*=*=*=*= initial.html =*=*=*=*
PROGRAM initial

PROGRAM initial


      PROGRAM initial
      IMPLICIT none
c-------------------------------------------------------------
C Author : L. Fairhead
C Date   : 27/01/94
C Objet  : Construction des etats initiaux pour le nouveau
C          modele a partir de fichiers de climatologie et du
C          Centre Europeen. Les deux
C          grilles doivent etre regulieres
c
c Modifie par z.x.li (le23mars1994)
c-------------------------------------------------------------
c
      REAL SSUM
      INTEGER ISMIN, ISMAX
      INTEGER jour
c
      INTEGER ivap
      PARAMETER (ivap=1)
c
      REAL wl_mx, ws_mx, wd_mx, wc_mx
      PARAMETER (wl_mx = 0.20)
      PARAMETER (ws_mx = 20.0)
      PARAMETER (wd_mx = 100.)
      PARAMETER (wc_mx = 20.0)
c
#include "dimensions.h"
#include "paramet.h"
#include "dimphy.h"
#include "comconst.h"
#include "comvert.h"
#include "comgeom2.h"
#include "control.h"
#include "logic.h"
#include "ener.h"
#include "drsdef.h"
#include "traceurs.h"

C Declarations pour le champ de depart
      INTEGER imdep, jmdep, lmdep
      INTEGER ibid, jbid, lbid
      PARAMETER (ibid = 400,
     .           jbid = 200,
     .           lbid = 30)
      REAL champ(ibid*jbid), champ3d(ibid*jbid*lbid)
      REAL dlon(ibid), dlat(jbid), plev(lbid)
c
      INTEGER ibid_msk, jbid_msk
      PARAMETER (ibid_msk=2200, jbid_msk=1100)
      REAL champ_msk(ibid_msk*jbid_msk)
      REAL dlon_msk(ibid_msk), dlat_msk(jbid_msk)

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,nqmx)

C Declarations pour l'inteprolation verticale
      REAL ax(lbid), ay(lbid)
      REAL bx, by
      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 dic, dat
      PARAMETER (dic = 10, dat = 11)

      INTEGER umdim, k
      INTEGER ind1, indlast
      INTEGER varnumb
      INTEGER size

c
      INTEGER i,j,l,ig, jr, iq
      INTEGER dayref
      REAL xpi, qsat, ttt, milibar, q_sat, xfact
      EXTERNAL q_sat
c
      REAL phystep
      INTEGER radpas
      REAL latfi(klon), lonfi(klon)
      INTEGER ntop(klon), nbas(klon)
      REAL rtop(klon), rbas(klon)
      REAL pacpr(klon)
      REAL pgz0f(klon)
      REAL deltat(klon)
      REAL pts(klon)
      REAL ptd(klon)
      REAL ptc(klon)
      REAL pwl(klon)
      REAL pws(klon)
      REAL pwd(klon)
      REAL pwc(klon)
      REAL psns(klon)
c
      INTEGER length
      PARAMETER (length=100)
      REAL tab_cntrl(length)

c
      REAL lmt_nat(klon)
      REAL lmt_sst(klon)

      INTEGER nbetat

      LOGICAL startdrs

      EXTERNAL defrun_new,iniconst,geopot,inigeom
c
#include "serre.h"
#include "fxyprim.h"
c-----------------------------------------------------------------------
      startdrs=.true.

c initialisations:
      CALL defrun_new( .TRUE. )

      rad  = 6400000.
      omeg = 4.*asin(1.)/(24.*3600.)
      g    = 9.8

ccc     mugaz=28.
ccc     kappa=.2857
c ... changement P. Le Van  ( 21/11/95 )        ...
c    pour avoir R = 287.059 et CP = 1004.70 , comme dans  physiq.F .

      mugaz = 28.9645
      kappa = 0.285716

      daysec=86400.
c
      dtvr    = daysec/float(day_step)

      CALL iniconst
      CALL inigeom
      PRINT*,'dtvr ',dtvr
c
c creer l'etat initial pour la physique
c
      phystep = dtvr * FLOAT(iphysiq)
      radpas = NINT (86400./phystep/4.0)
c
      latfi(1)=ASIN(1.0)
      DO j = 2, jjm
      DO i = 1, iim
            latfi((j-2)*iim+1+i)=fy(FLOAT(j))
      ENDDO
      ENDDO
      latfi(klon)=-ASIN(1.0)
