*=*=*=*= maketat0.html =*=*=*=*
PROGRAM maketat0

PROGRAM maketat0


      PROGRAM maketat0
c
c-------------------------------------------------------------
C Author : L. Fairhead
C Date   : 14/12/93
C Objet  : Construction des fichiers initiaux pour le nouveau
C          modele a partir de fichiers de climatologie. Les deux
C          grilles doivent etre regulieres
c-------------------------------------------------------------
c
      implicit none
#include "dimensions.h"
#include "paramet.h"
#include "control.h"
#include "logic.h"
#include "drsdef.h"
#include "comvert.h"
#include "comgeom2.h"
#include "comconst.h"

C Declarations pour le champ de depart
      INTEGER imdep, jmdep, lmdep
      INTEGER ibid, jbid, lbid
      parameter (ibid = 500,
     .           jbid = 500,
     .           lbid = 50)
      REAL champ(ibid*jbid), champ3d(ibid*jbid*lbid)
      REAL dlon(ibid), dlat(jbid), plev(lbid)

C Declarations pour le champ interpole 2D
      REAL champint(iim,jjp1)
      REAL champecrit(iip1,jjp1)
      REAL masque(iip1,jjp1)
      REAL psol(iip1,jjp1)
      REAL pext(iip1,jjp1)
      REAL phis(iip1,jjp1)

C Declarations pour le champ interpole 3D
      REAL champhor(iip1,jjp1,lbid)
      REAL champ3decr(iip1,jjp1,llm)
      REAL ucov(iip1,jjp1,llm)
      REAL vcov(iip1,jjm,llm)
      REAL temp(iip1,jjp1,llm)
      REAL q(iip1,jjp1,llm)

C Declarations pour l'inteprolation verticale
      REAL ax(lbid), ay(lbid)
      REAL bx(llm), by(llm)
      REAL yder(lbid)

C Declarations liees a la description des variables (setname)
      character varsource*120
      character varname*16, vartitle*80
      character varunits*40, vartype*8
      character vardate*8, vartime*8
      character dimsource*120
      character dimname*16, dimtitle*80
      character dimunits*40, dimtype*8
      character*80 drsname, filename

C Declaration DRS
      INTEGER aslun, setname, putdat, cllun, cluvdb
      INTEGER putvdim, inqlun, inqdict, getname, getcdim, getdat
      INTEGER setvdim, setdim
      INTEGER ierr
      INTEGER ibid
      INTEGER ecdicphy, ecdatphy, intdicphy, intdatphy
      parameter (ecdicphy = 10, ecdatphy = 11)
      parameter (intdicphy = 20, intdatphy = 21)
      INTEGER ecdicdyn, ecdatdyn, intdicdyn, intdatdyn
      parameter (ecdicdyn = 30, ecdatdyn = 31)
      parameter (intdicdyn = 40, intdatdyn = 41)

c Declarations pour les variables mises dans le fichier DRS
      INTEGER length
      parameter (length = 100)
      REAL tab_cntrl(length) ! tableau des parametres du run
      REAL dicfilver
      INTEGER nbas(iip1,jjp1), ntop(iip1,jjp1)
      REAL pacpr(iip1,jjp1)
      REAL pgz0f(iip1,jjp1)
      REAL r4
      parameter(r4 = IDRS_BYTES_PER_WORD)

      INTEGER icount
      INTEGER iix(200000), jjx(200000), ix(200000), jx(200000)
      REAL sx(200000),airnx(200000)
      INTEGER i, j, numdim, k, l
      INTEGER ind1, indlast
      INTEGER varnumb
      REAL polenord, polesud
      INTEGER size
      REAL rlatu(jjp1), rlonv(iip1)
      REAL phystep, daysec, dtvr
      INTEGER radpas
c Diverses variables locales
      REAL nivmer
      REAL pi
      REAL time
      logical ldrs
      INTEGER idayref
      REAL ttt, qs
      INTEGER nqllm, nbetat
#include "fxy_sin.h"

      pi = 4. * atan(1.)
      nivmer = 10.
      ldrs = .true.
      rad=6400000.
      omeg=4.*asin(1.)/(24.*3600.)
      g=9.8
      daysec=86400.

