Index: trunk/LMDZ.GENERIC/libf/phygeneric/aerave_new.F =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/aerave_new.F (revision 4062) +++ (revision ) @@ -1,307 +1,0 @@ - SUBROUTINE aerave_new ( ndata, - & longdata,epdata,omegdata,gdata, - & longref,epref,temp,nir,longir - & ,epir,omegir,gir,qref,omegaref ) - - - IMPLICIT NONE -c....................................................................... -c -c R.Fournier 02/1996 -c (modif F.Forget 02/1996) -c le spectre est decoupe en "nir" bandes et cette routine calcule -c les donnees radiatives moyenne sur chaque bande : l'optimisation -c est faite pour une temperature au sol "temp" et une epaisseur -c optique de l'atmosphere "epref" a la longueur d'onde "longref" -c -c dans la version actuelle, les ponderations sont independantes de -c l'epaisseur optique : c'est a dire que "omegir", "gir" -c et "epir/epre" sont independants de "epref". -c en effet les ponderations sont choisies pour une solution exacte -c en couche mince et milieu isotherme. -c -c entree -c -c ndata : taille des champs data -c longdata,epdata,omegdata,gdata : proprietes radiative de l'aerosol -c (longdata longueur d'onde en METRES) -c * longref : longueur d'onde a laquelle l'epaisseur optique -c est connue -c * epref : epaisseur optique a longref -c * temp : temperature choisie pour la ponderation (Planck) -c * nir : nombre d'intervals dans la discretisation spectrale -c du GCM -c * longir : longueurs d'onde definissant ces intervals -c -c sortie -c -c * epir : epaisseur optique moyenne pour chaque interval -c * omegir : "scattering albedo" moyen pour chaque interval -c * gir : "assymetry factor" moyen pour chaque interval -c * qref : extinction coefficient at reference wavelength -c * omegaref : single scat. albedo at reference wavelength -c -c....................................................................... -c - REAL longref - REAL epref - REAL temp - INTEGER nir - REAL*8 longir(nir+1) - REAL epir(nir) - REAL omegir(nir) - REAL gir(nir) -c -c....................................................................... -c - INTEGER iir - INTEGER,PARAMETER :: nirmx=1900 - INTEGER idata,ndata -c -c....................................................................... -c - REAL emit - REAL totalemit(nirmx) - REAL longdata(ndata),epdata(ndata) - & ,omegdata(ndata),gdata(ndata) - REAL qextcorrdata(ndata) - INTEGER ibande - INTEGER,PARAMETER :: nbande=1000 - REAL long,deltalong - INTEGER ilong - INTEGER i1,i2 - REAL c1,c2 - REAL factep,qextcorr,omeg,g - REAL qref,omegaref -c -c....................................................................... -c - DOUBLE PRECISION tmp1 - REAL tmp2,tmp3 -c -c - long=longref - -c check ordering of longdata - DO idata=1,ndata-1 - IF (longdata(1).LT.longdata(ndata)) THEN - IF (.not.(longdata(idata).LT.longdata(idata+1))) THEN - call abort_physic("aerave_new", - & "Non descending order in longdata",1) - ENDIF - ELSEIF (longdata(1).GT.longdata(ndata)) THEN - IF (.not.(longdata(idata).GT.longdata(idata+1))) THEN - call abort_physic("aerave_new", - & "Non ascending order in longdata",1) - ENDIF - ENDIF - ENDDO -c - - - - -c******************************************************** -c interpolation -c wavelengths (longdata) from data file in ascending order - IF (longdata(1).LT.longdata(ndata)) THEN - ilong=1 - DO idata=2,ndata - IF (long.gt.longdata(idata)) ilong=idata - ENDDO - i1=ilong - i2=ilong+1 - IF (i2.gt.ndata) i2=ndata - IF (long.lt.longdata(1)) i2=1 - IF (i1.eq.i2) THEN - c1=1.E+0 - c2=0.E+0 - ELSE - c1=(longdata(i2)-long) / (longdata(i2)-longdata(i1)) - c2=(longdata(i1)-long) / (longdata(i1)-longdata(i2)) - ENDIF - qref=c1*epdata(i1)+c2*epdata(i2) - omegaref=c1*omegdata(i1)+c2*omegdata(i2) - factep=qref/epref - DO idata=1,ndata - qextcorrdata(idata)=epdata(idata)/factep - ENDDO -c wavelengths (longdata) from data file in descending order - ELSEIF (longdata(1).GT.longdata(ndata)) THEN - ilong=1 - DO idata=2,ndata - IF (long.lt.longdata(idata)) ilong=idata - ENDDO - i1=ilong+1 - i2=ilong - IF (i1.gt.ndata) i1=ndata - IF (long.gt.longdata(1)) i1=1 - IF (i1.eq.i2) THEN - c1=1.E+0 - c2=0.E+0 - ELSE - c1=(longdata(i2)-long) / (longdata(i2)-longdata(i1)) - c2=(longdata(i1)-long) / (longdata(i1)-longdata(i2)) - ENDIF - qref=c1*epdata(i1)+c2*epdata(i2) - omegaref=c1*omegdata(i1)+c2*omegdata(i2) - factep=qref/epref - DO idata=1,ndata - qextcorrdata(idata)=epdata(idata)/factep - ENDDO - ENDIF - -c******************************************************** -c....................................................................... -c wavelengths (longdata) from data file in ascending order -c....................................................................... - IF (longdata(1).LT.longdata(ndata)) THEN - DO iir=1,nir -c -c....................................................................... -c - deltalong=(longir(iir+1)-longir(iir)) / nbande - totalemit(iir)=0.E+0 - epir(iir)=0.E+0 - omegir(iir)=0.E+0 - gir(iir)=0.E+0 -c -c....................................................................... -c - DO ibande=1,nbande -c -c....................................................................... -c - long=longir(iir) + (ibande-0.5E+0) * deltalong - CALL blackl(DBLE(long),DBLE(temp),tmp1) - emit=REAL(tmp1) -c -c....................................................................... -c -c interpolation - ilong=1 - DO idata=2,ndata - IF (long.gt.longdata(idata)) ilong=idata - ENDDO - i1=ilong - i2=ilong+1 - IF (i2.gt.ndata) i2=ndata - IF (long.lt.longdata(1)) i2=1 - IF (i1.eq.i2) THEN - c1=1.E+0 - c2=0.E+0 - ELSE - c1=(longdata(i2)-long) / (longdata(i2)-longdata(i1)) - c2=(longdata(i1)-long) / (longdata(i1)-longdata(i2)) - ENDIF - qextcorr=c1*qextcorrdata(i1)+c2*qextcorrdata(i2) - omeg=c1*omegdata(i1)+c2*omegdata(i2) - g=c1*gdata(i1)+c2*gdata(i2) -c -c....................................................................... -c - totalemit(iir)=totalemit(iir)+deltalong*emit - epir(iir)=epir(iir)+deltalong*emit*qextcorr - omegir(iir)=omegir(iir)+deltalong*emit*omeg*qextcorr - gir(iir)=gir(iir)+deltalong*emit*omeg*qextcorr*g -c -c....................................................................... -c - ENDDO -c -c....................................................................... -c - gir(iir)=gir(iir)/omegir(iir) - omegir(iir)=omegir(iir)/epir(iir) - epir(iir)=epir(iir)/totalemit(iir) -c -c....................................................................... -c - ENDDO -c....................................................................... -c wavelengths (longdata) from data file in descending order -c....................................................................... - ELSEIF (longdata(1).GT.longdata(ndata)) THEN - DO iir=1,nir -c -c....................................................................... -c - deltalong=(longir(iir+1)-longir(iir)) / nbande - totalemit(iir)=0.E+0 - epir(iir)=0.E+0 - omegir(iir)=0.E+0 - gir(iir)=0.E+0 -c -c....................................................................... -c - DO ibande=1,nbande -c -c....................................................................... -c - long=longir(iir) + (ibande-0.5E+0) * deltalong - CALL blackl(DBLE(long),DBLE(temp),tmp1) - emit=REAL(tmp1) -c -c....................................................................... -c -c interpolation - ilong=1 - DO idata=2,ndata - IF (long.lt.longdata(idata)) ilong=idata - ENDDO - i1=ilong+1 - i2=ilong - IF (i1.gt.ndata) i1=ndata - IF (long.gt.longdata(1)) i1=1 - IF (i1.eq.i2) THEN - c1=1.E+0 - c2=0.E+0 - ELSE - c1=(longdata(i2)-long) / (longdata(i2)-longdata(i1)) - c2=(longdata(i1)-long) / (longdata(i1)-longdata(i2)) - ENDIF - qextcorr=c1*qextcorrdata(i1)+c2*qextcorrdata(i2) - omeg=c1*omegdata(i1)+c2*omegdata(i2) - g=c1*gdata(i1)+c2*gdata(i2) -c -c....................................................................... -c - totalemit(iir)=totalemit(iir)+deltalong*emit - epir(iir)=epir(iir)+deltalong*emit*qextcorr - omegir(iir)=omegir(iir)+deltalong*emit*omeg*qextcorr - gir(iir)=gir(iir)+deltalong*emit*omeg*qextcorr*g -c -c....................................................................... -c - ENDDO -c -c....................................................................... -c - gir(iir)=gir(iir)/omegir(iir) - omegir(iir)=omegir(iir)/epir(iir) - epir(iir)=epir(iir)/totalemit(iir) -c -c....................................................................... -c - ENDDO - ENDIF -c -c******************************************************** -c -c...................................................................... -c -c Diagnostic de controle si on moyenne sur tout le spectre vis ou IR : -c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -c tmp2=0.E+0 -c DO iir=1,nir -c tmp2=tmp2+totalemit(iir) -c ENDDO -c tmp3=5.67E-8 * temp**4 -c IF (abs((tmp2-tmp3)/tmp3).gt.0.05E+0) THEN -c PRINT *,'!!!! <---> il manque du Planck (voir moyenne.F)' -c PRINT *,'somme des bandes :',tmp2,'--- Planck:',tmp3 -c ENDIF -c -c...................................................................... -c - END Index: trunk/LMDZ.GENERIC/libf/phygeneric/aeropacity.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/aeropacity.F90 (revision 4062) +++ (revision ) @@ -1,1096 +1,0 @@ -module aeropacity_mod - -implicit none - -contains - - Subroutine aeropacity(ngrid,nlayer,nq,pplay,pplev,pt,pq,zls, & - aerosol,reffrad,nueffrad, QREFvis3d,QREFir3d,tau_col, & - cloudfrac,totcloudfrac,clearsky) - - use radinc_h, only : L_TAUMAX,naerkind - use aerosol_mod, only: iaero_nlay, iaero_generic, & - iaero_aurora, iaero_back2lay, iaero_co2, & - iaero_dust, iaero_h2o, iaero_h2so4, & - iaero_nh3, i_rgcs_ice, noaero, & - iaero_venus1, iaero_venus2, iaero_venus2p, & - iaero_venus3, iaero_venusUV - USE tracer_h, only: noms,rho_co2,rho_ice,rho_q,mmol - use comcstfi_mod, only: g, pi, mugaz, avocado - use geometry_mod, only: latitude - use callkeys_mod, only: aerofixco2,aerofixh2o,kastprof,cloudlvl, & - CLFvarying,CLFfixval,dusttau,timedepdust, & - pres_bottom_tropo,pres_top_tropo,obs_tau_col_tropo, & - pres_bottom_strato,pres_top_strato,obs_tau_col_strato, & - tau_nh3_cloud, pres_nh3_cloud, & - nlayaero, aeronlay_tauref, aeronlay_choice, & - aeronlay_pbot, aeronlay_ptop, aeronlay_sclhght, & - aerogeneric - use generic_tracer_index_mod, only: generic_tracer_index - implicit none - -!================================================================== -! -! Purpose -! ------- -! Compute aerosol optical depth in each gridbox. -! -! Authors -! ------- -! F. Forget -! F. Montmessin (water ice scheme) -! update J.-B. Madeleine (2008) -! dust removal, simplification by Robin Wordsworth (2009) -! Generic n-layer aerosol - J. Vatant d'Ollone (2020) -! Radiative Generic Condensable Species - Lucas Teinturier (2022) -! -! Input -! ----- -! ngrid Number of horizontal gridpoints -! nlayer Number of layers -! nq Number of tracers -! pplev Pressure (Pa) at each layer boundary -! pq Aerosol mixing ratio -! reffrad(ngrid,nlayer,naerkind) Aerosol effective radius -! QREFvis3d(ngrid,nlayer,naerkind) \ 3d extinction coefficients -! QREFir3d(ngrid,nlayer,naerkind) / at reference wavelengths -! -! Output -! ------ -! aerosol Aerosol optical depth in layer l, grid point ig -! tau_col Total column optical depth at grid point ig -! -!======================================================================= - - INTEGER,INTENT(IN) :: ngrid ! number of atmospheric columns - INTEGER,INTENT(IN) :: nlayer ! number of atmospheric layers - INTEGER,INTENT(IN) :: nq ! number of tracers - REAL,INTENT(IN) :: pplay(ngrid,nlayer) ! mid-layer pressure (Pa) - REAL,INTENT(IN) :: pplev(ngrid,nlayer+1) ! inter-layer pressure (Pa) - REAL,INTENT(IN) :: pq(ngrid,nlayer,nq) ! tracers (.../kg_of_air) - REAL,INTENT(IN) :: zls ! Stellar longitude (rad) - REAL,INTENT(IN) :: pt(ngrid,nlayer) ! mid-layer temperature (K) - REAL,INTENT(OUT) :: aerosol(ngrid,nlayer,naerkind) ! aerosol optical depth - REAL,INTENT(IN) :: reffrad(ngrid,nlayer,naerkind) ! aerosol effective radius - REAL,INTENT(IN) :: nueffrad(ngrid,nlayer,naerkind) ! aerosol effective variance - REAL,INTENT(IN) :: QREFvis3d(ngrid,nlayer,naerkind) ! extinction coefficient in the visible - REAL,INTENT(IN) :: QREFir3d(ngrid,nlayer,naerkind) - REAL,INTENT(OUT):: tau_col(ngrid) !column integrated visible optical depth - ! BENJAMIN MODIFS - real,intent(in) :: cloudfrac(ngrid,nlayer) ! cloud fraction - real,intent(out) :: totcloudfrac(ngrid) ! total cloud fraction - logical,intent(in) :: clearsky - - real aerosol0, obs_tau_col_aurora, pm - real pcloud_deck, cloud_slope - - real dp_strato(ngrid) - real dp_tropo(ngrid) - real dp_layer(ngrid) - - INTEGER l,ig,iq,iaer,ia - - LOGICAL,SAVE :: firstcall=.true. -!$OMP THREADPRIVATE(firstcall) - REAL CBRT - EXTERNAL CBRT - - INTEGER,SAVE :: i_co2ice=0 ! co2 ice - INTEGER,SAVE :: i_h2oice=0 ! water ice -!$OMP THREADPRIVATE(i_co2ice,i_h2oice) - CHARACTER(LEN=20) :: tracername ! to temporarily store text - - ! for dust profiles - real topdust, expfactor, zp - REAL taudusttmp(ngrid) ! Temporary dust opacity used before scaling - REAL tauh2so4tmp(ngrid) ! Temporary h2so4 opacity used before scaling - - ! time-dependent dust (MM) - real zlsconst, odpref, taueq, tauS, tauN - real tau_pref_MGS(ngrid), tauscaling(ngrid) - - real CLFtot - integer igen_ice,igen_vap ! to store the index of generic tracer - logical dummy_bool ! dummy boolean just in case we need one - ! integer i_rgcs_ice(aerogeneric) - ! for venus clouds - real :: p_bot,p_top,h_bot,h_top,mode_dens,h_lay - - ! identify tracers - IF (firstcall) THEN - ia =0 - write(*,*) "Tracers found in aeropacity:" - do iq=1,nq - tracername=noms(iq) - if (tracername.eq."co2_ice") then - i_co2ice=iq - write(*,*) "i_co2ice=",i_co2ice - - endif - if (tracername.eq."h2o_ice") then - i_h2oice=iq - write(*,*) "i_h2oice=",i_h2oice - endif - enddo - - if (noaero) then - print*, "No active aerosols found in aeropacity" - else - print*, "If you would like to use aerosols, make sure any old" - print*, "start files are updated in newstart using the option" - print*, "q=0" - write(*,*) "Active aerosols found in aeropacity:" - endif - - if ((iaero_co2.ne.0).and.(.not.noaero)) then - print*, 'iaero_co2= ',iaero_co2 - endif - if (iaero_h2o.ne.0) then - print*,'iaero_h2o= ',iaero_h2o - endif - if (iaero_dust.ne.0) then - print*,'iaero_dust= ',iaero_dust - endif - if (iaero_h2so4.ne.0) then - print*,'iaero_h2so4= ',iaero_h2so4 - endif - if (iaero_back2lay.ne.0) then - print*,'iaero_back2lay= ',iaero_back2lay - endif - if (iaero_nh3.ne.0) then - print*,'iaero_nh3= ',iaero_nh3 - endif - if (iaero_nlay(1).ne.0) then - print*,'iaero_nlay= ',iaero_nlay(:) - endif - if (iaero_aurora.ne.0) then - print*,'iaero_aurora= ',iaero_aurora - endif - - if (iaero_venus1.ne.0) then - print*,'iaero_venus1= ',iaero_venus1 - endif - if (iaero_venus2.ne.0) then - print*,'iaero_venus2= ',iaero_venus2 - endif - if (iaero_venus2p.ne.0) then - print*,'iaero_venus2p= ',iaero_venus2p - endif - if (iaero_venus3.ne.0) then - print*,'iaero_venus3= ',iaero_venus3 - endif - if (iaero_venusUV.ne.0) then - print*,'iaero_venusUV= ',iaero_venusUV - endif - - if (aerogeneric .ne. 0) then - print*,"iaero_generic= ",iaero_generic(:) - endif - firstcall=.false. - ENDIF ! of IF (firstcall) - - -! --------------------------------------------------------- -!================================================================== -! CO2 ice aerosols -!================================================================== - - if (iaero_co2.ne.0) then - iaer=iaero_co2 -! 1. Initialization - aerosol(1:ngrid,1:nlayer,iaer)=0.0 -! 2. Opacity calculation - if (noaero) then ! aerosol set to zero - aerosol(1:ngrid,1:nlayer,iaer)=0.0 - elseif (aerofixco2.or.(i_co2ice.eq.0)) then ! CO2 ice cloud prescribed - aerosol(1:ngrid,1:nlayer,iaer)=1.e-9 - !aerosol(1:ngrid,12,iaer)=4.0 ! single cloud layer option - else - DO ig=1, ngrid - DO l=1,nlayer-1 ! to stop the rad tran bug - - aerosol0 = & - ( 0.75 * QREFvis3d(ig,l,iaer) / & - ( rho_co2 * reffrad(ig,l,iaer) ) ) * & - ( pq(ig,l,i_co2ice) + 1.E-9 ) * & - ( pplev(ig,l) - pplev(ig,l+1) ) / g - aerosol0 = max(aerosol0,1.e-9) - aerosol0 = min(aerosol0,L_TAUMAX) - aerosol(ig,l,iaer) = aerosol0 -! aerosol(ig,l,iaer) = 0.0 -! print*, aerosol(ig,l,iaer) -! using cloud fraction -! aerosol(ig,l,iaer) = -log(1 - CLF + CLF*exp(-aerosol0/CLF)) -! aerosol(ig,l,iaer) = min(aerosol(ig,l,iaer),L_TAUMAX) - - - ENDDO - ENDDO - end if ! if fixed or varying - end if ! if CO2 aerosols -!================================================================== -! Water ice / liquid -!================================================================== - - if (iaero_h2o.ne.0) then - iaer=iaero_h2o -! 1. Initialization - aerosol(1:ngrid,1:nlayer,iaer)=0.0 -! 2. Opacity calculation - if (aerofixh2o.or.(i_h2oice.eq.0).or.clearsky) then - aerosol(1:ngrid,1:nlayer,iaer) =1.e-9 - - ! put cloud at cloudlvl - if(kastprof.and.(cloudlvl.ne.0.0))then - ig=1 - do l=1,nlayer - if(int(cloudlvl).eq.l)then - !if(cloudlvl.gt.(pplay(ig,l)/pplev(ig,1)))then - print*,'Inserting cloud at level ',l - !aerosol(ig,l,iaer)=10.0 - - rho_ice=920.0 - - ! the Kasting approximation - aerosol(ig,l,iaer) = & - ( 0.75 * QREFvis3d(ig,l,iaer) / & - ( rho_ice * reffrad(ig,l,iaer) ) ) * & - !( pq(ig,l,i_h2oice) + 1.E-9 ) * & - ( 4.0e-4 + 1.E-9 ) * & - ( pplev(ig,l) - pplev(ig,l+1) ) / g - - - open(115,file='clouds.out',form='formatted') - write(115,*) l,aerosol(ig,l,iaer) - close(115) - - return - endif - end do - - call abort_physic("aeropacity", "Something wrong happened on water ice liquid opacity calculation",1) - endif - - else - - do ig=1, ngrid - !do l=1,nlayer-1 ! to stop the rad tran bug - do l=1,nlayer !JL18 if aerosols are present in the last layer we must account for them. Provides better upper boundary condition in the IR. They must however be put to zero in the sw (see optcv) - ! same correction should b-probably be done for other aerosol types. - aerosol(ig,l,iaer) = & !modification by BC - ( 0.75 * QREFvis3d(ig,l,iaer) / & - ( rho_ice * reffrad(ig,l,iaer) ) ) * & - ! pq(ig,l,i_h2oice) * & !JL I dropped the +1e-9 here to have the same - !( pplev(ig,l) - pplev(ig,l+1) ) / g ! opacity in the clearsky=true and the - ! clear=false/pq=0 case - ( pq(ig,l,i_h2oice) + 1.E-9 ) * & ! Doing this makes the code unstable, so I have restored it (RW) - ( pplev(ig,l) - pplev(ig,l+1) ) / g - - enddo - enddo - - if(CLFvarying)then - call totalcloudfrac(ngrid,nlayer,nq,cloudfrac,totcloudfrac,pplev,pq,aerosol(1,1,iaer)) - do ig=1, ngrid - !do l=1,nlayer-1 ! to stop the rad tran bug - do l=1,nlayer !JL18 if aerosols are present in the last layer we must account for them. Provides better upper boundary condition in the IR. They must however be put to zero in the sw (see optcv) - CLFtot = max(totcloudfrac(ig),0.01) - aerosol(ig,l,iaer)=aerosol(ig,l,iaer)/CLFtot - aerosol(ig,l,iaer) = max(aerosol(ig,l,iaer),1.e-9) - enddo - enddo - else - do ig=1, ngrid - !do l=1,nlayer-1 ! to stop the rad tran bug - do l=1,nlayer !JL18 if aerosols are present in the last layer we must account for them. Provides better upper boundary condition in the IR. They must however be put to zero in the sw (see optcv) - CLFtot = CLFfixval - aerosol(ig,l,iaer)=aerosol(ig,l,iaer)/CLFtot - aerosol(ig,l,iaer) = max(aerosol(ig,l,iaer),1.e-9) - enddo - enddo - end if!(CLFvarying) - endif !(aerofixed.or.(i_h2oice.eq.0).or.clearsky) - - end if ! End if h2o aerosol - -!================================================================== -! Dust -! Either constant/homogeneous or -! following MGS scenario for -! present-day Mars as per: -! Montmessin et al., 2004 -! (DOI: 10.1029/2004JE002284) -!================================================================== - if (iaero_dust.ne.0) then - iaer=iaero_dust -! 1. Initialization - aerosol(1:ngrid,1:nlayer,iaer)=0.0 - -! 2. Opacity calculation - - IF (timedepdust) THEN -! Time-dependent dust (MGS scenarion for present-day Mars) - - zlsconst = sin(zls-2.76) - taudusttmp(:) = 0 - odpref = 610. ! Reference pressure (Pa) of - ! DOD (Dust optical Depth) tau_pref_* - - DO l=1,nlayer-1 - DO ig=1,ngrid - - topdust = 60.+18.*zlsconst & ! From - - (32.+18.*zlsconst)*(sin(latitude(ig)))**4 & ! Montmessin - - 8.*zlsconst*(sin(latitude(ig)))**5 ! et al. 2004 - if (pplay(ig,l).ge.odpref/(988.**(topdust/70.))) then ! What is the use of this line? - zp = (odpref/pplay(ig,l))**(70./topdust) - expfactor = max(exp(0.007*(1.-max(zp,1.))),1.e-3) - else - expfactor = 1.e-3 - endif - -! Vertical scaling function - aerosol(ig,l,iaer) = (pplev(ig,l)-pplev(ig,l+1)) & - * expfactor - -! Horizontal scaling of the dust opacity - if (l==1) then - - taueq = 0.2 + (0.5-0.2) * (cos(0.5*(zls-4.363)))**14 - tauS = 0.1 + (0.5-0.1) * (cos(0.5*(zls-4.363)))**14 - tauN = 0.1 - - if (latitude(ig).ge.0) then - ! Northern hemisphere - tau_pref_MGS(ig) = tauN + (taueq-tauN)*0.5 & - *(1+tanh((45-latitude(ig)*180./pi)*6/60)) - else - ! Southern hemisphere - tau_pref_MGS(ig) = tauS + (taueq-tauS)*0.5 & - *(1+tanh((45+latitude(ig)*180./pi)*6/60)) - endif - endif - - ENDDO - ENDDO - - ELSE -! Fixed dust - -! expfactor=0. - topdust=30.0 ! km (used to be 10.0 km) LK - - DO l=1,nlayer-1 - DO ig=1,ngrid - - -! Typical mixing ratio profile - - zp=(pplev(ig,1)/pplay(ig,l))**(70./topdust) - expfactor=max(exp(0.007*(1.-max(zp,1.))),1.e-3) - -! Vertical scaling function - aerosol(ig,l,iaer)= (pplev(ig,l)-pplev(ig,l+1)) & - *expfactor - - - ENDDO - ENDDO - ENDIF ! of if timedepdust - - -! Rescaling each layer to reproduce the choosen (or assimilated) -! dust extinction opacity at visible reference wavelength, which -! is scaled to the surface pressure pplev(ig,1) - - taudusttmp(1:ngrid)=0. - DO l=1,nlayer - DO ig=1,ngrid - taudusttmp(ig) = taudusttmp(ig) & - + aerosol(ig,l,iaer) - ENDDO - ENDDO - - if (timedepdust) then -! Dust opacity scaling - tauscaling(:) = tau_pref_MGS(:) * pplev(:,1) / odpref - else - tauscaling(:) = 1 - endif - - DO l=1,nlayer-1 - DO ig=1,ngrid - aerosol(ig,l,iaer) = max(1E-20, & - dusttau * tauscaling(ig) & - * pplev(ig,1) / pplev(ig,1) & ! what is the use of this line ? (MM) - * aerosol(ig,l,iaer) & - / taudusttmp(ig)) - - - ENDDO - ENDDO - - call writediagfi(ngrid,"taudust","Optical depth at pref","-",2, dusttau * tauscaling) - - end if ! If dust aerosol - -!================================================================== -! H2SO4 -!================================================================== -! added by LK - if (iaero_h2so4.ne.0) then - iaer=iaero_h2so4 - -! 1. Initialization - aerosol(1:ngrid,1:nlayer,iaer)=0.0 - - -! 2. Opacity calculation - -! expfactor=0. - DO l=1,nlayer-1 - DO ig=1,ngrid -! Typical mixing ratio profile - - zp=(pplev(ig,1)/pplay(ig,l))**(70./30) !emulating topdust - expfactor=max(exp(0.007*(1.-max(zp,1.))),1.e-3) - -! Vertical scaling function - aerosol(ig,l,iaer)= (pplev(ig,l)-pplev(ig,l+1))*expfactor - - ENDDO - ENDDO - tauh2so4tmp(1:ngrid)=0. - DO l=1,nlayer - DO ig=1,ngrid - tauh2so4tmp(ig) = tauh2so4tmp(ig) + aerosol(ig,l,iaer) - ENDDO - ENDDO - DO l=1,nlayer-1 - DO ig=1,ngrid - aerosol(ig,l,iaer) = max(1E-20, & - 1 & - * pplev(ig,1) / pplev(ig,1) & - * aerosol(ig,l,iaer) & - / tauh2so4tmp(ig)) - - ENDDO - ENDDO - -! 1/700. is assuming a "sulfurtau" of 1 -! Sulfur aerosol routine to be improved. -! aerosol0 = & -! ( 0.75 * QREFvis3d(ig,l,iaer) / & -! ( rho_h2so4 * reffrad(ig,l,iaer) ) ) * & -! ( pq(ig,l,i_h2so4) + 1.E-9 ) * & -! ( pplev(ig,l) - pplev(ig,l+1) ) / g -! aerosol0 = max(aerosol0,1.e-9) -! aerosol0 = min(aerosol0,L_TAUMAX) -! aerosol(ig,l,iaer) = aerosol0 - -! ENDDO -! ENDDO - end if - - -! --------------------------------------------------------- -!================================================================== -! Two-layer aerosols (unknown composition) -! S. Guerlet (2013) - Modif by J. Vatant d'Ollone (2020) -! -! This scheme is deprecated and left for retrocompatibility -! You should use the n-layer scheme below ! -! -!================================================================== - - if (iaero_back2lay .ne.0) then - iaer=iaero_back2lay -! 1. Initialization - aerosol(1:ngrid,1:nlayer,iaer)=0.0 -! 2. Opacity calculation - - -! JVO 20 : Modif to have each of the layers (strato and tropo) correctly normalized -! Otherwise we previously had the total optical depth correct but for each -! separately, so it didn't match the input values + what's more normalizing -! to the sum was making them non-independent : eg changing tau_tropo was -! affecting stratopsheric values of optical depth ... -! -! Note that the main consequence of the former version bug was (in most cases) -! to strongly underestimate the stratospheric optical depths compared to the -! required values, eg, with tau_tropo=10 and tau_strato=0.1, you actually ended -! with an actual tau_strato of 1E-4 ... ! -! -! NB : Because of the extra transition opacity if the layers are non contiguous, -! be aware that at the the bottom we have tau > tau_strato + tau_tropo - - DO ig=1,ngrid - dp_tropo(ig) = 0.D0 - dp_strato(ig) = 0.D0 - DO l=1,nlayer-1 - aerosol(ig,l,iaer) = ( pplev(ig,l) - pplev(ig,l+1) ) - !! 1. below tropospheric layer: no aerosols - IF (pplev(ig,l) .gt. pres_bottom_tropo) THEN - aerosol(ig,l,iaer) = 0.D0 - !! 2. tropo layer - ELSEIF (pplev(ig,l) .le. pres_bottom_tropo .and. pplev(ig,l) .ge. pres_top_tropo) THEN - dp_tropo(ig) = dp_tropo(ig) + aerosol(ig,l,iaer) - !! 3. linear transition - ! JVO 20 : This interpolation needs to be done AFTER we set strato and tropo (see below) - !! 4. strato layer - ELSEIF (pplev(ig,l) .le. pres_bottom_strato .and. pplev(ig,l) .ge. pres_top_strato) THEN - dp_strato(ig) = dp_strato(ig) + aerosol(ig,l,iaer) - !! 5. above strato layer: no aerosols - ELSEIF (pplev(ig,l) .lt. pres_top_strato) THEN - aerosol(ig,l,iaer) = 0.D0 - ENDIF - ENDDO - ENDDO - -! 3. Re-normalize to the (input) observed (total) column (for each of the layers) - - DO ig=1,ngrid - DO l=1,nlayer-1 - IF (pplev(ig,l) .le. pres_bottom_tropo .and. pplev(ig,l) .ge. pres_top_tropo) THEN - aerosol(ig,l,iaer) = obs_tau_col_tropo*aerosol(ig,l,iaer)/dp_tropo(ig) - ELSEIF (pplev(ig,l) .lt. pres_top_tropo .and. pplev(ig,l) .gt. pres_bottom_strato) THEN - expfactor=log(pplev(ig,l)/pres_top_tropo)/log(pres_bottom_strato/pres_top_tropo) - aerosol(ig,l,iaer) = (obs_tau_col_strato/dp_strato(ig))**expfactor & - * (obs_tau_col_tropo/dp_tropo(ig))**(1.0-expfactor) & - * aerosol(ig,l,iaer) - ELSEIF (pplev(ig,l) .le. pres_bottom_strato .and. pplev(ig,l) .ge. pres_top_strato) THEN - aerosol(ig,l,iaer) = obs_tau_col_strato*aerosol(ig,l,iaer)/dp_strato(ig) - ENDIF - ENDDO - ENDDO - - - end if ! if Two-layer aerosols - -!================================================================== -! Saturn/Jupiter ammonia cloud = thin cloud (scale height 0.2 hard coded...) -! S. Guerlet (2013) -! JVO 20 : You should now use the generic n-layer scheme below -!================================================================== - - if (iaero_nh3 .ne.0) then - iaer=iaero_nh3 -! 1. Initialization - aerosol(1:ngrid,1:nlayer,iaer)=0.D0 -! 2. Opacity calculation - DO ig=1,ngrid - - DO l=1,nlayer-1 - !! 1. below cloud layer: no opacity - - IF (pplev(ig,l) .gt. pres_nh3_cloud ) THEN - aerosol(ig,l,iaer) = 0.D0 - - ELSEIF (pplev(ig,l) .le. pres_nh3_cloud ) THEN - cloud_slope=5. !!(hard-coded, correspond to scale height 0.2) - aerosol(ig,l,iaer) = ((pplev(ig,l)/pres_nh3_cloud)**(cloud_slope))*tau_nh3_cloud - - ENDIF - ENDDO - - END DO - -! 3. Re-normalize to observed total column - dp_layer(:)=0.0 - DO l=1,nlayer - DO ig=1,ngrid - dp_layer(ig) = dp_layer(ig) & - + aerosol(ig,l,iaer)/tau_nh3_cloud - ENDDO - ENDDO - - DO ig=1,ngrid - DO l=1,nlayer-1 - aerosol(ig,l,iaer)=aerosol(ig,l,iaer)/dp_layer(ig) - ENDDO - ENDDO - - end if ! if NH3 cloud - -!========================================================================================================= -! Generic N-layers aerosols/clouds -! Author : J. Vatant d'Ollone (2020) -! -! Purpose: Replaces and extents the former buggy 2-layer scheme as well as hard-coded NH3 cloud -! -! + Each layer can have different optical properties, size of particle ... -! + Enables up to n=4 layers as we apparently cannot run with more scatterers (could be worth checking...) -! + You have different choices for vertical profile of the aerosol layers : -! * aeronlay_choice = 1 : Layer tau is spread between ptop and pbot following atm scale height. -! * aeronlay_choice = 2 : Layer tau follows its own scale height above cloud deck (pbot). -! In this case ptop is dummy and sclhght gives the ratio H_cl/H_atm. -! * aeronlay_choice = ... feel free to add more cases ! -! + Layers can overlap if needed (if you want a 'transition layer' as in the 2-scheme, just add it) -! -!========================================================================================================= - - if (iaero_nlay(1) .ne.0) then - - DO ia=1,nlayaero - iaer=iaero_nlay(ia) - -! a. Initialization - aerosol(1:ngrid,1:nlayer,iaer)=0.D0 - -! b. Opacity calculation - - ! Case 1 : Follows atmospheric scale height between boundaries pressures - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - IF (aeronlay_choice(ia).eq.1) THEN - - dp_layer(:)=0.D0 - DO ig=1,ngrid - DO l=1,nlayer-1 - !! i. Opacity follows scale height - IF ( pplev(ig,l).le.aeronlay_pbot(ia) .AND. & - pplev(ig,l).ge.aeronlay_ptop(ia) ) THEN - aerosol(ig,l,iaer) = ( pplev(ig,l) - pplev(ig,l+1) ) - dp_layer(ig) = dp_layer(ig) + aerosol(ig,l,iaer) - !! ii. Outside aerosol layer boundaries: no aerosols - ELSE - aerosol(ig,l,iaer) = 0.D0 - ENDIF - ENDDO - ENDDO - ! iii. Re-normalize to required total opacity - DO ig=1,ngrid - DO l=1,nlayer-1 - IF ( pplev(ig,l).le.aeronlay_pbot(ia) .AND. & - pplev(ig,l).ge.aeronlay_ptop(ia) ) THEN - aerosol(ig,l,iaer) = aerosol(ig,l,iaer) / dp_layer(ig) & - * aeronlay_tauref(ia) - ENDIF - ENDDO - ENDDO - - ! Case 2 : Follows input scale height - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ELSE IF (aeronlay_choice(ia).eq.2) THEN - - cloud_slope = 1.D0/aeronlay_sclhght(ia) - pcloud_deck = aeronlay_pbot(ia) - dp_layer(:) = 0.D0 - - DO ig=1,ngrid - DO l=1,nlayer-1 - !! i. Below cloud layer: no opacity - IF (pplev(ig,l) .gt. pcloud_deck) THEN - aerosol(ig,l,iaer) = 0.D0 - !! ii. Follows scale height above cloud deck - ELSEIF (pplev(ig,l) .le. pcloud_deck) THEN - aerosol(ig,l,iaer) = ((pplev(ig,l)/pcloud_deck)**(cloud_slope)) - dp_layer(ig) = dp_layer(ig) + aerosol(ig,l,iaer) - ENDIF - ENDDO - ENDDO - ! iii. Re-normalize to required total opacity - DO ig=1,ngrid - DO l=1,nlayer-1 - IF (pplev(ig,l) .le. pcloud_deck) THEN - aerosol(ig,l,iaer) = aerosol(ig,l,iaer) / dp_layer(ig) & - * aeronlay_tauref(ia) - ENDIF - ENDDO - ENDDO - - ENDIF ! aeronlay_choice - - ENDDO ! loop on n aerosol layers - - end if ! if N-layer aerosols - -!================================================================== -! Jovian auroral aerosols (unknown composition) NON-GENERIC: vertical and meridional profile tuned to observations -! S. Guerlet (2015) -!================================================================== - - - if (iaero_aurora .ne.0) then - iaer=iaero_aurora -! 1. Initialization - aerosol(1:ngrid,1:nlayer,iaer)=0.D0 - pm = 2000. !!case study: maxi aerosols at 20 hPa -! 2. Opacity calculation - DO ig=1,ngrid - - !! Test Jupiter (based on Zhang et al 2013 observations, but a bit different), decembre 2015 - DO l=1,nlayer - aerosol(ig,l,iaer) = (pplev(ig,l)/pm)**2 * exp(-(pplev(ig,l)/pm)**2) - ENDDO - ENDDO - - ! 3. Meridional distribution, and re-normalize to observed total column - dp_layer(:)=0.D0 - DO ig=1,ngrid - !!Jupiter - !!Hem sud: - IF (latitude(ig)*180.D0/pi .lt. -45.D0 .and. latitude(ig)*180.D0/pi .gt. -70.) THEN - obs_tau_col_aurora= 10.D0**(-0.06D0*latitude(ig)*180.D0/pi-3.4D0) - ELSEIF (latitude(ig)*180.D0/pi .lt. -37.D0 .and. latitude(ig)*180.D0/pi .ge. -45.) THEN - obs_tau_col_aurora= 10.D0**(-0.3D0*latitude(ig)*180.D0/pi-14.3D0) - ELSEIF (latitude(ig)*180./pi .le. -70. ) THEN - obs_tau_col_aurora= 10**(0.06*70.-3.4D0) - !!Hem Nord: - ELSEIF (latitude(ig)*180.D0/pi .gt. 30.D0 .and. latitude(ig)*180.D0/pi .lt. 70.) THEN - obs_tau_col_aurora= 10.D0**(0.03D0*latitude(ig)*180.D0/pi-1.17D0) - ELSEIF (latitude(ig)*180.D0/pi .gt. 22.D0 .and. latitude(ig)*180.D0/pi .le. 30.) THEN - obs_tau_col_aurora= 10.D0**(0.3D0*latitude(ig)*180.D0/pi-9.4D0) - ELSEIF (latitude(ig)*180.D0/pi .ge. 70.) THEN - obs_tau_col_aurora= 10**(0.03*70.-1.17D0) - ELSEIF (latitude(ig)*180.D0/pi .ge. -37. .and. latitude(ig)*180.D0/pi .le. 22.) THEN - obs_tau_col_aurora = 0.001D0 !!Jupiter: mini pas a zero - ENDIF - - DO l=1,nlayer - dp_layer(ig) = dp_layer(ig) + aerosol(ig,l,iaer)/obs_tau_col_aurora - ENDDO - ENDDO - - DO ig=1,ngrid - DO l=1,nlayer-1 - aerosol(ig,l,iaer)=aerosol(ig,l,iaer)/dp_layer(ig) - ENDDO - ENDDO - - - end if ! if Auroral aerosols -!=========================================================================== -! Radiative Generic Condensable aerosols scheme -! Only used when we give aerogeneric != 0 in callphys.def -! Computes the generic aerosols' opacity in the same fashion as water of -! dust, using the QREFvis3d of the concerned specie -! Lucas Teinturier (2022) -!=========================================================================== - if (aerogeneric .ne. 0) then ! we enter the scheme - do ia=1,aerogeneric - iaer = iaero_generic(ia) - ! Initialization - aerosol(1:ngrid,1:nlayer,iaer) = 0.D0 - igen_ice = i_rgcs_ice(ia) - ! Let's loop on the horizontal and vertical grid - do ig=1,ngrid - do l=1,nlayer - aerosol(ig,l,iaer) = ( 0.75*QREFvis3d(ig,l,iaer) / & - (rho_q(igen_ice) * reffrad(ig,l,iaer)) ) * & - (pq(ig,l,igen_ice)+1E-9 ) * & - (pplev(ig,l) - pplev(ig,l+1)) /g - enddo !l=1,nlayer - enddo !ig=1,ngrid - enddo !ia=1,aerogeneric - endif !aerogeneric .ne. 0 - -!================================================================== -! Venus clouds (4 modes) -! S. Lebonnois (jan 2016) -!================================================================== -! distributions from Haus et al, 2013 -! mode 1 2 2p 3 -! r (microns) 0.30 1.05 1.40 3.65 -! sigma 1.56 1.29 1.23 1.28 -! reff (microns) 0.49 1.23 1.56 4.25 -! nueff 0.21 0.067 0.044 0.063 -! (nueff=exp(ln^2 sigma)-1) -! -! p_bot <=> zb ; p_top <=> zb+zc ; h_bot <=> Hlo ; h_top <=> Hup -! pp_bot: N=No*(p_bot/p)**(h_lay/h_bot) R=8.314463/mu (mu in kg/mol) -! N is in m-3 -! -! dTau = Qext*[pi*reff**2*exp(-3*ln(1+nueff))]*N*h_lay*(-dp)/p - -! Mode 1 - if (iaero_venus1 .ne.0) then - iaer=iaero_venus1 - -! 1. Initialization - aerosol(1:ngrid,1:nlayer,iaer)=0.0 - p_bot = 1.e5 - p_top = 1.e4 - h_bot = 1.0e3 ! m - h_top = 5.0e3 - -! 2. Opacity calculation - - DO ig=1,ngrid - DO l=1,nlayer-1 - - h_lay=8.314463*pt(ig,l)/(g*0.044) - - !! 1. below 2e5 Pa: no aerosols - IF (pplay(ig,l) .gt. 2.e5) THEN - mode_dens = 0. - - !! 2. cloud layer - ELSEIF (pplay(ig,l) .le. 2.e5 .and. pplay(ig,l) .gt. p_bot) THEN - mode_dens = 1.81e8*(p_bot/pplay(ig,l))**(h_lay/h_bot) - - ELSEIF (pplay(ig,l) .le. p_bot .and. pplay(ig,l) .gt. p_top) THEN - mode_dens = 1.81e8 ! m-3 - - ELSEIF (pplay(ig,l) .le. p_top .and. pplay(ig,l) .gt. 1.e2) THEN - mode_dens = 1.81e8*(pplay(ig,l)/p_top)**(h_lay/h_top) - - !! 3. above 1.e2 Pa: no aerosols - ELSEIF (pplay(ig,l) .le. 1.e2) THEN - mode_dens = 0. - ENDIF - - aerosol(ig,l,iaer) = QREFvis3d(ig,l,iaer)* & - pi*(reffrad(ig,l,iaer))**2*exp(-3.*log(1+nueffrad(ig,l,iaer)))* & - mode_dens*h_lay*(pplev(ig,l)-pplev(ig,l+1))/pplay(ig,l) - - ENDDO - ENDDO - - end if ! mode 1 - -! Mode 2 - if (iaero_venus2 .ne.0) then - iaer=iaero_venus2 - -! 1. Initialization - aerosol(1:ngrid,1:nlayer,iaer)=0.0 - p_bot = 1.1e4 - p_top = 1.e4 - h_bot = 3.0e3 - h_top = 3.5e3 - -! 2. Opacity calculation - - DO ig=1,ngrid - DO l=1,nlayer-1 - - h_lay=8.314463*pt(ig,l)/(g*0.044) - - !! 1. below 2e5 Pa: no aerosols - IF (pplay(ig,l) .gt. 2.e5) THEN - mode_dens = 0. - - !! 2. cloud layer - ELSEIF (pplay(ig,l) .le. 2.e5 .and. pplay(ig,l) .gt. p_bot) THEN - mode_dens = 1.00e8*(p_bot/pplay(ig,l))**(h_lay/h_bot) - - ELSEIF (pplay(ig,l) .le. p_bot .and. pplay(ig,l) .gt. p_top) THEN - mode_dens = 1.00e8 - - ELSEIF (pplay(ig,l) .le. p_top .and. pplay(ig,l) .gt. 1.e2) THEN - mode_dens = 1.00e8*(pplay(ig,l)/p_top)**(h_lay/h_top) - - !! 3. above 1.e2 Pa: no aerosols - ELSEIF (pplay(ig,l) .le. 1.e2) THEN - mode_dens = 0. - ENDIF - - aerosol(ig,l,iaer) = QREFvis3d(ig,l,iaer)* & - pi*(reffrad(ig,l,iaer))**2*exp(-3.*log(1+nueffrad(ig,l,iaer)))* & - mode_dens*h_lay*(pplev(ig,l)-pplev(ig,l+1))/pplay(ig,l) - - ENDDO - ENDDO - - end if ! mode 2 - -! Mode 2p - if (iaero_venus2p .ne.0) then - iaer=iaero_venus2p - -! 1. Initialization - aerosol(1:ngrid,1:nlayer,iaer)=0.0 - p_bot = 1.e5 - p_top = 2.3e4 - h_bot = 0.1e3 - h_top = 1.0e3 - -! 2. Opacity calculation - - DO ig=1,ngrid - DO l=1,nlayer-1 - - h_lay=8.314463*pt(ig,l)/(g*0.044) - - !! 1. below 2e5 Pa: no aerosols - IF (pplay(ig,l) .gt. 2.e5) THEN - mode_dens = 0. - - !! 2. cloud layer - ELSEIF (pplay(ig,l) .le. 2.e5 .and. pplay(ig,l) .gt. p_bot) THEN - mode_dens = 5.00e7*(p_bot/pplay(ig,l))**(h_lay/h_bot) - - ELSEIF (pplay(ig,l) .le. p_bot .and. pplay(ig,l) .gt. p_top) THEN - mode_dens = 5.00e7 - - ELSEIF (pplay(ig,l) .le. p_top .and. pplay(ig,l) .gt. 1.e2) THEN - mode_dens = 5.00e7*(pplay(ig,l)/p_top)**(h_lay/h_top) - - !! 3. above 1.e2 Pa: no aerosols - ELSEIF (pplay(ig,l) .le. 1.e2) THEN - mode_dens = 0. - ENDIF - - aerosol(ig,l,iaer) = QREFvis3d(ig,l,iaer)* & - pi*(reffrad(ig,l,iaer))**2*exp(-3.*log(1+nueffrad(ig,l,iaer)))* & - mode_dens*h_lay*(pplev(ig,l)-pplev(ig,l+1))/pplay(ig,l) - - ENDDO - ENDDO - - end if ! mode 2p - -! Mode 3 - if (iaero_venus3 .ne.0) then - iaer=iaero_venus3 - -! 1. Initialization - aerosol(1:ngrid,1:nlayer,iaer)=0.0 - p_bot = 1.e5 - p_top = 4.e4 - h_bot = 0.5e3 - h_top = 1.0e3 - -! 2. Opacity calculation - - DO ig=1,ngrid - DO l=1,nlayer-1 - - h_lay=8.314463*pt(ig,l)/(g*0.044) - - !! 1. below 2e5 Pa: no aerosols - IF (pplay(ig,l) .gt. 2.e5) THEN - mode_dens = 0. - - !! 2. cloud layer - ELSEIF (pplay(ig,l) .le. 2.e5 .and. pplay(ig,l) .gt. p_bot) THEN - mode_dens = 1.40e7*(p_bot/pplay(ig,l))**(h_lay/h_bot) - - ELSEIF (pplay(ig,l) .le. p_bot .and. pplay(ig,l) .gt. p_top) THEN - mode_dens = 1.40e7 - - ELSEIF (pplay(ig,l) .le. p_top .and. pplay(ig,l) .gt. 1.e2) THEN - mode_dens = 1.40e7*(pplay(ig,l)/p_top)**(h_lay/h_top) - - !! 3. above 1.e2 Pa: no aerosols - ELSEIF (pplay(ig,l) .le. 1.e2) THEN - mode_dens = 0. - ENDIF - - aerosol(ig,l,iaer) = QREFvis3d(ig,l,iaer)* & - pi*(reffrad(ig,l,iaer))**2*exp(-3.*log(1+nueffrad(ig,l,iaer)))* & - mode_dens*h_lay*(pplev(ig,l)-pplev(ig,l+1))/pplay(ig,l) - - ENDDO - ENDDO - - end if ! mode 3 - -! UV absorber - if (iaero_venusUV .ne.0) then - iaer=iaero_venusUV - -! 1. Initialization - aerosol(1:ngrid,1:nlayer,iaer)=0.0 - p_bot = 3.3e4 ! 58 km - p_top = 3.7e3 ! 70 km - h_bot = 1.0e3 - h_top = 1.0e3 - -! 2. Opacity calculation - - DO ig=1,ngrid - DO l=1,nlayer-1 - - h_lay=8.314463*pt(ig,l)/(g*0.044) - - !! 1. below 7e4 Pa: no aerosols - IF (pplay(ig,l) .gt. 7.e4) THEN - mode_dens = 0. - - !! 2. cloud layer - ELSEIF (pplay(ig,l) .le. 7.e4 .and. pplay(ig,l) .gt. p_bot) THEN - mode_dens = 1.00e7*(p_bot/pplay(ig,l))**(h_lay/h_bot) - - ELSEIF (pplay(ig,l) .le. p_bot .and. pplay(ig,l) .gt. p_top) THEN - mode_dens = 1.00e7 - - ELSEIF (pplay(ig,l) .le. p_top .and. pplay(ig,l) .gt. 1.e3) THEN - mode_dens = 1.00e7*(pplay(ig,l)/p_top)**(h_lay/h_top) - - !! 3. above 1.e3 Pa: no aerosols - ELSEIF (pplay(ig,l) .le. 1.e3) THEN - mode_dens = 0. - ENDIF - -! normalized to 0.35 microns (peak of absorption) - aerosol(ig,l,iaer) = QREFvis3d(ig,l,iaer)*mode_dens - - ENDDO - ENDDO - -! 3. Re-normalize to Haus et al 2015 total column optical depth - tau_col(:)=0.0 - DO l=1,nlayer - DO ig=1,ngrid - tau_col(ig) = tau_col(ig) & - + aerosol(ig,l,iaer) - ENDDO - ENDDO - DO ig=1,ngrid - DO l=1,nlayer-1 - aerosol(ig,l,iaer)=aerosol(ig,l,iaer)*0.205/tau_col(ig) - ENDDO - ENDDO - - end if ! UV absorber - -!================================================================== -! ig=10 -! do l=1,nlayer -! print*,8.314463*pt(ig,l)/(g*0.044),pplay(ig,l),aerosol(ig,l,1),aerosol(ig,l,2),aerosol(ig,l,3),aerosol(ig,l,4) -! print*,l,pplay(ig,l),aerosol(ig,l,5) -! enddo -! stop -!================================================================== - - -! -------------------------------------------------------------------------- -! Column integrated visible optical depth in each point (used for diagnostic) - - tau_col(:)=0.0 - do iaer = 1, naerkind - do l=1,nlayer - do ig=1,ngrid - tau_col(ig) = tau_col(ig) + aerosol(ig,l,iaer) - end do - end do - end do - - ! do ig=1,ngrid - ! do l=1,nlayer - ! do iaer = 1, naerkind - ! if(aerosol(ig,l,iaer).gt.1.e3)then - ! print*,'WARNING: aerosol=',aerosol(ig,l,iaer) - ! print*,'at ig=',ig,', l=',l,', iaer=',iaer - ! print*,'QREFvis3d=',QREFvis3d(ig,l,iaer) - ! print*,'reffrad=',reffrad(ig,l,iaer) - ! endif - ! end do - ! end do - ! end do - - ! do ig=1,ngrid - ! if(tau_col(ig).gt.1.e3)then - ! print*,'WARNING: tau_col=',tau_col(ig) - ! print*,'at ig=',ig - ! print*,'aerosol=',aerosol(ig,:,:) - ! print*,'QREFvis3d=',QREFvis3d(ig,:,:) - ! print*,'reffrad=',reffrad(ig,:,:) - ! endif - ! end do - - end subroutine aeropacity - -end module aeropacity_mod Index: trunk/LMDZ.GENERIC/libf/phygeneric/aeroptproperties.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/aeroptproperties.F90 (revision 4062) +++ (revision ) @@ -1,819 +1,0 @@ -module aeroptproperties_mod - -implicit none - -contains - - SUBROUTINE aeroptproperties(ngrid,nlayer,reffrad,nueffrad, & - QVISsQREF3d,omegaVIS3d,gVIS3d, & - QIRsQREF3d,omegaIR3d,gIR3d, & - QREFvis3d,QREFir3d)!, & -! omegaREFvis3d,omegaREFir3d) - - use radinc_h, only: L_NSPECTI,L_NSPECTV,nsizemax,naerkind - use radcommon_h, only: QVISsQREF,omegavis,gvis,QIRsQREF,omegair,gir - use radcommon_h, only: qrefvis,qrefir,omegarefir !,omegarefvis - use radcommon_h, only: radiustab,nsize - - implicit none - -! ============================================================= -! Aerosol Optical Properties -! -! Description: -! Compute the scattering parameters in each grid -! box, depending on aerosol grain sizes. Log-normal size -! distribution and Gauss-Legendre integration are used. - -! Parameters: -! Don't forget to set the value of varyingnueff below; If -! the effective variance of the distribution for the given -! aerosol is considered homogeneous in the atmosphere, please -! set varyingnueff(iaer) to .false. Resulting computational -! time will be much better. - -! Authors: J.-B. Madeleine, F. Forget, F. Montmessin -! Slightly modified and converted to F90 by R. Wordsworth (2009) -! Varying nueff section removed by R. Wordsworth for simplicity -! ============================================================== - -! Local variables -! --------------- - - - -! ============================================================= -! LOGICAL, PARAMETER :: varyingnueff(naerkind) = .false. ! not used! -! ============================================================= - -! Min. and max radius of the interpolation grid (in METERS) - REAL, PARAMETER :: refftabmin = 2e-8 !2e-8 -! REAL, PARAMETER :: refftabmax = 35e-6 - REAL, PARAMETER :: refftabmax = 1e-3 -! Log of the min and max variance of the interpolation grid - REAL, PARAMETER :: nuefftabmin = -4.6 - REAL, PARAMETER :: nuefftabmax = 0. -! Number of effective radius of the interpolation grid - INTEGER, PARAMETER :: refftabsize = 200 -! Number of effective variances of the interpolation grid -! INTEGER, PARAMETER :: nuefftabsize = 100 - INTEGER, PARAMETER :: nuefftabsize = 1 -! Interpolation grid indices (reff,nueff) - INTEGER :: grid_i,grid_j -! Intermediate variable - REAL :: var_tmp,var3d_tmp(ngrid,nlayer) -! Bilinear interpolation factors - REAL :: kx,ky,k1,k2,k3,k4 -! Size distribution parameters - REAL :: sizedistk1,sizedistk2 -! Pi! - REAL,SAVE :: pi -!$OMP THREADPRIVATE(pi) -! Variables used by the Gauss-Legendre integration: - INTEGER radius_id,gausind - REAL kint - REAL drad - INTEGER, PARAMETER :: ngau = 10 - REAL weightgaus(ngau),radgaus(ngau) - SAVE weightgaus,radgaus -! DATA weightgaus/.2955242247,.2692667193,.2190863625,.1494513491,.0666713443/ -! DATA radgaus/.1488743389,.4333953941,.6794095682,.8650633666,.9739065285/ - DATA radgaus/0.07652652113350,0.22778585114165, & - 0.37370608871528,0.51086700195146, & - 0.63605368072468,0.74633190646476, & - 0.83911697181213,0.91223442826796, & - 0.96397192726078,0.99312859919241/ - - DATA weightgaus/0.15275338723120,0.14917298659407, & - 0.14209610937519,0.13168863843930, & - 0.11819453196154,0.10193011980823, & - 0.08327674160932,0.06267204829828, & - 0.04060142982019,0.01761400714091/ -!$OMP THREADPRIVATE(radgaus,weightgaus) -! Indices - INTEGER :: i,j,k,l,m,iaer,idomain - INTEGER :: ig,lg,chg - -! Local saved variables -! --------------------- - -! Radius axis of the interpolation grid - REAL,SAVE :: refftab(refftabsize) -! Variance axis of the interpolation grid - REAL,SAVE :: nuefftab(nuefftabsize) -! Volume ratio of the grid - REAL,SAVE :: logvratgrid,vratgrid -! Grid used to remember which calculation is done - LOGICAL,SAVE,ALLOCATABLE :: checkgrid(:,:,:,:) -!$OMP THREADPRIVATE(refftab,nuefftab,logvratgrid,vratgrid,checkgrid) -! Optical properties of the grid (VISIBLE) - REAL,SAVE,ALLOCATABLE :: qsqrefVISgrid(:,:,:,:) - REAL,SAVE,ALLOCATABLE :: qextVISgrid(:,:,:,:) - REAL,SAVE,ALLOCATABLE :: qscatVISgrid(:,:,:,:) - REAL,SAVE,ALLOCATABLE :: omegVISgrid(:,:,:,:) - REAL,SAVE,ALLOCATABLE :: gVISgrid(:,:,:,:) -!$OMP THREADPRIVATE(qsqrefVISgrid,qextVISgrid,qscatVISgrid,omegVISgrid,gVISgrid) -! Optical properties of the grid (INFRARED) - REAL,SAVE,ALLOCATABLE :: qsqrefIRgrid(:,:,:,:) - REAL,SAVE,ALLOCATABLE :: qextIRgrid(:,:,:,:) - REAL,SAVE,ALLOCATABLE :: qscatIRgrid(:,:,:,:) - REAL,SAVE,ALLOCATABLE :: omegIRgrid(:,:,:,:) - REAL,SAVE,ALLOCATABLE :: gIRgrid(:,:,:,:) -!$OMP THREADPRIVATE(qsqrefIRgrid,qextIRgrid,qscatIRgrid,omegIRgrid,gIRgrid) -! Optical properties of the grid (REFERENCE WAVELENGTHS) - REAL,SAVE,ALLOCATABLE :: qrefVISgrid(:,:,:) - REAL,SAVE,ALLOCATABLE :: qscatrefVISgrid(:,:,:) - REAL,SAVE,ALLOCATABLE :: qrefIRgrid(:,:,:) - REAL,SAVE,ALLOCATABLE :: qscatrefIRgrid(:,:,:) - REAL,SAVE,ALLOCATABLE :: omegrefVISgrid(:,:,:) - REAL,SAVE,ALLOCATABLE :: omegrefIRgrid(:,:,:) -!$OMP THREADPRIVATE(qrefVISgrid,qscatrefVISgrid,qrefIRgrid,qscatrefIRgrid,omegrefVISgrid,& -!$OMP omegrefIRgrid) -! Firstcall - LOGICAL,SAVE :: firstcall = .true. - LOGICAL,SAVE :: first_allocate=.true. -!$OMP THREADPRIVATE(firstcall,first_allocate) -! Variables used by the Gauss-Legendre integration: - REAL,SAVE,ALLOCATABLE :: normd(:,:,:,:) - REAL,SAVE,ALLOCATABLE :: dista(:,:,:,:,:) - REAL,SAVE,ALLOCATABLE :: distb(:,:,:,:,:) -!$OMP THREADPRIVATE(normd,dista,distb) - - REAL,SAVE,ALLOCATABLE :: radGAUSa(:,:,:) - REAL,SAVE,ALLOCATABLE :: radGAUSb(:,:,:) -!$OMP THREADPRIVATE(radGAUSa,radGAUSb) - - REAL,SAVE,ALLOCATABLE :: qsqrefVISa(:,:,:) - REAL,SAVE,ALLOCATABLE :: qrefVISa(:,:) - REAL,SAVE,ALLOCATABLE :: qsqrefVISb(:,:,:) - REAL,SAVE,ALLOCATABLE :: qrefVISb(:,:) -!$OMP THREADPRIVATE(qsqrefVISa,qrefVISa,qsqrefVISb,qrefVISb) - REAL,SAVE,ALLOCATABLE :: omegVISa(:,:,:) - REAL,SAVE,ALLOCATABLE :: omegrefVISa(:,:) - REAL,SAVE,ALLOCATABLE :: omegVISb(:,:,:) - REAL,SAVE,ALLOCATABLE :: omegrefVISb(:,:) - REAL,SAVE,ALLOCATABLE :: gVISa(:,:,:) - REAL,SAVE,ALLOCATABLE :: gVISb(:,:,:) -!$OMP THREADPRIVATE(omegVISa,omegrefVISa,omegVISb,omegrefVISb,gVISa,gVISb) - - REAL,SAVE,ALLOCATABLE :: qsqrefIRa(:,:,:) - REAL,SAVE,ALLOCATABLE :: qrefIRa(:,:) - REAL,SAVE,ALLOCATABLE :: qsqrefIRb(:,:,:) - REAL,SAVE,ALLOCATABLE :: qrefIRb(:,:) -!$OMP THREADPRIVATE(qsqrefIRa,qrefIRa,qsqrefIRb,qrefIRb) - REAL,SAVE,ALLOCATABLE :: omegIRa(:,:,:) - REAL,SAVE,ALLOCATABLE :: omegrefIRa(:,:) - REAL,SAVE,ALLOCATABLE :: omegIRb(:,:,:) - REAL,SAVE,ALLOCATABLE :: omegrefIRb(:,:) - REAL,SAVE,ALLOCATABLE :: gIRa(:,:,:) - REAL,SAVE,ALLOCATABLE :: gIRb(:,:,:) -!$OMP THREADPRIVATE(omegIRa,omegrefIRa,omegIRb,omegrefIRb,gIRa,gIRb) - - REAL :: radiusm - REAL :: radiusr - -! Inputs -! ------ - - INTEGER :: ngrid,nlayer -! Aerosol effective radius used for radiative transfer (meter) - REAL,INTENT(IN) :: reffrad(ngrid,nlayer,naerkind) -! Aerosol effective variance used for radiative transfer (n.u.) - REAL,INTENT(IN) :: nueffrad(ngrid,nlayer,naerkind) - -! Outputs -! ------- - - REAL,INTENT(OUT) :: QVISsQREF3d(ngrid,nlayer,L_NSPECTV,naerkind) - REAL,INTENT(OUT) :: omegaVIS3d(ngrid,nlayer,L_NSPECTV,naerkind) - REAL,INTENT(OUT) :: gVIS3d(ngrid,nlayer,L_NSPECTV,naerkind) - - REAL,INTENT(OUT) :: QIRsQREF3d(ngrid,nlayer,L_NSPECTI,naerkind) - REAL,INTENT(OUT) :: omegaIR3d(ngrid,nlayer,L_NSPECTI,naerkind) - REAL,INTENT(OUT) :: gIR3d(ngrid,nlayer,L_NSPECTI,naerkind) - - REAL,INTENT(OUT) :: QREFvis3d(ngrid,nlayer,naerkind) - REAL,INTENT(OUT) :: QREFir3d(ngrid,nlayer,naerkind) - -! REAL :: omegaREFvis3d(ngrid,nlayer,naerkind) -! REAL :: omegaREFir3d(ngrid,nlayer,naerkind) - -! 0. Allocate local saved arrays at firstcall -! -------------------------------------------------- - IF (first_allocate) THEN - ! Grid used to remember computations already done at previous calls - ALLOCATE(checkgrid(refftabsize,nuefftabsize,naerkind,2)) - checkgrid(:,:,:,:)=.false. - ! Optical properties of the grid (VISIBLE) - ALLOCATE(qsqrefVISgrid(refftabsize,nuefftabsize,L_NSPECTV,naerkind)) - ALLOCATE(qextVISgrid(refftabsize,nuefftabsize,L_NSPECTV,naerkind)) - ALLOCATE(qscatVISgrid(refftabsize,nuefftabsize,L_NSPECTV,naerkind)) - ALLOCATE(omegVISgrid(refftabsize,nuefftabsize,L_NSPECTV,naerkind)) - ALLOCATE(gVISgrid(refftabsize,nuefftabsize,L_NSPECTV,naerkind)) - ! Optical properties of the grid (INFRARED) - ALLOCATE(qsqrefIRgrid(refftabsize,nuefftabsize,L_NSPECTI,naerkind)) - ALLOCATE(qextIRgrid(refftabsize,nuefftabsize,L_NSPECTI,naerkind)) - ALLOCATE(qscatIRgrid(refftabsize,nuefftabsize,L_NSPECTI,naerkind)) - ALLOCATE(omegIRgrid(refftabsize,nuefftabsize,L_NSPECTI,naerkind)) - ALLOCATE(gIRgrid(refftabsize,nuefftabsize,L_NSPECTI,naerkind)) - ! Optical properties of the grid (REFERENCE WAVELENGTHS) - ALLOCATE(qrefVISgrid(refftabsize,nuefftabsize,naerkind)) - ALLOCATE(qscatrefVISgrid(refftabsize,nuefftabsize,naerkind)) - ALLOCATE(qrefIRgrid(refftabsize,nuefftabsize,naerkind)) - ALLOCATE(qscatrefIRgrid(refftabsize,nuefftabsize,naerkind)) - ALLOCATE(omegrefVISgrid(refftabsize,nuefftabsize,naerkind)) - ALLOCATE(omegrefIRgrid(refftabsize,nuefftabsize,naerkind)) - ! Variables used by the Gauss-Legendre integration: - ALLOCATE(normd(refftabsize,nuefftabsize,naerkind,2)) - ALLOCATE(dista(refftabsize,nuefftabsize,naerkind,2,ngau)) - ALLOCATE(distb(refftabsize,nuefftabsize,naerkind,2,ngau)) - ALLOCATE(radGAUSa(ngau,naerkind,2)) - ALLOCATE(radGAUSb(ngau,naerkind,2)) - ! - ALLOCATE(qsqrefVISa(L_NSPECTV,ngau,naerkind)) - ALLOCATE(qrefVISa(ngau,naerkind)) - ALLOCATE(qsqrefVISb(L_NSPECTV,ngau,naerkind)) - ALLOCATE(qrefVISb(ngau,naerkind)) - ALLOCATE(omegVISa(L_NSPECTV,ngau,naerkind)) - ALLOCATE(omegrefVISa(ngau,naerkind)) - ALLOCATE(omegVISb(L_NSPECTV,ngau,naerkind)) - ALLOCATE(omegrefVISb(ngau,naerkind)) - ALLOCATE(gVISa(L_NSPECTV,ngau,naerkind)) - ALLOCATE(gVISb(L_NSPECTV,ngau,naerkind)) - ! - ALLOCATE(qsqrefIRa(L_NSPECTI,ngau,naerkind)) - ALLOCATE(qrefIRa(ngau,naerkind)) - ALLOCATE(qsqrefIRb(L_NSPECTI,ngau,naerkind)) - ALLOCATE(qrefIRb(ngau,naerkind)) - - ALLOCATE(omegIRa(L_NSPECTI,ngau,naerkind)) - ALLOCATE(omegrefIRa(ngau,naerkind)) - ALLOCATE(omegIRb(L_NSPECTI,ngau,naerkind)) - ALLOCATE(omegrefIRb(ngau,naerkind)) - ALLOCATE(gIRa(L_NSPECTI,ngau,naerkind)) - ALLOCATE(gIRb(L_NSPECTI,ngau,naerkind)) - - first_allocate=.false. - ENDIF ! of IF (first_allocate) - - DO iaer = 1, naerkind ! Loop on aerosol kind - IF ( (nsize(iaer,1).EQ.1).AND.(nsize(iaer,2).EQ.1) ) THEN -!================================================================== -! If there is one single particle size, optical -! properties of the considered aerosol are homogeneous - DO lg = 1, nlayer - DO ig = 1, ngrid - DO chg = 1, L_NSPECTV - QVISsQREF3d(ig,lg,chg,iaer)=QVISsQREF(chg,iaer,1) - omegaVIS3d(ig,lg,chg,iaer)=omegaVIS(chg,iaer,1) - gVIS3d(ig,lg,chg,iaer)=gVIS(chg,iaer,1) - ENDDO - DO chg = 1, L_NSPECTI - QIRsQREF3d(ig,lg,chg,iaer)=QIRsQREF(chg,iaer,1) - omegaIR3d(ig,lg,chg,iaer)=omegaIR(chg,iaer,1) - gIR3d(ig,lg,chg,iaer)=gIR(chg,iaer,1) - ENDDO - QREFvis3d(ig,lg,iaer)=QREFvis(iaer,1) - QREFir3d(ig,lg,iaer)=QREFir(iaer,1) -! omegaREFvis3d(ig,lg,iaer)=omegaREFvis(iaer,1) -! omegaREFir3d(ig,lg,iaer)=omegaREFir(iaer,1) - ENDDO - ENDDO - - - if (firstcall) then - print*,'Optical prop. of the aerosol are homogenous for:' - print*,'iaer = ',iaer - endif - - ELSE ! Varying effective radius and variance - DO idomain = 1, 2 ! Loop on visible or infrared channel -!================================================================== -! 1. Creating the effective radius and variance grid -! -------------------------------------------------- - IF (firstcall) THEN - -! 1.1 Pi! - pi = 2. * asin(1.e0) - -! 1.2 Effective radius - refftab(1) = refftabmin - refftab(refftabsize) = refftabmax - - logvratgrid = log(refftabmax/refftabmin) / float(refftabsize-1)*3. - vratgrid = exp(logvratgrid) - - do i = 2, refftabsize-1 - refftab(i) = refftab(i-1)*vratgrid**(1./3.) - enddo - -! 1.3 Effective variance - if(nuefftabsize.eq.1)then ! addded by RDW - print*,'Warning: no variance range in aeroptproperties' - nuefftab(1)=0.2 - else - do i = 0, nuefftabsize-1 - nuefftab(i+1) = exp( nuefftabmin + i*(nuefftabmax-nuefftabmin)/(nuefftabsize-1) ) - enddo - endif - - firstcall = .false. - ENDIF ! of IF (firstcall) - -! 1.4 Radius middle point and range for Gauss integration - radiusm=0.5*(radiustab(iaer,idomain,nsize(iaer,idomain)) + radiustab(iaer,idomain,1)) - radiusr=0.5*(radiustab(iaer,idomain,nsize(iaer,idomain)) - radiustab(iaer,idomain,1)) - -! 1.5 Interpolating data at the Gauss quadrature points: - DO gausind=1,ngau - drad=radiusr*radgaus(gausind) - radGAUSa(gausind,iaer,idomain)=radiusm-drad - - radius_id=minloc(abs(radiustab(iaer,idomain,:) - (radiusm-drad)),DIM=1) - IF ((radiustab(iaer,idomain,radius_id) - (radiusm-drad)).GT.0) THEN - radius_id=radius_id-1 - ENDIF - IF (radius_id.GE.nsize(iaer,idomain)) THEN - radius_id=nsize(iaer,idomain)-1 - kint = 1. - ELSEIF (radius_id.LT.1) THEN - radius_id=1 - kint = 0. - ELSE - kint = ( (radiusm-drad) - & - radiustab(iaer,idomain,radius_id) ) / & - ( radiustab(iaer,idomain,radius_id+1) - & - radiustab(iaer,idomain,radius_id) ) - ENDIF - IF (idomain.EQ.1) THEN ! VISIBLE DOMAIN ----------------- - DO m=1,L_NSPECTV - qsqrefVISa(m,gausind,iaer)= & - (1-kint)*QVISsQREF(m,iaer,radius_id) + & - kint*QVISsQREF(m,iaer,radius_id+1) - omegVISa(m,gausind,iaer)= & - (1-kint)*omegaVIS(m,iaer,radius_id) + & - kint*omegaVIS(m,iaer,radius_id+1) - gVISa(m,gausind,iaer)= & - (1-kint)*gVIS(m,iaer,radius_id) + & - kint*gVIS(m,iaer,radius_id+1) - ENDDO - qrefVISa(gausind,iaer)= & - (1-kint)*QREFvis(iaer,radius_id) + & - kint*QREFvis(iaer,radius_id+1) - omegrefVISa(gausind,iaer)= 0 -! omegrefVISa(gausind,iaer)= & -! (1-kint)*omegaREFvis(iaer,radius_id) + & -! kint*omegaREFvis(iaer,radius_id+1) - ELSE ! INFRARED DOMAIN ---------------------------------- - DO m=1,L_NSPECTI - qsqrefIRa(m,gausind,iaer)= & - (1-kint)*QIRsQREF(m,iaer,radius_id) + & - kint*QIRsQREF(m,iaer,radius_id+1) - omegIRa(m,gausind,iaer)= & - (1-kint)*omegaIR(m,iaer,radius_id) + & - kint*omegaIR(m,iaer,radius_id+1) - gIRa(m,gausind,iaer)= & - (1-kint)*gIR(m,iaer,radius_id) + & - kint*gIR(m,iaer,radius_id+1) - ENDDO - qrefIRa(gausind,iaer)= & - (1-kint)*QREFir(iaer,radius_id) + & - kint*QREFir(iaer,radius_id+1) - omegrefIRa(gausind,iaer)= & - (1-kint)*omegaREFir(iaer,radius_id) + & - kint*omegaREFir(iaer,radius_id+1) - ENDIF - ENDDO - - DO gausind=1,ngau - drad=radiusr*radgaus(gausind) - radGAUSb(gausind,iaer,idomain)=radiusm+drad - - radius_id=minloc(abs(radiustab(iaer,idomain,:) - & - (radiusm+drad)),DIM=1) - IF ((radiustab(iaer,idomain,radius_id) - & - (radiusm+drad)).GT.0) THEN - radius_id=radius_id-1 - ENDIF - IF (radius_id.GE.nsize(iaer,idomain)) THEN - radius_id=nsize(iaer,idomain)-1 - kint = 1. - ELSEIF (radius_id.LT.1) THEN - radius_id=1 - kint = 0. - ELSE - kint = ( (radiusm+drad) - & - radiustab(iaer,idomain,radius_id) ) / & - ( radiustab(iaer,idomain,radius_id+1) - & - radiustab(iaer,idomain,radius_id) ) - ENDIF - IF (idomain.EQ.1) THEN ! VISIBLE DOMAIN ----------------- - DO m=1,L_NSPECTV - qsqrefVISb(m,gausind,iaer)= & - (1-kint)*QVISsQREF(m,iaer,radius_id) + & - kint*QVISsQREF(m,iaer,radius_id+1) - omegVISb(m,gausind,iaer)= & - (1-kint)*omegaVIS(m,iaer,radius_id) + & - kint*omegaVIS(m,iaer,radius_id+1) - gVISb(m,gausind,iaer)= & - (1-kint)*gVIS(m,iaer,radius_id) + & - kint*gVIS(m,iaer,radius_id+1) - ENDDO - qrefVISb(gausind,iaer)= & - (1-kint)*QREFvis(iaer,radius_id) + & - kint*QREFvis(iaer,radius_id+1) - omegrefVISb(gausind,iaer)= 0 -! omegrefVISb(gausind,iaer)= & -! (1-kint)*omegaREFvis(iaer,radius_id) + & -! kint*omegaREFvis(iaer,radius_id+1) - ELSE ! INFRARED DOMAIN ---------------------------------- - DO m=1,L_NSPECTI - qsqrefIRb(m,gausind,iaer)= & - (1-kint)*QIRsQREF(m,iaer,radius_id) + & - kint*QIRsQREF(m,iaer,radius_id+1) - omegIRb(m,gausind,iaer)= & - (1-kint)*omegaIR(m,iaer,radius_id) + & - kint*omegaIR(m,iaer,radius_id+1) - gIRb(m,gausind,iaer)= & - (1-kint)*gIR(m,iaer,radius_id) + & - kint*gIR(m,iaer,radius_id+1) - ENDDO - qrefIRb(gausind,iaer)= & - (1-kint)*QREFir(iaer,radius_id) + & - kint*QREFir(iaer,radius_id+1) - omegrefIRb(gausind,iaer)= & - (1-kint)*omegaREFir(iaer,radius_id) + & - kint*omegaREFir(iaer,radius_id+1) - ENDIF - ENDDO - -!================================================================== -! CONSTANT NUEFF FROM HERE -!================================================================== - -! 2. Compute the scattering parameters using linear -! interpolation over grain sizes and constant nueff -! --------------------------------------------------- - - DO lg = 1,nlayer - DO ig = 1, ngrid -! 2.1 Effective radius index and kx calculation - var_tmp=reffrad(ig,lg,iaer)/refftabmin - var_tmp=log(var_tmp)*3. - var_tmp=var_tmp/logvratgrid+1. - grid_i=floor(var_tmp) - IF (grid_i.GE.refftabsize) THEN -! WRITE(*,*) 'Warning: particle size in grid box #' -! WRITE(*,*) ig,' is too large to be used by the ' -! WRITE(*,*) 'radiative transfer; please extend the ' -! WRITE(*,*) 'interpolation grid to larger grain sizes.' - grid_i=refftabsize-1 - kx = 1. - ELSEIF (grid_i.LT.1) THEN -! WRITE(*,*) 'Warning: particle size in grid box #' -! WRITE(*,*) ig,' is too small to be used by the ' -! WRITE(*,*) 'radiative transfer; please extend the ' -! WRITE(*,*) 'interpolation grid to smaller grain sizes.' - grid_i=1 - kx = 0. - ELSE - kx = ( reffrad(ig,lg,iaer)-refftab(grid_i) ) / & - ( refftab(grid_i+1)-refftab(grid_i) ) - ENDIF -! 2.3 Integration - DO j=grid_i,grid_i+1 -! 2.3.1 Check if the calculation has been done - IF (.NOT.checkgrid(j,1,iaer,idomain)) THEN -! 2.3.2 Log-normal dist., r_g and sigma_g are defined -! in [hansen_1974], "Light scattering in planetary -! atmospheres", Space Science Reviews 16 527-610. -! Here, sizedistk1=r_g and sizedistk2=sigma_g^2 - sizedistk2 = log(1.+nueffrad(1,1,iaer)) - sizedistk1 = exp(2.5*sizedistk2) - sizedistk1 = refftab(j) / sizedistk1 - - normd(j,1,iaer,idomain) = 1e-30 - DO gausind=1,ngau - drad=radiusr*radgaus(gausind) - dista(j,1,iaer,idomain,gausind) = LOG((radiusm-drad)/sizedistk1) - dista(j,1,iaer,idomain,gausind) = & - EXP(-dista(j,1,iaer,idomain,gausind) * & - dista(j,1,iaer,idomain,gausind) * & - 0.5e0/sizedistk2)/(radiusm-drad) - dista(j,1,iaer,idomain,gausind) = & - dista(j,1,iaer,idomain,gausind) / & - (sqrt(2e0*pi*sizedistk2)) - - distb(j,1,iaer,idomain,gausind) = LOG((radiusm+drad)/sizedistk1) - distb(j,1,iaer,idomain,gausind) = & - EXP(-distb(j,1,iaer,idomain,gausind) * & - distb(j,1,iaer,idomain,gausind) * & - 0.5e0/sizedistk2)/(radiusm+drad) - distb(j,1,iaer,idomain,gausind) = & - distb(j,1,iaer,idomain,gausind) / & - (sqrt(2e0*pi*sizedistk2)) - - normd(j,1,iaer,idomain)=normd(j,1,iaer,idomain) + & - weightgaus(gausind) * & - ( & - distb(j,1,iaer,idomain,gausind) * pi * & - radGAUSb(gausind,iaer,idomain) * & - radGAUSb(gausind,iaer,idomain) + & - dista(j,1,iaer,idomain,gausind) * pi * & - radGAUSa(gausind,iaer,idomain) * & - radGAUSa(gausind,iaer,idomain) & - ) - ENDDO - IF (idomain.EQ.1) THEN ! VISIBLE DOMAIN ----------- -! 2.3.3.vis Initialization - qsqrefVISgrid(j,1,:,iaer)=0. - qextVISgrid(j,1,:,iaer)=0. - qscatVISgrid(j,1,:,iaer)=0. - omegVISgrid(j,1,:,iaer)=0. - gVISgrid(j,1,:,iaer)=0. - qrefVISgrid(j,1,iaer)=0. - qscatrefVISgrid(j,1,iaer)=0. - omegrefVISgrid(j,1,iaer)=0. - - DO gausind=1,ngau - DO m=1,L_NSPECTV -! Convolution: - qextVISgrid(j,1,m,iaer) = & - qextVISgrid(j,1,m,iaer) + & - weightgaus(gausind) * & - ( & - qsqrefVISb(m,gausind,iaer) * & - qrefVISb(gausind,iaer) * & - pi*radGAUSb(gausind,iaer,idomain) * & - radGAUSb(gausind,iaer,idomain) * & - distb(j,1,iaer,idomain,gausind) + & - qsqrefVISa(m,gausind,iaer) * & - qrefVISa(gausind,iaer) * & - pi*radGAUSa(gausind,iaer,idomain) * & - radGAUSa(gausind,iaer,idomain) * & - dista(j,1,iaer,idomain,gausind) & - ) - qscatVISgrid(j,1,m,iaer) = & - qscatVISgrid(j,1,m,iaer) + & - weightgaus(gausind) * & - ( & - omegVISb(m,gausind,iaer) * & - qsqrefVISb(m,gausind,iaer) * & - qrefVISb(gausind,iaer) * & - pi*radGAUSb(gausind,iaer,idomain) * & - radGAUSb(gausind,iaer,idomain) * & - distb(j,1,iaer,idomain,gausind) + & - omegVISa(m,gausind,iaer) * & - qsqrefVISa(m,gausind,iaer) * & - qrefVISa(gausind,iaer) * & - pi*radGAUSa(gausind,iaer,idomain) * & - radGAUSa(gausind,iaer,idomain) * & - dista(j,1,iaer,idomain,gausind) & - ) - gVISgrid(j,1,m,iaer) = & - gVISgrid(j,1,m,iaer) + & - weightgaus(gausind) * & - ( & - omegVISb(m,gausind,iaer) * & - qsqrefVISb(m,gausind,iaer) * & - qrefVISb(gausind,iaer) * & - gVISb(m,gausind,iaer) * & - pi*radGAUSb(gausind,iaer,idomain) * & - radGAUSb(gausind,iaer,idomain) * & - distb(j,1,iaer,idomain,gausind) + & - omegVISa(m,gausind,iaer) * & - qsqrefVISa(m,gausind,iaer) * & - qrefVISa(gausind,iaer) * & - gVISa(m,gausind,iaer) * & - pi*radGAUSa(gausind,iaer,idomain) * & - radGAUSa(gausind,iaer,idomain) * & - dista(j,1,iaer,idomain,gausind) & - ) - ENDDO - qrefVISgrid(j,1,iaer) = & - qrefVISgrid(j,1,iaer) + & - weightgaus(gausind) * & - ( & - qrefVISb(gausind,iaer) * & - pi*radGAUSb(gausind,iaer,idomain) * & - radGAUSb(gausind,iaer,idomain) * & - distb(j,1,iaer,idomain,gausind) + & - qrefVISa(gausind,iaer) * & - pi*radGAUSa(gausind,iaer,idomain) * & - radGAUSa(gausind,iaer,idomain) * & - dista(j,1,iaer,idomain,gausind) & - ) - qscatrefVISgrid(j,1,iaer) = & - qscatrefVISgrid(j,1,iaer) + & - weightgaus(gausind) * & - ( & - omegrefVISb(gausind,iaer) * & - qrefVISb(gausind,iaer) * & - pi*radGAUSb(gausind,iaer,idomain) * & - radGAUSb(gausind,iaer,idomain) * & - distb(j,1,iaer,idomain,gausind) + & - omegrefVISa(gausind,iaer) * & - qrefVISa(gausind,iaer) * & - pi*radGAUSa(gausind,iaer,idomain) * & - radGAUSa(gausind,iaer,idomain) * & - dista(j,1,iaer,idomain,gausind) & - ) - ENDDO - - qrefVISgrid(j,1,iaer)=qrefVISgrid(j,1,iaer) / & - normd(j,1,iaer,idomain) - qscatrefVISgrid(j,1,iaer)=qscatrefVISgrid(j,1,iaer) / & - normd(j,1,iaer,idomain) - omegrefVISgrid(j,1,iaer)=qscatrefVISgrid(j,1,iaer) / & - qrefVISgrid(j,1,iaer) - DO m=1,L_NSPECTV - qextVISgrid(j,1,m,iaer)=qextVISgrid(j,1,m,iaer) / & - normd(j,1,iaer,idomain) - qscatVISgrid(j,1,m,iaer)=qscatVISgrid(j,1,m,iaer) / & - normd(j,1,iaer,idomain) - gVISgrid(j,1,m,iaer)=gVISgrid(j,1,m,iaer) / & - qscatVISgrid(j,1,m,iaer) / & - normd(j,1,iaer,idomain) - - qsqrefVISgrid(j,1,m,iaer)=qextVISgrid(j,1,m,iaer) / & - qrefVISgrid(j,1,iaer) - omegVISgrid(j,1,m,iaer)=qscatVISgrid(j,1,m,iaer) / & - qextVISgrid(j,1,m,iaer) - ENDDO - ELSE ! INFRARED DOMAIN ---------- -! 2.3.3.ir Initialization - qsqrefIRgrid(j,1,:,iaer)=0. - qextIRgrid(j,1,:,iaer)=0. - qscatIRgrid(j,1,:,iaer)=0. - omegIRgrid(j,1,:,iaer)=0. - gIRgrid(j,1,:,iaer)=0. - qrefIRgrid(j,1,iaer)=0. - qscatrefIRgrid(j,1,iaer)=0. - omegrefIRgrid(j,1,iaer)=0. - - DO gausind=1,ngau - DO m=1,L_NSPECTI -! Convolution: - qextIRgrid(j,1,m,iaer) = & - qextIRgrid(j,1,m,iaer) + & - weightgaus(gausind) * & - ( & - qsqrefIRb(m,gausind,iaer) * & - qrefVISb(gausind,iaer) * & - pi*radGAUSb(gausind,iaer,idomain) * & - radGAUSb(gausind,iaer,idomain) * & - distb(j,1,iaer,idomain,gausind) + & - qsqrefIRa(m,gausind,iaer) * & - qrefVISa(gausind,iaer) * & - pi*radGAUSa(gausind,iaer,idomain) * & - radGAUSa(gausind,iaer,idomain) * & - dista(j,1,iaer,idomain,gausind) & - ) - qscatIRgrid(j,1,m,iaer) = & - qscatIRgrid(j,1,m,iaer) + & - weightgaus(gausind) * & - ( & - omegIRb(m,gausind,iaer) * & - qsqrefIRb(m,gausind,iaer) * & - qrefVISb(gausind,iaer) * & - pi*radGAUSb(gausind,iaer,idomain) * & - radGAUSb(gausind,iaer,idomain) * & - distb(j,1,iaer,idomain,gausind) + & - omegIRa(m,gausind,iaer) * & - qsqrefIRa(m,gausind,iaer) * & - qrefVISa(gausind,iaer) * & - pi*radGAUSa(gausind,iaer,idomain) * & - radGAUSa(gausind,iaer,idomain) * & - dista(j,1,iaer,idomain,gausind) & - ) - gIRgrid(j,1,m,iaer) = & - gIRgrid(j,1,m,iaer) + & - weightgaus(gausind) * & - ( & - omegIRb(m,gausind,iaer) * & - qsqrefIRb(m,gausind,iaer) * & - qrefVISb(gausind,iaer) * & - gIRb(m,gausind,iaer) * & - pi*radGAUSb(gausind,iaer,idomain) * & - radGAUSb(gausind,iaer,idomain) * & - distb(j,1,iaer,idomain,gausind) + & - omegIRa(m,gausind,iaer) * & - qsqrefIRa(m,gausind,iaer) * & - qrefVISa(gausind,iaer) * & - gIRa(m,gausind,iaer) * & - pi*radGAUSa(gausind,iaer,idomain) * & - radGAUSa(gausind,iaer,idomain) * & - dista(j,1,iaer,idomain,gausind) & - ) - ENDDO - qrefIRgrid(j,1,iaer) = & - qrefIRgrid(j,1,iaer) + & - weightgaus(gausind) * & - ( & - qrefIRb(gausind,iaer) * & - pi*radGAUSb(gausind,iaer,idomain) * & - radGAUSb(gausind,iaer,idomain) * & - distb(j,1,iaer,idomain,gausind) + & - qrefIRa(gausind,iaer) * & - pi*radGAUSa(gausind,iaer,idomain) * & - radGAUSa(gausind,iaer,idomain) * & - dista(j,1,iaer,idomain,gausind) & - ) - qscatrefIRgrid(j,1,iaer) = & - qscatrefIRgrid(j,1,iaer) + & - weightgaus(gausind) * & - ( & - omegrefIRb(gausind,iaer) * & - qrefIRb(gausind,iaer) * & - pi*radGAUSb(gausind,iaer,idomain) * & - radGAUSb(gausind,iaer,idomain) * & - distb(j,1,iaer,idomain,gausind) + & - omegrefIRa(gausind,iaer) * & - qrefIRa(gausind,iaer) * & - pi*radGAUSa(gausind,iaer,idomain) * & - radGAUSa(gausind,iaer,idomain) * & - dista(j,1,iaer,idomain,gausind) & - ) - ENDDO - - qrefIRgrid(j,1,iaer)=qrefIRgrid(j,1,iaer) / & - normd(j,1,iaer,idomain) - qscatrefIRgrid(j,1,iaer)=qscatrefIRgrid(j,1,iaer) / & - normd(j,1,iaer,idomain) - omegrefIRgrid(j,1,iaer)=qscatrefIRgrid(j,1,iaer) / & - qrefIRgrid(j,1,iaer) - DO m=1,L_NSPECTI - qextIRgrid(j,1,m,iaer)=qextIRgrid(j,1,m,iaer) / & - normd(j,1,iaer,idomain) - qscatIRgrid(j,1,m,iaer)=qscatIRgrid(j,1,m,iaer) / & - normd(j,1,iaer,idomain) - gIRgrid(j,1,m,iaer)=gIRgrid(j,1,m,iaer) / & - qscatIRgrid(j,1,m,iaer) / & - normd(j,1,iaer,idomain) - - qsqrefIRgrid(j,1,m,iaer)=qextIRgrid(j,1,m,iaer) / & - qrefVISgrid(j,1,iaer) - omegIRgrid(j,1,m,iaer)=qscatIRgrid(j,1,m,iaer) / & - qextIRgrid(j,1,m,iaer) - ENDDO - ENDIF ! -------------------------- - checkgrid(j,1,iaer,idomain) = .true. - ENDIF !checkgrid - ENDDO !grid_i -! 2.4 Linear interpolation - k1 = (1-kx) - k2 = kx - IF (idomain.EQ.1) THEN ! VISIBLE ------------------------ - DO m=1,L_NSPECTV - QVISsQREF3d(ig,lg,m,iaer) = & - k1*qsqrefVISgrid(grid_i,1,m,iaer) + & - k2*qsqrefVISgrid(grid_i+1,1,m,iaer) - omegaVIS3d(ig,lg,m,iaer) = & - k1*omegVISgrid(grid_i,1,m,iaer) + & - k2*omegVISgrid(grid_i+1,1,m,iaer) - gVIS3d(ig,lg,m,iaer) = & - k1*gVISgrid(grid_i,1,m,iaer) + & - k2*gVISgrid(grid_i+1,1,m,iaer) - ENDDO !L_NSPECTV - QREFvis3d(ig,lg,iaer) = & - k1*qrefVISgrid(grid_i,1,iaer) + & - k2*qrefVISgrid(grid_i+1,1,iaer) -! omegaREFvis3d(ig,lg,iaer) = & -! k1*omegrefVISgrid(grid_i,1,iaer) + & -! k2*omegrefVISgrid(grid_i+1,1,iaer) - ELSE ! INFRARED ----------------------- - DO m=1,L_NSPECTI - QIRsQREF3d(ig,lg,m,iaer) = & - k1*qsqrefIRgrid(grid_i,1,m,iaer) + & - k2*qsqrefIRgrid(grid_i+1,1,m,iaer) - omegaIR3d(ig,lg,m,iaer) = & - k1*omegIRgrid(grid_i,1,m,iaer) + & - k2*omegIRgrid(grid_i+1,1,m,iaer) - gIR3d(ig,lg,m,iaer) = & - k1*gIRgrid(grid_i,1,m,iaer) + & - k2*gIRgrid(grid_i+1,1,m,iaer) - ENDDO !L_NSPECTI - QREFir3d(ig,lg,iaer) = & - k1*qrefIRgrid(grid_i,1,iaer) + & - k2*qrefIRgrid(grid_i+1,1,iaer) -! omegaREFir3d(ig,lg,iaer) = & -! k1*omegrefIRgrid(grid_i,1,iaer) + & -! k2*omegrefIRgrid(grid_i+1,1,iaer) - ENDIF ! -------------------------------- - ENDDO !nlayer - ENDDO !ngrid - -!================================================================== - - - - ENDDO ! idomain - - ENDIF ! nsize = 1 - - ENDDO ! iaer (loop on aerosol kind) - - END SUBROUTINE aeroptproperties - - -end module aeroptproperties_mod Index: trunk/LMDZ.GENERIC/libf/phygeneric/aerosol_global_variables.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/aerosol_global_variables.F90 (revision 4077) +++ trunk/LMDZ.GENERIC/libf/phygeneric/aerosol_global_variables.F90 (revision 4077) @@ -0,0 +1,207 @@ +!================================================================== +module aerosol_global_variables +implicit none + +!================================================================== + +! aerosol indexes: these are initialized to be 0 if the +! corresponding aerosol was not activated in callphys.def +! -- otherwise a value is set via aerosol_init + integer, save, protected :: iaero_co2 = 0 + integer, save, protected :: iaero_h2o = 0 + integer, save, protected :: iaero_dust = 0 + integer, save, protected :: iaero_h2so4 = 0 + logical, save, protected :: noaero = .false. +!$OMP THREADPRIVATE(iaero_co2,iaero_h2o,iaero_dust,iaero_h2so4,noaero) + +! two-layer simple aerosol model + integer, save, protected :: iaero_back2lay = 0 + ! NH3 cloud + integer, save, protected :: iaero_nh3 = 0 +! N-layer aerosol model (replaces the 2-layer and hard-coded clouds) + integer,dimension(:), allocatable, save, protected :: iaero_nlay +! Auroral aerosols + integer, save, protected :: iaero_aurora = 0 +!$OMP THREADPRIVATE(iaero_back2lay,iaero_nh3,iaero_nlay,iaero_aurora) + +! Generic aerosols + integer, dimension(:), allocatable, save, protected :: iaero_generic + integer, dimension(:), allocatable, save, protected :: i_rgcs_ice +!$OMP THREADPRIVATE(iaero_generic,i_rgcs_ice) + +! Venus clouds + integer, save, protected :: iaero_venus1 = 0 + integer, save, protected :: iaero_venus2 = 0 + integer, save, protected :: iaero_venus2p = 0 + integer, save, protected :: iaero_venus3 = 0 + integer, save, protected :: iaero_venusUV = 0 +!$OMP THREADPRIVATE(iaero_venus1,iaero_venus2,iaero_venus2p) +!$OMP THREADPRIVATE(iaero_venus3,iaero_venusUV) + +!================================================================== + +contains + + SUBROUTINE aerosol_init + + use mod_phys_lmdz_para, only : is_master + use radinc_h, only: naerkind + use tracer_h, only: n_rgcs, nqtot, is_rgcs + use callkeys_mod, only: aeroco2, aeroh2o, dusttau, aeroh2so4, & + aeroback2lay, aeronh3, nlayaero, aeronlay, & + aeroaurora, aerogeneric, & + aerovenus1, aerovenus2, aerovenus2p, & + aerovenus3, aerovenusUV + + IMPLICIT NONE +!======================================================================= +! subject: +! -------- +! Initialization related to aerosols +! (CO2 aerosols, dust, water, chemical species, ice...) +! +! author: Laura Kerber, S. Guerlet +! ------ +! +!======================================================================= + + integer :: i, ia, iq + + ! Special case, dyn. allocation for n-layer depending on callphys.def + IF(.NOT.ALLOCATED(iaero_nlay)) ALLOCATE(iaero_nlay(nlayaero)) + iaero_nlay(:) = 0 + ! Do the same for iaero_generic and i_rgcs_ice + IF (.not. allocated(iaero_generic)) allocate(iaero_generic(aerogeneric)) + if (.not. allocated(i_rgcs_ice)) allocate(i_rgcs_ice(aerogeneric)) + + ! Init of i_rgcs_ice + i_rgcs_ice(:) =0 + ia = 1 + do iq=1,nqtot + if (is_rgcs(iq) .eq. 1) then + i_rgcs_ice(ia)=iq + ia = ia+1 + endif + enddo + + iaero_generic(:)=0 + ia=0 + if (aeroco2) then + ia=ia+1 + iaero_co2=ia + endif + if (is_master) write(*,*) '--- CO2 aerosol = ', iaero_co2 + + if (aeroh2o) then + ia=ia+1 + iaero_h2o=ia + endif + if (is_master) write(*,*) '--- H2O aerosol = ', iaero_h2o + + if (dusttau.gt.0) then + ia=ia+1 + iaero_dust=ia + endif + if (is_master) write(*,*) '--- Dust aerosol = ', iaero_dust + + if (aeroh2so4) then + ia=ia+1 + iaero_h2so4=ia + endif + if (is_master) write(*,*) '--- H2SO4 aerosol = ', iaero_h2so4 + + if (aeroback2lay) then + ia=ia+1 + iaero_back2lay=ia + endif + if (is_master) write(*,*) '--- Two-layer aerosol = ', iaero_back2lay + + if (aeronh3) then + ia=ia+1 + iaero_nh3=ia + endif + if (is_master) write(*,*) '--- NH3 Cloud = ', iaero_nh3 + + if (aeronlay) then + do i=1,nlayaero + ia=ia+1 + iaero_nlay(i)=ia + enddo + endif + if (is_master) write(*,*) '--- N-layer aerosol = ', iaero_nlay + + if (aeroaurora) then + ia=ia+1 + iaero_aurora=ia + endif + if (is_master) write(*,*) '--- Auroral aerosols = ', iaero_aurora + + if (aerovenus1) then + ia=ia+1 + iaero_venus1=ia + endif + if (is_master) write(*,*) '--- Venus cloud, mode 1 aerosol = ', iaero_venus1 + + if (aerovenus2) then + ia=ia+1 + iaero_venus2=ia + endif + if (is_master) write(*,*) '--- Venus cloud, mode 2 aerosol = ', iaero_venus2 + + if (aerovenus2p) then + ia=ia+1 + iaero_venus2p=ia + endif + if (is_master) write(*,*) '--- Venus cloud, mode 2p aerosol = ', iaero_venus2p + + if (aerovenus3) then + ia=ia+1 + iaero_venus3=ia + endif + if (is_master) write(*,*) '--- Venus cloud, mode 3 aerosol = ', iaero_venus3 + + if (aerovenusUV) then + ia=ia+1 + iaero_venusUV=ia + endif + if (is_master) write(*,*) '--- Venus cloud, UV absorber = ', iaero_venusUV + + if (aerogeneric .ne. 0) then + do i=1,aerogeneric + ia = ia+1 + iaero_generic(i) = ia + enddo + endif + + if (is_master) then + write(*,*)'--- Radiative Generic Condensable Species = ',iaero_generic + + write(*,*) '=== Number of aerosols= ', ia + endif ! of is_master + +! For the zero aerosol case, we currently make a dummy co2 aerosol which is zero everywhere. +! (See aerosol_opacity.F90 for how this works). A better solution would be to turn off the +! aerosol machinery in the no aerosol case, but this would be complicated. LK + + if (ia.eq.0) then !For the zero aerosol case. + ia = 1 + noaero = .true. + iaero_co2=ia + endif + + if (ia.ne.naerkind) then + if (is_master) then + print*, 'Aerosols counted not equal to naerkind' + print*, 'set correct value for nearkind in callphys.def' + print*, 'which should be ',ia + print*, 'according to current options in callphys.def' + print*, 'or change/correct incompatible options there' + print*, 'Abort in aerosol_init' + endif + call abort_physic("iniaerosl",'wrong number of aerosols',1) + endif ! of if (ia.ne.naerkind) + + END SUBROUTINE aerosol_init + +end module aerosol_global_variables +!================================================================== Index: trunk/LMDZ.GENERIC/libf/phygeneric/aerosol_mod.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/aerosol_mod.F90 (revision 4062) +++ (revision ) @@ -1,207 +1,0 @@ -!================================================================== -module aerosol_mod -implicit none - -!================================================================== - -! aerosol indexes: these are initialized to be 0 if the -! corresponding aerosol was not activated in callphys.def -! -- otherwise a value is set via iniaerosol - integer, save, protected :: iaero_co2 = 0 - integer, save, protected :: iaero_h2o = 0 - integer, save, protected :: iaero_dust = 0 - integer, save, protected :: iaero_h2so4 = 0 - logical, save, protected :: noaero = .false. -!$OMP THREADPRIVATE(iaero_co2,iaero_h2o,iaero_dust,iaero_h2so4,noaero) - -! two-layer simple aerosol model - integer, save, protected :: iaero_back2lay = 0 - ! NH3 cloud - integer, save, protected :: iaero_nh3 = 0 -! N-layer aerosol model (replaces the 2-layer and hard-coded clouds) - integer,dimension(:), allocatable, save, protected :: iaero_nlay -! Auroral aerosols - integer, save, protected :: iaero_aurora = 0 -!$OMP THREADPRIVATE(iaero_back2lay,iaero_nh3,iaero_nlay,iaero_aurora) - -! Generic aerosols - integer, dimension(:), allocatable, save, protected :: iaero_generic - integer, dimension(:), allocatable, save, protected :: i_rgcs_ice -!$OMP THREADPRIVATE(iaero_generic,i_rgcs_ice) - -! Venus clouds - integer, save, protected :: iaero_venus1 = 0 - integer, save, protected :: iaero_venus2 = 0 - integer, save, protected :: iaero_venus2p = 0 - integer, save, protected :: iaero_venus3 = 0 - integer, save, protected :: iaero_venusUV = 0 -!$OMP THREADPRIVATE(iaero_venus1,iaero_venus2,iaero_venus2p) -!$OMP THREADPRIVATE(iaero_venus3,iaero_venusUV) - -!================================================================== - -contains - - SUBROUTINE iniaerosol - - use mod_phys_lmdz_para, only : is_master - use radinc_h, only: naerkind - use tracer_h, only: n_rgcs, nqtot, is_rgcs - use callkeys_mod, only: aeroco2, aeroh2o, dusttau, aeroh2so4, & - aeroback2lay, aeronh3, nlayaero, aeronlay, & - aeroaurora, aerogeneric, & - aerovenus1, aerovenus2, aerovenus2p, & - aerovenus3, aerovenusUV - - IMPLICIT NONE -!======================================================================= -! subject: -! -------- -! Initialization related to aerosols -! (CO2 aerosols, dust, water, chemical species, ice...) -! -! author: Laura Kerber, S. Guerlet -! ------ -! -!======================================================================= - - integer :: i, ia, iq - - ! Special case, dyn. allocation for n-layer depending on callphys.def - IF(.NOT.ALLOCATED(iaero_nlay)) ALLOCATE(iaero_nlay(nlayaero)) - iaero_nlay(:) = 0 - ! Do the same for iaero_generic and i_rgcs_ice - IF (.not. allocated(iaero_generic)) allocate(iaero_generic(aerogeneric)) - if (.not. allocated(i_rgcs_ice)) allocate(i_rgcs_ice(aerogeneric)) - - ! Init of i_rgcs_ice - i_rgcs_ice(:) =0 - ia = 1 - do iq=1,nqtot - if (is_rgcs(iq) .eq. 1) then - i_rgcs_ice(ia)=iq - ia = ia+1 - endif - enddo - - iaero_generic(:)=0 - ia=0 - if (aeroco2) then - ia=ia+1 - iaero_co2=ia - endif - if (is_master) write(*,*) '--- CO2 aerosol = ', iaero_co2 - - if (aeroh2o) then - ia=ia+1 - iaero_h2o=ia - endif - if (is_master) write(*,*) '--- H2O aerosol = ', iaero_h2o - - if (dusttau.gt.0) then - ia=ia+1 - iaero_dust=ia - endif - if (is_master) write(*,*) '--- Dust aerosol = ', iaero_dust - - if (aeroh2so4) then - ia=ia+1 - iaero_h2so4=ia - endif - if (is_master) write(*,*) '--- H2SO4 aerosol = ', iaero_h2so4 - - if (aeroback2lay) then - ia=ia+1 - iaero_back2lay=ia - endif - if (is_master) write(*,*) '--- Two-layer aerosol = ', iaero_back2lay - - if (aeronh3) then - ia=ia+1 - iaero_nh3=ia - endif - if (is_master) write(*,*) '--- NH3 Cloud = ', iaero_nh3 - - if (aeronlay) then - do i=1,nlayaero - ia=ia+1 - iaero_nlay(i)=ia - enddo - endif - if (is_master) write(*,*) '--- N-layer aerosol = ', iaero_nlay - - if (aeroaurora) then - ia=ia+1 - iaero_aurora=ia - endif - if (is_master) write(*,*) '--- Auroral aerosols = ', iaero_aurora - - if (aerovenus1) then - ia=ia+1 - iaero_venus1=ia - endif - if (is_master) write(*,*) '--- Venus cloud, mode 1 aerosol = ', iaero_venus1 - - if (aerovenus2) then - ia=ia+1 - iaero_venus2=ia - endif - if (is_master) write(*,*) '--- Venus cloud, mode 2 aerosol = ', iaero_venus2 - - if (aerovenus2p) then - ia=ia+1 - iaero_venus2p=ia - endif - if (is_master) write(*,*) '--- Venus cloud, mode 2p aerosol = ', iaero_venus2p - - if (aerovenus3) then - ia=ia+1 - iaero_venus3=ia - endif - if (is_master) write(*,*) '--- Venus cloud, mode 3 aerosol = ', iaero_venus3 - - if (aerovenusUV) then - ia=ia+1 - iaero_venusUV=ia - endif - if (is_master) write(*,*) '--- Venus cloud, UV absorber = ', iaero_venusUV - - if (aerogeneric .ne. 0) then - do i=1,aerogeneric - ia = ia+1 - iaero_generic(i) = ia - enddo - endif - - if (is_master) then - write(*,*)'--- Radiative Generic Condensable Species = ',iaero_generic - - write(*,*) '=== Number of aerosols= ', ia - endif ! of is_master - -! For the zero aerosol case, we currently make a dummy co2 aerosol which is zero everywhere. -! (See aeropacity.F90 for how this works). A better solution would be to turn off the -! aerosol machinery in the no aerosol case, but this would be complicated. LK - - if (ia.eq.0) then !For the zero aerosol case. - ia = 1 - noaero = .true. - iaero_co2=ia - endif - - if (ia.ne.naerkind) then - if (is_master) then - print*, 'Aerosols counted not equal to naerkind' - print*, 'set correct value for nearkind in callphys.def' - print*, 'which should be ',ia - print*, 'according to current options in callphys.def' - print*, 'or change/correct incompatible options there' - print*, 'Abort in iniaerosol' - endif - call abort_physic("iniaerosl",'wrong number of aerosols',1) - endif ! of if (ia.ne.naerkind) - - END SUBROUTINE iniaerosol - -end module aerosol_mod -!================================================================== Index: trunk/LMDZ.GENERIC/libf/phygeneric/aerosol_opacity.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/aerosol_opacity.F90 (revision 4077) +++ trunk/LMDZ.GENERIC/libf/phygeneric/aerosol_opacity.F90 (revision 4077) @@ -0,0 +1,1096 @@ +module aerosol_opacity_mod + +implicit none + +contains + + Subroutine aerosol_opacity(ngrid,nlayer,nq,pplay,pplev,pt,pq,zls, & + aerosol,reffrad,nueffrad, QREFvis3d,QREFir3d,tau_col, & + cloudfrac,totcloudfrac,clearsky) + + use radinc_h, only : L_TAUMAX,naerkind + use aerosol_global_variables , only: iaero_nlay, iaero_generic, & + iaero_aurora, iaero_back2lay, iaero_co2, & + iaero_dust, iaero_h2o, iaero_h2so4, & + iaero_nh3, i_rgcs_ice, noaero, & + iaero_venus1, iaero_venus2, iaero_venus2p, & + iaero_venus3, iaero_venusUV + USE tracer_h, only: noms,rho_co2,rho_ice,rho_q,mmol + use comcstfi_mod, only: g, pi, mugaz, avocado + use geometry_mod, only: latitude + use callkeys_mod, only: aerofixco2,aerofixh2o,kastprof,cloudlvl, & + CLFvarying,CLFfixval,dusttau,timedepdust, & + pres_bottom_tropo,pres_top_tropo,obs_tau_col_tropo, & + pres_bottom_strato,pres_top_strato,obs_tau_col_strato, & + tau_nh3_cloud, pres_nh3_cloud, & + nlayaero, aeronlay_tauref, aeronlay_choice, & + aeronlay_pbot, aeronlay_ptop, aeronlay_sclhght, & + aerogeneric + use generic_tracer_index_mod, only: generic_tracer_index + implicit none + +!================================================================== +! +! Purpose +! ------- +! Compute aerosol optical depth in each gridbox. +! +! Authors +! ------- +! F. Forget +! F. Montmessin (water ice scheme) +! update J.-B. Madeleine (2008) +! dust removal, simplification by Robin Wordsworth (2009) +! Generic n-layer aerosol - J. Vatant d'Ollone (2020) +! Radiative Generic Condensable Species - Lucas Teinturier (2022) +! +! Input +! ----- +! ngrid Number of horizontal gridpoints +! nlayer Number of layers +! nq Number of tracers +! pplev Pressure (Pa) at each layer boundary +! pq Aerosol mixing ratio +! reffrad(ngrid,nlayer,naerkind) Aerosol effective radius +! QREFvis3d(ngrid,nlayer,naerkind) \ 3d extinction coefficients +! QREFir3d(ngrid,nlayer,naerkind) / at reference wavelengths +! +! Output +! ------ +! aerosol Aerosol optical depth in layer l, grid point ig +! tau_col Total column optical depth at grid point ig +! +!======================================================================= + + INTEGER,INTENT(IN) :: ngrid ! number of atmospheric columns + INTEGER,INTENT(IN) :: nlayer ! number of atmospheric layers + INTEGER,INTENT(IN) :: nq ! number of tracers + REAL,INTENT(IN) :: pplay(ngrid,nlayer) ! mid-layer pressure (Pa) + REAL,INTENT(IN) :: pplev(ngrid,nlayer+1) ! inter-layer pressure (Pa) + REAL,INTENT(IN) :: pq(ngrid,nlayer,nq) ! tracers (.../kg_of_air) + REAL,INTENT(IN) :: zls ! Stellar longitude (rad) + REAL,INTENT(IN) :: pt(ngrid,nlayer) ! mid-layer temperature (K) + REAL,INTENT(OUT) :: aerosol(ngrid,nlayer,naerkind) ! aerosol optical depth + REAL,INTENT(IN) :: reffrad(ngrid,nlayer,naerkind) ! aerosol effective radius + REAL,INTENT(IN) :: nueffrad(ngrid,nlayer,naerkind) ! aerosol effective variance + REAL,INTENT(IN) :: QREFvis3d(ngrid,nlayer,naerkind) ! extinction coefficient in the visible + REAL,INTENT(IN) :: QREFir3d(ngrid,nlayer,naerkind) + REAL,INTENT(OUT):: tau_col(ngrid) !column integrated visible optical depth + ! BENJAMIN MODIFS + real,intent(in) :: cloudfrac(ngrid,nlayer) ! cloud fraction + real,intent(out) :: totcloudfrac(ngrid) ! total cloud fraction + logical,intent(in) :: clearsky + + real aerosol0, obs_tau_col_aurora, pm + real pcloud_deck, cloud_slope + + real dp_strato(ngrid) + real dp_tropo(ngrid) + real dp_layer(ngrid) + + INTEGER l,ig,iq,iaer,ia + + LOGICAL,SAVE :: firstcall=.true. +!$OMP THREADPRIVATE(firstcall) + REAL CBRT + EXTERNAL CBRT + + INTEGER,SAVE :: i_co2ice=0 ! co2 ice + INTEGER,SAVE :: i_h2oice=0 ! water ice +!$OMP THREADPRIVATE(i_co2ice,i_h2oice) + CHARACTER(LEN=20) :: tracername ! to temporarily store text + + ! for dust profiles + real topdust, expfactor, zp + REAL taudusttmp(ngrid) ! Temporary dust opacity used before scaling + REAL tauh2so4tmp(ngrid) ! Temporary h2so4 opacity used before scaling + + ! time-dependent dust (MM) + real zlsconst, odpref, taueq, tauS, tauN + real tau_pref_MGS(ngrid), tauscaling(ngrid) + + real CLFtot + integer igen_ice,igen_vap ! to store the index of generic tracer + logical dummy_bool ! dummy boolean just in case we need one + ! integer i_rgcs_ice(aerogeneric) + ! for venus clouds + real :: p_bot,p_top,h_bot,h_top,mode_dens,h_lay + + ! identify tracers + IF (firstcall) THEN + ia =0 + write(*,*) "Tracers found in aerosol_opacity:" + do iq=1,nq + tracername=noms(iq) + if (tracername.eq."co2_ice") then + i_co2ice=iq + write(*,*) "i_co2ice=",i_co2ice + + endif + if (tracername.eq."h2o_ice") then + i_h2oice=iq + write(*,*) "i_h2oice=",i_h2oice + endif + enddo + + if (noaero) then + print*, "No active aerosols found in aerosol_opacity" + else + print*, "If you would like to use aerosols, make sure any old" + print*, "start files are updated in newstart using the option" + print*, "q=0" + write(*,*) "Active aerosols found in aerosol_opacity:" + endif + + if ((iaero_co2.ne.0).and.(.not.noaero)) then + print*, 'iaero_co2= ',iaero_co2 + endif + if (iaero_h2o.ne.0) then + print*,'iaero_h2o= ',iaero_h2o + endif + if (iaero_dust.ne.0) then + print*,'iaero_dust= ',iaero_dust + endif + if (iaero_h2so4.ne.0) then + print*,'iaero_h2so4= ',iaero_h2so4 + endif + if (iaero_back2lay.ne.0) then + print*,'iaero_back2lay= ',iaero_back2lay + endif + if (iaero_nh3.ne.0) then + print*,'iaero_nh3= ',iaero_nh3 + endif + if (iaero_nlay(1).ne.0) then + print*,'iaero_nlay= ',iaero_nlay(:) + endif + if (iaero_aurora.ne.0) then + print*,'iaero_aurora= ',iaero_aurora + endif + + if (iaero_venus1.ne.0) then + print*,'iaero_venus1= ',iaero_venus1 + endif + if (iaero_venus2.ne.0) then + print*,'iaero_venus2= ',iaero_venus2 + endif + if (iaero_venus2p.ne.0) then + print*,'iaero_venus2p= ',iaero_venus2p + endif + if (iaero_venus3.ne.0) then + print*,'iaero_venus3= ',iaero_venus3 + endif + if (iaero_venusUV.ne.0) then + print*,'iaero_venusUV= ',iaero_venusUV + endif + + if (aerogeneric .ne. 0) then + print*,"iaero_generic= ",iaero_generic(:) + endif + firstcall=.false. + ENDIF ! of IF (firstcall) + + +! --------------------------------------------------------- +!================================================================== +! CO2 ice aerosols +!================================================================== + + if (iaero_co2.ne.0) then + iaer=iaero_co2 +! 1. Initialization + aerosol(1:ngrid,1:nlayer,iaer)=0.0 +! 2. Opacity calculation + if (noaero) then ! aerosol set to zero + aerosol(1:ngrid,1:nlayer,iaer)=0.0 + elseif (aerofixco2.or.(i_co2ice.eq.0)) then ! CO2 ice cloud prescribed + aerosol(1:ngrid,1:nlayer,iaer)=1.e-9 + !aerosol(1:ngrid,12,iaer)=4.0 ! single cloud layer option + else + DO ig=1, ngrid + DO l=1,nlayer-1 ! to stop the rad tran bug + + aerosol0 = & + ( 0.75 * QREFvis3d(ig,l,iaer) / & + ( rho_co2 * reffrad(ig,l,iaer) ) ) * & + ( pq(ig,l,i_co2ice) + 1.E-9 ) * & + ( pplev(ig,l) - pplev(ig,l+1) ) / g + aerosol0 = max(aerosol0,1.e-9) + aerosol0 = min(aerosol0,L_TAUMAX) + aerosol(ig,l,iaer) = aerosol0 +! aerosol(ig,l,iaer) = 0.0 +! print*, aerosol(ig,l,iaer) +! using cloud fraction +! aerosol(ig,l,iaer) = -log(1 - CLF + CLF*exp(-aerosol0/CLF)) +! aerosol(ig,l,iaer) = min(aerosol(ig,l,iaer),L_TAUMAX) + + + ENDDO + ENDDO + end if ! if fixed or varying + end if ! if CO2 aerosols +!================================================================== +! Water ice / liquid +!================================================================== + + if (iaero_h2o.ne.0) then + iaer=iaero_h2o +! 1. Initialization + aerosol(1:ngrid,1:nlayer,iaer)=0.0 +! 2. Opacity calculation + if (aerofixh2o.or.(i_h2oice.eq.0).or.clearsky) then + aerosol(1:ngrid,1:nlayer,iaer) =1.e-9 + + ! put cloud at cloudlvl + if(kastprof.and.(cloudlvl.ne.0.0))then + ig=1 + do l=1,nlayer + if(int(cloudlvl).eq.l)then + !if(cloudlvl.gt.(pplay(ig,l)/pplev(ig,1)))then + print*,'Inserting cloud at level ',l + !aerosol(ig,l,iaer)=10.0 + + rho_ice=920.0 + + ! the Kasting approximation + aerosol(ig,l,iaer) = & + ( 0.75 * QREFvis3d(ig,l,iaer) / & + ( rho_ice * reffrad(ig,l,iaer) ) ) * & + !( pq(ig,l,i_h2oice) + 1.E-9 ) * & + ( 4.0e-4 + 1.E-9 ) * & + ( pplev(ig,l) - pplev(ig,l+1) ) / g + + + open(115,file='clouds.out',form='formatted') + write(115,*) l,aerosol(ig,l,iaer) + close(115) + + return + endif + end do + + call abort_physic("aerosol_opacity", "Something wrong happened on water ice liquid opacity calculation",1) + endif + + else + + do ig=1, ngrid + !do l=1,nlayer-1 ! to stop the rad tran bug + do l=1,nlayer !JL18 if aerosols are present in the last layer we must account for them. Provides better upper boundary condition in the IR. They must however be put to zero in the sw (see rad_correlatedk_opacities_stellar) + ! same correction should b-probably be done for other aerosol types. + aerosol(ig,l,iaer) = & !modification by BC + ( 0.75 * QREFvis3d(ig,l,iaer) / & + ( rho_ice * reffrad(ig,l,iaer) ) ) * & + ! pq(ig,l,i_h2oice) * & !JL I dropped the +1e-9 here to have the same + !( pplev(ig,l) - pplev(ig,l+1) ) / g ! opacity in the clearsky=true and the + ! clear=false/pq=0 case + ( pq(ig,l,i_h2oice) + 1.E-9 ) * & ! Doing this makes the code unstable, so I have restored it (RW) + ( pplev(ig,l) - pplev(ig,l+1) ) / g + + enddo + enddo + + if(CLFvarying)then + call totalcloudfrac(ngrid,nlayer,nq,cloudfrac,totcloudfrac,pplev,pq,aerosol(1,1,iaer)) + do ig=1, ngrid + !do l=1,nlayer-1 ! to stop the rad tran bug + do l=1,nlayer !JL18 if aerosols are present in the last layer we must account for them. Provides better upper boundary condition in the IR. They must however be put to zero in the sw (see rad_correlatedk_opacities_stellar) + CLFtot = max(totcloudfrac(ig),0.01) + aerosol(ig,l,iaer)=aerosol(ig,l,iaer)/CLFtot + aerosol(ig,l,iaer) = max(aerosol(ig,l,iaer),1.e-9) + enddo + enddo + else + do ig=1, ngrid + !do l=1,nlayer-1 ! to stop the rad tran bug + do l=1,nlayer !JL18 if aerosols are present in the last layer we must account for them. Provides better upper boundary condition in the IR. They must however be put to zero in the sw (see rad_correlatedk_opacities_stellar) + CLFtot = CLFfixval + aerosol(ig,l,iaer)=aerosol(ig,l,iaer)/CLFtot + aerosol(ig,l,iaer) = max(aerosol(ig,l,iaer),1.e-9) + enddo + enddo + end if!(CLFvarying) + endif !(aerofixed.or.(i_h2oice.eq.0).or.clearsky) + + end if ! End if h2o aerosol + +!================================================================== +! Dust +! Either constant/homogeneous or +! following MGS scenario for +! present-day Mars as per: +! Montmessin et al., 2004 +! (DOI: 10.1029/2004JE002284) +!================================================================== + if (iaero_dust.ne.0) then + iaer=iaero_dust +! 1. Initialization + aerosol(1:ngrid,1:nlayer,iaer)=0.0 + +! 2. Opacity calculation + + IF (timedepdust) THEN +! Time-dependent dust (MGS scenarion for present-day Mars) + + zlsconst = sin(zls-2.76) + taudusttmp(:) = 0 + odpref = 610. ! Reference pressure (Pa) of + ! DOD (Dust optical Depth) tau_pref_* + + DO l=1,nlayer-1 + DO ig=1,ngrid + + topdust = 60.+18.*zlsconst & ! From + - (32.+18.*zlsconst)*(sin(latitude(ig)))**4 & ! Montmessin + - 8.*zlsconst*(sin(latitude(ig)))**5 ! et al. 2004 + if (pplay(ig,l).ge.odpref/(988.**(topdust/70.))) then ! What is the use of this line? + zp = (odpref/pplay(ig,l))**(70./topdust) + expfactor = max(exp(0.007*(1.-max(zp,1.))),1.e-3) + else + expfactor = 1.e-3 + endif + +! Vertical scaling function + aerosol(ig,l,iaer) = (pplev(ig,l)-pplev(ig,l+1)) & + * expfactor + +! Horizontal scaling of the dust opacity + if (l==1) then + + taueq = 0.2 + (0.5-0.2) * (cos(0.5*(zls-4.363)))**14 + tauS = 0.1 + (0.5-0.1) * (cos(0.5*(zls-4.363)))**14 + tauN = 0.1 + + if (latitude(ig).ge.0) then + ! Northern hemisphere + tau_pref_MGS(ig) = tauN + (taueq-tauN)*0.5 & + *(1+tanh((45-latitude(ig)*180./pi)*6/60)) + else + ! Southern hemisphere + tau_pref_MGS(ig) = tauS + (taueq-tauS)*0.5 & + *(1+tanh((45+latitude(ig)*180./pi)*6/60)) + endif + endif + + ENDDO + ENDDO + + ELSE +! Fixed dust + +! expfactor=0. + topdust=30.0 ! km (used to be 10.0 km) LK + + DO l=1,nlayer-1 + DO ig=1,ngrid + + +! Typical mixing ratio profile + + zp=(pplev(ig,1)/pplay(ig,l))**(70./topdust) + expfactor=max(exp(0.007*(1.-max(zp,1.))),1.e-3) + +! Vertical scaling function + aerosol(ig,l,iaer)= (pplev(ig,l)-pplev(ig,l+1)) & + *expfactor + + + ENDDO + ENDDO + ENDIF ! of if timedepdust + + +! Rescaling each layer to reproduce the choosen (or assimilated) +! dust extinction opacity at visible reference wavelength, which +! is scaled to the surface pressure pplev(ig,1) + + taudusttmp(1:ngrid)=0. + DO l=1,nlayer + DO ig=1,ngrid + taudusttmp(ig) = taudusttmp(ig) & + + aerosol(ig,l,iaer) + ENDDO + ENDDO + + if (timedepdust) then +! Dust opacity scaling + tauscaling(:) = tau_pref_MGS(:) * pplev(:,1) / odpref + else + tauscaling(:) = 1 + endif + + DO l=1,nlayer-1 + DO ig=1,ngrid + aerosol(ig,l,iaer) = max(1E-20, & + dusttau * tauscaling(ig) & + * pplev(ig,1) / pplev(ig,1) & ! what is the use of this line ? (MM) + * aerosol(ig,l,iaer) & + / taudusttmp(ig)) + + + ENDDO + ENDDO + + call writediagfi(ngrid,"taudust","Optical depth at pref","-",2, dusttau * tauscaling) + + end if ! If dust aerosol + +!================================================================== +! H2SO4 +!================================================================== +! added by LK + if (iaero_h2so4.ne.0) then + iaer=iaero_h2so4 + +! 1. Initialization + aerosol(1:ngrid,1:nlayer,iaer)=0.0 + + +! 2. Opacity calculation + +! expfactor=0. + DO l=1,nlayer-1 + DO ig=1,ngrid +! Typical mixing ratio profile + + zp=(pplev(ig,1)/pplay(ig,l))**(70./30) !emulating topdust + expfactor=max(exp(0.007*(1.-max(zp,1.))),1.e-3) + +! Vertical scaling function + aerosol(ig,l,iaer)= (pplev(ig,l)-pplev(ig,l+1))*expfactor + + ENDDO + ENDDO + tauh2so4tmp(1:ngrid)=0. + DO l=1,nlayer + DO ig=1,ngrid + tauh2so4tmp(ig) = tauh2so4tmp(ig) + aerosol(ig,l,iaer) + ENDDO + ENDDO + DO l=1,nlayer-1 + DO ig=1,ngrid + aerosol(ig,l,iaer) = max(1E-20, & + 1 & + * pplev(ig,1) / pplev(ig,1) & + * aerosol(ig,l,iaer) & + / tauh2so4tmp(ig)) + + ENDDO + ENDDO + +! 1/700. is assuming a "sulfurtau" of 1 +! Sulfur aerosol routine to be improved. +! aerosol0 = & +! ( 0.75 * QREFvis3d(ig,l,iaer) / & +! ( rho_h2so4 * reffrad(ig,l,iaer) ) ) * & +! ( pq(ig,l,i_h2so4) + 1.E-9 ) * & +! ( pplev(ig,l) - pplev(ig,l+1) ) / g +! aerosol0 = max(aerosol0,1.e-9) +! aerosol0 = min(aerosol0,L_TAUMAX) +! aerosol(ig,l,iaer) = aerosol0 + +! ENDDO +! ENDDO + end if + + +! --------------------------------------------------------- +!================================================================== +! Two-layer aerosols (unknown composition) +! S. Guerlet (2013) - Modif by J. Vatant d'Ollone (2020) +! +! This scheme is deprecated and left for retrocompatibility +! You should use the n-layer scheme below ! +! +!================================================================== + + if (iaero_back2lay .ne.0) then + iaer=iaero_back2lay +! 1. Initialization + aerosol(1:ngrid,1:nlayer,iaer)=0.0 +! 2. Opacity calculation + + +! JVO 20 : Modif to have each of the layers (strato and tropo) correctly normalized +! Otherwise we previously had the total optical depth correct but for each +! separately, so it didn't match the input values + what's more normalizing +! to the sum was making them non-independent : eg changing tau_tropo was +! affecting stratopsheric values of optical depth ... +! +! Note that the main consequence of the former version bug was (in most cases) +! to strongly underestimate the stratospheric optical depths compared to the +! required values, eg, with tau_tropo=10 and tau_strato=0.1, you actually ended +! with an actual tau_strato of 1E-4 ... ! +! +! NB : Because of the extra transition opacity if the layers are non contiguous, +! be aware that at the the bottom we have tau > tau_strato + tau_tropo + + DO ig=1,ngrid + dp_tropo(ig) = 0.D0 + dp_strato(ig) = 0.D0 + DO l=1,nlayer-1 + aerosol(ig,l,iaer) = ( pplev(ig,l) - pplev(ig,l+1) ) + !! 1. below tropospheric layer: no aerosols + IF (pplev(ig,l) .gt. pres_bottom_tropo) THEN + aerosol(ig,l,iaer) = 0.D0 + !! 2. tropo layer + ELSEIF (pplev(ig,l) .le. pres_bottom_tropo .and. pplev(ig,l) .ge. pres_top_tropo) THEN + dp_tropo(ig) = dp_tropo(ig) + aerosol(ig,l,iaer) + !! 3. linear transition + ! JVO 20 : This interpolation needs to be done AFTER we set strato and tropo (see below) + !! 4. strato layer + ELSEIF (pplev(ig,l) .le. pres_bottom_strato .and. pplev(ig,l) .ge. pres_top_strato) THEN + dp_strato(ig) = dp_strato(ig) + aerosol(ig,l,iaer) + !! 5. above strato layer: no aerosols + ELSEIF (pplev(ig,l) .lt. pres_top_strato) THEN + aerosol(ig,l,iaer) = 0.D0 + ENDIF + ENDDO + ENDDO + +! 3. Re-normalize to the (input) observed (total) column (for each of the layers) + + DO ig=1,ngrid + DO l=1,nlayer-1 + IF (pplev(ig,l) .le. pres_bottom_tropo .and. pplev(ig,l) .ge. pres_top_tropo) THEN + aerosol(ig,l,iaer) = obs_tau_col_tropo*aerosol(ig,l,iaer)/dp_tropo(ig) + ELSEIF (pplev(ig,l) .lt. pres_top_tropo .and. pplev(ig,l) .gt. pres_bottom_strato) THEN + expfactor=log(pplev(ig,l)/pres_top_tropo)/log(pres_bottom_strato/pres_top_tropo) + aerosol(ig,l,iaer) = (obs_tau_col_strato/dp_strato(ig))**expfactor & + * (obs_tau_col_tropo/dp_tropo(ig))**(1.0-expfactor) & + * aerosol(ig,l,iaer) + ELSEIF (pplev(ig,l) .le. pres_bottom_strato .and. pplev(ig,l) .ge. pres_top_strato) THEN + aerosol(ig,l,iaer) = obs_tau_col_strato*aerosol(ig,l,iaer)/dp_strato(ig) + ENDIF + ENDDO + ENDDO + + + end if ! if Two-layer aerosols + +!================================================================== +! Saturn/Jupiter ammonia cloud = thin cloud (scale height 0.2 hard coded...) +! S. Guerlet (2013) +! JVO 20 : You should now use the generic n-layer scheme below +!================================================================== + + if (iaero_nh3 .ne.0) then + iaer=iaero_nh3 +! 1. Initialization + aerosol(1:ngrid,1:nlayer,iaer)=0.D0 +! 2. Opacity calculation + DO ig=1,ngrid + + DO l=1,nlayer-1 + !! 1. below cloud layer: no opacity + + IF (pplev(ig,l) .gt. pres_nh3_cloud ) THEN + aerosol(ig,l,iaer) = 0.D0 + + ELSEIF (pplev(ig,l) .le. pres_nh3_cloud ) THEN + cloud_slope=5. !!(hard-coded, correspond to scale height 0.2) + aerosol(ig,l,iaer) = ((pplev(ig,l)/pres_nh3_cloud)**(cloud_slope))*tau_nh3_cloud + + ENDIF + ENDDO + + END DO + +! 3. Re-normalize to observed total column + dp_layer(:)=0.0 + DO l=1,nlayer + DO ig=1,ngrid + dp_layer(ig) = dp_layer(ig) & + + aerosol(ig,l,iaer)/tau_nh3_cloud + ENDDO + ENDDO + + DO ig=1,ngrid + DO l=1,nlayer-1 + aerosol(ig,l,iaer)=aerosol(ig,l,iaer)/dp_layer(ig) + ENDDO + ENDDO + + end if ! if NH3 cloud + +!========================================================================================================= +! Generic N-layers aerosols/clouds +! Author : J. Vatant d'Ollone (2020) +! +! Purpose: Replaces and extents the former buggy 2-layer scheme as well as hard-coded NH3 cloud +! +! + Each layer can have different optical properties, size of particle ... +! + Enables up to n=4 layers as we apparently cannot run with more scatterers (could be worth checking...) +! + You have different choices for vertical profile of the aerosol layers : +! * aeronlay_choice = 1 : Layer tau is spread between ptop and pbot following atm scale height. +! * aeronlay_choice = 2 : Layer tau follows its own scale height above cloud deck (pbot). +! In this case ptop is dummy and sclhght gives the ratio H_cl/H_atm. +! * aeronlay_choice = ... feel free to add more cases ! +! + Layers can overlap if needed (if you want a 'transition layer' as in the 2-scheme, just add it) +! +!========================================================================================================= + + if (iaero_nlay(1) .ne.0) then + + DO ia=1,nlayaero + iaer=iaero_nlay(ia) + +! a. Initialization + aerosol(1:ngrid,1:nlayer,iaer)=0.D0 + +! b. Opacity calculation + + ! Case 1 : Follows atmospheric scale height between boundaries pressures + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IF (aeronlay_choice(ia).eq.1) THEN + + dp_layer(:)=0.D0 + DO ig=1,ngrid + DO l=1,nlayer-1 + !! i. Opacity follows scale height + IF ( pplev(ig,l).le.aeronlay_pbot(ia) .AND. & + pplev(ig,l).ge.aeronlay_ptop(ia) ) THEN + aerosol(ig,l,iaer) = ( pplev(ig,l) - pplev(ig,l+1) ) + dp_layer(ig) = dp_layer(ig) + aerosol(ig,l,iaer) + !! ii. Outside aerosol layer boundaries: no aerosols + ELSE + aerosol(ig,l,iaer) = 0.D0 + ENDIF + ENDDO + ENDDO + ! iii. Re-normalize to required total opacity + DO ig=1,ngrid + DO l=1,nlayer-1 + IF ( pplev(ig,l).le.aeronlay_pbot(ia) .AND. & + pplev(ig,l).ge.aeronlay_ptop(ia) ) THEN + aerosol(ig,l,iaer) = aerosol(ig,l,iaer) / dp_layer(ig) & + * aeronlay_tauref(ia) + ENDIF + ENDDO + ENDDO + + ! Case 2 : Follows input scale height + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ELSE IF (aeronlay_choice(ia).eq.2) THEN + + cloud_slope = 1.D0/aeronlay_sclhght(ia) + pcloud_deck = aeronlay_pbot(ia) + dp_layer(:) = 0.D0 + + DO ig=1,ngrid + DO l=1,nlayer-1 + !! i. Below cloud layer: no opacity + IF (pplev(ig,l) .gt. pcloud_deck) THEN + aerosol(ig,l,iaer) = 0.D0 + !! ii. Follows scale height above cloud deck + ELSEIF (pplev(ig,l) .le. pcloud_deck) THEN + aerosol(ig,l,iaer) = ((pplev(ig,l)/pcloud_deck)**(cloud_slope)) + dp_layer(ig) = dp_layer(ig) + aerosol(ig,l,iaer) + ENDIF + ENDDO + ENDDO + ! iii. Re-normalize to required total opacity + DO ig=1,ngrid + DO l=1,nlayer-1 + IF (pplev(ig,l) .le. pcloud_deck) THEN + aerosol(ig,l,iaer) = aerosol(ig,l,iaer) / dp_layer(ig) & + * aeronlay_tauref(ia) + ENDIF + ENDDO + ENDDO + + ENDIF ! aeronlay_choice + + ENDDO ! loop on n aerosol layers + + end if ! if N-layer aerosols + +!================================================================== +! Jovian auroral aerosols (unknown composition) NON-GENERIC: vertical and meridional profile tuned to observations +! S. Guerlet (2015) +!================================================================== + + + if (iaero_aurora .ne.0) then + iaer=iaero_aurora +! 1. Initialization + aerosol(1:ngrid,1:nlayer,iaer)=0.D0 + pm = 2000. !!case study: maxi aerosols at 20 hPa +! 2. Opacity calculation + DO ig=1,ngrid + + !! Test Jupiter (based on Zhang et al 2013 observations, but a bit different), decembre 2015 + DO l=1,nlayer + aerosol(ig,l,iaer) = (pplev(ig,l)/pm)**2 * exp(-(pplev(ig,l)/pm)**2) + ENDDO + ENDDO + + ! 3. Meridional distribution, and re-normalize to observed total column + dp_layer(:)=0.D0 + DO ig=1,ngrid + !!Jupiter + !!Hem sud: + IF (latitude(ig)*180.D0/pi .lt. -45.D0 .and. latitude(ig)*180.D0/pi .gt. -70.) THEN + obs_tau_col_aurora= 10.D0**(-0.06D0*latitude(ig)*180.D0/pi-3.4D0) + ELSEIF (latitude(ig)*180.D0/pi .lt. -37.D0 .and. latitude(ig)*180.D0/pi .ge. -45.) THEN + obs_tau_col_aurora= 10.D0**(-0.3D0*latitude(ig)*180.D0/pi-14.3D0) + ELSEIF (latitude(ig)*180./pi .le. -70. ) THEN + obs_tau_col_aurora= 10**(0.06*70.-3.4D0) + !!Hem Nord: + ELSEIF (latitude(ig)*180.D0/pi .gt. 30.D0 .and. latitude(ig)*180.D0/pi .lt. 70.) THEN + obs_tau_col_aurora= 10.D0**(0.03D0*latitude(ig)*180.D0/pi-1.17D0) + ELSEIF (latitude(ig)*180.D0/pi .gt. 22.D0 .and. latitude(ig)*180.D0/pi .le. 30.) THEN + obs_tau_col_aurora= 10.D0**(0.3D0*latitude(ig)*180.D0/pi-9.4D0) + ELSEIF (latitude(ig)*180.D0/pi .ge. 70.) THEN + obs_tau_col_aurora= 10**(0.03*70.-1.17D0) + ELSEIF (latitude(ig)*180.D0/pi .ge. -37. .and. latitude(ig)*180.D0/pi .le. 22.) THEN + obs_tau_col_aurora = 0.001D0 !!Jupiter: mini pas a zero + ENDIF + + DO l=1,nlayer + dp_layer(ig) = dp_layer(ig) + aerosol(ig,l,iaer)/obs_tau_col_aurora + ENDDO + ENDDO + + DO ig=1,ngrid + DO l=1,nlayer-1 + aerosol(ig,l,iaer)=aerosol(ig,l,iaer)/dp_layer(ig) + ENDDO + ENDDO + + + end if ! if Auroral aerosols +!=========================================================================== +! Radiative Generic Condensable aerosols scheme +! Only used when we give aerogeneric != 0 in callphys.def +! Computes the generic aerosols' opacity in the same fashion as water of +! dust, using the QREFvis3d of the concerned specie +! Lucas Teinturier (2022) +!=========================================================================== + if (aerogeneric .ne. 0) then ! we enter the scheme + do ia=1,aerogeneric + iaer = iaero_generic(ia) + ! Initialization + aerosol(1:ngrid,1:nlayer,iaer) = 0.D0 + igen_ice = i_rgcs_ice(ia) + ! Let's loop on the horizontal and vertical grid + do ig=1,ngrid + do l=1,nlayer + aerosol(ig,l,iaer) = ( 0.75*QREFvis3d(ig,l,iaer) / & + (rho_q(igen_ice) * reffrad(ig,l,iaer)) ) * & + (pq(ig,l,igen_ice)+1E-9 ) * & + (pplev(ig,l) - pplev(ig,l+1)) /g + enddo !l=1,nlayer + enddo !ig=1,ngrid + enddo !ia=1,aerogeneric + endif !aerogeneric .ne. 0 + +!================================================================== +! Venus clouds (4 modes) +! S. Lebonnois (jan 2016) +!================================================================== +! distributions from Haus et al, 2013 +! mode 1 2 2p 3 +! r (microns) 0.30 1.05 1.40 3.65 +! sigma 1.56 1.29 1.23 1.28 +! reff (microns) 0.49 1.23 1.56 4.25 +! nueff 0.21 0.067 0.044 0.063 +! (nueff=exp(ln^2 sigma)-1) +! +! p_bot <=> zb ; p_top <=> zb+zc ; h_bot <=> Hlo ; h_top <=> Hup +! pp_bot: N=No*(p_bot/p)**(h_lay/h_bot) R=8.314463/mu (mu in kg/mol) +! N is in m-3 +! +! dTau = Qext*[pi*reff**2*exp(-3*ln(1+nueff))]*N*h_lay*(-dp)/p + +! Mode 1 + if (iaero_venus1 .ne.0) then + iaer=iaero_venus1 + +! 1. Initialization + aerosol(1:ngrid,1:nlayer,iaer)=0.0 + p_bot = 1.e5 + p_top = 1.e4 + h_bot = 1.0e3 ! m + h_top = 5.0e3 + +! 2. Opacity calculation + + DO ig=1,ngrid + DO l=1,nlayer-1 + + h_lay=8.314463*pt(ig,l)/(g*0.044) + + !! 1. below 2e5 Pa: no aerosols + IF (pplay(ig,l) .gt. 2.e5) THEN + mode_dens = 0. + + !! 2. cloud layer + ELSEIF (pplay(ig,l) .le. 2.e5 .and. pplay(ig,l) .gt. p_bot) THEN + mode_dens = 1.81e8*(p_bot/pplay(ig,l))**(h_lay/h_bot) + + ELSEIF (pplay(ig,l) .le. p_bot .and. pplay(ig,l) .gt. p_top) THEN + mode_dens = 1.81e8 ! m-3 + + ELSEIF (pplay(ig,l) .le. p_top .and. pplay(ig,l) .gt. 1.e2) THEN + mode_dens = 1.81e8*(pplay(ig,l)/p_top)**(h_lay/h_top) + + !! 3. above 1.e2 Pa: no aerosols + ELSEIF (pplay(ig,l) .le. 1.e2) THEN + mode_dens = 0. + ENDIF + + aerosol(ig,l,iaer) = QREFvis3d(ig,l,iaer)* & + pi*(reffrad(ig,l,iaer))**2*exp(-3.*log(1+nueffrad(ig,l,iaer)))* & + mode_dens*h_lay*(pplev(ig,l)-pplev(ig,l+1))/pplay(ig,l) + + ENDDO + ENDDO + + end if ! mode 1 + +! Mode 2 + if (iaero_venus2 .ne.0) then + iaer=iaero_venus2 + +! 1. Initialization + aerosol(1:ngrid,1:nlayer,iaer)=0.0 + p_bot = 1.1e4 + p_top = 1.e4 + h_bot = 3.0e3 + h_top = 3.5e3 + +! 2. Opacity calculation + + DO ig=1,ngrid + DO l=1,nlayer-1 + + h_lay=8.314463*pt(ig,l)/(g*0.044) + + !! 1. below 2e5 Pa: no aerosols + IF (pplay(ig,l) .gt. 2.e5) THEN + mode_dens = 0. + + !! 2. cloud layer + ELSEIF (pplay(ig,l) .le. 2.e5 .and. pplay(ig,l) .gt. p_bot) THEN + mode_dens = 1.00e8*(p_bot/pplay(ig,l))**(h_lay/h_bot) + + ELSEIF (pplay(ig,l) .le. p_bot .and. pplay(ig,l) .gt. p_top) THEN + mode_dens = 1.00e8 + + ELSEIF (pplay(ig,l) .le. p_top .and. pplay(ig,l) .gt. 1.e2) THEN + mode_dens = 1.00e8*(pplay(ig,l)/p_top)**(h_lay/h_top) + + !! 3. above 1.e2 Pa: no aerosols + ELSEIF (pplay(ig,l) .le. 1.e2) THEN + mode_dens = 0. + ENDIF + + aerosol(ig,l,iaer) = QREFvis3d(ig,l,iaer)* & + pi*(reffrad(ig,l,iaer))**2*exp(-3.*log(1+nueffrad(ig,l,iaer)))* & + mode_dens*h_lay*(pplev(ig,l)-pplev(ig,l+1))/pplay(ig,l) + + ENDDO + ENDDO + + end if ! mode 2 + +! Mode 2p + if (iaero_venus2p .ne.0) then + iaer=iaero_venus2p + +! 1. Initialization + aerosol(1:ngrid,1:nlayer,iaer)=0.0 + p_bot = 1.e5 + p_top = 2.3e4 + h_bot = 0.1e3 + h_top = 1.0e3 + +! 2. Opacity calculation + + DO ig=1,ngrid + DO l=1,nlayer-1 + + h_lay=8.314463*pt(ig,l)/(g*0.044) + + !! 1. below 2e5 Pa: no aerosols + IF (pplay(ig,l) .gt. 2.e5) THEN + mode_dens = 0. + + !! 2. cloud layer + ELSEIF (pplay(ig,l) .le. 2.e5 .and. pplay(ig,l) .gt. p_bot) THEN + mode_dens = 5.00e7*(p_bot/pplay(ig,l))**(h_lay/h_bot) + + ELSEIF (pplay(ig,l) .le. p_bot .and. pplay(ig,l) .gt. p_top) THEN + mode_dens = 5.00e7 + + ELSEIF (pplay(ig,l) .le. p_top .and. pplay(ig,l) .gt. 1.e2) THEN + mode_dens = 5.00e7*(pplay(ig,l)/p_top)**(h_lay/h_top) + + !! 3. above 1.e2 Pa: no aerosols + ELSEIF (pplay(ig,l) .le. 1.e2) THEN + mode_dens = 0. + ENDIF + + aerosol(ig,l,iaer) = QREFvis3d(ig,l,iaer)* & + pi*(reffrad(ig,l,iaer))**2*exp(-3.*log(1+nueffrad(ig,l,iaer)))* & + mode_dens*h_lay*(pplev(ig,l)-pplev(ig,l+1))/pplay(ig,l) + + ENDDO + ENDDO + + end if ! mode 2p + +! Mode 3 + if (iaero_venus3 .ne.0) then + iaer=iaero_venus3 + +! 1. Initialization + aerosol(1:ngrid,1:nlayer,iaer)=0.0 + p_bot = 1.e5 + p_top = 4.e4 + h_bot = 0.5e3 + h_top = 1.0e3 + +! 2. Opacity calculation + + DO ig=1,ngrid + DO l=1,nlayer-1 + + h_lay=8.314463*pt(ig,l)/(g*0.044) + + !! 1. below 2e5 Pa: no aerosols + IF (pplay(ig,l) .gt. 2.e5) THEN + mode_dens = 0. + + !! 2. cloud layer + ELSEIF (pplay(ig,l) .le. 2.e5 .and. pplay(ig,l) .gt. p_bot) THEN + mode_dens = 1.40e7*(p_bot/pplay(ig,l))**(h_lay/h_bot) + + ELSEIF (pplay(ig,l) .le. p_bot .and. pplay(ig,l) .gt. p_top) THEN + mode_dens = 1.40e7 + + ELSEIF (pplay(ig,l) .le. p_top .and. pplay(ig,l) .gt. 1.e2) THEN + mode_dens = 1.40e7*(pplay(ig,l)/p_top)**(h_lay/h_top) + + !! 3. above 1.e2 Pa: no aerosols + ELSEIF (pplay(ig,l) .le. 1.e2) THEN + mode_dens = 0. + ENDIF + + aerosol(ig,l,iaer) = QREFvis3d(ig,l,iaer)* & + pi*(reffrad(ig,l,iaer))**2*exp(-3.*log(1+nueffrad(ig,l,iaer)))* & + mode_dens*h_lay*(pplev(ig,l)-pplev(ig,l+1))/pplay(ig,l) + + ENDDO + ENDDO + + end if ! mode 3 + +! UV absorber + if (iaero_venusUV .ne.0) then + iaer=iaero_venusUV + +! 1. Initialization + aerosol(1:ngrid,1:nlayer,iaer)=0.0 + p_bot = 3.3e4 ! 58 km + p_top = 3.7e3 ! 70 km + h_bot = 1.0e3 + h_top = 1.0e3 + +! 2. Opacity calculation + + DO ig=1,ngrid + DO l=1,nlayer-1 + + h_lay=8.314463*pt(ig,l)/(g*0.044) + + !! 1. below 7e4 Pa: no aerosols + IF (pplay(ig,l) .gt. 7.e4) THEN + mode_dens = 0. + + !! 2. cloud layer + ELSEIF (pplay(ig,l) .le. 7.e4 .and. pplay(ig,l) .gt. p_bot) THEN + mode_dens = 1.00e7*(p_bot/pplay(ig,l))**(h_lay/h_bot) + + ELSEIF (pplay(ig,l) .le. p_bot .and. pplay(ig,l) .gt. p_top) THEN + mode_dens = 1.00e7 + + ELSEIF (pplay(ig,l) .le. p_top .and. pplay(ig,l) .gt. 1.e3) THEN + mode_dens = 1.00e7*(pplay(ig,l)/p_top)**(h_lay/h_top) + + !! 3. above 1.e3 Pa: no aerosols + ELSEIF (pplay(ig,l) .le. 1.e3) THEN + mode_dens = 0. + ENDIF + +! normalized to 0.35 microns (peak of absorption) + aerosol(ig,l,iaer) = QREFvis3d(ig,l,iaer)*mode_dens + + ENDDO + ENDDO + +! 3. Re-normalize to Haus et al 2015 total column optical depth + tau_col(:)=0.0 + DO l=1,nlayer + DO ig=1,ngrid + tau_col(ig) = tau_col(ig) & + + aerosol(ig,l,iaer) + ENDDO + ENDDO + DO ig=1,ngrid + DO l=1,nlayer-1 + aerosol(ig,l,iaer)=aerosol(ig,l,iaer)*0.205/tau_col(ig) + ENDDO + ENDDO + + end if ! UV absorber + +!================================================================== +! ig=10 +! do l=1,nlayer +! print*,8.314463*pt(ig,l)/(g*0.044),pplay(ig,l),aerosol(ig,l,1),aerosol(ig,l,2),aerosol(ig,l,3),aerosol(ig,l,4) +! print*,l,pplay(ig,l),aerosol(ig,l,5) +! enddo +! stop +!================================================================== + + +! -------------------------------------------------------------------------- +! Column integrated visible optical depth in each point (used for diagnostic) + + tau_col(:)=0.0 + do iaer = 1, naerkind + do l=1,nlayer + do ig=1,ngrid + tau_col(ig) = tau_col(ig) + aerosol(ig,l,iaer) + end do + end do + end do + + ! do ig=1,ngrid + ! do l=1,nlayer + ! do iaer = 1, naerkind + ! if(aerosol(ig,l,iaer).gt.1.e3)then + ! print*,'WARNING: aerosol=',aerosol(ig,l,iaer) + ! print*,'at ig=',ig,', l=',l,', iaer=',iaer + ! print*,'QREFvis3d=',QREFvis3d(ig,l,iaer) + ! print*,'reffrad=',reffrad(ig,l,iaer) + ! endif + ! end do + ! end do + ! end do + + ! do ig=1,ngrid + ! if(tau_col(ig).gt.1.e3)then + ! print*,'WARNING: tau_col=',tau_col(ig) + ! print*,'at ig=',ig + ! print*,'aerosol=',aerosol(ig,:,:) + ! print*,'QREFvis3d=',QREFvis3d(ig,:,:) + ! print*,'reffrad=',reffrad(ig,:,:) + ! endif + ! end do + + end subroutine aerosol_opacity + +end module aerosol_opacity_mod Index: trunk/LMDZ.GENERIC/libf/phygeneric/aerosol_optical_properties.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/aerosol_optical_properties.F90 (revision 4077) +++ trunk/LMDZ.GENERIC/libf/phygeneric/aerosol_optical_properties.F90 (revision 4077) @@ -0,0 +1,820 @@ +module aerosol_optical_properties_mod + +implicit none + +contains + + SUBROUTINE aerosol_optical_properties(ngrid,nlayer,reffrad, & + nueffrad, & + QVISsQREF3d,omegaVIS3d,gVIS3d, & + QIRsQREF3d,omegaIR3d,gIR3d, & + QREFvis3d,QREFir3d)!, & +! omegaREFvis3d,omegaREFir3d) + + use radinc_h, only: L_NSPECTI,L_NSPECTV,nsizemax,naerkind + use radcommon_h, only: QVISsQREF,omegavis,gvis,QIRsQREF,omegair,gir + use radcommon_h, only: qrefvis,qrefir,omegarefir !,omegarefvis + use radcommon_h, only: radiustab,nsize + + implicit none + +! ============================================================= +! Aerosol Optical Properties +! +! Description: +! Compute the scattering parameters in each grid +! box, depending on aerosol grain sizes. Log-normal size +! distribution and Gauss-Legendre integration are used. + +! Parameters: +! Don't forget to set the value of varyingnueff below; If +! the effective variance of the distribution for the given +! aerosol is considered homogeneous in the atmosphere, please +! set varyingnueff(iaer) to .false. Resulting computational +! time will be much better. + +! Authors: J.-B. Madeleine, F. Forget, F. Montmessin +! Slightly modified and converted to F90 by R. Wordsworth (2009) +! Varying nueff section removed by R. Wordsworth for simplicity +! ============================================================== + +! Local variables +! --------------- + + + +! ============================================================= +! LOGICAL, PARAMETER :: varyingnueff(naerkind) = .false. ! not used! +! ============================================================= + +! Min. and max radius of the interpolation grid (in METERS) + REAL, PARAMETER :: refftabmin = 2e-8 !2e-8 +! REAL, PARAMETER :: refftabmax = 35e-6 + REAL, PARAMETER :: refftabmax = 1e-3 +! Log of the min and max variance of the interpolation grid + REAL, PARAMETER :: nuefftabmin = -4.6 + REAL, PARAMETER :: nuefftabmax = 0. +! Number of effective radius of the interpolation grid + INTEGER, PARAMETER :: refftabsize = 200 +! Number of effective variances of the interpolation grid +! INTEGER, PARAMETER :: nuefftabsize = 100 + INTEGER, PARAMETER :: nuefftabsize = 1 +! Interpolation grid indices (reff,nueff) + INTEGER :: grid_i,grid_j +! Intermediate variable + REAL :: var_tmp,var3d_tmp(ngrid,nlayer) +! Bilinear interpolation factors + REAL :: kx,ky,k1,k2,k3,k4 +! Size distribution parameters + REAL :: sizedistk1,sizedistk2 +! Pi! + REAL,SAVE :: pi +!$OMP THREADPRIVATE(pi) +! Variables used by the Gauss-Legendre integration: + INTEGER radius_id,gausind + REAL kint + REAL drad + INTEGER, PARAMETER :: ngau = 10 + REAL weightgaus(ngau),radgaus(ngau) + SAVE weightgaus,radgaus +! DATA weightgaus/.2955242247,.2692667193,.2190863625,.1494513491,.0666713443/ +! DATA radgaus/.1488743389,.4333953941,.6794095682,.8650633666,.9739065285/ + DATA radgaus/0.07652652113350,0.22778585114165, & + 0.37370608871528,0.51086700195146, & + 0.63605368072468,0.74633190646476, & + 0.83911697181213,0.91223442826796, & + 0.96397192726078,0.99312859919241/ + + DATA weightgaus/0.15275338723120,0.14917298659407, & + 0.14209610937519,0.13168863843930, & + 0.11819453196154,0.10193011980823, & + 0.08327674160932,0.06267204829828, & + 0.04060142982019,0.01761400714091/ +!$OMP THREADPRIVATE(radgaus,weightgaus) +! Indices + INTEGER :: i,j,k,l,m,iaer,idomain + INTEGER :: ig,lg,chg + +! Local saved variables +! --------------------- + +! Radius axis of the interpolation grid + REAL,SAVE :: refftab(refftabsize) +! Variance axis of the interpolation grid + REAL,SAVE :: nuefftab(nuefftabsize) +! Volume ratio of the grid + REAL,SAVE :: logvratgrid,vratgrid +! Grid used to remember which calculation is done + LOGICAL,SAVE,ALLOCATABLE :: checkgrid(:,:,:,:) +!$OMP THREADPRIVATE(refftab,nuefftab,logvratgrid,vratgrid,checkgrid) +! Optical properties of the grid (VISIBLE) + REAL,SAVE,ALLOCATABLE :: qsqrefVISgrid(:,:,:,:) + REAL,SAVE,ALLOCATABLE :: qextVISgrid(:,:,:,:) + REAL,SAVE,ALLOCATABLE :: qscatVISgrid(:,:,:,:) + REAL,SAVE,ALLOCATABLE :: omegVISgrid(:,:,:,:) + REAL,SAVE,ALLOCATABLE :: gVISgrid(:,:,:,:) +!$OMP THREADPRIVATE(qsqrefVISgrid,qextVISgrid,qscatVISgrid,omegVISgrid,gVISgrid) +! Optical properties of the grid (INFRARED) + REAL,SAVE,ALLOCATABLE :: qsqrefIRgrid(:,:,:,:) + REAL,SAVE,ALLOCATABLE :: qextIRgrid(:,:,:,:) + REAL,SAVE,ALLOCATABLE :: qscatIRgrid(:,:,:,:) + REAL,SAVE,ALLOCATABLE :: omegIRgrid(:,:,:,:) + REAL,SAVE,ALLOCATABLE :: gIRgrid(:,:,:,:) +!$OMP THREADPRIVATE(qsqrefIRgrid,qextIRgrid,qscatIRgrid,omegIRgrid,gIRgrid) +! Optical properties of the grid (REFERENCE WAVELENGTHS) + REAL,SAVE,ALLOCATABLE :: qrefVISgrid(:,:,:) + REAL,SAVE,ALLOCATABLE :: qscatrefVISgrid(:,:,:) + REAL,SAVE,ALLOCATABLE :: qrefIRgrid(:,:,:) + REAL,SAVE,ALLOCATABLE :: qscatrefIRgrid(:,:,:) + REAL,SAVE,ALLOCATABLE :: omegrefVISgrid(:,:,:) + REAL,SAVE,ALLOCATABLE :: omegrefIRgrid(:,:,:) +!$OMP THREADPRIVATE(qrefVISgrid,qscatrefVISgrid,qrefIRgrid,qscatrefIRgrid,omegrefVISgrid,& +!$OMP omegrefIRgrid) +! Firstcall + LOGICAL,SAVE :: firstcall = .true. + LOGICAL,SAVE :: first_allocate=.true. +!$OMP THREADPRIVATE(firstcall,first_allocate) +! Variables used by the Gauss-Legendre integration: + REAL,SAVE,ALLOCATABLE :: normd(:,:,:,:) + REAL,SAVE,ALLOCATABLE :: dista(:,:,:,:,:) + REAL,SAVE,ALLOCATABLE :: distb(:,:,:,:,:) +!$OMP THREADPRIVATE(normd,dista,distb) + + REAL,SAVE,ALLOCATABLE :: radGAUSa(:,:,:) + REAL,SAVE,ALLOCATABLE :: radGAUSb(:,:,:) +!$OMP THREADPRIVATE(radGAUSa,radGAUSb) + + REAL,SAVE,ALLOCATABLE :: qsqrefVISa(:,:,:) + REAL,SAVE,ALLOCATABLE :: qrefVISa(:,:) + REAL,SAVE,ALLOCATABLE :: qsqrefVISb(:,:,:) + REAL,SAVE,ALLOCATABLE :: qrefVISb(:,:) +!$OMP THREADPRIVATE(qsqrefVISa,qrefVISa,qsqrefVISb,qrefVISb) + REAL,SAVE,ALLOCATABLE :: omegVISa(:,:,:) + REAL,SAVE,ALLOCATABLE :: omegrefVISa(:,:) + REAL,SAVE,ALLOCATABLE :: omegVISb(:,:,:) + REAL,SAVE,ALLOCATABLE :: omegrefVISb(:,:) + REAL,SAVE,ALLOCATABLE :: gVISa(:,:,:) + REAL,SAVE,ALLOCATABLE :: gVISb(:,:,:) +!$OMP THREADPRIVATE(omegVISa,omegrefVISa,omegVISb,omegrefVISb,gVISa,gVISb) + + REAL,SAVE,ALLOCATABLE :: qsqrefIRa(:,:,:) + REAL,SAVE,ALLOCATABLE :: qrefIRa(:,:) + REAL,SAVE,ALLOCATABLE :: qsqrefIRb(:,:,:) + REAL,SAVE,ALLOCATABLE :: qrefIRb(:,:) +!$OMP THREADPRIVATE(qsqrefIRa,qrefIRa,qsqrefIRb,qrefIRb) + REAL,SAVE,ALLOCATABLE :: omegIRa(:,:,:) + REAL,SAVE,ALLOCATABLE :: omegrefIRa(:,:) + REAL,SAVE,ALLOCATABLE :: omegIRb(:,:,:) + REAL,SAVE,ALLOCATABLE :: omegrefIRb(:,:) + REAL,SAVE,ALLOCATABLE :: gIRa(:,:,:) + REAL,SAVE,ALLOCATABLE :: gIRb(:,:,:) +!$OMP THREADPRIVATE(omegIRa,omegrefIRa,omegIRb,omegrefIRb,gIRa,gIRb) + + REAL :: radiusm + REAL :: radiusr + +! Inputs +! ------ + + INTEGER :: ngrid,nlayer +! Aerosol effective radius used for radiative transfer (meter) + REAL,INTENT(IN) :: reffrad(ngrid,nlayer,naerkind) +! Aerosol effective variance used for radiative transfer (n.u.) + REAL,INTENT(IN) :: nueffrad(ngrid,nlayer,naerkind) + +! Outputs +! ------- + + REAL,INTENT(OUT) :: QVISsQREF3d(ngrid,nlayer,L_NSPECTV,naerkind) + REAL,INTENT(OUT) :: omegaVIS3d(ngrid,nlayer,L_NSPECTV,naerkind) + REAL,INTENT(OUT) :: gVIS3d(ngrid,nlayer,L_NSPECTV,naerkind) + + REAL,INTENT(OUT) :: QIRsQREF3d(ngrid,nlayer,L_NSPECTI,naerkind) + REAL,INTENT(OUT) :: omegaIR3d(ngrid,nlayer,L_NSPECTI,naerkind) + REAL,INTENT(OUT) :: gIR3d(ngrid,nlayer,L_NSPECTI,naerkind) + + REAL,INTENT(OUT) :: QREFvis3d(ngrid,nlayer,naerkind) + REAL,INTENT(OUT) :: QREFir3d(ngrid,nlayer,naerkind) + +! REAL :: omegaREFvis3d(ngrid,nlayer,naerkind) +! REAL :: omegaREFir3d(ngrid,nlayer,naerkind) + +! 0. Allocate local saved arrays at firstcall +! -------------------------------------------------- + IF (first_allocate) THEN + ! Grid used to remember computations already done at previous calls + ALLOCATE(checkgrid(refftabsize,nuefftabsize,naerkind,2)) + checkgrid(:,:,:,:)=.false. + ! Optical properties of the grid (VISIBLE) + ALLOCATE(qsqrefVISgrid(refftabsize,nuefftabsize,L_NSPECTV,naerkind)) + ALLOCATE(qextVISgrid(refftabsize,nuefftabsize,L_NSPECTV,naerkind)) + ALLOCATE(qscatVISgrid(refftabsize,nuefftabsize,L_NSPECTV,naerkind)) + ALLOCATE(omegVISgrid(refftabsize,nuefftabsize,L_NSPECTV,naerkind)) + ALLOCATE(gVISgrid(refftabsize,nuefftabsize,L_NSPECTV,naerkind)) + ! Optical properties of the grid (INFRARED) + ALLOCATE(qsqrefIRgrid(refftabsize,nuefftabsize,L_NSPECTI,naerkind)) + ALLOCATE(qextIRgrid(refftabsize,nuefftabsize,L_NSPECTI,naerkind)) + ALLOCATE(qscatIRgrid(refftabsize,nuefftabsize,L_NSPECTI,naerkind)) + ALLOCATE(omegIRgrid(refftabsize,nuefftabsize,L_NSPECTI,naerkind)) + ALLOCATE(gIRgrid(refftabsize,nuefftabsize,L_NSPECTI,naerkind)) + ! Optical properties of the grid (REFERENCE WAVELENGTHS) + ALLOCATE(qrefVISgrid(refftabsize,nuefftabsize,naerkind)) + ALLOCATE(qscatrefVISgrid(refftabsize,nuefftabsize,naerkind)) + ALLOCATE(qrefIRgrid(refftabsize,nuefftabsize,naerkind)) + ALLOCATE(qscatrefIRgrid(refftabsize,nuefftabsize,naerkind)) + ALLOCATE(omegrefVISgrid(refftabsize,nuefftabsize,naerkind)) + ALLOCATE(omegrefIRgrid(refftabsize,nuefftabsize,naerkind)) + ! Variables used by the Gauss-Legendre integration: + ALLOCATE(normd(refftabsize,nuefftabsize,naerkind,2)) + ALLOCATE(dista(refftabsize,nuefftabsize,naerkind,2,ngau)) + ALLOCATE(distb(refftabsize,nuefftabsize,naerkind,2,ngau)) + ALLOCATE(radGAUSa(ngau,naerkind,2)) + ALLOCATE(radGAUSb(ngau,naerkind,2)) + ! + ALLOCATE(qsqrefVISa(L_NSPECTV,ngau,naerkind)) + ALLOCATE(qrefVISa(ngau,naerkind)) + ALLOCATE(qsqrefVISb(L_NSPECTV,ngau,naerkind)) + ALLOCATE(qrefVISb(ngau,naerkind)) + ALLOCATE(omegVISa(L_NSPECTV,ngau,naerkind)) + ALLOCATE(omegrefVISa(ngau,naerkind)) + ALLOCATE(omegVISb(L_NSPECTV,ngau,naerkind)) + ALLOCATE(omegrefVISb(ngau,naerkind)) + ALLOCATE(gVISa(L_NSPECTV,ngau,naerkind)) + ALLOCATE(gVISb(L_NSPECTV,ngau,naerkind)) + ! + ALLOCATE(qsqrefIRa(L_NSPECTI,ngau,naerkind)) + ALLOCATE(qrefIRa(ngau,naerkind)) + ALLOCATE(qsqrefIRb(L_NSPECTI,ngau,naerkind)) + ALLOCATE(qrefIRb(ngau,naerkind)) + + ALLOCATE(omegIRa(L_NSPECTI,ngau,naerkind)) + ALLOCATE(omegrefIRa(ngau,naerkind)) + ALLOCATE(omegIRb(L_NSPECTI,ngau,naerkind)) + ALLOCATE(omegrefIRb(ngau,naerkind)) + ALLOCATE(gIRa(L_NSPECTI,ngau,naerkind)) + ALLOCATE(gIRb(L_NSPECTI,ngau,naerkind)) + + first_allocate=.false. + ENDIF ! of IF (first_allocate) + + DO iaer = 1, naerkind ! Loop on aerosol kind + IF ( (nsize(iaer,1).EQ.1).AND.(nsize(iaer,2).EQ.1) ) THEN +!================================================================== +! If there is one single particle size, optical +! properties of the considered aerosol are homogeneous + DO lg = 1, nlayer + DO ig = 1, ngrid + DO chg = 1, L_NSPECTV + QVISsQREF3d(ig,lg,chg,iaer)=QVISsQREF(chg,iaer,1) + omegaVIS3d(ig,lg,chg,iaer)=omegaVIS(chg,iaer,1) + gVIS3d(ig,lg,chg,iaer)=gVIS(chg,iaer,1) + ENDDO + DO chg = 1, L_NSPECTI + QIRsQREF3d(ig,lg,chg,iaer)=QIRsQREF(chg,iaer,1) + omegaIR3d(ig,lg,chg,iaer)=omegaIR(chg,iaer,1) + gIR3d(ig,lg,chg,iaer)=gIR(chg,iaer,1) + ENDDO + QREFvis3d(ig,lg,iaer)=QREFvis(iaer,1) + QREFir3d(ig,lg,iaer)=QREFir(iaer,1) +! omegaREFvis3d(ig,lg,iaer)=omegaREFvis(iaer,1) +! omegaREFir3d(ig,lg,iaer)=omegaREFir(iaer,1) + ENDDO + ENDDO + + + if (firstcall) then + print*,'Optical prop. of the aerosol are homogenous for:' + print*,'iaer = ',iaer + endif + + ELSE ! Varying effective radius and variance + DO idomain = 1, 2 ! Loop on visible or infrared channel +!================================================================== +! 1. Creating the effective radius and variance grid +! -------------------------------------------------- + IF (firstcall) THEN + +! 1.1 Pi! + pi = 2. * asin(1.e0) + +! 1.2 Effective radius + refftab(1) = refftabmin + refftab(refftabsize) = refftabmax + + logvratgrid = log(refftabmax/refftabmin) / float(refftabsize-1)*3. + vratgrid = exp(logvratgrid) + + do i = 2, refftabsize-1 + refftab(i) = refftab(i-1)*vratgrid**(1./3.) + enddo + +! 1.3 Effective variance + if(nuefftabsize.eq.1)then ! addded by RDW + print*,'Warning: no variance range in aerosol_optical_properties' + nuefftab(1)=0.2 + else + do i = 0, nuefftabsize-1 + nuefftab(i+1) = exp( nuefftabmin + i*(nuefftabmax-nuefftabmin)/(nuefftabsize-1) ) + enddo + endif + + firstcall = .false. + ENDIF ! of IF (firstcall) + +! 1.4 Radius middle point and range for Gauss integration + radiusm=0.5*(radiustab(iaer,idomain,nsize(iaer,idomain)) + radiustab(iaer,idomain,1)) + radiusr=0.5*(radiustab(iaer,idomain,nsize(iaer,idomain)) - radiustab(iaer,idomain,1)) + +! 1.5 Interpolating data at the Gauss quadrature points: + DO gausind=1,ngau + drad=radiusr*radgaus(gausind) + radGAUSa(gausind,iaer,idomain)=radiusm-drad + + radius_id=minloc(abs(radiustab(iaer,idomain,:) - (radiusm-drad)),DIM=1) + IF ((radiustab(iaer,idomain,radius_id) - (radiusm-drad)).GT.0) THEN + radius_id=radius_id-1 + ENDIF + IF (radius_id.GE.nsize(iaer,idomain)) THEN + radius_id=nsize(iaer,idomain)-1 + kint = 1. + ELSEIF (radius_id.LT.1) THEN + radius_id=1 + kint = 0. + ELSE + kint = ( (radiusm-drad) - & + radiustab(iaer,idomain,radius_id) ) / & + ( radiustab(iaer,idomain,radius_id+1) - & + radiustab(iaer,idomain,radius_id) ) + ENDIF + IF (idomain.EQ.1) THEN ! VISIBLE DOMAIN ----------------- + DO m=1,L_NSPECTV + qsqrefVISa(m,gausind,iaer)= & + (1-kint)*QVISsQREF(m,iaer,radius_id) + & + kint*QVISsQREF(m,iaer,radius_id+1) + omegVISa(m,gausind,iaer)= & + (1-kint)*omegaVIS(m,iaer,radius_id) + & + kint*omegaVIS(m,iaer,radius_id+1) + gVISa(m,gausind,iaer)= & + (1-kint)*gVIS(m,iaer,radius_id) + & + kint*gVIS(m,iaer,radius_id+1) + ENDDO + qrefVISa(gausind,iaer)= & + (1-kint)*QREFvis(iaer,radius_id) + & + kint*QREFvis(iaer,radius_id+1) + omegrefVISa(gausind,iaer)= 0 +! omegrefVISa(gausind,iaer)= & +! (1-kint)*omegaREFvis(iaer,radius_id) + & +! kint*omegaREFvis(iaer,radius_id+1) + ELSE ! INFRARED DOMAIN ---------------------------------- + DO m=1,L_NSPECTI + qsqrefIRa(m,gausind,iaer)= & + (1-kint)*QIRsQREF(m,iaer,radius_id) + & + kint*QIRsQREF(m,iaer,radius_id+1) + omegIRa(m,gausind,iaer)= & + (1-kint)*omegaIR(m,iaer,radius_id) + & + kint*omegaIR(m,iaer,radius_id+1) + gIRa(m,gausind,iaer)= & + (1-kint)*gIR(m,iaer,radius_id) + & + kint*gIR(m,iaer,radius_id+1) + ENDDO + qrefIRa(gausind,iaer)= & + (1-kint)*QREFir(iaer,radius_id) + & + kint*QREFir(iaer,radius_id+1) + omegrefIRa(gausind,iaer)= & + (1-kint)*omegaREFir(iaer,radius_id) + & + kint*omegaREFir(iaer,radius_id+1) + ENDIF + ENDDO + + DO gausind=1,ngau + drad=radiusr*radgaus(gausind) + radGAUSb(gausind,iaer,idomain)=radiusm+drad + + radius_id=minloc(abs(radiustab(iaer,idomain,:) - & + (radiusm+drad)),DIM=1) + IF ((radiustab(iaer,idomain,radius_id) - & + (radiusm+drad)).GT.0) THEN + radius_id=radius_id-1 + ENDIF + IF (radius_id.GE.nsize(iaer,idomain)) THEN + radius_id=nsize(iaer,idomain)-1 + kint = 1. + ELSEIF (radius_id.LT.1) THEN + radius_id=1 + kint = 0. + ELSE + kint = ( (radiusm+drad) - & + radiustab(iaer,idomain,radius_id) ) / & + ( radiustab(iaer,idomain,radius_id+1) - & + radiustab(iaer,idomain,radius_id) ) + ENDIF + IF (idomain.EQ.1) THEN ! VISIBLE DOMAIN ----------------- + DO m=1,L_NSPECTV + qsqrefVISb(m,gausind,iaer)= & + (1-kint)*QVISsQREF(m,iaer,radius_id) + & + kint*QVISsQREF(m,iaer,radius_id+1) + omegVISb(m,gausind,iaer)= & + (1-kint)*omegaVIS(m,iaer,radius_id) + & + kint*omegaVIS(m,iaer,radius_id+1) + gVISb(m,gausind,iaer)= & + (1-kint)*gVIS(m,iaer,radius_id) + & + kint*gVIS(m,iaer,radius_id+1) + ENDDO + qrefVISb(gausind,iaer)= & + (1-kint)*QREFvis(iaer,radius_id) + & + kint*QREFvis(iaer,radius_id+1) + omegrefVISb(gausind,iaer)= 0 +! omegrefVISb(gausind,iaer)= & +! (1-kint)*omegaREFvis(iaer,radius_id) + & +! kint*omegaREFvis(iaer,radius_id+1) + ELSE ! INFRARED DOMAIN ---------------------------------- + DO m=1,L_NSPECTI + qsqrefIRb(m,gausind,iaer)= & + (1-kint)*QIRsQREF(m,iaer,radius_id) + & + kint*QIRsQREF(m,iaer,radius_id+1) + omegIRb(m,gausind,iaer)= & + (1-kint)*omegaIR(m,iaer,radius_id) + & + kint*omegaIR(m,iaer,radius_id+1) + gIRb(m,gausind,iaer)= & + (1-kint)*gIR(m,iaer,radius_id) + & + kint*gIR(m,iaer,radius_id+1) + ENDDO + qrefIRb(gausind,iaer)= & + (1-kint)*QREFir(iaer,radius_id) + & + kint*QREFir(iaer,radius_id+1) + omegrefIRb(gausind,iaer)= & + (1-kint)*omegaREFir(iaer,radius_id) + & + kint*omegaREFir(iaer,radius_id+1) + ENDIF + ENDDO + +!================================================================== +! CONSTANT NUEFF FROM HERE +!================================================================== + +! 2. Compute the scattering parameters using linear +! interpolation over grain sizes and constant nueff +! --------------------------------------------------- + + DO lg = 1,nlayer + DO ig = 1, ngrid +! 2.1 Effective radius index and kx calculation + var_tmp=reffrad(ig,lg,iaer)/refftabmin + var_tmp=log(var_tmp)*3. + var_tmp=var_tmp/logvratgrid+1. + grid_i=floor(var_tmp) + IF (grid_i.GE.refftabsize) THEN +! WRITE(*,*) 'Warning: particle size in grid box #' +! WRITE(*,*) ig,' is too large to be used by the ' +! WRITE(*,*) 'radiative transfer; please extend the ' +! WRITE(*,*) 'interpolation grid to larger grain sizes.' + grid_i=refftabsize-1 + kx = 1. + ELSEIF (grid_i.LT.1) THEN +! WRITE(*,*) 'Warning: particle size in grid box #' +! WRITE(*,*) ig,' is too small to be used by the ' +! WRITE(*,*) 'radiative transfer; please extend the ' +! WRITE(*,*) 'interpolation grid to smaller grain sizes.' + grid_i=1 + kx = 0. + ELSE + kx = ( reffrad(ig,lg,iaer)-refftab(grid_i) ) / & + ( refftab(grid_i+1)-refftab(grid_i) ) + ENDIF +! 2.3 Integration + DO j=grid_i,grid_i+1 +! 2.3.1 Check if the calculation has been done + IF (.NOT.checkgrid(j,1,iaer,idomain)) THEN +! 2.3.2 Log-normal dist., r_g and sigma_g are defined +! in [hansen_1974], "Light scattering in planetary +! atmospheres", Space Science Reviews 16 527-610. +! Here, sizedistk1=r_g and sizedistk2=sigma_g^2 + sizedistk2 = log(1.+nueffrad(1,1,iaer)) + sizedistk1 = exp(2.5*sizedistk2) + sizedistk1 = refftab(j) / sizedistk1 + + normd(j,1,iaer,idomain) = 1e-30 + DO gausind=1,ngau + drad=radiusr*radgaus(gausind) + dista(j,1,iaer,idomain,gausind) = LOG((radiusm-drad)/sizedistk1) + dista(j,1,iaer,idomain,gausind) = & + EXP(-dista(j,1,iaer,idomain,gausind) * & + dista(j,1,iaer,idomain,gausind) * & + 0.5e0/sizedistk2)/(radiusm-drad) + dista(j,1,iaer,idomain,gausind) = & + dista(j,1,iaer,idomain,gausind) / & + (sqrt(2e0*pi*sizedistk2)) + + distb(j,1,iaer,idomain,gausind) = LOG((radiusm+drad)/sizedistk1) + distb(j,1,iaer,idomain,gausind) = & + EXP(-distb(j,1,iaer,idomain,gausind) * & + distb(j,1,iaer,idomain,gausind) * & + 0.5e0/sizedistk2)/(radiusm+drad) + distb(j,1,iaer,idomain,gausind) = & + distb(j,1,iaer,idomain,gausind) / & + (sqrt(2e0*pi*sizedistk2)) + + normd(j,1,iaer,idomain)=normd(j,1,iaer,idomain) + & + weightgaus(gausind) * & + ( & + distb(j,1,iaer,idomain,gausind) * pi * & + radGAUSb(gausind,iaer,idomain) * & + radGAUSb(gausind,iaer,idomain) + & + dista(j,1,iaer,idomain,gausind) * pi * & + radGAUSa(gausind,iaer,idomain) * & + radGAUSa(gausind,iaer,idomain) & + ) + ENDDO + IF (idomain.EQ.1) THEN ! VISIBLE DOMAIN ----------- +! 2.3.3.vis Initialization + qsqrefVISgrid(j,1,:,iaer)=0. + qextVISgrid(j,1,:,iaer)=0. + qscatVISgrid(j,1,:,iaer)=0. + omegVISgrid(j,1,:,iaer)=0. + gVISgrid(j,1,:,iaer)=0. + qrefVISgrid(j,1,iaer)=0. + qscatrefVISgrid(j,1,iaer)=0. + omegrefVISgrid(j,1,iaer)=0. + + DO gausind=1,ngau + DO m=1,L_NSPECTV +! Convolution: + qextVISgrid(j,1,m,iaer) = & + qextVISgrid(j,1,m,iaer) + & + weightgaus(gausind) * & + ( & + qsqrefVISb(m,gausind,iaer) * & + qrefVISb(gausind,iaer) * & + pi*radGAUSb(gausind,iaer,idomain) * & + radGAUSb(gausind,iaer,idomain) * & + distb(j,1,iaer,idomain,gausind) + & + qsqrefVISa(m,gausind,iaer) * & + qrefVISa(gausind,iaer) * & + pi*radGAUSa(gausind,iaer,idomain) * & + radGAUSa(gausind,iaer,idomain) * & + dista(j,1,iaer,idomain,gausind) & + ) + qscatVISgrid(j,1,m,iaer) = & + qscatVISgrid(j,1,m,iaer) + & + weightgaus(gausind) * & + ( & + omegVISb(m,gausind,iaer) * & + qsqrefVISb(m,gausind,iaer) * & + qrefVISb(gausind,iaer) * & + pi*radGAUSb(gausind,iaer,idomain) * & + radGAUSb(gausind,iaer,idomain) * & + distb(j,1,iaer,idomain,gausind) + & + omegVISa(m,gausind,iaer) * & + qsqrefVISa(m,gausind,iaer) * & + qrefVISa(gausind,iaer) * & + pi*radGAUSa(gausind,iaer,idomain) * & + radGAUSa(gausind,iaer,idomain) * & + dista(j,1,iaer,idomain,gausind) & + ) + gVISgrid(j,1,m,iaer) = & + gVISgrid(j,1,m,iaer) + & + weightgaus(gausind) * & + ( & + omegVISb(m,gausind,iaer) * & + qsqrefVISb(m,gausind,iaer) * & + qrefVISb(gausind,iaer) * & + gVISb(m,gausind,iaer) * & + pi*radGAUSb(gausind,iaer,idomain) * & + radGAUSb(gausind,iaer,idomain) * & + distb(j,1,iaer,idomain,gausind) + & + omegVISa(m,gausind,iaer) * & + qsqrefVISa(m,gausind,iaer) * & + qrefVISa(gausind,iaer) * & + gVISa(m,gausind,iaer) * & + pi*radGAUSa(gausind,iaer,idomain) * & + radGAUSa(gausind,iaer,idomain) * & + dista(j,1,iaer,idomain,gausind) & + ) + ENDDO + qrefVISgrid(j,1,iaer) = & + qrefVISgrid(j,1,iaer) + & + weightgaus(gausind) * & + ( & + qrefVISb(gausind,iaer) * & + pi*radGAUSb(gausind,iaer,idomain) * & + radGAUSb(gausind,iaer,idomain) * & + distb(j,1,iaer,idomain,gausind) + & + qrefVISa(gausind,iaer) * & + pi*radGAUSa(gausind,iaer,idomain) * & + radGAUSa(gausind,iaer,idomain) * & + dista(j,1,iaer,idomain,gausind) & + ) + qscatrefVISgrid(j,1,iaer) = & + qscatrefVISgrid(j,1,iaer) + & + weightgaus(gausind) * & + ( & + omegrefVISb(gausind,iaer) * & + qrefVISb(gausind,iaer) * & + pi*radGAUSb(gausind,iaer,idomain) * & + radGAUSb(gausind,iaer,idomain) * & + distb(j,1,iaer,idomain,gausind) + & + omegrefVISa(gausind,iaer) * & + qrefVISa(gausind,iaer) * & + pi*radGAUSa(gausind,iaer,idomain) * & + radGAUSa(gausind,iaer,idomain) * & + dista(j,1,iaer,idomain,gausind) & + ) + ENDDO + + qrefVISgrid(j,1,iaer)=qrefVISgrid(j,1,iaer) / & + normd(j,1,iaer,idomain) + qscatrefVISgrid(j,1,iaer)=qscatrefVISgrid(j,1,iaer) / & + normd(j,1,iaer,idomain) + omegrefVISgrid(j,1,iaer)=qscatrefVISgrid(j,1,iaer) / & + qrefVISgrid(j,1,iaer) + DO m=1,L_NSPECTV + qextVISgrid(j,1,m,iaer)=qextVISgrid(j,1,m,iaer) / & + normd(j,1,iaer,idomain) + qscatVISgrid(j,1,m,iaer)=qscatVISgrid(j,1,m,iaer) / & + normd(j,1,iaer,idomain) + gVISgrid(j,1,m,iaer)=gVISgrid(j,1,m,iaer) / & + qscatVISgrid(j,1,m,iaer) / & + normd(j,1,iaer,idomain) + + qsqrefVISgrid(j,1,m,iaer)=qextVISgrid(j,1,m,iaer) / & + qrefVISgrid(j,1,iaer) + omegVISgrid(j,1,m,iaer)=qscatVISgrid(j,1,m,iaer) / & + qextVISgrid(j,1,m,iaer) + ENDDO + ELSE ! INFRARED DOMAIN ---------- +! 2.3.3.ir Initialization + qsqrefIRgrid(j,1,:,iaer)=0. + qextIRgrid(j,1,:,iaer)=0. + qscatIRgrid(j,1,:,iaer)=0. + omegIRgrid(j,1,:,iaer)=0. + gIRgrid(j,1,:,iaer)=0. + qrefIRgrid(j,1,iaer)=0. + qscatrefIRgrid(j,1,iaer)=0. + omegrefIRgrid(j,1,iaer)=0. + + DO gausind=1,ngau + DO m=1,L_NSPECTI +! Convolution: + qextIRgrid(j,1,m,iaer) = & + qextIRgrid(j,1,m,iaer) + & + weightgaus(gausind) * & + ( & + qsqrefIRb(m,gausind,iaer) * & + qrefVISb(gausind,iaer) * & + pi*radGAUSb(gausind,iaer,idomain) * & + radGAUSb(gausind,iaer,idomain) * & + distb(j,1,iaer,idomain,gausind) + & + qsqrefIRa(m,gausind,iaer) * & + qrefVISa(gausind,iaer) * & + pi*radGAUSa(gausind,iaer,idomain) * & + radGAUSa(gausind,iaer,idomain) * & + dista(j,1,iaer,idomain,gausind) & + ) + qscatIRgrid(j,1,m,iaer) = & + qscatIRgrid(j,1,m,iaer) + & + weightgaus(gausind) * & + ( & + omegIRb(m,gausind,iaer) * & + qsqrefIRb(m,gausind,iaer) * & + qrefVISb(gausind,iaer) * & + pi*radGAUSb(gausind,iaer,idomain) * & + radGAUSb(gausind,iaer,idomain) * & + distb(j,1,iaer,idomain,gausind) + & + omegIRa(m,gausind,iaer) * & + qsqrefIRa(m,gausind,iaer) * & + qrefVISa(gausind,iaer) * & + pi*radGAUSa(gausind,iaer,idomain) * & + radGAUSa(gausind,iaer,idomain) * & + dista(j,1,iaer,idomain,gausind) & + ) + gIRgrid(j,1,m,iaer) = & + gIRgrid(j,1,m,iaer) + & + weightgaus(gausind) * & + ( & + omegIRb(m,gausind,iaer) * & + qsqrefIRb(m,gausind,iaer) * & + qrefVISb(gausind,iaer) * & + gIRb(m,gausind,iaer) * & + pi*radGAUSb(gausind,iaer,idomain) * & + radGAUSb(gausind,iaer,idomain) * & + distb(j,1,iaer,idomain,gausind) + & + omegIRa(m,gausind,iaer) * & + qsqrefIRa(m,gausind,iaer) * & + qrefVISa(gausind,iaer) * & + gIRa(m,gausind,iaer) * & + pi*radGAUSa(gausind,iaer,idomain) * & + radGAUSa(gausind,iaer,idomain) * & + dista(j,1,iaer,idomain,gausind) & + ) + ENDDO + qrefIRgrid(j,1,iaer) = & + qrefIRgrid(j,1,iaer) + & + weightgaus(gausind) * & + ( & + qrefIRb(gausind,iaer) * & + pi*radGAUSb(gausind,iaer,idomain) * & + radGAUSb(gausind,iaer,idomain) * & + distb(j,1,iaer,idomain,gausind) + & + qrefIRa(gausind,iaer) * & + pi*radGAUSa(gausind,iaer,idomain) * & + radGAUSa(gausind,iaer,idomain) * & + dista(j,1,iaer,idomain,gausind) & + ) + qscatrefIRgrid(j,1,iaer) = & + qscatrefIRgrid(j,1,iaer) + & + weightgaus(gausind) * & + ( & + omegrefIRb(gausind,iaer) * & + qrefIRb(gausind,iaer) * & + pi*radGAUSb(gausind,iaer,idomain) * & + radGAUSb(gausind,iaer,idomain) * & + distb(j,1,iaer,idomain,gausind) + & + omegrefIRa(gausind,iaer) * & + qrefIRa(gausind,iaer) * & + pi*radGAUSa(gausind,iaer,idomain) * & + radGAUSa(gausind,iaer,idomain) * & + dista(j,1,iaer,idomain,gausind) & + ) + ENDDO + + qrefIRgrid(j,1,iaer)=qrefIRgrid(j,1,iaer) / & + normd(j,1,iaer,idomain) + qscatrefIRgrid(j,1,iaer)=qscatrefIRgrid(j,1,iaer) / & + normd(j,1,iaer,idomain) + omegrefIRgrid(j,1,iaer)=qscatrefIRgrid(j,1,iaer) / & + qrefIRgrid(j,1,iaer) + DO m=1,L_NSPECTI + qextIRgrid(j,1,m,iaer)=qextIRgrid(j,1,m,iaer) / & + normd(j,1,iaer,idomain) + qscatIRgrid(j,1,m,iaer)=qscatIRgrid(j,1,m,iaer) / & + normd(j,1,iaer,idomain) + gIRgrid(j,1,m,iaer)=gIRgrid(j,1,m,iaer) / & + qscatIRgrid(j,1,m,iaer) / & + normd(j,1,iaer,idomain) + + qsqrefIRgrid(j,1,m,iaer)=qextIRgrid(j,1,m,iaer) / & + qrefVISgrid(j,1,iaer) + omegIRgrid(j,1,m,iaer)=qscatIRgrid(j,1,m,iaer) / & + qextIRgrid(j,1,m,iaer) + ENDDO + ENDIF ! -------------------------- + checkgrid(j,1,iaer,idomain) = .true. + ENDIF !checkgrid + ENDDO !grid_i +! 2.4 Linear interpolation + k1 = (1-kx) + k2 = kx + IF (idomain.EQ.1) THEN ! VISIBLE ------------------------ + DO m=1,L_NSPECTV + QVISsQREF3d(ig,lg,m,iaer) = & + k1*qsqrefVISgrid(grid_i,1,m,iaer) + & + k2*qsqrefVISgrid(grid_i+1,1,m,iaer) + omegaVIS3d(ig,lg,m,iaer) = & + k1*omegVISgrid(grid_i,1,m,iaer) + & + k2*omegVISgrid(grid_i+1,1,m,iaer) + gVIS3d(ig,lg,m,iaer) = & + k1*gVISgrid(grid_i,1,m,iaer) + & + k2*gVISgrid(grid_i+1,1,m,iaer) + ENDDO !L_NSPECTV + QREFvis3d(ig,lg,iaer) = & + k1*qrefVISgrid(grid_i,1,iaer) + & + k2*qrefVISgrid(grid_i+1,1,iaer) +! omegaREFvis3d(ig,lg,iaer) = & +! k1*omegrefVISgrid(grid_i,1,iaer) + & +! k2*omegrefVISgrid(grid_i+1,1,iaer) + ELSE ! INFRARED ----------------------- + DO m=1,L_NSPECTI + QIRsQREF3d(ig,lg,m,iaer) = & + k1*qsqrefIRgrid(grid_i,1,m,iaer) + & + k2*qsqrefIRgrid(grid_i+1,1,m,iaer) + omegaIR3d(ig,lg,m,iaer) = & + k1*omegIRgrid(grid_i,1,m,iaer) + & + k2*omegIRgrid(grid_i+1,1,m,iaer) + gIR3d(ig,lg,m,iaer) = & + k1*gIRgrid(grid_i,1,m,iaer) + & + k2*gIRgrid(grid_i+1,1,m,iaer) + ENDDO !L_NSPECTI + QREFir3d(ig,lg,iaer) = & + k1*qrefIRgrid(grid_i,1,iaer) + & + k2*qrefIRgrid(grid_i+1,1,iaer) +! omegaREFir3d(ig,lg,iaer) = & +! k1*omegrefIRgrid(grid_i,1,iaer) + & +! k2*omegrefIRgrid(grid_i+1,1,iaer) + ENDIF ! -------------------------------- + ENDDO !nlayer + ENDDO !ngrid + +!================================================================== + + + + ENDDO ! idomain + + ENDIF ! nsize = 1 + + ENDDO ! iaer (loop on aerosol kind) + + END SUBROUTINE aerosol_optical_properties + + +end module aerosol_optical_properties_mod Index: trunk/LMDZ.GENERIC/libf/phygeneric/aerosol_optical_properties_averaging.F =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/aerosol_optical_properties_averaging.F (revision 4077) +++ trunk/LMDZ.GENERIC/libf/phygeneric/aerosol_optical_properties_averaging.F (revision 4077) @@ -0,0 +1,309 @@ + SUBROUTINE aerosol_optical_properties_averaging(ndata, + & longdata,epdata,omegdata,gdata, + & longref,epref,temp,nir,longir, + & epir,omegir,gir,qref,omegaref) + + + IMPLICIT NONE +c....................................................................... +c +c R.Fournier 02/1996 +c (modif F.Forget 02/1996) +c le spectre est decoupe en "nir" bandes et cette routine calcule +c les donnees radiatives moyenne sur chaque bande : l'optimisation +c est faite pour une temperature au sol "temp" et une epaisseur +c optique de l'atmosphere "epref" a la longueur d'onde "longref" +c +c dans la version actuelle, les ponderations sont independantes de +c l'epaisseur optique : c'est a dire que "omegir", "gir" +c et "epir/epre" sont independants de "epref". +c en effet les ponderations sont choisies pour une solution exacte +c en couche mince et milieu isotherme. +c +c entree +c +c ndata : taille des champs data +c longdata,epdata,omegdata,gdata : proprietes radiative de l'aerosol +c (longdata longueur d'onde en METRES) +c * longref : longueur d'onde a laquelle l'epaisseur optique +c est connue +c * epref : epaisseur optique a longref +c * temp : temperature choisie pour la ponderation (Planck) +c * nir : nombre d'intervals dans la discretisation spectrale +c du GCM +c * longir : longueurs d'onde definissant ces intervals +c +c sortie +c +c * epir : epaisseur optique moyenne pour chaque interval +c * omegir : "scattering albedo" moyen pour chaque interval +c * gir : "assymetry factor" moyen pour chaque interval +c * qref : extinction coefficient at reference wavelength +c * omegaref : single scat. albedo at reference wavelength +c +c....................................................................... +c + REAL longref + REAL epref + REAL temp + INTEGER nir + REAL*8 longir(nir+1) + REAL epir(nir) + REAL omegir(nir) + REAL gir(nir) +c +c....................................................................... +c + INTEGER iir + INTEGER,PARAMETER :: nirmx=1900 + INTEGER idata,ndata +c +c....................................................................... +c + REAL emit + REAL totalemit(nirmx) + REAL longdata(ndata),epdata(ndata) + & ,omegdata(ndata),gdata(ndata) + REAL qextcorrdata(ndata) + INTEGER ibande + INTEGER,PARAMETER :: nbande=1000 + REAL long,deltalong + INTEGER ilong + INTEGER i1,i2 + REAL c1,c2 + REAL factep,qextcorr,omeg,g + REAL qref,omegaref +c +c....................................................................... +c + DOUBLE PRECISION tmp1 + REAL tmp2,tmp3 +c +c + long=longref + +c check ordering of longdata + DO idata=1,ndata-1 + IF (longdata(1).LT.longdata(ndata)) THEN + IF (.not.(longdata(idata).LT.longdata(idata+1))) THEN + call abort_physic("aerosol_optical_properties_averaging", + & "Non descending order in longdata",1) + ENDIF + ELSEIF (longdata(1).GT.longdata(ndata)) THEN + IF (.not.(longdata(idata).GT.longdata(idata+1))) THEN + call abort_physic("aerosol_optical_properties_averaging", + & "Non ascending order in longdata",1) + ENDIF + ENDIF + ENDDO +c + + + + +c******************************************************** +c interpolation +c wavelengths (longdata) from data file in ascending order + IF (longdata(1).LT.longdata(ndata)) THEN + ilong=1 + DO idata=2,ndata + IF (long.gt.longdata(idata)) ilong=idata + ENDDO + i1=ilong + i2=ilong+1 + IF (i2.gt.ndata) i2=ndata + IF (long.lt.longdata(1)) i2=1 + IF (i1.eq.i2) THEN + c1=1.E+0 + c2=0.E+0 + ELSE + c1=(longdata(i2)-long) / (longdata(i2)-longdata(i1)) + c2=(longdata(i1)-long) / (longdata(i1)-longdata(i2)) + ENDIF + qref=c1*epdata(i1)+c2*epdata(i2) + omegaref=c1*omegdata(i1)+c2*omegdata(i2) + factep=qref/epref + DO idata=1,ndata + qextcorrdata(idata)=epdata(idata)/factep + ENDDO +c wavelengths (longdata) from data file in descending order + ELSEIF (longdata(1).GT.longdata(ndata)) THEN + ilong=1 + DO idata=2,ndata + IF (long.lt.longdata(idata)) ilong=idata + ENDDO + i1=ilong+1 + i2=ilong + IF (i1.gt.ndata) i1=ndata + IF (long.gt.longdata(1)) i1=1 + IF (i1.eq.i2) THEN + c1=1.E+0 + c2=0.E+0 + ELSE + c1=(longdata(i2)-long) / (longdata(i2)-longdata(i1)) + c2=(longdata(i1)-long) / (longdata(i1)-longdata(i2)) + ENDIF + qref=c1*epdata(i1)+c2*epdata(i2) + omegaref=c1*omegdata(i1)+c2*omegdata(i2) + factep=qref/epref + DO idata=1,ndata + qextcorrdata(idata)=epdata(idata)/factep + ENDDO + ENDIF + +c******************************************************** +c....................................................................... +c wavelengths (longdata) from data file in ascending order +c....................................................................... + IF (longdata(1).LT.longdata(ndata)) THEN + DO iir=1,nir +c +c....................................................................... +c + deltalong=(longir(iir+1)-longir(iir)) / nbande + totalemit(iir)=0.E+0 + epir(iir)=0.E+0 + omegir(iir)=0.E+0 + gir(iir)=0.E+0 +c +c....................................................................... +c + DO ibande=1,nbande +c +c....................................................................... +c + long=longir(iir) + (ibande-0.5E+0) * deltalong + CALL rad_blackbody_planck_law_wavelength(DBLE(long), + & DBLE(temp),tmp1) + emit=REAL(tmp1) +c +c....................................................................... +c +c interpolation + ilong=1 + DO idata=2,ndata + IF (long.gt.longdata(idata)) ilong=idata + ENDDO + i1=ilong + i2=ilong+1 + IF (i2.gt.ndata) i2=ndata + IF (long.lt.longdata(1)) i2=1 + IF (i1.eq.i2) THEN + c1=1.E+0 + c2=0.E+0 + ELSE + c1=(longdata(i2)-long) / (longdata(i2)-longdata(i1)) + c2=(longdata(i1)-long) / (longdata(i1)-longdata(i2)) + ENDIF + qextcorr=c1*qextcorrdata(i1)+c2*qextcorrdata(i2) + omeg=c1*omegdata(i1)+c2*omegdata(i2) + g=c1*gdata(i1)+c2*gdata(i2) +c +c....................................................................... +c + totalemit(iir)=totalemit(iir)+deltalong*emit + epir(iir)=epir(iir)+deltalong*emit*qextcorr + omegir(iir)=omegir(iir)+deltalong*emit*omeg*qextcorr + gir(iir)=gir(iir)+deltalong*emit*omeg*qextcorr*g +c +c....................................................................... +c + ENDDO +c +c....................................................................... +c + gir(iir)=gir(iir)/omegir(iir) + omegir(iir)=omegir(iir)/epir(iir) + epir(iir)=epir(iir)/totalemit(iir) +c +c....................................................................... +c + ENDDO +c....................................................................... +c wavelengths (longdata) from data file in descending order +c....................................................................... + ELSEIF (longdata(1).GT.longdata(ndata)) THEN + DO iir=1,nir +c +c....................................................................... +c + deltalong=(longir(iir+1)-longir(iir)) / nbande + totalemit(iir)=0.E+0 + epir(iir)=0.E+0 + omegir(iir)=0.E+0 + gir(iir)=0.E+0 +c +c....................................................................... +c + DO ibande=1,nbande +c +c....................................................................... +c + long=longir(iir) + (ibande-0.5E+0) * deltalong + CALL rad_blackbody_planck_law_wavelength(DBLE(long) + & ,DBLE(temp),tmp1) + emit=REAL(tmp1) +c +c....................................................................... +c +c interpolation + ilong=1 + DO idata=2,ndata + IF (long.lt.longdata(idata)) ilong=idata + ENDDO + i1=ilong+1 + i2=ilong + IF (i1.gt.ndata) i1=ndata + IF (long.gt.longdata(1)) i1=1 + IF (i1.eq.i2) THEN + c1=1.E+0 + c2=0.E+0 + ELSE + c1=(longdata(i2)-long) / (longdata(i2)-longdata(i1)) + c2=(longdata(i1)-long) / (longdata(i1)-longdata(i2)) + ENDIF + qextcorr=c1*qextcorrdata(i1)+c2*qextcorrdata(i2) + omeg=c1*omegdata(i1)+c2*omegdata(i2) + g=c1*gdata(i1)+c2*gdata(i2) +c +c....................................................................... +c + totalemit(iir)=totalemit(iir)+deltalong*emit + epir(iir)=epir(iir)+deltalong*emit*qextcorr + omegir(iir)=omegir(iir)+deltalong*emit*omeg*qextcorr + gir(iir)=gir(iir)+deltalong*emit*omeg*qextcorr*g +c +c....................................................................... +c + ENDDO +c +c....................................................................... +c + gir(iir)=gir(iir)/omegir(iir) + omegir(iir)=omegir(iir)/epir(iir) + epir(iir)=epir(iir)/totalemit(iir) +c +c....................................................................... +c + ENDDO + ENDIF +c +c******************************************************** +c +c...................................................................... +c +c Diagnostic de controle si on moyenne sur tout le spectre vis ou IR : +c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +c tmp2=0.E+0 +c DO iir=1,nir +c tmp2=tmp2+totalemit(iir) +c ENDDO +c tmp3=5.67E-8 * temp**4 +c IF (abs((tmp2-tmp3)/tmp3).gt.0.05E+0) THEN +c PRINT *,'!!!! <---> il manque du Planck (voir moyenne.F)' +c PRINT *,'somme des bandes :',tmp2,'--- Planck:',tmp3 +c ENDIF +c +c...................................................................... +c + END Index: trunk/LMDZ.GENERIC/libf/phygeneric/aerosol_radius.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/aerosol_radius.F90 (revision 4077) +++ trunk/LMDZ.GENERIC/libf/phygeneric/aerosol_radius.F90 (revision 4077) @@ -0,0 +1,432 @@ +!================================================================== +module aerosol_radius +!================================================================== +! module to centralize the radii calculations for aerosols +!================================================================== + +! CO2 cloud properties (initialized in inifis) + real,save :: Nmix_co2 ! Number mixing ratio of CO2 ice particles +!$OMP THREADPRIVATE(Nmix_co2) + + ! flag to specify if we assume a constant fixed radius for particles + logical,save :: radfixed ! initialized in inifis +!$OMP THREADPRIVATE(radfixed) + +! water cloud optical properties (initialized in aerosol_radius_init below) + real, save :: rad_h2o + real, save :: rad_h2o_ice + real, save :: Nmix_h2o + real, save :: Nmix_h2o_ice +!$OMP THREADPRIVATE(rad_h2o,rad_h2o_ice,Nmix_h2o,Nmix_h2o_ice) + + real,save :: nueff_iaero_h2o ! effective variance of H2O aerosol + ! (initialized in aerosol_radius_init below) +!$OMP THREADPRIVATE(nueff_iaero_h2o) +! coefficients for a variable nueff() for h2o aerosol; disabled for now + real, parameter :: coef_hot=0.13 + real, parameter :: coef_cold=0.09 + + +contains + + +!================================================================== + subroutine aerosol_radius_init(ngrid,nlayer,reffrad,nueffrad) +!================================================================== +! Purpose +! ------- +! Compute the effective radii of liquid and icy water particles +! Jeremy Leconte (2012) +! Extended to dust, CO2, NH3, 2-lay,Nlay,auroral aerosols by ?? +! Added Radiative Generic Condensable Species effective radii +! calculations (Lucas Teinturier 2022) +! +! Authors +! ------- +! Jeremy Leconte (2012) +! +!================================================================== + use mod_phys_lmdz_para, only : is_master + use ioipsl_getin_p_mod, only: getin_p + use radinc_h, only: naerkind + use aerosol_global_variables , only: iaero_back2lay, iaero_co2, iaero_dust, & + iaero_h2o, iaero_h2so4, iaero_nh3, iaero_nlay, & + iaero_aurora, iaero_generic, i_rgcs_ice, & + iaero_venus1, iaero_venus2, iaero_venus2p, & + iaero_venus3, iaero_venusUV + use callkeys_mod, only: size_nh3_cloud, nlayaero, aeronlay_size, & + aeronlay_nueff,aerogeneric + use tracer_h, only: radius, nqtot, is_rgcs + Implicit none + + integer,intent(in) :: ngrid + integer,intent(in) :: nlayer + + real, intent(out) :: reffrad(ngrid,nlayer,naerkind) !aerosols radii (K) + real, intent(out) :: nueffrad(ngrid,nlayer,naerkind) !variance + + logical, save :: firstcall=.true. +!$OMP THREADPRIVATE(firstcall) + integer :: iaer, ia , iq, i_rad + + do iaer=1,naerkind +! these values will change once the microphysics gets to work +! UNLESS tracer=.false., in which case we should be working with +! a fixed aerosol layer, and be able to define reffrad in a +! .def file. To be improved! +! |-> Done in th n-layer aerosol case (JVO 20) + + if(iaer.eq.iaero_co2)then ! CO2 ice + reffrad(1:ngrid,1:nlayer,iaer) = 1.e-4 + nueffrad(1:ngrid,1:nlayer,iaer) = 0.1 + endif + + if(iaer.eq.iaero_h2o)then ! H2O ice + nueff_iaero_h2o=0.1 ! default value for variance of h2o aerosols + call getin_p("nueff_iaero_h2o",nueff_iaero_h2o) + if (is_master) write(*,*)" nueff_iaero_h2o = ",nueff_iaero_h2o + reffrad(1:ngrid,1:nlayer,iaer) = 1.e-5 + nueffrad(1:ngrid,1:nlayer,iaer) = nueff_iaero_h2o + endif + + if(iaer.eq.iaero_dust)then ! dust + reffrad(1:ngrid,1:nlayer,iaer) = 1.e-5 + nueffrad(1:ngrid,1:nlayer,iaer) = 0.1 + endif + + if(iaer.eq.iaero_h2so4)then ! H2SO4 ice + reffrad(1:ngrid,1:nlayer,iaer) = 1.e-6 + nueffrad(1:ngrid,1:nlayer,iaer) = 0.1 + endif + + if(iaer.eq.iaero_back2lay)then ! Two-layer aerosols + reffrad(1:ngrid,1:nlayer,iaer) = 2.e-6 + nueffrad(1:ngrid,1:nlayer,iaer) = 0.1 + endif + + + if(iaer.eq.iaero_nh3)then ! Nh3 cloud + reffrad(1:ngrid,1:nlayer,iaer) = size_nh3_cloud + nueffrad(1:ngrid,1:nlayer,iaer) = 0.1 + endif + + do ia=1,nlayaero + if(iaer.eq.iaero_nlay(ia))then ! N-layer aerosols + reffrad(1:ngrid,1:nlayer,iaer) = aeronlay_size(ia) + nueffrad(1:ngrid,1:nlayer,iaer) = aeronlay_nueff(ia) + endif + enddo + + if(iaer.eq.iaero_aurora)then ! Auroral aerosols + reffrad(1:ngrid,1:nlayer,iaer) = 3.e-7 + nueffrad(1:ngrid,1:nlayer,iaer) = 0.1 + endif + + if(iaer.eq.iaero_venus1)then ! Venus cloud, mode 1, Haus13 model + reffrad(1:ngrid,1:nlayer,iaer) = 0.49e-6 + nueffrad(1:ngrid,1:nlayer,iaer) = 0.21 + endif + + if(iaer.eq.iaero_venus2)then ! Venus cloud, mode 2, Haus13 model + reffrad(1:ngrid,1:nlayer,iaer) = 1.23e-6 + nueffrad(1:ngrid,1:nlayer,iaer) = 0.067 + endif + + if(iaer.eq.iaero_venus2p)then ! Venus cloud, mode 2p, Haus13 model + reffrad(1:ngrid,1:nlayer,iaer) = 1.56e-6 + nueffrad(1:ngrid,1:nlayer,iaer) = 0.044 + endif + + if(iaer.eq.iaero_venus3)then ! Venus cloud, mode 3, Haus13 model + reffrad(1:ngrid,1:nlayer,iaer) = 4.25e-6 + nueffrad(1:ngrid,1:nlayer,iaer) = 0.062 + endif + + if(iaer.eq.iaero_venusUV)then ! Venus cloud, UV abs, 1 val as in table + reffrad(1:ngrid,1:nlayer,iaer) = 0.5e-6 + nueffrad(1:ngrid,1:nlayer,iaer) = 0.1 + endif + + do ia=1,aerogeneric ! Radiative Generic Condensable Species + if (iaer .eq. iaero_generic(ia)) then + i_rad = i_rgcs_ice(ia) + reffrad(1:ngrid,1:nlayer,iaer)=radius(i_rad) + nueffrad(1:ngrid,1:nlayer,iaer) = 0.1 + endif + enddo ! generic radiative condensable aerosols + + enddo ! iaer=1,naerkind + + + if (radfixed) then + + if (is_master) write(*,*)"radius of H2O water particles:" + rad_h2o=13. ! default value + call getin_p("rad_h2o",rad_h2o) + if (is_master) write(*,*)" rad_h2o = ",rad_h2o + + if (is_master) write(*,*)"radius of H2O ice particles:" + rad_h2o_ice=35. ! default value + call getin_p("rad_h2o_ice",rad_h2o_ice) + if (is_master) write(*,*)" rad_h2o_ice = ",rad_h2o_ice + + else + + if (is_master) write(*,*)"Number mixing ratio of H2O water particles:" + Nmix_h2o=1.e6 ! default value + call getin_p("Nmix_h2o",Nmix_h2o) + if (is_master) write(*,*)" Nmix_h2o = ",Nmix_h2o + + if (is_master) write(*,*)"Number mixing ratio of H2O ice particles:" + Nmix_h2o_ice=Nmix_h2o ! default value + call getin_p("Nmix_h2o_ice",Nmix_h2o_ice) + if (is_master) write(*,*)" Nmix_h2o_ice = ",Nmix_h2o_ice + endif + + + end subroutine aerosol_radius_init +!================================================================== + + +!================================================================== + subroutine h2o_reffrad(ngrid,nlayer,pq,pt,reffrad,nueffrad) +!================================================================== +! Purpose +! ------- +! Compute the effective radii of liquid and icy water particles +! +! Authors +! ------- +! Jeremy Leconte (2012) +! +!================================================================== + use watercommon_h, Only: T_h2O_ice_liq,T_h2O_ice_clouds,rhowater,rhowaterice + use comcstfi_mod, only: pi + Implicit none + + integer,intent(in) :: ngrid + integer,intent(in) :: nlayer + + real, intent(in) :: pq(ngrid,nlayer) !water ice mixing ratios (kg/kg) + real, intent(in) :: pt(ngrid,nlayer) !temperature (K) + real, intent(out) :: reffrad(ngrid,nlayer) !aerosol radii + real, intent(out) :: nueffrad(ngrid,nlayer) ! dispersion + + integer :: ig,l + real zfice ,zrad,zrad_liq,zrad_ice + real,external :: CBRT + + + if (radfixed) then + do l=1,nlayer + do ig=1,ngrid + zfice = 1.0 - (pt(ig,l)-T_h2O_ice_clouds) / (T_h2O_ice_liq-T_h2O_ice_clouds) + zfice = MIN(MAX(zfice,0.0),1.0) + reffrad(ig,l)= rad_h2o * (1.-zfice) + rad_h2o_ice * zfice +! nueffrad(ig,l) = coef_hot * (1.-zfice) + coef_cold * zfice + enddo + enddo + else + do l=1,nlayer + do ig=1,ngrid + zfice = 1.0 - (pt(ig,l)-T_h2O_ice_clouds) / (T_h2O_ice_liq-T_h2O_ice_clouds) + zfice = MIN(MAX(zfice,0.0),1.0) + zrad_liq = CBRT( 3*pq(ig,l)/(4*Nmix_h2o*pi*rhowater) ) + zrad_ice = CBRT( 3*pq(ig,l)/(4*Nmix_h2o_ice*pi*rhowaterice) ) +! nueffrad(ig,l) = coef_hot * (1.-zfice) + coef_cold * zfice + zrad = zrad_liq * (1.-zfice) + zrad_ice * zfice + + reffrad(ig,l) = min(max(zrad,1.e-6),1000.e-6) + enddo + enddo + end if + +! For now only constant nueff is enabled (otherwise some specific handling +! of variable nueff is required in aerosol_optical_properties) + nueffrad(1:ngrid,1:nlayer)=nueff_iaero_h2o + + end subroutine h2o_reffrad +!================================================================== + + +!================================================================== + subroutine h2o_cloudrad(ngrid,nlayer,pql,reffliq,reffice) +!================================================================== +! Purpose +! ------- +! Compute the effective radii of liquid and icy water particles +! +! Authors +! ------- +! Jeremy Leconte (2012) +! +!================================================================== + use watercommon_h, Only: rhowater,rhowaterice + use comcstfi_mod, only: pi + Implicit none + + integer,intent(in) :: ngrid + integer,intent(in) :: nlayer + + real, intent(in) :: pql(ngrid,nlayer) !condensed water mixing ratios (kg/kg) + real, intent(out) :: reffliq(ngrid,nlayer),reffice(ngrid,nlayer) !liquid and ice water particle radii (m) + + real,external :: CBRT + integer :: i,k + + if (radfixed) then + reffliq(1:ngrid,1:nlayer)= rad_h2o + reffice(1:ngrid,1:nlayer)= rad_h2o_ice + else + do k=1,nlayer + do i=1,ngrid + reffliq(i,k) = CBRT(3*pql(i,k)/(4*Nmix_h2o*pi*rhowater)) + reffliq(i,k) = min(max(reffliq(i,k),1.e-6),1000.e-6) + + reffice(i,k) = CBRT(3*pql(i,k)/(4*Nmix_h2o_ice*pi*rhowaterice)) + reffice(i,k) = min(max(reffice(i,k),1.e-6),1000.e-6) + enddo + enddo + endif + + end subroutine h2o_cloudrad +!================================================================== + + + +!================================================================== + subroutine aerosol_radius_co2(ngrid,nlayer,nq,pq,reffrad) +!================================================================== +! Purpose +! ------- +! Compute the effective radii of co2 ice particles +! +! Authors +! ------- +! Jeremy Leconte (2012) +! +!================================================================== + USE tracer_h, only:igcm_co2_ice,rho_co2 + use comcstfi_mod, only: pi + Implicit none + + integer,intent(in) :: ngrid,nlayer,nq + + real, intent(in) :: pq(ngrid,nlayer,nq) !tracer mixing ratios (kg/kg) + real, intent(out) :: reffrad(ngrid,nlayer) !co2 ice particles radii (m) + + integer :: ig,l + real :: zrad + real,external :: CBRT + + + + if (radfixed) then + reffrad(1:ngrid,1:nlayer) = 5.e-5 ! CO2 ice + else + do l=1,nlayer + do ig=1,ngrid + zrad = CBRT( 3*pq(ig,l,igcm_co2_ice)/(4*Nmix_co2*pi*rho_co2) ) + reffrad(ig,l) = min(max(zrad,1.e-6),100.e-6) + enddo + enddo + end if + + end subroutine aerosol_radius_co2 +!================================================================== + + + +!================================================================== + subroutine aerosol_radius_dust(ngrid,nlayer,reffrad) +!================================================================== +! Purpose +! ------- +! Compute the effective radii of dust particles +! +! Authors +! ------- +! Jeremy Leconte (2012) +! +!================================================================== + Implicit none + + integer,intent(in) :: ngrid + integer,intent(in) :: nlayer + + real, intent(out) :: reffrad(ngrid,nlayer) !dust particles radii (m) + + reffrad(1:ngrid,1:nlayer) = 2.e-6 ! dust + + end subroutine aerosol_radius_dust +!================================================================== + + +!================================================================== + subroutine aerosol_radius_h2so4(ngrid,nlayer,reffrad) +!================================================================== +! Purpose +! ------- +! Compute the effective radii of h2so4 particles +! +! Authors +! ------- +! Jeremy Leconte (2012) +! +!================================================================== + Implicit none + + integer,intent(in) :: ngrid + integer,intent(in) :: nlayer + + real, intent(out) :: reffrad(ngrid,nlayer) !h2so4 particle radii (m) + + reffrad(1:ngrid,1:nlayer) = 1.e-6 ! h2so4 + + end subroutine aerosol_radius_h2so4 +!================================================================== + +!================================================================== + subroutine aerosol_radius_back2lay(ngrid,reffrad,nlayer,pplev) +!================================================================== +! Purpose +! ------- +! Compute the effective radii of particles in a 2-layer model +! +! Authors +! ------- +! Sandrine Guerlet (2013) +! +!================================================================== + use callkeys_mod, only: pres_bottom_tropo,pres_top_tropo,size_tropo, & + pres_bottom_strato,size_strato + + Implicit none + + integer,intent(in) :: ngrid + + real, intent(out) :: reffrad(ngrid,nlayer) ! particle radii (m) + REAL,INTENT(IN) :: pplev(ngrid,nlayer+1) ! inter-layer pressure (Pa) + INTEGER,INTENT(IN) :: nlayer ! number of atmospheric layers + REAL :: expfactor + INTEGER l,ig + + reffrad(:,:)=1e-6 !!initialization, not important + DO ig=1,ngrid + DO l=1,nlayer-1 + IF (pplev(ig,l) .le. pres_bottom_tropo .and. pplev(ig,l) .ge. pres_top_tropo) THEN + reffrad(ig,l) = size_tropo + ELSEIF (pplev(ig,l) .lt. pres_top_tropo .and. pplev(ig,l) .gt. pres_bottom_strato) THEN + expfactor=log(size_strato/size_tropo) / log(pres_bottom_strato/pres_top_tropo) + reffrad(ig,l)= size_tropo*((pplev(ig,l)/pres_top_tropo)**expfactor) + ELSEIF (pplev(ig,l) .le. pres_bottom_strato) then + reffrad(ig,l) = size_strato + ENDIF + ENDDO + ENDDO + + end subroutine aerosol_radius_back2lay +!================================================================== + +end module aerosol_radius +!================================================================== Index: trunk/LMDZ.GENERIC/libf/phygeneric/ave_stelspec.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/ave_stelspec.F90 (revision 4062) +++ (revision ) @@ -1,178 +1,0 @@ - module ave_stelspec_mod - - implicit none - - contains - - subroutine ave_stelspec(STELLAR) - -!================================================================== -! -! Purpose -! ------- -! Average the chosen high resolution stellar spectrum over the -! visible bands in the model. -! -! Authors -! ------- -! Robin Wordsworth (2010). -! Generalized to very late spectral types (and Brown dwarfs) Jeremy Leconte (2012) -! Modified to account for any stellar spectrum file (Lucas Teinturier and Martin Turbet, 2023-2025) -! -! Called by -! --------- -! setspv.F -! -! Calls -! ----- -! none -! -!================================================================== - - use radinc_h, only: L_NSPECTV - use radcommon_h, only: BWNV, DWNV, tstellar - use datafile_mod, only: datadir - use callkeys_mod, only: stelbbody,stelTbb - use ioipsl_getin_p_mod, only: getin_p - - implicit none - - real*8 STELLAR(L_NSPECTV) - - integer Nfine - integer,parameter :: Nfineband=200 - integer ifine,band - - real,allocatable,save :: lam(:),stel_f(:) ! read by master thread - ! but used by all threads - real lamm,lamp - real dl - - character(len=100) :: file_id,file_id_lam - character(len=200) :: file_path,file_path_lam - character(len=150) :: stelspec_file - - real lam_temp - double precision stel_temp - - integer :: ios ! file opening/reading status - logical :: file_exists - - STELLAR(:)=0.0 - - print*,'enter ave_stellspec' - if(stelbbody)then - tstellar=stelTbb - Nfine=L_NSPECTV*Nfineband - do band=1,L_NSPECTV - lamm=10000.0/BWNV(band+1) - lamp=10000.0/BWNV(band) - dl=(lamp-lamm)/(Nfineband) - do ifine=1,Nfineband - lam_temp=lamm+(lamp-lamm)*(ifine-1.)/(Nfineband) - call blackl(dble(lam_temp*1e-6),dble(tstellar),stel_temp) - STELLAR(band)=STELLAR(band)+stel_temp*dl - enddo - end do - STELLAR(1:L_NSPECTV)=STELLAR(1:L_NSPECTV)/sum(STELLAR(1:L_NSPECTV)) - else !stelbbody - ! look for a " tstellar= ..." option in def files - tstellar = -1. ! default - call getin_p("tstellar",tstellar) ! default path - if (tstellar.eq.-1.) then - write(*,*)'Beware that startype is now deprecated, you should use ' - write(*,*)'stelspec_file and tstellar to define the input stellar spectrum.' - write(*,*)' ' - write(*,*)'Error: tstellar (effective stellar temperature) needs to be specified' - write(*,*)'in callphys.def: tstellar=...' - call abort_physic("ave_stelspec", "tstellar needs to be specified",1) - end if - - write(*,*) "Input stellar temperature is:" - write(*,*) "tstellar = ",tstellar - - ! load high resolution stellar data - ! look for a " stelspec_file= ..." option in def files - stelspec_file = "None" ! default - call getin_p("stelspec_file",stelspec_file) ! default path - - write(*,*) "Input stellar spectrum file is:" - write(*,*) "stelspec_file = ",trim(stelspec_file) - write(*,*) 'Please use ',1,' and only ',1,' header line in ',trim(stelspec_file) - - ! Check the target file is there - file_path = trim(datadir)//'/stellar_spectra/'//stelspec_file - print*, 'stellar flux : ', file_path - inquire(FILE=file_path,EXIST=file_exists) - - if (.not.file_exists) THEN - write(*,*)'Beware that startype is now deprecated, you should use ' - write(*,*)'stelspec_file and tstellar to define the input stellar spectrum.' - write(*,*)' ' - write(*,*)'Error: cannot open stelspec_file file ', trim(stelspec_file) - write(*,*)'It should be in :',trim(datadir),'/stellar_spectra/' - write(*,*)'1) You can change the data directory in callphys.def' - write(*,*)' with:' - write(*,*)' datadir=/path/to/the/directory' - write(*,*)'2) You can change the input stelspec_file file name in' - write(*,*)' callphys.def with:' - write(*,*)' stelspec_file=filename' - write(*,*)'You can check the online repository to search for ' - write(*,*)'available stellar spectra here : ' - write(*,*)'https://web.lmd.jussieu.fr/~lmdz/planets/generic/datagcm/stellar_spectra/' - call abort_physic("ave_stelspec", "Unable to read stellar flux file", 1) - end if - -!$OMP MASTER - ! Open the file - OPEN(UNIT=110,FILE=file_path,STATUS='old',iostat=ios) - ! Get number of line in the file - READ(110,*) ! skip first line header just in case - Nfine = 0 - do - read(110,*,iostat=ios) - if (ios<0) exit - Nfine = Nfine + 1 - end do - rewind(110) ! Rewind file after counting lines - READ(110,*) ! skip first line header just in case - - allocate(lam(Nfine),stel_f(Nfine)) - - do ifine=1,Nfine - read(110,*) lam(ifine), stel_f(ifine) ! lam [um] stel_f [per unit of wavelength] (integrated and normalized by Fat1AU) - enddo - -!$OMP END MASTER -!$OMP BARRIER - - ! sum data by band - band=1 - Do while(lam(1).lt. real(10000.0/BWNV(band+1))) - if (band.gt.L_NSPECTV-1) exit - band=band+1 - enddo - dl=lam(2)-lam(1) - STELLAR(band)=STELLAR(band)+stel_f(1)*dl - do ifine = 2,Nfine - if(lam(ifine) .gt. real(10000.0/BWNV(band)))then - band=band-1 - endif - if(band .lt. 1) exit - dl=lam(ifine)-lam(ifine-1) - STELLAR(band)=STELLAR(band)+stel_f(ifine)*dl - end do - - - STELLAR(1:L_NSPECTV)=STELLAR(1:L_NSPECTV)/sum(STELLAR(1:L_NSPECTV)) -!$OMP BARRIER -!$OMP MASTER - deallocate(lam) - deallocate(stel_f) -!$OMP END MASTER -!$OMP BARRIER - endif !stelbbody - - end subroutine ave_stelspec - - end module ave_stelspec_mod Index: trunk/LMDZ.GENERIC/libf/phygeneric/blackl.F =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/blackl.F (revision 4062) +++ (revision ) @@ -1,43 +1,0 @@ - subroutine blackl(blalong,blat,blae) - - implicit double precision (a-h,o-z) - - ! physical constants - sigma=5.670374D-8 - pi=datan(1.d0)*4.d0 - c0=2.997925d+08 - h=6.62607d-34 - cbol=1.380649d-23 - rind=1.d0 - c=c0/rind - c1=h*(c**2) - c2=h*c/cbol - - - blae=2.d0*pi*c1/blalong**5/(dexp(c2/blalong/blat)-1.d0) - - - return - end - - subroutine blackn(blalong,blat,blae) - - implicit double precision (a-h,o-z) - - ! physical constants - sigma=5.670374D-8 - pi=datan(1.d0)*4.d0 - c0=2.997925d+08 - h=6.62607d-34 - cbol=1.380649d-23 - rind=1.d0 - c=c0/rind - c1=h*(c**2) - c2=h*c/cbol - - - blae=2.d0*pi*c1*blalong**3/(dexp(c2*blalong/blat)-1.d0) - - - return - end Index: trunk/LMDZ.GENERIC/libf/phygeneric/calc_rayleigh.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/calc_rayleigh.F90 (revision 4062) +++ (revision ) @@ -1,341 +1,0 @@ -module calc_rayleigh_mod - -implicit none - -contains - - subroutine calc_rayleigh(qvar,muvar,PMID,TMID,tauray) - -!================================================================== -! -! Purpose -! ------- -! Average the Rayleigh scattering in each band, weighting the -! average by the blackbody function at temperature tstellar. -! Works for an arbitrary mix of gases. -! -! Authors -! ------- -! Robin Wordsworth (2010) -! Jeremy Leconte (2012): Added option for variable gas. Improved water rayleigh (Bucholtz 1995). -! Noe Clement (2022) : Additionnal comments & Methane+CO Rayleigh -! Gwenael Milcareck (2025): Rewriting the code -! -! Called by -! --------- -! setspv.F -! -! Calls -! ----- -! none -! -!================================================================== - - use radinc_h, only: L_NSPECTV, L_LEVELS - use radcommon_h, only: WAVEV, BWNV, DWNV, tstellar, scalep - use gases_h, only: ngasmx, vgas, gnom, gfrac, massmol, igas_CO2, igas_H2, & - igas_H2O, igas_He, igas_N2, igas_CH4, igas_CO, igas_Ar, igas_O2 - use comcstfi_mod, only: g, pi - use callkeys_mod, only: strictboundrayleigh - - implicit none - - real, intent(in) :: qvar(L_LEVELS) ! mol/mol - real, intent(in) :: muvar(L_LEVELS) ! g/mol - real, intent(in) :: PMID(L_LEVELS) ! mbar - real, intent(in) :: TMID(L_LEVELS) ! K - real, intent(out) :: tauray(L_LEVELS,L_NSPECTV) - real*8 wl,wn - integer N,Nfine,ifine,igas,k - parameter(Nfine=500.0) - real*8 :: Fk ! King factor for the depolarization - real*8 :: ng(L_LEVELS) ! real refractive index - real*8 :: P0(L_LEVELS) ! reference pressure - real*8 :: T0(L_LEVELS) ! reference temperature - - ! Parameters for H2O - real*8 :: a0, a1, a2, a3, a4, a5, a6, a7 - real*8 :: luv, lir - real*8 :: rhor,tr,lr - real*8 :: rho(L_LEVELS),rhos(L_LEVELS),ts(L_LEVELS) - real*8 :: b(L_LEVELS) - - real*8 mass_frac(ngasmx,L_LEVELS) - real*8 tauvar(L_LEVELS),tausum(L_LEVELS) - real*8 tauwei,bwidth,bstart - double precision df - - real*8 tauconsti(ngasmx,L_LEVELS) - real*8 tauvari(ngasmx,L_LEVELS) - - ! Miscellaneous : - character(len=200) :: message - character(len=10),parameter :: subname="rayleigh" - logical, save :: firstcall=.true. -!$OMP THREADPRIVATE(firstcall) - - integer icantbewrong - - ! This module calculates the Rayleigh scattering (also known as the Cabannes peak) - ! Rayleigh wings, Brillouin scattering and Raman scattering are not taken into account. - - ! we calculate here TAURAY which is in m2/mBar - - ! The cross section for ith particles of small size compared to the wavenumber - ! and in the electric dipole approximation is: - ! sigma_i = 24*pi**3*wn**4/N**2 * ((n_i(wn)**2 - 1)/(n_i(wn)**2 + 2))**2 * Fk_i(wn) - ! nu is the wavenumber - ! N is the number density of the gas (molecule/m3) - ! n_i is the real refractive index of the ith gas - ! Fk_i is the King factor of ith gas equals to (6+3*delta_i)/(6-7*delta_i) - ! where delta_i is the depolarization factor of the ith gas - - ! The rayleigh opacity is expressed by: - ! tau_r = P/(g*mu) * sum_{i=1}^Ntot [ x_i*sigma_i ] - ! P is the pressure - ! g is the standard gravity - ! mu is the mean molecular weight - ! x_i is the mass fraction of the ith gas - ! The pressure P dependence is calculated in optcv.F90 - - if(firstcall) then - - if ((BWNV(L_NSPECTV+1).gt.60000.).and.(strictboundrayleigh)) then - message="Rayleigh scattering is unknown for wn>60000 cm-1 - all data is extrapolated for higher wavenumber - if you know what you are doing, use strictboundrayleigh=.false." - call abort_physic(subname,message,1) - elseif ((BWNV(L_NSPECTV+1).gt.60000.).and..not.(strictboundrayleigh)) then - print*,'**********************************************' - print*,' we allow model to continue with wn>60000 cm-1' - print*,' ... we assume we know what you are doing ... ' - print*,' ... but do not let this happen too often ... ' - print*,'**********************************************' - endif - firstcall = .false. - endif - - - do igas=1,ngasmx - ! Convert qvar mol/mol -> kg/kg - if((igas.eq.vgas).and.(maxval(QVAR(:)).ge.1.e-2))then - ! print*,'variable gas is ',trim(gnom(igas)),' in Rayleigh scattering ' - mass_frac(igas,:) = QVAR(:)*massmol(igas)/muvar(:) - elseif((igas/=vgas).and.(gfrac(igas).ge.1.e-2))then - mass_frac(igas,:) = gfrac(igas)*(1.-QVAR(:))*massmol(igas)/muvar(:) - else - ! print*,'Ignoring ',trim(gnom(igas)),' in Rayleigh scattering '// & - ! 'as its mixing ratio is less than 0.01.' - ! ignore variable gas in Rayleigh calculation - ! ignore gases of mixing ratio < 0.01 in Rayleigh calculation - mass_frac(igas,:) = 0.0 - endif - tauvari(igas,:) = 0. - enddo - - ! WARNING, beyond 60000 cm-1, for all molecules, there are singularities due to the interpolation formula. - - - do N=1,L_NSPECTV - - ! The refractive index depend on temperature and pressure - ! It isn't the case here. Must be implemented in the future... - ! But in the current scientific litterature (2024), it's difficult - ! to find something that depends on temperature and pressure... - ! except for H2O - - tausum = 0.0 - tauwei = 0.0 - bstart = 10000.0/BWNV(N+1) ! BWNV is in cm-1 so 10000.0/BWNV is in micron - bwidth = (10000.0/BWNV(N)) - (10000.0/BWNV(N+1)) - do ifine=1,Nfine - wl=bstart+dble(ifine)*bwidth/Nfine - wn=BWNV(N)+dble(ifine)*(BWNV(N+1)-BWNV(N))/Nfine - - tauvar(:)=0.0 - do igas=1,ngasmx - if (maxval(mass_frac(igas,:)).ge.1e-2) then - - if(igas.eq.igas_CO2)then - ! Sneep et al, 2005 - ! doi:10.1016/j.jqsrt.2004.07.025 - T0(:) = 288.15 - P0(:) = 1.01325e5 - if (wn .lt. 55331) then - ! Sneep et al, 2005 - ! doi:10.1016/j.jqsrt.2004.07.025 - ! ng -> valid range of the measurements : 0.1807 - 1.8172 um - ng(:) = 1. + 1.1427e3*(5799.25/(128908.9**2 - wn**2) + 120.05/(89223.8**2 - wn**2) + 5.3334/(75037.5**2 - wn**2) + 4.3244/(67837.7**2 - wn**2) + 0.1218145e-4/(2418.136**2 - wn**2)) ! there is an error on the paper 1.1427e6 -> 1.1427e3 - else - ! Cuthbertson and Cuthbertson, 1920 (extrapolation) - ! doi:10.1098/rspa.1920.0020 - ng(:) = 1. + (6914.45/(156.85 - (wn*1e-4)**2))*1e-5 - endif - Fk = 1.1364 + 25.3e-12*wn**2 - tauvari(igas,:) = mass_frac(igas,:)*((ng(:)**2-1.)/(ng(:)**2+2.))**2 * Fk * (wn*100.)**4 ! wn*100 -> cm-1 to m-1 - ! N=P/(kB*T) and muvar/1000 -> g/mol to kg/mol - tauconsti(igas,:) = 24.*pi**3 *6.022141E+023 / (g*(muvar(:)/1000.)*(P0(:)/(1.380649E-23*T0(:)))**2) - elseif(igas.eq.igas_N2)then - ! Sneep et al, 2005 - ! doi:10.1016/j.jqsrt.2004.07.025 - T0(:) = 288.15 - P0(:) = 1.01325e5 - if(wn.gt.21360)then !between 21360 and 39370 cm-1. We extrapolate above. - ng(:) = 1. + (5677.465 + 318.81874e12/(14.4e9 - wn**2))*1e-8 !there is an error on the paper e12 -> e13 - else !between 4860 and 21360 cm-1. We extrapolate below. - ng(:) = 1. + (6498.2 + 307.4335e12/(14.4e9 - wn**2))*1e-8 - endif - Fk = 1.034 + 3.17e-12*wn**2 - tauvari(igas,:) = mass_frac(igas,:)*((ng(:)**2-1.)/(ng(:)**2+2.))**2 * Fk * (wn*100.)**4 - tauconsti(igas,:) = 24.*pi**3 *6.022141E+023 / (g*(muvar(:)/1000.)*(P0(:)/(1.380649E-23*T0(:)))**2) - elseif(igas.eq.igas_H2O)then - Fk = (6.+3.*3e-4)/(6.-7.*3e-4) ! delta=3e-4 Murphy 1977 doi:10.1063/1.434794 - if(wn<4840.) then ! necessary to prevent a singularity at 3230 cm-1 - ! Ciddor, 1996 - ! doi:10.1364/AO.35.001566 for wn<4840 cm-1 - T0(:)=293.15 - P0(:)=1333. - ng(:) = 1. + 1.022e-8*(295.235 + 2.6422*(wn*1e-4)**2 - 0.032380*(wn*1e-4)**4 + 0.004028*(wn*1e-4)**6) - tauvari(igas,:) = mass_frac(igas,:)*((ng(:)**2-1.)/(ng(:)**2+2.))**2 * Fk * (wn*100.)**4 - tauconsti(igas,:) = 24.*pi**3 *6.022141E+023 / (g*(muvar(:)/1000.)*(P0(:)/(1.380649E-23*T0(:)))**2) - elseif(wn>50000.) then - ! Barrell and Sears, 1939 (extrapolation) - ! doi:10.1098/rsta.1939.0004 - T0(:)=273.15 - P0(:)=101325. - ng(:) = 1. + (245.40+2.187*(1e4/wn)**(-2))*1e-6 - tauvari(igas,:) = mass_frac(igas,:)*((ng(:)**2-1.)/(ng(:)**2+2.))**2 * Fk * (wn*100.)**4 - tauconsti(igas,:) = 24.*pi**3 *6.022141E+023 / (g*(muvar(:)/1000.)*(P0(:)/(1.380649E-23*T0(:)))**2) - else - ! Harvey et al, 1998 - ! doi:10.1063/1.556029 - ! ng -> valid range of the measurements : 0.2 - 1.1 um - a0 = 0.244257733 - a1 = 9.74634476e-3 - a2 = -3.73234996e-3 - a3 = 2.68678472e-4 - a4 = 1.58920570e-3 - a5 = 2.45934259e-3 - a6 = 0.900704920 - a7 = -1.66626219e-2 - luv = 0.2292020 - lir = 5.432937 - Tr = 273.15 - rhor = 1000. - T0(:) = tmid(:) - P0(:) = pmid(:)*scalep - lr = 0.589 - rho(:) = mass_frac(igas,:)*muvar(:)/massmol(igas)*P0(:)/(8.314463*T0(:)/(muvar(:)/1000.)) - rhos(:) = rho(:)/rhor - ts(:) = T0(:)/Tr - b(:) = (a0 + a1*rhos(:) + a2*ts(:) + a3*ts(:)*(10000./wn/lr)**2 + a4/(10000./wn/lr)**2 + a5/((10000./wn/lr)**2 - luv**2) + a6/((10000./wn/lr)**2 - lir**2) + a7*rhos(:)**2)*rhos(:) - ng(:) = sqrt(2.*b(:)+1.)/sqrt(1.-b(:)) - tauvari(igas,:) = mass_frac(igas,:)*((ng(:)**2-1.)/(ng(:)**2+2.))**2 * Fk * (wn*100.)**4 - tauconsti(igas,:) = 24.*pi**3 *6.022141E+023 / (g*(muvar(:)/1000.)*(P0(:)/(1.380649E-23*T0(:)))**2) - endif - elseif(igas.eq.igas_H2)then - ! Peck and Hung, 1977 - ! doi:10.1364/JOSA.67.001550 - T0(:) = 273.15 - P0(:) = 1.01325e5 - ! ng -> valid range of the measurements : 0.1680 - 1.6945 um - if(wn<59534.) then - ng(:) = 1. + (14895.6/(180.7 - (wn*1e-4)**2) + 4903.7/(92.-(wn*1e-4)**2))*1e-6 - else - ng(:) = 1. + (23.79 + 12307.2/(109.832-(wn*1e-4)**2))*1e-6 ! extrapolation - endif - Fk = (6.+3.*0.02)/(6.-7.*0.02) ! delta=0.02 Hansen 1974 - tauvari(igas,:) = mass_frac(igas,:)*((ng(:)**2-1.)/(ng(:)**2+2.))**2 * Fk * (wn*100.)**4 - tauconsti(igas,:) = 24.*pi**3 *6.022141E+023 / (g*(muvar(:)/1000.)*(P0(:)/(1.380649E-23*T0(:)))**2) - elseif(igas.eq.igas_He)then - ! Thalman et al, 2014 - ! doi:10.1016/j.jqsrt.2014.05.030 - T0(:) = 288.15 - P0(:) = 1.01325e5 - ! ng -> valid range of the measurements : 0.2753 - 20.5813 um - ng(:) = 1. + (2283. + 1.8102e13/(1.5342e10 - wn**2))*1e-8 - Fk = 1. - tauvari(igas,:) = mass_frac(igas,:)*((ng(:)**2-1.)/(ng(:)**2+2.))**2 * Fk * (wn*100.)**4 - tauconsti(igas,:) = 24.*pi**3 *6.022141E+023 / (g*(muvar(:)/1000.)*(P0(:)/(1.380649E-23*T0(:)))**2) - elseif(igas.eq.igas_CH4)then - ! Sneep et al, 2005 - ! doi:10.1016/j.jqsrt.2004.07.025 - T0(:) = 288.15 - P0(:) = 1.01325e5 - ! ng -> valid range of the measurements : 0.3251 - 0.6330 um - ng(:) = 1. + 46662e-8 + 4.02e-14*wn**2 - Fk = 1. - tauvari(igas,:) = mass_frac(igas,:)*((ng(:)**2-1.)/(ng(:)**2+2.))**2 * Fk * (wn*100.)**4 - tauconsti(igas,:) = 24.*pi**3 *6.022141E+023 / (g*(muvar(:)/1000.)*(P0(:)/(1.380649E-23*T0(:)))**2) - elseif(igas.eq.igas_CO)then - ! Sneep et al, 2005 - ! doi:10.1016/j.jqsrt.2004.07.025 - T0(:) = 288.15 - P0(:) = 1.01325e5 - ! ng -> valid range of the measurements : 0.168 - 0.288 um - if(wn<59809.) then - ng(:) = 1. + 22851e-8 + 0.456e4/(71427.**2 - wn**2) - else - ng(:) = 1.00028476-2.01518666e-9*wn+1.88043553e-14*wn**2 ! extrapolation from previous data - endif - Fk = 1.016 - tauvari(igas,:) = mass_frac(igas,:)*((ng(:)**2-1.)/(ng(:)**2+2.))**2 * Fk * (wn*100.)**4 - tauconsti(igas,:) = 24.*pi**3 *6.022141E+023 / (g*(muvar(:)/1000.)*(P0(:)/(1.380649E-23*T0(:)))**2) - elseif(igas.eq.igas_Ar)then - ! Sneep et al, 2005 - ! doi:10.1016/j.jqsrt.2004.07.025 - T0(:) = 288.15 - P0(:) = 1.01325e5 - ! ng -> valid range of the measurements : 0.288 - 0.546 um - ng(:) = 1. + (6432.135 + 286.06021e12/(14.4e9 - wn**2))*1e-8 - Fk = 1. - tauvari(igas,:) = mass_frac(igas,:)*((ng(:)**2-1.)/(ng(:)**2+2.))**2 * Fk * (wn*100.)**4 - tauconsti(igas,:) = 24.*pi**3 *6.022141E+023 / (g*(muvar(:)/1000.)*(P0(:)/(1.380649E-23*T0(:)))**2) - elseif(igas.eq.igas_O2)then - ! Sneep et al, 2005 - ! doi:10.1016/j.jqsrt.2004.07.025 - T0(:) = 273.15 - P0(:) = 1.01325e5 - if (wn .lt. 18315) then - ! ng -> valid range of the measurements : > 0.546 um - ng(:) = 1. + (21351.3 + 21.85670/(4.09e9 - wn**2))*1e-8 - elseif ((18315 .le. wn) .and. (wn .lt. 34722)) then - ! ng -> valid range of the measurements : 0.288 - 0.546 um - ng(:) = 1. + (20564.8 + 24.80899/(4.09e9 - wn**2))*1e-8 - elseif ((34722 .le. wn) .and. (wn .lt. 45248)) then - ! ng -> valid range of the measurements : 0.288 - 0.221 um - ng(:) = 1. + (22120.4 + 20.31876/(4.09e9 - wn**2))*1e-8 - else - ! ng -> valid range of the measurements : < 0.221 um - ng(:) = 1. + (23796.7 + 16.89884/(4.09e9 - wn**2))*1e-8 - endif - Fk = 1.09 + 1.385e-11*wn**2 + 1.488e-20*wn**4 - tauvari(igas,:) = mass_frac(igas,:)*((ng(:)**2-1.)/(ng(:)**2+2.))**2 * Fk * (wn*100.)**4 - tauconsti(igas,:) = 24.*pi**3 *6.022141E+023 / (g*(muvar(:)/1000.)*(P0(:)/(1.380649E-23*T0(:)))**2) - else - print*,'No rayleigh scattering for ',trim(gnom(igas)),'. No data found.' - endif - - ! N=P/(kB*T) - ! pmid*scalep -> mbar to Pa - ! muvar/1000 -> g/mol to kg/mol - - tauvar(:)=tauvar(:)+tauconsti(igas,:)*tauvari(igas,:) - - endif !greater than 0.01 - - enddo !ngasmx - - call blackl(dble(wl*1e-6),dble(tstellar),df) - df=df*bwidth/Nfine - tauwei=tauwei+df - tausum(:)=tausum(:)+tauvar(:)*df - - enddo !Nfine - ! We add a scalep because pressure in radiative transfer is in mbar - TAURAY(:,N)=tausum(:)*scalep/tauwei - - end do !L_NSPECTV - - - end subroutine calc_rayleigh - -end module calc_rayleigh_mod Index: trunk/LMDZ.GENERIC/libf/phygeneric/call_rings.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/call_rings.F90 (revision 4062) +++ (revision ) @@ -1,69 +1,0 @@ -subroutine call_rings(ngrid, ptime, pday, diurnal) - ! A subroutine to compute the day fraction in case of rings shadowing. - - use radcommon_h, only: eclipse - use comsaison_h, only: fract, declin - use comcstfi_mod, only: rad, pi - use comdiurn_h, only: coslat, sinlat, coslon, sinlon - use callkeys_mod, only: flatten - - INTEGER, INTENT(IN) :: ngrid - REAL, INTENT(IN) :: ptime ! "universal time", given as fraction of sol (e.g.: 0.5 for noon) - REAL, INTENT(IN) :: pday ! Number of days counted from the North. Spring equinoxe. - LOGICAL, INTENT(IN) :: diurnal -! REAL, DIMENSION(:), INTENT(INOUT) :: fract ! day fraction for each point of the planet - -! to compute the daily average of rings shadowing - INTEGER, PARAMETER :: nb_hours = 1536 ! set how many times per day are used - REAL :: pas - INTEGER :: m - REAL :: ptime_day ! Universal time in sol fraction - REAL:: tmp_zls,tmp_dist_star, tmp_declin, tmp_right_ascen ! tmp solar longitude, stellar dist, declin and RA - REAL :: ztim1, ztim2, ztim3 - REAL, DIMENSION(:), ALLOCATABLE :: tmp_fract ! day fraction of the time interval - REAL, DIMENSION(:), ALLOCATABLE :: tmp_mu0 ! equivalent solar angle - -!! Eclipse incoming sunlight (e.g. Saturn ring shadowing) - ALLOCATE(eclipse(ngrid)) - - write(*,*) 'Rings shadow activated' - - if(diurnal .eqv. .false.) then ! we need to compute the daily average insolation (day fraction) - pas = 1./nb_hours - ptime_day = 0. - fract(:) = 0. - ALLOCATE(tmp_fract(ngrid)) - ALLOCATE(tmp_mu0(ngrid)) - tmp_fract(:) = 0. - eclipse(:) = 0. - tmp_mu0(:) = 0. - - do m=1, nb_hours - ptime_day = m*pas - call stellarlong(pday+ptime_day,tmp_zls) - call orbite(tmp_zls,tmp_dist_star,tmp_declin,tmp_right_ascen) - - ztim1=SIN(tmp_declin) - ztim2=COS(tmp_declin)*COS(2.*pi*(pday+ptime_day-.5)) - ztim3=-COS(tmp_declin)*SIN(2.*pi*(pday+ptime_day-.5)) - - call stelang(ngrid,sinlon,coslon,sinlat,coslat, & - ztim1,ztim2,ztim3,tmp_mu0,tmp_fract, flatten) - call rings(ngrid, tmp_declin, ptime_day, rad, flatten, eclipse) - fract(:) = fract(:) + (1.-eclipse(:))*tmp_fract(:) !! fract takes into account the rings shadow and the day/night alternation - - enddo - - fract(:) = fract(:)/nb_hours - - DEALLOCATE(tmp_fract) - DEALLOCATE(tmp_mu0) - - else ! instant insolation is weighted by the rings shadow - call rings(ngrid, declin, ptime, rad, 0., eclipse) - fract(:) = fract(:) * (1.-eclipse) - endif - - IF (ALLOCATED(eclipse)) DEALLOCATE(eclipse) - -end subroutine call_rings Index: trunk/LMDZ.GENERIC/libf/phygeneric/callcorrk.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/callcorrk.F90 (revision 4062) +++ (revision ) @@ -1,1350 +1,0 @@ -MODULE callcorrk_mod - -IMPLICIT NONE - -CONTAINS - - subroutine callcorrk(ngrid,nlayer,pq,nq,qsurf,zls, & - albedo,albedo_equivalent,emis,mu0,pplev,pplay,pt, & - tsurf,fract,dist_star,aerosol,muvar, & - dtlw,dtsw,fluxsurf_lw, & - fluxsurf_sw,fluxsurfabs_sw,fluxtop_lw, & - fluxabs_sw,fluxtop_dn, & - OLR_nu,OSR_nu,GSR_nu, & - int_dtaui,int_dtauv, & - tau_col,cloudfrac,totcloudfrac, & - clearsky,p_var,frac_var,firstcall,lastcall) - - use mod_phys_lmdz_para, only : is_master - use radinc_h, only: L_NSPECTV, L_NSPECTI, naerkind, banddir, corrkdir,& - L_LEVELS, L_NGAUSS, L_NLEVRAD, L_NLAYRAD, L_REFVAR - use radcommon_h, only: wrefvar, Cmk, fzeroi, fzerov, gasi, gasv, & - glat_ig, gweight, pfgasref, pgasmax, pgasmin, & - pgasref, tgasmax, tgasmin, tgasref, scalep, & - ubari, wnoi, stellarf, glat, dwnv, dwni - use watercommon_h, only: psat_water, epsi - use datafile_mod, only: datadir - use ioipsl_getin_p_mod, only: getin_p - use gases_h, only: ngasmx - use radii_mod, only : su_aer_radii,co2_reffrad,h2o_reffrad,dust_reffrad,h2so4_reffrad,back2lay_reffrad - use aerosol_mod, only : iaero_co2,iaero_h2o,iaero_dust,iaero_h2so4, & - iaero_back2lay, iaero_aurora, & - iaero_venus1,iaero_venus2,iaero_venus2p, & - iaero_venus3,iaero_venusUV - use aeropacity_mod, only: aeropacity - use aeroptproperties_mod, only: aeroptproperties - use tracer_h, only: igcm_h2o_ice, igcm_h2o_vap, igcm_co2_ice - use tracer_h, only: constants_epsi_generic - use comcstfi_mod, only: pi, mugaz, cpp - use callkeys_mod, only: varactive,diurnal,tracer,water,varfixed,satval, & - diagdtau,kastprof,strictboundcorrk,specOLR, & - CLFvarying,tplanckmin,tplanckmax,global1d, & - generic_condensation, aerovenus, nvarlayer, varspec - use optcv_mod, only: optcv - use optci_mod, only: optci - use sfluxi_mod, only: sfluxi - use sfluxv_mod, only: sfluxv - use recombin_corrk_mod, only: corrk_recombin, call_recombin - use pindex_mod, only: pindex - use generic_cloud_common_h, only: Psat_generic, epsi_generic - use generic_tracer_index_mod, only: generic_tracer_index - use planetwide_mod, only: planetwide_maxval, planetwide_minval - implicit none - -!================================================================== -! -! Purpose -! ------- -! Solve the radiative transfer using the correlated-k method for -! the gaseous absorption and the Toon et al. (1989) method for -! scatttering due to aerosols. -! -! Authors -! ------- -! Emmanuel 01/2001, Forget 09/2001 -! Robin Wordsworth (2009) -! -!================================================================== - -!----------------------------------------------------------------------- -! Declaration of the arguments (INPUT - OUTPUT) on the LMD GCM grid -! Layer #1 is the layer near the ground. -! Layer #nlayer is the layer at the top. -!----------------------------------------------------------------------- - - - ! INPUT - INTEGER,INTENT(IN) :: ngrid ! Number of atmospheric columns. - INTEGER,INTENT(IN) :: nlayer ! Number of atmospheric layers. - REAL,INTENT(IN) :: pq(ngrid,nlayer,nq) ! Tracers (kg/kg_of_air). - INTEGER,INTENT(IN) :: nq ! Number of tracers. - REAL,INTENT(IN) :: qsurf(ngrid,nq) ! Tracers on surface (kg.m-2). - REAL,INTENT(IN) :: zls ! Stellar longitude (rad). - REAL,INTENT(IN) :: albedo(ngrid,L_NSPECTV) ! Spectral Short Wavelengths Albedo. By MT2015 - REAL,INTENT(IN) :: emis(ngrid) ! Long Wave emissivity. - REAL,INTENT(IN) :: mu0(ngrid) ! Cosine of sun incident angle. - REAL,INTENT(IN) :: pplev(ngrid,nlayer+1) ! Inter-layer pressure (Pa). - REAL,INTENT(IN) :: pplay(ngrid,nlayer) ! Mid-layer pressure (Pa). - REAL,INTENT(IN) :: pt(ngrid,nlayer) ! Air temperature (K). - REAL,INTENT(IN) :: tsurf(ngrid) ! Surface temperature (K). - REAL,INTENT(IN) :: fract(ngrid) ! Fraction of day. - REAL,INTENT(IN) :: dist_star ! Distance star-planet (AU). - REAL,INTENT(IN) :: muvar(ngrid,nlayer+1) - REAL,INTENT(IN) :: cloudfrac(ngrid,nlayer) ! Fraction of clouds (%). - REAL,INTENT(IN) :: frac_var(nvarlayer,ngasmx)! Variable molar fraction. - REAL,INTENT(IN) :: p_var(nvarlayer) ! Pressure for frac_var interpolation (Pa) - logical,intent(in) :: clearsky - logical,intent(in) :: firstcall ! Signals first call to physics. - logical,intent(in) :: lastcall ! Signals last call to physics. - - ! OUTPUT - REAL,INTENT(OUT) :: aerosol(ngrid,nlayer,naerkind) ! Aerosol tau at reference wavelenght. - REAL,INTENT(OUT) :: dtlw(ngrid,nlayer) ! Heating rate (K/s) due to LW radiation. - REAL,INTENT(OUT) :: dtsw(ngrid,nlayer) ! Heating rate (K/s) due to SW radiation. - REAL,INTENT(OUT) :: fluxsurf_lw(ngrid) ! Incident LW flux to surf (W/m2). - REAL,INTENT(OUT) :: fluxsurf_sw(ngrid) ! Incident SW flux to surf (W/m2) - REAL,INTENT(OUT) :: fluxsurfabs_sw(ngrid) ! Absorbed SW flux by the surface (W/m2). By MT2015. - REAL,INTENT(OUT) :: fluxtop_lw(ngrid) ! Outgoing LW flux to space (W/m2). - REAL,INTENT(OUT) :: fluxabs_sw(ngrid) ! SW flux absorbed by the planet (W/m2). - REAL,INTENT(OUT) :: fluxtop_dn(ngrid) ! Incident top of atmosphere SW flux (W/m2). - REAL,INTENT(OUT) :: OLR_nu(ngrid,L_NSPECTI) ! Outgoing LW radiation in each band (Normalized to the band width (W/m2/cm-1). - REAL,INTENT(OUT) :: OSR_nu(ngrid,L_NSPECTV) ! Outgoing SW radiation in each band (Normalized to the band width (W/m2/cm-1). - REAL,INTENT(OUT) :: GSR_nu(ngrid,L_NSPECTV) ! Surface SW radiation in each band (Normalized to the band width (W/m2/cm-1). - REAL,INTENT(OUT) :: tau_col(ngrid) ! Diagnostic from aeropacity. - REAL,INTENT(OUT) :: albedo_equivalent(ngrid) ! Spectrally Integrated Albedo. For Diagnostic. By MT2015 - REAL,INTENT(OUT) :: totcloudfrac(ngrid) ! Column Fraction of clouds (%). - REAL,INTENT(OUT) :: int_dtaui(ngrid,nlayer,L_NSPECTI) ! VI optical thickness of layers within narrowbands for diags (). - REAL,INTENT(OUT) :: int_dtauv(ngrid,nlayer,L_NSPECTV) ! IR optical thickness of layers within narrowbands for diags (). - - - - - -! Globally varying aerosol optical properties on GCM grid ; not needed everywhere so not in radcommon_h. -! made "save" variables so they are allocated once in for all, not because -! the values need be saved from a time step to the next - REAL,SAVE,ALLOCATABLE :: QVISsQREF3d(:,:,:,:) - REAL,SAVE,ALLOCATABLE :: omegaVIS3d(:,:,:,:) - REAL,SAVE,ALLOCATABLE :: gVIS3d(:,:,:,:) -!$OMP THREADPRIVATE(QVISsQREF3d,omegaVIS3d,gVIS3d) - REAL,SAVE,ALLOCATABLE :: QIRsQREF3d(:,:,:,:) - REAL,SAVE,ALLOCATABLE :: omegaIR3d(:,:,:,:) - REAL,SAVE,ALLOCATABLE :: gIR3d(:,:,:,:) -!$OMP THREADPRIVATE(QIRsQREF3d,omegaIR3d,gIR3d) - -! REAL :: omegaREFvis3d(ngrid,nlayer,naerkind) -! REAL :: omegaREFir3d(ngrid,nlayer,naerkind) ! not sure of the point of these... - - REAL,ALLOCATABLE,SAVE :: reffrad(:,:,:) ! aerosol effective radius (m) - REAL,ALLOCATABLE,SAVE :: nueffrad(:,:,:) ! aerosol effective variance -!$OMP THREADPRIVATE(reffrad,nueffrad) - -!----------------------------------------------------------------------- -! Declaration of the variables required by correlated-k subroutines -! Numbered from top to bottom (unlike in the GCM) -!----------------------------------------------------------------------- - - REAL*8 tmid(L_LEVELS),pmid(L_LEVELS) - REAL*8 tlevrad(L_LEVELS),plevrad(L_LEVELS) - - ! Optical values for the optci/cv subroutines - REAL*8 stel(L_NSPECTV),stel_fract(L_NSPECTV) - ! NB: Arrays below are "save" to avoid reallocating them at every call - ! not because their content needs be reused from call to the next - REAL*8,allocatable,save :: dtaui(:,:,:) - REAL*8,allocatable,save :: dtauv(:,:,:) - REAL*8,allocatable,save :: cosbv(:,:,:) - REAL*8,allocatable,save :: cosbi(:,:,:) - REAL*8,allocatable,save :: wbari(:,:,:) - REAL*8,allocatable,save :: wbarv(:,:,:) -!$OMP THREADPRIVATE(dtaui,dtauv,cosbv,cosbi,wbari,wbarv) - REAL*8,allocatable,save :: tauv(:,:,:) - REAL*8,allocatable,save :: taucumv(:,:,:) - REAL*8,allocatable,save :: taucumi(:,:,:) -!$OMP THREADPRIVATE(tauv,taucumv,taucumi) - REAL*8,allocatable,save :: tauaero(:,:) -!$OMP THREADPRIVATE(tauaero) - REAL*8 nfluxtopv,nfluxtopi,nfluxtop,fluxtopvdn - REAL*8 nfluxoutv_nu(L_NSPECTV) ! Outgoing band-resolved VI flux at TOA (W/m2). - REAL*8 nfluxtopi_nu(L_NSPECTI) ! Net band-resolved IR flux at TOA (W/m2). - REAL*8 fluxupi_nu(L_NLAYRAD,L_NSPECTI) ! For 1D diagnostic. - REAL*8 fmneti(L_NLAYRAD),fmnetv(L_NLAYRAD) - REAL*8 fluxupv(L_NLAYRAD),fluxupi(L_NLAYRAD) - REAL*8 fluxdnv(L_NLAYRAD),fluxdni(L_NLAYRAD) - REAL*8 albi,acosz - REAL*8 albv(L_NSPECTV) ! Spectral Visible Albedo. - - INTEGER ig,l,k,nw,iaer,iq - - real*8,allocatable,save :: taugsurf(:,:) - real*8,allocatable,save :: taugsurfi(:,:) -!$OMP THREADPRIVATE(taugsurf,taugsurfi) - real*8 qvar(L_LEVELS) ! Mixing ratio of variable component (mol/mol). index 1 is the top of the atmosphere, index L_LEVELS is the bottom - - ! Local aerosol optical properties for each column on RADIATIVE grid. - real*8,save,allocatable :: QXVAER(:,:,:) ! Extinction coeff (QVISsQREF*QREFvis) - real*8,save,allocatable :: QSVAER(:,:,:) - real*8,save,allocatable :: GVAER(:,:,:) - real*8,save,allocatable :: QXIAER(:,:,:) ! Extinction coeff (QIRsQREF*QREFir) - real*8,save,allocatable :: QSIAER(:,:,:) - real*8,save,allocatable :: GIAER(:,:,:) -!$OMP THREADPRIVATE(QXVAER,QSVAER,GVAER,QXIAER,QSIAER,GIAER) - real, dimension(:,:,:), save, allocatable :: QREFvis3d - real, dimension(:,:,:), save, allocatable :: QREFir3d -!$OMP THREADPRIVATE(QREFvis3d,QREFir3d) - - - ! Miscellaneous : - real*8 temp,temp1,temp2,pweight - character(len=10) :: tmp1 - character(len=10) :: tmp2 - character(len=100) :: message - character(len=10),parameter :: subname="callcorrk" - - ! For fixed water vapour profiles. - integer i_var - real RH - real*8 pq_temp(nlayer) -! real(KIND=r8) :: pq_temp(nlayer) ! better F90 way.. DOESNT PORT TO F77!!! - real psat,qsat - - logical OLRz - real*8 NFLUXGNDV_nu(L_NSPECTV) - - ! Included by RW for runaway greenhouse 1D study. - real vtmp(nlayer) - REAL*8 muvarrad(L_LEVELS) - - ! Included by MT for albedo calculations. - REAL*8 albedo_temp(L_NSPECTV) ! For equivalent albedo calculation. - REAL*8 surface_stellar_flux ! Stellar flux reaching the surface. Useful for equivalent albedo calculation. - - ! local variable - integer ok ! status (returned by NetCDF functions) - - integer igcm_generic_vap, igcm_generic_ice! index of the vap and ice of generic_tracer - logical call_ice_vap_generic ! to call only one time the ice/vap pair of a tracer - real, save :: metallicity ! metallicity of planet --- is not used here, but necessary to call function Psat_generic -!$OMP THREADPRIVATE(metallicity) - REAL, SAVE :: qvap_deep ! deep mixing ratio of water vapor when simulating bottom less planets -!$OMP THREADPRIVATE(qvap_deep) - - REAL :: maxvalue,minvalue - - real :: frac_vari(L_LEVELS) - real :: fracvari(ngasmx,L_LEVELS) - -!=============================================================== -! I.a Initialization on first call -!=============================================================== - - - if(firstcall) then - - ! test on allocated necessary because of CLFvarying (two calls to callcorrk in physiq) - if(.not.allocated(QVISsQREF3d)) then - allocate(QVISsQREF3d(ngrid,nlayer,L_NSPECTV,naerkind)) - endif - if(.not.allocated(omegaVIS3d)) then - allocate(omegaVIS3d(ngrid,nlayer,L_NSPECTV,naerkind)) - endif - if(.not.allocated(gVIS3d)) then - allocate(gVIS3d(ngrid,nlayer,L_NSPECTV,naerkind)) - endif - if (.not.allocated(QIRsQREF3d)) then - allocate(QIRsQREF3d(ngrid,nlayer,L_NSPECTI,naerkind)) - endif - if (.not.allocated(omegaIR3d)) then - allocate(omegaIR3d(ngrid,nlayer,L_NSPECTI,naerkind)) - endif - if (.not.allocated(gIR3d)) then - allocate(gIR3d(ngrid,nlayer,L_NSPECTI,naerkind)) - endif - if (.not.allocated(tauaero)) then - allocate(tauaero(L_LEVELS,naerkind)) - endif - - if(.not.allocated(QXVAER)) then - allocate(QXVAER(L_LEVELS,L_NSPECTV,naerkind), stat=ok) - if (ok /= 0) then - write(*,*) "memory allocation failed for QXVAER!" - call abort_physic(subname,'allocation failure for QXVAER',1) - endif - endif - if(.not.allocated(QSVAER)) then - allocate(QSVAER(L_LEVELS,L_NSPECTV,naerkind), stat=ok) - if (ok /= 0) then - write(*,*) "memory allocation failed for QSVAER!" - call abort_physic(subname,'allocation failure for QSVAER',1) - endif - endif - if(.not.allocated(GVAER)) then - allocate(GVAER(L_LEVELS,L_NSPECTV,naerkind), stat=ok) - if (ok /= 0) then - write(*,*) "memory allocation failed for GVAER!" - call abort_physic(subname,'allocation failure for GVAER',1) - endif - endif - if(.not.allocated(QXIAER)) then - allocate(QXIAER(L_LEVELS,L_NSPECTI,naerkind), stat=ok) - if (ok /= 0) then - write(*,*) "memory allocation failed for QXIAER!" - call abort_physic(subname,'allocation failure for QXIAER',1) - endif - endif - if(.not.allocated(QSIAER)) then - allocate(QSIAER(L_LEVELS,L_NSPECTI,naerkind), stat=ok) - if (ok /= 0) then - write(*,*) "memory allocation failed for QSIAER!" - call abort_physic(subname,'allocation failure for QSIAER',1) - endif - endif - if(.not.allocated(GIAER)) then - allocate(GIAER(L_LEVELS,L_NSPECTI,naerkind), stat=ok) - if (ok /= 0) then - write(*,*) "memory allocation failed for GIAER!" - call abort_physic(subname,'allocation failure for GIAER',1) - endif - endif - - !!! ALLOCATED instances are necessary because of CLFvarying (strategy to call callcorrk twice in physiq...) - IF(.not.ALLOCATED(QREFvis3d))THEN - ALLOCATE(QREFvis3d(ngrid,nlayer,naerkind), stat=ok) - IF (ok/=0) THEN - write(*,*) "memory allocation failed for QREFvis3d!" - call abort_physic(subname,'allocation failure for QREFvis3d',1) - ENDIF - ENDIF - IF(.not.ALLOCATED(QREFir3d)) THEN - ALLOCATE(QREFir3d(ngrid,nlayer,naerkind), stat=ok) - IF (ok/=0) THEN - write(*,*) "memory allocation failed for QREFir3d!" - call abort_physic(subname,'allocation failure for QREFir3d',1) - ENDIF - ENDIF - ! Effective radius and variance of the aerosols - IF(.not.ALLOCATED(reffrad)) THEN - allocate(reffrad(ngrid,nlayer,naerkind), stat=ok) - IF (ok/=0) THEN - write(*,*) "memory allocation failed for reffrad!" - call abort_physic(subname,'allocation failure for reffrad',1) - ENDIF - ENDIF - IF(.not.ALLOCATED(nueffrad)) THEN - allocate(nueffrad(ngrid,nlayer,naerkind), stat=ok) - IF (ok/=0) THEN - write(*,*) "memory allocation failed for nueffrad!" - call abort_physic(subname,'allocation failure for nueffrad',1) - ENDIF - ENDIF - -#ifndef MESOSCALE - if (is_master) call system('rm -f surf_vals_long.out') -#endif - - call su_aer_radii(ngrid,nlayer,reffrad,nueffrad) - - -!-------------------------------------------------- -! Set up correlated k -!-------------------------------------------------- - - !this block is now done at firstcall of physiq_mod - ! print*, "callcorrk: Correlated-k data base folder:",trim(datadir) - ! call getin_p("corrkdir",corrkdir) - ! print*, "corrkdir = ",corrkdir - ! write( tmp1, '(i3)' ) L_NSPECTI - ! write( tmp2, '(i3)' ) L_NSPECTV - ! banddir=trim(adjustl(tmp1))//'x'//trim(adjustl(tmp2)) - ! banddir=trim(adjustl(corrkdir))//'/'//trim(adjustl(banddir)) - - ! call setspi ! Basic infrared properties. - ! call setspv ! Basic visible properties. - ! call sugas_corrk ! Set up gaseous absorption properties. - ! call suaer_corrk ! Set up aerosol optical properties. - - - ! now that L_NGAUSS has been initialized (by sugas_corrk) - ! allocate related arrays - if(.not.allocated(dtaui)) then - ALLOCATE(dtaui(L_NLAYRAD,L_NSPECTI,L_NGAUSS), stat=ok) - if (ok/=0) then - write(*,*) "memory allocation failed for dtaui!" - call abort_physic(subname,'allocation failure for dtaui',1) - endif - endif - if(.not.allocated(dtauv)) then - ALLOCATE(dtauv(L_NLAYRAD,L_NSPECTV,L_NGAUSS), stat=ok) - if (ok/=0) then - write(*,*) "memory allocation failed for dtauv!" - call abort_physic(subname,'allocation failure for dtauv',1) - endif - endif - if(.not.allocated(cosbv)) then - ALLOCATE(cosbv(L_NLAYRAD,L_NSPECTV,L_NGAUSS), stat=ok) - if (ok/=0) then - write(*,*) "memory allocation failed for cosbv!" - call abort_physic(subname,'allocation failure for cobsv',1) - endif - endif - if(.not.allocated(cosbi)) then - ALLOCATE(cosbi(L_NLAYRAD,L_NSPECTI,L_NGAUSS), stat=ok) - if (ok/=0) then - write(*,*) "memory allocation failed for cosbi!" - call abort_physic(subname,'allocation failure for cobsi',1) - endif - endif - if(.not.allocated(wbari)) then - ALLOCATE(wbari(L_NLAYRAD,L_NSPECTI,L_NGAUSS), stat=ok) - if (ok/=0) then - write(*,*) "memory allocation failed for wbari!" - call abort_physic(subname,'allocation failure for wbari',1) - endif - endif - if(.not.allocated(wbarv)) then - ALLOCATE(wbarv(L_NLAYRAD,L_NSPECTV,L_NGAUSS), stat=ok) - if (ok/=0) then - write(*,*) "memory allocation failed for wbarv!" - call abort_physic(subname,'allocation failure for wbarv',1) - endif - endif - if(.not.allocated(tauv)) then - ALLOCATE(tauv(L_NLEVRAD,L_NSPECTV,L_NGAUSS), stat=ok) - if (ok/=0) then - write(*,*) "memory allocation failed for tauv!" - call abort_physic(subname,'allocation failure for tauv',1) - endif - endif - if(.not.allocated(taucumv)) then - ALLOCATE(taucumv(L_LEVELS,L_NSPECTV,L_NGAUSS), stat=ok) - if (ok/=0) then - write(*,*) "memory allocation failed for taucumv!" - call abort_physic(subname,'allocation failure for taucumv',1) - endif - endif - if(.not.allocated(taucumi)) then - ALLOCATE(taucumi(L_LEVELS,L_NSPECTI,L_NGAUSS), stat=ok) - if (ok/=0) then - write(*,*) "memory allocation failed for taucumi!" - call abort_physic(subname,'allocation failure for taucumi',1) - endif - endif - if(.not.allocated(taugsurf)) then - ALLOCATE(taugsurf(L_NSPECTV,L_NGAUSS-1), stat=ok) - if (ok/=0) then - write(*,*) "memory allocation failed for taugsurf!" - call abort_physic(subname,'allocation failure for taugsurf',1) - endif - endif - if(.not.allocated(taugsurfi)) then - ALLOCATE(taugsurfi(L_NSPECTI,L_NGAUSS-1), stat=ok) - if (ok/=0) then - write(*,*) "memory allocation failed for taugsurfi!" - call abort_physic(subname,'allocation failure for taugsurfi',1) - endif - endif - - if((igcm_h2o_vap.eq.0) .and. varactive .and. water)then - message='varactive in callcorrk but no h2o_vap tracer.' - call abort_physic(subname,message,1) - endif - - if(varfixed .and. generic_condensation .and. .not. water)then - write(*,*) "Deep generic tracer vapor mixing ratio ? (no effect if negative) " - qvap_deep=-1. ! default value - call getin_p("qvap_deep",qvap_deep) - write(*,*) " qvap_deep = ",qvap_deep - - metallicity=0.0 ! default value --- is not used here but necessary to call function Psat_generic - call getin_p("metallicity",metallicity) ! --- is not used here but necessary to call function Psat_generic - endif - - end if ! of if (firstcall) - -!======================================================================= -! I.b Initialization on every call -!======================================================================= - - qxvaer(:,:,:)=0.0 - qsvaer(:,:,:)=0.0 - gvaer(:,:,:) =0.0 - - qxiaer(:,:,:)=0.0 - qsiaer(:,:,:)=0.0 - giaer(:,:,:) =0.0 - - OLR_nu(:,:) = 0. - OSR_nu(:,:) = 0. - GSR_nu(:,:) = 0. - -!-------------------------------------------------- -! Effective radius and variance of the aerosols -!-------------------------------------------------- - - do iaer=1,naerkind - - if ((iaer.eq.iaero_co2).and.tracer.and.(igcm_co2_ice.gt.0)) then ! Treat condensed co2 particles. - call co2_reffrad(ngrid,nlayer,nq,pq,reffrad(1,1,iaero_co2)) - - call planetwide_maxval(reffrad(:,:,iaero_co2),maxvalue) - call planetwide_minval(reffrad(:,:,iaero_co2),minvalue) - if (is_master) then - print*,'Max. CO2 ice particle size = ',maxvalue/1.e-6,' um' - print*,'Min. CO2 ice particle size = ',minvalue/1.e-6,' um' - end if - end if - - if ((iaer.eq.iaero_h2o).and.water) then ! Treat condensed water particles. To be generalized for other aerosols ... - call h2o_reffrad(ngrid,nlayer,pq(1,1,igcm_h2o_ice),pt, & - reffrad(1,1,iaero_h2o),nueffrad(1,1,iaero_h2o)) - - call planetwide_maxval(reffrad(:,:,iaero_h2o),maxvalue) - call planetwide_minval(reffrad(:,:,iaero_h2o),minvalue) - if (is_master) then - print*,'Max. H2O cloud particle size = ',maxvalue/1.e-6,' um' - print*,'Min. H2O cloud particle size = ',minvalue/1.e-6,' um' - end if - -! Currently the variance is constant everywhere (see h2o_reffrad), -! so no need to compute and print min/max -! call planetwide_maxval(nueffrad(:,:,iaero_h2o),maxvalue) -! call planetwide_minval(nueffrad(:,:,iaero_h2o),minvalue) -! if (is_master) then -! print*,'Max. H2O cloud particle variance = ',maxvalue -! print*,'Min. H2O cloud particle variance = ',minvalue -! end if - endif - - if(iaer.eq.iaero_dust)then - call dust_reffrad(ngrid,nlayer,reffrad(1,1,iaero_dust)) - if (is_master) then - print*,'Dust particle size = ',reffrad(1,1,iaer)/1.e-6,' um' - end if - endif - - if(iaer.eq.iaero_h2so4)then - call h2so4_reffrad(ngrid,nlayer,reffrad(1,1,iaero_h2so4)) - if (is_master) then - print*,'H2SO4 particle size =',reffrad(1,1,iaer)/1.e-6,' um' - end if - endif - - if(iaer.eq.iaero_back2lay)then - call back2lay_reffrad(ngrid,reffrad(1,1,iaero_back2lay),nlayer,pplev) - endif - - ! For n-layer aerosol size set once for all at firstcall in su_aer_radii - -! if(iaer.eq.iaero_aurora)then -! call aurora_reffrad(ngrid,nlayer,reffrad(1,1,iaero_aurora)) -! endif - - end do !iaer=1,naerkind. - - - ! How much light do we get ? - do nw=1,L_NSPECTV - stel(nw)=stellarf(nw)/(dist_star**2) - end do - - ! Get 3D aerosol optical properties. - call aeroptproperties(ngrid,nlayer,reffrad,nueffrad, & - QVISsQREF3d,omegaVIS3d,gVIS3d, & - QIRsQREF3d,omegaIR3d,gIR3d, & - QREFvis3d,QREFir3d) - - ! Get aerosol optical depths. - call aeropacity(ngrid,nlayer,nq,pplay,pplev,pt,pq,zls,aerosol, & - reffrad,nueffrad,QREFvis3d,QREFir3d, & - tau_col,cloudfrac,totcloudfrac,clearsky) - -!----------------------------------------------------------------------- - do ig=1,ngrid ! Starting Big Loop over every GCM column -!----------------------------------------------------------------------- - - -!======================================================================= -! II. Transformation of the GCM variables -!======================================================================= - - -!----------------------------------------------------------------------- -! Aerosol optical properties Qext, Qscat and g. -! The transformation in the vertical is the same as for temperature. -!----------------------------------------------------------------------- - - - do iaer=1,naerkind - ! Shortwave. - do nw=1,L_NSPECTV - - do l=1,nlayer - - temp1=QVISsQREF3d(ig,nlayer+1-l,nw,iaer) & - *QREFvis3d(ig,nlayer+1-l,iaer) - - temp2=QVISsQREF3d(ig,max(nlayer-l,1),nw,iaer) & - *QREFvis3d(ig,max(nlayer-l,1),iaer) - - qxvaer(2*l,nw,iaer) = temp1 - qxvaer(2*l+1,nw,iaer)=(temp1+temp2)/2 - - temp1=temp1*omegavis3d(ig,nlayer+1-l,nw,iaer) - temp2=temp2*omegavis3d(ig,max(nlayer-l,1),nw,iaer) - - qsvaer(2*l,nw,iaer) = temp1 - qsvaer(2*l+1,nw,iaer)=(temp1+temp2)/2 - - temp1=gvis3d(ig,nlayer+1-l,nw,iaer) - temp2=gvis3d(ig,max(nlayer-l,1),nw,iaer) - - gvaer(2*l,nw,iaer) = temp1 - gvaer(2*l+1,nw,iaer)=(temp1+temp2)/2 - - end do ! nlayer - - qxvaer(1,nw,iaer)=qxvaer(2,nw,iaer) - qxvaer(2*nlayer+1,nw,iaer)=0. - - qsvaer(1,nw,iaer)=qsvaer(2,nw,iaer) - qsvaer(2*nlayer+1,nw,iaer)=0. - - gvaer(1,nw,iaer)=gvaer(2,nw,iaer) - gvaer(2*nlayer+1,nw,iaer)=0. - - end do ! L_NSPECTV - - do nw=1,L_NSPECTI - ! Longwave - do l=1,nlayer - - temp1=QIRsQREF3d(ig,nlayer+1-l,nw,iaer) & - *QREFir3d(ig,nlayer+1-l,iaer) - - temp2=QIRsQREF3d(ig,max(nlayer-l,1),nw,iaer) & - *QREFir3d(ig,max(nlayer-l,1),iaer) - - qxiaer(2*l,nw,iaer) = temp1 - qxiaer(2*l+1,nw,iaer)=(temp1+temp2)/2 - - temp1=temp1*omegair3d(ig,nlayer+1-l,nw,iaer) - temp2=temp2*omegair3d(ig,max(nlayer-l,1),nw,iaer) - - qsiaer(2*l,nw,iaer) = temp1 - qsiaer(2*l+1,nw,iaer)=(temp1+temp2)/2 - - temp1=gir3d(ig,nlayer+1-l,nw,iaer) - temp2=gir3d(ig,max(nlayer-l,1),nw,iaer) - - giaer(2*l,nw,iaer) = temp1 - giaer(2*l+1,nw,iaer)=(temp1+temp2)/2 - - end do ! nlayer - - qxiaer(1,nw,iaer)=qxiaer(2,nw,iaer) - qxiaer(2*nlayer+1,nw,iaer)=0. - - qsiaer(1,nw,iaer)=qsiaer(2,nw,iaer) - qsiaer(2*nlayer+1,nw,iaer)=0. - - giaer(1,nw,iaer)=giaer(2,nw,iaer) - giaer(2*nlayer+1,nw,iaer)=0. - - end do ! L_NSPECTI - - end do ! naerkind - - ! Test / Correct for freaky s. s. albedo values. - do iaer=1,naerkind - do k=1,L_LEVELS - - do nw=1,L_NSPECTV - if(qsvaer(k,nw,iaer).gt.1.05*qxvaer(k,nw,iaer))then - message='Serious problems with qsvaer values' - call abort_physic(subname,message,1) - endif - if(qsvaer(k,nw,iaer).gt.qxvaer(k,nw,iaer))then - qsvaer(k,nw,iaer)=qxvaer(k,nw,iaer) - endif - end do - - do nw=1,L_NSPECTI - if(qsiaer(k,nw,iaer).gt.1.05*qxiaer(k,nw,iaer))then - message='Serious problems with qsvaer values' - call abort_physic(subname,message,1) - endif - if(qsiaer(k,nw,iaer).gt.qxiaer(k,nw,iaer))then - qsiaer(k,nw,iaer)=qxiaer(k,nw,iaer) - endif - end do - - end do ! L_LEVELS - end do ! naerkind - -!----------------------------------------------------------------------- -! Aerosol optical depths -!----------------------------------------------------------------------- - - do iaer=1,naerkind ! a bug was here - do k=0,nlayer-1 - - pweight=(pplay(ig,L_NLAYRAD-k)-pplev(ig,L_NLAYRAD-k+1))/ & - (pplev(ig,L_NLAYRAD-k)-pplev(ig,L_NLAYRAD-k+1)) - ! As 'aerosol' is at reference (visible) wavelenght we scale it as - ! it will be multplied by qxi/v in optci/v - temp=aerosol(ig,L_NLAYRAD-k,iaer)/QREFvis3d(ig,L_NLAYRAD-k,iaer) - tauaero(2*k+2,iaer)=max(temp*pweight,0.d0) - tauaero(2*k+3,iaer)=max(temp-tauaero(2*k+2,iaer),0.d0) - - end do - ! boundary conditions - tauaero(1,iaer) = tauaero(2,iaer) - !tauaero(1,iaer) = 0. - !JL18 at time of testing, the two above conditions gave the same results bit for bit. - - end do ! naerkind - - ! Albedo and Emissivity. - albi=1-emis(ig) ! Long Wave. - DO nw=1,L_NSPECTV ! Short Wave loop. - albv(nw)=albedo(ig,nw) - ENDDO - - acosz=mu0(ig) ! Cosine of sun incident angle : 3D simulations or local 1D simulations using latitude. - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!! Note by JL13 : In the following, some indices were changed in the interpolations, -!!! so that the model results are less dependent on the number of layers ! -!!! -!!! --- The older versions are commented with the comment !JL13index --- -!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - !----------------------------------------------------------------------- - ! Water vapour (to be generalised for other gases eventually ...) - !----------------------------------------------------------------------- - - if (water) then - if(varactive)then - - i_var=igcm_h2o_vap - do l=1,nlayer - qvar(2*l) = pq(ig,nlayer+1-l,i_var) - qvar(2*l+1) = pq(ig,nlayer+1-l,i_var) - !JL13index qvar(2*l+1) = (pq(ig,nlayer+1-l,i_var)+pq(ig,max(nlayer-l,1),i_var))/2 - !JL13index Average approximation as for temperature... - end do - qvar(1)=qvar(2) - - elseif(varfixed)then - - do l=1,nlayer ! Here we will assign fixed water vapour profiles globally. - RH = satval * ((pplay(ig,l)/pplev(ig,1) - 0.02) / 0.98) - if(RH.lt.0.0) RH=0.0 - - call Psat_water(pt(ig,l),pplay(ig,l),psat,qsat) - - !pq_temp(l) = qsat ! fully saturated everywhere - pq_temp(l) = RH * qsat ! ~realistic profile (e.g. 80% saturation at ground) - end do - - do l=1,nlayer - qvar(2*l) = pq_temp(nlayer+1-l) - qvar(2*l+1) = (pq_temp(nlayer+1-l)+pq_temp(max(nlayer-l,1)))/2 - end do - - qvar(1)=qvar(2) - - ! Lowest layer of atmosphere - RH = satval * (1 - 0.02) / 0.98 - if(RH.lt.0.0) RH=0.0 - - qvar(2*nlayer+1)= RH * qsat ! ~realistic profile (e.g. 80% saturation at ground) - - else - do k=1,L_LEVELS - qvar(k) = 1.0D-7 - end do - end if ! varactive/varfixed - - endif ! if (water) - - !----------------------------------------------------------------------- - ! GCS (Generic Condensable Specie) Vapor - ! If you have GCS tracers and they are : variable & radiatively active - ! - ! NC22 - !----------------------------------------------------------------------- - - if (generic_condensation .and. .not. water ) then - - ! For now, only one GCS tracer can be both variable and radiatively active - ! If you set two GCS tracers, that are variable and radiatively active, - ! the last one in tracer.def will be chosen as the one that will be vadiatively active - - do iq=1,nq - - call generic_tracer_index(nq,iq,igcm_generic_vap,igcm_generic_ice,call_ice_vap_generic) - - if (call_ice_vap_generic) then ! to call only one time the ice/vap pair of a tracer - - if(varactive)then - - i_var=igcm_generic_vap - do l=1,nlayer - qvar(2*l) = pq(ig,nlayer+1-l,i_var) - qvar(2*l+1) = pq(ig,nlayer+1-l,i_var) - !JL13index qvar(2*l+1) = (pq(ig,nlayer+1-l,i_var)+pq(ig,max(nlayer-l,1),i_var))/2 - !JL13index ! Average approximation as for temperature... - end do - qvar(1)=qvar(2) - - elseif(varfixed .and. (qvap_deep .ge. 0))then - - do l=1,nlayer ! Here we will assign fixed water vapour profiles globally. - - call Psat_generic(pt(ig,l),pplay(ig,l),metallicity,psat,qsat) - - if (qsat .lt. qvap_deep) then - pq_temp(l) = qsat ! fully saturated everywhere - else - pq_temp(l) = qvap_deep - end if - - end do - - do l=1,nlayer - qvar(2*l) = pq_temp(nlayer+1-l) - qvar(2*l+1) = (pq_temp(nlayer+1-l)+pq_temp(max(nlayer-l,1)))/2 - end do - - qvar(1)=qvar(2) - - else - do k=1,L_LEVELS - qvar(k) = 1.0D-7 - end do - end if ! varactive/varfixed - - endif - - end do ! do iq=1,nq loop on tracers - - end if ! if (generic_condensation .and. .not. water ) - - !----------------------------------------------------------------------- - ! No Water vapor and No GCS (Generic Condensable Specie) vapor - !----------------------------------------------------------------------- - - if (.not. generic_condensation .and. .not. water ) then - do k=1,L_LEVELS - qvar(k) = 1.0D-7 - end do - end if ! if (.not. generic_condensation .and. .not. water ) - - - if(.not.kastprof)then - ! IMPORTANT: Now convert from kg/kg to mol/mol. - do k=1,L_LEVELS - if (water) then - qvar(k) = qvar(k)/(epsi+qvar(k)*(1.-epsi)) - endif - if (generic_condensation .and. .not. water) then - do iq=1,nq - call generic_tracer_index(nq,iq,igcm_generic_vap,igcm_generic_ice,call_ice_vap_generic) - if (call_ice_vap_generic) then ! to call only one time the ice/vap pair of a tracer - - epsi_generic=constants_epsi_generic(iq) - - qvar(k) = qvar(k)/(epsi_generic+qvar(k)*(1.-epsi_generic)) - - endif - end do ! do iq=1,nq loop on tracers - endif - end do - end if - -!----------------------------------------------------------------------- -! kcm mode only ! -!----------------------------------------------------------------------- - - if(kastprof)then - - if(.not.global1d)then ! garde-fou/safeguard added by MT (to be removed in the future) - message='You have to fix mu0, the cosinus of the solar angle' - call abort_physic(subname,message,1) - endif - - ! Initial values equivalent to mugaz. - DO l=1,nlayer - muvarrad(2*l) = mugaz - muvarrad(2*l+1) = mugaz - END DO - - if(ngasmx.gt.1)then - - DO l=1,nlayer - muvarrad(2*l) = muvar(ig,nlayer+2-l) - muvarrad(2*l+1) = (muvar(ig,nlayer+2-l) + & - muvar(ig,max(nlayer+1-l,1)))/2 - END DO - - muvarrad(1) = muvarrad(2) - muvarrad(2*nlayer+1) = muvar(ig,1) - - print*,'Recalculating qvar with VARIABLE epsi for kastprof' - print*,'Assumes that the variable gas is H2O!!!' - print*,'Assumes that there is only one tracer' - - !i_var=igcm_h2o_vap - i_var=1 - - if(nq.gt.1)then - message='Need 1 tracer only to run kcm1d.e' - call abort_physic(subname,message,1) - endif - - do l=1,nlayer - vtmp(l)=pq(ig,l,i_var)/(epsi+pq(ig,l,i_var)*(1.-epsi)) - !vtmp(l)=pq(ig,l,i_var)*muvar(ig,l+1)/mH2O !JL to be changed - end do - - do l=1,nlayer - qvar(2*l) = vtmp(nlayer+1-l) - qvar(2*l+1) = vtmp(nlayer+1-l) -! qvar(2*l+1) = ( vtmp(nlayer+1-l) + vtmp(max(nlayer-l,1)) )/2 - end do - qvar(1)=qvar(2) - - write(*,*)trim(subname),' :Warning: reducing qvar in callcorrk.' - write(*,*)trim(subname),' :Temperature profile no longer consistent ', & - 'with saturated H2O. qsat=',satval - - do k=1,L_LEVELS - qvar(k) = qvar(k)*satval - end do - - endif - else ! if kastprof - DO l=1,nlayer - muvarrad(2*l) = muvar(ig,nlayer+2-l) - muvarrad(2*l+1) = (muvar(ig,nlayer+2-l)+muvar(ig,max(nlayer+1-l,1)))/2 - END DO - - muvarrad(1) = muvarrad(2) - muvarrad(2*nlayer+1)=muvar(ig,1) - endif ! if kastprof - - ! Keep values inside limits for which we have radiative transfer coefficients !!! - if(L_REFVAR.gt.1)then ! (there was a bug here) - do k=1,L_LEVELS - if(qvar(k).lt.wrefvar(1))then - qvar(k)=wrefvar(1)+1.0e-8 - elseif(qvar(k).gt.wrefvar(L_REFVAR))then - qvar(k)=wrefvar(L_REFVAR)-1.0e-8 - endif - end do - endif - -!----------------------------------------------------------------------- -! Pressure and temperature -!----------------------------------------------------------------------- - - DO l=1,nlayer - plevrad(2*l) = pplay(ig,nlayer+1-l)/scalep - plevrad(2*l+1) = pplev(ig,nlayer+1-l)/scalep - tlevrad(2*l) = pt(ig,nlayer+1-l) - tlevrad(2*l+1) = (pt(ig,nlayer+1-l)+pt(ig,max(nlayer-l,1)))/2 - END DO - - plevrad(1) = 0. -! plevrad(2) = 0. !! JL18 enabling this line puts the radiative top at p=0 which was the idea before, but does not seem to perform best after all. - if (aerovenus) then -!! GG19 modified below after SL routines - plevrad(2) = 0. - endif - - tlevrad(1) = tlevrad(2) - tlevrad(2*nlayer+1)=tsurf(ig) - - pmid(1) = pplay(ig,nlayer)/scalep - if (aerovenus) then -!! GG19 modified below after SL routines - pmid(1) = max(pgasmin,0.0001*plevrad(3)) - endif - pmid(2) = pmid(1) - - tmid(1) = tlevrad(2) - tmid(2) = tmid(1) - - DO l=1,L_NLAYRAD-1 - tmid(2*l+1) = tlevrad(2*l+1) - tmid(2*l+2) = tlevrad(2*l+1) - pmid(2*l+1) = plevrad(2*l+1) - pmid(2*l+2) = plevrad(2*l+1) - END DO - pmid(L_LEVELS) = plevrad(L_LEVELS) - tmid(L_LEVELS) = tlevrad(L_LEVELS) - -!!Alternative interpolation: -! pmid(3) = pmid(1) -! pmid(4) = pmid(1) -! tmid(3) = tmid(1) -! tmid(4) = tmid(1) -! DO l=2,L_NLAYRAD-1 -! tmid(2*l+1) = tlevrad(2*l) -! tmid(2*l+2) = tlevrad(2*l) -! pmid(2*l+1) = plevrad(2*l) -! pmid(2*l+2) = plevrad(2*l) -! END DO -! pmid(L_LEVELS) = plevrad(L_LEVELS-1) -! tmid(L_LEVELS) = tlevrad(L_LEVELS-1) - - ! Test for out-of-bounds pressure. - if(plevrad(3).lt.pgasmin)then - print*,'Minimum pressure is outside the radiative' - print*,'transfer kmatrix bounds, exiting.' - message="Minimum pressure outside of kmatrix bounds" - call abort_physic(subname,message,1) - elseif(plevrad(L_LEVELS).gt.pgasmax)then - print*,'Maximum pressure is outside the radiative' - print*,'transfer kmatrix bounds, exiting.' - message="Minimum pressure outside of kmatrix bounds" - call abort_physic(subname,message,1) - endif - - ! Test for out-of-bounds temperature. - ! -- JVO 20 : Also add a sanity test checking that tlevrad is - ! within Planck function temperature boundaries, - ! which would cause gfluxi/sfluxi to crash. - do k=1,L_LEVELS - - if(tlevrad(k).lt.tgasmin)then - print*,'Minimum temperature is outside the radiative' - print*,'transfer kmatrix bounds' - print*,"k=",k," tlevrad(k)=",tlevrad(k) - print*,"tgasmin=",tgasmin - if (strictboundcorrk) then - message="Minimum temperature outside of kmatrix bounds" - call abort_physic(subname,message,1) - else - print*,'***********************************************' - print*,'we allow model to continue with tlevradtgasmax' - print*,' ... we assume we know what you are doing ... ' - print*,' ... but do not let this happen too often ... ' - print*,'***********************************************' - !tlevrad(k)=tgasmax ! Used in the source function ! - endif - endif - - if (tlevrad(k).lt.tplanckmin) then - print*,'Minimum temperature is outside the boundaries for' - print*,'Planck function integration set in callphys.def, aborting.' - print*,"k=",k," tlevrad(k)=",tlevrad(k) - print*,"tplanckmin=",tplanckmin - message="Minimum temperature outside Planck function bounds - Change tplanckmin in callphys.def" - call abort_physic(subname,message,1) - else if (tlevrad(k).gt.tplanckmax) then - print*,'Maximum temperature is outside the boundaries for' - print*,'Planck function integration set in callphys.def, aborting.' - print*,"k=",k," tlevrad(k)=",tlevrad(k) - print*,"tplanckmax=",tplanckmax - message="Maximum temperature outside Planck function bounds - Change tplanckmax in callphys.def" - call abort_physic(subname,message,1) - endif - - enddo - - do k=1,L_NLAYRAD+1 - if(tmid(k).lt.tgasmin)then - print*,'Minimum temperature is outside the radiative' - print*,'transfer kmatrix bounds, exiting.' - print*,"k=",k," tmid(k)=",tmid(k) - print*,"tgasmin=",tgasmin - if (strictboundcorrk) then - message="Minimum temperature outside of kmatrix bounds" - call abort_physic(subname,message,1) - else - print*,'***********************************************' - print*,'we allow model to continue but with tmid=tgasmin' - print*,' ... we assume we know what you are doing ... ' - print*,' ... but do not let this happen too often ... ' - print*,'***********************************************' - tmid(k)=tgasmin - endif - elseif(tmid(k).gt.tgasmax)then - print*,'Maximum temperature is outside the radiative' - print*,'transfer kmatrix bounds, exiting.' - print*,"k=",k," tmid(k)=",tmid(k) - print*,"tgasmax=",tgasmax - if (strictboundcorrk) then - message="Maximum temperature outside of kmatrix bounds" - call abort_physic(subname,message,1) - else - print*,'***********************************************' - print*,'we allow model to continue but with tmid=tgasmax' - print*,' ... we assume we know what you are doing ... ' - print*,' ... but do not let this happen too often ... ' - print*,'***********************************************' - tmid(k)=tgasmax - endif - endif - enddo - -!----------------------------------------------------------------------- -! Variation of molar fraction for CIAs -!----------------------------------------------------------------------- - - if (varspec) then - do k=1,ngasmx - call pindex(p_var,frac_var(:,k),plevrad(:),nvarlayer,L_LEVELS,frac_vari) - fracvari(k,:) = frac_vari - enddo - endif - -!======================================================================= -! III. Calling the main radiative transfer subroutines -!======================================================================= - -! ---------------------------------------------------------------- -! Recombine reference corrk tables if needed - Added by JVO, 2020. - if (corrk_recombin) then - call call_recombin(ig,nlayer,pq(ig,:,:),pplay(ig,:),pt(ig,:),qvar(:),tmid(:),pmid(:)) - endif -! ---------------------------------------------------------------- - - Cmk= 0.01 * 1.0 / (glat(ig) * mugaz * 1.672621e-27) ! q_main=1.0 assumed. - glat_ig=glat(ig) - -!----------------------------------------------------------------------- -! Short Wave Part -!----------------------------------------------------------------------- - - if((fract(ig) .ge. 1.0e-4).or.(global1d)) then ! Only during daylight. - if((ngrid.eq.1).and.(global1d))then - do nw=1,L_NSPECTV - stel_fract(nw)= stel(nw)* 0.25 / acosz ! globally averaged = divide by 4, and we correct for solar zenith angle - end do - else - do nw=1,L_NSPECTV - stel_fract(nw)= stel(nw) * fract(ig) - end do - endif - - call optcv(dtauv,tauv,taucumv,plevrad, & - qxvaer,qsvaer,gvaer,wbarv,cosbv,tauaero, & - tmid,pmid,taugsurf,qvar,muvarrad,fracvari) - - call sfluxv(dtauv,tauv,taucumv,albv,dwnv,wbarv,cosbv, & - acosz,stel_fract, & - nfluxtopv,fluxtopvdn,nfluxoutv_nu,nfluxgndv_nu, & - fmnetv,fluxupv,fluxdnv,fzerov,taugsurf) - - else ! During the night, fluxes = 0. - nfluxtopv = 0.0d0 - fluxtopvdn = 0.0d0 - nfluxoutv_nu(:) = 0.0d0 - nfluxgndv_nu(:) = 0.0d0 - do l=1,L_NLAYRAD - fmnetv(l)=0.0d0 - fluxupv(l)=0.0d0 - fluxdnv(l)=0.0d0 - end do - end if - - - ! Equivalent Albedo Calculation (for OUTPUT). MT2015 - if((fract(ig) .ge. 1.0e-4).or.(global1d)) then ! equivalent albedo makes sense only during daylight. - surface_stellar_flux=sum(nfluxgndv_nu(1:L_NSPECTV)) - if(surface_stellar_flux .gt. 1.0e-3) then ! equivalent albedo makes sense only if the stellar flux received by the surface is positive. - DO nw=1,L_NSPECTV - albedo_temp(nw)=albedo(ig,nw)*nfluxgndv_nu(nw) - ENDDO - albedo_temp(1:L_NSPECTV)=albedo_temp(1:L_NSPECTV)/surface_stellar_flux - albedo_equivalent(ig)=sum(albedo_temp(1:L_NSPECTV)) - else - albedo_equivalent(ig)=0.0 ! Spectrally Integrated Albedo not defined for non-irradiated grid points. So we arbitrary set the equivalent albedo to 0. - endif - else - albedo_equivalent(ig)=0.0 ! Spectrally Integrated Albedo not defined for non-irradiated grid points. So we arbitrary set the equivalent albedo to 0. - endif - - -!----------------------------------------------------------------------- -! Long Wave Part -!----------------------------------------------------------------------- - - call optci(plevrad,tlevrad,dtaui,taucumi, & - qxiaer,qsiaer,giaer,cosbi,wbari,tauaero,tmid,pmid, & - taugsurfi,qvar,muvarrad,fracvari) - - call sfluxi(plevrad,tlevrad,dtaui,taucumi,ubari,albi, & - wnoi,dwni,cosbi,wbari,nfluxtopi,nfluxtopi_nu, & - fmneti,fluxupi,fluxdni,fluxupi_nu,fzeroi,taugsurfi) - -!----------------------------------------------------------------------- -! Transformation of the correlated-k code outputs -! (into dtlw, dtsw, fluxsurf_lw, fluxsurf_sw, fluxtop_lw, fluxtop_sw) - -! Flux incident at the top of the atmosphere - fluxtop_dn(ig)=fluxtopvdn - - fluxtop_lw(ig) = real(nfluxtopi) - fluxabs_sw(ig) = real(-nfluxtopv) - fluxsurf_lw(ig) = real(fluxdni(L_NLAYRAD)) - fluxsurf_sw(ig) = real(fluxdnv(L_NLAYRAD)) - -! Flux absorbed by the surface. By MT2015. - fluxsurfabs_sw(ig) = fluxsurf_sw(ig)*(1.-albedo_equivalent(ig)) - - if(fluxtop_dn(ig).lt.0.0)then - print*,'Achtung! fluxtop_dn has lost the plot!' - print*,'fluxtop_dn=',fluxtop_dn(ig) - print*,'acosz=',acosz - print*,'aerosol=',aerosol(ig,:,:) - print*,'temp= ',pt(ig,:) - print*,'pplay= ',pplay(ig,:) - message="Achtung! fluxtop_dn has lost the plot!" - call abort_physic(subname,message,1) - endif - -! Spectral output, for exoplanet observational comparison - if(specOLR)then - do nw=1,L_NSPECTI - OLR_nu(ig,nw)=nfluxtopi_nu(nw)/DWNI(nw) !JL Normalize to the bandwidth - end do - do nw=1,L_NSPECTV - GSR_nu(ig,nw)=nfluxgndv_nu(nw)/DWNV(nw) - OSR_nu(ig,nw)=nfluxoutv_nu(nw)/DWNV(nw) !JL Normalize to the bandwidth - end do - endif - -! Finally, the heating rates - - DO l=2,L_NLAYRAD - dtsw(ig,L_NLAYRAD+1-l)=(fmnetv(l)-fmnetv(l-1)) & - *glat(ig)/(cpp*scalep*(plevrad(2*l+1)-plevrad(2*l-1))) - dtlw(ig,L_NLAYRAD+1-l)=(fmneti(l)-fmneti(l-1)) & - *glat(ig)/(cpp*scalep*(plevrad(2*l+1)-plevrad(2*l-1))) - END DO - -! These are values at top of atmosphere - dtsw(ig,L_NLAYRAD)=(fmnetv(1)-nfluxtopv) & - *glat(ig)/(cpp*scalep*(plevrad(3)-plevrad(2))) - dtlw(ig,L_NLAYRAD)=(fmneti(1)-nfluxtopi) & - *glat(ig)/(cpp*scalep*(plevrad(3)-plevrad(2))) - - ! Optical thickness diagnostics (added by JVO) - if (diagdtau) then - do l=1,L_NLAYRAD - do nw=1,L_NSPECTV - int_dtauv(ig,l,nw) = 0.0d0 - DO k=1,L_NGAUSS - ! Output exp(-tau) because gweight ponderates exp and not tau itself - int_dtauv(ig,l,nw)= int_dtauv(ig,l,nw) + exp(-dtauv(l,nw,k))*gweight(k) - ENDDO - enddo - do nw=1,L_NSPECTI - int_dtaui(ig,l,nw) = 0.0d0 - DO k=1,L_NGAUSS - ! Output exp(-tau) because gweight ponderates exp and not tau itself - int_dtaui(ig,l,nw)= int_dtaui(ig,l,nw) + exp(-dtaui(l,nw,k))*gweight(k) - ENDDO - enddo - enddo - endif - - -!----------------------------------------------------------------------- - end do ! End of big loop over every GCM column. -!----------------------------------------------------------------------- - - - -!----------------------------------------------------------------------- -! Additional diagnostics -!----------------------------------------------------------------------- - - ! IR spectral output, for exoplanet observational comparison - if(lastcall.and.(ngrid.eq.1))then ! could disable the 1D output, they are in the diagfi and diagspec... JL12 - - print*,'Saving scalar quantities in surf_vals.out...' - print*,'psurf = ', pplev(1,1),' Pa' - open(116,file='surf_vals.out') - write(116,*) tsurf(1),pplev(1,1),fluxtop_dn(1), & - real(-nfluxtopv),real(nfluxtopi) - close(116) - - -! USEFUL COMMENT - Do Not Remove. -! -! if(specOLR)then -! open(117,file='OLRnu.out') -! do nw=1,L_NSPECTI -! write(117,*) OLR_nu(1,nw) -! enddo -! close(117) -! -! open(127,file='OSRnu.out') -! do nw=1,L_NSPECTV -! write(127,*) OSR_nu(1,nw) -! enddo -! close(127) -! endif - - ! OLR vs altitude: do it as a .txt file. - OLRz=.false. - if(OLRz)then - print*,'saving IR vertical flux for OLRz...' - open(118,file='OLRz_plevs.out') - open(119,file='OLRz.out') - do l=1,L_NLAYRAD - write(118,*) plevrad(2*l) - do nw=1,L_NSPECTI - write(119,*) fluxupi_nu(l,nw) - enddo - enddo - close(118) - close(119) - endif - - endif - - ! See physiq.F for explanations about CLFvarying. This is temporary. - if (lastcall .and. .not.CLFvarying) then - IF( ALLOCATED( gasi ) ) DEALLOCATE( gasi ) - IF( ALLOCATED( gasv ) ) DEALLOCATE( gasv ) -!$OMP BARRIER -!$OMP MASTER - IF( ALLOCATED( pgasref ) ) DEALLOCATE( pgasref ) - IF( ALLOCATED( tgasref ) ) DEALLOCATE( tgasref ) - IF( ALLOCATED( wrefvar ) ) DEALLOCATE( wrefvar ) - IF( ALLOCATED( pfgasref ) ) DEALLOCATE( pfgasref ) - IF( ALLOCATED( gweight ) ) DEALLOCATE( gweight ) -!$OMP END MASTER -!$OMP BARRIER - IF ( ALLOCATED(reffrad)) DEALLOCATE(reffrad) - IF ( ALLOCATED(nueffrad)) DEALLOCATE(nueffrad) - endif - - - end subroutine callcorrk - -END MODULE callcorrk_mod Index: trunk/LMDZ.GENERIC/libf/phygeneric/callsedim.F =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/callsedim.F (revision 4062) +++ trunk/LMDZ.GENERIC/libf/phygeneric/callsedim.F (revision 4077) @@ -10,6 +10,6 @@ use radinc_h, only : naerkind - use radii_mod, only: h2o_reffrad - use aerosol_mod, only : iaero_h2o + use aerosol_radius, only: h2o_reffrad + use aerosol_global_variables , only : iaero_h2o USE tracer_h, only : igcm_co2_ice,igcm_h2o_ice,radius,rho_q use comcstfi_mod, only: g Index: trunk/LMDZ.GENERIC/libf/phygeneric/condense_co2.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/condense_co2.F90 (revision 4062) +++ trunk/LMDZ.GENERIC/libf/phygeneric/condense_co2.F90 (revision 4077) @@ -8,6 +8,6 @@ use radinc_h, only : L_NSPECTV use gases_h, only: gfrac, igas_co2 - use radii_mod, only : co2_reffrad - use aerosol_mod, only : iaero_co2 + use aerosol_radius, only : aerosol_radius_co2 + use aerosol_global_variables , only : iaero_co2 USE surfdat_h, only: emisice, emissiv USE geometry_mod, only: latitude ! in radians @@ -273,6 +273,6 @@ ! Gravitational sedimentation starts. - ! Sedimentation computed from radius computed from q in module radii_mod. - call co2_reffrad(ngrid,nlayer,nq,zq,reffrad) + ! Sedimentation computed from radius computed from q in module aerosol_radius. + call aerosol_radius_co2(ngrid,nlayer,nq,zq,reffrad) DO ilay=1,nlayer Index: trunk/LMDZ.GENERIC/libf/phygeneric/dsolver.F =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/dsolver.F (revision 4062) +++ (revision ) @@ -1,102 +1,0 @@ - SUBROUTINE DSOLVER(NL,GAMA,CP,CM,CPM1,CMM1,E1,E2,E3,E4,BTOP, - * BSURF,RSF,XK1,XK2) - -C GCM2.0 Feb 2003 -C -C DOUBLE PRECISION VERSION OF SOLVER - -!! PARAMETER (NMAX=201) - IMPLICIT REAL*8 (A-H,O-Z) - DIMENSION GAMA(NL),CP(NL),CM(NL),CPM1(NL),CMM1(NL),XK1(NL), - * XK2(NL),E1(NL),E2(NL),E3(NL),E4(NL) - DIMENSION AF(2*NL),BF(2*NL),CF(2*NL),DF(2*NL),XK(2*NL) -C********************************************************* -C* THIS SUBROUTINE SOLVES FOR THE COEFFICIENTS OF THE * -C* TWO STREAM SOLUTION FOR GENERAL BOUNDARY CONDITIONS * -C* NO ASSUMPTION OF THE DEPENDENCE ON OPTICAL DEPTH OF * -C* C-PLUS OR C-MINUS HAS BEEN MADE. * -C* NL = NUMBER OF LAYERS IN THE MODEL * -C* CP = C-PLUS EVALUATED AT TAO=0 (TOP) * -C* CM = C-MINUS EVALUATED AT TAO=0 (TOP) * -C* CPM1 = C-PLUS EVALUATED AT TAOSTAR (BOTTOM) * -C* CMM1 = C-MINUS EVALUATED AT TAOSTAR (BOTTOM) * -C* EP = EXP(LAMDA*DTAU) * -C* EM = 1/EP * -C* E1 = EP + GAMA *EM * -C* E2 = EP - GAMA *EM * -C* E3 = GAMA*EP + EM * -C* E4 = GAMA*EP - EM * -C* BTOP = THE DIFFUSE RADIATION INTO THE MODEL AT TOP * -C* BSURF = THE DIFFUSE RADIATION INTO THE MODEL AT * -C* THE BOTTOM: INCLUDES EMMISION AND REFLECTION * -C* OF THE UNATTENUATED PORTION OF THE DIRECT * -C* BEAM. BSTAR+RSF*FO*EXP(-TAOSTAR/U0) * -C* RSF = REFLECTIVITY OF THE SURFACE * -C* XK1 = COEFFICIENT OF THE POSITIVE EXP TERM * -C* XK2 = COEFFICIENT OF THE NEGATIVE EXP TERM * -C********************************************************* - -C======================================================================C - - L=2*NL - -C ************MIXED COEFFICENTS********** -C THIS VERSION AVOIDS SINGULARITIES ASSOC. -C WITH W0=0 BY SOLVING FOR XK1+XK2, AND XK1-XK2. - - AF(1) = 0.0 - BF(1) = GAMA(1)+1. - CF(1) = GAMA(1)-1. - DF(1) = BTOP-CMM1(1) - N = 0 - LM2 = L-2 - -C EVEN TERMS - - DO I=2,LM2,2 - N = N+1 - AF(I) = (E1(N)+E3(N))*(GAMA(N+1)-1.) - BF(I) = (E2(N)+E4(N))*(GAMA(N+1)-1.) - CF(I) = 2.0*(1.-GAMA(N+1)**2) - DF(I) = (GAMA(N+1)-1.) * (CPM1(N+1) - CP(N)) + - * (1.-GAMA(N+1))* (CM(N)-CMM1(N+1)) - END DO - - N = 0 - LM1 = L-1 - DO I=3,LM1,2 - N = N+1 - AF(I) = 2.0*(1.-GAMA(N)**2) - BF(I) = (E1(N)-E3(N))*(1.+GAMA(N+1)) - CF(I) = (E1(N)+E3(N))*(GAMA(N+1)-1.) - DF(I) = E3(N)*(CPM1(N+1) - CP(N)) + E1(N)*(CM(N) - CMM1(N+1)) - END DO - - AF(L) = E1(NL)-RSF*E3(NL) - BF(L) = E2(NL)-RSF*E4(NL) - CF(L) = 0.0 - DF(L) = BSURF-CP(NL)+RSF*CM(NL) - - CALL DTRIDGL(L,AF,BF,CF,DF,XK) - -C ***UNMIX THE COEFFICIENTS**** - - DO 28 N=1,NL - XK1(N) = XK(2*N-1)+XK(2*N) - XK2(N) = XK(2*N-1)-XK(2*N) - -C NOW TEST TO SEE IF XK2 IS REALLY ZERO TO THE LIMIT OF THE -C MACHINE ACCURACY = 1 .E -30 -C XK2 IS THE COEFFICEINT OF THE GROWING EXPONENTIAL AND MUST -C BE TREATED CAREFULLY - - IF(XK2(N) .EQ. 0.0) GO TO 28 -c IF (ABS (XK2(N)/XK(2*N-1)) .LT. 1.E-30) XK2(N)=0.0 - - IF (ABS (XK2(N)/(XK(2*N-1)+1.e-20)) .LT. 1.E-30) XK2(N)=0.0 ! For debug only (with -Ktrap=fp option) - - - 28 CONTINUE - - RETURN - END Index: trunk/LMDZ.GENERIC/libf/phygeneric/dyn1d/kcm1d.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/dyn1d/kcm1d.F90 (revision 4062) +++ trunk/LMDZ.GENERIC/libf/phygeneric/dyn1d/kcm1d.F90 (revision 4077) @@ -11,6 +11,6 @@ varspec, varspec_data, nvarlayer use inifis_mod, only: inifis - use aerosol_mod, only: iniaerosol - use callcorrk_mod, only: callcorrk + use aerosol_global_variables , only: aerosol_init + use rad_correlatedk_mod, only: rad_correlatedk use comcstfi_mod use mod_grid_phy_lmdz, only : regular_lonlat @@ -410,5 +410,5 @@ - call iniaerosol + call aerosol_init @@ -416,5 +416,5 @@ ! Run radiative transfer - call callcorrk(1,nlayer,q,nq,qsurf, & + call rad_correlatedk(1,nlayer,q,nq,qsurf, & albedo_wv,albedo_equivalent, & emis,mu0,plev,play,temp, & @@ -470,5 +470,5 @@ firstcall=.false. lastcall=.true. - call callcorrk(1,nlayer,q,nq,qsurf, & + call rad_correlatedk(1,nlayer,q,nq,qsurf, & albedo_wv,albedo_equivalent,emis,mu0,plev,play,temp, & tsurf,fract,dist_star,aerosol,muvar, & Index: trunk/LMDZ.GENERIC/libf/phygeneric/dyn1d/rcm1d.F =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/dyn1d/rcm1d.F (revision 4062) +++ trunk/LMDZ.GENERIC/libf/phygeneric/dyn1d/rcm1d.F (revision 4077) @@ -1161,5 +1161,5 @@ IF (idt.eq.ndt) then !test lastcall=.true. - call stellarlong(day*1.0,zls) + call ephemeris_stellar_longitude(day*1.0,zls) ! write(103,*) 'Ls=',zls*180./pi ! write(103,*) 'Lat=', latitude(1)*180./pi Index: trunk/LMDZ.GENERIC/libf/phygeneric/ephemeris_orbit.F =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/ephemeris_orbit.F (revision 4077) +++ trunk/LMDZ.GENERIC/libf/phygeneric/ephemeris_orbit.F (revision 4077) @@ -0,0 +1,65 @@ + subroutine ephemeris_orbit(pls,pdist_star,pdecli,pright_ascenc) + + use planete_mod, only: p_elips, e_elips, timeperi, obliquit + use comcstfi_mod, only: pi + implicit none +!================================================================== +! +! Purpose +! ------- +! Distance from star and declination as a function of the stellar +! longitude Ls +! +! Inputs +! ------ +! pls Ls +! +! Outputs +! ------- +! pdist_star Distance Star-Planet in UA +! pdecli declinaison ( in radians ) +! pright_ascenc right ascension ( in radians ) +! +!======================================================================= + +c Declarations: +c ------------- + +c arguments: +c ---------- + + REAL pday,pdist_star,pdecli,pright_ascenc,pls,i + +c----------------------------------------------------------------------- + +c Star-Planet Distance + + pdist_star = p_elips/(1.+e_elips*cos(pls+timeperi)) + +c Stellar declination + +c ********************* version before 01/01/2000 ******* + + pdecli = asin (sin(pls)*sin(obliquit*pi/180.)) + +c********************* version after 01/01/2000 ******* +c i=obliquit*pi/180. +c pdecli=asin(sin(pls)*sin(i)/sqrt(sin(pls)**2+ +c & cos(pls)**2*cos(i)**2)) +c ****************************************************** + +c right ascencion + If((pls.lt.pi/2.d0)) then + pright_ascenc= atan(tan(pls)*cos(obliquit*pi/180.)) + else if((pls.gt.pi/2.d0).and.(pls.lt.3.d0*pi/2.d0)) then + pright_ascenc= pi+atan(tan(pls)*cos(obliquit*pi/180.)) + else if((pls.gt.3.d0*pi/2.d0)) then + pright_ascenc= 2.d0*pi+atan(tan(pls)*cos(obliquit*pi/180.)) + else if (Abs(pls-pi/2.d0).le.1.d-10) then + pright_ascenc= pi/2.d0 + else + pright_ascenc=-pi/2.d0 + end if + + RETURN + END Index: trunk/LMDZ.GENERIC/libf/phygeneric/ephemeris_orbit_init.F =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/ephemeris_orbit_init.F (revision 4077) +++ trunk/LMDZ.GENERIC/libf/phygeneric/ephemeris_orbit_init.F (revision 4077) @@ -0,0 +1,74 @@ + SUBROUTINE ephemeris_orbit_init + $ (papoastr,pperiastr,pyear_day,pperi_day,pobliq) + + USE planete_mod, only: apoastr, periastr, year_day, obliquit, + & peri_day, e_elips, p_elips, timeperi + use comcstfi_mod, only: pi + IMPLICIT NONE + +!======================================================================= +! Initialisation of orbital parameters (stored in planete_h module) +!======================================================================= + +c Arguments: +c ---------- + + REAL,INTENT(IN) :: papoastr,pperiastr,pyear_day,pperi_day,pobliq + +c Local: +c ------ + + REAL zxref,zanom,zz,zx0,zdx + INTEGER iter + +c----------------------------------------------------------------------- + + pi=2.*asin(1.) + + apoastr =papoastr + periastr=pperiastr + year_day=pyear_day + obliquit=pobliq + peri_day=pperi_day + + PRINT*,'ephemeris_orbit_init: Periastron in AU ',periastr + PRINT*,'ephemeris_orbit_init: Apoastron in AU ',apoastr + PRINT*,'ephemeris_orbit_init: Obliquity in degrees :',obliquit + + + e_elips=(apoastr-periastr)/(periastr+apoastr) + p_elips=0.5*(periastr+apoastr)*(1-e_elips*e_elips) + + print*,'ephemeris_orbit_init: e_elips',e_elips + print*,'ephemeris_orbit_init: p_elips',p_elips + +!----------------------------------------------------------------------- +! compute polar angle and distance to the Sun: +! ------------------------------------------------------- + +! compute mean anomaly zanom + + zz=(year_day-pperi_day)/year_day + zanom=2.*pi*(zz-nint(zz)) + zxref=abs(zanom) + PRINT*,'ephemeris_orbit_init: zanom ',zanom + +! solve equation zx0 - e * sin (zx0) = zxref for eccentric anomaly zx0 +! using Newton method + + zx0=zxref+e_elips*sin(zxref) + DO iter=1,100 + zdx=-(zx0-e_elips*sin(zx0)-zxref)/(1.-e_elips*cos(zx0)) + if(abs(zdx).le.(1.e-12)) exit + zx0=zx0+zdx + ENDDO + + zx0=zx0+zdx + if(zanom.lt.0.) zx0=-zx0 + PRINT*,'ephemeris_orbit_init: zx0 ',zx0 + + timeperi=2.*atan(sqrt((1.+e_elips)/(1.-e_elips))*tan(zx0/2.)) + PRINT*,'ephemeris_orbit_init: Perihelion solar long. Ls (deg)=', + & 360.-timeperi*180./pi + + END Index: trunk/LMDZ.GENERIC/libf/phygeneric/ephemeris_stellar_angle.F =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/ephemeris_stellar_angle.F (revision 4077) +++ trunk/LMDZ.GENERIC/libf/phygeneric/ephemeris_stellar_angle.F (revision 4077) @@ -0,0 +1,122 @@ + subroutine ephemeris_stellar_angle(kgrid, + & psilon,pcolon,psilat,pcolat, + & ptim1,ptim2,ptim3,pmu0,pfract, pflat) + IMPLICIT NONE + +C +C**** *LW* - ORGANIZES THE LONGWAVE CALCULATIONS +C +C PURPOSE. +C -------- +C CALCULATES THE STELLAR ANGLE FOR ALL THE POINTS OF THE GRID +C +C** INTERFACE. +C ---------- +C SUBROUTINE ephemeris_stellar_angle ( KGRID ) +C +C EXPLICIT ARGUMENTS : +C -------------------- +C ==== INPUTS === +C +C PSILON(KGRID) : SINUS OF THE LONGITUDE +C PCOLON(KGRID) : COSINUS OF THE LONGITUDE +C PSILAT(KGRID) : SINUS OF THE LATITUDE +C PCOLAT(KGRID) : COSINUS OF THE LATITUDE +C PTIM1 : SIN(DECLI) +C PTIM2 : COS(DECLI)*COS(TIME) +C PTIM3 : SIN(DECLI)*SIN(TIME) +C +C ==== OUTPUTS === +C +C PMU0 (KGRID) : SOLAR ANGLE +C PFRACT(KGRID) : DAY FRACTION OF THE TIME INTERVAL +C +C IMPLICIT ARGUMENTS : NONE +C -------------------- +C +C METHOD. +C ------- +C +C EXTERNALS. +C ---------- +C +C NONE +C +C REFERENCE. +C ---------- +C +C RADIATIVE PROCESSES IN METEOROLOGIE AND CLIMATOLOGIE +C PALTRIDGE AND PLATT +C +C AUTHOR. +C ------- +C FREDERIC HOURDIN +C +C MODIFICATIONS. +C -------------- +C ORIGINAL :90-01-14 +C 92-02-14 CALCULATIONS DONE THE ENTIER GRID (J.Polcher) +C----------------------------------------------------------------------- +C +C ------------------------------------------------------------------ + +C----------------------------------------------------------------------- +C +C* 0.1 ARGUMENTS +C --------- +C + INTEGER,INTENT(IN) :: kgrid + REAL,INTENT(IN) :: ptim1,ptim2,ptim3, pflat + REAL,INTENT(IN) :: psilon(kgrid),pcolon(kgrid) + REAL,INTENT(IN) :: psilat(kgrid), pcolat(kgrid) + REAL,INTENT(OUT) :: pmu0(kgrid),pfract(kgrid) +C + INTEGER jl + REAL ztim1,ztim2,ztim3, rap +C------------------------------------------------------------------------ +C------------------------------------------------------------------------ +C------------------------------------------------------------------------ +C +C------------------------------------------------------------------------ +C +C* 1. INITIALISATION +C -------------- +C +c----- SG: geometry adapted to a flattened planet (Feb2014) + + rap = 1./((1.-pflat)**2) + + 100 CONTINUE +C + DO jl=1,kgrid + pmu0(jl)=0. + pfract(jl)=0. + ENDDO +C +C* 1.1 COMPUTATION OF THE SOLAR ANGLE +C ------------------------------ +C + DO jl=1,kgrid + ztim1=psilat(jl)*ptim1*rap + ztim2=pcolat(jl)*ptim2 + ztim3=pcolat(jl)*ptim3 + pmu0(jl)=ztim1+ztim2*pcolon(jl)+ztim3*psilon(jl) + pmu0(jl)=pmu0(jl)/SQRT(pcolat(jl)**2+(rap**2)*(psilat(jl)**2)) + + ENDDO +C +C* 1.2 DISTINCTION BETWEEN DAY AND NIGHT +C --------------------------------- +C + DO jl=1,kgrid + IF (pmu0(jl).gt.0.) THEN + pfract(jl)=1. +c pmu0(jl)=sqrt(1224.*pmu0(jl)*pmu0(jl)+1.)/35. + ELSE +c pmu0(jl)=0. + pfract(jl)=0. + ENDIF + ENDDO +C + RETURN + END Index: trunk/LMDZ.GENERIC/libf/phygeneric/ephemeris_stellar_longitude.F =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/ephemeris_stellar_longitude.F (revision 4077) +++ trunk/LMDZ.GENERIC/libf/phygeneric/ephemeris_stellar_longitude.F (revision 4077) @@ -0,0 +1,101 @@ + SUBROUTINE ephemeris_stellar_longitude(pday,pstellong) + + USE planete_mod, ONLY: year_day, peri_day, e_elips, timeperi + use comcstfi_mod, only: pi + IMPLICIT NONE + +c======================================================================= +c +c Objet: +c ------ +c +c Calcul de la distance soleil-planete et de la declinaison +c en fonction du jour de l'annee. +c +c +c Methode: +c -------- +c +c Calcul complet de l'elipse +c +c Interface: +c ---------- +c +c Uncommon comprenant les parametres orbitaux. +c +c Arguments: +c ---------- +c +c Input: +c ------ +c pday jour de l'annee (le jour 0 correspondant a l'equinoxe) +c +c Output: +c ------- +c pdist_star distance entre le soleil et la planete +c ( en unite astronomique pour utiliser la constante +c solaire terrestre 1370 Wm-2 ) +c pdecli declinaison ( en radians ) +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +c arguments: +c ---------- + + REAL pday,pdist_star,pdecli,pstellong + LOGICAL lwrite + +c Local: +c ------ + + REAL zanom,xref,zx0,zdx,zteta,zz + INTEGER iter + + +c----------------------------------------------------------------------- +c calcul de l'angle polaire et de la distance au soleil : +c ------------------------------------------------------- + +c calcul de l'zanomalie moyenne + + zz=(pday-peri_day)/year_day + pi=2.*asin(1.) + zanom=2.*pi*(zz-nint(zz)) + xref=abs(zanom) + +c resolution de l'equation horaire zx0 - e * sin (zx0) = xref +c methode de Newton + + zx0=xref+e_elips*sin(xref) + DO 110 iter=1,10 + zdx=-(zx0-e_elips*sin(zx0)-xref)/(1.-e_elips*cos(zx0)) + if(abs(zdx).le.(1.e-7)) goto 120 + zx0=zx0+zdx +110 continue +120 continue + zx0=zx0+zdx + if(zanom.lt.0.) zx0=-zx0 + +c zteta est la longitude solaire + + zteta=2.*atan(sqrt((1.+e_elips)/(1.-e_elips))*tan(zx0/2.)) + + pstellong=zteta-timeperi + + IF(pstellong.LT.0.) pstellong=pstellong+2.*pi + IF(pstellong.GT.2.*pi) pstellong=pstellong-2.*pi +c----------------------------------------------------------------------- +c sorties eventuelles: +c --------------------- + +c IF (lwrite) THEN +c PRINT*,'jour de l"annee :',pday +c PRINT*,'distance au soleil (en unite astronomique) :',pdist_star +c PRINT*,'declinaison (en degres) :',pdecli*180./pi +c ENDIF + + RETURN + END Index: trunk/LMDZ.GENERIC/libf/phygeneric/gfluxi.F =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/gfluxi.F (revision 4062) +++ (revision ) @@ -1,246 +1,0 @@ - module gfluxi_mod - - implicit none - - contains - - SUBROUTINE GFLUXI(NLL,TLEV,NW,DW,DTAU,TAUCUM,W0,COSBAR,UBARI, - * RSF,BTOP,BSURF,FTOPUP,FMIDP,FMIDM) - - use radinc_h, only: L_TAUMAX, NTfac, NTstart - use radinc_h, only: L_NLAYRAD, L_LEVELS - use radcommon_h, only: planckir - use comcstfi_mod, only: pi - - IMPLICIT NONE - -!----------------------------------------------------------------------- -! THIS SUBROUTINE TAKES THE OPTICAL CONSTANTS AND BOUNDARY CONDITIONS -! FOR THE INFRARED FLUX AT ONE WAVELENGTH AND SOLVES FOR THE FLUXES AT -! THE LEVELS. THIS VERSION IS SET UP TO WORK WITH LAYER OPTICAL DEPTHS -! MEASURED FROM THE TOP OF EACH LAYER. THE TOP OF EACH LAYER HAS -! OPTICAL DEPTH ZERO. IN THIS SUB LEVEL N IS ABOVE LAYER N. THAT IS LAYER N -! HAS LEVEL N ON TOP AND LEVEL N+1 ON BOTTOM. OPTICAL DEPTH INCREASES -! FROM TOP TO BOTTOM. SEE C.P. MCKAY, TGM NOTES. -! THE TRI-DIAGONAL MATRIX SOLVER IS DSOLVER AND IS DOUBLE PRECISION SO MANY -! VARIABLES ARE PASSED AS SINGLE THEN BECOME DOUBLE IN DSOLVER -! -! NLL = NUMBER OF LEVELS (NLAYERS + 1) MUST BE LESS THAT NL (101) -! TLEV(L_LEVELS) = ARRAY OF TEMPERATURES AT GCM LEVELS -! WAVEN = WAVELENGTH FOR THE COMPUTATION -! DW = WAVENUMBER INTERVAL -! DTAU(NLAYER) = ARRAY OPTICAL DEPTH OF THE LAYERS -! W0(NLEVEL) = SINGLE SCATTERING ALBEDO -! COSBAR(NLEVEL) = ASYMMETRY FACTORS, 0=ISOTROPIC -! UBARI = AVERAGE ANGLE, MUST BE EQUAL TO 0.5 IN IR -! RSF = SURFACE REFLECTANCE -! BTOP = UPPER BOUNDARY CONDITION ON IR INTENSITY (NOT FLUX) -! BSURF = SURFACE EMISSION = (1-RSFI)*PLANCK, INTENSITY (NOT FLUX) -! FP(NLEVEL) = UPWARD FLUX AT LEVELS -! FM(NLEVEL) = DOWNWARD FLUX AT LEVELS -! FMIDP(NLAYER) = UPWARD FLUX AT LAYER MIDPOINTS -! FMIDM(NLAYER) = DOWNWARD FLUX AT LAYER MIDPOINTS -!----------------------------------------------------------------------- - - INTEGER NLL, NLAYER, L, NW, NT, NT2 - REAL*8 TERM, CPMID, CMMID - REAL*8 PLANCK - REAL*8 EM,EP - REAL*8 COSBAR(L_NLAYRAD), W0(L_NLAYRAD), DTAU(L_NLAYRAD) - REAL*8 TAUCUM(L_LEVELS), DTAUK - REAL*8 TLEV(L_LEVELS) - REAL*8 WAVEN, DW, UBARI, RSF - REAL*8 BTOP, BSURF, FMIDP(L_NLAYRAD), FMIDM(L_NLAYRAD) - REAL*8 B0(L_NLAYRAD) - REAL*8 B1(L_NLAYRAD) - REAL*8 ALPHA(L_NLAYRAD) - REAL*8 LAMDA(L_NLAYRAD),XK1(L_NLAYRAD),XK2(L_NLAYRAD) - REAL*8 GAMA(L_NLAYRAD),CP(L_NLAYRAD),CM(L_NLAYRAD) - REAL*8 CPM1(L_NLAYRAD),CMM1(L_NLAYRAD),E1(L_NLAYRAD) - REAL*8 E2(L_NLAYRAD) - REAL*8 E3(L_NLAYRAD) - REAL*8 E4(L_NLAYRAD) - REAL*8 FTOPUP, FLUXUP, FLUXDN - REAL*8 :: TAUMAX = L_TAUMAX - -! AB : variables for interpolation - REAL*8 C1 - REAL*8 C2 - REAL*8 P1 - REAL*8 P2 - -!======================================================================= -! WE GO WITH THE HEMISPHERIC CONSTANT APPROACH IN THE INFRARED - - NLAYER = L_NLAYRAD - - DO L=1,L_NLAYRAD-1 - -!----------------------------------------------------------------------- -! There is a problem when W0 = 1 -! open(888,file='W0') -! if ((W0(L).eq.0.).or.(W0(L).eq.1.)) then -! write(888,*) W0(L), L, 'gfluxi' -! endif -! Prevent this with an if statement: -!----------------------------------------------------------------------- - if (W0(L).eq.1.D0) then - W0(L) = 0.99999D0 - endif - - ALPHA(L) = SQRT( (1.0D0-W0(L))/(1.0D0-W0(L)*COSBAR(L)) ) - LAMDA(L) = ALPHA(L)*(1.0D0-W0(L)*COSBAR(L))/UBARI - - NT = int(TLEV(2*L)*NTfac) - NTstart+1 - NT2 = int(TLEV(2*L+2)*NTfac) - NTstart+1 - -! AB : PLANCKIR(NW,NT) is replaced by P1, the linear interpolation result for a temperature NT -! AB : idem for PLANCKIR(NW,NT2) and P2 - C1 = TLEV(2*L) * NTfac - int(TLEV(2*L) * NTfac) - C2 = TLEV(2*L+2)*NTfac - int(TLEV(2*L+2)*NTfac) - P1 = (1.0D0 - C1) * PLANCKIR(NW,NT) + C1 * PLANCKIR(NW,NT+1) - P2 = (1.0D0 - C2) * PLANCKIR(NW,NT2) + C2 * PLANCKIR(NW,NT2+1) - B1(L) = (P2 - P1) / DTAU(L) - B0(L) = P1 - END DO - -! Take care of special lower layer - - L = L_NLAYRAD - - if (W0(L).eq.1.) then - W0(L) = 0.99999D0 - end if - - ALPHA(L) = SQRT( (1.0D0-W0(L))/(1.0D0-W0(L)*COSBAR(L)) ) - LAMDA(L) = ALPHA(L)*(1.0D0-W0(L)*COSBAR(L))/UBARI - - ! Tsurf is used for 1st layer source function - ! -- same results for most thin atmospheres - ! -- and stabilizes integrations - NT = int(TLEV(2*L+1)*NTfac) - NTstart+1 - !! For deep, opaque, thick first layers (e.g. Saturn) - !! what is below works much better, not unstable, ... - !! ... and actually fully accurate because 1st layer temp (JL) - !NT = int(TLEV(2*L)*NTfac) - NTstart+1 - !! (or this one yields same results - !NT = int( (TLEV(2*L)+TLEV(2*L+1))*0.5*NTfac ) - NTstart+1 - - NT2 = int(TLEV(2*L)*NTfac) - NTstart+1 - -! AB : PLANCKIR(NW,NT) is replaced by P1, the linear interpolation result for a temperature NT -! AB : idem for PLANCKIR(NW,NT2) and P2 - C1 = TLEV(2*L+1)*NTfac - int(TLEV(2*L+1)*NTfac) - C2 = TLEV(2*L) * NTfac - int(TLEV(2*L) * NTfac) - P1 = (1.0D0 - C1) * PLANCKIR(NW,NT) + C1 * PLANCKIR(NW,NT+1) - P2 = (1.0D0 - C2) * PLANCKIR(NW,NT2) + C2 * PLANCKIR(NW,NT2+1) - B1(L) = (P1 - P2) / DTAU(L) - B0(L) = P2 - - DO L=1,L_NLAYRAD - GAMA(L) = (1.0D0-ALPHA(L))/(1.0D0+ALPHA(L)) - TERM = UBARI/(1.0D0-W0(L)*COSBAR(L)) - -! CPM1 AND CMM1 ARE THE CPLUS AND CMINUS TERMS EVALUATED -! AT THE TOP OF THE LAYER, THAT IS ZERO OPTICAL DEPTH - - CPM1(L) = B0(L)+B1(L)*TERM - CMM1(L) = B0(L)-B1(L)*TERM - -! CP AND CM ARE THE CPLUS AND CMINUS TERMS EVALUATED AT THE -! BOTTOM OF THE LAYER. THAT IS AT DTAU OPTICAL DEPTH. -! JL18 put CP and CM after the calculation of CPM1 and CMM1 to avoid unecessary calculations. - - CP(L) = CPM1(L) +B1(L)*DTAU(L) - CM(L) = CMM1(L) +B1(L)*DTAU(L) - END DO - -! NOW CALCULATE THE EXPONENTIAL TERMS NEEDED -! FOR THE TRIDIAGONAL ROTATED LAYERED METHOD -! WARNING IF DTAU(J) IS GREATER THAN ABOUT 35 (VAX) -! WE CLIP IT TO AVOID OVERFLOW. - - DO L=1,L_NLAYRAD - EP = EXP( MIN((LAMDA(L)*DTAU(L)),TAUMAX)) ! CLIPPED EXPONENTIAL - EM = 1.0D0/EP - E1(L) = EP+GAMA(L)*EM - E2(L) = EP-GAMA(L)*EM - E3(L) = GAMA(L)*EP+EM - E4(L) = GAMA(L)*EP-EM - END DO - -! B81=BTOP ! RENAME BEFORE CALLING DSOLVER - used to be to set -! B82=BSURF ! them to real*8 - but now everything is real*8 -! R81=RSF ! so this may not be necessary - -! DOUBLE PRECISION TRIDIAGONAL SOLVER - - CALL DSOLVER(NLAYER,GAMA,CP,CM,CPM1,CMM1,E1,E2,E3,E4,BTOP, - * BSURF,RSF,XK1,XK2) - -! NOW WE CALCULATE THE FLUXES AT THE MIDPOINTS OF THE LAYERS. - - DO L=1,L_NLAYRAD-1 - DTAUK = TAUCUM(2*L+1)-TAUCUM(2*L) - EP = EXP(MIN(LAMDA(L)*DTAUK,TAUMAX)) ! CLIPPED EXPONENTIAL - EM = 1.0D0/EP - TERM = UBARI/(1.D0-W0(L)*COSBAR(L)) - -! CP AND CM ARE THE CPLUS AND CMINUS TERMS EVALUATED AT THE -! BOTTOM OF THE LAYER. THAT IS AT DTAU OPTICAL DEPTH - - CPMID = B0(L)+B1(L)*DTAUK +B1(L)*TERM - CMMID = B0(L)+B1(L)*DTAUK -B1(L)*TERM - FMIDP(L) = XK1(L)*EP + GAMA(L)*XK2(L)*EM + CPMID - FMIDM(L) = XK1(L)*EP*GAMA(L) + XK2(L)*EM + CMMID - -! FOR FLUX WE INTEGRATE OVER THE HEMISPHERE TREATING INTENSITY CONSTANT - - FMIDP(L) = FMIDP(L)*PI - FMIDM(L) = FMIDM(L)*PI - END DO - -! And now, for the special bottom layer - - L = L_NLAYRAD - - EP = EXP(MIN((LAMDA(L)*DTAU(L)),TAUMAX)) ! CLIPPED EXPONENTIAL - EM = 1.0D0/EP - TERM = UBARI/(1.D0-W0(L)*COSBAR(L)) - -! CP AND CM ARE THE CPLUS AND CMINUS TERMS EVALUATED AT THE -! BOTTOM OF THE LAYER. THAT IS AT DTAU OPTICAL DEPTH - - CPMID = B0(L)+B1(L)*DTAU(L) +B1(L)*TERM - CMMID = B0(L)+B1(L)*DTAU(L) -B1(L)*TERM - FMIDP(L) = XK1(L)*EP + GAMA(L)*XK2(L)*EM + CPMID - FMIDM(L) = XK1(L)*EP*GAMA(L) + XK2(L)*EM + CMMID - -! FOR FLUX WE INTEGRATE OVER THE HEMISPHERE TREATING INTENSITY CONSTANT - - FMIDP(L) = FMIDP(L)*PI - FMIDM(L) = FMIDM(L)*PI - -! FLUX AT THE PTOP LEVEL - - EP = 1.0D0 - EM = 1.0D0 - TERM = UBARI/(1.0D0-W0(1)*COSBAR(1)) - -! CP AND CM ARE THE CPLUS AND CMINUS TERMS EVALUATED AT THE -! BOTTOM OF THE LAYER. THAT IS AT DTAU OPTICAL DEPTH - - CPMID = B0(1)+B1(1)*TERM - CMMID = B0(1)-B1(1)*TERM - - FLUXUP = XK1(1)*EP + GAMA(1)*XK2(1)*EM + CPMID - FLUXDN = XK1(1)*EP*GAMA(1) + XK2(1)*EM + CMMID - -! FOR FLUX WE INTEGRATE OVER THE HEMISPHERE TREATING INTENSITY CONSTANT - - FTOPUP = (FLUXUP-FLUXDN)*PI - - - END SUBROUTINE GFLUXI - - end module gfluxi_mod Index: trunk/LMDZ.GENERIC/libf/phygeneric/gfluxv.F =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/gfluxv.F (revision 4062) +++ (revision ) @@ -1,339 +1,0 @@ - module gfluxv_mod - - implicit none - - contains - - SUBROUTINE GFLUXV(DTDEL,TDEL,TAUCUMIN,WDEL,CDEL,UBAR0,F0PI,RSF, - * BTOP,BSURF,FMIDP,FMIDM,DIFFV,FLUXUP,FLUXDN) - - -C THIS SUBROUTINE TAKES THE OPTICAL CONSTANTS AND BOUNDARY CONDITIONS -C FOR THE VISIBLE FLUX AT ONE WAVELENGTH AND SOLVES FOR THE FLUXES AT -C THE LEVELS. THIS VERSION IS SET UP TO WORK WITH LAYER OPTICAL DEPTHS -C MEASURED FROM THE TOP OF EACH LAYER. (DTAU) TOP OF EACH LAYER HAS -C OPTICAL DEPTH TAU(N).IN THIS SUB LEVEL N IS ABOVE LAYER N. THAT IS LAYER N -C HAS LEVEL N ON TOP AND LEVEL N+1 ON BOTTOM. OPTICAL DEPTH INCREASES -C FROM TOP TO BOTTOM. SEE C.P. MCKAY, TGM NOTES. -C THIS SUBROUTINE DIFFERS FROM ITS IR COUNTERPART IN THAT HERE WE SOLVE FOR -C THE FLUXES DIRECTLY USING THE GENERALIZED NOTATION OF MEADOR AND WEAVOR -C J.A.S., 37, 630-642, 1980. -C THE TRI-DIAGONAL MATRIX SOLVER IS DSOLVER AND IS DOUBLE PRECISION SO MANY -C VARIABLES ARE PASSED AS SINGLE THEN BECOME DOUBLE IN DSOLVER -C -C NLL = NUMBER OF LEVELS (NAYER + 1) THAT WILL BE SOLVED -C NAYER = NUMBER OF LAYERS (NOTE DIFFERENT SPELLING HERE) -C WAVEN = WAVELENGTH FOR THE COMPUTATION -C DTDEL(NLAYER) = ARRAY OPTICAL DEPTH OF THE LAYERS -C TDEL(NLL) = ARRAY COLUMN OPTICAL DEPTH AT THE LEVELS -C WDEL(NLEVEL) = SINGLE SCATTERING ALBEDO -C CDEL(NLL) = ASYMMETRY FACTORS, 0=ISOTROPIC -C UBARV = AVERAGE ANGLE, -C UBAR0 = SOLAR ZENITH ANGLE -C F0PI = INCIDENT SOLAR DIRECT BEAM FLUX -C RSF = SURFACE REFLECTANCE -C BTOP = UPPER BOUNDARY CONDITION ON DIFFUSE FLUX -C BSURF = REFLECTED DIRECT BEAM = (1-RSFI)*F0PI*EDP-TAU/U -C FP(NLEVEL) = UPWARD FLUX AT LEVELS -C FM(NLEVEL) = DOWNWARD FLUX AT LEVELS -C FMIDP(NLAYER) = UPWARD FLUX AT LAYER MIDPOINTS -C FMIDM(NLAYER) = DOWNWARD FLUX AT LAYER MIDPOINTS -C added Dec 2002 -C DIFFV = downward diffuse solar flux at the surface -C -!======================================================================! - - use radinc_h, only: L_TAUMAX, L_NLAYRAD, L_NLEVRAD, L_LEVELS - - implicit none - -!! INTEGER NLP -!! PARAMETER (NLP=101) ! MUST BE LARGER THAN NLEVEL - - REAL*8 EM, EP, EXPTRM - REAL*8 W0(L_NLAYRAD), COSBAR(L_NLAYRAD), DTAU(L_NLAYRAD) - REAL*8 TAU(L_NLEVRAD), WDEL(L_NLAYRAD), CDEL(L_NLAYRAD) - REAL*8 DTDEL(L_NLAYRAD), TDEL(L_NLEVRAD) - REAL*8 FMIDP(L_NLAYRAD), FMIDM(L_NLAYRAD) - REAL*8 LAMDA(L_NLAYRAD), ALPHA(L_NLAYRAD), XK1(L_NLAYRAD) - REAL*8 XK2(L_NLAYRAD),G1(L_NLAYRAD), G2(L_NLAYRAD) - REAL*8 G3(L_NLAYRAD), GAMA(L_NLAYRAD),CP(L_NLAYRAD),CM(L_NLAYRAD) - REAL*8 CPM1(L_NLAYRAD),CMM1(L_NLAYRAD), E1(L_NLAYRAD) - REAL*8 E2(L_NLAYRAD),E3(L_NLAYRAD),E4(L_NLAYRAD) - REAL*8 FLUXUP, FLUXDN - REAL*8 FACTOR, TAUCUMIN(L_LEVELS), TAUCUM(L_LEVELS) - - integer NAYER, L, K - real*8 ubar0, f0pi, rsf, btop, bsurf, g4, denom, am, ap - real*8 taumax, taumid, cpmid, cmmid - real*8 diffv - -C======================================================================C - - - - - NAYER = L_NLAYRAD - TAUMAX = L_TAUMAX !Default is 35.0 - -! Delta-Eddington Scaling - - - FACTOR = 1.0D0 - WDEL(1)*CDEL(1)**2 - - TAU(1) = TDEL(1)*FACTOR - TAUCUM(1) = 0.0D0 - TAUCUM(2) = TAUCUMIN(2)*FACTOR - TAUCUM(3) = TAUCUM(2) +(TAUCUMIN(3)-TAUCUMIN(2))*FACTOR - - - DO L=1,L_NLAYRAD-1 - FACTOR = 1.0D0 - WDEL(L)*CDEL(L)**2 - W0(L) = WDEL(L)*(1.0D0-CDEL(L)**2)/FACTOR - COSBAR(L) = CDEL(L)/(1.0D0+CDEL(L)) - - DTAU(L) = DTDEL(L)*FACTOR - TAU(L+1) = TAU(L)+DTAU(L) - K = 2*(L+1) - TAUCUM(K) = TAU(L+1) - TAUCUM(K+1) = TAUCUM(K) + (TAUCUMIN(K+1)-TAUCUMIN(K))*FACTOR - END DO - -! Bottom layer - - L = L_NLAYRAD - FACTOR = 1.0D0 - WDEL(L)*CDEL(L)**2 - W0(L) = WDEL(L)*(1.0D0-CDEL(L)**2)/FACTOR - COSBAR(L) = CDEL(L)/(1.0D0+CDEL(L)) - DTAU(L) = DTDEL(L)*FACTOR - TAU(L+1) = TAU(L)+DTAU(L) - TAUCUM(2*L+1) = TAU(L+1) - - BSURF = RSF*UBAR0*F0PI*EXP(-MIN(TAU(L+1),TAUMAX)/UBAR0) - ! new definition of BSURF - ! the old one was false because it used tau, not tau' - ! tau' includes the contribution to the downward flux - ! of the radiation scattered in the forward direction - -C WE GO WITH THE QUADRATURE APPROACH HERE. THE "SQRT(3)" factors -C ARE THE UBARV TERM. - - DO L=1,L_NLAYRAD - - ALPHA(L)=SQRT( (1.0-W0(L))/(1.0-W0(L)*COSBAR(L) ) ) - -C SET OF CONSTANTS DETERMINED BY DOM - -! Quadrature method - G1(L) = (SQRT(3.0)*0.5)*(2.0- W0(L)*(1.0+COSBAR(L))) - G2(L) = (SQRT(3.0)*W0(L)*0.5)*(1.0-COSBAR(L)) - G3(L) = 0.5*(1.0-SQRT(3.0)*COSBAR(L)*UBAR0) - -! ----- some other methods... (RDW) ------ - -! Eddington method -! G1(L) = 0.25*(7.0 - W0(L)*(4.0 - 3.0*COSBAR(L))) -! G2(L) = -0.25*(1.0 - W0(L)*(4.0 - 3.0*COSBAR(L))) -! G3(L) = 0.25*(2.0 - 3.0*COSBAR(L)*UBAR0) - -! delta-Eddington method -! G1(L) = (7.0 - 3.0*g^2 - W0(L)*(4.0 + 3.0*g) + W0(L)*g^2*(4*beta0 + 3*g)) / & -! (4* (1 - g^2*() )) 0.25*(7.0 - W0(L)*(4.0 - 3.0*COSBAR(L))) - -! Hybrid modified Eddington-delta function method - -! ---------------------------------------- - -c So they use Quadrature -c but the scaling is Eddington? - - LAMDA(L) = SQRT(G1(L)**2 - G2(L)**2) - GAMA(L) = (G1(L)-LAMDA(L))/G2(L) - END DO - - - DO L=1,L_NLAYRAD - G4 = 1.0-G3(L) - DENOM = LAMDA(L)**2 - 1./UBAR0**2 - -C THERE IS A POTENTIAL PROBLEM HERE IF W0=0 AND UBARV=UBAR0 -C THEN DENOM WILL VANISH. THIS ONLY HAPPENS PHYSICALLY WHEN -C THE SCATTERING GOES TO ZERO -C PREVENT THIS WITH AN IF STATEMENT - - IF ( DENOM .EQ. 0.) THEN - DENOM=1.E-10 - END IF - - - AM = F0PI*W0(L)*(G4 *(G1(L)+1./UBAR0) +G2(L)*G3(L) )/DENOM - AP = F0PI*W0(L)*(G3(L)*(G1(L)-1./UBAR0) +G2(L)*G4 )/DENOM - -C CPM1 AND CMM1 ARE THE CPLUS AND CMINUS TERMS EVALUATED -C AT THE TOP OF THE LAYER, THAT IS LOWER OPTICAL DEPTH TAU(L) - - CPM1(L) = AP*EXP(-TAU(L)/UBAR0) - CMM1(L) = AM*EXP(-TAU(L)/UBAR0) - -C CP AND CM ARE THE CPLUS AND CMINUS TERMS EVALUATED AT THE -C BOTTOM OF THE LAYER. THAT IS AT HIGHER OPTICAL DEPTH TAU(L+1) - - CP(L) = AP*EXP(-TAU(L+1)/UBAR0) - CM(L) = AM*EXP(-TAU(L+1)/UBAR0) - - END DO - - - -C NOW CALCULATE THE EXPONENTIAL TERMS NEEDED -C FOR THE TRIDIAGONAL ROTATED LAYERED METHOD - - DO L=1,L_NLAYRAD - EXPTRM = MIN(TAUMAX,LAMDA(L)*DTAU(L)) ! CLIPPED EXPONENTIAL - EP = EXP(EXPTRM) - - EM = 1.0/EP - E1(L) = EP+GAMA(L)*EM - E2(L) = EP-GAMA(L)*EM - E3(L) = GAMA(L)*EP+EM - E4(L) = GAMA(L)*EP-EM - END DO - - CALL DSOLVER(NAYER,GAMA,CP,CM,CPM1,CMM1,E1,E2,E3,E4,BTOP, - * BSURF,RSF,XK1,XK2) - -C NOW WE CALCULATE THE FLUXES AT THE MIDPOINTS OF THE LAYERS. - - DO L=1,L_NLAYRAD-1 - EXPTRM = MIN(TAUMAX,LAMDA(L)*(TAUCUM(2*L+1)-TAUCUM(2*L))) - - EP = EXP(EXPTRM) - - EM = 1.0/EP - G4 = 1.0-G3(L) - DENOM = LAMDA(L)**2 - 1./UBAR0**2 - -C THERE IS A POTENTIAL PROBLEM HERE IF W0=0 AND UBARV=UBAR0 -C THEN DENOM WILL VANISH. THIS ONLY HAPPENS PHYSICALLY WHEN -C THE SCATTERING GOES TO ZERO -C PREVENT THIS WITH A IF STATEMENT - - - IF ( DENOM .EQ. 0.) THEN - DENOM=1.E-10 - END IF - - AM = F0PI*W0(L)*(G4 *(G1(L)+1./UBAR0) +G2(L)*G3(L) )/DENOM - AP = F0PI*W0(L)*(G3(L)*(G1(L)-1./UBAR0) +G2(L)*G4 )/DENOM - -C CPMID AND CMMID ARE THE CPLUS AND CMINUS TERMS EVALUATED -C AT THE MIDDLE OF THE LAYER. - - TAUMID = TAUCUM(2*L+1) - - CPMID = AP*EXP(-TAUMID/UBAR0) - CMMID = AM*EXP(-TAUMID/UBAR0) - - FMIDP(L) = XK1(L)*EP + GAMA(L)*XK2(L)*EM + CPMID - FMIDM(L) = XK1(L)*EP*GAMA(L) + XK2(L)*EM + CMMID - -C ADD THE DIRECT FLUX TO THE DOWNWELLING TERM - - FMIDM(L)= FMIDM(L)+UBAR0*F0PI*EXP(-MIN(TAUMID,TAUMAX)/UBAR0) - - END DO - -C FLUX AT THE Ptop layer - -! EP = 1.0 -! EM = 1.0 -C JL18 correction to account for the fact that the radiative top is not at zero optical depth. - EXPTRM = MIN(TAUMAX,LAMDA(L)*(TAUCUM(2))) - EP = EXP(EXPTRM) - EM = 1.0/EP - G4 = 1.0-G3(1) - DENOM = LAMDA(1)**2 - 1./UBAR0**2 - -C THERE IS A POTENTIAL PROBLEM HERE IF W0=0 AND UBARV=UBAR0 -C THEN DENOM WILL VANISH. THIS ONLY HAPPENS PHYSICALLY WHEN -C THE SCATTERING GOES TO ZERO -C PREVENT THIS WITH A IF STATEMENT - - IF ( DENOM .EQ. 0.) THEN - DENOM=1.E-10 - END IF - - AM = F0PI*W0(1)*(G4 *(G1(1)+1./UBAR0) +G2(1)*G3(1) )/DENOM - AP = F0PI*W0(1)*(G3(1)*(G1(1)-1./UBAR0) +G2(1)*G4 )/DENOM - -C CPMID AND CMMID ARE THE CPLUS AND CMINUS TERMS EVALUATED -C AT THE MIDDLE OF THE LAYER. - -C CPMID = AP -C CMMID = AM -C JL18 correction to account for the fact that the radiative top is not at zero optical depth. - TAUMID = TAUCUM(2) - CPMID = AP*EXP(-TAUMID/UBAR0) - CMMID = AM*EXP(-TAUMID/UBAR0) - - FLUXUP = XK1(1)*EP + GAMA(1)*XK2(1)*EM + CPMID - FLUXDN = XK1(1)*EP*GAMA(1) + XK2(1)*EM + CMMID - -C ADD THE DIRECT FLUX TO THE DOWNWELLING TERM - -! fluxdn = fluxdn+UBAR0*F0PI*EXP(-MIN(TAUCUM(1),TAUMAX)/UBAR0) -!JL18 the line above assumed that the top of the radiative model was P=0 -! it seems to be better for the IR to use the middle of the last physical layer as the radiative top. -! so we correct the downwelling flux below for the calculation of the heating rate - fluxdn = fluxdn+UBAR0*F0PI*EXP(-TAUCUM(2)/UBAR0) - -C This is for the "special" bottom layer, where we take -C DTAU instead of DTAU/2. - - L = L_NLAYRAD - EXPTRM = MIN(TAUMAX,LAMDA(L)*(TAUCUM(L_LEVELS)- - * TAUCUM(L_LEVELS-1))) - - EP = EXP(EXPTRM) - EM = 1.0/EP - G4 = 1.0-G3(L) - DENOM = LAMDA(L)**2 - 1./UBAR0**2 - - -C THERE IS A POTENTIAL PROBLEM HERE IF W0=0 AND UBARV=UBAR0 -C THEN DENOM WILL VANISH. THIS ONLY HAPPENS PHYSICALLY WHEN -C THE SCATTERING GOES TO ZERO -C PREVENT THIS WITH A IF STATEMENT - - - IF ( DENOM .EQ. 0.) THEN - DENOM=1.E-10 - END IF - - AM = F0PI*W0(L)*(G4 *(G1(L)+1./UBAR0) +G2(L)*G3(L) )/DENOM - AP = F0PI*W0(L)*(G3(L)*(G1(L)-1./UBAR0) +G2(L)*G4 )/DENOM - -C CPMID AND CMMID ARE THE CPLUS AND CMINUS TERMS EVALUATED -C AT THE MIDDLE OF THE LAYER. - - TAUMID = MIN(TAUCUM(L_LEVELS),TAUMAX) - CPMID = AP*EXP(-MIN(TAUMID,TAUMAX)/UBAR0) - CMMID = AM*EXP(-MIN(TAUMID,TAUMAX)/UBAR0) - - - FMIDP(L) = XK1(L)*EP + GAMA(L)*XK2(L)*EM + CPMID - FMIDM(L) = XK1(L)*EP*GAMA(L) + XK2(L)*EM + CMMID - -C Save the diffuse downward flux for TEMPGR calculations - - DIFFV = FMIDM(L) - - -C ADD THE DIRECT FLUX TO THE DOWNWELLING TERM - - FMIDM(L)= FMIDM(L)+UBAR0*F0PI*EXP(-MIN(TAUMID,TAUMAX)/UBAR0) - - - END SUBROUTINE GFLUXV - - end module gfluxv_mod Index: trunk/LMDZ.GENERIC/libf/phygeneric/inifis_mod.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/inifis_mod.F90 (revision 4062) +++ trunk/LMDZ.GENERIC/libf/phygeneric/inifis_mod.F90 (revision 4077) @@ -12,5 +12,5 @@ use radinc_h, only: ini_radinc_h, naerkind use radcommon_h, only: ini_radcommon_h - use radii_mod, only: radfixed, Nmix_co2 + use aerosol_radius, only: radfixed, Nmix_co2 use datafile_mod, only: datadir use comdiurn_h, only: sinlat, coslat, sinlon, coslon @@ -27,5 +27,5 @@ use ioipsl_getin_p_mod, only : getin_p use mod_phys_lmdz_para, only : is_parallel, is_master, bcast - use newton_cooling_hotJ, only: planetary_suffix + use rad_netwon_cooling_hot_jupiter, only: planetary_suffix !======================================================================= @@ -80,5 +80,5 @@ CHARACTER(len=20) :: rname="inifis" ! routine name, for messages - EXTERNAL iniorbit,orbite + EXTERNAL ephemeris_orbit_init,ephemeris_orbit EXTERNAL SSUM REAL SSUM Index: trunk/LMDZ.GENERIC/libf/phygeneric/iniorbit.F =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/iniorbit.F (revision 4062) +++ (revision ) @@ -1,74 +1,0 @@ - SUBROUTINE iniorbit - $ (papoastr,pperiastr,pyear_day,pperi_day,pobliq) - - USE planete_mod, only: apoastr, periastr, year_day, obliquit, - & peri_day, e_elips, p_elips, timeperi - use comcstfi_mod, only: pi - IMPLICIT NONE - -!======================================================================= -! Initialisation of orbital parameters (stored in planete_h module) -!======================================================================= - -c Arguments: -c ---------- - - REAL,INTENT(IN) :: papoastr,pperiastr,pyear_day,pperi_day,pobliq - -c Local: -c ------ - - REAL zxref,zanom,zz,zx0,zdx - INTEGER iter - -c----------------------------------------------------------------------- - - pi=2.*asin(1.) - - apoastr =papoastr - periastr=pperiastr - year_day=pyear_day - obliquit=pobliq - peri_day=pperi_day - - PRINT*,'iniorbit: Periastron in AU ',periastr - PRINT*,'iniorbit: Apoastron in AU ',apoastr - PRINT*,'iniorbit: Obliquity in degrees :',obliquit - - - e_elips=(apoastr-periastr)/(periastr+apoastr) - p_elips=0.5*(periastr+apoastr)*(1-e_elips*e_elips) - - print*,'iniorbit: e_elips',e_elips - print*,'iniorbit: p_elips',p_elips - -!----------------------------------------------------------------------- -! compute polar angle and distance to the Sun: -! ------------------------------------------------------- - -! compute mean anomaly zanom - - zz=(year_day-pperi_day)/year_day - zanom=2.*pi*(zz-nint(zz)) - zxref=abs(zanom) - PRINT*,'iniorbit: zanom ',zanom - -! solve equation zx0 - e * sin (zx0) = zxref for eccentric anomaly zx0 -! using Newton method - - zx0=zxref+e_elips*sin(zxref) - DO iter=1,100 - zdx=-(zx0-e_elips*sin(zx0)-zxref)/(1.-e_elips*cos(zx0)) - if(abs(zdx).le.(1.e-12)) exit - zx0=zx0+zdx - ENDDO - - zx0=zx0+zdx - if(zanom.lt.0.) zx0=-zx0 - PRINT*,'iniorbit: zx0 ',zx0 - - timeperi=2.*atan(sqrt((1.+e_elips)/(1.-e_elips))*tan(zx0/2.)) - PRINT*,'iniorbit: Perihelion solar long. Ls (deg)=', - & 360.-timeperi*180./pi - - END Index: trunk/LMDZ.GENERIC/libf/phygeneric/initracer.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/initracer.F90 (revision 4062) +++ trunk/LMDZ.GENERIC/libf/phygeneric/initracer.F90 (revision 4077) @@ -4,5 +4,5 @@ USE tracer_h USE callkeys_mod, only: water - USE recombin_corrk_mod, ONLY: ini_recombin + USE rad_correlatedk_online_recombination_mod, ONLY: rad_correlatedk_recombination_init USE mod_phys_lmdz_para, only: is_master, bcast use generic_cloud_common_h @@ -503,5 +503,5 @@ ! Processing modern traceur options if(moderntracdef) then - call ini_recombin + call rad_correlatedk_recombination_init endif Index: trunk/LMDZ.GENERIC/libf/phygeneric/interpolate_continuum.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/interpolate_continuum.F90 (revision 4062) +++ (revision ) @@ -1,838 +1,0 @@ -module interpolate_continuum_mod - -implicit none - -contains - - subroutine interpolate_continuum(filename,igas_X,igas_Y,c_WN,ind_WN,temp,pres_X,pres_Y,abs_coef,firstcall) - -!================================================================== -! -! Purpose -! ------- -! Generic routine to calculate continuum opacities, using lookup tables provided here: https://web.lmd.jussieu.fr/~lmdz/planets/generic/datagcm/continuum_data/ -! More information on the data here: https://lmdz-forge.lmd.jussieu.fr/mediawiki/Planets/index.php/Continuum_Database -! -! Author -! ------- -! M. Turbet (2025) -! -!================================================================== - - use datafile_mod, only: datadir - use mod_phys_lmdz_para, only : is_master - - use gases_h, only: ngasmx, gnom, & - igas_H2, igas_H2O, igas_He, igas_N2, & - igas_CH4, igas_CO2, igas_O2 - - use radinc_h, only: L_NSPECTI, L_NSPECTV - - use radcommon_h, only : BWNV,BWNI,WNOI,WNOV - - - implicit none - - ! input - integer,intent(in) :: ind_WN ! wavenumber index - integer,intent(in) :: igas_X ! index of molecule X - integer,intent(in) :: igas_Y ! index of molecule Y - double precision,intent(in) :: temp ! temperature (Kelvin) - double precision,intent(in) :: pres_X ! partial pressure of molecule X (Pascals) - double precision,intent(in) :: pres_Y ! partial pressure of molecule Y (Pascals) - character(len=*),intent(in) :: filename ! name of the lookup table - character(len=2),intent(in) :: c_WN ! wavelength chanel: infrared (IR) or visible (VI) - logical,intent(in) :: firstcall - - ! output - double precision,intent(out) :: abs_coef ! absorption coefficient (m^-1) - - ! intermediate variables - double precision amagat_X ! density of molecule X (in amagat units) - double precision amagat_Y ! density of molecule Y (in amagat units) - - character(len=512) :: line - character(len=21),parameter :: rname="interpolate_continuum" - - integer i, pos, iT, iW, iB, count_norm, igas - - double precision temp_value, temp_abs, temp_wn - - double precision z_temp - - integer num_wn, num_T - - double precision, dimension(:), allocatable :: temp_arr - double precision, dimension(:), allocatable :: wn_arr - double precision, dimension(:,:), allocatable :: abs_arr - - integer ios - - ! Temperature array, continuum absorption grid for the pair N2-N2 - integer,save :: num_T_N2N2 - double precision,save,dimension(:),allocatable :: temp_arr_N2N2 - double precision,save,dimension(:,:),allocatable :: abs_arr_N2N2_IR - double precision,save,dimension(:,:),allocatable :: abs_arr_N2N2_VI -! None of these saved variables are THREADPRIVATE because read by master -! and then only accessed but never modified and thus can be shared - - ! Temperature array, continuum absorption grid for the pair O2-O2 - integer,save :: num_T_O2O2 - double precision,save,dimension(:),allocatable :: temp_arr_O2O2 - double precision,save,dimension(:,:),allocatable :: abs_arr_O2O2_IR - double precision,save,dimension(:,:),allocatable :: abs_arr_O2O2_VI -! None of these saved variables are THREADPRIVATE because read by master -! and then only accessed but never modified and thus can be shared - - ! Temperature array, continuum absorption grid for the pair H2-H2 - integer,save :: num_T_H2H2 - double precision,save,dimension(:),allocatable :: temp_arr_H2H2 - double precision,save,dimension(:,:),allocatable :: abs_arr_H2H2_IR - double precision,save,dimension(:,:),allocatable :: abs_arr_H2H2_VI -! None of these saved variables are THREADPRIVATE because read by master -! and then only accessed but never modified and thus can be shared - - ! Temperature array, continuum absorption grid for the pair CO2-CO2 - integer,save :: num_T_CO2CO2 - double precision,save,dimension(:),allocatable :: temp_arr_CO2CO2 - double precision,save,dimension(:,:),allocatable :: abs_arr_CO2CO2_IR - double precision,save,dimension(:,:),allocatable :: abs_arr_CO2CO2_VI -! None of these saved variables are THREADPRIVATE because read by master -! and then only accessed but never modified and thus can be shared - - ! Temperature array, continuum absorption grid for the pair CH4-CH4 - integer,save :: num_T_CH4CH4 - double precision,save,dimension(:),allocatable :: temp_arr_CH4CH4 - double precision,save,dimension(:,:),allocatable :: abs_arr_CH4CH4_IR - double precision,save,dimension(:,:),allocatable :: abs_arr_CH4CH4_VI -! None of these saved variables are THREADPRIVATE because read by master -! and then only accessed but never modified and thus can be shared - - ! Temperature array, continuum absorption grid for the pair H2O-H2O - integer,save :: num_T_H2OH2O - double precision,save,dimension(:),allocatable :: temp_arr_H2OH2O - double precision,save,dimension(:,:),allocatable :: abs_arr_H2OH2O_IR - double precision,save,dimension(:,:),allocatable :: abs_arr_H2OH2O_VI -! None of these saved variables are THREADPRIVATE because read by master -! and then only accessed but never modified and thus can be shared - - ! Temperature array, continuum absorption grid for the pair H2-He - integer,save :: num_T_H2He - double precision,save,dimension(:),allocatable :: temp_arr_H2He - double precision,save,dimension(:,:),allocatable :: abs_arr_H2He_IR - double precision,save,dimension(:,:),allocatable :: abs_arr_H2He_VI -! None of these saved variables are THREADPRIVATE because read by master -! and then only accessed but never modified and thus can be shared - - ! Temperature array, continuum absorption grid for the pair H2-CH4 - integer,save :: num_T_H2CH4 - double precision,save,dimension(:),allocatable :: temp_arr_H2CH4 - double precision,save,dimension(:,:),allocatable :: abs_arr_H2CH4_IR - double precision,save,dimension(:,:),allocatable :: abs_arr_H2CH4_VI -! None of these saved variables are THREADPRIVATE because read by master -! and then only accessed but never modified and thus can be shared - - ! Temperature array, continuum absorption grid for the pair CO2-H2 - integer,save :: num_T_CO2H2 - double precision,save,dimension(:),allocatable :: temp_arr_CO2H2 - double precision,save,dimension(:,:),allocatable :: abs_arr_CO2H2_IR - double precision,save,dimension(:,:),allocatable :: abs_arr_CO2H2_VI -! None of these saved variables are THREADPRIVATE because read by master -! and then only accessed but never modified and thus can be shared - - ! Temperature array, continuum absorption grid for the pair CO2-CH4 - integer,save :: num_T_CO2CH4 - double precision,save,dimension(:),allocatable :: temp_arr_CO2CH4 - double precision,save,dimension(:,:),allocatable :: abs_arr_CO2CH4_IR - double precision,save,dimension(:,:),allocatable :: abs_arr_CO2CH4_VI -! None of these saved variables are THREADPRIVATE because read by master -! and then only accessed but never modified and thus can be shared - - ! Temperature array, continuum absorption grid for the pair N2-H2 - integer,save :: num_T_N2H2 - double precision,save,dimension(:),allocatable :: temp_arr_N2H2 - double precision,save,dimension(:,:),allocatable :: abs_arr_N2H2_IR - double precision,save,dimension(:,:),allocatable :: abs_arr_N2H2_VI -! None of these saved variables are THREADPRIVATE because read by master -! and then only accessed but never modified and thus can be shared - - ! Temperature array, continuum absorption grid for the pair N2-CH4 - integer,save :: num_T_N2CH4 - double precision,save,dimension(:),allocatable :: temp_arr_N2CH4 - double precision,save,dimension(:,:),allocatable :: abs_arr_N2CH4_IR - double precision,save,dimension(:,:),allocatable :: abs_arr_N2CH4_VI -! None of these saved variables are THREADPRIVATE because read by master -! and then only accessed but never modified and thus can be shared - - ! Temperature array, continuum absorption grid for the pair CO2-O2 - integer,save :: num_T_CO2O2 - double precision,save,dimension(:),allocatable :: temp_arr_CO2O2 - double precision,save,dimension(:,:),allocatable :: abs_arr_CO2O2_IR - double precision,save,dimension(:,:),allocatable :: abs_arr_CO2O2_VI -! None of these saved variables are THREADPRIVATE because read by master -! and then only accessed but never modified and thus can be shared - - ! Temperature array, continuum absorption grid for the pair N2-O2 - integer,save :: num_T_N2O2 - double precision,save,dimension(:), allocatable :: temp_arr_N2O2 - double precision,save,dimension(:,:), allocatable :: abs_arr_N2O2_IR - double precision,save,dimension(:,:), allocatable :: abs_arr_N2O2_VI -! None of these saved variables are THREADPRIVATE because read by master -! and then only accessed but never modified and thus can be shared - - ! Temperature array, continuum absorption grid for the pair H2O-N2 - integer,save :: num_T_H2ON2 - double precision,save,dimension(:),allocatable :: temp_arr_H2ON2 - double precision,save,dimension(:,:),allocatable :: abs_arr_H2ON2_IR - double precision,save,dimension(:,:),allocatable :: abs_arr_H2ON2_VI -! None of these saved variables are THREADPRIVATE because read by master -! and then only accessed but never modified and thus can be shared - - ! Temperature array, continuum absorption grid for the pair H2O-O2 - integer,save :: num_T_H2OO2 - double precision,save,dimension(:),allocatable :: temp_arr_H2OO2 - double precision,save,dimension(:,:),allocatable :: abs_arr_H2OO2_IR - double precision,save,dimension(:,:),allocatable :: abs_arr_H2OO2_VI -! None of these saved variables are THREADPRIVATE because read by master -! and then only accessed but never modified and thus can be shared - - ! Temperature array, continuum absorption grid for the pair H2O-CO2 - integer,save :: num_T_H2OCO2 - double precision,save,dimension(:),allocatable :: temp_arr_H2OCO2 - double precision,save,dimension(:,:),allocatable :: abs_arr_H2OCO2_IR - double precision,save,dimension(:,:),allocatable :: abs_arr_H2OCO2_VI -! None of these saved variables are THREADPRIVATE because read by master -! and then only accessed but never modified and thus can be shared - - - if(firstcall)then ! called by sugas_corrk only - if (is_master) print*,'----------------------------------------------------' - if (is_master) print*,'Initialising continuum (interpolate_continuum routine) from ', trim(filename) - -!$OMP MASTER - - open(unit=33, file=trim(filename), status="old", action="read",iostat=ios) - - if (ios.ne.0) then ! file not found - if (is_master) then - write(*,*) 'Error from interpolate_continuum routine' - write(*,*) 'Data file ',trim(filename),' not found.' - write(*,*) 'Check that your path to datagcm:',trim(datadir) - write(*,*) 'is correct. You can change it in callphys.def with:' - write(*,*) 'datadir = /absolute/path/to/datagcm' - write(*,*) 'Also check that the continuum data is there.' - write(*,*) 'Latest continuum data can be downloaded here:' - write(*,*) 'https://web.lmd.jussieu.fr/~lmdz/planets/generic/datagcm/continuum_data/' - endif - call abort_physic(rname,"missing input file",1) - endif - - ! We read the first line of the file to get the number of temperatures provided in the data file - read(33, '(A)') line - - i = 1 - iT = 0 - - do while (i .lt. len_trim(line)) - pos = index(line(i:), 'T=') - if (pos == 0) exit - i = i + pos - iT = iT + 1 - read(line(i+2:i+10), '(E9.2)') temp_value - end do - - num_T=iT ! num_T is the number of temperatures provided in the data file - - ! We read all the remaining lines of the file to get the number of wavenumbers provided in the data file - iW = 0 - do - read(33,*, end=501) line - iW = iW + 1 - end do - -501 continue - - num_wn=iW ! num_wn is the number of wavenumbers provided in the data file - - close(33) - - allocate(temp_arr(num_T)) - allocate(wn_arr(num_wn)) - allocate(abs_arr(num_wn,num_T)) - - ! We now open and read the file a second time to extract the temperature array, wavenumber array and continuum absorption data - - open(unit=33, file=trim(filename), status="old", action="read") - - ! We extract the temperature array (temp_arr) - - read(33, '(A)') line - - i = 1 - iT = 0 - - do while (i .lt. len_trim(line)) - pos = index(line(i:), 'T=') - if (pos == 0) exit - i = i + pos - iT = iT + 1 - read(line(i+2:i+10), '(E9.2)') temp_arr(iT) - end do - - ! We extract the wavenumber array (wn_arr) and continuum absorption (abs_arr) - - do iW=1,num_wn - read(33,*) wn_arr(iW), (abs_arr(iW, iT), iT=1,num_T) - end do - - close(33) - - print*,'We read continuum absorption data for the pair ', trim(gnom(igas_X)),'-',trim(gnom(igas_Y)) - print*,'Temperature grid of the dataset: ', temp_arr(:) - - ! We loop on all molecular pairs with available continuum data and fill the corresponding array - - if ((igas_X .eq. igas_CO2) .and. (igas_Y .eq. igas_CO2)) then - num_T_CO2CO2=num_T - allocate(temp_arr_CO2CO2(num_T_CO2CO2)) - allocate(abs_arr_CO2CO2_VI(L_NSPECTV,num_T_CO2CO2)) - allocate(abs_arr_CO2CO2_IR(L_NSPECTI,num_T_CO2CO2)) - temp_arr_CO2CO2(:)=temp_arr(:) - abs_arr_CO2CO2_VI(:,:)=0. - abs_arr_CO2CO2_IR(:,:)=0. - call interpolate_wn_abs_coeff(wn_arr,num_wn,abs_arr,abs_arr_CO2CO2_VI,abs_arr_CO2CO2_IR,num_T_CO2CO2) - elseif ((igas_X .eq. igas_N2) .and. (igas_Y .eq. igas_N2)) then - num_T_N2N2=num_T - allocate(temp_arr_N2N2(num_T_N2N2)) - allocate(abs_arr_N2N2_VI(L_NSPECTV,num_T_N2N2)) - allocate(abs_arr_N2N2_IR(L_NSPECTI,num_T_N2N2)) - temp_arr_N2N2(:)=temp_arr(:) - abs_arr_N2N2_VI(:,:)=0. - abs_arr_N2N2_IR(:,:)=0. - call interpolate_wn_abs_coeff(wn_arr,num_wn,abs_arr,abs_arr_N2N2_VI,abs_arr_N2N2_IR,num_T_N2N2) - elseif ((igas_X .eq. igas_O2) .and. (igas_Y .eq. igas_O2)) then - num_T_O2O2=num_T - allocate(temp_arr_O2O2(num_T_O2O2)) - allocate(abs_arr_O2O2_VI(L_NSPECTV,num_T_O2O2)) - allocate(abs_arr_O2O2_IR(L_NSPECTI,num_T_O2O2)) - temp_arr_O2O2(:)=temp_arr(:) - abs_arr_O2O2_VI(:,:)=0. - abs_arr_O2O2_IR(:,:)=0. - call interpolate_wn_abs_coeff(wn_arr,num_wn,abs_arr,abs_arr_O2O2_VI,abs_arr_O2O2_IR,num_T_O2O2) - elseif ((igas_X .eq. igas_CH4) .and. (igas_Y .eq. igas_CH4)) then - num_T_CH4CH4=num_T - allocate(temp_arr_CH4CH4(num_T_CH4CH4)) - allocate(abs_arr_CH4CH4_VI(L_NSPECTV,num_T_CH4CH4)) - allocate(abs_arr_CH4CH4_IR(L_NSPECTI,num_T_CH4CH4)) - temp_arr_CH4CH4(:)=temp_arr(:) - abs_arr_CH4CH4_VI(:,:)=0. - abs_arr_CH4CH4_IR(:,:)=0. - call interpolate_wn_abs_coeff(wn_arr,num_wn,abs_arr,abs_arr_CH4CH4_VI,abs_arr_CH4CH4_IR,num_T_CH4CH4) - elseif ((igas_X .eq. igas_H2) .and. (igas_Y .eq. igas_H2)) then - num_T_H2H2=num_T - allocate(temp_arr_H2H2(num_T_H2H2)) - allocate(abs_arr_H2H2_VI(L_NSPECTV,num_T_H2H2)) - allocate(abs_arr_H2H2_IR(L_NSPECTI,num_T_H2H2)) - temp_arr_H2H2(:)=temp_arr(:) - abs_arr_H2H2_VI(:,:)=0. - abs_arr_H2H2_IR(:,:)=0. - call interpolate_wn_abs_coeff(wn_arr,num_wn,abs_arr,abs_arr_H2H2_VI,abs_arr_H2H2_IR,num_T_H2H2) - elseif ((igas_X .eq. igas_H2O) .and. (igas_Y .eq. igas_H2O)) then - num_T_H2OH2O=num_T - allocate(temp_arr_H2OH2O(num_T_H2OH2O)) - allocate(abs_arr_H2OH2O_VI(L_NSPECTV,num_T_H2OH2O)) - allocate(abs_arr_H2OH2O_IR(L_NSPECTI,num_T_H2OH2O)) - temp_arr_H2OH2O(:)=temp_arr(:) - abs_arr_H2OH2O_VI(:,:)=0. - abs_arr_H2OH2O_IR(:,:)=0. - call interpolate_wn_abs_coeff(wn_arr,num_wn,abs_arr,abs_arr_H2OH2O_VI,abs_arr_H2OH2O_IR,num_T_H2OH2O) - elseif ((igas_X .eq. igas_N2) .and. (igas_Y .eq. igas_H2)) then - num_T_N2H2=num_T - allocate(temp_arr_N2H2(num_T_N2H2)) - allocate(abs_arr_N2H2_VI(L_NSPECTV,num_T_N2H2)) - allocate(abs_arr_N2H2_IR(L_NSPECTI,num_T_N2H2)) - temp_arr_N2H2(:)=temp_arr(:) - abs_arr_N2H2_VI(:,:)=0. - abs_arr_N2H2_IR(:,:)=0. - call interpolate_wn_abs_coeff(wn_arr,num_wn,abs_arr,abs_arr_N2H2_VI,abs_arr_N2H2_IR,num_T_N2H2) - elseif ((igas_X .eq. igas_N2) .and. (igas_Y .eq. igas_O2)) then - num_T_N2O2=num_T - allocate(temp_arr_N2O2(num_T_N2O2)) - allocate(abs_arr_N2O2_VI(L_NSPECTV,num_T_N2O2)) - allocate(abs_arr_N2O2_IR(L_NSPECTI,num_T_N2O2)) - temp_arr_N2O2(:)=temp_arr(:) - abs_arr_N2O2_VI(:,:)=0. - abs_arr_N2O2_IR(:,:)=0. - call interpolate_wn_abs_coeff(wn_arr,num_wn,abs_arr,abs_arr_N2O2_VI,abs_arr_N2O2_IR,num_T_N2O2) - elseif ((igas_X .eq. igas_N2) .and. (igas_Y .eq. igas_CH4)) then - num_T_N2CH4=num_T - allocate(temp_arr_N2CH4(num_T_N2CH4)) - allocate(abs_arr_N2CH4_VI(L_NSPECTV,num_T_N2CH4)) - allocate(abs_arr_N2CH4_IR(L_NSPECTI,num_T_N2CH4)) - temp_arr_N2CH4(:)=temp_arr(:) - abs_arr_N2CH4_VI(:,:)=0. - abs_arr_N2CH4_IR(:,:)=0. - call interpolate_wn_abs_coeff(wn_arr,num_wn,abs_arr,abs_arr_N2CH4_VI,abs_arr_N2CH4_IR,num_T_N2CH4) - elseif ((igas_X .eq. igas_CO2) .and. (igas_Y .eq. igas_O2)) then - num_T_CO2O2=num_T - allocate(temp_arr_CO2O2(num_T_CO2O2)) - allocate(abs_arr_CO2O2_VI(L_NSPECTV,num_T_CO2O2)) - allocate(abs_arr_CO2O2_IR(L_NSPECTI,num_T_CO2O2)) - temp_arr_CO2O2(:)=temp_arr(:) - abs_arr_CO2O2_VI(:,:)=0. - abs_arr_CO2O2_IR(:,:)=0. - call interpolate_wn_abs_coeff(wn_arr,num_wn,abs_arr,abs_arr_CO2O2_VI,abs_arr_CO2O2_IR,num_T_CO2O2) - elseif ((igas_X .eq. igas_H2) .and. (igas_Y .eq. igas_CH4)) then - num_T_H2CH4=num_T - allocate(temp_arr_H2CH4(num_T_H2CH4)) - allocate(abs_arr_H2CH4_VI(L_NSPECTV,num_T_H2CH4)) - allocate(abs_arr_H2CH4_IR(L_NSPECTI,num_T_H2CH4)) - temp_arr_H2CH4(:)=temp_arr(:) - abs_arr_H2CH4_VI(:,:)=0. - abs_arr_H2CH4_IR(:,:)=0. - call interpolate_wn_abs_coeff(wn_arr,num_wn,abs_arr,abs_arr_H2CH4_VI,abs_arr_H2CH4_IR,num_T_H2CH4) - elseif ((igas_X .eq. igas_H2) .and. (igas_Y .eq. igas_He)) then - num_T_H2He=num_T - allocate(temp_arr_H2He(num_T_H2He)) - allocate(abs_arr_H2He_VI(L_NSPECTV,num_T_H2He)) - allocate(abs_arr_H2He_IR(L_NSPECTI,num_T_H2He)) - temp_arr_H2He(:)=temp_arr(:) - abs_arr_H2He_VI(:,:)=0. - abs_arr_H2He_IR(:,:)=0. - call interpolate_wn_abs_coeff(wn_arr,num_wn,abs_arr,abs_arr_H2He_VI,abs_arr_H2He_IR,num_T_H2He) - elseif ((igas_X .eq. igas_H2O) .and. (igas_Y .eq. igas_N2)) then - num_T_H2ON2=num_T - allocate(temp_arr_H2ON2(num_T_H2ON2)) - allocate(abs_arr_H2ON2_VI(L_NSPECTV,num_T_H2ON2)) - allocate(abs_arr_H2ON2_IR(L_NSPECTI,num_T_H2ON2)) - temp_arr_H2ON2(:)=temp_arr(:) - abs_arr_H2ON2_VI(:,:)=0. - abs_arr_H2ON2_IR(:,:)=0. - call interpolate_wn_abs_coeff(wn_arr,num_wn,abs_arr,abs_arr_H2ON2_VI,abs_arr_H2ON2_IR,num_T_H2ON2) - elseif ((igas_X .eq. igas_H2O) .and. (igas_Y .eq. igas_O2)) then - num_T_H2OO2=num_T - allocate(temp_arr_H2OO2(num_T_H2OO2)) - allocate(abs_arr_H2OO2_VI(L_NSPECTV,num_T_H2OO2)) - allocate(abs_arr_H2OO2_IR(L_NSPECTI,num_T_H2OO2)) - temp_arr_H2OO2(:)=temp_arr(:) - abs_arr_H2OO2_VI(:,:)=0. - abs_arr_H2OO2_IR(:,:)=0. - call interpolate_wn_abs_coeff(wn_arr,num_wn,abs_arr,abs_arr_H2OO2_VI,abs_arr_H2OO2_IR,num_T_H2OO2) - elseif ((igas_X .eq. igas_H2O) .and. (igas_Y .eq. igas_CO2)) then - num_T_H2OCO2=num_T - allocate(temp_arr_H2OCO2(num_T_H2OCO2)) - allocate(abs_arr_H2OCO2_VI(L_NSPECTV,num_T_H2OCO2)) - allocate(abs_arr_H2OCO2_IR(L_NSPECTI,num_T_H2OCO2)) - temp_arr_H2OCO2(:)=temp_arr(:) - abs_arr_H2OCO2_VI(:,:)=0. - abs_arr_H2OCO2_IR(:,:)=0. - call interpolate_wn_abs_coeff(wn_arr,num_wn,abs_arr,abs_arr_H2OCO2_VI,abs_arr_H2OCO2_IR,num_T_H2OCO2) - elseif ((igas_X .eq. igas_CO2) .and. (igas_Y .eq. igas_CO2)) then - num_T_CO2CO2=num_T - allocate(temp_arr_CO2CO2(num_T_CO2CO2)) - allocate(abs_arr_CO2CO2_VI(L_NSPECTV,num_T_CO2CO2)) - allocate(abs_arr_CO2CO2_IR(L_NSPECTI,num_T_CO2CO2)) - temp_arr_CO2CO2(:)=temp_arr(:) - abs_arr_CO2CO2_VI(:,:)=0. - abs_arr_CO2CO2_IR(:,:)=0. - call interpolate_wn_abs_coeff(wn_arr,num_wn,abs_arr,abs_arr_CO2CO2_VI,abs_arr_CO2CO2_IR,num_T_CO2CO2) - elseif ((igas_X .eq. igas_CO2) .and. (igas_Y .eq. igas_H2)) then - num_T_CO2H2=num_T - allocate(temp_arr_CO2H2(num_T_CO2H2)) - allocate(abs_arr_CO2H2_VI(L_NSPECTV,num_T_CO2H2)) - allocate(abs_arr_CO2H2_IR(L_NSPECTI,num_T_CO2H2)) - temp_arr_CO2H2(:)=temp_arr(:) - abs_arr_CO2H2_VI(:,:)=0. - abs_arr_CO2H2_IR(:,:)=0. - call interpolate_wn_abs_coeff(wn_arr,num_wn,abs_arr,abs_arr_CO2H2_VI,abs_arr_CO2H2_IR,num_T_CO2H2) - elseif ((igas_X .eq. igas_CO2) .and. (igas_Y .eq. igas_CH4)) then - num_T_CO2CH4=num_T - allocate(temp_arr_CO2CH4(num_T_CO2CH4)) - allocate(abs_arr_CO2CH4_VI(L_NSPECTV,num_T_CO2CH4)) - allocate(abs_arr_CO2CH4_IR(L_NSPECTI,num_T_CO2CH4)) - temp_arr_CO2CH4(:)=temp_arr(:) - abs_arr_CO2CH4_VI(:,:)=0. - abs_arr_CO2CH4_IR(:,:)=0. - call interpolate_wn_abs_coeff(wn_arr,num_wn,abs_arr,abs_arr_CO2CH4_VI,abs_arr_CO2CH4_IR,num_T_CO2CH4) - endif ! igas_X / igas_Y condition - - -!$OMP END MASTER -!$OMP BARRIER - - - endif ! firstcall - - ! We loop on all molecular pairs with available continuum data and interpolate in the temperature field - ! Two options: we call visible (VI) or infrared (IR) tables, depending on the value of c_WN - - if ((igas_X .eq. igas_CO2) .and. (igas_Y .eq. igas_CO2)) then - call T_boundaries_continuum(z_temp,temp,temp_arr_CO2CO2,num_T_CO2CO2) - if(c_WN .eq. 'IR') then - call interpolate_T_abs_coeff(z_temp,temp_arr_CO2CO2,num_T_CO2CO2,abs_coef,abs_arr_CO2CO2_IR(ind_WN,:)) - elseif(c_WN .eq. 'VI') then - call interpolate_T_abs_coeff(z_temp,temp_arr_CO2CO2,num_T_CO2CO2,abs_coef,abs_arr_CO2CO2_VI(ind_WN,:)) - else - print*,'You must select visible (VI) or infrared (IR) channel.' - call abort_physic(rname,"CO2CO2 bad channel",1) - endif - elseif ((igas_X .eq. igas_N2) .and. (igas_Y .eq. igas_N2)) then - call T_boundaries_continuum(z_temp,temp,temp_arr_N2N2,num_T_N2N2) - if(c_WN .eq. 'IR') then - call interpolate_T_abs_coeff(z_temp,temp_arr_N2N2,num_T_N2N2,abs_coef,abs_arr_N2N2_IR(ind_WN,:)) - elseif(c_WN .eq. 'VI') then - call interpolate_T_abs_coeff(z_temp,temp_arr_N2N2,num_T_N2N2,abs_coef,abs_arr_N2N2_VI(ind_WN,:)) - else - print*,'You must select visible (VI) or infrared (IR) channel.' - call abort_physic(rname,"N2N2 bad channel",1) - endif - elseif ((igas_X .eq. igas_O2) .and. (igas_Y .eq. igas_O2)) then - call T_boundaries_continuum(z_temp,temp,temp_arr_O2O2,num_T_O2O2) - if(c_WN .eq. 'IR') then - call interpolate_T_abs_coeff(z_temp,temp_arr_O2O2,num_T_O2O2,abs_coef,abs_arr_O2O2_IR(ind_WN,:)) - elseif(c_WN .eq. 'VI') then - call interpolate_T_abs_coeff(z_temp,temp_arr_O2O2,num_T_O2O2,abs_coef,abs_arr_O2O2_VI(ind_WN,:)) - else - print*,'You must select visible (VI) or infrared (IR) channel.' - call abort_physic(rname,"O2O2 bad channel",1) - endif - elseif ((igas_X .eq. igas_CH4) .and. (igas_Y .eq. igas_CH4)) then - call T_boundaries_continuum(z_temp,temp,temp_arr_CH4CH4,num_T_CH4CH4) - if(c_WN .eq. 'IR') then - call interpolate_T_abs_coeff(z_temp,temp_arr_CH4CH4,num_T_CH4CH4,abs_coef,abs_arr_CH4CH4_IR(ind_WN,:)) - elseif(c_WN .eq. 'VI') then - call interpolate_T_abs_coeff(z_temp,temp_arr_CH4CH4,num_T_CH4CH4,abs_coef,abs_arr_CH4CH4_VI(ind_WN,:)) - else - print*,'You must select visible (VI) or infrared (IR) channel.' - call abort_physic(rname,"CH4CH4 bad channel",1) - endif - elseif ((igas_X .eq. igas_H2) .and. (igas_Y .eq. igas_H2)) then - call T_boundaries_continuum(z_temp,temp,temp_arr_H2H2,num_T_H2H2) - if(c_WN .eq. 'IR') then - call interpolate_T_abs_coeff(z_temp,temp_arr_H2H2,num_T_H2H2,abs_coef,abs_arr_H2H2_IR(ind_WN,:)) - elseif(c_WN .eq. 'VI') then - call interpolate_T_abs_coeff(z_temp,temp_arr_H2H2,num_T_H2H2,abs_coef,abs_arr_H2H2_VI(ind_WN,:)) - else - print*,'You must select visible (VI) or infrared (IR) channel.' - call abort_physic(rname,"H2H2 bad channel",1) - endif - elseif ((igas_X .eq. igas_H2O) .and. (igas_Y .eq. igas_H2O)) then - call T_boundaries_continuum(z_temp,temp,temp_arr_H2OH2O,num_T_H2OH2O) - if(c_WN .eq. 'IR') then - call interpolate_T_abs_coeff(z_temp,temp_arr_H2OH2O,num_T_H2OH2O,abs_coef,abs_arr_H2OH2O_IR(ind_WN,:)) - elseif(c_WN .eq. 'VI') then - call interpolate_T_abs_coeff(z_temp,temp_arr_H2OH2O,num_T_H2OH2O,abs_coef,abs_arr_H2OH2O_VI(ind_WN,:)) - else - print*,'You must select visible (VI) or infrared (IR) channel.' - call abort_physic(rname,"H2OH2O bad channel",1) - endif - elseif ((igas_X .eq. igas_N2) .and. (igas_Y .eq. igas_H2)) then - call T_boundaries_continuum(z_temp,temp,temp_arr_N2H2,num_T_N2H2) - if(c_WN .eq. 'IR') then - call interpolate_T_abs_coeff(z_temp,temp_arr_N2H2,num_T_N2H2,abs_coef,abs_arr_N2H2_IR(ind_WN,:)) - elseif(c_WN .eq. 'VI') then - call interpolate_T_abs_coeff(z_temp,temp_arr_N2H2,num_T_N2H2,abs_coef,abs_arr_N2H2_VI(ind_WN,:)) - else - print*,'You must select visible (VI) or infrared (IR) channel.' - call abort_physic(rname,"N2H2 bad channel",1) - endif - elseif ((igas_X .eq. igas_N2) .and. (igas_Y .eq. igas_O2)) then - call T_boundaries_continuum(z_temp,temp,temp_arr_N2O2,num_T_N2O2) - if(c_WN .eq. 'IR') then - call interpolate_T_abs_coeff(z_temp,temp_arr_N2O2,num_T_N2O2,abs_coef,abs_arr_N2O2_IR(ind_WN,:)) - elseif(c_WN .eq. 'VI') then - call interpolate_T_abs_coeff(z_temp,temp_arr_N2O2,num_T_N2O2,abs_coef,abs_arr_N2O2_VI(ind_WN,:)) - else - print*,'You must select visible (VI) or infrared (IR) channel.' - call abort_physic(rname,"N2O2 bad channel",1) - endif - elseif ((igas_X .eq. igas_N2) .and. (igas_Y .eq. igas_CH4)) then - call T_boundaries_continuum(z_temp,temp,temp_arr_N2CH4,num_T_N2CH4) - if(c_WN .eq. 'IR') then - call interpolate_T_abs_coeff(z_temp,temp_arr_N2CH4,num_T_N2CH4,abs_coef,abs_arr_N2CH4_IR(ind_WN,:)) - elseif(c_WN .eq. 'VI') then - call interpolate_T_abs_coeff(z_temp,temp_arr_N2CH4,num_T_N2CH4,abs_coef,abs_arr_N2CH4_VI(ind_WN,:)) - else - print*,'You must select visible (VI) or infrared (IR) channel.' - call abort_physic(rname,"N2CH4 bad channel",1) - endif - elseif ((igas_X .eq. igas_CO2) .and. (igas_Y .eq. igas_O2)) then - call T_boundaries_continuum(z_temp,temp,temp_arr_CO2O2,num_T_CO2O2) - if(c_WN .eq. 'IR') then - call interpolate_T_abs_coeff(z_temp,temp_arr_CO2O2,num_T_CO2O2,abs_coef,abs_arr_CO2O2_IR(ind_WN,:)) - elseif(c_WN .eq. 'VI') then - call interpolate_T_abs_coeff(z_temp,temp_arr_CO2O2,num_T_CO2O2,abs_coef,abs_arr_CO2O2_VI(ind_WN,:)) - else - print*,'You must select visible (VI) or infrared (IR) channel.' - call abort_physic(rname,"CO2O2 bad channel",1) - endif - elseif ((igas_X .eq. igas_H2) .and. (igas_Y .eq. igas_CH4)) then - call T_boundaries_continuum(z_temp,temp,temp_arr_H2CH4,num_T_H2CH4) - if(c_WN .eq. 'IR') then - call interpolate_T_abs_coeff(z_temp,temp_arr_H2CH4,num_T_H2CH4,abs_coef,abs_arr_H2CH4_IR(ind_WN,:)) - elseif(c_WN .eq. 'VI') then - call interpolate_T_abs_coeff(z_temp,temp_arr_H2CH4,num_T_H2CH4,abs_coef,abs_arr_H2CH4_VI(ind_WN,:)) - else - print*,'You must select visible (VI) or infrared (IR) channel.' - call abort_physic(rname,"H2CH4 bad channel",1) - endif - elseif ((igas_X .eq. igas_H2) .and. (igas_Y .eq. igas_He)) then - call T_boundaries_continuum(z_temp,temp,temp_arr_H2He,num_T_H2He) - if(c_WN .eq. 'IR') then - call interpolate_T_abs_coeff(z_temp,temp_arr_H2He,num_T_H2He,abs_coef,abs_arr_H2He_IR(ind_WN,:)) - elseif(c_WN .eq. 'VI') then - call interpolate_T_abs_coeff(z_temp,temp_arr_H2He,num_T_H2He,abs_coef,abs_arr_H2He_VI(ind_WN,:)) - else - print*,'You must select visible (VI) or infrared (IR) channel.' - call abort_physic(rname,"H2He bad channel",1) - endif - elseif ((igas_X .eq. igas_H2O) .and. (igas_Y .eq. igas_N2)) then - call T_boundaries_continuum(z_temp,temp,temp_arr_H2ON2,num_T_H2ON2) - if(c_WN .eq. 'IR') then - call interpolate_T_abs_coeff(z_temp,temp_arr_H2ON2,num_T_H2ON2,abs_coef,abs_arr_H2ON2_IR(ind_WN,:)) - elseif(c_WN .eq. 'VI') then - call interpolate_T_abs_coeff(z_temp,temp_arr_H2ON2,num_T_H2ON2,abs_coef,abs_arr_H2ON2_VI(ind_WN,:)) - else - print*,'You must select visible (VI) or infrared (IR) channel.' - call abort_physic(rname,"H2ON2 bad channel",1) - endif - elseif ((igas_X .eq. igas_H2O) .and. (igas_Y .eq. igas_O2)) then - call T_boundaries_continuum(z_temp,temp,temp_arr_H2OO2,num_T_H2OO2) - if(c_WN .eq. 'IR') then - call interpolate_T_abs_coeff(z_temp,temp_arr_H2OO2,num_T_H2OO2,abs_coef,abs_arr_H2OO2_IR(ind_WN,:)) - elseif(c_WN .eq. 'VI') then - call interpolate_T_abs_coeff(z_temp,temp_arr_H2OO2,num_T_H2OO2,abs_coef,abs_arr_H2OO2_VI(ind_WN,:)) - else - print*,'You must select visible (VI) or infrared (IR) channel.' - call abort_physic(rname,"H2OO2 bad channel",1) - endif - elseif ((igas_X .eq. igas_H2O) .and. (igas_Y .eq. igas_CO2)) then - call T_boundaries_continuum(z_temp,temp,temp_arr_H2OCO2,num_T_H2OCO2) - if(c_WN .eq. 'IR') then - call interpolate_T_abs_coeff(z_temp,temp_arr_H2OCO2,num_T_H2OCO2,abs_coef,abs_arr_H2OCO2_IR(ind_WN,:)) - elseif(c_WN .eq. 'VI') then - call interpolate_T_abs_coeff(z_temp,temp_arr_H2OCO2,num_T_H2OCO2,abs_coef,abs_arr_H2OCO2_VI(ind_WN,:)) - else - print*,'You must select visible (VI) or infrared (IR) channel.' - call abort_physic(rname,"H2OCO2 bad channel",1) - endif - elseif ((igas_X .eq. igas_CO2) .and. (igas_Y .eq. igas_H2)) then - call T_boundaries_continuum(z_temp,temp,temp_arr_CO2H2,num_T_CO2H2) - if(c_WN .eq. 'IR') then - call interpolate_T_abs_coeff(z_temp,temp_arr_CO2H2,num_T_CO2H2,abs_coef,abs_arr_CO2H2_IR(ind_WN,:)) - elseif(c_WN .eq. 'VI') then - call interpolate_T_abs_coeff(z_temp,temp_arr_CO2H2,num_T_CO2H2,abs_coef,abs_arr_CO2H2_VI(ind_WN,:)) - else - print*,'You must select visible (VI) or infrared (IR) channel.' - call abort_physic(rname,"CO2H2 bad channel",1) - endif - elseif ((igas_X .eq. igas_CO2) .and. (igas_Y .eq. igas_CH4)) then - call T_boundaries_continuum(z_temp,temp,temp_arr_CO2CH4,num_T_CO2CH4) - if(c_WN .eq. 'IR') then - call interpolate_T_abs_coeff(z_temp,temp_arr_CO2CH4,num_T_CO2CH4,abs_coef,abs_arr_CO2CH4_IR(ind_WN,:)) - elseif(c_WN .eq. 'VI') then - call interpolate_T_abs_coeff(z_temp,temp_arr_CO2CH4,num_T_CO2CH4,abs_coef,abs_arr_CO2CH4_VI(ind_WN,:)) - else - print*,'You must select visible (VI) or infrared (IR) channel.' - call abort_physic(rname,"CO2CH4 bad channel",1) - endif - endif ! igas_X / igas_Y condition - - ! We compute the values of amagat for molecules X and Y - amagat_X = (273.15/temp)*(pres_X/101325.0) - amagat_Y = (273.15/temp)*(pres_Y/101325.0) - - ! We convert the absorption coefficient from cm^-1 amagat^-2 into m^-1 - abs_coef=abs_coef*100.0*amagat_X*amagat_Y - - !print*,'We have ',amagat_X,' amagats of molecule ', trim(gnom(igas_X)) - !print*,'We have ',amagat_X,' amagats of molecule ', trim(gnom(igas_Y)) - !print*,'So the absorption is ',abs_coef,' m^-1' - - end subroutine interpolate_continuum - - - subroutine interpolate_wn_abs_coeff(wn_arr,num_wn,abs_arr_in,abs_arr_out_VI,abs_arr_out_IR,num_T) - -!================================================================== -! -! Purpose -! ------- -! Interpolate the continuum data into the visible (VI) and infrared (IR) spectral chanels. -! -! Author -! ------- -! M. Turbet (2025) -! -!================================================================== - - use radcommon_h, only : BWNV,BWNI,WNOI,WNOV - use radinc_h, only: L_NSPECTI, L_NSPECTV - use mod_phys_lmdz_para, only : is_master - - implicit none - - integer iW, iB, count_norm - integer,intent(in) :: num_T - integer,intent(in) :: num_wn - double precision,intent(in) :: wn_arr(num_wn) - double precision,intent(in) :: abs_arr_in(num_wn,num_T) - double precision,intent(out) :: abs_arr_out_IR(L_NSPECTI,num_T) - double precision,intent(out) :: abs_arr_out_VI(L_NSPECTV,num_T) - - ! First visible (VI) chanel - - ! We get read of all the wavenumbers lower than the minimum wavenumber in the visible wavenumber grid - iW=1 - do while((wn_arr(iW) .lt. BWNV(1)) .and. (iW .lt. num_wn)) - iW=iW+1 - enddo - - ! We compute the mean of the continuum absorption inside each wavenumber visible (VI) chanel - do iB = 1, L_NSPECTV - count_norm=0 - do while((wn_arr(iW) .lt. BWNV(iB+1)) .and. (iW .lt. num_wn)) - abs_arr_out_VI(iB,:)=abs_arr_out_VI(iB,:)+abs_arr_in(iW,:) - count_norm=count_norm+1 - iW=iW+1 - enddo - if(count_norm .ge. 1) abs_arr_out_VI(iB,:)=abs_arr_out_VI(iB,:)/count_norm - end do - - ! Then infrared (IR) chanel - - ! We get read of all the wavenumbers lower than the minimum wavenumber in the infrared wavenumber grid - iW=1 - do while((wn_arr(iW) .lt. BWNI(1)) .and. (iW .lt. num_wn)) - iW=iW+1 - enddo - - ! We compute the mean of the continuum absorption inside each wavenumber visible (VI) chanel - do iB = 1, L_NSPECTI - count_norm=0 - do while((wn_arr(iW) .lt. BWNI(iB+1)) .and. (iW .lt. num_wn)) - abs_arr_out_IR(iB,:)=abs_arr_out_IR(iB,:)+abs_arr_in(iW,:) - count_norm=count_norm+1 - iW=iW+1 - enddo - if(count_norm .ge. 1) abs_arr_out_IR(iB,:)=abs_arr_out_IR(iB,:)/count_norm - end do - - if (is_master) then - print*, 'Continuum absorption, first temperature, visible (VI):' - do iB = 1, L_NSPECTV - print*,WNOV(iB),' cm-1',abs_arr_out_VI(iB,1), ' cm-1 amagat-2' - end do - - print*, 'Continuum absorption, first temperature, infrared (IR):' - do iB = 1, L_NSPECTI - print*,WNOI(iB),' cm-1',abs_arr_out_IR(iB,1), ' cm-1 amagat-2' - end do - endif - - end subroutine interpolate_wn_abs_coeff - - - subroutine T_boundaries_continuum(z_temp,temp,temp_arr,num_T) - -!================================================================== -! -! Purpose -! ------- -! Check if the temperature is outside the boundaries of the continuum data temperatures. -! -! Author -! ------- -! M. Turbet (2025) -! -!================================================================== - - use callkeys_mod, only: strictboundcia - use mod_phys_lmdz_para, only : is_master - - implicit none - - double precision,intent(out) :: z_temp - double precision,intent(in) :: temp - integer,intent(in) :: num_T - double precision,intent(in) :: temp_arr(num_T) - - character(len=22) :: rname = "T_boundaries_continuum" - - z_temp=temp - - if(z_temp .lt. minval(temp_arr)) then - if (strictboundcia) then - if (is_master) then - print*,'Your temperatures are too low for this continuum dataset' - print*, 'Minimum temperature is ', minval(temp_arr), ' K' - endif - call abort_physic(rname,"temperature too low",1) - else - z_temp=minval(temp_arr) - endif - elseif(z_temp .gt. maxval(temp_arr)) then - if (strictboundcia) then - if (is_master) then - print*,'Your temperatures are too high for this continuum dataset' - print*, 'Maximum temperature is ', maxval(temp_arr), ' K' - endif - call abort_physic(rname,"temperature too high",1) - else - z_temp=maxval(temp_arr) - endif - endif - - end subroutine T_boundaries_continuum - - - subroutine interpolate_T_abs_coeff(z_temp,temp_arr,num_T,abs_coef,abs_arr) - -!================================================================== -! -! Purpose -! ------- -! Interpolate in the continuum data using the temperature field -! -! Author -! ------- -! M. Turbet (2025) -! -!================================================================== - - implicit none - - integer iT - double precision,intent(in) :: z_temp - integer,intent(in) :: num_T - double precision,intent(in) :: temp_arr(num_T) - - double precision,intent(out) :: abs_coef - double precision,intent(in) :: abs_arr(num_T) - - ! Check where to interpolate - iT=1 - do while ( z_temp .gt. temp_arr(iT) ) - iT=iT+1 - end do - - ! If below lowest temperature in temp_arr() - if (iT==1) then - abs_coef=abs_arr(1) - return - endif - - ! We proceed to a simple linear interpolation using the two most nearby temperatures - if(iT .lt. num_T) then - abs_coef=abs_arr(iT-1)+(abs_arr(iT)-abs_arr(iT-1))*(z_temp-temp_arr(iT-1))/(temp_arr(iT)-temp_arr(iT-1)) - else - ! If above highest temperature - abs_coef=abs_arr(iT) - endif - - !print*,'the absorption is ',abs_coef,' cm^-1 amagat^-2' - - - end subroutine interpolate_T_abs_coeff - -end module interpolate_continuum_mod Index: trunk/LMDZ.GENERIC/libf/phygeneric/newsedim.F =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/newsedim.F (revision 4062) +++ trunk/LMDZ.GENERIC/libf/phygeneric/newsedim.F (revision 4077) @@ -15,5 +15,5 @@ use tracer_h, only : igcm_h2o_ice use watercommon_h, only: T_h2O_ice_liq,T_h2O_ice_clouds - use radii_mod, only: h2o_cloudrad + use aerosol_radius, only: h2o_cloudrad IMPLICIT NONE Index: trunk/LMDZ.GENERIC/libf/phygeneric/newton_cooling_hotJ.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/newton_cooling_hotJ.F90 (revision 4062) +++ (revision ) @@ -1,182 +1,0 @@ -module newton_cooling_hotJ - - !========================================================================================== - ! Purpose - ! ------- - ! Compute a Newtonian cooling scheme for Hot Jupiters - ! for scenario 1 of the MOCHA intercomparaison project - ! (add citation to protocol paper here when it's live). - ! Check this paper's equations (1) and (4):https://iopscience.iop.org/article/10.3847/PSJ/ac9dfe/pdf - ! - ! We aim at having a generic code but you never know, it might need improving at some point. - ! The current (at time of writing) newtrelax.F90 routine is hardcoded for telluric temperate planets and untested. - ! Thus, we don't use it and use this one instead. - ! - ! Authors - ! ------- - ! Lucas Teinturier (2024) - ! - !========================================================================================== - implicit none - - ! Module variables - real, allocatable, save :: T0(:) - real, allocatable, save :: tau_relax(:) - real, allocatable, save :: delta_Teq(:) - real, allocatable, save :: Trelax(:,:) - character(100),save :: planetary_suffix - !$OMP THREADPRIVATE(planetary_suffix, Trelax,tau_relax,T0,delta_Teq) - - contains - - subroutine newtcool_MOCHA(ngrid,nlayer,coslon,coslat,temp,pplay,firstcall,lastcall,dtrad) - - ! use callkeys_mod, only: planetary_suffix ! this is to know which profiles to load for the T0, the delta Teq and the tau_rad - use mod_phys_lmdz_para, only : is_master, bcast ! for OpenMP stuff - implicit none - - ! Inputs - integer, intent(in) :: ngrid,nlayer - logical, intent(in) :: firstcall ! is it the first call of physiq_mod ? - logical, intent(in) :: lastcall !is it the last call of physiq_mod ? - real, intent(in) :: coslon(ngrid) !cosine of the longitude - real, intent(in) :: coslat(ngrid) ! cosine of the latitude - real, intent(in) :: temp(ngrid,nlayer) ! Temperature at each layer (K) - real, intent(in) :: pplay(ngrid,nlayer) ! Pressure mid-layers (Pa) - - ! Output - real, intent(out) :: dtrad(ngrid,nlayer) ! Tendency on temperature dT/dt (K/s) - - !! Internal variable - integer ig,l - character(100) :: filename - - if (firstcall) then - ! Allocation of the dynamical arrays - allocate(T0(nlayer)) - allocate(tau_relax(nlayer)) - allocate(delta_Teq(nlayer)) - allocate(Trelax(ngrid,nlayer)) - - if (is_master) then - print*,'-----------------------------------------------------' - print*,'| ATTENTION: You are using a Newtonian cooling scheme' - print*,'| for the radiative transfer. This means that ALL' - print*,'| other physics subroutines must be switched off.' - print*,'| Check that you have the required files in the ' - print*,'| simulation directory !' - print*,'-----------------------------------------------------' - print*,"the planetary suffix is ",planetary_suffix - - !! We load the data using the subroutine load_input - - ! Loading T0 - filename = trim(planetary_suffix) // "T0.dat" - ! print*,"filename = ",filename - call read_input(nlayer,filename,T0) - print*,"I successfully read",filename - - ! Loading tau_relax - filename = trim(planetary_suffix) // "tau_relax.dat" - call read_input(nlayer,filename,tau_relax) - print*,"I successfully read",filename - - ! Loading delta_Teq - filename = trim(planetary_suffix) // "delta_Teq.dat" - call read_input(nlayer,filename,delta_Teq) - print*,"I successfully read",filename - - endif ! of is_master - - ! Broadcast tau_relax and Trelax to everyone - call bcast(tau_relax) - call bcast(Trelax) - call bcast(T0) - call bcast(delta_Teq) - - ! now initialising Trelax depending on day or night side - do l=1,nlayer - do ig=1,ngrid - ! if we're on the day-side (the sub-stellar point is at lon =0, dayside is where the coslon >=0) - if (coslon(ig) .ge. 0) then - Trelax(ig,l) = T0(l)+delta_Teq(l)*(ABS(coslon(ig)*coslat(ig))-0.5) - else !we're on the night-side - Trelax(ig,l) = T0(l)-0.5*delta_Teq(l) - endif - enddo !ig=1,ngrid - enddo ! l=1,nlayer - - ! deallocate T0 and delta_Teq, we don't need them anymore - if (allocated(T0)) deallocate(T0) - if (allocated(delta_Teq)) deallocate(delta_Teq) - endif ! of firstcall - - ! call writediagfi(ngrid,"Trelax","Relaxation temperature ","K",3,Trelax) - ! Calculation of the radiative forcing - do l=1,nlayer - do ig=1,ngrid - if (pplay(ig,l) .le. 1.0e6) then - ! if pressure is lower than 10 bar - dtrad(ig,l) = (Trelax(ig,l)-temp(ig,l))/tau_relax(l) - else - ! Deeper than 10 bar, no relaxation, dtrad = 0 - dtrad(ig,l) = 0. - endif !(pplay(ig,l) .le. 1.e6) - enddo !ig =1,ngrid - enddo !l = 1,nlayer - - if (lastcall) then - deallocate(tau_relax) - deallocate(Trelax) - endif - - end subroutine newtcool_MOCHA - - subroutine read_input(nlayer,filename, field) - - !======================================== - ! Purpose - ! ------- - ! Read the input file for this module - ! Each file starts with an integer that should - ! be equal to nlayer (stops if that's not true) - ! - ! Author - ! ------ - ! Lucas Teinturier(2024) - ! - !======================================== - - implicit none - - ! Inputs - integer,intent(in) :: nlayer - character(100),intent(in) :: filename - - ! Output - real, intent(out) :: field(nlayer) - - !! Internal variables - integer ierr, nline, ii - - ! Opening the file - open(401,form='formatted',status='old',file=trim(filename) ,iostat=ierr) - if (ierr /=0) then - print*,"Problem in newton_cooling_hotJ.F90" - print*,"I have an issue opening file ",trim(filename) - call abort_physic("newton_cooling_hot_J", "Unable to read input file", 1) - endif - ! Checking that we have the right number of atmospheric layers - read(401,*) nline - if (nline /= nlayer) then - print*,"Error, you're not using the right # of atmospheric layers in ",trim(filename) - call abort_physic("newton_cooling_hot_J", "Number of layers does not match with number of lines in file", 1) - endif - ! Now reading the content of the file - do ii = 1,nline - read(401,*) field(ii) - enddo - close(401) - end subroutine read_input - -end module newton_cooling_hotJ Index: trunk/LMDZ.GENERIC/libf/phygeneric/newtrelax.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/newtrelax.F90 (revision 4062) +++ (revision ) @@ -1,128 +1,0 @@ -subroutine newtrelax(ngrid,nlayer,mu0,sinlat,popsk,temp,pplay,pplev,dtrad,firstcall) - - use comcstfi_mod, only: rcp, pi - use callkeys_mod, only: tau_relax - implicit none - -#include "netcdf.inc" - -!================================================================== -! -! Purpose -! ------- -! Alternative Newtonian radiative transfer scheme. -! -! Authors -! ------- -! R. Wordsworth (2010) -! -!================================================================== - - - ! Input - integer,intent(in) :: ngrid, nlayer - logical,intent(in) :: firstcall - real,intent(in) :: mu0(ngrid) ! cosine of sun incident angle - real,intent(in) :: sinlat(ngrid) ! sine of latitude - real,intent(in) :: temp(ngrid,nlayer) ! temperature at each layer (K) - real,intent(in) :: pplay(ngrid,nlayer) ! pressure at each layer (Pa) - real,intent(in) :: pplev(ngrid,nlayer+1) ! pressure at each level (Pa) - real,intent(in) :: popsk(ngrid,nlayer) ! pot. T to T converter - - ! Output - real,intent(out) :: dtrad(ngrid,nlayer) - - ! Internal - real Trelax_V, Trelax_H - real,allocatable,dimension(:,:),save :: Trelax -!$OMP THREADPRIVATE(Trelax) - - real T_trop ! relaxation temperature at tropopause (K) - real T_surf ! relaxation temperature at surface (K) - real dT_EP ! Equator-Pole relaxation temperature difference (K) - - real sig, f_sig, sig_trop - integer l,ig - - - logical tidallocked - parameter (tidallocked = .true.) - - ! Setup relaxation temperature - if(firstcall) then - - ALLOCATE(Trelax(ngrid,nlayer)) - - print*,'-----------------------------------------------------' - print*,'| ATTENTION: You are using a Newtonian cooling scheme' - print*,'| for the radiative transfer. This means that ALL' - print*,'| other physics subroutines must be switched off.' - print*,'-----------------------------------------------------' - - if(tidallocked)then - do ig=1,ngrid - - T_surf = 126. + 239.*mu0(ig) - T_trop = 140. + 52.*mu0(ig) - do l=1,nlayer - - if(mu0(ig).le.0.0)then ! night side - Trelax(ig,l)=0.0 - else ! day side - Trelax(ig,l) = T_surf*popsk(ig,l) - if (Trelax(ig,l).lt.T_trop) Trelax(ig,l) = T_trop - endif - - enddo - enddo - - else - - T_trop = 200. - T_surf = 288. - dT_EP = 70. - - sig_trop=(T_trop/T_surf)**(1./rcp) - - do l=1,nlayer - do ig=1,ngrid - - ! vertically varying component - Trelax_V = T_surf*popsk(ig,l) - if (Trelax_V.lt.T_trop) Trelax_V = T_trop - - ! horizontally varying component - sig = pplay(ig,l)/pplev(ig,1) - if(sig.ge.sig_trop)then - f_sig=sin((pi/2)*((sig-sig_trop)/(1-sig_trop))) - else - f_sig=0.0 - endif - Trelax_H = -f_sig*dT_EP*(sinlat(ig)**2 - 1./3.) - - Trelax(ig,l) = Trelax_V + Trelax_H - - enddo - enddo - - endif - - endif - - ! Calculate radiative forcing - do l=1,nlayer - do ig=1,ngrid - dtrad(ig,l) = -(temp(ig,l) - Trelax(ig,l)) / tau_relax - if(temp(ig,l).gt.500.)then ! Trelax(ig,l))then - print*,'ig=',ig - print*,'l=',l - print*,'temp=',temp(ig,l) - print*,'Trelax=',Trelax(ig,l) - endif - enddo - enddo - - call writediagfi(ngrid,'Tref','rad forc temp','K',3,Trelax) - !call writediagfi(ngrid,'ThetaZ','stellar zenith angle','deg',2,mu0) - -end subroutine newtrelax Index: trunk/LMDZ.GENERIC/libf/phygeneric/optci.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/optci.F90 (revision 4062) +++ (revision ) @@ -1,462 +1,0 @@ -MODULE optci_mod - -IMPLICIT NONE - -CONTAINS - -subroutine optci(PLEV,TLEV,DTAUI,TAUCUMI, & - QXIAER,QSIAER,GIAER,COSBI,WBARI,TAUAERO, & - TMID,PMID,TAUGSURF,QVAR,MUVAR,FRACVAR) - - use radinc_h, only: L_LEVELS, L_NLAYRAD, L_NSPECTI, L_NGAUSS, & - L_NLEVRAD, L_REFVAR, naerkind - use radcommon_h, only: gasi,tlimit,wrefVAR,Cmk,tgasref,pfgasref,wnoi,scalep,glat_ig - use gases_h, only: gfrac, ngasmx, igas_N2, igas_He, igas_H2O, igas_H2, & - igas_CH4, igas_CO2, igas_O2 - use comcstfi_mod, only: g, r, mugaz - use callkeys_mod, only: kastprof,continuum,graybody,varspec - use recombin_corrk_mod, only: corrk_recombin, gasi_recomb - use tpindex_mod, only: tpindex - use interpolate_continuum_mod, only: interpolate_continuum - - implicit none - - !================================================================== - ! - ! Purpose - ! ------- - ! Calculates longwave optical constants at each level. For each - ! layer and spectral interval in the IR it calculates WBAR, DTAU - ! and COSBAR. For each level it calculates TAU. - ! - ! TAUCUMI(L,LW) is the cumulative optical depth at level L (or alternatively - ! at the *bottom* of layer L), LW is the spectral wavelength interval. - ! - ! TLEV(L) - Temperature at the layer boundary (i.e., level) - ! PLEV(L) - Pressure at the layer boundary (i.e., level) - ! - ! Authors - ! ------- - ! Adapted from the NASA Ames code by R. Wordsworth (2009) - ! - !================================================================== - - - real*8,intent(out) :: DTAUI(L_NLAYRAD,L_NSPECTI,L_NGAUSS) - real*8 DTAUKI(L_LEVELS,L_NSPECTI,L_NGAUSS) - real*8 TAUI(L_NLEVRAD,L_NSPECTI,L_NGAUSS) - real*8,intent(out) :: TAUCUMI(L_LEVELS,L_NSPECTI,L_NGAUSS) - real*8,intent(in) :: PLEV(L_LEVELS) - real*8,intent(in) :: TLEV(L_LEVELS) ! not used - real*8,intent(in) :: TMID(L_LEVELS) - real*8,intent(in) :: PMID(L_LEVELS) - real*8,intent(out) :: COSBI(L_NLAYRAD,L_NSPECTI,L_NGAUSS) - real*8,intent(out) :: WBARI(L_NLAYRAD,L_NSPECTI,L_NGAUSS) - - ! for aerosols - real*8,intent(in) :: QXIAER(L_LEVELS,L_NSPECTI,NAERKIND) - real*8,intent(in) :: QSIAER(L_LEVELS,L_NSPECTI,NAERKIND) - real*8,intent(in) :: GIAER(L_LEVELS,L_NSPECTI,NAERKIND) - real*8,intent(in) :: TAUAERO(L_LEVELS,NAERKIND) - - ! local variables (saved for convenience as need be allocated) - real*8,save,allocatable :: TAUAEROLK(:,:,:) - real*8,save,allocatable :: TAEROS(:,:,:) -!$OMP THREADPRIVATE(TAUAEROLK,TAEROS) - - integer L, NW, NG, K, LK, IAER - integer MT(L_LEVELS), MP(L_LEVELS), NP(L_LEVELS) - real*8 ANS, TAUGAS - real*8 DPR(L_LEVELS), U(L_LEVELS) - real*8 LCOEF(4), LKCOEF(L_LEVELS,4) - - real*8,intent(out) :: taugsurf(L_NSPECTI,L_NGAUSS-1) - real*8 DCONT,DAERO - double precision wn_cont, p_cont, p_air, T_cont, dtemp, dtempc - double precision p_cross - - ! variable species mixing ratio variables - real*8,intent(in) :: QVAR(L_LEVELS) - real*8,intent(in) :: MUVAR(L_LEVELS) - real*8,intent(in) :: FRACVAR(ngasmx,L_LEVELS) - real*8 WRATIO(L_LEVELS) - real*8 KCOEF(4) - integer NVAR(L_LEVELS) - - ! temporary variables to reduce memory access time to gasi - real*8 tmpk(2,2) - real*8 tmpkvar(2,2,2) - - ! temporary variables for multiple aerosol calculation - real*8 atemp - real*8 btemp(L_NLAYRAD,L_NSPECTI) - - ! variables for k in units m^-1 - real*8 dz(L_LEVELS) - !real*8 rho !! see test below - - integer igas, jgas - - logical :: firstcall=.true. -!$OMP THREADPRIVATE(firstcall) - - !--- Kasting's CIA ---------------------------------------- - !real*8, parameter :: Ci(L_NSPECTI)=[ & - ! 3.8E-5, 1.2E-5, 2.8E-6, 7.6E-7, 4.5E-7, 2.3E-7, & - ! 5.4E-7, 1.6E-6, 0.0, & - ! 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - ! 0.0, 4.0E-7, 4.0E-6, 1.4E-5, & - ! 1.0E-5, 1.2E-6, 2.0E-7, 5.0E-8, 3.0E-8, 0.0 ] - !real*8, parameter :: Ti(L_NSPECTI)=[ -2.2, -1.9, & - ! -1.7, -1.7, -1.7, -1.7, -1.7, -1.7, & - ! 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - ! -1.7,-1.7,-1.7,-1.7,-1.7,-1.7,-1.7, -1.7,0.0 ] - !---------------------------------------------------------- - - if (firstcall) then - ! allocate local arrays of size "naerkind" (which are also - ! "saved" so that this is done only once in for all even if - ! we don't need to store the value from a time step to the next) - allocate(TAUAEROLK(L_LEVELS,L_NSPECTI,NAERKIND)) - allocate(TAEROS(L_LEVELS,L_NSPECTI,NAERKIND)) - firstcall=.false. - endif ! of if (firstcall) - - !======================================================================= - ! Determine the total gas opacity throughout the column, for each - ! spectral interval, NW, and each Gauss point, NG. - - taugsurf(:,:) = 0.0 - dpr(:) = 0.0 - lkcoef(:,:) = 0.0 - - do K=2,L_LEVELS - DPR(k) = PLEV(K)-PLEV(K-1) - - !--- Kasting's CIA ---------------------------------------- - !dz(k)=dpr(k)*189.02*TMID(K)/(0.03720*PMID(K)) - ! this is CO2 path length (in cm) as written by Francois - ! delta_z = delta_p * R_specific * T / (g * P) - ! But Kasting states that W is in units of _atmosphere_ cm - ! So we do - !dz(k)=dz(k)*(PMID(K)/1013.25) - !dz(k)=dz(k)/100.0 ! in m for SI calc - !---------------------------------------------------------- - - ! if we have continuum opacities, we need dz - if(kastprof)then - dz(k) = dpr(k)*(1000.0d0*8.314463d0/muvar(k))*TMID(K)/(g*PMID(K)) - U(k) = Cmk*DPR(k)*mugaz/muvar(k) - else - dz(k) = dpr(k)*R*TMID(K)/(glat_ig*PMID(K))*mugaz/muvar(k) - U(k) = Cmk*DPR(k)*mugaz/muvar(k) ! only Cmk line in optci.F - !JL13 the mugaz/muvar factor takes into account water meanmolecular weight if water is present - endif - - call tpindex(PMID(K),TMID(K),QVAR(K),pfgasref,tgasref,WREFVAR, & - LCOEF,MT(K),MP(K),NVAR(K),WRATIO(K)) - - do LK=1,4 - LKCOEF(K,LK) = LCOEF(LK) - end do - end do ! levels - - ! Spectral dependance of aerosol absorption - do iaer=1,naerkind - DO NW=1,L_NSPECTI - do K=2,L_LEVELS - TAEROS(K,NW,IAER) = TAUAERO(K,IAER) * QXIAER(K,NW,IAER) - end do ! levels - END DO - end do - - do NW=1,L_NSPECTI - - do K=2,L_LEVELS - - DAERO=SUM(TAEROS(K,NW,1:naerkind)) ! aerosol absorption - - DCONT = 0.0d0 ! continuum absorption - - if(continuum.and.(.not.graybody))then - ! include continua if necessary - - T_cont = dble(TMID(k)) - do igas=1,ngasmx - - if(gfrac(igas).eq.-1)then ! variable - p_cont = dble(PMID(k)*scalep*QVAR(k)) ! qvar = mol/mol - elseif(varspec) then - p_cont = dble(PMID(k)*scalep*FRACVAR(igas,k)*(1.-QVAR(k))) - else - p_cont = dble(PMID(k)*scalep*gfrac(igas)*(1.-QVAR(k))) - endif - - do jgas=1,ngasmx - if(gfrac(jgas).eq.-1)then ! variable - p_cross = dble(PMID(k)*scalep*QVAR(k)) ! qvar = mol/mol - elseif(varspec) then - p_cross = dble(PMID(k)*scalep*FRACVAR(jgas,k)*(1.-QVAR(k))) - else - p_cross = dble(PMID(k)*scalep*gfrac(jgas)*(1.-QVAR(k))) - endif - - dtemp=0.0 - - if ( ((igas .eq. igas_N2) .and. (jgas .eq. igas_N2)) .or. & - ((igas .eq. igas_N2) .and. (jgas .eq. igas_H2)) .or. & - ((igas .eq. igas_N2) .and. (jgas .eq. igas_O2)) .or. & - ((igas .eq. igas_N2) .and. (jgas .eq. igas_CH4)) .or. & - ((igas .eq. igas_O2) .and. (jgas .eq. igas_O2)) .or. & - ((igas .eq. igas_CO2) .and. (jgas .eq. igas_O2)) .or. & - ((igas .eq. igas_H2) .and. (jgas .eq. igas_H2)) .or. & - ((igas .eq. igas_H2) .and. (jgas .eq. igas_CH4)) .or. & - ((igas .eq. igas_H2) .and. (jgas .eq. igas_He)) .or. & - ((igas .eq. igas_CH4) .and. (jgas .eq. igas_CH4)) .or. & - ((igas .eq. igas_H2O) .and. (jgas .eq. igas_H2O)) .or. & - ((igas .eq. igas_H2O) .and. (jgas .eq. igas_N2)) .or. & - ((igas .eq. igas_H2O) .and. (jgas .eq. igas_O2)) .or. & - ((igas .eq. igas_H2O) .and. (jgas .eq. igas_CO2)) .or. & - ((igas .eq. igas_CO2) .and. (jgas .eq. igas_CO2)) .or. & - ((igas .eq. igas_CO2) .and. (jgas .eq. igas_H2)) .or. & - ((igas .eq. igas_CO2) .and. (jgas .eq. igas_CH4)) ) then - - call interpolate_continuum('',igas,jgas,'IR',nw,T_cont,p_cont,p_cross,dtemp,.false.) - - endif - - DCONT = DCONT + dtemp - - enddo ! jgas=1,ngasmx - - enddo ! igas=1,ngasmx - - DCONT = DCONT*dz(k) - - endif ! continuum - - do ng=1,L_NGAUSS-1 - - ! Now compute TAUGAS - - ! Interpolate between water mixing ratios - ! WRATIO = 0.0 if the requested water amount is equal to, or outside the - ! the water data range - - if(L_REFVAR.eq.1)then ! added by RW for special no variable case - - ! JVO 2017 : added tmpk because the repeated calls to gasi/v increased dramatically - ! the execution time of optci/v -> ~ factor 2 on the whole radiative - ! transfer on the tested simulations ! - - IF (corrk_recombin) THEN ! added by JVO - tmpk = GASI_RECOMB(MT(K):MT(K)+1,MP(K):MP(K)+1,1,NW,NG) ! contains the mix of recombined species - ELSE - tmpk = GASI(MT(K):MT(K)+1,MP(K):MP(K)+1,1,NW,NG) - ENDIF - - KCOEF(1) = tmpk(1,1) ! KCOEF(1) = GASI(MT(K),MP(K),1,NW,NG) - KCOEF(2) = tmpk(1,2) ! KCOEF(2) = GASI(MT(K),MP(K)+1,1,NW,NG) - KCOEF(3) = tmpk(2,2) ! KCOEF(3) = GASI(MT(K)+1,MP(K)+1,1,NW,NG) - KCOEF(4) = tmpk(2,1) ! KCOEF(4) = GASI(MT(K)+1,MP(K),1,NW,NG) - - else - - IF (corrk_recombin) THEN ! added by JVO - tmpkvar = GASI_RECOMB(MT(K):MT(K)+1,MP(K):MP(K)+1,NVAR(K):NVAR(K)+1,NW,NG) - ELSE - tmpkvar = GASI(MT(K):MT(K)+1,MP(K):MP(K)+1,NVAR(K):NVAR(K)+1,NW,NG) - ENDIF - - KCOEF(1) = tmpkvar(1,1,1) + WRATIO(K) * & - ( tmpkvar(1,1,2)-tmpkvar(1,1,1) ) - - KCOEF(2) = tmpkvar(1,2,1) + WRATIO(K) * & - ( tmpkvar(1,2,2)-tmpkvar(1,2,1) ) - - KCOEF(3) = tmpkvar(2,2,1) + WRATIO(K) * & - ( tmpkvar(2,2,2)-tmpkvar(2,2,1) ) - - KCOEF(4) = tmpkvar(2,1,1) + WRATIO(K) * & - ( tmpkvar(2,1,2)-tmpkvar(2,1,1) ) - - endif - - ! Interpolate the gaseous k-coefficients to the requested T,P values - - ANS = LKCOEF(K,1)*KCOEF(1) + LKCOEF(K,2)*KCOEF(2) + & - LKCOEF(K,3)*KCOEF(3) + LKCOEF(K,4)*KCOEF(4) - - TAUGAS = U(k)*ANS - - TAUGSURF(NW,NG) = TAUGSURF(NW,NG) + TAUGAS + DCONT - DTAUKI(K,nw,ng) = TAUGAS & - + DCONT & ! For parameterized continuum absorption - + DAERO ! For aerosol absorption - - end do - - ! Now fill in the "clear" part of the spectrum (NG = L_NGAUSS), - ! which holds continuum opacity only - - NG = L_NGAUSS - DTAUKI(K,nw,ng) = 0.d0 & - + DCONT & ! For parameterized continuum absorption - + DAERO ! For aerosol absorption - - end do - end do - - !======================================================================= - ! Now the full treatment for the layers, where besides the opacity - ! we need to calculate the scattering albedo and asymmetry factors - - do iaer=1,naerkind - DO NW=1,L_NSPECTI - DO K=2,L_LEVELS - TAUAEROLK(K,NW,IAER) = TAUAERO(K,IAER)*QSIAER(K,NW,IAER) ! effect of scattering albedo - ENDDO - ENDDO - end do - - DO NW=1,L_NSPECTI - DO L=1,L_NLAYRAD-1 - K = 2*L+1 - btemp(L,NW) = SUM(TAUAEROLK(K,NW,1:naerkind)) + SUM(TAUAEROLK(K+1,NW,1:naerkind)) - END DO ! L vertical loop - - ! Last level - L = L_NLAYRAD - K = 2*L+1 - btemp(L,NW) = SUM(TAUAEROLK(K,NW,1:naerkind)) - - END DO ! NW spectral loop - - - DO NW=1,L_NSPECTI - NG = L_NGAUSS - DO L=1,L_NLAYRAD-1 - - K = 2*L+1 - DTAUI(L,nw,ng) = DTAUKI(K,NW,NG) + DTAUKI(K+1,NW,NG)! + 1.e-50 - - atemp = 0. - if(DTAUI(L,NW,NG) .GT. 1.0D-9) then - do iaer=1,naerkind - atemp = atemp + & - GIAER(K,NW,IAER) * TAUAEROLK(K,NW,IAER) + & - GIAER(K+1,NW,IAER) * TAUAEROLK(K+1,NW,IAER) - end do - WBARI(L,nw,ng) = btemp(L,nw) / DTAUI(L,NW,NG) - else - WBARI(L,nw,ng) = 0.0D0 - DTAUI(L,NW,NG) = 1.0D-9 - endif - - if(btemp(L,nw) .GT. 0.0d0) then - cosbi(L,NW,NG) = atemp/btemp(L,nw) - else - cosbi(L,NW,NG) = 0.0D0 - end if - - END DO ! L vertical loop - - ! Last level - - L = L_NLAYRAD - K = 2*L+1 - DTAUI(L,nw,ng) = DTAUKI(K,NW,NG) ! + 1.e-50 - - atemp = 0. - if(DTAUI(L,NW,NG) .GT. 1.0D-9) then - do iaer=1,naerkind - atemp = atemp + GIAER(K,NW,IAER) * TAUAEROLK(K,NW,IAER) - end do - WBARI(L,nw,ng) = btemp(L,nw) / DTAUI(L,NW,NG) - else - WBARI(L,nw,ng) = 0.0D0 - DTAUI(L,NW,NG) = 1.0D-9 - endif - - if(btemp(L,nw) .GT. 0.0d0) then - cosbi(L,NW,NG) = atemp/btemp(L,nw) - else - cosbi(L,NW,NG) = 0.0D0 - end if - - - ! Now the other Gauss points, if needed. - - DO NG=1,L_NGAUSS-1 - IF(TAUGSURF(NW,NG) .gt. TLIMIT) THEN - - DO L=1,L_NLAYRAD-1 - K = 2*L+1 - DTAUI(L,nw,ng) = DTAUKI(K,NW,NG)+DTAUKI(K+1,NW,NG)! + 1.e-50 - - if(DTAUI(L,NW,NG) .GT. 1.0D-9) then - - WBARI(L,nw,ng) = btemp(L,nw) / DTAUI(L,NW,NG) - - else - WBARI(L,nw,ng) = 0.0D0 - DTAUI(L,NW,NG) = 1.0D-9 - endif - - cosbi(L,NW,NG) = cosbi(L,NW,L_NGAUSS) - END DO ! L vertical loop - - ! Last level - L = L_NLAYRAD - K = 2*L+1 - DTAUI(L,nw,ng) = DTAUKI(K,NW,NG)! + 1.e-50 - - if(DTAUI(L,NW,NG) .GT. 1.0D-9) then - - WBARI(L,nw,ng) = btemp(L,nw) / DTAUI(L,NW,NG) - - else - WBARI(L,nw,ng) = 0.0D0 - DTAUI(L,NW,NG) = 1.0D-9 - endif - - cosbi(L,NW,NG) = cosbi(L,NW,L_NGAUSS) - - END IF - - END DO ! NG Gauss loop - END DO ! NW spectral loop - - ! Total extinction optical depths - - DO NG=1,L_NGAUSS ! full gauss loop - DO NW=1,L_NSPECTI - TAUCUMI(1,NW,NG)=0.0D0 - DO K=2,L_LEVELS - TAUCUMI(K,NW,NG)=TAUCUMI(K-1,NW,NG)+DTAUKI(K,NW,NG) - END DO - END DO ! end full gauss loop - END DO - - ! be aware when comparing with textbook results - ! (e.g. Pierrehumbert p. 218) that - ! taucumi does not take the =0.5 factor into - ! account. It is the optical depth for a vertically - ! ascending ray with angle theta = 0. - - !open(127,file='taucum.out') - !do nw=1,L_NSPECTI - ! write(127,*) taucumi(L_LEVELS,nw,L_NGAUSS) - !enddo - !close(127) - -! print*,'WBARI' -! print*,WBARI -! print*,'DTAUI' -! print*,DTAUI -! call abort - -end subroutine optci - -END MODULE optci_mod - Index: trunk/LMDZ.GENERIC/libf/phygeneric/optcv.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/optcv.F90 (revision 4062) +++ (revision ) @@ -1,411 +1,0 @@ -MODULE optcv_mod - -IMPLICIT NONE - -CONTAINS - -SUBROUTINE OPTCV(DTAUV,TAUV,TAUCUMV,PLEV, & - QXVAER,QSVAER,GVAER,WBARV,COSBV, & - TAUAERO,TMID,PMID,TAUGSURF,QVAR,MUVAR,FRACVAR) - - use radinc_h, only: L_NLAYRAD, L_NLEVRAD, L_LEVELS, L_NSPECTV, L_NGAUSS, L_REFVAR, NAERKIND - use radcommon_h, only: gasv, tlimit, wrefVAR, Cmk, tgasref, pfgasref,wnov,scalep,glat_ig - use gases_h, only: gfrac, ngasmx, igas_H2, igas_H2O, igas_He, igas_N2, & - igas_CH4, igas_CO2, igas_O2 - use comcstfi_mod, only: g, r, mugaz - use callkeys_mod, only: kastprof,continuum,graybody,callgasvis,varspec, & - rayleigh - use recombin_corrk_mod, only: corrk_recombin, gasv_recomb - use tpindex_mod, only: tpindex - use interpolate_continuum_mod, only: interpolate_continuum - use calc_rayleigh_mod, only: calc_rayleigh - - implicit none - - !================================================================== - ! - ! Purpose - ! ------- - ! Calculates shortwave optical constants at each level. - ! - ! Authors - ! ------- - ! Adapted from the NASA Ames code by R. Wordsworth (2009) - ! - !================================================================== - ! - ! THIS SUBROUTINE SETS THE OPTICAL CONSTANTS IN THE VISUAL - ! IT CALCULATES FOR EACH LAYER, FOR EACH SPECTRAL INTERVAL IN THE VISUAL - ! LAYER: WBAR, DTAU, COSBAR - ! LEVEL: TAU - ! - ! TAUV(L,NW,NG) is the cumulative optical depth at the top of radiation code - ! layer L. NW is spectral wavelength interval, ng the Gauss point index. - ! - ! TLEV(L) - Temperature at the layer boundary - ! PLEV(L) - Pressure at the layer boundary (i.e. level) - ! GASV(NT,NPS,NW,NG) - Visible k-coefficients - ! - !------------------------------------------------------------------- - - - real*8,intent(out) :: DTAUV(L_NLAYRAD,L_NSPECTV,L_NGAUSS) - real*8 DTAUKV(L_LEVELS,L_NSPECTV,L_NGAUSS) - real*8,intent(out) :: TAUV(L_NLEVRAD,L_NSPECTV,L_NGAUSS) - real*8,intent(out) :: TAUCUMV(L_LEVELS,L_NSPECTV,L_NGAUSS) - real*8,intent(in) :: PLEV(L_LEVELS) - real*8,intent(in) :: TMID(L_LEVELS), PMID(L_LEVELS) - real*8,intent(out) :: COSBV(L_NLAYRAD,L_NSPECTV,L_NGAUSS) - real*8,intent(out) :: WBARV(L_NLAYRAD,L_NSPECTV,L_NGAUSS) - - ! for aerosols - real*8,intent(in) :: QXVAER(L_LEVELS,L_NSPECTV,NAERKIND) - real*8,intent(in) :: QSVAER(L_LEVELS,L_NSPECTV,NAERKIND) - real*8,intent(in) :: GVAER(L_LEVELS,L_NSPECTV,NAERKIND) - real*8,intent(in) :: TAUAERO(L_LEVELS,NAERKIND) - - ! local arrays (saved for convenience as need be allocated) - real*8,save,allocatable :: TAUAEROLK(:,:,:) - real*8,save,allocatable :: TAEROS(:,:,:) -!$OMP THREADPRIVATE(TAUAEROLK,TAEROS) - - integer L, NW, NG, K, LK, IAER - integer MT(L_LEVELS), MP(L_LEVELS), NP(L_LEVELS) - real*8 ANS, TAUGAS - real*8 TAURAY(L_LEVELS,L_NSPECTV) - real*8 TRAY(L_LEVELS,L_NSPECTV) - real*8 DPR(L_LEVELS), U(L_LEVELS) - real*8 LCOEF(4), LKCOEF(L_LEVELS,4) - - real*8,intent(out) :: taugsurf(L_NSPECTV,L_NGAUSS-1) - real*8 DCONT,DAERO - real*8 DRAYAER - double precision wn_cont, p_cont, p_air, T_cont, dtemp, dtempc - double precision p_cross - - ! variable species mixing ratio variables - real*8,intent(in) :: QVAR(L_LEVELS) - real*8,intent(in) :: MUVAR(L_LEVELS) - real*8,intent(in) :: FRACVAR(ngasmx,L_LEVELS) - real*8 :: WRATIO(L_LEVELS) - real*8 KCOEF(4) - integer NVAR(L_LEVELS) - - ! temporary variables to reduce memory access time to gasv - real*8 tmpk(2,2) - real*8 tmpkvar(2,2,2) - - ! temporary variables for multiple aerosol calculation - real*8 atemp(L_NLAYRAD,L_NSPECTV) - real*8 btemp(L_NLAYRAD,L_NSPECTV) - real*8 ctemp(L_NLAYRAD,L_NSPECTV) - - ! variables for k in units m^-1 - real*8 dz(L_LEVELS) - - - integer igas, jgas - - logical :: firstcall=.true. -!$OMP THREADPRIVATE(firstcall) - - if (firstcall) then - ! allocate local arrays of size "naerkind" (which are also - ! "saved" so that this is done only once in for all even if - ! we don't need to store the value from a time step to the next) - allocate(TAUAEROLK(L_LEVELS,L_NSPECTV,NAERKIND)) - allocate(TAEROS(L_LEVELS,L_NSPECTV,NAERKIND)) - firstcall=.false. - endif ! of if (firstcall) - - !======================================================================= - ! Determine the total gas opacity throughout the column, for each - ! spectral interval, NW, and each Gauss point, NG. - ! Calculate the continuum opacities, i.e., those that do not depend on - ! NG, the Gauss index. - - taugsurf(:,:) = 0.0 - dpr(:) = 0.0 - lkcoef(:,:) = 0.0 - - do K=2,L_LEVELS - DPR(k) = PLEV(K)-PLEV(K-1) - - ! if we have continuum opacities, we need dz - if(kastprof)then - dz(k) = dpr(k)*(1000.0d0*8.314463d0/muvar(k))*TMID(K)/(g*PMID(K)) - U(k) = Cmk*DPR(k)*mugaz/muvar(k) - else - dz(k) = dpr(k)*R*TMID(K)/(glat_ig*PMID(K))*mugaz/muvar(k) - U(k) = Cmk*DPR(k)*mugaz/muvar(k) ! only Cmk line in optci.F - !JL13 the mugaz/muvar factor takes into account water meanmolecular weight if water is present - endif - - call tpindex(PMID(K),TMID(K),QVAR(K),pfgasref,tgasref,WREFVAR, & - LCOEF,MT(K),MP(K),NVAR(K),WRATIO(K)) - - do LK=1,4 - LKCOEF(K,LK) = LCOEF(LK) - end do - end do ! levels - - ! Spectral dependance of aerosol absorption - !JL18 It seems to be good to have aerosols in the first "radiative layer" of the gcm in the IR - ! but visible does not handle very well diffusion in first layer. - ! The tauaero and tauray are thus set to 0 (a small value for rayleigh because the code crashes otherwise) - ! in the 4 first semilayers in optcv, but not optci. - ! This solves random variations of the sw heating at the model top. - do iaer=1,naerkind - do NW=1,L_NSPECTV - TAEROS(1:4,NW,IAER)=0.d0 - do K=5,L_LEVELS - TAEROS(K,NW,IAER) = TAUAERO(K,IAER) * QXVAER(K,NW,IAER) - end do ! levels - end do - end do - -!======================================================================= -! Set up the wavelength independent part of the Rayleigh scattering. -! WAVEV is in microns. There is no Rayleigh scattering in the IR. - - if(rayleigh) then - call calc_rayleigh(QVAR,MUVAR,PMID,TMID,TAURAY) - else - print*,'setspv: No Rayleigh scattering, check for NaN in output!' - do NW=1,L_NSPECTV - TAURAY(:,NW) = 1E-16 - end do - endif - - ! Computation of pressure dependant part of Rayleigh scattering - do NW=1,L_NSPECTV - TRAY(1:4,NW) = 1d-30 - do K=5,L_LEVELS - TRAY(K,NW) = TAURAY(K,NW) * DPR(K) - end do ! levels - end do - - ! we ignore K=1... - - do K=2,L_LEVELS - - do NW=1,L_NSPECTV - - DRAYAER = TRAY(K,NW) - ! DRAYAER is Tau RAYleigh scattering, plus AERosol opacity - do iaer=1,naerkind - DRAYAER = DRAYAER + TAEROS(K,NW,IAER) - end do - - DCONT = 0.0 ! continuum absorption - - if(continuum.and.(.not.graybody).and.callgasvis)then - ! include continua if necessary - - T_cont = dble(TMID(k)) - do igas=1,ngasmx - - if(gfrac(igas).eq.-1)then ! variable - p_cont = dble(PMID(k)*scalep*QVAR(k)) ! qvar = mol/mol - elseif(varspec) then - p_cont = dble(PMID(k)*scalep*FRACVAR(igas,k)*(1.-QVAR(k))) - else - p_cont = dble(PMID(k)*scalep*gfrac(igas)*(1.-QVAR(k))) - endif - - do jgas=1,ngasmx - if(gfrac(jgas).eq.-1)then ! variable - p_cross = dble(PMID(k)*scalep*QVAR(k)) ! qvar = mol/mol - elseif(varspec) then - p_cross = dble(PMID(k)*scalep*FRACVAR(jgas,k)*(1.-QVAR(k))) - else - p_cross = dble(PMID(k)*scalep*gfrac(jgas)*(1.-QVAR(k))) - endif - - dtemp=0.0 - - if ( ((igas .eq. igas_N2) .and. (jgas .eq. igas_N2)) .or. & - ((igas .eq. igas_N2) .and. (jgas .eq. igas_H2)) .or. & - ((igas .eq. igas_N2) .and. (jgas .eq. igas_O2)) .or. & - ((igas .eq. igas_N2) .and. (jgas .eq. igas_CH4)) .or. & - ((igas .eq. igas_O2) .and. (jgas .eq. igas_O2)) .or. & - ((igas .eq. igas_CO2) .and. (jgas .eq. igas_O2)) .or. & - ((igas .eq. igas_H2) .and. (jgas .eq. igas_H2)) .or. & - ((igas .eq. igas_H2) .and. (jgas .eq. igas_CH4)) .or. & - ((igas .eq. igas_H2) .and. (jgas .eq. igas_He)) .or. & - ((igas .eq. igas_CH4) .and. (jgas .eq. igas_CH4)) .or. & - ((igas .eq. igas_H2O) .and. (jgas .eq. igas_H2O)) .or. & - ((igas .eq. igas_H2O) .and. (jgas .eq. igas_N2)) .or. & - ((igas .eq. igas_H2O) .and. (jgas .eq. igas_O2)) .or. & - ((igas .eq. igas_H2O) .and. (jgas .eq. igas_CO2)) .or. & - ((igas .eq. igas_CO2) .and. (jgas .eq. igas_CO2)) .or. & - ((igas .eq. igas_CO2) .and. (jgas .eq. igas_H2)) .or. & - ((igas .eq. igas_CO2) .and. (jgas .eq. igas_CH4)) ) then - - call interpolate_continuum('',igas,jgas,'VI',nw,T_cont,p_cont,p_cross,dtemp,.false.) - - endif - - DCONT = DCONT + dtemp - - enddo ! jgas=1,ngasmx - - enddo ! igas=1,ngasmx - - DCONT = DCONT*dz(k) - - endif ! continuum - - do ng=1,L_NGAUSS-1 - - ! Now compute TAUGAS - - ! Interpolate between water mixing ratios - ! WRATIO = 0.0 if the requested water amount is equal to, or outside the - ! the water data range - - if(L_REFVAR.eq.1)then ! added by RW for special no variable case - - ! JVO 2017 : added tmpk because the repeated calls to gasi/v increased dramatically - ! the execution time of optci/v -> ~ factor 2 on the whole radiative - ! transfer on the tested simulations ! - - IF (corrk_recombin) THEN ! Added by JVO - tmpk = GASV_RECOMB(MT(K):MT(K)+1,MP(K):MP(K)+1,1,NW,NG) ! contains the mix of recombined species - ELSE - tmpk = GASV(MT(K):MT(K)+1,MP(K):MP(K)+1,1,NW,NG) - ENDIF - - KCOEF(1) = tmpk(1,1) ! KCOEF(1) = GASV(MT(K),MP(K),1,NW,NG) - KCOEF(2) = tmpk(1,2) ! KCOEF(2) = GASV(MT(K),MP(K)+1,1,NW,NG) - KCOEF(3) = tmpk(2,2) ! KCOEF(3) = GASV(MT(K)+1,MP(K)+1,1,NW,NG) - KCOEF(4) = tmpk(2,1) ! KCOEF(4) = GASV(MT(K)+1,MP(K),1,NW,NG) - - else - - IF (corrk_recombin) THEN - tmpkvar = GASV_RECOMB(MT(K):MT(K)+1,MP(K):MP(K)+1,NVAR(K):NVAR(K)+1,NW,NG) - ELSE - tmpkvar = GASV(MT(K):MT(K)+1,MP(K):MP(K)+1,NVAR(K):NVAR(K)+1,NW,NG) - ENDIF - - KCOEF(1) = tmpkvar(1,1,1) + WRATIO(K) * & - ( tmpkvar(1,1,2)-tmpkvar(1,1,1) ) - - KCOEF(2) = tmpkvar(1,2,1) + WRATIO(K) * & - ( tmpkvar(1,2,2)-tmpkvar(1,2,1) ) - - KCOEF(3) = tmpkvar(2,2,1) + WRATIO(K) * & - ( tmpkvar(2,2,2)-tmpkvar(2,2,1) ) - - KCOEF(4) = tmpkvar(2,1,1) + WRATIO(K) * & - ( tmpkvar(2,1,2)-tmpkvar(2,1,1) ) - - - endif - - ! Interpolate the gaseous k-coefficients to the requested T,P values - - ANS = LKCOEF(K,1)*KCOEF(1) + LKCOEF(K,2)*KCOEF(2) + & - LKCOEF(K,3)*KCOEF(3) + LKCOEF(K,4)*KCOEF(4) - - TAUGAS = U(k)*ANS - - TAUGSURF(NW,NG) = TAUGSURF(NW,NG) + TAUGAS + DCONT - DTAUKV(K,nw,ng) = TAUGAS & - + DRAYAER & ! DRAYAER includes all scattering contributions - + DCONT ! For parameterized continuum aborption - - end do - - ! Now fill in the "clear" part of the spectrum (NG = L_NGAUSS), - ! which holds continuum opacity only - - NG = L_NGAUSS - DTAUKV(K,nw,ng) = DRAYAER + DCONT ! Scattering + parameterized continuum absorption - - end do - end do - - !======================================================================= - ! Now the full treatment for the layers, where besides the opacity - ! we need to calculate the scattering albedo and asymmetry factors - - !JL18 It seems to be good to have aerosols in the first "radiative layer" of the gcm in the IR - ! but not in the visible - ! The tauaero is thus set to 0 in the 4 first semilayers in optcv, but not optci. - ! This solves random variations of the sw heating at the model top. - do iaer=1,naerkind - DO NW=1,L_NSPECTV - TAUAEROLK(1:4,NW,IAER)=0.d0 - DO K=5,L_LEVELS - TAUAEROLK(K,NW,IAER) = TAUAERO(K,IAER) * QSVAER(K,NW,IAER) ! effect of scattering albedo - ENDDO - ENDDO - end do - - DO NW=1,L_NSPECTV - DO L=1,L_NLAYRAD-1 - K = 2*L+1 - atemp(L,NW) = SUM(GVAER(K,NW,1:naerkind) * TAUAEROLK(K,NW,1:naerkind))+SUM(GVAER(K+1,NW,1:naerkind) * TAUAEROLK(K+1,NW,1:naerkind)) - btemp(L,NW) = SUM(TAUAEROLK(K,NW,1:naerkind)) + SUM(TAUAEROLK(K+1,NW,1:naerkind)) - ctemp(L,NW) = btemp(L,NW) + 0.9999*(TRAY(K,NW) + TRAY(K+1,NW)) ! JVO 2017 : does this 0.999 is really meaningful ? - btemp(L,NW) = btemp(L,NW) + TRAY(K,NW) + TRAY(K+1,NW) - COSBV(L,NW,1:L_NGAUSS) = atemp(L,NW)/btemp(L,NW) - END DO ! L vertical loop - - ! Last level - L = L_NLAYRAD - K = 2*L+1 - atemp(L,NW) = SUM(GVAER(K,NW,1:naerkind) * TAUAEROLK(K,NW,1:naerkind)) - btemp(L,NW) = SUM(TAUAEROLK(K,NW,1:naerkind)) - ctemp(L,NW) = btemp(L,NW) + 0.9999*TRAY(K,NW) ! JVO 2017 : does this 0.999 is really meaningful ? - btemp(L,NW) = btemp(L,NW) + TRAY(K,NW) - COSBV(L,NW,1:L_NGAUSS) = atemp(L,NW)/btemp(L,NW) - - - END DO ! NW spectral loop - - DO NG=1,L_NGAUSS - DO NW=1,L_NSPECTV - DO L=1,L_NLAYRAD-1 - - K = 2*L+1 - DTAUV(L,nw,ng) = DTAUKV(K,NW,NG) + DTAUKV(K+1,NW,NG) - WBARV(L,nw,ng) = ctemp(L,NW) / DTAUV(L,nw,ng) - - END DO ! L vertical loop - - ! Last level - - L = L_NLAYRAD - K = 2*L+1 - DTAUV(L,nw,ng) = DTAUKV(K,NW,NG) - - WBARV(L,NW,NG) = ctemp(L,NW) / DTAUV(L,NW,NG) - - END DO ! NW spectral loop - END DO ! NG Gauss loop - - ! Total extinction optical depths - - DO NG=1,L_NGAUSS ! full gauss loop - DO NW=1,L_NSPECTV - TAUCUMV(1,NW,NG)=0.0D0 - DO K=2,L_LEVELS - TAUCUMV(K,NW,NG)=TAUCUMV(K-1,NW,NG)+DTAUKV(K,NW,NG) - END DO - - DO L=1,L_NLAYRAD - TAUV(L,NW,NG)=TAUCUMV(2*L,NW,NG) - END DO - TAUV(L,NW,NG)=TAUCUMV(2*L_NLAYRAD+1,NW,NG) - END DO - END DO ! end full gauss loop - - - - -end subroutine optcv - -END MODULE optcv_mod Index: trunk/LMDZ.GENERIC/libf/phygeneric/orbite.F =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/orbite.F (revision 4062) +++ (revision ) @@ -1,65 +1,0 @@ - subroutine orbite(pls,pdist_star,pdecli,pright_ascenc) - - use planete_mod, only: p_elips, e_elips, timeperi, obliquit - use comcstfi_mod, only: pi - implicit none -!================================================================== -! -! Purpose -! ------- -! Distance from star and declination as a function of the stellar -! longitude Ls -! -! Inputs -! ------ -! pls Ls -! -! Outputs -! ------- -! pdist_star Distance Star-Planet in UA -! pdecli declinaison ( in radians ) -! pright_ascenc right ascension ( in radians ) -! -!======================================================================= - -c Declarations: -c ------------- - -c arguments: -c ---------- - - REAL pday,pdist_star,pdecli,pright_ascenc,pls,i - -c----------------------------------------------------------------------- - -c Star-Planet Distance - - pdist_star = p_elips/(1.+e_elips*cos(pls+timeperi)) - -c Stellar declination - -c ********************* version before 01/01/2000 ******* - - pdecli = asin (sin(pls)*sin(obliquit*pi/180.)) - -c********************* version after 01/01/2000 ******* -c i=obliquit*pi/180. -c pdecli=asin(sin(pls)*sin(i)/sqrt(sin(pls)**2+ -c & cos(pls)**2*cos(i)**2)) -c ****************************************************** - -c right ascencion - If((pls.lt.pi/2.d0)) then - pright_ascenc= atan(tan(pls)*cos(obliquit*pi/180.)) - else if((pls.gt.pi/2.d0).and.(pls.lt.3.d0*pi/2.d0)) then - pright_ascenc= pi+atan(tan(pls)*cos(obliquit*pi/180.)) - else if((pls.gt.3.d0*pi/2.d0)) then - pright_ascenc= 2.d0*pi+atan(tan(pls)*cos(obliquit*pi/180.)) - else if (Abs(pls-pi/2.d0).le.1.d-10) then - pright_ascenc= pi/2.d0 - else - pright_ascenc=-pi/2.d0 - end if - - RETURN - END Index: trunk/LMDZ.GENERIC/libf/phygeneric/physiq_mod.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/physiq_mod.F90 (revision 4062) +++ trunk/LMDZ.GENERIC/libf/phygeneric/physiq_mod.F90 (revision 4077) @@ -23,8 +23,8 @@ use gases_h, only: gnom, gfrac, ngasmx use radcommon_h, only: sigma, glat, grav, BWNV, WNOI, DWNI, DWNV, WNOV - use suaer_corrk_mod, only: suaer_corrk - use setspv_mod, only: setspv - use radii_mod, only: h2o_reffrad, co2_reffrad - use aerosol_mod, only: iniaerosol, iaero_co2, iaero_h2o + use rad_correlatedk_ini_aerosol_mod, only: rad_correlatedk_ini_aerosol + use rad_correlatedk_init_stellar_mod, only: rad_correlatedk_init_stellar + use aerosol_radius, only: h2o_reffrad, aerosol_radius_co2 + use aerosol_global_variables , only: aerosol_init, iaero_co2, iaero_h2o use surfdat_h, only: phisfi, zmea, zstd, zsig, zgam, zthe, & dryness @@ -82,5 +82,5 @@ use conc_mod, only: rnew, cpnew, ini_conc_mod use phys_state_var_mod - use callcorrk_mod, only: callcorrk + use rad_correlatedk_mod, only: rad_correlatedk use conduction_mod, only: conduction use molvis_mod, only: molvis @@ -95,5 +95,5 @@ use condensation_generic_mod, only: condensation_generic use datafile_mod, only: datadir - use newton_cooling_hotJ, only: newtcool_MOCHA ! LT, adding for MOCHA protocol + use rad_netwon_cooling_hot_jupiter, only: rad_newton_cooling_MOCHA_intercomparison ! LT, adding for MOCHA protocol #ifndef MESOSCALE @@ -337,5 +337,5 @@ real dtmoist(ngrid,nlayer) ! Moistadj routine. real dt_ekman(ngrid,nslay), dt_hdiff(ngrid,nslay), dt_gm(ngrid,nslay) ! Slab_ocean routine. - real zdtsw1(ngrid,nlayer), zdtlw1(ngrid,nlayer) ! Callcorrk routine. + real zdtsw1(ngrid,nlayer), zdtlw1(ngrid,nlayer) ! rad_correlatedk routine. real zdtchim(ngrid,nlayer) ! Calchim routine. @@ -594,5 +594,5 @@ ! Initialize aerosol indexes. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~ - call iniaerosol + call aerosol_init ! allocate related local arrays ! (need be allocated instead of automatic because of "naerkind") @@ -650,5 +650,5 @@ ! Initialize orbital calculation. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - call iniorbit(apoastr,periastr,year_day,peri_day,obliquit) + call ephemeris_orbit_init(apoastr,periastr,year_day,peri_day,obliquit) @@ -799,5 +799,5 @@ call su_watercycle ! even if we don't have a water cycle, we might - ! need epsi for the wvp definitions in callcorrk.F + ! need epsi for the wvp definitions in rad_correlatedk.F ! or RETV, RLvCp for the thermal plume model @@ -812,5 +812,5 @@ if (corrk) then ! We initialise the spectral grid here instead of - ! at firstcall of callcorrk so we can output XspecIR, XspecVI + ! at firstcall of rad_correlatedk so we can output XspecIR, XspecVI ! when using Dynamico print*, "physiq_mod: Correlated-k data base folder:",trim(datadir) @@ -821,8 +821,8 @@ banddir=trim(trim(adjustl(tmp1))//'x'//trim(adjustl(tmp2))) banddir=trim(trim(adjustl(corrkdir))//'/'//trim(adjustl(banddir))) - call setspi !Basic infrared properties. - call setspv ! Basic visible properties. - call sugas_corrk ! Set up gaseous absorption properties. - call suaer_corrk ! Set up aerosol optical properties. + call rad_correlatedk_init_thermal !Basic infrared properties. + call rad_correlatedk_init_stellar ! Basic visible properties. + call rad_correlatedk_read_opacity_tables ! Set up gaseous absorption properties. + call rad_correlatedk_ini_aerosol ! Set up aerosol optical properties. endif @@ -877,10 +877,10 @@ ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ if (season) then - call stellarlong(zday,zls) + call ephemeris_stellar_longitude(zday,zls) else - call stellarlong(noseason_day,zls) + call ephemeris_stellar_longitude(noseason_day,zls) end if - call orbite(zls,dist_star,declin,right_ascen) + call ephemeris_orbit(zls,dist_star,declin,right_ascen) if (tlocked) then @@ -981,5 +981,5 @@ ztim3=COS(declin)*SIN(zlss) - call stelang(ngrid,sinlon,coslon,sinlat,coslat, & + call ephemeris_stellar_angle(ngrid,sinlon,coslon,sinlat,coslat, & ztim1,ztim2,ztim3,mu0,fract, flatten) @@ -989,5 +989,5 @@ ztim3=-COS(declin)*SIN(2.*pi*(zday-.5)) - call stelang(ngrid,sinlon,coslon,sinlat,coslat, & + call ephemeris_stellar_angle(ngrid,sinlon,coslon,sinlat,coslat, & ztim1,ztim2,ztim3,mu0,fract, flatten) else if(diurnal .eqv. .false.) then @@ -1008,5 +1008,5 @@ ! Eclipse incoming sunlight (e.g. Saturn ring shadowing). if(rings_shadow) then - call call_rings(ngrid, ptime, pday, diurnal) + call rad_ring_shadowing(ngrid, ptime, pday, diurnal) endif @@ -1063,7 +1063,7 @@ endif !(ok_slab_ocean) - ! standard callcorrk + ! standard rad_correlatedk clearsky=.false. - call callcorrk(ngrid,nlayer,pq,nq,qsurf,zls, & + call rad_correlatedk(ngrid,nlayer,pq,nq,qsurf,zls, & albedo,albedo_equivalent,emis,mu0,pplev,pplay,pt, & tsurf,fract,dist_star,aerosol,muvar, & @@ -1094,7 +1094,7 @@ if(CLFvarying)then - ! ---> PROBLEMS WITH ALLOCATED ARRAYS : temporary solution in callcorrk: do not deallocate if CLFvarying ... + ! ---> PROBLEMS WITH ALLOCATED ARRAYS : temporary solution in rad_correlatedk: do not deallocate if CLFvarying ... clearsky=.true. - call callcorrk(ngrid,nlayer,pq,nq,qsurf,zls, & + call rad_correlatedk(ngrid,nlayer,pq,nq,qsurf,zls, & albedo,albedo_equivalent1,emis,mu0,pplev,pplay,pt, & tsurf,fract,dist_star,aerosol,muvar, & @@ -1162,6 +1162,6 @@ ! II.b Call Newtonian cooling scheme ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ! call newtrelax(ngrid,nlayer,mu0,sinlat,zpopsk,pt,pplay,pplev,dtrad,firstcall) - call newtcool_MOCHA(ngrid,nlayer,coslon,coslat,pt,pplay,firstcall,lastcall,dtrad) + ! call rad_netwon_cooling(ngrid,nlayer,mu0,sinlat,zpopsk,pt,pplay,pplev,dtrad,firstcall) + call rad_newton_cooling_MOCHA_intercomparison(ngrid,nlayer,coslon,coslat,pt,pplay,firstcall,lastcall,dtrad) zdtsurf(1:ngrid) = +(pt(1:ngrid,1)-tsurf(1:ngrid))/ptimestep @@ -2299,5 +2299,5 @@ reffcol(1:ngrid,1:naerkind)=0.0 if(co2cond.and.(iaero_co2.ne.0))then - call co2_reffrad(ngrid,nlayer,nq,zq,reffrad(1,1,iaero_co2)) + call aerosol_radius_co2(ngrid,nlayer,nq,zq,reffrad(1,1,iaero_co2)) do ig=1,ngrid reffcol(ig,iaero_co2) = SUM(zq(ig,1:nlayer,igcm_co2_ice)*reffrad(ig,1:nlayer,iaero_co2)*mass(ig,1:nlayer)) Index: trunk/LMDZ.GENERIC/libf/phygeneric/rad_blackbody.F =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/rad_blackbody.F (revision 4077) +++ trunk/LMDZ.GENERIC/libf/phygeneric/rad_blackbody.F (revision 4077) @@ -0,0 +1,43 @@ + subroutine rad_blackbody_planck_law_wavelength(blalong,blat,blae) + + implicit double precision (a-h,o-z) + + ! physical constants + sigma=5.670374D-8 + pi=datan(1.d0)*4.d0 + c0=2.997925d+08 + h=6.62607d-34 + cbol=1.380649d-23 + rind=1.d0 + c=c0/rind + c1=h*(c**2) + c2=h*c/cbol + + + blae=2.d0*pi*c1/blalong**5/(dexp(c2/blalong/blat)-1.d0) + + + return + end + + subroutine rad_blackbody_planck_law_wavenumber(blalong,blat,blae) + + implicit double precision (a-h,o-z) + + ! physical constants + sigma=5.670374D-8 + pi=datan(1.d0)*4.d0 + c0=2.997925d+08 + h=6.62607d-34 + cbol=1.380649d-23 + rind=1.d0 + c=c0/rind + c1=h*(c**2) + c2=h*c/cbol + + + blae=2.d0*pi*c1*blalong**3/(dexp(c2*blalong/blat)-1.d0) + + + return + end Index: trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk.F90 (revision 4077) +++ trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk.F90 (revision 4077) @@ -0,0 +1,1362 @@ +MODULE rad_correlatedk_mod + +IMPLICIT NONE + +CONTAINS + + subroutine rad_correlatedk(ngrid,nlayer,pq,nq,qsurf,zls, & + albedo,albedo_equivalent,emis,mu0,pplev,pplay,pt, & + tsurf,fract,dist_star,aerosol,muvar, & + dtlw,dtsw,fluxsurf_lw, & + fluxsurf_sw,fluxsurfabs_sw,fluxtop_lw, & + fluxabs_sw,fluxtop_dn, & + OLR_nu,OSR_nu,GSR_nu, & + int_dtaui,int_dtauv, & + tau_col,cloudfrac,totcloudfrac, & + clearsky,p_var,frac_var,firstcall,lastcall) + + use mod_phys_lmdz_para, only : is_master + use radinc_h, only: L_NSPECTV, L_NSPECTI, naerkind, banddir, corrkdir,& + L_LEVELS, L_NGAUSS, L_NLEVRAD, L_NLAYRAD, L_REFVAR + use radcommon_h, only: wrefvar, Cmk, fzeroi, fzerov, gasi, gasv, & + glat_ig, gweight, pfgasref, pgasmax, pgasmin, & + pgasref, tgasmax, tgasmin, tgasref, scalep, & + ubari, wnoi, stellarf, glat, dwnv, dwni + use watercommon_h, only: psat_water, epsi + use datafile_mod, only: datadir + use ioipsl_getin_p_mod, only: getin_p + use gases_h, only: ngasmx + use aerosol_radius, only : aerosol_radius_init,aerosol_radius_co2,h2o_reffrad, & + aerosol_radius_dust,aerosol_radius_h2so4,aerosol_radius_back2lay + use aerosol_global_variables , only : iaero_co2,iaero_h2o,iaero_dust,iaero_h2so4, & + iaero_back2lay, iaero_aurora, & + iaero_venus1,iaero_venus2,iaero_venus2p, & + iaero_venus3,iaero_venusUV + use aerosol_opacity_mod, only: aerosol_opacity + use aerosol_optical_properties_mod, only: aerosol_optical_properties + use tracer_h, only: igcm_h2o_ice, igcm_h2o_vap, igcm_co2_ice + use tracer_h, only: constants_epsi_generic + use comcstfi_mod, only: pi, mugaz, cpp + use callkeys_mod, only: varactive,diurnal,tracer,water,varfixed,satval, & + diagdtau,kastprof,strictboundcorrk,specOLR, & + CLFvarying,tplanckmin,tplanckmax,global1d, & + generic_condensation, aerovenus, nvarlayer, varspec + use rad_correlatedk_opacities_stellar_mod, & + only: rad_correlatedk_opacities_stellar + use rad_correlatedk_opacities_thermal_mod, & + only: rad_correlatedk_opacities_thermal + use rad_correlatedk_fluxes_thermal_mod, & + only: rad_correlatedk_fluxes_thermal + use rad_correlatedk_fluxes_stellar_mod, & + only: rad_correlatedk_fluxes_stellar + use rad_correlatedk_online_recombination_mod, & + only: corrk_recombin, & + rad_correlatedk_recombination_main + use pindex_mod, only: pindex + use generic_cloud_common_h, only: Psat_generic, epsi_generic + use generic_tracer_index_mod, only: generic_tracer_index + use planetwide_mod, only: planetwide_maxval, planetwide_minval + implicit none + +!================================================================== +! +! Purpose +! ------- +! Solve the radiative transfer using the correlated-k method for +! the gaseous absorption and the Toon et al. (1989) method for +! scatttering due to aerosols. +! +! Authors +! ------- +! Emmanuel 01/2001, Forget 09/2001 +! Robin Wordsworth (2009) +! +!================================================================== + +!----------------------------------------------------------------------- +! Declaration of the arguments (INPUT - OUTPUT) on the LMD GCM grid +! Layer #1 is the layer near the ground. +! Layer #nlayer is the layer at the top. +!----------------------------------------------------------------------- + + + ! INPUT + INTEGER,INTENT(IN) :: ngrid ! Number of atmospheric columns. + INTEGER,INTENT(IN) :: nlayer ! Number of atmospheric layers. + REAL,INTENT(IN) :: pq(ngrid,nlayer,nq) ! Tracers (kg/kg_of_air). + INTEGER,INTENT(IN) :: nq ! Number of tracers. + REAL,INTENT(IN) :: qsurf(ngrid,nq) ! Tracers on surface (kg.m-2). + REAL,INTENT(IN) :: zls ! Stellar longitude (rad). + REAL,INTENT(IN) :: albedo(ngrid,L_NSPECTV) ! Spectral Short Wavelengths Albedo. By MT2015 + REAL,INTENT(IN) :: emis(ngrid) ! Long Wave emissivity. + REAL,INTENT(IN) :: mu0(ngrid) ! Cosine of sun incident angle. + REAL,INTENT(IN) :: pplev(ngrid,nlayer+1) ! Inter-layer pressure (Pa). + REAL,INTENT(IN) :: pplay(ngrid,nlayer) ! Mid-layer pressure (Pa). + REAL,INTENT(IN) :: pt(ngrid,nlayer) ! Air temperature (K). + REAL,INTENT(IN) :: tsurf(ngrid) ! Surface temperature (K). + REAL,INTENT(IN) :: fract(ngrid) ! Fraction of day. + REAL,INTENT(IN) :: dist_star ! Distance star-planet (AU). + REAL,INTENT(IN) :: muvar(ngrid,nlayer+1) + REAL,INTENT(IN) :: cloudfrac(ngrid,nlayer) ! Fraction of clouds (%). + REAL,INTENT(IN) :: frac_var(nvarlayer,ngasmx)! Variable molar fraction. + REAL,INTENT(IN) :: p_var(nvarlayer) ! Pressure for frac_var interpolation (Pa) + logical,intent(in) :: clearsky + logical,intent(in) :: firstcall ! Signals first call to physics. + logical,intent(in) :: lastcall ! Signals last call to physics. + + ! OUTPUT + REAL,INTENT(OUT) :: aerosol(ngrid,nlayer,naerkind) ! Aerosol tau at reference wavelenght. + REAL,INTENT(OUT) :: dtlw(ngrid,nlayer) ! Heating rate (K/s) due to LW radiation. + REAL,INTENT(OUT) :: dtsw(ngrid,nlayer) ! Heating rate (K/s) due to SW radiation. + REAL,INTENT(OUT) :: fluxsurf_lw(ngrid) ! Incident LW flux to surf (W/m2). + REAL,INTENT(OUT) :: fluxsurf_sw(ngrid) ! Incident SW flux to surf (W/m2) + REAL,INTENT(OUT) :: fluxsurfabs_sw(ngrid) ! Absorbed SW flux by the surface (W/m2). By MT2015. + REAL,INTENT(OUT) :: fluxtop_lw(ngrid) ! Outgoing LW flux to space (W/m2). + REAL,INTENT(OUT) :: fluxabs_sw(ngrid) ! SW flux absorbed by the planet (W/m2). + REAL,INTENT(OUT) :: fluxtop_dn(ngrid) ! Incident top of atmosphere SW flux (W/m2). + REAL,INTENT(OUT) :: OLR_nu(ngrid,L_NSPECTI) ! Outgoing LW radiation in each band (Normalized to the band width (W/m2/cm-1). + REAL,INTENT(OUT) :: OSR_nu(ngrid,L_NSPECTV) ! Outgoing SW radiation in each band (Normalized to the band width (W/m2/cm-1). + REAL,INTENT(OUT) :: GSR_nu(ngrid,L_NSPECTV) ! Surface SW radiation in each band (Normalized to the band width (W/m2/cm-1). + REAL,INTENT(OUT) :: tau_col(ngrid) ! Diagnostic from aerosol_opacity. + REAL,INTENT(OUT) :: albedo_equivalent(ngrid) ! Spectrally Integrated Albedo. For Diagnostic. By MT2015 + REAL,INTENT(OUT) :: totcloudfrac(ngrid) ! Column Fraction of clouds (%). + REAL,INTENT(OUT) :: int_dtaui(ngrid,nlayer,L_NSPECTI) ! VI optical thickness of layers within narrowbands for diags (). + REAL,INTENT(OUT) :: int_dtauv(ngrid,nlayer,L_NSPECTV) ! IR optical thickness of layers within narrowbands for diags (). + + + + + +! Globally varying aerosol optical properties on GCM grid ; not needed everywhere so not in radcommon_h. +! made "save" variables so they are allocated once in for all, not because +! the values need be saved from a time step to the next + REAL,SAVE,ALLOCATABLE :: QVISsQREF3d(:,:,:,:) + REAL,SAVE,ALLOCATABLE :: omegaVIS3d(:,:,:,:) + REAL,SAVE,ALLOCATABLE :: gVIS3d(:,:,:,:) +!$OMP THREADPRIVATE(QVISsQREF3d,omegaVIS3d,gVIS3d) + REAL,SAVE,ALLOCATABLE :: QIRsQREF3d(:,:,:,:) + REAL,SAVE,ALLOCATABLE :: omegaIR3d(:,:,:,:) + REAL,SAVE,ALLOCATABLE :: gIR3d(:,:,:,:) +!$OMP THREADPRIVATE(QIRsQREF3d,omegaIR3d,gIR3d) + +! REAL :: omegaREFvis3d(ngrid,nlayer,naerkind) +! REAL :: omegaREFir3d(ngrid,nlayer,naerkind) ! not sure of the point of these... + + REAL,ALLOCATABLE,SAVE :: reffrad(:,:,:) ! aerosol effective radius (m) + REAL,ALLOCATABLE,SAVE :: nueffrad(:,:,:) ! aerosol effective variance +!$OMP THREADPRIVATE(reffrad,nueffrad) + +!----------------------------------------------------------------------- +! Declaration of the variables required by correlated-k subroutines +! Numbered from top to bottom (unlike in the GCM) +!----------------------------------------------------------------------- + + REAL*8 tmid(L_LEVELS),pmid(L_LEVELS) + REAL*8 tlevrad(L_LEVELS),plevrad(L_LEVELS) + + ! Optical values for the rad_correlatedk_opacities_thermal/cv subroutines + REAL*8 stel(L_NSPECTV),stel_fract(L_NSPECTV) + ! NB: Arrays below are "save" to avoid reallocating them at every call + ! not because their content needs be reused from call to the next + REAL*8,allocatable,save :: dtaui(:,:,:) + REAL*8,allocatable,save :: dtauv(:,:,:) + REAL*8,allocatable,save :: cosbv(:,:,:) + REAL*8,allocatable,save :: cosbi(:,:,:) + REAL*8,allocatable,save :: wbari(:,:,:) + REAL*8,allocatable,save :: wbarv(:,:,:) +!$OMP THREADPRIVATE(dtaui,dtauv,cosbv,cosbi,wbari,wbarv) + REAL*8,allocatable,save :: tauv(:,:,:) + REAL*8,allocatable,save :: taucumv(:,:,:) + REAL*8,allocatable,save :: taucumi(:,:,:) +!$OMP THREADPRIVATE(tauv,taucumv,taucumi) + REAL*8,allocatable,save :: tauaero(:,:) +!$OMP THREADPRIVATE(tauaero) + REAL*8 nfluxtopv,nfluxtopi,nfluxtop,fluxtopvdn + REAL*8 nfluxoutv_nu(L_NSPECTV) ! Outgoing band-resolved VI flux at TOA (W/m2). + REAL*8 nfluxtopi_nu(L_NSPECTI) ! Net band-resolved IR flux at TOA (W/m2). + REAL*8 fluxupi_nu(L_NLAYRAD,L_NSPECTI) ! For 1D diagnostic. + REAL*8 fmneti(L_NLAYRAD),fmnetv(L_NLAYRAD) + REAL*8 fluxupv(L_NLAYRAD),fluxupi(L_NLAYRAD) + REAL*8 fluxdnv(L_NLAYRAD),fluxdni(L_NLAYRAD) + REAL*8 albi,acosz + REAL*8 albv(L_NSPECTV) ! Spectral Visible Albedo. + + INTEGER ig,l,k,nw,iaer,iq + + real*8,allocatable,save :: taugsurf(:,:) + real*8,allocatable,save :: taugsurfi(:,:) +!$OMP THREADPRIVATE(taugsurf,taugsurfi) + real*8 qvar(L_LEVELS) ! Mixing ratio of variable component (mol/mol). index 1 is the top of the atmosphere, index L_LEVELS is the bottom + + ! Local aerosol optical properties for each column on RADIATIVE grid. + real*8,save,allocatable :: QXVAER(:,:,:) ! Extinction coeff (QVISsQREF*QREFvis) + real*8,save,allocatable :: QSVAER(:,:,:) + real*8,save,allocatable :: GVAER(:,:,:) + real*8,save,allocatable :: QXIAER(:,:,:) ! Extinction coeff (QIRsQREF*QREFir) + real*8,save,allocatable :: QSIAER(:,:,:) + real*8,save,allocatable :: GIAER(:,:,:) +!$OMP THREADPRIVATE(QXVAER,QSVAER,GVAER,QXIAER,QSIAER,GIAER) + real, dimension(:,:,:), save, allocatable :: QREFvis3d + real, dimension(:,:,:), save, allocatable :: QREFir3d +!$OMP THREADPRIVATE(QREFvis3d,QREFir3d) + + + ! Miscellaneous : + real*8 temp,temp1,temp2,pweight + character(len=10) :: tmp1 + character(len=10) :: tmp2 + character(len=100) :: message + character(len=10),parameter :: subname="rad_correlatedk" + + ! For fixed water vapour profiles. + integer i_var + real RH + real*8 pq_temp(nlayer) +! real(KIND=r8) :: pq_temp(nlayer) ! better F90 way.. DOESNT PORT TO F77!!! + real psat,qsat + + logical OLRz + real*8 NFLUXGNDV_nu(L_NSPECTV) + + ! Included by RW for runaway greenhouse 1D study. + real vtmp(nlayer) + REAL*8 muvarrad(L_LEVELS) + + ! Included by MT for albedo calculations. + REAL*8 albedo_temp(L_NSPECTV) ! For equivalent albedo calculation. + REAL*8 surface_stellar_flux ! Stellar flux reaching the surface. Useful for equivalent albedo calculation. + + ! local variable + integer ok ! status (returned by NetCDF functions) + + integer igcm_generic_vap, igcm_generic_ice! index of the vap and ice of generic_tracer + logical call_ice_vap_generic ! to call only one time the ice/vap pair of a tracer + real, save :: metallicity ! metallicity of planet --- is not used here, but necessary to call function Psat_generic +!$OMP THREADPRIVATE(metallicity) + REAL, SAVE :: qvap_deep ! deep mixing ratio of water vapor when simulating bottom less planets +!$OMP THREADPRIVATE(qvap_deep) + + REAL :: maxvalue,minvalue + + real :: frac_vari(L_LEVELS) + real :: fracvari(ngasmx,L_LEVELS) + +!=============================================================== +! I.a Initialization on first call +!=============================================================== + + + if(firstcall) then + + ! test on allocated necessary because of CLFvarying (two calls to rad_correlatedk in physiq) + if(.not.allocated(QVISsQREF3d)) then + allocate(QVISsQREF3d(ngrid,nlayer,L_NSPECTV,naerkind)) + endif + if(.not.allocated(omegaVIS3d)) then + allocate(omegaVIS3d(ngrid,nlayer,L_NSPECTV,naerkind)) + endif + if(.not.allocated(gVIS3d)) then + allocate(gVIS3d(ngrid,nlayer,L_NSPECTV,naerkind)) + endif + if (.not.allocated(QIRsQREF3d)) then + allocate(QIRsQREF3d(ngrid,nlayer,L_NSPECTI,naerkind)) + endif + if (.not.allocated(omegaIR3d)) then + allocate(omegaIR3d(ngrid,nlayer,L_NSPECTI,naerkind)) + endif + if (.not.allocated(gIR3d)) then + allocate(gIR3d(ngrid,nlayer,L_NSPECTI,naerkind)) + endif + if (.not.allocated(tauaero)) then + allocate(tauaero(L_LEVELS,naerkind)) + endif + + if(.not.allocated(QXVAER)) then + allocate(QXVAER(L_LEVELS,L_NSPECTV,naerkind), stat=ok) + if (ok /= 0) then + write(*,*) "memory allocation failed for QXVAER!" + call abort_physic(subname,'allocation failure for QXVAER',1) + endif + endif + if(.not.allocated(QSVAER)) then + allocate(QSVAER(L_LEVELS,L_NSPECTV,naerkind), stat=ok) + if (ok /= 0) then + write(*,*) "memory allocation failed for QSVAER!" + call abort_physic(subname,'allocation failure for QSVAER',1) + endif + endif + if(.not.allocated(GVAER)) then + allocate(GVAER(L_LEVELS,L_NSPECTV,naerkind), stat=ok) + if (ok /= 0) then + write(*,*) "memory allocation failed for GVAER!" + call abort_physic(subname,'allocation failure for GVAER',1) + endif + endif + if(.not.allocated(QXIAER)) then + allocate(QXIAER(L_LEVELS,L_NSPECTI,naerkind), stat=ok) + if (ok /= 0) then + write(*,*) "memory allocation failed for QXIAER!" + call abort_physic(subname,'allocation failure for QXIAER',1) + endif + endif + if(.not.allocated(QSIAER)) then + allocate(QSIAER(L_LEVELS,L_NSPECTI,naerkind), stat=ok) + if (ok /= 0) then + write(*,*) "memory allocation failed for QSIAER!" + call abort_physic(subname,'allocation failure for QSIAER',1) + endif + endif + if(.not.allocated(GIAER)) then + allocate(GIAER(L_LEVELS,L_NSPECTI,naerkind), stat=ok) + if (ok /= 0) then + write(*,*) "memory allocation failed for GIAER!" + call abort_physic(subname,'allocation failure for GIAER',1) + endif + endif + + !!! ALLOCATED instances are necessary because of CLFvarying (strategy to call rad_correlatedk twice in physiq...) + IF(.not.ALLOCATED(QREFvis3d))THEN + ALLOCATE(QREFvis3d(ngrid,nlayer,naerkind), stat=ok) + IF (ok/=0) THEN + write(*,*) "memory allocation failed for QREFvis3d!" + call abort_physic(subname,'allocation failure for QREFvis3d',1) + ENDIF + ENDIF + IF(.not.ALLOCATED(QREFir3d)) THEN + ALLOCATE(QREFir3d(ngrid,nlayer,naerkind), stat=ok) + IF (ok/=0) THEN + write(*,*) "memory allocation failed for QREFir3d!" + call abort_physic(subname,'allocation failure for QREFir3d',1) + ENDIF + ENDIF + ! Effective radius and variance of the aerosols + IF(.not.ALLOCATED(reffrad)) THEN + allocate(reffrad(ngrid,nlayer,naerkind), stat=ok) + IF (ok/=0) THEN + write(*,*) "memory allocation failed for reffrad!" + call abort_physic(subname,'allocation failure for reffrad',1) + ENDIF + ENDIF + IF(.not.ALLOCATED(nueffrad)) THEN + allocate(nueffrad(ngrid,nlayer,naerkind), stat=ok) + IF (ok/=0) THEN + write(*,*) "memory allocation failed for nueffrad!" + call abort_physic(subname,'allocation failure for nueffrad',1) + ENDIF + ENDIF + +#ifndef MESOSCALE + if (is_master) call system('rm -f surf_vals_long.out') +#endif + + call aerosol_radius_init(ngrid,nlayer,reffrad,nueffrad) + + +!-------------------------------------------------- +! Set up correlated k +!-------------------------------------------------- + + !this block is now done at firstcall of physiq_mod + ! print*, "rad_correlatedk: Correlated-k data base folder:",trim(datadir) + ! call getin_p("corrkdir",corrkdir) + ! print*, "corrkdir = ",corrkdir + ! write( tmp1, '(i3)' ) L_NSPECTI + ! write( tmp2, '(i3)' ) L_NSPECTV + ! banddir=trim(adjustl(tmp1))//'x'//trim(adjustl(tmp2)) + ! banddir=trim(adjustl(corrkdir))//'/'//trim(adjustl(banddir)) + + ! call rad_correlatedk_init_thermal ! Basic infrared properties. + ! call rad_correlatedk_init_stellar ! Basic visible properties. + ! call rad_correlatedk_read_opacity_tables ! Set up gaseous absorption properties. + ! call rad_correlatedk_ini_aerosol ! Set up aerosol optical properties. + + + ! now that L_NGAUSS has been initialized (by rad_correlatedk_read_opacity_tables ) + ! allocate related arrays + if(.not.allocated(dtaui)) then + ALLOCATE(dtaui(L_NLAYRAD,L_NSPECTI,L_NGAUSS), stat=ok) + if (ok/=0) then + write(*,*) "memory allocation failed for dtaui!" + call abort_physic(subname,'allocation failure for dtaui',1) + endif + endif + if(.not.allocated(dtauv)) then + ALLOCATE(dtauv(L_NLAYRAD,L_NSPECTV,L_NGAUSS), stat=ok) + if (ok/=0) then + write(*,*) "memory allocation failed for dtauv!" + call abort_physic(subname,'allocation failure for dtauv',1) + endif + endif + if(.not.allocated(cosbv)) then + ALLOCATE(cosbv(L_NLAYRAD,L_NSPECTV,L_NGAUSS), stat=ok) + if (ok/=0) then + write(*,*) "memory allocation failed for cosbv!" + call abort_physic(subname,'allocation failure for cobsv',1) + endif + endif + if(.not.allocated(cosbi)) then + ALLOCATE(cosbi(L_NLAYRAD,L_NSPECTI,L_NGAUSS), stat=ok) + if (ok/=0) then + write(*,*) "memory allocation failed for cosbi!" + call abort_physic(subname,'allocation failure for cobsi',1) + endif + endif + if(.not.allocated(wbari)) then + ALLOCATE(wbari(L_NLAYRAD,L_NSPECTI,L_NGAUSS), stat=ok) + if (ok/=0) then + write(*,*) "memory allocation failed for wbari!" + call abort_physic(subname,'allocation failure for wbari',1) + endif + endif + if(.not.allocated(wbarv)) then + ALLOCATE(wbarv(L_NLAYRAD,L_NSPECTV,L_NGAUSS), stat=ok) + if (ok/=0) then + write(*,*) "memory allocation failed for wbarv!" + call abort_physic(subname,'allocation failure for wbarv',1) + endif + endif + if(.not.allocated(tauv)) then + ALLOCATE(tauv(L_NLEVRAD,L_NSPECTV,L_NGAUSS), stat=ok) + if (ok/=0) then + write(*,*) "memory allocation failed for tauv!" + call abort_physic(subname,'allocation failure for tauv',1) + endif + endif + if(.not.allocated(taucumv)) then + ALLOCATE(taucumv(L_LEVELS,L_NSPECTV,L_NGAUSS), stat=ok) + if (ok/=0) then + write(*,*) "memory allocation failed for taucumv!" + call abort_physic(subname,'allocation failure for taucumv',1) + endif + endif + if(.not.allocated(taucumi)) then + ALLOCATE(taucumi(L_LEVELS,L_NSPECTI,L_NGAUSS), stat=ok) + if (ok/=0) then + write(*,*) "memory allocation failed for taucumi!" + call abort_physic(subname,'allocation failure for taucumi',1) + endif + endif + if(.not.allocated(taugsurf)) then + ALLOCATE(taugsurf(L_NSPECTV,L_NGAUSS-1), stat=ok) + if (ok/=0) then + write(*,*) "memory allocation failed for taugsurf!" + call abort_physic(subname,'allocation failure for taugsurf',1) + endif + endif + if(.not.allocated(taugsurfi)) then + ALLOCATE(taugsurfi(L_NSPECTI,L_NGAUSS-1), stat=ok) + if (ok/=0) then + write(*,*) "memory allocation failed for taugsurfi!" + call abort_physic(subname,'allocation failure for taugsurfi',1) + endif + endif + + if((igcm_h2o_vap.eq.0) .and. varactive .and. water)then + message='varactive in rad_correlatedk but no h2o_vap tracer.' + call abort_physic(subname,message,1) + endif + + if(varfixed .and. generic_condensation .and. .not. water)then + write(*,*) "Deep generic tracer vapor mixing ratio ? (no effect if negative) " + qvap_deep=-1. ! default value + call getin_p("qvap_deep",qvap_deep) + write(*,*) " qvap_deep = ",qvap_deep + + metallicity=0.0 ! default value --- is not used here but necessary to call function Psat_generic + call getin_p("metallicity",metallicity) ! --- is not used here but necessary to call function Psat_generic + endif + + end if ! of if (firstcall) + +!======================================================================= +! I.b Initialization on every call +!======================================================================= + + qxvaer(:,:,:)=0.0 + qsvaer(:,:,:)=0.0 + gvaer(:,:,:) =0.0 + + qxiaer(:,:,:)=0.0 + qsiaer(:,:,:)=0.0 + giaer(:,:,:) =0.0 + + OLR_nu(:,:) = 0. + OSR_nu(:,:) = 0. + GSR_nu(:,:) = 0. + +!-------------------------------------------------- +! Effective radius and variance of the aerosols +!-------------------------------------------------- + + do iaer=1,naerkind + + if ((iaer.eq.iaero_co2).and.tracer.and.(igcm_co2_ice.gt.0)) then ! Treat condensed co2 particles. + call aerosol_radius_co2(ngrid,nlayer,nq,pq,reffrad(1,1,iaero_co2)) + + call planetwide_maxval(reffrad(:,:,iaero_co2),maxvalue) + call planetwide_minval(reffrad(:,:,iaero_co2),minvalue) + if (is_master) then + print*,'Max. CO2 ice particle size = ',maxvalue/1.e-6,' um' + print*,'Min. CO2 ice particle size = ',minvalue/1.e-6,' um' + end if + end if + + if ((iaer.eq.iaero_h2o).and.water) then ! Treat condensed water particles. To be generalized for other aerosols ... + call h2o_reffrad(ngrid,nlayer,pq(1,1,igcm_h2o_ice),pt, & + reffrad(1,1,iaero_h2o),nueffrad(1,1,iaero_h2o)) + + call planetwide_maxval(reffrad(:,:,iaero_h2o),maxvalue) + call planetwide_minval(reffrad(:,:,iaero_h2o),minvalue) + if (is_master) then + print*,'Max. H2O cloud particle size = ',maxvalue/1.e-6,' um' + print*,'Min. H2O cloud particle size = ',minvalue/1.e-6,' um' + end if + +! Currently the variance is constant everywhere (see h2o_reffrad), +! so no need to compute and print min/max +! call planetwide_maxval(nueffrad(:,:,iaero_h2o),maxvalue) +! call planetwide_minval(nueffrad(:,:,iaero_h2o),minvalue) +! if (is_master) then +! print*,'Max. H2O cloud particle variance = ',maxvalue +! print*,'Min. H2O cloud particle variance = ',minvalue +! end if + endif + + if(iaer.eq.iaero_dust)then + call aerosol_radius_dust(ngrid,nlayer,reffrad(1,1,iaero_dust)) + if (is_master) then + print*,'Dust particle size = ',reffrad(1,1,iaer)/1.e-6,' um' + end if + endif + + if(iaer.eq.iaero_h2so4)then + call aerosol_radius_h2so4(ngrid,nlayer,reffrad(1,1,iaero_h2so4)) + if (is_master) then + print*,'H2SO4 particle size =',reffrad(1,1,iaer)/1.e-6,' um' + end if + endif + + if(iaer.eq.iaero_back2lay)then + call aerosol_radius_back2lay(ngrid,reffrad(1,1,iaero_back2lay),nlayer,pplev) + endif + + ! For n-layer aerosol size set once for all at firstcall in aerosol_radius_init + +! if(iaer.eq.iaero_aurora)then +! call aurora_reffrad(ngrid,nlayer,reffrad(1,1,iaero_aurora)) +! endif + + end do !iaer=1,naerkind. + + + ! How much light do we get ? + do nw=1,L_NSPECTV + stel(nw)=stellarf(nw)/(dist_star**2) + end do + + ! Get 3D aerosol optical properties. + call aerosol_optical_properties(ngrid,nlayer,reffrad,nueffrad, & + QVISsQREF3d,omegaVIS3d,gVIS3d, & + QIRsQREF3d,omegaIR3d,gIR3d, & + QREFvis3d,QREFir3d) + + ! Get aerosol optical depths. + call aerosol_opacity(ngrid,nlayer,nq,pplay,pplev,pt,pq,zls,aerosol, & + reffrad,nueffrad,QREFvis3d,QREFir3d, & + tau_col,cloudfrac,totcloudfrac,clearsky) + +!----------------------------------------------------------------------- + do ig=1,ngrid ! Starting Big Loop over every GCM column +!----------------------------------------------------------------------- + + +!======================================================================= +! II. Transformation of the GCM variables +!======================================================================= + + +!----------------------------------------------------------------------- +! Aerosol optical properties Qext, Qscat and g. +! The transformation in the vertical is the same as for temperature. +!----------------------------------------------------------------------- + + + do iaer=1,naerkind + ! Shortwave. + do nw=1,L_NSPECTV + + do l=1,nlayer + + temp1=QVISsQREF3d(ig,nlayer+1-l,nw,iaer) & + *QREFvis3d(ig,nlayer+1-l,iaer) + + temp2=QVISsQREF3d(ig,max(nlayer-l,1),nw,iaer) & + *QREFvis3d(ig,max(nlayer-l,1),iaer) + + qxvaer(2*l,nw,iaer) = temp1 + qxvaer(2*l+1,nw,iaer)=(temp1+temp2)/2 + + temp1=temp1*omegavis3d(ig,nlayer+1-l,nw,iaer) + temp2=temp2*omegavis3d(ig,max(nlayer-l,1),nw,iaer) + + qsvaer(2*l,nw,iaer) = temp1 + qsvaer(2*l+1,nw,iaer)=(temp1+temp2)/2 + + temp1=gvis3d(ig,nlayer+1-l,nw,iaer) + temp2=gvis3d(ig,max(nlayer-l,1),nw,iaer) + + gvaer(2*l,nw,iaer) = temp1 + gvaer(2*l+1,nw,iaer)=(temp1+temp2)/2 + + end do ! nlayer + + qxvaer(1,nw,iaer)=qxvaer(2,nw,iaer) + qxvaer(2*nlayer+1,nw,iaer)=0. + + qsvaer(1,nw,iaer)=qsvaer(2,nw,iaer) + qsvaer(2*nlayer+1,nw,iaer)=0. + + gvaer(1,nw,iaer)=gvaer(2,nw,iaer) + gvaer(2*nlayer+1,nw,iaer)=0. + + end do ! L_NSPECTV + + do nw=1,L_NSPECTI + ! Longwave + do l=1,nlayer + + temp1=QIRsQREF3d(ig,nlayer+1-l,nw,iaer) & + *QREFir3d(ig,nlayer+1-l,iaer) + + temp2=QIRsQREF3d(ig,max(nlayer-l,1),nw,iaer) & + *QREFir3d(ig,max(nlayer-l,1),iaer) + + qxiaer(2*l,nw,iaer) = temp1 + qxiaer(2*l+1,nw,iaer)=(temp1+temp2)/2 + + temp1=temp1*omegair3d(ig,nlayer+1-l,nw,iaer) + temp2=temp2*omegair3d(ig,max(nlayer-l,1),nw,iaer) + + qsiaer(2*l,nw,iaer) = temp1 + qsiaer(2*l+1,nw,iaer)=(temp1+temp2)/2 + + temp1=gir3d(ig,nlayer+1-l,nw,iaer) + temp2=gir3d(ig,max(nlayer-l,1),nw,iaer) + + giaer(2*l,nw,iaer) = temp1 + giaer(2*l+1,nw,iaer)=(temp1+temp2)/2 + + end do ! nlayer + + qxiaer(1,nw,iaer)=qxiaer(2,nw,iaer) + qxiaer(2*nlayer+1,nw,iaer)=0. + + qsiaer(1,nw,iaer)=qsiaer(2,nw,iaer) + qsiaer(2*nlayer+1,nw,iaer)=0. + + giaer(1,nw,iaer)=giaer(2,nw,iaer) + giaer(2*nlayer+1,nw,iaer)=0. + + end do ! L_NSPECTI + + end do ! naerkind + + ! Test / Correct for freaky s. s. albedo values. + do iaer=1,naerkind + do k=1,L_LEVELS + + do nw=1,L_NSPECTV + if(qsvaer(k,nw,iaer).gt.1.05*qxvaer(k,nw,iaer))then + message='Serious problems with qsvaer values' + call abort_physic(subname,message,1) + endif + if(qsvaer(k,nw,iaer).gt.qxvaer(k,nw,iaer))then + qsvaer(k,nw,iaer)=qxvaer(k,nw,iaer) + endif + end do + + do nw=1,L_NSPECTI + if(qsiaer(k,nw,iaer).gt.1.05*qxiaer(k,nw,iaer))then + message='Serious problems with qsvaer values' + call abort_physic(subname,message,1) + endif + if(qsiaer(k,nw,iaer).gt.qxiaer(k,nw,iaer))then + qsiaer(k,nw,iaer)=qxiaer(k,nw,iaer) + endif + end do + + end do ! L_LEVELS + end do ! naerkind + +!----------------------------------------------------------------------- +! Aerosol optical depths +!----------------------------------------------------------------------- + + do iaer=1,naerkind ! a bug was here + do k=0,nlayer-1 + + pweight=(pplay(ig,L_NLAYRAD-k)-pplev(ig,L_NLAYRAD-k+1))/ & + (pplev(ig,L_NLAYRAD-k)-pplev(ig,L_NLAYRAD-k+1)) + ! As 'aerosol' is at reference (visible) wavelenght we scale it as + ! it will be multplied by qxi/v in rad_correlatedk_opacities_thermal/v + temp=aerosol(ig,L_NLAYRAD-k,iaer)/QREFvis3d(ig,L_NLAYRAD-k,iaer) + tauaero(2*k+2,iaer)=max(temp*pweight,0.d0) + tauaero(2*k+3,iaer)=max(temp-tauaero(2*k+2,iaer),0.d0) + + end do + ! boundary conditions + tauaero(1,iaer) = tauaero(2,iaer) + !tauaero(1,iaer) = 0. + !JL18 at time of testing, the two above conditions gave the same results bit for bit. + + end do ! naerkind + + ! Albedo and Emissivity. + albi=1-emis(ig) ! Long Wave. + DO nw=1,L_NSPECTV ! Short Wave loop. + albv(nw)=albedo(ig,nw) + ENDDO + + acosz=mu0(ig) ! Cosine of sun incident angle : 3D simulations or local 1D simulations using latitude. + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!! Note by JL13 : In the following, some indices were changed in the interpolations, +!!! so that the model results are less dependent on the number of layers ! +!!! +!!! --- The older versions are commented with the comment !JL13index --- +!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + !----------------------------------------------------------------------- + ! Water vapour (to be generalised for other gases eventually ...) + !----------------------------------------------------------------------- + + if (water) then + if(varactive)then + + i_var=igcm_h2o_vap + do l=1,nlayer + qvar(2*l) = pq(ig,nlayer+1-l,i_var) + qvar(2*l+1) = pq(ig,nlayer+1-l,i_var) + !JL13index qvar(2*l+1) = (pq(ig,nlayer+1-l,i_var)+pq(ig,max(nlayer-l,1),i_var))/2 + !JL13index Average approximation as for temperature... + end do + qvar(1)=qvar(2) + + elseif(varfixed)then + + do l=1,nlayer ! Here we will assign fixed water vapour profiles globally. + RH = satval * ((pplay(ig,l)/pplev(ig,1) - 0.02) / 0.98) + if(RH.lt.0.0) RH=0.0 + + call Psat_water(pt(ig,l),pplay(ig,l),psat,qsat) + + !pq_temp(l) = qsat ! fully saturated everywhere + pq_temp(l) = RH * qsat ! ~realistic profile (e.g. 80% saturation at ground) + end do + + do l=1,nlayer + qvar(2*l) = pq_temp(nlayer+1-l) + qvar(2*l+1) = (pq_temp(nlayer+1-l)+pq_temp(max(nlayer-l,1)))/2 + end do + + qvar(1)=qvar(2) + + ! Lowest layer of atmosphere + RH = satval * (1 - 0.02) / 0.98 + if(RH.lt.0.0) RH=0.0 + + qvar(2*nlayer+1)= RH * qsat ! ~realistic profile (e.g. 80% saturation at ground) + + else + do k=1,L_LEVELS + qvar(k) = 1.0D-7 + end do + end if ! varactive/varfixed + + endif ! if (water) + + !----------------------------------------------------------------------- + ! GCS (Generic Condensable Specie) Vapor + ! If you have GCS tracers and they are : variable & radiatively active + ! + ! NC22 + !----------------------------------------------------------------------- + + if (generic_condensation .and. .not. water ) then + + ! For now, only one GCS tracer can be both variable and radiatively active + ! If you set two GCS tracers, that are variable and radiatively active, + ! the last one in tracer.def will be chosen as the one that will be vadiatively active + + do iq=1,nq + + call generic_tracer_index(nq,iq,igcm_generic_vap,igcm_generic_ice,call_ice_vap_generic) + + if (call_ice_vap_generic) then ! to call only one time the ice/vap pair of a tracer + + if(varactive)then + + i_var=igcm_generic_vap + do l=1,nlayer + qvar(2*l) = pq(ig,nlayer+1-l,i_var) + qvar(2*l+1) = pq(ig,nlayer+1-l,i_var) + !JL13index qvar(2*l+1) = (pq(ig,nlayer+1-l,i_var)+pq(ig,max(nlayer-l,1),i_var))/2 + !JL13index ! Average approximation as for temperature... + end do + qvar(1)=qvar(2) + + elseif(varfixed .and. (qvap_deep .ge. 0))then + + do l=1,nlayer ! Here we will assign fixed water vapour profiles globally. + + call Psat_generic(pt(ig,l),pplay(ig,l),metallicity,psat,qsat) + + if (qsat .lt. qvap_deep) then + pq_temp(l) = qsat ! fully saturated everywhere + else + pq_temp(l) = qvap_deep + end if + + end do + + do l=1,nlayer + qvar(2*l) = pq_temp(nlayer+1-l) + qvar(2*l+1) = (pq_temp(nlayer+1-l)+pq_temp(max(nlayer-l,1)))/2 + end do + + qvar(1)=qvar(2) + + else + do k=1,L_LEVELS + qvar(k) = 1.0D-7 + end do + end if ! varactive/varfixed + + endif + + end do ! do iq=1,nq loop on tracers + + end if ! if (generic_condensation .and. .not. water ) + + !----------------------------------------------------------------------- + ! No Water vapor and No GCS (Generic Condensable Specie) vapor + !----------------------------------------------------------------------- + + if (.not. generic_condensation .and. .not. water ) then + do k=1,L_LEVELS + qvar(k) = 1.0D-7 + end do + end if ! if (.not. generic_condensation .and. .not. water ) + + + if(.not.kastprof)then + ! IMPORTANT: Now convert from kg/kg to mol/mol. + do k=1,L_LEVELS + if (water) then + qvar(k) = qvar(k)/(epsi+qvar(k)*(1.-epsi)) + endif + if (generic_condensation .and. .not. water) then + do iq=1,nq + call generic_tracer_index(nq,iq,igcm_generic_vap,igcm_generic_ice,call_ice_vap_generic) + if (call_ice_vap_generic) then ! to call only one time the ice/vap pair of a tracer + + epsi_generic=constants_epsi_generic(iq) + + qvar(k) = qvar(k)/(epsi_generic+qvar(k)*(1.-epsi_generic)) + + endif + end do ! do iq=1,nq loop on tracers + endif + end do + end if + +!----------------------------------------------------------------------- +! kcm mode only ! +!----------------------------------------------------------------------- + + if(kastprof)then + + if(.not.global1d)then ! garde-fou/safeguard added by MT (to be removed in the future) + message='You have to fix mu0, the cosinus of the solar angle' + call abort_physic(subname,message,1) + endif + + ! Initial values equivalent to mugaz. + DO l=1,nlayer + muvarrad(2*l) = mugaz + muvarrad(2*l+1) = mugaz + END DO + + if(ngasmx.gt.1)then + + DO l=1,nlayer + muvarrad(2*l) = muvar(ig,nlayer+2-l) + muvarrad(2*l+1) = (muvar(ig,nlayer+2-l) + & + muvar(ig,max(nlayer+1-l,1)))/2 + END DO + + muvarrad(1) = muvarrad(2) + muvarrad(2*nlayer+1) = muvar(ig,1) + + print*,'Recalculating qvar with VARIABLE epsi for kastprof' + print*,'Assumes that the variable gas is H2O!!!' + print*,'Assumes that there is only one tracer' + + !i_var=igcm_h2o_vap + i_var=1 + + if(nq.gt.1)then + message='Need 1 tracer only to run kcm1d.e' + call abort_physic(subname,message,1) + endif + + do l=1,nlayer + vtmp(l)=pq(ig,l,i_var)/(epsi+pq(ig,l,i_var)*(1.-epsi)) + !vtmp(l)=pq(ig,l,i_var)*muvar(ig,l+1)/mH2O !JL to be changed + end do + + do l=1,nlayer + qvar(2*l) = vtmp(nlayer+1-l) + qvar(2*l+1) = vtmp(nlayer+1-l) +! qvar(2*l+1) = ( vtmp(nlayer+1-l) + vtmp(max(nlayer-l,1)) )/2 + end do + qvar(1)=qvar(2) + + write(*,*)trim(subname),' :Warning: reducing qvar in rad_correlatedk.' + write(*,*)trim(subname),' :Temperature profile no longer consistent ', & + 'with saturated H2O. qsat=',satval + + do k=1,L_LEVELS + qvar(k) = qvar(k)*satval + end do + + endif + else ! if kastprof + DO l=1,nlayer + muvarrad(2*l) = muvar(ig,nlayer+2-l) + muvarrad(2*l+1) = (muvar(ig,nlayer+2-l)+muvar(ig,max(nlayer+1-l,1)))/2 + END DO + + muvarrad(1) = muvarrad(2) + muvarrad(2*nlayer+1)=muvar(ig,1) + endif ! if kastprof + + ! Keep values inside limits for which we have radiative transfer coefficients !!! + if(L_REFVAR.gt.1)then ! (there was a bug here) + do k=1,L_LEVELS + if(qvar(k).lt.wrefvar(1))then + qvar(k)=wrefvar(1)+1.0e-8 + elseif(qvar(k).gt.wrefvar(L_REFVAR))then + qvar(k)=wrefvar(L_REFVAR)-1.0e-8 + endif + end do + endif + +!----------------------------------------------------------------------- +! Pressure and temperature +!----------------------------------------------------------------------- + + DO l=1,nlayer + plevrad(2*l) = pplay(ig,nlayer+1-l)/scalep + plevrad(2*l+1) = pplev(ig,nlayer+1-l)/scalep + tlevrad(2*l) = pt(ig,nlayer+1-l) + tlevrad(2*l+1) = (pt(ig,nlayer+1-l)+pt(ig,max(nlayer-l,1)))/2 + END DO + + plevrad(1) = 0. +! plevrad(2) = 0. !! JL18 enabling this line puts the radiative top at p=0 which was the idea before, but does not seem to perform best after all. + if (aerovenus) then +!! GG19 modified below after SL routines + plevrad(2) = 0. + endif + + tlevrad(1) = tlevrad(2) + tlevrad(2*nlayer+1)=tsurf(ig) + + pmid(1) = pplay(ig,nlayer)/scalep + if (aerovenus) then +!! GG19 modified below after SL routines + pmid(1) = max(pgasmin,0.0001*plevrad(3)) + endif + pmid(2) = pmid(1) + + tmid(1) = tlevrad(2) + tmid(2) = tmid(1) + + DO l=1,L_NLAYRAD-1 + tmid(2*l+1) = tlevrad(2*l+1) + tmid(2*l+2) = tlevrad(2*l+1) + pmid(2*l+1) = plevrad(2*l+1) + pmid(2*l+2) = plevrad(2*l+1) + END DO + pmid(L_LEVELS) = plevrad(L_LEVELS) + tmid(L_LEVELS) = tlevrad(L_LEVELS) + +!!Alternative interpolation: +! pmid(3) = pmid(1) +! pmid(4) = pmid(1) +! tmid(3) = tmid(1) +! tmid(4) = tmid(1) +! DO l=2,L_NLAYRAD-1 +! tmid(2*l+1) = tlevrad(2*l) +! tmid(2*l+2) = tlevrad(2*l) +! pmid(2*l+1) = plevrad(2*l) +! pmid(2*l+2) = plevrad(2*l) +! END DO +! pmid(L_LEVELS) = plevrad(L_LEVELS-1) +! tmid(L_LEVELS) = tlevrad(L_LEVELS-1) + + ! Test for out-of-bounds pressure. + if(plevrad(3).lt.pgasmin)then + print*,'Minimum pressure is outside the radiative' + print*,'transfer kmatrix bounds, exiting.' + message="Minimum pressure outside of kmatrix bounds" + call abort_physic(subname,message,1) + elseif(plevrad(L_LEVELS).gt.pgasmax)then + print*,'Maximum pressure is outside the radiative' + print*,'transfer kmatrix bounds, exiting.' + message="Minimum pressure outside of kmatrix bounds" + call abort_physic(subname,message,1) + endif + + ! Test for out-of-bounds temperature. + ! -- JVO 20 : Also add a sanity test checking that tlevrad is + ! within Planck function temperature boundaries, + ! which would cause rad_correlatedk_fluxes_solver_thermal/rad_correlatedk_fluxes_thermal to crash. + do k=1,L_LEVELS + + if(tlevrad(k).lt.tgasmin)then + print*,'Minimum temperature is outside the radiative' + print*,'transfer kmatrix bounds' + print*,"k=",k," tlevrad(k)=",tlevrad(k) + print*,"tgasmin=",tgasmin + if (strictboundcorrk) then + message="Minimum temperature outside of kmatrix bounds" + call abort_physic(subname,message,1) + else + print*,'***********************************************' + print*,'we allow model to continue with tlevradtgasmax' + print*,' ... we assume we know what you are doing ... ' + print*,' ... but do not let this happen too often ... ' + print*,'***********************************************' + !tlevrad(k)=tgasmax ! Used in the source function ! + endif + endif + + if (tlevrad(k).lt.tplanckmin) then + print*,'Minimum temperature is outside the boundaries for' + print*,'Planck function integration set in callphys.def, aborting.' + print*,"k=",k," tlevrad(k)=",tlevrad(k) + print*,"tplanckmin=",tplanckmin + message="Minimum temperature outside Planck function bounds - Change tplanckmin in callphys.def" + call abort_physic(subname,message,1) + else if (tlevrad(k).gt.tplanckmax) then + print*,'Maximum temperature is outside the boundaries for' + print*,'Planck function integration set in callphys.def, aborting.' + print*,"k=",k," tlevrad(k)=",tlevrad(k) + print*,"tplanckmax=",tplanckmax + message="Maximum temperature outside Planck function bounds - Change tplanckmax in callphys.def" + call abort_physic(subname,message,1) + endif + + enddo + + do k=1,L_NLAYRAD+1 + if(tmid(k).lt.tgasmin)then + print*,'Minimum temperature is outside the radiative' + print*,'transfer kmatrix bounds, exiting.' + print*,"k=",k," tmid(k)=",tmid(k) + print*,"tgasmin=",tgasmin + if (strictboundcorrk) then + message="Minimum temperature outside of kmatrix bounds" + call abort_physic(subname,message,1) + else + print*,'***********************************************' + print*,'we allow model to continue but with tmid=tgasmin' + print*,' ... we assume we know what you are doing ... ' + print*,' ... but do not let this happen too often ... ' + print*,'***********************************************' + tmid(k)=tgasmin + endif + elseif(tmid(k).gt.tgasmax)then + print*,'Maximum temperature is outside the radiative' + print*,'transfer kmatrix bounds, exiting.' + print*,"k=",k," tmid(k)=",tmid(k) + print*,"tgasmax=",tgasmax + if (strictboundcorrk) then + message="Maximum temperature outside of kmatrix bounds" + call abort_physic(subname,message,1) + else + print*,'***********************************************' + print*,'we allow model to continue but with tmid=tgasmax' + print*,' ... we assume we know what you are doing ... ' + print*,' ... but do not let this happen too often ... ' + print*,'***********************************************' + tmid(k)=tgasmax + endif + endif + enddo + +!----------------------------------------------------------------------- +! Variation of molar fraction for CIAs +!----------------------------------------------------------------------- + + if (varspec) then + do k=1,ngasmx + call pindex(p_var,frac_var(:,k),plevrad(:),nvarlayer,L_LEVELS,frac_vari) + fracvari(k,:) = frac_vari + enddo + endif + +!======================================================================= +! III. Calling the main radiative transfer subroutines +!======================================================================= + +! ---------------------------------------------------------------- +! Recombine reference corrk tables if needed - Added by JVO, 2020. + if (corrk_recombin) then + call rad_correlatedk_recombination_main(ig,nlayer,pq(ig,:,:),pplay(ig,:),pt(ig,:),qvar(:),tmid(:),pmid(:)) + endif +! ---------------------------------------------------------------- + + Cmk= 0.01 * 1.0 / (glat(ig) * mugaz * 1.672621e-27) ! q_main=1.0 assumed. + glat_ig=glat(ig) + +!----------------------------------------------------------------------- +! Short Wave Part +!----------------------------------------------------------------------- + + if((fract(ig) .ge. 1.0e-4).or.(global1d)) then ! Only during daylight. + if((ngrid.eq.1).and.(global1d))then + do nw=1,L_NSPECTV + stel_fract(nw)= stel(nw)* 0.25 / acosz ! globally averaged = divide by 4, and we correct for solar zenith angle + end do + else + do nw=1,L_NSPECTV + stel_fract(nw)= stel(nw) * fract(ig) + end do + endif + + call rad_correlatedk_opacities_stellar(dtauv, & + tauv,taucumv,plevrad, & + qxvaer,qsvaer,gvaer,wbarv,cosbv,tauaero, & + tmid,pmid,taugsurf,qvar,muvarrad,fracvari) + + call rad_correlatedk_fluxes_stellar(dtauv,tauv, & + taucumv,albv,dwnv,wbarv,cosbv, & + acosz,stel_fract, & + nfluxtopv,fluxtopvdn, & + nfluxoutv_nu,nfluxgndv_nu, & + fmnetv,fluxupv,fluxdnv,fzerov,taugsurf) + + else ! During the night, fluxes = 0. + nfluxtopv = 0.0d0 + fluxtopvdn = 0.0d0 + nfluxoutv_nu(:) = 0.0d0 + nfluxgndv_nu(:) = 0.0d0 + do l=1,L_NLAYRAD + fmnetv(l)=0.0d0 + fluxupv(l)=0.0d0 + fluxdnv(l)=0.0d0 + end do + end if + + + ! Equivalent Albedo Calculation (for OUTPUT). MT2015 + if((fract(ig) .ge. 1.0e-4).or.(global1d)) then ! equivalent albedo makes sense only during daylight. + surface_stellar_flux=sum(nfluxgndv_nu(1:L_NSPECTV)) + if(surface_stellar_flux .gt. 1.0e-3) then ! equivalent albedo makes sense only if the stellar flux received by the surface is positive. + DO nw=1,L_NSPECTV + albedo_temp(nw)=albedo(ig,nw)*nfluxgndv_nu(nw) + ENDDO + albedo_temp(1:L_NSPECTV)=albedo_temp(1:L_NSPECTV)/surface_stellar_flux + albedo_equivalent(ig)=sum(albedo_temp(1:L_NSPECTV)) + else + albedo_equivalent(ig)=0.0 ! Spectrally Integrated Albedo not defined for non-irradiated grid points. So we arbitrary set the equivalent albedo to 0. + endif + else + albedo_equivalent(ig)=0.0 ! Spectrally Integrated Albedo not defined for non-irradiated grid points. So we arbitrary set the equivalent albedo to 0. + endif + + +!----------------------------------------------------------------------- +! Long Wave Part +!----------------------------------------------------------------------- + + call rad_correlatedk_opacities_thermal(plevrad, & + tlevrad,dtaui,taucumi, & + qxiaer,qsiaer,giaer,cosbi,wbari,tauaero,tmid,pmid, & + taugsurfi,qvar,muvarrad,fracvari) + + call rad_correlatedk_fluxes_thermal(plevrad, & + tlevrad,dtaui,taucumi,ubari,albi, & + wnoi,dwni,cosbi,wbari,nfluxtopi,nfluxtopi_nu, & + fmneti,fluxupi,fluxdni,fluxupi_nu,fzeroi,taugsurfi) + +!----------------------------------------------------------------------- +! Transformation of the correlated-k code outputs +! (into dtlw, dtsw, fluxsurf_lw, fluxsurf_sw, fluxtop_lw, fluxtop_sw) + +! Flux incident at the top of the atmosphere + fluxtop_dn(ig)=fluxtopvdn + + fluxtop_lw(ig) = real(nfluxtopi) + fluxabs_sw(ig) = real(-nfluxtopv) + fluxsurf_lw(ig) = real(fluxdni(L_NLAYRAD)) + fluxsurf_sw(ig) = real(fluxdnv(L_NLAYRAD)) + +! Flux absorbed by the surface. By MT2015. + fluxsurfabs_sw(ig) = fluxsurf_sw(ig)*(1.-albedo_equivalent(ig)) + + if(fluxtop_dn(ig).lt.0.0)then + print*,'Achtung! fluxtop_dn has lost the plot!' + print*,'fluxtop_dn=',fluxtop_dn(ig) + print*,'acosz=',acosz + print*,'aerosol=',aerosol(ig,:,:) + print*,'temp= ',pt(ig,:) + print*,'pplay= ',pplay(ig,:) + message="Achtung! fluxtop_dn has lost the plot!" + call abort_physic(subname,message,1) + endif + +! Spectral output, for exoplanet observational comparison + if(specOLR)then + do nw=1,L_NSPECTI + OLR_nu(ig,nw)=nfluxtopi_nu(nw)/DWNI(nw) !JL Normalize to the bandwidth + end do + do nw=1,L_NSPECTV + GSR_nu(ig,nw)=nfluxgndv_nu(nw)/DWNV(nw) + OSR_nu(ig,nw)=nfluxoutv_nu(nw)/DWNV(nw) !JL Normalize to the bandwidth + end do + endif + +! Finally, the heating rates + + DO l=2,L_NLAYRAD + dtsw(ig,L_NLAYRAD+1-l)=(fmnetv(l)-fmnetv(l-1)) & + *glat(ig)/(cpp*scalep*(plevrad(2*l+1)-plevrad(2*l-1))) + dtlw(ig,L_NLAYRAD+1-l)=(fmneti(l)-fmneti(l-1)) & + *glat(ig)/(cpp*scalep*(plevrad(2*l+1)-plevrad(2*l-1))) + END DO + +! These are values at top of atmosphere + dtsw(ig,L_NLAYRAD)=(fmnetv(1)-nfluxtopv) & + *glat(ig)/(cpp*scalep*(plevrad(3)-plevrad(2))) + dtlw(ig,L_NLAYRAD)=(fmneti(1)-nfluxtopi) & + *glat(ig)/(cpp*scalep*(plevrad(3)-plevrad(2))) + + ! Optical thickness diagnostics (added by JVO) + if (diagdtau) then + do l=1,L_NLAYRAD + do nw=1,L_NSPECTV + int_dtauv(ig,l,nw) = 0.0d0 + DO k=1,L_NGAUSS + ! Output exp(-tau) because gweight ponderates exp and not tau itself + int_dtauv(ig,l,nw)= int_dtauv(ig,l,nw) + exp(-dtauv(l,nw,k))*gweight(k) + ENDDO + enddo + do nw=1,L_NSPECTI + int_dtaui(ig,l,nw) = 0.0d0 + DO k=1,L_NGAUSS + ! Output exp(-tau) because gweight ponderates exp and not tau itself + int_dtaui(ig,l,nw)= int_dtaui(ig,l,nw) + exp(-dtaui(l,nw,k))*gweight(k) + ENDDO + enddo + enddo + endif + + +!----------------------------------------------------------------------- + end do ! End of big loop over every GCM column. +!----------------------------------------------------------------------- + + + +!----------------------------------------------------------------------- +! Additional diagnostics +!----------------------------------------------------------------------- + + ! IR spectral output, for exoplanet observational comparison + if(lastcall.and.(ngrid.eq.1))then ! could disable the 1D output, they are in the diagfi and diagspec... JL12 + + print*,'Saving scalar quantities in surf_vals.out...' + print*,'psurf = ', pplev(1,1),' Pa' + open(116,file='surf_vals.out') + write(116,*) tsurf(1),pplev(1,1),fluxtop_dn(1), & + real(-nfluxtopv),real(nfluxtopi) + close(116) + + +! USEFUL COMMENT - Do Not Remove. +! +! if(specOLR)then +! open(117,file='OLRnu.out') +! do nw=1,L_NSPECTI +! write(117,*) OLR_nu(1,nw) +! enddo +! close(117) +! +! open(127,file='OSRnu.out') +! do nw=1,L_NSPECTV +! write(127,*) OSR_nu(1,nw) +! enddo +! close(127) +! endif + + ! OLR vs altitude: do it as a .txt file. + OLRz=.false. + if(OLRz)then + print*,'saving IR vertical flux for OLRz...' + open(118,file='OLRz_plevs.out') + open(119,file='OLRz.out') + do l=1,L_NLAYRAD + write(118,*) plevrad(2*l) + do nw=1,L_NSPECTI + write(119,*) fluxupi_nu(l,nw) + enddo + enddo + close(118) + close(119) + endif + + endif + + ! See physiq.F for explanations about CLFvarying. This is temporary. + if (lastcall .and. .not.CLFvarying) then + IF( ALLOCATED( gasi ) ) DEALLOCATE( gasi ) + IF( ALLOCATED( gasv ) ) DEALLOCATE( gasv ) +!$OMP BARRIER +!$OMP MASTER + IF( ALLOCATED( pgasref ) ) DEALLOCATE( pgasref ) + IF( ALLOCATED( tgasref ) ) DEALLOCATE( tgasref ) + IF( ALLOCATED( wrefvar ) ) DEALLOCATE( wrefvar ) + IF( ALLOCATED( pfgasref ) ) DEALLOCATE( pfgasref ) + IF( ALLOCATED( gweight ) ) DEALLOCATE( gweight ) +!$OMP END MASTER +!$OMP BARRIER + IF ( ALLOCATED(reffrad)) DEALLOCATE(reffrad) + IF ( ALLOCATED(nueffrad)) DEALLOCATE(nueffrad) + endif + + + end subroutine rad_correlatedk + +END MODULE rad_correlatedk_mod Index: trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_continuum_interpolation.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_continuum_interpolation.F90 (revision 4077) +++ trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_continuum_interpolation.F90 (revision 4077) @@ -0,0 +1,838 @@ +module rad_correlatedk_continuum_interpolation_mod + +implicit none + +contains + + subroutine rad_correlatedk_continuum_interpolation(filename,igas_X,igas_Y,c_WN,ind_WN,temp,pres_X,pres_Y,abs_coef,firstcall) + +!================================================================== +! +! Purpose +! ------- +! Generic routine to calculate continuum opacities, using lookup tables provided here: https://web.lmd.jussieu.fr/~lmdz/planets/generic/datagcm/continuum_data/ +! More information on the data here: https://lmdz-forge.lmd.jussieu.fr/mediawiki/Planets/index.php/Continuum_Database +! +! Author +! ------- +! M. Turbet (2025) +! +!================================================================== + + use datafile_mod, only: datadir + use mod_phys_lmdz_para, only : is_master + + use gases_h, only: ngasmx, gnom, & + igas_H2, igas_H2O, igas_He, igas_N2, & + igas_CH4, igas_CO2, igas_O2 + + use radinc_h, only: L_NSPECTI, L_NSPECTV + + use radcommon_h, only : BWNV,BWNI,WNOI,WNOV + + + implicit none + + ! input + integer,intent(in) :: ind_WN ! wavenumber index + integer,intent(in) :: igas_X ! index of molecule X + integer,intent(in) :: igas_Y ! index of molecule Y + double precision,intent(in) :: temp ! temperature (Kelvin) + double precision,intent(in) :: pres_X ! partial pressure of molecule X (Pascals) + double precision,intent(in) :: pres_Y ! partial pressure of molecule Y (Pascals) + character(len=*),intent(in) :: filename ! name of the lookup table + character(len=2),intent(in) :: c_WN ! wavelength chanel: infrared (IR) or visible (VI) + logical,intent(in) :: firstcall + + ! output + double precision,intent(out) :: abs_coef ! absorption coefficient (m^-1) + + ! intermediate variables + double precision amagat_X ! density of molecule X (in amagat units) + double precision amagat_Y ! density of molecule Y (in amagat units) + + character(len=512) :: line + character(len=21),parameter :: rname="rad_correlatedk_continuum_interpolation" + + integer i, pos, iT, iW, iB, count_norm, igas + + double precision temp_value, temp_abs, temp_wn + + double precision z_temp + + integer num_wn, num_T + + double precision, dimension(:), allocatable :: temp_arr + double precision, dimension(:), allocatable :: wn_arr + double precision, dimension(:,:), allocatable :: abs_arr + + integer ios + + ! Temperature array, continuum absorption grid for the pair N2-N2 + integer,save :: num_T_N2N2 + double precision,save,dimension(:),allocatable :: temp_arr_N2N2 + double precision,save,dimension(:,:),allocatable :: abs_arr_N2N2_IR + double precision,save,dimension(:,:),allocatable :: abs_arr_N2N2_VI +! None of these saved variables are THREADPRIVATE because read by master +! and then only accessed but never modified and thus can be shared + + ! Temperature array, continuum absorption grid for the pair O2-O2 + integer,save :: num_T_O2O2 + double precision,save,dimension(:),allocatable :: temp_arr_O2O2 + double precision,save,dimension(:,:),allocatable :: abs_arr_O2O2_IR + double precision,save,dimension(:,:),allocatable :: abs_arr_O2O2_VI +! None of these saved variables are THREADPRIVATE because read by master +! and then only accessed but never modified and thus can be shared + + ! Temperature array, continuum absorption grid for the pair H2-H2 + integer,save :: num_T_H2H2 + double precision,save,dimension(:),allocatable :: temp_arr_H2H2 + double precision,save,dimension(:,:),allocatable :: abs_arr_H2H2_IR + double precision,save,dimension(:,:),allocatable :: abs_arr_H2H2_VI +! None of these saved variables are THREADPRIVATE because read by master +! and then only accessed but never modified and thus can be shared + + ! Temperature array, continuum absorption grid for the pair CO2-CO2 + integer,save :: num_T_CO2CO2 + double precision,save,dimension(:),allocatable :: temp_arr_CO2CO2 + double precision,save,dimension(:,:),allocatable :: abs_arr_CO2CO2_IR + double precision,save,dimension(:,:),allocatable :: abs_arr_CO2CO2_VI +! None of these saved variables are THREADPRIVATE because read by master +! and then only accessed but never modified and thus can be shared + + ! Temperature array, continuum absorption grid for the pair CH4-CH4 + integer,save :: num_T_CH4CH4 + double precision,save,dimension(:),allocatable :: temp_arr_CH4CH4 + double precision,save,dimension(:,:),allocatable :: abs_arr_CH4CH4_IR + double precision,save,dimension(:,:),allocatable :: abs_arr_CH4CH4_VI +! None of these saved variables are THREADPRIVATE because read by master +! and then only accessed but never modified and thus can be shared + + ! Temperature array, continuum absorption grid for the pair H2O-H2O + integer,save :: num_T_H2OH2O + double precision,save,dimension(:),allocatable :: temp_arr_H2OH2O + double precision,save,dimension(:,:),allocatable :: abs_arr_H2OH2O_IR + double precision,save,dimension(:,:),allocatable :: abs_arr_H2OH2O_VI +! None of these saved variables are THREADPRIVATE because read by master +! and then only accessed but never modified and thus can be shared + + ! Temperature array, continuum absorption grid for the pair H2-He + integer,save :: num_T_H2He + double precision,save,dimension(:),allocatable :: temp_arr_H2He + double precision,save,dimension(:,:),allocatable :: abs_arr_H2He_IR + double precision,save,dimension(:,:),allocatable :: abs_arr_H2He_VI +! None of these saved variables are THREADPRIVATE because read by master +! and then only accessed but never modified and thus can be shared + + ! Temperature array, continuum absorption grid for the pair H2-CH4 + integer,save :: num_T_H2CH4 + double precision,save,dimension(:),allocatable :: temp_arr_H2CH4 + double precision,save,dimension(:,:),allocatable :: abs_arr_H2CH4_IR + double precision,save,dimension(:,:),allocatable :: abs_arr_H2CH4_VI +! None of these saved variables are THREADPRIVATE because read by master +! and then only accessed but never modified and thus can be shared + + ! Temperature array, continuum absorption grid for the pair CO2-H2 + integer,save :: num_T_CO2H2 + double precision,save,dimension(:),allocatable :: temp_arr_CO2H2 + double precision,save,dimension(:,:),allocatable :: abs_arr_CO2H2_IR + double precision,save,dimension(:,:),allocatable :: abs_arr_CO2H2_VI +! None of these saved variables are THREADPRIVATE because read by master +! and then only accessed but never modified and thus can be shared + + ! Temperature array, continuum absorption grid for the pair CO2-CH4 + integer,save :: num_T_CO2CH4 + double precision,save,dimension(:),allocatable :: temp_arr_CO2CH4 + double precision,save,dimension(:,:),allocatable :: abs_arr_CO2CH4_IR + double precision,save,dimension(:,:),allocatable :: abs_arr_CO2CH4_VI +! None of these saved variables are THREADPRIVATE because read by master +! and then only accessed but never modified and thus can be shared + + ! Temperature array, continuum absorption grid for the pair N2-H2 + integer,save :: num_T_N2H2 + double precision,save,dimension(:),allocatable :: temp_arr_N2H2 + double precision,save,dimension(:,:),allocatable :: abs_arr_N2H2_IR + double precision,save,dimension(:,:),allocatable :: abs_arr_N2H2_VI +! None of these saved variables are THREADPRIVATE because read by master +! and then only accessed but never modified and thus can be shared + + ! Temperature array, continuum absorption grid for the pair N2-CH4 + integer,save :: num_T_N2CH4 + double precision,save,dimension(:),allocatable :: temp_arr_N2CH4 + double precision,save,dimension(:,:),allocatable :: abs_arr_N2CH4_IR + double precision,save,dimension(:,:),allocatable :: abs_arr_N2CH4_VI +! None of these saved variables are THREADPRIVATE because read by master +! and then only accessed but never modified and thus can be shared + + ! Temperature array, continuum absorption grid for the pair CO2-O2 + integer,save :: num_T_CO2O2 + double precision,save,dimension(:),allocatable :: temp_arr_CO2O2 + double precision,save,dimension(:,:),allocatable :: abs_arr_CO2O2_IR + double precision,save,dimension(:,:),allocatable :: abs_arr_CO2O2_VI +! None of these saved variables are THREADPRIVATE because read by master +! and then only accessed but never modified and thus can be shared + + ! Temperature array, continuum absorption grid for the pair N2-O2 + integer,save :: num_T_N2O2 + double precision,save,dimension(:), allocatable :: temp_arr_N2O2 + double precision,save,dimension(:,:), allocatable :: abs_arr_N2O2_IR + double precision,save,dimension(:,:), allocatable :: abs_arr_N2O2_VI +! None of these saved variables are THREADPRIVATE because read by master +! and then only accessed but never modified and thus can be shared + + ! Temperature array, continuum absorption grid for the pair H2O-N2 + integer,save :: num_T_H2ON2 + double precision,save,dimension(:),allocatable :: temp_arr_H2ON2 + double precision,save,dimension(:,:),allocatable :: abs_arr_H2ON2_IR + double precision,save,dimension(:,:),allocatable :: abs_arr_H2ON2_VI +! None of these saved variables are THREADPRIVATE because read by master +! and then only accessed but never modified and thus can be shared + + ! Temperature array, continuum absorption grid for the pair H2O-O2 + integer,save :: num_T_H2OO2 + double precision,save,dimension(:),allocatable :: temp_arr_H2OO2 + double precision,save,dimension(:,:),allocatable :: abs_arr_H2OO2_IR + double precision,save,dimension(:,:),allocatable :: abs_arr_H2OO2_VI +! None of these saved variables are THREADPRIVATE because read by master +! and then only accessed but never modified and thus can be shared + + ! Temperature array, continuum absorption grid for the pair H2O-CO2 + integer,save :: num_T_H2OCO2 + double precision,save,dimension(:),allocatable :: temp_arr_H2OCO2 + double precision,save,dimension(:,:),allocatable :: abs_arr_H2OCO2_IR + double precision,save,dimension(:,:),allocatable :: abs_arr_H2OCO2_VI +! None of these saved variables are THREADPRIVATE because read by master +! and then only accessed but never modified and thus can be shared + + + if(firstcall)then ! called by rad_correlatedk_read_opacity_tables only + if (is_master) print*,'----------------------------------------------------' + if (is_master) print*,'Initialising continuum (rad_correlatedk_continuum_interpolation routine) from ', trim(filename) + +!$OMP MASTER + + open(unit=33, file=trim(filename), status="old", action="read",iostat=ios) + + if (ios.ne.0) then ! file not found + if (is_master) then + write(*,*) 'Error from rad_correlatedk_continuum_interpolation routine' + write(*,*) 'Data file ',trim(filename),' not found.' + write(*,*) 'Check that your path to datagcm:',trim(datadir) + write(*,*) 'is correct. You can change it in callphys.def with:' + write(*,*) 'datadir = /absolute/path/to/datagcm' + write(*,*) 'Also check that the continuum data is there.' + write(*,*) 'Latest continuum data can be downloaded here:' + write(*,*) 'https://web.lmd.jussieu.fr/~lmdz/planets/generic/datagcm/continuum_data/' + endif + call abort_physic(rname,"missing input file",1) + endif + + ! We read the first line of the file to get the number of temperatures provided in the data file + read(33, '(A)') line + + i = 1 + iT = 0 + + do while (i .lt. len_trim(line)) + pos = index(line(i:), 'T=') + if (pos == 0) exit + i = i + pos + iT = iT + 1 + read(line(i+2:i+10), '(E9.2)') temp_value + end do + + num_T=iT ! num_T is the number of temperatures provided in the data file + + ! We read all the remaining lines of the file to get the number of wavenumbers provided in the data file + iW = 0 + do + read(33,*, end=501) line + iW = iW + 1 + end do + +501 continue + + num_wn=iW ! num_wn is the number of wavenumbers provided in the data file + + close(33) + + allocate(temp_arr(num_T)) + allocate(wn_arr(num_wn)) + allocate(abs_arr(num_wn,num_T)) + + ! We now open and read the file a second time to extract the temperature array, wavenumber array and continuum absorption data + + open(unit=33, file=trim(filename), status="old", action="read") + + ! We extract the temperature array (temp_arr) + + read(33, '(A)') line + + i = 1 + iT = 0 + + do while (i .lt. len_trim(line)) + pos = index(line(i:), 'T=') + if (pos == 0) exit + i = i + pos + iT = iT + 1 + read(line(i+2:i+10), '(E9.2)') temp_arr(iT) + end do + + ! We extract the wavenumber array (wn_arr) and continuum absorption (abs_arr) + + do iW=1,num_wn + read(33,*) wn_arr(iW), (abs_arr(iW, iT), iT=1,num_T) + end do + + close(33) + + print*,'We read continuum absorption data for the pair ', trim(gnom(igas_X)),'-',trim(gnom(igas_Y)) + print*,'Temperature grid of the dataset: ', temp_arr(:) + + ! We loop on all molecular pairs with available continuum data and fill the corresponding array + + if ((igas_X .eq. igas_CO2) .and. (igas_Y .eq. igas_CO2)) then + num_T_CO2CO2=num_T + allocate(temp_arr_CO2CO2(num_T_CO2CO2)) + allocate(abs_arr_CO2CO2_VI(L_NSPECTV,num_T_CO2CO2)) + allocate(abs_arr_CO2CO2_IR(L_NSPECTI,num_T_CO2CO2)) + temp_arr_CO2CO2(:)=temp_arr(:) + abs_arr_CO2CO2_VI(:,:)=0. + abs_arr_CO2CO2_IR(:,:)=0. + call interpolate_wn_abs_coeff(wn_arr,num_wn,abs_arr,abs_arr_CO2CO2_VI,abs_arr_CO2CO2_IR,num_T_CO2CO2) + elseif ((igas_X .eq. igas_N2) .and. (igas_Y .eq. igas_N2)) then + num_T_N2N2=num_T + allocate(temp_arr_N2N2(num_T_N2N2)) + allocate(abs_arr_N2N2_VI(L_NSPECTV,num_T_N2N2)) + allocate(abs_arr_N2N2_IR(L_NSPECTI,num_T_N2N2)) + temp_arr_N2N2(:)=temp_arr(:) + abs_arr_N2N2_VI(:,:)=0. + abs_arr_N2N2_IR(:,:)=0. + call interpolate_wn_abs_coeff(wn_arr,num_wn,abs_arr,abs_arr_N2N2_VI,abs_arr_N2N2_IR,num_T_N2N2) + elseif ((igas_X .eq. igas_O2) .and. (igas_Y .eq. igas_O2)) then + num_T_O2O2=num_T + allocate(temp_arr_O2O2(num_T_O2O2)) + allocate(abs_arr_O2O2_VI(L_NSPECTV,num_T_O2O2)) + allocate(abs_arr_O2O2_IR(L_NSPECTI,num_T_O2O2)) + temp_arr_O2O2(:)=temp_arr(:) + abs_arr_O2O2_VI(:,:)=0. + abs_arr_O2O2_IR(:,:)=0. + call interpolate_wn_abs_coeff(wn_arr,num_wn,abs_arr,abs_arr_O2O2_VI,abs_arr_O2O2_IR,num_T_O2O2) + elseif ((igas_X .eq. igas_CH4) .and. (igas_Y .eq. igas_CH4)) then + num_T_CH4CH4=num_T + allocate(temp_arr_CH4CH4(num_T_CH4CH4)) + allocate(abs_arr_CH4CH4_VI(L_NSPECTV,num_T_CH4CH4)) + allocate(abs_arr_CH4CH4_IR(L_NSPECTI,num_T_CH4CH4)) + temp_arr_CH4CH4(:)=temp_arr(:) + abs_arr_CH4CH4_VI(:,:)=0. + abs_arr_CH4CH4_IR(:,:)=0. + call interpolate_wn_abs_coeff(wn_arr,num_wn,abs_arr,abs_arr_CH4CH4_VI,abs_arr_CH4CH4_IR,num_T_CH4CH4) + elseif ((igas_X .eq. igas_H2) .and. (igas_Y .eq. igas_H2)) then + num_T_H2H2=num_T + allocate(temp_arr_H2H2(num_T_H2H2)) + allocate(abs_arr_H2H2_VI(L_NSPECTV,num_T_H2H2)) + allocate(abs_arr_H2H2_IR(L_NSPECTI,num_T_H2H2)) + temp_arr_H2H2(:)=temp_arr(:) + abs_arr_H2H2_VI(:,:)=0. + abs_arr_H2H2_IR(:,:)=0. + call interpolate_wn_abs_coeff(wn_arr,num_wn,abs_arr,abs_arr_H2H2_VI,abs_arr_H2H2_IR,num_T_H2H2) + elseif ((igas_X .eq. igas_H2O) .and. (igas_Y .eq. igas_H2O)) then + num_T_H2OH2O=num_T + allocate(temp_arr_H2OH2O(num_T_H2OH2O)) + allocate(abs_arr_H2OH2O_VI(L_NSPECTV,num_T_H2OH2O)) + allocate(abs_arr_H2OH2O_IR(L_NSPECTI,num_T_H2OH2O)) + temp_arr_H2OH2O(:)=temp_arr(:) + abs_arr_H2OH2O_VI(:,:)=0. + abs_arr_H2OH2O_IR(:,:)=0. + call interpolate_wn_abs_coeff(wn_arr,num_wn,abs_arr,abs_arr_H2OH2O_VI,abs_arr_H2OH2O_IR,num_T_H2OH2O) + elseif ((igas_X .eq. igas_N2) .and. (igas_Y .eq. igas_H2)) then + num_T_N2H2=num_T + allocate(temp_arr_N2H2(num_T_N2H2)) + allocate(abs_arr_N2H2_VI(L_NSPECTV,num_T_N2H2)) + allocate(abs_arr_N2H2_IR(L_NSPECTI,num_T_N2H2)) + temp_arr_N2H2(:)=temp_arr(:) + abs_arr_N2H2_VI(:,:)=0. + abs_arr_N2H2_IR(:,:)=0. + call interpolate_wn_abs_coeff(wn_arr,num_wn,abs_arr,abs_arr_N2H2_VI,abs_arr_N2H2_IR,num_T_N2H2) + elseif ((igas_X .eq. igas_N2) .and. (igas_Y .eq. igas_O2)) then + num_T_N2O2=num_T + allocate(temp_arr_N2O2(num_T_N2O2)) + allocate(abs_arr_N2O2_VI(L_NSPECTV,num_T_N2O2)) + allocate(abs_arr_N2O2_IR(L_NSPECTI,num_T_N2O2)) + temp_arr_N2O2(:)=temp_arr(:) + abs_arr_N2O2_VI(:,:)=0. + abs_arr_N2O2_IR(:,:)=0. + call interpolate_wn_abs_coeff(wn_arr,num_wn,abs_arr,abs_arr_N2O2_VI,abs_arr_N2O2_IR,num_T_N2O2) + elseif ((igas_X .eq. igas_N2) .and. (igas_Y .eq. igas_CH4)) then + num_T_N2CH4=num_T + allocate(temp_arr_N2CH4(num_T_N2CH4)) + allocate(abs_arr_N2CH4_VI(L_NSPECTV,num_T_N2CH4)) + allocate(abs_arr_N2CH4_IR(L_NSPECTI,num_T_N2CH4)) + temp_arr_N2CH4(:)=temp_arr(:) + abs_arr_N2CH4_VI(:,:)=0. + abs_arr_N2CH4_IR(:,:)=0. + call interpolate_wn_abs_coeff(wn_arr,num_wn,abs_arr,abs_arr_N2CH4_VI,abs_arr_N2CH4_IR,num_T_N2CH4) + elseif ((igas_X .eq. igas_CO2) .and. (igas_Y .eq. igas_O2)) then + num_T_CO2O2=num_T + allocate(temp_arr_CO2O2(num_T_CO2O2)) + allocate(abs_arr_CO2O2_VI(L_NSPECTV,num_T_CO2O2)) + allocate(abs_arr_CO2O2_IR(L_NSPECTI,num_T_CO2O2)) + temp_arr_CO2O2(:)=temp_arr(:) + abs_arr_CO2O2_VI(:,:)=0. + abs_arr_CO2O2_IR(:,:)=0. + call interpolate_wn_abs_coeff(wn_arr,num_wn,abs_arr,abs_arr_CO2O2_VI,abs_arr_CO2O2_IR,num_T_CO2O2) + elseif ((igas_X .eq. igas_H2) .and. (igas_Y .eq. igas_CH4)) then + num_T_H2CH4=num_T + allocate(temp_arr_H2CH4(num_T_H2CH4)) + allocate(abs_arr_H2CH4_VI(L_NSPECTV,num_T_H2CH4)) + allocate(abs_arr_H2CH4_IR(L_NSPECTI,num_T_H2CH4)) + temp_arr_H2CH4(:)=temp_arr(:) + abs_arr_H2CH4_VI(:,:)=0. + abs_arr_H2CH4_IR(:,:)=0. + call interpolate_wn_abs_coeff(wn_arr,num_wn,abs_arr,abs_arr_H2CH4_VI,abs_arr_H2CH4_IR,num_T_H2CH4) + elseif ((igas_X .eq. igas_H2) .and. (igas_Y .eq. igas_He)) then + num_T_H2He=num_T + allocate(temp_arr_H2He(num_T_H2He)) + allocate(abs_arr_H2He_VI(L_NSPECTV,num_T_H2He)) + allocate(abs_arr_H2He_IR(L_NSPECTI,num_T_H2He)) + temp_arr_H2He(:)=temp_arr(:) + abs_arr_H2He_VI(:,:)=0. + abs_arr_H2He_IR(:,:)=0. + call interpolate_wn_abs_coeff(wn_arr,num_wn,abs_arr,abs_arr_H2He_VI,abs_arr_H2He_IR,num_T_H2He) + elseif ((igas_X .eq. igas_H2O) .and. (igas_Y .eq. igas_N2)) then + num_T_H2ON2=num_T + allocate(temp_arr_H2ON2(num_T_H2ON2)) + allocate(abs_arr_H2ON2_VI(L_NSPECTV,num_T_H2ON2)) + allocate(abs_arr_H2ON2_IR(L_NSPECTI,num_T_H2ON2)) + temp_arr_H2ON2(:)=temp_arr(:) + abs_arr_H2ON2_VI(:,:)=0. + abs_arr_H2ON2_IR(:,:)=0. + call interpolate_wn_abs_coeff(wn_arr,num_wn,abs_arr,abs_arr_H2ON2_VI,abs_arr_H2ON2_IR,num_T_H2ON2) + elseif ((igas_X .eq. igas_H2O) .and. (igas_Y .eq. igas_O2)) then + num_T_H2OO2=num_T + allocate(temp_arr_H2OO2(num_T_H2OO2)) + allocate(abs_arr_H2OO2_VI(L_NSPECTV,num_T_H2OO2)) + allocate(abs_arr_H2OO2_IR(L_NSPECTI,num_T_H2OO2)) + temp_arr_H2OO2(:)=temp_arr(:) + abs_arr_H2OO2_VI(:,:)=0. + abs_arr_H2OO2_IR(:,:)=0. + call interpolate_wn_abs_coeff(wn_arr,num_wn,abs_arr,abs_arr_H2OO2_VI,abs_arr_H2OO2_IR,num_T_H2OO2) + elseif ((igas_X .eq. igas_H2O) .and. (igas_Y .eq. igas_CO2)) then + num_T_H2OCO2=num_T + allocate(temp_arr_H2OCO2(num_T_H2OCO2)) + allocate(abs_arr_H2OCO2_VI(L_NSPECTV,num_T_H2OCO2)) + allocate(abs_arr_H2OCO2_IR(L_NSPECTI,num_T_H2OCO2)) + temp_arr_H2OCO2(:)=temp_arr(:) + abs_arr_H2OCO2_VI(:,:)=0. + abs_arr_H2OCO2_IR(:,:)=0. + call interpolate_wn_abs_coeff(wn_arr,num_wn,abs_arr,abs_arr_H2OCO2_VI,abs_arr_H2OCO2_IR,num_T_H2OCO2) + elseif ((igas_X .eq. igas_CO2) .and. (igas_Y .eq. igas_CO2)) then + num_T_CO2CO2=num_T + allocate(temp_arr_CO2CO2(num_T_CO2CO2)) + allocate(abs_arr_CO2CO2_VI(L_NSPECTV,num_T_CO2CO2)) + allocate(abs_arr_CO2CO2_IR(L_NSPECTI,num_T_CO2CO2)) + temp_arr_CO2CO2(:)=temp_arr(:) + abs_arr_CO2CO2_VI(:,:)=0. + abs_arr_CO2CO2_IR(:,:)=0. + call interpolate_wn_abs_coeff(wn_arr,num_wn,abs_arr,abs_arr_CO2CO2_VI,abs_arr_CO2CO2_IR,num_T_CO2CO2) + elseif ((igas_X .eq. igas_CO2) .and. (igas_Y .eq. igas_H2)) then + num_T_CO2H2=num_T + allocate(temp_arr_CO2H2(num_T_CO2H2)) + allocate(abs_arr_CO2H2_VI(L_NSPECTV,num_T_CO2H2)) + allocate(abs_arr_CO2H2_IR(L_NSPECTI,num_T_CO2H2)) + temp_arr_CO2H2(:)=temp_arr(:) + abs_arr_CO2H2_VI(:,:)=0. + abs_arr_CO2H2_IR(:,:)=0. + call interpolate_wn_abs_coeff(wn_arr,num_wn,abs_arr,abs_arr_CO2H2_VI,abs_arr_CO2H2_IR,num_T_CO2H2) + elseif ((igas_X .eq. igas_CO2) .and. (igas_Y .eq. igas_CH4)) then + num_T_CO2CH4=num_T + allocate(temp_arr_CO2CH4(num_T_CO2CH4)) + allocate(abs_arr_CO2CH4_VI(L_NSPECTV,num_T_CO2CH4)) + allocate(abs_arr_CO2CH4_IR(L_NSPECTI,num_T_CO2CH4)) + temp_arr_CO2CH4(:)=temp_arr(:) + abs_arr_CO2CH4_VI(:,:)=0. + abs_arr_CO2CH4_IR(:,:)=0. + call interpolate_wn_abs_coeff(wn_arr,num_wn,abs_arr,abs_arr_CO2CH4_VI,abs_arr_CO2CH4_IR,num_T_CO2CH4) + endif ! igas_X / igas_Y condition + + +!$OMP END MASTER +!$OMP BARRIER + + + endif ! firstcall + + ! We loop on all molecular pairs with available continuum data and interpolate in the temperature field + ! Two options: we call visible (VI) or infrared (IR) tables, depending on the value of c_WN + + if ((igas_X .eq. igas_CO2) .and. (igas_Y .eq. igas_CO2)) then + call T_boundaries_continuum(z_temp,temp,temp_arr_CO2CO2,num_T_CO2CO2) + if(c_WN .eq. 'IR') then + call interpolate_T_abs_coeff(z_temp,temp_arr_CO2CO2,num_T_CO2CO2,abs_coef,abs_arr_CO2CO2_IR(ind_WN,:)) + elseif(c_WN .eq. 'VI') then + call interpolate_T_abs_coeff(z_temp,temp_arr_CO2CO2,num_T_CO2CO2,abs_coef,abs_arr_CO2CO2_VI(ind_WN,:)) + else + print*,'You must select visible (VI) or infrared (IR) channel.' + call abort_physic(rname,"CO2CO2 bad channel",1) + endif + elseif ((igas_X .eq. igas_N2) .and. (igas_Y .eq. igas_N2)) then + call T_boundaries_continuum(z_temp,temp,temp_arr_N2N2,num_T_N2N2) + if(c_WN .eq. 'IR') then + call interpolate_T_abs_coeff(z_temp,temp_arr_N2N2,num_T_N2N2,abs_coef,abs_arr_N2N2_IR(ind_WN,:)) + elseif(c_WN .eq. 'VI') then + call interpolate_T_abs_coeff(z_temp,temp_arr_N2N2,num_T_N2N2,abs_coef,abs_arr_N2N2_VI(ind_WN,:)) + else + print*,'You must select visible (VI) or infrared (IR) channel.' + call abort_physic(rname,"N2N2 bad channel",1) + endif + elseif ((igas_X .eq. igas_O2) .and. (igas_Y .eq. igas_O2)) then + call T_boundaries_continuum(z_temp,temp,temp_arr_O2O2,num_T_O2O2) + if(c_WN .eq. 'IR') then + call interpolate_T_abs_coeff(z_temp,temp_arr_O2O2,num_T_O2O2,abs_coef,abs_arr_O2O2_IR(ind_WN,:)) + elseif(c_WN .eq. 'VI') then + call interpolate_T_abs_coeff(z_temp,temp_arr_O2O2,num_T_O2O2,abs_coef,abs_arr_O2O2_VI(ind_WN,:)) + else + print*,'You must select visible (VI) or infrared (IR) channel.' + call abort_physic(rname,"O2O2 bad channel",1) + endif + elseif ((igas_X .eq. igas_CH4) .and. (igas_Y .eq. igas_CH4)) then + call T_boundaries_continuum(z_temp,temp,temp_arr_CH4CH4,num_T_CH4CH4) + if(c_WN .eq. 'IR') then + call interpolate_T_abs_coeff(z_temp,temp_arr_CH4CH4,num_T_CH4CH4,abs_coef,abs_arr_CH4CH4_IR(ind_WN,:)) + elseif(c_WN .eq. 'VI') then + call interpolate_T_abs_coeff(z_temp,temp_arr_CH4CH4,num_T_CH4CH4,abs_coef,abs_arr_CH4CH4_VI(ind_WN,:)) + else + print*,'You must select visible (VI) or infrared (IR) channel.' + call abort_physic(rname,"CH4CH4 bad channel",1) + endif + elseif ((igas_X .eq. igas_H2) .and. (igas_Y .eq. igas_H2)) then + call T_boundaries_continuum(z_temp,temp,temp_arr_H2H2,num_T_H2H2) + if(c_WN .eq. 'IR') then + call interpolate_T_abs_coeff(z_temp,temp_arr_H2H2,num_T_H2H2,abs_coef,abs_arr_H2H2_IR(ind_WN,:)) + elseif(c_WN .eq. 'VI') then + call interpolate_T_abs_coeff(z_temp,temp_arr_H2H2,num_T_H2H2,abs_coef,abs_arr_H2H2_VI(ind_WN,:)) + else + print*,'You must select visible (VI) or infrared (IR) channel.' + call abort_physic(rname,"H2H2 bad channel",1) + endif + elseif ((igas_X .eq. igas_H2O) .and. (igas_Y .eq. igas_H2O)) then + call T_boundaries_continuum(z_temp,temp,temp_arr_H2OH2O,num_T_H2OH2O) + if(c_WN .eq. 'IR') then + call interpolate_T_abs_coeff(z_temp,temp_arr_H2OH2O,num_T_H2OH2O,abs_coef,abs_arr_H2OH2O_IR(ind_WN,:)) + elseif(c_WN .eq. 'VI') then + call interpolate_T_abs_coeff(z_temp,temp_arr_H2OH2O,num_T_H2OH2O,abs_coef,abs_arr_H2OH2O_VI(ind_WN,:)) + else + print*,'You must select visible (VI) or infrared (IR) channel.' + call abort_physic(rname,"H2OH2O bad channel",1) + endif + elseif ((igas_X .eq. igas_N2) .and. (igas_Y .eq. igas_H2)) then + call T_boundaries_continuum(z_temp,temp,temp_arr_N2H2,num_T_N2H2) + if(c_WN .eq. 'IR') then + call interpolate_T_abs_coeff(z_temp,temp_arr_N2H2,num_T_N2H2,abs_coef,abs_arr_N2H2_IR(ind_WN,:)) + elseif(c_WN .eq. 'VI') then + call interpolate_T_abs_coeff(z_temp,temp_arr_N2H2,num_T_N2H2,abs_coef,abs_arr_N2H2_VI(ind_WN,:)) + else + print*,'You must select visible (VI) or infrared (IR) channel.' + call abort_physic(rname,"N2H2 bad channel",1) + endif + elseif ((igas_X .eq. igas_N2) .and. (igas_Y .eq. igas_O2)) then + call T_boundaries_continuum(z_temp,temp,temp_arr_N2O2,num_T_N2O2) + if(c_WN .eq. 'IR') then + call interpolate_T_abs_coeff(z_temp,temp_arr_N2O2,num_T_N2O2,abs_coef,abs_arr_N2O2_IR(ind_WN,:)) + elseif(c_WN .eq. 'VI') then + call interpolate_T_abs_coeff(z_temp,temp_arr_N2O2,num_T_N2O2,abs_coef,abs_arr_N2O2_VI(ind_WN,:)) + else + print*,'You must select visible (VI) or infrared (IR) channel.' + call abort_physic(rname,"N2O2 bad channel",1) + endif + elseif ((igas_X .eq. igas_N2) .and. (igas_Y .eq. igas_CH4)) then + call T_boundaries_continuum(z_temp,temp,temp_arr_N2CH4,num_T_N2CH4) + if(c_WN .eq. 'IR') then + call interpolate_T_abs_coeff(z_temp,temp_arr_N2CH4,num_T_N2CH4,abs_coef,abs_arr_N2CH4_IR(ind_WN,:)) + elseif(c_WN .eq. 'VI') then + call interpolate_T_abs_coeff(z_temp,temp_arr_N2CH4,num_T_N2CH4,abs_coef,abs_arr_N2CH4_VI(ind_WN,:)) + else + print*,'You must select visible (VI) or infrared (IR) channel.' + call abort_physic(rname,"N2CH4 bad channel",1) + endif + elseif ((igas_X .eq. igas_CO2) .and. (igas_Y .eq. igas_O2)) then + call T_boundaries_continuum(z_temp,temp,temp_arr_CO2O2,num_T_CO2O2) + if(c_WN .eq. 'IR') then + call interpolate_T_abs_coeff(z_temp,temp_arr_CO2O2,num_T_CO2O2,abs_coef,abs_arr_CO2O2_IR(ind_WN,:)) + elseif(c_WN .eq. 'VI') then + call interpolate_T_abs_coeff(z_temp,temp_arr_CO2O2,num_T_CO2O2,abs_coef,abs_arr_CO2O2_VI(ind_WN,:)) + else + print*,'You must select visible (VI) or infrared (IR) channel.' + call abort_physic(rname,"CO2O2 bad channel",1) + endif + elseif ((igas_X .eq. igas_H2) .and. (igas_Y .eq. igas_CH4)) then + call T_boundaries_continuum(z_temp,temp,temp_arr_H2CH4,num_T_H2CH4) + if(c_WN .eq. 'IR') then + call interpolate_T_abs_coeff(z_temp,temp_arr_H2CH4,num_T_H2CH4,abs_coef,abs_arr_H2CH4_IR(ind_WN,:)) + elseif(c_WN .eq. 'VI') then + call interpolate_T_abs_coeff(z_temp,temp_arr_H2CH4,num_T_H2CH4,abs_coef,abs_arr_H2CH4_VI(ind_WN,:)) + else + print*,'You must select visible (VI) or infrared (IR) channel.' + call abort_physic(rname,"H2CH4 bad channel",1) + endif + elseif ((igas_X .eq. igas_H2) .and. (igas_Y .eq. igas_He)) then + call T_boundaries_continuum(z_temp,temp,temp_arr_H2He,num_T_H2He) + if(c_WN .eq. 'IR') then + call interpolate_T_abs_coeff(z_temp,temp_arr_H2He,num_T_H2He,abs_coef,abs_arr_H2He_IR(ind_WN,:)) + elseif(c_WN .eq. 'VI') then + call interpolate_T_abs_coeff(z_temp,temp_arr_H2He,num_T_H2He,abs_coef,abs_arr_H2He_VI(ind_WN,:)) + else + print*,'You must select visible (VI) or infrared (IR) channel.' + call abort_physic(rname,"H2He bad channel",1) + endif + elseif ((igas_X .eq. igas_H2O) .and. (igas_Y .eq. igas_N2)) then + call T_boundaries_continuum(z_temp,temp,temp_arr_H2ON2,num_T_H2ON2) + if(c_WN .eq. 'IR') then + call interpolate_T_abs_coeff(z_temp,temp_arr_H2ON2,num_T_H2ON2,abs_coef,abs_arr_H2ON2_IR(ind_WN,:)) + elseif(c_WN .eq. 'VI') then + call interpolate_T_abs_coeff(z_temp,temp_arr_H2ON2,num_T_H2ON2,abs_coef,abs_arr_H2ON2_VI(ind_WN,:)) + else + print*,'You must select visible (VI) or infrared (IR) channel.' + call abort_physic(rname,"H2ON2 bad channel",1) + endif + elseif ((igas_X .eq. igas_H2O) .and. (igas_Y .eq. igas_O2)) then + call T_boundaries_continuum(z_temp,temp,temp_arr_H2OO2,num_T_H2OO2) + if(c_WN .eq. 'IR') then + call interpolate_T_abs_coeff(z_temp,temp_arr_H2OO2,num_T_H2OO2,abs_coef,abs_arr_H2OO2_IR(ind_WN,:)) + elseif(c_WN .eq. 'VI') then + call interpolate_T_abs_coeff(z_temp,temp_arr_H2OO2,num_T_H2OO2,abs_coef,abs_arr_H2OO2_VI(ind_WN,:)) + else + print*,'You must select visible (VI) or infrared (IR) channel.' + call abort_physic(rname,"H2OO2 bad channel",1) + endif + elseif ((igas_X .eq. igas_H2O) .and. (igas_Y .eq. igas_CO2)) then + call T_boundaries_continuum(z_temp,temp,temp_arr_H2OCO2,num_T_H2OCO2) + if(c_WN .eq. 'IR') then + call interpolate_T_abs_coeff(z_temp,temp_arr_H2OCO2,num_T_H2OCO2,abs_coef,abs_arr_H2OCO2_IR(ind_WN,:)) + elseif(c_WN .eq. 'VI') then + call interpolate_T_abs_coeff(z_temp,temp_arr_H2OCO2,num_T_H2OCO2,abs_coef,abs_arr_H2OCO2_VI(ind_WN,:)) + else + print*,'You must select visible (VI) or infrared (IR) channel.' + call abort_physic(rname,"H2OCO2 bad channel",1) + endif + elseif ((igas_X .eq. igas_CO2) .and. (igas_Y .eq. igas_H2)) then + call T_boundaries_continuum(z_temp,temp,temp_arr_CO2H2,num_T_CO2H2) + if(c_WN .eq. 'IR') then + call interpolate_T_abs_coeff(z_temp,temp_arr_CO2H2,num_T_CO2H2,abs_coef,abs_arr_CO2H2_IR(ind_WN,:)) + elseif(c_WN .eq. 'VI') then + call interpolate_T_abs_coeff(z_temp,temp_arr_CO2H2,num_T_CO2H2,abs_coef,abs_arr_CO2H2_VI(ind_WN,:)) + else + print*,'You must select visible (VI) or infrared (IR) channel.' + call abort_physic(rname,"CO2H2 bad channel",1) + endif + elseif ((igas_X .eq. igas_CO2) .and. (igas_Y .eq. igas_CH4)) then + call T_boundaries_continuum(z_temp,temp,temp_arr_CO2CH4,num_T_CO2CH4) + if(c_WN .eq. 'IR') then + call interpolate_T_abs_coeff(z_temp,temp_arr_CO2CH4,num_T_CO2CH4,abs_coef,abs_arr_CO2CH4_IR(ind_WN,:)) + elseif(c_WN .eq. 'VI') then + call interpolate_T_abs_coeff(z_temp,temp_arr_CO2CH4,num_T_CO2CH4,abs_coef,abs_arr_CO2CH4_VI(ind_WN,:)) + else + print*,'You must select visible (VI) or infrared (IR) channel.' + call abort_physic(rname,"CO2CH4 bad channel",1) + endif + endif ! igas_X / igas_Y condition + + ! We compute the values of amagat for molecules X and Y + amagat_X = (273.15/temp)*(pres_X/101325.0) + amagat_Y = (273.15/temp)*(pres_Y/101325.0) + + ! We convert the absorption coefficient from cm^-1 amagat^-2 into m^-1 + abs_coef=abs_coef*100.0*amagat_X*amagat_Y + + !print*,'We have ',amagat_X,' amagats of molecule ', trim(gnom(igas_X)) + !print*,'We have ',amagat_X,' amagats of molecule ', trim(gnom(igas_Y)) + !print*,'So the absorption is ',abs_coef,' m^-1' + + end subroutine rad_correlatedk_continuum_interpolation + + + subroutine interpolate_wn_abs_coeff(wn_arr,num_wn,abs_arr_in,abs_arr_out_VI,abs_arr_out_IR,num_T) + +!================================================================== +! +! Purpose +! ------- +! Interpolate the continuum data into the visible (VI) and infrared (IR) spectral chanels. +! +! Author +! ------- +! M. Turbet (2025) +! +!================================================================== + + use radcommon_h, only : BWNV,BWNI,WNOI,WNOV + use radinc_h, only: L_NSPECTI, L_NSPECTV + use mod_phys_lmdz_para, only : is_master + + implicit none + + integer iW, iB, count_norm + integer,intent(in) :: num_T + integer,intent(in) :: num_wn + double precision,intent(in) :: wn_arr(num_wn) + double precision,intent(in) :: abs_arr_in(num_wn,num_T) + double precision,intent(out) :: abs_arr_out_IR(L_NSPECTI,num_T) + double precision,intent(out) :: abs_arr_out_VI(L_NSPECTV,num_T) + + ! First visible (VI) chanel + + ! We get read of all the wavenumbers lower than the minimum wavenumber in the visible wavenumber grid + iW=1 + do while((wn_arr(iW) .lt. BWNV(1)) .and. (iW .lt. num_wn)) + iW=iW+1 + enddo + + ! We compute the mean of the continuum absorption inside each wavenumber visible (VI) chanel + do iB = 1, L_NSPECTV + count_norm=0 + do while((wn_arr(iW) .lt. BWNV(iB+1)) .and. (iW .lt. num_wn)) + abs_arr_out_VI(iB,:)=abs_arr_out_VI(iB,:)+abs_arr_in(iW,:) + count_norm=count_norm+1 + iW=iW+1 + enddo + if(count_norm .ge. 1) abs_arr_out_VI(iB,:)=abs_arr_out_VI(iB,:)/count_norm + end do + + ! Then infrared (IR) chanel + + ! We get read of all the wavenumbers lower than the minimum wavenumber in the infrared wavenumber grid + iW=1 + do while((wn_arr(iW) .lt. BWNI(1)) .and. (iW .lt. num_wn)) + iW=iW+1 + enddo + + ! We compute the mean of the continuum absorption inside each wavenumber visible (VI) chanel + do iB = 1, L_NSPECTI + count_norm=0 + do while((wn_arr(iW) .lt. BWNI(iB+1)) .and. (iW .lt. num_wn)) + abs_arr_out_IR(iB,:)=abs_arr_out_IR(iB,:)+abs_arr_in(iW,:) + count_norm=count_norm+1 + iW=iW+1 + enddo + if(count_norm .ge. 1) abs_arr_out_IR(iB,:)=abs_arr_out_IR(iB,:)/count_norm + end do + + if (is_master) then + print*, 'Continuum absorption, first temperature, visible (VI):' + do iB = 1, L_NSPECTV + print*,WNOV(iB),' cm-1',abs_arr_out_VI(iB,1), ' cm-1 amagat-2' + end do + + print*, 'Continuum absorption, first temperature, infrared (IR):' + do iB = 1, L_NSPECTI + print*,WNOI(iB),' cm-1',abs_arr_out_IR(iB,1), ' cm-1 amagat-2' + end do + endif + + end subroutine interpolate_wn_abs_coeff + + + subroutine T_boundaries_continuum(z_temp,temp,temp_arr,num_T) + +!================================================================== +! +! Purpose +! ------- +! Check if the temperature is outside the boundaries of the continuum data temperatures. +! +! Author +! ------- +! M. Turbet (2025) +! +!================================================================== + + use callkeys_mod, only: strictboundcia + use mod_phys_lmdz_para, only : is_master + + implicit none + + double precision,intent(out) :: z_temp + double precision,intent(in) :: temp + integer,intent(in) :: num_T + double precision,intent(in) :: temp_arr(num_T) + + character(len=22) :: rname = "T_boundaries_continuum" + + z_temp=temp + + if(z_temp .lt. minval(temp_arr)) then + if (strictboundcia) then + if (is_master) then + print*,'Your temperatures are too low for this continuum dataset' + print*, 'Minimum temperature is ', minval(temp_arr), ' K' + endif + call abort_physic(rname,"temperature too low",1) + else + z_temp=minval(temp_arr) + endif + elseif(z_temp .gt. maxval(temp_arr)) then + if (strictboundcia) then + if (is_master) then + print*,'Your temperatures are too high for this continuum dataset' + print*, 'Maximum temperature is ', maxval(temp_arr), ' K' + endif + call abort_physic(rname,"temperature too high",1) + else + z_temp=maxval(temp_arr) + endif + endif + + end subroutine T_boundaries_continuum + + + subroutine interpolate_T_abs_coeff(z_temp,temp_arr,num_T,abs_coef,abs_arr) + +!================================================================== +! +! Purpose +! ------- +! Interpolate in the continuum data using the temperature field +! +! Author +! ------- +! M. Turbet (2025) +! +!================================================================== + + implicit none + + integer iT + double precision,intent(in) :: z_temp + integer,intent(in) :: num_T + double precision,intent(in) :: temp_arr(num_T) + + double precision,intent(out) :: abs_coef + double precision,intent(in) :: abs_arr(num_T) + + ! Check where to interpolate + iT=1 + do while ( z_temp .gt. temp_arr(iT) ) + iT=iT+1 + end do + + ! If below lowest temperature in temp_arr() + if (iT==1) then + abs_coef=abs_arr(1) + return + endif + + ! We proceed to a simple linear interpolation using the two most nearby temperatures + if(iT .lt. num_T) then + abs_coef=abs_arr(iT-1)+(abs_arr(iT)-abs_arr(iT-1))*(z_temp-temp_arr(iT-1))/(temp_arr(iT)-temp_arr(iT-1)) + else + ! If above highest temperature + abs_coef=abs_arr(iT) + endif + + !print*,'the absorption is ',abs_coef,' cm^-1 amagat^-2' + + + end subroutine interpolate_T_abs_coeff + +end module rad_correlatedk_continuum_interpolation_mod Index: trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_fluxes_solver_stellar.F =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_fluxes_solver_stellar.F (revision 4077) +++ trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_fluxes_solver_stellar.F (revision 4077) @@ -0,0 +1,339 @@ + module rad_correlatedk_fluxes_solver_stellar_mod + + implicit none + + contains + + SUBROUTINE rad_correlatedk_fluxes_solver_stellar(DTDEL, + * TDEL,TAUCUMIN,WDEL,CDEL,UBAR0,F0PI,RSF,BTOP, + * BSURF,FMIDP,FMIDM,DIFFV,FLUXUP,FLUXDN) + +C THIS SUBROUTINE TAKES THE OPTICAL CONSTANTS AND BOUNDARY CONDITIONS +C FOR THE VISIBLE FLUX AT ONE WAVELENGTH AND SOLVES FOR THE FLUXES AT +C THE LEVELS. THIS VERSION IS SET UP TO WORK WITH LAYER OPTICAL DEPTHS +C MEASURED FROM THE TOP OF EACH LAYER. (DTAU) TOP OF EACH LAYER HAS +C OPTICAL DEPTH TAU(N).IN THIS SUB LEVEL N IS ABOVE LAYER N. THAT IS LAYER N +C HAS LEVEL N ON TOP AND LEVEL N+1 ON BOTTOM. OPTICAL DEPTH INCREASES +C FROM TOP TO BOTTOM. SEE C.P. MCKAY, TGM NOTES. +C THIS SUBROUTINE DIFFERS FROM ITS IR COUNTERPART IN THAT HERE WE SOLVE FOR +C THE FLUXES DIRECTLY USING THE GENERALIZED NOTATION OF MEADOR AND WEAVOR +C J.A.S., 37, 630-642, 1980. +C THE TRI-DIAGONAL MATRIX SOLVER IS rad_tridiagonal_matrix_solver AND IS DOUBLE PRECISION SO MANY +C VARIABLES ARE PASSED AS SINGLE THEN BECOME DOUBLE IN rad_tridiagonal_matrix_solver +C +C NLL = NUMBER OF LEVELS (NAYER + 1) THAT WILL BE SOLVED +C NAYER = NUMBER OF LAYERS (NOTE DIFFERENT SPELLING HERE) +C WAVEN = WAVELENGTH FOR THE COMPUTATION +C DTDEL(NLAYER) = ARRAY OPTICAL DEPTH OF THE LAYERS +C TDEL(NLL) = ARRAY COLUMN OPTICAL DEPTH AT THE LEVELS +C WDEL(NLEVEL) = SINGLE SCATTERING ALBEDO +C CDEL(NLL) = ASYMMETRY FACTORS, 0=ISOTROPIC +C UBARV = AVERAGE ANGLE, +C UBAR0 = SOLAR ZENITH ANGLE +C F0PI = INCIDENT SOLAR DIRECT BEAM FLUX +C RSF = SURFACE REFLECTANCE +C BTOP = UPPER BOUNDARY CONDITION ON DIFFUSE FLUX +C BSURF = REFLECTED DIRECT BEAM = (1-RSFI)*F0PI*EDP-TAU/U +C FP(NLEVEL) = UPWARD FLUX AT LEVELS +C FM(NLEVEL) = DOWNWARD FLUX AT LEVELS +C FMIDP(NLAYER) = UPWARD FLUX AT LAYER MIDPOINTS +C FMIDM(NLAYER) = DOWNWARD FLUX AT LAYER MIDPOINTS +C added Dec 2002 +C DIFFV = downward diffuse solar flux at the surface +C +!======================================================================! + + use radinc_h, only: L_TAUMAX, L_NLAYRAD, L_NLEVRAD, L_LEVELS + + implicit none + +!! INTEGER NLP +!! PARAMETER (NLP=101) ! MUST BE LARGER THAN NLEVEL + + REAL*8 EM, EP, EXPTRM + REAL*8 W0(L_NLAYRAD), COSBAR(L_NLAYRAD), DTAU(L_NLAYRAD) + REAL*8 TAU(L_NLEVRAD), WDEL(L_NLAYRAD), CDEL(L_NLAYRAD) + REAL*8 DTDEL(L_NLAYRAD), TDEL(L_NLEVRAD) + REAL*8 FMIDP(L_NLAYRAD), FMIDM(L_NLAYRAD) + REAL*8 LAMDA(L_NLAYRAD), ALPHA(L_NLAYRAD), XK1(L_NLAYRAD) + REAL*8 XK2(L_NLAYRAD),G1(L_NLAYRAD), G2(L_NLAYRAD) + REAL*8 G3(L_NLAYRAD), GAMA(L_NLAYRAD),CP(L_NLAYRAD),CM(L_NLAYRAD) + REAL*8 CPM1(L_NLAYRAD),CMM1(L_NLAYRAD), E1(L_NLAYRAD) + REAL*8 E2(L_NLAYRAD),E3(L_NLAYRAD),E4(L_NLAYRAD) + REAL*8 FLUXUP, FLUXDN + REAL*8 FACTOR, TAUCUMIN(L_LEVELS), TAUCUM(L_LEVELS) + + integer NAYER, L, K + real*8 ubar0, f0pi, rsf, btop, bsurf, g4, denom, am, ap + real*8 taumax, taumid, cpmid, cmmid + real*8 diffv + +C======================================================================C + + + + + NAYER = L_NLAYRAD + TAUMAX = L_TAUMAX !Default is 35.0 + +! Delta-Eddington Scaling + + + FACTOR = 1.0D0 - WDEL(1)*CDEL(1)**2 + + TAU(1) = TDEL(1)*FACTOR + TAUCUM(1) = 0.0D0 + TAUCUM(2) = TAUCUMIN(2)*FACTOR + TAUCUM(3) = TAUCUM(2) +(TAUCUMIN(3)-TAUCUMIN(2))*FACTOR + + + DO L=1,L_NLAYRAD-1 + FACTOR = 1.0D0 - WDEL(L)*CDEL(L)**2 + W0(L) = WDEL(L)*(1.0D0-CDEL(L)**2)/FACTOR + COSBAR(L) = CDEL(L)/(1.0D0+CDEL(L)) + + DTAU(L) = DTDEL(L)*FACTOR + TAU(L+1) = TAU(L)+DTAU(L) + K = 2*(L+1) + TAUCUM(K) = TAU(L+1) + TAUCUM(K+1) = TAUCUM(K) + (TAUCUMIN(K+1)-TAUCUMIN(K))*FACTOR + END DO + +! Bottom layer + + L = L_NLAYRAD + FACTOR = 1.0D0 - WDEL(L)*CDEL(L)**2 + W0(L) = WDEL(L)*(1.0D0-CDEL(L)**2)/FACTOR + COSBAR(L) = CDEL(L)/(1.0D0+CDEL(L)) + DTAU(L) = DTDEL(L)*FACTOR + TAU(L+1) = TAU(L)+DTAU(L) + TAUCUM(2*L+1) = TAU(L+1) + + BSURF = RSF*UBAR0*F0PI*EXP(-MIN(TAU(L+1),TAUMAX)/UBAR0) + ! new definition of BSURF + ! the old one was false because it used tau, not tau' + ! tau' includes the contribution to the downward flux + ! of the radiation scattered in the forward direction + +C WE GO WITH THE QUADRATURE APPROACH HERE. THE "SQRT(3)" factors +C ARE THE UBARV TERM. + + DO L=1,L_NLAYRAD + + ALPHA(L)=SQRT( (1.0-W0(L))/(1.0-W0(L)*COSBAR(L) ) ) + +C SET OF CONSTANTS DETERMINED BY DOM + +! Quadrature method + G1(L) = (SQRT(3.0)*0.5)*(2.0- W0(L)*(1.0+COSBAR(L))) + G2(L) = (SQRT(3.0)*W0(L)*0.5)*(1.0-COSBAR(L)) + G3(L) = 0.5*(1.0-SQRT(3.0)*COSBAR(L)*UBAR0) + +! ----- some other methods... (RDW) ------ + +! Eddington method +! G1(L) = 0.25*(7.0 - W0(L)*(4.0 - 3.0*COSBAR(L))) +! G2(L) = -0.25*(1.0 - W0(L)*(4.0 - 3.0*COSBAR(L))) +! G3(L) = 0.25*(2.0 - 3.0*COSBAR(L)*UBAR0) + +! delta-Eddington method +! G1(L) = (7.0 - 3.0*g^2 - W0(L)*(4.0 + 3.0*g) + W0(L)*g^2*(4*beta0 + 3*g)) / & +! (4* (1 - g^2*() )) 0.25*(7.0 - W0(L)*(4.0 - 3.0*COSBAR(L))) + +! Hybrid modified Eddington-delta function method + +! ---------------------------------------- + +c So they use Quadrature +c but the scaling is Eddington? + + LAMDA(L) = SQRT(G1(L)**2 - G2(L)**2) + GAMA(L) = (G1(L)-LAMDA(L))/G2(L) + END DO + + + DO L=1,L_NLAYRAD + G4 = 1.0-G3(L) + DENOM = LAMDA(L)**2 - 1./UBAR0**2 + +C THERE IS A POTENTIAL PROBLEM HERE IF W0=0 AND UBARV=UBAR0 +C THEN DENOM WILL VANISH. THIS ONLY HAPPENS PHYSICALLY WHEN +C THE SCATTERING GOES TO ZERO +C PREVENT THIS WITH AN IF STATEMENT + + IF ( DENOM .EQ. 0.) THEN + DENOM=1.E-10 + END IF + + + AM = F0PI*W0(L)*(G4 *(G1(L)+1./UBAR0) +G2(L)*G3(L) )/DENOM + AP = F0PI*W0(L)*(G3(L)*(G1(L)-1./UBAR0) +G2(L)*G4 )/DENOM + +C CPM1 AND CMM1 ARE THE CPLUS AND CMINUS TERMS EVALUATED +C AT THE TOP OF THE LAYER, THAT IS LOWER OPTICAL DEPTH TAU(L) + + CPM1(L) = AP*EXP(-TAU(L)/UBAR0) + CMM1(L) = AM*EXP(-TAU(L)/UBAR0) + +C CP AND CM ARE THE CPLUS AND CMINUS TERMS EVALUATED AT THE +C BOTTOM OF THE LAYER. THAT IS AT HIGHER OPTICAL DEPTH TAU(L+1) + + CP(L) = AP*EXP(-TAU(L+1)/UBAR0) + CM(L) = AM*EXP(-TAU(L+1)/UBAR0) + + END DO + + + +C NOW CALCULATE THE EXPONENTIAL TERMS NEEDED +C FOR THE TRIDIAGONAL ROTATED LAYERED METHOD + + DO L=1,L_NLAYRAD + EXPTRM = MIN(TAUMAX,LAMDA(L)*DTAU(L)) ! CLIPPED EXPONENTIAL + EP = EXP(EXPTRM) + + EM = 1.0/EP + E1(L) = EP+GAMA(L)*EM + E2(L) = EP-GAMA(L)*EM + E3(L) = GAMA(L)*EP+EM + E4(L) = GAMA(L)*EP-EM + END DO + + CALL rad_tridiagonal_matrix_solver(NAYER,GAMA,CP,CM,CPM1, + * CMM1,E1,E2,E3,E4,BTOP,BSURF,RSF,XK1,XK2) + +C NOW WE CALCULATE THE FLUXES AT THE MIDPOINTS OF THE LAYERS. + + DO L=1,L_NLAYRAD-1 + EXPTRM = MIN(TAUMAX,LAMDA(L)*(TAUCUM(2*L+1)-TAUCUM(2*L))) + + EP = EXP(EXPTRM) + + EM = 1.0/EP + G4 = 1.0-G3(L) + DENOM = LAMDA(L)**2 - 1./UBAR0**2 + +C THERE IS A POTENTIAL PROBLEM HERE IF W0=0 AND UBARV=UBAR0 +C THEN DENOM WILL VANISH. THIS ONLY HAPPENS PHYSICALLY WHEN +C THE SCATTERING GOES TO ZERO +C PREVENT THIS WITH A IF STATEMENT + + + IF ( DENOM .EQ. 0.) THEN + DENOM=1.E-10 + END IF + + AM = F0PI*W0(L)*(G4 *(G1(L)+1./UBAR0) +G2(L)*G3(L) )/DENOM + AP = F0PI*W0(L)*(G3(L)*(G1(L)-1./UBAR0) +G2(L)*G4 )/DENOM + +C CPMID AND CMMID ARE THE CPLUS AND CMINUS TERMS EVALUATED +C AT THE MIDDLE OF THE LAYER. + + TAUMID = TAUCUM(2*L+1) + + CPMID = AP*EXP(-TAUMID/UBAR0) + CMMID = AM*EXP(-TAUMID/UBAR0) + + FMIDP(L) = XK1(L)*EP + GAMA(L)*XK2(L)*EM + CPMID + FMIDM(L) = XK1(L)*EP*GAMA(L) + XK2(L)*EM + CMMID + +C ADD THE DIRECT FLUX TO THE DOWNWELLING TERM + + FMIDM(L)= FMIDM(L)+UBAR0*F0PI*EXP(-MIN(TAUMID,TAUMAX)/UBAR0) + + END DO + +C FLUX AT THE Ptop layer + +! EP = 1.0 +! EM = 1.0 +C JL18 correction to account for the fact that the radiative top is not at zero optical depth. + EXPTRM = MIN(TAUMAX,LAMDA(L)*(TAUCUM(2))) + EP = EXP(EXPTRM) + EM = 1.0/EP + G4 = 1.0-G3(1) + DENOM = LAMDA(1)**2 - 1./UBAR0**2 + +C THERE IS A POTENTIAL PROBLEM HERE IF W0=0 AND UBARV=UBAR0 +C THEN DENOM WILL VANISH. THIS ONLY HAPPENS PHYSICALLY WHEN +C THE SCATTERING GOES TO ZERO +C PREVENT THIS WITH A IF STATEMENT + + IF ( DENOM .EQ. 0.) THEN + DENOM=1.E-10 + END IF + + AM = F0PI*W0(1)*(G4 *(G1(1)+1./UBAR0) +G2(1)*G3(1) )/DENOM + AP = F0PI*W0(1)*(G3(1)*(G1(1)-1./UBAR0) +G2(1)*G4 )/DENOM + +C CPMID AND CMMID ARE THE CPLUS AND CMINUS TERMS EVALUATED +C AT THE MIDDLE OF THE LAYER. + +C CPMID = AP +C CMMID = AM +C JL18 correction to account for the fact that the radiative top is not at zero optical depth. + TAUMID = TAUCUM(2) + CPMID = AP*EXP(-TAUMID/UBAR0) + CMMID = AM*EXP(-TAUMID/UBAR0) + + FLUXUP = XK1(1)*EP + GAMA(1)*XK2(1)*EM + CPMID + FLUXDN = XK1(1)*EP*GAMA(1) + XK2(1)*EM + CMMID + +C ADD THE DIRECT FLUX TO THE DOWNWELLING TERM + +! fluxdn = fluxdn+UBAR0*F0PI*EXP(-MIN(TAUCUM(1),TAUMAX)/UBAR0) +!JL18 the line above assumed that the top of the radiative model was P=0 +! it seems to be better for the IR to use the middle of the last physical layer as the radiative top. +! so we correct the downwelling flux below for the calculation of the heating rate + fluxdn = fluxdn+UBAR0*F0PI*EXP(-TAUCUM(2)/UBAR0) + +C This is for the "special" bottom layer, where we take +C DTAU instead of DTAU/2. + + L = L_NLAYRAD + EXPTRM = MIN(TAUMAX,LAMDA(L)*(TAUCUM(L_LEVELS)- + * TAUCUM(L_LEVELS-1))) + + EP = EXP(EXPTRM) + EM = 1.0/EP + G4 = 1.0-G3(L) + DENOM = LAMDA(L)**2 - 1./UBAR0**2 + + +C THERE IS A POTENTIAL PROBLEM HERE IF W0=0 AND UBARV=UBAR0 +C THEN DENOM WILL VANISH. THIS ONLY HAPPENS PHYSICALLY WHEN +C THE SCATTERING GOES TO ZERO +C PREVENT THIS WITH A IF STATEMENT + + + IF ( DENOM .EQ. 0.) THEN + DENOM=1.E-10 + END IF + + AM = F0PI*W0(L)*(G4 *(G1(L)+1./UBAR0) +G2(L)*G3(L) )/DENOM + AP = F0PI*W0(L)*(G3(L)*(G1(L)-1./UBAR0) +G2(L)*G4 )/DENOM + +C CPMID AND CMMID ARE THE CPLUS AND CMINUS TERMS EVALUATED +C AT THE MIDDLE OF THE LAYER. + + TAUMID = MIN(TAUCUM(L_LEVELS),TAUMAX) + CPMID = AP*EXP(-MIN(TAUMID,TAUMAX)/UBAR0) + CMMID = AM*EXP(-MIN(TAUMID,TAUMAX)/UBAR0) + + + FMIDP(L) = XK1(L)*EP + GAMA(L)*XK2(L)*EM + CPMID + FMIDM(L) = XK1(L)*EP*GAMA(L) + XK2(L)*EM + CMMID + +C Save the diffuse downward flux for TEMPGR calculations + + DIFFV = FMIDM(L) + + +C ADD THE DIRECT FLUX TO THE DOWNWELLING TERM + + FMIDM(L)= FMIDM(L)+UBAR0*F0PI*EXP(-MIN(TAUMID,TAUMAX)/UBAR0) + + + END SUBROUTINE rad_correlatedk_fluxes_solver_stellar + + end module rad_correlatedk_fluxes_solver_stellar_mod Index: trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_fluxes_solver_thermal.F =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_fluxes_solver_thermal.F (revision 4077) +++ trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_fluxes_solver_thermal.F (revision 4077) @@ -0,0 +1,247 @@ + module rad_correlatedk_fluxes_solver_thermal_mod + + implicit none + + contains + + SUBROUTINE rad_correlatedk_fluxes_solver_thermal(NLL, + * TLEV,NW,DW,DTAU,TAUCUM,W0,COSBAR,UBARI, + * RSF,BTOP,BSURF,FTOPUP,FMIDP,FMIDM) + + use radinc_h, only: L_TAUMAX, NTfac, NTstart + use radinc_h, only: L_NLAYRAD, L_LEVELS + use radcommon_h, only: planckir + use comcstfi_mod, only: pi + + IMPLICIT NONE + +!----------------------------------------------------------------------- +! THIS SUBROUTINE TAKES THE OPTICAL CONSTANTS AND BOUNDARY CONDITIONS +! FOR THE INFRARED FLUX AT ONE WAVELENGTH AND SOLVES FOR THE FLUXES AT +! THE LEVELS. THIS VERSION IS SET UP TO WORK WITH LAYER OPTICAL DEPTHS +! MEASURED FROM THE TOP OF EACH LAYER. THE TOP OF EACH LAYER HAS +! OPTICAL DEPTH ZERO. IN THIS SUB LEVEL N IS ABOVE LAYER N. THAT IS LAYER N +! HAS LEVEL N ON TOP AND LEVEL N+1 ON BOTTOM. OPTICAL DEPTH INCREASES +! FROM TOP TO BOTTOM. SEE C.P. MCKAY, TGM NOTES. +! THE TRI-DIAGONAL MATRIX SOLVER IS rad_tridiagonal_matrix_solver AND IS DOUBLE PRECISION SO MANY +! VARIABLES ARE PASSED AS SINGLE THEN BECOME DOUBLE IN rad_tridiagonal_matrix_solver +! +! NLL = NUMBER OF LEVELS (NLAYERS + 1) MUST BE LESS THAT NL (101) +! TLEV(L_LEVELS) = ARRAY OF TEMPERATURES AT GCM LEVELS +! WAVEN = WAVELENGTH FOR THE COMPUTATION +! DW = WAVENUMBER INTERVAL +! DTAU(NLAYER) = ARRAY OPTICAL DEPTH OF THE LAYERS +! W0(NLEVEL) = SINGLE SCATTERING ALBEDO +! COSBAR(NLEVEL) = ASYMMETRY FACTORS, 0=ISOTROPIC +! UBARI = AVERAGE ANGLE, MUST BE EQUAL TO 0.5 IN IR +! RSF = SURFACE REFLECTANCE +! BTOP = UPPER BOUNDARY CONDITION ON IR INTENSITY (NOT FLUX) +! BSURF = SURFACE EMISSION = (1-RSFI)*PLANCK, INTENSITY (NOT FLUX) +! FP(NLEVEL) = UPWARD FLUX AT LEVELS +! FM(NLEVEL) = DOWNWARD FLUX AT LEVELS +! FMIDP(NLAYER) = UPWARD FLUX AT LAYER MIDPOINTS +! FMIDM(NLAYER) = DOWNWARD FLUX AT LAYER MIDPOINTS +!----------------------------------------------------------------------- + + INTEGER NLL, NLAYER, L, NW, NT, NT2 + REAL*8 TERM, CPMID, CMMID + REAL*8 PLANCK + REAL*8 EM,EP + REAL*8 COSBAR(L_NLAYRAD), W0(L_NLAYRAD), DTAU(L_NLAYRAD) + REAL*8 TAUCUM(L_LEVELS), DTAUK + REAL*8 TLEV(L_LEVELS) + REAL*8 WAVEN, DW, UBARI, RSF + REAL*8 BTOP, BSURF, FMIDP(L_NLAYRAD), FMIDM(L_NLAYRAD) + REAL*8 B0(L_NLAYRAD) + REAL*8 B1(L_NLAYRAD) + REAL*8 ALPHA(L_NLAYRAD) + REAL*8 LAMDA(L_NLAYRAD),XK1(L_NLAYRAD),XK2(L_NLAYRAD) + REAL*8 GAMA(L_NLAYRAD),CP(L_NLAYRAD),CM(L_NLAYRAD) + REAL*8 CPM1(L_NLAYRAD),CMM1(L_NLAYRAD),E1(L_NLAYRAD) + REAL*8 E2(L_NLAYRAD) + REAL*8 E3(L_NLAYRAD) + REAL*8 E4(L_NLAYRAD) + REAL*8 FTOPUP, FLUXUP, FLUXDN + REAL*8 :: TAUMAX = L_TAUMAX + +! AB : variables for interpolation + REAL*8 C1 + REAL*8 C2 + REAL*8 P1 + REAL*8 P2 + +!======================================================================= +! WE GO WITH THE HEMISPHERIC CONSTANT APPROACH IN THE INFRARED + + NLAYER = L_NLAYRAD + + DO L=1,L_NLAYRAD-1 + +!----------------------------------------------------------------------- +! There is a problem when W0 = 1 +! open(888,file='W0') +! if ((W0(L).eq.0.).or.(W0(L).eq.1.)) then +! write(888,*) W0(L), L, 'rad_correlatedk_fluxes_solver_thermal' +! endif +! Prevent this with an if statement: +!----------------------------------------------------------------------- + if (W0(L).eq.1.D0) then + W0(L) = 0.99999D0 + endif + + ALPHA(L) = SQRT( (1.0D0-W0(L))/(1.0D0-W0(L)*COSBAR(L)) ) + LAMDA(L) = ALPHA(L)*(1.0D0-W0(L)*COSBAR(L))/UBARI + + NT = int(TLEV(2*L)*NTfac) - NTstart+1 + NT2 = int(TLEV(2*L+2)*NTfac) - NTstart+1 + +! AB : PLANCKIR(NW,NT) is replaced by P1, the linear interpolation result for a temperature NT +! AB : idem for PLANCKIR(NW,NT2) and P2 + C1 = TLEV(2*L) * NTfac - int(TLEV(2*L) * NTfac) + C2 = TLEV(2*L+2)*NTfac - int(TLEV(2*L+2)*NTfac) + P1 = (1.0D0 - C1) * PLANCKIR(NW,NT) + C1 * PLANCKIR(NW,NT+1) + P2 = (1.0D0 - C2) * PLANCKIR(NW,NT2) + C2 * PLANCKIR(NW,NT2+1) + B1(L) = (P2 - P1) / DTAU(L) + B0(L) = P1 + END DO + +! Take care of special lower layer + + L = L_NLAYRAD + + if (W0(L).eq.1.) then + W0(L) = 0.99999D0 + end if + + ALPHA(L) = SQRT( (1.0D0-W0(L))/(1.0D0-W0(L)*COSBAR(L)) ) + LAMDA(L) = ALPHA(L)*(1.0D0-W0(L)*COSBAR(L))/UBARI + + ! Tsurf is used for 1st layer source function + ! -- same results for most thin atmospheres + ! -- and stabilizes integrations + NT = int(TLEV(2*L+1)*NTfac) - NTstart+1 + !! For deep, opaque, thick first layers (e.g. Saturn) + !! what is below works much better, not unstable, ... + !! ... and actually fully accurate because 1st layer temp (JL) + !NT = int(TLEV(2*L)*NTfac) - NTstart+1 + !! (or this one yields same results + !NT = int( (TLEV(2*L)+TLEV(2*L+1))*0.5*NTfac ) - NTstart+1 + + NT2 = int(TLEV(2*L)*NTfac) - NTstart+1 + +! AB : PLANCKIR(NW,NT) is replaced by P1, the linear interpolation result for a temperature NT +! AB : idem for PLANCKIR(NW,NT2) and P2 + C1 = TLEV(2*L+1)*NTfac - int(TLEV(2*L+1)*NTfac) + C2 = TLEV(2*L) * NTfac - int(TLEV(2*L) * NTfac) + P1 = (1.0D0 - C1) * PLANCKIR(NW,NT) + C1 * PLANCKIR(NW,NT+1) + P2 = (1.0D0 - C2) * PLANCKIR(NW,NT2) + C2 * PLANCKIR(NW,NT2+1) + B1(L) = (P1 - P2) / DTAU(L) + B0(L) = P2 + + DO L=1,L_NLAYRAD + GAMA(L) = (1.0D0-ALPHA(L))/(1.0D0+ALPHA(L)) + TERM = UBARI/(1.0D0-W0(L)*COSBAR(L)) + +! CPM1 AND CMM1 ARE THE CPLUS AND CMINUS TERMS EVALUATED +! AT THE TOP OF THE LAYER, THAT IS ZERO OPTICAL DEPTH + + CPM1(L) = B0(L)+B1(L)*TERM + CMM1(L) = B0(L)-B1(L)*TERM + +! CP AND CM ARE THE CPLUS AND CMINUS TERMS EVALUATED AT THE +! BOTTOM OF THE LAYER. THAT IS AT DTAU OPTICAL DEPTH. +! JL18 put CP and CM after the calculation of CPM1 and CMM1 to avoid unecessary calculations. + + CP(L) = CPM1(L) +B1(L)*DTAU(L) + CM(L) = CMM1(L) +B1(L)*DTAU(L) + END DO + +! NOW CALCULATE THE EXPONENTIAL TERMS NEEDED +! FOR THE TRIDIAGONAL ROTATED LAYERED METHOD +! WARNING IF DTAU(J) IS GREATER THAN ABOUT 35 (VAX) +! WE CLIP IT TO AVOID OVERFLOW. + + DO L=1,L_NLAYRAD + EP = EXP( MIN((LAMDA(L)*DTAU(L)),TAUMAX)) ! CLIPPED EXPONENTIAL + EM = 1.0D0/EP + E1(L) = EP+GAMA(L)*EM + E2(L) = EP-GAMA(L)*EM + E3(L) = GAMA(L)*EP+EM + E4(L) = GAMA(L)*EP-EM + END DO + +! B81=BTOP ! RENAME BEFORE CALLING rad_tridiagonal_matrix_solver - used to be to set +! B82=BSURF ! them to real*8 - but now everything is real*8 +! R81=RSF ! so this may not be necessary + +! DOUBLE PRECISION TRIDIAGONAL SOLVER + + CALL rad_tridiagonal_matrix_solver(NLAYER,GAMA,CP,CM,CPM1, + * CMM1,E1,E2,E3,E4,BTOP,BSURF,RSF,XK1,XK2) + +! NOW WE CALCULATE THE FLUXES AT THE MIDPOINTS OF THE LAYERS. + + DO L=1,L_NLAYRAD-1 + DTAUK = TAUCUM(2*L+1)-TAUCUM(2*L) + EP = EXP(MIN(LAMDA(L)*DTAUK,TAUMAX)) ! CLIPPED EXPONENTIAL + EM = 1.0D0/EP + TERM = UBARI/(1.D0-W0(L)*COSBAR(L)) + +! CP AND CM ARE THE CPLUS AND CMINUS TERMS EVALUATED AT THE +! BOTTOM OF THE LAYER. THAT IS AT DTAU OPTICAL DEPTH + + CPMID = B0(L)+B1(L)*DTAUK +B1(L)*TERM + CMMID = B0(L)+B1(L)*DTAUK -B1(L)*TERM + FMIDP(L) = XK1(L)*EP + GAMA(L)*XK2(L)*EM + CPMID + FMIDM(L) = XK1(L)*EP*GAMA(L) + XK2(L)*EM + CMMID + +! FOR FLUX WE INTEGRATE OVER THE HEMISPHERE TREATING INTENSITY CONSTANT + + FMIDP(L) = FMIDP(L)*PI + FMIDM(L) = FMIDM(L)*PI + END DO + +! And now, for the special bottom layer + + L = L_NLAYRAD + + EP = EXP(MIN((LAMDA(L)*DTAU(L)),TAUMAX)) ! CLIPPED EXPONENTIAL + EM = 1.0D0/EP + TERM = UBARI/(1.D0-W0(L)*COSBAR(L)) + +! CP AND CM ARE THE CPLUS AND CMINUS TERMS EVALUATED AT THE +! BOTTOM OF THE LAYER. THAT IS AT DTAU OPTICAL DEPTH + + CPMID = B0(L)+B1(L)*DTAU(L) +B1(L)*TERM + CMMID = B0(L)+B1(L)*DTAU(L) -B1(L)*TERM + FMIDP(L) = XK1(L)*EP + GAMA(L)*XK2(L)*EM + CPMID + FMIDM(L) = XK1(L)*EP*GAMA(L) + XK2(L)*EM + CMMID + +! FOR FLUX WE INTEGRATE OVER THE HEMISPHERE TREATING INTENSITY CONSTANT + + FMIDP(L) = FMIDP(L)*PI + FMIDM(L) = FMIDM(L)*PI + +! FLUX AT THE PTOP LEVEL + + EP = 1.0D0 + EM = 1.0D0 + TERM = UBARI/(1.0D0-W0(1)*COSBAR(1)) + +! CP AND CM ARE THE CPLUS AND CMINUS TERMS EVALUATED AT THE +! BOTTOM OF THE LAYER. THAT IS AT DTAU OPTICAL DEPTH + + CPMID = B0(1)+B1(1)*TERM + CMMID = B0(1)-B1(1)*TERM + + FLUXUP = XK1(1)*EP + GAMA(1)*XK2(1)*EM + CPMID + FLUXDN = XK1(1)*EP*GAMA(1) + XK2(1)*EM + CMMID + +! FOR FLUX WE INTEGRATE OVER THE HEMISPHERE TREATING INTENSITY CONSTANT + + FTOPUP = (FLUXUP-FLUXDN)*PI + + + END SUBROUTINE rad_correlatedk_fluxes_solver_thermal + + end module rad_correlatedk_fluxes_solver_thermal_mod Index: trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_fluxes_stellar.F =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_fluxes_stellar.F (revision 4077) +++ trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_fluxes_stellar.F (revision 4077) @@ -0,0 +1,202 @@ + module rad_correlatedk_fluxes_stellar_mod + + implicit none + + contains + + SUBROUTINE rad_correlatedk_fluxes_stellar(DTAUV,TAUV, + * TAUCUMV,RSFV,DWNV,WBARV,COSBV, + * UBAR0,STEL,NFLUXTOPV,FLUXTOPVDN, + * NFLUXOUTV_nu,NFLUXGNDV_nu, + * FMNETV,FLUXUPV,FLUXDNV,FZEROV,taugsurf) + + use radinc_h, only: L_TAUMAX, L_LEVELS, L_NSPECTV, L_NGAUSS + use radinc_h, only: L_NLAYRAD, L_NLEVRAD + use radcommon_h, only: tlimit, gweight + use rad_correlatedk_fluxes_solver_stellar_mod, only: + * rad_correlatedk_fluxes_solver_stellar + + implicit none + + real*8 FMNETV(L_NLAYRAD) + real*8 TAUCUMV(L_LEVELS,L_NSPECTV,L_NGAUSS) + real*8 TAUV(L_NLEVRAD,L_NSPECTV,L_NGAUSS) + real*8 DTAUV(L_NLAYRAD,L_NSPECTV,L_NGAUSS), DWNV(L_NSPECTV) + real*8 FMUPV(L_NLAYRAD), FMDV(L_NLAYRAD) + real*8 COSBV(L_NLAYRAD,L_NSPECTV,L_NGAUSS) + real*8 WBARV(L_NLAYRAD,L_NSPECTV,L_NGAUSS) + real*8 STEL(L_NSPECTV) + real*8 FLUXUPV(L_NLAYRAD), FLUXDNV(L_NLAYRAD) + real*8 NFLUXTOPV, FLUXUP, FLUXDN,FLUXTOPVDN + real*8 NFLUXOUTV_nu(L_NSPECTV) + real*8 NFLUXGNDV_nu(L_NSPECTV) + + integer L, NG, NW, NG1,k + real*8 ubar0, f0pi, btop, bsurf, taumax, eterm + real*8 rsfv(L_NSPECTV) ! Spectral dependency added by MT2015. + real*8 FZEROV(L_NSPECTV) + + real*8 DIFFV, DIFFVT + real*8 taugsurf(L_NSPECTV,L_NGAUSS-1), fzero + +C======================================================================C + + TAUMAX = L_TAUMAX + +C ZERO THE NET FLUXES + + NFLUXTOPV = 0.0 + FLUXTOPVDN = 0.0 + + DO NW=1,L_NSPECTV + NFLUXOUTV_nu(NW)=0.0 + NFLUXGNDV_nu(NW)=0.0 + END DO + + DO L=1,L_NLAYRAD + FMNETV(L) = 0.0 + FLUXUPV(L) = 0.0 + FLUXDNV(L) = 0.0 + END DO + + DIFFVT = 0.0 + +C WE NOW ENTER A MAJOR LOOP OVER SPECTRAL INTERVALS IN THE VISIBLE +C TO CALCULATE THE NET FLUX IN EACH SPECTRAL INTERVAL + + DO 500 NW=1,L_NSPECTV + + F0PI = STEL(NW) + + FZERO = FZEROV(NW) + IF(FZERO.ge.0.99) goto 40 + DO NG=1,L_NGAUSS-1 + + if(TAUGSURF(NW,NG) .lt. TLIMIT) then + + fzero = fzero + (1.0-FZEROV(NW))*GWEIGHT(NG) + + goto 30 + end if + +C SET UP THE UPPER AND LOWER BOUNDARY CONDITIONS ON THE VISIBLE + + BTOP = 0.0 + !BSURF = 0./0. ! why was this here? + BSURF = 0. +C LOOP OVER THE NTERMS BEGINNING HERE + + +! FACTOR = 1.0D0 - WDEL(1)*CDEL(1)**2 +! TAU(1) = TDEL(1)*FACTOR + + + ETERM = MIN(TAUV(L_NLEVRAD,NW,NG),TAUMAX) + BSURF = RSFV(NW)*UBAR0*STEL(NW)*EXP(-ETERM/UBAR0) + +C WE CAN NOW SOLVE FOR THE COEFFICIENTS OF THE TWO STREAM +C CALL A SUBROUTINE THAT SOLVES FOR THE FLUX TERMS +C WITHIN EACH INTERVAL AT THE MIDPOINT WAVENUMBER +C +C FUW AND FDW ARE WORKING FLUX ARRAYS THAT WILL BE USED TO +C RETURN FLUXES FOR A GIVEN NT + + + CALL rad_correlatedk_fluxes_solver_stellar(DTAUV(1,NW,NG), + * TAUV(1,NW,NG),TAUCUMV(1,NW,NG), + * WBARV(1,NW,NG),COSBV(1,NW,NG),UBAR0,F0PI,RSFV(NW), + * BTOP,BSURF,FMUPV,FMDV,DIFFV,FLUXUP,FLUXDN) + +C NOW CALCULATE THE CUMULATIVE VISIBLE NET FLUX + + NFLUXTOPV = NFLUXTOPV+(FLUXUP-FLUXDN)*GWEIGHT(NG)* + * (1.0-FZEROV(NW)) + FLUXTOPVDN = FLUXTOPVDN+FLUXDN*GWEIGHT(NG)* + * (1.0-FZEROV(NW)) + DO L=1,L_NLAYRAD + FMNETV(L)=FMNETV(L)+( FMUPV(L)-FMDV(L) )* + * GWEIGHT(NG)*(1.0-FZEROV(NW)) + FLUXUPV(L) = FLUXUPV(L) + FMUPV(L)*GWEIGHT(NG)* + * (1.0-FZEROV(NW)) + FLUXDNV(L) = FLUXDNV(L) + FMDV(L)*GWEIGHT(NG)* + * (1.0-FZEROV(NW)) + END DO + +c band-resolved flux leaving TOA (RDW) + NFLUXOUTV_nu(NW) = NFLUXOUTV_nu(NW) + * +FLUXUP*GWEIGHT(NG)*(1.0-FZEROV(NW)) + +c band-resolved flux at ground (RDW) + NFLUXGNDV_nu(NW) = NFLUXGNDV_nu(NW) + * +FMDV(L_NLAYRAD)*GWEIGHT(NG)*(1.0-FZEROV(NW)) + + +C THE DIFFUSE COMPONENT OF THE DOWNWARD STELLAR FLUX + + DIFFVT = DIFFVT + DIFFV*GWEIGHT(NG)*(1.0-FZEROV(NW)) + + 30 CONTINUE + + END DO ! the Gauss loop + + 40 continue +C Special 17th Gauss point + + NG = L_NGAUSS + +C SET UP THE UPPER AND LOWER BOUNDARY CONDITIONS ON THE VISIBLE + + BTOP = 0.0 + +C LOOP OVER THE NTERMS BEGINNING HERE + + ETERM = MIN(TAUV(L_NLEVRAD,NW,NG),TAUMAX) + BSURF = RSFV(NW)*UBAR0*STEL(NW)*EXP(-ETERM/UBAR0) + + +C WE CAN NOW SOLVE FOR THE COEFFICIENTS OF THE TWO STREAM +C CALL A SUBROUTINE THAT SOLVES FOR THE FLUX TERMS +C WITHIN EACH INTERVAL AT THE MIDPOINT WAVENUMBER +C +C FUW AND FDW ARE WORKING FLUX ARRAYS THAT WILL BE USED TO +C RETURN FLUXES FOR A GIVEN NT + + CALL rad_correlatedk_fluxes_solver_stellar(DTAUV(1,NW,NG), + * TAUV(1,NW,NG),TAUCUMV(1,NW,NG), + * WBARV(1,NW,NG),COSBV(1,NW,NG),UBAR0,F0PI,RSFV(NW), + * BTOP,BSURF,FMUPV,FMDV,DIFFV,FLUXUP,FLUXDN) + + +C NOW CALCULATE THE CUMULATIVE VISIBLE NET FLUX + + NFLUXTOPV = NFLUXTOPV+(FLUXUP-FLUXDN)*FZERO + FLUXTOPVDN = FLUXTOPVDN+FLUXDN*FZERO + DO L=1,L_NLAYRAD + FMNETV(L)=FMNETV(L)+( FMUPV(L)-FMDV(L) )*FZERO + FLUXUPV(L) = FLUXUPV(L) + FMUPV(L)*FZERO + FLUXDNV(L) = FLUXDNV(L) + FMDV(L)*FZERO + END DO + +c band-resolved flux leaving TOA (RDW) + NFLUXOUTV_nu(NW) = NFLUXOUTV_nu(NW) + * +FLUXUP*FZERO + +c band-resolved flux at ground (RDW) + NFLUXGNDV_nu(NW) = NFLUXGNDV_nu(NW)+FMDV(L_NLAYRAD)*FZERO + + +C THE DIFFUSE COMPONENT OF THE DOWNWARD STELLAR FLUX + + DIFFVT = DIFFVT + DIFFV*FZERO + + + 500 CONTINUE + + +C *** END OF MAJOR SPECTRAL INTERVAL LOOP IN THE VISIBLE***** + + + END SUBROUTINE rad_correlatedk_fluxes_stellar + + end module rad_correlatedk_fluxes_stellar_mod + Index: trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_fluxes_thermal.F =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_fluxes_thermal.F (revision 4077) +++ trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_fluxes_thermal.F (revision 4077) @@ -0,0 +1,208 @@ + module rad_correlatedk_fluxes_thermal_mod + + implicit none + + contains + + SUBROUTINE rad_correlatedk_fluxes_thermal(PLEV,TLEV, + * DTAUI,TAUCUMI,UBARI,RSFI,WNOI,DWNI, + * COSBI,WBARI,NFLUXTOPI,NFLUXTOPI_nu, + * FMNETI,fluxupi,fluxdni,fluxupi_nu, + * FZEROI,TAUGSURF) + + use radinc_h, only: NTfac, NTstart, L_LEVELS, L_NSPECTI, L_NGAUSS + use radinc_h, only: L_NLAYRAD, L_NLEVRAD + use radcommon_h, only: planckir, tlimit,sigma, gweight + use comcstfi_mod, only: pi + use rad_correlatedk_fluxes_solver_thermal_mod, + * only: rad_correlatedk_fluxes_solver_thermal + + implicit none + + integer NLEVRAD, L, NW, NG, NTS, NTT + + real*8 TLEV(L_LEVELS), PLEV(L_LEVELS) + real*8 TAUCUMI(L_LEVELS,L_NSPECTI,L_NGAUSS) + real*8 FMNETI(L_NLAYRAD) + real*8 WNOI(L_NSPECTI), DWNI(L_NSPECTI) + real*8 DTAUI(L_NLAYRAD,L_NSPECTI,L_NGAUSS) + real*8 FMUPI(L_NLEVRAD), FMDI(L_NLEVRAD) + real*8 COSBI(L_NLAYRAD,L_NSPECTI,L_NGAUSS) + real*8 WBARI(L_NLAYRAD,L_NSPECTI,L_NGAUSS) + real*8 NFLUXTOPI + real*8 NFLUXTOPI_nu(L_NSPECTI) + real*8 fluxupi_nu(L_NLAYRAD,L_NSPECTI) + real*8 FTOPUP + + real*8 UBARI, RSFI, TSURF, BSURF, TTOP, BTOP, TAUTOP + real*8 PLANCK, PLTOP + real*8 fluxupi(L_NLAYRAD), fluxdni(L_NLAYRAD) + real*8 FZEROI(L_NSPECTI) + real*8 taugsurf(L_NSPECTI,L_NGAUSS-1), fzero + + real*8 fup_tmp(L_NSPECTI),fdn_tmp(L_NSPECTI) + real*8 PLANCKSUM,PLANCKREF + +! AB : variables for interpolation + REAL*8 C1 + REAL*8 C2 + REAL*8 P1 + +!======================================================================C + + NLEVRAD = L_NLEVRAD + +! ZERO THE NET FLUXES + NFLUXTOPI = 0.0D0 + + DO NW=1,L_NSPECTI + NFLUXTOPI_nu(NW) = 0.0D0 + DO L=1,L_NLAYRAD + FLUXUPI_nu(L,NW) = 0.0D0 + fup_tmp(nw)=0.0D0 + fdn_tmp(nw)=0.0D0 + END DO + END DO + + DO L=1,L_NLAYRAD + FMNETI(L) = 0.0D0 + FLUXUPI(L) = 0.0D0 + FLUXDNI(L) = 0.0D0 + END DO + +! WE NOW ENTER A MAJOR LOOP OVER SPECTRAL INTERVALS IN THE INFRARED +! TO CALCULATE THE NET FLUX IN EACH SPECTRAL INTERVAL + + TTOP = TLEV(2) ! JL12 why not (1) ??? + TSURF = TLEV(L_LEVELS) + + NTS = int(TSURF*NTfac)-NTstart+1 + NTT = int(TTOP *NTfac)-NTstart+1 + +!JL12 corrects the surface planck function so that its integral is equal to sigma Tsurf^4 +!JL12 this ensure that no flux is lost due to: +!JL12 -truncation of the planck function at high/low wavenumber +!JL12 -numerical error during first spectral integration +!JL12 -discrepancy between Tsurf and NTS/NTfac + PLANCKSUM = 0.d0 + PLANCKREF = TSURF * TSURF + PLANCKREF = sigma * PLANCKREF * PLANCKREF + + DO NW=1,L_NSPECTI +! AB : PLANCKIR(NW,NTS) is replaced by P1, the linear interpolation result for a temperature TSURF + C1 = TSURF * NTfac - int(TSURF * NTfac) + P1 = (1.0D0 - C1) * PLANCKIR(NW,NTS) + C1 * PLANCKIR(NW,NTS+1) + PLANCKSUM = PLANCKSUM + P1 * DWNI(NW) + ENDDO + + PLANCKSUM = PLANCKREF / (PLANCKSUM * Pi) +!JL12 + + DO 501 NW=1,L_NSPECTI +! SURFACE EMISSIONS - INDEPENDENT OF GAUSS POINTS +! AB : PLANCKIR(NW,NTS) is replaced by P1, the linear interpolation result for a temperature TSURF +! AB : idem for PLANCKIR(NW,NTT) and PLTOP + C1 = TSURF * NTfac - int(TSURF * NTfac) + C2 = TTOP * NTfac - int(TTOP * NTfac) + P1 = (1.0D0 - C1) * PLANCKIR(NW,NTS) + C1 * PLANCKIR(NW,NTS+1) + BSURF = (1. - RSFI) * P1 * PLANCKSUM + PLTOP = (1.0D0 - C2) * PLANCKIR(NW,NTT) + C2*PLANCKIR(NW,NTT+1) + +! If FZEROI(NW) = 1, then the k-coefficients are zero - skip to the +! special Gauss point at the end. + FZERO = FZEROI(NW) + + IF(FZERO.ge.0.99) goto 40 + + DO NG=1,L_NGAUSS-1 + + if(TAUGSURF(NW,NG).lt. TLIMIT) then + fzero = fzero + (1.0D0-FZEROI(NW))*GWEIGHT(NG) + goto 30 + end if + +! SET UP THE UPPER AND LOWER BOUNDARY CONDITIONS ON THE IR +! CALCULATE THE DOWNWELLING RADIATION AT THE TOP OF THE MODEL +! OR THE TOP LAYER WILL COOL TO SPACE UNPHYSICALLY + +! TAUTOP = DTAUI(1,NW,NG)*PLEV(2)/(PLEV(4)-PLEV(2)) + TAUTOP = TAUCUMI(2,NW,NG) + BTOP = (1.0D0-EXP(-TAUTOP/UBARI))*PLTOP + +! WE CAN NOW SOLVE FOR THE COEFFICIENTS OF THE TWO STREAM +! CALL A SUBROUTINE THAT SOLVES FOR THE FLUX TERMS +! WITHIN EACH INTERVAL AT THE MIDPOINT WAVENUMBER + + CALL rad_correlatedk_fluxes_solver_thermal(NLEVRAD, + * TLEV,NW,DWNI(NW),DTAUI(1,NW,NG), + * TAUCUMI(1,NW,NG), + * WBARI(1,NW,NG),COSBI(1,NW,NG),UBARI,RSFI,BTOP, + * BSURF,FTOPUP,FMUPI,FMDI) + +! NOW CALCULATE THE CUMULATIVE IR NET FLUX + NFLUXTOPI = NFLUXTOPI+FTOPUP*DWNI(NW)*GWEIGHT(NG) + * * (1.0D0-FZEROI(NW)) + +! and same thing by spectral band... (RDW) + NFLUXTOPI_nu(NW) = NFLUXTOPI_nu(NW) + FTOPUP * DWNI(NW) + * * GWEIGHT(NG) * (1.0D0-FZEROI(NW)) + + DO L=1,L_NLEVRAD-1 +! CORRECT FOR THE WAVENUMBER INTERVALS + FMNETI(L) = FMNETI(L) + (FMUPI(L)-FMDI(L)) * DWNI(NW) + * * GWEIGHT(NG)*(1.0D0-FZEROI(NW)) + FLUXUPI(L) = FLUXUPI(L) + FMUPI(L)*DWNI(NW)*GWEIGHT(NG) + * * (1.0D0-FZEROI(NW)) + FLUXDNI(L) = FLUXDNI(L) + FMDI(L)*DWNI(NW)*GWEIGHT(NG) + * * (1.0D0-FZEROI(NW)) +! and same thing by spectral band... (RW) + FLUXUPI_nu(L,NW) = FLUXUPI_nu(L,NW) + FMUPI(L)*DWNI(NW) + * * GWEIGHT(NG) * (1.0D0 - FZEROI(NW)) + END DO + + 30 CONTINUE + + END DO !End NGAUSS LOOP + + 40 CONTINUE + +! SPECIAL 17th Gauss point + NG = L_NGAUSS + +! TAUTOP = DTAUI(1,NW,NG)*PLEV(2)/(PLEV(4)-PLEV(2)) + TAUTOP = TAUCUMI(2,NW,NG) + BTOP = (1.0D0-EXP(-TAUTOP/UBARI))*PLTOP + +! WE CAN NOW SOLVE FOR THE COEFFICIENTS OF THE TWO STREAM +! CALL A SUBROUTINE THAT SOLVES FOR THE FLUX TERMS +! WITHIN EACH INTERVAL AT THE MIDPOINT WAVENUMBER + + CALL rad_correlatedk_fluxes_solver_thermal(NLEVRAD, + * TLEV,NW,DWNI(NW),DTAUI(1,NW,NG), + * TAUCUMI(1,NW,NG), + * WBARI(1,NW,NG),COSBI(1,NW,NG),UBARI,RSFI,BTOP, + * BSURF,FTOPUP,FMUPI,FMDI) + +! NOW CALCULATE THE CUMULATIVE IR NET FLUX + NFLUXTOPI = NFLUXTOPI+FTOPUP*DWNI(NW)*FZERO + +! and same thing by spectral band... (RW) + NFLUXTOPI_nu(NW) = NFLUXTOPI_nu(NW) + * +FTOPUP*DWNI(NW)*FZERO + + DO L=1,L_NLEVRAD-1 +! CORRECT FOR THE WAVENUMBER INTERVALS + FMNETI(L) = FMNETI(L)+(FMUPI(L)-FMDI(L))*DWNI(NW)*FZERO + FLUXUPI(L) = FLUXUPI(L) + FMUPI(L)*DWNI(NW)*FZERO + FLUXDNI(L) = FLUXDNI(L) + FMDI(L)*DWNI(NW)*FZERO +! and same thing by spectral band... (RW) + FLUXUPI_nu(L,NW) = FLUXUPI_nu(L,NW) + * + FMUPI(L) * DWNI(NW) * FZERO + END DO + + 501 CONTINUE !End Spectral Interval LOOP +! *** END OF MAJOR SPECTRAL INTERVAL LOOP IN THE INFRARED**** + + END SUBROUTINE rad_correlatedk_fluxes_thermal + + end module rad_correlatedk_fluxes_thermal_mod Index: trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_ini_aerosol.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_ini_aerosol.F90 (revision 4077) +++ trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_ini_aerosol.F90 (revision 4077) @@ -0,0 +1,626 @@ +module rad_correlatedk_ini_aerosol_mod + +implicit none + +contains + +subroutine rad_correlatedk_ini_aerosol + + ! inputs + use radinc_h, only: L_NSPECTI,L_NSPECTV,nsizemax,naerkind + use radcommon_h, only: blamv,blami,lamrefir,lamrefvis + use datafile_mod, only: datadir, aerdir + + ! outputs + use radcommon_h, only: QVISsQREF,omegavis,gvis,QIRsQREF,omegair,gir + use radcommon_h, only: radiustab,nsize,tstellar + use radcommon_h, only: qrefvis,qrefir,omegarefir !,omegarefvis + use aerosol_global_variables , only: noaero,iaero_co2,iaero_h2o,iaero_dust,iaero_h2so4 + use aerosol_global_variables , only: iaero_back2lay,iaero_nh3,iaero_nlay,iaero_aurora + use aerosol_global_variables , only: iaero_venus1,iaero_venus2,iaero_venus2p + use aerosol_global_variables , only: iaero_venus3,iaero_venusUV + use aerosol_global_variables , only: iaero_generic,i_rgcs_ice + use callkeys_mod, only: tplanet, optprop_back2lay_vis, optprop_back2lay_ir, & + optprop_aeronlay_vis, optprop_aeronlay_ir, & + aeronlay_lamref, nlayaero,aerogeneric + use tracer_h, only: noms + + use mod_phys_lmdz_para, only : is_master, bcast + + implicit none + +!================================================================== +! Purpose +! ------- +! Initialize all radiative aerosol properties +! +! Notes +! ----- +! Reads the optical properties -> Mean -> Variable assignment +! (ASCII files) (see radcommon_h.F90) +! wvl(nwvl) longsun +! ep(nwvl) epav QVISsQREF(L_NSPECTV) +! omeg(nwvl) omegav omegavis(L_NSPECTV) +! gfactor(nwvl) gav gvis(L_NSPECTV) +! +! Authors +! ------- +! Richard Fournier (1996) Francois Forget (1996) +! Frederic Hourdin +! Jean-jacques morcrette *ECMWF* +! MODIF Francois Forget (2000) +! MODIF Franck Montmessin (add water ice) +! MODIF J.-B. Madeleine 2008W27 +! - Optical properties read in ASCII files +! - Add varying radius of the particules +! - Add water ice clouds +! MODIF R. Wordsworth (2009) +! - generalisation to arbitrary spectral bands +! +!================================================================== + +! Optical properties (read in external ASCII files) + INTEGER :: nwvl ! Number of wavelengths in + ! the domain (VIS or IR), read by master + +! REAL :: solsir ! visible to infrared ratio +! ! (tau_0.67um/tau_9um) + + REAL, DIMENSION(:),& + ALLOCATABLE :: wvl ! Wavelength axis, read by master + REAL, DIMENSION(:),& + ALLOCATABLE :: radiusdyn ! Particle size axis, read by master + + REAL, DIMENSION(:,:),& + ALLOCATABLE :: ep,& ! Extinction coefficient Qext, read by master + omeg,& ! Single Scattering Albedo, read by master + gfactor ! Assymetry Factor, read by master + +! Local variables: + + INTEGER :: iaer ! Aerosol index + INTEGER :: idomain ! Domain index (1=VIS,2=IR) + INTEGER :: ilw ! longwave index + INTEGER :: isw ! shortwave index + INTEGER :: isize ! Particle size index + INTEGER :: jfile ! ASCII file scan index + INTEGER :: file_unit = 60 + LOGICAL :: file_ok, endwhile + CHARACTER(LEN=132) :: scanline ! ASCII file scanning line + +! I/O of "aerosol_optical_properties_averaging" (subroutine that spectrally averages +! the single scattering parameters) + + REAL lamref ! reference wavelengths + REAL epref ! reference extinction ep + + REAL epavVI(L_NSPECTV) ! Average ep (= /Qext(lamrefvis) if epref=1) + REAL omegavVI(L_NSPECTV) ! Average single scattering albedo + REAL gavVI(L_NSPECTV) ! Average assymetry parameter + + REAL epavIR(L_NSPECTI) ! Average ep (= /Qext(lamrefir) if epref=1) + REAL omegavIR(L_NSPECTI) ! Average single scattering albedo + REAL gavIR(L_NSPECTI) ! Average assymetry parameter + + logical forgetit ! use francois' data? + integer iwvl, ia + +! Local saved variables: + + CHARACTER(LEN=50),ALLOCATABLE :: file_id(:,:) + +!---- Please indicate the names of the optical property files below +! Please also choose the reference wavelengths of each aerosol + +!--------- README TO UNDERSTAND WHAT FOLLOWS (JVO 20) ------- +! The lamref variables comes from the Martian model +! where the visible one is the one used for computing +! and the IR one is used to output scaled opacity to +! match instrumental data ... This is done (at least +! for now) in the generic, so lamrefir is dummy*! + +! The important one is the VISIBLE one as it will be used +! to rescale the values in callcork.F90 assuming 'aerosol' is +! at this visible reference wavelenght. + +! *Actually if you change lamrefir here there is a +! slight sensitvity in the outputs because of some +! machine precision differences that amplifys and lead +! up to 10-6 differences in the radiative balance... +! This could be good to clean the code but would require +! a lot of modifs and to take care ! + +!-------------------------------------------------------------- + ! allocate file_id, as naerkind is a variable + allocate(file_id(naerkind,2)) + + if (noaero) then + print*, 'naerkind= 0' + endif + do iaer=1,naerkind + if (iaer.eq.iaero_co2) then + forgetit=.false. + if (.not.noaero) then + print*, 'naerkind= co2', iaer + end if +! visible + if(forgetit)then + file_id(iaer,1) = 'optprop_co2_vis_ff.dat' ! Francois' values + else + file_id(iaer,1) = 'optprop_co2ice_vis_n50.dat' + endif + lamrefvis(iaer)=1.5E-6 ! 1.5um OMEGA/MEx ??? + +! infrared + if(forgetit)then + file_id(iaer,2) = 'optprop_co2_ir_ff.dat' ! Francois' values + else + file_id(iaer,2) = 'optprop_co2ice_ir_n50.dat' + endif + lamrefir(iaer)=12.1E-6 ! Dummy in generic phys. (JVO 20) + endif ! CO2 aerosols +! NOTE: these lamref's are currently for dust, not CO2 ice. +! JB thinks this shouldn't matter too much, but it needs to be +! fixed / decided for the final version. + + if (iaer.eq.iaero_h2o) then + print*, 'naerkind= h2o', iaer + +! visible + file_id(iaer,1) = 'optprop_icevis_n50.dat' + lamrefvis(iaer)=1.5E-6 ! 1.5um OMEGA/MEx +! infrared + file_id(iaer,2) = 'optprop_iceir_n50.dat' + lamrefir(iaer)=12.1E-6 ! Dummy in generic phys. (JVO 20) + endif + + if (iaer.eq.iaero_dust) then + print*, 'naerkind= dust', iaer + +! visible + file_id(iaer,1) = 'optprop_dustvis_n50.dat' + !lamrefvis(iaer)=1.5E-6 ! 1.5um OMEGA/MEx + lamrefvis(iaer)=0.67e-6 +! infrared + file_id(iaer,2) = 'optprop_dustir_n50.dat' + lamrefir(iaer)=9.3E-6 ! Dummy in generic phys. (JVO 20) + endif + + if (iaer.eq.iaero_h2so4) then + print*, 'naerkind= h2so4', iaer + +! visible + file_id(iaer,1) = 'optprop_h2so4vis_n20.dat' + lamrefvis(iaer)=1.5E-6 ! no idea, must find +! infrared + file_id(iaer,2) = 'optprop_h2so4ir_n20.dat' + lamrefir(iaer)=9.3E-6 ! ! Dummy in generic phys. (JVO 20) +! added by LK + endif + + if (iaer.eq.iaero_back2lay) then + print*, 'naerkind= back2lay', iaer + +! visible + file_id(iaer,1) = TRIM(optprop_back2lay_vis) + lamrefvis(iaer)=0.8E-6 ! This is the important one. +! infrared + file_id(iaer,2) = TRIM(optprop_back2lay_ir) + lamrefir(iaer)=6.E-6 ! This is dummy. +! added by SG + endif + + if (iaer.eq.iaero_nh3) then + print*, 'naerkind= nh3', iaer + +! visible + file_id(iaer,1) = 'optprop_nh3ice_vis.dat' + lamrefvis(iaer)=0.756E-6 ! +! infrared + file_id(iaer,2) = 'optprop_nh3ice_ir.dat' + lamrefir(iaer)=6.E-6 ! dummy +! added by SG + endif + + do ia=1,nlayaero + if (iaer.eq.iaero_nlay(ia)) then + print*, 'naerkind= nlay', iaer + +! visible + file_id(iaer,1) = TRIM(optprop_aeronlay_vis(ia)) + lamrefvis(iaer)=aeronlay_lamref(ia) +! infrared + file_id(iaer,2) = TRIM(optprop_aeronlay_ir(ia)) + lamrefir(iaer)=6.E-6 ! Dummy value + endif + enddo +! added by JVO + + if (iaer.eq.iaero_aurora) then + print*, 'naerkind= aurora', iaer + +! visible + file_id(iaer,1) = 'optprop_aurora_vis.dat' + lamrefvis(iaer)=0.3E-6 ! +! infrared + file_id(iaer,2) = 'optprop_aurora_ir.dat' + lamrefir(iaer)=6.E-6 ! dummy +! added by SG + endif + +! VENUS CLOUDS + + if (iaer.eq.iaero_venus1) then + print*, 'naerkind= venus1', iaer + +! visible + file_id(iaer,1) = 'optprop_h2so4vis_n50.dat' + lamrefvis(iaer)=1.5E-6 ! no idea, must find +! infrared + file_id(iaer,2) = 'optprop_h2so4ir_n50.dat' + lamrefir(iaer)=9.3E-6 ! no idea, must find +! added by SL + endif + + if (iaer.eq.iaero_venus2) then + print*, 'naerkind= venus2', iaer + +! visible + file_id(iaer,1) = 'optprop_h2so4vis_n50.dat' + lamrefvis(iaer)=1.5E-6 ! no idea, must find +! infrared + file_id(iaer,2) = 'optprop_h2so4ir_n50.dat' + lamrefir(iaer)=9.3E-6 ! no idea, must find +! added by SL + endif + + if (iaer.eq.iaero_venus2p) then + print*, 'naerkind= venus2p', iaer + +! visible + file_id(iaer,1) = 'optprop_h2so4vis_n50.dat' + lamrefvis(iaer)=1.5E-6 ! no idea, must find +! infrared + file_id(iaer,2) = 'optprop_h2so4ir_n50.dat' + lamrefir(iaer)=9.3E-6 ! no idea, must find +! added by SL + endif + + if (iaer.eq.iaero_venus3) then + print*, 'naerkind= venus3', iaer + +! visible + file_id(iaer,1) = 'optprop_h2so4vis_n50.dat' + lamrefvis(iaer)=1.5E-6 ! no idea, must find +! infrared + file_id(iaer,2) = 'optprop_h2so4ir_n50.dat' + lamrefir(iaer)=9.3E-6 ! no idea, must find +! added by SL + endif + + if (iaer.eq.iaero_venusUV) then + print*, 'naerkind= venusUV', iaer + +! visible + file_id(iaer,1) = 'optprop_venusUVvis.dat' + lamrefvis(iaer)=3.5E-7 ! Haus et al. 2015 +! infrared + file_id(iaer,2) = 'optprop_venusUVir.dat' + lamrefir(iaer)=9.3E-6 ! not used anyway +! added by SL + endif + +! END VENUS CLOUDS + +! the following was added by LT + do ia=1,aerogeneric ! Read Radiative Generic Condensable Species data + if (iaer .eq. iaero_generic(ia)) then + if (index(noms(i_rgcs_ice(ia)),'Fe') .ne. 0) then + print*,"Reading Fe file" + file_id(iaer,1)='optprop_Fe_IR-VIS_n30.dat' + file_id(iaer,2)='optprop_Fe_IR-VIS_n30.dat' + lamrefvis(iaer) = 1.0E-6 !random pick + lamrefir(iaer) = 1.0E-6 !dummy but random pick + else if (index(noms(i_rgcs_ice(ia)),'Mn') .ne. 0) then + print*,"Reading MnS file" + file_id(iaer,1)='optprop_MnS_extended_IR-VIS_n35.dat' + file_id(iaer,2)='optprop_MnS_extended_IR-VIS_n35.dat' + lamrefvis(iaer) = 1.0E-6 !random pick + lamrefir(iaer) = 1.0E-6 !dummy but random pick + else if (index(noms(i_rgcs_ice(ia)),'Mg') .ne. 0) then + print*,"Reading Mg2SiO4 file" + file_id(iaer,1)='optprop_Mg2SiO4_amorph_extended_IR-VIS_n35.dat' + file_id(iaer,2)='optprop_Mg2SiO4_amorph_extended_IR-VIS_n35.dat' + lamrefvis(iaer) = 1.0E-6 !random pick + lamrefir(iaer) = 1.0E-6 !dummy but random pick + else if (index(noms(i_rgcs_ice(ia)),'Cr') .ne. 0) then + print*,"Reading Cr file" + file_id(iaer,1)='optprop_Cr_IR-VIS_n30.dat' + file_id(iaer,2)='optprop_Cr_IR-VIS_n30.dat' + lamrefvis(iaer) = 1.0E-6 !random pick + lamrefir(iaer) = 1.0E-6 !dummy but random pick + else +! If you want to add another specie, copy,paste & adapt the elseif block up here to your new specie (LT 2022) + call abort_physic("rad_correlatedk_ini_aerosol", "Unknown specie in radiative generic condensable species",1) + endif + endif + enddo ! ia=1,aerogeneric + enddo ! of do iaer=1,naerkind + +!------------------------------------------------------------------ + +! Initializations: + + radiustab(:,:,:) = 0.0 + gvis(:,:,:) = 0.0 + omegavis(:,:,:) = 0.0 + QVISsQREF(:,:,:) = 0.0 + gir(:,:,:) = 0.0 + omegair(:,:,:) = 0.0 + QIRsQREF(:,:,:) = 0.0 + + DO iaer = 1, naerkind ! Loop on aerosol kind + DO idomain = 1, 2 ! Loop on radiation domain (VIS or IR) +!================================================================== +! 1. READ OPTICAL PROPERTIES +!================================================================== + +! 1.1 Open the ASCII file + +!!!!$OMP MASTER + if (is_master) then + + INQUIRE(FILE=TRIM(datadir)//'/'//TRIM(aerdir)//& + '/'//TRIM(file_id(iaer,idomain)),& + EXIST=file_ok) + IF (file_ok) THEN + OPEN(UNIT=file_unit,& + FILE=TRIM(datadir)//'/'//TRIM(aerdir)//& + '/'//TRIM(file_id(iaer,idomain)),& + FORM='formatted') + ELSE + ! In ye old days these files were stored in datadir; + ! let's be retro-compatible + INQUIRE(FILE=TRIM(datadir)//& + '/'//TRIM(file_id(iaer,idomain)),& + EXIST=file_ok) + IF (file_ok) THEN + OPEN(UNIT=file_unit,& + FILE=TRIM(datadir)//& + '/'//TRIM(file_id(iaer,idomain)),& + FORM='formatted') + ENDIF + ENDIF + IF(.NOT.file_ok) THEN + write(*,*)'rad_correlatedk_ini_aerosol: Problem opening ',& + TRIM(file_id(iaer,idomain)) + write(*,*)'It should be in: ',TRIM(datadir)//'/'//TRIM(aerdir) + write(*,*)'1) You can set this directory address ',& + 'in callphys.def with:' + write(*,*)' datadir = /absolute/path/to/datagcm' + write(*,*)'2) If ',& + TRIM(file_id(iaer,idomain)),& + ' is a LMD reference datafile, it' + write(*,*)' can be obtained online at:' + write(*,*)' http://www.lmd.jussieu.fr/',& + '~lmdz/planets/generic/datagcm/' + CALL abort_physic("rad_correlatedk_ini_aerosol", "Unable to read file",1) + ENDIF + +! 1.2 Allocate the optical property table + + jfile = 1 + endwhile = .false. + DO WHILE (.NOT.endwhile) + READ(file_unit,*) scanline + IF ((scanline(1:1) .ne. '#').and.& + (scanline(1:1) .ne. ' ')) THEN + BACKSPACE(file_unit) + reading1_seq: SELECT CASE (jfile) ! ==================== + CASE(1) reading1_seq ! nwvl ---------------------------- + read(file_unit,*) nwvl + jfile = jfile+1 + CASE(2) reading1_seq ! nsize --------------------------- + read(file_unit,*) nsize(iaer,idomain) + endwhile = .true. + CASE DEFAULT reading1_seq ! ---------------------------- + CALL abort_physic("rad_correlatedk_ini_aerosol","Error while loading optical properties",1) + END SELECT reading1_seq ! ============================== + ENDIF + ENDDO + + endif ! of if (is_master) + + ! broadcast nwvl and nsize to all cores + call bcast(nwvl) + call bcast(nsize) + + ALLOCATE(wvl(nwvl)) ! wvl + ALLOCATE(radiusdyn(nsize(iaer,idomain))) ! radiusdyn + ALLOCATE(ep(nwvl,nsize(iaer,idomain))) ! ep + ALLOCATE(omeg(nwvl,nsize(iaer,idomain))) ! omeg + ALLOCATE(gfactor(nwvl,nsize(iaer,idomain))) ! g + + +! 1.3 Read the data + + if (is_master) then + jfile = 1 + endwhile = .false. + DO WHILE (.NOT.endwhile) + READ(file_unit,*) scanline + IF ((scanline(1:1) .ne. '#').and.& + (scanline(1:1) .ne. ' ')) THEN + BACKSPACE(file_unit) + reading2_seq: SELECT CASE (jfile) ! ==================== + CASE(1) reading2_seq ! wvl ----------------------------- + read(file_unit,*) wvl + jfile = jfile+1 + CASE(2) reading2_seq ! radiusdyn ----------------------- + read(file_unit,*) radiusdyn + jfile = jfile+1 + CASE(3) reading2_seq ! ep ------------------------------ + isize = 1 + DO WHILE (isize .le. nsize(iaer,idomain)) + READ(file_unit,*) scanline + IF ((scanline(1:1) .ne. '#').and.& + (scanline(1:1) .ne. ' ')) THEN + BACKSPACE(file_unit) + read(file_unit,*) ep(:,isize) + isize = isize + 1 + ENDIF + ENDDO + + jfile = jfile+1 + CASE(4) reading2_seq ! omeg ---------------------------- + isize = 1 + DO WHILE (isize .le. nsize(iaer,idomain)) + READ(file_unit,*) scanline + IF ((scanline(1:1) .ne. '#').and.& + (scanline(1:1) .ne. ' ')) THEN + BACKSPACE(file_unit) + read(file_unit,*) omeg(:,isize) + isize = isize + 1 + ENDIF + ENDDO + + jfile = jfile+1 + CASE(5) reading2_seq ! gfactor ------------------------- + isize = 1 + DO WHILE (isize .le. nsize(iaer,idomain)) + READ(file_unit,*) scanline + IF ((scanline(1:1) .ne. '#').and.& + (scanline(1:1) .ne. ' ')) THEN + BACKSPACE(file_unit) + read(file_unit,*) gfactor(:,isize) + isize = isize + 1 + ENDIF + ENDDO + + jfile = jfile+1 + IF ((idomain.NE.iaero_co2).OR.(iaer.NE.iaero_co2)) THEN + endwhile = .true. + ENDIF + CASE(6) reading2_seq + endwhile = .true. + CASE DEFAULT reading2_seq ! ---------------------------- + CALL abort_physic("rad_correlatedk_ini_aerosol","Error while loading optical properties",1) + END SELECT reading2_seq ! ============================== + ENDIF + ENDDO + +! 1.4 Close the file + + CLOSE(file_unit) + +! 1.5 If Francois' data, convert wvl to metres + if(iaer.eq.iaero_co2)then + if(forgetit)then + ! print*,'please sort out forgetit for naerkind>1' + do iwvl=1,nwvl + wvl(iwvl)=wvl(iwvl)*1.e-6 + enddo + endif + endif + + endif ! of if (is_master) + + ! broadcast arrays to all cores + call bcast(wvl) + call bcast(radiusdyn) + call bcast(ep) + call bcast(omeg) + call bcast(gfactor) + +!================================================================== +! 2. AVERAGED PROPERTIES AND VARIABLE ASSIGNMENTS +!================================================================== + domain: SELECT CASE (idomain) +!================================================================== + CASE(1) domain ! VISIBLE DOMAIN (idomain=1) +!================================================================== + + lamref=lamrefvis(iaer) + epref=1.E+0 + + DO isize=1,nsize(iaer,idomain) + +! Save the particle sizes + radiustab(iaer,idomain,isize)=radiusdyn(isize) + +! Averaged optical properties (GCM channels) + + CALL aerosol_optical_properties_averaging ( nwvl,& + wvl(:),ep(:,isize),omeg(:,isize),gfactor(:,isize),& + lamref,epref,tstellar,& + L_NSPECTV,blamv,epavVI,& + omegavVI,gavVI,QREFvis(iaer,isize),omegaREFir(iaer,isize)) + +! Variable assignments (declared in radcommon) + DO isw=1,L_NSPECTV + QVISsQREF(isw,iaer,isize)=epavVI(isw) + gvis(isw,iaer,isize)=gavVI(isw) + omegavis(isw,iaer,isize)=omegavVI(isw) + END DO + + ENDDO +!================================================================== + CASE(2) domain ! INFRARED DOMAIN (idomain=2) +!================================================================== + + DO isize=1,nsize(iaer,idomain) ! ---------------------------------- + + lamref=lamrefir(iaer) + epref=1.E+0 + +! Save the particle sizes + radiustab(iaer,idomain,isize)=radiusdyn(isize) + +! Averaged optical properties (GCM channels) + +! epav is /Qext(lamrefir) since epref=1 +! Note: aerosol_optical_properties_averaging also computes the extinction coefficient at +! the reference wavelength. This is called QREFvis or QREFir +! (not epref, which is a different parameter). +! Reference wavelengths SHOULD BE defined for each aerosol in +! radcommon_h.F90 + + CALL aerosol_optical_properties_averaging ( nwvl,& + wvl(:),ep(:,isize),omeg(:,isize),gfactor(:,isize),& + lamref,epref,tplanet,& + L_NSPECTI,blami,epavIR,& + omegavIR,gavIR,QREFir(iaer,isize),omegaREFir(iaer,isize)) + + +! Variable assignments (declared in radcommon) + DO ilw=1,L_NSPECTI + QIRsQREF(ilw,iaer,isize)=epavIR(ilw) + gir(ilw,iaer,isize)=gavIR(ilw) + omegair(ilw,iaer,isize)=omegavIR(ilw) + END DO + + + ENDDO ! isize (particle size) ------------------------------------- + + END SELECT domain + +!======================================================================== +! 3. Deallocate temporary variables that were read in the ASCII files +!======================================================================== + + DEALLOCATE(wvl) ! wvl + DEALLOCATE(radiusdyn) ! radiusdyn + DEALLOCATE(ep) ! ep + DEALLOCATE(omeg) ! omeg + DEALLOCATE(gfactor) ! g + + END DO ! Loop on iaer + END DO ! Loop on idomain +!======================================================================== + + ! cleanup + deallocate(file_id) + +end subroutine rad_correlatedk_ini_aerosol + +end module rad_correlatedk_ini_aerosol_mod Index: trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_init_stellar.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_init_stellar.F90 (revision 4077) +++ trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_init_stellar.F90 (revision 4077) @@ -0,0 +1,144 @@ + module rad_correlatedk_init_stellar_mod + + implicit none + + contains + + subroutine rad_correlatedk_init_stellar + +!================================================================== +! +! Purpose +! ------- +! Set up spectral intervals and stellar spectrum in the shortwave. +! +! Authors +! ------- +! Adapted from rad_correlatedk_init_stellar in the NASA Ames radiative code by +! Robin Wordsworth (2009). +! +! Called by +! --------- +! rad_correlatedk.F +! +! Calls +! ----- +! rad_correlatedk_stellar_spectrum .F +! +!================================================================== + + use radinc_h, only: L_NSPECTV, corrkdir, banddir + use radcommon_h, only: BWNV,BLAMV,WNOV,DWNV,WAVEV, & + STELLARF + use datafile_mod, only: datadir + use callkeys_mod, only: Fat1AU + use rad_correlatedk_stellar_spectrum_mod, only: rad_correlatedk_stellar_spectrum + + implicit none + + logical file_ok + + integer N, M, file_entries + + character(len=30) :: temp1 + character(len=200) :: file_id + character(len=200) :: file_path + + real*8 :: lastband(2) + + real*8 STELLAR(L_NSPECTV) + real*8 sum, dummy + + !! used to count lines + integer :: nb + integer :: ierr + +!======================================================================= +! Set up spectral bands - wavenumber [cm^(-1)]. Go from smaller to +! larger wavenumbers, the same as in the IR. + + write(temp1,'(i2.2)') L_NSPECTV + file_id='/corrk_data/'//trim(adjustl(banddir))//'/narrowbands_VI.in' + file_path=TRIM(datadir)//TRIM(file_id) + + ! check that the file exists + inquire(FILE=file_path,EXIST=file_ok) + if(.not.file_ok) then + write(*,*)'The file ',TRIM(file_path) + write(*,*)'was not found by rad_correlatedk_init_stellar.F90, exiting.' + write(*,*)'Check that your path to datagcm:',trim(datadir) + write(*,*)' is correct. You can change it in callphys.def with:' + write(*,*)' datadir = /absolute/path/to/datagcm' + write(*,*)'Also check that the corrkdir you chose in callphys.def exists.' + call abort_physic("rad_correlatedk_init_stellar", "Unable to read file",1) + endif + +!$OMP MASTER + nb=0 + ierr=0 + ! check that the file contains the right number of bands + open(131,file=file_path,form='formatted') + read(131,*,iostat=ierr) file_entries + do while (ierr==0) + read(131,*,iostat=ierr) dummy + if (ierr==0) nb=nb+1 + enddo + close(131) + + write(*,*) 'rad_correlatedk_init_stellar: L_NSPECTV = ',L_NSPECTV, 'in the model ' + write(*,*) ' there are ',nb, 'entries in ',TRIM(file_path) + if(nb.ne.L_NSPECTV) then + write(*,*) 'MISMATCH !! I stop here' + call abort_physic("rad_correlatedk_init_stellar","The number of entries in narrowbands_VI.in does not match with L_NSPECTV",1) + endif + + ! load and display the data + open(111,file=file_path,form='formatted') + read(111,*) + do M=1,L_NSPECTV-1 + read(111,*) BWNV(M) + end do + read(111,*) lastband + close(111) + BWNV(L_NSPECTV) =lastband(1) + BWNV(L_NSPECTV+1)=lastband(2) +!$OMP END MASTER +!$OMP BARRIER + + print*,'rad_correlatedk_init_stellar: VI band limits:' + do M=1,L_NSPECTV+1 + print*,m,'-->',BWNV(M),' cm^-1' + end do + print*,' ' + +! Set up mean wavenumbers and wavenumber deltas. Units of +! wavenumbers is cm^(-1); units of wavelengths is microns. + + do M=1,L_NSPECTV + WNOV(M) = 0.5*(BWNV(M+1)+BWNV(M)) + DWNV(M) = BWNV(M+1)-BWNV(M) + WAVEV(M) = 1.0E+4/WNOV(M) + BLAMV(M) = 0.01/BWNV(M) + end do + BLAMV(M) = 0.01/BWNV(M) ! wavelength in METERS for aerosol stuff +! note M=L_NSPECTV+1 after loop due to Fortran bizarreness + +!======================================================================= +! Set up stellar spectrum + + write(*,*)'rad_correlatedk_init_stellar: Interpolating stellar spectrum from the hires data...' + call rad_correlatedk_stellar_spectrum (STELLAR) + +! Sum the stellar flux, and write out the result. + sum = 0.0 + do N=1,L_NSPECTV + STELLARF(N) = STELLAR(N) * Fat1AU + sum = sum+STELLARF(N) + end do + write(6,'("rad_correlatedk_init_stellar: Stellar flux at 1 AU = ",f9.2," W m-2")') sum + print*,' ' + + END subroutine rad_correlatedk_init_stellar + + end module rad_correlatedk_init_stellar_mod + Index: trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_init_thermal.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_init_thermal.F90 (revision 4077) +++ trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_init_thermal.F90 (revision 4077) @@ -0,0 +1,226 @@ + subroutine rad_correlatedk_init_thermal + +!================================================================== +! +! Purpose +! ------- +! Set up spectral intervals and Planck function in the longwave. +! +! Authors +! ------- +! Adapted from rad_correlatedk_init_thermal in the NASA Ames radiative code by +! Robin Wordsworth (2009). +! +! Called by +! --------- +! rad_correlatedk.F +! +! Calls +! ----- +! none +! +!================================================================== + + use radinc_h, only: L_NSPECTI,corrkdir,banddir,NTstart,NTstop,NTfac + use radcommon_h, only: BWNI,BLAMI,WNOI,DWNI,WAVEI,planckir,sigma + use datafile_mod, only: datadir + use comcstfi_mod, only: pi + + implicit none + + logical file_ok + integer nw, nt, m, mm, file_entries + real*8 a, b, ans, y, bpa, bma, T, dummy + + character(len=30) :: temp1 + character(len=200) :: file_id + character(len=200) :: file_path + +! C1 and C2 values from Goody and Yung (2nd edition) MKS units +! These values lead to a "sigma" (sigma*T^4) of 5.67032E-8 W m^-2 K^-4 + + real*8 :: c1 = 3.741832D-16 ! W m^-2 + real*8 :: c2 = 1.438786D-2 ! m K + + real*8 :: lastband(2), plancksum + + !! used to count lines + integer :: nb + integer :: ierr + + logical forceEC, planckcheck + + real*8 :: x(12) = [ -0.981560634246719D0, -0.904117256370475D0, & + -0.769902674194305D0, -0.587317954286617D0, & + -0.367831498998180D0, -0.125233408511469D0, & + 0.125233408511469D0, 0.367831498998180D0, & + 0.587317954286617D0, 0.769902674194305D0, & + 0.904117256370475D0, 0.981560634246719D0 ] + + real*8 :: w(12) = [ 0.047175336386512D0, 0.106939325995318D0, & + 0.160078328543346D0, 0.203167426723066D0, & + 0.233492536538355D0, 0.249147045813403D0, & + 0.249147045813403D0, 0.233492536538355D0, & + 0.203167426723066D0, 0.160078328543346D0, & + 0.106939325995318D0, 0.047175336386512D0 ] + mm=0 + + forceEC=.true. + planckcheck=.true. + +!======================================================================= +! Set up spectral bands - wavenumber [cm^(-1)]. Go from smaller to +! larger wavenumbers. + + write(temp1,'(i2.2)') L_NSPECTI + !file_id='/corrk_data/' // corrkdir(1:LEN_TRIM(corrkdir)) // '/narrowbands_IR.in' + file_id='/corrk_data/'//trim(adjustl(banddir))//'/narrowbands_IR.in' + file_path=TRIM(datadir)//TRIM(file_id) + + ! check that the file exists + inquire(FILE=file_path,EXIST=file_ok) + if(.not.file_ok) then + write(*,*)'The file ',TRIM(file_path) + write(*,*)'was not found by rad_correlatedk_init_thermal.F90, exiting.' + write(*,*)'Check that your path to datagcm:',trim(datadir) + write(*,*)' is correct. You can change it in callphys.def with:' + write(*,*)' datadir = /absolute/path/to/datagcm' + write(*,*)'Also check that the corrkdir you chose in callphys.def exists.' + call abort_physic("rad_correlatedk_init_thermal","Unable to read file",1) + endif + +!$OMP MASTER + nb=0 + ierr=0 + ! check that the file contains the right number of bands + open(131,file=file_path,form='formatted') + read(131,*,iostat=ierr) file_entries + do while (ierr==0) + read(131,*,iostat=ierr) dummy +! write(*,*) 'rad_correlatedk_init_thermal: file_entries:',dummy,'ierr=',ierr + if (ierr==0) nb=nb+1 + enddo + close(131) + + write(*,*) 'rad_correlatedk_init_thermal: L_NSPECTI = ',L_NSPECTI, 'in the model ' + write(*,*) ' there are ',nb, 'entries in ',TRIM(file_path) + if(nb.ne.L_NSPECTI) then + write(*,*) 'MISMATCH !! I stop here' + call abort_physic("rad_correlatedk_init_thermal","The number of entries in narrowbands_IR.in does not match with L_NSPECTI",1) + endif + + ! load and display the data + open(111,file=file_path,form='formatted') + read(111,*) + do M=1,L_NSPECTI-1 + read(111,*) BWNI(M) + end do + read(111,*) lastband + close(111) + BWNI(L_NSPECTI) =lastband(1) + BWNI(L_NSPECTI+1)=lastband(2) +!$OMP END MASTER +!$OMP BARRIER + + print*,'' + print*,'rad_correlatedk_init_thermal: IR band limits:' + do M=1,L_NSPECTI+1 + print*,m,'-->',BWNI(M),' cm^-1' + end do + +! Set up mean wavenumbers and wavenumber deltas. Units of +! wavenumbers is cm^(-1); units of wavelengths is microns. + + do M=1,L_NSPECTI + WNOI(M) = 0.5D0*(BWNI(M+1)+BWNI(M)) + DWNI(M) = BWNI(M+1)-BWNI(M) + WAVEI(M) = 1.0D+4/WNOI(M) + BLAMI(M) = 0.01D0/BWNI(M) + end do + BLAMI(M) = 0.01D0/BWNI(M) +! note M=L_NSPECTI+1 after loop due to Fortran bizarreness + +!======================================================================= +! For each IR wavelength interval, compute the integral of B(T), the +! Planck function, divided by the wavelength interval, in cm-1. The +! integration is in MKS units, the final answer is the same as the +! original planck.f; W m^-2 wavenumber^-1, where wavenumber is in CM^-1. + + print*,'' + print*,'rad_correlatedk_init_thermal: Current Planck integration range:' + print*,'T = ',dble(NTstart)/NTfac, ' to ',dble(NTstop)/NTfac,' K.' + + IF(.NOT.ALLOCATED(planckir)) ALLOCATE(planckir(L_NSPECTI,NTstop-NTstart+1)) + + do NW=1,L_NSPECTI + a = 1.0D-2/BWNI(NW+1) + b = 1.0D-2/BWNI(NW) + bpa = (b+a)/2.0D0 + bma = (b-a)/2.0D0 + ! if (nw .eq. 25) then !LT debug + ! print*, "a = ",a + ! print*, "b= ",b + ! print*,"bpa = ",bpa + ! print*, "bma = ",bma + ! endif + do nt=NTstart,NTstop + T = dble(NT)/NTfac + ans = 0.0D0 + do mm=1,12 + y = bma*x(mm)+bpa + !to avoid floating overflow when T is low and optical wavelength + if ((c2/(y*T)) .lt. 700.0D0) then + ans = ans + w(mm)*c1/(y**5*(exp(c2/(y*T))-1.0D0)) + else + ans = ans +0.0D0 + endif + end do + planckir(NW,nt-NTstart+1) = ans*bma/(PI*DWNI(NW)) + end do + end do + + ! force planck=sigma*eps*T^4 for each temperature in array + if(forceEC)then + print*,'rad_correlatedk_init_thermal: Force F=sigma*eps*T^4 for all values of T!' + do nt=NTstart,NTstop + plancksum=0.0D0 + T=dble(NT)/NTfac + + do NW=1,L_NSPECTI + plancksum=plancksum+ & + planckir(NW,nt-NTstart+1)*DWNI(NW)*pi + end do + + do NW=1,L_NSPECTI + planckir(NW,nt-NTstart+1)= & + planckir(NW,nt-NTstart+1)* & + sigma*(dble(nt)/NTfac)**4/plancksum + end do + end do + endif + + if(planckcheck)then + ! check energy conservation at lower temperature boundary + plancksum=0.0D0 + nt=NTstart + do NW=1,L_NSPECTI + plancksum=plancksum+planckir(NW,nt-NTstart+1)*DWNI(NW)*pi + end do + print*,'rad_correlatedk_init_thermal: At lower limit:' + print*,'in model sig*T^4 = ',plancksum,' W m^-2' + print*,'actual sig*T^4 = ',sigma*(dble(nt)/NTfac)**4,' W m^-2' + + ! check energy conservation at upper temperature boundary + plancksum=0.0D0 + nt=NTstop + do NW=1,L_NSPECTI + plancksum=plancksum+planckir(NW,nt-NTstart+1)*DWNI(NW)*pi + end do + print*,'rad_correlatedk_init_thermal: At upper limit:' + print*,'in model sig*T^4 = ',plancksum,' W m^-2' + print*,'actual sig*T^4 = ',sigma*(dble(nt)/NTfac)**4,' W m^-2' + print*,'' + endif + + return + end subroutine rad_correlatedk_init_thermal Index: trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_online_recombination.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_online_recombination.F90 (revision 4077) +++ trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_online_recombination.F90 (revision 4077) @@ -0,0 +1,1032 @@ +MODULE rad_correlatedk_online_recombination_mod + + ! + ! Author : Jan Vatant d'Ollone (2018-2020) + ! + ! This module contains the following subroutines : + ! - rad_correlatedk_recombination_init : From modern traceur.def options check if we will use recombining and for which species. Called by initracer. + ! - rad_correlatedk_recombination_setup : Initialise tables. Called by rad_correlatedk_read_opacity_tables + ! - rad_correlatedk_recombination_main : Test profile of species and decide whether to call rad_correlatedk_online_recombination. Called by callcork + ! - rad_correlatedk_online_recombination : The core algorithm properly recombining corrk tables. + ! + + ! TODO : Think about the case where nqtot phys /= nqtot_dyn !! + ! TODO : Add the possibility to read an input profile for a specie !! + ! Also think about the hybrid case where we want force with a latitudinally variable input profile (likely need to tweak on-the-fly) + + IMPLICIT NONE + + LOGICAL, SAVE :: corrk_recombin=.false. ! Key boolean, is there any specie to recombin. + LOGICAL, SAVE :: use_premix=.true. ! Indicates if we recombin on top of a existing premix set of corrk. + !$OMP THREADPRIVATE(corrk_recombin,use_premix) + + INTEGER, SAVE :: nrecomb_tot ! # (total) of compounds to recombine + ! -> Linked to key is_recomb in tracer_h + + INTEGER, SAVE :: nrecomb_qset ! # of compounds to recombine having preset abundances (ie spectra computed with true vmr and not vmr=1) + !-> Linked to key is_recomb_qset in tracer_h + + INTEGER, SAVE :: nrecomb_qotf ! # of compounds to recombine on-the-fly (ie using value of pq, not input profile) + !-> Linked to key is_recomb_qotf in tracer_h + !$OMP THREADPRIVATE(nrecomb_tot,nrecomb_qset,nrecomb_qotf) + + ! Note : The variables above are not read in callphys.def but automatically defined in inirecombin called in initracer after processing traceur.def + + LOGICAL, SAVE :: all_otf ! True if all species are recombined on-the-fly, no premix, no preset .. + !$OMP THREADPRIVATE(all_otf) + + ! Following arrays are allocated in rad_correlatedk_recombination_setup (excepted otf2tot_idx, in rad_correlatedk_recombination_init) and deallocated in callcork lastcall + REAL*8, save, DIMENSION(:,:,:,:,:), ALLOCATABLE :: gasi_recomb, gasv_recomb + REAL*8, save, DIMENSION(:,:,:,:,:), ALLOCATABLE :: gasi_otf, gasv_otf + REAL*8, save, DIMENSION(:), ALLOCATABLE :: w_cum + REAL*8, save, DIMENSION(:), ALLOCATABLE :: wtwospec + + INTEGER, save, DIMENSION(:), ALLOCATABLE :: otf2tot_idx + INTEGER, save, DIMENSION(:), ALLOCATABLE :: rcb2tot_idx + INTEGER, save, DIMENSION(:), ALLOCATABLE :: otf2rcb_idx + + INTEGER, save, DIMENSION(:), ALLOCATABLE :: permut_idx + !$OMP THREADPRIVATE(gasi_recomb,gasv_recomb,w_cum,otf2tot_idx,rcb2tot_idx,otf2rcb_idx,permut_idx) + + CONTAINS + + + SUBROUTINE rad_correlatedk_recombination_init + + USE tracer_h + + IMPLICIT NONE + + INTEGER :: nspcrad ! # of is_rad species (tempooray here, should be a radcommon variabke) + INTEGER :: iq, icount + + ! Default values + use_premix = .true. + corrk_recombin = .false. + nrecomb_tot = 0 + nrecomb_qset = 0 + nrecomb_qotf = 0 + + nspcrad = 0 + + do iq=1,nqtot + + ! Counter used to check if all rad. species are recombin then no premix + if(is_rad(iq)==1) nspcrad = nspcrad + 1 + + ! Sanity checks + if (is_recomb(iq)==1 .and. is_rad(iq)==0) then + write(*,*) 'initracer : Error for tracer iq=',iq + write(*,*) 'is_recomb=1 but is_rad=0, this is not possible !' + call abort_physic('initrac','Conflicting traceur.def options',1) + endif + if (is_recomb_qset(iq)==1 .and. is_recomb(iq)==0) then + write(*,*) 'initracer : Error for tracer iq=',iq + write(*,*) 'is_recomb_qset=1 but is_recomb=0, this is not possible !' + call abort_physic('initrac','Conflicting traceur.def options',1) + endif + if (is_recomb_qotf(iq)==1 .and. is_recomb_qset(iq)==1) then + write(*,*) 'initracer : Error for tracer iq=',iq + write(*,*) 'is_recomb_qset=1 and is_recomb_qotf=1, this is not possible !' + call abort_physic('initrac','Conflicting traceur.def options',1) + endif + + if(is_recomb(iq)==1) then + corrk_recombin = .true. ! activating on first one found would be enough actually but I'm lazy + + nrecomb_tot = nrecomb_tot + 1 + + if(is_recomb_qset(iq)==1) nrecomb_qset = nrecomb_qset + 1 + if(is_recomb_qotf(iq)==1) nrecomb_qotf = nrecomb_qotf + 1 + + write(*,*) + write(*,*) 'rad_correlatedk_recombination_init: found specie : Name = ',trim(noms(iq)), & + ' ; Predefined vmr=', is_recomb_qset(iq), & + ' ; On-the-fly=', is_recomb_qotf(iq) + + endif + + enddo + + ! Init. correspondance array of indexes between subset of tracers + IF(.NOT. ALLOCATED(otf2tot_idx)) ALLOCATE(otf2tot_idx(nrecomb_qotf)) + icount=0 + do iq=1,nqtot + if(is_recomb_qotf(iq)==1) then + icount=icount+1 + otf2tot_idx(icount) = iq + endif + enddo + + IF(.NOT. ALLOCATED(rcb2tot_idx)) ALLOCATE(rcb2tot_idx(nrecomb_tot)) + icount=0 + do iq=1,nqtot + if(is_recomb(iq)==1) then + icount=icount+1 + rcb2tot_idx(icount) = iq + endif + enddo + + IF(.NOT. ALLOCATED(otf2rcb_idx)) ALLOCATE(otf2rcb_idx(nrecomb_qotf)) + icount=0 + do iq=1,nrecomb_tot + if(is_recomb_qotf(rcb2tot_idx(iq))==1) then + icount=icount+1 + otf2rcb_idx(icount) = iq + endif + enddo + + ! Use a premix set on top ? + if (nspcrad == nrecomb_tot .and. nspcrad /= 0) use_premix = .false. ! In this case all rad. species are recombined + + ! Summary + write(*,*) + write(*,*) 'rad_correlatedk_recombination_init: Total species found for corrk recombination =', nrecomb_tot + + if (corrk_recombin) then + if (use_premix) then + write(*,*) 'rad_correlatedk_recombination_init: .. Total radiative species matching total species for recombination...' + write(*,*) 'rad_correlatedk_recombination_init: .. Any pre-mixed set of opacities will be ignored.' + else + write(*,*) 'rad_correlatedk_recombination_init: .. Found less species to recombine than total radiative species..' + write(*,*) 'rad_correlatedk_recombination_init: .. Recombination will occur ontop of premix set of opacities' + endif + else + write(*,*) 'rad_correlatedk_recombination_init: .. No species found for recombination, I will use premix set only.' + endif + write(*,*) + + END SUBROUTINE rad_correlatedk_recombination_init + + + + SUBROUTINE rad_correlatedk_recombination_setup + USE radinc_h + USE radcommon_h, only: gweight, gasi, gasv + + IMPLICIT NONE + + INTEGER :: i, ig, jg, ind, iw, it, ip + + ! Allocations + IF(.NOT. ALLOCATED(permut_idx)) ALLOCATE(permut_idx(L_NGAUSS*L_NGAUSS)) + IF(.NOT. ALLOCATED(w_cum)) ALLOCATE(w_cum(L_NGAUSS)) + IF(.NOT. ALLOCATED(gasi_recomb)) ALLOCATE(gasi_recomb(L_NTREF,L_PINT,L_REFVAR,L_NSPECTI,L_NGAUSS)) + IF(.NOT. ALLOCATED(gasv_recomb)) ALLOCATE(gasv_recomb(L_NTREF,L_PINT,L_REFVAR,L_NSPECTV,L_NGAUSS)) + IF(.NOT. ALLOCATED(gasi_otf)) ALLOCATE(gasi_otf(L_NGAUSS,nrecomb_qotf,L_NSPECTI,L_NTREF,L_PINT)) + IF(.NOT. ALLOCATED(gasv_otf)) ALLOCATE(gasv_otf(L_NGAUSS,nrecomb_qotf,L_NSPECTI,L_NTREF,L_PINT)) + IF(.NOT. ALLOCATED(wtwospec)) ALLOCATE(wtwospec(L_NGAUSS*L_NGAUSS)) + + ! Init. for rad_correlatedk_online_recombination firstcall + permut_idx = (/(i, i=1,L_NGAUSS*L_NGAUSS)/) + + w_cum(1)= gweight(1) + DO i=2,L_NGAUSS + w_cum(i) = w_cum(i-1)+gweight(i) + ENDDO + + ! init wtwospec once for all + DO ig=1,L_NGAUSS + DO jg=1, L_NGAUSS + ind = jg+(ig-1)*L_NGAUSS + wtwospec(ind) = gweight(ig)*gweight(jg) + ENDDO + ENDDO + + ! init otf correlated-k array + do ip=1,L_PINT + do it=1,L_NTREF + do iw=1,L_NSPECTI + do i=1,nrecomb_qotf + do ig=1,L_NGAUSS + gasi_otf(ig,i,iw,it,ip) = gasi(it,ip,L_REFVAR+otf2rcb_idx(i),iw,ig) ! choose only idx corresponding to otf in gasi + enddo + enddo + enddo + enddo + enddo + do ip=1,L_PINT + do it=1,L_NTREF + do iw=1,L_NSPECTV + do i=1,nrecomb_qotf + do ig=1,L_NGAUSS + gasv_otf(ig,i,iw,it,ip) = gasv(it,ip,L_REFVAR+otf2rcb_idx(i),iw,ig) ! choose only idx corresponding to otf in gasv + enddo + enddo + enddo + enddo + enddo + + gasi_recomb(:,:,:,:,:) = gasi(:,:,1:L_REFVAR,:,:) ! non-zero init (=kappa_ir) + gasv_recomb(:,:,:,:,:) = gasv(:,:,1:L_REFVAR,:,:) ! non-zero init (=kappa_vi) + + END SUBROUTINE rad_correlatedk_recombination_setup + + + + SUBROUTINE rad_correlatedk_recombination_main(igrid,nlayer,pq,pplay,pt,qvar,tmid,pmid) + + USE comcstfi_mod, only: mugaz + USE radinc_h + USE radcommon_h + USE tracer_h, only: noms, mmol, is_recomb_qotf, is_recomb_qset + USE tpindex_mod, only: tpindex + + IMPLICIT NONE + + ! Inputs + INTEGER, INTENT(IN) :: igrid ! lon-lat grid point + INTEGER, INTENT(IN) :: nlayer ! Number of atmospheric layers. + + REAL*8, DIMENSION(:,:), INTENT(IN) :: pq ! Tracers vertical profiles (kg/kg) + REAL*8, DIMENSION(nlayer), INTENT(IN) :: pplay ! Atmospheric pressure (Pa) + REAL*8, DIMENSION(nlayer), INTENT(IN) :: pt ! Atmospheric temperature (K) + REAL*8, DIMENSION(L_LEVELS), INTENT(IN) :: qvar ! Mixing ratio of variable component (mol/mol) + REAL*8, DIMENSION(L_LEVELS), INTENT(IN) :: tmid ! Temperature of layers, mid levels (K) + REAL*8, DIMENSION(L_LEVELS), INTENT(IN) :: pmid ! Pressure of layers, mid levels (mBar) + + ! NB : qvar is on L_LEVELS but it has been processed in callcork compared to the one in pq + ! so we imperatively need to take this one. Note that there is no interpolation, so + ! pq(nlayer+1-l,ivar) is broadcast in qvar(2*l) qvar(2*l+1) + + ! Local variables + INTEGER :: ng + INTEGER :: ig,l,k,nw,iq,ip,ilay,it,ix,iw + + LOGICAL :: found + + REAL*8 :: fact, tmin, tmax, qmin, qmax + REAL*8 :: LCOEF(4), WRATIO + + LOGICAL,DIMENSION(:,:,:),ALLOCATABLE,save :: useptx ! Mask on which t-p-x ref grid point will be used + + REAL*8, DIMENSION(:,:), ALLOCATABLE,save :: pqr ! Tracers abundances at ref pressures used for onthefly recombining (mol/mol). + + LOGICAL,SAVE :: firstcall=.true. + !$OMP THREADPRIVATE(firstcall) + + ! At firstcall we precombine all what needs to be done only once (pre-mixed,forced profiles..), if needed. + IF (firstcall) THEN + + IF(.NOT. ALLOCATED(useptx)) ALLOCATE(useptx(L_NTREF,L_PINT,L_REFVAR)) + useptx(:,:,:) = .false. + + IF(use_premix .or. (.not.use_premix .and. nrecomb_qotf/=nrecomb_tot)) THEN ! we skip this if all species are on-the-fly + all_otf=.false. + IF(.NOT. ALLOCATED(pqr)) ALLOCATE(pqr(nrecomb_tot,L_PINT)) + ! Default value for premix and for fixed species for whom vmr has been taken + ! into account while computing high-resolution spectra + pqr(:,:) = 1.0 + + ! TODO : Missing implementation here for the tracers where we read an input profile !! + do iq=1,nrecomb_tot + if (is_recomb_qset(rcb2tot_idx(iq))==0 .and. is_recomb_qotf(rcb2tot_idx(iq))==0) then + print*, 'Recombining tracer ', noms(rcb2tot_idx(iq)),' requires an input profile, this is not implemented yet !!' + call abort_physic('rad_correlatedk_recombination_main','Missing implementation',1) + ! Read pqr(:,iq) + endif + enddo + + ! Recombine for all T-P-Q as we do it only once for all. + call rad_correlatedk_online_recombination_init(pqr) + ELSE + all_otf=.true. + ENDIF + + firstcall=.false. + IF (nrecomb_qotf==0) corrk_recombin = .false. + IF(ALLOCATED(pqr)) DEALLOCATE(pqr) + IF(.NOT. ALLOCATED(pqr)) ALLOCATE(pqr(nrecomb_qotf,L_PINT)) + + ENDIF ! firstcall + + ! NB : To have decent CPU time recombining is not done on all gridpoints and wavelenghts but we + ! calculate a gasi/v_recomb variable on the reference corrk-k T,P,X grid (only for T,P,X values + ! who match the atmospheric conditions) which is then processed as a standard pre-mix in + ! rad_correlatedk_opacities_thermal/v routines, but updated every time tracers on the ref P grid have varied > 1%. + + ! Extract tracers for species which are recombined on-the-fly + do ip=1,L_PINT + + ilay=0 + found = .false. + do l=1,nlayer + if (pplay(l) .le. 10.0**(pfgasref(ip)+2.0)) then ! pfgasref=log(p[mbar]) + found=.true. + ilay=l-1 + exit + endif + enddo + + if (.not. found) then ! set pq to top value + do iq=1,nrecomb_qotf + pqr(iq,ip) = pq(nlayer,otf2tot_idx(iq))*mugaz/mmol(otf2tot_idx(iq)) ! mol/mol + enddo + else + if (ilay==0) then ! set pq to bottom value + do iq=1,nrecomb_qotf + pqr(iq,ip) = pq(1,otf2tot_idx(iq))*mugaz/mmol(otf2tot_idx(iq)) ! mol/mol + enddo + else ! standard : interp pq between layers + fact = (10.0**(pfgasref(ip)+2.0) - pplay(ilay+1)) / (pplay(ilay) - pplay(ilay+1)) ! pfgasref=log(p[mbar]) + do iq=1,nrecomb_qotf + pqr(iq,ip) = pq(ilay,otf2tot_idx(iq))**fact * pq(ilay+1,otf2tot_idx(iq))**(1.0-fact) + pqr(iq,ip) = pqr(iq,ip)*mugaz/mmol(otf2tot_idx(iq)) ! mol/mol + enddo + endif ! if ilay==nlayer + endif ! if not found + + enddo ! ip=1,L_PINT + + ! The following useptx is a trick to call recombine only for the reference T-P-X + ! reference grid points that are useful given the temperature range (and variable specie amount) at a given altitude + ! (cf rad_correlatedk_opacities_thermal/rad_correlatedk_opacities_stellar routines where we interpolate corrk calling tpindex) + ! It saves a looot of time - JVO 18 + + do K=2,L_LEVELS + call tpindex(PMID(K),TMID(K),QVAR(K),pfgasref,tgasref,WREFVAR,LCOEF,it,ip,ix,WRATIO) + useptx(it:it+1,ip:ip+1,ix:ix+1) = .true. + end do + + if (.not.all_otf) then + call rad_correlatedk_online_recombination_mix(igrid,pqr,useptx) + else + if (nrecomb_qotf.gt.1) then + call rad_correlatedk_online_recombination_mix_allotf(igrid,pqr,useptx) + else + do ix=1,L_REFVAR + do ip=1,L_PINT + do it=1,L_NTREF + if (.not. useptx(it,ip,ix)) cycle + gasi_recomb(it,ip,ix,:,:) = pqr(1,ip)*gasi_otf(:,1,:,it,ip) + gasv_recomb(it,ip,ix,:,:) = pqr(1,ip)*gasv_otf(:,1,:,it,ip) + useptx(it,ip,ix) = .false. + enddo + enddo + enddo + endif + endif + + END SUBROUTINE rad_correlatedk_recombination_main + + SUBROUTINE rad_correlatedk_online_recombination_init(pqr) + + USE radinc_h + USE radcommon_h, only: gweight, tlimit, gasi, gasv + USE tracer_h, only: is_recomb_qotf + USE sort_mod, only: isort + + !----------------------------------------------------------------------- + ! Declarations: + ! ------------- + + IMPLICIT NONE + + ! Arguments : + ! ----------- + REAL*8, DIMENSION(nrecomb_qotf,L_PINT), INTENT(IN) :: pqr ! otf species mixing ration + + ! Local variables : + ! ----------------- + INTEGER :: it, ip, ix, iw, ig, jg, ind, ibin, ispec + + REAL*8, DIMENSION(L_NGAUSS) :: tmpk ! otf correlated-k by mixing ratio + REAL*8, DIMENSION(L_NGAUSS) :: krecomb + + REAL*8, DIMENSION(L_NGAUSS*L_NGAUSS) :: ktwospec + REAL*8, DIMENSION(L_NGAUSS*L_NGAUSS) :: ktwospec_s + REAL*8, DIMENSION(L_NGAUSS*L_NGAUSS) :: wtwospec_s + REAL*8, DIMENSION(L_NGAUSS*L_NGAUSS) :: wtwospec_cum + + REAL*8 :: wsplit + + do ix=1,L_REFVAR + do ip=1,L_PINT + do it=1,L_NTREF + + ! ------------------- + ! I. INFRARED + ! ------------------- + + DO iw=1,L_NSPECTI + DO ig=1,L_NGAUSS ! init correlated-k with premix + ! utiliser directement gasi_recomb au lieu d'un variable intermediere krecomb ? + ! Peut ok si L_NGAUSS première dimension de gasi_recomb + krecomb(ig) = gasi(it,ip,ix,iw,ig) + ENDDO + DO ispec=1,nrecomb_tot ! Loop on additional species + + IF(is_recomb_qotf(rcb2tot_idx(ispec))==1) CYCLE + ! takes all to recomb, the otf ones are skipped + DO ig=1,L_NGAUSS + tmpk(ig) = pqr(ispec,ip)*gasi(it,ip,L_REFVAR+ispec,iw,ig) + ENDDO + + ! Save ( a lot of ) CPU time, we don't add the specie if negligible absorption in the band + IF ( tmpk(L_NGAUSS-1) .LE. tlimit ) CYCLE + IF ( ALL( tmpk(1:L_NGAUSS-1) .LE. krecomb(1:L_NGAUSS-1)*0.1 ) ) CYCLE + IF ( ALL( krecomb(1:L_NGAUSS-1) .LE. tmpk(1:L_NGAUSS-1)*0.1 ) ) THEN + krecomb(1:L_NGAUSS-1) = tmpk(1:L_NGAUSS-1) + CYCLE + ENDIF + + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ! 1. Recombining ~~~~~~~~~~~~~~~~~~~~~~~~~ + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + DO ig=1,L_NGAUSS + DO jg=1, L_NGAUSS + ind = jg+(ig-1)*L_NGAUSS + ktwospec(ind) = krecomb(ig)+tmpk(jg) + ENDDO + ENDDO + + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ! 2. Resorting ~~~~~~~~~~~~~~~~~~~~~~~ + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + ! Pre-sort from last step ( we have always a similar regular pattern ) to gain time for sorting + ! NB : quite small array, quicker to permut with 2nd array than in place + DO ind=1,L_NGAUSS*L_NGAUSS + ktwospec_s(ind) = ktwospec(permut_idx(ind)) ! NB : won't do anything at firstcall + ENDDO + + CALL isort(ktwospec_s,L_NGAUSS*L_NGAUSS,permut_idx) ! Insertion sort quicker because pre-sorted + + ! Sort w according to permutations of k. + ! NB : quite small array, quicker to permut with 2nd array than in place + DO ind=1,L_NGAUSS*L_NGAUSS + wtwospec_s(ind) = wtwospec(permut_idx(ind)) + ENDDO + + wtwospec_cum(1) = wtwospec_s(1) + DO ind=2,L_NGAUSS*L_NGAUSS + wtwospec_cum(ind)= wtwospec_cum(ind-1)+wtwospec_s(ind) + ENDDO + + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ! 3. Rebinning on smaller amount of Gauss points ~~~~~~~~~~~ + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ibin=1 + + krecomb(:)=0.0 + + DO ig=1, L_NGAUSS-1 + + DO ind=ibin,L_NGAUSS*L_NGAUSS ! rather than a while + IF ( wtwospec_cum(ind) .GT. w_cum(ig) ) THEN + wsplit = w_cum(ig) - wtwospec_cum(ind-1) + krecomb(ig) = krecomb(ig) & + + sum ( wtwospec_s(ibin:ind-1)*ktwospec_s(ibin:ind-1) ) & + + wsplit*ktwospec_s(ind) + krecomb(ig+1) = (wtwospec_s(ind)-wsplit)*ktwospec_s(ind) + ibin=ind+1 + EXIT + ENDIF + ENDDO + + krecomb(L_NGAUSS) = krecomb(L_NGAUSS) + sum ( wtwospec_s(ibin:)*ktwospec_s(ibin:) ) + + ENDDO + + krecomb(1:L_NGAUSS-1) = krecomb(1:L_NGAUSS-1) / gweight(1:L_NGAUSS-1) ! gw(L_NGAUSS)=0 + + ENDDO ! ispec=1,nrecomb_qotf + gasi(it,ip,ix,iw,:) = krecomb(:) + ENDDO ! iw=1,L_NSPECTI + + ! ------------------- + ! II. VISIBLE + ! ------------------- + + DO iw=1,L_NSPECTV + DO ig=1,L_NGAUSS ! init correlated-k with premix + krecomb(ig) = gasv(it,ip,ix,iw,ig) ! there is a prerecombined cocktail + ENDDO + DO ispec=1,nrecomb_tot ! Loop on additional species + + IF(is_recomb_qotf(rcb2tot_idx(ispec))==1) CYCLE + ! takes all to recomb, the otf ones are skipped + DO ig=1,L_NGAUSS + tmpk(ig) = pqr(ispec,ip)*gasv(it,ip,L_REFVAR+ispec,iw,ig) + ENDDO + + ! Save ( a lot of ) CPU time, we don't add the specie if negligible absorption in the band + IF ( tmpk(L_NGAUSS-1) .LE. tlimit ) CYCLE + IF ( ALL( tmpk(1:L_NGAUSS-1) .LE. krecomb(1:L_NGAUSS-1)*0.1 ) ) CYCLE + IF ( ALL( krecomb(1:L_NGAUSS-1) .LE. tmpk(1:L_NGAUSS-1)*0.1 ) ) THEN + krecomb(1:L_NGAUSS-1) = tmpk(1:L_NGAUSS-1) + CYCLE + ENDIF + + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ! 1. Recombining ~~~~~~~~~~~~~~~~~~~~~~~~~ + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + DO ig=1,L_NGAUSS + DO jg=1, L_NGAUSS + ind = jg+(ig-1)*L_NGAUSS + ktwospec(ind) = krecomb(ig)+tmpk(jg) + ENDDO + ENDDO + + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ! 2. Resorting ~~~~~~~~~~~~~~~~~~~~~~~ + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + ! Pre-sort from last step ( we have always a similar regular pattern ) to gain time for sorting + ! NB : quite small array, quicker to permut with 2nd array than in place + DO ind=1,L_NGAUSS*L_NGAUSS + ktwospec_s(ind) = ktwospec(permut_idx(ind)) ! NB : won't do anything at firstcall + ENDDO + + CALL isort(ktwospec_s,L_NGAUSS*L_NGAUSS,permut_idx) ! Insertion sort quicker because pre-sorted + + ! Sort w according to permutations of k. + ! NB : quite small array, quicker to permut with 2nd array than in place + DO ind=1,L_NGAUSS*L_NGAUSS + wtwospec_s(ind) = wtwospec(permut_idx(ind)) + ENDDO + + wtwospec_cum(1) = wtwospec_s(1) + DO ind=2,L_NGAUSS*L_NGAUSS + wtwospec_cum(ind)= wtwospec_cum(ind-1)+wtwospec_s(ind) + ENDDO + + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ! 3. Rebinning on smaller amount of Gauss points ~~~~~~~~~~~ + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ibin=1 + + krecomb(:)=0.0 + + DO ig=1, L_NGAUSS-1 + + DO ind=ibin,L_NGAUSS*L_NGAUSS ! rather than a while + IF ( wtwospec_cum(ind) .GT. w_cum(ig) ) THEN + wsplit = w_cum(ig) - wtwospec_cum(ind-1) + krecomb(ig) = krecomb(ig) & + + sum ( wtwospec_s(ibin:ind-1)*ktwospec_s(ibin:ind-1) ) & + + wsplit*ktwospec_s(ind) + krecomb(ig+1) = (wtwospec_s(ind)-wsplit)*ktwospec_s(ind) + ibin=ind+1 + EXIT + ENDIF + ENDDO + + krecomb(L_NGAUSS) = krecomb(L_NGAUSS) + sum ( wtwospec_s(ibin:)*ktwospec_s(ibin:) ) + + ENDDO + + krecomb(1:L_NGAUSS-1) = krecomb(1:L_NGAUSS-1) / gweight(1:L_NGAUSS-1) ! gw(L_NGAUSS)=0 + + ENDDO ! ispec=1,nrecomb_qotf + gasv(it,ip,ix,iw,:) = krecomb(:) + ENDDO ! iw=1,L_NSPECTV + + enddo ! ix=1,L_NTREF + enddo ! it=1,L_PINT + enddo ! ip=1,L_REFVAR + + END SUBROUTINE rad_correlatedk_online_recombination_init + + SUBROUTINE rad_correlatedk_online_recombination_mix(igrid,pqr,useptx) + + USE radinc_h + USE radcommon_h, only: gweight, tlimit, gasi, gasv + USE sort_mod, only: isort + use comsaison_h, only: fract + + !----------------------------------------------------------------------- + ! Declarations: + ! ------------- + + IMPLICIT NONE + + ! Arguments : + ! ----------- + INTEGER, INTENT(IN) :: igrid ! lon-lat grid point + REAL*8, DIMENSION(nrecomb_qotf,L_PINT), INTENT(IN) :: pqr ! otf species mixing ration + LOGICAL, INTENT(INOUT) :: useptx(L_NTREF,L_PINT,L_REFVAR) ! Mask on which t-p-x ref grid point will be used + + ! Local variables : + ! ----------------- + INTEGER :: it, ip, ix, iw, ig, jg, ind, ibin, ispec + + REAL*8, DIMENSION(L_NGAUSS) :: tmpk ! otf correlated-k by mixing ratio + REAL*8, DIMENSION(L_NGAUSS) :: krecomb + + REAL*8, DIMENSION(L_NGAUSS*L_NGAUSS) :: ktwospec + REAL*8, DIMENSION(L_NGAUSS*L_NGAUSS) :: ktwospec_s + REAL*8, DIMENSION(L_NGAUSS*L_NGAUSS) :: wtwospec_s + REAL*8, DIMENSION(L_NGAUSS*L_NGAUSS) :: wtwospec_cum + + REAL*8 :: wsplit + + do ix=1,L_REFVAR + do ip=1,L_PINT + do it=1,L_NTREF + if (.not. useptx(it,ip,ix)) cycle + + ! ------------------- + ! I. INFRARED + ! ------------------- + + DO iw=1,L_NSPECTI + DO ig=1,L_NGAUSS ! init correlated-k with premix + ! utiliser directement gasi_recomb au lieu d'un variable intermediere krecomb ? + ! Peut ok si L_NGAUSS première dimension de gasi_recomb + krecomb(ig) = gasi(it,ip,ix,iw,ig) + ENDDO + DO ispec=1,nrecomb_qotf ! Loop on additional species + + DO ig=1,L_NGAUSS + tmpk(ig) = pqr(ispec,ip)*gasi_otf(ig,ispec,iw,it,ip) + ENDDO + + ! Save ( a lot of ) CPU time, we don't add the specie if negligible absorption in the band + IF ( tmpk(L_NGAUSS-1) .LE. tlimit ) CYCLE + IF ( ALL( tmpk(1:L_NGAUSS-1) .LE. krecomb(1:L_NGAUSS-1)*0.1 ) ) CYCLE + IF ( ALL( krecomb(1:L_NGAUSS-1) .LE. tmpk(1:L_NGAUSS-1)*0.1 ) ) THEN + krecomb(1:L_NGAUSS-1) = tmpk(1:L_NGAUSS-1) + CYCLE + ENDIF + + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ! 1. Recombining ~~~~~~~~~~~~~~~~~~~~~~~~~ + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + DO ig=1,L_NGAUSS + DO jg=1, L_NGAUSS + ind = jg+(ig-1)*L_NGAUSS + ktwospec(ind) = krecomb(ig)+tmpk(jg) + ENDDO + ENDDO + + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ! 2. Resorting ~~~~~~~~~~~~~~~~~~~~~~~ + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + ! Pre-sort from last step ( we have always a similar regular pattern ) to gain time for sorting + ! NB : quite small array, quicker to permut with 2nd array than in place + DO ind=1,L_NGAUSS*L_NGAUSS + ktwospec_s(ind) = ktwospec(permut_idx(ind)) ! NB : won't do anything at firstcall + ENDDO + + CALL isort(ktwospec_s,L_NGAUSS*L_NGAUSS,permut_idx) ! Insertion sort quicker because pre-sorted + + ! Sort w according to permutations of k. + ! NB : quite small array, quicker to permut with 2nd array than in place + DO ind=1,L_NGAUSS*L_NGAUSS + wtwospec_s(ind) = wtwospec(permut_idx(ind)) + ENDDO + + wtwospec_cum(1) = wtwospec_s(1) + DO ind=2,L_NGAUSS*L_NGAUSS + wtwospec_cum(ind)= wtwospec_cum(ind-1)+wtwospec_s(ind) + ENDDO + + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ! 3. Rebinning on smaller amount of Gauss points ~~~~~~~~~~~ + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ibin=1 + + krecomb(:)=0.0 + + DO ig=1, L_NGAUSS-1 + + DO ind=ibin,L_NGAUSS*L_NGAUSS ! rather than a while + IF ( wtwospec_cum(ind) .GT. w_cum(ig) ) THEN + wsplit = w_cum(ig) - wtwospec_cum(ind-1) + krecomb(ig) = krecomb(ig) & + + sum ( wtwospec_s(ibin:ind-1)*ktwospec_s(ibin:ind-1) ) & + + wsplit*ktwospec_s(ind) + krecomb(ig+1) = (wtwospec_s(ind)-wsplit)*ktwospec_s(ind) + ibin=ind+1 + EXIT + ENDIF + ENDDO + + krecomb(L_NGAUSS) = krecomb(L_NGAUSS) + sum ( wtwospec_s(ibin:)*ktwospec_s(ibin:) ) + + ENDDO + + krecomb(1:L_NGAUSS-1) = krecomb(1:L_NGAUSS-1) / gweight(1:L_NGAUSS-1) ! gw(L_NGAUSS)=0 + + ENDDO ! ispec=1,nrecomb_qotf + gasi_recomb(it,ip,ix,iw,:) = krecomb(:) + ENDDO ! iw=1,L_NSPECTI + + ! ------------------- + ! II. VISIBLE + ! ------------------- + + if(fract(igrid) .lt. 1.0e-4) cycle ! Only during daylight. + + DO iw=1,L_NSPECTV + DO ig=1,L_NGAUSS ! init correlated-k with premix + krecomb(ig) = gasv(it,ip,ix,iw,ig) ! gasv_loc order correctly for running time? + ENDDO + DO ispec=1,nrecomb_qotf ! Loop on additional species + + DO ig=1,L_NGAUSS + tmpk(ig) = pqr(ispec,ip)*gasv_otf(ig,ispec,iw,it,ip) + ENDDO + + ! Save ( a lot of ) CPU time, we don't add the specie if negligible absorption in the band + IF ( tmpk(L_NGAUSS-1) .LE. tlimit ) CYCLE + IF ( ALL( tmpk(1:L_NGAUSS-1) .LE. krecomb(1:L_NGAUSS-1)*0.1 ) ) CYCLE + IF ( ALL( krecomb(1:L_NGAUSS-1) .LE. tmpk(1:L_NGAUSS-1)*0.1 ) ) THEN + krecomb(1:L_NGAUSS-1) = tmpk(1:L_NGAUSS-1) + CYCLE + ENDIF + + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ! 1. Recombining ~~~~~~~~~~~~~~~~~~~~~~~~~ + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + DO ig=1,L_NGAUSS + DO jg=1, L_NGAUSS + ind = jg+(ig-1)*L_NGAUSS + ktwospec(ind) = krecomb(ig)+tmpk(jg) + ENDDO + ENDDO + + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ! 2. Resorting ~~~~~~~~~~~~~~~~~~~~~~~ + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + ! Pre-sort from last step ( we have always a similar regular pattern ) to gain time for sorting + ! NB : quite small array, quicker to permut with 2nd array than in place + DO ind=1,L_NGAUSS*L_NGAUSS + ktwospec_s(ind) = ktwospec(permut_idx(ind)) ! NB : won't do anything at firstcall + ENDDO + + CALL isort(ktwospec_s,L_NGAUSS*L_NGAUSS,permut_idx) ! Insertion sort quicker because pre-sorted + + ! Sort w according to permutations of k. + ! NB : quite small array, quicker to permut with 2nd array than in place + DO ind=1,L_NGAUSS*L_NGAUSS + wtwospec_s(ind) = wtwospec(permut_idx(ind)) + ENDDO + + wtwospec_cum(1) = wtwospec_s(1) + DO ind=2,L_NGAUSS*L_NGAUSS + wtwospec_cum(ind)= wtwospec_cum(ind-1)+wtwospec_s(ind) + ENDDO + + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ! 3. Rebinning on smaller amount of Gauss points ~~~~~~~~~~~ + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ibin=1 + + krecomb(:)=0.0 + + DO ig=1, L_NGAUSS-1 + + DO ind=ibin,L_NGAUSS*L_NGAUSS ! rather than a while + IF ( wtwospec_cum(ind) .GT. w_cum(ig) ) THEN + wsplit = w_cum(ig) - wtwospec_cum(ind-1) + krecomb(ig) = krecomb(ig) & + + sum ( wtwospec_s(ibin:ind-1)*ktwospec_s(ibin:ind-1) ) & + + wsplit*ktwospec_s(ind) + krecomb(ig+1) = (wtwospec_s(ind)-wsplit)*ktwospec_s(ind) + ibin=ind+1 + EXIT + ENDIF + ENDDO + + krecomb(L_NGAUSS) = krecomb(L_NGAUSS) + sum ( wtwospec_s(ibin:)*ktwospec_s(ibin:) ) + + ENDDO + + krecomb(1:L_NGAUSS-1) = krecomb(1:L_NGAUSS-1) / gweight(1:L_NGAUSS-1) ! gw(L_NGAUSS)=0 + + ENDDO ! ispec=1,nrecomb_qotf + gasv_recomb(it,ip,ix,iw,:) = krecomb(:) + ENDDO ! iw=1,L_NSPECTV + + useptx(it,ip,ix) = .false. + enddo ! ix=1,L_NTREF + enddo ! it=1,L_PINT + enddo ! ip=1,L_REFVAR + + END SUBROUTINE rad_correlatedk_online_recombination_mix + + SUBROUTINE rad_correlatedk_online_recombination_mix_allotf(igrid,pqr,useptx) + + USE radinc_h + USE radcommon_h, only: gweight, tlimit, gasi, gasv + USE sort_mod, only: isort + use comsaison_h, only: fract + + !----------------------------------------------------------------------- + ! Declarations: + ! ------------- + + IMPLICIT NONE + + ! Arguments : + ! ----------- + INTEGER, INTENT(IN) :: igrid ! lon-lat grid point + REAL*8, DIMENSION(nrecomb_qotf,L_PINT), INTENT(IN) :: pqr ! otf species mixing ration + LOGICAL, INTENT(INOUT) :: useptx(L_NTREF,L_PINT,L_REFVAR) ! Mask on which t-p-x ref grid point will be used + + ! Local variables : + ! ----------------- + INTEGER :: it, ip, ix, iw, ig, jg, ind, ibin, ispec + + REAL*8, DIMENSION(L_NGAUSS) :: tmpk ! otf correlated-k by mixing ratio + REAL*8, DIMENSION(L_NGAUSS) :: krecomb + + REAL*8, DIMENSION(L_NGAUSS*L_NGAUSS) :: ktwospec + REAL*8, DIMENSION(L_NGAUSS*L_NGAUSS) :: ktwospec_s + REAL*8, DIMENSION(L_NGAUSS*L_NGAUSS) :: wtwospec_s + REAL*8, DIMENSION(L_NGAUSS*L_NGAUSS) :: wtwospec_cum + + REAL*8 :: wsplit + + do ix=1,L_REFVAR + do ip=1,L_PINT + do it=1,L_NTREF + if (.not. useptx(it,ip,ix)) cycle + + ! ------------------- + ! I. INFRARED + ! ------------------- + + DO iw=1,L_NSPECTI + DO ig=1,L_NGAUSS ! init correlated-k with first gas + krecomb(ig) = pqr(1,ip)*gasi_otf(ig,1,iw,it,ip) + ENDDO + DO ispec=2,nrecomb_qotf ! Loop on additional species + + DO ig=1,L_NGAUSS + tmpk(ig) = pqr(ispec,ip)*gasi_otf(ig,ispec,iw,it,ip) + ENDDO + + ! Save ( a lot of ) CPU time, we don't add the specie if negligible absorption in the band + IF ( tmpk(L_NGAUSS-1) .LE. tlimit ) CYCLE + IF ( ALL( tmpk(1:L_NGAUSS-1) .LE. krecomb(1:L_NGAUSS-1)*0.01 ) ) CYCLE + IF ( ALL( krecomb(1:L_NGAUSS-1) .LE. tmpk(1:L_NGAUSS-1)*0.01 ) ) THEN + krecomb(1:L_NGAUSS-1) = tmpk(1:L_NGAUSS-1) + CYCLE + ENDIF + + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ! 1. Recombining ~~~~~~~~~~~~~~~~~~~~~~~~~ + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + DO ig=1,L_NGAUSS + DO jg=1, L_NGAUSS + ind = jg+(ig-1)*L_NGAUSS + ktwospec(ind) = krecomb(ig)+tmpk(jg) + ENDDO + ENDDO + + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ! 2. Resorting ~~~~~~~~~~~~~~~~~~~~~~~ + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + ! Pre-sort from last step ( we have always a similar regular pattern ) to gain time for sorting + ! NB : quite small array, quicker to permut with 2nd array than in place + DO ind=1,L_NGAUSS*L_NGAUSS + ktwospec_s(ind) = ktwospec(permut_idx(ind)) ! NB : won't do anything at firstcall + ENDDO + + CALL isort(ktwospec_s,L_NGAUSS*L_NGAUSS,permut_idx) ! Insertion sort quicker because pre-sorted + + ! Sort w according to permutations of k. + ! NB : quite small array, quicker to permut with 2nd array than in place + DO ind=1,L_NGAUSS*L_NGAUSS + wtwospec_s(ind) = wtwospec(permut_idx(ind)) + ENDDO + + wtwospec_cum(1) = wtwospec_s(1) + DO ind=2,L_NGAUSS*L_NGAUSS + wtwospec_cum(ind)= wtwospec_cum(ind-1)+wtwospec_s(ind) + ENDDO + + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ! 3. Rebinning on smaller amount of Gauss points ~~~~~~~~~~~ + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ibin=1 + + krecomb(:)=0.0 + + DO ig=1, L_NGAUSS-1 + + DO ind=ibin,L_NGAUSS*L_NGAUSS ! rather than a while + IF ( wtwospec_cum(ind) .GT. w_cum(ig) ) THEN + wsplit = w_cum(ig) - wtwospec_cum(ind-1) + krecomb(ig) = krecomb(ig) & + + sum ( wtwospec_s(ibin:ind-1)*ktwospec_s(ibin:ind-1) ) & + + wsplit*ktwospec_s(ind) + krecomb(ig+1) = (wtwospec_s(ind)-wsplit)*ktwospec_s(ind) + ibin=ind+1 + EXIT + ENDIF + ENDDO + + krecomb(L_NGAUSS) = krecomb(L_NGAUSS) + sum ( wtwospec_s(ibin:)*ktwospec_s(ibin:) ) + + ENDDO + + krecomb(1:L_NGAUSS-1) = krecomb(1:L_NGAUSS-1) / gweight(1:L_NGAUSS-1) ! gw(L_NGAUSS)=0 + + ENDDO ! ispec=1,nrecomb_qotf + gasi_recomb(it,ip,ix,iw,:) = krecomb(:) + ENDDO ! iw=1,L_NSPECTI + + ! ------------------- + ! II. VISIBLE + ! ------------------- + + if(fract(igrid) .lt. 1.0e-4) cycle ! Only during daylight. + + DO iw=1,L_NSPECTV + DO ig=1,L_NGAUSS ! init correlated-k with first gas + krecomb(ig) = pqr(1,ip)*gasv_otf(ig,1,iw,it,ip) + ENDDO + DO ispec=2,nrecomb_qotf ! Loop on additional species + + DO ig=1,L_NGAUSS + tmpk(ig) = pqr(ispec,ip)*gasv_otf(ig,ispec,iw,it,ip) + ENDDO + + ! Save ( a lot of ) CPU time, we don't add the specie if negligible absorption in the band + IF ( tmpk(L_NGAUSS-1) .LE. tlimit ) CYCLE + IF ( ALL( tmpk(1:L_NGAUSS-1) .LE. krecomb(1:L_NGAUSS-1)*0.01 ) ) CYCLE + IF ( ALL( krecomb(1:L_NGAUSS-1) .LE. tmpk(1:L_NGAUSS-1)*0.01 ) ) THEN + krecomb(1:L_NGAUSS-1) = tmpk(1:L_NGAUSS-1) + CYCLE + ENDIF + + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ! 1. Recombining ~~~~~~~~~~~~~~~~~~~~~~~~~ + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + DO ig=1,L_NGAUSS + DO jg=1, L_NGAUSS + ind = jg+(ig-1)*L_NGAUSS + ktwospec(ind) = krecomb(ig)+tmpk(jg) + ENDDO + ENDDO + + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ! 2. Resorting ~~~~~~~~~~~~~~~~~~~~~~~ + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + ! Pre-sort from last step ( we have always a similar regular pattern ) to gain time for sorting + ! NB : quite small array, quicker to permut with 2nd array than in place + DO ind=1,L_NGAUSS*L_NGAUSS + ktwospec_s(ind) = ktwospec(permut_idx(ind)) ! NB : won't do anything at firstcall + ENDDO + + CALL isort(ktwospec_s,L_NGAUSS*L_NGAUSS,permut_idx) ! Insertion sort quicker because pre-sorted + + ! Sort w according to permutations of k. + ! NB : quite small array, quicker to permut with 2nd array than in place + DO ind=1,L_NGAUSS*L_NGAUSS + wtwospec_s(ind) = wtwospec(permut_idx(ind)) + ENDDO + + wtwospec_cum(1) = wtwospec_s(1) + DO ind=2,L_NGAUSS*L_NGAUSS + wtwospec_cum(ind)= wtwospec_cum(ind-1)+wtwospec_s(ind) + ENDDO + + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ! 3. Rebinning on smaller amount of Gauss points ~~~~~~~~~~~ + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ibin=1 + + krecomb(:)=0.0 + + DO ig=1, L_NGAUSS-1 + + DO ind=ibin,L_NGAUSS*L_NGAUSS ! rather than a while + IF ( wtwospec_cum(ind) .GT. w_cum(ig) ) THEN + wsplit = w_cum(ig) - wtwospec_cum(ind-1) + krecomb(ig) = krecomb(ig) & + + sum ( wtwospec_s(ibin:ind-1)*ktwospec_s(ibin:ind-1) ) & + + wsplit*ktwospec_s(ind) + krecomb(ig+1) = (wtwospec_s(ind)-wsplit)*ktwospec_s(ind) + ibin=ind+1 + EXIT + ENDIF + ENDDO + + krecomb(L_NGAUSS) = krecomb(L_NGAUSS) + sum ( wtwospec_s(ibin:)*ktwospec_s(ibin:) ) + + ENDDO + + krecomb(1:L_NGAUSS-1) = krecomb(1:L_NGAUSS-1) / gweight(1:L_NGAUSS-1) ! gw(L_NGAUSS)=0 + + ENDDO ! ispec=1,nrecomb_qotf + gasv_recomb(it,ip,ix,iw,:) = krecomb(:) + ENDDO ! iw=1,L_NSPECTV + + useptx(it,ip,ix) = .false. + enddo ! ix=1,L_NTREF + enddo ! it=1,L_PINT + enddo ! ip=1,L_REFVAR + + END SUBROUTINE rad_correlatedk_online_recombination_mix_allotf + + END MODULE rad_correlatedk_online_recombination_mod + Index: trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_opacities_stellar.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_opacities_stellar.F90 (revision 4077) +++ trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_opacities_stellar.F90 (revision 4077) @@ -0,0 +1,411 @@ +MODULE rad_correlatedk_opacities_stellar_mod + +IMPLICIT NONE + +CONTAINS + +SUBROUTINE rad_correlatedk_opacities_stellar(DTAUV,TAUV,TAUCUMV,PLEV, & + QXVAER,QSVAER,GVAER,WBARV,COSBV, & + TAUAERO,TMID,PMID,TAUGSURF,QVAR,MUVAR,FRACVAR) + + use radinc_h, only: L_NLAYRAD, L_NLEVRAD, L_LEVELS, L_NSPECTV, L_NGAUSS, L_REFVAR, NAERKIND + use radcommon_h, only: gasv, tlimit, wrefVAR, Cmk, tgasref, pfgasref,wnov,scalep,glat_ig + use gases_h, only: gfrac, ngasmx, igas_H2, igas_H2O, igas_He, igas_N2, & + igas_CH4, igas_CO2, igas_O2 + use comcstfi_mod, only: g, r, mugaz + use callkeys_mod, only: kastprof,continuum,graybody,callgasvis,varspec, & + rayleigh + use rad_correlatedk_online_recombination_mod, only: corrk_recombin, gasv_recomb + use tpindex_mod, only: tpindex + use rad_correlatedk_continuum_interpolation_mod, only: rad_correlatedk_continuum_interpolation + use rad_correlatedk_rayleigh_scattering_opacity_mod, only: rad_correlatedk_rayleigh_scattering_opacity + + implicit none + + !================================================================== + ! + ! Purpose + ! ------- + ! Calculates shortwave optical constants at each level. + ! + ! Authors + ! ------- + ! Adapted from the NASA Ames code by R. Wordsworth (2009) + ! + !================================================================== + ! + ! THIS SUBROUTINE SETS THE OPTICAL CONSTANTS IN THE VISUAL + ! IT CALCULATES FOR EACH LAYER, FOR EACH SPECTRAL INTERVAL IN THE VISUAL + ! LAYER: WBAR, DTAU, COSBAR + ! LEVEL: TAU + ! + ! TAUV(L,NW,NG) is the cumulative optical depth at the top of radiation code + ! layer L. NW is spectral wavelength interval, ng the Gauss point index. + ! + ! TLEV(L) - Temperature at the layer boundary + ! PLEV(L) - Pressure at the layer boundary (i.e. level) + ! GASV(NT,NPS,NW,NG) - Visible k-coefficients + ! + !------------------------------------------------------------------- + + + real*8,intent(out) :: DTAUV(L_NLAYRAD,L_NSPECTV,L_NGAUSS) + real*8 DTAUKV(L_LEVELS,L_NSPECTV,L_NGAUSS) + real*8,intent(out) :: TAUV(L_NLEVRAD,L_NSPECTV,L_NGAUSS) + real*8,intent(out) :: TAUCUMV(L_LEVELS,L_NSPECTV,L_NGAUSS) + real*8,intent(in) :: PLEV(L_LEVELS) + real*8,intent(in) :: TMID(L_LEVELS), PMID(L_LEVELS) + real*8,intent(out) :: COSBV(L_NLAYRAD,L_NSPECTV,L_NGAUSS) + real*8,intent(out) :: WBARV(L_NLAYRAD,L_NSPECTV,L_NGAUSS) + + ! for aerosols + real*8,intent(in) :: QXVAER(L_LEVELS,L_NSPECTV,NAERKIND) + real*8,intent(in) :: QSVAER(L_LEVELS,L_NSPECTV,NAERKIND) + real*8,intent(in) :: GVAER(L_LEVELS,L_NSPECTV,NAERKIND) + real*8,intent(in) :: TAUAERO(L_LEVELS,NAERKIND) + + ! local arrays (saved for convenience as need be allocated) + real*8,save,allocatable :: TAUAEROLK(:,:,:) + real*8,save,allocatable :: TAEROS(:,:,:) +!$OMP THREADPRIVATE(TAUAEROLK,TAEROS) + + integer L, NW, NG, K, LK, IAER + integer MT(L_LEVELS), MP(L_LEVELS), NP(L_LEVELS) + real*8 ANS, TAUGAS + real*8 TAURAY(L_LEVELS,L_NSPECTV) + real*8 TRAY(L_LEVELS,L_NSPECTV) + real*8 DPR(L_LEVELS), U(L_LEVELS) + real*8 LCOEF(4), LKCOEF(L_LEVELS,4) + + real*8,intent(out) :: taugsurf(L_NSPECTV,L_NGAUSS-1) + real*8 DCONT,DAERO + real*8 DRAYAER + double precision wn_cont, p_cont, p_air, T_cont, dtemp, dtempc + double precision p_cross + + ! variable species mixing ratio variables + real*8,intent(in) :: QVAR(L_LEVELS) + real*8,intent(in) :: MUVAR(L_LEVELS) + real*8,intent(in) :: FRACVAR(ngasmx,L_LEVELS) + real*8 :: WRATIO(L_LEVELS) + real*8 KCOEF(4) + integer NVAR(L_LEVELS) + + ! temporary variables to reduce memory access time to gasv + real*8 tmpk(2,2) + real*8 tmpkvar(2,2,2) + + ! temporary variables for multiple aerosol calculation + real*8 atemp(L_NLAYRAD,L_NSPECTV) + real*8 btemp(L_NLAYRAD,L_NSPECTV) + real*8 ctemp(L_NLAYRAD,L_NSPECTV) + + ! variables for k in units m^-1 + real*8 dz(L_LEVELS) + + + integer igas, jgas + + logical :: firstcall=.true. +!$OMP THREADPRIVATE(firstcall) + + if (firstcall) then + ! allocate local arrays of size "naerkind" (which are also + ! "saved" so that this is done only once in for all even if + ! we don't need to store the value from a time step to the next) + allocate(TAUAEROLK(L_LEVELS,L_NSPECTV,NAERKIND)) + allocate(TAEROS(L_LEVELS,L_NSPECTV,NAERKIND)) + firstcall=.false. + endif ! of if (firstcall) + + !======================================================================= + ! Determine the total gas opacity throughout the column, for each + ! spectral interval, NW, and each Gauss point, NG. + ! Calculate the continuum opacities, i.e., those that do not depend on + ! NG, the Gauss index. + + taugsurf(:,:) = 0.0 + dpr(:) = 0.0 + lkcoef(:,:) = 0.0 + + do K=2,L_LEVELS + DPR(k) = PLEV(K)-PLEV(K-1) + + ! if we have continuum opacities, we need dz + if(kastprof)then + dz(k) = dpr(k)*(1000.0d0*8.314463d0/muvar(k))*TMID(K)/(g*PMID(K)) + U(k) = Cmk*DPR(k)*mugaz/muvar(k) + else + dz(k) = dpr(k)*R*TMID(K)/(glat_ig*PMID(K))*mugaz/muvar(k) + U(k) = Cmk*DPR(k)*mugaz/muvar(k) ! only Cmk line in rad_correlatedk_opacities_thermal.F + !JL13 the mugaz/muvar factor takes into account water meanmolecular weight if water is present + endif + + call tpindex(PMID(K),TMID(K),QVAR(K),pfgasref,tgasref,WREFVAR, & + LCOEF,MT(K),MP(K),NVAR(K),WRATIO(K)) + + do LK=1,4 + LKCOEF(K,LK) = LCOEF(LK) + end do + end do ! levels + + ! Spectral dependance of aerosol absorption + !JL18 It seems to be good to have aerosols in the first "radiative layer" of the gcm in the IR + ! but visible does not handle very well diffusion in first layer. + ! The tauaero and tauray are thus set to 0 (a small value for rayleigh because the code crashes otherwise) + ! in the 4 first semilayers in rad_correlatedk_opacities_stellar, but not rad_correlatedk_opacities_thermal. + ! This solves random variations of the sw heating at the model top. + do iaer=1,naerkind + do NW=1,L_NSPECTV + TAEROS(1:4,NW,IAER)=0.d0 + do K=5,L_LEVELS + TAEROS(K,NW,IAER) = TAUAERO(K,IAER) * QXVAER(K,NW,IAER) + end do ! levels + end do + end do + +!======================================================================= +! Set up the wavelength independent part of the Rayleigh scattering. +! WAVEV is in microns. There is no Rayleigh scattering in the IR. + + if(rayleigh) then + call rad_correlatedk_rayleigh_scattering_opacity(QVAR,MUVAR,PMID,TMID,TAURAY) + else + print*,'rad_correlatedk_init_stellar: No Rayleigh scattering, check for NaN in output!' + do NW=1,L_NSPECTV + TAURAY(:,NW) = 1E-16 + end do + endif + + ! Computation of pressure dependant part of Rayleigh scattering + do NW=1,L_NSPECTV + TRAY(1:4,NW) = 1d-30 + do K=5,L_LEVELS + TRAY(K,NW) = TAURAY(K,NW) * DPR(K) + end do ! levels + end do + + ! we ignore K=1... + + do K=2,L_LEVELS + + do NW=1,L_NSPECTV + + DRAYAER = TRAY(K,NW) + ! DRAYAER is Tau RAYleigh scattering, plus AERosol opacity + do iaer=1,naerkind + DRAYAER = DRAYAER + TAEROS(K,NW,IAER) + end do + + DCONT = 0.0 ! continuum absorption + + if(continuum.and.(.not.graybody).and.callgasvis)then + ! include continua if necessary + + T_cont = dble(TMID(k)) + do igas=1,ngasmx + + if(gfrac(igas).eq.-1)then ! variable + p_cont = dble(PMID(k)*scalep*QVAR(k)) ! qvar = mol/mol + elseif(varspec) then + p_cont = dble(PMID(k)*scalep*FRACVAR(igas,k)*(1.-QVAR(k))) + else + p_cont = dble(PMID(k)*scalep*gfrac(igas)*(1.-QVAR(k))) + endif + + do jgas=1,ngasmx + if(gfrac(jgas).eq.-1)then ! variable + p_cross = dble(PMID(k)*scalep*QVAR(k)) ! qvar = mol/mol + elseif(varspec) then + p_cross = dble(PMID(k)*scalep*FRACVAR(jgas,k)*(1.-QVAR(k))) + else + p_cross = dble(PMID(k)*scalep*gfrac(jgas)*(1.-QVAR(k))) + endif + + dtemp=0.0 + + if ( ((igas .eq. igas_N2) .and. (jgas .eq. igas_N2)) .or. & + ((igas .eq. igas_N2) .and. (jgas .eq. igas_H2)) .or. & + ((igas .eq. igas_N2) .and. (jgas .eq. igas_O2)) .or. & + ((igas .eq. igas_N2) .and. (jgas .eq. igas_CH4)) .or. & + ((igas .eq. igas_O2) .and. (jgas .eq. igas_O2)) .or. & + ((igas .eq. igas_CO2) .and. (jgas .eq. igas_O2)) .or. & + ((igas .eq. igas_H2) .and. (jgas .eq. igas_H2)) .or. & + ((igas .eq. igas_H2) .and. (jgas .eq. igas_CH4)) .or. & + ((igas .eq. igas_H2) .and. (jgas .eq. igas_He)) .or. & + ((igas .eq. igas_CH4) .and. (jgas .eq. igas_CH4)) .or. & + ((igas .eq. igas_H2O) .and. (jgas .eq. igas_H2O)) .or. & + ((igas .eq. igas_H2O) .and. (jgas .eq. igas_N2)) .or. & + ((igas .eq. igas_H2O) .and. (jgas .eq. igas_O2)) .or. & + ((igas .eq. igas_H2O) .and. (jgas .eq. igas_CO2)) .or. & + ((igas .eq. igas_CO2) .and. (jgas .eq. igas_CO2)) .or. & + ((igas .eq. igas_CO2) .and. (jgas .eq. igas_H2)) .or. & + ((igas .eq. igas_CO2) .and. (jgas .eq. igas_CH4)) ) then + + call rad_correlatedk_continuum_interpolation('',igas,jgas,'VI',nw,T_cont,p_cont,p_cross,dtemp,.false.) + + endif + + DCONT = DCONT + dtemp + + enddo ! jgas=1,ngasmx + + enddo ! igas=1,ngasmx + + DCONT = DCONT*dz(k) + + endif ! continuum + + do ng=1,L_NGAUSS-1 + + ! Now compute TAUGAS + + ! Interpolate between water mixing ratios + ! WRATIO = 0.0 if the requested water amount is equal to, or outside the + ! the water data range + + if(L_REFVAR.eq.1)then ! added by RW for special no variable case + + ! JVO 2017 : added tmpk because the repeated calls to gasi/v increased dramatically + ! the execution time of rad_correlatedk_opacities_thermal/v -> ~ factor 2 on the whole radiative + ! transfer on the tested simulations ! + + IF (corrk_recombin) THEN ! Added by JVO + tmpk = GASV_RECOMB(MT(K):MT(K)+1,MP(K):MP(K)+1,1,NW,NG) ! contains the mix of recombined species + ELSE + tmpk = GASV(MT(K):MT(K)+1,MP(K):MP(K)+1,1,NW,NG) + ENDIF + + KCOEF(1) = tmpk(1,1) ! KCOEF(1) = GASV(MT(K),MP(K),1,NW,NG) + KCOEF(2) = tmpk(1,2) ! KCOEF(2) = GASV(MT(K),MP(K)+1,1,NW,NG) + KCOEF(3) = tmpk(2,2) ! KCOEF(3) = GASV(MT(K)+1,MP(K)+1,1,NW,NG) + KCOEF(4) = tmpk(2,1) ! KCOEF(4) = GASV(MT(K)+1,MP(K),1,NW,NG) + + else + + IF (corrk_recombin) THEN + tmpkvar = GASV_RECOMB(MT(K):MT(K)+1,MP(K):MP(K)+1,NVAR(K):NVAR(K)+1,NW,NG) + ELSE + tmpkvar = GASV(MT(K):MT(K)+1,MP(K):MP(K)+1,NVAR(K):NVAR(K)+1,NW,NG) + ENDIF + + KCOEF(1) = tmpkvar(1,1,1) + WRATIO(K) * & + ( tmpkvar(1,1,2)-tmpkvar(1,1,1) ) + + KCOEF(2) = tmpkvar(1,2,1) + WRATIO(K) * & + ( tmpkvar(1,2,2)-tmpkvar(1,2,1) ) + + KCOEF(3) = tmpkvar(2,2,1) + WRATIO(K) * & + ( tmpkvar(2,2,2)-tmpkvar(2,2,1) ) + + KCOEF(4) = tmpkvar(2,1,1) + WRATIO(K) * & + ( tmpkvar(2,1,2)-tmpkvar(2,1,1) ) + + + endif + + ! Interpolate the gaseous k-coefficients to the requested T,P values + + ANS = LKCOEF(K,1)*KCOEF(1) + LKCOEF(K,2)*KCOEF(2) + & + LKCOEF(K,3)*KCOEF(3) + LKCOEF(K,4)*KCOEF(4) + + TAUGAS = U(k)*ANS + + TAUGSURF(NW,NG) = TAUGSURF(NW,NG) + TAUGAS + DCONT + DTAUKV(K,nw,ng) = TAUGAS & + + DRAYAER & ! DRAYAER includes all scattering contributions + + DCONT ! For parameterized continuum aborption + + end do + + ! Now fill in the "clear" part of the spectrum (NG = L_NGAUSS), + ! which holds continuum opacity only + + NG = L_NGAUSS + DTAUKV(K,nw,ng) = DRAYAER + DCONT ! Scattering + parameterized continuum absorption + + end do + end do + + !======================================================================= + ! Now the full treatment for the layers, where besides the opacity + ! we need to calculate the scattering albedo and asymmetry factors + + !JL18 It seems to be good to have aerosols in the first "radiative layer" of the gcm in the IR + ! but not in the visible + ! The tauaero is thus set to 0 in the 4 first semilayers in rad_correlatedk_opacities_stellar, but not rad_correlatedk_opacities_thermal. + ! This solves random variations of the sw heating at the model top. + do iaer=1,naerkind + DO NW=1,L_NSPECTV + TAUAEROLK(1:4,NW,IAER)=0.d0 + DO K=5,L_LEVELS + TAUAEROLK(K,NW,IAER) = TAUAERO(K,IAER) * QSVAER(K,NW,IAER) ! effect of scattering albedo + ENDDO + ENDDO + end do + + DO NW=1,L_NSPECTV + DO L=1,L_NLAYRAD-1 + K = 2*L+1 + atemp(L,NW) = SUM(GVAER(K,NW,1:naerkind) * TAUAEROLK(K,NW,1:naerkind))+SUM(GVAER(K+1,NW,1:naerkind) * TAUAEROLK(K+1,NW,1:naerkind)) + btemp(L,NW) = SUM(TAUAEROLK(K,NW,1:naerkind)) + SUM(TAUAEROLK(K+1,NW,1:naerkind)) + ctemp(L,NW) = btemp(L,NW) + 0.9999*(TRAY(K,NW) + TRAY(K+1,NW)) ! JVO 2017 : does this 0.999 is really meaningful ? + btemp(L,NW) = btemp(L,NW) + TRAY(K,NW) + TRAY(K+1,NW) + COSBV(L,NW,1:L_NGAUSS) = atemp(L,NW)/btemp(L,NW) + END DO ! L vertical loop + + ! Last level + L = L_NLAYRAD + K = 2*L+1 + atemp(L,NW) = SUM(GVAER(K,NW,1:naerkind) * TAUAEROLK(K,NW,1:naerkind)) + btemp(L,NW) = SUM(TAUAEROLK(K,NW,1:naerkind)) + ctemp(L,NW) = btemp(L,NW) + 0.9999*TRAY(K,NW) ! JVO 2017 : does this 0.999 is really meaningful ? + btemp(L,NW) = btemp(L,NW) + TRAY(K,NW) + COSBV(L,NW,1:L_NGAUSS) = atemp(L,NW)/btemp(L,NW) + + + END DO ! NW spectral loop + + DO NG=1,L_NGAUSS + DO NW=1,L_NSPECTV + DO L=1,L_NLAYRAD-1 + + K = 2*L+1 + DTAUV(L,nw,ng) = DTAUKV(K,NW,NG) + DTAUKV(K+1,NW,NG) + WBARV(L,nw,ng) = ctemp(L,NW) / DTAUV(L,nw,ng) + + END DO ! L vertical loop + + ! Last level + + L = L_NLAYRAD + K = 2*L+1 + DTAUV(L,nw,ng) = DTAUKV(K,NW,NG) + + WBARV(L,NW,NG) = ctemp(L,NW) / DTAUV(L,NW,NG) + + END DO ! NW spectral loop + END DO ! NG Gauss loop + + ! Total extinction optical depths + + DO NG=1,L_NGAUSS ! full gauss loop + DO NW=1,L_NSPECTV + TAUCUMV(1,NW,NG)=0.0D0 + DO K=2,L_LEVELS + TAUCUMV(K,NW,NG)=TAUCUMV(K-1,NW,NG)+DTAUKV(K,NW,NG) + END DO + + DO L=1,L_NLAYRAD + TAUV(L,NW,NG)=TAUCUMV(2*L,NW,NG) + END DO + TAUV(L,NW,NG)=TAUCUMV(2*L_NLAYRAD+1,NW,NG) + END DO + END DO ! end full gauss loop + + + + +end subroutine rad_correlatedk_opacities_stellar + +END MODULE rad_correlatedk_opacities_stellar_mod Index: trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_opacities_thermal.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_opacities_thermal.F90 (revision 4077) +++ trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_opacities_thermal.F90 (revision 4077) @@ -0,0 +1,462 @@ +MODULE rad_correlatedk_opacities_thermal_mod + +IMPLICIT NONE + +CONTAINS + +subroutine rad_correlatedk_opacities_thermal(PLEV,TLEV,DTAUI,TAUCUMI, & + QXIAER,QSIAER,GIAER,COSBI,WBARI,TAUAERO, & + TMID,PMID,TAUGSURF,QVAR,MUVAR,FRACVAR) + + use radinc_h, only: L_LEVELS, L_NLAYRAD, L_NSPECTI, L_NGAUSS, & + L_NLEVRAD, L_REFVAR, naerkind + use radcommon_h, only: gasi,tlimit,wrefVAR,Cmk,tgasref,pfgasref,wnoi,scalep,glat_ig + use gases_h, only: gfrac, ngasmx, igas_N2, igas_He, igas_H2O, igas_H2, & + igas_CH4, igas_CO2, igas_O2 + use comcstfi_mod, only: g, r, mugaz + use callkeys_mod, only: kastprof,continuum,graybody,varspec + use rad_correlatedk_online_recombination_mod, only: corrk_recombin, gasi_recomb + use tpindex_mod, only: tpindex + use rad_correlatedk_continuum_interpolation_mod, only: rad_correlatedk_continuum_interpolation + + implicit none + + !================================================================== + ! + ! Purpose + ! ------- + ! Calculates longwave optical constants at each level. For each + ! layer and spectral interval in the IR it calculates WBAR, DTAU + ! and COSBAR. For each level it calculates TAU. + ! + ! TAUCUMI(L,LW) is the cumulative optical depth at level L (or alternatively + ! at the *bottom* of layer L), LW is the spectral wavelength interval. + ! + ! TLEV(L) - Temperature at the layer boundary (i.e., level) + ! PLEV(L) - Pressure at the layer boundary (i.e., level) + ! + ! Authors + ! ------- + ! Adapted from the NASA Ames code by R. Wordsworth (2009) + ! + !================================================================== + + + real*8,intent(out) :: DTAUI(L_NLAYRAD,L_NSPECTI,L_NGAUSS) + real*8 DTAUKI(L_LEVELS,L_NSPECTI,L_NGAUSS) + real*8 TAUI(L_NLEVRAD,L_NSPECTI,L_NGAUSS) + real*8,intent(out) :: TAUCUMI(L_LEVELS,L_NSPECTI,L_NGAUSS) + real*8,intent(in) :: PLEV(L_LEVELS) + real*8,intent(in) :: TLEV(L_LEVELS) ! not used + real*8,intent(in) :: TMID(L_LEVELS) + real*8,intent(in) :: PMID(L_LEVELS) + real*8,intent(out) :: COSBI(L_NLAYRAD,L_NSPECTI,L_NGAUSS) + real*8,intent(out) :: WBARI(L_NLAYRAD,L_NSPECTI,L_NGAUSS) + + ! for aerosols + real*8,intent(in) :: QXIAER(L_LEVELS,L_NSPECTI,NAERKIND) + real*8,intent(in) :: QSIAER(L_LEVELS,L_NSPECTI,NAERKIND) + real*8,intent(in) :: GIAER(L_LEVELS,L_NSPECTI,NAERKIND) + real*8,intent(in) :: TAUAERO(L_LEVELS,NAERKIND) + + ! local variables (saved for convenience as need be allocated) + real*8,save,allocatable :: TAUAEROLK(:,:,:) + real*8,save,allocatable :: TAEROS(:,:,:) +!$OMP THREADPRIVATE(TAUAEROLK,TAEROS) + + integer L, NW, NG, K, LK, IAER + integer MT(L_LEVELS), MP(L_LEVELS), NP(L_LEVELS) + real*8 ANS, TAUGAS + real*8 DPR(L_LEVELS), U(L_LEVELS) + real*8 LCOEF(4), LKCOEF(L_LEVELS,4) + + real*8,intent(out) :: taugsurf(L_NSPECTI,L_NGAUSS-1) + real*8 DCONT,DAERO + double precision wn_cont, p_cont, p_air, T_cont, dtemp, dtempc + double precision p_cross + + ! variable species mixing ratio variables + real*8,intent(in) :: QVAR(L_LEVELS) + real*8,intent(in) :: MUVAR(L_LEVELS) + real*8,intent(in) :: FRACVAR(ngasmx,L_LEVELS) + real*8 WRATIO(L_LEVELS) + real*8 KCOEF(4) + integer NVAR(L_LEVELS) + + ! temporary variables to reduce memory access time to gasi + real*8 tmpk(2,2) + real*8 tmpkvar(2,2,2) + + ! temporary variables for multiple aerosol calculation + real*8 atemp + real*8 btemp(L_NLAYRAD,L_NSPECTI) + + ! variables for k in units m^-1 + real*8 dz(L_LEVELS) + !real*8 rho !! see test below + + integer igas, jgas + + logical :: firstcall=.true. +!$OMP THREADPRIVATE(firstcall) + + !--- Kasting's CIA ---------------------------------------- + !real*8, parameter :: Ci(L_NSPECTI)=[ & + ! 3.8E-5, 1.2E-5, 2.8E-6, 7.6E-7, 4.5E-7, 2.3E-7, & + ! 5.4E-7, 1.6E-6, 0.0, & + ! 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & + ! 0.0, 4.0E-7, 4.0E-6, 1.4E-5, & + ! 1.0E-5, 1.2E-6, 2.0E-7, 5.0E-8, 3.0E-8, 0.0 ] + !real*8, parameter :: Ti(L_NSPECTI)=[ -2.2, -1.9, & + ! -1.7, -1.7, -1.7, -1.7, -1.7, -1.7, & + ! 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & + ! -1.7,-1.7,-1.7,-1.7,-1.7,-1.7,-1.7, -1.7,0.0 ] + !---------------------------------------------------------- + + if (firstcall) then + ! allocate local arrays of size "naerkind" (which are also + ! "saved" so that this is done only once in for all even if + ! we don't need to store the value from a time step to the next) + allocate(TAUAEROLK(L_LEVELS,L_NSPECTI,NAERKIND)) + allocate(TAEROS(L_LEVELS,L_NSPECTI,NAERKIND)) + firstcall=.false. + endif ! of if (firstcall) + + !======================================================================= + ! Determine the total gas opacity throughout the column, for each + ! spectral interval, NW, and each Gauss point, NG. + + taugsurf(:,:) = 0.0 + dpr(:) = 0.0 + lkcoef(:,:) = 0.0 + + do K=2,L_LEVELS + DPR(k) = PLEV(K)-PLEV(K-1) + + !--- Kasting's CIA ---------------------------------------- + !dz(k)=dpr(k)*189.02*TMID(K)/(0.03720*PMID(K)) + ! this is CO2 path length (in cm) as written by Francois + ! delta_z = delta_p * R_specific * T / (g * P) + ! But Kasting states that W is in units of _atmosphere_ cm + ! So we do + !dz(k)=dz(k)*(PMID(K)/1013.25) + !dz(k)=dz(k)/100.0 ! in m for SI calc + !---------------------------------------------------------- + + ! if we have continuum opacities, we need dz + if(kastprof)then + dz(k) = dpr(k)*(1000.0d0*8.314463d0/muvar(k))*TMID(K)/(g*PMID(K)) + U(k) = Cmk*DPR(k)*mugaz/muvar(k) + else + dz(k) = dpr(k)*R*TMID(K)/(glat_ig*PMID(K))*mugaz/muvar(k) + U(k) = Cmk*DPR(k)*mugaz/muvar(k) ! only Cmk line in rad_correlatedk_opacities_thermal.F + !JL13 the mugaz/muvar factor takes into account water meanmolecular weight if water is present + endif + + call tpindex(PMID(K),TMID(K),QVAR(K),pfgasref,tgasref,WREFVAR, & + LCOEF,MT(K),MP(K),NVAR(K),WRATIO(K)) + + do LK=1,4 + LKCOEF(K,LK) = LCOEF(LK) + end do + end do ! levels + + ! Spectral dependance of aerosol absorption + do iaer=1,naerkind + DO NW=1,L_NSPECTI + do K=2,L_LEVELS + TAEROS(K,NW,IAER) = TAUAERO(K,IAER) * QXIAER(K,NW,IAER) + end do ! levels + END DO + end do + + do NW=1,L_NSPECTI + + do K=2,L_LEVELS + + DAERO=SUM(TAEROS(K,NW,1:naerkind)) ! aerosol absorption + + DCONT = 0.0d0 ! continuum absorption + + if(continuum.and.(.not.graybody))then + ! include continua if necessary + + T_cont = dble(TMID(k)) + do igas=1,ngasmx + + if(gfrac(igas).eq.-1)then ! variable + p_cont = dble(PMID(k)*scalep*QVAR(k)) ! qvar = mol/mol + elseif(varspec) then + p_cont = dble(PMID(k)*scalep*FRACVAR(igas,k)*(1.-QVAR(k))) + else + p_cont = dble(PMID(k)*scalep*gfrac(igas)*(1.-QVAR(k))) + endif + + do jgas=1,ngasmx + if(gfrac(jgas).eq.-1)then ! variable + p_cross = dble(PMID(k)*scalep*QVAR(k)) ! qvar = mol/mol + elseif(varspec) then + p_cross = dble(PMID(k)*scalep*FRACVAR(jgas,k)*(1.-QVAR(k))) + else + p_cross = dble(PMID(k)*scalep*gfrac(jgas)*(1.-QVAR(k))) + endif + + dtemp=0.0 + + if ( ((igas .eq. igas_N2) .and. (jgas .eq. igas_N2)) .or. & + ((igas .eq. igas_N2) .and. (jgas .eq. igas_H2)) .or. & + ((igas .eq. igas_N2) .and. (jgas .eq. igas_O2)) .or. & + ((igas .eq. igas_N2) .and. (jgas .eq. igas_CH4)) .or. & + ((igas .eq. igas_O2) .and. (jgas .eq. igas_O2)) .or. & + ((igas .eq. igas_CO2) .and. (jgas .eq. igas_O2)) .or. & + ((igas .eq. igas_H2) .and. (jgas .eq. igas_H2)) .or. & + ((igas .eq. igas_H2) .and. (jgas .eq. igas_CH4)) .or. & + ((igas .eq. igas_H2) .and. (jgas .eq. igas_He)) .or. & + ((igas .eq. igas_CH4) .and. (jgas .eq. igas_CH4)) .or. & + ((igas .eq. igas_H2O) .and. (jgas .eq. igas_H2O)) .or. & + ((igas .eq. igas_H2O) .and. (jgas .eq. igas_N2)) .or. & + ((igas .eq. igas_H2O) .and. (jgas .eq. igas_O2)) .or. & + ((igas .eq. igas_H2O) .and. (jgas .eq. igas_CO2)) .or. & + ((igas .eq. igas_CO2) .and. (jgas .eq. igas_CO2)) .or. & + ((igas .eq. igas_CO2) .and. (jgas .eq. igas_H2)) .or. & + ((igas .eq. igas_CO2) .and. (jgas .eq. igas_CH4)) ) then + + call rad_correlatedk_continuum_interpolation('',igas,jgas,'IR',nw,T_cont,p_cont,p_cross,dtemp,.false.) + + endif + + DCONT = DCONT + dtemp + + enddo ! jgas=1,ngasmx + + enddo ! igas=1,ngasmx + + DCONT = DCONT*dz(k) + + endif ! continuum + + do ng=1,L_NGAUSS-1 + + ! Now compute TAUGAS + + ! Interpolate between water mixing ratios + ! WRATIO = 0.0 if the requested water amount is equal to, or outside the + ! the water data range + + if(L_REFVAR.eq.1)then ! added by RW for special no variable case + + ! JVO 2017 : added tmpk because the repeated calls to gasi/v increased dramatically + ! the execution time of rad_correlatedk_opacities_thermal/v -> ~ factor 2 on the whole radiative + ! transfer on the tested simulations ! + + IF (corrk_recombin) THEN ! added by JVO + tmpk = GASI_RECOMB(MT(K):MT(K)+1,MP(K):MP(K)+1,1,NW,NG) ! contains the mix of recombined species + ELSE + tmpk = GASI(MT(K):MT(K)+1,MP(K):MP(K)+1,1,NW,NG) + ENDIF + + KCOEF(1) = tmpk(1,1) ! KCOEF(1) = GASI(MT(K),MP(K),1,NW,NG) + KCOEF(2) = tmpk(1,2) ! KCOEF(2) = GASI(MT(K),MP(K)+1,1,NW,NG) + KCOEF(3) = tmpk(2,2) ! KCOEF(3) = GASI(MT(K)+1,MP(K)+1,1,NW,NG) + KCOEF(4) = tmpk(2,1) ! KCOEF(4) = GASI(MT(K)+1,MP(K),1,NW,NG) + + else + + IF (corrk_recombin) THEN ! added by JVO + tmpkvar = GASI_RECOMB(MT(K):MT(K)+1,MP(K):MP(K)+1,NVAR(K):NVAR(K)+1,NW,NG) + ELSE + tmpkvar = GASI(MT(K):MT(K)+1,MP(K):MP(K)+1,NVAR(K):NVAR(K)+1,NW,NG) + ENDIF + + KCOEF(1) = tmpkvar(1,1,1) + WRATIO(K) * & + ( tmpkvar(1,1,2)-tmpkvar(1,1,1) ) + + KCOEF(2) = tmpkvar(1,2,1) + WRATIO(K) * & + ( tmpkvar(1,2,2)-tmpkvar(1,2,1) ) + + KCOEF(3) = tmpkvar(2,2,1) + WRATIO(K) * & + ( tmpkvar(2,2,2)-tmpkvar(2,2,1) ) + + KCOEF(4) = tmpkvar(2,1,1) + WRATIO(K) * & + ( tmpkvar(2,1,2)-tmpkvar(2,1,1) ) + + endif + + ! Interpolate the gaseous k-coefficients to the requested T,P values + + ANS = LKCOEF(K,1)*KCOEF(1) + LKCOEF(K,2)*KCOEF(2) + & + LKCOEF(K,3)*KCOEF(3) + LKCOEF(K,4)*KCOEF(4) + + TAUGAS = U(k)*ANS + + TAUGSURF(NW,NG) = TAUGSURF(NW,NG) + TAUGAS + DCONT + DTAUKI(K,nw,ng) = TAUGAS & + + DCONT & ! For parameterized continuum absorption + + DAERO ! For aerosol absorption + + end do + + ! Now fill in the "clear" part of the spectrum (NG = L_NGAUSS), + ! which holds continuum opacity only + + NG = L_NGAUSS + DTAUKI(K,nw,ng) = 0.d0 & + + DCONT & ! For parameterized continuum absorption + + DAERO ! For aerosol absorption + + end do + end do + + !======================================================================= + ! Now the full treatment for the layers, where besides the opacity + ! we need to calculate the scattering albedo and asymmetry factors + + do iaer=1,naerkind + DO NW=1,L_NSPECTI + DO K=2,L_LEVELS + TAUAEROLK(K,NW,IAER) = TAUAERO(K,IAER)*QSIAER(K,NW,IAER) ! effect of scattering albedo + ENDDO + ENDDO + end do + + DO NW=1,L_NSPECTI + DO L=1,L_NLAYRAD-1 + K = 2*L+1 + btemp(L,NW) = SUM(TAUAEROLK(K,NW,1:naerkind)) + SUM(TAUAEROLK(K+1,NW,1:naerkind)) + END DO ! L vertical loop + + ! Last level + L = L_NLAYRAD + K = 2*L+1 + btemp(L,NW) = SUM(TAUAEROLK(K,NW,1:naerkind)) + + END DO ! NW spectral loop + + + DO NW=1,L_NSPECTI + NG = L_NGAUSS + DO L=1,L_NLAYRAD-1 + + K = 2*L+1 + DTAUI(L,nw,ng) = DTAUKI(K,NW,NG) + DTAUKI(K+1,NW,NG)! + 1.e-50 + + atemp = 0. + if(DTAUI(L,NW,NG) .GT. 1.0D-9) then + do iaer=1,naerkind + atemp = atemp + & + GIAER(K,NW,IAER) * TAUAEROLK(K,NW,IAER) + & + GIAER(K+1,NW,IAER) * TAUAEROLK(K+1,NW,IAER) + end do + WBARI(L,nw,ng) = btemp(L,nw) / DTAUI(L,NW,NG) + else + WBARI(L,nw,ng) = 0.0D0 + DTAUI(L,NW,NG) = 1.0D-9 + endif + + if(btemp(L,nw) .GT. 0.0d0) then + cosbi(L,NW,NG) = atemp/btemp(L,nw) + else + cosbi(L,NW,NG) = 0.0D0 + end if + + END DO ! L vertical loop + + ! Last level + + L = L_NLAYRAD + K = 2*L+1 + DTAUI(L,nw,ng) = DTAUKI(K,NW,NG) ! + 1.e-50 + + atemp = 0. + if(DTAUI(L,NW,NG) .GT. 1.0D-9) then + do iaer=1,naerkind + atemp = atemp + GIAER(K,NW,IAER) * TAUAEROLK(K,NW,IAER) + end do + WBARI(L,nw,ng) = btemp(L,nw) / DTAUI(L,NW,NG) + else + WBARI(L,nw,ng) = 0.0D0 + DTAUI(L,NW,NG) = 1.0D-9 + endif + + if(btemp(L,nw) .GT. 0.0d0) then + cosbi(L,NW,NG) = atemp/btemp(L,nw) + else + cosbi(L,NW,NG) = 0.0D0 + end if + + + ! Now the other Gauss points, if needed. + + DO NG=1,L_NGAUSS-1 + IF(TAUGSURF(NW,NG) .gt. TLIMIT) THEN + + DO L=1,L_NLAYRAD-1 + K = 2*L+1 + DTAUI(L,nw,ng) = DTAUKI(K,NW,NG)+DTAUKI(K+1,NW,NG)! + 1.e-50 + + if(DTAUI(L,NW,NG) .GT. 1.0D-9) then + + WBARI(L,nw,ng) = btemp(L,nw) / DTAUI(L,NW,NG) + + else + WBARI(L,nw,ng) = 0.0D0 + DTAUI(L,NW,NG) = 1.0D-9 + endif + + cosbi(L,NW,NG) = cosbi(L,NW,L_NGAUSS) + END DO ! L vertical loop + + ! Last level + L = L_NLAYRAD + K = 2*L+1 + DTAUI(L,nw,ng) = DTAUKI(K,NW,NG)! + 1.e-50 + + if(DTAUI(L,NW,NG) .GT. 1.0D-9) then + + WBARI(L,nw,ng) = btemp(L,nw) / DTAUI(L,NW,NG) + + else + WBARI(L,nw,ng) = 0.0D0 + DTAUI(L,NW,NG) = 1.0D-9 + endif + + cosbi(L,NW,NG) = cosbi(L,NW,L_NGAUSS) + + END IF + + END DO ! NG Gauss loop + END DO ! NW spectral loop + + ! Total extinction optical depths + + DO NG=1,L_NGAUSS ! full gauss loop + DO NW=1,L_NSPECTI + TAUCUMI(1,NW,NG)=0.0D0 + DO K=2,L_LEVELS + TAUCUMI(K,NW,NG)=TAUCUMI(K-1,NW,NG)+DTAUKI(K,NW,NG) + END DO + END DO ! end full gauss loop + END DO + + ! be aware when comparing with textbook results + ! (e.g. Pierrehumbert p. 218) that + ! taucumi does not take the =0.5 factor into + ! account. It is the optical depth for a vertically + ! ascending ray with angle theta = 0. + + !open(127,file='taucum.out') + !do nw=1,L_NSPECTI + ! write(127,*) taucumi(L_LEVELS,nw,L_NGAUSS) + !enddo + !close(127) + +! print*,'WBARI' +! print*,WBARI +! print*,'DTAUI' +! print*,DTAUI +! call abort + +end subroutine rad_correlatedk_opacities_thermal + +END MODULE rad_correlatedk_opacities_thermal_mod + Index: trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_rayleigh_scattering_opacity.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_rayleigh_scattering_opacity.F90 (revision 4077) +++ trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_rayleigh_scattering_opacity.F90 (revision 4077) @@ -0,0 +1,341 @@ +module rad_correlatedk_rayleigh_scattering_opacity_mod + +implicit none + +contains + + subroutine rad_correlatedk_rayleigh_scattering_opacity(qvar,muvar,PMID,TMID,tauray) + +!================================================================== +! +! Purpose +! ------- +! Average the Rayleigh scattering in each band, weighting the +! average by the blackbody function at temperature tstellar. +! Works for an arbitrary mix of gases. +! +! Authors +! ------- +! Robin Wordsworth (2010) +! Jeremy Leconte (2012): Added option for variable gas. Improved water rayleigh (Bucholtz 1995). +! Noe Clement (2022) : Additionnal comments & Methane+CO Rayleigh +! Gwenael Milcareck (2025): Rewriting the code +! +! Called by +! --------- +! rad_correlatedk_init_stellar.F +! +! Calls +! ----- +! none +! +!================================================================== + + use radinc_h, only: L_NSPECTV, L_LEVELS + use radcommon_h, only: WAVEV, BWNV, DWNV, tstellar, scalep + use gases_h, only: ngasmx, vgas, gnom, gfrac, massmol, igas_CO2, igas_H2, & + igas_H2O, igas_He, igas_N2, igas_CH4, igas_CO, igas_Ar, igas_O2 + use comcstfi_mod, only: g, pi + use callkeys_mod, only: strictboundrayleigh + + implicit none + + real, intent(in) :: qvar(L_LEVELS) ! mol/mol + real, intent(in) :: muvar(L_LEVELS) ! g/mol + real, intent(in) :: PMID(L_LEVELS) ! mbar + real, intent(in) :: TMID(L_LEVELS) ! K + real, intent(out) :: tauray(L_LEVELS,L_NSPECTV) + real*8 wl,wn + integer N,Nfine,ifine,igas,k + parameter(Nfine=500.0) + real*8 :: Fk ! King factor for the depolarization + real*8 :: ng(L_LEVELS) ! real refractive index + real*8 :: P0(L_LEVELS) ! reference pressure + real*8 :: T0(L_LEVELS) ! reference temperature + + ! Parameters for H2O + real*8 :: a0, a1, a2, a3, a4, a5, a6, a7 + real*8 :: luv, lir + real*8 :: rhor,tr,lr + real*8 :: rho(L_LEVELS),rhos(L_LEVELS),ts(L_LEVELS) + real*8 :: b(L_LEVELS) + + real*8 mass_frac(ngasmx,L_LEVELS) + real*8 tauvar(L_LEVELS),tausum(L_LEVELS) + real*8 tauwei,bwidth,bstart + double precision df + + real*8 tauconsti(ngasmx,L_LEVELS) + real*8 tauvari(ngasmx,L_LEVELS) + + ! Miscellaneous : + character(len=200) :: message + character(len=10),parameter :: subname="rayleigh" + logical, save :: firstcall=.true. +!$OMP THREADPRIVATE(firstcall) + + integer icantbewrong + + ! This module calculates the Rayleigh scattering (also known as the Cabannes peak) + ! Rayleigh wings, Brillouin scattering and Raman scattering are not taken into account. + + ! we calculate here TAURAY which is in m2/mBar + + ! The cross section for ith particles of small size compared to the wavenumber + ! and in the electric dipole approximation is: + ! sigma_i = 24*pi**3*wn**4/N**2 * ((n_i(wn)**2 - 1)/(n_i(wn)**2 + 2))**2 * Fk_i(wn) + ! nu is the wavenumber + ! N is the number density of the gas (molecule/m3) + ! n_i is the real refractive index of the ith gas + ! Fk_i is the King factor of ith gas equals to (6+3*delta_i)/(6-7*delta_i) + ! where delta_i is the depolarization factor of the ith gas + + ! The rayleigh opacity is expressed by: + ! tau_r = P/(g*mu) * sum_{i=1}^Ntot [ x_i*sigma_i ] + ! P is the pressure + ! g is the standard gravity + ! mu is the mean molecular weight + ! x_i is the mass fraction of the ith gas + ! The pressure P dependence is calculated in rad_correlatedk_opacities_stellar.F90 + + if(firstcall) then + + if ((BWNV(L_NSPECTV+1).gt.60000.).and.(strictboundrayleigh)) then + message="Rayleigh scattering is unknown for wn>60000 cm-1 - all data is extrapolated for higher wavenumber - if you know what you are doing, use strictboundrayleigh=.false." + call abort_physic(subname,message,1) + elseif ((BWNV(L_NSPECTV+1).gt.60000.).and..not.(strictboundrayleigh)) then + print*,'**********************************************' + print*,' we allow model to continue with wn>60000 cm-1' + print*,' ... we assume we know what you are doing ... ' + print*,' ... but do not let this happen too often ... ' + print*,'**********************************************' + endif + firstcall = .false. + endif + + + do igas=1,ngasmx + ! Convert qvar mol/mol -> kg/kg + if((igas.eq.vgas).and.(maxval(QVAR(:)).ge.1.e-2))then + ! print*,'variable gas is ',trim(gnom(igas)),' in Rayleigh scattering ' + mass_frac(igas,:) = QVAR(:)*massmol(igas)/muvar(:) + elseif((igas/=vgas).and.(gfrac(igas).ge.1.e-2))then + mass_frac(igas,:) = gfrac(igas)*(1.-QVAR(:))*massmol(igas)/muvar(:) + else + ! print*,'Ignoring ',trim(gnom(igas)),' in Rayleigh scattering '// & + ! 'as its mixing ratio is less than 0.01.' + ! ignore variable gas in Rayleigh calculation + ! ignore gases of mixing ratio < 0.01 in Rayleigh calculation + mass_frac(igas,:) = 0.0 + endif + tauvari(igas,:) = 0. + enddo + + ! WARNING, beyond 60000 cm-1, for all molecules, there are singularities due to the interpolation formula. + + + do N=1,L_NSPECTV + + ! The refractive index depend on temperature and pressure + ! It isn't the case here. Must be implemented in the future... + ! But in the current scientific litterature (2024), it's difficult + ! to find something that depends on temperature and pressure... + ! except for H2O + + tausum = 0.0 + tauwei = 0.0 + bstart = 10000.0/BWNV(N+1) ! BWNV is in cm-1 so 10000.0/BWNV is in micron + bwidth = (10000.0/BWNV(N)) - (10000.0/BWNV(N+1)) + do ifine=1,Nfine + wl=bstart+dble(ifine)*bwidth/Nfine + wn=BWNV(N)+dble(ifine)*(BWNV(N+1)-BWNV(N))/Nfine + + tauvar(:)=0.0 + do igas=1,ngasmx + if (maxval(mass_frac(igas,:)).ge.1e-2) then + + if(igas.eq.igas_CO2)then + ! Sneep et al, 2005 + ! doi:10.1016/j.jqsrt.2004.07.025 + T0(:) = 288.15 + P0(:) = 1.01325e5 + if (wn .lt. 55331) then + ! Sneep et al, 2005 + ! doi:10.1016/j.jqsrt.2004.07.025 + ! ng -> valid range of the measurements : 0.1807 - 1.8172 um + ng(:) = 1. + 1.1427e3*(5799.25/(128908.9**2 - wn**2) + 120.05/(89223.8**2 - wn**2) + 5.3334/(75037.5**2 - wn**2) + 4.3244/(67837.7**2 - wn**2) + 0.1218145e-4/(2418.136**2 - wn**2)) ! there is an error on the paper 1.1427e6 -> 1.1427e3 + else + ! Cuthbertson and Cuthbertson, 1920 (extrapolation) + ! doi:10.1098/rspa.1920.0020 + ng(:) = 1. + (6914.45/(156.85 - (wn*1e-4)**2))*1e-5 + endif + Fk = 1.1364 + 25.3e-12*wn**2 + tauvari(igas,:) = mass_frac(igas,:)*((ng(:)**2-1.)/(ng(:)**2+2.))**2 * Fk * (wn*100.)**4 ! wn*100 -> cm-1 to m-1 + ! N=P/(kB*T) and muvar/1000 -> g/mol to kg/mol + tauconsti(igas,:) = 24.*pi**3 *6.022141E+023 / (g*(muvar(:)/1000.)*(P0(:)/(1.380649E-23*T0(:)))**2) + elseif(igas.eq.igas_N2)then + ! Sneep et al, 2005 + ! doi:10.1016/j.jqsrt.2004.07.025 + T0(:) = 288.15 + P0(:) = 1.01325e5 + if(wn.gt.21360)then !between 21360 and 39370 cm-1. We extrapolate above. + ng(:) = 1. + (5677.465 + 318.81874e12/(14.4e9 - wn**2))*1e-8 !there is an error on the paper e12 -> e13 + else !between 4860 and 21360 cm-1. We extrapolate below. + ng(:) = 1. + (6498.2 + 307.4335e12/(14.4e9 - wn**2))*1e-8 + endif + Fk = 1.034 + 3.17e-12*wn**2 + tauvari(igas,:) = mass_frac(igas,:)*((ng(:)**2-1.)/(ng(:)**2+2.))**2 * Fk * (wn*100.)**4 + tauconsti(igas,:) = 24.*pi**3 *6.022141E+023 / (g*(muvar(:)/1000.)*(P0(:)/(1.380649E-23*T0(:)))**2) + elseif(igas.eq.igas_H2O)then + Fk = (6.+3.*3e-4)/(6.-7.*3e-4) ! delta=3e-4 Murphy 1977 doi:10.1063/1.434794 + if(wn<4840.) then ! necessary to prevent a singularity at 3230 cm-1 + ! Ciddor, 1996 + ! doi:10.1364/AO.35.001566 for wn<4840 cm-1 + T0(:)=293.15 + P0(:)=1333. + ng(:) = 1. + 1.022e-8*(295.235 + 2.6422*(wn*1e-4)**2 - 0.032380*(wn*1e-4)**4 + 0.004028*(wn*1e-4)**6) + tauvari(igas,:) = mass_frac(igas,:)*((ng(:)**2-1.)/(ng(:)**2+2.))**2 * Fk * (wn*100.)**4 + tauconsti(igas,:) = 24.*pi**3 *6.022141E+023 / (g*(muvar(:)/1000.)*(P0(:)/(1.380649E-23*T0(:)))**2) + elseif(wn>50000.) then + ! Barrell and Sears, 1939 (extrapolation) + ! doi:10.1098/rsta.1939.0004 + T0(:)=273.15 + P0(:)=101325. + ng(:) = 1. + (245.40+2.187*(1e4/wn)**(-2))*1e-6 + tauvari(igas,:) = mass_frac(igas,:)*((ng(:)**2-1.)/(ng(:)**2+2.))**2 * Fk * (wn*100.)**4 + tauconsti(igas,:) = 24.*pi**3 *6.022141E+023 / (g*(muvar(:)/1000.)*(P0(:)/(1.380649E-23*T0(:)))**2) + else + ! Harvey et al, 1998 + ! doi:10.1063/1.556029 + ! ng -> valid range of the measurements : 0.2 - 1.1 um + a0 = 0.244257733 + a1 = 9.74634476e-3 + a2 = -3.73234996e-3 + a3 = 2.68678472e-4 + a4 = 1.58920570e-3 + a5 = 2.45934259e-3 + a6 = 0.900704920 + a7 = -1.66626219e-2 + luv = 0.2292020 + lir = 5.432937 + Tr = 273.15 + rhor = 1000. + T0(:) = tmid(:) + P0(:) = pmid(:)*scalep + lr = 0.589 + rho(:) = mass_frac(igas,:)*muvar(:)/massmol(igas)*P0(:)/(8.314463*T0(:)/(muvar(:)/1000.)) + rhos(:) = rho(:)/rhor + ts(:) = T0(:)/Tr + b(:) = (a0 + a1*rhos(:) + a2*ts(:) + a3*ts(:)*(10000./wn/lr)**2 + a4/(10000./wn/lr)**2 + a5/((10000./wn/lr)**2 - luv**2) + a6/((10000./wn/lr)**2 - lir**2) + a7*rhos(:)**2)*rhos(:) + ng(:) = sqrt(2.*b(:)+1.)/sqrt(1.-b(:)) + tauvari(igas,:) = mass_frac(igas,:)*((ng(:)**2-1.)/(ng(:)**2+2.))**2 * Fk * (wn*100.)**4 + tauconsti(igas,:) = 24.*pi**3 *6.022141E+023 / (g*(muvar(:)/1000.)*(P0(:)/(1.380649E-23*T0(:)))**2) + endif + elseif(igas.eq.igas_H2)then + ! Peck and Hung, 1977 + ! doi:10.1364/JOSA.67.001550 + T0(:) = 273.15 + P0(:) = 1.01325e5 + ! ng -> valid range of the measurements : 0.1680 - 1.6945 um + if(wn<59534.) then + ng(:) = 1. + (14895.6/(180.7 - (wn*1e-4)**2) + 4903.7/(92.-(wn*1e-4)**2))*1e-6 + else + ng(:) = 1. + (23.79 + 12307.2/(109.832-(wn*1e-4)**2))*1e-6 ! extrapolation + endif + Fk = (6.+3.*0.02)/(6.-7.*0.02) ! delta=0.02 Hansen 1974 + tauvari(igas,:) = mass_frac(igas,:)*((ng(:)**2-1.)/(ng(:)**2+2.))**2 * Fk * (wn*100.)**4 + tauconsti(igas,:) = 24.*pi**3 *6.022141E+023 / (g*(muvar(:)/1000.)*(P0(:)/(1.380649E-23*T0(:)))**2) + elseif(igas.eq.igas_He)then + ! Thalman et al, 2014 + ! doi:10.1016/j.jqsrt.2014.05.030 + T0(:) = 288.15 + P0(:) = 1.01325e5 + ! ng -> valid range of the measurements : 0.2753 - 20.5813 um + ng(:) = 1. + (2283. + 1.8102e13/(1.5342e10 - wn**2))*1e-8 + Fk = 1. + tauvari(igas,:) = mass_frac(igas,:)*((ng(:)**2-1.)/(ng(:)**2+2.))**2 * Fk * (wn*100.)**4 + tauconsti(igas,:) = 24.*pi**3 *6.022141E+023 / (g*(muvar(:)/1000.)*(P0(:)/(1.380649E-23*T0(:)))**2) + elseif(igas.eq.igas_CH4)then + ! Sneep et al, 2005 + ! doi:10.1016/j.jqsrt.2004.07.025 + T0(:) = 288.15 + P0(:) = 1.01325e5 + ! ng -> valid range of the measurements : 0.3251 - 0.6330 um + ng(:) = 1. + 46662e-8 + 4.02e-14*wn**2 + Fk = 1. + tauvari(igas,:) = mass_frac(igas,:)*((ng(:)**2-1.)/(ng(:)**2+2.))**2 * Fk * (wn*100.)**4 + tauconsti(igas,:) = 24.*pi**3 *6.022141E+023 / (g*(muvar(:)/1000.)*(P0(:)/(1.380649E-23*T0(:)))**2) + elseif(igas.eq.igas_CO)then + ! Sneep et al, 2005 + ! doi:10.1016/j.jqsrt.2004.07.025 + T0(:) = 288.15 + P0(:) = 1.01325e5 + ! ng -> valid range of the measurements : 0.168 - 0.288 um + if(wn<59809.) then + ng(:) = 1. + 22851e-8 + 0.456e4/(71427.**2 - wn**2) + else + ng(:) = 1.00028476-2.01518666e-9*wn+1.88043553e-14*wn**2 ! extrapolation from previous data + endif + Fk = 1.016 + tauvari(igas,:) = mass_frac(igas,:)*((ng(:)**2-1.)/(ng(:)**2+2.))**2 * Fk * (wn*100.)**4 + tauconsti(igas,:) = 24.*pi**3 *6.022141E+023 / (g*(muvar(:)/1000.)*(P0(:)/(1.380649E-23*T0(:)))**2) + elseif(igas.eq.igas_Ar)then + ! Sneep et al, 2005 + ! doi:10.1016/j.jqsrt.2004.07.025 + T0(:) = 288.15 + P0(:) = 1.01325e5 + ! ng -> valid range of the measurements : 0.288 - 0.546 um + ng(:) = 1. + (6432.135 + 286.06021e12/(14.4e9 - wn**2))*1e-8 + Fk = 1. + tauvari(igas,:) = mass_frac(igas,:)*((ng(:)**2-1.)/(ng(:)**2+2.))**2 * Fk * (wn*100.)**4 + tauconsti(igas,:) = 24.*pi**3 *6.022141E+023 / (g*(muvar(:)/1000.)*(P0(:)/(1.380649E-23*T0(:)))**2) + elseif(igas.eq.igas_O2)then + ! Sneep et al, 2005 + ! doi:10.1016/j.jqsrt.2004.07.025 + T0(:) = 273.15 + P0(:) = 1.01325e5 + if (wn .lt. 18315) then + ! ng -> valid range of the measurements : > 0.546 um + ng(:) = 1. + (21351.3 + 21.85670/(4.09e9 - wn**2))*1e-8 + elseif ((18315 .le. wn) .and. (wn .lt. 34722)) then + ! ng -> valid range of the measurements : 0.288 - 0.546 um + ng(:) = 1. + (20564.8 + 24.80899/(4.09e9 - wn**2))*1e-8 + elseif ((34722 .le. wn) .and. (wn .lt. 45248)) then + ! ng -> valid range of the measurements : 0.288 - 0.221 um + ng(:) = 1. + (22120.4 + 20.31876/(4.09e9 - wn**2))*1e-8 + else + ! ng -> valid range of the measurements : < 0.221 um + ng(:) = 1. + (23796.7 + 16.89884/(4.09e9 - wn**2))*1e-8 + endif + Fk = 1.09 + 1.385e-11*wn**2 + 1.488e-20*wn**4 + tauvari(igas,:) = mass_frac(igas,:)*((ng(:)**2-1.)/(ng(:)**2+2.))**2 * Fk * (wn*100.)**4 + tauconsti(igas,:) = 24.*pi**3 *6.022141E+023 / (g*(muvar(:)/1000.)*(P0(:)/(1.380649E-23*T0(:)))**2) + else + print*,'No rayleigh scattering for ',trim(gnom(igas)),'. No data found.' + endif + + ! N=P/(kB*T) + ! pmid*scalep -> mbar to Pa + ! muvar/1000 -> g/mol to kg/mol + + tauvar(:)=tauvar(:)+tauconsti(igas,:)*tauvari(igas,:) + + endif !greater than 0.01 + + enddo !ngasmx + + call rad_blackbody_planck_law_wavelength(dble(wl*1e-6),dble(tstellar),df) + df=df*bwidth/Nfine + tauwei=tauwei+df + tausum(:)=tausum(:)+tauvar(:)*df + + enddo !Nfine + ! We add a scalep because pressure in radiative transfer is in mbar + TAURAY(:,N)=tausum(:)*scalep/tauwei + + end do !L_NSPECTV + + + end subroutine rad_correlatedk_rayleigh_scattering_opacity + +end module rad_correlatedk_rayleigh_scattering_opacity_mod Index: trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_read_opacity_tables.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_read_opacity_tables.F90 (revision 4077) +++ trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_read_opacity_tables.F90 (revision 4077) @@ -0,0 +1,824 @@ + subroutine rad_correlatedk_read_opacity_tables + +!================================================================== +! +! Purpose +! ------- +! Set up gaseous absorption parameters used by the radiation code. +! This subroutine is a replacement for the old 'setrad', which contained +! both absorption and scattering data. +! +! Authors +! ------- +! Adapted and generalised from the NASA Ames code by Robin Wordsworth (2009) +! Added double gray case by Jeremy Leconte (2012) +! New HITRAN continuum data section by RW (2012) +! Modern traceur.def & corrk recombing scheme by J.Vatant d'Ollone (2020) +! +! Summary +! ------- +! +!================================================================== + + use radinc_h, only: corrkdir, banddir, L_NSPECTI, L_NSPECTV, & + L_NGAUSS, L_NPREF, L_NTREF, L_REFVAR, L_PINT + use radcommon_h, only : pgasref,pfgasref,pgasmin,pgasmax + use radcommon_h, only : tgasref,tgasmin,tgasmax + use radcommon_h, only : gasv,gasi,FZEROI,FZEROV,gweight + use radcommon_h, only : wrefvar,WNOI,WNOV + use datafile_mod, only: datadir + use comcstfi_mod, only: mugaz + use gases_h, only: gnom, ngasmx, & + igas_H2, igas_H2O, igas_He, igas_N2, igas_CH4, & + igas_CO2, igas_O2 + use ioipsl_getin_p_mod, only: getin_p + use callkeys_mod, only: varactive,varfixed,graybody,callgasvis,& + continuum + use tracer_h, only : nqtot, moderntracdef, is_recomb, noms + use rad_correlatedk_online_recombination_mod, only: rad_correlatedk_recombination_setup, & + corrk_recombin, use_premix, nrecomb_tot, rcb2tot_idx + use rad_correlatedk_continuum_interpolation_mod, only: rad_correlatedk_continuum_interpolation + implicit none + +!================================================================== + + logical file_ok + + integer n, nt, np, nh, ng, nw, m, i + + character(len=200) :: file_id + character(len=500) :: file_path + + ! ALLOCATABLE ARRAYS -- AS 12/2011 + REAL*8, DIMENSION(:,:,:,:,:), ALLOCATABLE,SAVE :: gasi8, gasv8 !read by master + character*20,allocatable,DIMENSION(:),SAVE :: gastype ! for check with gnom, read by master + + real*8 x, xi(4), yi(4), ans, p +! For gray case (JL12) + real kappa_IR, kappa_VI, IR_VI_wnlimit + integer nVI_limit,nIR_limit + + integer ngas, igas, jgas + + double precision testcont ! for continuum absorption initialisation + + if (.not. moderntracdef) use_premix=.true. ! Added by JVO for compatibility with 'old' traceur.def + +!$OMP MASTER + if (use_premix) then ! use_premix flag added by JVO, thus if pure recombining then premix is skipped + +!======================================================================= +! Load variable species data, exit if we have wrong database + file_id='/corrk_data/' // TRIM(corrkdir) // '/Q.dat' + file_path=TRIM(datadir)//TRIM(file_id) + + ! check that the file exists + inquire(FILE=file_path,EXIST=file_ok) + if(.not.file_ok) then + write(*,*)'The file ',TRIM(file_path) + write(*,*)'was not found by rad_correlatedk_read_opacity_tables .F90, exiting.' + write(*,*)'Check that your path to datagcm:',trim(datadir) + write(*,*)' is correct. You can change it in callphys.def with:' + write(*,*)' datadir = /absolute/path/to/datagcm' + write(*,*)'Also check that the corrkdir you chose in callphys.def exists.' + call abort_physic("rad_correlatedk_read_opacity_tables ", "Unable to read file", 1) + endif + + ! check that database matches varactive toggle + open(111,file=TRIM(file_path),form='formatted') + read(111,*) ngas + + if(moderntracdef) then + ! JVO 20 - TODO : Sanity check with nspcrad ! + print*, 'Warning : Sanity check on # of gases still not implemented !!' + else + if(ngas.ne.ngasmx)then + print*,'Number of gases in radiative transfer data (',ngas,') does not', & + 'match that in gases.def (',ngasmx,'), exiting.' + call abort_physic("rad_correlatedk_read_opacity_tables ", "Number of gases in radiative transfer data does not match that in gases.def", 1) + endif + endif + + if(ngas.eq.1 .and. (varactive.or.varfixed))then + print*,'You have varactive/fixed=.true. but the database [', & + corrkdir(1:LEN_TRIM(corrkdir)), & + '] has no variable species, exiting.' + call abort_physic("rad_correlatedk_read_opacity_tables ", "You have varactive/fixed=.true. but the database has no variable species",1) + elseif(ngas.gt.5 .or. ngas.lt.1)then + print*,ngas,' species in database [', & + corrkdir(1:LEN_TRIM(corrkdir)), & + '], radiative code cannot handle this.' + call abort_physic("rad_correlatedk_read_opacity_tables ", "No gas or too many gases for radiative code", 1) + endif + + ! dynamically allocate gastype and read from Q.dat + IF ( .NOT. ALLOCATED( gastype ) ) ALLOCATE( gastype( ngas ) ) + + do igas=1,ngas + read(111,*) gastype(igas) + if(corrk_recombin) then + print*,'Premix gas ',igas,' is ',gastype(igas) + else + print*,'Gas ',igas,' is ',gastype(igas) + endif + enddo + + ! get array size, load the coefficients + open(111,file=TRIM(file_path),form='formatted') + read(111,*) L_REFVAR + IF( .NOT. ALLOCATED( wrefvar ) ) ALLOCATE( WREFVAR(L_REFVAR) ) + read(111,*) wrefvar + close(111) + + if(L_REFVAR.gt.1 .and. (.not.varactive) .and. (.not.varfixed))then + print*,'You have varactive and varfixed=.false. and the database [', & + corrkdir(1:LEN_TRIM(corrkdir)), & + '] has a variable species.' + call abort_physic("rad_correlatedk_read_opacity_tables ", "You have varactive and varfixed=.false. and the database has a variable species",1) + endif + + if (moderntracdef) then + ! JVO 20 - TODO : Sanity check with nspcrad ! + print*, 'Warning : Sanity check on name of gases still not implemented !!' + else + ! Check that gastype and gnom match + do igas=1,ngas + print*,'Gas ',igas,' is ',trim(gnom(igas)) + if (trim(gnom(igas)).ne.trim(gastype(igas))) then + print*,'Name of a gas in radiative transfer data (',trim(gastype(igas)),') does not ', & + 'match that in gases.def (',trim(gnom(igas)),'), exiting. You should compare ', & + 'gases.def with Q.dat in your radiative transfer directory.' + call abort_physic("rad_correlatedk_read_opacity_tables ", "Name of a gas in radiative transfer data does not match that in gases.def",1) + endif + enddo + print*,'Confirmed gas match in radiative transfer and gases.def!' + endif + + ! display the values + print*,'Variable gas volume mixing ratios:' + do n=1,L_REFVAR + !print*,n,'.',wrefvar(n),' kg/kg' ! pay attention! + print*,n,'.',wrefvar(n),' mol/mol' + end do + print*,'' + + else + L_REFVAR = 1 + endif ! use_premix + +!======================================================================= +! Set the weighting in g-space + + file_id='/corrk_data/' // TRIM(corrkdir) // '/g.dat' + file_path=TRIM(datadir)//TRIM(file_id) + + ! check that the file exists + inquire(FILE=file_path,EXIST=file_ok) + if(.not.file_ok) then + write(*,*)'The file ',TRIM(file_path) + write(*,*)'was not found by rad_correlatedk_read_opacity_tables .F90, exiting.' + write(*,*)'Check that your path to datagcm:',trim(datadir) + write(*,*)' is correct. You can change it in callphys.def with:' + write(*,*)' datadir = /absolute/path/to/datagcm' + write(*,*)'Also check that the corrkdir you chose in callphys.def exists.' + call abort_physic("rad_correlatedk_read_opacity_tables ", "Unable to read file", 1) + endif + + ! check the array size is correct, load the coefficients + open(111,file=TRIM(file_path),form='formatted') + read(111,*) L_NGAUSS + IF( .NOT. ALLOCATED( gweight ) ) ALLOCATE( GWEIGHT(L_NGAUSS) ) + read(111,*) gweight + close(111) + + ! display the values + print*,'Correlated-k g-space grid:' + do n=1,L_NGAUSS + print*,n,'.',gweight(n) + end do + print*,'' + +!======================================================================= +! Set the reference pressure and temperature arrays. These are +! the pressures and temperatures at which we have k-coefficients. + +!----------------------------------------------------------------------- +! pressure + + file_id='/corrk_data/' // TRIM(corrkdir) // '/p.dat' + file_path=TRIM(datadir)//TRIM(file_id) + + ! check that the file exists + inquire(FILE=file_path,EXIST=file_ok) + if(.not.file_ok) then + write(*,*)'The file ',TRIM(file_path) + write(*,*)'was not found by rad_correlatedk_read_opacity_tables .F90, exiting.' + write(*,*)'Check that your path to datagcm:',trim(datadir) + write(*,*)' is correct. You can change it in callphys.def with:' + write(*,*)' datadir = /absolute/path/to/datagcm' + write(*,*)'Also check that the corrkdir you chose in callphys.def exists.' + call abort_physic("rad_correlatedk_read_opacity_tables ", "Unable to read file", 1) + endif + + ! get array size, load the coefficients + open(111,file=TRIM(file_path),form='formatted') + read(111,*) L_NPREF + IF( .NOT. ALLOCATED( pgasref ) ) ALLOCATE( PGASREF(L_NPREF) ) + read(111,*) pgasref + close(111) + L_PINT = (L_NPREF-1)*5+1 + IF( .NOT. ALLOCATED( pfgasref ) ) ALLOCATE( PFGASREF(L_PINT) ) + + ! display the values + print*,'Correlated-k pressure grid (mBar):' + do n=1,L_NPREF + print*,n,'. 1 x 10^',pgasref(n),' mBar' + end do + print*,'' + + ! save the min / max matrix values + pgasmin = 10.0**pgasref(1) + pgasmax = 10.0**pgasref(L_NPREF) + + ! interpolate to finer grid, adapted to uneven grids + do n=1,L_NPREF-1 + do m=1,5 + pfgasref((n-1)*5+m) = pgasref(n)+(m-1)*(pgasref(n+1) - pgasref(n))/5. + end do + end do + pfgasref(L_PINT) = pgasref(L_NPREF) + +!----------------------------------------------------------------------- +! temperature + + file_id='/corrk_data/' // TRIM(corrkdir) // '/T.dat' + file_path=TRIM(datadir)//TRIM(file_id) + + ! check that the file exists + inquire(FILE=file_path,EXIST=file_ok) + if(.not.file_ok) then + write(*,*)'The file ',TRIM(file_path) + write(*,*)'was not found by rad_correlatedk_read_opacity_tables .F90, exiting.' + write(*,*)'Check that your path to datagcm:',trim(datadir) + write(*,*)' is correct. You can change it in callphys.def with:' + write(*,*)' datadir = /absolute/path/to/datagcm' + write(*,*)'Also check that the corrkdir you chose in callphys.def exists.' + call abort_physic("rad_correlatedk_read_opacity_tables ", "Unable to read file",1) + endif + + ! get array size, load the coefficients + open(111,file=TRIM(file_path),form='formatted') + read(111,*) L_NTREF + IF( .NOT. ALLOCATED( tgasref ) ) ALLOCATE( TGASREF(L_NTREF) ) + read(111,*) tgasref + close(111) + + ! display the values + print*,'Correlated-k temperature grid:' + do n=1,L_NTREF + print*,n,'.',tgasref(n),' K' + end do + + ! save the min / max matrix values + tgasmin = tgasref(1) + tgasmax = tgasref(L_NTREF) + + if(corrk_recombin) then ! even if no premix we keep a L_REFVAR=1 to store precombined at firstcall (see + IF(.NOT. ALLOCATED(gasi8)) ALLOCATE(gasi8(L_NTREF,L_NPREF,L_REFVAR+nrecomb_tot,L_NSPECTI,L_NGAUSS)) + IF(.NOT. ALLOCATED(gasv8)) ALLOCATE(gasv8(L_NTREF,L_NPREF,L_REFVAR+nrecomb_tot,L_NSPECTV,L_NGAUSS)) + else + IF(.NOT. ALLOCATED(gasi8)) ALLOCATE(gasi8(L_NTREF,L_NPREF,L_REFVAR,L_NSPECTI,L_NGAUSS)) + IF(.NOT. ALLOCATED(gasv8)) ALLOCATE(gasv8(L_NTREF,L_NPREF,L_REFVAR,L_NSPECTV,L_NGAUSS)) + endif +!$OMP END MASTER +!$OMP BARRIER + +! JVO 20 : In these gasi/gasi8 matrix we stack in same dim. variable specie and species to recombine (to keep code small) + +!----------------------------------------------------------------------- +! allocate the multidimensional arrays in radcommon_h + if(corrk_recombin) then + IF(.NOT. ALLOCATED(gasi)) ALLOCATE(gasi(L_NTREF,L_PINT,L_REFVAR+nrecomb_tot,L_NSPECTI,L_NGAUSS)) + IF(.NOT. ALLOCATED(gasv)) ALLOCATE(gasv(L_NTREF,L_PINT,L_REFVAR+nrecomb_tot,L_NSPECTV,L_NGAUSS)) + ! display the values + print*,'' + print*,'Correlated-k matrix size:' + print*,'[',L_NTREF,',',L_NPREF,',',L_REFVAR+nrecomb_tot,' (',L_REFVAR,'+',nrecomb_tot,'),',L_NGAUSS,']' + else + IF(.NOT. ALLOCATED(gasi)) ALLOCATE(gasi(L_NTREF,L_PINT,L_REFVAR,L_NSPECTI,L_NGAUSS)) + IF(.NOT. ALLOCATED(gasv)) ALLOCATE(gasv(L_NTREF,L_PINT,L_REFVAR,L_NSPECTV,L_NGAUSS)) + ! display the values + print*,'' + print*,'Correlated-k matrix size:' + print*,'[',L_NTREF,',',L_NPREF,',',L_REFVAR,',',L_NGAUSS,']' + endif + +!======================================================================= +! Get gaseous k-coefficients and interpolate onto finer pressure grid + + +! wavelength used to separate IR from VI in graybody. We will need that anyway + IR_VI_wnlimit=3000. + write(*,*)"graybody: Visible / Infrared separation set at",10000./IR_VI_wnlimit,"um" + + nVI_limit=0 + Do nw=1,L_NSPECTV + if ((WNOV(nw).gt.IR_VI_wnlimit).and.(L_NSPECTV.gt.1)) then + nVI_limit=nw-1 + exit + endif + End do + nIR_limit=L_NSPECTI + Do nw=1,L_NSPECTI + if ((WNOI(nw).gt.IR_VI_wnlimit).and.(L_NSPECTI.gt.1)) then + nIR_limit=nw-1 + exit + endif + End do + + if (graybody) then +! constant absorption coefficient in visible + write(*,*)"graybody: constant absorption coefficient in visible:" + kappa_VI=-100000. + call getin_p("kappa_VI",kappa_VI) + write(*,*)" kappa_VI = ",kappa_VI + kappa_VI=kappa_VI*1.e4* mugaz * 1.672621e-27 ! conversion from m^2/kg to cm^2/molecule + +! constant absorption coefficient in IR + write(*,*)"graybody: constant absorption coefficient in InfraRed:" + kappa_IR=-100000. + call getin_p("kappa_IR",kappa_IR) + write(*,*)" kappa_IR = ",kappa_IR + kappa_IR=kappa_IR*1.e4* mugaz * 1.672621e-27 ! conversion from m^2/kg to cm^2/molecule + + write(*,*)"graybody: Visible / Infrared separation set at band: IR=",nIR_limit,", VI=",nVI_limit + + Else + kappa_VI=1.e-30 + kappa_IR=1.e-30 + End if + +!$OMP MASTER + + ! VISIBLE + if (callgasvis) then + + ! Looking for premixed corrk files corrk_gcm_VI.dat if needed + if (use_premix) then + ! print*,corrkdir(1:4) + if ((corrkdir(1:4).eq.'null'))then !(TRIM(corrkdir).eq.'null_LowTeffStar')) then + gasv8(:,:,:,:,:)=0.0 + print*,'using no corrk data' + print*,'Visible corrk gaseous absorption is set to zero if graybody=F' + else + file_id='/corrk_data/'//trim(adjustl(banddir))//'/corrk_gcm_VI.dat' + file_path=TRIM(datadir)//TRIM(file_id) + + ! check that the file exists + inquire(FILE=file_path,EXIST=file_ok) + if(.not.file_ok) then + write(*,*)'The file ',TRIM(file_path) + write(*,*)'was not found by rad_correlatedk_read_opacity_tables .F90.' + write(*,*)'Are you sure you have absorption data for these bands?' + call abort_physic("rad_correlatedk_read_opacity_tables ", "No absorption data found", 1) + endif + + open(111,file=TRIM(file_path),form='formatted') + read(111,*) gasv8(:,:,:L_REFVAR,:,:) + close(111) + end if + else + gasv8(:,:,1,:,:)=0.0 ! dummy but needs to be initialized + endif ! use_premix + + ! Looking for others files corrk_gcm_VI_XXX.dat if needed + if (corrk_recombin) then + do igas=1,nrecomb_tot + + file_id='/corrk_data/'//trim(adjustl(banddir))//'/corrk_gcm_VI_'//trim(adjustl(noms(rcb2tot_idx(igas))))//'.dat' + file_path=TRIM(datadir)//TRIM(file_id) + + ! check that the file exists + inquire(FILE=file_path,EXIST=file_ok) + if(.not.file_ok) then + write(*,*)'The file ',TRIM(file_path) + write(*,*)'was not found by rad_correlatedk_read_opacity_tables .F90.' + write(*,*)'Are you sure you have absorption data for this specie at these bands?' + call abort_physic("rad_correlatedk_read_opacity_tables ", "No absorption data found", 1) + endif + + open(111,file=TRIM(file_path),form='formatted') + read(111,*) gasv8(:,:,L_REFVAR+igas,:,:) + close(111) + enddo + endif ! corrk_recombin + + if(nVI_limit.eq.0) then + gasv8(:,:,:,:,:)= gasv8(:,:,:,:,:)+kappa_VI + else if (nVI_limit.eq.L_NSPECTV) then + gasv8(:,:,:,:,:)= gasv8(:,:,:,:,:)+kappa_IR + else + gasv8(:,:,:,1:nVI_limit,:)= gasv8(:,:,:,1:nVI_limit,:)+kappa_IR + gasv8(:,:,:,nVI_limit+1:L_NSPECTV,:)= gasv8(:,:,:,nVI_limit+1:L_NSPECTV,:)+kappa_VI + end if + + else + print*,'Visible corrk gaseous absorption is set to zero.' + gasv8(:,:,:,:,:)=0.0 + endif ! callgasvis + +!$OMP END MASTER +!$OMP BARRIER + + ! INFRA-RED + + ! Looking for premixed corrk files corrk_gcm_IR.dat if needed + if (use_premix) then + if ((corrkdir(1:4).eq.'null'))then !.or.(TRIM(corrkdir).eq.'null_LowTeffStar')) then + print*,'Infrared corrk gaseous absorption is set to zero if graybody=F' +!$OMP MASTER + gasi8(:,:,:,:,:)=0.0 +!$OMP END MASTER +!$OMP BARRIER + else + file_id='/corrk_data/'//trim(adjustl(banddir))//'/corrk_gcm_IR.dat' + file_path=TRIM(datadir)//TRIM(file_id) + + ! check that the file exists + inquire(FILE=file_path,EXIST=file_ok) + if(.not.file_ok) then + write(*,*)'The file ',TRIM(file_path) + write(*,*)'was not found by rad_correlatedk_read_opacity_tables .F90.' + write(*,*)'Are you sure you have absorption data for these bands?' + call abort_physic("rad_correlatedk_read_opacity_tables ", "No absorption data found", 1) + endif + +!$OMP MASTER + open(111,file=TRIM(file_path),form='formatted') + read(111,*) gasi8(:,:,:L_REFVAR,:,:) + close(111) +!$OMP END MASTER +!$OMP BARRIER + + ! 'fzero' is a currently unused feature that allows optimisation + ! of the radiative transfer by neglecting bands where absorption + ! is close to zero. As it could be useful in the future, this + ! section of the code has been kept commented and not erased. + ! RW 7/3/12. + + do nw=1,L_NSPECTI + fzeroi(nw) = 0.d0 +! do nt=1,L_NTREF +! do np=1,L_NPREF +! do nh=1,L_REFVAR +! do ng = 1,L_NGAUSS +! if(gasi8(nt,np,nh,nw,ng).lt.1.0e-25)then +! fzeroi(nw)=fzeroi(nw)+1.d0 +! endif +! end do +! end do +! end do +! end do +! fzeroi(nw)=fzeroi(nw)/dble(L_NTREF*L_NPREF*L_REFVAR*L_NGAUSS) + end do + + do nw=1,L_NSPECTV + fzerov(nw) = 0.d0 +! do nt=1,L_NTREF +! do np=1,L_NPREF +! do nh=1,L_REFVAR +! do ng = 1,L_NGAUSS +! if(gasv8(nt,np,nh,nw,ng).lt.1.0e-25)then +! fzerov(nw)=fzerov(nw)+1.d0 +! endif +! end do +! end do +! end do +! end do +! fzerov(nw)=fzerov(nw)/dble(L_NTREF*L_NPREF*L_REFVAR*L_NGAUSS) + end do + + endif ! if corrkdir=null + + else + gasi8(:,:,1,:,:)=0.0 ! dummy but needs to be initialized + endif ! use_premix + + ! Looking for others files corrk_gcm_IR_XXX.dat if needed + if (corrk_recombin) then + do igas=1,nrecomb_tot + + file_id='/corrk_data/'//trim(adjustl(banddir))//'/corrk_gcm_IR_'//trim(adjustl(noms(rcb2tot_idx(igas))))//'.dat' + file_path=TRIM(datadir)//TRIM(file_id) + + ! check that the file exists + inquire(FILE=file_path,EXIST=file_ok) + if(.not.file_ok) then + write(*,*)'The file ',TRIM(file_path) + write(*,*)'was not found by rad_correlatedk_read_opacity_tables .F90.' + write(*,*)'Are you sure you have absorption data for this specie at these bands?' + call abort_physic("rad_correlatedk_read_opacity_tables ", "No absorption data found", 1) + endif +!$OMP MASTER + open(111,file=TRIM(file_path),form='formatted') + read(111,*) gasi8(:,:,L_REFVAR+igas,:,:) + close(111) +!$OMP END MASTER +!$OMP BARRIER + enddo + endif ! corrk_recombin + +!$OMP MASTER + if(nIR_limit.eq.0) then + gasi8(:,:,:,:,:)= gasi8(:,:,:,:,:)+kappa_VI + else if (nIR_limit.eq.L_NSPECTI) then + gasi8(:,:,:,:,:)= gasi8(:,:,:,:,:)+kappa_IR + else + gasi8(:,:,:,1:nIR_limit,:)= gasi8(:,:,:,1:nIR_limit,:)+kappa_IR + gasi8(:,:,:,nIR_limit+1:L_NSPECTI,:)= gasi8(:,:,:,nIR_limit+1:L_NSPECTI,:)+kappa_VI + end if + + +! Take log10 of the values - this is what we will interpolate. +! Smallest value is 1.0E-200. + + do nt=1,L_NTREF + do np=1,L_NPREF + do nh=1,L_REFVAR+nrecomb_tot + do ng = 1,L_NGAUSS + + do nw=1,L_NSPECTV + if(gasv8(nt,np,nh,nw,ng).gt.1.0d-200) then + gasv8(nt,np,nh,nw,ng) = log10(gasv8(nt,np,nh,nw,ng)) + else + gasv8(nt,np,nh,nw,ng) = -200.0 + end if + end do + + do nw=1,L_NSPECTI + if(gasi8(nt,np,nh,nw,ng).gt.1.0d-200) then + gasi8(nt,np,nh,nw,ng) = log10(gasi8(nt,np,nh,nw,ng)) + else + gasi8(nt,np,nh,nw,ng) = -200.0 + end if + end do + + end do + end do + end do + end do +!$OMP END MASTER +!$OMP BARRIER + +! Interpolate the values: first the longwave + + do nt=1,L_NTREF + do nh=1,L_REFVAR+nrecomb_tot + do nw=1,L_NSPECTI + do ng=1,L_NGAUSS + +! First, the initial interval + + n = 1 + do m=1,5 + x = pfgasref(m) + xi(1) = pgasref(n) + xi(2) = pgasref(n+1) + xi(3) = pgasref(n+2) + xi(4) = pgasref(n+3) + yi(1) = gasi8(nt,n,nh,nw,ng) + yi(2) = gasi8(nt,n+1,nh,nw,ng) + yi(3) = gasi8(nt,n+2,nh,nw,ng) + yi(4) = gasi8(nt,n+3,nh,nw,ng) + call lagrange(x,xi,yi,ans) + gasi(nt,m,nh,nw,ng) = 10.0**ans + end do + + do n=2,L_NPREF-2 + do m=1,5 + i = (n-1)*5+m + x = pfgasref(i) + xi(1) = pgasref(n-1) + xi(2) = pgasref(n) + xi(3) = pgasref(n+1) + xi(4) = pgasref(n+2) + yi(1) = gasi8(nt,n-1,nh,nw,ng) + yi(2) = gasi8(nt,n,nh,nw,ng) + yi(3) = gasi8(nt,n+1,nh,nw,ng) + yi(4) = gasi8(nt,n+2,nh,nw,ng) + call lagrange(x,xi,yi,ans) + gasi(nt,i,nh,nw,ng) = 10.0**ans + end do + end do + +! Now, get the last interval + + n = L_NPREF-1 + do m=1,5 + i = (n-1)*5+m + x = pfgasref(i) + xi(1) = pgasref(n-2) + xi(2) = pgasref(n-1) + xi(3) = pgasref(n) + xi(4) = pgasref(n+1) + yi(1) = gasi8(nt,n-2,nh,nw,ng) + yi(2) = gasi8(nt,n-1,nh,nw,ng) + yi(3) = gasi8(nt,n,nh,nw,ng) + yi(4) = gasi8(nt,n+1,nh,nw,ng) + call lagrange(x,xi,yi,ans) + gasi(nt,i,nh,nw,ng) = 10.0**ans + end do + +! Fill the last pressure point + + gasi(nt,L_PINT,nh,nw,ng) = & + 10.0**gasi8(nt,L_NPREF,nh,nw,ng) + + end do + end do + end do + end do + +! Interpolate the values: now the shortwave + + do nt=1,L_NTREF + do nh=1,L_REFVAR+nrecomb_tot + do nw=1,L_NSPECTV + do ng=1,L_NGAUSS + +! First, the initial interval + + n = 1 + do m=1,5 + x = pfgasref(m) + xi(1) = pgasref(n) + xi(2) = pgasref(n+1) + xi(3) = pgasref(n+2) + xi(4) = pgasref(n+3) + yi(1) = gasv8(nt,n,nh,nw,ng) + yi(2) = gasv8(nt,n+1,nh,nw,ng) + yi(3) = gasv8(nt,n+2,nh,nw,ng) + yi(4) = gasv8(nt,n+3,nh,nw,ng) + call lagrange(x,xi,yi,ans) + gasv(nt,m,nh,nw,ng) = 10.0**ans + end do + + do n=2,L_NPREF-2 + do m=1,5 + i = (n-1)*5+m + x = pfgasref(i) + xi(1) = pgasref(n-1) + xi(2) = pgasref(n) + xi(3) = pgasref(n+1) + xi(4) = pgasref(n+2) + yi(1) = gasv8(nt,n-1,nh,nw,ng) + yi(2) = gasv8(nt,n,nh,nw,ng) + yi(3) = gasv8(nt,n+1,nh,nw,ng) + yi(4) = gasv8(nt,n+2,nh,nw,ng) + call lagrange(x,xi,yi,ans) + gasv(nt,i,nh,nw,ng) = 10.0**ans + end do + end do + +! Now, get the last interval + + n = L_NPREF-1 + do m=1,5 + i = (n-1)*5+m + x = pfgasref(i) + xi(1) = pgasref(n-2) + xi(2) = pgasref(n-1) + xi(3) = pgasref(n) + xi(4) = pgasref(n+1) + yi(1) = gasv8(nt,n-2,nh,nw,ng) + yi(2) = gasv8(nt,n-1,nh,nw,ng) + yi(3) = gasv8(nt,n,nh,nw,ng) + yi(4) = gasv8(nt,n+1,nh,nw,ng) + call lagrange(x,xi,yi,ans) + gasv(nt,i,nh,nw,ng) = 10.0**ans + end do + +! Fill the last pressure point + + gasv(nt,L_PINT,nh,nw,ng) = & + 10.0**gasv8(nt,L_NPREF,nh,nw,ng) + + end do + end do + end do + end do + +! Allocate and initialise arrays for corrk_recombin + if (corrk_recombin) call rad_correlatedk_recombination_setup + +!======================================================================= +! Initialise the continuum absorption data + if(continuum)then + + do igas=1,ngasmx ! we loop on all pairs of molecules that have data available + ! data can be downloaded from https://web.lmd.jussieu.fr/~lmdz/planets/generic/datagcm/continuum_data/ + if (igas .eq. igas_N2) then + file_id='/continuum_data/' // 'N2-N2_continuum_70-500K_2025.dat' + file_path=TRIM(datadir)//TRIM(file_id) + call rad_correlatedk_continuum_interpolation(file_path,igas_N2,igas_N2,'IR',1,300.D+0,10000.D+0,20000.D+0,testcont,.true.) + do jgas=1,ngasmx + if (jgas .eq. igas_H2) then + file_id='/continuum_data/' // 'H2-N2_continuum_40-600K_2025.dat' + file_path=TRIM(datadir)//TRIM(file_id) + call rad_correlatedk_continuum_interpolation(file_path,igas_N2,igas_H2,'IR',1,300.D+0,10000.D+0,20000.D+0,testcont,.true.) + elseif (jgas .eq. igas_O2) then + file_id='/continuum_data/' // 'O2-N2_continuum_100-500K_2025.dat' + file_path=TRIM(datadir)//TRIM(file_id) + call rad_correlatedk_continuum_interpolation(file_path,igas_N2,igas_O2,'IR',1,300.D+0,10000.D+0,20000.D+0,testcont,.true.) + elseif (jgas .eq. igas_CH4) then + file_id='/continuum_data/' // 'CH4-N2_continuum_40-600K_2025.dat' + file_path=TRIM(datadir)//TRIM(file_id) + call rad_correlatedk_continuum_interpolation(file_path,igas_N2,igas_CH4,'IR',1,300.D+0,10000.D+0,20000.D+0,testcont,.true.) + endif + enddo + elseif (igas .eq. igas_O2) then + file_id='/continuum_data/' // 'O2-O2_continuum_100-400K_2025.dat' + file_path=TRIM(datadir)//TRIM(file_id) + call rad_correlatedk_continuum_interpolation(file_path,igas_O2,igas_O2,'IR',1,300.D+0,10000.D+0,20000.D+0,testcont,.true.) + do jgas=1,ngasmx + if (jgas .eq. igas_CO2) then + file_id='/continuum_data/' // 'CO2-O2_continuum_150-600K_2025.dat' + file_path=TRIM(datadir)//TRIM(file_id) + call rad_correlatedk_continuum_interpolation(file_path,igas_CO2,igas_O2,'IR',1,300.D+0,10000.D+0,20000.D+0,testcont,.true.) + endif + enddo + elseif (igas .eq. igas_H2) then + file_id='/continuum_data/' // 'H2-H2_continuum_40-7000K_2025.dat' + file_path=TRIM(datadir)//TRIM(file_id) + call rad_correlatedk_continuum_interpolation(file_path,igas_H2,igas_H2,'IR',1,300.D+0,10000.D+0,20000.D+0,testcont,.true.) + do jgas=1,ngasmx + if (jgas .eq. igas_CH4) then + file_id='/continuum_data/' // 'H2-CH4_continuum_40-600K_2025.dat' + file_path=TRIM(datadir)//TRIM(file_id) + call rad_correlatedk_continuum_interpolation(file_path,igas_H2,igas_CH4,'IR',1,300.D+0,10000.D+0,20000.D+0,testcont,.true.) + elseif (jgas .eq. igas_He) then + file_id='/continuum_data/' // 'H2-He_continuum_40-5500K_2025.dat' + file_path=TRIM(datadir)//TRIM(file_id) + call rad_correlatedk_continuum_interpolation(file_path,igas_H2,igas_He,'IR',1,300.D+0,10000.D+0,20000.D+0,testcont,.true.) + endif + enddo + elseif (igas .eq. igas_CH4) then + file_id='/continuum_data/' // 'CH4-CH4_continuum_40-500K_2025.dat' + file_path=TRIM(datadir)//TRIM(file_id) + call rad_correlatedk_continuum_interpolation(file_path,igas_CH4,igas_CH4,'IR',1,300.D+0,10000.D+0,20000.D+0,testcont,.true.) + elseif (igas .eq. igas_H2O) then + file_id='/continuum_data/' // 'H2O-H2O_continuum_100-2000K_2025.dat' + file_path=TRIM(datadir)//TRIM(file_id) + call rad_correlatedk_continuum_interpolation(file_path,igas_H2O,igas_H2O,'IR',1,300.D+0,10000.D+0,20000.D+0,testcont,.true.) + do jgas=1,ngasmx + if (jgas .eq. igas_N2) then + file_id='/continuum_data/' // 'H2O-N2_continuum_100-2000K_2025.dat' + file_path=TRIM(datadir)//TRIM(file_id) + call rad_correlatedk_continuum_interpolation(file_path,igas_H2O,igas_N2,'IR',1,300.D+0,10000.D+0,20000.D+0,testcont,.true.) + elseif (jgas .eq. igas_O2) then + file_id='/continuum_data/' // 'H2O-O2_continuum_100-2000K_2025.dat' + file_path=TRIM(datadir)//TRIM(file_id) + call rad_correlatedk_continuum_interpolation(file_path,igas_H2O,igas_O2,'IR',1,300.D+0,10000.D+0,20000.D+0,testcont,.true.) + elseif (jgas .eq. igas_CO2) then + file_id='/continuum_data/' // 'H2O-CO2_continuum_100-800K_2025.dat' + file_path=TRIM(datadir)//TRIM(file_id) + call rad_correlatedk_continuum_interpolation(file_path,igas_H2O,igas_CO2,'IR',1,300.D+0,10000.D+0,20000.D+0,testcont,.true.) + endif + enddo + elseif (igas .eq. igas_CO2) then + file_id='/continuum_data/' // 'CO2-CO2_continuum_100-800K_2025.dat' + file_path=TRIM(datadir)//TRIM(file_id) + call rad_correlatedk_continuum_interpolation(file_path,igas_CO2,igas_CO2,'IR',1,300.D+0,10000.D+0,20000.D+0,testcont,.true.) + do jgas=1,ngasmx + if (jgas .eq. igas_H2) then + file_id='/continuum_data/' // 'CO2-H2_continuum_100-800K_2025.dat' + file_path=TRIM(datadir)//TRIM(file_id) + call rad_correlatedk_continuum_interpolation(file_path,igas_CO2,igas_H2,'IR',1,300.D+0,10000.D+0,20000.D+0,testcont,.true.) + elseif (jgas .eq. igas_CH4) then + file_id='/continuum_data/' // 'CO2-CH4_continuum_100-800K_2025.dat' + file_path=TRIM(datadir)//TRIM(file_id) + call rad_correlatedk_continuum_interpolation(file_path,igas_CO2,igas_CH4,'IR',1,300.D+0,10000.D+0,20000.D+0,testcont,.true.) + endif + enddo + endif + enddo ! igas=1,ngasmx + + endif ! continuum flag + + print*,'----------------------------------------------------' + print*,'And that`s all we have. It`s possible that other' + print*,'continuum absorption may be present, but if it is we' + print*,'don`t yet have data for it...' + print*,'' + +! Deallocate local arrays +!$OMP BARRIER +!$OMP MASTER + IF( ALLOCATED( gasi8 ) ) DEALLOCATE( gasi8 ) + IF( ALLOCATED( gasv8 ) ) DEALLOCATE( gasv8 ) + IF( ALLOCATED( pgasref ) ) DEALLOCATE( pgasref ) + IF( ALLOCATED( gastype ) ) DEALLOCATE( gastype ) +!$OMP END MASTER +!$OMP BARRIER + + end subroutine rad_correlatedk_read_opacity_tables Index: trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_stellar_spectrum.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_stellar_spectrum.F90 (revision 4077) +++ trunk/LMDZ.GENERIC/libf/phygeneric/rad_correlatedk_stellar_spectrum.F90 (revision 4077) @@ -0,0 +1,178 @@ + module rad_correlatedk_stellar_spectrum_mod + + implicit none + + contains + + subroutine rad_correlatedk_stellar_spectrum (STELLAR) + +!================================================================== +! +! Purpose +! ------- +! Average the chosen high resolution stellar spectrum over the +! visible bands in the model. +! +! Authors +! ------- +! Robin Wordsworth (2010). +! Generalized to very late spectral types (and Brown dwarfs) Jeremy Leconte (2012) +! Modified to account for any stellar spectrum file (Lucas Teinturier and Martin Turbet, 2023-2025) +! +! Called by +! --------- +! rad_correlatedk_init_stellar.F +! +! Calls +! ----- +! none +! +!================================================================== + + use radinc_h, only: L_NSPECTV + use radcommon_h, only: BWNV, DWNV, tstellar + use datafile_mod, only: datadir + use callkeys_mod, only: stelbbody,stelTbb + use ioipsl_getin_p_mod, only: getin_p + + implicit none + + real*8 STELLAR(L_NSPECTV) + + integer Nfine + integer,parameter :: Nfineband=200 + integer ifine,band + + real,allocatable,save :: lam(:),stel_f(:) ! read by master thread + ! but used by all threads + real lamm,lamp + real dl + + character(len=100) :: file_id,file_id_lam + character(len=200) :: file_path,file_path_lam + character(len=150) :: stelspec_file + + real lam_temp + double precision stel_temp + + integer :: ios ! file opening/reading status + logical :: file_exists + + STELLAR(:)=0.0 + + print*,'enter ave_stellspec' + if(stelbbody)then + tstellar=stelTbb + Nfine=L_NSPECTV*Nfineband + do band=1,L_NSPECTV + lamm=10000.0/BWNV(band+1) + lamp=10000.0/BWNV(band) + dl=(lamp-lamm)/(Nfineband) + do ifine=1,Nfineband + lam_temp=lamm+(lamp-lamm)*(ifine-1.)/(Nfineband) + call rad_blackbody_planck_law_wavelength(dble(lam_temp*1e-6),dble(tstellar),stel_temp) + STELLAR(band)=STELLAR(band)+stel_temp*dl + enddo + end do + STELLAR(1:L_NSPECTV)=STELLAR(1:L_NSPECTV)/sum(STELLAR(1:L_NSPECTV)) + else !stelbbody + ! look for a " tstellar= ..." option in def files + tstellar = -1. ! default + call getin_p("tstellar",tstellar) ! default path + if (tstellar.eq.-1.) then + write(*,*)'Beware that startype is now deprecated, you should use ' + write(*,*)'stelspec_file and tstellar to define the input stellar spectrum.' + write(*,*)' ' + write(*,*)'Error: tstellar (effective stellar temperature) needs to be specified' + write(*,*)'in callphys.def: tstellar=...' + call abort_physic("rad_correlatedk_stellar_spectrum", "tstellar needs to be specified",1) + end if + + write(*,*) "Input stellar temperature is:" + write(*,*) "tstellar = ",tstellar + + ! load high resolution stellar data + ! look for a " stelspec_file= ..." option in def files + stelspec_file = "None" ! default + call getin_p("stelspec_file",stelspec_file) ! default path + + write(*,*) "Input stellar spectrum file is:" + write(*,*) "stelspec_file = ",trim(stelspec_file) + write(*,*) 'Please use ',1,' and only ',1,' header line in ',trim(stelspec_file) + + ! Check the target file is there + file_path = trim(datadir)//'/stellar_spectra/'//stelspec_file + print*, 'stellar flux : ', file_path + inquire(FILE=file_path,EXIST=file_exists) + + if (.not.file_exists) THEN + write(*,*)'Beware that startype is now deprecated, you should use ' + write(*,*)'stelspec_file and tstellar to define the input stellar spectrum.' + write(*,*)' ' + write(*,*)'Error: cannot open stelspec_file file ', trim(stelspec_file) + write(*,*)'It should be in :',trim(datadir),'/stellar_spectra/' + write(*,*)'1) You can change the data directory in callphys.def' + write(*,*)' with:' + write(*,*)' datadir=/path/to/the/directory' + write(*,*)'2) You can change the input stelspec_file file name in' + write(*,*)' callphys.def with:' + write(*,*)' stelspec_file=filename' + write(*,*)'You can check the online repository to search for ' + write(*,*)'available stellar spectra here : ' + write(*,*)'https://web.lmd.jussieu.fr/~lmdz/planets/generic/datagcm/stellar_spectra/' + call abort_physic("rad_correlatedk_stellar_spectrum", "Unable to read stellar flux file", 1) + end if + +!$OMP MASTER + ! Open the file + OPEN(UNIT=110,FILE=file_path,STATUS='old',iostat=ios) + ! Get number of line in the file + READ(110,*) ! skip first line header just in case + Nfine = 0 + do + read(110,*,iostat=ios) + if (ios<0) exit + Nfine = Nfine + 1 + end do + rewind(110) ! Rewind file after counting lines + READ(110,*) ! skip first line header just in case + + allocate(lam(Nfine),stel_f(Nfine)) + + do ifine=1,Nfine + read(110,*) lam(ifine), stel_f(ifine) ! lam [um] stel_f [per unit of wavelength] (integrated and normalized by Fat1AU) + enddo + +!$OMP END MASTER +!$OMP BARRIER + + ! sum data by band + band=1 + Do while(lam(1).lt. real(10000.0/BWNV(band+1))) + if (band.gt.L_NSPECTV-1) exit + band=band+1 + enddo + dl=lam(2)-lam(1) + STELLAR(band)=STELLAR(band)+stel_f(1)*dl + do ifine = 2,Nfine + if(lam(ifine) .gt. real(10000.0/BWNV(band)))then + band=band-1 + endif + if(band .lt. 1) exit + dl=lam(ifine)-lam(ifine-1) + STELLAR(band)=STELLAR(band)+stel_f(ifine)*dl + end do + + + STELLAR(1:L_NSPECTV)=STELLAR(1:L_NSPECTV)/sum(STELLAR(1:L_NSPECTV)) +!$OMP BARRIER +!$OMP MASTER + deallocate(lam) + deallocate(stel_f) +!$OMP END MASTER +!$OMP BARRIER + endif !stelbbody + + end subroutine rad_correlatedk_stellar_spectrum + + end module rad_correlatedk_stellar_spectrum_mod Index: trunk/LMDZ.GENERIC/libf/phygeneric/rad_newton_cooling.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/rad_newton_cooling.F90 (revision 4077) +++ trunk/LMDZ.GENERIC/libf/phygeneric/rad_newton_cooling.F90 (revision 4077) @@ -0,0 +1,128 @@ +subroutine rad_netwon_cooling(ngrid,nlayer,mu0,sinlat,popsk,temp,pplay,pplev,dtrad,firstcall) + + use comcstfi_mod, only: rcp, pi + use callkeys_mod, only: tau_relax + implicit none + +#include "netcdf.inc" + +!================================================================== +! +! Purpose +! ------- +! Alternative Newtonian radiative transfer scheme. +! +! Authors +! ------- +! R. Wordsworth (2010) +! +!================================================================== + + + ! Input + integer,intent(in) :: ngrid, nlayer + logical,intent(in) :: firstcall + real,intent(in) :: mu0(ngrid) ! cosine of sun incident angle + real,intent(in) :: sinlat(ngrid) ! sine of latitude + real,intent(in) :: temp(ngrid,nlayer) ! temperature at each layer (K) + real,intent(in) :: pplay(ngrid,nlayer) ! pressure at each layer (Pa) + real,intent(in) :: pplev(ngrid,nlayer+1) ! pressure at each level (Pa) + real,intent(in) :: popsk(ngrid,nlayer) ! pot. T to T converter + + ! Output + real,intent(out) :: dtrad(ngrid,nlayer) + + ! Internal + real Trelax_V, Trelax_H + real,allocatable,dimension(:,:),save :: Trelax +!$OMP THREADPRIVATE(Trelax) + + real T_trop ! relaxation temperature at tropopause (K) + real T_surf ! relaxation temperature at surface (K) + real dT_EP ! Equator-Pole relaxation temperature difference (K) + + real sig, f_sig, sig_trop + integer l,ig + + + logical tidallocked + parameter (tidallocked = .true.) + + ! Setup relaxation temperature + if(firstcall) then + + ALLOCATE(Trelax(ngrid,nlayer)) + + print*,'-----------------------------------------------------' + print*,'| ATTENTION: You are using a Newtonian cooling scheme' + print*,'| for the radiative transfer. This means that ALL' + print*,'| other physics subroutines must be switched off.' + print*,'-----------------------------------------------------' + + if(tidallocked)then + do ig=1,ngrid + + T_surf = 126. + 239.*mu0(ig) + T_trop = 140. + 52.*mu0(ig) + do l=1,nlayer + + if(mu0(ig).le.0.0)then ! night side + Trelax(ig,l)=0.0 + else ! day side + Trelax(ig,l) = T_surf*popsk(ig,l) + if (Trelax(ig,l).lt.T_trop) Trelax(ig,l) = T_trop + endif + + enddo + enddo + + else + + T_trop = 200. + T_surf = 288. + dT_EP = 70. + + sig_trop=(T_trop/T_surf)**(1./rcp) + + do l=1,nlayer + do ig=1,ngrid + + ! vertically varying component + Trelax_V = T_surf*popsk(ig,l) + if (Trelax_V.lt.T_trop) Trelax_V = T_trop + + ! horizontally varying component + sig = pplay(ig,l)/pplev(ig,1) + if(sig.ge.sig_trop)then + f_sig=sin((pi/2)*((sig-sig_trop)/(1-sig_trop))) + else + f_sig=0.0 + endif + Trelax_H = -f_sig*dT_EP*(sinlat(ig)**2 - 1./3.) + + Trelax(ig,l) = Trelax_V + Trelax_H + + enddo + enddo + + endif + + endif + + ! Calculate radiative forcing + do l=1,nlayer + do ig=1,ngrid + dtrad(ig,l) = -(temp(ig,l) - Trelax(ig,l)) / tau_relax + if(temp(ig,l).gt.500.)then ! Trelax(ig,l))then + print*,'ig=',ig + print*,'l=',l + print*,'temp=',temp(ig,l) + print*,'Trelax=',Trelax(ig,l) + endif + enddo + enddo + + call writediagfi(ngrid,'Tref','rad forc temp','K',3,Trelax) + !call writediagfi(ngrid,'ThetaZ','stellar zenith angle','deg',2,mu0) + +end subroutine rad_netwon_cooling Index: trunk/LMDZ.GENERIC/libf/phygeneric/rad_newton_cooling_hot_jupiter.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/rad_newton_cooling_hot_jupiter.F90 (revision 4077) +++ trunk/LMDZ.GENERIC/libf/phygeneric/rad_newton_cooling_hot_jupiter.F90 (revision 4077) @@ -0,0 +1,182 @@ +module rad_netwon_cooling_hot_jupiter + + !========================================================================================== + ! Purpose + ! ------- + ! Compute a Newtonian cooling scheme for Hot Jupiters + ! for scenario 1 of the MOCHA intercomparaison project + ! (add citation to protocol paper here when it's live). + ! Check this paper's equations (1) and (4):https://iopscience.iop.org/article/10.3847/PSJ/ac9dfe/pdf + ! + ! We aim at having a generic code but you never know, it might need improving at some point. + ! The current (at time of writing) rad_netwon_cooling.F90 routine is hardcoded for telluric temperate planets and untested. + ! Thus, we don't use it and use this one instead. + ! + ! Authors + ! ------- + ! Lucas Teinturier (2024) + ! + !========================================================================================== + implicit none + + ! Module variables + real, allocatable, save :: T0(:) + real, allocatable, save :: tau_relax(:) + real, allocatable, save :: delta_Teq(:) + real, allocatable, save :: Trelax(:,:) + character(100),save :: planetary_suffix + !$OMP THREADPRIVATE(planetary_suffix, Trelax,tau_relax,T0,delta_Teq) + + contains + + subroutine rad_newton_cooling_MOCHA_intercomparison(ngrid,nlayer,coslon,coslat,temp,pplay,firstcall,lastcall,dtrad) + + ! use callkeys_mod, only: planetary_suffix ! this is to know which profiles to load for the T0, the delta Teq and the tau_rad + use mod_phys_lmdz_para, only : is_master, bcast ! for OpenMP stuff + implicit none + + ! Inputs + integer, intent(in) :: ngrid,nlayer + logical, intent(in) :: firstcall ! is it the first call of physiq_mod ? + logical, intent(in) :: lastcall !is it the last call of physiq_mod ? + real, intent(in) :: coslon(ngrid) !cosine of the longitude + real, intent(in) :: coslat(ngrid) ! cosine of the latitude + real, intent(in) :: temp(ngrid,nlayer) ! Temperature at each layer (K) + real, intent(in) :: pplay(ngrid,nlayer) ! Pressure mid-layers (Pa) + + ! Output + real, intent(out) :: dtrad(ngrid,nlayer) ! Tendency on temperature dT/dt (K/s) + + !! Internal variable + integer ig,l + character(100) :: filename + + if (firstcall) then + ! Allocation of the dynamical arrays + allocate(T0(nlayer)) + allocate(tau_relax(nlayer)) + allocate(delta_Teq(nlayer)) + allocate(Trelax(ngrid,nlayer)) + + if (is_master) then + print*,'-----------------------------------------------------' + print*,'| ATTENTION: You are using a Newtonian cooling scheme' + print*,'| for the radiative transfer. This means that ALL' + print*,'| other physics subroutines must be switched off.' + print*,'| Check that you have the required files in the ' + print*,'| simulation directory !' + print*,'-----------------------------------------------------' + print*,"the planetary suffix is ",planetary_suffix + + !! We load the data using the subroutine load_input + + ! Loading T0 + filename = trim(planetary_suffix) // "T0.dat" + ! print*,"filename = ",filename + call read_input(nlayer,filename,T0) + print*,"I successfully read",filename + + ! Loading tau_relax + filename = trim(planetary_suffix) // "tau_relax.dat" + call read_input(nlayer,filename,tau_relax) + print*,"I successfully read",filename + + ! Loading delta_Teq + filename = trim(planetary_suffix) // "delta_Teq.dat" + call read_input(nlayer,filename,delta_Teq) + print*,"I successfully read",filename + + endif ! of is_master + + ! Broadcast tau_relax and Trelax to everyone + call bcast(tau_relax) + call bcast(Trelax) + call bcast(T0) + call bcast(delta_Teq) + + ! now initialising Trelax depending on day or night side + do l=1,nlayer + do ig=1,ngrid + ! if we're on the day-side (the sub-stellar point is at lon =0, dayside is where the coslon >=0) + if (coslon(ig) .ge. 0) then + Trelax(ig,l) = T0(l)+delta_Teq(l)*(ABS(coslon(ig)*coslat(ig))-0.5) + else !we're on the night-side + Trelax(ig,l) = T0(l)-0.5*delta_Teq(l) + endif + enddo !ig=1,ngrid + enddo ! l=1,nlayer + + ! deallocate T0 and delta_Teq, we don't need them anymore + if (allocated(T0)) deallocate(T0) + if (allocated(delta_Teq)) deallocate(delta_Teq) + endif ! of firstcall + + ! call writediagfi(ngrid,"Trelax","Relaxation temperature ","K",3,Trelax) + ! Calculation of the radiative forcing + do l=1,nlayer + do ig=1,ngrid + if (pplay(ig,l) .le. 1.0e6) then + ! if pressure is lower than 10 bar + dtrad(ig,l) = (Trelax(ig,l)-temp(ig,l))/tau_relax(l) + else + ! Deeper than 10 bar, no relaxation, dtrad = 0 + dtrad(ig,l) = 0. + endif !(pplay(ig,l) .le. 1.e6) + enddo !ig =1,ngrid + enddo !l = 1,nlayer + + if (lastcall) then + deallocate(tau_relax) + deallocate(Trelax) + endif + + end subroutine rad_newton_cooling_MOCHA_intercomparison + + subroutine read_input(nlayer,filename, field) + + !======================================== + ! Purpose + ! ------- + ! Read the input file for this module + ! Each file starts with an integer that should + ! be equal to nlayer (stops if that's not true) + ! + ! Author + ! ------ + ! Lucas Teinturier(2024) + ! + !======================================== + + implicit none + + ! Inputs + integer,intent(in) :: nlayer + character(100),intent(in) :: filename + + ! Output + real, intent(out) :: field(nlayer) + + !! Internal variables + integer ierr, nline, ii + + ! Opening the file + open(401,form='formatted',status='old',file=trim(filename) ,iostat=ierr) + if (ierr /=0) then + print*,"Problem in rad_netwon_cooling_hot_jupiter.F90" + print*,"I have an issue opening file ",trim(filename) + call abort_physic("newton_cooling_hot_J", "Unable to read input file", 1) + endif + ! Checking that we have the right number of atmospheric layers + read(401,*) nline + if (nline /= nlayer) then + print*,"Error, you're not using the right # of atmospheric layers in ",trim(filename) + call abort_physic("newton_cooling_hot_J", "Number of layers does not match with number of lines in file", 1) + endif + ! Now reading the content of the file + do ii = 1,nline + read(401,*) field(ii) + enddo + close(401) + end subroutine read_input + +end module rad_netwon_cooling_hot_jupiter Index: trunk/LMDZ.GENERIC/libf/phygeneric/rad_ring_shadowing.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/rad_ring_shadowing.F90 (revision 4077) +++ trunk/LMDZ.GENERIC/libf/phygeneric/rad_ring_shadowing.F90 (revision 4077) @@ -0,0 +1,268 @@ +subroutine rad_ring_shadowing(ngrid, ptime, pday, diurnal) + ! A subroutine to compute the day fraction in case of rings shadowing. + + use radcommon_h, only: eclipse + use comsaison_h, only: fract, declin + use comcstfi_mod, only: rad, pi + use comdiurn_h, only: coslat, sinlat, coslon, sinlon + use callkeys_mod, only: flatten + + INTEGER, INTENT(IN) :: ngrid + REAL, INTENT(IN) :: ptime ! "universal time", given as fraction of sol (e.g.: 0.5 for noon) + REAL, INTENT(IN) :: pday ! Number of days counted from the North. Spring equinoxe. + LOGICAL, INTENT(IN) :: diurnal +! REAL, DIMENSION(:), INTENT(INOUT) :: fract ! day fraction for each point of the planet + +! to compute the daily average of rings shadowing + INTEGER, PARAMETER :: nb_hours = 1536 ! set how many times per day are used + REAL :: pas + INTEGER :: m + REAL :: ptime_day ! Universal time in sol fraction + REAL:: tmp_zls,tmp_dist_star, tmp_declin, tmp_right_ascen ! tmp solar longitude, stellar dist, declin and RA + REAL :: ztim1, ztim2, ztim3 + REAL, DIMENSION(:), ALLOCATABLE :: tmp_fract ! day fraction of the time interval + REAL, DIMENSION(:), ALLOCATABLE :: tmp_mu0 ! equivalent solar angle + +!! Eclipse incoming sunlight (e.g. Saturn ring shadowing) + ALLOCATE(eclipse(ngrid)) + + write(*,*) 'Rings shadow activated' + + if(diurnal .eqv. .false.) then ! we need to compute the daily average insolation (day fraction) + pas = 1./nb_hours + ptime_day = 0. + fract(:) = 0. + ALLOCATE(tmp_fract(ngrid)) + ALLOCATE(tmp_mu0(ngrid)) + tmp_fract(:) = 0. + eclipse(:) = 0. + tmp_mu0(:) = 0. + + do m=1, nb_hours + ptime_day = m*pas + call ephemeris_stellar_longitude(pday+ptime_day,tmp_zls) + call ephemeris_orbit(tmp_zls,tmp_dist_star,tmp_declin,tmp_right_ascen) + + ztim1=SIN(tmp_declin) + ztim2=COS(tmp_declin)*COS(2.*pi*(pday+ptime_day-.5)) + ztim3=-COS(tmp_declin)*SIN(2.*pi*(pday+ptime_day-.5)) + + call ephemeris_stellar_angle(ngrid,sinlon,coslon,sinlat,coslat, & + ztim1,ztim2,ztim3,tmp_mu0,tmp_fract, flatten) + call saturn_rings(ngrid, tmp_declin, ptime_day, rad, flatten, eclipse) + fract(:) = fract(:) + (1.-eclipse(:))*tmp_fract(:) !! fract takes into account the rings shadow and the day/night alternation + + enddo + + fract(:) = fract(:)/nb_hours + + DEALLOCATE(tmp_fract) + DEALLOCATE(tmp_mu0) + + else ! instant insolation is weighted by the rings shadow + call saturn_rings(ngrid, declin, ptime, rad, 0., eclipse) + fract(:) = fract(:) * (1.-eclipse) + endif + + IF (ALLOCATED(eclipse)) DEALLOCATE(eclipse) + +end subroutine rad_ring_shadowing + + +SUBROUTINE saturn_rings(ngrid, declin, ptime, rad, flat, eclipse) +! Calculates Saturn's rings shadowing +! Includes rings opacities measured by Cassini/UVIS +! Authors: M. Sylvestre, M. Capderou, S. Guerlet, A. Spiga + + use comdiurn_h, only: sinlat, sinlon, coslat, coslon + use geometry_mod, only: latitude ! (rad) + + implicit none + + INTEGER, INTENT(IN) :: ngrid ! horizontal grid dimension + REAL, INTENT(IN) :: declin ! latitude of the subsolar point + REAL, INTENT(IN) :: ptime ! UTC time in sol fraction : ptime=0.5 at noon + REAL, INTENT(IN) :: rad ! equatorial radius of the planet + REAL, INTENT(IN) :: flat ! flattening of the planet + REAL, DIMENSION(ngrid), INTENT(OUT) :: eclipse ! absorption of the light by the rings + + REAL :: rpol ! polar radius of the planet + REAL :: e ! shape excentricity of the planet : (1-e*e) = (1-f)*(1-f) + INTEGER, PARAMETER :: nb_a = 4 ! number of subdivisions of the A ring + INTEGER, PARAMETER :: nb_b = 3 ! number of subdivisions of the B ring + INTEGER, PARAMETER :: nb_c = 3 ! number of subdivisions of the C ring + INTEGER, PARAMETER :: nb_ca = 2 ! number of subdivisions in the Cassini division + INTEGER :: i + + ! arrays for the rings. TBD: dynamical? + REAL, DIMENSION(nb_a) :: A_Rint ! internal radii of the subdivisions of the A ring + REAL, DIMENSION(nb_a) :: A_Rext ! external radii of the subdivisions of the A ring + REAL, DIMENSION(nb_b) :: B_Rint ! internal radii of the subdivisions of the B ring + REAL, DIMENSION(nb_b) :: B_Rext ! external radii of the subdivisions of the B ring + REAL, DIMENSION(nb_c) :: C_Rint ! internal radii of the subdivisions of the C ring + REAL, DIMENSION(nb_c) :: C_Rext ! external radii of the subdivisions of the C ring + REAL, DIMENSION(nb_ca) :: Ca_Rint ! internal radii of the subdivisions of the Cassini Division + REAL, DIMENSION(nb_ca) :: Ca_Rext ! external radii of the subdivisions of the Cassini Division + + ! Opacities of the rings : for each one we can give different opacities for each part + REAL, DIMENSION(nb_a) :: tau_A ! opacity of the A ring + REAL, DIMENSION(nb_b) :: tau_B ! opacity of the B ring + REAL, DIMENSION(nb_c) :: tau_C ! opacity of the C ring + REAL, DIMENSION(nb_ca) :: tau_Ca ! opacity of the Cassini Division + + ! Parameters used to calculate if a point is under a ring subdivision's shadow + REAL :: phi_S ! subsolar point longitude + REAL, PARAMETER :: pi=acos(-1.0) + REAL, DIMENSION(:), ALLOCATABLE:: x, y, z ! cartesian coordinates of the points on the planet + REAL :: xs, ys, zs ! cartesian coordinates of the points of the subsolar point + REAL, DIMENSION(:), ALLOCATABLE :: k + REAL, DIMENSION(:), ALLOCATABLE :: N ! parameter to compute cartesian coordinates on a ellipsoidal planet + REAL, DIMENSION(:), ALLOCATABLE :: r ! distance at which the incident ray of sun crosses the equatorial plane + ! measured from the center of the planet + REAL :: Ns ! (same for the subsolar point) + + ! equinox --> no shadow (AS: why is this needed?) + if(declin .eq. 0.) then + eclipse(:) = 0. + return + endif + +! 1) INITIALIZATION + + ! Generic + rpol = (1.- flat)*rad + e = sqrt(2*flat - flat**2) + ALLOCATE(x(ngrid)) + ALLOCATE(y(ngrid)) + ALLOCATE(z(ngrid)) + ALLOCATE(k(ngrid)) + ALLOCATE(N(ngrid)) + ALLOCATE(r(ngrid)) + eclipse(:) = 2000. + +! Model of the rings with Cassini/UVIS opacities + + ! Size of the rings + A_Rint(1) = 2.03*rad + A_Rext(1) = 2.06*rad + A_Rint(2) = 2.06*rad + A_Rext(2) = 2.09*rad + A_Rint(3) = 2.09*rad + A_Rext(3) = 2.12*rad + A_Rint(4) = 2.12*rad + A_Rext(4) = 2.27*rad + + B_Rint(1) = 1.53*rad + B_Rext(1) = 1.64*rad + B_Rint(2) = 1.64*rad + B_Rext(2) = 1.83*rad + B_Rint(3) = 1.83*rad + B_Rext(3) = 1.95*rad + + C_Rint(1) = 1.24*rad + C_Rext(1) = 1.29*rad + C_Rint(2) = 1.29*rad + C_Rext(2) = 1.43*rad + C_Rint(3) = 1.43*rad + C_Rext(3) = 1.53*rad + + Ca_Rint(1) = 1.95*rad + Ca_Rext(1) = 1.99*rad + Ca_Rint(2) = 1.99*rad + Ca_Rext(2) = 2.03*rad + + + ! Opacities of the rings + tau_A(1) = 1.24 + tau_A(2) = 0.81 + tau_A(3) = 0.67 + tau_A(4) = 0.58 + + tau_B(1) = 1.29 + tau_B(2) = 5.13 + tau_B(3) = 2.84 + + tau_C(1) = 0.06 + tau_C(2) = 0.10 + tau_C(3) = 0.14 + + tau_Ca(1) = 0.06 + tau_Ca(2) = 0.24 + + ! Convert to cartesian coordinates + N(:) = rad / sqrt(1-(e**2)*sinlat(:)**2) + x(:) = N(:)*coslat(:)*coslon(:) + y(:) = N(:)*coslat(:)*sinlon(:) + z(:) = N(:)*(1-e**2)*sinlat(:) + +! 2) LOCATION OF THE SUBSOLAR POINT + + ! subsolar longitude is deduced from time fraction ptime + ! SG: the minus sign is important! ... otherwise subsolar point adopts a reverse rotation + phi_S = -(ptime - 0.5)*2.*pi +! write(*,*) 'subsol point coords : ', declin*180./pi, phi_S*180./pi + + ! subsolar latitude is declin (declination of the sun) + ! now convert in cartesian coordinates : + Ns = rad/sqrt(1-(e**2)*sin(declin)**2) + xs = Ns*cos(declin)*cos(phi_S) + ys = Ns*cos(declin)*sin(phi_S) + zs = Ns*(1-e**2)*sin(declin) + +! 3) WHERE DOES THE INCIDENT RAY OF SUN CROSS THE EQUATORIAL PLAN ? + + k(:) = -z(:)/zs + r(:) = (k(:)*xs + x(:))**2 + (k(:)*ys + y(:))**2 + r(:) = sqrt(r(:)) + +! 4) SO WHERE ARE THE SHADOW OF THESE RINGS ? + + ! Summer hemisphere is not under the shadow of the rings + where(latitude(:)*declin .gt. 0.) + eclipse(:) = 1000. + end where + + ! No shadow of the rings by night + where(x(:)*xs + y(:)*ys + z(:)*zs .lt. 0.) + eclipse(:) = 1000. + end where + + ! if the incident rays of sun cross a ring, there is a shadow + do i=1, nb_A + where(r(:) .ge. A_Rint(i) .and. r(:) .le. A_Rext(i) .and. eclipse(:) .ne. 1000.) + eclipse(:) = 1. - exp(-tau_A(i)/abs(sin(declin))) + end where + end do + + do i=1, nb_B + where(r(:) .ge. B_Rint(i) .and. r(:) .le. B_Rext(i) .and. eclipse(:) .ne. 1000.) + eclipse(:) = 1. - exp(-tau_B(i)/abs(sin(declin))) + end where + enddo + + do i=1, nb_C + where(r(:) .ge. C_Rint(i) .and. r(:) .le. C_Rext(i) .and. eclipse(:) .ne. 1000.) + eclipse(:) = 1. - exp(-tau_C(i)/abs(sin(declin))) + end where + enddo + + do i=1, nb_ca + where(r(:) .ge. Ca_Rint(i) .and. r(:) .le. Ca_Rext(i) .and. eclipse(:) .ne. 1000.) + eclipse(:) = 1. - exp(-tau_Ca(i)/abs(sin(declin))) + end where + enddo + + ! At the other places and the excluded ones, eclipse is 0. + where(eclipse(:) .eq. 2000. .or. eclipse(:) .eq. 1000.) + eclipse(:) = 0. + end where + +! 5) CLEAN THE PLACE + DEALLOCATE(x) + DEALLOCATE(y) + DEALLOCATE(z) + DEALLOCATE(k) + DEALLOCATE(N) + DEALLOCATE(r) + +END SUBROUTINE saturn_rings Index: trunk/LMDZ.GENERIC/libf/phygeneric/rad_tridiagonal_matrix_solver.F =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/rad_tridiagonal_matrix_solver.F (revision 4077) +++ trunk/LMDZ.GENERIC/libf/phygeneric/rad_tridiagonal_matrix_solver.F (revision 4077) @@ -0,0 +1,103 @@ + SUBROUTINE rad_tridiagonal_matrix_solver(NL, + * GAMA,CP,CM,CPM1,CMM1,E1,E2,E3,E4, + * BTOP,BSURF,RSF,XK1,XK2) + +C GCM2.0 Feb 2003 +C +C DOUBLE PRECISION VERSION OF SOLVER + +!! PARAMETER (NMAX=201) + IMPLICIT REAL*8 (A-H,O-Z) + DIMENSION GAMA(NL),CP(NL),CM(NL),CPM1(NL),CMM1(NL),XK1(NL), + * XK2(NL),E1(NL),E2(NL),E3(NL),E4(NL) + DIMENSION AF(2*NL),BF(2*NL),CF(2*NL),DF(2*NL),XK(2*NL) +C********************************************************* +C* THIS SUBROUTINE SOLVES FOR THE COEFFICIENTS OF THE * +C* TWO STREAM SOLUTION FOR GENERAL BOUNDARY CONDITIONS * +C* NO ASSUMPTION OF THE DEPENDENCE ON OPTICAL DEPTH OF * +C* C-PLUS OR C-MINUS HAS BEEN MADE. * +C* NL = NUMBER OF LAYERS IN THE MODEL * +C* CP = C-PLUS EVALUATED AT TAO=0 (TOP) * +C* CM = C-MINUS EVALUATED AT TAO=0 (TOP) * +C* CPM1 = C-PLUS EVALUATED AT TAOSTAR (BOTTOM) * +C* CMM1 = C-MINUS EVALUATED AT TAOSTAR (BOTTOM) * +C* EP = EXP(LAMDA*DTAU) * +C* EM = 1/EP * +C* E1 = EP + GAMA *EM * +C* E2 = EP - GAMA *EM * +C* E3 = GAMA*EP + EM * +C* E4 = GAMA*EP - EM * +C* BTOP = THE DIFFUSE RADIATION INTO THE MODEL AT TOP * +C* BSURF = THE DIFFUSE RADIATION INTO THE MODEL AT * +C* THE BOTTOM: INCLUDES EMMISION AND REFLECTION * +C* OF THE UNATTENUATED PORTION OF THE DIRECT * +C* BEAM. BSTAR+RSF*FO*EXP(-TAOSTAR/U0) * +C* RSF = REFLECTIVITY OF THE SURFACE * +C* XK1 = COEFFICIENT OF THE POSITIVE EXP TERM * +C* XK2 = COEFFICIENT OF THE NEGATIVE EXP TERM * +C********************************************************* + +C======================================================================C + + L=2*NL + +C ************MIXED COEFFICENTS********** +C THIS VERSION AVOIDS SINGULARITIES ASSOC. +C WITH W0=0 BY SOLVING FOR XK1+XK2, AND XK1-XK2. + + AF(1) = 0.0 + BF(1) = GAMA(1)+1. + CF(1) = GAMA(1)-1. + DF(1) = BTOP-CMM1(1) + N = 0 + LM2 = L-2 + +C EVEN TERMS + + DO I=2,LM2,2 + N = N+1 + AF(I) = (E1(N)+E3(N))*(GAMA(N+1)-1.) + BF(I) = (E2(N)+E4(N))*(GAMA(N+1)-1.) + CF(I) = 2.0*(1.-GAMA(N+1)**2) + DF(I) = (GAMA(N+1)-1.) * (CPM1(N+1) - CP(N)) + + * (1.-GAMA(N+1))* (CM(N)-CMM1(N+1)) + END DO + + N = 0 + LM1 = L-1 + DO I=3,LM1,2 + N = N+1 + AF(I) = 2.0*(1.-GAMA(N)**2) + BF(I) = (E1(N)-E3(N))*(1.+GAMA(N+1)) + CF(I) = (E1(N)+E3(N))*(GAMA(N+1)-1.) + DF(I) = E3(N)*(CPM1(N+1) - CP(N)) + E1(N)*(CM(N) - CMM1(N+1)) + END DO + + AF(L) = E1(NL)-RSF*E3(NL) + BF(L) = E2(NL)-RSF*E4(NL) + CF(L) = 0.0 + DF(L) = BSURF-CP(NL)+RSF*CM(NL) + + CALL DTRIDGL(L,AF,BF,CF,DF,XK) + +C ***UNMIX THE COEFFICIENTS**** + + DO 28 N=1,NL + XK1(N) = XK(2*N-1)+XK(2*N) + XK2(N) = XK(2*N-1)-XK(2*N) + +C NOW TEST TO SEE IF XK2 IS REALLY ZERO TO THE LIMIT OF THE +C MACHINE ACCURACY = 1 .E -30 +C XK2 IS THE COEFFICEINT OF THE GROWING EXPONENTIAL AND MUST +C BE TREATED CAREFULLY + + IF(XK2(N) .EQ. 0.0) GO TO 28 +c IF (ABS (XK2(N)/XK(2*N-1)) .LT. 1.E-30) XK2(N)=0.0 + + IF (ABS (XK2(N)/(XK(2*N-1)+1.e-20)) .LT. 1.E-30) XK2(N)=0.0 ! For debug only (with -Ktrap=fp option) + + + 28 CONTINUE + + RETURN + END Index: trunk/LMDZ.GENERIC/libf/phygeneric/radcommon_h.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/radcommon_h.F90 (revision 4062) +++ trunk/LMDZ.GENERIC/libf/phygeneric/radcommon_h.F90 (revision 4077) @@ -63,6 +63,6 @@ ! - REAL*8 BWNI(L_NSPECTI+1), WNOI(L_NSPECTI), DWNI(L_NSPECTI), WAVEI(L_NSPECTI) !BWNI read by master in setspi - REAL*8 BWNV(L_NSPECTV+1), WNOV(L_NSPECTV), DWNV(L_NSPECTV), WAVEV(L_NSPECTV) !BWNV read by master in setspv + REAL*8 BWNI(L_NSPECTI+1), WNOI(L_NSPECTI), DWNI(L_NSPECTI), WAVEI(L_NSPECTI) !BWNI read by master in rad_correlatedk_init_thermal + REAL*8 BWNV(L_NSPECTV+1), WNOV(L_NSPECTV), DWNV(L_NSPECTV), WAVEV(L_NSPECTV) !BWNV read by master in rad_correlatedk_init_stellar REAL*8 STELLARF(L_NSPECTV) !$OMP THREADPRIVATE(WNOI,DWNI,WAVEI,& @@ -81,6 +81,6 @@ real*8 pgasmin, pgasmax real*8 tgasmin, tgasmax -!$OMP THREADPRIVATE(gasi,gasv,& !wrefvar,pgasref,tgasref,pfgasref read by master in sugas_corrk - !$OMP FZEROI,FZEROV) !pgasmin,pgasmax,tgasmin,tgasmax read by master in sugas_corrk +!$OMP THREADPRIVATE(gasi,gasv,& !wrefvar,pgasref,tgasref,pfgasref read by master in rad_correlatedk_read_opacity_tables + !$OMP FZEROI,FZEROV) !pgasmin,pgasmax,tgasmin,tgasmax read by master in rad_correlatedk_read_opacity_tables real,allocatable,save :: QVISsQREF(:,:,:) @@ -102,5 +102,5 @@ integer,allocatable,save :: nsize(:,:) -!$OMP THREADPRIVATE(nsize) ! nsize filled by suaer_corrk +!$OMP THREADPRIVATE(nsize) ! nsize filled by rad_correlatedk_ini_aerosol ! Particle size axis (depend on the kind of aerosol and the @@ -111,5 +111,5 @@ ! Extinction coefficient at reference wavelengths; -! These wavelengths are defined in aeroptproperties, and called +! These wavelengths are defined in aerosol_optical_properties, and called ! longrefvis and longrefir. @@ -127,5 +127,5 @@ real*8,parameter :: UBARI = 0.5D0 -!$OMP THREADPRIVATE(QREFvis,QREFir,omegaREFir,& ! gweight read by master in sugas_corrk +!$OMP THREADPRIVATE(QREFvis,QREFir,omegaREFir,& ! gweight read by master in rad_correlatedk_read_opacity_tables !$OMP tstellar,planckir,PTOP) Index: trunk/LMDZ.GENERIC/libf/phygeneric/radii_mod.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/radii_mod.F90 (revision 4062) +++ (revision ) @@ -1,432 +1,0 @@ -!================================================================== -module radii_mod -!================================================================== -! module to centralize the radii calculations for aerosols -!================================================================== - -! CO2 cloud properties (initialized in inifis) - real,save :: Nmix_co2 ! Number mixing ratio of CO2 ice particles -!$OMP THREADPRIVATE(Nmix_co2) - - ! flag to specify if we assume a constant fixed radius for particles - logical,save :: radfixed ! initialized in inifis -!$OMP THREADPRIVATE(radfixed) - -! water cloud optical properties (initialized in su_aer_radii below) - real, save :: rad_h2o - real, save :: rad_h2o_ice - real, save :: Nmix_h2o - real, save :: Nmix_h2o_ice -!$OMP THREADPRIVATE(rad_h2o,rad_h2o_ice,Nmix_h2o,Nmix_h2o_ice) - - real,save :: nueff_iaero_h2o ! effective variance of H2O aerosol - ! (initialized in su_aer_radii below) -!$OMP THREADPRIVATE(nueff_iaero_h2o) -! coefficients for a variable nueff() for h2o aerosol; disabled for now - real, parameter :: coef_hot=0.13 - real, parameter :: coef_cold=0.09 - - -contains - - -!================================================================== - subroutine su_aer_radii(ngrid,nlayer,reffrad,nueffrad) -!================================================================== -! Purpose -! ------- -! Compute the effective radii of liquid and icy water particles -! Jeremy Leconte (2012) -! Extended to dust, CO2, NH3, 2-lay,Nlay,auroral aerosols by ?? -! Added Radiative Generic Condensable Species effective radii -! calculations (Lucas Teinturier 2022) -! -! Authors -! ------- -! Jeremy Leconte (2012) -! -!================================================================== - use mod_phys_lmdz_para, only : is_master - use ioipsl_getin_p_mod, only: getin_p - use radinc_h, only: naerkind - use aerosol_mod, only: iaero_back2lay, iaero_co2, iaero_dust, & - iaero_h2o, iaero_h2so4, iaero_nh3, iaero_nlay, & - iaero_aurora, iaero_generic, i_rgcs_ice, & - iaero_venus1, iaero_venus2, iaero_venus2p, & - iaero_venus3, iaero_venusUV - use callkeys_mod, only: size_nh3_cloud, nlayaero, aeronlay_size, & - aeronlay_nueff,aerogeneric - use tracer_h, only: radius, nqtot, is_rgcs - Implicit none - - integer,intent(in) :: ngrid - integer,intent(in) :: nlayer - - real, intent(out) :: reffrad(ngrid,nlayer,naerkind) !aerosols radii (K) - real, intent(out) :: nueffrad(ngrid,nlayer,naerkind) !variance - - logical, save :: firstcall=.true. -!$OMP THREADPRIVATE(firstcall) - integer :: iaer, ia , iq, i_rad - - do iaer=1,naerkind -! these values will change once the microphysics gets to work -! UNLESS tracer=.false., in which case we should be working with -! a fixed aerosol layer, and be able to define reffrad in a -! .def file. To be improved! -! |-> Done in th n-layer aerosol case (JVO 20) - - if(iaer.eq.iaero_co2)then ! CO2 ice - reffrad(1:ngrid,1:nlayer,iaer) = 1.e-4 - nueffrad(1:ngrid,1:nlayer,iaer) = 0.1 - endif - - if(iaer.eq.iaero_h2o)then ! H2O ice - nueff_iaero_h2o=0.1 ! default value for variance of h2o aerosols - call getin_p("nueff_iaero_h2o",nueff_iaero_h2o) - if (is_master) write(*,*)" nueff_iaero_h2o = ",nueff_iaero_h2o - reffrad(1:ngrid,1:nlayer,iaer) = 1.e-5 - nueffrad(1:ngrid,1:nlayer,iaer) = nueff_iaero_h2o - endif - - if(iaer.eq.iaero_dust)then ! dust - reffrad(1:ngrid,1:nlayer,iaer) = 1.e-5 - nueffrad(1:ngrid,1:nlayer,iaer) = 0.1 - endif - - if(iaer.eq.iaero_h2so4)then ! H2SO4 ice - reffrad(1:ngrid,1:nlayer,iaer) = 1.e-6 - nueffrad(1:ngrid,1:nlayer,iaer) = 0.1 - endif - - if(iaer.eq.iaero_back2lay)then ! Two-layer aerosols - reffrad(1:ngrid,1:nlayer,iaer) = 2.e-6 - nueffrad(1:ngrid,1:nlayer,iaer) = 0.1 - endif - - - if(iaer.eq.iaero_nh3)then ! Nh3 cloud - reffrad(1:ngrid,1:nlayer,iaer) = size_nh3_cloud - nueffrad(1:ngrid,1:nlayer,iaer) = 0.1 - endif - - do ia=1,nlayaero - if(iaer.eq.iaero_nlay(ia))then ! N-layer aerosols - reffrad(1:ngrid,1:nlayer,iaer) = aeronlay_size(ia) - nueffrad(1:ngrid,1:nlayer,iaer) = aeronlay_nueff(ia) - endif - enddo - - if(iaer.eq.iaero_aurora)then ! Auroral aerosols - reffrad(1:ngrid,1:nlayer,iaer) = 3.e-7 - nueffrad(1:ngrid,1:nlayer,iaer) = 0.1 - endif - - if(iaer.eq.iaero_venus1)then ! Venus cloud, mode 1, Haus13 model - reffrad(1:ngrid,1:nlayer,iaer) = 0.49e-6 - nueffrad(1:ngrid,1:nlayer,iaer) = 0.21 - endif - - if(iaer.eq.iaero_venus2)then ! Venus cloud, mode 2, Haus13 model - reffrad(1:ngrid,1:nlayer,iaer) = 1.23e-6 - nueffrad(1:ngrid,1:nlayer,iaer) = 0.067 - endif - - if(iaer.eq.iaero_venus2p)then ! Venus cloud, mode 2p, Haus13 model - reffrad(1:ngrid,1:nlayer,iaer) = 1.56e-6 - nueffrad(1:ngrid,1:nlayer,iaer) = 0.044 - endif - - if(iaer.eq.iaero_venus3)then ! Venus cloud, mode 3, Haus13 model - reffrad(1:ngrid,1:nlayer,iaer) = 4.25e-6 - nueffrad(1:ngrid,1:nlayer,iaer) = 0.062 - endif - - if(iaer.eq.iaero_venusUV)then ! Venus cloud, UV abs, 1 val as in table - reffrad(1:ngrid,1:nlayer,iaer) = 0.5e-6 - nueffrad(1:ngrid,1:nlayer,iaer) = 0.1 - endif - - do ia=1,aerogeneric ! Radiative Generic Condensable Species - if (iaer .eq. iaero_generic(ia)) then - i_rad = i_rgcs_ice(ia) - reffrad(1:ngrid,1:nlayer,iaer)=radius(i_rad) - nueffrad(1:ngrid,1:nlayer,iaer) = 0.1 - endif - enddo ! generic radiative condensable aerosols - - enddo ! iaer=1,naerkind - - - if (radfixed) then - - if (is_master) write(*,*)"radius of H2O water particles:" - rad_h2o=13. ! default value - call getin_p("rad_h2o",rad_h2o) - if (is_master) write(*,*)" rad_h2o = ",rad_h2o - - if (is_master) write(*,*)"radius of H2O ice particles:" - rad_h2o_ice=35. ! default value - call getin_p("rad_h2o_ice",rad_h2o_ice) - if (is_master) write(*,*)" rad_h2o_ice = ",rad_h2o_ice - - else - - if (is_master) write(*,*)"Number mixing ratio of H2O water particles:" - Nmix_h2o=1.e6 ! default value - call getin_p("Nmix_h2o",Nmix_h2o) - if (is_master) write(*,*)" Nmix_h2o = ",Nmix_h2o - - if (is_master) write(*,*)"Number mixing ratio of H2O ice particles:" - Nmix_h2o_ice=Nmix_h2o ! default value - call getin_p("Nmix_h2o_ice",Nmix_h2o_ice) - if (is_master) write(*,*)" Nmix_h2o_ice = ",Nmix_h2o_ice - endif - - - end subroutine su_aer_radii -!================================================================== - - -!================================================================== - subroutine h2o_reffrad(ngrid,nlayer,pq,pt,reffrad,nueffrad) -!================================================================== -! Purpose -! ------- -! Compute the effective radii of liquid and icy water particles -! -! Authors -! ------- -! Jeremy Leconte (2012) -! -!================================================================== - use watercommon_h, Only: T_h2O_ice_liq,T_h2O_ice_clouds,rhowater,rhowaterice - use comcstfi_mod, only: pi - Implicit none - - integer,intent(in) :: ngrid - integer,intent(in) :: nlayer - - real, intent(in) :: pq(ngrid,nlayer) !water ice mixing ratios (kg/kg) - real, intent(in) :: pt(ngrid,nlayer) !temperature (K) - real, intent(out) :: reffrad(ngrid,nlayer) !aerosol radii - real, intent(out) :: nueffrad(ngrid,nlayer) ! dispersion - - integer :: ig,l - real zfice ,zrad,zrad_liq,zrad_ice - real,external :: CBRT - - - if (radfixed) then - do l=1,nlayer - do ig=1,ngrid - zfice = 1.0 - (pt(ig,l)-T_h2O_ice_clouds) / (T_h2O_ice_liq-T_h2O_ice_clouds) - zfice = MIN(MAX(zfice,0.0),1.0) - reffrad(ig,l)= rad_h2o * (1.-zfice) + rad_h2o_ice * zfice -! nueffrad(ig,l) = coef_hot * (1.-zfice) + coef_cold * zfice - enddo - enddo - else - do l=1,nlayer - do ig=1,ngrid - zfice = 1.0 - (pt(ig,l)-T_h2O_ice_clouds) / (T_h2O_ice_liq-T_h2O_ice_clouds) - zfice = MIN(MAX(zfice,0.0),1.0) - zrad_liq = CBRT( 3*pq(ig,l)/(4*Nmix_h2o*pi*rhowater) ) - zrad_ice = CBRT( 3*pq(ig,l)/(4*Nmix_h2o_ice*pi*rhowaterice) ) -! nueffrad(ig,l) = coef_hot * (1.-zfice) + coef_cold * zfice - zrad = zrad_liq * (1.-zfice) + zrad_ice * zfice - - reffrad(ig,l) = min(max(zrad,1.e-6),1000.e-6) - enddo - enddo - end if - -! For now only constant nueff is enabled (otherwise some specific handling -! of variable nueff is required in aeroptproperties) - nueffrad(1:ngrid,1:nlayer)=nueff_iaero_h2o - - end subroutine h2o_reffrad -!================================================================== - - -!================================================================== - subroutine h2o_cloudrad(ngrid,nlayer,pql,reffliq,reffice) -!================================================================== -! Purpose -! ------- -! Compute the effective radii of liquid and icy water particles -! -! Authors -! ------- -! Jeremy Leconte (2012) -! -!================================================================== - use watercommon_h, Only: rhowater,rhowaterice - use comcstfi_mod, only: pi - Implicit none - - integer,intent(in) :: ngrid - integer,intent(in) :: nlayer - - real, intent(in) :: pql(ngrid,nlayer) !condensed water mixing ratios (kg/kg) - real, intent(out) :: reffliq(ngrid,nlayer),reffice(ngrid,nlayer) !liquid and ice water particle radii (m) - - real,external :: CBRT - integer :: i,k - - if (radfixed) then - reffliq(1:ngrid,1:nlayer)= rad_h2o - reffice(1:ngrid,1:nlayer)= rad_h2o_ice - else - do k=1,nlayer - do i=1,ngrid - reffliq(i,k) = CBRT(3*pql(i,k)/(4*Nmix_h2o*pi*rhowater)) - reffliq(i,k) = min(max(reffliq(i,k),1.e-6),1000.e-6) - - reffice(i,k) = CBRT(3*pql(i,k)/(4*Nmix_h2o_ice*pi*rhowaterice)) - reffice(i,k) = min(max(reffice(i,k),1.e-6),1000.e-6) - enddo - enddo - endif - - end subroutine h2o_cloudrad -!================================================================== - - - -!================================================================== - subroutine co2_reffrad(ngrid,nlayer,nq,pq,reffrad) -!================================================================== -! Purpose -! ------- -! Compute the effective radii of co2 ice particles -! -! Authors -! ------- -! Jeremy Leconte (2012) -! -!================================================================== - USE tracer_h, only:igcm_co2_ice,rho_co2 - use comcstfi_mod, only: pi - Implicit none - - integer,intent(in) :: ngrid,nlayer,nq - - real, intent(in) :: pq(ngrid,nlayer,nq) !tracer mixing ratios (kg/kg) - real, intent(out) :: reffrad(ngrid,nlayer) !co2 ice particles radii (m) - - integer :: ig,l - real :: zrad - real,external :: CBRT - - - - if (radfixed) then - reffrad(1:ngrid,1:nlayer) = 5.e-5 ! CO2 ice - else - do l=1,nlayer - do ig=1,ngrid - zrad = CBRT( 3*pq(ig,l,igcm_co2_ice)/(4*Nmix_co2*pi*rho_co2) ) - reffrad(ig,l) = min(max(zrad,1.e-6),100.e-6) - enddo - enddo - end if - - end subroutine co2_reffrad -!================================================================== - - - -!================================================================== - subroutine dust_reffrad(ngrid,nlayer,reffrad) -!================================================================== -! Purpose -! ------- -! Compute the effective radii of dust particles -! -! Authors -! ------- -! Jeremy Leconte (2012) -! -!================================================================== - Implicit none - - integer,intent(in) :: ngrid - integer,intent(in) :: nlayer - - real, intent(out) :: reffrad(ngrid,nlayer) !dust particles radii (m) - - reffrad(1:ngrid,1:nlayer) = 2.e-6 ! dust - - end subroutine dust_reffrad -!================================================================== - - -!================================================================== - subroutine h2so4_reffrad(ngrid,nlayer,reffrad) -!================================================================== -! Purpose -! ------- -! Compute the effective radii of h2so4 particles -! -! Authors -! ------- -! Jeremy Leconte (2012) -! -!================================================================== - Implicit none - - integer,intent(in) :: ngrid - integer,intent(in) :: nlayer - - real, intent(out) :: reffrad(ngrid,nlayer) !h2so4 particle radii (m) - - reffrad(1:ngrid,1:nlayer) = 1.e-6 ! h2so4 - - end subroutine h2so4_reffrad -!================================================================== - -!================================================================== - subroutine back2lay_reffrad(ngrid,reffrad,nlayer,pplev) -!================================================================== -! Purpose -! ------- -! Compute the effective radii of particles in a 2-layer model -! -! Authors -! ------- -! Sandrine Guerlet (2013) -! -!================================================================== - use callkeys_mod, only: pres_bottom_tropo,pres_top_tropo,size_tropo, & - pres_bottom_strato,size_strato - - Implicit none - - integer,intent(in) :: ngrid - - real, intent(out) :: reffrad(ngrid,nlayer) ! particle radii (m) - REAL,INTENT(IN) :: pplev(ngrid,nlayer+1) ! inter-layer pressure (Pa) - INTEGER,INTENT(IN) :: nlayer ! number of atmospheric layers - REAL :: expfactor - INTEGER l,ig - - reffrad(:,:)=1e-6 !!initialization, not important - DO ig=1,ngrid - DO l=1,nlayer-1 - IF (pplev(ig,l) .le. pres_bottom_tropo .and. pplev(ig,l) .ge. pres_top_tropo) THEN - reffrad(ig,l) = size_tropo - ELSEIF (pplev(ig,l) .lt. pres_top_tropo .and. pplev(ig,l) .gt. pres_bottom_strato) THEN - expfactor=log(size_strato/size_tropo) / log(pres_bottom_strato/pres_top_tropo) - reffrad(ig,l)= size_tropo*((pplev(ig,l)/pres_top_tropo)**expfactor) - ELSEIF (pplev(ig,l) .le. pres_bottom_strato) then - reffrad(ig,l) = size_strato - ENDIF - ENDDO - ENDDO - - end subroutine back2lay_reffrad -!================================================================== - -end module radii_mod -!================================================================== Index: trunk/LMDZ.GENERIC/libf/phygeneric/radinc_h.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/radinc_h.F90 (revision 4062) +++ trunk/LMDZ.GENERIC/libf/phygeneric/radinc_h.F90 (revision 4077) @@ -64,7 +64,7 @@ !$OMP THREADPRIVATE(L_NLAYRAD,L_LEVELS,L_NLEVRAD) - ! These are set in sugas_corrk + ! These are set in rad_correlatedk_read_opacity_tables ! [uses allocatable arrays] -- AS 12/2011 - integer :: L_NPREF, L_NTREF, L_REFVAR, L_PINT, L_NGAUSS !L_NPREF, L_NTREF, L_REFVAR, L_PINT, L_NGAUSS read by master in sugas_corrk + integer :: L_NPREF, L_NTREF, L_REFVAR, L_PINT, L_NGAUSS !L_NPREF, L_NTREF, L_REFVAR, L_PINT, L_NGAUSS read by master in rad_correlatedk_read_opacity_tables integer, parameter :: L_NSPECTI = NBinfrared Index: trunk/LMDZ.GENERIC/libf/phygeneric/rain.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/rain.F90 (revision 4062) +++ trunk/LMDZ.GENERIC/libf/phygeneric/rain.F90 (revision 4077) @@ -4,5 +4,5 @@ use ioipsl_getin_p_mod, only: getin_p use watercommon_h, only: T_h2O_ice_liq,T_h2O_ice_clouds, RLVTT, RCPD, RCPV, RW, RVTMP2,Psat_water,Tsat_water,rhowater - use radii_mod, only: h2o_cloudrad + use aerosol_radius, only: h2o_cloudrad USE tracer_h, only: igcm_h2o_vap, igcm_h2o_ice use comcstfi_mod, only: g, r Index: trunk/LMDZ.GENERIC/libf/phygeneric/rain_generic.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/rain_generic.F90 (revision 4062) +++ trunk/LMDZ.GENERIC/libf/phygeneric/rain_generic.F90 (revision 4077) @@ -6,5 +6,5 @@ use watercommon_h, only: T_h2O_ice_liq,T_h2O_ice_clouds,rhowater ! T_h2O_ice_clouds,rhowater are only used for precip_scheme_generic >=2 - use radii_mod, only: h2o_cloudrad ! only used for precip_scheme_generic >=2 + use aerosol_radius, only: h2o_cloudrad ! only used for precip_scheme_generic >=2 use tracer_h use comcstfi_mod, only: g, r, cpp Index: trunk/LMDZ.GENERIC/libf/phygeneric/recombin_corrk_mod.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/recombin_corrk_mod.F90 (revision 4062) +++ (revision ) @@ -1,1032 +1,0 @@ -MODULE recombin_corrk_mod - - ! - ! Author : Jan Vatant d'Ollone (2018-2020) - ! - ! This module contains the following subroutines : - ! - ini_recombin : From modern traceur.def options check if we will use recombining and for which species. Called by initracer. - ! - su_recombin : Initialise tables. Called by sugas_corrk - ! - call_recombin : Test profile of species and decide whether to call recombin_corrk. Called by callcork - ! - recombin_corrk : The core algorithm properly recombining corrk tables. Called by callrecombin_corrk. - ! - - ! TODO : Think about the case where nqtot phys /= nqtot_dyn !! - ! TODO : Add the possibility to read an input profile for a specie !! - ! Also think about the hybrid case where we want force with a latitudinally variable input profile (likely need to tweak on-the-fly) - - IMPLICIT NONE - - LOGICAL, SAVE :: corrk_recombin=.false. ! Key boolean, is there any specie to recombin. - LOGICAL, SAVE :: use_premix=.true. ! Indicates if we recombin on top of a existing premix set of corrk. - !$OMP THREADPRIVATE(corrk_recombin,use_premix) - - INTEGER, SAVE :: nrecomb_tot ! # (total) of compounds to recombine - ! -> Linked to key is_recomb in tracer_h - - INTEGER, SAVE :: nrecomb_qset ! # of compounds to recombine having preset abundances (ie spectra computed with true vmr and not vmr=1) - !-> Linked to key is_recomb_qset in tracer_h - - INTEGER, SAVE :: nrecomb_qotf ! # of compounds to recombine on-the-fly (ie using value of pq, not input profile) - !-> Linked to key is_recomb_qotf in tracer_h - !$OMP THREADPRIVATE(nrecomb_tot,nrecomb_qset,nrecomb_qotf) - - ! Note : The variables above are not read in callphys.def but automatically defined in inirecombin called in initracer after processing traceur.def - - LOGICAL, SAVE :: all_otf ! True if all species are recombined on-the-fly, no premix, no preset .. - !$OMP THREADPRIVATE(all_otf) - - ! Following arrays are allocated in su_recombin (excepted otf2tot_idx, in ini_recombin) and deallocated in callcork lastcall - REAL*8, save, DIMENSION(:,:,:,:,:), ALLOCATABLE :: gasi_recomb, gasv_recomb - REAL*8, save, DIMENSION(:,:,:,:,:), ALLOCATABLE :: gasi_otf, gasv_otf - REAL*8, save, DIMENSION(:), ALLOCATABLE :: w_cum - REAL*8, save, DIMENSION(:), ALLOCATABLE :: wtwospec - - INTEGER, save, DIMENSION(:), ALLOCATABLE :: otf2tot_idx - INTEGER, save, DIMENSION(:), ALLOCATABLE :: rcb2tot_idx - INTEGER, save, DIMENSION(:), ALLOCATABLE :: otf2rcb_idx - - INTEGER, save, DIMENSION(:), ALLOCATABLE :: permut_idx - !$OMP THREADPRIVATE(gasi_recomb,gasv_recomb,w_cum,otf2tot_idx,rcb2tot_idx,otf2rcb_idx,permut_idx) - - CONTAINS - - - SUBROUTINE ini_recombin - - USE tracer_h - - IMPLICIT NONE - - INTEGER :: nspcrad ! # of is_rad species (tempooray here, should be a radcommon variabke) - INTEGER :: iq, icount - - ! Default values - use_premix = .true. - corrk_recombin = .false. - nrecomb_tot = 0 - nrecomb_qset = 0 - nrecomb_qotf = 0 - - nspcrad = 0 - - do iq=1,nqtot - - ! Counter used to check if all rad. species are recombin then no premix - if(is_rad(iq)==1) nspcrad = nspcrad + 1 - - ! Sanity checks - if (is_recomb(iq)==1 .and. is_rad(iq)==0) then - write(*,*) 'initracer : Error for tracer iq=',iq - write(*,*) 'is_recomb=1 but is_rad=0, this is not possible !' - call abort_physic('initrac','Conflicting traceur.def options',1) - endif - if (is_recomb_qset(iq)==1 .and. is_recomb(iq)==0) then - write(*,*) 'initracer : Error for tracer iq=',iq - write(*,*) 'is_recomb_qset=1 but is_recomb=0, this is not possible !' - call abort_physic('initrac','Conflicting traceur.def options',1) - endif - if (is_recomb_qotf(iq)==1 .and. is_recomb_qset(iq)==1) then - write(*,*) 'initracer : Error for tracer iq=',iq - write(*,*) 'is_recomb_qset=1 and is_recomb_qotf=1, this is not possible !' - call abort_physic('initrac','Conflicting traceur.def options',1) - endif - - if(is_recomb(iq)==1) then - corrk_recombin = .true. ! activating on first one found would be enough actually but I'm lazy - - nrecomb_tot = nrecomb_tot + 1 - - if(is_recomb_qset(iq)==1) nrecomb_qset = nrecomb_qset + 1 - if(is_recomb_qotf(iq)==1) nrecomb_qotf = nrecomb_qotf + 1 - - write(*,*) - write(*,*) 'ini_recombin: found specie : Name = ',trim(noms(iq)), & - ' ; Predefined vmr=', is_recomb_qset(iq), & - ' ; On-the-fly=', is_recomb_qotf(iq) - - endif - - enddo - - ! Init. correspondance array of indexes between subset of tracers - IF(.NOT. ALLOCATED(otf2tot_idx)) ALLOCATE(otf2tot_idx(nrecomb_qotf)) - icount=0 - do iq=1,nqtot - if(is_recomb_qotf(iq)==1) then - icount=icount+1 - otf2tot_idx(icount) = iq - endif - enddo - - IF(.NOT. ALLOCATED(rcb2tot_idx)) ALLOCATE(rcb2tot_idx(nrecomb_tot)) - icount=0 - do iq=1,nqtot - if(is_recomb(iq)==1) then - icount=icount+1 - rcb2tot_idx(icount) = iq - endif - enddo - - IF(.NOT. ALLOCATED(otf2rcb_idx)) ALLOCATE(otf2rcb_idx(nrecomb_qotf)) - icount=0 - do iq=1,nrecomb_tot - if(is_recomb_qotf(rcb2tot_idx(iq))==1) then - icount=icount+1 - otf2rcb_idx(icount) = iq - endif - enddo - - ! Use a premix set on top ? - if (nspcrad == nrecomb_tot .and. nspcrad /= 0) use_premix = .false. ! In this case all rad. species are recombined - - ! Summary - write(*,*) - write(*,*) 'ini_recombin: Total species found for corrk recombination =', nrecomb_tot - - if (corrk_recombin) then - if (use_premix) then - write(*,*) 'ini_recombin: .. Total radiative species matching total species for recombination...' - write(*,*) 'ini_recombin: .. Any pre-mixed set of opacities will be ignored.' - else - write(*,*) 'ini_recombin: .. Found less species to recombine than total radiative species..' - write(*,*) 'ini_recombin: .. Recombination will occur ontop of premix set of opacities' - endif - else - write(*,*) 'ini_recombin: .. No species found for recombination, I will use premix set only.' - endif - write(*,*) - - END SUBROUTINE ini_recombin - - - - SUBROUTINE su_recombin - USE radinc_h - USE radcommon_h, only: gweight, gasi, gasv - - IMPLICIT NONE - - INTEGER :: i, ig, jg, ind, iw, it, ip - - ! Allocations - IF(.NOT. ALLOCATED(permut_idx)) ALLOCATE(permut_idx(L_NGAUSS*L_NGAUSS)) - IF(.NOT. ALLOCATED(w_cum)) ALLOCATE(w_cum(L_NGAUSS)) - IF(.NOT. ALLOCATED(gasi_recomb)) ALLOCATE(gasi_recomb(L_NTREF,L_PINT,L_REFVAR,L_NSPECTI,L_NGAUSS)) - IF(.NOT. ALLOCATED(gasv_recomb)) ALLOCATE(gasv_recomb(L_NTREF,L_PINT,L_REFVAR,L_NSPECTV,L_NGAUSS)) - IF(.NOT. ALLOCATED(gasi_otf)) ALLOCATE(gasi_otf(L_NGAUSS,nrecomb_qotf,L_NSPECTI,L_NTREF,L_PINT)) - IF(.NOT. ALLOCATED(gasv_otf)) ALLOCATE(gasv_otf(L_NGAUSS,nrecomb_qotf,L_NSPECTI,L_NTREF,L_PINT)) - IF(.NOT. ALLOCATED(wtwospec)) ALLOCATE(wtwospec(L_NGAUSS*L_NGAUSS)) - - ! Init. for recombin_corrk firstcall - permut_idx = (/(i, i=1,L_NGAUSS*L_NGAUSS)/) - - w_cum(1)= gweight(1) - DO i=2,L_NGAUSS - w_cum(i) = w_cum(i-1)+gweight(i) - ENDDO - - ! init wtwospec once for all - DO ig=1,L_NGAUSS - DO jg=1, L_NGAUSS - ind = jg+(ig-1)*L_NGAUSS - wtwospec(ind) = gweight(ig)*gweight(jg) - ENDDO - ENDDO - - ! init otf correlated-k array - do ip=1,L_PINT - do it=1,L_NTREF - do iw=1,L_NSPECTI - do i=1,nrecomb_qotf - do ig=1,L_NGAUSS - gasi_otf(ig,i,iw,it,ip) = gasi(it,ip,L_REFVAR+otf2rcb_idx(i),iw,ig) ! choose only idx corresponding to otf in gasi - enddo - enddo - enddo - enddo - enddo - do ip=1,L_PINT - do it=1,L_NTREF - do iw=1,L_NSPECTV - do i=1,nrecomb_qotf - do ig=1,L_NGAUSS - gasv_otf(ig,i,iw,it,ip) = gasv(it,ip,L_REFVAR+otf2rcb_idx(i),iw,ig) ! choose only idx corresponding to otf in gasv - enddo - enddo - enddo - enddo - enddo - - gasi_recomb(:,:,:,:,:) = gasi(:,:,1:L_REFVAR,:,:) ! non-zero init (=kappa_ir) - gasv_recomb(:,:,:,:,:) = gasv(:,:,1:L_REFVAR,:,:) ! non-zero init (=kappa_vi) - - END SUBROUTINE su_recombin - - - - SUBROUTINE call_recombin(igrid,nlayer,pq,pplay,pt,qvar,tmid,pmid) - - USE comcstfi_mod, only: mugaz - USE radinc_h - USE radcommon_h - USE tracer_h, only: noms, mmol, is_recomb_qotf, is_recomb_qset - USE tpindex_mod, only: tpindex - - IMPLICIT NONE - - ! Inputs - INTEGER, INTENT(IN) :: igrid ! lon-lat grid point - INTEGER, INTENT(IN) :: nlayer ! Number of atmospheric layers. - - REAL*8, DIMENSION(:,:), INTENT(IN) :: pq ! Tracers vertical profiles (kg/kg) - REAL*8, DIMENSION(nlayer), INTENT(IN) :: pplay ! Atmospheric pressure (Pa) - REAL*8, DIMENSION(nlayer), INTENT(IN) :: pt ! Atmospheric temperature (K) - REAL*8, DIMENSION(L_LEVELS), INTENT(IN) :: qvar ! Mixing ratio of variable component (mol/mol) - REAL*8, DIMENSION(L_LEVELS), INTENT(IN) :: tmid ! Temperature of layers, mid levels (K) - REAL*8, DIMENSION(L_LEVELS), INTENT(IN) :: pmid ! Pressure of layers, mid levels (mBar) - - ! NB : qvar is on L_LEVELS but it has been processed in callcork compared to the one in pq - ! so we imperatively need to take this one. Note that there is no interpolation, so - ! pq(nlayer+1-l,ivar) is broadcast in qvar(2*l) qvar(2*l+1) - - ! Local variables - INTEGER :: ng - INTEGER :: ig,l,k,nw,iq,ip,ilay,it,ix,iw - - LOGICAL :: found - - REAL*8 :: fact, tmin, tmax, qmin, qmax - REAL*8 :: LCOEF(4), WRATIO - - LOGICAL,DIMENSION(:,:,:),ALLOCATABLE,save :: useptx ! Mask on which t-p-x ref grid point will be used - - REAL*8, DIMENSION(:,:), ALLOCATABLE,save :: pqr ! Tracers abundances at ref pressures used for onthefly recombining (mol/mol). - - LOGICAL,SAVE :: firstcall=.true. - !$OMP THREADPRIVATE(firstcall) - - ! At firstcall we precombine all what needs to be done only once (pre-mixed,forced profiles..), if needed. - IF (firstcall) THEN - - IF(.NOT. ALLOCATED(useptx)) ALLOCATE(useptx(L_NTREF,L_PINT,L_REFVAR)) - useptx(:,:,:) = .false. - - IF(use_premix .or. (.not.use_premix .and. nrecomb_qotf/=nrecomb_tot)) THEN ! we skip this if all species are on-the-fly - all_otf=.false. - IF(.NOT. ALLOCATED(pqr)) ALLOCATE(pqr(nrecomb_tot,L_PINT)) - ! Default value for premix and for fixed species for whom vmr has been taken - ! into account while computing high-resolution spectra - pqr(:,:) = 1.0 - - ! TODO : Missing implementation here for the tracers where we read an input profile !! - do iq=1,nrecomb_tot - if (is_recomb_qset(rcb2tot_idx(iq))==0 .and. is_recomb_qotf(rcb2tot_idx(iq))==0) then - print*, 'Recombining tracer ', noms(rcb2tot_idx(iq)),' requires an input profile, this is not implemented yet !!' - call abort_physic('call_recombin','Missing implementation',1) - ! Read pqr(:,iq) - endif - enddo - - ! Recombine for all T-P-Q as we do it only once for all. - call recombin_corrk_ini(pqr) - ELSE - all_otf=.true. - ENDIF - - firstcall=.false. - IF (nrecomb_qotf==0) corrk_recombin = .false. - IF(ALLOCATED(pqr)) DEALLOCATE(pqr) - IF(.NOT. ALLOCATED(pqr)) ALLOCATE(pqr(nrecomb_qotf,L_PINT)) - - ENDIF ! firstcall - - ! NB : To have decent CPU time recombining is not done on all gridpoints and wavelenghts but we - ! calculate a gasi/v_recomb variable on the reference corrk-k T,P,X grid (only for T,P,X values - ! who match the atmospheric conditions) which is then processed as a standard pre-mix in - ! optci/v routines, but updated every time tracers on the ref P grid have varied > 1%. - - ! Extract tracers for species which are recombined on-the-fly - do ip=1,L_PINT - - ilay=0 - found = .false. - do l=1,nlayer - if (pplay(l) .le. 10.0**(pfgasref(ip)+2.0)) then ! pfgasref=log(p[mbar]) - found=.true. - ilay=l-1 - exit - endif - enddo - - if (.not. found) then ! set pq to top value - do iq=1,nrecomb_qotf - pqr(iq,ip) = pq(nlayer,otf2tot_idx(iq))*mugaz/mmol(otf2tot_idx(iq)) ! mol/mol - enddo - else - if (ilay==0) then ! set pq to bottom value - do iq=1,nrecomb_qotf - pqr(iq,ip) = pq(1,otf2tot_idx(iq))*mugaz/mmol(otf2tot_idx(iq)) ! mol/mol - enddo - else ! standard : interp pq between layers - fact = (10.0**(pfgasref(ip)+2.0) - pplay(ilay+1)) / (pplay(ilay) - pplay(ilay+1)) ! pfgasref=log(p[mbar]) - do iq=1,nrecomb_qotf - pqr(iq,ip) = pq(ilay,otf2tot_idx(iq))**fact * pq(ilay+1,otf2tot_idx(iq))**(1.0-fact) - pqr(iq,ip) = pqr(iq,ip)*mugaz/mmol(otf2tot_idx(iq)) ! mol/mol - enddo - endif ! if ilay==nlayer - endif ! if not found - - enddo ! ip=1,L_PINT - - ! The following useptx is a trick to call recombine only for the reference T-P-X - ! reference grid points that are useful given the temperature range (and variable specie amount) at a given altitude - ! (cf optci/optcv routines where we interpolate corrk calling tpindex) - ! It saves a looot of time - JVO 18 - - do K=2,L_LEVELS - call tpindex(PMID(K),TMID(K),QVAR(K),pfgasref,tgasref,WREFVAR,LCOEF,it,ip,ix,WRATIO) - useptx(it:it+1,ip:ip+1,ix:ix+1) = .true. - end do - - if (.not.all_otf) then - call recombin_corrk_mix(igrid,pqr,useptx) - else - if (nrecomb_qotf.gt.1) then - call recombin_corrk_mix_allotf(igrid,pqr,useptx) - else - do ix=1,L_REFVAR - do ip=1,L_PINT - do it=1,L_NTREF - if (.not. useptx(it,ip,ix)) cycle - gasi_recomb(it,ip,ix,:,:) = pqr(1,ip)*gasi_otf(:,1,:,it,ip) - gasv_recomb(it,ip,ix,:,:) = pqr(1,ip)*gasv_otf(:,1,:,it,ip) - useptx(it,ip,ix) = .false. - enddo - enddo - enddo - endif - endif - - END SUBROUTINE call_recombin - - SUBROUTINE recombin_corrk_ini(pqr) - - USE radinc_h - USE radcommon_h, only: gweight, tlimit, gasi, gasv - USE tracer_h, only: is_recomb_qotf - USE sort_mod, only: isort - - !----------------------------------------------------------------------- - ! Declarations: - ! ------------- - - IMPLICIT NONE - - ! Arguments : - ! ----------- - REAL*8, DIMENSION(nrecomb_qotf,L_PINT), INTENT(IN) :: pqr ! otf species mixing ration - - ! Local variables : - ! ----------------- - INTEGER :: it, ip, ix, iw, ig, jg, ind, ibin, ispec - - REAL*8, DIMENSION(L_NGAUSS) :: tmpk ! otf correlated-k by mixing ratio - REAL*8, DIMENSION(L_NGAUSS) :: krecomb - - REAL*8, DIMENSION(L_NGAUSS*L_NGAUSS) :: ktwospec - REAL*8, DIMENSION(L_NGAUSS*L_NGAUSS) :: ktwospec_s - REAL*8, DIMENSION(L_NGAUSS*L_NGAUSS) :: wtwospec_s - REAL*8, DIMENSION(L_NGAUSS*L_NGAUSS) :: wtwospec_cum - - REAL*8 :: wsplit - - do ix=1,L_REFVAR - do ip=1,L_PINT - do it=1,L_NTREF - - ! ------------------- - ! I. INFRARED - ! ------------------- - - DO iw=1,L_NSPECTI - DO ig=1,L_NGAUSS ! init correlated-k with premix - ! utiliser directement gasi_recomb au lieu d'un variable intermediere krecomb ? - ! Peut ok si L_NGAUSS première dimension de gasi_recomb - krecomb(ig) = gasi(it,ip,ix,iw,ig) - ENDDO - DO ispec=1,nrecomb_tot ! Loop on additional species - - IF(is_recomb_qotf(rcb2tot_idx(ispec))==1) CYCLE - ! takes all to recomb, the otf ones are skipped - DO ig=1,L_NGAUSS - tmpk(ig) = pqr(ispec,ip)*gasi(it,ip,L_REFVAR+ispec,iw,ig) - ENDDO - - ! Save ( a lot of ) CPU time, we don't add the specie if negligible absorption in the band - IF ( tmpk(L_NGAUSS-1) .LE. tlimit ) CYCLE - IF ( ALL( tmpk(1:L_NGAUSS-1) .LE. krecomb(1:L_NGAUSS-1)*0.1 ) ) CYCLE - IF ( ALL( krecomb(1:L_NGAUSS-1) .LE. tmpk(1:L_NGAUSS-1)*0.1 ) ) THEN - krecomb(1:L_NGAUSS-1) = tmpk(1:L_NGAUSS-1) - CYCLE - ENDIF - - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ! 1. Recombining ~~~~~~~~~~~~~~~~~~~~~~~~~ - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - DO ig=1,L_NGAUSS - DO jg=1, L_NGAUSS - ind = jg+(ig-1)*L_NGAUSS - ktwospec(ind) = krecomb(ig)+tmpk(jg) - ENDDO - ENDDO - - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ! 2. Resorting ~~~~~~~~~~~~~~~~~~~~~~~ - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - ! Pre-sort from last step ( we have always a similar regular pattern ) to gain time for sorting - ! NB : quite small array, quicker to permut with 2nd array than in place - DO ind=1,L_NGAUSS*L_NGAUSS - ktwospec_s(ind) = ktwospec(permut_idx(ind)) ! NB : won't do anything at firstcall - ENDDO - - CALL isort(ktwospec_s,L_NGAUSS*L_NGAUSS,permut_idx) ! Insertion sort quicker because pre-sorted - - ! Sort w according to permutations of k. - ! NB : quite small array, quicker to permut with 2nd array than in place - DO ind=1,L_NGAUSS*L_NGAUSS - wtwospec_s(ind) = wtwospec(permut_idx(ind)) - ENDDO - - wtwospec_cum(1) = wtwospec_s(1) - DO ind=2,L_NGAUSS*L_NGAUSS - wtwospec_cum(ind)= wtwospec_cum(ind-1)+wtwospec_s(ind) - ENDDO - - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ! 3. Rebinning on smaller amount of Gauss points ~~~~~~~~~~~ - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ibin=1 - - krecomb(:)=0.0 - - DO ig=1, L_NGAUSS-1 - - DO ind=ibin,L_NGAUSS*L_NGAUSS ! rather than a while - IF ( wtwospec_cum(ind) .GT. w_cum(ig) ) THEN - wsplit = w_cum(ig) - wtwospec_cum(ind-1) - krecomb(ig) = krecomb(ig) & - + sum ( wtwospec_s(ibin:ind-1)*ktwospec_s(ibin:ind-1) ) & - + wsplit*ktwospec_s(ind) - krecomb(ig+1) = (wtwospec_s(ind)-wsplit)*ktwospec_s(ind) - ibin=ind+1 - EXIT - ENDIF - ENDDO - - krecomb(L_NGAUSS) = krecomb(L_NGAUSS) + sum ( wtwospec_s(ibin:)*ktwospec_s(ibin:) ) - - ENDDO - - krecomb(1:L_NGAUSS-1) = krecomb(1:L_NGAUSS-1) / gweight(1:L_NGAUSS-1) ! gw(L_NGAUSS)=0 - - ENDDO ! ispec=1,nrecomb_qotf - gasi(it,ip,ix,iw,:) = krecomb(:) - ENDDO ! iw=1,L_NSPECTI - - ! ------------------- - ! II. VISIBLE - ! ------------------- - - DO iw=1,L_NSPECTV - DO ig=1,L_NGAUSS ! init correlated-k with premix - krecomb(ig) = gasv(it,ip,ix,iw,ig) ! there is a prerecombined cocktail - ENDDO - DO ispec=1,nrecomb_tot ! Loop on additional species - - IF(is_recomb_qotf(rcb2tot_idx(ispec))==1) CYCLE - ! takes all to recomb, the otf ones are skipped - DO ig=1,L_NGAUSS - tmpk(ig) = pqr(ispec,ip)*gasv(it,ip,L_REFVAR+ispec,iw,ig) - ENDDO - - ! Save ( a lot of ) CPU time, we don't add the specie if negligible absorption in the band - IF ( tmpk(L_NGAUSS-1) .LE. tlimit ) CYCLE - IF ( ALL( tmpk(1:L_NGAUSS-1) .LE. krecomb(1:L_NGAUSS-1)*0.1 ) ) CYCLE - IF ( ALL( krecomb(1:L_NGAUSS-1) .LE. tmpk(1:L_NGAUSS-1)*0.1 ) ) THEN - krecomb(1:L_NGAUSS-1) = tmpk(1:L_NGAUSS-1) - CYCLE - ENDIF - - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ! 1. Recombining ~~~~~~~~~~~~~~~~~~~~~~~~~ - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - DO ig=1,L_NGAUSS - DO jg=1, L_NGAUSS - ind = jg+(ig-1)*L_NGAUSS - ktwospec(ind) = krecomb(ig)+tmpk(jg) - ENDDO - ENDDO - - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ! 2. Resorting ~~~~~~~~~~~~~~~~~~~~~~~ - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - ! Pre-sort from last step ( we have always a similar regular pattern ) to gain time for sorting - ! NB : quite small array, quicker to permut with 2nd array than in place - DO ind=1,L_NGAUSS*L_NGAUSS - ktwospec_s(ind) = ktwospec(permut_idx(ind)) ! NB : won't do anything at firstcall - ENDDO - - CALL isort(ktwospec_s,L_NGAUSS*L_NGAUSS,permut_idx) ! Insertion sort quicker because pre-sorted - - ! Sort w according to permutations of k. - ! NB : quite small array, quicker to permut with 2nd array than in place - DO ind=1,L_NGAUSS*L_NGAUSS - wtwospec_s(ind) = wtwospec(permut_idx(ind)) - ENDDO - - wtwospec_cum(1) = wtwospec_s(1) - DO ind=2,L_NGAUSS*L_NGAUSS - wtwospec_cum(ind)= wtwospec_cum(ind-1)+wtwospec_s(ind) - ENDDO - - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ! 3. Rebinning on smaller amount of Gauss points ~~~~~~~~~~~ - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ibin=1 - - krecomb(:)=0.0 - - DO ig=1, L_NGAUSS-1 - - DO ind=ibin,L_NGAUSS*L_NGAUSS ! rather than a while - IF ( wtwospec_cum(ind) .GT. w_cum(ig) ) THEN - wsplit = w_cum(ig) - wtwospec_cum(ind-1) - krecomb(ig) = krecomb(ig) & - + sum ( wtwospec_s(ibin:ind-1)*ktwospec_s(ibin:ind-1) ) & - + wsplit*ktwospec_s(ind) - krecomb(ig+1) = (wtwospec_s(ind)-wsplit)*ktwospec_s(ind) - ibin=ind+1 - EXIT - ENDIF - ENDDO - - krecomb(L_NGAUSS) = krecomb(L_NGAUSS) + sum ( wtwospec_s(ibin:)*ktwospec_s(ibin:) ) - - ENDDO - - krecomb(1:L_NGAUSS-1) = krecomb(1:L_NGAUSS-1) / gweight(1:L_NGAUSS-1) ! gw(L_NGAUSS)=0 - - ENDDO ! ispec=1,nrecomb_qotf - gasv(it,ip,ix,iw,:) = krecomb(:) - ENDDO ! iw=1,L_NSPECTV - - enddo ! ix=1,L_NTREF - enddo ! it=1,L_PINT - enddo ! ip=1,L_REFVAR - - END SUBROUTINE recombin_corrk_ini - - SUBROUTINE recombin_corrk_mix(igrid,pqr,useptx) - - USE radinc_h - USE radcommon_h, only: gweight, tlimit, gasi, gasv - USE sort_mod, only: isort - use comsaison_h, only: fract - - !----------------------------------------------------------------------- - ! Declarations: - ! ------------- - - IMPLICIT NONE - - ! Arguments : - ! ----------- - INTEGER, INTENT(IN) :: igrid ! lon-lat grid point - REAL*8, DIMENSION(nrecomb_qotf,L_PINT), INTENT(IN) :: pqr ! otf species mixing ration - LOGICAL, INTENT(INOUT) :: useptx(L_NTREF,L_PINT,L_REFVAR) ! Mask on which t-p-x ref grid point will be used - - ! Local variables : - ! ----------------- - INTEGER :: it, ip, ix, iw, ig, jg, ind, ibin, ispec - - REAL*8, DIMENSION(L_NGAUSS) :: tmpk ! otf correlated-k by mixing ratio - REAL*8, DIMENSION(L_NGAUSS) :: krecomb - - REAL*8, DIMENSION(L_NGAUSS*L_NGAUSS) :: ktwospec - REAL*8, DIMENSION(L_NGAUSS*L_NGAUSS) :: ktwospec_s - REAL*8, DIMENSION(L_NGAUSS*L_NGAUSS) :: wtwospec_s - REAL*8, DIMENSION(L_NGAUSS*L_NGAUSS) :: wtwospec_cum - - REAL*8 :: wsplit - - do ix=1,L_REFVAR - do ip=1,L_PINT - do it=1,L_NTREF - if (.not. useptx(it,ip,ix)) cycle - - ! ------------------- - ! I. INFRARED - ! ------------------- - - DO iw=1,L_NSPECTI - DO ig=1,L_NGAUSS ! init correlated-k with premix - ! utiliser directement gasi_recomb au lieu d'un variable intermediere krecomb ? - ! Peut ok si L_NGAUSS première dimension de gasi_recomb - krecomb(ig) = gasi(it,ip,ix,iw,ig) - ENDDO - DO ispec=1,nrecomb_qotf ! Loop on additional species - - DO ig=1,L_NGAUSS - tmpk(ig) = pqr(ispec,ip)*gasi_otf(ig,ispec,iw,it,ip) - ENDDO - - ! Save ( a lot of ) CPU time, we don't add the specie if negligible absorption in the band - IF ( tmpk(L_NGAUSS-1) .LE. tlimit ) CYCLE - IF ( ALL( tmpk(1:L_NGAUSS-1) .LE. krecomb(1:L_NGAUSS-1)*0.1 ) ) CYCLE - IF ( ALL( krecomb(1:L_NGAUSS-1) .LE. tmpk(1:L_NGAUSS-1)*0.1 ) ) THEN - krecomb(1:L_NGAUSS-1) = tmpk(1:L_NGAUSS-1) - CYCLE - ENDIF - - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ! 1. Recombining ~~~~~~~~~~~~~~~~~~~~~~~~~ - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - DO ig=1,L_NGAUSS - DO jg=1, L_NGAUSS - ind = jg+(ig-1)*L_NGAUSS - ktwospec(ind) = krecomb(ig)+tmpk(jg) - ENDDO - ENDDO - - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ! 2. Resorting ~~~~~~~~~~~~~~~~~~~~~~~ - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - ! Pre-sort from last step ( we have always a similar regular pattern ) to gain time for sorting - ! NB : quite small array, quicker to permut with 2nd array than in place - DO ind=1,L_NGAUSS*L_NGAUSS - ktwospec_s(ind) = ktwospec(permut_idx(ind)) ! NB : won't do anything at firstcall - ENDDO - - CALL isort(ktwospec_s,L_NGAUSS*L_NGAUSS,permut_idx) ! Insertion sort quicker because pre-sorted - - ! Sort w according to permutations of k. - ! NB : quite small array, quicker to permut with 2nd array than in place - DO ind=1,L_NGAUSS*L_NGAUSS - wtwospec_s(ind) = wtwospec(permut_idx(ind)) - ENDDO - - wtwospec_cum(1) = wtwospec_s(1) - DO ind=2,L_NGAUSS*L_NGAUSS - wtwospec_cum(ind)= wtwospec_cum(ind-1)+wtwospec_s(ind) - ENDDO - - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ! 3. Rebinning on smaller amount of Gauss points ~~~~~~~~~~~ - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ibin=1 - - krecomb(:)=0.0 - - DO ig=1, L_NGAUSS-1 - - DO ind=ibin,L_NGAUSS*L_NGAUSS ! rather than a while - IF ( wtwospec_cum(ind) .GT. w_cum(ig) ) THEN - wsplit = w_cum(ig) - wtwospec_cum(ind-1) - krecomb(ig) = krecomb(ig) & - + sum ( wtwospec_s(ibin:ind-1)*ktwospec_s(ibin:ind-1) ) & - + wsplit*ktwospec_s(ind) - krecomb(ig+1) = (wtwospec_s(ind)-wsplit)*ktwospec_s(ind) - ibin=ind+1 - EXIT - ENDIF - ENDDO - - krecomb(L_NGAUSS) = krecomb(L_NGAUSS) + sum ( wtwospec_s(ibin:)*ktwospec_s(ibin:) ) - - ENDDO - - krecomb(1:L_NGAUSS-1) = krecomb(1:L_NGAUSS-1) / gweight(1:L_NGAUSS-1) ! gw(L_NGAUSS)=0 - - ENDDO ! ispec=1,nrecomb_qotf - gasi_recomb(it,ip,ix,iw,:) = krecomb(:) - ENDDO ! iw=1,L_NSPECTI - - ! ------------------- - ! II. VISIBLE - ! ------------------- - - if(fract(igrid) .lt. 1.0e-4) cycle ! Only during daylight. - - DO iw=1,L_NSPECTV - DO ig=1,L_NGAUSS ! init correlated-k with premix - krecomb(ig) = gasv(it,ip,ix,iw,ig) ! gasv_loc order correctly for running time? - ENDDO - DO ispec=1,nrecomb_qotf ! Loop on additional species - - DO ig=1,L_NGAUSS - tmpk(ig) = pqr(ispec,ip)*gasv_otf(ig,ispec,iw,it,ip) - ENDDO - - ! Save ( a lot of ) CPU time, we don't add the specie if negligible absorption in the band - IF ( tmpk(L_NGAUSS-1) .LE. tlimit ) CYCLE - IF ( ALL( tmpk(1:L_NGAUSS-1) .LE. krecomb(1:L_NGAUSS-1)*0.1 ) ) CYCLE - IF ( ALL( krecomb(1:L_NGAUSS-1) .LE. tmpk(1:L_NGAUSS-1)*0.1 ) ) THEN - krecomb(1:L_NGAUSS-1) = tmpk(1:L_NGAUSS-1) - CYCLE - ENDIF - - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ! 1. Recombining ~~~~~~~~~~~~~~~~~~~~~~~~~ - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - DO ig=1,L_NGAUSS - DO jg=1, L_NGAUSS - ind = jg+(ig-1)*L_NGAUSS - ktwospec(ind) = krecomb(ig)+tmpk(jg) - ENDDO - ENDDO - - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ! 2. Resorting ~~~~~~~~~~~~~~~~~~~~~~~ - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - ! Pre-sort from last step ( we have always a similar regular pattern ) to gain time for sorting - ! NB : quite small array, quicker to permut with 2nd array than in place - DO ind=1,L_NGAUSS*L_NGAUSS - ktwospec_s(ind) = ktwospec(permut_idx(ind)) ! NB : won't do anything at firstcall - ENDDO - - CALL isort(ktwospec_s,L_NGAUSS*L_NGAUSS,permut_idx) ! Insertion sort quicker because pre-sorted - - ! Sort w according to permutations of k. - ! NB : quite small array, quicker to permut with 2nd array than in place - DO ind=1,L_NGAUSS*L_NGAUSS - wtwospec_s(ind) = wtwospec(permut_idx(ind)) - ENDDO - - wtwospec_cum(1) = wtwospec_s(1) - DO ind=2,L_NGAUSS*L_NGAUSS - wtwospec_cum(ind)= wtwospec_cum(ind-1)+wtwospec_s(ind) - ENDDO - - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ! 3. Rebinning on smaller amount of Gauss points ~~~~~~~~~~~ - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ibin=1 - - krecomb(:)=0.0 - - DO ig=1, L_NGAUSS-1 - - DO ind=ibin,L_NGAUSS*L_NGAUSS ! rather than a while - IF ( wtwospec_cum(ind) .GT. w_cum(ig) ) THEN - wsplit = w_cum(ig) - wtwospec_cum(ind-1) - krecomb(ig) = krecomb(ig) & - + sum ( wtwospec_s(ibin:ind-1)*ktwospec_s(ibin:ind-1) ) & - + wsplit*ktwospec_s(ind) - krecomb(ig+1) = (wtwospec_s(ind)-wsplit)*ktwospec_s(ind) - ibin=ind+1 - EXIT - ENDIF - ENDDO - - krecomb(L_NGAUSS) = krecomb(L_NGAUSS) + sum ( wtwospec_s(ibin:)*ktwospec_s(ibin:) ) - - ENDDO - - krecomb(1:L_NGAUSS-1) = krecomb(1:L_NGAUSS-1) / gweight(1:L_NGAUSS-1) ! gw(L_NGAUSS)=0 - - ENDDO ! ispec=1,nrecomb_qotf - gasv_recomb(it,ip,ix,iw,:) = krecomb(:) - ENDDO ! iw=1,L_NSPECTV - - useptx(it,ip,ix) = .false. - enddo ! ix=1,L_NTREF - enddo ! it=1,L_PINT - enddo ! ip=1,L_REFVAR - - END SUBROUTINE recombin_corrk_mix - - SUBROUTINE recombin_corrk_mix_allotf(igrid,pqr,useptx) - - USE radinc_h - USE radcommon_h, only: gweight, tlimit, gasi, gasv - USE sort_mod, only: isort - use comsaison_h, only: fract - - !----------------------------------------------------------------------- - ! Declarations: - ! ------------- - - IMPLICIT NONE - - ! Arguments : - ! ----------- - INTEGER, INTENT(IN) :: igrid ! lon-lat grid point - REAL*8, DIMENSION(nrecomb_qotf,L_PINT), INTENT(IN) :: pqr ! otf species mixing ration - LOGICAL, INTENT(INOUT) :: useptx(L_NTREF,L_PINT,L_REFVAR) ! Mask on which t-p-x ref grid point will be used - - ! Local variables : - ! ----------------- - INTEGER :: it, ip, ix, iw, ig, jg, ind, ibin, ispec - - REAL*8, DIMENSION(L_NGAUSS) :: tmpk ! otf correlated-k by mixing ratio - REAL*8, DIMENSION(L_NGAUSS) :: krecomb - - REAL*8, DIMENSION(L_NGAUSS*L_NGAUSS) :: ktwospec - REAL*8, DIMENSION(L_NGAUSS*L_NGAUSS) :: ktwospec_s - REAL*8, DIMENSION(L_NGAUSS*L_NGAUSS) :: wtwospec_s - REAL*8, DIMENSION(L_NGAUSS*L_NGAUSS) :: wtwospec_cum - - REAL*8 :: wsplit - - do ix=1,L_REFVAR - do ip=1,L_PINT - do it=1,L_NTREF - if (.not. useptx(it,ip,ix)) cycle - - ! ------------------- - ! I. INFRARED - ! ------------------- - - DO iw=1,L_NSPECTI - DO ig=1,L_NGAUSS ! init correlated-k with first gas - krecomb(ig) = pqr(1,ip)*gasi_otf(ig,1,iw,it,ip) - ENDDO - DO ispec=2,nrecomb_qotf ! Loop on additional species - - DO ig=1,L_NGAUSS - tmpk(ig) = pqr(ispec,ip)*gasi_otf(ig,ispec,iw,it,ip) - ENDDO - - ! Save ( a lot of ) CPU time, we don't add the specie if negligible absorption in the band - IF ( tmpk(L_NGAUSS-1) .LE. tlimit ) CYCLE - IF ( ALL( tmpk(1:L_NGAUSS-1) .LE. krecomb(1:L_NGAUSS-1)*0.01 ) ) CYCLE - IF ( ALL( krecomb(1:L_NGAUSS-1) .LE. tmpk(1:L_NGAUSS-1)*0.01 ) ) THEN - krecomb(1:L_NGAUSS-1) = tmpk(1:L_NGAUSS-1) - CYCLE - ENDIF - - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ! 1. Recombining ~~~~~~~~~~~~~~~~~~~~~~~~~ - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - DO ig=1,L_NGAUSS - DO jg=1, L_NGAUSS - ind = jg+(ig-1)*L_NGAUSS - ktwospec(ind) = krecomb(ig)+tmpk(jg) - ENDDO - ENDDO - - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ! 2. Resorting ~~~~~~~~~~~~~~~~~~~~~~~ - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - ! Pre-sort from last step ( we have always a similar regular pattern ) to gain time for sorting - ! NB : quite small array, quicker to permut with 2nd array than in place - DO ind=1,L_NGAUSS*L_NGAUSS - ktwospec_s(ind) = ktwospec(permut_idx(ind)) ! NB : won't do anything at firstcall - ENDDO - - CALL isort(ktwospec_s,L_NGAUSS*L_NGAUSS,permut_idx) ! Insertion sort quicker because pre-sorted - - ! Sort w according to permutations of k. - ! NB : quite small array, quicker to permut with 2nd array than in place - DO ind=1,L_NGAUSS*L_NGAUSS - wtwospec_s(ind) = wtwospec(permut_idx(ind)) - ENDDO - - wtwospec_cum(1) = wtwospec_s(1) - DO ind=2,L_NGAUSS*L_NGAUSS - wtwospec_cum(ind)= wtwospec_cum(ind-1)+wtwospec_s(ind) - ENDDO - - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ! 3. Rebinning on smaller amount of Gauss points ~~~~~~~~~~~ - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ibin=1 - - krecomb(:)=0.0 - - DO ig=1, L_NGAUSS-1 - - DO ind=ibin,L_NGAUSS*L_NGAUSS ! rather than a while - IF ( wtwospec_cum(ind) .GT. w_cum(ig) ) THEN - wsplit = w_cum(ig) - wtwospec_cum(ind-1) - krecomb(ig) = krecomb(ig) & - + sum ( wtwospec_s(ibin:ind-1)*ktwospec_s(ibin:ind-1) ) & - + wsplit*ktwospec_s(ind) - krecomb(ig+1) = (wtwospec_s(ind)-wsplit)*ktwospec_s(ind) - ibin=ind+1 - EXIT - ENDIF - ENDDO - - krecomb(L_NGAUSS) = krecomb(L_NGAUSS) + sum ( wtwospec_s(ibin:)*ktwospec_s(ibin:) ) - - ENDDO - - krecomb(1:L_NGAUSS-1) = krecomb(1:L_NGAUSS-1) / gweight(1:L_NGAUSS-1) ! gw(L_NGAUSS)=0 - - ENDDO ! ispec=1,nrecomb_qotf - gasi_recomb(it,ip,ix,iw,:) = krecomb(:) - ENDDO ! iw=1,L_NSPECTI - - ! ------------------- - ! II. VISIBLE - ! ------------------- - - if(fract(igrid) .lt. 1.0e-4) cycle ! Only during daylight. - - DO iw=1,L_NSPECTV - DO ig=1,L_NGAUSS ! init correlated-k with first gas - krecomb(ig) = pqr(1,ip)*gasv_otf(ig,1,iw,it,ip) - ENDDO - DO ispec=2,nrecomb_qotf ! Loop on additional species - - DO ig=1,L_NGAUSS - tmpk(ig) = pqr(ispec,ip)*gasv_otf(ig,ispec,iw,it,ip) - ENDDO - - ! Save ( a lot of ) CPU time, we don't add the specie if negligible absorption in the band - IF ( tmpk(L_NGAUSS-1) .LE. tlimit ) CYCLE - IF ( ALL( tmpk(1:L_NGAUSS-1) .LE. krecomb(1:L_NGAUSS-1)*0.01 ) ) CYCLE - IF ( ALL( krecomb(1:L_NGAUSS-1) .LE. tmpk(1:L_NGAUSS-1)*0.01 ) ) THEN - krecomb(1:L_NGAUSS-1) = tmpk(1:L_NGAUSS-1) - CYCLE - ENDIF - - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ! 1. Recombining ~~~~~~~~~~~~~~~~~~~~~~~~~ - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - DO ig=1,L_NGAUSS - DO jg=1, L_NGAUSS - ind = jg+(ig-1)*L_NGAUSS - ktwospec(ind) = krecomb(ig)+tmpk(jg) - ENDDO - ENDDO - - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ! 2. Resorting ~~~~~~~~~~~~~~~~~~~~~~~ - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - ! Pre-sort from last step ( we have always a similar regular pattern ) to gain time for sorting - ! NB : quite small array, quicker to permut with 2nd array than in place - DO ind=1,L_NGAUSS*L_NGAUSS - ktwospec_s(ind) = ktwospec(permut_idx(ind)) ! NB : won't do anything at firstcall - ENDDO - - CALL isort(ktwospec_s,L_NGAUSS*L_NGAUSS,permut_idx) ! Insertion sort quicker because pre-sorted - - ! Sort w according to permutations of k. - ! NB : quite small array, quicker to permut with 2nd array than in place - DO ind=1,L_NGAUSS*L_NGAUSS - wtwospec_s(ind) = wtwospec(permut_idx(ind)) - ENDDO - - wtwospec_cum(1) = wtwospec_s(1) - DO ind=2,L_NGAUSS*L_NGAUSS - wtwospec_cum(ind)= wtwospec_cum(ind-1)+wtwospec_s(ind) - ENDDO - - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ! 3. Rebinning on smaller amount of Gauss points ~~~~~~~~~~~ - ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ibin=1 - - krecomb(:)=0.0 - - DO ig=1, L_NGAUSS-1 - - DO ind=ibin,L_NGAUSS*L_NGAUSS ! rather than a while - IF ( wtwospec_cum(ind) .GT. w_cum(ig) ) THEN - wsplit = w_cum(ig) - wtwospec_cum(ind-1) - krecomb(ig) = krecomb(ig) & - + sum ( wtwospec_s(ibin:ind-1)*ktwospec_s(ibin:ind-1) ) & - + wsplit*ktwospec_s(ind) - krecomb(ig+1) = (wtwospec_s(ind)-wsplit)*ktwospec_s(ind) - ibin=ind+1 - EXIT - ENDIF - ENDDO - - krecomb(L_NGAUSS) = krecomb(L_NGAUSS) + sum ( wtwospec_s(ibin:)*ktwospec_s(ibin:) ) - - ENDDO - - krecomb(1:L_NGAUSS-1) = krecomb(1:L_NGAUSS-1) / gweight(1:L_NGAUSS-1) ! gw(L_NGAUSS)=0 - - ENDDO ! ispec=1,nrecomb_qotf - gasv_recomb(it,ip,ix,iw,:) = krecomb(:) - ENDDO ! iw=1,L_NSPECTV - - useptx(it,ip,ix) = .false. - enddo ! ix=1,L_NTREF - enddo ! it=1,L_PINT - enddo ! ip=1,L_REFVAR - - END SUBROUTINE recombin_corrk_mix_allotf - - END MODULE recombin_corrk_mod - Index: trunk/LMDZ.GENERIC/libf/phygeneric/rings.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/rings.F90 (revision 4062) +++ (revision ) @@ -1,197 +1,0 @@ -SUBROUTINE rings(ngrid, declin, ptime, rad, flat, eclipse) -! Calculates Saturn's rings shadowing -! Includes rings opacities measured by Cassini/UVIS -! Authors: M. Sylvestre, M. Capderou, S. Guerlet, A. Spiga - - use comdiurn_h, only: sinlat, sinlon, coslat, coslon - use geometry_mod, only: latitude ! (rad) - - implicit none - - INTEGER, INTENT(IN) :: ngrid ! horizontal grid dimension - REAL, INTENT(IN) :: declin ! latitude of the subsolar point - REAL, INTENT(IN) :: ptime ! UTC time in sol fraction : ptime=0.5 at noon - REAL, INTENT(IN) :: rad ! equatorial radius of the planet - REAL, INTENT(IN) :: flat ! flattening of the planet - REAL, DIMENSION(ngrid), INTENT(OUT) :: eclipse ! absorption of the light by the rings - - REAL :: rpol ! polar radius of the planet - REAL :: e ! shape excentricity of the planet : (1-e*e) = (1-f)*(1-f) - INTEGER, PARAMETER :: nb_a = 4 ! number of subdivisions of the A ring - INTEGER, PARAMETER :: nb_b = 3 ! number of subdivisions of the B ring - INTEGER, PARAMETER :: nb_c = 3 ! number of subdivisions of the C ring - INTEGER, PARAMETER :: nb_ca = 2 ! number of subdivisions in the Cassini division - INTEGER :: i - - ! arrays for the rings. TBD: dynamical? - REAL, DIMENSION(nb_a) :: A_Rint ! internal radii of the subdivisions of the A ring - REAL, DIMENSION(nb_a) :: A_Rext ! external radii of the subdivisions of the A ring - REAL, DIMENSION(nb_b) :: B_Rint ! internal radii of the subdivisions of the B ring - REAL, DIMENSION(nb_b) :: B_Rext ! external radii of the subdivisions of the B ring - REAL, DIMENSION(nb_c) :: C_Rint ! internal radii of the subdivisions of the C ring - REAL, DIMENSION(nb_c) :: C_Rext ! external radii of the subdivisions of the C ring - REAL, DIMENSION(nb_ca) :: Ca_Rint ! internal radii of the subdivisions of the Cassini Division - REAL, DIMENSION(nb_ca) :: Ca_Rext ! external radii of the subdivisions of the Cassini Division - - ! Opacities of the rings : for each one we can give different opacities for each part - REAL, DIMENSION(nb_a) :: tau_A ! opacity of the A ring - REAL, DIMENSION(nb_b) :: tau_B ! opacity of the B ring - REAL, DIMENSION(nb_c) :: tau_C ! opacity of the C ring - REAL, DIMENSION(nb_ca) :: tau_Ca ! opacity of the Cassini Division - - ! Parameters used to calculate if a point is under a ring subdivision's shadow - REAL :: phi_S ! subsolar point longitude - REAL, PARAMETER :: pi=acos(-1.0) - REAL, DIMENSION(:), ALLOCATABLE:: x, y, z ! cartesian coordinates of the points on the planet - REAL :: xs, ys, zs ! cartesian coordinates of the points of the subsolar point - REAL, DIMENSION(:), ALLOCATABLE :: k - REAL, DIMENSION(:), ALLOCATABLE :: N ! parameter to compute cartesian coordinates on a ellipsoidal planet - REAL, DIMENSION(:), ALLOCATABLE :: r ! distance at which the incident ray of sun crosses the equatorial plane - ! measured from the center of the planet - REAL :: Ns ! (same for the subsolar point) - - ! equinox --> no shadow (AS: why is this needed?) - if(declin .eq. 0.) then - eclipse(:) = 0. - return - endif - -! 1) INITIALIZATION - - ! Generic - rpol = (1.- flat)*rad - e = sqrt(2*flat - flat**2) - ALLOCATE(x(ngrid)) - ALLOCATE(y(ngrid)) - ALLOCATE(z(ngrid)) - ALLOCATE(k(ngrid)) - ALLOCATE(N(ngrid)) - ALLOCATE(r(ngrid)) - eclipse(:) = 2000. - -! Model of the rings with Cassini/UVIS opacities - - ! Size of the rings - A_Rint(1) = 2.03*rad - A_Rext(1) = 2.06*rad - A_Rint(2) = 2.06*rad - A_Rext(2) = 2.09*rad - A_Rint(3) = 2.09*rad - A_Rext(3) = 2.12*rad - A_Rint(4) = 2.12*rad - A_Rext(4) = 2.27*rad - - B_Rint(1) = 1.53*rad - B_Rext(1) = 1.64*rad - B_Rint(2) = 1.64*rad - B_Rext(2) = 1.83*rad - B_Rint(3) = 1.83*rad - B_Rext(3) = 1.95*rad - - C_Rint(1) = 1.24*rad - C_Rext(1) = 1.29*rad - C_Rint(2) = 1.29*rad - C_Rext(2) = 1.43*rad - C_Rint(3) = 1.43*rad - C_Rext(3) = 1.53*rad - - Ca_Rint(1) = 1.95*rad - Ca_Rext(1) = 1.99*rad - Ca_Rint(2) = 1.99*rad - Ca_Rext(2) = 2.03*rad - - - ! Opacities of the rings - tau_A(1) = 1.24 - tau_A(2) = 0.81 - tau_A(3) = 0.67 - tau_A(4) = 0.58 - - tau_B(1) = 1.29 - tau_B(2) = 5.13 - tau_B(3) = 2.84 - - tau_C(1) = 0.06 - tau_C(2) = 0.10 - tau_C(3) = 0.14 - - tau_Ca(1) = 0.06 - tau_Ca(2) = 0.24 - - ! Convert to cartesian coordinates - N(:) = rad / sqrt(1-(e**2)*sinlat(:)**2) - x(:) = N(:)*coslat(:)*coslon(:) - y(:) = N(:)*coslat(:)*sinlon(:) - z(:) = N(:)*(1-e**2)*sinlat(:) - -! 2) LOCATION OF THE SUBSOLAR POINT - - ! subsolar longitude is deduced from time fraction ptime - ! SG: the minus sign is important! ... otherwise subsolar point adopts a reverse rotation - phi_S = -(ptime - 0.5)*2.*pi -! write(*,*) 'subsol point coords : ', declin*180./pi, phi_S*180./pi - - ! subsolar latitude is declin (declination of the sun) - ! now convert in cartesian coordinates : - Ns = rad/sqrt(1-(e**2)*sin(declin)**2) - xs = Ns*cos(declin)*cos(phi_S) - ys = Ns*cos(declin)*sin(phi_S) - zs = Ns*(1-e**2)*sin(declin) - -! 3) WHERE DOES THE INCIDENT RAY OF SUN CROSS THE EQUATORIAL PLAN ? - - k(:) = -z(:)/zs - r(:) = (k(:)*xs + x(:))**2 + (k(:)*ys + y(:))**2 - r(:) = sqrt(r(:)) - -! 4) SO WHERE ARE THE SHADOW OF THESE RINGS ? - - ! Summer hemisphere is not under the shadow of the rings - where(latitude(:)*declin .gt. 0.) - eclipse(:) = 1000. - end where - - ! No shadow of the rings by night - where(x(:)*xs + y(:)*ys + z(:)*zs .lt. 0.) - eclipse(:) = 1000. - end where - - ! if the incident rays of sun cross a ring, there is a shadow - do i=1, nb_A - where(r(:) .ge. A_Rint(i) .and. r(:) .le. A_Rext(i) .and. eclipse(:) .ne. 1000.) - eclipse(:) = 1. - exp(-tau_A(i)/abs(sin(declin))) - end where - end do - - do i=1, nb_B - where(r(:) .ge. B_Rint(i) .and. r(:) .le. B_Rext(i) .and. eclipse(:) .ne. 1000.) - eclipse(:) = 1. - exp(-tau_B(i)/abs(sin(declin))) - end where - enddo - - do i=1, nb_C - where(r(:) .ge. C_Rint(i) .and. r(:) .le. C_Rext(i) .and. eclipse(:) .ne. 1000.) - eclipse(:) = 1. - exp(-tau_C(i)/abs(sin(declin))) - end where - enddo - - do i=1, nb_ca - where(r(:) .ge. Ca_Rint(i) .and. r(:) .le. Ca_Rext(i) .and. eclipse(:) .ne. 1000.) - eclipse(:) = 1. - exp(-tau_Ca(i)/abs(sin(declin))) - end where - enddo - - ! At the other places and the excluded ones, eclipse is 0. - where(eclipse(:) .eq. 2000. .or. eclipse(:) .eq. 1000.) - eclipse(:) = 0. - end where - -! 5) CLEAN THE PLACE - DEALLOCATE(x) - DEALLOCATE(y) - DEALLOCATE(z) - DEALLOCATE(k) - DEALLOCATE(N) - DEALLOCATE(r) - -END SUBROUTINE rings Index: trunk/LMDZ.GENERIC/libf/phygeneric/setspi.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/setspi.F90 (revision 4062) +++ (revision ) @@ -1,226 +1,0 @@ - subroutine setspi - -!================================================================== -! -! Purpose -! ------- -! Set up spectral intervals and Planck function in the longwave. -! -! Authors -! ------- -! Adapted from setspi in the NASA Ames radiative code by -! Robin Wordsworth (2009). -! -! Called by -! --------- -! callcorrk.F -! -! Calls -! ----- -! none -! -!================================================================== - - use radinc_h, only: L_NSPECTI,corrkdir,banddir,NTstart,NTstop,NTfac - use radcommon_h, only: BWNI,BLAMI,WNOI,DWNI,WAVEI,planckir,sigma - use datafile_mod, only: datadir - use comcstfi_mod, only: pi - - implicit none - - logical file_ok - integer nw, nt, m, mm, file_entries - real*8 a, b, ans, y, bpa, bma, T, dummy - - character(len=30) :: temp1 - character(len=200) :: file_id - character(len=200) :: file_path - -! C1 and C2 values from Goody and Yung (2nd edition) MKS units -! These values lead to a "sigma" (sigma*T^4) of 5.67032E-8 W m^-2 K^-4 - - real*8 :: c1 = 3.741832D-16 ! W m^-2 - real*8 :: c2 = 1.438786D-2 ! m K - - real*8 :: lastband(2), plancksum - - !! used to count lines - integer :: nb - integer :: ierr - - logical forceEC, planckcheck - - real*8 :: x(12) = [ -0.981560634246719D0, -0.904117256370475D0, & - -0.769902674194305D0, -0.587317954286617D0, & - -0.367831498998180D0, -0.125233408511469D0, & - 0.125233408511469D0, 0.367831498998180D0, & - 0.587317954286617D0, 0.769902674194305D0, & - 0.904117256370475D0, 0.981560634246719D0 ] - - real*8 :: w(12) = [ 0.047175336386512D0, 0.106939325995318D0, & - 0.160078328543346D0, 0.203167426723066D0, & - 0.233492536538355D0, 0.249147045813403D0, & - 0.249147045813403D0, 0.233492536538355D0, & - 0.203167426723066D0, 0.160078328543346D0, & - 0.106939325995318D0, 0.047175336386512D0 ] - mm=0 - - forceEC=.true. - planckcheck=.true. - -!======================================================================= -! Set up spectral bands - wavenumber [cm^(-1)]. Go from smaller to -! larger wavenumbers. - - write(temp1,'(i2.2)') L_NSPECTI - !file_id='/corrk_data/' // corrkdir(1:LEN_TRIM(corrkdir)) // '/narrowbands_IR.in' - file_id='/corrk_data/'//trim(adjustl(banddir))//'/narrowbands_IR.in' - file_path=TRIM(datadir)//TRIM(file_id) - - ! check that the file exists - inquire(FILE=file_path,EXIST=file_ok) - if(.not.file_ok) then - write(*,*)'The file ',TRIM(file_path) - write(*,*)'was not found by setspi.F90, exiting.' - write(*,*)'Check that your path to datagcm:',trim(datadir) - write(*,*)' is correct. You can change it in callphys.def with:' - write(*,*)' datadir = /absolute/path/to/datagcm' - write(*,*)'Also check that the corrkdir you chose in callphys.def exists.' - call abort_physic("setspi","Unable to read file",1) - endif - -!$OMP MASTER - nb=0 - ierr=0 - ! check that the file contains the right number of bands - open(131,file=file_path,form='formatted') - read(131,*,iostat=ierr) file_entries - do while (ierr==0) - read(131,*,iostat=ierr) dummy -! write(*,*) 'setspi: file_entries:',dummy,'ierr=',ierr - if (ierr==0) nb=nb+1 - enddo - close(131) - - write(*,*) 'setspi: L_NSPECTI = ',L_NSPECTI, 'in the model ' - write(*,*) ' there are ',nb, 'entries in ',TRIM(file_path) - if(nb.ne.L_NSPECTI) then - write(*,*) 'MISMATCH !! I stop here' - call abort_physic("setspi","The number of entries in narrowbands_IR.in does not match with L_NSPECTI",1) - endif - - ! load and display the data - open(111,file=file_path,form='formatted') - read(111,*) - do M=1,L_NSPECTI-1 - read(111,*) BWNI(M) - end do - read(111,*) lastband - close(111) - BWNI(L_NSPECTI) =lastband(1) - BWNI(L_NSPECTI+1)=lastband(2) -!$OMP END MASTER -!$OMP BARRIER - - print*,'' - print*,'setspi: IR band limits:' - do M=1,L_NSPECTI+1 - print*,m,'-->',BWNI(M),' cm^-1' - end do - -! Set up mean wavenumbers and wavenumber deltas. Units of -! wavenumbers is cm^(-1); units of wavelengths is microns. - - do M=1,L_NSPECTI - WNOI(M) = 0.5D0*(BWNI(M+1)+BWNI(M)) - DWNI(M) = BWNI(M+1)-BWNI(M) - WAVEI(M) = 1.0D+4/WNOI(M) - BLAMI(M) = 0.01D0/BWNI(M) - end do - BLAMI(M) = 0.01D0/BWNI(M) -! note M=L_NSPECTI+1 after loop due to Fortran bizarreness - -!======================================================================= -! For each IR wavelength interval, compute the integral of B(T), the -! Planck function, divided by the wavelength interval, in cm-1. The -! integration is in MKS units, the final answer is the same as the -! original planck.f; W m^-2 wavenumber^-1, where wavenumber is in CM^-1. - - print*,'' - print*,'setspi: Current Planck integration range:' - print*,'T = ',dble(NTstart)/NTfac, ' to ',dble(NTstop)/NTfac,' K.' - - IF(.NOT.ALLOCATED(planckir)) ALLOCATE(planckir(L_NSPECTI,NTstop-NTstart+1)) - - do NW=1,L_NSPECTI - a = 1.0D-2/BWNI(NW+1) - b = 1.0D-2/BWNI(NW) - bpa = (b+a)/2.0D0 - bma = (b-a)/2.0D0 - ! if (nw .eq. 25) then !LT debug - ! print*, "a = ",a - ! print*, "b= ",b - ! print*,"bpa = ",bpa - ! print*, "bma = ",bma - ! endif - do nt=NTstart,NTstop - T = dble(NT)/NTfac - ans = 0.0D0 - do mm=1,12 - y = bma*x(mm)+bpa - !to avoid floating overflow when T is low and optical wavelength - if ((c2/(y*T)) .lt. 700.0D0) then - ans = ans + w(mm)*c1/(y**5*(exp(c2/(y*T))-1.0D0)) - else - ans = ans +0.0D0 - endif - end do - planckir(NW,nt-NTstart+1) = ans*bma/(PI*DWNI(NW)) - end do - end do - - ! force planck=sigma*eps*T^4 for each temperature in array - if(forceEC)then - print*,'setspi: Force F=sigma*eps*T^4 for all values of T!' - do nt=NTstart,NTstop - plancksum=0.0D0 - T=dble(NT)/NTfac - - do NW=1,L_NSPECTI - plancksum=plancksum+ & - planckir(NW,nt-NTstart+1)*DWNI(NW)*pi - end do - - do NW=1,L_NSPECTI - planckir(NW,nt-NTstart+1)= & - planckir(NW,nt-NTstart+1)* & - sigma*(dble(nt)/NTfac)**4/plancksum - end do - end do - endif - - if(planckcheck)then - ! check energy conservation at lower temperature boundary - plancksum=0.0D0 - nt=NTstart - do NW=1,L_NSPECTI - plancksum=plancksum+planckir(NW,nt-NTstart+1)*DWNI(NW)*pi - end do - print*,'setspi: At lower limit:' - print*,'in model sig*T^4 = ',plancksum,' W m^-2' - print*,'actual sig*T^4 = ',sigma*(dble(nt)/NTfac)**4,' W m^-2' - - ! check energy conservation at upper temperature boundary - plancksum=0.0D0 - nt=NTstop - do NW=1,L_NSPECTI - plancksum=plancksum+planckir(NW,nt-NTstart+1)*DWNI(NW)*pi - end do - print*,'setspi: At upper limit:' - print*,'in model sig*T^4 = ',plancksum,' W m^-2' - print*,'actual sig*T^4 = ',sigma*(dble(nt)/NTfac)**4,' W m^-2' - print*,'' - endif - - return - end subroutine setspi Index: trunk/LMDZ.GENERIC/libf/phygeneric/setspv.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/setspv.F90 (revision 4062) +++ (revision ) @@ -1,144 +1,0 @@ - module setspv_mod - - implicit none - - contains - - subroutine setspv - -!================================================================== -! -! Purpose -! ------- -! Set up spectral intervals and stellar spectrum in the shortwave. -! -! Authors -! ------- -! Adapted from setspv in the NASA Ames radiative code by -! Robin Wordsworth (2009). -! -! Called by -! --------- -! callcorrk.F -! -! Calls -! ----- -! ave_stelspec.F -! -!================================================================== - - use radinc_h, only: L_NSPECTV, corrkdir, banddir - use radcommon_h, only: BWNV,BLAMV,WNOV,DWNV,WAVEV, & - STELLARF - use datafile_mod, only: datadir - use callkeys_mod, only: Fat1AU - use ave_stelspec_mod, only: ave_stelspec - - implicit none - - logical file_ok - - integer N, M, file_entries - - character(len=30) :: temp1 - character(len=200) :: file_id - character(len=200) :: file_path - - real*8 :: lastband(2) - - real*8 STELLAR(L_NSPECTV) - real*8 sum, dummy - - !! used to count lines - integer :: nb - integer :: ierr - -!======================================================================= -! Set up spectral bands - wavenumber [cm^(-1)]. Go from smaller to -! larger wavenumbers, the same as in the IR. - - write(temp1,'(i2.2)') L_NSPECTV - file_id='/corrk_data/'//trim(adjustl(banddir))//'/narrowbands_VI.in' - file_path=TRIM(datadir)//TRIM(file_id) - - ! check that the file exists - inquire(FILE=file_path,EXIST=file_ok) - if(.not.file_ok) then - write(*,*)'The file ',TRIM(file_path) - write(*,*)'was not found by setspv.F90, exiting.' - write(*,*)'Check that your path to datagcm:',trim(datadir) - write(*,*)' is correct. You can change it in callphys.def with:' - write(*,*)' datadir = /absolute/path/to/datagcm' - write(*,*)'Also check that the corrkdir you chose in callphys.def exists.' - call abort_physic("setspv", "Unable to read file",1) - endif - -!$OMP MASTER - nb=0 - ierr=0 - ! check that the file contains the right number of bands - open(131,file=file_path,form='formatted') - read(131,*,iostat=ierr) file_entries - do while (ierr==0) - read(131,*,iostat=ierr) dummy - if (ierr==0) nb=nb+1 - enddo - close(131) - - write(*,*) 'setspv: L_NSPECTV = ',L_NSPECTV, 'in the model ' - write(*,*) ' there are ',nb, 'entries in ',TRIM(file_path) - if(nb.ne.L_NSPECTV) then - write(*,*) 'MISMATCH !! I stop here' - call abort_physic("setspv","The number of entries in narrowbands_VI.in does not match with L_NSPECTV",1) - endif - - ! load and display the data - open(111,file=file_path,form='formatted') - read(111,*) - do M=1,L_NSPECTV-1 - read(111,*) BWNV(M) - end do - read(111,*) lastband - close(111) - BWNV(L_NSPECTV) =lastband(1) - BWNV(L_NSPECTV+1)=lastband(2) -!$OMP END MASTER -!$OMP BARRIER - - print*,'setspv: VI band limits:' - do M=1,L_NSPECTV+1 - print*,m,'-->',BWNV(M),' cm^-1' - end do - print*,' ' - -! Set up mean wavenumbers and wavenumber deltas. Units of -! wavenumbers is cm^(-1); units of wavelengths is microns. - - do M=1,L_NSPECTV - WNOV(M) = 0.5*(BWNV(M+1)+BWNV(M)) - DWNV(M) = BWNV(M+1)-BWNV(M) - WAVEV(M) = 1.0E+4/WNOV(M) - BLAMV(M) = 0.01/BWNV(M) - end do - BLAMV(M) = 0.01/BWNV(M) ! wavelength in METERS for aerosol stuff -! note M=L_NSPECTV+1 after loop due to Fortran bizarreness - -!======================================================================= -! Set up stellar spectrum - - write(*,*)'setspv: Interpolating stellar spectrum from the hires data...' - call ave_stelspec(STELLAR) - -! Sum the stellar flux, and write out the result. - sum = 0.0 - do N=1,L_NSPECTV - STELLARF(N) = STELLAR(N) * Fat1AU - sum = sum+STELLARF(N) - end do - write(6,'("setspv: Stellar flux at 1 AU = ",f9.2," W m-2")') sum - print*,' ' - - END subroutine setspv - - end module setspv_mod - Index: trunk/LMDZ.GENERIC/libf/phygeneric/sfluxi.F =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/sfluxi.F (revision 4062) +++ (revision ) @@ -1,204 +1,0 @@ - module sfluxi_mod - - implicit none - - contains - - SUBROUTINE SFLUXI(PLEV,TLEV,DTAUI,TAUCUMI,UBARI,RSFI,WNOI,DWNI, - * COSBI,WBARI,NFLUXTOPI,NFLUXTOPI_nu, - * FMNETI,fluxupi,fluxdni,fluxupi_nu, - * FZEROI,TAUGSURF) - - use radinc_h, only: NTfac, NTstart, L_LEVELS, L_NSPECTI, L_NGAUSS - use radinc_h, only: L_NLAYRAD, L_NLEVRAD - use radcommon_h, only: planckir, tlimit,sigma, gweight - use comcstfi_mod, only: pi - use gfluxi_mod, only: gfluxi - - implicit none - - integer NLEVRAD, L, NW, NG, NTS, NTT - - real*8 TLEV(L_LEVELS), PLEV(L_LEVELS) - real*8 TAUCUMI(L_LEVELS,L_NSPECTI,L_NGAUSS) - real*8 FMNETI(L_NLAYRAD) - real*8 WNOI(L_NSPECTI), DWNI(L_NSPECTI) - real*8 DTAUI(L_NLAYRAD,L_NSPECTI,L_NGAUSS) - real*8 FMUPI(L_NLEVRAD), FMDI(L_NLEVRAD) - real*8 COSBI(L_NLAYRAD,L_NSPECTI,L_NGAUSS) - real*8 WBARI(L_NLAYRAD,L_NSPECTI,L_NGAUSS) - real*8 NFLUXTOPI - real*8 NFLUXTOPI_nu(L_NSPECTI) - real*8 fluxupi_nu(L_NLAYRAD,L_NSPECTI) - real*8 FTOPUP - - real*8 UBARI, RSFI, TSURF, BSURF, TTOP, BTOP, TAUTOP - real*8 PLANCK, PLTOP - real*8 fluxupi(L_NLAYRAD), fluxdni(L_NLAYRAD) - real*8 FZEROI(L_NSPECTI) - real*8 taugsurf(L_NSPECTI,L_NGAUSS-1), fzero - - real*8 fup_tmp(L_NSPECTI),fdn_tmp(L_NSPECTI) - real*8 PLANCKSUM,PLANCKREF - -! AB : variables for interpolation - REAL*8 C1 - REAL*8 C2 - REAL*8 P1 - -!======================================================================C - - NLEVRAD = L_NLEVRAD - -! ZERO THE NET FLUXES - NFLUXTOPI = 0.0D0 - - DO NW=1,L_NSPECTI - NFLUXTOPI_nu(NW) = 0.0D0 - DO L=1,L_NLAYRAD - FLUXUPI_nu(L,NW) = 0.0D0 - fup_tmp(nw)=0.0D0 - fdn_tmp(nw)=0.0D0 - END DO - END DO - - DO L=1,L_NLAYRAD - FMNETI(L) = 0.0D0 - FLUXUPI(L) = 0.0D0 - FLUXDNI(L) = 0.0D0 - END DO - -! WE NOW ENTER A MAJOR LOOP OVER SPECTRAL INTERVALS IN THE INFRARED -! TO CALCULATE THE NET FLUX IN EACH SPECTRAL INTERVAL - - TTOP = TLEV(2) ! JL12 why not (1) ??? - TSURF = TLEV(L_LEVELS) - - NTS = int(TSURF*NTfac)-NTstart+1 - NTT = int(TTOP *NTfac)-NTstart+1 - -!JL12 corrects the surface planck function so that its integral is equal to sigma Tsurf^4 -!JL12 this ensure that no flux is lost due to: -!JL12 -truncation of the planck function at high/low wavenumber -!JL12 -numerical error during first spectral integration -!JL12 -discrepancy between Tsurf and NTS/NTfac - PLANCKSUM = 0.d0 - PLANCKREF = TSURF * TSURF - PLANCKREF = sigma * PLANCKREF * PLANCKREF - - DO NW=1,L_NSPECTI -! AB : PLANCKIR(NW,NTS) is replaced by P1, the linear interpolation result for a temperature TSURF - C1 = TSURF * NTfac - int(TSURF * NTfac) - P1 = (1.0D0 - C1) * PLANCKIR(NW,NTS) + C1 * PLANCKIR(NW,NTS+1) - PLANCKSUM = PLANCKSUM + P1 * DWNI(NW) - ENDDO - - PLANCKSUM = PLANCKREF / (PLANCKSUM * Pi) -!JL12 - - DO 501 NW=1,L_NSPECTI -! SURFACE EMISSIONS - INDEPENDENT OF GAUSS POINTS -! AB : PLANCKIR(NW,NTS) is replaced by P1, the linear interpolation result for a temperature TSURF -! AB : idem for PLANCKIR(NW,NTT) and PLTOP - C1 = TSURF * NTfac - int(TSURF * NTfac) - C2 = TTOP * NTfac - int(TTOP * NTfac) - P1 = (1.0D0 - C1) * PLANCKIR(NW,NTS) + C1 * PLANCKIR(NW,NTS+1) - BSURF = (1. - RSFI) * P1 * PLANCKSUM - PLTOP = (1.0D0 - C2) * PLANCKIR(NW,NTT) + C2*PLANCKIR(NW,NTT+1) - -! If FZEROI(NW) = 1, then the k-coefficients are zero - skip to the -! special Gauss point at the end. - FZERO = FZEROI(NW) - - IF(FZERO.ge.0.99) goto 40 - - DO NG=1,L_NGAUSS-1 - - if(TAUGSURF(NW,NG).lt. TLIMIT) then - fzero = fzero + (1.0D0-FZEROI(NW))*GWEIGHT(NG) - goto 30 - end if - -! SET UP THE UPPER AND LOWER BOUNDARY CONDITIONS ON THE IR -! CALCULATE THE DOWNWELLING RADIATION AT THE TOP OF THE MODEL -! OR THE TOP LAYER WILL COOL TO SPACE UNPHYSICALLY - -! TAUTOP = DTAUI(1,NW,NG)*PLEV(2)/(PLEV(4)-PLEV(2)) - TAUTOP = TAUCUMI(2,NW,NG) - BTOP = (1.0D0-EXP(-TAUTOP/UBARI))*PLTOP - -! WE CAN NOW SOLVE FOR THE COEFFICIENTS OF THE TWO STREAM -! CALL A SUBROUTINE THAT SOLVES FOR THE FLUX TERMS -! WITHIN EACH INTERVAL AT THE MIDPOINT WAVENUMBER - - CALL GFLUXI(NLEVRAD,TLEV,NW,DWNI(NW),DTAUI(1,NW,NG), - * TAUCUMI(1,NW,NG), - * WBARI(1,NW,NG),COSBI(1,NW,NG),UBARI,RSFI,BTOP, - * BSURF,FTOPUP,FMUPI,FMDI) - -! NOW CALCULATE THE CUMULATIVE IR NET FLUX - NFLUXTOPI = NFLUXTOPI+FTOPUP*DWNI(NW)*GWEIGHT(NG) - * * (1.0D0-FZEROI(NW)) - -! and same thing by spectral band... (RDW) - NFLUXTOPI_nu(NW) = NFLUXTOPI_nu(NW) + FTOPUP * DWNI(NW) - * * GWEIGHT(NG) * (1.0D0-FZEROI(NW)) - - DO L=1,L_NLEVRAD-1 -! CORRECT FOR THE WAVENUMBER INTERVALS - FMNETI(L) = FMNETI(L) + (FMUPI(L)-FMDI(L)) * DWNI(NW) - * * GWEIGHT(NG)*(1.0D0-FZEROI(NW)) - FLUXUPI(L) = FLUXUPI(L) + FMUPI(L)*DWNI(NW)*GWEIGHT(NG) - * * (1.0D0-FZEROI(NW)) - FLUXDNI(L) = FLUXDNI(L) + FMDI(L)*DWNI(NW)*GWEIGHT(NG) - * * (1.0D0-FZEROI(NW)) -! and same thing by spectral band... (RW) - FLUXUPI_nu(L,NW) = FLUXUPI_nu(L,NW) + FMUPI(L)*DWNI(NW) - * * GWEIGHT(NG) * (1.0D0 - FZEROI(NW)) - END DO - - 30 CONTINUE - - END DO !End NGAUSS LOOP - - 40 CONTINUE - -! SPECIAL 17th Gauss point - NG = L_NGAUSS - -! TAUTOP = DTAUI(1,NW,NG)*PLEV(2)/(PLEV(4)-PLEV(2)) - TAUTOP = TAUCUMI(2,NW,NG) - BTOP = (1.0D0-EXP(-TAUTOP/UBARI))*PLTOP - -! WE CAN NOW SOLVE FOR THE COEFFICIENTS OF THE TWO STREAM -! CALL A SUBROUTINE THAT SOLVES FOR THE FLUX TERMS -! WITHIN EACH INTERVAL AT THE MIDPOINT WAVENUMBER - - CALL GFLUXI(NLEVRAD,TLEV,NW,DWNI(NW),DTAUI(1,NW,NG), - * TAUCUMI(1,NW,NG), - * WBARI(1,NW,NG),COSBI(1,NW,NG),UBARI,RSFI,BTOP, - * BSURF,FTOPUP,FMUPI,FMDI) - -! NOW CALCULATE THE CUMULATIVE IR NET FLUX - NFLUXTOPI = NFLUXTOPI+FTOPUP*DWNI(NW)*FZERO - -! and same thing by spectral band... (RW) - NFLUXTOPI_nu(NW) = NFLUXTOPI_nu(NW) - * +FTOPUP*DWNI(NW)*FZERO - - DO L=1,L_NLEVRAD-1 -! CORRECT FOR THE WAVENUMBER INTERVALS - FMNETI(L) = FMNETI(L)+(FMUPI(L)-FMDI(L))*DWNI(NW)*FZERO - FLUXUPI(L) = FLUXUPI(L) + FMUPI(L)*DWNI(NW)*FZERO - FLUXDNI(L) = FLUXDNI(L) + FMDI(L)*DWNI(NW)*FZERO -! and same thing by spectral band... (RW) - FLUXUPI_nu(L,NW) = FLUXUPI_nu(L,NW) - * + FMUPI(L) * DWNI(NW) * FZERO - END DO - - 501 CONTINUE !End Spectral Interval LOOP -! *** END OF MAJOR SPECTRAL INTERVAL LOOP IN THE INFRARED**** - - END SUBROUTINE SFLUXI - - end module sfluxi_mod Index: trunk/LMDZ.GENERIC/libf/phygeneric/sfluxv.F =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/sfluxv.F (revision 4062) +++ (revision ) @@ -1,198 +1,0 @@ - module sfluxv_mod - - implicit none - - contains - - SUBROUTINE SFLUXV(DTAUV,TAUV,TAUCUMV,RSFV,DWNV,WBARV,COSBV, - * UBAR0,STEL,NFLUXTOPV,FLUXTOPVDN, - * NFLUXOUTV_nu,NFLUXGNDV_nu, - * FMNETV,FLUXUPV,FLUXDNV,FZEROV,taugsurf) - - use radinc_h, only: L_TAUMAX, L_LEVELS, L_NSPECTV, L_NGAUSS - use radinc_h, only: L_NLAYRAD, L_NLEVRAD - use radcommon_h, only: tlimit, gweight - use gfluxv_mod, only: gfluxv - - implicit none - - real*8 FMNETV(L_NLAYRAD) - real*8 TAUCUMV(L_LEVELS,L_NSPECTV,L_NGAUSS) - real*8 TAUV(L_NLEVRAD,L_NSPECTV,L_NGAUSS) - real*8 DTAUV(L_NLAYRAD,L_NSPECTV,L_NGAUSS), DWNV(L_NSPECTV) - real*8 FMUPV(L_NLAYRAD), FMDV(L_NLAYRAD) - real*8 COSBV(L_NLAYRAD,L_NSPECTV,L_NGAUSS) - real*8 WBARV(L_NLAYRAD,L_NSPECTV,L_NGAUSS) - real*8 STEL(L_NSPECTV) - real*8 FLUXUPV(L_NLAYRAD), FLUXDNV(L_NLAYRAD) - real*8 NFLUXTOPV, FLUXUP, FLUXDN,FLUXTOPVDN - real*8 NFLUXOUTV_nu(L_NSPECTV) - real*8 NFLUXGNDV_nu(L_NSPECTV) - - integer L, NG, NW, NG1,k - real*8 ubar0, f0pi, btop, bsurf, taumax, eterm - real*8 rsfv(L_NSPECTV) ! Spectral dependency added by MT2015. - real*8 FZEROV(L_NSPECTV) - - real*8 DIFFV, DIFFVT - real*8 taugsurf(L_NSPECTV,L_NGAUSS-1), fzero - -C======================================================================C - - TAUMAX = L_TAUMAX - -C ZERO THE NET FLUXES - - NFLUXTOPV = 0.0 - FLUXTOPVDN = 0.0 - - DO NW=1,L_NSPECTV - NFLUXOUTV_nu(NW)=0.0 - NFLUXGNDV_nu(NW)=0.0 - END DO - - DO L=1,L_NLAYRAD - FMNETV(L) = 0.0 - FLUXUPV(L) = 0.0 - FLUXDNV(L) = 0.0 - END DO - - DIFFVT = 0.0 - -C WE NOW ENTER A MAJOR LOOP OVER SPECTRAL INTERVALS IN THE VISIBLE -C TO CALCULATE THE NET FLUX IN EACH SPECTRAL INTERVAL - - DO 500 NW=1,L_NSPECTV - - F0PI = STEL(NW) - - FZERO = FZEROV(NW) - IF(FZERO.ge.0.99) goto 40 - DO NG=1,L_NGAUSS-1 - - if(TAUGSURF(NW,NG) .lt. TLIMIT) then - - fzero = fzero + (1.0-FZEROV(NW))*GWEIGHT(NG) - - goto 30 - end if - -C SET UP THE UPPER AND LOWER BOUNDARY CONDITIONS ON THE VISIBLE - - BTOP = 0.0 - !BSURF = 0./0. ! why was this here? - BSURF = 0. -C LOOP OVER THE NTERMS BEGINNING HERE - - -! FACTOR = 1.0D0 - WDEL(1)*CDEL(1)**2 -! TAU(1) = TDEL(1)*FACTOR - - - ETERM = MIN(TAUV(L_NLEVRAD,NW,NG),TAUMAX) - BSURF = RSFV(NW)*UBAR0*STEL(NW)*EXP(-ETERM/UBAR0) - -C WE CAN NOW SOLVE FOR THE COEFFICIENTS OF THE TWO STREAM -C CALL A SUBROUTINE THAT SOLVES FOR THE FLUX TERMS -C WITHIN EACH INTERVAL AT THE MIDPOINT WAVENUMBER -C -C FUW AND FDW ARE WORKING FLUX ARRAYS THAT WILL BE USED TO -C RETURN FLUXES FOR A GIVEN NT - - - CALL GFLUXV(DTAUV(1,NW,NG),TAUV(1,NW,NG),TAUCUMV(1,NW,NG), - * WBARV(1,NW,NG),COSBV(1,NW,NG),UBAR0,F0PI,RSFV(NW), - * BTOP,BSURF,FMUPV,FMDV,DIFFV,FLUXUP,FLUXDN) - -C NOW CALCULATE THE CUMULATIVE VISIBLE NET FLUX - - NFLUXTOPV = NFLUXTOPV+(FLUXUP-FLUXDN)*GWEIGHT(NG)* - * (1.0-FZEROV(NW)) - FLUXTOPVDN = FLUXTOPVDN+FLUXDN*GWEIGHT(NG)* - * (1.0-FZEROV(NW)) - DO L=1,L_NLAYRAD - FMNETV(L)=FMNETV(L)+( FMUPV(L)-FMDV(L) )* - * GWEIGHT(NG)*(1.0-FZEROV(NW)) - FLUXUPV(L) = FLUXUPV(L) + FMUPV(L)*GWEIGHT(NG)* - * (1.0-FZEROV(NW)) - FLUXDNV(L) = FLUXDNV(L) + FMDV(L)*GWEIGHT(NG)* - * (1.0-FZEROV(NW)) - END DO - -c band-resolved flux leaving TOA (RDW) - NFLUXOUTV_nu(NW) = NFLUXOUTV_nu(NW) - * +FLUXUP*GWEIGHT(NG)*(1.0-FZEROV(NW)) - -c band-resolved flux at ground (RDW) - NFLUXGNDV_nu(NW) = NFLUXGNDV_nu(NW) - * +FMDV(L_NLAYRAD)*GWEIGHT(NG)*(1.0-FZEROV(NW)) - - -C THE DIFFUSE COMPONENT OF THE DOWNWARD STELLAR FLUX - - DIFFVT = DIFFVT + DIFFV*GWEIGHT(NG)*(1.0-FZEROV(NW)) - - 30 CONTINUE - - END DO ! the Gauss loop - - 40 continue -C Special 17th Gauss point - - NG = L_NGAUSS - -C SET UP THE UPPER AND LOWER BOUNDARY CONDITIONS ON THE VISIBLE - - BTOP = 0.0 - -C LOOP OVER THE NTERMS BEGINNING HERE - - ETERM = MIN(TAUV(L_NLEVRAD,NW,NG),TAUMAX) - BSURF = RSFV(NW)*UBAR0*STEL(NW)*EXP(-ETERM/UBAR0) - - -C WE CAN NOW SOLVE FOR THE COEFFICIENTS OF THE TWO STREAM -C CALL A SUBROUTINE THAT SOLVES FOR THE FLUX TERMS -C WITHIN EACH INTERVAL AT THE MIDPOINT WAVENUMBER -C -C FUW AND FDW ARE WORKING FLUX ARRAYS THAT WILL BE USED TO -C RETURN FLUXES FOR A GIVEN NT - - CALL GFLUXV(DTAUV(1,NW,NG),TAUV(1,NW,NG),TAUCUMV(1,NW,NG), - * WBARV(1,NW,NG),COSBV(1,NW,NG),UBAR0,F0PI,RSFV(NW), - * BTOP,BSURF,FMUPV,FMDV,DIFFV,FLUXUP,FLUXDN) - - -C NOW CALCULATE THE CUMULATIVE VISIBLE NET FLUX - - NFLUXTOPV = NFLUXTOPV+(FLUXUP-FLUXDN)*FZERO - FLUXTOPVDN = FLUXTOPVDN+FLUXDN*FZERO - DO L=1,L_NLAYRAD - FMNETV(L)=FMNETV(L)+( FMUPV(L)-FMDV(L) )*FZERO - FLUXUPV(L) = FLUXUPV(L) + FMUPV(L)*FZERO - FLUXDNV(L) = FLUXDNV(L) + FMDV(L)*FZERO - END DO - -c band-resolved flux leaving TOA (RDW) - NFLUXOUTV_nu(NW) = NFLUXOUTV_nu(NW) - * +FLUXUP*FZERO - -c band-resolved flux at ground (RDW) - NFLUXGNDV_nu(NW) = NFLUXGNDV_nu(NW)+FMDV(L_NLAYRAD)*FZERO - - -C THE DIFFUSE COMPONENT OF THE DOWNWARD STELLAR FLUX - - DIFFVT = DIFFVT + DIFFV*FZERO - - - 500 CONTINUE - - -C *** END OF MAJOR SPECTRAL INTERVAL LOOP IN THE VISIBLE***** - - - END SUBROUTINE SFLUXV - - end module sfluxv_mod - Index: trunk/LMDZ.GENERIC/libf/phygeneric/stelang.F =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/stelang.F (revision 4062) +++ (revision ) @@ -1,121 +1,0 @@ - subroutine stelang(kgrid,psilon,pcolon,psilat,pcolat, - & ptim1,ptim2,ptim3,pmu0,pfract, pflat) - IMPLICIT NONE - -C -C**** *LW* - ORGANIZES THE LONGWAVE CALCULATIONS -C -C PURPOSE. -C -------- -C CALCULATES THE STELLAR ANGLE FOR ALL THE POINTS OF THE GRID -C -C** INTERFACE. -C ---------- -C SUBROUTINE STELANG ( KGRID ) -C -C EXPLICIT ARGUMENTS : -C -------------------- -C ==== INPUTS === -C -C PSILON(KGRID) : SINUS OF THE LONGITUDE -C PCOLON(KGRID) : COSINUS OF THE LONGITUDE -C PSILAT(KGRID) : SINUS OF THE LATITUDE -C PCOLAT(KGRID) : COSINUS OF THE LATITUDE -C PTIM1 : SIN(DECLI) -C PTIM2 : COS(DECLI)*COS(TIME) -C PTIM3 : SIN(DECLI)*SIN(TIME) -C -C ==== OUTPUTS === -C -C PMU0 (KGRID) : SOLAR ANGLE -C PFRACT(KGRID) : DAY FRACTION OF THE TIME INTERVAL -C -C IMPLICIT ARGUMENTS : NONE -C -------------------- -C -C METHOD. -C ------- -C -C EXTERNALS. -C ---------- -C -C NONE -C -C REFERENCE. -C ---------- -C -C RADIATIVE PROCESSES IN METEOROLOGIE AND CLIMATOLOGIE -C PALTRIDGE AND PLATT -C -C AUTHOR. -C ------- -C FREDERIC HOURDIN -C -C MODIFICATIONS. -C -------------- -C ORIGINAL :90-01-14 -C 92-02-14 CALCULATIONS DONE THE ENTIER GRID (J.Polcher) -C----------------------------------------------------------------------- -C -C ------------------------------------------------------------------ - -C----------------------------------------------------------------------- -C -C* 0.1 ARGUMENTS -C --------- -C - INTEGER,INTENT(IN) :: kgrid - REAL,INTENT(IN) :: ptim1,ptim2,ptim3, pflat - REAL,INTENT(IN) :: psilon(kgrid),pcolon(kgrid) - REAL,INTENT(IN) :: psilat(kgrid), pcolat(kgrid) - REAL,INTENT(OUT) :: pmu0(kgrid),pfract(kgrid) -C - INTEGER jl - REAL ztim1,ztim2,ztim3, rap -C------------------------------------------------------------------------ -C------------------------------------------------------------------------ -C------------------------------------------------------------------------ -C -C------------------------------------------------------------------------ -C -C* 1. INITIALISATION -C -------------- -C -c----- SG: geometry adapted to a flattened planet (Feb2014) - - rap = 1./((1.-pflat)**2) - - 100 CONTINUE -C - DO jl=1,kgrid - pmu0(jl)=0. - pfract(jl)=0. - ENDDO -C -C* 1.1 COMPUTATION OF THE SOLAR ANGLE -C ------------------------------ -C - DO jl=1,kgrid - ztim1=psilat(jl)*ptim1*rap - ztim2=pcolat(jl)*ptim2 - ztim3=pcolat(jl)*ptim3 - pmu0(jl)=ztim1+ztim2*pcolon(jl)+ztim3*psilon(jl) - pmu0(jl)=pmu0(jl)/SQRT(pcolat(jl)**2+(rap**2)*(psilat(jl)**2)) - - ENDDO -C -C* 1.2 DISTINCTION BETWEEN DAY AND NIGHT -C --------------------------------- -C - DO jl=1,kgrid - IF (pmu0(jl).gt.0.) THEN - pfract(jl)=1. -c pmu0(jl)=sqrt(1224.*pmu0(jl)*pmu0(jl)+1.)/35. - ELSE -c pmu0(jl)=0. - pfract(jl)=0. - ENDIF - ENDDO -C - RETURN - END Index: trunk/LMDZ.GENERIC/libf/phygeneric/stellarlong.F =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/stellarlong.F (revision 4062) +++ (revision ) @@ -1,101 +1,0 @@ - SUBROUTINE stellarlong(pday,pstellong) - - USE planete_mod, ONLY: year_day, peri_day, e_elips, timeperi - use comcstfi_mod, only: pi - IMPLICIT NONE - -c======================================================================= -c -c Objet: -c ------ -c -c Calcul de la distance soleil-planete et de la declinaison -c en fonction du jour de l'annee. -c -c -c Methode: -c -------- -c -c Calcul complet de l'elipse -c -c Interface: -c ---------- -c -c Uncommon comprenant les parametres orbitaux. -c -c Arguments: -c ---------- -c -c Input: -c ------ -c pday jour de l'annee (le jour 0 correspondant a l'equinoxe) -c -c Output: -c ------- -c pdist_star distance entre le soleil et la planete -c ( en unite astronomique pour utiliser la constante -c solaire terrestre 1370 Wm-2 ) -c pdecli declinaison ( en radians ) -c -c======================================================================= -c----------------------------------------------------------------------- -c Declarations: -c ------------- - -c arguments: -c ---------- - - REAL pday,pdist_star,pdecli,pstellong - LOGICAL lwrite - -c Local: -c ------ - - REAL zanom,xref,zx0,zdx,zteta,zz - INTEGER iter - - -c----------------------------------------------------------------------- -c calcul de l'angle polaire et de la distance au soleil : -c ------------------------------------------------------- - -c calcul de l'zanomalie moyenne - - zz=(pday-peri_day)/year_day - pi=2.*asin(1.) - zanom=2.*pi*(zz-nint(zz)) - xref=abs(zanom) - -c resolution de l'equation horaire zx0 - e * sin (zx0) = xref -c methode de Newton - - zx0=xref+e_elips*sin(xref) - DO 110 iter=1,10 - zdx=-(zx0-e_elips*sin(zx0)-xref)/(1.-e_elips*cos(zx0)) - if(abs(zdx).le.(1.e-7)) goto 120 - zx0=zx0+zdx -110 continue -120 continue - zx0=zx0+zdx - if(zanom.lt.0.) zx0=-zx0 - -c zteta est la longitude solaire - - zteta=2.*atan(sqrt((1.+e_elips)/(1.-e_elips))*tan(zx0/2.)) - - pstellong=zteta-timeperi - - IF(pstellong.LT.0.) pstellong=pstellong+2.*pi - IF(pstellong.GT.2.*pi) pstellong=pstellong-2.*pi -c----------------------------------------------------------------------- -c sorties eventuelles: -c --------------------- - -c IF (lwrite) THEN -c PRINT*,'jour de l"annee :',pday -c PRINT*,'distance au soleil (en unite astronomique) :',pdist_star -c PRINT*,'declinaison (en degres) :',pdecli*180./pi -c ENDIF - - RETURN - END Index: trunk/LMDZ.GENERIC/libf/phygeneric/su_gases.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/su_gases.F90 (revision 4062) +++ trunk/LMDZ.GENERIC/libf/phygeneric/su_gases.F90 (revision 4077) @@ -145,5 +145,5 @@ if(count.ne.ngasmx)then - print*,'Mismatch between ngas and number of recognised gases in sugas_corrk.F90.' + print*,'Mismatch between ngas and number of recognised gases in rad_correlatedk_read_opacity_tables .F90.' print*,'Either we haven`t managed to assign all the gases, or there are duplicates.' print*,'Please try again.' Index: trunk/LMDZ.GENERIC/libf/phygeneric/suaer_corrk.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/suaer_corrk.F90 (revision 4062) +++ (revision ) @@ -1,626 +1,0 @@ -module suaer_corrk_mod - -implicit none - -contains - -subroutine suaer_corrk - - ! inputs - use radinc_h, only: L_NSPECTI,L_NSPECTV,nsizemax,naerkind - use radcommon_h, only: blamv,blami,lamrefir,lamrefvis - use datafile_mod, only: datadir, aerdir - - ! outputs - use radcommon_h, only: QVISsQREF,omegavis,gvis,QIRsQREF,omegair,gir - use radcommon_h, only: radiustab,nsize,tstellar - use radcommon_h, only: qrefvis,qrefir,omegarefir !,omegarefvis - use aerosol_mod, only: noaero,iaero_co2,iaero_h2o,iaero_dust,iaero_h2so4 - use aerosol_mod, only: iaero_back2lay,iaero_nh3,iaero_nlay,iaero_aurora - use aerosol_mod, only: iaero_venus1,iaero_venus2,iaero_venus2p - use aerosol_mod, only: iaero_venus3,iaero_venusUV - use aerosol_mod, only: iaero_generic,i_rgcs_ice - use callkeys_mod, only: tplanet, optprop_back2lay_vis, optprop_back2lay_ir, & - optprop_aeronlay_vis, optprop_aeronlay_ir, & - aeronlay_lamref, nlayaero,aerogeneric - use tracer_h, only: noms - - use mod_phys_lmdz_para, only : is_master, bcast - - implicit none - -!================================================================== -! Purpose -! ------- -! Initialize all radiative aerosol properties -! -! Notes -! ----- -! Reads the optical properties -> Mean -> Variable assignment -! (ASCII files) (see radcommon_h.F90) -! wvl(nwvl) longsun -! ep(nwvl) epav QVISsQREF(L_NSPECTV) -! omeg(nwvl) omegav omegavis(L_NSPECTV) -! gfactor(nwvl) gav gvis(L_NSPECTV) -! -! Authors -! ------- -! Richard Fournier (1996) Francois Forget (1996) -! Frederic Hourdin -! Jean-jacques morcrette *ECMWF* -! MODIF Francois Forget (2000) -! MODIF Franck Montmessin (add water ice) -! MODIF J.-B. Madeleine 2008W27 -! - Optical properties read in ASCII files -! - Add varying radius of the particules -! - Add water ice clouds -! MODIF R. Wordsworth (2009) -! - generalisation to arbitrary spectral bands -! -!================================================================== - -! Optical properties (read in external ASCII files) - INTEGER :: nwvl ! Number of wavelengths in - ! the domain (VIS or IR), read by master - -! REAL :: solsir ! visible to infrared ratio -! ! (tau_0.67um/tau_9um) - - REAL, DIMENSION(:),& - ALLOCATABLE :: wvl ! Wavelength axis, read by master - REAL, DIMENSION(:),& - ALLOCATABLE :: radiusdyn ! Particle size axis, read by master - - REAL, DIMENSION(:,:),& - ALLOCATABLE :: ep,& ! Extinction coefficient Qext, read by master - omeg,& ! Single Scattering Albedo, read by master - gfactor ! Assymetry Factor, read by master - -! Local variables: - - INTEGER :: iaer ! Aerosol index - INTEGER :: idomain ! Domain index (1=VIS,2=IR) - INTEGER :: ilw ! longwave index - INTEGER :: isw ! shortwave index - INTEGER :: isize ! Particle size index - INTEGER :: jfile ! ASCII file scan index - INTEGER :: file_unit = 60 - LOGICAL :: file_ok, endwhile - CHARACTER(LEN=132) :: scanline ! ASCII file scanning line - -! I/O of "aerave" (subroutine that spectrally averages -! the single scattering parameters) - - REAL lamref ! reference wavelengths - REAL epref ! reference extinction ep - - REAL epavVI(L_NSPECTV) ! Average ep (= /Qext(lamrefvis) if epref=1) - REAL omegavVI(L_NSPECTV) ! Average single scattering albedo - REAL gavVI(L_NSPECTV) ! Average assymetry parameter - - REAL epavIR(L_NSPECTI) ! Average ep (= /Qext(lamrefir) if epref=1) - REAL omegavIR(L_NSPECTI) ! Average single scattering albedo - REAL gavIR(L_NSPECTI) ! Average assymetry parameter - - logical forgetit ! use francois' data? - integer iwvl, ia - -! Local saved variables: - - CHARACTER(LEN=50),ALLOCATABLE :: file_id(:,:) - -!---- Please indicate the names of the optical property files below -! Please also choose the reference wavelengths of each aerosol - -!--------- README TO UNDERSTAND WHAT FOLLOWS (JVO 20) ------- -! The lamref variables comes from the Martian model -! where the visible one is the one used for computing -! and the IR one is used to output scaled opacity to -! match instrumental data ... This is done (at least -! for now) in the generic, so lamrefir is dummy*! - -! The important one is the VISIBLE one as it will be used -! to rescale the values in callcork.F90 assuming 'aerosol' is -! at this visible reference wavelenght. - -! *Actually if you change lamrefir here there is a -! slight sensitvity in the outputs because of some -! machine precision differences that amplifys and lead -! up to 10-6 differences in the radiative balance... -! This could be good to clean the code but would require -! a lot of modifs and to take care ! - -!-------------------------------------------------------------- - ! allocate file_id, as naerkind is a variable - allocate(file_id(naerkind,2)) - - if (noaero) then - print*, 'naerkind= 0' - endif - do iaer=1,naerkind - if (iaer.eq.iaero_co2) then - forgetit=.false. - if (.not.noaero) then - print*, 'naerkind= co2', iaer - end if -! visible - if(forgetit)then - file_id(iaer,1) = 'optprop_co2_vis_ff.dat' ! Francois' values - else - file_id(iaer,1) = 'optprop_co2ice_vis_n50.dat' - endif - lamrefvis(iaer)=1.5E-6 ! 1.5um OMEGA/MEx ??? - -! infrared - if(forgetit)then - file_id(iaer,2) = 'optprop_co2_ir_ff.dat' ! Francois' values - else - file_id(iaer,2) = 'optprop_co2ice_ir_n50.dat' - endif - lamrefir(iaer)=12.1E-6 ! Dummy in generic phys. (JVO 20) - endif ! CO2 aerosols -! NOTE: these lamref's are currently for dust, not CO2 ice. -! JB thinks this shouldn't matter too much, but it needs to be -! fixed / decided for the final version. - - if (iaer.eq.iaero_h2o) then - print*, 'naerkind= h2o', iaer - -! visible - file_id(iaer,1) = 'optprop_icevis_n50.dat' - lamrefvis(iaer)=1.5E-6 ! 1.5um OMEGA/MEx -! infrared - file_id(iaer,2) = 'optprop_iceir_n50.dat' - lamrefir(iaer)=12.1E-6 ! Dummy in generic phys. (JVO 20) - endif - - if (iaer.eq.iaero_dust) then - print*, 'naerkind= dust', iaer - -! visible - file_id(iaer,1) = 'optprop_dustvis_n50.dat' - !lamrefvis(iaer)=1.5E-6 ! 1.5um OMEGA/MEx - lamrefvis(iaer)=0.67e-6 -! infrared - file_id(iaer,2) = 'optprop_dustir_n50.dat' - lamrefir(iaer)=9.3E-6 ! Dummy in generic phys. (JVO 20) - endif - - if (iaer.eq.iaero_h2so4) then - print*, 'naerkind= h2so4', iaer - -! visible - file_id(iaer,1) = 'optprop_h2so4vis_n20.dat' - lamrefvis(iaer)=1.5E-6 ! no idea, must find -! infrared - file_id(iaer,2) = 'optprop_h2so4ir_n20.dat' - lamrefir(iaer)=9.3E-6 ! ! Dummy in generic phys. (JVO 20) -! added by LK - endif - - if (iaer.eq.iaero_back2lay) then - print*, 'naerkind= back2lay', iaer - -! visible - file_id(iaer,1) = TRIM(optprop_back2lay_vis) - lamrefvis(iaer)=0.8E-6 ! This is the important one. -! infrared - file_id(iaer,2) = TRIM(optprop_back2lay_ir) - lamrefir(iaer)=6.E-6 ! This is dummy. -! added by SG - endif - - if (iaer.eq.iaero_nh3) then - print*, 'naerkind= nh3', iaer - -! visible - file_id(iaer,1) = 'optprop_nh3ice_vis.dat' - lamrefvis(iaer)=0.756E-6 ! -! infrared - file_id(iaer,2) = 'optprop_nh3ice_ir.dat' - lamrefir(iaer)=6.E-6 ! dummy -! added by SG - endif - - do ia=1,nlayaero - if (iaer.eq.iaero_nlay(ia)) then - print*, 'naerkind= nlay', iaer - -! visible - file_id(iaer,1) = TRIM(optprop_aeronlay_vis(ia)) - lamrefvis(iaer)=aeronlay_lamref(ia) -! infrared - file_id(iaer,2) = TRIM(optprop_aeronlay_ir(ia)) - lamrefir(iaer)=6.E-6 ! Dummy value - endif - enddo -! added by JVO - - if (iaer.eq.iaero_aurora) then - print*, 'naerkind= aurora', iaer - -! visible - file_id(iaer,1) = 'optprop_aurora_vis.dat' - lamrefvis(iaer)=0.3E-6 ! -! infrared - file_id(iaer,2) = 'optprop_aurora_ir.dat' - lamrefir(iaer)=6.E-6 ! dummy -! added by SG - endif - -! VENUS CLOUDS - - if (iaer.eq.iaero_venus1) then - print*, 'naerkind= venus1', iaer - -! visible - file_id(iaer,1) = 'optprop_h2so4vis_n50.dat' - lamrefvis(iaer)=1.5E-6 ! no idea, must find -! infrared - file_id(iaer,2) = 'optprop_h2so4ir_n50.dat' - lamrefir(iaer)=9.3E-6 ! no idea, must find -! added by SL - endif - - if (iaer.eq.iaero_venus2) then - print*, 'naerkind= venus2', iaer - -! visible - file_id(iaer,1) = 'optprop_h2so4vis_n50.dat' - lamrefvis(iaer)=1.5E-6 ! no idea, must find -! infrared - file_id(iaer,2) = 'optprop_h2so4ir_n50.dat' - lamrefir(iaer)=9.3E-6 ! no idea, must find -! added by SL - endif - - if (iaer.eq.iaero_venus2p) then - print*, 'naerkind= venus2p', iaer - -! visible - file_id(iaer,1) = 'optprop_h2so4vis_n50.dat' - lamrefvis(iaer)=1.5E-6 ! no idea, must find -! infrared - file_id(iaer,2) = 'optprop_h2so4ir_n50.dat' - lamrefir(iaer)=9.3E-6 ! no idea, must find -! added by SL - endif - - if (iaer.eq.iaero_venus3) then - print*, 'naerkind= venus3', iaer - -! visible - file_id(iaer,1) = 'optprop_h2so4vis_n50.dat' - lamrefvis(iaer)=1.5E-6 ! no idea, must find -! infrared - file_id(iaer,2) = 'optprop_h2so4ir_n50.dat' - lamrefir(iaer)=9.3E-6 ! no idea, must find -! added by SL - endif - - if (iaer.eq.iaero_venusUV) then - print*, 'naerkind= venusUV', iaer - -! visible - file_id(iaer,1) = 'optprop_venusUVvis.dat' - lamrefvis(iaer)=3.5E-7 ! Haus et al. 2015 -! infrared - file_id(iaer,2) = 'optprop_venusUVir.dat' - lamrefir(iaer)=9.3E-6 ! not used anyway -! added by SL - endif - -! END VENUS CLOUDS - -! the following was added by LT - do ia=1,aerogeneric ! Read Radiative Generic Condensable Species data - if (iaer .eq. iaero_generic(ia)) then - if (index(noms(i_rgcs_ice(ia)),'Fe') .ne. 0) then - print*,"Reading Fe file" - file_id(iaer,1)='optprop_Fe_IR-VIS_n30.dat' - file_id(iaer,2)='optprop_Fe_IR-VIS_n30.dat' - lamrefvis(iaer) = 1.0E-6 !random pick - lamrefir(iaer) = 1.0E-6 !dummy but random pick - else if (index(noms(i_rgcs_ice(ia)),'Mn') .ne. 0) then - print*,"Reading MnS file" - file_id(iaer,1)='optprop_MnS_extended_IR-VIS_n35.dat' - file_id(iaer,2)='optprop_MnS_extended_IR-VIS_n35.dat' - lamrefvis(iaer) = 1.0E-6 !random pick - lamrefir(iaer) = 1.0E-6 !dummy but random pick - else if (index(noms(i_rgcs_ice(ia)),'Mg') .ne. 0) then - print*,"Reading Mg2SiO4 file" - file_id(iaer,1)='optprop_Mg2SiO4_amorph_extended_IR-VIS_n35.dat' - file_id(iaer,2)='optprop_Mg2SiO4_amorph_extended_IR-VIS_n35.dat' - lamrefvis(iaer) = 1.0E-6 !random pick - lamrefir(iaer) = 1.0E-6 !dummy but random pick - else if (index(noms(i_rgcs_ice(ia)),'Cr') .ne. 0) then - print*,"Reading Cr file" - file_id(iaer,1)='optprop_Cr_IR-VIS_n30.dat' - file_id(iaer,2)='optprop_Cr_IR-VIS_n30.dat' - lamrefvis(iaer) = 1.0E-6 !random pick - lamrefir(iaer) = 1.0E-6 !dummy but random pick - else -! If you want to add another specie, copy,paste & adapt the elseif block up here to your new specie (LT 2022) - call abort_physic("suaer_corrk", "Unknown specie in radiative generic condensable species",1) - endif - endif - enddo ! ia=1,aerogeneric - enddo ! of do iaer=1,naerkind - -!------------------------------------------------------------------ - -! Initializations: - - radiustab(:,:,:) = 0.0 - gvis(:,:,:) = 0.0 - omegavis(:,:,:) = 0.0 - QVISsQREF(:,:,:) = 0.0 - gir(:,:,:) = 0.0 - omegair(:,:,:) = 0.0 - QIRsQREF(:,:,:) = 0.0 - - DO iaer = 1, naerkind ! Loop on aerosol kind - DO idomain = 1, 2 ! Loop on radiation domain (VIS or IR) -!================================================================== -! 1. READ OPTICAL PROPERTIES -!================================================================== - -! 1.1 Open the ASCII file - -!!!!$OMP MASTER - if (is_master) then - - INQUIRE(FILE=TRIM(datadir)//'/'//TRIM(aerdir)//& - '/'//TRIM(file_id(iaer,idomain)),& - EXIST=file_ok) - IF (file_ok) THEN - OPEN(UNIT=file_unit,& - FILE=TRIM(datadir)//'/'//TRIM(aerdir)//& - '/'//TRIM(file_id(iaer,idomain)),& - FORM='formatted') - ELSE - ! In ye old days these files were stored in datadir; - ! let's be retro-compatible - INQUIRE(FILE=TRIM(datadir)//& - '/'//TRIM(file_id(iaer,idomain)),& - EXIST=file_ok) - IF (file_ok) THEN - OPEN(UNIT=file_unit,& - FILE=TRIM(datadir)//& - '/'//TRIM(file_id(iaer,idomain)),& - FORM='formatted') - ENDIF - ENDIF - IF(.NOT.file_ok) THEN - write(*,*)'suaer_corrk: Problem opening ',& - TRIM(file_id(iaer,idomain)) - write(*,*)'It should be in: ',TRIM(datadir)//'/'//TRIM(aerdir) - write(*,*)'1) You can set this directory address ',& - 'in callphys.def with:' - write(*,*)' datadir = /absolute/path/to/datagcm' - write(*,*)'2) If ',& - TRIM(file_id(iaer,idomain)),& - ' is a LMD reference datafile, it' - write(*,*)' can be obtained online at:' - write(*,*)' http://www.lmd.jussieu.fr/',& - '~lmdz/planets/generic/datagcm/' - CALL abort_physic("suaer_corrk", "Unable to read file",1) - ENDIF - -! 1.2 Allocate the optical property table - - jfile = 1 - endwhile = .false. - DO WHILE (.NOT.endwhile) - READ(file_unit,*) scanline - IF ((scanline(1:1) .ne. '#').and.& - (scanline(1:1) .ne. ' ')) THEN - BACKSPACE(file_unit) - reading1_seq: SELECT CASE (jfile) ! ==================== - CASE(1) reading1_seq ! nwvl ---------------------------- - read(file_unit,*) nwvl - jfile = jfile+1 - CASE(2) reading1_seq ! nsize --------------------------- - read(file_unit,*) nsize(iaer,idomain) - endwhile = .true. - CASE DEFAULT reading1_seq ! ---------------------------- - CALL abort_physic("suaer_corrk","Error while loading optical properties",1) - END SELECT reading1_seq ! ============================== - ENDIF - ENDDO - - endif ! of if (is_master) - - ! broadcast nwvl and nsize to all cores - call bcast(nwvl) - call bcast(nsize) - - ALLOCATE(wvl(nwvl)) ! wvl - ALLOCATE(radiusdyn(nsize(iaer,idomain))) ! radiusdyn - ALLOCATE(ep(nwvl,nsize(iaer,idomain))) ! ep - ALLOCATE(omeg(nwvl,nsize(iaer,idomain))) ! omeg - ALLOCATE(gfactor(nwvl,nsize(iaer,idomain))) ! g - - -! 1.3 Read the data - - if (is_master) then - jfile = 1 - endwhile = .false. - DO WHILE (.NOT.endwhile) - READ(file_unit,*) scanline - IF ((scanline(1:1) .ne. '#').and.& - (scanline(1:1) .ne. ' ')) THEN - BACKSPACE(file_unit) - reading2_seq: SELECT CASE (jfile) ! ==================== - CASE(1) reading2_seq ! wvl ----------------------------- - read(file_unit,*) wvl - jfile = jfile+1 - CASE(2) reading2_seq ! radiusdyn ----------------------- - read(file_unit,*) radiusdyn - jfile = jfile+1 - CASE(3) reading2_seq ! ep ------------------------------ - isize = 1 - DO WHILE (isize .le. nsize(iaer,idomain)) - READ(file_unit,*) scanline - IF ((scanline(1:1) .ne. '#').and.& - (scanline(1:1) .ne. ' ')) THEN - BACKSPACE(file_unit) - read(file_unit,*) ep(:,isize) - isize = isize + 1 - ENDIF - ENDDO - - jfile = jfile+1 - CASE(4) reading2_seq ! omeg ---------------------------- - isize = 1 - DO WHILE (isize .le. nsize(iaer,idomain)) - READ(file_unit,*) scanline - IF ((scanline(1:1) .ne. '#').and.& - (scanline(1:1) .ne. ' ')) THEN - BACKSPACE(file_unit) - read(file_unit,*) omeg(:,isize) - isize = isize + 1 - ENDIF - ENDDO - - jfile = jfile+1 - CASE(5) reading2_seq ! gfactor ------------------------- - isize = 1 - DO WHILE (isize .le. nsize(iaer,idomain)) - READ(file_unit,*) scanline - IF ((scanline(1:1) .ne. '#').and.& - (scanline(1:1) .ne. ' ')) THEN - BACKSPACE(file_unit) - read(file_unit,*) gfactor(:,isize) - isize = isize + 1 - ENDIF - ENDDO - - jfile = jfile+1 - IF ((idomain.NE.iaero_co2).OR.(iaer.NE.iaero_co2)) THEN - endwhile = .true. - ENDIF - CASE(6) reading2_seq - endwhile = .true. - CASE DEFAULT reading2_seq ! ---------------------------- - CALL abort_physic("suaer_corrk","Error while loading optical properties",1) - END SELECT reading2_seq ! ============================== - ENDIF - ENDDO - -! 1.4 Close the file - - CLOSE(file_unit) - -! 1.5 If Francois' data, convert wvl to metres - if(iaer.eq.iaero_co2)then - if(forgetit)then - ! print*,'please sort out forgetit for naerkind>1' - do iwvl=1,nwvl - wvl(iwvl)=wvl(iwvl)*1.e-6 - enddo - endif - endif - - endif ! of if (is_master) - - ! broadcast arrays to all cores - call bcast(wvl) - call bcast(radiusdyn) - call bcast(ep) - call bcast(omeg) - call bcast(gfactor) - -!================================================================== -! 2. AVERAGED PROPERTIES AND VARIABLE ASSIGNMENTS -!================================================================== - domain: SELECT CASE (idomain) -!================================================================== - CASE(1) domain ! VISIBLE DOMAIN (idomain=1) -!================================================================== - - lamref=lamrefvis(iaer) - epref=1.E+0 - - DO isize=1,nsize(iaer,idomain) - -! Save the particle sizes - radiustab(iaer,idomain,isize)=radiusdyn(isize) - -! Averaged optical properties (GCM channels) - - CALL aerave_new ( nwvl,& - wvl(:),ep(:,isize),omeg(:,isize),gfactor(:,isize),& - lamref,epref,tstellar,& - L_NSPECTV,blamv,epavVI,& - omegavVI,gavVI,QREFvis(iaer,isize),omegaREFir(iaer,isize)) - -! Variable assignments (declared in radcommon) - DO isw=1,L_NSPECTV - QVISsQREF(isw,iaer,isize)=epavVI(isw) - gvis(isw,iaer,isize)=gavVI(isw) - omegavis(isw,iaer,isize)=omegavVI(isw) - END DO - - ENDDO -!================================================================== - CASE(2) domain ! INFRARED DOMAIN (idomain=2) -!================================================================== - - DO isize=1,nsize(iaer,idomain) ! ---------------------------------- - - lamref=lamrefir(iaer) - epref=1.E+0 - -! Save the particle sizes - radiustab(iaer,idomain,isize)=radiusdyn(isize) - -! Averaged optical properties (GCM channels) - -! epav is /Qext(lamrefir) since epref=1 -! Note: aerave also computes the extinction coefficient at -! the reference wavelength. This is called QREFvis or QREFir -! (not epref, which is a different parameter). -! Reference wavelengths SHOULD BE defined for each aerosol in -! radcommon_h.F90 - - CALL aerave_new ( nwvl,& - wvl(:),ep(:,isize),omeg(:,isize),gfactor(:,isize),& - lamref,epref,tplanet,& - L_NSPECTI,blami,epavIR,& - omegavIR,gavIR,QREFir(iaer,isize),omegaREFir(iaer,isize)) - - -! Variable assignments (declared in radcommon) - DO ilw=1,L_NSPECTI - QIRsQREF(ilw,iaer,isize)=epavIR(ilw) - gir(ilw,iaer,isize)=gavIR(ilw) - omegair(ilw,iaer,isize)=omegavIR(ilw) - END DO - - - ENDDO ! isize (particle size) ------------------------------------- - - END SELECT domain - -!======================================================================== -! 3. Deallocate temporary variables that were read in the ASCII files -!======================================================================== - - DEALLOCATE(wvl) ! wvl - DEALLOCATE(radiusdyn) ! radiusdyn - DEALLOCATE(ep) ! ep - DEALLOCATE(omeg) ! omeg - DEALLOCATE(gfactor) ! g - - END DO ! Loop on iaer - END DO ! Loop on idomain -!======================================================================== - - ! cleanup - deallocate(file_id) - -end subroutine suaer_corrk - -end module suaer_corrk_mod Index: trunk/LMDZ.GENERIC/libf/phygeneric/sugas_corrk.F90 =================================================================== --- trunk/LMDZ.GENERIC/libf/phygeneric/sugas_corrk.F90 (revision 4062) +++ (revision ) @@ -1,824 +1,0 @@ - subroutine sugas_corrk - -!================================================================== -! -! Purpose -! ------- -! Set up gaseous absorption parameters used by the radiation code. -! This subroutine is a replacement for the old 'setrad', which contained -! both absorption and scattering data. -! -! Authors -! ------- -! Adapted and generalised from the NASA Ames code by Robin Wordsworth (2009) -! Added double gray case by Jeremy Leconte (2012) -! New HITRAN continuum data section by RW (2012) -! Modern traceur.def & corrk recombing scheme by J.Vatant d'Ollone (2020) -! -! Summary -! ------- -! -!================================================================== - - use radinc_h, only: corrkdir, banddir, L_NSPECTI, L_NSPECTV, & - L_NGAUSS, L_NPREF, L_NTREF, L_REFVAR, L_PINT - use radcommon_h, only : pgasref,pfgasref,pgasmin,pgasmax - use radcommon_h, only : tgasref,tgasmin,tgasmax - use radcommon_h, only : gasv,gasi,FZEROI,FZEROV,gweight - use radcommon_h, only : wrefvar,WNOI,WNOV - use datafile_mod, only: datadir - use comcstfi_mod, only: mugaz - use gases_h, only: gnom, ngasmx, & - igas_H2, igas_H2O, igas_He, igas_N2, igas_CH4, & - igas_CO2, igas_O2 - use ioipsl_getin_p_mod, only: getin_p - use callkeys_mod, only: varactive,varfixed,graybody,callgasvis,& - continuum - use tracer_h, only : nqtot, moderntracdef, is_recomb, noms - use recombin_corrk_mod, only: su_recombin, & - corrk_recombin, use_premix, nrecomb_tot, rcb2tot_idx - use interpolate_continuum_mod, only: interpolate_continuum - implicit none - -!================================================================== - - logical file_ok - - integer n, nt, np, nh, ng, nw, m, i - - character(len=200) :: file_id - character(len=500) :: file_path - - ! ALLOCATABLE ARRAYS -- AS 12/2011 - REAL*8, DIMENSION(:,:,:,:,:), ALLOCATABLE,SAVE :: gasi8, gasv8 !read by master - character*20,allocatable,DIMENSION(:),SAVE :: gastype ! for check with gnom, read by master - - real*8 x, xi(4), yi(4), ans, p -! For gray case (JL12) - real kappa_IR, kappa_VI, IR_VI_wnlimit - integer nVI_limit,nIR_limit - - integer ngas, igas, jgas - - double precision testcont ! for continuum absorption initialisation - - if (.not. moderntracdef) use_premix=.true. ! Added by JVO for compatibility with 'old' traceur.def - -!$OMP MASTER - if (use_premix) then ! use_premix flag added by JVO, thus if pure recombining then premix is skipped - -!======================================================================= -! Load variable species data, exit if we have wrong database - file_id='/corrk_data/' // TRIM(corrkdir) // '/Q.dat' - file_path=TRIM(datadir)//TRIM(file_id) - - ! check that the file exists - inquire(FILE=file_path,EXIST=file_ok) - if(.not.file_ok) then - write(*,*)'The file ',TRIM(file_path) - write(*,*)'was not found by sugas_corrk.F90, exiting.' - write(*,*)'Check that your path to datagcm:',trim(datadir) - write(*,*)' is correct. You can change it in callphys.def with:' - write(*,*)' datadir = /absolute/path/to/datagcm' - write(*,*)'Also check that the corrkdir you chose in callphys.def exists.' - call abort_physic("sugas_corrk", "Unable to read file", 1) - endif - - ! check that database matches varactive toggle - open(111,file=TRIM(file_path),form='formatted') - read(111,*) ngas - - if(moderntracdef) then - ! JVO 20 - TODO : Sanity check with nspcrad ! - print*, 'Warning : Sanity check on # of gases still not implemented !!' - else - if(ngas.ne.ngasmx)then - print*,'Number of gases in radiative transfer data (',ngas,') does not', & - 'match that in gases.def (',ngasmx,'), exiting.' - call abort_physic("sugas_corrk", "Number of gases in radiative transfer data does not match that in gases.def", 1) - endif - endif - - if(ngas.eq.1 .and. (varactive.or.varfixed))then - print*,'You have varactive/fixed=.true. but the database [', & - corrkdir(1:LEN_TRIM(corrkdir)), & - '] has no variable species, exiting.' - call abort_physic("sugas_corrk", "You have varactive/fixed=.true. but the database has no variable species",1) - elseif(ngas.gt.5 .or. ngas.lt.1)then - print*,ngas,' species in database [', & - corrkdir(1:LEN_TRIM(corrkdir)), & - '], radiative code cannot handle this.' - call abort_physic("sugas_corrk", "No gas or too many gases for radiative code", 1) - endif - - ! dynamically allocate gastype and read from Q.dat - IF ( .NOT. ALLOCATED( gastype ) ) ALLOCATE( gastype( ngas ) ) - - do igas=1,ngas - read(111,*) gastype(igas) - if(corrk_recombin) then - print*,'Premix gas ',igas,' is ',gastype(igas) - else - print*,'Gas ',igas,' is ',gastype(igas) - endif - enddo - - ! get array size, load the coefficients - open(111,file=TRIM(file_path),form='formatted') - read(111,*) L_REFVAR - IF( .NOT. ALLOCATED( wrefvar ) ) ALLOCATE( WREFVAR(L_REFVAR) ) - read(111,*) wrefvar - close(111) - - if(L_REFVAR.gt.1 .and. (.not.varactive) .and. (.not.varfixed))then - print*,'You have varactive and varfixed=.false. and the database [', & - corrkdir(1:LEN_TRIM(corrkdir)), & - '] has a variable species.' - call abort_physic("sugas_corrk", "You have varactive and varfixed=.false. and the database has a variable species",1) - endif - - if (moderntracdef) then - ! JVO 20 - TODO : Sanity check with nspcrad ! - print*, 'Warning : Sanity check on name of gases still not implemented !!' - else - ! Check that gastype and gnom match - do igas=1,ngas - print*,'Gas ',igas,' is ',trim(gnom(igas)) - if (trim(gnom(igas)).ne.trim(gastype(igas))) then - print*,'Name of a gas in radiative transfer data (',trim(gastype(igas)),') does not ', & - 'match that in gases.def (',trim(gnom(igas)),'), exiting. You should compare ', & - 'gases.def with Q.dat in your radiative transfer directory.' - call abort_physic("sugas_corrk", "Name of a gas in radiative transfer data does not match that in gases.def",1) - endif - enddo - print*,'Confirmed gas match in radiative transfer and gases.def!' - endif - - ! display the values - print*,'Variable gas volume mixing ratios:' - do n=1,L_REFVAR - !print*,n,'.',wrefvar(n),' kg/kg' ! pay attention! - print*,n,'.',wrefvar(n),' mol/mol' - end do - print*,'' - - else - L_REFVAR = 1 - endif ! use_premix - -!======================================================================= -! Set the weighting in g-space - - file_id='/corrk_data/' // TRIM(corrkdir) // '/g.dat' - file_path=TRIM(datadir)//TRIM(file_id) - - ! check that the file exists - inquire(FILE=file_path,EXIST=file_ok) - if(.not.file_ok) then - write(*,*)'The file ',TRIM(file_path) - write(*,*)'was not found by sugas_corrk.F90, exiting.' - write(*,*)'Check that your path to datagcm:',trim(datadir) - write(*,*)' is correct. You can change it in callphys.def with:' - write(*,*)' datadir = /absolute/path/to/datagcm' - write(*,*)'Also check that the corrkdir you chose in callphys.def exists.' - call abort_physic("sugas_corrk", "Unable to read file", 1) - endif - - ! check the array size is correct, load the coefficients - open(111,file=TRIM(file_path),form='formatted') - read(111,*) L_NGAUSS - IF( .NOT. ALLOCATED( gweight ) ) ALLOCATE( GWEIGHT(L_NGAUSS) ) - read(111,*) gweight - close(111) - - ! display the values - print*,'Correlated-k g-space grid:' - do n=1,L_NGAUSS - print*,n,'.',gweight(n) - end do - print*,'' - -!======================================================================= -! Set the reference pressure and temperature arrays. These are -! the pressures and temperatures at which we have k-coefficients. - -!----------------------------------------------------------------------- -! pressure - - file_id='/corrk_data/' // TRIM(corrkdir) // '/p.dat' - file_path=TRIM(datadir)//TRIM(file_id) - - ! check that the file exists - inquire(FILE=file_path,EXIST=file_ok) - if(.not.file_ok) then - write(*,*)'The file ',TRIM(file_path) - write(*,*)'was not found by sugas_corrk.F90, exiting.' - write(*,*)'Check that your path to datagcm:',trim(datadir) - write(*,*)' is correct. You can change it in callphys.def with:' - write(*,*)' datadir = /absolute/path/to/datagcm' - write(*,*)'Also check that the corrkdir you chose in callphys.def exists.' - call abort_physic("sugas_corrk", "Unable to read file", 1) - endif - - ! get array size, load the coefficients - open(111,file=TRIM(file_path),form='formatted') - read(111,*) L_NPREF - IF( .NOT. ALLOCATED( pgasref ) ) ALLOCATE( PGASREF(L_NPREF) ) - read(111,*) pgasref - close(111) - L_PINT = (L_NPREF-1)*5+1 - IF( .NOT. ALLOCATED( pfgasref ) ) ALLOCATE( PFGASREF(L_PINT) ) - - ! display the values - print*,'Correlated-k pressure grid (mBar):' - do n=1,L_NPREF - print*,n,'. 1 x 10^',pgasref(n),' mBar' - end do - print*,'' - - ! save the min / max matrix values - pgasmin = 10.0**pgasref(1) - pgasmax = 10.0**pgasref(L_NPREF) - - ! interpolate to finer grid, adapted to uneven grids - do n=1,L_NPREF-1 - do m=1,5 - pfgasref((n-1)*5+m) = pgasref(n)+(m-1)*(pgasref(n+1) - pgasref(n))/5. - end do - end do - pfgasref(L_PINT) = pgasref(L_NPREF) - -!----------------------------------------------------------------------- -! temperature - - file_id='/corrk_data/' // TRIM(corrkdir) // '/T.dat' - file_path=TRIM(datadir)//TRIM(file_id) - - ! check that the file exists - inquire(FILE=file_path,EXIST=file_ok) - if(.not.file_ok) then - write(*,*)'The file ',TRIM(file_path) - write(*,*)'was not found by sugas_corrk.F90, exiting.' - write(*,*)'Check that your path to datagcm:',trim(datadir) - write(*,*)' is correct. You can change it in callphys.def with:' - write(*,*)' datadir = /absolute/path/to/datagcm' - write(*,*)'Also check that the corrkdir you chose in callphys.def exists.' - call abort_physic("sugas_corrk", "Unable to read file",1) - endif - - ! get array size, load the coefficients - open(111,file=TRIM(file_path),form='formatted') - read(111,*) L_NTREF - IF( .NOT. ALLOCATED( tgasref ) ) ALLOCATE( TGASREF(L_NTREF) ) - read(111,*) tgasref - close(111) - - ! display the values - print*,'Correlated-k temperature grid:' - do n=1,L_NTREF - print*,n,'.',tgasref(n),' K' - end do - - ! save the min / max matrix values - tgasmin = tgasref(1) - tgasmax = tgasref(L_NTREF) - - if(corrk_recombin) then ! even if no premix we keep a L_REFVAR=1 to store precombined at firstcall (see - IF(.NOT. ALLOCATED(gasi8)) ALLOCATE(gasi8(L_NTREF,L_NPREF,L_REFVAR+nrecomb_tot,L_NSPECTI,L_NGAUSS)) - IF(.NOT. ALLOCATED(gasv8)) ALLOCATE(gasv8(L_NTREF,L_NPREF,L_REFVAR+nrecomb_tot,L_NSPECTV,L_NGAUSS)) - else - IF(.NOT. ALLOCATED(gasi8)) ALLOCATE(gasi8(L_NTREF,L_NPREF,L_REFVAR,L_NSPECTI,L_NGAUSS)) - IF(.NOT. ALLOCATED(gasv8)) ALLOCATE(gasv8(L_NTREF,L_NPREF,L_REFVAR,L_NSPECTV,L_NGAUSS)) - endif -!$OMP END MASTER -!$OMP BARRIER - -! JVO 20 : In these gasi/gasi8 matrix we stack in same dim. variable specie and species to recombine (to keep code small) - -!----------------------------------------------------------------------- -! allocate the multidimensional arrays in radcommon_h - if(corrk_recombin) then - IF(.NOT. ALLOCATED(gasi)) ALLOCATE(gasi(L_NTREF,L_PINT,L_REFVAR+nrecomb_tot,L_NSPECTI,L_NGAUSS)) - IF(.NOT. ALLOCATED(gasv)) ALLOCATE(gasv(L_NTREF,L_PINT,L_REFVAR+nrecomb_tot,L_NSPECTV,L_NGAUSS)) - ! display the values - print*,'' - print*,'Correlated-k matrix size:' - print*,'[',L_NTREF,',',L_NPREF,',',L_REFVAR+nrecomb_tot,' (',L_REFVAR,'+',nrecomb_tot,'),',L_NGAUSS,']' - else - IF(.NOT. ALLOCATED(gasi)) ALLOCATE(gasi(L_NTREF,L_PINT,L_REFVAR,L_NSPECTI,L_NGAUSS)) - IF(.NOT. ALLOCATED(gasv)) ALLOCATE(gasv(L_NTREF,L_PINT,L_REFVAR,L_NSPECTV,L_NGAUSS)) - ! display the values - print*,'' - print*,'Correlated-k matrix size:' - print*,'[',L_NTREF,',',L_NPREF,',',L_REFVAR,',',L_NGAUSS,']' - endif - -!======================================================================= -! Get gaseous k-coefficients and interpolate onto finer pressure grid - - -! wavelength used to separate IR from VI in graybody. We will need that anyway - IR_VI_wnlimit=3000. - write(*,*)"graybody: Visible / Infrared separation set at",10000./IR_VI_wnlimit,"um" - - nVI_limit=0 - Do nw=1,L_NSPECTV - if ((WNOV(nw).gt.IR_VI_wnlimit).and.(L_NSPECTV.gt.1)) then - nVI_limit=nw-1 - exit - endif - End do - nIR_limit=L_NSPECTI - Do nw=1,L_NSPECTI - if ((WNOI(nw).gt.IR_VI_wnlimit).and.(L_NSPECTI.gt.1)) then - nIR_limit=nw-1 - exit - endif - End do - - if (graybody) then -! constant absorption coefficient in visible - write(*,*)"graybody: constant absorption coefficient in visible:" - kappa_VI=-100000. - call getin_p("kappa_VI",kappa_VI) - write(*,*)" kappa_VI = ",kappa_VI - kappa_VI=kappa_VI*1.e4* mugaz * 1.672621e-27 ! conversion from m^2/kg to cm^2/molecule - -! constant absorption coefficient in IR - write(*,*)"graybody: constant absorption coefficient in InfraRed:" - kappa_IR=-100000. - call getin_p("kappa_IR",kappa_IR) - write(*,*)" kappa_IR = ",kappa_IR - kappa_IR=kappa_IR*1.e4* mugaz * 1.672621e-27 ! conversion from m^2/kg to cm^2/molecule - - write(*,*)"graybody: Visible / Infrared separation set at band: IR=",nIR_limit,", VI=",nVI_limit - - Else - kappa_VI=1.e-30 - kappa_IR=1.e-30 - End if - -!$OMP MASTER - - ! VISIBLE - if (callgasvis) then - - ! Looking for premixed corrk files corrk_gcm_VI.dat if needed - if (use_premix) then - ! print*,corrkdir(1:4) - if ((corrkdir(1:4).eq.'null'))then !(TRIM(corrkdir).eq.'null_LowTeffStar')) then - gasv8(:,:,:,:,:)=0.0 - print*,'using no corrk data' - print*,'Visible corrk gaseous absorption is set to zero if graybody=F' - else - file_id='/corrk_data/'//trim(adjustl(banddir))//'/corrk_gcm_VI.dat' - file_path=TRIM(datadir)//TRIM(file_id) - - ! check that the file exists - inquire(FILE=file_path,EXIST=file_ok) - if(.not.file_ok) then - write(*,*)'The file ',TRIM(file_path) - write(*,*)'was not found by sugas_corrk.F90.' - write(*,*)'Are you sure you have absorption data for these bands?' - call abort_physic("sugas_corrk", "No absorption data found", 1) - endif - - open(111,file=TRIM(file_path),form='formatted') - read(111,*) gasv8(:,:,:L_REFVAR,:,:) - close(111) - end if - else - gasv8(:,:,1,:,:)=0.0 ! dummy but needs to be initialized - endif ! use_premix - - ! Looking for others files corrk_gcm_VI_XXX.dat if needed - if (corrk_recombin) then - do igas=1,nrecomb_tot - - file_id='/corrk_data/'//trim(adjustl(banddir))//'/corrk_gcm_VI_'//trim(adjustl(noms(rcb2tot_idx(igas))))//'.dat' - file_path=TRIM(datadir)//TRIM(file_id) - - ! check that the file exists - inquire(FILE=file_path,EXIST=file_ok) - if(.not.file_ok) then - write(*,*)'The file ',TRIM(file_path) - write(*,*)'was not found by sugas_corrk.F90.' - write(*,*)'Are you sure you have absorption data for this specie at these bands?' - call abort_physic("sugas_corrk", "No absorption data found", 1) - endif - - open(111,file=TRIM(file_path),form='formatted') - read(111,*) gasv8(:,:,L_REFVAR+igas,:,:) - close(111) - enddo - endif ! corrk_recombin - - if(nVI_limit.eq.0) then - gasv8(:,:,:,:,:)= gasv8(:,:,:,:,:)+kappa_VI - else if (nVI_limit.eq.L_NSPECTV) then - gasv8(:,:,:,:,:)= gasv8(:,:,:,:,:)+kappa_IR - else - gasv8(:,:,:,1:nVI_limit,:)= gasv8(:,:,:,1:nVI_limit,:)+kappa_IR - gasv8(:,:,:,nVI_limit+1:L_NSPECTV,:)= gasv8(:,:,:,nVI_limit+1:L_NSPECTV,:)+kappa_VI - end if - - else - print*,'Visible corrk gaseous absorption is set to zero.' - gasv8(:,:,:,:,:)=0.0 - endif ! callgasvis - -!$OMP END MASTER -!$OMP BARRIER - - ! INFRA-RED - - ! Looking for premixed corrk files corrk_gcm_IR.dat if needed - if (use_premix) then - if ((corrkdir(1:4).eq.'null'))then !.or.(TRIM(corrkdir).eq.'null_LowTeffStar')) then - print*,'Infrared corrk gaseous absorption is set to zero if graybody=F' -!$OMP MASTER - gasi8(:,:,:,:,:)=0.0 -!$OMP END MASTER -!$OMP BARRIER - else - file_id='/corrk_data/'//trim(adjustl(banddir))//'/corrk_gcm_IR.dat' - file_path=TRIM(datadir)//TRIM(file_id) - - ! check that the file exists - inquire(FILE=file_path,EXIST=file_ok) - if(.not.file_ok) then - write(*,*)'The file ',TRIM(file_path) - write(*,*)'was not found by sugas_corrk.F90.' - write(*,*)'Are you sure you have absorption data for these bands?' - call abort_physic("sugas_corrk", "No absorption data found", 1) - endif - -!$OMP MASTER - open(111,file=TRIM(file_path),form='formatted') - read(111,*) gasi8(:,:,:L_REFVAR,:,:) - close(111) -!$OMP END MASTER -!$OMP BARRIER - - ! 'fzero' is a currently unused feature that allows optimisation - ! of the radiative transfer by neglecting bands where absorption - ! is close to zero. As it could be useful in the future, this - ! section of the code has been kept commented and not erased. - ! RW 7/3/12. - - do nw=1,L_NSPECTI - fzeroi(nw) = 0.d0 -! do nt=1,L_NTREF -! do np=1,L_NPREF -! do nh=1,L_REFVAR -! do ng = 1,L_NGAUSS -! if(gasi8(nt,np,nh,nw,ng).lt.1.0e-25)then -! fzeroi(nw)=fzeroi(nw)+1.d0 -! endif -! end do -! end do -! end do -! end do -! fzeroi(nw)=fzeroi(nw)/dble(L_NTREF*L_NPREF*L_REFVAR*L_NGAUSS) - end do - - do nw=1,L_NSPECTV - fzerov(nw) = 0.d0 -! do nt=1,L_NTREF -! do np=1,L_NPREF -! do nh=1,L_REFVAR -! do ng = 1,L_NGAUSS -! if(gasv8(nt,np,nh,nw,ng).lt.1.0e-25)then -! fzerov(nw)=fzerov(nw)+1.d0 -! endif -! end do -! end do -! end do -! end do -! fzerov(nw)=fzerov(nw)/dble(L_NTREF*L_NPREF*L_REFVAR*L_NGAUSS) - end do - - endif ! if corrkdir=null - - else - gasi8(:,:,1,:,:)=0.0 ! dummy but needs to be initialized - endif ! use_premix - - ! Looking for others files corrk_gcm_IR_XXX.dat if needed - if (corrk_recombin) then - do igas=1,nrecomb_tot - - file_id='/corrk_data/'//trim(adjustl(banddir))//'/corrk_gcm_IR_'//trim(adjustl(noms(rcb2tot_idx(igas))))//'.dat' - file_path=TRIM(datadir)//TRIM(file_id) - - ! check that the file exists - inquire(FILE=file_path,EXIST=file_ok) - if(.not.file_ok) then - write(*,*)'The file ',TRIM(file_path) - write(*,*)'was not found by sugas_corrk.F90.' - write(*,*)'Are you sure you have absorption data for this specie at these bands?' - call abort_physic("sugas_corrk", "No absorption data found", 1) - endif -!$OMP MASTER - open(111,file=TRIM(file_path),form='formatted') - read(111,*) gasi8(:,:,L_REFVAR+igas,:,:) - close(111) -!$OMP END MASTER -!$OMP BARRIER - enddo - endif ! corrk_recombin - -!$OMP MASTER - if(nIR_limit.eq.0) then - gasi8(:,:,:,:,:)= gasi8(:,:,:,:,:)+kappa_VI - else if (nIR_limit.eq.L_NSPECTI) then - gasi8(:,:,:,:,:)= gasi8(:,:,:,:,:)+kappa_IR - else - gasi8(:,:,:,1:nIR_limit,:)= gasi8(:,:,:,1:nIR_limit,:)+kappa_IR - gasi8(:,:,:,nIR_limit+1:L_NSPECTI,:)= gasi8(:,:,:,nIR_limit+1:L_NSPECTI,:)+kappa_VI - end if - - -! Take log10 of the values - this is what we will interpolate. -! Smallest value is 1.0E-200. - - do nt=1,L_NTREF - do np=1,L_NPREF - do nh=1,L_REFVAR+nrecomb_tot - do ng = 1,L_NGAUSS - - do nw=1,L_NSPECTV - if(gasv8(nt,np,nh,nw,ng).gt.1.0d-200) then - gasv8(nt,np,nh,nw,ng) = log10(gasv8(nt,np,nh,nw,ng)) - else - gasv8(nt,np,nh,nw,ng) = -200.0 - end if - end do - - do nw=1,L_NSPECTI - if(gasi8(nt,np,nh,nw,ng).gt.1.0d-200) then - gasi8(nt,np,nh,nw,ng) = log10(gasi8(nt,np,nh,nw,ng)) - else - gasi8(nt,np,nh,nw,ng) = -200.0 - end if - end do - - end do - end do - end do - end do -!$OMP END MASTER -!$OMP BARRIER - -! Interpolate the values: first the longwave - - do nt=1,L_NTREF - do nh=1,L_REFVAR+nrecomb_tot - do nw=1,L_NSPECTI - do ng=1,L_NGAUSS - -! First, the initial interval - - n = 1 - do m=1,5 - x = pfgasref(m) - xi(1) = pgasref(n) - xi(2) = pgasref(n+1) - xi(3) = pgasref(n+2) - xi(4) = pgasref(n+3) - yi(1) = gasi8(nt,n,nh,nw,ng) - yi(2) = gasi8(nt,n+1,nh,nw,ng) - yi(3) = gasi8(nt,n+2,nh,nw,ng) - yi(4) = gasi8(nt,n+3,nh,nw,ng) - call lagrange(x,xi,yi,ans) - gasi(nt,m,nh,nw,ng) = 10.0**ans - end do - - do n=2,L_NPREF-2 - do m=1,5 - i = (n-1)*5+m - x = pfgasref(i) - xi(1) = pgasref(n-1) - xi(2) = pgasref(n) - xi(3) = pgasref(n+1) - xi(4) = pgasref(n+2) - yi(1) = gasi8(nt,n-1,nh,nw,ng) - yi(2) = gasi8(nt,n,nh,nw,ng) - yi(3) = gasi8(nt,n+1,nh,nw,ng) - yi(4) = gasi8(nt,n+2,nh,nw,ng) - call lagrange(x,xi,yi,ans) - gasi(nt,i,nh,nw,ng) = 10.0**ans - end do - end do - -! Now, get the last interval - - n = L_NPREF-1 - do m=1,5 - i = (n-1)*5+m - x = pfgasref(i) - xi(1) = pgasref(n-2) - xi(2) = pgasref(n-1) - xi(3) = pgasref(n) - xi(4) = pgasref(n+1) - yi(1) = gasi8(nt,n-2,nh,nw,ng) - yi(2) = gasi8(nt,n-1,nh,nw,ng) - yi(3) = gasi8(nt,n,nh,nw,ng) - yi(4) = gasi8(nt,n+1,nh,nw,ng) - call lagrange(x,xi,yi,ans) - gasi(nt,i,nh,nw,ng) = 10.0**ans - end do - -! Fill the last pressure point - - gasi(nt,L_PINT,nh,nw,ng) = & - 10.0**gasi8(nt,L_NPREF,nh,nw,ng) - - end do - end do - end do - end do - -! Interpolate the values: now the shortwave - - do nt=1,L_NTREF - do nh=1,L_REFVAR+nrecomb_tot - do nw=1,L_NSPECTV - do ng=1,L_NGAUSS - -! First, the initial interval - - n = 1 - do m=1,5 - x = pfgasref(m) - xi(1) = pgasref(n) - xi(2) = pgasref(n+1) - xi(3) = pgasref(n+2) - xi(4) = pgasref(n+3) - yi(1) = gasv8(nt,n,nh,nw,ng) - yi(2) = gasv8(nt,n+1,nh,nw,ng) - yi(3) = gasv8(nt,n+2,nh,nw,ng) - yi(4) = gasv8(nt,n+3,nh,nw,ng) - call lagrange(x,xi,yi,ans) - gasv(nt,m,nh,nw,ng) = 10.0**ans - end do - - do n=2,L_NPREF-2 - do m=1,5 - i = (n-1)*5+m - x = pfgasref(i) - xi(1) = pgasref(n-1) - xi(2) = pgasref(n) - xi(3) = pgasref(n+1) - xi(4) = pgasref(n+2) - yi(1) = gasv8(nt,n-1,nh,nw,ng) - yi(2) = gasv8(nt,n,nh,nw,ng) - yi(3) = gasv8(nt,n+1,nh,nw,ng) - yi(4) = gasv8(nt,n+2,nh,nw,ng) - call lagrange(x,xi,yi,ans) - gasv(nt,i,nh,nw,ng) = 10.0**ans - end do - end do - -! Now, get the last interval - - n = L_NPREF-1 - do m=1,5 - i = (n-1)*5+m - x = pfgasref(i) - xi(1) = pgasref(n-2) - xi(2) = pgasref(n-1) - xi(3) = pgasref(n) - xi(4) = pgasref(n+1) - yi(1) = gasv8(nt,n-2,nh,nw,ng) - yi(2) = gasv8(nt,n-1,nh,nw,ng) - yi(3) = gasv8(nt,n,nh,nw,ng) - yi(4) = gasv8(nt,n+1,nh,nw,ng) - call lagrange(x,xi,yi,ans) - gasv(nt,i,nh,nw,ng) = 10.0**ans - end do - -! Fill the last pressure point - - gasv(nt,L_PINT,nh,nw,ng) = & - 10.0**gasv8(nt,L_NPREF,nh,nw,ng) - - end do - end do - end do - end do - -! Allocate and initialise arrays for corrk_recombin - if (corrk_recombin) call su_recombin - -!======================================================================= -! Initialise the continuum absorption data - if(continuum)then - - do igas=1,ngasmx ! we loop on all pairs of molecules that have data available - ! data can be downloaded from https://web.lmd.jussieu.fr/~lmdz/planets/generic/datagcm/continuum_data/ - if (igas .eq. igas_N2) then - file_id='/continuum_data/' // 'N2-N2_continuum_70-500K_2025.dat' - file_path=TRIM(datadir)//TRIM(file_id) - call interpolate_continuum(file_path,igas_N2,igas_N2,'IR',1,300.D+0,10000.D+0,20000.D+0,testcont,.true.) - do jgas=1,ngasmx - if (jgas .eq. igas_H2) then - file_id='/continuum_data/' // 'H2-N2_continuum_40-600K_2025.dat' - file_path=TRIM(datadir)//TRIM(file_id) - call interpolate_continuum(file_path,igas_N2,igas_H2,'IR',1,300.D+0,10000.D+0,20000.D+0,testcont,.true.) - elseif (jgas .eq. igas_O2) then - file_id='/continuum_data/' // 'O2-N2_continuum_100-500K_2025.dat' - file_path=TRIM(datadir)//TRIM(file_id) - call interpolate_continuum(file_path,igas_N2,igas_O2,'IR',1,300.D+0,10000.D+0,20000.D+0,testcont,.true.) - elseif (jgas .eq. igas_CH4) then - file_id='/continuum_data/' // 'CH4-N2_continuum_40-600K_2025.dat' - file_path=TRIM(datadir)//TRIM(file_id) - call interpolate_continuum(file_path,igas_N2,igas_CH4,'IR',1,300.D+0,10000.D+0,20000.D+0,testcont,.true.) - endif - enddo - elseif (igas .eq. igas_O2) then - file_id='/continuum_data/' // 'O2-O2_continuum_100-400K_2025.dat' - file_path=TRIM(datadir)//TRIM(file_id) - call interpolate_continuum(file_path,igas_O2,igas_O2,'IR',1,300.D+0,10000.D+0,20000.D+0,testcont,.true.) - do jgas=1,ngasmx - if (jgas .eq. igas_CO2) then - file_id='/continuum_data/' // 'CO2-O2_continuum_150-600K_2025.dat' - file_path=TRIM(datadir)//TRIM(file_id) - call interpolate_continuum(file_path,igas_CO2,igas_O2,'IR',1,300.D+0,10000.D+0,20000.D+0,testcont,.true.) - endif - enddo - elseif (igas .eq. igas_H2) then - file_id='/continuum_data/' // 'H2-H2_continuum_40-7000K_2025.dat' - file_path=TRIM(datadir)//TRIM(file_id) - call interpolate_continuum(file_path,igas_H2,igas_H2,'IR',1,300.D+0,10000.D+0,20000.D+0,testcont,.true.) - do jgas=1,ngasmx - if (jgas .eq. igas_CH4) then - file_id='/continuum_data/' // 'H2-CH4_continuum_40-600K_2025.dat' - file_path=TRIM(datadir)//TRIM(file_id) - call interpolate_continuum(file_path,igas_H2,igas_CH4,'IR',1,300.D+0,10000.D+0,20000.D+0,testcont,.true.) - elseif (jgas .eq. igas_He) then - file_id='/continuum_data/' // 'H2-He_continuum_40-5500K_2025.dat' - file_path=TRIM(datadir)//TRIM(file_id) - call interpolate_continuum(file_path,igas_H2,igas_He,'IR',1,300.D+0,10000.D+0,20000.D+0,testcont,.true.) - endif - enddo - elseif (igas .eq. igas_CH4) then - file_id='/continuum_data/' // 'CH4-CH4_continuum_40-500K_2025.dat' - file_path=TRIM(datadir)//TRIM(file_id) - call interpolate_continuum(file_path,igas_CH4,igas_CH4,'IR',1,300.D+0,10000.D+0,20000.D+0,testcont,.true.) - elseif (igas .eq. igas_H2O) then - file_id='/continuum_data/' // 'H2O-H2O_continuum_100-2000K_2025.dat' - file_path=TRIM(datadir)//TRIM(file_id) - call interpolate_continuum(file_path,igas_H2O,igas_H2O,'IR',1,300.D+0,10000.D+0,20000.D+0,testcont,.true.) - do jgas=1,ngasmx - if (jgas .eq. igas_N2) then - file_id='/continuum_data/' // 'H2O-N2_continuum_100-2000K_2025.dat' - file_path=TRIM(datadir)//TRIM(file_id) - call interpolate_continuum(file_path,igas_H2O,igas_N2,'IR',1,300.D+0,10000.D+0,20000.D+0,testcont,.true.) - elseif (jgas .eq. igas_O2) then - file_id='/continuum_data/' // 'H2O-O2_continuum_100-2000K_2025.dat' - file_path=TRIM(datadir)//TRIM(file_id) - call interpolate_continuum(file_path,igas_H2O,igas_O2,'IR',1,300.D+0,10000.D+0,20000.D+0,testcont,.true.) - elseif (jgas .eq. igas_CO2) then - file_id='/continuum_data/' // 'H2O-CO2_continuum_100-800K_2025.dat' - file_path=TRIM(datadir)//TRIM(file_id) - call interpolate_continuum(file_path,igas_H2O,igas_CO2,'IR',1,300.D+0,10000.D+0,20000.D+0,testcont,.true.) - endif - enddo - elseif (igas .eq. igas_CO2) then - file_id='/continuum_data/' // 'CO2-CO2_continuum_100-800K_2025.dat' - file_path=TRIM(datadir)//TRIM(file_id) - call interpolate_continuum(file_path,igas_CO2,igas_CO2,'IR',1,300.D+0,10000.D+0,20000.D+0,testcont,.true.) - do jgas=1,ngasmx - if (jgas .eq. igas_H2) then - file_id='/continuum_data/' // 'CO2-H2_continuum_100-800K_2025.dat' - file_path=TRIM(datadir)//TRIM(file_id) - call interpolate_continuum(file_path,igas_CO2,igas_H2,'IR',1,300.D+0,10000.D+0,20000.D+0,testcont,.true.) - elseif (jgas .eq. igas_CH4) then - file_id='/continuum_data/' // 'CO2-CH4_continuum_100-800K_2025.dat' - file_path=TRIM(datadir)//TRIM(file_id) - call interpolate_continuum(file_path,igas_CO2,igas_CH4,'IR',1,300.D+0,10000.D+0,20000.D+0,testcont,.true.) - endif - enddo - endif - enddo ! igas=1,ngasmx - - endif ! continuum flag - - print*,'----------------------------------------------------' - print*,'And that`s all we have. It`s possible that other' - print*,'continuum absorption may be present, but if it is we' - print*,'don`t yet have data for it...' - print*,'' - -! Deallocate local arrays -!$OMP BARRIER -!$OMP MASTER - IF( ALLOCATED( gasi8 ) ) DEALLOCATE( gasi8 ) - IF( ALLOCATED( gasv8 ) ) DEALLOCATE( gasv8 ) - IF( ALLOCATED( pgasref ) ) DEALLOCATE( pgasref ) - IF( ALLOCATED( gastype ) ) DEALLOCATE( gastype ) -!$OMP END MASTER -!$OMP BARRIER - - end subroutine sugas_corrk