*=*=*=*= radia1d.html =*=*=*=*
PROGRAM radia1d IMPLICIT NONE #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 "comsaison.h" #include "comg1d.h" #include "comvert.h" c Arguments : c ----------- INTEGER ngrid,nlayer,nq REAL plev(nlayermx+1),play(nlayermx) REAL temp(nlayermx) REAL psrf c dynamial tendencies INTEGER l,ierr,aslun,nlevel,iaer,ilayer,ilevel c REAL day_ini,time,longitude,latitude REAL zlay(nlayermx) REAL ztlev(nlayermx+1) REAL zplanck REAL zrad(nlayermx),zradc(nlayermx) REAL zdum1(nlayermx) REAL zdum2(nlayermx) REAL zdum3(nlayermx) REAL zdum4(nlayermx) REAL zdum5(nlayermx) REAL stephan REAL ztim1,ztim2,ztim3 REAL zco2,zp REAL ls,zmax,tau,tau_tot REAL dtlw(nlayermx),dtsw(nlayermx) REAL dtlwcl(nlayermx),dtswcl(nlayermx) REAL zflux(6) REAL aerosol(nlayermx,5),cst_aer,pview REAL tsurf,tsoil(nsoilmx) REAL co2ice,albedo(2),emis REAL dtrad(nlayermx),fluxrad REAL unjours real couche(ngridmx,nlayermx) . , space(ngridmx,nlayermx) . , sol(ngridmx,nlayermx) . , pnet(ngridmx,nlayermx) . , pcolc_lwmain(ngridmx,nlayermx) REAL tmp1(0:nlayermx),tmp2(0:nlayermx) REAL logps10(nlayermx) DATA stephan/5.67e-08/ DATA psrf,zmax/700.,9./ DATA ls,time,latitude,longitude/0.,12.,0.,0./ DATA diurnal/.true./ DATA tau/.5/ c WARNING declin and dist_sol are prescribed instead of Ls DATA declin,dist_sol/-24.8,1.4/ c----------------------------------------------------------------------- c 1. Initialisations : c -------------------- c PRINT*,'tau?' c READ(5,*) tau c PRINT*,'time 0 to 24 h' c READ(5,*) time c PRINT*,'latitude (degrees)' c READ(5,*) latitude tau=0 time=0 latitude=0 pi=2.*asin(1.) ls=ls*pi/180. time=time/24. latitude=latitude*pi/180. longitude=longitude*pi/180. declin=declin*pi/180. ngrid=1 nlayer=nlayermx nlevel=nlayer+1 rad=3397200. omeg=4.*asin(1.)/(88775.) g=3.72 mugaz=43.49 rcp=.256793 unjours=88775. daysec=unjours r = 8.314511*1000./mugaz cpp = r/rcp PRINT*,'Cp = ',cpp PRINT*,'R = ',r year_day = 668.6 ! duree de l'annee (sols) ~668.6 periheli = 206.66 ! dist.min. soleil-mars (Mkm) ~206.66 aphelie = 249.22 ! dist.max. soleil-mars (Mkm) ~249.22 peri_day = 485. ! date du perihelie (sols depuis printemps) obliquit = 23.98 ! Obliquite de la planete (deg) ~23.98 xradia = 1 c c calcul des pressions et altitudes en utilisant les niveaux sigma c ---------------------------------------------------------------- c CALL disvert(nlayer,rcp,sig,dsig,s,ds,dsig1,sdsig) DO ilayer=1,nlayer sig_s(ilayer)=s(ilayer)**(1.E+0/rcp) c._. play(ilayer)=psrf*s(ilayer)**(1.E+0/rcp) play(ilayer)=psrf*sig_s(ilayer) zlay(ilayer)=-200.E+0 *r*log(s(ilayer)) & /(1000.E+0 *g*rcp) c logps10(ilayer)=-log(play(ilayer)/100.E+0/10.E+0) logps10(ilayer)=-10*log(play(ilayer)/psrf) ENDDO DO ilevel=1,nlevel plev(ilevel)=psrf*sig(ilevel) ENDDO c DO l=1,nlayer c zlay(l)=zmax*(l-.5)/nlayer c plev(l)=psrf*exp(-zmax*(l-1.)/nlayer) c play(l)=psrf*exp(-zlay(l)) c ENDDO c plev(nlevel)=0. c c profil de temperature c --------------------- c tmp1(0)=0.E+0 DO ilayer=1,nlayer tmp1(ilayer)=zlay(ilayer) ENDDO call profile(nlayer+1,tmp1,tmp2) tsurf=tmp2(0) DO ilayer=1,nlayer temp(ilayer)=tmp2(ilayer) c._. temp(ilayer)=180.E+0 ENDDO c DO l=1,nlayer c temp(l)=200. c ENDDO DO l=1,nlayer dtrad(l)=0. ENDDO fluxrad=0. albedo(1)=.24 albedo(2)=.24 emis=1. CALL iniorbit(aphelie,periheli,year_day,peri_day,obliquit) c a total otempical detemph of .2 for Ps=700Pa cst_aer=tau/700. pview=1.66 CALL sucst(66,19900101,8000000,g,rad,mugaz,rcp,unjours) CALL surad(6) IF (ngrid.NE.ngridmx) THEN PRINT*,'STOP in inifis' PRINT*,'Probleme de dimenesions :' PRINT*,'ngrid = ',ngrid PRINT*,'ngridmx = ',ngridmx STOP ENDIF c....................................................................... c initialisation pour GRADS-1D c g1d_nlayer=nlayer+1 ! une couche en plus pour le sol g1d_nomfich='grads1d.dat' g1d_unitfich=40 g1d_nomctl='grads1d.ctl' g1d_unitctl=41 g1d_premier=.true. g2d_premier=.true. c c initialisation pour GRADS-1D c....................................................................... c----------------------------------------------------------------------- c 2. Calcul of the radiative tendencies : c --------------------------------------- CALL orbite(ls,dist_sol,declin) IF(diurnal) THEN ztim1=SIN(declin) ztim2=COS(declin)*COS(2.*pi*(time-.5)) ztim3=-COS(declin)*SIN(2.*pi*(time-.5)) CALL solang(ngrid,sin(longitude),cos(longitude), s sin(latitude),cos(latitude), s ztim1,ztim2,ztim3, s mu0,fract) PRINT*,'time, declin, sinlon,coslon,sinlat,coslat' PRINT*,time, declin,sin(longitude),cos(longitude), s sin(latitude),cos(latitude) ELSE CALL mucorr(ngrid,declin, lati, mu0, fract,10000.,rad) ENDIF c 2.2 Calcul of the radiative tendencies and fluxes: c -------------------------------------------------- c 2.1.1 layers tau_tot=0. DO l=1,nlayer zp=plev(1)/play(l) aerosol(l,1)=amax1(cst_aer* s (plev(l)-plev(l+1)) s *exp(.03*(1.-zp)),1.e-33) aerosol(l,1)=amax1( s tau*(plev(l)-plev(l+1))/plev(1) s *exp(.007*(1.-zp)),1.e-33) tau_tot=tau_tot+aerosol(l,1) ENDDO PRINT*,'tau total',tau_tot DO l=1,nlayermx aerosol(l,1)=aerosol(l,1)*tau/tau_tot ENDDO c 2.1.2 levels c Extrapolation for the air temperature above the surface ztlev(1)=temp(1)+ s (plev(1)-play(1))* s (temp(1)-temp(2))/(play(1)-play(2)) DO l=2,nlevel-1 ztlev(l)=0.5*(temp(l-1)+temp(l)) ENDDO ztlev(nlevel)=temp(nlayer) PRINT*,'temp' DO l=1,nlayer zdum1(l)=0. zdum2(l)=0. zdum3(l)=0. zdum4(l)=0. zdum5(l)=0. DO iaer=2,5 aerosol(l,iaer)=0. ENDDO ENDDO c 2.3 Calcul of the radiative tendencies and fluxes: c -------------------------------------------------- zco2=.95 PRINT*,' Tlay Tlev Play Plev z aerosol . dT(SW)/dt dT(LW)/dt (K/day)' DO l=1,nlayer WRITE(*,'(i3,2f7.1,2e11.3,f6.1,3e14.5)') l, s temp(l),ztlev(l),play(l),plev(l),zlay(l), s g*aerosol(l,1)/(plev(l)-plev(l+1)),dtswcl(l),dtlwcl(l) ENDDO PRINT*,'CALL radite' CALL radite(ngrid,nlayer,0,6,1,1, $ aerosol,albedo,zco2,zdum4,emis, $ mu0,zdum5, $ plev,play,zdum1,zdum2,zdum3,ztlev,tsurf,temp,pview, $ dtlw,dtsw,dtlwcl,dtswcl,zflux,zrad,zradc, $ fract,dist_sol . ,couche,sol,space,pnet,pcolc_lwmain) c 2.4 total flux and tendencies: c ------------------------------ c 2.4.1 fluxes fluxrad=emis*zflux(4) $ +zflux(5)*(1.-albedo(1)) $ +zflux(6)*(1.-albedo(2)) zplanck=tsurf*tsurf zplanck=emis* $ stephan*zplanck*zplanck fluxrad=fluxrad-zplanck c 2.4.2 temperature tendencies DO l=1,nlayer dtrad(l)=(dtsw(l)+dtlw(l))/unjours dtsw(l)=cpp*dtsw(l)/unjours dtlw(l)=dtlw(l) ENDDO c 2.5 Transformation of the radiative tendencies: c ----------------------------------------------- PRINT*,'Diagnotique for the radaition' PRINT*,'albedo, emissiv, mu0,fract,pview,Frad,Planck' PRINT*,albedo(1),emis,mu0(1),fract(1),pview, . fluxrad,zplanck PRINT*,'insolation',fract(1)*mu0(1)*1370.,' Fsol=', s zflux(5)+zflux(6) PRINT*,'unjours',unjours PRINT*,' Tlay Tlev Play Plev z aerosol . dT(SW)/dt dT(LW)/dt (K/day)' DO l=1,nlayer WRITE(*,'(i3,2f7.1,2e11.3,f6.1,3e14.5)') l, s temp(l),ztlev(l),play(l),plev(l),zlay(l), s g*aerosol(l,1)/(plev(l)-plev(l+1)),dtswcl(l),dtlwcl(l) c WRITE(55,'(2e15.5)') -dtlw(l),.001*zlay(l)*r*200./g c WRITE(56,'(2e15.5)') dtsw(l),zlay(l) ENDDO c....................................................................... c sorties GRADS-1D c c (on utilise tmp2 pour ajouter le sol => nlayer -> nlayer+1) c temp + tmep(0)=tsurf tmp2(0)=tsurf DO ilayer=1,nlayer tmp2(ilayer)=temp(ilayer) ENDDO g1d_tmp1='temp' g1d_tmp2='temperature avec tsurf' CALL writeg1d(1,nlayer+1,tmp2,g1d_tmp1,g1d_tmp2) c dtlwcl + dtlwcl(0)=dtlwcl(1) tmp2(0)=dtlwcl(1) DO ilayer=1,nlayer tmp2(ilayer)=dtlwcl(ilayer) ENDDO g1d_tmp1='dtlwc' g1d_tmp2='cooling rate avec valeur sol fictive' CALL writeg1d(1,nlayer+1,tmp2,g1d_tmp1,g1d_tmp2) c sorties GRADS-1D c c....................................................................... c....................................................................... c "fin pour GRADS-1D" c c zlay + zlay(0)= 0km (le sol) tmp2(0)=0.00001 ! pas 0 pour set zlog on DO ilayer=1,nlayer tmp2(ilayer)=zlay(ilayer) ENDDO CALL endg1d(1,nlayer+1,tmp2,1) c CALL endg1d(1,nlayer,zlay,1) c CALL endg1d(1,nlayer,logps10,ndt) c c "fin pour GRADS-1D" c....................................................................... END*********************************************************************** *********************************************************************** *********************************************************************** *********************************************************************** *=*=*=*= disvert.html =*=*=*=*
SUBROUTINE disvert(llm,kappa,sig,dsig,s,ds,dsig1,sdsig) IMPLICIT NONE c c======================================================================= c c c s = sigma ** kappa : coordonnee verticale c dsig(l) : epaisseur de la couche l ds la coord. s c sig(l) : sigma a l'interface des couches l et l-1 c ds(l) : distance entre les couches l et l-1 en coord.s c c======================================================================= c c declarations: c ------------- c integer llm real kappa,pi,x real sig(llm+1),dsig(llm),s(llm),ds(llm),dsig1(llm),sdsig(llm) integer ll,l,lllm,lllmm1,lllmp1 real abid,abid2,som,quoi,quand,snorm,sigbid,sbid REAL alpha,beta,h,zd,dz0,dz1 REAL gama,delta,deltaz,np real nhaut INTEGER ierr,ierr1,ierr2 real puiss real asig,bsig,csig,esig,zsig,p,zz,sig1 REAL SSUM,z1,z2 EXTERNAL SSUM c c----------------------------------------------------------------------- c lllm=llm lllmm1=lllm-1 lllmp1=lllm+1 pi=2.*asin(1.) OPEN(99,file='sigma.def',status='old',form='formatted', s iostat=ierr1) if(ierr1.ne.0) then close(99) open(99,file='esasig.def',status='old',form='formatted', s iostat=ierr2) endif c----------------------------------------------------------------------- c cas 1 on lit les options dans sigma.def: c ---------------------------------------- if (ierr1.eq.0) then READ(99,*) deltaz READ(99,*) h READ(99,*) beta READ(99,*) gama READ(99,*) delta READ(99,*) np CLOSE(99) alpha=deltaz/(llm*h) do l= 1, llm dsig(l) = (alpha+(1.-alpha)*exp(-beta*(llm-l)))* $ ( (tanh(gama*l)/tanh(gama*llm))**np + $ (1.-l/FLOAT(llm))*delta ) enddo sig(1)=1. do l=1,llm-1 sig(l+1)=sig(l)*(1.-dsig(l))/(1.+dsig(l)) enddo sig(llm+1)=0. do l = 1, llm dsig(l) = sig(l)-sig(l+1) enddo else if(ierr2.eq.0) then READ(99,*) h READ(99,*) dz0 READ(99,*) dz1 READ(99,*) nhaut CLOSE(99) dz0=dz0/h dz1=dz1/h sig1=(1.-dz1)/tanh(.5*(llm-1)/nhaut) esig=1. do l=1,20 print*,'esig=',esig esig=-log((1./sig1-1.)*exp(-dz0)/esig)/(llm-1.) enddo csig=(1./sig1-1.)/(exp(esig)-1.) DO L = 2, llm zz=csig*(exp(esig*(l-1.))-1.) sig(l) =1./(1.+zz) & * tanh(.5*(llm+1-l)/nhaut) ENDDO sig(1)=1. sig(llm+1)=0. do l = 1, llm dsig(l) =sig(l)-sig(l+1) enddo else print*,'WARNING!!! Ancienne discretisation verticale' stop h=7. snorm = 0. do l = 1, llm x = 2.*asin(1.) * (float(l)-0.5) / float(llm+1) dsig(l) = 1.0 + 7.0 * sin(x)**2 snorm = snorm + dsig(l) enddo snorm = 1./snorm do l = 1, llm dsig(l) = dsig(l)*snorm enddo sig(llm+1) = 0. do l = llm, 1, -1 sig(l) = sig(l+1) + dsig(l) enddo endif c----------------------------------------------------------------------- c calcul de s, ds, sdsig... c ------------------------- quoi = 1. + 2.* kappa s( llm ) = 1. s(lllmm1) = quoi IF( llm.gt.2 ) THEN DO ll = 2, lllmm1 l = lllmp1 - ll quand = sig(l+1)/ sig(l) s(l-1) = quoi * (1.-quand) * s(l) + quand * s(l+1) ENDDO END IF c snorm=(1.-.5*sig(2)+kappa*(1.-sig(2)))*s(1)+.5*sig(2)*s(2) DO l = 1, llm s(l) = s(l)/ snorm ENDDO DO l = 2, llm ds(l) = s(l-1) - s(l) ENDDO ds(1) = 1. - s(1) c DO l = 1, llm sdsig(l) = s(l) * dsig(l) dsig1(l)= 1./dsig(l) ENDDO c----------------------------------------------------------------------- c c Diagnostique sur la discretisation verticale: c --------------------------------------------- c print*,'Diagnostique de la discretisation verticale' print* print*,'comparaison de sig(l) et (s(l)+s(l+1))/2)**(1/K)' do 14 l=1,llm-1 sigbid=(0.5*(s(l)+s(l+1)))**(1./kappa) print*,'sig(',l+1,') = ',sig(l+1), S ' valeur approchee :',sigbid,' ',dsig(l) 14 continue print* print*,'comparaison de s(l) et (sig(l)+sig(l+1))/2)**K' do 15 l=1,llm sbid=(0.5*(sig(l+1)+sig(l)))**kappa print*,' s(',l,') = ',s(l), S ' valeur approchee :',sbid 15 continue c PRINT*,'Altitude approchee z,dz' PRINT* z1=0. print*,' l Z DZ Ztop dsig' DO 18 l=1,llm-1 z2=-h*log(sig(l+1)) write(*,'(i5,3x,4f8.4)') l,-h*log(s(l))/kappa,z2-z1,z2 & ,dsig(l) c write(14,'(3x,i5,1f10.4)') l,-h*log(s(l))/kappa z1=z2 18 CONTINUE write(*,'(i5,3x,3f8.4)') l,-h*log(s(llm))/kappa c write(14,'(3x,i5,1f10.4)') l,-h*log(s(llm))/kappa c----------------------------------------------------------------------- RETURN END