c    ######  P. Le Van  ( Modif le  21/11/95 )     #######
c     pour avoir R = 287.059 et CP = 1004.70 , comme dans  physiq.F

      mugaz = 28.9645
      kappa = 0.285716


C Initialisation de differents champs necessaires a l'etat intial
      open (8,file='run.def',form='formatted')
      call defrun(8)
      close(8)
Calcul de la discretisation verticale
      CALL iniconst
Calcul des coordonnees de la grille d'arrivee et des aires
      call inigeom
      dtvr = daysec/float(day_step)
      phystep = dtvr * float(iphysiq)
      radpas = nint (86400./phystep)
      do j = 1, jjp1
        do i = 1, iip1
          ntop(i,j) = 1
          nbas(i,j) = 1
          pacpr(i,j) = 0.
          pgz0f(i,j) = 1.
        enddo
      enddo

C Lecture fichier physique Centre Europeen
      write(6,'(a,$)')'Fichier physique a lire ? : '
      read (5,'(a)')drsname
      ierr = ASLUN(ecdicphy,drsname,ecdatphy,' ',IDRS_READ)
      if (ierr.ne.0) then
        write(6,*)' Pb d''ouverture du fichier a interpoler '
        write(6,*)' ierr = ', ierr
        call exit(1)
      endif
C Lecture de la date des donnees du fichier
      ierr = cluvdb()
      ierr = setname(' ','date',' ',' ',' ')
      ierr = inqdict(ecdicphy, IDRS_GETFIRSTVAR)
      size = r4
      ierr = getdat(ecdicphy, champ, size)
      idayref = int(champ(1))
      print *,'idayref', idayref


C Lecture fichier dynamique Centre Europeen
      write(6,'(a,$)')'Fichier dynamique a lire ? : '
      read (5,'(a)')drsname
      ierr = ASLUN(ecdicdyn,drsname,ecdatdyn,' ',IDRS_READ)
      if (ierr.ne.0) then
        write(6,*)' Pb d''ouverture du fichier a interpoler '
        write(6,*)' ierr = ', ierr
        call exit(1)
      endif
C Lecture de la date des donnees du fichier
      ierr = cluvdb()
      ierr = setname(' ','date',' ',' ',' ')
      ierr = inqdict(ecdicdyn, IDRS_GETFIRSTVAR)
      size = r4
      ierr = getdat(ecdicdyn, champ, size)
      if (int(champ(1)).ne.idayref) then
        write(6,*)' La date du fichier dynamique <> fichier physique'
        write(6,*) int(champ(1)), idayref
        write(6,*)' Je m''arrete'
        stop
      endif

C Ouverture fichier interpole
      write(6,'(a,$)')'Fichier de sortie physique? : '
      read (5,'(a)')drsname
      ierr = ASLUN(intdicphy,drsname,intdatphy,' ',IDRS_CREATE)
      if (ierr.ne.0) then
        write(6,*)' Pb d''ouverture du fichier interpole '
        write(6,*)' ierr = ', ierr
        call exit(1)
      endif

C Ouverture fichier interpole
      write(6,'(a,$)')'Fichier de sortie dynamique? : '
      read (5,'(a)')drsname
      ierr = ASLUN(intdicdyn,drsname,intdatdyn,' ',IDRS_CREATE)
      if (ierr.ne.0) then
        write(6,*)' Pb d''ouverture du fichier interpole '
        write(6,*)' ierr = ', ierr
        call exit(1)
      endif

c Traitement du fichier de conditions initiales pour la physique

c Lecture du nombre de variables dans le fichier DRS physique
      ierr = INQLUN (ecdicphy,filename,varnumb, dicfilver)
      if (ierr.ne.IDRS_SUCCESS) then
        print*,'  erreur inqlun',ierr
        call exit(1)
      endif
      write(6,*)' il y a ',varnumb,' variables dans le fichier'
      write(6,*)'    '

C boucle sur toutes les variables du fichier pour les interpoler
      ierr = CLUVDB()
      ierr = SETNAME(' ',' ',' ',' ',' ')
      ierr = INQDICT(ecdicphy, IDRS_GETFIRSTVAR)
