*=*=*=*= 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 Modifie par F.Lott, les parametre de l'orographie
c a l'echelle sous maille sont stockes sur la base de donnee
c physique.
c-------------------------------------------------------------
c
c
      REAL SSUM
      INTEGER jour
c
      INTEGER ivap
      PARAMETER (ivap=1)
c
      REAL qsolmax
      PARAMETER (qsolmax=150.0)
c
#include "dimensions.h"
#include "paramet.h"
c-----------------------------------------------------------------------
      INTEGER KIDIA, KFDIA, KLON, KLEV
      PARAMETER (KIDIA=1,KFDIA=iim*(jjm-1)+2,
     .           KLON=KFDIA-KIDIA+1,KLEV=llm)
c-----------------------------------------------------------------------
#include "comconst.h"
#include "comvert.h"
#include "comgeom2.h"
#include "control.h"
#include "logic.h"
#include "ener.h"
#include "drsdef.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), tsol(iip1,jjp1), phisol(iip1,jjp1)

      REAL phisoll(iip1*jjp1),psoll(iip1*jjp1)
      EQUIVALENCE( phisol,phisoll), ( psol,psoll)

      REAL pext(iip1,jjp1)
      REAL phis(iip1,jjp1)

      REAL phiss(iip1*jjp1)
      EQUIVALENCE(phis,phiss)

c Ajout de quelques parametres orographiques (F. LOTT janvier 1995)
      REAL zmea(iip1,jjp1),zstd(iip1,jjp1)
      REAL zsigllm
      REAL zsig(iip1,jjp1),zgam(iip1,jjp1),zthe(iip1,jjp1)
      REAL rugsrel(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)

      REAL uucov(ip1jmp1,llm),vvcov(ip1jm,llm),ttemp(ip1jmp1,llm)
      REAL qq(ip1jmp1,llm,nqmx)
      EQUIVALENCE(ucov,uucov),(vcov,vvcov),(temp,ttemp),(q,qq)

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 = 66, dat = 67)

      INTEGER icount
      INTEGER iix(200000), jjx(200000), ix(200000), jx(200000)
      REAL sx(200000),airnx(200000)
      INTEGER numdim, k
      INTEGER ind1, indlast
      INTEGER varnumb
      REAL polenord, polesud
      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 co2_ppm
      REAL solaire
      INTEGER iflag_con
      REAL latfi(klon), lonfi(klon)
      REAL champhys(klon)
      REAL ts(klon)
      REAL deltat(klon)
      REAL ws(klon)
      REAL sn(klon)
      REAL radsol(klon)
      REAL rugmer(klon)
      REAL agesno(klon)
      INTEGER length
      PARAMETER (length=100)
      REAL tab_cntrl(length)

c
      REAL lmt_nat(klon)
      REAL lmt_sst(klon)
      REAL seuil_vap

      INTEGER nbetat,imin,imax,ISMIN,ISMAX

      logical startdrs

      EXTERNAL defrun_new,iniconst,geopot,inigeom,ISMIN,ISMAX
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
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

      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)
      co2_ppm = 330.0
      solaire = 1370.0
      iflag_con = 4
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,'ecphy',dat,' ',IDRS_READ)
      IF (ierr.ne.0) THEN
      WRITE(6,*)' Pb d''ouverture du fichier ecphy a interp.'
      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_int_dyn(champint, tsol, iim, jjp1)
      CALL gr_dyn_fi(1, iip1, jjp1, klon, champecrit, ts)

c
      PRINT*,'ts=', ts(ISMIN(klon,ts,1))
     .            , ts(ISMAX(klon,ts,1))
c
      ierr = CLUVDB()
      ierr = SETNAME(' ','CDSW',' ',' ',' ')
      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, ws)
c
      PRINT*,'ws=', ws(ISMIN(klon,ws,1))
     .            , ws(ISMAX(klon,ws,1))
c
      xfact = ws(ISMAX(klon,ws,1))
c
      DO ig = 1, klon
         ws(ig) = ws(ig) * qsolmax / xfact
      ENDDO
      PRINT*,'ws=', ws(ISMIN(klon,ws,1))
     .            , ws(ISMAX(klon,ws,1))
c
      ierr = CLLUN(dic)
c
      DO ig = 1, klon
         radsol(ig) = 0.0
         sn(ig)     = 0.0
         deltat(ig) = 0.0
         rugmer(ig) = 0.001
         agesno(ig) = 50.0
      ENDDO
c
cmod F.Lott (Janvier 1995)
c
c traitement des donnees orographiques deduites de la base USN:
c  phis, masque, zmea, zstd, zsig, zgam, zthe
c
c  Ouverture du fichier de l'USN
c
      ierr = ASLUN(dic,'relief',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
      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)
