c=======================================================================
*=*=*=*= lect_start_archive.html =*=*=*=*
SUBROUTINE lect_start_archive(date,tsurf,tsoil,emis,q2, . t,ucov,vcov,pext,co2ice,h,phisold_newgrid) c======================================================================= c c c Auteur: 05/1997 c ------ c c c Objet: Lecture des variables d'un fichier "start_archive" c Necessite d'avoir auparavant lu l'entete c c c ATTENTION!!!! c entrer les valeurs exactes de la grille du fichier "start_archive": c en affectant imold, jmold, lmold dans lect_start_archive.F c puis compiler avec la resolution attendue c c c======================================================================= implicit none #include "dimensions.h" #include "../phymars/dimphys.h" #include "../phymars/surfdat.h" #include "../phymars/dimradmars.h" #include "../phymars/yomaer.h" #include "../phymars/planete.h" #include "paramet.h" #include "comconst.h" #include "comvert.h" #include "comgeom2.h" #include "control.h" #include "logic.h" #include "drsdef.h" #include "description.h" #include "ener.h" #include "temps.h" #include "lmdstd.h" c======================================================================= c Declarations c======================================================================= c Variables dimension du fichier "ini" c------------------------------------ INTEGER imold,jmold,lmold c ************************** A REGLER !!!! *************************** c Dimension de l'ancienne grille : PARAMETER (imold=64,jmold=48,lmold=25) c PARAMETER (imold=32,jmold=24,lmold=25) c ********************************************************************** c Fonctions DRS: c-------------- INTEGER cluvdb,setname,getdat,getslab,inqdict,getcdim c et autres: c---------- INTEGER lnblnk,drsread EXTERNAL lnblnk,drsread c Variables pour les lectures DRS des fichiers "ini" c-------------------------------------------------- INTEGER size INTEGER r4 parameter (r4 = IDRS_BYTES_PER_WORD) INTEGER length parameter (length = 100) INTEGER tab0 INTEGER NB_ETAT,NB_ETATMAX parameter (NB_ETATMAX = 100) INTEGER isoil,ig CHARACTER*2 str2 REAL dimfirst(4) ! tableau contenant les 1ers elements ! des dimensions REAL dimlast(4) ! tableau contenant les derniers elements ! des dimensions REAL dimcycl(4) ! tableau contenant les periodes ! des dimensions CHARACTER*120 dimsource CHARACTER*16 dimname CHARACTER*80 dimtitle CHARACTER*40 dimunits INTEGER dimtype INTEGER dimord(4) ! tableau contenant l'ordre data dimord /1,2,3,4/ ! de sortie des dimensions INTEGER vardim(4) REAL date INTEGER memoire c Variable histoire c------------------ REAL vcov(iip1,jjm,llm),ucov(iip1,jjp1,llm) ! vents covariants REAL h(iip1,jjp1,llm),pext(iip1,jjp1) c autre variables dynamique nouvelle grille c------------------------------------------ c!-*- integer klatdat,klongdat PARAMETER (klatdat=180,klongdat=360) c Physique sur grille scalaire c---------------------------- c variable physique c------------------ REAL tsurf(ngridmx),tsoil(ngridmx,nsoilmx),co2ice(ngridmx) REAL emis(ngridmx) REAL q2(ngridmx,nlayermx+1) c REAL phisfi(ngridmx) INTEGER i,j,l INTEGER unit c REAL year_day,periheli,aphelie,peri_day c REAL obliquit,z0,emin_turb,lmixmin c REAL emissiv,emisice(2),albedice(2),tauvis c REAL iceradius(2) , dtemisice(2) EXTERNAL RAN1 REAL RAN1 EXTERNAL iniconst,geopot,inigeom integer aslun integer ierr integer ismin external ismin CHARACTER*80 datapath c Variable nouvelle grille naturelle au point scalaire c------------------------------------------------------ real us(iip1,jjp1,llm),vs(iip1,jjp1,llm) REAL p(iip1,jjp1) REAL phisold_newgrid(iip1,jjp1) REAL t(iip1,jjp1,llm) real tsurfS(iip1,jjp1),tsoilS(iip1,jjp1,nsoilmx) real co2iceS(iip1,jjp1),emisS(iip1,jjp1) REAL q2S(iip1,jjp1,llm+1) real ptotal, co2icetotal c Var intermediaires : vent naturel, mais pas coord scalaire c----------------------------------------------------------- real vnat(iip1,jjm,llm),unat(iip1,jjp1,llm) c Variable de l'ancienne grille (lu dans newgridmars.data) c--------------------------------------------------------- real rlonuold(imold+1), rlatvold(jmold) real rlonvold(imold+1), rlatuold(jmold+1) real sigold(lmold+1),sold(lmold),sig_sold(lmold) real timelist(NB_ETATMAX) real sollong(NB_ETATMAX) real uold(imold+1,jmold+1,lmold) real vold(imold+1,jmold+1,lmold) real Told(imold+1,jmold+1,lmold) real PSold(imold+1,jmold+1) real phisold(imold+1,jmold+1) real tab_cntrl(100) real co2iceold(imold+1,jmold+1) real tsurfold(imold+1,jmold+1) real emisold(imold+1,jmold+1) real q2old(imold+1,jmold+1,lmold+1) real tsoilold(imold+1,jmold+1,nsoilmx) real ptotalold, co2icetotalold c Variable intermediaires iutilise pour l'extrapolation verticale c---------------------------------------------------------------- real var (imold+1,jmold+1,llm) real varp1 (imold+1,jmold+1,llm+1) c variable intermediaire pour l'extrapolation de la pression de surface c---------------------------------------------------------------- real pseaold(imold+1,jmold+1), Rgaz real psea(iip1,jjp1) c======================================================================= c c======================================================================= write(*,*) 'q2',ngridmx,nlayermx+1 write(*,*) 'q2S',iip1,jjp1,llm+1 write(*,*) 'q2old',imold+1,jmold+1,lmold+1 c----------------------------------------------------------------------- c Ouverture du fichier "start_archive" c----------------------------------------------------------------------- unit = 80 ierr = aslun(unit,'start_archive.dic', . unit+1,'start_archive.dat',IDRS_READ) IF (ierr.ne.0) THEN WRITE(6,*)' Pb d''ouverture du fichier "start_archive"' WRITE(6,*)' ierr = ', ierr CALL exit(1) ENDIF C----------------------------------------------------------------------- c Lecture DRS du tableau des parametres du run c (pour la lecture ulterieure de "ptotalold" et "co2icetotalold") c----------------------------------------------------------------------- ierr = CLUVDB() ierr = SETNAME(' ','controle',' ',' ',' ') size = r4 * length ierr = GETDAT(unit, tab_cntrl, size) tab0 = 50 c----------------------------------------------------------------------- c Lecture DRS des longitudes et latitudes c----------------------------------------------------------------------- ierr = CLUVDB() ierr = SETNAME(' ','rlonv',' ',' ',' ') size = (imold+1) * r4 ierr = GETDAT(unit,rlonvold, size) ierr = CLUVDB() ierr = SETNAME(' ','rlatu',' ',' ',' ') size = (jmold+1) * r4 ierr = GETDAT(unit,rlatuold, size) ierr = CLUVDB() ierr = SETNAME(' ','rlonu',' ',' ',' ') size = (imold+1) * r4 ierr = GETDAT(unit,rlonuold, size) ierr = CLUVDB() ierr = SETNAME(' ','rlatv',' ',' ',' ') size = (jmold) * r4 ierr = GETDAT(unit,rlatvold, size) c----------------------------------------------------------------------- c Lecture DRS des niveaux verticaux c----------------------------------------------------------------------- ierr = CLUVDB() ierr = SETNAME(' ','sig',' ',' ',' ') size = (lmold+1) * r4 ierr = GETDAT(unit,sigold, size) ierr = CLUVDB() ierr = SETNAME(' ','s',' ',' ',' ') size = lmold * r4 ierr = GETDAT(unit,sold, size) ierr = CLUVDB() ierr = SETNAME(' ','sig_s',' ',' ',' ') size = lmold * r4 ierr = GETDAT(unit,sig_sold, size) c----------------------------------------------------------------------- c Lecture DRS geopotentiel au sol c----------------------------------------------------------------------- ierr = CLUVDB() ierr = SETNAME(' ','phisinit',' ',' ',' ') size = (imold+1) * (jmold+1) * r4 ierr = GETDAT(unit,phisold, size) C----------------------------------------------------------------------- c lecture de "ptotalold" et "co2icetotalold" c----------------------------------------------------------------------- ptotalold = tab_cntrl(tab0+49) co2icetotalold = tab_cntrl(tab0+50) c----------------------------------------------------------------------- c Lecture du temps et choix c----------------------------------------------------------------------- c lecture bidon (ex co2ice) pour recuperer les temps ierr = CLUVDB() ierr = SETNAME(' ','co2ice',' ',' ',' ') ierr = INQDICT(unit, IDRS_GETFIRSTVAR) ierr = GETCDIM(3,dimsource,dimname,dimtitle, & dimunits,dimtype,NB_ETATMAX,timelist,NB_ETAT) write(*,*) write(*,*) write(*,*) 'Differentes dates des etats initiaux stockes:' write(*,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~' pi=2.*ASIN(1.) do i=1,NB_ETAT c call solarlong(timelist(i),sollong(i)) c sollong(i) = sollong(i)*180./pi write(*,*) 'etat initial au jour martien' ,nint(timelist(i)) c write(*,6) nint(timelist(i)),nint(mod(timelist(i),669)), c . sollong(i) enddo 6 FORMAT(i7,i7,f9.3) write(*,*) write(*,*) 'Choix de la date' 123 read(*,*,iostat=ierr) date if(ierr.ne.0) goto 123 memoire = 0 do i=1,NB_ETAT if (date.eq.timelist(i)) then memoire = i endif enddo if (memoire.eq.0) then write(*,*) write(*,*) write(*,*) 'He alors... Y sait pas lire !?!' write(*,*) write(*,*) 'Differentes dates des etats initiaux stockes:' write(*,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~' do i=1,NB_ETAT write(*,*) 'etat initial au jour martien' ,nint(timelist(i)) c write(*,6) nint(timelist(i)),nint(mod(timelist(i),669)) enddo goto 123 endif date = timelist(memoire) c----------------------------------------------------------------------- c Lecture des champs 2D (co2ice, emis,ps,tsurf,Tg[10], q2surf) c----------------------------------------------------------------------- c Il faudrait remplacer les lectures 2D et 3D par drsread, c mais Pb de compatibilite des grilles c ierr = drsread(unit,'co2ice',co2iceold,1) c 1ere dimension dimfirst(1) = rlonvold(1) dimlast(1) = rlonvold (imold+1) dimcycl(1) = 0. vardim(1) = imold+1 c 2eme dimension dimfirst(2) = rlatuold(1) dimlast(2) = rlatuold(jmold+1) dimcycl(2) = 0. vardim(2) = jmold+1 c temps dimension dimfirst(3) = date dimlast(3) = date dimcycl(3) = 0. vardim(3)= 1 ierr = CLUVDB() ierr = SETNAME(' ','co2ice',' ',' ',' ') ierr = INQDICT(unit, IDRS_GETFIRSTVAR) ierr = GETSLAB(unit, 3, dimord, dimfirst, . dimlast, dimcycl, co2iceold, vardim) ierr = CLUVDB() ierr = SETNAME(' ','emis',' ',' ',' ') ierr = INQDICT(unit, IDRS_GETFIRSTVAR) ierr = GETSLAB(unit, 3, dimord, dimfirst, . dimlast, dimcycl, emisold, vardim) ierr = CLUVDB() ierr = SETNAME(' ','ps',' ',' ',' ') ierr = INQDICT(unit, IDRS_GETFIRSTVAR) ierr = GETSLAB(unit, 3, dimord, dimfirst, . dimlast, dimcycl, psold, vardim) ierr = CLUVDB() ierr = SETNAME(' ','tsurf',' ',' ',' ') ierr = INQDICT(unit, IDRS_GETFIRSTVAR) ierr = GETSLAB(unit, 3, dimord, dimfirst, . dimlast, dimcycl, tsurfold, vardim) do isoil=1,nsoilmx write(str2,'(i2.2)') isoil ierr = CLUVDB() ierr = SETNAME(' ','Tg'//str2,' ',' ',' ') ierr = INQDICT(unit, IDRS_GETFIRSTVAR) ierr = GETSLAB(unit, 3, dimord, dimfirst, . dimlast, dimcycl, tsoilold(1,1,isoil), vardim) enddo ierr = CLUVDB() ierr = SETNAME(' ','q2surf',' ',' ',' ') ierr = INQDICT(unit, IDRS_GETFIRSTVAR) ierr = GETSLAB(unit, 3, dimord, dimfirst, . dimlast, dimcycl, q2old, vardim) c----------------------------------------------------------------------- c Lecture des champs 3D (t,u,v, q2atm) c----------------------------------------------------------------------- c 1ere dimension dimfirst(1) = rlonvold(1) dimlast(1) = rlonvold (imold+1) dimcycl(1) = 0. vardim(1) = imold+1 c 2eme dimension dimfirst(2) = rlatuold(1) dimlast(2) = rlatuold(jmold+1) dimcycl(2) = 0. vardim(2) = jmold+1 c 3eme dimension dimfirst(3) = sig_sold(1) dimlast(3) = sig_sold(lmold) dimcycl(3) = 0. vardim(3) = lmold c temps dimension dimfirst(4) = date dimlast(4) = date dimcycl(4) = 0. vardim(4)= 1 ierr = CLUVDB() ierr = SETNAME(' ','t',' ',' ',' ') ierr = INQDICT(unit, IDRS_GETFIRSTVAR) ierr = GETSLAB(unit, 4, dimord, dimfirst, . dimlast, dimcycl, told, vardim) ierr = CLUVDB() ierr = SETNAME(' ','u',' ',' ',' ') ierr = INQDICT(unit, IDRS_GETFIRSTVAR) ierr = GETSLAB(unit, 4, dimord, dimfirst, . dimlast, dimcycl, uold, vardim) ierr = CLUVDB() ierr = SETNAME(' ','v',' ',' ',' ') ierr = INQDICT(unit, IDRS_GETFIRSTVAR) ierr = GETSLAB(unit, 4, dimord, dimfirst, . dimlast, dimcycl, vold, vardim) ierr = CLUVDB() ierr = SETNAME(' ','q2atm',' ',' ',' ') ierr = INQDICT(unit, IDRS_GETFIRSTVAR) ierr = GETSLAB(unit, 4, dimord, dimfirst, . dimlast, dimcycl, q2old(1,1,2), vardim) c Chemin pour trouver les donnees de surface (albedo, relief, th.inertia...) c ------------------------------------------------------------------------- #ifdef CRAY datapath = '/u/rech/vnz/rvnz001/gcm/newdatamars' #else datapath = '/dw/chourdin/MARS/data_mars' #endif c======================================================================= c INTERPOLATION DANS LA NOUVELLE GRILLE et initialisation des variables c======================================================================= c Interpolation horizontale puis passage dans la grille physique pour c les variables physique c Interpolation verticale puis horizontale pour chaque variable 3D c======================================================================= c Relief call interp_horiz (phisold,phisold_newgrid,imold,jmold,iim,jjm,1, & rlonuold,rlatvold,rlonu,rlatv) c Glace CO2 call interp_horiz (co2iceold,co2ices,imold,jmold,iim,jjm,1, & rlonuold,rlatvold,rlonu,rlatv) c Temperature de surface call interp_horiz (tsurfold,tsurfs,imold,jmold,iim,jjm,1, & rlonuold,rlatvold,rlonu,rlatv) call gr_dyn_fi (1,iim+1,jjm+1,ngridmx,tsurfs,tsurf) c write(44,*) 'tsurf', tsurf c Temperature du sous-sol call interp_horiz(tsoilold,tsoils, & imold,jmold,iim,jjm,nsoilmx, & rlonuold,rlatvold,rlonu,rlatv) call gr_dyn_fi (nsoilmx,iim+1,jjm+1,ngridmx,tsoils,tsoil) c write(45,*) 'tsoil',tsoil c Emissivite de la surface call interp_horiz (emisold,emiss,imold,jmold,iim,jjm,1, & rlonuold,rlatvold,rlonu,rlatv) call gr_dyn_fi (1,iim+1,jjm+1,ngridmx,emiss,emis) c write(46,*) 'emis',emis c q2 : pbl wind variance write (*,*) 'q2old ', q2old (1,2,1) ! INFO call interp_vert & (q2old,varp1,lmold+1,llm+1,sigold,sig,(imold+1)*(jmold+1)) write (*,*) 'varp1 ', varp1 (1,2,1) ! INFO call interp_horiz(varp1,q2s,imold,jmold,iim,jjm,llm+1, & rlonuold,rlatvold,rlonu,rlatv) write (*,*) 'q2s ', q2s (1,2,1) ! INFO call gr_dyn_fi (llm+1,iim+1,jjm+1,ngridmx,q2s,q2) write (*,*) 'q2 ', q2 (1,2) ! INFO c write(47,*) 'q2',q2 c temperatures atmospheriques write (*,*) 'told ', told (1,jmold+1,1) ! INFO call interp_vert & (told,var,lmold,llm,sig_sold,sig_s,(imold+1)*(jmold+1)) write (*,*) 'var ', var (1,jmold+1,1) ! INFO call interp_horiz(var,t,imold,jmold,iim,jjm,llm, & rlonuold,rlatvold,rlonu,rlatv) write (*,*) 't ', t(1,jjp1,1) ! INFO c calcul des champ de vent; passage en vent covariant write (*,*) 'uold ', uold (1,2,1) ! INFO call interp_vert & (uold,var,lmold,llm,sig_sold,sig_s,(imold+1)*(jmold+1)) write (*,*) 'var ', var (1,2,1) ! INFO call interp_horiz(var,us,imold,jmold,iim,jjm,llm, & rlonuold,rlatvold,rlonu,rlatv) write (*,*) 'us ', us (1,2,1) ! INFO call interp_vert & (vold,var,lmold,llm,sig_sold,sig_s,(imold+1)*(jmold+1)) call interp_horiz(var,vs,imold,jmold,iim,jjm,llm, & rlonuold,rlatvold,rlonu,rlatv) call scal_wind(us,vs,unat,vnat) write (*,*) 'unat ', unat (1,2,1) ! INFO do l=1,llm do j = 1, jjp1 do i=1,iip1 ucov( i,j,l ) = unat( i,j,l ) * cu(i,j) c chris Warning ucov = 0 c ucov( i,j,l ) = 0 end do end do end do write (*,*) 'ucov ', ucov (1,2,1) ! INFO c write(48,*) 'ucov',ucov do l=1,llm do j = 1, jjm do i=1,iim vcov( i,j,l ) = vnat( i,j,l ) * cv(i,j) c chris Warning vcov = 0 c vcov( i,j,l ) = 0 end do vcov( iip1,j,l ) = vcov( 1,j,l ) end do end do c write(49,*) 'ucov',vcov c----------------------------------------------------------------------- c Traitement special de la pression au sol : c----------------------------------------------------------------------- c Calcul de la pression "au niveau de la mer" z = 0 dns l'ancienne grille Rgaz = 1000.*8.31/mugaz DO j=1,jmold+1 DO i=1,imold+1 pseaold(i,j)=psold(i,j)*EXP(phisold(i,j)/(Told(i,j,1)*Rgaz)) c chris Warning pseaold = 700 c pseaold(i,j)=700 ENDDO ENDDO c Test TestTest Test Test Test Test Test Test Test Test write (*,*)'pour i=9, j=9 pseaold,psold,phisold,told,Rgaz' write(*,*) pseaold(9,9),psold(9,9),phisold(9,9),told(9,9,1),Rgaz c Extrapolation la pression "au niveau de la mer" z = 0 dns la nouvelle grille call interp_horiz(pseaold,psea,imold,jmold,iim,jjm,1, & rlonuold,rlatvold,rlonu,rlatv) c chris Warning t = 200 c DO l=1,llm c DO j=1,jjp1 c DO i=1,iim c t(i,j,l) = 200 c ENDDO c ENDDO c ENDDO c Calcul de la pression avec le relief de la nouvelle grille DO j=1,jjp1 DO i=1,iim p(i,j) = psea(i,j)*EXP(-phisold_newgrid(i,j)/(t(i,j,1)*Rgaz)) pext(i,j)=p(i,j)*aire(i,j) ENDDO pext(iip1,j) = pext(1,j) ENDDO c Extrapolation la pression dans la nouvelle grille c call interp_horiz(psold,p,imold,jmold,iim,jjm,1, c & rlonuold,rlatvold,rlonu,rlatv) c Calcul de la pression avec le relief de la nouvelle grille c DO j=1,jjp1 c DO i=1,iim c pext(i,j)=p(i,j)*aire(i,j) c ENDDO c pext(iip1,j) = pext(1,j) c ENDDO c write(50,*) 'pext avant conservation',pext c----------------------------------------------------------------------- c On assure la conservation de la masse de l'atmosphere + calottes c----------------------------------------------------------------------- ptotal = 0. co2icetotal = 0. DO j=1,jjp1 DO i=1,iim ptotal=ptotal+pext(i,j)/g co2icetotal = co2icetotal + co2iceS(i,j)*aire(i,j) ENDDO ENDDO write(*,*) write(*,*)'Ancienne grille: masse de l atm :',ptotalold write(*,*)'Nouvelle grille: masse de l atm :',ptotal write (*,*) 'Ratio new atm./ old atm =', ptotal/ptotalold write(*,*) write(*,*)'Ancienne grille: masse de la glace CO2:',co2icetotalold write(*,*)'Nouvelle grille: masse de la glace CO2:',co2icetotal write(*,*)'Ratio new ice./old ice =',co2icetotal/co2icetotalold write(*,*) c print*,'pext pext pext ',pext c print*,'p ppppp',p DO j=1,jjp1 DO i=1,iip1 pext(i,j)=pext(i,j) * ptotalold/ptotal ENDDO ENDDO c write(51,*) 'pext apres conservation',pext if ( co2icetotalold.gt.0.) then DO j=1,jjp1 DO i=1,iip1 co2iceS(i,j)=co2iceS(i,j) * co2icetotalold/co2icetotal ENDDO ENDDO end if call gr_dyn_fi (1,iim+1,jjm+1,ngridmx,co2ices,co2ice) c write(52,*) 'co2ice',co2ice c----------------------------------------------------------------------- c Initialisation h: (passage de t -> h) c----------------------------------------------------------------------- DO l=1,llm DO j=1,jjp1 DO i=1,iim h(i,j,l) = t(i,j,l)*cpp/(s(l)*p(i,j)**kappa) ENDDO h(iip1,j,l) = h(1,j,l) ENDDO ENDDO c write(53,*) 'h',h c chris Warning tsurf = tsoil = 200 c DO ig=1,ngridmx c tsurf(ig) = 200 c DO l=1,nsoilmx c tsoil(ig,l) = 200 c ENDDO c ENDDO c*********************************************************************** c*********************************************************************** c Fin subroutine lecture ini c*********************************************************************** c*********************************************************************** return end