C la 1ere variable est date, on ne l'interpole pas
      ierr = INQDICT(ecdicphy, IDRS_GETNEXTVAR)
      ierr = GETNAME(varsource,varname,vartitle,varunits,vardate,
     .               vartime,vartype, numdim)
      ierr = SETNAME(' ',varname,' ',' ',' ')
      ierr = GETCDIM(1, dimsource, dimname, dimtitle, dimunits,
     .               dimtype,ibid, dlon, imdep)
      ierr = GETCDIM(2, dimsource, dimname, dimtitle, dimunits,
     .               dimtype,jbid, dlat, jmdep)
      size = imdep * jmdep * r4
      ierr = GETDAT(ecdicphy, champ, size)

c interpolation
      call linearb(imdep, jmdep, dlon, dlat,
     .             iim, jjp1, rlonv, rlatu,
     .             iix, jjx, ix, jx, sx, airnx, icount)
      call linear(imdep, jmdep, iim, jjp1,
     .            champ, champint,
     .            icount, iix, jjx, ix, jx, sx, airnx)
      call gr_int_dyn(champint, champecrit, iim, jjp1)

c Ecriture DRS du tableau des parametres du run
      tab_cntrl(1) = phystep
      tab_cntrl(2) = radpas
      tab_cntrl(3) = float(idayref)
      ierr = CLUVDB()
      ierr = SETDIM(1,'index',' ',length,1.,float(length))
      ierr = SETNAME(varsource,'controle',
     .            'Tableau des parametres du run',' ',' ')
      ierr = PUTDAT(intdicphy,tab_cntrl)

C Ecriture des coordonnees dans le fichier interpole
      ierr = CLUVDB()
      ierr = SETNAME(' ','longitude',' Longitudes','degres',' ')
      ierr = PUTVDIM(intdicphy,iip1,rlonv,ind1,indlast)
      ierr = SETNAME(' ','latitude',' Latitudes','degres',' ')
      ierr = PUTVDIM(intdicphy,jjp1,rlatu,ind1,indlast)

C Ecriture des champs de nuages et de longueur de rugosite
      ierr = CLUVDB()
      ierr = SETVDIM(1,' ','longitude',' ',' ',rlonv(1), rlonv(iip1))
      ierr = SETVDIM(2,' ','latitude',' ',' ',rlatu(1), rlatu(jjp1))
      ierr = SETNAME(' ', 'ntop', ' ', ' ', ' ')
      ierr = PUTDAT(intdicphy, ntop)
      ierr = CLUVDB()
      ierr = SETVDIM(1,' ','longitude',' ',' ',rlonv(1), rlonv(iip1))
      ierr = SETVDIM(2,' ','latitude',' ',' ',rlatu(1), rlatu(jjp1))
      ierr = SETNAME(' ', 'nbas', ' ', ' ', ' ')
      ierr = PUTDAT(intdicphy, nbas)
      ierr = CLUVDB()
      ierr = SETVDIM(1,' ','longitude',' ',' ',rlonv(1), rlonv(iip1))
      ierr = SETVDIM(2,' ','latitude',' ',' ',rlatu(1), rlatu(jjp1))
      ierr = SETNAME(' ', 'pacpr', ' ', ' ', ' ')
      ierr = PUTDAT(intdicphy, pacpr)
      ierr = CLUVDB()
      ierr = SETVDIM(1,' ','longitude',' ',' ',rlonv(1), rlonv(iip1))
      ierr = SETVDIM(2,' ','latitude',' ',' ',rlatu(1), rlatu(jjp1))
      ierr = SETNAME(' ', 'pgz0f', ' ', ' ', ' ')
      ierr = PUTDAT(intdicphy, pgz0f)

