*=*=*=*= 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 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(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