*=*=*=*= physiq.html =*=*=*=*
SUBROUTINE physiq(ecri,ngrid,nlayer,nq, $ firstcall,lastcall, $ pday,ptime,ptimestep, $ pplev,pplay,pphi, $ pu,pv,pt,pq, $ pdudyn,pdvdyn,pdtdyn,pdqdyn, $ pw, $ pdu,pdv,pdt,pdq,pdpsrf) IMPLICIT NONE c======================================================================= c c subject: c -------- c c Organisation of the physical parametrisations of the LMD c martian atmospheric general circulation modele. c It includes: c raditive transfer (long and shortwave) for CO2 and dust. c vertical turbulent mixing c convective adjsutment c condensation and sublimation of carbon dioxide. c c physical part history file writing c c c author: Frederic Hourdin 15/10/93 c ------- c Francois Forget 1994 c c Christophe Hourdin 02/1997 c Cutting of physiq call in order to reduce the size c of the program (NDLO2 and ndomainsz in dimradmars.h) c Only for Radite and Gravity wave drag c c c arguments: c ---------- c c input: c ------ c c ngrid Size of the horizontal grid. c All internal loops are performed on that grid. c nlayer Number of vertical layers. c nq Number of advected fields c firstcall True at the first call c lastcall True at the last call c pday Number of days counted from the North. Spring c equinoxe. c ptime hour (s) c ptimestep timestep (s) c pplay(ngrid,nlayer+1) Pressure at the middle of the layers (Pa) c pplev(ngrid,nlayer+1) intermediate pressure levels (pa) c pphi(ngrid,nlayer) Geopotential at the middle of the layers (m2s-2) c pu(ngrid,nlayer) u component of the wind (ms-1) c pv(ngrid,nlayer) v component of the wind (ms-1) c pt(ngrid,nlayer) Temperature (K) c pq(ngrid,nlayer,nq) Advected fields c pudyn(ngrid,nlayer) \ c pvdyn(ngrid,nlayer) \ Dynamical temporal derivative for the c ptdyn(ngrid,nlayer) / corresponding variables c pqdyn(ngrid,nlayer,nq) / c pw(ngrid,?) vertical velocity c c output: c ------- c c pdu(ngrid,nlayermx) \ c pdv(ngrid,nlayermx) \ Temporal derivative of the corresponding c pdt(ngrid,nlayermx) / variables due to physical processes. c pdq(ngrid,nlayermx) / c pdpsrf(ngrid) / c c======================================================================= c c 0. Declarations : c ------------------ #include "dimensions.h" #include "dimphys.h" #include "comgeomfi.h" #include "surfdat.h" #include "comdiurn.h" #include "callkeys.h" #include "comcstfi.h" #include "planete.h" #include "drsdef.h" #include "comsaison.h" #include "control.h" #include "dimradmars.h" #include "yomaer.h" #include "yomrdu.h" #include "comg1d.h" c Arguments : c ----------- c inputs: c ------- INTEGER ngrid,nlayer,nq REAL ecri REAL ptimestep REAL pplev(ngrid,nlayer+1),pplay(ngrid,nlayer) REAL pphi(ngrid,nlayer) REAL pu(ngrid,nlayer),pv(ngrid,nlayer) REAL pt(ngrid,nlayer),pq(ngrid,nlayer,nq) REAL pdu(ngrid,nlayer),pdv(ngrid,nlayer) CHARACTER*80 fichier data fichier /'startfi'/ c dynamical tendencies REAL pdtdyn(ngrid,nlayer),pdqdyn(ngrid,nlayer,nq) REAL pdudyn(ngrid,nlayer),pdvdyn(ngrid,nlayer) REAL pw(ngridmx,nlayer) c Time INTEGER pday REAL ptime c outputs: c -------- c physical tendencies REAL pdt(ngrid,nlayer),pdq(ngrid,nlayer,nq) REAL pdpsrf(ngrid) LOGICAL firstcall,lastcall c Local variables : c ----------------- INTEGER l,ig,ierr,aslun,nlevel,igout,cllun,iq,itra INTEGER tapphys INTEGER*4 day_ini REAL time,zday REAL zh(ngridmx,nlayermx),z1,z2 REAL zzlev(ngridmx,nlayermx+1),zzlay(ngridmx,nlayermx) REAL ztlev(ngridmx,nlayermx+1) REAL zdvfr(ngridmx,nlayermx),zdufr(ngridmx,nlayermx) REAL zdhfr(ngridmx,nlayermx),zdtsrf(ngridmx),zdtsrfr(ngridmx) REAL zdtc(ngridmx,nlayermx),zdtsrfc(ngridmx) REAL zdvc(ngridmx,nlayermx),zduc(ngridmx,nlayermx) REAL zflubid(ngridmx) REAL zplanck(ngridmx),zpopsk(ngridmx,nlayermx) REAL zrad(ngridmx,nlayermx),zradc(ngridmx,nlayermx) REAL zdum1(ngridmx,nlayermx) REAL zdum2(ngridmx,nlayermx) REAL zdum3(ngridmx,nlayermx) REAL zdum4(ngridmx,nlayermx) REAL zdum5(ngridmx,nlayermx) REAL stephan REAL ztim1,ztim2,ztim3 REAL zco2,zp REAL zmu(ngridmx) REAL zvar,zls,zaervar REAL zdtlw(ngridmx,nlayermx),zdtsw(ngridmx,nlayermx) REAL zdtlwcl(ngridmx,nlayermx),zdtswcl(ngridmx,nlayermx) REAL zflux(ngridmx,6) REAL ztime_fin REAL zdaerosolc(ngridmx,nlayermx) REAL q2(ngridmx,nlayermx+1) REAL zulow(ngridmx),zvlow(ngridmx) REAL zustr(ngridmx),zvstr(ngridmx) REAL co2heat0,p0nonlte REAL zlsconst REAL sigtest(nlayermx+1) INTEGER igwd,igwdim,itest(ngridmx),iii,jjj logical ll c Local saved variables: c ---------------------- save day_ini INTEGER icount SAVE icount REAL aerosol(ngridmx,nlayermx,5),cst_aer,pview(ngridmx) REAL tsurf(ngridmx),tsoil(ngridmx,nsoilmx) REAL co2ice(ngridmx),albedo(ngridmx,2),emis(ngridmx) REAL dtrad(ngridmx,nlayermx),fluxrad(ngridmx) REAL capcal(ngridmx),fluxgrd(ngridmx) REAL topdust0(ngridmx) , topdust SAVE aerosol,cst_aer,pview SAVE tsurf,tsoil SAVE co2ice,albedo,emis SAVE q2 SAVE capcal,fluxgrd,dtrad,fluxrad SAVE topdust0 LOGICAL ldrs,startdrs SAVE ldrs,startdrs SAVE stephan EXTERNAL vdif,convadj EXTERNAL orbite,mucorr EXTERNAL ismin,ismax DATA stephan/5.67e-08/ c Local variable for cutting of physiq call c ----------------------------------------- INTEGER ndomain parameter (ndomain = (ngridmx-1) / ndomainsz + 1) c cutting of radite call REAL zplev(ndomainsz,nlayermx+1) REAL zztlev(ndomainsz,nlayermx+1) REAL zplay(ndomainsz,nlayermx) REAL zt(ndomainsz,nlayermx) REAL zaerosol(ndomainsz,nlayermx,5) REAL zalbedo(ndomainsz,2) REAL zzrad(ndomainsz,nlayermx) REAL zzradc(ndomainsz,nlayermx) REAL zzdtlw(ndomainsz,nlayermx) REAL zzdtsw(ndomainsz,nlayermx) REAL zzdtlwcl(ndomainsz,nlayermx) REAL zzdtswcl(ndomainsz,nlayermx) REAL zzflux(ndomainsz,6) INTEGER jd,j,ig0,nd c cutting of Gravity wave drag call REAL zu(ndomainsz,nlayermx) REAL zv(ndomainsz,nlayermx) INTEGER zidx(ndomainsz) REAL zzdhfr(ndomainsz,nlayermx) REAL zzdufr(ndomainsz,nlayermx) REAL zzdvfr(ndomainsz,nlayermx) REAL seuil c local variables only used for diagnostic (diagfi) c ------------------------------------------------- REAL ps(ngridmx) real ztmp_cl(ngridmx,nlayermx) real ztmp_cv(ngridmx,nlayermx) real ztmp_gw(ngridmx,nlayermx) real zu_cl(ngridmx,nlayermx) real zu_cv(ngridmx,nlayermx) real zu_gw(ngridmx,nlayermx) real zv_cl(ngridmx,nlayermx) real zv_cv(ngridmx,nlayermx) real zv_gw(ngridmx,nlayermx) c c======================================================================= c c Fonction Intrinseque c -------------------- c To be used for seasonal varying dust: zaervar(zls)=0.7+.3*cos(zls+80.*pi/180.) c----------------------------------------------------------------------- c 1. Initialisation: c ----------------- zday=pday+ptime ldrs=.true. c igout=ngrid/2+1 igout=60 c Initialisation only at first call c -------------------------------------- IF(firstcall) THEN c variables set to 0 c """""""""""""""""" do itra=1,5 do l=1,nlayer do ig=1,ngrid aerosol(ig,l,itra)=0. enddo enddo enddo DO l=1,nlayer DO ig=1,ngrid dtrad(ig,l)=0. ENDDO ENDDO DO ig=1,ngrid fluxrad(ig)=0. ENDDO c reading startfi c """"""""""""""" CALL readfi(fichier,0,0,ngrid,nsoilmx,startdrs, . day_ini,time,co2ice,tsurf,tsoil,emis,q2) write (*,*) 'In physic day_ini =', day_ini CALL surfini(ngrid,co2ice,albedo) CALL iniorbit(aphelie,periheli,year_day,peri_day,obliquit) c initialisation radiative transfer and dust c """""""""""""""""""""""""""""""""""""""""" c Total optical depth of "tauvis" for Ps=700Pa: cst_aer = tauvis/700. c altitude of the top of the aerosol layer (km) at Ls=2.76rad: DO ig=1,ngrid topdust0(ig)=60. -22.*SIN(lati(ig))**2 END DO DO ig=1,ngrid pview(ig)=1.66 ! cosecant of viewing angle ENDDO CALL sucst(66,19900101,8000000,g,rad,mugaz,rcp,daysec) CALL surad(6) c initialisation soil c """"""""""""""""""" IF(callsoil) THEN CALL soil(ngrid,nsoilmx,firstcall,inertiedat, s ptimestep,tsurf,tsoil,capcal,fluxgrd) ELSE PRINT*,'WARNING!!! Thermal conduction in the soil s turned off' DO ig=1,ngrid capcal(ig)=1.e5 fluxgrd(ig)=0. ENDDO ENDIF icount=1 IF (ngrid.EQ.1) GOTO 10002 c On cree le fichier bande histoire histfi c """""""""""""""""""""""""""""""""""""""" c ATTENTION : On ecrase le "histphy" cree par gcm.F ! tapphys = 12 if (tapphys.ne.12) stop 'Pb d''indice du fichier histfi' close (tapphys,STATUS='delete') close (tapphys+1,STATUS='delete') ierr = cllun (tapphys) ierr = aslun(tapphys,'histfi.dic', . tapphys+1,'histfi.dat',IDRS_CREATE) IF (ierr.NE.0) THEN WRITE(6,*)' Pb d''ouverture du fichier histfi' WRITE(6,*)' ierr = ', ierr CALL EXIT(1) ENDIF CALL iniwritefi(tapphys,ldrs,pday) c Verification que la synchro des fichiers histoire dyn et phy est c possible (F.F) IF( MOD(iecri*day_step,iphysiq).ne.0) then write (*,*) 'pb de synchro a l ecriture fichier histoire' write (*,*) 'dyn et phy. Il faut iecri*day_step ' write (*,*) 'multiple de iphysiq ' stop ENDIF 10002 CONTINUE c initialisation Gravity Wave & orgraphy friction scheme c """"""""""""""""""""""""""""""""""""""""""""""""""""""" if(calllott) then do l=1,nlayermx+1 sigtest(l)=pplev(1,l)/pplev(1,1) enddo call sugwd(nlayermx,sigtest) print*,'WARNING!!! sigma levels are assumed' endif c!-*- c initialisation pour les statistiques c """""""""""""""""""""""""""""""""""" IF (callstats) THEN CALL instat ENDIF ENDIF ! (du "if firstcall") c Initialisations at every physical timestep: c ------------------------------------------ c print*,'momo zday = ',zday c print*,' momo Ls= ',zls*180./pi CALL solarlong(zday,zls) c print*,'momo zday = ',zday c print*,' momo Ls= ',zls*180./pi c Temporal variation of the dust optical depth as a function c of solar longitude. IF(laervar) THEN zvar=zaervar(zls) WRITE(37,'(3e15.5)') zls,zvar,zday ELSE zvar=1. ENDIF c IF (ngrid.NE.ngridmx) THEN c PRINT*,'STOP in inifis' c PRINT*,'Probleme de dimenesions :' c PRINT*,'ngrid = ',ngrid c PRINT*,'ngridmx = ',ngridmx c STOP c ENDIF DO l=1,nlayer DO ig=1,ngrid pdv(ig,l)=0. pdu(ig,l)=0. pdt(ig,l)=0. ENDDO ENDDO DO ig=1,ngrid pdpsrf(ig)=0. zflubid(ig)=0. zdtsrf(ig)=0. ENDDO CALL zerophys(ngrid*nlayer,zdum1) CALL zerophys(ngrid*nlayer,zdum2) CALL zerophys(ngrid*nlayer,zdum3) CALL zerophys(ngrid*nlayer,zdum4) CALL zerophys(ngrid*nlayer,zdum5) c calcul du geopotentiel aux niveaux intercouches c ----------------------------------------------- c ponderation des altitudes au niveau des couches en dp/p DO l=1,nlayer DO ig=1,ngrid zzlay(ig,l)=pphi(ig,l)/g ENDDO ENDDO DO ig=1,ngrid zzlev(ig,1)=0. ENDDO DO l=2,nlayer DO ig=1,ngrid z1=(pplay(ig,l-1)+pplev(ig,l))/(pplay(ig,l-1)-pplev(ig,l)) z2=(pplev(ig,l)+pplay(ig,l))/(pplev(ig,l)-pplay(ig,l)) zzlev(ig,l)=(z1*zzlay(ig,l-1)+z2*zzlay(ig,l))/(z1+z2) ENDDO ENDDO c Transformation de la temperature en temperature potentielle c ----------------------------------------------------------- DO l=1,nlayer DO ig=1,ngrid zpopsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**rcp ENDDO ENDDO DO l=1,nlayer DO ig=1,ngrid zh(ig,l)=pt(ig,l)/zpopsk(ig,l) ENDDO ENDDO c----------------------------------------------------------------------- c Stockage des statistiques : c ------------------------- IF (callstats) THEN CALL stats(ngrid, nlayer, co2ice, emis, tsurf & ,pplev, pplay, pt, pu, pv, q2) ENDIF c----------------------------------------------------------------------- c 2. Calcul of the radiative tendencies : c --------------------------------------- IF(callrad) THEN IF( MOD(icount-1,iradia).EQ.0) THEN print*, 'APPEL calcul RADIATIF' print*, 'icount =',icount,' et iradia=',iradia c 2.1 Useful calculations to prepare radiative transfer c ------------------------------------------------------ c Solar angle c ~~~~~~~~~~~ CALL orbite(zls,dist_sol,declin) IF(diurnal) THEN ztim1=SIN(declin) ztim2=COS(declin)*COS(2.*pi*(zday-.5)) ztim3=-COS(declin)*SIN(2.*pi*(zday-.5)) CALL solang(ngrid,sinlon,coslon,sinlat,coslat, s ztim1,ztim2,ztim3, s mu0,fract) IF(lwrite) THEN PRINT*,'day, declin, sinlon,coslon,sinlat,coslat' PRINT*,zday, declin, s sinlon(igout+1),coslon(igout+1), s sinlat(igout),coslat(igout) ENDIF ELSE CALL mucorr(ngrid,declin, lati, mu0, fract,10000.,rad) ENDIF c Aerosol distribution: c ~~~~~~~~~~~~~~~~~~~~~ if(esadust) then c new dust vertical distribution function: zlsconst=18.*SIN(zls-2.76) DO l=1,nlayer DO ig=1,ngrid if(laervarlat) then topdust=topdust0(ig)+zlsconst ! viking year else topdust=topdustref ! like before 03/96 endif zp=(700./pplay(ig,l))**(70./topdust) aerosol(ig,l,1)=zvar*cst_aer* s (pplev(ig,l)-pplev(ig,l+1)) s *max( exp(.007*(1.-max(zp,1.))) , 1.E-3 ) ENDDO ENDDO print*,'Ls= ',zls*180./pi,' TAU=',zvar*tauvis & ,' esadust D=',dist_sol else c old dust vertical distribution function ("conrath"): print*,'Ls= ',zls*180./pi,' TAU=',zvar*tauvis DO l=1,nlayer DO ig=1,ngrid zp=700./pplay(ig,l) aerosol(ig,l,1)= s zvar*cst_aer*(pplev(ig,l)-pplev(ig,l+1)) s *max( exp(.03*(1.-max(zp,1.))) , 1.E-3 ) ENDDO ENDDO endif c Cutting variables for radite (and save memory) c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ c write(*,*) 'Radite cutting: ngridmx,ngrid,ndomainsz,ndomain', c . ngridmx,ngrid,ndomainsz,ndomain DO jd=1,ndomain ig0=(jd-1)*ndomainsz if (jd.eq.ndomain) then nd=ngridmx-ig0 else nd=ndomainsz endif c Cutting of entries do l=1,nlayer+1 do ig = 1,nd zplev(ig,l) = pplev(ig0+ig,l) enddo enddo do l=1,nlayer do ig = 1,nd zplay(ig,l) = pplay(ig0+ig,l) zt(ig,l) = pt(ig0+ig,l) enddo enddo do j=1,5 do l=1,nlayer do ig = 1,nd zaerosol(ig,l,j) = aerosol(ig0+ig,l,j) enddo enddo enddo do j=1,2 do ig = 1,nd zalbedo(ig,j) = albedo(ig0+ig,j) enddo enddo c Intermediate levels: (computing ztlev) c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ c Extrapolation for the air temperature above the surface DO ig=1,nd zztlev(ig,1)=zt(ig,1)+ s (zplev(ig,1)-zplay(ig,1))* s (zt(ig,1)-zt(ig,2))/(zplay(ig,1)-zplay(ig,2)) ENDDO DO l=2,nlayer DO ig=1,nd zztlev(ig,l)=0.5*(zt(ig,l-1)+zt(ig,l)) ENDDO ENDDO nlevel=nlayer+1 DO ig=1,nd zztlev(ig,nlevel)=zt(ig,nlayer) ENDDO c 2.2 Calcul of the radiative tendencies and fluxes: c -------------------------------------------------- zco2=.95 CALL radite(nd,nlayer,0,6,1,1, $ zaerosol,zalbedo,zco2,zdum4,emis(ig0+1), $ mu0(ig0+1),zdum5, $ zplev,zplay,zdum1,zdum2,zdum3,zztlev,tsurf(ig0+1),zt, $ pview(ig0+1), $ zzdtlw,zzdtsw,zzdtlwcl,zzdtswcl,zzflux,zzrad,zzradc, $ fract(ig0+1),dist_sol) c 2.3 total flux and tendencies: c ------------------------------ c 2.3.1 fluxes c ~~~~~~~~~~~~ do l=1,nlayer do ig = 1,nd zrad(ig0+ig,l) = zzrad(ig,l) zradc(ig0+ig,l) = zzradc(ig,l) zdtlw(ig0+ig,l) = zzdtlw(ig,l) zdtsw(ig0+ig,l) = zzdtsw(ig,l) zdtlwcl(ig0+ig,l) = zzdtlwcl(ig,l) zdtswcl(ig0+ig,l) = zzdtswcl(ig,l) enddo enddo do l=1,nlayer+1 do ig = 1,nd ztlev(ig0+ig,l) = zztlev(ig,l) enddo enddo do j=1,6 do ig = 1,nd zflux(ig0+ig,j) = zzflux(ig,j) enddo enddo ENDDO ! (boucle jd=1, ndomain) DO ig=1,ngrid fluxrad(ig)=emis(ig)*zflux(ig,4) $ +zflux(ig,5)*(1.-albedo(ig,1)) $ +zflux(ig,6)*(1.-albedo(ig,2)) zplanck(ig)=tsurf(ig)*tsurf(ig) zplanck(ig)=emis(ig)* $ stephan*zplanck(ig)*zplanck(ig) fluxrad(ig)=fluxrad(ig)-zplanck(ig) ENDDO c 2.4.2 temperature tendencies c ~~~~~~~~~~~~~~~~~~~~~~~~~~~ DO l=1,nlayer DO ig=1,ngrid dtrad(ig,l)=(zdtsw(ig,l)+zdtlwcl(ig,l))/daysec c._. dtrad(ig,l)=(zdtsw(ig,l)+zdtlw(ig,l))/daysec ENDDO ENDDO c SORTIES SPECIALES DEBUG! c ~~~~~~~~~~~~~~~~~~~~~~~~ c tests pour debuguer en cas de valeurs NaN sur fluxrad do ig=1,ngrid if(.not.fluxrad(ig).le.500.) then c if(1.eq.0) then jjj=(ig-2)/iim+2 iii=ig-1-iim*(jjj-2) print*,'Sortie speciale debug physiq' print*,'Ca plante au point ',ig,iii,jjj print*,'mu0=',mu0(ig),' fract=',fract(ig) print*,'Alb.=',albedo(ig,1),albedo(ig,2),' emis',emis(ig) print*,'Flux rad : ',fluxrad(ig) print*,'l P P T T dtlw dtsw ' do l=1,nlayer print*,l,pplev(ig,l),pplay(ig,l),ztlev(ig,l) , ,pt(ig,l),zdtlwcl(ig,l),zdtsw(ig,l),aerosol(ig,l,1) enddo c appel du rayonnement avec diagnostiques au point de plantage nimp=0 jlimprad=ig CALL radite(ngrid,nlayer,0,6,1,1, $ aerosol,albedo,zco2,zdum4,emis, $ mu0,zdum5, $ pplev,pplay,zdum1,zdum2,zdum3,ztlev,tsurf,pt,pview, $ zdtlw,zdtsw,zdtlwcl,zdtswcl,zflux,zrad,zradc, $ fract,dist_sol) do l=1,nlayer print*,l,pplev(ig,l),pplay(ig,l),ztlev(ig,l) , ,pt(ig,l),zdtlwcl(ig,l),zdtsw(ig,l),aerosol(ig,l,1) enddo stop endif enddo c 2.4 CO2 near infrared absorption c ------------------------------- if(callco2v) then c co2heat is the heating by CO2 at 700Pa for a zero zenithal angle. c it is 1.3 K/day for the mean distance to sun (1.52UA). co2heat0=1.3*(1.52/dist_sol)**2/daysec c p0noonlte is a pressure below which non LTE effects are significant. c Modif Fred H., 08 08 96 p0nonlte=7.5e-3 do ig=1,ngrid zmu(ig)=sqrt(1224.*mu0(ig)*mu0(ig)+1.)/35. enddo if(callnlte) then do l=1,nlayer do ig=1,ngrid if(fract(ig).gt.0.) dtrad(ig,l)=dtrad(ig,l) s + co2heat0*sqrt((700.*zmu(ig))/pplay(ig,l)) s / (1+p0nonlte/pplay(ig,l)) enddo enddo else do l=1,nlayer do ig=1,ngrid if(fract(ig).gt.0.) dtrad(ig,l)=dtrad(ig,l) s + co2heat0/sqrt((700.*zmu(ig))/pplay(ig,l)) enddo enddo endif endif ENDIF ! mod(icount-1,iradia).eq.0 c 2.5 Transformation of the radiative tendencies: c ----------------------------------------------- DO l=1,nlayer DO ig=1,ngrid pdt(ig,l)=pdt(ig,l)+dtrad(ig,l) c print*,'dtrad et pdt:',ig,l,dtrad(ig,l),pdt(ig,l) ENDDO ENDDO IF(lwrite) THEN PRINT*,'Diagnotique for the radiation' PRINT*,'albedo, emissiv, mu0,fract,pview,Frad,Planck' PRINT*,albedo(igout,1),emis(igout),mu0(igout), s fract(igout),pview(igout), s fluxrad(igout),zplanck(igout) PRINT*,'Tlay Tlev Play Plev dT/dt SW dT/dt LW (K/day)' PRINT*,'daysec',daysec DO l=1,nlayer PRINT*,pt(igout,l),ztlev(igout,l), s pplay(igout,l),pplev(igout,l), s zdtsw(igout,l),zdtlw(igout,l) ENDDO ENDIF ENDIF c----------------------------------------------------------------------- c 3. Gravity wave drag : c ---------------------- c c Appeler le programme de parametrisation de l'orographie c a l'echelle sous-maille: c IF(calllott)THEN c Cutting variables for gravity wave drag (and save memory) c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ c write(*,*) c . 'Gravity wave drag cutting: ngridmx,ngrid,ndomainsz,ndomain', c . ngridmx,ngrid,ndomainsz,ndomain DO jd=1,ndomain ig0=(jd-1)*ndomainsz if (jd.eq.ndomain) then nd=ngridmx-ig0 else nd=ndomainsz endif c selection des points pour lesquels le shema est actif: igwd=0 DO ig=ig0+1,ig0+nd itest(ig)=0 cmod ll=zstd(ig).gt.10.0 ll=zstd(ig).gt.50.0 IF(ll) then itest(ig)=1 igwd=igwd+1 zidx(igwd)=ig - ig0 ENDIF ENDDO IGWDIM=MAX(1,IGWD) c Cutting of entries do l=1,nlayer+1 do ig = 1,nd zplev(ig,l) = pplev(ig0+ig,l) enddo enddo do l=1,nlayer do ig = 1,nd zplay(ig,l) = pplay(ig0+ig,l) zt(ig,l) = pt(ig0+ig,l) zu(ig,l) = pu(ig0+ig,l) zv(ig,l) = pv(ig0+ig,l) enddo enddo c Call gravity wave drag c ~~~~~~~~~~~~~~~~~~~~~~ call drag_noro (nd,nlayer,ptimestep,zplay,zplev, e zstd(ig0+1),zsig(ig0+1),zgam(ig0+1),zthe(ig0+1), e igwd,igwdim,zidx,itest(ig0+1), e zt, zu, zv, s zulow(ig0+1),zvlow(ig0+1),zustr(ig0+1),zvstr(ig0+1), s zzdhfr,zzdufr,zzdvfr) do l=1,nlayer do ig = 1,nd zdhfr(ig0+ig,l) = zzdhfr(ig,l) zdufr(ig0+ig,l) = zzdufr(ig,l) zdvfr(ig0+ig,l) = zzdvfr(ig,l) enddo enddo ENDDO ! (boucle jd=1, ndomain) c ajout des tendances gravity wave drag c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ DO l=1,nlayer DO ig=1,ngrid pdv(ig,l)=pdv(ig,l)+zdvfr(ig,l)/ptimestep pdu(ig,l)=pdu(ig,l)+zdufr(ig,l)/ptimestep pdt(ig,l)=pdt(ig,l)+zdhfr(ig,l)/ptimestep ztmp_gw(ig,l)=zdhfr(ig,l)/ptimestep ! for diagnostic only zu_gw(ig,l)=zdufr(ig,l)/ptimestep ! for diagnostic only zv_gw(ig,l)=zdvfr(ig,l)/ptimestep ! for diagnostic only ENDDO ENDDO ENDIF c----------------------------------------------------------------------- c 4. Vertical diffusion (turbulent mixing): c ----------------------------------------- c IF(calldifv) THEN DO ig=1,ngrid zflubid(ig)=fluxrad(ig)+fluxgrd(ig) ENDDO CALL zerophys(ngrid*nlayer,zdum1) CALL zerophys(ngrid*nlayer,zdum2) CALL zerophys(ngrid*nlayer,zdum3) do l=1,nlayer do ig=1,ngrid zdum3(ig,l)=pdt(ig,l)/zpopsk(ig,l) enddo enddo c Appel vdif (version martienne AVEC condensation) c ~~~~~~~~~ CALL vdifc(ngrid,nlayer,co2ice, zpopsk, $ ptimestep,capcal, $ pplay,pplev,zzlay,zzlev, $ z0, $ pu,pv,zh,tsurf,emis, $ zdum1,zdum2,zdum3,zflubid, $ zdufr,zdvfr,zdhfr,zdtsrfr,q2, $ lwrite) DO l=1,nlayer DO ig=1,ngrid pdv(ig,l)=pdv(ig,l)+zdvfr(ig,l) pdu(ig,l)=pdu(ig,l)+zdufr(ig,l) pdt(ig,l)=pdt(ig,l)+zdhfr(ig,l)*zpopsk(ig,l) ztmp_cl(ig,l)=zdhfr(ig,l)*zpopsk(ig,l) ! for diagnostic only zu_cl(ig,l)=zdufr(ig,l) ! for diagnostic only zv_cl(ig,l)=zdvfr(ig,l) ! for diagnostic only ENDDO ENDDO DO ig=1,ngrid zdtsrf(ig)=zdtsrf(ig)+zdtsrfr(ig) ENDDO ELSE DO ig=1,ngrid zdtsrf(ig)=zdtsrf(ig)+ s (fluxrad(ig)+fluxgrd(ig))/capcal(ig) ENDDO ENDIF c c c c----------------------------------------------------------------------- c 4. Dry convective adjustment: c ----------------------------- IF(calladj) THEN DO l=1,nlayer DO ig=1,ngrid zdum1(ig,l)=pdt(ig,l)/zpopsk(ig,l) ENDDO ENDDO CALL zerophys(ngrid*nlayer,zdufr) CALL zerophys(ngrid*nlayer,zdvfr) CALL zerophys(ngrid*nlayer,zdhfr) CALL convadj(ngrid,nlayer,ptimestep, $ pplay,pplev,zpopsk, $ pu,pv,zh, $ pdu,pdv,zdum1, $ zdufr,zdvfr,zdhfr) DO l=1,nlayer DO ig=1,ngrid pdu(ig,l)=pdu(ig,l)+zdufr(ig,l) pdv(ig,l)=pdv(ig,l)+zdvfr(ig,l) pdt(ig,l)=pdt(ig,l)+zdhfr(ig,l)*zpopsk(ig,l) ztmp_cv(ig,l)=zdhfr(ig,l)*zpopsk(ig,l) ! for diagnostic only zu_cv(ig,l)=zdufr(ig,l) ! for diagnostic only zv_cv(ig,l)=zdvfr(ig,l) ! for diagnostic only ENDDO ENDDO ENDIF c----------------------------------------------------------------------- c 5. Carbon dioxide condensation-sublimation: c ------------------------------------------- IF(callcond) THEN CALL newcondens(ngrid,nlayer,ptimestep, $ capcal,pplay,pplev,tsurf,pt, $ pphi,pdt,pdu,pdv,zdtsrf,pu,pv,aerosol, $ co2ice,albedo,emis, $ zdtc,zdtsrfc,pdpsrf,zduc,zdvc, $ zdaerosolc) DO l=1,nlayer DO ig=1,ngrid pdt(ig,l)=pdt(ig,l)+zdtc(ig,l) pdv(ig,l)=pdv(ig,l)+zdvc(ig,l) pdu(ig,l)=pdu(ig,l)+zduc(ig,l) ENDDO ENDDO DO ig=1,ngrid zdtsrf(ig) = zdtsrf(ig) + zdtsrfc(ig) ENDDO ENDIF c----------------------------------------------------------------------- c 6. Traitement des traceurs dans la physique c: ------------------------------------------- DO iq=1,nq DO l=1,nlayer DO ig=1,ngrid pdq(ig,l,iq) = 0. END DO END DO END DO c c ************************************************************** c IF (ngrid.EQ.1) THEN ! (si pas un modele 1d) c chris ajoute les sorties 1D avant d'ajouter les tendances g1d_tmp1='tsurf' g1d_tmp2='temperature au sol' CALL writeg1d(1,1,tsurf,g1d_tmp1,g1d_tmp2) do l = 1, nsoilmx if (l .LE. 9) then write(g1d_tmp1,'(a2,i1)') 'tg',l else write(g1d_tmp1,'(a2,i2)') 'tg',l endif write(g1d_tmp2,*) 'temperature du sol couche ',l CALL writeg1d(1,1,tsoil(1,l),g1d_tmp1,g1d_tmp2) enddo g1d_tmp1='dtlwc' g1d_tmp2='dtlw clear sky' CALL writeg1d(1,nlayer,zdtlwcl,g1d_tmp1,g1d_tmp2) g1d_tmp1='dtlw' g1d_tmp2='dtlw' CALL writeg1d(1,nlayer,zdtlw,g1d_tmp1,g1d_tmp2) c g1d_tmp1='pdt' c g1d_tmp2='pdt' c CALL writeg1d(1,nlayer,pdt,g1d_tmp1,g1d_tmp2) ENDIF c c ************************************************************** c c----------------------------------------------------------------------- c On incremente les tendances physiques de la temperature du sol: c --------------------------------------------------------------- DO ig=1,ngrid tsurf(ig)=tsurf(ig)+ptimestep*zdtsrf(ig) ENDDO c c----------------------------------------------------------------------- c soil temperatures: c -------------------- IF (callsoil) THEN CALL soil(ngrid,nsoilmx,.false.,inertiedat, s ptimestep,tsurf,tsoil,capcal,fluxgrd) IF(lwrite) THEN print*,'capacite du sol ',capcal(ngrid/2+1) PRINT*,'Surface Heat capacity,conduction Flux, Ts, s dTs, dt' PRINT*,capcal(igout),fluxgrd(igout),tsurf(igout), s zdtsrf(igout),ptimestep ENDIF ENDIF IF (lwrite) THEN PRINT*,'Global diagnostics for the physics' PRINT*,'Variables and their increments q and dq/dt * dt' WRITE(*,'(a6,a10,2a15)') 'Ts','dTs','ps','dps' WRITE(*,'(2f10.5,2f15.5)') s tsurf(igout),zdtsrf(igout)*ptimestep, s pplev(igout,1),pdpsrf(igout)*ptimestep WRITE(*,'(a4,a6,5a10)') 'l','u','du','v','dv','T','dT' WRITE(*,'(i4,6f10.5)') (l, s pu(igout,l),pdu(igout,l)*ptimestep, s pv(igout,l),pdv(igout,l)*ptimestep, s pt(igout,l),pdt(igout,l)*ptimestep, s l=1,nlayer) ENDIF c----------------------------------------------------------------------- c Debut des ecritures c ------------------- IF (ngrid.NE.1) THEN ! (si pas un modele 1d) c----------------------------------------------------------------------- c ecriture de la bande histoire physique (ajout 03/06/94 F.Forget) c -------------------------------------- c La physique est sauvee dans histfi juste avant que c la dynamique ne le soit dans histoire. c mais entre maintenant et l'ecriture de histoire, c on aura itau = itau +1 et remise a jour de time. c Donc on stocke lorsque mod(itau+1,iecri*day_step) =0 c Et avec temps = zday + dtvr/day_step - day_ini c (en fait dtvr = ptimestep/iphysiq) c write (*,*) 'ds la physique, itau =', iphysiq*icount -1 IF( MOD(iphysiq*icount,iecri*day_step).EQ.0) THEN ztime_fin = zday - float(day_ini) & + ptimestep/(float(iphysiq)*daysec) IF(ldrs) THEN CALL WRITEFI(ngrid,nsoilmx, s 12,ldrs, ztime_fin & ,1,co2ice,tsurf,tsoil,emis,q2) ENDIF ENDIF c----------------------------------------------------------------------- c Ecriture du fichier de reinitialisation de la physique : restartfi' c ------------------------------------------------------------------- c Remarque : On stocke restarfi c juste avant que la dynamique ne le soit dans restart. c entre maintenant et l'ecriture de restart, c on aura itau = itau +1 et remise a jour de time. c (lastcall = .true. lorsque itau+1 = itaufin) c Donc on stocke avec temps = time + dtvr IF(lastcall) THEN PRINT*,'Ecriture du fichier de reinitialisation de la physique' IF(startdrs) THEN ierr = aslun(92,'restartfi.dic', . 93,'restartfi.dat',IDRS_CREATE) ELSE OPEN(92,file='restartfi',form='unformatted',status='new', . iostat=ierr) ENDIF if (ierr.ne.0) then write(6,*)' Pb d''ouverture du fichier restartfi' write(6,*)' ierr = ', ierr call exit(1) endif ztime_fin = ptime + ptimestep/(float(iphysiq)*daysec) CALL iniwritefi(92,startdrs,pday+NINT(ztime_fin)) ztime_fin = ztime_fin - nint(ztime_fin) write(*,*)'pour writefi ztime_fin =',ztime_fin CALL WRITEFI(ngrid,nsoilmx, s 92,startdrs,ztime_fin,1,co2ice,tsurf,tsoil,emis,q2) IF(startdrs) THEN ierr=cllun(92) ELSE CLOSE(92) ENDIF ENDIF c *************************************************************** c SORTIES DIVERSES c **************** c T20m = 999. c emism = 99. c do ig=1,ngrid c T20m = min(T20m,Tsurf(ig) -43*(1-emis(ig))) c emism = min(emism,emis(ig)) c end do c write(*,*)'T20min =' , T20m c write(*,*)'presmin =' , presm c SORTIE DIAGFI (Variable Diagnostique sous format DRS) c ************** do ig=1,ngrid ps(ig) = pplev(ig,1) c tsoilf(ig) = tsoil(ig,nsoilmx) c fluxtop(ig) = zflux(ig,1) end do c call WRITEDRSFI(ngridmx,44,'Ls','Lon.solaire','deg',0,zls*57.296) call WRITEDRSFI(ngridmx,44,'T','Temperature','K',3,pt) c call WRITEDRSFI(ngridmx,44,'u','Vent zonal','m.s-1',3,pu) c call WRITEDRSFI(ngridmx,44,'v','Vent merid','m.s-1',3,pv) c call WRITEDRSFI(ngridmx,44,'W','Vent Vertical','m.s-1',3,pw) c call WRITEDRSFI(ngridmx,44,'q2','wind variance','m2.s-2',3,q2) call WRITEDRSFI(ngridmx,44,'co2ice','couche de glace co2', & 'kg/m2',2,co2ice) call WRITEDRSFI(ngridmx,44,'emis','grd emis',' ',2,emis) call WRITEDRSFI(ngridmx,44,'ps','Psurf','Pa',2,ps) call WRITEDRSFI(ngridmx,44,'Tsurf','Surf T','K',2,tsurf) call WRITEDRSFI(ngridmx,44,'zdtlwcl','dT/dt LWc','K',3,zdtlwcl) call WRITEDRSFI(ngridmx,44,'zdtsw','dT/dt SW','K',3,zdtsw) call WRITEDRSFI(ngridmx,44,'dtrad','dT/dt ','K',3,dtrad) call WRITEDRSFI(ngridmx,44,'zdtc','dt condens','K.s-1',3,zdtc) c call WRITEDRSFI(ngridmx,44,'zduc','du condens','',3,zduc) c call WRITEDRSFI(ngridmx,44,'zdvc','dv condens','',3,zdvc) c call WRITEDRSFI(ngridmx,44,'ztmpgw','dt gw','K.s-1',3,ztmp_gw) c call WRITEDRSFI(ngridmx,44,'zugw','du gw','',3,zu_gw) c call WRITEDRSFI(ngridmx,44,'zvgw','dv gw','',3,zv_gw) c call WRITEDRSFI(ngridmx,44,'ztmpcl','dt vdiff','K.s-1',3,ztmp_cl) c call WRITEDRSFI(ngridmx,44,'zucl','du vdiff','',3,zu_cl) c call WRITEDRSFI(ngridmx,44,'zvcl','dv vdiff','',3,zv_cl) c call WRITEDRSFI(ngridmx,44,'ztmpcv','dt conv','K.s-1',3,ztmp_cv) c call WRITEDRSFI(ngridmx,44,'zucv','du conv','',3,zu_cv) c call WRITEDRSFI(ngridmx,44,'zvcv','dv conv','',3,zv_cv) call WRITEDRSFI(ngridmx,44,'pdt','dt','',3,pdt) c call WRITEDRSFI(ngridmx,44,'pdu','du','',3,pdu) c call WRITEDRSFI(ngridmx,44,'pdv','dv','',3,pdv) ELSE ! (ngrid.EQ.1) si modele 1d c Sortie 1D grads (when using testphys1d) c *************************************** c c#ifdef CRAY c#else c CALL writeg1d(ngrid,nlayer,q2,'q2','q2') c CALL writeg1d(ngrid,1,tsurf(1),'tsurf','temp au sol') c#endif ENDIF ! (ngrid.EQ.1) icount=icount+1 RETURN END