C Ecriture du champ interpole
      ierr = CLUVDB()
      ierr = SETVDIM(1,' ','longitude',' ',' ',rlonv(1), rlonv(iip1))
      ierr = SETVDIM(2,' ','latitude',' ',' ',rlatu(1), rlatu(jjp1))
      ierr = SETNAME(varsource, varname, vartitle, varunits, vartype)
      ierr = PUTDAT(intdicphy, champecrit)

      do k = 3, varnumb
        ierr = INQDICT(ecdicphy, IDRS_GETNEXTVAR)
        ierr = GETNAME(varsource,varname,vartitle,varunits,vardate,
     .                 vartime,vartype, numdim)
        ierr = SETNAME(' ',varname,' ',' ',' ')
        ierr = GETCDIM(1, dimsource, dimname, dimtitle, dimunits,
     .               dimtype,ibid, dlon, imdep)
        ierr = GETCDIM(2, dimsource, dimname, dimtitle, dimunits,
     .               dimtype,jbid, dlat, jmdep)
        size = imdep * jmdep * r4
        ierr = GETDAT(ecdicphy, champ, size)

c interpolation
        call linearb(imdep, jmdep, dlon, dlat,
     .             iim, jjp1, rlonv, rlatu,
     .             iix, jjx, ix, jx, sx, airnx, icount)
        call linear(imdep, jmdep, iim, jjp1,
     .            champ, champint,
     .            icount, iix, jjx, ix, jx, sx, airnx)
        call gr_int_dyn(champint, champecrit, iim, jjp1)

c ecriture du fichier interpole
        ierr = CLUVDB()
        ierr = SETVDIM(1,' ','longitude',' ',' ',rlonv(1), rlonv(iip1))
        ierr = SETVDIM(2,' ','latitude',' ',' ',rlatu(1), rlatu(jjp1))
        ierr = SETNAME(varsource, varname, vartitle, varunits, vartype)
        ierr = PUTDAT(intdicphy, champecrit)
      enddo

c Traitement du fichier de conditions initiales pour la dynamique

C traitement du geopotentiel au sol
      ierr = cluvdb()
      ierr = SETNAME(' ','Z',' ',' ',' ')
      ierr = INQDICT(ecdicdyn, IDRS_GETFIRSTVAR)
      ierr = GETCDIM(1, dimsource, dimname, dimtitle, dimunits,
     .               dimtype,ibid, dlon, imdep)
      ierr = GETCDIM(2, dimsource, dimname, dimtitle, dimunits,
     .               dimtype,jbid, dlat, jmdep)
      size = imdep * jmdep * r4
      ierr = GETDAT(ecdicdyn, champ, size)
      call linearb(imdep, jmdep, dlon, dlat,
     .             iim, jjp1, rlonv, rlatu,
     .             iix, jjx, ix, jx, sx, airnx, icount)
      call linear(imdep, jmdep, iim, jjp1,
     .            champ, champint,
     .            icount, iix, jjx, ix, jx, sx, airnx)
      call gr_int_dyn(champint, phis, iim, jjp1)

C creation du masque ocean/continent et ecriture dans le fichier physique
      do j = 1, jjp1
        do i = 1, iip1
          masque(i, j) = 1.
          if (phis(i, j) .lt. nivmer) then
             masque(i, j) = 0.
             phis(i, j) = 0.
          endif
        enddo
      enddo
      ierr = CLUVDB()
      ierr = SETVDIM(1,' ','longitude',' ',' ',rlonv(1), rlonv(iip1))
      ierr = SETVDIM(2,' ','latitude',' ',' ',rlatu(1), rlatu(jjp1))
      varname = 'PITM'
      vartitle = 'Masque continent / ocean (1/0)'
      varunits = ' '
      vartype = ' '
      ierr = SETNAME(varsource, varname, vartitle, varunits, vartype)
      ierr = PUTDAT(intdicphy, masque)
      ierr = cllun(intdicphy)
      ierr = cllun(ecdicphy)

C Initialisation du fichier dynamique
      time = 0.
      call iniwrite(intdicdyn,ldrs, idayref, phis)

C traitement de la pression au sol
      ierr = cluvdb()
      ierr = SETNAME(' ','SP',' ',' ',' ')
      ierr = INQDICT(ecdicdyn, IDRS_GETFIRSTVAR)
      ierr = GETCDIM(1, dimsource, dimname, dimtitle, dimunits,
     .               dimtype,ibid, dlon, imdep)
      ierr = GETCDIM(2, dimsource, dimname, dimtitle, dimunits,
     .               dimtype,jbid, dlat, jmdep)
      size = imdep * jmdep * r4
      ierr = GETDAT(ecdicdyn, champ, size)
      call linearb(imdep, jmdep, dlon, dlat,
     .             iim, jjp1, rlonv, rlatu,
     .             iix, jjx, ix, jx, sx, airnx, icount)
      call linear(imdep, jmdep, iim, jjp1,
     .            champ, champint,
     .            icount, iix, jjx, ix, jx, sx, airnx)
      call gr_int_dyn(champint, psol, iim, jjp1)