c
c  calcul des parametres de l'orographie a l'echelle sous maille
c
      CALL grid_noro(imdep, jmdep, dlon_msk, dlat_msk, champ_msk,
     .            iim, jjp1, rlonv, rlatu, zmea,zstd,zsig,zgam,zthe)
cccccccccc Z.X. Li cccccccccccccccccccccccccccccccccccccccccccc
      CALL rugsoro(imdep, jmdep, dlon_msk, dlat_msk, champ_msk,
     .             iip1, jjp1, rlonv, rlatu, rugsrel)
c
c     ....   P. Le Van  ( modif  le 14/11/96 )   ...
c
cccccccccc Z.X. Li cccccccccccccccccccccccccccccccccccccccccccc
c
c  calcul des masques et du geopotentiel au sol
c
      PRINT*, 'Traitement du relief pour fabriquer masque'
      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.
            zmea(i,j) = 0.
            zstd(i,j) = 0.
            zsig(i,j) = 0.
            zgam(i,j) = 0.
            zthe(i,j) = 0.
            rugsrel(i,j) = 0.0
cmodfin
         ENDIF
      ENDDO
      ENDDO
c
c  stockage sur le fichier Physique:
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
      tab_cntrl(3) = co2_ppm
      tab_cntrl(4) = solaire
      tab_cntrl(5) = iflag_con
      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(' ', 'TS', ' ', ' ', ' ')
      ierr = SETDIM(1, 'pts_physiques', ' ', klon, 1.0, FLOAT(klon))
      ierr = PUTDAT(dic, ts)
c
      ierr = CLUVDB()
      ierr = SETNAME(' ', 'QS', ' ', ' ', ' ')
      ierr = SETDIM(1, 'pts_physiques', ' ', klon, 1.0, FLOAT(klon))
      ierr = PUTDAT(dic, ws)
c
      ierr = CLUVDB()
      ierr = SETNAME(' ', 'SNOW', ' ', ' ', ' ')
      ierr = SETDIM(1, 'pts_physiques', ' ', klon, 1.0, FLOAT(klon))
      ierr = PUTDAT(dic, sn)
c
      ierr = CLUVDB()
      ierr = SETNAME(' ', 'RADS', ' ', ' ', ' ')
      ierr = SETDIM(1, 'pts_physiques', ' ', klon, 1.0, FLOAT(klon))
      ierr = PUTDAT(dic, radsol)
c
      ierr = CLUVDB()
      ierr = SETNAME(' ', 'DELTAT', ' ', ' ', ' ')
      ierr = SETDIM(1, 'pts_physiques', ' ', klon, 1.0, FLOAT(klon))
      ierr = PUTDAT(dic, deltat)
c
      ierr = CLUVDB()
      ierr = SETNAME(' ', 'RUGMER', ' ', ' ', ' ')
      ierr = SETDIM(1, 'pts_physiques', ' ', klon, 1.0, FLOAT(klon))
      ierr = PUTDAT(dic, rugmer)
c
      ierr = CLUVDB()
      ierr = SETNAME(' ', 'AGESNO', ' ', ' ', ' ')
      ierr = SETDIM(1, 'pts_physiques', ' ', klon, 1.0, FLOAT(klon))
      ierr = PUTDAT(dic, agesno)
c
      CALL gr_dyn_fi(1, iip1, jjp1, klon, zstd, champhys)
      ierr = CLUVDB()
      ierr = SETNAME(' ', 'ZSTD', ' ', ' ', ' ')
      ierr = SETDIM(1, 'pts_physiques', ' ', klon, 1.0, FLOAT(klon))
      ierr = PUTDAT(dic, champhys)

      CALL gr_dyn_fi(1, iip1, jjp1, klon, zsig, champhys)
      ierr = CLUVDB()
      ierr = SETNAME(' ', 'ZSIG', ' ', ' ', ' ')
      ierr = SETDIM(1, 'pts_physiques', ' ', klon, 1.0, FLOAT(klon))
      ierr = PUTDAT(dic, champhys)

      CALL gr_dyn_fi(1, iip1, jjp1, klon, zgam, champhys)
      ierr = CLUVDB()
      ierr = SETNAME(' ', 'ZGAM', ' ', ' ', ' ')
      ierr = SETDIM(1, 'pts_physiques', ' ', klon, 1.0, FLOAT(klon))
      ierr = PUTDAT(dic, champhys)


      CALL gr_dyn_fi(1, iip1, jjp1, klon, zthe, champhys)
      ierr = CLUVDB()
      ierr = SETNAME(' ', 'ZTHE', ' ', ' ', ' ')
      ierr = SETDIM(1, 'pts_physiques', ' ', klon, 1.0, FLOAT(klon))
      ierr = PUTDAT(dic, champhys)

      CALL gr_dyn_fi(1, iip1, jjp1, klon, rugsrel, champhys)
      ierr = CLUVDB()
      ierr = SETNAME(' ', 'RUGSREL', ' ', ' ', ' ')
      ierr = SETDIM(1, 'pts_physiques', ' ', klon, 1.0, FLOAT(klon))
      ierr = PUTDAT(dic, champhys)

      ierr = CLLUN(dic)
