From a8a2ab870489fc180a4daa8474a735521ab1203f Mon Sep 17 00:00:00 2001 From: "Man.Zhang" Date: Tue, 11 Feb 2020 10:31:58 -0700 Subject: [PATCH 1/9] enable icloud=3 capability --- physics/GFS_rrtmg_pre.F90 | 117 +++++++- physics/GFS_rrtmg_pre.meta | 26 ++ physics/radiation_clouds.f | 596 ++++++++++++++++++++++++++++++++++++- 3 files changed, 719 insertions(+), 20 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index aa1ea039e..165411a33 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -20,7 +20,7 @@ end subroutine GFS_rrtmg_pre_init ! in the CCPP version - they are defined in the interstitial_create routine subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input Tbd, Cldprop, Coupling, & - Radtend, & ! input/output + Radtend,dx, & ! input/output f_ice, f_rain, f_rimef, flgmin, cwm, & ! F-A mp scheme only lm, im, lmk, lmp, & ! input kd, kt, kb, raddt, delp, dz, plvl, plyr, & ! output @@ -32,7 +32,8 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input faerlw1, faerlw2, faerlw3, aerodp, & clouds1, clouds2, clouds3, clouds4, clouds5, clouds6, & clouds7, clouds8, clouds9, cldsa, & - mtopa, mbota, de_lgth, alb1d, errmsg, errflg) + mtopa, mbota, de_lgth, alb1d, errmsg, errflg, & + mpirank, mpiroot) use machine, only: kind_phys use GFS_typedefs, only: GFS_statein_type, & @@ -63,7 +64,10 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input & progcld1, progcld3, & & progcld2, & & progcld4, progcld5, & - & progclduni + & progclduni, & + & cal_cldfra3, find_cloudLayers,adjust_cloudIce,adjust_cloudH2O, & + & adjust_cloudFinal + use module_radsw_parameters, only: topfsw_type, sfcfsw_type, & & profsw_type, NBDSW use module_radlw_parameters, only: topflw_type, sfcflw_type, & @@ -91,8 +95,9 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: cwm real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(in) :: flgmin real(kind=kind_phys), intent(out) :: raddt - - + + real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(in) :: dx + INTEGER, INTENT(IN) :: mpirank,mpiroot real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: delp real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: dz real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+1+LTP), intent(out) :: plvl @@ -146,18 +151,19 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input integer :: i, j, k, k1, k2, lsk, lv, n, itop, ibtc, LP1, lla, llb, lya, lyb - real(kind=kind_phys) :: es, qs, delt, tem0d + real(kind=kind_phys) :: es, qs, delt, tem0d, gridkm - real(kind=kind_phys), dimension(size(Grid%xlon,1)) :: cvt1, cvb1, tem1d, tskn + real(kind=kind_phys), dimension(size(Grid%xlon,1)) :: cvt1, cvb1, tem1d, tskn, xland real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP) :: & htswc, htlwc, gcice, grain, grime, htsw0, htlw0, & rhly, tvly,qstl, vvel, clw, ciw, prslk1, tem2da, & cldcov, deltaq, cnvc, cnvw, & - effrl, effri, effrr, effrs + effrl, effri, effrr, effrs,rho,plyrpa real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP+1) :: tem2db -! real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP+1) :: hz + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP) :: qc_save, qi_save + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP) :: qs_save real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,min(4,Model%ncnd)) :: ccnd real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,2:Model%ntrac) :: tracer1 @@ -165,6 +171,12 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,NF_VGAS) :: gasvmr real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,NBDSW,NF_AESW)::faersw real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,NBDLW,NF_AELW)::faerlw +!mz *temporary + real(kind=kind_phys),parameter:: con_rd =2.8705e+2_kind_phys + INTEGER :: ids, ide, jds, jde, kds, kde, & + & ims, ime, jms, jme, kms, kme, & + & its, ite, jts, jte, kts, kte + ! !===> ... begin here ! @@ -529,7 +541,7 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input ccnd(i,k,1) = tracer1(i,k,ntcw) ! liquid water/ice enddo enddo - elseif (Model%ncnd == 2) then ! MG or F-A + elseif (Model%ncnd == 2) then ! MG or do k=1,LMK do i=1,IM ccnd(i,k,1) = tracer1(i,k,ntcw) ! liquid water @@ -545,7 +557,7 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input ccnd(i,k,4) = tracer1(i,k,ntsw) ! snow water enddo enddo - elseif (Model%ncnd == 5) then ! GFDL MP, Thompson, MG3 + elseif (Model%ncnd == 5) then ! GFDL MP, Thompson, MG3, FA do k=1,LMK do i=1,IM ccnd(i,k,1) = tracer1(i,k,ntcw) ! liquid water @@ -638,6 +650,7 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input cldcov = 0.0 endif + ! ! --- add suspended convective cloud water to grid-scale cloud water ! only for cloud fraction & radiation computation @@ -673,6 +686,84 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input enddo endif +!mz HWRF physics: icloud=3 + ! Set internal dimensions + ids = 1 + ims = 1 + its = 1 + ide = size(Grid%xlon,1) + ime = size(Grid%xlon,1) + ite = size(Grid%xlon,1) + jds = 1 + jms = 1 + jts = 1 + jde = 1 + jme = 1 + jte = 1 + kds = 1 + kms = 1 + kts = 1 + kde = Model%levr+LTP + kme = Model%levr+LTP + kte = Model%levr+LTP + + do k = 1, LMK + do i = 1, IM + rho(i,k)=plyr(i,k)*100./(con_rd*tlyr(i,k)) + plyrpa(i,k)=plyr(i,k)*100. !hPa->Pa + end do + end do + + do i=1,im + if (Sfcprop%slmsk(i)==1. .or. Sfcprop%slmsk(i)==2.) then !sea/land/ice mask (=0/1/2) in FV3 + xland(i)=1.0 !but land/water = (1/2) in HWRF + else + xland(i)=2.0 + endif + enddo + + + gridkm = 1.414*SQRT(dx(1)*0.001*dx(1)*0.001 ) + ! if(mpirank == mpiroot) then + ! write(0,*)'cldfra3: max/min(plyrpa) = ', maxval(plyrpa), minval(plyrpa) + ! write(0,*)'cldfra3: max/min(rho) = ', maxval(rho), minval(rho) + ! endif + + + if(Model%icloud == 3) then + do i =1, im + do k =1, lmk + qc_save(i,k) = ccnd(i,k,1) + qi_save(i,k) = ccnd(i,k,2) + qs_save(i,k) = ccnd(i,k,4) + enddo + enddo + + + CALL cal_cldfra3(cldcov,qlyr,ccnd(:,:,1),ccnd(:,:,2), & + & ccnd(:,:,4),plyrpa,tlyr, RHO,XLAND,GRIDKM, & + & ids,ide, jds,jde, kds,kde, & + & ims,ime, jms,jme, kms,kme, & + & its,ite, jts,jte, kts,kte) +! if(mpirank == mpiroot) then +! write(0,*)'cal_cldfra3::max/min(cldcov) =', maxval(cldcov), & +! & minval(cldcov) +! endif + + !mz* back to micro-only qc qi,qs + do i =1, im + do k =1, lmk + ccnd(i,k,1) = qc_save(i,k) + ccnd(i,k,2) = qi_save(i,k) + ccnd(i,k,4) = qs_save(i,k) + enddo + enddo + + endif + + +!mz*end + if (lextop) then do i=1,im cldcov(i,lyb) = cldcov(i,lya) @@ -756,11 +847,11 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input Tbd%phy_f3d(:,:,Model%nseffr) = 250. endif - call progcld5 (plyr,plvl,tlyr,qlyr,qstl,rhly,tracer1, & ! --- inputs + call progcld5 (plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,tracer1,& ! --- inputs Grid%xlat,Grid%xlon,Sfcprop%slmsk,dz,delp, & ntrac-1, ntcw-1,ntiw-1,ntrw-1, & ntsw-1,ntgl-1, & - im, lmk, lmp, Model%uni_cld, & + im, lmk, lmp, Model%icloud,Model%uni_cld, & Model%lmfshal,Model%lmfdeep2, & cldcov(:,1:LMK),Tbd%phy_f3d(:,:,1), & Tbd%phy_f3d(:,:,2), Tbd%phy_f3d(:,:,3), & diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 7b40e2c1d..198cd0a5a 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -70,6 +70,15 @@ type = GFS_radtend_type intent = inout optional = F +[dx] + standard_name = cell_size + long_name = relative dx for the grid cell + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F [f_ice] standard_name = fraction_of_ice_water_cloud long_name = fraction of ice water cloud @@ -564,6 +573,23 @@ type = integer intent = out optional = F +[mpirank] + standard_name = mpi_rank + long_name = current MPI-rank + units = index + dimensions = () + type = integer + intent = in + optional = F +[mpiroot] + standard_name = mpi_root + long_name = master MPI-rank + units = index + dimensions = () + type = integer + intent = in + optional = F + ######################################################################## [ccpp-arg-table] diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index 49b394fe1..585ff01df 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -243,7 +243,9 @@ module module_radiation_clouds integer :: iovr = 1 !< maximum-random cloud overlapping method public progcld1, progcld2, progcld3, progcld4, progclduni, & - & cld_init, progcld5, progcld4o + & cld_init, progcld5, progcld4o, & + & cal_cldfra3, find_cloudLayers,adjust_cloudIce,adjust_cloudH2O, & + & adjust_cloudFinal ! ================= @@ -2339,10 +2341,10 @@ end subroutine progcld4o !! This subroutine computes cloud related quantities using Thompson/WSM6 cloud !! microphysics scheme. subroutine progcld5 & - & ( plyr,plvl,tlyr,qlyr,qstl,rhly,clw, & ! --- inputs: + & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw, & ! --- inputs: & xlat,xlon,slmsk,dz,delp, & & ntrac,ntcw,ntiw,ntrw,ntsw,ntgl, & - & IX, NLAY, NLP1, & + & IX, NLAY, NLP1,icloud, & & uni_cld, lmfshal, lmfdeep2, cldcov, & & re_cloud,re_ice,re_snow, & & clouds,clds,mtop,mbot,de_lgth & ! --- outputs: @@ -2428,13 +2430,13 @@ subroutine progcld5 & implicit none ! --- inputs - integer, intent(in) :: IX, NLAY, NLP1 + integer, intent(in) :: IX, NLAY, NLP1,ICLOUD integer, intent(in) :: ntrac, ntcw, ntiw, ntrw, ntsw, ntgl logical, intent(in) :: uni_cld, lmfshal, lmfdeep2 real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & - & tlyr, qlyr, qstl, rhly, cldcov, delp, dz, & + & tlyr, tvly, qlyr, qstl, rhly, cldcov, delp, dz, & & re_cloud, re_ice, re_snow real (kind=kind_phys), dimension(:,:,:), intent(in) :: clw @@ -2546,7 +2548,9 @@ subroutine progcld5 & enddo enddo - if (uni_cld) then ! use unified sgs clouds generated outside +!mz* if (uni_cld) then ! use unified sgs clouds generated outside +!mz* use unified sgs or thompson clouds generated outside + if (uni_cld .or. icloud == 3) then do k = 1, NLAY do i = 1, IX cldtot(i,k) = cldcov(i,k) @@ -2634,8 +2638,76 @@ subroutine progcld5 & enddo enddo endif +!mz + if (icloud .ne.0) then +! assign/calculate efective radii for cloud water, ice, rain, snow -! +! if (effr_in) then +! do k = 1, NLAY +! do i = 1, IX +! rew(i,k) = effrl (i,k) +! rei(i,k) = max(10.0, min(150.0,effri (i,k))) +! rer(i,k) = effrr (i,k) +! res(i,k) = effrs (i,k) +! enddo +! enddo +! else + do k = 1, NLAY + do i = 1, IX + rew(i,k) = reliq_def ! default liq radius to 10 micron + rei(i,k) = reice_def ! default ice radius to 50 micron + rer(i,k) = rrain_def ! default rain radius to 1000 micron + res(i,k) = rsnow_def ! default snow radius to 250 micron + enddo + enddo +!> -# Compute effective liquid cloud droplet radius over land. + do i = 1, IX + if (nint(slmsk(i)) == 1) then + do k = 1, NLAY + tem1 = min(1.0, max(0.0, (con_ttp-tlyr(i,k))*0.05)) + rew(i,k) = 5.0 + 5.0 * tem1 + enddo + endif + enddo + +!> -# Compute effective ice cloud droplet radius following Heymsfield +!! and McFarquhar (1996) \cite heymsfield_and_mcfarquhar_1996. + + do k = 1, NLAY + do i = 1, IX + tem2 = tlyr(i,k) - con_ttp + + if (cip(i,k) > 0.0) then + tem3 = gord * cip(i,k) * plyr(i,k) / (delp(i,k)*tvly(i,k)) + + if (tem2 < -50.0) then + rei(i,k) = (1250.0/9.917) * tem3 ** 0.109 + elseif (tem2 < -40.0) then + rei(i,k) = (1250.0/9.337) * tem3 ** 0.08 + elseif (tem2 < -30.0) then + rei(i,k) = (1250.0/9.208) * tem3 ** 0.055 + else + rei(i,k) = (1250.0/9.387) * tem3 ** 0.031 + endif + rei(i,k) = max(25.,rei(i,k)) !mz* HWRF +!mz GFDL +! rei(i,k) = max(10.0, min(rei(i,k), 150.0)) + endif + rei(i,k) = min(rei(i,k), 135.72) !- 1.0315*rei<= 140 microns + enddo + enddo + +!mz +!> -# Compute effective snow cloud droplet radius + do k = 1, NLAY + do i = 1, IX + res(i,k) = 10.0 + enddo + enddo +! endif +! + endif ! end icloud +!mz end do k = 1, NLAY do i = 1, IX clouds(i,k,1) = cldtot(i,k) @@ -3452,6 +3524,516 @@ end subroutine gethml !----------------------------------- !! @} +!+---+-----------------------------------------------------------------+ +!..Cloud fraction scheme by G. Thompson (NCAR-RAL), not intended for +!.. combining with any cumulus or shallow cumulus parameterization +!.. scheme cloud fractions. This is intended as a stand-alone for +!.. cloud fraction and is relatively good at getting widespread stratus +!.. and stratoCu without caring whether any deep/shallow Cu param schemes +!.. is making sub-grid-spacing clouds/precip. Under the hood, this +!.. scheme follows Mocko and Cotton (1995) in applicaiton of the +!.. Sundqvist et al (1989) scheme but using a grid-scale dependent +!.. RH threshold, one each for land v. ocean points based on +!.. experiences with HWRF testing. +!+---+-----------------------------------------------------------------+ +! +!+---+-----------------------------------------------------------------+ + + SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, & + & p,t,rho, XLAND, gridkm, & +! & rand_perturb_on, kme_stoch, rand_pert, & + & ids,ide, jds,jde, kds,kde, & + & ims,ime, jms,jme, kms,kme, & + & its,ite, jts,jte, kts,kte) +! + USE module_mp_thompson , ONLY : rsif, rslf + IMPLICIT NONE +! + INTEGER, INTENT(IN):: ids,ide, jds,jde, kds,kde, & + & ims,ime, jms,jme, kms,kme, & +! & kme_stoch, & + & its,ite, jts,jte, kts,kte + +! INTEGER, INTENT(IN):: rand_perturb_on + REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(IN):: qv,p,t,rho + REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT):: qc,qi,qs +! REAL, DIMENSION(ims:ime,kms:kme_stoch,jms:jme), INTENT(IN):: rand_pert + REAL, DIMENSION(ims:ime,jms:jme), INTENT(IN):: XLAND + + REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT):: cldfra + REAL, INTENT(IN):: gridkm + +!..Local vars. + REAL:: RH_00L, RH_00O, RH_00, RHI_max, entrmnt + REAL, DIMENSION(ims:ime,kms:kme,jms:jme):: qvsat + INTEGER:: i,j,k + REAL:: TK, TC, qvsi, qvsw, RHUM, xx, yy + REAL, DIMENSION(kts:kte):: qvs1d, cfr1d, T1d, & + & P1d, R1d, qc1d, qi1d, qs1d + + character*512 dbg_msg + LOGICAL:: debug_flag + +!+---+ + +!..First cut scale-aware. Higher resolution should require closer to +!.. saturated grid box for higher cloud fraction. Simple functions +!.. chosen based on Mocko and Cotton (1995) starting point and desire +!.. to get near 100% RH as grid spacing moves toward 1.0km, but higher +!.. RH over ocean required as compared to over land. + + RH_00L = 0.7 + SQRT(1./(25.0+gridkm*gridkm*gridkm)) + RH_00O = 0.81 + SQRT(1./(50.0+gridkm*gridkm*gridkm)) + + DO j = jts,jte + DO k = kts,kte + DO i = its,ite + RHI_max = 0.0 + CLDFRA(I,K,J) = 0.0 + + if (qc(i,k,j).gt.1.E-6 .or. qi(i,k,j).ge.1.E-7 .or.qs(i,k,j) & + & .gt.1.E-5) then + CLDFRA(I,K,J) = 1.0 + qvsat(i,k,j) = qv(i,k,j) + else + TK = t(i,k,j) + TC = TK - 273.16 + + qvsw = rslf(P(i,k,j), TK) + qvsi = rsif(P(i,k,j), TK) + + if (tc .ge. -12.0) then + qvsat(i,k,j) = qvsw + elseif (tc .lt. -20.0) then + qvsat(i,k,j) = qvsi + else + qvsat(i,k,j) = qvsw - (qvsw-qvsi)*(-12.0-tc)/(-12.0+20.) + endif + RHUM = MAX(0.01, MIN(qv(i,k,j)/qvsat(i,k,j), 0.9999)) + + IF ((XLAND(I,J)-1.5).GT.0.) THEN !--- Ocean + RH_00 = RH_00O + ELSE !--- Land + RH_00 = RH_00L + ENDIF + + if (tc .ge. -12.0) then + RHUM = MIN(0.999, RHUM) + CLDFRA(I,K,J) = MAX(0.0, 1.0-SQRT((1.0-RHUM)/(1.-RH_00))) + elseif (tc.lt.-12..and.tc.gt.-70. .and. RHUM.gt.RH_00L) then + RHUM = MAX(0.01, MIN(qv(i,k,j)/qvsat(i,k,j), 1.0 - 1.E-6)) + CLDFRA(I,K,J) = MAX(0., 1.0-SQRT((1.0-RHUM)/(1.0-RH_00L))) + endif + CLDFRA(I,K,J) = MIN(0.90, CLDFRA(I,K,J)) + + endif + ENDDO + ENDDO + ENDDO + + +!..Prepare for a 1-D column to find various cloud layers. + + DO j = jts,jte + DO i = its,ite +! if (i.gt.10.and.i.le.20 .and. j.gt.10.and.j.le.20) then +! debug_flag = .true. +! else +! debug_flag = .false. +! endif + +! if (rand_perturb_on .eq. 1) then +! entrmnt = MAX(0.01, MIN(0.99, 0.5 + rand_pert(i,1,j)*0.5)) +! else + entrmnt = 0.5 +! endif + + DO k = kts,kte + qvs1d(k) = qvsat(i,k,j) + cfr1d(k) = cldfra(i,k,j) + T1d(k) = t(i,k,j) + P1d(k) = p(i,k,j) + R1d(k) = rho(i,k,j) + qc1d(k) = qc(i,k,j) + qi1d(k) = qi(i,k,j) + qs1d(k) = qs(i,k,j) + ENDDO + +! if (debug_flag) then +! WRITE (dbg_msg,*) 'DEBUG-GT: finding cloud layers at point (', i, ', ', j, ')' +! CALL wrf_debug (150, dbg_msg) +! endif + call find_cloudLayers(qvs1d, cfr1d, T1d, P1d, R1d, entrmnt, & + & debug_flag, qc1d, qi1d, qs1d, kts,kte) + + DO k = kts,kte + cldfra(i,k,j) = cfr1d(k) + qc(i,k,j) = qc1d(k) + qi(i,k,j) = qi1d(k) + ENDDO + ENDDO + ENDDO + + + END SUBROUTINE cal_cldfra3 + + +!+---+-----------------------------------------------------------------+ +!..From cloud fraction array, find clouds of multi-level depth and +!compute +!.. a reasonable value of LWP or IWP that might be contained in that +!depth, +!.. unless existing LWC/IWC is already there. + + SUBROUTINE find_cloudLayers(qvs1d, cfr1d, T1d, P1d, R1d, entrmnt, & + & debugfl, qc1d, qi1d, qs1d, kts,kte) +! + IMPLICIT NONE +! + INTEGER, INTENT(IN):: kts, kte + LOGICAL, INTENT(IN):: debugfl + REAL, INTENT(IN):: entrmnt + REAL, DIMENSION(kts:kte), INTENT(IN):: qvs1d,T1d,P1d,R1d + REAL, DIMENSION(kts:kte), INTENT(INOUT):: cfr1d + REAL, DIMENSION(kts:kte), INTENT(INOUT):: qc1d, qi1d, qs1d + +!..Local vars. + REAL, DIMENSION(kts:kte):: theta, dz + REAL:: Z1, Z2, theta1, theta2, ht1, ht2 + INTEGER:: k, k2, k_tropo, k_m12C, k_m40C, k_cldb, k_cldt, kbot + LOGICAL:: in_cloud + character*512 dbg_msg + +!+---+ + + k_m12C = 0 + k_m40C = 0 + DO k = kte, kts, -1 + theta(k) = T1d(k)*((100000.0/P1d(k))**(287.05/1004.)) + if (T1d(k)-273.16 .gt. -40.0 .and. P1d(k).gt.7000.0) k_m40C = & + & MAX(k_m40C, k) + if (T1d(k)-273.16 .gt. -12.0 .and. P1d(k).gt.10000.0) k_m12C = & + & MAX(k_m12C, k) + ENDDO + if (k_m40C .le. kts) k_m40C = kts + if (k_m12C .le. kts) k_m12C = kts + + Z2 = 44307.692 * (1.0 - (P1d(kte)/101325.)**0.190) + DO k = kte-1, kts, -1 + Z1 = 44307.692 * (1.0 - (P1d(k)/101325.)**0.190) + dz(k+1) = Z2 - Z1 + Z2 = Z1 + ENDDO + dz(kts) = dz(kts+1) + +!..Find tropopause height, best surrogate, because we would not really +!.. wish to put fake clouds into the stratosphere. The 10/1500 ratio +!.. d(Theta)/d(Z) approximates a vertical line on typical SkewT chart +!.. near typical (mid-latitude) tropopause height. Since messy data +!.. could give us a false signal of such a transition, do the check over +!.. three K-level change, not just a level-to-level check. This method +!.. has potential failure in arctic-like conditions with extremely low +!.. tropopause height, as would any other diagnostic, so ensure resulting +!.. k_tropo level is above 4km. + + DO k = kte-3, kts, -1 + theta1 = theta(k) + theta2 = theta(k+2) + ht1 = 44307.692 * (1.0 - (P1d(k)/101325.)**0.190) + ht2 = 44307.692 * (1.0 - (P1d(k+2)/101325.)**0.190) + if ( (((theta2-theta1)/(ht2-ht1)) .lt. 10./1500. ) .AND. & + & (ht1.lt.19000.) .and. (ht1.gt.4000.) ) then + goto 86 + endif + ENDDO + 86 continue + k_tropo = MAX(kts+2, k+2) + +! if (debugfl) then +! print*, ' FOUND TROPOPAUSE ', k_tropo, ' near ', ht2, ' m' +! WRITE (dbg_msg,*) 'DEBUG-GT: FOUND TROPOPAUSE ', k_tropo, ' near ', ht2, ' m' +! CALL wrf_debug (150, dbg_msg) +! endif + +!..Eliminate possible fractional clouds above supposed tropopause. + DO k = k_tropo+1, kte + if (cfr1d(k).gt.0.0 .and. cfr1d(k).lt.0.999) then + cfr1d(k) = 0. + endif + ENDDO + +!..We would like to prevent fractional clouds below LCL in idealized +!.. situation with deep well-mixed convective PBL, that otherwise is +!.. likely to get clouds in more realistic capping inversion layer. + + kbot = kts+2 + DO k = kbot, k_m12C + if ( (theta(k)-theta(k-1)) .gt. 0.05E-3*dz(k)) EXIT + ENDDO + kbot = MAX(kts+1, k-2) + DO k = kts, kbot + if (cfr1d(k).gt.0.0 .and. cfr1d(k).lt.0.999) cfr1d(k) = 0. + ENDDO + + +!..Starting below tropo height, if cloud fraction greater than 1 +!percent, +!.. compute an approximate total layer depth of cloud, determine a total +!.. liquid water/ice path (LWP/IWP), then reduce that amount with tuning +!.. parameter to represent entrainment factor, then divide up LWP/IWP +!.. into delta-Z weighted amounts for individual levels per cloud layer. + + + k_cldb = k_tropo + in_cloud = .false. + k = k_tropo + DO WHILE (.not. in_cloud .AND. k.gt.k_m12C) + k_cldt = 0 + if (cfr1d(k).ge.0.01) then + in_cloud = .true. + k_cldt = MAX(k_cldt, k) + endif + if (in_cloud) then + DO k2 = k_cldt-1, k_m12C, -1 + if (cfr1d(k2).lt.0.01 .or. k2.eq.k_m12C) then + k_cldb = k2+1 + goto 87 + endif + ENDDO + 87 continue + in_cloud = .false. + endif + if ((k_cldt - k_cldb + 1) .ge. 2) then +! if (debugfl) then +! print*, 'An ice cloud layer is found between ', k_cldt, +! k_cldb, P1d(k_cldt)*0.01, P1d(k_cldb)*0.01 +! WRITE (dbg_msg,*) 'DEBUG-GT: An ice cloud layer is found between +! ', k_cldt, k_cldb, P1d(k_cldt)*0.01, P1d(k_cldb)*0.01 +! CALL wrf_debug (150, dbg_msg) +! endif + call adjust_cloudIce(cfr1d, qi1d, qs1d, qvs1d, T1d,R1d,dz, & + & entrmnt, k_cldb,k_cldt,kts,kte) + k = k_cldb + else + if (cfr1d(k_cldb).gt.0.and.qi1d(k_cldb).lt.1.E-6) & + & qi1d(k_cldb)=1.E-5*cfr1d(k_cldb) + endif + + + k = k - 1 + ENDDO + + + + k_cldb = k_tropo + in_cloud = .false. + k = k_m12C + 2 + DO WHILE (.not. in_cloud .AND. k.gt.kbot) + k_cldt = 0 + if (cfr1d(k).ge.0.01) then + in_cloud = .true. + k_cldt = MAX(k_cldt, k) + endif + if (in_cloud) then + DO k2 = k_cldt-1, kbot, -1 + if (cfr1d(k2).lt.0.01 .or. k2.eq.kbot) then + k_cldb = k2+1 + goto 88 + endif + ENDDO + 88 continue + in_cloud = .false. + endif + if ((k_cldt - k_cldb + 1) .ge. 2) then +! if (debugfl) then +! print*, 'A water cloud layer is found between ', k_cldt, +! k_cldb, P1d(k_cldt)*0.01, P1d(k_cldb)*0.01 +! WRITE (dbg_msg,*) 'DEBUG-GT: A water cloud layer is found +! between ', k_cldt, k_cldb, P1d(k_cldt)*0.01, P1d(k_cldb)*0.01 +! CALL wrf_debug (150, dbg_msg) +! endif + call adjust_cloudH2O(cfr1d, qc1d, qvs1d, T1d,R1d,dz, & + & entrmnt, k_cldb,k_cldt,kts,kte) + k = k_cldb + else + if (cfr1d(k_cldb).gt.0.and.qc1d(k_cldb).lt.1.E-6) & + & qc1d(k_cldb)=1.E-5*cfr1d(k_cldb) + endif + k = k - 1 + ENDDO + +!..Do a final total column adjustment since we may have added more than +!1mm +!.. LWP/IWP for multiple cloud decks. + + call adjust_cloudFinal(cfr1d, qc1d, qi1d, R1d,dz, kts,kte,k_tropo) + +! if (debugfl) then +! print*, ' Made-up fake profile of clouds' +! do k = kte, kts, -1 +! write(*,'(i3, 2x, f8.2, 2x, f9.2, 2x, f6.2, 2x, f15.7, 2x, +! f15.7)') & +! & K, T1d(k)-273.15, P1d(k)*0.01, cfr1d(k)*100., +! qc1d(k)*1000.,qi1d(k)*1000. +! enddo +! WRITE (dbg_msg,*) 'DEBUG-GT: Made-up fake profile of clouds' +! CALL wrf_debug (150, dbg_msg) +! do k = kte, kts, -1 +! write(dbg_msg,'(f8.2, 2x, f9.2, 2x, f6.2, 2x, f15.7, 2x, +! f15.7)') & +! & T1d(k)-273.15, P1d(k)*0.01, cfr1d(k)*100., +! qc1d(k)*1000.,qi1d(k)*1000. +! CALL wrf_debug (150, dbg_msg) +! enddo +! endif + + + END SUBROUTINE find_cloudLayers + +!+---+-----------------------------------------------------------------+ + + SUBROUTINE adjust_cloudIce(cfr,qi,qs,qvs, T,Rho,dz, entr, k1,k2, & + & kts,kte) +! + IMPLICIT NONE +! + INTEGER, INTENT(IN):: k1,k2, kts,kte + REAL, INTENT(IN):: entr + REAL, DIMENSION(kts:kte), INTENT(IN):: cfr, qvs, T, Rho, dz + REAL, DIMENSION(kts:kte), INTENT(INOUT):: qi, qs + REAL:: iwc, max_iwc, tdz, this_iwc, this_dz, iwp_exists + INTEGER:: k, kmid + + tdz = 0. + do k = k1, k2 + tdz = tdz + dz(k) + enddo + kmid = NINT(0.5*(k1+k2)) + max_iwc = ABS(qvs(k2-1)-qvs(k1)) +! print*, ' max_iwc = ', max_iwc, ' over DZ=',tdz + + iwp_exists = 0. + do k = k1, k2 + iwp_exists = iwp_exists + (qi(k)+qs(k))*Rho(k)*dz(k) + enddo + if (iwp_exists .gt. 1.0) RETURN + + this_dz = 0.0 + do k = k1, k2 + if (k.eq.k1) then + this_dz = this_dz + 0.5*dz(k) + else + this_dz = this_dz + dz(k) + endif + this_iwc = max_iwc*this_dz/tdz + iwc = MAX(1.E-6, this_iwc*(1.-entr)) + if (cfr(k).gt.0.01.and.cfr(k).lt.0.99.and.T(k).ge.203.16) then + qi(k) = qi(k) + 0.1*cfr(k)*iwc + elseif (qi(k).lt.1.E-5.and.cfr(k).ge.0.99.and.T(k).ge.203.16) & + & then + qi(k) = qi(k) + 0.01*iwc + endif + enddo + + END SUBROUTINE adjust_cloudIce + +!+---+-----------------------------------------------------------------+ + + SUBROUTINE adjust_cloudH2O(cfr, qc, qvs, T,Rho,dz, entr, k1,k2, & + & kts,kte) +! + IMPLICIT NONE +! + INTEGER, INTENT(IN):: k1,k2, kts,kte + REAL, INTENT(IN):: entr + REAL, DIMENSION(kts:kte):: cfr, qc, qvs, T, Rho, dz + REAL:: lwc, max_lwc, tdz, this_lwc, this_dz, lwp_exists + INTEGER:: k, kmid + + tdz = 0. + do k = k1, k2 + tdz = tdz + dz(k) + enddo + kmid = NINT(0.5*(k1+k2)) + max_lwc = ABS(qvs(k2-1)-qvs(k1)) +! print*, ' max_lwc = ', max_lwc, ' over DZ=',tdz + + lwp_exists = 0. + do k = k1, k2 + lwp_exists = lwp_exists + qc(k)*Rho(k)*dz(k) + enddo + if (lwp_exists .gt. 1.0) RETURN + + this_dz = 0.0 + do k = k1, k2 + if (k.eq.k1) then + this_dz = this_dz + 0.5*dz(k) + else + this_dz = this_dz + dz(k) + endif + this_lwc = max_lwc*this_dz/tdz + lwc = MAX(1.E-6, this_lwc*(1.-entr)) + if (cfr(k).gt.0.01.and.cfr(k).lt.0.99.and.T(k).lt.298.16.and. & + & T(k).ge.253.16) then + qc(k) = qc(k) + cfr(k)*cfr(k)*lwc + elseif (cfr(k).ge.0.99.and.qc(k).lt.1.E-5.and.T(k).lt.298.16 & + & .and.T(k).ge.253.16) then + qc(k) = qc(k) + 0.1*lwc + endif + enddo + + END SUBROUTINE adjust_cloudH2O + + +!+---+-----------------------------------------------------------------+ + +!..Do not alter any grid-explicitly resolved hydrometeors, rather only +!.. the supposed amounts due to the cloud fraction scheme. + + SUBROUTINE adjust_cloudFinal(cfr, qc, qi, Rho,dz, kts,kte,k_tropo) +! + IMPLICIT NONE +! + INTEGER, INTENT(IN):: kts,kte,k_tropo + REAL, DIMENSION(kts:kte), INTENT(IN):: cfr, Rho, dz + REAL, DIMENSION(kts:kte), INTENT(INOUT):: qc, qi + REAL:: lwp, iwp, xfac + INTEGER:: k + + lwp = 0. + do k = kts, k_tropo + if (cfr(k).gt.0.0) then + lwp = lwp + qc(k)*Rho(k)*dz(k) + endif + enddo + + iwp = 0. + do k = kts, k_tropo + if (cfr(k).gt.0.01 .and. cfr(k).lt.0.99) then + iwp = iwp + qi(k)*Rho(k)*dz(k) + endif + enddo + + if (lwp .gt. 1.5) then + xfac = 1./lwp + do k = kts, k_tropo + if (cfr(k).gt.0.01 .and. cfr(k).lt.0.99) then + qc(k) = qc(k)*xfac + endif + enddo + endif + + if (iwp .gt. 1.5) then + xfac = 1./iwp + do k = kts, k_tropo + if (cfr(k).gt.0.01 .and. cfr(k).lt.0.99) then + qi(k) = qi(k)*xfac + endif + enddo + endif + + END SUBROUTINE adjust_cloudFinal + ! !........................................! end module module_radiation_clouds ! From 9309fc60a936d1463cdb1689bcd820ae70e2f50a Mon Sep 17 00:00:00 2001 From: "Man.Zhang" Date: Thu, 13 Feb 2020 13:14:43 -0700 Subject: [PATCH 2/9] add exponential cloud overlapping for LW component --- physics/HWRF_mcica_random_numbers.F90 | 109 ++++ physics/HWRF_mersenne_twister.F90 | 304 +++++++++++ physics/radiation_clouds.f | 52 +- physics/radlw_main.f | 746 +++++++++++++++++++++++++- 4 files changed, 1178 insertions(+), 33 deletions(-) create mode 100644 physics/HWRF_mcica_random_numbers.F90 create mode 100644 physics/HWRF_mersenne_twister.F90 diff --git a/physics/HWRF_mcica_random_numbers.F90 b/physics/HWRF_mcica_random_numbers.F90 new file mode 100644 index 000000000..b2f2d20dd --- /dev/null +++ b/physics/HWRF_mcica_random_numbers.F90 @@ -0,0 +1,109 @@ + module mcica_random_numbers + + ! Generic module to wrap random number generators. + ! The module defines a type that identifies the particular stream of random + ! numbers, and has procedures for initializing it and getting real numbers + ! in the range 0 to 1. + ! This version uses the Mersenne Twister to generate random numbers on [0, 1]. + ! + use MersenneTwister, only: randomNumberSequence, & ! The random number engine. + new_RandomNumberSequence, getRandomReal +!! mji +!! use time_manager_mod, only: time_type, get_date + +!mz use parkind, only : im => kind_im, rb => kind_rb + use machine, only: im => kind_io4, rb => kind_phys + + implicit none + private + + type randomNumberStream + type(randomNumberSequence) :: theNumbers + end type randomNumberStream + + interface getRandomNumbers + module procedure getRandomNumber_Scalar, getRandomNumber_1D, getRandomNumber_2D + end interface getRandomNumbers + + interface initializeRandomNumberStream + module procedure initializeRandomNumberStream_S, initializeRandomNumberStream_V + end interface initializeRandomNumberStream + + public :: randomNumberStream, & + initializeRandomNumberStream, getRandomNumbers +!! mji +!! initializeRandomNumberStream, getRandomNumbers, & +!! constructSeed +contains + ! --------------------------------------------------------- + ! Initialization + ! --------------------------------------------------------- + function initializeRandomNumberStream_S(seed) result(new) + integer(kind=im), intent( in) :: seed + type(randomNumberStream) :: new + + new%theNumbers = new_RandomNumberSequence(seed) + + end function initializeRandomNumberStream_S + ! --------------------------------------------------------- + function initializeRandomNumberStream_V(seed) result(new) + integer(kind=im), dimension(:), intent( in) :: seed + type(randomNumberStream) :: new + + new%theNumbers = new_RandomNumberSequence(seed) + + end function initializeRandomNumberStream_V + + ! --------------------------------------------------------- + ! Procedures for drawing random numbers + ! --------------------------------------------------------- + subroutine getRandomNumber_Scalar(stream, number) + type(randomNumberStream), intent(inout) :: stream + real(kind=rb), intent( out) :: number + + number = getRandomReal(stream%theNumbers) + end subroutine getRandomNumber_Scalar + ! --------------------------------------------------------- + subroutine getRandomNumber_1D(stream, numbers) + type(randomNumberStream), intent(inout) :: stream + real(kind=rb), dimension(:), intent( out) :: numbers + + ! Local variables + integer(kind=im) :: i + + do i = 1, size(numbers) + numbers(i) = getRandomReal(stream%theNumbers) + end do + end subroutine getRandomNumber_1D + ! --------------------------------------------------------- + subroutine getRandomNumber_2D(stream, numbers) + type(randomNumberStream), intent(inout) :: stream + real(kind=rb), dimension(:, :), intent( out) :: numbers + + ! Local variables + integer(kind=im) :: i + + do i = 1, size(numbers, 2) + call getRandomNumber_1D(stream, numbers(:, i)) + end do + end subroutine getRandomNumber_2D + +! mji +! ! --------------------------------------------------------- +! ! Constructing a unique seed from grid cell index and model date/time +! ! Once we have the GFDL stuff we'll add the year, month, day, hour, minute +! ! --------------------------------------------------------- +! function constructSeed(i, j, time) result(seed) +! integer(kind=im), intent( in) :: i, j +! type(time_type), intent( in) :: time +! integer(kind=im), dimension(8) :: seed +! +! ! Local variables +! integer(kind=im) :: year, month, day, hour, minute, second +! +! +! call get_date(time, year, month, day, hour, minute, second) +! seed = (/ i, j, year, month, day, hour, minute, second /) +! end function constructSeed + + end module mcica_random_numbers diff --git a/physics/HWRF_mersenne_twister.F90 b/physics/HWRF_mersenne_twister.F90 new file mode 100644 index 000000000..f9e3b0b0a --- /dev/null +++ b/physics/HWRF_mersenne_twister.F90 @@ -0,0 +1,304 @@ +! Fortran-95 implementation of the Mersenne Twister 19937, following +! the C implementation described below (code mt19937ar-cok.c, dated 2002/2/10), +! adapted cosmetically by making the names more general. +! Users must declare one or more variables of type randomNumberSequence in the calling +! procedure which are then initialized using a required seed. If the +! variable is not initialized the random numbers will all be 0. +! For example: +! program testRandoms +! use RandomNumbers +! type(randomNumberSequence) :: randomNumbers +! integer :: i +! +! randomNumbers = new_RandomNumberSequence(seed = 100) +! do i = 1, 10 +! print ('(f12.10, 2x)'), getRandomReal(randomNumbers) +! end do +! end program testRandoms +! +! Fortran-95 implementation by +! Robert Pincus +! NOAA-CIRES Climate Diagnostics Center +! Boulder, CO 80305 +! email: Robert.Pincus@colorado.edu +! +! This documentation in the original C program reads: +! ------------------------------------------------------------- +! A C-program for MT19937, with initialization improved 2002/2/10. +! Coded by Takuji Nishimura and Makoto Matsumoto. +! This is a faster version by taking Shawn Cokus's optimization, +! Matthe Bellew's simplification, Isaku Wada's real version. +! +! Before using, initialize the state by using init_genrand(seed) +! or init_by_array(init_key, key_length). +! +! Copyright (C) 1997 - 2002, Makoto Matsumoto and Takuji Nishimura, +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! +! 3. The names of its contributors may not be used to endorse or promote +! products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +! A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! +! Any feedback is very welcome. +! http://www.math.keio.ac.jp/matumoto/emt.html +! email: matumoto@math.keio.ac.jp +! ------------------------------------------------------------- + + module MersenneTwister +! ------------------------------------------------------------- + +!mz use parkind, only : im => kind_im, rb => kind_rb + use machine, only: im => kind_io4, rb => kind_phys + + implicit none + private + + ! Algorithm parameters + ! ------- + ! Period parameters + integer(kind=im), parameter :: blockSize = 624, & + M = 397, & + MATRIX_A = -1727483681, & ! constant vector a (0x9908b0dfUL) + UMASK = -2147483647-1, & ! most significant w-r bits (0x80000000UL) + LMASK = 2147483647 ! least significant r bits (0x7fffffffUL) + ! Tempering parameters + integer(kind=im), parameter :: TMASKB= -1658038656, & ! (0x9d2c5680UL) + TMASKC= -272236544 ! (0xefc60000UL) + ! ------- + + ! The type containing the state variable + type randomNumberSequence + integer(kind=im) :: currentElement ! = blockSize + integer(kind=im), dimension(0:blockSize -1) :: state ! = 0 + end type randomNumberSequence + + interface new_RandomNumberSequence + module procedure initialize_scalar, initialize_vector + end interface new_RandomNumberSequence + + + public :: randomNumberSequence + public :: new_RandomNumberSequence, finalize_RandomNumberSequence, & + getRandomInt, getRandomPositiveInt, getRandomReal +! ------------------------------------------------------------- +contains + ! ------------------------------------------------------------- + ! Private functions + ! --------------------------- + function mixbits(u, v) + integer(kind=im), intent( in) :: u, v + integer(kind=im) :: mixbits + + mixbits = ior(iand(u, UMASK), iand(v, LMASK)) + end function mixbits + ! --------------------------- + function twist(u, v) + integer(kind=im), intent( in) :: u, v + integer(kind=im) :: twist + + ! Local variable + integer(kind=im), parameter, dimension(0:1) :: t_matrix = (/ 0_im, MATRIX_A /) + + twist = ieor(ishft(mixbits(u, v), -1_im), t_matrix(iand(v, 1_im))) + twist = ieor(ishft(mixbits(u, v), -1_im), t_matrix(iand(v, 1_im))) + end function twist + ! --------------------------- + subroutine nextState(twister) + type(randomNumberSequence), intent(inout) :: twister + + ! Local variables + integer(kind=im) :: k + + do k = 0, blockSize - M - 1 + twister%state(k) = ieor(twister%state(k + M), & + twist(twister%state(k), twister%state(k + 1_im))) + end do + do k = blockSize - M, blockSize - 2 + twister%state(k) = ieor(twister%state(k + M - blockSize), & + twist(twister%state(k), twister%state(k + 1_im))) + end do + twister%state(blockSize - 1_im) = ieor(twister%state(M - 1_im), & + twist(twister%state(blockSize - 1_im), twister%state(0_im))) + twister%currentElement = 0_im + + end subroutine nextState + ! --------------------------- + elemental function temper(y) + integer(kind=im), intent(in) :: y + integer(kind=im) :: temper + + integer(kind=im) :: x + + ! Tempering + x = ieor(y, ishft(y, -11)) + x = ieor(x, iand(ishft(x, 7), TMASKB)) + x = ieor(x, iand(ishft(x, 15), TMASKC)) + temper = ieor(x, ishft(x, -18)) + end function temper + ! ------------------------------------------------------------- + ! Public (but hidden) functions + ! -------------------- + function initialize_scalar(seed) result(twister) + integer(kind=im), intent(in ) :: seed + type(randomNumberSequence) :: twister + + integer(kind=im) :: i + ! See Knuth TAOCP Vol2. 3rd Ed. P.106 for multiplier. In the previous versions, + ! MSBs of the seed affect only MSBs of the array state[]. + ! 2002/01/09 modified by Makoto Matsumoto + + twister%state(0) = iand(seed, -1_im) + do i = 1, blockSize - 1 ! ubound(twister%state) + twister%state(i) = 1812433253_im * ieor(twister%state(i-1), & + ishft(twister%state(i-1), -30_im)) + i + twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines + end do + twister%currentElement = blockSize + end function initialize_scalar + ! ------------------------------------------------------------- + function initialize_vector(seed) result(twister) + integer(kind=im), dimension(0:), intent(in) :: seed + type(randomNumberSequence) :: twister + + integer(kind=im) :: i, j, k, nFirstLoop, nWraps + + nWraps = 0 + twister = initialize_scalar(19650218_im) + + nFirstLoop = max(blockSize, size(seed)) + do k = 1, nFirstLoop + i = mod(k + nWraps, blockSize) + j = mod(k - 1, size(seed)) + if(i == 0) then + twister%state(i) = twister%state(blockSize - 1) + twister%state(1) = ieor(twister%state(1), & + ieor(twister%state(1-1), & + ishft(twister%state(1-1), -30_im)) * 1664525_im) + & + seed(j) + j ! Non-linear + twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines + nWraps = nWraps + 1 + else + twister%state(i) = ieor(twister%state(i), & + ieor(twister%state(i-1), & + ishft(twister%state(i-1), -30_im)) * 1664525_im) + & + seed(j) + j ! Non-linear + twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines + end if + end do + + ! + ! Walk through the state array, beginning where we left off in the block above + ! + do i = mod(nFirstLoop, blockSize) + nWraps + 1, blockSize - 1 + twister%state(i) = ieor(twister%state(i), & + ieor(twister%state(i-1), & + ishft(twister%state(i-1), -30_im)) * 1566083941_im) - i ! Non-linear + twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines + end do + + twister%state(0) = twister%state(blockSize - 1) + + do i = 1, mod(nFirstLoop, blockSize) + nWraps + twister%state(i) = ieor(twister%state(i), & + ieor(twister%state(i-1), & + ishft(twister%state(i-1), -30_im)) * 1566083941_im) - i ! Non-linear + twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines + end do + + twister%state(0) = UMASK + twister%currentElement = blockSize + + end function initialize_vector + ! ------------------------------------------------------------- + ! Public functions + ! -------------------- + function getRandomInt(twister) + type(randomNumberSequence), intent(inout) :: twister + integer(kind=im) :: getRandomInt + ! Generate a random integer on the interval [0,0xffffffff] + ! Equivalent to genrand_int32 in the C code. + ! Fortran doesn't have a type that's unsigned like C does, + ! so this is integers in the range -2**31 - 2**31 + ! All functions for getting random numbers call this one, + ! then manipulate the result + + if(twister%currentElement >= blockSize) call nextState(twister) + + getRandomInt = temper(twister%state(twister%currentElement)) + twister%currentElement = twister%currentElement + 1 + + end function getRandomInt + ! -------------------- + function getRandomPositiveInt(twister) + type(randomNumberSequence), intent(inout) :: twister + integer(kind=im) :: getRandomPositiveInt + ! Generate a random integer on the interval [0,0x7fffffff] + ! or [0,2**31] + ! Equivalent to genrand_int31 in the C code. + + ! Local integers + integer(kind=im) :: localInt + + localInt = getRandomInt(twister) + getRandomPositiveInt = ishft(localInt, -1) + + end function getRandomPositiveInt + ! -------------------- + ! -------------------- +!! mji - modified Jan 2007, double converted to rrtmg real kind type + function getRandomReal(twister) + type(randomNumberSequence), intent(inout) :: twister +! double precision :: getRandomReal + real(kind=rb) :: getRandomReal + ! Generate a random number on [0,1] + ! Equivalent to genrand_real1 in the C code + ! The result is stored as double precision but has 32 bit resolution + + integer(kind=im) :: localInt + + localInt = getRandomInt(twister) + if(localInt < 0) then +! getRandomReal = dble(localInt + 2.0d0**32)/(2.0d0**32 - 1.0d0) + getRandomReal = (localInt + 2.0**32_rb)/(2.0**32_rb - 1.0_rb) + else +! getRandomReal = dble(localInt )/(2.0d0**32 - 1.0d0) + getRandomReal = (localInt )/(2.0**32_rb - 1.0_rb) + end if + + end function getRandomReal + ! -------------------- + subroutine finalize_RandomNumberSequence(twister) + type(randomNumberSequence), intent(inout) :: twister + + twister%currentElement = blockSize + twister%state(:) = 0_im + end subroutine finalize_RandomNumberSequence + + ! -------------------- + + end module MersenneTwister + diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index 585ff01df..74aaf6903 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -3584,33 +3584,33 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, & RH_00L = 0.7 + SQRT(1./(25.0+gridkm*gridkm*gridkm)) RH_00O = 0.81 + SQRT(1./(50.0+gridkm*gridkm*gridkm)) - - DO j = jts,jte - DO k = kts,kte - DO i = its,ite - RHI_max = 0.0 - CLDFRA(I,K,J) = 0.0 - + + DO j = jts,jte + DO k = kts,kte + DO i = its,ite + RHI_max = 0.0 + CLDFRA(I,K,J) = 0.0 + if (qc(i,k,j).gt.1.E-6 .or. qi(i,k,j).ge.1.E-7 .or.qs(i,k,j) & - & .gt.1.E-5) then - CLDFRA(I,K,J) = 1.0 - qvsat(i,k,j) = qv(i,k,j) - else - TK = t(i,k,j) - TC = TK - 273.16 - - qvsw = rslf(P(i,k,j), TK) - qvsi = rsif(P(i,k,j), TK) - - if (tc .ge. -12.0) then - qvsat(i,k,j) = qvsw - elseif (tc .lt. -20.0) then - qvsat(i,k,j) = qvsi - else - qvsat(i,k,j) = qvsw - (qvsw-qvsi)*(-12.0-tc)/(-12.0+20.) - endif - RHUM = MAX(0.01, MIN(qv(i,k,j)/qvsat(i,k,j), 0.9999)) - + & .gt.1.E-5) then + CLDFRA(I,K,J) = 1.0 + qvsat(i,k,j) = qv(i,k,j) + else + TK = t(i,k,j) + TC = TK - 273.16 + + qvsw = rslf(P(i,k,j), TK) + qvsi = rsif(P(i,k,j), TK) + + if (tc .ge. -12.0) then + qvsat(i,k,j) = qvsw + elseif (tc .lt. -20.0) then + qvsat(i,k,j) = qvsi + else + qvsat(i,k,j) = qvsw - (qvsw-qvsi)*(-12.0-tc)/(-12.0+20.) + endif + RHUM = MAX(0.01, MIN(qv(i,k,j)/qvsat(i,k,j), 0.9999)) + IF ((XLAND(I,J)-1.5).GT.0.) THEN !--- Ocean RH_00 = RH_00O ELSE !--- Land diff --git a/physics/radlw_main.f b/physics/radlw_main.f index 7b029f8b0..55f864f9b 100644 --- a/physics/radlw_main.f +++ b/physics/radlw_main.f @@ -243,12 +243,15 @@ module rrtmg_lw ! use physparam, only : ilwrate, ilwrgas, ilwcliq, ilwcice, & - & isubclw, icldflg, iovrlw, ivflip, & - & kind_phys + & isubclw, icldflg, iovrlw, ivflip +!mz & kind_phys use physcons, only : con_g, con_cp, con_avgd, con_amd, & & con_amw, con_amo3 use mersenne_twister, only : random_setseed, random_number, & & random_stat +!mz + use machine, only : kind_phys, & + & im => kind_io4, rb => kind_phys use module_radlw_parameters ! @@ -593,6 +596,28 @@ subroutine rrtmg_lw_run & real (kind=kind_phys), dimension(npts,nlay,nbands),intent(in):: & & aeraod, aerssa +!mz* HWRF -- INPUT from mcica_subcol_lw + real(kind=kind_phys),dimension(ngptlw,npts,nlay) :: cldfmcl ! Cloud fraction + ! Dimensions: (ngptlw,ncol,nlay) +! real(kind=rb), intent(in) :: ciwpmcl(:,:,:) ! In-cloud ice water path (g/m2) +! ! Dimensions: (ngptlw,ncol,nlay) +! real(kind=rb), intent(in) :: clwpmcl(:,:,:) ! In-cloud liquid water path (g/m2) +! ! Dimensions: (ngptlw,ncol,nlay) +! real(kind=rb), intent(in) :: cswpmcl(:,:,:) ! In-cloud snow water path (g/m2) +! ! Dimensions: (ngptlw,ncol,nlay) +! real(kind=rb), intent(in) :: relqmcl(:,:) ! Cloud water drop effective radius (microns) +! ! Dimensions: (ncol,nlay) +! real(kind=rb), intent(in) :: reicmcl(:,:) ! Cloud ice effective size (microns) +! ! Dimensions: (ncol,nlay) +! real(kind=rb), intent(in) :: resnmcl(:,:) ! Snow effective size (microns) +! ! Dimensions: (ncol,nlay) +! real(kind=rb), intent(in) :: taucmcl(:,:,:) ! In-cloud optical depth +! ! Dimensions: (ngptlw,ncol,nlay) +! real(kind=rb), intent(in) :: tauaer(:,:,:) ! Aerosol optical depth +! ! Dimensions: (ncol,nlay,nbndlw) + +!mz + ! --- outputs: real (kind=kind_phys), dimension(npts,nlay), intent(inout) :: hlwc real (kind=kind_phys), dimension(npts,nlay), intent(inout) :: & @@ -614,6 +639,11 @@ subroutine rrtmg_lw_run & logical, intent(in) :: lslwr ! --- locals: +! mz* - Add height of each layer for exponential-random cloud overlap +! This will be derived below from the dzlyr in each layer + real (kind=kind_phys), dimension( npts,nlay ) :: hgt + real (kind=kind_phys):: dzsum + real (kind=kind_phys), dimension(0:nlp1) :: cldfrc real (kind=kind_phys), dimension(0:nlay) :: totuflux, totdflux, & @@ -631,6 +661,7 @@ subroutine rrtmg_lw_run & real (kind=kind_phys), dimension(nlay,nbands) :: htrb real (kind=kind_phys), dimension(nbands,nlay) :: taucld, tauaer + real (kind=kind_phys), dimension(nbands,1,nlay) :: taucld3 real (kind=kind_phys), dimension(ngptlw,nlay) :: fracs, tautot, & & cldfmc @@ -654,6 +685,9 @@ subroutine rrtmg_lw_run & integer, dimension(npts) :: ipseed integer, dimension(nlay) :: jp, jt, jt1, indself, indfor, indminor integer :: laytrop, iplon, i, j, k, k1 + ! mz* added local arrays for RRTMG + integer :: irng, permuteseed,ig + integer :: inflglw, iceflglw, liqflglw logical :: lcf1 ! @@ -662,6 +696,14 @@ subroutine rrtmg_lw_run & ! Initialize CCPP error handling variables errmsg = '' errflg = 0 + +!mz* +! For passing in cloud physical properties; cloud optics parameterized +! in RRTMG: + inflglw = 2 + iceflglw = 3 + liqflglw = 1 + ! if (.not. lslwr) return @@ -734,6 +776,52 @@ subroutine rrtmg_lw_run & stemp = sfgtmp(iplon) ! surface ground temp if (iovrlw == 3) delgth= de_lgth(iplon) ! clouds decorr-length +! mz*: HWRF practice + if (iovrlw == 4 ) then + + +!Add layer height needed for exponential (icld=4) and +! exponential-random (icld=5) overlap options + + !iplon = 1 + irng = 0 + permuteseed = 150 + +!mz* Derive height + dzsum =0.0 + do k = 1,nlay + hgt(iplon,k)= dzsum+0.5*dzlyr(iplon,k)*1000. !km->m + dzsum = dzsum+ dzlyr(iplon,k)*1000. + enddo + +! Zero out cloud optical properties here; not used when passing physical properties +! to radiation and taucld is calculated in radiation + do k = 1, nlay + do j = 1, nbands + taucld3(j,iplon,k) = 0.0 + enddo + enddo + + +! call mcica_subcol_lw(iplon, ncol, nlay, iovrlw, permuteseed, & +! & irng, play, hgt, & +! & cldfrac, ciwpth, clwpth, cswpth, rei, rel, res, & +! & taucld, & +! & cldfmcl, & !--output +! & ciwpmcl, clwpmcl, cswpmcl, reicmcl, relqmcl, & +! & resnmcl, taucmcl) + +!mz* calculate cldfmcl for mcica first, *temporary + call mcica_subcol_lw(1, iplon, nlay, iovrlw, permuteseed, & + & irng, plyr, hgt, & + & cld_cf, cld_iwp, cld_lwp,cld_swp, & + & cld_ref_ice, cld_ref_liq, & + & cld_ref_snow, taucld3, & + & cldfmcl ) !--output + + endif +!mz* end + !> -# Prepare atmospheric profile for use in rrtm. ! the vertical index of internal array is from surface to top @@ -821,6 +909,8 @@ subroutine rrtmg_lw_run & !> -# Read cloud optical properties. if (ilwcliq > 0) then ! use prognostic cloud method +!mz: GFS operational + if (iovrlw .ne. 4 ) then do k = 1, nlay k1 = nlp1 - k cldfrc(k)= cld_cf(iplon,k1) @@ -828,11 +918,40 @@ subroutine rrtmg_lw_run & relw(k) = cld_ref_liq(iplon,k1) ciwp(k) = cld_iwp(iplon,k1) reiw(k) = cld_ref_ice(iplon,k1) + !mz*: Limit upper bound of reice for Fu ice + !parameterization and convert from effective radius + !to generalized effective size (*1.0315; Fu, 1996) + if (iovrlw .eq. 4 .and. iceflglw.eq.3) then + reiw(k) = cld_ref_ice(iplon,k1) *1.0315 + reiw(k) = min(140.0, reiw(k)) + endif cda1(k) = cld_rwp(iplon,k1) cda2(k) = cld_ref_rain(iplon,k1) cda3(k) = cld_swp(iplon,k1) cda4(k) = cld_ref_snow(iplon,k1) + !mz + if (iovrlw .eq. 4 .and. inflglw .ne.5) then + cda3(k) = 0. + cda4(k) = 10. + endif enddo + ! transfer + else if (iovrlw .eq. 4) then !mz HWRF + do k = 1, nlay + k1 = nlp1 - k + do ig = 1, ngptlw + cldfmc(ig,k) = cldfmcl(ig,iplon,k1) +!mz* not activate +! taucmc(ig,k) = taucmcl(ig,iplon,k1) +! ciwpmc(ig,k) = ciwpmcl(ig,iplon,k1) +! clwpmc(ig,k) = clwpmcl(ig,iplon,k1) +! cswpmc(ig,k) = cswpmcl(ig,iplon,k1) + enddo +! reicmc(k) = reicmcl(iplon,k1) +! relqmc(k) = relqmcl(iplon,k1) +! resnmc(k) = resnmcl(iplon,k1) + enddo + endif else ! use diagnostic cloud method do k = 1, nlay k1 = nlp1 - k @@ -928,17 +1047,45 @@ subroutine rrtmg_lw_run & enddo if (ilwcliq > 0) then ! use prognostic cloud method +!mz* + if (iovrlw .ne. 4) then do k = 1, nlay cldfrc(k)= cld_cf(iplon,k) clwp(k) = cld_lwp(iplon,k) relw(k) = cld_ref_liq(iplon,k) ciwp(k) = cld_iwp(iplon,k) reiw(k) = cld_ref_ice(iplon,k) + !mz*: Limit upper bound of reice for Fu ice + !parameterization and convert from effective radius + !to generalized effective size (*1.0315; Fu, 1996) + if (iovrlw .eq. 4 .and. iceflglw.eq.3) then + reiw(k) = cld_ref_ice(iplon,k1) *1.0315 + reiw(k) = min(140.0, reiw(k)) + endif cda1(k) = cld_rwp(iplon,k) cda2(k) = cld_ref_rain(iplon,k) cda3(k) = cld_swp(iplon,k) cda4(k) = cld_ref_snow(iplon,k) + !mz* + if (iovrlw .eq. 4 .and. inflglw .ne.5) then + cda3(k) = 0. + cda4(k) = 10. + endif + enddo + else if (iovrlw .eq. 4) then + do k = 1, nlay + do ig = 1, ngptlw + cldfmc(ig,k) = cldfmcl(ig,iplon,k) +! taucmc(ig,k) = taucmcl(ig,iplon,k) +! ciwpmc(ig,k) = ciwpmcl(ig,iplon,k) +! clwpmc(ig,k) = clwpmcl(ig,iplon,k) +! cswpmc(ig,k) = cswpmcl(ig,iplon,k) + enddo +! reicmc(k) = reicmcl(iplon,k) +! relqmc(k) = relqmcl(iplon,k) +! resnmc(k) = resnmcl(iplon,k) enddo + endif else ! use diagnostic cloud method do k = 1, nlay cldfrc(k)= cld_cf(iplon,k) @@ -1004,6 +1151,9 @@ subroutine rrtmg_lw_run & !> -# For cloudy atmosphere, call cldprop() to set cloud optical !! properties. +!mz* + if (iovrlw .ne. 4 ) then !mz:GFS oprational + lcf1 = .false. lab_do_k0 : do k = 1, nlay if ( cldfrc(k) > eps ) then @@ -1040,6 +1190,26 @@ subroutine rrtmg_lw_run & cldfmc = f_zero taucld = f_zero endif + endif !mz iovrlw.ne.4 + +! else if (iovrlw .eq. 4) then !mz*:HWRF for cldovrlp=4 + +!mz* call CLDPRMC to set cloud optical depth for McICA based on input cloud +! properties (inflglw) + +! For cloudy atmosphere, use cldprop to set cloud optical properties based on +! input cloud physical properties. Select method based on choices described +! in cldprop. Cloud fraction, water path, liquid droplet and ice particle +! effective radius must be passed into cldprop. Cloud fraction and cloud +! optical depth are transferred to rrtmg_lw arrays in cldprop. +! +! ncbands(im): number of cloud spectral bands +! taucmc(ngptlw,nlayers): cloud optical depth [mcica] + +! call cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, ciwpmc,& +! clwpmc, cswpmc, reicmc, relqmc, resnmc, & +! ncbands, taucmc) + ! if (lprnt) then ! print *,' after cldprop' @@ -1344,11 +1514,13 @@ subroutine rlwinit & ! !===> ... begin here ! - if ( iovrlw<0 .or. iovrlw>3 ) then + if ( iovrlw<0 .or. iovrlw>4 ) then print *,' *** Error in specification of cloud overlap flag', & & ' IOVRLW=',iovrlw,' in RLWINIT !!' stop - elseif ( iovrlw>=2 .and. isubclw==0 ) then +!mz +! elseif ( iovrlw>=2 .and. isubclw==0 ) then + elseif ( (iovrlw.eq.2 .or. iovrlw.eq.3).and. isubclw==0 ) then if (me == 0) then print *,' *** IOVRLW=',iovrlw,' is not available for', & & ' ISUBCLW=0 setting!!' @@ -6762,9 +6934,569 @@ end subroutine taumol !! @} !----------------------------------- +!mz* exponential cloud overlapping subroutines +!------------------------------------------------------------------ +! Public subroutines +!------------------------------------------------------------------ +! mz* - Add height needed for exponential and exponential-random cloud overlap methods (icld=4 and 5, respectively) +! mz* - cldfmcl only *temporary + subroutine mcica_subcol_lw(iplon, ncol, nlay, icld, permuteseed, & + & irng, play, hgt, & + & cldfrac, ciwp, clwp, cswp, rei, rel, res, tauc, & + & cldfmcl) +!mz* the below output need to be compatible with cldprop() +!mz ciwpmcl, clwpmcl, cswpmcl, reicmcl, relqmcl, resnmcl, taucmcl) + + use machine, only : im => kind_io4, rb => kind_phys +! ----- Input ----- +! Control + integer(kind=im), intent(in) :: iplon ! column/longitude index + integer(kind=im), intent(in) :: ncol ! number of columns + integer(kind=im), intent(in) :: nlay ! number of model layers + integer(kind=im), intent(in) :: icld ! clear/cloud, cloud overlap flag + integer(kind=im), intent(in) :: permuteseed ! if the cloud generator is called multiple times, + ! permute the seed between each call. + ! between calls for LW and SW, recommended + ! permuteseed differes by 'ngpt' + integer(kind=im), intent(inout) :: irng ! flag for random number generator + ! 0 = kissvec + ! 1 = Mersenne + ! Twister + +! Atmosphere + real(kind=rb), intent(in) :: play(:,:) ! layer pressures (mb) + ! Dimensions: (ncol,nlay) + +! mji - Add height + real(kind=rb), intent(in) :: hgt(:,:) ! layer height (m) + ! Dimensions: (ncol,nlay) + +! Atmosphere/clouds - cldprop + real(kind=rb), intent(in) :: cldfrac(:,:) ! layer cloud fraction + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: tauc(:,:,:) ! in-cloud optical depth + ! Dimensions: (nbndlw,ncol,nlay) +! real(kind=rb), intent(in) :: ssac(:,:,:) ! in-cloud single scattering albedo + ! Dimensions: (nbndlw,ncol,nlay) +! real(kind=rb), intent(in) :: asmc(:,:,:) ! in-cloud asymmetry parameter + ! Dimensions: (nbndlw,ncol,nlay) + real(kind=rb), intent(in) :: ciwp(:,:) ! in-cloud ice water path + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: clwp(:,:) ! in-cloud liquid water path + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: cswp(:,:) ! in-cloud snow path + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: rei(:,:) ! cloud ice particle size + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: rel(:,:) ! cloud liquid particle size + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: res(:,:) ! snow particle size + ! Dimensions: (ncol,nlay) + +! ----- Output ----- +! Atmosphere/clouds - cldprmc [mcica] + real(kind=rb), intent(out) :: cldfmcl(:,:,:) ! cloud fraction [mcica] + ! Dimensions: (ngptlw,ncol,nlay) +!mz* not activate, temporary local vars + real(kind=rb),dimension(ngptlw,ncol,nlay) :: ciwpmcl ! in-cloud ice water path [mcica] + ! Dimensions: (ngptlw,ncol,nlay) + real(kind=rb),dimension(ngptlw,ncol,nlay) :: clwpmcl ! in-cloud liquid water path [mcica] + ! Dimensions: (ngptlw,ncol,nlay) + real(kind=rb),dimension(ngptlw,ncol,nlay) :: cswpmcl ! in-cloud snow path [mcica] + ! Dimensions: (ngptlw,ncol,nlay) + real(kind=rb),dimension(ncol,nlay) :: relqmcl ! liquid particle size (microns) + ! Dimensions: (ncol,nlay) + real(kind=rb),dimension(ncol,nlay) :: reicmcl ! ice partcle size (microns) + ! Dimensions: (ncol,nlay) + real(kind=rb),dimension(ncol,nlay) :: resnmcl ! snow partcle size (microns) + ! Dimensions: (ncol,nlay) + real(kind=rb),dimension(ngptlw,ncol,nlay) :: taucmcl ! in-cloud optical depth [mcica] +!mz* + ! Dimensions: (ngptlw,ncol,nlay) +! real(kind=rb), intent(out) :: ssacmcl(:,:,:) ! in-cloud single scattering albedo [mcica] + ! Dimensions: (ngptlw,ncol,nlay) +! real(kind=rb), intent(out) :: asmcmcl(:,:,:) ! in-cloud asymmetry parameter [mcica] + ! Dimensions: (ngptlw,ncol,nlay) +! ----- Local ----- + +! Stochastic cloud generator variables [mcica] + integer(kind=im), parameter :: nsubclw = ngptlw ! number of sub-columns (g-point intervals) + integer(kind=im) :: ilev ! loop index + + real(kind=rb) :: pmid(ncol, nlay) ! layer pressures (Pa) +! real(kind=rb) :: pdel(ncol, nlay) ! layer pressure thickness (Pa) +! real(kind=rb) :: qi(ncol, nlay) ! ice water (specific humidity) +! real(kind=rb) :: ql(ncol, nlay) ! liq water (specific humidity) + +! Return if clear sky + if (icld.eq.0) return + +! NOTE: For GCM mode, permuteseed must be offset between LW and SW by at least the number of subcolumns + + +! Pass particle sizes to new arrays, no subcolumns for these properties yet +! Convert pressures from mb to Pa + + reicmcl(:ncol,:nlay) = rei(:ncol,:nlay) + relqmcl(:ncol,:nlay) = rel(:ncol,:nlay) + resnmcl(:ncol,:nlay) = res(:ncol,:nlay) + pmid(:ncol,:nlay) = play(:ncol,:nlay)*1.e2_rb + +! Generate the stochastic subcolumns of cloud optical properties for +! the longwave + call generate_stochastic_clouds (ncol, nlay, nsubclw, icld, irng, & + & pmid, hgt, cldfrac, clwp, ciwp, cswp, tauc, & + & cldfmcl, clwpmcl, ciwpmcl, cswpmcl, & + & taucmcl, permuteseed) + + end subroutine mcica_subcol_lw +!------------------------------------------------------------------------------------------------- + subroutine generate_stochastic_clouds(ncol, nlay, nsubcol, icld, & + & irng, pmid, hgt, cld, clwp, ciwp, cswp, tauc, & + & cld_stoch, clwp_stoch, ciwp_stoch, & + & cswp_stoch, tauc_stoch, changeSeed) +!------------------------------------------------------------------------------------------------- +!------------------------------------------------------------------------------------------------- +! Contact: Cecile Hannay (hannay@ucar.edu) +! +! Original code: Based on Raisanen et al., QJRMS, 2004. +! +! Modifications: +! 1) Generalized for use with RRTMG and added Mersenne Twister as the default +! random number generator, which can be changed to the optional kissvec random number generator +! with flag 'irng'. Some extra functionality has been commented or removed. +! Michael J. Iacono, AER, Inc., February 2007 +! 2) Activated exponential and exponential/random cloud overlap method +! Michael J. Iacono, AER, November 2017 +! +! Given a profile of cloud fraction, cloud water and cloud ice, we produce a set of subcolumns. +! Each layer within each subcolumn is homogeneous, with cloud fraction equal to zero or one +! and uniform cloud liquid and cloud ice concentration. +! The ensemble as a whole reproduces the probability function of cloud liquid and ice within each layer +! and obeys an overlap assumption in the vertical. +! +! Overlap assumption: +! The cloud are consistent with 5 overlap assumptions: random, maximum, maximum-random, exponential and exponential random. +! The default option is maximum-random (option 2) +! The options are: 1=random overlap, 2=max/random, 3=maximum overlap, 4=exponential overlap, 5=exp/random +! This is set with the variable "overlap" +! The exponential overlap uses also a length scale, Zo. (real, parameter :: Zo = 2500. ) +! +! Seed: +! If the stochastic cloud generator is called several times during the same timestep, +! one should change the seed between the call to insure that the +! subcolumns are different. +! This is done by changing the argument 'changeSeed' +! For example, if one wants to create a set of columns for the +! shortwave and another set for the longwave , +! use 'changeSeed = 1' for the first call and'changeSeed = 2' for the second call + +! PDF assumption: +! We can use arbitrary complicated PDFS. +! In the present version, we produce homogeneuous clouds (the simplest case). +! Future developments include using the PDF scheme of Ben Johnson. +! +! History file: +! Option to add diagnostics variables in the history file. (using FINCL in the namelist) +! nsubcol = number of subcolumns +! overlap = overlap type (1-3) +! Zo = length scale +! CLOUD_S = mean of the subcolumn cloud fraction ('_S" means Stochastic) +! CLDLIQ_S = mean of the subcolumn cloud water +! CLDICE_S = mean of the subcolumn cloud ice +! +! Note: +! Here: we force that the cloud condensate to be consistent with the cloud fraction +! i.e we only have cloud condensate when the cell is cloudy. +! In CAM: The cloud condensate and the cloud fraction are obtained from 2 different equations +! and the 2 quantities can be inconsistent (i.e. CAM can produce cloud fraction +! without cloud condensate or the opposite). +!----------------------------------------------------------------- + + use mcica_random_numbers +! The Mersenne Twister random number engine + use MersenneTwister, only: randomNumberSequence, & + & new_RandomNumberSequence, getRandomReal + use machine ,only : im => kind_io4, rb => kind_phys + + type(randomNumberSequence) :: randomNumbers + +! -- Arguments + + integer(kind=im), intent(in) :: ncol ! number of columns + integer(kind=im), intent(in) :: nlay ! number of layers + integer(kind=im), intent(in) :: icld ! clear/cloud, cloud overlap flag + integer(kind=im), intent(inout) :: irng ! flag for random number generator + ! 0 = kissvec + ! 1 = Mersenne Twister + integer(kind=im), intent(in) :: nsubcol ! number of sub-columns (g-point intervals) + integer(kind=im), optional, intent(in) :: changeSeed ! allows permuting seed + +! Column state (cloud fraction, cloud water, cloud ice) + variables needed to read physics state + real(kind=rb), intent(in) :: pmid(:,:) ! layer pressure (Pa) + ! Dimensions: (ncol,nlay) + + real(kind=rb), intent(in) :: hgt(:,:) ! layer height (m) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: cld(:,:) ! cloud fraction + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: clwp(:,:) ! in-cloud liquid water path + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: ciwp(:,:) ! in-cloud ice water path + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: cswp(:,:) ! in-cloud snow path + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: tauc(:,:,:) ! in-cloud optical depth + ! Dimensions:(nbndlw,ncol,nlay) +! real(kind=rb), intent(in) :: ssac(:,:,:) ! in-cloud single scattering albedo + ! Dimensions: (nbndlw,ncol,nlay) + ! inactive - for future expansion +! real(kind=rb), intent(in) :: asmc(:,:,:) ! in-cloud asymmetry parameter + ! Dimensions: (nbndlw,ncol,nlay) + ! inactive - for future expansion + + real(kind=rb), intent(out) :: cld_stoch(:,:,:) ! subcolumn cloud fraction + ! Dimensions: (ngptlw,ncol,nlay) + real(kind=rb), intent(out) :: clwp_stoch(:,:,:) ! subcolumn in-cloud liquid water path + ! Dimensions: (ngptlw,ncol,nlay) + real(kind=rb), intent(out) :: ciwp_stoch(:,:,:) ! subcolumn in-cloud ice water path + ! Dimensions: (ngptlw,ncol,nlay) + real(kind=rb), intent(out) :: cswp_stoch(:,:,:) ! subcolumn in-cloud snow path + ! Dimensions: (ngptlw,ncol,nlay) + real(kind=rb), intent(out) :: tauc_stoch(:,:,:) ! subcolumn in-cloud optical depth + ! Dimensions: (ngptlw,ncol,nlay) +! real(kind=rb), intent(out) :: ssac_stoch(:,:,:)! subcolumn in-cloud single scattering albedo + ! Dimensions: (ngptlw,ncol,nlay) + ! inactive - for future expansion +! real(kind=rb), intent(out) :: asmc_stoch(:,:,:)! subcolumn in-cloud asymmetry parameter + ! Dimensions: (ngptlw,ncol,nlay) + ! inactive - for future expansion + +! -- Local variables + real(kind=rb) :: cldf(ncol,nlay) ! cloud fraction + +! Mean over the subcolumns (cloud fraction, cloud water , cloud ice) - inactive +! real(kind=rb) :: mean_cld_stoch(ncol, nlay) ! cloud fraction +! real(kind=rb) :: mean_clwp_stoch(ncol, nlay) ! cloud water +! real(kind=rb) :: mean_ciwp_stoch(ncol, nlay) ! cloud ice +! real(kind=rb) :: mean_tauc_stoch(ncol, nlay) ! cloud optical depth +! real(kind=rb) :: mean_ssac_stoch(ncol, nlay) ! cloud single scattering albedo +! real(kind=rb) :: mean_asmc_stoch(ncol, nlay) ! cloud asymmetry parameter + +! Set overlap + integer(kind=im) :: overlap ! 1 = random overlap, 2 = maximum-random, + ! 3 = maximum overlap, 4 = exponential, + ! 5 = exponential-random + real(kind=rb), parameter :: Zo = 2500._rb ! length scale (m) + real(kind=rb), dimension(ncol,nlay) :: alpha ! overlap parameter + +! Constants (min value for cloud fraction and cloud water and ice) + real(kind=rb), parameter :: cldmin = 1.0e-20_rb ! min cloud fraction +! real(kind=rb), parameter :: qmin = 1.0e-10_rb ! min cloud water and cloud ice (not used) + +! Variables related to random number and seed + real(kind=rb), dimension(nsubcol, ncol, nlay) :: CDF, CDF2 !random numbers + integer(kind=im), dimension(ncol) :: seed1, seed2, seed3, seed4 !seed to create random number (kissvec) + real(kind=rb), dimension(ncol) :: rand_num ! random number (kissvec) + integer(kind=im) :: iseed ! seed to create random number (Mersenne Teister) + real(kind=rb) :: rand_num_mt ! random number (Mersenne Twister) + +! Flag to identify cloud fraction in subcolumns + logical, dimension(nsubcol, ncol, nlay) :: iscloudy ! flag that says whether a gridbox is cloudy + +! Indices + integer(kind=im) :: ilev, isubcol, i, n ! indices + +!------------------------------------------------------------------- + +! Check that irng is in bounds; if not, set to default + if (irng .ne. 0) irng = 1 + +! Pass input cloud overlap setting to local variable + overlap = icld + +! Ensure that cloud fractions are in bounds + do ilev = 1, nlay + do i = 1, ncol + cldf(i,ilev) = cld(i,ilev) + if (cldf(i,ilev) < cldmin) then + cldf(i,ilev) = 0._rb + endif + enddo + enddo + +! ----- Create seed -------- + +! Advance randum number generator by changeseed values + if (irng.eq.0) then +! For kissvec, create a seed that depends on the state of the columns. Maybe not the best way, but it works. +! Must use pmid from bottom four layers. + do i=1,ncol + if (pmid(i,1).lt.pmid(i,2)) then + stop 'MCICA_SUBCOL: KISSVEC SEED GENERATOR REQUIRES PMID & + & FROM BOTTOM FOUR LAYERS.' + endif + seed1(i) = (pmid(i,1) - int(pmid(i,1))) * 1000000000_im + seed2(i) = (pmid(i,2) - int(pmid(i,2))) * 1000000000_im + seed3(i) = (pmid(i,3) - int(pmid(i,3))) * 1000000000_im + seed4(i) = (pmid(i,4) - int(pmid(i,4))) * 1000000000_im + enddo + do i=1,changeSeed + call kissvec(seed1, seed2, seed3, seed4, rand_num) + enddo + elseif (irng.eq.1) then + randomNumbers = new_RandomNumberSequence(seed = changeSeed) + endif + +! ------ Apply overlap assumption -------- + +! generate the random numbers + + select case (overlap) + + case(1) +! Random overlap +! i) pick a random value at every level + + if (irng.eq.0) then + do isubcol = 1,nsubcol + do ilev = 1,nlay + call kissvec(seed1, seed2, seed3, seed4, rand_num) ! we get different random number for each level + CDF(isubcol,:,ilev) = rand_num + enddo + enddo + elseif (irng.eq.1) then + do isubcol = 1, nsubcol + do i = 1, ncol + do ilev = 1, nlay + rand_num_mt = getRandomReal(randomNumbers) + CDF(isubcol,i,ilev) = rand_num_mt + enddo + enddo + enddo + endif + + case(2) +! Maximum-Random overlap +! i) pick a random number for top layer. +! ii) walk down the column: +! - if the layer above is cloudy, we use the same random number than in the layer above +! - if the layer above is clear, we use a new random number + + if (irng.eq.0) then + do isubcol = 1,nsubcol + do ilev = 1,nlay + call kissvec(seed1, seed2, seed3, seed4, rand_num) + CDF(isubcol,:,ilev) = rand_num + enddo + enddo + elseif (irng.eq.1) then + do isubcol = 1, nsubcol + do i = 1, ncol + do ilev = 1, nlay + rand_num_mt = getRandomReal(randomNumbers) + CDF(isubcol,i,ilev) = rand_num_mt + enddo + enddo + enddo + endif + + do ilev = 2,nlay + do i = 1, ncol + do isubcol = 1, nsubcol + if (CDF(isubcol, i, ilev-1) > 1._rb - cldf(i,ilev-1) )& + & then + CDF(isubcol,i,ilev) = CDF(isubcol,i,ilev-1) + else + CDF(isubcol,i,ilev) = CDF(isubcol,i,ilev) * (1._rb & + & - cldf(i,ilev-1)) + endif + enddo + enddo + enddo + + case(3) +! Maximum overlap +! i) pick the same random numebr at every level + + if (irng.eq.0) then + do isubcol = 1,nsubcol + call kissvec(seed1, seed2, seed3, seed4, rand_num) + do ilev = 1,nlay + CDF(isubcol,:,ilev) = rand_num + enddo + enddo + elseif (irng.eq.1) then + do isubcol = 1, nsubcol + do i = 1, ncol + rand_num_mt = getRandomReal(randomNumbers) + do ilev = 1, nlay + CDF(isubcol,i,ilev) = rand_num_mt + enddo + enddo + enddo + endif + +! mji - Activate exponential cloud overlap option + case(4) + ! Exponential overlap: weighting between maximum and random overlap increases with the distance. + ! The random numbers for exponential overlap verify: + ! j=1 RAN(j)=RND1 + ! j>1 if RND1 < alpha(j,j-1) => RAN(j) = RAN(j-1) + ! RAN(j) = RND2 + ! alpha is obtained from the equation + ! alpha = exp(-(Z(j)-Z(j-1))/Zo) where Zo is a characteristic length scale + + ! compute alpha + do i = 1, ncol + alpha(i, 1) = 0._rb + do ilev = 2,nlay + alpha(i, ilev) = exp( -( hgt (i, ilev) - & + & hgt (i, ilev-1)) / Zo) + enddo + enddo + + ! generate 2 streams of random numbers + if (irng.eq.0) then + do isubcol = 1,nsubcol + do ilev = 1,nlay + call kissvec(seed1, seed2, seed3, seed4, rand_num) + CDF(isubcol, :, ilev) = rand_num + call kissvec(seed1, seed2, seed3, seed4, rand_num) + CDF2(isubcol, :, ilev) = rand_num + enddo + enddo + elseif (irng.eq.1) then + do isubcol = 1, nsubcol + do i = 1, ncol + do ilev = 1, nlay + rand_num_mt = getRandomReal(randomNumbers) + CDF(isubcol,i,ilev) = rand_num_mt + rand_num_mt = getRandomReal(randomNumbers) + CDF2(isubcol,i,ilev) = rand_num_mt + enddo + enddo + enddo + endif + + ! generate random numbers + do ilev = 2,nlay + where (CDF2(:, :, ilev) < spread(alpha (:,ilev), & + & dim=1,nCopies=nsubcol) ) + CDF(:,:,ilev) = CDF(:,:,ilev-1) + end where + end do + +! Activate exponential-random cloud overlap option + case(5) + ! Exponential-random overlap: +!mz* call wrf_error_fatal("Cloud Overlap case 5: ER has not yet & +! been implemented. Stopping...") + + end select + +! -- generate subcolumns for homogeneous clouds ----- + do ilev = 1,nlay + iscloudy(:,:,ilev) = (CDF(:,:,ilev) >= 1._rb - & + & spread(cldf(:,ilev), dim=1, nCopies=nsubcol) ) + enddo + +! where the subcolumn is cloudy, the subcolumn cloud fraction is 1; +! where the subcolumn is not cloudy, the subcolumn cloud fraction is 0; +! where there is a cloud, define the subcolumn cloud properties, +! otherwise set these to zero + + do ilev = 1,nlay + do i = 1, ncol + do isubcol = 1, nsubcol + if (iscloudy(isubcol,i,ilev) ) then + cld_stoch(isubcol,i,ilev) = 1._rb + clwp_stoch(isubcol,i,ilev) = clwp(i,ilev) + ciwp_stoch(isubcol,i,ilev) = ciwp(i,ilev) + cswp_stoch(isubcol,i,ilev) = cswp(i,ilev) + n = ngb(isubcol) + tauc_stoch(isubcol,i,ilev) = tauc(n,i,ilev) +! ssac_stoch(isubcol,i,ilev) = ssac(n,i,ilev) +! asmc_stoch(isubcol,i,ilev) = asmc(n,i,ilev) + else + cld_stoch(isubcol,i,ilev) = 0._rb + clwp_stoch(isubcol,i,ilev) = 0._rb + ciwp_stoch(isubcol,i,ilev) = 0._rb + cswp_stoch(isubcol,i,ilev) = 0._rb + tauc_stoch(isubcol,i,ilev) = 0._rb +! ssac_stoch(isubcol,i,ilev) = 1._rb +! asmc_stoch(isubcol,i,ilev) = 1._rb + endif + enddo + enddo + enddo +! -- compute the means of the subcolumns --- +! mean_cld_stoch(:,:) = 0._rb +! mean_clwp_stoch(:,:) = 0._rb +! mean_ciwp_stoch(:,:) = 0._rb +! mean_tauc_stoch(:,:) = 0._rb +! mean_ssac_stoch(:,:) = 0._rb +! mean_asmc_stoch(:,:) = 0._rb +! do i = 1, nsubcol +! mean_cld_stoch(:,:) = cld_stoch(i,:,:) + mean_cld_stoch(:,:) +! mean_clwp_stoch(:,:) = clwp_stoch( i,:,:) + mean_clwp_stoch(:,:) +! mean_ciwp_stoch(:,:) = ciwp_stoch( i,:,:) + mean_ciwp_stoch(:,:) +! mean_tauc_stoch(:,:) = tauc_stoch( i,:,:) + mean_tauc_stoch(:,:) +! mean_ssac_stoch(:,:) = ssac_stoch( i,:,:) + mean_ssac_stoch(:,:) +! mean_asmc_stoch(:,:) = asmc_stoch( i,:,:) + mean_asmc_stoch(:,:) +! end do +! mean_cld_stoch(:,:) = mean_cld_stoch(:,:) / nsubcol +! mean_clwp_stoch(:,:) = mean_clwp_stoch(:,:) / nsubcol +! mean_ciwp_stoch(:,:) = mean_ciwp_stoch(:,:) / nsubcol +! mean_tauc_stoch(:,:) = mean_tauc_stoch(:,:) / nsubcol +! mean_ssac_stoch(:,:) = mean_ssac_stoch(:,:) / nsubcol +! mean_asmc_stoch(:,:) = mean_asmc_stoch(:,:) / nsubcol + + end subroutine generate_stochastic_clouds + +!------------------------------------------------------------------ +! Private subroutines +!------------------------------------------------------------------ + +!----------------------------------------------------------------- + subroutine kissvec(seed1,seed2,seed3,seed4,ran_arr) +!---------------------------------------------------------------- + +! public domain code +! made available from http://www.fortran.com/ +! downloaded by pjr on 03/16/04 for NCAR CAM +! converted to vector form, functions inlined by pjr,mvr on 05/10/2004 + +! The KISS (Keep It Simple Stupid) random number generator. Combines: +! (1) The congruential generator x(n)=69069*x(n-1)+1327217885, period 2^32. +! (2) A 3-shift shift-register generator, period 2^32-1, +! (3) Two 16-bit multiply-with-carry generators, period 597273182964842497>2^59 +! Overall period>2^123; + real(kind=rb), dimension(:), intent(inout) :: ran_arr + integer(kind=im), dimension(:), intent(inout) :: seed1,seed2,seed3& + & ,seed4 + integer(kind=im) :: i,sz,kiss + integer(kind=im) :: m, k, n + +! inline function + m(k, n) = ieor (k, ishft (k, n) ) + + sz = size(ran_arr) + do i = 1, sz + seed1(i) = 69069_im * seed1(i) + 1327217885_im + seed2(i) = m (m (m (seed2(i), 13_im), - 17_im), 5_im) + seed3(i) = 18000_im * iand (seed3(i), 65535_im) + & + & ishft (seed3(i), - 16_im) + seed4(i) = 30903_im * iand (seed4(i), 65535_im) + & + & ishft (seed4(i), - 16_im) + kiss = seed1(i) + seed2(i) + ishft (seed3(i), 16_im) + seed4(i) + ran_arr(i) = kiss*2.328306e-10_rb + 0.5_rb + end do + + end subroutine kissvec ! -!........................................! - end module rrtmg_lw ! -!========================================! +!........................................!$ + end module rrtmg_lw !$ +!========================================!$ From 5597b2c5b3add78dc569c29135caf1fffe5e5410 Mon Sep 17 00:00:00 2001 From: "Man.Zhang" Date: Sun, 16 Feb 2020 11:26:53 -0700 Subject: [PATCH 3/9] finalize HWRF RRTMG LW capability --- physics/radiation_clouds.f | 183 +- physics/radlw_main.f | 7502 ------------------------------------ physics/radlw_main.meta | 16 + 3 files changed, 105 insertions(+), 7596 deletions(-) delete mode 100644 physics/radlw_main.f diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index 74aaf6903..c259fc22e 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -3610,104 +3610,99 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, & qvsat(i,k,j) = qvsw - (qvsw-qvsi)*(-12.0-tc)/(-12.0+20.) endif RHUM = MAX(0.01, MIN(qv(i,k,j)/qvsat(i,k,j), 0.9999)) - - IF ((XLAND(I,J)-1.5).GT.0.) THEN !--- Ocean - RH_00 = RH_00O - ELSE !--- Land - RH_00 = RH_00L - ENDIF - - if (tc .ge. -12.0) then - RHUM = MIN(0.999, RHUM) - CLDFRA(I,K,J) = MAX(0.0, 1.0-SQRT((1.0-RHUM)/(1.-RH_00))) - elseif (tc.lt.-12..and.tc.gt.-70. .and. RHUM.gt.RH_00L) then - RHUM = MAX(0.01, MIN(qv(i,k,j)/qvsat(i,k,j), 1.0 - 1.E-6)) - CLDFRA(I,K,J) = MAX(0., 1.0-SQRT((1.0-RHUM)/(1.0-RH_00L))) - endif - CLDFRA(I,K,J) = MIN(0.90, CLDFRA(I,K,J)) - - endif - ENDDO - ENDDO - ENDDO - - -!..Prepare for a 1-D column to find various cloud layers. - - DO j = jts,jte - DO i = its,ite -! if (i.gt.10.and.i.le.20 .and. j.gt.10.and.j.le.20) then -! debug_flag = .true. -! else -! debug_flag = .false. -! endif - -! if (rand_perturb_on .eq. 1) then -! entrmnt = MAX(0.01, MIN(0.99, 0.5 + rand_pert(i,1,j)*0.5)) -! else - entrmnt = 0.5 -! endif - - DO k = kts,kte - qvs1d(k) = qvsat(i,k,j) - cfr1d(k) = cldfra(i,k,j) - T1d(k) = t(i,k,j) - P1d(k) = p(i,k,j) - R1d(k) = rho(i,k,j) - qc1d(k) = qc(i,k,j) - qi1d(k) = qi(i,k,j) - qs1d(k) = qs(i,k,j) - ENDDO - -! if (debug_flag) then -! WRITE (dbg_msg,*) 'DEBUG-GT: finding cloud layers at point (', i, ', ', j, ')' -! CALL wrf_debug (150, dbg_msg) -! endif + + IF ((XLAND(I,J)-1.5).GT.0.) THEN !--- Ocean + RH_00 = RH_00O + ELSE !--- Land + RH_00 = RH_00L + ENDIF + + if (tc .ge. -12.0) then + RHUM = MIN(0.999, RHUM) + CLDFRA(I,K,J) = MAX(0.0, 1.0-SQRT((1.0-RHUM)/(1.-RH_00))) + elseif (tc.lt.-12..and.tc.gt.-70. .and. RHUM.gt.RH_00L) then + RHUM = MAX(0.01, MIN(qv(i,k,j)/qvsat(i,k,j), 1.0 - 1.E-6)) + CLDFRA(I,K,J) = MAX(0., 1.0-SQRT((1.0-RHUM)/(1.0-RH_00L))) + endif + CLDFRA(I,K,J) = MIN(0.90, CLDFRA(I,K,J)) + + endif + ENDDO + ENDDO + ENDDO + + +!..Prepare for a 1-D column to find various cloud layers. + + DO j = jts,jte + DO i = its,ite +! if (i.gt.10.and.i.le.20 .and. j.gt.10.and.j.le.20) then +! debug_flag = .true. +! else +! debug_flag = .false. +! endif + +! if (rand_perturb_on .eq. 1) then +! entrmnt = MAX(0.01, MIN(0.99, 0.5 + rand_pert(i,1,j)*0.5)) +! else + entrmnt = 0.5 +! endif + + DO k = kts,kte + qvs1d(k) = qvsat(i,k,j) + cfr1d(k) = cldfra(i,k,j) + T1d(k) = t(i,k,j) + P1d(k) = p(i,k,j) + R1d(k) = rho(i,k,j) + qc1d(k) = qc(i,k,j) + qi1d(k) = qi(i,k,j) + qs1d(k) = qs(i,k,j) + ENDDO + +! if (debug_flag) then +! WRITE (dbg_msg,*) 'DEBUG-GT: finding cloud layers at point (', i, ', ', j, ')' +! CALL wrf_debug (150, dbg_msg) +! endif call find_cloudLayers(qvs1d, cfr1d, T1d, P1d, R1d, entrmnt, & & debug_flag, qc1d, qi1d, qs1d, kts,kte) - - DO k = kts,kte - cldfra(i,k,j) = cfr1d(k) - qc(i,k,j) = qc1d(k) - qi(i,k,j) = qi1d(k) - ENDDO - ENDDO - ENDDO - - - END SUBROUTINE cal_cldfra3 - - -!+---+-----------------------------------------------------------------+ -!..From cloud fraction array, find clouds of multi-level depth and -!compute -!.. a reasonable value of LWP or IWP that might be contained in that -!depth, -!.. unless existing LWC/IWC is already there. - + + DO k = kts,kte + cldfra(i,k,j) = cfr1d(k) + qc(i,k,j) = qc1d(k) + qi(i,k,j) = qi1d(k) + ENDDO + ENDDO + ENDDO + + + END SUBROUTINE cal_cldfra3 +!+---+-----------------------------------------------------------------+ +!..From cloud fraction array, find clouds of multi-level depth and compute +!.. a reasonable value of LWP or IWP that might be contained in that depth, +!.. unless existing LWC/IWC is already there. + SUBROUTINE find_cloudLayers(qvs1d, cfr1d, T1d, P1d, R1d, entrmnt, & & debugfl, qc1d, qi1d, qs1d, kts,kte) -! - IMPLICIT NONE -! - INTEGER, INTENT(IN):: kts, kte - LOGICAL, INTENT(IN):: debugfl - REAL, INTENT(IN):: entrmnt - REAL, DIMENSION(kts:kte), INTENT(IN):: qvs1d,T1d,P1d,R1d - REAL, DIMENSION(kts:kte), INTENT(INOUT):: cfr1d - REAL, DIMENSION(kts:kte), INTENT(INOUT):: qc1d, qi1d, qs1d - -!..Local vars. - REAL, DIMENSION(kts:kte):: theta, dz - REAL:: Z1, Z2, theta1, theta2, ht1, ht2 - INTEGER:: k, k2, k_tropo, k_m12C, k_m40C, k_cldb, k_cldt, kbot - LOGICAL:: in_cloud - character*512 dbg_msg - -!+---+ - - k_m12C = 0 - k_m40C = 0 +! + IMPLICIT NONE + + INTEGER, INTENT(IN):: kts, kte + LOGICAL, INTENT(IN):: debugfl + REAL, INTENT(IN):: entrmnt + REAL, DIMENSION(kts:kte), INTENT(IN):: qvs1d,T1d,P1d,R1d + REAL, DIMENSION(kts:kte), INTENT(INOUT):: cfr1d + REAL, DIMENSION(kts:kte), INTENT(INOUT):: qc1d, qi1d, qs1d + +!..Local vars. + REAL, DIMENSION(kts:kte):: theta, dz + REAL:: Z1, Z2, theta1, theta2, ht1, ht2 + INTEGER:: k, k2, k_tropo, k_m12C, k_m40C, k_cldb, k_cldt, kbot + LOGICAL:: in_cloud + character*512 dbg_msg + + + k_m12C = 0 + k_m40C = 0 DO k = kte, kts, -1 theta(k) = T1d(k)*((100000.0/P1d(k))**(287.05/1004.)) if (T1d(k)-273.16 .gt. -40.0 .and. P1d(k).gt.7000.0) k_m40C = & diff --git a/physics/radlw_main.f b/physics/radlw_main.f deleted file mode 100644 index 55f864f9b..000000000 --- a/physics/radlw_main.f +++ /dev/null @@ -1,7502 +0,0 @@ -!> \file radlw_main.f -!! This file contains NCEP's modifications of the rrtmg-lw radiation -!! code from AER. - -!!!!! ============================================================== !!!!! -!!!!! lw-rrtm3 radiation package description !!!!! -!!!!! ============================================================== !!!!! -! ! -! this package includes ncep's modifications of the rrtm-lw radiation ! -! code from aer inc. ! -! ! -! the lw-rrtm3 package includes these parts: ! -! ! -! 'radlw_rrtm3_param.f' ! -! 'radlw_rrtm3_datatb.f' ! -! 'radlw_rrtm3_main.f' ! -! ! -! the 'radlw_rrtm3_param.f' contains: ! -! ! -! 'module_radlw_parameters' -- band parameters set up ! -! ! -! the 'radlw_rrtm3_datatb.f' contains: ! -! ! -! 'module_radlw_avplank' -- plank flux data ! -! 'module_radlw_ref' -- reference temperature and pressure ! -! 'module_radlw_cldprlw' -- cloud property coefficients ! -! 'module_radlw_kgbnn' -- absorption coeffients for 16 ! -! bands, where nn = 01-16 ! -! ! -! the 'radlw_rrtm3_main.f' contains: ! -! ! -! 'rrtmg_lw' -- main lw radiation transfer ! -! ! -! in the main module 'rrtmg_lw' there are only two ! -! externally callable subroutines: ! -! ! -! ! -! 'lwrad' -- main lw radiation routine ! -! inputs: ! -! (plyr,plvl,tlyr,tlvl,qlyr,olyr,gasvmr, ! -! clouds,icseed,aerosols,sfemis,sfgtmp, ! -! dzlyr,delpin,de_lgth, ! -! npts, nlay, nlp1, lprnt, ! -! outputs: ! -! hlwc,topflx,sfcflx,cldtau, ! -!! optional outputs: ! -! HLW0,HLWB,FLXPRF) ! -! ! -! 'rlwinit' -- initialization routine ! -! inputs: ! -! ( me ) ! -! outputs: ! -! (none) ! -! ! -! all the lw radiation subprograms become contained subprograms ! -! in module 'rrtmg_lw' and many of them are not directly ! -! accessable from places outside the module. ! -! ! -! derived data type constructs used: ! -! ! -! 1. radiation flux at toa: (from module 'module_radlw_parameters') ! -! topflw_type - derived data type for toa rad fluxes ! -! upfxc total sky upward flux at toa ! -! upfx0 clear sky upward flux at toa ! -! ! -! 2. radiation flux at sfc: (from module 'module_radlw_parameters') ! -! sfcflw_type - derived data type for sfc rad fluxes ! -! upfxc total sky upward flux at sfc ! -! upfx0 clear sky upward flux at sfc ! -! dnfxc total sky downward flux at sfc ! -! dnfx0 clear sky downward flux at sfc ! -! ! -! 3. radiation flux profiles(from module 'module_radlw_parameters') ! -! proflw_type - derived data type for rad vertical prof ! -! upfxc level upward flux for total sky ! -! dnfxc level downward flux for total sky ! -! upfx0 level upward flux for clear sky ! -! dnfx0 level downward flux for clear sky ! -! ! -! external modules referenced: ! -! ! -! 'module physparam' ! -! 'module physcons' ! -! 'mersenne_twister' ! -! ! -! compilation sequence is: ! -! ! -! 'radlw_rrtm3_param.f' ! -! 'radlw_rrtm3_datatb.f' ! -! 'radlw_rrtm3_main.f' ! -! ! -! and all should be put in front of routines that use lw modules ! -! ! -!==========================================================================! -! ! -! the original aer's program declarations: ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! | -! Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). | -! This software may be used, copied, or redistributed as long as it is | -! not sold and this copyright notice is reproduced on each copy made. | -! This model is provided as is without any express or implied warranties. | -! (http://www.rtweb.aer.com/) | -! | -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! ************************************************************************ ! -! ! -! rrtmg_lw ! -! ! -! ! -! a rapid radiative transfer model ! -! for the longwave region ! -! for application to general circulation models ! -! ! -! ! -! atmospheric and environmental research, inc. ! -! 131 hartwell avenue ! -! lexington, ma 02421 ! -! ! -! eli j. mlawer ! -! jennifer s. delamere ! -! michael j. iacono ! -! shepard a. clough ! -! ! -! ! -! email: miacono@aer.com ! -! email: emlawer@aer.com ! -! email: jdelamer@aer.com ! -! ! -! the authors wish to acknowledge the contributions of the ! -! following people: steven j. taubman, karen cady-pereira, ! -! patrick d. brown, ronald e. farren, luke chen, robert bergstrom. ! -! ! -! ************************************************************************ ! -! ! -! references: ! -! (rrtm_lw/rrtmg_lw): ! -! clough, s.A., m.w. shephard, e.j. mlawer, j.s. delamere, ! -! m.j. iacono, k. cady-pereira, s. boukabara, and p.d. brown: ! -! atmospheric radiative transfer modeling: a summary of the aer ! -! codes, j. quant. spectrosc. radiat. transfer, 91, 233-244, 2005. ! -! ! -! mlawer, e.j., s.j. taubman, p.d. brown, m.j. iacono, and s.a. ! -! clough: radiative transfer for inhomogeneous atmospheres: rrtm, ! -! a validated correlated-k model for the longwave. j. geophys. res., ! -! 102, 16663-16682, 1997. ! -! ! -! (mcica): ! -! pincus, r., h. w. barker, and j.-j. morcrette: a fast, flexible, ! -! approximation technique for computing radiative transfer in ! -! inhomogeneous cloud fields, j. geophys. res., 108(d13), 4376, ! -! doi:10.1029/2002JD003322, 2003. ! -! ! -! ************************************************************************ ! -! ! -! aer's revision history: ! -! this version of rrtmg_lw has been modified from rrtm_lw to use a ! -! reduced set of g-points for application to gcms. ! -! ! -! -- original version (derived from rrtm_lw), reduction of g-points, ! -! other revisions for use with gcms. ! -! 1999: m. j. iacono, aer, inc. ! -! -- adapted for use with ncar/cam3. ! -! may 2004: m. j. iacono, aer, inc. ! -! -- revised to add mcica capability. ! -! nov 2005: m. j. iacono, aer, inc. ! -! -- conversion to f90 formatting for consistency with rrtmg_sw. ! -! feb 2007: m. j. iacono, aer, inc. ! -! -- modifications to formatting to use assumed-shape arrays. ! -! aug 2007: m. j. iacono, aer, inc. ! -! ! -! ************************************************************************ ! -! ! -! ncep modifications history log: ! -! ! -! nov 1999, ken campana -- received the original code from ! -! aer (1998 ncar ccm version), updated to link up with ! -! ncep mrf model ! -! jun 2000, ken campana -- added option to switch random and ! -! maximum/random cloud overlap ! -! 2001, shrinivas moorthi -- further updates for mrf model ! -! may 2001, yu-tai hou -- updated on trace gases and cloud ! -! property based on rrtm_v3.0 codes. ! -! dec 2001, yu-tai hou -- rewritten code into fortran 90 std ! -! set ncep radiation structure standard that contains ! -! three plug-in compatable fortran program files: ! -! 'radlw_param.f', 'radlw_datatb.f', 'radlw_main.f' ! -! fixed bugs in subprograms taugb14, taugb2, etc. added ! -! out-of-bounds protections. (a detailed note of ! -! up_to_date modifications/corrections by ncep was sent ! -! to aer in 2002) ! -! jun 2004, yu-tai hou -- added mike iacono's apr 2004 ! -! modification of variable diffusivity angles. ! -! apr 2005, yu-tai hou -- minor modifications on module ! -! structures include rain/snow effect (this version of ! -! code was given back to aer in jun 2006) ! -! mar 2007, yu-tai hou -- added aerosol effect for ncep ! -! models using the generallized aerosol optical property! -! scheme for gfs model. ! -! apr 2007, yu-tai hou -- added spectral band heating as an ! -! optional output to support the 500 km gfs model's ! -! upper stratospheric radiation calculations. and ! -! restructure optional outputs for easy access by ! -! different models. ! -! oct 2008, yu-tai hou -- modified to include new features ! -! from aer's newer release v4.4-v4.7, including the ! -! mcica sub-grid cloud option. add rain/snow optical ! -! properties support to cloudy sky calculations. ! -! correct errors in mcica cloud optical properties for ! -! ebert & curry scheme (ilwcice=1) that needs band ! -! index conversion. simplified and unified sw and lw ! -! sub-column cloud subroutines into one module by using ! -! optional parameters. ! -! mar 2009, yu-tai hou -- replaced the original random number! -! generator coming from the original code with ncep w3 ! -! library to simplify the program and moved sub-column ! -! cloud subroutines inside the main module. added ! -! option of user provided permutation seeds that could ! -! be randomly generated from forecast time stamp. ! -! oct 2009, yu-tai hou -- modified subrtines "cldprop" and ! -! "rlwinit" according updats from aer's rrtmg_lw v4.8. ! -! nov 2009, yu-tai hou -- modified subrtine "taumol" according -! updats from aer's rrtmg_lw version 4.82. notice the ! -! cloud ice/liquid are assumed as in-cloud quantities, ! -! not as grid averaged quantities. ! -! jun 2010, yu-tai hou -- optimized code to improve efficiency -! apr 2012, b. ferrier and y. hou -- added conversion factor to fu's! -! cloud-snow optical property scheme. ! -! nov 2012, yu-tai hou -- modified control parameters thru ! -! module 'physparam'. ! -! FEB 2017 A.Cheng - add odpth output, effective radius input ! -! jun 2018, h-m lin/y-t hou -- added new option of cloud overlap ! -! method 'de-correlation-length' for mcica application ! -! ! -!!!!! ============================================================== !!!!! -!!!!! end descriptions !!!!! -!!!!! ============================================================== !!!!! - -!> This module contains the CCPP-compliant NCEP's modifications of the -!! rrtm-lw radiation code from aer inc. - module rrtmg_lw -! - use physparam, only : ilwrate, ilwrgas, ilwcliq, ilwcice, & - & isubclw, icldflg, iovrlw, ivflip -!mz & kind_phys - use physcons, only : con_g, con_cp, con_avgd, con_amd, & - & con_amw, con_amo3 - use mersenne_twister, only : random_setseed, random_number, & - & random_stat -!mz - use machine, only : kind_phys, & - & im => kind_io4, rb => kind_phys - - use module_radlw_parameters -! - use module_radlw_avplank, only : totplnk - use module_radlw_ref, only : preflog, tref, chi_mls -! - implicit none -! - private -! -! ... version tag and last revision date - character(40), parameter :: & - & VTAGLW='NCEP LW v5.1 Nov 2012 -RRTMG-LW v4.82 ' -! & VTAGLW='NCEP LW v5.0 Aug 2012 -RRTMG-LW v4.82 ' -! & VTAGLW='RRTMG-LW v4.82 Nov 2009 ' -! & VTAGLW='RRTMG-LW v4.8 Oct 2009 ' -! & VTAGLW='RRTMG-LW v4.71 Mar 2009 ' -! & VTAGLW='RRTMG-LW v4.4 Oct 2008 ' -! & VTAGLW='RRTM-LW v2.3g Mar 2007 ' -! & VTAGLW='RRTM-LW v2.3g Apr 2004 ' - -! --- constant values - real (kind=kind_phys), parameter :: eps = 1.0e-6 - real (kind=kind_phys), parameter :: oneminus= 1.0-eps - real (kind=kind_phys), parameter :: cldmin = tiny(cldmin) - real (kind=kind_phys), parameter :: bpade = 1.0/0.278 ! pade approx constant - real (kind=kind_phys), parameter :: stpfac = 296.0/1013.0 - real (kind=kind_phys), parameter :: wtdiff = 0.5 ! weight for radiance to flux conversion - real (kind=kind_phys), parameter :: tblint = ntbl ! lookup table conversion factor - real (kind=kind_phys), parameter :: f_zero = 0.0 - real (kind=kind_phys), parameter :: f_one = 1.0 - -! ... atomic weights for conversion from mass to volume mixing ratios - real (kind=kind_phys), parameter :: amdw = con_amd/con_amw - real (kind=kind_phys), parameter :: amdo3 = con_amd/con_amo3 - -! ... band indices - integer, dimension(nbands) :: nspa, nspb - - data nspa / 1, 1, 9, 9, 9, 1, 9, 1, 9, 1, 1, 9, 9, 1, 9, 9 / - data nspb / 1, 1, 5, 5, 5, 0, 1, 1, 1, 1, 1, 0, 0, 1, 0, 0 / - -! ... band wavenumber intervals -! real (kind=kind_phys) :: wavenum1(nbands), wavenum2(nbands) -! data wavenum1/ & -! & 10., 350., 500., 630., 700., 820., 980., 1080., & -!err & 1180., 1390., 1480., 1800., 2080., 2250., 2390., 2600. / -! & 1180., 1390., 1480., 1800., 2080., 2250., 2380., 2600. / -! data wavenum2/ & -! & 350., 500., 630., 700., 820., 980., 1080., 1180., & -!err & 1390., 1480., 1800., 2080., 2250., 2390., 2600., 3250. / -! & 1390., 1480., 1800., 2080., 2250., 2380., 2600., 3250. / -! real (kind=kind_phys) :: delwave(nbands) -! data delwave / 340., 150., 130., 70., 120., 160., 100., 100., & -! & 210., 90., 320., 280., 170., 130., 220., 650. / - -! --- reset diffusivity angle for Bands 2-3 and 5-9 to vary (between 1.50 -! and 1.80) as a function of total column water vapor. the function -! has been defined to minimize flux and cooling rate errors in these bands -! over a wide range of precipitable water values. - real (kind=kind_phys), dimension(nbands) :: a0, a1, a2 - - data a0 / 1.66, 1.55, 1.58, 1.66, 1.54, 1.454, 1.89, 1.33, & - & 1.668, 1.66, 1.66, 1.66, 1.66, 1.66, 1.66, 1.66 / - data a1 / 0.00, 0.25, 0.22, 0.00, 0.13, 0.446, -0.10, 0.40, & - & -0.006, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / - data a2 / 0.00, -12.0, -11.7, 0.00, -0.72,-0.243, 0.19,-0.062, & - & 0.414, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / - -!! --- logical flags for optional output fields - - logical :: lhlwb = .false. - logical :: lhlw0 = .false. - logical :: lflxprf= .false. - -! --- those data will be set up only once by "rlwinit" - -! ... fluxfac, heatfac are factors for fluxes (in w/m**2) and heating -! rates (in k/day, or k/sec set by subroutine 'rlwinit') -! semiss0 are default surface emissivity for each bands - - real (kind=kind_phys) :: fluxfac, heatfac, semiss0(nbands) - data semiss0(:) / nbands*1.0 / - - real (kind=kind_phys) :: tau_tbl(0:ntbl) !< clr-sky opt dep (for cldy transfer) - real (kind=kind_phys) :: exp_tbl(0:ntbl) !< transmittance lookup table - real (kind=kind_phys) :: tfn_tbl(0:ntbl) !< tau transition function; i.e. the - !< transition of planck func from mean lyr - !< temp to lyr boundary temp as a func of - !< opt dep. "linear in tau" method is used. - -! --- the following variables are used for sub-column cloud scheme - - integer, parameter :: ipsdlw0 = ngptlw ! initial permutation seed - -! --- public accessable subprograms - - public rrtmg_lw_init, rrtmg_lw_run, rrtmg_lw_finalize, rlwinit - - -! ================ - contains -! ================ - - subroutine rrtmg_lw_init () - end subroutine rrtmg_lw_init - -!> \defgroup module_radlw_main GFS RRTMG Longwave Module -!! \brief This module includes NCEP's modifications of the RRTMG-LW radiation -!! code from AER. -!! -!! The RRTM-LW package includes three files: -!! - radlw_param.f, which contains: -!! - module_radlw_parameters: band parameters set up -!! - radlw_datatb.f, which contains modules: -!! - module_radlw_avplank: plank flux data -!! - module_radlw_ref: reference temperature and pressure -!! - module_radlw_cldprlw: cloud property coefficients -!! - module_radlw_kgbnn: absorption coeffients for 16 bands, where nn = 01-16 -!! - radlw_main.f, which contains: -!! - rrtmg_lw_run(): the main LW radiation routine -!! - rlwinit(): the initialization routine -!! -!!\version NCEP LW v5.1 Nov 2012 -RRTMG-LW v4.82 -!! -!!\copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). -!! This software may be used, copied, or redistributed as long as it is -!! not sold and this copyright notice is reproduced on each copy made. -!! This model is provided as is without any express or implied warranties. -!! (http://www.rtweb.aer.com/) -!! \section arg_table_rrtmg_lw_run Argument Table -!! \htmlinclude rrtmg_lw_run.html -!! -!> \section gen_lwrad RRTMG Longwave Radiation Scheme General Algorithm -!> @{ - subroutine rrtmg_lw_run & - & ( plyr,plvl,tlyr,tlvl,qlyr,olyr,gasvmr_co2, gasvmr_n2o, & ! --- inputs - & gasvmr_ch4, gasvmr_o2, gasvmr_co, gasvmr_cfc11, & - & gasvmr_cfc12, gasvmr_cfc22, gasvmr_ccl4, & - & icseed,aeraod,aerssa,sfemis,sfgtmp, & - & dzlyr,delpin,de_lgth, & - & npts, nlay, nlp1, lprnt, cld_cf, lslwr, & - & hlwc,topflx,sfcflx,cldtau, & ! --- outputs - & HLW0,HLWB,FLXPRF, & ! --- optional - & cld_lwp, cld_ref_liq, cld_iwp, cld_ref_ice, & - & cld_rwp,cld_ref_rain, cld_swp, cld_ref_snow, & - & cld_od, errmsg, errflg & - & ) - -! ==================== defination of variables ==================== ! -! ! -! input variables: ! -! plyr (npts,nlay) : layer mean pressures (mb) ! -! plvl (npts,nlp1) : interface pressures (mb) ! -! tlyr (npts,nlay) : layer mean temperature (k) ! -! tlvl (npts,nlp1) : interface temperatures (k) ! -! qlyr (npts,nlay) : layer specific humidity (gm/gm) *see inside ! -! olyr (npts,nlay) : layer ozone concentration (gm/gm) *see inside ! -! gasvmr(npts,nlay,:): atmospheric gases amount: ! -! (check module_radiation_gases for definition) ! -! gasvmr(:,:,1) - co2 volume mixing ratio ! -! gasvmr(:,:,2) - n2o volume mixing ratio ! -! gasvmr(:,:,3) - ch4 volume mixing ratio ! -! gasvmr(:,:,4) - o2 volume mixing ratio ! -! gasvmr(:,:,5) - co volume mixing ratio ! -! gasvmr(:,:,6) - cfc11 volume mixing ratio ! -! gasvmr(:,:,7) - cfc12 volume mixing ratio ! -! gasvmr(:,:,8) - cfc22 volume mixing ratio ! -! gasvmr(:,:,9) - ccl4 volume mixing ratio ! -! clouds(npts,nlay,:): layer cloud profiles: ! -! (check module_radiation_clouds for definition) ! -! clouds(:,:,1) - layer total cloud fraction ! -! clouds(:,:,2) - layer in-cloud liq water path (g/m**2) ! -! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! -! clouds(:,:,4) - layer in-cloud ice water path (g/m**2) ! -! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! -! clouds(:,:,6) - layer rain drop water path (g/m**2) ! -! clouds(:,:,7) - mean eff radius for rain drop (micron) ! -! clouds(:,:,8) - layer snow flake water path (g/m**2) ! -! clouds(:,:,9) - mean eff radius for snow flake (micron) ! -! icseed(npts) : auxiliary special cloud related array ! -! when module variable isubclw=2, it provides ! -! permutation seed for each column profile that ! -! are used for generating random numbers. ! -! when isubclw /=2, it will not be used. ! -! aerosols(npts,nlay,nbands,:) : aerosol optical properties ! -! (check module_radiation_aerosols for definition)! -! (:,:,:,1) - optical depth ! -! (:,:,:,2) - single scattering albedo ! -! (:,:,:,3) - asymmetry parameter ! -! sfemis (npts) : surface emissivity ! -! sfgtmp (npts) : surface ground temperature (k) ! -! dzlyr(npts,nlay) : layer thickness (km) ! -! delpin(npts,nlay): layer pressure thickness (mb) ! -! de_lgth(npts) : cloud decorrelation length (km) ! -! npts : total number of horizontal points ! -! nlay, nlp1 : total number of vertical layers, levels ! -! lprnt : cntl flag for diagnostic print out ! -! ! -! output variables: ! -! hlwc (npts,nlay): total sky heating rate (k/day or k/sec) ! -! topflx(npts) : radiation fluxes at top, component: ! -! (check module_radlw_paramters for definition) ! -! upfxc - total sky upward flux at top (w/m2) ! -! upfx0 - clear sky upward flux at top (w/m2) ! -! sfcflx(npts) : radiation fluxes at sfc, component: ! -! (check module_radlw_paramters for definition) ! -! upfxc - total sky upward flux at sfc (w/m2) ! -! upfx0 - clear sky upward flux at sfc (w/m2) ! -! dnfxc - total sky downward flux at sfc (w/m2) ! -! dnfx0 - clear sky downward flux at sfc (w/m2) ! -! cldtau(npts,nlay): approx 10mu band layer cloud optical depth ! -! ! -!! optional output variables: ! -! hlwb(npts,nlay,nbands): spectral band total sky heating rates ! -! hlw0 (npts,nlay): clear sky heating rate (k/day or k/sec) ! -! flxprf(npts,nlp1): level radiative fluxes (w/m2), components: ! -! (check module_radlw_paramters for definition) ! -! upfxc - total sky upward flux ! -! dnfxc - total sky dnward flux ! -! upfx0 - clear sky upward flux ! -! dnfx0 - clear sky dnward flux ! -! ! -! external module variables: (in physparam) ! -! ilwrgas - control flag for rare gases (ch4,n2o,o2,cfcs, etc.) ! -! =0: do not include rare gases ! -! >0: include all rare gases ! -! ilwcliq - control flag for liq-cloud optical properties ! -! =1: input cld liqp & reliq, hu & stamnes (1993) ! -! =2: not used ! -! ilwcice - control flag for ice-cloud optical properties ! -! =1: input cld icep & reice, ebert & curry (1997) ! -! =2: input cld icep & reice, streamer (1996) ! -! =3: input cld icep & reice, fu (1998) ! -! isubclw - sub-column cloud approximation control flag ! -! =0: no sub-col cld treatment, use grid-mean cld quantities ! -! =1: mcica sub-col, prescribed seeds to get random numbers ! -! =2: mcica sub-col, providing array icseed for random numbers! -! iovrlw - cloud overlapping control flag ! -! =0: random overlapping clouds ! -! =1: maximum/random overlapping clouds ! -! =2: maximum overlap cloud (used for isubclw>0 only) ! -! =3: decorrelation-length overlap (for isubclw>0 only) ! -! ivflip - control flag for vertical index direction ! -! =0: vertical index from toa to surface ! -! =1: vertical index from surface to toa ! -! ! -! module parameters, control variables: ! -! nbands - number of longwave spectral bands ! -! maxgas - maximum number of absorbing gaseous ! -! maxxsec - maximum number of cross-sections ! -! ngptlw - total number of g-point subintervals ! -! ng## - number of g-points in band (##=1-16) ! -! ngb(ngptlw) - band indices for each g-point ! -! bpade - pade approximation constant (1/0.278) ! -! nspa,nspb(nbands)- number of lower/upper ref atm's per band ! -! delwave(nbands) - longwave band width (wavenumbers) ! -! ipsdlw0 - permutation seed for mcica sub-col clds ! -! ! -! major local variables: ! -! pavel (nlay) - layer pressures (mb) ! -! delp (nlay) - layer pressure thickness (mb) ! -! tavel (nlay) - layer temperatures (k) ! -! tz (0:nlay) - level (interface) temperatures (k) ! -! semiss (nbands) - surface emissivity for each band ! -! wx (nlay,maxxsec) - cross-section molecules concentration ! -! coldry (nlay) - dry air column amount ! -! (1.e-20*molecules/cm**2) ! -! cldfrc (0:nlp1) - layer cloud fraction ! -! taucld (nbands,nlay) - layer cloud optical depth for each band ! -! cldfmc (ngptlw,nlay) - layer cloud fraction for each g-point ! -! tauaer (nbands,nlay) - aerosol optical depths ! -! fracs (ngptlw,nlay) - planck fractions ! -! tautot (ngptlw,nlay) - total optical depths (gaseous+aerosols) ! -! colamt (nlay,maxgas) - column amounts of absorbing gases ! -! 1-maxgas are for watervapor, carbon ! -! dioxide, ozone, nitrous oxide, methane, ! -! oxigen, carbon monoxide, respectively ! -! (molecules/cm**2) ! -! pwvcm - column precipitable water vapor (cm) ! -! secdiff(nbands) - variable diffusivity angle defined as ! -! an exponential function of the column ! -! water amount in bands 2-3 and 5-9. ! -! this reduces the bias of several w/m2 in ! -! downward surface flux in high water ! -! profiles caused by using the constant ! -! diffusivity angle of 1.66. (mji) ! -! facij (nlay) - indicator of interpolation factors ! -! =0/1: indicate lower/higher temp & height ! -! selffac(nlay) - scale factor for self-continuum, equals ! -! (w.v. density)/(atm density at 296K,1013 mb) ! -! selffrac(nlay) - factor for temp interpolation of ref ! -! self-continuum data ! -! indself(nlay) - index of the lower two appropriate ref ! -! temp for the self-continuum interpolation ! -! forfac (nlay) - scale factor for w.v. foreign-continuum ! -! forfrac(nlay) - factor for temp interpolation of ref ! -! w.v. foreign-continuum data ! -! indfor (nlay) - index of the lower two appropriate ref ! -! temp for the foreign-continuum interp ! -! laytrop - tropopause layer index at which switch is ! -! made from one conbination kew species to ! -! another. ! -! jp(nlay),jt(nlay),jt1(nlay) ! -! - lookup table indexes ! -! totuflux(0:nlay) - total-sky upward longwave flux (w/m2) ! -! totdflux(0:nlay) - total-sky downward longwave flux (w/m2) ! -! htr(nlay) - total-sky heating rate (k/day or k/sec) ! -! totuclfl(0:nlay) - clear-sky upward longwave flux (w/m2) ! -! totdclfl(0:nlay) - clear-sky downward longwave flux (w/m2) ! -! htrcl(nlay) - clear-sky heating rate (k/day or k/sec) ! -! fnet (0:nlay) - net longwave flux (w/m2) ! -! fnetc (0:nlay) - clear-sky net longwave flux (w/m2) ! -! ! -! ! -! ====================== end of definitions =================== ! - -! --- inputs: - integer, intent(in) :: npts, nlay, nlp1 - integer, intent(in) :: icseed(npts) - - logical, intent(in) :: lprnt - - real (kind=kind_phys), dimension(npts,nlp1), intent(in) :: plvl, & - & tlvl - real (kind=kind_phys), dimension(npts,nlay), intent(in) :: plyr, & - & tlyr, qlyr, olyr, dzlyr, delpin - - real (kind=kind_phys),dimension(npts,nlay),intent(in)::gasvmr_co2,& - & gasvmr_n2o, gasvmr_ch4, gasvmr_o2, gasvmr_co, gasvmr_cfc11, & - & gasvmr_cfc12, gasvmr_cfc22, gasvmr_ccl4 - - real (kind=kind_phys), dimension(npts,nlay),intent(in):: cld_cf - real (kind=kind_phys), dimension(npts,nlay),intent(in),optional:: & - & cld_lwp, cld_ref_liq, cld_iwp, cld_ref_ice, & - & cld_rwp, cld_ref_rain, cld_swp, cld_ref_snow, & - & cld_od - - real (kind=kind_phys), dimension(npts), intent(in) :: sfemis, & - & sfgtmp, de_lgth - - real (kind=kind_phys), dimension(npts,nlay,nbands),intent(in):: & - & aeraod, aerssa - -!mz* HWRF -- INPUT from mcica_subcol_lw - real(kind=kind_phys),dimension(ngptlw,npts,nlay) :: cldfmcl ! Cloud fraction - ! Dimensions: (ngptlw,ncol,nlay) -! real(kind=rb), intent(in) :: ciwpmcl(:,:,:) ! In-cloud ice water path (g/m2) -! ! Dimensions: (ngptlw,ncol,nlay) -! real(kind=rb), intent(in) :: clwpmcl(:,:,:) ! In-cloud liquid water path (g/m2) -! ! Dimensions: (ngptlw,ncol,nlay) -! real(kind=rb), intent(in) :: cswpmcl(:,:,:) ! In-cloud snow water path (g/m2) -! ! Dimensions: (ngptlw,ncol,nlay) -! real(kind=rb), intent(in) :: relqmcl(:,:) ! Cloud water drop effective radius (microns) -! ! Dimensions: (ncol,nlay) -! real(kind=rb), intent(in) :: reicmcl(:,:) ! Cloud ice effective size (microns) -! ! Dimensions: (ncol,nlay) -! real(kind=rb), intent(in) :: resnmcl(:,:) ! Snow effective size (microns) -! ! Dimensions: (ncol,nlay) -! real(kind=rb), intent(in) :: taucmcl(:,:,:) ! In-cloud optical depth -! ! Dimensions: (ngptlw,ncol,nlay) -! real(kind=rb), intent(in) :: tauaer(:,:,:) ! Aerosol optical depth -! ! Dimensions: (ncol,nlay,nbndlw) - -!mz - -! --- outputs: - real (kind=kind_phys), dimension(npts,nlay), intent(inout) :: hlwc - real (kind=kind_phys), dimension(npts,nlay), intent(inout) :: & - & cldtau - - type (topflw_type), dimension(npts), intent(inout) :: topflx - type (sfcflw_type), dimension(npts), intent(inout) :: sfcflx - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - -!! --- optional outputs: - real (kind=kind_phys), dimension(npts,nlay,nbands),optional, & - & intent(inout) :: hlwb - real (kind=kind_phys), dimension(npts,nlay), optional, & - & intent(inout) :: hlw0 - type (proflw_type), dimension(npts,nlp1), optional, & - & intent(inout) :: flxprf - logical, intent(in) :: lslwr - -! --- locals: -! mz* - Add height of each layer for exponential-random cloud overlap -! This will be derived below from the dzlyr in each layer - real (kind=kind_phys), dimension( npts,nlay ) :: hgt - real (kind=kind_phys):: dzsum - - real (kind=kind_phys), dimension(0:nlp1) :: cldfrc - - real (kind=kind_phys), dimension(0:nlay) :: totuflux, totdflux, & - & totuclfl, totdclfl, tz - - real (kind=kind_phys), dimension(nlay) :: htr, htrcl - - real (kind=kind_phys), dimension(nlay) :: pavel, tavel, delp, & - & clwp, ciwp, relw, reiw, cda1, cda2, cda3, cda4, & - & coldry, colbrd, h2ovmr, o3vmr, fac00, fac01, fac10, fac11, & - & selffac, selffrac, forfac, forfrac, minorfrac, scaleminor, & - & scaleminorn2, temcol, dz - - real (kind=kind_phys), dimension(nbands,0:nlay) :: pklev, pklay - - real (kind=kind_phys), dimension(nlay,nbands) :: htrb - real (kind=kind_phys), dimension(nbands,nlay) :: taucld, tauaer - real (kind=kind_phys), dimension(nbands,1,nlay) :: taucld3 - real (kind=kind_phys), dimension(ngptlw,nlay) :: fracs, tautot, & - & cldfmc - - real (kind=kind_phys), dimension(nbands) :: semiss, secdiff - -! --- column amount of absorbing gases: -! (:,m) m = 1-h2o, 2-co2, 3-o3, 4-n2o, 5-ch4, 6-o2, 7-co - real (kind=kind_phys) :: colamt(nlay,maxgas) - -! --- column cfc cross-section amounts: -! (:,m) m = 1-ccl4, 2-cfc11, 3-cfc12, 4-cfc22 - real (kind=kind_phys) :: wx(nlay,maxxsec) - -! --- reference ratios of binary species parameter in lower atmosphere: -! (:,m,:) m = 1-h2o/co2, 2-h2o/o3, 3-h2o/n2o, 4-h2o/ch4, 5-n2o/co2, 6-o3/co2 - real (kind=kind_phys) :: rfrate(nlay,nrates,2) - - real (kind=kind_phys) :: tem0, tem1, tem2, pwvcm, summol, stemp, & - & delgth - - integer, dimension(npts) :: ipseed - integer, dimension(nlay) :: jp, jt, jt1, indself, indfor, indminor - integer :: laytrop, iplon, i, j, k, k1 - ! mz* added local arrays for RRTMG - integer :: irng, permuteseed,ig - integer :: inflglw, iceflglw, liqflglw - logical :: lcf1 - -! -!===> ... begin here -! - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - -!mz* -! For passing in cloud physical properties; cloud optics parameterized -! in RRTMG: - inflglw = 2 - iceflglw = 3 - liqflglw = 1 - -! - if (.not. lslwr) return - -! --- ... initialization - - lhlwb = present ( hlwb ) - lhlw0 = present ( hlw0 ) - lflxprf= present ( flxprf ) - - colamt(:,:) = f_zero - cldtau(:,:) = f_zero - -!! --- check for optional input arguments, depending on cloud method - if (ilwcliq > 0) then ! use prognostic cloud method - if ( .not.present(cld_lwp) .or. .not.present(cld_ref_liq) .or. & - & .not.present(cld_iwp) .or. .not.present(cld_ref_ice) .or. & - & .not.present(cld_rwp) .or. .not.present(cld_ref_rain) .or. & - & .not.present(cld_swp) .or. .not.present(cld_ref_snow)) then - write(errmsg,'(*(a))') & - & 'Logic error: ilwcliq>0 requires the following', & - & ' optional arguments to be present:', & - & ' cld_lwp, cld_ref_liq, cld_iwp, cld_ref_ice,', & - & ' cld_rwp, cld_ref_rain, cld_swp, cld_ref_snow' - errflg = 1 - return - end if - else ! use diagnostic cloud method - if ( .not.present(cld_od) ) then - write(errmsg,'(*(a))') & - & 'Logic error: ilwcliq<=0 requires the following', & - & ' optional argument to be present: cld_od' - errflg = 1 - return - end if - endif ! end if_ilwcliq - -!> -# Change random number seed value for each radiation invocation -!! (isubclw =1 or 2). - - if ( isubclw == 1 ) then ! advance prescribed permutation seed - do i = 1, npts - ipseed(i) = ipsdlw0 + i - enddo - elseif ( isubclw == 2 ) then ! use input array of permutaion seeds - do i = 1, npts - ipseed(i) = icseed(i) - enddo - endif - -! if ( lprnt ) then -! print *,' In rrtmg_lw, isubclw, ipsdlw0,ipseed =', & -! & isubclw, ipsdlw0, ipseed -! endif - -! --- ... loop over horizontal npts profiles - - lab_do_iplon : do iplon = 1, npts - -!> -# Read surface emissivity. - if (sfemis(iplon) > eps .and. sfemis(iplon) <= 1.0) then ! input surface emissivity - do j = 1, nbands - semiss(j) = sfemis(iplon) - enddo - else ! use default values - do j = 1, nbands - semiss(j) = semiss0(j) - enddo - endif - - stemp = sfgtmp(iplon) ! surface ground temp - if (iovrlw == 3) delgth= de_lgth(iplon) ! clouds decorr-length - -! mz*: HWRF practice - if (iovrlw == 4 ) then - - -!Add layer height needed for exponential (icld=4) and -! exponential-random (icld=5) overlap options - - !iplon = 1 - irng = 0 - permuteseed = 150 - -!mz* Derive height - dzsum =0.0 - do k = 1,nlay - hgt(iplon,k)= dzsum+0.5*dzlyr(iplon,k)*1000. !km->m - dzsum = dzsum+ dzlyr(iplon,k)*1000. - enddo - -! Zero out cloud optical properties here; not used when passing physical properties -! to radiation and taucld is calculated in radiation - do k = 1, nlay - do j = 1, nbands - taucld3(j,iplon,k) = 0.0 - enddo - enddo - - -! call mcica_subcol_lw(iplon, ncol, nlay, iovrlw, permuteseed, & -! & irng, play, hgt, & -! & cldfrac, ciwpth, clwpth, cswpth, rei, rel, res, & -! & taucld, & -! & cldfmcl, & !--output -! & ciwpmcl, clwpmcl, cswpmcl, reicmcl, relqmcl, & -! & resnmcl, taucmcl) - -!mz* calculate cldfmcl for mcica first, *temporary - call mcica_subcol_lw(1, iplon, nlay, iovrlw, permuteseed, & - & irng, plyr, hgt, & - & cld_cf, cld_iwp, cld_lwp,cld_swp, & - & cld_ref_ice, cld_ref_liq, & - & cld_ref_snow, taucld3, & - & cldfmcl ) !--output - - endif -!mz* end - -!> -# Prepare atmospheric profile for use in rrtm. -! the vertical index of internal array is from surface to top - -! --- ... molecular amounts are input or converted to volume mixing ratio -! and later then converted to molecular amount (molec/cm2) by the -! dry air column coldry (in molec/cm2) which is calculated from the -! layer pressure thickness (in mb), based on the hydrostatic equation -! --- ... and includes a correction to account for h2o in the layer. - - if (ivflip == 0) then ! input from toa to sfc - - tem1 = 100.0 * con_g - tem2 = 1.0e-20 * 1.0e3 * con_avgd - tz(0) = tlvl(iplon,nlp1) - - do k = 1, nlay - k1 = nlp1 - k - pavel(k)= plyr(iplon,k1) - delp(k) = delpin(iplon,k1) - tavel(k)= tlyr(iplon,k1) - tz(k) = tlvl(iplon,k1) - dz(k) = dzlyr(iplon,k1) - -!> -# Set absorber amount for h2o, co2, and o3. - -!test use -! h2ovmr(k)= max(f_zero,qlyr(iplon,k1)*amdw) ! input mass mixing ratio -! h2ovmr(k)= max(f_zero,qlyr(iplon,k1)) ! input vol mixing ratio -! o3vmr (k)= max(f_zero,olyr(iplon,k1)) ! input vol mixing ratio -!ncep model use - h2ovmr(k)= max(f_zero,qlyr(iplon,k1) & - & *amdw/(f_one-qlyr(iplon,k1))) ! input specific humidity - o3vmr (k)= max(f_zero,olyr(iplon,k1)*amdo3) ! input mass mixing ratio - -! --- ... tem0 is the molecular weight of moist air - tem0 = (f_one - h2ovmr(k))*con_amd + h2ovmr(k)*con_amw - coldry(k) = tem2*delp(k) / (tem1*tem0*(f_one+h2ovmr(k))) - temcol(k) = 1.0e-12 * coldry(k) - - colamt(k,1) = max(f_zero, coldry(k)*h2ovmr(k)) ! h2o - colamt(k,2) = max(temcol(k), coldry(k)*gasvmr_co2(iplon,k1)) ! co2 - colamt(k,3) = max(temcol(k), coldry(k)*o3vmr(k)) ! o3 - enddo - -!> -# Set up column amount for rare gases n2o,ch4,o2,co,ccl4,cf11,cf12, -!! cf22, convert from volume mixing ratio to molec/cm2 based on -!! coldry (scaled to 1.0e-20). - - if (ilwrgas > 0) then - do k = 1, nlay - k1 = nlp1 - k - colamt(k,4)=max(temcol(k), coldry(k)*gasvmr_n2o(iplon,k1)) ! n2o - colamt(k,5)=max(temcol(k), coldry(k)*gasvmr_ch4(iplon,k1)) ! ch4 - colamt(k,6)=max(f_zero, coldry(k)*gasvmr_o2(iplon,k1)) ! o2 - colamt(k,7)=max(f_zero, coldry(k)*gasvmr_co(iplon,k1)) ! co - - wx(k,1) = max( f_zero, coldry(k)*gasvmr_ccl4(iplon,k1) ) ! ccl4 - wx(k,2) = max( f_zero, coldry(k)*gasvmr_cfc11(iplon,k1) ) ! cf11 - wx(k,3) = max( f_zero, coldry(k)*gasvmr_cfc12(iplon,k1) ) ! cf12 - wx(k,4) = max( f_zero, coldry(k)*gasvmr_cfc22(iplon,k1) ) ! cf22 - enddo - else - do k = 1, nlay - colamt(k,4) = f_zero ! n2o - colamt(k,5) = f_zero ! ch4 - colamt(k,6) = f_zero ! o2 - colamt(k,7) = f_zero ! co - - wx(k,1) = f_zero - wx(k,2) = f_zero - wx(k,3) = f_zero - wx(k,4) = f_zero - enddo - endif - -!> -# Set aerosol optical properties. - - do k = 1, nlay - k1 = nlp1 - k - do j = 1, nbands - tauaer(j,k) = aeraod(iplon,k1,j) & - & * (f_one - aerssa(iplon,k1,j)) - enddo - enddo - -!> -# Read cloud optical properties. - if (ilwcliq > 0) then ! use prognostic cloud method -!mz: GFS operational - if (iovrlw .ne. 4 ) then - do k = 1, nlay - k1 = nlp1 - k - cldfrc(k)= cld_cf(iplon,k1) - clwp(k) = cld_lwp(iplon,k1) - relw(k) = cld_ref_liq(iplon,k1) - ciwp(k) = cld_iwp(iplon,k1) - reiw(k) = cld_ref_ice(iplon,k1) - !mz*: Limit upper bound of reice for Fu ice - !parameterization and convert from effective radius - !to generalized effective size (*1.0315; Fu, 1996) - if (iovrlw .eq. 4 .and. iceflglw.eq.3) then - reiw(k) = cld_ref_ice(iplon,k1) *1.0315 - reiw(k) = min(140.0, reiw(k)) - endif - cda1(k) = cld_rwp(iplon,k1) - cda2(k) = cld_ref_rain(iplon,k1) - cda3(k) = cld_swp(iplon,k1) - cda4(k) = cld_ref_snow(iplon,k1) - !mz - if (iovrlw .eq. 4 .and. inflglw .ne.5) then - cda3(k) = 0. - cda4(k) = 10. - endif - enddo - ! transfer - else if (iovrlw .eq. 4) then !mz HWRF - do k = 1, nlay - k1 = nlp1 - k - do ig = 1, ngptlw - cldfmc(ig,k) = cldfmcl(ig,iplon,k1) -!mz* not activate -! taucmc(ig,k) = taucmcl(ig,iplon,k1) -! ciwpmc(ig,k) = ciwpmcl(ig,iplon,k1) -! clwpmc(ig,k) = clwpmcl(ig,iplon,k1) -! cswpmc(ig,k) = cswpmcl(ig,iplon,k1) - enddo -! reicmc(k) = reicmcl(iplon,k1) -! relqmc(k) = relqmcl(iplon,k1) -! resnmc(k) = resnmcl(iplon,k1) - enddo - endif - else ! use diagnostic cloud method - do k = 1, nlay - k1 = nlp1 - k - cldfrc(k)= cld_cf(iplon,k1) - cda1(k) = cld_od(iplon,k1) - enddo - endif ! end if_ilwcliq - - cldfrc(0) = f_one ! padding value only - cldfrc(nlp1) = f_zero ! padding value only - -!> -# Compute precipitable water vapor for diffusivity angle adjustments. - - tem1 = f_zero - tem2 = f_zero - do k = 1, nlay - tem1 = tem1 + coldry(k) + colamt(k,1) - tem2 = tem2 + colamt(k,1) - enddo - - tem0 = 10.0 * tem2 / (amdw * tem1 * con_g) - pwvcm = tem0 * plvl(iplon,nlp1) - - else ! input from sfc to toa - - tem1 = 100.0 * con_g - tem2 = 1.0e-20 * 1.0e3 * con_avgd - tz(0) = tlvl(iplon,1) - - do k = 1, nlay - pavel(k)= plyr(iplon,k) - delp(k) = delpin(iplon,k) - tavel(k)= tlyr(iplon,k) - tz(k) = tlvl(iplon,k+1) - dz(k) = dzlyr(iplon,k) - -! --- ... set absorber amount -!test use -! h2ovmr(k)= max(f_zero,qlyr(iplon,k)*amdw) ! input mass mixing ratio -! h2ovmr(k)= max(f_zero,qlyr(iplon,k)) ! input vol mixing ratio -! o3vmr (k)= max(f_zero,olyr(iplon,k)) ! input vol mixing ratio -!ncep model use - h2ovmr(k)= max(f_zero,qlyr(iplon,k) & - & *amdw/(f_one-qlyr(iplon,k))) ! input specific humidity - o3vmr (k)= max(f_zero,olyr(iplon,k)*amdo3) ! input mass mixing ratio - -! --- ... tem0 is the molecular weight of moist air - tem0 = (f_one - h2ovmr(k))*con_amd + h2ovmr(k)*con_amw - coldry(k) = tem2*delp(k) / (tem1*tem0*(f_one+h2ovmr(k))) - temcol(k) = 1.0e-12 * coldry(k) - - colamt(k,1) = max(f_zero, coldry(k)*h2ovmr(k)) ! h2o - colamt(k,2) = max(temcol(k), coldry(k)*gasvmr_co2(iplon,k))! co2 - colamt(k,3) = max(temcol(k), coldry(k)*o3vmr(k)) ! o3 - enddo - -! --- ... set up col amount for rare gases, convert from volume mixing ratio -! to molec/cm2 based on coldry (scaled to 1.0e-20) - - if (ilwrgas > 0) then - do k = 1, nlay - colamt(k,4)=max(temcol(k), coldry(k)*gasvmr_n2o(iplon,k)) ! n2o - colamt(k,5)=max(temcol(k), coldry(k)*gasvmr_ch4(iplon,k)) ! ch4 - colamt(k,6)=max(f_zero, coldry(k)*gasvmr_o2(iplon,k)) ! o2 - colamt(k,7)=max(f_zero, coldry(k)*gasvmr_co(iplon,k)) ! co - - wx(k,1) = max( f_zero, coldry(k)*gasvmr_ccl4(iplon,k) ) ! ccl4 - wx(k,2) = max( f_zero, coldry(k)*gasvmr_cfc11(iplon,k) ) ! cf11 - wx(k,3) = max( f_zero, coldry(k)*gasvmr_cfc12(iplon,k) ) ! cf12 - wx(k,4) = max( f_zero, coldry(k)*gasvmr_cfc22(iplon,k) ) ! cf22 - enddo - else - do k = 1, nlay - colamt(k,4) = f_zero ! n2o - colamt(k,5) = f_zero ! ch4 - colamt(k,6) = f_zero ! o2 - colamt(k,7) = f_zero ! co - - wx(k,1) = f_zero - wx(k,2) = f_zero - wx(k,3) = f_zero - wx(k,4) = f_zero - enddo - endif - -! --- ... set aerosol optical properties - - do j = 1, nbands - do k = 1, nlay - tauaer(j,k) = aeraod(iplon,k,j) & - & * (f_one - aerssa(iplon,k,j)) - enddo - enddo - - if (ilwcliq > 0) then ! use prognostic cloud method -!mz* - if (iovrlw .ne. 4) then - do k = 1, nlay - cldfrc(k)= cld_cf(iplon,k) - clwp(k) = cld_lwp(iplon,k) - relw(k) = cld_ref_liq(iplon,k) - ciwp(k) = cld_iwp(iplon,k) - reiw(k) = cld_ref_ice(iplon,k) - !mz*: Limit upper bound of reice for Fu ice - !parameterization and convert from effective radius - !to generalized effective size (*1.0315; Fu, 1996) - if (iovrlw .eq. 4 .and. iceflglw.eq.3) then - reiw(k) = cld_ref_ice(iplon,k1) *1.0315 - reiw(k) = min(140.0, reiw(k)) - endif - cda1(k) = cld_rwp(iplon,k) - cda2(k) = cld_ref_rain(iplon,k) - cda3(k) = cld_swp(iplon,k) - cda4(k) = cld_ref_snow(iplon,k) - !mz* - if (iovrlw .eq. 4 .and. inflglw .ne.5) then - cda3(k) = 0. - cda4(k) = 10. - endif - enddo - else if (iovrlw .eq. 4) then - do k = 1, nlay - do ig = 1, ngptlw - cldfmc(ig,k) = cldfmcl(ig,iplon,k) -! taucmc(ig,k) = taucmcl(ig,iplon,k) -! ciwpmc(ig,k) = ciwpmcl(ig,iplon,k) -! clwpmc(ig,k) = clwpmcl(ig,iplon,k) -! cswpmc(ig,k) = cswpmcl(ig,iplon,k) - enddo -! reicmc(k) = reicmcl(iplon,k) -! relqmc(k) = relqmcl(iplon,k) -! resnmc(k) = resnmcl(iplon,k) - enddo - endif - else ! use diagnostic cloud method - do k = 1, nlay - cldfrc(k)= cld_cf(iplon,k) - cda1(k) = cld_od(iplon,k) - enddo - endif ! end if_ilwcliq - - cldfrc(0) = f_one ! padding value only - cldfrc(nlp1) = f_zero ! padding value only - -! --- ... compute precipitable water vapor for diffusivity angle adjustments - - tem1 = f_zero - tem2 = f_zero - do k = 1, nlay - tem1 = tem1 + coldry(k) + colamt(k,1) - tem2 = tem2 + colamt(k,1) - enddo - - tem0 = 10.0 * tem2 / (amdw * tem1 * con_g) - pwvcm = tem0 * plvl(iplon,1) - - endif ! if_ivflip - -!> -# Compute column amount for broadening gases. - - do k = 1, nlay - summol = f_zero - do i = 2, maxgas - summol = summol + colamt(k,i) - enddo - colbrd(k) = coldry(k) - summol - enddo - -!> -# Compute diffusivity angle adjustments. - - tem1 = 1.80 - tem2 = 1.50 - do j = 1, nbands - if (j==1 .or. j==4 .or. j==10) then - secdiff(j) = 1.66 - else - secdiff(j) = min( tem1, max( tem2, & - & a0(j)+a1(j)*exp(a2(j)*pwvcm) )) - endif - enddo - -! if (lprnt) then -! print *,' coldry',coldry -! print *,' wx(*,1) ',(wx(k,1),k=1,NLAY) -! print *,' wx(*,2) ',(wx(k,2),k=1,NLAY) -! print *,' wx(*,3) ',(wx(k,3),k=1,NLAY) -! print *,' wx(*,4) ',(wx(k,4),k=1,NLAY) -! print *,' iplon ',iplon -! print *,' pavel ',pavel -! print *,' delp ',delp -! print *,' tavel ',tavel -! print *,' tz ',tz -! print *,' h2ovmr ',h2ovmr -! print *,' o3vmr ',o3vmr -! endif - -!> -# For cloudy atmosphere, call cldprop() to set cloud optical -!! properties. - -!mz* - if (iovrlw .ne. 4 ) then !mz:GFS oprational - - lcf1 = .false. - lab_do_k0 : do k = 1, nlay - if ( cldfrc(k) > eps ) then - lcf1 = .true. - exit lab_do_k0 - endif - enddo lab_do_k0 - - if ( lcf1 ) then - - call cldprop & -! --- inputs: - & ( cldfrc,clwp,relw,ciwp,reiw,cda1,cda2,cda3,cda4, & - & nlay, nlp1, ipseed(iplon), dz, delgth, & -! --- outputs: - & cldfmc, taucld & - & ) - -! --- ... save computed layer cloud optical depth for output -! rrtm band-7 is apprx 10mu channel (or use spectral mean of bands 6-8) - - if (ivflip == 0) then ! input from toa to sfc - do k = 1, nlay - k1 = nlp1 - k - cldtau(iplon,k1) = taucld( 7,k) - enddo - else ! input from sfc to toa - do k = 1, nlay - cldtau(iplon,k) = taucld( 7,k) - enddo - endif ! end if_ivflip_block - - else - cldfmc = f_zero - taucld = f_zero - endif - endif !mz iovrlw.ne.4 - -! else if (iovrlw .eq. 4) then !mz*:HWRF for cldovrlp=4 - -!mz* call CLDPRMC to set cloud optical depth for McICA based on input cloud -! properties (inflglw) - -! For cloudy atmosphere, use cldprop to set cloud optical properties based on -! input cloud physical properties. Select method based on choices described -! in cldprop. Cloud fraction, water path, liquid droplet and ice particle -! effective radius must be passed into cldprop. Cloud fraction and cloud -! optical depth are transferred to rrtmg_lw arrays in cldprop. -! -! ncbands(im): number of cloud spectral bands -! taucmc(ngptlw,nlayers): cloud optical depth [mcica] - -! call cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, ciwpmc,& -! clwpmc, cswpmc, reicmc, relqmc, resnmc, & -! ncbands, taucmc) - - -! if (lprnt) then -! print *,' after cldprop' -! print *,' clwp',clwp -! print *,' ciwp',ciwp -! print *,' relw',relw -! print *,' reiw',reiw -! print *,' taucl',cda1 -! print *,' cldfrac',cldfrc -! endif - -!> -# Calling setcoef() to compute various coefficients needed in -!! radiative transfer calculations. - call setcoef & -! --- inputs: - & ( pavel,tavel,tz,stemp,h2ovmr,colamt,coldry,colbrd, & - & nlay, nlp1, & -! --- outputs: - & laytrop,pklay,pklev,jp,jt,jt1, & - & rfrate,fac00,fac01,fac10,fac11, & - & selffac,selffrac,indself,forfac,forfrac,indfor, & - & minorfrac,scaleminor,scaleminorn2,indminor & - & ) - -! if (lprnt) then -! print *,'laytrop',laytrop -! print *,'colh2o',(colamt(k,1),k=1,NLAY) -! print *,'colco2',(colamt(k,2),k=1,NLAY) -! print *,'colo3', (colamt(k,3),k=1,NLAY) -! print *,'coln2o',(colamt(k,4),k=1,NLAY) -! print *,'colch4',(colamt(k,5),k=1,NLAY) -! print *,'fac00',fac00 -! print *,'fac01',fac01 -! print *,'fac10',fac10 -! print *,'fac11',fac11 -! print *,'jp',jp -! print *,'jt',jt -! print *,'jt1',jt1 -! print *,'selffac',selffac -! print *,'selffrac',selffrac -! print *,'indself',indself -! print *,'forfac',forfac -! print *,'forfrac',forfrac -! print *,'indfor',indfor -! endif - -!> -# Call taumol() to calculte the gaseous optical depths and Plank -!! fractions for each longwave spectral band. - - call taumol & -! --- inputs: - & ( laytrop,pavel,coldry,colamt,colbrd,wx,tauaer, & - & rfrate,fac00,fac01,fac10,fac11,jp,jt,jt1, & - & selffac,selffrac,indself,forfac,forfrac,indfor, & - & minorfrac,scaleminor,scaleminorn2,indminor, & - & nlay, & -! --- outputs: - & fracs, tautot & - & ) - -! if (lprnt) then -! print *,' after taumol' -! do k = 1, nlay -! write(6,121) k -!121 format(' k =',i3,5x,'FRACS') -! write(6,122) (fracs(j,k),j=1,ngptlw) -!122 format(10e14.7) -! write(6,123) k -!123 format(' k =',i3,5x,'TAUTOT') -! write(6,122) (tautot(j,k),j=1,ngptlw) -! enddo -! endif - -!> -# Call the radiative transfer routine based on cloud scheme -!! selection. Compute the upward/downward radiative fluxes, and -!! heating rates for both clear or cloudy atmosphere. -!!\n - call rtrn(): clouds are assumed as randomly overlaping in a -!! vertical column -!!\n - call rtrnmr(): clouds are assumed as in maximum-randomly -!! overlaping in a vertical column; -!!\n - call rtrnmc(): clouds are treated with the mcica stochastic -!! approach. - - if (isubclw <= 0) then - - if (iovrlw <= 0) then - - call rtrn & -! --- inputs: - & ( semiss,delp,cldfrc,taucld,tautot,pklay,pklev, & - & fracs,secdiff,nlay,nlp1, & -! --- outputs: - & totuflux,totdflux,htr, totuclfl,totdclfl,htrcl, htrb & - & ) - - else - - call rtrnmr & -! --- inputs: - & ( semiss,delp,cldfrc,taucld,tautot,pklay,pklev, & - & fracs,secdiff,nlay,nlp1, & -! --- outputs: - & totuflux,totdflux,htr, totuclfl,totdclfl,htrcl, htrb & - & ) - - endif ! end if_iovrlw_block - - else - - call rtrnmc & -! --- inputs: - & ( semiss,delp,cldfmc,taucld,tautot,pklay,pklev, & - & fracs,secdiff,nlay,nlp1, & -! --- outputs: - & totuflux,totdflux,htr, totuclfl,totdclfl,htrcl, htrb & - & ) - - endif ! end if_isubclw_block - -!> -# Save outputs. - - topflx(iplon)%upfxc = totuflux(nlay) - topflx(iplon)%upfx0 = totuclfl(nlay) - - sfcflx(iplon)%upfxc = totuflux(0) - sfcflx(iplon)%upfx0 = totuclfl(0) - sfcflx(iplon)%dnfxc = totdflux(0) - sfcflx(iplon)%dnfx0 = totdclfl(0) - - if (ivflip == 0) then ! output from toa to sfc - -!! --- ... optional fluxes - if ( lflxprf ) then - do k = 0, nlay - k1 = nlp1 - k - flxprf(iplon,k1)%upfxc = totuflux(k) - flxprf(iplon,k1)%dnfxc = totdflux(k) - flxprf(iplon,k1)%upfx0 = totuclfl(k) - flxprf(iplon,k1)%dnfx0 = totdclfl(k) - enddo - endif - - do k = 1, nlay - k1 = nlp1 - k - hlwc(iplon,k1) = htr(k) - enddo - -!! --- ... optional clear sky heating rate - if ( lhlw0 ) then - do k = 1, nlay - k1 = nlp1 - k - hlw0(iplon,k1) = htrcl(k) - enddo - endif - -!! --- ... optional spectral band heating rate - if ( lhlwb ) then - do j = 1, nbands - do k = 1, nlay - k1 = nlp1 - k - hlwb(iplon,k1,j) = htrb(k,j) - enddo - enddo - endif - - else ! output from sfc to toa - -!! --- ... optional fluxes - if ( lflxprf ) then - do k = 0, nlay - flxprf(iplon,k+1)%upfxc = totuflux(k) - flxprf(iplon,k+1)%dnfxc = totdflux(k) - flxprf(iplon,k+1)%upfx0 = totuclfl(k) - flxprf(iplon,k+1)%dnfx0 = totdclfl(k) - enddo - endif - - do k = 1, nlay - hlwc(iplon,k) = htr(k) - enddo - -!! --- ... optional clear sky heating rate - if ( lhlw0 ) then - do k = 1, nlay - hlw0(iplon,k) = htrcl(k) - enddo - endif - -!! --- ... optional spectral band heating rate - if ( lhlwb ) then - do j = 1, nbands - do k = 1, nlay - hlwb(iplon,k,j) = htrb(k,j) - enddo - enddo - endif - - endif ! if_ivflip - - enddo lab_do_iplon - -!................................... - end subroutine rrtmg_lw_run -!----------------------------------- -!> @} - subroutine rrtmg_lw_finalize () - end subroutine rrtmg_lw_finalize - - - -!> \ingroup module_radlw_main -!> \brief This subroutine performs calculations necessary for the initialization -!! of the longwave model, which includes non-varying model variables, conversion -!! factors, and look-up tables -!! -!! Lookup tables are computed for use in the lw -!! radiative transfer, and input absorption coefficient data for each -!! spectral band are reduced from 256 g-point intervals to 140. -!!\param me print control for parallel process -!!\section rlwinit_gen rlwinit General Algorithm -!! @{ - subroutine rlwinit & - & ( me ) ! --- inputs -! --- outputs: (none) - -! =================== program usage description =================== ! -! ! -! purpose: initialize non-varying module variables, conversion factors,! -! and look-up tables. ! -! ! -! subprograms called: none ! -! ! -! ==================== defination of variables ==================== ! -! ! -! inputs: ! -! me - print control for parallel process ! -! ! -! outputs: (none) ! -! ! -! external module variables: (in physparam) ! -! ilwrate - heating rate unit selections ! -! =1: output in k/day ! -! =2: output in k/second ! -! ilwrgas - control flag for rare gases (ch4,n2o,o2,cfcs, etc.) ! -! =0: do not include rare gases ! -! >0: include all rare gases ! -! ilwcliq - liquid cloud optical properties contrl flag ! -! =0: input cloud opt depth from diagnostic scheme ! -! >0: input cwp,rew, and other cloud content parameters ! -! isubclw - sub-column cloud approximation control flag ! -! =0: no sub-col cld treatment, use grid-mean cld quantities ! -! =1: mcica sub-col, prescribed seeds to get random numbers ! -! =2: mcica sub-col, providing array icseed for random numbers! -! icldflg - cloud scheme control flag ! -! =0: diagnostic scheme gives cloud tau, omiga, and g. ! -! =1: prognostic scheme gives cloud liq/ice path, etc. ! -! iovrlw - clouds vertical overlapping control flag ! -! =0: random overlapping clouds ! -! =1: maximum/random overlapping clouds ! -! =2: maximum overlap cloud (isubcol>0 only) ! -! =3: decorrelation-length overlap (for isubclw>0 only) ! -! ! -! ******************************************************************* ! -! original code description ! -! ! -! original version: michael j. iacono; july, 1998 ! -! first revision for ncar ccm: september, 1998 ! -! second revision for rrtm_v3.0: september, 2002 ! -! ! -! this subroutine performs calculations necessary for the initialization -! of the longwave model. lookup tables are computed for use in the lw ! -! radiative transfer, and input absorption coefficient data for each ! -! spectral band are reduced from 256 g-point intervals to 140. ! -! ! -! ******************************************************************* ! -! ! -! definitions: ! -! arrays for 10000-point look-up tables: ! -! tau_tbl - clear-sky optical depth (used in cloudy radiative transfer! -! exp_tbl - exponential lookup table for tansmittance ! -! tfn_tbl - tau transition function; i.e. the transition of the Planck! -! function from that for the mean layer temperature to that ! -! for the layer boundary temperature as a function of optical -! depth. the "linear in tau" method is used to make the table -! ! -! ******************************************************************* ! -! ! -! ====================== end of description block ================= ! - -! --- inputs: - integer, intent(in) :: me - -! --- outputs: none - -! --- locals: - real (kind=kind_phys), parameter :: expeps = 1.e-20 - - real (kind=kind_phys) :: tfn, pival, explimit - - integer :: i - -! -!===> ... begin here -! - if ( iovrlw<0 .or. iovrlw>4 ) then - print *,' *** Error in specification of cloud overlap flag', & - & ' IOVRLW=',iovrlw,' in RLWINIT !!' - stop -!mz -! elseif ( iovrlw>=2 .and. isubclw==0 ) then - elseif ( (iovrlw.eq.2 .or. iovrlw.eq.3).and. isubclw==0 ) then - if (me == 0) then - print *,' *** IOVRLW=',iovrlw,' is not available for', & - & ' ISUBCLW=0 setting!!' - print *,' The program uses maximum/random overlap', & - & ' instead.' - endif - - iovrlw = 1 - endif - - if (me == 0) then - print *,' - Using AER Longwave Radiation, Version: ', VTAGLW - - if (ilwrgas > 0) then - print *,' --- Include rare gases N2O, CH4, O2, CFCs ', & - & 'absorptions in LW' - else - print *,' --- Rare gases effect is NOT included in LW' - endif - - if ( isubclw == 0 ) then - print *,' --- Using standard grid average clouds, no ', & - & 'sub-column clouds approximation applied' - elseif ( isubclw == 1 ) then - print *,' --- Using MCICA sub-colum clouds approximation ', & - & 'with a prescribed sequence of permutaion seeds' - elseif ( isubclw == 2 ) then - print *,' --- Using MCICA sub-colum clouds approximation ', & - & 'with provided input array of permutation seeds' - else - print *,' *** Error in specification of sub-column cloud ', & - & ' control flag isubclw =',isubclw,' !!' - stop - endif - endif - -!> -# Check cloud flags for consistency. - - if ((icldflg == 0 .and. ilwcliq /= 0) .or. & - & (icldflg == 1 .and. ilwcliq == 0)) then - print *,' *** Model cloud scheme inconsistent with LW', & - & ' radiation cloud radiative property setup !!' - stop - endif - -!> -# Setup default surface emissivity for each band. - - semiss0(:) = f_one - -!> -# Setup constant factors for flux and heating rate -!! the 1.0e-2 is to convert pressure from mb to \f$N/m^2\f$. - - pival = 2.0 * asin(f_one) - fluxfac = pival * 2.0d4 -! fluxfac = 62831.85307179586 ! = 2 * pi * 1.0e4 - - if (ilwrate == 1) then -! heatfac = 8.4391 -! heatfac = con_g * 86400. * 1.0e-2 / con_cp ! (in k/day) - heatfac = con_g * 864.0 / con_cp ! (in k/day) - else - heatfac = con_g * 1.0e-2 / con_cp ! (in k/second) - endif - -!> -# Compute lookup tables for transmittance, tau transition -!! function, and clear sky tau (for the cloudy sky radiative -!! transfer). tau is computed as a function of the tau -!! transition function, transmittance is calculated as a -!! function of tau, and the tau transition function is -!! calculated using the linear in tau formulation at values of -!! tau above 0.01. tf is approximated as tau/6 for tau < 0.01. -!! all tables are computed at intervals of 0.001. the inverse -!! of the constant used in the pade approximation to the tau -!! transition function is set to b. - - tau_tbl(0) = f_zero - exp_tbl(0) = f_one - tfn_tbl(0) = f_zero - - tau_tbl(ntbl) = 1.e10 - exp_tbl(ntbl) = expeps - tfn_tbl(ntbl) = f_one - - explimit = aint( -log(tiny(exp_tbl(0))) ) - - do i = 1, ntbl-1 -!org tfn = float(i) / float(ntbl) -!org tau_tbl(i) = bpade * tfn / (f_one - tfn) - tfn = real(i, kind_phys) / real(ntbl-i, kind_phys) - tau_tbl(i) = bpade * tfn - if (tau_tbl(i) >= explimit) then - exp_tbl(i) = expeps - else - exp_tbl(i) = exp( -tau_tbl(i) ) - endif - - if (tau_tbl(i) < 0.06) then - tfn_tbl(i) = tau_tbl(i) / 6.0 - else - tfn_tbl(i) = f_one - 2.0*( (f_one / tau_tbl(i)) & - & - ( exp_tbl(i) / (f_one - exp_tbl(i)) ) ) - endif - enddo - -!................................... - end subroutine rlwinit -!! @} -!----------------------------------- - - -!>\ingroup module_radlw_main -!> \brief This subroutine computes the cloud optical depth(s) for each cloudy -!! layer and g-point interval. -!!\param cfrac layer cloud fraction -!!\n --- for ilwcliq > 0 (prognostic cloud scheme) - - - -!!\param cliqp layer in-cloud liq water path (\f$g/m^2\f$) -!!\param reliq mean eff radius for liq cloud (micron) -!!\param cicep layer in-cloud ice water path (\f$g/m^2\f$) -!!\param reice mean eff radius for ice cloud (micron) -!!\param cdat1 layer rain drop water path (\f$g/m^2\f$) -!!\param cdat2 effective radius for rain drop (micron) -!!\param cdat3 layer snow flake water path(\f$g/m^2\f$) -!!\param cdat4 mean effective radius for snow flake(micron) -!!\n --- for ilwcliq = 0 (diagnostic cloud scheme) - - - -!!\param cliqp not used -!!\param cicep not used -!!\param reliq not used -!!\param reice not used -!!\param cdat1 layer cloud optical depth -!!\param cdat2 layer cloud single scattering albedo -!!\param cdat3 layer cloud asymmetry factor -!!\param cdat4 optional use -!!\param nlay number of layer number -!!\param nlp1 number of veritcal levels -!!\param ipseed permutation seed for generating random numbers (isubclw>0) -!!\param dz layer thickness (km) -!!\param de_lgth layer cloud decorrelation length (km) -!!\param cldfmc cloud fraction for each sub-column -!!\param taucld cloud optical depth for bands (non-mcica) -!!\section gen_cldprop cldprop General Algorithm -!> @{ - subroutine cldprop & - & ( cfrac,cliqp,reliq,cicep,reice,cdat1,cdat2,cdat3,cdat4, & ! --- inputs - & nlay, nlp1, ipseed, dz, de_lgth, & - & cldfmc, taucld & ! --- outputs - & ) - -! =================== program usage description =================== ! -! ! -! purpose: compute the cloud optical depth(s) for each cloudy layer ! -! and g-point interval. ! -! ! -! subprograms called: none ! -! ! -! ==================== defination of variables ==================== ! -! ! -! inputs: -size- ! -! cfrac - real, layer cloud fraction 0:nlp1 ! -! ..... for ilwcliq > 0 (prognostic cloud sckeme) - - - ! -! cliqp - real, layer in-cloud liq water path (g/m**2) nlay ! -! reliq - real, mean eff radius for liq cloud (micron) nlay ! -! cicep - real, layer in-cloud ice water path (g/m**2) nlay ! -! reice - real, mean eff radius for ice cloud (micron) nlay ! -! cdat1 - real, layer rain drop water path (g/m**2) nlay ! -! cdat2 - real, effective radius for rain drop (microm) nlay ! -! cdat3 - real, layer snow flake water path (g/m**2) nlay ! -! cdat4 - real, effective radius for snow flakes (micron) nlay ! -! ..... for ilwcliq = 0 (diagnostic cloud sckeme) - - - ! -! cdat1 - real, input cloud optical depth nlay ! -! cdat2 - real, layer cloud single scattering albedo nlay ! -! cdat3 - real, layer cloud asymmetry factor nlay ! -! cdat4 - real, optional use nlay ! -! cliqp - not used nlay ! -! reliq - not used nlay ! -! cicep - not used nlay ! -! reice - not used nlay ! -! ! -! dz - real, layer thickness (km) nlay ! -! de_lgth- real, layer cloud decorrelation length (km) 1 ! -! nlay - integer, number of vertical layers 1 ! -! nlp1 - integer, number of vertical levels 1 ! -! ipseed- permutation seed for generating random numbers (isubclw>0) ! -! ! -! outputs: ! -! cldfmc - real, cloud fraction for each sub-column ngptlw*nlay! -! taucld - real, cld opt depth for bands (non-mcica) nbands*nlay! -! ! -! explanation of the method for each value of ilwcliq, and ilwcice. ! -! set up in module "module_radlw_cntr_para" ! -! ! -! ilwcliq=0 : input cloud optical property (tau, ssa, asy). ! -! (used for diagnostic cloud method) ! -! ilwcliq>0 : input cloud liq/ice path and effective radius, also ! -! require the user of 'ilwcice' to specify the method ! -! used to compute aborption due to water/ice parts. ! -! ................................................................... ! -! ! -! ilwcliq=1: the water droplet effective radius (microns) is input! -! and the opt depths due to water clouds are computed ! -! as in hu and stamnes, j., clim., 6, 728-742, (1993). ! -! the values for absorption coefficients appropriate for -! the spectral bands in rrtm have been obtained for a ! -! range of effective radii by an averaging procedure ! -! based on the work of j. pinto (private communication). -! linear interpolation is used to get the absorption ! -! coefficients for the input effective radius. ! -! ! -! ilwcice=1: the cloud ice path (g/m2) and ice effective radius ! -! (microns) are input and the optical depths due to ice! -! clouds are computed as in ebert and curry, jgr, 97, ! -! 3831-3836 (1992). the spectral regions in this work ! -! have been matched with the spectral bands in rrtm to ! -! as great an extent as possible: ! -! e&c 1 ib = 5 rrtm bands 9-16 ! -! e&c 2 ib = 4 rrtm bands 6-8 ! -! e&c 3 ib = 3 rrtm bands 3-5 ! -! e&c 4 ib = 2 rrtm band 2 ! -! e&c 5 ib = 1 rrtm band 1 ! -! ilwcice=2: the cloud ice path (g/m2) and ice effective radius ! -! (microns) are input and the optical depths due to ice! -! clouds are computed as in rt code, streamer v3.0 ! -! (ref: key j., streamer user's guide, cooperative ! -! institute for meteorological satellite studies, 2001,! -! 96 pp.) valid range of values for re are between 5.0 ! -! and 131.0 micron. ! -! ilwcice=3: the ice generalized effective size (dge) is input and! -! the optical properties, are calculated as in q. fu, ! -! j. climate, (1998). q. fu provided high resolution ! -! tales which were appropriately averaged for the bands! -! in rrtm_lw. linear interpolation is used to get the ! -! coeff from the stored tables. valid range of values ! -! for deg are between 5.0 and 140.0 micron. ! -! ! -! other cloud control module variables: ! -! isubclw =0: standard cloud scheme, no sub-col cloud approximation ! -! >0: mcica sub-col cloud scheme using ipseed as permutation! -! seed for generating rundom numbers ! -! ! -! ====================== end of description block ================= ! -! - use module_radlw_cldprlw - -! --- inputs: - integer, intent(in) :: nlay, nlp1, ipseed - - real (kind=kind_phys), dimension(0:nlp1), intent(in) :: cfrac - real (kind=kind_phys), dimension(nlay), intent(in) :: cliqp, & - & reliq, cicep, reice, cdat1, cdat2, cdat3, cdat4, dz - real (kind=kind_phys), intent(in) :: de_lgth - -! --- outputs: - real (kind=kind_phys), dimension(ngptlw,nlay),intent(out):: cldfmc - real (kind=kind_phys), dimension(nbands,nlay),intent(out):: taucld - -! --- locals: - real (kind=kind_phys), dimension(nbands) :: tauliq, tauice - real (kind=kind_phys), dimension(nlay) :: cldf - - real (kind=kind_phys) :: dgeice, factor, fint, tauran, tausnw, & - & cldliq, refliq, cldice, refice - - logical :: lcloudy(ngptlw,nlay) - integer :: ia, ib, ig, k, index - -! -!===> ... begin here -! - do k = 1, nlay - do ib = 1, nbands - taucld(ib,k) = f_zero - enddo - enddo - - do k = 1, nlay - do ig = 1, ngptlw - cldfmc(ig,k) = f_zero - enddo - enddo - -!> -# Compute cloud radiative properties for a cloudy column: -!!\n - Compute cloud radiative properties for rain and snow (tauran,tausnw) -!!\n - Calculation of absorption coefficients due to water clouds(tauliq) -!!\n - Calculation of absorption coefficients due to ice clouds (tauice). -!!\n - For prognostic cloud scheme: sum up the cloud optical property: -!!\n \f$ taucld=tauice+tauliq+tauran+tausnw \f$ - -! --- ... compute cloud radiative properties for a cloudy column - - lab_if_ilwcliq : if (ilwcliq > 0) then - - lab_do_k : do k = 1, nlay - lab_if_cld : if (cfrac(k) > cldmin) then - - tauran = absrain * cdat1(k) ! ncar formula -!! tausnw = abssnow1 * cdat3(k) ! ncar formula -! --- if use fu's formula it needs to be normalized by snow density -! !not use snow density = 0.1 g/cm**3 = 0.1 g/(mu * m**2) -! use ice density = 0.9167 g/cm**3 = 0.9167 g/(mu * m**2) -! factor 1.5396=8/(3*sqrt(3)) converts reff to generalized ice particle size -! use newer factor value 1.0315 -! 1/(0.9167*1.0315) = 1.05756 - if (cdat3(k)>f_zero .and. cdat4(k)>10.0_kind_phys) then - tausnw = abssnow0*1.05756*cdat3(k)/cdat4(k) ! fu's formula - else - tausnw = f_zero - endif - - cldliq = cliqp(k) - cldice = cicep(k) -! refliq = max(2.5e0, min(60.0e0, reliq(k) )) -! refice = max(5.0e0, reice(k) ) - refliq = reliq(k) - refice = reice(k) - -! --- ... calculation of absorption coefficients due to water clouds. - - if ( cldliq <= f_zero ) then - do ib = 1, nbands - tauliq(ib) = f_zero - enddo - else - if ( ilwcliq == 1 ) then - - factor = refliq - 1.5 - index = max( 1, min( 57, int( factor ) )) - fint = factor - float(index) - - do ib = 1, nbands - tauliq(ib) = max(f_zero, cldliq*(absliq1(index,ib) & - & + fint*(absliq1(index+1,ib)-absliq1(index,ib)) )) - enddo - endif ! end if_ilwcliq_block - endif ! end if_cldliq_block - -! --- ... calculation of absorption coefficients due to ice clouds. - - if ( cldice <= f_zero ) then - do ib = 1, nbands - tauice(ib) = f_zero - enddo - else - -! --- ... ebert and curry approach for all particle sizes though somewhat -! unjustified for large ice particles - - if ( ilwcice == 1 ) then - refice = min(130.0, max(13.0, real(refice) )) - - do ib = 1, nbands - ia = ipat(ib) ! eb_&_c band index for ice cloud coeff - tauice(ib) = max(f_zero, cldice*(absice1(1,ia) & - & + absice1(2,ia)/refice) ) - enddo - -! --- ... streamer approach for ice effective radius between 5.0 and 131.0 microns -! and ebert and curry approach for ice eff radius greater than 131.0 microns. -! no smoothing between the transition of the two methods. - - elseif ( ilwcice == 2 ) then - - factor = (refice - 2.0) / 3.0 - index = max( 1, min( 42, int( factor ) )) - fint = factor - float(index) - - do ib = 1, nbands - tauice(ib) = max(f_zero, cldice*(absice2(index,ib) & - & + fint*(absice2(index+1,ib) - absice2(index,ib)) )) - enddo - -! --- ... fu's approach for ice effective radius between 4.8 and 135 microns -! (generalized effective size from 5 to 140 microns) - - elseif ( ilwcice == 3 ) then - -! dgeice = max(5.0, 1.5396*refice) ! v4.4 value - dgeice = max(5.0, 1.0315*refice) ! v4.71 value - factor = (dgeice - 2.0) / 3.0 - index = max( 1, min( 45, int( factor ) )) - fint = factor - float(index) - - do ib = 1, nbands - tauice(ib) = max(f_zero, cldice*(absice3(index,ib) & - & + fint*(absice3(index+1,ib) - absice3(index,ib)) )) - enddo - - endif ! end if_ilwcice_block - endif ! end if_cldice_block - - do ib = 1, nbands - taucld(ib,k) = tauice(ib) + tauliq(ib) + tauran + tausnw - enddo - - endif lab_if_cld - enddo lab_do_k - - else lab_if_ilwcliq - - do k = 1, nlay - if (cfrac(k) > cldmin) then - do ib = 1, nbands - taucld(ib,k) = cdat1(k) - enddo - endif - enddo - - endif lab_if_ilwcliq - -!> -# if physparam::isubclw > 0, call mcica_subcol() to distribute -!! cloud properties to each g-point. - - if ( isubclw > 0 ) then ! mcica sub-col clouds approx - do k = 1, nlay - if ( cfrac(k) < cldmin ) then - cldf(k) = f_zero - else - cldf(k) = cfrac(k) - endif - enddo - -! --- ... call sub-column cloud generator - - call mcica_subcol & -! --- inputs: - & ( cldf, nlay, ipseed, dz, de_lgth, & -! --- output: - & lcloudy & - & ) - - do k = 1, nlay - do ig = 1, ngptlw - if ( lcloudy(ig,k) ) then - cldfmc(ig,k) = f_one - else - cldfmc(ig,k) = f_zero - endif - enddo - enddo - - endif ! end if_isubclw_block - - return -! .................................. - end subroutine cldprop -! ---------------------------------- -!> @} - -!>\ingroup module_radlw_main -!>\brief This suroutine computes sub-colum cloud profile flag array. -!!\param cldf layer cloud fraction -!!\param nlay number of model vertical layers -!!\param ipseed permute seed for random num generator -!!\param dz layer thickness -!!\param de_lgth layer cloud decorrelation length (km) -!!\param lcloudy sub-colum cloud profile flag array -!!\section mcica_subcol_gen mcica_subcol General Algorithm -!! @{ - subroutine mcica_subcol & - & ( cldf, nlay, ipseed, dz, de_lgth, & ! --- inputs - & lcloudy & ! --- outputs - & ) - -! ==================== defination of variables ==================== ! -! ! -! input variables: size ! -! cldf - real, layer cloud fraction nlay ! -! nlay - integer, number of model vertical layers 1 ! -! ipseed - integer, permute seed for random num generator 1 ! -! ** note : if the cloud generator is called multiple times, need ! -! to permute the seed between each call; if between calls ! -! for lw and sw, use values differ by the number of g-pts. ! -! dz - real, layer thickness (km) nlay ! -! de_lgth - real, layer cloud decorrelation length (km) 1 ! -! ! -! output variables: ! -! lcloudy - logical, sub-colum cloud profile flag array ngptlw*nlay! -! ! -! other control flags from module variables: ! -! iovrlw : control flag for cloud overlapping method ! -! =0:random; =1:maximum/random: =2:maximum; =3:decorr ! -! ! -! ===================== end of definitions ==================== ! - - implicit none - -! --- inputs: - integer, intent(in) :: nlay, ipseed - - real (kind=kind_phys), dimension(nlay), intent(in) :: cldf, dz - real (kind=kind_phys), intent(in) :: de_lgth - -! --- outputs: - logical, dimension(ngptlw,nlay), intent(out) :: lcloudy - -! --- locals: - real (kind=kind_phys) :: cdfunc(ngptlw,nlay), rand1d(ngptlw), & - & rand2d(nlay*ngptlw), tem1, fac_lcf(nlay), & - & cdfun2(ngptlw,nlay) - - type (random_stat) :: stat ! for thread safe random generator - - integer :: k, n, k1 -! -!===> ... begin here -! -!> -# Call random_setseed() to advance randum number generator by ipseed values. - - call random_setseed & -! --- inputs: - & ( ipseed, & -! --- outputs: - & stat & - & ) - -!> -# Sub-column set up according to overlapping assumption: -!! - For random overlap, pick a random value at every level -!! - For max-random overlap, pick a random value at every level -!! - For maximum overlap, pick same random numebr at every level - - select case ( iovrlw ) - - case( 0 ) ! random overlap, pick a random value at every level - - call random_number & -! --- inputs: ( none ) -! --- outputs: - & ( rand2d, stat ) - - k1 = 0 - do n = 1, ngptlw - do k = 1, nlay - k1 = k1 + 1 - cdfunc(n,k) = rand2d(k1) - enddo - enddo - - case( 1 ) ! max-ran overlap - - call random_number & -! --- inputs: ( none ) -! --- outputs: - & ( rand2d, stat ) - - k1 = 0 - do n = 1, ngptlw - do k = 1, nlay - k1 = k1 + 1 - cdfunc(n,k) = rand2d(k1) - enddo - enddo - -! --- first pick a random number for bottom (or top) layer. -! then walk up the column: (aer's code) -! if layer below is cloudy, use the same rand num in the layer below -! if layer below is clear, use a new random number - -! --- from bottom up - do k = 2, nlay - k1 = k - 1 - tem1 = f_one - cldf(k1) - - do n = 1, ngptlw - if ( cdfunc(n,k1) > tem1 ) then - cdfunc(n,k) = cdfunc(n,k1) - else - cdfunc(n,k) = cdfunc(n,k) * tem1 - endif - enddo - enddo - -! --- or walk down the column: (if use original author's method) -! if layer above is cloudy, use the same rand num in the layer above -! if layer above is clear, use a new random number - -! --- from top down -! do k = nlay-1, 1, -1 -! k1 = k + 1 -! tem1 = f_one - cldf(k1) - -! do n = 1, ngptlw -! if ( cdfunc(n,k1) > tem1 ) then -! cdfunc(n,k) = cdfunc(n,k1) -! else -! cdfunc(n,k) = cdfunc(n,k) * tem1 -! endif -! enddo -! enddo - - case( 2 ) !< - For maximum overlap, pick same random numebr at every level - - call random_number & -! --- inputs: ( none ) -! --- outputs: - & ( rand1d, stat ) - - do n = 1, ngptlw - tem1 = rand1d(n) - - do k = 1, nlay - cdfunc(n,k) = tem1 - enddo - enddo - - case( 3 ) ! decorrelation length overlap - -! --- compute overlapping factors based on layer midpoint distances -! and decorrelation depths - - do k = nlay, 2, -1 - fac_lcf(k) = exp( -0.5 * (dz(k)+dz(k-1)) / de_lgth ) - enddo - -! --- setup 2 sets of random numbers - - call random_number ( rand2d, stat ) - - k1 = 0 - do k = 1, nlay - do n = 1, ngptlw - k1 = k1 + 1 - cdfunc(n,k) = rand2d(k1) - enddo - enddo - - call random_number ( rand2d, stat ) - - k1 = 0 - do k = 1, nlay - do n = 1, ngptlw - k1 = k1 + 1 - cdfun2(n,k) = rand2d(k1) - enddo - enddo - -! --- then working from the top down: -! if a random number (from an independent set -cdfun2) is smaller then the -! scale factor: use the upper layer's number, otherwise use a new random -! number (keep the original assigned one). - - do k = nlay-1, 1, -1 - k1 = k + 1 - - do n = 1, ngptlw - if ( cdfun2(n,k) <= fac_lcf(k1) ) then - cdfunc(n,k) = cdfunc(n,k1) - endif - enddo - enddo - - end select - -!> -# Generate subcolumns for homogeneous clouds. - - do k = 1, nlay - tem1 = f_one - cldf(k) - - do n = 1, ngptlw - lcloudy(n,k) = cdfunc(n,k) >= tem1 - enddo - enddo - - return -! .................................. - end subroutine mcica_subcol -!! @} -! ---------------------------------- - -!>\ingroup module_radlw_main -!> This subroutine computes various coefficients needed in radiative -!! transfer calculations. -!!\param pavel layer pressure (mb) -!!\param tavel layer temperature (K) -!!\param tz level(interface) temperatures (K) -!!\param stemp surface ground temperature (K) -!!\param h2ovmr layer w.v. volumn mixing ratio (kg/kg) -!!\param colamt column amounts of absorbing gases. -!! 2nd indices range: 1-maxgas, for watervapor,carbon dioxide, ozone, -!! nitrous oxide, methane,oxigen, carbon monoxide,etc. \f$(mol/cm^2)\f$ -!!\param coldry dry air column amount -!!\param colbrd column amount of broadening gases -!!\param nlay total number of vertical layers -!!\param nlp1 total number of vertical levels -!!\param laytrop tropopause layer index (unitless) -!!\param pklay integrated planck func at lay temp -!!\param pklev integrated planck func at lev temp -!!\param jp indices of lower reference pressure -!!\param jt, jt1 indices of lower reference temperatures -!!\param rfrate ref ratios of binary species param -!!\n (:,m,:)m=1-h2o/co2,2-h2o/o3,3-h2o/n2o, -!! 4-h2o/ch4,5-n2o/co2,6-o3/co2 -!!\n (:,:,n)n=1,2: the rates of ref press at -!! the 2 sides of the layer -!!\param fac00,fac01,fac10,fac11 factors multiply the reference ks, i,j=0/1 for -!! lower/higher of the 2 appropriate temperatures -!! and altitudes. -!!\param selffac scale factor for w. v. self-continuum equals -!! (w. v. density)/(atmospheric density at 296k and 1013 mb) -!!\param selffrac factor for temperature interpolation of -!! reference w. v. self-continuum data -!!\param indself index of lower ref temp for selffac -!!\param forfac scale factor for w. v. foreign-continuum -!!\param forfrac factor for temperature interpolation of -!! reference w.v. foreign-continuum data -!!\param indfor index of lower ref temp for forfac -!!\param minorfrac factor for minor gases -!!\param scaleminor,scaleminorn2 scale factors for minor gases -!!\param indminor index of lower ref temp for minor gases -!>\section setcoef_gen setcoef General Algorithm -!> @{ - subroutine setcoef & - & ( pavel,tavel,tz,stemp,h2ovmr,colamt,coldry,colbrd, & ! --- inputs: - & nlay, nlp1, & - & laytrop,pklay,pklev,jp,jt,jt1, & ! --- outputs: - & rfrate,fac00,fac01,fac10,fac11, & - & selffac,selffrac,indself,forfac,forfrac,indfor, & - & minorfrac,scaleminor,scaleminorn2,indminor & - & ) - -! =================== program usage description =================== ! -! ! -! purpose: compute various coefficients needed in radiative transfer ! -! calculations. ! -! ! -! subprograms called: none ! -! ! -! ==================== defination of variables ==================== ! -! ! -! inputs: -size- ! -! pavel - real, layer pressures (mb) nlay ! -! tavel - real, layer temperatures (k) nlay ! -! tz - real, level (interface) temperatures (k) 0:nlay ! -! stemp - real, surface ground temperature (k) 1 ! -! h2ovmr - real, layer w.v. volum mixing ratio (kg/kg) nlay ! -! colamt - real, column amounts of absorbing gases nlay*maxgas! -! 2nd indices range: 1-maxgas, for watervapor, ! -! carbon dioxide, ozone, nitrous oxide, methane, ! -! oxigen, carbon monoxide,etc. (molecules/cm**2) ! -! coldry - real, dry air column amount nlay ! -! colbrd - real, column amount of broadening gases nlay ! -! nlay/nlp1 - integer, total number of vertical layers, levels 1 ! -! ! -! outputs: ! -! laytrop - integer, tropopause layer index (unitless) 1 ! -! pklay - real, integrated planck func at lay temp nbands*0:nlay! -! pklev - real, integrated planck func at lev temp nbands*0:nlay! -! jp - real, indices of lower reference pressure nlay ! -! jt, jt1 - real, indices of lower reference temperatures nlay ! -! rfrate - real, ref ratios of binary species param nlay*nrates*2! -! (:,m,:)m=1-h2o/co2,2-h2o/o3,3-h2o/n2o,4-h2o/ch4,5-n2o/co2,6-o3/co2! -! (:,:,n)n=1,2: the rates of ref press at the 2 sides of the layer ! -! facij - real, factors multiply the reference ks, nlay ! -! i,j=0/1 for lower/higher of the 2 appropriate ! -! temperatures and altitudes. ! -! selffac - real, scale factor for w. v. self-continuum nlay ! -! equals (w. v. density)/(atmospheric density ! -! at 296k and 1013 mb) ! -! selffrac - real, factor for temperature interpolation of nlay ! -! reference w. v. self-continuum data ! -! indself - integer, index of lower ref temp for selffac nlay ! -! forfac - real, scale factor for w. v. foreign-continuum nlay ! -! forfrac - real, factor for temperature interpolation of nlay ! -! reference w.v. foreign-continuum data ! -! indfor - integer, index of lower ref temp for forfac nlay ! -! minorfrac - real, factor for minor gases nlay ! -! scaleminor,scaleminorn2 ! -! - real, scale factors for minor gases nlay ! -! indminor - integer, index of lower ref temp for minor gases nlay ! -! ! -! ====================== end of definitions =================== ! - -! --- inputs: - integer, intent(in) :: nlay, nlp1 - - real (kind=kind_phys), dimension(nlay,maxgas),intent(in):: colamt - real (kind=kind_phys), dimension(0:nlay), intent(in):: tz - - real (kind=kind_phys), dimension(nlay), intent(in) :: pavel, & - & tavel, h2ovmr, coldry, colbrd - - real (kind=kind_phys), intent(in) :: stemp - -! --- outputs: - integer, dimension(nlay), intent(out) :: jp, jt, jt1, indself, & - & indfor, indminor - - integer, intent(out) :: laytrop - - real (kind=kind_phys), dimension(nlay,nrates,2), intent(out) :: & - & rfrate - real (kind=kind_phys), dimension(nbands,0:nlay), intent(out) :: & - & pklev, pklay - - real (kind=kind_phys), dimension(nlay), intent(out) :: & - & fac00, fac01, fac10, fac11, selffac, selffrac, forfac, & - & forfrac, minorfrac, scaleminor, scaleminorn2 - -! --- locals: - real (kind=kind_phys) :: tlvlfr, tlyrfr, plog, fp, ft, ft1, & - & tem1, tem2 - - integer :: i, k, jp1, indlev, indlay -! -!===> ... begin here -! -!> -# Calculate information needed by the radiative transfer routine -!! that is specific to this atmosphere, especially some of the -!! coefficients and indices needed to compute the optical depths -!! by interpolating data from stored reference atmospheres. - - indlay = min(180, max(1, int(stemp-159.0) )) - indlev = min(180, max(1, int(tz(0)-159.0) )) - tlyrfr = stemp - int(stemp) - tlvlfr = tz(0) - int(tz(0)) - do i = 1, nbands - tem1 = totplnk(indlay+1,i) - totplnk(indlay,i) - tem2 = totplnk(indlev+1,i) - totplnk(indlev,i) - pklay(i,0) = delwave(i) * (totplnk(indlay,i) + tlyrfr*tem1) - pklev(i,0) = delwave(i) * (totplnk(indlev,i) + tlvlfr*tem2) - enddo - -! --- ... begin layer loop -!> -# Calculate the integrated Planck functions for each band at the -!! surface, level, and layer temperatures. - - laytrop = 0 - - do k = 1, nlay - - indlay = min(180, max(1, int(tavel(k)-159.0) )) - tlyrfr = tavel(k) - int(tavel(k)) - - indlev = min(180, max(1, int(tz(k)-159.0) )) - tlvlfr = tz(k) - int(tz(k)) - -! --- ... begin spectral band loop - - do i = 1, nbands - pklay(i,k) = delwave(i) * (totplnk(indlay,i) + tlyrfr & - & * (totplnk(indlay+1,i) - totplnk(indlay,i)) ) - pklev(i,k) = delwave(i) * (totplnk(indlev,i) + tlvlfr & - & * (totplnk(indlev+1,i) - totplnk(indlev,i)) ) - enddo - -!> -# Find the two reference pressures on either side of the -!! layer pressure. store them in jp and jp1. store in fp the -!! fraction of the difference (in ln(pressure)) between these -!! two values that the layer pressure lies. - - plog = log(pavel(k)) - jp(k)= max(1, min(58, int(36.0 - 5.0*(plog+0.04)) )) - jp1 = jp(k) + 1 -! --- ... limit pressure extrapolation at the top - fp = max(f_zero, min(f_one, 5.0*(preflog(jp(k))-plog) )) -!org fp = 5.0 * (preflog(jp(k)) - plog) - -!> -# Determine, for each reference pressure (jp and jp1), which -!! reference temperature (these are different for each -!! reference pressure) is nearest the layer temperature but does -!! not exceed it. store these indices in jt and jt1, resp. -!! store in ft (resp. ft1) the fraction of the way between jt -!! (jt1) and the next highest reference temperature that the -!! layer temperature falls. - - tem1 = (tavel(k)-tref(jp(k))) / 15.0 - tem2 = (tavel(k)-tref(jp1 )) / 15.0 - jt (k) = max(1, min(4, int(3.0 + tem1) )) - jt1(k) = max(1, min(4, int(3.0 + tem2) )) -! --- ... restrict extrapolation ranges by limiting abs(det t) < 37.5 deg - ft = max(-0.5, min(1.5, tem1 - float(jt (k) - 3) )) - ft1 = max(-0.5, min(1.5, tem2 - float(jt1(k) - 3) )) -!org ft = tem1 - float(jt (k) - 3) -!org ft1 = tem2 - float(jt1(k) - 3) - -!> -# We have now isolated the layer ln pressure and temperature, -!! between two reference pressures and two reference temperatures -!!(for each reference pressure). we multiply the pressure -!! fraction fp with the appropriate temperature fractions to get -!! the factors that will be needed for the interpolation that yields -!! the optical depths (performed in routines taugbn for band n). - - tem1 = f_one - fp - fac10(k) = tem1 * ft - fac00(k) = tem1 * (f_one - ft) - fac11(k) = fp * ft1 - fac01(k) = fp * (f_one - ft1) - - forfac(k) = pavel(k)*stpfac / (tavel(k)*(1.0 + h2ovmr(k))) - selffac(k) = h2ovmr(k) * forfac(k) - -!> -# Set up factors needed to separately include the minor gases -!! in the calculation of absorption coefficient. - - scaleminor(k) = pavel(k) / tavel(k) - scaleminorn2(k) = (pavel(k) / tavel(k)) & - & * (colbrd(k)/(coldry(k) + colamt(k,1))) - tem1 = (tavel(k) - 180.8) / 7.2 - indminor(k) = min(18, max(1, int(tem1))) - minorfrac(k) = tem1 - float(indminor(k)) - -!> -# If the pressure is less than ~100mb, perform a different -!! set of species interpolations. - - if (plog > 4.56) then - - laytrop = laytrop + 1 - - tem1 = (332.0 - tavel(k)) / 36.0 - indfor(k) = min(2, max(1, int(tem1))) - forfrac(k) = tem1 - float(indfor(k)) - -!> -# Set up factors needed to separately include the water vapor -!! self-continuum in the calculation of absorption coefficient. - - tem1 = (tavel(k) - 188.0) / 7.2 - indself(k) = min(9, max(1, int(tem1)-7)) - selffrac(k) = tem1 - float(indself(k) + 7) - -!> -# Setup reference ratio to be used in calculation of binary -!! species parameter in lower atmosphere. - - rfrate(k,1,1) = chi_mls(1,jp(k)) / chi_mls(2,jp(k)) - rfrate(k,1,2) = chi_mls(1,jp(k)+1) / chi_mls(2,jp(k)+1) - - rfrate(k,2,1) = chi_mls(1,jp(k)) / chi_mls(3,jp(k)) - rfrate(k,2,2) = chi_mls(1,jp(k)+1) / chi_mls(3,jp(k)+1) - - rfrate(k,3,1) = chi_mls(1,jp(k)) / chi_mls(4,jp(k)) - rfrate(k,3,2) = chi_mls(1,jp(k)+1) / chi_mls(4,jp(k)+1) - - rfrate(k,4,1) = chi_mls(1,jp(k)) / chi_mls(6,jp(k)) - rfrate(k,4,2) = chi_mls(1,jp(k)+1) / chi_mls(6,jp(k)+1) - - rfrate(k,5,1) = chi_mls(4,jp(k)) / chi_mls(2,jp(k)) - rfrate(k,5,2) = chi_mls(4,jp(k)+1) / chi_mls(2,jp(k)+1) - - else - - tem1 = (tavel(k) - 188.0) / 36.0 - indfor(k) = 3 - forfrac(k) = tem1 - f_one - - indself(k) = 0 - selffrac(k) = f_zero - -!> -# Setup reference ratio to be used in calculation of binary -!! species parameter in upper atmosphere. - - rfrate(k,1,1) = chi_mls(1,jp(k)) / chi_mls(2,jp(k)) - rfrate(k,1,2) = chi_mls(1,jp(k)+1) / chi_mls(2,jp(k)+1) - - rfrate(k,6,1) = chi_mls(3,jp(k)) / chi_mls(2,jp(k)) - rfrate(k,6,2) = chi_mls(3,jp(k)+1) / chi_mls(2,jp(k)+1) - - endif - -!> -# Rescale \a selffac and \a forfac for use in taumol. - - selffac(k) = colamt(k,1) * selffac(k) - forfac(k) = colamt(k,1) * forfac(k) - - enddo ! end do_k layer loop - - return -! .................................. - end subroutine setcoef -!> @} -! ---------------------------------- - -!>\ingroup module_radlw_main -!> This subroutine computes the upward/downward radiative fluxes, and -!! heating rates for both clear or cloudy atmosphere. Clouds assumed as -!! randomly overlaping in a vertical column. -!!\brief Original Code Description: this program calculates the upward -!! fluxes, downward fluxes, and heating rates for an arbitrary clear or -!! cloudy atmosphere. The input to this program is the atmospheric -!! profile, all Planck function information, and the cloud fraction by -!! layer. A variable diffusivity angle (secdif) is used for the angle -!! integration. Bands 2-3 and 5-9 use a value for secdif that varies -!! from 1.50 to 1.80 as a function of the column water vapor, and other -!! bands use a value of 1.66. The gaussian weight appropriate to this -!! angle (wtdiff =0.5) is applied here. Note that use of the emissivity -!! angle for the flux integration can cause errors of 1 to 4 \f$W/m^2\f$ -!! within cloudy layers. Clouds are treated with a random cloud overlap -!! method. -!!\param semiss lw surface emissivity -!!\param delp layer pressure thickness (mb) -!!\param cldfrc layer cloud fraction -!!\param taucld layer cloud opt depth -!!\param tautot total optical depth (gas+aerosols) -!!\param pklay integrated planck function at lay temp -!!\param pklev integrated planck func at lev temp -!!\param fracs planck fractions -!!\param secdif secant of diffusivity angle -!!\param nlay number of vertical layers -!!\param nlp1 number of vertical levels (interfaces) -!!\param totuflux total sky upward flux \f$(w/m^2)\f$ -!!\param totdflux total sky downward flux \f$(w/m^2)\f$ -!!\param htr total sky heating rate (k/sec or k/day) -!!\param totuclfl clear sky upward flux \f$(w/m^2)\f$ -!!\param totdclfl clear sky downward flux \f$(w/m^2)\f$ -!!\param htrcl clear sky heating rate (k/sec or k/day) -!!\param htrb spectral band lw heating rate (k/day) -!>\section gen_rtrn rtrn General Algorithm -!! @{ -! ---------------------------------- - subroutine rtrn & - & ( semiss,delp,cldfrc,taucld,tautot,pklay,pklev, & ! --- inputs - & fracs,secdif, nlay,nlp1, & - & totuflux,totdflux,htr, totuclfl,totdclfl,htrcl, htrb & ! --- outputs - & ) - -! =================== program usage description =================== ! -! ! -! purpose: compute the upward/downward radiative fluxes, and heating ! -! rates for both clear or cloudy atmosphere. clouds are assumed as ! -! randomly overlaping in a vertical colum. ! -! ! -! subprograms called: none ! -! ! -! ==================== defination of variables ==================== ! -! ! -! inputs: -size- ! -! semiss - real, lw surface emissivity nbands! -! delp - real, layer pressure thickness (mb) nlay ! -! cldfrc - real, layer cloud fraction 0:nlp1 ! -! taucld - real, layer cloud opt depth nbands,nlay! -! tautot - real, total optical depth (gas+aerosols) ngptlw,nlay! -! pklay - real, integrated planck func at lay temp nbands*0:nlay! -! pklev - real, integrated planck func at lev temp nbands*0:nlay! -! fracs - real, planck fractions ngptlw,nlay! -! secdif - real, secant of diffusivity angle nbands! -! nlay - integer, number of vertical layers 1 ! -! nlp1 - integer, number of vertical levels (interfaces) 1 ! -! ! -! outputs: ! -! totuflux- real, total sky upward flux (w/m2) 0:nlay ! -! totdflux- real, total sky downward flux (w/m2) 0:nlay ! -! htr - real, total sky heating rate (k/sec or k/day) nlay ! -! totuclfl- real, clear sky upward flux (w/m2) 0:nlay ! -! totdclfl- real, clear sky downward flux (w/m2) 0:nlay ! -! htrcl - real, clear sky heating rate (k/sec or k/day) nlay ! -! htrb - real, spectral band lw heating rate (k/day) nlay*nbands! -! ! -! module veriables: ! -! ngb - integer, band index for each g-value ngptlw! -! fluxfac - real, conversion factor for fluxes (pi*2.e4) 1 ! -! heatfac - real, conversion factor for heating rates (g/cp*1e-2) 1 ! -! tblint - real, conversion factor for look-up tbl (float(ntbl) 1 ! -! bpade - real, pade approx constant (1/0.278) 1 ! -! wtdiff - real, weight for radiance to flux conversion 1 ! -! ntbl - integer, dimension of look-up tables 1 ! -! tau_tbl - real, clr-sky opt dep lookup table 0:ntbl ! -! exp_tbl - real, transmittance lookup table 0:ntbl ! -! tfn_tbl - real, tau transition function 0:ntbl ! -! ! -! local variables: ! -! itgas - integer, index for gases contribution look-up table 1 ! -! ittot - integer, index for gases plus clouds look-up table 1 ! -! reflct - real, surface reflectance 1 ! -! atrgas - real, gaseous absorptivity 1 ! -! atrtot - real, gaseous and cloud absorptivity 1 ! -! odcld - real, cloud optical depth 1 ! -! efclrfr- real, effective clear sky fraction (1-efcldfr) nlay ! -! odepth - real, optical depth of gaseous only 1 ! -! odtot - real, optical depth of gas and cloud 1 ! -! gasfac - real, gas-only pade factor, used for planck fn 1 ! -! totfac - real, gas+cld pade factor, used for planck fn 1 ! -! bbdgas - real, gas-only planck function for downward rt 1 ! -! bbugas - real, gas-only planck function for upward rt 1 ! -! bbdtot - real, gas and cloud planck function for downward rt 1 ! -! bbutot - real, gas and cloud planck function for upward rt 1 ! -! gassrcu- real, upwd source radiance due to gas only nlay! -! totsrcu- real, upwd source radiance due to gas+cld nlay! -! gassrcd- real, dnwd source radiance due to gas only 1 ! -! totsrcd- real, dnwd source radiance due to gas+cld 1 ! -! radtotu- real, spectrally summed total sky upwd radiance 1 ! -! radclru- real, spectrally summed clear sky upwd radiance 1 ! -! radtotd- real, spectrally summed total sky dnwd radiance 1 ! -! radclrd- real, spectrally summed clear sky dnwd radiance 1 ! -! toturad- real, total sky upward radiance by layer 0:nlay*nbands! -! clrurad- real, clear sky upward radiance by layer 0:nlay*nbands! -! totdrad- real, total sky downward radiance by layer 0:nlay*nbands! -! clrdrad- real, clear sky downward radiance by layer 0:nlay*nbands! -! fnet - real, net longwave flux (w/m2) 0:nlay ! -! fnetc - real, clear sky net longwave flux (w/m2) 0:nlay ! -! ! -! ! -! ******************************************************************* ! -! original code description ! -! ! -! original version: e. j. mlawer, et al. rrtm_v3.0 ! -! revision for gcms: michael j. iacono; october, 2002 ! -! revision for f90: michael j. iacono; june, 2006 ! -! ! -! this program calculates the upward fluxes, downward fluxes, and ! -! heating rates for an arbitrary clear or cloudy atmosphere. the input ! -! to this program is the atmospheric profile, all Planck function ! -! information, and the cloud fraction by layer. a variable diffusivity! -! angle (secdif) is used for the angle integration. bands 2-3 and 5-9 ! -! use a value for secdif that varies from 1.50 to 1.80 as a function ! -! of the column water vapor, and other bands use a value of 1.66. the ! -! gaussian weight appropriate to this angle (wtdiff=0.5) is applied ! -! here. note that use of the emissivity angle for the flux integration! -! can cause errors of 1 to 4 W/m2 within cloudy layers. ! -! clouds are treated with a random cloud overlap method. ! -! ! -! ******************************************************************* ! -! ====================== end of description block ================= ! - -! --- inputs: - integer, intent(in) :: nlay, nlp1 - - real (kind=kind_phys), dimension(0:nlp1), intent(in) :: cldfrc - real (kind=kind_phys), dimension(nbands), intent(in) :: semiss, & - & secdif - real (kind=kind_phys), dimension(nlay), intent(in) :: delp - - real (kind=kind_phys), dimension(nbands,nlay),intent(in):: taucld - real (kind=kind_phys), dimension(ngptlw,nlay),intent(in):: fracs, & - & tautot - - real (kind=kind_phys), dimension(nbands,0:nlay), intent(in) :: & - & pklev, pklay - -! --- outputs: - real (kind=kind_phys), dimension(nlay), intent(out) :: htr, htrcl - - real (kind=kind_phys), dimension(nlay,nbands),intent(out) :: htrb - - real (kind=kind_phys), dimension(0:nlay), intent(out) :: & - & totuflux, totdflux, totuclfl, totdclfl - -! --- locals: - real (kind=kind_phys), parameter :: rec_6 = 0.166667 - - real (kind=kind_phys), dimension(0:nlay,nbands) :: clrurad, & - & clrdrad, toturad, totdrad - - real (kind=kind_phys), dimension(nlay) :: gassrcu, totsrcu, & - & trngas, efclrfr, rfdelp - real (kind=kind_phys), dimension(0:nlay) :: fnet, fnetc - - real (kind=kind_phys) :: totsrcd, gassrcd, tblind, odepth, odtot, & - & odcld, atrtot, atrgas, reflct, totfac, gasfac, flxfac, & - & plfrac, blay, bbdgas, bbdtot, bbugas, bbutot, dplnku, & - & dplnkd, radtotu, radclru, radtotd, radclrd, rad0, & - & clfr, trng, gasu - - integer :: ittot, itgas, ib, ig, k -! -!===> ... begin here -! - do ib = 1, NBANDS - do k = 0, NLAY - toturad(k,ib) = f_zero - totdrad(k,ib) = f_zero - clrurad(k,ib) = f_zero - clrdrad(k,ib) = f_zero - enddo - enddo - - do k = 0, nlay - totuflux(k) = f_zero - totdflux(k) = f_zero - totuclfl(k) = f_zero - totdclfl(k) = f_zero - enddo - -! --- ... loop over all g-points - - do ig = 1, ngptlw - ib = ngb(ig) - - radtotd = f_zero - radclrd = f_zero - -!> -# Downward radiative transfer loop. - - do k = nlay, 1, -1 - -!!\n - clear sky, gases contribution - - odepth = max( f_zero, secdif(ib)*tautot(ig,k) ) - if (odepth <= 0.06) then - atrgas = odepth - 0.5*odepth*odepth - trng = f_one - atrgas - gasfac = rec_6 * odepth - else - tblind = odepth / (bpade + odepth) - itgas = tblint*tblind + 0.5 - trng = exp_tbl(itgas) - atrgas = f_one - trng - gasfac = tfn_tbl(itgas) - odepth = tau_tbl(itgas) - endif - - plfrac = fracs(ig,k) - blay = pklay(ib,k) - - dplnku = pklev(ib,k ) - blay - dplnkd = pklev(ib,k-1) - blay - bbdgas = plfrac * (blay + dplnkd*gasfac) - bbugas = plfrac * (blay + dplnku*gasfac) - gassrcd= bbdgas * atrgas - gassrcu(k)= bbugas * atrgas - trngas(k) = trng - -!!\n - total sky, gases+clouds contribution - - clfr = cldfrc(k) - if (clfr >= eps) then -!!\n - cloudy layer - - odcld = secdif(ib) * taucld(ib,k) - efclrfr(k) = f_one-(f_one - exp(-odcld))*clfr - odtot = odepth + odcld - if (odtot < 0.06) then - totfac = rec_6 * odtot - atrtot = odtot - 0.5*odtot*odtot - else - tblind = odtot / (bpade + odtot) - ittot = tblint*tblind + 0.5 - totfac = tfn_tbl(ittot) - atrtot = f_one - exp_tbl(ittot) - endif - - bbdtot = plfrac * (blay + dplnkd*totfac) - bbutot = plfrac * (blay + dplnku*totfac) - totsrcd= bbdtot * atrtot - totsrcu(k)= bbutot * atrtot - -! --- ... total sky radiance - radtotd = radtotd*trng*efclrfr(k) + gassrcd & - & + clfr*(totsrcd - gassrcd) - totdrad(k-1,ib) = totdrad(k-1,ib) + radtotd - -! --- ... clear sky radiance - radclrd = radclrd*trng + gassrcd - clrdrad(k-1,ib) = clrdrad(k-1,ib) + radclrd - - else -! --- ... clear layer - -! --- ... total sky radiance - radtotd = radtotd*trng + gassrcd - totdrad(k-1,ib) = totdrad(k-1,ib) + radtotd - -! --- ... clear sky radiance - radclrd = radclrd*trng + gassrcd - clrdrad(k-1,ib) = clrdrad(k-1,ib) + radclrd - - endif ! end if_clfr_block - - enddo ! end do_k_loop - -!> -# Compute spectral emissivity & reflectance, include the -!! contribution of spectrally varying longwave emissivity and -!! reflection from the surface to the upward radiative transfer. - -! note: spectral and Lambertian reflection are identical for the -! diffusivity angle flux integration used here. - - reflct = f_one - semiss(ib) - rad0 = semiss(ib) * fracs(ig,1) * pklay(ib,0) - -!> -# Compute total sky radiance. - radtotu = rad0 + reflct*radtotd - toturad(0,ib) = toturad(0,ib) + radtotu - -!> -# Compute clear sky radiance - radclru = rad0 + reflct*radclrd - clrurad(0,ib) = clrurad(0,ib) + radclru - -!> -# Upward radiative transfer loop. - - do k = 1, nlay - clfr = cldfrc(k) - trng = trngas(k) - gasu = gassrcu(k) - - if (clfr >= eps) then -! --- ... cloudy layer - -! --- ... total sky radiance - radtotu = radtotu*trng*efclrfr(k) + gasu & - & + clfr*(totsrcu(k) - gasu) - toturad(k,ib) = toturad(k,ib) + radtotu - -! --- ... clear sky radiance - radclru = radclru*trng + gasu - clrurad(k,ib) = clrurad(k,ib) + radclru - - else -! --- ... clear layer - -! --- ... total sky radiance - radtotu = radtotu*trng + gasu - toturad(k,ib) = toturad(k,ib) + radtotu - -! --- ... clear sky radiance - radclru = radclru*trng + gasu - clrurad(k,ib) = clrurad(k,ib) + radclru - - endif ! end if_clfr_block - - enddo ! end do_k_loop - - enddo ! end do_ig_loop - -!> -# Process longwave output from band for total and clear streams. -!! Calculate upward, downward, and net flux. - - flxfac = wtdiff * fluxfac - - do k = 0, nlay - do ib = 1, nbands - totuflux(k) = totuflux(k) + toturad(k,ib) - totdflux(k) = totdflux(k) + totdrad(k,ib) - totuclfl(k) = totuclfl(k) + clrurad(k,ib) - totdclfl(k) = totdclfl(k) + clrdrad(k,ib) - enddo - - totuflux(k) = totuflux(k) * flxfac - totdflux(k) = totdflux(k) * flxfac - totuclfl(k) = totuclfl(k) * flxfac - totdclfl(k) = totdclfl(k) * flxfac - enddo - -! --- ... calculate net fluxes and heating rates - fnet(0) = totuflux(0) - totdflux(0) - - do k = 1, nlay - rfdelp(k) = heatfac / delp(k) - fnet(k) = totuflux(k) - totdflux(k) - htr (k) = (fnet(k-1) - fnet(k)) * rfdelp(k) - enddo - -!! --- ... optional clear sky heating rates - if ( lhlw0 ) then - fnetc(0) = totuclfl(0) - totdclfl(0) - - do k = 1, nlay - fnetc(k) = totuclfl(k) - totdclfl(k) - htrcl(k) = (fnetc(k-1) - fnetc(k)) * rfdelp(k) - enddo - endif - -!! --- ... optional spectral band heating rates - if ( lhlwb ) then - do ib = 1, nbands - fnet(0) = (toturad(0,ib) - totdrad(0,ib)) * flxfac - - do k = 1, nlay - fnet(k) = (toturad(k,ib) - totdrad(k,ib)) * flxfac - htrb(k,ib) = (fnet(k-1) - fnet(k)) * rfdelp(k) - enddo - enddo - endif - -! .................................. - end subroutine rtrn -!! @} -! ---------------------------------- - - -!>\ingroup module_radlw_main -!> This subroutine computes the upward/downward radiative fluxes, and -!! heating rates for both clear or cloudy atmosphere. Clouds are -!! assumed as in maximum-randomly overlaping in a vertical column. -!!\param semiss lw surface emissivity -!!\param delp layer pressure thickness (mb) -!!\param cldfrc layer cloud fraction -!!\param taucld layer cloud opt depth -!!\param tautot total optical depth (gas+aerosols) -!!\param pklay integrated planck func at lay temp -!!\param pklev integrated planck func at lev temp -!!\param fracs planck fractions -!!\param secdif secant of diffusivity angle -!!\param nlay number of vertical layers -!!\param nlp1 number of vertical levels (interfaces) -!!\param totuflux total sky upward flux (\f$w/m^2\f$) -!!\param totdflux total sky downward flux (\f$w/m^2\f$) -!!\param htr total sky heating rate (k/sec or k/day) -!!\param totuclfl clear sky upward flux (\f$w/m^2\f$) -!!\param totdclfl clear sky downward flux (\f$w/m^2\f$) -!!\param htrcl clear sky heating rate (k/sec or k/day) -!!\param htrb spectral band lw heating rate (k/day) -!!\section gen_rtrnmr rtrnmr General Algorithm -!> @{ -! ---------------------------------- - subroutine rtrnmr & - & ( semiss,delp,cldfrc,taucld,tautot,pklay,pklev, &! --- inputs - & fracs,secdif, nlay,nlp1, & - & totuflux,totdflux,htr, totuclfl,totdclfl,htrcl, htrb & ! --- outputs: - & ) - -! =================== program usage description =================== ! -! ! -! purpose: compute the upward/downward radiative fluxes, and heating ! -! rates for both clear or cloudy atmosphere. clouds are assumed as in ! -! maximum-randomly overlaping in a vertical colum. ! -! ! -! subprograms called: none ! -! ! -! ==================== defination of variables ==================== ! -! ! -! inputs: -size- ! -! semiss - real, lw surface emissivity nbands! -! delp - real, layer pressure thickness (mb) nlay ! -! cldfrc - real, layer cloud fraction 0:nlp1 ! -! taucld - real, layer cloud opt depth nbands,nlay! -! tautot - real, total optical depth (gas+aerosols) ngptlw,nlay! -! pklay - real, integrated planck func at lay temp nbands*0:nlay! -! pklev - real, integrated planck func at lev temp nbands*0:nlay! -! fracs - real, planck fractions ngptlw,nlay! -! secdif - real, secant of diffusivity angle nbands! -! nlay - integer, number of vertical layers 1 ! -! nlp1 - integer, number of vertical levels (interfaces) 1 ! -! ! -! outputs: ! -! totuflux- real, total sky upward flux (w/m2) 0:nlay ! -! totdflux- real, total sky downward flux (w/m2) 0:nlay ! -! htr - real, total sky heating rate (k/sec or k/day) nlay ! -! totuclfl- real, clear sky upward flux (w/m2) 0:nlay ! -! totdclfl- real, clear sky downward flux (w/m2) 0:nlay ! -! htrcl - real, clear sky heating rate (k/sec or k/day) nlay ! -! htrb - real, spectral band lw heating rate (k/day) nlay*nbands! -! ! -! module veriables: ! -! ngb - integer, band index for each g-value ngptlw! -! fluxfac - real, conversion factor for fluxes (pi*2.e4) 1 ! -! heatfac - real, conversion factor for heating rates (g/cp*1e-2) 1 ! -! tblint - real, conversion factor for look-up tbl (float(ntbl) 1 ! -! bpade - real, pade approx constant (1/0.278) 1 ! -! wtdiff - real, weight for radiance to flux conversion 1 ! -! ntbl - integer, dimension of look-up tables 1 ! -! tau_tbl - real, clr-sky opt dep lookup table 0:ntbl ! -! exp_tbl - real, transmittance lookup table 0:ntbl ! -! tfn_tbl - real, tau transition function 0:ntbl ! -! ! -! local variables: ! -! itgas - integer, index for gases contribution look-up table 1 ! -! ittot - integer, index for gases plus clouds look-up table 1 ! -! reflct - real, surface reflectance 1 ! -! atrgas - real, gaseous absorptivity 1 ! -! atrtot - real, gaseous and cloud absorptivity 1 ! -! odcld - real, cloud optical depth 1 ! -! odepth - real, optical depth of gaseous only 1 ! -! odtot - real, optical depth of gas and cloud 1 ! -! gasfac - real, gas-only pade factor, used for planck fn 1 ! -! totfac - real, gas+cld pade factor, used for planck fn 1 ! -! bbdgas - real, gas-only planck function for downward rt 1 ! -! bbugas - real, gas-only planck function for upward rt 1 ! -! bbdtot - real, gas and cloud planck function for downward rt 1 ! -! bbutot - real, gas and cloud planck function for upward rt 1 ! -! gassrcu- real, upwd source radiance due to gas only nlay! -! totsrcu- real, upwd source radiance due to gas + cld nlay! -! gassrcd- real, dnwd source radiance due to gas only 1 ! -! totsrcd- real, dnwd source radiance due to gas + cld 1 ! -! radtotu- real, spectrally summed total sky upwd radiance 1 ! -! radclru- real, spectrally summed clear sky upwd radiance 1 ! -! radtotd- real, spectrally summed total sky dnwd radiance 1 ! -! radclrd- real, spectrally summed clear sky dnwd radiance 1 ! -! toturad- real, total sky upward radiance by layer 0:nlay*nbands! -! clrurad- real, clear sky upward radiance by layer 0:nlay*nbands! -! totdrad- real, total sky downward radiance by layer 0:nlay*nbands! -! clrdrad- real, clear sky downward radiance by layer 0:nlay*nbands! -! fnet - real, net longwave flux (w/m2) 0:nlay ! -! fnetc - real, clear sky net longwave flux (w/m2) 0:nlay ! -! ! -! ! -! ******************************************************************* ! -! original code description ! -! ! -! original version: e. j. mlawer, et al. rrtm_v3.0 ! -! revision for gcms: michael j. iacono; october, 2002 ! -! revision for f90: michael j. iacono; june, 2006 ! -! ! -! this program calculates the upward fluxes, downward fluxes, and ! -! heating rates for an arbitrary clear or cloudy atmosphere. the input ! -! to this program is the atmospheric profile, all Planck function ! -! information, and the cloud fraction by layer. a variable diffusivity! -! angle (secdif) is used for the angle integration. bands 2-3 and 5-9 ! -! use a value for secdif that varies from 1.50 to 1.80 as a function ! -! of the column water vapor, and other bands use a value of 1.66. the ! -! gaussian weight appropriate to this angle (wtdiff=0.5) is applied ! -! here. note that use of the emissivity angle for the flux integration! -! can cause errors of 1 to 4 W/m2 within cloudy layers. ! -! clouds are treated with a maximum-random cloud overlap method. ! -! ! -! ******************************************************************* ! -! ====================== end of description block ================= ! - -! --- inputs: - integer, intent(in) :: nlay, nlp1 - - real (kind=kind_phys), dimension(0:nlp1), intent(in) :: cldfrc - real (kind=kind_phys), dimension(nbands), intent(in) :: semiss, & - & secdif - real (kind=kind_phys), dimension(nlay), intent(in) :: delp - - real (kind=kind_phys), dimension(nbands,nlay),intent(in):: taucld - real (kind=kind_phys), dimension(ngptlw,nlay),intent(in):: fracs, & - & tautot - - real (kind=kind_phys), dimension(nbands,0:nlay), intent(in) :: & - & pklev, pklay - -! --- outputs: - real (kind=kind_phys), dimension(nlay), intent(out) :: htr, htrcl - - real (kind=kind_phys), dimension(nlay,nbands),intent(out) :: htrb - - real (kind=kind_phys), dimension(0:nlay), intent(out) :: & - & totuflux, totdflux, totuclfl, totdclfl - -! --- locals: - real (kind=kind_phys), parameter :: rec_6 = 0.166667 - - real (kind=kind_phys), dimension(0:nlay,nbands) :: clrurad, & - & clrdrad, toturad, totdrad - - real (kind=kind_phys), dimension(nlay) :: gassrcu, totsrcu, & - & trngas, trntot, rfdelp - real (kind=kind_phys), dimension(0:nlay) :: fnet, fnetc - - real (kind=kind_phys) :: totsrcd, gassrcd, tblind, odepth, odtot, & - & odcld, atrtot, atrgas, reflct, totfac, gasfac, flxfac, & - & plfrac, blay, bbdgas, bbdtot, bbugas, bbutot, dplnku, & - & dplnkd, radtotu, radclru, radtotd, radclrd, rad0, rad, & - & totradd, clrradd, totradu, clrradu, fmax, fmin, rat1, rat2,& - & radmod, clfr, trng, trnt, gasu, totu - - integer :: ittot, itgas, ib, ig, k - -! dimensions for cloud overlap adjustment - real (kind=kind_phys), dimension(nlp1) :: faccld1u, faccld2u, & - & facclr1u, facclr2u, faccmb1u, faccmb2u - real (kind=kind_phys), dimension(0:nlay) :: faccld1d, faccld2d, & - & facclr1d, facclr2d, faccmb1d, faccmb2d - - logical :: lstcldu(nlay), lstcldd(nlay) -! -!===> ... begin here -! - do k = 1, nlp1 - faccld1u(k) = f_zero - faccld2u(k) = f_zero - facclr1u(k) = f_zero - facclr2u(k) = f_zero - faccmb1u(k) = f_zero - faccmb2u(k) = f_zero - enddo - - lstcldu(1) = cldfrc(1) > eps - rat1 = f_zero - rat2 = f_zero - - do k = 1, nlay-1 - - lstcldu(k+1) = cldfrc(k+1)>eps .and. cldfrc(k)<=eps - - if (cldfrc(k) > eps) then - -!> -# Setup maximum/random cloud overlap. - - if (cldfrc(k+1) >= cldfrc(k)) then - if (lstcldu(k)) then - if (cldfrc(k) < f_one) then - facclr2u(k+1) = (cldfrc(k+1) - cldfrc(k)) & - & / (f_one - cldfrc(k)) - endif - facclr2u(k) = f_zero - faccld2u(k) = f_zero - else - fmax = max(cldfrc(k), cldfrc(k-1)) - if (cldfrc(k+1) > fmax) then - facclr1u(k+1) = rat2 - facclr2u(k+1) = (cldfrc(k+1) - fmax)/(f_one - fmax) - elseif (cldfrc(k+1) < fmax) then - facclr1u(k+1) = (cldfrc(k+1) - cldfrc(k)) & - & / (cldfrc(k-1) - cldfrc(k)) - else - facclr1u(k+1) = rat2 - endif - endif - - if (facclr1u(k+1)>f_zero .or. facclr2u(k+1)>f_zero) then - rat1 = f_one - rat2 = f_zero - else - rat1 = f_zero - rat2 = f_zero - endif - else - if (lstcldu(k)) then - faccld2u(k+1) = (cldfrc(k) - cldfrc(k+1)) / cldfrc(k) - facclr2u(k) = f_zero - faccld2u(k) = f_zero - else - fmin = min(cldfrc(k), cldfrc(k-1)) - if (cldfrc(k+1) <= fmin) then - faccld1u(k+1) = rat1 - faccld2u(k+1) = (fmin - cldfrc(k+1)) / fmin - else - faccld1u(k+1) = (cldfrc(k) - cldfrc(k+1)) & - & / (cldfrc(k) - fmin) - endif - endif - - if (faccld1u(k+1)>f_zero .or. faccld2u(k+1)>f_zero) then - rat1 = f_zero - rat2 = f_one - else - rat1 = f_zero - rat2 = f_zero - endif - endif - - faccmb1u(k+1) = facclr1u(k+1) * faccld2u(k) * cldfrc(k-1) - faccmb2u(k+1) = faccld1u(k+1) * facclr2u(k) & - & * (f_one - cldfrc(k-1)) - endif - - enddo - - do k = 0, nlay - faccld1d(k) = f_zero - faccld2d(k) = f_zero - facclr1d(k) = f_zero - facclr2d(k) = f_zero - faccmb1d(k) = f_zero - faccmb2d(k) = f_zero - enddo - - lstcldd(nlay) = cldfrc(nlay) > eps - rat1 = f_zero - rat2 = f_zero - - do k = nlay, 2, -1 - - lstcldd(k-1) = cldfrc(k-1) > eps .and. cldfrc(k)<=eps - - if (cldfrc(k) > eps) then - - if (cldfrc(k-1) >= cldfrc(k)) then - if (lstcldd(k)) then - if (cldfrc(k) < f_one) then - facclr2d(k-1) = (cldfrc(k-1) - cldfrc(k)) & - & / (f_one - cldfrc(k)) - endif - - facclr2d(k) = f_zero - faccld2d(k) = f_zero - else - fmax = max(cldfrc(k), cldfrc(k+1)) - - if (cldfrc(k-1) > fmax) then - facclr1d(k-1) = rat2 - facclr2d(k-1) = (cldfrc(k-1) - fmax) / (f_one - fmax) - elseif (cldfrc(k-1) < fmax) then - facclr1d(k-1) = (cldfrc(k-1) - cldfrc(k)) & - & / (cldfrc(k+1) - cldfrc(k)) - else - facclr1d(k-1) = rat2 - endif - endif - - if (facclr1d(k-1)>f_zero .or. facclr2d(k-1)>f_zero) then - rat1 = f_one - rat2 = f_zero - else - rat1 = f_zero - rat2 = f_zero - endif - else - if (lstcldd(k)) then - faccld2d(k-1) = (cldfrc(k) - cldfrc(k-1)) / cldfrc(k) - facclr2d(k) = f_zero - faccld2d(k) = f_zero - else - fmin = min(cldfrc(k), cldfrc(k+1)) - - if (cldfrc(k-1) <= fmin) then - faccld1d(k-1) = rat1 - faccld2d(k-1) = (fmin - cldfrc(k-1)) / fmin - else - faccld1d(k-1) = (cldfrc(k) - cldfrc(k-1)) & - & / (cldfrc(k) - fmin) - endif - endif - - if (faccld1d(k-1)>f_zero .or. faccld2d(k-1)>f_zero) then - rat1 = f_zero - rat2 = f_one - else - rat1 = f_zero - rat2 = f_zero - endif - endif - - faccmb1d(k-1) = facclr1d(k-1) * faccld2d(k) * cldfrc(k+1) - faccmb2d(k-1) = faccld1d(k-1) * facclr2d(k) & - & * (f_one - cldfrc(k+1)) - endif - - enddo - -!> -# Initialize for radiative transfer - - do ib = 1, NBANDS - do k = 0, NLAY - toturad(k,ib) = f_zero - totdrad(k,ib) = f_zero - clrurad(k,ib) = f_zero - clrdrad(k,ib) = f_zero - enddo - enddo - - do k = 0, nlay - totuflux(k) = f_zero - totdflux(k) = f_zero - totuclfl(k) = f_zero - totdclfl(k) = f_zero - enddo - -! --- ... loop over all g-points - - do ig = 1, ngptlw - ib = ngb(ig) - - radtotd = f_zero - radclrd = f_zero - -!> -# Downward radiative transfer loop: - - do k = nlay, 1, -1 - -! --- ... clear sky, gases contribution - - odepth = max( f_zero, secdif(ib)*tautot(ig,k) ) - if (odepth <= 0.06) then - atrgas = odepth - 0.5*odepth*odepth - trng = f_one - atrgas - gasfac = rec_6 * odepth - else - tblind = odepth / (bpade + odepth) - itgas = tblint*tblind + 0.5 - trng = exp_tbl(itgas) - atrgas = f_one - trng - gasfac = tfn_tbl(itgas) - odepth = tau_tbl(itgas) - endif - - plfrac = fracs(ig,k) - blay = pklay(ib,k) - - dplnku = pklev(ib,k ) - blay - dplnkd = pklev(ib,k-1) - blay - bbdgas = plfrac * (blay + dplnkd*gasfac) - bbugas = plfrac * (blay + dplnku*gasfac) - gassrcd = bbdgas * atrgas - gassrcu(k)= bbugas * atrgas - trngas(k) = trng - -! --- ... total sky, gases+clouds contribution - - clfr = cldfrc(k) - if (lstcldd(k)) then - totradd = clfr * radtotd - clrradd = radtotd - totradd - rad = f_zero - endif - - if (clfr >= eps) then -!> - cloudy layer - - odcld = secdif(ib) * taucld(ib,k) - odtot = odepth + odcld - if (odtot < 0.06) then - totfac = rec_6 * odtot - atrtot = odtot - 0.5*odtot*odtot - trnt = f_one - atrtot - else - tblind = odtot / (bpade + odtot) - ittot = tblint*tblind + 0.5 - totfac = tfn_tbl(ittot) - trnt = exp_tbl(ittot) - atrtot = f_one - trnt - endif - - bbdtot = plfrac * (blay + dplnkd*totfac) - bbutot = plfrac * (blay + dplnku*totfac) - totsrcd = bbdtot * atrtot - totsrcu(k)= bbutot * atrtot - trntot(k) = trnt - - totradd = totradd*trnt + clfr*totsrcd - clrradd = clrradd*trng + (f_one - clfr)*gassrcd - -!> - total sky radiance - radtotd = totradd + clrradd - totdrad(k-1,ib) = totdrad(k-1,ib) + radtotd - -!> - clear sky radiance - radclrd = radclrd*trng + gassrcd - clrdrad(k-1,ib) = clrdrad(k-1,ib) + radclrd - - radmod = rad*(facclr1d(k-1)*trng + faccld1d(k-1)*trnt) & - & - faccmb1d(k-1)*gassrcd + faccmb2d(k-1)*totsrcd - - rad = -radmod + facclr2d(k-1)*(clrradd + radmod) & - & - faccld2d(k-1)*(totradd - radmod) - totradd = totradd + rad - clrradd = clrradd - rad - - else -! --- ... clear layer - -! --- ... total sky radiance - radtotd = radtotd*trng + gassrcd - totdrad(k-1,ib) = totdrad(k-1,ib) + radtotd - -! --- ... clear sky radiance - radclrd = radclrd*trng + gassrcd - clrdrad(k-1,ib) = clrdrad(k-1,ib) + radclrd - - endif ! end if_clfr_block - - enddo ! end do_k_loop - -!> -# Compute spectral emissivity & reflectance, include the -!! contribution of spectrally varying longwave emissivity and -!! reflection from the surface to the upward radiative transfer. - -! note: spectral and Lambertian reflection are identical for the -! diffusivity angle flux integration used here. - - reflct = f_one - semiss(ib) - rad0 = semiss(ib) * fracs(ig,1) * pklay(ib,0) - -!> -# Compute total sky radiance. - radtotu = rad0 + reflct*radtotd - toturad(0,ib) = toturad(0,ib) + radtotu - -!> -# Compute clear sky radiance. - radclru = rad0 + reflct*radclrd - clrurad(0,ib) = clrurad(0,ib) + radclru - -!> -# Upward radiative transfer loop: - - do k = 1, nlay - - clfr = cldfrc(k) - trng = trngas(k) - gasu = gassrcu(k) - - if (lstcldu(k)) then - totradu = clfr * radtotu - clrradu = radtotu - totradu - rad = f_zero - endif - - if (clfr >= eps) then -!> - cloudy layer radiance - - trnt = trntot(k) - totu = totsrcu(k) - totradu = totradu*trnt + clfr*totu - clrradu = clrradu*trng + (f_one - clfr)*gasu - -!> - total sky radiance - radtotu = totradu + clrradu - toturad(k,ib) = toturad(k,ib) + radtotu - -!> - clear sky radiance - radclru = radclru*trng + gasu - clrurad(k,ib) = clrurad(k,ib) + radclru - - radmod = rad*(facclr1u(k+1)*trng + faccld1u(k+1)*trnt) & - & - faccmb1u(k+1)*gasu + faccmb2u(k+1)*totu - rad = -radmod + facclr2u(k+1)*(clrradu + radmod) & - & - faccld2u(k+1)*(totradu - radmod) - totradu = totradu + rad - clrradu = clrradu - rad - - else -! --- ... clear layer - -! --- ... total sky radiance - radtotu = radtotu*trng + gasu - toturad(k,ib) = toturad(k,ib) + radtotu - -! --- ... clear sky radiance - radclru = radclru*trng + gasu - clrurad(k,ib) = clrurad(k,ib) + radclru - - endif ! end if_clfr_block - - enddo ! end do_k_loop - - enddo ! end do_ig_loop - -!> -# Process longwave output from band for total and clear streams. -!! calculate upward, downward, and net flux. - - flxfac = wtdiff * fluxfac - - do k = 0, nlay - do ib = 1, nbands - totuflux(k) = totuflux(k) + toturad(k,ib) - totdflux(k) = totdflux(k) + totdrad(k,ib) - totuclfl(k) = totuclfl(k) + clrurad(k,ib) - totdclfl(k) = totdclfl(k) + clrdrad(k,ib) - enddo - - totuflux(k) = totuflux(k) * flxfac - totdflux(k) = totdflux(k) * flxfac - totuclfl(k) = totuclfl(k) * flxfac - totdclfl(k) = totdclfl(k) * flxfac - enddo - -! --- ... calculate net fluxes and heating rates - fnet(0) = totuflux(0) - totdflux(0) - - do k = 1, nlay - rfdelp(k) = heatfac / delp(k) - fnet(k) = totuflux(k) - totdflux(k) - htr (k) = (fnet(k-1) - fnet(k)) * rfdelp(k) - enddo - -!! --- ... optional clear sky heating rates - if ( lhlw0 ) then - fnetc(0) = totuclfl(0) - totdclfl(0) - - do k = 1, nlay - fnetc(k) = totuclfl(k) - totdclfl(k) - htrcl(k) = (fnetc(k-1) - fnetc(k)) * rfdelp(k) - enddo - endif - -!! --- ... optional spectral band heating rates - if ( lhlwb ) then - do ib = 1, nbands - fnet(0) = (toturad(0,ib) - totdrad(0,ib)) * flxfac - - do k = 1, nlay - fnet(k) = (toturad(k,ib) - totdrad(k,ib)) * flxfac - htrb(k,ib) = (fnet(k-1) - fnet(k)) * rfdelp(k) - enddo - enddo - endif - -! ................................. - end subroutine rtrnmr -! --------------------------------- -!> @} - -!>\ingroup module_radlw_main -!> \brief This subroutine computes the upward/downward radiative fluxes, and -!! heating rates for both clear or cloudy atmosphere.Clouds are treated -!! with the mcica stochastic approach. -!! -!!\param semiss lw surface emissivity -!!\param delp layer pressure thickness (mb) -!!\param cldfmc layer cloud fraction (sub-column) -!!\param taucld layer cloud opt depth -!!\param tautot total optical depth (gas+aerosols) -!!\param pklay integrated planck func at lay temp -!!\param pklev integrated planck func at lev temp -!!\param fracs planck fractions -!!\param secdif secant of diffusivity angle -!!\param nlay number of vertical layers -!!\param nlp1 number of vertical levels (interfaces) -!!\param totuflux total sky upward flux \f$(w/m^2)\f$ -!!\param totdflux total sky downward flux \f$(w/m^2)\f$ -!!\param htr total sky heating rate (k/sec or k/day) -!!\param totuclfl clear sky upward flux \f$(w/m^2)\f$ -!!\param totdclfl clear sky downward flux \f$(w/m^2)\f$ -!!\param htrcl clear sky heating rate (k/sec or k/day) -!!\param htrb spectral band lw heating rate (k/day) -!!\section gen_rtrnmc rtrnmc General Algorithm -!> @{ -! --------------------------------- - subroutine rtrnmc & - & ( semiss,delp,cldfmc,taucld,tautot,pklay,pklev, & ! --- inputs: - & fracs,secdif, nlay,nlp1, & - & totuflux,totdflux,htr, totuclfl,totdclfl,htrcl, htrb & ! --- outputs: - & ) - -! =================== program usage description =================== ! -! ! -! purpose: compute the upward/downward radiative fluxes, and heating ! -! rates for both clear or cloudy atmosphere. clouds are treated with ! -! the mcica stochastic approach. ! -! ! -! subprograms called: none ! -! ! -! ==================== defination of variables ==================== ! -! ! -! inputs: -size- ! -! semiss - real, lw surface emissivity nbands! -! delp - real, layer pressure thickness (mb) nlay ! -! cldfmc - real, layer cloud fraction (sub-column) ngptlw*nlay! -! taucld - real, layer cloud opt depth nbands*nlay! -! tautot - real, total optical depth (gas+aerosols) ngptlw*nlay! -! pklay - real, integrated planck func at lay temp nbands*0:nlay! -! pklev - real, integrated planck func at lev temp nbands*0:nlay! -! fracs - real, planck fractions ngptlw*nlay! -! secdif - real, secant of diffusivity angle nbands! -! nlay - integer, number of vertical layers 1 ! -! nlp1 - integer, number of vertical levels (interfaces) 1 ! -! ! -! outputs: ! -! totuflux- real, total sky upward flux (w/m2) 0:nlay ! -! totdflux- real, total sky downward flux (w/m2) 0:nlay ! -! htr - real, total sky heating rate (k/sec or k/day) nlay ! -! totuclfl- real, clear sky upward flux (w/m2) 0:nlay ! -! totdclfl- real, clear sky downward flux (w/m2) 0:nlay ! -! htrcl - real, clear sky heating rate (k/sec or k/day) nlay ! -! htrb - real, spectral band lw heating rate (k/day) nlay*nbands! -! ! -! module veriables: ! -! ngb - integer, band index for each g-value ngptlw! -! fluxfac - real, conversion factor for fluxes (pi*2.e4) 1 ! -! heatfac - real, conversion factor for heating rates (g/cp*1e-2) 1 ! -! tblint - real, conversion factor for look-up tbl (float(ntbl) 1 ! -! bpade - real, pade approx constant (1/0.278) 1 ! -! wtdiff - real, weight for radiance to flux conversion 1 ! -! ntbl - integer, dimension of look-up tables 1 ! -! tau_tbl - real, clr-sky opt dep lookup table 0:ntbl ! -! exp_tbl - real, transmittance lookup table 0:ntbl ! -! tfn_tbl - real, tau transition function 0:ntbl ! -! ! -! local variables: ! -! itgas - integer, index for gases contribution look-up table 1 ! -! ittot - integer, index for gases plus clouds look-up table 1 ! -! reflct - real, surface reflectance 1 ! -! atrgas - real, gaseous absorptivity 1 ! -! atrtot - real, gaseous and cloud absorptivity 1 ! -! odcld - real, cloud optical depth 1 ! -! efclrfr- real, effective clear sky fraction (1-efcldfr) nlay! -! odepth - real, optical depth of gaseous only 1 ! -! odtot - real, optical depth of gas and cloud 1 ! -! gasfac - real, gas-only pade factor, used for planck function 1 ! -! totfac - real, gas and cloud pade factor, used for planck fn 1 ! -! bbdgas - real, gas-only planck function for downward rt 1 ! -! bbugas - real, gas-only planck function for upward rt 1 ! -! bbdtot - real, gas and cloud planck function for downward rt 1 ! -! bbutot - real, gas and cloud planck function for upward rt 1 ! -! gassrcu- real, upwd source radiance due to gas nlay! -! totsrcu- real, upwd source radiance due to gas+cld nlay! -! gassrcd- real, dnwd source radiance due to gas 1 ! -! totsrcd- real, dnwd source radiance due to gas+cld 1 ! -! radtotu- real, spectrally summed total sky upwd radiance 1 ! -! radclru- real, spectrally summed clear sky upwd radiance 1 ! -! radtotd- real, spectrally summed total sky dnwd radiance 1 ! -! radclrd- real, spectrally summed clear sky dnwd radiance 1 ! -! toturad- real, total sky upward radiance by layer 0:nlay*nbands! -! clrurad- real, clear sky upward radiance by layer 0:nlay*nbands! -! totdrad- real, total sky downward radiance by layer 0:nlay*nbands! -! clrdrad- real, clear sky downward radiance by layer 0:nlay*nbands! -! fnet - real, net longwave flux (w/m2) 0:nlay ! -! fnetc - real, clear sky net longwave flux (w/m2) 0:nlay ! -! ! -! ! -! ******************************************************************* ! -! original code description ! -! ! -! original version: e. j. mlawer, et al. rrtm_v3.0 ! -! revision for gcms: michael j. iacono; october, 2002 ! -! revision for f90: michael j. iacono; june, 2006 ! -! ! -! this program calculates the upward fluxes, downward fluxes, and ! -! heating rates for an arbitrary clear or cloudy atmosphere. the input ! -! to this program is the atmospheric profile, all Planck function ! -! information, and the cloud fraction by layer. a variable diffusivity! -! angle (secdif) is used for the angle integration. bands 2-3 and 5-9 ! -! use a value for secdif that varies from 1.50 to 1.80 as a function ! -! of the column water vapor, and other bands use a value of 1.66. the ! -! gaussian weight appropriate to this angle (wtdiff=0.5) is applied ! -! here. note that use of the emissivity angle for the flux integration! -! can cause errors of 1 to 4 W/m2 within cloudy layers. ! -! clouds are treated with the mcica stochastic approach and ! -! maximum-random cloud overlap. ! -! ! -! ******************************************************************* ! -! ====================== end of description block ================= ! - -! --- inputs: - integer, intent(in) :: nlay, nlp1 - - real (kind=kind_phys), dimension(nbands), intent(in) :: semiss, & - & secdif - real (kind=kind_phys), dimension(nlay), intent(in) :: delp - - real (kind=kind_phys), dimension(nbands,nlay),intent(in):: taucld - real (kind=kind_phys), dimension(ngptlw,nlay),intent(in):: fracs, & - & tautot, cldfmc - - real (kind=kind_phys), dimension(nbands,0:nlay), intent(in) :: & - & pklev, pklay - -! --- outputs: - real (kind=kind_phys), dimension(nlay), intent(out) :: htr, htrcl - - real (kind=kind_phys), dimension(nlay,nbands),intent(out) :: htrb - - real (kind=kind_phys), dimension(0:nlay), intent(out) :: & - & totuflux, totdflux, totuclfl, totdclfl - -! --- locals: - real (kind=kind_phys), parameter :: rec_6 = 0.166667 - - real (kind=kind_phys), dimension(0:nlay,nbands) :: clrurad, & - & clrdrad, toturad, totdrad - - real (kind=kind_phys), dimension(nlay) :: gassrcu, totsrcu, & - & trngas, efclrfr, rfdelp - real (kind=kind_phys), dimension(0:nlay) :: fnet, fnetc - - real (kind=kind_phys) :: totsrcd, gassrcd, tblind, odepth, odtot, & - & odcld, atrtot, atrgas, reflct, totfac, gasfac, flxfac, & - & plfrac, blay, bbdgas, bbdtot, bbugas, bbutot, dplnku, & - & dplnkd, radtotu, radclru, radtotd, radclrd, rad0, & - & clfm, trng, gasu - - integer :: ittot, itgas, ib, ig, k -! -!===> ... begin here -! - do ib = 1, NBANDS - do k = 0, NLAY - toturad(k,ib) = f_zero - totdrad(k,ib) = f_zero - clrurad(k,ib) = f_zero - clrdrad(k,ib) = f_zero - enddo - enddo - - do k = 0, nlay - totuflux(k) = f_zero - totdflux(k) = f_zero - totuclfl(k) = f_zero - totdclfl(k) = f_zero - enddo - -! --- ... loop over all g-points - - do ig = 1, ngptlw - ib = ngb(ig) - - radtotd = f_zero - radclrd = f_zero - -!> -# Downward radiative transfer loop. -!!\n - Clear sky, gases contribution -!!\n - Total sky, gases+clouds contribution -!!\n - Cloudy layer -!!\n - Total sky radiance -!!\n - Clear sky radiance - - do k = nlay, 1, -1 - -! --- ... clear sky, gases contribution - - odepth = max( f_zero, secdif(ib)*tautot(ig,k) ) - if (odepth <= 0.06) then - atrgas = odepth - 0.5*odepth*odepth - trng = f_one - atrgas - gasfac = rec_6 * odepth - else - tblind = odepth / (bpade + odepth) - itgas = tblint*tblind + 0.5 - trng = exp_tbl(itgas) - atrgas = f_one - trng - gasfac = tfn_tbl(itgas) - odepth = tau_tbl(itgas) - endif - - plfrac = fracs(ig,k) - blay = pklay(ib,k) - - dplnku = pklev(ib,k ) - blay - dplnkd = pklev(ib,k-1) - blay - bbdgas = plfrac * (blay + dplnkd*gasfac) - bbugas = plfrac * (blay + dplnku*gasfac) - gassrcd= bbdgas * atrgas - gassrcu(k)= bbugas * atrgas - trngas(k) = trng - -! --- ... total sky, gases+clouds contribution - - clfm = cldfmc(ig,k) - if (clfm >= eps) then -! --- ... cloudy layer - - odcld = secdif(ib) * taucld(ib,k) - efclrfr(k) = f_one - (f_one - exp(-odcld))*clfm - odtot = odepth + odcld - if (odtot < 0.06) then - totfac = rec_6 * odtot - atrtot = odtot - 0.5*odtot*odtot - else - tblind = odtot / (bpade + odtot) - ittot = tblint*tblind + 0.5 - totfac = tfn_tbl(ittot) - atrtot = f_one - exp_tbl(ittot) - endif - - bbdtot = plfrac * (blay + dplnkd*totfac) - bbutot = plfrac * (blay + dplnku*totfac) - totsrcd= bbdtot * atrtot - totsrcu(k)= bbutot * atrtot - -! --- ... total sky radiance - radtotd = radtotd*trng*efclrfr(k) + gassrcd & - & + clfm*(totsrcd - gassrcd) - totdrad(k-1,ib) = totdrad(k-1,ib) + radtotd - -! --- ... clear sky radiance - radclrd = radclrd*trng + gassrcd - clrdrad(k-1,ib) = clrdrad(k-1,ib) + radclrd - - else -! --- ... clear layer - -! --- ... total sky radiance - radtotd = radtotd*trng + gassrcd - totdrad(k-1,ib) = totdrad(k-1,ib) + radtotd - -! --- ... clear sky radiance - radclrd = radclrd*trng + gassrcd - clrdrad(k-1,ib) = clrdrad(k-1,ib) + radclrd - - endif ! end if_clfm_block - - enddo ! end do_k_loop - -!> -# Compute spectral emissivity & reflectance, include the -!! contribution of spectrally varying longwave emissivity and -!! reflection from the surface to the upward radiative transfer. - -! note: spectral and Lambertian reflection are identical for the -! diffusivity angle flux integration used here. - - reflct = f_one - semiss(ib) - rad0 = semiss(ib) * fracs(ig,1) * pklay(ib,0) - -!> -# Compute total sky radiance. - radtotu = rad0 + reflct*radtotd - toturad(0,ib) = toturad(0,ib) + radtotu - -!> -# Compute clear sky radiance. - radclru = rad0 + reflct*radclrd - clrurad(0,ib) = clrurad(0,ib) + radclru - -!> -# Upward radiative transfer loop. -!!\n - Compute total sky radiance -!!\n - Compute clear sky radiance - -! toturad holds summed radiance for total sky stream -! clrurad holds summed radiance for clear sky stream - - do k = 1, nlay - clfm = cldfmc(ig,k) - trng = trngas(k) - gasu = gassrcu(k) - - if (clfm > eps) then -! --- ... cloudy layer - -! --- ... total sky radiance - radtotu = radtotu*trng*efclrfr(k) + gasu & - & + clfm*(totsrcu(k) - gasu) - toturad(k,ib) = toturad(k,ib) + radtotu - -! --- ... clear sky radiance - radclru = radclru*trng + gasu - clrurad(k,ib) = clrurad(k,ib) + radclru - - else -! --- ... clear layer - -! --- ... total sky radiance - radtotu = radtotu*trng + gasu - toturad(k,ib) = toturad(k,ib) + radtotu - -! --- ... clear sky radiance - radclru = radclru*trng + gasu - clrurad(k,ib) = clrurad(k,ib) + radclru - - endif ! end if_clfm_block - - enddo ! end do_k_loop - - enddo ! end do_ig_loop - -!> -# Process longwave output from band for total and clear streams. -!! Calculate upward, downward, and net flux. - - flxfac = wtdiff * fluxfac - - do k = 0, nlay - do ib = 1, nbands - totuflux(k) = totuflux(k) + toturad(k,ib) - totdflux(k) = totdflux(k) + totdrad(k,ib) - totuclfl(k) = totuclfl(k) + clrurad(k,ib) - totdclfl(k) = totdclfl(k) + clrdrad(k,ib) - enddo - - totuflux(k) = totuflux(k) * flxfac - totdflux(k) = totdflux(k) * flxfac - totuclfl(k) = totuclfl(k) * flxfac - totdclfl(k) = totdclfl(k) * flxfac - enddo - -!> -# Calculate net fluxes and heating rates. - fnet(0) = totuflux(0) - totdflux(0) - - do k = 1, nlay - rfdelp(k) = heatfac / delp(k) - fnet(k) = totuflux(k) - totdflux(k) - htr (k) = (fnet(k-1) - fnet(k)) * rfdelp(k) - enddo - -!> -# Optional clear sky heating rates. - if ( lhlw0 ) then - fnetc(0) = totuclfl(0) - totdclfl(0) - - do k = 1, nlay - fnetc(k) = totuclfl(k) - totdclfl(k) - htrcl(k) = (fnetc(k-1) - fnetc(k)) * rfdelp(k) - enddo - endif - -!> -# Optional spectral band heating rates. - if ( lhlwb ) then - do ib = 1, nbands - fnet(0) = (toturad(0,ib) - totdrad(0,ib)) * flxfac - - do k = 1, nlay - fnet(k) = (toturad(k,ib) - totdrad(k,ib)) * flxfac - htrb(k,ib) = (fnet(k-1) - fnet(k)) * rfdelp(k) - enddo - enddo - endif - -! .................................. - end subroutine rtrnmc -! ---------------------------------- -!> @} - -!>\ingroup module_radlw_main -!>\brief This subroutine contains optical depths developed for the rapid -!! radiative transfer model. -!! -!! It contains the subroutines \a taugbn (where n goes from -!! 1 to 16). \a taugbn calculates the optical depths and planck fractions -!! per g-value and layer for band n. -!!\param laytrop tropopause layer index (unitless) layer at -!! which switch is made for key species -!!\param pavel layer pressures (mb) -!!\param coldry column amount for dry air \f$(mol/cm^2)\f$ -!!\param colamt column amounts of h2o, co2, o3, n2o, ch4,o2, -!! co \f$(mol/cm^2)\f$ -!!\param colbrd column amount of broadening gases -!!\param wx cross-section amounts \f$(mol/cm^2)\f$ -!!\param tauaer aerosol optical depth -!!\param rfrate reference ratios of binary species parameter -!!\n (:,m,:)m=1-h2o/co2,2-h2o/o3,3-h2o/n2o,4-h2o/ch4, -!! 5-n2o/co2,6-o3/co2 -!!\n (:,:,n)n=1,2: the rates of ref press at the 2 -!! sides of the layer -!!\param fac00,fac01,fac10,fac11 factors multiply the reference ks, i,j of 0/1 -!! for lower/higher of the 2 appropriate -!! temperatures and altitudes -!!\param jp index of lower reference pressure -!!\param jt, jt1 indices of lower reference temperatures for -!! pressure levels jp and jp+1, respectively -!!\param selffac scale factor for water vapor self-continuum -!! equals (water vapor density)/(atmospheric -!! density at 296k and 1013 mb) -!!\param selffrac factor for temperature interpolation of -!! reference water vapor self-continuum data -!!\param indself index of lower reference temperature for the -!! self-continuum interpolation -!!\param forfac scale factor for w. v. foreign-continuum -!!\param forfrac factor for temperature interpolation of -!! reference w.v. foreign-continuum data -!!\param indfor index of lower reference temperature for the -!! foreign-continuum interpolation -!!\param minorfrac factor for minor gases -!!\param scaleminor,scaleminorn2 scale factors for minor gases -!!\param indminor index of lower reference temperature for -!! minor gases -!!\param nlay total number of layers -!!\param fracs planck fractions -!!\param tautot total optical depth (gas+aerosols) -!>\section taumol_gen taumol General Algorithm -!! @{ -!! subprograms called: taugb## (## = 01 -16) - subroutine taumol & - & ( laytrop,pavel,coldry,colamt,colbrd,wx,tauaer, & ! --- inputs - & rfrate,fac00,fac01,fac10,fac11,jp,jt,jt1, & - & selffac,selffrac,indself,forfac,forfrac,indfor, & - & minorfrac,scaleminor,scaleminorn2,indminor, & - & nlay, & - & fracs, tautot & ! --- outputs - & ) - -! ************ original subprogram description *************** ! -! ! -! optical depths developed for the ! -! ! -! rapid radiative transfer model (rrtm) ! -! ! -! atmospheric and environmental research, inc. ! -! 131 hartwell avenue ! -! lexington, ma 02421 ! -! ! -! eli j. mlawer ! -! jennifer delamere ! -! steven j. taubman ! -! shepard a. clough ! -! ! -! email: mlawer@aer.com ! -! email: jdelamer@aer.com ! -! ! -! the authors wish to acknowledge the contributions of the ! -! following people: karen cady-pereira, patrick d. brown, ! -! michael j. iacono, ronald e. farren, luke chen, ! -! robert bergstrom. ! -! ! -! revision for g-point reduction: michael j. iacono; aer, inc. ! -! ! -! taumol ! -! ! -! this file contains the subroutines taugbn (where n goes from ! -! 1 to 16). taugbn calculates the optical depths and planck ! -! fractions per g-value and layer for band n. ! -! ! -! ******************************************************************* ! -! ================== program usage description ================== ! -! ! -! call taumol ! -! inputs: ! -! ( laytrop,pavel,coldry,colamt,colbrd,wx,tauaer, ! -! rfrate,fac00,fac01,fac10,fac11,jp,jt,jt1, ! -! selffac,selffrac,indself,forfac,forfrac,indfor, ! -! minorfrac,scaleminor,scaleminorn2,indminor, ! -! nlay, ! -! outputs: ! -! fracs, tautot ) ! -! ! -! subprograms called: taugb## (## = 01 -16) ! -! ! -! ! -! ==================== defination of variables ==================== ! -! ! -! inputs: size ! -! laytrop - integer, tropopause layer index (unitless) 1 ! -! layer at which switch is made for key species ! -! pavel - real, layer pressures (mb) nlay ! -! coldry - real, column amount for dry air (mol/cm2) nlay ! -! colamt - real, column amounts of h2o, co2, o3, n2o, ch4, ! -! o2, co (mol/cm**2) nlay*maxgas! -! colbrd - real, column amount of broadening gases nlay ! -! wx - real, cross-section amounts(mol/cm2) nlay*maxxsec! -! tauaer - real, aerosol optical depth nbands*nlay ! -! rfrate - real, reference ratios of binary species parameter ! -! (:,m,:)m=1-h2o/co2,2-h2o/o3,3-h2o/n2o,4-h2o/ch4,5-n2o/co2,6-o3/co2! -! (:,:,n)n=1,2: the rates of ref press at the 2 sides of the layer ! -! nlay*nrates*2! -! facij - real, factors multiply the reference ks, i,j of 0/1 ! -! for lower/higher of the 2 appropriate temperatures ! -! and altitudes nlay ! -! jp - real, index of lower reference pressure nlay ! -! jt, jt1 - real, indices of lower reference temperatures nlay ! -! for pressure levels jp and jp+1, respectively ! -! selffac - real, scale factor for water vapor self-continuum ! -! equals (water vapor density)/(atmospheric density ! -! at 296k and 1013 mb) nlay ! -! selffrac - real, factor for temperature interpolation of ! -! reference water vapor self-continuum data nlay ! -! indself - integer, index of lower reference temperature for ! -! the self-continuum interpolation nlay ! -! forfac - real, scale factor for w. v. foreign-continuum nlay ! -! forfrac - real, factor for temperature interpolation of ! -! reference w.v. foreign-continuum data nlay ! -! indfor - integer, index of lower reference temperature for ! -! the foreign-continuum interpolation nlay ! -! minorfrac - real, factor for minor gases nlay ! -! scaleminor,scaleminorn2 ! -! - real, scale factors for minor gases nlay ! -! indminor - integer, index of lower reference temperature for ! -! minor gases nlay ! -! nlay - integer, total number of layers 1 ! -! ! -! outputs: ! -! fracs - real, planck fractions ngptlw,nlay! -! tautot - real, total optical depth (gas+aerosols) ngptlw,nlay! -! ! -! internal variables: ! -! ng## - integer, number of g-values in band ## (##=01-16) 1 ! -! nspa - integer, for lower atmosphere, the number of ref ! -! atmos, each has different relative amounts of the ! -! key species for the band nbands! -! nspb - integer, same but for upper atmosphere nbands! -! absa - real, k-values for lower ref atmospheres (no w.v. ! -! self-continuum) (cm**2/molecule) nspa(##)*5*13*ng##! -! absb - real, k-values for high ref atmospheres (all sources) ! -! (cm**2/molecule) nspb(##)*5*13:59*ng##! -! ka_m'mgas'- real, k-values for low ref atmospheres minor species ! -! (cm**2/molecule) mmn##*ng##! -! kb_m'mgas'- real, k-values for high ref atmospheres minor species ! -! (cm**2/molecule) mmn##*ng##! -! selfref - real, k-values for w.v. self-continuum for ref atmos ! -! used below laytrop (cm**2/mol) 10*ng##! -! forref - real, k-values for w.v. foreign-continuum for ref atmos -! used below/above laytrop (cm**2/mol) 4*ng##! -! ! -! ****************************************************************** ! - -! --- inputs: - integer, intent(in) :: nlay, laytrop - - integer, dimension(nlay), intent(in) :: jp, jt, jt1, indself, & - & indfor, indminor - - real (kind=kind_phys), dimension(nlay), intent(in) :: pavel, & - & coldry, colbrd, fac00, fac01, fac10, fac11, selffac, & - & selffrac, forfac, forfrac, minorfrac, scaleminor, & - & scaleminorn2 - - real (kind=kind_phys), dimension(nlay,maxgas), intent(in):: colamt - real (kind=kind_phys), dimension(nlay,maxxsec),intent(in):: wx - - real (kind=kind_phys), dimension(nbands,nlay), intent(in):: tauaer - - real (kind=kind_phys), dimension(nlay,nrates,2), intent(in) :: & - & rfrate - -! --- outputs: - real (kind=kind_phys), dimension(ngptlw,nlay), intent(out) :: & - & fracs, tautot - -! --- locals - real (kind=kind_phys), dimension(ngptlw,nlay) :: taug - - integer :: ib, ig, k -! -!===> ... begin here -! - call taugb01 - call taugb02 - call taugb03 - call taugb04 - call taugb05 - call taugb06 - call taugb07 - call taugb08 - call taugb09 - call taugb10 - call taugb11 - call taugb12 - call taugb13 - call taugb14 - call taugb15 - call taugb16 - -! --- combine gaseous and aerosol optical depths - - do ig = 1, ngptlw - ib = ngb(ig) - - do k = 1, nlay - tautot(ig,k) = taug(ig,k) + tauaer(ib,k) - enddo - enddo - -! ================= - contains -! ================= - -!>\ingroup module_radlw_main -!> band 1: 10-350 cm-1 (low key - h2o; low minor - n2); -!! (high key - h2o; high minor - n2) -! ---------------------------------- - subroutine taugb01 -! .................................. - -! ------------------------------------------------------------------ ! -! written by eli j. mlawer, atmospheric & environmental research. ! -! revised by michael j. iacono, atmospheric & environmental research. ! -! ! -! band 1: 10-350 cm-1 (low key - h2o; low minor - n2) ! -! (high key - h2o; high minor - n2) ! -! ! -! compute the optical depth by interpolating in ln(pressure) and ! -! temperature. below laytrop, the water vapor self-continuum and ! -! foreign continuum is interpolated (in temperature) separately. ! -! ------------------------------------------------------------------ ! - - use module_radlw_kgb01 - -! --- locals: - integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, & - & indm, indmp, ig - - real (kind=kind_phys) :: pp, corradj, scalen2, tauself, taufor, & - & taun2 -! -!===> ... begin here -! -! --- minor gas mapping levels: -! lower - n2, p = 142.5490 mbar, t = 215.70 k -! upper - n2, p = 142.5490 mbar, t = 215.70 k - -! --- ... lower atmosphere loop - - do k = 1, laytrop - ind0 = ((jp(k)-1)*5 + (jt (k)-1)) * nspa(1) + 1 - ind1 = ( jp(k) *5 + (jt1(k)-1)) * nspa(1) + 1 - inds = indself(k) - indf = indfor(k) - indm = indminor(k) - - ind0p = ind0 + 1 - ind1p = ind1 + 1 - indsp = inds + 1 - indfp = indf + 1 - indmp = indm + 1 - - pp = pavel(k) - scalen2 = colbrd(k) * scaleminorn2(k) - if (pp < 250.0) then - corradj = f_one - 0.15 * (250.0-pp) / 154.4 - else - corradj = f_one - endif - - do ig = 1, ng01 - tauself = selffac(k) * (selfref(ig,inds) + selffrac(k) & - & * (selfref(ig,indsp) - selfref(ig,inds))) - taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & - & * (forref(ig,indfp) - forref(ig,indf))) - taun2 = scalen2 * (ka_mn2(ig,indm) + minorfrac(k) & - & * (ka_mn2(ig,indmp) - ka_mn2(ig,indm))) - - taug(ig,k) = corradj * (colamt(k,1) & - & * (fac00(k)*absa(ig,ind0) + fac10(k)*absa(ig,ind0p) & - & + fac01(k)*absa(ig,ind1) + fac11(k)*absa(ig,ind1p)) & - & + tauself + taufor + taun2) - - fracs(ig,k) = fracrefa(ig) - enddo - enddo - -! --- ... upper atmosphere loop - - do k = laytrop+1, nlay - ind0 = ((jp(k)-13)*5 + (jt (k)-1)) * nspb(1) + 1 - ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(1) + 1 - indf = indfor(k) - indm = indminor(k) - - ind0p = ind0 + 1 - ind1p = ind1 + 1 - indfp = indf + 1 - indmp = indm + 1 - - scalen2 = colbrd(k) * scaleminorn2(k) - corradj = f_one - 0.15 * (pavel(k) / 95.6) - - do ig = 1, ng01 - taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & - & * (forref(ig,indfp) - forref(ig,indf))) - taun2 = scalen2 * (kb_mn2(ig,indm) + minorfrac(k) & - & * (kb_mn2(ig,indmp) - kb_mn2(ig,indm))) - - taug(ig,k) = corradj * (colamt(k,1) & - & * (fac00(k)*absb(ig,ind0) + fac10(k)*absb(ig,ind0p) & - & + fac01(k)*absb(ig,ind1) + fac11(k)*absb(ig,ind1p)) & - & + taufor + taun2) - - fracs(ig,k) = fracrefb(ig) - enddo - enddo - -! .................................. - end subroutine taugb01 -! ---------------------------------- - -!>\ingroup module_radlw_main -!> Band 2: 350-500 cm-1 (low key - h2o; high key - h2o) -! ---------------------------------- - subroutine taugb02 -! .................................. - -! ------------------------------------------------------------------ ! -! band 2: 350-500 cm-1 (low key - h2o; high key - h2o) ! -! ------------------------------------------------------------------ ! - - use module_radlw_kgb02 - -! --- locals: - integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, & - & ig - - real (kind=kind_phys) :: corradj, tauself, taufor -! -!===> ... begin here -! -! --- ... lower atmosphere loop - - do k = 1, laytrop - ind0 = ((jp(k)-1)*5 + (jt (k)-1)) * nspa(2) + 1 - ind1 = ( jp(k) *5 + (jt1(k)-1)) * nspa(2) + 1 - inds = indself(k) - indf = indfor(k) - - ind0p = ind0 + 1 - ind1p = ind1 + 1 - indsp = inds + 1 - indfp = indf + 1 - - corradj = f_one - 0.05 * (pavel(k) - 100.0) / 900.0 - - do ig = 1, ng02 - tauself = selffac(k) * (selfref(ig,inds) + selffrac(k) & - & * (selfref(ig,indsp) - selfref(ig,inds))) - taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & - & * (forref(ig,indfp) - forref(ig,indf))) - - taug(ns02+ig,k) = corradj * (colamt(k,1) & - & * (fac00(k)*absa(ig,ind0) + fac10(k)*absa(ig,ind0p) & - & + fac01(k)*absa(ig,ind1) + fac11(k)*absa(ig,ind1p)) & - & + tauself + taufor) - - fracs(ns02+ig,k) = fracrefa(ig) - enddo - enddo - -! --- ... upper atmosphere loop - - do k = laytrop+1, nlay - ind0 = ((jp(k)-13)*5 + (jt (k)-1)) * nspb(2) + 1 - ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(2) + 1 - indf = indfor(k) - - ind0p = ind0 + 1 - ind1p = ind1 + 1 - indfp = indf + 1 - - do ig = 1, ng02 - taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & - & * (forref(ig,indfp) - forref(ig,indf))) - - taug(ns02+ig,k) = colamt(k,1) & - & * (fac00(k)*absb(ig,ind0) + fac10(k)*absb(ig,ind0p) & - & + fac01(k)*absb(ig,ind1) + fac11(k)*absb(ig,ind1p)) & - & + taufor - - fracs(ns02+ig,k) = fracrefb(ig) - enddo - enddo - -! .................................. - end subroutine taugb02 -! ---------------------------------- - -!>\ingroup module_radlw_main -!> Band 3: 500-630 cm-1 (low key - h2o,co2; low minor - n2o); -!! (high key - h2o,co2; high minor - n2o) -! ---------------------------------- - subroutine taugb03 -! .................................. - -! ------------------------------------------------------------------ ! -! band 3: 500-630 cm-1 (low key - h2o,co2; low minor - n2o) ! -! (high key - h2o,co2; high minor - n2o) ! -! ------------------------------------------------------------------ ! - - use module_radlw_kgb03 - -! --- locals: - integer :: k, ind0, ind1, inds, indsp, indf, indfp, indm, indmp, & - & id000, id010, id100, id110, id200, id210, jmn2o, jmn2op, & - & id001, id011, id101, id111, id201, id211, jpl, jplp, & - & ig, js, js1 - - real (kind=kind_phys) :: absn2o, ratn2o, adjfac, adjcoln2o, & - & speccomb, specparm, specmult, fs, & - & speccomb1, specparm1, specmult1, fs1, & - & speccomb_mn2o, specparm_mn2o, specmult_mn2o, fmn2o, & - & speccomb_planck,specparm_planck,specmult_planck,fpl, & - & refrat_planck_a, refrat_planck_b, refrat_m_a, refrat_m_b, & - & fac000, fac100, fac200, fac010, fac110, fac210, & - & fac001, fac101, fac201, fac011, fac111, fac211, & - & tau_major, tau_major1, tauself, taufor, n2om1, n2om2, & - & p, p4, fk0, fk1, fk2 -! -!===> ... begin here -! -! --- ... minor gas mapping levels: -! lower - n2o, p = 706.272 mbar, t = 278.94 k -! upper - n2o, p = 95.58 mbar, t = 215.7 k - - refrat_planck_a = chi_mls(1,9)/chi_mls(2,9) ! P = 212.725 mb - refrat_planck_b = chi_mls(1,13)/chi_mls(2,13) ! P = 95.58 mb - refrat_m_a = chi_mls(1,3)/chi_mls(2,3) ! P = 706.270 mb - refrat_m_b = chi_mls(1,13)/chi_mls(2,13) ! P = 95.58 mb - -! --- ... lower atmosphere loop - - do k = 1, laytrop - speccomb = colamt(k,1) + rfrate(k,1,1)*colamt(k,2) - specparm = colamt(k,1) / speccomb - specmult = 8.0 * min(specparm, oneminus) - js = 1 + int(specmult) - fs = mod(specmult, f_one) - ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(3) + js - - speccomb1 = colamt(k,1) + rfrate(k,1,2)*colamt(k,2) - specparm1 = colamt(k,1) / speccomb1 - specmult1 = 8.0 * min(specparm1, oneminus) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1, f_one) - ind1 = (jp(k)*5 + (jt1(k)-1)) * nspa(3) + js1 - - speccomb_mn2o = colamt(k,1) + refrat_m_a*colamt(k,2) - specparm_mn2o = colamt(k,1) / speccomb_mn2o - specmult_mn2o = 8.0 * min(specparm_mn2o, oneminus) - jmn2o = 1 + int(specmult_mn2o) - fmn2o = mod(specmult_mn2o, f_one) - - speccomb_planck = colamt(k,1) + refrat_planck_a*colamt(k,2) - specparm_planck = colamt(k,1) / speccomb_planck - specmult_planck = 8.0 * min(specparm_planck, oneminus) - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck, f_one) - - inds = indself(k) - indf = indfor(k) - indm = indminor(k) - indsp = inds + 1 - indfp = indf + 1 - indmp = indm + 1 - jmn2op= jmn2o+ 1 - jplp = jpl + 1 - -! --- ... in atmospheres where the amount of n2O is too great to be considered -! a minor species, adjust the column amount of n2O by an empirical factor -! to obtain the proper contribution. - - p = coldry(k) * chi_mls(4,jp(k)+1) - ratn2o = colamt(k,4) / p - if (ratn2o > 1.5) then - adjfac = 0.5 + (ratn2o - 0.5)**0.65 - adjcoln2o = adjfac * p - else - adjcoln2o = colamt(k,4) - endif - - if (specparm < 0.125) then - p = fs - f_one - p4 = p**4 - fk0 = p4 - fk1 = f_one - p - 2.0*p4 - fk2 = p + p4 - id000 = ind0 - id010 = ind0 + 9 - id100 = ind0 + 1 - id110 = ind0 +10 - id200 = ind0 + 2 - id210 = ind0 +11 - else if (specparm > 0.875) then - p = -fs - p4 = p**4 - fk0 = p4 - fk1 = f_one - p - 2.0*p4 - fk2 = p + p4 - id000 = ind0 + 1 - id010 = ind0 +10 - id100 = ind0 - id110 = ind0 + 9 - id200 = ind0 - 1 - id210 = ind0 + 8 - else - fk0 = f_one - fs - fk1 = fs - fk2 = f_zero - id000 = ind0 - id010 = ind0 + 9 - id100 = ind0 + 1 - id110 = ind0 +10 - id200 = ind0 - id210 = ind0 - endif - - fac000 = fk0*fac00(k) - fac100 = fk1*fac00(k) - fac200 = fk2*fac00(k) - fac010 = fk0*fac10(k) - fac110 = fk1*fac10(k) - fac210 = fk2*fac10(k) - - if (specparm1 < 0.125) then - p = fs1 - f_one - p4 = p**4 - fk0 = p4 - fk1 = f_one - p - 2.0*p4 - fk2 = p + p4 - id001 = ind1 - id011 = ind1 + 9 - id101 = ind1 + 1 - id111 = ind1 +10 - id201 = ind1 + 2 - id211 = ind1 +11 - elseif (specparm1 > 0.875) then - p = -fs1 - p4 = p**4 - fk0 = p4 - fk1 = f_one - p - 2.0*p4 - fk2 = p + p4 - id001 = ind1 + 1 - id011 = ind1 +10 - id101 = ind1 - id111 = ind1 + 9 - id201 = ind1 - 1 - id211 = ind1 + 8 - else - fk0 = f_one - fs1 - fk1 = fs1 - fk2 = f_zero - id001 = ind1 - id011 = ind1 + 9 - id101 = ind1 + 1 - id111 = ind1 +10 - id201 = ind1 - id211 = ind1 - endif - - fac001 = fk0*fac01(k) - fac101 = fk1*fac01(k) - fac201 = fk2*fac01(k) - fac011 = fk0*fac11(k) - fac111 = fk1*fac11(k) - fac211 = fk2*fac11(k) - - do ig = 1, ng03 - tauself = selffac(k)* (selfref(ig,inds) + selffrac(k) & - & * (selfref(ig,indsp) - selfref(ig,inds))) - taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & - & * (forref(ig,indfp) - forref(ig,indf))) - n2om1 = ka_mn2o(ig,jmn2o,indm) + fmn2o & - & * (ka_mn2o(ig,jmn2op,indm) - ka_mn2o(ig,jmn2o,indm)) - n2om2 = ka_mn2o(ig,jmn2o,indmp) + fmn2o & - & * (ka_mn2o(ig,jmn2op,indmp) - ka_mn2o(ig,jmn2o,indmp)) - absn2o = n2om1 + minorfrac(k) * (n2om2 - n2om1) - - tau_major = speccomb & - & * (fac000*absa(ig,id000) + fac010*absa(ig,id010) & - & + fac100*absa(ig,id100) + fac110*absa(ig,id110) & - & + fac200*absa(ig,id200) + fac210*absa(ig,id210)) - - tau_major1 = speccomb1 & - & * (fac001*absa(ig,id001) + fac011*absa(ig,id011) & - & + fac101*absa(ig,id101) + fac111*absa(ig,id111) & - & + fac201*absa(ig,id201) + fac211*absa(ig,id211)) - - taug(ns03+ig,k) = tau_major + tau_major1 & - & + tauself + taufor + adjcoln2o*absn2o - - fracs(ns03+ig,k) = fracrefa(ig,jpl) + fpl & - & * (fracrefa(ig,jplp) - fracrefa(ig,jpl)) - enddo ! end do_k_loop - enddo ! end do_ig_loop - -! --- ... upper atmosphere loop - - do k = laytrop+1, nlay - speccomb = colamt(k,1) + rfrate(k,1,1)*colamt(k,2) - specparm = colamt(k,1) / speccomb - specmult = 4.0 * min(specparm, oneminus) - js = 1 + int(specmult) - fs = mod(specmult, f_one) - ind0 = ((jp(k)-13)*5 + (jt(k)-1)) * nspb(3) + js - - speccomb1 = colamt(k,1) + rfrate(k,1,2)*colamt(k,2) - specparm1 = colamt(k,1) / speccomb1 - specmult1 = 4.0 * min(specparm1, oneminus) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1, f_one) - ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(3) + js1 - - speccomb_mn2o = colamt(k,1) + refrat_m_b*colamt(k,2) - specparm_mn2o = colamt(k,1) / speccomb_mn2o - specmult_mn2o = 4.0 * min(specparm_mn2o, oneminus) - jmn2o = 1 + int(specmult_mn2o) - fmn2o = mod(specmult_mn2o, f_one) - - speccomb_planck = colamt(k,1) + refrat_planck_b*colamt(k,2) - specparm_planck = colamt(k,1) / speccomb_planck - specmult_planck = 4.0 * min(specparm_planck, oneminus) - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck, f_one) - - indf = indfor(k) - indm = indminor(k) - indfp = indf + 1 - indmp = indm + 1 - jmn2op= jmn2o+ 1 - jplp = jpl + 1 - - id000 = ind0 - id010 = ind0 + 5 - id100 = ind0 + 1 - id110 = ind0 + 6 - id001 = ind1 - id011 = ind1 + 5 - id101 = ind1 + 1 - id111 = ind1 + 6 - -! --- ... in atmospheres where the amount of n2o is too great to be considered -! a minor species, adjust the column amount of N2O by an empirical factor -! to obtain the proper contribution. - - p = coldry(k) * chi_mls(4,jp(k)+1) - ratn2o = colamt(k,4) / p - if (ratn2o > 1.5) then - adjfac = 0.5 + (ratn2o - 0.5)**0.65 - adjcoln2o = adjfac * p - else - adjcoln2o = colamt(k,4) - endif - - fk0 = f_one - fs - fk1 = fs - fac000 = fk0*fac00(k) - fac010 = fk0*fac10(k) - fac100 = fk1*fac00(k) - fac110 = fk1*fac10(k) - - fk0 = f_one - fs1 - fk1 = fs1 - fac001 = fk0*fac01(k) - fac011 = fk0*fac11(k) - fac101 = fk1*fac01(k) - fac111 = fk1*fac11(k) - - do ig = 1, ng03 - taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & - & * (forref(ig,indfp) - forref(ig,indf))) - n2om1 = kb_mn2o(ig,jmn2o,indm) + fmn2o & - & * (kb_mn2o(ig,jmn2op,indm) - kb_mn2o(ig,jmn2o,indm)) - n2om2 = kb_mn2o(ig,jmn2o,indmp) + fmn2o & - & * (kb_mn2o(ig,jmn2op,indmp) - kb_mn2o(ig,jmn2o,indmp)) - absn2o = n2om1 + minorfrac(k) * (n2om2 - n2om1) - - tau_major = speccomb & - & * (fac000*absb(ig,id000) + fac010*absb(ig,id010) & - & + fac100*absb(ig,id100) + fac110*absb(ig,id110)) - - tau_major1 = speccomb1 & - & * (fac001*absb(ig,id001) + fac011*absb(ig,id011) & - & + fac101*absb(ig,id101) + fac111*absb(ig,id111)) - - taug(ns03+ig,k) = tau_major + tau_major1 & - & + taufor + adjcoln2o*absn2o - - fracs(ns03+ig,k) = fracrefb(ig,jpl) + fpl & - & * (fracrefb(ig,jplp) - fracrefb(ig,jpl)) - enddo - enddo - -! .................................. - end subroutine taugb03 -! ---------------------------------- - -!>\ingroup module_radlw_main -!> Band 4: 630-700 cm-1 (low key - h2o,co2; high key - o3,co2) -! ---------------------------------- - subroutine taugb04 -! .................................. - -! ------------------------------------------------------------------ ! -! band 4: 630-700 cm-1 (low key - h2o,co2; high key - o3,co2) ! -! ------------------------------------------------------------------ ! - - use module_radlw_kgb04 - -! --- locals: - integer :: k, ind0, ind1, inds, indsp, indf, indfp, jpl, jplp, & - & id000, id010, id100, id110, id200, id210, ig, js, js1, & - & id001, id011, id101, id111, id201, id211 - - real (kind=kind_phys) :: tauself, taufor, p, p4, fk0, fk1, fk2, & - & speccomb, specparm, specmult, fs, & - & speccomb1, specparm1, specmult1, fs1, & - & speccomb_planck,specparm_planck,specmult_planck,fpl, & - & fac000, fac100, fac200, fac010, fac110, fac210, & - & fac001, fac101, fac201, fac011, fac111, fac211, & - & refrat_planck_a, refrat_planck_b, tau_major, tau_major1 -! -!===> ... begin here -! - refrat_planck_a = chi_mls(1,11)/chi_mls(2,11) ! P = 142.5940 mb - refrat_planck_b = chi_mls(3,13)/chi_mls(2,13) ! P = 95.58350 mb - -! --- ... lower atmosphere loop - - do k = 1, laytrop - speccomb = colamt(k,1) + rfrate(k,1,1)*colamt(k,2) - specparm = colamt(k,1) / speccomb - specmult = 8.0 * min(specparm, oneminus) - js = 1 + int(specmult) - fs = mod(specmult, f_one) - ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(4) + js - - speccomb1 = colamt(k,1) + rfrate(k,1,2)*colamt(k,2) - specparm1 = colamt(k,1) / speccomb1 - specmult1 = 8.0 * min(specparm1, oneminus) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1, f_one) - ind1 = ( jp(k)*5 + (jt1(k)-1)) * nspa(4) + js1 - - speccomb_planck = colamt(k,1) + refrat_planck_a*colamt(k,2) - specparm_planck = colamt(k,1) / speccomb_planck - specmult_planck = 8.0 * min(specparm_planck, oneminus) - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck, 1.0) - - inds = indself(k) - indf = indfor(k) - indsp = inds + 1 - indfp = indf + 1 - jplp = jpl + 1 - - if (specparm < 0.125) then - p = fs - f_one - p4 = p**4 - fk0 = p4 - fk1 = f_one - p - 2.0*p4 - fk2 = p + p4 - id000 = ind0 - id010 = ind0 + 9 - id100 = ind0 + 1 - id110 = ind0 +10 - id200 = ind0 + 2 - id210 = ind0 +11 - elseif (specparm > 0.875) then - p = -fs - p4 = p**4 - fk0 = p4 - fk1 = f_one - p - 2.0*p4 - fk2 = p + p4 - id000 = ind0 + 1 - id010 = ind0 +10 - id100 = ind0 - id110 = ind0 + 9 - id200 = ind0 - 1 - id210 = ind0 + 8 - else - fk0 = f_one - fs - fk1 = fs - fk2 = f_zero - id000 = ind0 - id010 = ind0 + 9 - id100 = ind0 + 1 - id110 = ind0 +10 - id200 = ind0 - id210 = ind0 - endif - - fac000 = fk0*fac00(k) - fac100 = fk1*fac00(k) - fac200 = fk2*fac00(k) - fac010 = fk0*fac10(k) - fac110 = fk1*fac10(k) - fac210 = fk2*fac10(k) - - if (specparm1 < 0.125) then - p = fs1 - f_one - p4 = p**4 - fk0 = p4 - fk1 = f_one - p - 2.0*p4 - fk2 = p + p4 - id001 = ind1 - id011 = ind1 + 9 - id101 = ind1 + 1 - id111 = ind1 +10 - id201 = ind1 + 2 - id211 = ind1 +11 - elseif (specparm1 > 0.875) then - p = -fs1 - p4 = p**4 - fk0 = p4 - fk1 = f_one - p - 2.0*p4 - fk2 = p + p4 - id001 = ind1 + 1 - id011 = ind1 +10 - id101 = ind1 - id111 = ind1 + 9 - id201 = ind1 - 1 - id211 = ind1 + 8 - else - fk0 = f_one - fs1 - fk1 = fs1 - fk2 = f_zero - id001 = ind1 - id011 = ind1 + 9 - id101 = ind1 + 1 - id111 = ind1 +10 - id201 = ind1 - id211 = ind1 - endif - - fac001 = fk0*fac01(k) - fac101 = fk1*fac01(k) - fac201 = fk2*fac01(k) - fac011 = fk0*fac11(k) - fac111 = fk1*fac11(k) - fac211 = fk2*fac11(k) - - do ig = 1, ng04 - tauself = selffac(k)* (selfref(ig,inds) + selffrac(k) & - & * (selfref(ig,indsp) - selfref(ig,inds))) - taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & - & * (forref(ig,indfp) - forref(ig,indf))) - - tau_major = speccomb & - & * (fac000*absa(ig,id000) + fac010*absa(ig,id010) & - & + fac100*absa(ig,id100) + fac110*absa(ig,id110) & - & + fac200*absa(ig,id200) + fac210*absa(ig,id210)) - - tau_major1 = speccomb1 & - & * (fac001*absa(ig,id001) + fac011*absa(ig,id011) & - & + fac101*absa(ig,id101) + fac111*absa(ig,id111) & - & + fac201*absa(ig,id201) + fac211*absa(ig,id211)) - - taug(ns04+ig,k) = tau_major + tau_major1 + tauself + taufor - - fracs(ns04+ig,k) = fracrefa(ig,jpl) + fpl & - & * (fracrefa(ig,jplp) - fracrefa(ig,jpl)) - enddo ! end do_k_loop - enddo ! end do_ig_loop - -! --- ... upper atmosphere loop - - do k = laytrop+1, nlay - speccomb = colamt(k,3) + rfrate(k,6,1)*colamt(k,2) - specparm = colamt(k,3) / speccomb - specmult = 4.0 * min(specparm, oneminus) - js = 1 + int(specmult) - fs = mod(specmult, f_one) - ind0 = ((jp(k)-13)*5 + (jt(k)-1)) * nspb(4) + js - - speccomb1 = colamt(k,3) + rfrate(k,6,2)*colamt(k,2) - specparm1 = colamt(k,3) / speccomb1 - specmult1 = 4.0 * min(specparm1, oneminus) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1, f_one) - ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(4) + js1 - - speccomb_planck = colamt(k,3) + refrat_planck_b*colamt(k,2) - specparm_planck = colamt(k,3) / speccomb_planck - specmult_planck = 4.0 * min(specparm_planck, oneminus) - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck, f_one) - jplp = jpl + 1 - - id000 = ind0 - id010 = ind0 + 5 - id100 = ind0 + 1 - id110 = ind0 + 6 - id001 = ind1 - id011 = ind1 + 5 - id101 = ind1 + 1 - id111 = ind1 + 6 - - fk0 = f_one - fs - fk1 = fs - fac000 = fk0*fac00(k) - fac010 = fk0*fac10(k) - fac100 = fk1*fac00(k) - fac110 = fk1*fac10(k) - - fk0 = f_one - fs1 - fk1 = fs1 - fac001 = fk0*fac01(k) - fac011 = fk0*fac11(k) - fac101 = fk1*fac01(k) - fac111 = fk1*fac11(k) - - do ig = 1, ng04 - tau_major = speccomb & - & * (fac000*absb(ig,id000) + fac010*absb(ig,id010) & - & + fac100*absb(ig,id100) + fac110*absb(ig,id110)) - tau_major1 = speccomb1 & - & * (fac001*absb(ig,id001) + fac011*absb(ig,id011) & - & + fac101*absb(ig,id101) + fac111*absb(ig,id111)) - - taug(ns04+ig,k) = tau_major + tau_major1 - - fracs(ns04+ig,k) = fracrefb(ig,jpl) + fpl & - & * (fracrefb(ig,jplp) - fracrefb(ig,jpl)) - enddo - -! --- ... empirical modification to code to improve stratospheric cooling rates -! for co2. revised to apply weighting for g-point reduction in this band. - - taug(ns04+ 8,k) = taug(ns04+ 8,k) * 0.92 - taug(ns04+ 9,k) = taug(ns04+ 9,k) * 0.88 - taug(ns04+10,k) = taug(ns04+10,k) * 1.07 - taug(ns04+11,k) = taug(ns04+11,k) * 1.1 - taug(ns04+12,k) = taug(ns04+12,k) * 0.99 - taug(ns04+13,k) = taug(ns04+13,k) * 0.88 - taug(ns04+14,k) = taug(ns04+14,k) * 0.943 - enddo - -! .................................. - end subroutine taugb04 -! ---------------------------------- - -!>\ingroup module_radlw_main -!> Band 5: 700-820 cm-1 (low key - h2o,co2; low minor - o3, ccl4) -!! (high key - o3,co2) -! ---------------------------------- - subroutine taugb05 -! .................................. - -! ------------------------------------------------------------------ ! -! band 5: 700-820 cm-1 (low key - h2o,co2; low minor - o3, ccl4) ! -! (high key - o3,co2) ! -! ------------------------------------------------------------------ ! - - use module_radlw_kgb05 - -! --- locals: - integer :: k, ind0, ind1, inds, indsp, indf, indfp, indm, indmp, & - & id000, id010, id100, id110, id200, id210, jmo3, jmo3p, & - & id001, id011, id101, id111, id201, id211, jpl, jplp, & - & ig, js, js1 - - real (kind=kind_phys) :: tauself, taufor, o3m1, o3m2, abso3, & - & speccomb, specparm, specmult, fs, & - & speccomb1, specparm1, specmult1, fs1, & - & speccomb_mo3, specparm_mo3, specmult_mo3, fmo3, & - & speccomb_planck,specparm_planck,specmult_planck,fpl, & - & refrat_planck_a, refrat_planck_b, refrat_m_a, & - & fac000, fac100, fac200, fac010, fac110, fac210, & - & fac001, fac101, fac201, fac011, fac111, fac211, & - & p0, p40, fk00, fk10, fk20, p1, p41, fk01, fk11, fk21 -! -!===> ... begin here -! -! --- ... minor gas mapping level : -! lower - o3, p = 317.34 mbar, t = 240.77 k -! lower - ccl4 - -! --- ... calculate reference ratio to be used in calculation of Planck -! fraction in lower/upper atmosphere. - - refrat_planck_a = chi_mls(1,5)/chi_mls(2,5) ! P = 473.420 mb - refrat_planck_b = chi_mls(3,43)/chi_mls(2,43) ! P = 0.2369 mb - refrat_m_a = chi_mls(1,7)/chi_mls(2,7) ! P = 317.348 mb - -! --- ... lower atmosphere loop - - do k = 1, laytrop - speccomb = colamt(k,1) + rfrate(k,1,1)*colamt(k,2) - specparm = colamt(k,1) / speccomb - specmult = 8.0 * min(specparm, oneminus) - js = 1 + int(specmult) - fs = mod(specmult, f_one) - ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(5) + js - - speccomb1 = colamt(k,1) + rfrate(k,1,2)*colamt(k,2) - specparm1 = colamt(k,1) / speccomb1 - specmult1 = 8.0 * min(specparm1, oneminus) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1, f_one) - ind1 = (jp(k)*5 + (jt1(k)-1)) * nspa(5) + js1 - - speccomb_mo3 = colamt(k,1) + refrat_m_a*colamt(k,2) - specparm_mo3 = colamt(k,1) / speccomb_mo3 - specmult_mo3 = 8.0 * min(specparm_mo3, oneminus) - jmo3 = 1 + int(specmult_mo3) - fmo3 = mod(specmult_mo3, f_one) - - speccomb_planck = colamt(k,1) + refrat_planck_a*colamt(k,2) - specparm_planck = colamt(k,1) / speccomb_planck - specmult_planck = 8.0 * min(specparm_planck, oneminus) - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck, f_one) - - inds = indself(k) - indf = indfor(k) - indm = indminor(k) - indsp = inds + 1 - indfp = indf + 1 - indmp = indm + 1 - jplp = jpl + 1 - jmo3p = jmo3 + 1 - - if (specparm < 0.125) then - p0 = fs - f_one - p40 = p0**4 - fk00 = p40 - fk10 = f_one - p0 - 2.0*p40 - fk20 = p0 + p40 - - id000 = ind0 - id010 = ind0 + 9 - id100 = ind0 + 1 - id110 = ind0 +10 - id200 = ind0 + 2 - id210 = ind0 +11 - elseif (specparm > 0.875) then - p0 = -fs - p40 = p0**4 - fk00 = p40 - fk10 = f_one - p0 - 2.0*p40 - fk20 = p0 + p40 - - id000 = ind0 + 1 - id010 = ind0 +10 - id100 = ind0 - id110 = ind0 + 9 - id200 = ind0 - 1 - id210 = ind0 + 8 - else - fk00 = f_one - fs - fk10 = fs - fk20 = f_zero - - id000 = ind0 - id010 = ind0 + 9 - id100 = ind0 + 1 - id110 = ind0 +10 - id200 = ind0 - id210 = ind0 - endif - - fac000 = fk00 * fac00(k) - fac100 = fk10 * fac00(k) - fac200 = fk20 * fac00(k) - fac010 = fk00 * fac10(k) - fac110 = fk10 * fac10(k) - fac210 = fk20 * fac10(k) - - if (specparm1 < 0.125) then - p1 = fs1 - f_one - p41 = p1**4 - fk01 = p41 - fk11 = f_one - p1 - 2.0*p41 - fk21 = p1 + p41 - - id001 = ind1 - id011 = ind1 + 9 - id101 = ind1 + 1 - id111 = ind1 +10 - id201 = ind1 + 2 - id211 = ind1 +11 - elseif (specparm1 > 0.875) then - p1 = -fs1 - p41 = p1**4 - fk01 = p41 - fk11 = f_one - p1 - 2.0*p41 - fk21 = p1 + p41 - - id001 = ind1 + 1 - id011 = ind1 +10 - id101 = ind1 - id111 = ind1 + 9 - id201 = ind1 - 1 - id211 = ind1 + 8 - else - fk01 = f_one - fs1 - fk11 = fs1 - fk21 = f_zero - - id001 = ind1 - id011 = ind1 + 9 - id101 = ind1 + 1 - id111 = ind1 +10 - id201 = ind1 - id211 = ind1 - endif - - fac001 = fk01 * fac01(k) - fac101 = fk11 * fac01(k) - fac201 = fk21 * fac01(k) - fac011 = fk01 * fac11(k) - fac111 = fk11 * fac11(k) - fac211 = fk21 * fac11(k) - - do ig = 1, ng05 - tauself = selffac(k) * (selfref(ig,inds) + selffrac(k) & - & * (selfref(ig,indsp) - selfref(ig,inds))) - taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & - & * (forref(ig,indfp) - forref(ig,indf))) - o3m1 = ka_mo3(ig,jmo3,indm) + fmo3 & - & * (ka_mo3(ig,jmo3p,indm) - ka_mo3(ig,jmo3,indm)) - o3m2 = ka_mo3(ig,jmo3,indmp) + fmo3 & - & * (ka_mo3(ig,jmo3p,indmp) - ka_mo3(ig,jmo3,indmp)) - abso3 = o3m1 + minorfrac(k)*(o3m2 - o3m1) - - taug(ns05+ig,k) = speccomb & - & * (fac000*absa(ig,id000) + fac010*absa(ig,id010) & - & + fac100*absa(ig,id100) + fac110*absa(ig,id110) & - & + fac200*absa(ig,id200) + fac210*absa(ig,id210)) & - & + speccomb1 & - & * (fac001*absa(ig,id001) + fac011*absa(ig,id011) & - & + fac101*absa(ig,id101) + fac111*absa(ig,id111) & - & + fac201*absa(ig,id201) + fac211*absa(ig,id211)) & - & + tauself + taufor+abso3*colamt(k,3)+wx(k,1)*ccl4(ig) - - fracs(ns05+ig,k) = fracrefa(ig,jpl) + fpl & - & * (fracrefa(ig,jplp) - fracrefa(ig,jpl)) - enddo - enddo - -! --- ... upper atmosphere loop - - do k = laytrop+1, nlay - speccomb = colamt(k,3) + rfrate(k,6,1)*colamt(k,2) - specparm = colamt(k,3) / speccomb - specmult = 4.0 * min(specparm, oneminus) - js = 1 + int(specmult) - fs = mod(specmult, f_one) - ind0 = ((jp(k)-13)*5 + (jt(k)-1)) * nspb(5) + js - - speccomb1 = colamt(k,3) + rfrate(k,6,2)*colamt(k,2) - specparm1 = colamt(k,3) / speccomb1 - specmult1 = 4.0 * min(specparm1, oneminus) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1, f_one) - ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(5) + js1 - - speccomb_planck = colamt(k,3) + refrat_planck_b*colamt(k,2) - specparm_planck = colamt(k,3) / speccomb_planck - specmult_planck = 4.0 * min(specparm_planck, oneminus) - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck, f_one) - jplp= jpl + 1 - - id000 = ind0 - id010 = ind0 + 5 - id100 = ind0 + 1 - id110 = ind0 + 6 - id001 = ind1 - id011 = ind1 + 5 - id101 = ind1 + 1 - id111 = ind1 + 6 - - fk00 = f_one - fs - fk10 = fs - - fk01 = f_one - fs1 - fk11 = fs1 - - fac000 = fk00 * fac00(k) - fac010 = fk00 * fac10(k) - fac100 = fk10 * fac00(k) - fac110 = fk10 * fac10(k) - - fac001 = fk01 * fac01(k) - fac011 = fk01 * fac11(k) - fac101 = fk11 * fac01(k) - fac111 = fk11 * fac11(k) - - do ig = 1, ng05 - taug(ns05+ig,k) = speccomb & - & * (fac000*absb(ig,id000) + fac010*absb(ig,id010) & - & + fac100*absb(ig,id100) + fac110*absb(ig,id110)) & - & + speccomb1 & - & * (fac001*absb(ig,id001) + fac011*absb(ig,id011) & - & + fac101*absb(ig,id101) + fac111*absb(ig,id111)) & - & + wx(k,1) * ccl4(ig) - - fracs(ns05+ig,k) = fracrefb(ig,jpl) + fpl & - & * (fracrefb(ig,jplp) - fracrefb(ig,jpl)) - enddo - enddo - -! .................................. - end subroutine taugb05 -! ---------------------------------- - -!>\ingroup module_radlw_main -!> Band 6: 820-980 cm-1 (low key - h2o; low minor - co2) -!! (high key - none; high minor - cfc11, cfc12) -! ---------------------------------- - subroutine taugb06 -! .................................. - -! ------------------------------------------------------------------ ! -! band 6: 820-980 cm-1 (low key - h2o; low minor - co2) ! -! (high key - none; high minor - cfc11, cfc12) -! ------------------------------------------------------------------ ! - - use module_radlw_kgb06 - -! --- locals: - integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, & - & indm, indmp, ig - - real (kind=kind_phys) :: ratco2, adjfac, adjcolco2, tauself, & - & taufor, absco2, temp -! -!===> ... begin here -! -! --- ... minor gas mapping level: -! lower - co2, p = 706.2720 mb, t = 294.2 k -! upper - cfc11, cfc12 - -! --- ... lower atmosphere loop - - do k = 1, laytrop - ind0 = ((jp(k)-1)*5 + (jt (k)-1)) * nspa(6) + 1 - ind1 = ( jp(k) *5 + (jt1(k)-1)) * nspa(6) + 1 - - inds = indself(k) - indf = indfor(k) - indm = indminor(k) - indsp = inds + 1 - indfp = indf + 1 - indmp = indm + 1 - ind0p = ind0 + 1 - ind1p = ind1 + 1 - -! --- ... in atmospheres where the amount of co2 is too great to be considered -! a minor species, adjust the column amount of co2 by an empirical factor -! to obtain the proper contribution. - - temp = coldry(k) * chi_mls(2,jp(k)+1) - ratco2 = colamt(k,2) / temp - if (ratco2 > 3.0) then - adjfac = 2.0 + (ratco2-2.0)**0.77 - adjcolco2 = adjfac * temp - else - adjcolco2 = colamt(k,2) - endif - - do ig = 1, ng06 - tauself = selffac(k) * (selfref(ig,inds) + selffrac(k) & - & * (selfref(ig,indsp) - selfref(ig,inds))) - taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & - & * (forref(ig,indfp) - forref(ig,indf))) - absco2 = ka_mco2(ig,indm) + minorfrac(k) & - & * (ka_mco2(ig,indmp) - ka_mco2(ig,indm)) - - taug(ns06+ig,k) = colamt(k,1) & - & * (fac00(k)*absa(ig,ind0) + fac10(k)*absa(ig,ind0p) & - & + fac01(k)*absa(ig,ind1) + fac11(k)*absa(ig,ind1p)) & - & + tauself + taufor + adjcolco2*absco2 & - & + wx(k,2)*cfc11adj(ig) + wx(k,3)*cfc12(ig) - - fracs(ns06+ig,k) = fracrefa(ig) - enddo - enddo - -! --- ... upper atmosphere loop -! nothing important goes on above laytrop in this band. - - do k = laytrop+1, nlay - do ig = 1, ng06 - taug(ns06+ig,k) = wx(k,2)*cfc11adj(ig) + wx(k,3)*cfc12(ig) - - fracs(ns06+ig,k) = fracrefa(ig) - enddo - enddo - -! .................................. - end subroutine taugb06 -! ---------------------------------- - -!>\ingroup module_radlw_main -!> Band 7: 980-1080 cm-1 (low key - h2o,o3; low minor - co2) -!! (high key - o3; high minor - co2) -! ---------------------------------- - subroutine taugb07 -! .................................. - -! ------------------------------------------------------------------ ! -! band 7: 980-1080 cm-1 (low key - h2o,o3; low minor - co2) ! -! (high key - o3; high minor - co2) ! -! ------------------------------------------------------------------ ! - - use module_radlw_kgb07 - -! --- locals: - integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, & - & id000, id010, id100, id110, id200, id210, indm, indmp, & - & id001, id011, id101, id111, id201, id211, jmco2, jmco2p, & - & jpl, jplp, ig, js, js1 - - real (kind=kind_phys) :: tauself, taufor, co2m1, co2m2, absco2, & - & speccomb, specparm, specmult, fs, & - & speccomb1, specparm1, specmult1, fs1, & - & speccomb_mco2, specparm_mco2, specmult_mco2, fmco2, & - & speccomb_planck,specparm_planck,specmult_planck,fpl, & - & refrat_planck_a, refrat_m_a, ratco2, adjfac, adjcolco2, & - & fac000, fac100, fac200, fac010, fac110, fac210, & - & fac001, fac101, fac201, fac011, fac111, fac211, & - & p0, p40, fk00, fk10, fk20, p1, p41, fk01, fk11, fk21, temp -! -!===> ... begin here -! -! --- ... minor gas mapping level : -! lower - co2, p = 706.2620 mbar, t= 278.94 k -! upper - co2, p = 12.9350 mbar, t = 234.01 k - -! --- ... calculate reference ratio to be used in calculation of Planck -! fraction in lower atmosphere. - - refrat_planck_a = chi_mls(1,3)/chi_mls(3,3) ! P = 706.2620 mb - refrat_m_a = chi_mls(1,3)/chi_mls(3,3) ! P = 706.2720 mb - -! --- ... lower atmosphere loop - - do k = 1, laytrop - speccomb = colamt(k,1) + rfrate(k,2,1)*colamt(k,3) - specparm = colamt(k,1) / speccomb - specmult = 8.0 * min(specparm, oneminus) - js = 1 + int(specmult) - fs = mod(specmult, f_one) - ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(7) + js - - speccomb1 = colamt(k,1) + rfrate(k,2,2)*colamt(k,3) - specparm1 = colamt(k,1) / speccomb1 - specmult1 = 8.0 * min(specparm1, oneminus) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1, f_one) - ind1 = (jp(k)*5 + (jt1(k)-1)) * nspa(7) + js1 - - speccomb_mco2 = colamt(k,1) + refrat_m_a*colamt(k,3) - specparm_mco2 = colamt(k,1) / speccomb_mco2 - specmult_mco2 = 8.0 * min(specparm_mco2, oneminus) - jmco2 = 1 + int(specmult_mco2) - fmco2 = mod(specmult_mco2, f_one) - - speccomb_planck = colamt(k,1) + refrat_planck_a*colamt(k,3) - specparm_planck = colamt(k,1) / speccomb_planck - specmult_planck = 8.0 * min(specparm_planck, oneminus) - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck, f_one) - - inds = indself(k) - indf = indfor(k) - indm = indminor(k) - indsp = inds + 1 - indfp = indf + 1 - indmp = indm + 1 - jplp = jpl + 1 - jmco2p= jmco2+ 1 - ind0p = ind0 + 1 - ind1p = ind1 + 1 - -! --- ... in atmospheres where the amount of CO2 is too great to be considered -! a minor species, adjust the column amount of CO2 by an empirical factor -! to obtain the proper contribution. - - temp = coldry(k) * chi_mls(2,jp(k)+1) - ratco2 = colamt(k,2) / temp - if (ratco2 > 3.0) then - adjfac = 3.0 + (ratco2-3.0)**0.79 - adjcolco2 = adjfac * temp - else - adjcolco2 = colamt(k,2) - endif - - if (specparm < 0.125) then - p0 = fs - f_one - p40 = p0**4 - fk00 = p40 - fk10 = f_one - p0 - 2.0*p40 - fk20 = p0 + p40 - - id000 = ind0 - id010 = ind0 + 9 - id100 = ind0 + 1 - id110 = ind0 +10 - id200 = ind0 + 2 - id210 = ind0 +11 - elseif (specparm > 0.875) then - p0 = -fs - p40 = p0**4 - fk00 = p40 - fk10 = f_one - p0 - 2.0*p40 - fk20 = p0 + p40 - - id000 = ind0 + 1 - id010 = ind0 +10 - id100 = ind0 - id110 = ind0 + 9 - id200 = ind0 - 1 - id210 = ind0 + 8 - else - fk00 = f_one - fs - fk10 = fs - fk20 = f_zero - - id000 = ind0 - id010 = ind0 + 9 - id100 = ind0 + 1 - id110 = ind0 +10 - id200 = ind0 - id210 = ind0 - endif - - fac000 = fk00 * fac00(k) - fac100 = fk10 * fac00(k) - fac200 = fk20 * fac00(k) - fac010 = fk00 * fac10(k) - fac110 = fk10 * fac10(k) - fac210 = fk20 * fac10(k) - - if (specparm1 < 0.125) then - p1 = fs1 - f_one - p41 = p1**4 - fk01 = p41 - fk11 = f_one - p1 - 2.0*p41 - fk21 = p1 + p41 - - id001 = ind1 - id011 = ind1 + 9 - id101 = ind1 + 1 - id111 = ind1 +10 - id201 = ind1 + 2 - id211 = ind1 +11 - elseif (specparm1 > 0.875) then - p1 = -fs1 - p41 = p1**4 - fk01 = p41 - fk11 = f_one - p1 - 2.0*p41 - fk21 = p1 + p41 - - id001 = ind1 + 1 - id011 = ind1 +10 - id101 = ind1 - id111 = ind1 + 9 - id201 = ind1 - 1 - id211 = ind1 + 8 - else - fk01 = f_one - fs1 - fk11 = fs1 - fk21 = f_zero - - id001 = ind1 - id011 = ind1 + 9 - id101 = ind1 + 1 - id111 = ind1 +10 - id201 = ind1 - id211 = ind1 - endif - - fac001 = fk01 * fac01(k) - fac101 = fk11 * fac01(k) - fac201 = fk21 * fac01(k) - fac011 = fk01 * fac11(k) - fac111 = fk11 * fac11(k) - fac211 = fk21 * fac11(k) - - do ig = 1, ng07 - tauself = selffac(k)* (selfref(ig,inds) + selffrac(k) & - & * (selfref(ig,indsp) - selfref(ig,inds))) - taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & - & * (forref(ig,indfp) - forref(ig,indf))) - co2m1 = ka_mco2(ig,jmco2,indm) + fmco2 & - & * (ka_mco2(ig,jmco2p,indm) - ka_mco2(ig,jmco2,indm)) - co2m2 = ka_mco2(ig,jmco2,indmp) + fmco2 & - & * (ka_mco2(ig,jmco2p,indmp) - ka_mco2(ig,jmco2,indmp)) - absco2 = co2m1 + minorfrac(k) * (co2m2 - co2m1) - - taug(ns07+ig,k) = speccomb & - & * (fac000*absa(ig,id000) + fac010*absa(ig,id010) & - & + fac100*absa(ig,id100) + fac110*absa(ig,id110) & - & + fac200*absa(ig,id200) + fac210*absa(ig,id210)) & - & + speccomb1 & - & * (fac001*absa(ig,id001) + fac011*absa(ig,id011) & - & + fac101*absa(ig,id101) + fac111*absa(ig,id111) & - & + fac201*absa(ig,id201) + fac211*absa(ig,id211)) & - & + tauself + taufor + adjcolco2*absco2 - - fracs(ns07+ig,k) = fracrefa(ig,jpl) + fpl & - & * (fracrefa(ig,jplp) - fracrefa(ig,jpl)) - enddo - enddo - -! --- ... upper atmosphere loop - -! --- ... in atmospheres where the amount of co2 is too great to be considered -! a minor species, adjust the column amount of co2 by an empirical factor -! to obtain the proper contribution. - - do k = laytrop+1, nlay - temp = coldry(k) * chi_mls(2,jp(k)+1) - ratco2 = colamt(k,2) / temp - if (ratco2 > 3.0) then - adjfac = 2.0 + (ratco2-2.0)**0.79 - adjcolco2 = adjfac * temp - else - adjcolco2 = colamt(k,2) - endif - - ind0 = ((jp(k)-13)*5 + (jt (k)-1)) * nspb(7) + 1 - ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(7) + 1 - - indm = indminor(k) - indmp = indm + 1 - ind0p = ind0 + 1 - ind1p = ind1 + 1 - - do ig = 1, ng07 - absco2 = kb_mco2(ig,indm) + minorfrac(k) & - & * (kb_mco2(ig,indmp) - kb_mco2(ig,indm)) - - taug(ns07+ig,k) = colamt(k,3) & - & * (fac00(k)*absb(ig,ind0) + fac10(k)*absb(ig,ind0p) & - & + fac01(k)*absb(ig,ind1) + fac11(k)*absb(ig,ind1p)) & - & + adjcolco2 * absco2 - - fracs(ns07+ig,k) = fracrefb(ig) - enddo - -! --- ... empirical modification to code to improve stratospheric cooling rates -! for o3. revised to apply weighting for g-point reduction in this band. - - taug(ns07+ 6,k) = taug(ns07+ 6,k) * 0.92 - taug(ns07+ 7,k) = taug(ns07+ 7,k) * 0.88 - taug(ns07+ 8,k) = taug(ns07+ 8,k) * 1.07 - taug(ns07+ 9,k) = taug(ns07+ 9,k) * 1.1 - taug(ns07+10,k) = taug(ns07+10,k) * 0.99 - taug(ns07+11,k) = taug(ns07+11,k) * 0.855 - enddo - -! .................................. - end subroutine taugb07 -! ---------------------------------- - -!>\ingroup module_radlw_main -!> Band 8: 1080-1180 cm-1 (low key - h2o; low minor - co2,o3,n2o) -!! (high key - o3; high minor - co2, n2o) -! ---------------------------------- - subroutine taugb08 -! .................................. - -! ------------------------------------------------------------------ ! -! band 8: 1080-1180 cm-1 (low key - h2o; low minor - co2,o3,n2o) ! -! (high key - o3; high minor - co2, n2o) ! -! ------------------------------------------------------------------ ! - - use module_radlw_kgb08 - -! --- locals: - integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, & - & indm, indmp, ig - - real (kind=kind_phys) :: tauself, taufor, absco2, abso3, absn2o, & - & ratco2, adjfac, adjcolco2, temp -! -!===> ... begin here -! -! --- ... minor gas mapping level: -! lower - co2, p = 1053.63 mb, t = 294.2 k -! lower - o3, p = 317.348 mb, t = 240.77 k -! lower - n2o, p = 706.2720 mb, t= 278.94 k -! lower - cfc12,cfc11 -! upper - co2, p = 35.1632 mb, t = 223.28 k -! upper - n2o, p = 8.716e-2 mb, t = 226.03 k - -! --- ... lower atmosphere loop - - do k = 1, laytrop - ind0 = ((jp(k)-1)*5 + (jt (k)-1)) * nspa(8) + 1 - ind1 = ( jp(k) *5 + (jt1(k)-1)) * nspa(8) + 1 - - inds = indself(k) - indf = indfor(k) - indm = indminor(k) - ind0p = ind0 + 1 - ind1p = ind1 + 1 - indsp = inds + 1 - indfp = indf + 1 - indmp = indm + 1 - -! --- ... in atmospheres where the amount of co2 is too great to be considered -! a minor species, adjust the column amount of co2 by an empirical factor -! to obtain the proper contribution. - - temp = coldry(k) * chi_mls(2,jp(k)+1) - ratco2 = colamt(k,2) / temp - if (ratco2 > 3.0) then - adjfac = 2.0 + (ratco2-2.0)**0.65 - adjcolco2 = adjfac * temp - else - adjcolco2 = colamt(k,2) - endif - - do ig = 1, ng08 - tauself = selffac(k) * (selfref(ig,inds) + selffrac(k) & - & * (selfref(ig,indsp) - selfref(ig,inds))) - taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & - & * (forref(ig,indfp) - forref(ig,indf))) - absco2 = (ka_mco2(ig,indm) + minorfrac(k) & - & * (ka_mco2(ig,indmp) - ka_mco2(ig,indm))) - abso3 = (ka_mo3(ig,indm) + minorfrac(k) & - & * (ka_mo3(ig,indmp) - ka_mo3(ig,indm))) - absn2o = (ka_mn2o(ig,indm) + minorfrac(k) & - & * (ka_mn2o(ig,indmp) - ka_mn2o(ig,indm))) - - taug(ns08+ig,k) = colamt(k,1) & - & * (fac00(k)*absa(ig,ind0) + fac10(k)*absa(ig,ind0p) & - & + fac01(k)*absa(ig,ind1) + fac11(k)*absa(ig,ind1p)) & - & + tauself+taufor + adjcolco2*absco2 & - & + colamt(k,3)*abso3 + colamt(k,4)*absn2o & - & + wx(k,3)*cfc12(ig) + wx(k,4)*cfc22adj(ig) - - fracs(ns08+ig,k) = fracrefa(ig) - enddo - enddo - -! --- ... upper atmosphere loop - - do k = laytrop+1, nlay - ind0 = ((jp(k)-13)*5 + (jt (k)-1)) * nspb(8) + 1 - ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(8) + 1 - - indm = indminor(k) - ind0p = ind0 + 1 - ind1p = ind1 + 1 - indmp = indm + 1 - -! --- ... in atmospheres where the amount of co2 is too great to be considered -! a minor species, adjust the column amount of co2 by an empirical factor -! to obtain the proper contribution. - - temp = coldry(k) * chi_mls(2,jp(k)+1) - ratco2 = colamt(k,2) / temp - if (ratco2 > 3.0) then - adjfac = 2.0 + (ratco2-2.0)**0.65 - adjcolco2 = adjfac * temp - else - adjcolco2 = colamt(k,2) - endif - - do ig = 1, ng08 - absco2 = (kb_mco2(ig,indm) + minorfrac(k) & - & * (kb_mco2(ig,indmp) - kb_mco2(ig,indm))) - absn2o = (kb_mn2o(ig,indm) + minorfrac(k) & - & * (kb_mn2o(ig,indmp) - kb_mn2o(ig,indm))) - - taug(ns08+ig,k) = colamt(k,3) & - & * (fac00(k)*absb(ig,ind0) + fac10(k)*absb(ig,ind0p) & - & + fac01(k)*absb(ig,ind1) + fac11(k)*absb(ig,ind1p)) & - & + adjcolco2*absco2 + colamt(k,4)*absn2o & - & + wx(k,3)*cfc12(ig) + wx(k,4)*cfc22adj(ig) - - fracs(ns08+ig,k) = fracrefb(ig) - enddo - enddo - -! .................................. - end subroutine taugb08 -! ---------------------------------- - -!>\ingroup module_radlw_main -!> Band 9: 1180-1390 cm-1 (low key - h2o,ch4; low minor - n2o) -!! (high key - ch4; high minor - n2o) -! ---------------------------------- - subroutine taugb09 -! .................................. - -! ------------------------------------------------------------------ ! -! band 9: 1180-1390 cm-1 (low key - h2o,ch4; low minor - n2o) ! -! (high key - ch4; high minor - n2o) ! -! ------------------------------------------------------------------ ! - - use module_radlw_kgb09 - -! --- locals: - integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, & - & id000, id010, id100, id110, id200, id210, indm, indmp, & - & id001, id011, id101, id111, id201, id211, jmn2o, jmn2op, & - & jpl, jplp, ig, js, js1 - - real (kind=kind_phys) :: tauself, taufor, n2om1, n2om2, absn2o, & - & speccomb, specparm, specmult, fs, & - & speccomb1, specparm1, specmult1, fs1, & - & speccomb_mn2o, specparm_mn2o, specmult_mn2o, fmn2o, & - & speccomb_planck,specparm_planck,specmult_planck,fpl, & - & refrat_planck_a, refrat_m_a, ratn2o, adjfac, adjcoln2o, & - & fac000, fac100, fac200, fac010, fac110, fac210, & - & fac001, fac101, fac201, fac011, fac111, fac211, & - & p0, p40, fk00, fk10, fk20, p1, p41, fk01, fk11, fk21, temp -! -!===> ... begin here -! -! --- ... minor gas mapping level : -! lower - n2o, p = 706.272 mbar, t = 278.94 k -! upper - n2o, p = 95.58 mbar, t = 215.7 k - -! --- ... calculate reference ratio to be used in calculation of Planck -! fraction in lower/upper atmosphere. - - refrat_planck_a = chi_mls(1,9)/chi_mls(6,9) ! P = 212 mb - refrat_m_a = chi_mls(1,3)/chi_mls(6,3) ! P = 706.272 mb - -! --- ... lower atmosphere loop - - do k = 1, laytrop - speccomb = colamt(k,1) + rfrate(k,4,1)*colamt(k,5) - specparm = colamt(k,1) / speccomb - specmult = 8.0 * min(specparm, oneminus) - js = 1 + int(specmult) - fs = mod(specmult, f_one) - ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(9) + js - - speccomb1 = colamt(k,1) + rfrate(k,4,2)*colamt(k,5) - specparm1 = colamt(k,1) / speccomb1 - specmult1 = 8.0 * min(specparm1, oneminus) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1, f_one) - ind1 = (jp(k)*5 + (jt1(k)-1)) * nspa(9) + js1 - - speccomb_mn2o = colamt(k,1) + refrat_m_a*colamt(k,5) - specparm_mn2o = colamt(k,1) / speccomb_mn2o - specmult_mn2o = 8.0 * min(specparm_mn2o, oneminus) - jmn2o = 1 + int(specmult_mn2o) - fmn2o = mod(specmult_mn2o, f_one) - - speccomb_planck = colamt(k,1) + refrat_planck_a*colamt(k,5) - specparm_planck = colamt(k,1) / speccomb_planck - specmult_planck = 8.0 * min(specparm_planck, oneminus) - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck, f_one) - - inds = indself(k) - indf = indfor(k) - indm = indminor(k) - indsp = inds + 1 - indfp = indf + 1 - indmp = indm + 1 - jplp = jpl + 1 - jmn2op= jmn2o+ 1 - -! --- ... in atmospheres where the amount of n2o is too great to be considered -! a minor species, adjust the column amount of n2o by an empirical factor -! to obtain the proper contribution. - - temp = coldry(k) * chi_mls(4,jp(k)+1) - ratn2o = colamt(k,4) / temp - if (ratn2o > 1.5) then - adjfac = 0.5 + (ratn2o-0.5)**0.65 - adjcoln2o = adjfac * temp - else - adjcoln2o = colamt(k,4) - endif - - if (specparm < 0.125) then - p0 = fs - f_one - p40 = p0**4 - fk00 = p40 - fk10 = f_one - p0 - 2.0*p40 - fk20 = p0 + p40 - - id000 = ind0 - id010 = ind0 + 9 - id100 = ind0 + 1 - id110 = ind0 +10 - id200 = ind0 + 2 - id210 = ind0 +11 - elseif (specparm > 0.875) then - p0 = -fs - p40 = p0**4 - fk00 = p40 - fk10 = f_one - p0 - 2.0*p40 - fk20 = p0 + p40 - - id000 = ind0 + 1 - id010 = ind0 +10 - id100 = ind0 - id110 = ind0 + 9 - id200 = ind0 - 1 - id210 = ind0 + 8 - else - fk00 = f_one - fs - fk10 = fs - fk20 = f_zero - - id000 = ind0 - id010 = ind0 + 9 - id100 = ind0 + 1 - id110 = ind0 +10 - id200 = ind0 - id210 = ind0 - endif - - fac000 = fk00 * fac00(k) - fac100 = fk10 * fac00(k) - fac200 = fk20 * fac00(k) - fac010 = fk00 * fac10(k) - fac110 = fk10 * fac10(k) - fac210 = fk20 * fac10(k) - - if (specparm1 < 0.125) then - p1 = fs1 - f_one - p41 = p1**4 - fk01 = p41 - fk11 = f_one - p1 - 2.0*p41 - fk21 = p1 + p41 - - id001 = ind1 - id011 = ind1 + 9 - id101 = ind1 + 1 - id111 = ind1 +10 - id201 = ind1 + 2 - id211 = ind1 +11 - elseif (specparm1 > 0.875) then - p1 = -fs1 - p41 = p1**4 - fk01 = p41 - fk11 = f_one - p1 - 2.0*p41 - fk21 = p1 + p41 - - id001 = ind1 + 1 - id011 = ind1 +10 - id101 = ind1 - id111 = ind1 + 9 - id201 = ind1 - 1 - id211 = ind1 + 8 - else - fk01 = f_one - fs1 - fk11 = fs1 - fk21 = f_zero - - id001 = ind1 - id011 = ind1 + 9 - id101 = ind1 + 1 - id111 = ind1 +10 - id201 = ind1 - id211 = ind1 - endif - - fac001 = fk01 * fac01(k) - fac101 = fk11 * fac01(k) - fac201 = fk21 * fac01(k) - fac011 = fk01 * fac11(k) - fac111 = fk11 * fac11(k) - fac211 = fk21 * fac11(k) - - do ig = 1, ng09 - tauself = selffac(k)* (selfref(ig,inds) + selffrac(k) & - & * (selfref(ig,indsp) - selfref(ig,inds))) - taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & - & * (forref(ig,indfp) - forref(ig,indf))) - n2om1 = ka_mn2o(ig,jmn2o,indm) + fmn2o & - & * (ka_mn2o(ig,jmn2op,indm) - ka_mn2o(ig,jmn2o,indm)) - n2om2 = ka_mn2o(ig,jmn2o,indmp) + fmn2o & - & * (ka_mn2o(ig,jmn2op,indmp) - ka_mn2o(ig,jmn2o,indmp)) - absn2o = n2om1 + minorfrac(k) * (n2om2 - n2om1) - - taug(ns09+ig,k) = speccomb & - & * (fac000*absa(ig,id000) + fac010*absa(ig,id010) & - & + fac100*absa(ig,id100) + fac110*absa(ig,id110) & - & + fac200*absa(ig,id200) + fac210*absa(ig,id210)) & - & + speccomb1 & - & * (fac001*absa(ig,id001) + fac011*absa(ig,id011) & - & + fac101*absa(ig,id101) + fac111*absa(ig,id111) & - & + fac201*absa(ig,id201) + fac211*absa(ig,id211)) & - & + tauself + taufor + adjcoln2o*absn2o - - fracs(ns09+ig,k) = fracrefa(ig,jpl) + fpl & - & * (fracrefa(ig,jplp) - fracrefa(ig,jpl)) - enddo - enddo - -! --- ... upper atmosphere loop - - do k = laytrop+1, nlay - ind0 = ((jp(k)-13)*5 + (jt (k)-1)) * nspb(9) + 1 - ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(9) + 1 - - indm = indminor(k) - ind0p = ind0 + 1 - ind1p = ind1 + 1 - indmp = indm + 1 - -! --- ... in atmospheres where the amount of n2o is too great to be considered -! a minor species, adjust the column amount of n2o by an empirical factor -! to obtain the proper contribution. - - temp = coldry(k) * chi_mls(4,jp(k)+1) - ratn2o = colamt(k,4) / temp - if (ratn2o > 1.5) then - adjfac = 0.5 + (ratn2o - 0.5)**0.65 - adjcoln2o = adjfac * temp - else - adjcoln2o = colamt(k,4) - endif - - do ig = 1, ng09 - absn2o = kb_mn2o(ig,indm) + minorfrac(k) & - & * (kb_mn2o(ig,indmp) - kb_mn2o(ig,indm)) - - taug(ns09+ig,k) = colamt(k,5) & - & * (fac00(k)*absb(ig,ind0) + fac10(k)*absb(ig,ind0p) & - & + fac01(k)*absb(ig,ind1) + fac11(k)*absb(ig,ind1p)) & - & + adjcoln2o*absn2o - - fracs(ns09+ig,k) = fracrefb(ig) - enddo - enddo - -! .................................. - end subroutine taugb09 -! ---------------------------------- - -!>\ingroup module_radlw_main -!> Band 10: 1390-1480 cm-1 (low key - h2o; high key - h2o) -! ---------------------------------- - subroutine taugb10 -! .................................. - -! ------------------------------------------------------------------ ! -! band 10: 1390-1480 cm-1 (low key - h2o; high key - h2o) ! -! ------------------------------------------------------------------ ! - - use module_radlw_kgb10 - -! --- locals: - integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, & - & ig - - real (kind=kind_phys) :: tauself, taufor -! -!===> ... begin here -! -! --- ... lower atmosphere loop - - do k = 1, laytrop - ind0 = ((jp(k)-1)*5 + (jt (k)-1)) * nspa(10) + 1 - ind1 = ( jp(k) *5 + (jt1(k)-1)) * nspa(10) + 1 - - inds = indself(k) - indf = indfor(k) - ind0p = ind0 + 1 - ind1p = ind1 + 1 - indsp = inds + 1 - indfp = indf + 1 - - do ig = 1, ng10 - tauself = selffac(k) * (selfref(ig,inds) + selffrac(k) & - & * (selfref(ig,indsp) - selfref(ig,inds))) - taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & - & * (forref(ig,indfp) - forref(ig,indf))) - - taug(ns10+ig,k) = colamt(k,1) & - & * (fac00(k)*absa(ig,ind0) + fac10(k)*absa(ig,ind0p) & - & + fac01(k)*absa(ig,ind1) + fac11(k)*absa(ig,ind1p)) & - & + tauself + taufor - - fracs(ns10+ig,k) = fracrefa(ig) - enddo - enddo - -! --- ... upper atmosphere loop - - do k = laytrop+1, nlay - ind0 = ((jp(k)-13)*5 + (jt (k)-1)) * nspb(10) + 1 - ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(10) + 1 - - indf = indfor(k) - ind0p = ind0 + 1 - ind1p = ind1 + 1 - indfp = indf + 1 - - do ig = 1, ng10 - taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & - & * (forref(ig,indfp) - forref(ig,indf))) - - taug(ns10+ig,k) = colamt(k,1) & - & * (fac00(k)*absb(ig,ind0) + fac10(k)*absb(ig,ind0p) & - & + fac01(k)*absb(ig,ind1) + fac11(k)*absb(ig,ind1p)) & - & + taufor - - fracs(ns10+ig,k) = fracrefb(ig) - enddo - enddo - -! .................................. - end subroutine taugb10 -! ---------------------------------- - -!>\ingroup module_radlw_main -!> Band 11: 1480-1800 cm-1 (low - h2o; low minor - o2) -!! (high key - h2o; high minor - o2) -! ---------------------------------- - subroutine taugb11 -! .................................. - -! ------------------------------------------------------------------ ! -! band 11: 1480-1800 cm-1 (low - h2o; low minor - o2) ! -! (high key - h2o; high minor - o2) ! -! ------------------------------------------------------------------ ! - - use module_radlw_kgb11 - -! --- locals: - integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, & - & indm, indmp, ig - - real (kind=kind_phys) :: scaleo2, tauself, taufor, tauo2 -! -!===> ... begin here -! -! --- ... minor gas mapping level : -! lower - o2, p = 706.2720 mbar, t = 278.94 k -! upper - o2, p = 4.758820 mbarm t = 250.85 k - -! --- ... lower atmosphere loop - - do k = 1, laytrop - ind0 = ((jp(k)-1)*5 + (jt (k)-1)) * nspa(11) + 1 - ind1 = ( jp(k) *5 + (jt1(k)-1)) * nspa(11) + 1 - - inds = indself(k) - indf = indfor(k) - indm = indminor(k) - ind0p = ind0 + 1 - ind1p = ind1 + 1 - indsp = inds + 1 - indfp = indf + 1 - indmp = indm + 1 - - scaleo2 = colamt(k,6) * scaleminor(k) - - do ig = 1, ng11 - tauself = selffac(k) * (selfref(ig,inds) + selffrac(k) & - & * (selfref(ig,indsp) - selfref(ig,inds))) - taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & - & * (forref(ig,indfp) - forref(ig,indf))) - tauo2 = scaleo2 * (ka_mo2(ig,indm) + minorfrac(k) & - & * (ka_mo2(ig,indmp) - ka_mo2(ig,indm))) - - taug(ns11+ig,k) = colamt(k,1) & - & * (fac00(k)*absa(ig,ind0) + fac10(k)*absa(ig,ind0p) & - & + fac01(k)*absa(ig,ind1) + fac11(k)*absa(ig,ind1p)) & - & + tauself + taufor + tauo2 - - fracs(ns11+ig,k) = fracrefa(ig) - enddo - enddo - -! --- ... upper atmosphere loop - - do k = laytrop+1, nlay - ind0 = ((jp(k)-13)*5 + (jt (k)-1)) * nspb(11) + 1 - ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(11) + 1 - - indf = indfor(k) - indm = indminor(k) - ind0p = ind0 + 1 - ind1p = ind1 + 1 - indfp = indf + 1 - indmp = indm + 1 - - scaleo2 = colamt(k,6) * scaleminor(k) - - do ig = 1, ng11 - taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & - & * (forref(ig,indfp) - forref(ig,indf))) - tauo2 = scaleo2 * (kb_mo2(ig,indm) + minorfrac(k) & - & * (kb_mo2(ig,indmp) - kb_mo2(ig,indm))) - - taug(ns11+ig,k) = colamt(k,1) & - & * (fac00(k)*absb(ig,ind0) + fac10(k)*absb(ig,ind0p) & - & + fac01(k)*absb(ig,ind1) + fac11(k)*absb(ig,ind1p)) & - & + taufor + tauo2 - - fracs(ns11+ig,k) = fracrefb(ig) - enddo - enddo - -! .................................. - end subroutine taugb11 -! ---------------------------------- - -!>\ingroup module_radlw_main -!> Band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing) -! ---------------------------------- - subroutine taugb12 -! .................................. - -! ------------------------------------------------------------------ ! -! band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing) ! -! ------------------------------------------------------------------ ! - - use module_radlw_kgb12 - -! --- locals: - integer :: k, ind0, ind1, inds, indsp, indf, indfp, jpl, jplp, & - & id000, id010, id100, id110, id200, id210, ig, js, js1, & - & id001, id011, id101, id111, id201, id211 - - real (kind=kind_phys) :: tauself, taufor, refrat_planck_a, & - & speccomb, specparm, specmult, fs, & - & speccomb1, specparm1, specmult1, fs1, & - & speccomb_planck,specparm_planck,specmult_planck,fpl, & - & fac000, fac100, fac200, fac010, fac110, fac210, & - & fac001, fac101, fac201, fac011, fac111, fac211, & - & p0, p40, fk00, fk10, fk20, p1, p41, fk01, fk11, fk21 -! -!===> ... begin here -! -! --- ... calculate reference ratio to be used in calculation of Planck -! fraction in lower/upper atmosphere. - - refrat_planck_a = chi_mls(1,10)/chi_mls(2,10) ! P = 174.164 mb - -! --- ... lower atmosphere loop - - do k = 1, laytrop - speccomb = colamt(k,1) + rfrate(k,1,1)*colamt(k,2) - specparm = colamt(k,1) / speccomb - specmult = 8.0 * min(specparm, oneminus) - js = 1 + int(specmult) - fs = mod(specmult, f_one) - ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(12) + js - - speccomb1 = colamt(k,1) + rfrate(k,1,2)*colamt(k,2) - specparm1 = colamt(k,1) / speccomb1 - specmult1 = 8.0 * min(specparm1, oneminus) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1, f_one) - ind1 = (jp(k)*5 + (jt1(k)-1)) * nspa(12) + js1 - - speccomb_planck = colamt(k,1) + refrat_planck_a*colamt(k,2) - specparm_planck = colamt(k,1) / speccomb_planck - if (specparm_planck >= oneminus) specparm_planck=oneminus - specmult_planck = 8.0 * specparm_planck - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck, f_one) - - inds = indself(k) - indf = indfor(k) - indsp = inds + 1 - indfp = indf + 1 - jplp = jpl + 1 - - if (specparm < 0.125) then - p0 = fs - f_one - p40 = p0**4 - fk00 = p40 - fk10 = f_one - p0 - 2.0*p40 - fk20 = p0 + p40 - - id000 = ind0 - id010 = ind0 + 9 - id100 = ind0 + 1 - id110 = ind0 +10 - id200 = ind0 + 2 - id210 = ind0 +11 - elseif (specparm > 0.875) then - p0 = -fs - p40 = p0**4 - fk00 = p40 - fk10 = f_one - p0 - 2.0*p40 - fk20 = p0 + p40 - - id000 = ind0 + 1 - id010 = ind0 +10 - id100 = ind0 - id110 = ind0 + 9 - id200 = ind0 - 1 - id210 = ind0 + 8 - else - fk00 = f_one - fs - fk10 = fs - fk20 = f_zero - - id000 = ind0 - id010 = ind0 + 9 - id100 = ind0 + 1 - id110 = ind0 +10 - id200 = ind0 - id210 = ind0 - endif - - fac000 = fk00 * fac00(k) - fac100 = fk10 * fac00(k) - fac200 = fk20 * fac00(k) - fac010 = fk00 * fac10(k) - fac110 = fk10 * fac10(k) - fac210 = fk20 * fac10(k) - - if (specparm1 < 0.125) then - p1 = fs1 - f_one - p41 = p1**4 - fk01 = p41 - fk11 = f_one - p1 - 2.0*p41 - fk21 = p1 + p41 - - id001 = ind1 - id011 = ind1 + 9 - id101 = ind1 + 1 - id111 = ind1 +10 - id201 = ind1 + 2 - id211 = ind1 +11 - elseif (specparm1 > 0.875) then - p1 = -fs1 - p41 = p1**4 - fk01 = p41 - fk11 = f_one - p1 - 2.0*p41 - fk21 = p1 + p41 - - id001 = ind1 + 1 - id011 = ind1 +10 - id101 = ind1 - id111 = ind1 + 9 - id201 = ind1 - 1 - id211 = ind1 + 8 - else - fk01 = f_one - fs1 - fk11 = fs1 - fk21 = f_zero - - id001 = ind1 - id011 = ind1 + 9 - id101 = ind1 + 1 - id111 = ind1 +10 - id201 = ind1 - id211 = ind1 - endif - - fac001 = fk01 * fac01(k) - fac101 = fk11 * fac01(k) - fac201 = fk21 * fac01(k) - fac011 = fk01 * fac11(k) - fac111 = fk11 * fac11(k) - fac211 = fk21 * fac11(k) - - do ig = 1, ng12 - tauself = selffac(k)* (selfref(ig,inds) + selffrac(k) & - & * (selfref(ig,indsp) - selfref(ig,inds))) - taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & - & * (forref(ig,indfp) - forref(ig,indf))) - - taug(ns12+ig,k) = speccomb & - & * (fac000*absa(ig,id000) + fac010*absa(ig,id010) & - & + fac100*absa(ig,id100) + fac110*absa(ig,id110) & - & + fac200*absa(ig,id200) + fac210*absa(ig,id210)) & - & + speccomb1 & - & * (fac001*absa(ig,id001) + fac011*absa(ig,id011) & - & + fac101*absa(ig,id101) + fac111*absa(ig,id111) & - & + fac201*absa(ig,id201) + fac211*absa(ig,id211)) & - & + tauself + taufor - - fracs(ns12+ig,k) = fracrefa(ig,jpl) + fpl & - & *(fracrefa(ig,jplp) - fracrefa(ig,jpl)) - enddo - enddo - -! --- ... upper atmosphere loop - - do k = laytrop+1, nlay - do ig = 1, ng12 - taug(ns12+ig,k) = f_zero - fracs(ns12+ig,k) = f_zero - enddo - enddo - -! .................................. - end subroutine taugb12 -! ---------------------------------- - -!>\ingroup module_radlw_main -!> Band 13: 2080-2250 cm-1 (low key-h2o,n2o; high minor-o3 minor) -! ---------------------------------- - subroutine taugb13 -! .................................. - -! ------------------------------------------------------------------ ! -! band 13: 2080-2250 cm-1 (low key-h2o,n2o; high minor-o3 minor) ! -! ------------------------------------------------------------------ ! - - use module_radlw_kgb13 - -! --- locals: - integer :: k, ind0, ind1, inds, indsp, indf, indfp, indm, indmp, & - & id000, id010, id100, id110, id200, id210, jmco2, jpl, & - & id001, id011, id101, id111, id201, id211, jmco2p, jplp, & - & jmco, jmcop, ig, js, js1 - - real (kind=kind_phys) :: tauself, taufor, co2m1, co2m2, absco2, & - & speccomb, specparm, specmult, fs, & - & speccomb1, specparm1, specmult1, fs1, & - & speccomb_mco2, specparm_mco2, specmult_mco2, fmco2, & - & speccomb_mco, specparm_mco, specmult_mco, fmco, & - & speccomb_planck,specparm_planck,specmult_planck,fpl, & - & refrat_planck_a, refrat_m_a, refrat_m_a3, ratco2, & - & adjfac, adjcolco2, com1, com2, absco, abso3, & - & fac000, fac100, fac200, fac010, fac110, fac210, & - & fac001, fac101, fac201, fac011, fac111, fac211, & - & p0, p40, fk00, fk10, fk20, p1, p41, fk01, fk11, fk21, temp -! -!===> ... begin here -! -! --- ... minor gas mapping levels : -! lower - co2, p = 1053.63 mb, t = 294.2 k -! lower - co, p = 706 mb, t = 278.94 k -! upper - o3, p = 95.5835 mb, t = 215.7 k - -! --- ... calculate reference ratio to be used in calculation of Planck -! fraction in lower/upper atmosphere. - - refrat_planck_a = chi_mls(1,5)/chi_mls(4,5) ! P = 473.420 mb (Level 5) - refrat_m_a = chi_mls(1,1)/chi_mls(4,1) ! P = 1053. (Level 1) - refrat_m_a3 = chi_mls(1,3)/chi_mls(4,3) ! P = 706. (Level 3) - -! --- ... lower atmosphere loop - - do k = 1, laytrop - speccomb = colamt(k,1) + rfrate(k,3,1)*colamt(k,4) - specparm = colamt(k,1) / speccomb - specmult = 8.0 * min(specparm, oneminus) - js = 1 + int(specmult) - fs = mod(specmult, f_one) - ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(13) + js - - speccomb1 = colamt(k,1) + rfrate(k,3,2)*colamt(k,4) - specparm1 = colamt(k,1) / speccomb1 - specmult1 = 8.0 * min(specparm1, oneminus) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1, f_one) - ind1 = (jp(k)*5 + (jt1(k)-1)) * nspa(13) + js1 - - speccomb_mco2 = colamt(k,1) + refrat_m_a*colamt(k,4) - specparm_mco2 = colamt(k,1) / speccomb_mco2 - specmult_mco2 = 8.0 * min(specparm_mco2, oneminus) - jmco2 = 1 + int(specmult_mco2) - fmco2 = mod(specmult_mco2, f_one) - -! --- ... in atmospheres where the amount of co2 is too great to be considered -! a minor species, adjust the column amount of co2 by an empirical factor -! to obtain the proper contribution. - - speccomb_mco = colamt(k,1) + refrat_m_a3*colamt(k,4) - specparm_mco = colamt(k,1) / speccomb_mco - specmult_mco = 8.0 * min(specparm_mco, oneminus) - jmco = 1 + int(specmult_mco) - fmco = mod(specmult_mco, f_one) - - speccomb_planck = colamt(k,1) + refrat_planck_a*colamt(k,4) - specparm_planck = colamt(k,1) / speccomb_planck - specmult_planck = 8.0 * min(specparm_planck, oneminus) - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck, f_one) - - inds = indself(k) - indf = indfor(k) - indm = indminor(k) - indsp = inds + 1 - indfp = indf + 1 - indmp = indm + 1 - jplp = jpl + 1 - jmco2p= jmco2+ 1 - jmcop = jmco + 1 - -! --- ... in atmospheres where the amount of co2 is too great to be considered -! a minor species, adjust the column amount of co2 by an empirical factor -! to obtain the proper contribution. - - temp = coldry(k) * 3.55e-4 - ratco2 = colamt(k,2) / temp - if (ratco2 > 3.0) then - adjfac = 2.0 + (ratco2-2.0)**0.68 - adjcolco2 = adjfac * temp - else - adjcolco2 = colamt(k,2) - endif - - if (specparm < 0.125) then - p0 = fs - f_one - p40 = p0**4 - fk00 = p40 - fk10 = f_one - p0 - 2.0*p40 - fk20 = p0 + p40 - - id000 = ind0 - id010 = ind0 + 9 - id100 = ind0 + 1 - id110 = ind0 +10 - id200 = ind0 + 2 - id210 = ind0 +11 - elseif (specparm > 0.875) then - p0 = -fs - p40 = p0**4 - fk00 = p40 - fk10 = f_one - p0 - 2.0*p40 - fk20 = p0 + p40 - - id000 = ind0 + 1 - id010 = ind0 +10 - id100 = ind0 - id110 = ind0 + 9 - id200 = ind0 - 1 - id210 = ind0 + 8 - else - fk00 = f_one - fs - fk10 = fs - fk20 = f_zero - - id000 = ind0 - id010 = ind0 + 9 - id100 = ind0 + 1 - id110 = ind0 +10 - id200 = ind0 - id210 = ind0 - endif - - fac000 = fk00 * fac00(k) - fac100 = fk10 * fac00(k) - fac200 = fk20 * fac00(k) - fac010 = fk00 * fac10(k) - fac110 = fk10 * fac10(k) - fac210 = fk20 * fac10(k) - - if (specparm1 < 0.125) then - p1 = fs1 - f_one - p41 = p1**4 - fk01 = p41 - fk11 = f_one - p1 - 2.0*p41 - fk21 = p1 + p41 - - id001 = ind1 - id011 = ind1 + 9 - id101 = ind1 + 1 - id111 = ind1 +10 - id201 = ind1 + 2 - id211 = ind1 +11 - elseif (specparm1 > 0.875) then - p1 = -fs1 - p41 = p1**4 - fk01 = p41 - fk11 = f_one - p1 - 2.0*p41 - fk21 = p1 + p41 - - id001 = ind1 + 1 - id011 = ind1 +10 - id101 = ind1 - id111 = ind1 + 9 - id201 = ind1 - 1 - id211 = ind1 + 8 - else - fk01 = f_one - fs1 - fk11 = fs1 - fk21 = f_zero - - id001 = ind1 - id011 = ind1 + 9 - id101 = ind1 + 1 - id111 = ind1 +10 - id201 = ind1 - id211 = ind1 - endif - - fac001 = fk01 * fac01(k) - fac101 = fk11 * fac01(k) - fac201 = fk21 * fac01(k) - fac011 = fk01 * fac11(k) - fac111 = fk11 * fac11(k) - fac211 = fk21 * fac11(k) - - do ig = 1, ng13 - tauself = selffac(k)* (selfref(ig,inds) + selffrac(k) & - & * (selfref(ig,indsp) - selfref(ig,inds))) - taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & - & * (forref(ig,indfp) - forref(ig,indf))) - co2m1 = ka_mco2(ig,jmco2,indm) + fmco2 & - & * (ka_mco2(ig,jmco2p,indm) - ka_mco2(ig,jmco2,indm)) - co2m2 = ka_mco2(ig,jmco2,indmp) + fmco2 & - & * (ka_mco2(ig,jmco2p,indmp) - ka_mco2(ig,jmco2,indmp)) - absco2 = co2m1 + minorfrac(k) * (co2m2 - co2m1) - com1 = ka_mco(ig,jmco,indm) + fmco & - & * (ka_mco(ig,jmcop,indm) - ka_mco(ig,jmco,indm)) - com2 = ka_mco(ig,jmco,indmp) + fmco & - & * (ka_mco(ig,jmcop,indmp) - ka_mco(ig,jmco,indmp)) - absco = com1 + minorfrac(k) * (com2 - com1) - - taug(ns13+ig,k) = speccomb & - & * (fac000*absa(ig,id000) + fac010*absa(ig,id010) & - & + fac100*absa(ig,id100) + fac110*absa(ig,id110) & - & + fac200*absa(ig,id200) + fac210*absa(ig,id210)) & - & + speccomb1 & - & * (fac001*absa(ig,id001) + fac011*absa(ig,id011) & - & + fac101*absa(ig,id101) + fac111*absa(ig,id111) & - & + fac201*absa(ig,id201) + fac211*absa(ig,id211)) & - & + tauself + taufor + adjcolco2*absco2 & - & + colamt(k,7)*absco - - fracs(ns13+ig,k) = fracrefa(ig,jpl) + fpl & - & * (fracrefa(ig,jplp) - fracrefa(ig,jpl)) - enddo - enddo - -! --- ... upper atmosphere loop - - do k = laytrop+1, nlay - indm = indminor(k) - indmp = indm + 1 - - do ig = 1, ng13 - abso3 = kb_mo3(ig,indm) + minorfrac(k) & - & * (kb_mo3(ig,indmp) - kb_mo3(ig,indm)) - - taug(ns13+ig,k) = colamt(k,3)*abso3 - - fracs(ns13+ig,k) = fracrefb(ig) - enddo - enddo - -! .................................. - end subroutine taugb13 -! ---------------------------------- - -!>\ingroup module_radlw_main -!> Band 14: 2250-2380 cm-1 (low - co2; high - co2) -! ---------------------------------- - subroutine taugb14 -! .................................. - -! ------------------------------------------------------------------ ! -! band 14: 2250-2380 cm-1 (low - co2; high - co2) ! -! ------------------------------------------------------------------ ! - - use module_radlw_kgb14 - -! --- locals: - integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, & - & ig - - real (kind=kind_phys) :: tauself, taufor -! -!===> ... begin here -! -! --- ... lower atmosphere loop - - do k = 1, laytrop - ind0 = ((jp(k)-1)*5 + (jt (k)-1)) * nspa(14) + 1 - ind1 = ( jp(k) *5 + (jt1(k)-1)) * nspa(14) + 1 - - inds = indself(k) - indf = indfor(k) - ind0p = ind0 + 1 - ind1p = ind1 + 1 - indsp = inds + 1 - indfp = indf + 1 - - do ig = 1, ng14 - tauself = selffac(k) * (selfref(ig,inds) + selffrac(k) & - & * (selfref(ig,indsp) - selfref(ig,inds))) - taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & - & * (forref(ig,indfp) - forref(ig,indf))) - - taug(ns14+ig,k) = colamt(k,2) & - & * (fac00(k)*absa(ig,ind0) + fac10(k)*absa(ig,ind0p) & - & + fac01(k)*absa(ig,ind1) + fac11(k)*absa(ig,ind1p)) & - & + tauself + taufor - - fracs(ns14+ig,k) = fracrefa(ig) - enddo - enddo - -! --- ... upper atmosphere loop - - do k = laytrop+1, nlay - ind0 = ((jp(k)-13)*5 + (jt (k)-1)) * nspb(14) + 1 - ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(14) + 1 - - ind0p = ind0 + 1 - ind1p = ind1 + 1 - - do ig = 1, ng14 - taug(ns14+ig,k) = colamt(k,2) & - & * (fac00(k)*absb(ig,ind0) + fac10(k)*absb(ig,ind0p) & - & + fac01(k)*absb(ig,ind1) + fac11(k)*absb(ig,ind1p)) - - fracs(ns14+ig,k) = fracrefb(ig) - enddo - enddo - -! .................................. - end subroutine taugb14 -! ---------------------------------- - -!>\ingroup module_radlw_main -!> Band 15: 2380-2600 cm-1 (low - n2o,co2; low minor - n2) -!! (high - nothing) -! ---------------------------------- - subroutine taugb15 -! .................................. - -! ------------------------------------------------------------------ ! -! band 15: 2380-2600 cm-1 (low - n2o,co2; low minor - n2) ! -! (high - nothing) ! -! ------------------------------------------------------------------ ! - - use module_radlw_kgb15 - -! --- locals: - integer :: k, ind0, ind1, inds, indsp, indf, indfp, indm, indmp, & - & id000, id010, id100, id110, id200, id210, jpl, jplp, & - & id001, id011, id101, id111, id201, id211, jmn2, jmn2p, & - & ig, js, js1 - - real (kind=kind_phys) :: scalen2, tauself, taufor, & - & speccomb, specparm, specmult, fs, & - & speccomb1, specparm1, specmult1, fs1, & - & speccomb_mn2, specparm_mn2, specmult_mn2, fmn2, & - & speccomb_planck,specparm_planck,specmult_planck,fpl, & - & refrat_planck_a, refrat_m_a, n2m1, n2m2, taun2, & - & fac000, fac100, fac200, fac010, fac110, fac210, & - & fac001, fac101, fac201, fac011, fac111, fac211, & - & p0, p40, fk00, fk10, fk20, p1, p41, fk01, fk11, fk21 -! -!===> ... begin here -! -! --- ... minor gas mapping level : -! lower - nitrogen continuum, P = 1053., T = 294. - -! --- ... calculate reference ratio to be used in calculation of Planck -! fraction in lower atmosphere. - - refrat_planck_a = chi_mls(4,1)/chi_mls(2,1) ! P = 1053. mb (Level 1) - refrat_m_a = chi_mls(4,1)/chi_mls(2,1) ! P = 1053. mb - -! --- ... lower atmosphere loop - - do k = 1, laytrop - speccomb = colamt(k,4) + rfrate(k,5,1)*colamt(k,2) - specparm = colamt(k,4) / speccomb - specmult = 8.0 * min(specparm, oneminus) - js = 1 + int(specmult) - fs = mod(specmult, f_one) - ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(15) + js - - speccomb1 = colamt(k,4) + rfrate(k,5,2)*colamt(k,2) - specparm1 = colamt(k,4) / speccomb1 - specmult1 = 8.0 * min(specparm1, oneminus) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1, f_one) - ind1 = (jp(k)*5 + (jt1(k)-1)) * nspa(15) + js1 - - speccomb_mn2 = colamt(k,4) + refrat_m_a*colamt(k,2) - specparm_mn2 = colamt(k,4) / speccomb_mn2 - specmult_mn2 = 8.0 * min(specparm_mn2, oneminus) - jmn2 = 1 + int(specmult_mn2) - fmn2 = mod(specmult_mn2, f_one) - - speccomb_planck = colamt(k,4) + refrat_planck_a*colamt(k,2) - specparm_planck = colamt(k,4) / speccomb_planck - specmult_planck = 8.0 * min(specparm_planck, oneminus) - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck, f_one) - - scalen2 = colbrd(k) * scaleminor(k) - - inds = indself(k) - indf = indfor(k) - indm = indminor(k) - indsp = inds + 1 - indfp = indf + 1 - indmp = indm + 1 - jplp = jpl + 1 - jmn2p = jmn2 + 1 - - if (specparm < 0.125) then - p0 = fs - f_one - p40 = p0**4 - fk00 = p40 - fk10 = f_one - p0 - 2.0*p40 - fk20 = p0 + p40 - - id000 = ind0 - id010 = ind0 + 9 - id100 = ind0 + 1 - id110 = ind0 +10 - id200 = ind0 + 2 - id210 = ind0 +11 - elseif (specparm > 0.875) then - p0 = -fs - p40 = p0**4 - fk00 = p40 - fk10 = f_one - p0 - 2.0*p40 - fk20 = p0 + p40 - - id000 = ind0 + 1 - id010 = ind0 +10 - id100 = ind0 - id110 = ind0 + 9 - id200 = ind0 - 1 - id210 = ind0 + 8 - else - fk00 = f_one - fs - fk10 = fs - fk20 = f_zero - - id000 = ind0 - id010 = ind0 + 9 - id100 = ind0 + 1 - id110 = ind0 +10 - id200 = ind0 - id210 = ind0 - endif - - fac000 = fk00 * fac00(k) - fac100 = fk10 * fac00(k) - fac200 = fk20 * fac00(k) - fac010 = fk00 * fac10(k) - fac110 = fk10 * fac10(k) - fac210 = fk20 * fac10(k) - - if (specparm1 < 0.125) then - p1 = fs1 - f_one - p41 = p1**4 - fk01 = p41 - fk11 = f_one - p1 - 2.0*p41 - fk21 = p1 + p41 - - id001 = ind1 - id011 = ind1 + 9 - id101 = ind1 + 1 - id111 = ind1 +10 - id201 = ind1 + 2 - id211 = ind1 +11 - elseif (specparm1 > 0.875) then - p1 = -fs1 - p41 = p1**4 - fk01 = p41 - fk11 = f_one - p1 - 2.0*p41 - fk21 = p1 + p41 - - id001 = ind1 + 1 - id011 = ind1 +10 - id101 = ind1 - id111 = ind1 + 9 - id201 = ind1 - 1 - id211 = ind1 + 8 - else - fk01 = f_one - fs1 - fk11 = fs1 - fk21 = f_zero - - id001 = ind1 - id011 = ind1 + 9 - id101 = ind1 + 1 - id111 = ind1 +10 - id201 = ind1 - id211 = ind1 - endif - - fac001 = fk01 * fac01(k) - fac101 = fk11 * fac01(k) - fac201 = fk21 * fac01(k) - fac011 = fk01 * fac11(k) - fac111 = fk11 * fac11(k) - fac211 = fk21 * fac11(k) - - do ig = 1, ng15 - tauself = selffac(k)* (selfref(ig,inds) + selffrac(k) & - & * (selfref(ig,indsp) - selfref(ig,inds))) - taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & - & * (forref(ig,indfp) - forref(ig,indf))) - n2m1 = ka_mn2(ig,jmn2,indm) + fmn2 & - & * (ka_mn2(ig,jmn2p,indm) - ka_mn2(ig,jmn2,indm)) - n2m2 = ka_mn2(ig,jmn2,indmp) + fmn2 & - & * (ka_mn2(ig,jmn2p,indmp) - ka_mn2(ig,jmn2,indmp)) - taun2 = scalen2 * (n2m1 + minorfrac(k) * (n2m2 - n2m1)) - - taug(ns15+ig,k) = speccomb & - & * (fac000*absa(ig,id000) + fac010*absa(ig,id010) & - & + fac100*absa(ig,id100) + fac110*absa(ig,id110) & - & + fac200*absa(ig,id200) + fac210*absa(ig,id210)) & - & + speccomb1 & - & * (fac001*absa(ig,id001) + fac011*absa(ig,id011) & - & + fac101*absa(ig,id101) + fac111*absa(ig,id111) & - & + fac201*absa(ig,id201) + fac211*absa(ig,id211)) & - & + tauself + taufor + taun2 - - fracs(ns15+ig,k) = fracrefa(ig,jpl) + fpl & - & * (fracrefa(ig,jplp) - fracrefa(ig,jpl)) - enddo - enddo - -! --- ... upper atmosphere loop - - do k = laytrop+1, nlay - do ig = 1, ng15 - taug(ns15+ig,k) = f_zero - - fracs(ns15+ig,k) = f_zero - enddo - enddo - -! .................................. - end subroutine taugb15 -! ---------------------------------- - -!>\ingroup module_radlw_main -!> Band 16: 2600-3250 cm-1 (low key- h2o,ch4; high key - ch4) -! ---------------------------------- - subroutine taugb16 -! .................................. - -! ------------------------------------------------------------------ ! -! band 16: 2600-3250 cm-1 (low key- h2o,ch4; high key - ch4) ! -! ------------------------------------------------------------------ ! - - use module_radlw_kgb16 - -! --- locals: - integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, & - & id000, id010, id100, id110, id200, id210, jpl, jplp, & - & id001, id011, id101, id111, id201, id211, ig, js, js1 - - real (kind=kind_phys) :: tauself, taufor, refrat_planck_a, & - & speccomb, specparm, specmult, fs, & - & speccomb1, specparm1, specmult1, fs1, & - & speccomb_planck,specparm_planck,specmult_planck,fpl, & - & fac000, fac100, fac200, fac010, fac110, fac210, & - & fac001, fac101, fac201, fac011, fac111, fac211, & - & p0, p40, fk00, fk10, fk20, p1, p41, fk01, fk11, fk21 -! -!===> ... begin here -! -! --- ... calculate reference ratio to be used in calculation of Planck -! fraction in lower atmosphere. - - refrat_planck_a = chi_mls(1,6)/chi_mls(6,6) ! P = 387. mb (Level 6) - -! --- ... lower atmosphere loop - - do k = 1, laytrop - speccomb = colamt(k,1) + rfrate(k,4,1)*colamt(k,5) - specparm = colamt(k,1) / speccomb - specmult = 8.0 * min(specparm, oneminus) - js = 1 + int(specmult) - fs = mod(specmult, f_one) - ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(16) + js - - speccomb1 = colamt(k,1) + rfrate(k,4,2)*colamt(k,5) - specparm1 = colamt(k,1) / speccomb1 - specmult1 = 8.0 * min(specparm1, oneminus) - js1 = 1 + int(specmult1) - fs1 = mod(specmult1, f_one) - ind1 = (jp(k)*5 + (jt1(k)-1)) * nspa(16) + js1 - - speccomb_planck = colamt(k,1) + refrat_planck_a*colamt(k,5) - specparm_planck = colamt(k,1) / speccomb_planck - specmult_planck = 8.0 * min(specparm_planck, oneminus) - jpl = 1 + int(specmult_planck) - fpl = mod(specmult_planck, f_one) - - inds = indself(k) - indf = indfor(k) - indsp = inds + 1 - indfp = indf + 1 - jplp = jpl + 1 - - if (specparm < 0.125) then - p0 = fs - f_one - p40 = p0**4 - fk00 = p40 - fk10 = f_one - p0 - 2.0*p40 - fk20 = p0 + p40 - - id000 = ind0 - id010 = ind0 + 9 - id100 = ind0 + 1 - id110 = ind0 +10 - id200 = ind0 + 2 - id210 = ind0 +11 - elseif (specparm > 0.875) then - p0 = -fs - p40 = p0**4 - fk00 = p40 - fk10 = f_one - p0 - 2.0*p40 - fk20 = p0 + p40 - - id000 = ind0 + 1 - id010 = ind0 +10 - id100 = ind0 - id110 = ind0 + 9 - id200 = ind0 - 1 - id210 = ind0 + 8 - else - fk00 = f_one - fs - fk10 = fs - fk20 = f_zero - - id000 = ind0 - id010 = ind0 + 9 - id100 = ind0 + 1 - id110 = ind0 +10 - id200 = ind0 - id210 = ind0 - endif - - fac000 = fk00 * fac00(k) - fac100 = fk10 * fac00(k) - fac200 = fk20 * fac00(k) - fac010 = fk00 * fac10(k) - fac110 = fk10 * fac10(k) - fac210 = fk20 * fac10(k) - - if (specparm1 < 0.125) then - p1 = fs1 - f_one - p41 = p1**4 - fk01 = p41 - fk11 = f_one - p1 - 2.0*p41 - fk21 = p1 + p41 - - id001 = ind1 - id011 = ind1 + 9 - id101 = ind1 + 1 - id111 = ind1 +10 - id201 = ind1 + 2 - id211 = ind1 +11 - elseif (specparm1 > 0.875) then - p1 = -fs1 - p41 = p1**4 - fk01 = p41 - fk11 = f_one - p1 - 2.0*p41 - fk21 = p1 + p41 - - id001 = ind1 + 1 - id011 = ind1 +10 - id101 = ind1 - id111 = ind1 + 9 - id201 = ind1 - 1 - id211 = ind1 + 8 - else - fk01 = f_one - fs1 - fk11 = fs1 - fk21 = f_zero - - id001 = ind1 - id011 = ind1 + 9 - id101 = ind1 + 1 - id111 = ind1 +10 - id201 = ind1 - id211 = ind1 - endif - - fac001 = fk01 * fac01(k) - fac101 = fk11 * fac01(k) - fac201 = fk21 * fac01(k) - fac011 = fk01 * fac11(k) - fac111 = fk11 * fac11(k) - fac211 = fk21 * fac11(k) - - do ig = 1, ng16 - tauself = selffac(k)* (selfref(ig,inds) + selffrac(k) & - & * (selfref(ig,indsp) - selfref(ig,inds))) - taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & - & * (forref(ig,indfp) - forref(ig,indf))) - - taug(ns16+ig,k) = speccomb & - & * (fac000*absa(ig,id000) + fac010*absa(ig,id010) & - & + fac100*absa(ig,id100) + fac110*absa(ig,id110) & - & + fac200*absa(ig,id200) + fac210*absa(ig,id210)) & - & + speccomb1 & - & * (fac001*absa(ig,id001) + fac011*absa(ig,id011) & - & + fac101*absa(ig,id101) + fac111*absa(ig,id111) & - & + fac201*absa(ig,id201) + fac211*absa(ig,id211)) & - & + tauself + taufor - - fracs(ns16+ig,k) = fracrefa(ig,jpl) + fpl & - & * (fracrefa(ig,jplp) - fracrefa(ig,jpl)) - enddo - enddo - -! --- ... upper atmosphere loop - - do k = laytrop+1, nlay - ind0 = ((jp(k)-13)*5 + (jt (k)-1)) * nspb(16) + 1 - ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(16) + 1 - - ind0p = ind0 + 1 - ind1p = ind1 + 1 - - do ig = 1, ng16 - taug(ns16+ig,k) = colamt(k,5) & - & * (fac00(k)*absb(ig,ind0) + fac10(k)*absb(ig,ind0p) & - & + fac01(k)*absb(ig,ind1) + fac11(k)*absb(ig,ind1p)) - - fracs(ns16+ig,k) = fracrefb(ig) - enddo - enddo - -! .................................. - end subroutine taugb16 -! ---------------------------------- - -! .................................. - end subroutine taumol -!! @} -!----------------------------------- - -!mz* exponential cloud overlapping subroutines -!------------------------------------------------------------------ -! Public subroutines -!------------------------------------------------------------------ -! mz* - Add height needed for exponential and exponential-random cloud overlap methods (icld=4 and 5, respectively) -! mz* - cldfmcl only *temporary - subroutine mcica_subcol_lw(iplon, ncol, nlay, icld, permuteseed, & - & irng, play, hgt, & - & cldfrac, ciwp, clwp, cswp, rei, rel, res, tauc, & - & cldfmcl) -!mz* the below output need to be compatible with cldprop() -!mz ciwpmcl, clwpmcl, cswpmcl, reicmcl, relqmcl, resnmcl, taucmcl) - - use machine, only : im => kind_io4, rb => kind_phys -! ----- Input ----- -! Control - integer(kind=im), intent(in) :: iplon ! column/longitude index - integer(kind=im), intent(in) :: ncol ! number of columns - integer(kind=im), intent(in) :: nlay ! number of model layers - integer(kind=im), intent(in) :: icld ! clear/cloud, cloud overlap flag - integer(kind=im), intent(in) :: permuteseed ! if the cloud generator is called multiple times, - ! permute the seed between each call. - ! between calls for LW and SW, recommended - ! permuteseed differes by 'ngpt' - integer(kind=im), intent(inout) :: irng ! flag for random number generator - ! 0 = kissvec - ! 1 = Mersenne - ! Twister - -! Atmosphere - real(kind=rb), intent(in) :: play(:,:) ! layer pressures (mb) - ! Dimensions: (ncol,nlay) - -! mji - Add height - real(kind=rb), intent(in) :: hgt(:,:) ! layer height (m) - ! Dimensions: (ncol,nlay) - -! Atmosphere/clouds - cldprop - real(kind=rb), intent(in) :: cldfrac(:,:) ! layer cloud fraction - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: tauc(:,:,:) ! in-cloud optical depth - ! Dimensions: (nbndlw,ncol,nlay) -! real(kind=rb), intent(in) :: ssac(:,:,:) ! in-cloud single scattering albedo - ! Dimensions: (nbndlw,ncol,nlay) -! real(kind=rb), intent(in) :: asmc(:,:,:) ! in-cloud asymmetry parameter - ! Dimensions: (nbndlw,ncol,nlay) - real(kind=rb), intent(in) :: ciwp(:,:) ! in-cloud ice water path - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: clwp(:,:) ! in-cloud liquid water path - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: cswp(:,:) ! in-cloud snow path - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: rei(:,:) ! cloud ice particle size - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: rel(:,:) ! cloud liquid particle size - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: res(:,:) ! snow particle size - ! Dimensions: (ncol,nlay) - -! ----- Output ----- -! Atmosphere/clouds - cldprmc [mcica] - real(kind=rb), intent(out) :: cldfmcl(:,:,:) ! cloud fraction [mcica] - ! Dimensions: (ngptlw,ncol,nlay) -!mz* not activate, temporary local vars - real(kind=rb),dimension(ngptlw,ncol,nlay) :: ciwpmcl ! in-cloud ice water path [mcica] - ! Dimensions: (ngptlw,ncol,nlay) - real(kind=rb),dimension(ngptlw,ncol,nlay) :: clwpmcl ! in-cloud liquid water path [mcica] - ! Dimensions: (ngptlw,ncol,nlay) - real(kind=rb),dimension(ngptlw,ncol,nlay) :: cswpmcl ! in-cloud snow path [mcica] - ! Dimensions: (ngptlw,ncol,nlay) - real(kind=rb),dimension(ncol,nlay) :: relqmcl ! liquid particle size (microns) - ! Dimensions: (ncol,nlay) - real(kind=rb),dimension(ncol,nlay) :: reicmcl ! ice partcle size (microns) - ! Dimensions: (ncol,nlay) - real(kind=rb),dimension(ncol,nlay) :: resnmcl ! snow partcle size (microns) - ! Dimensions: (ncol,nlay) - real(kind=rb),dimension(ngptlw,ncol,nlay) :: taucmcl ! in-cloud optical depth [mcica] -!mz* - ! Dimensions: (ngptlw,ncol,nlay) -! real(kind=rb), intent(out) :: ssacmcl(:,:,:) ! in-cloud single scattering albedo [mcica] - ! Dimensions: (ngptlw,ncol,nlay) -! real(kind=rb), intent(out) :: asmcmcl(:,:,:) ! in-cloud asymmetry parameter [mcica] - ! Dimensions: (ngptlw,ncol,nlay) -! ----- Local ----- - -! Stochastic cloud generator variables [mcica] - integer(kind=im), parameter :: nsubclw = ngptlw ! number of sub-columns (g-point intervals) - integer(kind=im) :: ilev ! loop index - - real(kind=rb) :: pmid(ncol, nlay) ! layer pressures (Pa) -! real(kind=rb) :: pdel(ncol, nlay) ! layer pressure thickness (Pa) -! real(kind=rb) :: qi(ncol, nlay) ! ice water (specific humidity) -! real(kind=rb) :: ql(ncol, nlay) ! liq water (specific humidity) - -! Return if clear sky - if (icld.eq.0) return - -! NOTE: For GCM mode, permuteseed must be offset between LW and SW by at least the number of subcolumns - - -! Pass particle sizes to new arrays, no subcolumns for these properties yet -! Convert pressures from mb to Pa - - reicmcl(:ncol,:nlay) = rei(:ncol,:nlay) - relqmcl(:ncol,:nlay) = rel(:ncol,:nlay) - resnmcl(:ncol,:nlay) = res(:ncol,:nlay) - pmid(:ncol,:nlay) = play(:ncol,:nlay)*1.e2_rb - -! Generate the stochastic subcolumns of cloud optical properties for -! the longwave - call generate_stochastic_clouds (ncol, nlay, nsubclw, icld, irng, & - & pmid, hgt, cldfrac, clwp, ciwp, cswp, tauc, & - & cldfmcl, clwpmcl, ciwpmcl, cswpmcl, & - & taucmcl, permuteseed) - - end subroutine mcica_subcol_lw -!------------------------------------------------------------------------------------------------- - subroutine generate_stochastic_clouds(ncol, nlay, nsubcol, icld, & - & irng, pmid, hgt, cld, clwp, ciwp, cswp, tauc, & - & cld_stoch, clwp_stoch, ciwp_stoch, & - & cswp_stoch, tauc_stoch, changeSeed) -!------------------------------------------------------------------------------------------------- -!------------------------------------------------------------------------------------------------- -! Contact: Cecile Hannay (hannay@ucar.edu) -! -! Original code: Based on Raisanen et al., QJRMS, 2004. -! -! Modifications: -! 1) Generalized for use with RRTMG and added Mersenne Twister as the default -! random number generator, which can be changed to the optional kissvec random number generator -! with flag 'irng'. Some extra functionality has been commented or removed. -! Michael J. Iacono, AER, Inc., February 2007 -! 2) Activated exponential and exponential/random cloud overlap method -! Michael J. Iacono, AER, November 2017 -! -! Given a profile of cloud fraction, cloud water and cloud ice, we produce a set of subcolumns. -! Each layer within each subcolumn is homogeneous, with cloud fraction equal to zero or one -! and uniform cloud liquid and cloud ice concentration. -! The ensemble as a whole reproduces the probability function of cloud liquid and ice within each layer -! and obeys an overlap assumption in the vertical. -! -! Overlap assumption: -! The cloud are consistent with 5 overlap assumptions: random, maximum, maximum-random, exponential and exponential random. -! The default option is maximum-random (option 2) -! The options are: 1=random overlap, 2=max/random, 3=maximum overlap, 4=exponential overlap, 5=exp/random -! This is set with the variable "overlap" -! The exponential overlap uses also a length scale, Zo. (real, parameter :: Zo = 2500. ) -! -! Seed: -! If the stochastic cloud generator is called several times during the same timestep, -! one should change the seed between the call to insure that the -! subcolumns are different. -! This is done by changing the argument 'changeSeed' -! For example, if one wants to create a set of columns for the -! shortwave and another set for the longwave , -! use 'changeSeed = 1' for the first call and'changeSeed = 2' for the second call - -! PDF assumption: -! We can use arbitrary complicated PDFS. -! In the present version, we produce homogeneuous clouds (the simplest case). -! Future developments include using the PDF scheme of Ben Johnson. -! -! History file: -! Option to add diagnostics variables in the history file. (using FINCL in the namelist) -! nsubcol = number of subcolumns -! overlap = overlap type (1-3) -! Zo = length scale -! CLOUD_S = mean of the subcolumn cloud fraction ('_S" means Stochastic) -! CLDLIQ_S = mean of the subcolumn cloud water -! CLDICE_S = mean of the subcolumn cloud ice -! -! Note: -! Here: we force that the cloud condensate to be consistent with the cloud fraction -! i.e we only have cloud condensate when the cell is cloudy. -! In CAM: The cloud condensate and the cloud fraction are obtained from 2 different equations -! and the 2 quantities can be inconsistent (i.e. CAM can produce cloud fraction -! without cloud condensate or the opposite). -!----------------------------------------------------------------- - - use mcica_random_numbers -! The Mersenne Twister random number engine - use MersenneTwister, only: randomNumberSequence, & - & new_RandomNumberSequence, getRandomReal - use machine ,only : im => kind_io4, rb => kind_phys - - type(randomNumberSequence) :: randomNumbers - -! -- Arguments - - integer(kind=im), intent(in) :: ncol ! number of columns - integer(kind=im), intent(in) :: nlay ! number of layers - integer(kind=im), intent(in) :: icld ! clear/cloud, cloud overlap flag - integer(kind=im), intent(inout) :: irng ! flag for random number generator - ! 0 = kissvec - ! 1 = Mersenne Twister - integer(kind=im), intent(in) :: nsubcol ! number of sub-columns (g-point intervals) - integer(kind=im), optional, intent(in) :: changeSeed ! allows permuting seed - -! Column state (cloud fraction, cloud water, cloud ice) + variables needed to read physics state - real(kind=rb), intent(in) :: pmid(:,:) ! layer pressure (Pa) - ! Dimensions: (ncol,nlay) - - real(kind=rb), intent(in) :: hgt(:,:) ! layer height (m) - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: cld(:,:) ! cloud fraction - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: clwp(:,:) ! in-cloud liquid water path - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: ciwp(:,:) ! in-cloud ice water path - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: cswp(:,:) ! in-cloud snow path - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: tauc(:,:,:) ! in-cloud optical depth - ! Dimensions:(nbndlw,ncol,nlay) -! real(kind=rb), intent(in) :: ssac(:,:,:) ! in-cloud single scattering albedo - ! Dimensions: (nbndlw,ncol,nlay) - ! inactive - for future expansion -! real(kind=rb), intent(in) :: asmc(:,:,:) ! in-cloud asymmetry parameter - ! Dimensions: (nbndlw,ncol,nlay) - ! inactive - for future expansion - - real(kind=rb), intent(out) :: cld_stoch(:,:,:) ! subcolumn cloud fraction - ! Dimensions: (ngptlw,ncol,nlay) - real(kind=rb), intent(out) :: clwp_stoch(:,:,:) ! subcolumn in-cloud liquid water path - ! Dimensions: (ngptlw,ncol,nlay) - real(kind=rb), intent(out) :: ciwp_stoch(:,:,:) ! subcolumn in-cloud ice water path - ! Dimensions: (ngptlw,ncol,nlay) - real(kind=rb), intent(out) :: cswp_stoch(:,:,:) ! subcolumn in-cloud snow path - ! Dimensions: (ngptlw,ncol,nlay) - real(kind=rb), intent(out) :: tauc_stoch(:,:,:) ! subcolumn in-cloud optical depth - ! Dimensions: (ngptlw,ncol,nlay) -! real(kind=rb), intent(out) :: ssac_stoch(:,:,:)! subcolumn in-cloud single scattering albedo - ! Dimensions: (ngptlw,ncol,nlay) - ! inactive - for future expansion -! real(kind=rb), intent(out) :: asmc_stoch(:,:,:)! subcolumn in-cloud asymmetry parameter - ! Dimensions: (ngptlw,ncol,nlay) - ! inactive - for future expansion - -! -- Local variables - real(kind=rb) :: cldf(ncol,nlay) ! cloud fraction - -! Mean over the subcolumns (cloud fraction, cloud water , cloud ice) - inactive -! real(kind=rb) :: mean_cld_stoch(ncol, nlay) ! cloud fraction -! real(kind=rb) :: mean_clwp_stoch(ncol, nlay) ! cloud water -! real(kind=rb) :: mean_ciwp_stoch(ncol, nlay) ! cloud ice -! real(kind=rb) :: mean_tauc_stoch(ncol, nlay) ! cloud optical depth -! real(kind=rb) :: mean_ssac_stoch(ncol, nlay) ! cloud single scattering albedo -! real(kind=rb) :: mean_asmc_stoch(ncol, nlay) ! cloud asymmetry parameter - -! Set overlap - integer(kind=im) :: overlap ! 1 = random overlap, 2 = maximum-random, - ! 3 = maximum overlap, 4 = exponential, - ! 5 = exponential-random - real(kind=rb), parameter :: Zo = 2500._rb ! length scale (m) - real(kind=rb), dimension(ncol,nlay) :: alpha ! overlap parameter - -! Constants (min value for cloud fraction and cloud water and ice) - real(kind=rb), parameter :: cldmin = 1.0e-20_rb ! min cloud fraction -! real(kind=rb), parameter :: qmin = 1.0e-10_rb ! min cloud water and cloud ice (not used) - -! Variables related to random number and seed - real(kind=rb), dimension(nsubcol, ncol, nlay) :: CDF, CDF2 !random numbers - integer(kind=im), dimension(ncol) :: seed1, seed2, seed3, seed4 !seed to create random number (kissvec) - real(kind=rb), dimension(ncol) :: rand_num ! random number (kissvec) - integer(kind=im) :: iseed ! seed to create random number (Mersenne Teister) - real(kind=rb) :: rand_num_mt ! random number (Mersenne Twister) - -! Flag to identify cloud fraction in subcolumns - logical, dimension(nsubcol, ncol, nlay) :: iscloudy ! flag that says whether a gridbox is cloudy - -! Indices - integer(kind=im) :: ilev, isubcol, i, n ! indices - -!------------------------------------------------------------------- - -! Check that irng is in bounds; if not, set to default - if (irng .ne. 0) irng = 1 - -! Pass input cloud overlap setting to local variable - overlap = icld - -! Ensure that cloud fractions are in bounds - do ilev = 1, nlay - do i = 1, ncol - cldf(i,ilev) = cld(i,ilev) - if (cldf(i,ilev) < cldmin) then - cldf(i,ilev) = 0._rb - endif - enddo - enddo - -! ----- Create seed -------- - -! Advance randum number generator by changeseed values - if (irng.eq.0) then -! For kissvec, create a seed that depends on the state of the columns. Maybe not the best way, but it works. -! Must use pmid from bottom four layers. - do i=1,ncol - if (pmid(i,1).lt.pmid(i,2)) then - stop 'MCICA_SUBCOL: KISSVEC SEED GENERATOR REQUIRES PMID & - & FROM BOTTOM FOUR LAYERS.' - endif - seed1(i) = (pmid(i,1) - int(pmid(i,1))) * 1000000000_im - seed2(i) = (pmid(i,2) - int(pmid(i,2))) * 1000000000_im - seed3(i) = (pmid(i,3) - int(pmid(i,3))) * 1000000000_im - seed4(i) = (pmid(i,4) - int(pmid(i,4))) * 1000000000_im - enddo - do i=1,changeSeed - call kissvec(seed1, seed2, seed3, seed4, rand_num) - enddo - elseif (irng.eq.1) then - randomNumbers = new_RandomNumberSequence(seed = changeSeed) - endif - -! ------ Apply overlap assumption -------- - -! generate the random numbers - - select case (overlap) - - case(1) -! Random overlap -! i) pick a random value at every level - - if (irng.eq.0) then - do isubcol = 1,nsubcol - do ilev = 1,nlay - call kissvec(seed1, seed2, seed3, seed4, rand_num) ! we get different random number for each level - CDF(isubcol,:,ilev) = rand_num - enddo - enddo - elseif (irng.eq.1) then - do isubcol = 1, nsubcol - do i = 1, ncol - do ilev = 1, nlay - rand_num_mt = getRandomReal(randomNumbers) - CDF(isubcol,i,ilev) = rand_num_mt - enddo - enddo - enddo - endif - - case(2) -! Maximum-Random overlap -! i) pick a random number for top layer. -! ii) walk down the column: -! - if the layer above is cloudy, we use the same random number than in the layer above -! - if the layer above is clear, we use a new random number - - if (irng.eq.0) then - do isubcol = 1,nsubcol - do ilev = 1,nlay - call kissvec(seed1, seed2, seed3, seed4, rand_num) - CDF(isubcol,:,ilev) = rand_num - enddo - enddo - elseif (irng.eq.1) then - do isubcol = 1, nsubcol - do i = 1, ncol - do ilev = 1, nlay - rand_num_mt = getRandomReal(randomNumbers) - CDF(isubcol,i,ilev) = rand_num_mt - enddo - enddo - enddo - endif - - do ilev = 2,nlay - do i = 1, ncol - do isubcol = 1, nsubcol - if (CDF(isubcol, i, ilev-1) > 1._rb - cldf(i,ilev-1) )& - & then - CDF(isubcol,i,ilev) = CDF(isubcol,i,ilev-1) - else - CDF(isubcol,i,ilev) = CDF(isubcol,i,ilev) * (1._rb & - & - cldf(i,ilev-1)) - endif - enddo - enddo - enddo - - case(3) -! Maximum overlap -! i) pick the same random numebr at every level - - if (irng.eq.0) then - do isubcol = 1,nsubcol - call kissvec(seed1, seed2, seed3, seed4, rand_num) - do ilev = 1,nlay - CDF(isubcol,:,ilev) = rand_num - enddo - enddo - elseif (irng.eq.1) then - do isubcol = 1, nsubcol - do i = 1, ncol - rand_num_mt = getRandomReal(randomNumbers) - do ilev = 1, nlay - CDF(isubcol,i,ilev) = rand_num_mt - enddo - enddo - enddo - endif - -! mji - Activate exponential cloud overlap option - case(4) - ! Exponential overlap: weighting between maximum and random overlap increases with the distance. - ! The random numbers for exponential overlap verify: - ! j=1 RAN(j)=RND1 - ! j>1 if RND1 < alpha(j,j-1) => RAN(j) = RAN(j-1) - ! RAN(j) = RND2 - ! alpha is obtained from the equation - ! alpha = exp(-(Z(j)-Z(j-1))/Zo) where Zo is a characteristic length scale - - ! compute alpha - do i = 1, ncol - alpha(i, 1) = 0._rb - do ilev = 2,nlay - alpha(i, ilev) = exp( -( hgt (i, ilev) - & - & hgt (i, ilev-1)) / Zo) - enddo - enddo - - ! generate 2 streams of random numbers - if (irng.eq.0) then - do isubcol = 1,nsubcol - do ilev = 1,nlay - call kissvec(seed1, seed2, seed3, seed4, rand_num) - CDF(isubcol, :, ilev) = rand_num - call kissvec(seed1, seed2, seed3, seed4, rand_num) - CDF2(isubcol, :, ilev) = rand_num - enddo - enddo - elseif (irng.eq.1) then - do isubcol = 1, nsubcol - do i = 1, ncol - do ilev = 1, nlay - rand_num_mt = getRandomReal(randomNumbers) - CDF(isubcol,i,ilev) = rand_num_mt - rand_num_mt = getRandomReal(randomNumbers) - CDF2(isubcol,i,ilev) = rand_num_mt - enddo - enddo - enddo - endif - - ! generate random numbers - do ilev = 2,nlay - where (CDF2(:, :, ilev) < spread(alpha (:,ilev), & - & dim=1,nCopies=nsubcol) ) - CDF(:,:,ilev) = CDF(:,:,ilev-1) - end where - end do - -! Activate exponential-random cloud overlap option - case(5) - ! Exponential-random overlap: -!mz* call wrf_error_fatal("Cloud Overlap case 5: ER has not yet & -! been implemented. Stopping...") - - end select - -! -- generate subcolumns for homogeneous clouds ----- - do ilev = 1,nlay - iscloudy(:,:,ilev) = (CDF(:,:,ilev) >= 1._rb - & - & spread(cldf(:,ilev), dim=1, nCopies=nsubcol) ) - enddo - -! where the subcolumn is cloudy, the subcolumn cloud fraction is 1; -! where the subcolumn is not cloudy, the subcolumn cloud fraction is 0; -! where there is a cloud, define the subcolumn cloud properties, -! otherwise set these to zero - - do ilev = 1,nlay - do i = 1, ncol - do isubcol = 1, nsubcol - if (iscloudy(isubcol,i,ilev) ) then - cld_stoch(isubcol,i,ilev) = 1._rb - clwp_stoch(isubcol,i,ilev) = clwp(i,ilev) - ciwp_stoch(isubcol,i,ilev) = ciwp(i,ilev) - cswp_stoch(isubcol,i,ilev) = cswp(i,ilev) - n = ngb(isubcol) - tauc_stoch(isubcol,i,ilev) = tauc(n,i,ilev) -! ssac_stoch(isubcol,i,ilev) = ssac(n,i,ilev) -! asmc_stoch(isubcol,i,ilev) = asmc(n,i,ilev) - else - cld_stoch(isubcol,i,ilev) = 0._rb - clwp_stoch(isubcol,i,ilev) = 0._rb - ciwp_stoch(isubcol,i,ilev) = 0._rb - cswp_stoch(isubcol,i,ilev) = 0._rb - tauc_stoch(isubcol,i,ilev) = 0._rb -! ssac_stoch(isubcol,i,ilev) = 1._rb -! asmc_stoch(isubcol,i,ilev) = 1._rb - endif - enddo - enddo - enddo - -! -- compute the means of the subcolumns --- -! mean_cld_stoch(:,:) = 0._rb -! mean_clwp_stoch(:,:) = 0._rb -! mean_ciwp_stoch(:,:) = 0._rb -! mean_tauc_stoch(:,:) = 0._rb -! mean_ssac_stoch(:,:) = 0._rb -! mean_asmc_stoch(:,:) = 0._rb -! do i = 1, nsubcol -! mean_cld_stoch(:,:) = cld_stoch(i,:,:) + mean_cld_stoch(:,:) -! mean_clwp_stoch(:,:) = clwp_stoch( i,:,:) + mean_clwp_stoch(:,:) -! mean_ciwp_stoch(:,:) = ciwp_stoch( i,:,:) + mean_ciwp_stoch(:,:) -! mean_tauc_stoch(:,:) = tauc_stoch( i,:,:) + mean_tauc_stoch(:,:) -! mean_ssac_stoch(:,:) = ssac_stoch( i,:,:) + mean_ssac_stoch(:,:) -! mean_asmc_stoch(:,:) = asmc_stoch( i,:,:) + mean_asmc_stoch(:,:) -! end do -! mean_cld_stoch(:,:) = mean_cld_stoch(:,:) / nsubcol -! mean_clwp_stoch(:,:) = mean_clwp_stoch(:,:) / nsubcol -! mean_ciwp_stoch(:,:) = mean_ciwp_stoch(:,:) / nsubcol -! mean_tauc_stoch(:,:) = mean_tauc_stoch(:,:) / nsubcol -! mean_ssac_stoch(:,:) = mean_ssac_stoch(:,:) / nsubcol -! mean_asmc_stoch(:,:) = mean_asmc_stoch(:,:) / nsubcol - - end subroutine generate_stochastic_clouds - -!------------------------------------------------------------------ -! Private subroutines -!------------------------------------------------------------------ - -!----------------------------------------------------------------- - subroutine kissvec(seed1,seed2,seed3,seed4,ran_arr) -!---------------------------------------------------------------- - -! public domain code -! made available from http://www.fortran.com/ -! downloaded by pjr on 03/16/04 for NCAR CAM -! converted to vector form, functions inlined by pjr,mvr on 05/10/2004 - -! The KISS (Keep It Simple Stupid) random number generator. Combines: -! (1) The congruential generator x(n)=69069*x(n-1)+1327217885, period 2^32. -! (2) A 3-shift shift-register generator, period 2^32-1, -! (3) Two 16-bit multiply-with-carry generators, period 597273182964842497>2^59 -! Overall period>2^123; - real(kind=rb), dimension(:), intent(inout) :: ran_arr - integer(kind=im), dimension(:), intent(inout) :: seed1,seed2,seed3& - & ,seed4 - integer(kind=im) :: i,sz,kiss - integer(kind=im) :: m, k, n - -! inline function - m(k, n) = ieor (k, ishft (k, n) ) - - sz = size(ran_arr) - do i = 1, sz - seed1(i) = 69069_im * seed1(i) + 1327217885_im - seed2(i) = m (m (m (seed2(i), 13_im), - 17_im), 5_im) - seed3(i) = 18000_im * iand (seed3(i), 65535_im) + & - & ishft (seed3(i), - 16_im) - seed4(i) = 30903_im * iand (seed4(i), 65535_im) + & - & ishft (seed4(i), - 16_im) - kiss = seed1(i) + seed2(i) + ishft (seed3(i), 16_im) + seed4(i) - ran_arr(i) = kiss*2.328306e-10_rb + 0.5_rb - end do - - end subroutine kissvec -! - -!........................................!$ - end module rrtmg_lw !$ -!========================================!$ diff --git a/physics/radlw_main.meta b/physics/radlw_main.meta index 73977e5cb..4d2e5fa42 100644 --- a/physics/radlw_main.meta +++ b/physics/radlw_main.meta @@ -371,6 +371,22 @@ kind = kind_phys intent = in optional = T +[mpirank] + standard_name = mpi_rank + long_name = current MPI-rank + units = index + dimensions = () + type = integer + intent = in + optional = F +[mpiroot] + standard_name = mpi_root + long_name = master MPI-rank + units = index + dimensions = () + type = integer + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From bb68108abe5bf6d5101dd8eb451d562bdd30267d Mon Sep 17 00:00:00 2001 From: "Man.Zhang" Date: Tue, 17 Mar 2020 10:08:38 -0600 Subject: [PATCH 4/9] HWRF RRTMG cloud-rad interaction --- physics/GFS_rrtmg_pre.F90 | 6 +--- physics/GFS_rrtmg_pre.meta | 18 +++++------ physics/GFS_rrtmg_setup.F90 | 33 +++++++++++--------- physics/GFS_rrtmg_setup.meta | 20 ++++++------- physics/radiation_clouds.f | 24 +++++++++++---- physics/radlw_main.meta | 34 +++++++++++++++------ physics/radsw_main.f | 10 +++---- physics/radsw_main.meta | 58 ++++++++++++++++++++++++++++++------ 8 files changed, 136 insertions(+), 67 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 165411a33..92f21683a 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -81,7 +81,7 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input type(GFS_sfcprop_type), intent(in) :: Sfcprop type(GFS_statein_type), intent(in) :: Statein type(GFS_radtend_type), intent(inout) :: Radtend - type(GFS_tbd_type), intent(in) :: Tbd + type(GFS_tbd_type), intent(inout) :: Tbd type(GFS_cldprop_type), intent(in) :: Cldprop type(GFS_coupling_type), intent(in) :: Coupling @@ -724,10 +724,6 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input gridkm = 1.414*SQRT(dx(1)*0.001*dx(1)*0.001 ) - ! if(mpirank == mpiroot) then - ! write(0,*)'cldfra3: max/min(plyrpa) = ', maxval(plyrpa), minval(plyrpa) - ! write(0,*)'cldfra3: max/min(rho) = ', maxval(rho), minval(rho) - ! endif if(Model%icloud == 3) then diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 198cd0a5a..716090962 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -436,7 +436,7 @@ standard_name = total_cloud_fraction long_name = layer total cloud fraction units = frac - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) type = real kind = kind_phys intent = out @@ -445,7 +445,7 @@ standard_name = cloud_liquid_water_path long_name = layer cloud liquid water path units = g m-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) type = real kind = kind_phys intent = out @@ -454,7 +454,7 @@ standard_name = mean_effective_radius_for_liquid_cloud long_name = mean effective radius for liquid cloud units = micron - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) type = real kind = kind_phys intent = out @@ -463,7 +463,7 @@ standard_name = cloud_ice_water_path long_name = layer cloud ice water path units = g m-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) type = real kind = kind_phys intent = out @@ -472,7 +472,7 @@ standard_name = mean_effective_radius_for_ice_cloud long_name = mean effective radius for ice cloud units = micron - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) type = real kind = kind_phys intent = out @@ -481,7 +481,7 @@ standard_name = cloud_rain_water_path long_name = cloud rain water path units = g m-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) type = real kind = kind_phys intent = out @@ -490,7 +490,7 @@ standard_name = mean_effective_radius_for_rain_drop long_name = mean effective radius for rain drop units = micron - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) type = real kind = kind_phys intent = out @@ -499,7 +499,7 @@ standard_name = cloud_snow_water_path long_name = cloud snow water path units = g m-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) type = real kind = kind_phys intent = out @@ -508,7 +508,7 @@ standard_name = mean_effective_radius_for_snow_flake long_name = mean effective radius for snow flake units = micron - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) type = real kind = kind_phys intent = out diff --git a/physics/GFS_rrtmg_setup.F90 b/physics/GFS_rrtmg_setup.F90 index b6d86a34e..043ea8560 100644 --- a/physics/GFS_rrtmg_setup.F90 +++ b/physics/GFS_rrtmg_setup.F90 @@ -5,9 +5,9 @@ module GFS_rrtmg_setup use physparam, only : isolar , ictmflg, ico2flg, ioznflg, iaerflg,& ! & iaermdl, laswflg, lalwflg, lavoflg, icldflg, & & iaermdl, icldflg, & - & iovrsw , iovrlw , lcrick , lcnorm , lnoprec, & - & ialbflg, iemsflg, isubcsw, isubclw, ivflip , ipsd0, & - & iswcliq, & + & lcrick , lcnorm , lnoprec, & + & ialbflg, iemsflg, ivflip , ipsd0, & +! & iswcliq, & & kind_phys use radcons, only: ltp, lextop @@ -136,6 +136,7 @@ subroutine GFS_rrtmg_setup_init ( & ! =1: max/ran overlapping clouds ! ! =2: maximum overlap clouds (mcica only) ! ! =3: decorrelation-length overlap (mcica only) ! +! =4: exponential overlap clouds ! isubc_sw/isubc_lw: sub-column cloud approx control flag (sw/lw rad) ! ! =0: with out sub-column cloud approximation ! ! =1: mcica sub-col approx. prescribed random seed ! @@ -177,8 +178,8 @@ subroutine GFS_rrtmg_setup_init ( & integer, intent(in) :: num_p3d integer, intent(in) :: npdf3d integer, intent(in) :: ntoz - integer, intent(in) :: iovr_sw - integer, intent(in) :: iovr_lw + integer, intent(inout) :: iovr_sw + integer, intent(inout) :: iovr_lw integer, intent(in) :: isubc_sw integer, intent(in) :: isubc_lw integer, intent(in) :: icliq_sw @@ -204,6 +205,8 @@ subroutine GFS_rrtmg_setup_init ( & real(kind_phys), dimension(im,NSPC1) :: aerodp_check ! End for consistency checks + integer :: iswcliq + ! Initialize the CCPP error handling variables errmsg = '' errflg = 0 @@ -268,14 +271,14 @@ subroutine GFS_rrtmg_setup_init ( & iswcliq = icliq_sw ! optical property for liquid clouds for sw - iovrsw = iovr_sw ! cloud overlapping control flag for sw - iovrlw = iovr_lw ! cloud overlapping control flag for lw + ! iovrsw = iovr_sw ! cloud overlapping control flag for sw + ! iovrlw = iovr_lw ! cloud overlapping control flag for lw lcrick = crick_proof ! control flag for eliminating CRICK lcnorm = ccnorm ! control flag for in-cld condensate lnoprec = norad_precip ! precip effect on radiation flag (ferrier microphysics) - isubcsw = isubc_sw ! sub-column cloud approx flag in sw radiation - isubclw = isubc_lw ! sub-column cloud approx flag in lw radiation +! isubcsw = isubc_sw ! sub-column cloud approx flag in sw radiation +! isubclw = isubc_lw ! sub-column cloud approx flag in lw radiation ialbflg= ialb ! surface albedo control flag iemsflg= iems ! surface emissivity control flag @@ -303,7 +306,7 @@ subroutine GFS_rrtmg_setup_init ( & call radinit & ! --- inputs: - & ( si, levr, imp_physics, me ) + & ( si, levr, imp_physics,iswcliq, iovr_lw, iovr_sw, isubc_lw, isubc_sw, me ) ! --- outputs: ! ( none ) @@ -384,7 +387,7 @@ end subroutine GFS_rrtmg_setup_finalize ! Private functions - subroutine radinit( si, NLAY, imp_physics, me ) + subroutine radinit( si, NLAY, imp_physics,iswcliq, iovrlw,iovrsw,isubclw,isubcsw, me ) !................................... ! --- inputs: @@ -509,8 +512,10 @@ subroutine radinit( si, NLAY, imp_physics, me ) implicit none ! --- inputs: - integer, intent(in) :: NLAY, me, imp_physics + integer, intent(in) :: NLAY, me, imp_physics, & + & isubclw,isubcsw,iswcliq + integer, intent(inout) :: iovrlw,iovrsw real (kind=kind_phys), intent(in) :: si(:) ! --- outputs: (none, to module variables) @@ -619,9 +624,9 @@ subroutine radinit( si, NLAY, imp_physics, me ) call cld_init ( si, NLAY, imp_physics, me) ! --- ... cloud initialization routine - call rlwinit ( me ) ! --- ... lw radiation initialization routine + call rlwinit (iovrlw,isubclw, me ) ! --- ... lw radiation initialization routine - call rswinit ( me ) ! --- ... sw radiation initialization routine + call rswinit (iswcliq, iovrsw,isubcsw, me ) ! --- ... sw radiation initialization routine ! return !................................... diff --git a/physics/GFS_rrtmg_setup.meta b/physics/GFS_rrtmg_setup.meta index 8405d160d..4f96b76f1 100644 --- a/physics/GFS_rrtmg_setup.meta +++ b/physics/GFS_rrtmg_setup.meta @@ -107,32 +107,32 @@ intent = in optional = F [iovr_sw] - standard_name = flag_for_max_random_overlap_clouds_for_shortwave_radiation - long_name = sw: max-random overlap clouds + standard_name = flag_for_cloud_overlapping_method_for_shortwave_radiation + long_name = control flag for cloud overlapping method for SW units = flag dimensions = () type = integer - intent = in + intent = inout optional = F [iovr_lw] - standard_name = flag_for_max_random_overlap_clouds_for_longwave_radiation - long_name = lw: max-random overlap clouds + standard_name = flag_for_cloud_overlapping_method_for_longwave_radiation + long_name = control flag for cloud overlapping method for LW units = flag dimensions = () type = integer - intent = in + intent = inout optional = F [isubc_sw] - standard_name = flag_for_sw_clouds_without_sub_grid_approximation - long_name = flag for sw clouds without sub-grid approximation + standard_name = flag_for_sw_clouds_grid_approximation + long_name = flag for sw clouds sub-grid approximation units = flag dimensions = () type = integer intent = in optional = F [isubc_lw] - standard_name = flag_for_lw_clouds_without_sub_grid_approximation - long_name = flag for lw clouds without sub-grid approximation + standard_name = flag_for_lw_clouds_sub_grid_approximation + long_name = flag for lw clouds sub-grid approximation units = flag dimensions = () type = integer diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index c259fc22e..2a1184e99 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -2436,8 +2436,12 @@ subroutine progcld5 & logical, intent(in) :: uni_cld, lmfshal, lmfdeep2 real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & - & tlyr, tvly, qlyr, qstl, rhly, cldcov, delp, dz, & - & re_cloud, re_ice, re_snow + & tlyr, tvly, qlyr, qstl, rhly, cldcov, delp, dz +! & re_cloud, re_ice, re_snow + +!mz: for diagnostics purpose + real (kind=kind_phys), dimension(:,:), intent(inout) :: & + & re_cloud, re_ice, re_snow real (kind=kind_phys), dimension(:,:,:), intent(in) :: clw @@ -2689,9 +2693,11 @@ subroutine progcld5 & else rei(i,k) = (1250.0/9.387) * tem3 ** 0.031 endif +! if (icloud == 3 ) then rei(i,k) = max(25.,rei(i,k)) !mz* HWRF -!mz GFDL +! else !mz GFDL ! rei(i,k) = max(10.0, min(rei(i,k), 150.0)) +! endif endif rei(i,k) = min(rei(i,k), 135.72) !- 1.0315*rei<= 140 microns enddo @@ -2699,7 +2705,7 @@ subroutine progcld5 & !mz !> -# Compute effective snow cloud droplet radius - do k = 1, NLAY + do k = 1, NLAY do i = 1, IX res(i,k) = 10.0 enddo @@ -2717,8 +2723,14 @@ subroutine progcld5 & clouds(i,k,5) = rei(i,k) clouds(i,k,6) = crp(i,k) ! added for Thompson clouds(i,k,7) = rer(i,k) - clouds(i,k,8) = csp(i,k) ! added for Thompson - clouds(i,k,9) = res(i,k) + !mz inflg .ne.5 + clouds(i,k,8) = 0. + clouds(i,k,9) = 10. +!mz for diagnostics? + re_cloud(i,k) =rew(i,k) + re_ice(i,k) =rei(i,k) + re_snow(i,k) = 10. + enddo enddo diff --git a/physics/radlw_main.meta b/physics/radlw_main.meta index 4d2e5fa42..6fc58d635 100644 --- a/physics/radlw_main.meta +++ b/physics/radlw_main.meta @@ -207,6 +207,22 @@ kind = kind_phys intent = in optional = F +[iovrlw] + standard_name = flag_for_cloud_overlapping_method_for_longwave_radiation + long_name = control flag for cloud overlapping method for LW + units = flag + dimensions = () + type = integer + intent = in + optional = F +[isubclw] + standard_name = flag_for_lw_clouds_sub_grid_approximation + long_name = flag for lw clouds sub-grid approximation + units = flag + dimensions = () + type = integer + intent = in + optional = F [npts] standard_name = horizontal_loop_extent long_name = horizontal dimension @@ -243,7 +259,7 @@ standard_name = total_cloud_fraction long_name = total cloud fraction units = frac - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) type = real kind = kind_phys intent = in @@ -303,7 +319,7 @@ standard_name = cloud_liquid_water_path long_name = cloud liquid water path units = g m-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) type = real kind = kind_phys intent = in @@ -312,7 +328,7 @@ standard_name = mean_effective_radius_for_liquid_cloud long_name = mean effective radius for liquid cloud units = micron - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) type = real kind = kind_phys intent = in @@ -321,7 +337,7 @@ standard_name = cloud_ice_water_path long_name = cloud ice water path units = g m-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) type = real kind = kind_phys intent = in @@ -330,7 +346,7 @@ standard_name = mean_effective_radius_for_ice_cloud long_name = mean effective radius for ice cloud units = micron - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) type = real kind = kind_phys intent = in @@ -339,7 +355,7 @@ standard_name = cloud_rain_water_path long_name = cloud ice water path units = g m-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) type = real kind = kind_phys intent = in @@ -348,7 +364,7 @@ standard_name = mean_effective_radius_for_rain_drop long_name = mean effective radius for rain drop units = micron - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) type = real kind = kind_phys intent = in @@ -357,7 +373,7 @@ standard_name = cloud_snow_water_path long_name = cloud snow water path units = g m-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) type = real kind = kind_phys intent = in @@ -366,7 +382,7 @@ standard_name = mean_effective_radius_for_snow_flake long_name = mean effective radius for snow flake units = micron - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) type = real kind = kind_phys intent = in diff --git a/physics/radsw_main.f b/physics/radsw_main.f index b10541fb7..30bc58bba 100644 --- a/physics/radsw_main.f +++ b/physics/radsw_main.f @@ -268,7 +268,7 @@ !! code from aer inc. module rrtmg_sw ! - use physparam, only : iswrate, iswrgas, iswcliq, iswcice, & + use physparam, only : iswrate, iswrgas, iswcice, & !mz: iswcliq-NML option & isubcsw, icldflg, iovrsw, ivflip, & & iswmode, kind_phys use physcons, only : con_g, con_cp, con_avgd, con_amd, & @@ -1542,7 +1542,7 @@ end subroutine rswinit !----------------------------------- subroutine cldprop & & ( cfrac,cliqp,reliq,cicep,reice,cdat1,cdat2,cdat3,cdat4, & ! --- inputs - & cf1, nlay, ipseed, dz, delgth, & + & cf1, nlay, ipseed, dz, delgth, iswcliq, & & taucw, ssacw, asycw, cldfrc, cldfmc & ! --- output & ) @@ -1557,7 +1557,7 @@ subroutine cldprop & ! ! ! inputs: size ! ! cfrac - real, layer cloud fraction nlay ! -! ..... for iswcliq > 0 (prognostic cloud sckeme) - - - ! +! ..... for iswcliq > 0 (prognostic cloud scheme) - - - ! ! cliqp - real, layer in-cloud liq water path (g/m**2) nlay ! ! reliq - real, mean eff radius for liq cloud (micron) nlay ! ! cicep - real, layer in-cloud ice water path (g/m**2) nlay ! @@ -1566,7 +1566,7 @@ subroutine cldprop & ! cdat2 - real, effective radius for rain drop (micron) nlay ! ! cdat3 - real, layer snow flake water path(g/m**2) nlay ! ! cdat4 - real, mean eff radius for snow flake(micron) nlay ! -! ..... for iswcliq = 0 (diagnostic cloud sckeme) - - - ! +! ..... for iswcliq = 0 (diagnostic cloud scheme) - - - ! ! cdat1 - real, layer cloud optical depth nlay ! ! cdat2 - real, layer cloud single scattering albedo nlay ! ! cdat3 - real, layer cloud asymmetry factor nlay ! @@ -1628,7 +1628,7 @@ subroutine cldprop & use module_radsw_cldprtb ! --- inputs: - integer, intent(in) :: nlay, ipseed + integer, intent(in) :: nlay, ipseed, iswcliq real (kind=kind_phys), intent(in) :: cf1, delgth real (kind=kind_phys), dimension(nlay), intent(in) :: cliqp, & diff --git a/physics/radsw_main.meta b/physics/radsw_main.meta index c5cbe768a..49e9cc6b3 100644 --- a/physics/radsw_main.meta +++ b/physics/radsw_main.meta @@ -234,6 +234,30 @@ kind = kind_phys intent = in optional = F +[iswcliq] + standard_name = flag_for_optical_property_for_liquid_clouds_for_shortwave_radiation + long_name = sw optical property for liquid clouds + units = flag + dimensions = () + type = integer + intent = in + optional = F +[iovrsw] + standard_name = flag_for_cloud_overlapping_method_for_shortwave_radiation + long_name = control flag for cloud overlapping method for SW + units = flag + dimensions = () + type = integer + intent = in + optional = F +[isubcsw] + standard_name = flag_for_sw_clouds_grid_approximation + long_name = flag for sw clouds sub-grid approximation + units = flag + dimensions = () + type = integer + intent = in + optional = F [cosz] standard_name = cosine_of_zenith_angle long_name = cosine of the solar zenit angle @@ -304,7 +328,7 @@ standard_name = total_cloud_fraction long_name = total cloud fraction units = frac - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) type = real kind = kind_phys intent = in @@ -372,7 +396,7 @@ standard_name = cloud_liquid_water_path long_name = cloud liquid water path units = g m-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) type = real kind = kind_phys intent = in @@ -381,7 +405,7 @@ standard_name = mean_effective_radius_for_liquid_cloud long_name = mean effective radius for liquid cloud units = micron - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) type = real kind = kind_phys intent = in @@ -390,7 +414,7 @@ standard_name = cloud_ice_water_path long_name = cloud ice water path units = g m-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) type = real kind = kind_phys intent = in @@ -399,7 +423,7 @@ standard_name = mean_effective_radius_for_ice_cloud long_name = mean effective radius for ice cloud units = micron - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) type = real kind = kind_phys intent = in @@ -408,7 +432,7 @@ standard_name = cloud_rain_water_path long_name = cloud rain water path units = g m-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) type = real kind = kind_phys intent = in @@ -417,7 +441,7 @@ standard_name = mean_effective_radius_for_rain_drop long_name = mean effective radius for rain drop units = micron - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) type = real kind = kind_phys intent = in @@ -426,7 +450,7 @@ standard_name = cloud_snow_water_path long_name = cloud snow water path units = g m-2 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) type = real kind = kind_phys intent = in @@ -435,11 +459,27 @@ standard_name = mean_effective_radius_for_snow_flake long_name = mean effective radius for snow flake units = micron - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) type = real kind = kind_phys intent = in optional = T +[mpirank] + standard_name = mpi_rank + long_name = current MPI-rank + units = index + dimensions = () + type = integer + intent = in + optional = F +[mpiroot] + standard_name = mpi_root + long_name = master MPI-rank + units = index + dimensions = () + type = integer + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From c47c2cbb85710dcbccc47c3360047cb178151859 Mon Sep 17 00:00:00 2001 From: "Man.Zhang" Date: Sat, 21 Mar 2020 11:32:49 -0600 Subject: [PATCH 5/9] add progcld6 for GSD suite --- physics/GFS_rrtmg_pre.F90 | 69 ++-- physics/radiation_clouds.f | 788 +++++++++++++++++++++++++++---------- 2 files changed, 614 insertions(+), 243 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 92f21683a..7a5894f2e 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -36,41 +36,42 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input mpirank, mpiroot) use machine, only: kind_phys - use GFS_typedefs, only: GFS_statein_type, & - GFS_stateout_type, & - GFS_sfcprop_type, & - GFS_coupling_type, & - GFS_control_type, & - GFS_grid_type, & - GFS_tbd_type, & - GFS_cldprop_type, & - GFS_radtend_type, & + use GFS_typedefs, only: GFS_statein_type, & + GFS_stateout_type, & + GFS_sfcprop_type, & + GFS_coupling_type, & + GFS_control_type, & + GFS_grid_type, & + GFS_tbd_type, & + GFS_cldprop_type, & + GFS_radtend_type, & GFS_diag_type use physparam - use physcons, only: eps => con_eps, & - & epsm1 => con_epsm1, & - & fvirt => con_fvirt & - &, rog => con_rog & + use physcons, only: eps => con_eps, & + & epsm1 => con_epsm1, & + & fvirt => con_fvirt & + &, rog => con_rog & &, rocp => con_rocp - use radcons, only: itsfc,ltp, lextop, qmin, & + use radcons, only: itsfc,ltp, lextop, qmin, & qme5, qme6, epsq, prsmin use funcphys, only: fpvs - use module_radiation_astronomy,only: coszmn ! sol_init, sol_update - use module_radiation_gases, only: NF_VGAS, getgases, getozn ! gas_init, gas_update, - use module_radiation_aerosols, only: NF_AESW, NF_AELW, setaer, & ! aer_init, aer_update, + use module_radiation_astronomy,only: coszmn ! sol_init, sol_update + use module_radiation_gases, only: NF_VGAS, getgases, getozn ! gas_init, gas_update, + use module_radiation_aerosols, only: NF_AESW, NF_AELW, setaer, & ! aer_init, aer_update, & NSPC1 - use module_radiation_clouds, only: NF_CLDS, & ! cld_init - & progcld1, progcld3, & - & progcld2, & - & progcld4, progcld5, & + use module_radiation_clouds, only: NF_CLDS, & ! cld_init + & progcld1, progcld3, & + & progcld2, & + & progcld4, progcld5, & + & progcld6, & !F-A & progclduni, & & cal_cldfra3, find_cloudLayers,adjust_cloudIce,adjust_cloudH2O, & & adjust_cloudFinal - use module_radsw_parameters, only: topfsw_type, sfcfsw_type, & + use module_radsw_parameters, only: topfsw_type, sfcfsw_type, & & profsw_type, NBDSW - use module_radlw_parameters, only: topflw_type, sfcflw_type, & + use module_radlw_parameters, only: topflw_type, sfcflw_type, & & proflw_type, NBDLW use surface_perturbation, only: cdfnor @@ -835,8 +836,26 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input ! clouds, cldsa, mtopa, mbota, de_lgth) ! --- outputs endif - elseif(Model%imp_physics == 8 .or. Model%imp_physics == 6 .or. & - Model%imp_physics == 15) then + elseif(Model%imp_physics == 8 .or. Model%imp_physics == 6 ) then + if (Model%kdt == 1) then + Tbd%phy_f3d(:,:,Model%nleffr) = 10. + Tbd%phy_f3d(:,:,Model%nieffr) = 50. + Tbd%phy_f3d(:,:,Model%nseffr) = 250. + endif + + !mz* this is original progcld5 - temporary + call progcld6 (plyr,plvl,tlyr,qlyr,qstl,rhly,tracer1, & ! --- inputs + Grid%xlat,Grid%xlon,Sfcprop%slmsk,dz,delp, & + ntrac-1, ntcw-1,ntiw-1,ntrw-1, & + ntsw-1,ntgl-1, & + im, lmk, lmp, Model%uni_cld, & + Model%lmfshal,Model%lmfdeep2, & + cldcov(:,1:LMK),Tbd%phy_f3d(:,:,1), & + Tbd%phy_f3d(:,:,2), Tbd%phy_f3d(:,:,3), & + clouds,cldsa,mtopa,mbota, de_lgth) ! --- outputs + + + elseif(Model%imp_physics == 15) then if (Model%kdt == 1) then Tbd%phy_f3d(:,:,Model%nleffr) = 10. Tbd%phy_f3d(:,:,Model%nieffr) = 50. diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index 2a1184e99..41da8953f 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -244,6 +244,7 @@ module module_radiation_clouds public progcld1, progcld2, progcld3, progcld4, progclduni, & & cld_init, progcld5, progcld4o, & + & progcld6, & !mz- for GSL suite & cal_cldfra3, find_cloudLayers,adjust_cloudIce,adjust_cloudH2O, & & adjust_cloudFinal @@ -2767,6 +2768,358 @@ subroutine progcld5 & end subroutine progcld5 !................................... + +!mz: progcld5 benchmark + subroutine progcld6 & + & ( plyr,plvl,tlyr,qlyr,qstl,rhly,clw, & ! --- inputs: + & xlat,xlon,slmsk,dz,delp, & + & ntrac,ntcw,ntiw,ntrw,ntsw,ntgl, & + & IX, NLAY, NLP1, & + & uni_cld, lmfshal, lmfdeep2, cldcov, & + & re_cloud,re_ice,re_snow, & + & clouds,clds,mtop,mbot,de_lgth & ! --- outputs: + & ) + +! ================= subprogram documentation block ================ ! +! ! +! subprogram: progcld5 computes cloud related quantities using ! +! Thompson/WSM6 cloud microphysics scheme. ! +! ! +! abstract: this program computes cloud fractions from cloud ! +! condensates, ! +! and computes the low, mid, high, total and boundary layer cloud ! +! fractions and the vertical indices of low, mid, and high cloud ! +! top and base. the three vertical cloud domains are set up in the ! +! initial subroutine "cld_init". ! +! ! +! usage: call progcld5 ! +! ! +! subprograms called: gethml ! +! ! +! attributes: ! +! language: fortran 90 ! +! machine: ibm-sp, sgi ! +! ! +! ! +! ==================== definition of variables ==================== ! +! ! +! ! +! input variables: ! +! plyr (IX,NLAY) : model layer mean pressure in mb (100Pa) ! +! plvl (IX,NLP1) : model level pressure in mb (100Pa) ! +! tlyr (IX,NLAY) : model layer mean temperature in k ! +! tvly (IX,NLAY) : model layer virtual temperature in k ! +! qlyr (IX,NLAY) : layer specific humidity in gm/gm ! +! qstl (IX,NLAY) : layer saturate humidity in gm/gm ! +! rhly (IX,NLAY) : layer relative humidity (=qlyr/qstl) ! +! clw (IX,NLAY,ntrac) : layer cloud condensate amount ! +! xlat (IX) : grid latitude in radians, default to pi/2 -> -pi/2! +! range, otherwise see in-line comment ! +! xlon (IX) : grid longitude in radians (not used) ! +! slmsk (IX) : sea/land mask array (sea:0,land:1,sea-ice:2) ! +! dz (ix,nlay) : layer thickness (km) ! +! delp (ix,nlay) : model layer pressure thickness in mb (100Pa) ! +! IX : horizontal dimention ! +! NLAY,NLP1 : vertical layer/level dimensions ! +! uni_cld : logical - true for cloud fraction from shoc ! +! lmfshal : logical - true for mass flux shallow convection ! +! lmfdeep2 : logical - true for mass flux deep convection ! +! cldcov : layer cloud fraction (used when uni_cld=.true. ! +! ! +! output variables: ! +! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! +! clouds(:,:,1) - layer total cloud fraction ! +! clouds(:,:,2) - layer cloud liq water path (g/m**2) ! +! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! +! clouds(:,:,4) - layer cloud ice water path (g/m**2) ! +! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! +! clouds(:,:,6) - layer rain drop water path not assigned ! +! clouds(:,:,7) - mean eff radius for rain drop (micron) ! +! *** clouds(:,:,8) - layer snow flake water path not assigned ! +! clouds(:,:,9) - mean eff radius for snow flake (micron) ! +! *** fu's scheme need to be normalized by snow density (g/m**3/1.0e6) ! +! clds (IX,5) : fraction of clouds for low, mid, hi, tot, bl ! +! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! +! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! +! de_lgth(ix) : clouds decorrelation length (km) ! +! ! +! module variables: ! +! ivflip : control flag of vertical index direction ! +! =0: index from toa to surface ! +! =1: index from surface to toa ! +! lmfshal : mass-flux shallow conv scheme flag ! +! lmfdeep2 : scale-aware mass-flux deep conv scheme flag ! +! lcrick : control flag for eliminating CRICK ! +! =t: apply layer smoothing to eliminate CRICK ! +! =f: do not apply layer smoothing ! +! lcnorm : control flag for in-cld condensate ! +! =t: normalize cloud condensate ! +! =f: not normalize cloud condensate ! +! ! +! ==================== end of description ===================== ! +! + implicit none + +! --- inputs + integer, intent(in) :: IX, NLAY, NLP1 + integer, intent(in) :: ntrac, ntcw, ntiw, ntrw, ntsw, ntgl + + logical, intent(in) :: uni_cld, lmfshal, lmfdeep2 + + real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & + & tlyr, qlyr, qstl, rhly, cldcov, delp, dz, & + & re_cloud, re_ice, re_snow + + real (kind=kind_phys), dimension(:,:,:), intent(in) :: clw + + real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & + & slmsk + +! --- outputs + real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds + + real (kind=kind_phys), dimension(:,:), intent(out) :: clds + real (kind=kind_phys), dimension(:), intent(out) :: de_lgth + + integer, dimension(:,:), intent(out) :: mtop,mbot + +! --- local variables: + real (kind=kind_phys), dimension(IX,NLAY) :: cldtot, cldcnv, & + & cwp, cip, crp, csp, rew, rei, res, rer, tem2d, clwf + + real (kind=kind_phys) :: ptop1(IX,NK_CLDS+1), rxlat(ix) + + real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & + & tem1, tem2, tem3 + + integer :: i, k, id, nf + +! --- constant values +! real (kind=kind_phys), parameter :: xrc3 = 200. + real (kind=kind_phys), parameter :: xrc3 = 100. + +! +!===> ... begin here +! + do nf=1,nf_clds + do k=1,nlay + do i=1,ix + clouds(i,k,nf) = 0.0 + enddo + enddo + enddo +! clouds(:,:,:) = 0.0 + + do k = 1, NLAY + do i = 1, IX + cldtot(i,k) = 0.0 + cldcnv(i,k) = 0.0 + cwp (i,k) = 0.0 + cip (i,k) = 0.0 + crp (i,k) = 0.0 + csp (i,k) = 0.0 + rew (i,k) = re_cloud(i,k) + rei (i,k) = re_ice(i,k) + rer (i,k) = rrain_def ! default rain radius to 1000 micron + res (i,k) = re_snow(i,K) +! tem2d (i,k) = min( 1.0, max( 0.0, (con_ttp-tlyr(i,k))*0.05 ) ) + clwf(i,k) = 0.0 + enddo + enddo +! +! +! if ( lcrick ) then +! do i = 1, IX +! clwf(i,1) = 0.75*clw(i,1) + 0.25*clw(i,2) +! clwf(i,nlay) = 0.75*clw(i,nlay) + 0.25*clw(i,nlay-1) +! enddo +! do k = 2, NLAY-1 +! do i = 1, IX +! clwf(i,K) = 0.25*clw(i,k-1) + 0.5*clw(i,k) + 0.25*clw(i,k+1) +! enddo +! enddo +! else +! do k = 1, NLAY +! do i = 1, IX +! clwf(i,k) = clw(i,k) +! enddo +! enddo +! endif + + do k = 1, NLAY + do i = 1, IX + clwf(i,k) = clw(i,k,ntcw) + clw(i,k,ntiw) + clw(i,k,ntsw) + enddo + enddo +!> - Find top pressure for each cloud domain for given latitude. +!! ptopc(k,i): top presure of each cld domain (k=1-4 are sfc,L,m,h; +!! i=1,2 are low-lat (<45 degree) and pole regions) + + do i =1, IX + rxlat(i) = abs( xlat(i) / con_pi ) ! if xlat in pi/2 -> -pi/2 range +! rxlat(i) = abs(0.5 - xlat(i)/con_pi) ! if xlat in 0 -> pi range + enddo + + do id = 1, 4 + tem1 = ptopc(id,2) - ptopc(id,1) + + do i =1, IX + ptop1(i,id) = ptopc(id,1) + tem1*max( 0.0, 4.0*rxlat(i)-1.0 ) + enddo + enddo + +!> - Compute cloud liquid/ice condensate path in \f$ g/m^2 \f$ . + + do k = 1, NLAY + do i = 1, IX + cwp(i,k) = max(0.0, clw(i,k,ntcw) * gfac * delp(i,k)) + cip(i,k) = max(0.0, clw(i,k,ntiw) * gfac * delp(i,k)) + crp(i,k) = max(0.0, clw(i,k,ntrw) * gfac * delp(i,k)) + csp(i,k) = max(0.0, (clw(i,k,ntsw)+clw(i,k,ntgl)) * & + & gfac * delp(i,k)) + enddo + enddo + + if (uni_cld) then ! use unified sgs clouds generated outside + do k = 1, NLAY + do i = 1, IX + cldtot(i,k) = cldcov(i,k) + enddo + enddo + + else + +!> - Calculate layer cloud fraction. + + clwmin = 0.0 + if (.not. lmfshal) then + do k = 1, NLAY + do i = 1, IX + clwt = 1.0e-6 * (plyr(i,k)*0.001) +! clwt = 2.0e-6 * (plyr(i,k)*0.001) + + if (clwf(i,k) > clwt) then + + onemrh= max( 1.e-10, 1.0-rhly(i,k) ) + clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) + + tem1 = min(max(sqrt(sqrt(onemrh*qstl(i,k))),0.0001),1.0) + tem1 = 2000.0 / tem1 + +! tem1 = 1000.0 / tem1 + + value = max( min( tem1*(clwf(i,k)-clwm), 50.0 ), 0.0 ) + tem2 = sqrt( sqrt(rhly(i,k)) ) + + cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) + endif + enddo + enddo + else + do k = 1, NLAY + do i = 1, IX + clwt = 1.0e-6 * (plyr(i,k)*0.001) +! clwt = 2.0e-6 * (plyr(i,k)*0.001) + + if (clwf(i,k) > clwt) then + onemrh= max( 1.e-10, 1.0-rhly(i,k) ) + clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) +! + tem1 = min(max((onemrh*qstl(i,k))**0.49,0.0001),1.0) !jhan + if (lmfdeep2) then + tem1 = xrc3 / tem1 + else + tem1 = 100.0 / tem1 + endif +! + value = max( min( tem1*(clwf(i,k)-clwm), 50.0 ), 0.0 ) + tem2 = sqrt( sqrt(rhly(i,k)) ) + + cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) + endif + enddo + enddo + endif + + endif ! if (uni_cld) then + + do k = 1, NLAY + do i = 1, IX + if (cldtot(i,k) < climit) then + cldtot(i,k) = 0.0 + cwp(i,k) = 0.0 + cip(i,k) = 0.0 + crp(i,k) = 0.0 + csp(i,k) = 0.0 + endif + enddo + enddo + + if ( lcnorm ) then + do k = 1, NLAY + do i = 1, IX + if (cldtot(i,k) >= climit) then + tem1 = 1.0 / max(climit2, cldtot(i,k)) + cwp(i,k) = cwp(i,k) * tem1 + cip(i,k) = cip(i,k) * tem1 + crp(i,k) = crp(i,k) * tem1 + csp(i,k) = csp(i,k) * tem1 + endif + enddo + enddo + endif + +! + do k = 1, NLAY + do i = 1, IX + clouds(i,k,1) = cldtot(i,k) + clouds(i,k,2) = cwp(i,k) + clouds(i,k,3) = rew(i,k) + clouds(i,k,4) = cip(i,k) + clouds(i,k,5) = rei(i,k) + clouds(i,k,6) = crp(i,k) ! added for Thompson + clouds(i,k,7) = rer(i,k) + clouds(i,k,8) = csp(i,k) ! added for Thompson + clouds(i,k,9) = res(i,k) + enddo + enddo + +! --- ... estimate clouds decorrelation length in km +! this is only a tentative test, need to consider change later + + if ( iovr == 3 ) then + do i = 1, ix + de_lgth(i) = max( 0.6, 2.78-4.6*rxlat(i) ) + enddo + endif + +!> - Call gethml() to compute low,mid,high,total, and boundary layer +!! cloud fractions and clouds top/bottom layer indices for low, mid, +!! and high clouds. +! --- compute low, mid, high, total, and boundary layer cloud fractions +! and clouds top/bottom layer indices for low, mid, and high clouds. +! The three cloud domain boundaries are defined by ptopc. The cloud +! overlapping method is defined by control flag 'iovr', which may +! be different for lw and sw radiation programs. + + call gethml & +! --- inputs: + & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, & + & IX,NLAY, & +! --- outputs: + & clds, mtop, mbot & + & ) + + +! + return + +!............................................ + end subroutine progcld6 +!............................................ +!mz + + !> \ingroup module_radiation_clouds !> This subroutine computes cloud related quantities using !! for unified cloud microphysics scheme. @@ -3715,91 +4068,90 @@ SUBROUTINE find_cloudLayers(qvs1d, cfr1d, T1d, P1d, R1d, entrmnt, & k_m12C = 0 k_m40C = 0 - DO k = kte, kts, -1 - theta(k) = T1d(k)*((100000.0/P1d(k))**(287.05/1004.)) + DO k = kte, kts, -1 + theta(k) = T1d(k)*((100000.0/P1d(k))**(287.05/1004.)) if (T1d(k)-273.16 .gt. -40.0 .and. P1d(k).gt.7000.0) k_m40C = & - & MAX(k_m40C, k) + & MAX(k_m40C, k) if (T1d(k)-273.16 .gt. -12.0 .and. P1d(k).gt.10000.0) k_m12C = & - & MAX(k_m12C, k) - ENDDO - if (k_m40C .le. kts) k_m40C = kts - if (k_m12C .le. kts) k_m12C = kts - - Z2 = 44307.692 * (1.0 - (P1d(kte)/101325.)**0.190) - DO k = kte-1, kts, -1 - Z1 = 44307.692 * (1.0 - (P1d(k)/101325.)**0.190) - dz(k+1) = Z2 - Z1 - Z2 = Z1 - ENDDO - dz(kts) = dz(kts+1) - -!..Find tropopause height, best surrogate, because we would not really -!.. wish to put fake clouds into the stratosphere. The 10/1500 ratio -!.. d(Theta)/d(Z) approximates a vertical line on typical SkewT chart -!.. near typical (mid-latitude) tropopause height. Since messy data -!.. could give us a false signal of such a transition, do the check over -!.. three K-level change, not just a level-to-level check. This method -!.. has potential failure in arctic-like conditions with extremely low -!.. tropopause height, as would any other diagnostic, so ensure resulting -!.. k_tropo level is above 4km. - - DO k = kte-3, kts, -1 - theta1 = theta(k) - theta2 = theta(k+2) - ht1 = 44307.692 * (1.0 - (P1d(k)/101325.)**0.190) - ht2 = 44307.692 * (1.0 - (P1d(k+2)/101325.)**0.190) + & MAX(k_m12C, k) + ENDDO + if (k_m40C .le. kts) k_m40C = kts + if (k_m12C .le. kts) k_m12C = kts + + Z2 = 44307.692 * (1.0 - (P1d(kte)/101325.)**0.190) + DO k = kte-1, kts, -1 + Z1 = 44307.692 * (1.0 - (P1d(k)/101325.)**0.190) + dz(k+1) = Z2 - Z1 + Z2 = Z1 + ENDDO + dz(kts) = dz(kts+1) + +!..Find tropopause height, best surrogate, because we would not really +!.. wish to put fake clouds into the stratosphere. The 10/1500 ratio +!.. d(Theta)/d(Z) approximates a vertical line on typical SkewT chart +!.. near typical (mid-latitude) tropopause height. Since messy data +!.. could give us a false signal of such a transition, do the check over +!.. three K-level change, not just a level-to-level check. This method +!.. has potential failure in arctic-like conditions with extremely low +!.. tropopause height, as would any other diagnostic, so ensure resulting +!.. k_tropo level is above 4km. + + DO k = kte-3, kts, -1 + theta1 = theta(k) + theta2 = theta(k+2) + ht1 = 44307.692 * (1.0 - (P1d(k)/101325.)**0.190) + ht2 = 44307.692 * (1.0 - (P1d(k+2)/101325.)**0.190) if ( (((theta2-theta1)/(ht2-ht1)) .lt. 10./1500. ) .AND. & & (ht1.lt.19000.) .and. (ht1.gt.4000.) ) then - goto 86 - endif - ENDDO - 86 continue - k_tropo = MAX(kts+2, k+2) - -! if (debugfl) then -! print*, ' FOUND TROPOPAUSE ', k_tropo, ' near ', ht2, ' m' -! WRITE (dbg_msg,*) 'DEBUG-GT: FOUND TROPOPAUSE ', k_tropo, ' near ', ht2, ' m' -! CALL wrf_debug (150, dbg_msg) -! endif - -!..Eliminate possible fractional clouds above supposed tropopause. - DO k = k_tropo+1, kte - if (cfr1d(k).gt.0.0 .and. cfr1d(k).lt.0.999) then - cfr1d(k) = 0. - endif - ENDDO - -!..We would like to prevent fractional clouds below LCL in idealized -!.. situation with deep well-mixed convective PBL, that otherwise is -!.. likely to get clouds in more realistic capping inversion layer. - - kbot = kts+2 - DO k = kbot, k_m12C - if ( (theta(k)-theta(k-1)) .gt. 0.05E-3*dz(k)) EXIT - ENDDO - kbot = MAX(kts+1, k-2) - DO k = kts, kbot - if (cfr1d(k).gt.0.0 .and. cfr1d(k).lt.0.999) cfr1d(k) = 0. - ENDDO - - -!..Starting below tropo height, if cloud fraction greater than 1 -!percent, -!.. compute an approximate total layer depth of cloud, determine a total -!.. liquid water/ice path (LWP/IWP), then reduce that amount with tuning -!.. parameter to represent entrainment factor, then divide up LWP/IWP -!.. into delta-Z weighted amounts for individual levels per cloud layer. - - - k_cldb = k_tropo - in_cloud = .false. - k = k_tropo - DO WHILE (.not. in_cloud .AND. k.gt.k_m12C) - k_cldt = 0 - if (cfr1d(k).ge.0.01) then - in_cloud = .true. - k_cldt = MAX(k_cldt, k) - endif + goto 86 + endif + ENDDO + 86 continue + k_tropo = MAX(kts+2, k+2) + +! if (debugfl) then +! print*, ' FOUND TROPOPAUSE ', k_tropo, ' near ', ht2, ' m' +! WRITE (dbg_msg,*) 'DEBUG-GT: FOUND TROPOPAUSE ', k_tropo, ' near ', ht2, ' m' +! CALL wrf_debug (150, dbg_msg) +! endif + +!..Eliminate possible fractional clouds above supposed tropopause. + DO k = k_tropo+1, kte + if (cfr1d(k).gt.0.0 .and. cfr1d(k).lt.0.999) then + cfr1d(k) = 0. + endif + ENDDO + +!..We would like to prevent fractional clouds below LCL in idealized +!.. situation with deep well-mixed convective PBL, that otherwise is +!.. likely to get clouds in more realistic capping inversion layer. + + kbot = kts+2 + DO k = kbot, k_m12C + if ( (theta(k)-theta(k-1)) .gt. 0.05E-3*dz(k)) EXIT + ENDDO + kbot = MAX(kts+1, k-2) + DO k = kts, kbot + if (cfr1d(k).gt.0.0 .and. cfr1d(k).lt.0.999) cfr1d(k) = 0. + ENDDO + + +!..Starting below tropo height, if cloud fraction greater than 1 percent, +!.. compute an approximate total layer depth of cloud, determine a total +!.. liquid water/ice path (LWP/IWP), then reduce that amount with tuning +!.. parameter to represent entrainment factor, then divide up LWP/IWP +!.. into delta-Z weighted amounts for individual levels per cloud layer. + + + k_cldb = k_tropo + in_cloud = .false. + k = k_tropo + DO WHILE (.not. in_cloud .AND. k.gt.k_m12C) + k_cldt = 0 + if (cfr1d(k).ge.0.01) then + in_cloud = .true. + k_cldt = MAX(k_cldt, k) + endif if (in_cloud) then DO k2 = k_cldt-1, k_m12C, -1 if (cfr1d(k2).lt.0.01 .or. k2.eq.k_m12C) then @@ -3898,149 +4250,149 @@ SUBROUTINE find_cloudLayers(qvs1d, cfr1d, T1d, P1d, R1d, entrmnt, & END SUBROUTINE find_cloudLayers !+---+-----------------------------------------------------------------+ - + SUBROUTINE adjust_cloudIce(cfr,qi,qs,qvs, T,Rho,dz, entr, k1,k2, & - & kts,kte) -! - IMPLICIT NONE -! - INTEGER, INTENT(IN):: k1,k2, kts,kte - REAL, INTENT(IN):: entr - REAL, DIMENSION(kts:kte), INTENT(IN):: cfr, qvs, T, Rho, dz - REAL, DIMENSION(kts:kte), INTENT(INOUT):: qi, qs - REAL:: iwc, max_iwc, tdz, this_iwc, this_dz, iwp_exists - INTEGER:: k, kmid - - tdz = 0. - do k = k1, k2 - tdz = tdz + dz(k) - enddo - kmid = NINT(0.5*(k1+k2)) - max_iwc = ABS(qvs(k2-1)-qvs(k1)) -! print*, ' max_iwc = ', max_iwc, ' over DZ=',tdz - - iwp_exists = 0. - do k = k1, k2 - iwp_exists = iwp_exists + (qi(k)+qs(k))*Rho(k)*dz(k) - enddo - if (iwp_exists .gt. 1.0) RETURN - - this_dz = 0.0 - do k = k1, k2 - if (k.eq.k1) then - this_dz = this_dz + 0.5*dz(k) - else - this_dz = this_dz + dz(k) - endif - this_iwc = max_iwc*this_dz/tdz - iwc = MAX(1.E-6, this_iwc*(1.-entr)) - if (cfr(k).gt.0.01.and.cfr(k).lt.0.99.and.T(k).ge.203.16) then - qi(k) = qi(k) + 0.1*cfr(k)*iwc + & kts,kte) +! + IMPLICIT NONE +! + INTEGER, INTENT(IN):: k1,k2, kts,kte + REAL, INTENT(IN):: entr + REAL, DIMENSION(kts:kte), INTENT(IN):: cfr, qvs, T, Rho, dz + REAL, DIMENSION(kts:kte), INTENT(INOUT):: qi, qs + REAL:: iwc, max_iwc, tdz, this_iwc, this_dz, iwp_exists + INTEGER:: k, kmid + + tdz = 0. + do k = k1, k2 + tdz = tdz + dz(k) + enddo + kmid = NINT(0.5*(k1+k2)) + max_iwc = ABS(qvs(k2-1)-qvs(k1)) +! print*, ' max_iwc = ', max_iwc, ' over DZ=',tdz + + iwp_exists = 0. + do k = k1, k2 + iwp_exists = iwp_exists + (qi(k)+qs(k))*Rho(k)*dz(k) + enddo + if (iwp_exists .gt. 1.0) RETURN + + this_dz = 0.0 + do k = k1, k2 + if (k.eq.k1) then + this_dz = this_dz + 0.5*dz(k) + else + this_dz = this_dz + dz(k) + endif + this_iwc = max_iwc*this_dz/tdz + iwc = MAX(1.E-6, this_iwc*(1.-entr)) + if (cfr(k).gt.0.01.and.cfr(k).lt.0.99.and.T(k).ge.203.16) then + qi(k) = qi(k) + 0.1*cfr(k)*iwc elseif (qi(k).lt.1.E-5.and.cfr(k).ge.0.99.and.T(k).ge.203.16) & - & then + & then qi(k) = qi(k) + 0.01*iwc - endif - enddo - - END SUBROUTINE adjust_cloudIce - -!+---+-----------------------------------------------------------------+ - + endif + enddo + + END SUBROUTINE adjust_cloudIce + +!+---+-----------------------------------------------------------------+ + SUBROUTINE adjust_cloudH2O(cfr, qc, qvs, T,Rho,dz, entr, k1,k2, & - & kts,kte) -! - IMPLICIT NONE -! - INTEGER, INTENT(IN):: k1,k2, kts,kte - REAL, INTENT(IN):: entr - REAL, DIMENSION(kts:kte):: cfr, qc, qvs, T, Rho, dz - REAL:: lwc, max_lwc, tdz, this_lwc, this_dz, lwp_exists - INTEGER:: k, kmid - - tdz = 0. - do k = k1, k2 - tdz = tdz + dz(k) - enddo - kmid = NINT(0.5*(k1+k2)) - max_lwc = ABS(qvs(k2-1)-qvs(k1)) -! print*, ' max_lwc = ', max_lwc, ' over DZ=',tdz - - lwp_exists = 0. - do k = k1, k2 - lwp_exists = lwp_exists + qc(k)*Rho(k)*dz(k) - enddo - if (lwp_exists .gt. 1.0) RETURN - - this_dz = 0.0 - do k = k1, k2 - if (k.eq.k1) then - this_dz = this_dz + 0.5*dz(k) - else - this_dz = this_dz + dz(k) - endif - this_lwc = max_lwc*this_dz/tdz - lwc = MAX(1.E-6, this_lwc*(1.-entr)) + & kts,kte) +! + IMPLICIT NONE +! + INTEGER, INTENT(IN):: k1,k2, kts,kte + REAL, INTENT(IN):: entr + REAL, DIMENSION(kts:kte):: cfr, qc, qvs, T, Rho, dz + REAL:: lwc, max_lwc, tdz, this_lwc, this_dz, lwp_exists + INTEGER:: k, kmid + + tdz = 0. + do k = k1, k2 + tdz = tdz + dz(k) + enddo + kmid = NINT(0.5*(k1+k2)) + max_lwc = ABS(qvs(k2-1)-qvs(k1)) +! print*, ' max_lwc = ', max_lwc, ' over DZ=',tdz + + lwp_exists = 0. + do k = k1, k2 + lwp_exists = lwp_exists + qc(k)*Rho(k)*dz(k) + enddo + if (lwp_exists .gt. 1.0) RETURN + + this_dz = 0.0 + do k = k1, k2 + if (k.eq.k1) then + this_dz = this_dz + 0.5*dz(k) + else + this_dz = this_dz + dz(k) + endif + this_lwc = max_lwc*this_dz/tdz + lwc = MAX(1.E-6, this_lwc*(1.-entr)) if (cfr(k).gt.0.01.and.cfr(k).lt.0.99.and.T(k).lt.298.16.and. & - & T(k).ge.253.16) then - qc(k) = qc(k) + cfr(k)*cfr(k)*lwc + & T(k).ge.253.16) then + qc(k) = qc(k) + cfr(k)*cfr(k)*lwc elseif (cfr(k).ge.0.99.and.qc(k).lt.1.E-5.and.T(k).lt.298.16 & - & .and.T(k).ge.253.16) then - qc(k) = qc(k) + 0.1*lwc - endif - enddo - - END SUBROUTINE adjust_cloudH2O - - -!+---+-----------------------------------------------------------------+ - -!..Do not alter any grid-explicitly resolved hydrometeors, rather only -!.. the supposed amounts due to the cloud fraction scheme. - - SUBROUTINE adjust_cloudFinal(cfr, qc, qi, Rho,dz, kts,kte,k_tropo) -! - IMPLICIT NONE -! - INTEGER, INTENT(IN):: kts,kte,k_tropo - REAL, DIMENSION(kts:kte), INTENT(IN):: cfr, Rho, dz - REAL, DIMENSION(kts:kte), INTENT(INOUT):: qc, qi - REAL:: lwp, iwp, xfac - INTEGER:: k - - lwp = 0. - do k = kts, k_tropo - if (cfr(k).gt.0.0) then - lwp = lwp + qc(k)*Rho(k)*dz(k) - endif - enddo - - iwp = 0. - do k = kts, k_tropo - if (cfr(k).gt.0.01 .and. cfr(k).lt.0.99) then - iwp = iwp + qi(k)*Rho(k)*dz(k) - endif - enddo - - if (lwp .gt. 1.5) then - xfac = 1./lwp - do k = kts, k_tropo - if (cfr(k).gt.0.01 .and. cfr(k).lt.0.99) then - qc(k) = qc(k)*xfac - endif - enddo - endif - - if (iwp .gt. 1.5) then - xfac = 1./iwp - do k = kts, k_tropo - if (cfr(k).gt.0.01 .and. cfr(k).lt.0.99) then - qi(k) = qi(k)*xfac - endif - enddo - endif - - END SUBROUTINE adjust_cloudFinal - + & .and.T(k).ge.253.16) then + qc(k) = qc(k) + 0.1*lwc + endif + enddo + + END SUBROUTINE adjust_cloudH2O + + +!+---+-----------------------------------------------------------------+ + +!..Do not alter any grid-explicitly resolved hydrometeors, rather only +!.. the supposed amounts due to the cloud fraction scheme. + + SUBROUTINE adjust_cloudFinal(cfr, qc, qi, Rho,dz, kts,kte,k_tropo) +! + IMPLICIT NONE +! + INTEGER, INTENT(IN):: kts,kte,k_tropo + REAL, DIMENSION(kts:kte), INTENT(IN):: cfr, Rho, dz + REAL, DIMENSION(kts:kte), INTENT(INOUT):: qc, qi + REAL:: lwp, iwp, xfac + INTEGER:: k + + lwp = 0. + do k = kts, k_tropo + if (cfr(k).gt.0.0) then + lwp = lwp + qc(k)*Rho(k)*dz(k) + endif + enddo + + iwp = 0. + do k = kts, k_tropo + if (cfr(k).gt.0.01 .and. cfr(k).lt.0.99) then + iwp = iwp + qi(k)*Rho(k)*dz(k) + endif + enddo + + if (lwp .gt. 1.5) then + xfac = 1./lwp + do k = kts, k_tropo + if (cfr(k).gt.0.01 .and. cfr(k).lt.0.99) then + qc(k) = qc(k)*xfac + endif + enddo + endif + + if (iwp .gt. 1.5) then + xfac = 1./iwp + do k = kts, k_tropo + if (cfr(k).gt.0.01 .and. cfr(k).lt.0.99) then + qi(k) = qi(k)*xfac + endif + enddo + endif + + END SUBROUTINE adjust_cloudFinal + ! !........................................! end module module_radiation_clouds ! From ac32ce0297022819a2c984374a622fd71b8d1749 Mon Sep 17 00:00:00 2001 From: "Man.Zhang" Date: Tue, 24 Mar 2020 11:23:01 -0600 Subject: [PATCH 6/9] remove the connection of iovrlw/iovrsw with physparam --- physics/GFS_rrtmg_pre.F90 | 67 +++++++++------- physics/radiation_clouds.f | 158 ++++++++++++++++++++++++------------- 2 files changed, 139 insertions(+), 86 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 7a5894f2e..952673f95 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -62,7 +62,7 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input & NSPC1 use module_radiation_clouds, only: NF_CLDS, & ! cld_init & progcld1, progcld3, & - & progcld2, & +! & progcld2, & & progcld4, progcld5, & & progcld6, & !F-A & progclduni, & @@ -787,11 +787,12 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input ! or unified cloud and/or with MG microphysics if (Model%uni_cld .and. Model%ncld >= 2) then - call progclduni (plyr, plvl, tlyr, tvly, ccnd, ncndl, & ! --- inputs - Grid%xlat, Grid%xlon, Sfcprop%slmsk,dz,delp, & - IM, LMK, LMP, cldcov, & - effrl, effri, effrr, effrs, Model%effr_in, & - clouds, cldsa, mtopa, mbota, de_lgth) ! --- outputs + call progclduni (plyr, plvl, tlyr, tvly, ccnd, ncndl, & ! --- inputs + Grid%xlat, Grid%xlon, Sfcprop%slmsk,dz,delp, & + IM, LMK, LMP, cldcov, & + effrl, effri, effrr, effrs, Model%effr_in, & + Model%iovr_lw, Model%iovr_sw, & ! mz* for iovr=3 should come from + clouds, cldsa, mtopa, mbota, de_lgth) ! --- outputs else call progcld1 (plyr ,plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs ccnd(1:IM,1:LMK,1), Grid%xlat,Grid%xlon, & @@ -799,6 +800,7 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input Model%uni_cld, Model%lmfshal, & Model%lmfdeep2, cldcov, & effrl, effri, effrr, effrs, Model%effr_in, & + Model%iovr_lw, Model%iovr_sw, & clouds, cldsa, mtopa, mbota, de_lgth) ! --- outputs endif @@ -809,23 +811,26 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input cnvw, cnvc, Grid%xlat, Grid%xlon, & Sfcprop%slmsk, dz, delp, im, lmk, lmp, deltaq, & Model%sup, Model%kdt, me, & + Model%iovr_lw, Model%iovr_sw, & clouds, cldsa, mtopa, mbota, de_lgth) ! --- outputs elseif (Model%imp_physics == 11) then ! GFDL cloud scheme if (.not.Model%lgfdlmprad) then - call progcld4 (plyr, plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs - ccnd(1:IM,1:LMK,1), cnvw, cnvc, & - Grid%xlat, Grid%xlon, Sfcprop%slmsk, & - cldcov, dz, delp, im, lmk, lmp, & + call progcld4 (plyr, plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs + ccnd(1:IM,1:LMK,1), cnvw, cnvc, & + Grid%xlat, Grid%xlon, Sfcprop%slmsk, & + cldcov, dz, delp, im, lmk, lmp, & + Model%iovr_lw, Model%iovr_sw, & clouds, cldsa, mtopa, mbota, de_lgth) ! --- outputs else - call progclduni (plyr, plvl, tlyr, tvly, ccnd, ncndl, & ! --- inputs - Grid%xlat, Grid%xlon, Sfcprop%slmsk, dz,delp, & - IM, LMK, LMP, cldcov, & - effrl, effri, effrr, effrs, Model%effr_in, & + call progclduni (plyr, plvl, tlyr, tvly, ccnd, ncndl, & ! --- inputs + Grid%xlat, Grid%xlon, Sfcprop%slmsk, dz,delp, & + IM, LMK, LMP, cldcov, & + effrl, effri, effrr, effrs, Model%effr_in, & + Model%iovr_lw, Model%iovr_sw, & clouds, cldsa, mtopa, mbota, de_lgth) ! --- outputs ! call progcld4o (plyr, plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs ! tracer1, Grid%xlat, Grid%xlon, Sfcprop%slmsk, & @@ -844,14 +849,15 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input endif !mz* this is original progcld5 - temporary - call progcld6 (plyr,plvl,tlyr,qlyr,qstl,rhly,tracer1, & ! --- inputs - Grid%xlat,Grid%xlon,Sfcprop%slmsk,dz,delp, & - ntrac-1, ntcw-1,ntiw-1,ntrw-1, & - ntsw-1,ntgl-1, & - im, lmk, lmp, Model%uni_cld, & - Model%lmfshal,Model%lmfdeep2, & - cldcov(:,1:LMK),Tbd%phy_f3d(:,:,1), & - Tbd%phy_f3d(:,:,2), Tbd%phy_f3d(:,:,3), & + call progcld6 (plyr,plvl,tlyr,qlyr,qstl,rhly,tracer1, & ! --- inputs + Grid%xlat,Grid%xlon,Sfcprop%slmsk,dz,delp, & + ntrac-1, ntcw-1,ntiw-1,ntrw-1, & + ntsw-1,ntgl-1, & + im, lmk, lmp, Model%uni_cld, & + Model%lmfshal,Model%lmfdeep2, & + cldcov(:,1:LMK),Tbd%phy_f3d(:,:,1), & + Tbd%phy_f3d(:,:,2), Tbd%phy_f3d(:,:,3), & + Model%iovr_lw, Model%iovr_sw, & clouds,cldsa,mtopa,mbota, de_lgth) ! --- outputs @@ -862,14 +868,15 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input Tbd%phy_f3d(:,:,Model%nseffr) = 250. endif - call progcld5 (plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,tracer1,& ! --- inputs - Grid%xlat,Grid%xlon,Sfcprop%slmsk,dz,delp, & - ntrac-1, ntcw-1,ntiw-1,ntrw-1, & - ntsw-1,ntgl-1, & - im, lmk, lmp, Model%icloud,Model%uni_cld, & - Model%lmfshal,Model%lmfdeep2, & - cldcov(:,1:LMK),Tbd%phy_f3d(:,:,1), & - Tbd%phy_f3d(:,:,2), Tbd%phy_f3d(:,:,3), & + call progcld5 (plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,tracer1, & ! --- inputs + Grid%xlat,Grid%xlon,Sfcprop%slmsk,dz,delp, & + ntrac-1, ntcw-1,ntiw-1,ntrw-1, & + ntsw-1,ntgl-1, & + im, lmk, lmp, Model%icloud,Model%uni_cld, & + Model%lmfshal,Model%lmfdeep2, & + cldcov(:,1:LMK),Tbd%phy_f3d(:,:,1), & + Tbd%phy_f3d(:,:,2), Tbd%phy_f3d(:,:,3), & + Model%iovr_lw, Model%iovr_sw, & clouds,cldsa,mtopa,mbota, de_lgth) ! --- outputs endif ! end if_imp_physics diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index 41da8953f..b76d57eaf 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -194,14 +194,16 @@ !> This module computes cloud related quantities for radiation computations. module module_radiation_clouds ! - use physparam, only : icldflg, iovrsw, iovrlw, & +!mz* iovrsw, iovrlw need to come from NML + use physparam, only : icldflg, &!mz:iovrsw, iovrlw,& & lcrick, lcnorm, lnoprec, & - & ivflip, kind_phys, kind_io4 + & ivflip use physcons, only : con_fvirt, con_ttp, con_rocp, & & con_t0c, con_pi, con_g, con_rd, & & con_thgni use module_microphysics, only : rsipath2 use module_iounitdef, only : NICLTUN + use machine, only : kind_phys ! implicit none ! @@ -240,7 +242,7 @@ module module_radiation_clouds real (kind=kind_phys), parameter :: cldasy_def = 0.84 !< default cld asymmetry factor integer :: llyr = 2 !< upper limit of boundary layer clouds - integer :: iovr = 1 !< maximum-random cloud overlapping method +!mz integer :: iovr = 1 !< maximum-random cloud overlapping method public progcld1, progcld2, progcld3, progcld4, progclduni, & & cld_init, progcld5, progcld4o, & @@ -331,7 +333,7 @@ subroutine cld_init & ! ! --- set up module variables - iovr = max( iovrsw, iovrlw ) !cld ovlp used for diag HML cld output +!mz iovr = max( iovrsw, iovrlw ) !cld ovlp used for diag HML cld output if (me == 0) print *, VTAGCLD !print out version tag @@ -441,6 +443,7 @@ subroutine progcld1 & & xlat,xlon,slmsk,dz,delp, IX, NLAY, NLP1, & & uni_cld, lmfshal, lmfdeep2, cldcov, & & effrl,effri,effrr,effrs,effr_in, & + & iovr_lw, iovr_sw, & & clouds,clds,mtop,mbot,de_lgth & ! --- outputs: & ) @@ -524,7 +527,7 @@ subroutine progcld1 & implicit none ! --- inputs - integer, intent(in) :: IX, NLAY, NLP1 + integer, intent(in) :: IX, NLAY, NLP1,iovr_lw,iovr_sw logical, intent(in) :: uni_cld, lmfshal, lmfdeep2, effr_in @@ -552,7 +555,7 @@ subroutine progcld1 & real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & & tem1, tem2, tem3 - integer :: i, k, id, nf + integer :: i, k, id, nf,iovrw ! --- constant values ! real (kind=kind_phys), parameter :: xrc3 = 200. @@ -560,6 +563,8 @@ subroutine progcld1 & ! !===> ... begin here +!mz + iovrw = max( iovr_sw, iovr_lw ) !cld ovlp used for diag HML cld output ! do nf=1,nf_clds do k=1,nlay @@ -801,7 +806,7 @@ subroutine progcld1 & ! --- ... estimate clouds decorrelation length in km ! this is only a tentative test, need to consider change later - if ( iovr == 3 ) then + if ( iovrw == 3 ) then do i = 1, ix de_lgth(i) = max( 0.6, 2.78-4.6*rxlat(i) ) enddo @@ -815,7 +820,7 @@ subroutine progcld1 & call gethml & ! --- inputs: & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, & - & IX,NLAY, & + & IX,NLAY, iovr_lw, iovr_sw, & ! --- outputs: & clds, mtop, mbot & & ) @@ -873,6 +878,7 @@ subroutine progcld2 & & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw, & ! --- inputs: & xlat,xlon,slmsk,dz,delp, f_ice,f_rain,r_rime,flgmin, & & IX, NLAY, NLP1, lmfshal, lmfdeep2, & + & iovr_lw, iovr_sw, & & clouds,clds,mtop,mbot,de_lgth & ! --- outputs: & ) @@ -961,7 +967,7 @@ subroutine progcld2 & ! --- constants ! --- inputs - integer, intent(in) :: IX, NLAY, NLP1 + integer, intent(in) :: IX, NLAY, NLP1, iovr_lw,iovr_sw logical, intent(in) :: lmfshal, lmfdeep2 @@ -991,7 +997,7 @@ subroutine progcld2 & real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & & tem1, tem2, tem3 - integer :: i, k, id + integer :: i, k, id, iovrw ! --- constant values ! real (kind=kind_phys), parameter :: xrc3 = 200. @@ -1001,6 +1007,10 @@ subroutine progcld2 & !===> ... begin here ! ! clouds(:,:,:) = 0.0 +!zm +!mz$ + iovrw = max( iovr_sw, iovr_lw ) !cld ovlp used for diag HML cld output$ + !> - Assign water/ice/rain/snow cloud properties for Ferrier scheme. do k = 1, NLAY @@ -1247,7 +1257,7 @@ subroutine progcld2 & ! --- ... estimate clouds decorrelation length in km ! this is only a tentative test, need to consider change later - if ( iovr == 3 ) then + if ( iovrw == 3 ) then do i = 1, ix de_lgth(i) = max( 0.6, 2.78-4.6*rxlat(i) ) enddo @@ -1264,6 +1274,7 @@ subroutine progcld2 & ! --- inputs: & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, & & IX,NLAY, & + & iovr_lw,iovr_sw, & ! --- outputs: & clds, mtop, mbot & & ) @@ -1322,6 +1333,7 @@ subroutine progcld3 & & xlat,xlon,slmsk, dz, delp, & & ix, nlay, nlp1, & & deltaq,sup,kdt,me, & + & iovr_lw, iovr_sw, & & clouds,clds,mtop,mbot,de_lgth & ! --- outputs: & ) @@ -1404,7 +1416,7 @@ subroutine progcld3 & implicit none ! --- inputs - integer, intent(in) :: ix, nlay, nlp1,kdt + integer, intent(in) :: ix, nlay, nlp1,kdt,iovr_lw,iovr_sw real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & & tlyr, tvly, qlyr, qstl, rhly, clw, dz, delp @@ -1436,11 +1448,14 @@ subroutine progcld3 & real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & & tem1, tem2, tem3 - integer :: i, k, id, nf + integer :: i, k, id, nf, iovrw ! !===> ... begin here ! +!mz + iovrw = max( iovr_sw, iovr_lw ) !cld ovlp used for diag HML cld output + do nf=1,nf_clds do k=1,nlay do i=1,ix @@ -1644,7 +1659,7 @@ subroutine progcld3 & ! --- ... estimate clouds decorrelation length in km ! this is only a tentative test, need to consider change later - if ( iovr == 3 ) then + if ( iovrw == 3 ) then do i = 1, ix de_lgth(i) = max( 0.6, 2.78-4.6*rxlat(i) ) enddo @@ -1662,6 +1677,7 @@ subroutine progcld3 & ! --- inputs: & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, & & ix,nlay, & + & iovr_lw,iovr_sw, & ! --- outputs: & clds, mtop, mbot & & ) @@ -1718,7 +1734,8 @@ end subroutine progcld3 subroutine progcld4 & & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw,cnvw,cnvc, & ! --- inputs: & xlat,xlon,slmsk,cldtot, dz, delp, & - & IX, NLAY, NLP1, & + & IX, NLAY, NLP1, & + & iovr_lw, iovr_sw, & & clouds,clds,mtop,mbot,de_lgth & ! --- outputs: & ) @@ -1799,7 +1816,7 @@ subroutine progcld4 & implicit none ! --- inputs - integer, intent(in) :: IX, NLAY, NLP1 + integer, intent(in) :: IX, NLAY, NLP1,iovr_lw,iovr_sw real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & & tlyr, tvly, qlyr, qstl, rhly, clw, cldtot, cnvw, cnvc, & @@ -1825,11 +1842,14 @@ subroutine progcld4 & real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & & tem1, tem2, tem3 - integer :: i, k, id, nf + integer :: i, k, id, nf,iovrw ! !===> ... begin here ! +!mz + iovrw = max( iovr_sw, iovr_lw ) !cld ovlp used for diag HML cld output + do nf=1,nf_clds do k=1,nlay do i=1,ix @@ -1981,7 +2001,7 @@ subroutine progcld4 & ! --- ... estimate clouds decorrelation length in km ! this is only a tentative test, need to consider change later - if ( iovr == 3 ) then + if ( iovrw == 3 ) then do i = 1, ix de_lgth(i) = max( 0.6, 2.78-4.6*rxlat(i) ) enddo @@ -1997,6 +2017,7 @@ subroutine progcld4 & ! --- inputs: & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, & & IX,NLAY, & + & iovr_lw, iovr_sw, & ! --- outputs: & clds, mtop, mbot & & ) @@ -2060,6 +2081,7 @@ subroutine progcld4o & & xlat,xlon,slmsk, dz, delp, & & ntrac,ntcw,ntiw,ntrw,ntsw,ntgl,ntclamt, & & IX, NLAY, NLP1, & + & iovr_lw, iovr_sw, & & clouds,clds,mtop,mbot,de_lgth & ! --- outputs: & ) @@ -2139,7 +2161,7 @@ subroutine progcld4o & implicit none ! --- inputs - integer, intent(in) :: IX, NLAY, NLP1 + integer, intent(in) :: IX, NLAY, NLP1, iovr_lw, iovr_sw integer, intent(in) :: ntrac, ntcw, ntiw, ntrw, ntsw, ntgl, & & ntclamt @@ -2169,10 +2191,12 @@ subroutine progcld4o & & tem1, tem2, tem3 real (kind=kind_phys), dimension(IX,NLAY) :: cldtot - integer :: i, k, id, nf + integer :: i, k, id, nf, iovrw ! !===> ... begin here +!mz + iovrw = max( iovr_sw, iovr_lw ) !cld ovlp used for diag HML cld output ! do nf=1,nf_clds do k=1,nlay @@ -2309,7 +2333,7 @@ subroutine progcld4o & ! --- ... estimate clouds decorrelation length in km ! this is only a tentative test, need to consider change later - if ( iovr == 3 ) then + if ( iovrw == 3 ) then do i = 1, ix de_lgth(i) = max( 0.6, 2.78-4.6*rxlat(i) ) enddo @@ -2325,6 +2349,7 @@ subroutine progcld4o & ! --- inputs: & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, & & IX,NLAY, & + & iovr_lw, iovr_sw, & ! --- outputs: & clds, mtop, mbot & & ) @@ -2343,11 +2368,12 @@ end subroutine progcld4o !! microphysics scheme. subroutine progcld5 & & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw, & ! --- inputs: - & xlat,xlon,slmsk,dz,delp, & - & ntrac,ntcw,ntiw,ntrw,ntsw,ntgl, & + & xlat,xlon,slmsk,dz,delp, & + & ntrac,ntcw,ntiw,ntrw,ntsw,ntgl, & & IX, NLAY, NLP1,icloud, & - & uni_cld, lmfshal, lmfdeep2, cldcov, & - & re_cloud,re_ice,re_snow, & + & uni_cld, lmfshal, lmfdeep2, cldcov, & + & re_cloud,re_ice,re_snow, & + & iovr_lw,iovr_sw, & & clouds,clds,mtop,mbot,de_lgth & ! --- outputs: & ) @@ -2431,7 +2457,7 @@ subroutine progcld5 & implicit none ! --- inputs - integer, intent(in) :: IX, NLAY, NLP1,ICLOUD + integer, intent(in) :: IX, NLAY, NLP1,ICLOUD,iovr_lw,iovr_sw integer, intent(in) :: ntrac, ntcw, ntiw, ntrw, ntsw, ntgl logical, intent(in) :: uni_cld, lmfshal, lmfdeep2 @@ -2466,7 +2492,7 @@ subroutine progcld5 & real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & & tem1, tem2, tem3 - integer :: i, k, id, nf + integer :: i, k, id, nf, iovrw ! --- constant values ! real (kind=kind_phys), parameter :: xrc3 = 200. @@ -2474,6 +2500,8 @@ subroutine progcld5 & ! !===> ... begin here +!mz + iovrw = max( iovr_sw, iovr_lw ) !cld ovlp used for diag HML cld output ! do nf=1,nf_clds do k=1,nlay @@ -2738,7 +2766,7 @@ subroutine progcld5 & ! --- ... estimate clouds decorrelation length in km ! this is only a tentative test, need to consider change later - if ( iovr == 3 ) then + if ( iovrw == 3 ) then do i = 1, ix de_lgth(i) = max( 0.6, 2.78-4.6*rxlat(i) ) enddo @@ -2757,6 +2785,7 @@ subroutine progcld5 & ! --- inputs: & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, & & IX,NLAY, & + & iovr_lw,iovr_sw, & ! --- outputs: & clds, mtop, mbot & & ) @@ -2772,11 +2801,12 @@ end subroutine progcld5 !mz: progcld5 benchmark subroutine progcld6 & & ( plyr,plvl,tlyr,qlyr,qstl,rhly,clw, & ! --- inputs: - & xlat,xlon,slmsk,dz,delp, & - & ntrac,ntcw,ntiw,ntrw,ntsw,ntgl, & + & xlat,xlon,slmsk,dz,delp, & + & ntrac,ntcw,ntiw,ntrw,ntsw,ntgl, & & IX, NLAY, NLP1, & - & uni_cld, lmfshal, lmfdeep2, cldcov, & - & re_cloud,re_ice,re_snow, & + & uni_cld, lmfshal, lmfdeep2, cldcov, & + & re_cloud,re_ice,re_snow, & + & iovr_lw,iovr_sw, & & clouds,clds,mtop,mbot,de_lgth & ! --- outputs: & ) @@ -2858,12 +2888,12 @@ subroutine progcld6 & ! ! ! ==================== end of description ===================== ! ! - implicit none - -! --- inputs - integer, intent(in) :: IX, NLAY, NLP1 - integer, intent(in) :: ntrac, ntcw, ntiw, ntrw, ntsw, ntgl - + implicit none + +! --- inputs + integer, intent(in) :: IX, NLAY, NLP1,iovr_lw,iovr_sw + integer, intent(in) :: ntrac, ntcw, ntiw, ntrw, ntsw, ntgl + logical, intent(in) :: uni_cld, lmfshal, lmfdeep2 real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & @@ -2888,11 +2918,11 @@ subroutine progcld6 & & cwp, cip, crp, csp, rew, rei, res, rer, tem2d, clwf real (kind=kind_phys) :: ptop1(IX,NK_CLDS+1), rxlat(ix) - - real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & - & tem1, tem2, tem3 - - integer :: i, k, id, nf + + real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & + & tem1, tem2, tem3 + + integer :: i, k, id, nf, iovrw ! --- constant values ! real (kind=kind_phys), parameter :: xrc3 = 200. @@ -2900,7 +2930,10 @@ subroutine progcld6 & ! !===> ... begin here -! +!!mz$ + iovrw = max( iovr_sw, iovr_lw ) !cld ovlp used for diag HML cld output$ + +! do nf=1,nf_clds do k=1,nlay do i=1,ix @@ -3083,11 +3116,11 @@ subroutine progcld6 & clouds(i,k,9) = res(i,k) enddo enddo - + ! --- ... estimate clouds decorrelation length in km ! this is only a tentative test, need to consider change later - if ( iovr == 3 ) then + if ( iovrw == 3 ) then do i = 1, ix de_lgth(i) = max( 0.6, 2.78-4.6*rxlat(i) ) enddo @@ -3106,6 +3139,7 @@ subroutine progcld6 & ! --- inputs: & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, & & IX,NLAY, & + & iovr_lw, iovr_sw, & ! --- outputs: & clds, mtop, mbot & & ) @@ -3163,6 +3197,7 @@ subroutine progclduni & & ( plyr,plvl,tlyr,tvly,ccnd,ncnd, & ! --- inputs: & xlat,xlon,slmsk,dz,delp, IX, NLAY, NLP1, cldtot, & & effrl,effri,effrr,effrs,effr_in, & + & iovr_lw,iovr_sw, & !mz* $ & clouds,clds,mtop,mbot,de_lgth & ! --- outputs: & ) @@ -3257,6 +3292,9 @@ subroutine progclduni & real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & & slmsk + !mz* for GFSv16 + integer, intent(in) :: iovr_lw, iovr_sw + ! --- outputs real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds @@ -3267,6 +3305,7 @@ subroutine progclduni & integer, dimension(:,:), intent(out) :: mtop,mbot ! --- local variables: + integer :: iovrw real (kind=kind_phys), dimension(IX,NLAY) :: cldcnv, cwp, cip, & & crp, csp, rew, rei, res, rer real (kind=kind_phys), dimension(IX,NLAY,ncnd) :: cndf @@ -3288,6 +3327,9 @@ subroutine progclduni & ! enddo ! enddo ! +!mz* + iovrw = max( iovr_sw, iovr_lw ) !cld ovlp used for diag HML cld output + do k = 1, NLAY do i = 1, IX cldcnv(i,k) = 0.0 @@ -3457,7 +3499,7 @@ subroutine progclduni & !> -# Estimate clouds decorrelation length in km ! this is only a tentative test, need to consider change later - if ( iovr == 3 ) then + if ( iovrw == 3 ) then do i = 1, ix de_lgth(i) = max( 0.6, 2.78-4.6*rxlat(i) ) enddo @@ -3476,6 +3518,7 @@ subroutine progclduni & ! --- inputs: & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, & & IX,NLAY, & + & iovr_lw, iovr_sw, & ! --- outputs: & clds, mtop, mbot & & ) @@ -3511,7 +3554,7 @@ end subroutine progclduni !! @{ subroutine gethml & & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, & ! --- inputs: - & IX, NLAY, & + & IX, NLAY,iovr_lw,iovr_sw, & & clds, mtop, mbot & ! --- outputs: & ) @@ -3567,7 +3610,7 @@ subroutine gethml & implicit none! ! --- inputs: - integer, intent(in) :: IX, NLAY + integer, intent(in) :: IX, NLAY,iovr_sw,iovr_lw real (kind=kind_phys), dimension(:,:), intent(in) :: plyr, ptop1, & & cldtot, cldcnv, dz @@ -3583,11 +3626,14 @@ subroutine gethml & real (kind=kind_phys) :: pcur, pnxt, ccur, cnxt, alfa integer, dimension(IX):: idom, kbt1, kth1, kbt2, kth2 - integer :: i, k, id, id1, kstr, kend, kinc + integer :: i, k, id, id1, kstr, kend, kinc,iovrw ! !===> ... begin here ! +!mz* + iovrw = max( iovr_sw, iovr_lw ) !cld ovlp used for diag HML cld output + clds(:,:) = 0.0 do i = 1, IX @@ -3611,7 +3657,7 @@ subroutine gethml & kinc = 1 endif ! end_if_ivflip - if ( iovr == 0 ) then ! random overlap + if ( iovrw == 0 ) then ! random overlap do k = kstr, kend, kinc do i = 1, IX @@ -3630,7 +3676,7 @@ subroutine gethml & clds(i,4) = 1.0 - cl1(i) ! save total cloud enddo - elseif ( iovr == 1 ) then ! max/ran overlap + elseif ( iovrw == 1 ) then ! max/ran overlap do k = kstr, kend, kinc do i = 1, IX @@ -3654,7 +3700,7 @@ subroutine gethml & clds(i,4) = 1.0 - cl1(i) * cl2(i) ! save total cloud enddo - elseif ( iovr == 2 ) then ! maximum overlap all levels + elseif ( iovrw == 2 ) then ! maximum overlap all levels cl1(:) = 0.0 @@ -3675,7 +3721,7 @@ subroutine gethml & clds(i,4) = cl1(i) ! save total cloud enddo - elseif ( iovr == 3 ) then ! random if clear-layer divided, + elseif ( iovrw == 3 ) then ! random if clear-layer divided, ! otherwise de-corrlength method do i = 1, ix dz1(i) = - dz(i,kstr) @@ -3761,7 +3807,7 @@ subroutine gethml & if (kth2(i) == 0) kbt2(i) = k kth2(i) = kth2(i) + 1 - if ( iovr == 0 ) then + if ( iovrw == 0 ) then cl2(i) = cl2(i) + ccur - cl2(i)*ccur else cl2(i) = max( cl2(i), ccur ) @@ -3843,7 +3889,7 @@ subroutine gethml & if (kth2(i) == 0) kbt2(i) = k kth2(i) = kth2(i) + 1 - if ( iovr == 0 ) then + if ( iovrw == 0 ) then cl2(i) = cl2(i) + ccur - cl2(i)*ccur else cl2(i) = max( cl2(i), ccur ) From 5404462a72fe10477595c25baab0ae28fe667f0f Mon Sep 17 00:00:00 2001 From: "Man.Zhang" Date: Tue, 7 Apr 2020 10:04:47 -0600 Subject: [PATCH 7/9] add new radlw/radsw main with modern fortran --- physics/radlw_main.F90 | 8976 ++++++++++++++++++++++++++++++++++++++++ physics/radsw_main.F90 | 6339 ++++++++++++++++++++++++++++ 2 files changed, 15315 insertions(+) create mode 100644 physics/radlw_main.F90 create mode 100644 physics/radsw_main.F90 diff --git a/physics/radlw_main.F90 b/physics/radlw_main.F90 new file mode 100644 index 000000000..0596a987c --- /dev/null +++ b/physics/radlw_main.F90 @@ -0,0 +1,8976 @@ +!> \file radlw_main.f +!! This file contains NCEP's modifications of the rrtmg-lw radiation +!! code from AER. + +!!!!! ============================================================== !!!!! +!!!!! lw-rrtm3 radiation package description !!!!! +!!!!! ============================================================== !!!!! +! ! +! this package includes ncep's modifications of the rrtm-lw radiation ! +! code from aer inc. ! +! ! +! the lw-rrtm3 package includes these parts: ! +! ! +! 'radlw_rrtm3_param.f' ! +! 'radlw_rrtm3_datatb.f' ! +! 'radlw_rrtm3_main.f' ! +! ! +! the 'radlw_rrtm3_param.f' contains: ! +! ! +! 'module_radlw_parameters' -- band parameters set up ! +! ! +! the 'radlw_rrtm3_datatb.f' contains: ! +! ! +! 'module_radlw_avplank' -- plank flux data ! +! 'module_radlw_ref' -- reference temperature and pressure ! +! 'module_radlw_cldprlw' -- cloud property coefficients ! +! 'module_radlw_kgbnn' -- absorption coeffients for 16 ! +! bands, where nn = 01-16 ! +! ! +! the 'radlw_rrtm3_main.f' contains: ! +! ! +! 'rrtmg_lw' -- main lw radiation transfer ! +! ! +! in the main module 'rrtmg_lw' there are only two ! +! externally callable subroutines: ! +! ! +! ! +! 'lwrad' -- main lw radiation routine ! +! inputs: ! +! (plyr,plvl,tlyr,tlvl,qlyr,olyr,gasvmr, ! +! clouds,icseed,aerosols,sfemis,sfgtmp, ! +! dzlyr,delpin,de_lgth, ! +! npts, nlay, nlp1, lprnt, ! +! outputs: ! +! hlwc,topflx,sfcflx,cldtau, ! +!! optional outputs: ! +! HLW0,HLWB,FLXPRF) ! +! ! +! 'rlwinit' -- initialization routine ! +! inputs: ! +! ( me ) ! +! outputs: ! +! (none) ! +! ! +! all the lw radiation subprograms become contained subprograms ! +! in module 'rrtmg_lw' and many of them are not directly ! +! accessable from places outside the module. ! +! ! +! derived data type constructs used: ! +! ! +! 1. radiation flux at toa: (from module 'module_radlw_parameters') ! +! topflw_type - derived data type for toa rad fluxes ! +! upfxc total sky upward flux at toa ! +! upfx0 clear sky upward flux at toa ! +! ! +! 2. radiation flux at sfc: (from module 'module_radlw_parameters') ! +! sfcflw_type - derived data type for sfc rad fluxes ! +! upfxc total sky upward flux at sfc ! +! upfx0 clear sky upward flux at sfc ! +! dnfxc total sky downward flux at sfc ! +! dnfx0 clear sky downward flux at sfc ! +! ! +! 3. radiation flux profiles(from module 'module_radlw_parameters') ! +! proflw_type - derived data type for rad vertical prof ! +! upfxc level upward flux for total sky ! +! dnfxc level downward flux for total sky ! +! upfx0 level upward flux for clear sky ! +! dnfx0 level downward flux for clear sky ! +! ! +! external modules referenced: ! +! ! +! 'module physparam' ! +! 'module physcons' ! +! 'mersenne_twister' ! +! ! +! compilation sequence is: ! +! ! +! 'radlw_rrtm3_param.f' ! +! 'radlw_rrtm3_datatb.f' ! +! 'radlw_rrtm3_main.f' ! +! ! +! and all should be put in front of routines that use lw modules ! +! ! +!==========================================================================! +! ! +! the original aer's program declarations: ! +! ! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! | +! Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). | +! This software may be used, copied, or redistributed as long as it is | +! not sold and this copyright notice is reproduced on each copy made. | +! This model is provided as is without any express or implied warranties. | +! (http://www.rtweb.aer.com/) | +! | +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! ! +! ************************************************************************ ! +! ! +! rrtmg_lw ! +! ! +! ! +! a rapid radiative transfer model ! +! for the longwave region ! +! for application to general circulation models ! +! ! +! ! +! atmospheric and environmental research, inc. ! +! 131 hartwell avenue ! +! lexington, ma 02421 ! +! ! +! eli j. mlawer ! +! jennifer s. delamere ! +! michael j. iacono ! +! shepard a. clough ! +! ! +! ! +! email: miacono@aer.com ! +! email: emlawer@aer.com ! +! email: jdelamer@aer.com ! +! ! +! the authors wish to acknowledge the contributions of the ! +! following people: steven j. taubman, karen cady-pereira, ! +! patrick d. brown, ronald e. farren, luke chen, robert bergstrom. ! +! ! +! ************************************************************************ ! +! ! +! references: ! +! (rrtm_lw/rrtmg_lw): ! +! clough, s.A., m.w. shephard, e.j. mlawer, j.s. delamere, ! +! m.j. iacono, k. cady-pereira, s. boukabara, and p.d. brown: ! +! atmospheric radiative transfer modeling: a summary of the aer ! +! codes, j. quant. spectrosc. radiat. transfer, 91, 233-244, 2005. ! +! ! +! mlawer, e.j., s.j. taubman, p.d. brown, m.j. iacono, and s.a. ! +! clough: radiative transfer for inhomogeneous atmospheres: rrtm, ! +! a validated correlated-k model for the longwave. j. geophys. res., ! +! 102, 16663-16682, 1997. ! +! ! +! (mcica): ! +! pincus, r., h. w. barker, and j.-j. morcrette: a fast, flexible, ! +! approximation technique for computing radiative transfer in ! +! inhomogeneous cloud fields, j. geophys. res., 108(d13), 4376, ! +! doi:10.1029/2002JD003322, 2003. ! +! ! +! ************************************************************************ ! +! ! +! aer's revision history: ! +! this version of rrtmg_lw has been modified from rrtm_lw to use a ! +! reduced set of g-points for application to gcms. ! +! ! +! -- original version (derived from rrtm_lw), reduction of g-points, ! +! other revisions for use with gcms. ! +! 1999: m. j. iacono, aer, inc. ! +! -- adapted for use with ncar/cam3. ! +! may 2004: m. j. iacono, aer, inc. ! +! -- revised to add mcica capability. ! +! nov 2005: m. j. iacono, aer, inc. ! +! -- conversion to f90 formatting for consistency with rrtmg_sw. ! +! feb 2007: m. j. iacono, aer, inc. ! +! -- modifications to formatting to use assumed-shape arrays. ! +! aug 2007: m. j. iacono, aer, inc. ! +! ! +! ************************************************************************ ! +! ! +! ncep modifications history log: ! +! ! +! nov 1999, ken campana -- received the original code from ! +! aer (1998 ncar ccm version), updated to link up with ! +! ncep mrf model ! +! jun 2000, ken campana -- added option to switch random and ! +! maximum/random cloud overlap ! +! 2001, shrinivas moorthi -- further updates for mrf model ! +! may 2001, yu-tai hou -- updated on trace gases and cloud ! +! property based on rrtm_v3.0 codes. ! +! dec 2001, yu-tai hou -- rewritten code into fortran 90 std ! +! set ncep radiation structure standard that contains ! +! three plug-in compatable fortran program files: ! +! 'radlw_param.f', 'radlw_datatb.f', 'radlw_main.f' ! +! fixed bugs in subprograms taugb14, taugb2, etc. added ! +! out-of-bounds protections. (a detailed note of ! +! up_to_date modifications/corrections by ncep was sent ! +! to aer in 2002) ! +! jun 2004, yu-tai hou -- added mike iacono's apr 2004 ! +! modification of variable diffusivity angles. ! +! apr 2005, yu-tai hou -- minor modifications on module ! +! structures include rain/snow effect (this version of ! +! code was given back to aer in jun 2006) ! +! mar 2007, yu-tai hou -- added aerosol effect for ncep ! +! models using the generallized aerosol optical property! +! scheme for gfs model. ! +! apr 2007, yu-tai hou -- added spectral band heating as an ! +! optional output to support the 500 km gfs model's ! +! upper stratospheric radiation calculations. and ! +! restructure optional outputs for easy access by ! +! different models. ! +! oct 2008, yu-tai hou -- modified to include new features ! +! from aer's newer release v4.4-v4.7, including the ! +! mcica sub-grid cloud option. add rain/snow optical ! +! properties support to cloudy sky calculations. ! +! correct errors in mcica cloud optical properties for ! +! ebert & curry scheme (ilwcice=1) that needs band ! +! index conversion. simplified and unified sw and lw ! +! sub-column cloud subroutines into one module by using ! +! optional parameters. ! +! mar 2009, yu-tai hou -- replaced the original random number! +! generator coming from the original code with ncep w3 ! +! library to simplify the program and moved sub-column ! +! cloud subroutines inside the main module. added ! +! option of user provided permutation seeds that could ! +! be randomly generated from forecast time stamp. ! +! oct 2009, yu-tai hou -- modified subrtines "cldprop" and ! +! "rlwinit" according updats from aer's rrtmg_lw v4.8. ! +! nov 2009, yu-tai hou -- modified subrtine "taumol" according +! updats from aer's rrtmg_lw version 4.82. notice the ! +! cloud ice/liquid are assumed as in-cloud quantities, ! +! not as grid averaged quantities. ! +! jun 2010, yu-tai hou -- optimized code to improve efficiency +! apr 2012, b. ferrier and y. hou -- added conversion factor to fu's! +! cloud-snow optical property scheme. ! +! nov 2012, yu-tai hou -- modified control parameters thru ! +! module 'physparam'. ! +! FEB 2017 A.Cheng - add odpth output, effective radius input ! +! jun 2018, h-m lin/y-t hou -- added new option of cloud overlap ! +! method 'de-correlation-length' for mcica application ! +! ! +!!!!! ============================================================== !!!!! +!!!!! end descriptions !!!!! +!!!!! ============================================================== !!!!! + +!> This module contains the CCPP-compliant NCEP's modifications of the +!! rrtm-lw radiation code from aer inc. + module rrtmg_lw +! + use physparam, only : ilwrate, ilwrgas, ilwcliq, ilwcice, & + & icldflg, ivflip + use physcons, only : con_g, con_cp, con_avgd, con_amd, & + & con_amw, con_amo3 + use mersenne_twister, only : random_setseed, random_number, & + & random_stat +!mz + use machine, only : kind_phys, & + & im => kind_io4, rb => kind_phys + + use module_radlw_parameters +! + use module_radlw_avplank, only : totplnk + use module_radlw_ref, only : preflog, tref, chi_mls +! + implicit none +! + private +! +! ... version tag and last revision date + character(40), parameter :: & + & VTAGLW='NCEP LW v5.1 Nov 2012 -RRTMG-LW v4.82 ' +! & VTAGLW='NCEP LW v5.0 Aug 2012 -RRTMG-LW v4.82 ' +! & VTAGLW='RRTMG-LW v4.82 Nov 2009 ' +! & VTAGLW='RRTMG-LW v4.8 Oct 2009 ' +! & VTAGLW='RRTMG-LW v4.71 Mar 2009 ' +! & VTAGLW='RRTMG-LW v4.4 Oct 2008 ' +! & VTAGLW='RRTM-LW v2.3g Mar 2007 ' +! & VTAGLW='RRTM-LW v2.3g Apr 2004 ' + +! --- constant values + real (kind=kind_phys), parameter :: eps = 1.0e-6 + real (kind=kind_phys), parameter :: oneminus= 1.0-eps + real (kind=kind_phys), parameter :: cldmin = tiny(cldmin) + real (kind=kind_phys), parameter :: bpade = 1.0/0.278 ! pade approx constant + real (kind=kind_phys), parameter :: stpfac = 296.0/1013.0 + real (kind=kind_phys), parameter :: wtdiff = 0.5 ! weight for radiance to flux conversion + real (kind=kind_phys), parameter :: tblint = ntbl ! lookup table conversion factor + real (kind=kind_phys), parameter :: f_zero = 0.0 + real (kind=kind_phys), parameter :: f_one = 1.0 + +! ... atomic weights for conversion from mass to volume mixing ratios + real (kind=kind_phys), parameter :: amdw = con_amd/con_amw + real (kind=kind_phys), parameter :: amdo3 = con_amd/con_amo3 + +! ... band indices + integer, dimension(nbands) :: nspa, nspb + + data nspa / 1, 1, 9, 9, 9, 1, 9, 1, 9, 1, 1, 9, 9, 1, 9, 9 / + data nspb / 1, 1, 5, 5, 5, 0, 1, 1, 1, 1, 1, 0, 0, 1, 0, 0 / + +! ... band wavenumber intervals +! real (kind=kind_phys) :: wavenum1(nbands), wavenum2(nbands) +! data wavenum1/ & +! & 10., 350., 500., 630., 700., 820., 980., 1080., & +!err & 1180., 1390., 1480., 1800., 2080., 2250., 2390., 2600. / +! & 1180., 1390., 1480., 1800., 2080., 2250., 2380., 2600. / +! data wavenum2/ & +! & 350., 500., 630., 700., 820., 980., 1080., 1180., & +!err & 1390., 1480., 1800., 2080., 2250., 2390., 2600., 3250. / +! & 1390., 1480., 1800., 2080., 2250., 2380., 2600., 3250. / +! real (kind=kind_phys) :: delwave(nbands) +! data delwave / 340., 150., 130., 70., 120., 160., 100., 100., & +! & 210., 90., 320., 280., 170., 130., 220., 650. / + +! --- reset diffusivity angle for Bands 2-3 and 5-9 to vary (between 1.50 +! and 1.80) as a function of total column water vapor. the function +! has been defined to minimize flux and cooling rate errors in these bands +! over a wide range of precipitable water values. + real (kind=kind_phys), dimension(nbands) :: a0, a1, a2 + + data a0 / 1.66, 1.55, 1.58, 1.66, 1.54, 1.454, 1.89, 1.33, & + & 1.668, 1.66, 1.66, 1.66, 1.66, 1.66, 1.66, 1.66 / + data a1 / 0.00, 0.25, 0.22, 0.00, 0.13, 0.446, -0.10, 0.40, & + & -0.006, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + data a2 / 0.00, -12.0, -11.7, 0.00, -0.72,-0.243, 0.19,-0.062, & + & 0.414, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + +!! --- logical flags for optional output fields + + logical :: lhlwb = .false. + logical :: lhlw0 = .false. + logical :: lflxprf= .false. + +! --- those data will be set up only once by "rlwinit" + +! ... fluxfac, heatfac are factors for fluxes (in w/m**2) and heating +! rates (in k/day, or k/sec set by subroutine 'rlwinit') +! semiss0 are default surface emissivity for each bands + + real (kind=kind_phys) :: fluxfac, heatfac, semiss0(nbands) + data semiss0(:) / nbands*1.0 / + + real (kind=kind_phys) :: tau_tbl(0:ntbl) !< clr-sky opt dep (for cldy transfer) + real (kind=kind_phys) :: exp_tbl(0:ntbl) !< transmittance lookup table + real (kind=kind_phys) :: tfn_tbl(0:ntbl) !< tau transition function; i.e. the + !< transition of planck func from mean lyr + !< temp to lyr boundary temp as a func of + !< opt dep. "linear in tau" method is used. + +! --- the following variables are used for sub-column cloud scheme + + integer, parameter :: ipsdlw0 = ngptlw ! initial permutation seed + +! --- public accessable subprograms + + public rrtmg_lw_init, rrtmg_lw_run, rrtmg_lw_finalize, rlwinit + + +! ================ + contains +! ================ + + subroutine rrtmg_lw_init () + end subroutine rrtmg_lw_init + +!> \defgroup module_radlw_main GFS RRTMG Longwave Module +!! \brief This module includes NCEP's modifications of the RRTMG-LW radiation +!! code from AER. +!! +!! The RRTM-LW package includes three files: +!! - radlw_param.f, which contains: +!! - module_radlw_parameters: band parameters set up +!! - radlw_datatb.f, which contains modules: +!! - module_radlw_avplank: plank flux data +!! - module_radlw_ref: reference temperature and pressure +!! - module_radlw_cldprlw: cloud property coefficients +!! - module_radlw_kgbnn: absorption coeffients for 16 bands, where nn = 01-16 +!! - radlw_main.f, which contains: +!! - rrtmg_lw_run(): the main LW radiation routine +!! - rlwinit(): the initialization routine +!! +!!\version NCEP LW v5.1 Nov 2012 -RRTMG-LW v4.82 +!! +!!\copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). +!! This software may be used, copied, or redistributed as long as it is +!! not sold and this copyright notice is reproduced on each copy made. +!! This model is provided as is without any express or implied warranties. +!! (http://www.rtweb.aer.com/) +!! \section arg_table_rrtmg_lw_run Argument Table +!! \htmlinclude rrtmg_lw_run.html +!! +!> \section gen_lwrad RRTMG Longwave Radiation Scheme General Algorithm +!> @{ + subroutine rrtmg_lw_run & + & ( plyr,plvl,tlyr,tlvl,qlyr,olyr,gasvmr_co2, gasvmr_n2o, & ! --- inputs + & gasvmr_ch4, gasvmr_o2, gasvmr_co, gasvmr_cfc11, & + & gasvmr_cfc12, gasvmr_cfc22, gasvmr_ccl4, & + & icseed,aeraod,aerssa,sfemis,sfgtmp, & + & dzlyr,delpin,de_lgth, iovrlw, isubclw, & + & npts, nlay, nlp1, lprnt, cld_cf, lslwr, & + & hlwc,topflx,sfcflx,cldtau, & ! --- outputs + & HLW0,HLWB,FLXPRF, & ! --- optional + & cld_lwp, cld_ref_liq, cld_iwp, cld_ref_ice, & + & cld_rwp,cld_ref_rain, cld_swp, cld_ref_snow, & + & cld_od, mpirank,mpiroot,errmsg, errflg & + & ) + +! ==================== defination of variables ==================== ! +! ! +! input variables: ! +! plyr (npts,nlay) : layer mean pressures (mb) ! +! plvl (npts,nlp1) : interface pressures (mb) ! +! tlyr (npts,nlay) : layer mean temperature (k) ! +! tlvl (npts,nlp1) : interface temperatures (k) ! +! qlyr (npts,nlay) : layer specific humidity (gm/gm) *see inside ! +! olyr (npts,nlay) : layer ozone concentration (gm/gm) *see inside ! +! gasvmr(npts,nlay,:): atmospheric gases amount: ! +! (check module_radiation_gases for definition) ! +! gasvmr(:,:,1) - co2 volume mixing ratio ! +! gasvmr(:,:,2) - n2o volume mixing ratio ! +! gasvmr(:,:,3) - ch4 volume mixing ratio ! +! gasvmr(:,:,4) - o2 volume mixing ratio ! +! gasvmr(:,:,5) - co volume mixing ratio ! +! gasvmr(:,:,6) - cfc11 volume mixing ratio ! +! gasvmr(:,:,7) - cfc12 volume mixing ratio ! +! gasvmr(:,:,8) - cfc22 volume mixing ratio ! +! gasvmr(:,:,9) - ccl4 volume mixing ratio ! +! clouds(npts,nlay,:): layer cloud profiles: ! +! (check module_radiation_clouds for definition) ! +! clouds(:,:,1) - layer total cloud fraction ! +! clouds(:,:,2) - layer in-cloud liq water path (g/m**2) ! +! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! +! clouds(:,:,4) - layer in-cloud ice water path (g/m**2) ! +! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! +! clouds(:,:,6) - layer rain drop water path (g/m**2) ! +! clouds(:,:,7) - mean eff radius for rain drop (micron) ! +! clouds(:,:,8) - layer snow flake water path (g/m**2) ! +! clouds(:,:,9) - mean eff radius for snow flake (micron) ! +! icseed(npts) : auxiliary special cloud related array ! +! when module variable isubclw=2, it provides ! +! permutation seed for each column profile that ! +! are used for generating random numbers. ! +! when isubclw /=2, it will not be used. ! +! aerosols(npts,nlay,nbands,:) : aerosol optical properties ! +! (check module_radiation_aerosols for definition)! +! (:,:,:,1) - optical depth ! +! (:,:,:,2) - single scattering albedo ! +! (:,:,:,3) - asymmetry parameter ! +! sfemis (npts) : surface emissivity ! +! sfgtmp (npts) : surface ground temperature (k) ! +! dzlyr(npts,nlay) : layer thickness (km) ! +! delpin(npts,nlay): layer pressure thickness (mb) ! +! de_lgth(npts) : cloud decorrelation length (km) ! +! npts : total number of horizontal points ! +! nlay, nlp1 : total number of vertical layers, levels ! +! lprnt : cntl flag for diagnostic print out ! +! ! +! output variables: ! +! hlwc (npts,nlay): total sky heating rate (k/day or k/sec) ! +! topflx(npts) : radiation fluxes at top, component: ! +! (check module_radlw_paramters for definition) ! +! upfxc - total sky upward flux at top (w/m2) ! +! upfx0 - clear sky upward flux at top (w/m2) ! +! sfcflx(npts) : radiation fluxes at sfc, component: ! +! (check module_radlw_paramters for definition) ! +! upfxc - total sky upward flux at sfc (w/m2) ! +! upfx0 - clear sky upward flux at sfc (w/m2) ! +! dnfxc - total sky downward flux at sfc (w/m2) ! +! dnfx0 - clear sky downward flux at sfc (w/m2) ! +! cldtau(npts,nlay): approx 10mu band layer cloud optical depth ! +! ! +!! optional output variables: ! +! hlwb(npts,nlay,nbands): spectral band total sky heating rates ! +! hlw0 (npts,nlay): clear sky heating rate (k/day or k/sec) ! +! flxprf(npts,nlp1): level radiative fluxes (w/m2), components: ! +! (check module_radlw_paramters for definition) ! +! upfxc - total sky upward flux ! +! dnfxc - total sky dnward flux ! +! upfx0 - clear sky upward flux ! +! dnfx0 - clear sky dnward flux ! +! ! +! external module variables: (in physparam) ! +! ilwrgas - control flag for rare gases (ch4,n2o,o2,cfcs, etc.) ! +! =0: do not include rare gases ! +! >0: include all rare gases ! +! ilwcliq - control flag for liq-cloud optical properties ! +! =1: input cld liqp & reliq, hu & stamnes (1993) ! +! =2: not used ! +! ilwcice - control flag for ice-cloud optical properties ! +! =1: input cld icep & reice, ebert & curry (1997) ! +! =2: input cld icep & reice, streamer (1996) ! +! =3: input cld icep & reice, fu (1998) ! +! isubclw - sub-column cloud approximation control flag ! +! =0: no sub-col cld treatment, use grid-mean cld quantities ! +! =1: mcica sub-col, prescribed seeds to get random numbers ! +! =2: mcica sub-col, providing array icseed for random numbers! +! iovrlw - cloud overlapping control flag ! +! =0: random overlapping clouds ! +! =1: maximum/random overlapping clouds ! +! =2: maximum overlap cloud (used for isubclw>0 only) ! +! =3: decorrelation-length overlap (for isubclw>0 only) ! +! =4: exponential overlap cloud +! ivflip - control flag for vertical index direction ! +! =0: vertical index from toa to surface ! +! =1: vertical index from surface to toa ! +! ! +! module parameters, control variables: ! +! nbands - number of longwave spectral bands ! +! maxgas - maximum number of absorbing gaseous ! +! maxxsec - maximum number of cross-sections ! +! ngptlw - total number of g-point subintervals ! +! ng## - number of g-points in band (##=1-16) ! +! ngb(ngptlw) - band indices for each g-point ! +! bpade - pade approximation constant (1/0.278) ! +! nspa,nspb(nbands)- number of lower/upper ref atm's per band ! +! delwave(nbands) - longwave band width (wavenumbers) ! +! ipsdlw0 - permutation seed for mcica sub-col clds ! +! ! +! major local variables: ! +! pavel (nlay) - layer pressures (mb) ! +! delp (nlay) - layer pressure thickness (mb) ! +! tavel (nlay) - layer temperatures (k) ! +! tz (0:nlay) - level (interface) temperatures (k) ! +! semiss (nbands) - surface emissivity for each band ! +! wx (nlay,maxxsec) - cross-section molecules concentration ! +! coldry (nlay) - dry air column amount ! +! (1.e-20*molecules/cm**2) ! +! cldfrc (0:nlp1) - layer cloud fraction ! +! taucld (nbands,nlay) - layer cloud optical depth for each band ! +! cldfmc (ngptlw,nlay) - layer cloud fraction for each g-point ! +! tauaer (nbands,nlay) - aerosol optical depths ! +! fracs (ngptlw,nlay) - planck fractions ! +! tautot (ngptlw,nlay) - total optical depths (gaseous+aerosols) ! +! colamt (nlay,maxgas) - column amounts of absorbing gases ! +! 1-maxgas are for watervapor, carbon ! +! dioxide, ozone, nitrous oxide, methane, ! +! oxigen, carbon monoxide, respectively ! +! (molecules/cm**2) ! +! pwvcm - column precipitable water vapor (cm) ! +! secdiff(nbands) - variable diffusivity angle defined as ! +! an exponential function of the column ! +! water amount in bands 2-3 and 5-9. ! +! this reduces the bias of several w/m2 in ! +! downward surface flux in high water ! +! profiles caused by using the constant ! +! diffusivity angle of 1.66. (mji) ! +! facij (nlay) - indicator of interpolation factors ! +! =0/1: indicate lower/higher temp & height ! +! selffac(nlay) - scale factor for self-continuum, equals ! +! (w.v. density)/(atm density at 296K,1013 mb) ! +! selffrac(nlay) - factor for temp interpolation of ref ! +! self-continuum data ! +! indself(nlay) - index of the lower two appropriate ref ! +! temp for the self-continuum interpolation ! +! forfac (nlay) - scale factor for w.v. foreign-continuum ! +! forfrac(nlay) - factor for temp interpolation of ref ! +! w.v. foreign-continuum data ! +! indfor (nlay) - index of the lower two appropriate ref ! +! temp for the foreign-continuum interp ! +! laytrop - tropopause layer index at which switch is ! +! made from one conbination kew species to ! +! another. ! +! jp(nlay),jt(nlay),jt1(nlay) ! +! - lookup table indexes ! +! totuflux(0:nlay) - total-sky upward longwave flux (w/m2) ! +! totdflux(0:nlay) - total-sky downward longwave flux (w/m2) ! +! htr(nlay) - total-sky heating rate (k/day or k/sec) ! +! totuclfl(0:nlay) - clear-sky upward longwave flux (w/m2) ! +! totdclfl(0:nlay) - clear-sky downward longwave flux (w/m2) ! +! htrcl(nlay) - clear-sky heating rate (k/day or k/sec) ! +! fnet (0:nlay) - net longwave flux (w/m2) ! +! fnetc (0:nlay) - clear-sky net longwave flux (w/m2) ! +! ! +! ! +! ====================== end of definitions =================== ! + +! --- inputs: + integer, intent(in) :: npts, nlay, nlp1 + integer, intent(in) :: icseed(npts) + + logical, intent(in) :: lprnt + integer, intent(in) :: mpiroot + integer, intent(in) :: mpirank + integer, intent(in) :: iovrlw,isubclw + + real (kind=kind_phys), dimension(npts,nlp1), intent(in) :: plvl, & + & tlvl + real (kind=kind_phys), dimension(npts,nlay), intent(in) :: plyr, & + & tlyr, qlyr, olyr, dzlyr, delpin + + real (kind=kind_phys),dimension(npts,nlay),intent(in)::gasvmr_co2,& + & gasvmr_n2o, gasvmr_ch4, gasvmr_o2, gasvmr_co, gasvmr_cfc11, & + & gasvmr_cfc12, gasvmr_cfc22, gasvmr_ccl4 + + real (kind=kind_phys), dimension(npts,nlay),intent(in):: cld_cf + real (kind=kind_phys), dimension(npts,nlay),intent(in),optional:: & + & cld_lwp, cld_ref_liq, cld_iwp, cld_ref_ice, & + & cld_rwp, cld_ref_rain, cld_swp, cld_ref_snow, & + & cld_od + + real (kind=kind_phys), dimension(npts), intent(in) :: sfemis, & + & sfgtmp, de_lgth + + real (kind=kind_phys), dimension(npts,nlay,nbands),intent(in):: & + & aeraod, aerssa + +!mz* HWRF -- OUTPUT from mcica_subcol_lw + real(kind=kind_phys),dimension(ngptlw,npts,nlay) :: cldfmcl ! Cloud fraction + ! Dimensions: (ngptlw,ncol,nlay) + real(kind=kind_phys),dimension(ngptlw,npts,nlay) :: ciwpmcl ! In-cloud ice water path (g/m2) + ! Dimensions: (ngptlw,ncol,nlay) + real(kind=kind_phys),dimension(ngptlw,npts,nlay) :: clwpmcl ! In-cloud liquid water path (g/m2) + ! Dimensions: (ngptlw,ncol,nlay) + real(kind=kind_phys),dimension(ngptlw,npts,nlay) :: cswpmcl ! In-cloud snow water path (g/m2) + ! Dimensions: (ngptlw,ncol,nlay) + real(kind=kind_phys),dimension(npts,nlay) :: relqmcl ! Cloud water drop effective radius (microns) + ! Dimensions: (ncol,nlay) + real(kind=kind_phys),dimension(npts,nlay) :: reicmcl ! Cloud ice effective size (microns) + ! Dimensions: (ncol,nlay) + real(kind=kind_phys),dimension(npts,nlay) :: resnmcl ! Snow effective size (microns) + ! Dimensions: (ncol,nlay) + real(kind=kind_phys),dimension(ngptlw,npts,nlay) :: taucmcl ! In-cloud optical depth + ! Dimensions: (ngptlw,ncol,nlay) +! real(kind=kind_phys),dimension(npts,nlay,nbands) :: tauaer ! Aerosol optical depth +! ! Dimensions: (ncol,nlay,nbndlw) +!mz* output from cldprmc + integer :: ncbands ! number of cloud spectral bands + real(kind=kind_phys),dimension(ngptlw,nlay) :: taucmc ! cloud optical depth [mcica] + ! Dimensions: (ngptlw,nlayers) +!mz + +! --- outputs: + real (kind=kind_phys), dimension(npts,nlay), intent(inout) :: hlwc + real (kind=kind_phys), dimension(npts,nlay), intent(inout) :: & + & cldtau + + type (topflw_type), dimension(npts), intent(inout) :: topflx + type (sfcflw_type), dimension(npts), intent(inout) :: sfcflx + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +!! --- optional outputs: + real (kind=kind_phys), dimension(npts,nlay,nbands),optional, & + & intent(inout) :: hlwb + real (kind=kind_phys), dimension(npts,nlay), optional, & + & intent(inout) :: hlw0 + type (proflw_type), dimension(npts,nlp1), optional, & + & intent(inout) :: flxprf + logical, intent(in) :: lslwr + +! --- locals: +! mz* - Add height of each layer for exponential-random cloud overlap +! This will be derived below from the dzlyr in each layer + real (kind=kind_phys), dimension( npts,nlay ) :: hgt + real (kind=kind_phys):: dzsum + + real (kind=kind_phys), dimension(0:nlp1) :: cldfrc + + real (kind=kind_phys), dimension(0:nlay) :: totuflux, totdflux, & + & totuclfl, totdclfl, tz + + real (kind=kind_phys), dimension(nlay) :: htr, htrcl + + real (kind=kind_phys), dimension(nlay) :: pavel, tavel, delp, & + & clwp, ciwp, relw, reiw, cda1, cda2, cda3, cda4, & + & coldry, colbrd, h2ovmr, o3vmr, fac00, fac01, fac10, fac11, & + & selffac, selffrac, forfac, forfrac, minorfrac, scaleminor, & + & scaleminorn2, temcol, dz + +!mz* + real(kind=rb),dimension(0:nlay,nbands) :: planklay,planklev + real(kind=rb),dimension(0:nlay) :: pz + +! real(kind=rb) :: plankbnd(nbndlw) + real (kind=kind_phys), dimension(nbands,0:nlay) :: pklev, pklay + + real (kind=kind_phys), dimension(nlay,nbands) :: htrb + real (kind=kind_phys), dimension(nbands,nlay) :: taucld, tauaer + real (kind=kind_phys), dimension(nbands,1,nlay) :: taucld3 + real (kind=kind_phys), dimension(ngptlw,nlay) :: fracs, tautot + real (kind=kind_phys), dimension(nlay,ngptlw) :: fracs_r +!mz rtrnmc_mcica + real (kind=kind_phys), dimension(nlay,ngptlw) :: taut +!mz* Atmosphere/clouds - cldprop + real(kind=kind_phys), dimension(ngptlw,nlay) :: cldfmc, & + & cldfmc_save ! cloud fraction [mcica] + ! Dimensions: (ngptlw,nlay) + real(kind=kind_phys), dimension(ngptlw,nlay) :: ciwpmc ! in-cloud ice water path [mcica] + ! Dimensions: (ngptlw,nlay) + real(kind=kind_phys), dimension(ngptlw,nlay) :: clwpmc ! in-cloud liquid water path [mcica] + ! Dimensions: (ngptlw,nlay) + real(kind=kind_phys), dimension(ngptlw,nlay) :: cswpmc ! in-cloud snow path [mcica] + ! Dimensions: (ngptlw,nlay) + real(kind=kind_phys), dimension(nlay) :: relqmc ! liquid particle effective radius (microns) + ! Dimensions: (nlay) + real(kind=kind_phys), dimension(nlay) :: reicmc ! ice particle effective size (microns) + ! Dimensions: (nlay) + real(kind=kind_phys), dimension(nlay) :: resnmc ! snow effective size (microns) + ! Dimensions: (nlay) + + + real (kind=kind_phys), dimension(nbands) :: semiss, secdiff + +! --- column amount of absorbing gases: +! (:,m) m = 1-h2o, 2-co2, 3-o3, 4-n2o, 5-ch4, 6-o2, 7-co + real (kind=kind_phys) :: colamt(nlay,maxgas) + +! --- column cfc cross-section amounts: +! (:,m) m = 1-ccl4, 2-cfc11, 3-cfc12, 4-cfc22 + real (kind=kind_phys) :: wx(nlay,maxxsec) + +! --- reference ratios of binary species parameter in lower atmosphere: +! (:,m,:) m = 1-h2o/co2, 2-h2o/o3, 3-h2o/n2o, 4-h2o/ch4, 5-n2o/co2, 6-o3/co2 + real (kind=kind_phys) :: rfrate(nlay,nrates,2) + + real (kind=kind_phys) :: tem0, tem1, tem2, pwvcm, summol, stemp, & + & delgth + + integer, dimension(npts) :: ipseed + integer, dimension(nlay) :: jp, jt, jt1, indself, indfor, indminor + integer :: laytrop, iplon, i, j, k, k1 + ! mz* added local arrays for RRTMG + integer :: irng, permuteseed,ig + integer :: inflglw, iceflglw, liqflglw + logical :: lcf1 + integer :: istart ! beginning band of calculation + integer :: iend ! ending band of calculation + integer :: iout ! output option flag (inactive) + + +! +!===> ... begin here +! + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + +!mz* +! For passing in cloud physical properties; cloud optics parameterized +! in RRTMG: + inflglw = 2 + iceflglw = 3 + liqflglw = 1 + + istart = 1 + iend = 16 + iout = 0 + +! + if (.not. lslwr) return + +! --- ... initialization + + lhlwb = present ( hlwb ) + lhlw0 = present ( hlw0 ) + lflxprf= present ( flxprf ) + + colamt(:,:) = f_zero + cldtau(:,:) = f_zero + +!! --- check for optional input arguments, depending on cloud method + if (ilwcliq > 0) then ! use prognostic cloud method + if ( .not.present(cld_lwp) .or. .not.present(cld_ref_liq) .or. & + & .not.present(cld_iwp) .or. .not.present(cld_ref_ice) .or. & + & .not.present(cld_rwp) .or. .not.present(cld_ref_rain) .or. & + & .not.present(cld_swp) .or. .not.present(cld_ref_snow)) then + write(errmsg,'(*(a))') & + & 'Logic error: ilwcliq>0 requires the following', & + & ' optional arguments to be present:', & + & ' cld_lwp, cld_ref_liq, cld_iwp, cld_ref_ice,', & + & ' cld_rwp, cld_ref_rain, cld_swp, cld_ref_snow' + errflg = 1 + return + end if + else ! use diagnostic cloud method + if ( .not.present(cld_od) ) then + write(errmsg,'(*(a))') & + & 'Logic error: ilwcliq<=0 requires the following', & + & ' optional argument to be present: cld_od' + errflg = 1 + return + end if + endif ! end if_ilwcliq + +!> -# Change random number seed value for each radiation invocation +!! (isubclw =1 or 2). + + if ( isubclw == 1 ) then ! advance prescribed permutation seed + do i = 1, npts + ipseed(i) = ipsdlw0 + i + enddo + elseif ( isubclw == 2 ) then ! use input array of permutaion seeds + do i = 1, npts + ipseed(i) = icseed(i) + enddo + endif + +! if ( lprnt ) then +! print *,' In rrtmg_lw, isubclw, ipsdlw0,ipseed =', & +! & isubclw, ipsdlw0, ipseed +! endif + +! --- ... loop over horizontal npts profiles + + lab_do_iplon : do iplon = 1, npts + +!> -# Read surface emissivity. + if (sfemis(iplon) > eps .and. sfemis(iplon) <= 1.0) then ! input surface emissivity + do j = 1, nbands + semiss(j) = sfemis(iplon) + enddo + else ! use default values + do j = 1, nbands + semiss(j) = semiss0(j) + enddo + endif + + stemp = sfgtmp(iplon) ! surface ground temp + if (iovrlw == 3) delgth= de_lgth(iplon) ! clouds decorr-length + +! mz*: HWRF practice + if (iovrlw == 4 ) then + +!Add layer height needed for exponential (icld=4) and +! exponential-random (icld=5) overlap options + + !iplon = 1 + irng = 0 + permuteseed = 150 + +!mz* Derive height + dzsum =0.0 + do k = 1,nlay + hgt(iplon,k)= dzsum+0.5*dzlyr(iplon,k)*1000. !km->m + dzsum = dzsum+ dzlyr(iplon,k)*1000. + enddo + +! Zero out cloud optical properties here; not used when passing physical properties +! to radiation and taucld is calculated in radiation + do k = 1, nlay + do j = 1, nbands + taucld3(j,iplon,k) = 0.0 + enddo + enddo + + +! if(mpirank==mpiroot) then +! write(0,*) 'mcica_subcol_lw: max/min(cld_cf)=', & +! & maxval(cld_cf),minval(cld_cf) +! write(0,*) 'mcica_subcol_lw: max/min(cld_iwp)=', & +! & maxval(cld_iwp),minval(cld_iwp) +! write(0,*) 'mcica_subcol_lw: max/min(cld_lwp)=', & +! & maxval(cld_lwp),minval(cld_lwp) +! write(0,*) 'mcica_subcol_lw: max/min(cld_swp)=', & +! & maxval(cld_swp),minval(cld_swp) +! write(0,*) 'mcica_subcol_lw: max/min(cld_ref_ice)=', & +! & maxval(cld_ref_ice),minval(cld_ref_ice) +! write(0,*) 'mcica_subcol_lw: max/min(cld_ref_snow)=', & +! & maxval(cld_ref_snow),minval(cld_ref_snow) +! write(0,*) 'mcica_subcol_lw: max/min(cld_ref_liq)=', & +! & maxval(cld_ref_liq),minval(cld_ref_liq) + +! endif + + call mcica_subcol_lw(1, iplon, nlay, iovrlw, permuteseed, & + & irng, plyr, hgt, & + & cld_cf, cld_iwp, cld_lwp,cld_swp, & + & cld_ref_ice, cld_ref_liq, & + & cld_ref_snow, taucld3, & + & cldfmcl, & !--output + & ciwpmcl, clwpmcl, cswpmcl, reicmcl, relqmcl, & + & resnmcl, taucmcl) + +!mz +! if(mpirank==mpiroot) then +! write(0,*) 'mcica_subcol_lw: max/min(cldfmcl)=', & +! & maxval(cldfmcl),minval(cldfmcl) +! write(0,*) 'mcica_subcol_lw: max/min(ciwpmcl)=', & +! & maxval(ciwpmcl),minval(ciwpmcl) +! write(0,*) 'mcica_subcol_lw: max/min(clwpmcl)=', & +! & maxval(clwpmcl),minval(clwpmcl) +! write(0,*) 'mcica_subcol_lw: max/min(cswpmcl)=', & +! & maxval(cswpmcl),minval(cswpmcl) +! write(0,*) 'mcica_subcol_lw: max/min(reicmcl)=', & +! & maxval(reicmcl),minval(reicmcl) +! write(0,*) 'mcica_subcol_lw: max/min(relqmcl)=', & +! & maxval(relqmcl),minval(relqmcl) +! write(0,*) 'mcica_subcol_lw: max/min(resnmcl)=', & +! & maxval(resnmcl),minval(resnmcl) +! write(0,*) 'mcica_subcol_lw: max/min(taucmcl)=', & +! & maxval(taucmcl),minval(taucmcl) + +! endif + endif +!mz* end + +!> -# Prepare atmospheric profile for use in rrtm. +! the vertical index of internal array is from surface to top + +! --- ... molecular amounts are input or converted to volume mixing ratio +! and later then converted to molecular amount (molec/cm2) by the +! dry air column coldry (in molec/cm2) which is calculated from the +! layer pressure thickness (in mb), based on the hydrostatic equation +! --- ... and includes a correction to account for h2o in the layer. + + if (ivflip == 0) then ! input from toa to sfc + + tem1 = 100.0 * con_g + tem2 = 1.0e-20 * 1.0e3 * con_avgd + tz(0) = tlvl(iplon,nlp1) + + do k = 1, nlay + k1 = nlp1 - k + pavel(k)= plyr(iplon,k1) + delp(k) = delpin(iplon,k1) + tavel(k)= tlyr(iplon,k1) + tz(k) = tlvl(iplon,k1) + dz(k) = dzlyr(iplon,k1) + +!> -# Set absorber amount for h2o, co2, and o3. + +!test use +! h2ovmr(k)= max(f_zero,qlyr(iplon,k1)*amdw) ! input mass mixing ratio +! h2ovmr(k)= max(f_zero,qlyr(iplon,k1)) ! input vol mixing ratio +! o3vmr (k)= max(f_zero,olyr(iplon,k1)) ! input vol mixing ratio +!ncep model use + h2ovmr(k)= max(f_zero,qlyr(iplon,k1) & + & *amdw/(f_one-qlyr(iplon,k1))) ! input specific humidity + o3vmr (k)= max(f_zero,olyr(iplon,k1)*amdo3) ! input mass mixing ratio + +! --- ... tem0 is the molecular weight of moist air + tem0 = (f_one - h2ovmr(k))*con_amd + h2ovmr(k)*con_amw + coldry(k) = tem2*delp(k) / (tem1*tem0*(f_one+h2ovmr(k))) + temcol(k) = 1.0e-12 * coldry(k) + + colamt(k,1) = max(f_zero, coldry(k)*h2ovmr(k)) ! h2o + colamt(k,2) = max(temcol(k), coldry(k)*gasvmr_co2(iplon,k1)) ! co2 + colamt(k,3) = max(temcol(k), coldry(k)*o3vmr(k)) ! o3 + enddo + +!> -# Set up column amount for rare gases n2o,ch4,o2,co,ccl4,cf11,cf12, +!! cf22, convert from volume mixing ratio to molec/cm2 based on +!! coldry (scaled to 1.0e-20). + + if (ilwrgas > 0) then + do k = 1, nlay + k1 = nlp1 - k + colamt(k,4)=max(temcol(k), coldry(k)*gasvmr_n2o(iplon,k1)) ! n2o + colamt(k,5)=max(temcol(k), coldry(k)*gasvmr_ch4(iplon,k1)) ! ch4 + colamt(k,6)=max(f_zero, coldry(k)*gasvmr_o2(iplon,k1)) ! o2 + colamt(k,7)=max(f_zero, coldry(k)*gasvmr_co(iplon,k1)) ! co + + wx(k,1) = max( f_zero, coldry(k)*gasvmr_ccl4(iplon,k1) ) ! ccl4 + wx(k,2) = max( f_zero, coldry(k)*gasvmr_cfc11(iplon,k1) ) ! cf11 + wx(k,3) = max( f_zero, coldry(k)*gasvmr_cfc12(iplon,k1) ) ! cf12 + wx(k,4) = max( f_zero, coldry(k)*gasvmr_cfc22(iplon,k1) ) ! cf22 + enddo + else + do k = 1, nlay + colamt(k,4) = f_zero ! n2o + colamt(k,5) = f_zero ! ch4 + colamt(k,6) = f_zero ! o2 + colamt(k,7) = f_zero ! co + + wx(k,1) = f_zero + wx(k,2) = f_zero + wx(k,3) = f_zero + wx(k,4) = f_zero + enddo + endif + +!> -# Set aerosol optical properties. + + do k = 1, nlay + k1 = nlp1 - k + do j = 1, nbands + tauaer(j,k) = aeraod(iplon,k1,j) & + & * (f_one - aerssa(iplon,k1,j)) + enddo + enddo + +!> -# Read cloud optical properties. + if (ilwcliq > 0) then ! use prognostic cloud method +!mz: GFS operational + do k = 1, nlay + k1 = nlp1 - k + cldfrc(k)= cld_cf(iplon,k1) + clwp(k) = cld_lwp(iplon,k1) + relw(k) = cld_ref_liq(iplon,k1) + ciwp(k) = cld_iwp(iplon,k1) + reiw(k) = cld_ref_ice(iplon,k1) + cda1(k) = cld_rwp(iplon,k1) + cda2(k) = cld_ref_rain(iplon,k1) + cda3(k) = cld_swp(iplon,k1) + cda4(k) = cld_ref_snow(iplon,k1) + enddo + ! transfer + if (iovrlw .eq. 4) then !mz HWRF + do k = 1, nlay + k1 = nlp1 - k + do ig = 1, ngptlw + cldfmc(ig,k) = cldfmcl(ig,iplon,k1) + taucmc(ig,k) = taucmcl(ig,iplon,k1) + ciwpmc(ig,k) = ciwpmcl(ig,iplon,k1) + clwpmc(ig,k) = clwpmcl(ig,iplon,k1) + !mz cswpmc(ig,k) = cswpmcl(ig,iplon,k1) + cswpmc(ig,k) = 0.0 + enddo + reicmc(k) = reicmcl(iplon,k1) + relqmc(k) = relqmcl(iplon,k1) + resnmc(k) = resnmcl(iplon,k1) + enddo + endif + else ! use diagnostic cloud method + do k = 1, nlay + k1 = nlp1 - k + cldfrc(k)= cld_cf(iplon,k1) + cda1(k) = cld_od(iplon,k1) + enddo + endif ! end if_ilwcliq + + cldfrc(0) = f_one ! padding value only + cldfrc(nlp1) = f_zero ! padding value only + +!> -# Compute precipitable water vapor for diffusivity angle adjustments. + + tem1 = f_zero + tem2 = f_zero + do k = 1, nlay + tem1 = tem1 + coldry(k) + colamt(k,1) + tem2 = tem2 + colamt(k,1) + enddo + + tem0 = 10.0 * tem2 / (amdw * tem1 * con_g) + pwvcm = tem0 * plvl(iplon,nlp1) + + else ! input from sfc to toa + + tem1 = 100.0 * con_g + tem2 = 1.0e-20 * 1.0e3 * con_avgd + tz(0) = tlvl(iplon,1) + + do k = 1, nlay + pavel(k)= plyr(iplon,k) + delp(k) = delpin(iplon,k) + tavel(k)= tlyr(iplon,k) + tz(k) = tlvl(iplon,k+1) + dz(k) = dzlyr(iplon,k) + +! --- ... set absorber amount +!test use +! h2ovmr(k)= max(f_zero,qlyr(iplon,k)*amdw) ! input mass mixing ratio +! h2ovmr(k)= max(f_zero,qlyr(iplon,k)) ! input vol mixing ratio +! o3vmr (k)= max(f_zero,olyr(iplon,k)) ! input vol mixing ratio +!ncep model use + h2ovmr(k)= max(f_zero,qlyr(iplon,k) & + & *amdw/(f_one-qlyr(iplon,k))) ! input specific humidity + o3vmr (k)= max(f_zero,olyr(iplon,k)*amdo3) ! input mass mixing ratio + +! --- ... tem0 is the molecular weight of moist air + tem0 = (f_one - h2ovmr(k))*con_amd + h2ovmr(k)*con_amw + coldry(k) = tem2*delp(k) / (tem1*tem0*(f_one+h2ovmr(k))) + temcol(k) = 1.0e-12 * coldry(k) + + colamt(k,1) = max(f_zero, coldry(k)*h2ovmr(k)) ! h2o + colamt(k,2) = max(temcol(k), coldry(k)*gasvmr_co2(iplon,k))! co2 + colamt(k,3) = max(temcol(k), coldry(k)*o3vmr(k)) ! o3 + enddo + +! --- ... set up col amount for rare gases, convert from volume mixing ratio +! to molec/cm2 based on coldry (scaled to 1.0e-20) + + if (ilwrgas > 0) then + do k = 1, nlay + colamt(k,4)=max(temcol(k), coldry(k)*gasvmr_n2o(iplon,k)) ! n2o + colamt(k,5)=max(temcol(k), coldry(k)*gasvmr_ch4(iplon,k)) ! ch4 + colamt(k,6)=max(f_zero, coldry(k)*gasvmr_o2(iplon,k)) ! o2 + colamt(k,7)=max(f_zero, coldry(k)*gasvmr_co(iplon,k)) ! co + + wx(k,1) = max( f_zero, coldry(k)*gasvmr_ccl4(iplon,k) ) ! ccl4 + wx(k,2) = max( f_zero, coldry(k)*gasvmr_cfc11(iplon,k) ) ! cf11 + wx(k,3) = max( f_zero, coldry(k)*gasvmr_cfc12(iplon,k) ) ! cf12 + wx(k,4) = max( f_zero, coldry(k)*gasvmr_cfc22(iplon,k) ) ! cf22 + enddo + else + do k = 1, nlay + colamt(k,4) = f_zero ! n2o + colamt(k,5) = f_zero ! ch4 + colamt(k,6) = f_zero ! o2 + colamt(k,7) = f_zero ! co + + wx(k,1) = f_zero + wx(k,2) = f_zero + wx(k,3) = f_zero + wx(k,4) = f_zero + enddo + endif + +! --- ... set aerosol optical properties + + do j = 1, nbands + do k = 1, nlay + tauaer(j,k) = aeraod(iplon,k,j) & + & * (f_one - aerssa(iplon,k,j)) + enddo + enddo + + if (ilwcliq > 0) then ! use prognostic cloud method +!mz* + !mz calculate input for cldprop + do k = 1, nlay + cldfrc(k)= cld_cf(iplon,k) + clwp(k) = cld_lwp(iplon,k) + relw(k) = cld_ref_liq(iplon,k) + ciwp(k) = cld_iwp(iplon,k) + reiw(k) = cld_ref_ice(iplon,k) + cda1(k) = cld_rwp(iplon,k) + cda2(k) = cld_ref_rain(iplon,k) + cda3(k) = cld_swp(iplon,k) + cda4(k) = cld_ref_snow(iplon,k) + enddo + if (iovrlw .eq. 4) then +!mz* Move incoming GCM cloud arrays to RRTMG cloud arrays. +!For GCM input, incoming reicmcl is defined based on selected +!ice parameterization (inflglw) + do k = 1, nlay + do ig = 1, ngptlw + cldfmc(ig,k) = cldfmcl(ig,iplon,k) + taucmc(ig,k) = taucmcl(ig,iplon,k) + ciwpmc(ig,k) = ciwpmcl(ig,iplon,k) + clwpmc(ig,k) = clwpmcl(ig,iplon,k) + !mz cswpmc(ig,k) = cswpmcl(ig,iplon,k) + cswpmc(ig,k) = 0.0 + enddo + reicmc(k) = reicmcl(iplon,k) + relqmc(k) = relqmcl(iplon,k) + resnmc(k) = resnmcl(iplon,k) + enddo + endif + else ! use diagnostic cloud method + do k = 1, nlay + cldfrc(k)= cld_cf(iplon,k) + cda1(k) = cld_od(iplon,k) + enddo + endif ! end if_ilwcliq + + cldfrc(0) = f_one ! padding value only + cldfrc(nlp1) = f_zero ! padding value only + +! --- ... compute precipitable water vapor for diffusivity angle adjustments + + tem1 = f_zero + tem2 = f_zero + do k = 1, nlay + tem1 = tem1 + coldry(k) + colamt(k,1) + tem2 = tem2 + colamt(k,1) + enddo + + tem0 = 10.0 * tem2 / (amdw * tem1 * con_g) + pwvcm = tem0 * plvl(iplon,1) + + endif ! if_ivflip + +!> -# Compute column amount for broadening gases. + + do k = 1, nlay + summol = f_zero + do i = 2, maxgas + summol = summol + colamt(k,i) + enddo + colbrd(k) = coldry(k) - summol + enddo + +!> -# Compute diffusivity angle adjustments. + + tem1 = 1.80 + tem2 = 1.50 + do j = 1, nbands + if (j==1 .or. j==4 .or. j==10) then + secdiff(j) = 1.66 + else + secdiff(j) = min( tem1, max( tem2, & + & a0(j)+a1(j)*exp(a2(j)*pwvcm) )) + endif + enddo + +! if (lprnt) then +! print *,' coldry',coldry +! print *,' wx(*,1) ',(wx(k,1),k=1,NLAY) +! print *,' wx(*,2) ',(wx(k,2),k=1,NLAY) +! print *,' wx(*,3) ',(wx(k,3),k=1,NLAY) +! print *,' wx(*,4) ',(wx(k,4),k=1,NLAY) +! print *,' iplon ',iplon +! print *,' pavel ',pavel +! print *,' delp ',delp +! print *,' tavel ',tavel +! print *,' tz ',tz +! print *,' h2ovmr ',h2ovmr +! print *,' o3vmr ',o3vmr +! endif + +!> -# For cloudy atmosphere, call cldprop() to set cloud optical +!! properties. + + lcf1 = .false. + lab_do_k0 : do k = 1, nlay + if ( cldfrc(k) > eps ) then + lcf1 = .true. + exit lab_do_k0 + endif + enddo lab_do_k0 + + if ( lcf1 ) then + + !mz* for HWRF, save cldfmc with mcica + if (iovrlw .eq.4) then + do k = 1, nlay + do ig = 1, ngptlw + cldfmc_save(ig,k)=cldfmc (ig,k) + enddo + enddo + endif + + call cldprop & +! --- inputs: + & ( cldfrc,clwp,relw,ciwp,reiw,cda1,cda2,cda3,cda4, & + & nlay, nlp1, ipseed(iplon), dz, delgth,iovrlw, isubclw, & +! --- outputs: + & cldfmc, taucld & + & ) + + if (iovrlw .eq.4) then + !mz for HWRF, still using mcica cldfmc + do k = 1, nlay + do ig = 1, ngptlw + cldfmc(ig,k)=cldfmc_save(ig,k) + enddo + enddo + endif + +! --- ... save computed layer cloud optical depth for output +! rrtm band-7 is apprx 10mu channel (or use spectral mean of bands 6-8) + + if (ivflip == 0) then ! input from toa to sfc + do k = 1, nlay + k1 = nlp1 - k + cldtau(iplon,k1) = taucld( 7,k) + enddo + else ! input from sfc to toa + do k = 1, nlay + cldtau(iplon,k) = taucld( 7,k) + enddo + endif ! end if_ivflip_block + + else + cldfmc = f_zero + taucld = f_zero + endif + +!!mz* HWRF practice, calculate taucmc with mcica + if (iovrlw .eq.4) then + !mz* HWRF practice, calculate taucmc +! if(mpirank==mpiroot) then +! write(0,*) 'bfe cldprmc: nlay,inflglw,iceflglw,liqflglw',& +! & nlay,inflglw,iceflglw,liqflglw +! write(0,*) 'bfe cldprmc: max/min(taucmc)=', & +! & maxval(taucmc),minval(taucmc) +! endif + + call cldprmc(nlay, inflglw, iceflglw, liqflglw, & + & cldfmc, ciwpmc, & + & clwpmc, cswpmc, reicmc, relqmc, resnmc, & + & ncbands, taucmc) + endif +! if(mpirank==mpiroot) then +! write(0,*) 'aft cldprmc: ncbands', ncbands +! write(0,*) 'aft cldprmc: max/min(taucmc)=', & +! & maxval(taucmc),minval(taucmc) +! endif + + +!mz* end + + +! if (lprnt) then +! print *,' after cldprop' +! print *,' clwp',clwp +! print *,' ciwp',ciwp +! print *,' relw',relw +! print *,' reiw',reiw +! print *,' taucl',cda1 +! print *,' cldfrac',cldfrc +! endif + +!> -# Calling setcoef() to compute various coefficients needed in +!! radiative transfer calculations. + call setcoef & +! --- inputs: + & ( pavel,tavel,tz,stemp,h2ovmr,colamt,coldry,colbrd, & + & nlay, nlp1, & +! --- outputs: + & laytrop,pklay,pklev,jp,jt,jt1, & + & rfrate,fac00,fac01,fac10,fac11, & + & selffac,selffrac,indself,forfac,forfrac,indfor, & + & minorfrac,scaleminor,scaleminorn2,indminor & + & ) + +! if (lprnt) then +! print *,'laytrop',laytrop +! print *,'colh2o',(colamt(k,1),k=1,NLAY) +! print *,'colco2',(colamt(k,2),k=1,NLAY) +! print *,'colo3', (colamt(k,3),k=1,NLAY) +! print *,'coln2o',(colamt(k,4),k=1,NLAY) +! print *,'colch4',(colamt(k,5),k=1,NLAY) +! print *,'fac00',fac00 +! print *,'fac01',fac01 +! print *,'fac10',fac10 +! print *,'fac11',fac11 +! print *,'jp',jp +! print *,'jt',jt +! print *,'jt1',jt1 +! print *,'selffac',selffac +! print *,'selffrac',selffrac +! print *,'indself',indself +! print *,'forfac',forfac +! print *,'forfrac',forfrac +! print *,'indfor',indfor +! endif + +!> -# Call taumol() to calculte the gaseous optical depths and Plank +!! fractions for each longwave spectral band. + + call taumol & +! --- inputs: + & ( laytrop,pavel,coldry,colamt,colbrd,wx,tauaer, & + & rfrate,fac00,fac01,fac10,fac11,jp,jt,jt1, & + & selffac,selffrac,indself,forfac,forfrac,indfor, & + & minorfrac,scaleminor,scaleminorn2,indminor, & + & nlay, & +! --- outputs: + & fracs, tautot & + & ) + +! if (lprnt) then +! print *,' after taumol' +! do k = 1, nlay +! write(6,121) k +!121 format(' k =',i3,5x,'FRACS') +! write(6,122) (fracs(j,k),j=1,ngptlw) +!122 format(10e14.7) +! write(6,123) k +!123 format(' k =',i3,5x,'TAUTOT') +! write(6,122) (tautot(j,k),j=1,ngptlw) +! enddo +! endif + +!> -# Call the radiative transfer routine based on cloud scheme +!! selection. Compute the upward/downward radiative fluxes, and +!! heating rates for both clear or cloudy atmosphere. +!!\n - call rtrn(): clouds are assumed as randomly overlaping in a +!! vertical column +!!\n - call rtrnmr(): clouds are assumed as in maximum-randomly +!! overlaping in a vertical column; +!!\n - call rtrnmc(): clouds are treated with the mcica stochastic +!! approach. + + if (isubclw <= 0) then + + if (iovrlw <= 0) then + + call rtrn & +! --- inputs: + & ( semiss,delp,cldfrc,taucld,tautot,pklay,pklev, & + & fracs,secdiff,nlay,nlp1, & +! --- outputs: + & totuflux,totdflux,htr, totuclfl,totdclfl,htrcl, htrb & + & ) + + else + + call rtrnmr & +! --- inputs: + & ( semiss,delp,cldfrc,taucld,tautot,pklay,pklev, & + & fracs,secdiff,nlay,nlp1, & +! --- outputs: + & totuflux,totdflux,htr, totuclfl,totdclfl,htrcl, htrb & + & ) + + endif ! end if_iovrlw_block + + else + +! if(iovrlw == 4) then + +!mz*HWRF practice +! +! pz(0)=plyr(iplon,1) +! do k= 1,nlay +! pz(k)=plvl(iplon,k+1) +! enddo + +! do k = 0, nlay +! do j = 1, nbands +! ! taut (k,j) = tautot(j,k) +! planklay(k,j) = pklay(j,k) +! planklev(k,j) = pklev(j,k) +! enddo +! enddo + +! do k = 1, nlay +! do ig = 1, ngptlw +! fracs_r(k,ig) = fracs (ig,k) +! taut(k,ig)= tautot(ig,k) +! enddo +! enddo + +! call rtrnmc_mcica(nlay, istart, iend, iout, pz, & +! & semiss, ncbands, & +! & cldfmc, taucmc, planklay, planklev, & !plankbnd, & +! & pwvcm, fracs_r, taut, & +! & totuflux, totdflux, htr, & +! & totuclfl, totdclfl, htrcl ) + +! if(mpirank==mpiroot) then +! write(0,*) 'rtrnmc_mcica: max/min(htr)=', & +! & maxval(htr),minval(htr) +! endif + + +! else +!mz*end + +!mz*taucld(non-mcica) + call rtrnmc & +! --- inputs: + & ( semiss,delp,cldfmc,taucld,tautot,pklay,pklev, & + & fracs,secdiff,nlay,nlp1, & +! --- outputs: + & totuflux,totdflux,htr, totuclfl,totdclfl,htrcl, htrb & + & ) +! if(mpirank==mpiroot) then +! write(0,*) 'rtrnmc: max/min(htr)=', & +! & maxval(htr),minval(htr) +! endif + +! endif !end if_iovrlw block + + endif ! end if_isubclw_block + +!> -# Save outputs. + + topflx(iplon)%upfxc = totuflux(nlay) + topflx(iplon)%upfx0 = totuclfl(nlay) + + sfcflx(iplon)%upfxc = totuflux(0) + sfcflx(iplon)%upfx0 = totuclfl(0) + sfcflx(iplon)%dnfxc = totdflux(0) + sfcflx(iplon)%dnfx0 = totdclfl(0) + + if (ivflip == 0) then ! output from toa to sfc + +!! --- ... optional fluxes + if ( lflxprf ) then + do k = 0, nlay + k1 = nlp1 - k + flxprf(iplon,k1)%upfxc = totuflux(k) + flxprf(iplon,k1)%dnfxc = totdflux(k) + flxprf(iplon,k1)%upfx0 = totuclfl(k) + flxprf(iplon,k1)%dnfx0 = totdclfl(k) + enddo + endif + + do k = 1, nlay + k1 = nlp1 - k + hlwc(iplon,k1) = htr(k) + enddo + +!! --- ... optional clear sky heating rate + if ( lhlw0 ) then + do k = 1, nlay + k1 = nlp1 - k + hlw0(iplon,k1) = htrcl(k) + enddo + endif + +!! --- ... optional spectral band heating rate + if ( lhlwb ) then + do j = 1, nbands + do k = 1, nlay + k1 = nlp1 - k + hlwb(iplon,k1,j) = htrb(k,j) + enddo + enddo + endif + + else ! output from sfc to toa + +!! --- ... optional fluxes + if ( lflxprf ) then + do k = 0, nlay + flxprf(iplon,k+1)%upfxc = totuflux(k) + flxprf(iplon,k+1)%dnfxc = totdflux(k) + flxprf(iplon,k+1)%upfx0 = totuclfl(k) + flxprf(iplon,k+1)%dnfx0 = totdclfl(k) + enddo + endif + + do k = 1, nlay + hlwc(iplon,k) = htr(k) + enddo + +!! --- ... optional clear sky heating rate + if ( lhlw0 ) then + do k = 1, nlay + hlw0(iplon,k) = htrcl(k) + enddo + endif + +!! --- ... optional spectral band heating rate + if ( lhlwb ) then + do j = 1, nbands + do k = 1, nlay + hlwb(iplon,k,j) = htrb(k,j) + enddo + enddo + endif + + endif ! if_ivflip + + enddo lab_do_iplon + +!................................... + end subroutine rrtmg_lw_run +!----------------------------------- +!> @} + subroutine rrtmg_lw_finalize () + end subroutine rrtmg_lw_finalize + + + +!> \ingroup module_radlw_main +!> \brief This subroutine performs calculations necessary for the initialization +!! of the longwave model, which includes non-varying model variables, conversion +!! factors, and look-up tables +!! +!! Lookup tables are computed for use in the lw +!! radiative transfer, and input absorption coefficient data for each +!! spectral band are reduced from 256 g-point intervals to 140. +!!\param me print control for parallel process +!!\section rlwinit_gen rlwinit General Algorithm +!! @{ + subroutine rlwinit & + & (iovrlw,isubclw, me ) ! --- inputs +! --- outputs: (none) + +! =================== program usage description =================== ! +! ! +! purpose: initialize non-varying module variables, conversion factors,! +! and look-up tables. ! +! ! +! subprograms called: none ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: ! +! me - print control for parallel process ! +! ! +! outputs: (none) ! +! ! +! external module variables: (in physparam) ! +! ilwrate - heating rate unit selections ! +! =1: output in k/day ! +! =2: output in k/second ! +! ilwrgas - control flag for rare gases (ch4,n2o,o2,cfcs, etc.) ! +! =0: do not include rare gases ! +! >0: include all rare gases ! +! ilwcliq - liquid cloud optical properties contrl flag ! +! =0: input cloud opt depth from diagnostic scheme ! +! >0: input cwp,rew, and other cloud content parameters ! +! isubclw - sub-column cloud approximation control flag ! +! =0: no sub-col cld treatment, use grid-mean cld quantities ! +! =1: mcica sub-col, prescribed seeds to get random numbers ! +! =2: mcica sub-col, providing array icseed for random numbers! +! icldflg - cloud scheme control flag ! +! =0: diagnostic scheme gives cloud tau, omiga, and g. ! +! =1: prognostic scheme gives cloud liq/ice path, etc. ! +! iovrlw - clouds vertical overlapping control flag ! +! =0: random overlapping clouds ! +! =1: maximum/random overlapping clouds ! +! =2: maximum overlap cloud (isubcol>0 only) ! +! =3: decorrelation-length overlap (for isubclw>0 only) ! +! =4: exponential overlap cloud +! ! +! ******************************************************************* ! +! original code description ! +! ! +! original version: michael j. iacono; july, 1998 ! +! first revision for ncar ccm: september, 1998 ! +! second revision for rrtm_v3.0: september, 2002 ! +! ! +! this subroutine performs calculations necessary for the initialization +! of the longwave model. lookup tables are computed for use in the lw ! +! radiative transfer, and input absorption coefficient data for each ! +! spectral band are reduced from 256 g-point intervals to 140. ! +! ! +! ******************************************************************* ! +! ! +! definitions: ! +! arrays for 10000-point look-up tables: ! +! tau_tbl - clear-sky optical depth (used in cloudy radiative transfer! +! exp_tbl - exponential lookup table for tansmittance ! +! tfn_tbl - tau transition function; i.e. the transition of the Planck! +! function from that for the mean layer temperature to that ! +! for the layer boundary temperature as a function of optical +! depth. the "linear in tau" method is used to make the table +! ! +! ******************************************************************* ! +! ! +! ====================== end of description block ================= ! + +! --- inputs: + integer, intent(in) :: me,isubclw + integer, intent(inout) :: iovrlw + +! --- outputs: none + +! --- locals: + real (kind=kind_phys), parameter :: expeps = 1.e-20 + + real (kind=kind_phys) :: tfn, pival, explimit + + integer :: i + +! +!===> ... begin here +! + if ( iovrlw<0 .or. iovrlw>4 ) then + print *,' *** Error in specification of cloud overlap flag', & + & ' IOVRLW=',iovrlw,' in RLWINIT !!' + stop +!mz +! elseif ( iovrlw>=2 .and. isubclw==0 ) then + elseif ( (iovrlw.eq.2 .or. iovrlw.eq.3).and. isubclw==0 ) then + if (me == 0) then + print *,' *** IOVRLW=',iovrlw,' is not available for', & + & ' ISUBCLW=0 setting!!' + print *,' The program uses maximum/random overlap', & + & ' instead.' + endif + + iovrlw = 1 + endif + + if (me == 0) then + print *,' - Using AER Longwave Radiation, Version: ', VTAGLW + + if (ilwrgas > 0) then + print *,' --- Include rare gases N2O, CH4, O2, CFCs ', & + & 'absorptions in LW' + else + print *,' --- Rare gases effect is NOT included in LW' + endif + + if ( isubclw == 0 ) then + print *,' --- Using standard grid average clouds, no ', & + & 'sub-column clouds approximation applied' + elseif ( isubclw == 1 ) then + print *,' --- Using MCICA sub-colum clouds approximation ', & + & 'with a prescribed sequence of permutaion seeds' + elseif ( isubclw == 2 ) then + print *,' --- Using MCICA sub-colum clouds approximation ', & + & 'with provided input array of permutation seeds' + else + print *,' *** Error in specification of sub-column cloud ', & + & ' control flag isubclw =',isubclw,' !!' + stop + endif + endif + +!> -# Check cloud flags for consistency. + + if ((icldflg == 0 .and. ilwcliq /= 0) .or. & + & (icldflg == 1 .and. ilwcliq == 0)) then + print *,' *** Model cloud scheme inconsistent with LW', & + & ' radiation cloud radiative property setup !!' + stop + endif + +!> -# Setup default surface emissivity for each band. + + semiss0(:) = f_one + +!> -# Setup constant factors for flux and heating rate +!! the 1.0e-2 is to convert pressure from mb to \f$N/m^2\f$. + + pival = 2.0 * asin(f_one) + fluxfac = pival * 2.0d4 +! fluxfac = 62831.85307179586 ! = 2 * pi * 1.0e4 + + if (ilwrate == 1) then +! heatfac = 8.4391 +! heatfac = con_g * 86400. * 1.0e-2 / con_cp ! (in k/day) + heatfac = con_g * 864.0 / con_cp ! (in k/day) + else + heatfac = con_g * 1.0e-2 / con_cp ! (in k/second) + endif + +!> -# Compute lookup tables for transmittance, tau transition +!! function, and clear sky tau (for the cloudy sky radiative +!! transfer). tau is computed as a function of the tau +!! transition function, transmittance is calculated as a +!! function of tau, and the tau transition function is +!! calculated using the linear in tau formulation at values of +!! tau above 0.01. tf is approximated as tau/6 for tau < 0.01. +!! all tables are computed at intervals of 0.001. the inverse +!! of the constant used in the pade approximation to the tau +!! transition function is set to b. + + tau_tbl(0) = f_zero + exp_tbl(0) = f_one + tfn_tbl(0) = f_zero + + tau_tbl(ntbl) = 1.e10 + exp_tbl(ntbl) = expeps + tfn_tbl(ntbl) = f_one + + explimit = aint( -log(tiny(exp_tbl(0))) ) + + do i = 1, ntbl-1 +!org tfn = float(i) / float(ntbl) +!org tau_tbl(i) = bpade * tfn / (f_one - tfn) + tfn = real(i, kind_phys) / real(ntbl-i, kind_phys) + tau_tbl(i) = bpade * tfn + if (tau_tbl(i) >= explimit) then + exp_tbl(i) = expeps + else + exp_tbl(i) = exp( -tau_tbl(i) ) + endif + + if (tau_tbl(i) < 0.06) then + tfn_tbl(i) = tau_tbl(i) / 6.0 + else + tfn_tbl(i) = f_one - 2.0*( (f_one / tau_tbl(i)) & + & - ( exp_tbl(i) / (f_one - exp_tbl(i)) ) ) + endif + enddo + +!................................... + end subroutine rlwinit +!! @} +!----------------------------------- + + +!>\ingroup module_radlw_main +!> \brief This subroutine computes the cloud optical depth(s) for each cloudy +!! layer and g-point interval. +!!\param cfrac layer cloud fraction +!!\n --- for ilwcliq > 0 (prognostic cloud scheme) - - - +!!\param cliqp layer in-cloud liq water path (\f$g/m^2\f$) +!!\param reliq mean eff radius for liq cloud (micron) +!!\param cicep layer in-cloud ice water path (\f$g/m^2\f$) +!!\param reice mean eff radius for ice cloud (micron) +!!\param cdat1 layer rain drop water path (\f$g/m^2\f$) +!!\param cdat2 effective radius for rain drop (micron) +!!\param cdat3 layer snow flake water path(\f$g/m^2\f$) +!!\param cdat4 mean effective radius for snow flake(micron) +!!\n --- for ilwcliq = 0 (diagnostic cloud scheme) - - - +!!\param cliqp not used +!!\param cicep not used +!!\param reliq not used +!!\param reice not used +!!\param cdat1 layer cloud optical depth +!!\param cdat2 layer cloud single scattering albedo +!!\param cdat3 layer cloud asymmetry factor +!!\param cdat4 optional use +!!\param nlay number of layer number +!!\param nlp1 number of veritcal levels +!!\param ipseed permutation seed for generating random numbers (isubclw>0) +!!\param dz layer thickness (km) +!!\param de_lgth layer cloud decorrelation length (km) +!!\param cldfmc cloud fraction for each sub-column +!!\param taucld cloud optical depth for bands (non-mcica) +!!\section gen_cldprop cldprop General Algorithm +!> @{ + subroutine cldprop & + & ( cfrac,cliqp,reliq,cicep,reice,cdat1,cdat2,cdat3,cdat4, & ! --- inputs + & nlay, nlp1, ipseed, dz, de_lgth,iovrlw,isubclw, & + & cldfmc, taucld & ! --- outputs + & ) + +! =================== program usage description =================== ! +! ! +! purpose: compute the cloud optical depth(s) for each cloudy layer ! +! and g-point interval. ! +! ! +! subprograms called: none ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: -size- ! +! cfrac - real, layer cloud fraction 0:nlp1 ! +! ..... for ilwcliq > 0 (prognostic cloud sckeme) - - - ! +! cliqp - real, layer in-cloud liq water path (g/m**2) nlay ! +! reliq - real, mean eff radius for liq cloud (micron) nlay ! +! cicep - real, layer in-cloud ice water path (g/m**2) nlay ! +! reice - real, mean eff radius for ice cloud (micron) nlay ! +! cdat1 - real, layer rain drop water path (g/m**2) nlay ! +! cdat2 - real, effective radius for rain drop (microm) nlay ! +! cdat3 - real, layer snow flake water path (g/m**2) nlay ! +! cdat4 - real, effective radius for snow flakes (micron) nlay ! +! ..... for ilwcliq = 0 (diagnostic cloud sckeme) - - - ! +! cdat1 - real, input cloud optical depth nlay ! +! cdat2 - real, layer cloud single scattering albedo nlay ! +! cdat3 - real, layer cloud asymmetry factor nlay ! +! cdat4 - real, optional use nlay ! +! cliqp - not used nlay ! +! reliq - not used nlay ! +! cicep - not used nlay ! +! reice - not used nlay ! +! ! +! dz - real, layer thickness (km) nlay ! +! de_lgth- real, layer cloud decorrelation length (km) 1 ! +! nlay - integer, number of vertical layers 1 ! +! nlp1 - integer, number of vertical levels 1 ! +! ipseed- permutation seed for generating random numbers (isubclw>0) ! +! ! +! outputs: ! +! cldfmc - real, cloud fraction for each sub-column ngptlw*nlay! +! taucld - real, cld opt depth for bands (non-mcica) nbands*nlay! +! ! +! explanation of the method for each value of ilwcliq, and ilwcice. ! +! set up in module "module_radlw_cntr_para" ! +! ! +! ilwcliq=0 : input cloud optical property (tau, ssa, asy). ! +! (used for diagnostic cloud method) ! +! ilwcliq>0 : input cloud liq/ice path and effective radius, also ! +! require the user of 'ilwcice' to specify the method ! +! used to compute aborption due to water/ice parts. ! +! ................................................................... ! +! ! +! ilwcliq=1: the water droplet effective radius (microns) is input! +! and the opt depths due to water clouds are computed ! +! as in hu and stamnes, j., clim., 6, 728-742, (1993). ! +! the values for absorption coefficients appropriate for +! the spectral bands in rrtm have been obtained for a ! +! range of effective radii by an averaging procedure ! +! based on the work of j. pinto (private communication). +! linear interpolation is used to get the absorption ! +! coefficients for the input effective radius. ! +! ! +! ilwcice=1: the cloud ice path (g/m2) and ice effective radius ! +! (microns) are input and the optical depths due to ice! +! clouds are computed as in ebert and curry, jgr, 97, ! +! 3831-3836 (1992). the spectral regions in this work ! +! have been matched with the spectral bands in rrtm to ! +! as great an extent as possible: ! +! e&c 1 ib = 5 rrtm bands 9-16 ! +! e&c 2 ib = 4 rrtm bands 6-8 ! +! e&c 3 ib = 3 rrtm bands 3-5 ! +! e&c 4 ib = 2 rrtm band 2 ! +! e&c 5 ib = 1 rrtm band 1 ! +! ilwcice=2: the cloud ice path (g/m2) and ice effective radius ! +! (microns) are input and the optical depths due to ice! +! clouds are computed as in rt code, streamer v3.0 ! +! (ref: key j., streamer user's guide, cooperative ! +! institute for meteorological satellite studies, 2001,! +! 96 pp.) valid range of values for re are between 5.0 ! +! and 131.0 micron. ! +! ilwcice=3: the ice generalized effective size (dge) is input and! +! the optical properties, are calculated as in q. fu, ! +! j. climate, (1998). q. fu provided high resolution ! +! tales which were appropriately averaged for the bands! +! in rrtm_lw. linear interpolation is used to get the ! +! coeff from the stored tables. valid range of values ! +! for deg are between 5.0 and 140.0 micron. ! +! ! +! other cloud control module variables: ! +! isubclw =0: standard cloud scheme, no sub-col cloud approximation ! +! >0: mcica sub-col cloud scheme using ipseed as permutation! +! seed for generating rundom numbers ! +! ! +! ====================== end of description block ================= ! +! + use module_radlw_cldprlw + +! --- inputs: + integer, intent(in) :: nlay, nlp1, ipseed,iovrlw,isubclw + + real (kind=kind_phys), dimension(0:nlp1), intent(in) :: cfrac + real (kind=kind_phys), dimension(nlay), intent(in) :: cliqp, & + & reliq, cicep, reice, cdat1, cdat2, cdat3, cdat4, dz + real (kind=kind_phys), intent(in) :: de_lgth + +! --- outputs: + real (kind=kind_phys), dimension(ngptlw,nlay),intent(out):: cldfmc + real (kind=kind_phys), dimension(nbands,nlay),intent(out):: taucld + +! --- locals: + real (kind=kind_phys), dimension(nbands) :: tauliq, tauice + real (kind=kind_phys), dimension(nlay) :: cldf + + real (kind=kind_phys) :: dgeice, factor, fint, tauran, tausnw, & + & cldliq, refliq, cldice, refice + + logical :: lcloudy(ngptlw,nlay) + integer :: ia, ib, ig, k, index + +! +!===> ... begin here +! + do k = 1, nlay + do ib = 1, nbands + taucld(ib,k) = f_zero + enddo + enddo + + do k = 1, nlay + do ig = 1, ngptlw + cldfmc(ig,k) = f_zero + enddo + enddo + +!> -# Compute cloud radiative properties for a cloudy column: +!!\n - Compute cloud radiative properties for rain and snow (tauran,tausnw) +!!\n - Calculation of absorption coefficients due to water clouds(tauliq) +!!\n - Calculation of absorption coefficients due to ice clouds (tauice). +!!\n - For prognostic cloud scheme: sum up the cloud optical property: +!!\n \f$ taucld=tauice+tauliq+tauran+tausnw \f$ + +! --- ... compute cloud radiative properties for a cloudy column + + lab_if_ilwcliq : if (ilwcliq > 0) then + + lab_do_k : do k = 1, nlay + lab_if_cld : if (cfrac(k) > cldmin) then + + tauran = absrain * cdat1(k) ! ncar formula +!! tausnw = abssnow1 * cdat3(k) ! ncar formula +! --- if use fu's formula it needs to be normalized by snow density +! !not use snow density = 0.1 g/cm**3 = 0.1 g/(mu * m**2) +! use ice density = 0.9167 g/cm**3 = 0.9167 g/(mu * m**2) +! factor 1.5396=8/(3*sqrt(3)) converts reff to generalized ice particle size +! use newer factor value 1.0315 +! 1/(0.9167*1.0315) = 1.05756 + if (cdat3(k)>f_zero .and. cdat4(k)>10.0_kind_phys) then + tausnw = abssnow0*1.05756*cdat3(k)/cdat4(k) ! fu's formula + else + tausnw = f_zero + endif + + cldliq = cliqp(k) + cldice = cicep(k) +! refliq = max(2.5e0, min(60.0e0, reliq(k) )) +! refice = max(5.0e0, reice(k) ) + refliq = reliq(k) + refice = reice(k) + +! --- ... calculation of absorption coefficients due to water clouds. + + if ( cldliq <= f_zero ) then + do ib = 1, nbands + tauliq(ib) = f_zero + enddo + else + if ( ilwcliq == 1 ) then + + factor = refliq - 1.5 + index = max( 1, min( 57, int( factor ) )) + fint = factor - float(index) + + do ib = 1, nbands + tauliq(ib) = max(f_zero, cldliq*(absliq1(index,ib) & + & + fint*(absliq1(index+1,ib)-absliq1(index,ib)) )) + enddo + endif ! end if_ilwcliq_block + endif ! end if_cldliq_block + +! --- ... calculation of absorption coefficients due to ice clouds. + + if ( cldice <= f_zero ) then + do ib = 1, nbands + tauice(ib) = f_zero + enddo + else + +! --- ... ebert and curry approach for all particle sizes though somewhat +! unjustified for large ice particles + + if ( ilwcice == 1 ) then + refice = min(130.0, max(13.0, real(refice) )) + + do ib = 1, nbands + ia = ipat(ib) ! eb_&_c band index for ice cloud coeff + tauice(ib) = max(f_zero, cldice*(absice1(1,ia) & + & + absice1(2,ia)/refice) ) + enddo + +! --- ... streamer approach for ice effective radius between 5.0 and 131.0 microns +! and ebert and curry approach for ice eff radius greater than 131.0 microns. +! no smoothing between the transition of the two methods. + + elseif ( ilwcice == 2 ) then + + factor = (refice - 2.0) / 3.0 + index = max( 1, min( 42, int( factor ) )) + fint = factor - float(index) + + do ib = 1, nbands + tauice(ib) = max(f_zero, cldice*(absice2(index,ib) & + & + fint*(absice2(index+1,ib) - absice2(index,ib)) )) + enddo + +! --- ... fu's approach for ice effective radius between 4.8 and 135 microns +! (generalized effective size from 5 to 140 microns) + + elseif ( ilwcice == 3 ) then + +! dgeice = max(5.0, 1.5396*refice) ! v4.4 value + dgeice = max(5.0, 1.0315*refice) ! v4.71 value + factor = (dgeice - 2.0) / 3.0 + index = max( 1, min( 45, int( factor ) )) + fint = factor - float(index) + + do ib = 1, nbands + tauice(ib) = max(f_zero, cldice*(absice3(index,ib) & + & + fint*(absice3(index+1,ib) - absice3(index,ib)) )) + enddo + + endif ! end if_ilwcice_block + endif ! end if_cldice_block + + do ib = 1, nbands + taucld(ib,k) = tauice(ib) + tauliq(ib) + tauran + tausnw + enddo + + endif lab_if_cld + enddo lab_do_k + + else lab_if_ilwcliq + + do k = 1, nlay + if (cfrac(k) > cldmin) then + do ib = 1, nbands + taucld(ib,k) = cdat1(k) + enddo + endif + enddo + + endif lab_if_ilwcliq + +!> -# if isubclw > 0, call mcica_subcol() to distribute +!! cloud properties to each g-point. + + if ( isubclw > 0 ) then ! mcica sub-col clouds approx + do k = 1, nlay + if ( cfrac(k) < cldmin ) then + cldf(k) = f_zero + else + cldf(k) = cfrac(k) + endif + enddo + +! --- ... call sub-column cloud generator + + call mcica_subcol & +! --- inputs: + & ( cldf, nlay, ipseed, dz, de_lgth, iovrlw, & +! --- output: + & lcloudy & + & ) + + do k = 1, nlay + do ig = 1, ngptlw + if ( lcloudy(ig,k) ) then + cldfmc(ig,k) = f_one + else + cldfmc(ig,k) = f_zero + endif + enddo + enddo + + endif ! end if_isubclw_block + + return +! .................................. + end subroutine cldprop +! ---------------------------------- +!> @} + +!>\ingroup module_radlw_main +!>\brief This suroutine computes sub-colum cloud profile flag array. +!!\param cldf layer cloud fraction +!!\param nlay number of model vertical layers +!!\param ipseed permute seed for random num generator +!!\param dz layer thickness +!!\param de_lgth layer cloud decorrelation length (km) +!!\param lcloudy sub-colum cloud profile flag array +!!\section mcica_subcol_gen mcica_subcol General Algorithm +!! @{ + subroutine mcica_subcol & + & ( cldf, nlay, ipseed, dz, de_lgth, iovrlw, & ! --- inputs + & lcloudy & ! --- outputs + & ) + +! ==================== defination of variables ==================== ! +! ! +! input variables: size ! +! cldf - real, layer cloud fraction nlay ! +! nlay - integer, number of model vertical layers 1 ! +! ipseed - integer, permute seed for random num generator 1 ! +! ** note : if the cloud generator is called multiple times, need ! +! to permute the seed between each call; if between calls ! +! for lw and sw, use values differ by the number of g-pts. ! +! dz - real, layer thickness (km) nlay ! +! de_lgth - real, layer cloud decorrelation length (km) 1 ! +! ! +! output variables: ! +! lcloudy - logical, sub-colum cloud profile flag array ngptlw*nlay! +! ! +! other control flags from module variables: ! +! iovrlw : control flag for cloud overlapping method ! +! =0:random; =1:maximum/random: =2:maximum; =3:decorr ! +! ! +! ===================== end of definitions ==================== ! + + implicit none + +! --- inputs: + integer, intent(in) :: nlay, ipseed, iovrlw + + real (kind=kind_phys), dimension(nlay), intent(in) :: cldf, dz + real (kind=kind_phys), intent(in) :: de_lgth + +! --- outputs: + logical, dimension(ngptlw,nlay), intent(out) :: lcloudy + +! --- locals: + real (kind=kind_phys) :: cdfunc(ngptlw,nlay), rand1d(ngptlw), & + & rand2d(nlay*ngptlw), tem1, fac_lcf(nlay), & + & cdfun2(ngptlw,nlay) + + type (random_stat) :: stat ! for thread safe random generator + + integer :: k, n, k1 +! +!===> ... begin here +! +!> -# Call random_setseed() to advance randum number generator by ipseed values. + + call random_setseed & +! --- inputs: + & ( ipseed, & +! --- outputs: + & stat & + & ) + +!> -# Sub-column set up according to overlapping assumption: +!! - For random overlap, pick a random value at every level +!! - For max-random overlap, pick a random value at every level +!! - For maximum overlap, pick same random numebr at every level + + select case ( iovrlw ) + + case( 0 ) ! random overlap, pick a random value at every level + + call random_number & +! --- inputs: ( none ) +! --- outputs: + & ( rand2d, stat ) + + k1 = 0 + do n = 1, ngptlw + do k = 1, nlay + k1 = k1 + 1 + cdfunc(n,k) = rand2d(k1) + enddo + enddo + + case( 1 ) ! max-ran overlap + + call random_number & +! --- inputs: ( none ) +! --- outputs: + & ( rand2d, stat ) + + k1 = 0 + do n = 1, ngptlw + do k = 1, nlay + k1 = k1 + 1 + cdfunc(n,k) = rand2d(k1) + enddo + enddo + +! --- first pick a random number for bottom (or top) layer. +! then walk up the column: (aer's code) +! if layer below is cloudy, use the same rand num in the layer below +! if layer below is clear, use a new random number + +! --- from bottom up + do k = 2, nlay + k1 = k - 1 + tem1 = f_one - cldf(k1) + + do n = 1, ngptlw + if ( cdfunc(n,k1) > tem1 ) then + cdfunc(n,k) = cdfunc(n,k1) + else + cdfunc(n,k) = cdfunc(n,k) * tem1 + endif + enddo + enddo + +! --- or walk down the column: (if use original author's method) +! if layer above is cloudy, use the same rand num in the layer above +! if layer above is clear, use a new random number + +! --- from top down +! do k = nlay-1, 1, -1 +! k1 = k + 1 +! tem1 = f_one - cldf(k1) + +! do n = 1, ngptlw +! if ( cdfunc(n,k1) > tem1 ) then +! cdfunc(n,k) = cdfunc(n,k1) +! else +! cdfunc(n,k) = cdfunc(n,k) * tem1 +! endif +! enddo +! enddo + + case( 2 ) !< - For maximum overlap, pick same random numebr at every level + + call random_number & +! --- inputs: ( none ) +! --- outputs: + & ( rand1d, stat ) + + do n = 1, ngptlw + tem1 = rand1d(n) + + do k = 1, nlay + cdfunc(n,k) = tem1 + enddo + enddo + + case( 3 ) ! decorrelation length overlap + +! --- compute overlapping factors based on layer midpoint distances +! and decorrelation depths + + do k = nlay, 2, -1 + fac_lcf(k) = exp( -0.5 * (dz(k)+dz(k-1)) / de_lgth ) + enddo + +! --- setup 2 sets of random numbers + + call random_number ( rand2d, stat ) + + k1 = 0 + do k = 1, nlay + do n = 1, ngptlw + k1 = k1 + 1 + cdfunc(n,k) = rand2d(k1) + enddo + enddo + + call random_number ( rand2d, stat ) + + k1 = 0 + do k = 1, nlay + do n = 1, ngptlw + k1 = k1 + 1 + cdfun2(n,k) = rand2d(k1) + enddo + enddo + +! --- then working from the top down: +! if a random number (from an independent set -cdfun2) is smaller then the +! scale factor: use the upper layer's number, otherwise use a new random +! number (keep the original assigned one). + + do k = nlay-1, 1, -1 + k1 = k + 1 + + do n = 1, ngptlw + if ( cdfun2(n,k) <= fac_lcf(k1) ) then + cdfunc(n,k) = cdfunc(n,k1) + endif + enddo + enddo + + end select + +!> -# Generate subcolumns for homogeneous clouds. + + do k = 1, nlay + tem1 = f_one - cldf(k) + + do n = 1, ngptlw + lcloudy(n,k) = cdfunc(n,k) >= tem1 + enddo + enddo + + return +! .................................. + end subroutine mcica_subcol +!! @} +! ---------------------------------- + +!>\ingroup module_radlw_main +!> This subroutine computes various coefficients needed in radiative +!! transfer calculations. +!!\param pavel layer pressure (mb) +!!\param tavel layer temperature (K) +!!\param tz level(interface) temperatures (K) +!!\param stemp surface ground temperature (K) +!!\param h2ovmr layer w.v. volumn mixing ratio (kg/kg) +!!\param colamt column amounts of absorbing gases. +!! 2nd indices range: 1-maxgas, for watervapor,carbon dioxide, ozone, +!! nitrous oxide, methane,oxigen, carbon monoxide,etc. \f$(mol/cm^2)\f$ +!!\param coldry dry air column amount +!!\param colbrd column amount of broadening gases +!!\param nlay total number of vertical layers +!!\param nlp1 total number of vertical levels +!!\param laytrop tropopause layer index (unitless) +!!\param pklay integrated planck func at lay temp +!!\param pklev integrated planck func at lev temp +!!\param jp indices of lower reference pressure +!!\param jt, jt1 indices of lower reference temperatures +!!\param rfrate ref ratios of binary species param +!!\n (:,m,:)m=1-h2o/co2,2-h2o/o3,3-h2o/n2o, +!! 4-h2o/ch4,5-n2o/co2,6-o3/co2 +!!\n (:,:,n)n=1,2: the rates of ref press at +!! the 2 sides of the layer +!!\param fac00,fac01,fac10,fac11 factors multiply the reference ks, i,j=0/1 for +!! lower/higher of the 2 appropriate temperatures +!! and altitudes. +!!\param selffac scale factor for w. v. self-continuum equals +!! (w. v. density)/(atmospheric density at 296k and 1013 mb) +!!\param selffrac factor for temperature interpolation of +!! reference w. v. self-continuum data +!!\param indself index of lower ref temp for selffac +!!\param forfac scale factor for w. v. foreign-continuum +!!\param forfrac factor for temperature interpolation of +!! reference w.v. foreign-continuum data +!!\param indfor index of lower ref temp for forfac +!!\param minorfrac factor for minor gases +!!\param scaleminor,scaleminorn2 scale factors for minor gases +!!\param indminor index of lower ref temp for minor gases +!>\section setcoef_gen setcoef General Algorithm +!> @{ + subroutine setcoef & + & ( pavel,tavel,tz,stemp,h2ovmr,colamt,coldry,colbrd, & ! --- inputs: + & nlay, nlp1, & + & laytrop,pklay,pklev,jp,jt,jt1, & ! --- outputs: + & rfrate,fac00,fac01,fac10,fac11, & + & selffac,selffrac,indself,forfac,forfrac,indfor, & + & minorfrac,scaleminor,scaleminorn2,indminor & + & ) + +! =================== program usage description =================== ! +! ! +! purpose: compute various coefficients needed in radiative transfer ! +! calculations. ! +! ! +! subprograms called: none ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: -size- ! +! pavel - real, layer pressures (mb) nlay ! +! tavel - real, layer temperatures (k) nlay ! +! tz - real, level (interface) temperatures (k) 0:nlay ! +! stemp - real, surface ground temperature (k) 1 ! +! h2ovmr - real, layer w.v. volum mixing ratio (kg/kg) nlay ! +! colamt - real, column amounts of absorbing gases nlay*maxgas! +! 2nd indices range: 1-maxgas, for watervapor, ! +! carbon dioxide, ozone, nitrous oxide, methane, ! +! oxigen, carbon monoxide,etc. (molecules/cm**2) ! +! coldry - real, dry air column amount nlay ! +! colbrd - real, column amount of broadening gases nlay ! +! nlay/nlp1 - integer, total number of vertical layers, levels 1 ! +! ! +! outputs: ! +! laytrop - integer, tropopause layer index (unitless) 1 ! +! pklay - real, integrated planck func at lay temp nbands*0:nlay! +! pklev - real, integrated planck func at lev temp nbands*0:nlay! +! jp - real, indices of lower reference pressure nlay ! +! jt, jt1 - real, indices of lower reference temperatures nlay ! +! rfrate - real, ref ratios of binary species param nlay*nrates*2! +! (:,m,:)m=1-h2o/co2,2-h2o/o3,3-h2o/n2o,4-h2o/ch4,5-n2o/co2,6-o3/co2! +! (:,:,n)n=1,2: the rates of ref press at the 2 sides of the layer ! +! facij - real, factors multiply the reference ks, nlay ! +! i,j=0/1 for lower/higher of the 2 appropriate ! +! temperatures and altitudes. ! +! selffac - real, scale factor for w. v. self-continuum nlay ! +! equals (w. v. density)/(atmospheric density ! +! at 296k and 1013 mb) ! +! selffrac - real, factor for temperature interpolation of nlay ! +! reference w. v. self-continuum data ! +! indself - integer, index of lower ref temp for selffac nlay ! +! forfac - real, scale factor for w. v. foreign-continuum nlay ! +! forfrac - real, factor for temperature interpolation of nlay ! +! reference w.v. foreign-continuum data ! +! indfor - integer, index of lower ref temp for forfac nlay ! +! minorfrac - real, factor for minor gases nlay ! +! scaleminor,scaleminorn2 ! +! - real, scale factors for minor gases nlay ! +! indminor - integer, index of lower ref temp for minor gases nlay ! +! ! +! ====================== end of definitions =================== ! + +! --- inputs: + integer, intent(in) :: nlay, nlp1 + + real (kind=kind_phys), dimension(nlay,maxgas),intent(in):: colamt + real (kind=kind_phys), dimension(0:nlay), intent(in):: tz + + real (kind=kind_phys), dimension(nlay), intent(in) :: pavel, & + & tavel, h2ovmr, coldry, colbrd + + real (kind=kind_phys), intent(in) :: stemp + +! --- outputs: + integer, dimension(nlay), intent(out) :: jp, jt, jt1, indself, & + & indfor, indminor + + integer, intent(out) :: laytrop + + real (kind=kind_phys), dimension(nlay,nrates,2), intent(out) :: & + & rfrate + real (kind=kind_phys), dimension(nbands,0:nlay), intent(out) :: & + & pklev, pklay + + real (kind=kind_phys), dimension(nlay), intent(out) :: & + & fac00, fac01, fac10, fac11, selffac, selffrac, forfac, & + & forfrac, minorfrac, scaleminor, scaleminorn2 + +! --- locals: + real (kind=kind_phys) :: tlvlfr, tlyrfr, plog, fp, ft, ft1, & + & tem1, tem2 + + integer :: i, k, jp1, indlev, indlay +! +!===> ... begin here +! +!> -# Calculate information needed by the radiative transfer routine +!! that is specific to this atmosphere, especially some of the +!! coefficients and indices needed to compute the optical depths +!! by interpolating data from stored reference atmospheres. + + indlay = min(180, max(1, int(stemp-159.0) )) + indlev = min(180, max(1, int(tz(0)-159.0) )) + tlyrfr = stemp - int(stemp) + tlvlfr = tz(0) - int(tz(0)) + do i = 1, nbands + tem1 = totplnk(indlay+1,i) - totplnk(indlay,i) + tem2 = totplnk(indlev+1,i) - totplnk(indlev,i) + pklay(i,0) = delwave(i) * (totplnk(indlay,i) + tlyrfr*tem1) + pklev(i,0) = delwave(i) * (totplnk(indlev,i) + tlvlfr*tem2) + enddo + +! --- ... begin layer loop +!> -# Calculate the integrated Planck functions for each band at the +!! surface, level, and layer temperatures. + + laytrop = 0 + + do k = 1, nlay + + indlay = min(180, max(1, int(tavel(k)-159.0) )) + tlyrfr = tavel(k) - int(tavel(k)) + + indlev = min(180, max(1, int(tz(k)-159.0) )) + tlvlfr = tz(k) - int(tz(k)) + +! --- ... begin spectral band loop + + do i = 1, nbands +!mz* +! plankbnd(iband) = semiss(iband) * & +! (totplnk(indbound,iband) + tbndfrac * dbdtlev) +!mz + + pklay(i,k) = delwave(i) * (totplnk(indlay,i) + tlyrfr & + & * (totplnk(indlay+1,i) - totplnk(indlay,i)) ) + pklev(i,k) = delwave(i) * (totplnk(indlev,i) + tlvlfr & + & * (totplnk(indlev+1,i) - totplnk(indlev,i)) ) + enddo + +!> -# Find the two reference pressures on either side of the +!! layer pressure. store them in jp and jp1. store in fp the +!! fraction of the difference (in ln(pressure)) between these +!! two values that the layer pressure lies. + + plog = log(pavel(k)) + jp(k)= max(1, min(58, int(36.0 - 5.0*(plog+0.04)) )) + jp1 = jp(k) + 1 +! --- ... limit pressure extrapolation at the top + fp = max(f_zero, min(f_one, 5.0*(preflog(jp(k))-plog) )) +!org fp = 5.0 * (preflog(jp(k)) - plog) + +!> -# Determine, for each reference pressure (jp and jp1), which +!! reference temperature (these are different for each +!! reference pressure) is nearest the layer temperature but does +!! not exceed it. store these indices in jt and jt1, resp. +!! store in ft (resp. ft1) the fraction of the way between jt +!! (jt1) and the next highest reference temperature that the +!! layer temperature falls. + + tem1 = (tavel(k)-tref(jp(k))) / 15.0 + tem2 = (tavel(k)-tref(jp1 )) / 15.0 + jt (k) = max(1, min(4, int(3.0 + tem1) )) + jt1(k) = max(1, min(4, int(3.0 + tem2) )) +! --- ... restrict extrapolation ranges by limiting abs(det t) < 37.5 deg + ft = max(-0.5, min(1.5, tem1 - float(jt (k) - 3) )) + ft1 = max(-0.5, min(1.5, tem2 - float(jt1(k) - 3) )) +!org ft = tem1 - float(jt (k) - 3) +!org ft1 = tem2 - float(jt1(k) - 3) + +!> -# We have now isolated the layer ln pressure and temperature, +!! between two reference pressures and two reference temperatures +!!(for each reference pressure). we multiply the pressure +!! fraction fp with the appropriate temperature fractions to get +!! the factors that will be needed for the interpolation that yields +!! the optical depths (performed in routines taugbn for band n). + + tem1 = f_one - fp + fac10(k) = tem1 * ft + fac00(k) = tem1 * (f_one - ft) + fac11(k) = fp * ft1 + fac01(k) = fp * (f_one - ft1) + + forfac(k) = pavel(k)*stpfac / (tavel(k)*(1.0 + h2ovmr(k))) + selffac(k) = h2ovmr(k) * forfac(k) + +!> -# Set up factors needed to separately include the minor gases +!! in the calculation of absorption coefficient. + + scaleminor(k) = pavel(k) / tavel(k) + scaleminorn2(k) = (pavel(k) / tavel(k)) & + & * (colbrd(k)/(coldry(k) + colamt(k,1))) + tem1 = (tavel(k) - 180.8) / 7.2 + indminor(k) = min(18, max(1, int(tem1))) + minorfrac(k) = tem1 - float(indminor(k)) + +!> -# If the pressure is less than ~100mb, perform a different +!! set of species interpolations. + + if (plog > 4.56) then + + laytrop = laytrop + 1 + + tem1 = (332.0 - tavel(k)) / 36.0 + indfor(k) = min(2, max(1, int(tem1))) + forfrac(k) = tem1 - float(indfor(k)) + +!> -# Set up factors needed to separately include the water vapor +!! self-continuum in the calculation of absorption coefficient. + + tem1 = (tavel(k) - 188.0) / 7.2 + indself(k) = min(9, max(1, int(tem1)-7)) + selffrac(k) = tem1 - float(indself(k) + 7) + +!> -# Setup reference ratio to be used in calculation of binary +!! species parameter in lower atmosphere. + + rfrate(k,1,1) = chi_mls(1,jp(k)) / chi_mls(2,jp(k)) + rfrate(k,1,2) = chi_mls(1,jp(k)+1) / chi_mls(2,jp(k)+1) + + rfrate(k,2,1) = chi_mls(1,jp(k)) / chi_mls(3,jp(k)) + rfrate(k,2,2) = chi_mls(1,jp(k)+1) / chi_mls(3,jp(k)+1) + + rfrate(k,3,1) = chi_mls(1,jp(k)) / chi_mls(4,jp(k)) + rfrate(k,3,2) = chi_mls(1,jp(k)+1) / chi_mls(4,jp(k)+1) + + rfrate(k,4,1) = chi_mls(1,jp(k)) / chi_mls(6,jp(k)) + rfrate(k,4,2) = chi_mls(1,jp(k)+1) / chi_mls(6,jp(k)+1) + + rfrate(k,5,1) = chi_mls(4,jp(k)) / chi_mls(2,jp(k)) + rfrate(k,5,2) = chi_mls(4,jp(k)+1) / chi_mls(2,jp(k)+1) + + else + + tem1 = (tavel(k) - 188.0) / 36.0 + indfor(k) = 3 + forfrac(k) = tem1 - f_one + + indself(k) = 0 + selffrac(k) = f_zero + +!> -# Setup reference ratio to be used in calculation of binary +!! species parameter in upper atmosphere. + + rfrate(k,1,1) = chi_mls(1,jp(k)) / chi_mls(2,jp(k)) + rfrate(k,1,2) = chi_mls(1,jp(k)+1) / chi_mls(2,jp(k)+1) + + rfrate(k,6,1) = chi_mls(3,jp(k)) / chi_mls(2,jp(k)) + rfrate(k,6,2) = chi_mls(3,jp(k)+1) / chi_mls(2,jp(k)+1) + + endif + +!> -# Rescale \a selffac and \a forfac for use in taumol. + + selffac(k) = colamt(k,1) * selffac(k) + forfac(k) = colamt(k,1) * forfac(k) + + enddo ! end do_k layer loop + + return +! .................................. + end subroutine setcoef +!> @} +! ---------------------------------- + +!>\ingroup module_radlw_main +!> This subroutine computes the upward/downward radiative fluxes, and +!! heating rates for both clear or cloudy atmosphere. Clouds assumed as +!! randomly overlaping in a vertical column. +!!\brief Original Code Description: this program calculates the upward +!! fluxes, downward fluxes, and heating rates for an arbitrary clear or +!! cloudy atmosphere. The input to this program is the atmospheric +!! profile, all Planck function information, and the cloud fraction by +!! layer. A variable diffusivity angle (secdif) is used for the angle +!! integration. Bands 2-3 and 5-9 use a value for secdif that varies +!! from 1.50 to 1.80 as a function of the column water vapor, and other +!! bands use a value of 1.66. The gaussian weight appropriate to this +!! angle (wtdiff =0.5) is applied here. Note that use of the emissivity +!! angle for the flux integration can cause errors of 1 to 4 \f$W/m^2\f$ +!! within cloudy layers. Clouds are treated with a random cloud overlap +!! method. +!!\param semiss lw surface emissivity +!!\param delp layer pressure thickness (mb) +!!\param cldfrc layer cloud fraction +!!\param taucld layer cloud opt depth +!!\param tautot total optical depth (gas+aerosols) +!!\param pklay integrated planck function at lay temp +!!\param pklev integrated planck func at lev temp +!!\param fracs planck fractions +!!\param secdif secant of diffusivity angle +!!\param nlay number of vertical layers +!!\param nlp1 number of vertical levels (interfaces) +!!\param totuflux total sky upward flux \f$(w/m^2)\f$ +!!\param totdflux total sky downward flux \f$(w/m^2)\f$ +!!\param htr total sky heating rate (k/sec or k/day) +!!\param totuclfl clear sky upward flux \f$(w/m^2)\f$ +!!\param totdclfl clear sky downward flux \f$(w/m^2)\f$ +!!\param htrcl clear sky heating rate (k/sec or k/day) +!!\param htrb spectral band lw heating rate (k/day) +!>\section gen_rtrn rtrn General Algorithm +!! @{ +! ---------------------------------- + subroutine rtrn & + & ( semiss,delp,cldfrc,taucld,tautot,pklay,pklev, & ! --- inputs + & fracs,secdif, nlay,nlp1, & + & totuflux,totdflux,htr, totuclfl,totdclfl,htrcl, htrb & ! --- outputs + & ) + +! =================== program usage description =================== ! +! ! +! purpose: compute the upward/downward radiative fluxes, and heating ! +! rates for both clear or cloudy atmosphere. clouds are assumed as ! +! randomly overlaping in a vertical colum. ! +! ! +! subprograms called: none ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: -size- ! +! semiss - real, lw surface emissivity nbands! +! delp - real, layer pressure thickness (mb) nlay ! +! cldfrc - real, layer cloud fraction 0:nlp1 ! +! taucld - real, layer cloud opt depth nbands,nlay! +! tautot - real, total optical depth (gas+aerosols) ngptlw,nlay! +! pklay - real, integrated planck func at lay temp nbands*0:nlay! +! pklev - real, integrated planck func at lev temp nbands*0:nlay! +! fracs - real, planck fractions ngptlw,nlay! +! secdif - real, secant of diffusivity angle nbands! +! nlay - integer, number of vertical layers 1 ! +! nlp1 - integer, number of vertical levels (interfaces) 1 ! +! ! +! outputs: ! +! totuflux- real, total sky upward flux (w/m2) 0:nlay ! +! totdflux- real, total sky downward flux (w/m2) 0:nlay ! +! htr - real, total sky heating rate (k/sec or k/day) nlay ! +! totuclfl- real, clear sky upward flux (w/m2) 0:nlay ! +! totdclfl- real, clear sky downward flux (w/m2) 0:nlay ! +! htrcl - real, clear sky heating rate (k/sec or k/day) nlay ! +! htrb - real, spectral band lw heating rate (k/day) nlay*nbands! +! ! +! module veriables: ! +! ngb - integer, band index for each g-value ngptlw! +! fluxfac - real, conversion factor for fluxes (pi*2.e4) 1 ! +! heatfac - real, conversion factor for heating rates (g/cp*1e-2) 1 ! +! tblint - real, conversion factor for look-up tbl (float(ntbl) 1 ! +! bpade - real, pade approx constant (1/0.278) 1 ! +! wtdiff - real, weight for radiance to flux conversion 1 ! +! ntbl - integer, dimension of look-up tables 1 ! +! tau_tbl - real, clr-sky opt dep lookup table 0:ntbl ! +! exp_tbl - real, transmittance lookup table 0:ntbl ! +! tfn_tbl - real, tau transition function 0:ntbl ! +! ! +! local variables: ! +! itgas - integer, index for gases contribution look-up table 1 ! +! ittot - integer, index for gases plus clouds look-up table 1 ! +! reflct - real, surface reflectance 1 ! +! atrgas - real, gaseous absorptivity 1 ! +! atrtot - real, gaseous and cloud absorptivity 1 ! +! odcld - real, cloud optical depth 1 ! +! efclrfr- real, effective clear sky fraction (1-efcldfr) nlay ! +! odepth - real, optical depth of gaseous only 1 ! +! odtot - real, optical depth of gas and cloud 1 ! +! gasfac - real, gas-only pade factor, used for planck fn 1 ! +! totfac - real, gas+cld pade factor, used for planck fn 1 ! +! bbdgas - real, gas-only planck function for downward rt 1 ! +! bbugas - real, gas-only planck function for upward rt 1 ! +! bbdtot - real, gas and cloud planck function for downward rt 1 ! +! bbutot - real, gas and cloud planck function for upward rt 1 ! +! gassrcu- real, upwd source radiance due to gas only nlay! +! totsrcu- real, upwd source radiance due to gas+cld nlay! +! gassrcd- real, dnwd source radiance due to gas only 1 ! +! totsrcd- real, dnwd source radiance due to gas+cld 1 ! +! radtotu- real, spectrally summed total sky upwd radiance 1 ! +! radclru- real, spectrally summed clear sky upwd radiance 1 ! +! radtotd- real, spectrally summed total sky dnwd radiance 1 ! +! radclrd- real, spectrally summed clear sky dnwd radiance 1 ! +! toturad- real, total sky upward radiance by layer 0:nlay*nbands! +! clrurad- real, clear sky upward radiance by layer 0:nlay*nbands! +! totdrad- real, total sky downward radiance by layer 0:nlay*nbands! +! clrdrad- real, clear sky downward radiance by layer 0:nlay*nbands! +! fnet - real, net longwave flux (w/m2) 0:nlay ! +! fnetc - real, clear sky net longwave flux (w/m2) 0:nlay ! +! ! +! ! +! ******************************************************************* ! +! original code description ! +! ! +! original version: e. j. mlawer, et al. rrtm_v3.0 ! +! revision for gcms: michael j. iacono; october, 2002 ! +! revision for f90: michael j. iacono; june, 2006 ! +! ! +! this program calculates the upward fluxes, downward fluxes, and ! +! heating rates for an arbitrary clear or cloudy atmosphere. the input ! +! to this program is the atmospheric profile, all Planck function ! +! information, and the cloud fraction by layer. a variable diffusivity! +! angle (secdif) is used for the angle integration. bands 2-3 and 5-9 ! +! use a value for secdif that varies from 1.50 to 1.80 as a function ! +! of the column water vapor, and other bands use a value of 1.66. the ! +! gaussian weight appropriate to this angle (wtdiff=0.5) is applied ! +! here. note that use of the emissivity angle for the flux integration! +! can cause errors of 1 to 4 W/m2 within cloudy layers. ! +! clouds are treated with a random cloud overlap method. ! +! ! +! ******************************************************************* ! +! ====================== end of description block ================= ! + +! --- inputs: + integer, intent(in) :: nlay, nlp1 + + real (kind=kind_phys), dimension(0:nlp1), intent(in) :: cldfrc + real (kind=kind_phys), dimension(nbands), intent(in) :: semiss, & + & secdif + real (kind=kind_phys), dimension(nlay), intent(in) :: delp + + real (kind=kind_phys), dimension(nbands,nlay),intent(in):: taucld + real (kind=kind_phys), dimension(ngptlw,nlay),intent(in):: fracs, & + & tautot + + real (kind=kind_phys), dimension(nbands,0:nlay), intent(in) :: & + & pklev, pklay + +! --- outputs: + real (kind=kind_phys), dimension(nlay), intent(out) :: htr, htrcl + + real (kind=kind_phys), dimension(nlay,nbands),intent(out) :: htrb + + real (kind=kind_phys), dimension(0:nlay), intent(out) :: & + & totuflux, totdflux, totuclfl, totdclfl + +! --- locals: + real (kind=kind_phys), parameter :: rec_6 = 0.166667 + + real (kind=kind_phys), dimension(0:nlay,nbands) :: clrurad, & + & clrdrad, toturad, totdrad + + real (kind=kind_phys), dimension(nlay) :: gassrcu, totsrcu, & + & trngas, efclrfr, rfdelp + real (kind=kind_phys), dimension(0:nlay) :: fnet, fnetc + + real (kind=kind_phys) :: totsrcd, gassrcd, tblind, odepth, odtot, & + & odcld, atrtot, atrgas, reflct, totfac, gasfac, flxfac, & + & plfrac, blay, bbdgas, bbdtot, bbugas, bbutot, dplnku, & + & dplnkd, radtotu, radclru, radtotd, radclrd, rad0, & + & clfr, trng, gasu + + integer :: ittot, itgas, ib, ig, k +! +!===> ... begin here +! + do ib = 1, NBANDS + do k = 0, NLAY + toturad(k,ib) = f_zero + totdrad(k,ib) = f_zero + clrurad(k,ib) = f_zero + clrdrad(k,ib) = f_zero + enddo + enddo + + do k = 0, nlay + totuflux(k) = f_zero + totdflux(k) = f_zero + totuclfl(k) = f_zero + totdclfl(k) = f_zero + enddo + +! --- ... loop over all g-points + + do ig = 1, ngptlw + ib = ngb(ig) + + radtotd = f_zero + radclrd = f_zero + +!> -# Downward radiative transfer loop. + + do k = nlay, 1, -1 + +!!\n - clear sky, gases contribution + + odepth = max( f_zero, secdif(ib)*tautot(ig,k) ) + if (odepth <= 0.06) then + atrgas = odepth - 0.5*odepth*odepth + trng = f_one - atrgas + gasfac = rec_6 * odepth + else + tblind = odepth / (bpade + odepth) + itgas = tblint*tblind + 0.5 + trng = exp_tbl(itgas) + atrgas = f_one - trng + gasfac = tfn_tbl(itgas) + odepth = tau_tbl(itgas) + endif + + plfrac = fracs(ig,k) + blay = pklay(ib,k) + + dplnku = pklev(ib,k ) - blay + dplnkd = pklev(ib,k-1) - blay + bbdgas = plfrac * (blay + dplnkd*gasfac) + bbugas = plfrac * (blay + dplnku*gasfac) + gassrcd= bbdgas * atrgas + gassrcu(k)= bbugas * atrgas + trngas(k) = trng + +!!\n - total sky, gases+clouds contribution + + clfr = cldfrc(k) + if (clfr >= eps) then +!!\n - cloudy layer + + odcld = secdif(ib) * taucld(ib,k) + efclrfr(k) = f_one-(f_one - exp(-odcld))*clfr + odtot = odepth + odcld + if (odtot < 0.06) then + totfac = rec_6 * odtot + atrtot = odtot - 0.5*odtot*odtot + else + tblind = odtot / (bpade + odtot) + ittot = tblint*tblind + 0.5 + totfac = tfn_tbl(ittot) + atrtot = f_one - exp_tbl(ittot) + endif + + bbdtot = plfrac * (blay + dplnkd*totfac) + bbutot = plfrac * (blay + dplnku*totfac) + totsrcd= bbdtot * atrtot + totsrcu(k)= bbutot * atrtot + +! --- ... total sky radiance + radtotd = radtotd*trng*efclrfr(k) + gassrcd & + & + clfr*(totsrcd - gassrcd) + totdrad(k-1,ib) = totdrad(k-1,ib) + radtotd + +! --- ... clear sky radiance + radclrd = radclrd*trng + gassrcd + clrdrad(k-1,ib) = clrdrad(k-1,ib) + radclrd + + else +! --- ... clear layer + +! --- ... total sky radiance + radtotd = radtotd*trng + gassrcd + totdrad(k-1,ib) = totdrad(k-1,ib) + radtotd + +! --- ... clear sky radiance + radclrd = radclrd*trng + gassrcd + clrdrad(k-1,ib) = clrdrad(k-1,ib) + radclrd + + endif ! end if_clfr_block + + enddo ! end do_k_loop + +!> -# Compute spectral emissivity & reflectance, include the +!! contribution of spectrally varying longwave emissivity and +!! reflection from the surface to the upward radiative transfer. + +! note: spectral and Lambertian reflection are identical for the +! diffusivity angle flux integration used here. + + reflct = f_one - semiss(ib) + rad0 = semiss(ib) * fracs(ig,1) * pklay(ib,0) + +!> -# Compute total sky radiance. + radtotu = rad0 + reflct*radtotd + toturad(0,ib) = toturad(0,ib) + radtotu + +!> -# Compute clear sky radiance + radclru = rad0 + reflct*radclrd + clrurad(0,ib) = clrurad(0,ib) + radclru + +!> -# Upward radiative transfer loop. + + do k = 1, nlay + clfr = cldfrc(k) + trng = trngas(k) + gasu = gassrcu(k) + + if (clfr >= eps) then +! --- ... cloudy layer + +! --- ... total sky radiance + radtotu = radtotu*trng*efclrfr(k) + gasu & + & + clfr*(totsrcu(k) - gasu) + toturad(k,ib) = toturad(k,ib) + radtotu + +! --- ... clear sky radiance + radclru = radclru*trng + gasu + clrurad(k,ib) = clrurad(k,ib) + radclru + + else +! --- ... clear layer + +! --- ... total sky radiance + radtotu = radtotu*trng + gasu + toturad(k,ib) = toturad(k,ib) + radtotu + +! --- ... clear sky radiance + radclru = radclru*trng + gasu + clrurad(k,ib) = clrurad(k,ib) + radclru + + endif ! end if_clfr_block + + enddo ! end do_k_loop + + enddo ! end do_ig_loop + +!> -# Process longwave output from band for total and clear streams. +!! Calculate upward, downward, and net flux. + + flxfac = wtdiff * fluxfac + + do k = 0, nlay + do ib = 1, nbands + totuflux(k) = totuflux(k) + toturad(k,ib) + totdflux(k) = totdflux(k) + totdrad(k,ib) + totuclfl(k) = totuclfl(k) + clrurad(k,ib) + totdclfl(k) = totdclfl(k) + clrdrad(k,ib) + enddo + + totuflux(k) = totuflux(k) * flxfac + totdflux(k) = totdflux(k) * flxfac + totuclfl(k) = totuclfl(k) * flxfac + totdclfl(k) = totdclfl(k) * flxfac + enddo + +! --- ... calculate net fluxes and heating rates + fnet(0) = totuflux(0) - totdflux(0) + + do k = 1, nlay + rfdelp(k) = heatfac / delp(k) + fnet(k) = totuflux(k) - totdflux(k) + htr (k) = (fnet(k-1) - fnet(k)) * rfdelp(k) + enddo + +!! --- ... optional clear sky heating rates + if ( lhlw0 ) then + fnetc(0) = totuclfl(0) - totdclfl(0) + + do k = 1, nlay + fnetc(k) = totuclfl(k) - totdclfl(k) + htrcl(k) = (fnetc(k-1) - fnetc(k)) * rfdelp(k) + enddo + endif + +!! --- ... optional spectral band heating rates + if ( lhlwb ) then + do ib = 1, nbands + fnet(0) = (toturad(0,ib) - totdrad(0,ib)) * flxfac + + do k = 1, nlay + fnet(k) = (toturad(k,ib) - totdrad(k,ib)) * flxfac + htrb(k,ib) = (fnet(k-1) - fnet(k)) * rfdelp(k) + enddo + enddo + endif + +! .................................. + end subroutine rtrn +!! @} +! ---------------------------------- + + +!>\ingroup module_radlw_main +!> This subroutine computes the upward/downward radiative fluxes, and +!! heating rates for both clear or cloudy atmosphere. Clouds are +!! assumed as in maximum-randomly overlaping in a vertical column. +!!\param semiss lw surface emissivity +!!\param delp layer pressure thickness (mb) +!!\param cldfrc layer cloud fraction +!!\param taucld layer cloud opt depth +!!\param tautot total optical depth (gas+aerosols) +!!\param pklay integrated planck func at lay temp +!!\param pklev integrated planck func at lev temp +!!\param fracs planck fractions +!!\param secdif secant of diffusivity angle +!!\param nlay number of vertical layers +!!\param nlp1 number of vertical levels (interfaces) +!!\param totuflux total sky upward flux (\f$w/m^2\f$) +!!\param totdflux total sky downward flux (\f$w/m^2\f$) +!!\param htr total sky heating rate (k/sec or k/day) +!!\param totuclfl clear sky upward flux (\f$w/m^2\f$) +!!\param totdclfl clear sky downward flux (\f$w/m^2\f$) +!!\param htrcl clear sky heating rate (k/sec or k/day) +!!\param htrb spectral band lw heating rate (k/day) +!!\section gen_rtrnmr rtrnmr General Algorithm +!> @{ +! ---------------------------------- + subroutine rtrnmr & + & ( semiss,delp,cldfrc,taucld,tautot,pklay,pklev, &! --- inputs + & fracs,secdif, nlay,nlp1, & + & totuflux,totdflux,htr, totuclfl,totdclfl,htrcl, htrb & ! --- outputs: + & ) + +! =================== program usage description =================== ! +! ! +! purpose: compute the upward/downward radiative fluxes, and heating ! +! rates for both clear or cloudy atmosphere. clouds are assumed as in ! +! maximum-randomly overlaping in a vertical colum. ! +! ! +! subprograms called: none ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: -size- ! +! semiss - real, lw surface emissivity nbands! +! delp - real, layer pressure thickness (mb) nlay ! +! cldfrc - real, layer cloud fraction 0:nlp1 ! +! taucld - real, layer cloud opt depth nbands,nlay! +! tautot - real, total optical depth (gas+aerosols) ngptlw,nlay! +! pklay - real, integrated planck func at lay temp nbands*0:nlay! +! pklev - real, integrated planck func at lev temp nbands*0:nlay! +! fracs - real, planck fractions ngptlw,nlay! +! secdif - real, secant of diffusivity angle nbands! +! nlay - integer, number of vertical layers 1 ! +! nlp1 - integer, number of vertical levels (interfaces) 1 ! +! ! +! outputs: ! +! totuflux- real, total sky upward flux (w/m2) 0:nlay ! +! totdflux- real, total sky downward flux (w/m2) 0:nlay ! +! htr - real, total sky heating rate (k/sec or k/day) nlay ! +! totuclfl- real, clear sky upward flux (w/m2) 0:nlay ! +! totdclfl- real, clear sky downward flux (w/m2) 0:nlay ! +! htrcl - real, clear sky heating rate (k/sec or k/day) nlay ! +! htrb - real, spectral band lw heating rate (k/day) nlay*nbands! +! ! +! module veriables: ! +! ngb - integer, band index for each g-value ngptlw! +! fluxfac - real, conversion factor for fluxes (pi*2.e4) 1 ! +! heatfac - real, conversion factor for heating rates (g/cp*1e-2) 1 ! +! tblint - real, conversion factor for look-up tbl (float(ntbl) 1 ! +! bpade - real, pade approx constant (1/0.278) 1 ! +! wtdiff - real, weight for radiance to flux conversion 1 ! +! ntbl - integer, dimension of look-up tables 1 ! +! tau_tbl - real, clr-sky opt dep lookup table 0:ntbl ! +! exp_tbl - real, transmittance lookup table 0:ntbl ! +! tfn_tbl - real, tau transition function 0:ntbl ! +! ! +! local variables: ! +! itgas - integer, index for gases contribution look-up table 1 ! +! ittot - integer, index for gases plus clouds look-up table 1 ! +! reflct - real, surface reflectance 1 ! +! atrgas - real, gaseous absorptivity 1 ! +! atrtot - real, gaseous and cloud absorptivity 1 ! +! odcld - real, cloud optical depth 1 ! +! odepth - real, optical depth of gaseous only 1 ! +! odtot - real, optical depth of gas and cloud 1 ! +! gasfac - real, gas-only pade factor, used for planck fn 1 ! +! totfac - real, gas+cld pade factor, used for planck fn 1 ! +! bbdgas - real, gas-only planck function for downward rt 1 ! +! bbugas - real, gas-only planck function for upward rt 1 ! +! bbdtot - real, gas and cloud planck function for downward rt 1 ! +! bbutot - real, gas and cloud planck function for upward rt 1 ! +! gassrcu- real, upwd source radiance due to gas only nlay! +! totsrcu- real, upwd source radiance due to gas + cld nlay! +! gassrcd- real, dnwd source radiance due to gas only 1 ! +! totsrcd- real, dnwd source radiance due to gas + cld 1 ! +! radtotu- real, spectrally summed total sky upwd radiance 1 ! +! radclru- real, spectrally summed clear sky upwd radiance 1 ! +! radtotd- real, spectrally summed total sky dnwd radiance 1 ! +! radclrd- real, spectrally summed clear sky dnwd radiance 1 ! +! toturad- real, total sky upward radiance by layer 0:nlay*nbands! +! clrurad- real, clear sky upward radiance by layer 0:nlay*nbands! +! totdrad- real, total sky downward radiance by layer 0:nlay*nbands! +! clrdrad- real, clear sky downward radiance by layer 0:nlay*nbands! +! fnet - real, net longwave flux (w/m2) 0:nlay ! +! fnetc - real, clear sky net longwave flux (w/m2) 0:nlay ! +! ! +! ! +! ******************************************************************* ! +! original code description ! +! ! +! original version: e. j. mlawer, et al. rrtm_v3.0 ! +! revision for gcms: michael j. iacono; october, 2002 ! +! revision for f90: michael j. iacono; june, 2006 ! +! ! +! this program calculates the upward fluxes, downward fluxes, and ! +! heating rates for an arbitrary clear or cloudy atmosphere. the input ! +! to this program is the atmospheric profile, all Planck function ! +! information, and the cloud fraction by layer. a variable diffusivity! +! angle (secdif) is used for the angle integration. bands 2-3 and 5-9 ! +! use a value for secdif that varies from 1.50 to 1.80 as a function ! +! of the column water vapor, and other bands use a value of 1.66. the ! +! gaussian weight appropriate to this angle (wtdiff=0.5) is applied ! +! here. note that use of the emissivity angle for the flux integration! +! can cause errors of 1 to 4 W/m2 within cloudy layers. ! +! clouds are treated with a maximum-random cloud overlap method. ! +! ! +! ******************************************************************* ! +! ====================== end of description block ================= ! + +! --- inputs: + integer, intent(in) :: nlay, nlp1 + + real (kind=kind_phys), dimension(0:nlp1), intent(in) :: cldfrc + real (kind=kind_phys), dimension(nbands), intent(in) :: semiss, & + & secdif + real (kind=kind_phys), dimension(nlay), intent(in) :: delp + + real (kind=kind_phys), dimension(nbands,nlay),intent(in):: taucld + real (kind=kind_phys), dimension(ngptlw,nlay),intent(in):: fracs, & + & tautot + + real (kind=kind_phys), dimension(nbands,0:nlay), intent(in) :: & + & pklev, pklay + +! --- outputs: + real (kind=kind_phys), dimension(nlay), intent(out) :: htr, htrcl + + real (kind=kind_phys), dimension(nlay,nbands),intent(out) :: htrb + + real (kind=kind_phys), dimension(0:nlay), intent(out) :: & + & totuflux, totdflux, totuclfl, totdclfl + +! --- locals: + real (kind=kind_phys), parameter :: rec_6 = 0.166667 + + real (kind=kind_phys), dimension(0:nlay,nbands) :: clrurad, & + & clrdrad, toturad, totdrad + + real (kind=kind_phys), dimension(nlay) :: gassrcu, totsrcu, & + & trngas, trntot, rfdelp + real (kind=kind_phys), dimension(0:nlay) :: fnet, fnetc + + real (kind=kind_phys) :: totsrcd, gassrcd, tblind, odepth, odtot, & + & odcld, atrtot, atrgas, reflct, totfac, gasfac, flxfac, & + & plfrac, blay, bbdgas, bbdtot, bbugas, bbutot, dplnku, & + & dplnkd, radtotu, radclru, radtotd, radclrd, rad0, rad, & + & totradd, clrradd, totradu, clrradu, fmax, fmin, rat1, rat2,& + & radmod, clfr, trng, trnt, gasu, totu + + integer :: ittot, itgas, ib, ig, k + +! dimensions for cloud overlap adjustment + real (kind=kind_phys), dimension(nlp1) :: faccld1u, faccld2u, & + & facclr1u, facclr2u, faccmb1u, faccmb2u + real (kind=kind_phys), dimension(0:nlay) :: faccld1d, faccld2d, & + & facclr1d, facclr2d, faccmb1d, faccmb2d + + logical :: lstcldu(nlay), lstcldd(nlay) +! +!===> ... begin here +! + do k = 1, nlp1 + faccld1u(k) = f_zero + faccld2u(k) = f_zero + facclr1u(k) = f_zero + facclr2u(k) = f_zero + faccmb1u(k) = f_zero + faccmb2u(k) = f_zero + enddo + + lstcldu(1) = cldfrc(1) > eps + rat1 = f_zero + rat2 = f_zero + + do k = 1, nlay-1 + + lstcldu(k+1) = cldfrc(k+1)>eps .and. cldfrc(k)<=eps + + if (cldfrc(k) > eps) then + +!> -# Setup maximum/random cloud overlap. + + if (cldfrc(k+1) >= cldfrc(k)) then + if (lstcldu(k)) then + if (cldfrc(k) < f_one) then + facclr2u(k+1) = (cldfrc(k+1) - cldfrc(k)) & + & / (f_one - cldfrc(k)) + endif + facclr2u(k) = f_zero + faccld2u(k) = f_zero + else + fmax = max(cldfrc(k), cldfrc(k-1)) + if (cldfrc(k+1) > fmax) then + facclr1u(k+1) = rat2 + facclr2u(k+1) = (cldfrc(k+1) - fmax)/(f_one - fmax) + elseif (cldfrc(k+1) < fmax) then + facclr1u(k+1) = (cldfrc(k+1) - cldfrc(k)) & + & / (cldfrc(k-1) - cldfrc(k)) + else + facclr1u(k+1) = rat2 + endif + endif + + if (facclr1u(k+1)>f_zero .or. facclr2u(k+1)>f_zero) then + rat1 = f_one + rat2 = f_zero + else + rat1 = f_zero + rat2 = f_zero + endif + else + if (lstcldu(k)) then + faccld2u(k+1) = (cldfrc(k) - cldfrc(k+1)) / cldfrc(k) + facclr2u(k) = f_zero + faccld2u(k) = f_zero + else + fmin = min(cldfrc(k), cldfrc(k-1)) + if (cldfrc(k+1) <= fmin) then + faccld1u(k+1) = rat1 + faccld2u(k+1) = (fmin - cldfrc(k+1)) / fmin + else + faccld1u(k+1) = (cldfrc(k) - cldfrc(k+1)) & + & / (cldfrc(k) - fmin) + endif + endif + + if (faccld1u(k+1)>f_zero .or. faccld2u(k+1)>f_zero) then + rat1 = f_zero + rat2 = f_one + else + rat1 = f_zero + rat2 = f_zero + endif + endif + + faccmb1u(k+1) = facclr1u(k+1) * faccld2u(k) * cldfrc(k-1) + faccmb2u(k+1) = faccld1u(k+1) * facclr2u(k) & + & * (f_one - cldfrc(k-1)) + endif + + enddo + + do k = 0, nlay + faccld1d(k) = f_zero + faccld2d(k) = f_zero + facclr1d(k) = f_zero + facclr2d(k) = f_zero + faccmb1d(k) = f_zero + faccmb2d(k) = f_zero + enddo + + lstcldd(nlay) = cldfrc(nlay) > eps + rat1 = f_zero + rat2 = f_zero + + do k = nlay, 2, -1 + + lstcldd(k-1) = cldfrc(k-1) > eps .and. cldfrc(k)<=eps + + if (cldfrc(k) > eps) then + + if (cldfrc(k-1) >= cldfrc(k)) then + if (lstcldd(k)) then + if (cldfrc(k) < f_one) then + facclr2d(k-1) = (cldfrc(k-1) - cldfrc(k)) & + & / (f_one - cldfrc(k)) + endif + + facclr2d(k) = f_zero + faccld2d(k) = f_zero + else + fmax = max(cldfrc(k), cldfrc(k+1)) + + if (cldfrc(k-1) > fmax) then + facclr1d(k-1) = rat2 + facclr2d(k-1) = (cldfrc(k-1) - fmax) / (f_one - fmax) + elseif (cldfrc(k-1) < fmax) then + facclr1d(k-1) = (cldfrc(k-1) - cldfrc(k)) & + & / (cldfrc(k+1) - cldfrc(k)) + else + facclr1d(k-1) = rat2 + endif + endif + + if (facclr1d(k-1)>f_zero .or. facclr2d(k-1)>f_zero) then + rat1 = f_one + rat2 = f_zero + else + rat1 = f_zero + rat2 = f_zero + endif + else + if (lstcldd(k)) then + faccld2d(k-1) = (cldfrc(k) - cldfrc(k-1)) / cldfrc(k) + facclr2d(k) = f_zero + faccld2d(k) = f_zero + else + fmin = min(cldfrc(k), cldfrc(k+1)) + + if (cldfrc(k-1) <= fmin) then + faccld1d(k-1) = rat1 + faccld2d(k-1) = (fmin - cldfrc(k-1)) / fmin + else + faccld1d(k-1) = (cldfrc(k) - cldfrc(k-1)) & + & / (cldfrc(k) - fmin) + endif + endif + + if (faccld1d(k-1)>f_zero .or. faccld2d(k-1)>f_zero) then + rat1 = f_zero + rat2 = f_one + else + rat1 = f_zero + rat2 = f_zero + endif + endif + + faccmb1d(k-1) = facclr1d(k-1) * faccld2d(k) * cldfrc(k+1) + faccmb2d(k-1) = faccld1d(k-1) * facclr2d(k) & + & * (f_one - cldfrc(k+1)) + endif + + enddo + +!> -# Initialize for radiative transfer + + do ib = 1, NBANDS + do k = 0, NLAY + toturad(k,ib) = f_zero + totdrad(k,ib) = f_zero + clrurad(k,ib) = f_zero + clrdrad(k,ib) = f_zero + enddo + enddo + + do k = 0, nlay + totuflux(k) = f_zero + totdflux(k) = f_zero + totuclfl(k) = f_zero + totdclfl(k) = f_zero + enddo + +! --- ... loop over all g-points + + do ig = 1, ngptlw + ib = ngb(ig) + + radtotd = f_zero + radclrd = f_zero + +!> -# Downward radiative transfer loop: + + do k = nlay, 1, -1 + +! --- ... clear sky, gases contribution + + odepth = max( f_zero, secdif(ib)*tautot(ig,k) ) + if (odepth <= 0.06) then + atrgas = odepth - 0.5*odepth*odepth + trng = f_one - atrgas + gasfac = rec_6 * odepth + else + tblind = odepth / (bpade + odepth) + itgas = tblint*tblind + 0.5 + trng = exp_tbl(itgas) + atrgas = f_one - trng + gasfac = tfn_tbl(itgas) + odepth = tau_tbl(itgas) + endif + + plfrac = fracs(ig,k) + blay = pklay(ib,k) + + dplnku = pklev(ib,k ) - blay + dplnkd = pklev(ib,k-1) - blay + bbdgas = plfrac * (blay + dplnkd*gasfac) + bbugas = plfrac * (blay + dplnku*gasfac) + gassrcd = bbdgas * atrgas + gassrcu(k)= bbugas * atrgas + trngas(k) = trng + +! --- ... total sky, gases+clouds contribution + + clfr = cldfrc(k) + if (lstcldd(k)) then + totradd = clfr * radtotd + clrradd = radtotd - totradd + rad = f_zero + endif + + if (clfr >= eps) then +!> - cloudy layer + + odcld = secdif(ib) * taucld(ib,k) + odtot = odepth + odcld + if (odtot < 0.06) then + totfac = rec_6 * odtot + atrtot = odtot - 0.5*odtot*odtot + trnt = f_one - atrtot + else + tblind = odtot / (bpade + odtot) + ittot = tblint*tblind + 0.5 + totfac = tfn_tbl(ittot) + trnt = exp_tbl(ittot) + atrtot = f_one - trnt + endif + + bbdtot = plfrac * (blay + dplnkd*totfac) + bbutot = plfrac * (blay + dplnku*totfac) + totsrcd = bbdtot * atrtot + totsrcu(k)= bbutot * atrtot + trntot(k) = trnt + + totradd = totradd*trnt + clfr*totsrcd + clrradd = clrradd*trng + (f_one - clfr)*gassrcd + +!> - total sky radiance + radtotd = totradd + clrradd + totdrad(k-1,ib) = totdrad(k-1,ib) + radtotd + +!> - clear sky radiance + radclrd = radclrd*trng + gassrcd + clrdrad(k-1,ib) = clrdrad(k-1,ib) + radclrd + + radmod = rad*(facclr1d(k-1)*trng + faccld1d(k-1)*trnt) & + & - faccmb1d(k-1)*gassrcd + faccmb2d(k-1)*totsrcd + + rad = -radmod + facclr2d(k-1)*(clrradd + radmod) & + & - faccld2d(k-1)*(totradd - radmod) + totradd = totradd + rad + clrradd = clrradd - rad + + else +! --- ... clear layer + +! --- ... total sky radiance + radtotd = radtotd*trng + gassrcd + totdrad(k-1,ib) = totdrad(k-1,ib) + radtotd + +! --- ... clear sky radiance + radclrd = radclrd*trng + gassrcd + clrdrad(k-1,ib) = clrdrad(k-1,ib) + radclrd + + endif ! end if_clfr_block + + enddo ! end do_k_loop + +!> -# Compute spectral emissivity & reflectance, include the +!! contribution of spectrally varying longwave emissivity and +!! reflection from the surface to the upward radiative transfer. + +! note: spectral and Lambertian reflection are identical for the +! diffusivity angle flux integration used here. + + reflct = f_one - semiss(ib) + rad0 = semiss(ib) * fracs(ig,1) * pklay(ib,0) + +!> -# Compute total sky radiance. + radtotu = rad0 + reflct*radtotd + toturad(0,ib) = toturad(0,ib) + radtotu + +!> -# Compute clear sky radiance. + radclru = rad0 + reflct*radclrd + clrurad(0,ib) = clrurad(0,ib) + radclru + +!> -# Upward radiative transfer loop: + + do k = 1, nlay + + clfr = cldfrc(k) + trng = trngas(k) + gasu = gassrcu(k) + + if (lstcldu(k)) then + totradu = clfr * radtotu + clrradu = radtotu - totradu + rad = f_zero + endif + + if (clfr >= eps) then +!> - cloudy layer radiance + + trnt = trntot(k) + totu = totsrcu(k) + totradu = totradu*trnt + clfr*totu + clrradu = clrradu*trng + (f_one - clfr)*gasu + +!> - total sky radiance + radtotu = totradu + clrradu + toturad(k,ib) = toturad(k,ib) + radtotu + +!> - clear sky radiance + radclru = radclru*trng + gasu + clrurad(k,ib) = clrurad(k,ib) + radclru + + radmod = rad*(facclr1u(k+1)*trng + faccld1u(k+1)*trnt) & + & - faccmb1u(k+1)*gasu + faccmb2u(k+1)*totu + rad = -radmod + facclr2u(k+1)*(clrradu + radmod) & + & - faccld2u(k+1)*(totradu - radmod) + totradu = totradu + rad + clrradu = clrradu - rad + + else +! --- ... clear layer + +! --- ... total sky radiance + radtotu = radtotu*trng + gasu + toturad(k,ib) = toturad(k,ib) + radtotu + +! --- ... clear sky radiance + radclru = radclru*trng + gasu + clrurad(k,ib) = clrurad(k,ib) + radclru + + endif ! end if_clfr_block + + enddo ! end do_k_loop + + enddo ! end do_ig_loop + +!> -# Process longwave output from band for total and clear streams. +!! calculate upward, downward, and net flux. + + flxfac = wtdiff * fluxfac + + do k = 0, nlay + do ib = 1, nbands + totuflux(k) = totuflux(k) + toturad(k,ib) + totdflux(k) = totdflux(k) + totdrad(k,ib) + totuclfl(k) = totuclfl(k) + clrurad(k,ib) + totdclfl(k) = totdclfl(k) + clrdrad(k,ib) + enddo + + totuflux(k) = totuflux(k) * flxfac + totdflux(k) = totdflux(k) * flxfac + totuclfl(k) = totuclfl(k) * flxfac + totdclfl(k) = totdclfl(k) * flxfac + enddo + +! --- ... calculate net fluxes and heating rates + fnet(0) = totuflux(0) - totdflux(0) + + do k = 1, nlay + rfdelp(k) = heatfac / delp(k) + fnet(k) = totuflux(k) - totdflux(k) + htr (k) = (fnet(k-1) - fnet(k)) * rfdelp(k) + enddo + +!! --- ... optional clear sky heating rates + if ( lhlw0 ) then + fnetc(0) = totuclfl(0) - totdclfl(0) + + do k = 1, nlay + fnetc(k) = totuclfl(k) - totdclfl(k) + htrcl(k) = (fnetc(k-1) - fnetc(k)) * rfdelp(k) + enddo + endif + +!! --- ... optional spectral band heating rates + if ( lhlwb ) then + do ib = 1, nbands + fnet(0) = (toturad(0,ib) - totdrad(0,ib)) * flxfac + + do k = 1, nlay + fnet(k) = (toturad(k,ib) - totdrad(k,ib)) * flxfac + htrb(k,ib) = (fnet(k-1) - fnet(k)) * rfdelp(k) + enddo + enddo + endif + +! ................................. + end subroutine rtrnmr +! --------------------------------- +!> @} + +!>\ingroup module_radlw_main +!> \brief This subroutine computes the upward/downward radiative fluxes, and +!! heating rates for both clear or cloudy atmosphere.Clouds are treated +!! with the mcica stochastic approach. +!! +!!\param semiss lw surface emissivity +!!\param delp layer pressure thickness (mb) +!!\param cldfmc layer cloud fraction (sub-column) +!!\param taucld layer cloud opt depth +!!\param tautot total optical depth (gas+aerosols) +!!\param pklay integrated planck func at lay temp +!!\param pklev integrated planck func at lev temp +!!\param fracs planck fractions +!!\param secdif secant of diffusivity angle +!!\param nlay number of vertical layers +!!\param nlp1 number of vertical levels (interfaces) +!!\param totuflux total sky upward flux \f$(w/m^2)\f$ +!!\param totdflux total sky downward flux \f$(w/m^2)\f$ +!!\param htr total sky heating rate (k/sec or k/day) +!!\param totuclfl clear sky upward flux \f$(w/m^2)\f$ +!!\param totdclfl clear sky downward flux \f$(w/m^2)\f$ +!!\param htrcl clear sky heating rate (k/sec or k/day) +!!\param htrb spectral band lw heating rate (k/day) +!!\section gen_rtrnmc rtrnmc General Algorithm +!> @{ +! --------------------------------- + subroutine rtrnmc & + & ( semiss,delp,cldfmc,taucld,tautot,pklay,pklev, & ! --- inputs: + & fracs,secdif, nlay,nlp1, & + & totuflux,totdflux,htr, totuclfl,totdclfl,htrcl, htrb & ! --- outputs: + & ) + +! =================== program usage description =================== ! +! ! +! purpose: compute the upward/downward radiative fluxes, and heating ! +! rates for both clear or cloudy atmosphere. clouds are treated with ! +! the mcica stochastic approach. ! +! ! +! subprograms called: none ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: -size- ! +! semiss - real, lw surface emissivity nbands! +! delp - real, layer pressure thickness (mb) nlay ! +! cldfmc - real, layer cloud fraction (sub-column) ngptlw*nlay! +! taucld - real, layer cloud opt depth nbands*nlay! +! tautot - real, total optical depth (gas+aerosols) ngptlw*nlay! +! pklay - real, integrated planck func at lay temp nbands*0:nlay! +! pklev - real, integrated planck func at lev temp nbands*0:nlay! +! fracs - real, planck fractions ngptlw*nlay! +! secdif - real, secant of diffusivity angle nbands! +! nlay - integer, number of vertical layers 1 ! +! nlp1 - integer, number of vertical levels (interfaces) 1 ! +! ! +! outputs: ! +! totuflux- real, total sky upward flux (w/m2) 0:nlay ! +! totdflux- real, total sky downward flux (w/m2) 0:nlay ! +! htr - real, total sky heating rate (k/sec or k/day) nlay ! +! totuclfl- real, clear sky upward flux (w/m2) 0:nlay ! +! totdclfl- real, clear sky downward flux (w/m2) 0:nlay ! +! htrcl - real, clear sky heating rate (k/sec or k/day) nlay ! +! htrb - real, spectral band lw heating rate (k/day) nlay*nbands! +! ! +! module veriables: ! +! ngb - integer, band index for each g-value ngptlw! +! fluxfac - real, conversion factor for fluxes (pi*2.e4) 1 ! +! heatfac - real, conversion factor for heating rates (g/cp*1e-2) 1 ! +! tblint - real, conversion factor for look-up tbl (float(ntbl) 1 ! +! bpade - real, pade approx constant (1/0.278) 1 ! +! wtdiff - real, weight for radiance to flux conversion 1 ! +! ntbl - integer, dimension of look-up tables 1 ! +! tau_tbl - real, clr-sky opt dep lookup table 0:ntbl ! +! exp_tbl - real, transmittance lookup table 0:ntbl ! +! tfn_tbl - real, tau transition function 0:ntbl ! +! ! +! local variables: ! +! itgas - integer, index for gases contribution look-up table 1 ! +! ittot - integer, index for gases plus clouds look-up table 1 ! +! reflct - real, surface reflectance 1 ! +! atrgas - real, gaseous absorptivity 1 ! +! atrtot - real, gaseous and cloud absorptivity 1 ! +! odcld - real, cloud optical depth 1 ! +! efclrfr- real, effective clear sky fraction (1-efcldfr) nlay! +! odepth - real, optical depth of gaseous only 1 ! +! odtot - real, optical depth of gas and cloud 1 ! +! gasfac - real, gas-only pade factor, used for planck function 1 ! +! totfac - real, gas and cloud pade factor, used for planck fn 1 ! +! bbdgas - real, gas-only planck function for downward rt 1 ! +! bbugas - real, gas-only planck function for upward rt 1 ! +! bbdtot - real, gas and cloud planck function for downward rt 1 ! +! bbutot - real, gas and cloud planck function for upward rt 1 ! +! gassrcu- real, upwd source radiance due to gas nlay! +! totsrcu- real, upwd source radiance due to gas+cld nlay! +! gassrcd- real, dnwd source radiance due to gas 1 ! +! totsrcd- real, dnwd source radiance due to gas+cld 1 ! +! radtotu- real, spectrally summed total sky upwd radiance 1 ! +! radclru- real, spectrally summed clear sky upwd radiance 1 ! +! radtotd- real, spectrally summed total sky dnwd radiance 1 ! +! radclrd- real, spectrally summed clear sky dnwd radiance 1 ! +! toturad- real, total sky upward radiance by layer 0:nlay*nbands! +! clrurad- real, clear sky upward radiance by layer 0:nlay*nbands! +! totdrad- real, total sky downward radiance by layer 0:nlay*nbands! +! clrdrad- real, clear sky downward radiance by layer 0:nlay*nbands! +! fnet - real, net longwave flux (w/m2) 0:nlay ! +! fnetc - real, clear sky net longwave flux (w/m2) 0:nlay ! +! ! +! ! +! ******************************************************************* ! +! original code description ! +! ! +! original version: e. j. mlawer, et al. rrtm_v3.0 ! +! revision for gcms: michael j. iacono; october, 2002 ! +! revision for f90: michael j. iacono; june, 2006 ! +! ! +! this program calculates the upward fluxes, downward fluxes, and ! +! heating rates for an arbitrary clear or cloudy atmosphere. the input ! +! to this program is the atmospheric profile, all Planck function ! +! information, and the cloud fraction by layer. a variable diffusivity! +! angle (secdif) is used for the angle integration. bands 2-3 and 5-9 ! +! use a value for secdif that varies from 1.50 to 1.80 as a function ! +! of the column water vapor, and other bands use a value of 1.66. the ! +! gaussian weight appropriate to this angle (wtdiff=0.5) is applied ! +! here. note that use of the emissivity angle for the flux integration! +! can cause errors of 1 to 4 W/m2 within cloudy layers. ! +! clouds are treated with the mcica stochastic approach and ! +! maximum-random cloud overlap. ! +! ! +! ******************************************************************* ! +! ====================== end of description block ================= ! + +! --- inputs: + integer, intent(in) :: nlay, nlp1 + + real (kind=kind_phys), dimension(nbands), intent(in) :: semiss, & + & secdif + real (kind=kind_phys), dimension(nlay), intent(in) :: delp + + real (kind=kind_phys), dimension(nbands,nlay),intent(in):: taucld + real (kind=kind_phys), dimension(ngptlw,nlay),intent(in):: fracs, & + & tautot, cldfmc + + real (kind=kind_phys), dimension(nbands,0:nlay), intent(in) :: & + & pklev, pklay + +! --- outputs: + real (kind=kind_phys), dimension(nlay), intent(out) :: htr, htrcl + + real (kind=kind_phys), dimension(nlay,nbands),intent(out) :: htrb + + real (kind=kind_phys), dimension(0:nlay), intent(out) :: & + & totuflux, totdflux, totuclfl, totdclfl + +! --- locals: + real (kind=kind_phys), parameter :: rec_6 = 0.166667 + + real (kind=kind_phys), dimension(0:nlay,nbands) :: clrurad, & + & clrdrad, toturad, totdrad + + real (kind=kind_phys), dimension(nlay) :: gassrcu, totsrcu, & + & trngas, efclrfr, rfdelp + real (kind=kind_phys), dimension(0:nlay) :: fnet, fnetc + + real (kind=kind_phys) :: totsrcd, gassrcd, tblind, odepth, odtot, & + & odcld, atrtot, atrgas, reflct, totfac, gasfac, flxfac, & + & plfrac, blay, bbdgas, bbdtot, bbugas, bbutot, dplnku, & + & dplnkd, radtotu, radclru, radtotd, radclrd, rad0, & + & clfm, trng, gasu + + integer :: ittot, itgas, ib, ig, k +! +!===> ... begin here +! + do ib = 1, NBANDS + do k = 0, NLAY + toturad(k,ib) = f_zero + totdrad(k,ib) = f_zero + clrurad(k,ib) = f_zero + clrdrad(k,ib) = f_zero + enddo + enddo + + do k = 0, nlay + totuflux(k) = f_zero + totdflux(k) = f_zero + totuclfl(k) = f_zero + totdclfl(k) = f_zero + enddo + +! --- ... loop over all g-points + + do ig = 1, ngptlw + ib = ngb(ig) + + radtotd = f_zero + radclrd = f_zero + +!> -# Downward radiative transfer loop. +!!\n - Clear sky, gases contribution +!!\n - Total sky, gases+clouds contribution +!!\n - Cloudy layer +!!\n - Total sky radiance +!!\n - Clear sky radiance + + do k = nlay, 1, -1 + +! --- ... clear sky, gases contribution + + odepth = max( f_zero, secdif(ib)*tautot(ig,k) ) + if (odepth <= 0.06) then + atrgas = odepth - 0.5*odepth*odepth + trng = f_one - atrgas + gasfac = rec_6 * odepth + else + tblind = odepth / (bpade + odepth) + itgas = tblint*tblind + 0.5 + trng = exp_tbl(itgas) + atrgas = f_one - trng + gasfac = tfn_tbl(itgas) + odepth = tau_tbl(itgas) + endif + + plfrac = fracs(ig,k) + blay = pklay(ib,k) + + dplnku = pklev(ib,k ) - blay + dplnkd = pklev(ib,k-1) - blay + bbdgas = plfrac * (blay + dplnkd*gasfac) + bbugas = plfrac * (blay + dplnku*gasfac) + gassrcd= bbdgas * atrgas + gassrcu(k)= bbugas * atrgas + trngas(k) = trng + +! --- ... total sky, gases+clouds contribution + + clfm = cldfmc(ig,k) + if (clfm >= eps) then +! --- ... cloudy layer + + odcld = secdif(ib) * taucld(ib,k) + efclrfr(k) = f_one - (f_one - exp(-odcld))*clfm + odtot = odepth + odcld + if (odtot < 0.06) then + totfac = rec_6 * odtot + atrtot = odtot - 0.5*odtot*odtot + else + tblind = odtot / (bpade + odtot) + ittot = tblint*tblind + 0.5 + totfac = tfn_tbl(ittot) + atrtot = f_one - exp_tbl(ittot) + endif + + bbdtot = plfrac * (blay + dplnkd*totfac) + bbutot = plfrac * (blay + dplnku*totfac) + totsrcd= bbdtot * atrtot + totsrcu(k)= bbutot * atrtot + +! --- ... total sky radiance + radtotd = radtotd*trng*efclrfr(k) + gassrcd & + & + clfm*(totsrcd - gassrcd) + totdrad(k-1,ib) = totdrad(k-1,ib) + radtotd + +! --- ... clear sky radiance + radclrd = radclrd*trng + gassrcd + clrdrad(k-1,ib) = clrdrad(k-1,ib) + radclrd + + else +! --- ... clear layer + +! --- ... total sky radiance + radtotd = radtotd*trng + gassrcd + totdrad(k-1,ib) = totdrad(k-1,ib) + radtotd + +! --- ... clear sky radiance + radclrd = radclrd*trng + gassrcd + clrdrad(k-1,ib) = clrdrad(k-1,ib) + radclrd + + endif ! end if_clfm_block + + enddo ! end do_k_loop + +!> -# Compute spectral emissivity & reflectance, include the +!! contribution of spectrally varying longwave emissivity and +!! reflection from the surface to the upward radiative transfer. + +! note: spectral and Lambertian reflection are identical for the +! diffusivity angle flux integration used here. + + reflct = f_one - semiss(ib) + rad0 = semiss(ib) * fracs(ig,1) * pklay(ib,0) + +!> -# Compute total sky radiance. + radtotu = rad0 + reflct*radtotd + toturad(0,ib) = toturad(0,ib) + radtotu + +!> -# Compute clear sky radiance. + radclru = rad0 + reflct*radclrd + clrurad(0,ib) = clrurad(0,ib) + radclru + +!> -# Upward radiative transfer loop. +!!\n - Compute total sky radiance +!!\n - Compute clear sky radiance + +! toturad holds summed radiance for total sky stream +! clrurad holds summed radiance for clear sky stream + + do k = 1, nlay + clfm = cldfmc(ig,k) + trng = trngas(k) + gasu = gassrcu(k) + + if (clfm > eps) then +! --- ... cloudy layer + +! --- ... total sky radiance + radtotu = radtotu*trng*efclrfr(k) + gasu & + & + clfm*(totsrcu(k) - gasu) + toturad(k,ib) = toturad(k,ib) + radtotu + +! --- ... clear sky radiance + radclru = radclru*trng + gasu + clrurad(k,ib) = clrurad(k,ib) + radclru + + else +! --- ... clear layer + +! --- ... total sky radiance + radtotu = radtotu*trng + gasu + toturad(k,ib) = toturad(k,ib) + radtotu + +! --- ... clear sky radiance + radclru = radclru*trng + gasu + clrurad(k,ib) = clrurad(k,ib) + radclru + + endif ! end if_clfm_block + + enddo ! end do_k_loop + + enddo ! end do_ig_loop + +!> -# Process longwave output from band for total and clear streams. +!! Calculate upward, downward, and net flux. + + flxfac = wtdiff * fluxfac + + do k = 0, nlay + do ib = 1, nbands + totuflux(k) = totuflux(k) + toturad(k,ib) + totdflux(k) = totdflux(k) + totdrad(k,ib) + totuclfl(k) = totuclfl(k) + clrurad(k,ib) + totdclfl(k) = totdclfl(k) + clrdrad(k,ib) + enddo + + totuflux(k) = totuflux(k) * flxfac + totdflux(k) = totdflux(k) * flxfac + totuclfl(k) = totuclfl(k) * flxfac + totdclfl(k) = totdclfl(k) * flxfac + enddo + +!> -# Calculate net fluxes and heating rates. + fnet(0) = totuflux(0) - totdflux(0) + + do k = 1, nlay + rfdelp(k) = heatfac / delp(k) + fnet(k) = totuflux(k) - totdflux(k) + htr (k) = (fnet(k-1) - fnet(k)) * rfdelp(k) + enddo + +!> -# Optional clear sky heating rates. + if ( lhlw0 ) then + fnetc(0) = totuclfl(0) - totdclfl(0) + + do k = 1, nlay + fnetc(k) = totuclfl(k) - totdclfl(k) + htrcl(k) = (fnetc(k-1) - fnetc(k)) * rfdelp(k) + enddo + endif + +!> -# Optional spectral band heating rates. + if ( lhlwb ) then + do ib = 1, nbands + fnet(0) = (toturad(0,ib) - totdrad(0,ib)) * flxfac + + do k = 1, nlay + fnet(k) = (toturad(k,ib) - totdrad(k,ib)) * flxfac + htrb(k,ib) = (fnet(k-1) - fnet(k)) * rfdelp(k) + enddo + enddo + endif + +! .................................. + end subroutine rtrnmc +! ---------------------------------- +!> @} + +!>\ingroup module_radlw_main +!>\brief This subroutine contains optical depths developed for the rapid +!! radiative transfer model. +!! +!! It contains the subroutines \a taugbn (where n goes from +!! 1 to 16). \a taugbn calculates the optical depths and planck fractions +!! per g-value and layer for band n. +!!\param laytrop tropopause layer index (unitless) layer at +!! which switch is made for key species +!!\param pavel layer pressures (mb) +!!\param coldry column amount for dry air \f$(mol/cm^2)\f$ +!!\param colamt column amounts of h2o, co2, o3, n2o, ch4,o2, +!! co \f$(mol/cm^2)\f$ +!!\param colbrd column amount of broadening gases +!!\param wx cross-section amounts \f$(mol/cm^2)\f$ +!!\param tauaer aerosol optical depth +!!\param rfrate reference ratios of binary species parameter +!!\n (:,m,:)m=1-h2o/co2,2-h2o/o3,3-h2o/n2o,4-h2o/ch4, +!! 5-n2o/co2,6-o3/co2 +!!\n (:,:,n)n=1,2: the rates of ref press at the 2 +!! sides of the layer +!!\param fac00,fac01,fac10,fac11 factors multiply the reference ks, i,j of 0/1 +!! for lower/higher of the 2 appropriate +!! temperatures and altitudes +!!\param jp index of lower reference pressure +!!\param jt, jt1 indices of lower reference temperatures for +!! pressure levels jp and jp+1, respectively +!!\param selffac scale factor for water vapor self-continuum +!! equals (water vapor density)/(atmospheric +!! density at 296k and 1013 mb) +!!\param selffrac factor for temperature interpolation of +!! reference water vapor self-continuum data +!!\param indself index of lower reference temperature for the +!! self-continuum interpolation +!!\param forfac scale factor for w. v. foreign-continuum +!!\param forfrac factor for temperature interpolation of +!! reference w.v. foreign-continuum data +!!\param indfor index of lower reference temperature for the +!! foreign-continuum interpolation +!!\param minorfrac factor for minor gases +!!\param scaleminor,scaleminorn2 scale factors for minor gases +!!\param indminor index of lower reference temperature for +!! minor gases +!!\param nlay total number of layers +!!\param fracs planck fractions +!!\param tautot total optical depth (gas+aerosols) +!>\section taumol_gen taumol General Algorithm +!! @{ +!! subprograms called: taugb## (## = 01 -16) + subroutine taumol & + & ( laytrop,pavel,coldry,colamt,colbrd,wx,tauaer, & ! --- inputs + & rfrate,fac00,fac01,fac10,fac11,jp,jt,jt1, & + & selffac,selffrac,indself,forfac,forfrac,indfor, & + & minorfrac,scaleminor,scaleminorn2,indminor, & + & nlay, & + & fracs, tautot & ! --- outputs + & ) + +! ************ original subprogram description *************** ! +! ! +! optical depths developed for the ! +! ! +! rapid radiative transfer model (rrtm) ! +! ! +! atmospheric and environmental research, inc. ! +! 131 hartwell avenue ! +! lexington, ma 02421 ! +! ! +! eli j. mlawer ! +! jennifer delamere ! +! steven j. taubman ! +! shepard a. clough ! +! ! +! email: mlawer@aer.com ! +! email: jdelamer@aer.com ! +! ! +! the authors wish to acknowledge the contributions of the ! +! following people: karen cady-pereira, patrick d. brown, ! +! michael j. iacono, ronald e. farren, luke chen, ! +! robert bergstrom. ! +! ! +! revision for g-point reduction: michael j. iacono; aer, inc. ! +! ! +! taumol ! +! ! +! this file contains the subroutines taugbn (where n goes from ! +! 1 to 16). taugbn calculates the optical depths and planck ! +! fractions per g-value and layer for band n. ! +! ! +! ******************************************************************* ! +! ================== program usage description ================== ! +! ! +! call taumol ! +! inputs: ! +! ( laytrop,pavel,coldry,colamt,colbrd,wx,tauaer, ! +! rfrate,fac00,fac01,fac10,fac11,jp,jt,jt1, ! +! selffac,selffrac,indself,forfac,forfrac,indfor, ! +! minorfrac,scaleminor,scaleminorn2,indminor, ! +! nlay, ! +! outputs: ! +! fracs, tautot ) ! +! ! +! subprograms called: taugb## (## = 01 -16) ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! laytrop - integer, tropopause layer index (unitless) 1 ! +! layer at which switch is made for key species ! +! pavel - real, layer pressures (mb) nlay ! +! coldry - real, column amount for dry air (mol/cm2) nlay ! +! colamt - real, column amounts of h2o, co2, o3, n2o, ch4, ! +! o2, co (mol/cm**2) nlay*maxgas! +! colbrd - real, column amount of broadening gases nlay ! +! wx - real, cross-section amounts(mol/cm2) nlay*maxxsec! +! tauaer - real, aerosol optical depth nbands*nlay ! +! rfrate - real, reference ratios of binary species parameter ! +! (:,m,:)m=1-h2o/co2,2-h2o/o3,3-h2o/n2o,4-h2o/ch4,5-n2o/co2,6-o3/co2! +! (:,:,n)n=1,2: the rates of ref press at the 2 sides of the layer ! +! nlay*nrates*2! +! facij - real, factors multiply the reference ks, i,j of 0/1 ! +! for lower/higher of the 2 appropriate temperatures ! +! and altitudes nlay ! +! jp - real, index of lower reference pressure nlay ! +! jt, jt1 - real, indices of lower reference temperatures nlay ! +! for pressure levels jp and jp+1, respectively ! +! selffac - real, scale factor for water vapor self-continuum ! +! equals (water vapor density)/(atmospheric density ! +! at 296k and 1013 mb) nlay ! +! selffrac - real, factor for temperature interpolation of ! +! reference water vapor self-continuum data nlay ! +! indself - integer, index of lower reference temperature for ! +! the self-continuum interpolation nlay ! +! forfac - real, scale factor for w. v. foreign-continuum nlay ! +! forfrac - real, factor for temperature interpolation of ! +! reference w.v. foreign-continuum data nlay ! +! indfor - integer, index of lower reference temperature for ! +! the foreign-continuum interpolation nlay ! +! minorfrac - real, factor for minor gases nlay ! +! scaleminor,scaleminorn2 ! +! - real, scale factors for minor gases nlay ! +! indminor - integer, index of lower reference temperature for ! +! minor gases nlay ! +! nlay - integer, total number of layers 1 ! +! ! +! outputs: ! +! fracs - real, planck fractions ngptlw,nlay! +! tautot - real, total optical depth (gas+aerosols) ngptlw,nlay! +! ! +! internal variables: ! +! ng## - integer, number of g-values in band ## (##=01-16) 1 ! +! nspa - integer, for lower atmosphere, the number of ref ! +! atmos, each has different relative amounts of the ! +! key species for the band nbands! +! nspb - integer, same but for upper atmosphere nbands! +! absa - real, k-values for lower ref atmospheres (no w.v. ! +! self-continuum) (cm**2/molecule) nspa(##)*5*13*ng##! +! absb - real, k-values for high ref atmospheres (all sources) ! +! (cm**2/molecule) nspb(##)*5*13:59*ng##! +! ka_m'mgas'- real, k-values for low ref atmospheres minor species ! +! (cm**2/molecule) mmn##*ng##! +! kb_m'mgas'- real, k-values for high ref atmospheres minor species ! +! (cm**2/molecule) mmn##*ng##! +! selfref - real, k-values for w.v. self-continuum for ref atmos ! +! used below laytrop (cm**2/mol) 10*ng##! +! forref - real, k-values for w.v. foreign-continuum for ref atmos +! used below/above laytrop (cm**2/mol) 4*ng##! +! ! +! ****************************************************************** ! + +! --- inputs: + integer, intent(in) :: nlay, laytrop + + integer, dimension(nlay), intent(in) :: jp, jt, jt1, indself, & + & indfor, indminor + + real (kind=kind_phys), dimension(nlay), intent(in) :: pavel, & + & coldry, colbrd, fac00, fac01, fac10, fac11, selffac, & + & selffrac, forfac, forfrac, minorfrac, scaleminor, & + & scaleminorn2 + + real (kind=kind_phys), dimension(nlay,maxgas), intent(in):: colamt + real (kind=kind_phys), dimension(nlay,maxxsec),intent(in):: wx + + real (kind=kind_phys), dimension(nbands,nlay), intent(in):: tauaer + + real (kind=kind_phys), dimension(nlay,nrates,2), intent(in) :: & + & rfrate + +! --- outputs: + real (kind=kind_phys), dimension(ngptlw,nlay), intent(out) :: & + & fracs, tautot + +! --- locals + real (kind=kind_phys), dimension(ngptlw,nlay) :: taug + + integer :: ib, ig, k +! +!===> ... begin here +! + call taugb01 + call taugb02 + call taugb03 + call taugb04 + call taugb05 + call taugb06 + call taugb07 + call taugb08 + call taugb09 + call taugb10 + call taugb11 + call taugb12 + call taugb13 + call taugb14 + call taugb15 + call taugb16 + +! --- combine gaseous and aerosol optical depths + + do ig = 1, ngptlw + ib = ngb(ig) + + do k = 1, nlay + tautot(ig,k) = taug(ig,k) + tauaer(ib,k) + enddo + enddo + +! ================= + contains +! ================= + +!>\ingroup module_radlw_main +!> band 1: 10-350 cm-1 (low key - h2o; low minor - n2); +!! (high key - h2o; high minor - n2) +! ---------------------------------- + subroutine taugb01 +! .................................. + +! ------------------------------------------------------------------ ! +! written by eli j. mlawer, atmospheric & environmental research. ! +! revised by michael j. iacono, atmospheric & environmental research. ! +! ! +! band 1: 10-350 cm-1 (low key - h2o; low minor - n2) ! +! (high key - h2o; high minor - n2) ! +! ! +! compute the optical depth by interpolating in ln(pressure) and ! +! temperature. below laytrop, the water vapor self-continuum and ! +! foreign continuum is interpolated (in temperature) separately. ! +! ------------------------------------------------------------------ ! + + use module_radlw_kgb01 + +! --- locals: + integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, & + & indm, indmp, ig + + real (kind=kind_phys) :: pp, corradj, scalen2, tauself, taufor, & + & taun2 +! +!===> ... begin here +! +! --- minor gas mapping levels: +! lower - n2, p = 142.5490 mbar, t = 215.70 k +! upper - n2, p = 142.5490 mbar, t = 215.70 k + +! --- ... lower atmosphere loop + + do k = 1, laytrop + ind0 = ((jp(k)-1)*5 + (jt (k)-1)) * nspa(1) + 1 + ind1 = ( jp(k) *5 + (jt1(k)-1)) * nspa(1) + 1 + inds = indself(k) + indf = indfor(k) + indm = indminor(k) + + ind0p = ind0 + 1 + ind1p = ind1 + 1 + indsp = inds + 1 + indfp = indf + 1 + indmp = indm + 1 + + pp = pavel(k) + scalen2 = colbrd(k) * scaleminorn2(k) + if (pp < 250.0) then + corradj = f_one - 0.15 * (250.0-pp) / 154.4 + else + corradj = f_one + endif + + do ig = 1, ng01 + tauself = selffac(k) * (selfref(ig,inds) + selffrac(k) & + & * (selfref(ig,indsp) - selfref(ig,inds))) + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + taun2 = scalen2 * (ka_mn2(ig,indm) + minorfrac(k) & + & * (ka_mn2(ig,indmp) - ka_mn2(ig,indm))) + + taug(ig,k) = corradj * (colamt(k,1) & + & * (fac00(k)*absa(ig,ind0) + fac10(k)*absa(ig,ind0p) & + & + fac01(k)*absa(ig,ind1) + fac11(k)*absa(ig,ind1p)) & + & + tauself + taufor + taun2) + + fracs(ig,k) = fracrefa(ig) + enddo + enddo + +! --- ... upper atmosphere loop + + do k = laytrop+1, nlay + ind0 = ((jp(k)-13)*5 + (jt (k)-1)) * nspb(1) + 1 + ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(1) + 1 + indf = indfor(k) + indm = indminor(k) + + ind0p = ind0 + 1 + ind1p = ind1 + 1 + indfp = indf + 1 + indmp = indm + 1 + + scalen2 = colbrd(k) * scaleminorn2(k) + corradj = f_one - 0.15 * (pavel(k) / 95.6) + + do ig = 1, ng01 + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + taun2 = scalen2 * (kb_mn2(ig,indm) + minorfrac(k) & + & * (kb_mn2(ig,indmp) - kb_mn2(ig,indm))) + + taug(ig,k) = corradj * (colamt(k,1) & + & * (fac00(k)*absb(ig,ind0) + fac10(k)*absb(ig,ind0p) & + & + fac01(k)*absb(ig,ind1) + fac11(k)*absb(ig,ind1p)) & + & + taufor + taun2) + + fracs(ig,k) = fracrefb(ig) + enddo + enddo + +! .................................. + end subroutine taugb01 +! ---------------------------------- + +!>\ingroup module_radlw_main +!> Band 2: 350-500 cm-1 (low key - h2o; high key - h2o) +! ---------------------------------- + subroutine taugb02 +! .................................. + +! ------------------------------------------------------------------ ! +! band 2: 350-500 cm-1 (low key - h2o; high key - h2o) ! +! ------------------------------------------------------------------ ! + + use module_radlw_kgb02 + +! --- locals: + integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, & + & ig + + real (kind=kind_phys) :: corradj, tauself, taufor +! +!===> ... begin here +! +! --- ... lower atmosphere loop + + do k = 1, laytrop + ind0 = ((jp(k)-1)*5 + (jt (k)-1)) * nspa(2) + 1 + ind1 = ( jp(k) *5 + (jt1(k)-1)) * nspa(2) + 1 + inds = indself(k) + indf = indfor(k) + + ind0p = ind0 + 1 + ind1p = ind1 + 1 + indsp = inds + 1 + indfp = indf + 1 + + corradj = f_one - 0.05 * (pavel(k) - 100.0) / 900.0 + + do ig = 1, ng02 + tauself = selffac(k) * (selfref(ig,inds) + selffrac(k) & + & * (selfref(ig,indsp) - selfref(ig,inds))) + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + + taug(ns02+ig,k) = corradj * (colamt(k,1) & + & * (fac00(k)*absa(ig,ind0) + fac10(k)*absa(ig,ind0p) & + & + fac01(k)*absa(ig,ind1) + fac11(k)*absa(ig,ind1p)) & + & + tauself + taufor) + + fracs(ns02+ig,k) = fracrefa(ig) + enddo + enddo + +! --- ... upper atmosphere loop + + do k = laytrop+1, nlay + ind0 = ((jp(k)-13)*5 + (jt (k)-1)) * nspb(2) + 1 + ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(2) + 1 + indf = indfor(k) + + ind0p = ind0 + 1 + ind1p = ind1 + 1 + indfp = indf + 1 + + do ig = 1, ng02 + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + + taug(ns02+ig,k) = colamt(k,1) & + & * (fac00(k)*absb(ig,ind0) + fac10(k)*absb(ig,ind0p) & + & + fac01(k)*absb(ig,ind1) + fac11(k)*absb(ig,ind1p)) & + & + taufor + + fracs(ns02+ig,k) = fracrefb(ig) + enddo + enddo + +! .................................. + end subroutine taugb02 +! ---------------------------------- + +!>\ingroup module_radlw_main +!> Band 3: 500-630 cm-1 (low key - h2o,co2; low minor - n2o); +!! (high key - h2o,co2; high minor - n2o) +! ---------------------------------- + subroutine taugb03 +! .................................. + +! ------------------------------------------------------------------ ! +! band 3: 500-630 cm-1 (low key - h2o,co2; low minor - n2o) ! +! (high key - h2o,co2; high minor - n2o) ! +! ------------------------------------------------------------------ ! + + use module_radlw_kgb03 + +! --- locals: + integer :: k, ind0, ind1, inds, indsp, indf, indfp, indm, indmp, & + & id000, id010, id100, id110, id200, id210, jmn2o, jmn2op, & + & id001, id011, id101, id111, id201, id211, jpl, jplp, & + & ig, js, js1 + + real (kind=kind_phys) :: absn2o, ratn2o, adjfac, adjcoln2o, & + & speccomb, specparm, specmult, fs, & + & speccomb1, specparm1, specmult1, fs1, & + & speccomb_mn2o, specparm_mn2o, specmult_mn2o, fmn2o, & + & speccomb_planck,specparm_planck,specmult_planck,fpl, & + & refrat_planck_a, refrat_planck_b, refrat_m_a, refrat_m_b, & + & fac000, fac100, fac200, fac010, fac110, fac210, & + & fac001, fac101, fac201, fac011, fac111, fac211, & + & tau_major, tau_major1, tauself, taufor, n2om1, n2om2, & + & p, p4, fk0, fk1, fk2 +! +!===> ... begin here +! +! --- ... minor gas mapping levels: +! lower - n2o, p = 706.272 mbar, t = 278.94 k +! upper - n2o, p = 95.58 mbar, t = 215.7 k + + refrat_planck_a = chi_mls(1,9)/chi_mls(2,9) ! P = 212.725 mb + refrat_planck_b = chi_mls(1,13)/chi_mls(2,13) ! P = 95.58 mb + refrat_m_a = chi_mls(1,3)/chi_mls(2,3) ! P = 706.270 mb + refrat_m_b = chi_mls(1,13)/chi_mls(2,13) ! P = 95.58 mb + +! --- ... lower atmosphere loop + + do k = 1, laytrop + speccomb = colamt(k,1) + rfrate(k,1,1)*colamt(k,2) + specparm = colamt(k,1) / speccomb + specmult = 8.0 * min(specparm, oneminus) + js = 1 + int(specmult) + fs = mod(specmult, f_one) + ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(3) + js + + speccomb1 = colamt(k,1) + rfrate(k,1,2)*colamt(k,2) + specparm1 = colamt(k,1) / speccomb1 + specmult1 = 8.0 * min(specparm1, oneminus) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1, f_one) + ind1 = (jp(k)*5 + (jt1(k)-1)) * nspa(3) + js1 + + speccomb_mn2o = colamt(k,1) + refrat_m_a*colamt(k,2) + specparm_mn2o = colamt(k,1) / speccomb_mn2o + specmult_mn2o = 8.0 * min(specparm_mn2o, oneminus) + jmn2o = 1 + int(specmult_mn2o) + fmn2o = mod(specmult_mn2o, f_one) + + speccomb_planck = colamt(k,1) + refrat_planck_a*colamt(k,2) + specparm_planck = colamt(k,1) / speccomb_planck + specmult_planck = 8.0 * min(specparm_planck, oneminus) + jpl = 1 + int(specmult_planck) + fpl = mod(specmult_planck, f_one) + + inds = indself(k) + indf = indfor(k) + indm = indminor(k) + indsp = inds + 1 + indfp = indf + 1 + indmp = indm + 1 + jmn2op= jmn2o+ 1 + jplp = jpl + 1 + +! --- ... in atmospheres where the amount of n2O is too great to be considered +! a minor species, adjust the column amount of n2O by an empirical factor +! to obtain the proper contribution. + + p = coldry(k) * chi_mls(4,jp(k)+1) + ratn2o = colamt(k,4) / p + if (ratn2o > 1.5) then + adjfac = 0.5 + (ratn2o - 0.5)**0.65 + adjcoln2o = adjfac * p + else + adjcoln2o = colamt(k,4) + endif + + if (specparm < 0.125) then + p = fs - f_one + p4 = p**4 + fk0 = p4 + fk1 = f_one - p - 2.0*p4 + fk2 = p + p4 + id000 = ind0 + id010 = ind0 + 9 + id100 = ind0 + 1 + id110 = ind0 +10 + id200 = ind0 + 2 + id210 = ind0 +11 + else if (specparm > 0.875) then + p = -fs + p4 = p**4 + fk0 = p4 + fk1 = f_one - p - 2.0*p4 + fk2 = p + p4 + id000 = ind0 + 1 + id010 = ind0 +10 + id100 = ind0 + id110 = ind0 + 9 + id200 = ind0 - 1 + id210 = ind0 + 8 + else + fk0 = f_one - fs + fk1 = fs + fk2 = f_zero + id000 = ind0 + id010 = ind0 + 9 + id100 = ind0 + 1 + id110 = ind0 +10 + id200 = ind0 + id210 = ind0 + endif + + fac000 = fk0*fac00(k) + fac100 = fk1*fac00(k) + fac200 = fk2*fac00(k) + fac010 = fk0*fac10(k) + fac110 = fk1*fac10(k) + fac210 = fk2*fac10(k) + + if (specparm1 < 0.125) then + p = fs1 - f_one + p4 = p**4 + fk0 = p4 + fk1 = f_one - p - 2.0*p4 + fk2 = p + p4 + id001 = ind1 + id011 = ind1 + 9 + id101 = ind1 + 1 + id111 = ind1 +10 + id201 = ind1 + 2 + id211 = ind1 +11 + elseif (specparm1 > 0.875) then + p = -fs1 + p4 = p**4 + fk0 = p4 + fk1 = f_one - p - 2.0*p4 + fk2 = p + p4 + id001 = ind1 + 1 + id011 = ind1 +10 + id101 = ind1 + id111 = ind1 + 9 + id201 = ind1 - 1 + id211 = ind1 + 8 + else + fk0 = f_one - fs1 + fk1 = fs1 + fk2 = f_zero + id001 = ind1 + id011 = ind1 + 9 + id101 = ind1 + 1 + id111 = ind1 +10 + id201 = ind1 + id211 = ind1 + endif + + fac001 = fk0*fac01(k) + fac101 = fk1*fac01(k) + fac201 = fk2*fac01(k) + fac011 = fk0*fac11(k) + fac111 = fk1*fac11(k) + fac211 = fk2*fac11(k) + + do ig = 1, ng03 + tauself = selffac(k)* (selfref(ig,inds) + selffrac(k) & + & * (selfref(ig,indsp) - selfref(ig,inds))) + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + n2om1 = ka_mn2o(ig,jmn2o,indm) + fmn2o & + & * (ka_mn2o(ig,jmn2op,indm) - ka_mn2o(ig,jmn2o,indm)) + n2om2 = ka_mn2o(ig,jmn2o,indmp) + fmn2o & + & * (ka_mn2o(ig,jmn2op,indmp) - ka_mn2o(ig,jmn2o,indmp)) + absn2o = n2om1 + minorfrac(k) * (n2om2 - n2om1) + + tau_major = speccomb & + & * (fac000*absa(ig,id000) + fac010*absa(ig,id010) & + & + fac100*absa(ig,id100) + fac110*absa(ig,id110) & + & + fac200*absa(ig,id200) + fac210*absa(ig,id210)) + + tau_major1 = speccomb1 & + & * (fac001*absa(ig,id001) + fac011*absa(ig,id011) & + & + fac101*absa(ig,id101) + fac111*absa(ig,id111) & + & + fac201*absa(ig,id201) + fac211*absa(ig,id211)) + + taug(ns03+ig,k) = tau_major + tau_major1 & + & + tauself + taufor + adjcoln2o*absn2o + + fracs(ns03+ig,k) = fracrefa(ig,jpl) + fpl & + & * (fracrefa(ig,jplp) - fracrefa(ig,jpl)) + enddo ! end do_k_loop + enddo ! end do_ig_loop + +! --- ... upper atmosphere loop + + do k = laytrop+1, nlay + speccomb = colamt(k,1) + rfrate(k,1,1)*colamt(k,2) + specparm = colamt(k,1) / speccomb + specmult = 4.0 * min(specparm, oneminus) + js = 1 + int(specmult) + fs = mod(specmult, f_one) + ind0 = ((jp(k)-13)*5 + (jt(k)-1)) * nspb(3) + js + + speccomb1 = colamt(k,1) + rfrate(k,1,2)*colamt(k,2) + specparm1 = colamt(k,1) / speccomb1 + specmult1 = 4.0 * min(specparm1, oneminus) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1, f_one) + ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(3) + js1 + + speccomb_mn2o = colamt(k,1) + refrat_m_b*colamt(k,2) + specparm_mn2o = colamt(k,1) / speccomb_mn2o + specmult_mn2o = 4.0 * min(specparm_mn2o, oneminus) + jmn2o = 1 + int(specmult_mn2o) + fmn2o = mod(specmult_mn2o, f_one) + + speccomb_planck = colamt(k,1) + refrat_planck_b*colamt(k,2) + specparm_planck = colamt(k,1) / speccomb_planck + specmult_planck = 4.0 * min(specparm_planck, oneminus) + jpl = 1 + int(specmult_planck) + fpl = mod(specmult_planck, f_one) + + indf = indfor(k) + indm = indminor(k) + indfp = indf + 1 + indmp = indm + 1 + jmn2op= jmn2o+ 1 + jplp = jpl + 1 + + id000 = ind0 + id010 = ind0 + 5 + id100 = ind0 + 1 + id110 = ind0 + 6 + id001 = ind1 + id011 = ind1 + 5 + id101 = ind1 + 1 + id111 = ind1 + 6 + +! --- ... in atmospheres where the amount of n2o is too great to be considered +! a minor species, adjust the column amount of N2O by an empirical factor +! to obtain the proper contribution. + + p = coldry(k) * chi_mls(4,jp(k)+1) + ratn2o = colamt(k,4) / p + if (ratn2o > 1.5) then + adjfac = 0.5 + (ratn2o - 0.5)**0.65 + adjcoln2o = adjfac * p + else + adjcoln2o = colamt(k,4) + endif + + fk0 = f_one - fs + fk1 = fs + fac000 = fk0*fac00(k) + fac010 = fk0*fac10(k) + fac100 = fk1*fac00(k) + fac110 = fk1*fac10(k) + + fk0 = f_one - fs1 + fk1 = fs1 + fac001 = fk0*fac01(k) + fac011 = fk0*fac11(k) + fac101 = fk1*fac01(k) + fac111 = fk1*fac11(k) + + do ig = 1, ng03 + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + n2om1 = kb_mn2o(ig,jmn2o,indm) + fmn2o & + & * (kb_mn2o(ig,jmn2op,indm) - kb_mn2o(ig,jmn2o,indm)) + n2om2 = kb_mn2o(ig,jmn2o,indmp) + fmn2o & + & * (kb_mn2o(ig,jmn2op,indmp) - kb_mn2o(ig,jmn2o,indmp)) + absn2o = n2om1 + minorfrac(k) * (n2om2 - n2om1) + + tau_major = speccomb & + & * (fac000*absb(ig,id000) + fac010*absb(ig,id010) & + & + fac100*absb(ig,id100) + fac110*absb(ig,id110)) + + tau_major1 = speccomb1 & + & * (fac001*absb(ig,id001) + fac011*absb(ig,id011) & + & + fac101*absb(ig,id101) + fac111*absb(ig,id111)) + + taug(ns03+ig,k) = tau_major + tau_major1 & + & + taufor + adjcoln2o*absn2o + + fracs(ns03+ig,k) = fracrefb(ig,jpl) + fpl & + & * (fracrefb(ig,jplp) - fracrefb(ig,jpl)) + enddo + enddo + +! .................................. + end subroutine taugb03 +! ---------------------------------- + +!>\ingroup module_radlw_main +!> Band 4: 630-700 cm-1 (low key - h2o,co2; high key - o3,co2) +! ---------------------------------- + subroutine taugb04 +! .................................. + +! ------------------------------------------------------------------ ! +! band 4: 630-700 cm-1 (low key - h2o,co2; high key - o3,co2) ! +! ------------------------------------------------------------------ ! + + use module_radlw_kgb04 + +! --- locals: + integer :: k, ind0, ind1, inds, indsp, indf, indfp, jpl, jplp, & + & id000, id010, id100, id110, id200, id210, ig, js, js1, & + & id001, id011, id101, id111, id201, id211 + + real (kind=kind_phys) :: tauself, taufor, p, p4, fk0, fk1, fk2, & + & speccomb, specparm, specmult, fs, & + & speccomb1, specparm1, specmult1, fs1, & + & speccomb_planck,specparm_planck,specmult_planck,fpl, & + & fac000, fac100, fac200, fac010, fac110, fac210, & + & fac001, fac101, fac201, fac011, fac111, fac211, & + & refrat_planck_a, refrat_planck_b, tau_major, tau_major1 +! +!===> ... begin here +! + refrat_planck_a = chi_mls(1,11)/chi_mls(2,11) ! P = 142.5940 mb + refrat_planck_b = chi_mls(3,13)/chi_mls(2,13) ! P = 95.58350 mb + +! --- ... lower atmosphere loop + + do k = 1, laytrop + speccomb = colamt(k,1) + rfrate(k,1,1)*colamt(k,2) + specparm = colamt(k,1) / speccomb + specmult = 8.0 * min(specparm, oneminus) + js = 1 + int(specmult) + fs = mod(specmult, f_one) + ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(4) + js + + speccomb1 = colamt(k,1) + rfrate(k,1,2)*colamt(k,2) + specparm1 = colamt(k,1) / speccomb1 + specmult1 = 8.0 * min(specparm1, oneminus) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1, f_one) + ind1 = ( jp(k)*5 + (jt1(k)-1)) * nspa(4) + js1 + + speccomb_planck = colamt(k,1) + refrat_planck_a*colamt(k,2) + specparm_planck = colamt(k,1) / speccomb_planck + specmult_planck = 8.0 * min(specparm_planck, oneminus) + jpl = 1 + int(specmult_planck) + fpl = mod(specmult_planck, 1.0) + + inds = indself(k) + indf = indfor(k) + indsp = inds + 1 + indfp = indf + 1 + jplp = jpl + 1 + + if (specparm < 0.125) then + p = fs - f_one + p4 = p**4 + fk0 = p4 + fk1 = f_one - p - 2.0*p4 + fk2 = p + p4 + id000 = ind0 + id010 = ind0 + 9 + id100 = ind0 + 1 + id110 = ind0 +10 + id200 = ind0 + 2 + id210 = ind0 +11 + elseif (specparm > 0.875) then + p = -fs + p4 = p**4 + fk0 = p4 + fk1 = f_one - p - 2.0*p4 + fk2 = p + p4 + id000 = ind0 + 1 + id010 = ind0 +10 + id100 = ind0 + id110 = ind0 + 9 + id200 = ind0 - 1 + id210 = ind0 + 8 + else + fk0 = f_one - fs + fk1 = fs + fk2 = f_zero + id000 = ind0 + id010 = ind0 + 9 + id100 = ind0 + 1 + id110 = ind0 +10 + id200 = ind0 + id210 = ind0 + endif + + fac000 = fk0*fac00(k) + fac100 = fk1*fac00(k) + fac200 = fk2*fac00(k) + fac010 = fk0*fac10(k) + fac110 = fk1*fac10(k) + fac210 = fk2*fac10(k) + + if (specparm1 < 0.125) then + p = fs1 - f_one + p4 = p**4 + fk0 = p4 + fk1 = f_one - p - 2.0*p4 + fk2 = p + p4 + id001 = ind1 + id011 = ind1 + 9 + id101 = ind1 + 1 + id111 = ind1 +10 + id201 = ind1 + 2 + id211 = ind1 +11 + elseif (specparm1 > 0.875) then + p = -fs1 + p4 = p**4 + fk0 = p4 + fk1 = f_one - p - 2.0*p4 + fk2 = p + p4 + id001 = ind1 + 1 + id011 = ind1 +10 + id101 = ind1 + id111 = ind1 + 9 + id201 = ind1 - 1 + id211 = ind1 + 8 + else + fk0 = f_one - fs1 + fk1 = fs1 + fk2 = f_zero + id001 = ind1 + id011 = ind1 + 9 + id101 = ind1 + 1 + id111 = ind1 +10 + id201 = ind1 + id211 = ind1 + endif + + fac001 = fk0*fac01(k) + fac101 = fk1*fac01(k) + fac201 = fk2*fac01(k) + fac011 = fk0*fac11(k) + fac111 = fk1*fac11(k) + fac211 = fk2*fac11(k) + + do ig = 1, ng04 + tauself = selffac(k)* (selfref(ig,inds) + selffrac(k) & + & * (selfref(ig,indsp) - selfref(ig,inds))) + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + + tau_major = speccomb & + & * (fac000*absa(ig,id000) + fac010*absa(ig,id010) & + & + fac100*absa(ig,id100) + fac110*absa(ig,id110) & + & + fac200*absa(ig,id200) + fac210*absa(ig,id210)) + + tau_major1 = speccomb1 & + & * (fac001*absa(ig,id001) + fac011*absa(ig,id011) & + & + fac101*absa(ig,id101) + fac111*absa(ig,id111) & + & + fac201*absa(ig,id201) + fac211*absa(ig,id211)) + + taug(ns04+ig,k) = tau_major + tau_major1 + tauself + taufor + + fracs(ns04+ig,k) = fracrefa(ig,jpl) + fpl & + & * (fracrefa(ig,jplp) - fracrefa(ig,jpl)) + enddo ! end do_k_loop + enddo ! end do_ig_loop + +! --- ... upper atmosphere loop + + do k = laytrop+1, nlay + speccomb = colamt(k,3) + rfrate(k,6,1)*colamt(k,2) + specparm = colamt(k,3) / speccomb + specmult = 4.0 * min(specparm, oneminus) + js = 1 + int(specmult) + fs = mod(specmult, f_one) + ind0 = ((jp(k)-13)*5 + (jt(k)-1)) * nspb(4) + js + + speccomb1 = colamt(k,3) + rfrate(k,6,2)*colamt(k,2) + specparm1 = colamt(k,3) / speccomb1 + specmult1 = 4.0 * min(specparm1, oneminus) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1, f_one) + ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(4) + js1 + + speccomb_planck = colamt(k,3) + refrat_planck_b*colamt(k,2) + specparm_planck = colamt(k,3) / speccomb_planck + specmult_planck = 4.0 * min(specparm_planck, oneminus) + jpl = 1 + int(specmult_planck) + fpl = mod(specmult_planck, f_one) + jplp = jpl + 1 + + id000 = ind0 + id010 = ind0 + 5 + id100 = ind0 + 1 + id110 = ind0 + 6 + id001 = ind1 + id011 = ind1 + 5 + id101 = ind1 + 1 + id111 = ind1 + 6 + + fk0 = f_one - fs + fk1 = fs + fac000 = fk0*fac00(k) + fac010 = fk0*fac10(k) + fac100 = fk1*fac00(k) + fac110 = fk1*fac10(k) + + fk0 = f_one - fs1 + fk1 = fs1 + fac001 = fk0*fac01(k) + fac011 = fk0*fac11(k) + fac101 = fk1*fac01(k) + fac111 = fk1*fac11(k) + + do ig = 1, ng04 + tau_major = speccomb & + & * (fac000*absb(ig,id000) + fac010*absb(ig,id010) & + & + fac100*absb(ig,id100) + fac110*absb(ig,id110)) + tau_major1 = speccomb1 & + & * (fac001*absb(ig,id001) + fac011*absb(ig,id011) & + & + fac101*absb(ig,id101) + fac111*absb(ig,id111)) + + taug(ns04+ig,k) = tau_major + tau_major1 + + fracs(ns04+ig,k) = fracrefb(ig,jpl) + fpl & + & * (fracrefb(ig,jplp) - fracrefb(ig,jpl)) + enddo + +! --- ... empirical modification to code to improve stratospheric cooling rates +! for co2. revised to apply weighting for g-point reduction in this band. + + taug(ns04+ 8,k) = taug(ns04+ 8,k) * 0.92 + taug(ns04+ 9,k) = taug(ns04+ 9,k) * 0.88 + taug(ns04+10,k) = taug(ns04+10,k) * 1.07 + taug(ns04+11,k) = taug(ns04+11,k) * 1.1 + taug(ns04+12,k) = taug(ns04+12,k) * 0.99 + taug(ns04+13,k) = taug(ns04+13,k) * 0.88 + taug(ns04+14,k) = taug(ns04+14,k) * 0.943 + enddo + +! .................................. + end subroutine taugb04 +! ---------------------------------- + +!>\ingroup module_radlw_main +!> Band 5: 700-820 cm-1 (low key - h2o,co2; low minor - o3, ccl4) +!! (high key - o3,co2) +! ---------------------------------- + subroutine taugb05 +! .................................. + +! ------------------------------------------------------------------ ! +! band 5: 700-820 cm-1 (low key - h2o,co2; low minor - o3, ccl4) ! +! (high key - o3,co2) ! +! ------------------------------------------------------------------ ! + + use module_radlw_kgb05 + +! --- locals: + integer :: k, ind0, ind1, inds, indsp, indf, indfp, indm, indmp, & + & id000, id010, id100, id110, id200, id210, jmo3, jmo3p, & + & id001, id011, id101, id111, id201, id211, jpl, jplp, & + & ig, js, js1 + + real (kind=kind_phys) :: tauself, taufor, o3m1, o3m2, abso3, & + & speccomb, specparm, specmult, fs, & + & speccomb1, specparm1, specmult1, fs1, & + & speccomb_mo3, specparm_mo3, specmult_mo3, fmo3, & + & speccomb_planck,specparm_planck,specmult_planck,fpl, & + & refrat_planck_a, refrat_planck_b, refrat_m_a, & + & fac000, fac100, fac200, fac010, fac110, fac210, & + & fac001, fac101, fac201, fac011, fac111, fac211, & + & p0, p40, fk00, fk10, fk20, p1, p41, fk01, fk11, fk21 +! +!===> ... begin here +! +! --- ... minor gas mapping level : +! lower - o3, p = 317.34 mbar, t = 240.77 k +! lower - ccl4 + +! --- ... calculate reference ratio to be used in calculation of Planck +! fraction in lower/upper atmosphere. + + refrat_planck_a = chi_mls(1,5)/chi_mls(2,5) ! P = 473.420 mb + refrat_planck_b = chi_mls(3,43)/chi_mls(2,43) ! P = 0.2369 mb + refrat_m_a = chi_mls(1,7)/chi_mls(2,7) ! P = 317.348 mb + +! --- ... lower atmosphere loop + + do k = 1, laytrop + speccomb = colamt(k,1) + rfrate(k,1,1)*colamt(k,2) + specparm = colamt(k,1) / speccomb + specmult = 8.0 * min(specparm, oneminus) + js = 1 + int(specmult) + fs = mod(specmult, f_one) + ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(5) + js + + speccomb1 = colamt(k,1) + rfrate(k,1,2)*colamt(k,2) + specparm1 = colamt(k,1) / speccomb1 + specmult1 = 8.0 * min(specparm1, oneminus) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1, f_one) + ind1 = (jp(k)*5 + (jt1(k)-1)) * nspa(5) + js1 + + speccomb_mo3 = colamt(k,1) + refrat_m_a*colamt(k,2) + specparm_mo3 = colamt(k,1) / speccomb_mo3 + specmult_mo3 = 8.0 * min(specparm_mo3, oneminus) + jmo3 = 1 + int(specmult_mo3) + fmo3 = mod(specmult_mo3, f_one) + + speccomb_planck = colamt(k,1) + refrat_planck_a*colamt(k,2) + specparm_planck = colamt(k,1) / speccomb_planck + specmult_planck = 8.0 * min(specparm_planck, oneminus) + jpl = 1 + int(specmult_planck) + fpl = mod(specmult_planck, f_one) + + inds = indself(k) + indf = indfor(k) + indm = indminor(k) + indsp = inds + 1 + indfp = indf + 1 + indmp = indm + 1 + jplp = jpl + 1 + jmo3p = jmo3 + 1 + + if (specparm < 0.125) then + p0 = fs - f_one + p40 = p0**4 + fk00 = p40 + fk10 = f_one - p0 - 2.0*p40 + fk20 = p0 + p40 + + id000 = ind0 + id010 = ind0 + 9 + id100 = ind0 + 1 + id110 = ind0 +10 + id200 = ind0 + 2 + id210 = ind0 +11 + elseif (specparm > 0.875) then + p0 = -fs + p40 = p0**4 + fk00 = p40 + fk10 = f_one - p0 - 2.0*p40 + fk20 = p0 + p40 + + id000 = ind0 + 1 + id010 = ind0 +10 + id100 = ind0 + id110 = ind0 + 9 + id200 = ind0 - 1 + id210 = ind0 + 8 + else + fk00 = f_one - fs + fk10 = fs + fk20 = f_zero + + id000 = ind0 + id010 = ind0 + 9 + id100 = ind0 + 1 + id110 = ind0 +10 + id200 = ind0 + id210 = ind0 + endif + + fac000 = fk00 * fac00(k) + fac100 = fk10 * fac00(k) + fac200 = fk20 * fac00(k) + fac010 = fk00 * fac10(k) + fac110 = fk10 * fac10(k) + fac210 = fk20 * fac10(k) + + if (specparm1 < 0.125) then + p1 = fs1 - f_one + p41 = p1**4 + fk01 = p41 + fk11 = f_one - p1 - 2.0*p41 + fk21 = p1 + p41 + + id001 = ind1 + id011 = ind1 + 9 + id101 = ind1 + 1 + id111 = ind1 +10 + id201 = ind1 + 2 + id211 = ind1 +11 + elseif (specparm1 > 0.875) then + p1 = -fs1 + p41 = p1**4 + fk01 = p41 + fk11 = f_one - p1 - 2.0*p41 + fk21 = p1 + p41 + + id001 = ind1 + 1 + id011 = ind1 +10 + id101 = ind1 + id111 = ind1 + 9 + id201 = ind1 - 1 + id211 = ind1 + 8 + else + fk01 = f_one - fs1 + fk11 = fs1 + fk21 = f_zero + + id001 = ind1 + id011 = ind1 + 9 + id101 = ind1 + 1 + id111 = ind1 +10 + id201 = ind1 + id211 = ind1 + endif + + fac001 = fk01 * fac01(k) + fac101 = fk11 * fac01(k) + fac201 = fk21 * fac01(k) + fac011 = fk01 * fac11(k) + fac111 = fk11 * fac11(k) + fac211 = fk21 * fac11(k) + + do ig = 1, ng05 + tauself = selffac(k) * (selfref(ig,inds) + selffrac(k) & + & * (selfref(ig,indsp) - selfref(ig,inds))) + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + o3m1 = ka_mo3(ig,jmo3,indm) + fmo3 & + & * (ka_mo3(ig,jmo3p,indm) - ka_mo3(ig,jmo3,indm)) + o3m2 = ka_mo3(ig,jmo3,indmp) + fmo3 & + & * (ka_mo3(ig,jmo3p,indmp) - ka_mo3(ig,jmo3,indmp)) + abso3 = o3m1 + minorfrac(k)*(o3m2 - o3m1) + + taug(ns05+ig,k) = speccomb & + & * (fac000*absa(ig,id000) + fac010*absa(ig,id010) & + & + fac100*absa(ig,id100) + fac110*absa(ig,id110) & + & + fac200*absa(ig,id200) + fac210*absa(ig,id210)) & + & + speccomb1 & + & * (fac001*absa(ig,id001) + fac011*absa(ig,id011) & + & + fac101*absa(ig,id101) + fac111*absa(ig,id111) & + & + fac201*absa(ig,id201) + fac211*absa(ig,id211)) & + & + tauself + taufor+abso3*colamt(k,3)+wx(k,1)*ccl4(ig) + + fracs(ns05+ig,k) = fracrefa(ig,jpl) + fpl & + & * (fracrefa(ig,jplp) - fracrefa(ig,jpl)) + enddo + enddo + +! --- ... upper atmosphere loop + + do k = laytrop+1, nlay + speccomb = colamt(k,3) + rfrate(k,6,1)*colamt(k,2) + specparm = colamt(k,3) / speccomb + specmult = 4.0 * min(specparm, oneminus) + js = 1 + int(specmult) + fs = mod(specmult, f_one) + ind0 = ((jp(k)-13)*5 + (jt(k)-1)) * nspb(5) + js + + speccomb1 = colamt(k,3) + rfrate(k,6,2)*colamt(k,2) + specparm1 = colamt(k,3) / speccomb1 + specmult1 = 4.0 * min(specparm1, oneminus) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1, f_one) + ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(5) + js1 + + speccomb_planck = colamt(k,3) + refrat_planck_b*colamt(k,2) + specparm_planck = colamt(k,3) / speccomb_planck + specmult_planck = 4.0 * min(specparm_planck, oneminus) + jpl = 1 + int(specmult_planck) + fpl = mod(specmult_planck, f_one) + jplp= jpl + 1 + + id000 = ind0 + id010 = ind0 + 5 + id100 = ind0 + 1 + id110 = ind0 + 6 + id001 = ind1 + id011 = ind1 + 5 + id101 = ind1 + 1 + id111 = ind1 + 6 + + fk00 = f_one - fs + fk10 = fs + + fk01 = f_one - fs1 + fk11 = fs1 + + fac000 = fk00 * fac00(k) + fac010 = fk00 * fac10(k) + fac100 = fk10 * fac00(k) + fac110 = fk10 * fac10(k) + + fac001 = fk01 * fac01(k) + fac011 = fk01 * fac11(k) + fac101 = fk11 * fac01(k) + fac111 = fk11 * fac11(k) + + do ig = 1, ng05 + taug(ns05+ig,k) = speccomb & + & * (fac000*absb(ig,id000) + fac010*absb(ig,id010) & + & + fac100*absb(ig,id100) + fac110*absb(ig,id110)) & + & + speccomb1 & + & * (fac001*absb(ig,id001) + fac011*absb(ig,id011) & + & + fac101*absb(ig,id101) + fac111*absb(ig,id111)) & + & + wx(k,1) * ccl4(ig) + + fracs(ns05+ig,k) = fracrefb(ig,jpl) + fpl & + & * (fracrefb(ig,jplp) - fracrefb(ig,jpl)) + enddo + enddo + +! .................................. + end subroutine taugb05 +! ---------------------------------- + +!>\ingroup module_radlw_main +!> Band 6: 820-980 cm-1 (low key - h2o; low minor - co2) +!! (high key - none; high minor - cfc11, cfc12) +! ---------------------------------- + subroutine taugb06 +! .................................. + +! ------------------------------------------------------------------ ! +! band 6: 820-980 cm-1 (low key - h2o; low minor - co2) ! +! (high key - none; high minor - cfc11, cfc12) +! ------------------------------------------------------------------ ! + + use module_radlw_kgb06 + +! --- locals: + integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, & + & indm, indmp, ig + + real (kind=kind_phys) :: ratco2, adjfac, adjcolco2, tauself, & + & taufor, absco2, temp +! +!===> ... begin here +! +! --- ... minor gas mapping level: +! lower - co2, p = 706.2720 mb, t = 294.2 k +! upper - cfc11, cfc12 + +! --- ... lower atmosphere loop + + do k = 1, laytrop + ind0 = ((jp(k)-1)*5 + (jt (k)-1)) * nspa(6) + 1 + ind1 = ( jp(k) *5 + (jt1(k)-1)) * nspa(6) + 1 + + inds = indself(k) + indf = indfor(k) + indm = indminor(k) + indsp = inds + 1 + indfp = indf + 1 + indmp = indm + 1 + ind0p = ind0 + 1 + ind1p = ind1 + 1 + +! --- ... in atmospheres where the amount of co2 is too great to be considered +! a minor species, adjust the column amount of co2 by an empirical factor +! to obtain the proper contribution. + + temp = coldry(k) * chi_mls(2,jp(k)+1) + ratco2 = colamt(k,2) / temp + if (ratco2 > 3.0) then + adjfac = 2.0 + (ratco2-2.0)**0.77 + adjcolco2 = adjfac * temp + else + adjcolco2 = colamt(k,2) + endif + + do ig = 1, ng06 + tauself = selffac(k) * (selfref(ig,inds) + selffrac(k) & + & * (selfref(ig,indsp) - selfref(ig,inds))) + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + absco2 = ka_mco2(ig,indm) + minorfrac(k) & + & * (ka_mco2(ig,indmp) - ka_mco2(ig,indm)) + + taug(ns06+ig,k) = colamt(k,1) & + & * (fac00(k)*absa(ig,ind0) + fac10(k)*absa(ig,ind0p) & + & + fac01(k)*absa(ig,ind1) + fac11(k)*absa(ig,ind1p)) & + & + tauself + taufor + adjcolco2*absco2 & + & + wx(k,2)*cfc11adj(ig) + wx(k,3)*cfc12(ig) + + fracs(ns06+ig,k) = fracrefa(ig) + enddo + enddo + +! --- ... upper atmosphere loop +! nothing important goes on above laytrop in this band. + + do k = laytrop+1, nlay + do ig = 1, ng06 + taug(ns06+ig,k) = wx(k,2)*cfc11adj(ig) + wx(k,3)*cfc12(ig) + + fracs(ns06+ig,k) = fracrefa(ig) + enddo + enddo + +! .................................. + end subroutine taugb06 +! ---------------------------------- + +!>\ingroup module_radlw_main +!> Band 7: 980-1080 cm-1 (low key - h2o,o3; low minor - co2) +!! (high key - o3; high minor - co2) +! ---------------------------------- + subroutine taugb07 +! .................................. + +! ------------------------------------------------------------------ ! +! band 7: 980-1080 cm-1 (low key - h2o,o3; low minor - co2) ! +! (high key - o3; high minor - co2) ! +! ------------------------------------------------------------------ ! + + use module_radlw_kgb07 + +! --- locals: + integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, & + & id000, id010, id100, id110, id200, id210, indm, indmp, & + & id001, id011, id101, id111, id201, id211, jmco2, jmco2p, & + & jpl, jplp, ig, js, js1 + + real (kind=kind_phys) :: tauself, taufor, co2m1, co2m2, absco2, & + & speccomb, specparm, specmult, fs, & + & speccomb1, specparm1, specmult1, fs1, & + & speccomb_mco2, specparm_mco2, specmult_mco2, fmco2, & + & speccomb_planck,specparm_planck,specmult_planck,fpl, & + & refrat_planck_a, refrat_m_a, ratco2, adjfac, adjcolco2, & + & fac000, fac100, fac200, fac010, fac110, fac210, & + & fac001, fac101, fac201, fac011, fac111, fac211, & + & p0, p40, fk00, fk10, fk20, p1, p41, fk01, fk11, fk21, temp +! +!===> ... begin here +! +! --- ... minor gas mapping level : +! lower - co2, p = 706.2620 mbar, t= 278.94 k +! upper - co2, p = 12.9350 mbar, t = 234.01 k + +! --- ... calculate reference ratio to be used in calculation of Planck +! fraction in lower atmosphere. + + refrat_planck_a = chi_mls(1,3)/chi_mls(3,3) ! P = 706.2620 mb + refrat_m_a = chi_mls(1,3)/chi_mls(3,3) ! P = 706.2720 mb + +! --- ... lower atmosphere loop + + do k = 1, laytrop + speccomb = colamt(k,1) + rfrate(k,2,1)*colamt(k,3) + specparm = colamt(k,1) / speccomb + specmult = 8.0 * min(specparm, oneminus) + js = 1 + int(specmult) + fs = mod(specmult, f_one) + ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(7) + js + + speccomb1 = colamt(k,1) + rfrate(k,2,2)*colamt(k,3) + specparm1 = colamt(k,1) / speccomb1 + specmult1 = 8.0 * min(specparm1, oneminus) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1, f_one) + ind1 = (jp(k)*5 + (jt1(k)-1)) * nspa(7) + js1 + + speccomb_mco2 = colamt(k,1) + refrat_m_a*colamt(k,3) + specparm_mco2 = colamt(k,1) / speccomb_mco2 + specmult_mco2 = 8.0 * min(specparm_mco2, oneminus) + jmco2 = 1 + int(specmult_mco2) + fmco2 = mod(specmult_mco2, f_one) + + speccomb_planck = colamt(k,1) + refrat_planck_a*colamt(k,3) + specparm_planck = colamt(k,1) / speccomb_planck + specmult_planck = 8.0 * min(specparm_planck, oneminus) + jpl = 1 + int(specmult_planck) + fpl = mod(specmult_planck, f_one) + + inds = indself(k) + indf = indfor(k) + indm = indminor(k) + indsp = inds + 1 + indfp = indf + 1 + indmp = indm + 1 + jplp = jpl + 1 + jmco2p= jmco2+ 1 + ind0p = ind0 + 1 + ind1p = ind1 + 1 + +! --- ... in atmospheres where the amount of CO2 is too great to be considered +! a minor species, adjust the column amount of CO2 by an empirical factor +! to obtain the proper contribution. + + temp = coldry(k) * chi_mls(2,jp(k)+1) + ratco2 = colamt(k,2) / temp + if (ratco2 > 3.0) then + adjfac = 3.0 + (ratco2-3.0)**0.79 + adjcolco2 = adjfac * temp + else + adjcolco2 = colamt(k,2) + endif + + if (specparm < 0.125) then + p0 = fs - f_one + p40 = p0**4 + fk00 = p40 + fk10 = f_one - p0 - 2.0*p40 + fk20 = p0 + p40 + + id000 = ind0 + id010 = ind0 + 9 + id100 = ind0 + 1 + id110 = ind0 +10 + id200 = ind0 + 2 + id210 = ind0 +11 + elseif (specparm > 0.875) then + p0 = -fs + p40 = p0**4 + fk00 = p40 + fk10 = f_one - p0 - 2.0*p40 + fk20 = p0 + p40 + + id000 = ind0 + 1 + id010 = ind0 +10 + id100 = ind0 + id110 = ind0 + 9 + id200 = ind0 - 1 + id210 = ind0 + 8 + else + fk00 = f_one - fs + fk10 = fs + fk20 = f_zero + + id000 = ind0 + id010 = ind0 + 9 + id100 = ind0 + 1 + id110 = ind0 +10 + id200 = ind0 + id210 = ind0 + endif + + fac000 = fk00 * fac00(k) + fac100 = fk10 * fac00(k) + fac200 = fk20 * fac00(k) + fac010 = fk00 * fac10(k) + fac110 = fk10 * fac10(k) + fac210 = fk20 * fac10(k) + + if (specparm1 < 0.125) then + p1 = fs1 - f_one + p41 = p1**4 + fk01 = p41 + fk11 = f_one - p1 - 2.0*p41 + fk21 = p1 + p41 + + id001 = ind1 + id011 = ind1 + 9 + id101 = ind1 + 1 + id111 = ind1 +10 + id201 = ind1 + 2 + id211 = ind1 +11 + elseif (specparm1 > 0.875) then + p1 = -fs1 + p41 = p1**4 + fk01 = p41 + fk11 = f_one - p1 - 2.0*p41 + fk21 = p1 + p41 + + id001 = ind1 + 1 + id011 = ind1 +10 + id101 = ind1 + id111 = ind1 + 9 + id201 = ind1 - 1 + id211 = ind1 + 8 + else + fk01 = f_one - fs1 + fk11 = fs1 + fk21 = f_zero + + id001 = ind1 + id011 = ind1 + 9 + id101 = ind1 + 1 + id111 = ind1 +10 + id201 = ind1 + id211 = ind1 + endif + + fac001 = fk01 * fac01(k) + fac101 = fk11 * fac01(k) + fac201 = fk21 * fac01(k) + fac011 = fk01 * fac11(k) + fac111 = fk11 * fac11(k) + fac211 = fk21 * fac11(k) + + do ig = 1, ng07 + tauself = selffac(k)* (selfref(ig,inds) + selffrac(k) & + & * (selfref(ig,indsp) - selfref(ig,inds))) + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + co2m1 = ka_mco2(ig,jmco2,indm) + fmco2 & + & * (ka_mco2(ig,jmco2p,indm) - ka_mco2(ig,jmco2,indm)) + co2m2 = ka_mco2(ig,jmco2,indmp) + fmco2 & + & * (ka_mco2(ig,jmco2p,indmp) - ka_mco2(ig,jmco2,indmp)) + absco2 = co2m1 + minorfrac(k) * (co2m2 - co2m1) + + taug(ns07+ig,k) = speccomb & + & * (fac000*absa(ig,id000) + fac010*absa(ig,id010) & + & + fac100*absa(ig,id100) + fac110*absa(ig,id110) & + & + fac200*absa(ig,id200) + fac210*absa(ig,id210)) & + & + speccomb1 & + & * (fac001*absa(ig,id001) + fac011*absa(ig,id011) & + & + fac101*absa(ig,id101) + fac111*absa(ig,id111) & + & + fac201*absa(ig,id201) + fac211*absa(ig,id211)) & + & + tauself + taufor + adjcolco2*absco2 + + fracs(ns07+ig,k) = fracrefa(ig,jpl) + fpl & + & * (fracrefa(ig,jplp) - fracrefa(ig,jpl)) + enddo + enddo + +! --- ... upper atmosphere loop + +! --- ... in atmospheres where the amount of co2 is too great to be considered +! a minor species, adjust the column amount of co2 by an empirical factor +! to obtain the proper contribution. + + do k = laytrop+1, nlay + temp = coldry(k) * chi_mls(2,jp(k)+1) + ratco2 = colamt(k,2) / temp + if (ratco2 > 3.0) then + adjfac = 2.0 + (ratco2-2.0)**0.79 + adjcolco2 = adjfac * temp + else + adjcolco2 = colamt(k,2) + endif + + ind0 = ((jp(k)-13)*5 + (jt (k)-1)) * nspb(7) + 1 + ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(7) + 1 + + indm = indminor(k) + indmp = indm + 1 + ind0p = ind0 + 1 + ind1p = ind1 + 1 + + do ig = 1, ng07 + absco2 = kb_mco2(ig,indm) + minorfrac(k) & + & * (kb_mco2(ig,indmp) - kb_mco2(ig,indm)) + + taug(ns07+ig,k) = colamt(k,3) & + & * (fac00(k)*absb(ig,ind0) + fac10(k)*absb(ig,ind0p) & + & + fac01(k)*absb(ig,ind1) + fac11(k)*absb(ig,ind1p)) & + & + adjcolco2 * absco2 + + fracs(ns07+ig,k) = fracrefb(ig) + enddo + +! --- ... empirical modification to code to improve stratospheric cooling rates +! for o3. revised to apply weighting for g-point reduction in this band. + + taug(ns07+ 6,k) = taug(ns07+ 6,k) * 0.92 + taug(ns07+ 7,k) = taug(ns07+ 7,k) * 0.88 + taug(ns07+ 8,k) = taug(ns07+ 8,k) * 1.07 + taug(ns07+ 9,k) = taug(ns07+ 9,k) * 1.1 + taug(ns07+10,k) = taug(ns07+10,k) * 0.99 + taug(ns07+11,k) = taug(ns07+11,k) * 0.855 + enddo + +! .................................. + end subroutine taugb07 +! ---------------------------------- + +!>\ingroup module_radlw_main +!> Band 8: 1080-1180 cm-1 (low key - h2o; low minor - co2,o3,n2o) +!! (high key - o3; high minor - co2, n2o) +! ---------------------------------- + subroutine taugb08 +! .................................. + +! ------------------------------------------------------------------ ! +! band 8: 1080-1180 cm-1 (low key - h2o; low minor - co2,o3,n2o) ! +! (high key - o3; high minor - co2, n2o) ! +! ------------------------------------------------------------------ ! + + use module_radlw_kgb08 + +! --- locals: + integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, & + & indm, indmp, ig + + real (kind=kind_phys) :: tauself, taufor, absco2, abso3, absn2o, & + & ratco2, adjfac, adjcolco2, temp +! +!===> ... begin here +! +! --- ... minor gas mapping level: +! lower - co2, p = 1053.63 mb, t = 294.2 k +! lower - o3, p = 317.348 mb, t = 240.77 k +! lower - n2o, p = 706.2720 mb, t= 278.94 k +! lower - cfc12,cfc11 +! upper - co2, p = 35.1632 mb, t = 223.28 k +! upper - n2o, p = 8.716e-2 mb, t = 226.03 k + +! --- ... lower atmosphere loop + + do k = 1, laytrop + ind0 = ((jp(k)-1)*5 + (jt (k)-1)) * nspa(8) + 1 + ind1 = ( jp(k) *5 + (jt1(k)-1)) * nspa(8) + 1 + + inds = indself(k) + indf = indfor(k) + indm = indminor(k) + ind0p = ind0 + 1 + ind1p = ind1 + 1 + indsp = inds + 1 + indfp = indf + 1 + indmp = indm + 1 + +! --- ... in atmospheres where the amount of co2 is too great to be considered +! a minor species, adjust the column amount of co2 by an empirical factor +! to obtain the proper contribution. + + temp = coldry(k) * chi_mls(2,jp(k)+1) + ratco2 = colamt(k,2) / temp + if (ratco2 > 3.0) then + adjfac = 2.0 + (ratco2-2.0)**0.65 + adjcolco2 = adjfac * temp + else + adjcolco2 = colamt(k,2) + endif + + do ig = 1, ng08 + tauself = selffac(k) * (selfref(ig,inds) + selffrac(k) & + & * (selfref(ig,indsp) - selfref(ig,inds))) + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + absco2 = (ka_mco2(ig,indm) + minorfrac(k) & + & * (ka_mco2(ig,indmp) - ka_mco2(ig,indm))) + abso3 = (ka_mo3(ig,indm) + minorfrac(k) & + & * (ka_mo3(ig,indmp) - ka_mo3(ig,indm))) + absn2o = (ka_mn2o(ig,indm) + minorfrac(k) & + & * (ka_mn2o(ig,indmp) - ka_mn2o(ig,indm))) + + taug(ns08+ig,k) = colamt(k,1) & + & * (fac00(k)*absa(ig,ind0) + fac10(k)*absa(ig,ind0p) & + & + fac01(k)*absa(ig,ind1) + fac11(k)*absa(ig,ind1p)) & + & + tauself+taufor + adjcolco2*absco2 & + & + colamt(k,3)*abso3 + colamt(k,4)*absn2o & + & + wx(k,3)*cfc12(ig) + wx(k,4)*cfc22adj(ig) + + fracs(ns08+ig,k) = fracrefa(ig) + enddo + enddo + +! --- ... upper atmosphere loop + + do k = laytrop+1, nlay + ind0 = ((jp(k)-13)*5 + (jt (k)-1)) * nspb(8) + 1 + ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(8) + 1 + + indm = indminor(k) + ind0p = ind0 + 1 + ind1p = ind1 + 1 + indmp = indm + 1 + +! --- ... in atmospheres where the amount of co2 is too great to be considered +! a minor species, adjust the column amount of co2 by an empirical factor +! to obtain the proper contribution. + + temp = coldry(k) * chi_mls(2,jp(k)+1) + ratco2 = colamt(k,2) / temp + if (ratco2 > 3.0) then + adjfac = 2.0 + (ratco2-2.0)**0.65 + adjcolco2 = adjfac * temp + else + adjcolco2 = colamt(k,2) + endif + + do ig = 1, ng08 + absco2 = (kb_mco2(ig,indm) + minorfrac(k) & + & * (kb_mco2(ig,indmp) - kb_mco2(ig,indm))) + absn2o = (kb_mn2o(ig,indm) + minorfrac(k) & + & * (kb_mn2o(ig,indmp) - kb_mn2o(ig,indm))) + + taug(ns08+ig,k) = colamt(k,3) & + & * (fac00(k)*absb(ig,ind0) + fac10(k)*absb(ig,ind0p) & + & + fac01(k)*absb(ig,ind1) + fac11(k)*absb(ig,ind1p)) & + & + adjcolco2*absco2 + colamt(k,4)*absn2o & + & + wx(k,3)*cfc12(ig) + wx(k,4)*cfc22adj(ig) + + fracs(ns08+ig,k) = fracrefb(ig) + enddo + enddo + +! .................................. + end subroutine taugb08 +! ---------------------------------- + +!>\ingroup module_radlw_main +!> Band 9: 1180-1390 cm-1 (low key - h2o,ch4; low minor - n2o) +!! (high key - ch4; high minor - n2o) +! ---------------------------------- + subroutine taugb09 +! .................................. + +! ------------------------------------------------------------------ ! +! band 9: 1180-1390 cm-1 (low key - h2o,ch4; low minor - n2o) ! +! (high key - ch4; high minor - n2o) ! +! ------------------------------------------------------------------ ! + + use module_radlw_kgb09 + +! --- locals: + integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, & + & id000, id010, id100, id110, id200, id210, indm, indmp, & + & id001, id011, id101, id111, id201, id211, jmn2o, jmn2op, & + & jpl, jplp, ig, js, js1 + + real (kind=kind_phys) :: tauself, taufor, n2om1, n2om2, absn2o, & + & speccomb, specparm, specmult, fs, & + & speccomb1, specparm1, specmult1, fs1, & + & speccomb_mn2o, specparm_mn2o, specmult_mn2o, fmn2o, & + & speccomb_planck,specparm_planck,specmult_planck,fpl, & + & refrat_planck_a, refrat_m_a, ratn2o, adjfac, adjcoln2o, & + & fac000, fac100, fac200, fac010, fac110, fac210, & + & fac001, fac101, fac201, fac011, fac111, fac211, & + & p0, p40, fk00, fk10, fk20, p1, p41, fk01, fk11, fk21, temp +! +!===> ... begin here +! +! --- ... minor gas mapping level : +! lower - n2o, p = 706.272 mbar, t = 278.94 k +! upper - n2o, p = 95.58 mbar, t = 215.7 k + +! --- ... calculate reference ratio to be used in calculation of Planck +! fraction in lower/upper atmosphere. + + refrat_planck_a = chi_mls(1,9)/chi_mls(6,9) ! P = 212 mb + refrat_m_a = chi_mls(1,3)/chi_mls(6,3) ! P = 706.272 mb + +! --- ... lower atmosphere loop + + do k = 1, laytrop + speccomb = colamt(k,1) + rfrate(k,4,1)*colamt(k,5) + specparm = colamt(k,1) / speccomb + specmult = 8.0 * min(specparm, oneminus) + js = 1 + int(specmult) + fs = mod(specmult, f_one) + ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(9) + js + + speccomb1 = colamt(k,1) + rfrate(k,4,2)*colamt(k,5) + specparm1 = colamt(k,1) / speccomb1 + specmult1 = 8.0 * min(specparm1, oneminus) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1, f_one) + ind1 = (jp(k)*5 + (jt1(k)-1)) * nspa(9) + js1 + + speccomb_mn2o = colamt(k,1) + refrat_m_a*colamt(k,5) + specparm_mn2o = colamt(k,1) / speccomb_mn2o + specmult_mn2o = 8.0 * min(specparm_mn2o, oneminus) + jmn2o = 1 + int(specmult_mn2o) + fmn2o = mod(specmult_mn2o, f_one) + + speccomb_planck = colamt(k,1) + refrat_planck_a*colamt(k,5) + specparm_planck = colamt(k,1) / speccomb_planck + specmult_planck = 8.0 * min(specparm_planck, oneminus) + jpl = 1 + int(specmult_planck) + fpl = mod(specmult_planck, f_one) + + inds = indself(k) + indf = indfor(k) + indm = indminor(k) + indsp = inds + 1 + indfp = indf + 1 + indmp = indm + 1 + jplp = jpl + 1 + jmn2op= jmn2o+ 1 + +! --- ... in atmospheres where the amount of n2o is too great to be considered +! a minor species, adjust the column amount of n2o by an empirical factor +! to obtain the proper contribution. + + temp = coldry(k) * chi_mls(4,jp(k)+1) + ratn2o = colamt(k,4) / temp + if (ratn2o > 1.5) then + adjfac = 0.5 + (ratn2o-0.5)**0.65 + adjcoln2o = adjfac * temp + else + adjcoln2o = colamt(k,4) + endif + + if (specparm < 0.125) then + p0 = fs - f_one + p40 = p0**4 + fk00 = p40 + fk10 = f_one - p0 - 2.0*p40 + fk20 = p0 + p40 + + id000 = ind0 + id010 = ind0 + 9 + id100 = ind0 + 1 + id110 = ind0 +10 + id200 = ind0 + 2 + id210 = ind0 +11 + elseif (specparm > 0.875) then + p0 = -fs + p40 = p0**4 + fk00 = p40 + fk10 = f_one - p0 - 2.0*p40 + fk20 = p0 + p40 + + id000 = ind0 + 1 + id010 = ind0 +10 + id100 = ind0 + id110 = ind0 + 9 + id200 = ind0 - 1 + id210 = ind0 + 8 + else + fk00 = f_one - fs + fk10 = fs + fk20 = f_zero + + id000 = ind0 + id010 = ind0 + 9 + id100 = ind0 + 1 + id110 = ind0 +10 + id200 = ind0 + id210 = ind0 + endif + + fac000 = fk00 * fac00(k) + fac100 = fk10 * fac00(k) + fac200 = fk20 * fac00(k) + fac010 = fk00 * fac10(k) + fac110 = fk10 * fac10(k) + fac210 = fk20 * fac10(k) + + if (specparm1 < 0.125) then + p1 = fs1 - f_one + p41 = p1**4 + fk01 = p41 + fk11 = f_one - p1 - 2.0*p41 + fk21 = p1 + p41 + + id001 = ind1 + id011 = ind1 + 9 + id101 = ind1 + 1 + id111 = ind1 +10 + id201 = ind1 + 2 + id211 = ind1 +11 + elseif (specparm1 > 0.875) then + p1 = -fs1 + p41 = p1**4 + fk01 = p41 + fk11 = f_one - p1 - 2.0*p41 + fk21 = p1 + p41 + + id001 = ind1 + 1 + id011 = ind1 +10 + id101 = ind1 + id111 = ind1 + 9 + id201 = ind1 - 1 + id211 = ind1 + 8 + else + fk01 = f_one - fs1 + fk11 = fs1 + fk21 = f_zero + + id001 = ind1 + id011 = ind1 + 9 + id101 = ind1 + 1 + id111 = ind1 +10 + id201 = ind1 + id211 = ind1 + endif + + fac001 = fk01 * fac01(k) + fac101 = fk11 * fac01(k) + fac201 = fk21 * fac01(k) + fac011 = fk01 * fac11(k) + fac111 = fk11 * fac11(k) + fac211 = fk21 * fac11(k) + + do ig = 1, ng09 + tauself = selffac(k)* (selfref(ig,inds) + selffrac(k) & + & * (selfref(ig,indsp) - selfref(ig,inds))) + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + n2om1 = ka_mn2o(ig,jmn2o,indm) + fmn2o & + & * (ka_mn2o(ig,jmn2op,indm) - ka_mn2o(ig,jmn2o,indm)) + n2om2 = ka_mn2o(ig,jmn2o,indmp) + fmn2o & + & * (ka_mn2o(ig,jmn2op,indmp) - ka_mn2o(ig,jmn2o,indmp)) + absn2o = n2om1 + minorfrac(k) * (n2om2 - n2om1) + + taug(ns09+ig,k) = speccomb & + & * (fac000*absa(ig,id000) + fac010*absa(ig,id010) & + & + fac100*absa(ig,id100) + fac110*absa(ig,id110) & + & + fac200*absa(ig,id200) + fac210*absa(ig,id210)) & + & + speccomb1 & + & * (fac001*absa(ig,id001) + fac011*absa(ig,id011) & + & + fac101*absa(ig,id101) + fac111*absa(ig,id111) & + & + fac201*absa(ig,id201) + fac211*absa(ig,id211)) & + & + tauself + taufor + adjcoln2o*absn2o + + fracs(ns09+ig,k) = fracrefa(ig,jpl) + fpl & + & * (fracrefa(ig,jplp) - fracrefa(ig,jpl)) + enddo + enddo + +! --- ... upper atmosphere loop + + do k = laytrop+1, nlay + ind0 = ((jp(k)-13)*5 + (jt (k)-1)) * nspb(9) + 1 + ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(9) + 1 + + indm = indminor(k) + ind0p = ind0 + 1 + ind1p = ind1 + 1 + indmp = indm + 1 + +! --- ... in atmospheres where the amount of n2o is too great to be considered +! a minor species, adjust the column amount of n2o by an empirical factor +! to obtain the proper contribution. + + temp = coldry(k) * chi_mls(4,jp(k)+1) + ratn2o = colamt(k,4) / temp + if (ratn2o > 1.5) then + adjfac = 0.5 + (ratn2o - 0.5)**0.65 + adjcoln2o = adjfac * temp + else + adjcoln2o = colamt(k,4) + endif + + do ig = 1, ng09 + absn2o = kb_mn2o(ig,indm) + minorfrac(k) & + & * (kb_mn2o(ig,indmp) - kb_mn2o(ig,indm)) + + taug(ns09+ig,k) = colamt(k,5) & + & * (fac00(k)*absb(ig,ind0) + fac10(k)*absb(ig,ind0p) & + & + fac01(k)*absb(ig,ind1) + fac11(k)*absb(ig,ind1p)) & + & + adjcoln2o*absn2o + + fracs(ns09+ig,k) = fracrefb(ig) + enddo + enddo + +! .................................. + end subroutine taugb09 +! ---------------------------------- + +!>\ingroup module_radlw_main +!> Band 10: 1390-1480 cm-1 (low key - h2o; high key - h2o) +! ---------------------------------- + subroutine taugb10 +! .................................. + +! ------------------------------------------------------------------ ! +! band 10: 1390-1480 cm-1 (low key - h2o; high key - h2o) ! +! ------------------------------------------------------------------ ! + + use module_radlw_kgb10 + +! --- locals: + integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, & + & ig + + real (kind=kind_phys) :: tauself, taufor +! +!===> ... begin here +! +! --- ... lower atmosphere loop + + do k = 1, laytrop + ind0 = ((jp(k)-1)*5 + (jt (k)-1)) * nspa(10) + 1 + ind1 = ( jp(k) *5 + (jt1(k)-1)) * nspa(10) + 1 + + inds = indself(k) + indf = indfor(k) + ind0p = ind0 + 1 + ind1p = ind1 + 1 + indsp = inds + 1 + indfp = indf + 1 + + do ig = 1, ng10 + tauself = selffac(k) * (selfref(ig,inds) + selffrac(k) & + & * (selfref(ig,indsp) - selfref(ig,inds))) + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + + taug(ns10+ig,k) = colamt(k,1) & + & * (fac00(k)*absa(ig,ind0) + fac10(k)*absa(ig,ind0p) & + & + fac01(k)*absa(ig,ind1) + fac11(k)*absa(ig,ind1p)) & + & + tauself + taufor + + fracs(ns10+ig,k) = fracrefa(ig) + enddo + enddo + +! --- ... upper atmosphere loop + + do k = laytrop+1, nlay + ind0 = ((jp(k)-13)*5 + (jt (k)-1)) * nspb(10) + 1 + ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(10) + 1 + + indf = indfor(k) + ind0p = ind0 + 1 + ind1p = ind1 + 1 + indfp = indf + 1 + + do ig = 1, ng10 + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + + taug(ns10+ig,k) = colamt(k,1) & + & * (fac00(k)*absb(ig,ind0) + fac10(k)*absb(ig,ind0p) & + & + fac01(k)*absb(ig,ind1) + fac11(k)*absb(ig,ind1p)) & + & + taufor + + fracs(ns10+ig,k) = fracrefb(ig) + enddo + enddo + +! .................................. + end subroutine taugb10 +! ---------------------------------- + +!>\ingroup module_radlw_main +!> Band 11: 1480-1800 cm-1 (low - h2o; low minor - o2) +!! (high key - h2o; high minor - o2) +! ---------------------------------- + subroutine taugb11 +! .................................. + +! ------------------------------------------------------------------ ! +! band 11: 1480-1800 cm-1 (low - h2o; low minor - o2) ! +! (high key - h2o; high minor - o2) ! +! ------------------------------------------------------------------ ! + + use module_radlw_kgb11 + +! --- locals: + integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, & + & indm, indmp, ig + + real (kind=kind_phys) :: scaleo2, tauself, taufor, tauo2 +! +!===> ... begin here +! +! --- ... minor gas mapping level : +! lower - o2, p = 706.2720 mbar, t = 278.94 k +! upper - o2, p = 4.758820 mbarm t = 250.85 k + +! --- ... lower atmosphere loop + + do k = 1, laytrop + ind0 = ((jp(k)-1)*5 + (jt (k)-1)) * nspa(11) + 1 + ind1 = ( jp(k) *5 + (jt1(k)-1)) * nspa(11) + 1 + + inds = indself(k) + indf = indfor(k) + indm = indminor(k) + ind0p = ind0 + 1 + ind1p = ind1 + 1 + indsp = inds + 1 + indfp = indf + 1 + indmp = indm + 1 + + scaleo2 = colamt(k,6) * scaleminor(k) + + do ig = 1, ng11 + tauself = selffac(k) * (selfref(ig,inds) + selffrac(k) & + & * (selfref(ig,indsp) - selfref(ig,inds))) + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + tauo2 = scaleo2 * (ka_mo2(ig,indm) + minorfrac(k) & + & * (ka_mo2(ig,indmp) - ka_mo2(ig,indm))) + + taug(ns11+ig,k) = colamt(k,1) & + & * (fac00(k)*absa(ig,ind0) + fac10(k)*absa(ig,ind0p) & + & + fac01(k)*absa(ig,ind1) + fac11(k)*absa(ig,ind1p)) & + & + tauself + taufor + tauo2 + + fracs(ns11+ig,k) = fracrefa(ig) + enddo + enddo + +! --- ... upper atmosphere loop + + do k = laytrop+1, nlay + ind0 = ((jp(k)-13)*5 + (jt (k)-1)) * nspb(11) + 1 + ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(11) + 1 + + indf = indfor(k) + indm = indminor(k) + ind0p = ind0 + 1 + ind1p = ind1 + 1 + indfp = indf + 1 + indmp = indm + 1 + + scaleo2 = colamt(k,6) * scaleminor(k) + + do ig = 1, ng11 + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + tauo2 = scaleo2 * (kb_mo2(ig,indm) + minorfrac(k) & + & * (kb_mo2(ig,indmp) - kb_mo2(ig,indm))) + + taug(ns11+ig,k) = colamt(k,1) & + & * (fac00(k)*absb(ig,ind0) + fac10(k)*absb(ig,ind0p) & + & + fac01(k)*absb(ig,ind1) + fac11(k)*absb(ig,ind1p)) & + & + taufor + tauo2 + + fracs(ns11+ig,k) = fracrefb(ig) + enddo + enddo + +! .................................. + end subroutine taugb11 +! ---------------------------------- + +!>\ingroup module_radlw_main +!> Band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing) +! ---------------------------------- + subroutine taugb12 +! .................................. + +! ------------------------------------------------------------------ ! +! band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing) ! +! ------------------------------------------------------------------ ! + + use module_radlw_kgb12 + +! --- locals: + integer :: k, ind0, ind1, inds, indsp, indf, indfp, jpl, jplp, & + & id000, id010, id100, id110, id200, id210, ig, js, js1, & + & id001, id011, id101, id111, id201, id211 + + real (kind=kind_phys) :: tauself, taufor, refrat_planck_a, & + & speccomb, specparm, specmult, fs, & + & speccomb1, specparm1, specmult1, fs1, & + & speccomb_planck,specparm_planck,specmult_planck,fpl, & + & fac000, fac100, fac200, fac010, fac110, fac210, & + & fac001, fac101, fac201, fac011, fac111, fac211, & + & p0, p40, fk00, fk10, fk20, p1, p41, fk01, fk11, fk21 +! +!===> ... begin here +! +! --- ... calculate reference ratio to be used in calculation of Planck +! fraction in lower/upper atmosphere. + + refrat_planck_a = chi_mls(1,10)/chi_mls(2,10) ! P = 174.164 mb + +! --- ... lower atmosphere loop + + do k = 1, laytrop + speccomb = colamt(k,1) + rfrate(k,1,1)*colamt(k,2) + specparm = colamt(k,1) / speccomb + specmult = 8.0 * min(specparm, oneminus) + js = 1 + int(specmult) + fs = mod(specmult, f_one) + ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(12) + js + + speccomb1 = colamt(k,1) + rfrate(k,1,2)*colamt(k,2) + specparm1 = colamt(k,1) / speccomb1 + specmult1 = 8.0 * min(specparm1, oneminus) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1, f_one) + ind1 = (jp(k)*5 + (jt1(k)-1)) * nspa(12) + js1 + + speccomb_planck = colamt(k,1) + refrat_planck_a*colamt(k,2) + specparm_planck = colamt(k,1) / speccomb_planck + if (specparm_planck >= oneminus) specparm_planck=oneminus + specmult_planck = 8.0 * specparm_planck + jpl = 1 + int(specmult_planck) + fpl = mod(specmult_planck, f_one) + + inds = indself(k) + indf = indfor(k) + indsp = inds + 1 + indfp = indf + 1 + jplp = jpl + 1 + + if (specparm < 0.125) then + p0 = fs - f_one + p40 = p0**4 + fk00 = p40 + fk10 = f_one - p0 - 2.0*p40 + fk20 = p0 + p40 + + id000 = ind0 + id010 = ind0 + 9 + id100 = ind0 + 1 + id110 = ind0 +10 + id200 = ind0 + 2 + id210 = ind0 +11 + elseif (specparm > 0.875) then + p0 = -fs + p40 = p0**4 + fk00 = p40 + fk10 = f_one - p0 - 2.0*p40 + fk20 = p0 + p40 + + id000 = ind0 + 1 + id010 = ind0 +10 + id100 = ind0 + id110 = ind0 + 9 + id200 = ind0 - 1 + id210 = ind0 + 8 + else + fk00 = f_one - fs + fk10 = fs + fk20 = f_zero + + id000 = ind0 + id010 = ind0 + 9 + id100 = ind0 + 1 + id110 = ind0 +10 + id200 = ind0 + id210 = ind0 + endif + + fac000 = fk00 * fac00(k) + fac100 = fk10 * fac00(k) + fac200 = fk20 * fac00(k) + fac010 = fk00 * fac10(k) + fac110 = fk10 * fac10(k) + fac210 = fk20 * fac10(k) + + if (specparm1 < 0.125) then + p1 = fs1 - f_one + p41 = p1**4 + fk01 = p41 + fk11 = f_one - p1 - 2.0*p41 + fk21 = p1 + p41 + + id001 = ind1 + id011 = ind1 + 9 + id101 = ind1 + 1 + id111 = ind1 +10 + id201 = ind1 + 2 + id211 = ind1 +11 + elseif (specparm1 > 0.875) then + p1 = -fs1 + p41 = p1**4 + fk01 = p41 + fk11 = f_one - p1 - 2.0*p41 + fk21 = p1 + p41 + + id001 = ind1 + 1 + id011 = ind1 +10 + id101 = ind1 + id111 = ind1 + 9 + id201 = ind1 - 1 + id211 = ind1 + 8 + else + fk01 = f_one - fs1 + fk11 = fs1 + fk21 = f_zero + + id001 = ind1 + id011 = ind1 + 9 + id101 = ind1 + 1 + id111 = ind1 +10 + id201 = ind1 + id211 = ind1 + endif + + fac001 = fk01 * fac01(k) + fac101 = fk11 * fac01(k) + fac201 = fk21 * fac01(k) + fac011 = fk01 * fac11(k) + fac111 = fk11 * fac11(k) + fac211 = fk21 * fac11(k) + + do ig = 1, ng12 + tauself = selffac(k)* (selfref(ig,inds) + selffrac(k) & + & * (selfref(ig,indsp) - selfref(ig,inds))) + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + + taug(ns12+ig,k) = speccomb & + & * (fac000*absa(ig,id000) + fac010*absa(ig,id010) & + & + fac100*absa(ig,id100) + fac110*absa(ig,id110) & + & + fac200*absa(ig,id200) + fac210*absa(ig,id210)) & + & + speccomb1 & + & * (fac001*absa(ig,id001) + fac011*absa(ig,id011) & + & + fac101*absa(ig,id101) + fac111*absa(ig,id111) & + & + fac201*absa(ig,id201) + fac211*absa(ig,id211)) & + & + tauself + taufor + + fracs(ns12+ig,k) = fracrefa(ig,jpl) + fpl & + & *(fracrefa(ig,jplp) - fracrefa(ig,jpl)) + enddo + enddo + +! --- ... upper atmosphere loop + + do k = laytrop+1, nlay + do ig = 1, ng12 + taug(ns12+ig,k) = f_zero + fracs(ns12+ig,k) = f_zero + enddo + enddo + +! .................................. + end subroutine taugb12 +! ---------------------------------- + +!>\ingroup module_radlw_main +!> Band 13: 2080-2250 cm-1 (low key-h2o,n2o; high minor-o3 minor) +! ---------------------------------- + subroutine taugb13 +! .................................. + +! ------------------------------------------------------------------ ! +! band 13: 2080-2250 cm-1 (low key-h2o,n2o; high minor-o3 minor) ! +! ------------------------------------------------------------------ ! + + use module_radlw_kgb13 + +! --- locals: + integer :: k, ind0, ind1, inds, indsp, indf, indfp, indm, indmp, & + & id000, id010, id100, id110, id200, id210, jmco2, jpl, & + & id001, id011, id101, id111, id201, id211, jmco2p, jplp, & + & jmco, jmcop, ig, js, js1 + + real (kind=kind_phys) :: tauself, taufor, co2m1, co2m2, absco2, & + & speccomb, specparm, specmult, fs, & + & speccomb1, specparm1, specmult1, fs1, & + & speccomb_mco2, specparm_mco2, specmult_mco2, fmco2, & + & speccomb_mco, specparm_mco, specmult_mco, fmco, & + & speccomb_planck,specparm_planck,specmult_planck,fpl, & + & refrat_planck_a, refrat_m_a, refrat_m_a3, ratco2, & + & adjfac, adjcolco2, com1, com2, absco, abso3, & + & fac000, fac100, fac200, fac010, fac110, fac210, & + & fac001, fac101, fac201, fac011, fac111, fac211, & + & p0, p40, fk00, fk10, fk20, p1, p41, fk01, fk11, fk21, temp +! +!===> ... begin here +! +! --- ... minor gas mapping levels : +! lower - co2, p = 1053.63 mb, t = 294.2 k +! lower - co, p = 706 mb, t = 278.94 k +! upper - o3, p = 95.5835 mb, t = 215.7 k + +! --- ... calculate reference ratio to be used in calculation of Planck +! fraction in lower/upper atmosphere. + + refrat_planck_a = chi_mls(1,5)/chi_mls(4,5) ! P = 473.420 mb (Level 5) + refrat_m_a = chi_mls(1,1)/chi_mls(4,1) ! P = 1053. (Level 1) + refrat_m_a3 = chi_mls(1,3)/chi_mls(4,3) ! P = 706. (Level 3) + +! --- ... lower atmosphere loop + + do k = 1, laytrop + speccomb = colamt(k,1) + rfrate(k,3,1)*colamt(k,4) + specparm = colamt(k,1) / speccomb + specmult = 8.0 * min(specparm, oneminus) + js = 1 + int(specmult) + fs = mod(specmult, f_one) + ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(13) + js + + speccomb1 = colamt(k,1) + rfrate(k,3,2)*colamt(k,4) + specparm1 = colamt(k,1) / speccomb1 + specmult1 = 8.0 * min(specparm1, oneminus) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1, f_one) + ind1 = (jp(k)*5 + (jt1(k)-1)) * nspa(13) + js1 + + speccomb_mco2 = colamt(k,1) + refrat_m_a*colamt(k,4) + specparm_mco2 = colamt(k,1) / speccomb_mco2 + specmult_mco2 = 8.0 * min(specparm_mco2, oneminus) + jmco2 = 1 + int(specmult_mco2) + fmco2 = mod(specmult_mco2, f_one) + +! --- ... in atmospheres where the amount of co2 is too great to be considered +! a minor species, adjust the column amount of co2 by an empirical factor +! to obtain the proper contribution. + + speccomb_mco = colamt(k,1) + refrat_m_a3*colamt(k,4) + specparm_mco = colamt(k,1) / speccomb_mco + specmult_mco = 8.0 * min(specparm_mco, oneminus) + jmco = 1 + int(specmult_mco) + fmco = mod(specmult_mco, f_one) + + speccomb_planck = colamt(k,1) + refrat_planck_a*colamt(k,4) + specparm_planck = colamt(k,1) / speccomb_planck + specmult_planck = 8.0 * min(specparm_planck, oneminus) + jpl = 1 + int(specmult_planck) + fpl = mod(specmult_planck, f_one) + + inds = indself(k) + indf = indfor(k) + indm = indminor(k) + indsp = inds + 1 + indfp = indf + 1 + indmp = indm + 1 + jplp = jpl + 1 + jmco2p= jmco2+ 1 + jmcop = jmco + 1 + +! --- ... in atmospheres where the amount of co2 is too great to be considered +! a minor species, adjust the column amount of co2 by an empirical factor +! to obtain the proper contribution. + + temp = coldry(k) * 3.55e-4 + ratco2 = colamt(k,2) / temp + if (ratco2 > 3.0) then + adjfac = 2.0 + (ratco2-2.0)**0.68 + adjcolco2 = adjfac * temp + else + adjcolco2 = colamt(k,2) + endif + + if (specparm < 0.125) then + p0 = fs - f_one + p40 = p0**4 + fk00 = p40 + fk10 = f_one - p0 - 2.0*p40 + fk20 = p0 + p40 + + id000 = ind0 + id010 = ind0 + 9 + id100 = ind0 + 1 + id110 = ind0 +10 + id200 = ind0 + 2 + id210 = ind0 +11 + elseif (specparm > 0.875) then + p0 = -fs + p40 = p0**4 + fk00 = p40 + fk10 = f_one - p0 - 2.0*p40 + fk20 = p0 + p40 + + id000 = ind0 + 1 + id010 = ind0 +10 + id100 = ind0 + id110 = ind0 + 9 + id200 = ind0 - 1 + id210 = ind0 + 8 + else + fk00 = f_one - fs + fk10 = fs + fk20 = f_zero + + id000 = ind0 + id010 = ind0 + 9 + id100 = ind0 + 1 + id110 = ind0 +10 + id200 = ind0 + id210 = ind0 + endif + + fac000 = fk00 * fac00(k) + fac100 = fk10 * fac00(k) + fac200 = fk20 * fac00(k) + fac010 = fk00 * fac10(k) + fac110 = fk10 * fac10(k) + fac210 = fk20 * fac10(k) + + if (specparm1 < 0.125) then + p1 = fs1 - f_one + p41 = p1**4 + fk01 = p41 + fk11 = f_one - p1 - 2.0*p41 + fk21 = p1 + p41 + + id001 = ind1 + id011 = ind1 + 9 + id101 = ind1 + 1 + id111 = ind1 +10 + id201 = ind1 + 2 + id211 = ind1 +11 + elseif (specparm1 > 0.875) then + p1 = -fs1 + p41 = p1**4 + fk01 = p41 + fk11 = f_one - p1 - 2.0*p41 + fk21 = p1 + p41 + + id001 = ind1 + 1 + id011 = ind1 +10 + id101 = ind1 + id111 = ind1 + 9 + id201 = ind1 - 1 + id211 = ind1 + 8 + else + fk01 = f_one - fs1 + fk11 = fs1 + fk21 = f_zero + + id001 = ind1 + id011 = ind1 + 9 + id101 = ind1 + 1 + id111 = ind1 +10 + id201 = ind1 + id211 = ind1 + endif + + fac001 = fk01 * fac01(k) + fac101 = fk11 * fac01(k) + fac201 = fk21 * fac01(k) + fac011 = fk01 * fac11(k) + fac111 = fk11 * fac11(k) + fac211 = fk21 * fac11(k) + + do ig = 1, ng13 + tauself = selffac(k)* (selfref(ig,inds) + selffrac(k) & + & * (selfref(ig,indsp) - selfref(ig,inds))) + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + co2m1 = ka_mco2(ig,jmco2,indm) + fmco2 & + & * (ka_mco2(ig,jmco2p,indm) - ka_mco2(ig,jmco2,indm)) + co2m2 = ka_mco2(ig,jmco2,indmp) + fmco2 & + & * (ka_mco2(ig,jmco2p,indmp) - ka_mco2(ig,jmco2,indmp)) + absco2 = co2m1 + minorfrac(k) * (co2m2 - co2m1) + com1 = ka_mco(ig,jmco,indm) + fmco & + & * (ka_mco(ig,jmcop,indm) - ka_mco(ig,jmco,indm)) + com2 = ka_mco(ig,jmco,indmp) + fmco & + & * (ka_mco(ig,jmcop,indmp) - ka_mco(ig,jmco,indmp)) + absco = com1 + minorfrac(k) * (com2 - com1) + + taug(ns13+ig,k) = speccomb & + & * (fac000*absa(ig,id000) + fac010*absa(ig,id010) & + & + fac100*absa(ig,id100) + fac110*absa(ig,id110) & + & + fac200*absa(ig,id200) + fac210*absa(ig,id210)) & + & + speccomb1 & + & * (fac001*absa(ig,id001) + fac011*absa(ig,id011) & + & + fac101*absa(ig,id101) + fac111*absa(ig,id111) & + & + fac201*absa(ig,id201) + fac211*absa(ig,id211)) & + & + tauself + taufor + adjcolco2*absco2 & + & + colamt(k,7)*absco + + fracs(ns13+ig,k) = fracrefa(ig,jpl) + fpl & + & * (fracrefa(ig,jplp) - fracrefa(ig,jpl)) + enddo + enddo + +! --- ... upper atmosphere loop + + do k = laytrop+1, nlay + indm = indminor(k) + indmp = indm + 1 + + do ig = 1, ng13 + abso3 = kb_mo3(ig,indm) + minorfrac(k) & + & * (kb_mo3(ig,indmp) - kb_mo3(ig,indm)) + + taug(ns13+ig,k) = colamt(k,3)*abso3 + + fracs(ns13+ig,k) = fracrefb(ig) + enddo + enddo + +! .................................. + end subroutine taugb13 +! ---------------------------------- + +!>\ingroup module_radlw_main +!> Band 14: 2250-2380 cm-1 (low - co2; high - co2) +! ---------------------------------- + subroutine taugb14 +! .................................. + +! ------------------------------------------------------------------ ! +! band 14: 2250-2380 cm-1 (low - co2; high - co2) ! +! ------------------------------------------------------------------ ! + + use module_radlw_kgb14 + +! --- locals: + integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, & + & ig + + real (kind=kind_phys) :: tauself, taufor +! +!===> ... begin here +! +! --- ... lower atmosphere loop + + do k = 1, laytrop + ind0 = ((jp(k)-1)*5 + (jt (k)-1)) * nspa(14) + 1 + ind1 = ( jp(k) *5 + (jt1(k)-1)) * nspa(14) + 1 + + inds = indself(k) + indf = indfor(k) + ind0p = ind0 + 1 + ind1p = ind1 + 1 + indsp = inds + 1 + indfp = indf + 1 + + do ig = 1, ng14 + tauself = selffac(k) * (selfref(ig,inds) + selffrac(k) & + & * (selfref(ig,indsp) - selfref(ig,inds))) + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + + taug(ns14+ig,k) = colamt(k,2) & + & * (fac00(k)*absa(ig,ind0) + fac10(k)*absa(ig,ind0p) & + & + fac01(k)*absa(ig,ind1) + fac11(k)*absa(ig,ind1p)) & + & + tauself + taufor + + fracs(ns14+ig,k) = fracrefa(ig) + enddo + enddo + +! --- ... upper atmosphere loop + + do k = laytrop+1, nlay + ind0 = ((jp(k)-13)*5 + (jt (k)-1)) * nspb(14) + 1 + ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(14) + 1 + + ind0p = ind0 + 1 + ind1p = ind1 + 1 + + do ig = 1, ng14 + taug(ns14+ig,k) = colamt(k,2) & + & * (fac00(k)*absb(ig,ind0) + fac10(k)*absb(ig,ind0p) & + & + fac01(k)*absb(ig,ind1) + fac11(k)*absb(ig,ind1p)) + + fracs(ns14+ig,k) = fracrefb(ig) + enddo + enddo + +! .................................. + end subroutine taugb14 +! ---------------------------------- + +!>\ingroup module_radlw_main +!> Band 15: 2380-2600 cm-1 (low - n2o,co2; low minor - n2) +!! (high - nothing) +! ---------------------------------- + subroutine taugb15 +! .................................. + +! ------------------------------------------------------------------ ! +! band 15: 2380-2600 cm-1 (low - n2o,co2; low minor - n2) ! +! (high - nothing) ! +! ------------------------------------------------------------------ ! + + use module_radlw_kgb15 + +! --- locals: + integer :: k, ind0, ind1, inds, indsp, indf, indfp, indm, indmp, & + & id000, id010, id100, id110, id200, id210, jpl, jplp, & + & id001, id011, id101, id111, id201, id211, jmn2, jmn2p, & + & ig, js, js1 + + real (kind=kind_phys) :: scalen2, tauself, taufor, & + & speccomb, specparm, specmult, fs, & + & speccomb1, specparm1, specmult1, fs1, & + & speccomb_mn2, specparm_mn2, specmult_mn2, fmn2, & + & speccomb_planck,specparm_planck,specmult_planck,fpl, & + & refrat_planck_a, refrat_m_a, n2m1, n2m2, taun2, & + & fac000, fac100, fac200, fac010, fac110, fac210, & + & fac001, fac101, fac201, fac011, fac111, fac211, & + & p0, p40, fk00, fk10, fk20, p1, p41, fk01, fk11, fk21 +! +!===> ... begin here +! +! --- ... minor gas mapping level : +! lower - nitrogen continuum, P = 1053., T = 294. + +! --- ... calculate reference ratio to be used in calculation of Planck +! fraction in lower atmosphere. + + refrat_planck_a = chi_mls(4,1)/chi_mls(2,1) ! P = 1053. mb (Level 1) + refrat_m_a = chi_mls(4,1)/chi_mls(2,1) ! P = 1053. mb + +! --- ... lower atmosphere loop + + do k = 1, laytrop + speccomb = colamt(k,4) + rfrate(k,5,1)*colamt(k,2) + specparm = colamt(k,4) / speccomb + specmult = 8.0 * min(specparm, oneminus) + js = 1 + int(specmult) + fs = mod(specmult, f_one) + ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(15) + js + + speccomb1 = colamt(k,4) + rfrate(k,5,2)*colamt(k,2) + specparm1 = colamt(k,4) / speccomb1 + specmult1 = 8.0 * min(specparm1, oneminus) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1, f_one) + ind1 = (jp(k)*5 + (jt1(k)-1)) * nspa(15) + js1 + + speccomb_mn2 = colamt(k,4) + refrat_m_a*colamt(k,2) + specparm_mn2 = colamt(k,4) / speccomb_mn2 + specmult_mn2 = 8.0 * min(specparm_mn2, oneminus) + jmn2 = 1 + int(specmult_mn2) + fmn2 = mod(specmult_mn2, f_one) + + speccomb_planck = colamt(k,4) + refrat_planck_a*colamt(k,2) + specparm_planck = colamt(k,4) / speccomb_planck + specmult_planck = 8.0 * min(specparm_planck, oneminus) + jpl = 1 + int(specmult_planck) + fpl = mod(specmult_planck, f_one) + + scalen2 = colbrd(k) * scaleminor(k) + + inds = indself(k) + indf = indfor(k) + indm = indminor(k) + indsp = inds + 1 + indfp = indf + 1 + indmp = indm + 1 + jplp = jpl + 1 + jmn2p = jmn2 + 1 + + if (specparm < 0.125) then + p0 = fs - f_one + p40 = p0**4 + fk00 = p40 + fk10 = f_one - p0 - 2.0*p40 + fk20 = p0 + p40 + + id000 = ind0 + id010 = ind0 + 9 + id100 = ind0 + 1 + id110 = ind0 +10 + id200 = ind0 + 2 + id210 = ind0 +11 + elseif (specparm > 0.875) then + p0 = -fs + p40 = p0**4 + fk00 = p40 + fk10 = f_one - p0 - 2.0*p40 + fk20 = p0 + p40 + + id000 = ind0 + 1 + id010 = ind0 +10 + id100 = ind0 + id110 = ind0 + 9 + id200 = ind0 - 1 + id210 = ind0 + 8 + else + fk00 = f_one - fs + fk10 = fs + fk20 = f_zero + + id000 = ind0 + id010 = ind0 + 9 + id100 = ind0 + 1 + id110 = ind0 +10 + id200 = ind0 + id210 = ind0 + endif + + fac000 = fk00 * fac00(k) + fac100 = fk10 * fac00(k) + fac200 = fk20 * fac00(k) + fac010 = fk00 * fac10(k) + fac110 = fk10 * fac10(k) + fac210 = fk20 * fac10(k) + + if (specparm1 < 0.125) then + p1 = fs1 - f_one + p41 = p1**4 + fk01 = p41 + fk11 = f_one - p1 - 2.0*p41 + fk21 = p1 + p41 + + id001 = ind1 + id011 = ind1 + 9 + id101 = ind1 + 1 + id111 = ind1 +10 + id201 = ind1 + 2 + id211 = ind1 +11 + elseif (specparm1 > 0.875) then + p1 = -fs1 + p41 = p1**4 + fk01 = p41 + fk11 = f_one - p1 - 2.0*p41 + fk21 = p1 + p41 + + id001 = ind1 + 1 + id011 = ind1 +10 + id101 = ind1 + id111 = ind1 + 9 + id201 = ind1 - 1 + id211 = ind1 + 8 + else + fk01 = f_one - fs1 + fk11 = fs1 + fk21 = f_zero + + id001 = ind1 + id011 = ind1 + 9 + id101 = ind1 + 1 + id111 = ind1 +10 + id201 = ind1 + id211 = ind1 + endif + + fac001 = fk01 * fac01(k) + fac101 = fk11 * fac01(k) + fac201 = fk21 * fac01(k) + fac011 = fk01 * fac11(k) + fac111 = fk11 * fac11(k) + fac211 = fk21 * fac11(k) + + do ig = 1, ng15 + tauself = selffac(k)* (selfref(ig,inds) + selffrac(k) & + & * (selfref(ig,indsp) - selfref(ig,inds))) + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + n2m1 = ka_mn2(ig,jmn2,indm) + fmn2 & + & * (ka_mn2(ig,jmn2p,indm) - ka_mn2(ig,jmn2,indm)) + n2m2 = ka_mn2(ig,jmn2,indmp) + fmn2 & + & * (ka_mn2(ig,jmn2p,indmp) - ka_mn2(ig,jmn2,indmp)) + taun2 = scalen2 * (n2m1 + minorfrac(k) * (n2m2 - n2m1)) + + taug(ns15+ig,k) = speccomb & + & * (fac000*absa(ig,id000) + fac010*absa(ig,id010) & + & + fac100*absa(ig,id100) + fac110*absa(ig,id110) & + & + fac200*absa(ig,id200) + fac210*absa(ig,id210)) & + & + speccomb1 & + & * (fac001*absa(ig,id001) + fac011*absa(ig,id011) & + & + fac101*absa(ig,id101) + fac111*absa(ig,id111) & + & + fac201*absa(ig,id201) + fac211*absa(ig,id211)) & + & + tauself + taufor + taun2 + + fracs(ns15+ig,k) = fracrefa(ig,jpl) + fpl & + & * (fracrefa(ig,jplp) - fracrefa(ig,jpl)) + enddo + enddo + +! --- ... upper atmosphere loop + + do k = laytrop+1, nlay + do ig = 1, ng15 + taug(ns15+ig,k) = f_zero + + fracs(ns15+ig,k) = f_zero + enddo + enddo + +! .................................. + end subroutine taugb15 +! ---------------------------------- + +!>\ingroup module_radlw_main +!> Band 16: 2600-3250 cm-1 (low key- h2o,ch4; high key - ch4) +! ---------------------------------- + subroutine taugb16 +! .................................. + +! ------------------------------------------------------------------ ! +! band 16: 2600-3250 cm-1 (low key- h2o,ch4; high key - ch4) ! +! ------------------------------------------------------------------ ! + + use module_radlw_kgb16 + +! --- locals: + integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, & + & id000, id010, id100, id110, id200, id210, jpl, jplp, & + & id001, id011, id101, id111, id201, id211, ig, js, js1 + + real (kind=kind_phys) :: tauself, taufor, refrat_planck_a, & + & speccomb, specparm, specmult, fs, & + & speccomb1, specparm1, specmult1, fs1, & + & speccomb_planck,specparm_planck,specmult_planck,fpl, & + & fac000, fac100, fac200, fac010, fac110, fac210, & + & fac001, fac101, fac201, fac011, fac111, fac211, & + & p0, p40, fk00, fk10, fk20, p1, p41, fk01, fk11, fk21 +! +!===> ... begin here +! +! --- ... calculate reference ratio to be used in calculation of Planck +! fraction in lower atmosphere. + + refrat_planck_a = chi_mls(1,6)/chi_mls(6,6) ! P = 387. mb (Level 6) + +! --- ... lower atmosphere loop + + do k = 1, laytrop + speccomb = colamt(k,1) + rfrate(k,4,1)*colamt(k,5) + specparm = colamt(k,1) / speccomb + specmult = 8.0 * min(specparm, oneminus) + js = 1 + int(specmult) + fs = mod(specmult, f_one) + ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(16) + js + + speccomb1 = colamt(k,1) + rfrate(k,4,2)*colamt(k,5) + specparm1 = colamt(k,1) / speccomb1 + specmult1 = 8.0 * min(specparm1, oneminus) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1, f_one) + ind1 = (jp(k)*5 + (jt1(k)-1)) * nspa(16) + js1 + + speccomb_planck = colamt(k,1) + refrat_planck_a*colamt(k,5) + specparm_planck = colamt(k,1) / speccomb_planck + specmult_planck = 8.0 * min(specparm_planck, oneminus) + jpl = 1 + int(specmult_planck) + fpl = mod(specmult_planck, f_one) + + inds = indself(k) + indf = indfor(k) + indsp = inds + 1 + indfp = indf + 1 + jplp = jpl + 1 + + if (specparm < 0.125) then + p0 = fs - f_one + p40 = p0**4 + fk00 = p40 + fk10 = f_one - p0 - 2.0*p40 + fk20 = p0 + p40 + + id000 = ind0 + id010 = ind0 + 9 + id100 = ind0 + 1 + id110 = ind0 +10 + id200 = ind0 + 2 + id210 = ind0 +11 + elseif (specparm > 0.875) then + p0 = -fs + p40 = p0**4 + fk00 = p40 + fk10 = f_one - p0 - 2.0*p40 + fk20 = p0 + p40 + + id000 = ind0 + 1 + id010 = ind0 +10 + id100 = ind0 + id110 = ind0 + 9 + id200 = ind0 - 1 + id210 = ind0 + 8 + else + fk00 = f_one - fs + fk10 = fs + fk20 = f_zero + + id000 = ind0 + id010 = ind0 + 9 + id100 = ind0 + 1 + id110 = ind0 +10 + id200 = ind0 + id210 = ind0 + endif + + fac000 = fk00 * fac00(k) + fac100 = fk10 * fac00(k) + fac200 = fk20 * fac00(k) + fac010 = fk00 * fac10(k) + fac110 = fk10 * fac10(k) + fac210 = fk20 * fac10(k) + + if (specparm1 < 0.125) then + p1 = fs1 - f_one + p41 = p1**4 + fk01 = p41 + fk11 = f_one - p1 - 2.0*p41 + fk21 = p1 + p41 + + id001 = ind1 + id011 = ind1 + 9 + id101 = ind1 + 1 + id111 = ind1 +10 + id201 = ind1 + 2 + id211 = ind1 +11 + elseif (specparm1 > 0.875) then + p1 = -fs1 + p41 = p1**4 + fk01 = p41 + fk11 = f_one - p1 - 2.0*p41 + fk21 = p1 + p41 + + id001 = ind1 + 1 + id011 = ind1 +10 + id101 = ind1 + id111 = ind1 + 9 + id201 = ind1 - 1 + id211 = ind1 + 8 + else + fk01 = f_one - fs1 + fk11 = fs1 + fk21 = f_zero + + id001 = ind1 + id011 = ind1 + 9 + id101 = ind1 + 1 + id111 = ind1 +10 + id201 = ind1 + id211 = ind1 + endif + + fac001 = fk01 * fac01(k) + fac101 = fk11 * fac01(k) + fac201 = fk21 * fac01(k) + fac011 = fk01 * fac11(k) + fac111 = fk11 * fac11(k) + fac211 = fk21 * fac11(k) + + do ig = 1, ng16 + tauself = selffac(k)* (selfref(ig,inds) + selffrac(k) & + & * (selfref(ig,indsp) - selfref(ig,inds))) + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + + taug(ns16+ig,k) = speccomb & + & * (fac000*absa(ig,id000) + fac010*absa(ig,id010) & + & + fac100*absa(ig,id100) + fac110*absa(ig,id110) & + & + fac200*absa(ig,id200) + fac210*absa(ig,id210)) & + & + speccomb1 & + & * (fac001*absa(ig,id001) + fac011*absa(ig,id011) & + & + fac101*absa(ig,id101) + fac111*absa(ig,id111) & + & + fac201*absa(ig,id201) + fac211*absa(ig,id211)) & + & + tauself + taufor + + fracs(ns16+ig,k) = fracrefa(ig,jpl) + fpl & + & * (fracrefa(ig,jplp) - fracrefa(ig,jpl)) + enddo + enddo + +! --- ... upper atmosphere loop + + do k = laytrop+1, nlay + ind0 = ((jp(k)-13)*5 + (jt (k)-1)) * nspb(16) + 1 + ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(16) + 1 + + ind0p = ind0 + 1 + ind1p = ind1 + 1 + + do ig = 1, ng16 + taug(ns16+ig,k) = colamt(k,5) & + & * (fac00(k)*absb(ig,ind0) + fac10(k)*absb(ig,ind0p) & + & + fac01(k)*absb(ig,ind1) + fac11(k)*absb(ig,ind1p)) + + fracs(ns16+ig,k) = fracrefb(ig) + enddo + enddo + +! .................................. + end subroutine taugb16 +! ---------------------------------- + +! .................................. + end subroutine taumol +!! @} +!----------------------------------- + +!mz* exponential cloud overlapping subroutines +!------------------------------------------------------------------ +! Public subroutines +!------------------------------------------------------------------ +! mz* - Add height needed for exponential and exponential-random cloud overlap methods (icld=4 and 5, respectively) + subroutine mcica_subcol_lw(iplon, ncol, nlay, icld, permuteseed, & + & irng, play, hgt, & + & cldfrac, ciwp, clwp, cswp, rei, rel, res, tauc, & + & cldfmcl, & + & ciwpmcl, clwpmcl, cswpmcl, reicmcl, relqmcl, & + & resnmcl, taucmcl) + + use machine, only : im => kind_io4, rb => kind_phys +! ----- Input ----- +! Control + integer(kind=im), intent(in) :: iplon ! column/longitude index + integer(kind=im), intent(in) :: ncol ! number of columns + integer(kind=im), intent(in) :: nlay ! number of model layers + integer(kind=im), intent(in) :: icld ! clear/cloud, cloud overlap flag + integer(kind=im), intent(in) :: permuteseed ! if the cloud generator is called multiple times, + ! permute the seed between each call. + ! between calls for LW and SW, recommended + ! permuteseed differes by 'ngpt' + integer(kind=im), intent(inout) :: irng ! flag for random number generator + ! 0 = kissvec + ! 1 = Mersenne + ! Twister + +! Atmosphere + real(kind=rb), intent(in) :: play(:,:) ! layer pressures (mb) + ! Dimensions: (ncol,nlay) + +! mji - Add height + real(kind=rb), intent(in) :: hgt(:,:) ! layer height (m) + ! Dimensions: (ncol,nlay) + +! Atmosphere/clouds - cldprop + real(kind=rb), intent(in) :: cldfrac(:,:) ! layer cloud fraction + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: tauc(:,:,:) ! in-cloud optical depth + ! Dimensions: (nbndlw,ncol,nlay) +! real(kind=rb), intent(in) :: ssac(:,:,:) ! in-cloud single scattering albedo + ! Dimensions: (nbndlw,ncol,nlay) +! real(kind=rb), intent(in) :: asmc(:,:,:) ! in-cloud asymmetry parameter + ! Dimensions: (nbndlw,ncol,nlay) + real(kind=rb), intent(in) :: ciwp(:,:) ! in-cloud ice water path + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: clwp(:,:) ! in-cloud liquid water path + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: cswp(:,:) ! in-cloud snow path + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: rei(:,:) ! cloud ice particle size + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: rel(:,:) ! cloud liquid particle size + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: res(:,:) ! snow particle size + ! Dimensions: (ncol,nlay) + +! ----- Output ----- +! Atmosphere/clouds - cldprmc [mcica] + real(kind=rb), intent(out) :: cldfmcl(:,:,:) ! cloud fraction [mcica] + ! Dimensions: (ngptlw,ncol,nlay) + real(kind=rb), intent(out) :: ciwpmcl(:,:,:) ! in-cloud ice water path [mcica] + ! Dimensions: (ngptlw,ncol,nlay) + real(kind=rb), intent(out) :: clwpmcl(:,:,:) ! in-cloud liquid water path [mcica] + ! Dimensions: (ngptlw,ncol,nlay) + real(kind=rb), intent(out) :: cswpmcl(:,:,:) ! in-cloud snow path [mcica] + ! Dimensions: (ngptlw,ncol,nlay) + real(kind=rb), intent(out) :: relqmcl(:,:) ! liquid particle size (microns) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(out) :: reicmcl(:,:) ! ice partcle size (microns) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(out) :: resnmcl(:,:) ! snow partcle size (microns) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(out) :: taucmcl(:,:,:) ! in-cloud optical depth [mcica] +!mz* + ! Dimensions: (ngptlw,ncol,nlay) +! real(kind=rb), intent(out) :: ssacmcl(:,:,:) ! in-cloud single scattering albedo [mcica] + ! Dimensions: (ngptlw,ncol,nlay) +! real(kind=rb), intent(out) :: asmcmcl(:,:,:) ! in-cloud asymmetry parameter [mcica] + ! Dimensions: (ngptlw,ncol,nlay) +! ----- Local ----- + +! Stochastic cloud generator variables [mcica] + integer(kind=im), parameter :: nsubclw = ngptlw ! number of sub-columns (g-point intervals) + integer(kind=im) :: ilev ! loop index + + real(kind=rb) :: pmid(ncol, nlay) ! layer pressures (Pa) +! real(kind=rb) :: pdel(ncol, nlay) ! layer pressure thickness (Pa) +! real(kind=rb) :: qi(ncol, nlay) ! ice water (specific humidity) +! real(kind=rb) :: ql(ncol, nlay) ! liq water (specific humidity) + +! Return if clear sky + if (icld.eq.0) return + +! NOTE: For GCM mode, permuteseed must be offset between LW and SW by at least the number of subcolumns + + +! Pass particle sizes to new arrays, no subcolumns for these properties yet +! Convert pressures from mb to Pa + + reicmcl(:ncol,:nlay) = rei(:ncol,:nlay) + relqmcl(:ncol,:nlay) = rel(:ncol,:nlay) + resnmcl(:ncol,:nlay) = res(:ncol,:nlay) + pmid(:ncol,:nlay) = play(:ncol,:nlay)*1.e2_rb + +! Generate the stochastic subcolumns of cloud optical properties for +! the longwave + call generate_stochastic_clouds (ncol, nlay, nsubclw, icld, irng, & + & pmid, hgt, cldfrac, clwp, ciwp, cswp, tauc, & + & cldfmcl, clwpmcl, ciwpmcl, cswpmcl, & + & taucmcl, permuteseed) + + end subroutine mcica_subcol_lw +!------------------------------------------------------------------------------------------------- + subroutine generate_stochastic_clouds(ncol, nlay, nsubcol, icld, & + & irng, pmid, hgt, cld, clwp, ciwp, cswp, tauc, & + & cld_stoch, clwp_stoch, ciwp_stoch, & + & cswp_stoch, tauc_stoch, changeSeed) +!------------------------------------------------------------------------------------------------- +!------------------------------------------------------------------------------------------------- +! Contact: Cecile Hannay (hannay@ucar.edu) +! +! Original code: Based on Raisanen et al., QJRMS, 2004. +! +! Modifications: +! 1) Generalized for use with RRTMG and added Mersenne Twister as the default +! random number generator, which can be changed to the optional kissvec random number generator +! with flag 'irng'. Some extra functionality has been commented or removed. +! Michael J. Iacono, AER, Inc., February 2007 +! 2) Activated exponential and exponential/random cloud overlap method +! Michael J. Iacono, AER, November 2017 +! +! Given a profile of cloud fraction, cloud water and cloud ice, we produce a set of subcolumns. +! Each layer within each subcolumn is homogeneous, with cloud fraction equal to zero or one +! and uniform cloud liquid and cloud ice concentration. +! The ensemble as a whole reproduces the probability function of cloud liquid and ice within each layer +! and obeys an overlap assumption in the vertical. +! +! Overlap assumption: +! The cloud are consistent with 5 overlap assumptions: random, maximum, maximum-random, exponential and exponential random. +! The default option is maximum-random (option 2) +! The options are: 1=random overlap, 2=max/random, 3=maximum overlap, 4=exponential overlap, 5=exp/random +! This is set with the variable "overlap" +! The exponential overlap uses also a length scale, Zo. (real, parameter :: Zo = 2500. ) +! +! Seed: +! If the stochastic cloud generator is called several times during the same timestep, +! one should change the seed between the call to insure that the +! subcolumns are different. +! This is done by changing the argument 'changeSeed' +! For example, if one wants to create a set of columns for the +! shortwave and another set for the longwave , +! use 'changeSeed = 1' for the first call and'changeSeed = 2' for the second call + +! PDF assumption: +! We can use arbitrary complicated PDFS. +! In the present version, we produce homogeneuous clouds (the simplest case). +! Future developments include using the PDF scheme of Ben Johnson. +! +! History file: +! Option to add diagnostics variables in the history file. (using FINCL in the namelist) +! nsubcol = number of subcolumns +! overlap = overlap type (1-3) +! Zo = length scale +! CLOUD_S = mean of the subcolumn cloud fraction ('_S" means Stochastic) +! CLDLIQ_S = mean of the subcolumn cloud water +! CLDICE_S = mean of the subcolumn cloud ice +! +! Note: +! Here: we force that the cloud condensate to be consistent with the cloud fraction +! i.e we only have cloud condensate when the cell is cloudy. +! In CAM: The cloud condensate and the cloud fraction are obtained from 2 different equations +! and the 2 quantities can be inconsistent (i.e. CAM can produce cloud fraction +! without cloud condensate or the opposite). +!----------------------------------------------------------------- + + use mcica_random_numbers +! The Mersenne Twister random number engine + use MersenneTwister, only: randomNumberSequence, & + & new_RandomNumberSequence, getRandomReal + use machine ,only : im => kind_io4, rb => kind_phys + + type(randomNumberSequence) :: randomNumbers + +! -- Arguments + + integer(kind=im), intent(in) :: ncol ! number of columns + integer(kind=im), intent(in) :: nlay ! number of layers + integer(kind=im), intent(in) :: icld ! clear/cloud, cloud overlap flag + integer(kind=im), intent(inout) :: irng ! flag for random number generator + ! 0 = kissvec + ! 1 = Mersenne Twister + integer(kind=im), intent(in) :: nsubcol ! number of sub-columns (g-point intervals) + integer(kind=im), optional, intent(in) :: changeSeed ! allows permuting seed + +! Column state (cloud fraction, cloud water, cloud ice) + variables needed to read physics state + real(kind=rb), intent(in) :: pmid(:,:) ! layer pressure (Pa) + ! Dimensions: (ncol,nlay) + + real(kind=rb), intent(in) :: hgt(:,:) ! layer height (m) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: cld(:,:) ! cloud fraction + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: clwp(:,:) ! in-cloud liquid water path + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: ciwp(:,:) ! in-cloud ice water path + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: cswp(:,:) ! in-cloud snow path + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: tauc(:,:,:) ! in-cloud optical depth + ! Dimensions:(nbndlw,ncol,nlay) +! real(kind=rb), intent(in) :: ssac(:,:,:) ! in-cloud single scattering albedo + ! Dimensions: (nbndlw,ncol,nlay) + ! inactive - for future expansion +! real(kind=rb), intent(in) :: asmc(:,:,:) ! in-cloud asymmetry parameter + ! Dimensions: (nbndlw,ncol,nlay) + ! inactive - for future expansion + + real(kind=rb), intent(out) :: cld_stoch(:,:,:) ! subcolumn cloud fraction + ! Dimensions: (ngptlw,ncol,nlay) + real(kind=rb), intent(out) :: clwp_stoch(:,:,:) ! subcolumn in-cloud liquid water path + ! Dimensions: (ngptlw,ncol,nlay) + real(kind=rb), intent(out) :: ciwp_stoch(:,:,:) ! subcolumn in-cloud ice water path + ! Dimensions: (ngptlw,ncol,nlay) + real(kind=rb), intent(out) :: cswp_stoch(:,:,:) ! subcolumn in-cloud snow path + ! Dimensions: (ngptlw,ncol,nlay) + real(kind=rb), intent(out) :: tauc_stoch(:,:,:) ! subcolumn in-cloud optical depth + ! Dimensions: (ngptlw,ncol,nlay) +! real(kind=rb), intent(out) :: ssac_stoch(:,:,:)! subcolumn in-cloud single scattering albedo + ! Dimensions: (ngptlw,ncol,nlay) + ! inactive - for future expansion +! real(kind=rb), intent(out) :: asmc_stoch(:,:,:)! subcolumn in-cloud asymmetry parameter + ! Dimensions: (ngptlw,ncol,nlay) + ! inactive - for future expansion + +! -- Local variables + real(kind=rb) :: cldf(ncol,nlay) ! cloud fraction + +! Mean over the subcolumns (cloud fraction, cloud water , cloud ice) - inactive +! real(kind=rb) :: mean_cld_stoch(ncol, nlay) ! cloud fraction +! real(kind=rb) :: mean_clwp_stoch(ncol, nlay) ! cloud water +! real(kind=rb) :: mean_ciwp_stoch(ncol, nlay) ! cloud ice +! real(kind=rb) :: mean_tauc_stoch(ncol, nlay) ! cloud optical depth +! real(kind=rb) :: mean_ssac_stoch(ncol, nlay) ! cloud single scattering albedo +! real(kind=rb) :: mean_asmc_stoch(ncol, nlay) ! cloud asymmetry parameter + +! Set overlap + integer(kind=im) :: overlap ! 1 = random overlap, 2 = maximum-random, + ! 3 = maximum overlap, 4 = exponential, + ! 5 = exponential-random + real(kind=rb), parameter :: Zo = 2500._rb ! length scale (m) + real(kind=rb), dimension(ncol,nlay) :: alpha ! overlap parameter + +! Constants (min value for cloud fraction and cloud water and ice) + real(kind=rb), parameter :: cldmin = 1.0e-20_rb ! min cloud fraction +! real(kind=rb), parameter :: qmin = 1.0e-10_rb ! min cloud water and cloud ice (not used) + +! Variables related to random number and seed + real(kind=rb), dimension(nsubcol, ncol, nlay) :: CDF, CDF2 !random numbers + integer(kind=im), dimension(ncol) :: seed1, seed2, seed3, seed4 !seed to create random number (kissvec) + real(kind=rb), dimension(ncol) :: rand_num ! random number (kissvec) + integer(kind=im) :: iseed ! seed to create random number (Mersenne Teister) + real(kind=rb) :: rand_num_mt ! random number (Mersenne Twister) + +! Flag to identify cloud fraction in subcolumns + logical, dimension(nsubcol, ncol, nlay) :: iscloudy ! flag that says whether a gridbox is cloudy + +! Indices + integer(kind=im) :: ilev, isubcol, i, n ! indices + +!------------------------------------------------------------------- + +! Check that irng is in bounds; if not, set to default + if (irng .ne. 0) irng = 1 + +! Pass input cloud overlap setting to local variable + overlap = icld + +! Ensure that cloud fractions are in bounds + do ilev = 1, nlay + do i = 1, ncol + cldf(i,ilev) = cld(i,ilev) + if (cldf(i,ilev) < cldmin) then + cldf(i,ilev) = 0._rb + endif + enddo + enddo + +! ----- Create seed -------- + +! Advance randum number generator by changeseed values + if (irng.eq.0) then +! For kissvec, create a seed that depends on the state of the columns. Maybe not the best way, but it works. +! Must use pmid from bottom four layers. + do i=1,ncol + if (pmid(i,1).lt.pmid(i,2)) then + stop 'MCICA_SUBCOL: KISSVEC SEED GENERATOR REQUIRES PMID & + & FROM BOTTOM FOUR LAYERS.' + endif + seed1(i) = (pmid(i,1) - int(pmid(i,1))) * 1000000000_im + seed2(i) = (pmid(i,2) - int(pmid(i,2))) * 1000000000_im + seed3(i) = (pmid(i,3) - int(pmid(i,3))) * 1000000000_im + seed4(i) = (pmid(i,4) - int(pmid(i,4))) * 1000000000_im + enddo + do i=1,changeSeed + call kissvec(seed1, seed2, seed3, seed4, rand_num) + enddo + elseif (irng.eq.1) then + randomNumbers = new_RandomNumberSequence(seed = changeSeed) + endif + +! ------ Apply overlap assumption -------- + +! generate the random numbers + + select case (overlap) + + case(1) +! Random overlap +! i) pick a random value at every level + + if (irng.eq.0) then + do isubcol = 1,nsubcol + do ilev = 1,nlay + call kissvec(seed1, seed2, seed3, seed4, rand_num) ! we get different random number for each level + CDF(isubcol,:,ilev) = rand_num + enddo + enddo + elseif (irng.eq.1) then + do isubcol = 1, nsubcol + do i = 1, ncol + do ilev = 1, nlay + rand_num_mt = getRandomReal(randomNumbers) + CDF(isubcol,i,ilev) = rand_num_mt + enddo + enddo + enddo + endif + + case(2) +! Maximum-Random overlap +! i) pick a random number for top layer. +! ii) walk down the column: +! - if the layer above is cloudy, we use the same random number than in the layer above +! - if the layer above is clear, we use a new random number + + if (irng.eq.0) then + do isubcol = 1,nsubcol + do ilev = 1,nlay + call kissvec(seed1, seed2, seed3, seed4, rand_num) + CDF(isubcol,:,ilev) = rand_num + enddo + enddo + elseif (irng.eq.1) then + do isubcol = 1, nsubcol + do i = 1, ncol + do ilev = 1, nlay + rand_num_mt = getRandomReal(randomNumbers) + CDF(isubcol,i,ilev) = rand_num_mt + enddo + enddo + enddo + endif + + do ilev = 2,nlay + do i = 1, ncol + do isubcol = 1, nsubcol + if (CDF(isubcol, i, ilev-1) > 1._rb - cldf(i,ilev-1) )& + & then + CDF(isubcol,i,ilev) = CDF(isubcol,i,ilev-1) + else + CDF(isubcol,i,ilev) = CDF(isubcol,i,ilev) * (1._rb & + & - cldf(i,ilev-1)) + endif + enddo + enddo + enddo + + case(3) +! Maximum overlap +! i) pick the same random numebr at every level + + if (irng.eq.0) then + do isubcol = 1,nsubcol + call kissvec(seed1, seed2, seed3, seed4, rand_num) + do ilev = 1,nlay + CDF(isubcol,:,ilev) = rand_num + enddo + enddo + elseif (irng.eq.1) then + do isubcol = 1, nsubcol + do i = 1, ncol + rand_num_mt = getRandomReal(randomNumbers) + do ilev = 1, nlay + CDF(isubcol,i,ilev) = rand_num_mt + enddo + enddo + enddo + endif + +! mji - Activate exponential cloud overlap option + case(4) + ! Exponential overlap: weighting between maximum and random overlap increases with the distance. + ! The random numbers for exponential overlap verify: + ! j=1 RAN(j)=RND1 + ! j>1 if RND1 < alpha(j,j-1) => RAN(j) = RAN(j-1) + ! RAN(j) = RND2 + ! alpha is obtained from the equation + ! alpha = exp(-(Z(j)-Z(j-1))/Zo) where Zo is a characteristic length scale + + ! compute alpha + do i = 1, ncol + alpha(i, 1) = 0._rb + do ilev = 2,nlay + alpha(i, ilev) = exp( -( hgt (i, ilev) - & + & hgt (i, ilev-1)) / Zo) + enddo + enddo + + ! generate 2 streams of random numbers + if (irng.eq.0) then + do isubcol = 1,nsubcol + do ilev = 1,nlay + call kissvec(seed1, seed2, seed3, seed4, rand_num) + CDF(isubcol, :, ilev) = rand_num + call kissvec(seed1, seed2, seed3, seed4, rand_num) + CDF2(isubcol, :, ilev) = rand_num + enddo + enddo + elseif (irng.eq.1) then + do isubcol = 1, nsubcol + do i = 1, ncol + do ilev = 1, nlay + rand_num_mt = getRandomReal(randomNumbers) + CDF(isubcol,i,ilev) = rand_num_mt + rand_num_mt = getRandomReal(randomNumbers) + CDF2(isubcol,i,ilev) = rand_num_mt + enddo + enddo + enddo + endif + + ! generate random numbers + do ilev = 2,nlay + where (CDF2(:, :, ilev) < spread(alpha (:,ilev), & + & dim=1,nCopies=nsubcol) ) + CDF(:,:,ilev) = CDF(:,:,ilev-1) + end where + end do + +! Activate exponential-random cloud overlap option + case(5) + ! Exponential-random overlap: +!mz* call wrf_error_fatal("Cloud Overlap case 5: ER has not yet & +! been implemented. Stopping...") + + end select + +! -- generate subcolumns for homogeneous clouds ----- + do ilev = 1,nlay + iscloudy(:,:,ilev) = (CDF(:,:,ilev) >= 1._rb - & + & spread(cldf(:,ilev), dim=1, nCopies=nsubcol) ) + enddo + +! where the subcolumn is cloudy, the subcolumn cloud fraction is 1; +! where the subcolumn is not cloudy, the subcolumn cloud fraction is 0; +! where there is a cloud, define the subcolumn cloud properties, +! otherwise set these to zero + + do ilev = 1,nlay + do i = 1, ncol + do isubcol = 1, nsubcol + if (iscloudy(isubcol,i,ilev) ) then + cld_stoch(isubcol,i,ilev) = 1._rb + clwp_stoch(isubcol,i,ilev) = clwp(i,ilev) + ciwp_stoch(isubcol,i,ilev) = ciwp(i,ilev) +!mz +! cswp_stoch(isubcol,i,ilev) = cswp(i,ilev) + cswp_stoch(isubcol,i,ilev) = 0._rb + n = ngb(isubcol) + tauc_stoch(isubcol,i,ilev) = tauc(n,i,ilev) +! ssac_stoch(isubcol,i,ilev) = ssac(n,i,ilev) +! asmc_stoch(isubcol,i,ilev) = asmc(n,i,ilev) + else + cld_stoch(isubcol,i,ilev) = 0._rb + clwp_stoch(isubcol,i,ilev) = 0._rb + ciwp_stoch(isubcol,i,ilev) = 0._rb + cswp_stoch(isubcol,i,ilev) = 0._rb + tauc_stoch(isubcol,i,ilev) = 0._rb +! ssac_stoch(isubcol,i,ilev) = 1._rb +! asmc_stoch(isubcol,i,ilev) = 1._rb + endif + enddo + enddo + enddo + +! -- compute the means of the subcolumns --- +! mean_cld_stoch(:,:) = 0._rb +! mean_clwp_stoch(:,:) = 0._rb +! mean_ciwp_stoch(:,:) = 0._rb +! mean_tauc_stoch(:,:) = 0._rb +! mean_ssac_stoch(:,:) = 0._rb +! mean_asmc_stoch(:,:) = 0._rb +! do i = 1, nsubcol +! mean_cld_stoch(:,:) = cld_stoch(i,:,:) + mean_cld_stoch(:,:) +! mean_clwp_stoch(:,:) = clwp_stoch( i,:,:) + mean_clwp_stoch(:,:) +! mean_ciwp_stoch(:,:) = ciwp_stoch( i,:,:) + mean_ciwp_stoch(:,:) +! mean_tauc_stoch(:,:) = tauc_stoch( i,:,:) + mean_tauc_stoch(:,:) +! mean_ssac_stoch(:,:) = ssac_stoch( i,:,:) + mean_ssac_stoch(:,:) +! mean_asmc_stoch(:,:) = asmc_stoch( i,:,:) + mean_asmc_stoch(:,:) +! end do +! mean_cld_stoch(:,:) = mean_cld_stoch(:,:) / nsubcol +! mean_clwp_stoch(:,:) = mean_clwp_stoch(:,:) / nsubcol +! mean_ciwp_stoch(:,:) = mean_ciwp_stoch(:,:) / nsubcol +! mean_tauc_stoch(:,:) = mean_tauc_stoch(:,:) / nsubcol +! mean_ssac_stoch(:,:) = mean_ssac_stoch(:,:) / nsubcol +! mean_asmc_stoch(:,:) = mean_asmc_stoch(:,:) / nsubcol + + end subroutine generate_stochastic_clouds + +!------------------------------------------------------------------ +! Private subroutines +!------------------------------------------------------------------ + +!----------------------------------------------------------------- + subroutine kissvec(seed1,seed2,seed3,seed4,ran_arr) +!---------------------------------------------------------------- + +! public domain code +! made available from http://www.fortran.com/ +! downloaded by pjr on 03/16/04 for NCAR CAM +! converted to vector form, functions inlined by pjr,mvr on 05/10/2004 + +! The KISS (Keep It Simple Stupid) random number generator. Combines: +! (1) The congruential generator x(n)=69069*x(n-1)+1327217885, period 2^32. +! (2) A 3-shift shift-register generator, period 2^32-1, +! (3) Two 16-bit multiply-with-carry generators, period 597273182964842497>2^59 +! Overall period>2^123; + real(kind=rb), dimension(:), intent(inout) :: ran_arr + integer(kind=im), dimension(:), intent(inout) :: seed1,seed2,seed3& + & ,seed4 + integer(kind=im) :: i,sz,kiss + integer(kind=im) :: m, k, n + +! inline function + m(k, n) = ieor (k, ishft (k, n) ) + + sz = size(ran_arr) + do i = 1, sz + seed1(i) = 69069_im * seed1(i) + 1327217885_im + seed2(i) = m (m (m (seed2(i), 13_im), - 17_im), 5_im) + seed3(i) = 18000_im * iand (seed3(i), 65535_im) + & + & ishft (seed3(i), - 16_im) + seed4(i) = 30903_im * iand (seed4(i), 65535_im) + & + & ishft (seed4(i), - 16_im) + kiss = seed1(i) + seed2(i) + ishft (seed3(i), 16_im) + seed4(i) + ran_arr(i) = kiss*2.328306e-10_rb + 0.5_rb + end do + + end subroutine kissvec +! + subroutine rtrnmc_mcica(nlayers, istart, iend, iout, pz, semiss, & + & ncbands, cldfmc, taucmc, planklay, planklev, &!plankbnd, & + & pwvcm, fracs, taut, & + & totuflux, totdflux, htr, & + & totuclfl, totdclfl, htrc ) +!--------------------------------------------------------------- +! +! Original version: E. J. Mlawer, et al. RRTM_V3.0 +! Revision for GCMs: Michael J. Iacono; October, 2002 +! Revision for F90: Michael J. Iacono; June, 2006 +! +! This program calculates the upward fluxes, downward fluxes, and +! heating rates for an arbitrary clear or cloudy atmosphere. The input +! to this program is the atmospheric profile, all Planck function +! information, and the cloud fraction by layer. A variable diffusivity +! angle (SECDIFF) is used for the angle integration. Bands 2-3 and 5-9 +! use a value for SECDIFF that varies from 1.50 to 1.80 as a function of +! the column water vapor, and other bands use a value of 1.66. The Gaussian +! weight appropriate to this angle (WTDIFF=0.5) is applied here. Note that +! use of the emissivity angle for the flux integration can cause errors of +! 1 to 4 W/m2 within cloudy layers. +! Clouds are treated with the McICA stochastic approach and maximum-random +! cloud overlap. +!*************************************************************************** + +! ------- Declarations ------- + +! ----- Input ----- + integer(kind=im), intent(in) :: nlayers ! total number of layers + integer(kind=im), intent(in) :: istart ! beginning band of calculation + integer(kind=im), intent(in) :: iend ! ending band of calculation + integer(kind=im), intent(in) :: iout ! output option flag + +! Atmosphere + real(kind=rb), intent(in) :: pz(0:) ! level (interface) pressures (hPa, mb) + ! Dimensions: (0:nlayers) + real(kind=rb), intent(in) :: pwvcm ! precipitable water vapor (cm) + real(kind=rb), intent(in) :: semiss(:) ! lw surface emissivity + ! Dimensions: (nbndlw) +!mz + real(kind=rb), intent(in) :: planklay(0:,:) ! + ! Dimensions: (nlayers,nbndlw) + real(kind=rb), intent(in) :: planklev(0:,:) ! + ! Dimensions: (0:nlayers,nbndlw) +! real(kind=rb), intent(in) :: plankbnd(:) ! + ! Dimensions: (nbndlw) + real(kind=rb), intent(in) :: fracs(:,:) ! + ! Dimensions: (nlayers,ngptw) + real(kind=rb), intent(in) :: taut(:,:) ! gaseous + aerosol optical depths + ! Dimensions: (nlayers,ngptlw) + +! Clouds + integer(kind=im), intent(in) :: ncbands ! number of cloud spectral bands + real(kind=rb), intent(in) :: cldfmc(:,:) ! layer cloud fraction [mcica] + ! Dimensions: (ngptlw,nlayers) + real(kind=rb), intent(in) :: taucmc(:,:) ! layer cloud optical depth [mcica] + ! Dimensions: (ngptlw,nlayers) + +! ----- Output ----- + real(kind=rb), intent(out) :: totuflux(0:) ! upward longwave flux (w/m2) + ! Dimensions: (0:nlayers) + real(kind=rb), intent(out) :: totdflux(0:) ! downward longwave flux (w/m2) + ! Dimensions: (0:nlayers) +!mz* real(kind=rb), intent(out) :: fnet(0:) ! net longwave flux (w/m2) + ! Dimensions: (0:nlayers) + real(kind=rb), intent(out) :: htr(:) +!mz real(kind=rb), intent(out) :: htr(0:) ! longwave heating rate (k/day) + ! Dimensions: (0:nlayers) + real(kind=rb), intent(out) :: totuclfl(0:) ! clear sky upward longwave flux (w/m2) + ! Dimensions: (0:nlayers) + real(kind=rb), intent(out) :: totdclfl(0:) ! clear sky downward longwave flux (w/m2) + ! Dimensions: (0:nlayers) +!mz*real(kind=rb), intent(out) :: fnetc(0:) ! clear sky net longwave flux (w/m2) + ! Dimensions: (0:nlayers) + real(kind=rb), intent(out) :: htrc(:) +! real(kind=rb), intent(out) :: htrc(0:) ! clear sky longwave heating rate (k/day) + ! Dimensions: (0:nlayers) + +! ----- Local ----- +! Declarations for radiative transfer + real (kind=kind_phys), dimension(0:nlayers) :: fnet, fnetc + real(kind=rb) :: abscld(nlayers,ngptlw) + real(kind=rb) :: atot(nlayers) + real(kind=rb) :: atrans(nlayers) + real(kind=rb) :: bbugas(nlayers) + real(kind=rb) :: bbutot(nlayers) + real(kind=rb) :: clrurad(0:nlayers) + real(kind=rb) :: clrdrad(0:nlayers) + real(kind=rb) :: efclfrac(nlayers,ngptlw) + real(kind=rb) :: uflux(0:nlayers) + real(kind=rb) :: dflux(0:nlayers) + real(kind=rb) :: urad(0:nlayers) + real(kind=rb) :: drad(0:nlayers) + real(kind=rb) :: uclfl(0:nlayers) + real(kind=rb) :: dclfl(0:nlayers) + real(kind=rb) :: odcld(nlayers,ngptlw) + + + real(kind=rb) :: secdiff(nbands) ! secant of diffusivity angle + real(kind=rb) :: transcld, radld, radclrd, plfrac, blay, dplankup,& + & dplankdn + real(kind=rb) :: odepth, odtot, odepth_rec, odtot_rec, gassrc + real(kind=rb) :: tblind, tfactot, bbd, bbdtot, tfacgas, transc, & + & tausfac + real(kind=rb) :: rad0, reflect, radlu, radclru + + integer(kind=im) :: icldlyr(nlayers) ! flag for cloud in layer + integer(kind=im) :: ibnd, ib, iband, lay, lev, l, ig ! loop indices + integer(kind=im) :: igc ! g-point interval counter + integer(kind=im) :: iclddn ! flag for cloud in down path + integer(kind=im) :: ittot, itgas, itr ! lookup table indices +!mz* + real (kind=kind_phys), parameter :: rec_6 = 0.166667 + ! The cumulative sum of new g-points for each band + integer(kind=im) :: ngs(nbands) + ngs(:) = (/10,22,38,52,68,76,88,96,108,114,122,130,134,136,138, & + & 140/) + +! ------- Definitions ------- +! input +! nlayers ! number of model layers +! ngptlw ! total number of g-point subintervals +! nbndlw ! number of longwave spectral bands +! ncbands ! number of spectral bands for clouds +! secdiff ! diffusivity angle +! wtdiff ! weight for radiance to flux conversion +! pavel ! layer pressures (mb) +! pz ! level (interface) pressures (mb) +! tavel ! layer temperatures (k) +! tz ! level (interface) temperatures(mb) +! tbound ! surface temperature (k) +! cldfrac ! layer cloud fraction +! taucloud ! layer cloud optical depth +! itr ! integer look-up table index +! icldlyr ! flag for cloudy layers +! iclddn ! flag for cloud in column at any layer +! semiss ! surface emissivities for each band +! reflect ! surface reflectance +! bpade ! 1/(pade constant) +! tau_tbl ! clear sky optical depth look-up table +! exp_tbl ! exponential look-up table for transmittance +! tfn_tbl ! tau transition function look-up table + +! local +! atrans ! gaseous absorptivity +! abscld ! cloud absorptivity +! atot ! combined gaseous and cloud absorptivity +! odclr ! clear sky (gaseous) optical depth +! odcld ! cloud optical depth +! odtot ! optical depth of gas and cloud +! tfacgas ! gas-only pade factor, used for planck fn +! tfactot ! gas and cloud pade factor, used for planck fn +! bbdgas ! gas-only planck function for downward rt +! bbugas ! gas-only planck function for upward rt +! bbdtot ! gas and cloud planck function for downward rt +! bbutot ! gas and cloud planck function for upward calc. +! gassrc ! source radiance due to gas only +! efclfrac ! effective cloud fraction +! radlu ! spectrally summed upward radiance +! radclru ! spectrally summed clear sky upward radiance +! urad ! upward radiance by layer +! clrurad ! clear sky upward radiance by layer +! radld ! spectrally summed downward radiance +! radclrd ! spectrally summed clear sky downward radiance +! drad ! downward radiance by layer +! clrdrad ! clear sky downward radiance by layer + + +! output +! totuflux ! upward longwave flux (w/m2) +! totdflux ! downward longwave flux (w/m2) +! fnet ! net longwave flux (w/m2) +! htr ! longwave heating rate (k/day) +! totuclfl ! clear sky upward longwave flux (w/m2) +! totdclfl ! clear sky downward longwave flux (w/m2) +! fnetc ! clear sky net longwave flux (w/m2) +! htrc ! clear sky longwave heating rate (k/day) + + +!jm not thread safe hvrrtc = '$Revision: 1.3 $' + + do ibnd = 1,nbands!mz*nbndlw + if (ibnd.eq.1 .or. ibnd.eq.4 .or. ibnd.ge.10) then + secdiff(ibnd) = 1.66_rb + else + secdiff(ibnd) = a0(ibnd) + a1(ibnd)*exp(a2(ibnd)*pwvcm) + if (secdiff(ibnd) .gt. 1.80_rb) secdiff(ibnd) = 1.80_rb + if (secdiff(ibnd) .lt. 1.50_rb) secdiff(ibnd) = 1.50_rb + endif + enddo + + urad(0) = 0.0_rb + drad(0) = 0.0_rb + totuflux(0) = 0.0_rb + totdflux(0) = 0.0_rb + clrurad(0) = 0.0_rb + clrdrad(0) = 0.0_rb + totuclfl(0) = 0.0_rb + totdclfl(0) = 0.0_rb + + do lay = 1, nlayers + urad(lay) = 0.0_rb + drad(lay) = 0.0_rb + totuflux(lay) = 0.0_rb + totdflux(lay) = 0.0_rb + clrurad(lay) = 0.0_rb + clrdrad(lay) = 0.0_rb + totuclfl(lay) = 0.0_rb + totdclfl(lay) = 0.0_rb + icldlyr(lay) = 0 + +! Change to band loop? + do ig = 1, ngptlw + if (cldfmc(ig,lay) .eq. 1._rb) then + ib = ngb(ig) + odcld(lay,ig) = secdiff(ib) * taucmc(ig,lay) + transcld = exp(-odcld(lay,ig)) + abscld(lay,ig) = 1._rb - transcld + efclfrac(lay,ig) = abscld(lay,ig) * cldfmc(ig,lay) + icldlyr(lay) = 1 + else + odcld(lay,ig) = 0.0_rb + abscld(lay,ig) = 0.0_rb + efclfrac(lay,ig) = 0.0_rb + endif + enddo + + enddo + + igc = 1 +! Loop over frequency bands. + do iband = istart, iend + +! Reinitialize g-point counter for each band if output for each band is requested. + if (iout.gt.0.and.iband.ge.2) igc = ngs(iband-1)+1 + +! Loop over g-channels. + 1000 continue + +! Radiative transfer starts here. + radld = 0._rb + radclrd = 0._rb + iclddn = 0 + +! Downward radiative transfer loop. + + do lev = nlayers, 1, -1 + plfrac = fracs(lev,igc) + blay = planklay(lev,iband) + dplankup = planklev(lev,iband) - blay + dplankdn = planklev(lev-1,iband) - blay + odepth = secdiff(iband) * taut(lev,igc) + if (odepth .lt. 0.0_rb) odepth = 0.0_rb +! Cloudy layer + if (icldlyr(lev).eq.1) then + iclddn = 1 + odtot = odepth + odcld(lev,igc) + if (odtot .lt. 0.06_rb) then + atrans(lev) = odepth - 0.5_rb*odepth*odepth + odepth_rec = rec_6*odepth + gassrc = plfrac*(blay+dplankdn*odepth_rec)*atrans(lev) + + atot(lev) = odtot - 0.5_rb*odtot*odtot + odtot_rec = rec_6*odtot + bbdtot = plfrac * (blay+dplankdn*odtot_rec) + bbd = plfrac*(blay+dplankdn*odepth_rec) + radld = radld - radld * (atrans(lev) + & + & efclfrac(lev,igc) * (1. - atrans(lev))) + & + & gassrc + cldfmc(igc,lev) * & + & (bbdtot * atot(lev) - gassrc) + drad(lev-1) = drad(lev-1) + radld + + bbugas(lev) = plfrac * (blay+dplankup*odepth_rec) + bbutot(lev) = plfrac * (blay+dplankup*odtot_rec) + + elseif (odepth .le. 0.06_rb) then + atrans(lev) = odepth - 0.5_rb*odepth*odepth + odepth_rec = rec_6*odepth + gassrc = plfrac*(blay+dplankdn*odepth_rec)*atrans(lev) + + odtot = odepth + odcld(lev,igc) + tblind = odtot/(bpade+odtot) + ittot = tblint*tblind + 0.5_rb + tfactot = tfn_tbl(ittot) + bbdtot = plfrac * (blay + tfactot*dplankdn) + bbd = plfrac*(blay+dplankdn*odepth_rec) + atot(lev) = 1. - exp_tbl(ittot) + + radld = radld - radld * (atrans(lev) + & + & efclfrac(lev,igc) * (1._rb - atrans(lev))) + & + & gassrc + cldfmc(igc,lev) * & + & (bbdtot * atot(lev) - gassrc) + drad(lev-1) = drad(lev-1) + radld + + bbugas(lev) = plfrac * (blay + dplankup*odepth_rec) + bbutot(lev) = plfrac * (blay + tfactot * dplankup) + + else + + tblind = odepth/(bpade+odepth) + itgas = tblint*tblind+0.5_rb + odepth = tau_tbl(itgas) + atrans(lev) = 1._rb - exp_tbl(itgas) + tfacgas = tfn_tbl(itgas) + gassrc = atrans(lev) * plfrac * (blay + tfacgas*dplankdn) + + odtot = odepth + odcld(lev,igc) + tblind = odtot/(bpade+odtot) + ittot = tblint*tblind + 0.5_rb + tfactot = tfn_tbl(ittot) + bbdtot = plfrac * (blay + tfactot*dplankdn) + bbd = plfrac*(blay+tfacgas*dplankdn) + atot(lev) = 1._rb - exp_tbl(ittot) + + radld = radld - radld * (atrans(lev) + & + & efclfrac(lev,igc) * (1._rb - atrans(lev))) + & + & gassrc + cldfmc(igc,lev) * & + & (bbdtot * atot(lev) - gassrc) + drad(lev-1) = drad(lev-1) + radld + bbugas(lev) = plfrac * (blay + tfacgas * dplankup) + bbutot(lev) = plfrac * (blay + tfactot * dplankup) + endif +! Clear layer + else + if (odepth .le. 0.06_rb) then + atrans(lev) = odepth-0.5_rb*odepth*odepth + odepth = rec_6*odepth + bbd = plfrac*(blay+dplankdn*odepth) + bbugas(lev) = plfrac*(blay+dplankup*odepth) + else + tblind = odepth/(bpade+odepth) + itr = tblint*tblind+0.5_rb + transc = exp_tbl(itr) + atrans(lev) = 1._rb-transc + tausfac = tfn_tbl(itr) + bbd = plfrac*(blay+tausfac*dplankdn) + bbugas(lev) = plfrac * (blay + tausfac * dplankup) + endif + radld = radld + (bbd-radld)*atrans(lev) + drad(lev-1) = drad(lev-1) + radld + endif +! Set clear sky stream to total sky stream as long as layers +! remain clear. Streams diverge when a cloud is reached (iclddn=1), +! and clear sky stream must be computed separately from that point. + if (iclddn.eq.1) then + radclrd = radclrd + (bbd-radclrd) * atrans(lev) + clrdrad(lev-1) = clrdrad(lev-1) + radclrd + else + radclrd = radld + clrdrad(lev-1) = drad(lev-1) + endif + enddo + +! Spectral emissivity & reflectance +! Include the contribution of spectrally varying longwave emissivity +! and reflection from the surface to the upward radiative transfer. +! Note: Spectral and Lambertian reflection are identical for the +! diffusivity angle flux integration used here. + +!mz* +! rad0 = fracs(1,igc) * plankbnd(iband) + rad0 = semiss(iband) * fracs(1,igc) * planklay(0,iband) +!mz +! Add in specular reflection of surface downward radiance. + reflect = 1._rb - semiss(iband) + radlu = rad0 + reflect * radld + radclru = rad0 + reflect * radclrd + + +! Upward radiative transfer loop. + urad(0) = urad(0) + radlu + clrurad(0) = clrurad(0) + radclru + + do lev = 1, nlayers +! Cloudy layer + if (icldlyr(lev) .eq. 1) then + gassrc = bbugas(lev) * atrans(lev) + radlu = radlu - radlu * (atrans(lev) + & + & efclfrac(lev,igc) * (1._rb - atrans(lev))) + & + & gassrc + cldfmc(igc,lev) * & + & (bbutot(lev) * atot(lev) - gassrc) + urad(lev) = urad(lev) + radlu +! Clear layer + else + radlu = radlu + (bbugas(lev)-radlu)*atrans(lev) + urad(lev) = urad(lev) + radlu + endif +! Set clear sky stream to total sky stream as long as all layers +! are clear (iclddn=0). Streams must be calculated separately at +! all layers when a cloud is present (ICLDDN=1), because surface +! reflectance is different for each stream. + if (iclddn.eq.1) then + radclru = radclru + (bbugas(lev)-radclru)*atrans(lev) + clrurad(lev) = clrurad(lev) + radclru + else + radclru = radlu + clrurad(lev) = urad(lev) + endif + enddo + +! Increment g-point counter + igc = igc + 1 +! Return to continue radiative transfer for all g-channels in present band + if (igc .le. ngs(iband)) go to 1000 + +! Process longwave output from band for total and clear streams. +! Calculate upward, downward, and net flux. + do lev = nlayers, 0, -1 + uflux(lev) = urad(lev)*wtdiff + dflux(lev) = drad(lev)*wtdiff + urad(lev) = 0.0_rb + drad(lev) = 0.0_rb + totuflux(lev) = totuflux(lev) + uflux(lev) * delwave(iband) + totdflux(lev) = totdflux(lev) + dflux(lev) * delwave(iband) + uclfl(lev) = clrurad(lev)*wtdiff + dclfl(lev) = clrdrad(lev)*wtdiff + clrurad(lev) = 0.0_rb + clrdrad(lev) = 0.0_rb + totuclfl(lev) = totuclfl(lev) + uclfl(lev) * delwave(iband) + totdclfl(lev) = totdclfl(lev) + dclfl(lev) * delwave(iband) + enddo + +! End spectral band loop + enddo + +! Calculate fluxes at surface + totuflux(0) = totuflux(0) * fluxfac + totdflux(0) = totdflux(0) * fluxfac + fnet(0) = totuflux(0) - totdflux(0) + totuclfl(0) = totuclfl(0) * fluxfac + totdclfl(0) = totdclfl(0) * fluxfac + fnetc(0) = totuclfl(0) - totdclfl(0) + +! Calculate fluxes at model levels + do lev = 1, nlayers + totuflux(lev) = totuflux(lev) * fluxfac + totdflux(lev) = totdflux(lev) * fluxfac + fnet(lev) = totuflux(lev) - totdflux(lev) + totuclfl(lev) = totuclfl(lev) * fluxfac + totdclfl(lev) = totdclfl(lev) * fluxfac + fnetc(lev) = totuclfl(lev) - totdclfl(lev) + l = lev - 1 + +! Calculate heating rates at model layers + htr(l)=heatfac*(fnet(l)-fnet(lev))/(pz(l)-pz(lev)) + htrc(l)=heatfac*(fnetc(l)-fnetc(lev))/(pz(l)-pz(lev)) + enddo + +! Set heating rate to zero in top layer + htr(nlayers) = 0.0_rb + htrc(nlayers) = 0.0_rb + + end subroutine rtrnmc_mcica + +! ------------------------------------------------------------------------------ + subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & + & ciwpmc, clwpmc, cswpmc, reicmc, relqmc, resnmc, ncbands, taucmc) +! ------------------------------------------------------------------------------ + +! Purpose: Compute the cloud optical depth(s) for each cloudy layer. + +! ------- Input ------- + + integer(kind=im), intent(in) :: nlayers ! total number of layers + integer(kind=im), intent(in) :: inflag ! see definitions + integer(kind=im), intent(in) :: iceflag ! see definitions + integer(kind=im), intent(in) :: liqflag ! see definitions + + real(kind=rb), intent(in) :: cldfmc(:,:) ! cloud fraction [mcica] + ! Dimensions: (ngptlw,nlayers) + real(kind=rb), intent(in) :: ciwpmc(:,:) ! cloud ice water path [mcica] + ! Dimensions: (ngptlw,nlayers) + real(kind=rb), intent(in) :: clwpmc(:,:) ! cloud liquid water path [mcica] + ! Dimensions: (ngptlw,nlayers) + real(kind=rb), intent(in) :: cswpmc(:,:) ! cloud snow path [mcica] + ! Dimensions: (ngptlw,nlayers) + real(kind=rb), intent(in) :: relqmc(:) ! liquid particle effective radius (microns) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: reicmc(:) ! ice particle effective radius (microns) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: resnmc(:) ! snow particle effective radius (microns) + ! Dimensions: (nlayers) + ! specific definition of reicmc depends on setting of iceflag: + ! iceflag = 0: ice effective radius, r_ec, (Ebert and Curry, 1992), + ! r_ec must be >= 10.0 microns + ! iceflag = 1: ice effective radius, r_ec, (Ebert and Curry, 1992), + ! r_ec range is limited to 13.0 to 130.0 microns + ! iceflag = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996) + ! r_k range is limited to 5.0 to 131.0 microns + ! iceflag = 3: generalized effective size, dge, (Fu, 1996), + ! dge range is limited to 5.0 to 140.0 microns + ! [dge = 1.0315 * r_ec] + +! ------- Output ------- + + integer(kind=im), intent(out) :: ncbands ! number of cloud spectral bands + real(kind=rb), intent(inout) :: taucmc(:,:) ! cloud optical depth [mcica] + ! Dimensions: (ngptlw,nlayers) + +! ------- Local ------- + + integer(kind=im) :: lay ! Layer index + integer(kind=im) :: ib ! spectral band index + integer(kind=im) :: ig ! g-point interval index + integer(kind=im) :: index + integer(kind=im) :: icb(nbands) + real(kind=rb) , dimension(2) :: absice0 + real(kind=rb) , dimension(2,5) :: absice1 + real(kind=rb) , dimension(43,16) :: absice2 + real(kind=rb) , dimension(46,16) :: absice3 + real(kind=rb) :: absliq0 + real(kind=rb) , dimension(58,16) :: absliq1 + + real(kind=rb) :: abscoice(ngptlw) ! ice absorption coefficients + real(kind=rb) :: abscoliq(ngptlw) ! liquid absorption coefficients + real(kind=rb) :: abscosno(ngptlw) ! snow absorption coefficients + real(kind=rb) :: cwp ! cloud water path + real(kind=rb) :: radice ! cloud ice effective size (microns) + real(kind=rb) :: factor ! + real(kind=rb) :: fint ! + real(kind=rb) :: radliq ! cloud liquid droplet radius (microns) + real(kind=rb) :: radsno ! cloud snow effective size (microns) + real(kind=rb), parameter :: eps = 1.e-6_rb ! epsilon + real(kind=rb), parameter :: cldmin = 1.e-20_rb ! minimum value for cloud quantities + character*80 errmess + +! ------- Definitions ------- + +! Explanation of the method for each value of INFLAG. Values of +! 0 or 1 for INFLAG do not distingish being liquid and ice clouds. +! INFLAG = 2 does distinguish between liquid and ice clouds, and +! requires further user input to specify the method to be used to +! compute the aborption due to each. +! INFLAG = 0: For each cloudy layer, the cloud fraction and (gray) +! optical depth are input. +! INFLAG = 1: For each cloudy layer, the cloud fraction and cloud +! water path (g/m2) are input. The (gray) cloud optical +! depth is computed as in CCM2. +! INFLAG = 2: For each cloudy layer, the cloud fraction, cloud +! water path (g/m2), and cloud ice fraction are input. +! ICEFLAG = 0: The ice effective radius (microns) is input and the +! optical depths due to ice clouds are computed as in CCM3. +! ICEFLAG = 1: The ice effective radius (microns) is input and the +! optical depths due to ice clouds are computed as in +! Ebert and Curry, JGR, 97, 3831-3836 (1992). The +! spectral regions in this work have been matched with +! the spectral bands in RRTM to as great an extent +! as possible: +! E&C 1 IB = 5 RRTM bands 9-16 +! E&C 2 IB = 4 RRTM bands 6-8 +! E&C 3 IB = 3 RRTM bands 3-5 +! E&C 4 IB = 2 RRTM band 2 +! E&C 5 IB = 1 RRTM band 1 +! ICEFLAG = 2: The ice effective radius (microns) is input and the +! optical properties due to ice clouds are computed from +! the optical properties stored in the RT code, +! STREAMER v3.0 (Reference: Key. J., Streamer +! User's Guide, Cooperative Institute for +! Meteorological Satellite Studies, 2001, 96 pp.). +! Valid range of values for re are between 5.0 and +! 131.0 micron. +! ICEFLAG = 3: The ice generalized effective size (dge) is input +! and the optical properties, are calculated as in +! Q. Fu, J. Climate, (1998). Q. Fu provided high resolution +! tables which were appropriately averaged for the +! bands in RRTM_LW. Linear interpolation is used to +! get the coefficients from the stored tables. +! Valid range of values for dge are between 5.0 and +! 140.0 micron. +! LIQFLAG = 0: The optical depths due to water clouds are computed as +! in CCM3. +! LIQFLAG = 1: The water droplet effective radius (microns) is input +! and the optical depths due to water clouds are computed +! as in Hu and Stamnes, J., Clim., 6, 728-742, (1993). +! The values for absorption coefficients appropriate for +! the spectral bands in RRTM have been obtained for a +! range of effective radii by an averaging procedure +! based on the work of J. Pinto (private communication). +! Linear interpolation is used to get the absorption +! coefficients for the input effective radius. + + data icb /1,2,3,3,3,4,4,4,5, 5, 5, 5, 5, 5, 5, 5/ +! Everything below is for INFLAG = 2. + +! ABSICEn(J,IB) are the parameters needed to compute the liquid water +! absorption coefficient in spectral region IB for ICEFLAG=n. The units +! of ABSICEn(1,IB) are m2/g and ABSICEn(2,IB) has units (microns (m2/g)). +! For ICEFLAG = 0. + + absice0(:)= (/0.005_rb, 1.0_rb/) + +! For ICEFLAG = 1. + absice1(1,:) = (/0.0036_rb, 0.0068_rb, 0.0003_rb, 0.0016_rb, & + & 0.0020_rb/) + absice1(2,:) = (/1.136_rb , 0.600_rb , 1.338_rb , 1.166_rb , & + & 1.118_rb /) + +! For ICEFLAG = 2. In each band, the absorption +! coefficients are listed for a range of effective radii from 5.0 +! to 131.0 microns in increments of 3.0 microns. +! Spherical Ice Particle Parameterization +! absorption units (abs coef/iwc): [(m^-1)/(g m^-3)] + absice2(:,1) = (/ & +! band 1 + 7.798999e-02_rb,6.340479e-02_rb,5.417973e-02_rb,4.766245e-02_rb,4.272663e-02_rb, & + 3.880939e-02_rb,3.559544e-02_rb,3.289241e-02_rb,3.057511e-02_rb,2.855800e-02_rb, & + 2.678022e-02_rb,2.519712e-02_rb,2.377505e-02_rb,2.248806e-02_rb,2.131578e-02_rb, & + 2.024194e-02_rb,1.925337e-02_rb,1.833926e-02_rb,1.749067e-02_rb,1.670007e-02_rb, & + 1.596113e-02_rb,1.526845e-02_rb,1.461739e-02_rb,1.400394e-02_rb,1.342462e-02_rb, & + 1.287639e-02_rb,1.235656e-02_rb,1.186279e-02_rb,1.139297e-02_rb,1.094524e-02_rb, & + 1.051794e-02_rb,1.010956e-02_rb,9.718755e-03_rb,9.344316e-03_rb,8.985139e-03_rb, & + 8.640223e-03_rb,8.308656e-03_rb,7.989606e-03_rb,7.682312e-03_rb,7.386076e-03_rb, & + 7.100255e-03_rb,6.824258e-03_rb,6.557540e-03_rb/) + absice2(:,2) = (/ & +! band 2 + 2.784879e-02_rb,2.709863e-02_rb,2.619165e-02_rb,2.529230e-02_rb,2.443225e-02_rb, & + 2.361575e-02_rb,2.284021e-02_rb,2.210150e-02_rb,2.139548e-02_rb,2.071840e-02_rb, & + 2.006702e-02_rb,1.943856e-02_rb,1.883064e-02_rb,1.824120e-02_rb,1.766849e-02_rb, & + 1.711099e-02_rb,1.656737e-02_rb,1.603647e-02_rb,1.551727e-02_rb,1.500886e-02_rb, & + 1.451045e-02_rb,1.402132e-02_rb,1.354084e-02_rb,1.306842e-02_rb,1.260355e-02_rb, & + 1.214575e-02_rb,1.169460e-02_rb,1.124971e-02_rb,1.081072e-02_rb,1.037731e-02_rb, & + 9.949167e-03_rb,9.526021e-03_rb,9.107615e-03_rb,8.693714e-03_rb,8.284096e-03_rb, & + 7.878558e-03_rb,7.476910e-03_rb,7.078974e-03_rb,6.684586e-03_rb,6.293589e-03_rb, & + 5.905839e-03_rb,5.521200e-03_rb,5.139543e-03_rb/) + absice2(:,3) = (/ & +! band 3 + 1.065397e-01_rb,8.005726e-02_rb,6.546428e-02_rb,5.589131e-02_rb,4.898681e-02_rb, & + 4.369932e-02_rb,3.947901e-02_rb,3.600676e-02_rb,3.308299e-02_rb,3.057561e-02_rb, & + 2.839325e-02_rb,2.647040e-02_rb,2.475872e-02_rb,2.322164e-02_rb,2.183091e-02_rb, & + 2.056430e-02_rb,1.940407e-02_rb,1.833586e-02_rb,1.734787e-02_rb,1.643034e-02_rb, & + 1.557512e-02_rb,1.477530e-02_rb,1.402501e-02_rb,1.331924e-02_rb,1.265364e-02_rb, & + 1.202445e-02_rb,1.142838e-02_rb,1.086257e-02_rb,1.032445e-02_rb,9.811791e-03_rb, & + 9.322587e-03_rb,8.855053e-03_rb,8.407591e-03_rb,7.978763e-03_rb,7.567273e-03_rb, & + 7.171949e-03_rb,6.791728e-03_rb,6.425642e-03_rb,6.072809e-03_rb,5.732424e-03_rb, & + 5.403748e-03_rb,5.086103e-03_rb,4.778865e-03_rb/) + absice2(:,4) = (/ & +! band 4 + 1.804566e-01_rb,1.168987e-01_rb,8.680442e-02_rb,6.910060e-02_rb,5.738174e-02_rb, & + 4.902332e-02_rb,4.274585e-02_rb,3.784923e-02_rb,3.391734e-02_rb,3.068690e-02_rb, & + 2.798301e-02_rb,2.568480e-02_rb,2.370600e-02_rb,2.198337e-02_rb,2.046940e-02_rb, & + 1.912777e-02_rb,1.793016e-02_rb,1.685420e-02_rb,1.588193e-02_rb,1.499882e-02_rb, & + 1.419293e-02_rb,1.345440e-02_rb,1.277496e-02_rb,1.214769e-02_rb,1.156669e-02_rb, & + 1.102694e-02_rb,1.052412e-02_rb,1.005451e-02_rb,9.614854e-03_rb,9.202335e-03_rb, & + 8.814470e-03_rb,8.449077e-03_rb,8.104223e-03_rb,7.778195e-03_rb,7.469466e-03_rb, & + 7.176671e-03_rb,6.898588e-03_rb,6.634117e-03_rb,6.382264e-03_rb,6.142134e-03_rb, & + 5.912913e-03_rb,5.693862e-03_rb,5.484308e-03_rb/) + absice2(:,5) = (/ & +! band 5 + 2.131806e-01_rb,1.311372e-01_rb,9.407171e-02_rb,7.299442e-02_rb,5.941273e-02_rb, & + 4.994043e-02_rb,4.296242e-02_rb,3.761113e-02_rb,3.337910e-02_rb,2.994978e-02_rb, & + 2.711556e-02_rb,2.473461e-02_rb,2.270681e-02_rb,2.095943e-02_rb,1.943839e-02_rb, & + 1.810267e-02_rb,1.692057e-02_rb,1.586719e-02_rb,1.492275e-02_rb,1.407132e-02_rb, & + 1.329989e-02_rb,1.259780e-02_rb,1.195618e-02_rb,1.136761e-02_rb,1.082583e-02_rb, & + 1.032552e-02_rb,9.862158e-03_rb,9.431827e-03_rb,9.031157e-03_rb,8.657217e-03_rb, & + 8.307449e-03_rb,7.979609e-03_rb,7.671724e-03_rb,7.382048e-03_rb,7.109032e-03_rb, & + 6.851298e-03_rb,6.607615e-03_rb,6.376881e-03_rb,6.158105e-03_rb,5.950394e-03_rb, & + 5.752942e-03_rb,5.565019e-03_rb,5.385963e-03_rb/) + absice2(:,6) = (/ & +! band 6 + 1.546177e-01_rb,1.039251e-01_rb,7.910347e-02_rb,6.412429e-02_rb,5.399997e-02_rb, & + 4.664937e-02_rb,4.104237e-02_rb,3.660781e-02_rb,3.300218e-02_rb,3.000586e-02_rb, & + 2.747148e-02_rb,2.529633e-02_rb,2.340647e-02_rb,2.174723e-02_rb,2.027731e-02_rb, & + 1.896487e-02_rb,1.778492e-02_rb,1.671761e-02_rb,1.574692e-02_rb,1.485978e-02_rb, & + 1.404543e-02_rb,1.329489e-02_rb,1.260066e-02_rb,1.195636e-02_rb,1.135657e-02_rb, & + 1.079664e-02_rb,1.027257e-02_rb,9.780871e-03_rb,9.318505e-03_rb,8.882815e-03_rb, & + 8.471458e-03_rb,8.082364e-03_rb,7.713696e-03_rb,7.363817e-03_rb,7.031264e-03_rb, & + 6.714725e-03_rb,6.413021e-03_rb,6.125086e-03_rb,5.849958e-03_rb,5.586764e-03_rb, & + 5.334707e-03_rb,5.093066e-03_rb,4.861179e-03_rb/) + absice2(:,7) = (/ & +! band 7 + 7.583404e-02_rb,6.181558e-02_rb,5.312027e-02_rb,4.696039e-02_rb,4.225986e-02_rb, & + 3.849735e-02_rb,3.538340e-02_rb,3.274182e-02_rb,3.045798e-02_rb,2.845343e-02_rb, & + 2.667231e-02_rb,2.507353e-02_rb,2.362606e-02_rb,2.230595e-02_rb,2.109435e-02_rb, & + 1.997617e-02_rb,1.893916e-02_rb,1.797328e-02_rb,1.707016e-02_rb,1.622279e-02_rb, & + 1.542523e-02_rb,1.467241e-02_rb,1.395997e-02_rb,1.328414e-02_rb,1.264164e-02_rb, & + 1.202958e-02_rb,1.144544e-02_rb,1.088697e-02_rb,1.035218e-02_rb,9.839297e-03_rb, & + 9.346733e-03_rb,8.873057e-03_rb,8.416980e-03_rb,7.977335e-03_rb,7.553066e-03_rb, & + 7.143210e-03_rb,6.746888e-03_rb,6.363297e-03_rb,5.991700e-03_rb,5.631422e-03_rb, & + 5.281840e-03_rb,4.942378e-03_rb,4.612505e-03_rb/) + absice2(:,8) = (/ & +! band 8 + 9.022185e-02_rb,6.922700e-02_rb,5.710674e-02_rb,4.898377e-02_rb,4.305946e-02_rb, & + 3.849553e-02_rb,3.484183e-02_rb,3.183220e-02_rb,2.929794e-02_rb,2.712627e-02_rb, & + 2.523856e-02_rb,2.357810e-02_rb,2.210286e-02_rb,2.078089e-02_rb,1.958747e-02_rb, & + 1.850310e-02_rb,1.751218e-02_rb,1.660205e-02_rb,1.576232e-02_rb,1.498440e-02_rb, & + 1.426107e-02_rb,1.358624e-02_rb,1.295474e-02_rb,1.236212e-02_rb,1.180456e-02_rb, & + 1.127874e-02_rb,1.078175e-02_rb,1.031106e-02_rb,9.864433e-03_rb,9.439878e-03_rb, & + 9.035637e-03_rb,8.650140e-03_rb,8.281981e-03_rb,7.929895e-03_rb,7.592746e-03_rb, & + 7.269505e-03_rb,6.959238e-03_rb,6.661100e-03_rb,6.374317e-03_rb,6.098185e-03_rb, & + 5.832059e-03_rb,5.575347e-03_rb,5.327504e-03_rb/) + absice2(:,9) = (/ & +! band 9 + 1.294087e-01_rb,8.788217e-02_rb,6.728288e-02_rb,5.479720e-02_rb,4.635049e-02_rb, & + 4.022253e-02_rb,3.555576e-02_rb,3.187259e-02_rb,2.888498e-02_rb,2.640843e-02_rb, & + 2.431904e-02_rb,2.253038e-02_rb,2.098024e-02_rb,1.962267e-02_rb,1.842293e-02_rb, & + 1.735426e-02_rb,1.639571e-02_rb,1.553060e-02_rb,1.474552e-02_rb,1.402953e-02_rb, & + 1.337363e-02_rb,1.277033e-02_rb,1.221336e-02_rb,1.169741e-02_rb,1.121797e-02_rb, & + 1.077117e-02_rb,1.035369e-02_rb,9.962643e-03_rb,9.595509e-03_rb,9.250088e-03_rb, & + 8.924447e-03_rb,8.616876e-03_rb,8.325862e-03_rb,8.050057e-03_rb,7.788258e-03_rb, & + 7.539388e-03_rb,7.302478e-03_rb,7.076656e-03_rb,6.861134e-03_rb,6.655197e-03_rb, & + 6.458197e-03_rb,6.269543e-03_rb,6.088697e-03_rb/) + absice2(:,10) = (/ & +! band 10 + 1.593628e-01_rb,1.014552e-01_rb,7.458955e-02_rb,5.903571e-02_rb,4.887582e-02_rb, & + 4.171159e-02_rb,3.638480e-02_rb,3.226692e-02_rb,2.898717e-02_rb,2.631256e-02_rb, & + 2.408925e-02_rb,2.221156e-02_rb,2.060448e-02_rb,1.921325e-02_rb,1.799699e-02_rb, & + 1.692456e-02_rb,1.597177e-02_rb,1.511961e-02_rb,1.435289e-02_rb,1.365933e-02_rb, & + 1.302890e-02_rb,1.245334e-02_rb,1.192576e-02_rb,1.144037e-02_rb,1.099230e-02_rb, & + 1.057739e-02_rb,1.019208e-02_rb,9.833302e-03_rb,9.498395e-03_rb,9.185047e-03_rb, & + 8.891237e-03_rb,8.615185e-03_rb,8.355325e-03_rb,8.110267e-03_rb,7.878778e-03_rb, & + 7.659759e-03_rb,7.452224e-03_rb,7.255291e-03_rb,7.068166e-03_rb,6.890130e-03_rb, & + 6.720536e-03_rb,6.558794e-03_rb,6.404371e-03_rb/) + absice2(:,11) = (/ & +! band 11 + 1.656227e-01_rb,1.032129e-01_rb,7.487359e-02_rb,5.871431e-02_rb,4.828355e-02_rb, & + 4.099989e-02_rb,3.562924e-02_rb,3.150755e-02_rb,2.824593e-02_rb,2.560156e-02_rb, & + 2.341503e-02_rb,2.157740e-02_rb,2.001169e-02_rb,1.866199e-02_rb,1.748669e-02_rb, & + 1.645421e-02_rb,1.554015e-02_rb,1.472535e-02_rb,1.399457e-02_rb,1.333553e-02_rb, & + 1.273821e-02_rb,1.219440e-02_rb,1.169725e-02_rb,1.124104e-02_rb,1.082096e-02_rb, & + 1.043290e-02_rb,1.007336e-02_rb,9.739338e-03_rb,9.428223e-03_rb,9.137756e-03_rb, & + 8.865964e-03_rb,8.611115e-03_rb,8.371686e-03_rb,8.146330e-03_rb,7.933852e-03_rb, & + 7.733187e-03_rb,7.543386e-03_rb,7.363597e-03_rb,7.193056e-03_rb,7.031072e-03_rb, & + 6.877024e-03_rb,6.730348e-03_rb,6.590531e-03_rb/) + absice2(:,12) = (/ & +! band 12 + 9.194591e-02_rb,6.446867e-02_rb,4.962034e-02_rb,4.042061e-02_rb,3.418456e-02_rb, & + 2.968856e-02_rb,2.629900e-02_rb,2.365572e-02_rb,2.153915e-02_rb,1.980791e-02_rb, & + 1.836689e-02_rb,1.714979e-02_rb,1.610900e-02_rb,1.520946e-02_rb,1.442476e-02_rb, & + 1.373468e-02_rb,1.312345e-02_rb,1.257858e-02_rb,1.209010e-02_rb,1.164990e-02_rb, & + 1.125136e-02_rb,1.088901e-02_rb,1.055827e-02_rb,1.025531e-02_rb,9.976896e-03_rb, & + 9.720255e-03_rb,9.483022e-03_rb,9.263160e-03_rb,9.058902e-03_rb,8.868710e-03_rb, & + 8.691240e-03_rb,8.525312e-03_rb,8.369886e-03_rb,8.224042e-03_rb,8.086961e-03_rb, & + 7.957917e-03_rb,7.836258e-03_rb,7.721400e-03_rb,7.612821e-03_rb,7.510045e-03_rb, & + 7.412648e-03_rb,7.320242e-03_rb,7.232476e-03_rb/) + absice2(:,13) = (/ & +! band 13 + 1.437021e-01_rb,8.872535e-02_rb,6.392420e-02_rb,4.991833e-02_rb,4.096790e-02_rb, & + 3.477881e-02_rb,3.025782e-02_rb,2.681909e-02_rb,2.412102e-02_rb,2.195132e-02_rb, & + 2.017124e-02_rb,1.868641e-02_rb,1.743044e-02_rb,1.635529e-02_rb,1.542540e-02_rb, & + 1.461388e-02_rb,1.390003e-02_rb,1.326766e-02_rb,1.270395e-02_rb,1.219860e-02_rb, & + 1.174326e-02_rb,1.133107e-02_rb,1.095637e-02_rb,1.061442e-02_rb,1.030126e-02_rb, & + 1.001352e-02_rb,9.748340e-03_rb,9.503256e-03_rb,9.276155e-03_rb,9.065205e-03_rb, & + 8.868808e-03_rb,8.685571e-03_rb,8.514268e-03_rb,8.353820e-03_rb,8.203272e-03_rb, & + 8.061776e-03_rb,7.928578e-03_rb,7.803001e-03_rb,7.684443e-03_rb,7.572358e-03_rb, & + 7.466258e-03_rb,7.365701e-03_rb,7.270286e-03_rb/) + absice2(:,14) = (/ & +! band 14 + 1.288870e-01_rb,8.160295e-02_rb,5.964745e-02_rb,4.703790e-02_rb,3.888637e-02_rb, & + 3.320115e-02_rb,2.902017e-02_rb,2.582259e-02_rb,2.330224e-02_rb,2.126754e-02_rb, & + 1.959258e-02_rb,1.819130e-02_rb,1.700289e-02_rb,1.598320e-02_rb,1.509942e-02_rb, & + 1.432666e-02_rb,1.364572e-02_rb,1.304156e-02_rb,1.250220e-02_rb,1.201803e-02_rb, & + 1.158123e-02_rb,1.118537e-02_rb,1.082513e-02_rb,1.049605e-02_rb,1.019440e-02_rb, & + 9.916989e-03_rb,9.661116e-03_rb,9.424457e-03_rb,9.205005e-03_rb,9.001022e-03_rb, & + 8.810992e-03_rb,8.633588e-03_rb,8.467646e-03_rb,8.312137e-03_rb,8.166151e-03_rb, & + 8.028878e-03_rb,7.899597e-03_rb,7.777663e-03_rb,7.662498e-03_rb,7.553581e-03_rb, & + 7.450444e-03_rb,7.352662e-03_rb,7.259851e-03_rb/) + absice2(:,15) = (/ & +! band 15 + 8.254229e-02_rb,5.808787e-02_rb,4.492166e-02_rb,3.675028e-02_rb,3.119623e-02_rb, & + 2.718045e-02_rb,2.414450e-02_rb,2.177073e-02_rb,1.986526e-02_rb,1.830306e-02_rb, & + 1.699991e-02_rb,1.589698e-02_rb,1.495199e-02_rb,1.413374e-02_rb,1.341870e-02_rb, & + 1.278883e-02_rb,1.223002e-02_rb,1.173114e-02_rb,1.128322e-02_rb,1.087900e-02_rb, & + 1.051254e-02_rb,1.017890e-02_rb,9.873991e-03_rb,9.594347e-03_rb,9.337044e-03_rb, & + 9.099589e-03_rb,8.879842e-03_rb,8.675960e-03_rb,8.486341e-03_rb,8.309594e-03_rb, & + 8.144500e-03_rb,7.989986e-03_rb,7.845109e-03_rb,7.709031e-03_rb,7.581007e-03_rb, & + 7.460376e-03_rb,7.346544e-03_rb,7.238978e-03_rb,7.137201e-03_rb,7.040780e-03_rb, & + 6.949325e-03_rb,6.862483e-03_rb,6.779931e-03_rb/) + absice2(:,16) = (/ & +! band 16 + 1.382062e-01_rb,8.643227e-02_rb,6.282935e-02_rb,4.934783e-02_rb,4.063891e-02_rb, & + 3.455591e-02_rb,3.007059e-02_rb,2.662897e-02_rb,2.390631e-02_rb,2.169972e-02_rb, & + 1.987596e-02_rb,1.834393e-02_rb,1.703924e-02_rb,1.591513e-02_rb,1.493679e-02_rb, & + 1.407780e-02_rb,1.331775e-02_rb,1.264061e-02_rb,1.203364e-02_rb,1.148655e-02_rb, & + 1.099099e-02_rb,1.054006e-02_rb,1.012807e-02_rb,9.750215e-03_rb,9.402477e-03_rb, & + 9.081428e-03_rb,8.784143e-03_rb,8.508107e-03_rb,8.251146e-03_rb,8.011373e-03_rb, & + 7.787140e-03_rb,7.577002e-03_rb,7.379687e-03_rb,7.194071e-03_rb,7.019158e-03_rb, & + 6.854061e-03_rb,6.697986e-03_rb,6.550224e-03_rb,6.410138e-03_rb,6.277153e-03_rb, & + 6.150751e-03_rb,6.030462e-03_rb,5.915860e-03_rb/) + +! ICEFLAG = 3; Fu parameterization. Particle size 5 - 140 micron in +! increments of 3 microns. +! units = m2/g +! Hexagonal Ice Particle Parameterization +! absorption units (abs coef/iwc): [(m^-1)/(g m^-3)] + absice3(:,1) = (/ & +! band 1 + 3.110649e-03_rb,4.666352e-02_rb,6.606447e-02_rb,6.531678e-02_rb,6.012598e-02_rb, & + 5.437494e-02_rb,4.906411e-02_rb,4.441146e-02_rb,4.040585e-02_rb,3.697334e-02_rb, & + 3.403027e-02_rb,3.149979e-02_rb,2.931596e-02_rb,2.742365e-02_rb,2.577721e-02_rb, & + 2.433888e-02_rb,2.307732e-02_rb,2.196644e-02_rb,2.098437e-02_rb,2.011264e-02_rb, & + 1.933561e-02_rb,1.863992e-02_rb,1.801407e-02_rb,1.744812e-02_rb,1.693346e-02_rb, & + 1.646252e-02_rb,1.602866e-02_rb,1.562600e-02_rb,1.524933e-02_rb,1.489399e-02_rb, & + 1.455580e-02_rb,1.423098e-02_rb,1.391612e-02_rb,1.360812e-02_rb,1.330413e-02_rb, & + 1.300156e-02_rb,1.269801e-02_rb,1.239127e-02_rb,1.207928e-02_rb,1.176014e-02_rb, & + 1.143204e-02_rb,1.109334e-02_rb,1.074243e-02_rb,1.037786e-02_rb,9.998198e-03_rb, & + 9.602126e-03_rb/) + absice3(:,2) = (/ & +! band 2 + 3.984966e-04_rb,1.681097e-02_rb,2.627680e-02_rb,2.767465e-02_rb,2.700722e-02_rb, & + 2.579180e-02_rb,2.448677e-02_rb,2.323890e-02_rb,2.209096e-02_rb,2.104882e-02_rb, & + 2.010547e-02_rb,1.925003e-02_rb,1.847128e-02_rb,1.775883e-02_rb,1.710358e-02_rb, & + 1.649769e-02_rb,1.593449e-02_rb,1.540829e-02_rb,1.491429e-02_rb,1.444837e-02_rb, & + 1.400704e-02_rb,1.358729e-02_rb,1.318654e-02_rb,1.280258e-02_rb,1.243346e-02_rb, & + 1.207750e-02_rb,1.173325e-02_rb,1.139941e-02_rb,1.107487e-02_rb,1.075861e-02_rb, & + 1.044975e-02_rb,1.014753e-02_rb,9.851229e-03_rb,9.560240e-03_rb,9.274003e-03_rb, & + 8.992020e-03_rb,8.713845e-03_rb,8.439074e-03_rb,8.167346e-03_rb,7.898331e-03_rb, & + 7.631734e-03_rb,7.367286e-03_rb,7.104742e-03_rb,6.843882e-03_rb,6.584504e-03_rb, & + 6.326424e-03_rb/) + absice3(:,3) = (/ & +! band 3 + 6.933163e-02_rb,8.540475e-02_rb,7.701816e-02_rb,6.771158e-02_rb,5.986953e-02_rb, & + 5.348120e-02_rb,4.824962e-02_rb,4.390563e-02_rb,4.024411e-02_rb,3.711404e-02_rb, & + 3.440426e-02_rb,3.203200e-02_rb,2.993478e-02_rb,2.806474e-02_rb,2.638464e-02_rb, & + 2.486516e-02_rb,2.348288e-02_rb,2.221890e-02_rb,2.105780e-02_rb,1.998687e-02_rb, & + 1.899552e-02_rb,1.807490e-02_rb,1.721750e-02_rb,1.641693e-02_rb,1.566773e-02_rb, & + 1.496515e-02_rb,1.430509e-02_rb,1.368398e-02_rb,1.309865e-02_rb,1.254634e-02_rb, & + 1.202456e-02_rb,1.153114e-02_rb,1.106409e-02_rb,1.062166e-02_rb,1.020224e-02_rb, & + 9.804381e-03_rb,9.426771e-03_rb,9.068205e-03_rb,8.727578e-03_rb,8.403876e-03_rb, & + 8.096160e-03_rb,7.803564e-03_rb,7.525281e-03_rb,7.260560e-03_rb,7.008697e-03_rb, & + 6.769036e-03_rb/) + absice3(:,4) = (/ & +! band 4 + 1.765735e-01_rb,1.382700e-01_rb,1.095129e-01_rb,8.987475e-02_rb,7.591185e-02_rb, & + 6.554169e-02_rb,5.755500e-02_rb,5.122083e-02_rb,4.607610e-02_rb,4.181475e-02_rb, & + 3.822697e-02_rb,3.516432e-02_rb,3.251897e-02_rb,3.021073e-02_rb,2.817876e-02_rb, & + 2.637607e-02_rb,2.476582e-02_rb,2.331871e-02_rb,2.201113e-02_rb,2.082388e-02_rb, & + 1.974115e-02_rb,1.874983e-02_rb,1.783894e-02_rb,1.699922e-02_rb,1.622280e-02_rb, & + 1.550296e-02_rb,1.483390e-02_rb,1.421064e-02_rb,1.362880e-02_rb,1.308460e-02_rb, & + 1.257468e-02_rb,1.209611e-02_rb,1.164628e-02_rb,1.122287e-02_rb,1.082381e-02_rb, & + 1.044725e-02_rb,1.009154e-02_rb,9.755166e-03_rb,9.436783e-03_rb,9.135163e-03_rb, & + 8.849193e-03_rb,8.577856e-03_rb,8.320225e-03_rb,8.075451e-03_rb,7.842755e-03_rb, & + 7.621418e-03_rb/) + absice3(:,5) = (/ & +! band 5 + 2.339673e-01_rb,1.692124e-01_rb,1.291656e-01_rb,1.033837e-01_rb,8.562949e-02_rb, & + 7.273526e-02_rb,6.298262e-02_rb,5.537015e-02_rb,4.927787e-02_rb,4.430246e-02_rb, & + 4.017061e-02_rb,3.669072e-02_rb,3.372455e-02_rb,3.116995e-02_rb,2.894977e-02_rb, & + 2.700471e-02_rb,2.528842e-02_rb,2.376420e-02_rb,2.240256e-02_rb,2.117959e-02_rb, & + 2.007567e-02_rb,1.907456e-02_rb,1.816271e-02_rb,1.732874e-02_rb,1.656300e-02_rb, & + 1.585725e-02_rb,1.520445e-02_rb,1.459852e-02_rb,1.403419e-02_rb,1.350689e-02_rb, & + 1.301260e-02_rb,1.254781e-02_rb,1.210941e-02_rb,1.169468e-02_rb,1.130118e-02_rb, & + 1.092675e-02_rb,1.056945e-02_rb,1.022757e-02_rb,9.899560e-03_rb,9.584021e-03_rb, & + 9.279705e-03_rb,8.985479e-03_rb,8.700322e-03_rb,8.423306e-03_rb,8.153590e-03_rb, & + 7.890412e-03_rb/) + absice3(:,6) = (/ & +! band 6 + 1.145369e-01_rb,1.174566e-01_rb,9.917866e-02_rb,8.332990e-02_rb,7.104263e-02_rb, & + 6.153370e-02_rb,5.405472e-02_rb,4.806281e-02_rb,4.317918e-02_rb,3.913795e-02_rb, & + 3.574916e-02_rb,3.287437e-02_rb,3.041067e-02_rb,2.828017e-02_rb,2.642292e-02_rb, & + 2.479206e-02_rb,2.335051e-02_rb,2.206851e-02_rb,2.092195e-02_rb,1.989108e-02_rb, & + 1.895958e-02_rb,1.811385e-02_rb,1.734245e-02_rb,1.663573e-02_rb,1.598545e-02_rb, & + 1.538456e-02_rb,1.482700e-02_rb,1.430750e-02_rb,1.382150e-02_rb,1.336499e-02_rb, & + 1.293447e-02_rb,1.252685e-02_rb,1.213939e-02_rb,1.176968e-02_rb,1.141555e-02_rb, & + 1.107508e-02_rb,1.074655e-02_rb,1.042839e-02_rb,1.011923e-02_rb,9.817799e-03_rb, & + 9.522962e-03_rb,9.233688e-03_rb,8.949041e-03_rb,8.668171e-03_rb,8.390301e-03_rb, & + 8.114723e-03_rb/) + absice3(:,7) = (/ & +! band 7 + 1.222345e-02_rb,5.344230e-02_rb,5.523465e-02_rb,5.128759e-02_rb,4.676925e-02_rb, & + 4.266150e-02_rb,3.910561e-02_rb,3.605479e-02_rb,3.342843e-02_rb,3.115052e-02_rb, & + 2.915776e-02_rb,2.739935e-02_rb,2.583499e-02_rb,2.443266e-02_rb,2.316681e-02_rb, & + 2.201687e-02_rb,2.096619e-02_rb,2.000112e-02_rb,1.911044e-02_rb,1.828481e-02_rb, & + 1.751641e-02_rb,1.679866e-02_rb,1.612598e-02_rb,1.549360e-02_rb,1.489742e-02_rb, & + 1.433392e-02_rb,1.380002e-02_rb,1.329305e-02_rb,1.281068e-02_rb,1.235084e-02_rb, & + 1.191172e-02_rb,1.149171e-02_rb,1.108936e-02_rb,1.070341e-02_rb,1.033271e-02_rb, & + 9.976220e-03_rb,9.633021e-03_rb,9.302273e-03_rb,8.983216e-03_rb,8.675161e-03_rb, & + 8.377478e-03_rb,8.089595e-03_rb,7.810986e-03_rb,7.541170e-03_rb,7.279706e-03_rb, & + 7.026186e-03_rb/) + absice3(:,8) = (/ & +! band 8 + 6.711058e-02_rb,6.918198e-02_rb,6.127484e-02_rb,5.411944e-02_rb,4.836902e-02_rb, & + 4.375293e-02_rb,3.998077e-02_rb,3.683587e-02_rb,3.416508e-02_rb,3.186003e-02_rb, & + 2.984290e-02_rb,2.805671e-02_rb,2.645895e-02_rb,2.501733e-02_rb,2.370689e-02_rb, & + 2.250808e-02_rb,2.140532e-02_rb,2.038609e-02_rb,1.944018e-02_rb,1.855918e-02_rb, & + 1.773609e-02_rb,1.696504e-02_rb,1.624106e-02_rb,1.555990e-02_rb,1.491793e-02_rb, & + 1.431197e-02_rb,1.373928e-02_rb,1.319743e-02_rb,1.268430e-02_rb,1.219799e-02_rb, & + 1.173682e-02_rb,1.129925e-02_rb,1.088393e-02_rb,1.048961e-02_rb,1.011516e-02_rb, & + 9.759543e-03_rb,9.421813e-03_rb,9.101089e-03_rb,8.796559e-03_rb,8.507464e-03_rb, & + 8.233098e-03_rb,7.972798e-03_rb,7.725942e-03_rb,7.491940e-03_rb,7.270238e-03_rb, & + 7.060305e-03_rb/) + absice3(:,9) = (/ & +! band 9 + 1.236780e-01_rb,9.222386e-02_rb,7.383997e-02_rb,6.204072e-02_rb,5.381029e-02_rb, & + 4.770678e-02_rb,4.296928e-02_rb,3.916131e-02_rb,3.601540e-02_rb,3.335878e-02_rb, & + 3.107493e-02_rb,2.908247e-02_rb,2.732282e-02_rb,2.575276e-02_rb,2.433968e-02_rb, & + 2.305852e-02_rb,2.188966e-02_rb,2.081757e-02_rb,1.982974e-02_rb,1.891599e-02_rb, & + 1.806794e-02_rb,1.727865e-02_rb,1.654227e-02_rb,1.585387e-02_rb,1.520924e-02_rb, & + 1.460476e-02_rb,1.403730e-02_rb,1.350416e-02_rb,1.300293e-02_rb,1.253153e-02_rb, & + 1.208808e-02_rb,1.167094e-02_rb,1.127862e-02_rb,1.090979e-02_rb,1.056323e-02_rb, & + 1.023786e-02_rb,9.932665e-03_rb,9.646744e-03_rb,9.379250e-03_rb,9.129409e-03_rb, & + 8.896500e-03_rb,8.679856e-03_rb,8.478852e-03_rb,8.292904e-03_rb,8.121463e-03_rb, & + 7.964013e-03_rb/) + absice3(:,10) = (/ & +! band 10 + 1.655966e-01_rb,1.134205e-01_rb,8.714344e-02_rb,7.129241e-02_rb,6.063739e-02_rb, & + 5.294203e-02_rb,4.709309e-02_rb,4.247476e-02_rb,3.871892e-02_rb,3.559206e-02_rb, & + 3.293893e-02_rb,3.065226e-02_rb,2.865558e-02_rb,2.689288e-02_rb,2.532221e-02_rb, & + 2.391150e-02_rb,2.263582e-02_rb,2.147549e-02_rb,2.041476e-02_rb,1.944089e-02_rb, & + 1.854342e-02_rb,1.771371e-02_rb,1.694456e-02_rb,1.622989e-02_rb,1.556456e-02_rb, & + 1.494415e-02_rb,1.436491e-02_rb,1.382354e-02_rb,1.331719e-02_rb,1.284339e-02_rb, & + 1.239992e-02_rb,1.198486e-02_rb,1.159647e-02_rb,1.123323e-02_rb,1.089375e-02_rb, & + 1.057679e-02_rb,1.028124e-02_rb,1.000607e-02_rb,9.750376e-03_rb,9.513303e-03_rb, & + 9.294082e-03_rb,9.092003e-03_rb,8.906412e-03_rb,8.736702e-03_rb,8.582314e-03_rb, & + 8.442725e-03_rb/) + absice3(:,11) = (/ & +! band 11 + 1.775615e-01_rb,1.180046e-01_rb,8.929607e-02_rb,7.233500e-02_rb,6.108333e-02_rb, & + 5.303642e-02_rb,4.696927e-02_rb,4.221206e-02_rb,3.836768e-02_rb,3.518576e-02_rb, & + 3.250063e-02_rb,3.019825e-02_rb,2.819758e-02_rb,2.643943e-02_rb,2.487953e-02_rb, & + 2.348414e-02_rb,2.222705e-02_rb,2.108762e-02_rb,2.004936e-02_rb,1.909892e-02_rb, & + 1.822539e-02_rb,1.741975e-02_rb,1.667449e-02_rb,1.598330e-02_rb,1.534084e-02_rb, & + 1.474253e-02_rb,1.418446e-02_rb,1.366325e-02_rb,1.317597e-02_rb,1.272004e-02_rb, & + 1.229321e-02_rb,1.189350e-02_rb,1.151915e-02_rb,1.116859e-02_rb,1.084042e-02_rb, & + 1.053338e-02_rb,1.024636e-02_rb,9.978326e-03_rb,9.728357e-03_rb,9.495613e-03_rb, & + 9.279327e-03_rb,9.078798e-03_rb,8.893383e-03_rb,8.722488e-03_rb,8.565568e-03_rb, & + 8.422115e-03_rb/) + absice3(:,12) = (/ & +! band 12 + 9.465447e-02_rb,6.432047e-02_rb,5.060973e-02_rb,4.267283e-02_rb,3.741843e-02_rb, & + 3.363096e-02_rb,3.073531e-02_rb,2.842405e-02_rb,2.651789e-02_rb,2.490518e-02_rb, & + 2.351273e-02_rb,2.229056e-02_rb,2.120335e-02_rb,2.022541e-02_rb,1.933763e-02_rb, & + 1.852546e-02_rb,1.777763e-02_rb,1.708528e-02_rb,1.644134e-02_rb,1.584009e-02_rb, & + 1.527684e-02_rb,1.474774e-02_rb,1.424955e-02_rb,1.377957e-02_rb,1.333549e-02_rb, & + 1.291534e-02_rb,1.251743e-02_rb,1.214029e-02_rb,1.178265e-02_rb,1.144337e-02_rb, & + 1.112148e-02_rb,1.081609e-02_rb,1.052642e-02_rb,1.025178e-02_rb,9.991540e-03_rb, & + 9.745130e-03_rb,9.512038e-03_rb,9.291797e-03_rb,9.083980e-03_rb,8.888195e-03_rb, & + 8.704081e-03_rb,8.531306e-03_rb,8.369560e-03_rb,8.218558e-03_rb,8.078032e-03_rb, & + 7.947730e-03_rb/) + absice3(:,13) = (/ & +! band 13 + 1.560311e-01_rb,9.961097e-02_rb,7.502949e-02_rb,6.115022e-02_rb,5.214952e-02_rb, & + 4.578149e-02_rb,4.099731e-02_rb,3.724174e-02_rb,3.419343e-02_rb,3.165356e-02_rb, & + 2.949251e-02_rb,2.762222e-02_rb,2.598073e-02_rb,2.452322e-02_rb,2.321642e-02_rb, & + 2.203516e-02_rb,2.096002e-02_rb,1.997579e-02_rb,1.907036e-02_rb,1.823401e-02_rb, & + 1.745879e-02_rb,1.673819e-02_rb,1.606678e-02_rb,1.544003e-02_rb,1.485411e-02_rb, & + 1.430574e-02_rb,1.379215e-02_rb,1.331092e-02_rb,1.285996e-02_rb,1.243746e-02_rb, & + 1.204183e-02_rb,1.167164e-02_rb,1.132567e-02_rb,1.100281e-02_rb,1.070207e-02_rb, & + 1.042258e-02_rb,1.016352e-02_rb,9.924197e-03_rb,9.703953e-03_rb,9.502199e-03_rb, & + 9.318400e-03_rb,9.152066e-03_rb,9.002749e-03_rb,8.870038e-03_rb,8.753555e-03_rb, & + 8.652951e-03_rb/) + absice3(:,14) = (/ & +! band 14 + 1.559547e-01_rb,9.896700e-02_rb,7.441231e-02_rb,6.061469e-02_rb,5.168730e-02_rb, & + 4.537821e-02_rb,4.064106e-02_rb,3.692367e-02_rb,3.390714e-02_rb,3.139438e-02_rb, & + 2.925702e-02_rb,2.740783e-02_rb,2.578547e-02_rb,2.434552e-02_rb,2.305506e-02_rb, & + 2.188910e-02_rb,2.082842e-02_rb,1.985789e-02_rb,1.896553e-02_rb,1.814165e-02_rb, & + 1.737839e-02_rb,1.666927e-02_rb,1.600891e-02_rb,1.539279e-02_rb,1.481712e-02_rb, & + 1.427865e-02_rb,1.377463e-02_rb,1.330266e-02_rb,1.286068e-02_rb,1.244689e-02_rb, & + 1.205973e-02_rb,1.169780e-02_rb,1.135989e-02_rb,1.104492e-02_rb,1.075192e-02_rb, & + 1.048004e-02_rb,1.022850e-02_rb,9.996611e-03_rb,9.783753e-03_rb,9.589361e-03_rb, & + 9.412924e-03_rb,9.253977e-03_rb,9.112098e-03_rb,8.986903e-03_rb,8.878039e-03_rb, & + 8.785184e-03_rb/) + absice3(:,15) = (/ & +! band 15 + 1.102926e-01_rb,7.176622e-02_rb,5.530316e-02_rb,4.606056e-02_rb,4.006116e-02_rb, & + 3.579628e-02_rb,3.256909e-02_rb,3.001360e-02_rb,2.791920e-02_rb,2.615617e-02_rb, & + 2.464023e-02_rb,2.331426e-02_rb,2.213817e-02_rb,2.108301e-02_rb,2.012733e-02_rb, & + 1.925493e-02_rb,1.845331e-02_rb,1.771269e-02_rb,1.702531e-02_rb,1.638493e-02_rb, & + 1.578648e-02_rb,1.522579e-02_rb,1.469940e-02_rb,1.420442e-02_rb,1.373841e-02_rb, & + 1.329931e-02_rb,1.288535e-02_rb,1.249502e-02_rb,1.212700e-02_rb,1.178015e-02_rb, & + 1.145348e-02_rb,1.114612e-02_rb,1.085730e-02_rb,1.058633e-02_rb,1.033263e-02_rb, & + 1.009564e-02_rb,9.874895e-03_rb,9.669960e-03_rb,9.480449e-03_rb,9.306014e-03_rb, & + 9.146339e-03_rb,9.001138e-03_rb,8.870154e-03_rb,8.753148e-03_rb,8.649907e-03_rb, & + 8.560232e-03_rb/) + absice3(:,16) = (/ & +! band 16 + 1.688344e-01_rb,1.077072e-01_rb,7.994467e-02_rb,6.403862e-02_rb,5.369850e-02_rb, & + 4.641582e-02_rb,4.099331e-02_rb,3.678724e-02_rb,3.342069e-02_rb,3.065831e-02_rb, & + 2.834557e-02_rb,2.637680e-02_rb,2.467733e-02_rb,2.319286e-02_rb,2.188299e-02_rb, & + 2.071701e-02_rb,1.967121e-02_rb,1.872692e-02_rb,1.786931e-02_rb,1.708641e-02_rb, & + 1.636846e-02_rb,1.570743e-02_rb,1.509665e-02_rb,1.453052e-02_rb,1.400433e-02_rb, & + 1.351407e-02_rb,1.305631e-02_rb,1.262810e-02_rb,1.222688e-02_rb,1.185044e-02_rb, & + 1.149683e-02_rb,1.116436e-02_rb,1.085153e-02_rb,1.055701e-02_rb,1.027961e-02_rb, & + 1.001831e-02_rb,9.772141e-03_rb,9.540280e-03_rb,9.321966e-03_rb,9.116517e-03_rb, & + 8.923315e-03_rb,8.741803e-03_rb,8.571472e-03_rb,8.411860e-03_rb,8.262543e-03_rb, & + 8.123136e-03_rb/) + +! For LIQFLAG = 0. + absliq0 = 0.0903614_rb + +! For LIQFLAG = 1. In each band, the absorption +! coefficients are listed for a range of effective radii from 2.5 +! to 59.5 microns in increments of 1.0 micron. + absliq1(:, 1) = (/ & +! band 1 + 1.64047e-03_rb, 6.90533e-02_rb, 7.72017e-02_rb, 7.78054e-02_rb, 7.69523e-02_rb, & + 7.58058e-02_rb, 7.46400e-02_rb, 7.35123e-02_rb, 7.24162e-02_rb, 7.13225e-02_rb, & + 6.99145e-02_rb, 6.66409e-02_rb, 6.36582e-02_rb, 6.09425e-02_rb, 5.84593e-02_rb, & + 5.61743e-02_rb, 5.40571e-02_rb, 5.20812e-02_rb, 5.02245e-02_rb, 4.84680e-02_rb, & + 4.67959e-02_rb, 4.51944e-02_rb, 4.36516e-02_rb, 4.21570e-02_rb, 4.07015e-02_rb, & + 3.92766e-02_rb, 3.78747e-02_rb, 3.64886e-02_rb, 3.53632e-02_rb, 3.41992e-02_rb, & + 3.31016e-02_rb, 3.20643e-02_rb, 3.10817e-02_rb, 3.01490e-02_rb, 2.92620e-02_rb, & + 2.84171e-02_rb, 2.76108e-02_rb, 2.68404e-02_rb, 2.61031e-02_rb, 2.53966e-02_rb, & + 2.47189e-02_rb, 2.40678e-02_rb, 2.34418e-02_rb, 2.28392e-02_rb, 2.22586e-02_rb, & + 2.16986e-02_rb, 2.11580e-02_rb, 2.06356e-02_rb, 2.01305e-02_rb, 1.96417e-02_rb, & + 1.91682e-02_rb, 1.87094e-02_rb, 1.82643e-02_rb, 1.78324e-02_rb, 1.74129e-02_rb, & + 1.70052e-02_rb, 1.66088e-02_rb, 1.62231e-02_rb/) + absliq1(:, 2) = (/ & +! band 2 + 2.19486e-01_rb, 1.80687e-01_rb, 1.59150e-01_rb, 1.44731e-01_rb, 1.33703e-01_rb, & + 1.24355e-01_rb, 1.15756e-01_rb, 1.07318e-01_rb, 9.86119e-02_rb, 8.92739e-02_rb, & + 8.34911e-02_rb, 7.70773e-02_rb, 7.15240e-02_rb, 6.66615e-02_rb, 6.23641e-02_rb, & + 5.85359e-02_rb, 5.51020e-02_rb, 5.20032e-02_rb, 4.91916e-02_rb, 4.66283e-02_rb, & + 4.42813e-02_rb, 4.21236e-02_rb, 4.01330e-02_rb, 3.82905e-02_rb, 3.65797e-02_rb, & + 3.49869e-02_rb, 3.35002e-02_rb, 3.21090e-02_rb, 3.08957e-02_rb, 2.97601e-02_rb, & + 2.86966e-02_rb, 2.76984e-02_rb, 2.67599e-02_rb, 2.58758e-02_rb, 2.50416e-02_rb, & + 2.42532e-02_rb, 2.35070e-02_rb, 2.27997e-02_rb, 2.21284e-02_rb, 2.14904e-02_rb, & + 2.08834e-02_rb, 2.03051e-02_rb, 1.97536e-02_rb, 1.92271e-02_rb, 1.87239e-02_rb, & + 1.82425e-02_rb, 1.77816e-02_rb, 1.73399e-02_rb, 1.69162e-02_rb, 1.65094e-02_rb, & + 1.61187e-02_rb, 1.57430e-02_rb, 1.53815e-02_rb, 1.50334e-02_rb, 1.46981e-02_rb, & + 1.43748e-02_rb, 1.40628e-02_rb, 1.37617e-02_rb/) + absliq1(:, 3) = (/ & +! band 3 + 2.95174e-01_rb, 2.34765e-01_rb, 1.98038e-01_rb, 1.72114e-01_rb, 1.52083e-01_rb, & + 1.35654e-01_rb, 1.21613e-01_rb, 1.09252e-01_rb, 9.81263e-02_rb, 8.79448e-02_rb, & + 8.12566e-02_rb, 7.44563e-02_rb, 6.86374e-02_rb, 6.36042e-02_rb, 5.92094e-02_rb, & + 5.53402e-02_rb, 5.19087e-02_rb, 4.88455e-02_rb, 4.60951e-02_rb, 4.36124e-02_rb, & + 4.13607e-02_rb, 3.93096e-02_rb, 3.74338e-02_rb, 3.57119e-02_rb, 3.41261e-02_rb, & + 3.26610e-02_rb, 3.13036e-02_rb, 3.00425e-02_rb, 2.88497e-02_rb, 2.78077e-02_rb, & + 2.68317e-02_rb, 2.59158e-02_rb, 2.50545e-02_rb, 2.42430e-02_rb, 2.34772e-02_rb, & + 2.27533e-02_rb, 2.20679e-02_rb, 2.14181e-02_rb, 2.08011e-02_rb, 2.02145e-02_rb, & + 1.96561e-02_rb, 1.91239e-02_rb, 1.86161e-02_rb, 1.81311e-02_rb, 1.76673e-02_rb, & + 1.72234e-02_rb, 1.67981e-02_rb, 1.63903e-02_rb, 1.59989e-02_rb, 1.56230e-02_rb, & + 1.52615e-02_rb, 1.49138e-02_rb, 1.45791e-02_rb, 1.42565e-02_rb, 1.39455e-02_rb, & + 1.36455e-02_rb, 1.33559e-02_rb, 1.30761e-02_rb/) + absliq1(:, 4) = (/ & +! band 4 + 3.00925e-01_rb, 2.36949e-01_rb, 1.96947e-01_rb, 1.68692e-01_rb, 1.47190e-01_rb, & + 1.29986e-01_rb, 1.15719e-01_rb, 1.03568e-01_rb, 9.30028e-02_rb, 8.36658e-02_rb, & + 7.71075e-02_rb, 7.07002e-02_rb, 6.52284e-02_rb, 6.05024e-02_rb, 5.63801e-02_rb, & + 5.27534e-02_rb, 4.95384e-02_rb, 4.66690e-02_rb, 4.40925e-02_rb, 4.17664e-02_rb, & + 3.96559e-02_rb, 3.77326e-02_rb, 3.59727e-02_rb, 3.43561e-02_rb, 3.28662e-02_rb, & + 3.14885e-02_rb, 3.02110e-02_rb, 2.90231e-02_rb, 2.78948e-02_rb, 2.69109e-02_rb, & + 2.59884e-02_rb, 2.51217e-02_rb, 2.43058e-02_rb, 2.35364e-02_rb, 2.28096e-02_rb, & + 2.21218e-02_rb, 2.14700e-02_rb, 2.08515e-02_rb, 2.02636e-02_rb, 1.97041e-02_rb, & + 1.91711e-02_rb, 1.86625e-02_rb, 1.81769e-02_rb, 1.77126e-02_rb, 1.72683e-02_rb, & + 1.68426e-02_rb, 1.64344e-02_rb, 1.60427e-02_rb, 1.56664e-02_rb, 1.53046e-02_rb, & + 1.49565e-02_rb, 1.46214e-02_rb, 1.42985e-02_rb, 1.39871e-02_rb, 1.36866e-02_rb, & + 1.33965e-02_rb, 1.31162e-02_rb, 1.28453e-02_rb/) + absliq1(:, 5) = (/ & +! band 5 + 2.64691e-01_rb, 2.12018e-01_rb, 1.78009e-01_rb, 1.53539e-01_rb, 1.34721e-01_rb, & + 1.19580e-01_rb, 1.06996e-01_rb, 9.62772e-02_rb, 8.69710e-02_rb, 7.87670e-02_rb, & + 7.29272e-02_rb, 6.70920e-02_rb, 6.20977e-02_rb, 5.77732e-02_rb, 5.39910e-02_rb, & + 5.06538e-02_rb, 4.76866e-02_rb, 4.50301e-02_rb, 4.26374e-02_rb, 4.04704e-02_rb, & + 3.84981e-02_rb, 3.66948e-02_rb, 3.50394e-02_rb, 3.35141e-02_rb, 3.21038e-02_rb, & + 3.07957e-02_rb, 2.95788e-02_rb, 2.84438e-02_rb, 2.73790e-02_rb, 2.64390e-02_rb, & + 2.55565e-02_rb, 2.47263e-02_rb, 2.39437e-02_rb, 2.32047e-02_rb, 2.25056e-02_rb, & + 2.18433e-02_rb, 2.12149e-02_rb, 2.06177e-02_rb, 2.00495e-02_rb, 1.95081e-02_rb, & + 1.89917e-02_rb, 1.84984e-02_rb, 1.80269e-02_rb, 1.75755e-02_rb, 1.71431e-02_rb, & + 1.67283e-02_rb, 1.63303e-02_rb, 1.59478e-02_rb, 1.55801e-02_rb, 1.52262e-02_rb, & + 1.48853e-02_rb, 1.45568e-02_rb, 1.42400e-02_rb, 1.39342e-02_rb, 1.36388e-02_rb, & + 1.33533e-02_rb, 1.30773e-02_rb, 1.28102e-02_rb/) + absliq1(:, 6) = (/ & +! band 6 + 8.81182e-02_rb, 1.06745e-01_rb, 9.79753e-02_rb, 8.99625e-02_rb, 8.35200e-02_rb, & + 7.81899e-02_rb, 7.35939e-02_rb, 6.94696e-02_rb, 6.56266e-02_rb, 6.19148e-02_rb, & + 5.83355e-02_rb, 5.49306e-02_rb, 5.19642e-02_rb, 4.93325e-02_rb, 4.69659e-02_rb, & + 4.48148e-02_rb, 4.28431e-02_rb, 4.10231e-02_rb, 3.93332e-02_rb, 3.77563e-02_rb, & + 3.62785e-02_rb, 3.48882e-02_rb, 3.35758e-02_rb, 3.23333e-02_rb, 3.11536e-02_rb, & + 3.00310e-02_rb, 2.89601e-02_rb, 2.79365e-02_rb, 2.70502e-02_rb, 2.62618e-02_rb, & + 2.55025e-02_rb, 2.47728e-02_rb, 2.40726e-02_rb, 2.34013e-02_rb, 2.27583e-02_rb, & + 2.21422e-02_rb, 2.15522e-02_rb, 2.09869e-02_rb, 2.04453e-02_rb, 1.99260e-02_rb, & + 1.94280e-02_rb, 1.89501e-02_rb, 1.84913e-02_rb, 1.80506e-02_rb, 1.76270e-02_rb, & + 1.72196e-02_rb, 1.68276e-02_rb, 1.64500e-02_rb, 1.60863e-02_rb, 1.57357e-02_rb, & + 1.53975e-02_rb, 1.50710e-02_rb, 1.47558e-02_rb, 1.44511e-02_rb, 1.41566e-02_rb, & + 1.38717e-02_rb, 1.35960e-02_rb, 1.33290e-02_rb/) + absliq1(:, 7) = (/ & +! band 7 + 4.32174e-02_rb, 7.36078e-02_rb, 6.98340e-02_rb, 6.65231e-02_rb, 6.41948e-02_rb, & + 6.23551e-02_rb, 6.06638e-02_rb, 5.88680e-02_rb, 5.67124e-02_rb, 5.38629e-02_rb, & + 4.99579e-02_rb, 4.86289e-02_rb, 4.70120e-02_rb, 4.52854e-02_rb, 4.35466e-02_rb, & + 4.18480e-02_rb, 4.02169e-02_rb, 3.86658e-02_rb, 3.71992e-02_rb, 3.58168e-02_rb, & + 3.45155e-02_rb, 3.32912e-02_rb, 3.21390e-02_rb, 3.10538e-02_rb, 3.00307e-02_rb, & + 2.90651e-02_rb, 2.81524e-02_rb, 2.72885e-02_rb, 2.62821e-02_rb, 2.55744e-02_rb, & + 2.48799e-02_rb, 2.42029e-02_rb, 2.35460e-02_rb, 2.29108e-02_rb, 2.22981e-02_rb, & + 2.17079e-02_rb, 2.11402e-02_rb, 2.05945e-02_rb, 2.00701e-02_rb, 1.95663e-02_rb, & + 1.90824e-02_rb, 1.86174e-02_rb, 1.81706e-02_rb, 1.77411e-02_rb, 1.73281e-02_rb, & + 1.69307e-02_rb, 1.65483e-02_rb, 1.61801e-02_rb, 1.58254e-02_rb, 1.54835e-02_rb, & + 1.51538e-02_rb, 1.48358e-02_rb, 1.45288e-02_rb, 1.42322e-02_rb, 1.39457e-02_rb, & + 1.36687e-02_rb, 1.34008e-02_rb, 1.31416e-02_rb/) + absliq1(:, 8) = (/ & +! band 8 + 1.41881e-01_rb, 7.15419e-02_rb, 6.30335e-02_rb, 6.11132e-02_rb, 6.01931e-02_rb, & + 5.92420e-02_rb, 5.78968e-02_rb, 5.58876e-02_rb, 5.28923e-02_rb, 4.84462e-02_rb, & + 4.60839e-02_rb, 4.56013e-02_rb, 4.45410e-02_rb, 4.31866e-02_rb, 4.17026e-02_rb, & + 4.01850e-02_rb, 3.86892e-02_rb, 3.72461e-02_rb, 3.58722e-02_rb, 3.45749e-02_rb, & + 3.33564e-02_rb, 3.22155e-02_rb, 3.11494e-02_rb, 3.01541e-02_rb, 2.92253e-02_rb, & + 2.83584e-02_rb, 2.75488e-02_rb, 2.67925e-02_rb, 2.57692e-02_rb, 2.50704e-02_rb, & + 2.43918e-02_rb, 2.37350e-02_rb, 2.31005e-02_rb, 2.24888e-02_rb, 2.18996e-02_rb, & + 2.13325e-02_rb, 2.07870e-02_rb, 2.02623e-02_rb, 1.97577e-02_rb, 1.92724e-02_rb, & + 1.88056e-02_rb, 1.83564e-02_rb, 1.79241e-02_rb, 1.75079e-02_rb, 1.71070e-02_rb, & + 1.67207e-02_rb, 1.63482e-02_rb, 1.59890e-02_rb, 1.56424e-02_rb, 1.53077e-02_rb, & + 1.49845e-02_rb, 1.46722e-02_rb, 1.43702e-02_rb, 1.40782e-02_rb, 1.37955e-02_rb, & + 1.35219e-02_rb, 1.32569e-02_rb, 1.30000e-02_rb/) + absliq1(:, 9) = (/ & +! band 9 + 6.72726e-02_rb, 6.61013e-02_rb, 6.47866e-02_rb, 6.33780e-02_rb, 6.18985e-02_rb, & + 6.03335e-02_rb, 5.86136e-02_rb, 5.65876e-02_rb, 5.39839e-02_rb, 5.03536e-02_rb, & + 4.71608e-02_rb, 4.63630e-02_rb, 4.50313e-02_rb, 4.34526e-02_rb, 4.17876e-02_rb, & + 4.01261e-02_rb, 3.85171e-02_rb, 3.69860e-02_rb, 3.55442e-02_rb, 3.41954e-02_rb, & + 3.29384e-02_rb, 3.17693e-02_rb, 3.06832e-02_rb, 2.96745e-02_rb, 2.87374e-02_rb, & + 2.78662e-02_rb, 2.70557e-02_rb, 2.63008e-02_rb, 2.52450e-02_rb, 2.45424e-02_rb, & + 2.38656e-02_rb, 2.32144e-02_rb, 2.25885e-02_rb, 2.19873e-02_rb, 2.14099e-02_rb, & + 2.08554e-02_rb, 2.03230e-02_rb, 1.98116e-02_rb, 1.93203e-02_rb, 1.88482e-02_rb, & + 1.83944e-02_rb, 1.79578e-02_rb, 1.75378e-02_rb, 1.71335e-02_rb, 1.67440e-02_rb, & + 1.63687e-02_rb, 1.60069e-02_rb, 1.56579e-02_rb, 1.53210e-02_rb, 1.49958e-02_rb, & + 1.46815e-02_rb, 1.43778e-02_rb, 1.40841e-02_rb, 1.37999e-02_rb, 1.35249e-02_rb, & + 1.32585e-02_rb, 1.30004e-02_rb, 1.27502e-02_rb/) + absliq1(:,10) = (/ & +! band 10 + 7.97040e-02_rb, 7.63844e-02_rb, 7.36499e-02_rb, 7.13525e-02_rb, 6.93043e-02_rb, & + 6.72807e-02_rb, 6.50227e-02_rb, 6.22395e-02_rb, 5.86093e-02_rb, 5.37815e-02_rb, & + 5.14682e-02_rb, 4.97214e-02_rb, 4.77392e-02_rb, 4.56961e-02_rb, 4.36858e-02_rb, & + 4.17569e-02_rb, 3.99328e-02_rb, 3.82224e-02_rb, 3.66265e-02_rb, 3.51416e-02_rb, & + 3.37617e-02_rb, 3.24798e-02_rb, 3.12887e-02_rb, 3.01812e-02_rb, 2.91505e-02_rb, & + 2.81900e-02_rb, 2.72939e-02_rb, 2.64568e-02_rb, 2.54165e-02_rb, 2.46832e-02_rb, & + 2.39783e-02_rb, 2.33017e-02_rb, 2.26531e-02_rb, 2.20314e-02_rb, 2.14359e-02_rb, & + 2.08653e-02_rb, 2.03187e-02_rb, 1.97947e-02_rb, 1.92924e-02_rb, 1.88106e-02_rb, & + 1.83483e-02_rb, 1.79043e-02_rb, 1.74778e-02_rb, 1.70678e-02_rb, 1.66735e-02_rb, & + 1.62941e-02_rb, 1.59286e-02_rb, 1.55766e-02_rb, 1.52371e-02_rb, 1.49097e-02_rb, & + 1.45937e-02_rb, 1.42885e-02_rb, 1.39936e-02_rb, 1.37085e-02_rb, 1.34327e-02_rb, & + 1.31659e-02_rb, 1.29075e-02_rb, 1.26571e-02_rb/) + absliq1(:,11) = (/ & +! band 11 + 1.49438e-01_rb, 1.33535e-01_rb, 1.21542e-01_rb, 1.11743e-01_rb, 1.03263e-01_rb, & + 9.55774e-02_rb, 8.83382e-02_rb, 8.12943e-02_rb, 7.42533e-02_rb, 6.70609e-02_rb, & + 6.38761e-02_rb, 5.97788e-02_rb, 5.59841e-02_rb, 5.25318e-02_rb, 4.94132e-02_rb, & + 4.66014e-02_rb, 4.40644e-02_rb, 4.17706e-02_rb, 3.96910e-02_rb, 3.77998e-02_rb, & + 3.60742e-02_rb, 3.44947e-02_rb, 3.30442e-02_rb, 3.17079e-02_rb, 3.04730e-02_rb, & + 2.93283e-02_rb, 2.82642e-02_rb, 2.72720e-02_rb, 2.61789e-02_rb, 2.53277e-02_rb, & + 2.45237e-02_rb, 2.37635e-02_rb, 2.30438e-02_rb, 2.23615e-02_rb, 2.17140e-02_rb, & + 2.10987e-02_rb, 2.05133e-02_rb, 1.99557e-02_rb, 1.94241e-02_rb, 1.89166e-02_rb, & + 1.84317e-02_rb, 1.79679e-02_rb, 1.75238e-02_rb, 1.70983e-02_rb, 1.66901e-02_rb, & + 1.62983e-02_rb, 1.59219e-02_rb, 1.55599e-02_rb, 1.52115e-02_rb, 1.48761e-02_rb, & + 1.45528e-02_rb, 1.42411e-02_rb, 1.39402e-02_rb, 1.36497e-02_rb, 1.33690e-02_rb, & + 1.30976e-02_rb, 1.28351e-02_rb, 1.25810e-02_rb/) + absliq1(:,12) = (/ & +! band 12 + 3.71985e-02_rb, 3.88586e-02_rb, 3.99070e-02_rb, 4.04351e-02_rb, 4.04610e-02_rb, & + 3.99834e-02_rb, 3.89953e-02_rb, 3.74886e-02_rb, 3.54551e-02_rb, 3.28870e-02_rb, & + 3.32576e-02_rb, 3.22444e-02_rb, 3.12384e-02_rb, 3.02584e-02_rb, 2.93146e-02_rb, & + 2.84120e-02_rb, 2.75525e-02_rb, 2.67361e-02_rb, 2.59618e-02_rb, 2.52280e-02_rb, & + 2.45327e-02_rb, 2.38736e-02_rb, 2.32487e-02_rb, 2.26558e-02_rb, 2.20929e-02_rb, & + 2.15579e-02_rb, 2.10491e-02_rb, 2.05648e-02_rb, 1.99749e-02_rb, 1.95704e-02_rb, & + 1.91731e-02_rb, 1.87839e-02_rb, 1.84032e-02_rb, 1.80315e-02_rb, 1.76689e-02_rb, & + 1.73155e-02_rb, 1.69712e-02_rb, 1.66362e-02_rb, 1.63101e-02_rb, 1.59928e-02_rb, & + 1.56842e-02_rb, 1.53840e-02_rb, 1.50920e-02_rb, 1.48080e-02_rb, 1.45318e-02_rb, & + 1.42631e-02_rb, 1.40016e-02_rb, 1.37472e-02_rb, 1.34996e-02_rb, 1.32586e-02_rb, & + 1.30239e-02_rb, 1.27954e-02_rb, 1.25728e-02_rb, 1.23559e-02_rb, 1.21445e-02_rb, & + 1.19385e-02_rb, 1.17376e-02_rb, 1.15417e-02_rb/) + + absliq1(:,13) = (/ & +! band 13 + 3.11868e-02_rb, 4.48357e-02_rb, 4.90224e-02_rb, 4.96406e-02_rb, 4.86806e-02_rb, & + 4.69610e-02_rb, 4.48630e-02_rb, 4.25795e-02_rb, 4.02138e-02_rb, 3.78236e-02_rb, & + 3.74266e-02_rb, 3.60384e-02_rb, 3.47074e-02_rb, 3.34434e-02_rb, 3.22499e-02_rb, & + 3.11264e-02_rb, 3.00704e-02_rb, 2.90784e-02_rb, 2.81463e-02_rb, 2.72702e-02_rb, & + 2.64460e-02_rb, 2.56698e-02_rb, 2.49381e-02_rb, 2.42475e-02_rb, 2.35948e-02_rb, & + 2.29774e-02_rb, 2.23925e-02_rb, 2.18379e-02_rb, 2.11793e-02_rb, 2.07076e-02_rb, & + 2.02470e-02_rb, 1.97981e-02_rb, 1.93613e-02_rb, 1.89367e-02_rb, 1.85243e-02_rb, & + 1.81240e-02_rb, 1.77356e-02_rb, 1.73588e-02_rb, 1.69935e-02_rb, 1.66392e-02_rb, & + 1.62956e-02_rb, 1.59624e-02_rb, 1.56393e-02_rb, 1.53259e-02_rb, 1.50219e-02_rb, & + 1.47268e-02_rb, 1.44404e-02_rb, 1.41624e-02_rb, 1.38925e-02_rb, 1.36302e-02_rb, & + 1.33755e-02_rb, 1.31278e-02_rb, 1.28871e-02_rb, 1.26530e-02_rb, 1.24253e-02_rb, & + 1.22038e-02_rb, 1.19881e-02_rb, 1.17782e-02_rb/) + absliq1(:,14) = (/ & +! band 14 + 1.58988e-02_rb, 3.50652e-02_rb, 4.00851e-02_rb, 4.07270e-02_rb, 3.98101e-02_rb, & + 3.83306e-02_rb, 3.66829e-02_rb, 3.50327e-02_rb, 3.34497e-02_rb, 3.19609e-02_rb, & + 3.13712e-02_rb, 3.03348e-02_rb, 2.93415e-02_rb, 2.83973e-02_rb, 2.75037e-02_rb, & + 2.66604e-02_rb, 2.58654e-02_rb, 2.51161e-02_rb, 2.44100e-02_rb, 2.37440e-02_rb, & + 2.31154e-02_rb, 2.25215e-02_rb, 2.19599e-02_rb, 2.14282e-02_rb, 2.09242e-02_rb, & + 2.04459e-02_rb, 1.99915e-02_rb, 1.95594e-02_rb, 1.90254e-02_rb, 1.86598e-02_rb, & + 1.82996e-02_rb, 1.79455e-02_rb, 1.75983e-02_rb, 1.72584e-02_rb, 1.69260e-02_rb, & + 1.66013e-02_rb, 1.62843e-02_rb, 1.59752e-02_rb, 1.56737e-02_rb, 1.53799e-02_rb, & + 1.50936e-02_rb, 1.48146e-02_rb, 1.45429e-02_rb, 1.42782e-02_rb, 1.40203e-02_rb, & + 1.37691e-02_rb, 1.35243e-02_rb, 1.32858e-02_rb, 1.30534e-02_rb, 1.28270e-02_rb, & + 1.26062e-02_rb, 1.23909e-02_rb, 1.21810e-02_rb, 1.19763e-02_rb, 1.17766e-02_rb, & + 1.15817e-02_rb, 1.13915e-02_rb, 1.12058e-02_rb/) + absliq1(:,15) = (/ & +! band 15 + 5.02079e-03_rb, 2.17615e-02_rb, 2.55449e-02_rb, 2.59484e-02_rb, 2.53650e-02_rb, & + 2.45281e-02_rb, 2.36843e-02_rb, 2.29159e-02_rb, 2.22451e-02_rb, 2.16716e-02_rb, & + 2.11451e-02_rb, 2.05817e-02_rb, 2.00454e-02_rb, 1.95372e-02_rb, 1.90567e-02_rb, & + 1.86028e-02_rb, 1.81742e-02_rb, 1.77693e-02_rb, 1.73866e-02_rb, 1.70244e-02_rb, & + 1.66815e-02_rb, 1.63563e-02_rb, 1.60477e-02_rb, 1.57544e-02_rb, 1.54755e-02_rb, & + 1.52097e-02_rb, 1.49564e-02_rb, 1.47146e-02_rb, 1.43684e-02_rb, 1.41728e-02_rb, & + 1.39762e-02_rb, 1.37797e-02_rb, 1.35838e-02_rb, 1.33891e-02_rb, 1.31961e-02_rb, & + 1.30051e-02_rb, 1.28164e-02_rb, 1.26302e-02_rb, 1.24466e-02_rb, 1.22659e-02_rb, & + 1.20881e-02_rb, 1.19131e-02_rb, 1.17412e-02_rb, 1.15723e-02_rb, 1.14063e-02_rb, & + 1.12434e-02_rb, 1.10834e-02_rb, 1.09264e-02_rb, 1.07722e-02_rb, 1.06210e-02_rb, & + 1.04725e-02_rb, 1.03269e-02_rb, 1.01839e-02_rb, 1.00436e-02_rb, 9.90593e-03_rb, & + 9.77080e-03_rb, 9.63818e-03_rb, 9.50800e-03_rb/) + absliq1(:,16) = (/ & +! band 16 + 5.64971e-02_rb, 9.04736e-02_rb, 8.11726e-02_rb, 7.05450e-02_rb, 6.20052e-02_rb, & + 5.54286e-02_rb, 5.03503e-02_rb, 4.63791e-02_rb, 4.32290e-02_rb, 4.06959e-02_rb, & + 3.74690e-02_rb, 3.52964e-02_rb, 3.33799e-02_rb, 3.16774e-02_rb, 3.01550e-02_rb, & + 2.87856e-02_rb, 2.75474e-02_rb, 2.64223e-02_rb, 2.53953e-02_rb, 2.44542e-02_rb, & + 2.35885e-02_rb, 2.27894e-02_rb, 2.20494e-02_rb, 2.13622e-02_rb, 2.07222e-02_rb, & + 2.01246e-02_rb, 1.95654e-02_rb, 1.90408e-02_rb, 1.84398e-02_rb, 1.80021e-02_rb, & + 1.75816e-02_rb, 1.71775e-02_rb, 1.67889e-02_rb, 1.64152e-02_rb, 1.60554e-02_rb, & + 1.57089e-02_rb, 1.53751e-02_rb, 1.50531e-02_rb, 1.47426e-02_rb, 1.44428e-02_rb, & + 1.41532e-02_rb, 1.38734e-02_rb, 1.36028e-02_rb, 1.33410e-02_rb, 1.30875e-02_rb, & + 1.28420e-02_rb, 1.26041e-02_rb, 1.23735e-02_rb, 1.21497e-02_rb, 1.19325e-02_rb, & + 1.17216e-02_rb, 1.15168e-02_rb, 1.13177e-02_rb, 1.11241e-02_rb, 1.09358e-02_rb, & + 1.07525e-02_rb, 1.05741e-02_rb, 1.04003e-02_rb/) + +!jm not thread safe hvrclc = '$Revision: 1.8 $' + + ncbands = 1 + +! This initialization is done in rrtmg_lw_subcol.F90. +! do lay = 1, nlayers +! do ig = 1, ngptlw +! taucmc(ig,lay) = 0.0_rb +! enddo +! enddo + +! Main layer loop + do lay = 1, nlayers + + do ig = 1, ngptlw + cwp = ciwpmc(ig,lay) + clwpmc(ig,lay) + cswpmc(ig,lay) + if (cldfmc(ig,lay) .ge. cldmin .and. & + & (cwp .ge. cldmin .or. taucmc(ig,lay) .ge. cldmin)) then + + +! Ice clouds and water clouds combined. + if (inflag .eq. 0) then +! Cloud optical depth already defined in taucmc, return to main program + return + + elseif(inflag .eq. 1) then + stop 'INFLAG = 1 OPTION NOT AVAILABLE WITH MCICA' +! cwp = ciwpmc(ig,lay) + clwpmc(ig,lay) +! taucmc(ig,lay) = abscld1 * cwp + +! Separate treatement of ice clouds and water clouds. + elseif(inflag .ge. 2) then + radice = reicmc(lay) + +! Calculation of absorption coefficients due to ice clouds. + if ((ciwpmc(ig,lay)+cswpmc(ig,lay)) .eq. 0.0_rb) then + abscoice(ig) = 0.0_rb + abscosno(ig) = 0.0_rb + + elseif (iceflag .eq. 0) then + if (radice .lt. 10.0_rb) stop 'ICE RADIUS TOO SMALL' + abscoice(ig) = absice0(1) + absice0(2)/radice + abscosno(ig) = 0.0_rb + + elseif (iceflag .eq. 1) then + if (radice .lt. 13.0_rb .or. radice .gt. 130._rb) stop& + & 'ICE RADIUS OUT OF BOUNDS' + ncbands = 5 + ib = icb(ngb(ig)) + abscoice(ig) = absice1(1,ib) + absice1(2,ib)/radice + abscosno(ig) = 0.0_rb + +! For iceflag=2 option, ice particle effective radius is limited to 5.0 to 131.0 microns + + elseif (iceflag .eq. 2) then + if (radice .lt. 5.0_rb .or. radice .gt. 131.0_rb) stop& + & 'ICE RADIUS OUT OF BOUNDS' + ncbands = 16 + factor = (radice - 2._rb)/3._rb + index = int(factor) + if (index .eq. 43) index = 42 + fint = factor - float(index) + ib = ngb(ig) + abscoice(ig) = & + & absice2(index,ib) + fint * & + & (absice2(index+1,ib) - (absice2(index,ib))) + abscosno(ig) = 0.0_rb + +! For iceflag=3 option, ice particle generalized effective size is limited to 5.0 to 140.0 microns + + elseif (iceflag .ge. 3) then + if (radice .lt. 5.0_rb .or. radice .gt. 140.0_rb) then + write(errmess,'(A,i5,i5,f8.2,f8.2)' ) & + & 'ERROR: ICE GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS' & + & ,ig, lay, ciwpmc(ig,lay), radice + !mz call wrf_error_fatal(errmess) + end if + ncbands = 16 + factor = (radice - 2._rb)/3._rb + index = int(factor) + if (index .eq. 46) index = 45 + fint = factor - float(index) + ib = ngb(ig) + abscoice(ig) = & + & absice3(index,ib) + fint * & + & (absice3(index+1,ib) - (absice3(index,ib))) + abscosno(ig) = 0.0_rb + + endif + +!..Incorporate additional effects due to snow. + if (cswpmc(ig,lay).gt.0.0_rb .and. iceflag .eq. 5) then + radsno = resnmc(lay) + if (radsno .lt. 5.0_rb .or. radsno .gt. 140.0_rb) then + write(errmess,'(A,i5,i5,f8.2,f8.2)' ) & + & 'ERROR: SNOW GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS' & + & ,ig, lay, cswpmc(ig,lay), radsno + !mz call wrf_error_fatal(errmess) + end if + ncbands = 16 + factor = (radsno - 2._rb)/3._rb + index = int(factor) + if (index .eq. 46) index = 45 + fint = factor - float(index) + ib = ngb(ig) + abscosno(ig) = & + & absice3(index,ib) + fint * & + & (absice3(index+1,ib) - (absice3(index,ib))) + endif + + + +! Calculation of absorption coefficients due to water clouds. + if (clwpmc(ig,lay) .eq. 0.0_rb) then + abscoliq(ig) = 0.0_rb + + elseif (liqflag .eq. 0) then + abscoliq(ig) = absliq0 + + elseif (liqflag .eq. 1) then + radliq = relqmc(lay) + if (radliq .lt. 2.5_rb .or. radliq .gt. 60._rb) stop & + & 'LIQUID EFFECTIVE RADIUS OUT OF BOUNDS' + index = int(radliq - 1.5_rb) + if (index .eq. 0) index = 1 + if (index .eq. 58) index = 57 + fint = radliq - 1.5_rb - float(index) + ib = ngb(ig) + abscoliq(ig) = & + & absliq1(index,ib) + fint * & + & (absliq1(index+1,ib) - (absliq1(index,ib))) + endif + + taucmc(ig,lay) = ciwpmc(ig,lay) * abscoice(ig) + & + & clwpmc(ig,lay) * abscoliq(ig) + & + & cswpmc(ig,lay) * abscosno(ig) + + endif + endif + enddo + enddo + + end subroutine cldprmc + + +!........................................!$ + end module rrtmg_lw !$ +!========================================!$ diff --git a/physics/radsw_main.F90 b/physics/radsw_main.F90 new file mode 100644 index 000000000..cd7705d3f --- /dev/null +++ b/physics/radsw_main.F90 @@ -0,0 +1,6339 @@ +!> \file radsw_main.f +!! This file contains NCEP's modifications of the rrtmg-sw radiation +!! code from AER. + +! ============================================================== !!!!! +! sw-rrtm3 radiation package description !!!!! +! ============================================================== !!!!! +! ! +! this package includes ncep's modifications of the rrtm-sw radiation ! +! code from aer inc. ! +! ! +! the sw-rrtm3 package includes these parts: ! +! ! +! 'radsw_rrtm3_param.f' ! +! 'radsw_rrtm3_datatb.f' ! +! 'radsw_rrtm3_main.f' ! +! ! +! the 'radsw_rrtm3_param.f' contains: ! +! ! +! 'module_radsw_parameters' -- band parameters set up ! +! ! +! the 'radsw_rrtm3_datatb.f' contains: ! +! ! +! 'module_radsw_ref' -- reference temperature and pressure ! +! 'module_radsw_cldprtb' -- cloud property coefficients table ! +! 'module_radsw_sflux' -- spectral distribution of solar flux ! +! 'module_radsw_kgbnn' -- absorption coeffients for 14 ! +! bands, where nn = 16-29 ! +! ! +! the 'radsw_rrtm3_main.f' contains: ! +! ! +! 'rrtmg_sw' -- main sw radiation transfer ! +! ! +! in the main module 'rrtmg_sw' there are only two ! +! externally callable subroutines: ! +! ! +! 'swrad' -- main sw radiation routine ! +! inputs: ! +! (plyr,plvl,tlyr,tlvl,qlyr,olyr,gasvmr, ! +! clouds,icseed,aerosols,sfcalb, ! +! dzlyr,delpin,de_lgth, ! +! cosz,solcon,NDAY,idxday, ! +! npts, nlay, nlp1, lprnt, ! +! outputs: ! +! hswc,topflx,sfcflx,cldtau, ! +!! optional outputs: ! +! HSW0,HSWB,FLXPRF,FDNCMP) ! +! ) ! +! ! +! 'rswinit' -- initialization routine ! +! inputs: ! +! ( me ) ! +! outputs: ! +! (none) ! +! ! +! all the sw radiation subprograms become contained subprograms ! +! in module 'rrtmg_sw' and many of them are not directly ! +! accessable from places outside the module. ! +! ! +! derived data type constructs used: ! +! ! +! 1. radiation flux at toa: (from module 'module_radsw_parameters') ! +! topfsw_type - derived data type for toa rad fluxes ! +! upfxc total sky upward flux at toa ! +! dnfxc total sky downward flux at toa ! +! upfx0 clear sky upward flux at toa ! +! ! +! 2. radiation flux at sfc: (from module 'module_radsw_parameters') ! +! sfcfsw_type - derived data type for sfc rad fluxes ! +! upfxc total sky upward flux at sfc ! +! dnfxc total sky downward flux at sfc ! +! upfx0 clear sky upward flux at sfc ! +! dnfx0 clear sky downward flux at sfc ! +! ! +! 3. radiation flux profiles(from module 'module_radsw_parameters') ! +! profsw_type - derived data type for rad vertical prof ! +! upfxc level upward flux for total sky ! +! dnfxc level downward flux for total sky ! +! upfx0 level upward flux for clear sky ! +! dnfx0 level downward flux for clear sky ! +! ! +! 4. surface component fluxes(from module 'module_radsw_parameters' ! +! cmpfsw_type - derived data type for component sfc flux ! +! uvbfc total sky downward uv-b flux at sfc ! +! uvbf0 clear sky downward uv-b flux at sfc ! +! nirbm surface downward nir direct beam flux ! +! nirdf surface downward nir diffused flux ! +! visbm surface downward uv+vis direct beam flx ! +! visdf surface downward uv+vis diffused flux ! +! ! +! external modules referenced: ! +! ! +! 'module physparam' ! +! 'module physcons' ! +! 'mersenne_twister' ! +! ! +! compilation sequence is: ! +! ! +! 'radsw_rrtm3_param.f' ! +! 'radsw_rrtm3_datatb.f' ! +! 'radsw_rrtm3_main.f' ! +! ! +! and all should be put in front of routines that use sw modules ! +! ! +!==========================================================================! +! ! +! the original program declarations: ! +! ! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! ! +! Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). ! +! This software may be used, copied, or redistributed as long as it is ! +! not sold and this copyright notice is reproduced on each copy made. ! +! This model is provided as is without any express or implied warranties. ! +! (http://www.rtweb.aer.com/) ! +! ! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! ! +! ************************************************************************ ! +! ! +! rrtmg_sw ! +! ! +! ! +! a rapid radiative transfer model ! +! for the solar spectral region ! +! atmospheric and environmental research, inc. ! +! 131 hartwell avenue ! +! lexington, ma 02421 ! +! ! +! eli j. mlawer ! +! jennifer s. delamere ! +! michael j. iacono ! +! shepard a. clough ! +! ! +! ! +! email: miacono@aer.com ! +! email: emlawer@aer.com ! +! email: jdelamer@aer.com ! +! ! +! the authors wish to acknowledge the contributions of the ! +! following people: steven j. taubman, patrick d. brown, ! +! ronald e. farren, luke chen, robert bergstrom. ! +! ! +! ************************************************************************ ! +! ! +! references: ! +! (rrtm_sw/rrtmg_sw): ! +! clough, s.a., m.w. shephard, e.j. mlawer, j.s. delamere, ! +! m.j. iacono, k. cady-pereira, s. boukabara, and p.d. brown: ! +! atmospheric radiative transfer modeling: a summary of the aer ! +! codes, j. quant. spectrosc. radiat. transfer, 91, 233-244, 2005. ! +! ! +! (mcica): ! +! pincus, r., h. w. barker, and j.-j. morcrette: a fast, flexible, ! +! approximation technique for computing radiative transfer in ! +! inhomogeneous cloud fields, j. geophys. res., 108(d13), 4376, ! +! doi:10.1029/2002jd003322, 2003. ! +! ! +! ************************************************************************ ! +! ! +! aer's revision history: ! +! this version of rrtmg_sw has been modified from rrtm_sw to use a ! +! reduced set of g-point intervals and a two-stream model for ! +! application to gcms. ! +! ! +! -- original version (derived from rrtm_sw) ! +! 2002: aer. inc. ! +! -- conversion to f90 formatting; addition of 2-stream radiative transfer! +! feb 2003: j.-j. morcrette, ecmwf ! +! -- additional modifications for gcm application ! +! aug 2003: m. j. iacono, aer inc. ! +! -- total number of g-points reduced from 224 to 112. original ! +! set of 224 can be restored by exchanging code in module parrrsw.f90 ! +! and in file rrtmg_sw_init.f90. ! +! apr 2004: m. j. iacono, aer, inc. ! +! -- modifications to include output for direct and diffuse ! +! downward fluxes. there are output as "true" fluxes without ! +! any delta scaling applied. code can be commented to exclude ! +! this calculation in source file rrtmg_sw_spcvrt.f90. ! +! jan 2005: e. j. mlawer, m. j. iacono, aer, inc. ! +! -- revised to add mcica capability. ! +! nov 2005: m. j. iacono, aer, inc. ! +! -- reformatted for consistency with rrtmg_lw. ! +! feb 2007: m. j. iacono, aer, inc. ! +! -- modifications to formatting to use assumed-shape arrays. ! +! aug 2007: m. j. iacono, aer, inc. ! +! ! +! ************************************************************************ ! +! ! +! ncep modifications history log: ! +! ! +! sep 2003, yu-tai hou -- received aer's rrtm-sw gcm version ! +! code (v224) ! +! nov 2003, yu-tai hou -- corrected errors in direct/diffuse ! +! surface alabedo components. ! +! jan 2004, yu-tai hou -- modified code into standard modular! +! f9x code for ncep models. the original three cloud ! +! control flags are simplified into two: iflagliq and ! +! iflagice. combined the org subr sw_224 and setcoef ! +! into radsw (the main program); put all kgb##together ! +! and reformat into a separated data module; combine ! +! reftra and vrtqdr as swflux; optimized taumol and all ! +! taubgs to form a contained subroutines. ! +! jun 2004, yu-tai hou -- modified code based on aer's faster! +! version rrtmg_sw (v2.0) with 112 g-points. ! +! mar 2005, yu-tai hou -- modified to aer v2.3, correct cloud! +! scaling error, total sky properties are delta scaled ! +! after combining clear and cloudy parts. the testing ! +! criterion of ssa is saved before scaling. added cloud ! +! layer rain and snow contributions. all cloud water ! +! partical contents are treated the same way as other ! +! atmos particles. ! +! apr 2005, yu-tai hou -- modified on module structures (this! +! version of code was given back to aer in jun 2006) ! +! nov 2006, yu-tai hou -- modified code to include the ! +! generallized aerosol optical property scheme for gcms.! +! apr 2007, yu-tai hou -- added spectral band heating as an ! +! optional output to support the 500km model's upper ! +! stratospheric radiation calculations. restructure ! +! optional outputs for easy access by different models. ! +! oct 2008, yu-tai hou -- modified to include new features ! +! from aer's newer release v3.5-v3.61, including mcica ! +! sub-grid cloud option and true direct/diffuse fluxes ! +! without delta scaling. added rain/snow opt properties ! +! support to cloudy sky calculations. simplified and ! +! unified sw and lw sub-column cloud subroutines into ! +! one module by using optional parameters. ! +! mar 2009, yu-tai hou -- replaced the original random number! +! generator coming with the original code with ncep w3 ! +! library to simplify the program and moved sub-column ! +! cloud subroutines inside the main module. added ! +! option of user provided permutation seeds that could ! +! be randomly generated from forecast time stamp. ! +! mar 2009, yu-tai hou -- replaced random number generator ! +! programs coming from the original code with the ncep ! +! w3 library to simplify the program and moved sub-col ! +! cloud subroutines inside the main module. added ! +! option of user provided permutation seeds that could ! +! be randomly generated from forecast time stamp. ! +! nov 2009, yu-tai hou -- updated to aer v3.7-v3.8 version. ! +! notice the input cloud ice/liquid are assumed as ! +! in-cloud quantities, not grid average quantities. ! +! aug 2010, yu-tai hou -- uptimized code to improve efficiency +! splited subroutine spcvrt into two subs, spcvrc and ! +! spcvrm, to handling non-mcica and mcica type of calls.! +! apr 2012, b. ferrier and y. hou -- added conversion factor to fu's! +! cloud-snow optical property scheme. ! +! jul 2012, s. moorthi and Y. hou -- eliminated the pointer array ! +! in subr 'spcvrt' for multi-threading issue running ! +! under intel's fortran compiler. ! +! nov 2012, yu-tai hou -- modified control parameters thru ! +! module 'physparam'. ! +! jun 2013, yu-tai hou -- moving band 9 surface treatment ! +! back as in the rrtm2 version, spliting surface flux ! +! into two spectral regions (vis & nir), instead of ! +! designated it in nir region only. ! +! may 2016 yu-tai hou --reverting swflux name back to vrtqdr! +! jun 2018 yu-tai hou --updated cloud optical coeffs with ! +! aer's newer version v3.9-v4.0 for hu and stamnes ! +! scheme. (used if iswcliq=2); added new option of ! +! cloud overlap method 'de-correlation-length'. ! +! ! +!!!!! ============================================================== !!!!! +!!!!! end descriptions !!!!! +!!!!! ============================================================== !!!!! + +!> This module contains the CCPP-compliant NCEP's modifications of the rrtm-sw radiation +!! code from aer inc. + module rrtmg_sw +! + use physparam, only : iswrate, iswrgas, iswcice, & !mz: iswcliq + & icldflg, ivflip, & + & iswmode + use physcons, only : con_g, con_cp, con_avgd, con_amd, & + & con_amw, con_amo3 + use machine, only : rb => kind_phys, im => kind_io4, & + & kind_phys + + use module_radsw_parameters + use mersenne_twister, only : random_setseed, random_number, & + & random_stat + use module_radsw_ref, only : preflog, tref + use module_radsw_sflux +! + implicit none +! + private +! +! --- version tag and last revision date + character(40), parameter :: & + & VTAGSW='NCEP SW v5.1 Nov 2012 -RRTMG-SW v3.8 ' +! & VTAGSW='NCEP SW v5.0 Aug 2012 -RRTMG-SW v3.8 ' +! & VTAGSW='RRTMG-SW v3.8 Nov 2009' +! & VTAGSW='RRTMG-SW v3.7 Nov 2009' +! & VTAGSW='RRTMG-SW v3.61 Oct 2008' +! & VTAGSW='RRTMG-SW v3.5 Oct 2008' +! & VTAGSW='RRTM-SW 112v2.3 Apr 2007' +! & VTAGSW='RRTM-SW 112v2.3 Mar 2005' +! & VTAGSW='RRTM-SW 112v2.0 Jul 2004' + +! \name constant values + + real (kind=kind_phys), parameter :: eps = 1.0e-6 + real (kind=kind_phys), parameter :: oneminus= 1.0 - eps +! pade approx constant + real (kind=kind_phys), parameter :: bpade = 1.0/0.278 + real (kind=kind_phys), parameter :: stpfac = 296.0/1013.0 + real (kind=kind_phys), parameter :: ftiny = 1.0e-12 + real (kind=kind_phys), parameter :: flimit = 1.0e-20 +! internal solar constant + real (kind=kind_phys), parameter :: s0 = 1368.22 + + real (kind=kind_phys), parameter :: f_zero = 0.0 + real (kind=kind_phys), parameter :: f_one = 1.0 + +! \name atomic weights for conversion from mass to volume mixing ratios + real (kind=kind_phys), parameter :: amdw = con_amd/con_amw + real (kind=kind_phys), parameter :: amdo3 = con_amd/con_amo3 + +! \name band indices + integer, dimension(nblow:nbhgh) :: nspa, nspb +! band index for sfc flux + integer, dimension(nblow:nbhgh) :: idxsfc +! band index for cld prop + integer, dimension(nblow:nbhgh) :: idxebc + + data nspa(:) / 9, 9, 9, 9, 1, 9, 9, 1, 9, 1, 0, 1, 9, 1 / + data nspb(:) / 1, 5, 1, 1, 1, 5, 1, 0, 1, 0, 0, 1, 5, 1 / + +! data idxsfc(:) / 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 1 / ! band index for sfc flux + data idxsfc(:) / 1, 1, 1, 1, 1, 1, 1, 1, 0, 2, 2, 2, 2, 1 / ! band index for sfc flux + data idxebc(:) / 5, 5, 4, 4, 3, 3, 2, 2, 1, 1, 1, 1, 1, 5 / ! band index for cld prop + +! --- band wavenumber intervals +! real (kind=kind_phys), dimension(nblow:nbhgh):: wavenum1,wavenum2 +! data wavenum1(:) / & +! & 2600.0, 3250.0, 4000.0, 4650.0, 5150.0, 6150.0, 7700.0, & +! & 8050.0,12850.0,16000.0,22650.0,29000.0,38000.0, 820.0 / +! data wavenum2(:) / & +! 3250.0, 4000.0, 4650.0, 5150.0, 6150.0, 7700.0, 8050.0, & +! & 12850.0,16000.0,22650.0,29000.0,38000.0,50000.0, 2600.0 / +! real (kind=kind_phys), dimension(nblow:nbhgh) :: delwave +! data delwave(:) / & +! & 650.0, 750.0, 650.0, 500.0, 1000.0, 1550.0, 350.0, & +! & 4800.0, 3150.0, 6650.0, 6350.0, 9000.0,12000.0, 1780.0 / + +! uv-b band index + integer, parameter :: nuvb = 27 + +!\name logical flags for optional output fields + logical :: lhswb = .false. + logical :: lhsw0 = .false. + logical :: lflxprf= .false. + logical :: lfdncmp= .false. + + +! those data will be set up only once by "rswinit" + real (kind=kind_phys) :: exp_tbl(0:NTBMX) + + +! the factor for heating rates (in k/day, or k/sec set by subroutine +!! 'rswinit') + real (kind=kind_phys) :: heatfac + + +! initial permutation seed used for sub-column cloud scheme + integer, parameter :: ipsdsw0 = 1 + +! --- public accessable subprograms + + public rrtmg_sw_init, rrtmg_sw_run, rrtmg_sw_finalize, rswinit, & + & kissvec, generate_stochastic_clouds_sw,mcica_subcol_sw + + +! ================= + contains +! ================= + + subroutine rrtmg_sw_init () + end subroutine rrtmg_sw_init + +!> \defgroup module_radsw_main GFS RRTMG Shortwave Module +!! This module includes NCEP's modifications of the RRTMG-SW radiation +!! code from AER. +!! +!! The SW radiation model in the current NOAA Environmental Modeling +!! System (NEMS) was adapted from the RRTM radiation model developed by +!! AER Inc. (\cite clough_et_al_2005; \cite mlawer_et_al_1997). It contains 14 +!! spectral bands spanning a spectral wavenumber range of +!! \f$50000-820 cm^{-1}\f$ (corresponding to a wavelength range +!! \f$0.2-12.2\mu m\f$), each spectral band focuses on a specific set of +!! atmospheric absorbing species as shown in Table 1. To achieve great +!! computation efficiency while at the same time to maintain a high +!! degree of accuracy, the RRTM radiation model employs a corrected-k +!! distribution method (i.e. mapping the highly spectral changing +!! absorption coefficient, k, into a monotonic and smooth varying +!! cumulative probability function, g). In the RRTM-SW, there are 16 +!! unevenly distributed g points for each of the 14 bands for a total +!! of 224 g points. The GCM version of the code (RRTMG-SW) uses a reduced +!! number (various between 2 to 16) of g points for each of the bands +!! that totals to 112 instead of the full set of 224. To get high +!! quality for the scheme, many advanced techniques are used in RRTM +!! such as carefully selecting the band structure to handle various +!! major (key-species) and minor absorbers; deriving a binary parameter +!! for a paired key molecular species in the same domain; and using two +!! pressure regions (dividing level is at about 96mb) for optimal +!! treatment of various species, etc. +!!\tableofcontents +!! Table 1. RRTMG-SW spectral bands and the corresponding absorbing species +!! |Band #| Wavenumber Range | Lower Atm (Key)| Lower Atm (Minor)| Mid/Up Atm (Key)| Mid/Up Atm (Minor)| +!! |------|------------------|----------------|------------------|-----------------|-------------------| +!! | 16 | 2600-3250 |H2O,CH4 | |CH4 | | +!! | 17 | 3250-4000 |H2O,CO2 | |H2O,CO2 | | +!! | 18 | 4000-4650 |H2O,CH4 | |CH4 | | +!! | 19 | 4650-5150 |H2O,CO2 | |CO2 | | +!! | 20 | 5150-6150 |H2O |CH4 |H2O |CH4 | +!! | 21 | 6150-7700 |H2O,CO2 | |H2O,CO2 | | +!! | 22 | 7700-8050 |H2O,O2 | |O2 | | +!! | 23 | 8050-12850 |H2O | |--- | | +!! | 24 | 12850-16000 |H2O,O2 |O3 |O2 |O3 | +!! | 25 | 16000-22650 |H2O |O3 |--- |O3 | +!! | 26 | 22650-29000 |--- | |--- | | +!! | 27 | 29000-38000 |O3 | |O3 | | +!! | 28 | 38000-50000 |O3,O2 | |O3,O2 | | +!! | 29 | 820-2600 |H2O |CO2 |CO2 |H2O | +!!\tableofcontents +!! +!! The RRTM-SW package includes three files: +!! - radsw_param.f, which contains: +!! - module_radsw_parameters: specifies major parameters of the spectral +!! bands and defines the construct structures of derived-type variables +!! for holding the output results. +!! - radsw_datatb.f, which contains: +!! - module_radsw_ref: reference temperature and pressure +!! - module_radsw_cldprtb: cloud property coefficients table +!! - module_radsw_sflux: indexes and coefficients for spectral +!! distribution of solar flux +!! - module_radsw_kgbnn: absorption coefficents for 14 bands, where +!! nn = 16-29 +!! - radsw_main.f, which contains: +!! - rrtmg_sw_run(): the main SW radiation routine +!! - rswinit(): the initialization routine +!! +!!\author Eli J. Mlawer, emlawer@aer.com +!!\author Jennifer S. Delamere, jdelamer@aer.com +!!\author Michael J. Iacono, miacono@aer.com +!!\author Shepard A. Clough +!!\version NCEP SW v5.1 Nov 2012 -RRTMG-SW v3.8 +!! +!! The authors wish to acknowledge the contributions of the +!! following people: Steven J. Taubman, Karen Cady-Pereira, +!! Patrick D. Brown, Ronald E. Farren, Luke Chen, Robert Bergstrom. +!! +!!\copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). +!! This software may be used, copied, or redistributed as long as it is +!! not sold and this copyright notice is reproduced on each copy made. +!! This model is provided as is without any express or implied warranties. +!! (http://www.rtweb.aer.com/) +!! +!> \section arg_table_rrtmg_sw_run Argument Table +!! \htmlinclude rrtmg_sw_run.html +!! +!> \section gen_swrad RRTMG Shortwave Radiation Scheme General Algorithm +!> @{ +!----------------------------------- + subroutine rrtmg_sw_run & + & ( plyr,plvl,tlyr,tlvl,qlyr,olyr, & + & gasvmr_co2,gasvmr_n2o,gasvmr_ch4,gasvmr_o2,gasvmr_co, & + & gasvmr_cfc11,gasvmr_cfc12,gasvmr_cfc22,gasvmr_ccl4, & ! --- inputs + & icseed, aeraod, aerssa, aerasy, & + & sfcalb_nir_dir, sfcalb_nir_dif, & + & sfcalb_uvis_dir, sfcalb_uvis_dif, & + & dzlyr,delpin,de_lgth, iswcliq, iovrsw, isubcsw, & + & cosz,solcon,NDAY,idxday, & + & npts, nlay, nlp1, lprnt, & + & cld_cf, lsswr, & + & hswc,topflx,sfcflx,cldtau, & ! --- outputs + & HSW0,HSWB,FLXPRF,FDNCMP, & ! --- optional + & cld_lwp, cld_ref_liq, cld_iwp, cld_ref_ice, & + & cld_rwp,cld_ref_rain, cld_swp, cld_ref_snow, & + & cld_od, cld_ssa, cld_asy,mpirank,mpiroot, errmsg, errflg ) + +! ==================== defination of variables ==================== ! +! ! +! input variables: ! +! plyr (npts,nlay) : model layer mean pressure in mb ! +! plvl (npts,nlp1) : model level pressure in mb ! +! tlyr (npts,nlay) : model layer mean temperature in k ! +! tlvl (npts,nlp1) : model level temperature in k (not in use) ! +! qlyr (npts,nlay) : layer specific humidity in gm/gm *see inside ! +! olyr (npts,nlay) : layer ozone concentration in gm/gm ! +! gasvmr(npts,nlay,:): atmospheric constent gases: ! +! (check module_radiation_gases for definition) ! +! gasvmr(:,:,1) - co2 volume mixing ratio ! +! gasvmr(:,:,2) - n2o volume mixing ratio ! +! gasvmr(:,:,3) - ch4 volume mixing ratio ! +! gasvmr(:,:,4) - o2 volume mixing ratio ! +! gasvmr(:,:,5) - co volume mixing ratio (not used) ! +! gasvmr(:,:,6) - cfc11 volume mixing ratio (not used) ! +! gasvmr(:,:,7) - cfc12 volume mixing ratio (not used) ! +! gasvmr(:,:,8) - cfc22 volume mixing ratio (not used) ! +! gasvmr(:,:,9) - ccl4 volume mixing ratio (not used) ! +! clouds(npts,nlay,:): cloud profile ! +! (check module_radiation_clouds for definition) ! +! clouds(:,:,1) - layer total cloud fraction ! +! clouds(:,:,2) - layer in-cloud liq water path (g/m**2) ! +! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! +! clouds(:,:,4) - layer in-cloud ice water path (g/m**2) ! +! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! +! clouds(:,:,6) - layer rain drop water path (g/m**2) ! +! clouds(:,:,7) - mean eff radius for rain drop (micron) ! +! clouds(:,:,8) - layer snow flake water path (g/m**2) ! +! clouds(:,:,9) - mean eff radius for snow flake (micron) ! +! icseed(npts) : auxiliary special cloud related array ! +! when module variable isubcsw=2, it provides ! +! permutation seed for each column profile that ! +! are used for generating random numbers. ! +! when isubcsw /=2, it will not be used. ! +! aerosols(npts,nlay,nbdsw,:) : aerosol optical properties ! +! (check module_radiation_aerosols for definition) ! +! (:,:,:,1) - optical depth ! +! (:,:,:,2) - single scattering albedo ! +! (:,:,:,3) - asymmetry parameter ! +! sfcalb(npts, : ) : surface albedo in fraction ! +! (check module_radiation_surface for definition) ! +! ( :, 1 ) - near ir direct beam albedo ! +! ( :, 2 ) - near ir diffused albedo ! +! ( :, 3 ) - uv+vis direct beam albedo ! +! ( :, 4 ) - uv+vis diffused albedo ! +! dzlyr(npts,nlay) : layer thickness in km ! +! delpin(npts,nlay): layer pressure thickness (mb) ! +! de_lgth(npts) : clouds decorrelation length (km) ! +! cosz (npts) : cosine of solar zenith angle ! +! solcon : solar constant (w/m**2) ! +! NDAY : num of daytime points ! +! idxday(npts) : index array for daytime points ! +! npts : number of horizontal points ! +! nlay,nlp1 : vertical layer/lavel numbers ! +! lprnt : logical check print flag ! +! ! +! output variables: ! +! hswc (npts,nlay): total sky heating rates (k/sec or k/day) ! +! topflx(npts) : radiation fluxes at toa (w/m**2), components: ! +! (check module_radsw_parameters for definition) ! +! upfxc - total sky upward flux at toa ! +! dnflx - total sky downward flux at toa ! +! upfx0 - clear sky upward flux at toa ! +! sfcflx(npts) : radiation fluxes at sfc (w/m**2), components: ! +! (check module_radsw_parameters for definition) ! +! upfxc - total sky upward flux at sfc ! +! dnfxc - total sky downward flux at sfc ! +! upfx0 - clear sky upward flux at sfc ! +! dnfx0 - clear sky downward flux at sfc ! +! cldtau(npts,nlay): spectral band layer cloud optical depth (~0.55 mu) +! ! +!!optional outputs variables: ! +! hswb(npts,nlay,nbdsw): spectral band total sky heating rates ! +! hsw0 (npts,nlay): clear sky heating rates (k/sec or k/day) ! +! flxprf(npts,nlp1): level radiation fluxes (w/m**2), components: ! +! (check module_radsw_parameters for definition) ! +! dnfxc - total sky downward flux at interface ! +! upfxc - total sky upward flux at interface ! +! dnfx0 - clear sky downward flux at interface ! +! upfx0 - clear sky upward flux at interface ! +! fdncmp(npts) : component surface downward fluxes (w/m**2): ! +! (check module_radsw_parameters for definition) ! +! uvbfc - total sky downward uv-b flux at sfc ! +! uvbf0 - clear sky downward uv-b flux at sfc ! +! nirbm - downward surface nir direct beam flux ! +! nirdf - downward surface nir diffused flux ! +! visbm - downward surface uv+vis direct beam flux ! +! visdf - downward surface uv+vis diffused flux ! +! ! +! external module variables: (in physparam) ! +! iswrgas - control flag for rare gases (ch4,n2o,o2, etc.) ! +! =0: do not include rare gases ! +! >0: include all rare gases ! +! iswcliq - control flag for liq-cloud optical properties ! +! =0: input cloud optical depth, fixed ssa, asy ! +! =1: use hu and stamnes(1993) method for liq cld ! +! =2: use updated coeffs for hu and stamnes scheme ! +! iswcice - control flag for ice-cloud optical properties ! +! *** if iswcliq==0, iswcice is ignored ! +! =1: use ebert and curry (1992) scheme for ice clouds ! +! =2: use streamer v3.0 (2001) method for ice clouds ! +! =3: use fu's method (1996) for ice clouds ! +! iswmode - control flag for 2-stream transfer scheme ! +! =1; delta-eddington (joseph et al., 1976) ! +! =2: pifm (zdunkowski et al., 1980) ! +! =3: discrete ordinates (liou, 1973) ! +! isubcsw - sub-column cloud approximation control flag ! +! =0: no sub-col cld treatment, use grid-mean cld quantities ! +! =1: mcica sub-col, prescribed seeds to get random numbers ! +! =2: mcica sub-col, providing array icseed for random numbers! +! iovrsw - cloud overlapping control flag ! +! =0: random overlapping clouds ! +! =1: maximum/random overlapping clouds ! +! =2: maximum overlap cloud ! +! =3: decorrelation-length overlap clouds ! +! =4: exponential overlapping clouds +! ivflip - control flg for direction of vertical index ! +! =0: index from toa to surface ! +! =1: index from surface to toa ! +! ! +! module parameters, control variables: ! +! nblow,nbhgh - lower and upper limits of spectral bands ! +! maxgas - maximum number of absorbing gaseous ! +! ngptsw - total number of g-point subintervals ! +! ng## - number of g-points in band (##=16-29) ! +! ngb(ngptsw) - band indices for each g-point ! +! bpade - pade approximation constant (1/0.278) ! +! nspa,nspb(nblow:nbhgh) ! +! - number of lower/upper ref atm's per band ! +! ipsdsw0 - permutation seed for mcica sub-col clds ! +! ! +! major local variables: ! +! pavel (nlay) - layer pressures (mb) ! +! delp (nlay) - layer pressure thickness (mb) ! +! tavel (nlay) - layer temperatures (k) ! +! coldry (nlay) - dry air column amount ! +! (1.e-20*molecules/cm**2) ! +! cldfrc (nlay) - layer cloud fraction (norm by tot cld) ! +! cldfmc (nlay,ngptsw) - layer cloud fraction for g-point ! +! taucw (nlay,nbdsw) - cloud optical depth ! +! ssacw (nlay,nbdsw) - cloud single scattering albedo (weighted) ! +! asycw (nlay,nbdsw) - cloud asymmetry factor (weighted) ! +! tauaer (nlay,nbdsw) - aerosol optical depths ! +! ssaaer (nlay,nbdsw) - aerosol single scattering albedo ! +! asyaer (nlay,nbdsw) - aerosol asymmetry factor ! +! colamt (nlay,maxgas) - column amounts of absorbing gases ! +! 1 to maxgas are for h2o, co2, o3, n2o, ! +! ch4, o2, co, respectively (mol/cm**2) ! +! facij (nlay) - indicator of interpolation factors ! +! =0/1: indicate lower/higher temp & height ! +! selffac(nlay) - scale factor for self-continuum, equals ! +! (w.v. density)/(atm density at 296K,1013 mb) ! +! selffrac(nlay) - factor for temp interpolation of ref ! +! self-continuum data ! +! indself(nlay) - index of the lower two appropriate ref ! +! temp for the self-continuum interpolation ! +! forfac (nlay) - scale factor for w.v. foreign-continuum ! +! forfrac(nlay) - factor for temp interpolation of ref ! +! w.v. foreign-continuum data ! +! indfor (nlay) - index of the lower two appropriate ref ! +! temp for the foreign-continuum interp ! +! laytrop - layer at which switch is made from one ! +! combination of key species to another ! +! jp(nlay),jt(nlay),jt1(nlay) ! +! - lookup table indexes ! +! flxucb(nlp1,nbdsw) - spectral bnd total-sky upward flx (w/m2) ! +! flxdcb(nlp1,nbdsw) - spectral bnd total-sky downward flx (w/m2)! +! flxu0b(nlp1,nbdsw) - spectral bnd clear-sky upward flx (w/m2) ! +! flxd0b(nlp1,nbdsw) - spectral b d clear-sky downward flx (w/m2)! +! ! +! ! +! ===================== end of definitions ==================== ! + +! --- inputs: + integer, intent(in) :: npts, nlay, nlp1, NDAY + integer, intent(in) :: iswcliq,iovrsw,isubcsw + + integer, dimension(:), intent(in) :: idxday, icseed + + logical, intent(in) :: lprnt, lsswr + + real (kind=kind_phys), dimension(npts,nlp1), intent(in) :: & + & plvl, tlvl + real (kind=kind_phys), dimension(npts,nlay), intent(in) :: & + & plyr, tlyr, qlyr, olyr, dzlyr, delpin + + real (kind=kind_phys),dimension(npts),intent(in):: sfcalb_nir_dir + real (kind=kind_phys),dimension(npts),intent(in):: sfcalb_nir_dif + real (kind=kind_phys),dimension(npts),intent(in):: sfcalb_uvis_dir + real (kind=kind_phys),dimension(npts),intent(in):: sfcalb_uvis_dif + + real(kind=kind_phys),dimension(npts,nlay),intent(in)::gasvmr_co2 + real(kind=kind_phys),dimension(npts,nlay),intent(in)::gasvmr_n2o + real(kind=kind_phys),dimension(npts,nlay),intent(in)::gasvmr_ch4 + real(kind=kind_phys),dimension(npts,nlay),intent(in)::gasvmr_o2 + real(kind=kind_phys),dimension(npts,nlay),intent(in)::gasvmr_co + real(kind=kind_phys),dimension(npts,nlay),intent(in)::gasvmr_cfc11 + real(kind=kind_phys),dimension(npts,nlay),intent(in)::gasvmr_cfc12 + real(kind=kind_phys),dimension(npts,nlay),intent(in)::gasvmr_cfc22 + real(kind=kind_phys),dimension(npts,nlay),intent(in)::gasvmr_ccl4 + + real (kind=kind_phys), dimension(npts,nlay),intent(in):: cld_cf + real (kind=kind_phys), dimension(npts,nlay),intent(in),optional:: & + & cld_lwp, cld_ref_liq, cld_iwp, cld_ref_ice, & + & cld_rwp, cld_ref_rain, cld_swp, cld_ref_snow, & + & cld_od, cld_ssa, cld_asy + + real(kind=kind_phys),dimension(npts,nlay,nbdsw),intent(in)::aeraod + real(kind=kind_phys),dimension(npts,nlay,nbdsw),intent(in)::aerssa + real(kind=kind_phys),dimension(npts,nlay,nbdsw),intent(in)::aerasy + + real (kind=kind_phys), intent(in) :: cosz(npts), solcon, & + & de_lgth(npts) + + integer, intent(in) :: mpirank,mpiroot +! --- outputs: + real (kind=kind_phys), dimension(npts,nlay), intent(inout) :: hswc + real (kind=kind_phys), dimension(npts,nlay), intent(inout) :: & + & cldtau + + type (topfsw_type), dimension(npts), intent(inout) :: topflx + type (sfcfsw_type), dimension(npts), intent(inout) :: sfcflx + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +!! --- optional outputs: + real (kind=kind_phys), dimension(npts,nlay,nbdsw), optional, & + & intent(inout) :: hswb + + real (kind=kind_phys), dimension(npts,nlay), optional, & + & intent(inout) :: hsw0 + type (profsw_type), dimension(npts,nlp1), optional, & + & intent(inout) :: flxprf + type (cmpfsw_type), dimension(npts), optional, & + & intent(inout) :: fdncmp + +! --- locals: +!mz* HWRF -- input of mcica_subcol_sw + real(kind=kind_phys),dimension(1,nlay) :: hgt + real(kind=kind_phys) :: dzsum + real(kind=kind_phys),dimension( nbdsw, 1, nlay ) :: taucld3, & + ssacld3, & + asmcld3, & + fsfcld3 + +!mz* HWRF -- OUTPUT from mcica_subcol_sw + real(kind=kind_phys),dimension(ngptsw,npts,nlay) :: cldfmcl ! Cloud fraction + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=kind_phys),dimension(ngptsw,npts,nlay) :: ciwpmcl ! In-cloud ice water path (g/m2) + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=kind_phys),dimension(ngptsw,npts,nlay) :: clwpmcl ! In-cloud liquid water path (g/m2) + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=kind_phys),dimension(ngptsw,npts,nlay) :: cswpmcl ! In-cloud snow water path (g/m2) + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=kind_phys),dimension(npts,nlay) :: relqmcl ! Cloud water drop effective radius (microns) + ! Dimensions: (ncol,nlay) + real(kind=kind_phys),dimension(npts,nlay) :: reicmcl ! Cloud ice effective size (microns) + ! Dimensions: (ncol,nlay) + real(kind=kind_phys),dimension(npts,nlay) :: resnmcl ! Snow effective size (microns) + ! Dimensions: (ncol,nlay) + real(kind=kind_phys),dimension(ngptsw,npts,nlay) :: taucmcl ! In-cloud optical depth + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=kind_phys),dimension(ngptsw,npts,nlay) :: ssacmcl ! in-cloud single scattering albedo [mcica] + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=kind_phys),dimension(ngptsw,npts,nlay) :: asmcmcl ! in-cloud asymmetry parameter [mcica] + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=kind_phys),dimension(ngptsw,npts,nlay) :: fsfcmcl ! in-cloud forward scattering fraction [mcica] + ! Dimensions: (ngptsw,ncol,nlay) +!HWRF cldprmc_sw input +! real(kind=kind_phys),dimension(ngptsw,nlay) :: cldfmc,cldfmc_save! cloud fraction [mcica] +! ! Dimensions: (ngptsw,nlayers) + real(kind=kind_phys),dimension(ngptsw,nlay) :: ciwpmc ! cloud ice water path [mcica] + ! Dimensions: (ngptsw,nlayers) + real(kind=kind_phys),dimension(ngptsw,nlay) :: clwpmc ! cloud liquid water path [mcica] + ! Dimensions: (ngptsw,nlayers) + real(kind=kind_phys),dimension(ngptsw,nlay) :: cswpmc ! cloud snow water path [mcica] + ! Dimensions: (ngptsw,nlayers) + real(kind=kind_phys),dimension(nlay) :: resnmc ! cloud snow particle effective radius (microns) + ! Dimensions: (nlayers) + real(kind=kind_phys),dimension(nlay) :: relqmc ! cloud liquid particle effective radius (microns) + ! Dimensions: (nlayers) + real(kind=kind_phys),dimension(nlay) :: reicmc ! cloud ice particle effective radius (microns) + ! Dimensions: (nlayers) + ! specific definition of reicmc depends on setting of iceflag: + ! iceflag = 1: ice effective radius, r_ec, (Ebert and Curry, 1992), + ! r_ec range is limited to 13.0 to 130.0 microns + ! iceflag = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996) + ! r_k range is limited to 5.0 to 131.0 microns + ! iceflag = 3: generalized effective size, dge, (Fu, 1996), + ! dge range is limited to 5.0 to 140.0 microns + ! [dge = 1.0315 * r_ec] + real(kind=kind_phys),dimension(ngptsw,nlay) :: fsfcmc ! cloud forward scattering fraction + ! Dimensions: (ngptsw,nlayers) + +!mz* HWRF cldprmc_sw output (delta scaled) + real(kind=kind_phys),dimension(ngptsw,nlay) :: taucmc ! cloud optical depth (delta scaled) + ! Dimensions: (ngptsw,nlayers) + real(kind=kind_phys),dimension(ngptsw,nlay) :: ssacmc ! single scattering albedo (delta scaled) + ! Dimensions: (ngptsw,nlayers) + real(kind=kind_phys),dimension(ngptsw,nlay) :: asmcmc ! asymmetry parameter (delta scaled) + ! Dimensions: (ngptsw,nlayers) + real(kind=kind_phys),dimension(ngptsw,nlay) :: taormc ! cloud optical depth (non-delta scaled) + ! Dimensions: (ngptsw,nlayers) +!mz* + + real (kind=kind_phys), dimension(nlay,ngptsw) :: cldfmc, & + & cldfmc_save, & + & taug, taur + real (kind=kind_phys), dimension(nlp1,nbdsw):: fxupc, fxdnc, & + & fxup0, fxdn0 + + real (kind=kind_phys), dimension(nlay,nbdsw) :: & + & tauae, ssaae, asyae, taucw, ssacw, asycw + + real (kind=kind_phys), dimension(ngptsw) :: sfluxzen + + real (kind=kind_phys), dimension(nlay) :: cldfrc, delp, & + & pavel, tavel, coldry, colmol, h2ovmr, o3vmr, temcol, & + & cliqp, reliq, cicep, reice, cdat1, cdat2, cdat3, cdat4, & + & cfrac, fac00, fac01, fac10, fac11, forfac, forfrac, & + & selffac, selffrac, rfdelp, dz + + real (kind=kind_phys), dimension(nlp1) :: fnet, flxdc, flxuc, & + & flxd0, flxu0 + + real (kind=kind_phys), dimension(2) :: albbm, albdf, sfbmc, & + & sfbm0, sfdfc, sfdf0 + + real (kind=kind_phys) :: cosz1, sntz1, tem0, tem1, tem2, s0fac, & + & ssolar, zcf0, zcf1, ftoau0, ftoauc, ftoadc, & + & fsfcu0, fsfcuc, fsfcd0, fsfcdc, suvbfc, suvbf0, delgth + +! --- column amount of absorbing gases: +! (:,m) m = 1-h2o, 2-co2, 3-o3, 4-n2o, 5-ch4, 6-o2, 7-co + real (kind=kind_phys) :: colamt(nlay,maxgas) + + integer, dimension(npts) :: ipseed + integer, dimension(nlay) :: indfor, indself, jp, jt, jt1 + + integer :: i, ib, ipt, j1, k, kk, laytrop, mb,ig + integer :: inflgsw, iceflgsw, liqflgsw + integer :: irng, permuteseed +! +!===> ... begin here +! + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + +! Select cloud liquid and ice optics parameterization options +! For passing in cloud optical properties directly: +! inflgsw = 0 +! iceflgsw = 0 +! liqflgsw = 0 +! For passing in cloud physical properties; cloud optics parameterized in RRTMG: + inflgsw = 2 + iceflgsw = 3 + liqflgsw = 1 +! + if (.not. lsswr) return + if (nday <= 0) return + + lhswb = present ( hswb ) + lhsw0 = present ( hsw0 ) + lflxprf= present ( flxprf ) + lfdncmp= present ( fdncmp ) + +!> -# Compute solar constant adjustment factor (s0fac) according to solcon. +! *** s0, the solar constant at toa in w/m**2, is hard-coded with +! each spectra band, the total flux is about 1368.22 w/m**2. + + s0fac = solcon / s0 + +!> -# Initial output arrays (and optional) as zero. + + hswc(:,:) = f_zero + cldtau(:,:) = f_zero + topflx = topfsw_type ( f_zero, f_zero, f_zero ) + sfcflx = sfcfsw_type ( f_zero, f_zero, f_zero, f_zero ) + +!! --- ... initial optional outputs + if ( lflxprf ) then + flxprf = profsw_type ( f_zero, f_zero, f_zero, f_zero ) + endif + + if ( lfdncmp ) then + fdncmp = cmpfsw_type (f_zero,f_zero,f_zero,f_zero,f_zero,f_zero) + endif + + if ( lhsw0 ) then + hsw0(:,:) = f_zero + endif + + if ( lhswb ) then + hswb(:,:,:) = f_zero + endif + +!! --- check for optional input arguments, depending on cloud method + if (iswcliq > 0) then ! use prognostic cloud method + if ( .not.present(cld_lwp) .or. .not.present(cld_ref_liq) .or. & + & .not.present(cld_iwp) .or. .not.present(cld_ref_ice) .or. & + & .not.present(cld_rwp) .or. .not.present(cld_ref_rain) .or. & + & .not.present(cld_swp) .or. .not.present(cld_ref_snow) )then + write(errmsg,'(*(a))') & + & 'Logic error: iswcliq>0 requires the following', & + & ' optional arguments to be present:', & + & ' cld_lwp, cld_ref_liq, cld_iwp, cld_ref_ice,', & + & ' cld_rwp, cld_ref_rain, cld_swp, cld_ref_snow' + errflg = 1 + return + end if + else ! use diagnostic cloud method + if ( .not.present(cld_od) .or. .not.present(cld_ssa) .or. & + & .not.present(cld_asy)) then + write(errmsg,'(*(a))') & + & 'Logic error: iswcliq<=0 requires the following', & + & ' optional arguments to be present:', & + & ' cld_od, cld_ssa, cld_asy' + errflg = 1 + return + end if + endif ! end if_iswcliq + +!> -# Change random number seed value for each radiation invocation +!! (isubcsw =1 or 2). + + if ( isubcsw == 1 ) then ! advance prescribed permutation seed + do i = 1, npts + ipseed(i) = ipsdsw0 + i + enddo + elseif ( isubcsw == 2 ) then ! use input array of permutaion seeds + do i = 1, npts + ipseed(i) = icseed(i) + enddo + endif + + if ( lprnt ) then + write(0,*)' In radsw, isubcsw, ipsdsw0,ipseed =', & + & isubcsw, ipsdsw0, ipseed + endif + +! --- ... loop over each daytime grid point + + lab_do_ipt : do ipt = 1, NDAY + + j1 = idxday(ipt) + + cosz1 = cosz(j1) + sntz1 = f_one / cosz(j1) + ssolar = s0fac * cosz(j1) + if (iovrsw == 3) delgth = de_lgth(j1) ! clouds decorr-length + +!> -# Prepare surface albedo: bm,df - dir,dif; 1,2 - nir,uvv. + albbm(1) = sfcalb_nir_dir(j1) + albdf(1) = sfcalb_nir_dif(j1) + albbm(2) = sfcalb_uvis_dir(j1) + albdf(2) = sfcalb_uvis_dif(j1) + + +! mz*: HWRF practice + if (iovrsw == 4 ) then + + +!Add layer height needed for exponential (icld=4) and +! exponential-random (icld=5) overlap options + + !iplon = 1 + irng = 0 + permuteseed = 1 + +!mz* Derive height of each layer mid-point from layer thickness. +! Needed for exponential (iovrsw=4) and exponential-random overlap +! option (iovr=5)only. + dzsum =0.0 + do k = 1,nlay + hgt(j1,k)= dzsum+0.5*dzlyr(j1,k)*1000. !km->m + dzsum = dzsum+ dzlyr(j1,k)*1000. + enddo + +! Zero out cloud optical properties here; not used when passing physical properties +! to radiation and taucld is calculated in radiation + do k = 1, nlay + do ib = 1, nbdsw + taucld3(ib,j1,k) = 0.0 + ssacld3(ib,j1,k) = 1.0 + asmcld3(ib,j1,k) = 0.0 + fsfcld3(ib,j1,k) = 0.0 + enddo + enddo + +!mz +! if(mpirank==mpiroot) then +! write(0,*) 'mcica_subcol_sw: max/min(cld_cf)=', & +! & maxval(cld_cf),minval(cld_cf) +! write(0,*) 'mcica_subcol_sw: max/min(cld_iwp)=', & +! & maxval(cld_iwp),minval(cld_iwp) +! write(0,*) 'mcica_subcol_sw: max/min(cld_lwp)=', & +! & maxval(cld_lwp),minval(cld_lwp) +! write(0,*) 'mcica_subcol_sw: max/min(cld_swp)=', & +! & maxval(cld_swp),minval(cld_swp) +! write(0,*) 'mcica_subcol_sw: max/min(cld_ref_ice)=', & +! & maxval(cld_ref_ice),minval(cld_ref_ice) +! write(0,*) 'mcica_subcol_sw: max/min(cld_ref_snow)=', & +! & maxval(cld_ref_snow),minval(cld_ref_snow) +! write(0,*) 'mcica_subcol_sw: max/min(cld_ref_liq)=', & +! & maxval(cld_ref_liq),minval(cld_ref_liq) +! endif + + + call mcica_subcol_sw (1, j1, nlay, iovrsw, permuteseed, & + & irng, plyr, hgt, & + & cld_cf, cld_iwp, cld_lwp,cld_swp, & + & cld_ref_ice, cld_ref_liq, & + & cld_ref_snow, taucld3,ssacld3,asmcld3,fsfcld3, & + & cldfmcl, ciwpmcl, clwpmcl, cswpmcl, & !--output + & reicmcl, relqmcl, resnmcl, & + & taucmcl, ssacmcl, asmcmcl, fsfcmcl) + +!mz +! if(mpirank==mpiroot) then +! write(0,*) 'mcica_subcol_sw: max/min(cldfmcl)=', & +! & maxval(cldfmcl),minval(cldfmcl) +! write(0,*) 'mcica_subcol_sw: max/min(ciwpmcl)=', & +! & maxval(ciwpmcl),minval(ciwpmcl) +! write(0,*) 'mcica_subcol_sw: max/min(clwpmcl)=', & +! & maxval(clwpmcl),minval(clwpmcl) +! write(0,*) 'mcica_subcol_sw: max/min(cswpmcl)=', & +! & maxval(cswpmcl),minval(cswpmcl) +! write(0,*) 'mcica_subcol_sw: max/min(reicmcl)=', & +! & maxval(reicmcl),minval(reicmcl) +! write(0,*) 'mcica_subcol_sw: max/min(relqmcl)=', & +! & maxval(relqmcl),minval(relqmcl) +! write(0,*) 'mcica_subcol_sw: max/min(resnmcl)=', & +! & maxval(resnmcl),minval(resnmcl) +! endif + + endif +!mz* end + +!> -# Prepare atmospheric profile for use in rrtm. +! the vertical index of internal array is from surface to top + + if (ivflip == 0) then ! input from toa to sfc + + tem1 = 100.0 * con_g + tem2 = 1.0e-20 * 1.0e3 * con_avgd + + do k = 1, nlay + kk = nlp1 - k + pavel(k) = plyr(j1,kk) + tavel(k) = tlyr(j1,kk) + delp (k) = delpin(j1,kk) + dz (k) = dzlyr (j1,kk) +!> -# Set absorber and gas column amount, convert from volume mixing +!! ratio to molec/cm2 based on coldry (scaled to 1.0e-20) +!! - colamt(nlay,maxgas):column amounts of absorbing gases 1 to +!! maxgas are for h2o,co2,o3,n2o,ch4,o2,co, respectively +!! (\f$ mol/cm^2 \f$) + +!test use +! h2ovmr(k)= max(f_zero,qlyr(j1,kk)*amdw) ! input mass mixing ratio +! h2ovmr(k)= max(f_zero,qlyr(j1,kk)) ! input vol mixing ratio +! o3vmr (k)= max(f_zero,olyr(j1,kk)) ! input vol mixing ratio +!ncep model use + h2ovmr(k)= max(f_zero,qlyr(j1,kk)*amdw/(f_one-qlyr(j1,kk))) ! input specific humidity + o3vmr (k)= max(f_zero,olyr(j1,kk)*amdo3) ! input mass mixing ratio + + tem0 = (f_one - h2ovmr(k))*con_amd + h2ovmr(k)*con_amw + coldry(k) = tem2 * delp(k) / (tem1*tem0*(f_one + h2ovmr(k))) + temcol(k) = 1.0e-12 * coldry(k) + + colamt(k,1) = max(f_zero, coldry(k)*h2ovmr(k)) ! h2o + colamt(k,2) = max(temcol(k), coldry(k)*gasvmr_co2(j1,kk)) ! co2 + colamt(k,3) = max(f_zero, coldry(k)*o3vmr(k)) ! o3 + colmol(k) = coldry(k) + colamt(k,1) + enddo + +! --- ... set up gas column amount, convert from volume mixing ratio +! to molec/cm2 based on coldry (scaled to 1.0e-20) + + if (iswrgas > 0) then + do k = 1, nlay + kk = nlp1 - k + colamt(k,4) = max(temcol(k), coldry(k)*gasvmr_n2o(j1,kk)) ! n2o + colamt(k,5) = max(temcol(k), coldry(k)*gasvmr_ch4(j1,kk)) ! ch4 + colamt(k,6) = max(temcol(k), coldry(k)*gasvmr_o2(j1,kk)) ! o2 +! colamt(k,7) = max(temcol(k), coldry(k)*gasvmr(j1,kk,5)) ! co - notused + enddo + else + do k = 1, nlay + colamt(k,4) = temcol(k) ! n2o + colamt(k,5) = temcol(k) ! ch4 + colamt(k,6) = temcol(k) ! o2 +! colamt(k,7) = temcol(k) ! co - notused + enddo + endif + +!> -# Read aerosol optical properties from 'aerosols'. + + do k = 1, nlay + kk = nlp1 - k + do ib = 1, nbdsw + tauae(k,ib) = aeraod(j1,kk,ib) + ssaae(k,ib) = aerssa(j1,kk,ib) + asyae(k,ib) = aerasy(j1,kk,ib) + enddo + enddo + +!> -# Read cloud optical properties from 'clouds'. + if (iswcliq > 0) then ! use prognostic cloud method +!mz:GFS operational + !if (iovrsw .eq. 1) then + do k = 1, nlay + kk = nlp1 - k + cfrac(k) = cld_cf(j1,kk) ! cloud fraction + cliqp(k) = cld_lwp(j1,kk) ! cloud liq path + reliq(k) = cld_ref_liq(j1,kk) ! liq partical effctive radius + cicep(k) = cld_iwp(j1,kk) ! cloud ice path + reice(k) = cld_ref_ice(j1,kk) ! ice partical effctive radius + cdat1(k) = cld_rwp(j1,kk) ! cloud rain drop path + cdat2(k) = cld_ref_rain(j1,kk) ! rain partical effctive radius + cdat3(k) = cld_swp(j1,kk) ! cloud snow path + cdat4(k) = cld_ref_snow(j1,kk) ! snow partical effctive radius + enddo + if (iovrsw .eq. 4) then !mz* HWRF + do k = 1, nlay + kk = nlp1 - k + do ig = 1, ngptsw + cldfmc(k,ig) = cldfmcl(ig,j1,kk) + taucmc(ig,k) = taucmcl(ig,j1,kk) + ssacmc(ig,k) = ssacmcl(ig,j1,kk) + asmcmc(ig,k) = asmcmcl(ig,j1,kk) + fsfcmc(ig,k) = fsfcmcl(ig,j1,kk) + ciwpmc(ig,k) = ciwpmcl(ig,j1,kk) + clwpmc(ig,k) = clwpmcl(ig,j1,kk) + if (iceflgsw.eq.5) then + cswpmc(ig,k) = cswpmcl(ig,j1,kk) + endif + enddo + reicmc(k) = reicmcl(j1,kk) + relqmc(k) = relqmcl(j1,kk) + if (iceflgsw.eq.5) then + resnmc(k) = resnmcl(j1,kk) + endif + enddo + endif + else ! use diagnostic cloud method + do k = 1, nlay + kk = nlp1 - k + cfrac(k) = cld_cf(j1,kk) ! cloud fraction + cdat1(k) = cld_od(j1,kk) ! cloud optical depth + cdat2(k) = cld_ssa(j1,kk) ! cloud single scattering albedo + cdat3(k) = cld_asy(j1,kk) ! cloud asymmetry factor + enddo + endif ! end if_iswcliq + + else ! input from sfc to toa + + tem1 = 100.0 * con_g + tem2 = 1.0e-20 * 1.0e3 * con_avgd + + do k = 1, nlay + pavel(k) = plyr(j1,k) + tavel(k) = tlyr(j1,k) + delp (k) = delpin(j1,k) + dz (k) = dzlyr (j1,k) + +! --- ... set absorber amount +!test use +! h2ovmr(k)= max(f_zero,qlyr(j1,k)*amdw) ! input mass mixing ratio +! h2ovmr(k)= max(f_zero,qlyr(j1,k)) ! input vol mixing ratio +! o3vmr (k)= max(f_zero,olyr(j1,k)) ! input vol mixing ratio +!ncep model use + h2ovmr(k)= max(f_zero,qlyr(j1,k)*amdw/(f_one-qlyr(j1,k))) ! input specific humidity + o3vmr (k)= max(f_zero,olyr(j1,k)*amdo3) ! input mass mixing ratio + + tem0 = (f_one - h2ovmr(k))*con_amd + h2ovmr(k)*con_amw + coldry(k) = tem2 * delp(k) / (tem1*tem0*(f_one + h2ovmr(k))) + temcol(k) = 1.0e-12 * coldry(k) + + colamt(k,1) = max(f_zero, coldry(k)*h2ovmr(k)) ! h2o + colamt(k,2) = max(temcol(k), coldry(k)*gasvmr_co2(j1,k)) ! co2 + colamt(k,3) = max(f_zero, coldry(k)*o3vmr(k)) ! o3 + colmol(k) = coldry(k) + colamt(k,1) + enddo + + + if (lprnt) then + if (ipt == 1) then + write(0,*)' pavel=',pavel + write(0,*)' tavel=',tavel + write(0,*)' delp=',delp + write(0,*)' h2ovmr=',h2ovmr*1000 + write(0,*)' o3vmr=',o3vmr*1000000 + endif + endif + +! --- ... set up gas column amount, convert from volume mixing ratio +! to molec/cm2 based on coldry (scaled to 1.0e-20) + + if (iswrgas > 0) then + do k = 1, nlay + colamt(k,4) = max(temcol(k), coldry(k)*gasvmr_n2o(j1,k)) ! n2o + colamt(k,5) = max(temcol(k), coldry(k)*gasvmr_ch4(j1,k)) ! ch4 + colamt(k,6) = max(temcol(k), coldry(k)*gasvmr_o2(j1,k)) ! o2 +! colamt(k,7) = max(temcol(k), coldry(k)*gasvmr(j1,k,5)) ! co - notused + enddo + else + do k = 1, nlay + colamt(k,4) = temcol(k) ! n2o + colamt(k,5) = temcol(k) ! ch4 + colamt(k,6) = temcol(k) ! o2 +! colamt(k,7) = temcol(k) ! co - notused + enddo + endif + +! --- ... set aerosol optical properties + + do ib = 1, nbdsw + do k = 1, nlay + tauae(k,ib) = aeraod(j1,k,ib) + ssaae(k,ib) = aerssa(j1,k,ib) + asyae(k,ib) = aerasy(j1,k,ib) + enddo + enddo + + if (iswcliq > 0) then ! use prognostic cloud method + !if (iovrsw .eq. 1) then !mz* GFS operational + do k = 1, nlay + cfrac(k) = cld_cf(j1,k) ! cloud fraction + cliqp(k) = cld_lwp(j1,k) ! cloud liq path + reliq(k) = cld_ref_liq(j1,k) ! liq partical effctive radius + cicep(k) = cld_iwp(j1,k) ! cloud ice path + reice(k) = cld_ref_ice(j1,k) ! ice partical effctive radius + cdat1(k) = cld_rwp(j1,k) ! cloud rain drop path + cdat2(k) = cld_ref_rain(j1,k) ! rain partical effctive radius + cdat3(k) = cld_swp(j1,k) ! cloud snow path + cdat4(k) = cld_ref_snow(j1,k) ! snow partical effctive radius + enddo + if (iovrsw .eq. 4) then !mz* HWRF +!mz* Move incoming GCM cloud arrays to RRTMG cloud arrays. +!For GCM input, incoming reicmcl is defined based on selected +!ice parameterization (inflglw) + do k = 1, nlay + do ig = 1, ngptsw + cldfmc(k,ig) = cldfmcl(ig,j1,k) + taucmc(ig,k) = taucmcl(ig,j1,k) + ssacmc(ig,k) = ssacmcl(ig,j1,k) + asmcmc(ig,k) = asmcmcl(ig,j1,k) + fsfcmc(ig,k) = fsfcmcl(ig,j1,k) + ciwpmc(ig,k) = ciwpmcl(ig,j1,k) + clwpmc(ig,k) = clwpmcl(ig,j1,k) + if (iceflgsw .eq. 5) then + cswpmc(ig,k) = cswpmcl(ig,j1,k) + endif + enddo + reicmc(k) = reicmcl(j1,k) + relqmc(k) = relqmcl(j1,k) + if (iceflgsw .eq. 5) then + resnmc(k) = resnmcl(j1,k) + endif + enddo + + end if + else ! use diagnostic cloud method + do k = 1, nlay + cfrac(k) = cld_cf(j1,k) ! cloud fraction + cdat1(k) = cld_od(j1,k) ! cloud optical depth + cdat2(k) = cld_ssa(j1,k) ! cloud single scattering albedo + cdat3(k) = cld_asy(j1,k) ! cloud asymmetry factor + enddo + endif ! end if_iswcliq + + endif ! if_ivflip + +!> -# Compute fractions of clear sky view: +!! - random overlapping +!! - max/ran overlapping +!! - maximum overlapping + + zcf0 = f_one + zcf1 = f_one + if (iovrsw == 0) then ! random overlapping + do k = 1, nlay + zcf0 = zcf0 * (f_one - cfrac(k)) + enddo +!mz else if (iovrsw == 1) then ! max/ran overlapping + else if (iovrsw == 1.or. iovrsw == 4) then ! mz* also exponential overlapping + do k = 1, nlay + if (cfrac(k) > ftiny) then ! cloudy layer + zcf1 = min ( zcf1, f_one-cfrac(k) ) + elseif (zcf1 < f_one) then ! clear layer + zcf0 = zcf0 * zcf1 + zcf1 = f_one + endif + enddo + zcf0 = zcf0 * zcf1 + else if (iovrsw >= 2 .and. iovrsw .ne. 4) then + do k = 1, nlay + zcf0 = min ( zcf0, f_one-cfrac(k) ) ! used only as clear/cloudy indicator + enddo + endif + + if (zcf0 <= ftiny) zcf0 = f_zero + if (zcf0 > oneminus) zcf0 = f_one + zcf1 = f_one - zcf0 + +!> -# For cloudy sky column, call cldprop() to compute the cloud +!! optical properties for each cloudy layer. + + !if (iovrsw .eq. 1 ) then + + if (zcf1 > f_zero) then ! cloudy sky column + + !mz* for HWRF, save cldfmc with mcica + if (iovrsw .eq.4) then + do k = 1, nlay + do ig = 1, ngptsw + cldfmc_save(k,ig)=cldfmc (k,ig) + enddo + enddo + endif + + + call cldprop & +! --- inputs: + & ( cfrac,cliqp,reliq,cicep,reice,cdat1,cdat2,cdat3,cdat4, & + & zcf1, nlay, ipseed(j1), dz, delgth,iswcliq,iovrsw,isubcsw, & +! --- outputs: + & taucw, ssacw, asycw, cldfrc, cldfmc & !mz: cldfmc(k,ig) + & ) + + if (iovrsw .eq.4) then + !mz for HWRF, still using mcica cldfmc + do k = 1, nlay + do ig = 1, ngptsw + cldfmc(k,ig)=cldfmc_save(k,ig) + enddo + enddo + endif + +! --- ... save computed layer cloud optical depth for output +! rrtm band 10 is approx to the 0.55 mu spectrum + + if (ivflip == 0) then ! input from toa to sfc + do k = 1, nlay + kk = nlp1 - k + cldtau(j1,kk) = taucw(k,10) + enddo + else ! input from sfc to toa + do k = 1, nlay + cldtau(j1,k) = taucw(k,10) + enddo + endif ! end if_ivflip_block + + else ! clear sky column + cldfrc(:) = f_zero + cldfmc(:,:)= f_zero + do i = 1, nbdsw + do k = 1, nlay + taucw(k,i) = f_zero + ssacw(k,i) = f_zero + asycw(k,i) = f_zero + enddo + enddo + endif ! end if_zcf1_block + +! if (iovrsw .eq. 4) then !mz* HWRF +!! For cloudy atmosphere, use cldprop to set cloud optical properties based on +!! input cloud physical properties. Select method based on choices described +!! in cldprop. Cloud fraction, water path, liquid droplet and ice particle +!! effective radius must be passed in cldprop. Cloud fraction and cloud +!! optical properties are transferred to rrtmg_sw arrays in cldprop. + +! call cldprmc_sw(nlayers, inflg, iceflg, liqflg, cldfmc, & +! ciwpmc, clwpmc, cswpmc, reicmc, relqmc, resnmc, & +! taormc, taucmc, ssacmc, asmcmc, fsfcmc) +! icpr = 1 + +! endif + +!> -# Call setcoef() to compute various coefficients needed in +!! radiative transfer calculations. + call setcoef & +! --- inputs: + & ( pavel,tavel,h2ovmr, nlay,nlp1, & +! --- outputs: + & laytrop,jp,jt,jt1,fac00,fac01,fac10,fac11, & + & selffac,selffrac,indself,forfac,forfrac,indfor & + & ) + +!mz* HWRF clouds +! if(iovrsw .eq.0) then +! zcldfmc(:,:) = 0._rb +! ztaucmc(:,:) = 0._rb +! ztaormc(:,:) = 0._rb +! zasycmc(:,:) = 0._rb +! zomgcmc(:,:) = 1._rb + +! elseif (iovrsw.eq.4) then +! do i=1,nlayers +! do ig=1,ngptsw +! zcldfmc(i,ig) = cldfmc(ig,i) +! ztaucmc(i,ig) = taucmc(ig,i) +! ztaormc(i,ig) = taormc(ig,i) +! zasycmc(i,ig) = asmcmc(ig,i) +! zomgcmc(i,ig) = ssacmc(ig,i) +! enddo +! enddo +!Aerosol +!mz* no aerosol at this moment (iaer .eq.0) +! ztaua(:,:) = 0._rb +! zasya(:,:) = 0._rb +! zomga(:,:) = 1._rb + +! endif +!mz* + +!> -# Call taumol() to calculate optical depths for gaseous absorption +!! and rayleigh scattering + call taumol & +! --- inputs: + & ( colamt,colmol,fac00,fac01,fac10,fac11,jp,jt,jt1,laytrop, & + & forfac,forfrac,indfor,selffac,selffrac,indself, NLAY, & +! --- outputs: + & sfluxzen, taug, taur & + & ) + +!> -# Call the 2-stream radiation transfer model: +!! - if physparam::isubcsw .le.0, using standard cloud scheme, +!! call spcvrtc(). +!! - if physparam::isubcsw .gt.0, using mcica cloud scheme, +!! call spcvrtm(). + + if ( isubcsw <= 0 ) then ! use standard cloud scheme + + call spcvrtc & +! --- inputs: + & ( ssolar,cosz1,sntz1,albbm,albdf,sfluxzen,cldfrc, & + & zcf1,zcf0,taug,taur,tauae,ssaae,asyae,taucw,ssacw,asycw, & + & nlay, nlp1, & +! --- outputs: + & fxupc,fxdnc,fxup0,fxdn0, & + & ftoauc,ftoau0,ftoadc,fsfcuc,fsfcu0,fsfcdc,fsfcd0, & + & sfbmc,sfdfc,sfbm0,sfdf0,suvbfc,suvbf0 & + & ) + + else ! use mcica cloud scheme + +!mz if(iovrsw .eq. 1 ) then ! mz*:GFS operational + + call spcvrtm & +! --- inputs: + & ( ssolar,cosz1,sntz1,albbm,albdf,sfluxzen,cldfmc, & + & zcf1,zcf0,taug,taur,tauae,ssaae,asyae,taucw,ssacw,asycw, & + & nlay, nlp1, & +! --- outputs: + & fxupc,fxdnc,fxup0,fxdn0, & + & ftoauc,ftoau0,ftoadc,fsfcuc,fsfcu0,fsfcdc,fsfcd0, & + & sfbmc,sfdfc,sfbm0,sfdf0,suvbfc,suvbf0 & + & ) + +!mz else if (iovrsw .eq.4 ) then +! call spcvmc_sw & +! (nlayers, istart, iend, icpr, iout, & +! pavel, tavel, pz, tz, tbound, albdif, albdir, & +! zcldfmc, ztaucmc, zasycmc, zomgcmc, ztaormc, & +! ztaua, zasya, zomga, cossza, coldry, wkl, adjflux, & +! laytrop, layswtch, laylow, jp, jt, jt1, & +! co2mult, colch4, colco2, colh2o, colmol, coln2o, colo2, colo3, & +! fac00, fac01, fac10, fac11, & +! selffac, selffrac, indself, forfac, forfrac, indfor, & +! zbbfd, zbbfu, zbbcd, zbbcu, zuvfd, zuvcd, znifd, znicd, & +! zbbfddir, zbbcddir, zuvfddir, zuvcddir, znifddir, znicddir) + + endif + +!> -# Save outputs. +! --- ... sum up total spectral fluxes for total-sky + + do k = 1, nlp1 + flxuc(k) = f_zero + flxdc(k) = f_zero + + do ib = 1, nbdsw + flxuc(k) = flxuc(k) + fxupc(k,ib) + flxdc(k) = flxdc(k) + fxdnc(k,ib) + enddo + enddo + +!! --- ... optional clear sky fluxes + + if ( lhsw0 .or. lflxprf ) then + do k = 1, nlp1 + flxu0(k) = f_zero + flxd0(k) = f_zero + + do ib = 1, nbdsw + flxu0(k) = flxu0(k) + fxup0(k,ib) + flxd0(k) = flxd0(k) + fxdn0(k,ib) + enddo + enddo + endif + +! --- ... prepare for final outputs + + do k = 1, nlay + rfdelp(k) = heatfac / delp(k) + enddo + + if ( lfdncmp ) then +!! --- ... optional uv-b surface downward flux + fdncmp(j1)%uvbf0 = suvbf0 + fdncmp(j1)%uvbfc = suvbfc + +!! --- ... optional beam and diffuse sfc fluxes + fdncmp(j1)%nirbm = sfbmc(1) + fdncmp(j1)%nirdf = sfdfc(1) + fdncmp(j1)%visbm = sfbmc(2) + fdncmp(j1)%visdf = sfdfc(2) + endif ! end if_lfdncmp + +! --- ... toa and sfc fluxes + + topflx(j1)%upfxc = ftoauc + topflx(j1)%dnfxc = ftoadc + topflx(j1)%upfx0 = ftoau0 + + sfcflx(j1)%upfxc = fsfcuc + sfcflx(j1)%dnfxc = fsfcdc + sfcflx(j1)%upfx0 = fsfcu0 + sfcflx(j1)%dnfx0 = fsfcd0 + + if (ivflip == 0) then ! output from toa to sfc + +! --- ... compute heating rates + + fnet(1) = flxdc(1) - flxuc(1) + + do k = 2, nlp1 + kk = nlp1 - k + 1 + fnet(k) = flxdc(k) - flxuc(k) + hswc(j1,kk) = (fnet(k)-fnet(k-1)) * rfdelp(k-1) + enddo + +!! --- ... optional flux profiles + + if ( lflxprf ) then + do k = 1, nlp1 + kk = nlp1 - k + 1 + flxprf(j1,kk)%upfxc = flxuc(k) + flxprf(j1,kk)%dnfxc = flxdc(k) + flxprf(j1,kk)%upfx0 = flxu0(k) + flxprf(j1,kk)%dnfx0 = flxd0(k) + enddo + endif + +!! --- ... optional clear sky heating rates + + if ( lhsw0 ) then + fnet(1) = flxd0(1) - flxu0(1) + + do k = 2, nlp1 + kk = nlp1 - k + 1 + fnet(k) = flxd0(k) - flxu0(k) + hsw0(j1,kk) = (fnet(k)-fnet(k-1)) * rfdelp(k-1) + enddo + endif + +!! --- ... optional spectral band heating rates + + if ( lhswb ) then + do mb = 1, nbdsw + fnet(1) = fxdnc(1,mb) - fxupc(1,mb) + + do k = 2, nlp1 + kk = nlp1 - k + 1 + fnet(k) = fxdnc(k,mb) - fxupc(k,mb) + hswb(j1,kk,mb) = (fnet(k) - fnet(k-1)) * rfdelp(k-1) + enddo + enddo + endif + + else ! output from sfc to toa + +! --- ... compute heating rates + + fnet(1) = flxdc(1) - flxuc(1) + + do k = 2, nlp1 + fnet(k) = flxdc(k) - flxuc(k) + hswc(j1,k-1) = (fnet(k)-fnet(k-1)) * rfdelp(k-1) + enddo + +!! --- ... optional flux profiles + + if ( lflxprf ) then + do k = 1, nlp1 + flxprf(j1,k)%upfxc = flxuc(k) + flxprf(j1,k)%dnfxc = flxdc(k) + flxprf(j1,k)%upfx0 = flxu0(k) + flxprf(j1,k)%dnfx0 = flxd0(k) + enddo + endif + +!! --- ... optional clear sky heating rates + + if ( lhsw0 ) then + fnet(1) = flxd0(1) - flxu0(1) + + do k = 2, nlp1 + fnet(k) = flxd0(k) - flxu0(k) + hsw0(j1,k-1) = (fnet(k)-fnet(k-1)) * rfdelp(k-1) + enddo + endif + +!! --- ... optional spectral band heating rates + + if ( lhswb ) then + do mb = 1, nbdsw + fnet(1) = fxdnc(1,mb) - fxupc(1,mb) + + do k = 1, nlay + fnet(k+1) = fxdnc(k+1,mb) - fxupc(k+1,mb) + hswb(j1,k,mb) = (fnet(k+1) - fnet(k)) * rfdelp(k) + enddo + enddo + endif + + endif ! if_ivflip + + enddo lab_do_ipt + + return +!................................... + end subroutine rrtmg_sw_run +!----------------------------------- +!> @} + + subroutine rrtmg_sw_finalize () + end subroutine rrtmg_sw_finalize + + +!>\ingroup module_radsw_main +!> This subroutine initializes non-varying module variables, conversion +!! factors, and look-up tables. +!!\param me print control for parallel process +!>\section rswinit_gen rswinit General Algorithm +!! @{ +!----------------------------------- + subroutine rswinit & + & (iswcliq,iovrsw,isubcsw, me ) ! --- inputs: +! --- outputs: (none) + +! =================== program usage description =================== ! +! ! +! purpose: initialize non-varying module variables, conversion factors,! +! and look-up tables. ! +! ! +! subprograms called: none ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: ! +! me - print control for parallel process ! +! ! +! outputs: (none) ! +! ! +! external module variables: (in physparam) ! +! iswrate - heating rate unit selections ! +! =1: output in k/day ! +! =2: output in k/second ! +! iswrgas - control flag for rare gases (ch4,n2o,o2, etc.) ! +! =0: do not include rare gases ! +! >0: include all rare gases ! +! iswcliq - liquid cloud optical properties contrl flag ! +! =0: input cloud opt depth from diagnostic scheme ! +! >0: input cwp,rew, and other cloud content parameters ! +! isubcsw - sub-column cloud approximation control flag ! +! =0: no sub-col cld treatment, use grid-mean cld quantities ! +! =1: mcica sub-col, prescribed seeds to get random numbers ! +! =2: mcica sub-col, providing array icseed for random numbers! +! icldflg - cloud scheme control flag ! +! =0: diagnostic scheme gives cloud tau, omiga, and g. ! +! =1: prognostic scheme gives cloud liq/ice path, etc. ! +! iovrsw - clouds vertical overlapping control flag ! +! =0: random overlapping clouds ! +! =1: maximum/random overlapping clouds ! +! =2: maximum overlap cloud ! +! =3: decorrelation-length overlap clouds ! +! iswmode - control flag for 2-stream transfer scheme ! +! =1; delta-eddington (joseph et al., 1976) ! +! =2: pifm (zdunkowski et al., 1980) ! +! =3: discrete ordinates (liou, 1973) ! +! ! +! ******************************************************************* ! +! ! +! definitions: ! +! arrays for 10000-point look-up tables: ! +! tau_tbl clear-sky optical depth ! +! exp_tbl exponential lookup table for transmittance ! +! ! +! ******************************************************************* ! +! ! +! ====================== end of description block ================= ! + +! --- inputs: + integer, intent(in) :: me,isubcsw,iswcliq + integer, intent(inout) :: iovrsw + +! --- outputs: none + +! --- locals: + real (kind=kind_phys), parameter :: expeps = 1.e-20 + + integer :: i + + real (kind=kind_phys) :: tfn, tau + +! +!===> ... begin here +! + if ( iovrsw<0 .or. iovrsw>4 ) then + print *,' *** Error in specification of cloud overlap flag', & + & ' IOVRSW=',iovrsw,' in RSWINIT !!' + stop + endif + + if (me == 0) then + print *,' - Using AER Shortwave Radiation, Version: ',VTAGSW + + if (iswmode == 1) then + print *,' --- Delta-eddington 2-stream transfer scheme' + else if (iswmode == 2) then + print *,' --- PIFM 2-stream transfer scheme' + else if (iswmode == 3) then + print *,' --- Discrete ordinates 2-stream transfer scheme' + endif + + if (iswrgas <= 0) then + print *,' --- Rare gases absorption is NOT included in SW' + else + print *,' --- Include rare gases N2O, CH4, O2, absorptions',& + & ' in SW' + endif + + if ( isubcsw == 0 ) then + print *,' --- Using standard grid average clouds, no ', & + & 'sub-column clouds approximation applied' + elseif ( isubcsw == 1 ) then + print *,' --- Using MCICA sub-colum clouds approximation ', & + & 'with a prescribed sequence of permutation seeds' + elseif ( isubcsw == 2 ) then + print *,' --- Using MCICA sub-colum clouds approximation ', & + & 'with provided input array of permutation seeds' + else + print *,' *** Error in specification of sub-column cloud ', & + & ' control flag isubcsw =',isubcsw,' !!' + stop + endif + endif + +!> -# Check cloud flags for consistency. + + if ((icldflg == 0 .and. iswcliq /= 0) .or. & + & (icldflg == 1 .and. iswcliq == 0)) then + print *,' *** Model cloud scheme inconsistent with SW', & + & ' radiation cloud radiative property setup !!' + stop + endif + + if ( isubcsw==0 .and. iovrsw>2 ) then + if (me == 0) then + print *,' *** IOVRSW=',iovrsw,' is not available for', & + & ' ISUBCSW=0 setting!!' + print *,' The program will use maximum/random overlap', & + & ' instead.' + endif + + iovrsw = 1 + endif + +!> -# Setup constant factors for heating rate +!! the 1.0e-2 is to convert pressure from mb to \f$N/m^2\f$ . + + if (iswrate == 1) then +! heatfac = 8.4391 +! heatfac = con_g * 86400. * 1.0e-2 / con_cp ! (in k/day) + heatfac = con_g * 864.0 / con_cp ! (in k/day) + else + heatfac = con_g * 1.0e-2 / con_cp ! (in k/second) + endif + +!> -# Define exponential lookup tables for transmittance. +! tau is computed as a function of the \a tau transition function, and +! transmittance is calculated as a function of tau. all tables +! are computed at intervals of 0.0001. the inverse of the +! constant used in the Pade approximation to the tau transition +! function is set to bpade. + + exp_tbl(0) = 1.0 + exp_tbl(NTBMX) = expeps + + do i = 1, NTBMX-1 + tfn = float(i) / float(NTBMX-i) + tau = bpade * tfn + exp_tbl(i) = exp( -tau ) + enddo + + return +!................................... + end subroutine rswinit +!! @} +!----------------------------------- + +!>\ingroup module_radsw_main +!> This subroutine computes the cloud optical properties for each +!! cloudy layer and g-point interval. +!!\param cfrac layer cloud fraction +!!\n for physparam::iswcliq > 0 (prognostic cloud scheme) - - - +!!\param cliqp layer in-cloud liq water path (\f$g/m^2\f$) +!!\param reliq mean eff radius for liq cloud (micron) +!!\param cicep layer in-cloud ice water path (\f$g/m^2\f$) +!!\param reice mean eff radius for ice cloud (micron) +!!\param cdat1 layer rain drop water path (\f$g/m^2\f$) +!!\param cdat2 effective radius for rain drop (micron) +!!\param cdat3 layer snow flake water path(\f$g/m^2\f$) +!!\param cdat4 mean eff radius for snow flake(micron) +!!\n for physparam::iswcliq = 0 (diagnostic cloud scheme) - - - +!!\param cliqp not used +!!\param cicep not used +!!\param reliq not used +!!\param reice not used +!!\param cdat1 layer cloud optical depth +!!\param cdat2 layer cloud single scattering albedo +!!\param cdat3 layer cloud asymmetry factor +!!\param cdat4 optional use +!!\param cf1 effective total cloud cover at surface +!!\param nlay vertical layer number +!!\param ipseed permutation seed for generating random numbers +!! (isubcsw>0) +!!\param dz layer thickness (km) +!!\param delgth layer cloud decorrelation length (km) +!!\param taucw cloud optical depth, w/o delta scaled +!!\param ssacw weighted cloud single scattering albedo +!! (ssa = ssacw / taucw) +!!\param asycw weighted cloud asymmetry factor +!! (asy = asycw / ssacw) +!!\param cldfrc cloud fraction of grid mean value +!!\param cldfmc cloud fraction for each sub-column +!!\section General_cldprop cldprop General Algorithm +!> @{ +!----------------------------------- + subroutine cldprop & + & ( cfrac,cliqp,reliq,cicep,reice,cdat1,cdat2,cdat3,cdat4, & ! --- inputs + & cf1, nlay, ipseed, dz, delgth,iswcliq,iovrsw, isubcsw, & + & taucw, ssacw, asycw, cldfrc, cldfmc & ! --- output + & ) + +! =================== program usage description =================== ! +! ! +! Purpose: Compute the cloud optical properties for each cloudy layer ! +! and g-point interval. ! +! ! +! subprograms called: none ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! cfrac - real, layer cloud fraction nlay ! +! ..... for iswcliq > 0 (prognostic cloud sckeme) - - - ! +! cliqp - real, layer in-cloud liq water path (g/m**2) nlay ! +! reliq - real, mean eff radius for liq cloud (micron) nlay ! +! cicep - real, layer in-cloud ice water path (g/m**2) nlay ! +! reice - real, mean eff radius for ice cloud (micron) nlay ! +! cdat1 - real, layer rain drop water path (g/m**2) nlay ! +! cdat2 - real, effective radius for rain drop (micron) nlay ! +! cdat3 - real, layer snow flake water path(g/m**2) nlay ! +! cdat4 - real, mean eff radius for snow flake(micron) nlay ! +! ..... for iswcliq = 0 (diagnostic cloud sckeme) - - - ! +! cdat1 - real, layer cloud optical depth nlay ! +! cdat2 - real, layer cloud single scattering albedo nlay ! +! cdat3 - real, layer cloud asymmetry factor nlay ! +! cdat4 - real, optional use nlay ! +! cliqp - real, not used nlay ! +! cicep - real, not used nlay ! +! reliq - real, not used nlay ! +! reice - real, not used nlay ! +! ! +! cf1 - real, effective total cloud cover at surface 1 ! +! nlay - integer, vertical layer number 1 ! +! ipseed- permutation seed for generating random numbers (isubcsw>0) ! +! dz - real, layer thickness (km) nlay ! +! delgth- real, layer cloud decorrelation length (km) 1 ! +! ! +! outputs: ! +! taucw - real, cloud optical depth, w/o delta scaled nlay*nbdsw ! +! ssacw - real, weighted cloud single scattering albedo nlay*nbdsw ! +! (ssa = ssacw / taucw) ! +! asycw - real, weighted cloud asymmetry factor nlay*nbdsw ! +! (asy = asycw / ssacw) ! +! cldfrc - real, cloud fraction of grid mean value nlay ! +! cldfmc - real, cloud fraction for each sub-column nlay*ngptsw! +! ! +! ! +! explanation of the method for each value of iswcliq, and iswcice. ! +! set up in module "physparam" ! +! ! +! iswcliq=0 : input cloud optical property (tau, ssa, asy). ! +! (used for diagnostic cloud method) ! +! iswcliq>0 : input cloud liq/ice path and effective radius, also ! +! require the user of 'iswcice' to specify the method ! +! used to compute aborption due to water/ice parts. ! +! ................................................................... ! +! ! +! iswcliq=1 : liquid water cloud optical properties are computed ! +! as in hu and stamnes (1993), j. clim., 6, 728-742. ! +! iswcliq=2 : updated coeffs for hu and stamnes (1993) by aer ! +! w v3.9-v4.0. ! +! ! +! iswcice used only when iswcliq > 0 ! +! the cloud ice path (g/m2) and ice effective radius ! +! (microns) are inputs. ! +! iswcice=1 : ice cloud optical properties are computed as in ! +! ebert and curry (1992), jgr, 97, 3831-3836. ! +! iswcice=2 : ice cloud optical properties are computed as in ! +! streamer v3.0 (2001), key, streamer user's guide, ! +! cooperative institude for meteorological studies,95pp! +! iswcice=3 : ice cloud optical properties are computed as in ! +! fu (1996), j. clim., 9. ! +! ! +! other cloud control module variables: ! +! isubcsw =0: standard cloud scheme, no sub-col cloud approximation ! +! >0: mcica sub-col cloud scheme using ipseed as permutation! +! seed for generating rundom numbers ! +! ! +! ====================== end of description block ================= ! +! + use module_radsw_cldprtb + +! --- inputs: + integer, intent(in) :: nlay, ipseed,iswcliq,iovrsw,isubcsw + real (kind=kind_phys), intent(in) :: cf1, delgth + + real (kind=kind_phys), dimension(nlay), intent(in) :: cliqp, & + & reliq, cicep, reice, cdat1, cdat2, cdat3, cdat4, cfrac, dz + +! --- outputs: + real (kind=kind_phys), dimension(nlay,ngptsw), intent(out) :: & + & cldfmc + real (kind=kind_phys), dimension(nlay,nbdsw), intent(out) :: & + & taucw, ssacw, asycw + real (kind=kind_phys), dimension(nlay), intent(out) :: cldfrc + +! --- locals: + real (kind=kind_phys), dimension(nblow:nbhgh) :: tauliq, tauice, & + & ssaliq, ssaice, ssaran, ssasnw, asyliq, asyice, & + & asyran, asysnw + real (kind=kind_phys), dimension(nlay) :: cldf + + real (kind=kind_phys) :: dgeice, factor, fint, tauran, tausnw, & + & cldliq, refliq, cldice, refice, cldran, cldsnw, refsnw, & + & extcoliq, ssacoliq, asycoliq, extcoice, ssacoice, asycoice,& + & dgesnw + + logical :: lcloudy(nlay,ngptsw) + integer :: ia, ib, ig, jb, k, index + +! +!===> ... begin here +! + do ib = 1, nbdsw + do k = 1, nlay + taucw (k,ib) = f_zero + ssacw (k,ib) = f_one + asycw (k,ib) = f_zero + enddo + enddo + +!> -# Compute cloud radiative properties for a cloudy column. + + lab_if_iswcliq : if (iswcliq > 0) then + + lab_do_k : do k = 1, nlay + lab_if_cld : if (cfrac(k) > ftiny) then + +!> - Compute optical properties for rain and snow. +!!\n For rain: tauran/ssaran/asyran +!!\n For snow: tausnw/ssasnw/asysnw +!> - Calculation of absorption coefficients due to water clouds +!!\n For water clouds: tauliq/ssaliq/asyliq +!> - Calculation of absorption coefficients due to ice clouds +!!\n For ice clouds: tauice/ssaice/asyice +!> - For Prognostic cloud scheme: sum up the cloud optical property: +!!\n \f$ taucw=tauliq+tauice+tauran+tausnw \f$ +!!\n \f$ ssacw=ssaliq+ssaice+ssaran+ssasnw \f$ +!!\n \f$ asycw=asyliq+asyice+asyran+asysnw \f$ + + cldran = cdat1(k) +! refran = cdat2(k) + cldsnw = cdat3(k) + refsnw = cdat4(k) + dgesnw = 1.0315 * refsnw ! for fu's snow formula + + tauran = cldran * a0r + +!> - If use fu's formula it needs to be normalized by snow/ice density. +!! not use snow density = 0.1 g/cm**3 = 0.1 g/(mu * m**2) +!!\n use ice density = 0.9167 g/cm**3 = 0.9167 g/(mu * m**2) +!!\n 1/0.9167 = 1.09087 +!!\n factor 1.5396=8/(3*sqrt(3)) converts reff to generalized ice particle size +!! use newer factor value 1.0315 + if (cldsnw>f_zero .and. refsnw>10.0_kind_phys) then +! tausnw = cldsnw * (a0s + a1s/refsnw) + tausnw = cldsnw*1.09087*(a0s + a1s/dgesnw) ! fu's formula + else + tausnw = f_zero + endif + + do ib = nblow, nbhgh + ssaran(ib) = tauran * (f_one - b0r(ib)) + ssasnw(ib) = tausnw * (f_one - (b0s(ib)+b1s(ib)*dgesnw)) + asyran(ib) = ssaran(ib) * c0r(ib) + asysnw(ib) = ssasnw(ib) * c0s(ib) + enddo + + cldliq = cliqp(k) + cldice = cicep(k) + refliq = reliq(k) + refice = reice(k) + +!> - Calculation of absorption coefficients due to water clouds. + + if ( cldliq <= f_zero ) then + do ib = nblow, nbhgh + tauliq(ib) = f_zero + ssaliq(ib) = f_zero + asyliq(ib) = f_zero + enddo + else + factor = refliq - 1.5 + index = max( 1, min( 57, int( factor ) )) + fint = factor - float(index) + + if ( iswcliq == 1 ) then + do ib = nblow, nbhgh + extcoliq = max(f_zero, extliq1(index,ib) & + & + fint*(extliq1(index+1,ib)-extliq1(index,ib)) ) + ssacoliq = max(f_zero, min(f_one, ssaliq1(index,ib) & + & + fint*(ssaliq1(index+1,ib)-ssaliq1(index,ib)) )) + + asycoliq = max(f_zero, min(f_one, asyliq1(index,ib) & + & + fint*(asyliq1(index+1,ib)-asyliq1(index,ib)) )) +! forcoliq = asycoliq * asycoliq + + tauliq(ib) = cldliq * extcoliq + ssaliq(ib) = tauliq(ib) * ssacoliq + asyliq(ib) = ssaliq(ib) * asycoliq + enddo + elseif ( iswcliq == 2 ) then ! use updated coeffs + do ib = nblow, nbhgh + extcoliq = max(f_zero, extliq2(index,ib) & + & + fint*(extliq2(index+1,ib)-extliq2(index,ib)) ) + ssacoliq = max(f_zero, min(f_one, ssaliq2(index,ib) & + & + fint*(ssaliq2(index+1,ib)-ssaliq2(index,ib)) )) + + asycoliq = max(f_zero, min(f_one, asyliq2(index,ib) & + & + fint*(asyliq2(index+1,ib)-asyliq2(index,ib)) )) +! forcoliq = asycoliq * asycoliq + + tauliq(ib) = cldliq * extcoliq + ssaliq(ib) = tauliq(ib) * ssacoliq + asyliq(ib) = ssaliq(ib) * asycoliq + enddo + endif ! end if_iswcliq_block + endif ! end if_cldliq_block + +!> - Calculation of absorption coefficients due to ice clouds. + + if ( cldice <= f_zero ) then + do ib = nblow, nbhgh + tauice(ib) = f_zero + ssaice(ib) = f_zero + asyice(ib) = f_zero + enddo + else + +!> - ebert and curry approach for all particle sizes though somewhat +!! unjustified for large ice particles. + + if ( iswcice == 1 ) then + refice = min(130.0_kind_phys,max(13.0_kind_phys,refice)) + + do ib = nblow, nbhgh + ia = idxebc(ib) ! eb_&_c band index for ice cloud coeff + + extcoice = max(f_zero, abari(ia)+bbari(ia)/refice ) + ssacoice = max(f_zero, min(f_one, & + & f_one-cbari(ia)-dbari(ia)*refice )) + asycoice = max(f_zero, min(f_one, & + & ebari(ia)+fbari(ia)*refice )) +! forcoice = asycoice * asycoice + + tauice(ib) = cldice * extcoice + ssaice(ib) = tauice(ib) * ssacoice + asyice(ib) = ssaice(ib) * asycoice + enddo + +!> - streamer approach for ice effective radius between 5.0 and 131.0 microns. + + elseif ( iswcice == 2 ) then + refice = min(131.0_kind_phys,max(5.0_kind_phys,refice)) + + factor = (refice - 2.0) / 3.0 + index = max( 1, min( 42, int( factor ) )) + fint = factor - float(index) + + do ib = nblow, nbhgh + extcoice = max(f_zero, extice2(index,ib) & + & + fint*(extice2(index+1,ib)-extice2(index,ib)) ) + ssacoice = max(f_zero, min(f_one, ssaice2(index,ib) & + & + fint*(ssaice2(index+1,ib)-ssaice2(index,ib)) )) + asycoice = max(f_zero, min(f_one, asyice2(index,ib) & + & + fint*(asyice2(index+1,ib)-asyice2(index,ib)) )) +! forcoice = asycoice * asycoice + + tauice(ib) = cldice * extcoice + ssaice(ib) = tauice(ib) * ssacoice + asyice(ib) = ssaice(ib) * asycoice + enddo + +!> - fu's approach for ice effective radius between 4.8 and 135 microns +!! (generalized effective size from 5 to 140 microns). + + elseif ( iswcice == 3 ) then + dgeice = max( 5.0, min( 140.0, 1.0315*refice )) + + factor = (dgeice - 2.0) / 3.0 + index = max( 1, min( 45, int( factor ) )) + fint = factor - float(index) + + do ib = nblow, nbhgh + extcoice = max(f_zero, extice3(index,ib) & + & + fint*(extice3(index+1,ib)-extice3(index,ib)) ) + ssacoice = max(f_zero, min(f_one, ssaice3(index,ib) & + & + fint*(ssaice3(index+1,ib)-ssaice3(index,ib)) )) + asycoice = max(f_zero, min(f_one, asyice3(index,ib) & + & + fint*(asyice3(index+1,ib)-asyice3(index,ib)) )) +! fdelta = max(f_zero, min(f_one, fdlice3(index,ib) & +! & + fint*(fdlice3(index+1,ib)-fdlice3(index,ib)) )) +! forcoice = min( asycoice, fdelta+0.5/ssacoice ) ! see fu 1996 p. 2067 + + tauice(ib) = cldice * extcoice + ssaice(ib) = tauice(ib) * ssacoice + asyice(ib) = ssaice(ib) * asycoice + enddo + + endif ! end if_iswcice_block + endif ! end if_cldice_block + + do ib = 1, nbdsw + jb = nblow + ib - 1 + taucw(k,ib) = tauliq(jb)+tauice(jb)+tauran+tausnw + ssacw(k,ib) = ssaliq(jb)+ssaice(jb)+ssaran(jb)+ssasnw(jb) + asycw(k,ib) = asyliq(jb)+asyice(jb)+asyran(jb)+asysnw(jb) + enddo + + endif lab_if_cld + enddo lab_do_k + + else lab_if_iswcliq + + do k = 1, nlay + if (cfrac(k) > ftiny) then + do ib = 1, nbdsw + taucw(k,ib) = cdat1(k) + ssacw(k,ib) = cdat1(k) * cdat2(k) + asycw(k,ib) = ssacw(k,ib) * cdat3(k) + enddo + endif + enddo + + endif lab_if_iswcliq + +!> -# if physparam::isubcsw > 0, call mcica_subcol() to distribute +!! cloud properties to each g-point. + +!mz if ( isubcsw > 0 ) then ! mcica sub-col clouds approx + if ( isubcsw > 0 .and. iovrsw .ne. 4 ) then ! mcica sub-col clouds approx + + cldf(:) = cfrac(:) + where (cldf(:) < ftiny) + cldf(:) = f_zero + end where + +! --- ... call sub-column cloud generator + + call mcica_subcol & +! --- inputs: + & ( cldf, nlay, ipseed, dz, delgth, iovrsw, & +! --- outputs: + & lcloudy & + & ) + + do ig = 1, ngptsw + do k = 1, nlay + if ( lcloudy(k,ig) ) then + cldfmc(k,ig) = f_one + else + cldfmc(k,ig) = f_zero + endif + enddo + enddo + + else ! non-mcica, normalize cloud + + do k = 1, nlay + cldfrc(k) = cfrac(k) / cf1 + enddo + endif ! end if_isubcsw_block + + return +!................................... + end subroutine cldprop +!----------------------------------- +!> @} + +!>\ingroup module_radsw_main +!> This subroutine computes the sub-colum cloud profile flag array. +!!\param cldf layer cloud fraction +!!\param nlay number of model vertical layers +!!\param ipseed permute seed for random num generator +!!\param dz layer thickness (km) +!!\param de_lgth layer cloud decorrelation length (km) +!!\param lcloudy sub-colum cloud profile flag array +!!\section mcica_sw_gen mcica_subcol General Algorithm +!> @{ +! ---------------------------------- + subroutine mcica_subcol & + & ( cldf, nlay, ipseed, dz, de_lgth,iovrsw, & ! --- inputs + & lcloudy & ! --- outputs + & ) + +! ==================== defination of variables ==================== ! +! ! +! input variables: size ! +! cldf - real, layer cloud fraction nlay ! +! nlay - integer, number of model vertical layers 1 ! +! ipseed - integer, permute seed for random num generator 1 ! +! ** note : if the cloud generator is called multiple times, need ! +! to permute the seed between each call; if between calls ! +! for lw and sw, use values differ by the number of g-pts. ! +! dz - real, layer thickness (km) nlay ! +! de_lgth-real, layer cloud decorrelation length (km) 1 ! +! ! +! output variables: ! +! lcloudy - logical, sub-colum cloud profile flag array nlay*ngptsw! +! ! +! other control flags from module variables: ! +! iovrsw : control flag for cloud overlapping method ! +! =0: random ! +! =1: maximum/random overlapping clouds ! +! =2: maximum overlap cloud ! +! =3: cloud decorrelation-length overlap method ! +! ! +! ===================== end of definitions ==================== ! + + implicit none + +! --- inputs: + integer, intent(in) :: nlay, ipseed, iovrsw + + real (kind=kind_phys), dimension(nlay), intent(in) :: cldf, dz + real (kind=kind_phys), intent(in) :: de_lgth + +! --- outputs: + logical, dimension(nlay,ngptsw), intent(out):: lcloudy + +! --- locals: + real (kind=kind_phys) :: cdfunc(nlay,ngptsw), tem1, & + & rand2d(nlay*ngptsw), rand1d(ngptsw), fac_lcf(nlay), & + & cdfun2(nlay,ngptsw) + + type (random_stat) :: stat ! for thread safe random generator + + integer :: k, n, k1, ig +! +!===> ... begin here +! +!> -# Advance randum number generator by ipseed values. + + call random_setseed & +! --- inputs: + & ( ipseed, & +! --- outputs: + & stat & + & ) + +!> -# Sub-column set up according to overlapping assumption. + + select case ( iovrsw ) + + case( 0 ) ! random overlap, pick a random value at every level + + call random_number & +! --- inputs: ( none ) +! --- outputs: + & ( rand2d, stat ) + + k1 = 0 + do n = 1, ngptsw + do k = 1, nlay + k1 = k1 + 1 + cdfunc(k,n) = rand2d(k1) + enddo + enddo + + case( 1 ) ! max-ran overlap + + call random_number & +! --- inputs: ( none ) +! --- outputs: + & ( rand2d, stat ) + + k1 = 0 + do n = 1, ngptsw + do k = 1, nlay + k1 = k1 + 1 + cdfunc(k,n) = rand2d(k1) + enddo + enddo + +! --- first pick a random number for bottom/top layer. +! then walk up the column: (aer's code) +! if layer below is cloudy, use the same rand num in the layer below +! if layer below is clear, use a new random number + +! --- from bottom up + do k = 2, nlay + k1 = k - 1 + tem1 = f_one - cldf(k1) + + do n = 1, ngptsw + if ( cdfunc(k1,n) > tem1 ) then + cdfunc(k,n) = cdfunc(k1,n) + else + cdfunc(k,n) = cdfunc(k,n) * tem1 + endif + enddo + enddo + +! --- then walk down the column: (if use original author's method) +! if layer above is cloudy, use the same rand num in the layer above +! if layer above is clear, use a new random number + +! --- from top down +! do k = nlay-1, 1, -1 +! k1 = k + 1 +! tem1 = f_one - cldf(k1) + +! do n = 1, ngptsw +! if ( cdfunc(k1,n) > tem1 ) then +! cdfunc(k,n) = cdfunc(k1,n) +! else +! cdfunc(k,n) = cdfunc(k,n) * tem1 +! endif +! enddo +! enddo + + case( 2 ) ! maximum overlap, pick same random numebr at every level + + call random_number & +! --- inputs: ( none ) +! --- outputs: + & ( rand1d, stat ) + + do n = 1, ngptsw + tem1 = rand1d(n) + + do k = 1, nlay + cdfunc(k,n) = tem1 + enddo + enddo + + case( 3 ) ! decorrelation length overlap + +! --- compute overlapping factors based on layer midpoint distances +! and decorrelation depths + + do k = nlay, 2, -1 + fac_lcf(k) = exp( -0.5 * (dz(k)+dz(k-1)) / de_lgth ) + enddo + +! --- setup 2 sets of random numbers + + call random_number ( rand2d, stat ) + + k1 = 0 + do n = 1, ngptsw + do k = 1, nlay + k1 = k1 + 1 + cdfunc(k,n) = rand2d(k1) + enddo + enddo + + call random_number ( rand2d, stat ) + + k1 = 0 + do n = 1, ngptsw + do k = 1, nlay + k1 = k1 + 1 + cdfun2(k,n) = rand2d(k1) + enddo + enddo + +! --- then working from the top down: +! if a random number (from an independent set -cdfun2) is smaller then the +! scale factor: use the upper layer's number, otherwise use a new random +! number (keep the original assigned one). + + do n = 1, ngptsw + do k = nlay-1, 1, -1 + k1 = k + 1 + if ( cdfun2(k,n) <= fac_lcf(k1) ) then + cdfunc(k,n) = cdfunc(k1,n) + endif + enddo + enddo + + end select + +!> -# Generate subcolumns for homogeneous clouds. + + do k = 1, nlay + tem1 = f_one - cldf(k) + + do n = 1, ngptsw + lcloudy(k,n) = cdfunc(k,n) >= tem1 + enddo + enddo + + return +! .................................. + end subroutine mcica_subcol +!> @} +! ---------------------------------- + +!>\ingroup module_radsw_main +!> This subroutine computes various coefficients needed in radiative +!! transfer calculation. +!!\param pavel layer pressure (mb) +!!\param tavel layer temperature (k) +!!\param h2ovmr layer w.v. volumn mixing ratio (kg/kg) +!!\param nlay total number of vertical layers +!!\param nlp1 total number of vertical levels +!!\param laytrop tropopause layer index (unitless) +!!\param jp indices of lower reference pressure +!!\param jt,jt1 indices of lower reference temperatures at +!! levels of jp and jp+1 +!!\param fac00,fac01,fac10,fac11 factors mltiply the reference ks,i,j=0/1 for +!! lower/higher of the 2 appropriate temperature +!! and altitudes. +!!\param selffac scale factor for w. v. self-continuum equals +!! (w.v. density)/(atmospheric density at 296k +!! and 1013 mb) +!!\param selffrac factor for temperature interpolation of +!! reference w.v. self-continuum data +!!\param indself index of lower ref temp for selffac +!!\param forfac scale factor for w. v. foreign-continuum +!!\param forfrac factor for temperature interpolation of +!! reference w.v. foreign-continuum data +!!\param indfor index of lower ref temp for forfac +!>\section setcoef_gen_rw setcoef General Algorithm +!! @{ +! ---------------------------------- + subroutine setcoef & + & ( pavel,tavel,h2ovmr, nlay,nlp1, & ! --- inputs + & laytrop,jp,jt,jt1,fac00,fac01,fac10,fac11, & ! --- outputs + & selffac,selffrac,indself,forfac,forfrac,indfor & + & ) + +! =================== program usage description =================== ! +! ! +! purpose: compute various coefficients needed in radiative transfer ! +! calculations. ! +! ! +! subprograms called: none ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: -size- ! +! pavel - real, layer pressures (mb) nlay ! +! tavel - real, layer temperatures (k) nlay ! +! h2ovmr - real, layer w.v. volum mixing ratio (kg/kg) nlay ! +! nlay/nlp1 - integer, total number of vertical layers, levels 1 ! +! ! +! outputs: ! +! laytrop - integer, tropopause layer index (unitless) 1 ! +! jp - real, indices of lower reference pressure nlay ! +! jt, jt1 - real, indices of lower reference temperatures nlay ! +! at levels of jp and jp+1 ! +! facij - real, factors multiply the reference ks, nlay ! +! i,j=0/1 for lower/higher of the 2 appropriate ! +! temperatures and altitudes. ! +! selffac - real, scale factor for w. v. self-continuum nlay ! +! equals (w. v. density)/(atmospheric density ! +! at 296k and 1013 mb) ! +! selffrac - real, factor for temperature interpolation of nlay ! +! reference w. v. self-continuum data ! +! indself - integer, index of lower ref temp for selffac nlay ! +! forfac - real, scale factor for w. v. foreign-continuum nlay ! +! forfrac - real, factor for temperature interpolation of nlay ! +! reference w.v. foreign-continuum data ! +! indfor - integer, index of lower ref temp for forfac nlay ! +! ! +! ====================== end of definitions =================== ! + +! --- inputs: + integer, intent(in) :: nlay, nlp1 + + real (kind=kind_phys), dimension(:), intent(in) :: pavel, tavel, & + & h2ovmr + +! --- outputs: + integer, dimension(nlay), intent(out) :: indself, indfor, & + & jp, jt, jt1 + integer, intent(out) :: laytrop + + real (kind=kind_phys), dimension(nlay), intent(out) :: fac00, & + & fac01, fac10, fac11, selffac, selffrac, forfac, forfrac + +! --- locals: + real (kind=kind_phys) :: plog, fp, fp1, ft, ft1, tem1, tem2 + + integer :: i, k, jp1 +! +!===> ... begin here +! + laytrop= nlay + + do k = 1, nlay + + forfac(k) = pavel(k)*stpfac / (tavel(k)*(f_one + h2ovmr(k))) + +!> -# Find the two reference pressures on either side of the +!! layer pressure. store them in jp and jp1. store in fp the +!! fraction of the difference (in ln(pressure)) between these +!! two values that the layer pressure lies. + + plog = log(pavel(k)) + jp(k) = max(1, min(58, int(36.0 - 5.0*(plog+0.04)) )) + jp1 = jp(k) + 1 + fp = 5.0 * (preflog(jp(k)) - plog) + +!> -# Determine, for each reference pressure (jp and jp1), which +!! reference temperature (these are different for each reference +!! pressure) is nearest the layer temperature but does not exceed it. +!! store these indices in jt and jt1, resp. store in ft (resp. ft1) +!! the fraction of the way between jt (jt1) and the next highest +!! reference temperature that the layer temperature falls. + + tem1 = (tavel(k) - tref(jp(k))) / 15.0 + tem2 = (tavel(k) - tref(jp1 )) / 15.0 + jt (k) = max(1, min(4, int(3.0 + tem1) )) + jt1(k) = max(1, min(4, int(3.0 + tem2) )) + ft = tem1 - float(jt (k) - 3) + ft1 = tem2 - float(jt1(k) - 3) + +!> -# We have now isolated the layer ln pressure and temperature, +!! between two reference pressures and two reference temperatures +!! (for each reference pressure). we multiply the pressure +!! fraction fp with the appropriate temperature fractions to get +!! the factors that will be needed for the interpolation that yields +!! the optical depths (performed in routines taugbn for band n). + + fp1 = f_one - fp + fac10(k) = fp1 * ft + fac00(k) = fp1 * (f_one - ft) + fac11(k) = fp * ft1 + fac01(k) = fp * (f_one - ft1) + +!> -# If the pressure is less than ~100mb, perform a different +!! set of species interpolations. + + if ( plog > 4.56 ) then + + laytrop = k + +!> -# Set up factors needed to separately include the water vapor +!! foreign-continuum in the calculation of absorption coefficient. + + tem1 = (332.0 - tavel(k)) / 36.0 + indfor (k) = min(2, max(1, int(tem1))) + forfrac(k) = tem1 - float(indfor(k)) + +!> -# Set up factors needed to separately include the water vapor +!! self-continuum in the calculation of absorption coefficient. + + tem2 = (tavel(k) - 188.0) / 7.2 + indself (k) = min(9, max(1, int(tem2)-7)) + selffrac(k) = tem2 - float(indself(k) + 7) + selffac (k) = h2ovmr(k) * forfac(k) + + else + +! --- ... set up factors needed to separately include the water vapor +! foreign-continuum in the calculation of absorption coefficient. + + tem1 = (tavel(k) - 188.0) / 36.0 + indfor (k) = 3 + forfrac(k) = tem1 - f_one + + indself (k) = 0 + selffrac(k) = f_zero + selffac (k) = f_zero + + endif + + enddo ! end_do_k_loop + + return +! .................................. + end subroutine setcoef +!! @} +! ---------------------------------- + +!>\ingroup module_radsw_main +!> This subroutine computes the shortwave radiative fluxes using +!! two-stream method. +!!\param ssolar incoming solar flux at top +!!\param cosz cosine solar zenith angle +!!\param sntz secant solar zenith angle +!!\param albbm surface albedo for direct beam radiation +!!\param albdf surface albedo for diffused radiation +!!\param sfluxzen spectral distribution of incoming solar flux +!!\param cldfrc layer cloud fraction +!!\param cf1 >0: cloudy sky, otherwise: clear sky +!!\param cf0 =1-cf1 +!!\param taug spectral optical depth for gases +!!\param taur optical depth for rayleigh scattering +!!\param tauae aerosols optical depth +!!\param ssaae aerosols single scattering albedo +!!\param asyae aerosols asymmetry factor +!!\param taucw weighted cloud optical depth +!!\param ssacw weighted cloud single scat albedo +!!\param asycw weighted cloud asymmetry factor +!!\param nlay,nlp1 number of layers/levels +!!\param fxupc tot sky upward flux +!!\param fxdnc tot sky downward flux +!!\param fxup0 clr sky upward flux +!!\param fxdn0 clr sky downward flux +!!\param ftoauc tot sky toa upwd flux +!!\param ftoau0 clr sky toa upwd flux +!!\param ftoadc toa downward (incoming) solar flux +!!\param fsfcuc tot sky sfc upwd flux +!!\param fsfcu0 clr sky sfc upwd flux +!!\param fsfcdc tot sky sfc dnwd flux +!!\param fsfcd0 clr sky sfc dnwd flux +!!\param sfbmc tot sky sfc dnwd beam flux (nir/uv+vis) +!!\param sfdfc tot sky sfc dnwd diff flux (nir/uv+vis) +!!\param sfbm0 clr sky sfc dnwd beam flux (nir/uv+vis) +!!\param sfdf0 clr sky sfc dnwd diff flux (nir/uv+vis) +!!\param suvbfc tot sky sfc dnwd uv-b flux +!!\param suvbf0 clr sky sfc dnwd uv-b flux +!>\section General_spcvrtc spcvrtc General Algorithm +!! @{ +!----------------------------------- + subroutine spcvrtc & + & ( ssolar,cosz,sntz,albbm,albdf,sfluxzen,cldfrc, & ! --- inputs + & cf1,cf0,taug,taur,tauae,ssaae,asyae,taucw,ssacw,asycw, & + & nlay, nlp1, & + & fxupc,fxdnc,fxup0,fxdn0, & ! --- outputs + & ftoauc,ftoau0,ftoadc,fsfcuc,fsfcu0,fsfcdc,fsfcd0, & + & sfbmc,sfdfc,sfbm0,sfdf0,suvbfc,suvbf0 & + & ) + +! =================== program usage description =================== ! +! ! +! purpose: computes the shortwave radiative fluxes using two-stream ! +! method ! +! ! +! subprograms called: vrtqdr ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! ssolar - real, incoming solar flux at top 1 ! +! cosz - real, cosine solar zenith angle 1 ! +! sntz - real, secant solar zenith angle 1 ! +! albbm - real, surface albedo for direct beam radiation 2 ! +! albdf - real, surface albedo for diffused radiation 2 ! +! sfluxzen- real, spectral distribution of incoming solar flux ngptsw! +! cldfrc - real, layer cloud fraction nlay ! +! cf1 - real, >0: cloudy sky, otherwise: clear sky 1 ! +! cf0 - real, =1-cf1 1 ! +! taug - real, spectral optical depth for gases nlay*ngptsw! +! taur - real, optical depth for rayleigh scattering nlay*ngptsw! +! tauae - real, aerosols optical depth nlay*nbdsw ! +! ssaae - real, aerosols single scattering albedo nlay*nbdsw ! +! asyae - real, aerosols asymmetry factor nlay*nbdsw ! +! taucw - real, weighted cloud optical depth nlay*nbdsw ! +! ssacw - real, weighted cloud single scat albedo nlay*nbdsw ! +! asycw - real, weighted cloud asymmetry factor nlay*nbdsw ! +! nlay,nlp1 - integer, number of layers/levels 1 ! +! ! +! output variables: ! +! fxupc - real, tot sky upward flux nlp1*nbdsw ! +! fxdnc - real, tot sky downward flux nlp1*nbdsw ! +! fxup0 - real, clr sky upward flux nlp1*nbdsw ! +! fxdn0 - real, clr sky downward flux nlp1*nbdsw ! +! ftoauc - real, tot sky toa upwd flux 1 ! +! ftoau0 - real, clr sky toa upwd flux 1 ! +! ftoadc - real, toa downward (incoming) solar flux 1 ! +! fsfcuc - real, tot sky sfc upwd flux 1 ! +! fsfcu0 - real, clr sky sfc upwd flux 1 ! +! fsfcdc - real, tot sky sfc dnwd flux 1 ! +! fsfcd0 - real, clr sky sfc dnwd flux 1 ! +! sfbmc - real, tot sky sfc dnwd beam flux (nir/uv+vis) 2 ! +! sfdfc - real, tot sky sfc dnwd diff flux (nir/uv+vis) 2 ! +! sfbm0 - real, clr sky sfc dnwd beam flux (nir/uv+vis) 2 ! +! sfdf0 - real, clr sky sfc dnwd diff flux (nir/uv+vis) 2 ! +! suvbfc - real, tot sky sfc dnwd uv-b flux 1 ! +! suvbf0 - real, clr sky sfc dnwd uv-b flux 1 ! +! ! +! internal variables: ! +! zrefb - real, direct beam reflectivity for clear/cloudy nlp1 ! +! zrefd - real, diffuse reflectivity for clear/cloudy nlp1 ! +! ztrab - real, direct beam transmissivity for clear/cloudy nlp1 ! +! ztrad - real, diffuse transmissivity for clear/cloudy nlp1 ! +! zldbt - real, layer beam transmittance for clear/cloudy nlp1 ! +! ztdbt - real, lev total beam transmittance for clr/cld nlp1 ! +! ! +! control parameters in module "physparam" ! +! iswmode - control flag for 2-stream transfer schemes ! +! = 1 delta-eddington (joseph et al., 1976) ! +! = 2 pifm (zdunkowski et al., 1980) ! +! = 3 discrete ordinates (liou, 1973) ! +! ! +! ******************************************************************* ! +! original code description ! +! ! +! method: ! +! ------- ! +! standard delta-eddington, p.i.f.m., or d.o.m. layer calculations. ! +! kmodts = 1 eddington (joseph et al., 1976) ! +! = 2 pifm (zdunkowski et al., 1980) ! +! = 3 discrete ordinates (liou, 1973) ! +! ! +! modifications: ! +! -------------- ! +! original: h. barker ! +! revision: merge with rrtmg_sw: j.-j.morcrette, ecmwf, feb 2003 ! +! revision: add adjustment for earth/sun distance:mjiacono,aer,oct2003! +! revision: bug fix for use of palbp and palbd: mjiacono, aer, nov2003! +! revision: bug fix to apply delta scaling to clear sky: aer, dec2004 ! +! revision: code modified so that delta scaling is not done in cloudy ! +! profiles if routine cldprop is used; delta scaling can be ! +! applied by swithcing code below if cldprop is not used to ! +! get cloud properties. aer, jan 2005 ! +! revision: uniform formatting for rrtmg: mjiacono, aer, jul 2006 ! +! revision: use exponential lookup table for transmittance: mjiacono, ! +! aer, aug 2007 ! +! ! +! ******************************************************************* ! +! ====================== end of description block ================= ! + +! --- constant parameters: + real (kind=kind_phys), parameter :: zcrit = 0.9999995 ! thresold for conservative scattering + real (kind=kind_phys), parameter :: zsr3 = sqrt(3.0) + real (kind=kind_phys), parameter :: od_lo = 0.06 + real (kind=kind_phys), parameter :: eps1 = 1.0e-8 + +! --- inputs: + integer, intent(in) :: nlay, nlp1 + + real (kind=kind_phys), dimension(nlay,ngptsw), intent(in) :: & + & taug, taur + real (kind=kind_phys), dimension(nlay,nbdsw), intent(in) :: & + & taucw, ssacw, asycw, tauae, ssaae, asyae + + real (kind=kind_phys), dimension(ngptsw), intent(in) :: sfluxzen + real (kind=kind_phys), dimension(nlay), intent(in) :: cldfrc + + real (kind=kind_phys), dimension(2), intent(in) :: albbm, albdf + + real (kind=kind_phys), intent(in) :: cosz, sntz, cf1, cf0, ssolar + +! --- outputs: + real (kind=kind_phys), dimension(nlp1,nbdsw), intent(out) :: & + & fxupc, fxdnc, fxup0, fxdn0 + + real (kind=kind_phys), dimension(2), intent(out) :: sfbmc, sfdfc, & + & sfbm0, sfdf0 + + real (kind=kind_phys), intent(out) :: suvbfc, suvbf0, ftoadc, & + & ftoauc, ftoau0, fsfcuc, fsfcu0, fsfcdc, fsfcd0 + +! --- locals: + real (kind=kind_phys), dimension(nlay) :: ztaus, zssas, zasys, & + & zldbt0 + + real (kind=kind_phys), dimension(nlp1) :: zrefb, zrefd, ztrab, & + & ztrad, ztdbt, zldbt, zfu, zfd + + real (kind=kind_phys) :: ztau1, zssa1, zasy1, ztau0, zssa0, & + & zasy0, zasy3, zssaw, zasyw, zgam1, zgam2, zgam3, zgam4, & + & zc0, zc1, za1, za2, zb1, zb2, zrk, zrk2, zrp, zrp1, zrm1, & + & zrpp, zrkg1, zrkg3, zrkg4, zexp1, zexm1, zexp2, zexm2, & + & zexp3, zexp4, zden1, ze1r45, ftind, zsolar, zrefb1, & + & zrefd1, ztrab1, ztrad1, ztdbt0, zr1, zr2, zr3, zr4, zr5, & + & zt1, zt2, zt3, zf1, zf2, zrpp1 + + integer :: ib, ibd, jb, jg, k, kp, itind +! +!===> ... begin here + +!> -# Initialize output fluxes. + do ib = 1, nbdsw + do k = 1, nlp1 + fxdnc(k,ib) = f_zero + fxupc(k,ib) = f_zero + fxdn0(k,ib) = f_zero + fxup0(k,ib) = f_zero + enddo + enddo + + ftoadc = f_zero + ftoauc = f_zero + ftoau0 = f_zero + fsfcuc = f_zero + fsfcu0 = f_zero + fsfcdc = f_zero + fsfcd0 = f_zero + +!! --- ... uv-b surface downward fluxes + suvbfc = f_zero + suvbf0 = f_zero + +!! --- ... output surface flux components + sfbmc(1) = f_zero + sfbmc(2) = f_zero + sfdfc(1) = f_zero + sfdfc(2) = f_zero + sfbm0(1) = f_zero + sfbm0(2) = f_zero + sfdf0(1) = f_zero + sfdf0(2) = f_zero + +!> -# Loop over all g-points in each band. + + lab_do_jg : do jg = 1, ngptsw + + jb = NGB(jg) + ib = jb + 1 - nblow + ibd = idxsfc(jb) + + zsolar = ssolar * sfluxzen(jg) + +!> -# Set up toa direct beam and surface values (beam and diff). + + ztdbt(nlp1) = f_one + ztdbt0 = f_one + + zldbt(1) = f_zero + if (ibd /= 0) then + zrefb(1) = albbm(ibd) + zrefd(1) = albdf(ibd) + else + zrefb(1) = 0.5 * (albbm(1) + albbm(2)) + zrefd(1) = 0.5 * (albdf(1) + albdf(2)) + endif + ztrab(1) = f_zero + ztrad(1) = f_zero + +!> -# Compute clear-sky optical parameters, layer reflectance and +!! transmittance. +! - Set up toa direct beam and surface values (beam and diff). +! - Delta scaling for clear-sky condition. +! - General two-stream expressions for physparam::iswmode . +! - Compute homogeneous reflectance and transmittance for both +! conservative and non-conservative scattering. +! - Pre-delta-scaling clear and cloudy direct beam transmittance. +! - Call swflux() to compute the upward and downward radiation +! fluxes. + + do k = nlay, 1, -1 + kp = k + 1 + + ztau0 = max( ftiny, taur(k,jg)+taug(k,jg)+tauae(k,ib) ) + zssa0 = taur(k,jg) + tauae(k,ib)*ssaae(k,ib) + zasy0 = asyae(k,ib)*ssaae(k,ib)*tauae(k,ib) + zssaw = min( oneminus, zssa0 / ztau0 ) + zasyw = zasy0 / max( ftiny, zssa0 ) + +!> - Saving clear-sky quantities for later total-sky usage. + ztaus(k) = ztau0 + zssas(k) = zssa0 + zasys(k) = zasy0 + +!> - Delta scaling for clear-sky condition. + za1 = zasyw * zasyw + za2 = zssaw * za1 + + ztau1 = (f_one - za2) * ztau0 + zssa1 = (zssaw - za2) / (f_one - za2) +!org zasy1 = (zasyw - za1) / (f_one - za1) ! this line is replaced by the next + zasy1 = zasyw / (f_one + zasyw) ! to reduce truncation error + zasy3 = 0.75 * zasy1 + +!> - Perform general two-stream expressions: +!!\n control parameters in module "physparam" +!!\n iswmode - control flag for 2-stream transfer schemes +!!\n = 1 delta-eddington (joseph et al., 1976) +!!\n = 2 pifm (zdunkowski et al., 1980) +!!\n = 3 discrete ordinates (liou, 1973) + if ( iswmode == 1 ) then + zgam1 = 1.75 - zssa1 * (f_one + zasy3) + zgam2 =-0.25 + zssa1 * (f_one - zasy3) + zgam3 = 0.5 - zasy3 * cosz + elseif ( iswmode == 2 ) then ! pifm + zgam1 = 2.0 - zssa1 * (1.25 + zasy3) + zgam2 = 0.75* zssa1 * (f_one- zasy1) + zgam3 = 0.5 - zasy3 * cosz + elseif ( iswmode == 3 ) then ! discrete ordinates + zgam1 = zsr3 * (2.0 - zssa1 * (1.0 + zasy1)) * 0.5 + zgam2 = zsr3 * zssa1 * (1.0 - zasy1) * 0.5 + zgam3 = (1.0 - zsr3 * zasy1 * cosz) * 0.5 + endif + zgam4 = f_one - zgam3 + +!> - Compute homogeneous reflectance and transmittance for both conservative +!! scattering and non-conservative scattering. + + if ( zssaw >= zcrit ) then ! for conservative scattering + za1 = zgam1 * cosz - zgam3 + za2 = zgam1 * ztau1 + +! --- ... use exponential lookup table for transmittance, or expansion +! of exponential for low optical depth + + zb1 = min ( ztau1*sntz , 500.0 ) + if ( zb1 <= od_lo ) then + zb2 = f_one - zb1 + 0.5*zb1*zb1 + else + ftind = zb1 / (bpade + zb1) + itind = ftind*NTBMX + 0.5 + zb2 = exp_tbl(itind) + endif + +! ... collimated beam + zrefb(kp) = max(f_zero, min(f_one, & + & (za2 - za1*(f_one - zb2))/(f_one + za2) )) + ztrab(kp) = max(f_zero, min(f_one, f_one-zrefb(kp) )) + +! ... isotropic incidence + zrefd(kp) = max(f_zero, min(f_one, za2/(f_one + za2) )) + ztrad(kp) = max(f_zero, min(f_one, f_one-zrefd(kp) )) + + else ! for non-conservative scattering + za1 = zgam1*zgam4 + zgam2*zgam3 + za2 = zgam1*zgam3 + zgam2*zgam4 + zrk = sqrt ( (zgam1 - zgam2) * (zgam1 + zgam2) ) + zrk2= 2.0 * zrk + + zrp = zrk * cosz + zrp1 = f_one + zrp + zrm1 = f_one - zrp + zrpp1= f_one - zrp*zrp + zrpp = sign( max(flimit, abs(zrpp1)), zrpp1 ) ! avoid numerical singularity + zrkg1= zrk + zgam1 + zrkg3= zrk * zgam3 + zrkg4= zrk * zgam4 + + zr1 = zrm1 * (za2 + zrkg3) + zr2 = zrp1 * (za2 - zrkg3) + zr3 = zrk2 * (zgam3 - za2*cosz) + zr4 = zrpp * zrkg1 + zr5 = zrpp * (zrk - zgam1) + + zt1 = zrp1 * (za1 + zrkg4) + zt2 = zrm1 * (za1 - zrkg4) + zt3 = zrk2 * (zgam4 + za1*cosz) + +! --- ... use exponential lookup table for transmittance, or expansion +! of exponential for low optical depth + + zb1 = min ( zrk*ztau1, 500.0 ) + if ( zb1 <= od_lo ) then + zexm1 = f_one - zb1 + 0.5*zb1*zb1 + else + ftind = zb1 / (bpade + zb1) + itind = ftind*NTBMX + 0.5 + zexm1 = exp_tbl(itind) + endif + zexp1 = f_one / zexm1 + + zb2 = min ( sntz*ztau1, 500.0 ) + if ( zb2 <= od_lo ) then + zexm2 = f_one - zb2 + 0.5*zb2*zb2 + else + ftind = zb2 / (bpade + zb2) + itind = ftind*NTBMX + 0.5 + zexm2 = exp_tbl(itind) + endif + zexp2 = f_one / zexm2 + ze1r45 = zr4*zexp1 + zr5*zexm1 + +! ... collimated beam + if (ze1r45>=-eps1 .and. ze1r45<=eps1) then + zrefb(kp) = eps1 + ztrab(kp) = zexm2 + else + zden1 = zssa1 / ze1r45 + zrefb(kp) = max(f_zero, min(f_one, & + & (zr1*zexp1 - zr2*zexm1 - zr3*zexm2)*zden1 )) + ztrab(kp) = max(f_zero, min(f_one, zexm2*(f_one & + & - (zt1*zexp1 - zt2*zexm1 - zt3*zexp2)*zden1) )) + endif + +! ... diffuse beam + zden1 = zr4 / (ze1r45 * zrkg1) + zrefd(kp) = max(f_zero, min(f_one, & + & zgam2*(zexp1 - zexm1)*zden1 )) + ztrad(kp) = max(f_zero, min(f_one, zrk2*zden1 )) + endif ! end if_zssaw_block + +!> - Calculate direct beam transmittance. use exponential lookup table +!! for transmittance, or expansion of exponential for low optical depth. + + zr1 = ztau1 * sntz + if ( zr1 <= od_lo ) then + zexp3 = f_one - zr1 + 0.5*zr1*zr1 + else + ftind = zr1 / (bpade + zr1) + itind = max(0, min(NTBMX, int(0.5+NTBMX*ftind) )) + zexp3 = exp_tbl(itind) + endif + + ztdbt(k) = zexp3 * ztdbt(kp) + zldbt(kp) = zexp3 + +!> - Calculate pre-delta-scaling clear and cloudy direct beam transmittance. +! (must use 'orig', unscaled cloud optical depth) + + zr1 = ztau0 * sntz + if ( zr1 <= od_lo ) then + zexp4 = f_one - zr1 + 0.5*zr1*zr1 + else + ftind = zr1 / (bpade + zr1) + itind = max(0, min(NTBMX, int(0.5+NTBMX*ftind) )) + zexp4 = exp_tbl(itind) + endif + + zldbt0(k) = zexp4 + ztdbt0 = zexp4 * ztdbt0 + enddo ! end do_k_loop + +!> -# Call vrtqdr(), to compute the upward and downward radiation fluxes. + call vrtqdr & +! --- inputs: + & ( zrefb,zrefd,ztrab,ztrad,zldbt,ztdbt, & + & nlay, nlp1, & +! --- outputs: + & zfu, zfd & + & ) + +!> -# Compute upward and downward fluxes at levels. + do k = 1, nlp1 + fxup0(k,ib) = fxup0(k,ib) + zsolar*zfu(k) + fxdn0(k,ib) = fxdn0(k,ib) + zsolar*zfd(k) + enddo + +!> -# Compute surface downward beam/diffused flux components. + zb1 = zsolar*ztdbt0 + zb2 = zsolar*(zfd(1) - ztdbt0) + + if (ibd /= 0) then + sfbm0(ibd) = sfbm0(ibd) + zb1 + sfdf0(ibd) = sfdf0(ibd) + zb2 + else + zf1 = 0.5 * zb1 + zf2 = 0.5 * zb2 + sfbm0(1) = sfbm0(1) + zf1 + sfdf0(1) = sfdf0(1) + zf2 + sfbm0(2) = sfbm0(2) + zf1 + sfdf0(2) = sfdf0(2) + zf2 + endif +! sfbm0(ibd) = sfbm0(ibd) + zsolar*ztdbt0 +! sfdf0(ibd) = sfdf0(ibd) + zsolar*(zfd(1) - ztdbt0) + +!> -# Compute total sky optical parameters, layer reflectance and +!! transmittance. +! - Set up toa direct beam and surface values (beam and diff) +! - Delta scaling for total-sky condition +! - General two-stream expressions for physparam::iswmode +! - Compute homogeneous reflectance and transmittance for +! conservative scattering and non-conservative scattering +! - Pre-delta-scaling clear and cloudy direct beam transmittance +! - Call swflux() to compute the upward and downward radiation fluxes + + if ( cf1 > eps ) then + +!> - Set up toa direct beam and surface values (beam and diff). + ztdbt0 = f_one + zldbt(1) = f_zero + + do k = nlay, 1, -1 + kp = k + 1 + zc0 = f_one - cldfrc(k) + zc1 = cldfrc(k) + if ( zc1 > ftiny ) then ! it is a cloudy-layer + + ztau0 = ztaus(k) + taucw(k,ib) + zssa0 = zssas(k) + ssacw(k,ib) + zasy0 = zasys(k) + asycw(k,ib) + zssaw = min(oneminus, zssa0 / ztau0) + zasyw = zasy0 / max(ftiny, zssa0) + +!> - Perform delta scaling for total-sky condition. + za1 = zasyw * zasyw + za2 = zssaw * za1 + + ztau1 = (f_one - za2) * ztau0 + zssa1 = (zssaw - za2) / (f_one - za2) +!org zasy1 = (zasyw - za1) / (f_one - za1) + zasy1 = zasyw / (f_one + zasyw) + zasy3 = 0.75 * zasy1 + +!> - Perform general two-stream expressions: +!!\n control parameters in module "physparam" +!!\n iswmode - control flag for 2-stream transfer schemes +!!\n = 1 delta-eddington (joseph et al., 1976) +!!\n = 2 pifm (zdunkowski et al., 1980) +!!\n = 3 discrete ordinates (liou, 1973) + + if ( iswmode == 1 ) then + zgam1 = 1.75 - zssa1 * (f_one + zasy3) + zgam2 =-0.25 + zssa1 * (f_one - zasy3) + zgam3 = 0.5 - zasy3 * cosz + elseif ( iswmode == 2 ) then ! pifm + zgam1 = 2.0 - zssa1 * (1.25 + zasy3) + zgam2 = 0.75* zssa1 * (f_one- zasy1) + zgam3 = 0.5 - zasy3 * cosz + elseif ( iswmode == 3 ) then ! discrete ordinates + zgam1 = zsr3 * (2.0 - zssa1 * (1.0 + zasy1)) * 0.5 + zgam2 = zsr3 * zssa1 * (1.0 - zasy1) * 0.5 + zgam3 = (1.0 - zsr3 * zasy1 * cosz) * 0.5 + endif + zgam4 = f_one - zgam3 + + zrefb1 = zrefb(kp) + zrefd1 = zrefd(kp) + ztrab1 = ztrab(kp) + ztrad1 = ztrad(kp) + +!> - Compute homogeneous reflectance and transmittance for both conservative +!! and non-conservative scattering. + + if ( zssaw >= zcrit ) then ! for conservative scattering + za1 = zgam1 * cosz - zgam3 + za2 = zgam1 * ztau1 + +! --- ... use exponential lookup table for transmittance, or expansion +! of exponential for low optical depth + + zb1 = min ( ztau1*sntz , 500.0 ) + if ( zb1 <= od_lo ) then + zb2 = f_one - zb1 + 0.5*zb1*zb1 + else + ftind = zb1 / (bpade + zb1) + itind = ftind*NTBMX + 0.5 + zb2 = exp_tbl(itind) + endif + +! ... collimated beam + zrefb(kp) = max(f_zero, min(f_one, & + & (za2 - za1*(f_one - zb2))/(f_one + za2) )) + ztrab(kp) = max(f_zero, min(f_one, f_one-zrefb(kp))) + +! ... isotropic incidence + zrefd(kp) = max(f_zero, min(f_one, za2 / (f_one+za2) )) + ztrad(kp) = max(f_zero, min(f_one, f_one - zrefd(kp) )) + + else ! for non-conservative scattering + za1 = zgam1*zgam4 + zgam2*zgam3 + za2 = zgam1*zgam3 + zgam2*zgam4 + zrk = sqrt ( (zgam1 - zgam2) * (zgam1 + zgam2) ) + zrk2= 2.0 * zrk + + zrp = zrk * cosz + zrp1 = f_one + zrp + zrm1 = f_one - zrp + zrpp1= f_one - zrp*zrp + zrpp = sign( max(flimit, abs(zrpp1)), zrpp1 ) ! avoid numerical singularity + zrkg1= zrk + zgam1 + zrkg3= zrk * zgam3 + zrkg4= zrk * zgam4 + + zr1 = zrm1 * (za2 + zrkg3) + zr2 = zrp1 * (za2 - zrkg3) + zr3 = zrk2 * (zgam3 - za2*cosz) + zr4 = zrpp * zrkg1 + zr5 = zrpp * (zrk - zgam1) + + zt1 = zrp1 * (za1 + zrkg4) + zt2 = zrm1 * (za1 - zrkg4) + zt3 = zrk2 * (zgam4 + za1*cosz) + +! --- ... use exponential lookup table for transmittance, or expansion +! of exponential for low optical depth + + zb1 = min ( zrk*ztau1, 500.0 ) + if ( zb1 <= od_lo ) then + zexm1 = f_one - zb1 + 0.5*zb1*zb1 + else + ftind = zb1 / (bpade + zb1) + itind = ftind*NTBMX + 0.5 + zexm1 = exp_tbl(itind) + endif + zexp1 = f_one / zexm1 + + zb2 = min ( ztau1*sntz, 500.0 ) + if ( zb2 <= od_lo ) then + zexm2 = f_one - zb2 + 0.5*zb2*zb2 + else + ftind = zb2 / (bpade + zb2) + itind = ftind*NTBMX + 0.5 + zexm2 = exp_tbl(itind) + endif + zexp2 = f_one / zexm2 + ze1r45 = zr4*zexp1 + zr5*zexm1 + +! ... collimated beam + if ( ze1r45>=-eps1 .and. ze1r45<=eps1 ) then + zrefb(kp) = eps1 + ztrab(kp) = zexm2 + else + zden1 = zssa1 / ze1r45 + zrefb(kp) = max(f_zero, min(f_one, & + & (zr1*zexp1-zr2*zexm1-zr3*zexm2)*zden1 )) + ztrab(kp) = max(f_zero, min(f_one, zexm2*(f_one - & + & (zt1*zexp1-zt2*zexm1-zt3*zexp2)*zden1) )) + endif + +! ... diffuse beam + zden1 = zr4 / (ze1r45 * zrkg1) + zrefd(kp) = max(f_zero, min(f_one, & + & zgam2*(zexp1 - zexm1)*zden1 )) + ztrad(kp) = max(f_zero, min(f_one, zrk2*zden1 )) + endif ! end if_zssaw_block + +! --- ... combine clear and cloudy contributions for total sky +! and calculate direct beam transmittances + + zrefb(kp) = zc0*zrefb1 + zc1*zrefb(kp) + zrefd(kp) = zc0*zrefd1 + zc1*zrefd(kp) + ztrab(kp) = zc0*ztrab1 + zc1*ztrab(kp) + ztrad(kp) = zc0*ztrad1 + zc1*ztrad(kp) + +! --- ... direct beam transmittance. use exponential lookup table +! for transmittance, or expansion of exponential for low +! optical depth + + zr1 = ztau1 * sntz + if ( zr1 <= od_lo ) then + zexp3 = f_one - zr1 + 0.5*zr1*zr1 + else + ftind = zr1 / (bpade + zr1) + itind = max(0, min(NTBMX, int(0.5+NTBMX*ftind) )) + zexp3 = exp_tbl(itind) + endif + + zldbt(kp) = zc0*zldbt(kp) + zc1*zexp3 + ztdbt(k) = zldbt(kp) * ztdbt(kp) + +!> - Calculate pre-delta-scaling clear and cloudy direct beam transmittance. +! (must use 'orig', unscaled cloud optical depth) + + zr1 = ztau0 * sntz + if ( zr1 <= od_lo ) then + zexp4 = f_one - zr1 + 0.5*zr1*zr1 + else + ftind = zr1 / (bpade + zr1) + itind = max(0, min(NTBMX, int(0.5+NTBMX*ftind) )) + zexp4 = exp_tbl(itind) + endif + + ztdbt0 = (zc0*zldbt0(k) + zc1*zexp4) * ztdbt0 + + else ! if_zc1_block --- it is a clear layer + +! --- ... direct beam transmittance + ztdbt(k) = zldbt(kp) * ztdbt(kp) + +! --- ... pre-delta-scaling clear and cloudy direct beam transmittance + ztdbt0 = zldbt0(k) * ztdbt0 + + endif ! end if_zc1_block + enddo ! end do_k_loop + +!> -# Call vrtqdr(), to compute the upward and downward radiation fluxes. + + call vrtqdr & +! --- inputs: + & ( zrefb,zrefd,ztrab,ztrad,zldbt,ztdbt, & + & nlay, nlp1, & +! --- outputs: + & zfu, zfd & + & ) + +!> -# Compute upward and downward fluxes at levels. + do k = 1, nlp1 + fxupc(k,ib) = fxupc(k,ib) + zsolar*zfu(k) + fxdnc(k,ib) = fxdnc(k,ib) + zsolar*zfd(k) + enddo + +!> -# Process and save outputs. +!! - surface downward beam/diffused flux components + zb1 = zsolar*ztdbt0 + zb2 = zsolar*(zfd(1) - ztdbt0) + + if (ibd /= 0) then + sfbmc(ibd) = sfbmc(ibd) + zb1 + sfdfc(ibd) = sfdfc(ibd) + zb2 + else + zf1 = 0.5 * zb1 + zf2 = 0.5 * zb2 + sfbmc(1) = sfbmc(1) + zf1 + sfdfc(1) = sfdfc(1) + zf2 + sfbmc(2) = sfbmc(2) + zf1 + sfdfc(2) = sfdfc(2) + zf2 + endif +! sfbmc(ibd) = sfbmc(ibd) + zsolar*ztdbt0 +! sfdfc(ibd) = sfdfc(ibd) + zsolar*(zfd(1) - ztdbt0) + + endif ! end if_cf1_block + + enddo lab_do_jg + +! --- ... end of g-point loop + + do ib = 1, nbdsw + ftoadc = ftoadc + fxdn0(nlp1,ib) + ftoau0 = ftoau0 + fxup0(nlp1,ib) + fsfcu0 = fsfcu0 + fxup0(1,ib) + fsfcd0 = fsfcd0 + fxdn0(1,ib) + enddo + +!> - uv-b surface downward flux + ibd = nuvb - nblow + 1 + suvbf0 = fxdn0(1,ibd) + + if ( cf1 <= eps ) then ! clear column, set total-sky=clear-sky fluxes + do ib = 1, nbdsw + do k = 1, nlp1 + fxupc(k,ib) = fxup0(k,ib) + fxdnc(k,ib) = fxdn0(k,ib) + enddo + enddo + + ftoauc = ftoau0 + fsfcuc = fsfcu0 + fsfcdc = fsfcd0 + +!> - surface downward beam/diffused flux components + sfbmc(1) = sfbm0(1) + sfdfc(1) = sfdf0(1) + sfbmc(2) = sfbm0(2) + sfdfc(2) = sfdf0(2) + +!> - uv-b surface downward flux + suvbfc = suvbf0 + else ! cloudy column, compute total-sky fluxes + do ib = 1, nbdsw + do k = 1, nlp1 + fxupc(k,ib) = cf1*fxupc(k,ib) + cf0*fxup0(k,ib) + fxdnc(k,ib) = cf1*fxdnc(k,ib) + cf0*fxdn0(k,ib) + enddo + enddo + + do ib = 1, nbdsw + ftoauc = ftoauc + fxupc(nlp1,ib) + fsfcuc = fsfcuc + fxupc(1,ib) + fsfcdc = fsfcdc + fxdnc(1,ib) + enddo + +!> - uv-b surface downward flux + suvbfc = fxdnc(1,ibd) + +!> - surface downward beam/diffused flux components + sfbmc(1) = cf1*sfbmc(1) + cf0*sfbm0(1) + sfbmc(2) = cf1*sfbmc(2) + cf0*sfbm0(2) + sfdfc(1) = cf1*sfdfc(1) + cf0*sfdf0(1) + sfdfc(2) = cf1*sfdfc(2) + cf0*sfdf0(2) + endif ! end if_cf1_block + + return +!................................... + end subroutine spcvrtc +!----------------------------------- +!> @} + +!>\ingroup module_radsw_main +!> This subroutine computes the shortwave radiative fluxes using +!! two-stream method of h. barder and mcica,the monte-carlo independent +!! column approximation, for the representation of sub-grid cloud +!! variability (i.e. cloud overlap). +!!\param ssolar incoming solar flux at top +!!\param cosz cosine solar zenith angle +!!\param sntz secant solar zenith angle +!!\param albbm surface albedo for direct beam radiation +!!\param albdf surface albedo for diffused radiation +!!\param sfluxzen spectral distribution of incoming solar flux +!!\param cldfmc layer cloud fraction for g-point +!!\param cf1 >0: cloudy sky, otherwise: clear sky +!!\param cf0 =1-cf1 +!!\param taug spectral optical depth for gases +!!\param taur optical depth for rayleigh scattering +!!\param tauae aerosols optical depth +!!\param ssaae aerosols single scattering albedo +!!\param asyae aerosols asymmetry factor +!!\param taucw weighted cloud optical depth +!!\param ssacw weighted cloud single scat albedo +!!\param asycw weighted cloud asymmetry factor +!!\param nlay,nlp1 number of layers/levels +!!\param fxupc tot sky upward flux +!!\param fxdnc tot sky downward flux +!!\param fxup0 clr sky upward flux +!!\param fxdn0 clr sky downward flux +!!\param ftoauc tot sky toa upwd flux +!!\param ftoau0 clr sky toa upwd flux +!!\param ftoadc toa downward (incoming) solar flux +!!\param fsfcuc tot sky sfc upwd flux +!!\param fsfcu0 clr sky sfc upwd flux +!!\param fsfcdc tot sky sfc dnwd flux +!!\param fsfcd0 clr sky sfc dnwd flux +!!\param sfbmc tot sky sfc dnwd beam flux (nir/uv+vis) +!!\param sfdfc tot sky sfc dnwd diff flux (nir/uv+vis) +!!\param sfbm0 clr sky sfc dnwd beam flux (nir/uv+vis) +!!\param sfdf0 clr sky sfc dnwd diff flux (nir/uv+vis) +!!\param suvbfc tot sky sfc dnwd uv-b flux +!!\param suvbf0 clr sky sfc dnwd uv-b flux +!>\section spcvrtm_gen spcvrtm General Algorithm +!! @{ +!----------------------------------- + subroutine spcvrtm & + & ( ssolar,cosz,sntz,albbm,albdf,sfluxzen,cldfmc, & ! --- inputs + & cf1,cf0,taug,taur,tauae,ssaae,asyae,taucw,ssacw,asycw, & + & nlay, nlp1, & + & fxupc,fxdnc,fxup0,fxdn0, & ! --- outputs + & ftoauc,ftoau0,ftoadc,fsfcuc,fsfcu0,fsfcdc,fsfcd0, & + & sfbmc,sfdfc,sfbm0,sfdf0,suvbfc,suvbf0 & + & ) + +! =================== program usage description =================== ! +! ! +! purpose: computes the shortwave radiative fluxes using two-stream ! +! method of h. barker and mcica, the monte-carlo independent! +! column approximation, for the representation of sub-grid ! +! cloud variability (i.e. cloud overlap). ! +! ! +! subprograms called: vrtqdr ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! ssolar - real, incoming solar flux at top 1 ! +! cosz - real, cosine solar zenith angle 1 ! +! sntz - real, secant solar zenith angle 1 ! +! albbm - real, surface albedo for direct beam radiation 2 ! +! albdf - real, surface albedo for diffused radiation 2 ! +! sfluxzen- real, spectral distribution of incoming solar flux ngptsw! +! cldfmc - real, layer cloud fraction for g-point nlay*ngptsw! +! cf1 - real, >0: cloudy sky, otherwise: clear sky 1 ! +! cf0 - real, =1-cf1 1 ! +! taug - real, spectral optical depth for gases nlay*ngptsw! +! taur - real, optical depth for rayleigh scattering nlay*ngptsw! +! tauae - real, aerosols optical depth nlay*nbdsw ! +! ssaae - real, aerosols single scattering albedo nlay*nbdsw ! +! asyae - real, aerosols asymmetry factor nlay*nbdsw ! +! taucw - real, weighted cloud optical depth nlay*nbdsw ! +! ssacw - real, weighted cloud single scat albedo nlay*nbdsw ! +! asycw - real, weighted cloud asymmetry factor nlay*nbdsw ! +! nlay,nlp1 - integer, number of layers/levels 1 ! +! ! +! output variables: ! +! fxupc - real, tot sky upward flux nlp1*nbdsw ! +! fxdnc - real, tot sky downward flux nlp1*nbdsw ! +! fxup0 - real, clr sky upward flux nlp1*nbdsw ! +! fxdn0 - real, clr sky downward flux nlp1*nbdsw ! +! ftoauc - real, tot sky toa upwd flux 1 ! +! ftoau0 - real, clr sky toa upwd flux 1 ! +! ftoadc - real, toa downward (incoming) solar flux 1 ! +! fsfcuc - real, tot sky sfc upwd flux 1 ! +! fsfcu0 - real, clr sky sfc upwd flux 1 ! +! fsfcdc - real, tot sky sfc dnwd flux 1 ! +! fsfcd0 - real, clr sky sfc dnwd flux 1 ! +! sfbmc - real, tot sky sfc dnwd beam flux (nir/uv+vis) 2 ! +! sfdfc - real, tot sky sfc dnwd diff flux (nir/uv+vis) 2 ! +! sfbm0 - real, clr sky sfc dnwd beam flux (nir/uv+vis) 2 ! +! sfdf0 - real, clr sky sfc dnwd diff flux (nir/uv+vis) 2 ! +! suvbfc - real, tot sky sfc dnwd uv-b flux 1 ! +! suvbf0 - real, clr sky sfc dnwd uv-b flux 1 ! +! ! +! internal variables: ! +! zrefb - real, direct beam reflectivity for clear/cloudy nlp1 ! +! zrefd - real, diffuse reflectivity for clear/cloudy nlp1 ! +! ztrab - real, direct beam transmissivity for clear/cloudy nlp1 ! +! ztrad - real, diffuse transmissivity for clear/cloudy nlp1 ! +! zldbt - real, layer beam transmittance for clear/cloudy nlp1 ! +! ztdbt - real, lev total beam transmittance for clr/cld nlp1 ! +! ! +! control parameters in module "physparam" ! +! iswmode - control flag for 2-stream transfer schemes ! +! = 1 delta-eddington (joseph et al., 1976) ! +! = 2 pifm (zdunkowski et al., 1980) ! +! = 3 discrete ordinates (liou, 1973) ! +! ! +! ******************************************************************* ! +! original code description ! +! ! +! method: ! +! ------- ! +! standard delta-eddington, p.i.f.m., or d.o.m. layer calculations. ! +! kmodts = 1 eddington (joseph et al., 1976) ! +! = 2 pifm (zdunkowski et al., 1980) ! +! = 3 discrete ordinates (liou, 1973) ! +! ! +! modifications: ! +! -------------- ! +! original: h. barker ! +! revision: merge with rrtmg_sw: j.-j.morcrette, ecmwf, feb 2003 ! +! revision: add adjustment for earth/sun distance:mjiacono,aer,oct2003! +! revision: bug fix for use of palbp and palbd: mjiacono, aer, nov2003! +! revision: bug fix to apply delta scaling to clear sky: aer, dec2004 ! +! revision: code modified so that delta scaling is not done in cloudy ! +! profiles if routine cldprop is used; delta scaling can be ! +! applied by swithcing code below if cldprop is not used to ! +! get cloud properties. aer, jan 2005 ! +! revision: uniform formatting for rrtmg: mjiacono, aer, jul 2006 ! +! revision: use exponential lookup table for transmittance: mjiacono, ! +! aer, aug 2007 ! +! ! +! ******************************************************************* ! +! ====================== end of description block ================= ! + +! --- constant parameters: + real (kind=kind_phys), parameter :: zcrit = 0.9999995 ! thresold for conservative scattering + real (kind=kind_phys), parameter :: zsr3 = sqrt(3.0) + real (kind=kind_phys), parameter :: od_lo = 0.06 + real (kind=kind_phys), parameter :: eps1 = 1.0e-8 + +! --- inputs: + integer, intent(in) :: nlay, nlp1 + + real (kind=kind_phys), dimension(nlay,ngptsw), intent(in) :: & + & taug, taur, cldfmc + real (kind=kind_phys), dimension(nlay,nbdsw), intent(in) :: & + & taucw, ssacw, asycw, tauae, ssaae, asyae + + real (kind=kind_phys), dimension(ngptsw), intent(in) :: sfluxzen + + real (kind=kind_phys), dimension(2), intent(in) :: albbm, albdf + + real (kind=kind_phys), intent(in) :: cosz, sntz, cf1, cf0, ssolar + +! --- outputs: + real (kind=kind_phys), dimension(nlp1,nbdsw), intent(out) :: & + & fxupc, fxdnc, fxup0, fxdn0 + + real (kind=kind_phys), dimension(2), intent(out) :: sfbmc, sfdfc, & + & sfbm0, sfdf0 + + real (kind=kind_phys), intent(out) :: suvbfc, suvbf0, ftoadc, & + & ftoauc, ftoau0, fsfcuc, fsfcu0, fsfcdc, fsfcd0 + +! --- locals: + real (kind=kind_phys), dimension(nlay) :: ztaus, zssas, zasys, & + & zldbt0 + + real (kind=kind_phys), dimension(nlp1) :: zrefb, zrefd, ztrab, & + & ztrad, ztdbt, zldbt, zfu, zfd + + real (kind=kind_phys) :: ztau1, zssa1, zasy1, ztau0, zssa0, & + & zasy0, zasy3, zssaw, zasyw, zgam1, zgam2, zgam3, zgam4, & + & za1, za2, zb1, zb2, zrk, zrk2, zrp, zrp1, zrm1, zrpp, & + & zrkg1, zrkg3, zrkg4, zexp1, zexm1, zexp2, zexm2, zden1, & + & zexp3, zexp4, ze1r45, ftind, zsolar, ztdbt0, zr1, zr2, & + & zr3, zr4, zr5, zt1, zt2, zt3, zf1, zf2, zrpp1 + + integer :: ib, ibd, jb, jg, k, kp, itind +! +!===> ... begin here +! +!> -# Initialize output fluxes. + + do ib = 1, nbdsw + do k = 1, nlp1 + fxdnc(k,ib) = f_zero + fxupc(k,ib) = f_zero + fxdn0(k,ib) = f_zero + fxup0(k,ib) = f_zero + enddo + enddo + + ftoadc = f_zero + ftoauc = f_zero + ftoau0 = f_zero + fsfcuc = f_zero + fsfcu0 = f_zero + fsfcdc = f_zero + fsfcd0 = f_zero + +!! --- ... uv-b surface downward fluxes + suvbfc = f_zero + suvbf0 = f_zero + +!! --- ... output surface flux components + sfbmc(1) = f_zero + sfbmc(2) = f_zero + sfdfc(1) = f_zero + sfdfc(2) = f_zero + sfbm0(1) = f_zero + sfbm0(2) = f_zero + sfdf0(1) = f_zero + sfdf0(2) = f_zero + +!> -# Loop over all g-points in each band. + + lab_do_jg : do jg = 1, ngptsw + + jb = NGB(jg) + ib = jb + 1 - nblow + ibd = idxsfc(jb) ! spectral band index + + zsolar = ssolar * sfluxzen(jg) + +!> -# Set up toa direct beam and surface values (beam and diff). + + ztdbt(nlp1) = f_one + ztdbt0 = f_one + + zldbt(1) = f_zero + if (ibd /= 0) then + zrefb(1) = albbm(ibd) + zrefd(1) = albdf(ibd) + else + zrefb(1) = 0.5 * (albbm(1) + albbm(2)) + zrefd(1) = 0.5 * (albdf(1) + albdf(2)) + endif + ztrab(1) = f_zero + ztrad(1) = f_zero + +!> -# Compute clear-sky optical parameters, layer reflectance and +!! transmittance. +! - Set up toa direct beam and surface values (beam and diff) +! - Delta scaling for clear-sky condition +! - General two-stream expressions for physparam::iswmode +! - Compute homogeneous reflectance and transmittance for both +! conservative and non-conservative scattering +! - Pre-delta-scaling clear and cloudy direct beam transmittance +! - Call swflux() to compute the upward and downward radiation fluxes + + do k = nlay, 1, -1 + kp = k + 1 + + ztau0 = max( ftiny, taur(k,jg)+taug(k,jg)+tauae(k,ib) ) + zssa0 = taur(k,jg) + tauae(k,ib)*ssaae(k,ib) + zasy0 = asyae(k,ib)*ssaae(k,ib)*tauae(k,ib) + zssaw = min( oneminus, zssa0 / ztau0 ) + zasyw = zasy0 / max( ftiny, zssa0 ) + +!> - Saving clear-sky quantities for later total-sky usage. + ztaus(k) = ztau0 + zssas(k) = zssa0 + zasys(k) = zasy0 + +!> - Delta scaling for clear-sky condition. + za1 = zasyw * zasyw + za2 = zssaw * za1 + + ztau1 = (f_one - za2) * ztau0 + zssa1 = (zssaw - za2) / (f_one - za2) +!org zasy1 = (zasyw - za1) / (f_one - za1) ! this line is replaced by the next + zasy1 = zasyw / (f_one + zasyw) ! to reduce truncation error + zasy3 = 0.75 * zasy1 + +!> - Perform general two-stream expressions: +!!\n control parameters in module "physparam" +!!\n iswmode - control flag for 2-stream transfer schemes +!!\n = 1 delta-eddington (joseph et al., 1976) +!!\n = 2 pifm (zdunkowski et al., 1980) +!!\n = 3 discrete ordinates (liou, 1973) + if ( iswmode == 1 ) then + zgam1 = 1.75 - zssa1 * (f_one + zasy3) + zgam2 =-0.25 + zssa1 * (f_one - zasy3) + zgam3 = 0.5 - zasy3 * cosz + elseif ( iswmode == 2 ) then ! pifm + zgam1 = 2.0 - zssa1 * (1.25 + zasy3) + zgam2 = 0.75* zssa1 * (f_one- zasy1) + zgam3 = 0.5 - zasy3 * cosz + elseif ( iswmode == 3 ) then ! discrete ordinates + zgam1 = zsr3 * (2.0 - zssa1 * (1.0 + zasy1)) * 0.5 + zgam2 = zsr3 * zssa1 * (1.0 - zasy1) * 0.5 + zgam3 = (1.0 - zsr3 * zasy1 * cosz) * 0.5 + endif + zgam4 = f_one - zgam3 + +!> - Compute homogeneous reflectance and transmittance. + + if ( zssaw >= zcrit ) then ! for conservative scattering + za1 = zgam1 * cosz - zgam3 + za2 = zgam1 * ztau1 + +! --- ... use exponential lookup table for transmittance, or expansion +! of exponential for low optical depth + + zb1 = min ( ztau1*sntz , 500.0 ) + if ( zb1 <= od_lo ) then + zb2 = f_one - zb1 + 0.5*zb1*zb1 + else + ftind = zb1 / (bpade + zb1) + itind = ftind*NTBMX + 0.5 + zb2 = exp_tbl(itind) + endif + +! ... collimated beam + zrefb(kp) = max(f_zero, min(f_one, & + & (za2 - za1*(f_one - zb2))/(f_one + za2) )) + ztrab(kp) = max(f_zero, min(f_one, f_one-zrefb(kp) )) + +! ... isotropic incidence + zrefd(kp) = max(f_zero, min(f_one, za2/(f_one + za2) )) + ztrad(kp) = max(f_zero, min(f_one, f_one-zrefd(kp) )) + + else ! for non-conservative scattering + za1 = zgam1*zgam4 + zgam2*zgam3 + za2 = zgam1*zgam3 + zgam2*zgam4 + zrk = sqrt ( (zgam1 - zgam2) * (zgam1 + zgam2) ) + zrk2= 2.0 * zrk + + zrp = zrk * cosz + zrp1 = f_one + zrp + zrm1 = f_one - zrp + zrpp1= f_one - zrp*zrp + zrpp = sign( max(flimit, abs(zrpp1)), zrpp1 ) ! avoid numerical singularity + zrkg1= zrk + zgam1 + zrkg3= zrk * zgam3 + zrkg4= zrk * zgam4 + + zr1 = zrm1 * (za2 + zrkg3) + zr2 = zrp1 * (za2 - zrkg3) + zr3 = zrk2 * (zgam3 - za2*cosz) + zr4 = zrpp * zrkg1 + zr5 = zrpp * (zrk - zgam1) + + zt1 = zrp1 * (za1 + zrkg4) + zt2 = zrm1 * (za1 - zrkg4) + zt3 = zrk2 * (zgam4 + za1*cosz) + +! --- ... use exponential lookup table for transmittance, or expansion +! of exponential for low optical depth + + zb1 = min ( zrk*ztau1, 500.0 ) + if ( zb1 <= od_lo ) then + zexm1 = f_one - zb1 + 0.5*zb1*zb1 + else + ftind = zb1 / (bpade + zb1) + itind = ftind*NTBMX + 0.5 + zexm1 = exp_tbl(itind) + endif + zexp1 = f_one / zexm1 + + zb2 = min ( sntz*ztau1, 500.0 ) + if ( zb2 <= od_lo ) then + zexm2 = f_one - zb2 + 0.5*zb2*zb2 + else + ftind = zb2 / (bpade + zb2) + itind = ftind*NTBMX + 0.5 + zexm2 = exp_tbl(itind) + endif + zexp2 = f_one / zexm2 + ze1r45 = zr4*zexp1 + zr5*zexm1 + +! ... collimated beam + if (ze1r45>=-eps1 .and. ze1r45<=eps1) then + zrefb(kp) = eps1 + ztrab(kp) = zexm2 + else + zden1 = zssa1 / ze1r45 + zrefb(kp) = max(f_zero, min(f_one, & + & (zr1*zexp1 - zr2*zexm1 - zr3*zexm2)*zden1 )) + ztrab(kp) = max(f_zero, min(f_one, zexm2*(f_one & + & - (zt1*zexp1 - zt2*zexm1 - zt3*zexp2)*zden1) )) + endif + +! ... diffuse beam + zden1 = zr4 / (ze1r45 * zrkg1) + zrefd(kp) = max(f_zero, min(f_one, & + & zgam2*(zexp1 - zexm1)*zden1 )) + ztrad(kp) = max(f_zero, min(f_one, zrk2*zden1 )) + endif ! end if_zssaw_block + +!> - Calculate direct beam transmittance. use exponential lookup table +!! for transmittance, or expansion of exponential for low optical depth. + + zr1 = ztau1 * sntz + if ( zr1 <= od_lo ) then + zexp3 = f_one - zr1 + 0.5*zr1*zr1 + else + ftind = zr1 / (bpade + zr1) + itind = max(0, min(NTBMX, int(0.5+NTBMX*ftind) )) + zexp3 = exp_tbl(itind) + endif + + ztdbt(k) = zexp3 * ztdbt(kp) + zldbt(kp) = zexp3 + +!> - Calculate pre-delta-scaling clear and cloudy direct beam transmittance. +! (must use 'orig', unscaled cloud optical depth) + + zr1 = ztau0 * sntz + if ( zr1 <= od_lo ) then + zexp4 = f_one - zr1 + 0.5*zr1*zr1 + else + ftind = zr1 / (bpade + zr1) + itind = max(0, min(NTBMX, int(0.5+NTBMX*ftind) )) + zexp4 = exp_tbl(itind) + endif + + zldbt0(k) = zexp4 + ztdbt0 = zexp4 * ztdbt0 + enddo ! end do_k_loop + +!> -# Call vrtqdr(), to compute the upward and downward radiation fluxes. + call vrtqdr & +! --- inputs: + & ( zrefb,zrefd,ztrab,ztrad,zldbt,ztdbt, & + & nlay, nlp1, & +! --- outputs: + & zfu, zfd & + & ) + +!> -# Compute upward and downward fluxes at levels. + do k = 1, nlp1 + fxup0(k,ib) = fxup0(k,ib) + zsolar*zfu(k) + fxdn0(k,ib) = fxdn0(k,ib) + zsolar*zfd(k) + enddo + +!> -# Compute surface downward beam/diffuse flux components. + zb1 = zsolar*ztdbt0 + zb2 = zsolar*(zfd(1) - ztdbt0) + + if (ibd /= 0) then + sfbm0(ibd) = sfbm0(ibd) + zb1 + sfdf0(ibd) = sfdf0(ibd) + zb2 + else + zf1 = 0.5 * zb1 + zf2 = 0.5 * zb2 + sfbm0(1) = sfbm0(1) + zf1 + sfdf0(1) = sfdf0(1) + zf2 + sfbm0(2) = sfbm0(2) + zf1 + sfdf0(2) = sfdf0(2) + zf2 + endif +! sfbm0(ibd) = sfbm0(ibd) + zsolar*ztdbt0 +! sfdf0(ibd) = sfdf0(ibd) + zsolar*(zfd(1) - ztdbt0) + +!> -# Compute total sky optical parameters, layer reflectance and +!! transmittance. +! - Set up toa direct beam and surface values (beam and diff) +! - Delta scaling for total-sky condition +! - General two-stream expressions for physparam::iswmode +! - Compute homogeneous reflectance and transmittance for +! conservative scattering and non-conservative scattering +! - Pre-delta-scaling clear and cloudy direct beam transmittance +! - Call swflux() to compute the upward and downward radiation fluxes + + if ( cf1 > eps ) then + +!> - Set up toa direct beam and surface values (beam and diff). + ztdbt0 = f_one + zldbt(1) = f_zero + + do k = nlay, 1, -1 + kp = k + 1 + if ( cldfmc(k,jg) > ftiny ) then ! it is a cloudy-layer + + ztau0 = ztaus(k) + taucw(k,ib) + zssa0 = zssas(k) + ssacw(k,ib) + zasy0 = zasys(k) + asycw(k,ib) + zssaw = min(oneminus, zssa0 / ztau0) + zasyw = zasy0 / max(ftiny, zssa0) + +!> - Perform delta scaling for total-sky condition. + za1 = zasyw * zasyw + za2 = zssaw * za1 + + ztau1 = (f_one - za2) * ztau0 + zssa1 = (zssaw - za2) / (f_one - za2) +!org zasy1 = (zasyw - za1) / (f_one - za1) + zasy1 = zasyw / (f_one + zasyw) + zasy3 = 0.75 * zasy1 + +!> - Perform general two-stream expressions. + if ( iswmode == 1 ) then + zgam1 = 1.75 - zssa1 * (f_one + zasy3) + zgam2 =-0.25 + zssa1 * (f_one - zasy3) + zgam3 = 0.5 - zasy3 * cosz + elseif ( iswmode == 2 ) then ! pifm + zgam1 = 2.0 - zssa1 * (1.25 + zasy3) + zgam2 = 0.75* zssa1 * (f_one- zasy1) + zgam3 = 0.5 - zasy3 * cosz + elseif ( iswmode == 3 ) then ! discrete ordinates + zgam1 = zsr3 * (2.0 - zssa1 * (1.0 + zasy1)) * 0.5 + zgam2 = zsr3 * zssa1 * (1.0 - zasy1) * 0.5 + zgam3 = (1.0 - zsr3 * zasy1 * cosz) * 0.5 + endif + zgam4 = f_one - zgam3 + +!> - Compute homogeneous reflectance and transmittance for both convertive +!! and non-convertive scattering. + + if ( zssaw >= zcrit ) then ! for conservative scattering + za1 = zgam1 * cosz - zgam3 + za2 = zgam1 * ztau1 + +! --- ... use exponential lookup table for transmittance, or expansion +! of exponential for low optical depth + + zb1 = min ( ztau1*sntz , 500.0 ) + if ( zb1 <= od_lo ) then + zb2 = f_one - zb1 + 0.5*zb1*zb1 + else + ftind = zb1 / (bpade + zb1) + itind = ftind*NTBMX + 0.5 + zb2 = exp_tbl(itind) + endif + +! ... collimated beam + zrefb(kp) = max(f_zero, min(f_one, & + & (za2 - za1*(f_one - zb2))/(f_one + za2) )) + ztrab(kp) = max(f_zero, min(f_one, f_one-zrefb(kp))) + +! ... isotropic incidence + zrefd(kp) = max(f_zero, min(f_one, za2 / (f_one+za2) )) + ztrad(kp) = max(f_zero, min(f_one, f_one - zrefd(kp) )) + + else ! for non-conservative scattering + za1 = zgam1*zgam4 + zgam2*zgam3 + za2 = zgam1*zgam3 + zgam2*zgam4 + zrk = sqrt ( (zgam1 - zgam2) * (zgam1 + zgam2) ) + zrk2= 2.0 * zrk + + zrp = zrk * cosz + zrp1 = f_one + zrp + zrm1 = f_one - zrp + zrpp1= f_one - zrp*zrp + zrpp = sign( max(flimit, abs(zrpp1)), zrpp1 ) ! avoid numerical singularity + zrkg1= zrk + zgam1 + zrkg3= zrk * zgam3 + zrkg4= zrk * zgam4 + + zr1 = zrm1 * (za2 + zrkg3) + zr2 = zrp1 * (za2 - zrkg3) + zr3 = zrk2 * (zgam3 - za2*cosz) + zr4 = zrpp * zrkg1 + zr5 = zrpp * (zrk - zgam1) + + zt1 = zrp1 * (za1 + zrkg4) + zt2 = zrm1 * (za1 - zrkg4) + zt3 = zrk2 * (zgam4 + za1*cosz) + +! --- ... use exponential lookup table for transmittance, or expansion +! of exponential for low optical depth + + zb1 = min ( zrk*ztau1, 500.0 ) + if ( zb1 <= od_lo ) then + zexm1 = f_one - zb1 + 0.5*zb1*zb1 + else + ftind = zb1 / (bpade + zb1) + itind = ftind*NTBMX + 0.5 + zexm1 = exp_tbl(itind) + endif + zexp1 = f_one / zexm1 + + zb2 = min ( ztau1*sntz, 500.0 ) + if ( zb2 <= od_lo ) then + zexm2 = f_one - zb2 + 0.5*zb2*zb2 + else + ftind = zb2 / (bpade + zb2) + itind = ftind*NTBMX + 0.5 + zexm2 = exp_tbl(itind) + endif + zexp2 = f_one / zexm2 + ze1r45 = zr4*zexp1 + zr5*zexm1 + +! ... collimated beam + if ( ze1r45>=-eps1 .and. ze1r45<=eps1 ) then + zrefb(kp) = eps1 + ztrab(kp) = zexm2 + else + zden1 = zssa1 / ze1r45 + zrefb(kp) = max(f_zero, min(f_one, & + & (zr1*zexp1-zr2*zexm1-zr3*zexm2)*zden1 )) + ztrab(kp) = max(f_zero, min(f_one, zexm2*(f_one - & + & (zt1*zexp1-zt2*zexm1-zt3*zexp2)*zden1) )) + endif + +! ... diffuse beam + zden1 = zr4 / (ze1r45 * zrkg1) + zrefd(kp) = max(f_zero, min(f_one, & + & zgam2*(zexp1 - zexm1)*zden1 )) + ztrad(kp) = max(f_zero, min(f_one, zrk2*zden1 )) + endif ! end if_zssaw_block + +! --- ... direct beam transmittance. use exponential lookup table +! for transmittance, or expansion of exponential for low +! optical depth + + zr1 = ztau1 * sntz + if ( zr1 <= od_lo ) then + zexp3 = f_one - zr1 + 0.5*zr1*zr1 + else + ftind = zr1 / (bpade + zr1) + itind = max(0, min(NTBMX, int(0.5+NTBMX*ftind) )) + zexp3 = exp_tbl(itind) + endif + + zldbt(kp) = zexp3 + ztdbt(k) = zexp3 * ztdbt(kp) + +! --- ... pre-delta-scaling clear and cloudy direct beam transmittance +! (must use 'orig', unscaled cloud optical depth) + + zr1 = ztau0 * sntz + if ( zr1 <= od_lo ) then + zexp4 = f_one - zr1 + 0.5*zr1*zr1 + else + ftind = zr1 / (bpade + zr1) + itind = max(0, min(NTBMX, int(0.5+NTBMX*ftind) )) + zexp4 = exp_tbl(itind) + endif + + ztdbt0 = zexp4 * ztdbt0 + + else ! if_cldfmc_block --- it is a clear layer + +! --- ... direct beam transmittance + ztdbt(k) = zldbt(kp) * ztdbt(kp) + +!> - Calculate pre-delta-scaling clear and cloudy direct beam transmittance. + ztdbt0 = zldbt0(k) * ztdbt0 + + endif ! end if_cldfmc_block + enddo ! end do_k_loop + +!> -# Call vrtqdr(), to perform vertical quadrature + + call vrtqdr & +! --- inputs: + & ( zrefb,zrefd,ztrab,ztrad,zldbt,ztdbt, & + & nlay, nlp1, & +! --- outputs: + & zfu, zfd & + & ) + +! --- ... compute upward and downward fluxes at levels + do k = 1, nlp1 + fxupc(k,ib) = fxupc(k,ib) + zsolar*zfu(k) + fxdnc(k,ib) = fxdnc(k,ib) + zsolar*zfd(k) + enddo + +!> -# Process and save outputs. +!! - surface downward beam/diffused flux components + zb1 = zsolar*ztdbt0 + zb2 = zsolar*(zfd(1) - ztdbt0) + + if (ibd /= 0) then + sfbmc(ibd) = sfbmc(ibd) + zb1 + sfdfc(ibd) = sfdfc(ibd) + zb2 + else + zf1 = 0.5 * zb1 + zf2 = 0.5 * zb2 + sfbmc(1) = sfbmc(1) + zf1 + sfdfc(1) = sfdfc(1) + zf2 + sfbmc(2) = sfbmc(2) + zf1 + sfdfc(2) = sfdfc(2) + zf2 + endif +! sfbmc(ibd) = sfbmc(ibd) + zsolar*ztdbt0 +! sfdfc(ibd) = sfdfc(ibd) + zsolar*(zfd(1) - ztdbt0) + + endif ! end if_cf1_block + + enddo lab_do_jg + +! --- ... end of g-point loop + + do ib = 1, nbdsw + ftoadc = ftoadc + fxdn0(nlp1,ib) + ftoau0 = ftoau0 + fxup0(nlp1,ib) + fsfcu0 = fsfcu0 + fxup0(1,ib) + fsfcd0 = fsfcd0 + fxdn0(1,ib) + enddo + +!> - uv-b surface downward flux + ibd = nuvb - nblow + 1 + suvbf0 = fxdn0(1,ibd) + + if ( cf1 <= eps ) then ! clear column, set total-sky=clear-sky fluxes + do ib = 1, nbdsw + do k = 1, nlp1 + fxupc(k,ib) = fxup0(k,ib) + fxdnc(k,ib) = fxdn0(k,ib) + enddo + enddo + + ftoauc = ftoau0 + fsfcuc = fsfcu0 + fsfcdc = fsfcd0 + +!> - surface downward beam/diffused flux components + sfbmc(1) = sfbm0(1) + sfdfc(1) = sfdf0(1) + sfbmc(2) = sfbm0(2) + sfdfc(2) = sfdf0(2) + +!> - uv-b surface downward flux + suvbfc = suvbf0 + else ! cloudy column, compute total-sky fluxes + do ib = 1, nbdsw + ftoauc = ftoauc + fxupc(nlp1,ib) + fsfcuc = fsfcuc + fxupc(1,ib) + fsfcdc = fsfcdc + fxdnc(1,ib) + enddo + +!! --- ... uv-b surface downward flux + suvbfc = fxdnc(1,ibd) + endif ! end if_cf1_block + + return +!................................... + end subroutine spcvrtm +!! @} +!----------------------------------- + +!>\ingroup module_radsw_main +!> This subroutine is called by spcvrtc() and spcvrtm(), and computes +!! the upward and downward radiation fluxes. +!!\param zrefb layer direct beam reflectivity +!!\param zrefd layer diffuse reflectivity +!!\param ztrab layer direct beam transmissivity +!!\param ztrad layer diffuse transmissivity +!!\param zldbt layer mean beam transmittance +!!\param ztdbt total beam transmittance at levels +!!\param NLAY, NLP1 number of layers/levels +!!\param zfu upward flux at layer interface +!!\param zfd downward flux at layer interface +!!\section General_vrtqdr vrtqdr General Algorithm +!> @{ +!----------------------------------- + subroutine vrtqdr & + & ( zrefb,zrefd,ztrab,ztrad,zldbt,ztdbt, & ! inputs + & NLAY, NLP1, & + & zfu, zfd & ! outputs: + & ) + +! =================== program usage description =================== ! +! ! +! purpose: computes the upward and downward radiation fluxes ! +! ! +! interface: "vrtqdr" is called by "spcvrc" and "spcvrm" ! +! ! +! subroutines called : none ! +! ! +! ==================== defination of variables ==================== ! +! ! +! input variables: ! +! zrefb(NLP1) - layer direct beam reflectivity ! +! zrefd(NLP1) - layer diffuse reflectivity ! +! ztrab(NLP1) - layer direct beam transmissivity ! +! ztrad(NLP1) - layer diffuse transmissivity ! +! zldbt(NLP1) - layer mean beam transmittance ! +! ztdbt(NLP1) - total beam transmittance at levels ! +! NLAY, NLP1 - number of layers/levels ! +! ! +! output variables: ! +! zfu (NLP1) - upward flux at layer interface ! +! zfd (NLP1) - downward flux at layer interface ! +! ! +! ******************************************************************* ! +! ====================== end of description block ================= ! + +! --- inputs: + integer, intent(in) :: nlay, nlp1 + + real (kind=kind_phys), dimension(nlp1), intent(in) :: zrefb, & + & zrefd, ztrab, ztrad, ztdbt, zldbt + +! --- outputs: + real (kind=kind_phys), dimension(nlp1), intent(out) :: zfu, zfd + +! --- locals: + real (kind=kind_phys), dimension(nlp1) :: zrupb,zrupd,zrdnd,ztdn + + real (kind=kind_phys) :: zden1 + + integer :: k, kp +! +!===> ... begin here +! + +!> -# Link lowest layer with surface. + zrupb(1) = zrefb(1) ! direct beam + zrupd(1) = zrefd(1) ! diffused + +!> -# Pass from bottom to top. + do k = 1, nlay + kp = k + 1 + + zden1 = f_one / ( f_one - zrupd(k)*zrefd(kp) ) + zrupb(kp) = zrefb(kp) + ( ztrad(kp) * & + & ( (ztrab(kp) - zldbt(kp))*zrupd(k) + & + & zldbt(kp)*zrupb(k)) ) * zden1 + zrupd(kp) = zrefd(kp) + ztrad(kp)*ztrad(kp)*zrupd(k)*zden1 + enddo + +!> -# Upper boundary conditions + ztdn (nlp1) = f_one + zrdnd(nlp1) = f_zero + ztdn (nlay) = ztrab(nlp1) + zrdnd(nlay) = zrefd(nlp1) + +!> -# Pass from top to bottom + do k = nlay, 2, -1 + zden1 = f_one / (f_one - zrefd(k)*zrdnd(k)) + ztdn (k-1) = ztdbt(k)*ztrab(k) + ( ztrad(k) * & + & ( (ztdn(k) - ztdbt(k)) + ztdbt(k) * & + & zrefb(k)*zrdnd(k) )) * zden1 + zrdnd(k-1) = zrefd(k) + ztrad(k)*ztrad(k)*zrdnd(k)*zden1 + enddo + +!> -# Up and down-welling fluxes at levels. + do k = 1, nlp1 + zden1 = f_one / (f_one - zrdnd(k)*zrupd(k)) + zfu(k) = ( ztdbt(k)*zrupb(k) + & + & (ztdn(k) - ztdbt(k))*zrupd(k) ) * zden1 + zfd(k) = ztdbt(k) + ( ztdn(k) - ztdbt(k) + & + & ztdbt(k)*zrupb(k)*zrdnd(k) ) * zden1 + enddo + + return +!................................... + end subroutine vrtqdr +!----------------------------------- +!> @} + +!>\ingroup module_radsw_main +!> This subroutine calculates optical depths for gaseous absorption and +!! rayleigh scattering +!!\n subroutine called taumol## (## = 16-29) +!!\param colamt column amounts of absorbing gases the index +!! are for h2o, co2, o3, n2o, ch4, and o2, +!! respectively \f$(mol/cm^2)\f$ +!!\param colmol total column amount (dry air+water vapor) +!!\param fac00,fac01,fac10,fac11 for each layer, these are factors that are +!! needed to compute the interpolation factors +!! that multiply the appropriate reference +!! k-values. a value of 0/1 for i,j indicates +!! that the corresponding factor multiplies +!! reference k-value for the lower/higher of the +!! two appropriate temperatures, and altitudes, +!! respectively. +!!\param jp the index of the lower (in altitude) of the +!! two appropriate ref pressure levels needed +!! for interpolation. +!!\param jt, jt1 the indices of the lower of the two approp +!! ref temperatures needed for interpolation +!! (for pressure levels jp and jp+1, respectively) +!!\param laytrop tropopause layer index +!!\param forfac scale factor needed to foreign-continuum. +!!\param forfrac factor needed for temperature interpolation +!!\param indfor index of the lower of the two appropriate +!! reference temperatures needed for +!! foreign-continuum interpolation +!!\param selffac scale factor needed to h2o self-continuum. +!!\param selffrac factor needed for temperature interpolation +!! of reference h2o self-continuum data +!!\param indself index of the lower of the two appropriate +!! reference temperatures needed for the +!! self-continuum interpolation +!!\param nlay number of vertical layers +!!\param sfluxzen spectral distribution of incoming solar flux +!!\param taug spectral optical depth for gases +!!\param taur opt depth for rayleigh scattering +!>\section gen_al_taumol taumol General Algorithm +!! @{ +!----------------------------------- + subroutine taumol & + & ( colamt,colmol,fac00,fac01,fac10,fac11,jp,jt,jt1,laytrop, & ! --- inputs + & forfac,forfrac,indfor,selffac,selffrac,indself, nlay, & + & sfluxzen, taug, taur & ! --- outputs + & ) + +! ================== program usage description ================== ! +! ! +! description: ! +! calculate optical depths for gaseous absorption and rayleigh ! +! scattering. ! +! ! +! subroutines called: taugb## (## = 16 - 29) ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! colamt - real, column amounts of absorbing gases the index ! +! are for h2o, co2, o3, n2o, ch4, and o2, ! +! respectively (molecules/cm**2) nlay*maxgas! +! colmol - real, total column amount (dry air+water vapor) nlay ! +! facij - real, for each layer, these are factors that are ! +! needed to compute the interpolation factors ! +! that multiply the appropriate reference k- ! +! values. a value of 0/1 for i,j indicates ! +! that the corresponding factor multiplies ! +! reference k-value for the lower/higher of the ! +! two appropriate temperatures, and altitudes, ! +! respectively. naly ! +! jp - real, the index of the lower (in altitude) of the ! +! two appropriate ref pressure levels needed ! +! for interpolation. nlay ! +! jt, jt1 - integer, the indices of the lower of the two approp ! +! ref temperatures needed for interpolation (for ! +! pressure levels jp and jp+1, respectively) nlay ! +! laytrop - integer, tropopause layer index 1 ! +! forfac - real, scale factor needed to foreign-continuum. nlay ! +! forfrac - real, factor needed for temperature interpolation nlay ! +! indfor - integer, index of the lower of the two appropriate ! +! reference temperatures needed for foreign- ! +! continuum interpolation nlay ! +! selffac - real, scale factor needed to h2o self-continuum. nlay ! +! selffrac- real, factor needed for temperature interpolation ! +! of reference h2o self-continuum data nlay ! +! indself - integer, index of the lower of the two appropriate ! +! reference temperatures needed for the self- ! +! continuum interpolation nlay ! +! nlay - integer, number of vertical layers 1 ! +! ! +! output: ! +! sfluxzen- real, spectral distribution of incoming solar flux ngptsw! +! taug - real, spectral optical depth for gases nlay*ngptsw! +! taur - real, opt depth for rayleigh scattering nlay*ngptsw! +! ! +! =================================================================== ! +! ************ original subprogram description *************** ! +! ! +! optical depths developed for the ! +! ! +! rapid radiative transfer model (rrtm) ! +! ! +! atmospheric and environmental research, inc. ! +! 131 hartwell avenue ! +! lexington, ma 02421 ! +! ! +! ! +! eli j. mlawer ! +! jennifer delamere ! +! steven j. taubman ! +! shepard a. clough ! +! ! +! ! +! ! +! email: mlawer@aer.com ! +! email: jdelamer@aer.com ! +! ! +! the authors wish to acknowledge the contributions of the ! +! following people: patrick d. brown, michael j. iacono, ! +! ronald e. farren, luke chen, robert bergstrom. ! +! ! +! ******************************************************************* ! +! ! +! taumol ! +! ! +! this file contains the subroutines taugbn (where n goes from ! +! 16 to 29). taugbn calculates the optical depths and Planck ! +! fractions per g-value and layer for band n. ! +! ! +! output: optical depths (unitless) ! +! fractions needed to compute planck functions at every layer ! +! and g-value ! +! ! +! modifications: ! +! ! +! revised: adapted to f90 coding, j.-j.morcrette, ecmwf, feb 2003 ! +! revised: modified for g-point reduction, mjiacono, aer, dec 2003 ! +! revised: reformatted for consistency with rrtmg_lw, mjiacono, aer, ! +! jul 2006 ! +! ! +! ******************************************************************* ! +! ====================== end of description block ================= ! + +! --- inputs: + integer, intent(in) :: nlay, laytrop + + integer, dimension(nlay), intent(in) :: indfor, indself, & + & jp, jt, jt1 + + real (kind=kind_phys), dimension(nlay), intent(in) :: colmol, & + & fac00, fac01, fac10, fac11, forfac, forfrac, selffac, & + & selffrac + + real (kind=kind_phys), dimension(nlay,maxgas),intent(in) :: colamt + +! --- outputs: + real (kind=kind_phys), dimension(ngptsw), intent(out) :: sfluxzen + + real (kind=kind_phys), dimension(nlay,ngptsw), intent(out) :: & + & taug, taur + +! --- locals: + real (kind=kind_phys) :: fs, speccomb, specmult, colm1, colm2 + + integer, dimension(nlay,nblow:nbhgh) :: id0, id1 + + integer :: ibd, j, jb, js, k, klow, khgh, klim, ks, njb, ns +! +!===> ... begin here +! +! --- ... loop over each spectral band + + do jb = nblow, nbhgh + +! --- ... indices for layer optical depth + + do k = 1, laytrop + id0(k,jb) = ((jp(k)-1)*5 + (jt (k)-1)) * nspa(jb) + id1(k,jb) = ( jp(k) *5 + (jt1(k)-1)) * nspa(jb) + enddo + + do k = laytrop+1, nlay + id0(k,jb) = ((jp(k)-13)*5 + (jt (k)-1)) * nspb(jb) + id1(k,jb) = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(jb) + enddo + +! --- ... calculate spectral flux at toa + + ibd = ibx(jb) + njb = ng (jb) + ns = ngs(jb) + + select case (jb) + + case (16, 20, 23, 25, 26, 29) + + do j = 1, njb + sfluxzen(ns+j) = sfluxref01(j,1,ibd) + enddo + + case (27) + + do j = 1, njb + sfluxzen(ns+j) = scalekur * sfluxref01(j,1,ibd) + enddo + + case default + + if (jb==17 .or. jb==28) then + + ks = nlay + lab_do_k1 : do k = laytrop, nlay-1 + if (jp(k)=layreffr(jb)) then + ks = k + 1 + exit lab_do_k1 + endif + enddo lab_do_k1 + + colm1 = colamt(ks,ix1(jb)) + colm2 = colamt(ks,ix2(jb)) + speccomb = colm1 + strrat(jb)*colm2 + specmult = specwt(jb) * min( oneminus, colm1/speccomb ) + js = 1 + int( specmult ) + fs = mod(specmult, f_one) + + do j = 1, njb + sfluxzen(ns+j) = sfluxref02(j,js,ibd) & + & + fs * (sfluxref02(j,js+1,ibd) - sfluxref02(j,js,ibd)) + enddo + + else + + ks = laytrop + lab_do_k2 : do k = 1, laytrop-1 + if (jp(k)=layreffr(jb)) then + ks = k + 1 + exit lab_do_k2 + endif + enddo lab_do_k2 + + colm1 = colamt(ks,ix1(jb)) + colm2 = colamt(ks,ix2(jb)) + speccomb = colm1 + strrat(jb)*colm2 + specmult = specwt(jb) * min( oneminus, colm1/speccomb ) + js = 1 + int( specmult ) + fs = mod(specmult, f_one) + + do j = 1, njb + sfluxzen(ns+j) = sfluxref03(j,js,ibd) & + & + fs * (sfluxref03(j,js+1,ibd) - sfluxref03(j,js,ibd)) + enddo + + endif + + end select + + enddo + +!> - Call taumol## (##: 16-29) to calculate layer optical depth. + +!> - call taumol16() + call taumol16 +!> - call taumol17() + call taumol17 +!> - call taumol18() + call taumol18 +!> - call taumol19() + call taumol19 +!> - call taumol20() + call taumol20 +!> - call taumol21() + call taumol21 +!> - call taumol22() + call taumol22 +!> - call taumol23() + call taumol23 +!> - call taumol24() + call taumol24 +!> - call taumol25() + call taumol25 +!> - call taumol26() + call taumol26 +!> - call taumol27() + call taumol27 +!> - call taumol28() + call taumol28 +!> - call taumol29() + call taumol29 + + +! ================= + contains +! ================= + +!>\ingroup module_radsw_main +!> The subroutine computes the optical depth in band 16: 2600-3250 +!! cm-1 (low - h2o,ch4; high - ch4) +!----------------------------------- + subroutine taumol16 +!................................... + +! ------------------------------------------------------------------ ! +! band 16: 2600-3250 cm-1 (low - h2o,ch4; high - ch4) ! +! ------------------------------------------------------------------ ! +! + use module_radsw_kgb16 + +! --- locals: + + real (kind=kind_phys) :: speccomb, specmult, tauray, fs, fs1, & + & fac000,fac001,fac010,fac011, fac100,fac101,fac110,fac111 + + integer :: ind01, ind02, ind03, ind04, ind11, ind12, ind13, ind14 + integer :: inds, indf, indsp, indfp, j, js, k + +! +!===> ... begin here +! + +! --- ... compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. below laytrop, the water +! vapor self-continuum is interpolated (in temperature) separately. + + do k = 1, nlay + tauray = colmol(k) * rayl + + do j = 1, NG16 + taur(k,NS16+j) = tauray + enddo + enddo + + do k = 1, laytrop + speccomb = colamt(k,1) + strrat(16)*colamt(k,5) + specmult = 8.0 * min( oneminus, colamt(k,1)/speccomb ) + + js = 1 + int( specmult ) + fs = mod( specmult, f_one ) + fs1= f_one - fs + fac000 = fs1 * fac00(k) + fac010 = fs1 * fac10(k) + fac100 = fs * fac00(k) + fac110 = fs * fac10(k) + fac001 = fs1 * fac01(k) + fac011 = fs1 * fac11(k) + fac101 = fs * fac01(k) + fac111 = fs * fac11(k) + + ind01 = id0(k,16) + js + ind02 = ind01 + 1 + ind03 = ind01 + 9 + ind04 = ind01 + 10 + ind11 = id1(k,16) + js + ind12 = ind11 + 1 + ind13 = ind11 + 9 + ind14 = ind11 + 10 + inds = indself(k) + indf = indfor (k) + indsp= inds + 1 + indfp= indf + 1 + + do j = 1, NG16 + taug(k,NS16+j) = speccomb & + & *( fac000 * absa(ind01,j) + fac100 * absa(ind02,j) & + & + fac010 * absa(ind03,j) + fac110 * absa(ind04,j) & + & + fac001 * absa(ind11,j) + fac101 * absa(ind12,j) & + & + fac011 * absa(ind13,j) + fac111 * absa(ind14,j) ) & + & + colamt(k,1) * (selffac(k) * (selfref(inds,j) & + & + selffrac(k) * (selfref(indsp,j)-selfref(inds,j))) & + & + forfac(k) * (forref(indf,j) + forfrac(k) & + & * (forref(indfp,j) - forref(indf,j)))) + enddo + enddo + + do k = laytrop+1, nlay + ind01 = id0(k,16) + 1 + ind02 = ind01 + 1 + ind11 = id1(k,16) + 1 + ind12 = ind11 + 1 + + do j = 1, NG16 + taug(k,NS16+j) = colamt(k,5) & + & * ( fac00(k)*absb(ind01,j) + fac10(k)*absb(ind02,j) & + & + fac01(k)*absb(ind11,j) + fac11(k)*absb(ind12,j) ) + enddo + enddo + + return +!................................... + end subroutine taumol16 +!----------------------------------- + +!>\ingroup module_radsw_main +!> The subroutine computes the optical depth in band 17: 3250-4000 +!! cm-1 (low - h2o,co2; high - h2o,co2) +!----------------------------------- + subroutine taumol17 +!................................... + +! ------------------------------------------------------------------ ! +! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o,co2) ! +! ------------------------------------------------------------------ ! +! + use module_radsw_kgb17 + +! --- locals: + real (kind=kind_phys) :: speccomb, specmult, tauray, fs, fs1, & + & fac000,fac001,fac010,fac011, fac100,fac101,fac110,fac111 + + integer :: ind01, ind02, ind03, ind04, ind11, ind12, ind13, ind14 + integer :: inds, indf, indsp, indfp, j, js, k + +! +!===> ... begin here +! + +! --- ... compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. below laytrop, the water +! vapor self-continuum is interpolated (in temperature) separately. + + do k = 1, nlay + tauray = colmol(k) * rayl + + do j = 1, NG17 + taur(k,NS17+j) = tauray + enddo + enddo + + do k = 1, laytrop + speccomb = colamt(k,1) + strrat(17)*colamt(k,2) + specmult = 8.0 * min(oneminus, colamt(k,1) / speccomb) + + js = 1 + int(specmult) + fs = mod(specmult, f_one) + fs1= f_one - fs + fac000 = fs1 * fac00(k) + fac010 = fs1 * fac10(k) + fac100 = fs * fac00(k) + fac110 = fs * fac10(k) + fac001 = fs1 * fac01(k) + fac011 = fs1 * fac11(k) + fac101 = fs * fac01(k) + fac111 = fs * fac11(k) + + ind01 = id0(k,17) + js + ind02 = ind01 + 1 + ind03 = ind01 + 9 + ind04 = ind01 + 10 + ind11 = id1(k,17) + js + ind12 = ind11 + 1 + ind13 = ind11 + 9 + ind14 = ind11 + 10 + + inds = indself(k) + indf = indfor (k) + indsp= inds + 1 + indfp= indf + 1 + + do j = 1, NG17 + taug(k,NS17+j) = speccomb & + & * ( fac000 * absa(ind01,j) + fac100 * absa(ind02,j) & + & + fac010 * absa(ind03,j) + fac110 * absa(ind04,j) & + & + fac001 * absa(ind11,j) + fac101 * absa(ind12,j) & + & + fac011 * absa(ind13,j) + fac111 * absa(ind14,j) ) & + & + colamt(k,1) * (selffac(k) * (selfref(inds,j) & + & + selffrac(k) * (selfref(indsp,j)-selfref(inds,j))) & + & + forfac(k) * (forref(indf,j) + forfrac(k) & + & * (forref(indfp,j) - forref(indf,j)))) + enddo + enddo + + do k = laytrop+1, nlay + speccomb = colamt(k,1) + strrat(17)*colamt(k,2) + specmult = 4.0 * min(oneminus, colamt(k,1) / speccomb) + + js = 1 + int(specmult) + fs = mod(specmult, f_one) + fs1= f_one - fs + fac000 = fs1 * fac00(k) + fac010 = fs1 * fac10(k) + fac100 = fs * fac00(k) + fac110 = fs * fac10(k) + fac001 = fs1 * fac01(k) + fac011 = fs1 * fac11(k) + fac101 = fs * fac01(k) + fac111 = fs * fac11(k) + + ind01 = id0(k,17) + js + ind02 = ind01 + 1 + ind03 = ind01 + 5 + ind04 = ind01 + 6 + ind11 = id1(k,17) + js + ind12 = ind11 + 1 + ind13 = ind11 + 5 + ind14 = ind11 + 6 + + indf = indfor(k) + indfp= indf + 1 + + do j = 1, NG17 + taug(k,NS17+j) = speccomb & + & * ( fac000 * absb(ind01,j) + fac100 * absb(ind02,j) & + & + fac010 * absb(ind03,j) + fac110 * absb(ind04,j) & + & + fac001 * absb(ind11,j) + fac101 * absb(ind12,j) & + & + fac011 * absb(ind13,j) + fac111 * absb(ind14,j) ) & + & + colamt(k,1) * forfac(k) * (forref(indf,j) & + & + forfrac(k) * (forref(indfp,j) - forref(indf,j))) + enddo + enddo + + return +!................................... + end subroutine taumol17 +!----------------------------------- + +!>\ingroup module_radsw_main +!> The subroutine computes the optical depth in band 18: 4000-4650 +!! cm-1 (low - h2o,ch4; high - ch4) +!----------------------------------- + subroutine taumol18 +!................................... + +! ------------------------------------------------------------------ ! +! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4) ! +! ------------------------------------------------------------------ ! +! + use module_radsw_kgb18 + +! --- locals: + real (kind=kind_phys) :: speccomb, specmult, tauray, fs, fs1, & + & fac000,fac001,fac010,fac011, fac100,fac101,fac110,fac111 + + integer :: ind01, ind02, ind03, ind04, ind11, ind12, ind13, ind14 + integer :: inds, indf, indsp, indfp, j, js, k + +! +!===> ... begin here +! + +! --- ... compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. below laytrop, the water +! vapor self-continuum is interpolated (in temperature) separately. + + do k = 1, nlay + tauray = colmol(k) * rayl + + do j = 1, NG18 + taur(k,NS18+j) = tauray + enddo + enddo + + do k = 1, laytrop + speccomb = colamt(k,1) + strrat(18)*colamt(k,5) + specmult = 8.0 * min(oneminus, colamt(k,1) / speccomb) + + js = 1 + int(specmult) + fs = mod(specmult, f_one) + fs1= f_one - fs + fac000 = fs1 * fac00(k) + fac010 = fs1 * fac10(k) + fac100 = fs * fac00(k) + fac110 = fs * fac10(k) + fac001 = fs1 * fac01(k) + fac011 = fs1 * fac11(k) + fac101 = fs * fac01(k) + fac111 = fs * fac11(k) + + ind01 = id0(k,18) + js + ind02 = ind01 + 1 + ind03 = ind01 + 9 + ind04 = ind01 + 10 + ind11 = id1(k,18) + js + ind12 = ind11 + 1 + ind13 = ind11 + 9 + ind14 = ind11 + 10 + + inds = indself(k) + indf = indfor (k) + indsp= inds + 1 + indfp= indf + 1 + + do j = 1, NG18 + taug(k,NS18+j) = speccomb & + & * ( fac000 * absa(ind01,j) + fac100 * absa(ind02,j) & + & + fac010 * absa(ind03,j) + fac110 * absa(ind04,j) & + & + fac001 * absa(ind11,j) + fac101 * absa(ind12,j) & + & + fac011 * absa(ind13,j) + fac111 * absa(ind14,j) ) & + & + colamt(k,1) * (selffac(k) * (selfref(inds,j) & + & + selffrac(k) * (selfref(indsp,j)-selfref(inds,j))) & + & + forfac(k) * (forref(indf,j) + forfrac(k) & + & * (forref(indfp,j) - forref(indf,j)))) + enddo + enddo + + do k = laytrop+1, nlay + ind01 = id0(k,18) + 1 + ind02 = ind01 + 1 + ind11 = id1(k,18) + 1 + ind12 = ind11 + 1 + + do j = 1, NG18 + taug(k,NS18+j) = colamt(k,5) & + & * ( fac00(k)*absb(ind01,j) + fac10(k)*absb(ind02,j) & + & + fac01(k)*absb(ind11,j) + fac11(k)*absb(ind12,j) ) + enddo + enddo + + return +!................................... + end subroutine taumol18 +!----------------------------------- + +!>\ingroup module_radsw_main +!> The subroutine computes the optical depth in band 19: 4650-5150 +!! cm-1 (low - h2o,co2; high - co2) +!----------------------------------- + subroutine taumol19 +!................................... + +! ------------------------------------------------------------------ ! +! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2) ! +! ------------------------------------------------------------------ ! +! + use module_radsw_kgb19 + +! --- locals: + real (kind=kind_phys) :: speccomb, specmult, tauray, fs, fs1, & + & fac000,fac001,fac010,fac011, fac100,fac101,fac110,fac111 + + integer :: ind01, ind02, ind03, ind04, ind11, ind12, ind13, ind14 + integer :: inds, indf, indsp, indfp, j, js, k + +! +!===> ... begin here +! + +! --- ... compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. below laytrop, the water +! vapor self-continuum is interpolated (in temperature) separately. + + do k = 1, nlay + tauray = colmol(k) * rayl + + do j = 1, NG19 + taur(k,NS19+j) = tauray + enddo + enddo + + do k = 1, laytrop + speccomb = colamt(k,1) + strrat(19)*colamt(k,2) + specmult = 8.0 * min(oneminus, colamt(k,1) / speccomb) + + js = 1 + int(specmult) + fs = mod(specmult, f_one) + fs1= f_one - fs + fac000 = fs1 * fac00(k) + fac010 = fs1 * fac10(k) + fac100 = fs * fac00(k) + fac110 = fs * fac10(k) + fac001 = fs1 * fac01(k) + fac011 = fs1 * fac11(k) + fac101 = fs * fac01(k) + fac111 = fs * fac11(k) + + ind01 = id0(k,19) + js + ind02 = ind01 + 1 + ind03 = ind01 + 9 + ind04 = ind01 + 10 + ind11 = id1(k,19) + js + ind12 = ind11 + 1 + ind13 = ind11 + 9 + ind14 = ind11 + 10 + + inds = indself(k) + indf = indfor (k) + indsp= inds + 1 + indfp= indf + 1 + + do j = 1, NG19 + taug(k,NS19+j) = speccomb & + & * ( fac000 * absa(ind01,j) + fac100 * absa(ind02,j) & + & + fac010 * absa(ind03,j) + fac110 * absa(ind04,j) & + & + fac001 * absa(ind11,j) + fac101 * absa(ind12,j) & + & + fac011 * absa(ind13,j) + fac111 * absa(ind14,j) ) & + & + colamt(k,1) * (selffac(k) * (selfref(inds,j) & + & + selffrac(k) * (selfref(indsp,j)-selfref(inds,j))) & + & + forfac(k) * (forref(indf,j) + forfrac(k) & + & * (forref(indfp,j) - forref(indf,j)))) + enddo + enddo + + do k = laytrop+1, nlay + ind01 = id0(k,19) + 1 + ind02 = ind01 + 1 + ind11 = id1(k,19) + 1 + ind12 = ind11 + 1 + + do j = 1, NG19 + taug(k,NS19+j) = colamt(k,2) & + & * ( fac00(k)*absb(ind01,j) + fac10(k)*absb(ind02,j) & + & + fac01(k)*absb(ind11,j) + fac11(k)*absb(ind12,j) ) + enddo + enddo + +!................................... + end subroutine taumol19 +!----------------------------------- + +!>\ingroup module_radsw_main +!> The subroutine computes the optical depth in band 20: 5150-6150 +!! cm-1 (low - h2o; high - h2o) +!----------------------------------- + subroutine taumol20 +!................................... + +! ------------------------------------------------------------------ ! +! band 20: 5150-6150 cm-1 (low - h2o; high - h2o) ! +! ------------------------------------------------------------------ ! +! + use module_radsw_kgb20 + +! --- locals: + real (kind=kind_phys) :: tauray + + integer :: ind01, ind02, ind11, ind12 + integer :: inds, indf, indsp, indfp, j, k + +! +!===> ... begin here +! + +! --- ... compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. below laytrop, the water +! vapor self-continuum is interpolated (in temperature) separately. + + do k = 1, nlay + tauray = colmol(k) * rayl + + do j = 1, NG20 + taur(k,NS20+j) = tauray + enddo + enddo + + do k = 1, laytrop + ind01 = id0(k,20) + 1 + ind02 = ind01 + 1 + ind11 = id1(k,20) + 1 + ind12 = ind11 + 1 + + inds = indself(k) + indf = indfor (k) + indsp= inds + 1 + indfp= indf + 1 + + do j = 1, NG20 + taug(k,NS20+j) = colamt(k,1) & + & * ( (fac00(k)*absa(ind01,j) + fac10(k)*absa(ind02,j) & + & + fac01(k)*absa(ind11,j) + fac11(k)*absa(ind12,j)) & + & + selffac(k) * (selfref(inds,j) + selffrac(k) & + & * (selfref(indsp,j) - selfref(inds,j))) & + & + forfac(k) * (forref(indf,j) + forfrac(k) & + & * (forref(indfp,j) - forref(indf,j))) ) & + & + colamt(k,5) * absch4(j) + enddo + enddo + + do k = laytrop+1, nlay + ind01 = id0(k,20) + 1 + ind02 = ind01 + 1 + ind11 = id1(k,20) + 1 + ind12 = ind11 + 1 + + indf = indfor(k) + indfp= indf + 1 + + do j = 1, NG20 + taug(k,NS20+j) = colamt(k,1) & + & * ( fac00(k)*absb(ind01,j) + fac10(k)*absb(ind02,j) & + & + fac01(k)*absb(ind11,j) + fac11(k)*absb(ind12,j) & + & + forfac(k) * (forref(indf,j) + forfrac(k) & + & * (forref(indfp,j) - forref(indf,j))) ) & + & + colamt(k,5) * absch4(j) + enddo + enddo + + return +!................................... + end subroutine taumol20 +!----------------------------------- + +!>\ingroup module_radsw_main +!> The subroutine computes the optical depth in band 21: 6150-7700 +!! cm-1 (low - h2o,co2; high - h2o,co2) +!----------------------------------- + subroutine taumol21 +!................................... + +! ------------------------------------------------------------------ ! +! band 21: 6150-7700 cm-1 (low - h2o,co2; high - h2o,co2) ! +! ------------------------------------------------------------------ ! +! + use module_radsw_kgb21 + +! --- locals: + real (kind=kind_phys) :: speccomb, specmult, tauray, fs, fs1, & + & fac000,fac001,fac010,fac011, fac100,fac101,fac110,fac111 + + integer :: ind01, ind02, ind03, ind04, ind11, ind12, ind13, ind14 + integer :: inds, indf, indsp, indfp, j, js, k + +! +!===> ... begin here +! + +! --- ... compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. below laytrop, the water +! vapor self-continuum is interpolated (in temperature) separately. + + do k = 1, nlay + tauray = colmol(k) * rayl + + do j = 1, NG21 + taur(k,NS21+j) = tauray + enddo + enddo + + do k = 1, laytrop + speccomb = colamt(k,1) + strrat(21)*colamt(k,2) + specmult = 8.0 * min(oneminus, colamt(k,1) / speccomb) + + js = 1 + int(specmult) + fs = mod(specmult, f_one) + fs1= f_one - fs + fac000 = fs1 * fac00(k) + fac010 = fs1 * fac10(k) + fac100 = fs * fac00(k) + fac110 = fs * fac10(k) + fac001 = fs1 * fac01(k) + fac011 = fs1 * fac11(k) + fac101 = fs * fac01(k) + fac111 = fs * fac11(k) + + ind01 = id0(k,21) + js + ind02 = ind01 + 1 + ind03 = ind01 + 9 + ind04 = ind01 + 10 + ind11 = id1(k,21) + js + ind12 = ind11 + 1 + ind13 = ind11 + 9 + ind14 = ind11 + 10 + + inds = indself(k) + indf = indfor (k) + indsp= inds + 1 + indfp= indf + 1 + + do j = 1, NG21 + taug(k,NS21+j) = speccomb & + & * ( fac000 * absa(ind01,j) + fac100 * absa(ind02,j) & + & + fac010 * absa(ind03,j) + fac110 * absa(ind04,j) & + & + fac001 * absa(ind11,j) + fac101 * absa(ind12,j) & + & + fac011 * absa(ind13,j) + fac111 * absa(ind14,j) ) & + & + colamt(k,1) * (selffac(k) * (selfref(inds,j) & + & + selffrac(k) * (selfref(indsp,j) - selfref(inds,j))) & + & + forfac(k) * (forref(indf,j) + forfrac(k) & + & * (forref(indfp,j) - forref(indf,j)))) + enddo + enddo + + do k = laytrop+1, nlay + speccomb = colamt(k,1) + strrat(21)*colamt(k,2) + specmult = 4.0 * min(oneminus, colamt(k,1) / speccomb) + + js = 1 + int(specmult) + fs = mod(specmult, f_one) + fs1= f_one - fs + fac000 = fs1 * fac00(k) + fac010 = fs1 * fac10(k) + fac100 = fs * fac00(k) + fac110 = fs * fac10(k) + fac001 = fs1 * fac01(k) + fac011 = fs1 * fac11(k) + fac101 = fs * fac01(k) + fac111 = fs * fac11(k) + + ind01 = id0(k,21) + js + ind02 = ind01 + 1 + ind03 = ind01 + 5 + ind04 = ind01 + 6 + ind11 = id1(k,21) + js + ind12 = ind11 + 1 + ind13 = ind11 + 5 + ind14 = ind11 + 6 + + indf = indfor(k) + indfp= indf + 1 + + do j = 1, NG21 + taug(k,NS21+j) = speccomb & + & * ( fac000 * absb(ind01,j) + fac100 * absb(ind02,j) & + & + fac010 * absb(ind03,j) + fac110 * absb(ind04,j) & + & + fac001 * absb(ind11,j) + fac101 * absb(ind12,j) & + & + fac011 * absb(ind13,j) + fac111 * absb(ind14,j) ) & + & + colamt(k,1) * forfac(k) * (forref(indf,j) & + & + forfrac(k) * (forref(indfp,j) - forref(indf,j))) + enddo + enddo + +!................................... + end subroutine taumol21 +!----------------------------------- + +!>\ingroup module_radsw_main +!> The subroutine computes the optical depth in band 22: 7700-8050 +!! cm-1 (low - h2o,o2; high - o2) +!----------------------------------- + subroutine taumol22 +!................................... + +! ------------------------------------------------------------------ ! +! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2) ! +! ------------------------------------------------------------------ ! +! + use module_radsw_kgb22 + +! --- locals: + real (kind=kind_phys) :: speccomb, specmult, tauray, fs, fs1, & + & fac000,fac001,fac010,fac011, fac100,fac101,fac110,fac111, & + & o2adj, o2cont, o2tem + + integer :: ind01, ind02, ind03, ind04, ind11, ind12, ind13, ind14 + integer :: inds, indf, indsp, indfp, j, js, k + +! +!===> ... begin here +! +! --- ... the following factor is the ratio of total o2 band intensity (lines +! and mate continuum) to o2 band intensity (line only). it is needed +! to adjust the optical depths since the k's include only lines. + + o2adj = 1.6 + o2tem = 4.35e-4 / (350.0*2.0) + + +! --- ... compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. below laytrop, the water +! vapor self-continuum is interpolated (in temperature) separately. + + do k = 1, nlay + tauray = colmol(k) * rayl + + do j = 1, NG22 + taur(k,NS22+j) = tauray + enddo + enddo + + do k = 1, laytrop + o2cont = o2tem * colamt(k,6) + speccomb = colamt(k,1) + strrat(22)*colamt(k,6) + specmult = 8.0 * min(oneminus, colamt(k,1) / speccomb) + + js = 1 + int(specmult) + fs = mod(specmult, f_one) + fs1= f_one - fs + fac000 = fs1 * fac00(k) + fac010 = fs1 * fac10(k) + fac100 = fs * fac00(k) + fac110 = fs * fac10(k) + fac001 = fs1 * fac01(k) + fac011 = fs1 * fac11(k) + fac101 = fs * fac01(k) + fac111 = fs * fac11(k) + + ind01 = id0(k,22) + js + ind02 = ind01 + 1 + ind03 = ind01 + 9 + ind04 = ind01 + 10 + ind11 = id1(k,22) + js + ind12 = ind11 + 1 + ind13 = ind11 + 9 + ind14 = ind11 + 10 + + inds = indself(k) + indf = indfor (k) + indsp= inds + 1 + indfp= indf + 1 + + do j = 1, NG22 + taug(k,NS22+j) = speccomb & + & * ( fac000 * absa(ind01,j) + fac100 * absa(ind02,j) & + & + fac010 * absa(ind03,j) + fac110 * absa(ind04,j) & + & + fac001 * absa(ind11,j) + fac101 * absa(ind12,j) & + & + fac011 * absa(ind13,j) + fac111 * absa(ind14,j) ) & + & + colamt(k,1) * (selffac(k) * (selfref(inds,j) & + & + selffrac(k) * (selfref(indsp,j)-selfref(inds,j))) & + & + forfac(k) * (forref(indf,j) + forfrac(k) & + & * (forref(indfp,j) - forref(indf,j)))) + o2cont + enddo + enddo + + do k = laytrop+1, nlay + o2cont = o2tem * colamt(k,6) + + ind01 = id0(k,22) + 1 + ind02 = ind01 + 1 + ind11 = id1(k,22) + 1 + ind12 = ind11 + 1 + + do j = 1, NG22 + taug(k,NS22+j) = colamt(k,6) * o2adj & + & * ( fac00(k)*absb(ind01,j) + fac10(k)*absb(ind02,j) & + & + fac01(k)*absb(ind11,j) + fac11(k)*absb(ind12,j) ) & + & + o2cont + enddo + enddo + + return +!................................... + end subroutine taumol22 +!----------------------------------- + +!>\ingroup module_radsw_main +!> The subroutine computes the optical depth in band 23: 8050-12850 +!! cm-1 (low - h2o; high - nothing) +!----------------------------------- + subroutine taumol23 +!................................... + +! ------------------------------------------------------------------ ! +! band 23: 8050-12850 cm-1 (low - h2o; high - nothing) ! +! ------------------------------------------------------------------ ! +! + use module_radsw_kgb23 + +! --- locals: + integer :: ind01, ind02, ind11, ind12 + integer :: inds, indf, indsp, indfp, j, k + +! +!===> ... begin here +! + +! --- ... compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. below laytrop, the water +! vapor self-continuum is interpolated (in temperature) separately. + + do k = 1, nlay + do j = 1, NG23 + taur(k,NS23+j) = colmol(k) * rayl(j) + enddo + enddo + + do k = 1, laytrop + ind01 = id0(k,23) + 1 + ind02 = ind01 + 1 + ind11 = id1(k,23) + 1 + ind12 = ind11 + 1 + + inds = indself(k) + indf = indfor (k) + indsp= inds + 1 + indfp= indf + 1 + + do j = 1, NG23 + taug(k,NS23+j) = colamt(k,1) * (givfac & + & * ( fac00(k)*absa(ind01,j) + fac10(k)*absa(ind02,j) & + & + fac01(k)*absa(ind11,j) + fac11(k)*absa(ind12,j) ) & + & + selffac(k) * (selfref(inds,j) + selffrac(k) & + & * (selfref(indsp,j) - selfref(inds,j))) & + & + forfac(k) * (forref(indf,j) + forfrac(k) & + & * (forref(indfp,j) - forref(indf,j)))) + enddo + enddo + + do k = laytrop+1, nlay + do j = 1, NG23 + taug(k,NS23+j) = f_zero + enddo + enddo + +!................................... + end subroutine taumol23 +!----------------------------------- + +!>\ingroup module_radsw_main +!> The subroutine computes the optical depth in band 24: 12850-16000 +!! cm-1 (low - h2o,o2; high - o2) +!----------------------------------- + subroutine taumol24 +!................................... + +! ------------------------------------------------------------------ ! +! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2) ! +! ------------------------------------------------------------------ ! +! + use module_radsw_kgb24 + +! --- locals: + real (kind=kind_phys) :: speccomb, specmult, fs, fs1, & + & fac000,fac001,fac010,fac011, fac100,fac101,fac110,fac111 + + integer :: ind01, ind02, ind03, ind04, ind11, ind12, ind13, ind14 + integer :: inds, indf, indsp, indfp, j, js, k + +! +!===> ... begin here +! + +! --- ... compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. below laytrop, the water +! vapor self-continuum is interpolated (in temperature) separately. + + do k = 1, laytrop + speccomb = colamt(k,1) + strrat(24)*colamt(k,6) + specmult = 8.0 * min(oneminus, colamt(k,1) / speccomb) + + js = 1 + int(specmult) + fs = mod(specmult, f_one) + fs1= f_one - fs + fac000 = fs1 * fac00(k) + fac010 = fs1 * fac10(k) + fac100 = fs * fac00(k) + fac110 = fs * fac10(k) + fac001 = fs1 * fac01(k) + fac011 = fs1 * fac11(k) + fac101 = fs * fac01(k) + fac111 = fs * fac11(k) + + ind01 = id0(k,24) + js + ind02 = ind01 + 1 + ind03 = ind01 + 9 + ind04 = ind01 + 10 + ind11 = id1(k,24) + js + ind12 = ind11 + 1 + ind13 = ind11 + 9 + ind14 = ind11 + 10 + + inds = indself(k) + indf = indfor (k) + indsp= inds + 1 + indfp= indf + 1 + + do j = 1, NG24 + taug(k,NS24+j) = speccomb & + & * ( fac000 * absa(ind01,j) + fac100 * absa(ind02,j) & + & + fac010 * absa(ind03,j) + fac110 * absa(ind04,j) & + & + fac001 * absa(ind11,j) + fac101 * absa(ind12,j) & + & + fac011 * absa(ind13,j) + fac111 * absa(ind14,j) ) & + & + colamt(k,3) * abso3a(j) + colamt(k,1) & + & * (selffac(k) * (selfref(inds,j) + selffrac(k) & + & * (selfref(indsp,j) - selfref(inds,j))) & + & + forfac(k) * (forref(indf,j) + forfrac(k) & + & * (forref(indfp,j) - forref(indf,j)))) + + taur(k,NS24+j) = colmol(k) & + & * (rayla(j,js) + fs*(rayla(j,js+1) - rayla(j,js))) + enddo + enddo + + do k = laytrop+1, nlay + ind01 = id0(k,24) + 1 + ind02 = ind01 + 1 + ind11 = id1(k,24) + 1 + ind12 = ind11 + 1 + + do j = 1, NG24 + taug(k,NS24+j) = colamt(k,6) & + & * ( fac00(k)*absb(ind01,j) + fac10(k)*absb(ind02,j) & + & + fac01(k)*absb(ind11,j) + fac11(k)*absb(ind12,j) ) & + & + colamt(k,3) * abso3b(j) + + taur(k,NS24+j) = colmol(k) * raylb(j) + enddo + enddo + + return +!................................... + end subroutine taumol24 +!----------------------------------- + +!>\ingroup module_radsw_main +!> The subroutine computes the optical depth in band 25: 16000-22650 +!! cm-1 (low - h2o; high - nothing) +!----------------------------------- + subroutine taumol25 +!................................... + +! ------------------------------------------------------------------ ! +! band 25: 16000-22650 cm-1 (low - h2o; high - nothing) ! +! ------------------------------------------------------------------ ! +! + use module_radsw_kgb25 + +! --- locals: + integer :: ind01, ind02, ind11, ind12 + integer :: j, k + +! +!===> ... begin here +! + +! --- ... compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. below laytrop, the water +! vapor self-continuum is interpolated (in temperature) separately. + + do k = 1, nlay + do j = 1, NG25 + taur(k,NS25+j) = colmol(k) * rayl(j) + enddo + enddo + + do k = 1, laytrop + ind01 = id0(k,25) + 1 + ind02 = ind01 + 1 + ind11 = id1(k,25) + 1 + ind12 = ind11 + 1 + + do j = 1, NG25 + taug(k,NS25+j) = colamt(k,1) & + & * ( fac00(k)*absa(ind01,j) + fac10(k)*absa(ind02,j) & + & + fac01(k)*absa(ind11,j) + fac11(k)*absa(ind12,j) ) & + & + colamt(k,3) * abso3a(j) + enddo + enddo + + do k = laytrop+1, nlay + do j = 1, NG25 + taug(k,NS25+j) = colamt(k,3) * abso3b(j) + enddo + enddo + + return +!................................... + end subroutine taumol25 +!----------------------------------- + +!>\ingroup module_radsw_main +!> The subroutine computes the optical depth in band 26: 22650-29000 +!! cm-1 (low - nothing; high - nothing) +!----------------------------------- + subroutine taumol26 +!................................... + +! ------------------------------------------------------------------ ! +! band 26: 22650-29000 cm-1 (low - nothing; high - nothing) ! +! ------------------------------------------------------------------ ! +! + use module_radsw_kgb26 + +! --- locals: + integer :: j, k + +! +!===> ... begin here +! + +! --- ... compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. below laytrop, the water +! vapor self-continuum is interpolated (in temperature) separately. + + do k = 1, nlay + do j = 1, NG26 + taug(k,NS26+j) = f_zero + taur(k,NS26+j) = colmol(k) * rayl(j) + enddo + enddo + + return +!................................... + end subroutine taumol26 +!----------------------------------- + +!>\ingroup module_radsw_main +!> The subroutine computes the optical depth in band 27: 29000-38000 +!! cm-1 (low - o3; high - o3) +!----------------------------------- + subroutine taumol27 +!................................... + +! ------------------------------------------------------------------ ! +! band 27: 29000-38000 cm-1 (low - o3; high - o3) ! +! ------------------------------------------------------------------ ! +! + use module_radsw_kgb27 +! +! --- locals: + integer :: ind01, ind02, ind11, ind12 + integer :: j, k + +! +!===> ... begin here +! + +! --- ... compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. below laytrop, the water +! vapor self-continuum is interpolated (in temperature) separately. + + do k = 1, nlay + do j = 1, NG27 + taur(k,NS27+j) = colmol(k) * rayl(j) + enddo + enddo + + do k = 1, laytrop + ind01 = id0(k,27) + 1 + ind02 = ind01 + 1 + ind11 = id1(k,27) + 1 + ind12 = ind11 + 1 + + do j = 1, NG27 + taug(k,NS27+j) = colamt(k,3) & + & * ( fac00(k)*absa(ind01,j) + fac10(k)*absa(ind02,j) & + & + fac01(k)*absa(ind11,j) + fac11(k)*absa(ind12,j) ) + enddo + enddo + + do k = laytrop+1, nlay + ind01 = id0(k,27) + 1 + ind02 = ind01 + 1 + ind11 = id1(k,27) + 1 + ind12 = ind11 + 1 + + do j = 1, NG27 + taug(k,NS27+j) = colamt(k,3) & + & * ( fac00(k)*absb(ind01,j) + fac10(k)*absb(ind02,j) & + & + fac01(k)*absb(ind11,j) + fac11(k)*absb(ind12,j) ) + enddo + enddo + + return +!................................... + end subroutine taumol27 +!----------------------------------- + +!>\ingroup module_radsw_main +!> The subroutine computes the optical depth in band 28: 38000-50000 +!! cm-1 (low - o3,o2; high - o3,o2) +!----------------------------------- + subroutine taumol28 +!................................... + +! ------------------------------------------------------------------ ! +! band 28: 38000-50000 cm-1 (low - o3,o2; high - o3,o2) ! +! ------------------------------------------------------------------ ! +! + use module_radsw_kgb28 + +! --- locals: + real (kind=kind_phys) :: speccomb, specmult, tauray, fs, fs1, & + & fac000,fac001,fac010,fac011, fac100,fac101,fac110,fac111 + + integer :: ind01, ind02, ind03, ind04, ind11, ind12, ind13, ind14 + integer :: j, js, k + +! +!===> ... begin here +! + +! --- ... compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. below laytrop, the water +! vapor self-continuum is interpolated (in temperature) separately. + + do k = 1, nlay + tauray = colmol(k) * rayl + + do j = 1, NG28 + taur(k,NS28+j) = tauray + enddo + enddo + + do k = 1, laytrop + speccomb = colamt(k,3) + strrat(28)*colamt(k,6) + specmult = 8.0 * min(oneminus, colamt(k,3) / speccomb) + + js = 1 + int(specmult) + fs = mod(specmult, f_one) + fs1= f_one - fs + fac000 = fs1 * fac00(k) + fac010 = fs1 * fac10(k) + fac100 = fs * fac00(k) + fac110 = fs * fac10(k) + fac001 = fs1 * fac01(k) + fac011 = fs1 * fac11(k) + fac101 = fs * fac01(k) + fac111 = fs * fac11(k) + + ind01 = id0(k,28) + js + ind02 = ind01 + 1 + ind03 = ind01 + 9 + ind04 = ind01 + 10 + ind11 = id1(k,28) + js + ind12 = ind11 + 1 + ind13 = ind11 + 9 + ind14 = ind11 + 10 + + do j = 1, NG28 + taug(k,NS28+j) = speccomb & + & * ( fac000 * absa(ind01,j) + fac100 * absa(ind02,j) & + & + fac010 * absa(ind03,j) + fac110 * absa(ind04,j) & + & + fac001 * absa(ind11,j) + fac101 * absa(ind12,j) & + & + fac011 * absa(ind13,j) + fac111 * absa(ind14,j) ) + enddo + enddo + + do k = laytrop+1, nlay + speccomb = colamt(k,3) + strrat(28)*colamt(k,6) + specmult = 4.0 * min(oneminus, colamt(k,3) / speccomb) + + js = 1 + int(specmult) + fs = mod(specmult, f_one) + fs1= f_one - fs + fac000 = fs1 * fac00(k) + fac010 = fs1 * fac10(k) + fac100 = fs * fac00(k) + fac110 = fs * fac10(k) + fac001 = fs1 * fac01(k) + fac011 = fs1 * fac11(k) + fac101 = fs * fac01(k) + fac111 = fs * fac11(k) + + ind01 = id0(k,28) + js + ind02 = ind01 + 1 + ind03 = ind01 + 5 + ind04 = ind01 + 6 + ind11 = id1(k,28) + js + ind12 = ind11 + 1 + ind13 = ind11 + 5 + ind14 = ind11 + 6 + + do j = 1, NG28 + taug(k,NS28+j) = speccomb & + & * ( fac000 * absb(ind01,j) + fac100 * absb(ind02,j) & + & + fac010 * absb(ind03,j) + fac110 * absb(ind04,j) & + & + fac001 * absb(ind11,j) + fac101 * absb(ind12,j) & + & + fac011 * absb(ind13,j) + fac111 * absb(ind14,j) ) + enddo + enddo + + return +!................................... + end subroutine taumol28 +!----------------------------------- + +!>\ingroup module_radsw_main +!> The subroutine computes the optical depth in band 29: 820-2600 +!! cm-1 (low - h2o; high - co2) +!----------------------------------- + subroutine taumol29 +!................................... + +! ------------------------------------------------------------------ ! +! band 29: 820-2600 cm-1 (low - h2o; high - co2) ! +! ------------------------------------------------------------------ ! +! + use module_radsw_kgb29 + +! --- locals: + real (kind=kind_phys) :: tauray + + integer :: ind01, ind02, ind11, ind12 + integer :: inds, indf, indsp, indfp, j, k + +! +!===> ... begin here +! + +! --- ... compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. below laytrop, the water +! vapor self-continuum is interpolated (in temperature) separately. + + do k = 1, nlay + tauray = colmol(k) * rayl + + do j = 1, NG29 + taur(k,NS29+j) = tauray + enddo + enddo + + do k = 1, laytrop + ind01 = id0(k,29) + 1 + ind02 = ind01 + 1 + ind11 = id1(k,29) + 1 + ind12 = ind11 + 1 + + inds = indself(k) + indf = indfor (k) + indsp= inds + 1 + indfp= indf + 1 + + do j = 1, NG29 + taug(k,NS29+j) = colamt(k,1) & + & * ( (fac00(k)*absa(ind01,j) + fac10(k)*absa(ind02,j) & + & + fac01(k)*absa(ind11,j) + fac11(k)*absa(ind12,j) ) & + & + selffac(k) * (selfref(inds,j) + selffrac(k) & + & * (selfref(indsp,j) - selfref(inds,j))) & + & + forfac(k) * (forref(indf,j) + forfrac(k) & + & * (forref(indfp,j) - forref(indf,j)))) & + & + colamt(k,2) * absco2(j) + enddo + enddo + + do k = laytrop+1, nlay + ind01 = id0(k,29) + 1 + ind02 = ind01 + 1 + ind11 = id1(k,29) + 1 + ind12 = ind11 + 1 + + do j = 1, NG29 + taug(k,NS29+j) = colamt(k,2) & + & * ( fac00(k)*absb(ind01,j) + fac10(k)*absb(ind02,j) & + & + fac01(k)*absb(ind11,j) + fac11(k)*absb(ind12,j) ) & + & + colamt(k,1) * absh2o(j) + enddo + enddo + + return +!................................... + end subroutine taumol29 +!----------------------------------- + +!................................... + end subroutine taumol +!----------------------------------- + +!mz* HWRF subroutines + subroutine mcica_subcol_sw(iplon, ncol, nlay, icld, permuteseed, & + & irng, play, hgt, & + & cldfrac, ciwp, clwp, cswp, rei, rel, res, tauc, & + & ssac, asmc, fsfc, & + & cldfmcl, ciwpmcl, clwpmcl, cswpmcl, reicmcl, & + & relqmcl, resnmcl, & + & taucmcl, ssacmcl, asmcmcl, fsfcmcl) + +! ----- Input ----- +! Control + integer(kind=im), intent(in) :: iplon ! column/longitude dimension + integer(kind=im), intent(in) :: ncol ! number of columns + integer(kind=im), intent(in) :: nlay ! number of model layers + integer(kind=im), intent(in) :: icld ! clear/cloud, cloud overlap flag + integer(kind=im), intent(in) :: permuteseed ! if the cloud generator is called multiple times, + ! permute the seed between each call; + ! between calls for LW and SW, recommended + ! permuteseed differs by 'ngpt' + integer(kind=im), intent(inout) :: irng ! flag for random number generator + ! 0 = kissvec + ! 1 = Mersenne Twister + +! Atmosphere + real(kind=rb), intent(in) :: play(:,:) ! layer pressures (mb) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: hgt(:,:) ! layer height (m) + ! Dimensions: (ncol,nlay) + +! Atmosphere/clouds - cldprop + real(kind=rb), intent(in) :: cldfrac(:,:) ! layer cloud fraction + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: tauc(:,:,:) ! in-cloud optical depth + ! Dimensions: (nbndsw,ncol,nlay) + real(kind=rb), intent(in) :: ssac(:,:,:) ! in-cloud single scattering albedo (non-delta scaled) + ! Dimensions: (nbndsw,ncol,nlay) + real(kind=rb), intent(in) :: asmc(:,:,:) ! in-cloud asymmetry parameter (non-delta scaled) + ! Dimensions: (nbndsw,ncol,nlay) + real(kind=rb), intent(in) :: fsfc(:,:,:) ! in-cloud forward scattering fraction (non-delta scaled) + ! Dimensions: (nbndsw,ncol,nlay) + real(kind=rb), intent(in) :: ciwp(:,:) ! in-cloud ice water path + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: clwp(:,:) ! in-cloud liquid water path + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: cswp(:,:) ! in-cloud snow water path + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: rei(:,:) ! cloud ice particle size + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: rel(:,:) ! cloud liquid particle size + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: res(:,:) ! cloud snow particle size + ! Dimensions: (ncol,nlay) + +! ----- Output ----- +! Atmosphere/clouds - cldprmc [mcica] + real(kind=rb), intent(out) :: cldfmcl(:,:,:) ! cloud fraction [mcica] + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(out) :: ciwpmcl(:,:,:) ! in-cloud ice water path [mcica] + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(out) :: clwpmcl(:,:,:) ! in-cloud liquid water path [mcica] + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(out) :: cswpmcl(:,:,:) ! in-cloud snow water path [mcica] + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(out) :: relqmcl(:,:) ! liquid particle size (microns) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(out) :: reicmcl(:,:) ! ice partcle size (microns) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(out) :: resnmcl(:,:) ! snow partcle size (microns) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(out) :: taucmcl(:,:,:) ! in-cloud optical depth [mcica] + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(out) :: ssacmcl(:,:,:) ! in-cloud single scattering albedo [mcica] + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(out) :: asmcmcl(:,:,:) ! in-cloud asymmetry parameter [mcica] + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(out) :: fsfcmcl(:,:,:) ! in-cloud forward scattering fraction [mcica] + ! Dimensions: (ngptsw,ncol,nlay) + +! ----- Local ----- + +! Stochastic cloud generator variables [mcica] + integer(kind=im), parameter :: nsubcsw = ngptsw ! number of sub-columns (g-point intervals) + integer(kind=im) :: ilev ! loop index + + real(kind=rb) :: pmid(ncol,nlay) ! layer pressures (Pa) +! real(kind=rb) :: pdel(ncol,nlay) ! layer pressure thickness (Pa) +! real(kind=rb) :: qi(ncol,nlay) ! ice water (specific humidity) +! real(kind=rb) :: ql(ncol,nlay) ! liq water (specific humidity) + +! Return if clear sky + if (icld.eq.0) return + +! NOTE: For GCM mode, permuteseed must be offset between LW and SW by at least number of subcolumns + +! Pass particle sizes to new arrays, no subcolumns for these properties yet +! Convert pressures from mb to Pa + + reicmcl(:ncol,:nlay) = rei(:ncol,:nlay) + relqmcl(:ncol,:nlay) = rel(:ncol,:nlay) + resnmcl(:ncol,:nlay) = res(:ncol,:nlay) + pmid(:ncol,:nlay) = play(:ncol,:nlay)*1.e2_rb + +! Convert input ice and liquid cloud water paths to specific humidity ice and liquid components + +! cwp = (q * pdel * 1000.) / gravit) +! = (kg/kg * kg m-1 s-2 *1000.) / m s-2 +! = (g m-2) +! +! q = (cwp * gravit) / (pdel *1000.) +! = (g m-2 * m s-2) / (kg m-1 s-2 * 1000.) +! = kg/kg + +! do ilev = 1, nlay +! qi(ilev) = (ciwp(ilev) * grav) / (pdel(ilev) * 1000._rb) +! ql(ilev) = (clwp(ilev) * grav) / (pdel(ilev) * 1000._rb) +! enddo + + call generate_stochastic_clouds_sw (ncol, nlay, nsubcsw, icld, & + & irng, pmid, hgt, cldfrac, clwp, ciwp, cswp, & + & tauc, ssac, asmc, fsfc, cldfmcl, clwpmcl, & + & ciwpmcl, cswpmcl, & + & taucmcl, ssacmcl, asmcmcl, fsfcmcl, permuteseed) + + end subroutine mcica_subcol_sw + +!------------------------------------------------------------------------------------------------- + subroutine generate_stochastic_clouds_sw(ncol, nlay, nsubcol, & + & icld, irng, pmid, hgt, cld, clwp, ciwp, cswp, & + & tauc, ssac, asmc, fsfc, cld_stoch, clwp_stoch, & + & ciwp_stoch, cswp_stoch, & + & tauc_stoch, ssac_stoch, asmc_stoch, fsfc_stoch, changeSeed) +!------------------------------------------------------------------------------------------------- +! Contact: Cecile Hannay (hannay@ucar.edu) +! +! Original code: Based on Raisanen et al., QJRMS, 2004. +! +! Modifications: Generalized for use with RRTMG and added Mersenne Twister as the default +! random number generator, which can be changed to the optional kissvec random number generator +! with flag 'irng'. Some extra functionality has been commented or removed. +! Michael J. Iacono, AER, Inc., February 2007 +! +! Given a profile of cloud fraction, cloud water and cloud ice, we produce a set of subcolumns. +! Each layer within each subcolumn is homogeneous, with cloud fraction equal to zero or one +! and uniform cloud liquid and cloud ice concentration. +! The ensemble as a whole reproduces the probability function of cloud liquid and ice within each layer +! and obeys an overlap assumption in the vertical. +! +! Overlap assumption: +! The cloud are consistent with 4 overlap assumptions: random, maximum, maximum-random and exponential. +! The default option is maximum-random (option 3) +! The options are: 1=random overlap, 2=max/random, 3=maximum overlap, 4=exponential overlap +! This is set with the variable "overlap" +!mji - Exponential overlap option (overlap=4) has been deactivated in this version +! The exponential overlap uses also a length scale, Zo. (real, parameter :: Zo = 2500. ) +! +! Seed: +! If the stochastic cloud generator is called several times during the same timestep, +! one should change the seed between the call to insure that the subcolumns are different. +! This is done by changing the argument 'changeSeed' +! For example, if one wants to create a set of columns for the shortwave and another set for the longwave , +! use 'changeSeed = 1' for the first call and'changeSeed = 2' for the second call +! +! PDF assumption: +! We can use arbitrary complicated PDFS. +! In the present version, we produce homogeneuous clouds (the simplest case). +! Future developments include using the PDF scheme of Ben Johnson. +! +! History file: +! Option to add diagnostics variables in the history file. (using FINCL in the namelist) +! nsubcol = number of subcolumns +! overlap = overlap type (1-3) +! Zo = length scale +! CLOUD_S = mean of the subcolumn cloud fraction ('_S" means Stochastic) +! CLDLIQ_S = mean of the subcolumn cloud water +! CLDICE_S = mean of the subcolumn cloud ice +! +! +! Note: +! Here: we force that the cloud condensate to be consistent with the cloud fraction +! i.e we only have cloud condensate when the cell is cloudy. +! In CAM: The cloud condensate and the cloud fraction are obtained from 2 different equations +! and the 2 quantities can be inconsistent (i.e. CAM can produce cloud fraction +! without cloud condensate or the opposite). +!---------------------------------------------------------------------- + + use mcica_random_numbers +! The Mersenne Twister random number engine + use MersenneTwister, only: randomNumberSequence, & + new_RandomNumberSequence, getRandomReal + + type(randomNumberSequence) :: randomNumbers + +! -- Arguments + + integer(kind=im), intent(in) :: ncol ! number of layers + integer(kind=im), intent(in) :: nlay ! number of layers + integer(kind=im), intent(in) :: icld ! clear/cloud, cloud overlap flag + integer(kind=im), intent(inout) :: irng ! flag for random number generator + ! 0 = kissvec + ! 1 = Mersenne Twister + integer(kind=im), intent(in) :: nsubcol ! number of sub-columns (g-point intervals) + integer(kind=im), optional, intent(in) :: changeSeed ! allows permuting seed + +! Column state (cloud fraction, cloud water, cloud ice) + variables needed to read physics state + real(kind=rb), intent(in) :: pmid(:,:) ! layer pressure (Pa) + ! Dimensions: (ncol,nlay) +! mji - Add height + real(kind=rb), intent(in) :: hgt(:,:) ! layer height (m) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: cld(:,:) ! cloud fraction + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: clwp(:,:) ! in-cloud liquid water path (g/m2) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: ciwp(:,:) ! in-cloud ice water path (g/m2) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: cswp(:,:) ! in-cloud snow water path (g/m2) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: tauc(:,:,:) ! in-cloud optical depth (non-delta scaled) + ! Dimensions: (nbndsw,ncol,nlay) + real(kind=rb), intent(in) :: ssac(:,:,:) ! in-cloud single scattering albedo (non-delta scaled) + ! Dimensions: (nbndsw,ncol,nlay) + real(kind=rb), intent(in) :: asmc(:,:,:) ! in-cloud asymmetry parameter (non-delta scaled) + ! Dimensions: (nbndsw,ncol,nlay) + real(kind=rb), intent(in) :: fsfc(:,:,:) ! in-cloud forward scattering fraction (non-delta scaled) + ! Dimensions: (nbndsw,ncol,nlay) + real(kind=rb), intent(out) :: cld_stoch(:,:,:) ! subcolumn cloud fraction + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(out) :: clwp_stoch(:,:,:) ! subcolumn in-cloud liquid water path + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(out) :: ciwp_stoch(:,:,:) ! subcolumn in-cloud ice water path + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(out) :: cswp_stoch(:,:,:) ! subcolumn in-cloud snow water path + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(out) :: tauc_stoch(:,:,:) ! subcolumn in-cloud optical depth + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(out) :: ssac_stoch(:,:,:) ! subcolumn in-cloud single scattering albedo + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(out) :: asmc_stoch(:,:,:) ! subcolumn in-cloud asymmetry parameter + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(out) :: fsfc_stoch(:,:,:) ! subcolumn in-cloud forward scattering fraction + ! Dimensions: (ngptsw,ncol,nlay) + +! -- Local variables + real(kind=rb) :: cldf(ncol,nlay) ! cloud fraction + ! Dimensions: (ncol,nlay) + +! Mean over the subcolumns (cloud fraction, cloud water , cloud ice) - inactive +! real(kind=rb) :: mean_cld_stoch(ncol,nlay) ! cloud fraction +! real(kind=rb) :: mean_clwp_stoch(ncol,nlay) ! cloud water +! real(kind=rb) :: mean_ciwp_stoch(ncol,nlay) ! cloud ice +! real(kind=rb) :: mean_tauc_stoch(ncol,nlay) ! cloud optical depth +! real(kind=rb) :: mean_ssac_stoch(ncol,nlay) ! cloud single scattering albedo +! real(kind=rb) :: mean_asmc_stoch(ncol,nlay) ! cloud asymmetry parameter +! real(kind=rb) :: mean_fsfc_stoch(ncol,nlay) ! cloud forward scattering fraction + +! Set overlap + integer(kind=im) :: overlap ! 1 = random overlap, 2 = maximum-random, + ! 3 = maximum overlap, 4 = exponential, + ! 5 = exponential-random + real(kind=rb), parameter :: Zo = 2500._rb ! length scale (m) + real(kind=rb), dimension(ncol,nlay) :: alpha ! overlap parameter + +! Constants (min value for cloud fraction and cloud water and ice) + real(kind=rb), parameter :: cldmin = 1.0e-20_rb ! min cloud fraction +! real(kind=rb), parameter :: qmin = 1.0e-10_rb ! min cloud water and cloud ice (not used) + +! Variables related to random number and seed + real(kind=rb), dimension(nsubcol, ncol, nlay) :: CDF, CDF2 ! random numbers + integer(kind=im), dimension(ncol) :: seed1, seed2, seed3, seed4 ! seed to create random number + real(kind=rb), dimension(ncol) :: rand_num ! random number (kissvec) + integer(kind=im) :: iseed ! seed to create random number (Mersenne Twister) + real(kind=rb) :: rand_num_mt ! random number (Mersenne Twister) + +! Flag to identify cloud fraction in subcolumns + logical, dimension(nsubcol, ncol, nlay) :: isCloudy ! flag that says whether a gridbox is cloudy + +! Indices + integer(kind=im) :: ilev, isubcol, i, n, ngbm ! indices + +!------------------------------------------------------------------------------------------ + +! Check that irng is in bounds; if not, set to default + if (irng .ne. 0) irng = 1 + +! Pass input cloud overlap setting to local variable + overlap = icld + +! Ensure that cloud fractions are in bounds + do ilev = 1, nlay + do i = 1, ncol + cldf(i,ilev) = cld(i,ilev) + if (cldf(i,ilev) < cldmin) then + cldf(i,ilev) = 0._rb + endif + enddo + enddo + +! ----- Create seed -------- + +! Advance randum number generator by changeseed values + if (irng.eq.0) then +! For kissvec, create a seed that depends on the state of the columns. Maybe not the best way, but it works. + +! Must use pmid from bottom four layers. + do i=1,ncol + if (pmid(i,1).lt.pmid(i,2)) then + stop 'MCICA_SUBCOL: KISSVEC SEED GENERATOR REQUIRES PMID FROM BOTTOM FOUR LAYERS.' + endif + seed1(i) = (pmid(i,1) - int(pmid(i,1))) * 1000000000_im + seed2(i) = (pmid(i,2) - int(pmid(i,2))) * 1000000000_im + seed3(i) = (pmid(i,3) - int(pmid(i,3))) * 1000000000_im + seed4(i) = (pmid(i,4) - int(pmid(i,4))) * 1000000000_im + enddo + do i=1,changeSeed + call kissvec(seed1, seed2, seed3, seed4, rand_num) + enddo + elseif (irng.eq.1) then + randomNumbers = new_RandomNumberSequence(seed = changeSeed) + endif + + +! ------ Apply overlap assumption -------- + +! generate the random numbers + + select case (overlap) + + + case(1) +! Random overlap +! i) pick a random value at every level + + if (irng.eq.0) then + do isubcol = 1,nsubcol + do ilev = 1,nlay + call kissvec(seed1, seed2, seed3, seed4, rand_num) + CDF(isubcol,:,ilev) = rand_num + enddo + enddo + elseif (irng.eq.1) then + do isubcol = 1, nsubcol + do i = 1, ncol + do ilev = 1, nlay + rand_num_mt = getRandomReal(randomNumbers) + CDF(isubcol,i,ilev) = rand_num_mt + enddo + enddo + enddo + endif + + case(2) +! Maximum-Random overlap +! i) pick a random number for top layer. +! ii) walk down the column: +! - if the layer above is cloudy, we use the same random number than in the layer above +! - if the layer above is clear, we use a new random number + + if (irng.eq.0) then + do isubcol = 1,nsubcol + do ilev = 1,nlay + call kissvec(seed1, seed2, seed3, seed4, rand_num) + CDF(isubcol,:,ilev) = rand_num + enddo + enddo + elseif (irng.eq.1) then + do isubcol = 1, nsubcol + do i = 1, ncol + do ilev = 1, nlay + rand_num_mt = getRandomReal(randomNumbers) + CDF(isubcol,i,ilev) = rand_num_mt + enddo + enddo + enddo + endif + + do ilev = 2,nlay + do i = 1, ncol + do isubcol = 1, nsubcol + if (CDF(isubcol, i, ilev-1) > 1._rb - cldf(i,ilev-1) ) then + CDF(isubcol,i,ilev) = CDF(isubcol,i,ilev-1) + else + CDF(isubcol,i,ilev) = CDF(isubcol,i,ilev) * (1._rb - cldf(i,ilev-1)) + endif + enddo + enddo + enddo + + + case(3) +! Maximum overlap +! i) pick same random numebr at every level + + if (irng.eq.0) then + do isubcol = 1,nsubcol + call kissvec(seed1, seed2, seed3, seed4, rand_num) + do ilev = 1,nlay + CDF(isubcol,:,ilev) = rand_num + enddo + enddo + elseif (irng.eq.1) then + do isubcol = 1, nsubcol + do i = 1, ncol + rand_num_mt = getRandomReal(randomNumbers) + do ilev = 1, nlay + CDF(isubcol,i,ilev) = rand_num_mt + enddo + enddo + enddo + endif + + +! mji - Activate exponential cloud overlap option + case(4) + ! Exponential overlap: weighting between maximum and random overlap increases with the distance. + ! The random numbers for exponential overlap verify: + ! j=1 RAN(j)=RND1 + ! j>1 if RND1 < alpha(j,j-1) => RAN(j) = RAN(j-1) + ! RAN(j) = RND2 + ! alpha is obtained from the equation + ! alpha = exp(-(Z(j)-Z(j-1))/Zo) where Zo is a characteristic length scale + + ! compute alpha + do i = 1, ncol + alpha(i, 1) = 0._rb + do ilev = 2,nlay + alpha(i, ilev) = exp( -( hgt (i, ilev) - hgt (i, ilev-1)) / Zo) + enddo + enddo + + ! generate 2 streams of random numbers + if (irng.eq.0) then + do isubcol = 1,nsubcol + do ilev = 1,nlay + call kissvec(seed1, seed2, seed3, seed4, rand_num) + CDF(isubcol, :, ilev) = rand_num + call kissvec(seed1, seed2, seed3, seed4, rand_num) + CDF2(isubcol, :, ilev) = rand_num + enddo + enddo + elseif (irng.eq.1) then + do isubcol = 1, nsubcol + do i = 1, ncol + do ilev = 1, nlay + rand_num_mt = getRandomReal(randomNumbers) + CDF(isubcol,i,ilev) = rand_num_mt + rand_num_mt = getRandomReal(randomNumbers) + CDF2(isubcol,i,ilev) = rand_num_mt + enddo + enddo + enddo + endif + + ! generate random numbers + do ilev = 2,nlay + where (CDF2(:, :, ilev) < spread(alpha (:,ilev), dim=1, nCopies=nsubcol) ) + CDF(:,:,ilev) = CDF(:,:,ilev-1) + end where + end do + +! mji - Activate exponential-random cloud overlap option + case(5) + ! Exponential-random overlap: +! call wrf_error_fatal("Cloud Overlap case 5: ER has not yet been implemented. Stopping...") + + end select + + +! -- generate subcolumns for homogeneous clouds ----- + do ilev = 1, nlay + isCloudy(:,:,ilev) = (CDF(:,:,ilev) >= 1._rb - spread(cldf(:,ilev), dim=1, nCopies=nsubcol) ) + enddo + +! where the subcolumn is cloudy, the subcolumn cloud fraction is 1; +! where the subcolumn is not cloudy, the subcolumn cloud fraction is 0; +! where there is a cloud, define the subcolumn cloud properties, +! otherwise set these to zero + + ngbm = ngb(1) - 1 + do ilev = 1,nlay + do i = 1, ncol + do isubcol = 1, nsubcol + if ( iscloudy(isubcol,i,ilev) ) then + cld_stoch(isubcol,i,ilev) = 1._rb + clwp_stoch(isubcol,i,ilev) = clwp(i,ilev) + ciwp_stoch(isubcol,i,ilev) = ciwp(i,ilev) + cswp_stoch(isubcol,i,ilev) = cswp(i,ilev) + n = ngb(isubcol) - ngbm + tauc_stoch(isubcol,i,ilev) = tauc(n,i,ilev) + ssac_stoch(isubcol,i,ilev) = ssac(n,i,ilev) + asmc_stoch(isubcol,i,ilev) = asmc(n,i,ilev) + fsfc_stoch(isubcol,i,ilev) = fsfc(n,i,ilev) + else + cld_stoch(isubcol,i,ilev) = 0._rb + clwp_stoch(isubcol,i,ilev) = 0._rb + ciwp_stoch(isubcol,i,ilev) = 0._rb + cswp_stoch(isubcol,i,ilev) = 0._rb + tauc_stoch(isubcol,i,ilev) = 0._rb + ssac_stoch(isubcol,i,ilev) = 1._rb + asmc_stoch(isubcol,i,ilev) = 0._rb + fsfc_stoch(isubcol,i,ilev) = 0._rb + endif + enddo + enddo + enddo + + +! -- compute the means of the subcolumns --- +! mean_cld_stoch(:,:) = 0._rb +! mean_clwp_stoch(:,:) = 0._rb +! mean_ciwp_stoch(:,:) = 0._rb +! mean_tauc_stoch(:,:) = 0._rb +! mean_ssac_stoch(:,:) = 0._rb +! mean_asmc_stoch(:,:) = 0._rb +! mean_fsfc_stoch(:,:) = 0._rb +! do i = 1, nsubcol +! mean_cld_stoch(:,:) = cld_stoch(i,:,:) + mean_cld_stoch(:,:) +! mean_clwp_stoch(:,:) = clwp_stoch( i,:,:) + mean_clwp_stoch(:,:) +! mean_ciwp_stoch(:,:) = ciwp_stoch( i,:,:) + mean_ciwp_stoch(:,:) +! mean_tauc_stoch(:,:) = tauc_stoch( i,:,:) + mean_tauc_stoch(:,:) +! mean_ssac_stoch(:,:) = ssac_stoch( i,:,:) + mean_ssac_stoch(:,:) +! mean_asmc_stoch(:,:) = asmc_stoch( i,:,:) + mean_asmc_stoch(:,:) +! mean_fsfc_stoch(:,:) = fsfc_stoch( i,:,:) + mean_fsfc_stoch(:,:) +! end do +! mean_cld_stoch(:,:) = mean_cld_stoch(:,:) / nsubcol +! mean_clwp_stoch(:,:) = mean_clwp_stoch(:,:) / nsubcol +! mean_ciwp_stoch(:,:) = mean_ciwp_stoch(:,:) / nsubcol +! mean_tauc_stoch(:,:) = mean_tauc_stoch(:,:) / nsubcol +! mean_ssac_stoch(:,:) = mean_ssac_stoch(:,:) / nsubcol +! mean_asmc_stoch(:,:) = mean_asmc_stoch(:,:) / nsubcol +! mean_fsfc_stoch(:,:) = mean_fsfc_stoch(:,:) / nsubcol + + end subroutine generate_stochastic_clouds_sw + + +!-------------------------------------------------------------------------------------------------- + subroutine kissvec(seed1,seed2,seed3,seed4,ran_arr) +!-------------------------------------------------------------------------------------------------- + +! public domain code made available from http://www.fortran.com/ +! downloaded by pjr on 03/16/04 for NCAR CAM +! converted to vector form, functions inlined by pjr,mvr on 05/10/2004 + +! The KISS (Keep It Simple Stupid) random number generator. Combines: +! (1) The congruential generator x(n)=69069*x(n-1)+1327217885, period 2^32. +! (2) A 3-shift shift-register generator, period 2^32-1, +! (3) Two 16-bit multiply-with-carry generators, period 597273182964842497>2^59 +! Overall period>2^123; + +! + real(kind=rb), dimension(:), intent(inout) :: ran_arr + integer(kind=im), dimension(:), intent(inout) :: seed1,seed2,seed3,seed4 + integer(kind=im) :: i,sz,kiss + integer(kind=im) :: m, k, n + +! inline function + m(k, n) = ieor (k, ishft (k, n) ) + + sz = size(ran_arr) + do i = 1, sz + seed1(i) = 69069_im * seed1(i) + 1327217885_im + seed2(i) = m (m (m (seed2(i), 13_im), - 17_im), 5_im) + seed3(i) = 18000_im * iand (seed3(i), 65535_im) + ishft (seed3(i), - 16_im) + seed4(i) = 30903_im * iand (seed4(i), 65535_im) + ishft (seed4(i), - 16_im) + kiss = seed1(i) + seed2(i) + ishft (seed3(i), 16_im) + seed4(i) + ran_arr(i) = kiss*2.328306e-10_rb + 0.5_rb + end do + + end subroutine kissvec + +!! @} + +! +!........................................! + end module rrtmg_sw ! +!========================================! From 28d1bc22802b30220a3f5f0782b50b9d2d66d9f4 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Tue, 7 Apr 2020 10:29:48 -0600 Subject: [PATCH 8/9] Clean up HWRF RRTMG additions --- physics/GFS_rrtmg_pre.F90 | 265 +- physics/GFS_rrtmg_pre.meta | 17 - physics/GFS_rrtmg_setup.F90 | 32 +- physics/GFS_rrtmg_setup.meta | 4 +- physics/module_MP_FER_HIRES.F90 | 4 +- physics/physparam.f | 2 + physics/radiation_clouds.f | 151 +- physics/radlw_main.F90 | 191 +- physics/radlw_main.meta | 32 - physics/radsw_main.F90 | 175 +- physics/radsw_main.f | 5472 ------------------------------- physics/radsw_main.meta | 40 - 12 files changed, 265 insertions(+), 6120 deletions(-) delete mode 100644 physics/radsw_main.f diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 952673f95..8acb24a50 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -20,7 +20,7 @@ end subroutine GFS_rrtmg_pre_init ! in the CCPP version - they are defined in the interstitial_create routine subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input Tbd, Cldprop, Coupling, & - Radtend,dx, & ! input/output + Radtend, dx, & ! input/output f_ice, f_rain, f_rimef, flgmin, cwm, & ! F-A mp scheme only lm, im, lmk, lmp, & ! input kd, kt, kb, raddt, delp, dz, plvl, plyr, & ! output @@ -32,47 +32,50 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input faerlw1, faerlw2, faerlw3, aerodp, & clouds1, clouds2, clouds3, clouds4, clouds5, clouds6, & clouds7, clouds8, clouds9, cldsa, & - mtopa, mbota, de_lgth, alb1d, errmsg, errflg, & - mpirank, mpiroot) + mtopa, mbota, de_lgth, alb1d, errmsg, errflg) use machine, only: kind_phys - use GFS_typedefs, only: GFS_statein_type, & - GFS_stateout_type, & - GFS_sfcprop_type, & - GFS_coupling_type, & - GFS_control_type, & - GFS_grid_type, & - GFS_tbd_type, & - GFS_cldprop_type, & - GFS_radtend_type, & + use GFS_typedefs, only: GFS_statein_type, & + GFS_stateout_type, & + GFS_sfcprop_type, & + GFS_coupling_type, & + GFS_control_type, & + GFS_grid_type, & + GFS_tbd_type, & + GFS_cldprop_type, & + GFS_radtend_type, & GFS_diag_type use physparam - use physcons, only: eps => con_eps, & - & epsm1 => con_epsm1, & - & fvirt => con_fvirt & - &, rog => con_rog & - &, rocp => con_rocp - use radcons, only: itsfc,ltp, lextop, qmin, & + use physcons, only: eps => con_eps, & + epsm1 => con_epsm1, & + fvirt => con_fvirt, & + rog => con_rog, & + rocp => con_rocp, & + con_rd + use radcons, only: itsfc,ltp, lextop, qmin, & qme5, qme6, epsq, prsmin use funcphys, only: fpvs - use module_radiation_astronomy,only: coszmn ! sol_init, sol_update - use module_radiation_gases, only: NF_VGAS, getgases, getozn ! gas_init, gas_update, - use module_radiation_aerosols, only: NF_AESW, NF_AELW, setaer, & ! aer_init, aer_update, - & NSPC1 - use module_radiation_clouds, only: NF_CLDS, & ! cld_init - & progcld1, progcld3, & -! & progcld2, & - & progcld4, progcld5, & - & progcld6, & !F-A - & progclduni, & - & cal_cldfra3, find_cloudLayers,adjust_cloudIce,adjust_cloudH2O, & - & adjust_cloudFinal - - use module_radsw_parameters, only: topfsw_type, sfcfsw_type, & - & profsw_type, NBDSW - use module_radlw_parameters, only: topflw_type, sfcflw_type, & - & proflw_type, NBDLW + use module_radiation_astronomy,only: coszmn ! sol_init, sol_update + use module_radiation_gases, only: NF_VGAS, getgases, getozn ! gas_init, gas_update, + use module_radiation_aerosols, only: NF_AESW, NF_AELW, setaer, & ! aer_init, aer_update, + NSPC1 + use module_radiation_clouds, only: NF_CLDS, & ! cld_init + progcld1, progcld3, & + progcld2, & + progcld4, progcld5, & + progcld6, & ! F-A + progclduni, & + cal_cldfra3, & + find_cloudLayers, & + adjust_cloudIce, & + adjust_cloudH2O, & + adjust_cloudFinal + + use module_radsw_parameters, only: topfsw_type, sfcfsw_type, & + profsw_type, NBDSW + use module_radlw_parameters, only: topflw_type, sfcflw_type, & + proflw_type, NBDLW use surface_perturbation, only: cdfnor implicit none @@ -86,19 +89,18 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input type(GFS_cldprop_type), intent(in) :: Cldprop type(GFS_coupling_type), intent(in) :: Coupling - integer, intent(in) :: im, lm, lmk, lmp - integer, intent(out) :: kd, kt, kb + integer, intent(in) :: im, lm, lmk, lmp + integer, intent(out) :: kd, kt, kb ! F-A mp scheme only - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(in) :: f_ice - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(in) :: f_rain - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(in) :: f_rimef - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: cwm - real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(in) :: flgmin + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(in) :: f_ice + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(in) :: f_rain + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(in) :: f_rimef + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: cwm + real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(in) :: flgmin real(kind=kind_phys), intent(out) :: raddt - - real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(in) :: dx - INTEGER, INTENT(IN) :: mpirank,mpiroot + + real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(in) :: dx real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: delp real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: dz real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+1+LTP), intent(out) :: plvl @@ -160,11 +162,12 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input htswc, htlwc, gcice, grain, grime, htsw0, htlw0, & rhly, tvly,qstl, vvel, clw, ciw, prslk1, tem2da, & cldcov, deltaq, cnvc, cnvw, & - effrl, effri, effrr, effrs,rho,plyrpa + effrl, effri, effrr, effrs, rho, plyrpa real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP+1) :: tem2db - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP) :: qc_save, qi_save - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP) :: qs_save + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP) :: qc_save + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP) :: qi_save + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP) :: qs_save real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,min(4,Model%ncnd)) :: ccnd real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,2:Model%ntrac) :: tracer1 @@ -172,11 +175,10 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,NF_VGAS) :: gasvmr real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,NBDSW,NF_AESW)::faersw real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,NBDLW,NF_AELW)::faerlw -!mz *temporary - real(kind=kind_phys),parameter:: con_rd =2.8705e+2_kind_phys - INTEGER :: ids, ide, jds, jde, kds, kde, & - & ims, ime, jms, jme, kms, kme, & - & its, ite, jts, jte, kts, kte + + integer :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ! !===> ... begin here @@ -188,8 +190,8 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input if (.not. (Model%lsswr .or. Model%lslwr)) return !--- set commonly used integers - me = Model%me - NFXR = Model%nfxr + me = Model%me + NFXR = Model%nfxr NTRAC = Model%ntrac ! tracers in grrad strip off sphum - start tracer1(2:NTRAC) ntcw = Model%ntcw ntiw = Model%ntiw @@ -542,7 +544,7 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input ccnd(i,k,1) = tracer1(i,k,ntcw) ! liquid water/ice enddo enddo - elseif (Model%ncnd == 2) then ! MG or + elseif (Model%ncnd == 2) then ! MG do k=1,LMK do i=1,IM ccnd(i,k,1) = tracer1(i,k,ntcw) ! liquid water @@ -651,7 +653,6 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input cldcov = 0.0 endif - ! ! --- add suspended convective cloud water to grid-scale cloud water ! only for cloud fraction & radiation computation @@ -687,79 +688,71 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input enddo endif -!mz HWRF physics: icloud=3 - ! Set internal dimensions - ids = 1 - ims = 1 - its = 1 - ide = size(Grid%xlon,1) - ime = size(Grid%xlon,1) - ite = size(Grid%xlon,1) - jds = 1 - jms = 1 - jts = 1 - jde = 1 - jme = 1 - jte = 1 - kds = 1 - kms = 1 - kts = 1 - kde = Model%levr+LTP - kme = Model%levr+LTP - kte = Model%levr+LTP - - do k = 1, LMK - do i = 1, IM - rho(i,k)=plyr(i,k)*100./(con_rd*tlyr(i,k)) - plyrpa(i,k)=plyr(i,k)*100. !hPa->Pa - end do - end do - - do i=1,im - if (Sfcprop%slmsk(i)==1. .or. Sfcprop%slmsk(i)==2.) then !sea/land/ice mask (=0/1/2) in FV3 - xland(i)=1.0 !but land/water = (1/2) in HWRF - else - xland(i)=2.0 - endif - enddo - - - gridkm = 1.414*SQRT(dx(1)*0.001*dx(1)*0.001 ) + !mz HWRF physics: icloud=3 + if(Model%icloud == 3) then + + ! Set internal dimensions + ids = 1 + ims = 1 + its = 1 + ide = size(Grid%xlon,1) + ime = size(Grid%xlon,1) + ite = size(Grid%xlon,1) + jds = 1 + jms = 1 + jts = 1 + jde = 1 + jme = 1 + jte = 1 + kds = 1 + kms = 1 + kts = 1 + kde = Model%levr+LTP + kme = Model%levr+LTP + kte = Model%levr+LTP + do k = 1, LMK + do i = 1, IM + rho(i,k)=plyr(i,k)*100./(con_rd*tlyr(i,k)) + plyrpa(i,k)=plyr(i,k)*100. !hPa->Pa + end do + end do - if(Model%icloud == 3) then - do i =1, im - do k =1, lmk - qc_save(i,k) = ccnd(i,k,1) - qi_save(i,k) = ccnd(i,k,2) - qs_save(i,k) = ccnd(i,k,4) - enddo - enddo + do i=1,im + if (Sfcprop%slmsk(i)==1. .or. Sfcprop%slmsk(i)==2.) then ! sea/land/ice mask (=0/1/2) in FV3 + xland(i)=1.0 ! but land/water = (1/2) in HWRF + else + xland(i)=2.0 + endif + enddo + gridkm = sqrt(2.0)*sqrt(dx(1)*0.001*dx(1)*0.001) - CALL cal_cldfra3(cldcov,qlyr,ccnd(:,:,1),ccnd(:,:,2), & - & ccnd(:,:,4),plyrpa,tlyr, RHO,XLAND,GRIDKM, & - & ids,ide, jds,jde, kds,kde, & - & ims,ime, jms,jme, kms,kme, & - & its,ite, jts,jte, kts,kte) -! if(mpirank == mpiroot) then -! write(0,*)'cal_cldfra3::max/min(cldcov) =', maxval(cldcov), & -! & minval(cldcov) -! endif + do i =1, im + do k =1, lmk + qc_save(i,k) = ccnd(i,k,1) + qi_save(i,k) = ccnd(i,k,2) + qs_save(i,k) = ccnd(i,k,4) + enddo + enddo - !mz* back to micro-only qc qi,qs - do i =1, im - do k =1, lmk - ccnd(i,k,1) = qc_save(i,k) - ccnd(i,k,2) = qi_save(i,k) - ccnd(i,k,4) = qs_save(i,k) - enddo - enddo - endif + call cal_cldfra3(cldcov,qlyr,ccnd(:,:,1),ccnd(:,:,2), & + ccnd(:,:,4),plyrpa,tlyr,rho,xland,gridkm, & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte) + !mz* back to micro-only qc qi,qs + do i =1, im + do k =1, lmk + ccnd(i,k,1) = qc_save(i,k) + ccnd(i,k,2) = qi_save(i,k) + ccnd(i,k,4) = qs_save(i,k) + enddo + enddo -!mz*end + endif ! icloud == 3 if (lextop) then do i=1,im @@ -787,12 +780,11 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input ! or unified cloud and/or with MG microphysics if (Model%uni_cld .and. Model%ncld >= 2) then - call progclduni (plyr, plvl, tlyr, tvly, ccnd, ncndl, & ! --- inputs - Grid%xlat, Grid%xlon, Sfcprop%slmsk,dz,delp, & - IM, LMK, LMP, cldcov, & - effrl, effri, effrr, effrs, Model%effr_in, & - Model%iovr_lw, Model%iovr_sw, & ! mz* for iovr=3 should come from - clouds, cldsa, mtopa, mbota, de_lgth) ! --- outputs + call progclduni (plyr, plvl, tlyr, tvly, ccnd, ncndl, & ! --- inputs + Grid%xlat, Grid%xlon, Sfcprop%slmsk,dz,delp, & + IM, LMK, LMP, cldcov, & + effrl, effri, effrr, effrs, Model%effr_in, & + clouds, cldsa, mtopa, mbota, de_lgth) ! --- outputs else call progcld1 (plyr ,plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs ccnd(1:IM,1:LMK,1), Grid%xlat,Grid%xlon, & @@ -800,7 +792,6 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input Model%uni_cld, Model%lmfshal, & Model%lmfdeep2, cldcov, & effrl, effri, effrr, effrs, Model%effr_in, & - Model%iovr_lw, Model%iovr_sw, & clouds, cldsa, mtopa, mbota, de_lgth) ! --- outputs endif @@ -811,7 +802,6 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input cnvw, cnvc, Grid%xlat, Grid%xlon, & Sfcprop%slmsk, dz, delp, im, lmk, lmp, deltaq, & Model%sup, Model%kdt, me, & - Model%iovr_lw, Model%iovr_sw, & clouds, cldsa, mtopa, mbota, de_lgth) ! --- outputs @@ -822,16 +812,14 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input ccnd(1:IM,1:LMK,1), cnvw, cnvc, & Grid%xlat, Grid%xlon, Sfcprop%slmsk, & cldcov, dz, delp, im, lmk, lmp, & - Model%iovr_lw, Model%iovr_sw, & - clouds, cldsa, mtopa, mbota, de_lgth) ! --- outputs + clouds, cldsa, mtopa, mbota, de_lgth) ! --- outputs else call progclduni (plyr, plvl, tlyr, tvly, ccnd, ncndl, & ! --- inputs Grid%xlat, Grid%xlon, Sfcprop%slmsk, dz,delp, & IM, LMK, LMP, cldcov, & effrl, effri, effrr, effrs, Model%effr_in, & - Model%iovr_lw, Model%iovr_sw, & - clouds, cldsa, mtopa, mbota, de_lgth) ! --- outputs + clouds, cldsa, mtopa, mbota, de_lgth) ! --- outputs ! call progcld4o (plyr, plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs ! tracer1, Grid%xlat, Grid%xlon, Sfcprop%slmsk, & ! dz, delp, & @@ -841,14 +829,15 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input ! clouds, cldsa, mtopa, mbota, de_lgth) ! --- outputs endif - elseif(Model%imp_physics == 8 .or. Model%imp_physics == 6 ) then + elseif(Model%imp_physics == 8) then if (Model%kdt == 1) then Tbd%phy_f3d(:,:,Model%nleffr) = 10. Tbd%phy_f3d(:,:,Model%nieffr) = 50. Tbd%phy_f3d(:,:,Model%nseffr) = 250. endif - !mz* this is original progcld5 - temporary + ! mz* this is the original progcld5 - temporary + ! will be replaced with GSL's version of progcld6 for Thompson MP call progcld6 (plyr,plvl,tlyr,qlyr,qstl,rhly,tracer1, & ! --- inputs Grid%xlat,Grid%xlon,Sfcprop%slmsk,dz,delp, & ntrac-1, ntcw-1,ntiw-1,ntrw-1, & @@ -857,8 +846,7 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input Model%lmfshal,Model%lmfdeep2, & cldcov(:,1:LMK),Tbd%phy_f3d(:,:,1), & Tbd%phy_f3d(:,:,2), Tbd%phy_f3d(:,:,3), & - Model%iovr_lw, Model%iovr_sw, & - clouds,cldsa,mtopa,mbota, de_lgth) ! --- outputs + clouds,cldsa,mtopa,mbota, de_lgth) ! --- outputs elseif(Model%imp_physics == 15) then @@ -876,7 +864,6 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input Model%lmfshal,Model%lmfdeep2, & cldcov(:,1:LMK),Tbd%phy_f3d(:,:,1), & Tbd%phy_f3d(:,:,2), Tbd%phy_f3d(:,:,3), & - Model%iovr_lw, Model%iovr_sw, & clouds,cldsa,mtopa,mbota, de_lgth) ! --- outputs endif ! end if_imp_physics diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 716090962..2c00f697b 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -573,23 +573,6 @@ type = integer intent = out optional = F -[mpirank] - standard_name = mpi_rank - long_name = current MPI-rank - units = index - dimensions = () - type = integer - intent = in - optional = F -[mpiroot] - standard_name = mpi_root - long_name = master MPI-rank - units = index - dimensions = () - type = integer - intent = in - optional = F - ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_rrtmg_setup.F90 b/physics/GFS_rrtmg_setup.F90 index 043ea8560..7a52f573c 100644 --- a/physics/GFS_rrtmg_setup.F90 +++ b/physics/GFS_rrtmg_setup.F90 @@ -5,9 +5,9 @@ module GFS_rrtmg_setup use physparam, only : isolar , ictmflg, ico2flg, ioznflg, iaerflg,& ! & iaermdl, laswflg, lalwflg, lavoflg, icldflg, & & iaermdl, icldflg, & - & lcrick , lcnorm , lnoprec, & - & ialbflg, iemsflg, ivflip , ipsd0, & -! & iswcliq, & + & iovrsw , iovrlw , lcrick , lcnorm , lnoprec, & + & ialbflg, iemsflg, isubcsw, isubclw, ivflip , ipsd0, & + & iswcliq, & & kind_phys use radcons, only: ltp, lextop @@ -178,8 +178,8 @@ subroutine GFS_rrtmg_setup_init ( & integer, intent(in) :: num_p3d integer, intent(in) :: npdf3d integer, intent(in) :: ntoz - integer, intent(inout) :: iovr_sw - integer, intent(inout) :: iovr_lw + integer, intent(in) :: iovr_sw + integer, intent(in) :: iovr_lw integer, intent(in) :: isubc_sw integer, intent(in) :: isubc_lw integer, intent(in) :: icliq_sw @@ -205,8 +205,6 @@ subroutine GFS_rrtmg_setup_init ( & real(kind_phys), dimension(im,NSPC1) :: aerodp_check ! End for consistency checks - integer :: iswcliq - ! Initialize the CCPP error handling variables errmsg = '' errflg = 0 @@ -271,14 +269,14 @@ subroutine GFS_rrtmg_setup_init ( & iswcliq = icliq_sw ! optical property for liquid clouds for sw - ! iovrsw = iovr_sw ! cloud overlapping control flag for sw - ! iovrlw = iovr_lw ! cloud overlapping control flag for lw + iovrsw = iovr_sw ! cloud overlapping control flag for sw + iovrlw = iovr_lw ! cloud overlapping control flag for lw lcrick = crick_proof ! control flag for eliminating CRICK lcnorm = ccnorm ! control flag for in-cld condensate lnoprec = norad_precip ! precip effect on radiation flag (ferrier microphysics) -! isubcsw = isubc_sw ! sub-column cloud approx flag in sw radiation -! isubclw = isubc_lw ! sub-column cloud approx flag in lw radiation + isubcsw = isubc_sw ! sub-column cloud approx flag in sw radiation + isubclw = isubc_lw ! sub-column cloud approx flag in lw radiation ialbflg= ialb ! surface albedo control flag iemsflg= iems ! surface emissivity control flag @@ -306,7 +304,7 @@ subroutine GFS_rrtmg_setup_init ( & call radinit & ! --- inputs: - & ( si, levr, imp_physics,iswcliq, iovr_lw, iovr_sw, isubc_lw, isubc_sw, me ) + & ( si, levr, imp_physics, me ) ! --- outputs: ! ( none ) @@ -387,7 +385,7 @@ end subroutine GFS_rrtmg_setup_finalize ! Private functions - subroutine radinit( si, NLAY, imp_physics,iswcliq, iovrlw,iovrsw,isubclw,isubcsw, me ) + subroutine radinit( si, NLAY, imp_physics, me ) !................................... ! --- inputs: @@ -512,10 +510,8 @@ subroutine radinit( si, NLAY, imp_physics,iswcliq, iovrlw,iovrsw,isubclw,isubcsw implicit none ! --- inputs: - integer, intent(in) :: NLAY, me, imp_physics, & - & isubclw,isubcsw,iswcliq + integer, intent(in) :: NLAY, me, imp_physics - integer, intent(inout) :: iovrlw,iovrsw real (kind=kind_phys), intent(in) :: si(:) ! --- outputs: (none, to module variables) @@ -624,9 +620,9 @@ subroutine radinit( si, NLAY, imp_physics,iswcliq, iovrlw,iovrsw,isubclw,isubcsw call cld_init ( si, NLAY, imp_physics, me) ! --- ... cloud initialization routine - call rlwinit (iovrlw,isubclw, me ) ! --- ... lw radiation initialization routine + call rlwinit ( me ) ! --- ... lw radiation initialization routine - call rswinit (iswcliq, iovrsw,isubcsw, me ) ! --- ... sw radiation initialization routine + call rswinit ( me ) ! --- ... sw radiation initialization routine ! return !................................... diff --git a/physics/GFS_rrtmg_setup.meta b/physics/GFS_rrtmg_setup.meta index 4f96b76f1..18ed4c49c 100644 --- a/physics/GFS_rrtmg_setup.meta +++ b/physics/GFS_rrtmg_setup.meta @@ -112,7 +112,7 @@ units = flag dimensions = () type = integer - intent = inout + intent = in optional = F [iovr_lw] standard_name = flag_for_cloud_overlapping_method_for_longwave_radiation @@ -120,7 +120,7 @@ units = flag dimensions = () type = integer - intent = inout + intent = in optional = F [isubc_sw] standard_name = flag_for_sw_clouds_grid_approximation diff --git a/physics/module_MP_FER_HIRES.F90 b/physics/module_MP_FER_HIRES.F90 index 23a2de7d7..02a09481b 100644 --- a/physics/module_MP_FER_HIRES.F90 +++ b/physics/module_MP_FER_HIRES.F90 @@ -306,7 +306,7 @@ SUBROUTINE FER_HIRES (DT,RHgrd, & !----------------------------------------------------------------------- ! -! MZ: HWRF practice start +! MZ: HWRF start !---------- !2015-03-30, recalculate some constants which may depend on phy time step CALL MY_GROWTH_RATES_NMM_hr (DT) @@ -341,7 +341,7 @@ SUBROUTINE FER_HIRES (DT,RHgrd, & !write(*,*)'braut=',braut !! END OF adding, 2015-03-30 !----------- -! MZ: HWRF practice end +! MZ: HWRF end ! DO j = jms,jme diff --git a/physics/physparam.f b/physics/physparam.f index 795cb4fab..e722297de 100644 --- a/physics/physparam.f +++ b/physics/physparam.f @@ -234,6 +234,7 @@ module physparam !!\n =1:use maximum-random cloud overlapping method !!\n =2:use maximum cloud overlapping method !!\n =3:use decorrelation length overlapping method +!!\n =4: exponential overlapping cloud !!\n Opr GFS/CFS=1; see IOVR_SW in run scripts integer, save :: iovrsw = 1 !> cloud overlapping control flag for LW @@ -241,6 +242,7 @@ module physparam !!\n =1:use maximum-random cloud overlapping method !!\n =2:use maximum cloud overlapping method !!\n =3:use decorrelation length overlapping method +!!\n =4: exponential overlapping cloud !!\n Opr GFS/CFS=1; see IOVR_LW in run scripts integer, save :: iovrlw = 1 diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index b76d57eaf..8a943a032 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -194,8 +194,7 @@ !> This module computes cloud related quantities for radiation computations. module module_radiation_clouds ! -!mz* iovrsw, iovrlw need to come from NML - use physparam, only : icldflg, &!mz:iovrsw, iovrlw,& + use physparam, only : icldflg, iovrsw, iovrlw, & & lcrick, lcnorm, lnoprec, & & ivflip use physcons, only : con_fvirt, con_ttp, con_rocp, & @@ -242,13 +241,13 @@ module module_radiation_clouds real (kind=kind_phys), parameter :: cldasy_def = 0.84 !< default cld asymmetry factor integer :: llyr = 2 !< upper limit of boundary layer clouds -!mz integer :: iovr = 1 !< maximum-random cloud overlapping method +! DH* TODO - HOW TO GET/SET THIS CORRECTLY? + integer :: iovr = 1 !< maximum-random cloud overlapping method public progcld1, progcld2, progcld3, progcld4, progclduni, & - & cld_init, progcld5, progcld4o, & - & progcld6, & !mz- for GSL suite - & cal_cldfra3, find_cloudLayers,adjust_cloudIce,adjust_cloudH2O, & - & adjust_cloudFinal + & cld_init, progcld5, progcld6, progcld4o, cal_cldfra3, & + & find_cloudLayers, adjust_cloudIce, adjust_cloudH2O, & + & adjust_cloudFinal ! ================= @@ -307,6 +306,7 @@ subroutine cld_init & ! =1: max/ran overlapping clouds ! ! =2: maximum overlap clouds (mcica only) ! ! =3: decorrelation-length overlap (mcica only) ! +! =4: exponential overlapping cloud ! ! ivflip : control flag for direction of vertical index ! ! =0: index from toa to surface ! ! =1: index from surface to toa ! @@ -333,7 +333,7 @@ subroutine cld_init & ! ! --- set up module variables -!mz iovr = max( iovrsw, iovrlw ) !cld ovlp used for diag HML cld output + iovr = max( iovrsw, iovrlw ) !cld ovlp used for diag HML cld output if (me == 0) print *, VTAGCLD !print out version tag @@ -443,7 +443,6 @@ subroutine progcld1 & & xlat,xlon,slmsk,dz,delp, IX, NLAY, NLP1, & & uni_cld, lmfshal, lmfdeep2, cldcov, & & effrl,effri,effrr,effrs,effr_in, & - & iovr_lw, iovr_sw, & & clouds,clds,mtop,mbot,de_lgth & ! --- outputs: & ) @@ -527,7 +526,7 @@ subroutine progcld1 & implicit none ! --- inputs - integer, intent(in) :: IX, NLAY, NLP1,iovr_lw,iovr_sw + integer, intent(in) :: IX, NLAY, NLP1 logical, intent(in) :: uni_cld, lmfshal, lmfdeep2, effr_in @@ -555,7 +554,7 @@ subroutine progcld1 & real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & & tem1, tem2, tem3 - integer :: i, k, id, nf,iovrw + integer :: i, k, id, nf ! --- constant values ! real (kind=kind_phys), parameter :: xrc3 = 200. @@ -563,8 +562,6 @@ subroutine progcld1 & ! !===> ... begin here -!mz - iovrw = max( iovr_sw, iovr_lw ) !cld ovlp used for diag HML cld output ! do nf=1,nf_clds do k=1,nlay @@ -806,7 +803,7 @@ subroutine progcld1 & ! --- ... estimate clouds decorrelation length in km ! this is only a tentative test, need to consider change later - if ( iovrw == 3 ) then + if ( iovr == 3 ) then do i = 1, ix de_lgth(i) = max( 0.6, 2.78-4.6*rxlat(i) ) enddo @@ -820,7 +817,7 @@ subroutine progcld1 & call gethml & ! --- inputs: & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, & - & IX,NLAY, iovr_lw, iovr_sw, & + & IX,NLAY, & ! --- outputs: & clds, mtop, mbot & & ) @@ -878,7 +875,6 @@ subroutine progcld2 & & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw, & ! --- inputs: & xlat,xlon,slmsk,dz,delp, f_ice,f_rain,r_rime,flgmin, & & IX, NLAY, NLP1, lmfshal, lmfdeep2, & - & iovr_lw, iovr_sw, & & clouds,clds,mtop,mbot,de_lgth & ! --- outputs: & ) @@ -967,7 +963,7 @@ subroutine progcld2 & ! --- constants ! --- inputs - integer, intent(in) :: IX, NLAY, NLP1, iovr_lw,iovr_sw + integer, intent(in) :: IX, NLAY, NLP1 logical, intent(in) :: lmfshal, lmfdeep2 @@ -997,7 +993,7 @@ subroutine progcld2 & real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & & tem1, tem2, tem3 - integer :: i, k, id, iovrw + integer :: i, k, id ! --- constant values ! real (kind=kind_phys), parameter :: xrc3 = 200. @@ -1007,10 +1003,6 @@ subroutine progcld2 & !===> ... begin here ! ! clouds(:,:,:) = 0.0 -!zm -!mz$ - iovrw = max( iovr_sw, iovr_lw ) !cld ovlp used for diag HML cld output$ - !> - Assign water/ice/rain/snow cloud properties for Ferrier scheme. do k = 1, NLAY @@ -1257,7 +1249,7 @@ subroutine progcld2 & ! --- ... estimate clouds decorrelation length in km ! this is only a tentative test, need to consider change later - if ( iovrw == 3 ) then + if ( iovr == 3 ) then do i = 1, ix de_lgth(i) = max( 0.6, 2.78-4.6*rxlat(i) ) enddo @@ -1274,7 +1266,6 @@ subroutine progcld2 & ! --- inputs: & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, & & IX,NLAY, & - & iovr_lw,iovr_sw, & ! --- outputs: & clds, mtop, mbot & & ) @@ -1333,7 +1324,6 @@ subroutine progcld3 & & xlat,xlon,slmsk, dz, delp, & & ix, nlay, nlp1, & & deltaq,sup,kdt,me, & - & iovr_lw, iovr_sw, & & clouds,clds,mtop,mbot,de_lgth & ! --- outputs: & ) @@ -1416,7 +1406,7 @@ subroutine progcld3 & implicit none ! --- inputs - integer, intent(in) :: ix, nlay, nlp1,kdt,iovr_lw,iovr_sw + integer, intent(in) :: ix, nlay, nlp1,kdt real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & & tlyr, tvly, qlyr, qstl, rhly, clw, dz, delp @@ -1448,14 +1438,11 @@ subroutine progcld3 & real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & & tem1, tem2, tem3 - integer :: i, k, id, nf, iovrw + integer :: i, k, id, nf ! !===> ... begin here ! -!mz - iovrw = max( iovr_sw, iovr_lw ) !cld ovlp used for diag HML cld output - do nf=1,nf_clds do k=1,nlay do i=1,ix @@ -1659,7 +1646,7 @@ subroutine progcld3 & ! --- ... estimate clouds decorrelation length in km ! this is only a tentative test, need to consider change later - if ( iovrw == 3 ) then + if ( iovr == 3 ) then do i = 1, ix de_lgth(i) = max( 0.6, 2.78-4.6*rxlat(i) ) enddo @@ -1677,7 +1664,6 @@ subroutine progcld3 & ! --- inputs: & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, & & ix,nlay, & - & iovr_lw,iovr_sw, & ! --- outputs: & clds, mtop, mbot & & ) @@ -1734,8 +1720,7 @@ end subroutine progcld3 subroutine progcld4 & & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw,cnvw,cnvc, & ! --- inputs: & xlat,xlon,slmsk,cldtot, dz, delp, & - & IX, NLAY, NLP1, & - & iovr_lw, iovr_sw, & + & IX, NLAY, NLP1, & & clouds,clds,mtop,mbot,de_lgth & ! --- outputs: & ) @@ -1816,7 +1801,7 @@ subroutine progcld4 & implicit none ! --- inputs - integer, intent(in) :: IX, NLAY, NLP1,iovr_lw,iovr_sw + integer, intent(in) :: IX, NLAY, NLP1 real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & & tlyr, tvly, qlyr, qstl, rhly, clw, cldtot, cnvw, cnvc, & @@ -1842,14 +1827,11 @@ subroutine progcld4 & real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & & tem1, tem2, tem3 - integer :: i, k, id, nf,iovrw + integer :: i, k, id, nf ! !===> ... begin here ! -!mz - iovrw = max( iovr_sw, iovr_lw ) !cld ovlp used for diag HML cld output - do nf=1,nf_clds do k=1,nlay do i=1,ix @@ -2001,7 +1983,7 @@ subroutine progcld4 & ! --- ... estimate clouds decorrelation length in km ! this is only a tentative test, need to consider change later - if ( iovrw == 3 ) then + if ( iovr == 3 ) then do i = 1, ix de_lgth(i) = max( 0.6, 2.78-4.6*rxlat(i) ) enddo @@ -2017,7 +1999,6 @@ subroutine progcld4 & ! --- inputs: & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, & & IX,NLAY, & - & iovr_lw, iovr_sw, & ! --- outputs: & clds, mtop, mbot & & ) @@ -2081,7 +2062,6 @@ subroutine progcld4o & & xlat,xlon,slmsk, dz, delp, & & ntrac,ntcw,ntiw,ntrw,ntsw,ntgl,ntclamt, & & IX, NLAY, NLP1, & - & iovr_lw, iovr_sw, & & clouds,clds,mtop,mbot,de_lgth & ! --- outputs: & ) @@ -2161,7 +2141,7 @@ subroutine progcld4o & implicit none ! --- inputs - integer, intent(in) :: IX, NLAY, NLP1, iovr_lw, iovr_sw + integer, intent(in) :: IX, NLAY, NLP1 integer, intent(in) :: ntrac, ntcw, ntiw, ntrw, ntsw, ntgl, & & ntclamt @@ -2191,12 +2171,10 @@ subroutine progcld4o & & tem1, tem2, tem3 real (kind=kind_phys), dimension(IX,NLAY) :: cldtot - integer :: i, k, id, nf, iovrw + integer :: i, k, id, nf ! !===> ... begin here -!mz - iovrw = max( iovr_sw, iovr_lw ) !cld ovlp used for diag HML cld output ! do nf=1,nf_clds do k=1,nlay @@ -2333,7 +2311,7 @@ subroutine progcld4o & ! --- ... estimate clouds decorrelation length in km ! this is only a tentative test, need to consider change later - if ( iovrw == 3 ) then + if ( iovr == 3 ) then do i = 1, ix de_lgth(i) = max( 0.6, 2.78-4.6*rxlat(i) ) enddo @@ -2349,7 +2327,6 @@ subroutine progcld4o & ! --- inputs: & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, & & IX,NLAY, & - & iovr_lw, iovr_sw, & ! --- outputs: & clds, mtop, mbot & & ) @@ -2373,7 +2350,6 @@ subroutine progcld5 & & IX, NLAY, NLP1,icloud, & & uni_cld, lmfshal, lmfdeep2, cldcov, & & re_cloud,re_ice,re_snow, & - & iovr_lw,iovr_sw, & & clouds,clds,mtop,mbot,de_lgth & ! --- outputs: & ) @@ -2457,16 +2433,15 @@ subroutine progcld5 & implicit none ! --- inputs - integer, intent(in) :: IX, NLAY, NLP1,ICLOUD,iovr_lw,iovr_sw + integer, intent(in) :: IX, NLAY, NLP1, ICLOUD integer, intent(in) :: ntrac, ntcw, ntiw, ntrw, ntsw, ntgl logical, intent(in) :: uni_cld, lmfshal, lmfdeep2 real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & & tlyr, tvly, qlyr, qstl, rhly, cldcov, delp, dz -! & re_cloud, re_ice, re_snow -!mz: for diagnostics purpose +!mz: for diagnostics real (kind=kind_phys), dimension(:,:), intent(inout) :: & & re_cloud, re_ice, re_snow @@ -2492,7 +2467,7 @@ subroutine progcld5 & real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & & tem1, tem2, tem3 - integer :: i, k, id, nf, iovrw + integer :: i, k, id, nf ! --- constant values ! real (kind=kind_phys), parameter :: xrc3 = 200. @@ -2500,8 +2475,6 @@ subroutine progcld5 & ! !===> ... begin here -!mz - iovrw = max( iovr_sw, iovr_lw ) !cld ovlp used for diag HML cld output ! do nf=1,nf_clds do k=1,nlay @@ -2672,19 +2645,9 @@ subroutine progcld5 & enddo endif !mz - if (icloud .ne.0) then + if (icloud .ne. 0) then ! assign/calculate efective radii for cloud water, ice, rain, snow -! if (effr_in) then -! do k = 1, NLAY -! do i = 1, IX -! rew(i,k) = effrl (i,k) -! rei(i,k) = max(10.0, min(150.0,effri (i,k))) -! rer(i,k) = effrr (i,k) -! res(i,k) = effrs (i,k) -! enddo -! enddo -! else do k = 1, NLAY do i = 1, IX rew(i,k) = reliq_def ! default liq radius to 10 micron @@ -2722,11 +2685,7 @@ subroutine progcld5 & else rei(i,k) = (1250.0/9.387) * tem3 ** 0.031 endif -! if (icloud == 3 ) then rei(i,k) = max(25.,rei(i,k)) !mz* HWRF -! else !mz GFDL -! rei(i,k) = max(10.0, min(rei(i,k), 150.0)) -! endif endif rei(i,k) = min(rei(i,k), 135.72) !- 1.0315*rei<= 140 microns enddo @@ -2739,8 +2698,7 @@ subroutine progcld5 & res(i,k) = 10.0 enddo enddo -! endif -! + endif ! end icloud !mz end do k = 1, NLAY @@ -2756,8 +2714,8 @@ subroutine progcld5 & clouds(i,k,8) = 0. clouds(i,k,9) = 10. !mz for diagnostics? - re_cloud(i,k) =rew(i,k) - re_ice(i,k) =rei(i,k) + re_cloud(i,k) = rew(i,k) + re_ice(i,k) = rei(i,k) re_snow(i,k) = 10. enddo @@ -2766,7 +2724,7 @@ subroutine progcld5 & ! --- ... estimate clouds decorrelation length in km ! this is only a tentative test, need to consider change later - if ( iovrw == 3 ) then + if ( iovr == 3 ) then do i = 1, ix de_lgth(i) = max( 0.6, 2.78-4.6*rxlat(i) ) enddo @@ -2785,7 +2743,6 @@ subroutine progcld5 & ! --- inputs: & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, & & IX,NLAY, & - & iovr_lw,iovr_sw, & ! --- outputs: & clds, mtop, mbot & & ) @@ -2806,7 +2763,6 @@ subroutine progcld6 & & IX, NLAY, NLP1, & & uni_cld, lmfshal, lmfdeep2, cldcov, & & re_cloud,re_ice,re_snow, & - & iovr_lw,iovr_sw, & & clouds,clds,mtop,mbot,de_lgth & ! --- outputs: & ) @@ -2891,7 +2847,7 @@ subroutine progcld6 & implicit none ! --- inputs - integer, intent(in) :: IX, NLAY, NLP1,iovr_lw,iovr_sw + integer, intent(in) :: IX, NLAY, NLP1 integer, intent(in) :: ntrac, ntcw, ntiw, ntrw, ntsw, ntgl logical, intent(in) :: uni_cld, lmfshal, lmfdeep2 @@ -2922,7 +2878,7 @@ subroutine progcld6 & real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & & tem1, tem2, tem3 - integer :: i, k, id, nf, iovrw + integer :: i, k, id, nf ! --- constant values ! real (kind=kind_phys), parameter :: xrc3 = 200. @@ -2930,8 +2886,6 @@ subroutine progcld6 & ! !===> ... begin here -!!mz$ - iovrw = max( iovr_sw, iovr_lw ) !cld ovlp used for diag HML cld output$ ! do nf=1,nf_clds @@ -3120,7 +3074,7 @@ subroutine progcld6 & ! --- ... estimate clouds decorrelation length in km ! this is only a tentative test, need to consider change later - if ( iovrw == 3 ) then + if ( iovr == 3 ) then do i = 1, ix de_lgth(i) = max( 0.6, 2.78-4.6*rxlat(i) ) enddo @@ -3139,7 +3093,6 @@ subroutine progcld6 & ! --- inputs: & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, & & IX,NLAY, & - & iovr_lw, iovr_sw, & ! --- outputs: & clds, mtop, mbot & & ) @@ -3197,7 +3150,6 @@ subroutine progclduni & & ( plyr,plvl,tlyr,tvly,ccnd,ncnd, & ! --- inputs: & xlat,xlon,slmsk,dz,delp, IX, NLAY, NLP1, cldtot, & & effrl,effri,effrr,effrs,effr_in, & - & iovr_lw,iovr_sw, & !mz* $ & clouds,clds,mtop,mbot,de_lgth & ! --- outputs: & ) @@ -3292,9 +3244,6 @@ subroutine progclduni & real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & & slmsk - !mz* for GFSv16 - integer, intent(in) :: iovr_lw, iovr_sw - ! --- outputs real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds @@ -3305,7 +3254,6 @@ subroutine progclduni & integer, dimension(:,:), intent(out) :: mtop,mbot ! --- local variables: - integer :: iovrw real (kind=kind_phys), dimension(IX,NLAY) :: cldcnv, cwp, cip, & & crp, csp, rew, rei, res, rer real (kind=kind_phys), dimension(IX,NLAY,ncnd) :: cndf @@ -3327,9 +3275,6 @@ subroutine progclduni & ! enddo ! enddo ! -!mz* - iovrw = max( iovr_sw, iovr_lw ) !cld ovlp used for diag HML cld output - do k = 1, NLAY do i = 1, IX cldcnv(i,k) = 0.0 @@ -3499,7 +3444,7 @@ subroutine progclduni & !> -# Estimate clouds decorrelation length in km ! this is only a tentative test, need to consider change later - if ( iovrw == 3 ) then + if ( iovr == 3 ) then do i = 1, ix de_lgth(i) = max( 0.6, 2.78-4.6*rxlat(i) ) enddo @@ -3518,7 +3463,6 @@ subroutine progclduni & ! --- inputs: & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, & & IX,NLAY, & - & iovr_lw, iovr_sw, & ! --- outputs: & clds, mtop, mbot & & ) @@ -3554,7 +3498,7 @@ end subroutine progclduni !! @{ subroutine gethml & & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, & ! --- inputs: - & IX, NLAY,iovr_lw,iovr_sw, & + & IX, NLAY, & & clds, mtop, mbot & ! --- outputs: & ) @@ -3610,7 +3554,7 @@ subroutine gethml & implicit none! ! --- inputs: - integer, intent(in) :: IX, NLAY,iovr_sw,iovr_lw + integer, intent(in) :: IX, NLAY real (kind=kind_phys), dimension(:,:), intent(in) :: plyr, ptop1, & & cldtot, cldcnv, dz @@ -3626,14 +3570,11 @@ subroutine gethml & real (kind=kind_phys) :: pcur, pnxt, ccur, cnxt, alfa integer, dimension(IX):: idom, kbt1, kth1, kbt2, kth2 - integer :: i, k, id, id1, kstr, kend, kinc,iovrw + integer :: i, k, id, id1, kstr, kend, kinc ! !===> ... begin here ! -!mz* - iovrw = max( iovr_sw, iovr_lw ) !cld ovlp used for diag HML cld output - clds(:,:) = 0.0 do i = 1, IX @@ -3657,7 +3598,7 @@ subroutine gethml & kinc = 1 endif ! end_if_ivflip - if ( iovrw == 0 ) then ! random overlap + if ( iovr == 0 ) then ! random overlap do k = kstr, kend, kinc do i = 1, IX @@ -3676,7 +3617,7 @@ subroutine gethml & clds(i,4) = 1.0 - cl1(i) ! save total cloud enddo - elseif ( iovrw == 1 ) then ! max/ran overlap + elseif ( iovr == 1 ) then ! max/ran overlap do k = kstr, kend, kinc do i = 1, IX @@ -3700,7 +3641,7 @@ subroutine gethml & clds(i,4) = 1.0 - cl1(i) * cl2(i) ! save total cloud enddo - elseif ( iovrw == 2 ) then ! maximum overlap all levels + elseif ( iovr == 2 ) then ! maximum overlap all levels cl1(:) = 0.0 @@ -3721,7 +3662,7 @@ subroutine gethml & clds(i,4) = cl1(i) ! save total cloud enddo - elseif ( iovrw == 3 ) then ! random if clear-layer divided, + elseif ( iovr == 3 ) then ! random if clear-layer divided, ! otherwise de-corrlength method do i = 1, ix dz1(i) = - dz(i,kstr) @@ -3807,7 +3748,7 @@ subroutine gethml & if (kth2(i) == 0) kbt2(i) = k kth2(i) = kth2(i) + 1 - if ( iovrw == 0 ) then + if ( iovr == 0 ) then cl2(i) = cl2(i) + ccur - cl2(i)*ccur else cl2(i) = max( cl2(i), ccur ) @@ -3889,7 +3830,7 @@ subroutine gethml & if (kth2(i) == 0) kbt2(i) = k kth2(i) = kth2(i) + 1 - if ( iovrw == 0 ) then + if ( iovr == 0 ) then cl2(i) = cl2(i) + ccur - cl2(i)*ccur else cl2(i) = max( cl2(i), ccur ) diff --git a/physics/radlw_main.F90 b/physics/radlw_main.F90 index 0596a987c..4ee7ca22b 100644 --- a/physics/radlw_main.F90 +++ b/physics/radlw_main.F90 @@ -243,14 +243,15 @@ module rrtmg_lw ! use physparam, only : ilwrate, ilwrgas, ilwcliq, ilwcice, & - & icldflg, ivflip + & isubclw, icldflg, iovrlw, ivflip, & + & kind_phys use physcons, only : con_g, con_cp, con_avgd, con_amd, & & con_amw, con_amo3 use mersenne_twister, only : random_setseed, random_number, & & random_stat !mz use machine, only : kind_phys, & - & im => kind_io4, rb => kind_phys + & im => kind_io4, rb => kind_phys use module_radlw_parameters ! @@ -391,13 +392,13 @@ subroutine rrtmg_lw_run & & gasvmr_ch4, gasvmr_o2, gasvmr_co, gasvmr_cfc11, & & gasvmr_cfc12, gasvmr_cfc22, gasvmr_ccl4, & & icseed,aeraod,aerssa,sfemis,sfgtmp, & - & dzlyr,delpin,de_lgth, iovrlw, isubclw, & + & dzlyr,delpin,de_lgth, & & npts, nlay, nlp1, lprnt, cld_cf, lslwr, & & hlwc,topflx,sfcflx,cldtau, & ! --- outputs & HLW0,HLWB,FLXPRF, & ! --- optional & cld_lwp, cld_ref_liq, cld_iwp, cld_ref_ice, & & cld_rwp,cld_ref_rain, cld_swp, cld_ref_snow, & - & cld_od, mpirank,mpiroot,errmsg, errflg & + & cld_od, errmsg, errflg & & ) ! ==================== defination of variables ==================== ! @@ -494,7 +495,7 @@ subroutine rrtmg_lw_run & ! =1: maximum/random overlapping clouds ! ! =2: maximum overlap cloud (used for isubclw>0 only) ! ! =3: decorrelation-length overlap (for isubclw>0 only) ! -! =4: exponential overlap cloud +! =4: exponential overlapping cloud ! ! ivflip - control flag for vertical index direction ! ! =0: vertical index from toa to surface ! ! =1: vertical index from surface to toa ! @@ -574,9 +575,6 @@ subroutine rrtmg_lw_run & integer, intent(in) :: icseed(npts) logical, intent(in) :: lprnt - integer, intent(in) :: mpiroot - integer, intent(in) :: mpirank - integer, intent(in) :: iovrlw,isubclw real (kind=kind_phys), dimension(npts,nlp1), intent(in) :: plvl, & & tlvl @@ -648,7 +646,7 @@ subroutine rrtmg_lw_run & ! mz* - Add height of each layer for exponential-random cloud overlap ! This will be derived below from the dzlyr in each layer real (kind=kind_phys), dimension( npts,nlay ) :: hgt - real (kind=kind_phys):: dzsum + real (kind=kind_phys) :: dzsum real (kind=kind_phys), dimension(0:nlp1) :: cldfrc @@ -678,8 +676,8 @@ subroutine rrtmg_lw_run & !mz rtrnmc_mcica real (kind=kind_phys), dimension(nlay,ngptlw) :: taut !mz* Atmosphere/clouds - cldprop - real(kind=kind_phys), dimension(ngptlw,nlay) :: cldfmc, & - & cldfmc_save ! cloud fraction [mcica] + real(kind=kind_phys), dimension(ngptlw,nlay) :: cldfmc, & + & cldfmc_save ! cloud fraction [mcica] ! Dimensions: (ngptlw,nlay) real(kind=kind_phys), dimension(ngptlw,nlay) :: ciwpmc ! in-cloud ice water path [mcica] ! Dimensions: (ngptlw,nlay) @@ -734,10 +732,9 @@ subroutine rrtmg_lw_run & !mz* ! For passing in cloud physical properties; cloud optics parameterized ! in RRTMG: - inflglw = 2 - iceflglw = 3 - liqflglw = 1 - + inflglw = 2 + iceflglw = 3 + liqflglw = 1 istart = 1 iend = 16 iout = 0 @@ -814,7 +811,7 @@ subroutine rrtmg_lw_run & stemp = sfgtmp(iplon) ! surface ground temp if (iovrlw == 3) delgth= de_lgth(iplon) ! clouds decorr-length -! mz*: HWRF practice +! mz*: HWRF if (iovrlw == 4 ) then !Add layer height needed for exponential (icld=4) and @@ -839,25 +836,6 @@ subroutine rrtmg_lw_run & enddo enddo - -! if(mpirank==mpiroot) then -! write(0,*) 'mcica_subcol_lw: max/min(cld_cf)=', & -! & maxval(cld_cf),minval(cld_cf) -! write(0,*) 'mcica_subcol_lw: max/min(cld_iwp)=', & -! & maxval(cld_iwp),minval(cld_iwp) -! write(0,*) 'mcica_subcol_lw: max/min(cld_lwp)=', & -! & maxval(cld_lwp),minval(cld_lwp) -! write(0,*) 'mcica_subcol_lw: max/min(cld_swp)=', & -! & maxval(cld_swp),minval(cld_swp) -! write(0,*) 'mcica_subcol_lw: max/min(cld_ref_ice)=', & -! & maxval(cld_ref_ice),minval(cld_ref_ice) -! write(0,*) 'mcica_subcol_lw: max/min(cld_ref_snow)=', & -! & maxval(cld_ref_snow),minval(cld_ref_snow) -! write(0,*) 'mcica_subcol_lw: max/min(cld_ref_liq)=', & -! & maxval(cld_ref_liq),minval(cld_ref_liq) - -! endif - call mcica_subcol_lw(1, iplon, nlay, iovrlw, permuteseed, & & irng, plyr, hgt, & & cld_cf, cld_iwp, cld_lwp,cld_swp, & @@ -867,26 +845,6 @@ subroutine rrtmg_lw_run & & ciwpmcl, clwpmcl, cswpmcl, reicmcl, relqmcl, & & resnmcl, taucmcl) -!mz -! if(mpirank==mpiroot) then -! write(0,*) 'mcica_subcol_lw: max/min(cldfmcl)=', & -! & maxval(cldfmcl),minval(cldfmcl) -! write(0,*) 'mcica_subcol_lw: max/min(ciwpmcl)=', & -! & maxval(ciwpmcl),minval(ciwpmcl) -! write(0,*) 'mcica_subcol_lw: max/min(clwpmcl)=', & -! & maxval(clwpmcl),minval(clwpmcl) -! write(0,*) 'mcica_subcol_lw: max/min(cswpmcl)=', & -! & maxval(cswpmcl),minval(cswpmcl) -! write(0,*) 'mcica_subcol_lw: max/min(reicmcl)=', & -! & maxval(reicmcl),minval(reicmcl) -! write(0,*) 'mcica_subcol_lw: max/min(relqmcl)=', & -! & maxval(relqmcl),minval(relqmcl) -! write(0,*) 'mcica_subcol_lw: max/min(resnmcl)=', & -! & maxval(resnmcl),minval(resnmcl) -! write(0,*) 'mcica_subcol_lw: max/min(taucmcl)=', & -! & maxval(taucmcl),minval(taucmcl) - -! endif endif !mz* end @@ -977,7 +935,6 @@ subroutine rrtmg_lw_run & !> -# Read cloud optical properties. if (ilwcliq > 0) then ! use prognostic cloud method -!mz: GFS operational do k = 1, nlay k1 = nlp1 - k cldfrc(k)= cld_cf(iplon,k1) @@ -990,8 +947,8 @@ subroutine rrtmg_lw_run & cda3(k) = cld_swp(iplon,k1) cda4(k) = cld_ref_snow(iplon,k1) enddo - ! transfer - if (iovrlw .eq. 4) then !mz HWRF + ! HWRF RRMTG + if (iovrlw == 4) then !mz HWRF do k = 1, nlay k1 = nlp1 - k do ig = 1, ngptlw @@ -1102,8 +1059,6 @@ subroutine rrtmg_lw_run & enddo if (ilwcliq > 0) then ! use prognostic cloud method -!mz* - !mz calculate input for cldprop do k = 1, nlay cldfrc(k)= cld_cf(iplon,k) clwp(k) = cld_lwp(iplon,k) @@ -1115,7 +1070,7 @@ subroutine rrtmg_lw_run & cda3(k) = cld_swp(iplon,k) cda4(k) = cld_ref_snow(iplon,k) enddo - if (iovrlw .eq. 4) then + if (iovrlw == 4) then !mz* Move incoming GCM cloud arrays to RRTMG cloud arrays. !For GCM input, incoming reicmcl is defined based on selected !ice parameterization (inflglw) @@ -1209,7 +1164,7 @@ subroutine rrtmg_lw_run & if ( lcf1 ) then !mz* for HWRF, save cldfmc with mcica - if (iovrlw .eq.4) then + if (iovrlw == 4) then do k = 1, nlay do ig = 1, ngptlw cldfmc_save(ig,k)=cldfmc (ig,k) @@ -1220,12 +1175,12 @@ subroutine rrtmg_lw_run & call cldprop & ! --- inputs: & ( cldfrc,clwp,relw,ciwp,reiw,cda1,cda2,cda3,cda4, & - & nlay, nlp1, ipseed(iplon), dz, delgth,iovrlw, isubclw, & + & nlay, nlp1, ipseed(iplon), dz, delgth, & ! --- outputs: & cldfmc, taucld & & ) - if (iovrlw .eq.4) then + if (iovrlw == 4) then !mz for HWRF, still using mcica cldfmc do k = 1, nlay do ig = 1, ngptlw @@ -1253,30 +1208,13 @@ subroutine rrtmg_lw_run & taucld = f_zero endif -!!mz* HWRF practice, calculate taucmc with mcica - if (iovrlw .eq.4) then - !mz* HWRF practice, calculate taucmc -! if(mpirank==mpiroot) then -! write(0,*) 'bfe cldprmc: nlay,inflglw,iceflglw,liqflglw',& -! & nlay,inflglw,iceflglw,liqflglw -! write(0,*) 'bfe cldprmc: max/min(taucmc)=', & -! & maxval(taucmc),minval(taucmc) -! endif - - call cldprmc(nlay, inflglw, iceflglw, liqflglw, & - & cldfmc, ciwpmc, & - & clwpmc, cswpmc, reicmc, relqmc, resnmc, & - & ncbands, taucmc) - endif -! if(mpirank==mpiroot) then -! write(0,*) 'aft cldprmc: ncbands', ncbands -! write(0,*) 'aft cldprmc: max/min(taucmc)=', & -! & maxval(taucmc),minval(taucmc) -! endif - - -!mz* end - +!mz* HWRF: calculate taucmc with mcica + if (iovrlw == 4) then + call cldprmc(nlay, inflglw, iceflglw, liqflglw, & + & cldfmc, ciwpmc, & + & clwpmc, cswpmc, reicmc, relqmc, resnmc, & + & ncbands, taucmc) + endif ! if (lprnt) then ! print *,' after cldprop' @@ -1382,51 +1320,10 @@ subroutine rrtmg_lw_run & & totuflux,totdflux,htr, totuclfl,totdclfl,htrcl, htrb & & ) - endif ! end if_iovrlw_block - - else - -! if(iovrlw == 4) then + endif ! end if_iovrlw_block -!mz*HWRF practice -! -! pz(0)=plyr(iplon,1) -! do k= 1,nlay -! pz(k)=plvl(iplon,k+1) -! enddo - -! do k = 0, nlay -! do j = 1, nbands -! ! taut (k,j) = tautot(j,k) -! planklay(k,j) = pklay(j,k) -! planklev(k,j) = pklev(j,k) -! enddo -! enddo + else -! do k = 1, nlay -! do ig = 1, ngptlw -! fracs_r(k,ig) = fracs (ig,k) -! taut(k,ig)= tautot(ig,k) -! enddo -! enddo - -! call rtrnmc_mcica(nlay, istart, iend, iout, pz, & -! & semiss, ncbands, & -! & cldfmc, taucmc, planklay, planklev, & !plankbnd, & -! & pwvcm, fracs_r, taut, & -! & totuflux, totdflux, htr, & -! & totuclfl, totdclfl, htrcl ) - -! if(mpirank==mpiroot) then -! write(0,*) 'rtrnmc_mcica: max/min(htr)=', & -! & maxval(htr),minval(htr) -! endif - - -! else -!mz*end - -!mz*taucld(non-mcica) call rtrnmc & ! --- inputs: & ( semiss,delp,cldfmc,taucld,tautot,pklay,pklev, & @@ -1434,12 +1331,6 @@ subroutine rrtmg_lw_run & ! --- outputs: & totuflux,totdflux,htr, totuclfl,totdclfl,htrcl, htrb & & ) -! if(mpirank==mpiroot) then -! write(0,*) 'rtrnmc: max/min(htr)=', & -! & maxval(htr),minval(htr) -! endif - -! endif !end if_iovrlw block endif ! end if_isubclw_block @@ -1546,7 +1437,7 @@ end subroutine rrtmg_lw_finalize !!\section rlwinit_gen rlwinit General Algorithm !! @{ subroutine rlwinit & - & (iovrlw,isubclw, me ) ! --- inputs + & ( me ) ! --- inputs ! --- outputs: (none) ! =================== program usage description =================== ! @@ -1615,8 +1506,7 @@ subroutine rlwinit & ! ====================== end of description block ================= ! ! --- inputs: - integer, intent(in) :: me,isubclw - integer, intent(inout) :: iovrlw + integer, intent(in) :: me ! --- outputs: none @@ -1634,9 +1524,7 @@ subroutine rlwinit & print *,' *** Error in specification of cloud overlap flag', & & ' IOVRLW=',iovrlw,' in RLWINIT !!' stop -!mz -! elseif ( iovrlw>=2 .and. isubclw==0 ) then - elseif ( (iovrlw.eq.2 .or. iovrlw.eq.3).and. isubclw==0 ) then + elseif ( (iovrlw==2 .or. iovrlw==3) .and. isubclw==0 ) then if (me == 0) then print *,' *** IOVRLW=',iovrlw,' is not available for', & & ' ISUBCLW=0 setting!!' @@ -1780,7 +1668,7 @@ end subroutine rlwinit !> @{ subroutine cldprop & & ( cfrac,cliqp,reliq,cicep,reice,cdat1,cdat2,cdat3,cdat4, & ! --- inputs - & nlay, nlp1, ipseed, dz, de_lgth,iovrlw,isubclw, & + & nlay, nlp1, ipseed, dz, de_lgth, & & cldfmc, taucld & ! --- outputs & ) @@ -1880,7 +1768,7 @@ subroutine cldprop & use module_radlw_cldprlw ! --- inputs: - integer, intent(in) :: nlay, nlp1, ipseed,iovrlw,isubclw + integer, intent(in) :: nlay, nlp1, ipseed real (kind=kind_phys), dimension(0:nlp1), intent(in) :: cfrac real (kind=kind_phys), dimension(nlay), intent(in) :: cliqp, & @@ -2044,7 +1932,7 @@ subroutine cldprop & endif lab_if_ilwcliq -!> -# if isubclw > 0, call mcica_subcol() to distribute +!> -# if physparam::isubclw > 0, call mcica_subcol() to distribute !! cloud properties to each g-point. if ( isubclw > 0 ) then ! mcica sub-col clouds approx @@ -2060,7 +1948,7 @@ subroutine cldprop & call mcica_subcol & ! --- inputs: - & ( cldf, nlay, ipseed, dz, de_lgth, iovrlw, & + & ( cldf, nlay, ipseed, dz, de_lgth, & ! --- output: & lcloudy & & ) @@ -2094,7 +1982,7 @@ end subroutine cldprop !!\section mcica_subcol_gen mcica_subcol General Algorithm !! @{ subroutine mcica_subcol & - & ( cldf, nlay, ipseed, dz, de_lgth, iovrlw, & ! --- inputs + & ( cldf, nlay, ipseed, dz, de_lgth, & ! --- inputs & lcloudy & ! --- outputs & ) @@ -2122,7 +2010,7 @@ subroutine mcica_subcol & implicit none ! --- inputs: - integer, intent(in) :: nlay, ipseed, iovrlw + integer, intent(in) :: nlay, ipseed real (kind=kind_phys), dimension(nlay), intent(in) :: cldf, dz real (kind=kind_phys), intent(in) :: de_lgth @@ -2473,11 +2361,6 @@ subroutine setcoef & ! --- ... begin spectral band loop do i = 1, nbands -!mz* -! plankbnd(iband) = semiss(iband) * & -! (totplnk(indbound,iband) + tbndfrac * dbdtlev) -!mz - pklay(i,k) = delwave(i) * (totplnk(indlay,i) + tlyrfr & & * (totplnk(indlay+1,i) - totplnk(indlay,i)) ) pklev(i,k) = delwave(i) * (totplnk(indlev,i) + tlvlfr & diff --git a/physics/radlw_main.meta b/physics/radlw_main.meta index 6fc58d635..da7496f87 100644 --- a/physics/radlw_main.meta +++ b/physics/radlw_main.meta @@ -207,22 +207,6 @@ kind = kind_phys intent = in optional = F -[iovrlw] - standard_name = flag_for_cloud_overlapping_method_for_longwave_radiation - long_name = control flag for cloud overlapping method for LW - units = flag - dimensions = () - type = integer - intent = in - optional = F -[isubclw] - standard_name = flag_for_lw_clouds_sub_grid_approximation - long_name = flag for lw clouds sub-grid approximation - units = flag - dimensions = () - type = integer - intent = in - optional = F [npts] standard_name = horizontal_loop_extent long_name = horizontal dimension @@ -387,22 +371,6 @@ kind = kind_phys intent = in optional = T -[mpirank] - standard_name = mpi_rank - long_name = current MPI-rank - units = index - dimensions = () - type = integer - intent = in - optional = F -[mpiroot] - standard_name = mpi_root - long_name = master MPI-rank - units = index - dimensions = () - type = integer - intent = in - optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/radsw_main.F90 b/physics/radsw_main.F90 index cd7705d3f..51512835c 100644 --- a/physics/radsw_main.F90 +++ b/physics/radsw_main.F90 @@ -268,8 +268,8 @@ !! code from aer inc. module rrtmg_sw ! - use physparam, only : iswrate, iswrgas, iswcice, & !mz: iswcliq - & icldflg, ivflip, & + use physparam, only : iswrate, iswrgas, iswcliq, iswcice, & + & isubcsw, icldflg, iovrsw, ivflip, & & iswmode use physcons, only : con_g, con_cp, con_avgd, con_amd, & & con_amw, con_amo3 @@ -369,7 +369,7 @@ module rrtmg_sw ! --- public accessable subprograms public rrtmg_sw_init, rrtmg_sw_run, rrtmg_sw_finalize, rswinit, & - & kissvec, generate_stochastic_clouds_sw,mcica_subcol_sw + & kissvec, generate_stochastic_clouds_sw, mcica_subcol_sw ! ================= @@ -470,7 +470,7 @@ subroutine rrtmg_sw_run & & icseed, aeraod, aerssa, aerasy, & & sfcalb_nir_dir, sfcalb_nir_dif, & & sfcalb_uvis_dir, sfcalb_uvis_dif, & - & dzlyr,delpin,de_lgth, iswcliq, iovrsw, isubcsw, & + & dzlyr,delpin,de_lgth, & & cosz,solcon,NDAY,idxday, & & npts, nlay, nlp1, lprnt, & & cld_cf, lsswr, & @@ -478,7 +478,8 @@ subroutine rrtmg_sw_run & & HSW0,HSWB,FLXPRF,FDNCMP, & ! --- optional & cld_lwp, cld_ref_liq, cld_iwp, cld_ref_ice, & & cld_rwp,cld_ref_rain, cld_swp, cld_ref_snow, & - & cld_od, cld_ssa, cld_asy,mpirank,mpiroot, errmsg, errflg ) + & cld_od, cld_ssa, cld_asy, errmsg, errflg & + & ) ! ==================== defination of variables ==================== ! ! ! @@ -597,7 +598,7 @@ subroutine rrtmg_sw_run & ! =1: maximum/random overlapping clouds ! ! =2: maximum overlap cloud ! ! =3: decorrelation-length overlap clouds ! -! =4: exponential overlapping clouds +! =4: exponential overlapping clouds ! ! ivflip - control flg for direction of vertical index ! ! =0: index from toa to surface ! ! =1: index from surface to toa ! @@ -657,7 +658,6 @@ subroutine rrtmg_sw_run & ! --- inputs: integer, intent(in) :: npts, nlay, nlp1, NDAY - integer, intent(in) :: iswcliq,iovrsw,isubcsw integer, dimension(:), intent(in) :: idxday, icseed @@ -696,7 +696,6 @@ subroutine rrtmg_sw_run & real (kind=kind_phys), intent(in) :: cosz(npts), solcon, & & de_lgth(npts) - integer, intent(in) :: mpirank,mpiroot ! --- outputs: real (kind=kind_phys), dimension(npts,nlay), intent(inout) :: hswc real (kind=kind_phys), dimension(npts,nlay), intent(inout) :: & @@ -822,7 +821,7 @@ subroutine rrtmg_sw_run & integer, dimension(npts) :: ipseed integer, dimension(nlay) :: indfor, indself, jp, jt, jt1 - integer :: i, ib, ipt, j1, k, kk, laytrop, mb,ig + integer :: i, ib, ipt, j1, k, kk, laytrop, mb, ig integer :: inflgsw, iceflgsw, liqflgsw integer :: irng, permuteseed ! @@ -834,13 +833,13 @@ subroutine rrtmg_sw_run & ! Select cloud liquid and ice optics parameterization options ! For passing in cloud optical properties directly: -! inflgsw = 0 -! iceflgsw = 0 -! liqflgsw = 0 +! inflgsw = 0 +! iceflgsw = 0 +! liqflgsw = 0 ! For passing in cloud physical properties; cloud optics parameterized in RRTMG: - inflgsw = 2 - iceflgsw = 3 - liqflgsw = 1 + inflgsw = 2 + iceflgsw = 3 + liqflgsw = 1 ! if (.not. lsswr) return if (nday <= 0) return @@ -942,7 +941,7 @@ subroutine rrtmg_sw_run & albdf(2) = sfcalb_uvis_dif(j1) -! mz*: HWRF practice +! mz*: HWRF if (iovrsw == 4 ) then @@ -973,25 +972,6 @@ subroutine rrtmg_sw_run & enddo enddo -!mz -! if(mpirank==mpiroot) then -! write(0,*) 'mcica_subcol_sw: max/min(cld_cf)=', & -! & maxval(cld_cf),minval(cld_cf) -! write(0,*) 'mcica_subcol_sw: max/min(cld_iwp)=', & -! & maxval(cld_iwp),minval(cld_iwp) -! write(0,*) 'mcica_subcol_sw: max/min(cld_lwp)=', & -! & maxval(cld_lwp),minval(cld_lwp) -! write(0,*) 'mcica_subcol_sw: max/min(cld_swp)=', & -! & maxval(cld_swp),minval(cld_swp) -! write(0,*) 'mcica_subcol_sw: max/min(cld_ref_ice)=', & -! & maxval(cld_ref_ice),minval(cld_ref_ice) -! write(0,*) 'mcica_subcol_sw: max/min(cld_ref_snow)=', & -! & maxval(cld_ref_snow),minval(cld_ref_snow) -! write(0,*) 'mcica_subcol_sw: max/min(cld_ref_liq)=', & -! & maxval(cld_ref_liq),minval(cld_ref_liq) -! endif - - call mcica_subcol_sw (1, j1, nlay, iovrsw, permuteseed, & & irng, plyr, hgt, & & cld_cf, cld_iwp, cld_lwp,cld_swp, & @@ -999,25 +979,7 @@ subroutine rrtmg_sw_run & & cld_ref_snow, taucld3,ssacld3,asmcld3,fsfcld3, & & cldfmcl, ciwpmcl, clwpmcl, cswpmcl, & !--output & reicmcl, relqmcl, resnmcl, & - & taucmcl, ssacmcl, asmcmcl, fsfcmcl) - -!mz -! if(mpirank==mpiroot) then -! write(0,*) 'mcica_subcol_sw: max/min(cldfmcl)=', & -! & maxval(cldfmcl),minval(cldfmcl) -! write(0,*) 'mcica_subcol_sw: max/min(ciwpmcl)=', & -! & maxval(ciwpmcl),minval(ciwpmcl) -! write(0,*) 'mcica_subcol_sw: max/min(clwpmcl)=', & -! & maxval(clwpmcl),minval(clwpmcl) -! write(0,*) 'mcica_subcol_sw: max/min(cswpmcl)=', & -! & maxval(cswpmcl),minval(cswpmcl) -! write(0,*) 'mcica_subcol_sw: max/min(reicmcl)=', & -! & maxval(reicmcl),minval(reicmcl) -! write(0,*) 'mcica_subcol_sw: max/min(relqmcl)=', & -! & maxval(relqmcl),minval(relqmcl) -! write(0,*) 'mcica_subcol_sw: max/min(resnmcl)=', & -! & maxval(resnmcl),minval(resnmcl) -! endif + & taucmcl, ssacmcl, asmcmcl, fsfcmcl) endif !mz* end @@ -1093,8 +1055,6 @@ subroutine rrtmg_sw_run & !> -# Read cloud optical properties from 'clouds'. if (iswcliq > 0) then ! use prognostic cloud method -!mz:GFS operational - !if (iovrsw .eq. 1) then do k = 1, nlay kk = nlp1 - k cfrac(k) = cld_cf(j1,kk) ! cloud fraction @@ -1107,7 +1067,7 @@ subroutine rrtmg_sw_run & cdat3(k) = cld_swp(j1,kk) ! cloud snow path cdat4(k) = cld_ref_snow(j1,kk) ! snow partical effctive radius enddo - if (iovrsw .eq. 4) then !mz* HWRF + if (iovrsw == 4) then !mz* HWRF do k = 1, nlay kk = nlp1 - k do ig = 1, ngptsw @@ -1128,7 +1088,7 @@ subroutine rrtmg_sw_run & resnmc(k) = resnmcl(j1,kk) endif enddo - endif + endif else ! use diagnostic cloud method do k = 1, nlay kk = nlp1 - k @@ -1210,7 +1170,6 @@ subroutine rrtmg_sw_run & enddo if (iswcliq > 0) then ! use prognostic cloud method - !if (iovrsw .eq. 1) then !mz* GFS operational do k = 1, nlay cfrac(k) = cld_cf(j1,k) ! cloud fraction cliqp(k) = cld_lwp(j1,k) ! cloud liq path @@ -1222,7 +1181,7 @@ subroutine rrtmg_sw_run & cdat3(k) = cld_swp(j1,k) ! cloud snow path cdat4(k) = cld_ref_snow(j1,k) ! snow partical effctive radius enddo - if (iovrsw .eq. 4) then !mz* HWRF + if (iovrsw == 4) then !mz* HWRF !mz* Move incoming GCM cloud arrays to RRTMG cloud arrays. !For GCM input, incoming reicmcl is defined based on selected !ice parameterization (inflglw) @@ -1269,8 +1228,7 @@ subroutine rrtmg_sw_run & do k = 1, nlay zcf0 = zcf0 * (f_one - cfrac(k)) enddo -!mz else if (iovrsw == 1) then ! max/ran overlapping - else if (iovrsw == 1.or. iovrsw == 4) then ! mz* also exponential overlapping + else if (iovrsw == 1 .or. iovrsw == 4) then ! max/ra/exp overlapping do k = 1, nlay if (cfrac(k) > ftiny) then ! cloudy layer zcf1 = min ( zcf1, f_one-cfrac(k) ) @@ -1280,7 +1238,7 @@ subroutine rrtmg_sw_run & endif enddo zcf0 = zcf0 * zcf1 - else if (iovrsw >= 2 .and. iovrsw .ne. 4) then + else if (iovrsw >= 2 .and. iovrsw /= 4) then do k = 1, nlay zcf0 = min ( zcf0, f_one-cfrac(k) ) ! used only as clear/cloudy indicator enddo @@ -1292,13 +1250,11 @@ subroutine rrtmg_sw_run & !> -# For cloudy sky column, call cldprop() to compute the cloud !! optical properties for each cloudy layer. - - !if (iovrsw .eq. 1 ) then if (zcf1 > f_zero) then ! cloudy sky column !mz* for HWRF, save cldfmc with mcica - if (iovrsw .eq.4) then + if (iovrsw == 4) then do k = 1, nlay do ig = 1, ngptsw cldfmc_save(k,ig)=cldfmc (k,ig) @@ -1306,16 +1262,15 @@ subroutine rrtmg_sw_run & enddo endif - call cldprop & ! --- inputs: & ( cfrac,cliqp,reliq,cicep,reice,cdat1,cdat2,cdat3,cdat4, & - & zcf1, nlay, ipseed(j1), dz, delgth,iswcliq,iovrsw,isubcsw, & + & zcf1, nlay, ipseed(j1), dz, delgth, & ! --- outputs: - & taucw, ssacw, asycw, cldfrc, cldfmc & !mz: cldfmc(k,ig) + & taucw, ssacw, asycw, cldfrc, cldfmc & & ) - if (iovrsw .eq.4) then + if (iovrsw == 4) then !mz for HWRF, still using mcica cldfmc do k = 1, nlay do ig = 1, ngptsw @@ -1350,20 +1305,6 @@ subroutine rrtmg_sw_run & enddo endif ! end if_zcf1_block -! if (iovrsw .eq. 4) then !mz* HWRF -!! For cloudy atmosphere, use cldprop to set cloud optical properties based on -!! input cloud physical properties. Select method based on choices described -!! in cldprop. Cloud fraction, water path, liquid droplet and ice particle -!! effective radius must be passed in cldprop. Cloud fraction and cloud -!! optical properties are transferred to rrtmg_sw arrays in cldprop. - -! call cldprmc_sw(nlayers, inflg, iceflg, liqflg, cldfmc, & -! ciwpmc, clwpmc, cswpmc, reicmc, relqmc, resnmc, & -! taormc, taucmc, ssacmc, asmcmc, fsfcmc) -! icpr = 1 - -! endif - !> -# Call setcoef() to compute various coefficients needed in !! radiative transfer calculations. call setcoef & @@ -1374,33 +1315,6 @@ subroutine rrtmg_sw_run & & selffac,selffrac,indself,forfac,forfrac,indfor & & ) -!mz* HWRF clouds -! if(iovrsw .eq.0) then -! zcldfmc(:,:) = 0._rb -! ztaucmc(:,:) = 0._rb -! ztaormc(:,:) = 0._rb -! zasycmc(:,:) = 0._rb -! zomgcmc(:,:) = 1._rb - -! elseif (iovrsw.eq.4) then -! do i=1,nlayers -! do ig=1,ngptsw -! zcldfmc(i,ig) = cldfmc(ig,i) -! ztaucmc(i,ig) = taucmc(ig,i) -! ztaormc(i,ig) = taormc(ig,i) -! zasycmc(i,ig) = asmcmc(ig,i) -! zomgcmc(i,ig) = ssacmc(ig,i) -! enddo -! enddo -!Aerosol -!mz* no aerosol at this moment (iaer .eq.0) -! ztaua(:,:) = 0._rb -! zasya(:,:) = 0._rb -! zomga(:,:) = 1._rb - -! endif -!mz* - !> -# Call taumol() to calculate optical depths for gaseous absorption !! and rayleigh scattering call taumol & @@ -1431,8 +1345,6 @@ subroutine rrtmg_sw_run & & ) else ! use mcica cloud scheme - -!mz if(iovrsw .eq. 1 ) then ! mz*:GFS operational call spcvrtm & ! --- inputs: @@ -1445,19 +1357,6 @@ subroutine rrtmg_sw_run & & sfbmc,sfdfc,sfbm0,sfdf0,suvbfc,suvbf0 & & ) -!mz else if (iovrsw .eq.4 ) then -! call spcvmc_sw & -! (nlayers, istart, iend, icpr, iout, & -! pavel, tavel, pz, tz, tbound, albdif, albdir, & -! zcldfmc, ztaucmc, zasycmc, zomgcmc, ztaormc, & -! ztaua, zasya, zomga, cossza, coldry, wkl, adjflux, & -! laytrop, layswtch, laylow, jp, jt, jt1, & -! co2mult, colch4, colco2, colh2o, colmol, coln2o, colo2, colo3, & -! fac00, fac01, fac10, fac11, & -! selffac, selffrac, indself, forfac, forfrac, indfor, & -! zbbfd, zbbfu, zbbcd, zbbcu, zuvfd, zuvcd, znifd, znicd, & -! zbbfddir, zbbcddir, zuvfddir, zuvcddir, znifddir, znicddir) - endif !> -# Save outputs. @@ -1634,7 +1533,7 @@ end subroutine rrtmg_sw_finalize !! @{ !----------------------------------- subroutine rswinit & - & (iswcliq,iovrsw,isubcsw, me ) ! --- inputs: + & ( me ) ! --- inputs: ! --- outputs: (none) ! =================== program usage description =================== ! @@ -1690,8 +1589,7 @@ subroutine rswinit & ! ====================== end of description block ================= ! ! --- inputs: - integer, intent(in) :: me,isubcsw,iswcliq - integer, intent(inout) :: iovrsw + integer, intent(in) :: me ! --- outputs: none @@ -1838,7 +1736,7 @@ end subroutine rswinit !----------------------------------- subroutine cldprop & & ( cfrac,cliqp,reliq,cicep,reice,cdat1,cdat2,cdat3,cdat4, & ! --- inputs - & cf1, nlay, ipseed, dz, delgth,iswcliq,iovrsw, isubcsw, & + & cf1, nlay, ipseed, dz, delgth, & & taucw, ssacw, asycw, cldfrc, cldfmc & ! --- output & ) @@ -1853,7 +1751,7 @@ subroutine cldprop & ! ! ! inputs: size ! ! cfrac - real, layer cloud fraction nlay ! -! ..... for iswcliq > 0 (prognostic cloud sckeme) - - - ! +! ..... for iswcliq > 0 (prognostic cloud scheme) - - - ! ! cliqp - real, layer in-cloud liq water path (g/m**2) nlay ! ! reliq - real, mean eff radius for liq cloud (micron) nlay ! ! cicep - real, layer in-cloud ice water path (g/m**2) nlay ! @@ -1862,7 +1760,7 @@ subroutine cldprop & ! cdat2 - real, effective radius for rain drop (micron) nlay ! ! cdat3 - real, layer snow flake water path(g/m**2) nlay ! ! cdat4 - real, mean eff radius for snow flake(micron) nlay ! -! ..... for iswcliq = 0 (diagnostic cloud sckeme) - - - ! +! ..... for iswcliq = 0 (diagnostic cloud scheme) - - - ! ! cdat1 - real, layer cloud optical depth nlay ! ! cdat2 - real, layer cloud single scattering albedo nlay ! ! cdat3 - real, layer cloud asymmetry factor nlay ! @@ -1924,7 +1822,7 @@ subroutine cldprop & use module_radsw_cldprtb ! --- inputs: - integer, intent(in) :: nlay, ipseed,iswcliq,iovrsw,isubcsw + integer, intent(in) :: nlay, ipseed real (kind=kind_phys), intent(in) :: cf1, delgth real (kind=kind_phys), dimension(nlay), intent(in) :: cliqp, & @@ -2170,8 +2068,7 @@ subroutine cldprop & !> -# if physparam::isubcsw > 0, call mcica_subcol() to distribute !! cloud properties to each g-point. -!mz if ( isubcsw > 0 ) then ! mcica sub-col clouds approx - if ( isubcsw > 0 .and. iovrsw .ne. 4 ) then ! mcica sub-col clouds approx + if ( isubcsw > 0 .and. iovrsw /= 4 ) then ! mcica sub-col clouds approx cldf(:) = cfrac(:) where (cldf(:) < ftiny) @@ -2182,7 +2079,7 @@ subroutine cldprop & call mcica_subcol & ! --- inputs: - & ( cldf, nlay, ipseed, dz, delgth, iovrsw, & + & ( cldf, nlay, ipseed, dz, delgth, & ! --- outputs: & lcloudy & & ) @@ -2222,7 +2119,7 @@ end subroutine cldprop !> @{ ! ---------------------------------- subroutine mcica_subcol & - & ( cldf, nlay, ipseed, dz, de_lgth,iovrsw, & ! --- inputs + & ( cldf, nlay, ipseed, dz, de_lgth, & ! --- inputs & lcloudy & ! --- outputs & ) @@ -2253,7 +2150,7 @@ subroutine mcica_subcol & implicit none ! --- inputs: - integer, intent(in) :: nlay, ipseed, iovrsw + integer, intent(in) :: nlay, ipseed real (kind=kind_phys), dimension(nlay), intent(in) :: cldf, dz real (kind=kind_phys), intent(in) :: de_lgth @@ -2268,7 +2165,7 @@ subroutine mcica_subcol & type (random_stat) :: stat ! for thread safe random generator - integer :: k, n, k1, ig + integer :: k, n, k1 ! !===> ... begin here ! diff --git a/physics/radsw_main.f b/physics/radsw_main.f deleted file mode 100644 index 30bc58bba..000000000 --- a/physics/radsw_main.f +++ /dev/null @@ -1,5472 +0,0 @@ -!> \file radsw_main.f -!! This file contains NCEP's modifications of the rrtmg-sw radiation -!! code from AER. - -! ============================================================== !!!!! -! sw-rrtm3 radiation package description !!!!! -! ============================================================== !!!!! -! ! -! this package includes ncep's modifications of the rrtm-sw radiation ! -! code from aer inc. ! -! ! -! the sw-rrtm3 package includes these parts: ! -! ! -! 'radsw_rrtm3_param.f' ! -! 'radsw_rrtm3_datatb.f' ! -! 'radsw_rrtm3_main.f' ! -! ! -! the 'radsw_rrtm3_param.f' contains: ! -! ! -! 'module_radsw_parameters' -- band parameters set up ! -! ! -! the 'radsw_rrtm3_datatb.f' contains: ! -! ! -! 'module_radsw_ref' -- reference temperature and pressure ! -! 'module_radsw_cldprtb' -- cloud property coefficients table ! -! 'module_radsw_sflux' -- spectral distribution of solar flux ! -! 'module_radsw_kgbnn' -- absorption coeffients for 14 ! -! bands, where nn = 16-29 ! -! ! -! the 'radsw_rrtm3_main.f' contains: ! -! ! -! 'rrtmg_sw' -- main sw radiation transfer ! -! ! -! in the main module 'rrtmg_sw' there are only two ! -! externally callable subroutines: ! -! ! -! 'swrad' -- main sw radiation routine ! -! inputs: ! -! (plyr,plvl,tlyr,tlvl,qlyr,olyr,gasvmr, ! -! clouds,icseed,aerosols,sfcalb, ! -! dzlyr,delpin,de_lgth, ! -! cosz,solcon,NDAY,idxday, ! -! npts, nlay, nlp1, lprnt, ! -! outputs: ! -! hswc,topflx,sfcflx,cldtau, ! -!! optional outputs: ! -! HSW0,HSWB,FLXPRF,FDNCMP) ! -! ) ! -! ! -! 'rswinit' -- initialization routine ! -! inputs: ! -! ( me ) ! -! outputs: ! -! (none) ! -! ! -! all the sw radiation subprograms become contained subprograms ! -! in module 'rrtmg_sw' and many of them are not directly ! -! accessable from places outside the module. ! -! ! -! derived data type constructs used: ! -! ! -! 1. radiation flux at toa: (from module 'module_radsw_parameters') ! -! topfsw_type - derived data type for toa rad fluxes ! -! upfxc total sky upward flux at toa ! -! dnfxc total sky downward flux at toa ! -! upfx0 clear sky upward flux at toa ! -! ! -! 2. radiation flux at sfc: (from module 'module_radsw_parameters') ! -! sfcfsw_type - derived data type for sfc rad fluxes ! -! upfxc total sky upward flux at sfc ! -! dnfxc total sky downward flux at sfc ! -! upfx0 clear sky upward flux at sfc ! -! dnfx0 clear sky downward flux at sfc ! -! ! -! 3. radiation flux profiles(from module 'module_radsw_parameters') ! -! profsw_type - derived data type for rad vertical prof ! -! upfxc level upward flux for total sky ! -! dnfxc level downward flux for total sky ! -! upfx0 level upward flux for clear sky ! -! dnfx0 level downward flux for clear sky ! -! ! -! 4. surface component fluxes(from module 'module_radsw_parameters' ! -! cmpfsw_type - derived data type for component sfc flux ! -! uvbfc total sky downward uv-b flux at sfc ! -! uvbf0 clear sky downward uv-b flux at sfc ! -! nirbm surface downward nir direct beam flux ! -! nirdf surface downward nir diffused flux ! -! visbm surface downward uv+vis direct beam flx ! -! visdf surface downward uv+vis diffused flux ! -! ! -! external modules referenced: ! -! ! -! 'module physparam' ! -! 'module physcons' ! -! 'mersenne_twister' ! -! ! -! compilation sequence is: ! -! ! -! 'radsw_rrtm3_param.f' ! -! 'radsw_rrtm3_datatb.f' ! -! 'radsw_rrtm3_main.f' ! -! ! -! and all should be put in front of routines that use sw modules ! -! ! -!==========================================================================! -! ! -! the original program declarations: ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). ! -! This software may be used, copied, or redistributed as long as it is ! -! not sold and this copyright notice is reproduced on each copy made. ! -! This model is provided as is without any express or implied warranties. ! -! (http://www.rtweb.aer.com/) ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! ************************************************************************ ! -! ! -! rrtmg_sw ! -! ! -! ! -! a rapid radiative transfer model ! -! for the solar spectral region ! -! atmospheric and environmental research, inc. ! -! 131 hartwell avenue ! -! lexington, ma 02421 ! -! ! -! eli j. mlawer ! -! jennifer s. delamere ! -! michael j. iacono ! -! shepard a. clough ! -! ! -! ! -! email: miacono@aer.com ! -! email: emlawer@aer.com ! -! email: jdelamer@aer.com ! -! ! -! the authors wish to acknowledge the contributions of the ! -! following people: steven j. taubman, patrick d. brown, ! -! ronald e. farren, luke chen, robert bergstrom. ! -! ! -! ************************************************************************ ! -! ! -! references: ! -! (rrtm_sw/rrtmg_sw): ! -! clough, s.a., m.w. shephard, e.j. mlawer, j.s. delamere, ! -! m.j. iacono, k. cady-pereira, s. boukabara, and p.d. brown: ! -! atmospheric radiative transfer modeling: a summary of the aer ! -! codes, j. quant. spectrosc. radiat. transfer, 91, 233-244, 2005. ! -! ! -! (mcica): ! -! pincus, r., h. w. barker, and j.-j. morcrette: a fast, flexible, ! -! approximation technique for computing radiative transfer in ! -! inhomogeneous cloud fields, j. geophys. res., 108(d13), 4376, ! -! doi:10.1029/2002jd003322, 2003. ! -! ! -! ************************************************************************ ! -! ! -! aer's revision history: ! -! this version of rrtmg_sw has been modified from rrtm_sw to use a ! -! reduced set of g-point intervals and a two-stream model for ! -! application to gcms. ! -! ! -! -- original version (derived from rrtm_sw) ! -! 2002: aer. inc. ! -! -- conversion to f90 formatting; addition of 2-stream radiative transfer! -! feb 2003: j.-j. morcrette, ecmwf ! -! -- additional modifications for gcm application ! -! aug 2003: m. j. iacono, aer inc. ! -! -- total number of g-points reduced from 224 to 112. original ! -! set of 224 can be restored by exchanging code in module parrrsw.f90 ! -! and in file rrtmg_sw_init.f90. ! -! apr 2004: m. j. iacono, aer, inc. ! -! -- modifications to include output for direct and diffuse ! -! downward fluxes. there are output as "true" fluxes without ! -! any delta scaling applied. code can be commented to exclude ! -! this calculation in source file rrtmg_sw_spcvrt.f90. ! -! jan 2005: e. j. mlawer, m. j. iacono, aer, inc. ! -! -- revised to add mcica capability. ! -! nov 2005: m. j. iacono, aer, inc. ! -! -- reformatted for consistency with rrtmg_lw. ! -! feb 2007: m. j. iacono, aer, inc. ! -! -- modifications to formatting to use assumed-shape arrays. ! -! aug 2007: m. j. iacono, aer, inc. ! -! ! -! ************************************************************************ ! -! ! -! ncep modifications history log: ! -! ! -! sep 2003, yu-tai hou -- received aer's rrtm-sw gcm version ! -! code (v224) ! -! nov 2003, yu-tai hou -- corrected errors in direct/diffuse ! -! surface alabedo components. ! -! jan 2004, yu-tai hou -- modified code into standard modular! -! f9x code for ncep models. the original three cloud ! -! control flags are simplified into two: iflagliq and ! -! iflagice. combined the org subr sw_224 and setcoef ! -! into radsw (the main program); put all kgb##together ! -! and reformat into a separated data module; combine ! -! reftra and vrtqdr as swflux; optimized taumol and all ! -! taubgs to form a contained subroutines. ! -! jun 2004, yu-tai hou -- modified code based on aer's faster! -! version rrtmg_sw (v2.0) with 112 g-points. ! -! mar 2005, yu-tai hou -- modified to aer v2.3, correct cloud! -! scaling error, total sky properties are delta scaled ! -! after combining clear and cloudy parts. the testing ! -! criterion of ssa is saved before scaling. added cloud ! -! layer rain and snow contributions. all cloud water ! -! partical contents are treated the same way as other ! -! atmos particles. ! -! apr 2005, yu-tai hou -- modified on module structures (this! -! version of code was given back to aer in jun 2006) ! -! nov 2006, yu-tai hou -- modified code to include the ! -! generallized aerosol optical property scheme for gcms.! -! apr 2007, yu-tai hou -- added spectral band heating as an ! -! optional output to support the 500km model's upper ! -! stratospheric radiation calculations. restructure ! -! optional outputs for easy access by different models. ! -! oct 2008, yu-tai hou -- modified to include new features ! -! from aer's newer release v3.5-v3.61, including mcica ! -! sub-grid cloud option and true direct/diffuse fluxes ! -! without delta scaling. added rain/snow opt properties ! -! support to cloudy sky calculations. simplified and ! -! unified sw and lw sub-column cloud subroutines into ! -! one module by using optional parameters. ! -! mar 2009, yu-tai hou -- replaced the original random number! -! generator coming with the original code with ncep w3 ! -! library to simplify the program and moved sub-column ! -! cloud subroutines inside the main module. added ! -! option of user provided permutation seeds that could ! -! be randomly generated from forecast time stamp. ! -! mar 2009, yu-tai hou -- replaced random number generator ! -! programs coming from the original code with the ncep ! -! w3 library to simplify the program and moved sub-col ! -! cloud subroutines inside the main module. added ! -! option of user provided permutation seeds that could ! -! be randomly generated from forecast time stamp. ! -! nov 2009, yu-tai hou -- updated to aer v3.7-v3.8 version. ! -! notice the input cloud ice/liquid are assumed as ! -! in-cloud quantities, not grid average quantities. ! -! aug 2010, yu-tai hou -- uptimized code to improve efficiency -! splited subroutine spcvrt into two subs, spcvrc and ! -! spcvrm, to handling non-mcica and mcica type of calls.! -! apr 2012, b. ferrier and y. hou -- added conversion factor to fu's! -! cloud-snow optical property scheme. ! -! jul 2012, s. moorthi and Y. hou -- eliminated the pointer array ! -! in subr 'spcvrt' for multi-threading issue running ! -! under intel's fortran compiler. ! -! nov 2012, yu-tai hou -- modified control parameters thru ! -! module 'physparam'. ! -! jun 2013, yu-tai hou -- moving band 9 surface treatment ! -! back as in the rrtm2 version, spliting surface flux ! -! into two spectral regions (vis & nir), instead of ! -! designated it in nir region only. ! -! may 2016 yu-tai hou --reverting swflux name back to vrtqdr! -! jun 2018 yu-tai hou --updated cloud optical coeffs with ! -! aer's newer version v3.9-v4.0 for hu and stamnes ! -! scheme. (used if iswcliq=2); added new option of ! -! cloud overlap method 'de-correlation-length'. ! -! ! -!!!!! ============================================================== !!!!! -!!!!! end descriptions !!!!! -!!!!! ============================================================== !!!!! - -!> This module contains the CCPP-compliant NCEP's modifications of the rrtm-sw radiation -!! code from aer inc. - module rrtmg_sw -! - use physparam, only : iswrate, iswrgas, iswcice, & !mz: iswcliq-NML option - & isubcsw, icldflg, iovrsw, ivflip, & - & iswmode, kind_phys - use physcons, only : con_g, con_cp, con_avgd, con_amd, & - & con_amw, con_amo3 - - use module_radsw_parameters - use mersenne_twister, only : random_setseed, random_number, & - & random_stat - use module_radsw_ref, only : preflog, tref - use module_radsw_sflux -! - implicit none -! - private -! -! --- version tag and last revision date - character(40), parameter :: & - & VTAGSW='NCEP SW v5.1 Nov 2012 -RRTMG-SW v3.8 ' -! & VTAGSW='NCEP SW v5.0 Aug 2012 -RRTMG-SW v3.8 ' -! & VTAGSW='RRTMG-SW v3.8 Nov 2009' -! & VTAGSW='RRTMG-SW v3.7 Nov 2009' -! & VTAGSW='RRTMG-SW v3.61 Oct 2008' -! & VTAGSW='RRTMG-SW v3.5 Oct 2008' -! & VTAGSW='RRTM-SW 112v2.3 Apr 2007' -! & VTAGSW='RRTM-SW 112v2.3 Mar 2005' -! & VTAGSW='RRTM-SW 112v2.0 Jul 2004' - -! \name constant values - - real (kind=kind_phys), parameter :: eps = 1.0e-6 - real (kind=kind_phys), parameter :: oneminus= 1.0 - eps -! pade approx constant - real (kind=kind_phys), parameter :: bpade = 1.0/0.278 - real (kind=kind_phys), parameter :: stpfac = 296.0/1013.0 - real (kind=kind_phys), parameter :: ftiny = 1.0e-12 - real (kind=kind_phys), parameter :: flimit = 1.0e-20 -! internal solar constant - real (kind=kind_phys), parameter :: s0 = 1368.22 - - real (kind=kind_phys), parameter :: f_zero = 0.0 - real (kind=kind_phys), parameter :: f_one = 1.0 - -! \name atomic weights for conversion from mass to volume mixing ratios - real (kind=kind_phys), parameter :: amdw = con_amd/con_amw - real (kind=kind_phys), parameter :: amdo3 = con_amd/con_amo3 - -! \name band indices - integer, dimension(nblow:nbhgh) :: nspa, nspb -! band index for sfc flux - integer, dimension(nblow:nbhgh) :: idxsfc -! band index for cld prop - integer, dimension(nblow:nbhgh) :: idxebc - - data nspa(:) / 9, 9, 9, 9, 1, 9, 9, 1, 9, 1, 0, 1, 9, 1 / - data nspb(:) / 1, 5, 1, 1, 1, 5, 1, 0, 1, 0, 0, 1, 5, 1 / - -! data idxsfc(:) / 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 1 / ! band index for sfc flux - data idxsfc(:) / 1, 1, 1, 1, 1, 1, 1, 1, 0, 2, 2, 2, 2, 1 / ! band index for sfc flux - data idxebc(:) / 5, 5, 4, 4, 3, 3, 2, 2, 1, 1, 1, 1, 1, 5 / ! band index for cld prop - -! --- band wavenumber intervals -! real (kind=kind_phys), dimension(nblow:nbhgh):: wavenum1,wavenum2 -! data wavenum1(:) / & -! & 2600.0, 3250.0, 4000.0, 4650.0, 5150.0, 6150.0, 7700.0, & -! & 8050.0,12850.0,16000.0,22650.0,29000.0,38000.0, 820.0 / -! data wavenum2(:) / & -! 3250.0, 4000.0, 4650.0, 5150.0, 6150.0, 7700.0, 8050.0, & -! & 12850.0,16000.0,22650.0,29000.0,38000.0,50000.0, 2600.0 / -! real (kind=kind_phys), dimension(nblow:nbhgh) :: delwave -! data delwave(:) / & -! & 650.0, 750.0, 650.0, 500.0, 1000.0, 1550.0, 350.0, & -! & 4800.0, 3150.0, 6650.0, 6350.0, 9000.0,12000.0, 1780.0 / - -! uv-b band index - integer, parameter :: nuvb = 27 - -!\name logical flags for optional output fields - logical :: lhswb = .false. - logical :: lhsw0 = .false. - logical :: lflxprf= .false. - logical :: lfdncmp= .false. - - -! those data will be set up only once by "rswinit" - real (kind=kind_phys) :: exp_tbl(0:NTBMX) - - -! the factor for heating rates (in k/day, or k/sec set by subroutine -!! 'rswinit') - real (kind=kind_phys) :: heatfac - - -! initial permutation seed used for sub-column cloud scheme - integer, parameter :: ipsdsw0 = 1 - -! --- public accessable subprograms - - public rrtmg_sw_init, rrtmg_sw_run, rrtmg_sw_finalize, rswinit - - -! ================= - contains -! ================= - - subroutine rrtmg_sw_init () - end subroutine rrtmg_sw_init - -!> \defgroup module_radsw_main GFS RRTMG Shortwave Module -!! This module includes NCEP's modifications of the RRTMG-SW radiation -!! code from AER. -!! -!! The SW radiation model in the current NOAA Environmental Modeling -!! System (NEMS) was adapted from the RRTM radiation model developed by -!! AER Inc. (\cite clough_et_al_2005; \cite mlawer_et_al_1997). It contains 14 -!! spectral bands spanning a spectral wavenumber range of -!! \f$50000-820 cm^{-1}\f$ (corresponding to a wavelength range -!! \f$0.2-12.2\mu m\f$), each spectral band focuses on a specific set of -!! atmospheric absorbing species as shown in Table 1. To achieve great -!! computation efficiency while at the same time to maintain a high -!! degree of accuracy, the RRTM radiation model employs a corrected-k -!! distribution method (i.e. mapping the highly spectral changing -!! absorption coefficient, k, into a monotonic and smooth varying -!! cumulative probability function, g). In the RRTM-SW, there are 16 -!! unevenly distributed g points for each of the 14 bands for a total -!! of 224 g points. The GCM version of the code (RRTMG-SW) uses a reduced -!! number (various between 2 to 16) of g points for each of the bands -!! that totals to 112 instead of the full set of 224. To get high -!! quality for the scheme, many advanced techniques are used in RRTM -!! such as carefully selecting the band structure to handle various -!! major (key-species) and minor absorbers; deriving a binary parameter -!! for a paired key molecular species in the same domain; and using two -!! pressure regions (dividing level is at about 96mb) for optimal -!! treatment of various species, etc. -!!\tableofcontents -!! Table 1. RRTMG-SW spectral bands and the corresponding absorbing species -!! |Band #| Wavenumber Range | Lower Atm (Key)| Lower Atm (Minor)| Mid/Up Atm (Key)| Mid/Up Atm (Minor)| -!! |------|------------------|----------------|------------------|-----------------|-------------------| -!! | 16 | 2600-3250 |H2O,CH4 | |CH4 | | -!! | 17 | 3250-4000 |H2O,CO2 | |H2O,CO2 | | -!! | 18 | 4000-4650 |H2O,CH4 | |CH4 | | -!! | 19 | 4650-5150 |H2O,CO2 | |CO2 | | -!! | 20 | 5150-6150 |H2O |CH4 |H2O |CH4 | -!! | 21 | 6150-7700 |H2O,CO2 | |H2O,CO2 | | -!! | 22 | 7700-8050 |H2O,O2 | |O2 | | -!! | 23 | 8050-12850 |H2O | |--- | | -!! | 24 | 12850-16000 |H2O,O2 |O3 |O2 |O3 | -!! | 25 | 16000-22650 |H2O |O3 |--- |O3 | -!! | 26 | 22650-29000 |--- | |--- | | -!! | 27 | 29000-38000 |O3 | |O3 | | -!! | 28 | 38000-50000 |O3,O2 | |O3,O2 | | -!! | 29 | 820-2600 |H2O |CO2 |CO2 |H2O | -!!\tableofcontents -!! -!! The RRTM-SW package includes three files: -!! - radsw_param.f, which contains: -!! - module_radsw_parameters: specifies major parameters of the spectral -!! bands and defines the construct structures of derived-type variables -!! for holding the output results. -!! - radsw_datatb.f, which contains: -!! - module_radsw_ref: reference temperature and pressure -!! - module_radsw_cldprtb: cloud property coefficients table -!! - module_radsw_sflux: indexes and coefficients for spectral -!! distribution of solar flux -!! - module_radsw_kgbnn: absorption coefficents for 14 bands, where -!! nn = 16-29 -!! - radsw_main.f, which contains: -!! - rrtmg_sw_run(): the main SW radiation routine -!! - rswinit(): the initialization routine -!! -!!\author Eli J. Mlawer, emlawer@aer.com -!!\author Jennifer S. Delamere, jdelamer@aer.com -!!\author Michael J. Iacono, miacono@aer.com -!!\author Shepard A. Clough -!!\version NCEP SW v5.1 Nov 2012 -RRTMG-SW v3.8 -!! -!! The authors wish to acknowledge the contributions of the -!! following people: Steven J. Taubman, Karen Cady-Pereira, -!! Patrick D. Brown, Ronald E. Farren, Luke Chen, Robert Bergstrom. -!! -!!\copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). -!! This software may be used, copied, or redistributed as long as it is -!! not sold and this copyright notice is reproduced on each copy made. -!! This model is provided as is without any express or implied warranties. -!! (http://www.rtweb.aer.com/) -!! -!> \section arg_table_rrtmg_sw_run Argument Table -!! \htmlinclude rrtmg_sw_run.html -!! -!> \section gen_swrad RRTMG Shortwave Radiation Scheme General Algorithm -!> @{ -!----------------------------------- - subroutine rrtmg_sw_run & - & ( plyr,plvl,tlyr,tlvl,qlyr,olyr, & - & gasvmr_co2,gasvmr_n2o,gasvmr_ch4,gasvmr_o2,gasvmr_co, & - & gasvmr_cfc11,gasvmr_cfc12,gasvmr_cfc22,gasvmr_ccl4, & ! --- inputs - & icseed, aeraod, aerssa, aerasy, & - & sfcalb_nir_dir, sfcalb_nir_dif, & - & sfcalb_uvis_dir, sfcalb_uvis_dif, & - & dzlyr,delpin,de_lgth, & - & cosz,solcon,NDAY,idxday, & - & npts, nlay, nlp1, lprnt, & - & cld_cf, lsswr, & - & hswc,topflx,sfcflx,cldtau, & ! --- outputs - & HSW0,HSWB,FLXPRF,FDNCMP, & ! --- optional - & cld_lwp, cld_ref_liq, cld_iwp, cld_ref_ice, & - & cld_rwp,cld_ref_rain, cld_swp, cld_ref_snow, & - & cld_od, cld_ssa, cld_asy, errmsg, errflg - & ) - -! ==================== defination of variables ==================== ! -! ! -! input variables: ! -! plyr (npts,nlay) : model layer mean pressure in mb ! -! plvl (npts,nlp1) : model level pressure in mb ! -! tlyr (npts,nlay) : model layer mean temperature in k ! -! tlvl (npts,nlp1) : model level temperature in k (not in use) ! -! qlyr (npts,nlay) : layer specific humidity in gm/gm *see inside ! -! olyr (npts,nlay) : layer ozone concentration in gm/gm ! -! gasvmr(npts,nlay,:): atmospheric constent gases: ! -! (check module_radiation_gases for definition) ! -! gasvmr(:,:,1) - co2 volume mixing ratio ! -! gasvmr(:,:,2) - n2o volume mixing ratio ! -! gasvmr(:,:,3) - ch4 volume mixing ratio ! -! gasvmr(:,:,4) - o2 volume mixing ratio ! -! gasvmr(:,:,5) - co volume mixing ratio (not used) ! -! gasvmr(:,:,6) - cfc11 volume mixing ratio (not used) ! -! gasvmr(:,:,7) - cfc12 volume mixing ratio (not used) ! -! gasvmr(:,:,8) - cfc22 volume mixing ratio (not used) ! -! gasvmr(:,:,9) - ccl4 volume mixing ratio (not used) ! -! clouds(npts,nlay,:): cloud profile ! -! (check module_radiation_clouds for definition) ! -! clouds(:,:,1) - layer total cloud fraction ! -! clouds(:,:,2) - layer in-cloud liq water path (g/m**2) ! -! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! -! clouds(:,:,4) - layer in-cloud ice water path (g/m**2) ! -! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! -! clouds(:,:,6) - layer rain drop water path (g/m**2) ! -! clouds(:,:,7) - mean eff radius for rain drop (micron) ! -! clouds(:,:,8) - layer snow flake water path (g/m**2) ! -! clouds(:,:,9) - mean eff radius for snow flake (micron) ! -! icseed(npts) : auxiliary special cloud related array ! -! when module variable isubcsw=2, it provides ! -! permutation seed for each column profile that ! -! are used for generating random numbers. ! -! when isubcsw /=2, it will not be used. ! -! aerosols(npts,nlay,nbdsw,:) : aerosol optical properties ! -! (check module_radiation_aerosols for definition) ! -! (:,:,:,1) - optical depth ! -! (:,:,:,2) - single scattering albedo ! -! (:,:,:,3) - asymmetry parameter ! -! sfcalb(npts, : ) : surface albedo in fraction ! -! (check module_radiation_surface for definition) ! -! ( :, 1 ) - near ir direct beam albedo ! -! ( :, 2 ) - near ir diffused albedo ! -! ( :, 3 ) - uv+vis direct beam albedo ! -! ( :, 4 ) - uv+vis diffused albedo ! -! dzlyr(npts,nlay) : layer thickness in km ! -! delpin(npts,nlay): layer pressure thickness (mb) ! -! de_lgth(npts) : clouds decorrelation length (km) ! -! cosz (npts) : cosine of solar zenith angle ! -! solcon : solar constant (w/m**2) ! -! NDAY : num of daytime points ! -! idxday(npts) : index array for daytime points ! -! npts : number of horizontal points ! -! nlay,nlp1 : vertical layer/lavel numbers ! -! lprnt : logical check print flag ! -! ! -! output variables: ! -! hswc (npts,nlay): total sky heating rates (k/sec or k/day) ! -! topflx(npts) : radiation fluxes at toa (w/m**2), components: ! -! (check module_radsw_parameters for definition) ! -! upfxc - total sky upward flux at toa ! -! dnflx - total sky downward flux at toa ! -! upfx0 - clear sky upward flux at toa ! -! sfcflx(npts) : radiation fluxes at sfc (w/m**2), components: ! -! (check module_radsw_parameters for definition) ! -! upfxc - total sky upward flux at sfc ! -! dnfxc - total sky downward flux at sfc ! -! upfx0 - clear sky upward flux at sfc ! -! dnfx0 - clear sky downward flux at sfc ! -! cldtau(npts,nlay): spectral band layer cloud optical depth (~0.55 mu) -! ! -!!optional outputs variables: ! -! hswb(npts,nlay,nbdsw): spectral band total sky heating rates ! -! hsw0 (npts,nlay): clear sky heating rates (k/sec or k/day) ! -! flxprf(npts,nlp1): level radiation fluxes (w/m**2), components: ! -! (check module_radsw_parameters for definition) ! -! dnfxc - total sky downward flux at interface ! -! upfxc - total sky upward flux at interface ! -! dnfx0 - clear sky downward flux at interface ! -! upfx0 - clear sky upward flux at interface ! -! fdncmp(npts) : component surface downward fluxes (w/m**2): ! -! (check module_radsw_parameters for definition) ! -! uvbfc - total sky downward uv-b flux at sfc ! -! uvbf0 - clear sky downward uv-b flux at sfc ! -! nirbm - downward surface nir direct beam flux ! -! nirdf - downward surface nir diffused flux ! -! visbm - downward surface uv+vis direct beam flux ! -! visdf - downward surface uv+vis diffused flux ! -! ! -! external module variables: (in physparam) ! -! iswrgas - control flag for rare gases (ch4,n2o,o2, etc.) ! -! =0: do not include rare gases ! -! >0: include all rare gases ! -! iswcliq - control flag for liq-cloud optical properties ! -! =0: input cloud optical depth, fixed ssa, asy ! -! =1: use hu and stamnes(1993) method for liq cld ! -! =2: use updated coeffs for hu and stamnes scheme ! -! iswcice - control flag for ice-cloud optical properties ! -! *** if iswcliq==0, iswcice is ignored ! -! =1: use ebert and curry (1992) scheme for ice clouds ! -! =2: use streamer v3.0 (2001) method for ice clouds ! -! =3: use fu's method (1996) for ice clouds ! -! iswmode - control flag for 2-stream transfer scheme ! -! =1; delta-eddington (joseph et al., 1976) ! -! =2: pifm (zdunkowski et al., 1980) ! -! =3: discrete ordinates (liou, 1973) ! -! isubcsw - sub-column cloud approximation control flag ! -! =0: no sub-col cld treatment, use grid-mean cld quantities ! -! =1: mcica sub-col, prescribed seeds to get random numbers ! -! =2: mcica sub-col, providing array icseed for random numbers! -! iovrsw - cloud overlapping control flag ! -! =0: random overlapping clouds ! -! =1: maximum/random overlapping clouds ! -! =2: maximum overlap cloud ! -! =3: decorrelation-length overlap clouds ! -! ivflip - control flg for direction of vertical index ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! ! -! module parameters, control variables: ! -! nblow,nbhgh - lower and upper limits of spectral bands ! -! maxgas - maximum number of absorbing gaseous ! -! ngptsw - total number of g-point subintervals ! -! ng## - number of g-points in band (##=16-29) ! -! ngb(ngptsw) - band indices for each g-point ! -! bpade - pade approximation constant (1/0.278) ! -! nspa,nspb(nblow:nbhgh) ! -! - number of lower/upper ref atm's per band ! -! ipsdsw0 - permutation seed for mcica sub-col clds ! -! ! -! major local variables: ! -! pavel (nlay) - layer pressures (mb) ! -! delp (nlay) - layer pressure thickness (mb) ! -! tavel (nlay) - layer temperatures (k) ! -! coldry (nlay) - dry air column amount ! -! (1.e-20*molecules/cm**2) ! -! cldfrc (nlay) - layer cloud fraction (norm by tot cld) ! -! cldfmc (nlay,ngptsw) - layer cloud fraction for g-point ! -! taucw (nlay,nbdsw) - cloud optical depth ! -! ssacw (nlay,nbdsw) - cloud single scattering albedo (weighted) ! -! asycw (nlay,nbdsw) - cloud asymmetry factor (weighted) ! -! tauaer (nlay,nbdsw) - aerosol optical depths ! -! ssaaer (nlay,nbdsw) - aerosol single scattering albedo ! -! asyaer (nlay,nbdsw) - aerosol asymmetry factor ! -! colamt (nlay,maxgas) - column amounts of absorbing gases ! -! 1 to maxgas are for h2o, co2, o3, n2o, ! -! ch4, o2, co, respectively (mol/cm**2) ! -! facij (nlay) - indicator of interpolation factors ! -! =0/1: indicate lower/higher temp & height ! -! selffac(nlay) - scale factor for self-continuum, equals ! -! (w.v. density)/(atm density at 296K,1013 mb) ! -! selffrac(nlay) - factor for temp interpolation of ref ! -! self-continuum data ! -! indself(nlay) - index of the lower two appropriate ref ! -! temp for the self-continuum interpolation ! -! forfac (nlay) - scale factor for w.v. foreign-continuum ! -! forfrac(nlay) - factor for temp interpolation of ref ! -! w.v. foreign-continuum data ! -! indfor (nlay) - index of the lower two appropriate ref ! -! temp for the foreign-continuum interp ! -! laytrop - layer at which switch is made from one ! -! combination of key species to another ! -! jp(nlay),jt(nlay),jt1(nlay) ! -! - lookup table indexes ! -! flxucb(nlp1,nbdsw) - spectral bnd total-sky upward flx (w/m2) ! -! flxdcb(nlp1,nbdsw) - spectral bnd total-sky downward flx (w/m2)! -! flxu0b(nlp1,nbdsw) - spectral bnd clear-sky upward flx (w/m2) ! -! flxd0b(nlp1,nbdsw) - spectral b d clear-sky downward flx (w/m2)! -! ! -! ! -! ===================== end of definitions ==================== ! - -! --- inputs: - integer, intent(in) :: npts, nlay, nlp1, NDAY - - integer, dimension(:), intent(in) :: idxday, icseed - - logical, intent(in) :: lprnt, lsswr - - real (kind=kind_phys), dimension(npts,nlp1), intent(in) :: & - & plvl, tlvl - real (kind=kind_phys), dimension(npts,nlay), intent(in) :: & - & plyr, tlyr, qlyr, olyr, dzlyr, delpin - - real (kind=kind_phys),dimension(npts),intent(in):: sfcalb_nir_dir - real (kind=kind_phys),dimension(npts),intent(in):: sfcalb_nir_dif - real (kind=kind_phys),dimension(npts),intent(in):: sfcalb_uvis_dir - real (kind=kind_phys),dimension(npts),intent(in):: sfcalb_uvis_dif - - real(kind=kind_phys),dimension(npts,nlay),intent(in)::gasvmr_co2 - real(kind=kind_phys),dimension(npts,nlay),intent(in)::gasvmr_n2o - real(kind=kind_phys),dimension(npts,nlay),intent(in)::gasvmr_ch4 - real(kind=kind_phys),dimension(npts,nlay),intent(in)::gasvmr_o2 - real(kind=kind_phys),dimension(npts,nlay),intent(in)::gasvmr_co - real(kind=kind_phys),dimension(npts,nlay),intent(in)::gasvmr_cfc11 - real(kind=kind_phys),dimension(npts,nlay),intent(in)::gasvmr_cfc12 - real(kind=kind_phys),dimension(npts,nlay),intent(in)::gasvmr_cfc22 - real(kind=kind_phys),dimension(npts,nlay),intent(in)::gasvmr_ccl4 - - real (kind=kind_phys), dimension(npts,nlay),intent(in):: cld_cf - real (kind=kind_phys), dimension(npts,nlay),intent(in),optional:: & - & cld_lwp, cld_ref_liq, cld_iwp, cld_ref_ice, & - & cld_rwp, cld_ref_rain, cld_swp, cld_ref_snow, & - & cld_od, cld_ssa, cld_asy - - real(kind=kind_phys),dimension(npts,nlay,nbdsw),intent(in)::aeraod - real(kind=kind_phys),dimension(npts,nlay,nbdsw),intent(in)::aerssa - real(kind=kind_phys),dimension(npts,nlay,nbdsw),intent(in)::aerasy - - real (kind=kind_phys), intent(in) :: cosz(npts), solcon, & - & de_lgth(npts) - -! --- outputs: - real (kind=kind_phys), dimension(npts,nlay), intent(inout) :: hswc - real (kind=kind_phys), dimension(npts,nlay), intent(inout) :: & - & cldtau - - type (topfsw_type), dimension(npts), intent(inout) :: topflx - type (sfcfsw_type), dimension(npts), intent(inout) :: sfcflx - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - -!! --- optional outputs: - real (kind=kind_phys), dimension(npts,nlay,nbdsw), optional, & - & intent(inout) :: hswb - - real (kind=kind_phys), dimension(npts,nlay), optional, & - & intent(inout) :: hsw0 - type (profsw_type), dimension(npts,nlp1), optional, & - & intent(inout) :: flxprf - type (cmpfsw_type), dimension(npts), optional, & - & intent(inout) :: fdncmp - -! --- locals: - real (kind=kind_phys), dimension(nlay,ngptsw) :: cldfmc, & - & taug, taur - real (kind=kind_phys), dimension(nlp1,nbdsw):: fxupc, fxdnc, & - & fxup0, fxdn0 - - real (kind=kind_phys), dimension(nlay,nbdsw) :: & - & tauae, ssaae, asyae, taucw, ssacw, asycw - - real (kind=kind_phys), dimension(ngptsw) :: sfluxzen - - real (kind=kind_phys), dimension(nlay) :: cldfrc, delp, & - & pavel, tavel, coldry, colmol, h2ovmr, o3vmr, temcol, & - & cliqp, reliq, cicep, reice, cdat1, cdat2, cdat3, cdat4, & - & cfrac, fac00, fac01, fac10, fac11, forfac, forfrac, & - & selffac, selffrac, rfdelp, dz - - real (kind=kind_phys), dimension(nlp1) :: fnet, flxdc, flxuc, & - & flxd0, flxu0 - - real (kind=kind_phys), dimension(2) :: albbm, albdf, sfbmc, & - & sfbm0, sfdfc, sfdf0 - - real (kind=kind_phys) :: cosz1, sntz1, tem0, tem1, tem2, s0fac, & - & ssolar, zcf0, zcf1, ftoau0, ftoauc, ftoadc, & - & fsfcu0, fsfcuc, fsfcd0, fsfcdc, suvbfc, suvbf0, delgth - -! --- column amount of absorbing gases: -! (:,m) m = 1-h2o, 2-co2, 3-o3, 4-n2o, 5-ch4, 6-o2, 7-co - real (kind=kind_phys) :: colamt(nlay,maxgas) - - integer, dimension(npts) :: ipseed - integer, dimension(nlay) :: indfor, indself, jp, jt, jt1 - - integer :: i, ib, ipt, j1, k, kk, laytrop, mb -! -!===> ... begin here -! - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 -! - if (.not. lsswr) return - if (nday <= 0) return - - lhswb = present ( hswb ) - lhsw0 = present ( hsw0 ) - lflxprf= present ( flxprf ) - lfdncmp= present ( fdncmp ) - -!> -# Compute solar constant adjustment factor (s0fac) according to solcon. -! *** s0, the solar constant at toa in w/m**2, is hard-coded with -! each spectra band, the total flux is about 1368.22 w/m**2. - - s0fac = solcon / s0 - -!> -# Initial output arrays (and optional) as zero. - - hswc(:,:) = f_zero - cldtau(:,:) = f_zero - topflx = topfsw_type ( f_zero, f_zero, f_zero ) - sfcflx = sfcfsw_type ( f_zero, f_zero, f_zero, f_zero ) - -!! --- ... initial optional outputs - if ( lflxprf ) then - flxprf = profsw_type ( f_zero, f_zero, f_zero, f_zero ) - endif - - if ( lfdncmp ) then - fdncmp = cmpfsw_type (f_zero,f_zero,f_zero,f_zero,f_zero,f_zero) - endif - - if ( lhsw0 ) then - hsw0(:,:) = f_zero - endif - - if ( lhswb ) then - hswb(:,:,:) = f_zero - endif - -!! --- check for optional input arguments, depending on cloud method - if (iswcliq > 0) then ! use prognostic cloud method - if ( .not.present(cld_lwp) .or. .not.present(cld_ref_liq) .or. & - & .not.present(cld_iwp) .or. .not.present(cld_ref_ice) .or. & - & .not.present(cld_rwp) .or. .not.present(cld_ref_rain) .or. & - & .not.present(cld_swp) .or. .not.present(cld_ref_snow) )then - write(errmsg,'(*(a))') & - & 'Logic error: iswcliq>0 requires the following', & - & ' optional arguments to be present:', & - & ' cld_lwp, cld_ref_liq, cld_iwp, cld_ref_ice,', & - & ' cld_rwp, cld_ref_rain, cld_swp, cld_ref_snow' - errflg = 1 - return - end if - else ! use diagnostic cloud method - if ( .not.present(cld_od) .or. .not.present(cld_ssa) .or. & - & .not.present(cld_asy)) then - write(errmsg,'(*(a))') & - & 'Logic error: iswcliq<=0 requires the following', & - & ' optional arguments to be present:', & - & ' cld_od, cld_ssa, cld_asy' - errflg = 1 - return - end if - endif ! end if_iswcliq - -!> -# Change random number seed value for each radiation invocation -!! (isubcsw =1 or 2). - - if ( isubcsw == 1 ) then ! advance prescribed permutation seed - do i = 1, npts - ipseed(i) = ipsdsw0 + i - enddo - elseif ( isubcsw == 2 ) then ! use input array of permutaion seeds - do i = 1, npts - ipseed(i) = icseed(i) - enddo - endif - - if ( lprnt ) then - write(0,*)' In radsw, isubcsw, ipsdsw0,ipseed =', & - & isubcsw, ipsdsw0, ipseed - endif - -! --- ... loop over each daytime grid point - - lab_do_ipt : do ipt = 1, NDAY - - j1 = idxday(ipt) - - cosz1 = cosz(j1) - sntz1 = f_one / cosz(j1) - ssolar = s0fac * cosz(j1) - if (iovrsw == 3) delgth = de_lgth(j1) ! clouds decorr-length - -!> -# Prepare surface albedo: bm,df - dir,dif; 1,2 - nir,uvv. - albbm(1) = sfcalb_nir_dir(j1) - albdf(1) = sfcalb_nir_dif(j1) - albbm(2) = sfcalb_uvis_dir(j1) - albdf(2) = sfcalb_uvis_dif(j1) - -!> -# Prepare atmospheric profile for use in rrtm. -! the vertical index of internal array is from surface to top - - if (ivflip == 0) then ! input from toa to sfc - - tem1 = 100.0 * con_g - tem2 = 1.0e-20 * 1.0e3 * con_avgd - - do k = 1, nlay - kk = nlp1 - k - pavel(k) = plyr(j1,kk) - tavel(k) = tlyr(j1,kk) - delp (k) = delpin(j1,kk) - dz (k) = dzlyr (j1,kk) -!> -# Set absorber and gas column amount, convert from volume mixing -!! ratio to molec/cm2 based on coldry (scaled to 1.0e-20) -!! - colamt(nlay,maxgas):column amounts of absorbing gases 1 to -!! maxgas are for h2o,co2,o3,n2o,ch4,o2,co, respectively -!! (\f$ mol/cm^2 \f$) - -!test use -! h2ovmr(k)= max(f_zero,qlyr(j1,kk)*amdw) ! input mass mixing ratio -! h2ovmr(k)= max(f_zero,qlyr(j1,kk)) ! input vol mixing ratio -! o3vmr (k)= max(f_zero,olyr(j1,kk)) ! input vol mixing ratio -!ncep model use - h2ovmr(k)= max(f_zero,qlyr(j1,kk)*amdw/(f_one-qlyr(j1,kk))) ! input specific humidity - o3vmr (k)= max(f_zero,olyr(j1,kk)*amdo3) ! input mass mixing ratio - - tem0 = (f_one - h2ovmr(k))*con_amd + h2ovmr(k)*con_amw - coldry(k) = tem2 * delp(k) / (tem1*tem0*(f_one + h2ovmr(k))) - temcol(k) = 1.0e-12 * coldry(k) - - colamt(k,1) = max(f_zero, coldry(k)*h2ovmr(k)) ! h2o - colamt(k,2) = max(temcol(k), coldry(k)*gasvmr_co2(j1,kk)) ! co2 - colamt(k,3) = max(f_zero, coldry(k)*o3vmr(k)) ! o3 - colmol(k) = coldry(k) + colamt(k,1) - enddo - -! --- ... set up gas column amount, convert from volume mixing ratio -! to molec/cm2 based on coldry (scaled to 1.0e-20) - - if (iswrgas > 0) then - do k = 1, nlay - kk = nlp1 - k - colamt(k,4) = max(temcol(k), coldry(k)*gasvmr_n2o(j1,kk)) ! n2o - colamt(k,5) = max(temcol(k), coldry(k)*gasvmr_ch4(j1,kk)) ! ch4 - colamt(k,6) = max(temcol(k), coldry(k)*gasvmr_o2(j1,kk)) ! o2 -! colamt(k,7) = max(temcol(k), coldry(k)*gasvmr(j1,kk,5)) ! co - notused - enddo - else - do k = 1, nlay - colamt(k,4) = temcol(k) ! n2o - colamt(k,5) = temcol(k) ! ch4 - colamt(k,6) = temcol(k) ! o2 -! colamt(k,7) = temcol(k) ! co - notused - enddo - endif - -!> -# Read aerosol optical properties from 'aerosols'. - - do k = 1, nlay - kk = nlp1 - k - do ib = 1, nbdsw - tauae(k,ib) = aeraod(j1,kk,ib) - ssaae(k,ib) = aerssa(j1,kk,ib) - asyae(k,ib) = aerasy(j1,kk,ib) - enddo - enddo - -!> -# Read cloud optical properties from 'clouds'. - if (iswcliq > 0) then ! use prognostic cloud method - do k = 1, nlay - kk = nlp1 - k - cfrac(k) = cld_cf(j1,kk) ! cloud fraction - cliqp(k) = cld_lwp(j1,kk) ! cloud liq path - reliq(k) = cld_ref_liq(j1,kk) ! liq partical effctive radius - cicep(k) = cld_iwp(j1,kk) ! cloud ice path - reice(k) = cld_ref_ice(j1,kk) ! ice partical effctive radius - cdat1(k) = cld_rwp(j1,kk) ! cloud rain drop path - cdat2(k) = cld_ref_rain(j1,kk) ! rain partical effctive radius - cdat3(k) = cld_swp(j1,kk) ! cloud snow path - cdat4(k) = cld_ref_snow(j1,kk) ! snow partical effctive radius - enddo - else ! use diagnostic cloud method - do k = 1, nlay - kk = nlp1 - k - cfrac(k) = cld_cf(j1,kk) ! cloud fraction - cdat1(k) = cld_od(j1,kk) ! cloud optical depth - cdat2(k) = cld_ssa(j1,kk) ! cloud single scattering albedo - cdat3(k) = cld_asy(j1,kk) ! cloud asymmetry factor - enddo - endif ! end if_iswcliq - - else ! input from sfc to toa - - tem1 = 100.0 * con_g - tem2 = 1.0e-20 * 1.0e3 * con_avgd - - do k = 1, nlay - pavel(k) = plyr(j1,k) - tavel(k) = tlyr(j1,k) - delp (k) = delpin(j1,k) - dz (k) = dzlyr (j1,k) - -! --- ... set absorber amount -!test use -! h2ovmr(k)= max(f_zero,qlyr(j1,k)*amdw) ! input mass mixing ratio -! h2ovmr(k)= max(f_zero,qlyr(j1,k)) ! input vol mixing ratio -! o3vmr (k)= max(f_zero,olyr(j1,k)) ! input vol mixing ratio -!ncep model use - h2ovmr(k)= max(f_zero,qlyr(j1,k)*amdw/(f_one-qlyr(j1,k))) ! input specific humidity - o3vmr (k)= max(f_zero,olyr(j1,k)*amdo3) ! input mass mixing ratio - - tem0 = (f_one - h2ovmr(k))*con_amd + h2ovmr(k)*con_amw - coldry(k) = tem2 * delp(k) / (tem1*tem0*(f_one + h2ovmr(k))) - temcol(k) = 1.0e-12 * coldry(k) - - colamt(k,1) = max(f_zero, coldry(k)*h2ovmr(k)) ! h2o - colamt(k,2) = max(temcol(k), coldry(k)*gasvmr_co2(j1,k)) ! co2 - colamt(k,3) = max(f_zero, coldry(k)*o3vmr(k)) ! o3 - colmol(k) = coldry(k) + colamt(k,1) - enddo - - - if (lprnt) then - if (ipt == 1) then - write(0,*)' pavel=',pavel - write(0,*)' tavel=',tavel - write(0,*)' delp=',delp - write(0,*)' h2ovmr=',h2ovmr*1000 - write(0,*)' o3vmr=',o3vmr*1000000 - endif - endif - -! --- ... set up gas column amount, convert from volume mixing ratio -! to molec/cm2 based on coldry (scaled to 1.0e-20) - - if (iswrgas > 0) then - do k = 1, nlay - colamt(k,4) = max(temcol(k), coldry(k)*gasvmr_n2o(j1,k)) ! n2o - colamt(k,5) = max(temcol(k), coldry(k)*gasvmr_ch4(j1,k)) ! ch4 - colamt(k,6) = max(temcol(k), coldry(k)*gasvmr_o2(j1,k)) ! o2 -! colamt(k,7) = max(temcol(k), coldry(k)*gasvmr(j1,k,5)) ! co - notused - enddo - else - do k = 1, nlay - colamt(k,4) = temcol(k) ! n2o - colamt(k,5) = temcol(k) ! ch4 - colamt(k,6) = temcol(k) ! o2 -! colamt(k,7) = temcol(k) ! co - notused - enddo - endif - -! --- ... set aerosol optical properties - - do ib = 1, nbdsw - do k = 1, nlay - tauae(k,ib) = aeraod(j1,k,ib) - ssaae(k,ib) = aerssa(j1,k,ib) - asyae(k,ib) = aerasy(j1,k,ib) - enddo - enddo - - if (iswcliq > 0) then ! use prognostic cloud method - do k = 1, nlay - cfrac(k) = cld_cf(j1,k) ! cloud fraction - cliqp(k) = cld_lwp(j1,k) ! cloud liq path - reliq(k) = cld_ref_liq(j1,k) ! liq partical effctive radius - cicep(k) = cld_iwp(j1,k) ! cloud ice path - reice(k) = cld_ref_ice(j1,k) ! ice partical effctive radius - cdat1(k) = cld_rwp(j1,k) ! cloud rain drop path - cdat2(k) = cld_ref_rain(j1,k) ! rain partical effctive radius - cdat3(k) = cld_swp(j1,k) ! cloud snow path - cdat4(k) = cld_ref_snow(j1,k) ! snow partical effctive radius - enddo - else ! use diagnostic cloud method - do k = 1, nlay - cfrac(k) = cld_cf(j1,k) ! cloud fraction - cdat1(k) = cld_od(j1,k) ! cloud optical depth - cdat2(k) = cld_ssa(j1,k) ! cloud single scattering albedo - cdat3(k) = cld_asy(j1,k) ! cloud asymmetry factor - enddo - endif ! end if_iswcliq - - endif ! if_ivflip - -!> -# Compute fractions of clear sky view: -!! - random overlapping -!! - max/ran overlapping -!! - maximum overlapping - - zcf0 = f_one - zcf1 = f_one - if (iovrsw == 0) then ! random overlapping - do k = 1, nlay - zcf0 = zcf0 * (f_one - cfrac(k)) - enddo - else if (iovrsw == 1) then ! max/ran overlapping - do k = 1, nlay - if (cfrac(k) > ftiny) then ! cloudy layer - zcf1 = min ( zcf1, f_one-cfrac(k) ) - elseif (zcf1 < f_one) then ! clear layer - zcf0 = zcf0 * zcf1 - zcf1 = f_one - endif - enddo - zcf0 = zcf0 * zcf1 - else if (iovrsw >= 2) then - do k = 1, nlay - zcf0 = min ( zcf0, f_one-cfrac(k) ) ! used only as clear/cloudy indicator - enddo - endif - - if (zcf0 <= ftiny) zcf0 = f_zero - if (zcf0 > oneminus) zcf0 = f_one - zcf1 = f_one - zcf0 - -!> -# For cloudy sky column, call cldprop() to compute the cloud -!! optical properties for each cloudy layer. - - if (zcf1 > f_zero) then ! cloudy sky column - - call cldprop & -! --- inputs: - & ( cfrac,cliqp,reliq,cicep,reice,cdat1,cdat2,cdat3,cdat4, & - & zcf1, nlay, ipseed(j1), dz, delgth, & -! --- outputs: - & taucw, ssacw, asycw, cldfrc, cldfmc & - & ) - -! --- ... save computed layer cloud optical depth for output -! rrtm band 10 is approx to the 0.55 mu spectrum - - if (ivflip == 0) then ! input from toa to sfc - do k = 1, nlay - kk = nlp1 - k - cldtau(j1,kk) = taucw(k,10) - enddo - else ! input from sfc to toa - do k = 1, nlay - cldtau(j1,k) = taucw(k,10) - enddo - endif ! end if_ivflip_block - - else ! clear sky column - cldfrc(:) = f_zero - cldfmc(:,:)= f_zero - do i = 1, nbdsw - do k = 1, nlay - taucw(k,i) = f_zero - ssacw(k,i) = f_zero - asycw(k,i) = f_zero - enddo - enddo - endif ! end if_zcf1_block - -!> -# Call setcoef() to compute various coefficients needed in -!! radiative transfer calculations. - call setcoef & -! --- inputs: - & ( pavel,tavel,h2ovmr, nlay,nlp1, & -! --- outputs: - & laytrop,jp,jt,jt1,fac00,fac01,fac10,fac11, & - & selffac,selffrac,indself,forfac,forfrac,indfor & - & ) - -!> -# Call taumol() to calculate optical depths for gaseous absorption -!! and rayleigh scattering - call taumol & -! --- inputs: - & ( colamt,colmol,fac00,fac01,fac10,fac11,jp,jt,jt1,laytrop, & - & forfac,forfrac,indfor,selffac,selffrac,indself, NLAY, & -! --- outputs: - & sfluxzen, taug, taur & - & ) - -!> -# Call the 2-stream radiation transfer model: -!! - if physparam::isubcsw .le.0, using standard cloud scheme, -!! call spcvrtc(). -!! - if physparam::isubcsw .gt.0, using mcica cloud scheme, -!! call spcvrtm(). - - if ( isubcsw <= 0 ) then ! use standard cloud scheme - - call spcvrtc & -! --- inputs: - & ( ssolar,cosz1,sntz1,albbm,albdf,sfluxzen,cldfrc, & - & zcf1,zcf0,taug,taur,tauae,ssaae,asyae,taucw,ssacw,asycw, & - & nlay, nlp1, & -! --- outputs: - & fxupc,fxdnc,fxup0,fxdn0, & - & ftoauc,ftoau0,ftoadc,fsfcuc,fsfcu0,fsfcdc,fsfcd0, & - & sfbmc,sfdfc,sfbm0,sfdf0,suvbfc,suvbf0 & - & ) - - else ! use mcica cloud scheme - - call spcvrtm & -! --- inputs: - & ( ssolar,cosz1,sntz1,albbm,albdf,sfluxzen,cldfmc, & - & zcf1,zcf0,taug,taur,tauae,ssaae,asyae,taucw,ssacw,asycw, & - & nlay, nlp1, & -! --- outputs: - & fxupc,fxdnc,fxup0,fxdn0, & - & ftoauc,ftoau0,ftoadc,fsfcuc,fsfcu0,fsfcdc,fsfcd0, & - & sfbmc,sfdfc,sfbm0,sfdf0,suvbfc,suvbf0 & - & ) - - endif - -!> -# Save outputs. -! --- ... sum up total spectral fluxes for total-sky - - do k = 1, nlp1 - flxuc(k) = f_zero - flxdc(k) = f_zero - - do ib = 1, nbdsw - flxuc(k) = flxuc(k) + fxupc(k,ib) - flxdc(k) = flxdc(k) + fxdnc(k,ib) - enddo - enddo - -!! --- ... optional clear sky fluxes - - if ( lhsw0 .or. lflxprf ) then - do k = 1, nlp1 - flxu0(k) = f_zero - flxd0(k) = f_zero - - do ib = 1, nbdsw - flxu0(k) = flxu0(k) + fxup0(k,ib) - flxd0(k) = flxd0(k) + fxdn0(k,ib) - enddo - enddo - endif - -! --- ... prepare for final outputs - - do k = 1, nlay - rfdelp(k) = heatfac / delp(k) - enddo - - if ( lfdncmp ) then -!! --- ... optional uv-b surface downward flux - fdncmp(j1)%uvbf0 = suvbf0 - fdncmp(j1)%uvbfc = suvbfc - -!! --- ... optional beam and diffuse sfc fluxes - fdncmp(j1)%nirbm = sfbmc(1) - fdncmp(j1)%nirdf = sfdfc(1) - fdncmp(j1)%visbm = sfbmc(2) - fdncmp(j1)%visdf = sfdfc(2) - endif ! end if_lfdncmp - -! --- ... toa and sfc fluxes - - topflx(j1)%upfxc = ftoauc - topflx(j1)%dnfxc = ftoadc - topflx(j1)%upfx0 = ftoau0 - - sfcflx(j1)%upfxc = fsfcuc - sfcflx(j1)%dnfxc = fsfcdc - sfcflx(j1)%upfx0 = fsfcu0 - sfcflx(j1)%dnfx0 = fsfcd0 - - if (ivflip == 0) then ! output from toa to sfc - -! --- ... compute heating rates - - fnet(1) = flxdc(1) - flxuc(1) - - do k = 2, nlp1 - kk = nlp1 - k + 1 - fnet(k) = flxdc(k) - flxuc(k) - hswc(j1,kk) = (fnet(k)-fnet(k-1)) * rfdelp(k-1) - enddo - -!! --- ... optional flux profiles - - if ( lflxprf ) then - do k = 1, nlp1 - kk = nlp1 - k + 1 - flxprf(j1,kk)%upfxc = flxuc(k) - flxprf(j1,kk)%dnfxc = flxdc(k) - flxprf(j1,kk)%upfx0 = flxu0(k) - flxprf(j1,kk)%dnfx0 = flxd0(k) - enddo - endif - -!! --- ... optional clear sky heating rates - - if ( lhsw0 ) then - fnet(1) = flxd0(1) - flxu0(1) - - do k = 2, nlp1 - kk = nlp1 - k + 1 - fnet(k) = flxd0(k) - flxu0(k) - hsw0(j1,kk) = (fnet(k)-fnet(k-1)) * rfdelp(k-1) - enddo - endif - -!! --- ... optional spectral band heating rates - - if ( lhswb ) then - do mb = 1, nbdsw - fnet(1) = fxdnc(1,mb) - fxupc(1,mb) - - do k = 2, nlp1 - kk = nlp1 - k + 1 - fnet(k) = fxdnc(k,mb) - fxupc(k,mb) - hswb(j1,kk,mb) = (fnet(k) - fnet(k-1)) * rfdelp(k-1) - enddo - enddo - endif - - else ! output from sfc to toa - -! --- ... compute heating rates - - fnet(1) = flxdc(1) - flxuc(1) - - do k = 2, nlp1 - fnet(k) = flxdc(k) - flxuc(k) - hswc(j1,k-1) = (fnet(k)-fnet(k-1)) * rfdelp(k-1) - enddo - -!! --- ... optional flux profiles - - if ( lflxprf ) then - do k = 1, nlp1 - flxprf(j1,k)%upfxc = flxuc(k) - flxprf(j1,k)%dnfxc = flxdc(k) - flxprf(j1,k)%upfx0 = flxu0(k) - flxprf(j1,k)%dnfx0 = flxd0(k) - enddo - endif - -!! --- ... optional clear sky heating rates - - if ( lhsw0 ) then - fnet(1) = flxd0(1) - flxu0(1) - - do k = 2, nlp1 - fnet(k) = flxd0(k) - flxu0(k) - hsw0(j1,k-1) = (fnet(k)-fnet(k-1)) * rfdelp(k-1) - enddo - endif - -!! --- ... optional spectral band heating rates - - if ( lhswb ) then - do mb = 1, nbdsw - fnet(1) = fxdnc(1,mb) - fxupc(1,mb) - - do k = 1, nlay - fnet(k+1) = fxdnc(k+1,mb) - fxupc(k+1,mb) - hswb(j1,k,mb) = (fnet(k+1) - fnet(k)) * rfdelp(k) - enddo - enddo - endif - - endif ! if_ivflip - - enddo lab_do_ipt - - return -!................................... - end subroutine rrtmg_sw_run -!----------------------------------- -!> @} - - subroutine rrtmg_sw_finalize () - end subroutine rrtmg_sw_finalize - - -!>\ingroup module_radsw_main -!> This subroutine initializes non-varying module variables, conversion -!! factors, and look-up tables. -!!\param me print control for parallel process -!>\section rswinit_gen rswinit General Algorithm -!! @{ -!----------------------------------- - subroutine rswinit & - & ( me ) ! --- inputs: -! --- outputs: (none) - -! =================== program usage description =================== ! -! ! -! purpose: initialize non-varying module variables, conversion factors,! -! and look-up tables. ! -! ! -! subprograms called: none ! -! ! -! ==================== defination of variables ==================== ! -! ! -! inputs: ! -! me - print control for parallel process ! -! ! -! outputs: (none) ! -! ! -! external module variables: (in physparam) ! -! iswrate - heating rate unit selections ! -! =1: output in k/day ! -! =2: output in k/second ! -! iswrgas - control flag for rare gases (ch4,n2o,o2, etc.) ! -! =0: do not include rare gases ! -! >0: include all rare gases ! -! iswcliq - liquid cloud optical properties contrl flag ! -! =0: input cloud opt depth from diagnostic scheme ! -! >0: input cwp,rew, and other cloud content parameters ! -! isubcsw - sub-column cloud approximation control flag ! -! =0: no sub-col cld treatment, use grid-mean cld quantities ! -! =1: mcica sub-col, prescribed seeds to get random numbers ! -! =2: mcica sub-col, providing array icseed for random numbers! -! icldflg - cloud scheme control flag ! -! =0: diagnostic scheme gives cloud tau, omiga, and g. ! -! =1: prognostic scheme gives cloud liq/ice path, etc. ! -! iovrsw - clouds vertical overlapping control flag ! -! =0: random overlapping clouds ! -! =1: maximum/random overlapping clouds ! -! =2: maximum overlap cloud ! -! =3: decorrelation-length overlap clouds ! -! iswmode - control flag for 2-stream transfer scheme ! -! =1; delta-eddington (joseph et al., 1976) ! -! =2: pifm (zdunkowski et al., 1980) ! -! =3: discrete ordinates (liou, 1973) ! -! ! -! ******************************************************************* ! -! ! -! definitions: ! -! arrays for 10000-point look-up tables: ! -! tau_tbl clear-sky optical depth ! -! exp_tbl exponential lookup table for transmittance ! -! ! -! ******************************************************************* ! -! ! -! ====================== end of description block ================= ! - -! --- inputs: - integer, intent(in) :: me - -! --- outputs: none - -! --- locals: - real (kind=kind_phys), parameter :: expeps = 1.e-20 - - integer :: i - - real (kind=kind_phys) :: tfn, tau - -! -!===> ... begin here -! - if ( iovrsw<0 .or. iovrsw>3 ) then - print *,' *** Error in specification of cloud overlap flag', & - & ' IOVRSW=',iovrsw,' in RSWINIT !!' - stop - endif - - if (me == 0) then - print *,' - Using AER Shortwave Radiation, Version: ',VTAGSW - - if (iswmode == 1) then - print *,' --- Delta-eddington 2-stream transfer scheme' - else if (iswmode == 2) then - print *,' --- PIFM 2-stream transfer scheme' - else if (iswmode == 3) then - print *,' --- Discrete ordinates 2-stream transfer scheme' - endif - - if (iswrgas <= 0) then - print *,' --- Rare gases absorption is NOT included in SW' - else - print *,' --- Include rare gases N2O, CH4, O2, absorptions',& - & ' in SW' - endif - - if ( isubcsw == 0 ) then - print *,' --- Using standard grid average clouds, no ', & - & 'sub-column clouds approximation applied' - elseif ( isubcsw == 1 ) then - print *,' --- Using MCICA sub-colum clouds approximation ', & - & 'with a prescribed sequence of permutation seeds' - elseif ( isubcsw == 2 ) then - print *,' --- Using MCICA sub-colum clouds approximation ', & - & 'with provided input array of permutation seeds' - else - print *,' *** Error in specification of sub-column cloud ', & - & ' control flag isubcsw =',isubcsw,' !!' - stop - endif - endif - -!> -# Check cloud flags for consistency. - - if ((icldflg == 0 .and. iswcliq /= 0) .or. & - & (icldflg == 1 .and. iswcliq == 0)) then - print *,' *** Model cloud scheme inconsistent with SW', & - & ' radiation cloud radiative property setup !!' - stop - endif - - if ( isubcsw==0 .and. iovrsw>2 ) then - if (me == 0) then - print *,' *** IOVRSW=',iovrsw,' is not available for', & - & ' ISUBCSW=0 setting!!' - print *,' The program will use maximum/random overlap', & - & ' instead.' - endif - - iovrsw = 1 - endif - -!> -# Setup constant factors for heating rate -!! the 1.0e-2 is to convert pressure from mb to \f$N/m^2\f$ . - - if (iswrate == 1) then -! heatfac = 8.4391 -! heatfac = con_g * 86400. * 1.0e-2 / con_cp ! (in k/day) - heatfac = con_g * 864.0 / con_cp ! (in k/day) - else - heatfac = con_g * 1.0e-2 / con_cp ! (in k/second) - endif - -!> -# Define exponential lookup tables for transmittance. -! tau is computed as a function of the \a tau transition function, and -! transmittance is calculated as a function of tau. all tables -! are computed at intervals of 0.0001. the inverse of the -! constant used in the Pade approximation to the tau transition -! function is set to bpade. - - exp_tbl(0) = 1.0 - exp_tbl(NTBMX) = expeps - - do i = 1, NTBMX-1 - tfn = float(i) / float(NTBMX-i) - tau = bpade * tfn - exp_tbl(i) = exp( -tau ) - enddo - - return -!................................... - end subroutine rswinit -!! @} -!----------------------------------- - -!>\ingroup module_radsw_main -!> This subroutine computes the cloud optical properties for each -!! cloudy layer and g-point interval. -!!\param cfrac layer cloud fraction -!!\n for physparam::iswcliq > 0 (prognostic cloud scheme) - - - -!!\param cliqp layer in-cloud liq water path (\f$g/m^2\f$) -!!\param reliq mean eff radius for liq cloud (micron) -!!\param cicep layer in-cloud ice water path (\f$g/m^2\f$) -!!\param reice mean eff radius for ice cloud (micron) -!!\param cdat1 layer rain drop water path (\f$g/m^2\f$) -!!\param cdat2 effective radius for rain drop (micron) -!!\param cdat3 layer snow flake water path(\f$g/m^2\f$) -!!\param cdat4 mean eff radius for snow flake(micron) -!!\n for physparam::iswcliq = 0 (diagnostic cloud scheme) - - - -!!\param cliqp not used -!!\param cicep not used -!!\param reliq not used -!!\param reice not used -!!\param cdat1 layer cloud optical depth -!!\param cdat2 layer cloud single scattering albedo -!!\param cdat3 layer cloud asymmetry factor -!!\param cdat4 optional use -!!\param cf1 effective total cloud cover at surface -!!\param nlay vertical layer number -!!\param ipseed permutation seed for generating random numbers -!! (isubcsw>0) -!!\param dz layer thickness (km) -!!\param delgth layer cloud decorrelation length (km) -!!\param taucw cloud optical depth, w/o delta scaled -!!\param ssacw weighted cloud single scattering albedo -!! (ssa = ssacw / taucw) -!!\param asycw weighted cloud asymmetry factor -!! (asy = asycw / ssacw) -!!\param cldfrc cloud fraction of grid mean value -!!\param cldfmc cloud fraction for each sub-column -!!\section General_cldprop cldprop General Algorithm -!> @{ -!----------------------------------- - subroutine cldprop & - & ( cfrac,cliqp,reliq,cicep,reice,cdat1,cdat2,cdat3,cdat4, & ! --- inputs - & cf1, nlay, ipseed, dz, delgth, iswcliq, & - & taucw, ssacw, asycw, cldfrc, cldfmc & ! --- output - & ) - -! =================== program usage description =================== ! -! ! -! Purpose: Compute the cloud optical properties for each cloudy layer ! -! and g-point interval. ! -! ! -! subprograms called: none ! -! ! -! ==================== defination of variables ==================== ! -! ! -! inputs: size ! -! cfrac - real, layer cloud fraction nlay ! -! ..... for iswcliq > 0 (prognostic cloud scheme) - - - ! -! cliqp - real, layer in-cloud liq water path (g/m**2) nlay ! -! reliq - real, mean eff radius for liq cloud (micron) nlay ! -! cicep - real, layer in-cloud ice water path (g/m**2) nlay ! -! reice - real, mean eff radius for ice cloud (micron) nlay ! -! cdat1 - real, layer rain drop water path (g/m**2) nlay ! -! cdat2 - real, effective radius for rain drop (micron) nlay ! -! cdat3 - real, layer snow flake water path(g/m**2) nlay ! -! cdat4 - real, mean eff radius for snow flake(micron) nlay ! -! ..... for iswcliq = 0 (diagnostic cloud scheme) - - - ! -! cdat1 - real, layer cloud optical depth nlay ! -! cdat2 - real, layer cloud single scattering albedo nlay ! -! cdat3 - real, layer cloud asymmetry factor nlay ! -! cdat4 - real, optional use nlay ! -! cliqp - real, not used nlay ! -! cicep - real, not used nlay ! -! reliq - real, not used nlay ! -! reice - real, not used nlay ! -! ! -! cf1 - real, effective total cloud cover at surface 1 ! -! nlay - integer, vertical layer number 1 ! -! ipseed- permutation seed for generating random numbers (isubcsw>0) ! -! dz - real, layer thickness (km) nlay ! -! delgth- real, layer cloud decorrelation length (km) 1 ! -! ! -! outputs: ! -! taucw - real, cloud optical depth, w/o delta scaled nlay*nbdsw ! -! ssacw - real, weighted cloud single scattering albedo nlay*nbdsw ! -! (ssa = ssacw / taucw) ! -! asycw - real, weighted cloud asymmetry factor nlay*nbdsw ! -! (asy = asycw / ssacw) ! -! cldfrc - real, cloud fraction of grid mean value nlay ! -! cldfmc - real, cloud fraction for each sub-column nlay*ngptsw! -! ! -! ! -! explanation of the method for each value of iswcliq, and iswcice. ! -! set up in module "physparam" ! -! ! -! iswcliq=0 : input cloud optical property (tau, ssa, asy). ! -! (used for diagnostic cloud method) ! -! iswcliq>0 : input cloud liq/ice path and effective radius, also ! -! require the user of 'iswcice' to specify the method ! -! used to compute aborption due to water/ice parts. ! -! ................................................................... ! -! ! -! iswcliq=1 : liquid water cloud optical properties are computed ! -! as in hu and stamnes (1993), j. clim., 6, 728-742. ! -! iswcliq=2 : updated coeffs for hu and stamnes (1993) by aer ! -! w v3.9-v4.0. ! -! ! -! iswcice used only when iswcliq > 0 ! -! the cloud ice path (g/m2) and ice effective radius ! -! (microns) are inputs. ! -! iswcice=1 : ice cloud optical properties are computed as in ! -! ebert and curry (1992), jgr, 97, 3831-3836. ! -! iswcice=2 : ice cloud optical properties are computed as in ! -! streamer v3.0 (2001), key, streamer user's guide, ! -! cooperative institude for meteorological studies,95pp! -! iswcice=3 : ice cloud optical properties are computed as in ! -! fu (1996), j. clim., 9. ! -! ! -! other cloud control module variables: ! -! isubcsw =0: standard cloud scheme, no sub-col cloud approximation ! -! >0: mcica sub-col cloud scheme using ipseed as permutation! -! seed for generating rundom numbers ! -! ! -! ====================== end of description block ================= ! -! - use module_radsw_cldprtb - -! --- inputs: - integer, intent(in) :: nlay, ipseed, iswcliq - real (kind=kind_phys), intent(in) :: cf1, delgth - - real (kind=kind_phys), dimension(nlay), intent(in) :: cliqp, & - & reliq, cicep, reice, cdat1, cdat2, cdat3, cdat4, cfrac, dz - -! --- outputs: - real (kind=kind_phys), dimension(nlay,ngptsw), intent(out) :: & - & cldfmc - real (kind=kind_phys), dimension(nlay,nbdsw), intent(out) :: & - & taucw, ssacw, asycw - real (kind=kind_phys), dimension(nlay), intent(out) :: cldfrc - -! --- locals: - real (kind=kind_phys), dimension(nblow:nbhgh) :: tauliq, tauice, & - & ssaliq, ssaice, ssaran, ssasnw, asyliq, asyice, & - & asyran, asysnw - real (kind=kind_phys), dimension(nlay) :: cldf - - real (kind=kind_phys) :: dgeice, factor, fint, tauran, tausnw, & - & cldliq, refliq, cldice, refice, cldran, cldsnw, refsnw, & - & extcoliq, ssacoliq, asycoliq, extcoice, ssacoice, asycoice,& - & dgesnw - - logical :: lcloudy(nlay,ngptsw) - integer :: ia, ib, ig, jb, k, index - -! -!===> ... begin here -! - do ib = 1, nbdsw - do k = 1, nlay - taucw (k,ib) = f_zero - ssacw (k,ib) = f_one - asycw (k,ib) = f_zero - enddo - enddo - -!> -# Compute cloud radiative properties for a cloudy column. - - lab_if_iswcliq : if (iswcliq > 0) then - - lab_do_k : do k = 1, nlay - lab_if_cld : if (cfrac(k) > ftiny) then - -!> - Compute optical properties for rain and snow. -!!\n For rain: tauran/ssaran/asyran -!!\n For snow: tausnw/ssasnw/asysnw -!> - Calculation of absorption coefficients due to water clouds -!!\n For water clouds: tauliq/ssaliq/asyliq -!> - Calculation of absorption coefficients due to ice clouds -!!\n For ice clouds: tauice/ssaice/asyice -!> - For Prognostic cloud scheme: sum up the cloud optical property: -!!\n \f$ taucw=tauliq+tauice+tauran+tausnw \f$ -!!\n \f$ ssacw=ssaliq+ssaice+ssaran+ssasnw \f$ -!!\n \f$ asycw=asyliq+asyice+asyran+asysnw \f$ - - cldran = cdat1(k) -! refran = cdat2(k) - cldsnw = cdat3(k) - refsnw = cdat4(k) - dgesnw = 1.0315 * refsnw ! for fu's snow formula - - tauran = cldran * a0r - -!> - If use fu's formula it needs to be normalized by snow/ice density. -!! not use snow density = 0.1 g/cm**3 = 0.1 g/(mu * m**2) -!!\n use ice density = 0.9167 g/cm**3 = 0.9167 g/(mu * m**2) -!!\n 1/0.9167 = 1.09087 -!!\n factor 1.5396=8/(3*sqrt(3)) converts reff to generalized ice particle size -!! use newer factor value 1.0315 - if (cldsnw>f_zero .and. refsnw>10.0_kind_phys) then -! tausnw = cldsnw * (a0s + a1s/refsnw) - tausnw = cldsnw*1.09087*(a0s + a1s/dgesnw) ! fu's formula - else - tausnw = f_zero - endif - - do ib = nblow, nbhgh - ssaran(ib) = tauran * (f_one - b0r(ib)) - ssasnw(ib) = tausnw * (f_one - (b0s(ib)+b1s(ib)*dgesnw)) - asyran(ib) = ssaran(ib) * c0r(ib) - asysnw(ib) = ssasnw(ib) * c0s(ib) - enddo - - cldliq = cliqp(k) - cldice = cicep(k) - refliq = reliq(k) - refice = reice(k) - -!> - Calculation of absorption coefficients due to water clouds. - - if ( cldliq <= f_zero ) then - do ib = nblow, nbhgh - tauliq(ib) = f_zero - ssaliq(ib) = f_zero - asyliq(ib) = f_zero - enddo - else - factor = refliq - 1.5 - index = max( 1, min( 57, int( factor ) )) - fint = factor - float(index) - - if ( iswcliq == 1 ) then - do ib = nblow, nbhgh - extcoliq = max(f_zero, extliq1(index,ib) & - & + fint*(extliq1(index+1,ib)-extliq1(index,ib)) ) - ssacoliq = max(f_zero, min(f_one, ssaliq1(index,ib) & - & + fint*(ssaliq1(index+1,ib)-ssaliq1(index,ib)) )) - - asycoliq = max(f_zero, min(f_one, asyliq1(index,ib) & - & + fint*(asyliq1(index+1,ib)-asyliq1(index,ib)) )) -! forcoliq = asycoliq * asycoliq - - tauliq(ib) = cldliq * extcoliq - ssaliq(ib) = tauliq(ib) * ssacoliq - asyliq(ib) = ssaliq(ib) * asycoliq - enddo - elseif ( iswcliq == 2 ) then ! use updated coeffs - do ib = nblow, nbhgh - extcoliq = max(f_zero, extliq2(index,ib) & - & + fint*(extliq2(index+1,ib)-extliq2(index,ib)) ) - ssacoliq = max(f_zero, min(f_one, ssaliq2(index,ib) & - & + fint*(ssaliq2(index+1,ib)-ssaliq2(index,ib)) )) - - asycoliq = max(f_zero, min(f_one, asyliq2(index,ib) & - & + fint*(asyliq2(index+1,ib)-asyliq2(index,ib)) )) -! forcoliq = asycoliq * asycoliq - - tauliq(ib) = cldliq * extcoliq - ssaliq(ib) = tauliq(ib) * ssacoliq - asyliq(ib) = ssaliq(ib) * asycoliq - enddo - endif ! end if_iswcliq_block - endif ! end if_cldliq_block - -!> - Calculation of absorption coefficients due to ice clouds. - - if ( cldice <= f_zero ) then - do ib = nblow, nbhgh - tauice(ib) = f_zero - ssaice(ib) = f_zero - asyice(ib) = f_zero - enddo - else - -!> - ebert and curry approach for all particle sizes though somewhat -!! unjustified for large ice particles. - - if ( iswcice == 1 ) then - refice = min(130.0_kind_phys,max(13.0_kind_phys,refice)) - - do ib = nblow, nbhgh - ia = idxebc(ib) ! eb_&_c band index for ice cloud coeff - - extcoice = max(f_zero, abari(ia)+bbari(ia)/refice ) - ssacoice = max(f_zero, min(f_one, & - & f_one-cbari(ia)-dbari(ia)*refice )) - asycoice = max(f_zero, min(f_one, & - & ebari(ia)+fbari(ia)*refice )) -! forcoice = asycoice * asycoice - - tauice(ib) = cldice * extcoice - ssaice(ib) = tauice(ib) * ssacoice - asyice(ib) = ssaice(ib) * asycoice - enddo - -!> - streamer approach for ice effective radius between 5.0 and 131.0 microns. - - elseif ( iswcice == 2 ) then - refice = min(131.0_kind_phys,max(5.0_kind_phys,refice)) - - factor = (refice - 2.0) / 3.0 - index = max( 1, min( 42, int( factor ) )) - fint = factor - float(index) - - do ib = nblow, nbhgh - extcoice = max(f_zero, extice2(index,ib) & - & + fint*(extice2(index+1,ib)-extice2(index,ib)) ) - ssacoice = max(f_zero, min(f_one, ssaice2(index,ib) & - & + fint*(ssaice2(index+1,ib)-ssaice2(index,ib)) )) - asycoice = max(f_zero, min(f_one, asyice2(index,ib) & - & + fint*(asyice2(index+1,ib)-asyice2(index,ib)) )) -! forcoice = asycoice * asycoice - - tauice(ib) = cldice * extcoice - ssaice(ib) = tauice(ib) * ssacoice - asyice(ib) = ssaice(ib) * asycoice - enddo - -!> - fu's approach for ice effective radius between 4.8 and 135 microns -!! (generalized effective size from 5 to 140 microns). - - elseif ( iswcice == 3 ) then - dgeice = max( 5.0, min( 140.0, 1.0315*refice )) - - factor = (dgeice - 2.0) / 3.0 - index = max( 1, min( 45, int( factor ) )) - fint = factor - float(index) - - do ib = nblow, nbhgh - extcoice = max(f_zero, extice3(index,ib) & - & + fint*(extice3(index+1,ib)-extice3(index,ib)) ) - ssacoice = max(f_zero, min(f_one, ssaice3(index,ib) & - & + fint*(ssaice3(index+1,ib)-ssaice3(index,ib)) )) - asycoice = max(f_zero, min(f_one, asyice3(index,ib) & - & + fint*(asyice3(index+1,ib)-asyice3(index,ib)) )) -! fdelta = max(f_zero, min(f_one, fdlice3(index,ib) & -! & + fint*(fdlice3(index+1,ib)-fdlice3(index,ib)) )) -! forcoice = min( asycoice, fdelta+0.5/ssacoice ) ! see fu 1996 p. 2067 - - tauice(ib) = cldice * extcoice - ssaice(ib) = tauice(ib) * ssacoice - asyice(ib) = ssaice(ib) * asycoice - enddo - - endif ! end if_iswcice_block - endif ! end if_cldice_block - - do ib = 1, nbdsw - jb = nblow + ib - 1 - taucw(k,ib) = tauliq(jb)+tauice(jb)+tauran+tausnw - ssacw(k,ib) = ssaliq(jb)+ssaice(jb)+ssaran(jb)+ssasnw(jb) - asycw(k,ib) = asyliq(jb)+asyice(jb)+asyran(jb)+asysnw(jb) - enddo - - endif lab_if_cld - enddo lab_do_k - - else lab_if_iswcliq - - do k = 1, nlay - if (cfrac(k) > ftiny) then - do ib = 1, nbdsw - taucw(k,ib) = cdat1(k) - ssacw(k,ib) = cdat1(k) * cdat2(k) - asycw(k,ib) = ssacw(k,ib) * cdat3(k) - enddo - endif - enddo - - endif lab_if_iswcliq - -!> -# if physparam::isubcsw > 0, call mcica_subcol() to distribute -!! cloud properties to each g-point. - - if ( isubcsw > 0 ) then ! mcica sub-col clouds approx - - cldf(:) = cfrac(:) - where (cldf(:) < ftiny) - cldf(:) = f_zero - end where - -! --- ... call sub-column cloud generator - - call mcica_subcol & -! --- inputs: - & ( cldf, nlay, ipseed, dz, delgth, & -! --- outputs: - & lcloudy & - & ) - - do ig = 1, ngptsw - do k = 1, nlay - if ( lcloudy(k,ig) ) then - cldfmc(k,ig) = f_one - else - cldfmc(k,ig) = f_zero - endif - enddo - enddo - - else ! non-mcica, normalize cloud - - do k = 1, nlay - cldfrc(k) = cfrac(k) / cf1 - enddo - endif ! end if_isubcsw_block - - return -!................................... - end subroutine cldprop -!----------------------------------- -!> @} - -!>\ingroup module_radsw_main -!> This subroutine computes the sub-colum cloud profile flag array. -!!\param cldf layer cloud fraction -!!\param nlay number of model vertical layers -!!\param ipseed permute seed for random num generator -!!\param dz layer thickness (km) -!!\param de_lgth layer cloud decorrelation length (km) -!!\param lcloudy sub-colum cloud profile flag array -!!\section mcica_sw_gen mcica_subcol General Algorithm -!> @{ -! ---------------------------------- - subroutine mcica_subcol & - & ( cldf, nlay, ipseed, dz, de_lgth, & ! --- inputs - & lcloudy & ! --- outputs - & ) - -! ==================== defination of variables ==================== ! -! ! -! input variables: size ! -! cldf - real, layer cloud fraction nlay ! -! nlay - integer, number of model vertical layers 1 ! -! ipseed - integer, permute seed for random num generator 1 ! -! ** note : if the cloud generator is called multiple times, need ! -! to permute the seed between each call; if between calls ! -! for lw and sw, use values differ by the number of g-pts. ! -! dz - real, layer thickness (km) nlay ! -! de_lgth-real, layer cloud decorrelation length (km) 1 ! -! ! -! output variables: ! -! lcloudy - logical, sub-colum cloud profile flag array nlay*ngptsw! -! ! -! other control flags from module variables: ! -! iovrsw : control flag for cloud overlapping method ! -! =0: random ! -! =1: maximum/random overlapping clouds ! -! =2: maximum overlap cloud ! -! =3: cloud decorrelation-length overlap method ! -! ! -! ===================== end of definitions ==================== ! - - implicit none - -! --- inputs: - integer, intent(in) :: nlay, ipseed - - real (kind=kind_phys), dimension(nlay), intent(in) :: cldf, dz - real (kind=kind_phys), intent(in) :: de_lgth - -! --- outputs: - logical, dimension(nlay,ngptsw), intent(out):: lcloudy - -! --- locals: - real (kind=kind_phys) :: cdfunc(nlay,ngptsw), tem1, & - & rand2d(nlay*ngptsw), rand1d(ngptsw), fac_lcf(nlay), & - & cdfun2(nlay,ngptsw) - - type (random_stat) :: stat ! for thread safe random generator - - integer :: k, n, k1 -! -!===> ... begin here -! -!> -# Advance randum number generator by ipseed values. - - call random_setseed & -! --- inputs: - & ( ipseed, & -! --- outputs: - & stat & - & ) - -!> -# Sub-column set up according to overlapping assumption. - - select case ( iovrsw ) - - case( 0 ) ! random overlap, pick a random value at every level - - call random_number & -! --- inputs: ( none ) -! --- outputs: - & ( rand2d, stat ) - - k1 = 0 - do n = 1, ngptsw - do k = 1, nlay - k1 = k1 + 1 - cdfunc(k,n) = rand2d(k1) - enddo - enddo - - case( 1 ) ! max-ran overlap - - call random_number & -! --- inputs: ( none ) -! --- outputs: - & ( rand2d, stat ) - - k1 = 0 - do n = 1, ngptsw - do k = 1, nlay - k1 = k1 + 1 - cdfunc(k,n) = rand2d(k1) - enddo - enddo - -! --- first pick a random number for bottom/top layer. -! then walk up the column: (aer's code) -! if layer below is cloudy, use the same rand num in the layer below -! if layer below is clear, use a new random number - -! --- from bottom up - do k = 2, nlay - k1 = k - 1 - tem1 = f_one - cldf(k1) - - do n = 1, ngptsw - if ( cdfunc(k1,n) > tem1 ) then - cdfunc(k,n) = cdfunc(k1,n) - else - cdfunc(k,n) = cdfunc(k,n) * tem1 - endif - enddo - enddo - -! --- then walk down the column: (if use original author's method) -! if layer above is cloudy, use the same rand num in the layer above -! if layer above is clear, use a new random number - -! --- from top down -! do k = nlay-1, 1, -1 -! k1 = k + 1 -! tem1 = f_one - cldf(k1) - -! do n = 1, ngptsw -! if ( cdfunc(k1,n) > tem1 ) then -! cdfunc(k,n) = cdfunc(k1,n) -! else -! cdfunc(k,n) = cdfunc(k,n) * tem1 -! endif -! enddo -! enddo - - case( 2 ) ! maximum overlap, pick same random numebr at every level - - call random_number & -! --- inputs: ( none ) -! --- outputs: - & ( rand1d, stat ) - - do n = 1, ngptsw - tem1 = rand1d(n) - - do k = 1, nlay - cdfunc(k,n) = tem1 - enddo - enddo - - case( 3 ) ! decorrelation length overlap - -! --- compute overlapping factors based on layer midpoint distances -! and decorrelation depths - - do k = nlay, 2, -1 - fac_lcf(k) = exp( -0.5 * (dz(k)+dz(k-1)) / de_lgth ) - enddo - -! --- setup 2 sets of random numbers - - call random_number ( rand2d, stat ) - - k1 = 0 - do n = 1, ngptsw - do k = 1, nlay - k1 = k1 + 1 - cdfunc(k,n) = rand2d(k1) - enddo - enddo - - call random_number ( rand2d, stat ) - - k1 = 0 - do n = 1, ngptsw - do k = 1, nlay - k1 = k1 + 1 - cdfun2(k,n) = rand2d(k1) - enddo - enddo - -! --- then working from the top down: -! if a random number (from an independent set -cdfun2) is smaller then the -! scale factor: use the upper layer's number, otherwise use a new random -! number (keep the original assigned one). - - do n = 1, ngptsw - do k = nlay-1, 1, -1 - k1 = k + 1 - if ( cdfun2(k,n) <= fac_lcf(k1) ) then - cdfunc(k,n) = cdfunc(k1,n) - endif - enddo - enddo - - end select - -!> -# Generate subcolumns for homogeneous clouds. - - do k = 1, nlay - tem1 = f_one - cldf(k) - - do n = 1, ngptsw - lcloudy(k,n) = cdfunc(k,n) >= tem1 - enddo - enddo - - return -! .................................. - end subroutine mcica_subcol -!> @} -! ---------------------------------- - -!>\ingroup module_radsw_main -!> This subroutine computes various coefficients needed in radiative -!! transfer calculation. -!!\param pavel layer pressure (mb) -!!\param tavel layer temperature (k) -!!\param h2ovmr layer w.v. volumn mixing ratio (kg/kg) -!!\param nlay total number of vertical layers -!!\param nlp1 total number of vertical levels -!!\param laytrop tropopause layer index (unitless) -!!\param jp indices of lower reference pressure -!!\param jt,jt1 indices of lower reference temperatures at -!! levels of jp and jp+1 -!!\param fac00,fac01,fac10,fac11 factors mltiply the reference ks,i,j=0/1 for -!! lower/higher of the 2 appropriate temperature -!! and altitudes. -!!\param selffac scale factor for w. v. self-continuum equals -!! (w.v. density)/(atmospheric density at 296k -!! and 1013 mb) -!!\param selffrac factor for temperature interpolation of -!! reference w.v. self-continuum data -!!\param indself index of lower ref temp for selffac -!!\param forfac scale factor for w. v. foreign-continuum -!!\param forfrac factor for temperature interpolation of -!! reference w.v. foreign-continuum data -!!\param indfor index of lower ref temp for forfac -!>\section setcoef_gen_rw setcoef General Algorithm -!! @{ -! ---------------------------------- - subroutine setcoef & - & ( pavel,tavel,h2ovmr, nlay,nlp1, & ! --- inputs - & laytrop,jp,jt,jt1,fac00,fac01,fac10,fac11, & ! --- outputs - & selffac,selffrac,indself,forfac,forfrac,indfor & - & ) - -! =================== program usage description =================== ! -! ! -! purpose: compute various coefficients needed in radiative transfer ! -! calculations. ! -! ! -! subprograms called: none ! -! ! -! ==================== defination of variables ==================== ! -! ! -! inputs: -size- ! -! pavel - real, layer pressures (mb) nlay ! -! tavel - real, layer temperatures (k) nlay ! -! h2ovmr - real, layer w.v. volum mixing ratio (kg/kg) nlay ! -! nlay/nlp1 - integer, total number of vertical layers, levels 1 ! -! ! -! outputs: ! -! laytrop - integer, tropopause layer index (unitless) 1 ! -! jp - real, indices of lower reference pressure nlay ! -! jt, jt1 - real, indices of lower reference temperatures nlay ! -! at levels of jp and jp+1 ! -! facij - real, factors multiply the reference ks, nlay ! -! i,j=0/1 for lower/higher of the 2 appropriate ! -! temperatures and altitudes. ! -! selffac - real, scale factor for w. v. self-continuum nlay ! -! equals (w. v. density)/(atmospheric density ! -! at 296k and 1013 mb) ! -! selffrac - real, factor for temperature interpolation of nlay ! -! reference w. v. self-continuum data ! -! indself - integer, index of lower ref temp for selffac nlay ! -! forfac - real, scale factor for w. v. foreign-continuum nlay ! -! forfrac - real, factor for temperature interpolation of nlay ! -! reference w.v. foreign-continuum data ! -! indfor - integer, index of lower ref temp for forfac nlay ! -! ! -! ====================== end of definitions =================== ! - -! --- inputs: - integer, intent(in) :: nlay, nlp1 - - real (kind=kind_phys), dimension(:), intent(in) :: pavel, tavel, & - & h2ovmr - -! --- outputs: - integer, dimension(nlay), intent(out) :: indself, indfor, & - & jp, jt, jt1 - integer, intent(out) :: laytrop - - real (kind=kind_phys), dimension(nlay), intent(out) :: fac00, & - & fac01, fac10, fac11, selffac, selffrac, forfac, forfrac - -! --- locals: - real (kind=kind_phys) :: plog, fp, fp1, ft, ft1, tem1, tem2 - - integer :: i, k, jp1 -! -!===> ... begin here -! - laytrop= nlay - - do k = 1, nlay - - forfac(k) = pavel(k)*stpfac / (tavel(k)*(f_one + h2ovmr(k))) - -!> -# Find the two reference pressures on either side of the -!! layer pressure. store them in jp and jp1. store in fp the -!! fraction of the difference (in ln(pressure)) between these -!! two values that the layer pressure lies. - - plog = log(pavel(k)) - jp(k) = max(1, min(58, int(36.0 - 5.0*(plog+0.04)) )) - jp1 = jp(k) + 1 - fp = 5.0 * (preflog(jp(k)) - plog) - -!> -# Determine, for each reference pressure (jp and jp1), which -!! reference temperature (these are different for each reference -!! pressure) is nearest the layer temperature but does not exceed it. -!! store these indices in jt and jt1, resp. store in ft (resp. ft1) -!! the fraction of the way between jt (jt1) and the next highest -!! reference temperature that the layer temperature falls. - - tem1 = (tavel(k) - tref(jp(k))) / 15.0 - tem2 = (tavel(k) - tref(jp1 )) / 15.0 - jt (k) = max(1, min(4, int(3.0 + tem1) )) - jt1(k) = max(1, min(4, int(3.0 + tem2) )) - ft = tem1 - float(jt (k) - 3) - ft1 = tem2 - float(jt1(k) - 3) - -!> -# We have now isolated the layer ln pressure and temperature, -!! between two reference pressures and two reference temperatures -!! (for each reference pressure). we multiply the pressure -!! fraction fp with the appropriate temperature fractions to get -!! the factors that will be needed for the interpolation that yields -!! the optical depths (performed in routines taugbn for band n). - - fp1 = f_one - fp - fac10(k) = fp1 * ft - fac00(k) = fp1 * (f_one - ft) - fac11(k) = fp * ft1 - fac01(k) = fp * (f_one - ft1) - -!> -# If the pressure is less than ~100mb, perform a different -!! set of species interpolations. - - if ( plog > 4.56 ) then - - laytrop = k - -!> -# Set up factors needed to separately include the water vapor -!! foreign-continuum in the calculation of absorption coefficient. - - tem1 = (332.0 - tavel(k)) / 36.0 - indfor (k) = min(2, max(1, int(tem1))) - forfrac(k) = tem1 - float(indfor(k)) - -!> -# Set up factors needed to separately include the water vapor -!! self-continuum in the calculation of absorption coefficient. - - tem2 = (tavel(k) - 188.0) / 7.2 - indself (k) = min(9, max(1, int(tem2)-7)) - selffrac(k) = tem2 - float(indself(k) + 7) - selffac (k) = h2ovmr(k) * forfac(k) - - else - -! --- ... set up factors needed to separately include the water vapor -! foreign-continuum in the calculation of absorption coefficient. - - tem1 = (tavel(k) - 188.0) / 36.0 - indfor (k) = 3 - forfrac(k) = tem1 - f_one - - indself (k) = 0 - selffrac(k) = f_zero - selffac (k) = f_zero - - endif - - enddo ! end_do_k_loop - - return -! .................................. - end subroutine setcoef -!! @} -! ---------------------------------- - -!>\ingroup module_radsw_main -!> This subroutine computes the shortwave radiative fluxes using -!! two-stream method. -!!\param ssolar incoming solar flux at top -!!\param cosz cosine solar zenith angle -!!\param sntz secant solar zenith angle -!!\param albbm surface albedo for direct beam radiation -!!\param albdf surface albedo for diffused radiation -!!\param sfluxzen spectral distribution of incoming solar flux -!!\param cldfrc layer cloud fraction -!!\param cf1 >0: cloudy sky, otherwise: clear sky -!!\param cf0 =1-cf1 -!!\param taug spectral optical depth for gases -!!\param taur optical depth for rayleigh scattering -!!\param tauae aerosols optical depth -!!\param ssaae aerosols single scattering albedo -!!\param asyae aerosols asymmetry factor -!!\param taucw weighted cloud optical depth -!!\param ssacw weighted cloud single scat albedo -!!\param asycw weighted cloud asymmetry factor -!!\param nlay,nlp1 number of layers/levels -!!\param fxupc tot sky upward flux -!!\param fxdnc tot sky downward flux -!!\param fxup0 clr sky upward flux -!!\param fxdn0 clr sky downward flux -!!\param ftoauc tot sky toa upwd flux -!!\param ftoau0 clr sky toa upwd flux -!!\param ftoadc toa downward (incoming) solar flux -!!\param fsfcuc tot sky sfc upwd flux -!!\param fsfcu0 clr sky sfc upwd flux -!!\param fsfcdc tot sky sfc dnwd flux -!!\param fsfcd0 clr sky sfc dnwd flux -!!\param sfbmc tot sky sfc dnwd beam flux (nir/uv+vis) -!!\param sfdfc tot sky sfc dnwd diff flux (nir/uv+vis) -!!\param sfbm0 clr sky sfc dnwd beam flux (nir/uv+vis) -!!\param sfdf0 clr sky sfc dnwd diff flux (nir/uv+vis) -!!\param suvbfc tot sky sfc dnwd uv-b flux -!!\param suvbf0 clr sky sfc dnwd uv-b flux -!>\section General_spcvrtc spcvrtc General Algorithm -!! @{ -!----------------------------------- - subroutine spcvrtc & - & ( ssolar,cosz,sntz,albbm,albdf,sfluxzen,cldfrc, & ! --- inputs - & cf1,cf0,taug,taur,tauae,ssaae,asyae,taucw,ssacw,asycw, & - & nlay, nlp1, & - & fxupc,fxdnc,fxup0,fxdn0, & ! --- outputs - & ftoauc,ftoau0,ftoadc,fsfcuc,fsfcu0,fsfcdc,fsfcd0, & - & sfbmc,sfdfc,sfbm0,sfdf0,suvbfc,suvbf0 & - & ) - -! =================== program usage description =================== ! -! ! -! purpose: computes the shortwave radiative fluxes using two-stream ! -! method ! -! ! -! subprograms called: vrtqdr ! -! ! -! ==================== defination of variables ==================== ! -! ! -! inputs: size ! -! ssolar - real, incoming solar flux at top 1 ! -! cosz - real, cosine solar zenith angle 1 ! -! sntz - real, secant solar zenith angle 1 ! -! albbm - real, surface albedo for direct beam radiation 2 ! -! albdf - real, surface albedo for diffused radiation 2 ! -! sfluxzen- real, spectral distribution of incoming solar flux ngptsw! -! cldfrc - real, layer cloud fraction nlay ! -! cf1 - real, >0: cloudy sky, otherwise: clear sky 1 ! -! cf0 - real, =1-cf1 1 ! -! taug - real, spectral optical depth for gases nlay*ngptsw! -! taur - real, optical depth for rayleigh scattering nlay*ngptsw! -! tauae - real, aerosols optical depth nlay*nbdsw ! -! ssaae - real, aerosols single scattering albedo nlay*nbdsw ! -! asyae - real, aerosols asymmetry factor nlay*nbdsw ! -! taucw - real, weighted cloud optical depth nlay*nbdsw ! -! ssacw - real, weighted cloud single scat albedo nlay*nbdsw ! -! asycw - real, weighted cloud asymmetry factor nlay*nbdsw ! -! nlay,nlp1 - integer, number of layers/levels 1 ! -! ! -! output variables: ! -! fxupc - real, tot sky upward flux nlp1*nbdsw ! -! fxdnc - real, tot sky downward flux nlp1*nbdsw ! -! fxup0 - real, clr sky upward flux nlp1*nbdsw ! -! fxdn0 - real, clr sky downward flux nlp1*nbdsw ! -! ftoauc - real, tot sky toa upwd flux 1 ! -! ftoau0 - real, clr sky toa upwd flux 1 ! -! ftoadc - real, toa downward (incoming) solar flux 1 ! -! fsfcuc - real, tot sky sfc upwd flux 1 ! -! fsfcu0 - real, clr sky sfc upwd flux 1 ! -! fsfcdc - real, tot sky sfc dnwd flux 1 ! -! fsfcd0 - real, clr sky sfc dnwd flux 1 ! -! sfbmc - real, tot sky sfc dnwd beam flux (nir/uv+vis) 2 ! -! sfdfc - real, tot sky sfc dnwd diff flux (nir/uv+vis) 2 ! -! sfbm0 - real, clr sky sfc dnwd beam flux (nir/uv+vis) 2 ! -! sfdf0 - real, clr sky sfc dnwd diff flux (nir/uv+vis) 2 ! -! suvbfc - real, tot sky sfc dnwd uv-b flux 1 ! -! suvbf0 - real, clr sky sfc dnwd uv-b flux 1 ! -! ! -! internal variables: ! -! zrefb - real, direct beam reflectivity for clear/cloudy nlp1 ! -! zrefd - real, diffuse reflectivity for clear/cloudy nlp1 ! -! ztrab - real, direct beam transmissivity for clear/cloudy nlp1 ! -! ztrad - real, diffuse transmissivity for clear/cloudy nlp1 ! -! zldbt - real, layer beam transmittance for clear/cloudy nlp1 ! -! ztdbt - real, lev total beam transmittance for clr/cld nlp1 ! -! ! -! control parameters in module "physparam" ! -! iswmode - control flag for 2-stream transfer schemes ! -! = 1 delta-eddington (joseph et al., 1976) ! -! = 2 pifm (zdunkowski et al., 1980) ! -! = 3 discrete ordinates (liou, 1973) ! -! ! -! ******************************************************************* ! -! original code description ! -! ! -! method: ! -! ------- ! -! standard delta-eddington, p.i.f.m., or d.o.m. layer calculations. ! -! kmodts = 1 eddington (joseph et al., 1976) ! -! = 2 pifm (zdunkowski et al., 1980) ! -! = 3 discrete ordinates (liou, 1973) ! -! ! -! modifications: ! -! -------------- ! -! original: h. barker ! -! revision: merge with rrtmg_sw: j.-j.morcrette, ecmwf, feb 2003 ! -! revision: add adjustment for earth/sun distance:mjiacono,aer,oct2003! -! revision: bug fix for use of palbp and palbd: mjiacono, aer, nov2003! -! revision: bug fix to apply delta scaling to clear sky: aer, dec2004 ! -! revision: code modified so that delta scaling is not done in cloudy ! -! profiles if routine cldprop is used; delta scaling can be ! -! applied by swithcing code below if cldprop is not used to ! -! get cloud properties. aer, jan 2005 ! -! revision: uniform formatting for rrtmg: mjiacono, aer, jul 2006 ! -! revision: use exponential lookup table for transmittance: mjiacono, ! -! aer, aug 2007 ! -! ! -! ******************************************************************* ! -! ====================== end of description block ================= ! - -! --- constant parameters: - real (kind=kind_phys), parameter :: zcrit = 0.9999995 ! thresold for conservative scattering - real (kind=kind_phys), parameter :: zsr3 = sqrt(3.0) - real (kind=kind_phys), parameter :: od_lo = 0.06 - real (kind=kind_phys), parameter :: eps1 = 1.0e-8 - -! --- inputs: - integer, intent(in) :: nlay, nlp1 - - real (kind=kind_phys), dimension(nlay,ngptsw), intent(in) :: & - & taug, taur - real (kind=kind_phys), dimension(nlay,nbdsw), intent(in) :: & - & taucw, ssacw, asycw, tauae, ssaae, asyae - - real (kind=kind_phys), dimension(ngptsw), intent(in) :: sfluxzen - real (kind=kind_phys), dimension(nlay), intent(in) :: cldfrc - - real (kind=kind_phys), dimension(2), intent(in) :: albbm, albdf - - real (kind=kind_phys), intent(in) :: cosz, sntz, cf1, cf0, ssolar - -! --- outputs: - real (kind=kind_phys), dimension(nlp1,nbdsw), intent(out) :: & - & fxupc, fxdnc, fxup0, fxdn0 - - real (kind=kind_phys), dimension(2), intent(out) :: sfbmc, sfdfc, & - & sfbm0, sfdf0 - - real (kind=kind_phys), intent(out) :: suvbfc, suvbf0, ftoadc, & - & ftoauc, ftoau0, fsfcuc, fsfcu0, fsfcdc, fsfcd0 - -! --- locals: - real (kind=kind_phys), dimension(nlay) :: ztaus, zssas, zasys, & - & zldbt0 - - real (kind=kind_phys), dimension(nlp1) :: zrefb, zrefd, ztrab, & - & ztrad, ztdbt, zldbt, zfu, zfd - - real (kind=kind_phys) :: ztau1, zssa1, zasy1, ztau0, zssa0, & - & zasy0, zasy3, zssaw, zasyw, zgam1, zgam2, zgam3, zgam4, & - & zc0, zc1, za1, za2, zb1, zb2, zrk, zrk2, zrp, zrp1, zrm1, & - & zrpp, zrkg1, zrkg3, zrkg4, zexp1, zexm1, zexp2, zexm2, & - & zexp3, zexp4, zden1, ze1r45, ftind, zsolar, zrefb1, & - & zrefd1, ztrab1, ztrad1, ztdbt0, zr1, zr2, zr3, zr4, zr5, & - & zt1, zt2, zt3, zf1, zf2, zrpp1 - - integer :: ib, ibd, jb, jg, k, kp, itind -! -!===> ... begin here - -!> -# Initialize output fluxes. - do ib = 1, nbdsw - do k = 1, nlp1 - fxdnc(k,ib) = f_zero - fxupc(k,ib) = f_zero - fxdn0(k,ib) = f_zero - fxup0(k,ib) = f_zero - enddo - enddo - - ftoadc = f_zero - ftoauc = f_zero - ftoau0 = f_zero - fsfcuc = f_zero - fsfcu0 = f_zero - fsfcdc = f_zero - fsfcd0 = f_zero - -!! --- ... uv-b surface downward fluxes - suvbfc = f_zero - suvbf0 = f_zero - -!! --- ... output surface flux components - sfbmc(1) = f_zero - sfbmc(2) = f_zero - sfdfc(1) = f_zero - sfdfc(2) = f_zero - sfbm0(1) = f_zero - sfbm0(2) = f_zero - sfdf0(1) = f_zero - sfdf0(2) = f_zero - -!> -# Loop over all g-points in each band. - - lab_do_jg : do jg = 1, ngptsw - - jb = NGB(jg) - ib = jb + 1 - nblow - ibd = idxsfc(jb) - - zsolar = ssolar * sfluxzen(jg) - -!> -# Set up toa direct beam and surface values (beam and diff). - - ztdbt(nlp1) = f_one - ztdbt0 = f_one - - zldbt(1) = f_zero - if (ibd /= 0) then - zrefb(1) = albbm(ibd) - zrefd(1) = albdf(ibd) - else - zrefb(1) = 0.5 * (albbm(1) + albbm(2)) - zrefd(1) = 0.5 * (albdf(1) + albdf(2)) - endif - ztrab(1) = f_zero - ztrad(1) = f_zero - -!> -# Compute clear-sky optical parameters, layer reflectance and -!! transmittance. -! - Set up toa direct beam and surface values (beam and diff). -! - Delta scaling for clear-sky condition. -! - General two-stream expressions for physparam::iswmode . -! - Compute homogeneous reflectance and transmittance for both -! conservative and non-conservative scattering. -! - Pre-delta-scaling clear and cloudy direct beam transmittance. -! - Call swflux() to compute the upward and downward radiation -! fluxes. - - do k = nlay, 1, -1 - kp = k + 1 - - ztau0 = max( ftiny, taur(k,jg)+taug(k,jg)+tauae(k,ib) ) - zssa0 = taur(k,jg) + tauae(k,ib)*ssaae(k,ib) - zasy0 = asyae(k,ib)*ssaae(k,ib)*tauae(k,ib) - zssaw = min( oneminus, zssa0 / ztau0 ) - zasyw = zasy0 / max( ftiny, zssa0 ) - -!> - Saving clear-sky quantities for later total-sky usage. - ztaus(k) = ztau0 - zssas(k) = zssa0 - zasys(k) = zasy0 - -!> - Delta scaling for clear-sky condition. - za1 = zasyw * zasyw - za2 = zssaw * za1 - - ztau1 = (f_one - za2) * ztau0 - zssa1 = (zssaw - za2) / (f_one - za2) -!org zasy1 = (zasyw - za1) / (f_one - za1) ! this line is replaced by the next - zasy1 = zasyw / (f_one + zasyw) ! to reduce truncation error - zasy3 = 0.75 * zasy1 - -!> - Perform general two-stream expressions: -!!\n control parameters in module "physparam" -!!\n iswmode - control flag for 2-stream transfer schemes -!!\n = 1 delta-eddington (joseph et al., 1976) -!!\n = 2 pifm (zdunkowski et al., 1980) -!!\n = 3 discrete ordinates (liou, 1973) - if ( iswmode == 1 ) then - zgam1 = 1.75 - zssa1 * (f_one + zasy3) - zgam2 =-0.25 + zssa1 * (f_one - zasy3) - zgam3 = 0.5 - zasy3 * cosz - elseif ( iswmode == 2 ) then ! pifm - zgam1 = 2.0 - zssa1 * (1.25 + zasy3) - zgam2 = 0.75* zssa1 * (f_one- zasy1) - zgam3 = 0.5 - zasy3 * cosz - elseif ( iswmode == 3 ) then ! discrete ordinates - zgam1 = zsr3 * (2.0 - zssa1 * (1.0 + zasy1)) * 0.5 - zgam2 = zsr3 * zssa1 * (1.0 - zasy1) * 0.5 - zgam3 = (1.0 - zsr3 * zasy1 * cosz) * 0.5 - endif - zgam4 = f_one - zgam3 - -!> - Compute homogeneous reflectance and transmittance for both conservative -!! scattering and non-conservative scattering. - - if ( zssaw >= zcrit ) then ! for conservative scattering - za1 = zgam1 * cosz - zgam3 - za2 = zgam1 * ztau1 - -! --- ... use exponential lookup table for transmittance, or expansion -! of exponential for low optical depth - - zb1 = min ( ztau1*sntz , 500.0 ) - if ( zb1 <= od_lo ) then - zb2 = f_one - zb1 + 0.5*zb1*zb1 - else - ftind = zb1 / (bpade + zb1) - itind = ftind*NTBMX + 0.5 - zb2 = exp_tbl(itind) - endif - -! ... collimated beam - zrefb(kp) = max(f_zero, min(f_one, & - & (za2 - za1*(f_one - zb2))/(f_one + za2) )) - ztrab(kp) = max(f_zero, min(f_one, f_one-zrefb(kp) )) - -! ... isotropic incidence - zrefd(kp) = max(f_zero, min(f_one, za2/(f_one + za2) )) - ztrad(kp) = max(f_zero, min(f_one, f_one-zrefd(kp) )) - - else ! for non-conservative scattering - za1 = zgam1*zgam4 + zgam2*zgam3 - za2 = zgam1*zgam3 + zgam2*zgam4 - zrk = sqrt ( (zgam1 - zgam2) * (zgam1 + zgam2) ) - zrk2= 2.0 * zrk - - zrp = zrk * cosz - zrp1 = f_one + zrp - zrm1 = f_one - zrp - zrpp1= f_one - zrp*zrp - zrpp = sign( max(flimit, abs(zrpp1)), zrpp1 ) ! avoid numerical singularity - zrkg1= zrk + zgam1 - zrkg3= zrk * zgam3 - zrkg4= zrk * zgam4 - - zr1 = zrm1 * (za2 + zrkg3) - zr2 = zrp1 * (za2 - zrkg3) - zr3 = zrk2 * (zgam3 - za2*cosz) - zr4 = zrpp * zrkg1 - zr5 = zrpp * (zrk - zgam1) - - zt1 = zrp1 * (za1 + zrkg4) - zt2 = zrm1 * (za1 - zrkg4) - zt3 = zrk2 * (zgam4 + za1*cosz) - -! --- ... use exponential lookup table for transmittance, or expansion -! of exponential for low optical depth - - zb1 = min ( zrk*ztau1, 500.0 ) - if ( zb1 <= od_lo ) then - zexm1 = f_one - zb1 + 0.5*zb1*zb1 - else - ftind = zb1 / (bpade + zb1) - itind = ftind*NTBMX + 0.5 - zexm1 = exp_tbl(itind) - endif - zexp1 = f_one / zexm1 - - zb2 = min ( sntz*ztau1, 500.0 ) - if ( zb2 <= od_lo ) then - zexm2 = f_one - zb2 + 0.5*zb2*zb2 - else - ftind = zb2 / (bpade + zb2) - itind = ftind*NTBMX + 0.5 - zexm2 = exp_tbl(itind) - endif - zexp2 = f_one / zexm2 - ze1r45 = zr4*zexp1 + zr5*zexm1 - -! ... collimated beam - if (ze1r45>=-eps1 .and. ze1r45<=eps1) then - zrefb(kp) = eps1 - ztrab(kp) = zexm2 - else - zden1 = zssa1 / ze1r45 - zrefb(kp) = max(f_zero, min(f_one, & - & (zr1*zexp1 - zr2*zexm1 - zr3*zexm2)*zden1 )) - ztrab(kp) = max(f_zero, min(f_one, zexm2*(f_one & - & - (zt1*zexp1 - zt2*zexm1 - zt3*zexp2)*zden1) )) - endif - -! ... diffuse beam - zden1 = zr4 / (ze1r45 * zrkg1) - zrefd(kp) = max(f_zero, min(f_one, & - & zgam2*(zexp1 - zexm1)*zden1 )) - ztrad(kp) = max(f_zero, min(f_one, zrk2*zden1 )) - endif ! end if_zssaw_block - -!> - Calculate direct beam transmittance. use exponential lookup table -!! for transmittance, or expansion of exponential for low optical depth. - - zr1 = ztau1 * sntz - if ( zr1 <= od_lo ) then - zexp3 = f_one - zr1 + 0.5*zr1*zr1 - else - ftind = zr1 / (bpade + zr1) - itind = max(0, min(NTBMX, int(0.5+NTBMX*ftind) )) - zexp3 = exp_tbl(itind) - endif - - ztdbt(k) = zexp3 * ztdbt(kp) - zldbt(kp) = zexp3 - -!> - Calculate pre-delta-scaling clear and cloudy direct beam transmittance. -! (must use 'orig', unscaled cloud optical depth) - - zr1 = ztau0 * sntz - if ( zr1 <= od_lo ) then - zexp4 = f_one - zr1 + 0.5*zr1*zr1 - else - ftind = zr1 / (bpade + zr1) - itind = max(0, min(NTBMX, int(0.5+NTBMX*ftind) )) - zexp4 = exp_tbl(itind) - endif - - zldbt0(k) = zexp4 - ztdbt0 = zexp4 * ztdbt0 - enddo ! end do_k_loop - -!> -# Call vrtqdr(), to compute the upward and downward radiation fluxes. - call vrtqdr & -! --- inputs: - & ( zrefb,zrefd,ztrab,ztrad,zldbt,ztdbt, & - & nlay, nlp1, & -! --- outputs: - & zfu, zfd & - & ) - -!> -# Compute upward and downward fluxes at levels. - do k = 1, nlp1 - fxup0(k,ib) = fxup0(k,ib) + zsolar*zfu(k) - fxdn0(k,ib) = fxdn0(k,ib) + zsolar*zfd(k) - enddo - -!> -# Compute surface downward beam/diffused flux components. - zb1 = zsolar*ztdbt0 - zb2 = zsolar*(zfd(1) - ztdbt0) - - if (ibd /= 0) then - sfbm0(ibd) = sfbm0(ibd) + zb1 - sfdf0(ibd) = sfdf0(ibd) + zb2 - else - zf1 = 0.5 * zb1 - zf2 = 0.5 * zb2 - sfbm0(1) = sfbm0(1) + zf1 - sfdf0(1) = sfdf0(1) + zf2 - sfbm0(2) = sfbm0(2) + zf1 - sfdf0(2) = sfdf0(2) + zf2 - endif -! sfbm0(ibd) = sfbm0(ibd) + zsolar*ztdbt0 -! sfdf0(ibd) = sfdf0(ibd) + zsolar*(zfd(1) - ztdbt0) - -!> -# Compute total sky optical parameters, layer reflectance and -!! transmittance. -! - Set up toa direct beam and surface values (beam and diff) -! - Delta scaling for total-sky condition -! - General two-stream expressions for physparam::iswmode -! - Compute homogeneous reflectance and transmittance for -! conservative scattering and non-conservative scattering -! - Pre-delta-scaling clear and cloudy direct beam transmittance -! - Call swflux() to compute the upward and downward radiation fluxes - - if ( cf1 > eps ) then - -!> - Set up toa direct beam and surface values (beam and diff). - ztdbt0 = f_one - zldbt(1) = f_zero - - do k = nlay, 1, -1 - kp = k + 1 - zc0 = f_one - cldfrc(k) - zc1 = cldfrc(k) - if ( zc1 > ftiny ) then ! it is a cloudy-layer - - ztau0 = ztaus(k) + taucw(k,ib) - zssa0 = zssas(k) + ssacw(k,ib) - zasy0 = zasys(k) + asycw(k,ib) - zssaw = min(oneminus, zssa0 / ztau0) - zasyw = zasy0 / max(ftiny, zssa0) - -!> - Perform delta scaling for total-sky condition. - za1 = zasyw * zasyw - za2 = zssaw * za1 - - ztau1 = (f_one - za2) * ztau0 - zssa1 = (zssaw - za2) / (f_one - za2) -!org zasy1 = (zasyw - za1) / (f_one - za1) - zasy1 = zasyw / (f_one + zasyw) - zasy3 = 0.75 * zasy1 - -!> - Perform general two-stream expressions: -!!\n control parameters in module "physparam" -!!\n iswmode - control flag for 2-stream transfer schemes -!!\n = 1 delta-eddington (joseph et al., 1976) -!!\n = 2 pifm (zdunkowski et al., 1980) -!!\n = 3 discrete ordinates (liou, 1973) - - if ( iswmode == 1 ) then - zgam1 = 1.75 - zssa1 * (f_one + zasy3) - zgam2 =-0.25 + zssa1 * (f_one - zasy3) - zgam3 = 0.5 - zasy3 * cosz - elseif ( iswmode == 2 ) then ! pifm - zgam1 = 2.0 - zssa1 * (1.25 + zasy3) - zgam2 = 0.75* zssa1 * (f_one- zasy1) - zgam3 = 0.5 - zasy3 * cosz - elseif ( iswmode == 3 ) then ! discrete ordinates - zgam1 = zsr3 * (2.0 - zssa1 * (1.0 + zasy1)) * 0.5 - zgam2 = zsr3 * zssa1 * (1.0 - zasy1) * 0.5 - zgam3 = (1.0 - zsr3 * zasy1 * cosz) * 0.5 - endif - zgam4 = f_one - zgam3 - - zrefb1 = zrefb(kp) - zrefd1 = zrefd(kp) - ztrab1 = ztrab(kp) - ztrad1 = ztrad(kp) - -!> - Compute homogeneous reflectance and transmittance for both conservative -!! and non-conservative scattering. - - if ( zssaw >= zcrit ) then ! for conservative scattering - za1 = zgam1 * cosz - zgam3 - za2 = zgam1 * ztau1 - -! --- ... use exponential lookup table for transmittance, or expansion -! of exponential for low optical depth - - zb1 = min ( ztau1*sntz , 500.0 ) - if ( zb1 <= od_lo ) then - zb2 = f_one - zb1 + 0.5*zb1*zb1 - else - ftind = zb1 / (bpade + zb1) - itind = ftind*NTBMX + 0.5 - zb2 = exp_tbl(itind) - endif - -! ... collimated beam - zrefb(kp) = max(f_zero, min(f_one, & - & (za2 - za1*(f_one - zb2))/(f_one + za2) )) - ztrab(kp) = max(f_zero, min(f_one, f_one-zrefb(kp))) - -! ... isotropic incidence - zrefd(kp) = max(f_zero, min(f_one, za2 / (f_one+za2) )) - ztrad(kp) = max(f_zero, min(f_one, f_one - zrefd(kp) )) - - else ! for non-conservative scattering - za1 = zgam1*zgam4 + zgam2*zgam3 - za2 = zgam1*zgam3 + zgam2*zgam4 - zrk = sqrt ( (zgam1 - zgam2) * (zgam1 + zgam2) ) - zrk2= 2.0 * zrk - - zrp = zrk * cosz - zrp1 = f_one + zrp - zrm1 = f_one - zrp - zrpp1= f_one - zrp*zrp - zrpp = sign( max(flimit, abs(zrpp1)), zrpp1 ) ! avoid numerical singularity - zrkg1= zrk + zgam1 - zrkg3= zrk * zgam3 - zrkg4= zrk * zgam4 - - zr1 = zrm1 * (za2 + zrkg3) - zr2 = zrp1 * (za2 - zrkg3) - zr3 = zrk2 * (zgam3 - za2*cosz) - zr4 = zrpp * zrkg1 - zr5 = zrpp * (zrk - zgam1) - - zt1 = zrp1 * (za1 + zrkg4) - zt2 = zrm1 * (za1 - zrkg4) - zt3 = zrk2 * (zgam4 + za1*cosz) - -! --- ... use exponential lookup table for transmittance, or expansion -! of exponential for low optical depth - - zb1 = min ( zrk*ztau1, 500.0 ) - if ( zb1 <= od_lo ) then - zexm1 = f_one - zb1 + 0.5*zb1*zb1 - else - ftind = zb1 / (bpade + zb1) - itind = ftind*NTBMX + 0.5 - zexm1 = exp_tbl(itind) - endif - zexp1 = f_one / zexm1 - - zb2 = min ( ztau1*sntz, 500.0 ) - if ( zb2 <= od_lo ) then - zexm2 = f_one - zb2 + 0.5*zb2*zb2 - else - ftind = zb2 / (bpade + zb2) - itind = ftind*NTBMX + 0.5 - zexm2 = exp_tbl(itind) - endif - zexp2 = f_one / zexm2 - ze1r45 = zr4*zexp1 + zr5*zexm1 - -! ... collimated beam - if ( ze1r45>=-eps1 .and. ze1r45<=eps1 ) then - zrefb(kp) = eps1 - ztrab(kp) = zexm2 - else - zden1 = zssa1 / ze1r45 - zrefb(kp) = max(f_zero, min(f_one, & - & (zr1*zexp1-zr2*zexm1-zr3*zexm2)*zden1 )) - ztrab(kp) = max(f_zero, min(f_one, zexm2*(f_one - & - & (zt1*zexp1-zt2*zexm1-zt3*zexp2)*zden1) )) - endif - -! ... diffuse beam - zden1 = zr4 / (ze1r45 * zrkg1) - zrefd(kp) = max(f_zero, min(f_one, & - & zgam2*(zexp1 - zexm1)*zden1 )) - ztrad(kp) = max(f_zero, min(f_one, zrk2*zden1 )) - endif ! end if_zssaw_block - -! --- ... combine clear and cloudy contributions for total sky -! and calculate direct beam transmittances - - zrefb(kp) = zc0*zrefb1 + zc1*zrefb(kp) - zrefd(kp) = zc0*zrefd1 + zc1*zrefd(kp) - ztrab(kp) = zc0*ztrab1 + zc1*ztrab(kp) - ztrad(kp) = zc0*ztrad1 + zc1*ztrad(kp) - -! --- ... direct beam transmittance. use exponential lookup table -! for transmittance, or expansion of exponential for low -! optical depth - - zr1 = ztau1 * sntz - if ( zr1 <= od_lo ) then - zexp3 = f_one - zr1 + 0.5*zr1*zr1 - else - ftind = zr1 / (bpade + zr1) - itind = max(0, min(NTBMX, int(0.5+NTBMX*ftind) )) - zexp3 = exp_tbl(itind) - endif - - zldbt(kp) = zc0*zldbt(kp) + zc1*zexp3 - ztdbt(k) = zldbt(kp) * ztdbt(kp) - -!> - Calculate pre-delta-scaling clear and cloudy direct beam transmittance. -! (must use 'orig', unscaled cloud optical depth) - - zr1 = ztau0 * sntz - if ( zr1 <= od_lo ) then - zexp4 = f_one - zr1 + 0.5*zr1*zr1 - else - ftind = zr1 / (bpade + zr1) - itind = max(0, min(NTBMX, int(0.5+NTBMX*ftind) )) - zexp4 = exp_tbl(itind) - endif - - ztdbt0 = (zc0*zldbt0(k) + zc1*zexp4) * ztdbt0 - - else ! if_zc1_block --- it is a clear layer - -! --- ... direct beam transmittance - ztdbt(k) = zldbt(kp) * ztdbt(kp) - -! --- ... pre-delta-scaling clear and cloudy direct beam transmittance - ztdbt0 = zldbt0(k) * ztdbt0 - - endif ! end if_zc1_block - enddo ! end do_k_loop - -!> -# Call vrtqdr(), to compute the upward and downward radiation fluxes. - - call vrtqdr & -! --- inputs: - & ( zrefb,zrefd,ztrab,ztrad,zldbt,ztdbt, & - & nlay, nlp1, & -! --- outputs: - & zfu, zfd & - & ) - -!> -# Compute upward and downward fluxes at levels. - do k = 1, nlp1 - fxupc(k,ib) = fxupc(k,ib) + zsolar*zfu(k) - fxdnc(k,ib) = fxdnc(k,ib) + zsolar*zfd(k) - enddo - -!> -# Process and save outputs. -!! - surface downward beam/diffused flux components - zb1 = zsolar*ztdbt0 - zb2 = zsolar*(zfd(1) - ztdbt0) - - if (ibd /= 0) then - sfbmc(ibd) = sfbmc(ibd) + zb1 - sfdfc(ibd) = sfdfc(ibd) + zb2 - else - zf1 = 0.5 * zb1 - zf2 = 0.5 * zb2 - sfbmc(1) = sfbmc(1) + zf1 - sfdfc(1) = sfdfc(1) + zf2 - sfbmc(2) = sfbmc(2) + zf1 - sfdfc(2) = sfdfc(2) + zf2 - endif -! sfbmc(ibd) = sfbmc(ibd) + zsolar*ztdbt0 -! sfdfc(ibd) = sfdfc(ibd) + zsolar*(zfd(1) - ztdbt0) - - endif ! end if_cf1_block - - enddo lab_do_jg - -! --- ... end of g-point loop - - do ib = 1, nbdsw - ftoadc = ftoadc + fxdn0(nlp1,ib) - ftoau0 = ftoau0 + fxup0(nlp1,ib) - fsfcu0 = fsfcu0 + fxup0(1,ib) - fsfcd0 = fsfcd0 + fxdn0(1,ib) - enddo - -!> - uv-b surface downward flux - ibd = nuvb - nblow + 1 - suvbf0 = fxdn0(1,ibd) - - if ( cf1 <= eps ) then ! clear column, set total-sky=clear-sky fluxes - do ib = 1, nbdsw - do k = 1, nlp1 - fxupc(k,ib) = fxup0(k,ib) - fxdnc(k,ib) = fxdn0(k,ib) - enddo - enddo - - ftoauc = ftoau0 - fsfcuc = fsfcu0 - fsfcdc = fsfcd0 - -!> - surface downward beam/diffused flux components - sfbmc(1) = sfbm0(1) - sfdfc(1) = sfdf0(1) - sfbmc(2) = sfbm0(2) - sfdfc(2) = sfdf0(2) - -!> - uv-b surface downward flux - suvbfc = suvbf0 - else ! cloudy column, compute total-sky fluxes - do ib = 1, nbdsw - do k = 1, nlp1 - fxupc(k,ib) = cf1*fxupc(k,ib) + cf0*fxup0(k,ib) - fxdnc(k,ib) = cf1*fxdnc(k,ib) + cf0*fxdn0(k,ib) - enddo - enddo - - do ib = 1, nbdsw - ftoauc = ftoauc + fxupc(nlp1,ib) - fsfcuc = fsfcuc + fxupc(1,ib) - fsfcdc = fsfcdc + fxdnc(1,ib) - enddo - -!> - uv-b surface downward flux - suvbfc = fxdnc(1,ibd) - -!> - surface downward beam/diffused flux components - sfbmc(1) = cf1*sfbmc(1) + cf0*sfbm0(1) - sfbmc(2) = cf1*sfbmc(2) + cf0*sfbm0(2) - sfdfc(1) = cf1*sfdfc(1) + cf0*sfdf0(1) - sfdfc(2) = cf1*sfdfc(2) + cf0*sfdf0(2) - endif ! end if_cf1_block - - return -!................................... - end subroutine spcvrtc -!----------------------------------- -!> @} - -!>\ingroup module_radsw_main -!> This subroutine computes the shortwave radiative fluxes using -!! two-stream method of h. barder and mcica,the monte-carlo independent -!! column approximation, for the representation of sub-grid cloud -!! variability (i.e. cloud overlap). -!!\param ssolar incoming solar flux at top -!!\param cosz cosine solar zenith angle -!!\param sntz secant solar zenith angle -!!\param albbm surface albedo for direct beam radiation -!!\param albdf surface albedo for diffused radiation -!!\param sfluxzen spectral distribution of incoming solar flux -!!\param cldfmc layer cloud fraction for g-point -!!\param cf1 >0: cloudy sky, otherwise: clear sky -!!\param cf0 =1-cf1 -!!\param taug spectral optical depth for gases -!!\param taur optical depth for rayleigh scattering -!!\param tauae aerosols optical depth -!!\param ssaae aerosols single scattering albedo -!!\param asyae aerosols asymmetry factor -!!\param taucw weighted cloud optical depth -!!\param ssacw weighted cloud single scat albedo -!!\param asycw weighted cloud asymmetry factor -!!\param nlay,nlp1 number of layers/levels -!!\param fxupc tot sky upward flux -!!\param fxdnc tot sky downward flux -!!\param fxup0 clr sky upward flux -!!\param fxdn0 clr sky downward flux -!!\param ftoauc tot sky toa upwd flux -!!\param ftoau0 clr sky toa upwd flux -!!\param ftoadc toa downward (incoming) solar flux -!!\param fsfcuc tot sky sfc upwd flux -!!\param fsfcu0 clr sky sfc upwd flux -!!\param fsfcdc tot sky sfc dnwd flux -!!\param fsfcd0 clr sky sfc dnwd flux -!!\param sfbmc tot sky sfc dnwd beam flux (nir/uv+vis) -!!\param sfdfc tot sky sfc dnwd diff flux (nir/uv+vis) -!!\param sfbm0 clr sky sfc dnwd beam flux (nir/uv+vis) -!!\param sfdf0 clr sky sfc dnwd diff flux (nir/uv+vis) -!!\param suvbfc tot sky sfc dnwd uv-b flux -!!\param suvbf0 clr sky sfc dnwd uv-b flux -!>\section spcvrtm_gen spcvrtm General Algorithm -!! @{ -!----------------------------------- - subroutine spcvrtm & - & ( ssolar,cosz,sntz,albbm,albdf,sfluxzen,cldfmc, & ! --- inputs - & cf1,cf0,taug,taur,tauae,ssaae,asyae,taucw,ssacw,asycw, & - & nlay, nlp1, & - & fxupc,fxdnc,fxup0,fxdn0, & ! --- outputs - & ftoauc,ftoau0,ftoadc,fsfcuc,fsfcu0,fsfcdc,fsfcd0, & - & sfbmc,sfdfc,sfbm0,sfdf0,suvbfc,suvbf0 & - & ) - -! =================== program usage description =================== ! -! ! -! purpose: computes the shortwave radiative fluxes using two-stream ! -! method of h. barker and mcica, the monte-carlo independent! -! column approximation, for the representation of sub-grid ! -! cloud variability (i.e. cloud overlap). ! -! ! -! subprograms called: vrtqdr ! -! ! -! ==================== defination of variables ==================== ! -! ! -! inputs: size ! -! ssolar - real, incoming solar flux at top 1 ! -! cosz - real, cosine solar zenith angle 1 ! -! sntz - real, secant solar zenith angle 1 ! -! albbm - real, surface albedo for direct beam radiation 2 ! -! albdf - real, surface albedo for diffused radiation 2 ! -! sfluxzen- real, spectral distribution of incoming solar flux ngptsw! -! cldfmc - real, layer cloud fraction for g-point nlay*ngptsw! -! cf1 - real, >0: cloudy sky, otherwise: clear sky 1 ! -! cf0 - real, =1-cf1 1 ! -! taug - real, spectral optical depth for gases nlay*ngptsw! -! taur - real, optical depth for rayleigh scattering nlay*ngptsw! -! tauae - real, aerosols optical depth nlay*nbdsw ! -! ssaae - real, aerosols single scattering albedo nlay*nbdsw ! -! asyae - real, aerosols asymmetry factor nlay*nbdsw ! -! taucw - real, weighted cloud optical depth nlay*nbdsw ! -! ssacw - real, weighted cloud single scat albedo nlay*nbdsw ! -! asycw - real, weighted cloud asymmetry factor nlay*nbdsw ! -! nlay,nlp1 - integer, number of layers/levels 1 ! -! ! -! output variables: ! -! fxupc - real, tot sky upward flux nlp1*nbdsw ! -! fxdnc - real, tot sky downward flux nlp1*nbdsw ! -! fxup0 - real, clr sky upward flux nlp1*nbdsw ! -! fxdn0 - real, clr sky downward flux nlp1*nbdsw ! -! ftoauc - real, tot sky toa upwd flux 1 ! -! ftoau0 - real, clr sky toa upwd flux 1 ! -! ftoadc - real, toa downward (incoming) solar flux 1 ! -! fsfcuc - real, tot sky sfc upwd flux 1 ! -! fsfcu0 - real, clr sky sfc upwd flux 1 ! -! fsfcdc - real, tot sky sfc dnwd flux 1 ! -! fsfcd0 - real, clr sky sfc dnwd flux 1 ! -! sfbmc - real, tot sky sfc dnwd beam flux (nir/uv+vis) 2 ! -! sfdfc - real, tot sky sfc dnwd diff flux (nir/uv+vis) 2 ! -! sfbm0 - real, clr sky sfc dnwd beam flux (nir/uv+vis) 2 ! -! sfdf0 - real, clr sky sfc dnwd diff flux (nir/uv+vis) 2 ! -! suvbfc - real, tot sky sfc dnwd uv-b flux 1 ! -! suvbf0 - real, clr sky sfc dnwd uv-b flux 1 ! -! ! -! internal variables: ! -! zrefb - real, direct beam reflectivity for clear/cloudy nlp1 ! -! zrefd - real, diffuse reflectivity for clear/cloudy nlp1 ! -! ztrab - real, direct beam transmissivity for clear/cloudy nlp1 ! -! ztrad - real, diffuse transmissivity for clear/cloudy nlp1 ! -! zldbt - real, layer beam transmittance for clear/cloudy nlp1 ! -! ztdbt - real, lev total beam transmittance for clr/cld nlp1 ! -! ! -! control parameters in module "physparam" ! -! iswmode - control flag for 2-stream transfer schemes ! -! = 1 delta-eddington (joseph et al., 1976) ! -! = 2 pifm (zdunkowski et al., 1980) ! -! = 3 discrete ordinates (liou, 1973) ! -! ! -! ******************************************************************* ! -! original code description ! -! ! -! method: ! -! ------- ! -! standard delta-eddington, p.i.f.m., or d.o.m. layer calculations. ! -! kmodts = 1 eddington (joseph et al., 1976) ! -! = 2 pifm (zdunkowski et al., 1980) ! -! = 3 discrete ordinates (liou, 1973) ! -! ! -! modifications: ! -! -------------- ! -! original: h. barker ! -! revision: merge with rrtmg_sw: j.-j.morcrette, ecmwf, feb 2003 ! -! revision: add adjustment for earth/sun distance:mjiacono,aer,oct2003! -! revision: bug fix for use of palbp and palbd: mjiacono, aer, nov2003! -! revision: bug fix to apply delta scaling to clear sky: aer, dec2004 ! -! revision: code modified so that delta scaling is not done in cloudy ! -! profiles if routine cldprop is used; delta scaling can be ! -! applied by swithcing code below if cldprop is not used to ! -! get cloud properties. aer, jan 2005 ! -! revision: uniform formatting for rrtmg: mjiacono, aer, jul 2006 ! -! revision: use exponential lookup table for transmittance: mjiacono, ! -! aer, aug 2007 ! -! ! -! ******************************************************************* ! -! ====================== end of description block ================= ! - -! --- constant parameters: - real (kind=kind_phys), parameter :: zcrit = 0.9999995 ! thresold for conservative scattering - real (kind=kind_phys), parameter :: zsr3 = sqrt(3.0) - real (kind=kind_phys), parameter :: od_lo = 0.06 - real (kind=kind_phys), parameter :: eps1 = 1.0e-8 - -! --- inputs: - integer, intent(in) :: nlay, nlp1 - - real (kind=kind_phys), dimension(nlay,ngptsw), intent(in) :: & - & taug, taur, cldfmc - real (kind=kind_phys), dimension(nlay,nbdsw), intent(in) :: & - & taucw, ssacw, asycw, tauae, ssaae, asyae - - real (kind=kind_phys), dimension(ngptsw), intent(in) :: sfluxzen - - real (kind=kind_phys), dimension(2), intent(in) :: albbm, albdf - - real (kind=kind_phys), intent(in) :: cosz, sntz, cf1, cf0, ssolar - -! --- outputs: - real (kind=kind_phys), dimension(nlp1,nbdsw), intent(out) :: & - & fxupc, fxdnc, fxup0, fxdn0 - - real (kind=kind_phys), dimension(2), intent(out) :: sfbmc, sfdfc, & - & sfbm0, sfdf0 - - real (kind=kind_phys), intent(out) :: suvbfc, suvbf0, ftoadc, & - & ftoauc, ftoau0, fsfcuc, fsfcu0, fsfcdc, fsfcd0 - -! --- locals: - real (kind=kind_phys), dimension(nlay) :: ztaus, zssas, zasys, & - & zldbt0 - - real (kind=kind_phys), dimension(nlp1) :: zrefb, zrefd, ztrab, & - & ztrad, ztdbt, zldbt, zfu, zfd - - real (kind=kind_phys) :: ztau1, zssa1, zasy1, ztau0, zssa0, & - & zasy0, zasy3, zssaw, zasyw, zgam1, zgam2, zgam3, zgam4, & - & za1, za2, zb1, zb2, zrk, zrk2, zrp, zrp1, zrm1, zrpp, & - & zrkg1, zrkg3, zrkg4, zexp1, zexm1, zexp2, zexm2, zden1, & - & zexp3, zexp4, ze1r45, ftind, zsolar, ztdbt0, zr1, zr2, & - & zr3, zr4, zr5, zt1, zt2, zt3, zf1, zf2, zrpp1 - - integer :: ib, ibd, jb, jg, k, kp, itind -! -!===> ... begin here -! -!> -# Initialize output fluxes. - - do ib = 1, nbdsw - do k = 1, nlp1 - fxdnc(k,ib) = f_zero - fxupc(k,ib) = f_zero - fxdn0(k,ib) = f_zero - fxup0(k,ib) = f_zero - enddo - enddo - - ftoadc = f_zero - ftoauc = f_zero - ftoau0 = f_zero - fsfcuc = f_zero - fsfcu0 = f_zero - fsfcdc = f_zero - fsfcd0 = f_zero - -!! --- ... uv-b surface downward fluxes - suvbfc = f_zero - suvbf0 = f_zero - -!! --- ... output surface flux components - sfbmc(1) = f_zero - sfbmc(2) = f_zero - sfdfc(1) = f_zero - sfdfc(2) = f_zero - sfbm0(1) = f_zero - sfbm0(2) = f_zero - sfdf0(1) = f_zero - sfdf0(2) = f_zero - -!> -# Loop over all g-points in each band. - - lab_do_jg : do jg = 1, ngptsw - - jb = NGB(jg) - ib = jb + 1 - nblow - ibd = idxsfc(jb) ! spectral band index - - zsolar = ssolar * sfluxzen(jg) - -!> -# Set up toa direct beam and surface values (beam and diff). - - ztdbt(nlp1) = f_one - ztdbt0 = f_one - - zldbt(1) = f_zero - if (ibd /= 0) then - zrefb(1) = albbm(ibd) - zrefd(1) = albdf(ibd) - else - zrefb(1) = 0.5 * (albbm(1) + albbm(2)) - zrefd(1) = 0.5 * (albdf(1) + albdf(2)) - endif - ztrab(1) = f_zero - ztrad(1) = f_zero - -!> -# Compute clear-sky optical parameters, layer reflectance and -!! transmittance. -! - Set up toa direct beam and surface values (beam and diff) -! - Delta scaling for clear-sky condition -! - General two-stream expressions for physparam::iswmode -! - Compute homogeneous reflectance and transmittance for both -! conservative and non-conservative scattering -! - Pre-delta-scaling clear and cloudy direct beam transmittance -! - Call swflux() to compute the upward and downward radiation fluxes - - do k = nlay, 1, -1 - kp = k + 1 - - ztau0 = max( ftiny, taur(k,jg)+taug(k,jg)+tauae(k,ib) ) - zssa0 = taur(k,jg) + tauae(k,ib)*ssaae(k,ib) - zasy0 = asyae(k,ib)*ssaae(k,ib)*tauae(k,ib) - zssaw = min( oneminus, zssa0 / ztau0 ) - zasyw = zasy0 / max( ftiny, zssa0 ) - -!> - Saving clear-sky quantities for later total-sky usage. - ztaus(k) = ztau0 - zssas(k) = zssa0 - zasys(k) = zasy0 - -!> - Delta scaling for clear-sky condition. - za1 = zasyw * zasyw - za2 = zssaw * za1 - - ztau1 = (f_one - za2) * ztau0 - zssa1 = (zssaw - za2) / (f_one - za2) -!org zasy1 = (zasyw - za1) / (f_one - za1) ! this line is replaced by the next - zasy1 = zasyw / (f_one + zasyw) ! to reduce truncation error - zasy3 = 0.75 * zasy1 - -!> - Perform general two-stream expressions: -!!\n control parameters in module "physparam" -!!\n iswmode - control flag for 2-stream transfer schemes -!!\n = 1 delta-eddington (joseph et al., 1976) -!!\n = 2 pifm (zdunkowski et al., 1980) -!!\n = 3 discrete ordinates (liou, 1973) - if ( iswmode == 1 ) then - zgam1 = 1.75 - zssa1 * (f_one + zasy3) - zgam2 =-0.25 + zssa1 * (f_one - zasy3) - zgam3 = 0.5 - zasy3 * cosz - elseif ( iswmode == 2 ) then ! pifm - zgam1 = 2.0 - zssa1 * (1.25 + zasy3) - zgam2 = 0.75* zssa1 * (f_one- zasy1) - zgam3 = 0.5 - zasy3 * cosz - elseif ( iswmode == 3 ) then ! discrete ordinates - zgam1 = zsr3 * (2.0 - zssa1 * (1.0 + zasy1)) * 0.5 - zgam2 = zsr3 * zssa1 * (1.0 - zasy1) * 0.5 - zgam3 = (1.0 - zsr3 * zasy1 * cosz) * 0.5 - endif - zgam4 = f_one - zgam3 - -!> - Compute homogeneous reflectance and transmittance. - - if ( zssaw >= zcrit ) then ! for conservative scattering - za1 = zgam1 * cosz - zgam3 - za2 = zgam1 * ztau1 - -! --- ... use exponential lookup table for transmittance, or expansion -! of exponential for low optical depth - - zb1 = min ( ztau1*sntz , 500.0 ) - if ( zb1 <= od_lo ) then - zb2 = f_one - zb1 + 0.5*zb1*zb1 - else - ftind = zb1 / (bpade + zb1) - itind = ftind*NTBMX + 0.5 - zb2 = exp_tbl(itind) - endif - -! ... collimated beam - zrefb(kp) = max(f_zero, min(f_one, & - & (za2 - za1*(f_one - zb2))/(f_one + za2) )) - ztrab(kp) = max(f_zero, min(f_one, f_one-zrefb(kp) )) - -! ... isotropic incidence - zrefd(kp) = max(f_zero, min(f_one, za2/(f_one + za2) )) - ztrad(kp) = max(f_zero, min(f_one, f_one-zrefd(kp) )) - - else ! for non-conservative scattering - za1 = zgam1*zgam4 + zgam2*zgam3 - za2 = zgam1*zgam3 + zgam2*zgam4 - zrk = sqrt ( (zgam1 - zgam2) * (zgam1 + zgam2) ) - zrk2= 2.0 * zrk - - zrp = zrk * cosz - zrp1 = f_one + zrp - zrm1 = f_one - zrp - zrpp1= f_one - zrp*zrp - zrpp = sign( max(flimit, abs(zrpp1)), zrpp1 ) ! avoid numerical singularity - zrkg1= zrk + zgam1 - zrkg3= zrk * zgam3 - zrkg4= zrk * zgam4 - - zr1 = zrm1 * (za2 + zrkg3) - zr2 = zrp1 * (za2 - zrkg3) - zr3 = zrk2 * (zgam3 - za2*cosz) - zr4 = zrpp * zrkg1 - zr5 = zrpp * (zrk - zgam1) - - zt1 = zrp1 * (za1 + zrkg4) - zt2 = zrm1 * (za1 - zrkg4) - zt3 = zrk2 * (zgam4 + za1*cosz) - -! --- ... use exponential lookup table for transmittance, or expansion -! of exponential for low optical depth - - zb1 = min ( zrk*ztau1, 500.0 ) - if ( zb1 <= od_lo ) then - zexm1 = f_one - zb1 + 0.5*zb1*zb1 - else - ftind = zb1 / (bpade + zb1) - itind = ftind*NTBMX + 0.5 - zexm1 = exp_tbl(itind) - endif - zexp1 = f_one / zexm1 - - zb2 = min ( sntz*ztau1, 500.0 ) - if ( zb2 <= od_lo ) then - zexm2 = f_one - zb2 + 0.5*zb2*zb2 - else - ftind = zb2 / (bpade + zb2) - itind = ftind*NTBMX + 0.5 - zexm2 = exp_tbl(itind) - endif - zexp2 = f_one / zexm2 - ze1r45 = zr4*zexp1 + zr5*zexm1 - -! ... collimated beam - if (ze1r45>=-eps1 .and. ze1r45<=eps1) then - zrefb(kp) = eps1 - ztrab(kp) = zexm2 - else - zden1 = zssa1 / ze1r45 - zrefb(kp) = max(f_zero, min(f_one, & - & (zr1*zexp1 - zr2*zexm1 - zr3*zexm2)*zden1 )) - ztrab(kp) = max(f_zero, min(f_one, zexm2*(f_one & - & - (zt1*zexp1 - zt2*zexm1 - zt3*zexp2)*zden1) )) - endif - -! ... diffuse beam - zden1 = zr4 / (ze1r45 * zrkg1) - zrefd(kp) = max(f_zero, min(f_one, & - & zgam2*(zexp1 - zexm1)*zden1 )) - ztrad(kp) = max(f_zero, min(f_one, zrk2*zden1 )) - endif ! end if_zssaw_block - -!> - Calculate direct beam transmittance. use exponential lookup table -!! for transmittance, or expansion of exponential for low optical depth. - - zr1 = ztau1 * sntz - if ( zr1 <= od_lo ) then - zexp3 = f_one - zr1 + 0.5*zr1*zr1 - else - ftind = zr1 / (bpade + zr1) - itind = max(0, min(NTBMX, int(0.5+NTBMX*ftind) )) - zexp3 = exp_tbl(itind) - endif - - ztdbt(k) = zexp3 * ztdbt(kp) - zldbt(kp) = zexp3 - -!> - Calculate pre-delta-scaling clear and cloudy direct beam transmittance. -! (must use 'orig', unscaled cloud optical depth) - - zr1 = ztau0 * sntz - if ( zr1 <= od_lo ) then - zexp4 = f_one - zr1 + 0.5*zr1*zr1 - else - ftind = zr1 / (bpade + zr1) - itind = max(0, min(NTBMX, int(0.5+NTBMX*ftind) )) - zexp4 = exp_tbl(itind) - endif - - zldbt0(k) = zexp4 - ztdbt0 = zexp4 * ztdbt0 - enddo ! end do_k_loop - -!> -# Call vrtqdr(), to compute the upward and downward radiation fluxes. - call vrtqdr & -! --- inputs: - & ( zrefb,zrefd,ztrab,ztrad,zldbt,ztdbt, & - & nlay, nlp1, & -! --- outputs: - & zfu, zfd & - & ) - -!> -# Compute upward and downward fluxes at levels. - do k = 1, nlp1 - fxup0(k,ib) = fxup0(k,ib) + zsolar*zfu(k) - fxdn0(k,ib) = fxdn0(k,ib) + zsolar*zfd(k) - enddo - -!> -# Compute surface downward beam/diffuse flux components. - zb1 = zsolar*ztdbt0 - zb2 = zsolar*(zfd(1) - ztdbt0) - - if (ibd /= 0) then - sfbm0(ibd) = sfbm0(ibd) + zb1 - sfdf0(ibd) = sfdf0(ibd) + zb2 - else - zf1 = 0.5 * zb1 - zf2 = 0.5 * zb2 - sfbm0(1) = sfbm0(1) + zf1 - sfdf0(1) = sfdf0(1) + zf2 - sfbm0(2) = sfbm0(2) + zf1 - sfdf0(2) = sfdf0(2) + zf2 - endif -! sfbm0(ibd) = sfbm0(ibd) + zsolar*ztdbt0 -! sfdf0(ibd) = sfdf0(ibd) + zsolar*(zfd(1) - ztdbt0) - -!> -# Compute total sky optical parameters, layer reflectance and -!! transmittance. -! - Set up toa direct beam and surface values (beam and diff) -! - Delta scaling for total-sky condition -! - General two-stream expressions for physparam::iswmode -! - Compute homogeneous reflectance and transmittance for -! conservative scattering and non-conservative scattering -! - Pre-delta-scaling clear and cloudy direct beam transmittance -! - Call swflux() to compute the upward and downward radiation fluxes - - if ( cf1 > eps ) then - -!> - Set up toa direct beam and surface values (beam and diff). - ztdbt0 = f_one - zldbt(1) = f_zero - - do k = nlay, 1, -1 - kp = k + 1 - if ( cldfmc(k,jg) > ftiny ) then ! it is a cloudy-layer - - ztau0 = ztaus(k) + taucw(k,ib) - zssa0 = zssas(k) + ssacw(k,ib) - zasy0 = zasys(k) + asycw(k,ib) - zssaw = min(oneminus, zssa0 / ztau0) - zasyw = zasy0 / max(ftiny, zssa0) - -!> - Perform delta scaling for total-sky condition. - za1 = zasyw * zasyw - za2 = zssaw * za1 - - ztau1 = (f_one - za2) * ztau0 - zssa1 = (zssaw - za2) / (f_one - za2) -!org zasy1 = (zasyw - za1) / (f_one - za1) - zasy1 = zasyw / (f_one + zasyw) - zasy3 = 0.75 * zasy1 - -!> - Perform general two-stream expressions. - if ( iswmode == 1 ) then - zgam1 = 1.75 - zssa1 * (f_one + zasy3) - zgam2 =-0.25 + zssa1 * (f_one - zasy3) - zgam3 = 0.5 - zasy3 * cosz - elseif ( iswmode == 2 ) then ! pifm - zgam1 = 2.0 - zssa1 * (1.25 + zasy3) - zgam2 = 0.75* zssa1 * (f_one- zasy1) - zgam3 = 0.5 - zasy3 * cosz - elseif ( iswmode == 3 ) then ! discrete ordinates - zgam1 = zsr3 * (2.0 - zssa1 * (1.0 + zasy1)) * 0.5 - zgam2 = zsr3 * zssa1 * (1.0 - zasy1) * 0.5 - zgam3 = (1.0 - zsr3 * zasy1 * cosz) * 0.5 - endif - zgam4 = f_one - zgam3 - -!> - Compute homogeneous reflectance and transmittance for both convertive -!! and non-convertive scattering. - - if ( zssaw >= zcrit ) then ! for conservative scattering - za1 = zgam1 * cosz - zgam3 - za2 = zgam1 * ztau1 - -! --- ... use exponential lookup table for transmittance, or expansion -! of exponential for low optical depth - - zb1 = min ( ztau1*sntz , 500.0 ) - if ( zb1 <= od_lo ) then - zb2 = f_one - zb1 + 0.5*zb1*zb1 - else - ftind = zb1 / (bpade + zb1) - itind = ftind*NTBMX + 0.5 - zb2 = exp_tbl(itind) - endif - -! ... collimated beam - zrefb(kp) = max(f_zero, min(f_one, & - & (za2 - za1*(f_one - zb2))/(f_one + za2) )) - ztrab(kp) = max(f_zero, min(f_one, f_one-zrefb(kp))) - -! ... isotropic incidence - zrefd(kp) = max(f_zero, min(f_one, za2 / (f_one+za2) )) - ztrad(kp) = max(f_zero, min(f_one, f_one - zrefd(kp) )) - - else ! for non-conservative scattering - za1 = zgam1*zgam4 + zgam2*zgam3 - za2 = zgam1*zgam3 + zgam2*zgam4 - zrk = sqrt ( (zgam1 - zgam2) * (zgam1 + zgam2) ) - zrk2= 2.0 * zrk - - zrp = zrk * cosz - zrp1 = f_one + zrp - zrm1 = f_one - zrp - zrpp1= f_one - zrp*zrp - zrpp = sign( max(flimit, abs(zrpp1)), zrpp1 ) ! avoid numerical singularity - zrkg1= zrk + zgam1 - zrkg3= zrk * zgam3 - zrkg4= zrk * zgam4 - - zr1 = zrm1 * (za2 + zrkg3) - zr2 = zrp1 * (za2 - zrkg3) - zr3 = zrk2 * (zgam3 - za2*cosz) - zr4 = zrpp * zrkg1 - zr5 = zrpp * (zrk - zgam1) - - zt1 = zrp1 * (za1 + zrkg4) - zt2 = zrm1 * (za1 - zrkg4) - zt3 = zrk2 * (zgam4 + za1*cosz) - -! --- ... use exponential lookup table for transmittance, or expansion -! of exponential for low optical depth - - zb1 = min ( zrk*ztau1, 500.0 ) - if ( zb1 <= od_lo ) then - zexm1 = f_one - zb1 + 0.5*zb1*zb1 - else - ftind = zb1 / (bpade + zb1) - itind = ftind*NTBMX + 0.5 - zexm1 = exp_tbl(itind) - endif - zexp1 = f_one / zexm1 - - zb2 = min ( ztau1*sntz, 500.0 ) - if ( zb2 <= od_lo ) then - zexm2 = f_one - zb2 + 0.5*zb2*zb2 - else - ftind = zb2 / (bpade + zb2) - itind = ftind*NTBMX + 0.5 - zexm2 = exp_tbl(itind) - endif - zexp2 = f_one / zexm2 - ze1r45 = zr4*zexp1 + zr5*zexm1 - -! ... collimated beam - if ( ze1r45>=-eps1 .and. ze1r45<=eps1 ) then - zrefb(kp) = eps1 - ztrab(kp) = zexm2 - else - zden1 = zssa1 / ze1r45 - zrefb(kp) = max(f_zero, min(f_one, & - & (zr1*zexp1-zr2*zexm1-zr3*zexm2)*zden1 )) - ztrab(kp) = max(f_zero, min(f_one, zexm2*(f_one - & - & (zt1*zexp1-zt2*zexm1-zt3*zexp2)*zden1) )) - endif - -! ... diffuse beam - zden1 = zr4 / (ze1r45 * zrkg1) - zrefd(kp) = max(f_zero, min(f_one, & - & zgam2*(zexp1 - zexm1)*zden1 )) - ztrad(kp) = max(f_zero, min(f_one, zrk2*zden1 )) - endif ! end if_zssaw_block - -! --- ... direct beam transmittance. use exponential lookup table -! for transmittance, or expansion of exponential for low -! optical depth - - zr1 = ztau1 * sntz - if ( zr1 <= od_lo ) then - zexp3 = f_one - zr1 + 0.5*zr1*zr1 - else - ftind = zr1 / (bpade + zr1) - itind = max(0, min(NTBMX, int(0.5+NTBMX*ftind) )) - zexp3 = exp_tbl(itind) - endif - - zldbt(kp) = zexp3 - ztdbt(k) = zexp3 * ztdbt(kp) - -! --- ... pre-delta-scaling clear and cloudy direct beam transmittance -! (must use 'orig', unscaled cloud optical depth) - - zr1 = ztau0 * sntz - if ( zr1 <= od_lo ) then - zexp4 = f_one - zr1 + 0.5*zr1*zr1 - else - ftind = zr1 / (bpade + zr1) - itind = max(0, min(NTBMX, int(0.5+NTBMX*ftind) )) - zexp4 = exp_tbl(itind) - endif - - ztdbt0 = zexp4 * ztdbt0 - - else ! if_cldfmc_block --- it is a clear layer - -! --- ... direct beam transmittance - ztdbt(k) = zldbt(kp) * ztdbt(kp) - -!> - Calculate pre-delta-scaling clear and cloudy direct beam transmittance. - ztdbt0 = zldbt0(k) * ztdbt0 - - endif ! end if_cldfmc_block - enddo ! end do_k_loop - -!> -# Call vrtqdr(), to perform vertical quadrature - - call vrtqdr & -! --- inputs: - & ( zrefb,zrefd,ztrab,ztrad,zldbt,ztdbt, & - & nlay, nlp1, & -! --- outputs: - & zfu, zfd & - & ) - -! --- ... compute upward and downward fluxes at levels - do k = 1, nlp1 - fxupc(k,ib) = fxupc(k,ib) + zsolar*zfu(k) - fxdnc(k,ib) = fxdnc(k,ib) + zsolar*zfd(k) - enddo - -!> -# Process and save outputs. -!! - surface downward beam/diffused flux components - zb1 = zsolar*ztdbt0 - zb2 = zsolar*(zfd(1) - ztdbt0) - - if (ibd /= 0) then - sfbmc(ibd) = sfbmc(ibd) + zb1 - sfdfc(ibd) = sfdfc(ibd) + zb2 - else - zf1 = 0.5 * zb1 - zf2 = 0.5 * zb2 - sfbmc(1) = sfbmc(1) + zf1 - sfdfc(1) = sfdfc(1) + zf2 - sfbmc(2) = sfbmc(2) + zf1 - sfdfc(2) = sfdfc(2) + zf2 - endif -! sfbmc(ibd) = sfbmc(ibd) + zsolar*ztdbt0 -! sfdfc(ibd) = sfdfc(ibd) + zsolar*(zfd(1) - ztdbt0) - - endif ! end if_cf1_block - - enddo lab_do_jg - -! --- ... end of g-point loop - - do ib = 1, nbdsw - ftoadc = ftoadc + fxdn0(nlp1,ib) - ftoau0 = ftoau0 + fxup0(nlp1,ib) - fsfcu0 = fsfcu0 + fxup0(1,ib) - fsfcd0 = fsfcd0 + fxdn0(1,ib) - enddo - -!> - uv-b surface downward flux - ibd = nuvb - nblow + 1 - suvbf0 = fxdn0(1,ibd) - - if ( cf1 <= eps ) then ! clear column, set total-sky=clear-sky fluxes - do ib = 1, nbdsw - do k = 1, nlp1 - fxupc(k,ib) = fxup0(k,ib) - fxdnc(k,ib) = fxdn0(k,ib) - enddo - enddo - - ftoauc = ftoau0 - fsfcuc = fsfcu0 - fsfcdc = fsfcd0 - -!> - surface downward beam/diffused flux components - sfbmc(1) = sfbm0(1) - sfdfc(1) = sfdf0(1) - sfbmc(2) = sfbm0(2) - sfdfc(2) = sfdf0(2) - -!> - uv-b surface downward flux - suvbfc = suvbf0 - else ! cloudy column, compute total-sky fluxes - do ib = 1, nbdsw - ftoauc = ftoauc + fxupc(nlp1,ib) - fsfcuc = fsfcuc + fxupc(1,ib) - fsfcdc = fsfcdc + fxdnc(1,ib) - enddo - -!! --- ... uv-b surface downward flux - suvbfc = fxdnc(1,ibd) - endif ! end if_cf1_block - - return -!................................... - end subroutine spcvrtm -!! @} -!----------------------------------- - -!>\ingroup module_radsw_main -!> This subroutine is called by spcvrtc() and spcvrtm(), and computes -!! the upward and downward radiation fluxes. -!!\param zrefb layer direct beam reflectivity -!!\param zrefd layer diffuse reflectivity -!!\param ztrab layer direct beam transmissivity -!!\param ztrad layer diffuse transmissivity -!!\param zldbt layer mean beam transmittance -!!\param ztdbt total beam transmittance at levels -!!\param NLAY, NLP1 number of layers/levels -!!\param zfu upward flux at layer interface -!!\param zfd downward flux at layer interface -!!\section General_vrtqdr vrtqdr General Algorithm -!> @{ -!----------------------------------- - subroutine vrtqdr & - & ( zrefb,zrefd,ztrab,ztrad,zldbt,ztdbt, & ! inputs - & NLAY, NLP1, & - & zfu, zfd & ! outputs: - & ) - -! =================== program usage description =================== ! -! ! -! purpose: computes the upward and downward radiation fluxes ! -! ! -! interface: "vrtqdr" is called by "spcvrc" and "spcvrm" ! -! ! -! subroutines called : none ! -! ! -! ==================== defination of variables ==================== ! -! ! -! input variables: ! -! zrefb(NLP1) - layer direct beam reflectivity ! -! zrefd(NLP1) - layer diffuse reflectivity ! -! ztrab(NLP1) - layer direct beam transmissivity ! -! ztrad(NLP1) - layer diffuse transmissivity ! -! zldbt(NLP1) - layer mean beam transmittance ! -! ztdbt(NLP1) - total beam transmittance at levels ! -! NLAY, NLP1 - number of layers/levels ! -! ! -! output variables: ! -! zfu (NLP1) - upward flux at layer interface ! -! zfd (NLP1) - downward flux at layer interface ! -! ! -! ******************************************************************* ! -! ====================== end of description block ================= ! - -! --- inputs: - integer, intent(in) :: nlay, nlp1 - - real (kind=kind_phys), dimension(nlp1), intent(in) :: zrefb, & - & zrefd, ztrab, ztrad, ztdbt, zldbt - -! --- outputs: - real (kind=kind_phys), dimension(nlp1), intent(out) :: zfu, zfd - -! --- locals: - real (kind=kind_phys), dimension(nlp1) :: zrupb,zrupd,zrdnd,ztdn - - real (kind=kind_phys) :: zden1 - - integer :: k, kp -! -!===> ... begin here -! - -!> -# Link lowest layer with surface. - zrupb(1) = zrefb(1) ! direct beam - zrupd(1) = zrefd(1) ! diffused - -!> -# Pass from bottom to top. - do k = 1, nlay - kp = k + 1 - - zden1 = f_one / ( f_one - zrupd(k)*zrefd(kp) ) - zrupb(kp) = zrefb(kp) + ( ztrad(kp) * & - & ( (ztrab(kp) - zldbt(kp))*zrupd(k) + & - & zldbt(kp)*zrupb(k)) ) * zden1 - zrupd(kp) = zrefd(kp) + ztrad(kp)*ztrad(kp)*zrupd(k)*zden1 - enddo - -!> -# Upper boundary conditions - ztdn (nlp1) = f_one - zrdnd(nlp1) = f_zero - ztdn (nlay) = ztrab(nlp1) - zrdnd(nlay) = zrefd(nlp1) - -!> -# Pass from top to bottom - do k = nlay, 2, -1 - zden1 = f_one / (f_one - zrefd(k)*zrdnd(k)) - ztdn (k-1) = ztdbt(k)*ztrab(k) + ( ztrad(k) * & - & ( (ztdn(k) - ztdbt(k)) + ztdbt(k) * & - & zrefb(k)*zrdnd(k) )) * zden1 - zrdnd(k-1) = zrefd(k) + ztrad(k)*ztrad(k)*zrdnd(k)*zden1 - enddo - -!> -# Up and down-welling fluxes at levels. - do k = 1, nlp1 - zden1 = f_one / (f_one - zrdnd(k)*zrupd(k)) - zfu(k) = ( ztdbt(k)*zrupb(k) + & - & (ztdn(k) - ztdbt(k))*zrupd(k) ) * zden1 - zfd(k) = ztdbt(k) + ( ztdn(k) - ztdbt(k) + & - & ztdbt(k)*zrupb(k)*zrdnd(k) ) * zden1 - enddo - - return -!................................... - end subroutine vrtqdr -!----------------------------------- -!> @} - -!>\ingroup module_radsw_main -!> This subroutine calculates optical depths for gaseous absorption and -!! rayleigh scattering -!!\n subroutine called taumol## (## = 16-29) -!!\param colamt column amounts of absorbing gases the index -!! are for h2o, co2, o3, n2o, ch4, and o2, -!! respectively \f$(mol/cm^2)\f$ -!!\param colmol total column amount (dry air+water vapor) -!!\param fac00,fac01,fac10,fac11 for each layer, these are factors that are -!! needed to compute the interpolation factors -!! that multiply the appropriate reference -!! k-values. a value of 0/1 for i,j indicates -!! that the corresponding factor multiplies -!! reference k-value for the lower/higher of the -!! two appropriate temperatures, and altitudes, -!! respectively. -!!\param jp the index of the lower (in altitude) of the -!! two appropriate ref pressure levels needed -!! for interpolation. -!!\param jt, jt1 the indices of the lower of the two approp -!! ref temperatures needed for interpolation -!! (for pressure levels jp and jp+1, respectively) -!!\param laytrop tropopause layer index -!!\param forfac scale factor needed to foreign-continuum. -!!\param forfrac factor needed for temperature interpolation -!!\param indfor index of the lower of the two appropriate -!! reference temperatures needed for -!! foreign-continuum interpolation -!!\param selffac scale factor needed to h2o self-continuum. -!!\param selffrac factor needed for temperature interpolation -!! of reference h2o self-continuum data -!!\param indself index of the lower of the two appropriate -!! reference temperatures needed for the -!! self-continuum interpolation -!!\param nlay number of vertical layers -!!\param sfluxzen spectral distribution of incoming solar flux -!!\param taug spectral optical depth for gases -!!\param taur opt depth for rayleigh scattering -!>\section gen_al_taumol taumol General Algorithm -!! @{ -!----------------------------------- - subroutine taumol & - & ( colamt,colmol,fac00,fac01,fac10,fac11,jp,jt,jt1,laytrop, & ! --- inputs - & forfac,forfrac,indfor,selffac,selffrac,indself, nlay, & - & sfluxzen, taug, taur & ! --- outputs - & ) - -! ================== program usage description ================== ! -! ! -! description: ! -! calculate optical depths for gaseous absorption and rayleigh ! -! scattering. ! -! ! -! subroutines called: taugb## (## = 16 - 29) ! -! ! -! ==================== defination of variables ==================== ! -! ! -! inputs: size ! -! colamt - real, column amounts of absorbing gases the index ! -! are for h2o, co2, o3, n2o, ch4, and o2, ! -! respectively (molecules/cm**2) nlay*maxgas! -! colmol - real, total column amount (dry air+water vapor) nlay ! -! facij - real, for each layer, these are factors that are ! -! needed to compute the interpolation factors ! -! that multiply the appropriate reference k- ! -! values. a value of 0/1 for i,j indicates ! -! that the corresponding factor multiplies ! -! reference k-value for the lower/higher of the ! -! two appropriate temperatures, and altitudes, ! -! respectively. naly ! -! jp - real, the index of the lower (in altitude) of the ! -! two appropriate ref pressure levels needed ! -! for interpolation. nlay ! -! jt, jt1 - integer, the indices of the lower of the two approp ! -! ref temperatures needed for interpolation (for ! -! pressure levels jp and jp+1, respectively) nlay ! -! laytrop - integer, tropopause layer index 1 ! -! forfac - real, scale factor needed to foreign-continuum. nlay ! -! forfrac - real, factor needed for temperature interpolation nlay ! -! indfor - integer, index of the lower of the two appropriate ! -! reference temperatures needed for foreign- ! -! continuum interpolation nlay ! -! selffac - real, scale factor needed to h2o self-continuum. nlay ! -! selffrac- real, factor needed for temperature interpolation ! -! of reference h2o self-continuum data nlay ! -! indself - integer, index of the lower of the two appropriate ! -! reference temperatures needed for the self- ! -! continuum interpolation nlay ! -! nlay - integer, number of vertical layers 1 ! -! ! -! output: ! -! sfluxzen- real, spectral distribution of incoming solar flux ngptsw! -! taug - real, spectral optical depth for gases nlay*ngptsw! -! taur - real, opt depth for rayleigh scattering nlay*ngptsw! -! ! -! =================================================================== ! -! ************ original subprogram description *************** ! -! ! -! optical depths developed for the ! -! ! -! rapid radiative transfer model (rrtm) ! -! ! -! atmospheric and environmental research, inc. ! -! 131 hartwell avenue ! -! lexington, ma 02421 ! -! ! -! ! -! eli j. mlawer ! -! jennifer delamere ! -! steven j. taubman ! -! shepard a. clough ! -! ! -! ! -! ! -! email: mlawer@aer.com ! -! email: jdelamer@aer.com ! -! ! -! the authors wish to acknowledge the contributions of the ! -! following people: patrick d. brown, michael j. iacono, ! -! ronald e. farren, luke chen, robert bergstrom. ! -! ! -! ******************************************************************* ! -! ! -! taumol ! -! ! -! this file contains the subroutines taugbn (where n goes from ! -! 16 to 29). taugbn calculates the optical depths and Planck ! -! fractions per g-value and layer for band n. ! -! ! -! output: optical depths (unitless) ! -! fractions needed to compute planck functions at every layer ! -! and g-value ! -! ! -! modifications: ! -! ! -! revised: adapted to f90 coding, j.-j.morcrette, ecmwf, feb 2003 ! -! revised: modified for g-point reduction, mjiacono, aer, dec 2003 ! -! revised: reformatted for consistency with rrtmg_lw, mjiacono, aer, ! -! jul 2006 ! -! ! -! ******************************************************************* ! -! ====================== end of description block ================= ! - -! --- inputs: - integer, intent(in) :: nlay, laytrop - - integer, dimension(nlay), intent(in) :: indfor, indself, & - & jp, jt, jt1 - - real (kind=kind_phys), dimension(nlay), intent(in) :: colmol, & - & fac00, fac01, fac10, fac11, forfac, forfrac, selffac, & - & selffrac - - real (kind=kind_phys), dimension(nlay,maxgas),intent(in) :: colamt - -! --- outputs: - real (kind=kind_phys), dimension(ngptsw), intent(out) :: sfluxzen - - real (kind=kind_phys), dimension(nlay,ngptsw), intent(out) :: & - & taug, taur - -! --- locals: - real (kind=kind_phys) :: fs, speccomb, specmult, colm1, colm2 - - integer, dimension(nlay,nblow:nbhgh) :: id0, id1 - - integer :: ibd, j, jb, js, k, klow, khgh, klim, ks, njb, ns -! -!===> ... begin here -! -! --- ... loop over each spectral band - - do jb = nblow, nbhgh - -! --- ... indices for layer optical depth - - do k = 1, laytrop - id0(k,jb) = ((jp(k)-1)*5 + (jt (k)-1)) * nspa(jb) - id1(k,jb) = ( jp(k) *5 + (jt1(k)-1)) * nspa(jb) - enddo - - do k = laytrop+1, nlay - id0(k,jb) = ((jp(k)-13)*5 + (jt (k)-1)) * nspb(jb) - id1(k,jb) = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(jb) - enddo - -! --- ... calculate spectral flux at toa - - ibd = ibx(jb) - njb = ng (jb) - ns = ngs(jb) - - select case (jb) - - case (16, 20, 23, 25, 26, 29) - - do j = 1, njb - sfluxzen(ns+j) = sfluxref01(j,1,ibd) - enddo - - case (27) - - do j = 1, njb - sfluxzen(ns+j) = scalekur * sfluxref01(j,1,ibd) - enddo - - case default - - if (jb==17 .or. jb==28) then - - ks = nlay - lab_do_k1 : do k = laytrop, nlay-1 - if (jp(k)=layreffr(jb)) then - ks = k + 1 - exit lab_do_k1 - endif - enddo lab_do_k1 - - colm1 = colamt(ks,ix1(jb)) - colm2 = colamt(ks,ix2(jb)) - speccomb = colm1 + strrat(jb)*colm2 - specmult = specwt(jb) * min( oneminus, colm1/speccomb ) - js = 1 + int( specmult ) - fs = mod(specmult, f_one) - - do j = 1, njb - sfluxzen(ns+j) = sfluxref02(j,js,ibd) & - & + fs * (sfluxref02(j,js+1,ibd) - sfluxref02(j,js,ibd)) - enddo - - else - - ks = laytrop - lab_do_k2 : do k = 1, laytrop-1 - if (jp(k)=layreffr(jb)) then - ks = k + 1 - exit lab_do_k2 - endif - enddo lab_do_k2 - - colm1 = colamt(ks,ix1(jb)) - colm2 = colamt(ks,ix2(jb)) - speccomb = colm1 + strrat(jb)*colm2 - specmult = specwt(jb) * min( oneminus, colm1/speccomb ) - js = 1 + int( specmult ) - fs = mod(specmult, f_one) - - do j = 1, njb - sfluxzen(ns+j) = sfluxref03(j,js,ibd) & - & + fs * (sfluxref03(j,js+1,ibd) - sfluxref03(j,js,ibd)) - enddo - - endif - - end select - - enddo - -!> - Call taumol## (##: 16-29) to calculate layer optical depth. - -!> - call taumol16() - call taumol16 -!> - call taumol17() - call taumol17 -!> - call taumol18() - call taumol18 -!> - call taumol19() - call taumol19 -!> - call taumol20() - call taumol20 -!> - call taumol21() - call taumol21 -!> - call taumol22() - call taumol22 -!> - call taumol23() - call taumol23 -!> - call taumol24() - call taumol24 -!> - call taumol25() - call taumol25 -!> - call taumol26() - call taumol26 -!> - call taumol27() - call taumol27 -!> - call taumol28() - call taumol28 -!> - call taumol29() - call taumol29 - - -! ================= - contains -! ================= - -!>\ingroup module_radsw_main -!> The subroutine computes the optical depth in band 16: 2600-3250 -!! cm-1 (low - h2o,ch4; high - ch4) -!----------------------------------- - subroutine taumol16 -!................................... - -! ------------------------------------------------------------------ ! -! band 16: 2600-3250 cm-1 (low - h2o,ch4; high - ch4) ! -! ------------------------------------------------------------------ ! -! - use module_radsw_kgb16 - -! --- locals: - - real (kind=kind_phys) :: speccomb, specmult, tauray, fs, fs1, & - & fac000,fac001,fac010,fac011, fac100,fac101,fac110,fac111 - - integer :: ind01, ind02, ind03, ind04, ind11, ind12, ind13, ind14 - integer :: inds, indf, indsp, indfp, j, js, k - -! -!===> ... begin here -! - -! --- ... compute the optical depth by interpolating in ln(pressure), -! temperature, and appropriate species. below laytrop, the water -! vapor self-continuum is interpolated (in temperature) separately. - - do k = 1, nlay - tauray = colmol(k) * rayl - - do j = 1, NG16 - taur(k,NS16+j) = tauray - enddo - enddo - - do k = 1, laytrop - speccomb = colamt(k,1) + strrat(16)*colamt(k,5) - specmult = 8.0 * min( oneminus, colamt(k,1)/speccomb ) - - js = 1 + int( specmult ) - fs = mod( specmult, f_one ) - fs1= f_one - fs - fac000 = fs1 * fac00(k) - fac010 = fs1 * fac10(k) - fac100 = fs * fac00(k) - fac110 = fs * fac10(k) - fac001 = fs1 * fac01(k) - fac011 = fs1 * fac11(k) - fac101 = fs * fac01(k) - fac111 = fs * fac11(k) - - ind01 = id0(k,16) + js - ind02 = ind01 + 1 - ind03 = ind01 + 9 - ind04 = ind01 + 10 - ind11 = id1(k,16) + js - ind12 = ind11 + 1 - ind13 = ind11 + 9 - ind14 = ind11 + 10 - inds = indself(k) - indf = indfor (k) - indsp= inds + 1 - indfp= indf + 1 - - do j = 1, NG16 - taug(k,NS16+j) = speccomb & - & *( fac000 * absa(ind01,j) + fac100 * absa(ind02,j) & - & + fac010 * absa(ind03,j) + fac110 * absa(ind04,j) & - & + fac001 * absa(ind11,j) + fac101 * absa(ind12,j) & - & + fac011 * absa(ind13,j) + fac111 * absa(ind14,j) ) & - & + colamt(k,1) * (selffac(k) * (selfref(inds,j) & - & + selffrac(k) * (selfref(indsp,j)-selfref(inds,j))) & - & + forfac(k) * (forref(indf,j) + forfrac(k) & - & * (forref(indfp,j) - forref(indf,j)))) - enddo - enddo - - do k = laytrop+1, nlay - ind01 = id0(k,16) + 1 - ind02 = ind01 + 1 - ind11 = id1(k,16) + 1 - ind12 = ind11 + 1 - - do j = 1, NG16 - taug(k,NS16+j) = colamt(k,5) & - & * ( fac00(k)*absb(ind01,j) + fac10(k)*absb(ind02,j) & - & + fac01(k)*absb(ind11,j) + fac11(k)*absb(ind12,j) ) - enddo - enddo - - return -!................................... - end subroutine taumol16 -!----------------------------------- - -!>\ingroup module_radsw_main -!> The subroutine computes the optical depth in band 17: 3250-4000 -!! cm-1 (low - h2o,co2; high - h2o,co2) -!----------------------------------- - subroutine taumol17 -!................................... - -! ------------------------------------------------------------------ ! -! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o,co2) ! -! ------------------------------------------------------------------ ! -! - use module_radsw_kgb17 - -! --- locals: - real (kind=kind_phys) :: speccomb, specmult, tauray, fs, fs1, & - & fac000,fac001,fac010,fac011, fac100,fac101,fac110,fac111 - - integer :: ind01, ind02, ind03, ind04, ind11, ind12, ind13, ind14 - integer :: inds, indf, indsp, indfp, j, js, k - -! -!===> ... begin here -! - -! --- ... compute the optical depth by interpolating in ln(pressure), -! temperature, and appropriate species. below laytrop, the water -! vapor self-continuum is interpolated (in temperature) separately. - - do k = 1, nlay - tauray = colmol(k) * rayl - - do j = 1, NG17 - taur(k,NS17+j) = tauray - enddo - enddo - - do k = 1, laytrop - speccomb = colamt(k,1) + strrat(17)*colamt(k,2) - specmult = 8.0 * min(oneminus, colamt(k,1) / speccomb) - - js = 1 + int(specmult) - fs = mod(specmult, f_one) - fs1= f_one - fs - fac000 = fs1 * fac00(k) - fac010 = fs1 * fac10(k) - fac100 = fs * fac00(k) - fac110 = fs * fac10(k) - fac001 = fs1 * fac01(k) - fac011 = fs1 * fac11(k) - fac101 = fs * fac01(k) - fac111 = fs * fac11(k) - - ind01 = id0(k,17) + js - ind02 = ind01 + 1 - ind03 = ind01 + 9 - ind04 = ind01 + 10 - ind11 = id1(k,17) + js - ind12 = ind11 + 1 - ind13 = ind11 + 9 - ind14 = ind11 + 10 - - inds = indself(k) - indf = indfor (k) - indsp= inds + 1 - indfp= indf + 1 - - do j = 1, NG17 - taug(k,NS17+j) = speccomb & - & * ( fac000 * absa(ind01,j) + fac100 * absa(ind02,j) & - & + fac010 * absa(ind03,j) + fac110 * absa(ind04,j) & - & + fac001 * absa(ind11,j) + fac101 * absa(ind12,j) & - & + fac011 * absa(ind13,j) + fac111 * absa(ind14,j) ) & - & + colamt(k,1) * (selffac(k) * (selfref(inds,j) & - & + selffrac(k) * (selfref(indsp,j)-selfref(inds,j))) & - & + forfac(k) * (forref(indf,j) + forfrac(k) & - & * (forref(indfp,j) - forref(indf,j)))) - enddo - enddo - - do k = laytrop+1, nlay - speccomb = colamt(k,1) + strrat(17)*colamt(k,2) - specmult = 4.0 * min(oneminus, colamt(k,1) / speccomb) - - js = 1 + int(specmult) - fs = mod(specmult, f_one) - fs1= f_one - fs - fac000 = fs1 * fac00(k) - fac010 = fs1 * fac10(k) - fac100 = fs * fac00(k) - fac110 = fs * fac10(k) - fac001 = fs1 * fac01(k) - fac011 = fs1 * fac11(k) - fac101 = fs * fac01(k) - fac111 = fs * fac11(k) - - ind01 = id0(k,17) + js - ind02 = ind01 + 1 - ind03 = ind01 + 5 - ind04 = ind01 + 6 - ind11 = id1(k,17) + js - ind12 = ind11 + 1 - ind13 = ind11 + 5 - ind14 = ind11 + 6 - - indf = indfor(k) - indfp= indf + 1 - - do j = 1, NG17 - taug(k,NS17+j) = speccomb & - & * ( fac000 * absb(ind01,j) + fac100 * absb(ind02,j) & - & + fac010 * absb(ind03,j) + fac110 * absb(ind04,j) & - & + fac001 * absb(ind11,j) + fac101 * absb(ind12,j) & - & + fac011 * absb(ind13,j) + fac111 * absb(ind14,j) ) & - & + colamt(k,1) * forfac(k) * (forref(indf,j) & - & + forfrac(k) * (forref(indfp,j) - forref(indf,j))) - enddo - enddo - - return -!................................... - end subroutine taumol17 -!----------------------------------- - -!>\ingroup module_radsw_main -!> The subroutine computes the optical depth in band 18: 4000-4650 -!! cm-1 (low - h2o,ch4; high - ch4) -!----------------------------------- - subroutine taumol18 -!................................... - -! ------------------------------------------------------------------ ! -! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4) ! -! ------------------------------------------------------------------ ! -! - use module_radsw_kgb18 - -! --- locals: - real (kind=kind_phys) :: speccomb, specmult, tauray, fs, fs1, & - & fac000,fac001,fac010,fac011, fac100,fac101,fac110,fac111 - - integer :: ind01, ind02, ind03, ind04, ind11, ind12, ind13, ind14 - integer :: inds, indf, indsp, indfp, j, js, k - -! -!===> ... begin here -! - -! --- ... compute the optical depth by interpolating in ln(pressure), -! temperature, and appropriate species. below laytrop, the water -! vapor self-continuum is interpolated (in temperature) separately. - - do k = 1, nlay - tauray = colmol(k) * rayl - - do j = 1, NG18 - taur(k,NS18+j) = tauray - enddo - enddo - - do k = 1, laytrop - speccomb = colamt(k,1) + strrat(18)*colamt(k,5) - specmult = 8.0 * min(oneminus, colamt(k,1) / speccomb) - - js = 1 + int(specmult) - fs = mod(specmult, f_one) - fs1= f_one - fs - fac000 = fs1 * fac00(k) - fac010 = fs1 * fac10(k) - fac100 = fs * fac00(k) - fac110 = fs * fac10(k) - fac001 = fs1 * fac01(k) - fac011 = fs1 * fac11(k) - fac101 = fs * fac01(k) - fac111 = fs * fac11(k) - - ind01 = id0(k,18) + js - ind02 = ind01 + 1 - ind03 = ind01 + 9 - ind04 = ind01 + 10 - ind11 = id1(k,18) + js - ind12 = ind11 + 1 - ind13 = ind11 + 9 - ind14 = ind11 + 10 - - inds = indself(k) - indf = indfor (k) - indsp= inds + 1 - indfp= indf + 1 - - do j = 1, NG18 - taug(k,NS18+j) = speccomb & - & * ( fac000 * absa(ind01,j) + fac100 * absa(ind02,j) & - & + fac010 * absa(ind03,j) + fac110 * absa(ind04,j) & - & + fac001 * absa(ind11,j) + fac101 * absa(ind12,j) & - & + fac011 * absa(ind13,j) + fac111 * absa(ind14,j) ) & - & + colamt(k,1) * (selffac(k) * (selfref(inds,j) & - & + selffrac(k) * (selfref(indsp,j)-selfref(inds,j))) & - & + forfac(k) * (forref(indf,j) + forfrac(k) & - & * (forref(indfp,j) - forref(indf,j)))) - enddo - enddo - - do k = laytrop+1, nlay - ind01 = id0(k,18) + 1 - ind02 = ind01 + 1 - ind11 = id1(k,18) + 1 - ind12 = ind11 + 1 - - do j = 1, NG18 - taug(k,NS18+j) = colamt(k,5) & - & * ( fac00(k)*absb(ind01,j) + fac10(k)*absb(ind02,j) & - & + fac01(k)*absb(ind11,j) + fac11(k)*absb(ind12,j) ) - enddo - enddo - - return -!................................... - end subroutine taumol18 -!----------------------------------- - -!>\ingroup module_radsw_main -!> The subroutine computes the optical depth in band 19: 4650-5150 -!! cm-1 (low - h2o,co2; high - co2) -!----------------------------------- - subroutine taumol19 -!................................... - -! ------------------------------------------------------------------ ! -! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2) ! -! ------------------------------------------------------------------ ! -! - use module_radsw_kgb19 - -! --- locals: - real (kind=kind_phys) :: speccomb, specmult, tauray, fs, fs1, & - & fac000,fac001,fac010,fac011, fac100,fac101,fac110,fac111 - - integer :: ind01, ind02, ind03, ind04, ind11, ind12, ind13, ind14 - integer :: inds, indf, indsp, indfp, j, js, k - -! -!===> ... begin here -! - -! --- ... compute the optical depth by interpolating in ln(pressure), -! temperature, and appropriate species. below laytrop, the water -! vapor self-continuum is interpolated (in temperature) separately. - - do k = 1, nlay - tauray = colmol(k) * rayl - - do j = 1, NG19 - taur(k,NS19+j) = tauray - enddo - enddo - - do k = 1, laytrop - speccomb = colamt(k,1) + strrat(19)*colamt(k,2) - specmult = 8.0 * min(oneminus, colamt(k,1) / speccomb) - - js = 1 + int(specmult) - fs = mod(specmult, f_one) - fs1= f_one - fs - fac000 = fs1 * fac00(k) - fac010 = fs1 * fac10(k) - fac100 = fs * fac00(k) - fac110 = fs * fac10(k) - fac001 = fs1 * fac01(k) - fac011 = fs1 * fac11(k) - fac101 = fs * fac01(k) - fac111 = fs * fac11(k) - - ind01 = id0(k,19) + js - ind02 = ind01 + 1 - ind03 = ind01 + 9 - ind04 = ind01 + 10 - ind11 = id1(k,19) + js - ind12 = ind11 + 1 - ind13 = ind11 + 9 - ind14 = ind11 + 10 - - inds = indself(k) - indf = indfor (k) - indsp= inds + 1 - indfp= indf + 1 - - do j = 1, NG19 - taug(k,NS19+j) = speccomb & - & * ( fac000 * absa(ind01,j) + fac100 * absa(ind02,j) & - & + fac010 * absa(ind03,j) + fac110 * absa(ind04,j) & - & + fac001 * absa(ind11,j) + fac101 * absa(ind12,j) & - & + fac011 * absa(ind13,j) + fac111 * absa(ind14,j) ) & - & + colamt(k,1) * (selffac(k) * (selfref(inds,j) & - & + selffrac(k) * (selfref(indsp,j)-selfref(inds,j))) & - & + forfac(k) * (forref(indf,j) + forfrac(k) & - & * (forref(indfp,j) - forref(indf,j)))) - enddo - enddo - - do k = laytrop+1, nlay - ind01 = id0(k,19) + 1 - ind02 = ind01 + 1 - ind11 = id1(k,19) + 1 - ind12 = ind11 + 1 - - do j = 1, NG19 - taug(k,NS19+j) = colamt(k,2) & - & * ( fac00(k)*absb(ind01,j) + fac10(k)*absb(ind02,j) & - & + fac01(k)*absb(ind11,j) + fac11(k)*absb(ind12,j) ) - enddo - enddo - -!................................... - end subroutine taumol19 -!----------------------------------- - -!>\ingroup module_radsw_main -!> The subroutine computes the optical depth in band 20: 5150-6150 -!! cm-1 (low - h2o; high - h2o) -!----------------------------------- - subroutine taumol20 -!................................... - -! ------------------------------------------------------------------ ! -! band 20: 5150-6150 cm-1 (low - h2o; high - h2o) ! -! ------------------------------------------------------------------ ! -! - use module_radsw_kgb20 - -! --- locals: - real (kind=kind_phys) :: tauray - - integer :: ind01, ind02, ind11, ind12 - integer :: inds, indf, indsp, indfp, j, k - -! -!===> ... begin here -! - -! --- ... compute the optical depth by interpolating in ln(pressure), -! temperature, and appropriate species. below laytrop, the water -! vapor self-continuum is interpolated (in temperature) separately. - - do k = 1, nlay - tauray = colmol(k) * rayl - - do j = 1, NG20 - taur(k,NS20+j) = tauray - enddo - enddo - - do k = 1, laytrop - ind01 = id0(k,20) + 1 - ind02 = ind01 + 1 - ind11 = id1(k,20) + 1 - ind12 = ind11 + 1 - - inds = indself(k) - indf = indfor (k) - indsp= inds + 1 - indfp= indf + 1 - - do j = 1, NG20 - taug(k,NS20+j) = colamt(k,1) & - & * ( (fac00(k)*absa(ind01,j) + fac10(k)*absa(ind02,j) & - & + fac01(k)*absa(ind11,j) + fac11(k)*absa(ind12,j)) & - & + selffac(k) * (selfref(inds,j) + selffrac(k) & - & * (selfref(indsp,j) - selfref(inds,j))) & - & + forfac(k) * (forref(indf,j) + forfrac(k) & - & * (forref(indfp,j) - forref(indf,j))) ) & - & + colamt(k,5) * absch4(j) - enddo - enddo - - do k = laytrop+1, nlay - ind01 = id0(k,20) + 1 - ind02 = ind01 + 1 - ind11 = id1(k,20) + 1 - ind12 = ind11 + 1 - - indf = indfor(k) - indfp= indf + 1 - - do j = 1, NG20 - taug(k,NS20+j) = colamt(k,1) & - & * ( fac00(k)*absb(ind01,j) + fac10(k)*absb(ind02,j) & - & + fac01(k)*absb(ind11,j) + fac11(k)*absb(ind12,j) & - & + forfac(k) * (forref(indf,j) + forfrac(k) & - & * (forref(indfp,j) - forref(indf,j))) ) & - & + colamt(k,5) * absch4(j) - enddo - enddo - - return -!................................... - end subroutine taumol20 -!----------------------------------- - -!>\ingroup module_radsw_main -!> The subroutine computes the optical depth in band 21: 6150-7700 -!! cm-1 (low - h2o,co2; high - h2o,co2) -!----------------------------------- - subroutine taumol21 -!................................... - -! ------------------------------------------------------------------ ! -! band 21: 6150-7700 cm-1 (low - h2o,co2; high - h2o,co2) ! -! ------------------------------------------------------------------ ! -! - use module_radsw_kgb21 - -! --- locals: - real (kind=kind_phys) :: speccomb, specmult, tauray, fs, fs1, & - & fac000,fac001,fac010,fac011, fac100,fac101,fac110,fac111 - - integer :: ind01, ind02, ind03, ind04, ind11, ind12, ind13, ind14 - integer :: inds, indf, indsp, indfp, j, js, k - -! -!===> ... begin here -! - -! --- ... compute the optical depth by interpolating in ln(pressure), -! temperature, and appropriate species. below laytrop, the water -! vapor self-continuum is interpolated (in temperature) separately. - - do k = 1, nlay - tauray = colmol(k) * rayl - - do j = 1, NG21 - taur(k,NS21+j) = tauray - enddo - enddo - - do k = 1, laytrop - speccomb = colamt(k,1) + strrat(21)*colamt(k,2) - specmult = 8.0 * min(oneminus, colamt(k,1) / speccomb) - - js = 1 + int(specmult) - fs = mod(specmult, f_one) - fs1= f_one - fs - fac000 = fs1 * fac00(k) - fac010 = fs1 * fac10(k) - fac100 = fs * fac00(k) - fac110 = fs * fac10(k) - fac001 = fs1 * fac01(k) - fac011 = fs1 * fac11(k) - fac101 = fs * fac01(k) - fac111 = fs * fac11(k) - - ind01 = id0(k,21) + js - ind02 = ind01 + 1 - ind03 = ind01 + 9 - ind04 = ind01 + 10 - ind11 = id1(k,21) + js - ind12 = ind11 + 1 - ind13 = ind11 + 9 - ind14 = ind11 + 10 - - inds = indself(k) - indf = indfor (k) - indsp= inds + 1 - indfp= indf + 1 - - do j = 1, NG21 - taug(k,NS21+j) = speccomb & - & * ( fac000 * absa(ind01,j) + fac100 * absa(ind02,j) & - & + fac010 * absa(ind03,j) + fac110 * absa(ind04,j) & - & + fac001 * absa(ind11,j) + fac101 * absa(ind12,j) & - & + fac011 * absa(ind13,j) + fac111 * absa(ind14,j) ) & - & + colamt(k,1) * (selffac(k) * (selfref(inds,j) & - & + selffrac(k) * (selfref(indsp,j) - selfref(inds,j))) & - & + forfac(k) * (forref(indf,j) + forfrac(k) & - & * (forref(indfp,j) - forref(indf,j)))) - enddo - enddo - - do k = laytrop+1, nlay - speccomb = colamt(k,1) + strrat(21)*colamt(k,2) - specmult = 4.0 * min(oneminus, colamt(k,1) / speccomb) - - js = 1 + int(specmult) - fs = mod(specmult, f_one) - fs1= f_one - fs - fac000 = fs1 * fac00(k) - fac010 = fs1 * fac10(k) - fac100 = fs * fac00(k) - fac110 = fs * fac10(k) - fac001 = fs1 * fac01(k) - fac011 = fs1 * fac11(k) - fac101 = fs * fac01(k) - fac111 = fs * fac11(k) - - ind01 = id0(k,21) + js - ind02 = ind01 + 1 - ind03 = ind01 + 5 - ind04 = ind01 + 6 - ind11 = id1(k,21) + js - ind12 = ind11 + 1 - ind13 = ind11 + 5 - ind14 = ind11 + 6 - - indf = indfor(k) - indfp= indf + 1 - - do j = 1, NG21 - taug(k,NS21+j) = speccomb & - & * ( fac000 * absb(ind01,j) + fac100 * absb(ind02,j) & - & + fac010 * absb(ind03,j) + fac110 * absb(ind04,j) & - & + fac001 * absb(ind11,j) + fac101 * absb(ind12,j) & - & + fac011 * absb(ind13,j) + fac111 * absb(ind14,j) ) & - & + colamt(k,1) * forfac(k) * (forref(indf,j) & - & + forfrac(k) * (forref(indfp,j) - forref(indf,j))) - enddo - enddo - -!................................... - end subroutine taumol21 -!----------------------------------- - -!>\ingroup module_radsw_main -!> The subroutine computes the optical depth in band 22: 7700-8050 -!! cm-1 (low - h2o,o2; high - o2) -!----------------------------------- - subroutine taumol22 -!................................... - -! ------------------------------------------------------------------ ! -! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2) ! -! ------------------------------------------------------------------ ! -! - use module_radsw_kgb22 - -! --- locals: - real (kind=kind_phys) :: speccomb, specmult, tauray, fs, fs1, & - & fac000,fac001,fac010,fac011, fac100,fac101,fac110,fac111, & - & o2adj, o2cont, o2tem - - integer :: ind01, ind02, ind03, ind04, ind11, ind12, ind13, ind14 - integer :: inds, indf, indsp, indfp, j, js, k - -! -!===> ... begin here -! -! --- ... the following factor is the ratio of total o2 band intensity (lines -! and mate continuum) to o2 band intensity (line only). it is needed -! to adjust the optical depths since the k's include only lines. - - o2adj = 1.6 - o2tem = 4.35e-4 / (350.0*2.0) - - -! --- ... compute the optical depth by interpolating in ln(pressure), -! temperature, and appropriate species. below laytrop, the water -! vapor self-continuum is interpolated (in temperature) separately. - - do k = 1, nlay - tauray = colmol(k) * rayl - - do j = 1, NG22 - taur(k,NS22+j) = tauray - enddo - enddo - - do k = 1, laytrop - o2cont = o2tem * colamt(k,6) - speccomb = colamt(k,1) + strrat(22)*colamt(k,6) - specmult = 8.0 * min(oneminus, colamt(k,1) / speccomb) - - js = 1 + int(specmult) - fs = mod(specmult, f_one) - fs1= f_one - fs - fac000 = fs1 * fac00(k) - fac010 = fs1 * fac10(k) - fac100 = fs * fac00(k) - fac110 = fs * fac10(k) - fac001 = fs1 * fac01(k) - fac011 = fs1 * fac11(k) - fac101 = fs * fac01(k) - fac111 = fs * fac11(k) - - ind01 = id0(k,22) + js - ind02 = ind01 + 1 - ind03 = ind01 + 9 - ind04 = ind01 + 10 - ind11 = id1(k,22) + js - ind12 = ind11 + 1 - ind13 = ind11 + 9 - ind14 = ind11 + 10 - - inds = indself(k) - indf = indfor (k) - indsp= inds + 1 - indfp= indf + 1 - - do j = 1, NG22 - taug(k,NS22+j) = speccomb & - & * ( fac000 * absa(ind01,j) + fac100 * absa(ind02,j) & - & + fac010 * absa(ind03,j) + fac110 * absa(ind04,j) & - & + fac001 * absa(ind11,j) + fac101 * absa(ind12,j) & - & + fac011 * absa(ind13,j) + fac111 * absa(ind14,j) ) & - & + colamt(k,1) * (selffac(k) * (selfref(inds,j) & - & + selffrac(k) * (selfref(indsp,j)-selfref(inds,j))) & - & + forfac(k) * (forref(indf,j) + forfrac(k) & - & * (forref(indfp,j) - forref(indf,j)))) + o2cont - enddo - enddo - - do k = laytrop+1, nlay - o2cont = o2tem * colamt(k,6) - - ind01 = id0(k,22) + 1 - ind02 = ind01 + 1 - ind11 = id1(k,22) + 1 - ind12 = ind11 + 1 - - do j = 1, NG22 - taug(k,NS22+j) = colamt(k,6) * o2adj & - & * ( fac00(k)*absb(ind01,j) + fac10(k)*absb(ind02,j) & - & + fac01(k)*absb(ind11,j) + fac11(k)*absb(ind12,j) ) & - & + o2cont - enddo - enddo - - return -!................................... - end subroutine taumol22 -!----------------------------------- - -!>\ingroup module_radsw_main -!> The subroutine computes the optical depth in band 23: 8050-12850 -!! cm-1 (low - h2o; high - nothing) -!----------------------------------- - subroutine taumol23 -!................................... - -! ------------------------------------------------------------------ ! -! band 23: 8050-12850 cm-1 (low - h2o; high - nothing) ! -! ------------------------------------------------------------------ ! -! - use module_radsw_kgb23 - -! --- locals: - integer :: ind01, ind02, ind11, ind12 - integer :: inds, indf, indsp, indfp, j, k - -! -!===> ... begin here -! - -! --- ... compute the optical depth by interpolating in ln(pressure), -! temperature, and appropriate species. below laytrop, the water -! vapor self-continuum is interpolated (in temperature) separately. - - do k = 1, nlay - do j = 1, NG23 - taur(k,NS23+j) = colmol(k) * rayl(j) - enddo - enddo - - do k = 1, laytrop - ind01 = id0(k,23) + 1 - ind02 = ind01 + 1 - ind11 = id1(k,23) + 1 - ind12 = ind11 + 1 - - inds = indself(k) - indf = indfor (k) - indsp= inds + 1 - indfp= indf + 1 - - do j = 1, NG23 - taug(k,NS23+j) = colamt(k,1) * (givfac & - & * ( fac00(k)*absa(ind01,j) + fac10(k)*absa(ind02,j) & - & + fac01(k)*absa(ind11,j) + fac11(k)*absa(ind12,j) ) & - & + selffac(k) * (selfref(inds,j) + selffrac(k) & - & * (selfref(indsp,j) - selfref(inds,j))) & - & + forfac(k) * (forref(indf,j) + forfrac(k) & - & * (forref(indfp,j) - forref(indf,j)))) - enddo - enddo - - do k = laytrop+1, nlay - do j = 1, NG23 - taug(k,NS23+j) = f_zero - enddo - enddo - -!................................... - end subroutine taumol23 -!----------------------------------- - -!>\ingroup module_radsw_main -!> The subroutine computes the optical depth in band 24: 12850-16000 -!! cm-1 (low - h2o,o2; high - o2) -!----------------------------------- - subroutine taumol24 -!................................... - -! ------------------------------------------------------------------ ! -! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2) ! -! ------------------------------------------------------------------ ! -! - use module_radsw_kgb24 - -! --- locals: - real (kind=kind_phys) :: speccomb, specmult, fs, fs1, & - & fac000,fac001,fac010,fac011, fac100,fac101,fac110,fac111 - - integer :: ind01, ind02, ind03, ind04, ind11, ind12, ind13, ind14 - integer :: inds, indf, indsp, indfp, j, js, k - -! -!===> ... begin here -! - -! --- ... compute the optical depth by interpolating in ln(pressure), -! temperature, and appropriate species. below laytrop, the water -! vapor self-continuum is interpolated (in temperature) separately. - - do k = 1, laytrop - speccomb = colamt(k,1) + strrat(24)*colamt(k,6) - specmult = 8.0 * min(oneminus, colamt(k,1) / speccomb) - - js = 1 + int(specmult) - fs = mod(specmult, f_one) - fs1= f_one - fs - fac000 = fs1 * fac00(k) - fac010 = fs1 * fac10(k) - fac100 = fs * fac00(k) - fac110 = fs * fac10(k) - fac001 = fs1 * fac01(k) - fac011 = fs1 * fac11(k) - fac101 = fs * fac01(k) - fac111 = fs * fac11(k) - - ind01 = id0(k,24) + js - ind02 = ind01 + 1 - ind03 = ind01 + 9 - ind04 = ind01 + 10 - ind11 = id1(k,24) + js - ind12 = ind11 + 1 - ind13 = ind11 + 9 - ind14 = ind11 + 10 - - inds = indself(k) - indf = indfor (k) - indsp= inds + 1 - indfp= indf + 1 - - do j = 1, NG24 - taug(k,NS24+j) = speccomb & - & * ( fac000 * absa(ind01,j) + fac100 * absa(ind02,j) & - & + fac010 * absa(ind03,j) + fac110 * absa(ind04,j) & - & + fac001 * absa(ind11,j) + fac101 * absa(ind12,j) & - & + fac011 * absa(ind13,j) + fac111 * absa(ind14,j) ) & - & + colamt(k,3) * abso3a(j) + colamt(k,1) & - & * (selffac(k) * (selfref(inds,j) + selffrac(k) & - & * (selfref(indsp,j) - selfref(inds,j))) & - & + forfac(k) * (forref(indf,j) + forfrac(k) & - & * (forref(indfp,j) - forref(indf,j)))) - - taur(k,NS24+j) = colmol(k) & - & * (rayla(j,js) + fs*(rayla(j,js+1) - rayla(j,js))) - enddo - enddo - - do k = laytrop+1, nlay - ind01 = id0(k,24) + 1 - ind02 = ind01 + 1 - ind11 = id1(k,24) + 1 - ind12 = ind11 + 1 - - do j = 1, NG24 - taug(k,NS24+j) = colamt(k,6) & - & * ( fac00(k)*absb(ind01,j) + fac10(k)*absb(ind02,j) & - & + fac01(k)*absb(ind11,j) + fac11(k)*absb(ind12,j) ) & - & + colamt(k,3) * abso3b(j) - - taur(k,NS24+j) = colmol(k) * raylb(j) - enddo - enddo - - return -!................................... - end subroutine taumol24 -!----------------------------------- - -!>\ingroup module_radsw_main -!> The subroutine computes the optical depth in band 25: 16000-22650 -!! cm-1 (low - h2o; high - nothing) -!----------------------------------- - subroutine taumol25 -!................................... - -! ------------------------------------------------------------------ ! -! band 25: 16000-22650 cm-1 (low - h2o; high - nothing) ! -! ------------------------------------------------------------------ ! -! - use module_radsw_kgb25 - -! --- locals: - integer :: ind01, ind02, ind11, ind12 - integer :: j, k - -! -!===> ... begin here -! - -! --- ... compute the optical depth by interpolating in ln(pressure), -! temperature, and appropriate species. below laytrop, the water -! vapor self-continuum is interpolated (in temperature) separately. - - do k = 1, nlay - do j = 1, NG25 - taur(k,NS25+j) = colmol(k) * rayl(j) - enddo - enddo - - do k = 1, laytrop - ind01 = id0(k,25) + 1 - ind02 = ind01 + 1 - ind11 = id1(k,25) + 1 - ind12 = ind11 + 1 - - do j = 1, NG25 - taug(k,NS25+j) = colamt(k,1) & - & * ( fac00(k)*absa(ind01,j) + fac10(k)*absa(ind02,j) & - & + fac01(k)*absa(ind11,j) + fac11(k)*absa(ind12,j) ) & - & + colamt(k,3) * abso3a(j) - enddo - enddo - - do k = laytrop+1, nlay - do j = 1, NG25 - taug(k,NS25+j) = colamt(k,3) * abso3b(j) - enddo - enddo - - return -!................................... - end subroutine taumol25 -!----------------------------------- - -!>\ingroup module_radsw_main -!> The subroutine computes the optical depth in band 26: 22650-29000 -!! cm-1 (low - nothing; high - nothing) -!----------------------------------- - subroutine taumol26 -!................................... - -! ------------------------------------------------------------------ ! -! band 26: 22650-29000 cm-1 (low - nothing; high - nothing) ! -! ------------------------------------------------------------------ ! -! - use module_radsw_kgb26 - -! --- locals: - integer :: j, k - -! -!===> ... begin here -! - -! --- ... compute the optical depth by interpolating in ln(pressure), -! temperature, and appropriate species. below laytrop, the water -! vapor self-continuum is interpolated (in temperature) separately. - - do k = 1, nlay - do j = 1, NG26 - taug(k,NS26+j) = f_zero - taur(k,NS26+j) = colmol(k) * rayl(j) - enddo - enddo - - return -!................................... - end subroutine taumol26 -!----------------------------------- - -!>\ingroup module_radsw_main -!> The subroutine computes the optical depth in band 27: 29000-38000 -!! cm-1 (low - o3; high - o3) -!----------------------------------- - subroutine taumol27 -!................................... - -! ------------------------------------------------------------------ ! -! band 27: 29000-38000 cm-1 (low - o3; high - o3) ! -! ------------------------------------------------------------------ ! -! - use module_radsw_kgb27 -! -! --- locals: - integer :: ind01, ind02, ind11, ind12 - integer :: j, k - -! -!===> ... begin here -! - -! --- ... compute the optical depth by interpolating in ln(pressure), -! temperature, and appropriate species. below laytrop, the water -! vapor self-continuum is interpolated (in temperature) separately. - - do k = 1, nlay - do j = 1, NG27 - taur(k,NS27+j) = colmol(k) * rayl(j) - enddo - enddo - - do k = 1, laytrop - ind01 = id0(k,27) + 1 - ind02 = ind01 + 1 - ind11 = id1(k,27) + 1 - ind12 = ind11 + 1 - - do j = 1, NG27 - taug(k,NS27+j) = colamt(k,3) & - & * ( fac00(k)*absa(ind01,j) + fac10(k)*absa(ind02,j) & - & + fac01(k)*absa(ind11,j) + fac11(k)*absa(ind12,j) ) - enddo - enddo - - do k = laytrop+1, nlay - ind01 = id0(k,27) + 1 - ind02 = ind01 + 1 - ind11 = id1(k,27) + 1 - ind12 = ind11 + 1 - - do j = 1, NG27 - taug(k,NS27+j) = colamt(k,3) & - & * ( fac00(k)*absb(ind01,j) + fac10(k)*absb(ind02,j) & - & + fac01(k)*absb(ind11,j) + fac11(k)*absb(ind12,j) ) - enddo - enddo - - return -!................................... - end subroutine taumol27 -!----------------------------------- - -!>\ingroup module_radsw_main -!> The subroutine computes the optical depth in band 28: 38000-50000 -!! cm-1 (low - o3,o2; high - o3,o2) -!----------------------------------- - subroutine taumol28 -!................................... - -! ------------------------------------------------------------------ ! -! band 28: 38000-50000 cm-1 (low - o3,o2; high - o3,o2) ! -! ------------------------------------------------------------------ ! -! - use module_radsw_kgb28 - -! --- locals: - real (kind=kind_phys) :: speccomb, specmult, tauray, fs, fs1, & - & fac000,fac001,fac010,fac011, fac100,fac101,fac110,fac111 - - integer :: ind01, ind02, ind03, ind04, ind11, ind12, ind13, ind14 - integer :: j, js, k - -! -!===> ... begin here -! - -! --- ... compute the optical depth by interpolating in ln(pressure), -! temperature, and appropriate species. below laytrop, the water -! vapor self-continuum is interpolated (in temperature) separately. - - do k = 1, nlay - tauray = colmol(k) * rayl - - do j = 1, NG28 - taur(k,NS28+j) = tauray - enddo - enddo - - do k = 1, laytrop - speccomb = colamt(k,3) + strrat(28)*colamt(k,6) - specmult = 8.0 * min(oneminus, colamt(k,3) / speccomb) - - js = 1 + int(specmult) - fs = mod(specmult, f_one) - fs1= f_one - fs - fac000 = fs1 * fac00(k) - fac010 = fs1 * fac10(k) - fac100 = fs * fac00(k) - fac110 = fs * fac10(k) - fac001 = fs1 * fac01(k) - fac011 = fs1 * fac11(k) - fac101 = fs * fac01(k) - fac111 = fs * fac11(k) - - ind01 = id0(k,28) + js - ind02 = ind01 + 1 - ind03 = ind01 + 9 - ind04 = ind01 + 10 - ind11 = id1(k,28) + js - ind12 = ind11 + 1 - ind13 = ind11 + 9 - ind14 = ind11 + 10 - - do j = 1, NG28 - taug(k,NS28+j) = speccomb & - & * ( fac000 * absa(ind01,j) + fac100 * absa(ind02,j) & - & + fac010 * absa(ind03,j) + fac110 * absa(ind04,j) & - & + fac001 * absa(ind11,j) + fac101 * absa(ind12,j) & - & + fac011 * absa(ind13,j) + fac111 * absa(ind14,j) ) - enddo - enddo - - do k = laytrop+1, nlay - speccomb = colamt(k,3) + strrat(28)*colamt(k,6) - specmult = 4.0 * min(oneminus, colamt(k,3) / speccomb) - - js = 1 + int(specmult) - fs = mod(specmult, f_one) - fs1= f_one - fs - fac000 = fs1 * fac00(k) - fac010 = fs1 * fac10(k) - fac100 = fs * fac00(k) - fac110 = fs * fac10(k) - fac001 = fs1 * fac01(k) - fac011 = fs1 * fac11(k) - fac101 = fs * fac01(k) - fac111 = fs * fac11(k) - - ind01 = id0(k,28) + js - ind02 = ind01 + 1 - ind03 = ind01 + 5 - ind04 = ind01 + 6 - ind11 = id1(k,28) + js - ind12 = ind11 + 1 - ind13 = ind11 + 5 - ind14 = ind11 + 6 - - do j = 1, NG28 - taug(k,NS28+j) = speccomb & - & * ( fac000 * absb(ind01,j) + fac100 * absb(ind02,j) & - & + fac010 * absb(ind03,j) + fac110 * absb(ind04,j) & - & + fac001 * absb(ind11,j) + fac101 * absb(ind12,j) & - & + fac011 * absb(ind13,j) + fac111 * absb(ind14,j) ) - enddo - enddo - - return -!................................... - end subroutine taumol28 -!----------------------------------- - -!>\ingroup module_radsw_main -!> The subroutine computes the optical depth in band 29: 820-2600 -!! cm-1 (low - h2o; high - co2) -!----------------------------------- - subroutine taumol29 -!................................... - -! ------------------------------------------------------------------ ! -! band 29: 820-2600 cm-1 (low - h2o; high - co2) ! -! ------------------------------------------------------------------ ! -! - use module_radsw_kgb29 - -! --- locals: - real (kind=kind_phys) :: tauray - - integer :: ind01, ind02, ind11, ind12 - integer :: inds, indf, indsp, indfp, j, k - -! -!===> ... begin here -! - -! --- ... compute the optical depth by interpolating in ln(pressure), -! temperature, and appropriate species. below laytrop, the water -! vapor self-continuum is interpolated (in temperature) separately. - - do k = 1, nlay - tauray = colmol(k) * rayl - - do j = 1, NG29 - taur(k,NS29+j) = tauray - enddo - enddo - - do k = 1, laytrop - ind01 = id0(k,29) + 1 - ind02 = ind01 + 1 - ind11 = id1(k,29) + 1 - ind12 = ind11 + 1 - - inds = indself(k) - indf = indfor (k) - indsp= inds + 1 - indfp= indf + 1 - - do j = 1, NG29 - taug(k,NS29+j) = colamt(k,1) & - & * ( (fac00(k)*absa(ind01,j) + fac10(k)*absa(ind02,j) & - & + fac01(k)*absa(ind11,j) + fac11(k)*absa(ind12,j) ) & - & + selffac(k) * (selfref(inds,j) + selffrac(k) & - & * (selfref(indsp,j) - selfref(inds,j))) & - & + forfac(k) * (forref(indf,j) + forfrac(k) & - & * (forref(indfp,j) - forref(indf,j)))) & - & + colamt(k,2) * absco2(j) - enddo - enddo - - do k = laytrop+1, nlay - ind01 = id0(k,29) + 1 - ind02 = ind01 + 1 - ind11 = id1(k,29) + 1 - ind12 = ind11 + 1 - - do j = 1, NG29 - taug(k,NS29+j) = colamt(k,2) & - & * ( fac00(k)*absb(ind01,j) + fac10(k)*absb(ind02,j) & - & + fac01(k)*absb(ind11,j) + fac11(k)*absb(ind12,j) ) & - & + colamt(k,1) * absh2o(j) - enddo - enddo - - return -!................................... - end subroutine taumol29 -!----------------------------------- - -!................................... - end subroutine taumol -!----------------------------------- -!! @} - -! -!........................................! - end module rrtmg_sw ! -!========================================! diff --git a/physics/radsw_main.meta b/physics/radsw_main.meta index 49e9cc6b3..692042937 100644 --- a/physics/radsw_main.meta +++ b/physics/radsw_main.meta @@ -234,30 +234,6 @@ kind = kind_phys intent = in optional = F -[iswcliq] - standard_name = flag_for_optical_property_for_liquid_clouds_for_shortwave_radiation - long_name = sw optical property for liquid clouds - units = flag - dimensions = () - type = integer - intent = in - optional = F -[iovrsw] - standard_name = flag_for_cloud_overlapping_method_for_shortwave_radiation - long_name = control flag for cloud overlapping method for SW - units = flag - dimensions = () - type = integer - intent = in - optional = F -[isubcsw] - standard_name = flag_for_sw_clouds_grid_approximation - long_name = flag for sw clouds sub-grid approximation - units = flag - dimensions = () - type = integer - intent = in - optional = F [cosz] standard_name = cosine_of_zenith_angle long_name = cosine of the solar zenit angle @@ -464,22 +440,6 @@ kind = kind_phys intent = in optional = T -[mpirank] - standard_name = mpi_rank - long_name = current MPI-rank - units = index - dimensions = () - type = integer - intent = in - optional = F -[mpiroot] - standard_name = mpi_root - long_name = master MPI-rank - units = index - dimensions = () - type = integer - intent = in - optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 2933be7ef786d843e9eb7e8cfb793bfcdda6f2e2 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 8 Apr 2020 06:09:44 -0600 Subject: [PATCH 9/9] Cleanup comments in newly added/modified radiation code --- physics/physparam.f | 4 ++-- physics/radiation_clouds.f | 21 +++++++++++---------- physics/radsw_main.F90 | 4 ++-- 3 files changed, 15 insertions(+), 14 deletions(-) diff --git a/physics/physparam.f b/physics/physparam.f index e722297de..3c5d22186 100644 --- a/physics/physparam.f +++ b/physics/physparam.f @@ -234,7 +234,7 @@ module physparam !!\n =1:use maximum-random cloud overlapping method !!\n =2:use maximum cloud overlapping method !!\n =3:use decorrelation length overlapping method -!!\n =4: exponential overlapping cloud +!!\n =4:use exponential overlapping cloud method !!\n Opr GFS/CFS=1; see IOVR_SW in run scripts integer, save :: iovrsw = 1 !> cloud overlapping control flag for LW @@ -242,7 +242,7 @@ module physparam !!\n =1:use maximum-random cloud overlapping method !!\n =2:use maximum cloud overlapping method !!\n =3:use decorrelation length overlapping method -!!\n =4: exponential overlapping cloud +!!\n =4:use exponential overlapping cloud method !!\n Opr GFS/CFS=1; see IOVR_LW in run scripts integer, save :: iovrlw = 1 diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index 8a943a032..96c3dd664 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -241,7 +241,6 @@ module module_radiation_clouds real (kind=kind_phys), parameter :: cldasy_def = 0.84 !< default cld asymmetry factor integer :: llyr = 2 !< upper limit of boundary layer clouds -! DH* TODO - HOW TO GET/SET THIS CORRECTLY? integer :: iovr = 1 !< maximum-random cloud overlapping method public progcld1, progcld2, progcld3, progcld4, progclduni, & @@ -2341,13 +2340,13 @@ end subroutine progcld4o !----------------------------------- !> \ingroup module_radiation_clouds -!! This subroutine computes cloud related quantities using Thompson/WSM6 cloud -!! microphysics scheme. +!! This subroutine computes cloud related quantities using +!! Ferrier-Aligo cloud microphysics scheme. subroutine progcld5 & & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw, & ! --- inputs: & xlat,xlon,slmsk,dz,delp, & & ntrac,ntcw,ntiw,ntrw,ntsw,ntgl, & - & IX, NLAY, NLP1,icloud, & + & IX, NLAY, NLP1, icloud, & & uni_cld, lmfshal, lmfdeep2, cldcov, & & re_cloud,re_ice,re_snow, & & clouds,clds,mtop,mbot,de_lgth & ! --- outputs: @@ -2356,7 +2355,7 @@ subroutine progcld5 & ! ================= subprogram documentation block ================ ! ! ! ! subprogram: progcld5 computes cloud related quantities using ! -! Thompson/WSM6 cloud microphysics scheme. ! +! Ferrier-Aligo cloud microphysics scheme. ! ! ! ! abstract: this program computes cloud fractions from cloud ! ! condensates, ! @@ -2393,6 +2392,7 @@ subroutine progcld5 & ! delp (ix,nlay) : model layer pressure thickness in mb (100Pa) ! ! IX : horizontal dimention ! ! NLAY,NLP1 : vertical layer/level dimensions ! +! icloud : cloud effect to the optical depth in radiation ! ! uni_cld : logical - true for cloud fraction from shoc ! ! lmfshal : logical - true for mass flux shallow convection ! ! lmfdeep2 : logical - true for mass flux deep convection ! @@ -2755,7 +2755,8 @@ end subroutine progcld5 !................................... -!mz: progcld5 benchmark +!mz: this is the original progcld5 for Thompson MP (and WSM6), +! to be replaced by the GSL version of progcld6 for Thompson MP subroutine progcld6 & & ( plyr,plvl,tlyr,qlyr,qstl,rhly,clw, & ! --- inputs: & xlat,xlon,slmsk,dz,delp, & @@ -2768,8 +2769,8 @@ subroutine progcld6 & ! ================= subprogram documentation block ================ ! ! ! -! subprogram: progcld5 computes cloud related quantities using ! -! Thompson/WSM6 cloud microphysics scheme. ! +! subprogram: progcld6 computes cloud related quantities using ! +! Thompson/WSM6 cloud microphysics scheme. ! ! ! ! abstract: this program computes cloud fractions from cloud ! ! condensates, ! @@ -2778,7 +2779,7 @@ subroutine progcld6 & ! top and base. the three vertical cloud domains are set up in the ! ! initial subroutine "cld_init". ! ! ! -! usage: call progcld5 ! +! usage: call progcld6 ! ! ! ! subprograms called: gethml ! ! ! @@ -3883,7 +3884,7 @@ end subroutine gethml !.. cloud fraction and is relatively good at getting widespread stratus !.. and stratoCu without caring whether any deep/shallow Cu param schemes !.. is making sub-grid-spacing clouds/precip. Under the hood, this -!.. scheme follows Mocko and Cotton (1995) in applicaiton of the +!.. scheme follows Mocko and Cotton (1995) in application of the !.. Sundqvist et al (1989) scheme but using a grid-scale dependent !.. RH threshold, one each for land v. ocean points based on !.. experiences with HWRF testing. diff --git a/physics/radsw_main.F90 b/physics/radsw_main.F90 index 51512835c..924d750b1 100644 --- a/physics/radsw_main.F90 +++ b/physics/radsw_main.F90 @@ -1228,7 +1228,7 @@ subroutine rrtmg_sw_run & do k = 1, nlay zcf0 = zcf0 * (f_one - cfrac(k)) enddo - else if (iovrsw == 1 .or. iovrsw == 4) then ! max/ra/exp overlapping + else if (iovrsw == 1 .or. iovrsw == 4) then ! max/ran/exp overlapping do k = 1, nlay if (cfrac(k) > ftiny) then ! cloudy layer zcf1 = min ( zcf1, f_one-cfrac(k) ) @@ -2068,7 +2068,7 @@ subroutine cldprop & !> -# if physparam::isubcsw > 0, call mcica_subcol() to distribute !! cloud properties to each g-point. - if ( isubcsw > 0 .and. iovrsw /= 4 ) then ! mcica sub-col clouds approx + if ( isubcsw > 0 .and. iovrsw /= 4 ) then ! mcica sub-col clouds approx cldf(:) = cfrac(:) where (cldf(:) < ftiny)