Calcul pression extensive
      do j = 1, jjp1
        do i = 1, iip1
          pext(i, j) = psol(i, j) * aire(i, j)
c         pext(i, j) = psol(i, j)
        enddo
      enddo

C Traitement du vent zonal
      ierr = cluvdb()
      ierr = SETNAME(' ','U',' ',' ',' ')
      ierr = INQDICT(ecdicdyn, IDRS_GETFIRSTVAR)
      ierr = GETCDIM(1, dimsource, dimname, dimtitle, dimunits,
     .               dimtype,ibid, dlon, imdep)
      ierr = GETCDIM(2, dimsource, dimname, dimtitle, dimunits,
     .               dimtype,jbid, dlat, jmdep)
      ierr = GETCDIM(3, dimsource, dimname, dimtitle, dimunits,
     .               dimtype,lbid, plev, lmdep)
      size = imdep * jmdep * lmdep * r4
      ierr = GETDAT(ecdicdyn, champ3d, size)

C je suppose que les niveaux de pression sont numerotes de bas en haut:
c         psol = 1
c         haut = lmdep
c Interpolation horizontale
      do l = lmdep, 1, -1
        do j = 1, jmdep
          do i = 1, imdep
            champ(imdep*(j-1)+i) =
     .            champ3d(i + (j-1)*imdep + (l-1)*jmdep*imdep)
          enddo
        enddo
        call linearb(imdep, jmdep, dlon, dlat,
     .             iim, jjp1, rlonu, rlatu,
     .             iix, jjx, ix, jx, sx, airnx, icount)
        call linear(imdep, jmdep, iim, jjp1,
     .             champ, champint,
     .             icount, iix, jjx, ix, jx, sx, airnx)
        call gr_int_dyn(champint, champecrit, iim, jjp1)
        do j = 1, jjp1
          do i = 1, iip1
            champhor(i, j, (lmdep - l + 1)) = champecrit (i, j)
          enddo
        enddo
      enddo
c Interpolation verticale par spline
      do j=1,jjp1
        do  i=1,iim
          do l=1,lmdep
            ax(l)=plev(lmdep - l + 1)
          enddo
          do  l=1,llm
            bx(l)=sig_s(l)*psol(i, j)/ 100.
          enddo
          do  l=1,lmdep
            ay(l)=champhor(i,j,l)
          enddo
          call SPLINE(ax,ay,lmdep,1e30,1.e30,yder)
          do  l=1,llm
            call SPLINT(ax,ay,yder,lmdep,bx(l),by(l))
            champ3decr(i,j,l)=by(l)
          enddo
        enddo
        do l = 1, llm
          champ3decr(iip1, j, l) = champ3decr(1, j, l)
        enddo
      enddo
C Passage aux vents covariants
      do l = 1, llm
        do j=1,jjp1
          do i = 1, iip1
            ucov(i,j,l) = champ3decr(i,j,l) * cu (i, j)
c           ucov(i,j,l) = champ3decr(i,j,l)
          enddo
        enddo
      enddo

C Traitement du vent meridien
      ierr = cluvdb()
      ierr = SETNAME(' ','V',' ',' ',' ')
      ierr = INQDICT(ecdicdyn, IDRS_GETFIRSTVAR)
      ierr = GETCDIM(1, dimsource, dimname, dimtitle, dimunits,
     .               dimtype,ibid, dlon, imdep)
      ierr = GETCDIM(2, dimsource, dimname, dimtitle, dimunits,
     .               dimtype,jbid, dlat, jmdep)
      ierr = GETCDIM(3, dimsource, dimname, dimtitle, dimunits,
     .               dimtype,lbid, plev, lmdep)
      size = imdep * jmdep * lmdep * r4
      ierr = GETDAT(ecdicdyn, champ3d, size)

