*=*=*=*= initial.html =*=*=*=*
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(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