c
c
c  Calcul des champs dynamiques initiaux a partir de donnees issues
c  du centre Europeen.
c
      ierr = ASLUN(dic,'ecdyn',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
      print*,'Entrer le jour du debut de la simulation'
cc    print*,'1er juin =151  1er janvier=1 ...'
      READ(*,*) dayref
cccc  1er Juillet
cc      dayref=181
c
      ierr = CLUVDB()
      ierr = SETNAME(' ','Z',' ',' ',' ')
      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, phisol, iim, jjp1)
      imin = ISMIN(iip1*jjp1,phisol,1)
      imax = ISMAX(iip1*jjp1,phisol,1)
      PRINT*,'phisol = ', phisoll(imin),phisoll(imax)
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)
      DO j = 1, jjp1
      DO i = 1, iip1
         psol(i,j) = psol(i,j)*(1.0+(phisol(i,j)-phis(i,j))
     .                             /287.0/tsol(i,j))
         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
c       print*, 'vitesse u l=', l, plev(l)
c    .      , champecrit(ISMIN(iip1*jjp1,champecrit,1))
c    .      , 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
c       print*, 'vitesse v l=', l, plev(l)
c     .      , champint(ISMIN(iim*jjm,champint,1))
c     .      , 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
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)

c     print*, 'temperature lue='
c    .      , champ3d(ISMIN(imdep*jmdep*lmdep,champ3d,1))
c    .      , 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)
c    .      ,champecrit(ISMIN(iip1*jjp1,champecrit,1))
c    .      ,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
c     print*, 'temperature='
c    .      , champ3decr(ISMIN((iim+1)*(jjm+1)*llm,champ3decr,1))
c    .      , champ3decr(ISMAX((iim+1)*(jjm+1)*llm,champ3decr,1))
c
C Passage a l' enthalpie potentielle
c
      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)
c       print*, 'humidite rel. l=', l, plev(l)
c    .      , champecrit(ISMIN(iip1*jjp1,champecrit,1))
c    .      , 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
c
      seuil_vap = 1.0e-10
c
      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
            IF( q(i,j,l,ivap).LT.0. ) q(i,j,l,ivap) = seuil_vap
          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
      DO l =1,llm

      PRINT *, 'NIVEAU L ',l
      imin=ISMIN(ip1jmp1,uucov(1,l),1)
      imax=ISMAX(ip1jmp1,uucov(1,l),1)
      PRINT*, 'ucov = ', uucov(imin,l),uucov(imax,l)

      imin=ISMIN(ip1jm,vvcov(1,l),1)
      imax=ISMAX(ip1jm,vvcov(1,l),1)
      PRINT*, 'vcov = ', vvcov(imin,l),vvcov(imax,l)
c
      imin=ISMIN(ip1jmp1,ttemp(1,l),1)
      imax=ISMAX(ip1jmp1,ttemp(1,l),1)
      PRINT*, 'enth. = ', ttemp(imin,l),ttemp(imax,l)
c
      imin=ISMIN(ip1jmp1,qq(1,l,ivap),1)
      imax=ISMAX(ip1jmp1,qq(1,l,ivap),1)
      PRINT*, 'q = ', qq(imin,l,ivap),qq(imax,l,ivap)
c

      ENDDO

      imin=ISMIN(ip1jmp1,psoll(1),1)
      imax=ISMAX(ip1jmp1,psoll(1),1)
      PRINT*, 'psol = ', psoll(imin),psoll(imax)
c
      imin=ISMIN(ip1jmp1,phiss(1),1)
      imax=ISMAX(ip1jmp1,phiss(1),1)
      PRINT*, 'phis = ', phiss(imin),phiss(imax)
c
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 iniwrite(dic,startdrs,dayref,phis)
ccc      CALL writedem(dic,nqmx,startdrs,0.0,
ccc     .              vcov,ucov,temp,q,pext, phis,nbetat)
      CALL write_noro(dic,nqmx,startdrs,0.0,vcov,ucov,temp,q,pext,phis,
     .                zmea,zstd,zsig,zgam,zthe,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