c Interpolation horizontale
      do l = lmdep, 1, -1
        do j = 1, jmdep
          do i = 1, imdep
            champ(imdep*(j-1)+i) =
     .            champ3d(i + (j-1)*imdep + (l-1)*jmdep*imdep)
          enddo
        enddo
        call linearb(imdep, jmdep, dlon, dlat,
     .             iim, jjm, rlonv, rlatv,
     .             iix, jjx, ix, jx, sx, airnx, icount)
        call linear(imdep, jmdep, iim, jjm,
     .             champ, champint,
     .             icount, iix, jjx, ix, jx, sx, airnx)
        call gr_int_dyn(champint, champecrit, iim, jjp1)
        do j = 1, jjm
          do i = 1, iip1
            champhor(i, j, (lmdep - l + 1)) = champecrit (i, j)
          enddo
        enddo
      enddo
c Interpolation verticale par spline
      do j=1,jjm
        do  i=1,iim
c         do l=1,lmdep
c           ax(l)=plev(lmdep - l + 1)
c         enddo
c         do  l=1,llm
c           bx(l)=sig_s(l)*psol(i, j)
c         enddo
          do  l=1,lmdep
            ay(l)=champhor(i,j,l)
          enddo
          call SPLINE(ax,ay,lmdep,1e30,1.e30,yder)
          do  l=1,llm
            call SPLINT(ax,ay,yder,lmdep,bx(l),by(l))
            vcov(i,j,l)=by(l)
          enddo
        enddo
        do l = 1, llm
          vcov(iip1, j, l) = vcov(1, j, l)
        enddo
      enddo
C Passage aux vents covariants
      do l = 1, llm
        do j=1,jjm
          do i = 1, iip1
            vcov(i,j,l) = vcov(i,j,l) * cv (i, j)
c           vcov(i,j,l) = vcov(i,j,l)
          enddo
        enddo
      enddo

C Traitement de l'enthalpie/temperature
      ierr = cluvdb()
      ierr = SETNAME(' ','T',' ',' ',' ')
      ierr = INQDICT(ecdicdyn, IDRS_GETFIRSTVAR)
      ierr = GETCDIM(1, dimsource, dimname, dimtitle, dimunits,
     .               dimtype,ibid, dlon, imdep)
      ierr = GETCDIM(2, dimsource, dimname, dimtitle, dimunits,
     .               dimtype,jbid, dlat, jmdep)
      ierr = GETCDIM(3, dimsource, dimname, dimtitle, dimunits,
     .               dimtype,lbid, plev, lmdep)
      size = imdep * jmdep * lmdep * r4
      ierr = GETDAT(ecdicdyn, champ3d, size)

C je suppose que les niveaux de pression sont numerotes de bas en haut:
c         psol = 1
c         haut = lmdep
c Interpolation horizontale
      do l = lmdep, 1, -1
        do j = 1, jmdep
          do i = 1, imdep
            champ(imdep*(j-1)+i) =
     .            champ3d(i + (j-1)*imdep + (l-1)*jmdep*imdep)
          enddo
        enddo
        call linearb(imdep, jmdep, dlon, dlat,
     .             iim, jjp1, rlonv, rlatu,
     .             iix, jjx, ix, jx, sx, airnx, icount)
        call linear(imdep, jmdep, iim, jjp1,
     .             champ, champint,
     .             icount, iix, jjx, ix, jx, sx, airnx)
        call gr_int_dyn(champint, champecrit, iim, jjp1)
        do j = 1, jjp1
          do i = 1, iip1
            champhor(i, j, (lmdep - l + 1)) = champecrit (i, j)
          enddo
        enddo
      enddo
c Interpolation verticale par spline
      do j=1,jjp1
        do  i=1,iim