c
      lonfi(1) = 0.0
      DO j = 2, jjm
      DO i = 1, iim
         lonfi((j-2)*iim+1+i) = fx(FLOAT(i))
      ENDDO
      ENDDO
      lonfi(klon) = 0.0
c
      xpi = 2.0 * ASIN(1.0)
      DO ig = 1, klon
         latfi(ig) = latfi(ig) * 180.0 / xpi
         lonfi(ig) = lonfi(ig) * 180.0 / xpi
      ENDDO
c
c
      ierr = ASLUN(dic,'ecphy88070112',dat,' ',IDRS_READ)
      if (ierr.ne.0) then
        WRITE(6,*)' Pb d''ouverture du fichier a interpoler '
        WRITE(6,*)' ierr = ', ierr
        CALL ABORT
      endif
c
      ierr = CLUVDB()
      ierr = SETNAME(' ','ST',' ',' ',' ')
      ierr = INQDICT(dic, 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 * IDRS_BYTES_PER_WORD
      ierr = GETDAT(dic, champ, size)
      CALL grille_m(imdep, jmdep, dlon, dlat, champ,
     .             iim, jjp1, rlonv, rlatu, champint)
      CALL gr_int_dyn(champint, champecrit, iim, jjp1)
      CALL gr_dyn_fi(1, iip1, jjp1, klon, champecrit, pts)
      PRINT*,'pts=', pts(ISMIN(klon,pts,1)), pts(ISMAX(klon,pts,1))
c
      ierr = CLUVDB()
      ierr = SETNAME(' ','DST',' ',' ',' ')
      ierr = INQDICT(dic, 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 * IDRS_BYTES_PER_WORD
      ierr = GETDAT(dic, champ, size)
      CALL grille_m(imdep, jmdep, dlon, dlat, champ,
     .             iim, jjp1, rlonv, rlatu, champint)
      CALL gr_int_dyn(champint, champecrit, iim, jjp1)
      CALL gr_dyn_fi(1, iip1, jjp1, klon, champecrit, ptd)
      PRINT*,'ptd=', ptd(ISMIN(klon,ptd,1)), ptd(ISMAX(klon,ptd,1))
c
      ierr = CLUVDB()
      ierr = SETNAME(' ','CDST',' ',' ',' ')
      ierr = INQDICT(dic, 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 * IDRS_BYTES_PER_WORD
      ierr = GETDAT(dic, champ, size)
      CALL grille_m(imdep, jmdep, dlon, dlat, champ,
     .             iim, jjp1, rlonv, rlatu, champint)
      CALL gr_int_dyn(champint, champecrit, iim, jjp1)
      CALL gr_dyn_fi(1, iip1, jjp1, klon, champecrit, ptc)
      PRINT*,'ptc=', ptc(ISMIN(klon,ptc,1)), ptc(ISMAX(klon,ptc,1))
c
      ierr = CLUVDB()
      ierr = SETNAME(' ','SRC',' ',' ',' ')
      ierr = INQDICT(dic, 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 * IDRS_BYTES_PER_WORD
      ierr = GETDAT(dic, champ, size)
      CALL grille_m(imdep, jmdep, dlon, dlat, champ,
     .             iim, jjp1, rlonv, rlatu, champint)
      CALL gr_int_dyn(champint, champecrit, iim, jjp1)
      CALL gr_dyn_fi(1, iip1, jjp1, klon, champecrit, pwl)
      PRINT*,'pwl=', pwl(ISMIN(klon,pwl,1)), pwl(ISMAX(klon,pwl,1))
      xfact = wl_mx / pwl(ISMAX(klon,pwl,1))
      DO i = 1, klon
         pwl(i) = pwl(i) * xfact
      ENDDO
      PRINT*,'pwl=', pwl(ISMIN(klon,pwl,1)), pwl(ISMAX(klon,pwl,1))
c
      ierr = CLUVDB()
      ierr = SETNAME(' ','SSW',' ',' ',' ')
      ierr = INQDICT(dic, 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 * IDRS_BYTES_PER_WORD
      ierr = GETDAT(dic, champ, size)
      CALL grille_m(imdep, jmdep, dlon, dlat, champ,
     .             iim, jjp1, rlonv, rlatu, champint)
      CALL gr_int_dyn(champint, champecrit, iim, jjp1)
      CALL gr_dyn_fi(1, iip1, jjp1, klon, champecrit, pws)
      PRINT*,'pws=', pws(ISMIN(klon,pws,1)), pws(ISMAX(klon,pws,1))
      xfact = ws_mx / pws(ISMAX(klon,pws,1))
      DO i = 1, klon
         pws(i) = pws(i) * xfact
      ENDDO
      PRINT*,'pws=', pws(ISMIN(klon,pws,1)), pws(ISMAX(klon,pws,1))
c
      ierr = CLUVDB()
      ierr = SETNAME(' ','DSW',' ',' ',' ')
      ierr = INQDICT(dic, 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 * IDRS_BYTES_PER_WORD
      ierr = GETDAT(dic, champ, size)
      CALL grille_m(imdep, jmdep, dlon, dlat, champ,
     .             iim, jjp1, rlonv, rlatu, champint)
      CALL gr_int_dyn(champint, champecrit, iim, jjp1)
      CALL gr_dyn_fi(1, iip1, jjp1, klon, champecrit, pwd)
      PRINT*,'pwd=', pwd(ISMIN(klon,pwd,1)), pwd(ISMAX(klon,pwd,1))
      xfact = wd_mx / pwd(ISMAX(klon,pwd,1))
      DO i = 1, klon
         pwd(i) = pwd(i) * xfact
      ENDDO
      PRINT*,'pwd=', pwd(ISMIN(klon,pwd,1)), pwd(ISMAX(klon,pwd,1))
c
      ierr = CLUVDB()
      ierr = SETNAME(' ','CDSW',' ',' ',' ')
      ierr = INQDICT(dic, 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 * IDRS_BYTES_PER_WORD
      ierr = GETDAT(dic, champ, size)
      CALL grille_m(imdep, jmdep, dlon, dlat, champ,
     .             iim, jjp1, rlonv, rlatu, champint)
      CALL gr_int_dyn(champint, champecrit, iim, jjp1)
      CALL gr_dyn_fi(1, iip1, jjp1, klon, champecrit, pwc)
      PRINT*,'pwc=', pwc(ISMIN(klon,pwc,1)), pwc(ISMAX(klon,pwc,1))
      xfact = wc_mx / pwc(ISMAX(klon,pwc,1))
      DO i = 1, klon
         pwc(i) = pwc(i) * xfact
      ENDDO
      PRINT*,'pwc=', pwc(ISMIN(klon,pwc,1)), pwc(ISMAX(klon,pwc,1))
c
      ierr = CLLUN(dic)
c
      DO ig = 1, klon
         pacpr(ig) = 0.0
         rtop(ig) = 1.0
         rbas(ig) = 1.0
         psns(ig) = 0.0
         deltat(ig) = 0.0
      ENDDO
c
c
      ierr = ASLUN(dic,'startphy.dic',
     .             dat,'startphy.dat',IDRS_CREATE)
      IF (ierr.ne.0) THEN
        WRITE(6,*)' Pb d''ouverture du fichier'
        WRITE(6,*)' ierr = ', ierr
        CALL ABORT
      ENDIF
c
      DO ierr = 1, length
         tab_cntrl(ierr) = 0.0
      ENDDO
      tab_cntrl(1) = phystep
      tab_cntrl(2) = radpas
      ierr = CLUVDB()
      ierr = SETDIM(1,'index',' ',length,1.,float(length))
      ierr = SETNAME(' ','controle', 'parametres controle',' ',' ')
      ierr = PUTDAT(dic, tab_cntrl)
c
      ierr = CLUVDB()
      ierr = SETNAME(' ','longitude', 'Longitudes','degres',' ')
      ierr = SETDIM(1, 'pts_physiques', ' ', klon, 1.0, FLOAT(klon))
      ierr = PUTDAT(dic, lonfi)
c
      ierr = CLUVDB()
      ierr = SETNAME(' ','latitude', 'Latitudes','degres',' ')
      ierr = SETDIM(1, 'pts_physiques', ' ', klon, 1.0, FLOAT(klon))
      ierr = PUTDAT(dic, latfi)
c
      ierr = CLUVDB()
      ierr = SETNAME(' ','RTOP',' ',' ',' ')
      ierr = SETDIM(1, 'pts_physiques', ' ', klon, 1.0, FLOAT(klon))
      ierr = PUTDAT(dic, rtop)
c
      ierr = CLUVDB()
      ierr = SETNAME(' ','RBAS',' ',' ',' ')
      ierr = SETDIM(1, 'pts_physiques', ' ', klon, 1.0, FLOAT(klon))
      ierr = PUTDAT(dic, rbas)
c
      ierr = CLUVDB()
      ierr = SETNAME(' ','PACPR',' ',' ',' ')
      ierr = SETDIM(1, 'pts_physiques', ' ', klon, 1.0, FLOAT(klon))
      ierr = PUTDAT(dic, pacpr, klon*IDRS_BYTES_PER_WORD)
c
      ierr = CLUVDB()
      ierr = SETNAME(' ','PTS',' ',' ',' ')
      ierr = SETDIM(1, 'pts_physiques', ' ', klon, 1.0, FLOAT(klon))
      ierr = PUTDAT(dic, pts, klon*IDRS_BYTES_PER_WORD)
c
      ierr = CLUVDB()
      ierr = SETNAME(' ','PTD',' ',' ',' ')
      ierr = SETDIM(1, 'pts_physiques', ' ', klon, 1.0, FLOAT(klon))
      ierr = PUTDAT(dic, ptd, klon*IDRS_BYTES_PER_WORD)
c
      ierr = CLUVDB()
      ierr = SETNAME(' ','PTC',' ',' ',' ')
      ierr = SETDIM(1, 'pts_physiques', ' ', klon, 1.0, FLOAT(klon))
      ierr = PUTDAT(dic, ptc, klon*IDRS_BYTES_PER_WORD)
c
      ierr = CLUVDB()
      ierr = SETNAME(' ','PWL',' ',' ',' ')
      ierr = SETDIM(1, 'pts_physiques', ' ', klon, 1.0, FLOAT(klon))
      ierr = PUTDAT(dic, pwl, klon*IDRS_BYTES_PER_WORD)
c
      ierr = CLUVDB()
      ierr = SETNAME(' ','PWS',' ',' ',' ')
      ierr = SETDIM(1, 'pts_physiques', ' ', klon, 1.0, FLOAT(klon))
      ierr = PUTDAT(dic, pws, klon*IDRS_BYTES_PER_WORD)
c
      ierr = CLUVDB()
      ierr = SETNAME(' ','PWD',' ',' ',' ')
      ierr = SETDIM(1, 'pts_physiques', ' ', klon, 1.0, FLOAT(klon))
      ierr = PUTDAT(dic, pwd, klon*IDRS_BYTES_PER_WORD)
c
      ierr = CLUVDB()
      ierr = SETNAME(' ','PWC',' ',' ',' ')
      ierr = SETDIM(1, 'pts_physiques', ' ', klon, 1.0, FLOAT(klon))
      ierr = PUTDAT(dic, pwc, klon*IDRS_BYTES_PER_WORD)
c
      ierr = CLUVDB()
      ierr = SETNAME(' ','PSNS',' ',' ',' ')
      ierr = SETDIM(1, 'pts_physiques', ' ', klon, 1.0, FLOAT(klon))
      ierr = PUTDAT(dic, psns, klon*IDRS_BYTES_PER_WORD)
c
      ierr = CLUVDB()
      ierr = SETNAME(' ','DELTAT',' ',' ',' ')
      ierr = SETDIM(1, 'pts_physiques', ' ', klon, 1.0, FLOAT(klon))
      ierr = PUTDAT(dic, deltat, klon*IDRS_BYTES_PER_WORD)
c
      ierr = CLLUN(dic)
c
      ierr = ASLUN(dic,'relief_nasa',dat,' ',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
C traitement du geopotentiel au sol
c
      PRINT*, 'Traitement du relief pour fabriquer masque'
      ierr = CLUVDB()
      ierr = SETNAME(' ','RELIEF',' ',' ',' ')
      ierr = INQDICT(dic, IDRS_GETFIRSTVAR)
      ierr = GETCDIM(1, dimsource, dimname, dimtitle, dimunits,
     .               dimtype,ibid_msk, dlon_msk, imdep)
      ierr = GETCDIM(2, dimsource, dimname, dimtitle, dimunits,
     .               dimtype,jbid_msk, dlat_msk, jmdep)
      ierr=GETDAT(dic,champ_msk,imdep*jmdep*IDRS_BYTES_PER_WORD)
      ierr = CLLUN(dic)
      CALL grille_m(imdep, jmdep, dlon_msk, dlat_msk, champ_msk,
     .             iim, jjp1, rlonv, rlatu, champint)
      CALL gr_int_dyn(champint, phis, iim, jjp1)
      CALL mask_c_o(imdep, jmdep, dlon_msk, dlat_msk, champ_msk,
     .             iim, jjp1, rlonv, rlatu, champint)
      CALL gr_int_dyn(champint, masque, iim, jjp1)
c
      DO j=1,jjp1
      DO i=1,iip1
         phis(i,j) = phis(i,j) * 9.81
         if (NINT(masque(i,j)) .EQ. 0) then
            phis(i,j) = 0.
         endif
      ENDDO
      ENDDO
c
      ierr = ASLUN(dic,'ecdyn88070112',dat,' ',IDRS_READ)
      if (ierr.ne.0) then
        WRITE(6,*)' Pb d''ouverture du fichier a interpoler '
        WRITE(6,*)' ierr = ', ierr
        CALL ABORT
      endif
c
      PRINT*,'saison ',saison
      dayref = 181
c
      ierr = CLUVDB()
      ierr = SETNAME(' ','SP',' ',' ',' ')
      ierr = INQDICT(dic, 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 * IDRS_BYTES_PER_WORD
      ierr = GETDAT(dic, champ, size)
      CALL grille_m(imdep, jmdep, dlon, dlat, champ,
     .             iim, jjp1, rlonv, rlatu, champint)
      CALL gr_int_dyn(champint, psol, iim, jjp1)
      PRINT*,'psol=', psol(ISMIN(iip1*jjp1,psol,1))
     .              , psol(ISMAX(iip1*jjp1,psol,1))
      DO j = 1, jjp1
      DO i = 1, iip1
         pext(i, j) = psol(i, j) * aire(i, j)
      ENDDO
      ENDDO
c
      ierr = cluvdb()
      ierr = SETNAME(' ','U',' ',' ',' ')
      ierr = INQDICT(dic, 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 * IDRS_BYTES_PER_WORD
      ierr = GETDAT(dic, 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 = 1, lmdep
        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 grille_m(imdep, jmdep, dlon, dlat, champ,
     .             iim, jjp1, rlonu, rlatu, champint)
       CALL gr_int_dyn(champint, champecrit, iim, jjp1)
c
        print*, 'vitesse u l=', l, plev(l)
     .      , champecrit(ISMIN(iip1*jjp1,champecrit,1))
     .      , champecrit(ISMAX(iip1*jjp1,champecrit,1))
        DO j = 1, jjp1
          DO i = 1, iip1
            champhor(i, j, l) = 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) * 100.0
            ay(l)=champhor(i,j,lmdep-l+1)
          ENDDO
          CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder)
          DO  l=1,llm
            bx=sig_s(llm-l+1)*psol(i,j)
            CALL SPLINT(ax,ay,yder,lmdep,bx,by)
            champ3decr(i,j,llm-l+1)=by
          ENDDO
        ENDDO
        DO l = 1, llm
          champ3decr(iip1, j, llm-l+1) = champ3decr(1, j, llm-l+1)
        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)
          ENDDO
        ENDDO
      ENDDO
C Traitement du vent meridien
      ierr = cluvdb()
      ierr = SETNAME(' ','V',' ',' ',' ')
      ierr = INQDICT(dic, 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 * IDRS_BYTES_PER_WORD
      ierr = GETDAT(dic, champ3d, size)

c Interpolation horizontale
      DO l = 1, lmdep
        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 grille_m(imdep, jmdep, dlon, dlat, champ,
     .             iim, jjm, rlonv, rlatv, champint)
        CALL gr_int_dyn(champint, champecrit, iim, jjm)
c
c     Ajout  P.Le Van    16/03/95  ..
c
        print*, 'vitesse v l=', l, plev(l)
     .      , champint(ISMIN(iim*jjm,champint,1))
     .      , champint(ISMAX(iim*jjm,champint,1))
        DO j = 1, jjm
          DO i = 1, iim
            champhor(i, j, l) = champecrit (i, j)
          ENDDO
        ENDDO
      ENDDO
c Interpolation verticale par spline
      DO j=1,jjm
        DO  i=1,iim
          DO l=1,lmdep
            ax(l)=plev(lmdep-l+1) * 100.0
            ay(l)=champhor(i,j,lmdep-l+1)
          ENDDO
          CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder)
          DO  l=1,llm
            bx=sig_s(llm-l+1)*psol(i,j)
            CALL SPLINT(ax,ay,yder,lmdep,bx,by)
            vcov(i,j,llm-l+1)=by
          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)
          ENDDO
        ENDDO
      ENDDO
C Traitement de l'enthalpie/temperature
      ierr = cluvdb()
      ierr = SETNAME(' ','T',' ',' ',' ')
      ierr = INQDICT(dic, 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 * IDRS_BYTES_PER_WORD
      ierr = GETDAT(dic, champ3d, size)

      print*, 'temperature lue='
     .      , champ3d(ISMIN(imdep*jmdep*lmdep,champ3d,1))
     .      , champ3d(ISMAX(imdep*jmdep*lmdep,champ3d,1))

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 = 1, lmdep
        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 grille_m(imdep, jmdep, dlon, dlat, champ,
     .             iim, jjp1, rlonv, rlatu, champint)
        CALL gr_int_dyn(champint, champecrit, iim, jjp1)
        print*, 'temperature l=', l, plev(l)
     .      , champecrit(ISMIN(iip1*jjp1,champecrit,1))
     .      , champecrit(ISMAX(iip1*jjp1,champecrit,1))
        DO j = 1, jjp1
          DO i = 1, iip1
            champhor(i, j, l) = 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) * 100.0
            ay(l)=champhor(i,j,lmdep-l+1)
          ENDDO
          CALL SPLINE(ax,ay,lmdep,1e30,1.e30,yder)
          DO  l=1,llm
            bx=sig_s(llm-l+1)*psol(i,j)
            CALL SPLINT(ax,ay,yder,lmdep,bx,by)
            champ3decr(i,j,llm-l+1)=by
          ENDDO
        ENDDO
        DO l = 1, llm
          champ3decr(iip1, j, l) = champ3decr(1, j, l)
        ENDDO
      ENDDO
      print*, 'temperature='
     .      , champ3decr(ISMIN((iim+1)*(jjm+1)*llm,champ3decr,1))
     .      , champ3decr(ISMAX((iim+1)*(jjm+1)*llm,champ3decr,1))
C Passage a la temperature potentielle
      DO l = 1, llm
        DO j=1,jjp1
          DO i = 1, iip1
            temp(i,j,l) = champ3decr(i,j,l)*cpp/(s(l)*
     .                    (psol(i,j))**kappa)
          ENDDO
        ENDDO
      ENDDO



      DO iq = 1, nqmx
      DO l = 1, llm
        DO j=1,jjp1
          DO i = 1, iip1
            q(i,j,l,iq)=0.0
          ENDDO
        ENDDO
      ENDDO
      ENDDO


C Traitement de l'humidite
      ierr = cluvdb()
      ierr = SETNAME(' ','R',' ',' ',' ')
      ierr = INQDICT(dic, 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 * IDRS_BYTES_PER_WORD
      ierr = GETDAT(dic, 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 = 1, lmdep
        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 grille_m(imdep, jmdep, dlon, dlat, champ,
     .             iim, jjp1, rlonv, rlatu, champint)
        CALL gr_int_dyn(champint, champecrit, iim, jjp1)
        print*, 'humidite rel. l=', l, plev(l)
     .      , champecrit(ISMIN(iip1*jjp1,champecrit,1))
     .      , champecrit(ISMAX(iip1*jjp1,champecrit,1))
        DO j = 1, jjp1
          DO i = 1, iip1
            champhor(i, j, l) = 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) * 100.0
            ay(l) = champhor(i,j,lmdep-l+1)
          ENDDO
          CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder)
          DO  l=1,llm
            bx=sig_s(llm-l+1)*psol(i,j)
            CALL SPLINT(ax,ay,yder,lmdep,bx,by)
            champ3decr(i,j,llm-l+1)=by
          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) * s(l) * psol(i,j)**kappa / cpp
            milibar = psol(i,j) * sig_s(l) / 100.0
            qsat = q_sat(ttt,milibar)
            q(i,j,l,ivap)=0.01*champ3decr(i,j,l)*qsat
          ENDDO
        ENDDO
      ENDDO

c
c
      ierr = CLLUN(dic)
c
c-----------------------------------------------------------------------
c   ecriture du fichier de demarrage:
c   --------------------------------
c
      etot0=0.
      ptot0=0.
      stot0=0.
      ztot0=0.
      ang0=0.

      daysec=86400.
c-----------------------------------------------------------------------
c
      PRINT*, 'ucov=', ucov(ISMIN((iim+1)*(jjm+1)*llm,ucov,1))
     .            , ucov(ISMAX((iim+1)*(jjm+1)*llm,ucov,1))
c
      PRINT*, 'vcov=', vcov(ISMIN((iim+1)*(jjm)*llm,vcov,1))
     .            , vcov(ISMAX((iim+1)*(jjm)*llm,vcov,1))
c
      PRINT*, 'temp=', temp(ISMIN((iim+1)*(jjm+1)*llm,temp,1))
     .            , temp(ISMAX((iim+1)*(jjm+1)*llm,temp,1))
c
      PRINT*, 'q=', q(ISMIN((iim+1)*(jjm+1)*llm,q(1,1,1,ivap),1))
     .            , q(ISMAX((iim+1)*(jjm+1)*llm,q(1,1,1,ivap),1))
c
      PRINT*, 'psol=', psol(ISMIN((iim+1)*(jjm+1),psol,1))
     .             , psol(ISMAX((iim+1)*(jjm+1),psol,1))
c
      PRINT*, 'phis=', phis(ISMIN((iim+1)*(jjm+1),phis,1))
     .               , phis(ISMAX((iim+1)*(jjm+1),phis,1))
c-----------------------------------------------------------------------
      IF(startdrs) THEN
         ierr = aslun(dic,'start.dic',
     .             dat,'start.dat',IDRS_CREATE)
      ELSE
         OPEN(dic,file='start',form='unformatted',status='new',
     .   iostat=ierr)
      ENDIF
      IF (ierr.NE.0) THEN
        WRITE(6,*)' Pb d''ouverture du fichier restart'
        WRITE(6,*)' ierr = ', ierr
        CALL exit(1)
      ENDIF
      CALL iniecriba(dic,startdrs,dayref,phis)
      CALL writedem(dic,startdrs,0.0,
     .              vcov,ucov,temp,q,pext, phis,nbetat)
      ierr = cllun(dic)

      END
*=*=*=*= q_sat.html =*=*=*=*
FUNCTION q_sat

FUNCTION q_sat


      FUNCTION q_sat(kelvin, milibar)
c
      IMPLICIT none
c======================================================================
c Autheur(s): Z.X. Li (LMD/CNRS)
c Objet: calculer la vapeur d'eau saturante (formule Centre Euro.)
c======================================================================
c Arguments:
c kelvin---input-R: temperature en Kelvin
c milibar--input-R: pression en mb
c
c q_sat----output-R: vapeur d'eau saturante en kg/kg
c======================================================================
c
      REAL q_sat, kelvin, milibar
c
      REAL r2es
      parameter (r2es=611.14 *18.0153/28.9644)
c
      REAL r3les, r3ies, r3es
      parameter (R3LES=17.269)
      parameter (R3IES=21.875)
c
      REAL r4les, r4ies, r4es
      parameter (R4LES=35.86)
      parameter (R4IES=7.66)
c
      REAL rtt
      parameter (rtt=273.16)
c
      REAL retv
      parameter (retv=28.9644/18.0153 - 1.0)
c
      REAL zqsat
      REAL temp, pres
C     ------------------------------------------------------------------
c
c
      temp = kelvin
      pres = milibar * 100.0
c
      if (temp .LE. rtt) then
         r3es = r3ies
         r4es = r4ies
      else
         r3es = r3les
         r4es = r4les
      endif
c
      zqsat=r2es/pres * EXP ( r3es*(temp-rtt) / (temp-r4es) )
      zqsat=MIN(0.5,ZQSAT)
      zqsat=zqsat/(1.-retv  *zqsat)
c
      q_sat = zqsat
c
      return
      end