c         do l=1,lmdep
c           ax(l)=plev(lmdep - l + 1)
c         enddo
c         do  l=1,llm
c           bx(l)=sig_s(l)*psol(i, j)
c         enddo
          do  l=1,lmdep
            ay(l)=champhor(i,j,l)
          enddo
          call SPLINE(ax,ay,lmdep,1e30,1.e30,yder)
          do  l=1,llm
            call SPLINT(ax,ay,yder,lmdep,bx(l),by(l))
            champ3decr(i,j,l)=by(l)
          enddo
        enddo
        do l = 1, llm
          champ3decr(iip1, j, l) = champ3decr(1, j, l)
        enddo
      enddo
C Passage a la temperature potentielle
      do l = 1, llm
        do j=1,jjp1
          do i = 1, iip1
c           temp(i,j,l) = champ3decr(i,j,l)
            temp(i,j,l) = champ3decr(i,j,l)*cpp/(s(l)*
     .                    (psol(i,j)/100.)**kappa)
          enddo
        enddo
      enddo

C Traitement de l'humidite
      ierr = cluvdb()
      ierr = SETNAME(' ','R',' ',' ',' ')
      ierr = INQDICT(ecdicdyn, IDRS_GETFIRSTVAR)
      ierr = GETCDIM(1, dimsource, dimname, dimtitle, dimunits,
     .               dimtype,ibid, dlon, imdep)
      ierr = GETCDIM(2, dimsource, dimname, dimtitle, dimunits,
     .               dimtype,jbid, dlat, jmdep)
      ierr = GETCDIM(3, dimsource, dimname, dimtitle, dimunits,
     .               dimtype,lbid, plev, lmdep)
      size = imdep * jmdep * lmdep * r4
      ierr = GETDAT(ecdicdyn, champ3d, size)

C je suppose que les niveaux de pression sont numerotes de bas en haut:
c         psol = 1
c         haut = lmdep
c Interpolation horizontale
      do l = lmdep, 1, -1
        do j = 1, jmdep
          do i = 1, imdep
            champ(imdep*(j-1)+i) =
     .            champ3d(i + (j-1)*imdep + (l-1)*jmdep*imdep)
          enddo
        enddo
        call linearb(imdep, jmdep, dlon, dlat,
     .             iim, jjp1, rlonv, rlatu,
     .             iix, jjx, ix, jx, sx, airnx, icount)
        call linear(imdep, jmdep, iim, jjp1,
     .             champ, champint,
     .             icount, iix, jjx, ix, jx, sx, airnx)
        call gr_int_dyn(champint, champecrit, iim, jjp1)
        do j = 1, jjp1
          do i = 1, iip1
            champhor(i, j, (lmdep - l + 1)) = champecrit (i, j)
          enddo
        enddo
      enddo
c Interpolation verticale par spline
      do j=1,jjp1
        do  i=1,iim
c         do l=1,lmdep
c           ax(l)=plev(lmdep - l + 1)
c         enddo
c         do  l=1,llm
c           bx(l)=sig_s(l)*psol(i, j)
c         enddo
          do  l=1,lmdep
            ay(l)=champhor(i,j,l)
          enddo
          call SPLINE(ax,ay,lmdep,1e30,1.e30,yder)
          do  l=1,llm
            call SPLINT(ax,ay,yder,lmdep,bx(l),by(l))
            champ3decr(i,j,l)=by(l)
          enddo
        enddo
        do l = 1, llm
          champ3decr(iip1, j, l) = champ3decr(1, j, l)
        enddo
      enddo
C Passage au rapport de melange
      do l = 1, llm
        do j=1,jjp1
          do i = 1, iip1
            ttt=temp(i,j,l)
            if(ttt.gt.233.) then
              qs=.622*10.**(2.07023-0.0032091*ttt-2484.896/ttt
     .+3.56654*log10(ttt))/ax(l)
            else
              qs=.622*10.**(23.8319-2948.964/ttt-5.028*log10(ttt)
     .-29810.16*exp(-.0699382*ttt)+25.21935*exp(-2999.924/ttt))/ax(l)
            endif
            q(i,j,l)=0.01  *champ3decr(i,j,l)*qs
          enddo
        enddo
      enddo
      nqllm = 1
      nbetat = 1
      call writedem(intdicdyn, nqllm, ldrs, time, vcov, ucov, temp,
     .              q, pext, phis, nbetat)

      ierr = cllun(ecdicdyn)
      ierr = cllun(intdicdyn)

      end