From 8ba1c3c74ef8e19e8652480a626cd05ba2b03515 Mon Sep 17 00:00:00 2001 From: "andrew.hazelton" Date: Wed, 4 Mar 2020 21:45:58 +0000 Subject: [PATCH 01/42] Changes to EDMF-HAFS and EDMF-TKE to OutputEddy Diffusivity --- physics/moninedmf_hafs.f | 11 +++++++++-- physics/moninedmf_hafs.meta | 9 +++++++++ physics/satmedmfvdifq.F | 11 +++++++++-- physics/satmedmfvdifq.meta | 9 +++++++++ 4 files changed, 36 insertions(+), 4 deletions(-) diff --git a/physics/moninedmf_hafs.f b/physics/moninedmf_hafs.f index 5c6ff85a8..2bc682909 100644 --- a/physics/moninedmf_hafs.f +++ b/physics/moninedmf_hafs.f @@ -64,7 +64,7 @@ subroutine hedmf_hafs_run(ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & & prsi,del,prsl,prslk,phii,phil,delt,dspheat, & & dusfc,dvsfc,dtsfc,dqsfc,hpbl,hgamt,hgamq,dkt, & & kinver,xkzm_m,xkzm_h,xkzm_s,lprnt,ipr, & - & xkzminv,moninq_fac,islimsk,errmsg,errflg) + & xkzminv,moninq_fac,islimsk,dkudiagnostic,errmsg,errflg) ! use machine , only : kind_phys use funcphys , only : fpvs @@ -144,7 +144,7 @@ subroutine hedmf_hafs_run(ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & & ti(im,km-1), shr2(im,km-1), & & al(im,km-1), ad(im,km), & & au(im,km-1), a1(im,km), & - & a2(im,km*ntrac) + & a2(im,km*ntrac), dkudiagnostic(im,km-1) ! real(kind=kind_phys) tcko(im,km), qcko(im,km,ntrac), & & ucko(im,km), vcko(im,km), xmf(im,km) @@ -1395,6 +1395,13 @@ subroutine hedmf_hafs_run(ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & ! enddo enddo + + do k = 1,km1 + do i=1,im + dkudiagnostic(i,k) = dku(i,k) + enddo + enddo + ! ! solve tridiagonal problem for momentum ! diff --git a/physics/moninedmf_hafs.meta b/physics/moninedmf_hafs.meta index bc1461ada..f22ccbb25 100644 --- a/physics/moninedmf_hafs.meta +++ b/physics/moninedmf_hafs.meta @@ -507,6 +507,15 @@ type = integer intent = in optional = F +[dkudiagnostic] + standard_name = atmosphere_momentum_diffusivity + long_name = diffusivity for momentum + units = m2 s-1 + dimensions = (horizontal_dimension,vertical_dimension_minus_one) + type = real + kind = kind_phys + intent = out + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index 546cefca6..0fd44ac0b 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -65,7 +65,7 @@ subroutine satmedmfvdifq_run(ix,im,km,ntrac,ntcw,ntiw,ntke, & & prsi,del,prsl,prslk,phii,phil,delt, & & dspheat,dusfc,dvsfc,dtsfc,dqsfc,hpbl, & & kinver,xkzm_m,xkzm_h,xkzm_s,dspfac,bl_upfr,bl_dnfr, & - & errmsg,errflg) + & dkudiagnostic,errmsg,errflg) ! use machine , only : kind_phys use funcphys , only : fpvs @@ -123,7 +123,8 @@ subroutine satmedmfvdifq_run(ix,im,km,ntrac,ntcw,ntiw,ntke, & & slx(im,km), svx(im,km), qtx(im,km), & tvx(im,km), pix(im,km), radx(im,km-1), & dku(im,km-1),dkt(im,km-1), dkq(im,km-1), - & cku(im,km-1),ckt(im,km-1) + & cku(im,km-1),ckt(im,km-1), + & dkudiagnostic(im,km-1) ! real(kind=kind_phys) plyr(im,km), rhly(im,km), cfly(im,km), & qstl(im,km) @@ -1383,6 +1384,12 @@ subroutine satmedmfvdifq_run(ix,im,km,ntrac,ntcw,ntiw,ntke, & ! enddo enddo + + do k = 1,km1 + do i=1,im + dkudiagnostic(i,k) = dku(i,k) + enddo + enddo c c solve tridiagonal problem for momentum c diff --git a/physics/satmedmfvdifq.meta b/physics/satmedmfvdifq.meta index ec679faec..b63e3ae40 100644 --- a/physics/satmedmfvdifq.meta +++ b/physics/satmedmfvdifq.meta @@ -578,6 +578,15 @@ kind = kind_phys intent = in optional = F +[dkudiagnostic] + standard_name = atmosphere_momentum_diffusivity + long_name = diffusivity for momentum + units = m2 s-1 + dimensions = (horizontal_dimension,vertical_dimension_minus_one) + type = real + kind = kind_phys + intent = out + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 1df7376ed7293b29495f1b2b089cd6eb2862708b Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Fri, 3 Apr 2020 09:44:51 -0600 Subject: [PATCH 02/42] Update CODEOWNERS for HWRF physics development --- CODEOWNERS | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CODEOWNERS b/CODEOWNERS index 0d5230f89..a419f106a 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -3,7 +3,7 @@ # These owners will be the default owners for everything in the repo. #* @defunkt -* @climbfuji @llpcarson @grantfirl @JulieSchramm +* @climbfuji @llpcarson @grantfirl @mzhangw # Order is important. The last matching pattern has the most precedence. # So if a pull request only touches javascript files, only these owners From 10867d1b84eea12e8a9effef712965249830b9f5 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Tue, 10 Dec 2019 11:58:48 -0700 Subject: [PATCH 03/42] add hurricane-specific code to moninedmf.f --- physics/moninedmf.f | 366 ++++++++++++++++++++++++++++++++++------- physics/moninedmf.meta | 43 +++++ 2 files changed, 348 insertions(+), 61 deletions(-) diff --git a/physics/moninedmf.f b/physics/moninedmf.f index 1084aa426..a9532857c 100644 --- a/physics/moninedmf.f +++ b/physics/moninedmf.f @@ -64,7 +64,8 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & & prsi,del,prsl,prslk,phii,phil,delt,dspheat, & & dusfc,dvsfc,dtsfc,dqsfc,hpbl,hgamt,hgamq,dkt, & & kinver,xkzm_m,xkzm_h,xkzm_s,lprnt,ipr, & - & xkzminv,moninq_fac,errmsg,errflg) + & xkzminv,moninq_fac,hurr_pbl,islimsk,var_ric, & + & coef_ric_l,coef_ric_s,errmsg,errflg) ! use machine , only : kind_phys use funcphys , only : fpvs @@ -74,14 +75,15 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & ! ! arguments ! - logical, intent(in) :: lprnt - integer, intent(in) :: ipr + logical, intent(in) :: lprnt, hurr_pbl + integer, intent(in) :: ipr, islimsk(im) integer, intent(in) :: ix, im, km, ntrac, ntcw, kinver(im) integer, intent(out) :: kpbl(im) ! real(kind=kind_phys), intent(in) :: delt, xkzm_m, xkzm_h, xkzm_s - real(kind=kind_phys), intent(in) :: xkzminv, moninq_fac + real(kind=kind_phys), intent(in) :: xkzminv, moninq_fac, var_ric, & + & coef_ric_l, coef_ric_s real(kind=kind_phys), intent(inout) :: dv(im,km), du(im,km), & & tau(im,km), rtg(im,km,ntrac) real(kind=kind_phys), intent(in) :: & @@ -180,7 +182,15 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & & ptem, ptem1, ptem2, tx1(im), tx2(im) ! real(kind=kind_phys) zstblmax,h1, h2, qlcr, actei, - & cldtime + & cldtime, ttend_fac + + !! for hurricane application + real(kind=kind_phys) wspm(im,km-1) + integer kLOC ! RGF + real :: xDKU ! RGF + + integer, parameter :: useshape=2!0-- no change, original ALPHA adjustment,1-- shape1, 2-- shape2(adjust above sfc) + real :: smax,ashape,sz2h, sksfc,skmax,ashape1,skminusk0, hmax cc parameter(gravi=1.0/grav) parameter(g=grav) @@ -211,6 +221,8 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & parameter (zstblmax = 2500., qlcr=3.5e-5) ! parameter (actei = 0.23) parameter (actei = 0.7) + + c c----------------------------------------------------------------------- c @@ -422,23 +434,48 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & !! The temperature of the thermal is of primary importance. For the initial estimate of the PBL height, the thermal is assumed to have one of two temperatures. If the boundary layer is stable, the thermal is assumed to have a temperature equal to the surface virtual temperature. Otherwise, the thermal is assumed to have the same virtual potential temperature as the lowest model level. For the stable case, the critical bulk Richardson number becomes a function of the wind speed and roughness length, otherwise it is set to a tunable constant. ! compute the pbl height ! - do i=1,im - flg(i) = .false. - rbup(i) = rbsoil(i) -! - if(pblflg(i)) then - thermal(i) = thvx(i,1) - crb(i) = crbcon - else - thermal(i) = tsea(i)*(1.+fv*max(q1(i,1,1),qmin)) - tem = sqrt(u10m(i)**2+v10m(i)**2) - tem = max(tem, 1.) - robn = tem / (f0 * z0(i)) - tem1 = 1.e-7 * robn - crb(i) = 0.16 * (tem1 ** (-0.18)) - crb(i) = max(min(crb(i), crbmax), crbmin) - endif - enddo + if (.not. hurr_pbl) then + do i=1,im + flg(i) = .false. + rbup(i) = rbsoil(i) + ! + if(pblflg(i)) then + thermal(i) = thvx(i,1) + crb(i) = crbcon + else + thermal(i) = tsea(i)*(1.+fv*max(q1(i,1,1),qmin)) + tem = sqrt(u10m(i)**2+v10m(i)**2) + tem = max(tem, 1.) + robn = tem / (f0 * z0(i)) + tem1 = 1.e-7 * robn + crb(i) = 0.16 * (tem1 ** (-0.18)) + crb(i) = max(min(crb(i), crbmax), crbmin) + endif + enddo + else + do i=1,im + flg(i) = .false. + rbup(i) = rbsoil(i) + + ! use variable Ri for all conditions + if(pblflg(i)) then + thermal(i) = thvx(i,1) + else + thermal(i) = tsea(i)*(1.+fv*max(q1(i,1,1),qmin)) + endif + tem = sqrt(u10m(i)**2+v10m(i)**2) + tem = max(tem, 1.) + robn = tem / (f0 * z0(i)) + tem1 = 1.e-7 * robn + crb(i) = crbcon + if (var_ric .eq. 1.) then + if (islimsk(i) .eq. 1) crb(I) = coef_ric_l*(tem1)**(-0.18) + if (islimsk(i) .eq. 0) crb(I) = coef_ric_s*(tem1)**(-0.18) + endif + crb(i) = max(min(crb(i), crbmax), crbmin) + enddo + endif + !> Given the thermal's properties and the critical Richardson number, a loop is executed to find the first level above the surface where the modified Richardson number is greater than the critical Richardson number, using equation 10a from Troen and Mahrt (1986) \cite troen_and_mahrt_1986 (also equation 8 from Hong and Pan (1996) \cite hong_and_pan_1996): !! \f[ !! h = Ri\frac{T_0\left|\vec{v}(h)\right|^2}{g\left(\theta_v(h) - \theta_s\right)} @@ -719,38 +756,223 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & kpbl(i) = 1 endif enddo -! + + +!!! 20150915 WeiguoWang added alpha (moninq_fac) and wind-dependent modification of K by RGF +! ------------------------------------------------------------------------------------- +! begin RGF modifications +! this is version MOD05 + +! RGF determine wspd at roughly 500 m above surface, or as close as possible, +! reuse SPDK2 +! zi(i,k) is AGL, right? May not matter if applied only to water grid points + if(hurr_pbl .and. moninq_fac .lt. 0.0) then + do i=1,im + spdk2 = 0. + wspm(i,1) = 0. + do k = 1, kmpbl ! kmpbl is like a max possible pbl height + if (zi(i,k) .le. 500. .and. zi(i,k+1) .gt. 500.) then ! find level bracketing 500 m + spdk2 = SQRT(u1(i,k)*u1(i,k)+v1(i,k)*v1(i,k)) ! wspd near 500 m + wspm(i,1) = spdkw/0.6 ! now the Km limit for 500 m. just store in K=1 + wspm(i,2) = float(k) ! height of level at gridpoint i. store in K=2 + endif + enddo !k + enddo ! i + endif ! hurr_pbl and moninq_fac < 0 + + ! compute diffusion coefficients below pbl !> ## Compute diffusion coefficients below the PBL top !! Below the PBL top, the diffusion coefficients (\f$K_m\f$ and \f$K_h\f$) are calculated according to equation 2 in Hong and Pan (1996) \cite hong_and_pan_1996 where a different value for \f$w_s\f$ (PBL vertical velocity scale) is used depending on the PBL stability. \f$K_h\f$ is calculated from \f$K_m\f$ using the Prandtl number. The calculated diffusion coefficients are checked so that they are bounded by maximum values and the local background diffusion coefficients. - do k = 1, kmpbl - do i=1,im - if(k < kpbl(i)) then -! zfac = max((1.-(zi(i,k+1)-zl(i,1))/ -! 1 (hpbl(i)-zl(i,1))), zfmin) - zfac = max((1.-zi(i,k+1)/hpbl(i)), zfmin) - tem = zi(i,k+1) * (zfac**pfac) * moninq_fac ! lmh suggested by kg - if(pblflg(i)) then - tem1 = vk * wscaleu(i) * tem -! dku(i,k) = xkzmo(i,k) + tem1 -! dkt(i,k) = xkzo(i,k) + tem1 * prinv(i) - dku(i,k) = tem1 - dkt(i,k) = tem1 * prinv(i) - else - tem1 = vk * wscale(i) * tem -! dku(i,k) = xkzmo(i,k) + tem1 -! dkt(i,k) = xkzo(i,k) + tem1 * prinv(i) - dku(i,k) = tem1 - dkt(i,k) = tem1 * prinv(i) + if (.not. hurr_pbl) then + do k = 1, kmpbl + do i=1,im + if(k < kpbl(i)) then +! zfac = max((1.-(zi(i,k+1)-zl(i,1))/ +! 1 (hpbl(i)-zl(i,1))), zfmin) + zfac = max((1.-zi(i,k+1)/hpbl(i)), zfmin) + tem = zi(i,k+1) * (zfac**pfac) * moninq_fac ! lmh suggested by kg + if(pblflg(i)) then + tem1 = vk * wscaleu(i) * tem +! dku(i,k) = xkzmo(i,k) + tem1 +! dkt(i,k) = xkzo(i,k) + tem1 * prinv(i) + dku(i,k) = tem1 + dkt(i,k) = tem1 * prinv(i) + else + tem1 = vk * wscale(i) * tem +! dku(i,k) = xkzmo(i,k) + tem1 +! dkt(i,k) = xkzo(i,k) + tem1 * prinv(i) + dku(i,k) = tem1 + dkt(i,k) = tem1 * prinv(i) + endif + dku(i,k) = min(dku(i,k),dkmax) + dku(i,k) = max(dku(i,k),xkzmo(i,k)) + dkt(i,k) = min(dkt(i,k),dkmax) + dkt(i,k) = max(dkt(i,k),xkzo(i,k)) + dktx(i,k)= dkt(i,k) endif - dku(i,k) = min(dku(i,k),dkmax) - dku(i,k) = max(dku(i,k),xkzmo(i,k)) - dkt(i,k) = min(dkt(i,k),dkmax) - dkt(i,k) = max(dkt(i,k),xkzo(i,k)) - dktx(i,k)= dkt(i,k) - endif - enddo - enddo + enddo !i + enddo !k + else + !hurricane PBL case (note that the i and k loop order has been switched) + do i=1, im + do k=1, kmpbl + if (k < kpbl(i)) then +! zfac = max((1.-(zi(i,k+1)-zl(i,1))/ +! 1 (hpbl(i)-zl(i,1))), zfmin) + zfac = max((1.-zi(i,k+1)/hpbl(i)), zfmin) + tem = zi(i,k+1) * (zfac**pfac) * ABS(moninq_fac) + +!!!! CHANGES FOR HEIGHT-DEPENDENT K ADJUSTMENT, WANG W + if (useshape .ge. 1) then + sz2h=(zi(i,k+1)-zl(i,1))/(hpbl(i)-zl(i,1)) + sz2h=max(sz2h,zfmin) + sz2h=min(sz2h,1.0) + zfac=(1.0-sz2h)**pfac +! smax=0.148 !! max value of this shape function + smax=0.148 !! max value of this shape function + hmax=0.333 !! roughly height if max K + skmax=hmax*(1.0-hmax)**pfac + sksfc=min(zi(i,2)/hpbl(i),0.05) ! surface layer top, 0.05H or ZI(2) (Zi(1)=0) + sksfc=sksfc*(1-sksfc)**pfac + + zfac=max(zfac,zfmin) + ashape=max(ABS(moninq_fac),0.2) ! should not be smaller than 0.2, otherwise too much adjustment(?) + if (useshape == 1) then + ashape=(1.0 - ((sz2h*zfac/smax)**0.25) *(1.0 - ashape)) + tem = zi(i,k+1) * (zfac) * ashape + elseif (useshape == 2) then !only adjus K that is > K_surface_top + ashape1=1.0 + if (skmax > sksfc) then + ashape1=(skmax*ashape-sksfc)/(skmax-sksfc) + endif + skminusk0 = zi(i,k+1)*zfac - hpbl(i)*sksfc + tem = zi(i,k+1) * (zfac) ! no adjustment + if (skminusk0 > 0) then ! only adjust K which is > surface top K + tem = skminusk0*ashape1 + hpbl(i)*sksfc + endif + endif ! useshape == 1 or 2 + endif ! endif useshape>1 +!!!! END OF CHANGES , WANG W + +!!If alpha >= 0, this is the only modification of K +! if alpha = -1, the above provides the first guess for DKU, based on assumption +! alpha = +1 +! (other values of alpha < 0 can also be applied) +! if alpha > 0, the above applies the alpha suppression factor and we are +! finished + + if(pblflg(i)) then + tem1 = vk * wscaleu(i) * tem +! dku(i,k) = xkzmo(i,k) + tem1 +! dkt(i,k) = xkzo(i,k) + tem1 * prinv(i) + dku(i,k) = tem1 + dkt(i,k) = tem1 * prinv(i) + else + tem1 = vk * wscale(i) * tem +! dku(i,k) = xkzmo(i,k) + tem1 +! dkt(i,k) = xkzo(i,k) + tem1 * prinv(i) + dku(i,k) = tem1 + dkt(i,k) = tem1 * prinv(i) + endif + dku(i,k) = min(dku(i,k),dkmax) + dku(i,k) = max(dku(i,k),xkzmo(i,k)) + dkt(i,k) = min(dkt(i,k),dkmax) + dkt(i,k) = max(dkt(i,k),xkzo(i,k)) + dktx(i,k)= dkt(i,k) + endif !k < kpbl(i) + enddo !K loop + +! possible modification of first guess DKU, under certain conditions +! (1) this applies only to columns over water + if (islimsk(i) .eq. 0) then ! sea only +! (2) alpha test +! if alpha < 0, find alpha for each column and do the loop again +! if alpha > 0, we are finished + if (moninq_fac .lt. 0.) then ! variable alpha test +! k-level of layer around 500 m + kLOC = INT(wspm(i,2)) +! print *,' kLOC ',kLOC,' KPBL ',KPBL(I) + +! (3) only do this IF KPBL(I) >= kLOC. Otherwise, we are finished, with DKU as +! if alpha = +1 + if(kpbl(i) .gt. kLOC) then + xDKU = DKU(i,kLOC) ! Km at k-level +! (4) DKU check. +! WSPM(i,1) is the KM cap for the 500-m level. +! if DKU at 500-m level < WSPM(i,1), do not limit Km ANYWHERE. Alpha = +! abs(alpha). No need to recalc. +! if DKU at 500-m level > WSPM(i,1), then alpha = WSPM(i,1)/xDKU for entire +! column + if(xDKU .ge. wspm(i,1)) then ! ONLY if DKU at 500-m exceeds cap, otherwise already done + wspm(i,3) = wspm(i,1)/xDKU ! ratio of cap to Km at k-level, store in WSPM(i,3) + !WSPM(i,4) = amin1(WSPM(I,3),1.0) ! this is new column alpha. cap at 1. ! should never be needed + wspm(i,4) = min(wspm(i,3),1.0) ! this is new column alpha. cap at 1. ! should never be needed + !! recalculate K capped by WSPM(i,1) + do k = 1, kmpbl + if(k < kpbl(i)) then +! zfac = max((1.-(zi(i,k+1)-zl(i,1))/ +! 1 (hpbl(i)-zl(i,1))), zfmin) + zfac = max((1.-zi(i,k+1)/hpbl(i)), zfmin) + tem = zi(i,k+1) * (zfac**pfac) * wspm(i,4) +!!! wang use different K shape, options!!!!!!!!!!!!!!!!!!!!!!!!! +!!!! HANGES FOR HEIGHT-DEPENDENT K ADJUSTMENT, WANG W + if(useshape .ge. 1) then + sz2h=(zi(i,k+1)-zl(i,1))/(hpbl(i)-zl(i,1)) + sz2h=max(sz2h,zfmin) + sz2h=min(sz2h,1.0) + zfac=(1.0-sz2h)**pfac + smax=0.148 !! max value of this shape function + hmax=0.333 !! roughly height if max K + skmax=hmax*(1.0-hmax)**pfac + sksfc=min(zi(i,2)/hpbl(i),0.05) ! surface layer top, 0.05H or ZI(2) (Zi(1)=0) + sksfc=sksfc*(1-sksfc)**pfac + + zfac=max(zfac,zfmin) + ashape=max(wspm(i,4),0.2) !! adjustment coef should not smaller than 0.2 + if(useshape ==1) then + ashape=(1.0 - ((sz2h*zfac/smax)**0.25)* + & (1.0 - ashape)) + tem = zi(i,k+1) * (zfac) * ashape + elseif (useshape == 2) then !only adjus K that is > K_surface_top + ashape1=1.0 + if (skmax > sksfc) then + ashape1=(skmax*ashape-sksfc)/(skmax-sksfc) + endif + skminusk0=zi(i,k+1)*zfac - hpbl(i)*sksfc + tem = zi(i,k+1) * (zfac) ! no adjustment + if (skminusk0 > 0) then ! only adjust K which is > surface top K + tem = skminusk0*ashape1 + HPBL(i)*sksfc + endif + endif ! endif useshape=1 or 2 + endif ! endif useshape>1 +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + if(pblflg(i)) then + tem1 = vk * wscaleu(i) * tem +! dku(i,k) = xkzmo(i,k) + tem1 +! dkt(i,k) = xkzo(i,k) + tem1 * prinv(i) + dku(i,k) = tem1 + dkt(i,k) = tem1 * prinv(i) + else + tem1 = vk * wscale(i) * tem +! dku(i,k) = xkzmo(i,k) + tem1 +! dkt(i,k) = xkzo(i,k) + tem1 * prinv(i) + dku(i,k) = tem1 + dkt(i,k) = tem1 * prinv(i) + endif !pblflg + dku(i,k) = min(dku(i,k),dkmax) + dku(i,k) = max(dku(i,k),xkzmo(i,k)) + dkt(i,k) = min(dkt(i,k),dkmax) + dkt(i,k) = max(dkt(i,k),xkzo(i,k)) + dktx(i,k)= dkt(i,k) + endif ! k < kpbl(i) + enddo ! K loop + endif ! xDKU .ge. wspm(i,1) + endif ! kpbl(i) .ge. kLOC + endif ! moninq_fac < 0 + endif ! islimsk == 0 + enddo ! I loop + endif ! not hurr_pbl ! ! compute diffusion coefficients based on local scheme above pbl !> ## Compute diffusion coefficients above the PBL top @@ -916,16 +1138,32 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !> After \f$K_h^{Sc}\f$ has been determined from the surface to the top of the stratocumulus layer, it is added to the value for the diffusion coefficient calculated previously using surface-based mixing [see equation 6 of Lock et al. (2000) \cite lock_et_al_2000 ]. - do k = 1, kmpbl - do i=1,im - if(scuflg(i)) then - dkt(i,k) = dkt(i,k)+ckt(i,k) - dku(i,k) = dku(i,k)+cku(i,k) - dkt(i,k) = min(dkt(i,k),dkmax) - dku(i,k) = min(dku(i,k),dkmax) - endif + if (.not. hurr_pbl) then + do k = 1, kmpbl + do i=1,im + if(scuflg(i)) then + dkt(i,k) = dkt(i,k)+ckt(i,k) + dku(i,k) = dku(i,k)+cku(i,k) + dkt(i,k) = min(dkt(i,k),dkmax) + dku(i,k) = min(dku(i,k),dkmax) + endif + enddo enddo - enddo + else + do k = 1, kmpbl + do i=1,im + if(scuflg(i)) then + !! if K needs to be adjusted by alpha, then no need to add this term + if (moninq_fac == 1.0) then + dkt(i,k) = dkt(i,k)+ckt(i,k) + dku(i,k) = dku(i,k)+cku(i,k) + end if + dkt(i,k) = min(dkt(i,k),dkmax) + dku(i,k) = min(dku(i,k),dkmax) + endif + enddo + enddo + endif ! ! compute tridiagonal matrix elements for heat and moisture ! @@ -1067,13 +1305,19 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & ! add dissipative heating at the first model layer ! !> Next, the temperature tendency is updated following equation 14. + if (hurr_pbl) then + ttend_fac = 0.7 + else + ttend_fac = 0.5 + endif + do i = 1,im tem = govrth(i)*sflux(i) tem1 = tem + stress(i)*spd1(i)/zl(i,1) tem2 = 0.5 * (tem1+diss(i,1)) tem2 = max(tem2, 0.) ttend = tem2 / cp - tau(i,1) = tau(i,1)+0.5*ttend + tau(i,1) = tau(i,1)+ttend_fac*ttend enddo ! ! add dissipative heating above the first model layer @@ -1083,7 +1327,7 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & tem = 0.5 * (diss(i,k-1)+diss(i,k)) tem = max(tem, 0.) ttend = tem / cp - tau(i,k) = tau(i,k) + 0.5*ttend + tau(i,k) = tau(i,k) + ttend_fac*ttend enddo enddo ! diff --git a/physics/moninedmf.meta b/physics/moninedmf.meta index 6a6ccd183..43af9877d 100644 --- a/physics/moninedmf.meta +++ b/physics/moninedmf.meta @@ -499,6 +499,49 @@ kind = kind_phys intent = in optional = F +[hurr_pbl] + standard_name = flag_hurricane_PBL + long_name = flag for hurricane-specific options in PBL scheme + units = flag + dimensions = () + type = logical + intent = in + optional = F +[islmsk] + standard_name = sea_land_ice_mask + long_name = sea/land/ice mask (=0/1/2) + units = flag + dimensions = (horizontal_dimension) + type = integer + intent = in + optional = F +[var_ric] + standard_name = flag_variable_bulk_richardson_number + long_name = flag for calculating variable bulk richardson number for hurricane PBL + units = flag + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[coef_ric_l] + standard_name = coefficient_for_variable_bulk_richardson_number_over_land + long_name = coefficient for calculating variable bulk richardson number for hurricane PBL over land + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[coef_ric_s] + standard_name = coefficient_for_variable_bulk_richardson_number_over_ocean + long_name = coefficient for calculating variable bulk richardson number for hurricane PBL over ocean + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From cce995ddd369ccb4f3d4f36e7c7ef6cb6a66ae4d Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Mon, 3 Feb 2020 15:47:12 -0700 Subject: [PATCH 04/42] clean up logic to better align with HAFS version from Bin Liu, Chunxi Zhang, Weiguo Wang, and Qingfu Liu --- physics/moninedmf.f | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/physics/moninedmf.f b/physics/moninedmf.f index a9532857c..72cb15f35 100644 --- a/physics/moninedmf.f +++ b/physics/moninedmf.f @@ -434,7 +434,7 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & !! The temperature of the thermal is of primary importance. For the initial estimate of the PBL height, the thermal is assumed to have one of two temperatures. If the boundary layer is stable, the thermal is assumed to have a temperature equal to the surface virtual temperature. Otherwise, the thermal is assumed to have the same virtual potential temperature as the lowest model level. For the stable case, the critical bulk Richardson number becomes a function of the wind speed and roughness length, otherwise it is set to a tunable constant. ! compute the pbl height ! - if (.not. hurr_pbl) then + if (.not. (hurr_pbl .and. moninq_fac < 0.0)) then do i=1,im flg(i) = .false. rbup(i) = rbsoil(i) @@ -766,7 +766,7 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & ! RGF determine wspd at roughly 500 m above surface, or as close as possible, ! reuse SPDK2 ! zi(i,k) is AGL, right? May not matter if applied only to water grid points - if(hurr_pbl .and. moninq_fac .lt. 0.0) then + if(hurr_pbl .and. moninq_fac < 0.0) then do i=1,im spdk2 = 0. wspm(i,1) = 0. @@ -784,7 +784,7 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & ! compute diffusion coefficients below pbl !> ## Compute diffusion coefficients below the PBL top !! Below the PBL top, the diffusion coefficients (\f$K_m\f$ and \f$K_h\f$) are calculated according to equation 2 in Hong and Pan (1996) \cite hong_and_pan_1996 where a different value for \f$w_s\f$ (PBL vertical velocity scale) is used depending on the PBL stability. \f$K_h\f$ is calculated from \f$K_m\f$ using the Prandtl number. The calculated diffusion coefficients are checked so that they are bounded by maximum values and the local background diffusion coefficients. - if (.not. hurr_pbl) then + if (.not. (hurr_pbl .and. moninq_fac < 0.0)) then do k = 1, kmpbl do i=1,im if(k < kpbl(i)) then @@ -814,7 +814,7 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & enddo !i enddo !k else - !hurricane PBL case (note that the i and k loop order has been switched) + !hurricane PBL case and moninq_fac < 0 (note that the i and k loop order has been switched) do i=1, im do k=1, kmpbl if (k < kpbl(i)) then @@ -889,6 +889,8 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & ! (2) alpha test ! if alpha < 0, find alpha for each column and do the loop again ! if alpha > 0, we are finished + +!GJF: redundant check for moninq_fac < 0? if (moninq_fac .lt. 0.) then ! variable alpha test ! k-level of layer around 500 m kLOC = INT(wspm(i,2)) @@ -969,10 +971,10 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & enddo ! K loop endif ! xDKU .ge. wspm(i,1) endif ! kpbl(i) .ge. kLOC - endif ! moninq_fac < 0 + endif ! moninq_fac < 0 (GJF: redundant?) endif ! islimsk == 0 enddo ! I loop - endif ! not hurr_pbl + endif ! not (hurr_pbl and moninq_fac < 0) ! ! compute diffusion coefficients based on local scheme above pbl !> ## Compute diffusion coefficients above the PBL top @@ -1154,7 +1156,7 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & do i=1,im if(scuflg(i)) then !! if K needs to be adjusted by alpha, then no need to add this term - if (moninq_fac == 1.0) then + if (.not. (hurr_pbl .and. moninq_fac < 0.0)) then dkt(i,k) = dkt(i,k)+ckt(i,k) dku(i,k) = dku(i,k)+cku(i,k) end if @@ -1305,7 +1307,7 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & ! add dissipative heating at the first model layer ! !> Next, the temperature tendency is updated following equation 14. - if (hurr_pbl) then + if (hurr_pbl .and. moninq_fac < 0.0) then ttend_fac = 0.7 else ttend_fac = 0.5 From e839247d49d50f6bb7211d80e6fe285e14ce438f Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Thu, 6 Feb 2020 11:31:27 -0700 Subject: [PATCH 05/42] send constants through the argument list --- physics/moninedmf.f | 35 +++++++++++++++++------------------ physics/moninedmf.meta | 36 ++++++++++++++++++++++++++++++++++++ 2 files changed, 53 insertions(+), 18 deletions(-) diff --git a/physics/moninedmf.f b/physics/moninedmf.f index 72cb15f35..f6b405df1 100644 --- a/physics/moninedmf.f +++ b/physics/moninedmf.f @@ -65,12 +65,11 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & & dusfc,dvsfc,dtsfc,dqsfc,hpbl,hgamt,hgamq,dkt, & & kinver,xkzm_m,xkzm_h,xkzm_s,lprnt,ipr, & & xkzminv,moninq_fac,hurr_pbl,islimsk,var_ric, & - & coef_ric_l,coef_ric_s,errmsg,errflg) + & coef_ric_l,coef_ric_s,grav,cp,hvap,fv,errmsg,errflg) ! use machine , only : kind_phys use funcphys , only : fpvs - use physcons, grav => con_g, rd => con_rd, cp => con_cp - &, hvap => con_hvap, fv => con_fvirt + implicit none ! ! arguments @@ -82,6 +81,7 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & ! real(kind=kind_phys), intent(in) :: delt, xkzm_m, xkzm_h, xkzm_s + real(kind=kind_phys), intent(in) :: grav, cp, hvap, fv real(kind=kind_phys), intent(in) :: xkzminv, moninq_fac, var_ric, & & coef_ric_l, coef_ric_s real(kind=kind_phys), intent(inout) :: dv(im,km), du(im,km), & @@ -158,12 +158,12 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & ! ublflg: true for unstable but not convective(strongly unstable) pbl ! real(kind=kind_phys) aphi16, aphi5, bvf2, wfac, - & cfac, conq, cont, conw, + & cfac, conq, cont, & dk, dkmax, dkmin, & dq1, dsdz2, dsdzq, dsdzt, & dsdzu, dsdzv, & dsig, dt2, dthe1, dtodsd, - & dtodsu, dw2, dw2min, g, + & dtodsu, dw2, dw2min, & gamcrq, gamcrt, gocp, & gravi, f0, & prnum, prmax, prmin, pfac, crbcon, @@ -192,11 +192,7 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & integer, parameter :: useshape=2!0-- no change, original ALPHA adjustment,1-- shape1, 2-- shape2(adjust above sfc) real :: smax,ashape,sz2h, sksfc,skmax,ashape1,skminusk0, hmax cc - parameter(gravi=1.0/grav) - parameter(g=grav) - parameter(gocp=g/cp) - parameter(cont=cp/g,conq=hvap/g,conw=1.0/g) ! for del in pa -! parameter(cont=1000.*cp/g,conq=1000.*hvap/g,conw=1000./g) ! for del in kpa +! parameter(cont=1000.*cp/grav,conq=1000.*hvap/grav,conw=1000./grav) ! for del in kpa parameter(rlam=30.0,vk=0.4,vk2=vk*vk) parameter(prmin=0.25,prmax=4.,zolcr=0.2,zolcru=-0.5) parameter(dw2min=0.0001,dkmin=0.0,dkmax=1000.,rimin=-100.) @@ -247,7 +243,10 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & errflg = 0 !> ## Compute preliminary variables from input arguments - + gravi=1.0/grav + gocp=grav/cp + cont=cp/grav + conq=hvap/grav ! compute preliminary variables ! if (ix .lt. im) stop @@ -413,7 +412,7 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & enddo !> - Calculate \f$\frac{g}{\theta}\f$ (govrth), \f$\beta = \frac{\Delta t}{\Delta z}\f$ (beta), \f$u_*\f$ (ustar), total surface flux (sflux), and set pblflag to false if the total surface energy flux is into the surface do i = 1,im - govrth(i) = g/theta(i,1) + govrth(i) = grav/theta(i,1) enddo ! do i=1,im @@ -490,7 +489,7 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & rbdn(i) = rbup(i) spdk2 = max((u1(i,k)**2+v1(i,k)**2),1.) rbup(i) = (thvx(i,k)-thermal(i))* - & (g*zl(i,k)/thvx(i,1))/spdk2 + & (grav*zl(i,k)/thvx(i,1))/spdk2 kpbl(i) = k flg(i) = rbup(i) > crb(i) endif @@ -600,7 +599,7 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & rbdn(i) = rbup(i) spdk2 = max((u1(i,k)**2+v1(i,k)**2),1.) rbup(i) = (thvx(i,k)-thermal(i))* - & (g*zl(i,k)/thvx(i,1))/spdk2 + & (grav*zl(i,k)/thvx(i,1))/spdk2 kpbl(i) = k flg(i) = rbup(i) > crb(i) endif @@ -1014,7 +1013,7 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & do k = 1, km1 do i=1,im if(k >= kpbl(i)) then - bvf2 = g*bf(i,k)*ti(i,k) + bvf2 = grav*bf(i,k)*ti(i,k) ri = max(bvf2/shr2(i,k),rimin) zk = vk*zi(i,k+1) if(ri < 0.) then ! unstable regime @@ -1299,7 +1298,7 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & ! do k = 1,km1 do i = 1,im - diss(i,k) = dku(i,k)*shr2(i,k)-g*ti(i,k)*dkt(i,k)*bf(i,k) + diss(i,k) = dku(i,k)*shr2(i,k)-grav*ti(i,k)*dkt(i,k)*bf(i,k) ! diss(i,k) = dku(i,k)*shr2(i,k) enddo enddo @@ -1394,8 +1393,8 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & vtend = (a2(i,k)-v1(i,k))*rdt du(i,k) = du(i,k) + utend dv(i,k) = dv(i,k) + vtend - dusfc(i) = dusfc(i) + conw*del(i,k)*utend - dvsfc(i) = dvsfc(i) + conw*del(i,k)*vtend + dusfc(i) = dusfc(i) + gravi*del(i,k)*utend + dvsfc(i) = dvsfc(i) + gravi*del(i,k)*vtend ! ! for dissipative heating for ecmwf model ! diff --git a/physics/moninedmf.meta b/physics/moninedmf.meta index 43af9877d..5791262a4 100644 --- a/physics/moninedmf.meta +++ b/physics/moninedmf.meta @@ -542,6 +542,42 @@ kind = kind_phys intent = in optional = F +[grav] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[hvap] + standard_name = latent_heat_of_vaporization_of_water_at_0C + long_name = latent heat of evaporation/sublimation + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[fv] + standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one + long_name = (rv/rd) - 1 (rv = ideal gas constant for water vapor) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 78c03e0bb3c43f737cbd9f7e0171164a32c2def2 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Thu, 26 Mar 2020 11:53:59 -0600 Subject: [PATCH 06/42] send constants through physcons module; sending constants through the argument list (specifically grav and cp) causes regression test failures in PROD mode --- physics/moninedmf.f | 27 +++++++++++++++------------ physics/moninedmf.meta | 36 ------------------------------------ 2 files changed, 15 insertions(+), 48 deletions(-) diff --git a/physics/moninedmf.f b/physics/moninedmf.f index f6b405df1..66495d91f 100644 --- a/physics/moninedmf.f +++ b/physics/moninedmf.f @@ -65,10 +65,15 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & & dusfc,dvsfc,dtsfc,dqsfc,hpbl,hgamt,hgamq,dkt, & & kinver,xkzm_m,xkzm_h,xkzm_s,lprnt,ipr, & & xkzminv,moninq_fac,hurr_pbl,islimsk,var_ric, & - & coef_ric_l,coef_ric_s,grav,cp,hvap,fv,errmsg,errflg) + & coef_ric_l,coef_ric_s,errmsg,errflg) ! use machine , only : kind_phys use funcphys , only : fpvs + !GJF: Note that sending these constants through the argument list + !results in regression test failures with "PROD" mode compilation + !flags (specifically, grav and cp) + use physcons, grav => con_g, cp => con_cp, + & hvap => con_hvap, fv => con_fvirt implicit none ! @@ -81,7 +86,6 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & ! real(kind=kind_phys), intent(in) :: delt, xkzm_m, xkzm_h, xkzm_s - real(kind=kind_phys), intent(in) :: grav, cp, hvap, fv real(kind=kind_phys), intent(in) :: xkzminv, moninq_fac, var_ric, & & coef_ric_l, coef_ric_s real(kind=kind_phys), intent(inout) :: dv(im,km), du(im,km), & @@ -158,7 +162,7 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & ! ublflg: true for unstable but not convective(strongly unstable) pbl ! real(kind=kind_phys) aphi16, aphi5, bvf2, wfac, - & cfac, conq, cont, + & cfac, conq, cont, conw, & dk, dkmax, dkmin, & dq1, dsdz2, dsdzq, dsdzt, & dsdzu, dsdzv, @@ -182,8 +186,9 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & & ptem, ptem1, ptem2, tx1(im), tx2(im) ! real(kind=kind_phys) zstblmax,h1, h2, qlcr, actei, - & cldtime, ttend_fac - + & cldtime + real :: ttend_fac + !! for hurricane application real(kind=kind_phys) wspm(im,km-1) integer kLOC ! RGF @@ -192,6 +197,9 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & integer, parameter :: useshape=2!0-- no change, original ALPHA adjustment,1-- shape1, 2-- shape2(adjust above sfc) real :: smax,ashape,sz2h, sksfc,skmax,ashape1,skminusk0, hmax cc + parameter(gravi=1.0/grav) + parameter(gocp=grav/cp) + parameter(cont=cp/grav,conq=hvap/grav,conw=1.0/grav) ! for del in pa ! parameter(cont=1000.*cp/grav,conq=1000.*hvap/grav,conw=1000./grav) ! for del in kpa parameter(rlam=30.0,vk=0.4,vk2=vk*vk) parameter(prmin=0.25,prmax=4.,zolcr=0.2,zolcru=-0.5) @@ -242,11 +250,6 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & errmsg = '' errflg = 0 -!> ## Compute preliminary variables from input arguments - gravi=1.0/grav - gocp=grav/cp - cont=cp/grav - conq=hvap/grav ! compute preliminary variables ! if (ix .lt. im) stop @@ -1393,8 +1396,8 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & vtend = (a2(i,k)-v1(i,k))*rdt du(i,k) = du(i,k) + utend dv(i,k) = dv(i,k) + vtend - dusfc(i) = dusfc(i) + gravi*del(i,k)*utend - dvsfc(i) = dvsfc(i) + gravi*del(i,k)*vtend + dusfc(i) = dusfc(i) + conw*del(i,k)*utend + dvsfc(i) = dvsfc(i) + conw*del(i,k)*vtend ! ! for dissipative heating for ecmwf model ! diff --git a/physics/moninedmf.meta b/physics/moninedmf.meta index 5791262a4..43af9877d 100644 --- a/physics/moninedmf.meta +++ b/physics/moninedmf.meta @@ -542,42 +542,6 @@ kind = kind_phys intent = in optional = F -[grav] - standard_name = gravitational_acceleration - long_name = gravitational acceleration - units = m s-2 - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[cp] - standard_name = specific_heat_of_dry_air_at_constant_pressure - long_name = specific heat of dry air at constant pressure - units = J kg-1 K-1 - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[hvap] - standard_name = latent_heat_of_vaporization_of_water_at_0C - long_name = latent heat of evaporation/sublimation - units = J kg-1 - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[fv] - standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one - long_name = (rv/rd) - 1 (rv = ideal gas constant for water vapor) - units = none - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From b492f726db97a45a68baf5311a74ed10d882001a Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 6 Apr 2020 15:11:46 -0600 Subject: [PATCH 07/42] physics/moninedmf.{f,meta}: apply missing updates that were hidden in a update-from-dtc-develop commit --- physics/moninedmf.f | 2 +- physics/moninedmf.meta | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/moninedmf.f b/physics/moninedmf.f index 66495d91f..2d93eb5a7 100644 --- a/physics/moninedmf.f +++ b/physics/moninedmf.f @@ -775,7 +775,7 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & do k = 1, kmpbl ! kmpbl is like a max possible pbl height if (zi(i,k) .le. 500. .and. zi(i,k+1) .gt. 500.) then ! find level bracketing 500 m spdk2 = SQRT(u1(i,k)*u1(i,k)+v1(i,k)*v1(i,k)) ! wspd near 500 m - wspm(i,1) = spdkw/0.6 ! now the Km limit for 500 m. just store in K=1 + wspm(i,1) = spdk2/0.6 ! now the Km limit for 500 m. just store in K=1 wspm(i,2) = float(k) ! height of level at gridpoint i. store in K=2 endif enddo !k diff --git a/physics/moninedmf.meta b/physics/moninedmf.meta index 43af9877d..b5297b63f 100644 --- a/physics/moninedmf.meta +++ b/physics/moninedmf.meta @@ -507,7 +507,7 @@ type = logical intent = in optional = F -[islmsk] +[islimsk] standard_name = sea_land_ice_mask long_name = sea/land/ice mask (=0/1/2) units = flag From a8a2ab870489fc180a4daa8474a735521ab1203f Mon Sep 17 00:00:00 2001 From: "Man.Zhang" Date: Tue, 11 Feb 2020 10:31:58 -0700 Subject: [PATCH 08/42] 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 09/42] 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 10/42] 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 11/42] 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 12/42] 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 13/42] 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 14/42] 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 15/42] 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 16/42] 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) From 6a8c80e538f23cfa7b6703b423dd9963c4477334 Mon Sep 17 00:00:00 2001 From: Man Zhang Date: Mon, 13 Apr 2020 20:32:19 -0600 Subject: [PATCH 17/42] Merge mzhangw:HAFS_fer_hires into NCAR:dtc/hwrf-physics Squashed commit of the following: commit 406f7408b6308145d81e84cc6047d8cd19396f22 Author: Man.Zhang Date: Mon Apr 13 20:24:59 2020 -0600 FA uses progcld5 commit 682fab9654f7c6188109efa3fec9a922d8034c39 Merge: 25b3f66 d979604 Author: Man.Zhang Date: Mon Mar 16 10:42:12 2020 -0600 Merge branch 'dtc/develop' of https://github.com/NCAR/ccpp-physics into HAFS_fer_hires commit 25b3f66d74fc4ece9a665c4e2c353294bb60e636 Author: Man.Zhang Date: Mon Mar 16 10:37:42 2020 -0600 modify stateout update of FA scheme commit 05c533134ac5d61581dbd37a7995ca8af21fda60 Author: Man Zhang Date: Tue Feb 11 16:45:48 2020 -0700 sci doc updates commit 982a11d13d0f8287fefc8b3c217f0933c57e1a95 Author: Man Zhang Date: Fri Feb 7 16:47:00 2020 -0700 FA sci doc updates commit 27c1fcbe3e57ece5a039a083451195e2ed652303 Merge: 8d87e55 73f9f09 Author: Man.Zhang Date: Fri Feb 7 14:26:54 2020 -0700 Merge branch 'dtc/develop' of https://github.com/NCAR/ccpp-physics into HAFS_fer_hires commit 8d87e55fef1a4e7b7b8ce9420b190951a4e47cc3 Author: Man.Zhang Date: Fri Feb 7 14:24:47 2020 -0700 FA scientific documentation commit 67ad5a523f4815d145233383343d15655a29896d Author: Man.Zhang Date: Wed Dec 11 13:13:48 2019 -0700 consolidate with Chunxis version commit 76b547584344386ce4cee467b588e348676b6ef6 Merge: 7c6a472 02812f6 Author: Man.Zhang Date: Wed Dec 11 11:49:22 2019 -0700 Merge branch 'dtc/develop' of https://github.com/NCAR/ccpp-physics into HAFS_fer_hires commit 7c6a47282704958e18f02b8c9f36f6ebf2262d71 Author: Man.Zhang Date: Thu Dec 5 16:28:50 2019 -0700 output mass weighted RF in GFS_suite_stateout_update_run, it will used in FA commit 41086af5af34ed011ecc7fbad64458a7c9c54ee5 Merge: 92d9edf f895fc0 Author: Man.Zhang Date: Thu Dec 5 12:08:30 2019 -0700 Merge branch 'dtc/develop' of https://github.com/NCAR/ccpp-physics into HAFS_fer_hires commit 92d9edf0d624eea93d1a0ce740c6d55bb556015c Author: Man.Zhang Date: Mon Nov 25 14:16:16 2019 -0700 chunxi fix : f_rimef = qg in FA code commit f9e3ee0af2c0cd27b9861ae6d89fd06744ee233e Author: Man.Zhang Date: Mon Nov 25 11:39:54 2019 -0700 From Eric: convert wet mixing ratios of cloud species to mixing ratio before the scheme, and convert back after scheme. From Chunxi, modify: 1. FA interface with GFS RRTMG using progcld2; 2.air pressure improvement; 3. add f_qrimef mixing in PBL commit f497d403dc61b52b0cba01808a2e58ad2461db60 Merge: bd4a30c 73b8c0d Author: Man.Zhang Date: Mon Nov 25 09:44:14 2019 -0700 Merge branch 'dtc/develop' of https://github.com/NCAR/ccpp-physics into HAFS_fer_hires commit bd4a30c08411d2bcb692c7499028284920ccee08 Author: Man.Zhang Date: Fri Nov 22 14:30:16 2019 -0700 monir format fix commit 4c2abd18beaaa068c32324f7dbda5deff78712a3 Merge: db7fc8d a7c38a6 Author: Man.Zhang Date: Thu Nov 21 19:29:50 2019 -0700 Merge branch 'dtc/develop' of https://github.com/NCAR/ccpp-physics into HAFS_fer_hires commit db7fc8db07c4291f791e835f2f28f824b6daace1 Author: Man.Zhang Date: Thu Nov 21 19:29:04 2019 -0700 minor change commit ab52b2610907aa7aeae78a95c610133c526a9195 Author: Man.Zhang Date: Thu Nov 21 18:48:53 2019 -0700 delete update_moist module commit db9e3a75590043ef03dd840229fe98572081c9cb Author: Man.Zhang Date: Mon Nov 18 14:40:10 2019 -0700 cleanup FA codes commit 482a43bc753ec033374dfc387edbfde5281b5083 Merge: 380229c 74851c1 Author: Man.Zhang Date: Mon Nov 18 14:31:07 2019 -0700 Merge branch 'dtc/develop' of https://github.com/NCAR/ccpp-physics into HAFS_fer_hires commit 380229cf38ec5ecec5aae31677c7038de9d9b79c Author: Man.Zhang Date: Thu Nov 14 13:46:13 2019 -0700 1. do some code cleanup 2. correct tracer diffusions definition before/after PBL in GFS_PBL_generic commit a312444323d43746cca3fbff816a087ab14e2787 Author: Man.Zhang Date: Mon Nov 11 10:52:21 2019 -0700 Chunxi's email 11/07/2019: the srflag is based on sr. so we need to make sure 'cal_pre' is always set to false in namelist file. commit f2c927192cbdf27e91ab3f5b4bbbba1709bb7743 Merge: 6777489 333980d Author: Man.Zhang Date: Thu Nov 7 11:03:56 2019 -0700 Merge branch 'dtc/develop' of https://github.com/NCAR/ccpp-physics into HAFS_fer_hires commit 6777489880b16735c809a70cc98c134566b52b72 Author: Man.Zhang Date: Thu Nov 7 10:56:33 2019 -0700 add Chunxi GFS_MP_generic change related to FA scheme commit 327b07f577d1cd367de27a7104113533cb098e36 Author: Man.Zhang Date: Wed Oct 23 19:56:11 2019 -0600 minor fix commit bfedaabc2a9900cbc2e1428823e8ef57d1f31f1a Author: Man.Zhang Date: Wed Oct 23 09:44:46 2019 -0600 add meta files for FA scheme and HAFS_update_moist commit a5b5fa967a3a350c04c8f7936226ce71ce973ca7 Merge: 1ff46c7 cfafb29 Author: Man.Zhang Date: Fri Oct 18 09:56:40 2019 -0600 Merge branch 'gmtb/develop' of https://github.com/NCAR/ccpp-physics into HAFS_fer_hires commit 1ff46c78740c8d69dcaeab4dac881651f9f757d6 Author: Man.Zhang Date: Tue Oct 8 20:42:58 2019 -0600 add update_moist() module to F-A suite commit 258fcebef1cb17750fc1f3de0d143e1ce3ea53da Merge: 53fba5b ecb641e Author: Man.Zhang Date: Mon Oct 7 15:36:47 2019 -0600 Merge branch 'gmtb/develop' of https://github.com/NCAR/ccpp-physics into HAFS_fer_hires commit 53fba5b4086361d4d4c2ceb0fb41334c48ee30cd Author: Man.Zhang Date: Mon Oct 7 14:55:21 2019 -0600 1. recalculate some FAmp tables which depend on physics time step in F-A scheme 2. change ncw value to HWRF application commit 1656aac7574026f40bd006d37771bb845b0ed4bb Author: Man.Zhang Date: Mon Sep 30 12:02:24 2019 -0600 revert MP_generic to original version to obtain B4B for control/csawmg/satmedmf commit dfccc5b66b3148b6b27f5ea41c519280db1a9537 Author: Man.Zhang Date: Sun Sep 29 11:06:55 2019 -0600 fix bugs in GFS_PBL_generic commit fc744d37b4d1793c5b12915a6980a0226d630406 Merge: 1a024b7 dc74b57 Author: Man.Zhang Date: Mon Sep 23 14:17:29 2019 -0600 Merge branch 'gmtb/develop' of https://github.com/NCAR/ccpp-physics into HAFS_fer_hires commit 1a024b7e33569813915088ea89cec4004af2e46c Author: Man.Zhang Date: Fri Sep 20 22:01:07 2019 -0600 fix ccpp_control crashed problem commit 957ff823926e8eae5b94cdc9baec00a50725cd09 Author: Man.Zhang Date: Thu Sep 19 10:14:59 2019 -0600 turn on/off spec_adv option is working in CCPP F-A scheme. commit 370d49f718bd1c13be7b8d1176d54183d8452a5c Author: Man.Zhang Date: Tue Sep 17 16:55:24 2019 -0600 use progcld5 for F-A in GFS_rrtmg_pre commit bbbf155ebf1584d27fc357f66b35f874c78d706c Author: Man.Zhang Date: Thu Sep 12 09:19:17 2019 -0600 F-A scheme modification related to meta data file update commit 2b8d9e4cce92c59447078d61feef8dca11dcbd20 Merge: 08662ae 9fc5ac1 Author: Man.Zhang Date: Wed Sep 11 16:15:30 2019 -0600 Merge branch 'HAFS_fer_hires' of https://github.com/mzhangw/ccpp-physics into HAFS_fer_hires commit 08662ae5463aeb30524ac0798219f5c7454cbe13 Author: Man.Zhang Date: Wed Sep 11 16:14:47 2019 -0600 add vars to meta table commit 9fc5ac15ff2b7a4e822f68e592ddb4aa7d207832 Author: Man Zhang Date: Wed Sep 11 16:12:00 2019 -0600 initialize Doxygen documentation in F-A scheme commit d749a6879a47656bad756e1823a12db92df14efa Merge: dff5b0f 20dd8d2 Author: Man.Zhang Date: Tue Sep 10 15:19:15 2019 -0600 Merge branch 'gmtb/develop' of https://github.com/NCAR/ccpp-physics into HAFS_fer_hires commit dff5b0f17da3a6d6d47ff5d184fea30f7b21f010 Merge: bed9c0e 727417c Author: Man.Zhang Date: Wed Sep 4 14:30:28 2019 -0600 Merge branch 'chunxi_physics' of https://github.com/ChunxiZhang-NOAA/ccpp-physics into HAFS_fer_hires commit bed9c0e4308b5c44ea4b3daac0976c69d848200a Merge: 1f8a26a 44137a3 Author: Man.Zhang Date: Wed Sep 4 14:26:51 2019 -0600 Merge branch 'HAFS_fer_hires' of https://github.com/mzhangw/ccpp-physics into HAFS_fer_hires commit 1f8a26a47908983229e19052b511035e0f5aea92 Author: Man.Zhang Date: Wed Sep 4 14:24:27 2019 -0600 bug fixed in augument list of FER_HIRES commit 44137a3741ad118cfbf6b46a1e39ebcdff84d808 Merge: 1808226 6abba22 Author: Man.Zhang Date: Tue Sep 3 10:33:04 2019 -0600 Merge branch 'gmtb/develop' of https://github.com/NCAR/ccpp-physics into HAFS_fer_hires commit 1808226b104453dc0907aad07015a098991db9df Author: Man.Zhang Date: Sat Aug 31 17:51:49 2019 -0600 tracer treatment fix commit 727417c249e2c20d91c55334bdd8da1ba0de9a71 Author: Chunxi.Zhang-NOAA Date: Fri Aug 30 22:13:06 2019 +0000 GFS_MP_generic.F90: recalculate srflag GFS_PBL_generic.F90: define tracers for vertical diffusion GFS_rrtmg_pre.F90: change ncnd module_mp_fer_hires_pre.F90: revised the definition to tracers mp_fer_hires.F90: revised the definition to tracers commit ec729e8434a0b63010547ba3b8ed3e21a6d54342 Author: Man.Zhang Date: Thu Aug 29 21:43:36 2019 -0600 make consistent standard name as Chunxis implementation commit 3a26975a0524594c917a99826c6b7c558894ce8a Merge: 1426c6e c7faeb7 Author: Man.Zhang Date: Thu Aug 29 21:02:59 2019 -0600 Merge branch 'chunxi_physics' of https://github.com/ChunxiZhang-NOAA/ccpp-physics into HAFS_fer_hires commit 1426c6ee9ea83346319faf966d22b93ae508096e Author: Man.Zhang Date: Thu Aug 29 20:32:12 2019 -0600 fix omp message and pass F-A scheme commit c7faeb7b8b3a2e98596308f088824d4f097886af Author: Chunxi.Zhang-NOAA Date: Thu Aug 29 16:20:51 2019 +0000 mp_fer_hires.F90: changed the definitions for f_ice, f_rain and f_rimef. Deleted QS since it will not be used. we only need QI. module_mp_fer_hires_pre.F90: changes related to f_ice, f_rain and f_rimef module_mp_fer_hires_pre.F90: added commit 4e0d9bd0026cc53ea67fed262d3632d05ac917f1 Merge: 9aaa575 01823bc Author: Man.Zhang Date: Tue Aug 27 17:13:12 2019 -0600 Merge branch 'gmtb/develop' of https://github.com/NCAR/ccpp-physics into HAFS_fer_hires commit 9aaa57535015ffb489ba51635a65fe0fc26cc1e9 Author: Man.Zhang Date: Tue Aug 27 15:57:43 2019 -0600 minor fix commit 6b888640907453ae7f90c4c16107afe811a478ec Author: Eric Aligo Date: Tue Aug 27 17:31:03 2019 +0000 Fixed bug to allow both Qi and Qc to be updated from CU scheme. commit 73f95a60f1f7fbc2a2679f2a19498c036845a436 Author: Man.Zhang Date: Mon Aug 26 22:05:00 2019 -0600 fortran format fix commit d5f8a622be5f9ad4c1b636f4762cf44cdca91774 Author: Man.Zhang Date: Mon Aug 26 17:16:30 2019 -0600 minor fix commit fb011da3962ce69c10c23c6241cc0f29153936f3 Author: Man.Zhang Date: Mon Aug 26 17:05:04 2019 -0600 Aligo-use the dx of the 1st i poit to set an integer value of dx to be used for determining RHgrd commit 80fedc458556b9c7ca4a73d61dd1c50eec023fb4 Author: Man.Zhang Date: Mon Aug 26 13:41:24 2019 -0600 further constants fix commit 473ff9ea06d080d5a17483c5731081e463523840 Author: Man.Zhang Date: Mon Aug 26 10:45:49 2019 -0600 dimension fixed commit c29c3cdcdf13db9e53e838a6e42d7c6f6afb379c Author: Man.Zhang Date: Sun Aug 25 22:44:04 2019 -0600 convert USE ESMF to ccpp mpi method; temporary constant treatment commit 8b886b9627cf5fa8a053522f7411d77f61c8a368 Author: Man.Zhang Date: Wed Aug 21 11:06:19 2019 -0600 delete HWRF F-A scheme commit b78a1a2ae7f8ef288c368b5b0cf3fa46405038af Merge: dbabee7 ff2c6d8 Author: Man.Zhang Date: Mon Aug 19 13:42:42 2019 -0600 Merge branch 'gmtb/develop' of https://github.com/NCAR/ccpp-physics into HAFS_fer_hires commit dbabee7650a6fbed815c3dc566f478b78166baf8 Author: Man.Zhang Date: Mon Aug 19 13:41:36 2019 -0600 update commit 7c481b51e96a40e43fa5b79e45dc5c12a3908401 Author: Man.Zhang Date: Thu Aug 15 08:34:33 2019 -0600 initialize FER_HIRES scheme commit bbac675e1379f533a6b492c0c6cd4cf90d9d3a21 Merge: d06f755 fb29006 Author: Man.Zhang Date: Mon Aug 5 10:33:29 2019 -0600 Merge branch 'gmtb/develop' of https://github.com/NCAR/ccpp-physics into HAFS_fer_hires commit d06f7550c6873d7b724d96fb6b066e7324396699 Author: Man.Zhang Date: Thu Aug 1 11:29:43 2019 -0600 minor fix commit 970ae6694eafe6d0481b527f39dfccf51cdc3f73 Author: Man.Zhang Date: Wed Jul 31 13:41:12 2019 -0600 change file name commit d666a3e34cab2efcd3aab998c510150fecf3b022 Author: Man Zhang Date: Wed Jul 31 12:25:36 2019 -0600 pass prebuild commit 63f07c4b13a2b73aff22402560a32839c9d79e51 Merge: d0d4035 6bb0897 Author: Man Zhang Date: Wed Jul 31 10:10:31 2019 -0600 Merge branch 'gmtb/develop' of https://github.com/NCAR/ccpp-physics into FA-HWRF-V4_0a commit d0d40355c48ea3741aa5d365145d7b5c68e0c8e7 Author: Man Zhang Date: Wed Jul 31 10:09:44 2019 -0600 initialize FER_HIRES implementation commit e77c0a16075569a3856fc2ca7990ad2ccd9e93a5 Author: Man Zhang Date: Fri Jul 19 14:55:03 2019 -0600 add fer_hires wrapper module commit 193435bde766b7a0c891b88a8af6bc33fa2f1652 Author: Man.Zhang Date: Mon Jul 1 16:31:01 2019 -0600 initialize Ferrier-Aligo MP scheme implementation from HWRF V4.0 --- physics/GFS_suite_interstitial.F90 | 20 +- physics/GFS_suite_interstitial.meta | 41 ++ physics/docs/ccpp_doxyfile | 4 +- physics/docs/img/FA_DRI.png | Bin 0 -> 162043 bytes physics/docs/img/FA_MP_schematic.png | Bin 0 -> 135098 bytes physics/docs/img/FA_NOR_EQ.png | Bin 0 -> 47494 bytes physics/docs/library.bib | 554 +++++++++++++++------------ physics/docs/pdftxt/HWRF_FAMP.txt | 91 +++++ physics/module_MP_FER_HIRES.F90 | 255 ++++++------ physics/mp_fer_hires.F90 | 103 ++--- physics/radiation_clouds.f | 240 ++++-------- 11 files changed, 697 insertions(+), 611 deletions(-) create mode 100644 physics/docs/img/FA_DRI.png create mode 100644 physics/docs/img/FA_MP_schematic.png create mode 100644 physics/docs/img/FA_NOR_EQ.png create mode 100644 physics/docs/pdftxt/HWRF_FAMP.txt diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 index 935dd9430..1707c7f7c 100644 --- a/physics/GFS_suite_interstitial.F90 +++ b/physics/GFS_suite_interstitial.F90 @@ -409,7 +409,8 @@ end subroutine GFS_suite_stateout_update_finalize !! subroutine GFS_suite_stateout_update_run (im, levs, ntrac, dtp, & tgrs, ugrs, vgrs, qgrs, dudt, dvdt, dtdt, dqdt, & - gt0, gu0, gv0, gq0, errmsg, errflg) + gt0, gu0, gv0, gq0, ntiw, nqrimef, imp_physics, & + imp_physics_fer_hires, epsq, errmsg, errflg) use machine, only: kind_phys @@ -419,7 +420,9 @@ subroutine GFS_suite_stateout_update_run (im, levs, ntrac, dtp, & integer, intent(in) :: im integer, intent(in) :: levs integer, intent(in) :: ntrac - real(kind=kind_phys), intent(in) :: dtp + integer, intent(in) :: imp_physics,imp_physics_fer_hires + integer, intent(in) :: ntiw, nqrimef + real(kind=kind_phys), intent(in) :: dtp, epsq real(kind=kind_phys), dimension(im,levs), intent(in) :: tgrs, ugrs, vgrs real(kind=kind_phys), dimension(im,levs,ntrac), intent(in) :: qgrs @@ -431,6 +434,7 @@ subroutine GFS_suite_stateout_update_run (im, levs, ntrac, dtp, & character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg + integer :: i, k ! Initialize CCPP error handling variables errmsg = '' errflg = 0 @@ -439,6 +443,18 @@ subroutine GFS_suite_stateout_update_run (im, levs, ntrac, dtp, & gu0(:,:) = ugrs(:,:) + dudt(:,:) * dtp gv0(:,:) = vgrs(:,:) + dvdt(:,:) * dtp gq0(:,:,:) = qgrs(:,:,:) + dqdt(:,:,:) * dtp + + if (imp_physics == imp_physics_fer_hires) then + do k=1,levs + do i=1,im + if(gq0(i,k,ntiw) > epsq) then + gq0(i,k,nqrimef) = max(1., gq0(i,k,nqrimef)/gq0(i,k,ntiw)) + else + gq0(i,k,nqrimef) = 1. + end if + end do + end do + end if end subroutine GFS_suite_stateout_update_run diff --git a/physics/GFS_suite_interstitial.meta b/physics/GFS_suite_interstitial.meta index 9cda625ab..0f02e7c63 100644 --- a/physics/GFS_suite_interstitial.meta +++ b/physics/GFS_suite_interstitial.meta @@ -1043,6 +1043,47 @@ kind = kind_phys intent = out optional = F +[ntiw] + standard_name = index_for_ice_cloud_condensate + long_name = tracer index for ice water + units = index + dimensions = () + type = integer + intent = in + optional = F +[nqrimef] + standard_name = index_for_mass_weighted_rime_factor + long_name = tracer index for mass weighted rime factor + units = index + dimensions = () + type = integer + intent = in + optional = F +[imp_physics] + standard_name = flag_for_microphysics_scheme + long_name = choice of microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_fer_hires] + standard_name = flag_for_fer_hires_microphysics_scheme + long_name = choice of Ferrier-Aligo microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[epsq] + standard_name = minimum_value_of_specific_humidity + long_name = floor value for specific humidity + units = kg kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/docs/ccpp_doxyfile b/physics/docs/ccpp_doxyfile index 339ddb3f8..0578d14a8 100644 --- a/physics/docs/ccpp_doxyfile +++ b/physics/docs/ccpp_doxyfile @@ -133,6 +133,7 @@ INPUT = pdftxt/mainpage.txt \ pdftxt/GSD_CU_GF_deep.txt \ pdftxt/GSD_RUCLSM.txt \ pdftxt/GSD_THOMPSON.txt \ + pdftxt/HWRF_FAMP.txt \ ### pdftxt/GFSphys_namelist.txt \ ### pdftxt/GFS_STOCHY_PHYS.txt \ pdftxt/suite_input.nml.txt \ @@ -262,9 +263,8 @@ INPUT = pdftxt/mainpage.txt \ ../module_mp_radar.F90 \ ../mp_thompson_post.F90 \ ### HAFS - ../module_MP_FER_HIRES.F90 \ ../mp_fer_hires.F90 \ - ../module_mp_fer_hires_pre.F90 \ + ../module_MP_FER_HIRES.F90 \ ### utils ../funcphys.f90 \ ../physparam.f \ diff --git a/physics/docs/img/FA_DRI.png b/physics/docs/img/FA_DRI.png new file mode 100644 index 0000000000000000000000000000000000000000..63737c469b2e16b5dcd624d12cbb3824142abe90 GIT binary patch literal 162043 zcmd4(Ra_lQ)HV)c37Z6WcMTBSHMqN5g1fuBy9Rd&?iM__I|L67!QI33&dK|J-+$&e zcXKi4ChWbttE*O3ty+)t30II4M|g+(4gvxKK~h3Q2?7Fg5CQ@^9P}3W#*FDO6awO1 zr@64Of~2r8v4VrGiMf?A1cXF*@>f_DWlh|{GtWbkyf;Ges2<`T$$HS#60mqA{>V}w z8df~gKr&8D5s{jxAq5QlWNys9fZ$JpwMTwo0pAfZ1x1aCYJ#%X>f20T_gAlc9@f1# zo;sgS`Syt*BnsdO8E{hG5(m@nz&^Fik{0Bfx9meeF?K_X=Z=1P=VtTi6C}j+kDKcB z_Q)|Yrxhdi#jcIl>ID6MxKs$iPoTj%m@)LAN#cUg;qCX3g1aR4mGC6CDVE47+hlJ@ zyibaoJbBS$WEx%@shvMpMeBoOCh;YL_Lt&rG7o=Ec=^{im=wXS^o)UB_jKYC zNV;EqENVCfINU}3IDPST$Lyi1K6@4hrM%M+Wq> z4PJHh^A&?IEe)A5Hz;I4H@X!hN;*ii6SLCz`yt``S3##+ne98d{f~*>efFO`!tOOm z>UuCa<2SJyQmG```H9iVAy9rnVTM6_A-`Ap#EcAudk%w748gmD1x>snjQy1+)A|Ql z^4I?T8nhr*jve&==>whOQl{}AV?W^imRPu6hXoY&CvZhNYO$q{Ai6st;Oejp;prik z^&kY(bfU~V#G6KKASP~@MW3%9ejYcy!4`y35=5kiWXpYX?GIN2!9KL)`bMuC35GOF z#J|xm{5mnfDFKq*kDizaJz(t%5jC`UH`71>AeY}^2#G4-IH8vX`vfoN zMou|@L-K$?_+&WcdGJ0eK(YqE;@!~?X?>ob2)Cian{14Da)I@mylzxF@6@{oH%;zI zz0e5#U^f@fVczAEE2t#B9f2_py%c2K<=dw@yg5@= zOxaJfQNMpG@DU&axH@R z&{Tc9+laqnwm<%Qv?ptkcY|x^UWYo1jva8kXuU`EBKX7GN%V>;AR9+{fQ%3FhruL? ztcg^RG^1K2jY2LCXBOehM`KD#l~@&`qhLp_MkYcNkdTltllm!Lk@QPqMT0OF3p>%yrF?%tNjz4;>EK4?Snln9*?@(*)Dd z(+HTInHP=4jP2{b*Xh;KE%7cH)_pY!rJ;_%><|1=XjP=5RHY!cQ{&*_;M6M8D%6VR zz~``iS$C;+xp|p(xqG?416xX6_Ayybw)iwZJAb{%M^Qo5PB~2ZXVp~hR5fE!i^#Mp zlU%J}t)ji)MI@^1ur!UNd8|_844QF6UEZbCF8prqhIOHga!m*G+hB-Jk% z!pUEfZ$1pFd{?DZnOE^vaW8{aVJPiXEGTO&qbS2D&r-)zF8Rh&?l>1Y&+x4)e|UD) zY`8&b*?74nBqF3bL}L4!SnNPUakfdSNtH>#9vXdqN|su?TCG~iLQB*4TZa>b<(p+B zXArjwHyrnq^LM9WryD0Sr{=?^gP7kmzo&2NZhqeo9wpxBUe8|BUY}uqK{$p_fJel+ z#{Chp5CRvn8`2#0g$$1@W}2jc-!Q7SgK4ql$9*>3aNjujTH(6UP?81imvqZzgGZOr z+nIwR&lDH>7aJ4n6e~6J+aaBW)k)sP_O<7Z;Ji1p`Kwzo6iYKJ4)w<6yF9dH<(%cc zYIl`13!|0Inyy;D^|g(gE37}GmMm5VeiAlxm{OTy88!Ewrt=M~uldx!Xg*CMvLgzG zDkJ)Gr*l$rEpWwroYlr`u5ehYNi0U|J^VJC%QDV2@L;kB^&IF`Ga8O*Wriou0m)v7USfTgTG+&H6U~0{@XW zw-;0ApH5G&vuV{s84r5z)yW0hf(>Ke1m7^d;kr9#69a9%0E(l;kk&flV=9#$ua%$RX(pndxX=pEJFKW-QowXIY zCB7tg+;LnB^ED_Thyx!<4rgCC-*zj$ue7kc@ONR_PT0->x|fuU6rOrYMqfu}SxS1^ z@*vCB?$z5_{F&RL=&P3pRVaxXv8fM9!ejEy5}&UF&8XM7I(T1{#oPuCWzuA9Ok7j+ z7j7%QF0C(hRft!cR-LWp*6NRjxFW*b>BA#2X?PzEwMs8;Q+$1_4K( zPT#qGGsj>X(P5_J+G|6G552T)KDAFpO;W98HNUmlnmuYLTlO3(t*x!Iq}HlDTJ%%| zT)b{B*3q)5wD4qbW7w7O-pdCh<|kJBL_ge|(!45Xm7K_NWKMHA)`ZWfOu@66vc)!& zH^4WEHQqKpG&(o&G;zF`JZj%)M%VA|?@XR>%k$>A`s@ka28Sc+4Q50hNA_kNaTDoA zv^(uzj*RlDKUeFt{r0|5`l`JcY$>-mq37DN?$UcIHY%HuF}}92CflX`x;|$(JL@%i zt7cj4ZR@#F*Ln5w@deA)bG_3e)MtOMJHo%SP2crwL)+W-od4+0LEsMT8DX(Nrccrp z_EpO-;1o?L`5;gGhw;9^e#+#0HEv(wu0GB*HYBaLI_G`1FTt?qCm+R2r5EFqZ~X^L zOlP(0>g9UT?Ry>BK8dd!XFF}#!>Rj!s!9T&fbF));{bZ&K~_^{kB{8@W_+D=PK!yycuOs$8aHtN2(fM~CN z>xUog2HU5OMzPO#m6_|FBOv}u;G(@cI}rh5z6v5}7XsPOEva{CYB=p~p+1FX4x>9I zW$OY7Zi}9N&oLf(Km37}^?Lc_yU6E2ni=K7 zJVOur2K;k|N1kS?_ng&K)?b0rHp^T^!%0I{hTG8A`lG&)t%31JH)}hf(uIKFb>jy9 zv^I9qCw8;8vT@{g<0Jih1vl_F_-h7I;=h+TS@Mx;$SM#E+d3E%vwdX!$Vkfnj+mI3 z*TKkyTS-Lh-|fIBK2kF$Cp&Hi23J?tkFG2qZ5>P*n7FvO7#Nuun3?H;E9f2FZJhMo z=xrRy{%hoa+7U5!G;}bxb27KJAqKarZ(!@}#79aBe$fB^_g_Da-OT^blWZLS4GS0` z1NavPrjLva|JycjD=+w4ZUu8UV=E02b8BN8N8lO!tZZz&f3N@l_~rjR@&CG0^Z(q* z#rXfY^Z)wg-<`Y+-~s$!1Ntvof4>F7#s7|%;eSKV|L#+?`fmsbK?q5aPbzMZ$62tc z=>4dJM=@S~Wa5yY0w5tFp+AI0q_TvRgyE2V`!)$m#c=#_4j=Yz4}vtp56T32SYm?9 zl=t-ZraJFyt1-jz`srFo+1bjo?Gs3d`jT45%-`dI7Icpt=Abxs(e%Exs^e~?*9d2{uTV&CW=D6 z1-zX7!{zSovSoE6-_c65E&Q!QTjAeM8j$6t8Wi6t=j(=3(_z@ix?Cb77b-HpHvBk?+2u<4|^F!o_D7UWR0$8>pc-q zv3Y!IWh%oyzQ6oop9gOO{|l(#HMp0g0|L+If!9Zilj#y1w(E57G3m}fpQM>)$L9%$ zK6b%A+1<>mukz8%A}b6Apd``LK0N>}N-llfDJ&&y+- z-KNlMYd4a>>vKK6=W*@rc@mBCPE9Z3d%FCMf3uYD2lQDHVxGsp;Gk$y`e#+v>#B7ku290I&X;-zKa`%jBmBBKy=o+Pv~nWurC&aPeYaEl+c{|ay)di=DLwgTh(IFb>;DImlAV> zsJX;o7p*E$R}OwK>-?}^ASapBYP5iJSAh;5! zX@=50>~vLXmFedrk`w$-R-V5LV)>N}#^A{Ls{StZBxHqgCaG@BLd}G?tk%mai@5Kh z@)uOW>ns-ncrGSHyP2x9W%Th5%GeHW<&j0(zrlDSPbtJ;KT*`Yl3m^`ex_y8BEOFP z`}E*gU||Kvy2q$zGU^93Sg)u(ULTUhkUP>d41TpHdnzzA?^0|N27$ zPCBGtv~>QPP2vk+W63;oEueh(|JuMX)5X4q__u%Sh!jdHh6Jj(|KHL@C4!_F?8`AE z$om)4Fd!Nspj1rt|MsAS7myp#{+}JlAP5C%==FQ^=TvAn%ekDcrl~9b?>dEovf5WK zk;_812>Prt%;a?(u%Odm7N6<+=b_H~$wg9DwV#(-!b9P2AQ+MF?>2mmCo;M8=ioac z5)2PgceMf$BCtN{P&0Hr*UgowN>7oi{tM^35QvetZI~D-z&gP;r>v1lW1gus6qk-c zvC+#={+kWWQK;z>KR}ePF-Qs2M@2Bwu5Ja zfu-n0%P={nQHJ0NOcPunAZDLs*@sMpnZ%`ZLVicD{~0gjDjg2bw8w~rTtk4(zK+{!!B0q zS?AMEZXn_%(IQf9G_d@vCSz~qfax*7hYULpMB`AJ;k9V zL`vC0pdlcKAHLM2vstEiT@F*FU~{=oaP3P}>orT3DpBmt$_pfy z!x`f)_EpFxBOoCpubucT)fv}0AE|jp9I;#doJu#NRj)dZIPygQd(N~hH-Lu?3sr$6 zWLMpBn?9DxB)m}lIj3^ls&1vqTKmwx7h$H=ao=j+=lMc>GZ;8h|0Zqo**(xx2QWrv zn^jI67LzE74&Y>vWOTTG@TxN!Ms@%5uwM!1viT#p&SV_-;`Fmdxf(s!c{lX#as6b9 z&DwW3>v9n!AoK_N<@B^b9RSd5OdWUYo|oOwNJAsZw1KzS^r!Eyw5&iCp90^iB|5z! zVUj5ZY3X)&+^o`+D&z&|ng-#Ma4(BT%1BFJecgn%Oo$cu(-MWxHN$;r#M62=8i7F@ zv^ZC)Tv>|AQYCc_&QJgIv?#J}kIjSWg55t)XOm)4z*QNC;Hc;6MkqlEG#V8 z>#|tQ6L>F&$e2BEt$Ydir$Xx|xTUok%=Cwv62QrZn#Z6Il*Z*)d@?$b#ZzQ7oUru! z@aqssjqL*IVsX=db&U=&qv-^GIoJ0I15EGp9@yQjNQS0R#=Lc(r<0U+MsHH&c_QCu zlCQchX*UuSDbvGMx@{F`vNylyPe_JPt*7B|iH$;Y8xe7sMFwIBj^y6&gb%#acR83M z!Hb_M0WKcVw(T&kj!Y>-c}E(~!3e8Y1}(Zp@+pvZ0bfW5={cRQKucYLpsHcMl&e)n)yt$=75D{B5l{cl zyrb?55i{%1SRpWPY>bVK-i*wx~GhoBgX+7Wkwhw{W;dDumSGpFU+B2Cjtw=1AGQn{e z+ejRZA>euL+kKmuoo&M=a<|qY>||ycgYOOm7l})#`0Hn%R^-!*D*ICs>6lrN{eV8f z)sOcKN!fg!j|65@YFKm{ztWq}cJwMgclk6KJ{BDyPx)Tt_v%&Shl0>K^j=c1Z@`aa z=)eA^@yBiYmY{OFpXz%Lvd89F_9^xmGTDCSue{$f75ITa2|bUQgadSUfkUfap9Gos zDBdmetwqpWKg99RTW5wscRJ?A9Mt14(O(56kJ-MBpU9HE~qmbLVj%Nlj)0@S( zef8+aOWEX;8w%ne@AaJUE*^^)Z@Mxav>((ghbPym3Jf{K0BP_kbcCUwm{JVp_kXS? zGzEH^E*UXRsC?HSJh%ixZEn*H!BJKux}u5G)eHKntlT<3UX5i=tS>Z&%ucD3oG&go zTzjxD=!q;2;4SV5t5m&H$mOu=iHJ~bH0*7nW{dam z0MGO`f!KVP@g^ZlyyyTtIgeaZgncMbp$p7emC3JocK8VNhu`1zyzwZm>p-^*_FpE_ z$6LRVgnED$<`;rQRxamohj6~IK)B9ED3Ybe(}WSy=!`iIZe;sg(nO#_F5E-SR-^Qt zIXBq9kU90bmpQ;!&K~7%kL=zN)YH*ywL>u_s^|bbHBhHUyHDwX@e~TNAaa-bpFdBw zZI&T-*h^-`@;TY#?)!ewh}3bWG$!-x*2_jK_o+v5f?qCohSx{W?$V;T{bNL)FlM0N zhyk(aMz(+kAD`8rIF!MoBw;O1tb&7qzV(Q%Kab^478`Jr)Mh_}R|J<<&V%64j}4vV_3k{g}gMZlS`;OW%u2e~wKao&s6j7JFTkrDDJOw4{cBhAp*W>ulv zwxH&^yxs18wG;6EV_dOp#_~C$%=g#ltJv{=Zl7m2uB|Y#o!{lvm`x2z;fO#InC?;4 zR)sOZ^IzLDX}{NupEnf!t!JdiCj;aC@blCW-D9yrlZESU)p2)T{c~gGcDxjB%TaZg z9xl6;*&@#Lo{obZDE^WhA~pzIl`*@X>bL`?!?R^p71A~IAW_|I9AkG;-uCxvs>q)h z$=^tT5{b>MQD2l;3}uKh<7&cJ!;99}pjl5+^D?h>#RlEn?kmaA&Wy-Z`)S9WUXRm= zUO4Brpxkjq&nT^14NxCy+O%wjya)-l?+QIcEqL6mxvn@*0MOyR9GBjv=PxE+EBn1t z1(F9sllGq?PxT3g4JZq@82%bUU+z5OgJZ)haBRb;3vEzx;B+N4nRE(+m?{@qDGx!Y zCHP8RD9cP1bJWsedaqYqR3VE{j9B9i>SEzv5Uoh)~N5y3^4>pGLWqA%9iH*yqH2C;=VOw~;+D@u)4?r#1+IPe#G)=4@nt6If= z)451)>@~!TWN<%K3CWd>RVjCg`9p;IEvACkC+F&wJ##b>&nM`hYEx6h}=2P9dsWrvR#gJN-X2z z#Wl2}m|#>KqiW%%PpP5wNq%i%t7Au_D4P|&LAcz=+S0!7WUA%Y57SsACPS!g!qNtP z+r!qr%Ii>s5fX<`E*nlxmo>Z|V8Q${Zr{~1Bx6{n%k*Q1g#``@v1Q3D?lA98-I5y0 z-VZoa@nsTR6j6py{Kx1?%lT24%-DzM<0)wS;vWI!_xG!OZfT;RY zDu*Tnfoc-PiVPhH?dC&jhE8c)BBZxBg(to&f1HhF7chBZ$|A&`J zFhm!er~LPM3lH)}E&A+XcAXZgmCR2VQ6EdhpfL6B`JHGbi#*8ra-}In8D(QGuQuzu#E(Pj^mhU4*m~7Mg;@po}%D?{YroYo@kV6Oi=I-GD?5} zGR#*@wSNHlEilkT{S@b@|3T;^xq0}18}R=r@@0P_tIqSzhDNn4DT!K_+%#VIx>bi!dWSXV z#o&3wF`JcuxW?lcXi4HRNGz*Xes8Gn`P1Y+$02k)~6!@e5u!Pjx1JQ}G{Erg2 zY!>9+kJs@D6w)Dc#zQv?+P014E&y%{RpF>%3>q&7PQ;l?ZH^VnbaQ}$gNpnOG@S=# zF%Ayrd-_qKD&Y99r-W0y0GvY!prSgh9e}hmhP!;Z+xWWPaW*CvW0orSt=EI}DALTO zg5eU;U0=$%SYZeOb&q$S*kHuI0^kL1>n&%W{&c;*$cMn=7)&->%u4}~MDfi0Da~>= zcB?;f#b=5#hak_9zCl0862QdEK8OI!d~)&4q27KZ)R60_upmZJ5$0)jo5;WAfv71i|s+Yy5kd$9;Hs@61j!vkw+qvpTFnJ-xuCK9#xO_ zz!K3Bd7b;Ox^8%b;Ul;hUj?QD%p_?;1!6O_Ju@HLd&lM$HUdnhX1z)DJZg^DrKGL; zvFW34KZd$SKnO1^5~0=L48Zxi-*1K*Z~hS7^SFa6HY^0d^yU3_tTY%`K~=MlXm6 zubPHUs_nXkA`%?i4;aW)@E0UMMu}HVnhkc&%JGaZoNaVQCaHy{%3BJ8QF+d8LLDjq*!ZjdX*$z8nsOpp+u# zQ8PDaoH&mut{w&COMOpYZ?^nYQ)3Njk5kM7SVp=YS$7bwKkOImx zYj5?h4j&B>b4cWuTL7T@93%J#VAdxxBbTt4fyumUU@H+ax!xUPnY_*^XeToo=>2Za zm`CWaYCrfO$*#c#xV`$`ft8^V88ZP?T*!qt!(Rdgl>kD^pTvefVe%t-z+}?q%?NFE z7?bSsWW`0^_$QA!N9SRyKr+OQHkT6%VJ@@4qgKoBb@;AzJ}+;(0ulCgb5`BY+HTxB zj+xI$d{?f~>=%38&DOp<-=?-z;bj~lS>|yP0VgC=sNX|;8L%{U9ixa-;pURUaT<=S zE7$ zHg7)xiqJ^{mU(k+R}(zmlyWm! zb!X4TvUN}^Rd5^UI7+uUrde@@74da0W@Fv_3n+)KfYjzau(FV1ESr2(zc=Epmt<^x z4M<2A%_T(W{;SB;V{GDV<>@>D5v0i0Fkv^ng+t$UpbeWuKB&tzXMf}KylueEV+qf8 zoZwoRi@>6Ve9`^x6i-{-E_K>o-^?ecM!?Ew06R_Uu3y*hnT!lKmbw1RbAdD(I?CyE zmCMY7Yk>;Lh)x;mH$d*a%h0f<8YfyN^OUbQ8Moq@5E*fwh(9z1_89wEpLtkj@6$rC z$&~39lkLH@@B*%Nf`eIlRJ2zOkdP}#;-I7lwMw>H1vqujktVfJkEA~QD8mK?Eza%t7UPMD2 z&e(iEEVhbazu?Osy6ZIPj}UrGhz5=GFwiI}N(>KN*$W|CP7ReuEO<=JrJ(8wAA?KF z6IY<^h@dAG`vEE#5Jn9*w<^`8g<$OZNRl(8CP3e~*i5aiWu}1xM1!^ENHq~2vg3hj zDd@;U{ zB9anS*doxe=$8|P_+6rO^2(Jle`I*kPP%wz%CrZ_jxl!padbIR;zNK4koiut2uXzj z#q%}XDx0DcKJgbXI>i)q1`Q6Sx!YcGVSqGjIfxS&9|7uP6^NV^ibhPE)m?_3=`!2a zpCB@ACU0)obz4gTCCnX0sHVQ}S)(EFU$7$tMZio0C~7(EUxh~sAl_7o`clJxI%F6K z7#51ZBHq8x66C;x(9GGL>Hal=@(CCYDWe71zt7=8Kp08Ki(~$2Zp5TOStbS}W-anh zwTTB0sc>nomKy4bL?O=CJ^}WxLMOow!zwIyIo=w>8IL@)`Z1w#J}OLx9dgNPC`>u- z+O|^$MQP}So#FGBONY)3^;)OIx<(OFk}{yDbU+^;g%x17aQtkMm2%DR0` z3vR44Xgg&RMR*J6?B61foU!+{T@%DBea?U`28f?@ol4`3u(?y4q1v*$C?7Q#R4D)M z*Ww`TBt#(;pjeRNKrgjxAsO1-T4^%+sXrY)Q1wW}B8M-JeGlA#(n?t%pK^u9I%3*H0Ug5a}jU}t7BSER1N@4n(3%Y-* z2mmotGciw+NRh!a9a!NKqe->;fhJOqol>p7wN`!meQoPY1YT%n(q*Fv?i~~EHq)L{ zP~+^&$8WIc{`sQ7{a{+H3M7K*kEGrdqAksOx9<(hPx9FE#EK|VNhX##43~7Iu{R2J+cH_4A*>gI9pLrA)T9^ z*UDmO(_1(uHBP}DLDm7oyT)?hx#XXK-jb)85tt;9D(pHL8l0H34mHHdRJe@S^;nxk zUmTFXkqgZ_29Rm$aTf%EuL0SYMdC>oLm4LfIQcN!ufraR8Cd1B*m$>?k^&^PwbRoy zP_1AB|KqO%8c||>AlxAmfrJT4%ve+eVJHmh(oqDcCI{TeqQv+BHim~~t1JNZ;X#qZ zRxge3e5R+Rxyo59_~bDN!IV->qx7makKNI7uwMv{YGIZKf!hp8_pP$3Y^r!*Mt$`s zp(x`IIMEk!@guqkh?oR5q{#4)^Z0>z`Ge^GBBFk5L+M|`(W{ARu7>)*o5!k`RWVWi zjyh`j0ZtJzzZ%j>krzR~`lZTRF^F)LE#%Rv@+_n5`Er&Y!od82y+q?DK!QN-?$g>P zH8f!}ncKpU4RsEtKs1qU(*TQ^n4~{FfMFIR`w>TGoRollAzuVwuI=pwB(DGYJp}83 zrv3)6>%SDx?F0Iz>HPPCI1P}IiAls{kR_lWE@9;;%cNu)^hasVOITQxy*e61>xdVC zf?|OUfB(~5R+QKT#SfW^d3CnOC{@O$H-I1*;FDPql5ha!r402S!QaBhLhA5^O{UlpR~%hg9`ilpg> zeE{WYruwtMicPc4+76f{-ANBZK8j032L?l)buWT_TR|_q>yJY;w3&>Uv>rW~GSe?( z(Lf%**5*3;v(|7Iz@u^Iv&F+qgZO0fycaaub0^mIm5{tqn zsqTC%14A-qhaCy`=ZnGJIAKJ%a_h=M@QTMBL9t~ierW_fH`;fuvhUJAIPZ$MdrmOA z>#s8|C8x!sAJp*Q17gEavbr9PR|xTj=NTW@b`;AGN-+jIw>qJO*M~{p9l(o_0I-ci zfH|cQ@X9b-{bcM}5(mi1N$QE&eIETH?c!wQCuQ~cA0@qX0i7nJ zQ;BYrGdxtI`_r~FDS%Vn1+>H@Fo^fKJEaFI@cK=hCn?Nlv^+x2UEbTDhG1fO7$~Oc z6@6ZA7T?(FX#dr6DF(4~h)?ufVE(K(2-;*kr^x8>$tuZsWyAdHDK6+t64Ayu0D8 zLb>9tl~W4INZ)<<>(!*d<>e@YG_Zemn^tUSoeZ29iQISM12~Q=o7XMI+uRybKB$gl zAwG6m%zw~qv5S`!tWltp%cKSvo2J6B5_)}#K79aosee%U_T{tnN>ehJxN{hOsmj@yEL}Ted+Rg|Np`u;^Ib_2+|a*Gm&nh%SZ1{_5Mt$aJBUeO%$Z zhOZ5hIHu4itw^kk(QLF(#j^?61GU;L)ro>AHc9-PRhaLP%a;lz(YW?A9mm+X)3C>- z)};?jMTyJ6g$ah9b$c%8SMsv$!k4txk4OgBderl&8m?zauKV7!r8K1u>WPj;Fe@zm zrF0rKf?(4C9w4{1?u)HnP^xH1@VPD-e;o#7YHEPI2+x%jG65k98}0R&9{}Igz`Z5z zi)85hSrwa)g6b*xz-&AtQ?)2lj#HN%fjRs>+5xc5Tms2psSxI`j|*@zxMVd-fBncl zuKUe<;W9!HVCJ|&B2rTrSYh^Tv_E!~w9~(87>re=?JUDt8py_Hi3NIjFPJLTilpl( zzZ#*zYLYHmO!E&%zi#-xHd2ZX`DutYuMhBOT55Q{N0$g=wFAKU=dp^xM%#_`ge?Ht z(SV7jCAXoCh*?B9IOLJs3j@kvcpO8yAKYZEx+qGES>Crx?3HVmyQ6`2&Xl|IM@CjX}Z(dhBb ztA=St9IPcAv#Lg*m-EEp0B#29BF6z;|M+-i4a_WQkUu4>?;o!Wh)gHz_Js;fL)$;8 z=$h(**qZWI)A_;U_7U~(8El3sW)tj27M_szCwB^Rirt)|xa8gG8vXQqsq$dDEQyHC{c7fPH?iDU z1!qwlk@Jr}IA)t;PT`sjt$;NE)3Rx!KKhB9R)CCTUta+=@`xNppTPI|Lh*#K^kfJz zNbCXd8fcjkvP#z=sNSYZ3M1VNgquCxTIcD>jSk`fHM%{!e)y_xyOO88w{)>~^&Ij7 z_7#+Ib$BwHgwl8s1_S*fHkxJsR=lKIOw$miVk$-!+%?#{DM!27KqAbJj)>lD@>cOX z8wbAH)KFFHBkobs<&tU65`Iacy`lB-1kYK6mZ{B=tN&v7!X2=oltHuIB>NBhIn6H- z3ytk3z!%XCk67r-jeo^^cvBOiJ^9wC`w^o|qz4H~bVJ8@5K7%UDICwd-5IXOGf z=WxC*dzSCR8JHu1VuqQWCSp6RVrK_;=^CzSB9PVTB9Lv-UyZ5E91N^GElZipuU=o=&+b&v z?tO(CF&%7Y-*<$*SSSPF5nRHh+^_c7D{&=Z@@dRsf)Z*vB`fsl;NY+r-4jYf z**5KrdPAZq$@k4krrXdmZ9zBRRLfI%3eO}1fHo6k8W8J$fof#Yw8)mV7!{2}^8+|<&SYFF{fH&2G3h@U_GQW}q<&B>6FFkmZ;niB zRV)~w47Hw(TS?`1E^EISz+(^2DVKq|DVO=-DD(5fa468hzsw0d*mXz&5ON7A^xC-M zN!N^8VR{$~%NmYkBrdGMe(pdVRf&)7BrGD)>O z4p7$yrP}t>SPP24Xf0>^S`n|1?e@}4#pZ)K(FNurQ1V&Aq9auq3!O-L*JO{Fwp-ptULfK|i{-rY%7OIUhdpF(_DR>RtbntxL}2~gA<{26kI$k}WMiSqnh8DHr&13O>;c=~Gc*AySh=1&AdT4wf* z)|F6ehVs8$EBgw;@D?n+GGl*S!j+3-kcxq0j^~C4lwlA8B(Ktijc&V}eN#jXL_NXk zQ$I?eHit+eKCfHN+U!gQuisWG*9PE{#2;S+bWCO%&{Lx?oh%8_648m zxq&Dgv^mxzZlSU^K!qLhZp0-D$G=SEB%qIp5+o0Bee&3f3#M{j<92>FB*8ZZ3`w`R zX0?FS*I-|k!ETMJgedgunBM_-Yh#(YAu`U5z`%GBW0|T6gCqrWa^=~quSp31RnZ}8 zdw8}AY;3&;2^xT%cjIm_hr8-iL&OrSl_+Fl_u=uCz1i-2INKG8CPT)46mliz9xE<` zr(Lf;o~dX1Ili5|fU~KIkCkQS*Dj@zsKIC11ZH?#)*(!a@ihY1YxcvJ2+aUWq*DL{ z8BNCjIR*5YW?Tw5q$&Umrty1!pVyj3428$pqEh*Qj49#(cRN(*6-&rh5hCm9y5{^f z`h6n;)j1KxAWXInK{~+Z?8HF8;8bA-3Cq9!d3nJ)m_K5F#U=E#-lO=4^)W5<&(ntI zvB^^00wB=>`+~v zD>r&8Ph2I;4_v48iJ+Whd^CMbXLx`(Rv-ttg$IkEY)S!Y{EO-|IT^`%=bNTOStEaU z&Q!Nim<1#?{^=MRF3RPo-)_K8$(=&B(<|4B>$}!_c)1gBaIUhC;c#n@A>>{QU(ZPI0{<_EdYBPh3g;yT zr>(wlE*<;VUOfjwcB|C2gR~%I&Z%EJ!d7H`646itBp#S~HSuFaFP2W}vZtV1hv zww<^da1zgl$XIQ3uK9>1dIAK2wP&B~_qwX_ZdW12Fn#h5p zR^&{LzA#v`&w-!Dggdg++WrJfU?hor5>@jK1_3EL2KoIK0henp0>{sv(hU*|&tWWM zvRchH*42@wG};EAieZVoY6R$@naNNfYr}1L>edxPR_FmCTWZ1(*ICnk z>VQ~fIp6Dx=Azy&9uuAAJ<*l9s|cP+rjeE-m=yh2sRT4)a&gX^Ic56It<`M=yo&|e zu}N|@Dl$d=FyLhu|2jQkK*0bcNf3Rr+pu8WWdLNF`*4C|oH}&^mi?|X|IbGJ@V7i) z;Rolm+5Xp5Bgl_zSF9ef*SMY*ySMcnXvv<>d)fW30f#gYVwpi&sIaOxO3EbD2ovzy zWP1~|{iR_&QMw_+g0@qYQTAmT?wn>ifVIDtbmaHfnFERutV7Gk!q9cR&d&0u>0Qu1t9u@VX1+t6b3b| zn9@}`oX{#mzz*b3Dng9Tql)69%uxBC>j_v(gaCdD4sFzv{3rd$0gsAG44<+2_rlKq zPcFdS*KpIodPz=6`-m+5x$U4$2nmx;gScG1I_3J>$s8b&Rk#}gA~%i2v?_^CQwVU> z#~;Z-A1zcS0&hX=mRqTCmq!B~5*!2T0%J0wNj%KLeH=qnov~vstXKJ7l^x^tH{*cq znF0J-ju*h6Jn3HNg%Tzh#`39o+#a`Xv`P?Qb2${Yig|LKG|a+Wj>>}R)jWGPvQJ5>ob^GrF@Dh@c0h<(4ufChAgdp{!7LfEN z@6~&vYng#A4Gs1A)_!W>9n;`ec2P(t)yRJR`E=SL2hig?A$T@%fR^upBz}EGQ<6#A z^>UlRl$??TyrZ#SZte0(UD6At#_9__xY%5K;IBqe&VE4zwkapz#$8ZqZ&~NR`azdH zd2~E*b-X+88fIUkKQv#QOD6W)?kvX`1@J8BO@7f=Me~lk5 zF>dX$xEm?h*iM7w@~2kx%UQ#?r*DM&kkzE$A>lsMK)O zIP8ur-3iXD{J*Gs>$fQ1HtP2)0)jM%AU$+(;~WPJF?XEjTA#IUAot5<3HJWRotdFqGKak(!|2Q{uGDQ+Z?IbXK8VT) z&FBCCiE7Kno&c*e3Ftu*;L?}CWS0j)r~#tdC4hZouJ*?5EwmN;gutC)17D2AM2RcCdXid5NBuTH4F?GL2NF!@?#f)9z?nIxaDybFopZ6tqsqxs#<{! zwz(U9=UX7j5j-7wyWwh?^T~38WrX$VYBN+7TQUSkbC$#L;uI!<;=f>RGzZ7xGk^S5 z06bWxl@XJgO2=Mv+Cl%n&Zedge$75u2TZ z%M`QToQ%IU@b6;2B?SL?XdLzqe7=u+OrHnaTOsgXw?xkSfP2G`4MaZ!ABUM-tr{$A z|7Mc|ChyzI`5yty^zuUw!HQt!hIX|WQZ`W zk*r+7468|Zn={3WB=Q6__rxMp-UAZZaGfy6VXb=71)3q4SYcVaWsKC<<|!eR$qI-m zcOaN@B~S+lp5-?fTZ)hoQ(n2^6q>`DlMzMwY=T_RuKpxS{iMFfMSusegYMq?A=aO`P`>~KY!r;_Y2~HRgmj(x z0^ppUorguS{aWvfPxq!Dd z538WR2-36N2~i0k<2h@|X|&idagIQ)&D=@oGIyEm-v&V3}wS9`t@y~3v{$La_6IdLI z06Y2d`6}xL)^cIao_yq98vyj*#-fC@K6|CxN<ul?LgBI zy5=q2ck2JQ3m^}UNu7Nt0M4Ad*VJh!DlizRyp+)SiNJ0MlK7a;8FCYJ-mX%JwF_9m z#yl55;jK6d*BqgL-%RN6d>8@e99=Y{0=p!kV?2taO@W#TspFYxKqP@}Q5WLth_^xE zz?m7PNYdHTcei`G&|~^7n0paUaOdgMit;{J?jUGp7HRcMI9C@p3zcD{lOg3|*80}B zBwb_TRRa%%<#q(fPgEWZn3`W{nnuC4{tzbCb#YO{zo=a)##1EYv0>K+C}d-=b4UlO z0J69={~AJXSF-ia4}PJ}Oyy+`_`Z#)B;qojBhX-+)0zcXU7zimHgjKXDb;=(eSg%} zTfdyfU!u)veeuQ=(5fTfbGfghk^l4Yw+2w5du}dTv@u|{0%|}HK>hIR>FJSwmAis+ z=`F&7g!gHA@#l{#$t?*pqq3Eyys{VVNBQwDhL;|92LFg-l~>t#jOph})MK?K9w zdSP|c7;iI5OIv?~Z>#Jm-(V{^7#~ngZDvB22u(_gfBWG6<=)9MiQ}kICed2a6!{v5 zUYE`qm8f=qIkS^uOv7EzF;uleW8T~0ch2191eKw@=j7}3JB&S*nZc{vp1w|Xe}@MakqXsQ_f=2c5!CU1~WFV&qCUS#6)rQT)tMoO>%FCKTT|Ngu2er!Ct?4Tfk^=**0Bj z!gThzv^eJ*ybP#B*a0d#GCw^K|9+n(^D!HqzWu;_{zjTXWttFEzd#X>NJ-x6)Jd7s zE?v+)rS0Z7TCDPS#e06*e@-USaS|N616G0O{OLTle?(m^H->)Hq)fMI>WYzMAoJWa zQQ5z*h+h!I&9Iy>12@DHyWu6thhY{r`$h{k*%F#vlug&6xrX@b$_u&7tPBF#JU9x; zrD`?S8e~n^AbiG@os7Z-P+0SK33qk~jb<9`2j^AoM zl&eKGXVwjCVz%c`_>49Rx4(_2%0CdjL%v92(w~pkOS9OKT51%;Gbaj{d;I!6G$ZKV zu~g@`}jn z6f*DPlqqUo=rX*&Yx7j-s+8v6KbVgs(re1exYbMBU#5mdHsVDAM4rg90fbMRl0J-I zFb)z^dV4*gf4m7f5i6N3Q6Kg$6Ay`v)#DYbNkqFP9=(CsYd2KZ*k>3q5GFq1t|Rj# ze4n2WHzXDl6ZS^+bm^?wP_CR8Jc)!k(c*|*?>s(wk#3ghN6wxrPieP^pv5-Yad#fI zvX`&SORaJIevFU5PyMhhd7FBA@>G4A5%fLb)-2~Y=jBxj$1MNtsP*n*YRvNUVy0BD zFvo`E(+J4DpD*0?KHjEt6{s&+dI^i0viuFHxu%M9U z{^yU+nyRayrSAo=9o=$gra$@)55~W@s@q=V_585Fh*-$Nj<%^EwLjA4c|a~s@g+zZ zn0%*v#m5qXP4|9^R}>Pi%M`;0#@6QTToY`crjP&Cl0fK=#W5qRRNm;d`+Q~JtivvK zL~wXk} z4im}@Ik)|6&-@ks08L5&NR$dPSn4+-1k|IuuM~d!@fPOliD~Zj>1EZikf7+uFTOY|7d6oA)-b(q!jxf%54aB+jO9j( zf+Wx@rwo!XB_JN|0KB;2K?8nI`F82^oA0ttjT40Ig-l7k#fJm3nA!55|5jtOT z6G~nC{y$`%n#@tB??!IEQW-(!e()&A%g4TONERF;m{f<#gmwbUZ_Eu`AqEMHP#eQ( zpR(9(Kt5C_aaFD<1ZOY8@10p3<&!0Qa7GVGqyPHy|T03Sfo2&y@lp z)KavZUF|D6l6`x2;2^`_XeJFqa`Y;i~xW%U4InN6DOdBWp;?EM$!Rz`l(c{*MrFx zKBuPEMy6X|yLUgK^pT(Qb!tx!HOB{`@7`Y@Syn$kW!0FWw(C_|B!-8$f%=_5Zj<}8 z*1c47|GZNpv#m{WiW}%E-p(W4M6`(*tb$-`lzhc33t80wfXn#s?x*oHdD>|bTU~ZU zE3aXaVF~~4z4-cG5MdvC=6uaD^ktW4;OuoFA-`*euoZ#HQ!MO1C~Kr!>#*eXYZ~+s z(2E5kSFd=-OrW1QfQ^XrqCGZOjJ4r+0)e5qAZ86$UrYopOV4j5co6W2i(pf7T1f^) zA}p5Q?gw?>afQy#8r=Uq&GOl~7bY;wGxz{XR!p6*y5eOh3yW0>mo1lt5b>lp9CnSUFVwHUW?1xKF?=zf+ zBZ8^>l}>Lt(AjG40YfK`TM^yv8Z%_gobfa0LMIErRRfTZN%#uKU{mv;48om z#ZBc(4C7?#^0=@LHgAG3Yr|d%;8~X4&WJMpRL}>4NwsO@lc^lCV2NP_OIy^aM^#IAq-`zUx8OwBnPh8-+Pt65 zPmM+^-6~o)IiS7aH(J%V3c7@hW|(jxMq=TI+|p=~ z>6OE(lI87g;Z4jWsOlLpg55RLRo_s>y}7|<&^_8-$9}Fvz|zKJt)>1UVYexiG#UqH zJe4C3xXry2`nNFH0hl>cRR`?A<)~zJ>HFSOP#s@S0Tn z3=IuEk_i8kXmzr@r5h0=Z2tT@!05k|Wi?d(vUNlBR~)4S8+qi)Nkf5bK#zdXA*2!= zZjsRF86kILP%@NRrtMh_zR(`dOO0bqN|Rv`!;P4OQ3GI=&albie9xZ%GloUI zB>QJ7D9{KpKMGO=!aTuo4bYwk?Zm#7{}U(3!^Ki}vVPN_CyXGM#yS3-xAXBbjKHSr z72J2aosl&8(?RDkhY5~KCA$w-NMCN#8;pYjU;LF>c8I>i{ZB>hk@zv*DlMXkn`1oJ zBdl5ZzlJlAr2h;US&oVVS-w*67sZJG*ZaYIB9D743IjzFf9!?vlrz?Is=)v{7%rwp z`Ce0wYp5u)8BZ~MO_eBpcYLX(jSQGq77{ zRtU6U5=?|Il;cr69Oqi(u_TB7GFzlT*W8*YkA$Aym%={*2Q**S0`d_*DV15*z)C5^ z84|z+-vCNkVly){C6C;AGoj$t{*tV3$3x$7jEMn;E1G2Jhw+~pZ*6Jeu?<9ZP?K<3@dB2$Nb1L~6WwK;J+eVh^M!_Dtyn}5t_(@s^s(U(HVHp_N zH_#`!7j`m*H861fmdNJDyUTNtk#5d;mY&}3Qh6H=cTpO}e;KS}(+zhMz{9BSUnXjV zTB1>%!w;nS>gn>PLrE(%ehYhvd5WZOAvLLkD zv{9{DQB57=AK6Xx;f^2q&v1Go>2M(z68`z3@B~CdxGsSQfD8xh$t7SJ!Q{ z^8AD*v~tZ-XmBstD=SNvcA`VAzqpT89^?3p%EC2}hhxe61vSdZ_47E(fN_gXvmJEI zK1x(v0L@SYP+hZ3`prpfeKfd-;KxnUekJ?L{z3UmHELf(Sl*DuR#?-{P?<=DRz0h> z2N4%mW^i$>(}~uD9l4b5L=uCx`k(po(FKD36;4NzXpLV*cE>ia6n;$pkMk{o`frZE zcz^(k^vmF%TFM#7$7(X{&#EZaYgyJ=|K{(yI1g|%cz$%15aT0#d?ntr2PAK!ZeO^Y zTdiW{{wggK9qvt_o%QPz+u!RtukEgDtaytGk@JJA7z<}VI`T_iA4q(yvkcZH8IPwf ztsMb{@gqc&_2>sWBn__fa)gdEVGii(cuXU)pqa`<)@t4Bp}ea3EE?i>QqUdwD3eHU zmgPG|kNE1RU}`a+eu*kg8pF;(Zd3z{oi5 zoj7v=Q2+|4D{`U_GU=Dv4BE|`y+PVo^|vHwsgFX%}kO?C=@3ocAD|;L)Se zf?H#dqpGMOBR$jsKNdr<{|oRlsjuHF{aMc4H@W(joxsV9WWLCw7gYZXuqba|@J**q zyIBX{iYRPcJODuK1JWq%%aRx>PoLIX(ytYJJ}~wS*}{*3Rj2^1AN6K9ds7BOUrG;R z&WXFXP5=^e3;QRe;sgMSo)`X?R&pxSg^Kc*HZKHdk=}VV-E6962fe!h!kC#0K^Of9 zN~$+7ADek5eZvn-BLl2=V6;K8;oM{P9)UdVL)`5 zY@Gz*%|`N(+Yl@&JgNlFL~4yzabL648*!MYP0HCuYyH-ak#R(}ZH@&UvLqe5kbb6V zG2JGc?2IF5;N&KiKi%QaEX|6aa$aSMiaWGRa!#G4-+p`GQBT!(dkoyfnSczK1g1hE zBQ&jNoO8Q?@Kr{9eveGRaQHgAkk?5Bp{V0ixeEMp8FeEL)b%`TZM4V{jCLE;)&L|1 z64D`zPSCXgPVLZmR}9(WbSlN1j{%n zK%tCB9Q431V-R?s2Hm+f+FY{UvE13H^qCd7Tx_ZH0lod|HkE4q5#d@hi~QZI6H29D zz8XwMgqI+pgTSA0!k4#kkANXuFih+6SVPCpWwJ&529ttjorH|*-nZ@YZ@cejbE5=kKRX-|VYvz*68aEK&HvKTb35D>J;OQ5 zg!1!xbN)h`ns_CTV4QMF>DESj)Fd`y^g~1|%){F832>CA>VC$#DjkNKAD69lSU~nD zBxr_?C; zNRmPb5O$naEE|`+SCv}ED^OhG?XYs&p|SN-kBO*s8@Aa<5FyY z0iFAcaK25lWA6ObeB-ZtNpjH&B!>7k{o4vGJo}bUxYj+$vb^q#9}U=T=lwO2j88(} zV9ndD$rC)LSnF}eRT1%>%`57!u#u9dsfcQzOZ>u-lyDcX z#aEYcR<9n0uCy2Ix*MAX`0Bj#mrd+v;`6=8$3RfAnrR`+NH7QqzFTavB}=M8LmNYqWxt>uw!aO%_^<^Za!w{@zrEKR zg&M_S#qSwm>2_9xnZZSGYP#INJnw7 z)L~R@@AZu%ocN{j^?3L(otfsErmd1|&TMA~^Eh9j(=A@QXIGYaVi6Caq~OzgMkPjH zBL=Znyumm}mykkq2_&PJ6(%_?AdEGJ#mt_p{J=Yv9|Yqp zG@VG%JZLGz5V(;3s2A5zJ)_F+f)sl+=H5VB^({>bJ_8;~4~nmMa;!w{-%RI_vgRfG zD;uK9+08f5scYHWAzbzKvY^%eMJmUAJm-}laUKB}((Lz6 z(3H{O>GL;P@f7P(U#x~7**)W#M0H@|DKID>S`5J}IYoK$AF>REFM?bK z@0tf^m*NnaiZJj^=%UN0&| z;@lz{;@x4O2$22+ee)tuF0vC}N+@u`U?AdE8a}fGiVYnZD#{3NVxhbhdhGcSV`mXFDJA&Q9<)`C7 zH&0l{R(B{(OkGgAi98+y+=-9lS=)V->xYOBXW!?oh7H49V;w(^CHdp?#2IsYMj2%! z(0$glHdr?D&@fH^(mgES^~w^74%NKgUlUTMy^RsB$*S5t`aZn+eaz$QBUELJ%5QJX z`#?>NfdO}AV=A2n-;CgHo4ty0lEhD5u2)~cAYcHysc5Y&p!w&=V4K6Ce6XSfL2hns&9+=UFJ zxZ6$`o~+3B#fxbm^|y_Rp%0&21a(1xB=e7k8I2xNB{*`=lsBYBaowI0*h3h0B98I= z$&Oz1{Cav|crb~kwt+t3B;`eh1f>Aa;L+sBZpmySfXsMKJ<&>^Dvm3KqoeGYD@}lt zIBQnEl(t?rKWN4ydrm}_G&430kE;xR;HrwcF|5Zg<`;<+UPLs0&S!8V9^DQw#5~e1 zOUd!6!hV5F*8hNzE{iaQIZ&7$W)u({^Nxmj z5jOP)NJAr^yFVf_6J!$YAp`esbwpeX3d!(=BH^$=+~`;I@dA@-2{R7vamd!?)V+ znr%Nm5Jvo0OS3>3|3-9FzKP}Xj}^Q0W$2cNFBTfAo{IwMs@znA4f8hPKD%DE0q?k_ zM>GZ#0+Bo(la|xPMq?PI9PP(TMdc8viZ6YhfpSB&{Q}Ee@%lR*-d}y2+h%W2E z9JEb#>kEvCK_`P=>4{7jeC~C|OoIyNzB34w-D`Vk+|>R<&TjUe5a?yk!-Z!#Ek24X z=i^HLd_zyAlk1_y!P9xlVyD!+Z0keGrMzwNb=<(nL8O%Q?mxvp0TiYv{@=g+rf7q` z(((%6=|4*RObSR*K#H{LB7G#=%kJlHT3lydX3=6d`aq3NN-4kHWJK)5EFY`nli?8T z9N^G3W|ru4?dNHto0mkf>)%ptt8*`UxO%Cz|v`WakZ7E)xZycQT#)b0uGLXO8qqBms+@O;NI z>&Z!bIk<}c*39LdWhadm&uM>S+my(AqUP!ue{cD^mXfa|dOX;r;dH<#1Rje4!osDO zv#QkmDlXhNEpLPf)`p&x4}E7Z*6e3~jD2Dm55n?0`vEcdJmu2)%rO?1-Wk5P~iSv$+v zc(LfsARpe~F)#S!*&=VdDY$TxR3kj?W&dytNG1w#ATvbs$em-mx2*FAHOq~Z)jCW)pgQRkJtVAo}^@T&WaJ2W0KJAOK z@lX}TwjAXL!_ZLSr0;kJ9y$GLc6Rkc$CEgBF+uaB=8^nQh7AVpEUYmbzkKGqS+>S{ z5NU)}AV_b`CC}QfBF8<%5a9N-+pyH$`4~Y{BQeH!ltvxOri4F6gpmZuhD zW7BAt)vd0#mF8hHQ4mi&4J4b5eG~l)%vmW6u`9c!y^%)mD)~(Z?96=l3XPfxZxr8~!9^dIpLjj5D3=)SA@qcS2OozFH0s^% zmM`O{aQReu*b@VBE|u&`y716=be61;t(9vIsw9HvgR}*tyC72YRV3W=kv1EUI7BVd zBk8iwn@dvBT;G1Zvz_ib>^WLXRw4e|L>dikrJ&p@qZ~@6eJ30DTYiFLv`Fx-2V~KH zHn;9uJ9N+&YgHuvwVGFptn`o)#WW;A=l-!FEyK)76zx)rSvASa&4ejZ>ok-KQNZVp z-H1ecrTm6TdVUyGAU`DoJ7x^}1Fnt-yBCjAkU66Woth8LLOtqT!Y`894y!M>By(9r z!=vh(loiUSMyRJ<)q-D>h#ru-A6)b#WC~mRp4c`H`j7A}lXq`;|0;y=zu#f`@!^e#h^>SFOGCH=nf0r$e`irx1G`CbP3P#0++~`qWuBM^t|4Md9 zbYNp2s(E#0>-1tslo~W>?yTdkc4{OFk)(%jo2pMwz=O2POqF}q=8i$A-d-x^uObu3 zvcrV<0b?bEElHXs_D??T@S6N&+zI9L1)HJ4c%Sqj_wj6r#-wq_q0Y5UZBMd}dAKyo z1+Ub{pV1gfZaY>QI}g3iYJwB6-1Cia`BA zLa0CZgo9qVO%*qR#n3VgN%$k{SHrPWhG)6uK)!4VjFaGxK<_uSRj*UL6aBHq@5X*$ zut0o*XVmfC4Dvr;?bw<1L;GB9WcOy zG7h#%%R$#ph_JeP;#xKtc(&5%fQawqtg5GaZxK-s`y(h)qFY$GQD;!sGW8P z`WP4>ZfOqWcff;|t<-BbI-Jg*E>t9@(QT<~Oa=u-v2S1L8cCHL&UaIi!3fq)?nXnz zj25fDg0^}RBJiMtL~t1xemLv2c7nZv%bW+U=rriAN|sU?w|H;VSl~M=PfmbkK|h+v znE0x)gC6MBBMU z;Z$&I#%#+hu*d17r5%26aabyyNcT&j{ zt8AgKsh_Awt4>W;=*Z8ny<}FKG`v3ZKDFlI&jYKcaW3~%U?ozjSH*57OP0|;YNAeTw zK3Wn>qzP&;%&IgP4R1~7iy_fiSJ~GXngk*fvuQe=-Y+~3+|+A>WFpVqq8NGmR)?d~ z2r40mG*s8EsnZuMud6ekQ~ItZ>n#5V^!`Bu<6p%-i(`LIbzf2H)oUFyUl*`fG$CO| zU_E!y)6M61GlT@clRlzmn9M#Dh%_}3$ygd4IEGwE{ypE6a3a>yKBC zcQk5p^3=`GDqH8mkE$1*Cx5#OYdR&Eg zmX^6}Ezi=HhxtzJ{1(Sko`>V74Er1B=SR!gS-~jc=c}`ylM7Y%Ybo8*kH?ZDhS7pc zQVLd$NK8+ogPUhX`bz^ZS;xeK?n3uCLo;_K3FlHBn^nY$o`;PX2OUz8S5vrNcb!iR z#>Tl-@x3y*c9_Wb7dz{oe=+UiJ=b5fy(4yaVG-ATF>jCln0A@GOupppG=+9}HGP1k z_tA|Yjt86MJyBv0`BjE(1;}@B_(&eH)I_TOWTYTFM_i4AtHJjFM4w!y9!N@ zR_N2@I2vBQghE4E43E4Vow$P=2gnw?0oof|+uNkCPEXCVm7IL2n>?)`fmeq1tG8R6 zOABH!OG^u5*N;3t#6H%cq-qk5A+=Po$Gsr>P zq%i}SX6XV#0WZ&kFBwjKoy{&kbaqx*-zfIba?yn>5mCQ<+@jy=C4Qp*eO>Y5PuLz| z^T~~_QJnQPM5NJy_-ljoW;u( zq9f=$+`-vFFto~l8pecHbA~9h8eq_UOy}8>uHaBN3pwbNYTE6%c6KB=@555u2-APu zDv;aT%4nu3oQYdyhj}MXFEsEm5JvP6Unh3@xVlYr&0>Fga=F7Fmj+hjcVC2dIxgID z3ts14%;bW3%<_LbCIaQfg2;E8idb`7TGw0kkr)ZP+3mV68()Y!{szD*7n?5PG-`j+C*?KH;Q_KP~z8(*7zVF)A^Hb5uC{#uj&u?5% z9y*K0OJ+aRWyyh*8#@0uZaZKdW zA(4XAr&&(Fk>`|1a3dDdXaBlpG3oZmAWHJ??WX6MJMnjOCf*|*b87J1sopn2|3qZc za&mqZAXvzQ+u_;YBSu&n%$;p=DYxwzrp-An$N)mf1z{V5__xxM+0RkCmQFjs%Jo(B z{G+l6%qKNTN>mO|ztm49c!9|OZ{y?STq)5{eQFrB@E?rcb2hg9r&2*5klL4J*U9;& z8@I6a$`;ZJxfw$vE>6e?UO$#$ZeOFf=5{zw$6f7vo$eLJiF>p71|{M?mkTzMZZG@1IB(!`R-IsJ4;1l{_50g{~;9~ zp2k_CN+IF$8kc6{`WXO23;$U`T?iqat3jtu&z3EoR-jR7-6*sBf%DZAzX#n8sf>Ac5f z_mQ}TL`2ZlhvZ{=n=+PKiA%oV7-1jFr;rO7>O)R2cP#oM=qOe!`bMjE$5V(PyuOXV zDMcsZxx|(ym#AjxNND`Qy-v;20Ykb5eY}r0&Z`81((7eei!Cy8Dc+;_4tb}%+KG}- zwctqOKM7f$LA(@zok-W)*M-wXpwY_iuE4V_@ADg_)Q4BQ9C$Q~oq%Nb5h%%4bWj3kMhQjy9#}O2ZfG zkj|9-1a7Isv>K^72!69-Hgi5iM#p2Tn*?RT~IKb3Dq1*E|I z)_@ArB4?FhUQSf3eW-P$1E!{p0(7O)8TszQHz3^%t%Xx10|)Dzi<+at|6WqVaDh7L z?f)NsfmT8;US-JyG=DfB&;`6VW?tU6VFA0V6*DsVnCS{sHzzAW%gf7-g!UPX`WKGb zN?koYFpN=wmFFAiN9v z=&?ga+zlu>#8O938Ft9fZQH)UzxMS90d{t&>+=zg50jmbqn#U3FaM%000BZ4H!R#B z9e2S)fZFzaT{(F6e0sJ8TH7>klj*p6%ID%@x93}a^J;^GvgwB~Z33&Z7GqK?L=I$| zL%X}XLt}HL!e9O>zWD1u&FS~=?2!BWFK|MnA*0?8jo!UOLkNOThl<-L*4_`xx_|8h zz&TLH{Bt=2dR%-!Xj-$%C8}RJSx{BkySkGdlF8#Pol~EZCKB|(?R;A4MER7Pm^QdA zA}Ja4AuZaLGmRs52ef}*geZFS6lt`!w2ZVKoxKH(ff`?h>-nI+A{%K|8K6+3ma5*>z~LThjm_ScLubc zwv1Xl^x$;-fL^MoWt$}<3A&Ry{!(}xh!M9?R#!R|5nJJcfgV3l4h{PFxbGqxAblP1 zs8bx$_pckx3;oc+?b_V7&vh$=3Oz(zy>ab0sJNKM@b=xXQfl;N<>N>t?lj}=lMkB5 zf0O)I$Q@57)@kw~;xOxX6VB(S&YdgV2l2Nv>j`3CJk<|IG8Ena_h`wDNa2l9{b$yW z%Y;fDQnijld23b$mW1@K+DXB%?Ck70#rDSpnI?xBlnPcg~MKKCe6;w~4tXn7%RJ z-`}5aqIu)$RW`N_KZ3$)99$>cV@%9;qaeCRTTqN`0ID7&Wa6tLOxasn7Qizj!xJA2UVcOO^_|c|tx)Ut*Yw^H*lWJdEBy#!^#z{pg61YEi{zAhBf=V?go~4=# z{!vs@x7L9m)sT7(e^%-IJ~m@-^5t=oMNqKAO-frE-)qmr3!Z~xbIx)XjdZwum%+Ll z)Nm~byuVO5IXyM@<_KK%|FXatqg=_(R5;@pB2Gi=9pX9LzyhwLR>&30rO=b-D?;$> zKOFB19CXQaJNsrGmoxWubA+lk%M)uzlMo;m*p)XT77ISUeK)!A{QN9CTVnpu@mM=^ z=n^1KGyJ;F5*b`n@%>6~pu4&=E)3{N>0N&uU)RBGf!GFOGD4L9B&4F}6p8Ha&#}i~ zGMzn0NU3Auny%o&(w^yRHZsBNhO;E#ZmzBpJa3>qZ(vdpNS{C9 zcV6Hh93PkU(Nru36@7c{(?zi!LU<{2t0$=6r6v98I4X(QU0U*fP#*HLl8_57i%4f2 zfq>fvz4Q5~(`xl#^okzaY(ItnRbl;qX+lH&CBb(~u8YYE^thNNh*XVqV<)04B8U>PECQ|Lfncv^Fb??M=>z}8ZW_W*U7{8|fi4y)$%}^?n0aI)1j_uClSiU? zoCs*%+GUJvod$w$yqRHJdqXZZA-uooH#;O>$kI;}nBPLsAny??i^Su8+}r)|Y!zE-&?fY0J>;ztf4=N=DqYz3NkK7!482TJc7fC5g-?NAPQDk% zj#L9@K=Ci;D=nys7S)L%w*N;e zGR$R?_*wAvvx^Q~8uy?S>6xO}Wn6SsxLurvSn;B*faBrczwClH)lqBAJPmbqxU7kb z{q@sX;rpx2_5*=5OdrkDT>4}ZWIizIW|f+rM|Wa^YsM?Trrc5lDU5%(R7qu)2s=gr$A$E+TUs=(lcouRXQ-zrqnv^qRnJ3hYaES@jgO=3+~rr0XpET_09zA&=zw{3 z0V^8c!yiw2;&jvPX&7%j6E87y2$Rnnxw`4IE{$ma75-|506%|~Kfk}Y88?Rp$LSPl zD~3x*ZaS;??=d;WJS+?&6}&=L_p#_Zwg3XP=qGC1AA}i%rWTfz-Fz6b(gHmcWC8bL z4zx=-W z|Ft-sc01|+U_y&eraKm^(qt7jJT;LpTZ{c*vZEq*M%(XNGu5vWY;GACDL^nc=?dCH~^(7C$|QT7q~&onJfj zZQ3Trf)^%2Do$g+m@}QCc=ymVd7nr0t5B46PTo$RT{^8IW_Uu|q4UE=_N)dq4^8#b zug2Op0xP^We|AXh?vURbvg}Bas<*!8h`%AwIVenu)6gM(;CF0jM zKk^9WzeN|mOBls2M!iu=IPQB?j>SAA!R#~fq7kXLNBM)NEuBNum&*}vkrZ7!Ci44D z;zty|K}_X%r?U#Pk0#D^b2Bs=7L2nT9LjDH%x&2{V?*wL)7Bp;1woT;KdVx4N~qFURPwRmVGE`HF;e)siJJj9dQIZr_}SR}&RCyo zR{O%#zw^=ZBw`dlT2l;;7?udAv%sjcsv@0OiG0Qo;B(u|ap2?>e4{8v=8G)z^4$51 zzeiOVolVGy6@`aLoirLNP9Hog8J*2wHw{dpHFW^VTM5R!vBz9UR z(pCNR{t7Wq`U^(mYcJxtvIgXnJThwIZPU{~y-hPw7uAs2`k8sD!*9k01R;y`%MZNO z<@Pw1-hwjeG~vkUd7fjDcqKxvb`BvZH68H3r5NJ$gT6w#@9>Y%m**qiS%$?GP8xhQ zcpFz&ufRy3OUdjfmj~}uojpBoT)$IYTZxjZa#dtqw0&`voHo9>-f;y(G0xqiS5oBX zCDUD3Zd`+K`jfQT_mSF3{X&7E&@gUA{n%wI+pT^F&EP0rjziQm)GuOr0~P-S>e0Pfqk$k%MN|2IcPhvv~D%v-x&}87}X9QcD((O{%;&< z6)G&f6i!)kF1zuEOlBum;<=J+8x($2x*naeLWxV4i@V$dGiyH~bcxA{_5*Se&iV#? z6T%9oSbD7Pd&=c!0$e1Zag2^UB*%W^?bdghZ(o@V>bStvvFMke|VU7zQ+!ke(rHR5!;U3F# zDeD)As5L}#x%YNYM$!{JbVYvVU=O7oBGzV_}Y@Vnw`A->z3tI z9!?>OHU1ja71T^(v4;js4*>?;Y_`cQ+~G_GF8jEv0UiW6Ob+PP^V&weYv=4Qeynj#H4QZ<=Q0YLh1)%6c5mVy7q_Dc?zKbFD z*)f@Gu!YWa1P#mf9Hb;xNp%m+$>n|BlOi(VaLbriV|E6^R8yn8-f{5+lPoC?kc{rN zH>gw6{XrI?v{K*MdSl?Zi+glJnP%AHh;miU7%7u?`!;(UDtPPaqK(Yb!X$7G;;VyO z0-Y?*+K@)4C`;Dfn+fGbloV!oep(LCkj%VkA(u9Xq;wzrg(2vF_uW^o#58xT7Tw_g z?E;W9QzzY=C!3yqMRgLAFNzo95i`MC_gVQ*9zHq+JMT-L-CwEeobq<;@@ucZe;vPi zI3f1#zquGw5&Ds(m))&Is5Yq1i;i6^h?*T3=9GFhtfWhunJ-%>pULfsS|~YS8;VL{ z_*$&4JeIn-=iLG1=vt*FPs<@BS)=B|qS+b!r+^e1g%8701h%2=C#EL|x$TB{_V%^$ z)JaNqV^g`cnbVi0VPtLd4AkQP4|i|b6<5@Biv|f22p(L5LvVL@cXxLPPU8|FI5dp~ zcXxLP(zsi2cM0xrI?wyO=lq2`Zhza|YmZ)g*QzB|HRsf3#MD?<5~UOm1$0s=vL)Gy zdWbe`Uq0Ojyx$k;;er4Dt$A#H;oqjeiRylcYM?&3^5fx5deNJ%r1-VGh%GD}+;xKP zp|^$9vRPQ>X8N7bLpDq?J>2PDXZho61NCx3;WDF~d(nzwI4&?e6LvQjU*or6B=RWQ z(PtDc#KZz=S~gX);^o9UUaLU!wm@!&1e-DwHg%h@qmRe#e0b+3A=w9Gvx7K!-jhnG zbH0or>@uvQXz~1o9lFcp218SHoRNj0JhE{yyRPtg4SKrtirypp%pClRU?rxe*{YV} zcEnBvlbiFkF#Kg+f|7Ih#IYAgKCplopEZ6I=tHI^AMY{2rpZHC#ptaFHGMvKFrNr zp%`Z2=;C^PX2E<^Jxo3>G5&x7UsJv~G-Fy%;>emQMt2J&b|pFoO0qm7;ljW})BM!Ofg>Hej~EH3BP%Lt){0klXu^tu!g zmzOfiSCOiDatDWhc%pi95qU?nr>56JKbT=r4^mIba})@nke_VXY272 z@=jXdnoH#tCfRus#o&@gWH7q=y;Ww$PdcA`gWx{pIz8Mngh5$xYC7`+!0tkL8EWGl z5NqPhC`(o}` zC~R}mz*5Bq{u}#23|Ty{;WD&m!T|+9np2^>y@A(-xl1GPB=g{Y%YaLm+ND{{?z{Id$Hb0)pT=(7DphMKwQHJIsPtwOgt|@ zsQ7ApYKRhrSpR)$Atm1&dvgQRjhhGXl&YfUaeJ4W+Zu#n05!{oB<+KTDNRl6LmO^S z7Teo<&Fyjnd(K;v{jCp~Kj$+rav}qETu&8wC#O%T2IYJ?P{qhHRC&$B>j>8@pIx_r zw?_FSSSC<&nZ5I-h2d}bWrn)e3Qb-X9(PRB(@5oTN1vO)<`xnNH)A5o7jVMzx!!o?EEC|g1%vV7%yeqpi=gJgTi4>CKHq!TcxR6jXiT2SOq zrKRahf%0GKgGI>SL6KK`@<^F&<&V3At;3_Q1uc(@qtQZ4yeTpsAiN2a$eKu^h?eD$3>^h|N;; z^3%ky{GgdaaMTfZJm4{i+oWnLtJ0Ro5QmXWIVDWS8?ytBt?#A?iw#xIJ61240k?q3_fw@)EcXb>rTg7$|{H zikBd6<}B-~A8)XlTx^z5K${r)hXBOip7BGkigXh(ipHe_V#D=6TP0+< zkVn7!tg5dx<+NH+^AlC)V-ZN!0Qmg>CcQ`KdT)$NUWK=huukpUE(F$Y&9$} z{ZWTjzx(*1@loYN)tmr8)|#SR1*aqq@g~56@IRJ7K$(h~&JykA zpcw@NPtB9pt2p&{-(%r zh&HZ zeqRku;_>40mn1w z%1A#(u4F}GYmfJRn-xX&r9=UJi5;?RaDBEFP~rIcbv@Em-4A7!m^$gtwcA%b;%pO_ zOCEX^jE49&LJw~**1eUX-DnlHL1{%9V5!noPE%uknqdUSj&}XEiDk+WXU#59PWukQ z3*Qf))f;t>a1%{kZnmQ~%zis_@wT;1kLA2pwO_E5t-FE^`{$-~)Nb>u$}w}FEL&35 zjgMbwc{ds3Tl7>GXB6RcWV|9r|8jcfCll9WjPeNHJA`Q?n+7U!+(vsM!^| z@gJYApX*Z&yE)}F%T6aC5xwt%cYe>m*!7I&$-tFdnFyf@INo9kAjY)H3XSo*J?lUv zYQG4lRu=nW8!<1sKUH_;NFSFWYOtgb(FmWl@JzGyq>|#6^S;Y6sK97^0OKUqmj$mZ zHYr^Ujylv9;yw4v*zL$9t|(RkUxu#S&1_NkM-t1WMyX*4`h8-P|6rW|ttHo=+94`j zS#2W>ymH<<^TM9dU?6+l;(NH(1%`cPBI1#}SmWV+UOF6Kk%gz~5?6N6H9w3DkAQRW zMa0cbRB&*J` zfl@)`d)efQM%`1bo7am9`BLFU2)@f;h=Bbt~~& z2ugt<{ycg*i6bU{mLI3xFAO2ic;b`Se{s(Ic>0Sb>ov^@4<@!N6fTd_kv3TkX>&&^CVgvv_mwN8FxhDtg*6CroE}WtYe3}_!4M28pC;bgj7{u z6~EacStrHC=2znv^1oA$;G;{k3%hmuPbBa(9I|j(WSQZ~mSG9H8ImQnFkQ=HxTd)NVImELtjS40^?Z-g4Ho?DwMZ}t6&si{NNuYFuKDTR#`qftxd#d!HV zqtV=>WAFsYgyr%mn<>$}AW2HFJ&`~F11FNDmGuQO2g`KeW}o<}9fdXy{&!B2+dh~ zK6t+=WMgnSxS{V;C#{y3Gmx0UU3?@29KRPf+hN@*Fwm1UCc++LVw;t_$(< z#XihH@1SN{SKF}3^p1NHuKb>(Fe5M<`e8a)Ta*PNvsFRe`ItC1rRInM+&24|fUtwQ z23j9s820L8PfV6uleHm3XPi)d9ex;TJf5$ub>_c@c1RPrpIsQ*Vk4Nu5ReZK8;ti1 zbB-sjo?*RlGe{-w`(WTsk9j6Eey62;fH z=E1s4yRm0Aw4tRUWm0vZo#*GaEmJC8FR$z~2`u2lrs3^ZqXr?DiBBA~Y` zyHYRf7!)KmEwzPFU8_#jI-u4z8mB#T)2MJlG@6V=F(MiwF4aBg^Q*hLU?4fAabcZF z6$u3CJ)}XL!IWt7=)^w`d9(SrR)E4oevKl=FgAL5GHK|)Y&OlKBl?BN&eAo9-;=lS z7^&8qJ|0VRBQD>j=7Ww!>EdkGuO&~rnn}nHw2k5wId2wpdZW#)igz2D{?Oi1mIBA7 z7!RdYW#uUueH}zDy5QqaN<^kLLWJo$4FDY_$_ImRy~e04+Q1=c?+SRE>a{RSAGVhU zrDTFV_Pch`tU3kOvj)~1^E4h+ObEh?CPobc^Yf`E5SbiV(r=)>JM9cNYs_~Ci9?rjv~QH z1#9Xj(l_{2QOGEJuycjJIjQ}dxUo`iDdvL%OK4#z#8CxkQc|}p>`h})D6!#&!l#!O z;7HVR6%;2;Nt>j73JBO-k?5z{74>#WF%ZPQZZQgiBuuaGP zKH0y@crn0?a4DOaO*nX&V%XCgp5~*m6g4j9eiEC>XKbOr_pnR$6vy9JhC{^tP~^#s z%`zl_n@k!^fM{!SgZqRU;4tu<*wo)YN8568pRO%MpppA=`AHRms`e!X%$7=J`0sY8 zdaC@gPq*xvwaR`XJ`q?a&-``9h?DqpcGP2cX!biBwY}QKnxrmBIT1_1%c9_1m;sY= zY8J#fi&eiqgw%%-@+wD(M|hU=GNCakIu2^-zT0!k$)6sG=663_?OHUy7@jF_PA=0Z zt_8gVT>k!|^_iCe%tts%p9y0`fKOY#&C`~4cjSon01+E2yL`MIvt8jYYIO8k?l z{gfGeFB%WOnx^lp`u?P#n*F_T4olRQXLaE_3sMuKE)_I1m*vsK=eZUGa+iC~ahSwT zaLpdXDx41dbCnK7S6L% zse~L|VqUvJ!yaQ^Rc$CKi9A0upZnH)&d51+=7a+zbh+c;W8-GrOb$)PRp^2(77c{1 zq*5LA;`erAq}Cxxxcveigk((Mn_)nNXRC4FRKwIMQh6B^foO4>h{xIKxKiuq`JHhQ zEl2ch^Y74Ru#;+yLsJN4);KzH&TfC{9e(f(;)JpIUIEIim2#VcI7KxVQ;GRwbTs#u z+$Uj{Jgu1={B*E2vj#>to&vPh{|v$&fR+!5SC+;<;W<+w#dY@JM-jqD?7s{<<-Lbq z;4^6>3dpctl-_jrH+X5vCU&~z(C*`WzbUOYi@5!o?Q@RMX#n$+nQkf%ja03zP^V%^ zE>0buE{GyOk^6ndgq+9wm10X2E~*qjD6}@Yq!ecNw<9-~_{ct|rXY7fEJS(XjZKQ}lkYVWc{ZcS!cAxziiS8b2PqQ8fP~A^VH>iFWYKaE zAnNi7Ngvz?`4++o70Hp_T}&qHeqQ{ke?@MKGgfj!TGmTvx!KmiCZkGYo-^?$l{FcU zINYUhjfu^31#@}@lX|5NQ%Mh3)zzB=nTH&WaFuX=B*j3G)RaQqsEz(5dBJ&MZnR#91e038754 ztb(1XRE(z&KVUXnl}IWe9Q2ms_fnEXocsGjqBsd6^R$Dwd&X z7XB)z^GSx-j1vjc_Q-=wb&{sv6irP5bR;`C>A34tE4oTPUy<;YCJ4yT;j;@5F?Kk# zzqYg{97`=frm`EC1fcorCBQ1cC+lM*OcljD6Y~>@jufm3iA%BFB0}%v6R4~>@usk4*98JYsR*p-wV*;&o|_V6-?Z;DeS4_ zHwA~WGJm8pR@G9<%die?532nXKW=dtE^#05nYa5EzUt8&j8YQ$ugGvas$6a51FW^H z8(X(^;CdDix=I=zWc^JFj7g{OUj{4ZW}If!-m6IqjmRSBCy`Q`SmtlR zU$=_KO-cI^odd=NQd12i--p=YxbLi#P;#?w$w+u>h&aYl@D(g6nb0&c#u!F%ph)|X zU3;j~SgT7Jqm>5IF4B@~cX^cAWZX=C7 ziSg0bf0W6Nj?D!P{hp#YJ;)M_h9}|fe^9`Ylmh=uMDjsp#$mYp=d9TOoHeu|tN0rl z8k0Pe*^1#RwX0d&Yf`6iB;o*^WKOo#;pl!8?lytDOm@;8(w9hbb z0q%fyJY|q6`#6%-B$nZ60l=5yG*L%$7P)lei~_##)moliBnr=wP*PsPM;qnwSrlCJ zU}x0%YM{OTHi1MLp#|ABp+>VH#&=T>s06s;UMj4j@q}kR8?muz$@Hz&PGV|)WEp2z zKN=Mdhpp9p$%(uGW6%~ONK$5bCtpooWf3u8gIIRb7yVxu{QsTdywSeTNK(}X${Z`= zq`k9E3i}qr-q*t>=Er(8W)c4oFl%6=su`<6<%4;mWY8yq*_WdTgq=@l#UOG$M8?GV zQc=Q3OSD{}DC zhqr4Loa8J-OC>V^V&vM!vwNNULeQuU=ky0YirX+PMxQt(J5kW083DM(v}<4 zC~ombu;7!M#S?ab=m+#Tdg9~oc@L%KE#A|h`0wcjbYx0an%&tz`LVWo*dL1O$LKqa zlxC`M3)kwZtl+Pz;z`%r&^oRC923_dq9(*4R+1{_-h6zs>oOS7&i18twms{9KGO?| zK4hH+gJF`FtD_+mncCt=0^e6oLy&ikSY5(hC3HNrM+?{hlxG1DsH6LO4nljCL(gm@|l2X2|fE=^CvrJWZ-u{K}p zJQ%tVN_2QqCH0fIW_=mqmnU0tBGV^VOf~M;oBF}@TaPvzH~RUQKuBf0pP#$O7fE4R zwU`*>zF!e6T-Nc&vSGN&zkiukWI;#<`a8VpSVxiS=cBVpjHw8WH{SdtIRL<{V!$_1 zh8s}@AcaA+O7tABar4xrcUJf}W?J@;wNh)TkQq8MwxFsnAF$T&RXtuvo#In>RsF}gy9Q0{c zrwvbg}Rz$_Dhrj6^X4j zGH<{?in11k*5QSNDFZntxT4zw;x5o?NJuy9462Rgkl;2U?2X~dzc7$Sa9|8Tft;e$ zgg0_5p7~e$iOyXF)X5z3vfK@<0uw2A(v__7>JC{%M5}@ta%YZKF+{(CinR2}TR!%V zz{b|ch|4#Ye_4l|Rl~(3kQAa4SHUt#&nE}E;`gsEecK|_p`=Os_~0qWK;&1_RB>_~ zD!>fR8v)~Oz6*WdJa3;~m@(bP2!(3*)-CO_H~&K8Jvf6`RG-*;>*MJ{?{=P+*?amo z$9X$VX$Fc$r)NEjxsAa0#@Il(%zEIiOK?u*w;Yx93`HkaBCN7iBtho9W7tek>P{&JO2GR@ns5$mF_ZieQ{4KUBrj|b7$;hwu5e(Y z2334(!^Xkgy~vHMsjZ5Ix~Ja||B}Zy1aeUi!KV4lz`zC@Ql>^tNfoy! zHE)B4BC8zp`LB!COqw}g@fYU^drZVQ zk;2mb)8g;TD?ItQ*xx`I<5=gQ;S5YRHI}eM;ZM&C%2#sqjm(xTV!waZ#hQRHP&3sJmFvZAoFnjDw%rzN9Ib^5{0Jf_P`Jdf zWIZegBUpsrZfIfoQBIfY!E=sd(;}8xOqz76H!LTOx7&JC8jP;XQdP^1HWyuJLGOF=oV<5 ze$8~N$orIO6c`%Ia~;8ti6%ZpHP2CT<58&2t(4@Lyh~iOFiR{QPQpv__)6b2mJ)0} z4XKGCh$01-@+wTX(kOuQFx1+|jk6wA3>dkZSZag%CVB#v`SZ<}anH(40s=k27-5Gm zW;=r9m~15`qJdx8V0M>Mk`R$8Fk_Q8_9Dy}`a~rOF}cCJ=anE20-F_N)!;AC3;)@h zcsD!zH;;GfjuEVEglRnGhj=NDoaun>T?M3HVMa;l>&@G;D`ZI3a^r~a(}s5(Hdjqp@mVkRBS9u@&v&8#aYIP928^dVL#=WwY$W9 z)|VdmVV<9zcaKQ$Wmsjt6oONv^yt8v7kT2cQg~&)m8H1gQF(R{F*q!B!Xe=@6qzZ( z?K=nZ$bGo=NWSAn=@E_?W1E6*4k+-#qq zz*Z9OfR1;vqVo9i+}u!Ydzu7wNW_tZ>{x#!!0^N_1o@Oibo&Kiz6x^Zo-R)nK0rI@%z7QSWWJ_eA9<}Db|=MmR&d*Jwk$mc$*7ErLNY4#@e9}LAEC*3 z+Fm&1_XeLr*W7V)*+GS{9G&s3e@u_1Q9R0!D%G`E;Y9f54{>+$*%YSYE#sTIsgkRY zkE{nU5HIIS6AyEVR1t)axhLdNa{JlcSiEa>`76G(j*SpeR0w#UNy@>fRakhCCl_IH zDk6S&1`U5C1buMe=Bewcfe*8pQd8eXUm>uaTKpqYoGVynYbR46g&hBnbYLM-_paXDFG{4=-rHgcW2NCUgn zVbZbb>mbb_PO1$xzFFQa+n~?l#+-dq)pyiIUNHZ-!pQ;`Yh=aItHuzF7)^u)Pw-S<^@D5bT(dw{SfxUjy)I9!ZiKfkff3NoHB9 zfNck4{@vUL)Vd-vL}f)>EAG&K!^r&jmm%%b2C?PTbq1yOk`lSre9~_TIpf@aQbJsT zkE7b=Z^1GEjoczHi-58y9%UePL}rs34%o_~OTF}6dvmGZh8Fy0;jbv$!2dbZ&3XqU z2+({yLzEbMdr@1#me`D-&g#MGei%?l>x7)LpzE^=Y|%DN86|udIi0M}jI`cPcNDvR z$#o;O1h;4}Kg?WI-KGpF@6vmZ8S=9nowdb)T*t9poL-PCwA*uh50QJPIz~{f$_AHQme)H1D#iRc!9sd8g0oP$LpZ1Y{Is_vHd3xbJ zv>IKmxVqCMf~Grl$*T*`-bru3BTwF8qguwm&wbmwqju1EXeznH=FDNxqc>Ze* z;L~bZkUaH2f)>cv%4d)mtmgBVg~$JBxk6A|%#ih;3ptJWKb`ykc7s2IgkK*w*wT<8 zFg{Ys>VFXCe_-5IUdUK-BD&ij!^Fgl=e1Bh9y#;K&&`D*d4B*qU6$P3{HK|{!@p*i zw@x-Ty;oPPf;YLSm9hN?*OmTV>+qzD+VmcsYd1cS_xTS+Ngymdd@t9m0q3GKl~ef(C>HCI07a;=!IK9ZCAM>cG0Ru9hEf!;n0D@c$b^lGE7u1qlhM zq_h;E@p>roUwh!7Ltx2d*q*1wOuk!4mZy!4jWpO%o~Qh7oB#75j1c3jGiq&9fg#8| zNAG{~8cuc80{Z{D1hMpRt?W6J^XWe%=ikl?KUAaV<;5~{P2SJ{>9pf#h$Wlh?mzRK zK!oA|vlkGwc~vctAh^ckpBw6Zgm~b}Us<_|{D$0I(wAGKcMielKa==2%t^8at_{R- z@J>D}D`SEXn)>JJ)@uLK|9Qsm?y&S@W2$XWi%;X0q+fG!x1Dtzx4z>}TQ|HM9RCMu z^e`kPSod_lN0Jrr23YmE=(Kd@%?umeYxBi<)%%~mZ}K9P?0OLeI?gW&y1}%VV|w|{!xC7q z>Hqz%jt%*JWV_X*Q%0wZ$^SB{=>1<|?jpT{`^}+B{RYAMUpVbb?+C8bJZmsy@F_PU zSZC}wxY#TX@{GhMr=*Zd#6uiST=wOrSja*0=^rlHu2YkV#Gf9UZ6MC#SxreG6e6hc z_sZbE?+h#G1&Sd{I|9t)q(u>_LVW|pBlrpk&IP}{}g*Uzd+qCEUC9}-I+T>kue^PTRjwEb!!cH&IE{rBv{;A5&W|Enl{%c=kU|W~_#;+<08{yOV_)Gj74f zwzW~mjdS1rKL}SE==nHEbVK8N%&5-ys^prEPemna|MxDJRrMCSfVzK7qjQd+7HLHI z>Hkg>->(r$bZ_@rItm2}RB6>{9777K+7~oNuH1bwk*7`-CV_eXE$1dWe5~7d8j! ztoF%^aWX#g@l=oYQRJm3%GWLoP5 zw})QDeeS$tP4bD|9o_QS3q6XV-FlyzS>i)^_cI+bGK%oi$;nCIZa>Ac?($bs?R{d_ z5Z%_ek)0joF@EGXoWagWI?rz#QWh2FRr`>FT476io=bG zJjoXttuKYEp?1A?#*MC^{_=Px$nLApX3M?1rfGFXJMe8mA z;+q4mjm_d@LB#~D7$Z`geY;am3)-H`oBQf--g`MVHE4yJ_sNVuc zA(y%I@_T0s7|m4>JdYx2a&+&>-S3mjsyUzCaa)FwX@2mR*d!6zfKvNUqY)PMhYuZs z^*N~$=}4J`bf`b+fmh50i8l4|ZL5rl_QKf2t-YZ`yS+(R9>eN0{PIvrAL_ElM){>n zky#^<2_5121>;EjRfE9aeaO-R*KEQU4>+O}I2C^Hn4Y<`j`dMQrJKK@2j6=02u%p2 zDg1JM(ihaW_YDLP>&Snk(}6X2yqdJ%`E9u`$4aNIDXqf{I{AwFwzp#5<)UET^~W3= z1qVE~`{`;5iIbBtaL;TU0Qf!s=B3CZn7HdZi^t|Kb3%Qc=&Zx2@5xh5NY_0Z(ZG|k zxqa8Fh3zyUHbKgbP&Dj@p_qaxVl=gx2_8X;%%IL5?K`>0?-+mWmyp3;cVl#@Nq$zu z2C1`#nlsukyS1+l71c=>&+I#;fGzG)y7*BhM@A9A)Mvow7}rE9?$L*l`|2@=J;(O% zN=8f7z7_gNf3yr)cYlpWLxz0Ipj;v3ej zkEkrqm);}(duA3UijUDoc|+N0Q2*$i7E-^Ua!1XjOOM@mq*m;_{eU>PFt_dQ zy%jbnHWhfXN zwhVW=(mYA;aWyqGZs550vBw6&V%%I$fV zLA&q!cReItbV4-P>UmQ1+s`>zyPEeY|N6}r2<3lZ=@IR!>xRHmlOMsLN(igjd`uJfO8rS5FAC@20-W&`mex^6DrXkuSU#1L53>po} zt?PzrLzrfQb9+r-#Y71CzoX@TABs;R)N>5ZCDdEDEcnh?=CU@K#e)<#8Uh24ni{TE z)y~5Nre0K|Xm{g{A!j1)HMU0+U|3t~w2A}JqG5coktk@vq*gLEHvW*XjBw8571yen z<_pI*%f{_|1DjV%zZBFfL>T%Qu2^UhBET0cN9 z36>i7qwpK){02;wo|zfD-F+0t0M%ym0zMtUP2|=l+x5J?!iA`2{WNSjca?MXI)6N< zX=wRD)ZPNu;QF~m*z(|MGVNK_kRGHDDPYlG>}rz#9+`@Y zdTM$-2<92(AHM?=vEQ_GOTrU^q@?8EEA%P=i1?!Qo|sa~wecMEerXBfVg=;e+1U54 zkOc6pU!UKna?#dHk3hSa^m0bYJZ^DLw(#%Kq1LvxwhI5pv0nE)vyjgF`?)7F34}47 zumDpMpU~#@00}^|QPkmOGmGcl8;Xf6fhc8~A6@H$4>10Y`?dNR<4!scj~}Q^5s|Y< z`hUL!15T2zhX{)3vu2uKnwi^;iB(k!-R?c|YjdaL^E>bqqhri`?V(ktT0Qlu0b=7S zWQ63oStQ)ub(s*vSVG-b1au*YP?FcK6bVbz{NWUhuOLaAPn+}2gUTI;qx5d4(7U0V zyC+`K!Z9=ePm^`>N`C~kJ-Yct*vOw~*93ch?rVhEFA5@*AD=nN@PaN5@8ss`syW+DkDL{*WFiKloCbu28V;s=q|_Q%p*Vx~;uEdXCBrTfbhNE)FHe z*xM98R~kWJ#d~a}p(H(Tnnv=$fWE8lXLCb?bV`wNQ$_%U7UV4R?C|hdm^G{a(e(h` zAQoRky@hJ*GRDN)WyJW~;>OO+SK^p-u1m203k&(5%FODcm*4LrxI@`{ldOil00+7N zE5j>keKuD%TwWpb0&vzjaYIv6m9dM62K_@S)phsZXzA{}LhV>40{Mge{i)TN=<_OK z*?n_;(gmc+pQqHjWU$msW-b9Ea$vLRa!bBa>Ej32`MePTcr6{D~+xx(;Y*v9k>R&+pnw;p}zn} zgvRKIk|YUR-_uL*U&t{QuQ8v$d}d)=E6eAR`}%d6Bg6-3f$rXRK_8skOM0z;w%Urh z=W~1IvvNa?dkxw*+^gs1LZz7ts2d3=0PQLkc;yBJkXE4 zGJun^tM`^zpOo&^Ok+(BvJCnKeqT?)ijL1dJpAaDr4RuCk~e}IJ90*GmseKCqtf*; z0XA8=GG!qv;$H-~_^i}t^LSByKzkjR7XNLm4)}cOl_7-4RvGh<4PgZev;`zU3Qp+x zDajR-rBmD!cm;o= zlZTG{CiCN* z;e3dy)T#=JSC+C0f9&c|$ns3sS52Gy;z~4n8@~e^CClEbB{t_cg#T5X>Y8DL{N%`} zCO!qmCJ&Co+$#yDZ;RREz?0x}9E4T~35~q9dbdz~4E?GjMK5r%pt#xURwv~^=6i`< z3EQIjIecr;RWPG2e(MBl%2gBOGhd6C*7bKAX%JcMJb>K4+a-*^IhkR(xa0FLF3~dL z-Onk%q9VC;jH6%oG;Zj@%N;mQo8=z81Uim}V)j~pWQfaL{#1;5CVUj}XH;)tn*3ib z0H^(ztf&ZMnvGb?L$ z=YJZ(n#c9h@uqVAjc2yn`s>-oYF$>0?}~597Z#UYraPUC9)qLlty)Yz0Q8woUqM#M z6pMjj+4BuLj@Is&g`k}h@%9&76fGY|rVA^92O~tjBdIL2+AYKNs)nkeR~n%` zDl@k>t*VIW4v5tB>Byuspj-C6>jtsR?Lx0XNGGQNj{tYxCeN0=EF5X2nTCEbqlq5d zLY3Xn^#%jf9kX`)JK-w+=jCf-wNE90d*NBx=(@l8K@Nb3rm>p1;Xkva(?56x(S*~K zuhX8q`C%?GPibpMnpD@&kY(nctwr|rzK(ud%R!5Dy!^b{sDjLR0r3~t;Wy*crE(+t z9(YRd=MRk)njFLtI2~_Qci62^#ogrX^xeusd1QCGW*2S0M}L%*y`sDm@qp<*>)O|C z3tz_>JxMLcPMVxExDL`5soFNvWnN!7Sje2{&MfSK4>uxvDusm?5T}KI_AQV6s&#h4 zC&)Q${}R8Jb$|ua{W9Am2rDi?amP~YBx~KLX)Vdof1vl9hN4Q%^gTLcSTnU_LIvF` z3Bi7_tqizR-od@dE5B|%Cgg1xiQgj)Ok!cuKWXs1^X!+}t~d`Ef3-fbXN%<}a8PR@ z`heMfwBCNdUHl%GJvcW9kq_m1DJf=+Da{8ExsF8osqgC`SP1$&i8+(}tzq`NQ z2dJ&Sn4Nx&4@rbtxh1RNUkn~1#bWz4)4I8~Of?b!pykKkjk(# z%z4EZ9p`~{ZN=(FJlnv}sgWLla`gE44@Kvur=LokI_LAJuj!zhv7mJHVmfP2M{9%f z|J~M`RJEr7F45q6;D=OZllAat7CQMO$^XzT#GJFCh2{zitSALy0ty{6yfq-1h^o=H zJ5F2ma~1I>Oks&Qte093>UoA|x;F4r}hfk*i1mjwnYf*LD9A zIpRkn7YQUS&iH5q!A13Xj^6aQfH5#(Hisg<466(Qb%Gt;6WRTN&#D;3>9El9h}1gn zyB5k2sO%Pk^3)P?I3Z*Jwg4@LRbW$LMJ%5pr!Bev^yc z^UV#T=Mwo`1En_2=!6c{->#7JFD?-S|Ev%{s+2FfIF5t>V+~5;w z_f>;Hp2^6E`v-9LfBiFZ(+g%HU?Dw}jl!F=eTgvK10G z+)CW_+$#u_*VBs*IU9$JN{$l-30 z63o&~6)NjC*4yg+fYI z4Gj(9_>to{aPYt@>N#F|#2x+@i$^0CN9iyA5~ULi(HXgjYUA#330}`=ox+CIoN>HDmiWdsAb7`&upR`I9M^-=tJp^fQbd1Q|7L@>R|bg?|_AMAX)sPLsD{Fg`)BwY$ZxS%#vf;#=YQFe&DyTM|m3*qFj}@Z{b)facapVv%DN* zS0(s7K8Q2R6;+(At+4#^FTx_W*5CZE!0F*Do}QeC#Lg}hfAyE(d-PG*gMrm`LZt28 zbjbOIU--{BKQxHG-ahQvvj=vEKIT^hQ#amm2*}zXYwAUZ9JM*#aTierEE#f49zgkH zs#Mqd~yH2edy`!(a*iTybY3cMroQa zmYM`;ITDOR&yu~HSyI|T!s;UAdR`_nQ?hD)0=8Vyj3*3@3`wTKlvIWJb@Nzl)h={z z7cX7JFMjz8G&eS*qrC$$@iBT7r6C2-~G&XMgk8bfeEjYh2>btpk3gBjdEO| zz!thWCw zK}Q$CJFTs)sHv_&UthoEEk+&J(5RxcWc_`{D7H0sx1fN-=)n#WIo zD`HWOH+~)1)B*o<=iv0U=K%MGGvf3JLr;m+ioA635-Mve5f&DPy?gi0sT_v}hfq^n zgUeSgOR33X1cwAGn-P`1J;(;EYc|hD0+s~Sl}}`votsgPGYFV5FWv;TWF8P4q9v?ir-5wVblqzVO}mxD{13Nkz_eD0O5EDDrZ{7xybArlUN{arX5cm^YaKpm)W zfWysVxCryjL=zb~Ub_LDIt{$?vVP3*%5lpS4!Sv+5;GI6o12>(qM{>_wK@x-5ur$4 zkqi${$(x*`5hxWB6pW1Y3}xS0k+K3l-ad0*-yHp#uZ;xeBLNy41moOK^?K02!rVtQ z%5jQ}Sje@tr4>cRMQCknMPyhcl9H3)>pL@oa7q_yEn2Qr#+kI)f1xw=G?vzTk&lOv zSZAbVz)|w}B4y%cYQnN;^SSrUEkIeBu-&YO<3IeL!XKA1ap}FAH)CW?1_CbROnfFQ zH=w!^qn{pz!_FNT70a!mu>oIv@dYZYDpihKH*ZCd0CuKpUOryfvSX_#$Y_Z<_8}@Z zYEG+>{ZQ$y%vy=>|LxzRn=wb>Sfyn=lMz_Gc4rTx-dP?noEZ^DX< zRK&zaKRFXF6&(o>_UysP>#w8Q(;M|-6?%Di$RZ&c?g@$Ld1?;^^KQeXyZ`=8?ibhd zE#YOYszSfyJLc!-e>yiN59DF(cpBl??{1$K(T;EVH%pzrQ_j1SPt(&nTX$A5M@^JO)RVl)L7iq#@ z>Fw)1<4v=^ux_4V$gw0c&u7sQREkfeB_h|&_+m>-GcI4gjHAboA}}COEVMPq-n0(x z;<*@o^<|7!{7`turQDU(q`cMW#VZ)j$rWx@VsqS88CBI(;ln?CsNN6%Ab(`~W?FmL z^_kum{*JC)yN0HQCL|;#AS-LNfRX&rF6k$260#s;Pf&1>xY0d~(zNT{Sf-uR(P98O zkM8Euhs~HxvrJCWk0+!SsJ(Mqq~_) z^hl0$S^D@&xG@E5SFhFdh?v+IIE&&WBGuuUr!h(p&WFeDUm?fU?J{_Ob{M5`7;PNA;j_5q`&U$!Rbs1D3i0&v!b+jF`|Pt%@zF;g zX)Yx#;-~gK1y_%0>yO;OKJ&^*z(xWb%N9ekcrluyeNW#CrpWl~U ztMfUhg>1tW{XpLUS{qwYS62tJ1dWV{n^lMga&mI;`H|1z;_4#GawWFy+-8*HLWFC! z9g~2})tp=H-HdXyButl{#9x#sT9UD;DB1c4`_bOfu7zXi4w_3b-tUeoQs}kD|E$l= zvys4T65tq1mnt1AR;(CXoY}?%8M~82{n2;c2XgOB?xwy4&X+DA@P&i$6E|jbR5SvG zB;fe*&w8 zR%wb!SX9{b1nl!WjM?f5mVi|!cMOmt6Stk(vR95&PL?G%n+%!2%vC#iDJv=~P*hl? zxm%@D-GHvvREanGc>B&vIZh}rtrW zK0OA9Z@dA=b?YR%b_CVc)k=C!Pl&Goa;UTxl9KcwBICI;&iJiA`4)Qmdf?;Zg8=^k z{oU+)YM&}?B3v^vGvFzyJEj>4EJOktvXXgqqM*Yherx>O&5v9auw+bGGZeA`foVkF0LHZ>mCt&OLt%!|@g_i&avIQ0B>F$Z5q9Q@p zwIeP)PHW=vhdmVvZ}mC#*|HohK#qR@2yW)o^Dyt1sRSY;;qd0`7`^@fNT7Uj>~Zw? zDRd_#p{S`*EXNwP*m`?=RXJX~a1pCAR!Lfi@U_Z#?3T0omfZvxEl8Y%p zdS@7KG|fohVI)9r+yrMe2eO^ovQUn!FfcMS0`f)X-OR&BfBXn{itlLLW33dAwHmF( zvuDrZ_aFQow+n8=VZ;I67rk+><{n;r@kJy`ZM>kMAZ*yU0dcW$=$3f38r&vS3&;`5`QD`02G_8r*&%zjO=nCQ&BFcNsoB%oe78SbzI;*GY}Ln+5s!@RL8{=&_^l@e;mA5h7O@Yy{dA7Z>CG_uof(dATyN z`1twY_O08RQ$|GKx4-iz2nh67Mv1_kKl8O1r`{vpNXv?x`ki@iB=ArYh=>r{ zxa}A{CJNGqbJa;KN&nni@Rra*>WWnO3*z<6+0*Fg>_BH*CwlvObxd+0nVX-BKYsW} z+^f5%)zvo(O&#+OO*0ZO5`Zx9EQ7`vV{>aWDk>_`-PsLqq2KcGk_2NX2c;U~CAPG- z;L6o2sFZD3M(BIr{T}}6dw+#*e)F3OQXpkqQDLDfQEqS1Vm*jroKT3es9}9PSH_9N zrDWRd5@0O2MUuqp>+8XiN{<4rJ^L9w#@{l5Udlz`1$j(q?!xrsSuA6@yF=sYE>13p z5M{b~(`F>ZB}|}T{beCYZd4*$S(DMtW8u|3rX1S5H4?C^1T5D)jhQiQ$9=EKVjp-} zSdOmlu856~g}bLa;uGT$c03GsitcE20&9Y8ZEi(rNvTq5Z4~7gpAfI`@~q4(q_0fJ z#fuk_e>)$k!s|(N-NQECIMQp44v(U*zfWDhyrG1&8z92;((RCh_48-X2~}tnHf`F3 z)oWMVH3l~QSuBxHNjVo93WqgW82v;@0cevig90Zmo(mN&Iyo8XM8xBnW+dcDAL*a4)=#c!ypuiw0Arv;@DrJ4W z$Z)A-F8O7oy&^c_VH+nOt6Wf1W0SghIYFhRrArQ5+RQcm9`?XXd4IWAeLcO%&&@|p zUXG$2R|_YoX|qT`6x^^d&xWLZ&Bf!v$9 zXlQ6qyhwRfIg%2S?h|C#;dGXTaqw-zaIakZZcvtQ5lkkUN*qyiim8n{o}HogxhUm`~d%;6+#HT_)Zt>{8pw8>a> zERV%RY~KK1O%vI@dpDAkli}v-ZXMb@+emJ2 zLR8Tu@x@o%CX?dFIy&PuFJDoRLpXKvq>Mc`q^G9CH(hFz&f<+492!KUq=HaM()~)W z%cA`@rnwIDk&(b`5};QjG9nUNw`@g1Y=SDtTgA6@mq97|ZLhZMlq21!mes}yzK^wK_|wt#04E zjq5kAD>{{A$ll)5PZ|rkh%pqEP{+y5b8~WozmLCx$j>1_E-2V&p-_Gk`Jr>{_auMK zSbK6xGXDIp{~8TzvQhlu?~#71YLZAIgf#ydvHniW!mLzWQy+i!F?{`fk)53lqE)#V zoQlW}2nxV+&p)SS+en}h5gzfSZ6+PWyfG56qXf8Mb9Z;w2Z1@H`DC5Yu{Jhu*yHfa zPC0UNC8DXPw+FNet-4BxJWNYw zO8mpE@+&V( zUAfP2=JXj|HB)JA*}4TUJpTeh!a^QKmJ|D`TU9I}0&)ll;-9^5>Z%%Di6x{d2WhMOc=O*^^X|A7YxEdA9(uc|AGmCF13`!)Wuaot8GL|&|kOeYpr;}Ci} z5|=ZnoxXDBVVX9*1SS>~Vtuiiye(*I`aK@6Pszi3`t)i1R*1hl+dFaS&>_6~+97bv zJ&MLfVW1QgZrQsFL+^hCR~yb%;flfmM^_|eug8y9B;&I`jOB^dO1;Gvsr48s1Oc3A zh6LQebS5hLfPernE@^k`_fZJP9AjBXfa9{ZrWRK(UjE<=cab^jR zIZ4EwDsEL50prkWSxVM6UHSF3^-6l*DusosDyuNe^qoi4MrGm{62MuLl%?_v@kexZ zlUR@A=A%40NyU!7FHWF0IUeEB(HLy&Kv`78wBMIZz9)#lwi1W! z(WoG2``&ijhj~rKNX6{o?xE;EKASeP1k`fmWG?ur5s8y=l}L9qS%#KE^AQfywQJVm zg@Z4kL((d;H>`W4iy;zRoI3sme*T9Kv00A)cjD3y9M_F1KZ(El3Fm54VF8LH**{ji zCeh_pC>k7qUup_=`FNo~zWe3dzZ43;79|E?4O1exiIt)oi}!@TA9`5$Y?_h4qm%$s zI^u*(pJfHx+S`;5cv$jy?bVi@ale`dRmsqykeL6(betxija`P~U*G)HJN$upYr-!IMH9 zQ};9PjRfW+0Y_)?#z|2LcNx2EBUVYk`Ru&FZH#hUpupz4ITa-T2rl7dN!OIkJT>2L zo}BGu4)^x;*22@tX~{@QOIdoZJGqA05S~;VJzYIYk4N-0OQyNIEe=SFirCZ3Q>;IC z4Ep#WS5T-e4ejvn60Ts5z44ar?1uk+#0Rdjy|+N(eWdz{lek&A0&fv={?;a`iXySo zoEtgFSebz}UTcKcvK+@w9K-qZ=aoR8%8xO7R~M-^GsV413-;EnTlmqx{Rrjd<=8H1 zCcZ(w2n-SAxE#|oBY}sKfQ)6*CK9k`(5eq5$**Q-T8v6QAd{twqstfxxzUVs-V8Db zty#B52R^E?dmm68`{2WyVhKsO`*;ywDAqdNn2K0hKlkE_(;jN zwJ*FViq{kPA3v6g9eoqsc+s8e>V-kEbX{c8=Fli$z3 zjSZ-gl#devCk?rg{M@veB|v4km?R7{AL-G5L&hH> zSU>ypGkpBX$B0dgg-?JF62-z>4CTnN#(p%$9TtH|;qfgI%D8UHvrVzNT#i7}%1saj z)Hh*7(wbbe*C8r42HES^Av7u+net(PrzUPPU#bWt`MRsC3r#Ie80a4`#boUv>m|}B#{)?r=usFP8B}+> z#Rjw(m%te94q?6NYVAaOTN~=@YH+F`AHMya`2Qf*+e`=PkfPGpbKu<5g|y5J{Kfaa zi_Wf2#Kpvk((}d5yqm(j(~1y@O-4pVY0>aA=g)xYD!!r=H*emoO7Pux-bL}fCT15X)AKveskDNS7tt6W)h%cWX|}FoEt)7QLQ=Zi?OhrNlY{TW@g&K zd_F%3aHY&iu(iDv_iFEHDJD~CeSWfAj$3g&#K*_uwbx$5s;pI-Z@X^YI(0c(*GmsW zn~(_<+`g$q_;g{$iuE=hYntTDq=NI1IO4gV{1`o-e};Hr?D6dEL4}JWk|YOm+9uS7 z4&oxkfBR?n#KmEwOh7!3;hO~#d%OpqYuB+&T&C_Xy@U)Y5`ON?X;q9}on0s|Ek{{# znJ)THo<51(++2;JZr-v5tQ~2r#c3sOK72q4FrHm5o{Y0+&Z1aybYr7qO`hWe%JM7S z%_>>tEPR#(O1Qe3Y8+qb4f%=>&R7W%pc^-C6y=zuKWbW3wku!8?TU&D@h|`KFKCkZ z-+_GxaOjOgT9IJJ)0ePIcV{=Ms;bc3){I*>Z{qyTJfs(w;#Efv1i1RD8+FG0`9+=N zHU8p#@wd9DlS)oi$oog&(btcL?shc9N8@S9;oKu-*ScCeaO~J|1r@bRok)5{5>gWI z^fOOuX|_$9HX(G8Xc%WbXY=I~CjtIem`W5A9fNx{_tZOQPbMv6Ioe@}X^c?-7>qjx z`3cXfK;<80&YK-B$#l605}+mJE@)Cdti~Kdrb>)RlD&h(4eJ~0k(ZaJ$}v7BUJ;~; zN!He1e&%YLtLS&%eHRz6T!5zlVSJ_daib`xs+vYbmQ=xCaz|%vERx(Q^{)6BZ!Hod z|K&g@-Wu+Mzc10IA@CE|En}Ko=uxr9NQ{z?)U;HDhJ>Q6wG9Em0SFOrkFgppNt)-y zl7O=SaTw2jYVT8^=fXiy)`NCrp)$&GvF@BrKNj#tDoDaziW}1{M&=&Vj09{Yz!*wZ zMHNn*JfT+KnyfYO^YX)m4ecN_C|BW|= zK5+#)g#`VEl&DJi;w+-uMe)rC+$Sj3f$%`w$V|hLvb*T-?!qP(nN5hty?gg?yYRL$ z=rG2)Y5gW-NSxBk(@P&DT4%oJ)bx%oowWJDNZ>&vARY}a%7TM~HI~hBHY%xd_G(5s z+Cj1w#CTLnBdB{-TvS@JN>)0i83|YtAo2b6E7$SX&)z~yTMJrWXvIq}zJ%|7?|bO& z>rpaPIl_^RV{ z+OAmM1K7F-PJi(oscI9CH}mpwPvVxrL4jy!Xi&N?y0M5(B@@ufRhe4W%IeMDd1uyf z%<~g00a@S;iM6O@t7IW&&t{aP9i>ZTBL6I9X~#pEu9uhuXf;+;RN&;9lgN`8A;|!G zBq5)bFw%uMpRReXjOTJsGKY`_kKg#l8#r+A03yR9rLsl?e)`jY$AwE51f;VX=_zUW zqpug99;(Fa&XW5$LmP+>hx0%DA8?VhjukQqMJ6TU>Xobb@Z%3bz|HQRyRmltS_Fg! zz~9dwS*un}ikZ&Pt@+qUU`a~AC`UWoHo8^$H_@2xX!CaBbMxYfl>n{Ay!k&BMal&+ceAsj69N7K2#p9e%5v(> zG4B^$0{Z)q`E<D|qzX(q+dO8tI|vE~Hho zoEz&Wvav8Xa}+mi*rYDYnXZ{*iutm&)wNm*jg>$G#pOw0Lh0R71@bVq9U|bFm%jFr z#sq_e)08W-CLsh^-PkS~aQeU_ho@6rGa62wfg7uFNSvG$a>u_ouB^WFQ_p9n^EaOx2|Tm}WT3KI59ijgLiW>-=Z8Ly zbg;ZHN zo}O-Z{=~0JuB2GoxM3sy{(t*>^h?Ubnl)>*;I?gQ$JBFUtfi>12><>+{~fmrZX+T* zLTi(*T(uHpt$FwTcNG2mCcfU~F|b^FB-U8&)7ml$c(ySa~e%S(71q1}3Lh>K;&YVHK$kj_~Iz zmGv~HIx}3j2)|v3qrdtE&IzyT*;6N!Xq<@D^&8hCJvALf)H=C3q2Ou(E}XxBn(7*5 z`zbCi#<|nyK*Vaaq>>oKs>sr`MU?=(N+q(;JA3LZDoQI13BaOC_YrqS>yf!RF76~B zpE?yi;*(hdha*UZ{G7BzxTp{>;<9d3kO5MnYrf4{(4>KZftmz;QTdQ7* zox67;ASgf;K7>~DcHMbFN*Gn(z{crDHW{2xPAL})?<#XmaCoq!E4rXtSa(jHJc$#(`vB|f>hU{K zdOs1in=%19xrhatBeBCz2Yc|QtM{bCc!;vha&$wu^C0@g<-2S5F3>7<7%8f2AS zBa=v@xcDPwV(}OEYi~yf&WH>3fP5ZkV?A<7k|N4AMX-8TMB#PFcKrkWC@LvZ@C|b_ z4?K53%3DPtDJe1mh@#`t}@TW_kV) z_i3(OtqETzjb$D`n@bjReQ!;y3gi%XiS>T2{g&PLGES;1tC5qN0}^|$Sg``DB-y^F zrw1p$IEgc7&w$iz&%f|Iwn+60rdwRRa1p1@p3?YVO>K>)b@X=k;?m{I7?jvdPiQCx zS{mUbaa?yPKI|=YZ@mJ3IyF3q&j!2jP4~&J&_J=;*GoL|iX8ve?OUi5+Bk<%N2R!H z5ayjeDW0s#Z(R5m_@=kF7Y%g{3JfB}S5R<}$$MOO1N8B@AbK+F-HdXyqlBp(l_7`L zkp1ta9k0axT~k*4Q+KpjGkpCdwxQu6oI7_8KltxIP!jT2UVcSEIJCy70DtqF-@x0; z8?kY*$j;7ISLTL|8&FbKg6isOoH%g;IXOA#>FQA;fK5_nYU8HOxRHBZ`aP@l@K{M> zP>$m$it>wrVYMEEY^+Cr8LY33xZ+q}Cn~F}P+U@qU6P0SH-GgvC@L;Opn!CWi;C6t z9T^n~Cl@EB^vcW4$0r|stjc-AmJN92l~*+0{v_T^6OUeHfI~3nu*&1Vi*G-I%L|4sOkw)oLX&?ntEQj-5O3 z!t*a6Ix1RGzAOYwImXAwBOxvUp`pR@9FOS8X!Q5?Yr$easkE_v#}15Utwf0vmn4&0 zoPciLbn?Kkl+L<%;v@=-?qK)s-PpNfC(268@QYvm0!NMvF)y_(dEr4(r`GG4@o<$9X5p?NbQ0SR`ZhA`&>Lx(Akc{)2Hx`ETdy2&dB|9@^erru}r#m*KJsbh^PpSjnb7$WOj$d zMib%_^n0s6^K2xr7!nvu=NON}(<3KJ(q7FdM>|NClRDEl93@UOEPR!8m6@s>vkRIF z3T?I{<^ih*R6t zf`Z;IWC*R?>+U}MdZHzW_4uD${qO^cPhP4hLu*Sbf&+uGDsvV5eEpD+BnnVcH>?RO zRcPm46rj+C4I8jptXo#@FwIC{F(tscv_~q|^bhurGmhDg*u^}Op^sZ!X{bK3{ z<3ye9oyvvTEetu{zLR0|*5>AU41mK0#K^#i(y4J#@uW5u#*XxeoIp5J`6$|1tVQM+ z(rRQ8?XaLQb-fl86rioG4Zh+k{nne`LTo}TT!fA3^odg_D=Wjj+Iw(wa|6d9^Ca20 zFWGjAg(RRzfI8=8G57qaP{i3-k1p~$N%ng^J{IZ1)tW5eAa6Gh?A^6jDgHCE|*$my{B^ zd(+a>G#*OBzq+DI%$4MQVH%0;rlz=j5$pY+7;T_aV?(VAeRqD=P zU^nyL+$hI+i)vvTDxgH-G;W@5I$?PV5rAp4OTbOIMakpo?(L4qn6awzv+uFYzZHek zDe=4WXV2sFW1oXnI1WghaNE{xl3y5rb?dXSK6|||;gq4XyHgcqQ*#sIV&aq}yrR4U zO-)Vk^6*kJ3g$xcL8VL21}7ULSJ|56ac*P)ha`@}c;iG9Yu>H40j{!QACUNGk)TvR z`t&0-);B8Yz`FJ81n?88#b=$xs-?mtzbZd-73zbCnI zfz{U1uE@_1|L`IF1N;#g8j1C5*TYMS7spG?@8EL>QP)tX)+6IFbe|Fs!?IS5&5fD{ zlD#Hdc~?uzN^#@H4KN>ZYU`H|z7TQWbQr=W2bak>hqf-XeR3FuQU#$*06>ESQoTct z!-B`|^2~aUrNyOEWVv4BjeGX&L1tDa$d+T8k-%a}fWSu9JI!8~jf%<&4KEB1jg@^{ ztYg^rW0a$FhM~< z>T>25j4|$ic0Z!yV^CF9sS3^A&0UeCzxvg$(A3tXO6o7a_m^7rBTVQs3^>T4=4eylu03H0clv7W2(E^%BAHY=!#`U7;>vJ z=drM$5I<}DnF7ODkeGz-j^f4eknIjRdti%rHXP-()f|P_Hb~-;Q~ez7qDWtJ^}^0! z@q+Y8%(A8pj2AVE=2ZHL9&tLo-sv&Z9LsQ6>wA7UZ~^H z+tXWtPE?u|oo)C;(k$X#+_AS?VwK}=R7*`xRgUaCOq6D*Jghb-WBaa`Gg`K7z~(nz z$I4Axm5AKk(_KM7)^_IENMJD~K%--5bVxiP^npw_QWxiFMma8y94GZ+xl>uPiUiHN zg0^OzNn4sXMgr4IfNs!gVXh(KlqJuSQxqy!Z$P{QC@D7ipDV*eo(I%@AVV1LIDVkL$+*Hok5 z%YQ?z&Zvk8#;u)O5GHjU*Gb|(0ad0M3D{EtI=7OJbFP892q$5b<01%grY^|t!aw6) znn^)%8m@37uzxs6ry08K|lc8_kx`}sx{Vs0Zx~0`G)~;TQ z-TU@v{E>*hmtT4rn>KC2o#H$A_>+%uR!GO0ciY_3jHcExnz_ctMx2q@;dOaj?(e~$ zx_Beo*&TGD&enP*-?DV$8aVvPH<2aC!KjFEAw&0^Z5Q*Mk-(x!fb;32m{W~%T(n#E z<&HSX5mcdp<0m^S;mg7?pUf%&Ceas5ZsEmC7ZDm6DwQ=hVt85d#9E;kYEJd1G%q8s$uW zE{|L2!2c@<)6EX95{I1m^txo<{OBmGTel9W$%&ITq&v60y zk^sj^P)Lw6;E+nr&)*O0*R6+}hnw!|BE^W)($etS>#rd!B1{=;T%BB{?qZ!L`Nzk{ zgBB*oVOK{NYHDiGF8PwI@yNcTqoa|vDocp~3JMEQTU#rIV_ncDZqd#Wi79r85|)MC zOwF%<2yy4m;q2xOhzbjVw~vo*O2t@SR*vJxkK>M{cdW}^ho_%;S}og|`ZAvz2`p3s z1A_y~`sC&!;4r~;*sB@kXb;JX4rHv6%CV!9)!Q4iRFH?4Vac(FxR+y}0RaJcO5%oO zpdm8|3kNfv$VTu@d_p`99Xf;!8#f~NW)7}hz9zL63-Qi-@8IcuPpdMeg?Q!q6}2u& z7w78gs->=oe%&RgQpPINR;DQ(SGzEdL`a%PQkf`90XxjrNM{jS--?Q(N0GBS3){1^ zb#s>1VsYdT{_p{A=HEnBb=6qiNn!G#l}fSzf{fIYBD&X8T(SPX{#s>Zw&R)aj07kF zF21U3t8wMZ6^+HGB&Eo2<32!av87~`<6=v6ygzbVGI-qG(+yTnCzHHUj&lo}KLD!{ zeDb7P+f;x7f&TiCVe};c0#iIf!$MVQ28-gXEw9Cq&yPsa1EXefK3|zl-2?05|2o$SOk0*zetPb=`+K01Pn=XS$RUzApSuu>Fe-*cIND@tmnM){D&jTD7^CQYH2 zrqjMvLryq$-N6 zNYEp0)hiMb$cYHV-k4adDy{%J?$ge>iNaph+z!WUH*ijf352r_Uz|9B8iWajTVFBvKFM9yPM_% z>jpFYM>dqY+B&s>nWLGyA{7aV3C0~egS?jO#|$qdB`0Cu-hF6pZq`hI!9k-Om(=~X z@*KHBc5s%Ev8%WT%}RI9d)U|Chr1PbkzbIH&6_rhsUW-9FQhQ%`7D(UsAyPdI5BYy zIm-9+TExW0;N@3dMp{N1KKc9;eEiYJ3fLiez~ImrNQ_lG9A%tliHgc_3qYxW$9~+` zhF?g94x(7S8XE9PVG(?#$nhJVuJGt4Mfq5B7FVlB#XVG)m7q{a(UaohbU|2AQK6m_ zdP`XSg9?qL=%l`T{@LddA0Myo^4Pdo&Ci?*&8o4}%UAHuZ{ATd_16x)hF60RNz7Cf zw`ot51n6O4r6b1A$AFKrs1rJBo-*UMQ@3aR$H1^aq&uafLP*1}U%jp=AaqN% zcD16rvs-&`6IW%TDAQKSgZ#gGTX9UDJIDL(?&`#a>sK)p6pZzvI9JidJ3b%rWu}u9 zLl#B)c5n#Nv(}(U@-HhZE0q&AGb2-DLU)SpfTgt7X064c*A5{yJym}fjLXxSoU1X` zRC})$1-A-73cQU1Lh6-xDQMN2_QXkmu2eqA3}w$?wNZ|C8d{v}Wv(|2IrEgSr5IgZ zT(t}m^O&Bb#zjhhAk zZFA27Q+I!&-dls+aa3$Zk(u@WNfAQ3)L^`L=>nL{&lq)DYMRE?sMw}jgbS4kEi~pf z63jq{Mr&&;GK47n)TvXrTPhVhdOFc31(Aou9UCV|(<%Yx^oc9fYE)o71O0ecKFD_R z##T{~R+H|qR_Z^NH?-hCYVS!*CV8LJoAHZQim)-NgN3MMgzM3i!y+ItBCmq)CAK@&5YEZdY%Vqa8$RP3+`W zC8CN}(WAJTcDR&B)}_iwj;18-PvAmgNMe9Y;x8;LL``LlqD*_bd$4j+5mx{6z)Fu=Lf+l`E08GE0fckDoY>n-b&o3=Bd5j#&#h z<1RUgrIM%ku5hx(x%wkYs(VS%+{!!10<&DCjcHczMo5>&eos#ZfQ$^VF70c!;rHi z@1ix)lgpA1RhCcSgujrRXDui=nOjKTh3vo7we6baBLP2!J!{{C}blAe#mRZV-cB`{%V$T+g*40}mr_9dIW zj`{@j%bRF{O6+|Tmy0+lC+4#8!8({vQez?GY+;&-6U9Ocl8WqJ-931F`+y~&QqoeC zM8aBlEkrg1<`DQorAI#2lDj2iC9tHEuI?_-LZx+CCaD-yrbLHwkwRt0*l%BNpT-VZ zBeGQP%?~8a;|I>J605v#&60~XwyX+uRn_QE4!mW^9=&ilwo zUl$aDnk4-HNvmeU)C+eHcLaw7D-eh27A2A*@!7G@G#8L#DkVh}BrV7VxL7I6xVSN@ zIVwq3`d~E<+eWL5sTKoWq7>!NYE+VK9c^&vbkNicas&?xxy4mkxZED<$2I}t*f!sm zPPl*gNA#`}&Q($Jp&_9tzFVxWVj@m!zR1_+?bgJElXBXVs$V zqeaQMANy%(ZUJ*mt;TJv?X1t(ce%Xz!9WMrN_i`yRjuYA3f-~jE*#_-D_5^le%Ff1 z3I+WX3h(Qt=1nLsFW2KRw~>VEcJ67Qn#^Umi`sa?+SR$v>GV~ZSq9LM}`}gsS5N96dqF-xOzxg zDX}1%B+hqExh5-Aaqif;LoLs#MxJQ<9&RT!Ab`LJ^zK589{0AI7_#FBN`?YF2*>FDn^izEJ z#}74;KQSQ@%!3^49aMmhx3@RK!oxuKvUS|4*I?co32z%>_$YcV8cGqM+>JJW|H z0Zwv?Ruu)wXY+%%Bs23fCt(7Z2IY^9AgMa?7{|#5KUB#YVdlYEno9R1dXhP0(*Av zMZF~Dzjyp7!Ww&!BFcKAiDGxZSqM)lgLUA!1EP4dbfLq(|LOn!Cor`mMbNBoy!HlS zg|qc%Z~Y7`o3&xX2E6i$AYHShl$HVBOo-FGm@EO#qa2sSB#foW-46py-tyt!8Rhu! zGW>E6VkNTb09WU%%0V7LCRJ4k z0)mu>l*-UW6qb)zSMFk2Ik`HGxguqpQAV`7NIK4ERV>qZDLNztqr6mNe3GU?UeY~J z?ZI;got(YZfIagl^+)*BrcB^rObO$R8%yf92p|;^7fLrXb@T?7I{O4?bX5F z$;weabF6QH!-pTjD=k$kCy>pAyslo7xKGNs-Me-x7cA3O4j(y;($Z1|2<_Ru$NUhC z1ZI=~QS9`TuyA*EO*LYoV`RMBPleg9=NT{Y$@qdUFQP76J6lm(SF1|WD973FJ*^ey zziryM384|8Po#3ByC^L=4Z{bA5fT)lii@C@VnLWDBqwTdV~!&#K`OH7*l6tCw^tQv zqI}Pk5cNinD@a=7okA+k*dG^Zbk~yLov!P!urPI}G9U5O*;5MC;i{bUeLN3Z@l=pj zWBo-c?BPMFt0xq3MH0I_I^2i7BVGs-;Lk+s>Bq>~3mAQ^9L{3>(tVqpn2bX&A3{!k z4&q|s6a`CKI0AuurN}ZD13Vww<4yEuUKk081n5yAuu$|7h|$GCv;BI%Wa~hVj{qWu2U+vF>c7o zVjv(XCMsH~-n{+2Q7i6A7R+vIZ$n#ao2Gg&G2dz)o*qiW*4)yJp<6>*xgszmP_0PH zk&2M@@80{(d%EK0e(WbdHy?R7@-+T;^7Kh9Qam&=qzadH9toVGa_p7ZqSd%~3Gxp@ zUw0qw$$7O(8c3mdweASFYN(UM3T-@G4y831`nMlrSgcexu|$Jt4QHg{%C##vdFrI* zKhnMW{qKKYW31b@ZAZMIYI)yHGZL6i0(AFlwHf(+kOq-}$5Ht$*{d1lXb;KCBtcga zU8}(X!HA8HH6^R&Dd*)nITBGy+B7D|Gq*4^D-#)+8Nv}NmY&sQ+%SjBKQKV5VEAcX zBVDCTsUToxLDtX-qZk=yk3^x@XcTUzwE zyt14hDZq!x|A#+6tmz?{t1>m#$a;$eLQy$ds8uR*ZL-*-qAV&aQcnnpz=!4d`7&X> z=Q5&%5Xz z>5m=M{BI<1UjkH)3CRiAy?eKkRme(CejBD_)qM#qfme#M#x6#u#hl#CWvwz_gr$^FzKGFW5yMkn!)%VKO?IQV|MQD z?i1HT%i6=$1MxBO$Xb=9N&9rOx=W2jHvL{=l;L6Fny$fW8MIufRO=h-m7#`pAhS1Q zYrh{#oUpNJEC+HzDOyL9@k|AM@zO=OIJ%%ys&z<57!nJ(N>V{8WEJn<*kx_4&(4Be zb^5RW1EU+)0&ji;0aD9xW!g%$PKi{F43C7b5Ud*j&Lpv!H?v59q!NKafn$qG`Q40& zcf(%ISdMm(EMr0ZV{-Gr(16As?Qj^=h$tl%0dDPRMSE8}y864&KhiJiaGZNr zu7%2su2!N#)uk*$$jQSAkwUbsFEY#}`IMc)uWG9}X%XKL zYxYw)W~$UKbsw@Z9|e%+P}d5azY0jYNXB1o#rOa2e~~=LCPaipAT}}9EE;VEZC=ky z0vvyuf2$t&@s;Jg_FULTMma7_Uh~?Tla&5hK^V>#Hgm?jIx!n9D+#zuY%nux72bIL z4RrN%Vf*&&2$Fn3uAwG1d9RAm=0jSL{F|=P)kHG!h^PofM^7l$@r`MfQTe_2!iyLl z7}j`ULra4eN8Y=CFCro%qzXqBO7E7c+tl)KSPGEmLW`C3Z&dCzH8twywa#Tk05$cE z4LB<7K8M_$k=!+whGTut=h2QH3=7$~kDv`#X061i0D1^mTL{ySZGYzVlPdvhZe{pk zrr*S3NyjM1#ge2=KWa6~d*Lh5hy?MF(B|z8unzgGXQ9nWB(LR1Y@bs{W zH$H?2sKC@UIlcZ=%P&1M9e?KcXG#>nGF4Q{^$qoS>lbg~R{kxVJ9kcNNsuY1C37pH!m}sMb&#HEALekkwa1do^+Z>oCQdlfjWE~s> z10_Fm=4prhF$Icg zvLD68#W;QHG_K`dQ+FzXI;4?XnYvPQC7CkP+1-hvJ4I?Ol7N6#qt$3Vl0bk=C9JwJ zoRNXh(kiS0tFl8YaPrw#@_WB@>%>xYyLJ^$-oK7wL(mi)$1H#ayuvlq_a z`4hwn%g?h1pG9&?5~3rbmCKc68uM+OFiBn>8x@O``<|x1%p8-*dvW;%p)j#&z*tQW4fAMEZ4L=^N-XN~rOT+Os=$`bTd-Qtor=PoV?Xot zeF=1Rb)i;Vm!y*;cWF&s4UQZ=BBbR$=;`m#iYEl9L`Oy=HCYM|d--ZYb&$mW$ks!y zQvz*fYK%=*R#hr;_1f(Ml*$U;B{me!Zr<2j)c_Y^#+gskpF@~G9Nu^Z4&VDO5EG-j zaYAB!Nj@I5k-$DJBMmFkR_Nl&N>6#v{>*-lmjo<8j=j&yC`UU=m|z@&asAXl3lRe2r4Q;k z;C^OdH6hkz^MZy4@2x)6;;`SuI@=gtHUj-BE<|sl+&pyy&~h|wP6<$13=R(}GLpG& z%em3zStH6NHzybUQpI9LY6_C&K_(iGod<2K)wprvMkO34=PKiM%v~f)4%u_)8fDSp z6Q@oHQ%#Fh`zS_qbhK9OAOOeL$5+Z?xoe3va=+Qgu^ekF?5) z3yV-CAe-ajhP^DHpa1OQgAGzi3F_ql=U3P#>Gsd?BOriD94AF;g@>g4J3mDpYP}6d}%ZD z!4wH_HR$H-1`l_MU(FM`Kc$N$^LC(b09UVE#gG2=M;hBZc;F!3_{JMZOi6sGQeDhL z%wCtRaYWL^aSSq++uqiWJCaJl?-|F72#wJCju$UpRAoqOjg}fYPZQ!3K;&v(ULLx8 zyC=z%u3A2Rwe1hjGQo{a8=(PH_o-{qC=E=Ij}D ziTeJXuPR4=Z`-J($yLij%sg*De?L{~96zQle+h7I<)6KqQI2+yuw^wWAV< z*DfPN5T*$U35bb}QGiZmb){N?R5)bDq2grnJ%Kr-qFYE~CStsUBNCikMMcis9GEkC z@hV1t{SF+2kerS8yIbT?Ra2$bEM38@48oZG)Xr$J=H=$${XQ369HKInsr>N>U6WWm4y4?-%F~ zKT#5kjjZHk5*8MUJ$v`SKfqtBdr%p(N(Ygt+qZ7l5WK5uvc?_mHZ2BeuP3p}sNTxFEw zeGxCKSDX__d3fpSC6ttvD8S6wj@SgF9PKoG_`{|Pt3%-Jr0n7ZWR&B~!ln|i{xpxt z#x*zdUQ7R*=@cW!O0@u1hybPgm30?GLqi`pHG%9f;Su2~EGpbKp?-^riovadTS^;8 zW}JJq_a?F7EL5_LH*OWh=q<|l)KD+}yW((^4O(>WNzD8_$x;OFCq$goJG9OsZTtw#Fe z97ZHJbZ|_5whD8O-IwOqw))5>#L6@U<|yVC=pV$$=f`m?CfS-by9)w7N*ViT~E(HZQ!5mNK zgRV$jq3&6pnrV-h1Q=_Mj)}&WEn7g8HOK3aLdYU#@M;wb_Q!(lYdPc7t?oQE^dVL1g~mnE;=ZlBA#$#taEQ=ohkX#^D~O zQR!Y2H|EJNPO5^m7I3t@*f-;iJU0S$=-Oora6XMXzJU)>jAK)k^dZ2Bi6;G4OMS_A zgkT`S%N45zKT^|-J8!>@8vK-}~LL)*E>>rG@ z)HHbccqv+yysR9*3=1&EGhgd*uJwDL)Qvn|bO#v@E{GbHdXF~9Z6{HbJ48YL7JcXo ziI5UnSxShmitIrzczi$7=#`h1Yy8$tDu5)fNJel_uqsL_$2MX7p&Ps8Zi%LlbaZs8 z2V=R8y@wR%SHHW=qspQsp1HB{VZTY$C`UWoZcg<4V_E`NHbcL9*h|-Dx#ii_R|2%2-1M)!Ndk6m!=1 z5Aw|8wzqa@9%DyWhgzmz|N7UlZp}JLA@S4m$XZEX=POwu#LIPfR_6206XCZTSCc?wR%p!J9!G84{kVJ#*WAq7V=Dxljb|_-lK|#2v{n|#P~#I z&|w^sh*k2YT7W3JUFX|)uUIN7Fenh+-QAkLM8(eEf|Zg%mu;CW8hv}I3-wh29o!X6g{}@R?%??>;$*r|}Gs@AH31oJUAt2=?vY2PWtBQssFt4wSVf3t6kOP;#dP$4?yBa6(i>6q1vZ^)-tuw|91;IwB0sE*|i2p3K|o z*3yZv!=Ir;(mG0tizWB6Qx^qvGyC}Z=rMRLbcd2BmW7);#SOZ7^JZ+@xozCdHd!jP z7B_F)jA4m$GPcTdA?nd;jPoWWCg`=QA{IHB_IOLcl&pHZ@6Wu>jwP%3(Dn#cI`cXy zv(Z;70ir>J1A>u}nt`;mH0;>EL*ePRRx&4PDuZ-MZ(zLIvb^SV;;i&>^2AA19%(6Q z*tut?#xmIlt?|Uv76jI#SLFnq( zD94bH5PajCZ{lk&d`%Z!blp=9wv7u1%iCl7xq1EgNkBaj;&IT0jNCPQnvj!6$>S%B zC3{Bta}#%}0&?gB82i00+3PVUzBm#Hl9UCyGg&!sg__^L^K)%iQ2F}6QSpFCUx!D z+=2d2K0}dEFBaXaRSs1aVP3ysJ;Fl6z!)JFJ@baC2m^{1(#41jVW!LxW@KAar$p`^|4_9P+K7zlBq0PmQ^0#gTI5+EpA8 z_vm^dAo$ME0MeZAD{g1`ouqdUVVhGwYDF13iQ=a6rmNZ0!&5B=D#oqbw(9AzHs$Fv zr}4oDLLVo}lB_92JDawACBS)=U`GSUS%UX?Y(*mhe*xn-vSbz8B20i|9hv`^vIJ-i z5^Tc9Vm2x>7B4OCt=YU5QRv0agA)9>F9w}QI6K( z_#7?2nQ!<6!f*Eu^hwNcSmLKUckj}a6I!>FVRURX4*DO|@>;$9z4-W(k8$?gS!~*} z2~YVx1uyT1%L&yBG5+y_-6P^{xvC-nIjy1O14Kih{4d zk6sJUzfXWfgJPvJ2Dx|7Ua;@mcW&d|ci+_n@pbFg!CzddQx^uda0&2!;t0RH&sKXsI#9f+$vJNflw5hP$gfe7t;=gq*Z#R0wom zK5V0l_2kKu%DVHNzxWRJ?c0aynrhs>eOtjaOxYm_hAcWolCM@cDsI#%Ict6mZSa;d zTFzg81(KjRmJ>Oyj`~%c#K6>OR282zhva%9;pOS?_eB6W# zrn@f6rR;7QE?&F{f|*h?(j;|e3s_szD9Gs~_SJsIxs<6!^g!6V*;P5x)x*K3pcLk& zNTasr1zOKjKhyW}Bjrk%57}_ZwTYFD0pu*Xd$*KNn5CRZD4+{5{psBQ@pMT7{`s@# zaXsg{mii$p4goA{*RE9sLJr`@rbbN4%zr>(Q1RB**W%3CGYF3gM|?s&+B@2nD>Wo2 z1SzR0=7!b!4qCKMu3ATPUnI`IEvdB;!?F5tvoW`eDv{0V7$@S z&lfQ zzj_I9ZlyjMk_8okWA;=Kc2kc1ef?;ZQZ;n1bPH!93;tTBFxd_GS}iKQJh|ZU&-gii zxOZN;hPEUA@xAQK{?@S7mrexB`RL zZdfbGPY(g+4B=k=J$21ml{y~ge5u6BD$DTR`|pW6)EA8njat0;nf=dT&z?O(_FbTK zcFm%Y^ZeaVA%;N4R1Ui0N{s&Q_i)&}338HpI_<(JbX5R7r%s*{$2D3+kg6Pq^(R_vhEF{sm4|}6PIdU%pw8u zdD10Dz=oTFYG3Q1OE?>H=3r`;(A2hWzDTz71qZiXRz;{v_$@=W| zk}H@#0qUXb`CHcC>nz8b=_^v=-M)2uOwq{iJux8>G4V0TTAPK2rUp$PahLo^PeHc! z$HW3hP6I*&Fwul8eB{_kjC^(&&M&_N30Ml(Y>lE*$#}z5nCA{YheL-BDGgt5U$0hc zAZm5zj-8+t=;rD+(cN?}nDe-8>o$10c;cRrqm#CfIjHKjnr;X4*;guoN2M5fk#oHET?uq_hOA&YhT)sL8ox$LC6o%8?gpHOtM~(9j@7Pj6uK+9;lR<{6|(3}C6P z;wG+3R`3(-IQK8rx@7Y_MFL#4=UmT0RZW$$tFCPwe3Qf zs8})sF}0-VR+0X$nG5;aq1O={7lYxOg>bS}j?$~cy%zNT^k=A+w2ojQP4JR*j|&A8nr^1@b4J77n9W@Ha->yq+&M* zBK`ZkFb4fOSjR4IOiAi%xz_sndK^D`Tz;$)kQdIxrQC!cM_27j`5GSCxy#~#RA7Ys z=jP_Bry(UJW!fCQM|Mt2;6Pl6s&&nI!lvo(NvuOhS4U0ACu()~?%hJH9U%(DMe{3l zKiQ|hzaM!b^LKyqF7B4xRq}x64?d6loB613sDCKsXmd(hV43M7MYoGEFgO4v_wU%Y z9ea1~LYufjPx*P_fc#>DCA2cp^qQujl>y)|#31=FM8Orq=2=T~%FOuIh3qmvh1-lXFf2B!Pq^ z6aWQKL_&aOfA-}ku4E(x=*kH05to~O_ZQCZoU_w+f46-8t6xd%>eVuP@+8Swn4>(g z!v$)(N&249OURHAt>!V#Ksbr;l zL#0udjpD83U`0m{(*ZqE{Qd4F{BHk_XFWI3lo3jIC>d!dUwYd z^ejY_Qo2^JRVXxOZ3}$we*SE2rHTZIP2%~rTBJ8BJkkIplw_jP1VV2}=n$DZf1V8X zS6)?pKSL?oQd3inZ?$V@f%c^MF=e!vqs&2sBKwOR8Y%vl{7sm-IeNP8qF3*Ufnv2a zD8DMg1x!I*U7Zw{T$I5ourKR;uM9dP(Kqf=F5ca1RO@ZYR4e#{%aw9L1^iUyZ=Izi z00{~4Ruq}dhQ|^t$%?1F{0V%J%{E94JzT8z(t()I?KlWS?uqF@_9=L!U9Yhcw11+Z!M8_Hc z-VO0DEEZ9b_ZNFNFvN(40?zx?7$b9=@Njj<$tVtG);g@%V(0pJNr1fHTwDncnDBEl%w=o!2=B>K1A zY7?l|pn8KPCnYIG&gGqx1BVVsgOYv|lLP}mA>`Zj>Ic!|_C@3P?5nD(N;YrZEY;Vl zH9zw?3Doe*!HO#~;^0XM)9{Pa{B&F-H@1o*apYsgG91>LjAKWSk%{9cDh=NxMc-yg zkaDZ?pg!Z)@3+cWEf<%Trm{N|a9>h0y?b>Ch zGj{Y?S-4=KS2#L1r=Oo$SDimkAKD|9BPY#5=Lk1nXsmSL0_Q$<^q6uko-m$82Cc;( zb$hH$wt*UIpa;Xbd9?n@$FYMA@c&E@st$omo&~$VCcr@KHo_C7Wu>xh=Qab}&|g@4 zB*Rl_BQqq^EVIA>W#SpGKsZ7eIv;7grfk+(MT=fMf6)pkk5i$Vl9D2`XU&#<2lrV@ z$KC^bB{U?|JUj@~|a z#4Hh(4{8D0ha)pa%FG!vt?wWm@DF(WT+jy{*ZY0D5uzdAUDV2;d-r>BNx*TH*+BOnWIoxe|f=6 zJ>E(bNf!U9Q>Tik5Gg4uk%s05Q$E{nDiXCz|2cw@onl4eI(`5B_hpA7L2*Yuzxa89 zQ6@Gq)_`*)@e_xn$TA8ZW0&9cbu+6~Jq4g=Ve0V<@|VCtzH+_greq8Xkwks%G+1+{ zXo2K;(OQ^UV}7?=n&r}^ONNN&++KVAHM0&Oa-TVErny@a;uAU)ZTcWmD{@SqKHaXx z@~Ab|_@EZ1)lrr_zr<2T*hiLHsUeE|^|l|c2UsJZ=Ja&CH~KtzB%N2d$wnlPkm{?| zhGac{?6_*Pnq#B``_9cfh8{~yOf*61$y4dieFMnhuj^vfpXV^pj)g0ln1Z8V47Bs_ zkMqUj0zxw>E=fvOm&mEJr=+T;N}zyCNmVXY_0)9Nh~=MAW*O=?<`?G6po@d7vPF)9 zT%LdKd6_yUadS&G>SR{ZlTU1vBzq?hQ^x>vQ6*)Y(F3Q>%j0% zhfP%r`9H@dNcr2pkZNBa*|_05191J@@BhupQT_bQpUa!;-jwHZ7U_FmE7ip@oQ7~C z*7-1C8ny+56Q88`2NvZX`qnv)_t|qjz`Ef4xsKwQvB|#sML04*)6&u`2C#DFN)vz< zcTjpY23))HDv}48tZo%w|9&|o&)vPdd*%ij(Sb6^)5}auZ|k`SScm~I@i3*L=gptp zZ*?dUf=Eo!a#YGdlRYk5TH9JR%^_H=n(h(al%*nmhLwiZMZ@YMVIJ0*vP)$KghH9a zvLeKRm3rgm4Y{SY7MZh;(j0+g_fyP(soGWf*-X;K}OqewaDr_Arhm< zcUpiRe(H@D8J(FX`6^V8D}YF+nWbnnH#S@D=CHV7W)1T>*Wr}o!mWx@VV1D7!(Ki! zcd>H4?Fr}sy|06O)#5jY1~=JrtzYgq+7?`eQA49F@fSC$<3@9ynS>23G#0Y@8T@v?^^eZBp4|GsknlsUt^>P@qHj|UIRo;`aMxN^PY zC(Osvl2WzAHX2&E=30&Am!hzS1cr!jv#-?Ms(U0r4)Ym+6;y73a7fW|VwgO09z&ys z%FNj_%~ibNyA85w(1c02Ts}nBLZN4PRa#nJDy>=#1BNGvJ08{ZK^`W@ z;`azG_x&(Guw26&H{dYx2Us*pyF^+ZK^h2w*60Iq2Fh5JFr?*Vf)aMl zvTEfjNlQtSU}dNw9b(VEJ%%9VevoWUGmEpE(;;jE;7+kr<{@gk-TB_JpPQg)@6&9- zE4nCu_|qTEy8=Nu1Q3YXQe6yp`QDUO`Z~hRdh}5tmsoaLUe~$R_7DF_hUoi23Y>9o zxN`ACt$lf|@yS}{jrab;1U=Mv(C4{ZvF^Y1zJ79hz(?ba0l@)QZq4v2YE62o^@}8e zfdkhf6AZ}s+O=zCcAFSdjYTZRA=<%esKZdI*tmD5>U9oN`~xh-S>c5 z8>&CB&|*zsW!Puk|HS)EFM5D+SXogi8#iv0&%gX!E?>Fq3T3EfIx2mXagZh@CaGtm zQOYXI%xXMv@PO5Rbl-hX_X4XCrIx>z_7<}ad)nT8zpM>4H8n=jh7fgcZR!R-7#6Go zQe^cFw{LVa-?}DgS1P)5YVEe_f;mOOe9@^Y@PdMDL%=ubY3Y_Ch5)X)USnmfa37PV z;%x)32MD*Nr>DsREnx<85l*I?>Sp&;^QdrSu=4<|7O50hxK2US1?d3h;oiDV4EOH_ z+-se@hPKq3M|Fwdkl?4rBKFk1KuHQwCYGtHJVixENlHp;CpVd=jysU|Yqe6*oN;Rs zPt>?x*T%de>Ho~RGg4GsWELUYzf-{Q65dn|Ic@ZHdo;8bzS=s_7vKn_wB< z^11Z`w`p(ofdIc>v+&Evk>WQZMP&C8g{7*C*J&+n(z&L#=i~!r4x(EHALC=v9KU0f0#U^`(4zN z@EImQZYCZqVnz_{b**-PYqYzdD0PaOtx$^^tCv`7P;h5u-TA%u`3dU* z9dCqOAdm4e#HtP^4>gYoMC>l8IO4Sl4+%E~Bt9-)MlKj>wGpvE0qwx8 z3h;r(Tm)sxZ*ZN00!7*F&f2pdJ>WkC68j^)10mdSy}{hLSOQLi`fjw=mRvAzzQibx zYKc?CDUdo&D;a<4)i;DlMtEIUavI(VN6VnDfwK7xAjjCa36RW zc#oUvq2>|c$hlgAuWD*k*d~qyyMIh-bg})l zTU>-Rbuw8zwZD$*JW~H4f77N z4LCV_%!8HpX>f^@ke3cq5bV#VJ z4Q=WoruzEpax^zrw&?kcYP%sXDQ#Ggn;?o%t2O+#rvKc&DeVUji_c&E zRBkI8{%XZ#$vu&4vBqpIm_9Ny(-5k7aOxZD<wOirr%Y;#8rxy2GZ;a<0r_JNmFF@yxAt;Ky_lJ!PR=T>Z%l7EV5Eq09rCLGG)&E zInsKg)m)Nze*n)o2yEsoLYnyG!&s7Ri_%Q(RupGaJy-|a8>tt^j~};v4^eNzF|Ek4 zpt)Y2_YGI!cu(>VvY+XH>VcBH0+FI3X&XD%(DA=hTDkKo$X{Ojvi#!bzmVkAWIKf4 zU_Xh_iX3tAae|N@uGU{~7;w1Oii!%^v15l3oRgag^Vfv&*BhiMVx1v%!Hr1&pn+XzGV#`uGwYR%d;TH`&#g3o5UQ}OK>+z7>88u3p zRp6HC?@N^u@2a{{Z|b=tf2;I$?#WzJCUWNH$k;JsWy*}H;@68x8>~}96kHdtbtJK< z>1!unyUUq)-+HJAoOQL`oi@os$MTGDL{nAaN5NxIo0rQk8^b?ffXd2B1p?%o6$!h= z@L|Kvr31g>)6%$swEn7C{j~I(_d0st0|+lr(3x48GExzpj5#dEu7c6oWAKn*nWXN& zi4!Lp0O#Uo7vm5@{QY;A)J?=CncpNW;NnQ<(LRDtV$YI zCjtZBQgT!84twX24}9(_5WD`MT`kPp8slqIkSa5(M%}DCzI_&;b(tWvXmpwY$Yc)QoV!|XPCs~}arMbm86-n?V z$(Y)0rA4Kx3AS6!xagQ@8))P{qQPQO4&>Hx^K?cVYL$z5@Z1~7m+U?FAE^ge)B!R% z%`|KE(%`y8P~rl0#-44f+XIH7M&Z(BOQo@?(O7aeZ{IANH*U66kI~s$PEI{P#2uNl zju3O6EpJf0L6C;yj)aNkeu9zX8K6f6D5z~vhK}OsobUaf`5o@g0R35-#uPJk9{K7; zv}wGsS>30NzPBaD=RQjpF5aUjr1n?;uLQQX$qW9(TH_^2XmfqD=2Kl!-otV$+*+>B&M_CU_Q)TcF>{8D9Xn1#b!}2~ zzR2o3!koig%}mcUl5SG5_Uzpw#U;g^05}{6CZpDBmo>??IfB#uI3w#T{`_f8EYk1@O#UgXCvQAs3(mQk|m`tOD%5O@(Ms<#ieTm+vG? zw++w=KmH(4^?XI$rhY3H%YeSHx8C~arI%hZ z%MjOf*Tyx`hdjKk|9b$#gFhEi)w9RzdRV!@y(q)#wzvX+Sn9DtFLXFyvq=l?szh2IqJ=0N5!~LS2`Rx9g`)kSz z1%!O;yPbL4P0e#Gy<|zt6&fhV z-Q!S%k>`k}$Rouk#qC!E^CdSAO1wKh%K1nf2!XGY+uOW7;OQP{Xljt+(qa>4RJ({! z0f=k##EBDTwSicjHFK6#si2523M<>poHI+^q&MZz;X@W{ynOkxj2JP(s^na~a@A@* zLcR7d%}}Wg>LI#w)vQE7HWW6VJbAL6!^I01<%_SskW!8Rxi^Gk%gq)U)aEKZm9LZM zf81)4v&zBzPeGBAp~Acy+tGbDE_d>XSn>I<|0F&umWxD2iob3Vs~|!57U-vF-Kb%b zn2>0mE>QD>{dyL{?!WiG?!O)|V?)Dn0~V0ewW~m;T~I&&7hilKJGbxDVEIjR-xzVM z4t$WTR0SBSWoX7v9Pe?BpzHa0;ynTp%?9(|grg@8@)YjVDA9Cr>&nVz5#zKl`pEQsw}O8+()nhxH_*?U9tLz)LW!#$DFxy48#I} zjNZ!Mg1#tk4_k>i4?SX)8Zf>?z5NChx&&JZD zf|~-)xM3UA1$$8QE_bLaI7*pqB8w|!a8JCNfm-cj)?~T$_RpkR*Ob=!I*CvPH8Mge z%yqvs3OK_Mboj_&yT&zZ))-3{>|G&4yhIf4_v1-=jezWr)-RSLlZ#17K31I$(m8YH zSkT+z4!RIB5#Y>=iBk;P-GSR57w@TKbO=MehmHb(@#t+m_W*IJ(&ADhsRt@glKRsy z9(um&zWWwoH6nS0%%449wr|~T!VV7&WdEbbj5Z66)D4iS&^59>4dHc6*=0Wc{8JN> zFTVJqJh$jMy${#qFCTv-hc&sLR1NM0zd^|H40kES0N@DVR_!Vr*|%x>3Z!vbQ&W>1 zK5$shpF6Jr8&}?>^PT%M$`Rl^&YN7qApanHo~P#(c&%F6|M&k>umcGn_8wvAxzl^i4~3W-i#$xwc4Gw~oI=Aw&B9%{aG_*njxxHrp-LJa zT%kI>t|dLTYR${kbI;RLd-o6jAvIc!Wc3THE#?{?6>b*qO|@dn%FB$SHnt_!&WS$s z3dSCL_DBB`#mNeyo5kU|h4ld=tZ(`uKq1v=t0c@4i(^s*_yx!vKYgvibA$<>!MMSD zyXL+*^pCO^$8zLaZYz_63CrHEA3w@D|JVm*(QQ-sJ@M$mi-pF=+s(T9W1s31aePWW zQ9*+u;*7V<%uEB%u&^g2CCD3Zydm>*=9|DHzmdFSVvM9!;Y#Ju=d7VYw3^zs~%I107liLG~ zb;cugMqPj$&n>L|A{=qyq>f0H(BM$nzkk2@2l-3($ZQjaOb{j*5OUZmMrMt)7{il$ zdwPFn2t{wqvG@Ijf`l887!xi$#{%#D9tQ4~Sb@;AF&7Y0pgQS~?i#Vd{d@Nt&nHUQ zD=)ty%a$)Q%MsAaECtxGPZoQ}62fx>u{+HXOdJCXkaA(9TOsiH4MZoiu6Q zW>!YJBqS(<(A|E8y=%s-88R$(m>QyflA-`4azMT9$?XAWO>mw)d8Yj$9GOUHf(?xg z1~Eq?1PO;Lh&gY%iT)S*Ceni0CZc_nMTW6^f2tc%L1lkov zpORxtOpkI-xKvMQ=_^t|uGd|c7nZ-Ebv38TE3dp_d6W5h`S&{w6EY~i5C)L<_&C)% zIAs^9VKFWmyq?X_PJ8vfc}9AmUxXuo9GLz=$&E}O zDYItH5?FDZfqF+>AmLieFD@~z6Whl?zX!Mg`a{DR=>7DA^CyhpxlqCn4)|HfV_WcNLII zDOdk5|0){_w9<&4*2FPcy8g`8{6@`vbhhmxQ}5U35AzxOg=oRC*dOM%-fesC0oGLa zzn-^#yl?wOIO3{7BW1wMUoc;O`Sveu65~2C?NBX7CWlSB2L;+6?|S>?*GzJo=t`2@ zk&p8XE%uMn$qaZJ{l%XlBkz9pDEk{ozd>*j1H{dTC5F}K^hbBs5w0%Jc{%eWBP&C$ zT)yH;{(tX1L#EEu5>(Zyh<@_fC-U{zU%Sdd(YFXK4Yx5L5oWaN>MBKwhfDFrVxxFO zNevGTmn)T5tSSbTI@}v`6k$k+1Y!Z);NS_cOpA(&T(M&Pfg>P-0)tH8-nez6V>bxc ztc)y+_aUqy0>7+)8D1kyZ{1d2DHW2$2dSU|!uEQ2olMTkmgS925_##W97$j3HQzXXMoyMql=b@dvX+>lLQuFe_jCwH_w66! zHA(>e3Kbnng44&3u}kkyyYv8S1IiV|6|UyFh1EGims9B5w@iE{P;`_g*Xm@#Z3ai7 z1^VwEip2o;$q7X(f-5^jw`EJ{_P4?{CBP&*{kd%}ZbGw#TmRo9u#TwO81Mrp*lVFI{ zfFS{9Ia1pZVMW!BtgI{%2BS=k7X&A{;R^LT1mIEpc&ivORXYeE8=NrCHskfcIDf*d{DE%z!`?7N(8Y zl3eq2UNtCT_?grZ;**>r$wQ-Ma*GlKoINeSR^H~Rca%s(ty=ds^yY1uQFcYPg$IeB z7Cy!j?Q6lvbwb^@d;4xVdi{Ahf5MmgvJ;`=-jXIx%HR!nJU!=aR=s3j_91(b4>72$QXec91v`^ z3rUCYRe^|Wk+MsKH5SZYAYq|lk~K0*#*7^!&8^K=hczxX&b&TYa?I6MMT!IM zxsRbvU-ac0v?{bgCOm_9+m3Bk8plsrESQ)8atMsGNI-8j(1oMZce-o|pd1!`Z|hwT zuxPP3b|(yax0ivp71!$^C7CbvN`_sa)?1y1BVepaNlme^MAs|BDumD<@XVCSQw;G< zb(`R@U|F?#m7+0cs)ZS8fH%^oI1V5eM>sGx0mzZ$UteEuwHb%0FpZDXbdWdS5ON-| zh-zzVrRG|V2}J}OIg^@tSNTje%nRQe^pHR|*5~axt3uu*ZH8jtEA0 z9_P)UCnM5E*o3mliL$HIaZD^Kb3ZMND2_11`mwxCy4@=ue=zvmKX3*-h-DtmqU*lR zv+^2?>D;+I`O|xUvRL5ri=US_-g?8_pNV?E$ajb2p8|fNfTwLPsXfsIwP027 zkZwYOXOyYSx0S$L_i;)s)en@1^}qRri=Ufy=%Y$_;MoH4Iet>^Bqk|c+zqu<+bqV5 z*UG(NB&CnAL;BE z3kXDbcbi+9ZG1Qa^G7dI8oj6AQ65n;5^(L z3pR=;f`yukeri>*jk~a<&u{BCD6jxxicS`(#abXcckPs4{OlJ({1Yq4m}H6yb^bOO zQWc;~*9Ow{il&HgT&&9bS&dzPgX@)t)382qsdC> zv9=B0-O;*@*EC&Yn+o2Xc0YMu-N>CM6zhRxA zuL&i%E-`Xw>P)YMeTS&$=XDQUJC{P9nJG%w54sZ-^r zKmV!a1NXF8(=}LU6=fB&d(Uno{!dqAC#fGpV}^FPRn0A%nkMk6!fgvM2KOqdAUbfR zrmEUvgCBhOfx0nEY`*e6=~-PH_sm_;b^ZQ9@0l~K2?%i%X1q$Q8wg$cBrGz_aw$oD z0aXhUwy31Y2+VQ8l4r>{Dp3-JZ90Z#=xd7Lbu<;&viFEw@&CPisX{zY-PY5zKO1j0 zN_tAVx{~7!%aixT78Z43jZ)AAi(_(P@-r8Abov)h3*4s>e;py!SF7dVfrIkz@BX`7EWT** z!qqRX={!$#Y+yduP;u(`Y#^RM& zmVjxZBBN{{)H&R_bElQEg0Y6}J*l|B5X7Q~TbN29SkWlZ8R;1YSmJyrp#|`Vbds`5 zWd`gcHH3Ahp}9c@YyTB1gHTOfn+nIy;67hv)`>WLTtd@FXitfpIhQL}s;@}ckT5HV z@XAkKQOnieENK*5tYBZY%-vTw_F%yeBGP69V;5_bldt!bMS`v8w`0?XAVo6WT z$@TMzSUzD!hQ$p7RoIblSW;3V)22+**nH>eH8(VVMy}wYLx+?}#!s!GX)zSHSYBguqY1^sM-NNkg+dcd zaS4iCMd&Di=W#5=?z)nN4~vlp?p0j92u6S|q2Zy5v>h(3&8<3>^mDZ;uhm>L>kRJL z7gxV%N>$0F5;>{yzH>@`@a~Q4^1lT}N~pTvI+_ZsjBAbZcS>%M{?ngo>cv*OZmn+k-~Q#>k~|{Wh&D)g2XT7(^l7Y?p6-ddUc=H2!aJci;$?iTq&2zF4=0y%wcO|2qXLtH5! zN+y>%D$_uHxw&VgTw{-g(GgN7ffCx}B0O-;WysB2GDX2VEow!dRkSRgE9fi9^Ndg{ z8U_COrO!)FPL3%XT$i^!IX%EwBNM>WtzU#AU>meADs0zQ*V-gSOXMOgCZ~%blZt_k zO9&x3kQ>)V^Omf7_`5jJ@BPDHapzx>tamkX(0cfVGwn}a{-AnawwtJXo z$NIw6iclsFI)2=E$w#wkwpJGO=`ZT1i>T|7oIOt z1X`;F{0X8n@Nt!-DQb=h{X{nvicI*cm#>=J3AY!EP1nib2+000|DWjo@}As7^#IBi zY&ql_LYR@EamS%*DPj>#96!+%vH1A-P6`>`mZ{UG8uc53BqAchV)uAyjvqTNP{Dx) zU!m+U@S?(QQ(RJPf^qW1$@25Jel8OyOpr}mHe0?Ud55r7t$J~lOqw`JD$6Qm$BrGc zaq~uteVPzf^r*Q$)vBX$ToU=)tJMpn@j_B79Luk32QXK<`_6q^+YT>`{v&mS>q>}C zkg=LxLXm=2Mb}n%d-V+S}wqt?4*g^E%moU$w65L0|3nS>F#{IsWi|xIA?C43WO>n|=|F4NVPl zuHc-xhNjJ!CTmu&F>RK(gkGTuL^vW@2#9w)u}#mF9L?h=k6RuS!hY>5Yb8+u4qYb$ zH*Rpdn*aK+=DB*boV&5&DMqnxB? z&zzHsg%{=e_3O6iL`Fu+_%RdAN<)wl_ry9obmWl5GLK3tsj6qna)VahN!?|tQxlnIAeAr>~*`u&dY&FxFv zuvV|DLF1H1Rq0+lZ@L8UJ|xN%;GC`msgR!IKSV+_RU>uM6eT+Eo7f`jT3ub80i8My z=6%t3J)r9_a>LWDUxcHLY?Tq=L&Ifc#zPo6Kaj921ih6-*ayu2Nix~eFP+gHwYJPMP-Evgzf|$ z!VEVqba9|V-RFPT{s54L17(8y6_S*^!!m?@25Xt$lkfQ2PhOMP*1cxHBT_w3 z3Q9{$ZSKVY4g=0;pLq)2iYL2Fi_-Ya8LE4v(+wgpmYH~jRyj2r< z-2Hif-?;}E56)lbZ~FdSzX-=b)yU9(BSIsj_HwNu@eBc`W08qOyn+QFNdK5XJf6hH zO(7ODX4Dv|x>{vP(Qv1-2*FqBGz21lFyuf!&TIa8o3{sg(*p=NM<_bmGbfr97_)2F zF8NdmwvaDINM$$*7+rq(bu+T=19BE#fY>n@yj7YIkR9}AmrPXf4146sf zdc}~dSgMqh8##KUy!WT~%-Vz{XVR2O5~7rH*Ay9At5^ZRHq>}bO-{AE$Q8?0Sgevt z6rX(hiHj&e=k)y=bDbDyn{uCajahcxp6_Ay;Wx}Ln@{@Lt!7s_E3V&3CuzFTBw=A; zvTWHhX=!eeU;pOUa^~zA0|;d*I)1{G$?96wzPWTs+W+V8MOyAL^7tqK%Kw}1#Ao(w zQLa2Cpt!sC=p{gkP+e1PDI=g*sX>bZ(o;h?R%?v5w7Arik)F2oe)sS_z&J3)NlR9- z9(!_O?HA#Qwn<@Apx7YGt~Xvc3zFCcC_C6K2%u9%0GRoY1)XLRGWkuTWq#k2cP6lL z^$ZCeBAMBlQr}oFOiG))T_hhj4UHY`*wDCq@3yap9}?bQczZxy`gIL*`h;?JDm5A7 z&lE~^J>ssMK7G2m7M+}Tgz50O;j&m$5@yYrWk3^BImkE0J?S*YJfz-OV|(}SHDC?} zj2XA5wG7mTO&hE%7H&f7JPrvQVpb(-ARt(Yg@&lrMVyqxe0R&$IR?+53ppoBUXeOs z06xBX1RmIrXsSTmne^~XA`FQi;Fcmblc^H}HjzNB3CFkM_dj@F_U_wj;5p)*xLm*Z>I;iCCMj9>9i= zT7`_tOO^8efBZ?^$R{LCh5Pf$$vROF)(P35ame=1zZIY7pBK^M2w0B@UqzR^HNe$x>eSgYlebV?oimN zV10o!VE69bmiUi*5+EF&9nh@^QoJ`*!~pTSb?a8w{9Urb<|vFhg++xXTuJ{xh?wwg zy$=~rsy&aZzfgVY5pp`kYC z5yaCbPm}hxcA21{o#?w|_1sSDzAtgTMutZ|&;@(nAA3LSu?JXNo%OZH4g26rj|fKw zJO28H2K6bZUX{bDE1`8p-5>{>mi;5_KE2F&*; z8@T-NDiA}0TeGV*G+-{q11HM(L=aNi&E^b~OB>@9EAm0jH^5i2#%Oh%kEJKu2xJg@@S`2gpWgE;iCr+J^OP4OmzJvRW!HDA}CnZ}hrPYE|j|)~N))w>Q zehuM?5MynKR7$r&0jf4O>p61?-TcOVKmNY{5*-z7=a`<6ArmJ~G^^H&!cqdPulJknVJ=c0$Qq^PI$tkDvTu$W5?L$f!uxO!z zjWqu;I!4}F_omF7Jy!uy%Ali_g|G~n_ptM@zF`ehOd6r@ZT-^&1G;1tlLSN^kZ}U% zFi)V_(y$cWYaBY0+!2x_AaCEk-F~-b&5N36HPHm8{kWI^5!0x@UT@S-#2>o4Khe4= zv|DR_GURl0NH1SpzgA~?cIOMv%hKnT%G8-tdvsy-a<@;_W{gwDUT+(7q46%TWr(_E zSV$UT*7 z<*g9p)Q1d6SIbS$KP@v&ViRKxLCZ0xC|dR4m@(3*g1+smO)^+X$UC(w*QM$I`IQuC zALXls$@P#2O5BzhrXv^&@(SeB&pwr-M~|8ie&?^>k&#&=JFPQZtGD%i4T2xNzYQ z1kZymmkC>tUm&TvQ$W8vyfI5=LVhq(?Dq>5C993A1u{7OqpGbW&a z_=kUxOQo00iu~mBPs}p~6VNcV=9s5gj67&m@kk%3xzx%<>&qPf_rG*L4J_YN=Oq9C z`XBN?weJEIaQE`7ud1b;;8Kir>v{!69Y22Dn1op0NH1BrVx@th2KhhOdhdKd@4H9o z0mcyH%eC%$ZejI^aAYu(t3}c>?ihmoB+TRXut}pA=c9sf&>fAL@Ha@Mi2fr+M+NRc zUnM$Lp*1u@>(1%lgBmUygkrr;+LJn9zxwJcJLapey(*I@X$;|RW8XWr?huf601`MZ z<$%yQ*REM>NHna%2Q?-gLNPjes7{)|P8uV>wQJ&kz1|KDN3YM@y6*w*GlQP{_%Iel z_j~ky)7a2tamC-g`#TdFO>ZSX|^* zGIyAYm8zgDYomnBiN;4+zMEVx)DRLV=sjkNsA>0CV&Du3meXUw{?c61Y z_8&5)9LU&ldlJGqdFrIBdSR8k@x~iQ=g4_*JgxzS7f>DJ3*ru2QpSvy_MExWo>!t_ zo_oUEPhU>(@ss~W1%IJ>uI6Z12VfEnmoTIUhmRb#9L5RbCkT0-DXI4?ZQIcMpJ#i3 z+jZ}jdF)so5spkWCI}?QnOT{gv_}Rg!jb2W3*_b90qPpS8q-sakpbPC2Ed0rEE0Cv z52!xs;UT11bZL~>L3pAW&zwC|-hTUSbGMMZ{DNDr1a!B(_j7g0=^x5PcWyavAN9Tm0J9NRcvW44^y!Q_Gt>&w3Kv?(u}Q5;+@V-n z2uKu?+4E*wC<2!%-WZr(C{BJR_l!^=VCKx3vTofvA$0?kX=+NUL};1_tToI%rkdpm zs|yt6c*%2$HAqe|VX}V1dh^zR{_fOt?i2IG8g=HXeXpOBl0iBIas9z6)UrlqS(-`S zxjZQ;D=}pk#wyUVwRN>dgNG1CaAUoeUn)0Y79JUHRxTv!+6}fwRH?FD7#}Bb!^0%` za$ToW3U9k3D-;0Kws?_*Do80nm33P4jb=M${`q`E_rmEqW7Z4<4R+dr_l?JTfY2LA zYQUR}>3c$??+@8K>GKH3MaUr(`byCBbP7PH$v=X@f|53yHf%EV8rGsS;i_w^1NP)HK2GD9{86%sSPVI71{6?hlNgRE29I-qr|`F~ zfv!VcT_!xdZmP$>$;=D#{Zi9XZD(O2;aV`cScVN9X7r8CEzKqj7cX3F>^k5AsNg|E z$RTucPv;uF90~s8#*Z^XbSzB-W=Uy@T)uKy&YeAHl{@$y=x*GwpgHjZIpGmd$d}45 zNkd!btauhV9=I+I#jeUN3NDH<)NtfNQ-hLtC`1F->$TQpd6_McfqsD|5J8PbhD2I^ z^1uD&-(<|_F*0WS7&)d?d7pj$nZ&6Oe0|;PCfq^J(HZ&*l~ygbO4JahVtz_AGX4i*TV+oUlQtV`T9!*oESfzSZo4Ab-t ztjy}FYIQLw$?;=0gdh9EopYs1%K&ZJAh+6Y$poED)Qx)(;O8+9KcIgOfQkFYLg{Uf z*8_}0JUBc^kGYU{-hgVYw^{`joa;r`1@!5p36o@A{5+$0bmj$PmsA=m&fq>AI&7%S zo;}-g3DKO4< zd!mFRLd7|zp$xZAY zma9$QZIa*p+wUYVKhMygRSY?ia9&q`cOoXnj+SN`#z{)-epw^)3>+aPkbM6JPl>yK(^BKr=@oh@6W{jE1m znChV{UpqN98K8u%8RpsRxN`3cPxJtwvC9>g<;cM!Qczf6T(^ujP|3bJ);-nwML2?Z zBSt|S(eeWCb2SJxD65zVOqxe+ECdL_u8m2Az`Wh2L3$N}PD2>te#QOSXK^l0K`kGE zM$wVcmJ79H=@QA#9`#t)=A84>_{{xr8Um8${+aWg_qlTqFwQ7OOj-fJ7hHbh)H@Lw zh!78 z7Q-tkDY2>;fMEd7QNrzhmOgPr1RsyC4MB*{d59HSzmtRJfD zs?8lcclIphW}PdSv=6V8{Yhf#S~|kkoSYmPHD;9LozcoGxn~WZKn&ee&7;B*ZI(&JfTlPw0dbOy3D(2!h=$ju z3B=7>Bo)96rFSN1(NzTG<1{9g?;saCjRh7>H9$L<0ex9rEVxgdhD!#w3k)CRLy^1n zxQ$~v?m^s9C~5sRDq=eYNNxTW_K_Z~pm!_D;J`ya}I!v|#b z3#*OlEnF=+$S&whlv0q`OBOFN)+urXvofvhU0Z%AsjEi%$qCH<-_o~fl;(A*)ZLxZ-?&sFsYeymFUPDCA`Nb*&4fBur zf+fl^K)K`1Va^Z^p}I(HOso_Y7Fph9lTVYmUQvh%TL8p^=56elv09xf*XA@XdiYI= zyRKfd+G4OgH=$! z^;d7XQ0)p7^0xlz0oG(F4`UOw#;Gbm2jUJ`-B4R+Rq63m^Vmv_tLJ>dc}tzxv15mk zi>IcfN@-cCRpdb1w78%O#~Y0|%oVh9YG3=^LCOkXunc(`i;0QBX4`|A9j#QiXCuoh4*yzRj~fOXc| z+-jB(ifGBD5-Be)mum)Gxn#m?tb$62F)mW{Wk%*mMRN|Zn0VFYDic5`qqs*ANC+d8 z$DK-&fp*UL1k3O(`=Qmz|L!yU9TOM?NUcMBZFOaf|av7$ybl0_9RaD(q5?NVm=j8n7 zr+u5bd52tYx+b-Hd}>$H=ib(TJz#El6_5x?(rQ>sF?8_E88XU4r{Xc;2tXcE|ZysVg9`NvU=reD}VDi z$L{o7y>GBMu)f>EuUd{1OY5|q_f1C+u!wT+D5Oh$PuJk@_}cs8ZVxy@h5li_#Ky7V!8rIaP^ifu3Y0TI$ zrm(_e`qejI8L2l`9;rwO7z7sM7_x8DI1o+%WUw{?-Z0-ycn;QFRkiwVG~Y1ch;YS~ zivR-z1cx#%VYGjgBEULaOX0;rDK0Ix{Z5!P!7N3Xe4x8Sh{C#q0)Q))@q%DPU>o#R$ms-PjX6%R8O5MCDGxM z-qg9w)DZ3GnYwL|rm{@Y)R^wbKddvo|9QLzFg8%W@Hh-O%Ms}g|00twK0aQ?Xzm~b z6pagn(TIc*#;QM8gW-IxGr$(YzKAn138zh)YPn6gdak+g3W-mOH%L1R z27c^mQ>Pg$_;CfZGb(UFaZPByFq9DUxY=^k5|f>6yw9C`fQ246_pDj74Di4>>5K8u z`6vVX9q#7J%avxap#-wvlb47PLU>hQt~Q|qi8#WNsuEMCO;H};SnEr;MblE!%sokt z7#3u?x)ph5j7DFHmXPoe6JlTkzyxqSP_1}(u(l9t%o`M77^k>zEK~?=U;Vq~bIa%- zagp8{30otw;kwt>og!^`OvXAkfUAs#GVTfU8Ko17Mp8aN zw*t&TXp(aX(+=N5uSU3pDjf(hlw{@?!V}?3wUvy)8OG;|HOkt+10|Yc82CoLIrfx>EP|Z#;`miptIXAFO2mj1SCtX9d^1ur zBqb%qknvcNDDf!oEt>cE)py^DzwUEfu%9febESegz3-z|uJ4(A8FZmgWV$N!-q!Cu zz*wUg{l2~X%v+J3lCB`f0VW&~f`CzQTi*7)t$Bp5)C@F8G(~&(>GNZ{Q15qlI5z0E zZc(AS-m>sME(^~6j@|JYhNEhl{yzSe3x;(Zq`(1h>$wNGcPKRcdD{+Jfaq(a(1{Y-om8=)?*d*69q^-B-1Hl(OxGkxlG^L8-4ZfZt^ zrdUWM?a@h-Ct0j5C?H4{Em~w{)KEx4 zry}s&8^9Q}?!SEW7bEGWAi&?g^Ea9kInEOO5lox6Y_?b*tT+JJYSs0*d)IEOK!HUF zNXO!HBa%%JGrrBus_sn$B32?XNs9xjrNw=B1Rv+ZF>a`ZhGzvb4lIH8o9!mt88epi zsP5DD+d6*qJ#z>wLZE-3fpz#T^N8P(?g5~0RMsfNGazt>MGaHy@`^I&)LRi}z6ar2 zSWswjO04LBU`6JJhS|CU(iMby&f*+tQw89T4%0!ZSf@{#BC>Ilh`Vs)0u;I0zH_hm ztSj*fNBX0m8}eaz+;EvNae@E>V|*c3Jk>lS99awX!6ZRr`}mWO4VsNsdg|0EOC&~s zqS@i{A!Y)_6eV!rMeNq<^HeYN@qQfu&h0_EK=`_>A#Uum&{zzwYc0>pvI}l%5e@-(m!%<;FpWz>AGt||8o8USJtzr)yY?U2ZxuZlhX`>Hx>OBW`{G)Q zMMBQbaTAgf_1NtauNJny5)jCa-6FM(op0R5a%q3>0~hD2TI}A|zdgXX$5TQ0jHW7- z$4MIF~6&E3nwYYKHc z4Pgaq&Y=T`By32SS$dbNE?ZoWiWQ`G438ad`HQgW0FL7~LX9_V`ZO7;`HBE;K2M!K20gCGwS8#-0 zCv|0u&KFtQ*veI_WRlY5u^%kd%u$(kPJnZK)S|pIS$S2rYt2WUza6bbQ;ZHA7N29s zMOg$oKK8!opB}&?W#dD~3yPIlVIDfPN2CzK5tQl+%U+NXDI<)51C5r(WFUDL*D7ul zG)9C6TIL81oFgm;dPDd#IaOabt==I680gp4tMkWl(Rfnx&1OSF!h{qP8)J)EuYT{{ z=z%@pE)=`l7(usV`wsc-?|y4;Ntf^#YUxVMF_7cr7Lw}V8lQtKPtvSB6+XBmhYcHM zu|rU#^B2rFR5w;C2yE&n9yxr(;&})hYbx)k%ZlJaaAIMCm_?wm4+NKcL+H}X)vCV% z5laIV%bH*)TveuxI6&74+_F>vAv}YCg>(S+9t14_AW}+5`+!ysxN&36#cL;_)OoiQ*)GRUi*Hx!@qDSY>wbLH zy{BfcZSMWAe|mti#ri@Thpn?Lv>s|6kwgU5!y?0E($qp%XqL+bl^5iM9yS z7c8K}##k`1DjD$J*0()?D-}d1))uiwas%Vy;*1O*c9}i9_ZWHO-p@-Pw&ol*$J)@uqtQos%tDVPQj zw?O+5@Bn_GzY7WuGIT1))*5vkC#t)YkPg>Jbr5nO5snDbJ$v_<0t;|wR904paBR^b znXhBEJ$;0XuRYWG<|rDrebaVj2iPD!YhUX8o%fwbdjJIoU>f7r6{_;w+Tju5Nbj&n zGDvwmYYmNt1>f=V1Zq{ zc(KKnp0zRJ>FW&*3z5ZIaRMRq?fP$J|K9ypo{IP$_Xjo|%KjkGXecVUG!x?!W#x*M zvhMYDW|8ebyx(G!7fUb7EM<|QY6k)r&rgIB49uUiKs9-P*}HGA6;XDs3*m-9Y-?Pou%qSZFQ~n&00~< z002M$NklCAQ-P` zolPUzFS{hk3JmLw7v)jU#$&?qQBUZp_?;>aj5>h^ z+gErzmFH<#jwlT*Kv)+p*GLaL^nUe7J%A^M>KcSKD9ZcUC!fj2jT_}`{#lD1PMtQ@ z@)^ko+_rt2k?-UFoHuKpQ16h!!W*}2l&#yg8vPoU<=}RW@u>1saIQdp^V{FZ*>h)& zU5AQ0>I~?%F(wew2w+@d)QQA8tgq2BSIJ`W!Xd#!j7%J!SX{ou2XT+GAW~o$OafM4 z^)+S3Aug$285Ty|zX(gJa9q7|)#9V1vj8|kaAu}uN^*R%6c-iS`Eq>72zKt=X;x-% zSg@p|DtnHCbbkHoUkl)zi4!JjsjXx3`IlcQLbpI>3=WYMenafqJ1$b0dfL}-7Ag}RJ>2trNaK^U4FU02uu?U$rDb+uYh{aNUl{=G)xaLoeW<7#%kB^PFx{=kQ6m~k#Nb|sT3~>P5vgF4>GEQt1YXkQ#*Fanr1%f=} z(`QZ_7c^EauH|D2xGBiXmph6`J(`>#b1v6OxTcwOYS$X1U1OF$N`t9Vy3<$QH+|m& ztf!$0oQhA3mx`+u7P`817uePJM*}nBZGGMYOm5sx$~`fV_{JflV#CzkHZ=|Qn#gy843k1KqiE@b?yN)Xlg7X*bp)!Ge_D2 z?~1{wJW+Qf71I%5SWH&Ef zmb<7aA>40LP}rXFz%}6lzBA~KkpVynNgTi6LV@uzKfmaCMVwBuR2Bpt=SBJ$%Gk*4 zk*@lG`Z?@6oNrP>k_lhj`;ZGv7(2lf2rLp%s|ZfUXT7G2h;k!mXdY#vDi${m9g)!8 zM`h4mH?&<}tJ32gIU(%|O!CpH9(pr6UAFg4-}V5CPkKg%g$qz%h%*^u3!H0m$qP#qCq3AqEfB2O`A8#&K)}i zKGo^drdtXGJil7oN!+NH z%P-6J?c0Tvtf7%ZO@V=VXZ+~#5*`&UhYlT-BO0sYdjK(xfWu>eLWHnG5ITrdzOQPj zvM~T4hulUy3UaxTM=oOE=U|m7+hA5wVOB--`jvncm0kl&SifT3z zqha#%FqaXl!!yuW$SxFJkPYiM$d(PRBDgS_ptVE#fYyIZD@5QDTfTg`fi18;pdX{E z#L2TKC1Pl#WMyY{jS7z6TB*u-NYT^XFyutl6EodwrE~AIlrG=dqK= zKZJW-;k?np#jz* zE{f8Kpwt^}RXvR3Smh`L<|s|1bAW0Gc{^_GI6Fq|^;#<)06Be(B3?-dA09B=QaKQO z>^m(z&D^!5oFE_(j9DYIOi=^X%5QNiFU(n}Zn^{`P+;Ch4T~~%9jx)OEl0 zo8J7yYdQ9&mmXmo790MUaQr<>?b`KgY5^X$BGMGE1r&lcU^#Vat$;p+T_0C7?z17j zE-erxqM^CL+-$8HGeV*8wjcHY)(Z{ep!AdM{@uJ06bo^Z2 zIb*!R<%!!B_a+T1Z10}E^0}sDP;hwZlBM#Tx(G?LIIY&=U;g|T*|1@Qi}w^4x84%& z3xCA+h})4S!K1RW($K7F$!QW69A-e6$}5!yv^m>!)~r9HkJNKSC}RmS7Ep?C$zmTRbx%PC-7y8Bb?Es&WSGk^W{*Cjy( zC+Dh3pW-uRigK%d^F!90Qss<2q{INK6e#M*`qlfNXL^8fXX#+7Fp*N^$>tS~9_U?e zAh~?EeQulU3K;scA|DZOEY2ik6XSVh-77};ym#+jTTroPaOLqGXv9_pY9J(WncylT zCID_hk-ixmr~oFlW}Y>rqPIgaGE!40)QvaTPhIu_{)RdQtU_zl=qGs$D*J`%@6x?)id6EcV z%4+4G%QshhW@eVfTmQK2k0vB*Yicd#2oo1**7US=nL2r@ELprnGBYx*J|xt5#9%?^ z!bOY4x<}uiQKla}6et6Sj~r>bNjjG7K z_mTK4%2DX83P^ABSPyVt825M`Jl#Bh1W#YV6S{wwz34*TAtbq}&q8C7vqeyI(jZ-j zC>XaGi#XLI7}U4)Juw{?+fH66?IOp`_pJ2Sql^jSE)yqBl+^T88&{DLk>;{wUzA28 z#=B?#9-&?#s8doGh}8jTC@CwE4O=#tFdz>SDmoJ;n%aRI^w^PO5+4_D@i>GQCEgGy zSa-N9@7K7GJWzHJlB7kD3rXq*^8i$;6GL$zbhP-aSSsx$mt3Ue#8I7AtroeK z6Z27GcyIG;5BMlUJg8>=Ogrq7cJ*y51Uyb%hq$<_YpboI!LNSxD@%X)<=elMoP{}(G$KjaZoZJ; z{q}eAFaO`a*zec8v_}5vfBh%<@WT&ehXQ*5*#P3f3gnNJ9nJx3kYj^B2JML;1WgEX z)POkm>2CxtUIvsUlqPC0A|y%f$JI()v$4L>z&10K82wzqIXQ9cgymQk7Zw`@9Eexq zoCxjQW4VT^rF0kW-uFLz-{RM=yz+|Vp^7AjHRasA{R9}0o)+psJUbrZr1GBTUJMuqSEctWd2`s+6_qN{k0D=Zr zHWhGo?Al@cr&c$0&>$=3`_ngnD&r@Omp!{Q4MVM`{PX!{*`c^ipE2F)B7$W7;?pmz z-XltRa#FI6USQ&>$~s1v#JSzacZh+ES8j#oMNC43h6qUxywnS|Ff|0 zufuKftn}LBT_;KfB=1L$9W`NMu{;Id5IdZvaj?Zp78~Ld1Tpcui0}w2WE@9KP5T=` z0D$G4zj?>veDibW8zS)3$x~8LSYYwMq}U`wxrWq+n5%Yd_E=f7=0yqCxFSNcsJO_y z1R-f5CWMMhi$yeDu)Buxh)}VR#>knWH9NFa)Rr0Nazr=L~kg#i`XkxY}Mr|i;V^c1-}|sVYZ~ z91{TKW@B@b7X>Cz1Rdo{^L4gV^Xx~aM zmDu}~j1(giFFapp<*)$eSlmzx8bcC6#Sbh;*l;-aWy_XH_NZ(-Z>(5ik1*bR^Uc?S zTN!V~jvYG;lte82r59f^<$?4e(7Y(LFTAkQEa4Uv%)uHny)W=X6<(j^%cT9_A(2lu z+`Xu~PfZHW`D(q~Q81LEk~)9qefL;BfT59wGXi(ac!~>;)pcBJo^splfC=* znl*@$gM0jZ;d!HgLxBMei{QJmP+4)5Xdd7UL!S_W39R@;@gMAOF+My8xJ$7T$x$PI z+lo7LywxjL8&N`jUcPMGvCYU0Mvfe5*H%_mrn|UfF5ZiUMN*i5!7NW)tmHf5 z`gIzX%1z}}ZB#}CL7Yy5sDUbRO&sa5C4Dm-u$b|bKCQssHiB4h}cUHDz*qHpeSPBrZJsK zw!1maKDAF%_l{9D?if|S+&|#fxHV4I-Fs(uNlvn3cA|+U8v71GK|lpmY>-AokVa5I z5K->@OtJ_d#wILd4}x5`%ThvUqLWBT+So60Si%A zLI|MhdX>>NkiFaR>ITz%P0vU-&<#;9JV=aMWlg2kIiZapHh^IUVaxTFtx7$lg^3t3 z;*>X#l$$$ut~spKThUx?Y-*J0k<+b3SMKRt*?(Zaz5cDY-x5E6zjmXqpO5bkP$)Aa zQ|Te45~#qTxzQSt9?9&|5V?QD9T|D%g7^(k6s|fPZ7Pc4jNX|6_65!@dcIbI>7B#& zcofGt_Bbs+>`vE4&qiRiM+=dD*fD=fug1GZ`!gjaMS#cG)z-C3#A#GP^g-((qRO=^ z*IN4^HbYzVq}lXwQg<$6`cwMeKjvq}_+hjLYaMR-wCQFXsWoEsDk>{X?-X^SDPfaM zL>v-5hKLQ{RB1YWc+#a%K`<;hGh{xf>oFkXQ$MHi@ZI}&h33eoa!wgF2QhQ{BvSJ$ zFH>T?I)#AHs11(sA7cU!blouB;cws1Ksj3Pxbk<-2#@fN=`bH)6-??p`KksMfTuTpp7E{jA?|~ua7(}QTb-0iL69W`YJJnLCdFS#> zSb%ge8zho)&@@2CQfr0tNIelS&ggNY?YU9WbBrEB(`UMJkm@Ie{HH(vNs5Y!1SIdO z6|1a6hnJ@ONe=_yp?@XOw`)-2vO3qj7NwcgYxJwmp4ND8=jdn3Jfk48?^1j|dUKgl zxwh%=Vm*M8K%~rdAm{f}&w$H$!sT%H{@@tLr#?-Oej#2f7a`tpXAktzul(sggJ_|) zx>gDc3axtr9UtQ2;;b7yo0-e=BkhMs0Q2J-Y`74%>F5!r>icX&&Uo|;K&1dQKhLm?(|N~EPr z>HA1aEBK4ljR*SS_Gy?ghXF~$f3@M>ylGC=^=5{43L2DMe{ zrvQTZ+5G8dL+g^F#pv<8Xr*hg<`yO{l%Sv>Yl$^WQP!bhAy(%^yZ`_blok|!K+mG_ zO8pXmPe@3(gsb7bf9{Oj&$}S~mFwsltlUTyQeV)|QzCTT574>T>co()>3QnktSOHH z`lHkvTT4%Uq({HdF^-R(qbGg_Mv;H!+2|&KQNSbTz88J4;qkqZ01F8TG2U2UNZ@0A zZKB5b_;>?Dpu5>U-S=1r>4Q&VZ6WrK>JT+Ij2hat2r$gj$Obt#s0l%#K_=;j5ki4x z%a>c^TE#U3*{pwgy#aWLn)rF+jW=Y$`~_wxsqX=NiJTrO$jlu}J0>+XHBx>@TS;kJ zmLCRbT2hfvIA}9fS5s%73nPOwL_`RX215z5mA~O8QY$1SOs54>wt#c^PIPPu4h}XU zbT4nMQL6!KJJe>iNCXLdhWl9L%6H&9I~Gk(;20jm(@#45o*VP1l?Xew}sMp_d!(kdz}lD+%)%IVzG zCh`uc|BOaIMEGyN{k8-L1)F1oG2+~CPBA=0Zx|BlhiJ3{zQKrf9)KmR#;j(7*K$rV zp7&Z*sYiiAq+*FAxjry%JcoXcM4TL#NRr5uwSg`xH9m~-?3uHTu%DNkXZ36h7!fYQ z63E*T${o?r&h@h!VjW{s0?-^b7DNME9cM^Id*(MwU-!XG+GIz&^;xZB_gcVe;81Bi4(?7Fs>xL zNInNTssMce?C_m1dON<}VXe95#j5DHzAo!zmZf0fFaq|W4ob9|xFFGv0Ya4sk7HC+ zRmeQ=c@_mj?--KM;$9Uv)soAcm|C!YbL zcEDa=@A%qUqRn48Uuibqoy#Xb;`hJ8F^=CqKTrKA7cyy704X#(cBhB))F0AKFGQV$ zO|G!0Q0S*eG!$MYWUG14TJ;+(bh(stm0&e&7rc-T96jVG1G~$`#SMqBqy! z@9ErAJ0k@O*knP%0*k1q7b4ufdGlt;)D&T`Mp{H?6UI+4Kup=SGLw~Cv~ZE7zBj(L z(F`Z`KVHZC!3X5rGN6sb#m8Ct3tEV!K9w>-mkoG|gZj18I#9SF70+t{;keXpC`Hf$ z3nN@wR%&V8)@IE_XjBa97Dp3`2&V)%5+Ec;T z%H?kJT^TiIlzmo|cy{mEE&1nEs6y!@RaI5CW}$dc(?qo=Iwsm20E{ZYAyBPkL%Ix2 zwR-&9Z=~)2_;04O+T}6*!$*NfGu1$zB+^mi=orZEGxX@c*-t%n4q2D17r>64vr&&e z!jnD2F^*3*Uyt`}^_=mhF^HscX!1+pzb_0nNm>Ze%$T%W^5SG`EX#t1Xw72Aap3RC zQxpWE5rQ*%Zw4Oags~0*qP+9YJ61niv|y101qVr1R+eo4db^~gr3lTFsaLXw0oOo* zppJ*y49$wE3xjwCag1@gP;kM%0FfM^8=NEC{PlDLzzPluwsTFy1;7RH4YfW%JjQKQ zgM-E?&t;%0MU;SeIU6GNK#o^YU13xXT5XLSp-qYNE6l*rFOxn z+N7y0Z8ZDsKbr$JkZj^?V%F=jFHFpH@*UaKXGYJINkNm$uuxNjJ~4FoP(y2SKT$ss z6}3sgRe)zu&;cMrFG$pl_yOQUZ5abYvwYI2+k!TNv9R$!J{-e}Gdo4CMWEJV< zNK{B`D~uq6+9A;|gnhI#>EJ@Pf#>@U_ifiE)^&pcM(hBtEYT(WM~pSmB$4B=p~J*W zK{93KWk&GF`GV|EpUM*|_ePWpcxU>I>1O=<59}`+-`;3Ok5nwRRMsRY*hCc=PfSYG z6mffPl)36M^m}T^%wo1^P=bQQ;~#z{Z8`s!=m+oeR9wLE9s^`V?M)LWh)@J?AQoR_jN=xIuFbbgQ&o9o!xWlnR^@+>Vy~wHheY{en@k> zfKRB~SVxV*%N7a#(?9-`NzEbly?gg=*|~G4iGPnCJK9jMq%2FdpWy&Sl>&~y@p19(Zdi= z^qXj^JI&ha4f+TjUZC~_sR80WNZFH>K|K7;H{UcvPc(@j0TJZ+bLWjG373|%EL}dJ zyO@F2_do<;%ip#bP;TSKjfQT`I*}!}8*WQzP^i&eUVZIVGyZ%B2H%VMmGV4I`^s3w7F?}<;KYvAbMSIagIxOSr*idJhWJjOCccv+^n0msRarcR z35$nvFg1jI;I+;j-^~D>Sq7-1;qKx7cX0PNcn*)xrf(a++5o&;ODDEpU(eyE?cI;W z1~yDli69dpYJc?MN7k4ZdH{ygWzZDi~9=WYJU&4h}X1Dzb6G;lc9$U*4C~r%nre&sj5P z*&2iE31x)TC@9&qqiK?HBEz`0Nm@r8JaDk}vqUi`EF?^$(Kwl=#tS`I26I(hTx{SV ze7jk*^|LD|$W!SdZTk+0TvP*zapXs}S9==6bp0>UT5J3*by&`5d#_8S;^B2r+Axk& zl-K*qOFK4;eXbe!c2Bhoghkly+gKgr=$iCi{OyX2NUIVVxeR45zQuEUC^qIh zT0;VzNZsn_;iE!JAdDmPfTkuJ9(5&Z2V=*KH2}qP`-OgjAB@yy;pHOPx@D_i6cAPz zGiHo|Sh{~5BD0#x8abbTUM^g?AayrxN>p@|_A{Jg2+a}0N67dw?FOx&puk>EPdyAB z2u_UXyt(rfd=qbx93UUigrr&FxhBLbjYQL(8JQV|KBb;X6JzKUh@`Jsv&IZ;rTCsN;mP)zp8m%+j)5G;4W6dJAeD;}iH;PHfBq-y z6X|sF=xOG<-sj59k)C(waEzlHXBT6@h1i#dIR<+1qq-73J6fu0tE}z>V%LVIm`O>o zQIYO*ITC$oj@m&&%;AYI<_8s?-pPl1AopQUfKU0c8cmDI(?|Q!f`?wmLaA zR2n!lFRpYd&IYn{MAt;5a6W5Q;NV7OwG?P;to`aNgiMfCJ^t2a z%^n+8i^t#nQnV{GD(pQz&AIct8DK3xt3AUpj^E9DuidgpQIFQYP3scCjTv~0ePEC} z9pyJlmMvXsO?Htsv+u4(kzq?)H*e}nY)<_>yLx|YL~OuB78p@yJoyaZbijKArAb>V z5SZJ(+-9mp@rm(P<0I`&YMWH#>UC>mu8IYaW_<5Y@5!0mGm@K^YmI^-{S&nToZ(!N zqNPpn)~8012&y%B){hVdHWC3h7`Sgi&mI3U;r3W!qqEYKxL(?at(nRQYU z)EM2Ut&yY0k4kEKs-|}Xjhaz#vA_u50Jo5EBmK_n;1H8CB~40$Wwd&;Pi326J?Uis zk^YjDoTLQ)k=EOh_a(Z;K$c%Gm+YKut5HVJiI&MK#C|;OxSYy6Wz-EcR*~2nJ8o>p z#8bQF7$9IV`p{HDr-T}&AYEU(`HL@Q+LS30_{LkJ;j#?*bgTF_wmdwpA@w@mPdwh* zARhne*P5ua0S31V=(R1{~&v1D*0CMPGXXD}7mM1>` z^Y{Wb5Yk}$F!~Q1U>cV=3e1P=H;-|fe;CLPppM?((%d3Nnhqq|3fU`|w+V?SB_>(=6qOlYMWE7Q9U?x6(=WDtA%{~B zTXYYVgGR~FFo>k+x&fgcfp2nYcIfIv5@ZrJOssj>oT z4j(#fuL%ndGf{igskVH!#p;UmdSnn4*HqQm`a(DWBhH)m_G(dHfHA(Uhx7)=3TWU(jfm}CyhKR?e zx0Dz8uc8*&b+7aLF=l{$0|%U}0=L`q(~t4Or+A8E9G_y+9_J-?;`H3HQP~FnZ2>HGlYhn{Ke}$L(TI`MCdP^l2jhq#B=yK^ z;141x2fe}+XVlOk25__fri6xvO3Bp{Ij#l}+C~2Pe7RDjqU72g1Q|H82Sj-Yo1-)X z4Fc3D=QBJc+{peIO9Tf1aS=`O`N$k#h>sjSV$UH;rNtDyNc3Pq*AiKJDr%O`fpLSV z5C8De#Y<)|TPL>Kd*xrqw}^6X>|Co)LJa}TLtn=kn#M$B2gEGKnHo6Y9?;eN4F_?U zf^CRW`58Z{J^dUT7i(!^$|biOZ=0hqZo)VL&Fi6AqQm?4il=@T>949e>P+-F^m@^- zU6kY1rfW)V5f0)Y z&vq~h=}OX(I5l)pId}e?@dT%68WHI>)^&q+|A1^y?T(0W*|KHw+AFV_LB;rhnnfjt zlqMhCgmUdbQnxprM zu_N;2K8zeKwx}WI6WoT^@i>v2lgM3KmYO1 zRxe%u(t2|i*o;Bc60!1rhy-lgwoU7fwH8fo*swtcc@44_V0W)97M}~3#Q##+!W zle8Vr5RX@iMS_DL{ygWA9%sO{eg^jY7RS)zvwrxUj&c0qbNJv9um$Q3Gw6+1UQup} z8^}?;r~~~?+V~6}Fj#Ii-ZJlw)Q6>1)ktC}`Nt;9eQdPA_^FS%29E>s7&2&xxO?Hd z-t$HLje$bX^m@g0t1pH}gv;91Yi0iY`BGF+WV*H>FIktn_U*E@N^2+_7aSA7F3VRe zH)EN0EX@Eo0B#} zBoQKLR=9}(bchIf4`?BPaS%pFL>xjt1`R`upa#7iQLn*(BWQq14}B@&Uh+4`1TaH? zNvJ2JPFJj0VQE$()j4zKNKkN)so{{ibL8F0&&g57M8qs!uIj#XEg$Q}; z=Ue6TEuTwMbCVhFRjXH71UpgzObZY;uhUjx-#64DQ0pyiDp}{@7{~9MsV*p&qsx(qhq6G`buX3sn?QNHZ}Ag3+t1I(B$C4@?)qkzWM^ed zP(YBZU%y_KBrlPP0V?)ANzy2|b@Y1Uvk<95V{9p14% zIm7k!4VFg!dgs?tT3Tx9XbgHktur$EUnv#u|NT2HqTaN>UH{XoK`v-JvE0@>vTl&K z4AJXFu4}#Y>^aeic0JAc{fHR=&v3Qms-c=`=0M$fphooW8jf*v)6C+9(|!l_4=x}O zcQ5k5$YK0DI{?(F*re_#(56)vHh;tYgr9WJQ&Ux%dSwH1MU~7CMv{Njz?|{qGk{}q z^~zNP$)ImbPezFF)XXqAoS&GO80$;{vHs%ui&9cvBE==e-#Rhv?+IlBDn@d0vI&e6 zL6%-Cwb~z`8jeFlWxy*}uU(b8`Z`nO;nmdas6|4V@bl4HWBC;`oTEpLwrhcii|BOR zm~p0F!{_iB=3@v{(y;I%r%jzE!GXcDb=y|sMUM0tX{mUG#R1QdYK3Y7fCy>{YlzlT zpl68)i7Y|1@;7UYA5ymHr`o#H=*?PvDdC@M6UP7t0B{doWoT#RHONcqYwHEcGSaGT zI=9qOsefW@lNTn-(&VM;M0jdTuDjAtyLm{C>Z-Q;e;p_9w!U}D-P`i#`^qWpH$dL; z^cEkDzT0wg#X~uqIw>8`b#6R-1~^BYKcattTFf)iyt{^D9NjRpu8R?a0f`!-J1L>Q zG}y$bK^-}KM6Q)yvs4)KLc~Em7Fn+a3l~UIQj&ppm>Y~D^~lz?_PS(Wny=pat{4e6 z5ex&M7$Pk{f4?q53m7&!S5-N+67Mp>&w*8uN zGVhA#P*1B>Un#p{ln_1-^+V99=n?}8Vlzachf>AZ31ck^r0z%U5a14vpUpihM8uWV zl_qybv~lp@L5uQ;G)SS+B1^xJ1cd}yG@W@Y)0_z$gt!H9GAnA9rGHU(qF%mi)pAwD znJGht4KXz9^;g^5bR}wJ3?1f>qHO&dn`G+$^FL)sV{?~NiJdG_s>vT)Z%d9kCj-a& z%e1+3Wzoe#Rn<{Z1x*(_#<9zkJ@gOu(+L3+1W;7b71jM!2f9_)pu2`+9NjgunmHl0 zO3H=JsxL)CY@BpIpxXQt2$Iu-cBZ~0^q(f?Psy6He{YlM@x*E|J#CKF;@Xk3e zFRgjWB;9In)k?`_HGFFPNZpcBh3lA@n5f{EJ5s5wpD=DXNTf`gZZ{b}kS;BxZ5J?d=V+d&4R=x7_D`p&_oB;Y+yMC>uaZ^%L+VCZ-4(=tFdAfy}gH;0j5s=uS&td=-$*Qa`%C~vVZ4J`GrP;)5=s&6>HdOG-!?e z!#g)cn|i5}&?ZfauD$irOVUpxpf(jSXe%rd51o4@_I7%ebMs*{fPn;|>^Z0%@Q1_g zuHl>!cg?JxGdpqorU380bLg&b@Knd;JCk|>5J9bp?gv4QLE56H#RR8GRUswD=1jVo z->%^@j6{~)cE(f8fKD6r--QboT4ZO=nWnG141JEjQV(8Q_mZ_`q85p9q+7*Mul5KM z01Ocxsx;6nhyb|M1=)R&$&^Yqm8N=KS8Oy=4Lqq(5^s)o2J< zMXJ&ci{p^K1Qj}Lgles7Wc%*B@5)zSeZx|HPq)V1Au?P%#xWt4+>!Jbp z1b!s-V!CahliPf^S*}-Kw{$8|U6Q89i5!jgq3xRBxsqN5eah>1?cF80=X2%0K8BI` zYUfub2mpX)-I{gc=j$ioVd0i;higcGNz`sePabV)RRjT0w!D~n}BY%g}cD?GlwxJqsoJcxxkmUe?gT!5MP_X@-ot-oGYulco z*N6>Nc(mP@qLI43(E01(Gw|&k)0xBF!!eF-m|@pO-|C^YGgZhjW7+M(al_j_7l$;Z z9QDSL&9j=961efo=?&P}+-P+sq`;0JJuYP>WhTo-J+^ZMiDAS*x}1#X;)}fiAA)%$ z^0Il=y~XBS_i63}CQo`ZCN{?Se29Z{{zi=+B@=@tO7XQ~`SS;VmgC2c8z2I89Qb~u zxT0o9sTxm`Aw!7_TQsds24RTz5EBqb;tk{}Qf(Mv^iqqj6t@e9tAbBexys2k)R~Am z#uT9e>XSqVXuD!ui9it>m@#vPtszpZ0KCvpB_afX12+;hEm1HI0?}epa+0A`5mn#3 zd9#U-L;pyammpEIqKtn@sun{xM-3g(EIeJx03cXF`2rkj(wZWqe?UBgmD5OKW4ylR zb)|c>DXw5dKaBu8UE|!$Xl<5#T4V28h3vMF)G>6%k1!Tg-)E5Su(oiLhQ>$vYp}+^t7ezBO4kU zOvwhKKkceWLlVUSjF~=dx-46=%nTc8*<)$Ptj>(O(JVDC1*&TE+1Ag@xDj!JbcI5} zc_&iD@E~|zSz9U4G7t&RJCkQoBhq#la8jjk8$pP|sjR+UZAe&JSP>nft$Hf=lznax zwjseGaw7AD?Ar5XkBP+!#4{<3)pK=NHoZ}!{cHn*U`@IVqWI`> zqYd7lmy;*Wx0_AydTONd+_bAZ!)8h6$|6Sf+HKzSZ)fz*3;>QvKb|h1{Phz%Ach9T znY{cwYv}7e+}q^(a7u7ue)s#|8Mz+eanW6Z_G6q|1h~(hJ!|zzBCx3uQ?0WGT{&v% zYApTu(SLkoH9%+%q+U^~p@s?Ng6I@_4}ch`B~U=1at!Q0P-@l4q*kU{Q(~Mfj5dZ3 zP!3#0RFmMqrk_i<&K&$bZ{9o;E2ln4dN*!voYkV>TJoMg8rAV#X|4>l1Vk-eJ8%}Z zZ`&?4DtNwHxrWdKF#Lbq`A0dCenOTmTWaFxMa4z(`4^uXP>Aj&bPPcQ_LQ#UNt!xd zp$@~On))s$2|=if{qM^G6+CFUtInSSnw-&lGeCO(p2t0{;kq{+?HI@2J7*n7az#9x zJW>E=96KI;@o#vm$4^QMFoS7MdU^=L&qRbE65*aLUb5IWHdo}RlVs6M#MJiYw-B?r z&l$Zl1E4FZ`(|cmT6B)SDTa==Pj|Ji;9YIdOL`UO1Qi^>QUG!C&gNMiC&?lgE97;JPO)X7!zDdQBqP(eEy9W*(Fy$N^e2#~KzJ2qyWfkD7VJL|dK{peD zLVM!a{0$I@mK?IFgjukjjQNOAgi@?H`FSkmnqIx%} zlGBL0xEO0 zGnRd1qbL1^2abXTfQ-9})T6InLR^BiE~1virbkqO!b<1C-%A!NASA9)J$zLj(T&;} zy)y%-5kZ0{HOQD8KG~ut#J-VhiwKP{qkzGh7dOw^Q|;NeNA~XBD|OfF%rLB6u~Mc^ zo2vZBQx@I9FDxi7FqNJ3v~+p>jn}RI_u7WnEc!$^fCw!pILLr8q|?z?9Xo!keGYFg z)ofLO4v{1chB1mr%aLy7HEN&?t|3Jm9kUXU1pa~IBa zoC`x{D%v3^F)SE4qCg@;&La^gA_E{$8KhGY1_x0}w~g@= z#!E|6i`7FR_)nTR$+8X*|B=8$m>_bhwup+2wbom3WJ!$z>T+>rF~GyMHOh|~e0H1zqIP8X__1r_Q7`PH zkFzh}G#em?J%qG`n}%Z?-88WrmPPK-zh^_>#<%@Z4$Z}F{59PWPMtg@ep+_~h(j86 z*UnwmJQnU9>8nQ#XLESe3_bbdfN-e2@ng=1Z7d?e`p@OCxQ@z(jecp~>2_cY#)yau zzM+pQ%=oBLLBxTUR-_uk0>cc*f?OS`*c){>453UK6RHk<7a{i}`Gt@;hVS&r({g>n zbxUcI#-)yTI`6be){#L#fS|NY#l*F4M?H|b;Qsyl4Gct+Y&J=1h-50zcg3*+ty-c6 z7CAUx!)MIO$THypju|;U($cX_+7$!ij7a&~HERv^N`0Kjl1P%snKW*~-2_WFGhYb{ z5-j84p>@(lq2a3H)Fxiv&Y^4G_#E^Fsz}9Os0{JtHkcg%c{R zWmarljLq>wUgq4b_K;e&o6C(h&yI0)<8pJQQz;<7=o>!XFZCcG_6w613aK>!8<4&C z9oT0zpII|z88yI-Q|=u4F=n9qTEx(F9?&sRwjo7HO%6qyw>G{dK|w(s(LTnAXmgRK zX_27I&dD}zBWPo|glzUuEgOgTFCyyidxp6qyt-Nfsok z)LZ{S^1%lm$eElo){k=2rcD;%{{9cYH)SA112%5lC^7S5jQ1E386m-{HUzB$MHWl* zD=lfD0(m?S9P2z~cKg0+uvR4}${~%w4}AT#p>iL1Ql~p`D08xN0>R@9+x(l=- z@Ow6=De66wo{LY2Hxwb!2&pY+JpVI5bRQNPX8b_9bI|Gvpbf^Z^B^+3RB%~RkEL2I zkaNrr3OVosF`lui1T!UaiqH@k>IKIpx`g`*r2`Pm@wDTHWF@L4)k@lzpUB8anHM|H zp7)mz{vx?5)D3k5!E=zWAZr2L(4q?CNhC=ZjwCpjzM~{9HO-tdSf>F zeR8Sjl4%{I@5{Bx^9oA}W$5ss2KpiO%fJC39Zl{0`nBsC5!Xqp0&?2+>=Vrwcb*En zeSd_vR4OPaJ2hP?GnX|o{Qi_5`vmVriks*hxjX8aTu;t;a0XagMEEDOPMWwrju7X_ zUBihS-88dY+?+f%0SL+<^+3tJsDq6P4NhuRa62)CG<(KDAPquuTX=9FBnea~sH397 zJavy`Uer1IseCVp?lIBPX8h+RCIA3H07*naRCq33x+MAe`BwkC(|AY1BEqyT=Bf0Y zq1M7FJ>$56VgOnpsm8gy)u22^(zwugbn|CDObnbT0B|@K{79|^lxv`1T)leL+GCLh z9W+pz23OS>tpr0je$05|8KPv<+T3cuE(8TCDl0k+3td2C4(ICu^AGLO*Yyq^0{{q!FYBS*ReFvPKA$2y4S z7gPb|Ox_vWr2I$vOTdHxQJTLD9ynNngM-aecc=IF^xvrOz7hjBoXuUMKhoqocI>b; z>BWl|1>U2d3WigI#K_PCvAU{S{73lY-~?0I%#^-Z_gfZrrG~jTHk}T~Td<0Mw<}6xfj11Rdk(jz#zbj;U)G1(-ue z4$0@AeQpS3j19=v6t5H+F>-_?E=V+E0-urIixBXmHQKy$_l^N%Fj#bKC)LS@&pF1R zRa8}2)Hre6L<8HPcS_xGO2ibsWZFz@fT$3<#gSu2czS-Mfd|&!*laeoF5!&()`r40p+x6s?}Y? zF^+DUS<;L5``xz%PpXK>>O~&35t=f2igheFfBt+&-Dv!T3E~;$Y0ztGRMrGqYgcrL zALi385B4I@%TMvUkqW$~`li(4vQK4OdXUTqyhBo$7%%!ZlFEc@7!(*}yh%%$Y8rCd zjA;tgStQr4UNdKjS|d^5`3vW*=7@^TjOjD%^%z}f7^K~aQsFWJ0wN+Hm3qDWy4B-Q zS)wZkJja$hEfP0BPTt-4uA!hwVG_*}5dtRKwOc758ubDIqqE4_GiRmznjTlb1C$Wx zMHduJ3U!2>sa#%l z!DR)Zd28><(Z=EJo-M+OWZ+Qj-LpsD|KNR#prLOdWydw-jPIWT=tjPNzB1T*unFPg z6uE0S#?cKkiwDd<3?wO%4#H~twc&<${P7QIUDefd_t$2w)PDHtpmcEx@c2l7(X|~p zFaQSt4@liXI(Npip8@n!F?4LyM0TUcj5edhCn192e8Nwp;{|C)j3Bi{96fl7q%7ea zq8Nig;(VVxebS!OaJ#`GF=!qhGd=9N@CpG`ApS5valY03ic5A{T^pwO9vWB1p<=@Vi%8E)m9s=nYFpTDkecP)HJ@)W;Q-QaL%oMu^J9bz zs3n46rIB&dohFMmO>$17OY~R~s~{Z=Mqv8%>6YfLs;QFx^`5eLZoI6})UnT3`=o#O zs8K&>Wn#SS(DZP+B2>dQvU&B@SFQHSy6-+*pe0HWJPs0;2H>Pwo$=@yAeG8+{eJW- zp8gpRp1r3(mh;MQXTWvh=uBZoqWcB)g3c6egZM!Qv-2Qg1dzn0i+B9J=_5_);aJ!l zzQE2z=lOZow{cFW34Xryb88I+MPgCXB9m4l3WJLXauPvt1jOm9h$I`vkJ=yYpk~dS zC3)xatdTH)7NpkdZq-?I22G==pvVxefNEMaElKJVBMQl$I%C1b0yEB}M*V#JFEl(DK`G&l7&mGX8Aw< z=l@WivZwqkVS&usxmN}#AnAeO?;}?gm3>HM=8o*$FO@T*Oqs{!7^Um5QN}WA( zwhZJOjEGYj4&H(rCMP@3!-iawNrmPna~p zv~O`@P^+OHhcRos*=X`^0B?wXh`LbRfh@oC>z$H)GF!qz!h|j!^i@22?yRLR0mL9a zPB)Mtszpj&5A-Mcs2E-(-bg=^W$_vAV+I;SK^hb}IVdHlCV`qIBM}r7Bz|N3Oq2DS zZ@y_)mr)72`kVFQGJ2#~g93wXEgeodY`_;%x%21FH>o)QH#n}bb7E!o^x1*|MJf+~ z%sX$rBX7R(rtICfSHApmyLhVz!TK{=Cb(3hj&8S$c$k+oEl!j|b`7`qU9 ze7RZRwih5TAfOpJjasL@eVrb%#4ZjPKhby8yE zV`bP-MTa)l%LrA@K_ZZJD~*j6l4Tt?&YeGJy%`aS80Iz1>V_bid4GCEwzRg$>9ePe z;sdCMR$7P;U|{|H{mj^sRz-Z=qAmq;)m7J7q*_y5V-X?BOxw0^v&fd~ZLBsC1`UnM z4!t2szrwfl7~o;YuCA=M8YOzEVVc4v?MjL`JUrZ}730Q_SHbia<0g+(g`Y9`m!y9W z6x}ARdu3{U^sD^`q)J~O6B8?|)~qt+AP~1kTk3X}*xYdh5EU3XNS!}tJkboWuac7f z&hb$1!cD_5j&7RR0E0n%zRrg=L)rO`K6IOnfD{N3Bz2YV7IoK2VAEg&1=KzYa3vET)dI~5ei`a3>z{`5KzbH@fl34K%-UaqZr}J z>PiznkDL}MwYO@`5K^;5XO$+&)HF|IpD<7u=vc(X$7zpAj50OHnNc(CGi7SaD*8cs zX#~4QTWL+}A)DGdpr4#pnnXXG)4njEjfBz{3XT!UfQI*mIow zd!7OI3KVikhr4q)#?cM4%gM8$PR#(1Z^M80MgMO22EBJkzCY?8sG6XGIY5zsJ&i67 z1lR-zpU~4Z{h<3u>0wkp`ScUXIFVsd9>`6iM*~rPdvu-$(1l0}BqzWeC>fI@6wsoz zM!;2|Mm@D2hhZEsY=n#&Im$#HFjQ;StT8$Rl#8ufw_0CFv`vv;!)Wn3njE*?YqPo~ zk*nWGKSQ=+ED;c=ZVmbr`8mKi)J08GRkeysuaz2dmd}pBIqkLp+>n-~h6tbs%EzV4 zmy9+N92{&LDMlVNEOd^zd2t3bBEmz)ZuXqn`dy>sw(72a@Yx4)`0!x~8$3{!4;m_7 zDt_K&=ylyPdV~}PPLPwDKE9>3*08Wp6B0m82ej;0JHC2=#?j>%&L2-T1GcvkEV?gX z?D$-caqO6i-n-%2=n(+`soHTud+#lNGDjkPWb$F7#~HWGN7HgW4VOa!56rqlD2mS+ zy*mTc3UA!JAtj|Ha#`igNTZUn1Tkq!Hu^ZvfddGC5ELiTTk@i0^VEq7p*J8vj^Tsk zj#>>g1W5hcwrw+A)wS!^%J_-nB{MVA(w<3+k_>vEb~MdYYXZgxSZ_#DsHAHV0Y@f| z$o1rvlNJdg30HN!N@&Q8L4ym(ef#$BGawJf6e9?i_+rULi#TV-&a^Zzs9KCRDSZqh zXk6M>9ZflE(Pv^}qIHPbvwx55*|Wz|#XtM`&m<%?R4$&sC=KYnD!n4nqrc3pQ^J3D z$9AAfye(QFelM?+*?;{=0@UeSy=t|@#l_iY%gxKR7FiF=lJxFb?R!VFdF_5q+%OG} zadg9^x;A>$LIC90cm^la4PWK44@tCPJVu558C&J@=f;y$v zmzGqjeiL!46Wn6`}aylR))Q|(NXj}AyWQ|ismm+9&Yl! z12W=%x2TaXJ~>#te)DUIo-k4Qy1tesCc6ruhH8!Om6u=9NNuk8sv0vTq}IAJFyNZPu07=rLc7y{3Fe>*w%SItc5(s=P`* z+x?kE)6_N*GQh!b8QpG2asK=PGvEq7e!w9f>!siAN{{t)=Shz<19&&C@vKgy>-~PL z-zbt?F1TzR;1PEQ(80!IZ2ojp>ML{C`TM*3w)b#v ztFHk*VV+%4;QWLHOFtsoO~(sbNYS{OmQv6>hy*um*r1e!2HC!2yIj0{(NuAM_Rb~~ z^WL&`i{!TEnpgnoRH8rXhG?;p=Ay_7yUx~ng*B~!j2L}%xl!luPLSt+q zNqRF@R8&Y%P>{fVq^^iaI6~l%`DxIM;l5sTU6wCjF3CyB2Ef_!5GQF~c6Ru`qE$$(qkqDIzpWT<%j z@)x3TUY$L)>6(@%Q$o!Xg`KQZS!VPxxM;$nJL`QwnZV_&s?~E+kr89x|zVEn>=;$1N<%w zDv?TuVSVCHnDFTdIXJ$ckkLQ z)pga@UJ730>=Co=d{Wb+mt+2!e9IPKbU?SlE5v!46h6re$BpwhEY*oB4_N{@k$_k* zB#q6D29QBuTo;Z-gLK+Jy#~ZA(IzQgBGOMk`_!V$H(%Fo7%D4PdbQMmLo_=^D1cNa z=-A-UVENUrer1YGjcS0;ojYd+8v4oHn7K02XQb)CZr|~>4A$s+YVH|HE-vppJ?*!L zdx^)o)tY;q)a5be)5q6GrB$a{go;Bj+;_MkgB|18WvY7R5B8I1F&yLQhFNxVeg@)z&L<`}Xa!c+p}>oS$f*99mc9<>kp3zcD7> zU2>(w06=64=z2jt6QGQ**6K*9QsV=y3Lpq)33)+i6z~pB!cOTXplPY&AqoJvXYH!B zCPMJdoo_7SE4xxAn?K!b1{N^@v|XcTMq97Q4?p_QqSe=4ea-5bAFAlV{=@stDO;4d zNLDXjEd|8|vhUD7m8L6~SdB<$p1UOdy3;qPvrf^dQI&W!#O^pB$m+qHq_zr`Wq!O$ z<0(xAY6-#@&TzvF=vLv{C){xKjzc=ev12NF?*ug4!KCQOp(D>XW! z?ao@q)T(HKhxW3R;NXtCs5K&J@V8I@X0mk=lOyDnS6(qBYoxA0mJ>M8$ zDmo@wX3m&t=~H-u0l@*Le6(}dPO0BlZ#6<9JL+simvow_xL#p~k@W!u1VL}41IH@y z9wQ2kgLEpK$+>gp%8jZUa<$~D)YjCR(}XT7^=VSI90Q&uhLKt|of+PK`)vaV(Me<9 z;e8S?DL`gSn_>LO{EPXfmr4pBKu=kDnOwMV!GJ`RIwq;%g(C?sY1+i^ng2t|=1lj)(Y6eAXkXtD2IMB2x>eT0Ix43wt(?JENCpfb9gU zMZ(F=)7y^8?&Z(l*AIt5-~#lxuTn>JqEPSmMc(Y$1c>xVm6{TYa?hw6k}`Gua6gh^ z+)p*&Y&{?rGvGO|oxl(tj|erIN9%F)9|tphv8 zZ|d}^2A&}`85|rew;FFr{`q`MeIibdhAM&sh>;^P2jB$*f>A`uZTd{D&uL4mix)21 zxu(vEo+-u{lqX^XsLhbB1UU;A66G62&JUUC5rYc^+1{(7nfd<(Tdz%rUpFlP7nP773Jy?J4aL%q01@ZbK?8a zk}D!2!s@H24q?zi^>W>JA6z3`D^5+l`^-Gv-|P=$9&WeXHq^77fX9336FqxyIWA&moJmx|tG9VH};F+|lUHs~L8OfXoTK|~=Wct(yf@bwmkKWbR zhsWVOf?x~`3~U!C?-X=C-mE*%>Wvv78aj6Tn4HQzW!)*DQS98gQ}T22<>i-OmS6t; zFRef0+BIuUnvE19sZSFxS6~*kM8GkuebjIu?}J|b_kaI)NnVmH8#Ur9QQE}0{ByQW zsBO|bnPc25x@QPi(59D*E=$(wECX;wMn+m)`_nC-N<)2vYh+_sg20?^}T6cQv+bD|_7BtpiH8Y`!=P8qEUj%fG6K0s!L zv@(W}ra)897q7l>Eu_&zn#>Nad-&Um&nfI|l#@zzZ> zZ0f+EI~q7C(2UL1@~Z~Kp+Pa+)Ie?W3pJ!Ir_H)(tX;j<(w?a0kZLR~Ewv~qG(6PO ztDsg<=E*&kBXAGVQ1uz+VBmGUZoJbEt4aXAU0JKVt!>C<2&R;xl z>DhgI_gSrRuy)3v)>)}Ek=&eIiwbG5OzM<$@1?>^W~>1K#V5p@p*^Ij*dhh`M1+LO z+QCC*d`l08k$U*br5YYi>^KoPe<~-Qd8_ZFJHD?f;AeYtg!i$&1!Vhtp?xm zBE4bGvKmIBTI#TY0fCNj>^wn_xP7qB&|Ki1q zO_vvAd8_u8WfoAl+40Q|IdtTZb@o`9w9+_>Sy@@uii@=af;J{P#`IgMYtl#Yjo02# zUgKQJNINPOM~+C6rts%znsw>b3i0aRuTihxyORT@?aepDQ~O(*tEQj1Oe4-Mf7>D- zefW{!Fi<~l(ljc~k@p?kC);;!H)Wxo&K{!d@HtzWS{%dJ(*%9beUxHwcAy-AN+vyh zR~;314aYdTVP=VrFan+)o58n8s6fNuCq!NI|% zpo8(HZ{@AJTc*U5pkfE$ZBDDxHmRycHjElAgKwxnz>Qmkc3mc&naS6Pv_OseY!xdA z2@251Ju}CI6R2T19WWFXwqH7F^=wVFXND=R8Z$25L^yl~$D z7406Xh|gD5ZD&>Us`j<8xgCf_6JU_1H)?KJO=+axNHem0*5k*Ho6!TYis2*0N(9Fs zJvp%dKr>7T7C;eNv22AkQ%*mgZc=rm{XxqP8aPO`SC2`#)(e;1^N=Lf6>q*)C4puKoul9WR(}2SU&`3g8%#wAKvG~xptZpY3JQ|->()z9P@sPH3kJji zkOXhD@_ME9uXG)kJpd5Vq`*nK?)wQkwzT&0_xHCxmPFD3khngos;bn&WW7*!XTYmrL+#f4{SuQ zsfaV11fKi+g-VcCRTPkrq`6q&%#Smk{S4GAs3rYax*0QgfAR70GJpPji^>q}hRna^ zv(IJgwyoAlgXoMpBpRwbA7ex95dweYwhTRjcMN+dWdYL*Q38ft3;kPXL16dl7$#K?L9z%o5@x}i-0?*M8UGir=> z(+Dv+JL-@0j$E>MiS>b`uj1FLdQ*3^&XBG|prm#W?%ped)d0`&^pb(9^*gYK>A$N+ zyvTQ$;pt z!z{OZG#VMvvP$V3W*GHXUl^p4*eIH`2Ob3fDcWe3+5k021fM}Bs?T6(#)`5Eiz?{E z;EZQD1G=}gYV8YN;T5GZkfOR?eO=Oyr5Rdye!_gKDME7~or$h0Bz(}P)Xad=XJ=(z5n6+2H5)7 zfBjdh%>!tm=OfW6qV#~cPUW1k^+Sr4v?R4pj4sX>TCfoLp>t3drLQE&R*Vp@gLmoY zt7<>We?(#~Gb__5C(E=}HDjn(k4|fwzV?crw`5ESlL3|0vQ)nxDPb>-ssZ=l7=TWl zHhr2I#Pes)Tm6$}%RCRkbKaZoAl(O!@{Q^nMq$~yWvk71P;ijVAxKOj^OR#LCYBJO z5oTj!gX2JUnnVjW*if}>)lC7h)3bW#rehp?XCAv8r6Y1wg&aB%Smgg~oSiP8qBi6R9$u-`yAk$u7_ zAEa0(hfX$wO!pT)BPmuQHLf>mjX0$MhT;<9EIo+^jAky~`vMgG|z|nviZsE1EYZhe!u0a^!c=~bc>qxqG_KexO zrqsx4y|h&M#pARVn6NNOMyioZRYQA4ReK^8{-2=Kjh-$|5z2>7A&7 z)=FQt=t7o0D#A)Rm|WIpfEh0p@?$kYT1vNWL^LSa#%0eomiOjMMS zt^|3FRH;QK%uBFniP|S17P@tCY%@X%>H@w$C31?aTE5CaF+^)9?vPUDvmaLF8;lAH zO%X~Txu*&@sam%jeW^hHWzcX5%eyE;ipnHF0Z3D|7v=qa!(@~KfrhG~>S=iD-E*4n z%m1y;zz}_J|5InBEg(he6dV*793-n(uF*7Yq&X26&R;NDJ-|Z<6)ao2%;t>sPVK#? zh>vT7%nINjP^*Y2+|r0~*EhS2>xpBsX6+hN65=~C--xph_8cr>S_1_D#GLfy(K$2c z&UtW*qZ?+|b@IBjtm;EHfK7|~k?4QM^-|9l@n^)VNssl{TI0~6L+m2Qn|2JO8y4YX z9+KXNadB}*yr&z+C!0Sp@;w;<3|4AJs?gDbh%e(rhMfHPq^aQ$*#U?lMflCmZw$FP zFJYeKp3Rl=s&W$&7~wO*s2Lzcsr?bvp^1tC1*n5$9GyE(=bbji7}B)Elm|)b5x@_K zO?Yk86(gob7{?MmN~s%41I z$5^dX@n83duJcsk%8pitcC^+z+ceT`oHki@>hBY&M-^#3R{rkqe`V-V0A^oo`9gN= z*kOR5*Is_jnkzFeMAbc^OIha_cBmg@Qi4K)jiv#81N~Z3%7K~&rX+#5I`zrzUv8JL zzW&P2&pSVRM^-FfsS)Rh&L6q&-Bt(2X<79XJ?*YkYL}K(Jv*vD(Qo+Zk4+i~R36>i zx#+pjA$3!OZN1kj!@Y*fjOjBBK;hCyCp=1^|6VUmz7(DNNu>XtWv@>MH(Ee!VL=K0rkmg0h|Jl5xr0VGN4oW8Lh;6 zc!qEv4<9^i&x6ZH)I+@)u>j6B5f^DjB0r1`Fy7-$6(_)%pg$%mTb1RN8X33R zd?TJfQVMP;P725FD+7fsr)AYo^lZB}bfO|^H)bsR&f2vLo>UM#u7g@%X;i{E0@Pg0 zEp08vOMo;W2;-2D5ZUzZCYdpH zhV0(8TMnfhG6x5WLQ_k#Q5QD6w!zS?7){cOb+vU?SLSoVPXvVtdKEq*oXEnGLgTZN zW(REcC8Df6AEwRRsw zltVOY;-!*$I0R5v($dllZ}JyQ-IIcW9z zq@<+wR${6I)E5SOEBh)x?ZbT=tCLoB(~5E#NDl9cB;E8@&(&f1t`MeEQ&UY!3@JDe zg{0Vcto44YrCK3Bqq<@eS?Y-WksE=;6j0s`iUeF2|!C2P9f=9M8dCED9=&PKLP`w zF-d_^R|H_gbC0E}T8&0}fVbw%o@1itL{l_Rh6X~jrX;pZX3@^=|EMKwQl!h>tI1^B0 z_8;Ca@BQIDyQZk&qF4K(cKqo+fBbFPCk5nq>OXf5$2huSb}<4*;m{3(6o45@m!so` z_j{fWNxF;;42~O$Cp4s`)=2tJr^O5;hLHLaH7HW84D$%}(Ytr)T z5QBn(BsnQrRxMj)a>!bKMOZrlE)cqnyaqOL^{sBM~- zd|0e;S0A{cNNaCJQTr>3mzG(z+IEU{JbUJBNtmBt1{2jCdRw-%v{*D96BA?7c4SKS zAJ}gWAkN<%)s*dNu-0)Dpu-$Ka@bUT5O~J`x{N2UBT6J4O-hy5;7Af}(%Ox5DqU<4 zXn5!s>gmmY;`dpg!3liWN$kb%=NQLcoXpOLVlktT16q~aePyu0QcEEvL=B5pMEri7 z!8{=;2V&0^Q9jP=oaglJ3}A>R1WYg^Nu+nP{-#O6fi5O;#IYGOZj3BkywK`@=$8^D z64}jBng)@gkM=%9VvQOmN;2FR92RVCov0UPp3IbECytrw&h(knt(Hl~VE3NgmNf_t z3YMDdHIkl@ZW3&80+SMxWSGw|xl(q;j1<%fI)BjZ<@}}dmX@EYicGYm0vSu{u~}1_ z{9Wh^)Av*o=JQ!bDk;yu>0nqFf9%y&9Ph zB5jNsz?_}m>@@Wtga|Nd%o~w+=YhdveyPDDbq6XKF@bq;^JL1@DTdVT{CsZn8rOiA znw*?$X;xCRfR#WJ_oabz?ErFq;%D3dIqk91PyCxa`s1@;A%PR^`6=2C2`_Xup$7Q* z)3U2ws>?h-J)8ju)Mx0@fde0ceL#Qul0)(6*?soUut;CeL-y%x`Eu)*X5?Of?R8nX zLeY|%79B8HBYy?w@RK+o(WKR`D)4H=$Pp&=Fsf;kEYJw@w$=_oow61pRZWMMWHbZL z&de4%TOb+^O(P*bL8`7-S^5(GWK+FrlkVOva385hzWmb5GG|tllJNIhggAVdrrlMM z2XG9HnXg{CY6wpZBZ%k$g9a$iGECOL`kKsA1Hbm7W-^+-zk@@6UBlzGKCXItvQ;~5 zeDU!ocFbS>>Q`pGK$^mBYal z;46dPrc=pF>s~S^+usxJyE zl$LDC%a<6{V(0Fi@~Ik%z@Q*mx_GHYhNK!H&2QSY$;9Ue4;WJVLU*hOVas7Ux0dwON!;|onK46 zHW**2b?wDp?UXU4RjPB`bxqw@bnA`4v2v%fTE^BiN`HO0wW3A}Kl@C!-)R!4Ep!qA zNs7T{K(%<|jW=Z3vgL}#^|uJwrI15}M<){MtE7m@pmZMqh@i1FYswW$3bYLxH4`b5 zE`6Lq8XBjh&kj9Lu6@Lv8>?d+-MPXri27q2eb?*Ko$vai9J{XWrku<^X&vBeZ`La0 z{GM^n0BlfOA{|73OXdQ_4>pCib#01_Y)7lQ910${e|Xr=_|ay7O+5d6zIBgiyxnLK z9lEFVUZkG(@+&VJhy>$Ev;)0^P5)@hQAH>plJKx_qh#D}ye+6Af$&7`Enam`Ck0Qk z*GJA$pqADpD^${rR#ichf~-S@m!dh39Zj={aM*}pX7ms!IFfQiE*D=mE@YTWx{-B2 zNW7q+z&^{W6{{?2{Pfem$;W^FSmLz)xT(JaSxT!F#qr>JYSMaldeB5UH-5Av=bV#S zwHh_vz9Y@qs&CrbBp&Lt5t#yZA-zn4U67{1p_(4nGegA2S|(CmxooA}QDY1rbmD|b zMuQ=B+Ig^{S1UM(?jemg8%+cO9axMb(a@6)j)&8M(?DZ!Qn{2cUSx2N?F}Bfhp29~ zy9HJp|yc)qkMqWyx5&%^5SIUMxraqYd5~R(ToO2(Bo;x4awZ9fErMv7~ksJYU?OMsxxLzj8QrOK$7Jo(_dLbLX-fBma zYgxsW%J}wI`yVgX|JfWtIMUD-6e61yDJ4rQsl(1@OR980{{dE)#8C1W2GV5&xsSmH z!c8_hC+JMTFxfcutf`N%VemIHStZ3+ zGzB-nbXQ5WcApw^D|GX88O;}c-k!JbNBWXZ^zc-Rm0Jjp&&StCZfZ@rs;0`$FXtK6 z7C4AWi<0Ecjc;0d6hQ~-h4gz2m=s`YFBnY(!|fXAbQ#du<8=0Et1Dte0B}W2jxcGu z{rmS@#5i>5P@`|aT`Vgvv$aGA3rP3y8j-gHof;b(D^NPp(@)6JV<{4@DgJ*fE|UpO zJtI>~eTT|cHGXFf9MrYxp&|yOWq@WYQWc2v`_fVwe7{lNnU*LoYtKpV(PL!mmMzw0 z1mT0)$+hO-0T_al`t5K(_6qNavPM9cN|q7LSWbSn4-cMtc!gS)@M zb9j8$VsF#jIQ<;$?`PoYJP%XB#Y=|-c#c(7RWfbLG^;P7n1kv{x{6M-=`B@{JaJK? zZJc~=*T#TDfj4atBR;{vh<+dGPNp9*=E30@ECk8%mt z`gq9!O=IqZB2rf)Aqon@z~a=kwdm?oT1K@-$}NctBv_4gQE8d+EQ!d_I|YPsp1$;D1ji9eatge9rNff_f!v<^rHbGOmpnto}z3a&@$Zy+A@elN;ea~>;#_AYH zH!K=Xnw>a3Z_pcD#?lRM_1qnjItVSP4j(vdFm{^UQfJz=dzbxq4f2w^3aO_-EQSy{ zG8bBvloP5X@WVhy_N94y9!@0bzVs96a^S!LJBOn+qC%C0PAVA9O+VWt|L~9hV70U| zH5$|%8|oY6^S^yA-Xpv%f`eW`y;*l?1@35OK!ccy(h50o;)FH3hSSIoYBnHSQBxvC ziczh*S!d59TADmzvZc;2KnD&Uu;>+j-;Br^n)3a|2=oA1pfa?nAxSx&D*1{o{X69` z{$jB2gK0O7y6!~;%K0@bWSh#|6`st}sMyb_7*H}Ql)p$hAUSEVw$cjJh07B_+z5bRgU%Eo-s_SIOH#_93onILk4WLr@X5N$* za3YAlNi73n`{2V548XH&`7(K3^8zW{oe22GbaL3ga7{D{<|8-D68QkwMcCr zCjvka)DGV7MK+9FBkZd<&&YCmwt?>bE|Tu;YsfK0Mv3ziWnRoYi|FZk z$&qTrD&(|s5OJdDMTx{*fo3HNR6yVt&3ENDY8c0AH2c6%W8EAYB;}zR6{;lMIE~O^ z6^MhDD;lWVw{4eGr%%cB8Pk==7%!t0O?^<)uAeEbgZ5f6Q8BV!)2!qD$IITmd*$Tm zlU7To*12ZQ8VOQ^N;71H01#3~CQ-M6E`#-qI0ETs+PU#KfEpZ!LT%0rC1&yBWTTDn znV_uTu%Jvtx|&E42eSNHx$#7~rh+wcj8h5==~Z*cc}M8Rnzec%uOHnf5M5w>wtv5F zliX#-f7l<6ar|NP_r0%XvAUETY_Yo0%lY09@+=?3ky8&A@2*7!ps5!T9RRi<1r!w> zWtx9qvcmC$`B}>Ex<5HUUF$7qw^)~Z;o@aLd`JdWH z@s3fSk<)~h4z%f14PAm}eSOL6GA4P98A(U8y>#6ZdW<_ zK&n_Ylq7V#+tDoCOI4Swfh-H5tq-hQ*gx1zk7pm3Z@&G;LT}__A|oPgLjc^tra_*k zqXKrELAZ&HgWME9x1~kx++$1r4w4kQKe#*rpQLA`YeD}qLspW@qJRL(i>-~Uu0gKlrC&-0A zd?p7p&$)j6Po_}EO&ljCvpG~4CL~FK?BsA_MHmz-H}`ObNJO)Zy^x%o=^mYL25Kl z(YxC($@E`+f);uJHUKtPcrQUc5}G2kjP*Ne#3;+9kiTMs4el3gAtUEjkQpI2tV2)8 z#QBT+{dq_LnFodhN}r%UW}Q<|4!QN2(`SV84){<3)-k<`gQwPlWc|=}Qa8N4N0QhlQbIoQ9!*@$cBaL%L{P*&JmK85%d# zHc}9I(1Fp3!8kk{oyk>e?|5fDSS~{0d3mJlc%&$|IZUA16}|CKmbWZK~$Ds z95{HOHRYW!Zh~>2vRU&y2?^$$R$_1c_u6Z(*+#y5_ip*?mwz=+?Y(#3GgK&E&du95 zZNsjutF>bIfBu($Hq`4M|KX3aNJE`x&g2?+3&tJ7hVYfrD-va6%2~a*z`j9BF;^fR zHIzGAn`-xJf??*i=CH3#87tSdOytOcbSXHUFG<6b73lGJshFT!!x7kpIl?#puVzBY3T6EC`EejH}A>ZIm(8kq0S?Rj~F@|5^;VXH({I| zAFxp4!TncPRhuFum)k$IzbeOm(!0+uTQNohG(SbC5& zTAtRvn3q`b7;04Ov@rZzTSm0gVB`u=*@TJf^3o+k&1qZ{B?^ zbu4tMVJUaC0tsj;tGuk-LgTcPq9qj`BShSR%8nZ4J?u4IM0%T6WSUK3?{y56 z_?YGgGmm6iZWLnt=(uQOal%8T%!HgcsR2U8ernY5IvqmD_k{+9TDTL>Z|l}Ag3_e_ zD0$VHx^YKGMJq4tUW<}=Ul%`f&lm&{D$tpP@bi>uQ#?cost6hE6@)^aa3}y2I($$A z3P_FcGofYHlK0?u5WaA%GEg4;YfFQ@6mOgGJh$eAr+smcu5$E&RL$a5qt}Yr;dLZm zuHV|r08m4X)+G&h5#niY{pQ-tbJop=jTypi%8_8PL6H#3V`HMT3JPM|_HB}`b%Qh` z26+mKbNLU;O%XySj<93l`JFs0ojvyM1d0^;ay!nbB_bWo{G#Lo7cE*OBNU*Lmw#4? z%TJpU9Y1lrd1ch{5mJN)H8L{N(3v|`X%S|{6Jj1@9LX?%4_#gG4*3GHO6x32Kq9m@ zFkC;|L6vOCPaB$)SB+ltp3uJ1QI*bM_0mvkggpsEju|(`(72QqUAuA3ytZ+QSfy1K z^@oSj4q5(?%@<}TT4hmIv2*)QyADFkv9YlhR`u)J&1!e?00)N;HlqPx4ZtE$>g3W% zA$SiI9mWJ9W=cR7%wJ%QnfrzI^M2cXKjZD@<>eW()XAKast|jd_t~C|ZEt}Pl{4qV z`$Zr9eE-w)(Mj6vVRfNCuLs#uWQ+w&=m+2g?TsknPDo6Ui0}yM*0Gxz3-wxOMjmCn z7Gaa0>C{whT1&a1c77dwlvj1;teMu>7q4pR(xq15{>q|PbV>OZ5t%DFG3^nBP_}p1ltazY!XZ(#ko8{kz z57$zW2{Q7`Nr_sqMtYTBe&ESm)YbNVNDsNWzQ@vc&~F?QluiHeDOXvzg; zN;@tXf%YHVZ(-IsbLOZ_Co8hm-{aL^y{79;6!hf(fHH1;?zZqd`zhWddx*9+&|A`* z_t9{bqYnhzpb+)Bk%MVZgPbFI725e=IbW){WHn$w;K{+(-KjI0u24nj!Gr@4!c~qf zcZLuNpu_;s3S6IrBmqX8%04Mu1GZ{wr~sKXev%9fA87m3%9Sgv$0E<3+!v$(d_f5C z?z`_A$p9gD@@_;AtOZo+49Py4Z9PCi$KuJQ&Q6t(0b1zqmuz{*dIi|@QDqVIfBoO$ zUv{ZUft^>PffK{yQKTPHf=Buee4+Za@C6;rHY@B;u&o#mT@@4@@^@0q&AVM@>NS=;($p~#i|un_|I#UXn-;WY_o0KHuD-G z97st?v92O%X=$=+_bwwr7@j!Xlxd&fzLsO$tAHC2sc}Q&tosOITSyP~?b&CXtI#46 z67?QLRk$9A!WS)BWJ=%r@7_OybcJ4Vmr~uK1Sw&FoE`FYYALxt7<_*C;Ri#;lgot1 z*uTqzC|2*|wuzs~Qay)Em8%?mI9qJ7>r-@;r4LWlq7F@uzqny>5<5KBGl_K~15!W^ zj#ur3U%kNtgpu$(*&tD}-hXRRH`tCYhD{m;SXohN;Hrd#VfGBOG?zzPE0C#^r%bjk z6el(02|Esof`|ZQ*zk~^t2ieKbqPv{QKh-aQ*!e3Nr{Mvu)kC5x@Y$u^U^?~lE3Sr zMg8YW&q>$rU6m*zM7pZ2*>U-I()oYnQGrV|LZ5Ri^Mkl)@#8(x%L0 z%eF0+V+DymOy!ZR=VZQ~%{^M2J0By=Zz94z=00u$%z63c2 z@3Gf4@={h>W&{jGVn7IU4S3e96Hvq`P82vs$i?#-RBpm(u!FUs|FMT)WYe*hdO=wbZhRrX|v`P6^s%V8YaUN zh8taApI&_gFOY5*lr_Yt7X}g&geRLipd46rV4j&cX`;-SF~bz^=YRcNx^(IyfB5|$ ztcyJa;DCIBH7q-K;VTjaD)E1PDILlm45z}(yS1)HGKPf8r^=c$LUWUpl`LJp)X=XG z5)4zXFa1!OtX;R(xMJZx#eidzg$I^UF>?<^otm0z3{T&${9bnM+G*gU(Mh9a!h{LR z=NfD!N=Gx5`25;+88UE)brT5=(f*c4kI7GKf0E+jVxzlbUc)R@UQvGEGb7yWC_sQs zl#_r4ra^I3bd+5eAK*PuFp_`e=c$vYn&*fDN1^iB;-X?>(!tAyoB@8;wmxhx#eVSE z5I((KS2_AXyxyLoM;){;&4?1btOebfT1@@(`k&2$r?Wc~8XitM7674N_{u`dq39lE z9wr?h==pd&=eWH2`kOMZ|2%aWeDHwWLq3rNc#bH*P3t#V!ThY5vrKvM96db%JHf=FP>1V(F%sObmu7eVa8mgcg&GF?b>&<`v=l?DT_8+jECH0FmL?-+Q=!SDu zT&S@Ag(;F^50l=D3tn0v z$zzix@61_iNrh4ZWQ12r-m;*mK>qxfKMMrxj3rB!n0NSv0+<>rM@S@891%cBmT3 zMUp3N56Y3}M??+;yl0>FotAW!qfNJG`#-a8?j2HnB;DWJ*A5T-{Y2Jr`Ek{c1{kQS zuCfg=I560hWAV9StM{^w1zvL-5DzRVWhG_SrU=gy`MKl8NWi=o4Uxi1f=39m4Rmpo zCq)d2u(BMK;E~KD=4HW^`}^Ph-st400fa^nW+c9!I(^D`F$odEm_vPETwI(XFkf5p znkiP;T%eo-IeJx#@I&=$(9-Xu(}_F{D>Pz4>C#DV#79c`r13IHnQUfGouTz_w`I-R zHFDy_2`kMYKZ-ZDW$PBnNcXhEijIty1@p9oV&Wv@{OzL+j6eD4W2JPvY6^(_IN@SS zR#4a=S3%tN^y?`be%>H^ckeYKfDwr!WZ}Yv#;OB3Kv7wdk%5EAB|pjM0N*@pkUD^j zpD0Q7wQBPo>7?O!m3$`zJ4QKc@f7hmiLg+2%KD;1$)}(ER%?kbo1%=2jC_C;;9=)( z&96JohW8%ptNU@4qYotOc#Z&asClvn>7@jGaLN{QNb?$X!5%+$TnUsfYJa+!LRS*P zR@AM*Y(Ya^@-iR*v7#Bs2)Pk*rHxU0L-~57(DMFI>#Ez# zSI=GsKp}k2v!fP|M#$tI$*qB|gtY}?@A!mx3#ZfhBQhe=6hcs+AbIDVcjWTL%d%z5 z7R%?6#|#@VSjK9}NA#ggQ3inr1*6KMlZIxK{>vX_jLt1hdI~)ww{6*G3MX=Oq{PI> zNbRj!BdRVeDzs~0KF(3z(wj9mWyAiBs%+}alO*(tH%I;xb|<=$;7vlP4oHX3@6%8( zT_Na>F?QTo3v&{l?V;c@a*u>Z0nCgWJx;1?s!fqSc;PzN@8#4Zq9f$3x8JhR@{|cv z48`gwN9S`WMZOqT^Qd0%iOdtytw%RW8l9y4w{g;)6v$Eqg{{%zI_U+rP z$0G|Kz=IhSI^S93wD#)Kv5V)mmUMIN@LDinAdIK6@ai8{TX+(NmpQZNSbmNY4aza7 z^P_h4#`POk&Om)0-XlsRY(SXh)IR&{GpVesv}geQrR3;fm09@eLJPeD)FA{)EPaI5 z%FfDBB7vF*6(ix)gPm^6(cAShU&E(E72HCP!<B=NtdvGVe(t`-Aj*k@31v`m9x24K*PnKNX# z5}wocie|weT4|aLxCMYsR%Vt_+)MYWMtKv zRaWmfEPj~$?hn7ST1YO~a*Ov}x#t&@9$$EfFhrqf@g(`3JSjQZt=qSn0-!TT%FGlq z7+Fs!xbv0gCFe|zkfH!Vd<(DoF;vBTwz9m^DEp|31ROPc{%q^5iK1~w(-Lr%W7Bf^ zRj*>vn1w?~RVSux^!GOZUv=PC@L?7{8zJGgOBXMx570q+tECR}2nfW^9Xi|QSzKN$ z{RZ~ayo|?sZIF|0X#CvXjEa{2XbJ71c;0yZ4a*1j3+pHQ4(ziqcd5QpCb6~Q`k#0W)K)>zL$ygWkfgko!N-Z0OvsJKLWDQfjqh3U_~sUdcq z2aQK{puc1#CrVF6H4j#$NM4R(pb%eCWGj6a0ny+I?%1`%A{21_CPpV3O&$EGTQ_et zS~;Q=kc&s_^%oWv%G$MSEq}^638z9vz&&l=ve~#@c^!UMdXu7H=&XU!N63|Q0mtT; z%-@HFImsCsNroyq-eby%h^XEwULzjo(r=eq83;Wbr%s=0??ZWlRHa_?^*3I(R#x#! zc;MIb@m)7izUMVm4b#uspVk@=?4a;Lh9d5$0bX*dY@K1?Y7J^T&KL1+!I#qM27KCS;^qGBv(foZIm#2_Uzju>k8J{h7Nm9P)Lv#`1ds+3N6WK|3p8*AJ_b7 z$W{O_|Mj2#>%IJ$_8!!hRzv&)OsSQeE0%*t)8&ei2Q1KIy{YbD_eS^|yZb&pB;d0T zWwCm0qt920zbd4dxEKS-fbN9+J1#!Xq7i%d?vqtNtddh_P8pDB-kf>HAd_}5O}6jY zZu!As+KTG6MXzZy;V@aXdX@aN?k5Y&;?3c;kv~j3a7cby^OLpJ3JD6ayg5K3yy-px zeGJ$`0X_hwA%lk4Ws)j@-3Cw3d!RHi65)Ftp@sr^R|jE=0*6rt79yf3P}&iyh49@O zD96;9sa8IMvV?{YPFg7GsxDTU5so2hWh&ktp&qZBcKHYn3bw|{9Jg;TW#{pJk8_gN z@Llf*8ToqrB6(k*sU02P+2}jn)lFW#M;p)KVYUf%K zhy1ho*6xQzj&<%7`kQyn4X6=;{ICw)(Xu2!3nfD2fKm?ZJ0OJxg;x9cvX)UKjz}~w z3xElYtUGq;XlyxzP66?-*+Viuc!;7um4@x6)=zd){GrWwh^ z+f6K%K0T$wTgqtjH=jwodZj}(oCpy*JfU|PyFYkNg& zEr|64dIreHAAO>payrqZMjjSuv25x87M>u7Wi@o-s<6u!{!aMmZoVplCk5*T1vxt51$KFwknu;@cya6 z~`OY5U0&-f-rVX#nUvu^D=*{CD{SFc|+BPe-PvJ@8-OS#r5#>5P@ z%^6_Jp@WA^5dkboNKkSBE%iY8Ob?Hgk@{Nw2k%L)DwtIY%(}~3>OT1B10yMi^qX_zrA0(U2+ErV#dvrQ(s97R z0meAvuV9>IN=vs_Y2WY$LE##4fGWac$B#)yrj~$csRiJf+4E-0=&_@%Zud`r`jcd2 zWJvOeWcmAl_#x2x<$V5vdV!4w$_#PgG8_?P_ z424ejKnQpAbwC>AR|10q4Y|rfbqoqZuGR| zw-7~`R_Q%mGD2~T3^-Q3M`z8^@;V`G(5Dz6P1RSTAo*(TCD-h$wl(-pCpL(;>Dk!u zXZMF+BLN;Hn>`zUTOSlApFDBW>eL8B`E~U(N-#R7->Sc5iqa;w&TW(?N>4Ib4SaP0M8B2pS&1(Mj8Ppj~=6FPwl*-;YvDKfZBvE5Wvd31@kN? zn3$MoO7g3v-%3w?uCJdsCH=JoBJ0a9Wpm9n8FlQ0d{(C(VH3A|J0w7g=BCPb3hLSR z*Uu$BHb!|#BkY}&HP9A~d>y3;eU#L^q^QJ{W$C$6s~bcqlWRj+mX_&jn*08T|NIXE z*aby#F#Vu~RZ%D?(wQ?;O_8qqNlQJx|K1pGX6b8hyzz#_#l*>e^)UGx3J|m@Kp>PS zK$}Y!G%BK=@ziNkrMq8uIgxYXfwoo1jTT%}l)sgR${=KaSowny4{$vodTG~17#dG^ zpCW4a?cZnRCbMSFmXS##?7WVs{I%2rq%gUAJYPIyx_z|e!Jg{2tZJoC*inW6azJM` zSUausexBsAQEFJyba*GvWY+AUaPtna*im+DAh)$xn^Fya2T0&p*T@JE4jh|ZHFO5* z)g3KM0@R=4)y$nUSI%ENZ-A=Wt2dNZEl&b^_mU|}Ku+O5Xi>bPPd@&{YFR54JhN%j zW?A{;4>C-_Rtu`NyyHf_T-?1+1F7}$`t{oq)D)SFA}R0AN)h?=Q|a`t|5L+;U8GN7 zA1i%0dibazQBl;CSKuAO#zQH@v8-bzIIb1)^CInT@s%oKXbJIb-+%9YyFSWMC{H1m z3gUM5tl7%mGgxz^dB&=fot>@s6`-_oQ`HDawtQ=0L6Mb)aDw5(hg+Q?3iqs1%dOwM z-g2O0lE+A-hK{d%e#JabyBPf+o*PCXpCe?7GNY9n3La7nkh8N=v`j>c`?)4O(mgx( z7*8w;4=&<}sBl99JI4gj6CE3^ImP~Fgrh9U3%Au_d#f7QIFP;`uIK0j37az1o6Zw>Gf6c}VoIN?3Q&5MMT zo3e@u^|t0~E-dhlpC~1&48L?$`l_KcOc{|L7@d^3esqF#{qQ{*tj&=B=C{9<1?o|u z25Gr%#&9Sy<@T5}40C*=dQgfH85NVyZ zX3ZKas;5um;zf&%Cl!MHHCoa^3oCveHfWep-St(PIZ97JgF^HT**Kpe412livaI@X zmDNu2p7-8;Pd(gtQ{>+Fg>uBR#H;S3wZ3fhs9QTOxZ#8sf27TSA>UdBPBuu;f6YMs1@rZr9&YFHDi3+jlCr>S>A84j!|V`KWJ| z)&uJ97N=2_SoI{kc+CMmdslzI7BxWX|M>UPN0kN866OUPevOt$tXjF+CIvMm4bUb$*QZ`zf!}+G%Ti77syWt4LBA#Lvn?NGtj_CQ=l>wS@)jZ zJ*foU<0&Wk?9jTM)@AkK5j}eMsuQ2;t>&nIjHe4<{TU!^?r~ei0;t-q2}!||5+0N)&MWj<1ul> zaQh&wCpWj^W6!@!#Cv zTaE-!C`p=M9HMoKwbyHZr2n5;E=HCnc?Ve1A9(E`GuTgH1@4l*QS zi2S$z=fBCu4I8Zn@Xfd0lsOCL$dMyQWX;cOr1Em5L`Fo)l2@0Qf~4!lmtTEp^_t}W z@Jfkhq-UgCYc5FCXU&==AAS6h)#8#S*t~VKHE!(Qdw)O~cI>K_<-KuP!Ax+q!X~8@FdDjDq-$uzeQO0p&z=Gj zSQpEE0|ugkf&w{`bwsWy*lA?aNU2k>9D~nbJQU^^ns*5xC}L=&DNfd1YZ*ik@XkH^ zgzv7~RgONG5vB||u0A*1e`9-j#D3s|OL(D&B(zg=twt`KzaUx1v#fRtnNaIS8zFL& zO)16~deQF5nn5Uy%iyrcBjx$w$O1!L*=?)BHD zv*rsQJ?=_Zl*R|`{%(J4-5Sqiev*()kNxk6D>wY#QDxM{X(UF?}CVxk9 zKAfZ|BfL~tcp&dCSH({)B+8SV`=}A4%rm9OBHkal(dG=+O{E$bdv@)SW#2C|&oL?@ zN@8MTEmz6k&sUr`A`R9LulMfjq0e*91B(vV2oVE0Q&(mJD!ijkYmcycLt6R?%?STNq;&ztF!S?KgQ-kHw2J& zZ@%`X6>5hK3NyBj$AyQU?h4#by-*1#&_v$*jnt{qx&7z=C4MDz;837db1q8vyp9^) ztPJTR>w^O1@a;O8t$Dl~>hT;od_<0EeI&?eDC)+I8E0KUwr$@gxp}$fNxt)&cMRN; zr4((OH*YorjZps^Z@yt=CHoKTw_c6#n_{eu88^lv8K?G~G9vQgl48s8K}g=izo+F> zfB4}Co71tXj9z{9Rm)GJ3@=`|Xe>A&bD@;u+^{~OPzlXa!qn7wn3qP5o#R4q09qAF zJil&!4Y^A=YRPTFz1mCB!8Avv914`KGhojl7aFbkeUvFVQRw6tc&v0DIeq%H8Lf9T zC(J#l-P*c_Ua!lL)4Cp6!__*TBi2oOX<0=l4qE-JUbWilvRH8BQm|ZO)zXfSidFc0 zpygocdH`o6T%7(Ij(gZ<(I8Owht?qh^=9ryMM;GsICm+fSy1VEnQ^C!_%$bF*H=~P zYp+Pp1@mQ$HUf^-P;5e6tenX?W8q6Y!7v5(OrJhoq9dcN_u_ZUzSI2nY3s{4ZSpj0 ze+7#Vt*THEczV#K0SZGI(6E`BMe>isMYS1tcaXOg_rdDhAbW!9WQsJ37KepdTSTer?#JDc)$ z_*d)H13#O0R`%}SD|n|+#lczYJ@5b_*8p9MGW5>t^E1fUX;YN~Pn$PKL`GPhX5-MT z_wicV&o~~)i7$^6;ycamdX7GL`i|$=UI+jXAqC4=q(J7W+XBr80H^%CdXH*FXKMex zI`sljqOhl+7^hE}Zr~g%@$kWOa1Z(XCD4IKmRP1mnyYxafpQ(@f5dj+ioqXK&(>!fr15H$}uSS0R1{?!X$0t{D##b zlCxaDe!Y30Fw+biI8YU2kTF2*+PzCwtX^Sx%im4=ohcl=%}eJmS-z0cm8vUM4?FAT1yUeSJyv~Y`50|P>Jlo`2DC*(=Ulv>DFUwPHaI)*0OgBm}(`7eJp*Zw1=av0CD5&K~Q_Yjc&OkEF}PgLItaaeD}>5+%9y7JH8;InSPd<^<*{M=kTxbRM1;quH z|YlbZ&rf_9?^7{JHZLZMs0> z65}l#yYA<8mdixB5vH7=NLdudv17-KZ3o2)^Us7a6Ksytyc^aU+HTR{8PWrCoEU!D zr?X|-u5HGSL-^NwF#kcJ0!pJSBPue=(5EQMA|)3f7VVR(%RQZI2u^w!22g~r zbCGZ?G;e@<28Iok_=I?)qPwPmA}A11ei0E7rlcoNova>Ty>P4_!Zi@Uh26L z^4+dz-L%7L2K;H5@Ao9i`RK~AXU85%9+_+%NxF6FX5byVh1tdYl*iKK2pjfeXla(NCh$`Pt+NAC{Ds7!r=K zX>@e7Sz;_CXCm_e8F)m7RBd#ew)iUx4t`6%*dR?7_qt9sp2(I=*LBTebw}Hf0N&5} z^7B^TN;o|_N-51k`iUQg(bX#we63b*^p}!_`|etmM$N$t*{O4Avyzu%c#a%3QX(QF zY%WpEPS}*N;N}m8OYB4yZdV=m^clKRvNb| zNKb$+A^k(7vtMT;2S2#)pj4cz5G&D83Obl-Fy3GQLSX{tp{>^JIkT+>_hil~BO9R5 zo-i(9Sim@R+km=m+tzJHzE1%^=>+b@d*Jolx_!%149-5m+F^~<+^mu6nrdssg*j>4 zNE1uMLW)hi?tLETXZEYIvNEAV2>mA^1VE0?Ugf;6HGSv)O$I)`Xg93d3;|n{*WG(8 z)Iuo7vE)dKPZ&QzdiA-Vy#nR=JRV{*ZsEDSwL$6Ki$NMS2DCbtMk+U^dWRR9)y#40e zrtDU%S|Nwh4q3Pp!fyCaApqFBZ?EyTf?ECH{ST~6qfYahD44+m2V2Mz9LvOpu8aCt5-M{vG=*4~b%f31{(Zi-l-L_VH|^g4?-!r^Lm^Ssz4lfB??E z{OaH3=Z!yGKK-rN-ZF$L3O6k+O;)d7ZLO;MsZjvi&Z*Os|fi;RkRs4dZOz{mW6!2%B8o3Fny;1Vt4-u=zH8aAHLkjH$? zAzI|0aX4^1Jo}2r5%I-^y2|khrOHGjf0lJLOR6qcnPm#hngwu3yM+TVNg9)6i;jn8 z4^E$3{oQ-DPETm*J>liF$+rQvpcI5!G}uSzrqGE4e8^Ca}cp-@o6y6FjbN ziVE$h)N#Wzvvob_(EpY9@{=!=YbPM9!3N{UNl_s-o?d9l($x?{#B>)h#R zy$*j^^@E%(IBQ^(xv6uF|Mgn6rw=0Qmkt;xUUJ|Vy_>gfmQ|}(NnU=Qh5e1yMlT;l zM_nTxGGXJXQ>Pjl`?{7Zoy|RK$`im1(IkK~wDoGN9O)cFUViX^!Ipa`7g|zQVvVAa z8F@v@IlRF-Pdfz&<6_VgvL&C%y`{`Z@uW7M_Mk8LbI!i%aja2{zS~$`<@kgTn~8>} zNF&iPW5-x)7&i0TTeVWCmNAoj*oa}$y|bs_);TQJs}nwPUUR=UApxD|^myEtV&)~CG#-VwH z_R_NIo|t~sH;{&S37JPSZS&!IxXSTYiS)UB*oYq9d{aZI)6K})rrzBNRSx5e&&#cV zzH)W)Sh@XQ{wUWKso7asZU(7`G*PM1IxCoEx#r;_R zD^5&QjMXKQD+A;O$0%rL@{-gr0?Hu=dFs?Dt5f8r>u=SY(Mkhm4BN!`M42~xo|Z{O z>alY@-8&QoJ0NU;%uJbSt*vUbrZPJ#+mtCvZ}P;+vP3&?zybssJ2E0tXv0MlXTUOp z2M^ZLi(68nNYf4)DxN)iwiV}(n=oE3YR-~9pz+{Z_(vX<>&2_3rz6KksnTc}5`X?q zF0@j;&p_Qd0aYQ52lkT`78v1UFV8xd|5Rgh>;$BSpL|TIX;m z(_iA^&a3YCM@ax6k5lU5gt8v>e)n%JM*^_9K%$Kzp*7StMQwK1NIdCE zJL+9^F^_Q3;zgQ!3zHesW~c{PF5jFhm8!a{@{hfH%1a7lId{EUw(Qs@8R;43nb9K> zkBvsb@o}EK8FX*FM)*DLP?{l8$wduQvhtMaDHf)LQ76A3-^v!?S{*lOoHZZbymgB} zNKWYmIn2~qsiu&iZTn&M57v<*S;Mj)e5AQdMUHZBq*Z7)1^5O9hxf(j4=dTh=YRR! zn4l;F0T@IBv+9*xEKZe?tC@AuGaLsDahw=!LD-j67o&$AW&LVYIR80 zZd@}93+sTTHQl<%>VN%LLny;0lbSk9 z3+T_unje2Of{1SFiJf_KiPS5*j#dX-c|)%ry{xoifz~AAgsoA)PI*PS<@-jAQZjB; z42Kj5vuWcdxpeuGg)-^uIA!t_%m3{^xZj8XMvomWGiT0}frAHHWCCJt@|mDslSU=U zz##*rD8ES7u3IaBaPSfd>CaMxszyO2BQ3)e5(MWcFrpbK#+;Km^8L#1W%o%;DufG0D^0e_XoUy4h zQ?1<_$E68!fpVmxWTT=Z&5Lck_jpee=e*vpwbq~66L2~@>p#!_K;F?e!&Q!6as_n; zV?^!kT0v1_mEq0!>0}R7CXKR^GGo{{dFrGk+{bJ9B)DI&)jMJFQS0YDoR(GIuem=z zLIU@~CBWU?(fTC7#!b1z;q=1_GC3z9YB-KcnW6M=39?=b_Gv^+H~ZPCvz3~yMt1Mo zEt@uPGD7i5Qzpqs^}K@T%n|=9)w1~d4F#<27SfYBO+vLkHzZCj|{)fN&4;HN{ zE-03@tJcc)UE3|pmNYua@`|*II&koS<*o@OLLE1F$YASf7^EOCh{>m)oo?5{wN+iL zlKuPk8!Gm?k`_>}3yHX&8pSBaua%SlVBLJBw0l_z&?&sXs-A0ldb+XpkSh-i2sEXL za>L7{goE$i1CI}40D46dnmv3}bFD<4)B^_G6A~O^?X>VHjW70WuJqNAG)kRXPLv$` z5+3!MAJ>={{_?_?4XI1cw>^x;28S>2xlJlZ!WrZ$x@g`2iX&UQgZ^t^=W_# zaWC&-(kCc)Vsvb@S*mwCYWPHZ$dN>+=4s#VeUhJ_Zy^!Tc}FsjSm*?JHpR(MRqD{NdDadmr=ZvOp>-Mci@0OUDXdzN)3sEeq*RD3yGh_fSEzsVJ3YLNEwEmWcQZ+X? zO3|j>w1MydRltW2WytCuS9=h!x?jwiIm>ugYgNG!_5{7ko&l@OEd4C|#BJR>P}HDf zscD43eEh`mR-jK;4-_V!X*{Z{t7Z4@-PYWg5*6g};m03Z{*?EUbBC}10|SGb#>%fP zdCm3~j1TgwTPE+i=O_M#k-k;{;S6rN&Wu^r1iu1K^DLuXk{Q;%PiBM@#Z zzTJCv+vJUij4+PHp+kq7f`ky897E&LwO*UMYB4Zu7}O$xeq#aLu2cW;miAXu57TlH zsv4b*UVm&i3^|SE)!g45gMv_zwfWNTO%9Espghe4QA^q#&qe~wU7fg|)WB1S6)&kk z^LsSf1q9Q*TX(5bl`9y)vIOzz`NQ_(Yd2Xjg|!EknPsJ zn|YggXYvFj?YW9`hK!#xcaAAeQVl3~_AdIP8WDPMu+>fCeYUHi^RqFrh%fH{K`r2m zv-tR!Oga|l4Mm$#)3b8LO5;p?>+QE>{N3>lXQ#&+6L00Jm6DU4V*>7ZsHaq1sF2qd zzou*&@ef6E;aNs%d_N#Cz$WJ1Iz^l*FDQ!upa2BM4hqa!7__Y7%f?e|I1Lxx4t{7b zD0G8nlg2u1c+I(gef@@p+h{C{R}X=7Q-+N5cK7>}Nr1I;`O;;9` zaYaL+H2yt!=%7VpMokzcW0J;L7YRau(6o(C*67NhAyQmeY~CQoCB^j^umS!7vVPrq zE7k`9M?Qbj_(>Lm+_Y(v0cl{pdHe0R1x6e?Za{F)nx;@61>3V%PuaL-qof~7mpgTL z44i{v^Y7trAfz&rn*{_^pM zA8Y%n9=85Ty)aOY1_;uEe?Vm6QQ;Dz`BmKx%;UqmMDcqMQ;vGiXHK87&vR`rFL>EJ zQr^ekZ{4|NQ7UqmC|eXYo+;jF&WRk$ub#;}W6x;R=ur|kEUwx7s@~Vs8h=Jk>=E|m z!y9N5$`Nl7RGP8qYgmU|1~Gc`LhglB35#ZCWy-hTerw^7g$oyI3#GnR)W2uv9;L+> z`Tg&HZx&;d^43Yu;-g5Hhhq=u-W$mUSVH{Xe&THESU2#i+TU3K){=4r>P)LyTXZQP4N&uQOl+BThBQk&Xd>K1&taR%7OSI)l z4qIJ)#nu=6qSOOYY){vSufF-pN*2id#m2-c*KVBvlp(JM@FiS%Ps#hS@e^(YSVM#+ zuy>$Tp0BhLjU798749%Gi%Zbac0inS1nri7QVXWHlZAiuTT@+^g9DJh6UH9 za~IE~xu=up6i#cKQiY8JA*c2S1xiTc-~RM(wlM&->D{-tg+?AG@F$&!Tod(@3as)R z?;%mbhn?q1UuRAEu4(626_Prw6jBa}oQ z7o!311H>MK&vK1ydK6D{jgAa~w|%D!^T;y-VpPN^E%i3B&P$^0gDowBbzjvWm5xLRcom1vc4BGX*>k) z!QUyWCj>_rA5wQ`1IAF`9OS;)q#ZCAUW~ndz}GjTdi(-&eZ}m8=t4HV2Zmc9Bwt8YRu(HRb~$OuVP=UAr5N z8|#njqfa3nHj2xNjp3&HaR+z9Y!MEWBp3rc=o*zX?XQ^ojR#0xx?-fxN|hN3R_g7wmYDC{ z3lT5oeRsd^_S`uJ^AE2Tv@Fk*deZS@$J=@|3`Iqybne#K_CAjDqywjc^~HW=r6hWN zO%3G9y;oINnV0X~VA**;^X%fKi?-e&ad-Mq@^|(C3=`(5tqHwG&%CVGIj;MP?z_x? z&Qqm*JTbNcG$PkWU&m`ETEzYY!w~xjh6K%|?#EoYu3oz;Cyt%4a2D1+ zjaDH|Krutbb#VVd88Uc?6+m-tI(o3NU@5an!Bj$y1=#)cl<9UY*Hx+BQUyw{NP0m6 zta?_1`z2I&DC3ak%TAhXtbGuK>W_JLY+x7($BrH|_LZIiN|deqqHM5@Kg)U80Mibp znHqAbdieIna7Smq8PRh|jTg8qqkj*YL`xvr+ZqX+=M zz#zpa*7@-LitjB~=-0!~a(7(!K}C`B+*unGq=!d@OXl%R*|B?vZLH)6+4KRUP)khr z3vd8_UHmL-!a%J604w83L_t)Hy6?a~GZ3I)OX>WcN5lapi72^8b3S+lI27;Bt)S(sla z7*As-jFlVLZdhBf+`L>FrFmg!{n)qn?A>E^reoF9h8>A#LfMxuN1ITNSW2L^_#($= zU9{C|=fP=!&c4@Zt_lmhw_1F`N~z>{0$9uP$@vL8Vo?#EI*@+Am@vqrQX9s7H&$}q$7J!bc+Tdl;@N*lg8Bx@iIXR6 zgWzus6JCEtPUNHTDuB+Dm(4z@UIH!E79CEC&y$a#U-X#ela7q`su2#G1^WI&(_$^72eUkkch}&SsIDn`c(!vSrK6 z({R90-uL*lKjWDJzBrh6&^8^qHJm(s(!4V^cSkl&9iKUb=SKH$Ja+!P+1r)(kZ}~1_lNUJ6sGet0ICGWtdi=z3i5L=Lh9mPE z#v*5qSV@c`ijgnR8_yl@5rYw0KJw9&^1xBeHDcTzNArd-dL&wM= zOh_+3Hhc=cu@I31AsxI1Hcz|?HbOi~!mBJ^?t}9^Y&iGse0Sbwvbra8drc3)Iq;TI zP*vB|>q<{EufXQgy?NE-aWu!w2F&Kiy}-MhnVBhhr}ON2+;@%0)saot&bAp?AIwf3 zv@?ye>-70rNs`K%zu~=i*7vfR^6UspBY%_t9wRw!?s)cl6dt%eCxm6=qu6dpT zr2=@HpdFE8K~aGf%JXah;uMt>+3$G$+#~bIk&(B2`T4&2srSRP;QE-8Y-pr8XnGC5 zr`b=Eei%U&Ex+hltgN z<;4c(4Bk)dnuTHS{pC;2Tb}AWVMhx;>Lg%sF>xKG+%Q4!O+L=+Okih1IbNENY#j_r2fl>E0bMfgJ^GpVf&=NXlfO$_lx7pUXa`@_-+fO@K`bS>dsA z>GodTR2VEy7A19|{N3^ay2#jI_$=4SbE&;q>yf{1ro7IzV|^M>LGJAqP%s-4NJSQS30|pK-rN?<}p6K;4*x)%AN`>c+?D*YerpF=|&3&?2^Zfb3Q$oRk zTBbFWlPhPgAa6UnUIUvvKXVS0iW#PQPUZ|o2W1qt=_7ZY(>Ay@eJsd==g-e~>OIfU zjB0(M>|B{CWJt;>&c~4B*-)Gh_>TKPff1zw8M}JbY73ome7s$HO@cth5M?hSg2Qzn zSFV@u{9~OugWnnao&Rj;OWZHd8HLL;NB%@TY#pmC8Q#ZpeuiPj3^jcZiivwg_I#Fm z@tnry&Un-{+Z%qx|0q7^8FIgzS1;{}M`vWELSrr>3-0S-!?|A; zep7SAkx}F8uxF=o;u?|FZ8kL>jbG=Oo%B5&kgIOO&a-ju&-pCZ;T-Ex*ZZ*h;C1fT zHgNr!B6(AMdd{vWW>wnUqbV7#=iYU5etvdd_gs%BBEfU!Z`?ay4E~O1#|F(>WnOa6 z&NVyN;M|Y%JNM48=!PE3nM2O~+aK@!582p!WgpT1m}guEU!0pSlr4%MT|&Wp*<8S8;ArLOOtU+Dlb!sR)YIx7Z zrq1I%_mG+Q{dr%bvu?fL?>vWxz1FY?sG-ChV=qTx`f{{6<%p26Kx_f&19BD>Af5Q3 z@p2^nh~*T*Bf||CLL8j9H=qG%rpO;WtHEMo0rBMyR|2jCTE7H9?EWyx)oZJ?qJ$7?&7t=qQBjvYHpc@mNV z)k@ysB}G@k{_ksRN4jOj!1oNNwnSFFVP<&_e&RT8}$a>V!sD>~Gw@Q&Jbz?x>NkEfSPfkjfsHmuC zmT&aYt+|JFCE!ZHm4GXO=OlqPryL2V0_7$l4ul)zSYykLd?WxIlKMc3DW-Mv0MBX0 zxusO8)5ov377QCY_bJcOo<9cilmhrFm2G#W8w?2xF@Op3 zb;r{IpC4f0Nr3Vz&-z!sS8bXAB^^ch);JxAxI3C90m^AAN-LzYs#3xRgh^=sP+R|$ z5ZS(J+P=rl-8PqVY?d@%;G5ZOXit-oks+|`LwOZDEY_&Npc`{N+2%bQ zP|7g*P+OLjrQI58YE6a|6vM|jckWynKYqNc9GfRrdpG4y`MLSBbLUPgpa*q1Y~(O& z8Vn!j<2IS6IAxpv2qiTaDlS;>$?W6VMuyI24h19>X+*Q!@#GS~Fg|hogt8p%w7Ok- zi9!)dtt6~m5NJR}Nqs9-31h~OF%pMI?X#}g_vG?_X78jf3T{m3wdf@Wts11#(6ga1 z$%VS3c@iLWPT_Zm7KW2Q9vVB;+K63I!t|oTA}b!plXOS(B*0vyHhABjeP(?lTew6I zC`am%tRq&i-@GHb?-MvUlHJ z*|KGeIUCS`B4saKR7PwaYrpwM0kYA zAZ71R_77M;V7+ih^CW=x0<-_9Q6sgFUxJ0K;WvdQjSd3z@AEZLar3UYb-bG*dgklJ zs*BQpV1G$TNwIDg5O-H!sx}6h)^R5-=PC*FL1CA3T#3=U^|US_;o;%N%W52>+8~-{ z%OSzqAJQF9Bmu}6=!^oNtAB5QixA;8!sAQ#6}WI`OrK%hg?8@TAt!TA8nq{%d06Db zRgO<2`e*khHXFb|Sch2TcS7z6-4UQsiin6XZ^tDKcshBLPlUFQFLDeer6tm&-i&`)>9C0E5uY5!S=Q;U9az z&FeQ!aYB^tD#s_AE6h>C`_rdSmu{W9NkL(O)w$z+)2IOY%Y@hjiH(g_-qtFO&=nck z|JACi#(?y&v$)FfVUqFH>k7odqJfB)vJ+^kAku}QzOb~=cps-sovJmLeSLKWZT`3< z=FjHk%em5XR?0JU=uqRbZ1XqngBt|-2dbN}H5T~k+|w4C3hNhUuaP^4FV(d>o?Q6U zT$4(PjgPek&)c?dld%3_MnqmvTp$5~0Vd-oKcf3ij0|{gA-X4YsCyWW!^7`h zNVU5f&OQ8l7>yvr^!)8%!&QzClZ+2vcL;kyrqR2O2D5ZW*t~VKfl0{gfUJB}ve<{0 z*QyVV6;3OnQ`%;VZVj=~v4&P{)i?D5FaDZ#L!lQRT@z?bJScpSb!Rwr@|0ws%9f!1 zL1vM=DBvf5NEjNhbJ431;215gVCkZx1>r%O83P<~$CFEdbq~or9cajt6D8s`@{y3u z*WU8rIQSi>1P2AO^hXU>IX+4{KKdKslfXWKa$~AV?hp4#00l`qCp^ZmQ1!yQbddDJ3eM5a6<`pW!{K`0f!pyf?3sj8YwK$* z+5rhXon2@l$9x^GO{y33^srD3QCLZRB&gBD6` z7>*|hV2rRdXutyp4p@YPc2U=>uiNVb2Mv5EprNJ9bK?=n}e)>mBIVvkF<#^6PvfL4R*ogLSWl81>0edg4Jh9u{%a zIm-NO3VBYOFB+@^Xv8aI?-&|ARHCD!t>HCFvi3%;_1sLReY|IpFY zAKcd-F9DL~Sx2(u+_`fS(5JWNwfq`B#KwK;!X?Q_%aF7~Y1SZ=hs7d*xu<7$?E|O1 z;y|qd&S7E<8#YX)PM>N8tiP7sq2WSW*$?Enu=28wXW8VYjhHu@3_0bV&Xt4v4;ql^ zhSoRrQDcK%bGl}f2te77bmQ(7&`V+yVhzFes0Gl<#Pigb3kdAkvEy>Syh7+jNI8c0 zxS}2)jhSg=O$Zg{s9yfPOs)ZHV9=t8Ccn9Pxfb1E!vW|tIDBxs^~^DRK|@kkOX>=g zq%|YHCs-8c=~JgA?Z6>>4-LWl_U-GTsnog3TrMsuwnzt_IbLM)m}G1GOkT1*4MLq+ znORnLMF*v>e!sM%VlRc* zf4P3`x;-n5Kbp`_o;q2=28KOy?z#*)&6t5aBv58NND9uW{o1y5o7L65|Ka;GBw~mi zjSaq}phPzOyg@c@*(et-U9jGcQzlQ5MT-_S@V(Ocnvm5cb@f>cAOh){-rjPJjt73N z=9+;L)~;PEMa4z(H^2KEnKWsV$phKbVV=6MRX?oKjsBP=)gvP#WzoV#GGk_n%DAtE zORiqKrs0)33r(@fx5wekRf?l&ybIaHhV>gHE;>%$eeYcf9S~|_!Gi&~v~|l?S-)Yu zA$$QWuz4(5v_yu*53`2LHP>q_H%6!XZrV$4fHIKKehEXbJq=iGP-->mJ(p^y`YoHZ zt}geCyt?RBnK5IAbnn^S#9^EL(JcA;>#t2gBIo{t`pd$F3neu*Rf2i)3Pd}6{>(;HaIrWeK_>U6O-&4kd+)7JJW%K6EvVPNgQ*bD} z31cV7>q}mfxMA@PEdhBidjzBvem(s>b&aYt`MvUdrR}rKSCl4o<&WEE+tx-(M?Jd7)A^Y}g=c)~zuF)#OQ&bs?3?_HElOY5eZH?@DA; zq(S7#E!>ILSb>hmJ*;1O`7QI~YH<^mD$XyKtLf`9M@AARtVB#cP#$WKeT@ZRy_i6S|JHiQEPtDLo46T>1= zUVnGq*Z8}u92-mIQNOFu2~V9XJ|`uGB|?~l2MNH&3H@QIAJ0B6dk*d~>*cL?-ZDgL zwifn&|K0bJb}&s6;u6ey!QCh1*U9Ot^{8{V;lH8yDlb)9KI=l|1?#+yp}-g65*89h z$^L`;B`+^e#*7^!Z@>Arm1k_;v{~>pckkM5`5MA~W@J3UgB%c!JLHdouD zQOueKd{|amW}#FRB{^Agh7N{+eE~;g_nzGbw0UFk8|HNv78RP24AafX5hEo$I{bb_ z`a{;fw^8`G=gi+-<@h90y7wLwS#QlP#%W(j$gBhU2AEZTN3;`&T8j)qr6;pbYK;4u zj8iU8@-hPl43u74no*)*n6*Ey6<9Em#w3YZeC;sr?>og~wyO|u*#Wd>8GO|iKOU*-4-;|1mD z4$+WuH!~JSCyy3n8Wv+4PoGU*kxw*N<={sxoEE$zN%8chpw*BzxGzrezOj&i(p zztlWwc)r^z3(YLZlP>#rI(11aPAS)^< zvfLs$2`o%Pga8%@6B2>~xPTSd;cf@poCXgXY+-9k3qWML%Fz=#f;KNP(O=>;92(d+ zP;yS@*v11WfdO4%d3m`-KQQ2^uVe5$kST`X`Ag@e>Z;CFci83&@C&x3u&^+xj;+?* zV~t$ga?wK2%vJUQJWC=WFbjEO2zVak9nTh=wQd}g$+T15XtM03K(FD6!!^a^;p@d< zV6ET1OP6;$UHxnmx^?@OD^srtWph=HVgPhE{c25yDlU()#t%9#S^pr> zt&UEkP0ql$?xF3zI_hh;>Xe;D<=>tMYZkgUtH_pN#)!(6jT~!}+DI0YJ06q(VgEWMnLrUDQ+{^_wRIitcnlEdHNM*h zrEjyjs$T*-ovV&iJaVGGk@f98 zETy6{v`B|%OKAAB%~|y@&C`VG#!Jo(Z~B!#xI6Sy3J~Q+0-jA9tHrT)tii5YL|3j} zG1Q+aP(26lA?ZwiK`f=tURKakUP9aam@~j4n@ZwRg*Wex`z7G_TwsIp_ni#x?d3yQEWivv&YxnLyay$Qx zsitD}7{h9K=o)9P;t{c-8-MbRng$`!-Gne8-zh2R-0{Ie_l7sSKQu%?YOmEA_cY}( z45D*@&5WH%6(f0I=J>N7?oRS+B&voEmJ18P*>JjRZgKFC!Ip!7006cY9wy(9W*(KQ zYgLw14%K=lcRVNotZ%cxbt88|C4>k2YmSGUE%}LoNca$&yA-mYJ#*IbJ><;kD_CApZhr?P<&GvKpmUUUk1?U& zY}j1Yk^%DKkSQF?JSNrE)wUm;&DFVkG}9Ulgoj5o)aNyE#?;Z(Yydh6K8o*8ao!}9U)c&j^MvgEf>$0WG zte79*&W6n!q-Q`+nK*Hx0i+yk$Fr2Ds~n$Jn(A{y!3EPopWc0}K8HiGk;e>;k-4+y z8WNCB8@u;uosK5yL;8luyt(rvL7VY5#l!lvm(rF#2W=hA^muqXlxk!h%alV04_O@89|hzytG`1Wc2FY%jAXE$iVxls=6Ylm8m5CNV*gj7m9y(e@PylY!Q!s z{rj0W^pHch>zB!Q=bXqfLI8M?DerRfv&>a$Z};xmYb;I>>BG`O^aG|Lx7_HLsY8Uw z(oUK#p-f}y%&86apUh8c$Fp^x%}7hPT5-63DFGQhMr%zq-GUPJ#c-A5Q%aSG286iw zdaXf<;Z!6M?>z{+Qp|q!+EwxI;cqp0SV-=8xCB@zB-;sB;k^K|0p#Eea=iQ5*nZTX^;7$KgV1o{C`XL0Y4?4fGpd4t};I{_O7V$LF9{d{E0?RK z;A}qdWApF{iMhj-Kuec^n{#aGPsqJKR|2hA0&oo<){Y<>H*S>3m`E8gXn?rNu@yhi zc690Y#{t{Xjk~w%O2CzXZzTZgklZodD*&Ytvh`&c%(r*r9=*Luz*Uaz?TNeh>q_7` zNuWyeLjcz3cuxy55XcTv_BmaGdm2{)Pb~pAtoqcVb3f=xzy}gg@C-mM0361N+C>ZZ zz4$pfBj{5AHq?Z6>Z+yv%|Pop^^Pz%;l_8{AeHRe-xZ!bD1pOrJS%728%gQC|NS2(=J#8)5rcIeKekJVN*`p+%$a7czl;`}P?rJUuo+7ju4kaY6@n?D#QAiM8%; zw2ab1Z-~#`;Yy$-Nx=0SThh~Tuch5f0Od$M;-CKXCnJjZ{jJ{{`;XK24^Qp9HiU*; zf)-uB>HZr}LHQGCH_BwroIWEfe^_ZXjnsz@Pe_#Lr;vKBw!7k3X&Grkn>Lgpgxe4| z(4&v?rGkP2D_?*}o(8qR^I?UluBw(zn>NYCDo-1-sHjL+IX=ZRa6jT(3AoD9xAJw5 z?nA4}HINZe5mxjLA%+p|!*rrW+`*b#tWk1p z+A=}yXU%`l<{GEy$i$IC!F=V#O4+h?i_xh$gwl_@e)sRL1fHh^T;=#YrR|=}mB8a9 zpkY&TaG{~0rf3Qa3uVieEfNzGBZMb$5K&O%BfE9+^uj}NJqZfb$rJYM-ctsK4U`ch zMhFdOZ(P5j1OeBLK%cf&ph_WO;2J2luDMoYsMFfIS_$nRYFw)*LAtNQBYIcErF6C8 zy10%mow`^~G;~0yGDTgsM$|O=Wk8=685wB}fgz1Y0i(3t;Yy&TNx)T(E$xZ8*VC>g zKwggCcEQ2HM&X9{btd}-pb{RfbF48n0b9^lzQ+efGr>a+O^=F7OTAxc1rr8bV-O$ zu#PbRXwsF-67MuBDoR2^LgakKdCASqHDC=MQ_|`TyHH+n+YeD2$&$OMz0QFSxXW zQPN;tATcILfNH`F0cSQe`@0tZj>T_F{4SejpB57x(SVNagH+<6b1$@%H$B&(4{NY} z+ERFY60W-e%JX&}exWLq4UYBm#<`QZcgSG=H=lJ59RJRcde)9R-qu7 zCZ}_;9tlyb9ats-oc)fcgmIufpm`LUzcU+ z`y~s`S(yLa+DLV1ej~g<^B!HUd2$zmeh_qnHAr}lh>%4p1zN35PEATCn~}|zo01+$ zn`lnWObK!o3!4QQx-ulC-I98J+Q0CW17Zl<)+E?&zXiAVls0)93A9Rp;@B!N9!~=2 zNC3hC@jB24f@2P~8$t3)QgWZ`&t=}X9{6-o39DcS^~3J<(X4CE_f8;n>C{AlMuv;5P#F9R2o+@O~~l0i;p9*?uF% za?!*JQK?9)SX^Ax-hsPv=j%I`S}{F6ttk}h396?D5yPW8H?bDTT0#WDE0&59&|Z%y zTZe)EdhkvI9lA~TW0d#HvR&NPsMEdn(=SvH9nrOm^BW2Hi~v1HpS>WwoeNGt9Wpd= z?G5)zPpC(OZr*-=Ma1ar?5xa8&sd#Oc#ROR7h8YJ(5Yp^3|)2e8A+=;1M9hgcDhIM>C*wk=tM0mVv~845kJp8tK>07r)5L?<dri2Ud%!k)LClw)RX?$&`7o&78|) zNWe=1Tyyl2Hf@nW69gbU@aXCZkh9-8#->PB^i&zm)2n9!Q<<1{9U308V3_5fmL>m3 z-VVn#5!h30)3M`hvtt_ETRq#(c8KHZZ>zGlwq|RbR|l`!PiH@Wl7L?b&~x<5E5Z99 zfm0BGr-%quRGUG|D7OJ|!xZYxTQ_BVY+T-rXtf=!;R;dpVqkp{d6Foge(TFy=INsN zdAKj^g?ZW_ftCnR99zQ0gGsFp^VZHOtYCD8H5{byf z-oB+`NuK}pTnaA=$6|=;I+q77OaDNB+tqA*4}mvG0_Q-0;&={Fc}WuRnt&AyNBgSE zK=8}S)C^}If06(RG$ufCY|My9kN^pg00~?$0`7@X7YqjfToNDw5+DH*00D|4{|`uj u1W14cNZ9`z^}0$<})pY`ynhw{C0Eg@_V8Iw6SOyRG+Lf`o`JS|oZeA$l(%dWp_i zzVF=Mx%d2a|JcuZu+}oo`OY!lcZ~6h($rAG#-PAJLPElZE6ZymA%RkW4-y0o_>P3g zogHvNcGp&tMXDa9+6BHqcTqNUM?xYcc={mQwhbGP+*K`?;t&#M8IErmd(% zxe|_;Z%le2!{| zmgko)?|rRp4!bk?$J#$^i#lhuh=Ae)=~p5DbMb(grFl6jDD+&qF8u!g{wN-%j;~BO z7@cLZxg+|2J%%4-xDo#4IkM7sd>1g)|Gore%6v!P8ZOxW{Xeh&&l`2=RzqtEFjoH0 zolg&Bkb`qHN3q`e$Nj&@6AxnqX|S*t9%KLid^OL9tu$xg_rXHsVAocZi~Q4<&$6u2 z1|1wP?zP$;|E~d1kbnr8HR?MbZa$ey>PiMsKpt}3NA1o=#lMX3_EBBj*|pvN_Yo*C zW(>>~H!uYe$hqUXERI@o-a6Y+$i3>Nw{L?^nc7#zw3k0-jO;n>CyErj-wl3Pdzw`k zHJ*!X<}9!&YxVirETsz&9jMiJe2f5RsR z?{=)tbi4L?FWS9j4|u$9I$2cqwVuD($q#tzxa1~l`0D)L_y5dec{-%+-@N_5u4go} zCGcd>*KS4@0^WXNOTu-b72mTtr`7{&^(+C_UH8fSuNHmts@(0C*^Z5woDILUQ}3@2 znpXA?TaOy0AFh682|GK9@7II~+Rt#{$yJ9CDZUZ8Ty!@u=|ck(OW!`D@g28)7NlI= z{%^i<{_Ur^)}s#lPoHa5s*K%pG||ZJ6X?gi@FMFbde6E`y|t}xw+fb6My76GKMy*U zU;XyCx{f*DcT#BC%i`~NVTj+=T7>76x-jZ`{Xyfxd^CHt?U?jqTl>{|OygQO<)}bm z?EKibA|yj9v3KRU?}Nmb`@a=l@pY%I6nx&7qd9Z2@bB;QAfHeq%Or?}^(Q9`?tM~W@6*i! z(ehn0i&8s-*Y?D zX6CIdB*@ZNVQApO7WS&)tse6@)c;GzO=Yh8sAwU#`-q@{E$+caq7t>8TsYQOUW?w@ z^%!oaY^QG(9=nr0Brna77o0oq_fvE<(6f|!edYrLPt|N0Z!iAZw12q7K@J|1yv%8E zTxhJ#M@#^Jap&oCt?ZK_bSuW#jx~sYFPJBw-fpT_-^h+JCPe3Fz}}<;RO_ED)@f-4 z%ZSbuuukD&urDUGQX|_!7@KJL05vC@g(#T7&^ps9c#QcsLLvA8p#>ro z9TRa{Y~~>`mr`1Y3i$K<{UY!4%#z&Vcrmv6C?TSXk*lpxKG=4^|Gus^liV$R5GjF zdyXYF<8Yb~z0Zg)FUh^!?V^8@Feh8P=;XIsZvvcerZcUxv!e~=^L>q)!ya%kZQyx#(zjrdAV~r;j*JY?z<;d{d*Rq`(3nqR^di_+ z>hbQ(Y;@V~V=m}xC`&C~q6uLT9sz#Gh|ogll!Ys1Bv01hQRk!7)qBM^S#wM~+>Ntu zGFxq~=FqpWpr?fYvxI1&fsjoqZMPBD%T~iR7VJRH2XRL4GFgAsE7c-m28A(+vtdGI z@{T0PL;96T(fuclaiKRPFYHO6MOVrMsp{YIw$e?dz|UlmHd+=*>pa!Lvhdpy=|Q65 zrFw+`XbrEG_O>_w*>&gp>`eVT3IH2zi6A^=bgsR_LLsCmq;*DUY-pby_%Cd0*L=~o zMHaRxsxRkf3U=2aM99c?C$wgd4^6GT(m8Yb2u9jZmMdWALMyoycT0&{Ov`8^h5K-?i90paNj**fYP~b0GlOh4FDbv!0l$egrG*{$g5-u@v(s*AdSlayzqq{5`@LTSGln*~Ud^NS z%qbq>a{HX1-RCGp83rP`K7!tWa z_LVtb-h@6CCAo9w?O`iV8DBhKV{hn233D{aP=4GgNs+}rzRyt3cuZsi>%(5f$KW~2 z0~@ZO?jqNb8I5XtivAa@zc;S^f%WMp1>s5e)8dB%i0np&=SsHXe|r$J8zB>`OG@>3 zr89txtVI}Q%du%me-0Z>X3`9ihT^y-^Xxeh+Do+Yd5kD8=*Qdrx)&zu!VL!z`A3jn z%wTJsu#UL+FE1oV15C-sin^n?Lz7%t-aft&D`>_&^OPX@vh;q%FK#P>#=j;(>V|~@ z$}G$P|5=CH?$EN8)|;e09+>1H$!RN>S;KFqC^t~jYS9-DP09}40i*NwCYchj3r3G0GQsb+hB<;P*!gH*CFH5d<-T>r3x-m!{LYpk~ z5sVreSnsgvvEoaQ-9wFNSm^2VtSzgwO;CS1$cVd%m}@;8bdaBU<7=-f5+hkbJ(tg92Z zBgQh8(7Rq0 zCNIw&|C6}Tfns0F+v~7K*uL$hJB7B^7PyGpGF%UEqeGo>|wxHhWa zO5dOBY*j(K@O0+oUdeRYa_5Cu!Zrke)Odu=&wVc z$@_5BF1%1kaX{}9Sy1E~ML6gS-8~Qi#X*qOMmAMLQh0wdyK*sL%MQS>24bT8c;{ey zwDt%wW$FhQM`De+$&b6xZMV(-#2^8;B_LxV?BATT$$zf4o8e#Gb~8ybsH-NMkn;N+nN12h(vX{F)(DldsDvduAbq$|tnZqAH>vf;bZr~ssBtoXEhFaOl zhW^9*f%-M%eB?8X1pRZ+U7=oy`W+Lw3pBG>F%E+Qu1sCQLmQrha^edNLiX321ZqhT zaw%?x$?=xVZRB>X{qJfSIT73O0vFtPi$U{7jof))l?Cg6Hi#4uu7+?kgYn)(Cv5v& zE|F4=yP8FatYe}=mn@UjgFClKO?~mLFD0IheUAy56T4_~_54Vak@40(>EjE?7*#_- zqKMq*lQ2+>F+42!)BP79B2oyD9}LJ>$dq{T`I$a<-0V%MhpNtXy0takYNl;8t^2uw z_mDwLt?zL=lCat`+9%Lt%_?kS&=7%?Y9rvGf}n12oM`r)BSJb}K_(lLxhbY?S)jG( z+V}imH3S!j>0J>s5S}*$6Ww=lqGBrNbD<8h>*Er#@)Ha&wHFd6@*!;m*zh^t!ywQ4 zhDj=gLT9|OA?{9zjKc}dH@*3WeB=ukPYCks1^A6;^lQ&KMm$xfHgJ9Sfcd>|<&S?p z+j>M{2kA|Rz%p6IBh72v;Xs`-LV5g({eG&+pT1V68Qr`R;~VO8CKy>KEB!@Fk$6@F zqvF+}w>=u)FBIK04wcD4rjF`RUkiB{$NdLI7*hR(f9Sf0vxk!3*NsVG_Cd>RU!YT{ z>;x^CgLoi zJ2Gq&Ig`?AOC?i*$4OVhIy~M=+87la<&jh|P||af*DaYw0omPR-p(PI{f<3%>v)QRZTy3{O@nV3UbsQ)hCg(k{njQ2g$T5f5Ra- zHvtmupb|G%E*%{o>FrBptdkE#NvI{lc|X5qxO2TLCkn89_$`<8iosAm`1ODB?g-M1 zYvuQd*8Ug|!vV9EKrJ%|jdqzaptiKGx_xTur4Tyk1k(CWWC4B&fyQ6EhiF^62@>nU z*YB6CfYiJZD4lp1lp@O46QVqMIWwB@BQ1#f=@{^_S)~#(Dxsgxw{}0~<5;F`Txl!= zK?Dt8{9U4csP&0_fn%29wA_DSVCu88sg7kL>)U}8*5yr!w?4Lnu-OaD8C2)lr(!)w zmR8dXyHpKs9>^ho)UN)t9C3mDzd4MoiM_K*1Ho2vR_WNGd|9b*yc{6CgvLZX_sn?h z(uF#Oy3u_mb+sCTSO0UzmcoYeQ7N>5`i>SFr@Ik^R14#nQwn~gwv|G(0AQA!8Sb=i zI4%t}U5gz}r`ipuBFt?4k{mTzSoM4=_V%n}`vYwOM5m)t7wi@#l+Mu4{>6cbW9xgS zuRcS^>{s*}OMEzq&gh5qHktn%1gAl;H6>>3^TD58lu(-c3!$f+B^*+(1ykkEOoFCt z=;53^!>^FNI@EfI`SbRU8cvvE2*P)S?uM2_hs3h-rxIis7_S-NTPTITK!x?$eP^@_ z`jDi`g>H%WBZ4HwQ{T`kRdXn<;JG#^@hTnSIEiNN))#OJ{)Wr4UEGf;4R@cpon(dB(WxHY44!J^`VWDmaBblIQi~9BH6vP+I2P50$QEn6C_R z7HY}1_jPvEc+x(Nm)K!=h5jT=S%R!fxPNC=c;UJ7|QwWrc6D?5ibVKN0$m zDG%GaTqTzmWr#+Uq`o9pTQ);C^i6(s*oHTr;_x>3K1Kc*h0!XhzhSnvB9f~mq4Ef0 zB^Q*Ra>Qb&Eh_P;b38%piHOpq0%ORrlYA^=iiaWN7qF?vmOrRUy${10W?i)qSS;gh8X^_IQz+G`)K`W7^8I4MG+miI z5PlnT%*;*)vW)$HkBX_HX3;A}a#xPIrz#n;6YE!u%fAs!m>;r0bY=()nb(#7Wf}U` zzlH46h>W+DBSNv_I6UNyzMt)aNvy%6_iiLFnccc4)MwD#5WZh{8ba| zzqEN$`t7CK&)%QfOlci`#+`OZnshFbn3)`Sc?s?VPBLtQjZ+7uU%veHG>2FWF$JZu?1<8#*rDRw;GpePX*-zPL^I-eYpsWK{2g^M>qL2}ITUq%97PU2jr zJ}QgG!*A9qi-%=Le792V;#LXYi4BbL**vvOJmLgrAmr54+EOn;=R!;GrdHGMA8wBp zfV7NyGQO&QQboa=39<^*L*@X5^nyh%W=ypEy&$Sql4n&*@F~QJ!GL>5dpXS__Nf2r zWaA*{8MWqmB(p5snC~qtT3SEtx!cVX(FBb==_Y)EH9d%NqS-^A5^%pYpD61avRp=w zKna>tklog;?wR{aR@0oq45GMl{L(&*hD95orAJeo&ycmn@PI(xo zJ=a}L#ew*4fN*fqY$j`n4TyQ}lT9WhN;w>_c0o12q%W$Bt0cwmpHIEO%^G}5`DshW zZG(V?tf6Rk2%2D%=WWe03NQ)Gvp0XgIO9s+)qGWVSqC87Cf&rxuAE6xKL&uw-+7Z> zuu6gcP0^hk!u~&Lr$bT(nY8^$K?s~U&!GEk8q%O)l{>}L*6)lW-Bs~*m+W(Zw3L0TjV7xis z)qykZ((dR~#qPA<|67n_YkVti5)q=o@)s%3bnic~VS)#<5A4;-3Pt>(l7_qK5`@x^ z1UneQ?Rsqqn2+&K(dTqg>E=3zjhZ~w-FkNtkP75$?WrOkzOmyL0D^Gs9#?8V6MZz zkH2Rd60___6lj%7o-PR4O)_Nc^4b-fZ*^o0)NPS6;d1xTH{)(LXs(CWYWDlIK2ak` z5f{Vco<6kk@V2?WByT5_uu`Xl9#zE$$!AvxXHq{KpmCrxZEI=P#L}!$6mKMn=RM^D;NQ09jW5Oi7kLn47U8)N`eM zPb{-T&H5XnN!yC$U@N@`{7|l<`vON5mAL<8X#Y>~NaO5}^RkL>%S}{4Sm3fq&E=we ztsY#lam|-Vdg_8l-&{x~b@0&{Hz>hJ01JUx=2(ztU?|Aai?mCB9KmKX4Oe@e0%w@| z%@gj_alI{rIUqvC9?+Ab6#EIh+`VVIYd_cf-VNZR#ujsbk6~|pOfk@G<9*6u;*n6u zHTJJSiT)vzkyybZQST4t1x1qNSWeV`_?`h|WJI}~^#NA+6`E+_aC}wU$%xQ=zeBQm zZ9a_P9iLUXb&KSEJ)BrOwUvN>#{NrY5%%ym5B_8(dfn-P<)kCWO~|TAoZXdpVofyK z50LeAodCCS8+_ChD@&nQY;dfoP@b@P$#WrWK=2{vN_Iv*BgKGuVm_JNWAq-M=_Gb+ zQ95aOZ=SvTE83|J8(08Xx7F-K;e!y$bNpm^<=z~}&l8HW zv?nXx0FQJ4RO}>uhGKQ_#~ej7MPywcnSpJqaJyD#(`0@X)6-;XQ8!E49J@*M z%dz&SuU>Z{z{pLfgL^CLLlceL}xsZmmYBll9`*YK9FKgX;2s*dk=skPqOvQ z2yO516;K}QRUdeSp!odKPGZ{7Q-BhtOnvkCtMZF%HlwGGi7s)&mUkydKP~mXWS*80 z4TT+r7lke4A1<9nPJ*;%weQ>W2>Z+liyLT_qS%{cnN)Ds1V?w4u~WtoFS#rC=uU?f z`*~cy6GXzuw1rmrbq)e9#+ip(@yqm6bpjgz{tr_Cd>-kVL+!Mr0eVi5N35O zijhTfdxCmm4bZFF0hK^sPR5*#M67W5ANI8ru-D2-kkRypIpm4>AjPHKO$3j50R1Lp zJY)u0+h@w}5P<}+>2ORSxLMdTgOa-_Ci^)kJB$CAUIStbYLXa0>bv9^J76Wf7QQ}4AurI%;_j-=8#PEtUwP>ivr@Q0MCf*0dWp((|B*j@~xL&$BYKcSy)Na21I}lO#6mmjWH>^fU=(|6mPwEpUjaCg)B?ndI4)j_k-E7 zrO+r+f8aoYde5`^=vMY`nR8-wzGzn+SLiC^3_SgEOz^%ghk!t~A)XCpS_t&!&MVUk z8jW~qy^i;r{Yx9);?CXK7_O8WLSC80af+GbYK;sQu0-%*fYU zywYq-&9&ojnP)O&0lG>S`u9K#giVFq|2%QQ7CfPu#1v^%e}&9Tt22#!Kzm`GxmJuU zZxN+WNQn24Rwek#T0frYG|RsFD?l@i%{SPS-i48M-5O-m63DCwymLqVjNF{k`(pJlRz+B-~Ewf+G;cz${9&u*$@PxY{`$*Amj_dU8}XX8h*1Ov0u z%qjTj|4ARK@B?dPPRF^lO|bY0Ht{+c>eHUcB7RF{sI?=TmR9dB(G~@~ps7dMz&29W{ehxkR7y$CrjaSDqNhBq#%!6%;r8xeInT(g1?EVMO zGVoXgPH4qoB>l+YJ4EJY+*gKpxtGQnvwV3(+GMTA)1OsAr^W*#m~+nap0b9vq3wPE zqf8$-M`@}|HRy`LtcPZ#RMa{_O^1~PlpGKWg?r|voY?fkA(-Tf@}{D=?tmGU|_Tfi4h`Zm)}hFx!8p8B*&k_d^k z+au>J{ET0ufz)Hi4fNxG@Xg$!Qo(dl_Be!Q!KN;q1A_hnp5udy8*N_$Bp>eLVb}C9 zJ6@2X3#?BqgbC5r1kmwQ9(fk>?>9Ew4_kJ^yRwjd6#b(S{q-f%#RKv@6(27@jwLK0 zhW{ATT=sY{6r8xXn+}D3!Rljr_L;%C)EM3JcmBiI^5&_J3Gk(C`QVR{H|NYZ%t{3( z&_Gq(YQd|}5-OJ&U`=hSC!ufd+wX79EWupmLxJ`M=6Ou`C%y13jJq zk%{Im+!33C^RtOJNfd3*A;iOnX2F(`-n$z&+AkyGjg#OEuNWmK3TE&%hBV!10+Z{% zGts=U9W+K;_To+k^s!RAidfK&Ohsb|Q*!8^K~o#ujgy>I>^550jaBkS?F1 z;4JT(?bQJvz1|eTzoH#e{~>&GAh7<(dL~%JTYOvg0j*4uBKoNE?!~x*3WhjT{J4qD z5#GV{d#b5rHT%FWs(hvTya@yTtgi_vG_+vCx?8{&KvG|_`Rb=Ip$_qZd3c12=k6pU z2SRK31hTLw?Vsm46yEd$T>XwtB{m&=R1)HPtjAb|K0mnN#IHc7oBGbdOZkdW6x5*j zeZX>r)*ahw#O1W^X|^c9$L1we^b=vfu9%(~8I2P-)r|;sy^}98xno8ThiclyPTt{_ zV)HU0BDyzAC{-}!Prvq2V{V`PO>uS&Bi4sp7PEmJlf}6dZHpNh-y2gZ@Fu@}e%f-> zacgw6+%A{s z1p1$AtzPjJ=`qNN{!RozIFU+{Aqw>|TC*#adY=&N@plgLmdVkPe@^SoM#FWrAF!$z zY9|yaD^%9Hx*nr+VUX@r_X>D?AU8v@M+m9fYIGZJmzaUE`KhS#ppXWpk9Is`vU4!& z;NWJy*`Sa!hNI(g%@qnjgTR*X0YddXRy(RvK>-BzuDm9YDZabm*Sj9`wncCpjejCX z3&SfS!A%4sr=44$ko6IH!^j0QGe$S$Z~XRchKQxht*4jms+G*Ih zY30svd9a4x-6?GfW-hHh)}F(B zMsXR-kyv_4{x^Eo4-Boi6)i*7BNZzb^bLD(y5v}$P4eq17TM?C~T`59yJpj5z zCm{LmoDOm03Ny7+bXyef9fDwNsrGjP%k9ZH2 z)Vn{L9{_pb;P@wQQ^SmrsW`=p*df+Nsk-B z`?~#$Yq002_?h6`45lU(-5Xi}uvo<)O}7BHj4HE}uDD2aj_#O~RW(BPEf71i?{R<;wvHBgQL6vkjpR4_}yV_C^7*+Nty(}y0Y8G8IcR*1GoEK72Z}{;-XGe`_B1dFkACs8W=h8j1 z)5G`6KkL5@d7c`D26*zrD*&J6_Dhi7xzxlfRrbJ{u^hKVds`?Kn&hLW2CNW^1^7@a zivxqY`+M)0)GfzVQF6A>H_Z0xl1IxK+CN`2LX(QH0CLQwnR^iF^zwn#fG`D|5*W)m z2e3$lku=i-EJVm_C29<;6a6Q*5f8!}%`f7YE>pVJ00kU7G}*Wlp*{+@%Wgp=x}?Q> zWQOuNnq~fNf%x_}Wu6hBBkYOLG=IevCt%@aiZHOjyxBZM);x2%6|a@aI=)usAQmaz zAzhqYTOmlH1n~)JwLhaV#^2mUo$}&%4C3DPD{2&BZ&DXd%&xf0m4JYk9a=K3m=O9I8Y)d$VwM2ax9|&5EA7U! zj`JKjR-(QAe31*1?mU%}_Z*T$;z0~hrvp=!O==qsAFC!5LY zcHm)M9mx{HXd`!ptZ){WK_P9Dvp|&1b5^u{ZBGc#K=((kczmnhU77oM8+7wcd%Y5B z3tHooYfPkqJ`VK8G^!1~?i&=G+pHgR2qLL1s~YNaY;XE&z8-%2J2NkjW4_r6vyTp7 zHWdGZ%jbW0#iL)F>(6u(XNDFa>%QSRhpML8DqPrzBV#||1+A-~J?;InmTJ!lM)UvI`vYkeFsBNv^K_F5Q6U8cn22v@s6#WM{RXejCPiIrd4kEg0S--0Zm{e7hl zc;9ypk?{ej_(Uc+$C?O*P@@4|O9{mGz)Z1e1qppGy^v_tlijaS%T5n&)uxW$Ia7X6`p zCfYAidduZnTOT8uV0fukfUx{5>}pOSAxk}@L`||*f}25=%DB$5Xr(x3B#B6luVL<> z>63djbyk^S;+cMulQMp3;h@IlAxTk>>Wq1(D+Tfc4V)hhYRB^9B`7gwzFk(zp#F2g z(odo|cqVG{*^~L>jvGBm6maZ?bXqlb;HibIFi2%zxxYD#2dttVZ)9q|!SLMCnQlbF z%jmy}N*_kB$T}F5_ZlI-1mnkrYi{4j`gYQ5(%_k)p;vTEhj$fr;K6GY>IShMZ1s$~ z?t;C;b|O(sC<1c&Gwq6_dL(}GTZF$!Qy-s*4L#$PHc$M{j834Dbm`WE$$pxIneA9C zlD200XSe1Ze4wcSvJo5&el(KjL#V|4T4Bo_ZwN`XRv!EwGCy>~5oa|K?CysAg2?M= z8SVpBX1w@bs*W3My_Njp*RDNr*@F`SC)YtdV4_AshB}+`LSFLbWt=dq1o83j2^%Ru zC}omuDKm!&u+Yi7le(Kz;q&ARWC_RK-FNZ-5dQ8a0-gN3)f)Vw#s022jkM*yowg;{ z)%JYhGbIPcJ0gX{VX;T=!GmCAG!f9)MOO@Vbw3NqN0DmhXp#`Tc3!~mCj`x*B})jt9=G-~=cNTKLdk1Vws$4bla{_65L=x!`r)#AzD>Su}O`6e)l37KkWx>ZabP8XYa zm;c-Ivs&`rxhI$LakizlT7}%A1B=IOi~A1VK^$w&Sga(T{Ab3@EJbY`83w?xO#!mY zfKAyzr0kZjhPx?Mi7>$_mRq|!>poz6+!ZS!L)RYSpWRut?Y0`wt}qhjlrY8Fh4)|z zUeItJIZNhqC3Cd+xo2x4M)LIttnHLodCHjHq@bkDA6R*FlkdC#)mGW1happ}F!`no zrfN<;UMo;tE`R?#LTBABri;4#?&b1+t>lOXX@#%iVPwGitBT7$8on6ZL=W%J0$H6g zgbrV3i%Urd!{zZW%{!G;z1O44%Gq^V_@>i+N6r=1#h{#ZtP!S>IOzeOsEm`(Wfk^| zR@h_$AEn(W74zG}gE1`>#VC7Y^J2~{I^eyTYRN7+cvCn#L6n3`GZ+stA0oFhlkGjQS=DEVYZUcbHVn9rOyY%S3n_LiddU95G}q9 zjI|A#n|_nq%F{WURVhNuzwXmI4NJ{H>DwZ<{OFrqP1@Tkq)G)ZAuxgy&Ti7$)>=H+ zGGyC=CX_(u;-rs;1_W{K=^{<~8Y+FX3cDVjBa@!ryVsVoleFb-S0PWuP z+4Fbf@2rm<{E9k%T`)li)Y-OuD%a)DgpGbvp9XA;Fw}{;WmVk|`)RQ7iTa=}mh>EseDVR4XhD zpsQC&kBLpbE!zm9Hns}97u=Tnu>4noMO31%4ag&}8Uib~03n2uu< z{QJk`r6{*|6EL$u!YRY~Q{&*v2^^d3@MG5Q`w z&Z3}eIizGhrnNnAoYnbS?{7TQ0b{9{=?0x-3q0k>H(WtPvSK#+Ch~HP+svt;Byo3Li8Sf*o34>hnfG(7-O_XZ}O=eD8(FklxlAL~W zD)N0ezC434lRMRTrlb1{>*dez?HIJ+$i8s867s!96M{Lv$G>ow(fmoZtl=&2-?ode zIaZWm{~X)Km2j)mUpF1+Lb}~rU*unT4=^&_zS7%qaUOsF$xxo4x$d_Kyk6ut(7wh9 z3*-%@Bglwib?ldKvKh;haVO(sW&ERWxH9?pYUt+g$*3skf(E%hv}Bq#7?IVGq8Rg# zNL76Jui|4K1y!FbUZ=bzN&us;KW)67Obnc1GYVrn(AX`91?X++5YH$PNl&uS-Rhdi zGnAwloX?1uyk!6Fn3VV4&c^ffpY>}6u55O*zK3zTW@Ya4hxF4H-~Rndn+rq#G%IM9 z8VfE)i^gzu$Gk(n-@`%`uLY6SyB3FAW=8z=Q+Ib)uu2e;j97YQJl)?9<`?SX#*Bgg10B7)^BG7Pyggnh z$NnL(0^P=gjsTt%k4rR>W;~R2=VZ&s+M?{FI;i*8)7o5ipswB6IR|$WdsmkMCXif5(598mY#h zKK|4x(og3xKwi(w`BgKR1EV{MDoLbViIXuz^darnAdp=<%I#rMja1ZxgcGVWPzb#lf)eyOzkgVsYq_tkc zkd#+*UUa10fmb$sQD*6HO$tys83x2P#Yb9o;S4XIRh1eu>GpS=-~Xc)5Cdm?{`Lzi zX!igv*xEY=IAQ=IP#*$An_w}aU9b6xBOY4Pkx_QyH_RmRLyix>TH!3RMlreN)8OTr zjrUJ%Vekq(DJ>Z-RDgzFDIV)@xCRpntr?wDW2D;hhnR%?X$7O9t$M;U;jUlWAJQX#1O4^NgEI_<`o=zb))hPU!Q8@69&`ZAW zcRXzFsr7KbgWw23KkkD6ox|_pdgqz6GTSDeXcP$_=ccKgc$5%f7x@Dq!$GduuGKVg zSq1QXIe}7V2qyImhl*_SO-`xpn@X925eKzNU88|qtEJ9&xT&tjhA(go@=1_2_|Aj0 zubzMCBnsLXE>pwxwlk-bj6Qt;jGv4ZA(`F zrX#)^zBcxF7%v`dh;*dCr`dE{GV;c{izZ2cJkw8x9!>!*`u3hVq7ZE3MR2+<4fny` zTOeqYTh$P-BTSqFy2=nUAwnvgTAz%D{fC9qD-V?Ayray-4IYvc+ACT&vdR-5oD=&$ zuIORA*l~{~X}ehD3fmN2aaxnQuc%g(mVDDlDoi$tWH~PHvX0xmO?#y#g)_M7AH1uC zXyufC@>D7)0lwb}=q05Xs8kLqNiNr+-ajK%m2o2Wx&36>Z5J z(arGyG(v>?N#N>nzX^+~sS6D_Mp1}Xcd|)evdf);V;?h38ZAqzOzHnn2qF(1g6szzGO2^XEShOy%#&;b2+=cSwI7=SIebE3fhnMY5U@;r^J1{RfJOy5?bv&Xb-k)q8R%<>6pV`$aHK;nvR#Q^ZYwwExhvCwz#kITi?;EsC__*R?}!?qj~2h3mc;4`Ba(Qp~nS5eDa(u zfoH|2)ej^yN6>a!tC)t}V%^rnYQ79|ARtmwzI7$tAb0uO#kgx=x3O#BanW9P@ocNh z0PyyyOx4Coiya_dB#%j$7VagA1E!3)D=EOzMT_K04kV<*0~5e8{?kmn+#zp0A3!BsOBZ zaovr$rUu=8iznz|o{>*B_7dXaL6Yvc?^4Pnh77ccx(mU^Nzo1!bT>N$x?Ud_MNBk# zC_>Yu-W|+O{{tGXj@xB?OnpxjvU$v9%Ry;yPoUw}sugI>J@|0X4P!Wwd)&@;{!s_? zw<~L})2nT=o zaw7&R*s|`|(?|AufA7>XZr@DL3p`HgzcvmtOUe5fCg5KeNqAq(^Y@zM<#-m?%PbZ$ z*VhXwgB=ZNOr1Ld9KYUglXJN5UHNV~@G8EV({~`{+{D1p>O38k7bowWS<$o6zE}+j zVANXug=x_4MXE$g2aA8jG`m^(I^g~y4unZ0V>?%CMQf+KPp4q$jQT<5I9h>aphJe3 zr#>cE{5?+U&pf~frul-ZiE*%h*?p|XR;Av*r0(YbEW`$o2YiVnqJcqOdErhrkh}HttV7FfU!XqZ~5PXGY!*G1AM4=R$WB^ zFwieLHqI%2wN(w*u0`|%9n4EC{6j*1OS=9&h~B9e(vr4xfNPMe_4o&-+~ZtR56P=g zsqy!258BC8I$~L4vfma(3O^5g=^1kc50W9H(OWkqNSrEXl=>GTp$_8FU5)UZ_2&Ex z+|_;wHo{o1#&Bx6iJEh)C5U|dr%s@LAFVilO$6cZOtBgvttn_Resxr7m6gr8K*!6U z-e6r*Q!`@xmk)i9(_WF_{8P0GUDuRedOwOvOYh~fD%wgkV3iTYKWKbq7zp^}uhJ$b~}CZ~tS5^cbS(NbCqV2 ziq<*zP)nS2Nc#MB<& zzdj)10lsuecc-*;cc(NGhXzTdLmKIBICLZ3ormrY=|;NY8Gmd2*Ykef%sq40b?yDx zRXz#vrPU1kuk-m1_nAx(-+cSEVy~F1a2XosEVfe-J5KjszX3gAHQ?Wx`{xz$Vy7RS zY;(U-IgMa2w8U{nl)#02_|x0TcWSCA49X|>3-!z>dM@X&h6Lg|V+gX&7k}*yevcXU zIo&(8=RSHbF|Iyl{QrxN-b?t=i9AzXq`U7XYKxWhjJ8Ftl8DK^oGhmpAuXOtO(6#f!+K5t& zp7UXdZjTdfBDiF|sCy9~#f51Uv{a%VgK;&BmdyHF{`wex*}26dPJh-Gb7}U;N{FVm z^DXmqWL{bQ3A*sTj!F0-ft#R(+yAG^+JePEo`4c`o4v&;Y-7|EeLKdNexEJ$R$_W3 zGsFL;e^hjf!K6_!36mzRhA`~F6eFLCDxQylcVte4nH%4TS>rzX=~D1Z)iMp?vnU(j zF77VO6=3T8sr5+PNv4l48-JfXHD=LPET5>+-|k;hw*3Tud=$GB&1OF;;ODz_)01v zD`BH5sd?TWyY!V<@<0M|#DFD<;DDL!aqRqF;0>~JAXLUe?nE&3c+vKwmD+HRQPdz&Y&jXW$~MO zg+vKFe}hycWTy{Pm4JdX#<=d^`R~3hS92y@;xQ$%4VYMi{n=P*N7>2Q5S(v-7P|G_ z+IORaW$Vi)YHPw;54-oyJVI%fYlnYnNCL)~QX#A-v?-`4q1q7ylvEmKCswA9szCt zU34pa<-hcHCQ}DlIH&As{sQ3*>^q~mdL<_goWM?fVP-Ko`<-tESoBCgmjLgRcA zP196koeNcgBRRpxx_^%s+Fi>eSU;U)>lbm^q?>mos z_8&AuB(SmhZ-DwYMsCWNzTb+G@?+?*Aox(h*Nrpg-nnosae4#kY34Qa(3B3FH;Q%l z%IW-IwnQDoCzq{WZbzHYFSdNX4VuM(g|iJ^9Kb6qjGCkBALBBuF#Y~~X^rkjBsR2; zY4M;(v?m33qXw|I2;vjPVLo(#Z~c;#j<)5P zCGRERF4hv_dck;Mw%p2^-VSjP)|~w%ux9<|WSuuW$>+z?(|4mSGAl#vX$QPFy?9gH zR9L6SJrs#4t4n(iY}q_B?&>$AJm0Z4^wjpg#cmjx6J+b%!yS;Ke0r;@aL$ zXjI1;uFlsM^&BV5!?^{cCaxLYy1-A18p9DNSO;eRfI#6-(}-*oe1{)lXecOA#O`Br z3s_>&3j`%J(`9bN{r+oaPMwTLviym{4chxQI`$=!J?Im`6_?G>SDN2DE&2qC)1(z8 zvKTBXmSTuBJ#7X^fN=n6_9ZK-OM$HG1b6=ou=aeCxDf;@{T`$p1{K5UslTzHsW7ck z$z6D@au=?5$KZ1>7R-Y0YrYasG@-V@?MWzlx-WA|hsNk4$4f@VFT6?A><~F@E>DEl z0%Q0|{Vp5Y%@oHc_%~A6ti?!;>O3HGOzM~B&f`-JNoT4hl|{Dt=|OO zE+Th`E03Uy)o)8?V-?#z<9Wmc-O1P-f?~cFa%2kW4q28=CGRWW@Sg6s^Xd7d$K`g( z>b9emy_ha4MlWl!OFWaGB*RG>EV8E1#E&+DsRZzJj|hqHv>zA>rOP+*=zaJ`|PD~oc)&7jOy>`102N@^p zka?&ny)X*FhLmZ|O1~tCktsS`;iH}8v~8Kj)7?m>rDisZi=n#8MZQ=2Oqps$k!qi! zp#%8WGiHA00eAgjv_HFjMR8Xu7$a0x$wpZ*(Asf1%)+7-%g`0eE6ylRw{Bw47->GU zHR4Q)NKYkTLD@76Y>3TCIcQB0iuUHGi+~aRWC^-3w_Vn-ej`A7Au~Yt7bNw*R{a}I zdw>uG>&_0~6Ap4tN9T!N&VW`ZXuNqZ&8DZBN?t78nsbwR zXH!mo#4wKe$Yrg;RuLmdk<2z3Gds_f(2UM-;sctpXGh$iW!^m(J~phWDkcau-8EcgiN+xfLb&y1~O+?xVJzfye7VgdsH z{J?m$zmiWW@a4Znd_g|h&`KGDhMvZappgd*+0E= zxi)QC9JascJ#fs~W6^>t;>vL*{G)e?c#FZzAe7K${n!daKb77fPo2`hd|||2 zT-`BPc5vHG0u$$h2>wC>;^*xA zdR~S51MUZ{*s2oB*#auBp#-O4mr{C%|Eziw#}4nCmAsK0ID*;Yz8&R$M=)} zDdD#on}5HgZ;ye_Iy%BM+a(2x`}*q?fID688Q}~WuvD1Vk<7g>w)BSVPzt5Q=s$|} zXW05Ar{47pW?lXw=6CyVVK7H=xqw(s=2B_XITt9d=f>Q)5&OfD{RJda!9(3enpM1~ zjJ^L|2VyCy%qK*e&$Tk$U$XtE7ETjHnk05`LI902qSnTPcH*bi>>EpmwhCqQIpjVC zm?4CAuF^1XWLGO%J-p6^KHs2$X;Ijo#B|3v_`+=F&7bkyskkPCTB&w0P$(WqhTrSp z#j`haKau1d{9PH#iXo(+xsG><#^3vu0c-ePSYbBSYdoOPDb*a)u7I6Z1BvFFRZxN; z-$j*%h$QHQep9~ba=k-U1D;F=o);75Ctyjy6ida8`b{d2CZ8MR6C;i3>;8!Oq&f41 zx%ktU$}az%=Z|2MFQoux>N@@MipU?6lFjvKHijt~Q$Ixv!WL?5|9K}yJYWM=DCu;i zv8p@^ed5a13jND>D=VTqPMc0!F&auys`|;AvG}2bzh0IK-Bm+c{al{6#I+{LqF0h^$$&wePIbB^ z$eK#*)w(3@beH!yIx1&Sxtp~W@rLo}n+54uFff>)R_D`&ULSwHN*kT{-L3z$eGyPG z#m7)R7R4)O9(fjrCK9~OFlQ#i82CmY${(YUEcFwHMdIc0MxEVnLmZyF&?3OjOJM8; z>;J0vD%_x$Gylhm+0!UQ`$M9iL_3alUcG8!)*#&EX-dCn6Bc1fY^n&RnEZ`gu~GVW zW9#=a-dYSKGSoha6K#xQrHf_GlIz?CKDt?h_yV|lwwM{|kS6l@oxt+ggH@gSO$Yp- zh9S~0Ep~O8ET1bMITh60S*}ESKNpJF-CQ(^fqZOeViWP0Rg;o8HC#JO;r;0A*k2AK zzg01X=I84PD$UC!2FGiaIrCxzM{L12uiqZtpQMQssT2lX&ZcuP$S%{0?VMyN?mwBJ zI1NYo1(!=a%51r1E=Xh@?a~T5YN{VsmhtHkQct;QdR}#Ksn*JforbN-A+s9vyc!Vs zKZbVIL-X#s-k}8&{QmuRFMU=TIGT@YvUj2;jDcQ&=o6QZAHe2AKXOdFU57Q7`D3J$ z!f6BA`)8Lm&TN;Fg}c3w!>EtHPSL2*3m%}+g|C~>Rp6x;S7SGU!FK^ z20lLEM~TQ{nqxhAT%-80(#qCXSlFG`-{I!>_erF)lGMhG;|atMXa@ z5Y^soR5_tiBN1UWIl%>EOE45z*p#d0k3ZNE`CtAkvp@JsulGv*>Pq=!DmKggc?PmU z^{pH@DC9czl$KR4hfZ1jh-Q&9WtRLqzS3`tPd}>UsY0bB5G+D`srh=HUS1O|^ON4m z9eT?rEh@O>ID^;`S;icD5^zE;kyx8Kmhm5=zIq?3Z1#i&=zx71x8aXa%d1g6hu$8F zt0A(&(K0F8*MWh+s+l4ij)tl=QL?Q2*nyX8tYImycuL9ph_az^ep8uW0WH0|^PZZnD`ft{988IO=?J%r!0 zTdqT#3N~nUt5Byh&il~x3)XMvW|^rZ-W!lxFKk3)glU+-WiwUm8dT9SctMsr2-94( zR1}JXGCi{1&})XS)%N=ohgN-MOpcyK#EQJfrDUvVF?(FnQ=b@?zyh+zE-PQZA9a+> zgm;FOCJhr*>P^ULDr{X1xgDZ(Br>IR{!`(Tk!=P}`+@*LDTPSIS!*I?bOMelsBQ^h zVTmiAr}*)ZT)Fm&`E{iTF2t7T5{%@XYnyjX$)dXSax$@8&8COpKU*}HpRX$IU@_;) zzoK`+M{Rf~v&=Pyz5Ne|z_#HE=+XV1#5c>TI*`npLeG?tZwwLp=%wP;uD!imIYGu9 z>n@*bS3HX;Hp%Emuz9cWz+X?ZAyZG{F9Iw-W>4xTFtP5P*yEEUo@p2_7PCj!@ryzo zZg5D4$&Q3Ewoj83yqHG{IzK=8V-^3a%8#N0Re6rUA!R_r9RX8#7Qxa&XT~T~1fl?a z;J9mnrl^$m)%Q#GoFl-cRE7QOuxG8U%?~IjCf(*NDMbU_g*&pA^o&QJuc zSEjOylUe4Vu#;Z5aC=MN^+#6SBGzJS^&qWXL7V=^HGOY?VPw(1K z}<&{sldt0?Lw@NfE=A zkVlpP_ZR17M2w_{OQQnLM}@t=Z)^0mFZOaAbq#LE&v8hqtE}?x%gd3-HxY#8;GAAH z)~N%@h@3PBjEOGQeJ;Z=t>h%zHUrdpj}ql1c%L*2Cw5vO*6?zxC2a0q%(RMfNgp?R zxu`}8O(v%08RcZ}2nBepq~nLsK@xh$6&CX?t_Na^MY0x6(WT9So=(i}?4Og5K_9ma zuY*WYKXU^hM=N2g{x?22_kT;sI{6I(v45(#U!90WrfX6p0hiqQyLR-#VJQaCHvlgd zh#6sc%LtkNvEXbqyAD+56#J>qJmyX?tf*+;s0GNZwos`)2w#!M)}JSu$Sf;x1{Gl6 zkD6>LTAXKSj5I%6U2t3wUD{wa3!O>FZnpOO)>W+_fUm-g5*5fi;JYIemg|f<19LDE zYENnq9a|s3wXpB{|mtYD1=dARI1V0rG4BP;;p$O9D&rnEBh{D6m&3{MdhV&{8fnvH756lJl>-eU7ZI%3#5cNX1F<{%8J$oD zs8*+m*!4R0m3DCOH$hFnY{`E@w!e6csrC@9(fEao?rpK%vnI!NCk;odIN;~8$E^bU zfVj&N7{y!|tHe$Oa zwndEA&a$g%-ISsHrZZjwBdMGWfmtU8`!(i6j5`ITabD*=8>KhV^6uwh7TqB*4=Fyhj0 zgn}{Sx$RkE00US)W4IlJxghI@?xbPIJ!A<(n#y}i|8eMM6&Vx%2}AKHMw7EJ+dIjA zxRKbu4QTnZJE(YwM|F*o`*rRBGEr9Ta^*rB81*{<4SQ06QzYImoR8rr%(Tu)U;m?j z9ZXo2pSQ*5pKs-oO_B9UL9TMmfz4BwXovLTmm0F{;&%i2Zt)Kh$YI-~1W#oz>V3oZ z9#Uzeu%%A-_4gOT)JJwyeyc+5nKdM%8WUs@F$y}AwyRBnFb#I;mJB>=b)~YLDW0c^ zURsB9n|b)rVz^T=_VtNgpzGZ$%HqgxzJL-826WF_29x6v{|^-1HM`d7>+1;^9k18L z>JvbPXYtBHOG)}pvhA$a4?Urg_bpRoA}?oAHQ|`5Ybb_2%82a2J#yf`%KZknO|oXE z)EA1e4Qj~Ue8frGEqT3WB{+y#kwT(w^}eO+a?$N}ZW+7_?G8i2*gZOO-68c105@q`uqS1`erb*Vt%Do56A#2g!e>v-DwStl1%(i5uOr_>I^*ldB zKDU&6P;no2A-qn89H<_gPYBcQ#EX#q?|o#X&;IwPiEOf_b{cvdQvXw{Ui(b@Wnnto@ZlAJaz>mq_FF19S_D(yvNCLPP z^aX6n6rFpDPpQPtovTml7#0w557dNjtV5^g@)uQMzC)Sc#NXq|Hfw8y0S-xnfha}L zPUd$Ss%q^js?gxeU-hxHSu!AVD!|)#9>0Vd`{(V>SGFK4FG_A6UD4d14bEm#X%7>0 z!0`xc92WvFd?_Qwc5y23dathy&@*$CfL4DwmY2_ON|o>M9(QNVl0lp}Gx<8TV5zj6 z_iUa(L7`s4nA|aH<~y5BZS_2w{3mMruM`Oq{^D#CSdAaA@^rGtp>`$C#k%SYqIVrV zCKQQlk_>Z$gBxmvgkK6?i5XnJU88L&M~}3tRQf)Z7g_Y2*DS)N23}tX%WcXx+RKKM z-tJQTY<`r1K@p0#r2INYU)JZ#B02){-^oD48m(-WLalAbLZSDGom(R$onY-$;7rMo z#&(Y;k$uc5wtJaC@eZL>;eiJ(zbL|;%NQwE@O#tpUn7_sK=NQp`@M0AKH&ufSV%tF zvPK$|223lQuMuW+Xf0D9_3SITc;>NW+ZGBwKkegMK2izWfS+aT)Dfsq=BVwcK~NU^ z$||Ip>*IYDf!V?sY~J@V_D?1bZ+lY|jyT1VIAQa}Kv;0xla}-jc$Rf^6`fCp8kSwc zjj~*aEw7gB3#|-ZAou0G-WUR^f|Kf&b93A?yve4r)9tnIr#xrkX4<^jf{ouOfOKY# zEXSzf->D}72{zQUp+Mv1;)$CGUIw#cCN2DpS3>8T)~vHEKmH4LN#)hA)xS~g(y!sV z%3EK;g4)vXPAK9c_FTwarTTd81Hz47u3ObuIxBIxP$e@hK}T*e}Cpj zRx~QrCBPq&Rkg+CqfwlyV2}5fuN5lRgb2l8TGr2jiGKaO#p)q=(qHfy6na?3C`R~a z?)2LZ0S=h}*kJ;sLP^*Oef_}L4%rggL#GYH*i7k?mUDJLX$OA~9rPl2PqnCw4;gD(do*gp@~PjL<1t=Y`HW{q#)MFt)Go#|!v7dtEbnn~jiVqP}hw zK2r$AfC6JCm@>qB90P0{{Khu}EaTHdM+XMi}hW4s$H<*9; z;u1Rfm2_a|%w#9j>+vwKPZWLl9pYCiF}~U^n4QSw4W88)qM!Go*ub`T zS`T(;Po!cqvZk-4PGa*kV$h1}f0G8B5Onl|O{WdA#Al-)x|w_~`orF+%!z9eH9hT{ zsY}-1(HFc}WGjYVH18{Ai_xvzbWC6jy@RXW&qZ@sTjmb}!*;`Nl3pof`SuUrBQJO~WwMj-+GOhr z;3t~_vYvW|-}OjlF+M_nyWXjZc`+uJa+lt_g<|85iLIR%WqB|p*af1W=cw85R7#w6 zzP+L|kJrXgd9Uk#KJHn1E&4^Ywq35=9 zEP=xDbs8cDGmgJ9V*ZV#_Jee&h};yOOf`tgD&|q9>~V%_j%7ns(qeC1+z2u7VdE{X zfM)DMSW?j;$yTi9(xvCpc7N28)QBJuTM^9CU3D4G=tO+;5+&k@F^SCSd)bSIgHxe< zm`IfHI{aAO%fKM?Cg6KFG!KXou+G!Bmixj&sNg9PhBG9x25ZbDK02+b&FZ2L90_84Vs#Yv*6#6m^)nWn| zY&ddphPecPaN=o|D+TrlqqtjdUuWC-GV&1GV1`SJ+JqpcVGB`2)(E{2C=6I+I0iGxG{TSVnkO6Jj)yIT<}XF^ ztXqB{`X*8k9BV3Ef;1rHR5$45T{i6nXsWnUDz;ry3Z@hcO9(nrR-?58zA7AoUed^f z%UtJm1}j^RN^?>ro=S#Q7biYb1paAp!E|Yu>N1%wM0q4N7o7Xx^SAp$@0D6l>~xf+ zFi?a*|6+iWPY zBrJK%AIzXQeG1Or|K`e+y#Ln+utwkm8xG3D%8f-C1{}J=(8rEgs*j}XW}*6->)QTd zvfbzGdI65(?EuouHq|_-q}<6F=$L;HmS657ikvVjtY&?b+KM0MLYIWExhu*zE|5i$ zz^#e+oZ0bAZp8ffMK3py@@|JDWi;>H(r)GAir8O`lC7$I3VogMPSeM+8FM_?hW(0? zsL{nX=9$U!TG84sS$yoWZ8J!j7M4dLfFn7jmz|a8Qi{mGg%S|ro_+K{z5&5sh}7F=EY zghoq+^Ph5~EkEdJ8^*Vwp@bY#8VIg2mo>giPeOtP?IxExM&M$K5{4?9dQuYvlMQ&ENJk(xn`TB51;?xVS`u~# zj&n5!nx<68{!naio-(s91*uZZUKH3CJ$B|Z>N+cyfUW83qVY5LOU?|rY{!)uG2tW( zJ8u$8m)aQn)4lL5Fm%!>rm=?!5J$e-CeLnV$p>P*UM$_o-B(;$Ox4%Q#}6u3i!Gd# zaEdq&Q+ZuY=BI6(@R7!Wy8r7_7G6=*X4BIe2H|EYFC6h+hLl&3Mr#M9-CRH!%^N14p`#pMlKx8={+ zW2*%9*_a_e6oh^<(p4xmD)#eVUrCI}AofcqJnm=mNJ6wY`P`&vpDF+#-Cv3oD{gSBbV));7iewC>edw=Yx7@qQ>IJ1bB8cNRKi0)EB@36` zy4WRWCTuu;#qm)kynbkR1S@wyeBQFYL0D|8A=Ev0M@5LgPm4WOP>RBM)eX#qZm!CS z$8d4J3cQft#JUqWaE+n(qTli5b}oHEHC zez%UiJS^n>sNq?a)^NCwLjubgbE-={a_UeTSgXJ5hD*OlhUw!eY^$aQb z819o5Vw(|u8D2DWQ>1${$*~#kRrk%8moKy_w7iTbyO(b@ObP<7JKWyZaWl{A`LkOqKo?|Xb0YFyI=^B+Tl)AM&o7>3 z*k=|@w0!khNunG{74|g797}{j#)bpYn67^uriG+z_A@9HA~=B_55{MPp=XAzz;9<% z7+i%!zK6>S56IK5>nIgc{<`PgbdYr)m{H;&6x1~e zAOS@FfI(<{86cZ5_CD z^jO`?h_M67JHsmeG;yCHedkTvsQ*eYVyN;UT8VFna+R_|aV1An(xfO;^Y^wUZnTpK z{?GJZJq{?n^Ng&VKPNg`p7YNgMG|NYG3d&V@8f@(yUOsAs#L+In{)ez?alfMq^O_< zauHn%-=O-lJ>iK)z%>V6|1nBMQ)i)aRidvS7*Tkc)B_(k#xAwVw&~SmN$-p3vJx|$ zT3yc6YvN+%VyBJ>@EE2ZIV}dU((Sk?#g2H%(^`q+B_v%hzJe(ShpOTT|0ZEAcFLn?s)?|&qt2#(8`3q61vfjvqF(`c1*Bgv zZ`Le8h?yh|MJQrg4sIxwu7nI8Jc=`iYg4Ti6S)f&O~}0{33*~~FbXnn?yjDJk6fK7 zysK_#J`LX!z_CFy!!{uZBbOcgtklO<-!iNjHYp9IElpD-3m%l~?YaR%XGF-yS4<+9 z^Ibj?bLMyz{>m#oh2M~?%aqyZ@cxNLyJ9-QmwA2o zuEMtLU?R66-y5Q4{WUcov9P2}q$W5z3GU>5qS3QL0Sc|MGUnUdi}Xm%9g~K~0oj51PRWXW+0F{(XHZ;U^P)b8%QHLLdXzCsE&;xInsZ)*&4D1Mr3p zqz&ku*bW>Upo5L&ehkYd5PBEf!_PiRlffAXMqs(7bPbziJfEfZuK)3Lfqdxto^GXV zV}A#L<0^bat*@H`OV#q6PG#5Wq#Z9xd*mo(@&&ma66SNI^_Z?4SGHFEmLPvY@4NCX z6(kCyO@mqn6p^w3aRRCK*)I~EdKfZZ2p@cNHgaWlUx{~Xn;gZ?jvn)o!xCylI>51F z$Z+XNC67Rw1CxaMh#9lF?+wI_rmVA9Vrx(P?UQ#jy6Ve?c5Pk@^-W`$gYjN;gPvOK zh9^Ug?8HS6o#t=M&eELDqr0b#Vw$F=dH7R)QSfU)`mv7jz>O-WXoEaUY^JaK?}PNd z`OZ?LMbRKd7I}&;$5O#R@RCZ1DNKi>N85Rx*&}Gck$d+p^GEdMFPJ{2_>8$ETTwV0 zPn2kku=QUgh-$+Dv)4lCD+<{|qZ1r0RistIpq$7I0Z9V8i@=H%D-GFchESU@;iW@L8ZZ}uy5!KMYw?Ku%k(1^EW5xgeP2OARk4`vu@?i=1n zRlaI&FB`jPxui$|pY@ZFQ>_!4u58sWSEP|Uj&iPp|5vx7Lx-afk@#|6 zFN(Qq5Zd}5?#9P*0}n)HP>t%az-wl_tA5 zniA}n@+-kl=B9A8=IF7TRDy#canq3?t6)Pf)n-UO!P%M~$Ir7zr_u{`naaz~D3J>E z(6`6>mLX*~pvwvmt1t>b(Dz6gzlh$o6E7N(noR0%XR~arJcQX|(-wqc4MkhcIP-Cqyj@0hz$5TXThIM2qToNNu9x_bwiZeci z#aG37CBdKN+`2i!Uk3W^S^evcvT=aW?OuSTMLWqcABCbrHqd9&|HG@W=RPcrWMciF zcaTv0+F~{k0=Dz`N4EVs7Mjr-@WM&yfyry6&AjG+AGH@U-v25yf$t9l(UBF0n!v%n zowsv+FScs2XtD4Bdw7hyXJwt0{5aN_Yu|WLLV8V3Exc{X7`(GeB?zUl=y-sEV~kAs zj3Wl`wpisv`Z~A}>-~UIa8J9U@jAiYwKGG?uqb8k7BP(7KFm;>y!Pqy`$3a*7_%kW zo;OC8STD9t-^a*Xyr;&3p--z zaKJN2|H3J5lb<^FWNa)<*>uA{v8Ci`^eM{IU^0&T53_MK?q16pk}mKuF+}U@dqN?7 zx+ncL+Xu23nc03W6=f9Oobn<#@4KWD*pEZx;=z_Rz6zRYS;dG+7}SR9UCOKTod)lg zIAPp+_Z@cNceAlM=!wjXe99O+w=t`w->27A3l{3lN2e1pwcKXj(x$oh7rX5nMnw(GOPQkN;-K&=gW^B}w=O~rtxN55wCWxBeQymI6p<5Yd_v(cC zJNDE377$aY{#CB`eEu$XTWKRI9pVtDFR$KEZ@3@4Oan*M)wC5ZHiZ{|`!xwM<7e5W z7F$HNcf(R;t2OuU6nlp6bHGUO{2Ph%b+0Pia@a3JVOX@wl6VFhC<<_7-!%ul(!3Iq zzKG=&McCv-5%}%qdHoS&Em_?{f)nV0_iG8+z!3V<#!kTRYWq<_?NNYB!T6hDqS&h8 zq6p02r0(zqbeVkn+nb+pj|-ls37f&N4m2N9Xu3Sw8a8D1b(B&lkN}ursEzD-S^JuTY;sGE0AkLStv z*iCNq;dCX{fL7rq66QSnSD-UB%vHW8<~N^fTsY{}Sch+|F5K0RE?C4Sc#XLGXYDZo zh%uZtfI3HeZrTP2imX29_1hcot-D~&{gJN54Bp+##=TuU>`NZ!!>ivN%1!+-W-q{g z)1gI)sj*162LQG2x`eQ~QrW=*I)Hh`vH z_cHZkHRTDk`d4V!8yruGFa2?y8rK@1j(vm5zdH)n*MC>(@5Lp8j>^>maIK&*F#>1O zhH{v3Re)4ir|i7%^m&DAlYkBdCC1tLynd`w!#a14VF#B?A16a2s59m`8>8$o$4g?6 zcGR|}F7>tFAEylQGvkBHSq5)gA!~?>xW>F{Ju4x9LyNmWd*+)P%Fd+UJ19~3MSrEg z0*dhwiLj3sOuXsgH^%qsJoTMu8Vslt@9^ulHY)w67hq(!8jo52Hg(D=R#LGm)4VXK z&>OqojerN&((fac(p4W9)NPPIS&%Z6dUU}AwKjfGFk{r(N4d6pZJV3 z2wmoLbGn(BxJ0vK$Sve`9dY=q5_?oOvcVZ3$K2QeX7w_5J6Y?|&ZaI&PbG75J&= zPVVgw@TE0oU~EY+=H6Dt=VvM52a@nC`@Ey;1dtCYpPkwbt7cyF+LDb@U$`rl&mteu zrcSj_@-*aDs2{lWdNl&7;28#o&3v;&cKgGP@VT{`xe<5hKP-7U*QVRcJu~vVmXcJ9 zFAcmQ8jyOHQ>0XC^o(Cje?W3{MA29Pe*UA!zi;~Q<~U&}KLdz|Rv?eGEa@H1N}~fS zUY@!wKn$(WJrn*nFVnc#qD{nJYoZw5F@V6t56lg)<%$a*8r1f7LxS{_+LRwSg%zH0 z(vcd`%bgq45HdUBb%LCnwfyBiCCB?{`AjankIL2v%8523a1i^eSKENBFTXT!HLhNn z?@Pti&GF7nhD)LvwIh*q=r=$-g;U;4Pi{pZQb~FuzCA9hMWCy=uT!&H%};#-fP+S^ z8E&V`LGXM3s_%2`{~N`fBL5gub((EG&-5F811f47a}o1`&MkTIv2l;dlkP@M`h!*) zg(XTY9IWRcPbfv(ue1;M{rl=UPH7#a#1vihQa8din95c?ITZE9KOh~<68=U$&GdGX zan_+8X{w=*G%5R=KgY7LA+Lu;O#{FN+ReN?w+VbdGfSAxVIUS$?@atIq%Gc&YtQbB z?BZ~P-O51!>nZR6b`Gq%v^N9D zyk4q2L8>ppsa*?a<%Ls1%k=01;+?|rOHU_n46b=8bLai~Ns%hZM1^XwAq}sO?03kP zQsfwqPv>PyyQ;EcF3-^PaJeYE%k#KNKaK=yN5VFYfQJ9)@x|R){CgR=QOCHR0gG(g(;C%ABGFuH*b1qE5Ro+u| zOq&fzfgK76VW;ydU8sBR%fkosSg$Ez;FsBfh^$ZPUz7q3LQrMN#yell8;UHKC2^plu<^N`R}x~)HniOH?^fOyyRcsU=r2euaYFox=*u$eGMkclZR?B#>&AK9^i9348g^Wk`EUI^d+W7Y z?c8p*h>zTnueyK`6oAmHZdzm(0CnGV!-h}Rh5g?A;!9ih%|_p5Va%~PfbGC1{tW;} zYA)YimCoHOR#u|k!0(z~S@UXIUyxS%L##IGQae~*BL2z;i4bahU?My7d~Caw?SV7o zQ2DXvc2L#9j->T0oUKNEE+Q zv1oyseFH%`-{?Xx`aZ`KYhG-v;o;QTwU=dff`)eZ(Sz+;hB zOy&n>y+@cE>0XvoO10vu+kkjNXqsa=U{f!!Zhrd)ER5l0{+ZewtzJg8ne!Ul^WYHA;{HZ3WiHt++@*tnnRbKi!?}X>)p2Ti4rQ)s6y7;=Z`+m z75VzxD@S7B{LnT5RDr~uitYQG9rC|m1ZsAXuT5WGEV1dx+@6@)1kJ|6dl%zkgFpIwP zkTlSL$E^Mi$We}Q1-pbU23M397lTyS4zWdN_t!;eNc{GR4zKZ<)y;k8D*dIVM6^@m zpUzAg)}5SIJg01n7dxytT&yF%*&RBve(Q{pc;iQq}mZo!e)^d-WxN8978R;Cd*D#$-QL%wz`1#Sk7MA^! z@}ukRym~))G(T8TKqy3N@{D+Nd}Hk7FEb8^Im4Wfm0cZo3r^v<>i<{(7^d}Yol9#D zH2#w2i3TAxk*(0&>xPxlTUEmXNxa<}i{UQ@&;59`hao%3XP+4@N(%LTKj$zl@EucVIJ%{(LDU0?XGF~3UXlK2 z=j6eW8bJS@)kdy59yRA6{*K!N_=o-!;s8#HqBZOh;YUjog8n6D@_r=%vOMu z@iSMxZ`y@jglF)5Q3US~Vk2J`V@4{YuVWj!U&%|F3RhZlI}Al%Z0G;VYp_>IHTtz9 zEBM~W9Ih%S62_={MnI1Cx~!By2;xTxyP>*~OkS-2ts9=x2PU4ckYES~$|qEqO)z_ntTw?x?+?l!$6B5~3IZ0NbKPLGq) z0PdT)A*C=Dm|9kw-kKgiM5z0I7&;C2g<(Y&p97gr%eVljH{JL3p`A~O#r(l(LFAo{ zvEc)mn~{{U;@bT_7S8#FI5j1`itJI=cPUVL7;NBNn+)#!cOk4otb=FqP?zmWC^Ow z@9(lrx`Den=Bf7}F&LVI;YV$qW4q1YBAZscVj=cS;bHr*i{+wQKwx2QsL~%DjI5lR`B9pM*LJ)KXB!;v_^qh zWMej}k6zj`AvwnqL5^MblT+AK)jbRms*0fQ)9(-s!Yqu~wf(OCwgh4yeb7s zyMd=l8^BUiQsu*dp#E!j{WzVtDOV@tJz<_^<$FqFdJLND z3E^zEl%lLOiC?XHx{!46W8(=7^_@SICe;?xHa@}z28FG;OPGCy>ZivV4h~KO!2DfG z(zCY$AmUN0UaJ#>*+dH>B~~!LLj`!4UsiO2batxlYqo@7qW{F(m+$!-(N8}z`$Jh< z(kqy4XHur^=xaydz4q~9yv=0HAIbI#;X3k#9&e>FTza%TEAspfQ3*PscExImzq_>H z7)agwei0>3eJ6gCqv%xTlf}N2Ml>yX)&BXzbe%$2JC^hR(exG$QFQO$@GRZkjldGp zAky6+rEr51OE=Obv2;jxhcwb9h``bv0@BhQ(p}H;{k`u$u)8xmbI!RwIl&E02n&W~ zHE6sQ65c6JCB1zcK*;#*-&BcuBg6Znp58Z5l<Ql#5d#4bdgW=wDFaBI&7{fe?BZ0O+FuN zJTXs>@99qz7$AB2W2Wbi$`-z3TSU6hX_p=Iiifhr7u)M-ZEmwv6z(uluxFQm9*od@ z86i3nJZJz$;L#xj`KD}^A|5;$MY$Gd-)%SxJGEJA6s28B-$-n*2Y3IgQ_&I?umA8q zUTrVT345~uL~~xaQd$uBsHTs|R2eY1&YnXBKC^{> zD|@p^cHU8r&rz_)ml(buB%tM0gYmQ~bAOO4F$04D*I0fZC>{kN3X2{^C;q%J!jFJDNh7SI@0DIF) z7|Q!L+POCx{MaLSk`KysXDij|k5y*a_B|Kxn7NrJUjdD1GlJj!f<7&in_uOG^Gx0~ z3?hrqw+94&kSeiH1g7=NPH3@|knPdbX=lr>W%^%q2U}7|YUrlK6y*#oG zv`Xz;{bSj?X@qxp4&HxlV_Q)xf6~e^g#JMHzq64oka`oc^G3wkrJm+BOO=dxg3&IY z&gQJT#Ou0G`hCYHj|ea#Nz7F(h|A^=f3}bb*G~oAt_O6>4C~`4pB?v+8XnP**WiaL z*S)Dq`?)y*0rPUZB{+oFn%*?+Gu5N>q*uxBZgYKh6G0#_-&65Tx_7KvWA0w&r}4MX z1rVmmU ze5&(O_Yl&iN}h~2h^$3@av}trqyjRs1kOVL98(Ej)>T?A&=9-K`|y$0&-QT^B}7%) z|7Gf^HAtnfo$4R2!R-qS9@Yht&kS(mS25Z1eALfC;Rs*KR4F?dX)3dv3{pPdIVz@W zC+q(8U8!d&jVBSxvtyLo5ys}~)OQ&rCgVj-YH9eew6%NtcGMe`$jIg41V2P){6JCs zEyMqY7RjjhbFg~*gLql_`7+rpyPDQQj?r^X?+)4L_h28Jl^8?~0ci1??0z4MKzVcUfab$K@MZWRojgEl(W|qLwy}Q75*1LX< zK9q5d(Sf4v+j;lun*oavJNxsdbPK+xti^?~cZ(n63K2aw%)1S@SueJ7m<83%->h0- zBeE#Osu83;?MRe=EpnAYySTE*WKvQSan*324@uaPySZ=m;gT4~c zo&Lf^@t@=T@UiK=%ITOPd8T*g9YXw)?bhO)MFj!t2+Cc%rHf@5{a4Fhl;}Nq!nDs; zo-?wj5(X-LllF-Fc-wz#QxZRI@clvZg|h~SftZ}73*e^fv9m19_NCXY!Gk=N% zDXe0~C7r64V%I5H-eaTTsXZz|Gz?##Z(2uXRB^tM4YDi^j>1jv<>nPQ^;c0uY-ZCG zCjDL*G&I@5(~FpNBdnnlQCK)GT2KdM;FJ$30&zErJtik+gJGSrSIdiLscL?+r^iH^ zTS$$+n1R-MXCs1^uP1qJ-(29rzqzJ4ldr-wZPxClO`LudF>Snnril|CdC%SPZ4HmtQy=heOQ;TW(>&?Ts*7u!{F(l--%?Eu^dnmxSoa`T_M71y^;jGr8d54A zd=N^V8Lxy)s@}e9clWo-)!~OvRG{X3v4!>wE3sK_?Wox-Vf8G^AKE^k*(83qRbr_p9GojE#<9)lzm89zsu%dzgJUoR!cbYyZrO#lMT_$ zjcGl-%!qunR&+%w;RJeGp`*_N`47pz5cn8b!IIqx2lk01$-?NU$C*;~O&;&BKc_$w zA|+%ijDLER<)Re7{zXXg z%F_VQwntb6JZD987R>_3%}DRB7y|M<{-kKylr#nCeX@`V$lrSX_N4mP8$2+9^OXPf z%8=4+@sQl-Vs`#Jc6NiY)-;^Nk}dcy@=X1wPCp|IrTITKoTTM8Hk>@Og|`m+T55Yy zd>m(vUP?h&Kevt^3c?ms z&u71!_6jZLk`{GQk}dz+WC``;grP$PPT!dx#^iJi<$dRElDy20f}v4^Vm4+3^Y2H@ zk~P){Z2n|r7hLLtrKf3nJC&n4ORUBui+h(eZ*&iG_z!+o&QpXj0#$!h>yh0mJpN=y zd28O=6;)Yq1q>k*7UP`=RRh~MKSo2B>AB1PSxim6p07}@gem(u{@3N+c$@%D6sQT^ zUjV)u;b>_$TmDJOPIMoW`Hz8wAk?M3Xu8ON<$E~vb)M(mWupBnI_#1OCopD(-&Jr- zfja_=&7s2{ZuCR#6uY7R4iE1zYj3Te(!1;mS; zmb;5>7vini$#u|>(tbRTORk&F(MPTHR>+m#r8eIX{|usrw8w_JlT{t&S_ky|d{n*f_ zit(^(^l;zA8vkK*(XPWa!hWht>QQ9>NzukfXAA1LI>yl)qhK7;a55J8&%H<=`ZnC> zo$NjTafs@vY3J=mI(mv-itG~I` zt{sMd#3uNrl*U1aT;l++;x@09OVaVLZvtvq`wE=_c=~$VUYq6&N;v!vxAOy!aTk)_ zR9Nt_Cku3QuGaJjo+Ml2_juRaYpin)hqt_1y4j)|mS~~bN(@L~Llu-FG`f#f@{t}} zJ&C`G**gjh&$a7lN$H-Md*Ds(f{(0_un`_h1OODkhg@F#oWUN(kwp)HHjw6qh@kX4 zX4I>%I8>?DodlWvVgco*`+teS*+>IbUy^hcvfn%N`G zkr)a=@+LKqD!#lnH+lXjo=r%&N*0TVICQyojxI9nb&9$5GpJ1BukK@UG@+aL7&2xF zxY^7KdXEjwk~!uXN4ZA#K)Q&^>^?z7V!w3YYScksC;j*Ba?)Qs%Dk`a!RQ4J#lKX; zqs)j?kzE7Z2dKE(FRYZHRya zAC-Y$Y!hb@Bm0CsoCK`PI!CwG6>0qTu@Wqhu)I8Y8^Tli3V(hy>`3%yXp5J4eFLjY zZpw}Sgei_WFZ*b|F?#Z|sM@u0gZ?Ym>YaJ{;Z2hKto6o~aM2{?I|}_OGIc+AK;_B1 zMiNELV4lcRFv=62s`P|8Jj41X0`9Q?p}iMxMLRD$DJ_6iMUTQ(i#Col5#G)F=&`mX zc(+^7J-n<1FvXwLG`spVBha~eBJuvtpIG}H!Cp7;ieC5$?!zxv{;#3NIi&6vs}|ox zL^K)CxBVqo3;6imdoXfw1M&d~jbS7;POLE~fNqUKT81s5?!f0T%meF9RDk=$l)zA? zn$OSiYt@HEe60gFT&4c=R{i=Qp*CmYBYI)|AEK@z+Fz_dSfo3McqmsjHd__6uG&bq zaRlK(6Jz`ZL*7*d8{jj{Hi?#;!GeUQ*e{>@N$Mkx!Nqg@c-d~D^ZvEeez}!M%0lhK zhZK@KzcmYn4O4NHgkW%xODB9pS0(iYlhJ;NU24AkDzMt2#9Z!G0PZD`=d>pvy1tmeH#de$ix?Akz=H~7jdP=>2 z#Lo~e@2?00!c*XRvTPHYi}{{HWAL`)a?*~bqs((};V@DopWiR#wG;7`Z~}a$(RQ|6 z5|gVKky|PtwPc4M;6kf=m>EokFRr? zRykj{Pj$s)X5iPH&orLxw+!1Q`)p>G-$ zSe!HbazqS1vMg`ze|a1eby=E!7bwK8ZuqzNDQKk~!JSBKBtJBy@=oC0Ty^mL^bz+Z zCxrue(3ezRj1#U34P6TKL*bX}e=h~7ItS|Xvwo2}9>L2%e!y)$ zbu;Hbf{~hbH`wKt5-+mV0FCC;KFTn1i)l*g<>dbit+^9`ce(>iDY~z?Qvso1v(#B08h$D#voDf!SC=6#LCc6dW#Xe#ouI?N?_i}z{URblk@jFD7$86-6CpkUVM za5CC+WddW>32ci4$Un7XjqcA)20ninOH6#F)UivfXTE#-D|A#Osd0@VBmqib;>~MW z|H8PBzgodD*#s$P9+kLv(``dp{L^yeH6hSO1NZsfF|lj??{J1B@#2E4z6;|u(rXIv zv0U<(+v)e}*z63CHuS4e>(o$D47ceb+RcYJE=|Qug~cfZ+rco=v6@OW$p(1;`5MLK z;@#(2$zqhqw^0O1iPbHcI&g;OY|u_K;Muh6@#+4!yW*H!dpBUravPa)R?B>@#@PLA zka5*t_EGlh`on!MT_>uwSLu65MGa#GKXU&#hUla`(2pc8*vUG=D+EcpF z6PSHj$h)(tJ9*^!FI39l8al89vzc*Dv$7Z?LrrXB>+frRcc)>ePMqy2K5~F&PiMJS z^Mxq?F~)~B3~Xm@^{Gzj=6?8xk~|P-PGTfwFe{%7(Srrs3;BtHHP^qoC3Y;w^{hD8 zyIe$BKSc#M?Ri_Hc5H|noA=Se95@Mm`ieQuj4sshhzZg3DG=g_P(C{IVM-D_fBJSj zCA>|JIj*-=uVvIL7uQtLS05P}S>6reFMuFNb`|=05T6gcMdgLX+c6=fXf+2tJIR!P z$0Pus`!Hs-&ZoG@|5xU7b!q>x3T4;ifa{`;K_TPv__O<3NIflA)Pi%VGG>I?Eg-uW zeZaDr$*6P-FVVI5^tr9E?RGo!3U2RTT1J&k_3)s>brZ zm)mdAp|#TC?*R9A3$bj}`z;1nUO?=@mN&%hH>+6HS5?dQZ2E1+1wy7r5zg<&9{VSk zVoAqFP!s@EIFiqX(;hw5BhbmY73DW$%55-0Smr;M1Mggh^@;`iW_6yj&DL^^Fssr6 zCO>D?cSI|m^%nPi(o{iAH}VeN#q-}unKl0)*|;sgGHz%tRLXs=b)!^kTn#?lP;MRN zEpdr*q!y-G;jT;5`)^JTYwG}^#Ncu-t0BmK<4y3v#G4Zdd)1&Egz34uw|{(b#{*mi zkJput7zGHX1i=47gu&kSR>(Z`{gDLsO?ErOSx9^>s6@QReN21rlbQN<68!MtAUABA z?Ir*hti3uWxPkQr-X9YrA=KaREt~tUMe)v^T|+lL2Tq#cxypPJWTx{FX~~x>j`!tT z?5eYa&n)&|RVLxf1Az~pki2DWTG~TPXu~hKXdxeq7vc`rfj5a=FS#^9@-D8PT5oOg z1fdBBs8m|rpDc#vgUvCpl$^b+MC5^lyzW;|m(^!UeN$}?fr;FZgw%M{pVIZRff^^E zU+|(m1Ufy1H@!R}6-m`X?GEo)Biew;ScxZ3?y?EG{miM_O$4Wrq-%KJ8f1N72Vqy% z;e9g01K%DVD4HEH&6yStwn?ZinlG(5u03j}t|_E8r_M&|L*#Jl?&!$yxZ3T1Ig%rPk2PfgT-;>Gf@{}J(c}nd(siAW^D4#hbD7JnJ zlPsz#%3NaohP%1@UqbLA64qMD;2YfcBEr^-y*iUT1{hP&f1u<@MJ@GUaqTd)3KQuG zU1?fHs49I|S_nk5^=AF6%*t>N?eGK?gm?(o!D0RT1TSxY58-_~Z0xIge2N@ip zo)^%0;DT+@;kVl_fnTVwzBfEyMzeT|tCMl?>2hLMiPTWLP-*EA+y$So-!9?3qIMD!{GhfB z{ZAMdV2aqn&-(dx!gq(vHDg34LbQaTsD4A-se`k5HISRKpFMaHfx0U5(^-qisBI>) zFykr~7_SD!s%I9jCY9Bd$%P{h>6a@J5Y;7~mSFq}y;x74HU=5ZuF`k=Pcyb|;r=Lr zEu)?BiRrZWb^|oFfxX3hy&qoCp*7@aXvXUH{$`V-=8%0RVXGz*(?;(QwSIbi#9ZW-9+s3OsD+FX1v_&QoG(rl7Pyw zFa(15cX<v7Lt|NAS_ zY_Nu^tbu1bU0j|PHr}psYb6<8jV3+*btU^-@SDptH%ZM~3{t*%qlg@(lmoe%j)z`Z z>$2JG&ofPO56If%hgblg&2;Gr@7d^ZNIDeNtK;$N`}>8^R|54?ILU*u>%;F8g}^KF z+ziM|V(`gt%`;64NAv^+= z!uxWuiw`qd_#5WOLx4P7Dop)s`rCLt`U|PAT|=L-n8`Oo_BATq=iTqd3PKVy62W=8 z3!QJ`jtNvqW;+EXF9hlMniBOVYD#tc^@kJ?;W%oN!IHK+DiX8VE9S z@Cx%d#e)tY`}no~Qf~g==+d#pnn+)cXvp zBCdcyy&WyXmvK#&Iqior)g|l$NJ)s`!1}GwP`c<>!d#_EWMWNE9w)nPsowN-a(rAa zE{lqJY(Wsx>DgMnf*du?oimX|;0PKB`fC%3$sDDBdh6%joCzvg^H*vrYQ;k&y-=YN zaKwGl4`cHFlA!#8h{cJ{ZA$EP@tptZB=r%C%0ZGekNR0=mbT0XC)Cx}lvfNaXrXwo zaiZu}34U;$G~MmWj1u5X!|zPw=UdtXKv{5t?F?8`_}yVr+O4!%#ktUi*^`bA>Wz# zXj=*UU=l4e$MyHPe(b|E4h;b%JQgbL= z^D&w-R22%oEw{)ESf>*eW0!WaV9tU#d%rjN!3kD3NcPf=b$$57RR3MNp+(S<(4e%( zSZR9kkn&G^upR*}7Zwwd2+lz3Pz4UbBe$YNJ!#SoOMe7?cMQe8FX!7#U4zIBg` z(@p(e{*}$2I!6ECoN+VCenEh%M93TVzofh^{m)q#kegV<=H2tT&?lUl2=j+J%-!deJeCymK})y-Cl!vRq>$MVqbffyByx|+Z4$; z`95r)&F8Bh9rN&N1mZCTYXxOKodM<~s7fE5B8|@mI{1|z$VJpTj;z1{F5`v|zPqyG zU*W-G5$;L6bZI{?=~$;zOT67H2Y+a)MGw{2J{%rk=yna0(Vi8=2(t+?bW5Auy$i}i zz?naMyCv7Rm-%3xbZde#Jc3u8fWwC2SA4^{PN@`3BfSG^r9{TVfUks18L_5o)iQB7 zE4#V+*1HrF-gkQ?VMludj^eR_rh;WmyR!4R`BO!RNOlfQ^A>A@g})#(zHpyu2+Q&F zeaG{6ggp3`?53;mlm5!(h0=q+2;V?Z$|B>v|4#X$0#!)zxKWCMnNt1G-Y8{rq_6A3 z!EdlT{Mqf3I?Y83p3Mo=xLNz9?#eWJaYPRDWLZ%|k{t1WIm3%l;_Faf6Z^#g(`c&@ zE>uFgPpmy86KZ!;igm;Ifoi}Y&;Xsxq$00lI|DQTyaQg(B1gzj zl2h)EgW{rSqwqK9kRHw!i+=HIP)VXgdOXy;5M@@Qf$W@hB*lHXAvUC=nyMTaG!G`GwUe)VrDNYQ=;RN1GDs&&FK618QOgfhOKWxxyZ(|E{32O+8D$7nP{T3LD zop6eG2uvae)|#_Ewlu`X41>%ylAm90p|T|6h2~8{A_*!W|4;EwHn<&668W6$e4p1M z9y{oX5HH*vY8;&)ci)kJRMGTJ&w zI_xR^k?TV~A;2V_(?C6em1Z}XeE99(@M){|FP1huJ*%GPrj*and_%_8tA#=>9M-^# zlYOO;wt~np__`~yj>cqhknyGUwBSH%HLJcPP2B*qg@fQt-^L-j$gild#B%kG;gUV9GgK;0>W##1agb__ zIy-nPggNeGo?0w%x(m@FLb>vlv$`S8sPC=ytB>2(Ax{0riM#LRhMrxtC~&x zDia1jsOu$kXhFVJbp^%TCZk4?)8rxPV4|)zXrLyuKaOO0?&^FH+4!2gTvhA;mN74C zwhKOG;#np*32{Lz`a{I`fIUULC(G7`DnY|T$ZpbZ%^diXWtZ1R0dXgLzk;CJVS@?t za1;AZVvFyC#GyWnc3~e{2ZY=fR|QxUg6^=O?=6f{jtGFa*vKsP+2g5iqTupWfhfa+ zFVpL3zpRn1J#RK&pAr84z_e27;((e~=!~g%o4=KR&-2y{L756_T#&cwMCGUYloOvm z>~+Gc*QrWA(O)7E0dP5_V)rT9&JPiFR)2QxA)ygjMJ}<;7 z;C;m08?_;f|GWPIG3{`s(xU#RqRsiqB(5{-t5-53JVEig>P$@OIQTu^(`%@j@~2KS z-f%P1Ka=;jpI<&xkOGhe<&Ax?;UTjgvgJKB74mC^w$ki#oxpzx+G>}1Q1Epj!a?y9 z0xa$zyZ1xbIA;}UbH^qE95e+O;>&K_L1w1laR0{xBYH>BFbHIEmLpFi{UrRtRBXw zy2*2$Xo(4d7e-LKC<9i-?>oir)t`7P^%11vEm@rA`v*b+_Oc74EZ09+u6CL{$LFEC7vw zA_k(RO`I+x44veM)P`y@o&b4rLIO6FrkZqO=;D2aN^5UBFHpuWOFBSXPjAM ziKkv-i5f$V1(Z?M6{N!gTd)KYq(CVF5C6d#wEXk6jmf$c-&ab;_mE>Uevj zZJq!&5vs;M6OPi*pNQA-DG}ZSzJ_fN7~}#>FlB%VrbTV%8;lczdkEaN?y8nrDqm*7 zb0~swB*bcJD#x`B3Qo`FQl)60-{ugayh>fS22M~#Qq$RK>Bv{a0(;g!L+OA7kHjzd z$EXL!#J4fSb&UyM272%l`M2#J3VDi5@1g(%ZgjqIy`*zMa0-&JfuLV&@}TbJ%v0p- zfW#+kx7j#kCM7PZWzt#x%C6h50k>w*3+O*oU*H7ZEj)}h_NX`6notw2XMS!MqFQ;L zt^nn*!aKz=Hh?MuJgnvqj=07_USp8L-+beF|1(rjynMS(A%9chM@Cw7O$()@p{cpt!2me?RAEZUYY~V9er~c`EvO&A8knHy_uBBV#!#c&-Qf z1MM=-&8q^s-oTGdWop_}ZH#!#D*~&*ob~E+Tr0kHb_xo(al!d?&XmS+CXlWO8h>`- zM}9)!2FcS~Awe#m!w!EOWgL+`Oy!gxCYkNGGpP`B{1*-yP$C$5k`CHqeD#>ovkV!e z!*9LC&=&JtIkjgrV)IMe>}Sv>ilPS}urx&ALQ*8t^%L}ZgTzCW*y8tP6ZnKeZiAzP zw~CkaD{@uwa4VPyKR!sdRC$iJjHR}Sil?RzKR*AohTeC!brA>Ja5qx`?1LBy>G*{X zmM3j5Gw3>?JSVQJAg3Bh!M$}YL+aHx6ns2yimM{9f^QJSz{6 zdw#ahw$sD&b|vVaKfkrW@oUz$8N`Je3^PI)fwTsOWZd)VXRsT*LxF@lqpbcY*HE4g z1s0u0rf&#gG?rIV59VUZMPsohwAlTLR>Aa?`FjQ5WgiY#5;`xN*z~*7s4RDKY8hkn z5j+nytJCikRdQk%fWX|UENT3*QyvCmJ!0$g(d=IgVt!9vuRW@N!vFYFJmdb76jh_V zzA+Nxy*T#!fZsi_3Hz@<&_E-i0y`KXXYKa{w8~6msno1hl~Zpm*o9r3r{eD`1@Z}D z?7gtA&nS`3cu@R^Me^`;U&Iu$ng~(zxNUzjA`~w&!m7+MZa5Os6c^Rfv|cYY9n;wVp23)W*VtM)I>l<*zz@f%lAu7+j*@{KxAR30IgKC<*IqI+a7tm=_^PmM!C_ z{wG$$_hk(cI~_hifYCU z(W?ehAPN`U^7;0}Pje?{C+xDO;+F`#b*D5NZhbWN&BwyBM+GFFZZ<;rt9u>34rBOI zB?j9e5YE?IsvqQ2l>nqU=y$M-`ZW6vyJ1I5K{(HeKpBJUAjDkIzuqs>g%q`uGx(7Q z`3KoU&hzcKKguNHie>6{&COTaajV z?7fdm63jB>L+jr3ItjVVl91Be1Ems<&N9mWNI;_i^SU?ehIhtHGp7;0Kn8dXu)Nro zm@yJ#jh>yaAJ}e+@HL#^)t1PRp{5YD9cB%Xf+y606$7AsnA@bg{>F)A?^q-Nd(W>5Gc$o;|y%dfL_|47mDGgqY0&EnHGgG~)IW0R_ zZu`>MjUaov$H>fdD2`}EG_r$qzr_3+Q#=DuMEMkab&B%>SJF=*4STNeR>xnRuB8tn z3(Uh)hKt;>Ve(TQ<`~y8`bkl^Oa61#|B$7GRbjW(66yCA_qkZ051YmWAg@k1>AhNO z*U!FX{!4`MIc(6JK<7|A;Tl=es|%eODNaqEM9aH{-w2y1l)$D{%`Fhjmx3p|&Y+a^ z3XWJYk&PhYaBCVC=kN~xSJwHhT{?_P#9SDC4$UHGk6&uf1#sPk4!tAuG$tpX0N~M~ zy`_3Hzt_${q6q{c>Qog|)N)vKc~d=9WTRUl`h3b-M8w0RAFHSR%fE{Vi2(u+G117_ z>u-8Vji{i=5JC?;g8b{0H^`xk;w7qGz}K`YuPeUAUN}ghBu<6+mU5XqxCyeoodNOC z9TOo5v4xU%M*=FLU(oZC4qlD(jB!H<3y@ewUTMfyvBSRjL|X@Zy)4ADK^`0^IOCI za$^R*Y$GU-p}vnu{{*I-PaWVF`A&RhtQnhW$7gHZ=Ff8iDMyw))j;6J#q$)SAmL~F zMdyn0nT0MKClr*o6iiC6I?%|o8qbM{5(8QxD(l#-bukdaGp+*!vJFzqCI5_HVDQ> zkWFX-&0@n|MeP`P{4Mf2#G%K?v_ElTJf<6$*jZn?KnHZmyd-HyM4sZBJMbE*QMo0l z=?L8ul&rHViWlX-++Q70#-xt={~LN;jb-s!w}RiLuT_qTbP@;T%H4~g%pHs9Os!Ge zs6Y4l-y3#DF9lGdC?7B=eP3;7*?YOuFr|j6`u35WFcnQ>YHdYo>$B&G|T6xF9+DoW{L|WGA?s9 z_17VHj|mR9_H9-aTZ#lKFJt?}4xSFRsjBx)?wqX@eSg_NNAWI6(wCcq^EbVX8Ew7u zc)|#iqg&A9^l*(KYf_A~R9r+|d0nbR=Nw(ahKC9?UWJivEb^9wIEK>x&0yWcT}1Rn zX-+jQ)04XX)T98ae1-yxH&sb<@auO?5W(>U4&LW{R(Uiw? zlAN!G#{c0I1Wd@E-GBsJ6h7HEY6I{?hIL+IZ_*%-5H5OQ3rY;;Iig~?pKa~mCxZnF z$OQBceR#;qlI=gSAmSkPVi@Ooq@@^HL;x9>aAsgGC>c9HVuB=s4Y` zfJC$*FNAWo9@kTLqW7MmfVHaX02s!X=vP(a*$L57Mbt7a$#%yOk}V?~52pT#pNNw4 zc;VL&uU`P|5_I@8?Xbk*xFY#fiSR1x>k|QiF$@Y?YbnXTh`%V~KEA}y8NR8q5WzXd zQWY_^MG9=d6+4NU6wmR1y1iRX5r;+qiE``&NRz#%Y>QsLdV4nTu}llME(a}9M$_-V z*NNZlB$Sdo!~mvkPDzvJr$@vB=n72`avoZVry&F-!@smoP%>Q4(5M#kcTcjBY38iX zFIWxZucfr-W`{XFLwywW5nH5h6XX;4CQsW;D5X5ZW;&y*>Xw0ySZ9dqK}7RvO(oru zv4D&XarYVQZlY7(h|FT>1KHZr5-G~uFekjcD;?hxCO+a|Du?g<=roSz3EeX5uusB< zsu8%S!{IfeJS;j$o5~)1*czkjW~N;e-&h%9&fNSs*7W8mRa__EUio;qwevpiot4PA zZ*k49tRO+&>L0aFCAfJKD(YmBUJgDcdvEc_Iz0)PF#zE}>R6%eG(fQS%C4ppC4c;Y zqc{^L0iK2awhR19a439eVNa0jbtjRqbI!iDftJS@LOkqL29Zv32bCT*S6E8;kWax< zYKezw??Q~DXGdhwCCu*3tKv_C049Wj-FqP%Q{F0$C|0LeY2T@-Qm;ciFbtfiZ@_%4 z!$_+wF>AvrGA}@`H(fB6>YLGoX{lR%O0H5}J|W?)dbcrqPb;sJ*Zh1%uaLnYVFwsN zeOEg|tY{LHjphOoSCo6iudeo$kox3^j-$P+AS!DJp*M7%!4c>SOU+HaE=*LbgOeoO zzYe*RTp53}qfZpnM^X=@Tjr1pv%?riu&B|qNq+WgKH|t-b=Oe2O>2U}i$P4P`0cHA3e&I z0|R8w7}-|c0v1=_AI8s`ISmnq$zKmVN2*|~CLi=RV6z~tn$XMqcd>FCC>`@PPoI-uQrdd<8=r?>BTLfA~4GOV@jB=Xh$k`XjQ%sPV+BYN7$1m`>kr=DpWj%+&0uNRkXkdGBR!P*&F= z>LtBB0sNY2vFmL(ly|gnmHbB}C>sVquE@wO=n z%D`GCS?9;9qrFs2{JV{`T%mtqUkFpcXlQpwEEj`O96hYEV1D2BIgkD$%tv{Tz0;D3 zN8kJ6DapqPeY>}~T-E`b?-|2dnj5x1^L&z~S5i~1)paAL*|Z8(?124R0*I-6c#=(M zqAM7=#^45Kt>}>N2e&G25+e&=SZ0~2L1T-BP@n+>2CV|N7LB_&B!nHLu(!ibn2MNX zZ+A!LNVw6v2Tp--G%kOn>IYg8ZNCx`3Sk+5W4Qg{Y5WYJ|_n8tKyrg6hm? zOlyTDiStE}d9i#(|1f?S$Lf)Gs>lHi^n*B*pP0 z%xfcm$JkOQe2TYY__DLN5X-8#8=(e%1E!&J7a+%O)prokQ{?VR)1m{Ws@b&hgM|c{ zk+Ap!FR0vAe3$BZ(1)qg_KKMUe>LSEs8{L_X~|UMr2 zvDrtN=x@*;gt(+TsO~@L_VDK?*gs$Jg0GRL=zbgVSO|wNI*p!o&!toV#mkc3C>}dtWDOsAB zRQjVu)J9qbZyKKR7v7a1}=A`cTRfV_s)0NbD_UCwwS9)`83Z~deiy%lqQ8> zL4vK~fdY&k(&uH}x4{Es>L<38(RDF#x6+EK4>^OWrSZUSk= zg)~3^I_-n?;Ag)x8tfr0#+iwq7P~NjGL^Rh>2?wfUC66)M!IMs zg8^w1i8!$lZ?PCaF&Arvr^esZRw$6;(7s2~ib2yTHlgeA`7=zKBnmSQ5h|>o%R7j) zfRY$#7Lyo7eX-M=ZcJX7yQ3ckLLy(INxtGhJ|S2|{N8u z{FMz~1RN9h-T_IQ6G_z;GaMnmnBWXt%)3Fl;SQ3-BdXbS3`p`EA!B8z>HDNA`1lK&-h(x}Gv2ZnXZe?P0;Yb=W z@8Az|vT=wDx3po-Gix7WBDU1T2%(x50}tvuk?7eQ^|;x@5fj#2)Ncc1a9Ha9QX6ek zSb0&TffG)O#z)m2W1-)|Vb;7x>d8u9GCZ-{zcXeu-liOzQG$kqE)BvbP=C*A5~CaW zfLol_M}@(AH=CyRAX(7n?m?*_Nr+#}6SgA;bp6?`0S% zDJ^mudtCDIx*-gv+$ScY+CEwDK*BnB5EBCg~TLqy6?pn9Cn-j+CGw}&u zHdtZf>DTKh)c@h17LC}!-irc7`+WS*@8G*KgrU)At7ufm*mE*2nOTY)M^jT1KTx;y zPHuT=ps$xF_zBOM0RxNi@e|SAXamr<-oCeW`&9fns_N6BjM&YHOAQq)!iy45c_lI; z=b`&z@J)cy)#!gG0Xu{t?uCn8pZiDyWv$`;Nh9ZQo4-A<1{iA*#fzjnfoBDYVvqm7 zp{`0Dw@L$cxJ5FE$Z90iCibT>k5o;)ffb>^us!LQ?#RsvYRko>N{~%8&T`CdM`GK)GG*zV|4( zvH-m*ZG~wuH)qkkJb1+})<^`B@Kg)F;yU+ie8lA=8}ENh=sAY!h$Ks(kN7p>3n4q3 z9i6=t(A8^)`RIW(9EZvC9gRtW9+UIu?l%p{1{{IMNvVHQ9*7yv2pU}Y=e$=v9)q$! z>99ODgxaw1&wB!qFCCp_t0Q07-y+gGkt2VBGvq1AALYq&+CQet?l6jP3@v8BDc!&I zMcD*j=Dnx06b%=$^AlbEcnV3G?8n|>3 zyQZqWH}V9B2!!yjF-Asj?>rX47#ug=4Mzzh?+MESi1iZygG>C8L0s`0h&Jc2W`TT& zQ>;_`)w)E49NG^sf(70JREVkt-a;ZhVPT0ceTkg%fw-%h02YaN8KW-d7f;j=v&SF> zk-b+vsZF31hMjFq{(AF5Ql-aX)9C;8C-`e6z}Qc?WuuX1Ap9})Aq4s^S-K(?Pf8Vr zrqmRn)%OE8GFuYg&}RsT;AHJ3QsHIo-6{ZmYcZm=zB>7mylt!ccV1RX=sTBXQ=|T2 zD~stuKViZVW>4bU08|-Z%tMnHumhs(PZYwuzN%7Vz0yg4p?@-F)4ERwRa-C3Y`w*Y z1yLM~%+6MQqWpD>ASlMtFH$&!PzZ~jIyaLf8K3JC4L9jx#<-A+eYY37A;Je2(W*rE zc*6)NHH>qoOXC00bQWw;b!{7_OFEU18oEQeLztmk=^Q{Bq`Mo20i;uqkP?t?=~P1L z4(XDvZ}Ysz_XlS7KGt4q-F2PU>pb7ZVoJsBN$9zOG0>_&SHS%UE_5A>sfBEfmd>}> z?}n8-sNYFmo1dtg`vfJ0Wys}Udk2>p9R}5Uh~JX_FO+MxSw%l37VJpz>knl5P4F=t zhc+fUTUNGb+>X^ZM{0|59@;iHF zzYHP-1Tgu^QZKtX|Gd=}={So^4N?wzO+&oq`OihIv6-_Iu?%5rmNa4P&6zY)cAoo% zIQ5?hiH(P^N(TOU>p;ghh|o=txRKd@!SFKD&$8&tCm({IfE)Wf3yRn8jG3W9yBWB6 z90WGU=DHL3*&)&P5zs`ufPTiuY9I}Hj>l5c(E`%GJ`QY*aeB=k2*2w166KE#b?gG2 zru)5|Ss!GSYW@)J$JD1<)f8s7?OwblY{u9VG$Z@O=R>eb89rsoK(^Z%b90c}v& zdm;-e*lBs$Oc=Pkub2+fe4M0j8`XyYkxHq8jxr;C8hA8qQ%6!6vzQ!cNGqJF)XE+;)QN&zqn5 z|{<5QvRF(qk6a-1wWCY5?eq;Ns3;j^*qx^d~>z+)&@Ki(UsS-OdcwZ1{UnoUs zbwN9(PCST)^x>uGwb56b)}LIK`xLWzCue>MTKmyw3;FI19-EDJl?G$>z5Au#dA#lM zkEvIhI-B_`(PGeu97fFRvOFwFYQ@@GVx;;_Pu=d6#)M#h9h>a(F2j774#Zi z;ESxxb!wx5qM{w6d=Ri4(vH+6xXDIktK ztWy*y@+rm-%;mZ5ud%6%zw95zdE>g@eL<<1smp300IcgMO1_a1j2C^SC2ZD3R1T?{ z_6)~zR+b?6gvhu{#++Rs!F#XzTj1}?E|x~1|03wlXV~dC6c^vaWfPC8@kg860=W{q z&5Q30EIuv?3+W2o>*=_o4x?^&&4f7ozEbZsG|Y&ta-O6-`vT{?Xul$a zhFB|kPit2QnsMvc(lvSVdvCNORt29;b+OTpa{Bey50XKX|FJ$|)*uQ-V-y*#YnFS| zt)TTdi;sPR4QOXkrpFZR%zf~%NQx0Ax0^PW(*`I2G3)$RtExdDQAFm{NKN^YF`p{| zt3zE1H~ymjWa19Ze)lYkVeC7L+iU@?6#H+^)Iqf~_lNe~moFB2+^lK-^<>Ri`ZiG* zB$r8KH<=+6yGoUJz*&6vD$?+^%+)TC%6v-tnm)dSNQ6gCnAh6H-qs^X`e`0_+#RW} z<-g-%4*05VNmIaK)lj;z>V-};tk!lL0sUDA5hIa2h%RB>MS0F9HH+4zZstn2*l&fi zy+52Cv)EE)0pBtci{Kv@0`4*(6Buj5E_Gd}B@&0ZU_zA(y~@W;EitK~Q+vjMsKA&U zc2ecaiPYPUF%4vZx=1T*D zx`FV?ckU9VpQv_=n7hA^i|o&alNsAE<@wdZk+Sphc3DPFV`?#oNCT2*5Yis!2AK!^f!=>s9E=@b3dc^qMP)hNne8V9sFU!?hY$|bRW zD-Nx$_qg|b@kie6~x#MIburci|JT(<&=)P9eLJ+U}+hlk(m#r&b5vpMS}V2j5z8@@DNmwW4K)q8(|m z<}2m$Qj8no;=fV=wP(6DPWh=+PevQC{aA$Dn#d|*x7pU%S-{IMod!!N0ieZ@t`6;q z+c?jLIFrr9Kwar8;9fw%>HX7qy*KDL$NR+f`063*;wM6|klavZB~8kb=Zb#=y^;4; zDxxzdJ86Q*cQsZXajW`LfqyM$e$P%HzpG6;=PpMKYXGH4Y^m{|$Md|Wu*HJ=BS1>B z4UNB(+^u>^lfu$9m{@*$Lc1$rC1(;aXFtoWRXa7e5LT8ACZhJ^l)V2LHmagwj!6Ny zszVK8^xp&cIBK^``fI{JQn6DA_fNB6XqqIK>~FTrEX*G|-{9sT%(mTfz3rFYiW-5w z3&}Q^Vy?E&fiXdLA+-` z$ECCZ5Oz+p#OIz+lzWCV`ddjIsgP!|^HDyWPf5%tv71bHA)}o^%7mjk^pq5+& zhk!Cv@oKs(nX)KTKWc9ixfKJ0_?kph;075Kq`@E>+MGr68ZECLf%8?^H3FxZ5IVM^ zUj^~f>-$Le%6@lvC_oPXiS&kBXY(6bnP|NN!gIj{1PuY>7th4Y#V zHrCJeW}FoIH9~THp7XW+-a5z&Rqekm;Ti@O78EVg0e*j^&Zhue=eFlW%)EKfk|*RK z9?z;_^$SPbk_Uo+(LG=}jra!e5PfILvOiDr;hXterZgKcroBkQr5^^}4?#lp zrh(VdYBNud)-r2Qr?#XT_*@qQ0#T(KQ9CV`F^A3p!Kt=f^W>YoGhJkWR&L)f;ZbZR30{5Yw-aiMigqley%g za5i2mhDD?KI|C*$+HE-<1EdJGAMyeG+GCK@F#6H^LRT%hT`pv=S)z3i`tYvz^(FJU}DA7!{XV4X6VQ7GxCw#%R9KgrtG`O%+w;VUylC;^L% z+SaGd0O62WfJO3E{;_6P&o*4Jrks7}U?Z1K|CbbaIjxl{{m|VjDB`d0`g7UG?kra% zUD>YxfA7GKxHWR-OFszW07e%*q%w3Bb2}F>6y@-&=C^{X{dx+=yCX&{zj4 z1a4>a9>dwuvGr}&0wuW9u%Lwcg01JObun0cA(s^_=u`0-H|av*4$6qIckB1{e??4G6?Tfg7dGFe;9 zxGL`$u%CXoXbUguzcz%wMbQl%eueV4OCR@jc6u8)KOs+7|K+qPKhI6z{kK=rQrd^_ zKmGzGi6Dxn_eFEMM}R7YpN!VYgHru863-tp`NaQuth?Sb9YrF%6+f%|9?+aH+*SA0 ze2w^c(y{7o8;zj`Lb7#Es`BHcE-E`gnT5!(RR|O_;4DK;P&Q=NW*^N4 zfj76jXrFD!(NW;!m~H}4=e@`cr<>~yOunI7WyE)9-2?k;kwn|@dIpqJ(}W+Rs=V&+ zG*qwvFr-Q)BFTG9sk6zFi>N@3>V%ay3g%&mX}cPZ9Nf(n2%BIaaBbN=aBrY!d*DtE z0+%o-`po+b^EZf)i3 zCyw8m&|E6*=8w&9p$xxJB}UZ5l2SD9rT($}4q`@`?^ZT;PYoR^B?2zRX=#Aax}RU~ zx`6t#Dc_a;wa2WPE1QVY*4Gm4R=HWo=oF701KY|U>?hfK6fK$QE5IYL>Z~yhC0|j$ zpvrt_T*Ez@1jU29_gRlKWG)M=<*>h8E*3f$IcV+Ba#zE&gP*GYe`URIL}@S^SaTAhk=GR>kv z38jV}Czx+1cG`W<7J#vUGw(EU-%$NK$g41I*=tBG)zc62b-N*_!bZeI>R6S}6&w9Akp48dyNZi=cHR4(7G+6< zn%L==J3pi_Euy*DhNjIxJo{!yX;nX%+PMI$ho&MVjAlNby5xP=ua$7Ww3^SjoKwKn zIf)?U8n?|$Chp*|U@C5Yt?*V?v(sRIO6NS6s6hjg?>;&|@}qDl?0~3f-{)*-&lJ9+ z|L`ft8>$HlGNt^F5^Y27EcKpWhxAw~J&`Fon!KnhPSf(YDT5g~8QP*Y7Q(ewhIu3o z1?ha;jb8w2&Pn&?Lz3ne0&^AwA?5G)iZDciJS7PfQuW_S`LDNdNc^*}&DK3La18s& zH>O{e92oM)U;Q=vviMn7qhOMu*5Ix4P@_`pbQjlID(GZ8TR|=%kd~xNL^ote*Qag% z@Ar8-|GLjs>&A`Ax^K2hd%_?ct7}xI<|Oj|x?XAs$=4)$w-Ey~{}}>In;@&)?EUGy zu<}8X0ufC8(l(4qyWtBeLIdbOCLi7{Tz~z^BGqIcj!1~m^v4(qWF9FYerw^qS8$(= z&5lvhX(AFCOG(odJZbE+P@D<|)6~B%XErVM%s8X!&SQ-}?2pA=S^LKPcS(BWG((Fr zZnEV|?Cnv5UAa(y0K~`S+By^lCSv)Hkj$NI%N?y0>DQgA+mk~4r`s}l2_)&#{CxIA zFPkB#v(zRtlyf@i>Lb@g%hdpO3uhWZDK_SOQUMO^Jo`hwWnu-xGI{BJvFhf0OJYw( zx8yV|H>(pQ-Qt4>yI0f3QkD#CVB;YHA7z2$7e_a(QK<(NIyIkE7@AyR6FL$L-Hqu_ zpXIpcs!cR8@)s+JPemRU-l!uzFD;T_cNV}NR>x5{icADNdPs3r*@V{=P?wn__UCs} zl}t!CVS0pJrS9oXWQJV_>6M#YEKt{^FaJ_E^$`+lj{R>z_F^N2UGscpA{%ii%Dlf^ zpM`4V%D|;Tq5S=Z>Sbro^^jBIj`QwTqAJ++7lIU_$&hvU z*lRC?REd?OnRkp1KjLt3iEPEwY782&>H?2w1?5m7g3b6fitc5ycsjc7Z-h9wlY+pg zxDmtJxQtWtr+{}1+AkmnK+~{$M9-0Bd=(;JyX7$R2Qr#HH(1krq~%*24jF*>d_+-&PE{()k_mVZ@D^)NVN zUL$W%RM274#_P6#HwVP`O2aaWM$1BnfLyrIF29=}IIOz0vsQuu(RPJwB<_uaA)SFn zUe*T@fOMpw6Z=U^LYDATGDdqd20L3&u39rz+$ld!$1f&9-XTM$wg5)t`-C3L;KOy^ zcZQ5&&Hs8)LLG!us~pz9Z3sHV*bD3+&Yq8b6T%(X@U%z1JI(T_p>~MdUw`9*eQDL% z#C|j&I54`%RK<0*18|3l%YFrrz4Nm#okSG>>~~`Ue^OcHsevP9uHRIQOag)Z4*`v! ztBL{8xpVxLr0H2@<7k3t0(s5M#EW!Lr{ziq^ytpONboVwEdaTv&TWlSL#t zbkQY;grVsCdJDk+U`YF0O4$&dJA|n&HKmmUPVgW=nYI zIf8uCe@LIdCG?eL?g9;Rt(y52L*z&F$iIn?88r%lP9FPTflU$}vn>Fp(XNG8qA;E& zE*53YN%AWgwrWK)ha3u6%%5U|bCY}M^roiQDZ;G0> zu{L#}*4FWf8)LxEL3IVdoJqv-O1)rwwTkNXS#10JA7ctbG7lXUi*kAw>N#sb_>36k zT1f_=-x18`swlcVcXB*gwMLSGKq``DW<~!!;;RX4PC_7V>JWdrKWEKpQ!gdKOQ#U? zsu8cs+_IngW-$O$&$~D-r~7$W-aUH8kQzpnuXKkHw)rL=TiEpaIPl4LrWgCCQr0rr zi4b5a|KoIahvS<*Xt5;X9kMK1vy69#-GOUrc;ORpIzq7Bpm?_eS)%4U`esqEeGol9#JJ zfcWk|IDdQ=Em8)cdUH&P54Z!$dLug3!2V_OV6=&g^5J$ow>eN{Ly|2iuWlOmD zqF`)161eH*vp+km?Gd}svJQjBezhxjc>1jT0q|uvd+}1E%j8SVJwTAf*qH~^El4km zjznE6$}_XsbTNOv_*s0v1I==P=7_jsnZiA~3Tv^~t^pD$-eEhyd_m^(iQ3~uCQbr) zP{Q09zO2+c0Q-w5;njmb01KPZQWa*H&e=fVrQfH$h21`hf3+*$u~(Fk<(IA5K&ZQWH}Cw}AEDXfvMuvgxp* zz(~|G$&?vNKBzJv0rQ!5j@0O_$R&NJTrPoVC`_$vfs$-L(7~M+$*ND5?8fh=6>STY zFECa;DiBaF)~Aqu40cf7#jsV?PzP#vP+;CoMF76ajeBD3Sz_LUR@5y6+jTHJ(SrSUDceW}pa@P8~P>RX|;<2Ah=NX~EvL z3lSZqf#>!u66YTPmZUED+T&t7%L%tD%^$IgGIHaWM1TTK3?`N2C};T*^1>?ye=1uO z^&k&oDI1^Grncq)H!Ddts-F%$>%N9xL0d)0g?|S0G~eOq5++|J4YPTxaMk@F@zNsH zSY*zQ#suF~w+tVA$B%y`wqR2*j8^?@fbIwcobsaq}Q6BW7Gf-@^JmxI@$XlD?wgmY(OThQ#xXxlsF8J-7{jtvSv8Yal`fku8ipd73 z%-tbeK<_t4r=?Rf!%@Ys;K<0W5i2GhLh@!hu^apR0x_b{z5oIv&=R9-Mohjx{;$2! zjCPU>xKcHt=|`bS0EY3;UQ{?MkRWP%y8M&;P~2L;H%82f1K}-T{O~GOL1MPW^Z0c_ zpP@VBm54OzJLwvg zaht*GXHAQMQxpIYdA99g>_lBg_#?Gpi_nh`O`su{VvrV+gCbX95rlYiyVX%kC74pD z%THd2-Jkq;yQ*M2mI5-cr2r<;G;Yi8lmSQ-Mqr{lCD*UeI7hGZ9^7-+rVE zX)T#6pul`LeugnvT;6Xq?pFBs5q29%L)k2#jcKa+Sk>LDLh`>zyNDl_!^&L7=wtC* ztTzYLj@N=)C-kmaiaP)&j1-#@(Sob}pC-Z=`nPd4fZycHj^y-KGxSqWkU7O_6apGz z@Zb=yMt{_P4NamX$_{Kk^4$EA@qr-76>u2C3CNSPb;At_F;$$)eR9Jb-I~K%r>fv^%H$0+o0YaUZyzH3kZp<*cOz$ds2hrjjqN#!J9r|J=;s`+)PsSj` z${m$0i4YU3v(QR3#?x?AWmYdGTMSmN;m+qL*PH}aL9>None^G+1R+m4=)D6Ria*sk zhgT=e;=k;BEZzzfI*7SklGmmb)v+rW>_NX)5Z)j#E)e#q)ZjeE5ZFK)f<1n9yfh^G zvw;qF#syE!UGWvick@%BMi9Iuyd*JEq5Hu%H}vn#PYLA>fd4YPc@0Dj-cb@IV`C~` zVx}p|@-OU+@z1>)=ei17LWD2MfbxIkLVFl5YYwaA5aQW~ch#SD)8Nq*;rnyHDtc3B zrvI6iSxy|YtAv?jnzzXg=Tqt2{rc||2jesiwSt^t1&0B#BMw3rg1#-j9!0*TFT%^a z8V-rX`)%ab>z}fC;pJ~q=0Pw9EK^ulI+3=CH=qZj<+(L^JWG4BK4$MaXc@kE>RU3( zRIaz(%k|OUn`U;7C1xh$^jRwq;?QK)%(scXk8K@sC_r+*n*0JUN&;^j4S_PikH=1x z?~`+q`Gy8FgssQ@>~h6-vfKX{pE>$omC)AQej9jgx0CBzwXV5BFg>LRP6BMyoQ>7poh#UqRfz}S$|ktP`?JRf?JG?l|G zYPl}G7kNmB%T<3@lg*;eve6bAzflBE4vDAFu!GqU^1-_{Smb^JN*j`pYNDv@Z(F2M zRFkSvTYow(ze^F;Std$oSkdG3H8UB!B(qEn7yd?_APZC5>%19rY5)qT0*Z#1dkH0i znrfQhLc)?2O*R9DpT4?_``gxI0T20J>0(Wx+Jsq(r#zZWxJMkFskZCpJHsscYvf9` zQjAX*)ryRm1fVk$y^q+$w#x@ZdEBDwQ7to%eFV-Z5F)^nx!Bv#Pdh+-uh7eDpQr2HUR#s?Z7mL?$(zB#x;0ptgeV9h#3 z8La5y@H)W->4Pk0(bqUPaxGwpJSZ-Xjb!rmIuCA!9B;Y-O>{LN>qkbEklCbDVl2DM zy=r5E$-DX|J1`jx686qI?}6QV>?k!~6!b2`7uQRVG5;on;sSinhhw~6;k10{g5%-w zNu|5Nm}8Ruoq;Da`%m*NeX?eL<+lv+2Q(L+p8l^5X%jpm4p`Ja91;i=N)8rjdPJ}b zHd_)7HJ<3@{qXTc=*S+NHj-ro>h(UzQi^HLKTjN<#P2(`C2iv6e zx12NS=7};~i04qm*|(!cQoQZ++X9%Mf}d`&P(0@AZOzK6Raq(qbX}`JNh?Vn*G_5~ zm4+o6v|@e6nsRl?pVr`zT*jG8rg0)X3L~t~Ro2+>Z1kZbV-)*h#?(~h^_)bGVq@-q zzctm6JLaDk1Lt`$Jmmbu0NdkLj7^#vW6dF7Xr_^8>zq~{@0?>P(}jQw2rtF-@}VTF z9sJ=)qL>tyS(G|MI{oYm`eb@M516WGr0u7v;I1WaY-XS*3gk8LlMI1TenG%b{xl{i zO%mT+zksfE4jd@pG4sRPnv;Df42H%P8Sb*E#Fr0->p(f#hCPa?{_VZxyn?Xc!(7CX zR|1G5B$mb=n6B*eQ@9Ob)?2b}fPb_;uyJn7RxyN-a1?^1rXbCw=~BMO$Y!S9(efGA zJ@A3ouE$jVDiSCHFV+WkviwyV;GU2^Dp%)`-B)zc+O>^G%jn?Bhw)wLj!Nprm}AL} z-x!G})lT?<_ZEcu$J1byMNr`^m-jTu^v_sk?W8{oI+2+Dg z-lz&veIHC9G#HYGLyS3RE{hd1R47W^?b&8}nvpZ^htvvDcquI4JoFhUI~_x|?AemV zB6!qkz^WWP@0h!=0YMR@gdlUo40D`}hXZS9=e0a2p}A)8d?5md57i|uw>f5~6d|$s z`~6h_e%I-Ccpr2H-|6X)zMLIw8O1gfF#lVt_jC{peR9jZ{<8*sfEe*%XK34NY>o2w zLFf5Qh26?a)%EkLMKe%da3x4lC;&#|6p}#_ehT@0`0DwteOSDxuoQxoD-~(>s}#s2 z4-4+;a9=Drmz{)$r>`wB5{6e=Y~zaH!hw=tY^UA_PnUnDTr8>)nORNnG)k%sNCJg+ z$ebhps5lm(T@T^|FiCd5<_AHo!$7TRbPC{u)F#>cx&X^85FcdH7cb;zxj@sz*PV~~ zrpF0MMC)3mKi(c&9Epi2HW9{%qQGc@esN<-by(Cjen;_k_)@z47KtOdEbOt)|5pH( z@tD`7msX&?+J?F4UCC`+j>G+zvD;e}hpm8GF0ZYG=!=SxzSxVR4kiDyjFZAcezF=n zMKg)|?k0*_ymOTY21-IwO1s}Y67!J5U+CSnEGUR-FMn|@)HVTChj(d9)wFK5Ga}^H z>b7jg#f7k}BopCA8(aaYU$rDx8Z7qatGmj-vlsUsTLVyF5Zx-?yXAI5gcU9#9bxG| zUa%?i2Xj^PaNKxP`Z&ph#orwiLffQ6E zRb~pWm$Vot;*6isdy!ChIiG zDm?#>r5m^xJ5F;=)P-bdL3#0q+~wru0h8P(doGj>iH$hE%i&yj zVvhlI18n?|3cfAHIjDHHLH#s~E3_H}i@g3!{a~}4;)abk^y=9wzZRp zUUjSe*x!l9(NeI$WRUpqO+B}x=Hi3a9QR8Kluy$hFmA<-Y+*NMJy_6#Le#J7>%Yz zo^pRzZ}iB^xP$d7lOuH^hW0O->glbj2#6kyZ6Ur0ehkNV!UxrH5DykrnG{oK!cWC4 z&o+~{Y(M5?xVHXxaGc2iD}|iM1Q!LVz_2uj9`^J)Yp05;f~BN%Y1H!6$KOvj(vpM< z<+}fVFO39_5h>Dx4LJGl8x$z)$*wCNd$jjh(YT8px1FCsmOin+H-DZfrYYG}|MCDJ zPLFw9G3e#c;dg&OCq{_%-ZNgguxgd4;%pLzV7|ZYLYKe?mBytS_Tx+32CK^yb)2PE zhq=S(w&khgS?Z-*@vGB}eZae3i8T{`+k9tBFG(|RCeu1V4zoA~6BGVNZnTYjW%qA~ z81ZDHH_t{)9$jgGq4$dzDfCx?C1$USPuDoQ&48}hgm*X*4_LFhhUYx70~S$u7C~9i|IpG#w<~HQ?Vv3AUdOLt8Coo6Ar|+d zjDq#**l$Nv8f!41^nwMSy?3r(zq=I{sFf2Ma!#{q(EG$3B^(zAy2-w*4($d05^ znepBI?W`^7Bo^4)LD0tb79tCKc(W8^cQ)m`JeSyg>c+fd3k#GT06Vk~6^#eOD#K1B zXEn`VM7B&0StjFByD(4_1h+ln)~P)W9bmd}Hd(@y_mmVk=%%TNB{g%!BHt4@cM6G<+h3=S8eYBjEPmO$7uM{&au_Eg^35GU&nzmggGdhMWn!=L4@h2yoyT}_x z3^GrpLzxAeAEz;xG~a!iKMo`7eIXOYO3q%R5jMTWhRGErX25(dtCmc{rLHMOFCkFSmp^javBqsF_kdzmkEP$-l%$qA8x ztwM7^(!=fiFM@G++3qhaASMqfAUIr8^<@EBvOce^2)lUEy2QtdIdo%&fvjI+d*v6N zzh5LDm=W*)Rr39!xmg_6w#d7cl%vF-Z1eETJMlR@kHHWsut%H4N2BDR@!{M28Kl)8 z&6H~cAZo3QzcWs9+auG`<73-n&?cDxXX#;KEGIzIQIZYuT0@b!1Ar;2FfX%>$SExU zDP#ZMH{UfNd5Q-|pZKvu!u4+j!i&3=5mI^2M>z0hv#m~2N`lBVO^ZUDlC>}_xeRC` z6`g3y(wO(rW`7FE5zhz`%7C)VXjsBvGNb#+>N33Fwk*NL))TpFUJn|*aT`xSVPTF$ z&yZk#K;S|f^&-NugFTgZa?2t?m{C!HcC5Lfx@?T}VY48S9Nx8Q*(_a{V!=woo!WYg zFojuR7;v0ocWTQaQgk`(*B<8PltK+5TXK>Ae#xA}kW+-)TdP7c&bFRRn4W!H zCdDY6w)}APx2x|(4B2zi?)%?{!ek`>FosO9CRZPMn1(n#ZAvFY7!&@bm~ibuqV4WwyZ?ig6Ed8&5o&p(K1tZ{R{EA1(*t86L`3s?S8l$} z8f*+~rEx+OCZ?+fd)am&q&s;juE{f@SS8MkUfcalyTT%aFD%BChzj`+G^=5?uLj65 z$>0MKq>7Z5_*`osVcBv_7rI=lPoq*{u#W`-^5jDTw=z1oJi#z?g`t79k!W(A5MUC?&jFyKgG zKoXEu8}hd!l=m_<+xWd-9d_sfrHH|Rd|ChiKx-8j6{47Mg%z1tU=-Qj7@ncTM{2dvzCS3I)yWc*MukwQBTc2N zU@>1@2s{B7xn>D?+>tcv#H46P|hoFxSzB6dH0NslhA zrgg?N$Tp*it@d5oCq6pblvM_G^nCpf-W904+odmj+iIfp|vPysqB{OpRkAeC7ygKyDc&iJu}gwY=fb#`eZDG8$p_U4I^;m0tgNxVX| z$5nL6m-c)vn%(_yp(wx;$i;?;3yPryH-%#nl8Bc3m@7eFpb*;H#AIP)_yGM(S(3Ig zT90^+xa6Bjrt`>?UyNY{GHJ17{^Q9x)B@4OMX?8J{xTQ%9XpYd_huMjxGeV}GRr|P zSRJx+`e%I9LVaCp&9L!pDJ`7yyR&jvgj8u?F`_YDn;J{`P5gmeWNDvKq90I~ndBYP z55!swd1(KAe}?T+f`>F@;WqTHR&%C*J)^OMyKZ=xIX(p>TGTdD$vjkvEo5PO##R;e zy3vYGx@Akaj*R~ymCjnU&+hF%GP9|Vc5=kD)(VQTPvtDb{8I`$$%AXj<#!X-qn}D8 zT&U4MJiN=e@n5GT5KcE#eb0P&gy+OZA*r13=1h;g;`Rp1zfv~~$fRx8Lh178La06t zY0J{dGjd62M?y6yM^G*V?K0*hA3wWP2pCk0(VhTm8dVmUKj{W{T+DF3$H{?kUHP7AskCuK@(%QNW!Zi2D;4hQfORYwFgN9)ndEf za~t8+mQWDRX8bpJEdix4TE)&wso%SyH^G=?)TdGdm>AeL$^L)=o4V5uDTWJO{6XTm z_9bNyzuUoJNZ4@J%?|wU;`edlKmX4H5TLj>IM=hhQUs+6D|!omUb1vV?h!6+NS#wK zKeS5~MC(mK7Q{+L;%yp(li;35Z1Rilg;%0uRD%ANr7v7IWpfIms@;)T<(rmQI z*pkz9c#*c))^RoJUurngr|E(qr%b!O#0!|n^yX-&2r(!;j)98rw}mc3K}2b7j*RGC zmZ+QAsA+cpE05oj^L=02^5u83k@Pc{e5+Xop`aAH178yGS1WtFGhEHKOu@_pw3uGS zOY-;9dXxhCJHgW!cPDvrXlXX*_F!u3*!y_0SEK$hPE)&Q4pcG6_j$`1iTJ_ydE(JK zUP%jA_j06|c5hTKDwRefc26iJr8l&wbKGqr%8a7uQG)q=Vg`>z>n9%QK6Uyk+lrfT zfUWITD!+L%@*?Ce%3%(Y8pU?&67rV$W;?phRRSlsGs-+IQUIAvuXN;3(}^^!qSB6_ z#p&Q)(Al8VpuYdbxr0(zlE0Q2cC*9gSA~bgM=gpAe;I^2hQ_>uh6ulj93m7)6Bj;O z%jnTbiMyQymIWtAgZC9$;`5_9=r3zGN&C|dB|Yyt0(Rg-{xc3|0$@8U3xXdA1aC3T zGYmeCKZgc(D(c3*E2M+&_K3=nIV2uanJsTl_2FT3i{=9c%Z3z~sBX&?%(ZM>orOs;%>HW>Qk--5A4uX(vxQuKDGp0^-O8KOm( zI=XC0h$)znT-C}szu5x=qOt_3Rt3}Jk`Jwsy@)`k0voZXe()22kyM-7feaLz@Y|8F zVv<=gF7NJfpWI`s5h|nF#|X7-2a%boQc^ilxml5zimf_n<-0>n%X`#aU)SIY)Gz5{ zh860ub)&B*X}wly>XZ@}+tE=jBU(QS6?sqt9*lX8t&LWlRQ$^2?wDs05Z;X2Ek6I_ zQm!HIs0W&?uhWdL+*S4RZu;{aI`da(lX-72!g!eU{9$se{pE3qpS9AGheBkIK3LJ&IB8VTfv44`t*cAg&ftEZva6is-0jw_ zQJ8%R$UnAN_w9OQ{aG}mtVM6w+Ooo{AY@kz5=)ck7o1 zy^TH)eC4@R3JU1)XTH(67%(!-+``u(p<_w{q)@F-)k zrGu|&9}d1h9Da8y&@;VCAT~TTk)18Gze|sU{fc>+QY(MC4isq;0KXfil=u8VOsLL^ zp{?8Bwg6dU_IzyL02lU02(6oj-=20pj%;olvwn7ZaEVHxow*yc(4@E`Wg$8akVkQd zq4BP3x}^O~@j3*3=A2_)+ZxO(WVm;(B~R#*o6$IYFy~FU9G#!b%cH8XgjP7r)Pa3R zI6I@jNZS*}+p_zps7s*ubojn6^H0IU@`6?3oLeKPPCmGgRFAg#z_XLj``_Ul$?`(X zOM;?LuAk2T_spC??CM5vx{@HpLqOxqpW(1MRE>}5yRE3Y(X)o;|I{%vY&J&)P*k9!H1>!BF3bn652 z@c&Yx%M2scymB8GILN}f%&}b9E%tv&t)w1mhpx!RdS^?N8n;~urG893V5Wv0mP{`n zi!+o@X^EmfC|km_j}-^Bx{HvIqBFCwg<@3ppZm|0!Tz+XVXh{BuLTtHi}Abc!n!uG z@TsR4dQ(Q-n+lv>Z=xjXqUFJU<3=Z?iJ)M#B1bP4pGfM^eJB!JY>`#vTVIXl|1t~{ zP+a$kCYSvncQ~*E^@rmo9ea+)6of5%W{TAo^GGW(=#i)YpX;pVNzvw3oZU|iy;QDL!^I*QdEdgRfaU_uT9DAN_jEl!ILOa zcD;F9lVFB|ct!L0m8@^y%hXc9D|o^#HiODWwv){z*#GIy{D=1-h>JU>`opn*b!Qtt zv063oIk`ReEzgO%N>+w3q(G?zgV52aalF8%R@cjD+fC9a`i3MF#z}DI8nM3;(32a@45bW&vx92q;+G<1={-Eyd%N8 z7{x6turMZO%*Z7)X_iE!w}g`T2bw#9ZBe`L%*qR3#R>O7>o3?R}qba$iDUDByYNDE3y z?F;Ywe%@#Q2Ydha{=~P7bIx=1I@YmfmnhA(L7?p`SrRIx6So1^Coj!!I9?KHvAEt? zG9;+HN&eu~&W0Qy9d(%bK<8(4SG92j?%@6D(a}T_5gLJF{-|~!j5{l6Z~y9(q1G!` znS1S<{F&hvl6^ERt3N`lvi!{x|2QUzkWX{l9WHf>SeD_IY?g9HmTaf)TTx8+dJ;;S zDH*$aC*A|=KoZq?%$EzUJ$KGZ>#mo~PmBUSyl354m-bLghrQ2|Ec1Gchk$BYcfLNV z)jE4*P^aqnjU@0lI!svpmDjc)njIv`W_JK~6FS6zrxWBJLhKpSkmqS_H)ZQemjpHq z=?|1mUDAG5PHT5BrD)|BHMe86E!W>JJs$yJmhsRBONG%?6{NQ5L%Z8X}-z{AVI2N6B_9U`jw>Ka#L{=M&1l)HshA8v8x)6}z75}Qj1ihM^o-faK% z4G#djHGeO@Et-BDg0A_>bq@kSZ}W|PG|kw20xWRlfFfMjy_P+meA8y_Ty`HPpd^a} z|MY9}#3aB2k}yw3j#`U{x^|e*PB{8KdS_x&)-JA?O$7$(EmYL*S*~of&zv*g9b0H9 z#@q135nwPk60rYy^>im^C9sP^>=Mc;ant%5>-FQnb$XtqHZS#UAucZKEXUJgb@^X7 zObOv#O9rm!3r_)OusDDJY`ftZ+E6mvlW*n-=!#oh8@KMBK)14y*P)Z{bHeX1aFW=~ zd0merZrDBPe!XV`-5o9_reQc!mbL<+L{CBn0fdSV{c`ixlgr;xTVMMmE1p1kX1eM6 z{;}Yya-R-qRnbSi+|W;@?&%1y_N?CM-bZ)VUHSN8z4?CL05M8hHiFf2_;=BQ#4nYe zMnvM|kObi;?C_sbF*B?O4e0Hqf-|~gdc&lYHYE>*7Yxm`kgb02(!UoDvRFknX&JQ* z?x}5DW&AoUF3e386-)wK93KzmF#$uzPL&3uTOng3gfECaiRh z@kEM!!q&~?fCj$Bi-{EwT6|Tx8IoIzwQ(K0bpi@s4S}vm8nBFPF*|ID5f0*&JWjC) zaqL{w3pVOB(c}b0rsu~6etA5-p!3->-HlL3!0x~SW`PXeKs$>`W8_%Xj0yRNK zw5`^9H*{JgI%Ck+`wzLUlAi83=4x-fC#27HBp(&n$~yE!HlMFwy}c@5ApXwR!M=On zjDIw~>P$YMa;0Q&srq$bgp{s*2ut+KSdFl>XgZuOUNvs!ddfV@M47|iL^%##mY1Hj z5!5`Fon)ts3EhJ2YdHC97q8#3j_(D(-+yeBRRy@ysZiiBzQIS+u~NpsX?7t3e)@m=ly`jP+5hXAS%4ndRHXM1(rDc|Xo%)R zx_2N^j{_}oD}$_d`D@sB;83)PAz-F`@{K-7xNmP>KDr*BO@@tvn#V(rqxdvE6EoyV z`yxx@Bx#Y*n!$8%(`A%l!zEhE`qI^D<4C5DmAVjZ0y>)_kMK+OrGG^9p#snt4Y|+J zw`pfVG*^7zQ@0tCaJ@sH<%m-VKSpall&B55`LY))I=neHCV8c$4v&3Ym{IVXnP^FX z17FD^{qtjF+Z=wB)acX}TMc4~wWbMoEmB0ZJsElpSE2w3Th`6M!*y=05+(e7K zG9NGOmgFm&8z0=B-JYuC_bab>-#_i)Qc!$W^X;xX0~A*u-dPZ|?DqxRf$vF{V(|VA( zh$LY^X0oPUz1*p6{BBIJMY1^Y~0Xw|ZfepN=HE zz#Vn!zDfgxtnME0rUv(>TL+e`Hi5c~T9St3fY{cq|E)3R`~)8B}5WiG8=S-sm&^P#=EgNG^zb@pT_)VvYx144Evv=ZH)?HHufG zu85dVTfN%MK3?(K2QB_ti+R5AD=w&i`rNXX-~N=Ec8%8zid?q(X{ zf%f$fhgHzIEMJdQY9@|_>jK{wij4WE)M*8!oi2fbHFMwRBPLot5~ly1NZGGV2>zPwV@f_zbCjY2pZb%+5w;b$I3dkr_slWX&yC= zB}uL04>B?z>!@#oC*_x8xH_6L$;+EkRp>6YPUu`noFsi8MhNI0xRL36yao&p(~fpud#%N-J(2iW8h|ugq3@mEL?%a$ujU-#pxQE)okaW2JJoz(VchdIaH zAcRqRPgEGlG`|o6w!nRFVL4NA;AmY1wrw?*nejp?${i_k*8zx*!Nb?zqjAxdT7y=Y z!Bl0X;i{2ItG6qATtSGyQ$2?0m9{f){P-vPVMMtZkjvxN`#A}xPDT5b^Q=NyCT0Dw zT6xBvR%>?RFijWd_pcq8x)H5dxJW3}0)A!R?W~|o4*PVZWkKdM{8C!zlS43Hjd5!5 zy)6!lV~W*C)6yEBHQ27tB+Lq>DYp6Hic4Mf$E4RkR*d_u6#qznzm2mYvGTc1deH6V zYJ)N8lcTq+HO}OKV8;>MHIOuc*@_NDXmRuz^Ltkk=FwS)b%U)|T>_+QBrk5WF#*C) z75m7QxrRPAQm%%|swsrIqfLgaA);H&wYUk~=}Dc;?)JD_liv~%k5T@F<-8^T5S z_ld5>sE1OVME@0G;yWy9cwb$afm}JfYXr%l{ANcK#-iBYKtM5+tHgv@r%mcM5Jf0- z+lobgJSn%Kk4ofe1i%Q%#wAjbX7b*H4fHVeBvef8!-CH)ph3aa$p8ncO#z`?SN#Z* z=|(F{Go7Iw-Dj?3(|n)fu1ZpSC%X<u1EU$lIf-12ync*?%&&zZ;R?5*1lDhTzx#i!vk_Jp0Y zFKFwQ^8hZ(tT&!=akRY`-BzwVVBT`V7$jQfDFZQy$GM!Bf1V+(94o*wg&!+OXAD6{ zwxUf!A&DR)9w3q3V=hD+P_Z5dl=m4HM@G?Z{!c6^+R9eW%rXBl(tgOivzo;GfCVYp z?E#QG$SVdbMvy6HPhb&{{@^QKWMyN6Pra+uyb?Y3Co8|Y7_;(PrP2w#BuCdA!1t%^ zO`sIjEirU&-Y}X0)HE^+K;8#hWI_+3~T+VrY+5j zoK=xBi%OQw);9{X5;$}f@hUf0TYd>JnU??#OpS4|FXd~kJNg0yILhL>>7uwz=h;`6 zc3G#Uo_K=Tq(tY!cL$q9qbL&GkeN$7atm?(+s77F+xii&x`(J1TAKFbn zGhc4`6m^Q7F+dCTs;fy4V%w@&<>6rIiXNg0A=RAMw@m(^^@4Cv0vW3o`1L+TLDL5# zx9QLmJPhpon(HvJ{<++!#DJiKzL9FrX_{by1|aqfh%0I^ zMSn3;A(IZ|^ON}k0-q2muDkRs%uUvn%`Q>mPR)$uX2iBlvcHWf=dyD$%WXJ5S+;xP zt$3#gq<5A&G=lKB!F5B)&v<1R%1q}GUnX~;@22!y*>chCI0Tv2;Y~t36YyoZu=^*-AF1T!M8<(3@yf(FrVdAvHu zoa8A4(MxI&!qpt;2pBGi6w4G72EoMY6bDd=8j=|gQ<8NRf**wQ&S!X~wllYexqSCb zP#87s)H78FdikxhjmHG-qClwe8l5~ENM_!Gb!1LJIfjKALUTL~j45n%Ps&13b)}a0 z&Cm55F_cy3p08{j6Ck&sAEA^N5MqLLkTqo_J-*#BHT`o2E-wmj!koNrG@ryz*WZ(Y zw$*Q9*`~%=346&=hrLuXmXL0eXmaC80zQd%7RA zAKO6wyrc{r>6rfUgXO=mJKh~I0*?~4L4;= zups!>5_${X#fb#FhzkU?gBc`jfXhNqifXUavW-#3#CMdr{*=NHpAl$N7bE6_)C)(i z4rR!3Z|w((KK1SYZoAeEqDaK=`&+i_r5``dYJg|C>FpuZSqDVY-Kr{8N`BOQaM*|R zGjzJ?R7Pr7B)+9)Vd(4=;c^Uwj=&RC$?l@9 zF%hAXxmxkNj#Tn9dUO&>+NwrAfUmuz-=f4Ltkiwv zU0hcUPv@*ZeU0dscCGqf|BUqRpW$xn{=nQ`uQKg&*qJJxyiq#Tv)TZN{c6h%8kGq2 zj0-uoA0Ni6_dY<%NibhRI|(b^@3dfS)B6S#40#=G63e=xwCB(%m>#Z8n6H1Na~r=u znR#mGJP9?1{7eM&+JWE#zMi@|H@#_$JCKkXz&zDwg;@13l(^(?ct)C$^_D#CW;^1r zPSyQ>r~ZT!xwX@!ZP1MQmhv~tsPO8IQTmymw|`x7B0Ac}i3KM%G)5FF(n4MQ-5^2( zoWhQ&BhhA>0NlE~RpUomObWsQA5G`V1r2+$D0Cznky@xKWR(ApxQ6~UjE5v#Ztay8 zT~I9H@#2qp9ZLE1d?Qjb0g!G)_G$N%4NH1qGgvAWrNO9}mNBdkb}I?-J-b~aevcljdHxmNv!xkBig(JYt(KD)It*;OW+66=L9RotH84B?Jq+gE9qxXT{F%yhDS z@T@X3Db6GmeTYB_JHHCPH>1cx(8C=|;p~~&ga<(yE(COQFDV;5p&RhKTpa26MOAxy zDOr1jw!@qC+#kha75(Ow;Htyv{Fs8wd6YUc-gvc@bruyv_+g+IB;@0D`8-0g*CW}O zJU_Zln!G#NIQmkGw3b_$E-L<|X5i#uXSmhviHX&rpGhL4uJ(rs33I*5dTBbTrCHIf(4)t{ zK@mi)-pA}-CD2?;WGyceKQkPDMX!ZR!EdK7(`*^TLf`=LhDwrgL|;yDJ%m~6{|G(e z=7c0QhmT9m8WQy>NJ7;RN;1q(0do?Ms5%BFk;tTP_kl=*AsDcrAR#P?uw&VK)~QVS z18w{Awi*omsjVtvrU`Xf{2;05XBe0iE;*1WIUX3+NLPi$N;t8Dt5BsmDS`1fZSPjg1%5dMF@~A`VD&GtATsF6k+hDfg5* zjSDT8s?g@eVv`7JXTFh((0f%fij)r~tY1wUXcS!*HKE zL5Cq=?E@KF9=aX3@_CokymTg9$$)%Vi&1VXHAK_4(O@f8hRUqp7)fjhc3)l<&i72X8^S{GbRH+(usFfwhR0v$1N1iTB(xc5MYe4M&#jhqJAR#TcO)ro;byYpqL0r#hrH z=8+?xVp-#_e4o90?!r@?P;4v-V?LTZ)uct=9Ok~f+RAGo*WnXL6zWd*ubJoW<7*>= zf-&{C9Djc8jYU4}qd+B8wt+I7$X9Y_fe90!7FGu25PCBaf@%km^s(^`2UWE2HemR| z;!nKx? z{$k+ZH80AVp3K#y^Fh%@sZ93k@9#WInS+zLK!)+v1c)Mlf^s~Fi>EXN@AC5FCVjB> z5#0G*=6K!PeY#P0p)S7O(`WOXYFX6cJqT#cR~s$8;;&hXicB;PY-w6mJ%)@A40@`YVn1B<+)WGFl6DB?L_7gEqg38w?rce%3I82(e(Be2luy85%^FC< z&2cuULUdYmOLN`!E8{S+%Q36!mLb`2(kef}0Agy$KC=DMgwN02_|aLd+H)g;NW+89 zXPU@90$$CJTBqcJG;BJjQA8ug3?N}+f2&08C6v^jN&pu}#62!4%;Tx0nUw(I3b_1kLL0%b8bg%Dw!hth z|D5C^28z%_kkxK5nuP5X2r{m7ADh5cQ*b7gkL_h?Tc<@x#u+`TCj48?eoh$MC9n%Z z73U*7_SElr@?1G+=@OoP^U})CwS6~o4Urv5PXa+l;zIhYm4oY~h8TohT$gLbR{RsVLVForIR5`Ghh*fB3d=to3sUuAqM$I)Z#E-g(fKg<21}r`Bh>0cb z8(;2WEr3|B**%QBiVkpnKa7#19{`SXN0g< zWX*Em`4_DF^u2O0NCUzgBT`OjXknTGQSS32ckn|p9oDOT<>&1Wq-s7)4b4#zc<~s} z#-o#|?|&VZm2z3r%T1jTE=dqS_3~uCFX4M-Ep~vw% z{Q1GpmBu28Mu2)>ZrSTY>@ZLoFq?CnOvfeUC=0rqm|g(*sNMXA3|2H>#H|Ja|FMoKDrIpZBYhY#BvYpWru&G$phnw^v(|B(*-FBbnj`N7-cC zJ`!R@y;%W3F^f{~Nu;ekXt33S2uAIAY|Hf?;!5I)c*Eb{=3OECIOHh|)emWVr754N zkm;K3FWwvdQVBFKsE=QS1oEKZudA!K9ous6j%aUx(R>-OJB{_~4&ETBaR9vkUYKe_ zch0M>^8t0GGXH`U72Z8-NnQX?oEuGny+-n)`|Db~1S-lu(*=Vpyn9Z>)~RJ+?;F4- zS#$ha9BCQh9{u|Pc0T9o)<}%N2X~cIO6?!-)VVZ1&m=6ZmbGrY|8Xwcei%5bG8?`! zSfytQ|HncofkH+ZgiEX*;lLK(6Wa)V89h50hoQ69wx|ZmTlxbOI1BbBmkZg(PJ<9y zA8#{Yf;rUMOkB6vX%Aeks(9lRXRWhu?!P~>KWy!AWf2o{F`)3Ty%A=7a^~uTR<+MLRLD%wlq*M5aI2l$wbng zZZr-H?%+6DPR|#$=qZNuuRT{A);+ZhdB$TL$-cjy*6m^Zz@HDWRqgT_ckV@jh19-;KDq3_n~ghWdP(+kBcbyp zxoD;w=Y`6utog$$#iFdftv(G&{Eo8UL%8cXMhtmHnakh=C|I2!1cC=P zUg(acqy^1u8FoL2Q*6>-mqZa(T6g})rZ#Syvv@!#NtYnPwcG!K9AIHFH>sk{nMXq? zGk6*3k1+*URtjU;NVLLsYRap>n@RQ}snkzJ7w=$iK&2uVE0HQE>?&KAf%35$-3CZS z)bHl2&PW?lo2#`vXO-^toEqrsRjcMufTpL#9YJSRzJK1@`Em(muXg|wGSZGhR4H=H zXOKnZY7nqnJawNN3S#q%FE>Vcv14Dx5shf(>)mWU>d7UI@>g22Xx3gbV35K&riP+2 z&pvZ%TG@ZovTzx+!EP;xmQz{``p`ii1^LlbS{MF22lw<1I%d$3d;*7jopAS&e8H2? zbQp`!j4Th3NV=}OZDE@m&T zeH~A5=@sxw_-foAu&)d*Vqhs)K0O6TO7lg_0D1rCclQ>Dh%B_;ejhbML0Jh5DZ@2k za*3-a0b|SWPaXG|x-0Xrz&U{$wyW$kZ=c2tla|M(PC9~-()oBahYz<)*qG zttNa6(1&dmbV(=;hetW+333PV>jeQ9vDXmvV>XiurFenB-+456b~c*NYBDq=)4b11 zzh?hJwY|XRMK8{0Pe=s;4ekRAD(5)`j7;sCRompwmOAPv1~+?~kn?XZfBnw0x}DtO z5sLQieT?WA!K7#@gdLH{B~n?u@$E(MBqua4l;ZPKhzj}IdM%0%zx6yk0ijXyVu3*l z{kaYfp@aI9_I`S1W}`${^hg*fmZ>bRmQ0C_tv0V#S!8t5Zd{^bC77*&k*#Rv!GkA zc$r)b#d>(3Aj^~IE`OOcSY5;mcGwbyM9e#G2$w&n=Vi8rOh@klR^~)qg+Cs znVm(}rDmV8Lm6F|LmtUcyXD8?ZR49k7rLW}^73#Hn6$__t;ZCkjYl<|;Iywlw=HVu z`hBVXJ~vJ*kWapm)z`<9nS5O&yi=6d`6(V9{4~r4^f*$TGKCp%RPmHG{l5Kl=+3#+ zKfHso+$UkCH2w6KRVo=G{6!zPBR*|Hne;HDR6x)_PgyEoKypn03RKzFsR&|xBJNk0 zQPGFVlx}lzpZ4)sUQ6>VI($hsf;|iWsccwK3tg8|g$p4n#q~i018a2c8;W$GZPtB^ z>=-#hS15rKDwdZ4jggcd@HL1zVa5~QZbCF{7YkdJZ!c@5s9|YEPYOh$z&_muspH~M zYC1T90x4?ohH?B!Vtd73>&kIgaU>0I<>ke$b;sM(7z~)V-d8HOhy7hHveN@0!383x4tZ=p2iDVN`$6B{wwR4M8e`c z8Qt*1bV(6O**$1m*-0me6cWej;(#;Q5%>3~<#$h^8_{+ms)Ekhxb2qvoV$(ew*$&x+nsa(w%#*}<2@+A}E1Fhdz~Jz9h+U7W~U>6(7!NMoBsFbh&)k`j=j zLGn&4pY??BfPdO7K-mz6?oI|c?mAU;0u?8cEuRcZ2MK}a*oq2(FIo1`#e~}|rt6w2 z;9-YRt}%zM6T;|Ot~3ntdaVp3JUq+?=t1(RSa0AK^de1_PRSvNqMGM=Z2D3e@VwGe zT(@`aB!7ia2@7b7F}OeTXND`@yByH!G3tf!%p2Vm(e}s?0=X3ms_;RP;?j%QL_%Bo zQEt^FAvE^xc;avp5(N7(6*gp@P}H!&IzP6k)M#gpQyrF7cUSY2yu%NDG&lC-eOv23 zImwA*i!}h2ReJ6~p{4Ltdq!xGV1cE$lrEKBl||^&R~>jaB3=wdC8v`?+CXnBXPJ?1 zkvbW7`28-h{d#5R)%yuyjN`}>@>WH$is$CFR8jO{g!~?V z9EQ>9LI*<0o$a)zh5EnR!ihCav)`~%97nDbqHSyT_0sNnP~G_y8^OB@zF@=xlRgsb z(^~{5rx7`DYl>4-LPJvEsIACU^3KS0#2;JR;jk)?Fg_5Hskr>8M!^z3g<$7}8R5CO zGo|!q@BaI>v%9aI6$U>Tx5JWpd{o7FO^YHtj$9C#mjoligshSa9zB+cO!a;9Ncp)A zJ@7pl01-P-E22!fJX6gAy_EP{5EVkJ2fp)LE9aUnxa3LY_xG%G!nsIBw@1icVYl1} z{&mDjQCV>)io3Xkg3TlBQEqf^7x^}LX9rdDRt~wE>Zs?zk3wAkCqzPM|6z5KHxF8N zE8?k`EGKMt+N_iul^Ze~q<$4NOz&N5P_f}Ri(l8x^Uum%e%j>2!GA4QP1$d!-CLIq~r0q^WT})A_-noRYdtFc% z6#3@aE^XI&hL8Y>?dsTFi62PCrGUF+Cx{<$!q7af3`)uH(1j4-F^G&D2npPC@rTK6 z1Du_;z{qcJMceV9)D3xRbwP(IZOYYLpM=#N)6>4Hvu}dX@|leB;h!Bce{qO&?>lBh z+x6)Ok$4XjsoYv}46kQwQJzbpDV-NTQqh50%h*1WK~o`;9(R=jc;tKF=PJTw*kiI4 z9{uzz*a)FDQ@jhcbwq$`pZ@ErHtD}Acz06UJLw^J3SYJVu28EUIJsxA%G0`rQ~PT) z2K~X>L}$MKN>?qaBmhV%?eDg|fO-zRAChIq8xz`Yt=`^vS+0sstz530EzEwr@i;1o zT2th37*iDZAbQAmxki?UL(XNZ6ukizk9dl_RH+rQDAB zu1NY+tn8?Saf4PMmi>2J?ITvlDk$#yM1E}c)?chMa8CGLAvf{yRD&bp+%TYio-5GQ zb3*>PnXqH(J#rf5Oj~%ji4&q7fO2UNIujokG(W883EP*v<-Qy;0ULW89V$;^ zd0uwK2|Rznt6(OSoB3Ai4I%DiAMtx8W%7%If5ieYrixf~k8;+f;eP}SoLWZ!?4Myz zau4K^Y8VMOIq;1nM8|f$m@|J4X5=B=JFbE7wVFKW$UDenTKr7m)I>Mc%Wa(&Yaj^K zbo_jJ1aQS*Pj&-kkL7P}Rp|;1%F#I7-S(|HCH4yi`0sb~W8c0KNYem6L>Gkf7By7| zsc=(&fsp@6K@0l+Bs9WfkiAQpV4aXD1y%5tPsGK6xyJZEgD^~J^HgR)RssfQxR1Ne z16vxT94F17ezInB{IhFK$;WJ<@I46hlM$Y{OFF`Xw?1B)m~vzAcFL8PZj{zKh`vJD|+X_ z?vl+|DU6W!bctf|H2%*@h*vMvY7Ly`4a`!Wh6Oo7(4f4C#QN8Ig+GOol9E98W_%SJ zUkAaRs41UNbpJ#u=Xwc@3JJ|?>+FAQe(`a^;tBZ(CdgDJ>vDC`{;!Yx=Ra_uamX_J zFn>?{3ScG(%-%}PuG@{$>o}-H6lGTDm8ma$@TeIGRLq?>+y)0s2G!y|N%yg;nO_Np8A+jF>P2r`diXGh(D*C*W<7x@C=1ci z5-RbH4j$s(rohX~w7_j5vxU9RApqj7E><~UJ@Q5=vu&P0rTAb!1as}pFCu~W#G236 zNYqZB{)1Ql`)kK7&~bjst*WmI8+Tn6F9!Go848T<))VK^Rc^=rn+5sYGbIj*F;JQf|?mv{M4xYhrMEKSX9+a~|#3Q*;tLx=^4 zlFAGRCayxgjmyup#}UU^7K>BOy!`)QD6O%CTMbfQA4 zT)h4X=6Kkf)C8JV5)~{QQEBIqf7}p|zEYv@jG*L)~>?zV$WKYDAqItC;0nK%h~?_2&XVTVA-`}IY$`?V8=piSq*X_Ru=uXrXK7l zC!mQ;$GA?Gl>3t`+9w5zVVsg_n|a6w+z6$iOAf>PGoT(=gPCKoEI+vC29PtnJpm{c zL&T7Sh&Sz!ONaTIo{E;85`sWxA9w^#53ntP;(tHozwj|M{(COk>3vd+*sqMSE;}(E z@!)T=_yDJ0v7cT3;DHaC=ijb&} zf2J$nsBQq%*%Xu9o1oq>t@kzs*R@#$%9H#^C&C(EfL9!2`r^(IFePBi-O+gcs}gs? zv!(m9G*Oa0mY}oN)rU!ZCA;#+k)vb_nA3tK_LL5DYJYm`UeRNJGpw~zeckW#BPSw} z|M)cfp!cYcAz?&ZspFqg6z~ojzF19zt-oVo35w{=$`CFZLI-FU>Uo=rK)Ut7(;`VV zcGhM`L^R==ceHCX)7Vb~;sDGujo9WEPDSZSOqR&Tpx>1 zoohiq?|0y-3~g58>q@1L&j0fZ07ohHNnWq~o@-8PunN-l?NrqIEGMLSxTFkM{J@Bh znZ+&#ht*^1E5Kd1NN;78vvB75pN|E?7t^~i>xmkJ4z6e?uxJglFlBIX@asLTqWhi@ zOaWzSTu4pmJ~D5#BK_5mk!_6Wo4IOp*+;4`ehFg2R%ib^h7C2)qDqS}nK)&%5t_Hh zz#}J?IVYB@Vc!1Mpu^@^%CqsZPX;-dfu!}UGd5={<9!;!^VB=_0j(*#pCuMG^AC#t zujUcs0~gWL)iE!gwA_A5ThyujB4Sr&j-P5q_4W~5 zcxYGTy)-4jG>WP*HRrO?PZO{rH#K5 z`=2%d1foPCoz-v6MmsM7M8ZGv{Pzzt`CZo*qup!opX}=&&*F0z_=&~ljs4#qBloUr zYBTQF_n#TLb9ITBzz2rD3;kjLf8%F6ljZdO;{y2SUj9FRA^-m+{55oU8uI@fNl3Qp zqY`OYVj)~O7|-EjI>>XqdnTaw`~!7qt-LH_+i0%%Q8M|QMPssS*KjiL*Jpl;kc`E~ z#R{WV_9ezsH>QR9(q7N$Jo31z&bd z17>f56>Z7U-t(Z2eECQr?P*1=8h*F|Og z`$782E8HwUB0U{eEDVy_8&XFM+`lRRd9ot4+e~kJ^4?Ne{#-jw)IfZiTwE%$%qcZ( zbF_Y+O?N7mE{N@0M~SFGVWxPQSC7!{QmfZZbO&JN0B0i*dyngKw^3(t4Q}8#6iePN zC(HWli_(nl;esti!#)H+_1FE>3*XU5$FmErQS6Pv9=Ciw6TrO%q{PuLuj^x^x zTvLlH_TF7-;McEg^I0cwf`Q{c?wG;Idk%1Pi_yMf`LeWgMmRf_oS9dYhSLXet&xN8 zn|W!woXgKzPxqYz3aK5aTHIOIpS5xPjf|CW?)RHpFVhG{4!5^?)|Rh!bhSv0qrrxJ z^0o>EjwX%fMC)nq|%^T0AgW5JmG)_iAUE z_9CtKdbe$Or(_-04zO!y;fZws`hyl zobVu4Z1NAacecmDig;to9mWihhCPCpFY3EkXPq0Ek}DI?YZTDA#!3YRm6o50(h}R; zNAC=1q9!M3C?3n0q=xS;kHk_4kM}Bzq*y0%JmYb$DW}!&G8V~kV2dcT{l27UWUj;Z zesRG%vq2S?m3s*huomd>G;KzQ{xn*!*Jv_}7QQE7QG_RQAhauNwjP*Y1pm=pdPg!$ zuW^hu6F?#r`KN91=y#Ezt3f$nQE1%m@D-t`R~e17 zEAnZ;;v&;Sf)@}p8)h_bRs8+wJl~WoKB{TooOh% z&%e!h4QlT$5q)?1FSfwGf6#5;;M5qAT=tmyYlgu<0cgOYUW8_@JtorP_N)IFgPbrR zbi0%VhWBp>Shx0Iou@xO1pAUx_xs&c6C?DXS{gaZz7N^Qk&7Dm&xywEi=&lP7>lttQrJS*vP4ok2qL z&T5mQq4Ng4p0G=+_te6Itble7U-1@W$AVJCbazg_iMJY@jfTg1>#?J^ug=`D^V(-G zVf+b(RwRpW>@d+d-`AY~Y$wOqda`T(fFWg1)Yer2w1DyHi0&WZwm_#%!sjqH=c=4{ zXcb{jdwHKBNt%ZxZ(t(8ckYP(a)`S~QF@V!$9*M$?JitO3UmSPobJAYH|D}$;j zDY=J=`=Zf+OzYk0yro&r1$Fg?7*} zDSJMZ{a77}MUFs>H^U*N`EPUL3ODXbuC8+p1Mlq{oNM8=R*Qp*)FnyUpsTh6KHKi} zH3`val6S4yei5Rt+CzBIaG736@+ zwci4^CNTOi!GSU@+Z_fFop7n_Se7O{OL`5qUnQcYrHP@f>D|> zjM$ib>+4!&XLC68j|=`mZcv77(n%d07ABY1K4lYR{&=c}_|&^7!pI|RD#i7XohDmD zemT`W%Xvk`|Iqc0eOH)j1a0)8X0yu-yTQdAy>6|Z%eaW(TWzJ0a&|GJ%d^@XrVP9G zUidHV=!aqgD~W%j+cY`Wtd|WlRs#jDX$P}#x}>7!()`U#p{m9VRNK-666c!OM?!V6 zQbdGBq7jBN^K$4z-i<~rFvkz#qI251&M&z%=V5{wEn19Y!zAXKtWPvWJSl|c-ln_f zp2+abhc#}A!7o|=T7JrqM`&plS{F+tC#Oq;@DOd!sdi5jFB?x)i{nqy0S>8)2B_+G?*pBg!d<*wDvf8gwIi0a*Tab28~zo z$4`MtHXtARgXI8B3y)P8T8~xC+2}x7Ew%Jk#YGSUEZ_ttIJL#K*ejo1nkt@y32e)! zG)pq79LT}uhPCI#ACrtC{9iQ-mKlkXxS3hQJ!nLRF{pyxoRIVCA_rQ&lxoNx{g)fL z5@yQge0|O5(=LWzD0U0Wr**_%HVx*RdRv8jU!fV>jR&}(@ z)7Z8a7Yef)N_5!V%_sezTSkP5L`M}=E=N4V%?WA2qoM2j*`ih27IHNI_orx}VL6mn zR1f0moc=yOX|Rg{X#=^*Dd&`F+Sitpw&Z*DBF8G&WbJKHGo@Qpa5b| zdi8zcK6Y{wbf1D~_f)4S83$RNfqYxdsWdRxYned!t5kBwop@+FyCXhxdzn3+hO=6& ziY94F;m;#B-dhcPxlYuzdn3iTYU7gH{p!AQ-+j9;Y6X7pr=P_k=*uom z73W589ykuolvGIuOa^u~)@~Z*xxBDfc_kxRE%|Kxojutf)uC7_QEkCdCU}6qojMBc29$_lRV(#koz5GF+nRc`kIr}VNPlD|GmATu|RZg6HheDYd zg{{-Kg(C6fFGBPf*h9;1d6lonJ-c$bdwm_u(uXDMM+$^ag(8A;Zn!IBse}cm(lM0J zsDu#wABBv|Ux+V!qmF0W&Z+cvens<5(de3Cc)mg>2kss?PQCksH|cR}nEbi97~yIi z{JpGcp~f1eT~N2V?&2#knn@q|_Brf;8Jj>M`>^J)OXM^>VcFiU#C$g;U~*}m>Dy-) zG#aIyxWg%U)BXXG%38zE=LXhi*Ac%s>Iu){99<39jZ3+CGvR_Aah&ct{@?45@Y{3szY}&LH9nF$h6OWsrx7wpRgda7H^P9(*t3TGaW)Tq{&9RL!Y?AGi zUUQ3!E}q^jJ8o9k8MNuqE&fn+44yqd$k_XoNmaf$O4S+b_v~z%(=_M+m;ak^XFGi+ z*L2Irhzq-0K&jXIx-ms(Z<#9Wnhb#P)b0)!^-UKFzdl_G%1O3Og`CNoo(6a{bVTU@X}h`_jjEO z$#-{lj4od`)PGib#_~8^=uuZj-Xsr*P z-qGrHXv%9nR;OCx2P~BPac*}d^1iN7zpqevR&BE8utt?!xzS0y^P=8kNY|j<3hzZc zJnNbCld~G23^@Pi#J=3*H*e4=lFVCxNu>(&L&TuY-`u7Rr~#fbzj>kd>1WRXd5?d(wv9u z{OGPRtkLzeJdAIWuD7vcD{P&xnm=!Txb6-(Alkvw7w0|K*)|2hXYL$_?Yb_w#`^Z{ z6MnB)u`;yDwX|LsZxf!J>%E$u0Q6>`NKn@N_{R_vN(*3 z`Essr)cN`HoR`DBgJZ=*fBl9HI&XD8Y913NjMsgjN9}pG&6clNuCc5O=iUfix7&AY zw+-uKs1`8bcvPuxKKu9UZ(X%+r_L+RL9GhMze?wPpFR;IuG1ZgBglD7wiB+GmAXck z3%4G+AB`G4I$TrW4x!+DOeBLoxR3B4;aVPTFE1p}BlL7tvhnMSZIybnt(|%ReHsQ5e_q$EHhiuoqX=u1cd-d!c+TwWxncgL= z*@t`dw(V8wx3lfg{J8!(UOPlGH&pMkdDWe5)lP`5*`V#Zhpb#=HJjGkXq{WVxgY2` zI%@PN;nOo*ZwnW`5-{Nz%|*yFaP8VPI;Xqagz@8Skd6`0+Ld}v^wvFluzqviaZEZ( z;t4*Gwl1A@pVR%3vG(rOCmff}TQ=*yx+=8arAtR$LrNjpDZYg5&^$ONnHSGL?#Z0T z^K{;=)pNhUumTIt2}mZ-f6gb45%(~zg*kKPXuPX!jP76k6@hu{&EeD)N_pU0sg@~jAstl z3gb9Hf|ee=dKi3wYm5;5OYG7$5gYh%VU!Ormx}Oo(F0)Ah*5fQ zudv4+e^L*Tcyr((J8alcTfBHlco6eO#)-U;ReCU#KGkv zU_88a@zChgr&l<(w8cY%lOw!6sSoBFt_K=Zp*=3zUAv;xlLzi7Ne5}Wr*2r>)R;3j zQBGiR9Lfzsq_ndxbjHnv!G+mT{qtae%=hivOBcq7aKSJpbsJAi^*2z2Bo^Ly^ljW2 z>&yjBB`wt&LzUKRSm6Sp4+>)qH*?L0lbr87NVwT^AwoPMg7n9nxDhZ;E`E+L`y4X$ zAdNN74GAIZz-HjU{$VVqE)kiB#>WBtH^{la{?P#F{Tn14DJJP=vW z0?8aSsDIeTI3XuhRXw$AwVAVC4mUN{cM#cMwQ7wXwhO}8wQC@C%wfH5RNJ;~wTVhG zIaoJANG>-Pqy!uEz=KFayyl8bRfs_K)G_F<2UIV;U~CM8A>s!CoUb}O6emm=7j8<7 zhcQA>!2_HY>PEOy4`Uu`y>%`wUc5A%&&ze)4Id#wuerYT;w)Rdbg}i(ISql2^Y5T> z?$CEhdsK%vbzaaGELbGcHP1$m9%+Mz3=cOx#>ETBrcE0IHe83isBkRC>0!g$J1+}d z-;hCGOqMKKYV#`R2V%{*d6;su=KAC&$PIO!ZlYXQH9Mm4>lYy z7UsmP-&ng{Yj*{_T|s9)PQZQ7do?5JZfZQ8WR@7R#G1*M~7d0lIWu6f;= zeltvV2M>)~*lv9;vc7QPlByiXjvF7$?w2|@RTF1(XaNcRe#I-F5R15c|4 zoVlUL7@+z&Ec0OOa&?`5#B{*vb1S|K36a+~xaitZA&RXwWt~hU3oSiSF|^Ke^imFU zcaL#fwtQLn)fLyrI2@6A8yVwzYvgoC)*s_3WIP66U00Fo6~Uc#(fdm~R#eWwxHD(& zFkIAG7k{;&k6;sD_1TLD2=Zqh*ARL6ple#6HnaESQaLXqOQOYa5yEN z4HE&__Gba?>lfBPc69Z$u)0{4GiT1MN{%4y+-Xtmt`j^s%4b?zTNUmK@KJD{#k}3<;nd zy9_?|SNR4swM2AZPn&yM$ib8fxGj*_9_7ERTK?+niYy{%$OF#~ zOBp#tB((>4?clY@x}(-gOmp22GzHQZ_uExGj}*oSOB*@SuQr zi77B1)4c)t9Ra24B?)m{9S>8~MSc#|evKVFCeLnp*0!dvJPtgEn***J)@`Utf{|!_ zY9FG>lfv@$IM3y2uufL3Tv-WYTh`v((@v|NO!ci;v7%x^v&MNktugDEw_$qfoH%K6 z*7ukStiI#1SRO^7ojkt%qkQW6jqFnZEy6ycdeqFx#28?d!^Vvps>fHzIl|^|ZWdg9i_+UfsR>;z11o z%;F;k?pa8Xn2ZS;kR{~KDYRjF|D9@vu=u#?~{8ujlguRk;j) zd!{+o9v)j>ZbX9Nbi?)6r#=R3-*~cy#K;+14Vg2}m{;X_N1{dM7bepUjDa;F<78A+ zL7lLbcbH=3BoNU;basW9QldP7evT~1ix(q$fQ`R<#$93L@2>iv^4H+Ohsv1fE@h|< zIGKxM6@+cXh+)V2`taxUILBe{b+U5s=8a{v&zT3!H^T3|S-> z##md{%<^F1f}3xyp7L?wIdkUB4rWcx`a}vvAa|9H5J*NXudTWnk|Pr#6fv__=^@xb zuh0|7r!{?|%LylxIxuL^kXR>UYDk2Ign1)*I^7nlc}hT^=LQq!Et%flUKIggXK`@J z1Cf^ z#RuSl88ynw#3RF70K9|~2#iUh=y*K45?;}^5eau85tOko-=Rap>*xA^vi$EJ0bVcO zn=K(xysC&LtB=KOK?|8s{=!$R&xr}`k{JYqya5}Y=dF>ez9FZKp{bGk=^=VZA`l^i zh?c(e`z{YFIHZ`~S0#6o-8+hpi}pIxqbL;0PW?gmk)w*O7aSMBW!p0DVKi85cL-dUN#@&z(EBj_uxr zKSd`_KYdrjmI9=S9}a6S&#GtL(6)akW>?E z8D49@;%{jnaE)DV>x$89W1FmZ`XaIv^nKF4wuILqo&Exc;ei02DG zb#B;D!vI20JTe<&F_`4>@d|L`vxuvbiRY86oyFq0gbYF8siYKu-Jk$H3(iEJEdO^# zz;q&6yd+W;C{#oSc>^4*zX~|%GO{=(i<=h+z#v9s47qb1#ZI1C!&?I+?&}+Qr%V|} z)<&a5r6y3?WSK<^OpqipUI8QZA+GA|*Qa02IpW0!bc`NrL&!va;l_BHMkRIQKIfcW z+phgc3WA^yqtk9-9%KcG2{ZLeUX(D3wdQ$)Y9?goE>ASHo{?$X0Hc)nFoN;EHRzs_COden&Ss;rH0lAf9$BeDU1rJs$?6;-L zEJJ6)gj4D`c6H?lnv4lAi;YIJXU{GN61t{r6&oftbam#wEs^123H?v5GWB2o^k(*WbLA zZi_-6QS&(fuv|Mz+u+#*Lm^N+6r$vC`GisJRl%K_5SL{ArOTGaQ<2He#Po|2$Mkty zBpnM|nIIO*(BxtYg#fq_!zI>c6UgSyvU2sx3e1!#!5~~fb7=Acc@Zkug#b`Oi1Eqt ze`5s5B_joajQ)-{Jr-q1A|*F1hqsesUM=8*+{vXuKIK&*fkPvU!g@#wBtkId4$ArE zkwMxRH}mJuuhy)brQIPB^0z2{Yh-7_lat~#92Lb&=8!m~kG%3~tz4Bn;^YOAVV*3F z;X#*JZ-WJbfVggtm#&pFJG=syFo<^WNNRfxp@*;`EPeaPwMxQ&$P@3LXNee$8Pg(F z$cc>?z-?SY%@x4Xmbx~w1~&(Ik(;pr&MhIdNHuZ?VC5>US-+;P?_ODt!x9#iS0+R( zv}8li&JZl&8zEogX3bisNUP8e0QG$Bm~e_bVLL>FAHf3c929I2X^;~Q?9GLozF{Lo z84z(B&_-6T0S}w#3B_Rijor$SIe21|#HO?#=@LF49vnK9JY}I-ZC#z*R31g1>A}GQ zgjzf0C(5G|g16ylNIV2&g`ojcAcW93(s;|lTa!cH>St%t59Au#jDhqc*}F3S`%&oCnlWVP^KG7ee4(D`dKu(sEBXBQ` zK#f3VjlvS%MC*2Gj4*OX-fg<$%p$vM@-r|PxxRB<{T_}Ff%U;A`KI!VMR1lZT@*uk zK;8V*Kb!|=V0haYhB(3`yoK>;V-vDkbINng<}Ja@70W6Sw5F^Z(XR7y5B#?t8SV^Q zn`cFRMOj2^Cj?7|1{($@x@&D)tFYokmlIAX5keu4Lw)QtN^*GsX;6UT)OcTbPV8b@ z89=7A5IebC`w#5RWF|D2glURfxM=g%grWP!iappTyP^_i93Sw`paS`=$?@Sek@&rD z|FG&h_FM_nfN5jG&_Ga5jvO!qP`GJmaz^&&cm?@Q82z{jW9xPP4Upv|u^bLW39O7) zW7Vn^)f%A4ss|!T%q$H+-?@21yb+_TAWK$k>1@8}8zQx5cw}~O zS+ROWRoX)6dm?|lOR2VoNBj1RtoF-Bv&iuN&h=$?2<5N?Au9nqVdnU#O6Qi1+2pY$ zuV33!cISTKLWC1oA%en@a+7&{dZ)fV*XYr_N}qs;r{_omhH=4H*<(P=ZBvUdI2 zn)fp}Z$whp_N6mR>n_#CQ+L zuJw={k&z+8LaYbGdlq7|Zo`_=xv4W)7HsGrk7#gaaR}b_7`!zsoB4xRW1?X6fA_xK zA;!Bi_Awl?Ydw0Rj2aiu#OUE6iMuOtgNi!7XWxPSs=_m#NMhn<4v&b^5e;f>?&uxG zL>`dI(PNXJnQsOq_YO99M9zl{$!3(u0wV9Ej1?DR^#>&Cba6xNJP&B}N+eWZW3`0|yU?yzQz+mD2}$ zrTwF$e5aPlY30dsas=+Z5#R_w@Fq>2Tpa{(d~1GI#F12uq+Z!56+Vz``kGRbEmhU& zCFE=~;qt7DzNv#=K;q!elEvB37F?UPbykhy#MG=9CwjCw^33QZ&+9j?Pe*!{=`*KS zeIjpJ#8m3a{-p8j9-Sy}@W;lSYp%PtIwD|`e>2o1ktZ@)KT8IH8=AJQ|(~1H692+5lZF-gqI$jvXEAb6*8=BoZ)A%phaZl#NlPT;&^3 z6z%Qp8IT-d6OdoEDg-n@HFIV{bFpZ719%F!i-i+;U<@`!&Ls>K0pF6POKLbtl57}d zX`i9aQtOkWCaHC3h^>&=qD2d%)9^nliw9$ z)|sQ9B6kRp99#fXEz8)mdCF~?0vtSu2;z=- zEFE*ivPBeFrSfxX*e0ZL(V|$!k==P`oKco1M2ZMB*02pZ$Qb$bQ$1i?Z0>OcQ&;s2 z4oe-pa@Gy6qT)Cep;@_vBLlo51-xU9zmgxR-8@PNC1b2lpZ;}h-0wMvg@Rbym@*}6 z$F5)@UHOJWjVWxBjQ)rRhAa7B4FlW6?x$8Tavy`IXI=X zr+tVC0xd7PEB#`G@+7O12UB{0z96<8?wdNLtP9~E6;d^8#*FG+GY32qLbCo|yg0@{ zep}hdvJh?{E5v7Dx&DUh>$uOFJ*zz8!i&nOlPA`VRok{~t7GT5rh_3=(iV)_-hKHz zibF((2eW^0(XnJwA9$sOsD;1dVyvD&Br$%`U=Om~r^)~_40qrw64yEg>y*0LW@Y4o z7ld+Ix@2jLi)>8V8jou5Rokb;yFMT?X-zM%k2_Q6cPup8NCXQz!JC#dC9wR{D$y}Nf0gp z<_a<@{OuSZAVray2+BqXkP-*D(~`^OyfsJVcqU-p5EpTyi0vSy+}rw3i#4z(N5U+v zU_9@PGfP{-I=y4s-*nTB)lxtPlnRc#JDIe#af8b-Gs$&=>lG*e^M7FkSclHhbH1U? zG{Vj{Ufg`kE!C)@6nUaX+%9`gEFc?Xv8!uSB^r#MtoF!A{|X!yKiNeffB=GX+rr!G zQ9_6iX{`q*IQfH7@Uv=hBYMQF}+%@e!FoyrdJD(-z?N%ldAs^T2pT z?&`*wJm2nUsQ@!(Os`%62FOB9 z!-#A+*RgJJiL%o#M!E2~BSjY6cvB^iJc@nN1|D-n8KGxb@GhEPb0_pJN0!&H|Bgh0 zqV(jEoqcvI50^|C^P$5BXXpLIdUTMmA$ienV`Af4uU@TmBI|{+)MkvFJV}qxj|sV7 zKj;bTNPgLb;o~zt`-*4)dA0G8o*-){%gGVAw?}}HW*tgLl5Vp*>sMrFaEwowPj>w~ zR$*Nm%fb&B-1Fw09{F!YJXU6%GuCbBv-S|gY8=K>iP*tvat@27&p5A^@gz-&ql_a9 zHc1(gsxl%`4iN~rKXGz$?0fa9YxCAyZ>?=&oWocc0k=eZnjPcPWt^`o(qNrW4+%Zd z<%APTp{`9)#H`zDLFZh%%uAHq(t38}t{fpTb;`8lJ;nPH3%(|8XL6j=M9G$kvHrvK z`^6h0fgDg`?-Z5|Fb)l8`MZV!G3f(C>g+x>ft&kmsX3LD!b2YXkP1l7X{5j?MBaxP z5tiM%oekH!*5^E}(@x9zhXFHZs!gBPRzpDxa}FUueZ)nN$XSy!>*UGF5)z{rgw54w zB9FHKR!RZ516;z0H~?MBxbg0&*Jq0t=e*4HS>C2`J>Ej72|k6Y4r5J`Q+|ric%5vP zx+g__1l_o(QOKIHH*Fvy&;Iff7eYD}IdtU5f$x!AF{ zElScH3tLm1#%guWHbWR#zDQTi$w_JkSp_CQ$h_}JevTgp+b$2mnUp-qr$6Rt7(=YYqSGD$iHZ|wz?b>x- z9TRe)9>?%FV=#M5$|)g=4|&i7v;N{C4xp1KgwYObXU64J!Kz^NUq2pn|NCYA&!85C#Q9TVsOY|#XQs3UUOaAm;a@04vd!nDo2XP^VA7>Q9Ppb$JrNzquD|jq~iBF9T4G2bBH*@C9DW}glJsWw1n77sStsT6O))pcd zS7UvizQC6>vCN5VOY70reIdj{c+`W}QY02HT~g(eTnXPhj!j+W#ClQ42_wOp<0aKk zGST5>$FX~wNG2M z+c?o%@YeX9dFGk*bK`2>_0K)z*}oa#4X)f9ZMwJX&ag@-Pq@OANjZ)z7(=dYn2{?!JL_D;MtY7-b!}~J_0$9VH)hV9RUY|>N7l3>V^SAa zp24Uao%J;+>uLG26%`wX506)J?1YS2&XSIvkc+vuuU+0bTQlByxVJXOtHaQF^{2N_ zuky-}9h}^7b=%Mb$M@~tSGu+)`jAu+SaPDv2`7{WeO$m{+?aSKhYd++YG-v1Z|ckm z_))AQlDN(ixM9T&mF+*|ArHy9+3nS%g53j63dSk+js)R_q?CjRz3jd#lWAulB`{>5 zqkWPi6wuodLP2p-+*5O)Fmh;OZd$vb=0OOT`wjt|HDh)Ka0*a3rz<3NOF%|QZ_e!5 z(Ll+M$N|O{9xSI?%8wei9izOa%Y z8#53vJ0%w`Tv(IX|L_n0ux^@A8&dT7&wswU&@E`;&Ud}*U6s`I>}jp52=({A_r3D- zpZ~mEbImn}0RhoczW@F2SKxo?OJ7>y+^AH@cr_azbs$+(wB0c*bNn|FS+EB zstEM=BOm!lm7h1f;SJ?UPkK_16@!f(ow{>gQ1-L?Zq9mQw*EXfC%J8IEqV)|tkz=V8 zdv|1G%CuAJef#(3m1%v27{^2|VFyx{Jin|BVOrp=ObrM&WpY9#N+nde-tVIobs=)ine&nz9#-Ob^_+0(%)7mSkN0xa_C@UMSMEo1hARZl8N;{c0C?2*tlJHUW*m>_w=r=>>l@$r#+oK|;e{90 z`tNg}`_wc8-l%6j^O=XM{K-##QvUg$|G63sFbJ+a;t`Li$73D7sE2=uhQ0EYudKL; zz#{v|2ciZ;V3KzHPb<Cm7uP7>BOm$5ipTWCZ-4vSa{l?} zmnS^o2{khE{`bGX9;DBRc*#p%QZBmaqI6V^Pdo=Ep|xW&yTtSN>a>UVhu2Y#!`kHjD6C1qe(TK% zb;bg4lo4XblVih%z8ue{oL~R?*X32OdR5+(adY{nfBL6N-n7T!{lXW%Q2zLj|G50o zAN^5%wnhDc4}73}^{ZbkfBxrxUVib5Uld1g0HA;PhkvNo^z=Uzj78tx-d+$c7UVnM z`OfOeP=~VwkuGBl6kJSJZjn>VkVd+xdA-~R32ss(Ls^$(c61)6x2Q#5f*V*OC8jo_(~>^-K60 z0i;;SkJ%z0NExq*?=e^&3m!inUa}^%nu3{rtCvjkJTv&)+uQ5<;K|<{A}gn}PmK1yk!SsLUF$@It~@u#w4`r5^XfN7 z)*cTh59&QF)(TuQfBoyr&wlo^`uls;jOl#zLEs z@mIh4)%E2GZ++`q%VQt=*xF?HZ2UMw%s-i;FTF}xJ}^CbZx;lO?)=VozEkzr?^8dy z>gZTfZi&$%UlF!50PM}6doN60v=lz7%o?d@%7(+xrF4v_6}`o~tu9dm9&jf~@Xks- zI*iqkXfMN%8p1Ik9gs|kR%P(2lT01fjg%*8f{ZTuP4sK>q{)@w`nR@-ph$y)5sbIG z`7-0J{%Ik?!ue8ePINipgmQn}#5!0>SjdS1Wt9O>yBT++(?VWAaz==xFt&Wi3V;zp zljVLy(tsj~22GB`ZK==q(*ac`)a3JO4o`>>QS|CLV03EousqLm9k(I*oh8otkfY}B z^_`souYQ&BBZ|m^x>z5Q;e{$siIB;IlUvywR=qAvU`sqx>XP3h)Y{fIr5s8w#?h3= zkrQgM{pL5nselDcno!HjU;gq6c-l=!6#~l3W(<)gUd`*Tzdqit8An!oxBn)*NC>4x zAhp%MS?3C%b@WK{k7%rgM=5jEr% zaIwh9#<7Zic(%Fow>~J^t)3>FWFhvnxL2JNB?YUnhMg7wXaFwxc3jKecvc+uFg{-S zA(0E7AU_B-aFv52-;(@{4N#CzN`23sKx@#4jY*SKeh z;2=ZD5ySt_{_M}{TKDhcE#{3Az}WIcwzaiYjFOV0zet;T{hwA^M607>9TKe{NHEX# z)1LOUDp%V4SAX?a)d4|gk|lCPUi24+_EdNDwEyOe!-A7RO2_Y8wAuT(JF-5IuSwZd z$591$$u*84D!@T@Fi}gV#vF(-1liv}Wo~k+crjh8 z7(j2>@h((kkh@o2k>|P2E-c}o-pM^6D9DoMnkc($0iiRc+=C3Ph!7Ec6EQp!L6cWN07OjZ6E@6HTNu@BH{AhyIL=R@9D%5BK0A|NaWkz_O?1MJQI(5+~aD0 zj03CorwKJ6G{)e^KmKtQG@e63sQ6wz#>V|fr#>C4crMGTDaN5G2$UUZ#uLyri=g@5 zW(Ah2MdEqqop)YcP`>A_5c;6h8Zhy>op4u2d8yMPkf#breeODKR#!)IrY^no(rS6C z%RS%y?stn__2k0!fL{In&4XzXHpP5XdPf%h^>e(%_*$6UBs+F&ukD;W_q3`QZC(H* zo@tjh?~=vtNoE0+L%JnpE zne3V;$oR2aTe#GFceU$e`QJMNlr3+xBXn$#@p?jv8Nu*5#UnI|fRRUX?DxUQ`Jvov z6A>ANm1M}h6(e(xHHJh|P9iD3x8t92-4-0Sp~?02jY?VfWJ_JHlk`6^;dJpfUJ@a2 z3evOXY$;NXc<*^vt&vcN>T%?C?6)_@d*piAvX1H)V03HOt+(dYa#;h&p?XBDd3wGn*(*hS@o}XK?q3$)Wc}iRK26`|M{Q) zS;;3{bgeWXp>EePRADg!>W2Yqz1}}3JshhvM9ZB1?ce@w^->CZ!$KIw;n6rTM26rT zqoF+x6FZH9OX_*W%|S?K2dd%aY49U(-`b`g}KI6x)oib?~SLk`}k=m@@niv zoje2P!$^AR-S2*Pb;x**$Q7Nb?f0ap!;xh?_j1K+PGV%k-i;!nMzJrB*w=&FqU#N@tR6X zqxXF7*`C4a(4M(s;F%ZwP(-qN_iJs2v^LH2i7qFcP#OR~z-U?o(mRP+)dbz(nS4Sr zIOmNmU%onoXj!h$S!?;+fD&ZNo5jFG7P~t<$mqG>86{iw~oN*2QXtfdycUb z-W5(^K>|W!AV=uQPkwUk|J}92_W-ARX}o)ndeoyTNHrGbCqMbg@}nR9s0uou6Vm?J z$39kE2aqWYhQR;(fB&z}J)$g+(ijV`^A4~mpZ)A-*U*#DxN!u=!b`vdF-92mPyYcO zIWliAdeMujqG6B#q;G%w+m+B7GhWCOQOv93URa|RJJ|z*LJG!>hn>u>isyw43RCvV zJqI%nLn41dC=>_9-zWXRGUeYoHm9RwS>|$4<|zl_W`2c6yc^m(n}IeUXMlMQdF9!+ zS;a;f=@^R^EzX#2E%VPk=R|bDzQD!^}V$x zj4s@49V49X@9Nqf%*_!#A&y86OeBj^KO9;w;U6w(zfEQG#Nd)Vb>{|C#L|JBbIFM3 zX>orvb0tpdcZTc1gF|X4kMedrm-S$+IXY!V<`JADQ7q#q%94}9PQ%avDNS@nnf$mc)*`A3x)_cEg4pAap5 zgP_VmJm;Kq@^+TfE2hFp81VOh|Myh~KJR(Ys|3++WQw7WNYO2q5F7x{ zc*Zj-!J;dqGr?4C|L})DTyaI4VJAH++GPyjHa%n<)Wtgnd*!9WYkC)1ZN|_2fBBbx zS=;oASG?kIde)JIxBGy=adpyJa^!i5IS3GTxvEVOKId3~oBAzP!FbVejlQM>{Y~GQ zFLQTKi|C_GE@zx^dNpF2mj%Fn{YLP~t+mlI4i44l^4N}z-f@jJ#2ZLAFa-OB&}qN* zjTHJ`Ul4yqG}h;xo%`x_h%3&)z-l%a;zQn=#=Eb-=3G7GkzCT9XT;k%eR^A>wTbcu zEB54brzO}#WX+o6THie#oF3kHIPUkRlpfx5T$la)7r&|skDJ&oN?=f5xtLJq#t1%Z z7$|PaU`aYXB?HPLP)wk~^Dbk#G(gh;@&3p~lXz-dyuqUEc^?nhExx@g?XP za}Y5L0uauLo7+y$o>&B|$p<{(0oA(nY(ny@U;U~A8PY{CJ%<7ThO9M0^ql8Br#$`X zPp^HF`@_-(G6*CA=ONVRhd=z`$0U>hpI~2n@x`^RtmKA3|KmUYW3}9Q9^d}18}ty zh&Pt>T?w`4cEw}lRiHpiiiCN0#DtKwdMQ2gQslZb%YR7iLlzFfTa2%hm;%x2C%J+61nP%D=R2HAiIoDmj9h2fQVgp z{f(8#@Otx7l3B{vnrS@HRVl@IX~-7&axY~8!=%s1)w3pB?{1f;*tgaTH|nu$@gUBa zIX&lcPN?<6N`_4!aYT1+SGmH3yd4$!$k^%P6($*BQaB6AH*PA|t&8Zt{S_Y5nq!V;Eh@bAE3NacK4J zj+?N0I_tbwRM(_|bE6Q9WCZJST)Ycsj|Ny2%s*Yg}BT&GKH6 zPBJE4L7n#duzz|B{R3|=*lfW7Db;)axTrMxo;&c`iva5}(NB3;nl%o$a z8QI)e^Ct-cAdmom*4bxOVRP=2ckFs!CQG6&rqt1sqECPVQF~K3Jxh>v>EEnamZE${ z;MRSyxDQzp=0L6pk86R6UEc^8!L_*Wsx%89F!7YK8UZaq6~2(Wh|D&NlrjMd@*-LK zJ_k5Hrx==I(QBj9kT&z}GtUG{KtT9LfA!UZR?MOAoBJ$6^TX0M1_&xZVG$yZ78Vi< z%uhr?^tPvOLL3w_V5mD$v%o0^?VdO9^vwN~swjmkS(A>E08EsFIslC}lCxPeXI0{> zE;1wJVI0gUV5hL<#Q~UMF>H*pIc9v3V_>5`9;uF{OUmpyvra_UPuBV0Fao63hAnbr z-3T=h?Vu92;V1 zce~?xR;|1y>v3T9TEPix*p5>8%uv@ZZ$uiGBTUrOlIxcD3n^nDk#7Xlu2u@TA%en! z&3d#M2sT)w+K?}@dwY9TdWiC-P05YVo5{Mi=LoYn6P$~x?UiVTq>_Yr_OOaNjP}__ntb~C`oQ*>~kP4mG6q|XpU!=&KAcMY#i!fDN zkvEP3`hoY6R~GSOT*Ddq3`sVhNTJX&%=dgA$WMLhQ{{q?LH$(_e)WCkGoPs>8?i)s zjo%M`@PopWDimJltZC@&zZu`Iw*eJ?!7^iska8#>y}Z1}hYq6m8t<>RA<9UvwPLJ| zk2y8A=I8e*o_}NJ;o57j&lsFj$3rTeHkx;9WnXwlR~J6uyww~Ln6-%XRwFFe+F#*X zYxB^dgJn%**?HRQ*C#D6vTlxzt#!@;Wg{}LC>b9>Po!VQC7r4~$GmQjKJiTa$xerJE`UoqO*52vBzZh2`ze00W+F zL$;M6vs(m;vR}DkWftr&v*7Q47<4J^3aTNPaBbtp4QX52mo_%Q0Yv*nNFDx+P*V2Z z9osi#(S&XY31xja3-ipg&a48BT;A{g=hux9a*33l(aBQ1k-!|Ov_OFjfZ=sxIU{(0 z0*O-^khY-wZ4m%N0;&%d7XkOvlhV{@yoIP6BB>tMEx>8Wr21IKevCQtYsWe8Li*g( zy)<=q|4h3TpacMbR#V*Hy^gAU@@4az%orC0&2KB$OQ(pDyY*m}Z$fh$R7e)a949a=d%-K1*s3jlwX1`C?_1`lBR*eMu zQ{u^kIgA!5J`}Qix7o91Cr^AsjhuL^Pb-v`9NNeNqr)3(I-+Q;NvRccgB37?Jo$_q zb#!!8?3|tG2_=NU$iqG}#*1|*@2e8XtU+tkuG48zeBK@gCvVQF7SpCpt=E!w?IhE@ z=)&2PCr_$*90sSQ zA6~#hey!2lZd+K#w=H^tyx=Ij>I0Hd3%^SrBCQW z>(+SD|G15I+PLgKzoLE200`qroSKQcu+V?<^ z_@XuOA%aKddv09k5a!EKwG!MJ=Di!fRPO;Qr3V0#`h*3Um6_ zljq*KrdAFm%T)-1CCj=+aD;W51?;zc$;&Ulygo+=M~H$otPMRa&9x06^yEHZ(h+6A zvKC5VIWxtE;2qsj#N;-T3a#VSeo=gF%ojavkYzR>pP-TlHO!@K}P$E(6?r&oebN=_67 z)z;R2d_%DH((>;g`C@tRM}JgSWiwo6zqFnAN9ARoeq(vej_;KB|M2|shNq4#-~H>k z<%R#11N%oNKe#?2N7ZcJUM4>8i{)RQcYZnh;J3?Pzv#W?vIQH;*4~lBVN=Vr`#+&P zVdMMC`>x2FA+lBmxiOpWb_VcvReK^wB1Pth^zBtHeEavxn;)6{(gCgJ|MIKm2lS32&+7_zroX#ewn#3_B=jFz#tb{HJogKil$V@2r1a0T?^v!aKTQ9= ze9h=`QO?VI^0{~Isc+qTWqI=hUtYelW@XvDC(pgT!iWCDf0Vy`%md29wp?8n=d)FL zKkiMh`_uFxeb4RqU!>9raT}yo~Cn zsLnq7tawYNR_}<-jgD{=N|$y-5hAB#oL9)0Q%bxm2mqO164|u#)U#}4&}Q=PI&JZp z^=$)?zIZMVk2;17kuH>DWP%x|2hbD3bmMQwYera;k^~D!jJW5!RViQj z-|)v+X$#|ca$~n56tapVSpP0&ta%DHl5uFb9qW(s`eSP z?xp#6^Sk?Zo^LL?7j1N{&wcOT=7s*EyXX{0!F}+9AFSbb1c!IqwREJpqC0~#~Qz;AM~Cyf|iWu#ELwZoFYRAlJc;JJ*+tIQoFU2 zT>0&%dpX*(x_{r3zvZycm^rH~x@~dg7$T31dwHkUj`XDAF_1(pZ5*Qu89KW&)&nE+ zupDL#%4b5>#)@+c5!6S0@T315Hgs0QPQ8_<#=yq;s;i3A!b9>)CT=*Ccd{ z!UV`WGoVj=;uGrY&;SzPP=qacj(W$tDL(>;0jrvW84xAZghV?mitWf`CQut4qhaTG z140ttY(Ou&I9vLlu_0@2d~eBbxJ_f>0Ha<=FDVc`iuTU-R%^Sc-S_JdGa$ShT1 z26-s@4h-}`SXv#&Do9#Wco8TIKx4s5g60X7Z(}YLmaOj^ix(L3tP)&xSyV@s?rrb> zx9j{{JDbm&-_3X3f9oT%%QN>M|M4G{c-zFo3u9rbrzyv(r}@13-CTcHzw7A%kzpWm z@Zi2GU&e~!@mw-GI^jqlXn|9ZP6R*AIw7M5ESl6)z}dsa?F_ zlsGxxw#_rf)U^Rwn)-zNs|P2~cX;~7crkliuKRd-*6aSc{A%}o%b)(kCFL*fpTl~~ z=CbtKua%F@o>Sg1adbKLX6^-*ojJeE z9v2pP=n>^rA3VEU^o@(lFFTX2aN%>xQ|AUa_dldOVCl8xBhP+exnxDWvV%`A&-udl z%1dTy<*ntzkNeB=nUx6C~=7t47Izgu4W=y#Q01tIkB#sBub^4#`rPe>ad{f@$;%G;K;@h8eW(o@uX8QRZfG&`-6dGb716D9qOgn;BGAcke_U($@dIt7%L3e zuWz4(@XieO_Q_h_ci^#`7N8_uY#iw)~quW{5zm~Gwofv@_Y-Q&iMt$AsO4tcB6 zj=VvnS0%mPT*M=Zz%kfiGhK2|i+knk$-|aTz<{TptYMo&91Vm(882(G!HMQKTy&r4 zkz8==5gFtRux61p$TNA&1ZB9 zeD*vc_U1df!nu();0Q6dMQ+;L+iO@GnMD$fN8@RQv-+tXdPHfkT1u7(mN7Ga`e9R~ zd`EKTo(7MbcDbL9fSI0c>_oR7^O(m}dE@CcFE(9zo*YB#Kwq@o^+-9Q)r>J&^Bi(T zW_f{yg0<;*3&MTweaxP-}>g-68s}Khw zM(`-Y#)26d;rE&#%GUXPuHCVtt6H#xl8^uuW!ttKc$>*xvS@J@Wm^?2pCeRAlu7bl zV7s`>CbIh?(#B&ILdPnV$Su)Zg0}@?_nVv zMQf~tnS~(;x=k-~wk&+b!nrsh5TSF$m@3`JqWRmr>W@W4ak;kXQ@ttw@ww9c*3OQ2 zC>5Svo=J-dz)%vrmKIOrA!){|>A!!IJH^-?Pw9&6U3JwJ6(An`;D_cJP7WAQm4iIo z8W!Kzk`D%r9A93ZB!$&b2|i)mSm55bJt3Y(J8N@eZN`YwLw82Y(Voy8Qv&6%e%T-7X97#siS=T(_bvV{6#iPJmbFQq9qB478UV~a6miK(m z%u!s^&MrG+vyHiER+&|Y)>*RK%Y@rWS?@l1*X(JjtG>+QwDOM2-&NM0`FG{}YZsOu zzV(CU`{)0CnRv>~GHOEJlRja1nK>nAq*mV0Cmz|H1mWHpP46q3npF)xWuE<7{`_ zUZ!7CKGXTvX&&S8frg(ILuU?^ouh?4ha8iyl~&d=#t&kPJH5eyiq zLN)`88PhrkkFwel9KAV*GmGXl-Y{|}oa{KY&6~GY`J5gyVNJ+AZykJ`Ur+(g=ds^U|XCiNmQKSihfh|Z9tdO&g zR5qCFSq+xK7T!9##s(P}h(scVQV4w4kewsj2xIjdp)+?#C9Fm6{2-b(5RwJs4P% z*XSSjd8Tm@2Is(VkDN(`vq8PaPhYfG+q?g0w@~==pa1;&G7k4T0mOL9^)#ODd)@0^ zS3dW-&()MF&$KpdW}@qjF`PFi+717WJyPk1Ty`I;+PEJ4hfWxqcW2K`iV68Z%5V@| z0)Md8*Jdu{+@E{y{Car56A*A8NB0;zYn1GJ-6GyV zuX;g>HE#Us+KW66jP7vV?ySRo`yFbY!~ci!a^?+!nNzu>#(;<2_~^Hd$c{Wxhq~}B z^^Y0jgoa}~mU=KeJ-XzuR((@SkM20mi`EAqI+l0Td>UaI?B0$<%CX-7WQ-*hK}c9c z$dJd+i_yo2xwCF}C&#Q64iB(|oeO7=80qLCM_g>L0<|{)ye}RfZe~ZZY}&lBPVgWh z?cC2ZYLHF7_rwyAwE=+vdH#?PzybMePd<~cMnL0`tnWbHx_wJ>KXbTx+95o?Ekt+w zuI-hGvOEqQiXdh2d0UC+dS52MK_qxVErh!(Hq{U|3k$eil4EuJAZow`(WDgQtq3by zIDo(+5~e|<-Oppi%4G5REnMyJTmp5pcJMIpEb?d~iHZe-WDCOp7TyLV&Ei7bv9mY}DC1AzWdS`Z~@`J&!vOaPa+#mCMt|+X4c&)v+QgLV?ct zGj40vudcugz#MllY*<3<(?jrLko6znUC;4!My4E}BBxhKaC>BMM}F);ADo?n?b(TY z_hn7_<-dKo{N#q5pLg@pvSYyLGBEQsdr;0Y>=$c$;?#2H^sVKJm1mcyTrj>>UGH1U z*WUb<_!Yx{%iQwVzs?T%k++9>Z-3zW1vi(@5QkwQz-{%jyiTtxJ54YCe7Ry{#$~{y z@}TEDue7Sn5gNIF>DN9}u3R54Ro3OH7d*B+VD_Xkvg*tnF8u4CmTP|b>vHXukd$G0 z-RU!*QSLt`a=+_W1BBEq5sJA@jlr#8*060`>JyJ7k<~jhduXs<-thnnopHaU2#S^V`g5uaKDF^ zbEk|gBL;|b9KDb~ie*i9jxvayS+^s&HFW5ZO7uiLrsib{jPp^ER|Yp|X&qIPP+XWV zS=bXrwPSZHkL$pp9MKb_L*#|gJ8EqD5Hcqxa=<`?9Pi4=7{){F3eBd*zI~z?ox!&= zvgRnYDC%G#|F6*VxC!GThXbop+P$~+&Tcu6ib&7E;PHWY@B5}6pTlG8ot(nm&W#(= z$GrSu!uX^+dFOB|hZ;W1ClfMUyJ2nJ06Ff|@f8R5=6dT&eZ~T|4ojOI$u)fV(E9A- z{SSQONraiOgApu+h5-+Yc@Ra4j2(}eyg*o|5AE&k^*#!mw~2y=Bk&Qya-7WzUhsm7 zokwdIqK62;dKhX03atO>Pk&nR$wnYvKhJ{ozW28uB#gtsvtSymlmiOi<$?NbSGWx~ zh#+DmoGdKe5K409?~WMdkI2axoEPv`UwOI^LD&uVZG>_5FWsY0h>ha8bb)$oLNb1w z7xFUUE)OUiMq&^^ILz=zpkb}CL)MKyJQqIKSO4}LDO5<8_H%}Kj%XD9r@izGokKtQ z(SBsy_u5SFdB)vg`qAcxZsGm2q0*S|-Jj@X))b63*ADY{P``Ah0a-T;CH->JLW0zh z(?nfE{FX0YQGbs>5Tob3K6G<*#K!Ov@@)QaAJI&=nhFaL-O79_UX|R)9ZMMsP+q=nGpUoEZ5*#U3tDUFFm7q-R#l& ze{Xzt7~^6^w9KG;qt9XDctH(6Pr62wuba^Utg2`*j5A&lYoon>j!UXh9@mX72TP4iR_%&_P*1Ibf zrQOt5{Q5WPTTU2=r<$insDkH(Tp;$W)Yb8Z`_2244%acJz<3rZTN@b27tapms(+3n zGRAd0BePyfXC43#GVc3vBQ;IJ=Nn|DwF<;g2l;d|RF~?ELbYD33SJYwo$M zylleb%4gSSNAcKaln;I7AIdWymW?D8k=B>XKJw;r@jrc}T)Z@!Qzk#8y#1>0mS+!K zS$_PF4=vBz@ZPfOb5Ck2y3_BgKlqsPuU#|C(#viwi?ZRNqu=~;_C-%ApZe~r%KXDu z=kVce-z_hn_T=)(Ev-D{M}KTX`Ra4VmLZkY9=`DKANw-ak`7=7oN1r^r3_eC(hbzq=WZ7E#!B2jg4Tv4L%S!9bIin*F-gZOD z^Bk^->|1-t4Ta1A*|KG8HAXjW>Wu6;QYf3ZvNpX7cumOAkU@iUCgmAb(Zb4GVyxb@ zAYt#2wAr)fr0#xE$hXz{oyIXS*e8FTfyv^X@yaAu zIC9?}a)WpbPMzb%O4B(00`HBrF}L=O2TX!Z)*PIGx7H>6f`9&oeej1tZC&~|GUXce z=_d?8+K*LWq~f{S!GMQ*@Cnwt*R$a({BnKsZ2d-T;e_II7*BWjOh4c`qN+aFO4q4R z-UEz`vhTFTXRsUw`ApwnkA7*JJ}d60GyEodaF@5*J=zcd)uDalgnrW>k^hurWt#X=nXoF2E`gTu>FR_H1vgr&; zi{6nEy?PCfAj)6B>{}|0fFhK=!s3NWOaKq4ow=<0v17)TgSp;D1~{o{$s0_vaNNQ1@H(_*nU zh2UwMa%3IG3g8h`g|Ie%TkL))n4T6uK`E)Hd6vJs7tiBHR{((0TwDLq?LQW~pQZp7 zi%03+R`oUQZl2ftyZg1q7JxUUsRL*=ZEC)=kh>S{Fs@C#&AkZdk)L(H?^u7k-%(T+ ztvB6Fm^!)aj#m(fcn%$zC_nzjgfjd8 zJ*_}Ae{hD#*r`Lv1HfO)b`*2{SL=1zZ-NjSyhur>w?9P8UJIg-4DQM$d> zmWpoyud39xhCouZ)?_P3i-JE8g+8K^zESavAT0<1#pTSrnX_hA1>+uGOL)TbENM2Rf+5( zq&&X}jEIDK5Gr1Oq4o($-*DoF=eQnGa4p5@m3E^O`X4@QOX(jya8Cd|Io9h}(^Sv>Li{`W` z&2`Pco8Q`vq;xNyhYWWw>hp7Caew2j^qqToRh1*hPkXyx>zbx7u0;+T=Y{W%Eab`k zN7m6?r;l_LVtsEFdY>A!et7xh?QYt-;^o8Hwqux81H zvt315c`{E8_BVS-v|H5R;6dp;F&y(O=dBtK&(+@{S%cQJdi4=^k(x3%YZQsMZW==d zm)V!=T2X-(W>`PI=TPIB#G%xEqRR;_I~Z*W^~9 ztzG~IFnFBm1m}Lw2VBUgqdSHS$q`1GEFtYt!$+01IaCzEl&4@f7J@8X#2eW^R)#ha zNWkCv@$};>M=r|lcXtPg?tgc`=6L>ANB4TV|9xaVch#;Vul4Wlb@k-$rjF*?=J%1G zH~+r7-`($T{%(G|xBK6BR~LlwKOqgpMld;&odE&)z%9j?H=D$B1q{f5(*hViWKqtW z#mv|U>{g&4OFOgsZ*0C}2nb6Ij$(Bk;<_rHsL45|<-X_6PdIyUz+`RO9L1eAfG7wd z4h`r`PNFqM;%z)VErUispuF_c-z(4j?Z20Iz5j#d1K(R#_V39~^JO=b&Xu>7S3dlf z^7U7JseJia_f`^ji*UW^jM3$NBLbFTWjoe)ln1&Z@a{$@^-@ z%`dOGpB*f z?|kN4<;fp-VyV3{r%9}D`Saaw$0oTrT-9;>5o2=58Rexp8R7ZU7nb*2@PxAIIO`!p za<{8@F2rePycs-;FpWo^5pkb$?vwe>i5a`D4u(0b{6JM2t5>gyh#o9$ZEY=YQtv)B zye1ujvgO%gC?jY*YKUTc!eqi=qAg@J2_s+u??Aa zeDjndtZ>$b9UB-J??Qss(W%`G@#C1Nqh5L}Y&#Moj{NsgD?5%4kM&$tbbnU&znkiN z`dM@RiTr)6e*8~rV^8{TUEn4#m{VYQJdkue!j5C;Cnpw+C)d`e^d|R^P4bJ#A%L~6 z@C2L7)`Y*fM&VIqw9yOJnW7H$Bj)af^VT;$(s*$39N2&$dgD|jnOW1;pVJubJ3slF zF#sG9q`lU(H74RZGSOOZ7i4Ij=yJjd<)|o-zI|7f6*)_CMHKC6b5BbMc|pNybNApmlWHpG>^Gm|V-LlA^Rf%`pEOecD}Pu71=MgTA} zA|{SMwaUZ3EY@w=*uZ-;c1#kdBjejc2yOP-n$O22nR-x2r^BNMNB(#OkiONcSH;@h zTrE-?w>q=wYue;#kZn>r30La@O<-W#Yx}D8Kr(Hs2<9SH9pR?uIjmeisFTHzbV@#X#A7_;J zeC~zi-Rl$fJNl(}`jq0JT;vAMo<2J}&2J3O4NQnP5rh~SlP4yPgc3>=#&Ksu2Mvw< zb(Iwz%hShrRU;c+2{A8SlFeMfABK-pGK6J>qI)GQ#|Y}$n)ie!9CsjF&S96FNv}y9 zF(kQ^kyC^go^IaQI;)XVNTr_b^FSu4I9g#v~_Hh?Ed}I zSCTdq0%>O|FN*YyNx@y8_X-BDi_F4Q(E{sZXpAseEcX*ZUa@>-#rCjpE4a$gg74u8lhf<8*Mu5IuqO;0PRP3@|Tc89O#|JuuuNBy&*zyd@__ z9lf!3{n|Jca!zZwPXDB^Y~Q`TOwJk_6zA0~Il*CMayU5>@S;64TCb_rjsg9XdeNtU z&9k)Tp=z&#*$}sSZP^>#aP-~yZc)GAZ?ukn_X#JIj(p%f;i!uPWo!D_2(w+p#|;nKjKr%Dai}kBzk~gu_$h_xN#fNk;%|0%BQs z7A3H?*VeMNZ+-&e!ce`0I@1ORpPnrLcSaynT|JJhK15JX7-e`MWX>XIvGTU;-v&wHG|{j>7xv$G3x#_ZA-*&aFW)R2}rW&UrT zP!@jcAIpQ^az)v*`HFINnASzJ)tS)C;i_Z2)s=SmgZf9Ggrlv$V@W>3HG0~N^5U;u zS{9!9=DsTI%PnL_m_E+W133-3*9jm;+{mXp6uiU&O zhbbROm@k{F?n%+c++0RH?A_(nd*kuEJwCqbl8eiNC;my9AEV-T!B*F{3WG(ujQ7N^ zUAv)@J^zM>qk}~gV=yps8OvH`?&T}OR%sOu+_!OHS5C+hiyopmL zCwD7&C!#`uNh{hD59G)gLq6Y<`vR)jv@pWh=*Q2xnquUR&W&TzR0lf?|>*#23cKCkz>jfdG>Db z0e$r=n>C~0M@CN=BWsRf&!{?CPL9C6JpxiMcJJC7&d^!Y@@$N2Zy%b?a5H1PZ-~*8 z+}o^iM{Y6PmM>Xeb-o?nqqBD9&Ua;P?T>s9Nd9@BtfTE&GY9-Tq*OjMJ;5MC_qK0q zy~@#AuKFUfEwXhWI-obaJCtL(VnmL~8sS{%2p^GZhubjLI4*Fc)-LpIRYypJ;_%?* zACVp5oMengYsYg=bUERK5_s*&fI4r9$4`EnftSCdqkzYbW;+|Xb#318<{2Tz6)W;a znkePzGm>8w1q+01rZJ#{5~`LzW`MDNVQK)xs^%ed;4T8FeqdxGFEyd z6Fs>n>%VtKKsaM#JUgqCib1}dAu0DvPE0j=;$0_mtXr?qYUIvAv(6`#vjzZw2KkbQ zD}3lElYe2=ubol8`MO7y2V_@ttAr9|O@+f8QPTEaNijJ_3f-^1bxAq>Z!aw$c=)6;=k{xQ z^}4luGcO4E?EAl4ew#VF_S-)w>!0)Nk__9Vsf;Xt{+j2OcU<~)1I`2kzM<=M|vN4YpB09wp)^ zrAU+r$*eNT!=b=(Q!%j728lsB1$-8?%&@%?x@Yj`^$?i^F(xVVT+ zZM%0R%cJ*f^_(mxN8sKb0pV)-lDy85nY8gdw3gnvhX>DbB@8xCjqDA#> zI9}4i=vtNa(vgj^3?L3KPN((Z45F-3>8v%zo&4D;@i3Bojx@Q&ctbsvCR_s%b^47p zEE4MbTW`Ik>Ipf?q7*oXqr9wV>x*G&E#gm%MjQlBqE~F{le1|(p6GHX$iBB9=*S5J zi5%Lc$l{cv0N}*`mu3QluMsq#PsoOsY9(g?y7bKD?=6dFp48 zd#gzcSWSG3#A>G^X;vtbyBUxIb0A5OPL}^WBVayRfzmR73+2m5;ZZ^mE$&vhgI6dU za1z3%0Oi|;C&cIp*d$y{)`hK|THweCJ6x~7?z$?Qh$%zGaVlg=oqiZGypZ*~$e+-t zb5<#E29S324hgMqp6c8A35SAMG8+L?3C>TMg!S6=eoa^w14WyTX8R%YB@7q;0eZ{Hcv zU|7PP11q2EQ-+`Ng7UdaMg&n1+aW2ly?EF?0< zV2*yg%d+N^Pbx3C>W|BdpLTkA(EMpNq$;dBb?PI_lOO-M^0KE-D~Gl(Ez2)^TY21@ ze%Y$4Pj=T{@b+@e_g`8j=9B%~E-ufU_qg)GTjRm|olCZqtKMDS@w}&$zrS=*>3^T| zN^7e`jw;)?sw`V{d$aWK$dhc=e6l>_{HK=>@5u`q;$glk8bnFh<+*Ix@~RAMPJuTR zhPg)M7%+B&`kcaHfFP67BgjGhiOk5QA}}zXltBMRhQG5&^p=LRf{;fXOldD^A zYn|=dk%$eW8eWolGV918n>RQGs^@)s>zFl4_qywED9h!+hbY=*PM$@e$S|XyhqG=b z$n!kQnnDmA_2R??9#qP9`Ld2mbe*l~jb)U4#rfoeA-6U~ICAS`IXMFN_6S%nWL7@$ zjG5DG)WB&7UJ`ma*H@=O`}FCFdY)bhqIJ0<^6!X4kytvS?$VC}kg_4o zL;d90I>kAxI}Wq$J6b2VFuw2_(Nad99A#v5@#2L!3hJ7AY|)^Q%Ml@n?p2@l1tXkB zvo(CBo(hprJUxL|*;G{ZM6QDuC%VvgwPb;xkf+^tTXv7$xF9>BTA%@pkS-v^k_KoP zd#ki|#CCSBub|@E*-0wrB4*JV6YL$qL-vHT?HD&fcH2_!fz^=K!8x{NMrG!5fSk+q zo2##`&oL3K4T<6%9ZM>(+G#euy**x<0abykzbfoJkkvjQ1Yt*Vk@`ll*|AO-B*Hts zh{7WXCXfI)ukwjccw8mMw|DB~um9yEKw(p?S6_Wi4L>;k0We5%b~F{>03gDYHgoZY zZ{C{lL_!a|JuFRfE+=MalqnF9z_&0R5SO3vv=A++QzWvRY zlsRfiTh_0Or|df~ET{eTrDfZ}fq5-tp4y<}`7bLkd+KA#tN!HN%x7M|dYk?|GX2YI zD0g&Yp0$6sH_NYmIioJ!KlHHomPKEBVVOQ5hG)00n?GTPw467+=^yJ+Szd?eAY!-% zn;6&(8r}(!5Mi*f*>Or?P&^D4o^T{odXdx{`I0u%z)M)`8SU-um9$YrTVr4^T9Pw% zgKuz_2g8OKyG=!p;3Rxrx^zk8EBT!5)3Pi1^eVePZ-}lC-ccAiitLh#~m%&|w#0h~H@Qrgt=s@hGfU6i4n@Vxai;#@fE z%z4f5o&0@r1n!j)u-Qc}@~)i;d*|HYpX3Z?#~fO3j4+tIc=4i281aSK*(5V2-gqQZ zZajyX$cnWCm+1(&FA_Q?dV&+nTC@guC#?gY?TRjNY$4fZ)bTdb8}QZlOO`CnVd>XE z!5CgyE5SJH)e%YRq9;Vnq)YMe<2M_^Vb;cZA&NmaXwTG~PBL{$%N)K}2J9%69LBd3 zMJR8+d121*TUM1VVBwwxjsOO8X8j_4W3s(oA}d$(f(18Z;_`0FOyZn)4keVcdU+W~ zWpdqT;O!2#mEO)jN_yJVq6mb%p~;gcCCt7uWMET0 zhQ=$3Opf-kq*==V+kvH?0Ys4j`4R}^!dUX&bb@&LuAZY6a6XW@-lT+>9QnfaT**Xs zx9^Og0(WGDR{?SGtSf$XMJ3Dg=bzgm#PM|6(K|57x>K{um*5EBd#3RtoIF@*R>Gsn ztI95}E%|;`#(*d1-20ppVBVPVTT(r~+U4E1>T|>gCABlpc6u9Xc3+WZPY$WKmxt9J{`AU92|Y1|BCbS zc1FR}dqTnyBq6oUA^H^2h#X)%AOy`qbsiX^)*?_j&LS2VubrK6+J7*c3!DeWgTWY} zxP}eMduuZv`s*NaO3|)th7IMV?&jK-qRkG{ob5O?DG@Vg&N>VT$fSj8OgCk-!uEJ& zELI*DudOpSixT?qN>7LOZ_G8uVrpbjcw}#WdS$FEY+gj|Aul}N@@t%EKo*=f@atdy zrq=b)yua4w2XekO;cTHv=l6L>D+TK;LeFJH@kSj=ofG4YpE0AYj_qCl=l{2Nr_FU` z*Li?1L69Ipa00*y0Gj|OaOgqmK`yHm$J2+z`67RctDGO>|B&Q=q>_sLA(kR_#XZU0 zoY^F15&$QFBLETvKr-*M4sY8o%OzLJNR_K}WtfeNd(YW>?X}+Zu3_)vxC!Td#<90n zYb;AIHr{?kwliQBGLwC7|M(T+^>AUiwVwG{|K=6q5W=%F4TIa?qRH#%`$~=@S_+vm z-|t`fPEMa~?H|bJz4`KK>%mjD=34pN8ztnXRAfE>!7CrxvNgTehxRt#{r-=6GEB(Mc6OvZ6g^p5P5|)s@AWkq;7;ubaT4{$+y9sG+hx&MPfHL-S?2|3 zoW=tyl;n&RezOHO4(lIgBcndd_SvfDuhi)NFp@*&WLM*icLak1GKD*yHD2?~T=oUi z9Eao#S_y~!8IS4|y|&R(rXQI_!fA$p&pqjx#Dn0E19u**?>jG1PwB2~!q8?ipAB>{ zLWY;~x5)^uE9G~3I7j-YIdb!Acd>fqhl6cTwWem%~9+|2G{fDEcIp!tb zx0yqEQmYHB(dObMNRa8;l{q;bCd#Aa>$D5=aF(;NYyIHw zjD1_@+YA00yyVI^@@c+{ zXjThIYz(2}$7CRl+Z?s69Cegk=E=v<^If^0H7A?)6RY6=ty|MIAC-m6moHYv(!)X= zM9;Tsvyvo3GPS2T83#6~2)EBiJvuay%FWSQlg;{n{{T-n<0j5P!t5RK!|`M61j^Y{ zOoWn<8N}$R(U7R4G1}o6b<+a?Wb_{ZOGL#<^azpf5@hdzzSde4_*s-YM{l-sHC-uAC+*mq-wLkAOy7e@_&m>|tE=K_{Mg(;^NOdg`0Ky^U-?cPUybAy zj~H=Y8*vEEUqr+YW@qM>4(Hn~6fs0Fr?SJ}6OTHwrht?Kp$|_yIUq{s;P@?1mdXH> z82o*3aIne=j%*@JPHkz)uFzzkkLPioacY{3jj2-m0SW{YkO=?)&+v(nH2QZ%W+^>q z;l@M!%+GU>?`7xeuHAINri2_uo3R+PYdp;kT2CP0P{@c5llPlA9tYprIg4<}7IFB9 z>BPi%Ib8a{=z$Bz1voiI3I0Hl0 zq7&m2MQ}a6hpl;Vg){ezSDB9fcO|g$;#_UKky&9oaC+p#@q90jBFq?H1`oG)DdA-U zX9z_mRyZXfSKi|TJVB^7S0+#%P7m8i%8kg);$p~0dh{O!!?ZdbOA!7vSo<(I@I3gc ztdFE3C+r8|u<6alOBqjrFH$o#HIeGl?jn80j@0Vov=I)r!s3Mo4?`>-R7(pINXC`z z%^W-(MPLc91Y5(wf&SR(XTf*bF2^7Z<#25HfA{V}$sW!*A;fvMvP#JFQsyeK<`bHX z?v8wCz4d?o=8M87eu91&leHWi7^)!Lc#jKgw?3`g}zjyRKXEjWB@X1djvESSE&pa1M<^>-B##O2-d z=Znlqm>`XO^vm3ze7o`)V<&U%9dv7Je5N&_yMC54HiVq-^%6j7oiJCrec)h@V|%Rx zJXxd;A$*7b4F=m7wvg;LUuKQBCSfs}IU(5i!fZ0=l_&~{cQ1YxCxFF*6#ecJGuBh9 z2h83T{S~liX>%5}jg-&xq`V`Mg%b-9wx`hx{sGzDA72l%J@JbFWvd8-YO0nx_cL~W zK@i|yIM0S{w9^JC|^2X zMTkT*iAqG*H*egihHtwind_!MKQUi@hE)*62{Akmth2~&z?J5~ zu}=q3$je+r>vqLA8HUHTTUm)fr?>I8&Gl&8(9!h_ww|E zGiT1!dYGdz8>^!k>ghX3U!1n}kl`qqM<&QFGH*3{$|+nZ?CyI5};#jLAi}F&?}Dg^y$-0Su2>yY0IK<(n?>PlRzA?qyun_{&E^f zfVLl5Avjk-Z=5dOc76DxjRIkj6%&{sjT-{q=yB~54K~0Z&daG4%4I4CYzWS=OJ}F9 zCZh@)kUfM-fa@9D4suq}aXr~RRU+9g6${xT7~%VL->%x#T(d6(7k)m8eIT1EE9RoL zi4C@~0lu*p!JZ9A&*NDA?Obq}O?4#0cx&cX>zAMXqBS|4c8*{oToYgq2CoKVpL_E; zSwJLOHd4h4u_9Mv8a+LlHmLNT7Iw*c?Th`zPu#p&B#3N$uCVe+9v7VZ%Zv@BT>&Xp z1%b^z$MIWF`0QWpE-=A*3Do(4o_szFpH>CCWSiA(${G2ST`N^gR1L-y=IIH4$H0$bGd=8!W13M98e&U-8-{u-g#KZ?3%GuON@?hq1D7t~v z3xrgnnjkD>?`49y$eABOTCIb?hP_$)D_7Dt9OB52;tc$Q`MpR&sVkXSr!#1al2G$q zFY~l6%H_w8pRBRs0?sf-YW>iSxWuwEx+B?u!)W_s7mh@H|NZxBe&m~>Wc~A0x#)eC zzvK=Zkm=$h!G^AI3%cg9y_@;kbV7OK=0t>+@@jz4jwgz#SHYq)1Pk5>ZFec2EF{2S zNMmDTC0xXXASuz47%xR8cx4Vm$q$2Mn6CdaBnSX2n*e7IUPlZOJ6S@Dz_2Nw&mm8g zg0UfX#$;i9PKGJnn~6GK)dA_08~L(jUzAMgEjWd7f5Zjhat-}SMM$C)=IeUSj{@LV zQ+fgdoCX2{>lw`4++6-UBskv{(Q_E08W}NTqZB@;M@h!aj!9)3#MSp0?%^1V`zw#$ zjRE*P0%CmT>-Za`C(cLakc03$@@OsmcyDir{oRz<=H_QZ9^WaaRZb*-uP7>WW>{_c zA=n%c05eu==AOVnNy|KB+q^Fu=pMn)M3BkIMXpG*qjEY^ey};qdRVv45KHX|B2Uk^ z_I`nR*7s@jfq_~FPEJ(Lku~ePt+JOkYXLl9g?KBkls-hJQL{RlMZn`6K6B^z7`3vM zYbukFw=x; zbM@-A`i`iY{LIhe>g+DB5>DoXh}zhLWGYh@NI{d>4CnjLJBM;J;pDg1{(qH#5U(2oHY5_y$kX#qekq_I4YlXp)8BDbXMc^{VBMA(R*EzHB1~#ZFkV{Wba3y27e}AFY6VAX9 z>xR^-PVf_wBd$9>k<&)fzdaH{Y5lzT6sMvfTYEz^d|%Q5p?6;d2~qSirY$)_s?nRK zt&E=#yta4ZKTV*20na-y#3yGJ@{K(S8el2Cu+gS>@m{()BEr zCf}v|jbF$C_qmsf5Pre0AfsBgWB}oxcNxEIu7C(%xPJY5$?DyA-zz_1T#_A#u5&SA10A}Nz=tgP2={Q5 znEvnH=M!$%tQ90S7BZL5^GG`Hx z&*>eYD1?q=VB>%USa8_Rq67{~Iu=Vho}%aBiFwIdIR zis({w&$wtl@KQ>q5TAVVNs%PiBo~ILCs6rFMwRg($H=I$QD}zBu-l{^NC|t)Ya{az zg;G>wP$IT-UPji_GL+;27+J{>kbR9U_tl@_e#U~ZJ`K5k5d)NJH;+Sy4wQi_Dfr!I zk#(}L4nRgfk4H#7dibI>mQ=lGrOI4eYesJkl+ctd5b=dPp3uK!!3mlR0AcVSe)wUC zw5H^>(lhCPG9u%4a8ZOmfQ4*#cc+AqDBNdcJhz6#(i1w7&eDvlyL!L$T^@`+lI2=- z60pkjzKHDHPf)}$mxGD^m?wR;HZnP#aRwaK!z%&Atfi=yuGqL`jp!UO)&t5pxt90o zA>s&}SMwy7ZRyuyKgwtbgJZ17(P8K0PZsnF0r>6fU#A3M6UU`w>ABT{M7Tp2I16_D zf-Ypu5xj+9D7`sz_H3;^-GzfO?+SqRQa^jPP;Ej3(Rmp{nG-fbSJO5C!4N1V|bKVZ|W3J!8?j{Jo6tQLf<-Fxr7-+J%e z?0n8Ol)#<3q4nuO^u~+K=%_h(zyu<^))C^HF(8!2$fuGQCq+IIH@$uPTf-sxe39`< zT)fQszImBkF~5}eBruSFSw@7?wUAQdwBG!!^7jdTn_%gD1OJa$y9K(*{@9}l!ON8IM3Kr$VU#?#M~pCJvo~Usg#1o zb`~Ry9Wf%MUrIij?48eX;G!=eqo1L&k|6?&v>a-bkkBq(xLD8cK9b%SJtU`3ovwvI zQktHj=CJg7Ms5fYAXA0~RE&35gpN@7yykbnhp-(@KO@6xA1n;401V|RVB8f$PsBNu zNRko1|Ni?GH39(<`mF#nMg_p^g*0lw=FIfw&UR#1J=*c&Vn)QMLk4T&p{! z$sHLxOh;JhHf-yQV-`@dMKAh{eDox%Vl2o3n{*wd0SQKMS63gjhU3r?JegFFEPapw z)Ze^p{)6E~E@EqBzzG|Fl|^$b-TAZUi+BijWw1DF7-|gF{}&sB&#r;&*1!30WXT%2 z9y^8&wYe$swjN|brv3)UdU~>vC7;*t<{Iz5_g-bl%t8^b5Sk^h4Gcz~eKX>k2jqU5NzG_XTEo$`4=}K52?Zz)l=|yH< z<+t;mEFHaASnz1&ruB^Cw^!`ogB@QX}KnWnX$9 zaR;RK$&))}uXw`#{ygVBdhYWQKV(+PiHs56@7XKi@g@nCu_F9hrRW_wE!MbmHf(J6 z)LV{YEo5;|WWNTPTR+5|j{3bSXYo7adZ6z>Y%v5qV-`3G5(J~=V>|}o;Y>Id< z&iCP?JeeU;no_J3GlSlF9h_3-z(`Pm$bo!y8T6QhtJ zG(VA}UJ@B8{c=*$hr16}w1ZIY3$f8WjueSTDKs*)CF9%PCA-T|n*KV9B(ulCyvTg! z(ihZ@Y7jQWugU`1sVZuD_OjV&tW?S<^j1_)(%?`OeWMIx?H@Rl)VTtj zBb=JYRAms=4|y;LVIyVwGw_}qvYnch86;<^ zk4K*^;EUMnC2QlU9I}OW0m@eX{FlFIUAcI<^+$jFM`I%nDW_}7p6Vg}?#5W%2f!l*BHcPpBL8j7$cfesnQ6UFoISv&{~Q@xi~EaB zG>-yANNRiu0PJEX0~sFI6`hNUfxD;p*pzMFY(T*1dq7aMzAv`mI13vakO%gq{UsrM z9BN8SnWLUjSt@$$Rn8@jkL){BM#|Ts`+C;03pUE3M^=eyGMgzbUA~$}lMTd)*;tT( zD`SBToGE?eKoJ<5^MJYyO-Dk^J9AGvn%SYb(rG~=Y(WT=%4FwkXb>>5H?rkiWTN~x zN71ZVlNBRFax#84XRbc){l=*^P6}=+I}tk*WIaf5y%-|kDPkN!@9sFL zU_td`#b!Nz&4xq)rn#~8w#;FUfJCc@zDU91q5KcV*?1sh=roGHI6atAEg`vvVAc+1 zRTNl*FdH=Vs?>6CcMqK0Z-pQum-s+KSi=-7qh6Hg_3&I7h~#nd^&} z&lB+F8OE`J^>xn#e^j;vn|$}=$>2i%2Ah-;$rK*bdpppbuO~2Vdiv6865O4do@)Ko zU;SkzE&ly~_>+>C1Jz}8$y(MAKEOfcRK1^c=}n&U)SD-!tt3b{CpJwVWXMzl;Jd7% zQg5B85nES*v4(p8`4^Zd39=S>3knglLy?(&JbmZN?2;v9Y2N@Wb6w?ga#vnP^6#XI z2K(TJmpMLLil0a_1>vPvyK}AXwAU0t%4gb{Gsna5dT^@o6Dhy0?#%Vla~d0y1lg7+ zNI7)_-om-rxuzvY1`9qqL4&^TNJ0h%$ugUx^&RRNDmxGq=nu5sGGY@GleI3lZqJl% zd4yp8RDUO6c$I~0bv}>o$3H0tt0FEgE`*ql6t-ETBFNEon_b|-p7=vAe&TqDl%xov zO+U#>u*ClawCes&1W{tvPfW*u_P>8#k1_qpk3X$VM>3kSfiu}83WLkX$HupWobQeQ zlbB%3id3e0cRxN-p9WOQ4(h|2CaaUbu8AK(>--?0gXk(I%%(2`E12WaqI3)H8_PGn&dw zW&sz{M+VGyPnT0RewE#_ zQM{{HFPF2DT0edIOo8w7=Su;O-b#9*yFl$XmnDkDblEQ-xIkroCZ>qUG$Pw4M{Xmazfbz59+9 z7?l&v+#f#9&bPcjeBzxr4d=@>yM}FKc@ol5nS<^`BHNIQJcxc&1t5m2HV4r}Q5AIkMow#fzovGNLlP2-nX)`(?6h19jYj zvH~zIhY?_|ew{cY@<&8udW*os@byq~+#04UI?r7C5A{bEvhil{NCD-->~!l=)>yPE zb8~X^R5=9(hm;nf4Y+ggQ_~aWV2<58R^>aHPsEZ@a%OiEEL^;Bp`0hj;_r?zs?0$Q zQ#72toJD>)V0|-swiX`Q+1^tnncav+0*C2+z;=+c7#^vlfO6BA@Z zffEO8Y~;t`<#y54Z8<=Ct|Dh(!^tDVY*R3&tW^O@Hu=a9a6E#FFTVJ^j-5Go?tJS{ z|MaIW6cxxpKmoj{RFQa@2FG40d1*A~$VJIOQ>J1d>kj1p@-P2qaACRid;jL&w%!?j zCpMjV2V{{j#8lsuvlI~+@6k^-j|}L;Th8z1IX*Go`tny_wLV<`LF;hz{W<%|u{583 z_KVzmA?uc>zYHhy5GS*e&p(OGWD^!5E4zsA$5t<0yj1vcESYTOT=rv(oW$JRe9j;J z+W>f)@uN%dqbDTAe`qnDx-Gx z?AZ#S*FvC|lhJq+yF@BDa+t^_1R4t=ncIUu2qi*jo!H6JN@Nx1$SJ9WbSHpD2)4vQ z`>*s&^QrVGcsUUL^%lnYam1@3b1y>f1yJ-2p6a_6tRa}NSWsm%#O|yK%q2g^ zwaH3;bMbFO;JT|U|LISDw|o&jGftSTFZxw5@4N4=Rgyt6LwQmkDs1TO+nbD6j+F{F zIBLgwz;|oe7tBQ-$YOV}fgJpOYp~)~&Qi6hNYZ0R>{KrsoqYN%tqk+aA+LwxZv@$C z2?&-w&Anc(uNH>9dc#j7Qx>~{&DLC?49`?3oOSyq2?jU_4|gT&B`{o$Un4UaE%?+M zJwfU^^OS+-&vK+q^ue{@4T5zrJ*mI<2ftUo#N#hjQ10C`1{J4ljEs(L%V%M)0FMqo zdh#%SLT_bC&5QTzRD$^=4F2R#{#`bi{;=??GkT^qOW8?Vz6 z74pnR$Y=0qvw3tjdhSd|GS!Rw`+xWcA>`S#qS6z&DyPq9jdz5P+`2WLjQ4!}!CY%( zcqBSCP#7wi^v ztDqyg{LVYWk=eHDMU{x-4>#WAc)mOi_F0}R#!oowtg^V_MDzhx&|v{6U6gR!*PE(u z7O;qO0+N@((8C$aX1_L_P|E&r=13pXC=E@ZKt|T3jzo#_b8Lj|v19wA?@GU=5)tw@ zG&mG6w6l0Q=U?SGpO8dgBP(GJ9Hz{u9qbPRz#N(TncHH3lJk?!N0ur>5+JOn4n-M7 zBHklYAmV((Tj`N84~MS;W*MW^7fpk^z8%+TM>QIXky^%xxN`y`9oG^CajunR3m{SS zjaMODc9dnFzKi@Qn~=LKA`o&tGSUZvj8S@-0a>%)Y`tWPfRoa-0K@0JXWT`sbN^=E z>p8^uy*h&9+Y8?o0Dk!4N3Eay|WFB>Yhq&zAJkL?CIP+nS|Wa>26jmUaz?HzvgfqvhYemz2*6`c9E0_&@#mi8gZLm5QvoCT z&RJK`5TbGPsNIE!TfhG>6BZDk*OqB_bTma;q=#$bB!l>+Mu87Rx989eN9QnH!eX$A4cadavK-W5>=X&7~ z;;oT4edCDR*C~ge&-s^r%NR5P;b@f^r=};PHwRn)>CgYX)=VITys{s<;C_1Y9P7oo zA~*B}(YtizaxzfKXheSOoQ}%22ryv;S<@l9AUi;==EhEtZW$bo!}SG|j+vUB%agkj zII#<*Q(3F#xS9KvHFuxF!RUz%T$N=Fo~be*NJ^Tu2G%3@X4~YUH*9=zvet_Zx*sAi zH8oxGETOcNW||E$s@ zSa98e*tfP3Hek~m+r1x*n@pzF8GuUue2ky~M$&^@d3uleAU4MA2f1-QegdBE*_~su z;!E6n2`FC%3W0ib8T{APoBskTX-yfft!gV`k8s}(e)|L@RP^vy2M3#t z!gOCNgS8=Vf3pukwU4b<-+u6h&a)dysw168Dv)vV%zXTxgb90QA9QTjt|YYLPcY{B zWV`uW!MKw=RQC?WzSyVAmeUM8p~{g%NU_Bc0FA|_9Pg)1&b(yE@vF^#ZEfG+FY;>t z_rK)7$-&e_5gUs_k?-W3MFzn+UP=a&Kx8KvYJq-)BZ3ET2n~mKEEyi3x1fMU>Bsc| zJpg0;N>TvrMpDoKi8JfU=af+xjHvU>nX?5LN-L{AZb^)?{kz$^x9gQ zu;a{J7dQe*q`^2Cs`Yp`#Qq0A$f57~4DfUBi8wb|EaioR$(l78z9uR*H*(ke)9z7Z z`~&&@?D_L~4(jpBy6Evil4b(dbV2rUIu7#EoKa128nU+Wi@s4GtVGkenDF zFYt98^0t<~hddZN-H`#hoqJR!FM6U8n>-u^@$S3t1@LpWSmp{StruXRTO8o%=xE92 z;lqWh6DHl26wzL>=j+taPMD) zfGiL_`Y!v^I0PlJm6{Lvu$AEe@$dZ3@09a%7%!)IC(eX3vpz_vjE(VYQ!qXR+aCcW}KdlIH-ehNB*A~%fxMw*;_c=HSwQcbm-RakQaO8j zw#ETat)ZU=7m&)78e_j2`vq-+$=YlXeOA8HPbGkrRb{X2n4Y@^J=zr+o;YE5=8?`v&gV@RFf z*@DcZ0P4n#8-N|ovA${dh`k&)rnx%20WY?>>7Lk4Vv zJdjg%O|~-F@JDHUJ+_SuxfVZxtXebnqlH0VK0FfipFVZ6Y>%uvIwTLAu#sbc@*VSo z?|Y)>+G-FLF99}tw)UMk=I9^0t6>K@E9WAlbc#Qu+kS`Z)z=qn zFuzx^0Ys9YpwD!w9auGfqO;_UXdzr%@;^P4&QW#m!msEAAL?Nidq&QXp*v$jJ_YXD0oc7WP?2ic%Ds-DgHs83&57(DL|w6XWl`c5E-ER9v28f=%R+z1##+E%5uP3;{CLGaY_cZJltm*$J7qWnNXV0D~tP>Dh zn|&#tvlrv)$a=7E?M3_m9|IR0K~;VtSzY*b@?=W-u?fBh#?vj=s1}|qUitsbO-q<( z+#}5T{o$?v_;||l`to7_(^Phx_sk~gmo=gPuCHHuGhdsYp%huIuY0a!dh3!(mL{(f zT@1yUTl!QgQjAO^;aed6m!3pHS^WK0oE0bjI)f8Q zjtq~)8KmT$oo@`%;)|M-iVcW3hq5tpr1tfjN7dUWy7~Cy9~IeCIzScy5#XfkFY|o> z-nIQu^(u*I^~Q;SJRJx?5rW;ksgx#Ca}>{$*8J>TjU7115SBr`O1~SWN+d3#Lmn2> zcd{i$vOn^W)sZc^c;QldpvD3Q=gZ(_hedmw+wtQk%IHg>Lxhwf^o-2Sil{ncXom`@ z7w+c~Pbmlb+j77I$*coeV?;86=Es4Xo5;<9u%c#Q#EAh&z^k-|Kmn({F=&QeP1d;{ z;LyO&$oIr4xrS(sGeJZzfE;2g6NlgM8j)quZkQ2 zqG!<~_wadh=k#4q7QtBblgYx!%w=f`6s;rB6(n3pnZE(ZvjxcW^Y`K)RRRvQ&Yw@q zO4byCHa^ku!a|;gllvVD5d*l7^OT^42a9E^PjZj#=~0$N*01IaRO7F9i|9{ZZ=U3l z_g>{3RM%R0pd6gGiL6NlS&U?URUd783~Kn}Un%S;~Zmy_?zWat92IyN?5b|b6f zdWf>@7EEz1@5uxJ*5&0KnjD?aTO~vDbZ`G!3;+En&IvGEf20iI@>oDSr3F~xiaX`z# z3Jw;*WD|PJng=Az)M3>sHnLv`yw-@};o%C1l#r|6JvO67;a-lO@f5P*>^8Q}v$yAB zkB*B;VEh&vR5aY9o<`J{EL1R!KRB3&3m_G+!3IaI6fh1}yD#F-CI#k*QI;(0)K@yM z6#|)1ZuGuj0Wt9uG^7!cHtxz0hqTjqttHDxLTJOL>CS=Nn=T*$WYHfy5CFoB!@D1fifO;0AJ|*ww&LoSJFHLRsrLhhad{s7UXHc&+?$a)}TLl|7gpj zv{$5GH$;Y?Fn2c3Kk2Kr!HYkXh|tTpH3U~ufZUMJsj11<7oShGhDU~5Bf}#_#O!optY3XH#dC#^4;8?vuF3v=DGr#scZ%!jPmH(f?l4oq4|_b|yLF2~dbPn?{D&sX$C%GnW8vOFr)@P5g!V;um^tZQ2#os*Gy0bN%k< zFx^oRkeMY5cBWUHe4Nj^H|u20`QE9wIL*m z+Z_X=^qv-QCS;D00ih$OPe+k+975g)&Omb_PGc@TU=9#PZV)=oli-U81`G%lspP!3 z4Q?x8GU8|YvSK8FSk?j&TF;^*f*o6$ERsGrfMT&6x@(~*!>%YF(zr#fA*Ak5n$$fz z*SNNKruSrVp*1s=r&$z0@2rf5=&OW(^AAm)=f)|}3GL{mLc$c{K3hAFzc7Z6zw**-UVu6jfP z)MSW=zOOT9&n5~><{;q7P(8k?T{aT!asn90U%!66ocigL9*d}1JFOG}`Nao0h&GukFCeI2wmDX(t99!5$&!PTnsrj{ebXOD z)Z1Ug8$c{Qvy)KYSo&LH==7m8PxRToExmk^CFjzd879lMR^VZ6_6EG^K}Q}@X0w$n z+sTk{;MdoijCBCfZtWY_Ze*UwZ-1-LlbO;*^(aqt;22(WQt8XGw%rGms->O}QTBjP7dG-rPb2D?H?)&jQI^5hhyxFX=WPIKH$ca8JV*@La2 z*pzIG?7a2sJ{BF1BaM-j1F`8xo6C#mHuGqEi4J6392~PB8aP_P3q>X;>$E3N(CCVs z1$rg(=#Tq2dl24O(-$c%U(bmPoS=Y9W_U|<2bps?xc^>>{u!5kQke2$J!ir8?9F2} zkHm?Glq9p`i8crG=sx6#J|KpiqO8#3DvU`6yQizwmrV^wjvqSVf5t4MgA8p8Rv>`a z5}0RETW5l^Y<)T#7G%OW%_g&+&$wrA&6Zu$fA->Y?;IV@Lk;wgN_I56=aJ}+Lu4e| z*j?);5Tgt6_oeHrtLbG7Zf)I?jBRkdzc=N}1Q4~zD1|q{H5*Zo z4|Y8kzxc2>N85z_8`Hk*yjO15SGbY!Td!w1W7m3FXZ~>K_H6X&Z%(?Hot;ep_cY^6 zb~U=ECs8ly&fu071B7E`H9=_C>k!R6i6!?HP#|u#i7w+Z?t^{W60#=2ftzDvRb@Fb zk}6%U$z}x-f`1R0(B6T7ddgS@IKf++cvKAd2ML62(fzTBv9gV0!49X5Ak=i9&#%^| zj0Fb5O(fI?6og+8sM5e^!!Y^>I|Z@UkB@%+Do^%`eD%&ce^SuKPY7aE5UziBz5L*4 z`Hk$S2#9B7(YvwM{phhSPz>3x51aIkYcK5Vgd z_2QLgvtVpO5@#jrfk&(chxj==z6CD`FLFt*_*K4fej|O!3y+F3z#XzvHR+DNXm`lD zOTix%tbo}jzc#((ef|24WcY3u5XmT*U`GH*IhFw`Srb5$T5q0`(vEsKDOng`jxe@+ z<`6Pbgi?kkT%R9_qtbY<^f5L*o;$qVkrgGkBTees^<=s}|NQe9OB&~+)Mcn~7#0Sp z;D~`FpqZGQsFD>RM*ft>fin_|ICy3=MXHQLJt4+3rKP7mv$pB`V(5C?jGrPSVUB#@ zl&@a7(wa#mH#j(y^6Ke|ra1P?m(t%AfE(iU-zpeTp{NK&6X`X*gR&{IV6wSNL^2#e zP^QUTH1>)LIT7+Ng^RKQSDRu+MouI;+84mjQxIZM>`o%xuy!Mr-Kaa0hv{8~JF6MH9e0ZG9K4q7N`ZiBg7K zkiyy9+t5| z=)z)j!LdHbB#bo#m22`~drMD&AiBRk_aHrdX~u4mk;aW`+? zEPFk3#_=+{VpDUqfe41t0~t2tl%2u`yWo|}k)MD>wHnCy$|R44IFb#Y#7|fYGPIcp zRt*gdR=`to4&KT5j-(aLgA)W?Y`lvS9{>Oj|4BqaR2yy}h}M=a@V62*+9LRSV`6)H zW05!VGiUOVT(NNvc~-_|*K|)6!#q_oWl3eJWf}!xZ!!nLQw0?`MDAHOmvvC#ur~BB z!!KRXPEs})84H9}1menK%i$5R4Z47Y8mBd|-tAuSBG18;caG*EB>617`{tW(>Igm= zeMFlrlO0TOgcZB>dbp6i5R*+?1ET5Pu18yLoSP?D+hRs}2U zS(SwEw6V{3zWw&wx{fvj7*1cVrEgTrSoyci3kK2!HVPkPZ}|X~mCbx@dWQ1+`EzkH z%{f{Gx{&9Xa%_ycc~E@QXl>D?f0cJdnE-_$a#Al|OqXGb4j6}>aRZ%$VeSFa7(xjx zMx;FFm;;M$N0w+(bR}&Ld@Q710_2GS0S8J!nHh5R%LL3hSD>QT1Nce9*K=vJKnNa! z)1;u&K%50vmXbjgG5B#U?^7OQMn-M4aNG~$1)g(r*D8W9rx2%ztS~lXtj9}b4#1;7 z_XJFg*SNfp0?!nU9TmX44*;TA3ju9TzYHZ{M)B=fx2rp!uF?@8aV?H+cQQoCW^Pl! zYu*%*yeO;hi-wyh%u|EX%M()UY(j)^oEHl>%>spmy8( zYz%*WeW~Omi)oEqgDyG}hkWe5l#RBA*3ZT-WS8>=mUM|T=P+smNY+ckx^Xso>Nty( zA~HAR()H<=bu~6e<3ymPXUg)T;jOvPWJ*fbpWNvp`N-l)bI2%6PTVYjQ5H2$=YCq3 zt(hM^Zir$UutUz=>+f`-d1RgSU`xt*hqKFGTL^HMg(3&`1QZ2Spj2eN=PPOL{ATn*an+bo9o^$VleXYRv?=&2wbrc=aAVc#w?| zanPK?-DD8-^l^-2E^y*h9j=YYBN}9lFu(`I-P~oFJ?_*-Hsq0Rw=tp0sF?#`=0w>Z zy|EESx!J+n)|*XeOJVPvh(289PIH$5LVN^QTe8~{;JcRh1jegtjU#sk9w4XJGNc@| zN1Gz`WT!OhC@c45&m1Woqo*<*WKYLD1;y^n)2Byk9+xj)$!BHD8*&IA_4g`gy@@>9 z*r1xRWL+~?^Y=ouT$6rUE4ZavB>T!HWfZN4XG$XzWPv;*`fLv&vKG6tqg2+E>}!Kp zbV|u@a&o#HzunMUTgXMAe>&r1|L_?3p3MdobF4FXhX*6q12ryo1rz88vWfsX5ZY$C zYGVp{GH){H_@5?l7o4#z)r>Yan41llNS&kEI8bvz63u~3=qdZ43&zgh2pDV*fjM_% z!SfySc28sTv(}eQG5skEM<1-O(x~fnZRuj_6@ZX299EH%RqfbvIQV$9 zg2ldElg#@c?ojNnU5zcx_9ElNd6)a@}!^0B){<&2%UB-8B3pIJBy1C zf_=>+Gb_-_=k(peJ!^CHXtN0sK0Z$+K^ByAgkySsVTFyi5+)g5`2m3dUkEo;cgRRk z(jOhwhDOKTn+&$(OU77wmUZ6|JD#1JZAp;0r-~81ay>8dN5EUchz zJvaOR@M;)JZuA#sEXo3Et~D_+QO>uL&>8yS^RlEOJVfDn+97Jkdx$P$Ggk5i$V$-+jXv5GrYBG762JjSdV`#C zpi1D+q6d!tKw^L+5^b#kzVk+nO=C3Y*4>>xx!lirk1|l?Btj(D1Bp77a;*=?4A5mp z9cT~qOW$)3V0$OK`#68==qxji2v~Cj^u>Gus*D@pCL6ls-c_oNU62bxMW3x7xfh|# zS}Z-&*B2m+jv)^has-U5m|m~3@rnG~?C!TNoSFLyuqp^hNs2DnxoFdg5~t6|yvhJ{ zB)g#R)tKoWAZ?uAd}Ope#8ALVTY43U!@e59j*BX+wz{n;60U>$Qg?s7ks!VTgrZvP4QBI?`x4-&| z^_?0BTXl^(o+Egp%>dbKblcNen!ZHym7Vu_SU`u3zo#cz*ElTp$VuAm>3785+`Q;B zLS_AxzUdpC5MUrI^ky+Qp~u_0SU;G+R^5*-_^j{HPgxKZo+i7irqB>f`XS3gXXtWJ z<83=iQzA!FKL4A~D?2xr|Gt&u*;&EV$Zc9f zC@O26Im0knV>(H{={_=qC~Qx8&M`$CB-~Ygm02Zox(*WHchow+wvV~8siKh)S+Qw^ z>H78WD!EX^D&Mtv%o=*C7a0q<}d@{0Y`5`O1BtVdSV8`r>uOM3_6Irre z#_w^P*7fO=^uGp!T#tW?nw8GLiP}LN`$S%B67u~BA)jxKuCtafjxNAc_Bk>#oM5g= zXy~~nZ!)@k`EvZkSj`n_QEt_6pGS9Of$4&|$u?Rq z@<61uNoiZKX;1~Chi8^I?;4 zny)}gkxAD5gf5QewplS$`f?SBEtzjSPPmBXC7>@nJ@CKR~7;u|BJt7XXi4Zu<`)-_6Yh( z4hiPK>PVI-ul_lTUFdL?Cj77mr&AK~leknL3Jq@Y;5h4opD%N*^{ z&_G3j0NR3BWQzot9aUhVHCu~dDYj#NERankQthHyq<43mn5a`Et4Wtbki7ulGAJBR z!jXy=I4N`SHv~`FlvD9cSS3lNdTDiw&f&?b%2n6F$BA3>;CLJN4h!h}mk9GtO9LQQ$ z2k8|Bo4@yECS@K)X0vm1HEu`KFnY=>OKc2`OYaOKg-`&OW7(k$kZh>&nYKJ8*+rR9-O-Wp6U3Pc^3isA!e*l0_0kSWkq#Kr(aU0K5+vR#wtG7?PwV0=WVdoG73` zf{-m^;na-Pd$Q{yas;%Gvx(#M7}B)_CeK%Lb|P{X-QxV%hTw)n)<%)(=ly_EbYWNS zY25B75J67ZhK(@*7+`vOi1D%s4#DRUdl_ce-^hITBy)Wv`p`uE0sS~l-~^NfOHFfp zcAZDgh&ZCaP5`%cVsn+*&HZgudXlpT*F%zIZ8#VX51PJA|MGg~DY&FB?J?19!H3>d z*=y^@IU@jeUz!YCbqazWP%>50qbD4?tUd>g%&=wuD!JN3GIBg+`urWx%K`&!W7WTm zkXa{LGmfJxJ!xwjDN6+#;7nyl=tX47zKv5!m7aN#Cp&5Dv~_Y{vR9s_@7BW_k{SJC zvmED>*xQcG*@u0HZpcKCE5hL3p7qTp;HPUKZ2~E>;Q(P49Y74|eU_tanLfyP*rnQ? zY~q&S134Nmf<*q68FBA8#qqJU4Z*2oE6K*0l}h*me)B_A*bpp-gED+8vFG0GaFvmU zJ#fwoxk3qHg!!ARYp}K9W5e}b!C!`&_nm?u>(`vOC{u2Ofgn#sYp?c$V9w(NJ_0y? zgN?~T!dyY@LbBe<^Rn;cYaDb*uuj)yQUzED1^li@QKppp`c=jm9|Tin;W=wQ2sQ{b zZ3=Y+9$Yc!!iKDc9y>a~{`RMR2+qr#>4k%Pa98pIPS!&Wa&PuZr<@5%kF@0Qj|k*) z-h**SA54?wWgEUD6HhN(SJi`kZ_j-NTlAlgvo-=J>kV&}tl35RiQLnR&iNeOvF-vf z8#d{_Yaw-W!CHr_drBR9Z&&qT9la*2HnC@Cj^q&pTQk)$8Ee%8_|di@b5jbZ z5Bwl|k?CZY0x~$Gye`NfKZzChBWIXP5BXZUjwG{x`eYpZFfq8rwKVxpzl-^8DPZee({s+SwV1zN+WVM!aL!)M8XZ)tbk@bLE zHi=qG^HWJM4}616$X_B!ZzNq7tiopgkA0U;M<4hZJ=m2!%{*-^Wt+yrW?&57K$hm} ryZm_JX2yf)vT>&_98c@QX1@L}tBEsRpfq;M@N=pG%KtRA0{*()0p#HpHB6k@B0N@?4Fnj3Aa@<&c$z=pY_ScBe0nu z!XhwZO%M|pp}$E=BF1;&L5258oxdWGI;PvAr05Ml5Ia7Kz`k`ioe}G zFP*hP;s`^i2qRI0auh<|1;I9eaDHF*gf!?!h5+ONgIWWl?oxu?l0i8G8AymRg4d0R zslg@tS(LyP0#yqkb0M(@)Sb}pfjvSZ1M%uZ2SNwzTYB1{4+inxkA3x7^= z99i6%-`U@x_z=7kij7tp#WEw|@KT};jhY$Vuux>u%Ap^?S%9zwXAPS)s?`!LV4cRq z4N{scntB=`8{;<;E(xA7dw@j@(QL;$DRc-EfKv_c?;>r*?=o(^IFofKdcpSaZh&3J zC5*aWcRrzgA^hO)BmP7al24>OLLq<&g1{n;X^2shwxU`C#G;f(u>u8((OFV6rPf60 zDL7H;QHarnq@<**WR_%WQ@5n{q*7&aQ#&YG$gi`=Wm(C+6E#wRrFo?`D$vKE$KY9V z3l!bSCF7zu3N8%KXwNjyDdgfaYRQb_$!ql5jLY=POwSt8BxPj#l&u=Hy4ApwmN|wh zt{DhxeQRXv@H@(5mt)Rj-x+jP3|!YN;Vg_SLRNRyMRN&r=ccYEgC_cA{$S(Nykik;BGBuStC5gQT7ate5PGF~KC%TJ(%kE9njmFLPP1eo+&EXz&6?HXZnu2`! zMR9)dMw!2|lDd;>r0P=LRN+)Tb6E#)TAf9qQMggrS@=2zO@3UKM%p?-C1wWQyrrq= zMrI#jf9Qv1>Lz`X?oLN&XQ|P66$P@o5vEw0QQAH2m|B-QrP{ojpPF|yv>H=YpK?ic zXEjANW=)cyL{qXi!BQkul_-WD-LDSgAUY5m< z!KZxK@!?7G_0kQq@2NI;M%lJ2CNCaU4>Lz)zUdwe?+zCB>2?~{58w3`)_(IZ_N>44 zh80217O(BZQ!LM{x-^^D?DNr))o|AgX*_ixNO)@HcbZ2blbF3SuXH)VEe9v1~g5aqi?-!Q7k3Qcom(%LUay|@xYrhv9OE%2|k^>?G zvOb$ZhCuv64y^@59m*$!GIkH`GOZf97C2tzPF)uvs#%y|G*wN7{Cwi z7NsUV6+IE96k8Yb3=@Q#MMe*E|6^l4Qaxfp^i?c%G)}A@UMI_qMXC!1RW%15HX)Hd zraO?Fu%8rt8Nza&ka9{RvG8l9FH+RM`Xp z9KK(7Mi-WS7M)Ge+NRD5&f?BYyLme?JCe%^XT4{Q5E-G#p*#g02k!&RmI zr6;9Xdy#vi7++-MWbif9bB23!tJAZyR>s(N_HUtP31%M3;%?uc)xo41B&KLn#U>Qn zr3~*vtf<#{dimc~CA>zD<+9`)EIiYV7anRemN%Ba)k@Y|)?Ka@HX8p7FN$-(PjCq4 z9C0{Vt8L|Ryp@VqRG7rtNiSvic9^}7weP=%*Vrnc$iYPA_yk=*d~!>1`~3Xa#^b39sbs3Qq4eq$=^!3oDC<-0Wp?7%Q=UM#od@AY-1_9YpJ&3) z{A@s0@mcY9@6Sh0?Ad7eXrT+;_Di2A_3@XXM$I)^hI`sYrQ?! zg+B()p(~IYk?x5-1lF8@_fp$QOhT^yeF1ZaR<2>EO%Z#dE6Q!z%`-6sOet$35R) z(0r=qRh%nu$yy)I*$2IRC?)^UJ zRpc-5^gj@N2#Z287|V${iy6v0H%vNFXmw{); zhR4u_#83I0oXPctb@^|)pBrI>lW0|>``Mf{a-RNl?cD@Tr&SuPtlG;0jvdJcN?{Zl@uy$R7A{f9@62W}YP0_9YmlCLs6c`+FX&-Sbc#cP+uTC$0wKvQq3fRd{1ilx z`8tr$eGrsDuhgOMQ{!2W3(e^?bC~_<={wiRusaM42d+sdhf&Y$Y_}qqAbNZtn@?

S_L6AZ+`;D64a4~NoG&8EDMW#N^Ed*CgFMRD(@Z9xO_8A}`pn2A6T5ekM za=fOF_Ke16jwa@eUiMCZGF=c5elOlXMSF8MV-hcWI|o-@F9E>c6uf`Re^oO9Nd6{q zvlRen$t#hFIl7pWa4@nnG6MwRNJvQdUCbbiI09d)XIq@da^M( zx>z!?@bK_3F|#tUvNHUkU~u(za5MH|aBwC2myrLH12lIvb+LAGvvzbK`Ae>`iKDxl z008ipqJKaCveVql`ahZ+T>o+FkAqBqwJ@K_8(UMziN4vti8_rF!TRS|Npi8N8^8SYX66mh4X(n|EuL6PJX7p9QZGX{uQmiYyX5x5RRYe-=Pxzbb>sJq}yjGKug(!50GyyOODH7Oa-$Tas&jL@<#6$=%Fo3sWLigJHsBgh0e!*j2 zGzh#|5{wiCIT#vfR3K0oK!VCm3-+Ugh!i>Tf2&~tBvC16F#jg|t63s4kX(TbLWYPE z^}ngnsFtDsOJE{QEDES}t^`afzuX`B|DhyTXhQxU)i|VJ$=q=$)ZUqYTk?OD(z#~D z|5yIoNM=z8a%VhJr5omdZ2nhkGWWRPf6E6Ng~CYfu!|P%8UK&jYpIY!UQEpNdI@llw@I$#7MRxHi-i_u>(~~!d0A? zE^mITh6gV02QET;f%TM)fyYgQwd%lrFva}iTCNntn}gRnkz0#LKP1NlCw_|#hnveF zVQ3S%LWJ1PG0@cyT4z-+@)r>}8@9D{J`(it+?#&qhy0n%Lvd-^dP@h4Y5fN;E80*J zK`{>pW}@f6`mqE8R8bZ6!C@_O%>PO9OSGEa>u$G_QesFmtEdDl7@1=^pr7?-==T~K zxY=s{!MWGYFX+ZHnF!8Rt+$7=0upWb%CfoRIl-quXs5KDUuBNQ6S;13z3k}a+3HUl zWLSC)+}K?H9MGexx@6v5f5+d+0wBx)5BBxxtoN&x?Q!6*TH)J#&#TxIFd(JbPE{GM zrA4=pWKHR?bl~B+sG=-~;FlNgx63@(9+Uv)FMerIRn=!16#E%&|L63_4RgO_d-P16uoOLkcFJUrt7HE1^MkyBjarodo(sm;V@oe&g(+ zE~I8>Al$(e4$hgg)OeJ5j0@d{E$fg`;hu212n>S3Bov`bdBAo=cL`J+#p(6h(C=b3 zZw5v|U(~wK19~7DVO2R_+adAR1qI4gaYYUKtEYoV1`koBoKP$`BnkPKN%gYII!6&d zS!8}0LSB9wV3@8qy{B*;V@vk>(Zb8tt@HG37V1e=(9CR*!is<~`Rzudx<1i+nPlLg z>o;uqeTt>-Z&+pb>r)b?#t&!wq1ks+0Z|K0DKFH)GEghdP#8)?=E3k!JXj-xKNd3_ z(T^i)nu+Y~zf#lI0TbYvLq~>e+R5m`$b;JWimgLpG7G*qd8n0mU4CrD3dcSOJIH+mzCF0ddN_D`BQgD#VQ5Dr0rpwCggesgF zv=Y!2e4=mISPeXWcynMW{FZRYm9IXEFTsXhJ3n&RNN6wkBqQ>_W;4qT0RPp;2$}M# zFPlgiFbnmzcR<|F?7^#Y_)F4f%(mlvBTdWgUb|y^;aCbTZX~p;V5ogFf+1}=v&g<* z@EfQp_xG}|CPK{nV`4Cg>_wJLMBmP>sZ&y?V&}K&AJ<~K^Znpmn^Kqs)mBC!2X;nB z6>GcJbYzq|I*5(kAGrx&tk{)~+@4&H&wjozrpU&mB3?BueiR5t@ zdoC5V_|r#!R~JzSk>DX}UFXnUTkelcg;VWxo9cV**$N4diZ2?!a2O6zn2Jp`K8o?* z*K=LX(Gd?wYe;wksON1$C8)Oe5}1Z|=EC0oa_$=mfRMAlodl{A!C!9d3qQk|oY1JE#b7yy6xAE;OAxzA? z(R{#0gn&7L3gvH6gVGOS+gvC1)Lo%PfACA7ejw~E*4B(SdS$#UaBM}gp}QHH?u5)~ zJXNj~SY-^uQBrKj^<#lQcArp{#rwgFJ{tqNmte%OX~X%Z=JecJYy=v4D<6|ZDo2no z!;m)tf*%i(t%7X9B2*iX4vIMVn;)@F^ukt`Zh_d3JANGMI5xs?`Kg0uYchxDg@nfD zM(CAL0&;ByXqNf{G%M_`l~d&|OLRdWQ*@8>sxTfl%wiwE+2GAniDl@7op!~x;tmeN z_Dyd{i+E{~*kUv%zNvP_p>7)!A>Rxb)CIYm0O4Trr{*CmocuJxT5F^7jGBrHhE zAL~oa?f9R*-59e>Qe)A4{(%w!)XCTZn43L5Eam25BI{ZSO^Dssjkf$)zh%NlDxZVZ zhl`z4>1oxN!@|h`0JNkezj|t*xVXv>;&>@OfpqD@u)A@i7~x;T2pt>CkiPclqxAV< z%qG4N{(d*mkJcU$VtcpjHB005@k>ch%HMp!fBc|R+UMN42|FZPa0ouWN^-lQbCp;V zDPkEERd$yP#>3s+MX8t`#9NCXv@z(P4Xay_p?~#)H}QYBjgD|lBp`$m?+;&25mi>v zN@%^b7rkAiB=g-6)jG{-^fZL^_*yx*r>*_{dt}gYL)698{C>rBbYMX>reXqm9Oj7C zTv@+mjEI>YC04#=h`^d$HwNT9#+sk6&(!*QNMLf21UoNIT-Vm%!Z%sSj-!_}T8PR~ zC0}3aEMpjia7xs=Wy{bu#i|G$TVSRMv4O8Oq{U=jsJ1FAigQ0B)z*cuq$*^7z=d~e zH-c1gT=71$35T5!I*zLiCX=z|gLlmD^Uxfd@`rSbx%o8H#SPk)R?iuSDtsSR7=k>B zP&~T`hLas0&yu&HMy1bWZ?^*UZx2J6oaSInXC|>onxXP2=Xl+G)7wt2*H~?; zdV6UGUh^86Rz~!()smtmp{3t1ZwL21hNi`jTbffY39Twu67s@ou3w;al~$J&&}v4` z;Oj=7oU^2)V#Q%Jo5XHC>V2y1>`@WW>x9kxX+@E_p)+@$c-rt-E&!>VZUb3XLxB-^ zPDK^Hko)*Cs2;zxLc?^8Fb`GGOy$QV)V}M4K4KVqYGb+`>V>p8kAE-Gj!1t1FN)&% zPJkb`qPMl|M-B+SB!J55AHQ@j>MbHdBqSu)lvy#yM>(t-gj2fW8~sx5L1?(Xx@(k0KL8JC?fP>ZAa zjTrG4YgY!}RrUtG=TFF*vQ6v6jPB4lPthPYTu&2k8AY^O+k=6L#H1xeSR26SHX6|H$|;G{paPGs&q)!NC1m*7zm7%~9U`C< z^nH$ArnUpVL{p860vxmKRJq9;`2m9qaFY|zAN&Tyd$xI%PXuRV_{3?2d74(y4%IK{ zO%VEY$LFO9TWYO_{mH?Hn&e4Qmx~%-x09gUaRC11^O|?hSWNBLCTqiB~Tbv*DArbISWD*XelCacsVQJ>EIu5<&s>U=XFV#-CUt zpam&SK?XLKv(zkhXhPc5YL7mB&6JuPl-HKMT<;~|sqD7h%l%&F?dX*6>TuCNLQj)) z*FHRo|T^6>1VbDvP}q?ye8c%3g#6GL7`gaXDK4&?YW*HuhF?UT># znnQ(=ukcM!_Qm1Vjm-|oCr9izA1547SB96ShTOe5WF;(omh`NuzXu70bl{q&1DR`r zBsR90vtmWi%rW$uE`wW&?mABzdcT9pDGd$slpqsBmTloF@M0C9uRgLD+S)--E1dGB zgiqh~**XsYT4&TsKMEco4mphOE1aJV4axT=#|~?adK&RIO+vAN!OMz)ucRKBJ37|3 z+!xVSW=GP5v=2ej&vhwM;02toN548gu}oy>hmP*3%$?H)c|6bq`C@VSe2FOY1(2K3 z5%?!VP6pMNUZz){j@d2;GMYfLPGrb^9*x8sq5Z2jDSzig1Xn#DdA%b)88%|ClPl2n zVrFc-67+HML5_RqUp>H~Er&ea)h9m5F%f;07jJ?l_S+*XjWhG&Cw zRv>>HQY8Eu@Oa8nf)EUzXTHb_ee$SVSjZ5UPs9GRQn>HONoV< zc3@(;qKRRHl3jM_O0ag%Hvl5FK|DcZ)J({s z;{eglhYA@tg>pL>o~j=ME&PJ8-ekFE^=foXzT>`cwZX`QJk`6ZvW&d=Zh^|_vfk9` zUOmP6K3HplKY(+?%bTJa53r5!bEx-QPF$M~_UPe0bg$j(=DnJq1KkHm*lOEOQ9w`J zxa_wW>neex+Kq&7pIetpPbFj5X~$7gg+Gq9qJvcodKs|T7+;}cS!@&AEExLSpTl6T zImp;~h^-etPz-xb7)L{oY2LZnC7?G;2*oeo@C$lBpolJWgI4Qu!qjY`r&{1W4L<>Q z?O8@s_>%M#7q#@j>8{^b-_d_6>uSWT#ZZwlP+)tfP??$>-~gA7FX}0-XI(gm+hAZb zBcN9K15>5~SJ=RVBI+d+Bc=>uyua*gM?wRK~A}OQf}TQw0j90X5VJ*@!Ald+P4?E<`wFD zo%_lC_^>&YpB`S@&}UgC;WdL}CZ88O{`(#DCv7>I=Lf+=P5|OBXRfWX*UQm9WG*(& z224-?PtA_8&Cqba?(5Ob{C@a?vr(SiVid)lx%zOwueeWjB%&u$xqhqdN>lS8`QN#L zF1NODG5ZpkqG2H<2>kZ!pYCdMzxAA!Uf+?}+aabV<6uR9uchaEFz|7sgsqPktxWS} zvtgbqf??pYu?O)`W?ySq^+=DWic-vO5{Sz9<3$F7`NR-zJ4=6`EL}0PCl@tMPT~!p z!3iVIG4zHG<6B$Wl^P-bMI&4tR2>7s7iYqt#eRDEG#MU8os}CHFRm?>!ws6GmuZSV zTS(0fjh)L?K#PDaN;VjLQW*3oupAIIAd*n|xG@$k-+e8uiBmWE1E_(v3-w%CXQLB= zStIL&R7TlIt{_>AHZ(tn!UDyEo?Yaoxh0t(B-?}%1V6(B+~|4!4#Ne(#Wj>i*XOv= zigv2$I1sJ4n&ke|ZlZt_HHo@{ybMoXzdyG{i=27*yA(EFo&ZsjH9GSr0kV3)dF0QD zz{zrP%V&k2R$q9EIpYQ`dz_TKK<-h$=2dz%&6y9oz;fY<^A=c>cL+-GFEpKOSQk$_ zeC-WmJFkJFd?ZOOG3j81+H0gcsy@>2aMOb{7bhB0ZJN*?vA74Pd`GX zGNF?AxK>W9mGt#u%b!-0QnRD1d;-FcR*n6vc#3CdP%-ht8bVmgQ)6p@yXUD0W~)I@ zm2zeZ+3~^Jrl@5O!sEB!B;=!@(ir(%EE#~&ZLsH6M^Aap`P zQ-iC><61CFL1b!5QsZ-0$i7!W^>eO#aPyX1vI7W62zW%X8Gcqt3J)XT;&kLA2X_-2 zD;gCwmX3=mdn>_x4`PS`Zo$A%2fs^H)~@N{bcU1z#igaAqNm+|a5)OAy261KIS+W5 zm_WMx(~Qq|7NDj7#=(eizXGKr0lrTP=;LTy6F^NiI3ri<%o+O7Be+#5NnP* zX(4yeuxpsIS5J)I9>*D@E#vjo>|mI%<;&9os=cfibOi zAJ?L#3dbzy!0(^_EmDEpy|SuKSk<1vqi!>{o%5n_iYhC}W!L#3>^YNL5L_9xu|b=j zT$vQ-=y{XwdI2VR&M>afBv8N4?hM?4^qh#jHFBizQIGV|*d}hHI>vUYTyD&j{_O}= zr33shI#ZEIl0xI#3$M*k1?fZbPZoxB=OL&>9%o$SHF7q6hL&Bp)1ZWRwXwil53~=f zUtuhqZ1hm?AYz`z+;ye1aZ&BEnTbKebKFFhCY1y$Ys+cOl1a+TQh+dW1>7H&R^lCT zXzdnw(QMOHJX0_+V6+>u;u@8xvrYjM5?*1`ZcEfu3N7$^vqTMKxbljhF;+F1amcY2 z+r)tMhLA9HlsEPd4GXfUZFu&Un#A2l65g937!(|-;SpGqZBu%{0LT%DixmTzNQJzN zl_-KQ3APy(Vi@k8gz@=#0_aM`)13}ulTF{Sdtcz-$ed<7xFaV=v7Y4!7gK(a65F{I zw=JDC!aTdvWs!4p@JaFR*Wz!TDD^_0O!S6*Xk2eE#F^V~Fg2VGBYy2^WIJWhEG)S( zuS)($!zFx{zWQ7XJ$co@Dw~dOZ+!cJ(axO+`K_5~ zv4i=0yd-Y8q9WlfQu6y{Fd9`G4Wmls`^%)zjwb_R$#b+NU-Xju+dCDBKNcDep|q+A z`+Pz$e`5zB!_v#!<8|h}i5|Nj<%JeI=qRcEpp}jAC0JfM?{NEu$`$7=~_SG-$EBSgts^YN91tLWWPSFb)f}F@M z>At2>tUW(EnZyJou{nM6)Lh~`Gos=k1sN;{8Yk)#LQ2E9b)g;|mA_SG$UxSU0xY4I z#K70~U6oa4U+d~4TNf4s2F_o%G5TT}rwtnMGJ6gY)tZamUD?syz|90V&c98rHr&kKd%b)`Ga9guY{o@#L6BheuZ{+`xG)(O zSF*os$tp_2nR*Q6e7}NFpmMD)1F*2b;yw!=i2+c4jCoo0kvOa9q7cH{sXkk0%=v!Z zg7nrWJwBih>7d4^Sc#Zal0l>DjgpuKwcB&<1HXq^!MJM9I1wPVkFF?{lp^J$Z7+-^ zwZB+R3OQxsL3V9ILvh5^z4lO3o4v>dE;5!n4HS!f`Gv8U*ADS?N&EI%HP(=vh01;> zq35y~l9@yh#7(M$R~PxQv^pLlnb@U5OWjvUwI1X;Y`EjA>=SVOPX8&;2t%-7t8g~5 zKQF-omaCO#*GDQPi>$1g#48S=Wm?P4&fZ=kKRj2orr0sGaJ~i|Atquv&z(8!a580G zf+Mwjhf3C;Hh8!XIL2Vy)VmAzQylLPP;Ln-vgJ2LPvhb>su*ZS!Fuv@aGPTvP~=0) zi>v0_4#d#&>r};_2@|8cj;wJ4AY(uj_x6QvgW=>(p~VaZKsTy&hQ+PQH9&c#FD|HJo!Z!l zPd-T>pi&;eO6|QurHcf=GmebWWSf+RnKyY;U=G{LB_(H)04Br*<#?!^yCcSC=0SoN zbawX!8Ph%G0q|JdU}mO!H^ntSU;NUPD$D@6L>@ZLxXM||N3~TJS}}TeSN^;zsrd)A z;ks8PveG4|N@QU1K5A#nvG=w@BAp*56S4`SaAgum+dOM6M85b{Ix$G+lDU~}Va^w# zyQ)Ez_o?~wN@zbif>xC1yWUt!S!)B!h`leth1sR2XrRTEJHkL`f_T)wr}&u5yi>_s z=TYy(er!U2Oa06xfso*GHbF+ut8FjIBLPa@n}-@x^d8`}{F>DZ5%pKt1xr74DT&ze zAhpr3$~vUsCz8d+xgNU@i$rcVmMBJg5f)frS`E6m%KEOwOAO1-%zdDLS2^m>&XxZj zpA5%ECd$PzKV&!$VW|qOljl$^?uNtls6wt@H+-_27RfSQXX_iBECdf?6%j@O#dUDT)~YO| z=j!%b{mJV|!{Y`oj0qie@TL%v=`Gw<%o{;+OCL`Ngskmo z>1q9NO2P#YahKz~$A{I0UU+2XvC($cUro18*nr=Zo#s^O=M;wG`ZWoF$O|?@UNKmJ z67^Y=N#wNmbLir>`54DYw7MGKSI`S{B`!uAnr(~vK`VB0z^VFkO2juO*%o?AS6DBylsc?I_nZZ zRnU=3PlXUPEt?CWyQ5GXap_k)i5`AZ*{cLi>)|j~cW>Kx5>lbOx)S~JTTs*-Sskg_ z()4;C-g?QZ5Q2m-<9&xmZS59?v$qdRwtdgYc-Dm<-$Yh4x${^ILzw)$s%noW(-A*+lhZ#F)@M zBm=qmR+aZF2Ocl)jQx+0YMBrt7Sa<8Kb~zSq}v94I`V!gPpML~GqZJ^wYGo2Ve2=6 zG~W5Z8=oZg0nTD;m8~;f=kq#byW!IBFphBMngWz(5|^aNF2uiVK3uTAS$mQinVw--%ax-knCO1b&kRW7p~n%c;L5*2uPf36a4H$zhTERU%2Ef|V^Rl!eWzSQ{A zee!!rO)F?MedEtU54G{($bb>fy>|QCktD?+1WIBRD<0HW=3(%so&#ets-G0t47NYv zWBMD^r~h4nR^8(6n>Hx_ryKI6U1@A4J0ilw#oSYt@HD}Y7)-g z;MpRdkoa~r*Ok+sttf_gROi!x|6C9{i+b?XwyUArnyX9Ha7@TBMy$;T`$X!;#?!<| zXkWnK>1B9HuP<%-uSpWZ^nD;e__dKqD=7e=>q@@}H>Ew_3*K&~7del~+d?5X@{`YC z5aZ#NiJteWaqhE)e<7^x#fN=4dUyGVaT-6$=)M%r%4B*mJY>bh;k zDsS^#Ma3b2W2RrcG5);?>{3O=G&VY7d=V171W1Q=ydl5n!B!^k#IpTJW!uo&1j#5- zySOx%n3f*me4G?}O*sdwXn5-0wp)%WnA8azY|I$orNqXbz!_qvLA1IZ8!|~4*n6`Z z){#EqRs$0(A2kAgAmYp7crE;%z>QrZObd&mAq^3OV~+01QQ1DRSa}{^veJ@^8b%qC zFRirxT2_QKe`*u%yY=-2b4PsWK>pJk{B;#KDG#;0^?El+@6(gNy$Ai$A!^vSn@E)R z-V{$}d@UBlpeb!YI!<|__cUNQZ8%8tRQ`E%HwdCH&9PJTT4Rlt7VFAXfX9A- zO*^<2)DbmIY7v72cTQg8B=`3n}>{`TTWia3h=F0k62Y zBq@))IQgdw0F}FCk~>NBy-6e?wKYbR^nLn0TU%rOF^JXVaXO2*6vwUHkSKKSg`@TItj$y zoz;?2H2SE+?>#-Kyj4`)GkO38lt4f~ZfSK(a&AT&hs&0du>gIjg+)-}2Ufm20ERqn zP<-SKL1$^>M+5vwrLBX+X`jhTcSJuYALefI>zw90USatdZOI$el$Q<;H}WDU>H;Zw zG&E%6k*EI^*)oW#e{A=WNvyFPHu7!mu{@rgZz-INB92^RRwR4$nhk#@#KhQ|i+gH| z-7zjadXzFb;*Z!A+^lRNWUV=GrfXvF?}to1>3QQ(lhZ`Q<+B2RkS4;`*+=M#;OcF287)jkCju0_29sO0D4d;23+jkA#`; zng+}|5dx(JJsX|~5hvQA)i}#{b|^APbCmJayp}r|M{jTQDsP1pTkh`9-JS;U{qrfx?4rPmjI@*D=@ri>I^#l|mZ0LQs zqWra4g%-xW7;abpuudHkMT~dt`|0uqVOhex?am=ws@uGiT8gSR0 zd*nbp1a-jLO-loHT$Rd-Yb_;*8LtF=Ur_ND&w9p0Kb9i29C@0d9}{nBD4Y``9gV$) zqo)O}nSR)OF4BHKAcXWJLEkfkg+}*ve3aiRl_cfpx#xcAMFy4kycxxn@jQpS9qM#E zHxO=R?J4>r99u9mWUYsvUMCe9KIkIhv*GcXKnNzSIG$XphK<=YNU6-Z4mr6Q9NQc} zwFQ)wnQowe@HujL2(1`)G#mY=I5Af55}h=LBvFBk-l}>pc(<-jMS6%rK%lavz}+H$sb(y(#3zS%5zKlrhZr0=njnviHH=o@ixy_ zp{v4$3ed-kgtAXF79)HK;a}SM>{UZMpl0M?9& zNfN5*-gEIq2$Smlae%V&GUz3uY!U%x|LQu;(cMYa1q);^G<1P8;M+FNg|&#KA4|H> zCwD%5O_9i}LT2~IP{rb&iBEJM8lF!G4{yW$W*m;^t9vGwA3fFq>j@XnGRh=RQW~EV z!$Q*UHy8}3C11Fz94%S}pfbKFO0{)h-G}{JlNU7W*gll{uuMBLA6$vke7oaVX;mzm z10P3aZX{>if^Dq94tYK|bl8&R9q(A1sGaT380WOoQyJn=HsaYp6wEW zW{O(3!ESK z%uP8!Fa-%(p5drS`Ri!E69lE8ZA#LEM~f=29HKAalBwQ(2Zj5&Or{!1b>B z53EQZy6f4IZRJ_LKzjqWFRLf_Z)g<`517a*J|RxbHFX&3%Mjo6{B)pVdO&Cl;6Q0m z3{y*!ZUxs;e8Q4S|5{AHJK4aUa*}j4w@(H>c+bjKLQxm7e2qV0Tk5WmZS{!0rD#^E zt8@W3$qW_|&xOv)b1{c4=AN2T0hp>h5*k{i`Gb5!o~kNg{HM$xWEd4B z=z#ED<^)N47816_Yz-}`8L3No%y2JMEG*xayQj*<`e$*iEwu@EeDZ%uH1`rY~&O29S?ULLPEGdCXCm3Mx-|*H$UVg47nNL!H zm7s%SilVs~@AolDRF0{E0)cnYZfX_M!&aDa#c@9PA)IhbqZ?guzbq+q{mMz0qodG? zNmXUxrMcyCcuJ3TsXFGeZp_U2{@~t%l!F3AX?9)+q9cZxg(|dBcc_!gXKOW@c+rA( z#f2aC1@|&ZSu2}TCaRE8|J=L$2R&yD6Kk?VK0&!&S^i8utIEo)L#A^S%DN-<839W3 znff0b;nswt5e7Pypk4u2=9Xq=WQ^QqFgs+Kg5`&62E%{Taiie$4ofqW#6Zlrl)Z#j7>-E(fk|Bhr{c6;{Xx{E5t$EEMi@ z(Xu?1tGACr`4lOcDkBs*&~OayycsGIM-N_rFxcLsZ%AiL4*{mnB=c)c;F9&zmQfe7 zG8ln?%nIVkJpwfy^vv;-nR(t{U4tIj|7Wb}A!N?;QCeX+h}HlQIKwy1U2L?;!AfvI zqxIg`sn@Tt9=N(1mW6OVb2E^7HHOQHwBG7CTQ2m&3j98=NxYjVEy)hk4Yx+KSf*Ik zBmSA%(Rkfcy&4mXXof3 zSLw@2Tzt9*hQCVCHMTwyewj*ogA|ZLw@5=~hW+Iw-mVd7bVtJ66@^~V9KnPNf)2-s zx6>&*L#~u)J_kS%PMAgf1IcTJI=aA1=5U^JD`{>8)#XYX@V^i>GczLr%*97ap?g*T zV_>YfQL3V|jGHybmDQV4)%sm+%ILPGouUvpK2~9za$uX(uR2CIcb=^y=OMA~-d!dc z>NH;R*hvWs8}?+tBur%92+AK2Mp*d|(ORu*!?%kIVw2~HoW{_08-A0*39?~rpO)6Oe1@94O4 zpzF{-F8kUOz{f#^zB2(GK-fzBc3xR&HQHywWwGXlp8R96SZO&Zz^)D+jY{#Bv*+1> zLva0M)bpYfVp``#lpuszDmH{H4l-;7qIo?Oc6KN!D-TRvm5`Pfd-ZY^9&k|Pk7 zV99DDe$X%yp?4UiKpWvAygRy9U{8hy&Ad+L8EhsuBjy1m_J;F}$(2;BEyQDb#NX)R zpjq6%vN~WPE+ZUe0yZ8OPpV|;OIq7@g{tMfuWrL($*0l$>CfvgYweBnLWswxl+mJJ zuI|`N%od4SJUh3Mtc+t6C3SKMu|gicdvLbE-}n+%u4sZrkm#R5)AnUQ+CerQ^kbpM zIini3vaow7`(4 zBg@dq709#m^Fii7F_TRg$VloX`@a3jLH~j@=l=R@Q6$fY!qb1>QG8^S&}c!FXoZenkm-5d(!8p?_K{O;G70YlSA5?&%)HL?O=6=V zzEug=+<(rSB$uXhnr;6Kjt39IA5g+D82hqz`-m%rdn=9%Di7p3g@xUZhyApHYuQp)`DozQgZjzwWLrzCn=K;d|^szt?|{j z<8Xjn&u1Lri~Bftc{5QTOqGhKA8eaF!?5MZ$(&g}T?#rp=f0QF5=OeqZseL3*}%H^~x(`8-#-oJiOwQ4G7Ax_^ zGvw=&rpE?zRfgmMe+o22G2EB#=?$#}`A^+2SZsqZU*bMdfZO%8)|AJ|Qq2TNfTW9LI z8{VyWgAtu&Jff+oc6LuU*i&$F9kJNU0I(($Lh?(aqRHIUF2wf_T9<;Xy{Ih_ns&Z2 zcMdUM=2m$fK;tWIPKCVd%c9m-^v)Xpp1yRDv^8Z|aHJIXW}IHaD{qVGXAn#G>v8sS(Yr+OkAecLar0O}aABF)o`teeN;v z%375#nuaQ4@73J>CL__JC=;%TQZ@vCSv7@20--!mVC`t8NDvW&-F)%7IaZP5Sr`&r zW%PraRCzudg~I{VV)PwdH;1<2q#ZbN_K=)8%G9vBx;_P z<&IgD@ZcUrq$++9+#U)0O3V>E7lw_`G)q%QcII750%A|yo9w@46zO02%`nyXG|990 zk!1QmcX*Tn*($=8x`Z2kN6w|WpD1t#av}yD5?9E{aYXD`8O3(%NI*kRs-2^G^I0pY zFLIH&%!K1Bn#$|b!TRp{nOLJR3%!7q2#G1se!tEd?e8H{8BBz$Qci z9os7(A5VN(eX2KJ{1ywoopZd7Zr$mHjVOf(=&mc^aCp)eW*4*i774_dc|3L#p&m}r zUV5L}5wLT9NXHP%u z?TQ7DCO!_LfTMAr!k|QGva)YO^nuw_8Z|r=P)OUxE_TWMBP_Ac?Pqa$x zsYI|?N^_Xw?OAH-MqNzU2V)v$eV0+ShP9D>C@e2SWD%p(?@2FQ zo1a|ZKNgeVk3By5A@6mk`#4~jh)gBU^Q!qZ#NmKF)VC@-T7K}Zrhf2_TOdjY{^apu z@H9a%Dx)o9FpF2vi$i@Jt3xkUn8wuznK0sV-D0HRqX}VBPJ5@!GFOEU_S@U*I!*yv zyjOKs@UWGXv(lAI@23||@phQ`(^1;vw$2M?>@06#(+JsX<y9er)C_Gc?Cit23mGE&TO0d_cc`66zmp*fP$~RMK7*VrSkV zQuef>tMg6MELQx@JZ@+j3+#u^$8F8eS0>6_U-(*b18L45Z9sht2^{Owlw`uN$=?i; zZa|`$%;>$I<>#wZzhFltrhVRcDXVy=gJH?_>x#8+q zNOlRV5Hu;4Afr-l73P5Svl$#TSoFAo`(j$~gm6*p__LmCr}m89`hYKp>dlT}e}2%P zh#>Y_^1f00=XW2RNa1hl)?3IoOi}$+68)DBBF}w(ODY}sJerEak;)OEZ7XxQQI+z5 zW4pw)t9PSq$33~Lt98l8=b~s9Uczxynhsi5G+vuWV^t}xHiz}-UOLXL^T)@X1?$*w z`JGZeuO?!Fb%x5NXIxrSCNY->a=EAz5&mfBP1VaGoRq++7M4g3HhH(iKpdkMagq`v z0{R{a6+POU+w$!u*V%1GmH!7}K%T#&zWP;c-dTbsZ4wqHq=F$!+J)2T61@wAKycniHr5rBYfEw1=6vU6shw5jmQPp}KbIVy^ z)*qsY{Vy*+O9UhW5&?<8&Q8^t&*<%;-#Toj!~bBv#$6qGV|8J z-1ANR^sPPUxOFDFGtkfW#|3YX6D^fJ@I(<82FKKe(AawHM2z8|DWNucm)ZKojiRNT z&Ol@B6y(#$D0gfIa&yNb(#jMjIr+$p{uGmSO3a#GfW!zp!vZ8i)suxuOf#)vyZHYx z6xvp4>0QUR=!Ahe@5iPevFO8-5s}(~g@Jppac3=TCJW+|Ek`}?h!>SVN(3YV5`j^M zfZT45vIlg$8sX`G{lTAUC_VzxB+gT4>@bHX;NmMg@!t;%v0+CohRNYO_%`wziGV~v zA|Me6A~0~)KO7WcC?Y(WYTLLcW)a4=DkDYwrryQj!0~=}2fce-Xlip)WuRg@3m!%Z zfF&X{m^k!GsNCR7BBBoq&EmZHW#vA|s3kp|v%c|j%pRYCEc;MHC=d*5 zpa@El4$wOVB}xR7F}W#O5~zw7f8+PTu|@K8$Q3TwsuTZ@LPHW5ioEleqUE8rs7Q}Q z^*I?x8KGI#iLa2nqC`L)OG(SoYdQnYouV6r8_7Rt!R z;h_Vsb;kYWhs)6o4{cMtv@=obr~=YavT!tys1u4qZ#*DpcMmiSKzPWdz3(P;k@wMc zz1sl~`H4nvBw0`g0~+=o!JKE^beG?=gA$cGv};r(4;J{jpr5)Th))N~_B6mBqe4PK z9Q3^TVA4h@QB)|xQ^U|!QHd^h4#^VR#1tVt%~fdgSm0LM5gTfN((h!O_A^}w4awtE z5JfBK)`mtfngEn$#&5FfIiNgjJ7Y%esYX=FScI5p+&zG;kyz3#a##z@ek~!V~qqtERSXdzvI6(!4x^qw~NT!1Emju}p;wKV3F^pUu+Gq`9n>FzI zpYJabFf$^3CJc?Q!y(3Xm!B%fzJdJtu6??k9bifw2SYVD=*g(jn_)IFbixRwa;Hlh z4zGtugX8IO!0BcOrqor8VI$KE4IU$hpUHGmZYR8q8RjG&;`!^DqDQOkuLc((HyB2P zYH4wK5o=6IdpSMlvXNYW@EzqhrxF42?7S}adEvRs*+fa9h1tmYZ3GW5n19m8c~BUR zius7?tO7o!R`TdzHPgnlH_pnbY|e4qD}XM>=WDDgLq+)>lVGOW?xgD*j+*^ufs&6_yN=n#bkebSf&va|o zivWoSF5mx6B$z!?;KW16_S(E0=~zGG3wd1~Xm4&q$+mLD&zX%V6XWyrJ{Dd|B(v>6 zXL~F5?k1^q0+yImgxKv!jb%(BHaOsKr3?Lbyn6o=i1_Zkn3)oRa0?|bA_DYK4G>Zi zapmAR8}fkQ@4d&c4g4V5aKt0UV0F}B<9-j+$yUtFr3C2URr-I>AvP}$f?VI4Ac@-{L%$QQ~l%i5H6&~B` zz2USdOp+aNM{!XTs=kv{L{eT$N*QtD6Mm11|`U6OyStp*2o7o);QBZh=OHZ}rQ1}zmN-{)c6v2OmpuLKR8Xle}18iva_!u5x{ z?@-^5eC`|S>|_6KWcM5Se0J~6-&KubR}SV*j6o!`6rA2gJU>55H(G6bZ;HB zHdyS@$eWOZs?>3qG+_c}XGWj?6BQ#s2TN2eRAa|cdce)xNG1t-e|1zASdFqycmA!lFZUW9>6P#K!U_ylh&6y9<|G1hVCGUUa2zw}eL>#E(2jgDwcvBhE{@f^A+5t2F$xuz&QSn_K;^xZ#TY=#C| zNj@xlp$F&PdIKg+%?YMkQMGlVa(_9>I6Ap~4p+We3-wMw=TO#JFyr^zy#g>vrT$eq}v;KT{I`wA< zXtC8(hR1Jv3chFtw@p*w`3D}rcb;5^S(%B*2^}VG)v2%PG2O9o`*LjFxDO9J-HC7i zd>&d~e*hH@{wVIz002M$NklKu5 ziPf<`edVE7Nu<6E<3%h$v}>I<3!pYdLGu!2<#q;7PDkX}h(R0S&;1|{T;M3gNgPFy zurQ9LI?B=3d)CI6mLs3irs>(yNEU>YX&-zvDt6TFW$KGtk&zOE2oAO*tf{>h`U3y; zQ#|RZDaB^KS4D)toDq)@j;~=mS--lrS8hP@#&_^cUBM+fI#MCM9n!D7iNbY{Q1xa2U_>A4r%q7tVG*siGRhWYqY8Sd&Jt+Gm0bjrID~PdDl1LS% z*W*Hus~vk@UjtQD71mdui?~z+C3r?k9WyXx$@lTw>4K~!A~Yf#2~2)#pLr>+O__%| z*D^(kG67=~VxXjoEW#3w2U8cY<3%GrJr&7OeUZ5jVSZviv4^YZ&zGu1k;Z}T3@8dD zpV(V`L09v+x={D&(|EngjCtcSvH0u+1UhZVjIzP@WemH(Im6$!1AlpX8H%et7=P(^ zF+Mv39_@Ts3isfRfBXh-WIuvMxiJXuAMcF#2Rxlj*1Q#W|NeO(<0eeVo`CULDM-F> zA*xptWBW6Y;I#=4Bdh!=tgr3B=9IH>%ltG1y6RBA^#c@bTZgwvIB#B*&Gksn`Ry1V zDmQ<^KDMT$5JhV?VAu8vG%may-=EKUmd+6;wa~o8-CcvHfAAZaFT9Z0~UH1|7U?IBepoFQ_o{5}rs(nf}qkQi~>}hl$Inl_Q)5fIBiP~+|$UirlZqB+R zijPNBTXr75--VXCmZ0a4uo)S)2=y1)vCe9z#Dx-uqcS$ynNU34RI&;CsbW)xhaj2R z-vz%u>Zv@&*;<3<>Rl)?T}f$EB2r>Z&;}f^&z=U=-G4z(VHqgPk_0~b?zdc>8*tO|XtlcmRf&6qBlEY{lbf67< zW}aB-ok zHE#xOS!na23D$#k(S>3Bf^$h;1g{sl-2zCPvJgqkH#eb&yG)XO1JyTb?nc#2+oJBP zf4^J%dz#SI+KG~?BrHCEF@s|oVNy^E#lh_8uEmP=tC?Q70Ua)(x)mofj#Ee?#?8M1 zndHf2D3nYwHytOSK;Aqgji=lzm_$xR^&UHi-wuCbIwiN_VBulMdQkOpa*KFQdf3w} zRP*{#Q`gSX+q+>n@B~lp?N8Fx1Dr2>ZjR}FTTrE62t`x|#-xvh@j@FSA}y2@9>A5y zx#=}ZH-ccRH6mpXKZ?!v!9sN^O%{V+D*eL#gU^xu<5b&8iE-g<*p5#&)u1sDjvt+0 zK*t9X{E*pfg93?VFXH2pCKQO|)Fe&=n&9a|XYF>p^GO44xpWMs%pQ-Ja6O`@FGR-r zGVCZ{iTCz2LdUpiJ(jTuUpOC^UzUqNM+J)P?XWq@@aFOjXzZjJ0u2d6MRLOt6rab* zR6rf*YHLGveJ$!LOR;Br5%%q@hGQx>RKfl~f(w1FLpUCN+%T5zq{Mdvvk5Q}btE^d z=05vVVbeutrn1dg``LQz>(--t4Cm0^K|F#x3p+(x6A2TK6IhNFyPn1(6cv@>lbsIy z`ZrUM7;k_{X@y;PHqw9mckJ9-$#Ia3IV4VlpPn1_h1*b5*$PkY`Ix(K3^fR1EC?@P zB|@13YLHj+fwl^1p4gasX+KI3pgEE{H;Ac-y(dgR#3U)qM>zkIPl!3Uce5%sqXK{a z%zU2OgXERZiKYyWwidKfc_Eg#|3f2Lu;)mfl%VSEn zT(u}?uou^GjRJ^xazR_pTEVr;zqoYd_Dd)FBJ*)L*W?vs-v|s+3K{*alKcE z=9R1AV+s-WoW7sgH#zY$QSP31K7&4gKB6fVi=}!{JnYa+ey;08V)ygdRnvlq3NH*k z6XwmDfaqugW}lOa&#E1GbZaf{DhL}S>Qq{j5SFgPJ-4jEJ->Sbm6x0k#SIrCpX5=+ zCD_$gf&IHT;%oo+7^d8GKjzJugh@xC{9=J{IqMOKod{KkJ{bA>P-BMp#6cp$3E1pf z5*A@cMYS2FMg0&U93(78LF)Sojl?O+GU~WQ2lrgBf6Xz*J0$`?p8Nivv4~*|LXjIS$SA03>SaJMG zD*`1w;wGoVx=suC&KfFo86ttN6Ftwu+C98{rM$Vz0t65ghoM1)1ep&-eDKX0qRwKI}2CW48V`=KHn zK57}bwab-{gs2!K3&JHP8Eb0LzA-1d3xB3vNUm-&CQO}(^QKRL-Awg?VGJfrSpbc% z2mXIQO;2eDZS}bQIGFdS-%Z3vv50cMA-J@)5spNqDBZOYg`3vliC5Ple#R2yWzWSq z7o}iaKAnb+ByAG&mLRR-6c3Dobbo z73bPim>I4_0cuCu%kb7i|A&{Ib79Sxga_uvLw9h&9_pfOq96;jQ*=|b@8K%05q7L% zUgyieV7*6~P6l7}b7EJ!=QA|d(oPZu$Ywk?1N(+rX@Vhi45l;r_EY<5FdbHpZ_kbo z&i#ifAf8t%*1xm{TlX@J)uL2vFAYIn4%Z@^iIOH^6h4GqDxZ(optzk*G&k3Qel=8$ z(JMJ30!EEL=t(c;VNGzY7UYU+ILDle9`{`VJ) zP~XULOI4}bgt++dp!1S=>T0bKi8%$Ziz**#K<_7#FR>1Yc~x*Stu+oY&thPh*|Ozsu$0~xk=^`oY{MGV;CbwCuIShFXFD76}Wh5J{HUgLGd4djkB)1 z3v{^vn;(bqVJ^IT&kcC2IunZcxp?H} zrI;9Hq1tJ1dwQj75uj!b4(^zV)Id}MF6LOP!L~vgl4j|s%HpJX;0Prba2+KrA^uKm z+ue>!Vv>R$Hf23rN0{8zYzZJbRDpshd(f6=;DyB;LC-;ZJmy?=Cw}aC3@bK&fFFKy zCmwnJUW|1W;;rYG;nn4=MypyC28QoJgb?TJg&79>TxYmC|FAJ6b`|Dc$Yy zDzW&+n{nAqHzRwX)_hP+PUsh0SlgTG;H81PJ~o@Sdj|-FSTGnD%oOTJTTwZ>yQY9N z9{sloVh7*e(g@_tVUSiUqD3AaQ7CEEnz+zgd}!HTjdAx~glsy5*k}YCJc1s38Ur^k z78?(qfGB=%J(9G^Pt$^$eb~QaE8e{SulUd%j>L(SGEbe4pa1q+B*Y~k+)h&lD`T)x z8!&7?;~W4FwHaGCQwrLG;(8bCjC4Pas-|!Tn&q-`425fj#)yRc^YNX#0@%7?8=m^{ zEl_faVbOaAlIScezekeT2|=yMmaqut3P@hi>qSbUAi8P z42;@a$pDOGAZXHch>VHB<*8z2vXNfqQ|#Qi3vVpRfIVyyMk+I)wUuM#;TDTi+W4^; z!slDN{4Ffa;>L&GA1$%cb02*J_l%A5+VEVI}dPf*Vn_-h{wd zcO--+poHnCoWyHgh;o)%g^pK+ZA&6F{6>xv!qIoQ2q z8NU0HN}u=j`1_61F(EMo9=&L^)-MTR=`uWd*KWMDU@^Yq`FCb+yon50F3YCDCK6RMb0EBR>UHH`=wJrBCZYHVM%0NYGyD98^$6LYTp zWUx=SmOB}D<2s*6Ot^{wXWy;ZxOo@;@ZjC>wHGnepGxJVTX5aA(~!u>y|ZHmY;>{I z5u}*oiZF9@DA{XkyeINdWoGF#(g-ldo6ljSp?GL{hSK&tg5Cn#Yal;$JltVty^V%Y(WXpdY zYB}`>6{ecvWBB~(*RW0#51qe1u1xj9(G}0*<&9UtFFFOkoj=rN747*r;}zXJ5R*Oy z9{v%uYB;d^l|NzkM>4v27yu(5j{EMs33G-;A&{2jGdLTQ9`5J$HbtOz8Nl3b4 z9@0{cShebHWR_cz=S-r7hR>oWjXN*06Z1J?9l2Sg-H2rTmH`67*K&E@H;oK#)HLLb zAV%Zqv#E=u*BFhr3%OPZp0VgZbVMbVOW}tc>d*|AjHry61AaV2Qqi= zq$M#AbN+lQ;^B_cJ^Qi$sU_T`+<@O*>4`A^wm=gFe8VFVRF)5O#da*KPsY@1ry!2W z&|}7xVe#uP5bKNTJ*`0y+H)P@3A?%k_oJ7x))AHM?2cGIX zuCOPx24XyY+2N{JI;m%~3Q3E}2bJ-gjW=ltEax(GowzH+v$~ zBzgzA5hkV~;yC@|$Btri#v$&6GD+^If;o9SExM=KKYm;zxdRaZ?y7q?Xh`b=02RV<4kaGcXI?XlXY8!WrJm26Gff-lN#KsTq#I`(=cTrhMzT-vQGb9N^ zB78Uy#8mSmORF~J@(FV^pGt^*Mp_8z4!WUa=vXIr_Ehp}imRYz zK!KXkhG)2}>r~PHi&Dt6Z3;4A%5{E7DlJE2D~FE3j2z|Yq2+W5R%8u#KiQW2qI>qNFNAe z)M(7RauzBJn&2N2=n5XWs5eIUS3`9%$0GH!tn8g19o;viA!r~`YgZjp z7_nXF5_jT?5N%htwK|vh)f3o%*n;8H)8R`lAE8vYFHYj88Y*(J`nx6ge8Db+4;h7# z)0o0&-dMzhc)RFWl$4=TtOY&jQ`XvIlxOe8xBuOU!r4iPjSE6ttQneWn#g>kHpd6{gIYh&6A|$I6NZH2TM5@Qr`O<-=nb@IlM#85$|b zovWzSZCbkmJ5MMuV{{D0&Y6r9zb0fEi3Q@?Q4!$hBF^n3rmh-9(Ej<7o#-27WDj5j zu3Kjz3zwac6~8Ch?rH6!H%Flh#L#K8i8o?DsV&6;Qn+L@m*(EX6NyBX%(^P!B;NNJHA47O#B*s1v=mOiG;d(v)Nkm4}Wa0gL@4?Et29%xUOjB4g#?JpM zp1PU~f9D;NIG60$Oi_=2J^U=z?Ds;k?sB~U#5~0K7^v)Z?s#Xun4_T-wYi6|=wHWh z*+Wd%QLziP`_|&6Rqx@EH$!mmwc~NmoMgHKx+%i#sB(iLI2JMCHtZ{}=R_puE;)v# zaYl`GAgAl5jd3gWz z6nN3<(79VU7*SfuB-yWg{5{GlQ!v7uiqRv7BPA{vI?@dYWvn-)B6}|~H!Q`*>Qwx0 z)_9DW5RX8;9fJm^L9yyMs&kAe;l29O6?V2c>9p%|{3=O;>Om6Q_=rY)$GO(Y_C>_S z5>U_nah3|3%XZ`N-VOM_k2Yc6pB7-!uxJblqz6V`jDmy2IR%@k5X3M~X3rM+^C>&= ze4X;nbD`K6xAu+BKeZPQv6yZQC~(ti>9#c@edewB6D^PHH*Uf2URr^JC+ZPPH?6T9 zBXCtg7Ai?HX{AL<$u&Zw4~CaH0Et6Lys2n*DOv3~=!6HzjZx5EbeF|X7=gH`U_>#A zx|&9oNPh)98hzn(=NcHuyq#>1+3bNJx}R+soW~_(z=qunA3X@5aKpGZCPiKq`ir@b!NU z&#ib1+XJn{Fh$~us5b4p?cBEaCPoV6;rr+A$0w%ikTBnXYlD?o`raR~Nc#w~(*}1# zRnT_+S>Cyb$kj#!aDu4ep&ew$@5F*Cbl?C+i3t{A0h;zE^?;3tS&>hzr@7A@<@>Pg zi!ZTk@jBf6<;dDoZP$4#(ySBj^{R4#7BpXp!(dk z_|3Dq@JSef-@Gsdi41z_%4#mt1;Hldid+e0~W? zjtPc8m9DdwYUFP@h>Xv7qh`vlkx1n$g_~I=gIko0u#(Yo<{ zv>np+&b2@!KG$&*kvMV`X;!QlivOV6a(V=$(Hudq4l#Gl8?kv;F(OCkVPmF{;w(AR z<})&r$;>-Id&Qc|m#|A{8K|S7+qOlqq9u!*i#4nGe+ok4M;dyJ7OhuLYOr!ZoTc$JfFA#&e8J^_QL zj6v83n@|!N0!vU7f@l^ydCWOCjyo5%2?>+9>+4Bft`0!qce?_xWen9!op}X{oXa8K zxC>u@_%5PN_aQFW8|EIH^ceD-oky1REQH*i&WIH=0t|kznSC+$n&VjZ^w2+p4c1VfDSu-$skT1pr&_c9hKlW~1j*7xumC=1??c>?G`6?Uh@C250&MR`{DS(VrYpiqd-(Kd&2o_Gd+BEju=PMO>bz5M?d7u( zXZ43^)lRJCMEJow-{7uWr*H?sC=HjT@(k^5{YhBI&ZKt>D~gf3BVR^wNaf5D&~c&? zmc{N$Q+*}P^tGI9)vkr})TG( zJ5J=pG4Z|(?sVgnoFLYbz+0}KEmNGJZJ?X7k@p%zpfs^ka%(l}OY`vcdz%_d_tBPkcycj;M|`wg2n<$&Shb zpRbx0Z)ZtSOWzOz7S>7jTf#=+^rTV1$Ji2e*1i$ld{&VVSj(3P3(#@LE9)e1LvRxO zgUgU;`x2{HE{4Ym4P{w|`lwl$Hzo@H9vo-g)ZMD7pZv8&VHeNnlu|ErJ@LILEx)vU z?&-g-pr5m9OuP!ydu4pK7?s8#AR-Y{lLeT)ccsg|%u&g_Mb)S-$)~oR2fukTR|*c1 z&!)xa$-e_45Rx(iX+*|uNu{<&o*=KwT+#+hwG9m=4*I!`E-hL?*MMB_iP%vSk)Zw?2`L$tTPqx8 zos00r=Hbu}E3tOjGHegHAOD`7MuI*@oG9(M;ei{G{iio@jQMt!aVH$+MRyQE zI@fyg?~}r3r&myM5?nppvDK47*UJ7PtUt|7{7hEsdO2CM84l{^Qt?mLaMllk;=h>- zZc)}&EcpC8xFt@);H$60q8HwiQm5QF~g5zke(ch7-636Gzh!8kidpD z^Cbq&$y;f6pilF14SR~su#L`x+wpMg}}|=2{kd4HkARz^$sphRCEN4ftG=?a?Zn}gSeY#`x*5m z(xy}qLhU7Z^k_wJ(|f?JjP8}{I+Qm!U?wI9q#3BMV{k|{T_xi~=&~fkc3BQ`_U**` zpXTGv_iiCkW&pgEB6nQ_vNLm_4fKb%SX580img^_A+wMe=8p_U%+RSAKeZSKwy(wV z^;@xOR}SQfQ^;>;LtJ&U#I~r@{op}XV~tCZVzvvXU{P0*lS{?m zfqFDC5=XeTwZxSwsBnpVcUF=SH|jizZDarGG-qpkBS?dhk0jCtY~1}FzB{TWN0J|W z=G=nIhXs<%_w(VOgws9)B)x`JWck#LH_twMC&zsl` zIZCnSr5A80Y&@K^jOS5ta+KrHhDBJr@JqbBFAHfOe}?Mm)1VxiPS;k8A|od@#v^zL zZog|Ve4@C(M}>81);&LWd%kKRmk;wWg%6tq9m6;;Bdx-RkA4i>&#y$_PbVV0NBy6P zX30xr46`+Kmk!XG<*ZpTNz zzltDiDqqyt=sbgW!espF_s!V3bq8K}{BA}Ge#X=-VFcxOuRMym%r&2h{wBtac;`1t zTI)vMa|7Obc{{4}s*!bL8sd3>`CFFY(3UJ5l;417BI#Q`H5-Z(&sv<8LKJ21z|0$d zgHg9Vh3R9{Flk5>46d+GBZ87A!QDR!Pg|eI|2^^t0;{jVjrUxO)EYd zNu8Xd+qFoz5H%X&3;2@CxklP-hD_T|EKOPAW&XD)KS$ zLI%Ek>3T{C*o&Cj1Ni%Ei!kez>!BuQ&5iD$V;dJ>k2Mt&8R#%`C@nM!!D_|P$iAlQ zsRi}|-H^c21rNUriTXbvzq%Uh4^|*K-3#)HEVBJ);ltx{+&dx)p$zw{Ej)nDpFWE} zI&Z>1ZXAQ5W*>wNpMgQn2XQz%mpS{$R!@$b=Hh+Wl2e3*MJoJuTntRjIavDXr}*^a zZ=t;DF$5c^I93%g?-`YsyzlV9=SEyLOO1OYL%Y071+gyTrJ<7MLCcW0e<+g2&&3^; z6(~G@6x+Ug1dFrkkZ%dZjZeIf`J)KBXS7sXX)HdDh>0Z1rN;-2RUHM*E#2eRS<4Y^WzmYy;_Vlnh&w(}I<|^%HDa@*4hIT8)M& z>F|mVM>z4IKc<|k>;luKBX;$Nh-lb|)qBd2Fx-a`?RBse?!iBgG-K+G!5Enm#EotZ zw!ZsIyx24i?u-h2^Xfs!T=5Y$lrxaRCm2`G83r$UCbHN52YdDv;J~EcBAuyPJWhpi zx^AzTfdi%0wOHde1CKxW0Fp>qo{PK(Z~IiSl0CZk$X2Y&tcRRQX4M9! z<`^~^qe;BBb;CB4RMeuH_<)1z15o7a}& z`)wXjtck#rGsAjtF%6<8Uk)YBpxfX71AhMKJPeBTMgl=?2fx^i^jm&U9;Z>565iSL zE2?G`+u*A(*EbqhCJn{VV2^g@YcZe=wBk*I-ZzrKJrl~=89QtJq86vXBa~-h$@0zE zx#oKuJbauxP&Gb$`R~|2WHe&JLNGo(0-;mx$Ip(xgwIzbZI5H#b<+`QHo>RGe;}I1eqf~H6oaWZGmoEYExZy!xa$-e zU3Y~8hHix*PC!k2NUD}pb&_|ayECNk&s_pCG>}!8d8{aRKlXu6o6B>*z(uXWM)&u2 z?58F7@%Im-qPz;LR%WBoZ7*g|y9N_zy`6RgQ|3^4_{T>t;5WA(L1L^L;lWK`nTp*Z{;G*6WFGj3}+CLrlKXMy( z(~ZC2;alLmc`gc9FGFpU4AXx1DsD~>V)g+!YD($yI=%`AoU>5J#L_ZGgt|wJ#gl)h zReRC9_#;=~kZK($A|LCV!wQL(!?=6AG_5vPW)nefmfe?;{ zBE;VLwkyi5jRvZF5pez@R?OgO=F0~`A$HC~5r_))#e|}ARMa$cUeLFYaJH+Yt6|9X_*v>ic!!1} zg^Iw*Iz&{N)`X~$bMe5>u!JIkNN!LWT!T#aRb``{~!}yd+0_eZkYooX(*0=|1E~!_bjes z&eQ}FV>+3Wt}Jgg4mTvgTNO^r4tM%*b6W80eD_)*v!$V!HaZ#U zaV;4=evDMRJcoJ)?>jRr#NSBA5?aPyWsl$OXH+T?iW$G$rwexzLTWZxJa?CWid3nJQ=yPfyx4VLj36nhn zqA+@f8hJJkT5`G=l>(2U(sGCA%`_g9xtpwp-(Uq|X%hE0k(NOa&9Nh^Jj0m3Z9IH} z3sAq&3ccQmNQMp@yn--uY8Z^dY~JqLJ^3h8GPQ|!I4+;d=s8Bfxd{T3PDPl54gLw3 zGLz<3gEx;klSDa*(XHS`oS9-bA&vyWO69^!fPvbKx*`CYkwwC=a;7JA;ahXAR}er` z9X!k-NSk^SQkq5XLQ)d=F^d72szsoLe_Sd7um;>%TZ^3~+##D~@bpz6B|QzZW{^OT zpY>c|Oabw@?3UZmKybB&ld8ACZS*qg_FV7g)cJfWD$Y}*CP3>Gh=M97*}V;DibzHP z-6;vPr!%i30o;se(l9hUX7u&A6R`*;NvoVnms0DEq0{Fen=qx4>ITX}2VZi?B_s_; zBw+=C%)M9r8v=+WblGHA_)_&y$fTw+Qo;M*+#A( z@WGJFZbm@88=7?fjDq8L3Lk{0j>A|6nMLy0aPs3BG#%3jwYB5i-ubi$Q;8i%H=THL zTql1_k@3dQ(UnMla_h9)Hu>6$R%0{s*4_K26^q}z5y^P(q2Z==M6Cutd5An?p%j z|CYKt+#Y`yKK%LyMhcOKqnSGho1Gn%E-XPMpyC9m;ch^P)81HzMn)8sSJrc4WLt@S z636)v-}IwA5w2@HTv^lwK8m;9ZLu>A25*+HGlzv*Ym0E`<6AKEy~()s)=BvN10xC8 z?Y3I!hjW&I1N+{)4XO6 z48$3B;6l65x6`S9R}QWw3z@*niAzzyM(zj|sTNG!fawMMJ7-{#4y2KQ{~AJjJ&AE@ z;ZWn;Y;S5gkNLr@#I%TW^-OMUFdCqzm8Fph!!1?@rnGrcI$hgHqFy)7RV_InJN?+h zKV6ZI0#8O&=Ttf>E;~*O-DyMc;ju{kpqYa&p1vFbboq-dxSjK-rw6G?m?}yrG@_1X zOC<>ycc7TowcMHpR8@MAJ8A-ggM4X8>C_k=FXmc>h|=Za*xhs@@_q{Fjh%AoD&>kG z5^c0thzVoFrJEiqOBSQZHe>XxC-MB6?HHdNjwElP*frzW58q%K%%hM}N zYVU>U(;C;Qt!MbNYuTMT!G$?x->)n!MicMB!L_KFiibCYmGr!Kmomups}rWVQ3&NodTpLmF;AMBYwa>)LVZD*QyOTE_c7MP^|&HUvC~pN;h9 z8YS}85iHLr#bYa8!hbclP*EC;SFVi}C%AA_A}?eOgA+v25GN;;HX^Kuvuj`g0G}(@ z2AzR&mDz}?W1dsG^TgI!OR`}R@$DwYuIudn_0Q?%f?l_e){jo-)RE)EM$lyd-A2CD zf{kjr{QQb>t#KEQ6k8EZP2P_AD52FIBe;7-+_pFaif3nL;T`JPu@&z%gD z=CWpio;m9R;)+^hgqL>!3__6*a{ynbt`^I0=b1x*`vR#j5Rq-oCr8O{`IOZEIJb;L+(xkuztQXHXL4g@;gA z77K2I7>U=DGo@pCF9CrdYeWtiddr<7Atwex;DFBB=X-yli+Bd@XUtip6)!>px-8r^ zC^$)b_%elvHzSca0>rDMm4T5;p1v-5bXi9qeJRGenv0#U*60eJ5Y~M`DRRm{!q0>~ z=m?$Y2oMl1Am$P?2XgFFxgtPUY-C(a-mMdW#@+0i^DgAA39?)Yx}$}ii@5;l9$ZC` zGA)CVqf@A45I5_Z^w@6RT>Cl7LFM4+l4r5hK8zH3gaO z*@^(si>a);=}cf^RfHcHOk#qUqipADlLR2r8x`?EYLzm$GYDp~#J?q_XK76yBOZoIkRi9W00JFB*4(#M_;xBCy;{uZ!px zyt9^dq22EtK5~tNEf##-g+)sdcw%ly z_$T3SoeGsSedl$HV^??nbINtP@Ok_5JSa}5w?(DZ!(La7V@nR9=2vOdVEG{J4390Q zS&r<`I)O$d=+3BPh^pB2U39HUv{?)U8F?p2ZdYCgM|L(!h$i(FYke>Jy6D(_()`oK z-u*YONw&MGq5IP=)-S>WX9|vi-2NZ(?a-}Dqe0}^=eywk4Znk=}(chVgpvWa(T zTs-Zp{_=&GCK<)Fp%z}zYK)Ha?{?AXFD*Xb?GR*{y%^%>`|>}sKDLl&zp zh;#c@N9AH{uSQ;tgE&YNk_U%!qe!K$E7u9B39Qve@Xr@481YAcghkS=xc@LhuDq7+ zS^e3Qg7;cpolYRvS+lhqKYY6gE52ib_U|_HfMjgR$Yub641>c6*k_L_J-8S}azE4$ zzX#V`b{TwpJ!llTNLv!lLlj@{MSW#hT*0z!0s{>0?oMzC?(XjH65QS0-66OHhv4o` zaCZg`?ki(u>70gTU5vDmlEDvN+b40X>Z@=!#)iHx@pP%zi zxEzW$J*;E>HKXTqN;-=pQXqKSLClG6|MSNTrig=*mv{mk3Rd}6$Q?HVaj!QN7 z!0h_EYv4VNG1Jrm+VaKw^vXa5!$`fyOub)>LF1KyIXUL2t-%S=&M`cCIwREs4+-}-U9_=hES zf5=H>l!ZG96dJeblJEh^9r{jxLE+j$sG9CEiLPcF961pfVltp|*n(Ooa&87Cv^ChZ z#OX*_5!#8Z)k*4x*}<8=P?66All96ekLRA3IufStn|cVh9+qex)lr{#?VV;rta+WFX!4NT?-e;4%2R@Yfi<9pYE(*fTO&;lr9lI9-W$RI;Dy72ctIHpQ z23J8gzGr$=c0I9E9y&fDo4*J1H*=O>|0qNR-zXy`@_emt>BqpJsOtTRCt>?Kfx%d7 z@Imhf(7}lPX58=2fY~5=c-ZBs6UE4Efy}+*3MgG5u4@59Z*(;yAS#CH6r+HoO<#{_ zCS@xRimDyH)AxkZLmHGUv8QCxLNVKT0nXCFl@&|N__Lw|v^=p)u>96wv201bs)ph+ znz2sd+V9Or41gr0xbGX?MlB_s~3`G%9{??&8}4}=rJ!ldJE%u1wvUiO65KAJRwVJs|V zkJhC_K``POLohO*Hj#mo70a~y$c6G`VCd6=i*A~GL0ZH0MzNyQsgQz1bS6*T)Zd-u z+zq6X>#HpzqMkUCrUt9)FSaD(DYHq{KRXr6?=LR0GS#GS$Q4bc115t4O%I za!uakTuvctm8VOn&T3+66#d%O@d0h^02k_DL4Drh4Q7-M@p`#P;pv(Yq3sKyB!mSJ zq}BhRCs`0$cOh+#qN8%2`G%b5(!!UU3BkA`%%^fICq{ zhb_q9K$lpw3Pfp8wnFch&8bs<6cy|x1d8WGhcKWnv^`)-_l(~EtU*lvdL>7qbq5-G z^=^E5U2^KZ(7%juUfY`dc#~k&`;DSNY%(GNuwDTdzW2ndYQsO5A)ZG6dNkM}Dy~dd z?$~6E?1U?}?n8qz93%Xlv>xpma_{_`fNc}Rb#LLe{Jnd^Y>7T*7{uZ;%&C?a+*P45 z^gY?mhQJ#2{RtEqYqd0V_%9)4MhaP`W(A3GzLRjWVt{hUG-&2fSL3qdmk-nT5Qj|b zsgKId`Tc(Ebp88>viCkdbTCtS3S1K-N%g>9KEe>p`_vbwvy#hRAR9ZWKph144V}er z*dEO-3~gQXF=lpSpF*%7qlW3JC?J^r#s%};Z8i!gzD3|e#MNb9>vQ0R(4-=ooEJQ5 za!yZ^4NkOVtcVT}bs)$1=j`7^0DT7_xHyRTj?7affm@C^oC|_Jk{%BEa)BW-ym}vR zI$^Uwzd^=w03yDpM>Si-85z1m>S^+nZz5PP#?ex4!k9LNFYz-;FH&f+r}5&EB~N3d z3IO;_JBx0c!80*>8}+K-NZjP{Y@Z+^J!9&KGYB9nJC`*FKLej^53XE}axj1<{(a^Q z-P6xZF|HSW6kVgc zj^U;8_XcT)g0-dIb#+WCejA z*3{Mu9^0CosLozcI@&C|42Zgruy6R!uwPfU*l#thAL*E5zv_*8Va1WSPQ=Xc;{wFB zyB+2Wn<{}`zRR&v#vEvalzC2W;zxUBKyuQzIH_{)>Z!C*8$;eex12{{qeH#@;O-J> zq~p3DD}@0TBb@Pk`aN%=-6l>y4W6Y(N`C zSBLles%S-@84yBMt4Z z=7*oMwM}GDtuL;|fBNVcJ)RhsjF_Yxoig^)T2F(QkIE}5eiJ!0bBpQvL5Ru9h&y_V zNKf~Qo@>aJ1W<7{p?a~?54ZJYw3zBJ4-GvYxMOX7`9j+#DI%!iU)EVf@@Xsoe=&DR z6c7OGg4Bf?g7NPCV34^3yQ1>?2!F9j_YY5=evK}&SYg1V`I zu$Fr*@($hj@<6?rh<8>REI9Xro_c}m6G+dOCi9{mul!TK)<9q0gUjua#sTLUr%iNNr8cDJAewUx5uf8c9^wc8FiF$ zo^_$plH6xmXai=fR2*L7c{QpzputO{4>o4E*$DdRd^^`!2USD6Q z)p)~jpmX1pq?9VPoR5};EP5#80bWYve@8$v=xlLlIGw==Db#siEWZt&M>I}F@lAYu z%nY@faSyaQl?8zWf1N6~R^OLU2g^JO%{KXeqZb+UZPn-a1tN3L&XlV2Ix{ob`(|)e zZ^&mzgYZ@Nb1!eMSzfZO?SGU=d(z zTqX0s|H}PORYG#cT4W@E|50XEz9mIhndSo6fej|@0wH1gJjMUj`*iaQGR9hT%ICe{ zFF;BE56BrfvY>9h*6luVzwSz zSG69WI?qYwwD~TH7eh+^|Ihu&0(?mW0xCG5;UkEhNz{MlQKPjU1C;doLLaiazOjn@ z*RB6!5bl45EK{!LYE7=F-g1#E6Z}6QdEJu#!Vx4X(R%!>?U%et`acno2zYJ;K-PlD zyj@&XP!~)bOe-pc!9B7cKl~XGP_$O6TuX8jko3X3SR}yy+oVrSpR?vNAU!xFP1&Jb zob;ng5Wle`pqv^=KKjE>NVpLH-fS#?1sai|F!<@1QKyLizxJ^ICe;J2EsSr?MpKS! zt#BM|zw{#?Wpsqxz^;by=!;r56-_>I14i#Y*@PWc_Vh_ELT zb%87d@?9luJzuWg_NSAF6{=Y# z{?~atslJM{5Pu6(E1Ymb>KLK~G4#tB?C-)VvN55DysKn8^Hxf5ofiEwp$PU!^7OSV zgr$retBQ~`(wGNB14LNkR~HwTUlq+gpTz3hf5AJ&AYz_Dy~B8FZOhcsiZ!hL$~D26 zY6bVA8cEr*cT}|1{<0;Zv$EiJ`gRr`Ys@4amQjv%Z}m0thprIWQez?&foi4L@lqyU zt&+J6y3pSj)bgs^PzLXq-80{Is?~*S2$ttIieJ7@RqdPSd`v1e_rtVr#I`}wAQs)} znu)V~(9<;$k#PZSPnF*`3`ln&Kba1QiI~v@Z7l)guyspL_;A+kCA&%v7={x3&5{QG zQ)CF3SnJ>3Q#d7pMrW0aBPMncvLMKxo~UXng-l)OaL%NTym7ZL4&nI;5#{Df5x<#R zQ5aHk-(aS%HR5dsnU}y77)Z<*y zgrLTMp)7E98^NyvW~Nu{7j#?=)x_XKuC>tiMYV{jB0?;yTH)exz#fp-gnqxgitVp% zqQFO*f4^3o(*57{!Z3%T0_ZMeQe;$HF_ZXV%^{tS?&g~nAtp@Dj2h($dfh2TkmUeh zTWzk~h{tKM+9cP<%;5A}=UlI<7Z~fp0*B6YkG8r%K2oF#DuOAez2+~%WS>e7&P9L@&sG=f*QY0VbHUw*)3MPc+P$%rPO2JEwCL$TT&&L(ij-AIn5s$&-M8k zdkxuoH!#CCcQ?ZA_N6R>=r!_)#ABchW4(%rhdfMy>D@4l_DgEzO{p%$I}RxS5MoysVZ*y z^8wy*`|8tjb^fE}qt_Yh*=>$N>m+z~&!RF&)!07~CZT+dhTFjAcfXlS-}cN~^upO+ zpV$7CgKmx_+y?V$sJO~U@P90lr5FyK_GKD!R53Z1-B%D3&cM~ZF1l0@Uh=+~QU46& zwC1#+$M3bq%S$HXVf?__d9GQS8|l!`xeH8 zHV0;(&$_S9`TO2iT85~huV-i-SM^M#Z}jwA8Yywc+I;2V;(e^RVmv4^WFKf-c^ARYQA|MXt){tR@c~&S%%Z zIQ0<{Sn@qx$=vAt)cqGoI3f91{-j)GmCT@uW-!*xZgAY?!RYx>Wu1|4mKC${ZSy|o zqo4cHQWW2p!@3Waa3YN14@)FVhQ+Gf>&!*;Ggm?!{&<(5`t5K?#QLeU)g^WKw7$iC`*SB`H+q6S8S$w)(-KlsVl`?hM=Q! zP&cnc{?^n>8GNCU!+RUxXsti7+7^=n<8?mO<;_IRmaS!1C3fQJE%DMC$1<+E+i`T$$W@N4F65lBUB*-o^a^wrB zWAG|DZ_PEgR2R>cwg)rOVvm=#WuwSS`&z(q_jb2_=i=Rz|}DGBx_1x8O3 z*@&j8U9X6X1yv)$@F+@Y1XEQ)aNd>_Wo#@AU&-c}!aAOBDA5#pj^R=I3km9T+trL- zY#>+zd&uTchqy3B!)w*xRGs9=!Pvxk2kTYHaP2o>4ULtE@v|=@I7Q$*!m5x{hMPe* z49!Fp)W9}>s4X2 zb8pPlRt&+H#{7LJb#~(C{E9f_wtS-x#hV4qvLAjq9Gi<4AxecMMnivizJcRp;!U?U zYk-?}V0tNocasvR&kygeV%Qch0y~vr?3IV%J+JdTgN{UpG2q=pvq%$C*`3>k9B* zv$g<9Z>wjo3w&F!tc_Qklq%n#w1Pud zJHM3ws|XN-vB~|E*lx*gQ`kt3(J^u^Qvhax~26G=@vPxi#4er6D4N7FO!o=~oqOBsz zTuGoJ9UEX1xZ5)QEJ5t@Q*<$@`*XS=8|b$He_sQOLo4(3(lCK+!3JjnJp;X;?&>)l zydj&+Cwpqd*tQ=&7D-%%NPOMKCCZIUajn;*6C|>{paM~pXI_t{u5Q#*T7E1_tg{jW zOiwm@^!3IB8vCNd^xsfRW;(a!LdxgN!c%@%Nx{od#ENBMaWLDn%+@J5{7%Izh&|Y+ z*i2uP6$uWXArI0r7ZCVNgtd5KkN`nKKMRid8rgLrdcvgP7L1yMQb_PK=nEYwJoh5? z8@XhjpHz=x*wC>Kt;d5fZ8;got2@T+3C3D(;C0-ujj zE48lFCwxAsJP2~&g#W6UeAI%uy*u#xzQ<8ASxS6I3F4K@4O`vFs?QLlB7eC&C-e>4 zWo9W~@6Vso3ng^)Umj&QdPQ&E>2e4-n>;!vrQ`BM6@rWzG(|2;XWW6I#*BV#WDGAZ zk5v0*jb>&&d>w~iu=c(ij?aXP%p{r4Vf($LC@jfMZl+-R*7@By6d-M02wPY4N4EIU zP?mU1x;|e0ld^|U7Y@HF=?6=7f3OETs7rFDbjv@8==u(}&Sl^2v78HehZ2LNbOQD% zhB(;qi(%Ra-Y#T_p-6J+$@(>~^yS9!MXmD&#py&rdBzae$_1VWIelbr`iXC>iZOZM zF#@QOfmvs3w4jv4;&K1+AmT6G+jKD%^Yqbox^tBqJU~6Bqm9QN9V8PcT+90+*}VFo zF=$T$0P&p7rSLp&41H_caM!Z>aR=T??{(hOwgG!}_b$uv`h!J=g` z$KQ0$k(XQi2x(dv3t3{ImzQ#P}0dH zRO?!Ep$p@?*_(Iz9!5#|NuwOWLXZ4)WPvm|l|L{z;@0045g_9Ul^;Z}Ck_8PQ{a7a zxZHK#?LNwd8MncM3;m8$a#tNXqZUoc_rh&CUL){hPM(pU4`2B(e#`6%vT`dW3h6AU z#m5&fbAu%BvM40&!SyPI0^|#GZ?qQ3zcUy@obIp&7c4f{mROGy_kNq(@={mI^xcIK zg~xM^nVd&hiRqb|RS1-{{dkH03QA=+D9c9|KM(WDDHP&lg6R6520TtYk1V9e3>kLa zJ=aIM;XJ^B!%y}P7QmNEvl|Xv$U+iW`qf_JB4%La5kcM*Kfvd{EJ3-Fbkvx9hzR3|aQfrvDlSy%9FU_z*dP2(Bv%x^S#ePd)xO^suaKxP! zHGH9kCb#$`br`4Ml*qZb2v5>?8phOWTsn#>?eM8I8-X%QDlnALoeb$}zXW0ddK_XjTud;L`NyRCv36e&;W_J^8fND}Lv{d;}8P?>zr zAY#K&#Vrt*8IRbRpN(~~fQ%k4G|;GWqYbnD!OUQzmpK}K#zi5!-07Z(p&6}Jl|TXy zEeufnwGsQ(c228O^_gU37>N2buo{_V4g>=aL_#GisOe|4Jfe!0h89n5BM301xjZ=D zuy?u-{8!- zvVfmHW}uWn%O-TuK5KB5YDcn4LH3>K2u)?*xiwVi zaOiB6DCT!egapnW7Ei39r_s8~CKRvxp8})-O%w+f^Ru8l@=ymMEi$2KBXjvz}8v^u1orXuUJo&qemKK7oWHlRYgjEoApMIl%MGj|5`lzZVxI-VjeU1wb zBL)jNH=plX-Dt9xTs5q!5RlX(zOsZ;jCVuQ{v^&#@!G3}DC*?NH1`pSh42Z08YX5S5)Wo91it-n%TQ}G z%;lX?I^3xI5e%F(r5C%F!>napB(m#YbH7c|31+r_E@tFLRg^Zj?XUV$d zg#6vGE)`E)(3BiO+Z2n!b=9UF<=(AzbwIZpuT6-WD26Q-CHBkCA_lUd^F$++CSHGa zjF_|!=F8S^Qf>w3M~>slIVR6vz^NsHKfmfB#a_-1-ozpnTHYep$05}Ytp|5(Dz4_b zRkwR7-$M^N{!sDV;`m+%vh%$@i3GccUuINGYYr(@{+Z}$j*)eLP5lPEn`ODKMP6`; zKJvL>%%s>vBz53@=UvD$5cRl6sPw*Sc4sApC@dW&CF6lawe^KeJ9#^bCC|&yAZ20C zqCgCs+`!Tl->;UA4Bnjd)7>OViB?<6hl)@MlU*GYX%)XLSDh?t+_nAzBS!*P=pO*p zAaO=3s>8(z7G+H}s$@7H^zCw+qH#BHt)QpjR@}^T`#_cAnQS8ll90d4X%S;1VJoU& z@i^ZAzrf9{D$zVBm#xS?9$EZ~#qx4Z&!27#9WL7JQi zxmCkSBw!qJrU3^VFo}7I$BxQ=Fd=m3CtY{jqo{)FKG2gm*N}@ttvmc+)0>;S79r^5 z8(3Gk%g8f`$!Zn~;a3OKYUK(dzQ6ovx5escnd7+0rt_t=EmyuV?ci@LC48N?#Ps<2 z^C>cTT<-hO;{CxUrE+WNeQ^+2?-Y9yw84^D@)?WgE10fyv*?;ZZw=Stthw-0S-@0fKKbXiVzF^UAV=A_!KZ zta6Mh-H8~K@D9{Ngb}LWDEMx&$hqqrZ=hwmKjbEUvI36F6_W9QVk=NnyB~bcM)yZ( z6Zklet9Ycr3P1gTjw%H27#X;HJ(wQwSRWM@MItjsv&Ioj`$^_V zppvb?wK*Z=BrK6hVsM!~2S;;-sB9$gy2oY{mF-=Mdr1>Ri;@BwS}q$+jLDDJ;fmS2 z5+}Ew@zO~7eP{Fm76%fgR|JwyUm8B&4~Y3H`#!OCs*=qp{iz6Env10L9NmqW2U3!K z5jNPX7^_u`T%EV4+mm~ZhS`8a+5hY~;O8FvASA>VPFT@hk!)9TY)foN+G!$jFbWBR z+kTZlg&C+88QQP{1T1cD@1&&L2DX1>Pw2>)D9=O0r%| z1&Om3mQ`a=-kbLSVTj!pV3+VzR+ra&KA%nU*Ki%^n`K5>Z32fW#D3ot6Tzw+8DH;L zxS&ca$XAU29YnPIiqp24QA*VlSM9R20-9_kO4^8VmiNBs2U!a^$RS6{tAKS;INk%@ ziqIQbQ#exV2>-MRxZ^lq@}PRQM;*YrrKd+Rv)T6M^utr7gn-P| zqc1RbQa;)JD^!&X=ZrOi)2s+AyPcz)5_ z=;iFh7ajaD2qn|@j;J#>Bb5k^(TSC1RG^^vRw5`m+#c6Y)(RRnU9B=Ez5(M#O;u06 zk1}l0B@NvG;i5WV#C_>W-1cn=*JQ>WqvuP@F9hd?_hsA)1trC}-D0_5(IYu0<8nAX zM&^mFenSyMAL8q{@ooIf$oPQ-EL6$!qUw?Cfz=smg}O91pOTWj2DWQoQ9CsKrcD}j zKf(HKYMZUbcd|}h9cZ}ErDf`FGsfgVrHPtFvF5A z5vabuW4Wve1J~Qp;r;vw;<}DLPdw(tIA2#Fnaz~h6D36rsp$s(&SXB_Gsv1Z30fGd zHR!`n4x9_ln}F_@oOdmP(f7#>fD(HaDk-B7^+Ra#O^67$@|Ei58s&zvXE-8L`8y@8 z24-X~=Z(sa+$TIY5F_iOOiEf;Ip7K)rryNd4b{H74Wz7fI9FIk?L*q{RUz>p^WgdA ze{l)a;bup-g-iWq1@fNu4s_}@L{m?il9a9{tG4(#d>w*`uKJnxI{_S{%YsR+k?{>$ z*ZGeq)x>Jte(rgo=ki+-DztdC`UPa&PyfU0JGg|8jW$*DGj zz=4p*zNvclWty>WGE{9$p1?G` zr7?M$#>$lr1!@U-jAvrXjW^3uVkizub7H2TiK@*unO$j$qJ5g1meDG^Q)X>g_NyQ;xW0r_&nJ_1r(mk4Ckk=e^K6ftG zzYLX5Y_jqhEcj6v1K}Hz8RA-g6J%)kZ^6D6MbwGjBt$Bp_x@!X~9_0+Syz&*2hD{Wfg3yFZl^+h$+-}(#7SL^HP%9jf5aX z)di_Cv~T6bMRFTdEz+R2fvOYW(qJs?R~beuMyz@S@czXQA1o{X00VA2n0^oBuTvB4 z7n@sN4->72Iij&hsNs1OAAXG@VeTC?^z8QU0KMmhZym2M6;vGFV3dAJQQ0Qr<&*JI z@V|zd+?Q>Mk(4Yc4K>0J$CU&x<`JiQ!!P$HGJrv zPmB7|6vt+FQ5q5^s=2-rxvF+El3_p`J&|~diNbHyNm;-!fP(NTfD2_W$9?sCi!e=X!_1rY6_nwu(K<@ zq3^cV#+AtH7#S;?sK4G_JaB8U#Kb;KWPP88=V>baq9&F?mtxmIQ2r(L<;kodN5YrM_iKMO+!~q!djMj=dx(X)IMV!kuByXhfl1jTuEbxt819FwCAbWo;H`0BzcDV z*!|*C+_tP1!_{)V4X4||AVNnFGPRd0aQ;<#~Z_1&H$ zj0uS!KTiOiwS$(wxiOiDnJcQJ4!*_vl1Ib6TJKO86ED%07~@0&oOV;mUg3cOSIH0g zp9dnP7Gg}&L<5XfT`+D46yX#1^AM$~rcwxtwVpAtv5*HvlG5gAAzD?Hk9Z+~6bANs zzfzOKne}l%y41+@)R=%_*|pQJGv_lN-$|n>p;0}k^<7_)KWW!2+16@{9EpH5nvpTs ztduXLsnHQ5UJZ~rKi9Wra(r#0exYE(JuNn^Xk?PQ9TJ45I=#sL!KTNCYd^A<<>#kE zhdPw8cBH4anr);*v5_2YwE(?5kX#9ci+^7FZ1@iU@&nz~WILktSfRJTvVQ$skuQaU zrNX*A1d+0BjQX6gJ4Tw&H9wc!R4jC8W{WfU*k)oBt(%!bPSif5btKZ1TdJ=znF$s= zChs-86oi^qi_#PD7`CFf1Vw8 zj&^nv^LV!h*Br1=-)cWVG55qvjIKG@0ol!0@aSD`#c~CqbI!w;>mBLgr=p_!opm>u zq1a-q=wKhMIA<+H%RlOD^kN!$`8qOb=8X!$+whBPKUL1hie!h{hsUFp>vojsUoF}E z&%DQ%L-vk}Un3d^dIvlT&w8D>AhhpjIjshZV7=M5?Womch<^|Dj!s0B_%8BcJY%Dd zH-Ix)j$Lhy=?lM5XuimJr~|DDz>ZthuuK0^by${W=*P^s%vAodP(x^W&5rDX$=c|g`&r?XCg5A zUGL=wczGPYwrRC8ByA{4HRp2sZzJ^j1`6;$D)h!>;j=Z?zw05ELOmT~?Yotet5XCr zNUa*vqfBrDCfVgcyv7usQkIuzl+@ot?lu`0PltoLB$X`lTT)*OD;F^O7X7X4Y39Z( zWX3lRMMR$~>6yzw6V8S2XD5uRX9M@0&Q#_A16urrl)+K+bWy~QNvE}K14GcD@cv|! z8h;c6;1z*lsqmNmSRE6v@{?_isqL2?1Bu1TD6OdvMaligRg7BpgjoN!iK8~+GLLg8s|d5OWC`-&HfU(uhG1HkBpzm=Z7@#XP<)qZg5~6;M$CDk;w_|v|M9W|wDuU3++j&S zlQ3Gg*q9+Snsk66Y(Oa7VZSK2zXEe_!2@E5KHD$vTN4ujf_t<8kD~HhqqF_|eXt4S zjO1+wYOoCkrH@dI6P{KdEee68-QoQy`Z;2Acf@3>KC)}a(4KO&t^^=fQ(h)YbHgR4 z;RJ4`2nVgcji*-o!C?!-$1zIhhC7naQ_QF-s;tZU$&gSi;C8PNhn{)Uc;e!>KH~Z! zTEj%to~1{qW@46dfvb_*58~e=Y05P%GTTuF>yv8^ajr9BL&5<5Az z?;NK(5!JJ>7bkwwwV{p>1A_gLfJ|St(y&%iRW-v@Ry$es(-u5?lE2I;vtYHLLVa8k zt!D9wm~R1$q~LD%+i){V>hYA>9`paU9}R@k%c2FJp40J zqj_$Qw?oHer$hq>3Imh8xF~+xCkW2{BwxumXm*$s3QyHVf?C?O@Q??o9ds%mx%xtno5f9H_=2<3Uy~Z2Nn>sLMQAJn5v!- z`xyB$3WoL4&4SBP>_XB4Xr6Cr_5oBX$YI>Mhy zjw>L=EaYFEe=hU>PZZ8zG=E_JSKN;Hr-sY+Qf89>Q6MBh z30A=I7oe7j{vSdAs`kZwir;aQHx>CmopJyXhgs;#?=*n_;QD+KO!z6j?;>X`{C`S- zUw;BW??a(#{80N}s6hTt@gZBhDailVC@$pBD?pUBvz7k~70LHgJWRJ2H7UyfqHrd; Z2.0.CO;2}, Author = {Zhang, Guang J. and Wu, Xiaoqing}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBBLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvWmhhbmcvMjAwMy5wZGZPEQHEAAAAAAHEAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAAAqjuYIMjAwMy5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAFrUP9K0L8MAAAAAAAAAAAACAAUAAAkgAAAAAAAAAAAAAAAAAAAABVpoYW5nAAAQAAgAANHneLIAAAARAAgAANK0kjMAAAABABgAKo7mAChslgAobIsAKGd7ABteBwACmFwAAgBbTWFjaW50b3NoIEhEOlVzZXJzOgBncmFudGY6AENsb3VkU3RhdGlvbjoAZmlybF9saWJyYXJ5OgBmaXJsX2xpYnJhcnlfZmlsZXM6AFpoYW5nOgAyMDAzLnBkZgAADgASAAgAMgAwADAAMwAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASFVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9aaGFuZy8yMDAzLnBkZgATAAEvAAAVAAIADf//AAAACAANABoAJABoAAAAAAAAAgEAAAAAAAAABQAAAAAAAAAAAAAAAAAAAjA=}, Booktitle = {Journal of the Atmospheric Sciences}, Da = {2003/05/01}, Date-Added = {2016-06-14 23:39:50 +0000}, @@ -2142,13 +2161,13 @@ @article{zhang_and_wu_2003 Url = {http://dx.doi.org/10.1175/1520-0469(2003)060<1120:CMTAPP>2.0.CO;2}, Volume = {60}, Year = {2003}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBBLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvWmhhbmcvMjAwMy5wZGZPEQHEAAAAAAHEAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAAAqjuYIMjAwMy5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAFrUP9K0L8MAAAAAAAAAAAACAAUAAAkgAAAAAAAAAAAAAAAAAAAABVpoYW5nAAAQAAgAANHneLIAAAARAAgAANK0kjMAAAABABgAKo7mAChslgAobIsAKGd7ABteBwACmFwAAgBbTWFjaW50b3NoIEhEOlVzZXJzOgBncmFudGY6AENsb3VkU3RhdGlvbjoAZmlybF9saWJyYXJ5OgBmaXJsX2xpYnJhcnlfZmlsZXM6AFpoYW5nOgAyMDAzLnBkZgAADgASAAgAMgAwADAAMwAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASFVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9aaGFuZy8yMDAzLnBkZgATAAEvAAAVAAIADf//AAAACAANABoAJABoAAAAAAAAAgEAAAAAAAAABQAAAAAAAAAAAAAAAAAAAjA=}, Bdsk-Url-1 = {http://dx.doi.org/10.1175/1520-0469(2003)060%3C1120:CMTAPP%3E2.0.CO;2}} @article{fritsch_and_chappell_1980, Abstract = {Abstract A parameterization formulation for incorporating the effects of midlatitude deep convection into mesoscale-numerical models is presented. The formulation is based on the hypothesis that the buoyant energy available to a parcel, in combination with a prescribed period of time for the convection to remove that energy, can be used to regulate the amount of convection in a mesoscale numerical model grid element. Individual clouds are represented as entraining moist updraft and downdraft plumes. The fraction of updraft condensate evaporated in moist downdrafts is determined from an empirical relationship between the vertical shear of the horizontal wind and precipitation efficiency. Vertical transports of horizontal momentum and warming by compensating subsidence are included in the parameterization. Since updraft and downdraft areas are sometimes a substantial fraction of mesoscale model grid-element areas, grid-point temperatures (adjusted for convection) are an area-weighted mean of updraft, downdraft and environmental temperatures.}, Annote = {doi: 10.1175/1520-0469(1980)037<1722:NPOCDM>2.0.CO;2}, Author = {Fritsch, J. M. and Chappell, C. F.}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBDLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvRnJpdHNjaC8xOTgwLnBkZk8RAcoAAAAAAcoAAgAADE1hY2ludG9zaCBIRAAAAAAAAAAAAAAAAAAAANHnJFJIKwAAARCuMwgxOTgwLnBkZgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAABEKs103xvpgAAAAAAAAAAAAIABQAACSAAAAAAAAAAAAAAAAAAAAAHRnJpdHNjaAAAEAAIAADR53iyAAAAEQAIAADTfMQGAAAAAQAYARCuMwAobJYAKGyLAChnewAbXgcAAphcAAIAXU1hY2ludG9zaCBIRDpVc2VyczoAZ3JhbnRmOgBDbG91ZFN0YXRpb246AGZpcmxfbGlicmFyeToAZmlybF9saWJyYXJ5X2ZpbGVzOgBGcml0c2NoOgAxOTgwLnBkZgAADgASAAgAMQA5ADgAMAAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASlVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9Gcml0c2NoLzE5ODAucGRmABMAAS8AABUAAgAN//8AAAAIAA0AGgAkAGoAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACOA==}, Booktitle = {Journal of the Atmospheric Sciences}, Da = {1980/08/01}, Date = {1980/08/01}, @@ -2169,12 +2188,12 @@ @article{fritsch_and_chappell_1980 Volume = {37}, Year = {1980}, Year1 = {1980}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBDLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvRnJpdHNjaC8xOTgwLnBkZk8RAcoAAAAAAcoAAgAADE1hY2ludG9zaCBIRAAAAAAAAAAAAAAAAAAAANHnJFJIKwAAARCuMwgxOTgwLnBkZgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAABEKs103xvpgAAAAAAAAAAAAIABQAACSAAAAAAAAAAAAAAAAAAAAAHRnJpdHNjaAAAEAAIAADR53iyAAAAEQAIAADTfMQGAAAAAQAYARCuMwAobJYAKGyLAChnewAbXgcAAphcAAIAXU1hY2ludG9zaCBIRDpVc2VyczoAZ3JhbnRmOgBDbG91ZFN0YXRpb246AGZpcmxfbGlicmFyeToAZmlybF9saWJyYXJ5X2ZpbGVzOgBGcml0c2NoOgAxOTgwLnBkZgAADgASAAgAMQA5ADgAMAAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASlVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9Gcml0c2NoLzE5ODAucGRmABMAAS8AABUAAgAN//8AAAAIAA0AGgAkAGoAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACOA==}, Bdsk-Url-1 = {http://dx.doi.org/10.1175/1520-0469(1980)037%3C1722:NPOCDM%3E2.0.CO;2}} @article{bechtold_et_al_2008, Abstract = {Advances in simulating atmospheric variability with the ECMWF model are presented that stem from revisions of the convection and diffusion parametrizations. The revisions concern in particular the introduction of a variable convective adjustment time-scale, a convective entrainment rate proportional to the environmental relative humidity, as well as free tropospheric diffusion coefficients for heat and momentum based on Monin--Obukhov functional dependencies.The forecasting system is evaluated against analyses and observations using high-resolution medium-range deterministic and ensemble forecasts, monthly and seasonal integrations, and decadal integrations with coupled atmosphere-ocean models. The results show a significantly higher and more realistic level of model activity in terms of the amplitude of tropical and extratropical mesoscale, synoptic and planetary perturbations. Importantly, with the higher variability and reduced bias not only the probabilistic scores are improved, but also the midlatitude deterministic scores in the short and medium ranges. Furthermore, for the first time the model is able to represent a realistic spectrum of convectively coupled equatorial Kelvin and Rossby waves, and maintains a realistic amplitude of the Madden--Julian oscillation (MJO) during monthly forecasts. However, the propagation speed of the MJO is slower than observed. The higher tropical tropospheric wave activity also results in better stratospheric temperatures and winds through the deposition of momentum.The partitioning between convective and resolved precipitation is unaffected by the model changes with roughly 62% of the total global precipitation being of the convective type. Finally, the changes in convection and diffusion parametrizations resulted in a larger spread of the ensemble forecasts, which allowed the amplitude of the initial perturbations in the ensemble prediction system to decrease by 30%. Copyright {\copyright} 2008 Royal Meteorological Society}, Author = {Bechtold, Peter and K{\"o}hler, Martin and Jung, Thomas and Doblas-Reyes, Francisco and Leutbecher, Martin and Rodwell, Mark J. and Vitart, Frederic and Balsamo, Gianpaolo}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBELi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvQmVjaHRvbGQvMjAwOC5wZGZPEQHMAAAAAAHMAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAAAobfkIMjAwOC5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAARZce9OEjEwAAAAAAAAAAAACAAUAAAkgAAAAAAAAAAAAAAAAAAAACEJlY2h0b2xkABAACAAA0ed4sgAAABEACAAA04TgrAAAAAEAGAAobfkAKGyWAChsiwAoZ3sAG14HAAKYXAACAF5NYWNpbnRvc2ggSEQ6VXNlcnM6AGdyYW50ZjoAQ2xvdWRTdGF0aW9uOgBmaXJsX2xpYnJhcnk6AGZpcmxfbGlicmFyeV9maWxlczoAQmVjaHRvbGQ6ADIwMDgucGRmAA4AEgAIADIAMAAwADgALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAEtVc2Vycy9ncmFudGYvQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvQmVjaHRvbGQvMjAwOC5wZGYAABMAAS8AABUAAgAN//8AAAAIAA0AGgAkAGsAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACOw==}, Date-Added = {2016-06-14 23:11:58 +0000}, Date-Modified = {2016-06-14 23:11:58 +0000}, Doi = {10.1002/qj.289}, @@ -2188,12 +2207,12 @@ @article{bechtold_et_al_2008 Url = {http://dx.doi.org/10.1002/qj.289}, Volume = {134}, Year = {2008}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBELi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvQmVjaHRvbGQvMjAwOC5wZGZPEQHMAAAAAAHMAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAAAobfkIMjAwOC5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAARZce9OEjEwAAAAAAAAAAAACAAUAAAkgAAAAAAAAAAAAAAAAAAAACEJlY2h0b2xkABAACAAA0ed4sgAAABEACAAA04TgrAAAAAEAGAAobfkAKGyWAChsiwAoZ3sAG14HAAKYXAACAF5NYWNpbnRvc2ggSEQ6VXNlcnM6AGdyYW50ZjoAQ2xvdWRTdGF0aW9uOgBmaXJsX2xpYnJhcnk6AGZpcmxfbGlicmFyeV9maWxlczoAQmVjaHRvbGQ6ADIwMDgucGRmAA4AEgAIADIAMAAwADgALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAEtVc2Vycy9ncmFudGYvQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvQmVjaHRvbGQvMjAwOC5wZGYAABMAAS8AABUAAgAN//8AAAAIAA0AGgAkAGsAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACOw==}, Bdsk-Url-1 = {http://dx.doi.org/10.1002/qj.289}} @article{han_and_pan_2011, Annote = {doi: 10.1175/WAF-D-10-05038.1}, Author = {Han, Jongil and Pan, Hua-Lu}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxA/Li4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvSGFuLzIwMTEucGRmTxEBvgAAAAABvgACAAAMTWFjaW50b3NoIEhEAAAAAAAAAAAAAAAAAAAA0eckUkgrAAAAWsT5CDIwMTEucGRmAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAADC1cfTGvlvAAAAAAAAAAAAAgAFAAAJIAAAAAAAAAAAAAAAAAAAAANIYW4AABAACAAA0ed4sgAAABEACAAA0xtNzwAAAAEAGABaxPkAKGyWAChsiwAoZ3sAG14HAAKYXAACAFlNYWNpbnRvc2ggSEQ6VXNlcnM6AGdyYW50ZjoAQ2xvdWRTdGF0aW9uOgBmaXJsX2xpYnJhcnk6AGZpcmxfbGlicmFyeV9maWxlczoASGFuOgAyMDExLnBkZgAADgASAAgAMgAwADEAMQAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIARlVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9IYW4vMjAxMS5wZGYAEwABLwAAFQACAA3//wAAAAgADQAaACQAZgAAAAAAAAIBAAAAAAAAAAUAAAAAAAAAAAAAAAAAAAIo}, Booktitle = {Weather and Forecasting}, Da = {2011/08/01}, Date = {2011/08/01}, @@ -2214,22 +2233,22 @@ @article{han_and_pan_2011 Volume = {26}, Year = {2011}, Year1 = {2011}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxA/Li4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvSGFuLzIwMTEucGRmTxEBvgAAAAABvgACAAAMTWFjaW50b3NoIEhEAAAAAAAAAAAAAAAAAAAA0eckUkgrAAAAWsT5CDIwMTEucGRmAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAADC1cfTGvlvAAAAAAAAAAAAAgAFAAAJIAAAAAAAAAAAAAAAAAAAAANIYW4AABAACAAA0ed4sgAAABEACAAA0xtNzwAAAAEAGABaxPkAKGyWAChsiwAoZ3sAG14HAAKYXAACAFlNYWNpbnRvc2ggSEQ6VXNlcnM6AGdyYW50ZjoAQ2xvdWRTdGF0aW9uOgBmaXJsX2xpYnJhcnk6AGZpcmxfbGlicmFyeV9maWxlczoASGFuOgAyMDExLnBkZgAADgASAAgAMgAwADEAMQAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIARlVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9IYW4vMjAxMS5wZGYAEwABLwAAFQACAA3//wAAAAgADQAaACQAZgAAAAAAAAIBAAAAAAAAAAUAAAAAAAAAAAAAAAAAAAIo}, Bdsk-Url-1 = {http://dx.doi.org/10.1175/WAF-D-10-05038.1}} @article{pan_and_wu_1995, Author = {Pan, H. -L. and W.-S. Wu}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxA/Li4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvUGFuLzE5OTUucGRmTxEBvgAAAAABvgACAAAMTWFjaW50b3NoIEhEAAAAAAAAAAAAAAAAAAAA0eckUkgrAAAAwtTNCDE5OTUucGRmAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAADCtU/TGvMJAAAAAAAAAAAAAgAFAAAJIAAAAAAAAAAAAAAAAAAAAANQYW4AABAACAAA0ed4sgAAABEACAAA0xtHaQAAAAEAGADC1M0AKGyWAChsiwAoZ3sAG14HAAKYXAACAFlNYWNpbnRvc2ggSEQ6VXNlcnM6AGdyYW50ZjoAQ2xvdWRTdGF0aW9uOgBmaXJsX2xpYnJhcnk6AGZpcmxfbGlicmFyeV9maWxlczoAUGFuOgAxOTk1LnBkZgAADgASAAgAMQA5ADkANQAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIARlVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9QYW4vMTk5NS5wZGYAEwABLwAAFQACAA3//wAAAAgADQAaACQAZgAAAAAAAAIBAAAAAAAAAAUAAAAAAAAAAAAAAAAAAAIo}, Date-Added = {2016-06-14 23:06:41 +0000}, Date-Modified = {2016-06-14 23:06:41 +0000}, Journal = {NMC Office Note, No. 409}, Pages = {40pp}, Title = {Implementing a Mass Flux Convection Parameterization Package for the NMC Medium-Range Forecast Model}, - Year = {1995}} + Year = {1995}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxA/Li4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvUGFuLzE5OTUucGRmTxEBvgAAAAABvgACAAAMTWFjaW50b3NoIEhEAAAAAAAAAAAAAAAAAAAA0eckUkgrAAAAwtTNCDE5OTUucGRmAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAADCtU/TGvMJAAAAAAAAAAAAAgAFAAAJIAAAAAAAAAAAAAAAAAAAAANQYW4AABAACAAA0ed4sgAAABEACAAA0xtHaQAAAAEAGADC1M0AKGyWAChsiwAoZ3sAG14HAAKYXAACAFlNYWNpbnRvc2ggSEQ6VXNlcnM6AGdyYW50ZjoAQ2xvdWRTdGF0aW9uOgBmaXJsX2xpYnJhcnk6AGZpcmxfbGlicmFyeV9maWxlczoAUGFuOgAxOTk1LnBkZgAADgASAAgAMQA5ADkANQAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIARlVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9QYW4vMTk5NS5wZGYAEwABLwAAFQACAA3//wAAAAgADQAaACQAZgAAAAAAAAIBAAAAAAAAAAUAAAAAAAAAAAAAAAAAAAIo}} @article{grell_1993, Annote = {doi: 10.1175/1520-0493(1993)121<0764:PEOAUB>2.0.CO;2}, Author = {Grell, Georg A.}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBBLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvR3JlbGwvMTk5My5wZGZPEQHEAAAAAAHEAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAAAoie0IMTk5My5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAMK4dtMa9LMAAAAAAAAAAAACAAUAAAkgAAAAAAAAAAAAAAAAAAAABUdyZWxsAAAQAAgAANHneLIAAAARAAgAANMbSRMAAAABABgAKIntAChslgAobIsAKGd7ABteBwACmFwAAgBbTWFjaW50b3NoIEhEOlVzZXJzOgBncmFudGY6AENsb3VkU3RhdGlvbjoAZmlybF9saWJyYXJ5OgBmaXJsX2xpYnJhcnlfZmlsZXM6AEdyZWxsOgAxOTkzLnBkZgAADgASAAgAMQA5ADkAMwAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASFVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9HcmVsbC8xOTkzLnBkZgATAAEvAAAVAAIADf//AAAACAANABoAJABoAAAAAAAAAgEAAAAAAAAABQAAAAAAAAAAAAAAAAAAAjA=}, Booktitle = {Monthly Weather Review}, Da = {1993/03/01}, Date = {1993/03/01}, @@ -2250,11 +2269,11 @@ @article{grell_1993 Volume = {121}, Year = {1993}, Year1 = {1993}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBBLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvR3JlbGwvMTk5My5wZGZPEQHEAAAAAAHEAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAAAoie0IMTk5My5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAMK4dtMa9LMAAAAAAAAAAAACAAUAAAkgAAAAAAAAAAAAAAAAAAAABUdyZWxsAAAQAAgAANHneLIAAAARAAgAANMbSRMAAAABABgAKIntAChslgAobIsAKGd7ABteBwACmFwAAgBbTWFjaW50b3NoIEhEOlVzZXJzOgBncmFudGY6AENsb3VkU3RhdGlvbjoAZmlybF9saWJyYXJ5OgBmaXJsX2xpYnJhcnlfZmlsZXM6AEdyZWxsOgAxOTkzLnBkZgAADgASAAgAMQA5ADkAMwAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASFVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9HcmVsbC8xOTkzLnBkZgATAAEvAAAVAAIADf//AAAACAANABoAJABoAAAAAAAAAgEAAAAAAAAABQAAAAAAAAAAAAAAAAAAAjA=}, Bdsk-Url-1 = {http://dx.doi.org/10.1175/1520-0493(1993)121%3C0764:PEOAUB%3E2.0.CO;2}} @article{arakawa_and_schubert_1974, Author = {Arakawa, A and Schubert, WH}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBDLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvQXJha2F3YS8xOTc0LnBkZk8RAcoAAAAAAcoAAgAADE1hY2ludG9zaCBIRAAAAAAAAAAAAAAAAAAAANHnJFJIKwAAAChtVQgxOTc0LnBkZgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKG1ctM8h9AAAAAAAAAAAAAIABQAACSAAAAAAAAAAAAAAAAAAAAAHQXJha2F3YQAAEAAIAADR53iyAAAAEQAIAAC0z4RkAAAAAQAYAChtVQAobJYAKGyLAChnewAbXgcAAphcAAIAXU1hY2ludG9zaCBIRDpVc2VyczoAZ3JhbnRmOgBDbG91ZFN0YXRpb246AGZpcmxfbGlicmFyeToAZmlybF9saWJyYXJ5X2ZpbGVzOgBBcmFrYXdhOgAxOTc0LnBkZgAADgASAAgAMQA5ADcANAAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASlVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9BcmFrYXdhLzE5NzQucGRmABMAAS8AABUAAgAN//8AAAAIAA0AGgAkAGoAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACOA==}, Date-Added = {2016-06-14 23:04:30 +0000}, Date-Modified = {2018-07-18 19:00:17 +0000}, Isi = {A1974S778800004}, @@ -2267,6 +2286,7 @@ @article{arakawa_and_schubert_1974 Title = {Interaction of a cumulus cloud ensemble with the large-scale environment, Part I}, Volume = {31}, Year = {1974}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBDLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvQXJha2F3YS8xOTc0LnBkZk8RAcoAAAAAAcoAAgAADE1hY2ludG9zaCBIRAAAAAAAAAAAAAAAAAAAANHnJFJIKwAAAChtVQgxOTc0LnBkZgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKG1ctM8h9AAAAAAAAAAAAAIABQAACSAAAAAAAAAAAAAAAAAAAAAHQXJha2F3YQAAEAAIAADR53iyAAAAEQAIAAC0z4RkAAAAAQAYAChtVQAobJYAKGyLAChnewAbXgcAAphcAAIAXU1hY2ludG9zaCBIRDpVc2VyczoAZ3JhbnRmOgBDbG91ZFN0YXRpb246AGZpcmxfbGlicmFyeToAZmlybF9saWJyYXJ5X2ZpbGVzOgBBcmFrYXdhOgAxOTc0LnBkZgAADgASAAgAMQA5ADcANAAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASlVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9BcmFrYXdhLzE5NzQucGRmABMAAS8AABUAAgAN//8AAAAIAA0AGgAkAGoAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACOA==}, Bdsk-Url-1 = {http://ws.isiknowledge.com/cps/openurl/service?url_ver=Z39.88-2004&rft_id=info:ut/A1974S778800004}} @article{harshvardhan_et_al_1989, @@ -2500,7 +2520,6 @@ @article{akmaev_1991 @article{siebesma_et_al_2007, Abstract = {A better conceptual understanding and more realistic parameterizations of convective boundary layers in climate and weather prediction models have been major challenges in meteorological research. In particular, parameterizations of the dry convective boundary layer, in spite of the absence of water phase-changes and its consequent simplicity as compared to moist convection, typically suffer from problems in attempting to represent realistically the boundary layer growth and what is often referred to as countergradient fluxes. The eddy-diffusivity (ED) approach has been relatively successful in representing some characteristics of neutral boundary layers and surface layers in general. The mass-flux (MF) approach, on the other hand, has been used for the parameterization of shallow and deep moist convection. In this paper, a new approach that relies on a combination of the ED and MF parameterizations (EDMF) is proposed for the dry convective boundary layer. It is shown that the EDMF approach follows naturally from a decomposition of the turbulent fluxes into 1) a part that includes strong organized updrafts, and 2) a remaining turbulent field. At the basis of the EDMF approach is the concept that nonlocal subgrid transport due to the strong updrafts is taken into account by the MF approach, while the remaining transport is taken into account by an ED closure. Large-eddy simulation (LES) results of the dry convective boundary layer are used to support the theoretical framework of this new approach and to determine the parameters of the EDMF model. The performance of the new formulation is evaluated against LES results, and it is shown that the EDMF closure is able to reproduce the main properties of dry convective boundary layers in a realistic manner. Furthermore, it will be shown that this approach has strong advantages over the more traditional countergradient approach, especially in the entrainment layer. As a result, this EDMF approach opens the way to parameterize the clear and cumulus-topped boundary layer in a simple and unified way.}, Author = {Siebesma, A. Pier and Soares, Pedro M. M. and Teixeira, Joao}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBELi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvU2llYmVzbWEvMjAwNy5wZGZPEQHMAAAAAAHMAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAAAqYEwIMjAwNy5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACphyMc7+4hQREYgQ0FSTwACAAUAAAkgAAAAAAAAAAAAAAAAAAAACFNpZWJlc21hABAACAAA0ed4sgAAABEACAAAxzxd+AAAAAEAGAAqYEwAKGyWAChsiwAoZ3sAG14HAAKYXAACAF5NYWNpbnRvc2ggSEQ6VXNlcnM6AGdyYW50ZjoAQ2xvdWRTdGF0aW9uOgBmaXJsX2xpYnJhcnk6AGZpcmxfbGlicmFyeV9maWxlczoAU2llYmVzbWE6ADIwMDcucGRmAA4AEgAIADIAMAAwADcALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAEtVc2Vycy9ncmFudGYvQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvU2llYmVzbWEvMjAwNy5wZGYAABMAAS8AABUAAgAN//8AAAAIAA0AGgAkAGsAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACOw==}, Date-Added = {2016-05-20 17:17:49 +0000}, Date-Modified = {2016-05-20 17:17:49 +0000}, Doi = {DOI 10.1175/JAS3888.1}, @@ -2514,12 +2533,12 @@ @article{siebesma_et_al_2007 Title = {A combined eddy-diffusivity mass-flux approach for the convective boundary layer}, Volume = {64}, Year = {2007}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBELi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvU2llYmVzbWEvMjAwNy5wZGZPEQHMAAAAAAHMAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAAAqYEwIMjAwNy5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACphyMc7+4hQREYgQ0FSTwACAAUAAAkgAAAAAAAAAAAAAAAAAAAACFNpZWJlc21hABAACAAA0ed4sgAAABEACAAAxzxd+AAAAAEAGAAqYEwAKGyWAChsiwAoZ3sAG14HAAKYXAACAF5NYWNpbnRvc2ggSEQ6VXNlcnM6AGdyYW50ZjoAQ2xvdWRTdGF0aW9uOgBmaXJsX2xpYnJhcnk6AGZpcmxfbGlicmFyeV9maWxlczoAU2llYmVzbWE6ADIwMDcucGRmAA4AEgAIADIAMAAwADcALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAEtVc2Vycy9ncmFudGYvQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvU2llYmVzbWEvMjAwNy5wZGYAABMAAS8AABUAAgAN//8AAAAIAA0AGgAkAGsAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACOw==}, Bdsk-Url-1 = {http://ws.isiknowledge.com/cps/openurl/service?url_ver=Z39.88-2004&rft_id=info:ut/000245742600011}} @article{soares_et_al_2004, Abstract = {Recently, a new consistent way of parametrizing simultaneously local and non-local turbulent transport for the convective atmospheric boundary layer has been proposed and tested for the clear boundary layer. This approach assumes that in the convective boundary layer the subgrid-scale fluxes result from two different mixing scales: small eddies, that are parametrized by an eddy-diffusivity approach, and thermals, which are represented by a mass-flux contribution. Since the interaction between the cloud layer and the underlying sub-cloud layer predominantly takes place through strong updraughts, this approach offers an interesting avenue of establishing a unified description of the turbulent transport in the cumulus-topped boundary layer. This paper explores the possibility of such a new approach for the cumulus-topped boundary layer. In the sub-cloud and cloud layers, the mass-flux term represents the effect of strong updraughts. These are modelled by a simple entraining parcel, which determines the mean properties of the strong updraughts, the boundary-layer height, the lifting condensation level and cloud top. The residual smaller-scale turbulent transport is parametrized with an eddy-diffusivity approach that uses a turbulent kinetic energy closure. The new scheme is implemented and tested in the research model MesoNH. Copyright {\copyright} 2004 Royal Meteorological Society}, Author = {Soares, P. M. M. and Miranda, P. M. A. and Siebesma, A. P. and Teixeira, J.}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBCLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvU29hcmVzLzIwMDQucGRmTxEBxgAAAAABxgACAAAMTWFjaW50b3NoIEhEAAAAAAAAAAAAAAAAAAAA0eckUkgrAAAAWIC2CDIwMDQucGRmAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAABYf6DSsqNwAAAAAAAAAAAAAgAFAAAJIAAAAAAAAAAAAAAAAAAAAAZTb2FyZXMAEAAIAADR53iyAAAAEQAIAADSswXgAAAAAQAYAFiAtgAobJYAKGyLAChnewAbXgcAAphcAAIAXE1hY2ludG9zaCBIRDpVc2VyczoAZ3JhbnRmOgBDbG91ZFN0YXRpb246AGZpcmxfbGlicmFyeToAZmlybF9saWJyYXJ5X2ZpbGVzOgBTb2FyZXM6ADIwMDQucGRmAA4AEgAIADIAMAAwADQALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAElVc2Vycy9ncmFudGYvQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvU29hcmVzLzIwMDQucGRmAAATAAEvAAAVAAIADf//AAAACAANABoAJABpAAAAAAAAAgEAAAAAAAAABQAAAAAAAAAAAAAAAAAAAjM=}, Date-Added = {2016-05-20 17:17:49 +0000}, Date-Modified = {2016-05-20 17:17:49 +0000}, Doi = {10.1256/qj.03.223}, @@ -2533,11 +2552,11 @@ @article{soares_et_al_2004 Url = {http://dx.doi.org/10.1256/qj.03.223}, Volume = {130}, Year = {2004}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBCLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvU29hcmVzLzIwMDQucGRmTxEBxgAAAAABxgACAAAMTWFjaW50b3NoIEhEAAAAAAAAAAAAAAAAAAAA0eckUkgrAAAAWIC2CDIwMDQucGRmAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAABYf6DSsqNwAAAAAAAAAAAAAgAFAAAJIAAAAAAAAAAAAAAAAAAAAAZTb2FyZXMAEAAIAADR53iyAAAAEQAIAADSswXgAAAAAQAYAFiAtgAobJYAKGyLAChnewAbXgcAAphcAAIAXE1hY2ludG9zaCBIRDpVc2VyczoAZ3JhbnRmOgBDbG91ZFN0YXRpb246AGZpcmxfbGlicmFyeToAZmlybF9saWJyYXJ5X2ZpbGVzOgBTb2FyZXM6ADIwMDQucGRmAA4AEgAIADIAMAAwADQALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAElVc2Vycy9ncmFudGYvQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvU29hcmVzLzIwMDQucGRmAAATAAEvAAAVAAIADf//AAAACAANABoAJABpAAAAAAAAAgEAAAAAAAAABQAAAAAAAAAAAAAAAAAAAjM=}, Bdsk-Url-1 = {http://dx.doi.org/10.1256/qj.03.223}} @article{troen_and_mahrt_1986, Author = {Troen, IB and Mahrt, L.}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBBLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvVHJvZW4vMTk4Ni5wZGZPEQHEAAAAAAHEAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAABNeegIMTk4Ni5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAE13kNKUWwUAAAAAAAAAAAACAAUAAAkgAAAAAAAAAAAAAAAAAAAABVRyb2VuAAAQAAgAANHneLIAAAARAAgAANKUvXUAAAABABgATXnoAChslgAobIsAKGd7ABteBwACmFwAAgBbTWFjaW50b3NoIEhEOlVzZXJzOgBncmFudGY6AENsb3VkU3RhdGlvbjoAZmlybF9saWJyYXJ5OgBmaXJsX2xpYnJhcnlfZmlsZXM6AFRyb2VuOgAxOTg2LnBkZgAADgASAAgAMQA5ADgANgAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASFVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9Ucm9lbi8xOTg2LnBkZgATAAEvAAAVAAIADf//AAAACAANABoAJABoAAAAAAAAAgEAAAAAAAAABQAAAAAAAAAAAAAAAAAAAjA=}, Date-Added = {2016-05-20 17:17:49 +0000}, Date-Modified = {2016-05-20 17:17:49 +0000}, Doi = {10.1007/BF00122760}, @@ -2551,13 +2570,13 @@ @article{troen_and_mahrt_1986 Url = {http://dx.doi.org/10.1007/BF00122760}, Volume = {37}, Year = {1986}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBBLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvVHJvZW4vMTk4Ni5wZGZPEQHEAAAAAAHEAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAABNeegIMTk4Ni5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAE13kNKUWwUAAAAAAAAAAAACAAUAAAkgAAAAAAAAAAAAAAAAAAAABVRyb2VuAAAQAAgAANHneLIAAAARAAgAANKUvXUAAAABABgATXnoAChslgAobIsAKGd7ABteBwACmFwAAgBbTWFjaW50b3NoIEhEOlVzZXJzOgBncmFudGY6AENsb3VkU3RhdGlvbjoAZmlybF9saWJyYXJ5OgBmaXJsX2xpYnJhcnlfZmlsZXM6AFRyb2VuOgAxOTg2LnBkZgAADgASAAgAMQA5ADgANgAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASFVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9Ucm9lbi8xOTg2LnBkZgATAAEvAAAVAAIADf//AAAACAANABoAJABoAAAAAAAAAgEAAAAAAAAABQAAAAAAAAAAAAAAAAAAAjA=}, Bdsk-Url-1 = {http://dx.doi.org/10.1007/BF00122760}} @article{macvean_and_mason_1990, Abstract = {Abstract In a recent paper, Kuo and Schubert demonstrated the lack of observational support for the relevance of the criterion for cloud-top entrainment instability proposed by Randall and by Deardorff. Here we derive a new criterion, based on a model of the instability as resulting from the energy released close to cloud top, by Mixing between saturated boundary-layer air and unsaturated air from above the capping inversion. The condition is derived by considering the net conversion from potential to kinetic energy in a system consisting of two layers of fluid straddling cloud-top, when a small amount of mixing occurs between these layers. This contrasts with previous analyses, which only considered the change in buoyancy of the cloud layer when unsaturated air is mixed into it. In its most general form, this new criterion depends on the ratio of the depths of the layers involved in the mixing. It is argued that, for a self-sustaining instability, there must be a net release of kinetic energy on the same depth and time scales as the entrainment process itself. There are two plausible ways in which this requirement may be satisfied. Either one takes the depths of the layers involved in the mixing to each be comparable to the vertical scale of the entrainment process, which is typically of order tens of meters or less, or alternatively, one must allow for the efficiency with which energy released by mixing through a much deeper lower layer becomes available to initiate further entrainment. In both cases the same criterion for instability results. This criterion is much more restrictive than that proposed by Randall and by Deardorff; furthermore, the observational data is then consistent with the predictions of the current theory. Further analysis provides estimates of the turbulent fluxes associated with cloud-top entrainment instability. This analysis effectively constitutes an energetically consistent turbulence closure for models of boundary layers with cloud. The implications for such numerical models are discussed. Comparisons are also made with other possible criteria for cloud-top entrainment instability which have recently been suggested.}, Annote = {doi: 10.1175/1520-0469(1990)047<1012:CTEITS>2.0.CO;2}, Author = {MacVean, M. K. and Mason, P. J.}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBDLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvTWFjVmVhbi8xOTkwLnBkZk8RAcoAAAAAAcoAAgAADE1hY2ludG9zaCBIRAAAAAAAAAAAAAAAAAAAANHnJFJIKwAAAFx8zwgxOTkwLnBkZgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAXHyn0rkkRQAAAAAAAAAAAAIABQAACSAAAAAAAAAAAAAAAAAAAAAHTWFjVmVhbgAAEAAIAADR53iyAAAAEQAIAADSuYa1AAAAAQAYAFx8zwAobJYAKGyLAChnewAbXgcAAphcAAIAXU1hY2ludG9zaCBIRDpVc2VyczoAZ3JhbnRmOgBDbG91ZFN0YXRpb246AGZpcmxfbGlicmFyeToAZmlybF9saWJyYXJ5X2ZpbGVzOgBNYWNWZWFuOgAxOTkwLnBkZgAADgASAAgAMQA5ADkAMAAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASlVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9NYWNWZWFuLzE5OTAucGRmABMAAS8AABUAAgAN//8AAAAIAA0AGgAkAGoAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACOA==}, Booktitle = {Journal of the Atmospheric Sciences}, Da = {1990/04/01}, Date-Added = {2016-05-20 17:16:05 +0000}, @@ -2576,11 +2595,11 @@ @article{macvean_and_mason_1990 Url = {http://dx.doi.org/10.1175/1520-0469(1990)047<1012:CTEITS>2.0.CO;2}, Volume = {47}, Year = {1990}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBDLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvTWFjVmVhbi8xOTkwLnBkZk8RAcoAAAAAAcoAAgAADE1hY2ludG9zaCBIRAAAAAAAAAAAAAAAAAAAANHnJFJIKwAAAFx8zwgxOTkwLnBkZgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAXHyn0rkkRQAAAAAAAAAAAAIABQAACSAAAAAAAAAAAAAAAAAAAAAHTWFjVmVhbgAAEAAIAADR53iyAAAAEQAIAADSuYa1AAAAAQAYAFx8zwAobJYAKGyLAChnewAbXgcAAphcAAIAXU1hY2ludG9zaCBIRDpVc2VyczoAZ3JhbnRmOgBDbG91ZFN0YXRpb246AGZpcmxfbGlicmFyeToAZmlybF9saWJyYXJ5X2ZpbGVzOgBNYWNWZWFuOgAxOTkwLnBkZgAADgASAAgAMQA5ADkAMAAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASlVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9NYWNWZWFuLzE5OTAucGRmABMAAS8AABUAAgAN//8AAAAIAA0AGgAkAGoAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACOA==}, Bdsk-Url-1 = {http://dx.doi.org/10.1175/1520-0469(1990)047%3C1012:CTEITS%3E2.0.CO;2}} @article{louis_1979, Author = {Louis, JF}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBBLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvTG91aXMvMTk3OS5wZGZPEQHEAAAAAAHEAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAAAonogIMTk3OS5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACiej8FuU4pQREYgQ0FSTwACAAUAAAkgAAAAAAAAAAAAAAAAAAAABUxvdWlzAAAQAAgAANHneLIAAAARAAgAAMFutfoAAAABABgAKJ6IAChslgAobIsAKGd7ABteBwACmFwAAgBbTWFjaW50b3NoIEhEOlVzZXJzOgBncmFudGY6AENsb3VkU3RhdGlvbjoAZmlybF9saWJyYXJ5OgBmaXJsX2xpYnJhcnlfZmlsZXM6AExvdWlzOgAxOTc5LnBkZgAADgASAAgAMQA5ADcAOQAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASFVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9Mb3Vpcy8xOTc5LnBkZgATAAEvAAAVAAIADf//AAAACAANABoAJABoAAAAAAAAAgEAAAAAAAAABQAAAAAAAAAAAAAAAAAAAjA=}, Date-Added = {2016-05-20 17:15:52 +0000}, Date-Modified = {2016-05-20 17:15:52 +0000}, Isi = {A1979HT69700004}, @@ -2593,12 +2612,12 @@ @article{louis_1979 Title = {A PARAMETRIC MODEL OF VERTICAL EDDY FLUXES IN THE ATMOSPHERE}, Volume = {17}, Year = {1979}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBBLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvTG91aXMvMTk3OS5wZGZPEQHEAAAAAAHEAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAAAonogIMTk3OS5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACiej8FuU4pQREYgQ0FSTwACAAUAAAkgAAAAAAAAAAAAAAAAAAAABUxvdWlzAAAQAAgAANHneLIAAAARAAgAAMFutfoAAAABABgAKJ6IAChslgAobIsAKGd7ABteBwACmFwAAgBbTWFjaW50b3NoIEhEOlVzZXJzOgBncmFudGY6AENsb3VkU3RhdGlvbjoAZmlybF9saWJyYXJ5OgBmaXJsX2xpYnJhcnlfZmlsZXM6AExvdWlzOgAxOTc5LnBkZgAADgASAAgAMQA5ADcAOQAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASFVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9Mb3Vpcy8xOTc5LnBkZgATAAEvAAAVAAIADf//AAAACAANABoAJABoAAAAAAAAAgEAAAAAAAAABQAAAAAAAAAAAAAAAAAAAjA=}, Bdsk-Url-1 = {http://ws.isiknowledge.com/cps/openurl/service?url_ver=Z39.88-2004&rft_id=info:ut/A1979HT69700004}} @article{lock_et_al_2000, Abstract = {A new boundary layer turbulent mixing scheme has been developed for use in the UKMO weather forecasting and climate prediction models. This includes a representation of nonlocal mixing (driven by both surface fluxes and cloud-top processes) in unstable layers, either coupled to or decoupled from the surface, and an explicit entrainment parameterization. The scheme is formulated in moist conserved variables so that it can treat both dry and cloudy layers. Details of the scheme and examples of its performance in single-column model tests are presented.}, Author = {Lock, AP and Brown, AR and Bush, MR and Martin, GM and Smith, RNB}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBALi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvTG9jay8yMDAwLnBkZk8RAcAAAAAAAcAAAgAADE1hY2ludG9zaCBIRAAAAAAAAAAAAAAAAAAAANHnJFJIKwAAACibewgyMDAwLnBkZgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKJuLywPrPAAAAAAAAAAAAAIABQAACSAAAAAAAAAAAAAAAAAAAAAETG9jawAQAAgAANHneLIAAAARAAgAAMsETawAAAABABgAKJt7AChslgAobIsAKGd7ABteBwACmFwAAgBaTWFjaW50b3NoIEhEOlVzZXJzOgBncmFudGY6AENsb3VkU3RhdGlvbjoAZmlybF9saWJyYXJ5OgBmaXJsX2xpYnJhcnlfZmlsZXM6AExvY2s6ADIwMDAucGRmAA4AEgAIADIAMAAwADAALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAEdVc2Vycy9ncmFudGYvQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvTG9jay8yMDAwLnBkZgAAEwABLwAAFQACAA3//wAAAAgADQAaACQAZwAAAAAAAAIBAAAAAAAAAAUAAAAAAAAAAAAAAAAAAAIr}, Date-Added = {2016-05-20 17:15:36 +0000}, Date-Modified = {2016-05-20 17:15:36 +0000}, Isi = {000089461100008}, @@ -2611,13 +2630,13 @@ @article{lock_et_al_2000 Title = {A new boundary layer mixing scheme. {P}art {I}: Scheme description and single-column model tests}, Volume = {128}, Year = {2000}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBALi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvTG9jay8yMDAwLnBkZk8RAcAAAAAAAcAAAgAADE1hY2ludG9zaCBIRAAAAAAAAAAAAAAAAAAAANHnJFJIKwAAACibewgyMDAwLnBkZgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKJuLywPrPAAAAAAAAAAAAAIABQAACSAAAAAAAAAAAAAAAAAAAAAETG9jawAQAAgAANHneLIAAAARAAgAAMsETawAAAABABgAKJt7AChslgAobIsAKGd7ABteBwACmFwAAgBaTWFjaW50b3NoIEhEOlVzZXJzOgBncmFudGY6AENsb3VkU3RhdGlvbjoAZmlybF9saWJyYXJ5OgBmaXJsX2xpYnJhcnlfZmlsZXM6AExvY2s6ADIwMDAucGRmAA4AEgAIADIAMAAwADAALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAEdVc2Vycy9ncmFudGYvQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvTG9jay8yMDAwLnBkZgAAEwABLwAAFQACAA3//wAAAAgADQAaACQAZwAAAAAAAAIBAAAAAAAAAAUAAAAAAAAAAAAAAAAAAAIr}, Bdsk-Url-1 = {http://ws.isiknowledge.com/cps/openurl/service?url_ver=Z39.88-2004&rft_id=info:ut/000089461100008}} @article{hong_and_pan_1996, Abstract = {Abstract In this paper, the incorporation of a simple atmospheric boundary layer diffusion scheme into the NCEP Medium-Range Forecast Model is described. A boundary layer diffusion package based on the Troen and Mahrt nonlocal diffusion concept has been tested for possible operational implementation. The results from this approach are compared with those from the local diffusion approach, which is the current operational scheme, and verified against FIFE observations during 9?10 August 1987. The comparisons between local and nonlocal approaches are extended to the forecast for a heavy rain case of 15?17 May 1995. The sensitivity of both the boundary layer development and the precipitation forecast to the tuning parameters in the nonlocal diffusion scheme is also investigated. Special attention is given to the interaction of boundary layer processes with precipitation physics. Some results of parallel runs during August 1995 are also presented.}, Annote = {doi: 10.1175/1520-0493(1996)124<2322:NBLVDI>2.0.CO;2}, Author = {Hong, Song-You and Pan, Hua-Lu}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBALi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvSG9uZy8xOTk2LnBkZk8RAcAAAAAAAcAAAgAADE1hY2ludG9zaCBIRAAAAAAAAAAAAAAAAAAAANHnJFJIKwAAAE18FggxOTk2LnBkZgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAATXvY0pRb8QAAAAAAAAAAAAIABQAACSAAAAAAAAAAAAAAAAAAAAAESG9uZwAQAAgAANHneLIAAAARAAgAANKUvmEAAAABABgATXwWAChslgAobIsAKGd7ABteBwACmFwAAgBaTWFjaW50b3NoIEhEOlVzZXJzOgBncmFudGY6AENsb3VkU3RhdGlvbjoAZmlybF9saWJyYXJ5OgBmaXJsX2xpYnJhcnlfZmlsZXM6AEhvbmc6ADE5OTYucGRmAA4AEgAIADEAOQA5ADYALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAEdVc2Vycy9ncmFudGYvQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvSG9uZy8xOTk2LnBkZgAAEwABLwAAFQACAA3//wAAAAgADQAaACQAZwAAAAAAAAIBAAAAAAAAAAUAAAAAAAAAAAAAAAAAAAIr}, Booktitle = {Monthly Weather Review}, Da = {1996/10/01}, Date = {1996/10/01}, @@ -2638,13 +2657,13 @@ @article{hong_and_pan_1996 Volume = {124}, Year = {1996}, Year1 = {1996}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBALi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvSG9uZy8xOTk2LnBkZk8RAcAAAAAAAcAAAgAADE1hY2ludG9zaCBIRAAAAAAAAAAAAAAAAAAAANHnJFJIKwAAAE18FggxOTk2LnBkZgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAATXvY0pRb8QAAAAAAAAAAAAIABQAACSAAAAAAAAAAAAAAAAAAAAAESG9uZwAQAAgAANHneLIAAAARAAgAANKUvmEAAAABABgATXwWAChslgAobIsAKGd7ABteBwACmFwAAgBaTWFjaW50b3NoIEhEOlVzZXJzOgBncmFudGY6AENsb3VkU3RhdGlvbjoAZmlybF9saWJyYXJ5OgBmaXJsX2xpYnJhcnlfZmlsZXM6AEhvbmc6ADE5OTYucGRmAA4AEgAIADEAOQA5ADYALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAEdVc2Vycy9ncmFudGYvQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvSG9uZy8xOTk2LnBkZgAAEwABLwAAFQACAA3//wAAAAgADQAaACQAZwAAAAAAAAIBAAAAAAAAAAUAAAAAAAAAAAAAAAAAAAIr}, Bdsk-Url-1 = {http://dx.doi.org/10.1175/1520-0493(1996)124%3C2322:NBLVDI%3E2.0.CO;2}} @article{han_and_pan_2006, Abstract = {Abstract A parameterization of the convection-induced pressure gradient force (PGF) in convective momentum transport (CMT) is tested for hurricane intensity forecasting using NCEP's operational Global Forecast System (GFS) and its nested Regional Spectral Model (RSM). In the parameterization the PGF is assumed to be proportional to the product of the cloud mass flux and vertical wind shear. Compared to control forecasts using the present operational GFS and RSM where the PGF effect in CMT is taken into account empirically, the new PGF parameterization helps increase hurricane intensity by reducing the vertical momentum exchange, giving rise to a closer comparison to the observations. In addition, the new PGF parameterization forecasts not only show more realistically organized precipitation patterns with enhanced hurricane intensity but also reduce the forecast track error. Nevertheless, the model forecasts with the new PGF parameterization still largely underpredict the observed intensity. One of the many possible reasons for the large underprediction may be the absence of hurricane initialization in the models.}, Annote = {doi: 10.1175/MWR3090.1}, Author = {Han, Jongil and Pan, Hua-Lu}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxA/Li4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvSGFuLzIwMDYucGRmTxEBvgAAAAABvgACAAAMTWFjaW50b3NoIEhEAAAAAAAAAAAAAAAAAAAA0eckUkgrAAAAWsT5CDIwMDYucGRmAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAABazFjStCvVAAAAAAAAAAAAAgAFAAAJIAAAAAAAAAAAAAAAAAAAAANIYW4AABAACAAA0ed4sgAAABEACAAA0rSORQAAAAEAGABaxPkAKGyWAChsiwAoZ3sAG14HAAKYXAACAFlNYWNpbnRvc2ggSEQ6VXNlcnM6AGdyYW50ZjoAQ2xvdWRTdGF0aW9uOgBmaXJsX2xpYnJhcnk6AGZpcmxfbGlicmFyeV9maWxlczoASGFuOgAyMDA2LnBkZgAADgASAAgAMgAwADAANgAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIARlVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9IYW4vMjAwNi5wZGYAEwABLwAAFQACAA3//wAAAAgADQAaACQAZgAAAAAAAAIBAAAAAAAAAAUAAAAAAAAAAAAAAAAAAAIo}, Booktitle = {Monthly Weather Review}, Da = {2006/02/01}, Date-Added = {2016-05-20 17:11:17 +0000}, @@ -2663,11 +2682,11 @@ @article{han_and_pan_2006 Url = {http://dx.doi.org/10.1175/MWR3090.1}, Volume = {134}, Year = {2006}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxA/Li4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvSGFuLzIwMDYucGRmTxEBvgAAAAABvgACAAAMTWFjaW50b3NoIEhEAAAAAAAAAAAAAAAAAAAA0eckUkgrAAAAWsT5CDIwMDYucGRmAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAABazFjStCvVAAAAAAAAAAAAAgAFAAAJIAAAAAAAAAAAAAAAAAAAAANIYW4AABAACAAA0ed4sgAAABEACAAA0rSORQAAAAEAGABaxPkAKGyWAChsiwAoZ3sAG14HAAKYXAACAFlNYWNpbnRvc2ggSEQ6VXNlcnM6AGdyYW50ZjoAQ2xvdWRTdGF0aW9uOgBmaXJsX2xpYnJhcnk6AGZpcmxfbGlicmFyeV9maWxlczoASGFuOgAyMDA2LnBkZgAADgASAAgAMgAwADAANgAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIARlVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9IYW4vMjAwNi5wZGYAEwABLwAAFQACAA3//wAAAAgADQAaACQAZgAAAAAAAAIBAAAAAAAAAAUAAAAAAAAAAAAAAAAAAAIo}, Bdsk-Url-1 = {http://dx.doi.org/10.1175/MWR3090.1}} @article{businger_et_al_1971, Author = {Businger, JA and Wyngaard, JC and Izumi, Y and Bradley, EF}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBELi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvQnVzaW5nZXIvMTk3MS5wZGZPEQHMAAAAAAHMAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAAAodUUIMTk3MS5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACh1cbTPIxwAAAAAAAAAAAACAAUAAAkgAAAAAAAAAAAAAAAAAAAACEJ1c2luZ2VyABAACAAA0ed4sgAAABEACAAAtM+FjAAAAAEAGAAodUUAKGyWAChsiwAoZ3sAG14HAAKYXAACAF5NYWNpbnRvc2ggSEQ6VXNlcnM6AGdyYW50ZjoAQ2xvdWRTdGF0aW9uOgBmaXJsX2xpYnJhcnk6AGZpcmxfbGlicmFyeV9maWxlczoAQnVzaW5nZXI6ADE5NzEucGRmAA4AEgAIADEAOQA3ADEALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAEtVc2Vycy9ncmFudGYvQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvQnVzaW5nZXIvMTk3MS5wZGYAABMAAS8AABUAAgAN//8AAAAIAA0AGgAkAGsAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACOw==}, Date-Added = {2016-05-20 17:10:50 +0000}, Date-Modified = {2018-07-18 18:58:08 +0000}, Isi = {A1971I822800004}, @@ -2680,6 +2699,7 @@ @article{businger_et_al_1971 Title = {Flux-profile relationships in the atmospheric surface layer}, Volume = {28}, Year = {1971}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBELi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvQnVzaW5nZXIvMTk3MS5wZGZPEQHMAAAAAAHMAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAAAodUUIMTk3MS5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACh1cbTPIxwAAAAAAAAAAAACAAUAAAkgAAAAAAAAAAAAAAAAAAAACEJ1c2luZ2VyABAACAAA0ed4sgAAABEACAAAtM+FjAAAAAEAGAAodUUAKGyWAChsiwAoZ3sAG14HAAKYXAACAF5NYWNpbnRvc2ggSEQ6VXNlcnM6AGdyYW50ZjoAQ2xvdWRTdGF0aW9uOgBmaXJsX2xpYnJhcnk6AGZpcmxfbGlicmFyeV9maWxlczoAQnVzaW5nZXI6ADE5NzEucGRmAA4AEgAIADEAOQA3ADEALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAEtVc2Vycy9ncmFudGYvQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvQnVzaW5nZXIvMTk3MS5wZGYAABMAAS8AABUAAgAN//8AAAAIAA0AGgAkAGsAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACOw==}, Bdsk-Url-1 = {http://ws.isiknowledge.com/cps/openurl/service?url_ver=Z39.88-2004&rft_id=info:ut/A1971I822800004}} @article{xu_and_randall_1996, @@ -2870,18 +2890,17 @@ @article{kim_and_arakawa_1995 @techreport{hou_et_al_2002, Author = {Y. Hou and S. Moorthi and K. Campana}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxAiLi4vLi4vemhhbmctbGliL2hvdV9ldF9hbF8yMDAyLnBkZk8RAdwAAAAAAdwAAgAADE1hY2ludG9zaCBIRAAAAAAAAAAAAAAAAAAAAM/T1mZIKwAAAFKkjRJob3VfZXRfYWxfMjAwMi5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAUqai02OGCgAAAAAAAAAAAAIAAgAACSAAAAAAAAAAAAAAAAAAAAAJemhhbmctbGliAAAQAAgAAM/UKsYAAAARAAgAANNj2moAAAABABgAUqSNAE1lSgAj19QACTbFAAk2xAACZvkAAgBbTWFjaW50b3NoIEhEOlVzZXJzOgBtYW56aGFuZzoARG9jdW1lbnRzOgBNYW4uWmhhbmc6AGdtdGItZG9jOgB6aGFuZy1saWI6AGhvdV9ldF9hbF8yMDAyLnBkZgAADgAmABIAaABvAHUAXwBlAHQAXwBhAGwAXwAyADAAMAAyAC4AcABkAGYADwAaAAwATQBhAGMAaQBuAHQAbwBzAGgAIABIAEQAEgBIVXNlcnMvbWFuemhhbmcvRG9jdW1lbnRzL01hbi5aaGFuZy9nbXRiLWRvYy96aGFuZy1saWIvaG91X2V0X2FsXzIwMDIucGRmABMAAS8AABUAAgAP//8AAAAIAA0AGgAkAEkAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACKQ==}, Date-Added = {2016-05-19 19:52:22 +0000}, Date-Modified = {2016-05-20 15:14:59 +0000}, Institution = {NCEP}, Number = {441}, Title = {Parameterization of Solar Radiation Transfer}, Type = {office note}, - Year = {2002}} + Year = {2002}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxAiLi4vLi4vemhhbmctbGliL2hvdV9ldF9hbF8yMDAyLnBkZk8RAdwAAAAAAdwAAgAADE1hY2ludG9zaCBIRAAAAAAAAAAAAAAAAAAAAM/T1mZIKwAAAFKkjRJob3VfZXRfYWxfMjAwMi5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAUqai02OGCgAAAAAAAAAAAAIAAgAACSAAAAAAAAAAAAAAAAAAAAAJemhhbmctbGliAAAQAAgAAM/UKsYAAAARAAgAANNj2moAAAABABgAUqSNAE1lSgAj19QACTbFAAk2xAACZvkAAgBbTWFjaW50b3NoIEhEOlVzZXJzOgBtYW56aGFuZzoARG9jdW1lbnRzOgBNYW4uWmhhbmc6AGdtdGItZG9jOgB6aGFuZy1saWI6AGhvdV9ldF9hbF8yMDAyLnBkZgAADgAmABIAaABvAHUAXwBlAHQAXwBhAGwAXwAyADAAMAAyAC4AcABkAGYADwAaAAwATQBhAGMAaQBuAHQAbwBzAGgAIABIAEQAEgBIVXNlcnMvbWFuemhhbmcvRG9jdW1lbnRzL01hbi5aaGFuZy9nbXRiLWRvYy96aGFuZy1saWIvaG91X2V0X2FsXzIwMDIucGRmABMAAS8AABUAAgAP//8AAAAIAA0AGgAkAEkAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACKQ==}} @article{hu_and_stamnes_1993, Author = {Y.X. Hu and K. Stamnes}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxAnLi4vLi4vemhhbmctbGliL2h1X2FuZF9zdGFtbmVzXzE5OTMucGRmTxEB8AAAAAAB8AACAAAMTWFjaW50b3NoIEhEAAAAAAAAAAAAAAAAAAAAz9PWZkgrAAAAUqSNF2h1X2FuZF9zdGFtbmVzXzE5OTMucGRmAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAABSpJHTY3R+AAAAAAAAAAAAAgACAAAJIAAAAAAAAAAAAAAAAAAAAAl6aGFuZy1saWIAABAACAAAz9QqxgAAABEACAAA02PI3gAAAAEAGABSpI0ATWVKACPX1AAJNsUACTbEAAJm+QACAGBNYWNpbnRvc2ggSEQ6VXNlcnM6AG1hbnpoYW5nOgBEb2N1bWVudHM6AE1hbi5aaGFuZzoAZ210Yi1kb2M6AHpoYW5nLWxpYjoAaHVfYW5kX3N0YW1uZXNfMTk5My5wZGYADgAwABcAaAB1AF8AYQBuAGQAXwBzAHQAYQBtAG4AZQBzAF8AMQA5ADkAMwAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIATVVzZXJzL21hbnpoYW5nL0RvY3VtZW50cy9NYW4uWmhhbmcvZ210Yi1kb2MvemhhbmctbGliL2h1X2FuZF9zdGFtbmVzXzE5OTMucGRmAAATAAEvAAAVAAIAD///AAAACAANABoAJABOAAAAAAAAAgEAAAAAAAAABQAAAAAAAAAAAAAAAAAAAkI=}, Date-Added = {2016-05-19 19:31:56 +0000}, Date-Modified = {2016-05-20 15:13:12 +0000}, Journal = {J. Climate}, @@ -2889,276 +2908,303 @@ @article{hu_and_stamnes_1993 Pages = {728-742}, Title = {An accurate parameterization of the radiative properties of water clouds suitable for use in climate models}, Volume = {6}, - Year = {1993}} + Year = {1993}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxAnLi4vLi4vemhhbmctbGliL2h1X2FuZF9zdGFtbmVzXzE5OTMucGRmTxEB8AAAAAAB8AACAAAMTWFjaW50b3NoIEhEAAAAAAAAAAAAAAAAAAAAz9PWZkgrAAAAUqSNF2h1X2FuZF9zdGFtbmVzXzE5OTMucGRmAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAABSpJHTY3R+AAAAAAAAAAAAAgACAAAJIAAAAAAAAAAAAAAAAAAAAAl6aGFuZy1saWIAABAACAAAz9QqxgAAABEACAAA02PI3gAAAAEAGABSpI0ATWVKACPX1AAJNsUACTbEAAJm+QACAGBNYWNpbnRvc2ggSEQ6VXNlcnM6AG1hbnpoYW5nOgBEb2N1bWVudHM6AE1hbi5aaGFuZzoAZ210Yi1kb2M6AHpoYW5nLWxpYjoAaHVfYW5kX3N0YW1uZXNfMTk5My5wZGYADgAwABcAaAB1AF8AYQBuAGQAXwBzAHQAYQBtAG4AZQBzAF8AMQA5ADkAMwAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIATVVzZXJzL21hbnpoYW5nL0RvY3VtZW50cy9NYW4uWmhhbmcvZ210Yi1kb2MvemhhbmctbGliL2h1X2FuZF9zdGFtbmVzXzE5OTMucGRmAAATAAEvAAAVAAIAD///AAAACAANABoAJABOAAAAAAAAAgEAAAAAAAAABQAAAAAAAAAAAAAAAAAAAkI=}} @article{alexander_et_al_2010, - author = {Alexander, M. J. and Geller, M. and McLandress, C. and Polavarapu, S. and Preusse, P. and Sassi, F. and Sato, K. and Eckermann, S. and Ern, M. and Hertzog, A. and Kawatani, Y. and Pulido, M. and Shaw, T. A. and Sigmond, M. and Vincent, R. and Watanabe, S.}, - title = {Recent developments in gravity-wave effects in climate models and the global distribution of gravity-wave momentum flux from observations and models}, - journal = {Quarterly Journal of the Royal Meteorological Society}, - volume = {136}, - number = {650}, - pages = {1103-1124}, - keywords = {atmosphere, gravity wave, momentum flux, drag, force, wind tendency, climate, global model}, - doi = {10.1002/qj.637}, - url = {https://rmets.onlinelibrary.wiley.com/doi/abs/10.1002/qj.637}, - eprint = {https://rmets.onlinelibrary.wiley.com/doi/pdf/10.1002/qj.637}, - year = {2010}} + Author = {Alexander, M. J. and Geller, M. and McLandress, C. and Polavarapu, S. and Preusse, P. and Sassi, F. and Sato, K. and Eckermann, S. and Ern, M. and Hertzog, A. and Kawatani, Y. and Pulido, M. and Shaw, T. A. and Sigmond, M. and Vincent, R. and Watanabe, S.}, + Doi = {10.1002/qj.637}, + Eprint = {https://rmets.onlinelibrary.wiley.com/doi/pdf/10.1002/qj.637}, + Journal = {Quarterly Journal of the Royal Meteorological Society}, + Keywords = {atmosphere, gravity wave, momentum flux, drag, force, wind tendency, climate, global model}, + Number = {650}, + Pages = {1103-1124}, + Title = {Recent developments in gravity-wave effects in climate models and the global distribution of gravity-wave momentum flux from observations and models}, + Url = {https://rmets.onlinelibrary.wiley.com/doi/abs/10.1002/qj.637}, + Volume = {136}, + Year = {2010}, + Bdsk-Url-1 = {https://rmets.onlinelibrary.wiley.com/doi/abs/10.1002/qj.637}, + Bdsk-Url-2 = {https://doi.org/10.1002/qj.637}} @article{plougonven_and_zhang_2014, - author = {Plougonven, R. and Zhang, F.}, - title = {Internal gravity waves from atmospheric jets and fronts}, - journal = {Reviews of Geophysics}, - volume = {52}, - number = {1}, - pages = {33-76}, - keywords = {gravity waves, stratosphere, atmosphere, jets, fronts, weather}, - doi = {10.1002/2012RG000419}, - url = {https://agupubs.onlinelibrary.wiley.com/doi/abs/10.1002/2012RG000419}, - eprint = {https://agupubs.onlinelibrary.wiley.com/doi/pdf/10.1002/2012RG000419}, - year = {2014}} + Author = {Plougonven, R. and Zhang, F.}, + Doi = {10.1002/2012RG000419}, + Eprint = {https://agupubs.onlinelibrary.wiley.com/doi/pdf/10.1002/2012RG000419}, + Journal = {Reviews of Geophysics}, + Keywords = {gravity waves, stratosphere, atmosphere, jets, fronts, weather}, + Number = {1}, + Pages = {33-76}, + Title = {Internal gravity waves from atmospheric jets and fronts}, + Url = {https://agupubs.onlinelibrary.wiley.com/doi/abs/10.1002/2012RG000419}, + Volume = {52}, + Year = {2014}, + Bdsk-Url-1 = {https://agupubs.onlinelibrary.wiley.com/doi/abs/10.1002/2012RG000419}, + Bdsk-Url-2 = {https://doi.org/10.1002/2012RG000419}} @article{weinstock_1984, - author = {Weinstock, J.}, - title = {Simplified derivation of an algorithm for nonlinear gravity waves}, - journal = {Journal of Geophysical Research: Space Physics}, - volume = {89}, - number = {A1}, - pages = {345-350}, - doi = {10.1029/JA089iA01p00345}, - url = {https://agupubs.onlinelibrary.wiley.com/doi/abs/10.1029/JA089iA01p00345}, - eprint = {https://agupubs.onlinelibrary.wiley.com/doi/pdf/10.1029/JA089iA01p00345}, - year = {1984}} + Author = {Weinstock, J.}, + Doi = {10.1029/JA089iA01p00345}, + Eprint = {https://agupubs.onlinelibrary.wiley.com/doi/pdf/10.1029/JA089iA01p00345}, + Journal = {Journal of Geophysical Research: Space Physics}, + Number = {A1}, + Pages = {345-350}, + Title = {Simplified derivation of an algorithm for nonlinear gravity waves}, + Url = {https://agupubs.onlinelibrary.wiley.com/doi/abs/10.1029/JA089iA01p00345}, + Volume = {89}, + Year = {1984}, + Bdsk-Url-1 = {https://agupubs.onlinelibrary.wiley.com/doi/abs/10.1029/JA089iA01p00345}, + Bdsk-Url-2 = {https://doi.org/10.1029/JA089iA01p00345}} @article{holton_1983, - author = {Holton, James R.}, - title = {The Influence of Gravity Wave Breaking on the General Circulation of the Middle Atmosphere}, - journal = {Journal of the Atmospheric Sciences}, - volume = {40}, - number = {10}, - pages = {2497-2507}, - year = {1983}, - doi = {10.1175/1520-0469(1983)040<2497:TIOGWB>2.0.CO;2}, - URL = {https://doi.org/10.1175/1520-0469(1983)040<2497:TIOGWB>2.0.CO;2}, - eprint = {https://doi.org/10.1175/1520-0469(1983)040<2497:TIOGWB>2.0.CO;2}} + Author = {Holton, James R.}, + Doi = {10.1175/1520-0469(1983)040<2497:TIOGWB>2.0.CO;2}, + Eprint = {https://doi.org/10.1175/1520-0469(1983)040<2497:TIOGWB>2.0.CO;2}, + Journal = {Journal of the Atmospheric Sciences}, + Number = {10}, + Pages = {2497-2507}, + Title = {The Influence of Gravity Wave Breaking on the General Circulation of the Middle Atmosphere}, + Url = {https://doi.org/10.1175/1520-0469(1983)040<2497:TIOGWB>2.0.CO;2}, + Volume = {40}, + Year = {1983}, + Bdsk-Url-1 = {https://doi.org/10.1175/1520-0469(1983)040%3C2497:TIOGWB%3E2.0.CO;2}} @article{geller_et_al_2013, - author = {Geller, M. A. and Alexander, M. Joan and Love, P. T. and Bacmeister, J. and Ern, M. and Hertzog, A. and Manzini, E. and Preusse, P. and Sato, K. and Scaife, A. A. and Zhou, T.}, - title = {A Comparison between Gravity Wave Momentum Fluxes in Observations and Climate Models}, - journal = {Journal of Climate}, - volume = {26}, - number = {17}, - pages = {6383-6405}, - year = {2013}, - doi = {10.1175/JCLI-D-12-00545.1}, - URL = {https://doi.org/10.1175/JCLI-D-12-00545.1}, - eprint = {https://doi.org/10.1175/JCLI-D-12-00545.1}} + Author = {Geller, M. A. and Alexander, M. Joan and Love, P. T. and Bacmeister, J. and Ern, M. and Hertzog, A. and Manzini, E. and Preusse, P. and Sato, K. and Scaife, A. A. and Zhou, T.}, + Doi = {10.1175/JCLI-D-12-00545.1}, + Eprint = {https://doi.org/10.1175/JCLI-D-12-00545.1}, + Journal = {Journal of Climate}, + Number = {17}, + Pages = {6383-6405}, + Title = {A Comparison between Gravity Wave Momentum Fluxes in Observations and Climate Models}, + Url = {https://doi.org/10.1175/JCLI-D-12-00545.1}, + Volume = {26}, + Year = {2013}, + Bdsk-Url-1 = {https://doi.org/10.1175/JCLI-D-12-00545.1}} @article{garcia_et_al_2017, - author = {Garcia, R. R. and Smith, A. K. and Kinnison, D. E. and Cámara, Á. and Murphy, D. J.}, - title = {Modification of the Gravity Wave Parameterization in the Whole Atmosphere Community Climate Model: Motivation and Results}, - journal = {Journal of the Atmospheric Sciences}, - volume = {74}, - number = {1}, - pages = {275-291}, - year = {2017}, - doi = {10.1175/JAS-D-16-0104.1}, - URL = {https://doi.org/10.1175/JAS-D-16-0104.1}, - eprint = {https://doi.org/10.1175/JAS-D-16-0104.1}} + Author = {Garcia, R. R. and Smith, A. K. and Kinnison, D. E. and C{\'a}mara, {\'A}. and Murphy, D. J.}, + Doi = {10.1175/JAS-D-16-0104.1}, + Eprint = {https://doi.org/10.1175/JAS-D-16-0104.1}, + Journal = {Journal of the Atmospheric Sciences}, + Number = {1}, + Pages = {275-291}, + Title = {Modification of the Gravity Wave Parameterization in the Whole Atmosphere Community Climate Model: Motivation and Results}, + Url = {https://doi.org/10.1175/JAS-D-16-0104.1}, + Volume = {74}, + Year = {2017}, + Bdsk-Url-1 = {https://doi.org/10.1175/JAS-D-16-0104.1}} @inproceedings{yudin_et_al_2016, - title={Gravity wave physics in the NOAA Environmental Modeling System}, - author={Yudin, V.A. and Akmaev, R.A. and Fuller-Rowell, T.J. and Alpert, J.C.}, - booktitle={International SPARC Gravity Wave Symposium}, - volume={48}, - number={1}, - pages={012024}, - year={2016}, - organization={}} + Author = {Yudin, V.A. and Akmaev, R.A. and Fuller-Rowell, T.J. and Alpert, J.C.}, + Booktitle = {International SPARC Gravity Wave Symposium}, + Number = {1}, + Pages = {012024}, + Title = {Gravity wave physics in the NOAA Environmental Modeling System}, + Volume = {48}, + Year = {2016}} @inproceedings{alpert_et_al_2018, - title={Integrating Unified Gravity Wave Physics Research into the Next Generation Global Prediction System for NCEP Research to Operations}, - author={Alpert, Jordan C and Yudin, Valery and Fuller-Rowell, Tim and Akmaev, Rashid A}, - booktitle={98th American Meteorological Society Annual Meeting}, - year={2018}, - organization={AMS}} + Author = {Alpert, Jordan C and Yudin, Valery and Fuller-Rowell, Tim and Akmaev, Rashid A}, + Booktitle = {98th American Meteorological Society Annual Meeting}, + Organization = {AMS}, + Title = {Integrating Unified Gravity Wave Physics Research into the Next Generation Global Prediction System for NCEP Research to Operations}, + Year = {2018}} @article{eckermann_2011, - author = {Eckermann, Stephen D.}, - title = {Explicitly Stochastic Parameterization of Nonorographic Gravity Wave Drag}, - journal = {Journal of the Atmospheric Sciences}, - volume = {68}, - number = {8}, - pages = {1749-1765}, - year = {2011}, - doi = {10.1175/2011JAS3684.1}, - URL = {https://doi.org/10.1175/2011JAS3684.1}, - eprint = {https://doi.org/10.1175/2011JAS3684.1}} + Author = {Eckermann, Stephen D.}, + Doi = {10.1175/2011JAS3684.1}, + Eprint = {https://doi.org/10.1175/2011JAS3684.1}, + Journal = {Journal of the Atmospheric Sciences}, + Number = {8}, + Pages = {1749-1765}, + Title = {Explicitly Stochastic Parameterization of Nonorographic Gravity Wave Drag}, + Url = {https://doi.org/10.1175/2011JAS3684.1}, + Volume = {68}, + Year = {2011}, + Bdsk-Url-1 = {https://doi.org/10.1175/2011JAS3684.1}} @article{lott_et_al_2012, - author = {Lott, F. and Guez, L. and Maury, P.}, - title = {A stochastic parameterization of non-orographic gravity waves: Formalism and impact on the equatorial stratosphere}, - journal = {Geophysical Research Letters}, - volume = {39}, - number = {6}, - pages = {}, - keywords = {Quasi-Biennial Oscillation, Rossby-gravity waves, gravity waves, stochastic parameterization, stratospheric dynamics}, - doi = {10.1029/2012GL051001}, - url = {https://agupubs.onlinelibrary.wiley.com/doi/abs/10.1029/2012GL051001}, - eprint = {https://agupubs.onlinelibrary.wiley.com/doi/pdf/10.1029/2012GL051001}, - year = {2012}} + Author = {Lott, F. and Guez, L. and Maury, P.}, + Doi = {10.1029/2012GL051001}, + Eprint = {https://agupubs.onlinelibrary.wiley.com/doi/pdf/10.1029/2012GL051001}, + Journal = {Geophysical Research Letters}, + Keywords = {Quasi-Biennial Oscillation, Rossby-gravity waves, gravity waves, stochastic parameterization, stratospheric dynamics}, + Number = {6}, + Title = {A stochastic parameterization of non-orographic gravity waves: Formalism and impact on the equatorial stratosphere}, + Url = {https://agupubs.onlinelibrary.wiley.com/doi/abs/10.1029/2012GL051001}, + Volume = {39}, + Year = {2012}, + Bdsk-Url-1 = {https://agupubs.onlinelibrary.wiley.com/doi/abs/10.1029/2012GL051001}, + Bdsk-Url-2 = {https://doi.org/10.1029/2012GL051001}} @conference{yudin_et_al_2018, - author = {Yudin, V. A and Akmaev, R. A. and Alpert, J. C. and Fuller-Rowell T. J., and Karol S. I.}, - Booktitle = {25th Conference on Numerical Weather Prediction}, - Date-Added = {2018-06-04 10:50:44 -0600}, - Date-Modified = {2018-06-04 10:54:39 -0600}, - Editor = {Am. Meteorol. Soc.}, - Title = {Gravity Wave Physics and Dynamics in the FV3-based Atmosphere Models Extended into the Mesosphere}, - Year = {2018}} + Author = {Yudin, V. A and Akmaev, R. A. and Alpert, J. C. and Fuller-Rowell T. J., and Karol S. I.}, + Booktitle = {25th Conference on Numerical Weather Prediction}, + Date-Added = {2018-06-04 10:50:44 -0600}, + Date-Modified = {2018-06-04 10:54:39 -0600}, + Editor = {Am. Meteorol. Soc.}, + Title = {Gravity Wave Physics and Dynamics in the FV3-based Atmosphere Models Extended into the Mesosphere}, + Year = {2018}} @article{hines_1997, - title = "Doppler-spread parameterization of gravity-wave momentum deposition in the middle atmosphere. Part 2: Broad and quasi monochromatic spectra, and implementation", - journal = "Journal of Atmospheric and Solar-Terrestrial Physics", - volume = "59", - number = "4", - pages = "387 - 400", - year = "1997", - issn = "1364-6826", - doi = "https://doi.org/10.1016/S1364-6826(96)00080-6", - url = "http://www.sciencedirect.com/science/article/pii/S1364682696000806", - author = "Colin O. Hines"} + Author = {Colin O. Hines}, + Doi = {https://doi.org/10.1016/S1364-6826(96)00080-6}, + Issn = {1364-6826}, + Journal = {Journal of Atmospheric and Solar-Terrestrial Physics}, + Number = {4}, + Pages = {387 - 400}, + Title = {Doppler-spread parameterization of gravity-wave momentum deposition in the middle atmosphere. Part 2: Broad and quasi monochromatic spectra, and implementation}, + Url = {http://www.sciencedirect.com/science/article/pii/S1364682696000806}, + Volume = {59}, + Year = {1997}, + Bdsk-Url-1 = {http://www.sciencedirect.com/science/article/pii/S1364682696000806}, + Bdsk-Url-2 = {https://doi.org/10.1016/S1364-6826(96)00080-6}} @article{alexander_and_dunkerton_1999, - author = {Alexander, M. J. and Dunkerton, T. J.}, - title = {A Spectral Parameterization of Mean-Flow Forcing due to Breaking Gravity Waves}, - journal = {Journal of the Atmospheric Sciences}, - volume = {56}, - number = {24}, - pages = {4167-4182}, - year = {1999}, - doi = {10.1175/1520-0469(1999)056<4167:ASPOMF>2.0.CO;2}, - URL = {https://doi.org/10.1175/1520-0469(1999)056<4167:ASPOMF>2.0.CO;2}, - eprint = {https://doi.org/10.1175/1520-0469(1999)056<4167:ASPOMF>2.0.CO;2}} + Author = {Alexander, M. J. and Dunkerton, T. J.}, + Doi = {10.1175/1520-0469(1999)056<4167:ASPOMF>2.0.CO;2}, + Eprint = {https://doi.org/10.1175/1520-0469(1999)056<4167:ASPOMF>2.0.CO;2}, + Journal = {Journal of the Atmospheric Sciences}, + Number = {24}, + Pages = {4167-4182}, + Title = {A Spectral Parameterization of Mean-Flow Forcing due to Breaking Gravity Waves}, + Url = {https://doi.org/10.1175/1520-0469(1999)056<4167:ASPOMF>2.0.CO;2}, + Volume = {56}, + Year = {1999}, + Bdsk-Url-1 = {https://doi.org/10.1175/1520-0469(1999)056%3C4167:ASPOMF%3E2.0.CO;2}} @article{scinocca_2003, - author = {Scinocca, John F.}, - title = {An Accurate Spectral Nonorographic Gravity Wave Drag Parameterization for General Circulation Models}, - journal = {Journal of the Atmospheric Sciences}, - volume = {60}, - number = {4}, - pages = {667-682}, - year = {2003}, - doi = {10.1175/1520-0469(2003)060<0667:AASNGW>2.0.CO;2}, - URL = {https://doi.org/10.1175/1520-0469(2003)060<0667:AASNGW>2.0.CO;2}, - eprint = {https://doi.org/10.1175/1520-0469(2003)060<0667:AASNGW>2.0.CO;2}} + Author = {Scinocca, John F.}, + Doi = {10.1175/1520-0469(2003)060<0667:AASNGW>2.0.CO;2}, + Eprint = {https://doi.org/10.1175/1520-0469(2003)060<0667:AASNGW>2.0.CO;2}, + Journal = {Journal of the Atmospheric Sciences}, + Number = {4}, + Pages = {667-682}, + Title = {An Accurate Spectral Nonorographic Gravity Wave Drag Parameterization for General Circulation Models}, + Url = {https://doi.org/10.1175/1520-0469(2003)060<0667:AASNGW>2.0.CO;2}, + Volume = {60}, + Year = {2003}, + Bdsk-Url-1 = {https://doi.org/10.1175/1520-0469(2003)060%3C0667:AASNGW%3E2.0.CO;2}} @article{shaw_and_shepherd_2009, - author = {Shaw, Tiffany A. and Shepherd, Theodore G.}, - title = {A Theoretical Framework for Energy and Momentum Consistency in Subgrid-Scale Parameterization for Climate Models}, - journal = {Journal of the Atmospheric Sciences}, - volume = {66}, - number = {10}, - pages = {3095-3114}, - year = {2009}, - doi = {10.1175/2009JAS3051.1}, - URL = {https://doi.org/10.1175/2009JAS3051.1}, - eprint = {https://doi.org/10.1175/2009JAS3051.1}} - -@Article{molod_et_al_2015, - AUTHOR = {Molod, A. and Takacs, L. and Suarez, M. and Bacmeister, J.}, - TITLE = {Development of the GEOS-5 atmospheric general circulation model: evolution from MERRA to MERRA2}, - JOURNAL = {Geoscientific Model Development}, - VOLUME = {8}, - YEAR = {2015}, - NUMBER = {5}, - PAGES = {1339--1356}, - URL = {https://www.geosci-model-dev.net/8/1339/2015/}, - DOI = {10.5194/gmd-8-1339-2015}} + Author = {Shaw, Tiffany A. and Shepherd, Theodore G.}, + Doi = {10.1175/2009JAS3051.1}, + Eprint = {https://doi.org/10.1175/2009JAS3051.1}, + Journal = {Journal of the Atmospheric Sciences}, + Number = {10}, + Pages = {3095-3114}, + Title = {A Theoretical Framework for Energy and Momentum Consistency in Subgrid-Scale Parameterization for Climate Models}, + Url = {https://doi.org/10.1175/2009JAS3051.1}, + Volume = {66}, + Year = {2009}, + Bdsk-Url-1 = {https://doi.org/10.1175/2009JAS3051.1}} + +@article{molod_et_al_2015, + Author = {Molod, A. and Takacs, L. and Suarez, M. and Bacmeister, J.}, + Doi = {10.5194/gmd-8-1339-2015}, + Journal = {Geoscientific Model Development}, + Number = {5}, + Pages = {1339--1356}, + Title = {Development of the GEOS-5 atmospheric general circulation model: evolution from MERRA to MERRA2}, + Url = {https://www.geosci-model-dev.net/8/1339/2015/}, + Volume = {8}, + Year = {2015}, + Bdsk-Url-1 = {https://www.geosci-model-dev.net/8/1339/2015/}, + Bdsk-Url-2 = {https://doi.org/10.5194/gmd-8-1339-2015}} @article{richter_et_al_2010, - author = {Richter, Jadwiga H. and Sassi, Fabrizio and Garcia, Rolando R.}, - title = {Toward a Physically Based Gravity Wave Source Parameterization in a General Circulation Model}, - journal = {Journal of the Atmospheric Sciences}, - volume = {67}, - number = {1}, - pages = {136-156}, - year = {2010}, - doi = {10.1175/2009JAS3112.1}, - URL = {https://doi.org/10.1175/2009JAS3112.1}, - eprint = {https://doi.org/10.1175/2009JAS3112.1}} + Author = {Richter, Jadwiga H. and Sassi, Fabrizio and Garcia, Rolando R.}, + Doi = {10.1175/2009JAS3112.1}, + Eprint = {https://doi.org/10.1175/2009JAS3112.1}, + Journal = {Journal of the Atmospheric Sciences}, + Number = {1}, + Pages = {136-156}, + Title = {Toward a Physically Based Gravity Wave Source Parameterization in a General Circulation Model}, + Url = {https://doi.org/10.1175/2009JAS3112.1}, + Volume = {67}, + Year = {2010}, + Bdsk-Url-1 = {https://doi.org/10.1175/2009JAS3112.1}} @article{richter_et_al_2014, - author = {Richter, Jadwiga H. and Solomon, Abraham and Bacmeister, Julio T.}, - title = {Effects of vertical resolution and nonorographic gravity wave drag on the simulated climate in the Community Atmosphere Model, version 5}, - journal = {Journal of Advances in Modeling Earth Systems}, - volume = {6}, - number = {2}, - pages = {357-383}, - keywords = {climate modeling, vertical resolution, modeling, climate, global circulation model, general circulation model}, - doi = {10.1002/2013MS000303}, - url = {https://agupubs.onlinelibrary.wiley.com/doi/abs/10.1002/2013MS000303}, - eprint = {https://agupubs.onlinelibrary.wiley.com/doi/pdf/10.1002/2013MS000303}, - year = {2014}} + Author = {Richter, Jadwiga H. and Solomon, Abraham and Bacmeister, Julio T.}, + Doi = {10.1002/2013MS000303}, + Eprint = {https://agupubs.onlinelibrary.wiley.com/doi/pdf/10.1002/2013MS000303}, + Journal = {Journal of Advances in Modeling Earth Systems}, + Keywords = {climate modeling, vertical resolution, modeling, climate, global circulation model, general circulation model}, + Number = {2}, + Pages = {357-383}, + Title = {Effects of vertical resolution and nonorographic gravity wave drag on the simulated climate in the Community Atmosphere Model, version 5}, + Url = {https://agupubs.onlinelibrary.wiley.com/doi/abs/10.1002/2013MS000303}, + Volume = {6}, + Year = {2014}, + Bdsk-Url-1 = {https://agupubs.onlinelibrary.wiley.com/doi/abs/10.1002/2013MS000303}, + Bdsk-Url-2 = {https://doi.org/10.1002/2013MS000303}} @article{gelaro_et_al_2017, - author = {Gelaro, et al.}, - title = {The Modern-Era Retrospective Analysis for Research and Applications, Version 2 (MERRA-2)}, - journal = {Journal of Climate}, - volume = {30}, - number = {14}, - pages = {5419-5454}, - year = {2017}, - doi = {10.1175/JCLI-D-16-0758.1}, - URL = {https://doi.org/10.1175/JCLI-D-16-0758.1}, - eprint = {https://doi.org/10.1175/JCLI-D-16-0758.1}} + Author = {Gelaro, et al.}, + Doi = {10.1175/JCLI-D-16-0758.1}, + Eprint = {https://doi.org/10.1175/JCLI-D-16-0758.1}, + Journal = {Journal of Climate}, + Number = {14}, + Pages = {5419-5454}, + Title = {The Modern-Era Retrospective Analysis for Research and Applications, Version 2 (MERRA-2)}, + Url = {https://doi.org/10.1175/JCLI-D-16-0758.1}, + Volume = {30}, + Year = {2017}, + Bdsk-Url-1 = {https://doi.org/10.1175/JCLI-D-16-0758.1}} @article{garcia_et_al_2007, - author = {Garcia, R. R. and Marsh, D. R. and Kinnison, D. E. and Boville, B. A. and Sassi, F.}, - title = {Simulation of secular trends in the middle atmosphere, 1950–2003}, - journal = {Journal of Geophysical Research: Atmospheres}, - volume = {112}, - number = {D9}, - pages = {}, - keywords = {global change, ozone depletion, water vapor trends, temperature trends}, - doi = {10.1029/2006JD007485}, - url = {https://agupubs.onlinelibrary.wiley.com/doi/abs/10.1029/2006JD007485}, - eprint = {https://agupubs.onlinelibrary.wiley.com/doi/pdf/10.1029/2006JD007485}, - year = {2007}} + Author = {Garcia, R. R. and Marsh, D. R. and Kinnison, D. E. and Boville, B. A. and Sassi, F.}, + Doi = {10.1029/2006JD007485}, + Eprint = {https://agupubs.onlinelibrary.wiley.com/doi/pdf/10.1029/2006JD007485}, + Journal = {Journal of Geophysical Research: Atmospheres}, + Keywords = {global change, ozone depletion, water vapor trends, temperature trends}, + Number = {D9}, + Title = {Simulation of secular trends in the middle atmosphere, 1950--2003}, + Url = {https://agupubs.onlinelibrary.wiley.com/doi/abs/10.1029/2006JD007485}, + Volume = {112}, + Year = {2007}, + Bdsk-Url-1 = {https://agupubs.onlinelibrary.wiley.com/doi/abs/10.1029/2006JD007485}, + Bdsk-Url-2 = {https://doi.org/10.1029/2006JD007485}} @article{eckermann_et_al_2009, - title = "High-altitude data assimilation system experiments for the northern summer mesosphere season of 2007", - journal = "Journal of Atmospheric and Solar-Terrestrial Physics", - volume = "71", - number = "3", - pages = "531 - 551", - year = "2009", - note = "Global Perspectives on the Aeronomy of the Summer Mesopause Region", - issn = "1364-6826", - doi = "https://doi.org/10.1016/j.jastp.2008.09.036", - url = "http://www.sciencedirect.com/science/article/pii/S1364682608002575", - author = "Stephen D. Eckermann and Karl W. Hoppel and Lawrence Coy and John P. McCormack and David E. Siskind and Kim Nielsen and Andrew Kochenash and Michael H. Stevens and Christoph R. Englert and Werner Singer and Mark Hervig", - keywords = "Data assimilation, Polar mesospheric cloud, Tide, Planetary wave, Mesosphere",} + Author = {Stephen D. Eckermann and Karl W. Hoppel and Lawrence Coy and John P. McCormack and David E. Siskind and Kim Nielsen and Andrew Kochenash and Michael H. Stevens and Christoph R. Englert and Werner Singer and Mark Hervig}, + Doi = {https://doi.org/10.1016/j.jastp.2008.09.036}, + Issn = {1364-6826}, + Journal = {Journal of Atmospheric and Solar-Terrestrial Physics}, + Keywords = {Data assimilation, Polar mesospheric cloud, Tide, Planetary wave, Mesosphere}, + Note = {Global Perspectives on the Aeronomy of the Summer Mesopause Region}, + Number = {3}, + Pages = {531 - 551}, + Title = {High-altitude data assimilation system experiments for the northern summer mesosphere season of 2007}, + Url = {http://www.sciencedirect.com/science/article/pii/S1364682608002575}, + Volume = {71}, + Year = {2009}, + Bdsk-Url-1 = {http://www.sciencedirect.com/science/article/pii/S1364682608002575}, + Bdsk-Url-2 = {https://doi.org/10.1016/j.jastp.2008.09.036}} @inproceedings{alpert_et_al_2019, - title={Atmospheric Gravity Wave Sources Correlated with Resolved-scale GW Activity and Sub-grid Scale Parameterization in the FV3gfs Model}, - author={Alpert, Jordan C and Yudin, Valery A and Strobach, Edward}, - booktitle={AGU Fall Meeting 2019}, - year={2019}, - organization={AGU}} - -@Article{ern_et_al_2018, - AUTHOR = {Ern, M. and Trinh, Q. T. and Preusse, P. and Gille, J. C. and Mlynczak, M. G. and Russell III, J. M. and Riese, M.}, - TITLE = {GRACILE: a comprehensive climatology of atmospheric gravity wave parameters based on satellite limb soundings}, - JOURNAL = {Earth System Science Data}, - VOLUME = {10}, - YEAR = {2018}, - NUMBER = {2}, - PAGES = {857--892}, - URL = {https://www.earth-syst-sci-data.net/10/857/2018/}, - DOI = {10.5194/essd-10-857-2018}} + Author = {Alpert, Jordan C and Yudin, Valery A and Strobach, Edward}, + Booktitle = {AGU Fall Meeting 2019}, + Organization = {AGU}, + Title = {Atmospheric Gravity Wave Sources Correlated with Resolved-scale GW Activity and Sub-grid Scale Parameterization in the FV3gfs Model}, + Year = {2019}} + +@article{ern_et_al_2018, + Author = {Ern, M. and Trinh, Q. T. and Preusse, P. and Gille, J. C. and Mlynczak, M. G. and Russell III, J. M. and Riese, M.}, + Doi = {10.5194/essd-10-857-2018}, + Journal = {Earth System Science Data}, + Number = {2}, + Pages = {857--892}, + Title = {GRACILE: a comprehensive climatology of atmospheric gravity wave parameters based on satellite limb soundings}, + Url = {https://www.earth-syst-sci-data.net/10/857/2018/}, + Volume = {10}, + Year = {2018}, + Bdsk-Url-1 = {https://www.earth-syst-sci-data.net/10/857/2018/}, + Bdsk-Url-2 = {https://doi.org/10.5194/essd-10-857-2018}} @inproceedings{yudin_et_al_2019, - title={Longitudinal Variability of Wave Dynamics in Weather Models Extended into the Mesosphere and Thermosphere}, - author={Yudin V.A. , S. I. Karol, R.A. Akmaev, T. Fuller-Rowell, D. Kleist, A. Kubaryk, and C. Thompson}, - booktitle={Space Weather Workshop}, - year={2019},} + Author = {Yudin V.A. , S. I. Karol, R.A. Akmaev, T. Fuller-Rowell, D. Kleist, A. Kubaryk, and C. Thompson}, + Booktitle = {Space Weather Workshop}, + Title = {Longitudinal Variability of Wave Dynamics in Weather Models Extended into the Mesosphere and Thermosphere}, + Year = {2019}} diff --git a/physics/docs/pdftxt/HWRF_FAMP.txt b/physics/docs/pdftxt/HWRF_FAMP.txt new file mode 100644 index 000000000..4fb555d84 --- /dev/null +++ b/physics/docs/pdftxt/HWRF_FAMP.txt @@ -0,0 +1,91 @@ +/** +\page HWRF_famp HWRF Ferrier-Aligo (FA) Microphysics Scheme +\section des_famp Description + +The Ferrier-Aligo (FA) microphysics (Aligo et al. 2018 \cite aligo_et_al_2018) is a single +moment scheme predicting mass mixing ratios of rain water (\f$q_r\f$), cloud water (\f$q_c\f$), +cloud ice (\f$q_i\f$), and snow-graupel (\f$q_s\f$). The FA scheme is currently used operationally +in the North American Mesoscale Forecast System (NAM; including the parent 12-km domain, the 3-km +NAM nests, and the 1.5km fire weather nest), the Hurricane Weather Research and Forecasting Model (HWRF), +the Hurricanes in a Multi-scale Ocean-coupled Non-hydrostatic Model (HMON), and the High-Resolution +Window (HiResW) Non-dydrostatic Multiscale Model on the B grid (NMMB). The FA scheme advects each +species separately in the NAM nests, and advects the total condensate in the 12-km parent NAM,HiResW NMMB, +HWRF, and HMON. + +Unique to the FA scheme is the calculation of a diagnostic array called the "rime factor" (RF), which +represents the degree of riming onto snow-graupel, and takes into account the temperature of the ice particle, +the impact velocity of the cloud droplet on the ice particle, and the size of the cloud droplet. For all +practical purposes, one can categorize precipitation ice as snow, graupel, or hail, similar to the ice +species predicted in other microphysical schemes based on the value of the RF. For example, an RF = 1 +represents unrimed snow; lightly rimed snow occurs when 1 < RF < 2; heavily rimed snow when 2< RF \f$\leq\f$ 5; +graupel when 5 < RF < 10; and frozen drops or hail when RF \f$geqslant\f$ 10. In reality, the RF knows +no arbitrary cutoff between different ice categories, and the categorizations above are somewhat subjective. +Figure 1 is a schematic illustration of the FA scheme processes and each process is described in Table 1. + +\image html FA_MP_schematic.png "Figure 1: Schematic illustration of FA scheme processes with a description of each process in Table 1." width=10cm + +Table 1. List of microphysical processes and their description. All processes are in units of \f$kg kg^{-1}\f$. +\tableofcontents +| Microphysical Source/Sinks | Description | +|----------------------------------|--------------------------------------------------------| +| PIHOM | Homogeneous freezing of cloud water to ice. | +| PIDEP | Net ice deposition (> 0) or sublimation (< 0). | +| PINIT | Initiation (nucleation) of cloud ice. | +| PIACW | Cloud water collection by precipitation ice. | +| PIACWI | Cloud water riming onto precipitation ice at < 0 | +| PIACR | Freezing of supercooled rain to precipitation ice. | +| PIMLT | Melting of precipitation ice to form rain. | +| PICND | Condensation onto wet, melting ice. | +| PIEVP | Evaporation from wet, melting ice. | +| PCOND | Net cloud water condensation (> 0) or evaporation (< 0)| +| PRAUT | Droplet self-collection (Autoconversion) to form rain. | +| PRACW | Cloud water collection (Accretion) by rain. | +| PREVP | Rain evaporation. | +| PIACWR | Accreted cloud water shed to form rain at > 0 | +\tableofcontents + +Owing to operational computation constraints, and unique to the FA scheme, the sedimentation process +does not use finite differencing of precipitation fluxes in the vertical in order to circumvent the +requirement that small time steps be used in order to maintain numerical stability, particularly since +the vertical resolution often increases dramatically near the ground. The algorithm is instead based upon +a partitioning of precipitation already present in the grid box at the beginning of the time step and the +precipitation entering the grid box from above at the end of the time step. A more detailed description +of the sedimentation algorithm can be found in Aligo et al. (2018, appendix D). + +An algorithm was developed in FA to improve stratiform rainfall by allowing the rain intercept parameter, +\f$N_{or}\f$, to vary with height and the mean drop diameter to be fixed below melting layers. This is +different from other single-moment microphysics schemes (WSM6 and Lin) that assume a constant value for +\f$N_{or}\f$. The algorithm in the FA scheme, simular to what is done in the Thompson scheme \cite Thompson_2008, +assumes that a snow-graupel particle about to enter the melting layer from above has the same mean mass +as a drop formed from melting below the melting layer. The mean drop diameter calculated below the melting layer +acts as the lower limit for the mean drop sizes as the rain descends to lower levels. This algorithm is only +active if 1) the snow-graupel density above the melting level (i.e.\f$T_c<0^{o}C\f$) is \f$<225kg m^{-3}\f$ +(which corresponds to an RF=10), 2) the rain content does not exceed \f$1gm^{-3}\f$, and 3) there is vertical +continuity of the rain at lower levels with the rain that formed from melting ice. + +The FA scheme also uses a drizzle parameterization in order to minimize the spatial extent of light (<20dBZ) +reflectivity echoes that developed at the top of moist boundary layers, over the Southeastern U.S., within +warm conveyor belts, and over ocean areas covered by stratocumulus in the NMMB. The drizzle parameterization +uses a variable \f$N_{or}\f$ following Westbrook et al. (2010) \cite westbrook_et_al_2010, and approach +conceptually similar to that described in Thompson et al.(2008) \cite Thompson_2008 for drizzle. Figure 2a +shows an example of drizzle forming in a single low-level liquid cloud layer above \f$0^oC\f$, in which the +smaller, more numerous drizzle drops produce lower radar reflectivities, compared to rain, with \f$N_{or}=8\times10^6m\f$, +for example. For multiple cloud layers, drizzle from low clouds must be completely disconnected from rain formed +aloft from melting ice, such that a rain-free layer must seperate any stratiform rain layer aloft from drizzle formed +within liquid clouds at lower levels.Supercooled drizzle is also allowed to form from warm-rain processes below \f$0^oC\f$. +The quantity \f$N_{or}\f$ is modified only when the rainwater content is \f$< 0.5 gm^{-3}\f$, such that \f$N_{or}\f$ is +assumed to vary (red line in Fig.2b) with rain content (\f$\rho_\alpha\times q_r\f$) as + +\image html FA_NOR_EQ.png " " width=10cm + +\image html FA_DRI.png " Figure 2. (a) Schematic illustration of the drizzle parameterization for a single cloud layer in which drizzle forms from a low-level liquid water cloud at > 0C only when it is completely disconnected from rain formed from melting ice aloft. (b) The scatterplot from Westbrook at al.(2010) shows retrieved rain rate (R,mm/h) vs the mornalized rain intercept paramter (Nl in 1/m^4, where Nl=Nor for exponential distributions) based on lidar observations of drizzle. The different values of Nor described in (1) are overlaid on the figure with the red line showing the variation of Nor as a funciton of rain rate for rain contents between 0.02 and 0.5 g/m^3. " width=10cm + + +\section intra_famp Intraphysics Communication +\ref arg_table_mp_fer_hires_run + +\section gen_famp General Algorithm +\ref gen_al_famp + + +*/ diff --git a/physics/module_MP_FER_HIRES.F90 b/physics/module_MP_FER_HIRES.F90 index 02a09481b..f45ffa04f 100644 --- a/physics/module_MP_FER_HIRES.F90 +++ b/physics/module_MP_FER_HIRES.F90 @@ -1,9 +1,9 @@ !>\file module_MP_FER_HIRES.F90 !! "Modified" fer_hires microphysics - 11 July 2016 version !! -! (1) Ice nucleation: Fletcher (1962) replaces Meyers et al. (1992) -! (2) Cloud ice is a simple function of the number concentration from (1), and it -! is no longer a fractional function of the large ice. Thus, the FLARGE & +!! (1) Ice nucleation: Fletcher (1962) replaces Meyers et al. (1992) +!! (2) Cloud ice is a simple function of the number concentration from (1), and it +!! is no longer a fractional function of the large ice. Thus, the FLARGE & ! FSMALL parameters are no longer used. ! (3) T_ICE_init=-12 deg C provides a slight delay in the initial onset of ice. ! (4) NLImax is a function of rime factor (RF) and temperature. @@ -242,37 +242,41 @@ MODULE MODULE_MP_FER_HIRES !! version, and QRIMEF is only in the advected version. The innards !! are all the same. SUBROUTINE FER_HIRES (DT,RHgrd, & - & dz8w,rho_phy,p_phy,pi_phy,th_phy,t_phy, & + & prsi,p_phy,t_phy, & & q,qt, & - & LOWLYR,SR, & + & LOWLYR,SR,TRAIN_PHY, & & F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY, & & QC,QR,QS, & & RAINNC,RAINNCV, & & threads, & - & ims,ime, jms,jme, lm, & + & ims,ime, lm, & & d_ss, & & refl_10cm,DX1 ) !----------------------------------------------------------------------- IMPLICIT NONE !----------------------------------------------------------------------- - INTEGER,INTENT(IN) :: D_SS,IMS,IME,JMS,JME,LM,DX1 + INTEGER,INTENT(IN) :: D_SS,IMS,IME,LM,DX1 REAL, INTENT(IN) :: DT,RHgrd INTEGER, INTENT(IN) :: THREADS - REAL, INTENT(IN), DIMENSION(ims:ime, jms:jme, lm):: & - & dz8w,p_phy,pi_phy,rho_phy - REAL, INTENT(INOUT), DIMENSION(ims:ime, jms:jme, lm):: & - & th_phy,t_phy,q,qt - REAL, INTENT(INOUT), DIMENSION(ims:ime,jms:jme, lm ) :: & + REAL, INTENT(IN), DIMENSION(ims:ime, lm+1):: & + & prsi + REAL, INTENT(IN), DIMENSION(ims:ime, lm):: & + & p_phy + REAL, INTENT(INOUT), DIMENSION(ims:ime, lm):: & + & q,qt,t_phy + REAL, INTENT(INOUT), DIMENSION(ims:ime, lm ):: & !Aligo Oct 23,2019: dry mixing ratio for cloud species & qc,qr,qs - REAL, INTENT(INOUT), DIMENSION(ims:ime, jms:jme,lm) :: & + REAL, INTENT(INOUT), DIMENSION(ims:ime, lm) :: & & F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY - REAL, INTENT(OUT), DIMENSION(ims:ime, jms:jme,lm) :: & + REAL, INTENT(OUT), DIMENSION(ims:ime, lm) :: & & refl_10cm - REAL, INTENT(INOUT), DIMENSION(ims:ime,jms:jme) :: & + REAL, INTENT(INOUT), DIMENSION(ims:ime) :: & & RAINNC,RAINNCV - REAL, INTENT(OUT), DIMENSION(ims:ime,jms:jme):: SR + REAL, INTENT(OUT), DIMENSION(ims:ime):: SR + REAL, INTENT(OUT), DIMENSION( ims:ime, lm ) :: & + & TRAIN_PHY ! - INTEGER, DIMENSION( ims:ime, jms:jme ),INTENT(INOUT) :: LOWLYR + INTEGER, DIMENSION( ims:ime ),INTENT(INOUT) :: LOWLYR !----------------------------------------------------------------------- ! LOCAL VARS @@ -282,24 +286,22 @@ SUBROUTINE FER_HIRES (DT,RHgrd, & ! the microphysics scheme. Instead, they will be used by Eta precip ! assimilation. - REAL, DIMENSION( ims:ime, jms:jme,lm ) :: & - & TLATGS_PHY,TRAIN_PHY - REAL, DIMENSION(ims:ime,jms:jme):: APREC,PREC,ACPREC + REAL, DIMENSION(ims:ime):: APREC,PREC,ACPREC - INTEGER :: I,J,K,KK + INTEGER :: I,K,KK REAL :: wc !------------------------------------------------------------------------ ! For subroutine EGCP01COLUMN_hr !----------------------------------------------------------------------- INTEGER :: LSFC,I_index,J_index,L - INTEGER,DIMENSION(ims:ime,jms:jme) :: LMH + INTEGER,DIMENSION(ims:ime) :: LMH REAL :: TC,QI,QRdum,QW,Fice,Frain,DUM,ASNOW,ARAIN REAL,DIMENSION(lm) :: P_col,Q_col,T_col,WC_col, & RimeF_col,QI_col,QR_col,QW_col, THICK_col,DPCOL,pcond1d, & pidep1d,piacw1d,piacwi1d,piacwr1d,piacr1d,picnd1d,pievp1d, & pimlt1d,praut1d,pracw1d,prevp1d,pisub1d,pevap1d,DBZ_col, & NR_col,NS_col,vsnow1d,vrain11d,vrain21d,vci1d,NSmICE1d, & - INDEXS1d,INDEXR1d,RFlag1d,RHC_col + INDEXS1d,INDEXR1d,RFlag1d,RHC_col ! !----------------------------------------------------------------------- !********************************************************************** @@ -309,7 +311,7 @@ SUBROUTINE FER_HIRES (DT,RHgrd, & ! MZ: HWRF start !---------- !2015-03-30, recalculate some constants which may depend on phy time step - CALL MY_GROWTH_RATES_NMM_hr (DT) + CALL MY_GROWTH_RATES_NMM_hr (DT) !--- CIACW is used in calculating riming rates ! The assumed effective collection efficiency of cloud water rimed onto @@ -331,93 +333,79 @@ SUBROUTINE FER_HIRES (DT,RHgrd, & ! BRAUT=DT*1.1E10*BETA6/NCW - !write(*,*)'dt=',dt - !write(*,*)'pi=',pi - !write(*,*)'c1=',c1 - !write(*,*)'ciacw=',ciacw - !write(*,*)'ciacr=',ciacr - !write(*,*)'cracw=',cracw - !write(*,*)'araut=',araut - !write(*,*)'braut=',braut !! END OF adding, 2015-03-30 !----------- ! MZ: HWRF end ! - DO j = jms,jme DO i = ims,ime - ACPREC(i,j)=0. - APREC (i,j)=0. - PREC (i,j)=0. - SR (i,j)=0. + ACPREC(i)=0. + APREC (i)=0. + PREC (i)=0. + SR (i)=0. ENDDO + DO k = 1,lm DO i = ims,ime - TLATGS_PHY (i,j,k)=0. - TRAIN_PHY (i,j,k)=0. + TRAIN_PHY (i,k)=0. ENDDO ENDDO - ENDDO !----------------------------------------------------------------------- !-- Start of original driver for EGCP01COLUMN_hr !----------------------------------------------------------------------- ! - DO J=JMS,JME - DO I=IMS,IME - LSFC=LM-LOWLYR(I,J)+1 ! "L" of surface - DO K=1,LM - DPCOL(K)=RHO_PHY(I,J,K)*GRAV*dz8w(I,J,K) - ENDDO + DO I=IMS,IME + LSFC=LM-LOWLYR(I)+1 ! "L" of surface + DO K=1,LM + DPCOL(K)=prsi(I,K)-prsi(I,K+1) + ENDDO ! !--- Initialize column data (1D arrays) ! - L=LM + L=LM !-- qt = CWM, total condensate - IF (qt(I,J,L) .LE. EPSQ) qt(I,J,L)=EPSQ - F_ice_phy(I,J,L)=1. - F_rain_phy(I,J,L)=0. - F_RimeF_phy(I,J,L)=1. + IF (qt(I,L) .LE. EPSQ) qt(I,L)=EPSQ + F_ice_phy(I,L)=1. + F_rain_phy(I,L)=0. + F_RimeF_phy(I,L)=1. do L=LM,1,-1 -! -!--- Pressure (Pa) = (Psfc-Ptop)*(ETA/ETA_sfc)+Ptop -! - P_col(L)=P_phy(I,J,L) + P_col(L)=P_phy(I,L) ! !--- Layer thickness = RHO*DZ = -DP/G = (Psfc-Ptop)*D_ETA/(G*ETA_sfc) ! THICK_col(L)=DPCOL(L)*RGRAV - T_col(L)=T_phy(I,J,L) + T_col(L)=T_phy(I,L) TC=T_col(L)-T0C - Q_col(L)=max(EPSQ, q(I,J,L)) - IF (qt(I,J,L) .LE. EPSQ1) THEN + Q_col(L)=max(EPSQ, q(I,L)) + IF (qt(I,L) .LE. EPSQ1) THEN WC_col(L)=0. IF (TC .LT. T_ICE) THEN - F_ice_phy(I,J,L)=1. + F_ice_phy(I,L)=1. ELSE - F_ice_phy(I,J,L)=0. + F_ice_phy(I,L)=0. ENDIF - F_rain_phy(I,J,L)=0. - F_RimeF_phy(I,J,L)=1. + F_rain_phy(I,L)=0. + F_RimeF_phy(I,L)=1. ELSE - WC_col(L)=qt(I,J,L) + WC_col(L)=qt(I,L) !-- Debug 20120111 ! TC==TC will fail if NaN, preventing unnecessary error messages IF (WC_col(L)>QTwarn .AND. P_col(L)1 g/kg condensate in stratosphere; I,J,L,TC,P,QT=', & - I,J,L,TC,.01*P_col(L),1000.*WC_col(L) + WRITE(0,*) 'WARN4: >1 g/kg condensate in stratosphere; I,L,TC,P,QT=', & + I,L,TC,.01*P_col(L),1000.*WC_col(L) QTwarn=MAX(WC_col(L),10.*QTwarn) Pwarn=MIN(P_col(L),0.5*Pwarn) ENDIF !-- TC/=TC will pass if TC is NaN IF (WARN5 .AND. TC/=TC) THEN - WRITE(0,*) 'WARN5: NaN temperature; I,J,L,P=',I,J,L,.01*P_col(L) + WRITE(0,*) 'WARN5: NaN temperature; I,L,P=',I,L,.01*P_col(L) WARN5=.FALSE. ENDIF ENDIF - IF (T_ICE<=-100.) F_ice_phy(I,J,L)=0. + IF (T_ICE<=-100.) F_ice_phy(I,L)=0. ! ! ! !--- Determine composition of condensate in terms of ! ! cloud water, ice, & rain @@ -426,8 +414,8 @@ SUBROUTINE FER_HIRES (DT,RHgrd, & QI=0. QRdum=0. QW=0. - Fice=F_ice_phy(I,J,L) - Frain=F_rain_phy(I,J,L) + Fice=F_ice_phy(I,L) + Frain=F_rain_phy(I,L) ! IF (Fice .GE. 1.) THEN QI=WC @@ -447,8 +435,8 @@ SUBROUTINE FER_HIRES (DT,RHgrd, & QW=QW-QRdum ENDIF ENDIF - IF (QI .LE. 0.) F_RimeF_phy(I,J,L)=1. - RimeF_col(L)=F_RimeF_phy(I,J,L) ! (real) + IF (QI .LE. 0.) F_RimeF_phy(I,L)=1. + RimeF_col(L)=F_RimeF_phy(I,L) ! (real) QI_col(L)=QI QR_col(L)=QRdum QW_col(L)=QW @@ -469,8 +457,8 @@ SUBROUTINE FER_HIRES (DT,RHgrd, & !--- Perform the microphysical calculations in this column ! I_index=I - J_index=J - CALL EGCP01COLUMN_hr ( ARAIN, ASNOW, DT, RHC_col, & + J_index=1 + CALL EGCP01COLUMN_hr ( ARAIN, ASNOW, DT, RHC_col, & & I_index, J_index, LSFC, & & P_col, QI_col, QR_col, Q_col, QW_col, RimeF_col, T_col, & & THICK_col, WC_col,LM,pcond1d,pidep1d, & @@ -483,11 +471,10 @@ SUBROUTINE FER_HIRES (DT,RHgrd, & !--- Update storage arrays ! do L=LM,1,-1 - TRAIN_phy(I,J,L)=(T_col(L)-T_phy(I,J,L))/DT - TLATGS_phy(I,J,L)=T_col(L)-T_phy(I,J,L) - T_phy(I,J,L)=T_col(L) - q(I,J,L)=Q_col(L) - qt(I,J,L)=WC_col(L) + TRAIN_phy(I,L)=(T_col(L)-T_phy(I,L))/DT + T_phy(I,L)=T_col(L) + q(I,L)=Q_col(L) + qt(I,L)=WC_col(L) !---convert 1D source/sink terms to one 4D array !---d_ss is the total number of source/sink terms in the 4D mprates array !---if d_ss=1, only 1 source/sink term is used @@ -496,20 +483,20 @@ SUBROUTINE FER_HIRES (DT,RHgrd, & !--- REAL*4 array storage ! IF (QI_col(L) .LE. EPSQ) THEN - F_ice_phy(I,J,L)=0. - IF (T_col(L) .LT. T_ICEK) F_ice_phy(I,J,L)=1. - F_RimeF_phy(I,J,L)=1. + F_ice_phy(I,L)=0. + IF (T_col(L) .LT. T_ICEK) F_ice_phy(I,L)=1. + F_RimeF_phy(I,L)=1. ELSE - F_ice_phy(I,J,L)=MAX( 0., MIN(1., QI_col(L)/WC_col(L)) ) - F_RimeF_phy(I,J,L)=MAX(1., RimeF_col(L)) + F_ice_phy(I,L)=MAX( 0., MIN(1., QI_col(L)/WC_col(L)) ) + F_RimeF_phy(I,L)=MAX(1., RimeF_col(L)) ENDIF IF (QR_col(L) .LE. EPSQ) THEN DUM=0 ELSE DUM=QR_col(L)/(QR_col(L)+QW_col(L)) ENDIF - F_rain_phy(I,J,L)=DUM - REFL_10CM(I,J,L)=DBZ_col(L) !jul28 + F_rain_phy(I,L)=DUM + REFL_10CM(I,L)=DBZ_col(L) !jul28 ENDDO ! !--- Update accumulated precipitation statistics @@ -517,63 +504,57 @@ SUBROUTINE FER_HIRES (DT,RHgrd, & !--- Surface precipitation statistics; SR is fraction of surface ! precipitation (if >0) associated with snow ! - APREC(I,J)=(ARAIN+ASNOW)*RRHOL ! Accumulated surface precip (depth in m) !<--- Ying - PREC(I,J)=PREC(I,J)+APREC(I,J) - ACPREC(I,J)=ACPREC(I,J)+APREC(I,J) - IF(APREC(I,J) .LT. 1.E-8) THEN - SR(I,J)=0. + APREC(I)=(ARAIN+ASNOW)*RRHOL ! Accumulated surface precip (depth in m) !<--- Ying + PREC(I)=PREC(I)+APREC(I) + ACPREC(I)=ACPREC(I)+APREC(I) + IF(APREC(I) .LT. 1.E-8) THEN + SR(I)=0. ELSE - SR(I,J)=RRHOL*ASNOW/APREC(I,J) + SR(I)=RRHOL*ASNOW/APREC(I) ENDIF ! !####################################################################### !####################################################################### ! enddo ! End "I" loop - enddo ! End "J" loop ! !----------------------------------------------------------------------- !-- End of original driver for EGCP01COLUMN_hr !----------------------------------------------------------------------- ! - DO j = jms,jme do k = lm, 1, -1 DO i = ims,ime - th_phy(i,j,k) = t_phy(i,j,k)/pi_phy(i,j,k) - WC=qt(I,J,K) - QS(I,J,K)=0. - QR(I,J,K)=0. - QC(I,J,K)=0. -! - IF(F_ICE_PHY(I,J,K)>=1.)THEN - QS(I,J,K)=WC - ELSEIF(F_ICE_PHY(I,J,K)<=0.)THEN - QC(I,J,K)=WC + WC=qt(I,K) + QS(I,K)=0. + QR(I,K)=0. + QC(I,K)=0. +! + IF(F_ICE_PHY(I,K)>=1.)THEN + QS(I,K)=WC + ELSEIF(F_ICE_PHY(I,K)<=0.)THEN + QC(I,K)=WC ELSE - QS(I,J,K)=F_ICE_PHY(I,J,K)*WC - QC(I,J,K)=WC-QS(I,J,K) + QS(I,K)=F_ICE_PHY(I,K)*WC + QC(I,K)=WC-QS(I,K) ENDIF ! - IF(QC(I,J,K)>0..AND.F_RAIN_PHY(I,J,K)>0.)THEN - IF(F_RAIN_PHY(I,J,K).GE.1.)THEN - QR(I,J,K)=QC(I,J,K) - QC(I,J,K)=0. + IF(QC(I,K)>0..AND.F_RAIN_PHY(I,K)>0.)THEN + IF(F_RAIN_PHY(I,K).GE.1.)THEN + QR(I,K)=QC(I,K) + QC(I,K)=0. ELSE - QR(I,J,K)=F_RAIN_PHY(I,J,K)*QC(I,J,K) - QC(I,J,K)=QC(I,J,K)-QR(I,J,K) + QR(I,K)=F_RAIN_PHY(I,K)*QC(I,K) + QC(I,K)=QC(I,K)-QR(I,K) ENDIF ENDIF ENDDO !- i ENDDO !- k - ENDDO !- j ! !- Update rain (convert from m to kg/m**2, which is also equivalent to mm depth) ! - DO j=jms,jme DO i=ims,ime - RAINNC(i,j)=APREC(i,j)*1000.+RAINNC(i,j) - RAINNCV(i,j)=APREC(i,j)*1000. - ENDDO + RAINNC(i)=APREC(i)*1000.+RAINNC(i) + RAINNCV(i)=APREC(i)*1000. ENDDO ! !----------------------------------------------------------------------- @@ -639,16 +620,38 @@ END SUBROUTINE FER_HIRES !!\param qi_col vertical column of model ice mixing ratio (kg/kg) !!\param qr_col vertical column of model rain ratio (kg/kg) !!\param q_col vertical column of model water vapor specific humidity (kg/kg) -!!\param qw_col -!!\param rimef_col -!!\param t_col -!!\param thick_col -!!\param wc_col -!!\param lm -!!\param pcond1d -!!\param pidep1d -!!\param piacw1d -!!\param piacwi1d +!!\param qw_col vertical column of model cloud water mixing ratio (kg/kg) +!!\param rimef_col vertical column of rime factor for ice in model (ratio, defined below) +!!\param t_col vertical column of model temperature (deg K) +!!\param thick_col vertical column of model mass thickness (density*height increment) +!!\param wc_col vertical column of model mixing ratio of total condensate (kg/kg) +!!\param lm vertical dimension +!!\param pcond1d net cloud water condensation (>0) or evaporation (<0) (kg/kg) +!!\param pidep1d net ice deposition (>0) or sublimation (<0) (kg/kg) +!!\param piacw1d cloud water collection by precipitation ice (kg/kg) +!!\param piacwi1d cloud water riming onto precipitation ice at <0 (kg/kg) +!!\param piacwr1d accreted cloud water shed to form rain at >0 (kg/kg) +!!\param piacr1d freezing of supercooled rain to precipitation ice (kg/kg) +!!\param picnd1d condensation onto wet, melting ice (kg/kg) +!!\param pievp1d evaporation from wet, melting ice (kg/kg) +!!\param pimlt1d melting of precipitation ice to form rain (kg/kg) +!!\param praut1d droplet self_collection (autoconversion) to form rain (kg/kg) +!!\param pracw1d cloud water collection (accretion) by rain (kg/kg) +!!\param prevp1d rain evaporation (kg/kg) +!!\param pisub1d +!!\param pevap1d +!!\param DBZ_col vertical column of radar reflectivity (dBZ) +!!\param NR_col vertical column of rain number concentration (m^-3) +!!\param NS_col vertical column of snow number concentration (m^-3) +!!\param vsnow1d fall speed of rimed snow w/ air resistance correction +!!\param vrain11d fall speed of rain into grid from above (m/s) +!!\param vrain21d fall speed of rain out of grid box to the level below (m/s) +!!\param vci1d Fall speed of 50-micron ice crystals w/ air resistance correction +!!\param NSmICE1d number concentration of small ice crystals at current level +!!\param INDEXS1d +!!\param INDEXR1d +!!\param RFlag1d +!!\param DX1 SUBROUTINE EGCP01COLUMN_hr ( ARAIN, ASNOW, DTPH, RHC_col, & & I_index, J_index, LSFC, & & P_col, QI_col, QR_col, Q_col, QW_col, RimeF_col, T_col, & diff --git a/physics/mp_fer_hires.F90 b/physics/mp_fer_hires.F90 index 95e521141..19cfa117a 100644 --- a/physics/mp_fer_hires.F90 +++ b/physics/mp_fer_hires.F90 @@ -1,5 +1,5 @@ !>\file mp_fer_hires.F90 -!! This file contains +!! This file contains the Ferrier-Aligo microphysics scheme driver. ! module mp_fer_hires @@ -113,7 +113,7 @@ subroutine mp_fer_hires_init(ncol, nlev, dtp, imp_physics, & end subroutine mp_fer_hires_init -!>\defgroup hafs_famp HAFS Ferrier-Aligo Cloud Microphysics Scheme +!>\defgroup hafs_famp HWRF Ferrier-Aligo Microphysics Scheme !> This is the CCPP-compliant FER_HIRES driver module. !> \section arg_table_mp_fer_hires_run Argument Table !! \htmlinclude mp_fer_hires_run.html @@ -124,9 +124,8 @@ SUBROUTINE mp_fer_hires_run(NCOL, NLEV, DT ,SPEC_ADV & ,T,Q,CWM & ,TRAIN,SR & ,F_ICE,F_RAIN,F_RIMEF & - ,QC,QR,QI,QG & ! wet mixing ratio - !,qc_m,qi_m,qr_m & - ,PREC &!,ACPREC -MZ:not used + ,QC,QR,QI,QG & + ,PREC & ,mpirank, mpiroot, threads & ,refl_10cm & ,RHGRD,dx & @@ -171,7 +170,6 @@ SUBROUTINE mp_fer_hires_run(NCOL, NLEV, DT ,SPEC_ADV & real(kind_phys), intent(inout) :: qg(1:ncol,1:nlev) ! QRIMEF real(kind_phys), intent(inout) :: prec(1:ncol) -! real(kind_phys) :: acprec(1:ncol) !MZ: change to local real(kind_phys), intent(inout) :: refl_10cm(1:ncol,1:nlev) real(kind_phys), intent(in ) :: rhgrd real(kind_phys), intent(in ) :: dx(1:ncol) @@ -185,27 +183,19 @@ SUBROUTINE mp_fer_hires_run(NCOL, NLEV, DT ,SPEC_ADV & integer :: I,J,K,N integer :: lowlyr(1:ncol) integer :: dx1 - !real(kind_phys) :: mprates(1:ncol,1:nlev,d_ss) - real(kind_phys) :: DTPHS,PCPCOL,RDTPHS,TNEW + real(kind_phys) :: PCPCOL real(kind_phys) :: ql(1:nlev),tl(1:nlev) real(kind_phys) :: rainnc(1:ncol),rainncv(1:ncol) real(kind_phys) :: snownc(1:ncol),snowncv(1:ncol) real(kind_phys) :: graupelncv(1:ncol) - real(kind_phys) :: dz(1:ncol,1:nlev) - real(kind_phys) :: pi_phy(1:ncol,1:nlev) - real(kind_phys) :: rr(1:ncol,1:nlev) - real(kind_phys) :: th_phy(1:ncol,1:nlev) - real(kind_phys) :: R_G, CAPPA + real(kind_phys) :: train_phy(1:ncol,1:nlev) ! Dimension - integer :: ims, ime, jms, jme, lm + integer :: ims, ime, lm !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- - R_G=1./G - CAPPA=R_D/CP - ! Initialize the CCPP error handling variables errmsg = '' errflg = 0 @@ -217,18 +207,9 @@ SUBROUTINE mp_fer_hires_run(NCOL, NLEV, DT ,SPEC_ADV & return end if - -!ZM NTSD=ITIMESTEP -!ZM presume nphs=1 DTPHS=NPHS*DT - DTPHS=DT - RDTPHS=1./DTPHS -!ZM AVRAIN=AVRAIN+1. - ! Set internal dimensions ims = 1 ime = ncol - jms = 1 - jme = 1 lm = nlev ! Use the dx of the 1st i point to set an integer value of dx to be used for @@ -266,18 +247,8 @@ SUBROUTINE mp_fer_hires_run(NCOL, NLEV, DT ,SPEC_ADV & !*** FILL THE SINGLE-COLUMN INPUT !----------------------------------------------------------------------- ! - DO K=LM,1,-1 ! We are moving down from the top in the flipped arrays + DO K=LM,1,-1 !mz* We are moving down from the top in the flipped arrays -! -! TL(K)=T(I,K) -! QL(K)=AMAX1(Q(I,K),EPSQ) -! - RR(I,K)=P_PHY(I,K)/(R_D*T(I,K)*(P608*AMAX1(Q(I,K),EPSQ)+1.)) - PI_PHY(I,K)=(P_PHY(I,K)*1.E-5)**CAPPA - TH_PHY(I,K)=T(I,K)/PI_PHY(I,K) - DZ(I,K)=(PRSI(I,K)-PRSI(I,K+1))*R_G/RR(I,K) - -! !*** CALL MICROPHYSICS !MZ* in HWRF @@ -289,7 +260,7 @@ SUBROUTINE mp_fer_hires_run(NCOL, NLEV, DT ,SPEC_ADV & IF (T(I,K) < T_ICEK) F_ICE(I,K)=1. ELSE F_ICE(I,K)=MAX( 0., MIN(1., QI(I,K)/cwm(I,K) ) ) - F_RIMEF(I,K)=QG(I,K)/QI(I,K) + F_RIMEF(I,K)=QG(I,K)!/QI(I,K) ENDIF IF (QR(I,K) <= EPSQ) THEN F_RAIN(I,K)=0. @@ -297,38 +268,30 @@ SUBROUTINE mp_fer_hires_run(NCOL, NLEV, DT ,SPEC_ADV & F_RAIN(I,K)=QR(I,K)/(QR(I,K)+QC(I,K)) ENDIF - end do - enddo - -!--------------------------------------------------------------------- -!*** Update the rime factor array after 3d advection -!--------------------------------------------------------------------- -!MZ* in namphysics -! DO K=1,LM -! DO I=IMS,IME -! IF (QG(I,K)>EPSQ .AND. QI(I,K)>EPSQ) THEN -! F_RIMEF(I,K)=MIN(50.,MAX(1.,QG(I,K)/QI(I,K))) -! ELSE -! F_RIMEF(I,K)=1. -! ENDIF -! ENDDO -! ENDDO + ENDDO + ENDDO +!--------------------------------------------------------------------- +!aligo + cwm(i,k) = cwm(i,k)/(1.0_kind_phys-q(i,k)) + qr(i,k) = qr(i,k)/(1.0_kind_phys-q(i,k)) + qi(i,k) = qi(i,k)/(1.0_kind_phys-q(i,k)) + qc(i,k) = qc(i,k)/(1.0_kind_phys-q(i,k)) +!aligo !--------------------------------------------------------------------- CALL FER_HIRES( & - DT=dtphs,RHgrd=RHGRD & - ,DZ8W=dz,RHO_PHY=rr,P_PHY=p_phy,PI_PHY=pi_phy & - ,TH_PHY=th_phy,T_PHY=t & + DT=DT,RHgrd=RHGRD & + ,PRSI=prsi,P_PHY=p_phy,T_PHY=t & ,Q=Q,QT=cwm & - ,LOWLYR=LOWLYR,SR=SR & + ,LOWLYR=LOWLYR,SR=SR,TRAIN_PHY=train_phy & ,F_ICE_PHY=F_ICE,F_RAIN_PHY=F_RAIN & ,F_RIMEF_PHY=F_RIMEF & ,QC=QC,QR=QR,QS=QI & ,RAINNC=rainnc,RAINNCV=rainncv & ,threads=threads & - ,IMS=IMS,IME=IME,JMS=JMS,JME=JME,LM=LM & + ,IMS=IMS,IME=IME,LM=LM & ,D_SS=d_ss & ,refl_10cm=refl_10cm,DX1=DX1) @@ -336,17 +299,15 @@ SUBROUTINE mp_fer_hires_run(NCOL, NLEV, DT ,SPEC_ADV & !....................................................................... !MZ* -!Aligo Oct-23-2019 +!Aligo Oct-23-2019 ! - Convert dry qc,qr,qi back to wet mixing ratio -! DO K = 1, LM -! DO I= IMS, IME -! qc_m(i,k) = qc(i,k)/(1.0_kind_phys+q(i,k)) -! qi_m(i,k) = qi(i,k)/(1.0_kind_phys+q(i,k)) -! qr_m(i,k) = qr(i,k)/(1.0_kind_phys+q(i,k)) -! ENDDO -! ENDDO - - + DO K = 1, LM + DO I= IMS, IME + qc(i,k) = qc(i,k)/(1.0_kind_phys+q(i,k)) + qi(i,k) = qi(i,k)/(1.0_kind_phys+q(i,k)) + qr(i,k) = qr(i,k)/(1.0_kind_phys+q(i,k)) + ENDDO + ENDDO !----------------------------------------------------------- DO K=1,LM @@ -366,9 +327,7 @@ SUBROUTINE mp_fer_hires_run(NCOL, NLEV, DT ,SPEC_ADV & !*** UPDATE TEMPERATURE, SPECIFIC HUMIDITY, CLOUD WATER, AND HEATING. !----------------------------------------------------------------------- ! - TNEW=TH_PHY(I,K)*PI_PHY(I,K) - TRAIN(I,K)=TRAIN(I,K)+(TNEW-T(I,K))*RDTPHS - T(I,K)=TNEW + TRAIN(I,K)=TRAIN(I,K)+TRAIN_PHY(I,K) ENDDO ENDDO diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index 96c3dd664..0d3f75c71 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -868,22 +868,24 @@ end subroutine progcld1 !!\param mtop (IX,3), vertical indices for low, mid, hi cloud tops !!\param mbot (IX,3), vertical indices for low, mid, hi cloud bases !!\param de_lgth (IX), clouds decorrelation length (km) -!>\section gen_progcld2 progcld2 General Algorithm +!>\section gen_progcld2 progcld2 General Algorithm for the F-A MP scheme !> @{ 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, & + & ( plyr,plvl,tlyr,qlyr,qstl,rhly,tvly,clw, & ! --- inputs: + & xlat,xlon,slmsk,dz,delp, & + & ntrac, ntcw, ntiw, ntrw, & + & IX, NLAY, NLP1, & + & lmfshal, lmfdeep2, & & clouds,clds,mtop,mbot,de_lgth & ! --- outputs: & ) ! ================= subprogram documentation block ================ ! ! ! ! subprogram: progcld2 computes cloud related quantities using ! -! ferrier's prognostic cloud microphysics scheme. ! +! Thompson/WSM6 cloud microphysics scheme. ! ! ! ! abstract: this program computes cloud fractions from cloud ! -! condensates, calculates liquid/ice cloud droplet effective radius, ! +! 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 ! @@ -908,11 +910,6 @@ subroutine progcld2 & ! 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) : layer cloud condensate amount ! -! f_ice (IX,NLAY) : fraction of layer cloud ice (ferrier micro-phys) ! -! f_rain(IX,NLAY) : fraction of layer rain water (ferrier micro-phys) ! -! r_rime(IX,NLAY) : mass ratio of total ice to unrimed ice (>=1) ! -! flgmin(IX) : minimim large ice fraction ! ! 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) ! @@ -921,6 +918,8 @@ subroutine progcld2 & ! delp (ix,nlay) : model layer pressure thickness in mb (100Pa) ! ! IX : horizontal dimention ! ! NLAY,NLP1 : vertical layer/level dimensions ! +! lmfshal : logical - true for mass flux shallow convection ! +! lmfdeep2 : logical - true for mass flux deep convection ! ! ! ! output variables: ! ! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! @@ -929,9 +928,9 @@ subroutine progcld2 & ! 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 (g/m**2) ! +! 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 (g/m**2) ! +! *** 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 ! @@ -939,7 +938,7 @@ subroutine progcld2 & ! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! ! de_lgth(ix) : clouds decorrelation length (km) ! ! ! -! external module variables: ! +! module variables: ! ! ivflip : control flag of vertical index direction ! ! =0: index from toa to surface ! ! =1: index from surface to toa ! @@ -951,28 +950,24 @@ subroutine progcld2 & ! lcnorm : control flag for in-cld condensate ! ! =t: normalize cloud condensate ! ! =f: not normalize cloud condensate ! -! lnoprec : precip effect in radiation flag (ferrier scheme) ! -! =t: snow/rain has no impact on radiation ! -! =f: snow/rain has impact on radiation ! ! ! ! ==================== end of description ===================== ! ! implicit none -! --- constants - ! --- inputs integer, intent(in) :: IX, NLAY, NLP1 + integer, intent(in) :: ntrac, ntcw, ntiw, ntrw logical, intent(in) :: lmfshal, lmfdeep2 real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & - & tlyr, tvly, qlyr, qstl, rhly, clw, f_ice, f_rain, r_rime, & - & dz, delp + & tlyr, qlyr, qstl, rhly, tvly, delp, dz + + real (kind=kind_phys), dimension(:,:,:), intent(in) :: clw real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & & slmsk - real (kind=kind_phys), dimension(:), intent(in) :: flgmin ! --- outputs real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds @@ -984,15 +979,14 @@ subroutine progcld2 & ! --- local variables: real (kind=kind_phys), dimension(IX,NLAY) :: cldtot, cldcnv, & - & cwp, cip, crp, csp, rew, rei, res, rer, tem2d, clw2, & - & qcwat, qcice, qrain, fcice, frain, rrime, rsden, clwf + & 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 + integer :: i, k, id, nf ! --- constant values ! real (kind=kind_phys), parameter :: xrc3 = 200. @@ -1001,9 +995,15 @@ subroutine progcld2 & ! !===> ... 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 -!> - Assign water/ice/rain/snow cloud properties for Ferrier scheme. do k = 1, NLAY do i = 1, IX cldtot(i,k) = 0.0 @@ -1012,39 +1012,23 @@ subroutine progcld2 & cip (i,k) = 0.0 crp (i,k) = 0.0 csp (i,k) = 0.0 - rew (i,k) = reliq_def ! default liq radius to 10 micron - rei (i,k) = reice_def ! default ice radius to 50 micron + rew (i,k) = reliq_def + rei (i,k) = reice_def rer (i,k) = rrain_def ! default rain radius to 1000 micron - res (i,k) = rsnow_def ! default snow radius to 250 micron - fcice (i,k) = max(0.0, min(1.0, f_ice(i,k))) - frain (i,k) = max(0.0, min(1.0, f_rain(i,k))) - rrime (i,k) = max(1.0, r_rime(i,k)) - tem2d (i,k) = tlyr(i,k) - con_t0c + res (i,k) = rsnow_def + 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 k = 1, NLAY do i = 1, IX - clwf(i,k) = clw(i,k) + clwf(i,k) = clw(i,k,ntcw) + clw(i,k,ntiw) enddo - enddo - endif - -!> - Compute SFC/low/middle/high cloud top pressure for each cloud -!! domain for given latitude. -! - ptopc(k,i): top pressure of each cld domain (k=1-4 are sfc,l,m, -!! h; i=1,2 are low-lat (<45 degree) and pole regions) + 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 @@ -1059,76 +1043,61 @@ subroutine progcld2 & enddo enddo -!> - Seperate cloud condensate into liquid, ice, and rain types, and -!! save the liquid+ice condensate in array clw2 for later calculation -!! of cloud fraction. +!> - Compute cloud liquid/ice condensate path in \f$ g/m^2 \f$ . do k = 1, NLAY - do i = 1, IX - if (tem2d(i,k) > -40.0) then - qcice(i,k) = clwf(i,k) * fcice(i,k) - tem1 = clwf(i,k) - qcice(i,k) - qrain(i,k) = tem1 * frain(i,k) - qcwat(i,k) = tem1 - qrain(i,k) - clw2 (i,k) = qcwat(i,k) + qcice(i,k) - else - qcice(i,k) = clwf(i,k) - qrain(i,k) = 0.0 - qcwat(i,k) = 0.0 - clw2 (i,k) = clwf(i,k) - endif - enddo + 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) = 0.0 + enddo enddo -!> - Call module_microphysics::rsipath2(), in Ferrier's scheme, to -!! compute layer's cloud liquid, ice, rain, and snow water condensate -!! path and the partical effective radius for liquid droplet, rain drop, -!! and snow flake. - call rsipath2 & -! --- inputs: - & ( plyr, plvl, tlyr, qlyr, qcwat, qcice, qrain, rrime, & - & IX, NLAY, ivflip, flgmin, & -! --- outputs: - & cwp, cip, crp, csp, rew, rer, res, rsden & - & ) +!> - Compute cloud ice effective radii + + 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)) - do k = 1, NLAY - do i = 1, IX - tem2d(i,k) = (con_g * plyr(i,k)) & - & / (con_rd* delp(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(10.0, min(rei(i,k), 150.0)) + endif enddo - enddo + enddo + !> - Calculate layer cloud fraction. - clwmin = 0.0e-6 + clwmin = 0.0 if (.not. lmfshal) then do k = 1, NLAY do i = 1, IX -! clwt = 1.0e-7 * (plyr(i,k)*0.001) -! clwt = 1.0e-6 * (plyr(i,k)*0.001) - clwt = 2.0e-6 * (plyr(i,k)*0.001) -! clwt = 5.0e-6 * (plyr(i,k)*0.001) -! clwt = 5.0e-6 + clwt = 1.0e-6 * (plyr(i,k)*0.001) +! clwt = 2.0e-6 * (plyr(i,k)*0.001) + + if (clwf(i,k) > clwt) then - if (clw2(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(onemrh*qstl(i,k)),0.0001),1.0) -! tem1 = 100.0 / tem1 - tem1 = min(max(sqrt(sqrt(onemrh*qstl(i,k))),0.0001),1.0) tem1 = 2000.0 / tem1 -! tem1 = 2400.0 / tem1 -!cnt tem1 = 2500.0 / tem1 -! tem1 = min(max(sqrt(onemrh*qstl(i,k)),0.0001),1.0) -! tem1 = 2000.0 / tem1 + ! tem1 = 1000.0 / tem1 -! tem1 = 100.0 / tem1 - value = max( min( tem1*(clw2(i,k)-clwm), 50.0 ), 0.0 ) + 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 ) @@ -1138,21 +1107,21 @@ subroutine progcld2 & 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) + clwt = 1.0e-6 * (plyr(i,k)*0.001) +! clwt = 2.0e-6 * (plyr(i,k)*0.001) - if (clw2(i,k) > clwt) then + 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 + 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*(clw2(i,k)-clwm), 50.0 ), 0.0 ) + 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 ) @@ -1173,16 +1142,6 @@ subroutine progcld2 & enddo enddo -!> - When lnoprec = .true. snow/rain has no impact on radiation. - if ( lnoprec ) then - do k = 1, NLAY - do i = 1, IX - crp(i,k) = 0.0 - csp(i,k) = 0.0 - enddo - enddo - endif -! if ( lcnorm ) then do k = 1, NLAY do i = 1, IX @@ -1197,38 +1156,6 @@ subroutine progcld2 & enddo endif -!> - Calculate effective ice cloud droplet radius following Heymsfield and McFarquhar (1996) -!! \cite heymsfield_and_mcfarquhar_1996 . - - do k = 1, NLAY - do i = 1, IX - tem1 = tlyr(i,k) - con_ttp - tem2 = cip(i,k) - - if (tem2 > 0.0) then - tem3 = tem2d(i,k) * tem2 / tvly(i,k) - - if (tem1 < -50.0) then - rei(i,k) = (1250.0/9.917) * tem3 ** 0.109 - elseif (tem1 < -40.0) then - rei(i,k) = (1250.0/9.337) * tem3 ** 0.08 - elseif (tem1 < -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 - -! if (lprnt .and. k == l) print *,' reiL=',rei(i,k),' icec=', & -! & icec,' cip=',cip(i,k),' tem=',tem,' delt=',delt - - rei(i,k) = max(10.0, min(rei(i,k), 300.0)) -! rei(i,k) = max(20.0, min(rei(i,k), 300.0)) -!!!! rei(i,k) = max(30.0, min(rei(i,k), 300.0)) -! rei(i,k) = max(50.0, min(rei(i,k), 300.0)) -! rei(i,k) = max(100.0, min(rei(i,k), 300.0)) - endif - enddo - enddo ! do k = 1, NLAY do i = 1, IX @@ -1237,10 +1164,9 @@ subroutine progcld2 & 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) + clouds(i,k,6) = crp(i,k) ! added for Thompson clouds(i,k,7) = rer(i,k) -! clouds(i,k,8) = csp(i,k) !ncar scheme - clouds(i,k,8) = csp(i,k) * rsden(i,k) !fu's scheme + clouds(i,k,8) = csp(i,k) ! added for Thompson clouds(i,k,9) = res(i,k) enddo enddo @@ -1254,9 +1180,11 @@ subroutine progcld2 & 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. +!> - 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. @@ -1274,6 +1202,8 @@ subroutine progcld2 & return !................................... end subroutine progcld2 +!................................... + !> @} !----------------------------------- From cb2d558dcc2fbd984a82569edcfe04b749bebeb8 Mon Sep 17 00:00:00 2001 From: "Man.Zhang" Date: Thu, 30 Apr 2020 09:48:20 -0600 Subject: [PATCH 18/42] fix unitialized parameter and dimensions in FA --- physics/GFS_rrtmg_pre.F90 | 8 ++++++-- physics/module_MP_FER_HIRES.F90 | 8 +++++++- physics/mp_fer_hires.F90 | 4 ++++ physics/radiation_clouds.f | 9 ++++----- 4 files changed, 21 insertions(+), 8 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 8acb24a50..af2cb0093 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -566,7 +566,11 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input ccnd(i,k,1) = tracer1(i,k,ntcw) ! liquid water ccnd(i,k,2) = tracer1(i,k,ntiw) ! ice water ccnd(i,k,3) = tracer1(i,k,ntrw) ! rain water - ccnd(i,k,4) = tracer1(i,k,ntsw) + tracer1(i,k,ntgl) ! snow + grapuel + if (Model%imp_physics == 15 ) then + ccnd(i,k,4) = 0.0 + else + ccnd(i,k,4) = tracer1(i,k,ntsw) + tracer1(i,k,ntgl) ! snow + grapuel + endif enddo enddo endif @@ -859,7 +863,7 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input 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, & +!mz ntsw-1,ntgl-1, & im, lmk, lmp, Model%icloud,Model%uni_cld, & Model%lmfshal,Model%lmfdeep2, & cldcov(:,1:LMK),Tbd%phy_f3d(:,:,1), & diff --git a/physics/module_MP_FER_HIRES.F90 b/physics/module_MP_FER_HIRES.F90 index f45ffa04f..c758f7951 100644 --- a/physics/module_MP_FER_HIRES.F90 +++ b/physics/module_MP_FER_HIRES.F90 @@ -289,7 +289,7 @@ SUBROUTINE FER_HIRES (DT,RHgrd, & REAL, DIMENSION(ims:ime):: APREC,PREC,ACPREC INTEGER :: I,K,KK - REAL :: wc + REAL :: wc, RDIS, BETA6 !------------------------------------------------------------------------ ! For subroutine EGCP01COLUMN_hr !----------------------------------------------------------------------- @@ -331,6 +331,12 @@ SUBROUTINE FER_HIRES (DT,RHgrd, & ! !-- See comments in subroutine etanewhr_init starting with variable RDIS= ! +!-- Relative dispersion == standard deviation of droplet spectrum / mean radius +! (see pp 1542-1543, Liu & Daum, JAS, 2004) + RDIS=0.5 !-- relative dispersion of droplet spectrum + BETA6=( (1.+3.*RDIS*RDIS)*(1.+4.*RDIS*RDIS)*(1.+5.*RDIS*RDIS)/ & + & ((1.+RDIS*RDIS)*(1.+2.*RDIS*RDIS) ) ) + BRAUT=DT*1.1E10*BETA6/NCW !! END OF adding, 2015-03-30 diff --git a/physics/mp_fer_hires.F90 b/physics/mp_fer_hires.F90 index 19cfa117a..4935d8aa6 100644 --- a/physics/mp_fer_hires.F90 +++ b/physics/mp_fer_hires.F90 @@ -274,10 +274,14 @@ SUBROUTINE mp_fer_hires_run(NCOL, NLEV, DT ,SPEC_ADV & !--------------------------------------------------------------------- !aligo + DO K = 1, LM + DO I= IMS, IME cwm(i,k) = cwm(i,k)/(1.0_kind_phys-q(i,k)) qr(i,k) = qr(i,k)/(1.0_kind_phys-q(i,k)) qi(i,k) = qi(i,k)/(1.0_kind_phys-q(i,k)) qc(i,k) = qc(i,k)/(1.0_kind_phys-q(i,k)) + ENDDO + ENDDO !aligo !--------------------------------------------------------------------- diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index 0d3f75c71..65f483821 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -2275,7 +2275,7 @@ end subroutine progcld4o subroutine progcld5 & & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw, & ! --- inputs: & xlat,xlon,slmsk,dz,delp, & - & ntrac,ntcw,ntiw,ntrw,ntsw,ntgl, & + & ntrac,ntcw,ntiw,ntrw, & & IX, NLAY, NLP1, icloud, & & uni_cld, lmfshal, lmfdeep2, cldcov, & & re_cloud,re_ice,re_snow, & @@ -2364,7 +2364,7 @@ subroutine progcld5 & ! --- inputs integer, intent(in) :: IX, NLAY, NLP1, ICLOUD - integer, intent(in) :: ntrac, ntcw, ntiw, ntrw, ntsw, ntgl + integer, intent(in) :: ntrac, ntcw, ntiw, ntrw logical, intent(in) :: uni_cld, lmfshal, lmfdeep2 @@ -2452,7 +2452,7 @@ subroutine progcld5 & do k = 1, NLAY do i = 1, IX - clwf(i,k) = clw(i,k,ntcw) + clw(i,k,ntiw) + clw(i,k,ntsw) + clwf(i,k) = clw(i,k,ntcw) + clw(i,k,ntiw) enddo enddo !> - Find top pressure for each cloud domain for given latitude. @@ -2479,8 +2479,7 @@ subroutine progcld5 & 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)) + csp(i,k) = 0.0 enddo enddo From b084396e1fe3947f26b3903029ff28253620e996 Mon Sep 17 00:00:00 2001 From: "Man.Zhang" Date: Thu, 30 Apr 2020 12:20:25 -0600 Subject: [PATCH 19/42] fix unitialized parameters in samfdeepcnv --- physics/samfdeepcnv.f | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f index f64a0b332..d067d7187 100644 --- a/physics/samfdeepcnv.f +++ b/physics/samfdeepcnv.f @@ -201,7 +201,7 @@ subroutine samfdeepcnv_run (im,ix,km,itc,ntc,cliq,cp,cvap, & c physical parameters ! parameter(asolfac=0.89) !HWRF ! parameter(grav=grav) -! parameter(elocp=hvap/cp,el2orc=hvap*hvap/(rv*cp)) +! parameter(elocp=hvap/cp,el2orc=hvap*hvap/(rv*cp)) ! parameter(c0s=.002,c1=.002,d0=.01) ! parameter(d0=.01) parameter(d0=.001) @@ -215,7 +215,7 @@ subroutine samfdeepcnv_run (im,ix,km,itc,ntc,cliq,cp,cvap, & ! as Nccn=100 for sea and Nccn=1000 for land ! parameter(cm=1.0) -! parameter(fact1=(cvap-cliq)/rv,fact2=hvap/rv-fact1*t0c) +! parameter(fact1=(cvap-cliq)/rv,fact2=hvap/rv-fact1*t0c) parameter(clamd=0.03,tkemx=0.65,tkemn=0.05) parameter(dtke=tkemx-tkemn) parameter(dbeta=0.1) @@ -276,13 +276,13 @@ subroutine samfdeepcnv_run (im,ix,km,itc,ntc,cliq,cp,cvap, & errflg = 0 - if(.not. hwrf_samfdeep) then elocp = hvap/cp el2orc = hvap*hvap/(rv*cp) fact1 = (cvap-cliq)/rv fact2 = hvap/rv-fact1*t0c ! + if(.not. hwrf_samfdeep) then c----------------------------------------------------------------------- !> ## Determine whether to perform aerosol transport do_aerosols = (itc > 0) .and. (ntc > 0) .and. (ntr > 0) From d35fad0f27a7cd3b38e49351ba9d1d3f8e10bbff Mon Sep 17 00:00:00 2001 From: "Man.Zhang" Date: Thu, 30 Apr 2020 15:42:18 -0600 Subject: [PATCH 20/42] bug fix in HWRF RRTMG --- physics/radlw_main.F90 | 11 +++++++---- physics/radsw_main.F90 | 4 ++-- 2 files changed, 9 insertions(+), 6 deletions(-) diff --git a/physics/radlw_main.F90 b/physics/radlw_main.F90 index 4ee7ca22b..f5278ed33 100644 --- a/physics/radlw_main.F90 +++ b/physics/radlw_main.F90 @@ -670,7 +670,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(nbands,npts,nlay) :: taucld3 real (kind=kind_phys), dimension(ngptlw,nlay) :: fracs, tautot real (kind=kind_phys), dimension(nlay,ngptlw) :: fracs_r !mz rtrnmc_mcica @@ -1175,7 +1175,7 @@ subroutine rrtmg_lw_run & call cldprop & ! --- inputs: & ( cldfrc,clwp,relw,ciwp,reiw,cda1,cda2,cda3,cda4, & - & nlay, nlp1, ipseed(iplon), dz, delgth, & + & nlay, nlp1, ipseed(iplon), dz, delgth,iovrlw, & ! --- outputs: & cldfmc, taucld & & ) @@ -1668,7 +1668,7 @@ end subroutine rlwinit !> @{ subroutine cldprop & & ( cfrac,cliqp,reliq,cicep,reice,cdat1,cdat2,cdat3,cdat4, & ! --- inputs - & nlay, nlp1, ipseed, dz, de_lgth, & + & nlay, nlp1, ipseed, dz, de_lgth, iovrlw, & & cldfmc, taucld & ! --- outputs & ) @@ -1768,7 +1768,7 @@ subroutine cldprop & use module_radlw_cldprlw ! --- inputs: - integer, intent(in) :: nlay, nlp1, ipseed + integer, intent(in) :: nlay, nlp1, ipseed, iovrlw real (kind=kind_phys), dimension(0:nlp1), intent(in) :: cfrac real (kind=kind_phys), dimension(nlay), intent(in) :: cliqp, & @@ -1946,6 +1946,8 @@ subroutine cldprop & ! --- ... call sub-column cloud generator +!mz* + if (iovrlw .ne. 4) then call mcica_subcol & ! --- inputs: & ( cldf, nlay, ipseed, dz, de_lgth, & @@ -1962,6 +1964,7 @@ subroutine cldprop & endif enddo enddo + endif !iovrlw endif ! end if_isubclw_block diff --git a/physics/radsw_main.F90 b/physics/radsw_main.F90 index 924d750b1..321414976 100644 --- a/physics/radsw_main.F90 +++ b/physics/radsw_main.F90 @@ -720,9 +720,9 @@ subroutine rrtmg_sw_run & ! --- locals: !mz* HWRF -- input of mcica_subcol_sw - real(kind=kind_phys),dimension(1,nlay) :: hgt + real(kind=kind_phys),dimension(npts,nlay) :: hgt real(kind=kind_phys) :: dzsum - real(kind=kind_phys),dimension( nbdsw, 1, nlay ) :: taucld3, & + real(kind=kind_phys),dimension( nbdsw, npts, nlay ) :: taucld3, & ssacld3, & asmcld3, & fsfcld3 From ef386967e9cab4a672be603f52a51704f538d226 Mon Sep 17 00:00:00 2001 From: "Man.Zhang" Date: Fri, 8 May 2020 10:59:14 -0600 Subject: [PATCH 21/42] add force_read_ferhires capability in FA --- physics/module_MP_FER_HIRES.F90 | 148 ++++++++++++++++++++++---------- physics/mp_fer_hires.F90 | 28 ++++-- physics/mp_fer_hires.meta | 18 ++++ 3 files changed, 145 insertions(+), 49 deletions(-) diff --git a/physics/module_MP_FER_HIRES.F90 b/physics/module_MP_FER_HIRES.F90 index c758f7951..776898f93 100644 --- a/physics/module_MP_FER_HIRES.F90 +++ b/physics/module_MP_FER_HIRES.F90 @@ -148,23 +148,23 @@ MODULE MODULE_MP_FER_HIRES INTEGER, PRIVATE,PARAMETER :: MY_T1=1, MY_T2=35 REAL,PRIVATE,DIMENSION(MY_T1:MY_T2),SAVE :: MY_GROWTH_NMM ! - REAL, PRIVATE,PARAMETER :: DMImin=.05e-3, DMImax=1.e-3, & + REAL, PRIVATE,PARAMETER :: DMImin=.05e-3, DMImax=1.e-3, & & DelDMI=1.e-6,XMImin=1.e6*DMImin REAL, PUBLIC,PARAMETER :: XMImax=1.e6*DMImax, XMIexp=.0536 INTEGER, PUBLIC,PARAMETER :: MDImin=XMImin, MDImax=XMImax - REAL, PRIVATE,DIMENSION(MDImin:MDImax) :: & + REAL, ALLOCATABLE, DIMENSION(:) :: & & ACCRI,VSNOWI,VENTI1,VENTI2 REAL, PUBLIC,DIMENSION(MDImin:MDImax) :: SDENS !-- For RRTM ! - REAL, PRIVATE,PARAMETER :: DMRmin=.05e-3, DMRmax=1.0e-3, & + REAL, PRIVATE,PARAMETER :: DMRmin=.05e-3, DMRmax=1.0e-3, & & DelDMR=1.e-6, XMRmin=1.e6*DMRmin, XMRmax=1.e6*DMRmax INTEGER, PUBLIC,PARAMETER :: MDRmin=XMRmin, MDRmax=XMRmax ! - REAL, PRIVATE,DIMENSION(MDRmin:MDRmax):: & + REAL, ALLOCATABLE, DIMENSION(:):: & & ACCRR,MASSR,RRATE,VRAIN,VENTR1,VENTR2 ! INTEGER, PRIVATE,PARAMETER :: Nrime=40 - REAL, DIMENSION(2:9,0:Nrime),PRIVATE,SAVE :: VEL_RF + REAL, ALLOCATABLE, DIMENSION(:,:) :: VEL_RF ! INTEGER,PARAMETER :: NX=7501 REAL, PARAMETER :: XMIN=180.0,XMAX=330.0 @@ -226,7 +226,7 @@ MODULE MODULE_MP_FER_HIRES !HWRF & ,NCW=300.E6 !- 100.e6 (maritime), 500.e6 (continental) !--- Other public variables passed to other routines: - REAL, PUBLIC,DIMENSION(MDImin:MDImax) :: MASSI + REAL, ALLOCATABLE ,DIMENSION(:) :: MASSI ! CONTAINS @@ -449,8 +449,9 @@ SUBROUTINE FER_HIRES (DT,RHgrd, & !GFDL => New. Added RHC_col to allow for height- and grid-dependent values for !GFDL the relative humidity threshold for condensation ("RHgrd") !6/11/2010 mod - Use lower RHgrd_out threshold for < 850 hPa +!mz 05/06/2020 - 10km !------------------------------------------------------------ - IF(DX1 .GE. 10 .AND. P_col(L) \section arg_table_mp_fer_hires_finalize Argument Table !! - subroutine mp_fer_hires_finalize () + subroutine mp_fer_hires_finalize (errmsg,errflg) + implicit none + + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + + ! Initialize the CCPP error handling variables + errmsg = '' + errflg = 0 + + if (.not.is_initialized) return + + call ferhires_finalize() + + is_initialized = .false. + + end subroutine mp_fer_hires_finalize end module mp_fer_hires diff --git a/physics/mp_fer_hires.meta b/physics/mp_fer_hires.meta index a7a33378a..1782aecf6 100644 --- a/physics/mp_fer_hires.meta +++ b/physics/mp_fer_hires.meta @@ -130,6 +130,24 @@ [ccpp-arg-table] name = mp_fer_hires_finalize type = scheme + +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F ######################################################################## [ccpp-arg-table] name = mp_fer_hires_run From 4233a040a54159e129549afe964cb035057481c9 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Wed, 13 May 2020 14:13:57 -0600 Subject: [PATCH 22/42] addition of HWRF Noah LSM and GFDL surface layer; for HWRF Noah LSM 1) edit CMakeLists.txt to remove inoperative set_source_file_properties statement 2) edit GFS_surface_generic.F90 to handle ivegsrc=3,4,5 3) edit sfc_drv.f, sfc_drv_ruc.F90, sfc_noahmp_drv.F to check for valid ivegsrc, isot 4) add Noah working routines module_sf_noahlsm.F90 and module_sf_noahlsm_glacial_only.F90 5) add CCPP-compliant sfc_noah_wrfv4 scheme and associated interstitials; for GFDL surface layer 1) add module_sf_exchcoef.f90 for internal subroutines and 2) gfdl_sfc_layer as CCPP-compliant GFDL surface layer scheme --- CMakeLists.txt | 26 - physics/GFS_surface_generic.F90 | 8 +- physics/gfdl_sfc_layer.F90 | 1779 ++++++++ physics/gfdl_sfc_layer.meta | 801 ++++ physics/module_sf_exchcoef.f90 | 733 +++ physics/module_sf_noahlsm.F90 | 4773 ++++++++++++++++++++ physics/module_sf_noahlsm_glacial_only.F90 | 1285 ++++++ physics/sfc_drv.f | 15 +- physics/sfc_drv_ruc.F90 | 11 + physics/sfc_noah_wrfv4.F90 | 261 ++ physics/sfc_noah_wrfv4.meta | 764 ++++ physics/sfc_noah_wrfv4_interstitial.F90 | 758 ++++ physics/sfc_noah_wrfv4_interstitial.meta | 1098 +++++ physics/sfc_noahmp_drv.f | 13 + 14 files changed, 12296 insertions(+), 29 deletions(-) create mode 100644 physics/gfdl_sfc_layer.F90 create mode 100644 physics/gfdl_sfc_layer.meta create mode 100755 physics/module_sf_exchcoef.f90 create mode 100644 physics/module_sf_noahlsm.F90 create mode 100644 physics/module_sf_noahlsm_glacial_only.F90 create mode 100644 physics/sfc_noah_wrfv4.F90 create mode 100644 physics/sfc_noah_wrfv4.meta create mode 100644 physics/sfc_noah_wrfv4_interstitial.F90 create mode 100644 physics/sfc_noah_wrfv4_interstitial.meta diff --git a/CMakeLists.txt b/CMakeLists.txt index b8d3c3e18..e3560f502 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -174,32 +174,6 @@ if (${CMAKE_Fortran_COMPILER_ID} STREQUAL "GNU") elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") # Adjust settings for bit-for-bit reproducibility of NEMSfv3gfs if (PROJECT STREQUAL "CCPP-FV3") - SET_SOURCE_FILES_PROPERTIES(${CMAKE_CURRENT_SOURCE_DIR}/physics/module_bfmicrophysics.f - ${CMAKE_CURRENT_SOURCE_DIR}/physics/sflx.f - ${CMAKE_CURRENT_SOURCE_DIR}/physics/sfc_diff.f - ${CMAKE_CURRENT_SOURCE_DIR}/physics/sfc_diag.f - ${CMAKE_CURRENT_SOURCE_DIR}/physics/module_nst_model.f90 - ${CMAKE_CURRENT_SOURCE_DIR}/physics/calpreciptype.f90 - ${CMAKE_CURRENT_SOURCE_DIR}/physics/mersenne_twister.f - ${CMAKE_CURRENT_SOURCE_DIR}/physics/module_nst_water_prop.f90 - ${CMAKE_CURRENT_SOURCE_DIR}/physics/aer_cloud.F - ${CMAKE_CURRENT_SOURCE_DIR}/physics/wv_saturation.F - ${CMAKE_CURRENT_SOURCE_DIR}/physics/cldwat2m_micro.F - ${CMAKE_CURRENT_SOURCE_DIR}/physics/surface_perturbation.F90 - ${CMAKE_CURRENT_SOURCE_DIR}/physics/radiation_aerosols.f - ${CMAKE_CURRENT_SOURCE_DIR}/physics/cu_gf_deep.F90 - ${CMAKE_CURRENT_SOURCE_DIR}/physics/cu_gf_sh.F90 - ${CMAKE_CURRENT_SOURCE_DIR}/physics/module_bl_mynn.F90 - ${CMAKE_CURRENT_SOURCE_DIR}/physics/module_MYNNPBL_wrapper.F90 - ${CMAKE_CURRENT_SOURCE_DIR}/physics/module_sf_mynn.F90 - ${CMAKE_CURRENT_SOURCE_DIR}/physics/module_MYNNSFC_wrapper.F90 - ${CMAKE_CURRENT_SOURCE_DIR}/physics/module_MYNNrad_pre.F90 - ${CMAKE_CURRENT_SOURCE_DIR}/physics/module_MYNNrad_post.F90 - ${CMAKE_CURRENT_SOURCE_DIR}/physics/module_mp_thompson_make_number_concentrations.F90 - ${CMAKE_CURRENT_SOURCE_DIR}/physics/module_SF_JSFC.F90 - ${CMAKE_CURRENT_SOURCE_DIR}/physics/module_BL_MYJPBL.F90 - PROPERTIES COMPILE_FLAGS "-r8 -ftz") - # Replace -xHost or -xCORE-AVX2 with -xCORE-AVX-I for certain files set(CMAKE_Fortran_FLAGS_LOPT1 ${CMAKE_Fortran_FLAGS_OPT}) string(REPLACE "-xHOST" "-xCORE-AVX-I" diff --git a/physics/GFS_surface_generic.F90 b/physics/GFS_surface_generic.F90 index ac366ae54..d6f751cc7 100644 --- a/physics/GFS_surface_generic.F90 +++ b/physics/GFS_surface_generic.F90 @@ -148,10 +148,14 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, else soiltyp(i) = 9 endif - if (ivegsrc == 1) then + if (ivegsrc == 0 .or. ivegsrc == 4) then + vegtype(i) = 24 + elseif (ivegsrc == 1) then vegtype(i) = 15 - elseif(ivegsrc == 2) then + elseif (ivegsrc == 2) then vegtype(i) = 13 + elseif (ivegsrc == 3 .or. ivegsrc == 5) then + vegtype(i) = 15 endif slopetyp(i) = 9 else diff --git a/physics/gfdl_sfc_layer.F90 b/physics/gfdl_sfc_layer.F90 new file mode 100644 index 000000000..edd3f0c30 --- /dev/null +++ b/physics/gfdl_sfc_layer.F90 @@ -0,0 +1,1779 @@ +!> \file gfdl_sfc_layer.f +!! This file contains ... + +!> This module contains the CCPP-compliant GFDL surface layer scheme. + module gfdl_sfc_layer + + use machine , only : kind_phys + + implicit none + + public :: gfdl_sfc_layer_init, gfdl_sfc_layer_run, gfdl_sfc_layer_finalize + + private + + contains + +!> \section arg_table_gfdl_sfc_layer_init Argument Table +!! \htmlinclude gfdl_sfc_layer_init.html +!! + subroutine gfdl_sfc_layer_init (icoef_sf, cplwav, cplwav2atm, lcurr_sf, & + pert_cd, ntsflg, errmsg, errflg) + + implicit none + + integer, intent(in) :: icoef_sf, ntsflg + logical, intent(in) :: cplwav, cplwav2atm, lcurr_sf, pert_cd + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + +#if HWRF==1 + write(errmsg,'(*(a))') 'The GFDL surface layer scheme does not support '& + //'use of the HWRF preprocessor flag in gfdl_sfc_layer.F90' + errflg = 1 + return +#endif + + if (icoef_sf < 0 .or. icoef_sf > 8) then + write(errmsg,'(*(a))') 'The value of icoef_sf is outside of the ' & + //'supported range (0-8) in gfdl_sfc_layer.F90' + errflg = 1 + return + end if + + if (cplwav .or. cplwav2atm) then + write(errmsg,'(*(a))') 'The GFDL surface layer scheme is not set up ' & + //'to be coupled to waves in gfdl_sfc_layer.F90' + errflg = 1 + return + end if + + if (lcurr_sf) then + write(errmsg,'(*(a))') 'The GFDL surface layer scheme is not set up ' & + //'to be used with the lcurr_sf option in gfdl_sfc_layer.F90' + errflg = 1 + return + end if + + if (pert_cd) then + write(errmsg,'(*(a))') 'The GFDL surface layer scheme is not set up ' & + //'to be used with the pert_cd option in gfdl_sfc_layer.F90' + errflg = 1 + return + end if + + if (ntsflg > 0) then + !GJF: In order to enable ntsflg > 0, the variable 'tstrc' passed into MFLUX2 should be set + ! to the surface_skin_temperature_over_X_interstitial rather than the average of it and + ! surface_skin_temperature_after_iteration_over_X + write(errmsg,'(*(a))') 'Setting ntsflg > 0 is currently not supported'& + //' in gfdl_sfc_layer.F90' + errflg = 1 + return + end if + + !GJF: Initialization notes: In WRF, the subroutine module_sf_myjsfc/myjsfcinit + ! is called for initialization of the GFDL surface layer scheme from + ! the module_physics_init subroutine. It contains the following + ! initializations which should already have been done by other + ! code in UFS-related host models: + ! IF(.NOT.RESTART)THEN + ! DO J=JTS,JTE + ! DO I=ITS,ITF + ! USTAR(I,J)=0.1 + ! ENDDO + ! ENDDO + ! ENDIF + !also initialize surface roughness length + + end subroutine gfdl_sfc_layer_init + + subroutine gfdl_sfc_layer_finalize () + end subroutine gfdl_sfc_layer_finalize + +!> \section arg_table_gfdl_sfc_layer_run Argument Table +!! \htmlinclude gfdl_sfc_layer_run.html +!! + subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & + lsm_noah, lsm_noahmp, lsm_ruc, lsm_noah_wrfv4, icoef_sf, cplwav, & + cplwav2atm, lcurr_sf, pert_Cd, ntsflg, sfenth, z1, shdmax, ivegsrc, & + vegtype, sigmaf, dt, wet, dry, icy, isltyp, rd, grav, ep1, ep2, smois, & + psfc, prsl1, q1, t1, u1, v1, u10, v10, gsw, glw, tsurf_ocn, tsurf_lnd, & + tsurf_ice, tskin_ocn, tskin_lnd, tskin_ice, ustar_ocn, ustar_lnd, & + ustar_ice, znt_ocn, znt_lnd, znt_ice, cdm_ocn, cdm_lnd, cdm_ice, & + stress_ocn, stress_lnd, stress_ice, rib_ocn, rib_lnd, rib_ice, fm_ocn, & + fm_lnd, fm_ice, fh_ocn, fh_lnd, fh_ice, fh2_ocn, fh2_lnd, fh2_ice, & + ch_ocn, ch_lnd, ch_ice, fm10_ocn, fm10_lnd, fm10_ice, qss_ocn, qss_lnd, & + qss_ice, errmsg, errflg) + + use funcphys, only: fpvs + + !#### GJF: temporarily grab parameters from LSM-specific modules -- should go through CCPP #### + ! (fixing this involves replacing the functionality of set_soilveg and namelist_soilveg) + use namelist_soilveg, only: maxsmc_noah => maxsmc, drysmc_noah => drysmc + use namelist_soilveg_ruc, only: maxsmc_ruc => maxsmc, drysmc_ruc => drysmc + use noahmp_tables, only: maxsmc_noahmp => smcmax_table, drysmc_noahmp => smcdry_table + use module_sf_noahlsm, only: maxsmc_noah_wrfv4 => maxsmc, drysmc_noah_wrfv4 => drysmc + !################################################################################################ + + implicit none + + integer, intent(in) :: im, nsoil, km, ivegsrc + integer, intent(in) :: lsm, lsm_noah, lsm_noahmp, & + lsm_ruc, lsm_noah_wrfv4, icoef_sf,& + ntsflg + logical, intent(in) :: cplwav, cplwav2atm !GJF: this scheme has not been tested with these on + logical, intent(in) :: lcurr_sf !GJF: this scheme has not been tested with this option turned on; the variables scurx and scury need to be input in order to use this + logical, intent(in) :: pert_Cd !GJF: this scheme has not been tested with this option turned on; the variables ens_random_seed and ens_Cdamp need to be input in order to use this + logical, dimension(im), intent(in) :: flag_iter, wet, dry, icy + integer, dimension(im), intent(in) :: isltyp, vegtype + real(kind=kind_phys), intent(in) :: dt, sfenth + real(kind=kind_phys), intent(in) :: rd,grav,ep1,ep2 + real(kind=kind_phys), dimension(im,nsoil), intent(in) :: smois + real(kind=kind_phys), dimension(im), intent(in) :: psfc, prsl1, & + q1, t1, u1, v1, u10, v10, gsw, glw, z1, shdmax, sigmaf, xlat, xlon, & + tsurf_ocn, tsurf_lnd, tsurf_ice + + real(kind=kind_phys), intent(inout), dimension(im) :: tskin_ocn, & + tskin_lnd, tskin_ice, ustar_ocn, ustar_lnd, ustar_ice, & + znt_ocn, znt_lnd, znt_ice, cdm_ocn, cdm_lnd, cdm_ice, & + stress_ocn, stress_lnd, stress_ice, rib_ocn, rib_lnd, rib_ice, & + fm_ocn, fm_lnd, fm_ice, fh_ocn, fh_lnd, fh_ice, fh2_ocn, fh2_lnd, & + fh2_ice, ch_ocn, ch_lnd, ch_ice, fm10_ocn, fm10_lnd, fm10_ice, & + qss_ocn, qss_lnd, qss_ice + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + !local variables + + integer :: i, its, ite, ims, ime + + !GJF: the vonKarman constant should come in through the CCPP and be defined by the host model + real (kind=kind_phys), parameter :: karman = 0.4 + real (kind=kind_phys), parameter :: log01=log(0.01), log05=log(0.05), & + log07=log(0.07) + + !GJF: if the following variables will be used, they should be turned into intent(in) namelist options + integer :: iwavecpl, ens_random_seed, issflx + logical :: diag_wind10m, diag_qss + real(kind=kind_phys) :: ens_Cdamp + + real(kind=kind_phys), dimension(im) :: wetc, pspc, pkmax, tstrc, upc, & + vpc, mznt, slwdc, wspd, wind10, qfx, qgh, zkmax, z1_cm, z0max, ztmax + real(kind=kind_phys), dimension(im) :: u10_lnd, u10_ocn, u10_ice, & + v10_lnd, v10_ocn, v10_ice + + !GJF: the following variables are identified as: + !"SCURX" "Surface Currents(X)" "m s-1" + !"SCURY" "Surface Currents(Y)" "m s-1 + !"CHARN" "Charnock Coeff" " " + !"MSANG" "Wind/Stress Angle" "Radian" + real(kind=kind_phys), dimension(im) :: charn, msang, scurx, scury + + real(kind=kind_phys), dimension(im) :: fxh, fxe, fxmx, fxmy, xxfh, & + xxfh2, tzot + real(kind=kind_phys), dimension(1:30) :: maxsmc, drysmc + real(kind=kind_phys) :: smcmax, smcdry, zhalf, cd10, & + esat, fm_lnd_old, fh_lnd_old, tem1, tem2, czilc, cdlimit + + !#### This block will become unnecessary when maxsmc and drysmc come through the CCPP #### + if (lsm == lsm_noah) then + maxsmc = maxsmc_noah + drysmc = drysmc_noah + else if (lsm == lsm_noahmp) then + maxsmc = maxsmc_noahmp + drysmc = drysmc_noahmp + else if (lsm == lsm_ruc) then + maxsmc = maxsmc_ruc + drysmc = drysmc_ruc + else if (lsm == lsm_noah_wrfv4) then + maxsmc = maxsmc_noah_wrfv4 + drysmc = drysmc_noah_wrfv4 + else + !GJF: These data were from the original GFDL surface layer scheme, but + ! rather than being hard-coded here, they should be shared with the + ! LSM. These data are kept for legacy purposes. Note that these only + ! have nonzero values for 16 soil types vs 19 for other STAS datasets + data maxsmc/0.339, 0.421, 0.434, 0.476, 0.476, 0.439, & + 0.404, 0.464, 0.465, 0.406, 0.468, 0.468, & + 0.439, 1.000, 0.200, 0.421, 0.000, 0.000, & + 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, & + 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/ + data drysmc/0.010, 0.028, 0.047, 0.084, 0.084, 0.066, & + 0.067, 0.120, 0.103, 0.100, 0.126, 0.138, & + 0.066, 0.000, 0.006, 0.028, 0.000, 0.000, & + 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, & + 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/ + end if + !######################################################################## + + !GJF: This code has not been tested with iwavecpl = 1; the variables 'charn' and 'msang' (and others?) need to be input in order to use this + ! if (cplwav .or. cplwav2atm) then + ! iwavecpl = 1 + ! else + ! iwavecpl = 0 + ! end if + iwavecpl = 0 + + !GJF: temporary setting of variables that should be moved to namelist is they are used + ens_random_seed = 0 !used for HWRF ensemble? + ens_Cdamp = 0.0 !used for HWRF ensemble? + + issflx = 0 !GJF: 1 = calculate surface fluxes, 0 = don't + diag_wind10m = .false. !GJF: if one wants 10m wind speeds to come from this scheme, set this to True, + ! put [u,v]10_[lnd/ocn/ice] in the scheme argument list (and metadata), and modify + ! GFS_surface_compsites to receive the individual components and calculate an all-grid value + diag_qss = .false. !GJF: saturation specific humidities are calculated by LSM, sea surface, and sea ice schemes in + ! GFS-based suites + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + its = 1 + ims = 1 + ite = im + ime = im + + do i=its, ite + if (flag_iter(i)) then + !GJF: Perform data preparation that is the same for all surface types + + pspc(i) = psfc(i)*10. ! convert from Pa to cgs + pkmax(i) = prsl1(i)*10. ! convert from Pa to cgs + + upc(i) = u1(i)*100. ! convert from m s-1 to cm s-1 + vpc(i) = v1(i)*100. ! convert from m s-1 to cm s-1 + + !GJF: wind speed at the lowest model layer is calculated in a scheme prior to this (if this scheme + ! is part of a GFS-based suite), but it is recalculated here because this one DOES NOT include + ! a convective wind enhancement component (convective gustiness factor) to follow the original + ! GFDL surface layer scheme; this may not be necessary + wspd(i) = sqrt(u1(i)*u1(i) + v1(i)*v1(i)) + wspd(i) = amax1(wspd(i),1.0) !wspd is in m s-1 + + !Wang: use previous u10 v10 to compute wind10, input to MFLUX2 to compute z0 (for first time step, u10 and v10 may be zero) + wind10(i)=sqrt(u10(i)*u10(i)+v10(i)*v10(i)) !m s-1 + + !Wang: calulate height of the first half level + ! if (wind10(i) <= 1.0e-10 .or. wind10(i) > 150.0) then + ! zhalf = -rd*t1(i)*alog(pkmax(i)/pspc(i))/grav !m + ! endif + + !GJF: rather than calculate the height of the first half level, if it is precalculated + ! in a different scheme, pass it in and use it; note that in FV3, calculating via the hypsometric equation + ! occasionally produced values much shallower than those passed in + !zkmax(i) = -rd*t1(i)*alog(pkmax(i)/pspc(i))/grav !m + zkmax(i) = z1(i) + z1_cm(i) = 100.0*z1(i) + + !GJF: this drag coefficient lower limit was suggested by Chunxi Zhang via his module_sf_sfclayrev.f90 + cdlimit = 1.0e-5/zkmax(i) + + !slwdc... GFDL downward net flux in units of cal/(cm**2/min) + !also divide by 10**4 to convert from /m**2 to /cm**2 + slwdc(i)=gsw(i)+glw(i) + slwdc(i)=0.239*60.*slwdc(i)*1.e-4 + + !GJF: these variables should be passed in if these options are used + charn(i) = 0.0 !used with wave coupling (iwavecpl == 1) + msang(i) = 0.0 !used with wave coupling (iwavecpl == 1) + scurx(i) = 0.0 !used with ocean currents? (lcurr_sf == T) + scury(i) = 0.0 !used with ocean currents? (lcurr_sf == T) + + if (diag_qss) then + esat = fpvs(t1(i)) + qgh(i) = ep2*esat/(psfc(i)-esat) + end if + + !GJF: these vars are not needed in a GFS-based suite + !rho1(i)=prsl1(i)/(rd*t1(i)*(1.+ep1*q1(i))) + !cpm(i)=cp*(1.+0.8*q1(i)) + + !GJF: perform data preparation that depends on surface types and call the mflux2 subroutine for each surface type + ! Note that this is different than the original WRF module_sf_gfdl.F where mflux2 is called once for all surface + ! types, with negative roughness lengths denoting open ocean. + if (dry(i)) then + !GJF: from WRF's module_sf_gfdl.F + smcdry=drysmc(isltyp(i)) + smcmax=maxsmc(isltyp(i)) + wetc(i)=(smois(i,1)-smcdry)/(smcmax-smcdry) + wetc(i)=amin1(1.,amax1(wetc(i),0.)) + + !GJF: the lower boundary temperature passed in to MFLUX2 either follows GFS: + tstrc(i) = 0.5*(tskin_lnd(i) + tsurf_lnd(i)) !averaging tskin_lnd and tsurf_lnd as in GFS surface layer breaks ntsflg functionality + !GJF: or WRF module_sf_gfdl.F: + !tstrc(i) = tskin_lnd(i) + + !GJF: Roughness Length Limitation section + ! The WRF version of module_sf_gfdl.F has no checks on the roughness lengths prior to entering MFLUX2. + ! The following limits were placed on roughness lengths from the GFS surface layer scheme at the suggestion + ! of Chunxi Zhang. Using the GFDL surface layer without such checks can lead to instability in the UFS. + + !znt_lnd is in cm, z0max/ztmax are in m at this point + z0max(i) = max(1.0e-6, min(0.01 * znt_lnd(i), zkmax(i))) + + tem1 = 1.0 - shdmax(i) + tem2 = tem1 * tem1 + tem1 = 1.0 - tem2 + + if( ivegsrc == 1 ) then + if (vegtype(i) == 10) then + z0max(i) = exp( tem2*log01 + tem1*log07 ) + elseif (vegtype(i) == 6) then + z0max(i) = exp( tem2*log01 + tem1*log05 ) + elseif (vegtype(i) == 7) then + ! z0max(i) = exp( tem2*log01 + tem1*log01 ) + z0max(i) = 0.01 + elseif (vegtype(i) == 16) then + ! z0max(i) = exp( tem2*log01 + tem1*log01 ) + z0max(i) = 0.01 + else + z0max(i) = exp( tem2*log01 + tem1*log(z0max(i)) ) + endif + elseif (ivegsrc == 2 ) then + if (vegtype(i) == 7) then + z0max(i) = exp( tem2*log01 + tem1*log07 ) + elseif (vegtype(i) == 8) then + z0max(i) = exp( tem2*log01 + tem1*log05 ) + elseif (vegtype(i) == 9) then + ! z0max(i) = exp( tem2*log01 + tem1*log01 ) + z0max(i) = 0.01 + elseif (vegtype(i) == 11) then + ! z0max(i) = exp( tem2*log01 + tem1*log01 ) + z0max(i) = 0.01 + else + z0max(i) = exp( tem2*log01 + tem1*log(z0max(i)) ) + endif + endif + + z0max(i) = max(z0max(i), 1.0e-6) + + ! czilc = 10.0 ** (- (0.40/0.07) * z0) ! fei's canopy height dependance of czil + czilc = 0.8 + + tem1 = 1.0 - sigmaf(i) + ztmax(i) = z0max(i)*exp( - tem1*tem1 & + & * czilc*karman*sqrt(ustar_lnd(i)*(0.01/1.5e-05))) + ztmax(i) = max(ztmax(i), 1.0e-6) + + !GJF: from WRF's module_sf_gfdl.F + if (wind10(i) <= 1.0e-10 .or. wind10(i) > 150.0) then + !GJF: why not use wspd(i) to save compute? + wind10(i)=sqrt(u1(i)*u1(i)+v1(i)*v1(i))*alog(10.0/z0max(i))/alog(z1(i)/z0max(i)) !m s-1 + end if + wind10(i)=wind10(i)*100.0 !convert from m/s to cm/s + + ztmax(i) = ztmax(i)*100.0 !convert from m to cm + z0max(i) = z0max(i)*100.0 !convert from m to cm + + call mflux2 (fxh(i), fxe(i), fxmx(i), fxmy(i), cdm_lnd(i), rib_lnd(i), & + xxfh(i), ztmax(i), z0max(i), tstrc(i), & + pspc(i), pkmax(i), wetc(i), slwdc(i), z1_cm(i), icoef_sf, iwavecpl, lcurr_sf, charn(i), msang(i), & + scurx(i), scury(i), pert_Cd, ens_random_seed, ens_Cdamp, upc(i), vpc(i), t1(i), q1(i), & + dt, wind10(i), xxfh2(i), ntsflg, sfenth, tzot(i), errmsg, & + errflg) + if (errflg /= 0) return + + !GJF: this is broken when tstrc is set to an average of two variables + if (ntsflg==1) then + tskin_lnd(i) = tstrc(i) ! gopal's doing + end if + + if (diag_wind10m) then + u10_lnd(i) = u1(i)*(0.01*wind10(i)/wspd(i)) + v10_lnd(i) = v1(i)*(0.01*wind10(i)/wspd(i)) + end if + + !GJF: these variables are not needed in a GFS-based suite, but are found in WRF's module_sf_gfdl.F and kept in comments for legacy + !gz1oz0(i) = alog(zkmax(i)/(0.01*znt_lnd(i))) + !taux(i) = fxmx(i)/10. ! gopal's doing for Ocean coupling + !tauy(i) = fxmy(i)/10. ! gopal's doing for Ocean coupling + + fm_lnd(i) = karman/sqrt(cdm_lnd(i)) + fh_lnd(i) = karman*xxfh(i) + + !GJF: Other CCPP schemes (PBL) ask for fm/fh instead of psim/psih + !psim_lnd(i)=gz1oz0(i)-fm_lnd(i) + !psih_lnd(i)=gz1oz0(i)-fh_lnd(i) + + fh2_lnd(i) = karman*xxfh2(i) + ch_lnd(i) = karman*karman/(fm_lnd(i) * fh_lnd(i)) + + !GJF: these bounds on drag coefficients are from Chunxi Zhang's module_sf_sfclayrev.f90 + cdm_lnd(i) = max(cdm_lnd(i), cdlimit) + cdm_lnd(i) = min(cdm_lnd(i), 0.1) + ch_lnd(i) = max(ch_lnd(i), cdlimit) + ch_lnd(i) = min(ch_lnd(i), 0.1) + !GJF: this bound is from WRF's module_sf_gfdl.F (I'm not sure if both are needed or which is more restrictive.) + ch_lnd(i) = min(ch_lnd(i), 0.05/wspd(i)) + + !GJF: from WRF's module_sf_gfdl.F + ustar_lnd(i) = 0.01*sqrt(cdm_lnd(i)* & + (upc(i)*upc(i) + vpc(i)*vpc(i))) + !GJF: from Chunxi Zhang's module_sf_sfclayrev.f90 (I'm not sure it's necessary.) + ustar_lnd(i) = amax1(ustar_lnd(i),0.001) + + stress_lnd(i) = cdm_lnd(i)*wspd(i)*wspd(i) + + !GJF: from WRF's module_sf_gfdl.F + ! convert cd, ch to values at 10m, for output + cd10 = cdm_lnd(i) + if ( wind10(i) .ge. 0.1 ) then + cd10=cdm_lnd(i)* (wspd(i)/(0.01*wind10(i)) )**2 + !tmp9=0.01*abs(tzot(i)) + !ch_out(i)=ch_lnd(i)*(wspd(i)/(0.01*wind10(i)) ) * & + ! (alog(zkmax(i)/tmp9)/alog(10.0/tmp9)) + end if + fm10_lnd(i) = karman/sqrt(cd10) + + !GJF: conductances aren't used in other CCPP schemes, but this limit + ! might be able to replace the limits on drag coefficients above + + !chs_lnd(i)=ch_lnd(i)*wspd (i) !conductance + !chs2_lnd(i)=ustar_lnd(i)*karman/fh2_lnd(i) !2m conductance + + !!!2014-0922 cap CHS over land points + ! chs_lnd(i)=amin1(chs_lnd(i), 0.05) + ! chs2_lnd(i)=amin1(chs2_lnd(i), 0.05) + ! if (chs2_lnd(i) < 0) chs2_lnd(i)=1.0e-6 + + if (diag_qss) then + esat = fpvs(tskin_lnd(i)) + qss_lnd(i) = ep2*esat/(psfc(i)-esat) + end if + + !GJF: not used in CCPP + !flhc_lnd(i)=cpm(i)*rho1(i)*chs_lnd(i) + !flqc_lnd(i)=rho1(i)*chs_lnd(i) + !cqs2_lnd(i)=chs2_lnd(i) + end if !dry + + if (icy(i)) then + !GJF: from WRF's module_sf_gfdl.F + smcdry=drysmc(isltyp(i)) + smcmax=maxsmc(isltyp(i)) + wetc(i)=(smois(i,1)-smcdry)/(smcmax-smcdry) + wetc(i)=amin1(1.,amax1(wetc(i),0.)) + + + !GJF: the lower boundary temperature passed in to MFLUX2 either follows GFS: + tstrc(i) = 0.5*(tskin_ice(i) + tsurf_ice(i)) !averaging tskin_ice and tsurf_ice as in GFS surface layer breaks ntsflg functionality + !GJF: or WRF module_sf_gfdl.F: + !tstrc(i) = tskin_ice(i) + !averaging tskin_ice and tsurf_ice as in GFS surface layer breaks ntsflg functionality + + !GJF: Roughness Length Limitation section + ! The WRF version of module_sf_gfdl.F has no checks on the roughness lengths prior to entering MFLUX2. + ! The following limits were placed on roughness lengths from the GFS surface layer scheme at the suggestion + ! of Chunxi Zhang. Using the GFDL surface layer without such checks can lead to instability in the UFS. + + !znt_ice is in cm, z0max/ztmax are in m at this point + z0max(i) = max(1.0e-6, min(0.01 * znt_ice(i), zkmax(i))) + !** xubin's new z0 over land and sea ice + tem1 = 1.0 - shdmax(i) + tem2 = tem1 * tem1 + tem1 = 1.0 - tem2 + + if( ivegsrc == 1 ) then + z0max(i) = exp( tem2*log01 + tem1*log(z0max(i)) ) + elseif (ivegsrc == 2 ) then + z0max(i) = exp( tem2*log01 + tem1*log(z0max(i)) ) + endif + + z0max(i) = max(z0max(i), 1.0e-6) + + ! czilc = 10.0 ** (- (0.40/0.07) * z0) ! fei's canopy height + ! dependance of czil + czilc = 0.8 + + tem1 = 1.0 - sigmaf(i) + ztmax(i) = z0max(i)*exp( - tem1*tem1 & + & * czilc*karman*sqrt(ustar_ice(i)*(0.01/1.5e-05))) + ztmax(i) = max(ztmax(i), 1.0e-6) + + + !GJF: from WRF's module_sf_gfdl.F + if (wind10(i) <= 1.0e-10 .or. wind10(i) > 150.0) then + !GJF: why not use wspd(i) to save compute? + wind10(i)=sqrt(u1(i)*u1(i)+v1(i)*v1(i))*alog(10.0/z0max(i))/alog(z1(i)/z0max(i)) + end if + wind10(i)=wind10(i)*100.0 !! m/s to cm/s + + ztmax(i) = ztmax(i)*100.0 !m to cm + z0max(i) = z0max(i)*100.0 !m to cm + + call mflux2 (fxh(i), fxe(i), fxmx(i), fxmy(i), cdm_ice(i), rib_ice(i), & + xxfh(i), ztmax(i), z0max(i), tstrc(i), & + pspc(i), pkmax(i), wetc(i), slwdc(i), z1_cm(i), icoef_sf, iwavecpl, lcurr_sf, charn(i), msang(i), & + scurx(i), scury(i), pert_Cd, ens_random_seed, ens_Cdamp, upc(i), vpc(i), t1(i), q1(i), & + dt, wind10(i), xxfh2(i), ntsflg, sfenth, tzot(i), errmsg, & + errflg) + if (errflg /= 0) return + + !GJF: this is broken when tstrc is set to an average of two variables + if (ntsflg==1) then + tskin_ice(i) = tstrc(i) ! gopal's doing + end if + + if (diag_wind10m) then + u10_ice(i) = u1(i)*(0.01*wind10(i)/wspd(i)) + v10_ice(i) = v1(i)*(0.01*wind10(i)/wspd(i)) + end if + + !GJF: these variables are not needed in a GFS-based suite, but are found in WRF's module_sf_gfdl.F and kept in comments for legacy + !gz1oz0(i) = alog(zkmax(i)/znt_ice(i)) + !taux(i) = fxmx(i)/10. ! gopal's doing for Ocean coupling + !tauy(i) = fxmy(i)/10. ! gopal's doing for Ocean coupling + + fm_ice(i) = karman/sqrt(cdm_ice(i)) + fh_ice(i) = karman*xxfh(i) + + !Other CCPP schemes (PBL) ask for fm/fh instead of psim/psih + !psim_ice(i)=gz1oz0(i)-fm_ice(i) + !psih_ice(i)=gz1oz0(i)-fh_ice(i) + + fh2_ice(i) = karman*xxfh2(i) + ch_ice(i) = karman*karman/(fm_ice(i) * fh_ice(i)) + + !GJF: these bounds on drag coefficients are from Chunxi Zhang's module_sf_sfclayrev.f90 + cdm_ice(i) = max(cdm_ice(i), cdlimit) + cdm_ice(i) = min(cdm_ice(i), 0.1) + ch_ice(i) = max(ch_ice(i), cdlimit) + ch_ice(i) = min(ch_ice(i), 0.1) + !GJF: this bound is from WRF's module_sf_gfdl.F (I'm not sure if both are needed or which is more restrictive.) + ch_ice(i) = min(ch_ice(i), 0.05/wspd(i)) + + ustar_ice(i) = 0.01*sqrt(cdm_ice(i)* & + (upc(i)*upc(i) + vpc(i)*vpc(i))) + !GJF: from Chunxi Zhang's module_sf_sfclayrev.f90 (I'm not sure it's necessary.) + ustar_ice(i) = amax1(ustar_ice(i),0.001) + + stress_ice(i) = cdm_ice(i)*wspd(i)*wspd(i) + + !GJF: from WRF's module_sf_gfdl.F + !!! convert cd, ch to values at 10m, for output + cd10 = cdm_ice(i) + if ( wind10(i) .ge. 0.1 ) then + cd10=cdm_ice(i)* (wspd(i)/(0.01*wind10(i)) )**2 + !tmp9=0.01*abs(tzot(i)) + !ch_out(i)=ch_ice(i)*(wspd(i)/(0.01*wind10(i)) ) * & + ! (alog(zkmax(i)/tmp9)/alog(10.0/tmp9)) + end if + fm10_ice(i) = karman/sqrt(cd10) + + !GJF: conductances aren't used in other CCPP schemes + !chs_ice(i)=ch_ice(i)*wspd (i) !conductance + !chs2_ice(i)=ustar_ice(i)*karman/fh2_ice(i) !2m conductance + + if (diag_qss) then + esat = fpvs(tskin_ice(i)) + qss_ice(i) = ep2*esat/(psfc(i)-esat) + end if + + !flhc_ice(i)=cpm(i)*rho1(i)*chs_ice(i) + !flqc_ice(i)=rho1(i)*chs_ice(i) + !cqs2_ice(i)=chs2_ice(i) + end if !ice + + if (wet(i)) then + wetc(i) = 1.0 + + !GJF: the lower boundary temperature passed in to MFLUX2 either follows GFS: + tstrc(i) = 0.5*(tskin_ocn(i) + tsurf_ocn(i)) !averaging tskin_ocn and tsurf_ocn as in GFS surface layer breaks ntsflg functionality + !GJF: or WRF module_sf_gfdl.F: + !tstrc(i) = tskin_ocn(i) + + !GJF: from WRF's module_sf_gfdl.F + if (wind10(i) <= 1.0e-10 .or. wind10(i) > 150.0) then + wind10(i)=sqrt(u1(i)*u1(i)+v1(i)*v1(i))*alog(10.0/(0.01*znt_ocn(i)))/alog(z1(i)/(0.01*znt_ocn(i))) + end if + wind10(i)=wind10(i)*100.0 !! m/s to cm/s + + !GJF: mflux2 expects negative roughness length for ocean points + znt_ocn(i) = -znt_ocn(i) + + call mflux2 (fxh(i), fxe(i), fxmx(i), fxmy(i), cdm_ocn(i), rib_ocn(i), & + xxfh(i), znt_ocn(i), mznt(i), tstrc(i), & + pspc(i), pkmax(i), wetc(i), slwdc(i), z1_cm(i), icoef_sf, iwavecpl, lcurr_sf, charn(i), msang(i), & + scurx(i), scury(i), pert_Cd, ens_random_seed, ens_Cdamp, upc(i), vpc(i), t1(i), q1(i), & + dt, wind10(i), xxfh2(i), ntsflg, sfenth, tzot(i), errmsg, & + errflg) + if (errflg /= 0) return + + !GJF: this is broken when tstrc is set to an average of two variables + if (ntsflg==1) then + tskin_ocn(i) = tstrc(i) ! gopal's doing + end if + + znt_ocn(i)= abs(znt_ocn(i)) + mznt(i)= abs(mznt(i)) + + !GJF: these bounds on ocean roughness lengths are from Chunxi Zhang's module_sf_sfclayrev.f90 (in cm) + znt_ocn(i)=min(2.85e-1,max(znt_ocn(i),1.27e-5)) + + if (diag_wind10m) then + u10_ocn(i) = u1(i)*(0.01*wind10(i)/wspd(i)) + v10_ocn(i) = v1(i)*(0.01*wind10(i)/wspd(i)) + end if + + !GJF: these variables are not needed in a GFS-based suite, but are found in WRF's module_sf_gfdl.F and kept in comments for legacy + !gz1oz0(i) = alog(zkmax(i)/znt_ocn(i)) + !taux(i) = fxmx(i)/10. ! gopal's doing for Ocean coupling + !tauy(i) = fxmy(i)/10. ! gopal's doing for Ocean coupling + + fm_ocn(i) = karman/sqrt(cdm_ocn(i)) + fh_ocn(i) = karman*xxfh(i) + + !Other CCPP schemes (PBL) ask for fm/fh instead of psim/psih + !psim_ocn(i)=gz1oz0(i)-fm_ocn(i) + !psih_ocn(i)=gz1oz0(i)-fh_ocn(i) + + fh2_ocn(i) = karman*xxfh2(i) + ch_ocn(i) = karman*karman/(fm_ocn(i) * fh_ocn(i)) + + !GJF: these bounds on drag coefficients are from Chunxi Zhang's module_sf_sfclayrev.f90 + cdm_ocn(i) = max(cdm_ocn(i), cdlimit) + cdm_ocn(i) = min(cdm_ocn(i), 0.1) + ch_ocn(i) = max(ch_ocn(i), cdlimit) + ch_ocn(i) = min(ch_ocn(i), 0.1) + !GJF: this bound is from WRF's module_sf_gfdl.F (I'm not sure if both are needed or which is more restrictive.) + ch_ocn(i) = min(ch_ocn(i), 0.05/wspd(i)) + + ustar_ocn(i) = 0.01*sqrt(cdm_ocn(i)* & + (upc(i)*upc(i) + vpc(i)*vpc(i))) + !GJF: from Chunxi Zhang's module_sf_sfclayrev.f90 (I'm not sure it's necessary.) + ustar_ocn(i) = amax1(ustar_ocn(i),0.001) + + stress_ocn(i) = cdm_ocn(i)*wspd(i)*wspd(i) + + !GJF: from WRF's module_sf_gfdl.F + !!! convert cd, ch to values at 10m, for output + cd10 = cdm_ocn(i) + if ( wind10(i) .ge. 0.1 ) then + cd10=cdm_ocn(i)* (wspd(i)/(0.01*wind10(i)) )**2 + !tmp9=0.01*abs(tzot(i)) + !ch_out(i)=ch_ocn(i)*(wspd(i)/(0.01*wind10(i)) ) * & + ! (alog(zkmax(i)/tmp9)/alog(10.0/tmp9)) + end if + fm10_ocn(i) = karman/sqrt(cd10) + + !GJF: conductances aren't used in other CCPP schemes + !chs_ocn(i)=ch_ocn(i)*wspd (i) !conductance + !chs2_ocn(i)=ustar_ocn(i)*karman/fh2_ocn(i) !2m conductance + + if (diag_qss) then + esat = fpvs(tskin_ocn(i)) + qss_ocn(i) = ep2*esat/(psfc(i)-esat) + end if + end if !wet + + !flhc_ocn(i)=cpm(i)*rho1(i)*chs_ocn(i) + !flqc_ocn(i)=rho1(i)*chs_ocn(i) + !cqs2_ocn(i)=chs2_ocn(i) + end if !flag_iter + end do + + !GJF: this code has not been updated since GFS suites don't require this; one would need to have different values of hfx, qfx, lh for each surface type + ! if (isfflx.eq.0) then + ! do i=its,ite + ! hfx(i)=0. + ! lh(i)=0. + ! qfx(i)=0. + ! enddo + ! else + ! do i=its,ite + ! if(islmsk == 0) then + ! !water + ! hfx(i)= -10.*cp*fxh(i) + ! else if (islmsk == 1) then + ! hfx(i)= -10.*cp*fxh(i) + ! hfx(i)=amax1(hfx(i),-250.) + ! end if + ! qfx(j)=-10.*fxe(i) + ! qfx(i)=amax1(qfx(i),0.) + ! lh(i)=xlv*qfx(i) + ! enddo + ! endif + + + end subroutine gfdl_sfc_layer_run + +!--------------------------------- +!GJF (2020/04/21): The starting point for the MFLUX2 subroutine here was module_sf_gfdl.F in WRF + SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !mzoc KWON + pspc,pkmax,wetc,slwdc,z1, & + icoef_sf,iwavecpl,lcurr_sf,alpha,gamma,xcur,ycur, & + pert_Cd, ens_random_seed, ens_Cdamp, & + upc,vpc,tpc,rpc,dt,wind10,xxfh2,ntsflg,sfenth, & + tzot, errmsg, errflg) + +!------------------------------------------------------------------------ +! +! MFLUX2 computes surface fluxes of momentum, heat,and moisture +! using monin-obukhov. the roughness length "z0" is prescribed +! over land and over ocean "z0" is computed using charnocks formula. +! the universal functions (from similarity theory approach) are +! those of hicks. This is Bob's doing. +! +!------------------------------------------------------------------------ + + USE module_sf_exchcoef + IMPLICIT NONE + +!----------------------------------------------------------------------- +! user interface variables +!----------------------------------------------------------------------- + !GJF: This subroutine was converted to expect data from a single point instead of a horizontal array to accommodate a fractional landmask + !integer,intent(in) :: ims,ime + !integer,intent(in) :: its,ite + integer, parameter :: ims = 1 + integer, parameter :: ime = 1 + integer, parameter :: its = 1 + integer, parameter :: ite = 1 + integer,intent(in) :: ntsflg + integer,intent(in) :: icoef_sf + integer,intent(in) :: iwavecpl + logical,intent(in) :: lcurr_sf + logical,intent(in) :: pert_Cd + integer,intent(in) :: ens_random_seed + real(kind=kind_phys),intent(in) :: ens_Cdamp + + real(kind=kind_phys), intent (out), dimension (ims :ime ) :: fxh + real(kind=kind_phys), intent (out), dimension (ims :ime ) :: fxe + real(kind=kind_phys), intent (out), dimension (ims :ime ) :: fxmx + real(kind=kind_phys), intent (out), dimension (ims :ime ) :: fxmy + real(kind=kind_phys), intent (inout), dimension (ims :ime ) :: cdm +! real, intent (out), dimension (ims :ime ) :: cdm2 + real(kind=kind_phys), intent (out), dimension (ims :ime ) :: rib + real(kind=kind_phys), intent (out), dimension (ims :ime ) :: xxfh + real(kind=kind_phys), intent (out), dimension (ims :ime ) :: xxfh2 + real(kind=kind_phys), intent (out), dimension (ims :ime ) :: wind10 + + real(kind=kind_phys), intent ( inout), dimension (ims :ime ) :: zoc,mzoc !KWON + real(kind=kind_phys), intent ( inout), dimension (ims :ime ) :: tzot !WANG + real(kind=kind_phys), intent ( inout), dimension (ims :ime ) :: tstrc + + real(kind=kind_phys), intent ( in) :: dt + real(kind=kind_phys), intent ( in) :: sfenth + real(kind=kind_phys), intent ( in), dimension (ims :ime ) :: pspc + real(kind=kind_phys), intent ( in), dimension (ims :ime ) :: pkmax + real(kind=kind_phys), intent ( in), dimension (ims :ime ) :: wetc + real(kind=kind_phys), intent ( in), dimension (ims :ime ) :: slwdc + real(kind=kind_phys), intent ( in), dimension (ims :ime ) :: alpha, gamma + real(kind=kind_phys), intent ( in), dimension (ims :ime ) :: xcur, ycur + real(kind=kind_phys), intent ( in), dimension (ims :ime ) :: z1 + + real(kind=kind_phys), intent ( in), dimension (ims :ime ) :: upc + real(kind=kind_phys), intent ( in), dimension (ims :ime ) :: vpc + real(kind=kind_phys), intent ( in), dimension (ims :ime ) :: tpc + real(kind=kind_phys), intent ( in), dimension (ims :ime ) :: rpc + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +!----------------------------------------------------------------------- +! internal variables +!----------------------------------------------------------------------- + + integer, parameter :: icntx = 30 + + integer, dimension(1 :ime) :: ifz + integer, dimension(1 :ime) :: indx + integer, dimension(1 :ime) :: istb + integer, dimension(1 :ime) :: it + integer, dimension(1 :ime) :: iutb + + real(kind=kind_phys), dimension(1 :ime) :: aap + real(kind=kind_phys), dimension(1 :ime) :: bq1 + real(kind=kind_phys), dimension(1 :ime) :: bq1p + real(kind=kind_phys), dimension(1 :ime) :: delsrad + real(kind=kind_phys), dimension(1 :ime) :: ecof + real(kind=kind_phys), dimension(1 :ime) :: ecofp + real(kind=kind_phys), dimension(1 :ime) :: estso + real(kind=kind_phys), dimension(1 :ime) :: estsop + real(kind=kind_phys), dimension(1 :ime) :: fmz1 + real(kind=kind_phys), dimension(1 :ime) :: fmz10 + real(kind=kind_phys), dimension(1 :ime) :: fmz2 + real(kind=kind_phys), dimension(1 :ime) :: fmzo1 + real(kind=kind_phys), dimension(1 :ime) :: foft + real(kind=kind_phys), dimension(1 :ime) :: foftm + real(kind=kind_phys), dimension(1 :ime) :: frac + real(kind=kind_phys), dimension(1 :ime) :: land + real(kind=kind_phys), dimension(1 :ime) :: pssp + real(kind=kind_phys), dimension(1 :ime) :: qf + real(kind=kind_phys), dimension(1 :ime) :: rdiff + real(kind=kind_phys), dimension(1 :ime) :: rho + real(kind=kind_phys), dimension(1 :ime) :: rkmaxp + real(kind=kind_phys), dimension(1 :ime) :: rstso + real(kind=kind_phys), dimension(1 :ime) :: rstsop + real(kind=kind_phys), dimension(1 :ime) :: sf10 + real(kind=kind_phys), dimension(1 :ime) :: sf2 + real(kind=kind_phys), dimension(1 :ime) :: sfm + real(kind=kind_phys), dimension(1 :ime) :: sfzo + real(kind=kind_phys), dimension(1 :ime) :: sgzm + real(kind=kind_phys), dimension(1 :ime) :: slwa + real(kind=kind_phys), dimension(1 :ime) :: szeta + real(kind=kind_phys), dimension(1 :ime) :: szetam + real(kind=kind_phys), dimension(1 :ime) :: t1 + real(kind=kind_phys), dimension(1 :ime) :: t2 + real(kind=kind_phys), dimension(1 :ime) :: tab1 + real(kind=kind_phys), dimension(1 :ime) :: tab2 + real(kind=kind_phys), dimension(1 :ime) :: tempa1 + real(kind=kind_phys), dimension(1 :ime) :: tempa2 + real(kind=kind_phys), dimension(1 :ime) :: theta + real(kind=kind_phys), dimension(1 :ime) :: thetap + real(kind=kind_phys), dimension(1 :ime) :: tsg + real(kind=kind_phys), dimension(1 :ime) :: tsm + real(kind=kind_phys), dimension(1 :ime) :: tsp + real(kind=kind_phys), dimension(1 :ime) :: tss + real(kind=kind_phys), dimension(1 :ime) :: ucom + real(kind=kind_phys), dimension(1 :ime) :: uf10 + real(kind=kind_phys), dimension(1 :ime) :: uf2 + real(kind=kind_phys), dimension(1 :ime) :: ufh + real(kind=kind_phys), dimension(1 :ime) :: ufm + real(kind=kind_phys), dimension(1 :ime) :: ufzo + real(kind=kind_phys), dimension(1 :ime) :: ugzm + real(kind=kind_phys), dimension(1 :ime) :: uzeta + real(kind=kind_phys), dimension(1 :ime) :: uzetam + real(kind=kind_phys), dimension(1 :ime) :: vcom + real(kind=kind_phys), dimension(1 :ime) :: vrtkx + real(kind=kind_phys), dimension(1 :ime) :: vrts + real(kind=kind_phys), dimension(1 :ime) :: wind + real(kind=kind_phys), dimension(1 :ime) :: windp + real(kind=kind_phys), dimension(1 :ime) :: wind10p !WANG, 10m wind previous step + real(kind=kind_phys), dimension(1 :ime) :: uvs1 +! real(kind=kind_phys), dimension(1 :ime) :: xxfh + real(kind=kind_phys), dimension(1 :ime) :: xxfm + real(kind=kind_phys), dimension(1 :ime) :: xxsh + real(kind=kind_phys), dimension(1 :ime) :: z10 + real(kind=kind_phys), dimension(1 :ime) :: z2 + real(kind=kind_phys), dimension(1 :ime) :: zeta + real(kind=kind_phys), dimension(1 :ime) :: zkmax + + real(kind=kind_phys), dimension(1 :ime) :: pss + real(kind=kind_phys), dimension(1 :ime) :: tstar + real(kind=kind_phys), dimension(1 :ime) :: ukmax + real(kind=kind_phys), dimension(1 :ime) :: vkmax + real(kind=kind_phys), dimension(1 :ime) :: tkmax + real(kind=kind_phys), dimension(1 :ime) :: rkmax + real(kind=kind_phys), dimension(1 :ime) :: zot + real(kind=kind_phys), dimension(1 :ime) :: fhzo1 + real(kind=kind_phys), dimension(1 :ime) :: sfh + + real(kind=kind_phys) :: ux13, yo, y,xo,x,ux21,ugzzo,ux11,ux12,uzetao,xnum,alll + real(kind=kind_phys) :: ux1,ugz,x10,uzo,uq,ux2,ux3,xtan,xden,y10,uzet1o,ugz10 + real(kind=kind_phys) :: szet2, zal2,ugz2 + real(kind=kind_phys) :: rovcp,boycon,cmo2,psps1,zog,enrca,rca,cmo1,amask,en,ca,a,c + real(kind=kind_phys) :: sgz,zal10,szet10,fmz,szo,sq,fmzo,rzeta1,zal1g,szetao,rzeta2,zal2g + real(kind=kind_phys) :: hcap,xks,pith,teps,diffot,delten,alevp,psps2,alfus,nstep + real(kind=kind_phys) :: shfx,sigt4,reflect + real(kind=kind_phys) :: cor1,cor2,szetho,zal2gh,cons_p000001,cons_7,vis,ustar,restar,rat + real(kind=kind_phys) :: wndm,ckg + real(kind=kind_phys) :: windmks,znott,znotm + real(kind=kind_phys) :: ubot, vbot + integer:: i,j,ii,iq,nnest,icnt,ngd,ip + +!----------------------------------------------------------------------- +! internal variables +!----------------------------------------------------------------------- + + real(kind=kind_phys), dimension (223) :: tab + real(kind=kind_phys), dimension (223) :: table + real(kind=kind_phys), dimension (101) :: tab11 + real(kind=kind_phys), dimension (41) :: table4 + real(kind=kind_phys), dimension (42) :: tab3 + real(kind=kind_phys), dimension (54) :: table2 + real(kind=kind_phys), dimension (54) :: table3 + real(kind=kind_phys), dimension (74) :: table1 + real(kind=kind_phys), dimension (80) :: tab22 + + character(len=255) :: message + + equivalence (tab(1),tab11(1)) + equivalence (tab(102),tab22(1)) + equivalence (tab(182),tab3(1)) + equivalence (table(1),table1(1)) + equivalence (table(75),table2(1)) + equivalence (table(129),table3(1)) + equivalence (table(183),table4(1)) + + data amask/ -98.0/ +!----------------------------------------------------------------------- +! tables used to obtain the vapor pressures or saturated vapor +! pressure +!----------------------------------------------------------------------- + + data tab11/21*0.01403,0.01719,0.02101,0.02561,0.03117,0.03784, & + &.04584,.05542,.06685,.08049,.09672,.1160,.1388,.1658,.1977,.2353, & + &.2796,.3316,.3925,.4638,.5472,.6444,.7577,.8894,1.042,1.220,1.425, & + &1.662,1.936,2.252,2.615,3.032,3.511,4.060,4.688,5.406,6.225,7.159, & + &8.223,9.432,10.80,12.36,14.13,16.12,18.38,20.92,23.80,27.03,30.67, & + &34.76,39.35,44.49,50.26,56.71,63.93,71.98,80.97,90.98,102.1,114.5, & + &128.3,143.6,160.6,179.4,200.2,223.3,248.8,276.9,307.9,342.1,379.8, & + &421.3,466.9,517.0,572.0,632.3,698.5,770.9,850.2,937.0,1032./ + + data tab22/1146.6,1272.0,1408.1,1556.7,1716.9,1890.3,2077.6,2279.6 & + &,2496.7,2729.8,2980.0,3247.8,3534.1,3839.8,4164.8,4510.5,4876.9, & + &5265.1,5675.2,6107.8,6566.2,7054.7,7575.3,8129.4,8719.2,9346.5, & + &10013.,10722.,11474.,12272.,13119.,14017.,14969.,15977.,17044., & + &18173.,19367.,20630.,21964.,23373.,24861.,26430.,28086.,29831., & + &31671.,33608.,35649.,37796.,40055.,42430.,44927.,47551.,50307., & + &53200.,56236.,59422.,62762.,66264.,69934.,73777.,77802.,82015., & + &86423.,91034.,95855.,100890.,106160.,111660.,117400.,123400., & + &129650.,136170.,142980.,150070.,157460.,165160.,173180.,181530., & + &190220.,199260./ + + data tab3/208670.,218450.,228610.,239180.,250160.,261560.,273400., & + &285700.,298450.,311690.,325420.,339650.,354410.,369710.,385560., & + &401980.,418980.,436590.,454810.,473670.,493170.,513350.,534220., & + &555800.,578090.,601130.,624940.,649530.,674920.,701130.,728190., & + &756110.,784920.,814630.,845280.,876880.,909450.,943020.,977610., & + &1013250.,1049940.,1087740./ + + data table1/20*0.0,.3160e-02,.3820e-02,.4600e-02,.5560e-02,.6670e-02, & + & .8000e-02,.9580e-02,.1143e-01,.1364e-01,.1623e-01,.1928e-01, & + &.2280e-01,.2700e-01,.3190e-01,.3760e-01,.4430e-01,.5200e-01, & + &.6090e-01,.7130e-01,.8340e-01,.9720e-01,.1133e+00,.1317e-00, & + &.1526e-00,.1780e-00,.2050e-00,.2370e-00,.2740e-00,.3160e-00, & + &.3630e-00,.4170e-00,.4790e-00,.5490e-00,.6280e-00,.7180e-00, & + &.8190e-00,.9340e-00,.1064e+01,.1209e+01,.1368e+01,.1560e+01, & + &.1770e+01,.1990e+01,.2260e+01,.2540e+01,.2880e+01,.3230e+01, & + &.3640e+01,.4090e+01,.4590e+01,.5140e+01,.5770e+01,.6450e+01, & + &.7220e+01/ + + data table2/.8050e+01,.8990e+01,.1001e+02,.1112e+02,.1240e+02, & + &.1380e+02,.1530e+02,.1700e+02,.1880e+02,.2080e+02,.2310e+02, & + &.2550e+02,.2810e+02,.3100e+02,.3420e+02,.3770e+02,.4150e+02, & + &.4560e+02,.5010e+02,.5500e+02,.6030e+02,.6620e+02,.7240e+02, & + &.7930e+02,.8680e+02,.9500e+02,.1146e+03,.1254e+03,.1361e+03, & + &.1486e+03,.1602e+03,.1734e+03,.1873e+03,.2020e+03,.2171e+03, & + &.2331e+03,.2502e+03,.2678e+03,.2863e+03,.3057e+03,.3250e+03, & + &.3457e+03,.3664e+03,.3882e+03,.4101e+03,.4326e+03,.4584e+03, & + &.4885e+03,.5206e+03,.5541e+03,.5898e+03,.6273e+03,.6665e+03, & + &.7090e+03/ + + data table3/.7520e+03,.7980e+03,.8470e+03,.8980e+03,.9520e+03, & + &.1008e+04,.1067e+04,.1129e+04,.1194e+04,.1263e+04,.1334e+04, & + &.1409e+04,.1488e+04,.1569e+04,.1656e+04,.1745e+04,.1840e+04, & + &.1937e+04,.2041e+04,.2147e+04,.2259e+04,.2375e+04,.2497e+04, & + &.2624e+04,.2756e+04,.2893e+04,.3036e+04,.3186e+04,.3340e+04, & + &.3502e+04,.3670e+04,.3843e+04,.4025e+04,.4213e+04,.4408e+04, & + &.4611e+04,.4821e+04,.5035e+04,.5270e+04,.5500e+04,.5740e+04, & + &.6000e+04,.6250e+04,.6520e+04,.6810e+04,.7090e+04,.7390e+04, & + &.7700e+04,.8020e+04,.8350e+04,.8690e+04,.9040e+04,.9410e+04, & + &.9780e+04/ + + data table4/.1016e+05,.1057e+05,.1098e+05,.1140e+05,.1184e+05, & + &.1230e+05,.1275e+05,.1324e+05,.1373e+05,.1423e+05,.1476e+05, & + &.1530e+05,.1585e+05,.1642e+05,.1700e+05,.1761e+05,.1822e+05, & + &.1886e+05,.1950e+05,.2018e+05,.2087e+05,.2158e+05,.2229e+05, & + &.2304e+05,.2381e+05,.2459e+05,.2539e+05,.2621e+05,.2706e+05, & + &.2792e+05,.2881e+05,.2971e+05,.3065e+05,.3160e+05,.3257e+05, & + &.3357e+05,.3459e+05,.3564e+05,.3669e+05,.3780e+05,.0000e+00/ +! +! spcify constants needed by MFLUX2 +! +!GJF: should send through argument list, but these have nonstandard units + real,parameter :: cp = 1.00464e7 + real,parameter :: g = 980.6 + real,parameter :: rgas = 2.87e6 + real,parameter :: og = 1./g + integer :: ntstep = 0 + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 +! +#if HWRF==1 + real*8 :: gasdev,ran1 !zhang + real :: rr !zhang + logical,save :: pert_Cd_local !zhang + CHARACTER(len=3) :: env_memb,env_pp + integer,save :: ens_random_seed_local,env_pp_local !zhang + integer :: ensda_physics_pert !zhang + real,save :: ens_Cdamp_local !zhang + data ens_random_seed_local/0/ + data env_pp_local/0/ + if ( ens_random_seed_local .eq. 0 ) then + CALL nl_get_ensda_physics_pert(1,ensda_physics_pert) + ens_random_seed_local=ens_random_seed + env_pp_local=ensda_physics_pert + pert_Cd_local=.false. + ens_Cdamp_local=0.0 +! env_pp=1: do physics perturbations for ensda members, ens_random_seed must be 99 + if ( env_pp_local .eq. 1 ) then + if ( ens_random_seed .ne. 99 ) then + pert_Cd_local=.true. + ens_Cdamp_local=ens_Cdamp + else +! ens_random_seed=99 do physics perturbation for ensemble forecasts, env_pp must be zero + ens_random_seed_local=ens_random_seed + pert_Cd_local=pert_Cd + ens_Cdamp_local=ens_Cdamp + endif + else + ens_random_seed_local=ens_random_seed + pert_Cd_local=pert_Cd + ens_Cdamp_local=ens_Cdamp + endif + print*, "Cd ===", ens_random_seed_local,pert_Cd_local,ens_Cdamp_local,ensda_physics_pert + endif +#endif + +! character*10 routine +! routine = 'mflux2' +! +!------------------------------------------------------------------------ +! set water availability constant "ecof" and land mask "land". +! limit minimum wind speed to 100 cm/s +!------------------------------------------------------------------------ +! constants for 10 m winds (correction for knots +! + cor1 = .120 + cor2 = 720. +! KWON : remove the artificial increase of 10m wind speed over 60kts +! which comes from GFDL hurricane model + cor1 = 0. + cor2 = 0. +! + + do i = its,ite + z10(i) = 1000. + z2 (i) = 200. + pss(i) = pspc(i) + tstar(i) = tstrc(i) + + if ( lcurr_sf .and. zoc(i) .le. 0.0 ) then + ubot = upc(i) - xcur(i) * 100.0 + vbot = vpc(i) - ycur(i) * 100.0 +! ubot = upc(i) +! vbot = vpc(i) + else + ubot = upc(i) + vbot = vpc(i) + endif + uvs1(i)= amax1( SQRT(ubot*ubot + & + vbot*vbot), 100.0) + if ( iwavecpl .eq. 1 .and. zoc(i) .le. 0.0 ) then + ukmax(i) = ( ubot * cos(gamma(i)) - & + vbot * sin(gamma(i)) ) & + * cos(gamma(i)) + vkmax(i) = ( vbot * cos(gamma(i)) - & + ubot * sin(gamma(i)) ) & + * cos(gamma(i)) + + else + ukmax(i) = ubot + vkmax(i) = vbot + endif + +! ukmax(i) = upc(i) +! vkmax(i) = vpc(i) + tkmax(i) = tpc(i) + rkmax(i) = rpc(i) + enddo + + do i = its,ite + windp(i) = SQRT(ukmax(i)*ukmax(i) + vkmax(i)*vkmax(i)) + wind (i) = amax1(windp(i),100.) + +!! use wind10 previous step + wind10p(i) = wind10(i) !! cm/s + wind10p(i) = amax1(wind10p(i),100.) +!! + + if (zoc(i) .LT. amask) zoc(i) = -0.0185*0.001*wind10p(i)*wind10p(i)*og + if (zoc(i) .GT. 0.0) then + ecof(i) = wetc(i) + land(i) = 1.0 + zot (i) = zoc(i) + else + ecof(i) = wetc(i) + land(i) = 0.0 + windmks=wind10p(i)*.01 + if ( iwavecpl .eq. 1 ) then + call znot_wind10m(windmks,znott,znotm,icoef_sf) + !Check if Charnock parameter ratio is received in a proper range. + if ( alpha(i) .ge. 0.2 .and. alpha(i) .le. 5. ) then + znotm = znotm*alpha(i) + endif + zoc(i) = -100.*znotm + zot(i) = -100* znott + else + call znot_wind10m(windmks,znott,znotm,icoef_sf) + zoc(i) = -100.*znotm + zot(i) = -100* znott + endif + endif +!------------------------------------------------------------------------ +! where necessary modify zo values over ocean. +!------------------------------------------------------------------------ +! + mzoc(i) = zoc(i) !FOR SAVE MOMENTUM Zo + tzot(i) = zot(i) !output wang + enddo + +!------------------------------------------------------------------------ +! define constants: +! a and c = constants used in evaluating universal function for +! stable case +! ca = karmen constant +! cm01 = constant part of vertical integral of universal +! function; stable case ( 0.5 < zeta < or = 10.0) +! cm02 = constant part of vertical integral of universal +! function; stable case ( zeta > 10.0) +!------------------------------------------------------------------------ + + en = 2. + c = .76 + a = 5. + ca = .4 + cmo1 = .5*a - 1.648 + cmo2 = 17.193 + .5*a - 10.*c + boycon = .61 + rovcp=rgas/cp + + do i = its,ite + theta(i) = tkmax(i)/((pkmax(i)/pspc(i))**rovcp) + vrtkx(i) = 1.0 + boycon*rkmax(i) + !zkmax(i) = -rgas*tkmax(i)*alog(pkmax(i)/pspc(i))*og + zkmax(i) = z1(i) !use precalculated height of first model layer center + enddo + +!------------------------------------------------------------------------ +! get saturation mixing ratios at surface +!------------------------------------------------------------------------ + + do i = its,ite + tsg (i) = tstar(i) + tab1 (i) = tstar(i) - 153.16 + it (i) = IFIX(tab1(i)) + tab2 (i) = tab1(i) - FLOAT(it(i)) + t1 (i) = tab(min(223,max(1,it(i) + 1))) + t2 (i) = table(min(223,max(1,it(i) + 1))) + estso(i) = t1(i) + tab2(i)*t2(i) + psps1 = (pss(i) - estso(i)) + if(psps1 .EQ. 0.0)then + psps1 = .1 + endif + rstso(i) = 0.622*estso(i)/psps1 + vrts (i) = 1. + boycon*ecof(i)*rstso(i) + enddo + +!------------------------------------------------------------------------ +! check if consideration of virtual temperature changes stability. +! if so, set "dthetav" to near neutral value (1.0e-4). also check +! for very small lapse rates; if ABS(tempa1) <1.0e-4 then +! tempa1=1.0e-4 +!------------------------------------------------------------------------ + + do i = its,ite + tempa1(i) = theta(i)*vrtkx(i) - tstar(i)*vrts(i) + tempa2(i) = tempa1(i)*(theta(i) - tstar(i)) + if (tempa2(i) .LT. 0.) tempa1(i) = 1.0e-4 + tab1(i) = ABS(tempa1(i)) + if (tab1(i) .LT. 1.0e-4) tempa1(i) = 1.0e-4 +!------------------------------------------------------------------------ +! compute bulk richardson number "rib" at each point. if "rib" +! exceeds 95% of critical richardson number "tab1" then "rib = tab1" +!------------------------------------------------------------------------ + + rib (i) = g*zkmax(i)*tempa1(i)/ & + (tkmax(i)*vrtkx(i)*wind(i)*wind(i)) + tab2(i) = ABS(zoc(i)) + tab1(i) = 0.95/(c*(1. - tab2(i)/zkmax(i))) + if (rib(i) .GT. tab1(i)) rib(i) = tab1(i) + enddo + + do i = its,ite + zeta(i) = ca*rib(i)/0.03 + enddo + +!------------------------------------------------------------------------ +! begin looping through points on line, solving wegsteins iteration +! for zeta at each point, and using hicks functions +!------------------------------------------------------------------------ + +!------------------------------------------------------------------------ +! set initial guess of zeta=non - dimensional height "szeta" for +! stable points +!------------------------------------------------------------------------ + + rca = 1./ca + enrca = en*rca +! turn off interfacial layer by zeroing out enrca + enrca = 0.0 + zog = .0185*og + +!------------------------------------------------------------------------ +! stable points +!------------------------------------------------------------------------ + + ip = 0 + do i = its,ite + if (zeta(i) .GE. 0.0) then + ip = ip + 1 + istb(ip) = i + endif + enddo + + if (ip .EQ. 0) go to 170 + do i = 1,ip + szetam(i) = 1.0e+30 + sgzm(i) = 0.0e+00 + szeta(i) = zeta(istb(i)) + ifz(i) = 1 + enddo + +!------------------------------------------------------------------------ +! begin wegstein iteration for "zeta" at stable points using +! hicks(1976) +!------------------------------------------------------------------------ + + do icnt = 1,icntx + do i = 1,ip + if (ifz(i) .EQ. 0) go to 80 + zal1g = ALOG(szeta(i)) + if (szeta(i) .LE. 0.5) then + fmz1(i) = (zal1g + a*szeta(i))*rca + else if (szeta(i) .GT. 0.5 .AND. szeta(i) .LE. 10.) then + rzeta1 = 1./szeta(i) + fmz1(i) = (8.*zal1g + 4.25*rzeta1 - & + 0.5*rzeta1*rzeta1 + cmo1)*rca + else if (szeta(i) .GT. 10.) then + fmz1(i) = (c*szeta(i) + cmo2)*rca + endif + szetao = ABS(zoc(istb(i)))/zkmax(istb(i))*szeta(i) + zal2g = ALOG(szetao) + if (szetao .LE. 0.5) then + fmzo1(i) = (zal2g + a*szetao)*rca + sfzo (i) = 1. + a*szetao + else if (szetao .GT. 0.5 .AND. szetao .LE. 10.) then + rzeta2 = 1./szetao + fmzo1(i) = (8.*zal2g + 4.25*rzeta2 - & + 0.5*rzeta2*rzeta2 + cmo1)*rca + sfzo (i) = 8.0 - 4.25*rzeta2 + rzeta2*rzeta2 + else if (szetao .GT. 10.) then + fmzo1(i) = (c*szetao + cmo2)*rca + sfzo (i) = c*szetao + endif + + +! compute heat & moisture parts of zot.. for calculation of sfh + + szetho = ABS(zot(istb(i)))/zkmax(istb(i))*szeta(i) + zal2gh = ALOG(szetho) + if (szetho .LE. 0.5) then + fhzo1(i) = (zal2gh + a*szetho)*rca + sfzo (i) = 1. + a*szetho + else if (szetho .GT. 0.5 .AND. szetho .LE. 10.) then + rzeta2 = 1./szetho + fhzo1(i) = (8.*zal2gh + 4.25*rzeta2 - & + 0.5*rzeta2*rzeta2 + cmo1)*rca + sfzo (i) = 8.0 - 4.25*rzeta2 + rzeta2*rzeta2 + else if (szetho .GT. 10.) then + fhzo1(i) = (c*szetho + cmo2)*rca + sfzo (i) = c*szetho + endif + +!------------------------------------------------------------------------ +! compute universal function at 10 meters for diagnostic purposes +!------------------------------------------------------------------------ + + szet10 = ABS(z10(istb(i)))/zkmax(istb(i))*szeta(i) + zal10 = ALOG(szet10) + if (szet10 .LE. 0.5) then + fmz10(i) = (zal10 + a*szet10)*rca + else if (szet10 .GT. 0.5 .AND. szet10 .LE. 10.) then + rzeta2 = 1./szet10 + fmz10(i) = (8.*zal10 + 4.25*rzeta2 - & + 0.5*rzeta2*rzeta2 + cmo1)*rca + else if (szet10 .GT. 10.) then + fmz10(i) = (c*szet10 + cmo2)*rca + endif + sf10(i) = fmz10(i) - fmzo1(i) +! compute 2m values for diagnostics in HWRF + szet2 = ABS(z2 (istb(i)))/zkmax(istb(i))*szeta(i) + zal2 = ALOG(szet2 ) + if (szet2 .LE. 0.5) then + fmz2 (i) = (zal2 + a*szet2 )*rca + else if (szet2 .GT. 0.5 .AND. szet2 .LE. 2.) then + rzeta2 = 1./szet2 + fmz2 (i) = (8.*zal2 + 4.25*rzeta2 - & + 0.5*rzeta2*rzeta2 + cmo1)*rca + else if (szet2 .GT. 2.) then + fmz2 (i) = (c*szet2 + cmo2)*rca + endif + sf2 (i) = fmz2 (i) - fmzo1(i) + + sfm(i) = fmz1(i) - fmzo1(i) + sfh(i) = fmz1(i) - fhzo1(i) + sgz = ca*rib(istb(i))*sfm(i)*sfm(i)/ & + (sfh(i) + enrca*sfzo(i)) + fmz = (sgz - szeta(i))/szeta(i) + fmzo = ABS(fmz) + if (fmzo .GE. 5.0e-5) then + sq = (sgz - sgzm(i))/(szeta(i) - szetam(i)) + if(sq .EQ. 1) then + write(errmsg,'(*(a))') 'NCO ERROR DIVIDE BY ZERO IN gfdl_sfc_layer.F90/MFLUX2 (STABLE CASE)'// & + 'sq is 1 ',fmzo,sgz,sgzm(i),szeta(i),szetam(i) + errflg = 1 + return + endif + szetam(i) = szeta(i) + szeta (i) = (sgz - szeta(i)*sq)/(1.0 - sq) + sgzm (i) = sgz + else + ifz(i) = 0 + endif +80 continue + enddo + enddo + + do i = 1,ip + if (ifz(i) .GE. 1) go to 110 + enddo + + go to 130 + +110 continue + + write(errmsg,'(*(a))') 'NON-CONVERGENCE FOR STABLE ZETA IN gfdl_sfc_layer.F90/MFLUX2' + errflg = 1 + return +! call MPI_CLOSE(1,routine) + +!------------------------------------------------------------------------ +! update "zo" for ocean points. "zo"cannot be updated within the +! wegsteins iteration as the scheme (for the near neutral case) +! can become unstable +!------------------------------------------------------------------------ + +130 continue + do i = 1,ip + szo = zoc(istb(i)) + if (szo .LT. 0.0) then + wndm=wind(istb(i))*0.01 + if(wndm.lt.15.0) then + ckg=0.0185*og + else + ckg=(sfenth*(4*0.000308*wndm) + (1.-sfenth)*0.0185 )*og + endif + + szo = - ckg*wind(istb(i))*wind(istb(i))/ & + (sfm(i)*sfm(i)) + cons_p000001 = .000001 + cons_7 = 7. + vis = 1.4E-1 + + ustar = sqrt( -szo / zog) + restar = -ustar * szo / vis + restar = max(restar,cons_p000001) +! Rat taken from Zeng, Zhao and Dickinson 1997 + rat = 2.67 * restar ** .25 - 2.57 + rat = min(rat ,cons_7) !constant + rat=0. + zot(istb(i)) = szo * exp(-rat) + else + zot(istb(i)) = zoc(istb(i)) + endif + +! in hwrf thermal znot is loaded back into the zoc array for next step + zoc(istb(i)) = szo + enddo + + do i = 1,ip + xxfm(istb(i)) = sfm(i) + xxfh(istb(i)) = sfh(i) + xxfh2(istb(i)) = sf2 (i) + xxsh(istb(i)) = sfzo(i) + enddo + +!------------------------------------------------------------------------ +! obtain wind at 10 meters for diagnostic purposes +!------------------------------------------------------------------------ + + do i = 1,ip + wind10(istb(i)) = sf10(i)*uvs1(istb(i))/sfm(i) + wind10(istb(i)) = wind10(istb(i)) * 1.944 + if(wind10(istb(i)) .GT. 6000.0) then + wind10(istb(i))=wind10(istb(i))+wind10(istb(i))*cor1 & + - cor2 + endif +! the above correction done by GFDL in centi-kts!!!-change back + wind10(istb(i)) = wind10(istb(i)) / 1.944 + enddo + +!------------------------------------------------------------------------ +! unstable points +!------------------------------------------------------------------------ + +170 continue + + iq = 0 + do i = its,ite + if (zeta(i) .LT. 0.0) then + iq = iq + 1 + iutb(iq) = i + endif + enddo + + if (iq .EQ. 0) go to 290 + do i = 1,iq + uzeta (i) = zeta(iutb(i)) + ifz (i) = 1 + uzetam(i) = 1.0e+30 + ugzm (i) = 0.0e+00 + enddo + +!------------------------------------------------------------------------ +! begin wegstein iteration for "zeta" at unstable points using +! hicks functions +!------------------------------------------------------------------------ + + do icnt = 1,icntx + do i = 1,iq + if (ifz(i) .EQ. 0) go to 200 + ugzzo = ALOG(zkmax(iutb(i))/ABS(zot(iutb(i)))) + uzetao = ABS(zot(iutb(i)))/zkmax(iutb(i))*uzeta(i) + ux11 = 1. - 16.*uzeta(i) + ux12 = 1. - 16.*uzetao + y = SQRT(ux11) + yo = SQRT(ux12) + ufzo(i) = 1./yo + ux13 = (1. + y)/(1. + yo) + ux21 = ALOG(ux13) + ufh(i) = (ugzzo - 2.*ux21)*rca +! recompute scalers for ufm in terms of mom znot... zoc + ugzzo = ALOG(zkmax(iutb(i))/ABS(zoc(iutb(i)))) + uzetao = ABS(zoc(iutb(i)))/zkmax(iutb(i))*uzeta(i) + ux11 = 1. - 16.*uzeta(i) + ux12 = 1. - 16.*uzetao + y = SQRT(ux11) + yo = SQRT(ux12) + ux13 = (1. + y)/(1. + yo) + ux21 = ALOG(ux13) +! ufzo(i) = 1./yo + x = SQRT(y) + xo = SQRT(yo) + xnum = (x**2 + 1.)*((x + 1.)**2) + xden = (xo**2 + 1.)*((xo + 1.)**2) + xtan = ATAN(x) - ATAN(xo) + ux3 = ALOG(xnum/xden) + ufm(i) = (ugzzo - ux3 + 2.*xtan)*rca + +!------------------------------------------------------------------------ +! obtain ten meter winds for diagnostic purposes +!------------------------------------------------------------------------ + + ugz10 = ALOG(z10(iutb(i))/ABS(zoc(iutb(i)))) + uzet1o = ABS(z10(iutb(i)))/zkmax(iutb(i))*uzeta(i) + uzetao = ABS(zoc(iutb(i)))/zkmax(iutb(i))*uzeta(i) + ux11 = 1. - 16.*uzet1o + ux12 = 1. - 16.*uzetao + y = SQRT(ux11) + y10 = SQRT(ux12) + ux13 = (1. + y)/(1. + y10) + ux21 = ALOG(ux13) + x = SQRT(y) + x10 = SQRT(y10) + xnum = (x**2 + 1.)*((x + 1.)**2) + xden = (x10**2 + 1.)*((x10 + 1.)**2) + xtan = ATAN(x) - ATAN(x10) + ux3 = ALOG(xnum/xden) + uf10(i) = (ugz10 - ux3 + 2.*xtan)*rca + +! obtain 2m values for diagnostics... + + + ugz2 = ALOG(z2 (iutb(i))/ABS(zoc(iutb(i)))) + uzet1o = ABS(z2 (iutb(i)))/zkmax(iutb(i))*uzeta(i) + uzetao = ABS(zoc(iutb(i)))/zkmax(iutb(i))*uzeta(i) + ux11 = 1. - 16.*uzet1o + ux12 = 1. - 16.*uzetao + y = SQRT(ux11) + yo = SQRT(ux12) + ux13 = (1. + y)/(1. + yo) + ux21 = ALOG(ux13) + uf2 (i) = (ugzzo - 2.*ux21)*rca + + + ugz = ca*rib(iutb(i))*ufm(i)*ufm(i)/(ufh(i) + enrca*ufzo(i)) + ux1 = (ugz - uzeta(i))/uzeta(i) + ux2 = ABS(ux1) + if (ux2 .GE. 5.0e-5) then + uq = (ugz - ugzm(i))/(uzeta(i) - uzetam(i)) + uzetam(i) = uzeta(i) + if(uq .EQ. 1) then + write(errmsg,'(*(a))') 'NCO ERROR DIVIDE BY ZERO IN gfdl_sfc_layer.F90/MFLUX2 (UNSTABLE CASE)'// & + 'uq is 1 ',ux2,ugz,ugzm(i),uzeta(i),uzetam(i) + errflg = 1 + return + endif + uzeta (i) = (ugz - uzeta(i)*uq)/(1.0 - uq) + ugzm (i) = ugz + else + ifz(i) = 0 + endif +200 continue + enddo + enddo + + + do i = 1,iq + if (ifz(i) .GE. 1) go to 230 + enddo + + go to 250 + +230 continue + write(errmsg,'(*(a))') 'NON-CONVERGENCE FOR UNSTABLE ZETA IN ROW'// & + 'uq is 1 ',ux2,ugz,ugzm(i),uzeta(i),uzetam(i) + errflg = 1 + return + +! call MPI_CLOSE(1,routine) + +!------------------------------------------------------------------------ +! gather unstable values +!------------------------------------------------------------------------ + +250 continue + +!------------------------------------------------------------------------ +! update "zo" for ocean points. zo cannot be updated within the +! wegsteins iteration as the scheme (for the near neutral case) +! can become unstable. +!------------------------------------------------------------------------ + + do i = 1,iq + uzo = zoc(iutb(i)) + if (zoc(iutb(i)) .LT. 0.0) then + wndm=wind(iutb(i))*0.01 + if(wndm.lt.15.0) then + ckg=0.0185*og + else + ckg=(4*0.000308*wndm)*og + ckg=(sfenth*(4*0.000308*wndm) + (1.-sfenth)*0.0185 )*og + endif + uzo =-ckg*wind(iutb(i))*wind(iutb(i))/(ufm(i)*ufm(i)) + cons_p000001 = .000001 + cons_7 = 7. + vis = 1.4E-1 + + ustar = sqrt( -uzo / zog) + restar = -ustar * uzo / vis + restar = max(restar,cons_p000001) +! Rat taken from Zeng, Zhao and Dickinson 1997 + rat = 2.67 * restar ** .25 - 2.57 + rat = min(rat ,cons_7) !constant + rat=0.0 + zot(iutb(i)) = uzo * exp(-rat) + else + zot(iutb(i)) = zoc(iutb(i)) + endif +! in hwrf thermal znot is loaded back into the zoc array for next step + zoc(iutb(i)) = uzo + enddo + +!------------------------------------------------------------------------ +! obtain wind at ten meters for diagnostic purposes +!------------------------------------------------------------------------ + do i = 1,iq + wind10(iutb(i)) = uf10(i)*uvs1(iutb(i))/ufm(i) + wind10(iutb(i)) = wind10(iutb(i)) * 1.944 + if(wind10(iutb(i)) .GT. 6000.0) then + wind10(iutb(i))=wind10(iutb(i))+wind10(iutb(i))*cor1 & + - cor2 + endif +! the above correction done by GFDL in centi-kts!!!-change back + wind10(iutb(i)) = wind10(iutb(i)) / 1.944 + enddo + + do i = 1,iq + xxfm(iutb(i)) = ufm(i) + xxfh(iutb(i)) = ufh(i) + xxfh2(iutb(i)) = uf2 (i) + xxsh(iutb(i)) = ufzo(i) + enddo + +290 continue + + do i = its,ite + ucom(i) = ukmax(i) + vcom(i) = vkmax(i) + if (windp(i) .EQ. 0.0) then + windp(i) = 100.0 + ucom (i) = 100.0/SQRT(2.0) + vcom (i) = 100.0/SQRT(2.0) + endif + rho(i) = pss(i)/(rgas*(tsg(i) + enrca*(theta(i) - & + tsg(i))*xxsh(i)/(xxfh(i) + enrca*xxsh(i)))) + bq1(i) = wind(i)*rho(i)/(xxfm(i)*(xxfh(i) + enrca*xxsh(i))) + enddo + +! do land sfc temperature prediction if ntsflg=1 +! ntsflg = 1 ! gopal's doing + + if (ntsflg .EQ. 0) go to 370 + alll = 600. + xks = 0.01 + hcap = .5/2.39e-8 + pith = SQRT(4.*ATAN(1.0)) + alfus = alll/2.39e-8 + teps = 0.1 +! slwdc... in units of cal/min ???? +! slwa... in units of ergs/sec/cm*2 +! 1 erg=2.39e-8 cal +!------------------------------------------------------------------------ +! pack land and sea ice points +!------------------------------------------------------------------------ + + ip = 0 + do i = its,ite + if (land(i) .EQ. 1) then + ip = ip + 1 + indx (ip) = i +! slwa is defined as positive down.... + slwa (ip) = slwdc(i)/(2.39e-8*60.) + tss (ip) = tstar(i) + thetap (ip) = theta(i) + rkmaxp (ip) = rkmax(i) + aap (ip) = 5.673e-5 + pssp (ip) = pss(i) + ecofp (ip) = ecof(i) + estsop (ip) = estso(i) + rstsop (ip) = rstso(i) + bq1p (ip) = bq1(i) + bq1p (ip) = amax1(bq1p(ip),0.1e-3) + delsrad(ip) = dt *pith/(hcap*SQRT(3600.*24.*xks)) + endif + enddo + +!------------------------------------------------------------------------ +! initialize variables for first pass of iteration +!------------------------------------------------------------------------ + + do i = 1,ip + ifz (i) = 1 + tsm (i) = tss(i) + rdiff(i) = amin1(0.0,(rkmaxp(i) - rstsop(i))) + +300 format(2X, ' SURFACE EQUILIBRIUM CALCULATION ') + + foftm(i) = tss(i) + delsrad(i)*(slwa(i) - aap(i)*tsm(i)**4 - & + cp*bq1p(i)*(tsm(i) - thetap(i)) + ecofp(i)*alfus*bq1p(i)* & + rdiff(i)) + tsp(i) = foftm(i) + enddo + +!------------------------------------------------------------------------ +! do iteration to determine "tstar" at new time level +!------------------------------------------------------------------------ + + do icnt = 1,icntx + do i = 1,ip + if (ifz(i) .EQ. 0) go to 330 + tab1 (i) = tsp(i) - 153.16 + it (i) = IFIX(tab1(i)) + tab2 (i) = tab1(i) - FLOAT(it(i)) + t1 (i) = tab(min(223,max(1,it(i) + 1))) + t2 (i) = table(min(223,max(1,it(i) + 1))) + estsop(i) = t1(i) + tab2(i)*t2(i) + psps2 = (pssp(i) - estsop(i)) + if(psps2 .EQ. 0.0)then + psps2 = .1 + endif + rstsop(i) = 0.622*estsop(i)/psps2 + rdiff (i) = amin1(0.0,(rkmaxp(i) - rstsop(i))) + + foft(i) = tss(i) + delsrad(i)*(slwa(i) - aap(i)*tsp(i)**4 - & + cp*bq1p(i)*(tsp(i) - thetap(i)) + ecofp(i)*alfus*bq1p(i)* & + rdiff(i)) + + frac(i) = ABS((foft(i) - tsp(i))/tsp(i)) + +!------------------------------------------------------------------------ +! check for convergence of all points use wegstein iteration +!------------------------------------------------------------------------ + + if (frac(i) .GE. teps) then + qf (i) = (foft(i) - foftm(i))/(tsp(i) - tsm(i)) + tsm (i) = tsp(i) + tsp (i) = (foft(i) - tsp(i)*qf(i))/(1. - qf(i)) + foftm(i) = foft(i) + else + ifz(i) = 0 + endif +330 continue + enddo + enddo + +!------------------------------------------------------------------------ +! check for convergence of "t star" prediction +!------------------------------------------------------------------------ + + do i = 1,ip + if (ifz(i) .EQ. 1) then + write(errmsg,'(*(a))') 'NON-CONVERGENCE OF T* PREDICTED (T*,I) = ', & + tsp(i), i + errflg = 1 + return +! call MPI_CLOSE(1,routine) + endif + enddo + + do i = 1,ip + ii = indx(i) + tstrc(ii) = tsp (i) + enddo + +!------------------------------------------------------------------------ +! compute fluxes and momentum drag coef +!------------------------------------------------------------------------ + +370 continue + do i = its,ite +!!! + if ( iwavecpl .eq. 1 .and. zoc(i) .le. 0.0 ) then + windmks = wind10(i) * 0.01 + call znot_wind10m(windmks,znott,znotm,icoef_sf) + !Check if Charnock parameter ratio is received in a proper range. + if ( alpha(i) .ge. 0.2 .and. alpha(i) .le. 5. ) then + znotm = znotm*alpha(i) + endif + zoc(i) = -100.*znotm + zot(i) = -100* znott + endif +!!!! + fxh(i) = bq1(i)*(theta(i) - tsg(i)) + fxe(i) = ecof(i)*bq1(i)*(rkmax(i) - rstso(i)) + if (fxe(i) .GT. 0.0) fxe(i) = 0.0 + fxmx(i) = rho(i)/(xxfm(i)*xxfm(i))*wind(i)*wind(i)*ucom(i)/ & + windp(i) + fxmy(i) = rho(i)/(xxfm(i)*xxfm(i))*wind(i)*wind(i)*vcom(i)/ & + windp(i) + cdm(i) = 1./(xxfm(i)*xxfm(i)) +#if HWRF==1 +! randomly perturb the Cd +!zzz if( pert_Cd_local .and. ens_random_seed_local .gt. 0 ) then + if( pert_Cd_local ) then + ens_random_seed_local=ran1(-ens_random_seed_local)*1000 + rr=2.0*ens_Cdamp_local*ran1(-ens_random_seed_local)-ens_Cdamp_local + cdm(i) = cdm(i) *(1.0+rr) + endif +#endif + + enddo + ntstep = ntstep + 1 + return + end subroutine MFLUX2 + + end module gfdl_sfc_layer diff --git a/physics/gfdl_sfc_layer.meta b/physics/gfdl_sfc_layer.meta new file mode 100644 index 000000000..738216d1a --- /dev/null +++ b/physics/gfdl_sfc_layer.meta @@ -0,0 +1,801 @@ +[ccpp-arg-table] + name = gfdl_sfc_layer_init + type = scheme +[icoef_sf] + standard_name = flag_for_surface_roughness_option_over_ocean + long_name = surface roughness options over ocean + units = flag + dimensions = () + type = integer + intent = in + optional = F +[cplwav] + standard_name = flag_for_wave_coupling + long_name = flag controlling cplwav collection (default off) + units = flag + dimensions = () + type = logical + intent = in + optional = F +[cplwav2atm] + standard_name = flag_for_wave_coupling_to_atm + long_name = flag controlling ocean wave coupling to the atmosphere (default off) + units = flag + dimensions = () + type = logical + intent = in + optional = F +[lcurr_sf] + standard_name = flag_for_ocean_currents_in_surface_layer_scheme + long_name = flag for taking ocean currents into account in surface layer scheme + units = flag + dimensions = () + type = logical + intent = in + optional = F +[pert_cd] + standard_name = flag_for_perturbation_of_surface_drag_coefficient_for_momentum_in_air + long_name = flag for perturbing the surface drag coefficient for momentum in surface layer scheme + units = flag + dimensions = () + type = logical + intent = in + optional = F +[ntsflg] + standard_name = flag_for_updating_skin_temperatuer_in_surface_layer_scheme + long_name = flag for updating skin temperature in the surface layer scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-arg-table] + name = gfdl_sfc_layer_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[nsoil] + standard_name = soil_vertical_dimension + long_name = soil vertical layer dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[km] + standard_name = vertical_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in + optional = F +[xlat] + standard_name = latitude + long_name = latitude + units = radians + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[xlon] + standard_name = longitude + long_name = longitude + units = radians + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[flag_iter] + standard_name = flag_for_iteration + long_name = flag for iteration + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in + optional = F +[lsm] + standard_name = flag_for_land_surface_scheme + long_name = flag for land surface model + units = flag + dimensions = () + type = integer + intent = in + optional = F +[lsm_noah] + standard_name = flag_for_noah_land_surface_scheme + long_name = flag for NOAH land surface model + units = flag + dimensions = () + type = integer + intent = in + optional = F +[lsm_noahmp] + standard_name = flag_for_noahmp_land_surface_scheme + long_name = flag for NOAH MP land surface model + units = flag + dimensions = () + type = integer + intent = in + optional = F +[lsm_ruc] + standard_name = flag_for_ruc_land_surface_scheme + long_name = flag for RUC land surface model + units = flag + dimensions = () + type = integer + intent = in + optional = F +[lsm_noah_wrfv4] + standard_name = flag_for_noah_wrfv4_land_surface_scheme + long_name = flag for NOAH WRFv4 land surface model + units = flag + dimensions = () + type = integer + intent = in + optional = F +[icoef_sf] + standard_name = flag_for_surface_roughness_option_over_ocean + long_name = surface roughness options over ocean + units = flag + dimensions = () + type = integer + intent = in + optional = F +[cplwav] + standard_name = flag_for_wave_coupling + long_name = flag controlling cplwav collection (default off) + units = flag + dimensions = () + type = logical + intent = in + optional = F +[cplwav2atm] + standard_name = flag_for_wave_coupling_to_atm + long_name = flag controlling ocean wave coupling to the atmosphere (default off) + units = flag + dimensions = () + type = logical + intent = in + optional = F +[lcurr_sf] + standard_name = flag_for_ocean_currents_in_surface_layer_scheme + long_name = flag for taking ocean currents into account in surface layer scheme + units = flag + dimensions = () + type = logical + intent = in + optional = F +[pert_Cd] + standard_name = flag_for_perturbation_of_surface_drag_coefficient_for_momentum_in_air + long_name = flag for perturbing the surface drag coefficient for momentum in surface layer scheme + units = flag + dimensions = () + type = logical + intent = in + optional = F +[ntsflg] + standard_name = flag_for_updating_skin_temperatuer_in_surface_layer_scheme + long_name = flag for updating skin temperature in the surface layer scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[sfenth] + standard_name = enthalpy_flux_factor + long_name = enthalpy flux factor used in surface layer scheme + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[z1] + standard_name = height_above_ground_at_lowest_model_layer + long_name = height above ground at 1st model layer + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[shdmax] + standard_name = maximum_vegetation_area_fraction + long_name = max fractnl cover of green veg + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[ivegsrc] + standard_name = vegetation_type_dataset_choice + long_name = land use dataset choice + units = index + dimensions = () + type = integer + intent = in + optional = F +[vegtype] + standard_name = vegetation_type_classification + long_name = vegetation type at each grid cell + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in + optional = F +[sigmaf] + standard_name = bounded_vegetation_area_fraction + long_name = areal fractional cover of green vegetation bounded on the bottom + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[dt] + standard_name = time_step_for_physics + long_name = physics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[wet] + standard_name = flag_nonzero_wet_surface_fraction + long_name = flag indicating presence of some ocean or lake surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in + optional = F +[dry] + standard_name = flag_nonzero_land_surface_fraction + long_name = flag indicating presence of some land surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in + optional = F +[icy] + standard_name = flag_nonzero_sea_ice_surface_fraction + long_name = flag indicating presence of some sea ice surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in + optional = F +[isltyp] + standard_name = soil_type_classification + long_name = soil type at each grid cell + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in + optional = F +[rd] + standard_name = gas_constant_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[grav] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[ep1] + standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one + long_name = (rv/rd) - 1 (rv = ideal gas constant for water vapor) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[ep2] + standard_name = ratio_of_dry_air_to_water_vapor_gas_constants + long_name = rd/rv + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[smois] + standard_name = volume_fraction_of_soil_moisture + long_name = total soil moisture + units = frac + dimensions = (horizontal_loop_extent,soil_vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[psfc] + standard_name = surface_air_pressure + long_name = surface pressure + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[prsl1] + standard_name = air_pressure_at_lowest_model_layer + long_name = mean pressure at lowest model layer + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[q1] + standard_name = water_vapor_specific_humidity_at_lowest_model_layer + long_name = water vapor specific humidity at lowest model layer + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[t1] + standard_name = air_temperature_at_lowest_model_layer + long_name = 1st model layer air temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[u1] + standard_name = x_wind_at_lowest_model_layer + long_name = zonal wind at lowest model layer + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[v1] + standard_name = y_wind_at_lowest_model_layer + long_name = meridional wind at lowest model layer + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[u10] + standard_name = x_wind_at_10m + long_name = 10 meter u wind speed + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[v10] + standard_name = y_wind_at_10m + long_name = 10 meter v wind speed + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[gsw] + standard_name = surface_downwelling_shortwave_flux + long_name = surface downwelling shortwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[glw] + standard_name = surface_downwelling_longwave_flux + long_name = surface downwelling longwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[tsurf_ocn] + standard_name = surface_skin_temperature_after_iteration_over_ocean + long_name = surface skin temperature after iteration over ocean + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[tsurf_lnd] + standard_name = surface_skin_temperature_after_iteration_over_land + long_name = surface skin temperature after iteration over land + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[tsurf_ice] + standard_name = surface_skin_temperature_after_iteration_over_ice + long_name = surface skin temperature after iteration over ice + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[tskin_ocn] + standard_name = surface_skin_temperature_over_ocean_interstitial + long_name = surface skin temperature over ocean (temporary use as interstitial) + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tskin_lnd] + standard_name = surface_skin_temperature_over_land_interstitial + long_name = surface skin temperature over land (temporary use as interstitial) + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tskin_ice] + standard_name = surface_skin_temperature_over_ice_interstitial + long_name = surface skin temperature over ice (temporary use as interstitial) + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[ustar_ocn] + standard_name = surface_friction_velocity_over_ocean + long_name = surface friction velocity over ocean + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[ustar_lnd] + standard_name = surface_friction_velocity_over_land + long_name = surface friction velocity over land + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[ustar_ice] + standard_name = surface_friction_velocity_over_ice + long_name = surface friction velocity over ice + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[znt_ocn] + standard_name = surface_roughness_length_over_ocean_interstitial + long_name = surface roughness length over ocean (temporary use as interstitial) + units = cm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[znt_lnd] + standard_name = surface_roughness_length_over_land_interstitial + long_name = surface roughness length over land (temporary use as interstitial) + units = cm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[znt_ice] + standard_name = surface_roughness_length_over_ice_interstitial + long_name = surface roughness length over ice (temporary use as interstitial) + units = cm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[cdm_ocn] + standard_name = surface_drag_coefficient_for_momentum_in_air_over_ocean + long_name = surface exchange coeff for momentum over ocean + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[cdm_lnd] + standard_name = surface_drag_coefficient_for_momentum_in_air_over_land + long_name = surface exchange coeff for momentum over land + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[cdm_ice] + standard_name = surface_drag_coefficient_for_momentum_in_air_over_ice + long_name = surface exchange coeff for momentum over ice + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[stress_ocn] + standard_name = surface_wind_stress_over_ocean + long_name = surface wind stress over ocean + units = m2 s-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[stress_lnd] + standard_name = surface_wind_stress_over_land + long_name = surface wind stress over land + units = m2 s-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[stress_ice] + standard_name = surface_wind_stress_over_ice + long_name = surface wind stress over ice + units = m2 s-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[rib_ocn] + standard_name = bulk_richardson_number_at_lowest_model_level_over_ocean + long_name = bulk Richardson number at the surface over ocean + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[rib_lnd] + standard_name = bulk_richardson_number_at_lowest_model_level_over_land + long_name = bulk Richardson number at the surface over land + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[rib_ice] + standard_name = bulk_richardson_number_at_lowest_model_level_over_ice + long_name = bulk Richardson number at the surface over ice + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[fm_ocn] + standard_name = Monin_Obukhov_similarity_function_for_momentum_over_ocean + long_name = Monin-Obukhov similarity function for momentum over ocean + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[fm_lnd] + standard_name = Monin_Obukhov_similarity_function_for_momentum_over_land + long_name = Monin-Obukhov similarity function for momentum over land + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[fm_ice] + standard_name = Monin_Obukhov_similarity_function_for_momentum_over_ice + long_name = Monin-Obukhov similarity function for momentum over ice + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[fh_ocn] + standard_name = Monin_Obukhov_similarity_function_for_heat_over_ocean + long_name = Monin-Obukhov similarity function for heat over ocean + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[fh_lnd] + standard_name = Monin_Obukhov_similarity_function_for_heat_over_land + long_name = Monin-Obukhov similarity function for heat over land + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[fh_ice] + standard_name = Monin_Obukhov_similarity_function_for_heat_over_ice + long_name = Monin-Obukhov similarity function for heat over ice + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[fh2_ocn] + standard_name = Monin_Obukhov_similarity_function_for_heat_at_2m_over_ocean + long_name = Monin-Obukhov similarity parameter for heat at 2m over ocean + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[fh2_lnd] + standard_name = Monin_Obukhov_similarity_function_for_heat_at_2m_over_land + long_name = Monin-Obukhov similarity parameter for heat at 2m over land + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[fh2_ice] + standard_name = Monin_Obukhov_similarity_function_for_heat_at_2m_over_ice + long_name = Monin-Obukhov similarity parameter for heat at 2m over ice + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[ch_ocn] + standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air_over_ocean + long_name = surface exchange coeff heat & moisture over ocean + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[ch_lnd] + standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air_over_land + long_name = surface exchange coeff heat & moisture over land + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[ch_ice] + standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air_over_ice + long_name = surface exchange coeff heat & moisture over ice + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[fm10_ocn] + standard_name = Monin_Obukhov_similarity_function_for_momentum_at_10m_over_ocean + long_name = Monin-Obukhov similarity parameter for momentum at 10m over ocean + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[fm10_lnd] + standard_name = Monin_Obukhov_similarity_function_for_momentum_at_10m_over_land + long_name = Monin-Obukhov similarity parameter for momentum at 10m over land + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[fm10_ice] + standard_name = Monin_Obukhov_similarity_function_for_momentum_at_10m_over_ice + long_name = Monin-Obukhov similarity parameter for momentum at 10m over ice + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[qss_ocn] + standard_name = surface_specific_humidity_over_ocean + long_name = surface air saturation specific humidity over ocean + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys +[qss_lnd] + standard_name = surface_specific_humidity_over_land + long_name = surface air saturation specific humidity over land + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys +[qss_ice] + standard_name = surface_specific_humidity_over_ice + long_name = surface air saturation specific humidity over ice + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F diff --git a/physics/module_sf_exchcoef.f90 b/physics/module_sf_exchcoef.f90 new file mode 100755 index 000000000..0e3dae80c --- /dev/null +++ b/physics/module_sf_exchcoef.f90 @@ -0,0 +1,733 @@ +! This MODULE holds the routines that calculate air-sea exchange coefficients + +MODULE module_sf_exchcoef +CONTAINS + + SUBROUTINE znot_m_v1(uref,znotm) + IMPLICIT NONE + +! uref(m/s) : Reference level wind +! znotm(meter): Roughness scale for momentum +! Author : Biju Thomas on 02/07/2014 +! + + REAL, INTENT(IN) :: uref + REAL, INTENT(OUT):: znotm + REAL :: bs0, bs1, bs2, bs3, bs4, bs5, bs6 + REAL :: cf0, cf1, cf2, cf3, cf4, cf5, cf6 + + + bs0 = -8.367276172397277e-12 + bs1 = 1.7398510865876079e-09 + bs2 = -1.331896578363359e-07 + bs3 = 4.507055294438727e-06 + bs4 = -6.508676881906914e-05 + bs5 = 0.00044745137674732834 + bs6 = -0.0010745704660847233 + + cf0 = 2.1151080765239772e-13 + cf1 = -3.2260663894433345e-11 + cf2 = -3.329705958751961e-10 + cf3 = 1.7648562021709124e-07 + cf4 = 7.107636825694182e-06 + cf5 = -0.0013914681964973246 + cf6 = 0.0406766967657759 + + + IF ( uref .LE. 5.0 ) THEN + znotm = (0.0185 / 9.8*(7.59e-4*uref**2+2.46e-2*uref)**2) + ELSEIF (uref .GT. 5.0 .AND. uref .LT. 10.0) THEN + znotm =.00000235*(uref**2 - 25 ) + 3.805129199617346e-05 + ELSEIF ( uref .GE. 10.0 .AND. uref .LT. 60.0) THEN + znotm = bs6 + bs5*uref + bs4*uref**2 + bs3*uref**3 + bs2*uref**4 + & + bs1*uref**5 + bs0*uref**6 + ELSE + znotm = cf6 + cf5*uref + cf4*uref**2 + cf3*uref**3 + cf2*uref**4 + & + cf1*uref**5 + cf0*uref**6 + + END IF + + END SUBROUTINE znot_m_v1 + + SUBROUTINE znot_m_v0(uref,znotm) + IMPLICIT NONE + +! uref(m/s) : Reference level wind +! znotm(meter): Roughness scale for momentum +! Author : Biju Thomas on 02/07/2014 + + REAL, INTENT(IN) :: uref + REAL, INTENT(OUT):: znotm + REAL :: yz, y1, y2, y3, y4 + + yz = 0.0001344 + y1 = 3.015e-05 + y2 = 1.517e-06 + y3 = -3.567e-08 + y4 = 2.046e-10 + + IF ( uref .LT. 12.5 ) THEN + znotm = (0.0185 / 9.8*(7.59e-4*uref**2+2.46e-2*uref)**2) + ELSE IF ( uref .GE. 12.5 .AND. uref .LT. 30.0 ) THEN + znotm = (0.0739793 * uref -0.58)/1000.0 + ELSE + znotm = yz + uref*y1 + uref**2*y2 + uref**3*y3 + uref**4*y4 + END IF + + END SUBROUTINE znot_m_v0 + + + SUBROUTINE znot_t_v1(uref,znott) + IMPLICIT NONE + +! uref(m/s) : Reference level wind +! znott(meter): Roughness scale for temperature/moisture +! Author : Biju Thomas on 02/07/2014 + + REAL, INTENT(IN) :: uref + REAL, INTENT(OUT):: znott + REAL :: to0, to1, to2, to3 + REAL :: tr0, tr1, tr2, tr3 + REAL :: tn0, tn1, tn2, tn3, tn4, tn5 + REAL :: ta0, ta1, ta2, ta3, ta4, ta5, ta6 + REAL :: tt0, tt1, tt2, tt3, tt4, tt5, tt6, tt7 + + + tr0 = 6.451939325286488e-08 + tr1 = -7.306388137342143e-07 + tr2 = -1.3709065148333262e-05 + tr3 = 0.00019109962089098182 + + to0 = 1.4379320027061375e-08 + to1 = -2.0674525898850674e-07 + to2 = -6.8950970846611e-06 + to3 = 0.00012199648268521026 + + tn0 = 1.4023940955902878e-10 + tn1 = -1.4752557214976321e-08 + tn2 = 5.90998487691812e-07 + tn3 = -1.0920804077770066e-05 + tn4 = 8.898205876940546e-05 + tn5 = -0.00021123340439418298 + + tt0 = 1.92409564131838e-12 + tt1 = -5.765467086754962e-10 + tt2 = 7.276979099726975e-08 + tt3 = -5.002261599293387e-06 + tt4 = 0.00020220445539973736 + tt5 = -0.0048088230565883 + tt6 = 0.0623468551971189 + tt7 = -0.34019193746967424 + + ta0 = -1.7787470700719361e-10 + ta1 = 4.4691736529848764e-08 + ta2 = -3.0261975348463414e-06 + ta3 = -0.00011680322286017206 + ta4 = 0.024449377821884846 + ta5 = -1.1228628619105638 + ta6 = 17.358026773905973 + + IF ( uref .LE. 7.0 ) THEN + znott = (0.0185 / 9.8*(7.59e-4*uref**2+2.46e-2*uref)**2) + ELSEIF ( uref .GE. 7.0 .AND. uref .LT. 12.5 ) THEN + znott = tr3 + tr2*uref + tr1*uref**2 + tr0*uref**3 + ELSEIF ( uref .GE. 12.5 .AND. uref .LT. 15.0 ) THEN + znott = to3 + to2*uref + to1*uref**2 + to0*uref**3 + ELSEIF ( uref .GE. 15.0 .AND. uref .LT. 30.0) THEN + znott = tn5 + tn4*uref + tn3*uref**2 + tn2*uref**3 + tn1*uref**4 + & + tn0*uref**5 + ELSEIF ( uref .GE. 30.0 .AND. uref .LT. 60.0) THEN + znott = tt7 + tt6*uref + tt5*uref**2 + tt4*uref**3 + tt3*uref**4 + & + tt2*uref**5 + tt1*uref**6 + tt0*uref**7 + ELSE + znott = ta6 + ta5*uref + ta4*uref**2 + ta3*uref**3 + ta2*uref**4 + & + ta1*uref**5 + ta0*uref**6 + END IF + + END SUBROUTINE znot_t_v1 + + SUBROUTINE znot_t_v0(uref,znott) + IMPLICIT NONE + +! uref(m/s) : Reference level wind +! znott(meter): Roughness scale for temperature/moisture +! Author : Biju Thomas on 02/07/2014 + + REAL, INTENT(IN) :: uref + REAL, INTENT(OUT):: znott + + IF ( uref .LT. 7.0 ) THEN + znott = (0.0185 / 9.8*(7.59e-4*uref**2+2.46e-2*uref)**2) + ELSE + znott = (0.2375*exp(-0.5250*uref) + 0.0025*exp(-0.0211*uref))*0.01 + END IF + + END SUBROUTINE znot_t_v0 + + + SUBROUTINE znot_t_v2(uu,znott) + IMPLICIT NONE + +! uu in MKS +! znott in m +! Biju Thomas on 02/12/2015 +! + + REAL, INTENT(IN) :: uu + REAL, INTENT(OUT):: znott + REAL :: ta0, ta1, ta2, ta3, ta4, ta5, ta6 + REAL :: tb0, tb1, tb2, tb3, tb4, tb5, tb6 + REAL :: tt0, tt1, tt2, tt3, tt4, tt5, tt6 + + ta0 = 2.51715926619e-09 + ta1 = -1.66917514012e-07 + ta2 = 4.57345863551e-06 + ta3 = -6.64883696932e-05 + ta4 = 0.00054390175125 + ta5 = -0.00239645231325 + ta6 = 0.00453024927761 + + + tb0 = -1.72935914649e-14 + tb1 = 2.50587455802e-12 + tb2 = -7.90109676541e-11 + tb3 = -4.40976353607e-09 + tb4 = 3.68968179733e-07 + tb5 = -9.43728336756e-06 + tb6 = 8.90731312383e-05 + + tt0 = 4.68042680888e-14 + tt1 = -1.98125754931e-11 + tt2 = 3.41357133496e-09 + tt3 = -3.05130605309e-07 + tt4 = 1.48243563819e-05 + tt5 = -0.000367207751936 + tt6 = 0.00357204479347 + + IF ( uu .LE. 7.0 ) THEN + znott = (0.0185 / 9.8*(7.59e-4*uu**2+2.46e-2*uu)**2) + ELSEIF ( uu .GE. 7.0 .AND. uu .LT. 15. ) THEN + znott = ta6 + ta5*uu + ta4*uu**2 + ta3*uu**3 + ta2*uu**4 + & + ta1*uu**5 + ta0*uu**6 + ELSEIF ( uu .GE. 15.0 .AND. uu .LT. 60.0) THEN + znott = tb6 + tb5*uu + tb4*uu**2 + tb3*uu**3 + tb2*uu**4 + & + tb1*uu**5 + tb0*uu**6 + ELSE + znott = tt6 + tt5*uu + tt4*uu**2 + tt3*uu**3 + tt2*uu**4 + & + tt1*uu**5 + tt0*uu**6 + END IF + + END SUBROUTINE znot_t_v2 + + SUBROUTINE znot_m_v6(uref,znotm) + IMPLICIT NONE +! Calculate areodynamical roughness over water with input 10-m wind +! For low-to-moderate winds, try to match the Cd-U10 relationship from COARE V3.5 (Edson et al. 2013) +! For high winds, try to fit available observational data +! +! Bin Liu, NOAA/NCEP/EMC 2017 +! +! uref(m/s) : wind speed at 10-m height +! znotm(meter): areodynamical roughness scale over water +! + + REAL, INTENT(IN) :: uref + REAL, INTENT(OUT):: znotm + REAL :: p13, p12, p11, p10 + REAL :: p25, p24, p23, p22, p21, p20 + REAL :: p35, p34, p33, p32, p31, p30 + REAL :: p40 + + p13 = -1.296521881682694e-02 + p12 = 2.855780863283819e-01 + p11 = -1.597898515251717e+00 + p10 = -8.396975715683501e+00 + + p25 = 3.790846746036765e-10 + p24 = 3.281964357650687e-09 + p23 = 1.962282433562894e-07 + p22 = -1.240239171056262e-06 + p21 = 1.739759082358234e-07 + p20 = 2.147264020369413e-05 + + p35 = 1.840430200185075e-07 + p34 = -2.793849676757154e-05 + p33 = 1.735308193700643e-03 + p32 = -6.139315534216305e-02 + p31 = 1.255457892775006e+00 + p30 = -1.663993561652530e+01 + + p40 = 4.579369142033410e-04 + + if (uref >= 0.0 .and. uref <= 6.5 ) then + znotm = exp( p10 + p11*uref + p12*uref**2 + p13*uref**3) + elseif (uref > 6.5 .and. uref <= 15.7) then + znotm = p25*uref**5 + p24*uref**4 + p23*uref**3 + p22*uref**2 + p21*uref + p20 + elseif (uref > 15.7 .and. uref <= 53.0) then + znotm = exp( p35*uref**5 + p34*uref**4 + p33*uref**3 + p32*uref**2 + p31*uref + p30 ) + elseif ( uref > 53.0) then + znotm = p40 + else + print*, 'Wrong input uref value:',uref + endif + + END SUBROUTINE znot_m_v6 + + SUBROUTINE znot_t_v6(uref,znott) + IMPLICIT NONE +! Calculate scalar roughness over water with input 10-m wind +! For low-to-moderate winds, try to match the Ck-U10 relationship from COARE algorithm +! For high winds, try to retain the Ck-U10 relationship of FY2015 HWRF +! +! Bin Liu, NOAA/NCEP/EMC 2017 +! +! uref(m/s) : wind speed at 10-m height +! znott(meter): scalar roughness scale over water +! + + REAL, INTENT(IN) :: uref + REAL, INTENT(OUT):: znott + + REAL :: p00 + REAL :: p15, p14, p13, p12, p11, p10 + REAL :: p25, p24, p23, p22, p21, p20 + REAL :: p35, p34, p33, p32, p31, p30 + REAL :: p45, p44, p43, p42, p41, p40 + REAL :: p56, p55, p54, p53, p52, p51, p50 + REAL :: p60 + + p00 = 1.100000000000000e-04 + + p15 = -9.144581627678278e-10 + p14 = 7.020346616456421e-08 + p13 = -2.155602086883837e-06 + p12 = 3.333848806567684e-05 + p11 = -2.628501274963990e-04 + p10 = 8.634221567969181e-04 + + p25 = -8.654513012535990e-12 + p24 = 1.232380050058077e-09 + p23 = -6.837922749505057e-08 + p22 = 1.871407733439947e-06 + p21 = -2.552246987137160e-05 + p20 = 1.428968311457630e-04 + + p35 = 3.207515102100162e-12 + p34 = -2.945761895342535e-10 + p33 = 8.788972147364181e-09 + p32 = -3.814457439412957e-08 + p31 = -2.448983648874671e-06 + p30 = 3.436721779020359e-05 + + p45 = -3.530687797132211e-11 + p44 = 3.939867958963747e-09 + p43 = -1.227668406985956e-08 + p42 = -1.367469811838390e-05 + p41 = 5.988240863928883e-04 + p40 = -7.746288511324971e-03 + + p56 = -1.187982453329086e-13 + p55 = 4.801984186231693e-11 + p54 = -8.049200462388188e-09 + p53 = 7.169872601310186e-07 + p52 = -3.581694433758150e-05 + p51 = 9.503919224192534e-04 + p50 = -1.036679430885215e-02 + + p60 = 4.751256171799112e-05 + + if (uref >= 0.0 .and. uref < 5.9 ) then + znott = p00 + elseif (uref >= 5.9 .and. uref <= 15.4) then + znott = p15*uref**5 + p14*uref**4 + p13*uref**3 + p12*uref**2 + p11*uref + p10 + elseif (uref > 15.4 .and. uref <= 21.6) then + znott = p25*uref**5 + p24*uref**4 + p23*uref**3 + p22*uref**2 + p21*uref + p20 + elseif (uref > 21.6 .and. uref <= 42.2) then + znott = p35*uref**5 + p34*uref**4 + p33*uref**3 + p32*uref**2 + p31*uref + p30 + elseif ( uref > 42.2 .and. uref <= 53.3) then + znott = p45*uref**5 + p44*uref**4 + p43*uref**3 + p42*uref**2 + p41*uref + p40 + elseif ( uref > 53.3 .and. uref <= 80.0) then + znott = p56*uref**6 + p55*uref**5 + p54*uref**4 + p53*uref**3 + p52*uref**2 + p51*uref + p50 + elseif ( uref > 80.0) then + znott = p60 + else + print*, 'Wrong input uref value:',uref + endif + + END SUBROUTINE znot_t_v6 + + SUBROUTINE znot_m_v7(uref,znotm) + IMPLICIT NONE +! Calculate areodynamical roughness over water with input 10-m wind +! For low-to-moderate winds, try to match the Cd-U10 relationship from COARE V3.5 (Edson et al. 2013) +! For high winds, try to fit available observational data +! Comparing to znot_t_v6, slightly decrease Cd for higher wind speed +! +! Bin Liu, NOAA/NCEP/EMC 2018 +! +! uref(m/s) : wind speed at 10-m height +! znotm(meter): areodynamical roughness scale over water +! + + REAL, INTENT(IN) :: uref + REAL, INTENT(OUT):: znotm + REAL :: p13, p12, p11, p10 + REAL :: p25, p24, p23, p22, p21, p20 + REAL :: p35, p34, p33, p32, p31, p30 + REAL :: p40 + + p13 = -1.296521881682694e-02 + p12 = 2.855780863283819e-01 + p11 = -1.597898515251717e+00 + p10 = -8.396975715683501e+00 + + p25 = 3.790846746036765e-10 + p24 = 3.281964357650687e-09 + p23 = 1.962282433562894e-07 + p22 = -1.240239171056262e-06 + p21 = 1.739759082358234e-07 + p20 = 2.147264020369413e-05 + + p35 = 1.897534489606422e-07 + p34 = -3.019495980684978e-05 + p33 = 1.931392924987349e-03 + p32 = -6.797293095862357e-02 + p31 = 1.346757797103756e+00 + p30 = -1.707846930193362e+01 + + p40 = 3.371427455376717e-04 + + if (uref >= 0.0 .and. uref <= 6.5 ) then + znotm = exp( p10 + p11*uref + p12*uref**2 + p13*uref**3) + elseif (uref > 6.5 .and. uref <= 15.7) then + znotm = p25*uref**5 + p24*uref**4 + p23*uref**3 + p22*uref**2 + p21*uref + p20 + elseif (uref > 15.7 .and. uref <= 53.0) then + znotm = exp( p35*uref**5 + p34*uref**4 + p33*uref**3 + p32*uref**2 + p31*uref + p30 ) + elseif ( uref > 53.0) then + znotm = p40 + else + print*, 'Wrong input uref value:',uref + endif + + END SUBROUTINE znot_m_v7 + + SUBROUTINE znot_t_v7(uref,znott) + IMPLICIT NONE +! Calculate scalar roughness over water with input 10-m wind +! For low-to-moderate winds, try to match the Ck-U10 relationship from COARE algorithm +! For high winds, try to retain the Ck-U10 relationship of FY2015 HWRF +! To be compatible with the slightly decreased Cd for higher wind speed +! +! Bin Liu, NOAA/NCEP/EMC 2018 +! +! uref(m/s) : wind speed at 10-m height +! znott(meter): scalar roughness scale over water +! + + REAL, INTENT(IN) :: uref + REAL, INTENT(OUT):: znott + + REAL :: p00 + REAL :: p15, p14, p13, p12, p11, p10 + REAL :: p25, p24, p23, p22, p21, p20 + REAL :: p35, p34, p33, p32, p31, p30 + REAL :: p45, p44, p43, p42, p41, p40 + REAL :: p56, p55, p54, p53, p52, p51, p50 + REAL :: p60 + + p00 = 1.100000000000000e-04 + + p15 = -9.193764479895316e-10 + p14 = 7.052217518653943e-08 + p13 = -2.163419217747114e-06 + p12 = 3.342963077911962e-05 + p11 = -2.633566691328004e-04 + p10 = 8.644979973037803e-04 + + p25 = -9.402722450219142e-12 + p24 = 1.325396583616614e-09 + p23 = -7.299148051141852e-08 + p22 = 1.982901461144764e-06 + p21 = -2.680293455916390e-05 + p20 = 1.484341646128200e-04 + + p35 = 7.921446674311864e-12 + p34 = -1.019028029546602e-09 + p33 = 5.251986927351103e-08 + p32 = -1.337841892062716e-06 + p31 = 1.659454106237737e-05 + p30 = -7.558911792344770e-05 + + p45 = -2.694370426850801e-10 + p44 = 5.817362913967911e-08 + p43 = -5.000813324746342e-06 + p42 = 2.143803523428029e-04 + p41 = -4.588070983722060e-03 + p40 = 3.924356617245624e-02 + + p56 = -1.663918773476178e-13 + p55 = 6.724854483077447e-11 + p54 = -1.127030176632823e-08 + p53 = 1.003683177025925e-06 + p52 = -5.012618091180904e-05 + p51 = 1.329762020689302e-03 + p50 = -1.450062148367566e-02 + + p60 = 6.840803042788488e-05 + + if (uref >= 0.0 .and. uref < 5.9 ) then + znott = p00 + elseif (uref >= 5.9 .and. uref <= 15.4) then + znott = p15*uref**5 + p14*uref**4 + p13*uref**3 + p12*uref**2 + p11*uref + p10 + elseif (uref > 15.4 .and. uref <= 21.6) then + znott = p25*uref**5 + p24*uref**4 + p23*uref**3 + p22*uref**2 + p21*uref + p20 + elseif (uref > 21.6 .and. uref <= 42.6) then + znott = p35*uref**5 + p34*uref**4 + p33*uref**3 + p32*uref**2 + p31*uref + p30 + elseif ( uref > 42.6 .and. uref <= 53.0) then + znott = p45*uref**5 + p44*uref**4 + p43*uref**3 + p42*uref**2 + p41*uref + p40 + elseif ( uref > 53.0 .and. uref <= 80.0) then + znott = p56*uref**6 + p55*uref**5 + p54*uref**4 + p53*uref**3 + p52*uref**2 + p51*uref + p50 + elseif ( uref > 80.0) then + znott = p60 + else + print*, 'Wrong input uref value:',uref + endif + + END SUBROUTINE znot_t_v7 + + SUBROUTINE znot_m_v8(uref,znotm) + IMPLICIT NONE +! Calculate areodynamical roughness over water with input 10-m wind +! For low-to-moderate winds, try to match the Cd-U10 relationship from COARE V3.5 (Edson et al. 2013) +! For high winds, try to fit available observational data +! Comparing to znot_t_v6, slightly decrease Cd for higher wind speed +! And this is another variation similar to v7 +! +! Bin Liu, NOAA/NCEP/EMC 2018 +! +! uref(m/s) : wind speed at 10-m height +! znotm(meter): areodynamical roughness scale over water +! + + REAL, INTENT(IN) :: uref + REAL, INTENT(OUT):: znotm + REAL :: p13, p12, p11, p10 + REAL :: p25, p24, p23, p22, p21, p20 + REAL :: p35, p34, p33, p32, p31, p30 + REAL :: p40 + + p13 = -1.296521881682694e-02 + p12 = 2.855780863283819e-01 + p11 = -1.597898515251717e+00 + p10 = -8.396975715683501e+00 + + p25 = 3.790846746036765e-10 + p24 = 3.281964357650687e-09 + p23 = 1.962282433562894e-07 + p22 = -1.240239171056262e-06 + p21 = 1.739759082358234e-07 + p20 = 2.147264020369413e-05 + + p35 = 1.897534489606422e-07 + p34 = -3.019495980684978e-05 + p33 = 1.931392924987349e-03 + p32 = -6.797293095862357e-02 + p31 = 1.346757797103756e+00 + p30 = -1.707846930193362e+01 + + p40 = 3.886804744928044e-04 + + if (uref >= 0.0 .and. uref <= 6.5 ) then + znotm = exp( p10 + p11*uref + p12*uref**2 + p13*uref**3) + elseif (uref > 6.5 .and. uref <= 15.7) then + znotm = p25*uref**5 + p24*uref**4 + p23*uref**3 + p22*uref**2 + p21*uref + p20 + elseif (uref > 15.7 .and. uref <= 51.5) then + znotm = exp( p35*uref**5 + p34*uref**4 + p33*uref**3 + p32*uref**2 + p31*uref + p30 ) + elseif ( uref > 51.5) then + znotm = p40 + else + print*, 'Wrong input uref value:',uref + endif + + END SUBROUTINE znot_m_v8 + + SUBROUTINE znot_t_v8(uref,znott) + IMPLICIT NONE +! Calculate scalar roughness over water with input 10-m wind +! For low-to-moderate winds, try to match the Ck-U10 relationship from COARE algorithm +! For high winds, try to retain the Ck-U10 relationship of FY2015 HWRF +! To be compatible with the slightly decreased Cd for higher wind speed +! And this is another variation similar to v7 +! +! Bin Liu, NOAA/NCEP/EMC 2018 +! +! uref(m/s) : wind speed at 10-m height +! znott(meter): scalar roughness scale over water +! + + REAL, INTENT(IN) :: uref + REAL, INTENT(OUT):: znott + + REAL :: p00 + REAL :: p15, p14, p13, p12, p11, p10 + REAL :: p25, p24, p23, p22, p21, p20 + REAL :: p35, p34, p33, p32, p31, p30 + REAL :: p45, p44, p43, p42, p41, p40 + REAL :: p56, p55, p54, p53, p52, p51, p50 + REAL :: p60 + + p00 = 1.100000000000000e-04 + + p15 = -9.193764479895316e-10 + p14 = 7.052217518653943e-08 + p13 = -2.163419217747114e-06 + p12 = 3.342963077911962e-05 + p11 = -2.633566691328004e-04 + p10 = 8.644979973037803e-04 + + p25 = -9.402722450219142e-12 + p24 = 1.325396583616614e-09 + p23 = -7.299148051141852e-08 + p22 = 1.982901461144764e-06 + p21 = -2.680293455916390e-05 + p20 = 1.484341646128200e-04 + + p35 = 7.921446674311864e-12 + p34 = -1.019028029546602e-09 + p33 = 5.251986927351103e-08 + p32 = -1.337841892062716e-06 + p31 = 1.659454106237737e-05 + p30 = -7.558911792344770e-05 + + p45 = -2.706461188613193e-10 + p44 = 5.845859022891930e-08 + p43 = -5.027577045502003e-06 + p42 = 2.156326523752734e-04 + p41 = -4.617267288861201e-03 + p40 = 3.951492707214883e-02 + + p56 = -1.112896580069263e-13 + p55 = 4.450334755105140e-11 + p54 = -7.375373918500171e-09 + p53 = 6.493685149526543e-07 + p52 = -3.206421106713471e-05 + p51 = 8.407596231678149e-04 + p50 = -9.027924333673693e-03 + + p60 = 5.791179079892191e-05 + + if (uref >= 0.0 .and. uref < 5.9 ) then + znott = p00 + elseif (uref >= 5.9 .and. uref <= 15.4) then + znott = p15*uref**5 + p14*uref**4 + p13*uref**3 + p12*uref**2 + p11*uref + p10 + elseif (uref > 15.4 .and. uref <= 21.6) then + znott = p25*uref**5 + p24*uref**4 + p23*uref**3 + p22*uref**2 + p21*uref + p20 + elseif (uref > 21.6 .and. uref <= 42.6) then + znott = p35*uref**5 + p34*uref**4 + p33*uref**3 + p32*uref**2 + p31*uref + p30 + elseif ( uref > 42.6 .and. uref <= 51.5) then + znott = p45*uref**5 + p44*uref**4 + p43*uref**3 + p42*uref**2 + p41*uref + p40 + elseif ( uref > 51.5 .and. uref <= 80.0) then + znott = p56*uref**6 + p55*uref**5 + p54*uref**4 + p53*uref**3 + p52*uref**2 + p51*uref + p50 + elseif ( uref > 80.0) then + znott = p60 + else + print*, 'Wrong input uref value:',uref + endif + + END SUBROUTINE znot_t_v8 + + SUBROUTINE znot_wind10m(w10m,znott,znotm,icoef_sf) + IMPLICIT NONE + +! w10m(m/s) : 10-m wind speed +! znott(meter): Roughness scale for temperature/moisture, zt +! znotm(meter): Roughness scale for momentum, z0 +! Author : Weiguo Wang on 02/24/2016 +! convert from icoef=0,1,2 to have 10m level cd, ch match obs + REAL, INTENT(IN) :: w10m + INTEGER, INTENT(IN) :: icoef_sf + REAL, INTENT(OUT):: znott, znotm + + real :: zm,zt,windmks, zlev,z10, tmp, zlevt, aaa, zm1,zt1 + zlev=20.0 + zlevt=10.0 + z10=10.0 + windmks=w10m + if (windmks > 85.0) windmks=85.0 + if (windmks < 1.0) windmks=1.0 + if ( icoef_sf .EQ. 1) then + call znot_m_v1(windmks,zm1) + call znot_t_v1(windmks,zt1) + + else if ( icoef_sf .EQ. 0 ) then + call znot_m_v0(windmks,zm1) + call znot_t_v0(windmks,zt1) + + else if( icoef_sf .EQ. 2 ) then + call znot_m_v1(windmks,zm1) + call znot_t_v2(windmks,zt1) + + else if( icoef_sf .EQ. 3 ) then + call znot_m_v1(windmks,zm) + call znot_t_v2(windmks,zt) +!! adjust a little to match obs at 10m, cd is reduced + tmp=0.4*0.4/(alog(zlev/zm))**2 ! cd at zlev + zm1=z10/exp( sqrt(0.4*0.4/(tmp*0.95-0.0002)) ) +!ch + tmp=0.4*0.4/(alog(zlevt/zm)*alog(zlevt/zt)) ! ch at zlev using old formula + zt1=z10/exp( 0.4*0.4/( 0.95*tmp*alog(z10/zm1) ) ) + + else if( icoef_sf .EQ. 4 ) then + + call znot_m_v1(windmks,zm) + call znot_t_v2(windmks,zt) +!! for wind<20, cd similar to icoef=2 at 10m, then reduced + tmp=0.4*0.4/(alog(10.0/zm))**2 ! cd at zlev + aaa=0.75 + if (windmks < 20) then + aaa=0.99 + elseif(windmks < 45.0) then + aaa=0.99+(windmks-20)*(0.75-0.99)/(45.0-20.0) + endif + zm1=z10/exp( sqrt(0.4*0.4/(tmp*aaa)) ) +!ch + tmp=0.4*0.4/(alog(zlevt/zm)*alog(zlevt/zt)) ! ch at zlev using old formula + zt1=z10/exp( 0.4*0.4/( 0.95*tmp*alog(z10/zm1) ) ) + + else if( icoef_sf .EQ. 5 ) then + + call znot_m_v1(windmks,zm) + call znot_t_v2(windmks,zt) +!! for wind<20, cd similar to icoef=2 at 10m, then reduced + tmp=0.4*0.4/(alog(10.0/zm))**2 ! cd at zlev + aaa=0.80 + if (windmks < 20) then + aaa=1.0 + elseif(windmks < 45.0) then + aaa=1.0+(windmks-20)*(0.80-1.0)/(45.0-20.0) + endif + zm1=z10/exp( sqrt(0.4*0.4/(tmp*aaa)) ) +!ch + tmp=0.4*0.4/(alog(zlevt/zm)*alog(zlevt/zt)) ! ch at zlev using old formula + zt1=z10/exp( 0.4*0.4/( 1.0*tmp*alog(z10/zm1) ) ) + + else if( icoef_sf .EQ. 6 ) then + call znot_m_v6(windmks,zm1) + call znot_t_v6(windmks,zt1) + else if( icoef_sf .EQ. 7 ) then + call znot_m_v7(windmks,zm1) + call znot_t_v7(windmks,zt1) + else if( icoef_sf .EQ. 8 ) then + call znot_m_v8(windmks,zm1) + call znot_t_v8(windmks,zt1) + else + write(0,*)'stop, icoef_sf must be one of 0,1,2,3,4,5,6,7,8' + stop + endif + znott=zt1 + znotm=zm1 + + end subroutine znot_wind10m + +END MODULE module_sf_exchcoef + diff --git a/physics/module_sf_noahlsm.F90 b/physics/module_sf_noahlsm.F90 new file mode 100644 index 000000000..9336abf65 --- /dev/null +++ b/physics/module_sf_noahlsm.F90 @@ -0,0 +1,4773 @@ + MODULE module_sf_noahlsm + +!ckay=KIRAN ALAPATY @ US EPA -- November 01, 2015 +! +! Tim Glotfelty@CNSU; AJ Deng@PSU +!modified for use with FASDAS +!Flux Adjusting Surface Data Assimilation System to assimilate +!surface layer and soil layers temperature and moisture using +! surfance reanalsys +!Reference: Alapaty et al., 2008: Development of the flux-adjusting surface +! data assimilation system for mesoscale models. JAMC, 47, 2331-2350 +! + + REAL, PARAMETER :: EMISSI_S = 0.95 + +! VEGETATION PARAMETERS + INTEGER :: LUCATS , BARE + INTEGER :: NATURAL + INTEGER :: LOW_DENSITY_RESIDENTIAL, HIGH_DENSITY_RESIDENTIAL, HIGH_INTENSITY_INDUSTRIAL + integer, PARAMETER :: NLUS=50 + CHARACTER(LEN=256) LUTYPE + INTEGER, DIMENSION(1:NLUS) :: NROTBL + real, dimension(1:NLUS) :: SNUPTBL, RSTBL, RGLTBL, HSTBL, & + SHDTBL, MAXALB, & + EMISSMINTBL, EMISSMAXTBL, & + LAIMINTBL, LAIMAXTBL, & + Z0MINTBL, Z0MAXTBL, & + ALBEDOMINTBL, ALBEDOMAXTBL, & + ZTOPVTBL,ZBOTVTBL + REAL :: TOPT_DATA,CMCMAX_DATA,CFACTR_DATA,RSMAX_DATA + +! SOIL PARAMETERS + INTEGER :: SLCATS + INTEGER, PARAMETER :: NSLTYPE=30 + CHARACTER(LEN=256) SLTYPE + REAL, DIMENSION (1:NSLTYPE) :: BB,DRYSMC,F11, & + MAXSMC, REFSMC,SATPSI,SATDK,SATDW, WLTSMC,QTZ + +! LSM GENERAL PARAMETERS + INTEGER :: SLPCATS + INTEGER, PARAMETER :: NSLOPE=30 + REAL, DIMENSION (1:NSLOPE) :: SLOPE_DATA + REAL :: SBETA_DATA,FXEXP_DATA,CSOIL_DATA,SALP_DATA,REFDK_DATA, & + REFKDT_DATA,FRZK_DATA,ZBOT_DATA, SMLOW_DATA,SMHIGH_DATA, & + CZIL_DATA + REAL :: LVCOEF_DATA + + integer, private :: iloc, jloc +!$omp threadprivate(iloc, jloc) +! + CONTAINS +! + + SUBROUTINE SFLX (IILOC,JJLOC,FFROZP,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C + LOCAL, & !L + LLANDUSE, LSOIL, & !CL + LWDN,SOLDN,SOLNET,SFCPRS,PRCP,SFCTMP,Q2,SFCSPD, & !F + COSZ,PRCPRAIN, SOLARDIRECT, & !F + TH2,Q2SAT,DQSDT2, & !I + VEGTYP,SOILTYP,SLOPETYP,SHDFAC,SHDMIN,SHDMAX, & !I + ALB, SNOALB,TBOT, Z0BRD, Z0, EMISSI, EMBRD, & !S + CMC,T1,STC,SMC,SH2O,SNOWH,SNEQV,ALBEDO,CH,CM, & !H + CP, RD, SIGMA, CPH2O, CPICE, LSUBF, & !physical constants +! ---------------------------------------------------------------------- +! OUTPUTS, DIAGNOSTICS, PARAMETERS BELOW GENERALLY NOT NECESSARY WHEN +! COUPLED WITH E.G. A NWP MODEL (SUCH AS THE NOAA/NWS/NCEP MESOSCALE ETA +! MODEL). OTHER APPLICATIONS MAY REQUIRE DIFFERENT OUTPUT VARIABLES. +! ---------------------------------------------------------------------- + ETA,SHEAT, ETA_KINEMATIC,FDOWN, & !O + EC,EDIR,ET,ETT,ESNOW,DRIP,DEW, & !O + BETA,ETP,SSOIL, & !O + FLX1,FLX2,FLX3, & !O + FLX4,FVB,FBUR,FGSN,UA_PHYS, & !UA + SNOMLT,SNCOVR, & !O + RUNOFF1,RUNOFF2,RUNOFF3, & !O + RC,PC,RSMIN,XLAI,RCS,RCT,RCQ,RCSOIL, & !O + SOILW,SOILM,Q1,SMAV, & !D + RDLAI2D,USEMONALB, & + SNOTIME1, & + RIBB, & + SMCWLT,SMCDRY,SMCREF,SMCMAX,NROOT, & + SFHEAD1RT, & !I + INFXS1RT,ETPND1,OPT_THCND,AOASIS, & !P + XSDA_QFX,HFX_PHY,QFX_PHY,XQNORM, & !fasdas + fasdas,HCPCT_FASDAS, & !fasdas + errflg, errmsg) + +! ---------------------------------------------------------------------- +! SUBROUTINE SFLX - UNIFIED NOAHLSM VERSION 1.0 JULY 2007 +! ---------------------------------------------------------------------- +! SUB-DRIVER FOR "Noah LSM" FAMILY OF PHYSICS SUBROUTINES FOR A +! SOIL/VEG/SNOWPACK LAND-SURFACE MODEL TO UPDATE SOIL MOISTURE, SOIL +! ICE, SOIL TEMPERATURE, SKIN TEMPERATURE, SNOWPACK WATER CONTENT, +! SNOWDEPTH, AND ALL TERMS OF THE SURFACE ENERGY BALANCE AND SURFACE +! WATER BALANCE (EXCLUDING INPUT ATMOSPHERIC FORCINGS OF DOWNWARD +! RADIATION AND PRECIP) +! ---------------------------------------------------------------------- +! SFLX ARGUMENT LIST KEY: +! ---------------------------------------------------------------------- +! C CONFIGURATION INFORMATION +! L LOGICAL +! CL 4-string character bearing logical meaning +! F FORCING DATA +! I OTHER (INPUT) FORCING DATA +! S SURFACE CHARACTERISTICS +! H HISTORY (STATE) VARIABLES +! O OUTPUT VARIABLES +! D DIAGNOSTIC OUTPUT +! P Parameters +! Msic Miscellaneous terms passed from gridded driver +! ---------------------------------------------------------------------- +! 1. CONFIGURATION INFORMATION (C): +! ---------------------------------------------------------------------- +! DT TIMESTEP (SEC) (DT SHOULD NOT EXCEED 3600 SECS, RECOMMEND +! 1800 SECS OR LESS) +! ZLVL HEIGHT (M) ABOVE GROUND OF ATMOSPHERIC FORCING VARIABLES +! NSOIL NUMBER OF SOIL LAYERS (AT LEAST 2, AND NOT GREATER THAN +! PARAMETER NSOLD SET BELOW) +! SLDPTH THE THICKNESS OF EACH SOIL LAYER (M) +! ---------------------------------------------------------------------- +! 2. LOGICAL: +! ---------------------------------------------------------------------- +! LCH Exchange coefficient (Ch) calculation flag (false: using +! ch-routine SFCDIF; true: Ch is brought in) +! LOCAL Flag for local-site simulation (where there is no +! maps for albedo, veg fraction, and roughness +! true: all LSM parameters (inluding albedo, veg fraction and +! roughness length) will be defined by three tables +! LLANDUSE (=USGS, using USGS landuse classification) +! LSOIL (=STAS, using FAO/STATSGO soil texture classification) +! OPT_THCND option for how to treat thermal conductivity +! ---------------------------------------------------------------------- +! 3. FORCING DATA (F): +! ---------------------------------------------------------------------- +! LWDN LW DOWNWARD RADIATION (W M-2; POSITIVE, NOT NET LONGWAVE) +! SOLDN SOLAR DOWNWARD RADIATION (W M-2; POSITIVE, NOT NET SOLAR) +! SOLNET NET DOWNWARD SOLAR RADIATION ((W M-2; POSITIVE) +! SFCPRS PRESSURE AT HEIGHT ZLVL ABOVE GROUND (PASCALS) +! PRCP PRECIP RATE (KG M-2 S-1) (NOTE, THIS IS A RATE) +! SFCTMP AIR TEMPERATURE (K) AT HEIGHT ZLVL ABOVE GROUND +! TH2 AIR POTENTIAL TEMPERATURE (K) AT HEIGHT ZLVL ABOVE GROUND +! Q2 MIXING RATIO AT HEIGHT ZLVL ABOVE GROUND (KG KG-1) +! COSZ Solar zenith angle (not used for now) +! PRCPRAIN Liquid-precipitation rate (KG M-2 S-1) (not used) +! SOLARDIRECT Direct component of downward solar radiation (W M-2) (not used) +! FFROZP FRACTION OF FROZEN PRECIPITATION +! ---------------------------------------------------------------------- +! 4. OTHER FORCING (INPUT) DATA (I): +! ---------------------------------------------------------------------- +! SFCSPD WIND SPEED (M S-1) AT HEIGHT ZLVL ABOVE GROUND +! Q2SAT SAT SPECIFIC HUMIDITY AT HEIGHT ZLVL ABOVE GROUND (KG KG-1) +! DQSDT2 SLOPE OF SAT SPECIFIC HUMIDITY CURVE AT T=SFCTMP +! (KG KG-1 K-1) +! ---------------------------------------------------------------------- +! 5. CANOPY/SOIL CHARACTERISTICS (S): +! ---------------------------------------------------------------------- +! VEGTYP VEGETATION TYPE (INTEGER INDEX) +! SOILTYP SOIL TYPE (INTEGER INDEX) +! SLOPETYP CLASS OF SFC SLOPE (INTEGER INDEX) +! SHDFAC AREAL FRACTIONAL COVERAGE OF GREEN VEGETATION +! (FRACTION= 0.0-1.0) +! SHDMIN MINIMUM AREAL FRACTIONAL COVERAGE OF GREEN VEGETATION +! (FRACTION= 0.0-1.0) <= SHDFAC +! PTU PHOTO THERMAL UNIT (PLANT PHENOLOGY FOR ANNUALS/CROPS) +! (NOT YET USED, BUT PASSED TO REDPRM FOR FUTURE USE IN +! VEG PARMS) +! ALB BACKROUND SNOW-FREE SURFACE ALBEDO (FRACTION), FOR JULIAN +! DAY OF YEAR (USUALLY FROM TEMPORAL INTERPOLATION OF +! MONTHLY MEAN VALUES' CALLING PROG MAY OR MAY NOT +! INCLUDE DIURNAL SUN ANGLE EFFECT) +! SNOALB UPPER BOUND ON MAXIMUM ALBEDO OVER DEEP SNOW (E.G. FROM +! ROBINSON AND KUKLA, 1985, J. CLIM. & APPL. METEOR.) +! TBOT BOTTOM SOIL TEMPERATURE (LOCAL YEARLY-MEAN SFC AIR +! TEMPERATURE) +! Z0BRD Background fixed roughness length (M) +! Z0 Time varying roughness length (M) as function of snow depth +! +! EMBRD Background surface emissivity (between 0 and 1) +! EMISSI Surface emissivity (between 0 and 1) +! ---------------------------------------------------------------------- +! 6. HISTORY (STATE) VARIABLES (H): +! ---------------------------------------------------------------------- +! CMC CANOPY MOISTURE CONTENT (M) +! T1 GROUND/CANOPY/SNOWPACK) EFFECTIVE SKIN TEMPERATURE (K) +! STC(NSOIL) SOIL TEMP (K) +! SMC(NSOIL) TOTAL SOIL MOISTURE CONTENT (VOLUMETRIC FRACTION) +! SH2O(NSOIL) UNFROZEN SOIL MOISTURE CONTENT (VOLUMETRIC FRACTION) +! NOTE: FROZEN SOIL MOISTURE = SMC - SH2O +! SNOWH ACTUAL SNOW DEPTH (M) +! SNEQV LIQUID WATER-EQUIVALENT SNOW DEPTH (M) +! NOTE: SNOW DENSITY = SNEQV/SNOWH +! ALBEDO SURFACE ALBEDO INCLUDING SNOW EFFECT (UNITLESS FRACTION) +! =SNOW-FREE ALBEDO (ALB) WHEN SNEQV=0, OR +! =FCT(MSNOALB,ALB,VEGTYP,SHDFAC,SHDMIN) WHEN SNEQV>0 +! CH SURFACE EXCHANGE COEFFICIENT FOR HEAT AND MOISTURE +! (M S-1); NOTE: CH IS TECHNICALLY A CONDUCTANCE SINCE +! IT HAS BEEN MULTIPLIED BY WIND SPEED. +! CM SURFACE EXCHANGE COEFFICIENT FOR MOMENTUM (M S-1); NOTE: +! CM IS TECHNICALLY A CONDUCTANCE SINCE IT HAS BEEN +! MULTIPLIED BY WIND SPEED. +! 6a: Physical constants +! CP specific heat of dry air at constant pressure +! RD gas constant for dry air +! SIGMA Steffan-Boltzmann constant +! CPH2O specific heat of liquid water +! CPICE specific heat of ice +! LSUBF latent heat of fusion for water +! ---------------------------------------------------------------------- +! 7. OUTPUT (O): +! ---------------------------------------------------------------------- +! OUTPUT VARIABLES NECESSARY FOR A COUPLED NUMERICAL WEATHER PREDICTION +! MODEL, E.G. NOAA/NWS/NCEP MESOSCALE ETA MODEL. FOR THIS APPLICATION, +! THE REMAINING OUTPUT/DIAGNOSTIC/PARAMETER BLOCKS BELOW ARE NOT +! NECESSARY. OTHER APPLICATIONS MAY REQUIRE DIFFERENT OUTPUT VARIABLES. +! ETA ACTUAL LATENT HEAT FLUX (W m-2: NEGATIVE, IF UP FROM +! SURFACE) +! ETA_KINEMATIC atctual latent heat flux in Kg m-2 s-1 +! SHEAT SENSIBLE HEAT FLUX (W M-2: POSITIVE, IF UPWARD FROM +! SURFACE) +! FDOWN Radiation forcing at the surface (W m-2) = SOLDN*(1-alb)+LWDN +! ---------------------------------------------------------------------- +! EC CANOPY WATER EVAPORATION (W m-2) +! EDIR DIRECT SOIL EVAPORATION (W m-2) +! ET(NSOIL) PLANT TRANSPIRATION FROM A PARTICULAR ROOT (SOIL) LAYER +! (W m-2) +! ETT TOTAL PLANT TRANSPIRATION (W m-2) +! ESNOW SUBLIMATION FROM (OR DEPOSITION TO IF <0) SNOWPACK +! (W m-2) +! DRIP THROUGH-FALL OF PRECIP AND/OR DEW IN EXCESS OF CANOPY +! WATER-HOLDING CAPACITY (M) +! DEW DEWFALL (OR FROSTFALL FOR T<273.15) (M) +! ---------------------------------------------------------------------- +! BETA RATIO OF ACTUAL/POTENTIAL EVAP (DIMENSIONLESS) +! ETP POTENTIAL EVAPORATION (W m-2) +! SSOIL SOIL HEAT FLUX (W M-2: NEGATIVE IF DOWNWARD FROM SURFACE) +! ---------------------------------------------------------------------- +! FLX1 PRECIP-SNOW SFC (W M-2) +! FLX2 FREEZING RAIN LATENT HEAT FLUX (W M-2) +! FLX3 PHASE-CHANGE HEAT FLUX FROM SNOWMELT (W M-2) +! ---------------------------------------------------------------------- +! SNOMLT SNOW MELT (M) (WATER EQUIVALENT) +! SNCOVR FRACTIONAL SNOW COVER (UNITLESS FRACTION, 0-1) +! ---------------------------------------------------------------------- +! RUNOFF1 SURFACE RUNOFF (M S-1), NOT INFILTRATING THE SURFACE +! RUNOFF2 SUBSURFACE RUNOFF (M S-1), DRAINAGE OUT BOTTOM OF LAST +! SOIL LAYER (BASEFLOW) +! RUNOFF3 NUMERICAL TRUNCTATION IN EXCESS OF POROSITY (SMCMAX) +! FOR A GIVEN SOIL LAYER AT THE END OF A TIME STEP (M S-1). +! Note: the above RUNOFF2 is actually the sum of RUNOFF2 and RUNOFF3 +! ---------------------------------------------------------------------- +! RC CANOPY RESISTANCE (S M-1) +! PC PLANT COEFFICIENT (UNITLESS FRACTION, 0-1) WHERE PC*ETP +! = ACTUAL TRANSP +! XLAI LEAF AREA INDEX (DIMENSIONLESS) +! RSMIN MINIMUM CANOPY RESISTANCE (S M-1) +! RCS INCOMING SOLAR RC FACTOR (DIMENSIONLESS) +! RCT AIR TEMPERATURE RC FACTOR (DIMENSIONLESS) +! RCQ ATMOS VAPOR PRESSURE DEFICIT RC FACTOR (DIMENSIONLESS) +! RCSOIL SOIL MOISTURE RC FACTOR (DIMENSIONLESS) +! ---------------------------------------------------------------------- +! 8. DIAGNOSTIC OUTPUT (D): +! ---------------------------------------------------------------------- +! SOILW AVAILABLE SOIL MOISTURE IN ROOT ZONE (UNITLESS FRACTION +! BETWEEN SMCWLT AND SMCMAX) +! SOILM TOTAL SOIL COLUMN MOISTURE CONTENT (FROZEN+UNFROZEN) (M) +! Q1 Effective mixing ratio at surface (kg kg-1), used for +! diagnosing the mixing ratio at 2 meter for coupled model +! SMAV Soil Moisture Availability for each layer, as a fraction +! between SMCWLT and SMCMAX. +! Documentation for SNOTIME1 and SNOABL2 ????? +! What categories of arguments do these variables fall into ???? +! Documentation for RIBB ????? +! What category of argument does RIBB fall into ????? +! ---------------------------------------------------------------------- +! 9. PARAMETERS (P): +! ---------------------------------------------------------------------- +! SMCWLT WILTING POINT (VOLUMETRIC) +! SMCDRY DRY SOIL MOISTURE THRESHOLD WHERE DIRECT EVAP FRM TOP +! LAYER ENDS (VOLUMETRIC) +! SMCREF SOIL MOISTURE THRESHOLD WHERE TRANSPIRATION BEGINS TO +! STRESS (VOLUMETRIC) +! SMCMAX POROSITY, I.E. SATURATED VALUE OF SOIL MOISTURE +! (VOLUMETRIC) +! NROOT NUMBER OF ROOT LAYERS, A FUNCTION OF VEG TYPE, DETERMINED +! IN SUBROUTINE REDPRM. +! ---------------------------------------------------------------------- + + + IMPLICIT NONE +! ---------------------------------------------------------------------- + +! DECLARATIONS - LOGICAL AND CHARACTERS +! ---------------------------------------------------------------------- + + INTEGER, INTENT(IN) :: IILOC, JJLOC + LOGICAL, INTENT(IN):: LOCAL + LOGICAL :: FRZGRA, SNOWNG + CHARACTER (LEN=256), INTENT(IN):: LLANDUSE, LSOIL + +! ---------------------------------------------------------------------- +! 1. CONFIGURATION INFORMATION (C): +! ---------------------------------------------------------------------- + INTEGER,INTENT(IN) :: NSOIL,SLOPETYP,SOILTYP,VEGTYP + INTEGER, INTENT(IN) :: ISURBAN + INTEGER,INTENT(OUT):: NROOT + INTEGER KZ, K, iout + +! ---------------------------------------------------------------------- +! 2. LOGICAL: +! ---------------------------------------------------------------------- + LOGICAL, INTENT(IN) :: RDLAI2D + LOGICAL, INTENT(IN) :: USEMONALB + INTEGER, INTENT(IN) :: OPT_THCND + + REAL, INTENT(INOUT):: SFHEAD1RT,INFXS1RT, ETPND1 + + REAL, INTENT(IN) :: SHDMIN,SHDMAX,DT,DQSDT2,LWDN,PRCP,PRCPRAIN, & + Q2,Q2SAT,SFCPRS,SFCSPD,SFCTMP, SNOALB, & + SOLDN,SOLNET,TBOT,TH2,ZLVL, & + FFROZP,AOASIS + REAL, INTENT(IN) :: CP, RD, SIGMA, CPH2O, CPICE, LSUBF + REAL, INTENT(OUT) :: EMBRD + REAL, INTENT(OUT) :: ALBEDO + REAL, INTENT(INOUT):: COSZ, SOLARDIRECT,CH,CM, & + CMC,SNEQV,SNCOVR,SNOWH,T1,XLAI,SHDFAC,Z0BRD, & + EMISSI, ALB + REAL, INTENT(INOUT):: SNOTIME1 + REAL, INTENT(INOUT):: RIBB + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SLDPTH + REAL, DIMENSION(1:NSOIL), INTENT(OUT):: ET + REAL, DIMENSION(1:NSOIL), INTENT(OUT):: SMAV + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: SH2O, SMC, STC + REAL,DIMENSION(1:NSOIL):: RTDIS, ZSOIL + + REAL,INTENT(OUT) :: ETA_KINEMATIC,BETA,DEW,DRIP,EC,EDIR,ESNOW,ETA, & + ETP,FLX1,FLX2,FLX3,SHEAT,PC,RUNOFF1,RUNOFF2, & + RUNOFF3,RC,RSMIN,RCQ,RCS,RCSOIL,RCT,SSOIL, & + SMCDRY,SMCMAX,SMCREF,SMCWLT,SNOMLT, SOILM, & + SOILW,FDOWN,Q1 + LOGICAL, INTENT(IN) :: UA_PHYS ! UA: flag for UA option + REAL,INTENT(OUT) :: FLX4 ! UA: energy added to sensible heat + REAL,INTENT(OUT) :: FVB ! UA: frac. veg. w/snow beneath + REAL,INTENT(OUT) :: FBUR ! UA: fraction of canopy buried + REAL,INTENT(OUT) :: FGSN ! UA: ground snow cover fraction + REAL :: ZTOPV ! UA: height of canopy top + REAL :: ZBOTV ! UA: height of canopy bottom + REAL :: GAMA ! UA: = EXP(-1.* XLAI) + REAL :: FNET ! UA: + REAL :: ETPN ! UA: + REAL :: RU ! UA: + + REAL :: BEXP,CFACTR,CMCMAX,CSOIL,CZIL,DF1,DF1H,DF1A,DKSAT,DWSAT, & + DSOIL,DTOT,ETT,FRCSNO,FRCSOI,EPSCA,F1,FXEXP,FRZX,HS, & + KDT,LVH2O,PRCP1,PSISAT,QUARTZ,R,RCH,REFKDT,RR,RGL, & + RSMAX, & + RSNOW,SNDENS,SNCOND,SBETA,SN_NEW,SLOPE,SNUP,SALP,SOILWM, & + SOILWW,T1V,T24,T2V,TH2V,TOPT,TFREEZ,TSNOW,ZBOT,Z0,PRCPF, & + ETNS,PTU,LSUBS + REAL :: LVCOEF + REAL :: INTERP_FRACTION + REAL :: LAIMIN, LAIMAX + REAL :: ALBEDOMIN, ALBEDOMAX + REAL :: EMISSMIN, EMISSMAX + REAL :: Z0MIN, Z0MAX + +! ---------------------------------------------------------------------- +! DECLARATIONS - PARAMETERS +! ---------------------------------------------------------------------- + PARAMETER (TFREEZ = 273.15) + PARAMETER (LVH2O = 2.501E+6) + PARAMETER (LSUBS = 2.83E+6) + PARAMETER (R = 287.04) +! +! FASDAS +! + INTEGER, INTENT(IN ) :: fasdas + REAL, INTENT(INOUT) :: XSDA_QFX, XQNORM + REAL, INTENT(INOUT) :: HFX_PHY, QFX_PHY + REAL, INTENT( OUT) :: HCPCT_FASDAS +! +! END FASDAS + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg +! +! ---------------------------------------------------------------------- +! INITIALIZATION +! ---------------------------------------------------------------------- + errmsg = '' + errflg = 0 + + ILOC = IILOC + JLOC = JJLOC + + RUNOFF1 = 0.0 + RUNOFF2 = 0.0 + RUNOFF3 = 0.0 + SNOMLT = 0.0 + + IF ( .NOT. UA_PHYS ) THEN + FLX4 = 0.0 + FVB = 0.0 + FBUR = 0.0 + FGSN = 0.0 + ENDIF + +! ---------------------------------------------------------------------- +! CALCULATE DEPTH (NEGATIVE) BELOW GROUND FROM TOP SKIN SFC TO BOTTOM OF +! EACH SOIL LAYER. NOTE: SIGN OF ZSOIL IS NEGATIVE (DENOTING BELOW +! GROUND) +! ---------------------------------------------------------------------- + ZSOIL (1) = - SLDPTH (1) + DO KZ = 2,NSOIL + ZSOIL (KZ) = - SLDPTH (KZ) + ZSOIL (KZ -1) + END DO +! ---------------------------------------------------------------------- +! NEXT IS CRUCIAL CALL TO SET THE LAND-SURFACE PARAMETERS, INCLUDING +! SOIL-TYPE AND VEG-TYPE DEPENDENT PARAMETERS. +! ---------------------------------------------------------------------- + CALL REDPRM (VEGTYP,SOILTYP,SLOPETYP,CFACTR,CMCMAX,RSMAX,TOPT, & + REFKDT,KDT,SBETA, SHDFAC,RSMIN,RGL,HS,ZBOT,FRZX, & + PSISAT,SLOPE,SNUP,SALP,BEXP,DKSAT,DWSAT, & + SMCMAX,SMCWLT,SMCREF,SMCDRY,F1,QUARTZ,FXEXP, & + RTDIS,SLDPTH,ZSOIL,NROOT,NSOIL,CZIL, & + LAIMIN, LAIMAX, EMISSMIN, EMISSMAX, ALBEDOMIN, & + ALBEDOMAX, Z0MIN, Z0MAX, CSOIL, PTU, LLANDUSE, & + LSOIL,LOCAL,LVCOEF,ZTOPV,ZBOTV,errmsg,errflg) + if(errflg > 0) return + +!urban + IF(VEGTYP==ISURBAN)THEN + SHDFAC=0.05 + RSMIN=400.0 + SMCMAX = 0.45 + SMCREF = 0.42 + SMCWLT = 0.40 + SMCDRY = 0.40 + ENDIF + + IF ( SHDFAC >= SHDMAX ) THEN + EMBRD = EMISSMAX + IF (.NOT. RDLAI2D) THEN + XLAI = LAIMAX + ENDIF + IF (.NOT. USEMONALB) THEN + ALB = ALBEDOMIN + ENDIF + Z0BRD = Z0MAX + ELSE IF ( SHDFAC <= SHDMIN ) THEN + EMBRD = EMISSMIN + IF(.NOT. RDLAI2D) THEN + XLAI = LAIMIN + ENDIF + IF(.NOT. USEMONALB) then + ALB = ALBEDOMAX + ENDIF + Z0BRD = Z0MIN + ELSE + + IF ( SHDMAX > SHDMIN ) THEN + + INTERP_FRACTION = ( SHDFAC - SHDMIN ) / ( SHDMAX - SHDMIN ) + ! Bound INTERP_FRACTION between 0 and 1 + INTERP_FRACTION = MIN ( INTERP_FRACTION, 1.0 ) + INTERP_FRACTION = MAX ( INTERP_FRACTION, 0.0 ) + ! Scale Emissivity and LAI between EMISSMIN and EMISSMAX by INTERP_FRACTION + EMBRD = ( ( 1.0 - INTERP_FRACTION ) * EMISSMIN ) + ( INTERP_FRACTION * EMISSMAX ) + IF (.NOT. RDLAI2D) THEN + XLAI = ( ( 1.0 - INTERP_FRACTION ) * LAIMIN ) + ( INTERP_FRACTION * LAIMAX ) + ENDIF + if (.not. USEMONALB) then + ALB = ( ( 1.0 - INTERP_FRACTION ) * ALBEDOMAX ) + ( INTERP_FRACTION * ALBEDOMIN ) + endif + Z0BRD = ( ( 1.0 - INTERP_FRACTION ) * Z0MIN ) + ( INTERP_FRACTION * Z0MAX ) + + ELSE + + EMBRD = 0.5 * EMISSMIN + 0.5 * EMISSMAX + IF (.NOT. RDLAI2D) THEN + XLAI = 0.5 * LAIMIN + 0.5 * LAIMAX + ENDIF + if (.not. USEMONALB) then + ALB = 0.5 * ALBEDOMIN + 0.5 * ALBEDOMAX + endif + Z0BRD = 0.5 * Z0MIN + 0.5 * Z0MAX + + ENDIF + + ENDIF +! ---------------------------------------------------------------------- +! INITIALIZE PRECIPITATION LOGICALS. +! ---------------------------------------------------------------------- + SNOWNG = .FALSE. + FRZGRA = .FALSE. + +! ---------------------------------------------------------------------- +! IF INPUT SNOWPACK IS NONZERO, THEN COMPUTE SNOW DENSITY "SNDENS" AND +! SNOW THERMAL CONDUCTIVITY "SNCOND" (NOTE THAT CSNOW IS A FUNCTION +! SUBROUTINE) +! ---------------------------------------------------------------------- + IF ( SNEQV <= 1.E-7 ) THEN ! safer IF kmh (2008/03/25) + SNEQV = 0.0 + SNDENS = 0.0 + SNOWH = 0.0 + SNCOND = 1.0 + ELSE + SNDENS = SNEQV / SNOWH + IF(SNDENS > 1.0) THEN + errmsg = 'Physical snow depth is less than snow water equiv.' + errflg = 1 + return + ENDIF + CALL CSNOW (SNCOND,SNDENS) + END IF +! ---------------------------------------------------------------------- +! DETERMINE IF IT'S PRECIPITATING AND WHAT KIND OF PRECIP IT IS. +! IF IT'S PRCPING AND THE AIR TEMP IS COLDER THAN 0 C, IT'S SNOWING! +! IF IT'S PRCPING AND THE AIR TEMP IS WARMER THAN 0 C, BUT THE GRND +! TEMP IS COLDER THAN 0 C, FREEZING RAIN IS PRESUMED TO BE FALLING. +! ---------------------------------------------------------------------- + IF (PRCP > 0.0) THEN +! snow defined when fraction of frozen precip (FFROZP) > 0.5, +! passed in from model microphysics. + IF (FFROZP .GT. 0.5) THEN + SNOWNG = .TRUE. + ELSE + IF (T1 <= TFREEZ) FRZGRA = .TRUE. + END IF + END IF +! ---------------------------------------------------------------------- +! IF EITHER PRCP FLAG IS SET, DETERMINE NEW SNOWFALL (CONVERTING PRCP +! RATE FROM KG M-2 S-1 TO A LIQUID EQUIV SNOW DEPTH IN METERS) AND ADD +! IT TO THE EXISTING SNOWPACK. +! NOTE THAT SINCE ALL PRECIP IS ADDED TO SNOWPACK, NO PRECIP INFILTRATES +! INTO THE SOIL SO THAT PRCP1 IS SET TO ZERO. +! ---------------------------------------------------------------------- + IF ( (SNOWNG) .OR. (FRZGRA) ) THEN + SN_NEW = PRCP * DT * 0.001 + SNEQV = SNEQV + SN_NEW + PRCPF = 0.0 + +! ---------------------------------------------------------------------- +! UPDATE SNOW DENSITY BASED ON NEW SNOWFALL, USING OLD AND NEW SNOW. +! UPDATE SNOW THERMAL CONDUCTIVITY +! ---------------------------------------------------------------------- + CALL SNOW_NEW (SFCTMP,SN_NEW,SNOWH,SNDENS) + CALL CSNOW (SNCOND,SNDENS) + +! ---------------------------------------------------------------------- +! PRECIP IS LIQUID (RAIN), HENCE SAVE IN THE PRECIP VARIABLE THAT +! LATER CAN WHOLELY OR PARTIALLY INFILTRATE THE SOIL (ALONG WITH +! ANY CANOPY "DRIP" ADDED TO THIS LATER) +! ---------------------------------------------------------------------- + ELSE + PRCPF = PRCP + ENDIF +! ---------------------------------------------------------------------- +! DETERMINE SNOWCOVER AND ALBEDO OVER LAND. +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! IF SNOW DEPTH=0, SET SNOW FRACTION=0, ALBEDO=SNOW FREE ALBEDO. +! ---------------------------------------------------------------------- + IF (SNEQV == 0.0) THEN + SNCOVR = 0.0 + ALBEDO = ALB + EMISSI = EMBRD + IF(UA_PHYS) FGSN = 0.0 + IF(UA_PHYS) FVB = 0.0 + IF(UA_PHYS) FBUR = 0.0 + ELSE +! ---------------------------------------------------------------------- +! DETERMINE SNOW FRACTIONAL COVERAGE. +! DETERMINE SURFACE ALBEDO MODIFICATION DUE TO SNOWDEPTH STATE. +! ---------------------------------------------------------------------- + CALL SNFRAC (SNEQV,SNUP,SALP,SNOWH,SNCOVR, & + XLAI,SHDFAC,FVB,GAMA,FBUR, & + FGSN,ZTOPV,ZBOTV,UA_PHYS) + + IF ( UA_PHYS ) then + IF(SFCTMP <= T1) THEN + RU = 0. + ELSE + RU = 100.*SHDFAC*FGSN*MIN((SFCTMP-T1)/5., 1.)*(1.-EXP(-XLAI)) + ENDIF + CH = CH/(1.+RU*CH) + ENDIF + + SNCOVR = MIN(SNCOVR,0.98) + + CALL ALCALC (ALB,SNOALB,EMBRD,SHDFAC,SHDMIN,SNCOVR,T1, & + ALBEDO,EMISSI,DT,SNOWNG,SNOTIME1,LVCOEF) + ENDIF +! ---------------------------------------------------------------------- +! NEXT CALCULATE THE SUBSURFACE HEAT FLUX, WHICH FIRST REQUIRES +! CALCULATION OF THE THERMAL DIFFUSIVITY. TREATMENT OF THE +! LATTER FOLLOWS THAT ON PAGES 148-149 FROM "HEAT TRANSFER IN +! COLD CLIMATES", BY V. J. LUNARDINI (PUBLISHED IN 1981 +! BY VAN NOSTRAND REINHOLD CO.) I.E. TREATMENT OF TWO CONTIGUOUS +! "PLANE PARALLEL" MEDIUMS (NAMELY HERE THE FIRST SOIL LAYER +! AND THE SNOWPACK LAYER, IF ANY). THIS DIFFUSIVITY TREATMENT +! BEHAVES WELL FOR BOTH ZERO AND NONZERO SNOWPACK, INCLUDING THE +! LIMIT OF VERY THIN SNOWPACK. THIS TREATMENT ALSO ELIMINATES +! THE NEED TO IMPOSE AN ARBITRARY UPPER BOUND ON SUBSURFACE +! HEAT FLUX WHEN THE SNOWPACK BECOMES EXTREMELY THIN. +! ---------------------------------------------------------------------- +! FIRST CALCULATE THERMAL DIFFUSIVITY OF TOP SOIL LAYER, USING +! BOTH THE FROZEN AND LIQUID SOIL MOISTURE, FOLLOWING THE +! SOIL THERMAL DIFFUSIVITY FUNCTION OF PETERS-LIDARD ET AL. +! (1998,JAS, VOL 55, 1209-1224), WHICH REQUIRES THE SPECIFYING +! THE QUARTZ CONTENT OF THE GIVEN SOIL CLASS (SEE ROUTINE REDPRM) +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! NEXT ADD SUBSURFACE HEAT FLUX REDUCTION EFFECT FROM THE +! OVERLYING GREEN CANOPY, ADAPTED FROM SECTION 2.1.2 OF +! PETERS-LIDARD ET AL. (1997, JGR, VOL 102(D4)) +! ---------------------------------------------------------------------- + CALL TDFCND (DF1,SMC (1),QUARTZ,SMCMAX,SH2O (1),BEXP, PSISAT, SOILTYP, OPT_THCND) + +!urban + IF ( VEGTYP == ISURBAN ) DF1=3.24 + + DF1 = DF1 * EXP (SBETA * SHDFAC) +! +! kmh 09/03/2006 +! kmh 03/25/2008 change SNCOVR threshold to 0.97 +! + IF ( SNCOVR .GT. 0.97 ) THEN + DF1 = SNCOND + ENDIF +! +! ---------------------------------------------------------------------- +! FINALLY "PLANE PARALLEL" SNOWPACK EFFECT FOLLOWING +! V.J. LINARDINI REFERENCE CITED ABOVE. NOTE THAT DTOT IS +! COMBINED DEPTH OF SNOWDEPTH AND THICKNESS OF FIRST SOIL LAYER +! ---------------------------------------------------------------------- + + DSOIL = - (0.5 * ZSOIL (1)) + IF (SNEQV == 0.) THEN + SSOIL = DF1 * (T1- STC (1) ) / DSOIL + ELSE + DTOT = SNOWH + DSOIL + FRCSNO = SNOWH / DTOT + +! 1. HARMONIC MEAN (SERIES FLOW) +! DF1 = (SNCOND*DF1)/(FRCSOI*SNCOND+FRCSNO*DF1) + FRCSOI = DSOIL / DTOT +! 2. ARITHMETIC MEAN (PARALLEL FLOW) +! DF1 = FRCSNO*SNCOND + FRCSOI*DF1 + DF1H = (SNCOND * DF1)/ (FRCSOI * SNCOND+ FRCSNO * DF1) + +! 3. GEOMETRIC MEAN (INTERMEDIATE BETWEEN HARMONIC AND ARITHMETIC MEAN) +! DF1 = (SNCOND**FRCSNO)*(DF1**FRCSOI) +! weigh DF by snow fraction +! DF1 = DF1H*SNCOVR + DF1A*(1.0-SNCOVR) +! DF1 = DF1H*SNCOVR + DF1*(1.0-SNCOVR) + DF1A = FRCSNO * SNCOND+ FRCSOI * DF1 + +! ---------------------------------------------------------------------- +! CALCULATE SUBSURFACE HEAT FLUX, SSOIL, FROM FINAL THERMAL DIFFUSIVITY +! OF SURFACE MEDIUMS, DF1 ABOVE, AND SKIN TEMPERATURE AND TOP +! MID-LAYER SOIL TEMPERATURE +! ---------------------------------------------------------------------- + DF1 = DF1A * SNCOVR + DF1* (1.0- SNCOVR) + SSOIL = DF1 * (T1- STC (1) ) / DTOT + END IF +! ---------------------------------------------------------------------- +! DETERMINE SURFACE ROUGHNESS OVER SNOWPACK USING SNOW CONDITION FROM +! THE PREVIOUS TIMESTEP. +! ---------------------------------------------------------------------- + IF (SNCOVR > 0. ) THEN + CALL SNOWZ0 (SNCOVR,Z0,Z0BRD,SNOWH,FBUR,FGSN,SHDMAX,UA_PHYS) + ELSE + Z0=Z0BRD + IF(UA_PHYS) CALL SNOWZ0 (SNCOVR,Z0,Z0BRD,SNOWH,FBUR,FGSN, & + SHDMAX,UA_PHYS) + END IF +! ---------------------------------------------------------------------- +! NEXT CALL ROUTINE SFCDIF TO CALCULATE THE SFC EXCHANGE COEF (CH) FOR +! HEAT AND MOISTURE. + +! NOTE !!! +! DO NOT CALL SFCDIF UNTIL AFTER ABOVE CALL TO REDPRM, IN CASE +! ALTERNATIVE VALUES OF ROUGHNESS LENGTH (Z0) AND ZILINTINKEVICH COEF +! (CZIL) ARE SET THERE VIA NAMELIST I/O. + +! NOTE !!! +! ROUTINE SFCDIF RETURNS A CH THAT REPRESENTS THE WIND SPD TIMES THE +! "ORIGINAL" NONDIMENSIONAL "Ch" TYPICAL IN LITERATURE. HENCE THE CH +! RETURNED FROM SFCDIF HAS UNITS OF M/S. THE IMPORTANT COMPANION +! COEFFICIENT OF CH, CARRIED HERE AS "RCH", IS THE CH FROM SFCDIF TIMES +! AIR DENSITY AND PARAMETER "CP". "RCH" IS COMPUTED IN "CALL PENMAN". +! RCH RATHER THAN CH IS THE COEFF USUALLY INVOKED LATER IN EQNS. + +! NOTE !!! +! ---------------------------------------------------------------------- +! SFCDIF ALSO RETURNS THE SURFACE EXCHANGE COEFFICIENT FOR MOMENTUM, CM, +! ALSO KNOWN AS THE SURFACE DRAGE COEFFICIENT. Needed as a state variable +! for iterative/implicit solution of CH in SFCDIF +! ---------------------------------------------------------------------- +! IF(.NOT.LCH) THEN +! T1V = T1 * (1.0+ 0.61 * Q2) +! TH2V = TH2 * (1.0+ 0.61 * Q2) +! CALL SFCDIF_off (ZLVL,Z0,T1V,TH2V,SFCSPD,CZIL,CM,CH) +! ENDIF + +! ---------------------------------------------------------------------- +! CALL PENMAN SUBROUTINE TO CALCULATE POTENTIAL EVAPORATION (ETP), AND +! OTHER PARTIAL PRODUCTS AND SUMS SAVE IN COMMON/RITE FOR LATER +! CALCULATIONS. +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! CALCULATE TOTAL DOWNWARD RADIATION (SOLAR PLUS LONGWAVE) NEEDED IN +! PENMAN EP SUBROUTINE THAT FOLLOWS +! ---------------------------------------------------------------------- +! FDOWN = SOLDN * (1.0- ALBEDO) + LWDN + FDOWN = SOLNET + LWDN +! ---------------------------------------------------------------------- +! CALC VIRTUAL TEMPS AND VIRTUAL POTENTIAL TEMPS NEEDED BY SUBROUTINES +! PENMAN. + T2V = SFCTMP * (1.0+ 0.61 * Q2 ) + + iout=0 + if(iout.eq.1) then + print*,'before penman' + print*,' SFCTMP',SFCTMP,'SFCPRS',SFCPRS,'CH',CH,'T2V',T2V, & + 'TH2',TH2,'PRCP',PRCP,'FDOWN',FDOWN,'T24',T24,'SSOIL',SSOIL, & + 'Q2',Q2,'Q2SAT',Q2SAT,'ETP',ETP,'RCH',RCH, & + 'EPSCA',EPSCA,'RR',RR ,'SNOWNG',SNOWNG,'FRZGRA',FRZGRA, & + 'DQSDT2',DQSDT2,'FLX2',FLX2,'SNOWH',SNOWH,'SNEQV',SNEQV, & + ' DSOIL',DSOIL,' FRCSNO',FRCSNO,' SNCOVR',SNCOVR,' DTOT',DTOT, & + ' ZSOIL (1)',ZSOIL(1),' DF1',DF1,'T1',T1,' STC1',STC(1), & + 'ALBEDO',ALBEDO,'SMC',SMC,'STC',STC,'SH2O',SH2O + endif + + CALL PENMAN (SFCTMP,SFCPRS,CH,T2V,TH2,PRCP,FDOWN,T24,SSOIL, & + Q2,Q2SAT,ETP,RCH,EPSCA,RR,SNOWNG,FRZGRA, & + DQSDT2,FLX2,EMISSI,SNEQV,T1,SNCOVR,AOASIS, & + ALBEDO,SOLDN,FVB,GAMA,STC(1),ETPN,FLX4,UA_PHYS, & + CP,RD,SIGMA,CPH2O,CPICE,LSUBF) +! +! ---------------------------------------------------------------------- +! CALL CANRES TO CALCULATE THE CANOPY RESISTANCE AND CONVERT IT INTO PC +! IF NONZERO GREENNESS FRACTION +! ---------------------------------------------------------------------- + +! ---------------------------------------------------------------------- +! FROZEN GROUND EXTENSION: TOTAL SOIL WATER "SMC" WAS REPLACED +! BY UNFROZEN SOIL WATER "SH2O" IN CALL TO CANRES BELOW +! ---------------------------------------------------------------------- + IF ( (SHDFAC > 0.) .AND. (XLAI > 0.) ) THEN + CALL CANRES (SOLDN,CH,SFCTMP,Q2,SFCPRS,SH2O,ZSOIL,NSOIL, & + SMCWLT,SMCREF,RSMIN,RC,PC,NROOT,Q2SAT,DQSDT2, & + TOPT,RSMAX,RGL,HS,XLAI, & + RCS,RCT,RCQ,RCSOIL,EMISSI,CP,RD,SIGMA) + ELSE + RC = 0.0 + END IF +! ---------------------------------------------------------------------- +! NOW DECIDE MAJOR PATHWAY BRANCH TO TAKE DEPENDING ON WHETHER SNOWPACK +! EXISTS OR NOT: +! ---------------------------------------------------------------------- + ESNOW = 0.0 + IF (SNEQV == 0.0) THEN + CALL NOPAC (ETP,ETA,PRCP,SMC,SMCMAX,SMCWLT, & + SMCREF,SMCDRY,CMC,CMCMAX,NSOIL,DT, & + SHDFAC, & + SBETA,Q2,T1,SFCTMP,T24,TH2,FDOWN,F1,EMISSI, & + SSOIL, & + STC,EPSCA,BEXP,PC,RCH,RR,CFACTR, & + SH2O,SLOPE,KDT,FRZX,PSISAT,ZSOIL, & + DKSAT,DWSAT,TBOT,ZBOT,RUNOFF1,RUNOFF2, & + RUNOFF3,EDIR,EC,ET,ETT,NROOT,RTDIS, & + QUARTZ,FXEXP,CSOIL, & + BETA,DRIP,DEW,FLX1,FLX3,VEGTYP,ISURBAN, & + SFHEAD1RT,INFXS1RT,ETPND1,SOILTYP,OPT_THCND & + ,XSDA_QFX,QFX_PHY,XQNORM,fasdas,HCPCT_FASDAS, & !fasdas + SIGMA,CPH2O) + ETA_KINEMATIC = ETA + ELSE + CALL SNOPAC (ETP,ETA,PRCP,PRCPF,SNOWNG,SMC,SMCMAX,SMCWLT, & + SMCREF,SMCDRY,CMC,CMCMAX,NSOIL,DT, & + SBETA,DF1, & + Q2,T1,SFCTMP,T24,TH2,FDOWN,F1,SSOIL,STC,EPSCA, & + SFCPRS,BEXP,PC,RCH,RR,CFACTR,SNCOVR,SNEQV,SNDENS,& + SNOWH,SH2O,SLOPE,KDT,FRZX,PSISAT, & + ZSOIL,DWSAT,DKSAT,TBOT,ZBOT,SHDFAC,RUNOFF1, & + RUNOFF2,RUNOFF3,EDIR,EC,ET,ETT,NROOT,SNOMLT, & + RTDIS,QUARTZ,FXEXP,CSOIL, & + BETA,DRIP,DEW,FLX1,FLX2,FLX3,ESNOW,ETNS,EMISSI, & + RIBB,SOLDN, & + ISURBAN, & + VEGTYP, & + ETPN,FLX4,UA_PHYS, & + SFHEAD1RT,INFXS1RT,ETPND1,SOILTYP,OPT_THCND & + ,QFX_PHY,fasdas,HCPCT_FASDAS,SIGMA,CPH2O,CPICE, & !fasdas + LSUBF) + ETA_KINEMATIC = ESNOW + ETNS - 1000.0*DEW + END IF + +! Calculate effective mixing ratio at grnd level (skin) +! +! Q1=Q2+ETA*CP/RCH + Q1=Q2+ETA_KINEMATIC*CP/RCH +! +! ---------------------------------------------------------------------- +! DETERMINE SENSIBLE HEAT (H) IN ENERGY UNITS (W M-2) +! ---------------------------------------------------------------------- + + SHEAT = - (CH * CP * SFCPRS)/ (R * T2V) * ( TH2- T1 ) + IF(UA_PHYS) SHEAT = SHEAT + FLX4 +! +! FASDAS +! + IF ( fasdas == 1 ) THEN + HFX_PHY = SHEAT + ENDIF +! +! END FASDAS +! +! ---------------------------------------------------------------------- +! CONVERT EVAP TERMS FROM KINEMATIC (KG M-2 S-1) TO ENERGY UNITS (W M-2) +! ---------------------------------------------------------------------- + EDIR = EDIR * LVH2O + EC = EC * LVH2O + DO K=1,4 + ET(K) = ET(K) * LVH2O + ENDDO + ETT = ETT * LVH2O + + ETPND1=ETPND1 * LVH2O + + ESNOW = ESNOW * LSUBS + ETP = ETP*((1.-SNCOVR)*LVH2O + SNCOVR*LSUBS) + IF(UA_PHYS) ETPN = ETPN*((1.-SNCOVR)*LVH2O + SNCOVR*LSUBS) + IF (ETP .GT. 0.) THEN + ETA = EDIR + EC + ETT + ESNOW + ELSE + ETA = ETP + ENDIF +! ---------------------------------------------------------------------- +! DETERMINE BETA (RATIO OF ACTUAL TO POTENTIAL EVAP) +! ---------------------------------------------------------------------- + IF (ETP == 0.0) THEN + BETA = 0.0 + ELSE + BETA = ETA/ETP + ENDIF + +! ---------------------------------------------------------------------- +! CONVERT THE SIGN OF SOIL HEAT FLUX SO THAT: +! SSOIL>0: WARM THE SURFACE (NIGHT TIME) +! SSOIL<0: COOL THE SURFACE (DAY TIME) +! ---------------------------------------------------------------------- + SSOIL = -1.0* SSOIL + +! ---------------------------------------------------------------------- +! FOR THE CASE OF LAND: +! CONVERT RUNOFF3 (INTERNAL LAYER RUNOFF FROM SUPERSAT) FROM M TO M S-1 +! AND ADD TO SUBSURFACE RUNOFF/DRAINAGE/BASEFLOW. RUNOFF2 IS ALREADY +! A RATE AT THIS POINT +! ---------------------------------------------------------------------- + RUNOFF3 = RUNOFF3/ DT + RUNOFF2 = RUNOFF2+ RUNOFF3 + SOILM = -1.0* SMC (1)* ZSOIL (1) + DO K = 2,NSOIL + SOILM = SOILM + SMC (K)* (ZSOIL (K -1) - ZSOIL (K)) + END DO + SOILWM = -1.0* (SMCMAX - SMCWLT)* ZSOIL (1) + SOILWW = -1.0* (SMC (1) - SMCWLT)* ZSOIL (1) + + DO K = 1,NSOIL + SMAV(K)=(SMC(K) - SMCWLT)/(SMCMAX - SMCWLT) + END DO + + IF (NROOT >= 2) THEN + DO K = 2,NROOT + SOILWM = SOILWM + (SMCMAX - SMCWLT)* (ZSOIL (K -1) - ZSOIL (K)) + SOILWW = SOILWW + (SMC(K) - SMCWLT)* (ZSOIL (K -1) - ZSOIL (K)) + END DO + END IF + IF (SOILWM .LT. 1.E-6) THEN + SOILWM = 0.0 + SOILW = 0.0 + SOILM = 0.0 + ELSE + SOILW = SOILWW / SOILWM + END IF + +! ---------------------------------------------------------------------- + END SUBROUTINE SFLX +! ---------------------------------------------------------------------- + + SUBROUTINE ALCALC (ALB,SNOALB,EMBRD,SHDFAC,SHDMIN,SNCOVR,TSNOW,ALBEDO,EMISSI, & + DT,SNOWNG,SNOTIME1,LVCOEF) + +! ---------------------------------------------------------------------- +! CALCULATE ALBEDO INCLUDING SNOW EFFECT (0 -> 1) +! ALB SNOWFREE ALBEDO +! SNOALB MAXIMUM (DEEP) SNOW ALBEDO +! SHDFAC AREAL FRACTIONAL COVERAGE OF GREEN VEGETATION +! SHDMIN MINIMUM AREAL FRACTIONAL COVERAGE OF GREEN VEGETATION +! SNCOVR FRACTIONAL SNOW COVER +! ALBEDO SURFACE ALBEDO INCLUDING SNOW EFFECT +! TSNOW SNOW SURFACE TEMPERATURE (K) +! ---------------------------------------------------------------------- + IMPLICIT NONE + +! ---------------------------------------------------------------------- +! SNOALB IS ARGUMENT REPRESENTING MAXIMUM ALBEDO OVER DEEP SNOW, +! AS PASSED INTO SFLX, AND ADAPTED FROM THE SATELLITE-BASED MAXIMUM +! SNOW ALBEDO FIELDS PROVIDED BY D. ROBINSON AND G. KUKLA +! (1985, JCAM, VOL 24, 402-411) +! ---------------------------------------------------------------------- + REAL, INTENT(IN) :: ALB, SNOALB, EMBRD, SHDFAC, SHDMIN, SNCOVR, TSNOW + REAL, INTENT(IN) :: DT + LOGICAL, INTENT(IN) :: SNOWNG + REAL, INTENT(INOUT):: SNOTIME1 + REAL, INTENT(OUT) :: ALBEDO, EMISSI + REAL :: SNOALB2 + REAL :: TM,SNOALB1 + REAL, INTENT(IN) :: LVCOEF + REAL, PARAMETER :: SNACCA=0.94,SNACCB=0.58,SNTHWA=0.82,SNTHWB=0.46 +! turn of vegetation effect +! ALBEDO = ALB + (1.0- (SHDFAC - SHDMIN))* SNCOVR * (SNOALB - ALB) +! ALBEDO = (1.0-SNCOVR)*ALB + SNCOVR*SNOALB !this is equivalent to below + ALBEDO = ALB + SNCOVR*(SNOALB-ALB) + EMISSI = EMBRD + SNCOVR*(EMISSI_S - EMBRD) + +! BASE FORMULATION (DICKINSON ET AL., 1986, COGLEY ET AL., 1990) +! IF (TSNOW.LE.263.16) THEN +! ALBEDO=SNOALB +! ELSE +! IF (TSNOW.LT.273.16) THEN +! TM=0.1*(TSNOW-263.16) +! SNOALB1=0.5*((0.9-0.2*(TM**3))+(0.8-0.16*(TM**3))) +! ELSE +! SNOALB1=0.67 +! IF(SNCOVR.GT.0.95) SNOALB1= 0.6 +! SNOALB1 = ALB + SNCOVR*(SNOALB-ALB) +! ENDIF +! ENDIF +! ALBEDO = ALB + SNCOVR*(SNOALB1-ALB) + +! ISBA FORMULATION (VERSEGHY, 1991; BAKER ET AL., 1990) +! SNOALB1 = SNOALB+COEF*(0.85-SNOALB) +! SNOALB2=SNOALB1 +!!m LSTSNW=LSTSNW+1 +! SNOTIME1 = SNOTIME1 + DT +! IF (SNOWNG) THEN +! SNOALB2=SNOALB +!!m LSTSNW=0 +! SNOTIME1 = 0.0 +! ELSE +! IF (TSNOW.LT.273.16) THEN +!! SNOALB2=SNOALB-0.008*LSTSNW*DT/86400 +!!m SNOALB2=SNOALB-0.008*SNOTIME1/86400 +! SNOALB2=(SNOALB2-0.65)*EXP(-0.05*DT/3600)+0.65 +!! SNOALB2=(ALBEDO-0.65)*EXP(-0.01*DT/3600)+0.65 +! ELSE +! SNOALB2=(SNOALB2-0.5)*EXP(-0.0005*DT/3600)+0.5 +!! SNOALB2=(SNOALB-0.5)*EXP(-0.24*LSTSNW*DT/86400)+0.5 +!!m SNOALB2=(SNOALB-0.5)*EXP(-0.24*SNOTIME1/86400)+0.5 +! ENDIF +! ENDIF +! +!! print*,'SNOALB2',SNOALB2,'ALBEDO',ALBEDO,'DT',DT +! ALBEDO = ALB + SNCOVR*(SNOALB2-ALB) +! IF (ALBEDO .GT. SNOALB2) ALBEDO=SNOALB2 +!!m LSTSNW1=LSTSNW +!! SNOTIME = SNOTIME1 + +! formulation by Livneh +! ---------------------------------------------------------------------- +! SNOALB IS CONSIDERED AS THE MAXIMUM SNOW ALBEDO FOR NEW SNOW, AT +! A VALUE OF 85%. SNOW ALBEDO CURVE DEFAULTS ARE FROM BRAS P.263. SHOULD +! NOT BE CHANGED EXCEPT FOR SERIOUS PROBLEMS WITH SNOW MELT. +! TO IMPLEMENT ACCUMULATIN PARAMETERS, SNACCA AND SNACCB, ASSERT THAT IT +! IS INDEED ACCUMULATION SEASON. I.E. THAT SNOW SURFACE TEMP IS BELOW +! ZERO AND THE DATE FALLS BETWEEN OCTOBER AND FEBRUARY +! ---------------------------------------------------------------------- + SNOALB1 = SNOALB+LVCOEF*(0.85-SNOALB) + SNOALB2=SNOALB1 +! ---------------- Initial LSTSNW -------------------------------------- + IF (SNOWNG) THEN + SNOTIME1 = 0. + ELSE + SNOTIME1=SNOTIME1+DT +! IF (TSNOW.LT.273.16) THEN + SNOALB2=SNOALB1*(SNACCA**((SNOTIME1/86400.0)**SNACCB)) +! ELSE +! SNOALB2 =SNOALB1*(SNTHWA**((SNOTIME1/86400.0)**SNTHWB)) +! ENDIF + ENDIF +! + SNOALB2 = MAX ( SNOALB2, ALB ) + ALBEDO = ALB + SNCOVR*(SNOALB2-ALB) + IF (ALBEDO .GT. SNOALB2) ALBEDO=SNOALB2 + +! IF (TSNOW.LT.273.16) THEN +! ALBEDO=SNOALB-0.008*DT/86400 +! ELSE +! ALBEDO=(SNOALB-0.5)*EXP(-0.24*DT/86400)+0.5 +! ENDIF + +! IF (ALBEDO > SNOALB) ALBEDO = SNOALB + +! ---------------------------------------------------------------------- + END SUBROUTINE ALCALC +! ---------------------------------------------------------------------- + + SUBROUTINE CANRES (SOLAR,CH,SFCTMP,Q2,SFCPRS,SMC,ZSOIL,NSOIL, & + SMCWLT,SMCREF,RSMIN,RC,PC,NROOT,Q2SAT,DQSDT2, & + TOPT,RSMAX,RGL,HS,XLAI, & + RCS,RCT,RCQ,RCSOIL,EMISSI,CP,RD,SIGMA) + +! ---------------------------------------------------------------------- +! SUBROUTINE CANRES +! ---------------------------------------------------------------------- +! CALCULATE CANOPY RESISTANCE WHICH DEPENDS ON INCOMING SOLAR RADIATION, +! AIR TEMPERATURE, ATMOSPHERIC WATER VAPOR PRESSURE DEFICIT AT THE +! LOWEST MODEL LEVEL, AND SOIL MOISTURE (PREFERABLY UNFROZEN SOIL +! MOISTURE RATHER THAN TOTAL) +! ---------------------------------------------------------------------- +! SOURCE: JARVIS (1976), NOILHAN AND PLANTON (1989, MWR), JACQUEMIN AND +! NOILHAN (1990, BLM) +! SEE ALSO: CHEN ET AL (1996, JGR, VOL 101(D3), 7251-7268), EQNS 12-14 +! AND TABLE 2 OF SEC. 3.1.2 +! ---------------------------------------------------------------------- +! INPUT: +! SOLAR INCOMING SOLAR RADIATION +! CH SURFACE EXCHANGE COEFFICIENT FOR HEAT AND MOISTURE +! SFCTMP AIR TEMPERATURE AT 1ST LEVEL ABOVE GROUND +! Q2 AIR HUMIDITY AT 1ST LEVEL ABOVE GROUND +! Q2SAT SATURATION AIR HUMIDITY AT 1ST LEVEL ABOVE GROUND +! DQSDT2 SLOPE OF SATURATION HUMIDITY FUNCTION WRT TEMP +! SFCPRS SURFACE PRESSURE +! SMC VOLUMETRIC SOIL MOISTURE +! ZSOIL SOIL DEPTH (NEGATIVE SIGN, AS IT IS BELOW GROUND) +! NSOIL NO. OF SOIL LAYERS +! NROOT NO. OF SOIL LAYERS IN ROOT ZONE (1.LE.NROOT.LE.NSOIL) +! XLAI LEAF AREA INDEX +! SMCWLT WILTING POINT +! SMCREF REFERENCE SOIL MOISTURE (WHERE SOIL WATER DEFICIT STRESS +! SETS IN) +! RSMIN, RSMAX, TOPT, RGL, HS ARE CANOPY STRESS PARAMETERS SET IN +! SURBOUTINE REDPRM +! CP specific heat of dry air at constant pressure +! OUTPUT: +! PC PLANT COEFFICIENT +! RC CANOPY RESISTANCE +! ---------------------------------------------------------------------- + + IMPLICIT NONE + INTEGER, INTENT(IN) :: NROOT,NSOIL + INTEGER K + REAL, INTENT(IN) :: CH,DQSDT2,HS,Q2,Q2SAT,RSMIN,RGL,RSMAX, & + SFCPRS,SFCTMP,SMCREF,SMCWLT, SOLAR,TOPT,XLAI, & + EMISSI, CP, RD, SIGMA + REAL,DIMENSION(1:NSOIL), INTENT(IN) :: SMC,ZSOIL + REAL, INTENT(OUT):: PC,RC,RCQ,RCS,RCSOIL,RCT + REAL :: DELTA,FF,GX,P,RR + REAL, DIMENSION(1:NSOIL) :: PART + REAL, PARAMETER :: SLV = 2.501000E6 + + +! ---------------------------------------------------------------------- +! INITIALIZE CANOPY RESISTANCE MULTIPLIER TERMS. +! ---------------------------------------------------------------------- + RCS = 0.0 + RCT = 0.0 + RCQ = 0.0 + RCSOIL = 0.0 + +! ---------------------------------------------------------------------- +! CONTRIBUTION DUE TO INCOMING SOLAR RADIATION +! ---------------------------------------------------------------------- + RC = 0.0 + FF = 0.55*2.0* SOLAR / (RGL * XLAI) + RCS = (FF + RSMIN / RSMAX) / (1.0+ FF) + +! ---------------------------------------------------------------------- +! CONTRIBUTION DUE TO AIR TEMPERATURE AT FIRST MODEL LEVEL ABOVE GROUND +! RCT EXPRESSION FROM NOILHAN AND PLANTON (1989, MWR). +! ---------------------------------------------------------------------- + RCS = MAX (RCS,0.0001) + RCT = 1.0- 0.0016* ( (TOPT - SFCTMP)**2.0) + +! ---------------------------------------------------------------------- +! CONTRIBUTION DUE TO VAPOR PRESSURE DEFICIT AT FIRST MODEL LEVEL. +! RCQ EXPRESSION FROM SSIB +! ---------------------------------------------------------------------- + RCT = MAX (RCT,0.0001) + RCQ = 1.0/ (1.0+ HS * (Q2SAT - Q2)) + +! ---------------------------------------------------------------------- +! CONTRIBUTION DUE TO SOIL MOISTURE AVAILABILITY. +! DETERMINE CONTRIBUTION FROM EACH SOIL LAYER, THEN ADD THEM UP. +! ---------------------------------------------------------------------- + RCQ = MAX (RCQ,0.01) + GX = (SMC (1) - SMCWLT) / (SMCREF - SMCWLT) + IF (GX > 1.) GX = 1. + IF (GX < 0.) GX = 0. + +! ---------------------------------------------------------------------- +! USE SOIL DEPTH AS WEIGHTING FACTOR +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! USE ROOT DISTRIBUTION AS WEIGHTING FACTOR +! PART(1) = RTDIS(1) * GX +! ---------------------------------------------------------------------- + PART (1) = (ZSOIL (1)/ ZSOIL (NROOT)) * GX + DO K = 2,NROOT + GX = (SMC (K) - SMCWLT) / (SMCREF - SMCWLT) + IF (GX > 1.) GX = 1. + IF (GX < 0.) GX = 0. +! ---------------------------------------------------------------------- +! USE SOIL DEPTH AS WEIGHTING FACTOR +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! USE ROOT DISTRIBUTION AS WEIGHTING FACTOR +! PART(K) = RTDIS(K) * GX +! ---------------------------------------------------------------------- + PART (K) = ( (ZSOIL (K) - ZSOIL (K -1))/ ZSOIL (NROOT)) * GX + END DO + DO K = 1,NROOT + RCSOIL = RCSOIL + PART (K) + END DO + +! ---------------------------------------------------------------------- +! DETERMINE CANOPY RESISTANCE DUE TO ALL FACTORS. CONVERT CANOPY +! RESISTANCE (RC) TO PLANT COEFFICIENT (PC) TO BE USED WITH POTENTIAL +! EVAP IN DETERMINING ACTUAL EVAP. PC IS DETERMINED BY: +! PC * LINERIZED PENMAN POTENTIAL EVAP = +! PENMAN-MONTEITH ACTUAL EVAPORATION (CONTAINING RC TERM). +! ---------------------------------------------------------------------- + RCSOIL = MAX (RCSOIL,0.0001) + + RC = RSMIN / (XLAI * RCS * RCT * RCQ * RCSOIL) +! RR = (4.* SIGMA * RD / CP)* (SFCTMP **4.)/ (SFCPRS * CH) + 1.0 + RR = (4.* EMISSI *SIGMA * RD / CP)* (SFCTMP **4.)/ (SFCPRS * CH) & + + 1.0 + + DELTA = (SLV / CP)* DQSDT2 + + PC = (RR + DELTA)/ (RR * (1. + RC * CH) + DELTA) + +! ---------------------------------------------------------------------- + END SUBROUTINE CANRES +! ---------------------------------------------------------------------- + + SUBROUTINE CSNOW (SNCOND,DSNOW) + +! ---------------------------------------------------------------------- +! SUBROUTINE CSNOW +! FUNCTION CSNOW +! ---------------------------------------------------------------------- +! CALCULATE SNOW TERMAL CONDUCTIVITY +! ---------------------------------------------------------------------- + IMPLICIT NONE + REAL, INTENT(IN) :: DSNOW + REAL, INTENT(OUT):: SNCOND + REAL :: C + REAL, PARAMETER :: UNIT = 0.11631 + +! ---------------------------------------------------------------------- +! SNCOND IN UNITS OF CAL/(CM*HR*C), RETURNED IN W/(M*C) +! CSNOW IN UNITS OF CAL/(CM*HR*C), RETURNED IN W/(M*C) +! BASIC VERSION IS DYACHKOVA EQUATION (1960), FOR RANGE 0.1-0.4 +! ---------------------------------------------------------------------- + C = 0.328*10** (2.25* DSNOW) +! CSNOW=UNIT*C + +! ---------------------------------------------------------------------- +! DE VAUX EQUATION (1933), IN RANGE 0.1-0.6 +! ---------------------------------------------------------------------- +! SNCOND=0.0293*(1.+100.*DSNOW**2) +! CSNOW=0.0293*(1.+100.*DSNOW**2) + +! ---------------------------------------------------------------------- +! E. ANDERSEN FROM FLERCHINGER +! ---------------------------------------------------------------------- +! SNCOND=0.021+2.51*DSNOW**2 +! CSNOW=0.021+2.51*DSNOW**2 + +! SNCOND = UNIT * C +! double snow thermal conductivity + SNCOND = 2.0 * UNIT * C + +! ---------------------------------------------------------------------- + END SUBROUTINE CSNOW +! ---------------------------------------------------------------------- + SUBROUTINE DEVAP (EDIR,ETP1,SMC,ZSOIL,SHDFAC,SMCMAX,BEXP, & + DKSAT,DWSAT,SMCDRY,SMCREF,SMCWLT,FXEXP) + +! ---------------------------------------------------------------------- +! SUBROUTINE DEVAP +! FUNCTION DEVAP +! ---------------------------------------------------------------------- +! CALCULATE DIRECT SOIL EVAPORATION +! ---------------------------------------------------------------------- + IMPLICIT NONE + REAL, INTENT(IN) :: ETP1,SMC,BEXP,DKSAT,DWSAT,FXEXP, & + SHDFAC,SMCDRY,SMCMAX,ZSOIL,SMCREF,SMCWLT + REAL, INTENT(OUT):: EDIR + REAL :: FX, SRATIO + + +! ---------------------------------------------------------------------- +! DIRECT EVAP A FUNCTION OF RELATIVE SOIL MOISTURE AVAILABILITY, LINEAR +! WHEN FXEXP=1. +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! FX > 1 REPRESENTS DEMAND CONTROL +! FX < 1 REPRESENTS FLUX CONTROL +! ---------------------------------------------------------------------- + + SRATIO = (SMC - SMCDRY) / (SMCMAX - SMCDRY) + IF (SRATIO > 0.) THEN + FX = SRATIO**FXEXP + FX = MAX ( MIN ( FX, 1. ) ,0. ) + ELSE + FX = 0. + ENDIF + +! ---------------------------------------------------------------------- +! ALLOW FOR THE DIRECT-EVAP-REDUCING EFFECT OF SHADE +! ---------------------------------------------------------------------- + EDIR = FX * ( 1.0- SHDFAC ) * ETP1 + +! ---------------------------------------------------------------------- + END SUBROUTINE DEVAP + + SUBROUTINE DEVAP_hydro (EDIR,ETP1,SMC,ZSOIL,SHDFAC,SMCMAX,BEXP, & + DKSAT,DWSAT,SMCDRY,SMCREF,SMCWLT,FXEXP, & + SFHEAD1RT,ETPND1,DT) + +! ---------------------------------------------------------------------- +! SUBROUTINE DEVAP +! FUNCTION DEVAP +! ---------------------------------------------------------------------- +! CALCULATE DIRECT SOIL EVAPORATION +! ---------------------------------------------------------------------- + IMPLICIT NONE + REAL, INTENT(IN) :: ETP1,SMC,BEXP,DKSAT,DWSAT,FXEXP, & + SHDFAC,SMCDRY,SMCMAX,ZSOIL,SMCREF,SMCWLT + REAL, INTENT(OUT):: EDIR + REAL :: FX, SRATIO + + REAL, INTENT(INOUT) :: SFHEAD1RT,ETPND1 + REAL, INTENT(IN ) :: DT + REAL :: EDIRTMP + + + +! ---------------------------------------------------------------------- +! DIRECT EVAP A FUNCTION OF RELATIVE SOIL MOISTURE AVAILABILITY, LINEAR +! WHEN FXEXP=1. +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! FX > 1 REPRESENTS DEMAND CONTROL +! FX < 1 REPRESENTS FLUX CONTROL +! ---------------------------------------------------------------------- + + SRATIO = (SMC - SMCDRY) / (SMCMAX - SMCDRY) + IF (SRATIO > 0.) THEN + FX = SRATIO**FXEXP + FX = MAX ( MIN ( FX, 1. ) ,0. ) + ELSE + FX = 0. + ENDIF + +!DJG NDHMS/WRF-Hydro edits... Adjustment for ponded surface water : Reduce ETP1 + EDIRTMP = 0. + ETPND1 = 0. + +!DJG NDHMS/WRF-Hydro edits... Calc Max Potential Dir Evap. (ETP1 units: }=m/s) + +!DJG NDHMS/WRF-Hydro...currently set ponded water evap to 0.0 until further notice...11/5/2012 +!EDIRTMP = ( 1.0- SHDFAC ) * ETP1 + +! Convert all units to (m) +! Convert EDIRTMP from (kg m{-2} s{-1}=m/s) to (m) ... + EDIRTMP = EDIRTMP * DT + +!DJG NDHMS/WRF-Hydro edits... Convert SFHEAD from (mm) to (m) ... + SFHEAD1RT=SFHEAD1RT * 0.001 + + + +!DJG NDHMS/WRF-Hydro edits... Calculate ETPND as reduction in EDIR(TMP)... + IF (EDIRTMP > 0.) THEN + IF ( EDIRTMP > SFHEAD1RT ) THEN + ETPND1 = SFHEAD1RT + SFHEAD1RT=0. + EDIRTMP = EDIRTMP - ETPND1 + ELSE + ETPND1 = EDIRTMP + EDIRTMP = 0. + SFHEAD1RT = SFHEAD1RT - ETPND1 + END IF + END IF + +!DJG NDHMS/WRF-Hydro edits... Convert SFHEAD units back to (mm) + IF ( SFHEAD1RT /= 0.) SFHEAD1RT=SFHEAD1RT * 1000. + +!DJG NDHMS/WRF-Hydro edits...Convert ETPND and EDIRTMP back to (mm/s=kg m{-2} s{-1}) + ETPND1 = ETPND1 / DT + EDIRTMP = EDIRTMP / DT +!DEBUG print *, "After DEVAP...SFCHEAD+ETPND1",SFHEAD1RT+ETPND1*DT + + +! ---------------------------------------------------------------------- +! ALLOW FOR THE DIRECT-EVAP-REDUCING EFFECT OF SHADE +! ---------------------------------------------------------------------- +!DJG NDHMS/WRF-Hydro edits... +! EDIR = FX * ( 1.0- SHDFAC ) * ETP1 + EDIR = FX * EDIRTMP + + + + +! ---------------------------------------------------------------------- + END SUBROUTINE DEVAP_hydro +! ---------------------------------------------------------------------- + + SUBROUTINE EVAPO (ETA1,SMC,NSOIL,CMC,ETP1,DT,ZSOIL, & + SH2O, & + SMCMAX,BEXP,PC,SMCWLT,DKSAT,DWSAT, & + SMCREF,SHDFAC,CMCMAX, & + SMCDRY,CFACTR, & + EDIR,EC,ET,ETT,SFCTMP,Q2,NROOT,RTDIS,FXEXP, & + SFHEAD1RT,ETPND1) + +! ---------------------------------------------------------------------- +! SUBROUTINE EVAPO +! ---------------------------------------------------------------------- +! CALCULATE SOIL MOISTURE FLUX. THE SOIL MOISTURE CONTENT (SMC - A PER +! UNIT VOLUME MEASUREMENT) IS A DEPENDENT VARIABLE THAT IS UPDATED WITH +! PROGNOSTIC EQNS. THE CANOPY MOISTURE CONTENT (CMC) IS ALSO UPDATED. +! FROZEN GROUND VERSION: NEW STATES ADDED: SH2O, AND FROZEN GROUND +! CORRECTION FACTOR, FRZFACT AND PARAMETER SLOPE. +! ---------------------------------------------------------------------- + IMPLICIT NONE + INTEGER, INTENT(IN) :: NSOIL, NROOT + INTEGER :: I,K + REAL, INTENT(IN) :: BEXP, CFACTR,CMC,CMCMAX,DKSAT, & + DT,DWSAT,ETP1,FXEXP,PC,Q2,SFCTMP, & + SHDFAC,SMCDRY,SMCMAX,SMCREF,SMCWLT + REAL, INTENT(OUT) :: EC,EDIR,ETA1,ETT + REAL :: CMC2MS + REAL,DIMENSION(1:NSOIL), INTENT(IN) :: RTDIS, SMC, SH2O, ZSOIL + REAL,DIMENSION(1:NSOIL), INTENT(OUT) :: ET + + REAL, INTENT(INOUT) :: SFHEAD1RT,ETPND1 + +! ---------------------------------------------------------------------- +! EXECUTABLE CODE BEGINS HERE IF THE POTENTIAL EVAPOTRANSPIRATION IS +! GREATER THAN ZERO. +! ---------------------------------------------------------------------- + EDIR = 0. + EC = 0. + ETT = 0. + DO K = 1,NSOIL + ET (K) = 0. + END DO + +! ---------------------------------------------------------------------- +! RETRIEVE DIRECT EVAPORATION FROM SOIL SURFACE. CALL THIS FUNCTION +! ONLY IF VEG COVER NOT COMPLETE. +! FROZEN GROUND VERSION: SH2O STATES REPLACE SMC STATES. +! ---------------------------------------------------------------------- + IF (ETP1 > 0.0) THEN + IF (SHDFAC < 1.) THEN +#ifdef WRF_HYDRO +! CALL DEVAP_hydro (EDIR,ETP1,SMC (1),ZSOIL (1),SHDFAC,SMCMAX, & +! BEXP,DKSAT,DWSAT,SMCDRY,SMCREF,SMCWLT,FXEXP, & +! SFHEAD1RT,ETPND1,DT) +!DJG Reduce ETP1 by EDIR & ETPND1... +! ETP1=ETP1-EDIR-ETPND1 + +! following is the temparay setting ... + CALL DEVAP (EDIR,ETP1,SMC (1),ZSOIL (1),SHDFAC,SMCMAX, & + BEXP,DKSAT,DWSAT,SMCDRY,SMCREF,SMCWLT,FXEXP) +! ETP1=ETP1-EDIR +#else + CALL DEVAP (EDIR,ETP1,SMC (1),ZSOIL (1),SHDFAC,SMCMAX, & + BEXP,DKSAT,DWSAT,SMCDRY,SMCREF,SMCWLT,FXEXP) +#endif + END IF +! ---------------------------------------------------------------------- +! INITIALIZE PLANT TOTAL TRANSPIRATION, RETRIEVE PLANT TRANSPIRATION, +! AND ACCUMULATE IT FOR ALL SOIL LAYERS. +! ---------------------------------------------------------------------- + + IF (SHDFAC > 0.0) THEN + CALL TRANSP (ET,NSOIL,ETP1,SH2O,CMC,ZSOIL,SHDFAC,SMCWLT, & + CMCMAX,PC,CFACTR,SMCREF,SFCTMP,Q2,NROOT,RTDIS) + DO K = 1,NSOIL + ETT = ETT + ET ( K ) + END DO +! ---------------------------------------------------------------------- +! CALCULATE CANOPY EVAPORATION. +! IF STATEMENTS TO AVOID TANGENT LINEAR PROBLEMS NEAR CMC=0.0. +! ---------------------------------------------------------------------- + IF (CMC > 0.0) THEN + EC = SHDFAC * ( ( CMC / CMCMAX ) ** CFACTR ) * ETP1 + ELSE + EC = 0.0 + END IF +! ---------------------------------------------------------------------- +! EC SHOULD BE LIMITED BY THE TOTAL AMOUNT OF AVAILABLE WATER ON THE +! CANOPY. -F.CHEN, 18-OCT-1994 +! ---------------------------------------------------------------------- + CMC2MS = CMC / DT + EC = MIN ( CMC2MS, EC ) + END IF + END IF +! ---------------------------------------------------------------------- +! TOTAL UP EVAP AND TRANSP TYPES TO OBTAIN ACTUAL EVAPOTRANSP +! ---------------------------------------------------------------------- + ETA1 = EDIR + ETT + EC + +! ---------------------------------------------------------------------- + END SUBROUTINE EVAPO +! ---------------------------------------------------------------------- + + SUBROUTINE FAC2MIT(SMCMAX,FLIMIT) + IMPLICIT NONE + REAL, INTENT(IN) :: SMCMAX + REAL, INTENT(OUT) :: FLIMIT + + FLIMIT = 0.90 + + IF ( SMCMAX == 0.395 ) THEN + FLIMIT = 0.59 + ELSE IF ( ( SMCMAX == 0.434 ) .OR. ( SMCMAX == 0.404 ) ) THEN + FLIMIT = 0.85 + ELSE IF ( ( SMCMAX == 0.465 ) .OR. ( SMCMAX == 0.406 ) ) THEN + FLIMIT = 0.86 + ELSE IF ( ( SMCMAX == 0.476 ) .OR. ( SMCMAX == 0.439 ) ) THEN + FLIMIT = 0.74 + ELSE IF ( ( SMCMAX == 0.200 ) .OR. ( SMCMAX == 0.464 ) ) THEN + FLIMIT = 0.80 + ENDIF + +! ---------------------------------------------------------------------- + END SUBROUTINE FAC2MIT +! ---------------------------------------------------------------------- + + SUBROUTINE FRH2O (FREE,TKELV,SMC,SH2O,SMCMAX,BEXP,PSIS) + +! ---------------------------------------------------------------------- +! SUBROUTINE FRH2O +! ---------------------------------------------------------------------- +! CALCULATE AMOUNT OF SUPERCOOLED LIQUID SOIL WATER CONTENT IF +! TEMPERATURE IS BELOW 273.15K (T0). REQUIRES NEWTON-TYPE ITERATION TO +! SOLVE THE NONLINEAR IMPLICIT EQUATION GIVEN IN EQN 17 OF KOREN ET AL +! (1999, JGR, VOL 104(D16), 19569-19585). +! ---------------------------------------------------------------------- +! NEW VERSION (JUNE 2001): MUCH FASTER AND MORE ACCURATE NEWTON +! ITERATION ACHIEVED BY FIRST TAKING LOG OF EQN CITED ABOVE -- LESS THAN +! 4 (TYPICALLY 1 OR 2) ITERATIONS ACHIEVES CONVERGENCE. ALSO, EXPLICIT +! 1-STEP SOLUTION OPTION FOR SPECIAL CASE OF PARAMETER CK=0, WHICH +! REDUCES THE ORIGINAL IMPLICIT EQUATION TO A SIMPLER EXPLICIT FORM, +! KNOWN AS THE "FLERCHINGER EQN". IMPROVED HANDLING OF SOLUTION IN THE +! LIMIT OF FREEZING POINT TEMPERATURE T0. +! ---------------------------------------------------------------------- +! INPUT: + +! TKELV.........TEMPERATURE (Kelvin) +! SMC...........TOTAL SOIL MOISTURE CONTENT (VOLUMETRIC) +! SH2O..........LIQUID SOIL MOISTURE CONTENT (VOLUMETRIC) +! SMCMAX........SATURATION SOIL MOISTURE CONTENT (FROM REDPRM) +! B.............SOIL TYPE "B" PARAMETER (FROM REDPRM) +! PSIS..........SATURATED SOIL MATRIC POTENTIAL (FROM REDPRM) + +! OUTPUT: +! FRH2O.........SUPERCOOLED LIQUID WATER CONTENT +! FREE..........SUPERCOOLED LIQUID WATER CONTENT +! ---------------------------------------------------------------------- + IMPLICIT NONE + REAL, INTENT(IN) :: BEXP,PSIS,SH2O,SMC,SMCMAX,TKELV + REAL, INTENT(OUT) :: FREE + REAL :: BX,DENOM,DF,DSWL,FK,SWL,SWLK + INTEGER :: NLOG,KCOUNT +! PARAMETER(CK = 0.0) + REAL, PARAMETER :: CK = 8.0, BLIM = 5.5, ERROR = 0.005, & + HLICE = 3.335E5, GS = 9.81,DICE = 920.0, & + DH2O = 1000.0, T0 = 273.15 + +! ---------------------------------------------------------------------- +! LIMITS ON PARAMETER B: B < 5.5 (use parameter BLIM) +! SIMULATIONS SHOWED IF B > 5.5 UNFROZEN WATER CONTENT IS +! NON-REALISTICALLY HIGH AT VERY LOW TEMPERATURES. +! ---------------------------------------------------------------------- + BX = BEXP + +! ---------------------------------------------------------------------- +! INITIALIZING ITERATIONS COUNTER AND ITERATIVE SOLUTION FLAG. +! ---------------------------------------------------------------------- + IF (BEXP > BLIM) BX = BLIM + NLOG = 0 + +! ---------------------------------------------------------------------- +! IF TEMPERATURE NOT SIGNIFICANTLY BELOW FREEZING (T0), SH2O = SMC +! ---------------------------------------------------------------------- + KCOUNT = 0 +! FRH2O = SMC + IF (TKELV > (T0- 1.E-3)) THEN + FREE = SMC + ELSE + +! ---------------------------------------------------------------------- +! OPTION 1: ITERATED SOLUTION FOR NONZERO CK +! IN KOREN ET AL, JGR, 1999, EQN 17 +! ---------------------------------------------------------------------- +! INITIAL GUESS FOR SWL (frozen content) +! ---------------------------------------------------------------------- + IF (CK /= 0.0) THEN + SWL = SMC - SH2O +! ---------------------------------------------------------------------- +! KEEP WITHIN BOUNDS. +! ---------------------------------------------------------------------- + IF (SWL > (SMC -0.02)) SWL = SMC -0.02 + +! ---------------------------------------------------------------------- +! START OF ITERATIONS +! ---------------------------------------------------------------------- + IF (SWL < 0.) SWL = 0. + 1001 Continue + IF (.NOT.( (NLOG < 10) .AND. (KCOUNT == 0))) goto 1002 + NLOG = NLOG +1 + DF = ALOG ( ( PSIS * GS / HLICE ) * ( ( 1. + CK * SWL )**2.) * & + ( SMCMAX / (SMC - SWL) )** BX) - ALOG ( - ( & + TKELV - T0)/ TKELV) + DENOM = 2. * CK / ( 1. + CK * SWL ) + BX / ( SMC - SWL ) + SWLK = SWL - DF / DENOM +! ---------------------------------------------------------------------- +! BOUNDS USEFUL FOR MATHEMATICAL SOLUTION. +! ---------------------------------------------------------------------- + IF (SWLK > (SMC -0.02)) SWLK = SMC - 0.02 + IF (SWLK < 0.) SWLK = 0. + +! ---------------------------------------------------------------------- +! MATHEMATICAL SOLUTION BOUNDS APPLIED. +! ---------------------------------------------------------------------- + DSWL = ABS (SWLK - SWL) + +! ---------------------------------------------------------------------- +! IF MORE THAN 10 ITERATIONS, USE EXPLICIT METHOD (CK=0 APPROX.) +! WHEN DSWL LESS OR EQ. ERROR, NO MORE ITERATIONS REQUIRED. +! ---------------------------------------------------------------------- + SWL = SWLK + IF ( DSWL <= ERROR ) THEN + KCOUNT = KCOUNT +1 + END IF +! ---------------------------------------------------------------------- +! END OF ITERATIONS +! ---------------------------------------------------------------------- +! BOUNDS APPLIED WITHIN DO-BLOCK ARE VALID FOR PHYSICAL SOLUTION. +! ---------------------------------------------------------------------- +! FRH2O = SMC - SWL + goto 1001 + 1002 continue + FREE = SMC - SWL + END IF +! ---------------------------------------------------------------------- +! END OPTION 1 +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! OPTION 2: EXPLICIT SOLUTION FOR FLERCHINGER EQ. i.e. CK=0 +! IN KOREN ET AL., JGR, 1999, EQN 17 +! APPLY PHYSICAL BOUNDS TO FLERCHINGER SOLUTION +! ---------------------------------------------------------------------- + IF (KCOUNT == 0) THEN +! PRINT *,'Flerchinger USEd in NEW version. Iterations=',NLOG + FK = ( ( (HLICE / (GS * ( - PSIS)))* & + ( (TKELV - T0)/ TKELV))** ( -1/ BX))* SMCMAX +! FRH2O = MIN (FK, SMC) + IF (FK < 0.02) FK = 0.02 + FREE = MIN (FK, SMC) +! ---------------------------------------------------------------------- +! END OPTION 2 +! ---------------------------------------------------------------------- + END IF + END IF +! ---------------------------------------------------------------------- + END SUBROUTINE FRH2O +! ---------------------------------------------------------------------- + + SUBROUTINE HRT (RHSTS,STC,SMC,SMCMAX,NSOIL,ZSOIL,YY,ZZ1, & + TBOT,ZBOT,PSISAT,SH2O,DT,BEXP,SOILTYP,OPT_THCND, & + F1,DF1,QUARTZ,CSOIL,AI,BI,CI,VEGTYP,ISURBAN & + ,HCPCT_FASDAS ) !fasdas + +! ---------------------------------------------------------------------- +! SUBROUTINE HRT +! ---------------------------------------------------------------------- +! CALCULATE THE RIGHT HAND SIDE OF THE TIME TENDENCY TERM OF THE SOIL +! THERMAL DIFFUSION EQUATION. ALSO TO COMPUTE ( PREPARE ) THE MATRIX +! COEFFICIENTS FOR THE TRI-DIAGONAL MATRIX OF THE IMPLICIT TIME SCHEME. +! ---------------------------------------------------------------------- + IMPLICIT NONE + LOGICAL :: ITAVG + INTEGER, INTENT(IN) :: OPT_THCND + INTEGER, INTENT(IN) :: NSOIL, VEGTYP, SOILTYP + INTEGER, INTENT(IN) :: ISURBAN + INTEGER :: I, K + + REAL, INTENT(IN) :: BEXP, CSOIL, DF1, DT,F1,PSISAT,QUARTZ, & + SMCMAX ,TBOT,YY,ZZ1, ZBOT + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC,STC,ZSOIL + REAL, DIMENSION(1:NSOIL), INTENT(INOUT):: SH2O + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: RHSTS + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: AI, BI,CI + REAL :: DDZ, DDZ2, DENOM, DF1N, DF1K, DTSDZ, & + DTSDZ2,HCPCT,QTOT,SSOIL,SICE,TAVG,TBK, & + TBK1,TSNSR,TSURF,CSOIL_LOC + REAL, PARAMETER :: T0 = 273.15, CAIR = 1004.0, CICE = 2.106E6,& + CH2O = 4.2E6 + +! +! FASDAS +! + REAL, INTENT( OUT) :: HCPCT_FASDAS +! +! END FASDAS +! + +!urban + IF( VEGTYP == ISURBAN ) then + CSOIL_LOC=3.0E6 + ELSE + CSOIL_LOC=CSOIL + ENDIF + +! ---------------------------------------------------------------------- +! INITIALIZE LOGICAL FOR SOIL LAYER TEMPERATURE AVERAGING. +! ---------------------------------------------------------------------- + ITAVG = .TRUE. +! ---------------------------------------------------------------------- +! BEGIN SECTION FOR TOP SOIL LAYER +! ---------------------------------------------------------------------- +! CALC THE HEAT CAPACITY OF THE TOP SOIL LAYER +! ---------------------------------------------------------------------- + HCPCT = SH2O (1)* CH2O + (1.0- SMCMAX)* CSOIL_LOC + (SMCMAX - SMC (1))& + * CAIR & + + ( SMC (1) - SH2O (1) )* CICE +! +! FASDAS +! + HCPCT_FASDAS = HCPCT +! +! END FASDAS +! +! ---------------------------------------------------------------------- +! CALC THE MATRIX COEFFICIENTS AI, BI, AND CI FOR THE TOP LAYER +! ---------------------------------------------------------------------- + DDZ = 1.0 / ( -0.5 * ZSOIL (2) ) + AI (1) = 0.0 + CI (1) = (DF1 * DDZ) / (ZSOIL (1) * HCPCT) + +! ---------------------------------------------------------------------- +! CALCULATE THE VERTICAL SOIL TEMP GRADIENT BTWN THE 1ST AND 2ND SOIL +! LAYERS. THEN CALCULATE THE SUBSURFACE HEAT FLUX. USE THE TEMP +! GRADIENT AND SUBSFC HEAT FLUX TO CALC "RIGHT-HAND SIDE TENDENCY +! TERMS", OR "RHSTS", FOR TOP SOIL LAYER. +! ---------------------------------------------------------------------- + BI (1) = - CI (1) + DF1 / (0.5 * ZSOIL (1) * ZSOIL (1)* HCPCT * & + ZZ1) + DTSDZ = (STC (1) - STC (2)) / ( -0.5 * ZSOIL (2)) + SSOIL = DF1 * (STC (1) - YY) / (0.5 * ZSOIL (1) * ZZ1) +! RHSTS(1) = (DF1 * DTSDZ - SSOIL) / (ZSOIL(1) * HCPCT) + DENOM = (ZSOIL (1) * HCPCT) + +! ---------------------------------------------------------------------- +! NEXT CAPTURE THE VERTICAL DIFFERENCE OF THE HEAT FLUX AT TOP AND +! BOTTOM OF FIRST SOIL LAYER FOR USE IN HEAT FLUX CONSTRAINT APPLIED TO +! POTENTIAL SOIL FREEZING/THAWING IN ROUTINE SNKSRC. +! ---------------------------------------------------------------------- +! QTOT = SSOIL - DF1*DTSDZ + RHSTS (1) = (DF1 * DTSDZ - SSOIL) / DENOM + +! ---------------------------------------------------------------------- +! CALCULATE FROZEN WATER CONTENT IN 1ST SOIL LAYER. +! ---------------------------------------------------------------------- + QTOT = -1.0* RHSTS (1)* DENOM + +! ---------------------------------------------------------------------- +! IF TEMPERATURE AVERAGING INVOKED (ITAVG=TRUE; ELSE SKIP): +! SET TEMP "TSURF" AT TOP OF SOIL COLUMN (FOR USE IN FREEZING SOIL +! PHYSICS LATER IN FUNCTION SUBROUTINE SNKSRC). IF SNOWPACK CONTENT IS +! ZERO, THEN TSURF EXPRESSION BELOW GIVES TSURF = SKIN TEMP. IF +! SNOWPACK IS NONZERO (HENCE ARGUMENT ZZ1=1), THEN TSURF EXPRESSION +! BELOW YIELDS SOIL COLUMN TOP TEMPERATURE UNDER SNOWPACK. THEN +! CALCULATE TEMPERATURE AT BOTTOM INTERFACE OF 1ST SOIL LAYER FOR USE +! LATER IN FUNCTION SUBROUTINE SNKSRC +! ---------------------------------------------------------------------- + SICE = SMC (1) - SH2O (1) + IF (ITAVG) THEN + TSURF = (YY + (ZZ1-1) * STC (1)) / ZZ1 +! ---------------------------------------------------------------------- +! IF FROZEN WATER PRESENT OR ANY OF LAYER-1 MID-POINT OR BOUNDING +! INTERFACE TEMPERATURES BELOW FREEZING, THEN CALL SNKSRC TO +! COMPUTE HEAT SOURCE/SINK (AND CHANGE IN FROZEN WATER CONTENT) +! DUE TO POSSIBLE SOIL WATER PHASE CHANGE +! ---------------------------------------------------------------------- + CALL TBND (STC (1),STC (2),ZSOIL,ZBOT,1,NSOIL,TBK) + IF ( (SICE > 0.) .OR. (STC (1) < T0) .OR. & + (TSURF < T0) .OR. (TBK < T0) ) THEN +! TSNSR = SNKSRC (TAVG,SMC(1),SH2O(1), + CALL TMPAVG (TAVG,TSURF,STC (1),TBK,ZSOIL,NSOIL,1) + CALL SNKSRC (TSNSR,TAVG,SMC (1),SH2O (1), & + ZSOIL,NSOIL,SMCMAX,PSISAT,BEXP,DT,1,QTOT) +! RHSTS(1) = RHSTS(1) - TSNSR / ( ZSOIL(1) * HCPCT ) + RHSTS (1) = RHSTS (1) - TSNSR / DENOM + END IF + ELSE +! TSNSR = SNKSRC (STC(1),SMC(1),SH2O(1), + IF ( (SICE > 0.) .OR. (STC (1) < T0) ) THEN + CALL SNKSRC (TSNSR,STC (1),SMC (1),SH2O (1), & + ZSOIL,NSOIL,SMCMAX,PSISAT,BEXP,DT,1,QTOT) +! RHSTS(1) = RHSTS(1) - TSNSR / ( ZSOIL(1) * HCPCT ) + RHSTS (1) = RHSTS (1) - TSNSR / DENOM + END IF +! ---------------------------------------------------------------------- +! THIS ENDS SECTION FOR TOP SOIL LAYER. +! ---------------------------------------------------------------------- + END IF + +! INITIALIZE DDZ2 +! ---------------------------------------------------------------------- + + DDZ2 = 0.0 + DF1K = DF1 + +! ---------------------------------------------------------------------- +! LOOP THRU THE REMAINING SOIL LAYERS, REPEATING THE ABOVE PROCESS +! (EXCEPT SUBSFC OR "GROUND" HEAT FLUX NOT REPEATED IN LOWER LAYERS) +! ---------------------------------------------------------------------- +! CALCULATE HEAT CAPACITY FOR THIS SOIL LAYER. +! ---------------------------------------------------------------------- + DO K = 2,NSOIL + HCPCT = SH2O (K)* CH2O + (1.0- SMCMAX)* CSOIL_LOC + (SMCMAX - SMC ( & + K))* CAIR + ( SMC (K) - SH2O (K) )* CICE +! ---------------------------------------------------------------------- +! THIS SECTION FOR LAYER 2 OR GREATER, BUT NOT LAST LAYER. +! ---------------------------------------------------------------------- +! CALCULATE THERMAL DIFFUSIVITY FOR THIS LAYER. +! ---------------------------------------------------------------------- + IF (K /= NSOIL) THEN + +! ---------------------------------------------------------------------- +! CALC THE VERTICAL SOIL TEMP GRADIENT THRU THIS LAYER +! ---------------------------------------------------------------------- + CALL TDFCND (DF1N,SMC (K),QUARTZ,SMCMAX,SH2O (K),BEXP, PSISAT, SOILTYP, OPT_THCND) + +!urban + IF ( VEGTYP == ISURBAN ) DF1N = 3.24 + + DENOM = 0.5 * ( ZSOIL (K -1) - ZSOIL (K +1) ) + +! ---------------------------------------------------------------------- +! CALC THE MATRIX COEF, CI, AFTER CALC'NG ITS PARTIAL PRODUCT +! ---------------------------------------------------------------------- + DTSDZ2 = ( STC (K) - STC (K +1) ) / DENOM + DDZ2 = 2. / (ZSOIL (K -1) - ZSOIL (K +1)) + +! ---------------------------------------------------------------------- +! IF TEMPERATURE AVERAGING INVOKED (ITAVG=TRUE; ELSE SKIP): CALCULATE +! TEMP AT BOTTOM OF LAYER. +! ---------------------------------------------------------------------- + CI (K) = - DF1N * DDZ2 / ( (ZSOIL (K -1) - ZSOIL (K)) * & + HCPCT) + IF (ITAVG) THEN + CALL TBND (STC (K),STC (K +1),ZSOIL,ZBOT,K,NSOIL,TBK1) + END IF + + ELSE +! ---------------------------------------------------------------------- +! SPECIAL CASE OF BOTTOM SOIL LAYER: CALCULATE THERMAL DIFFUSIVITY FOR +! BOTTOM LAYER. +! ---------------------------------------------------------------------- + +! ---------------------------------------------------------------------- +! CALC THE VERTICAL SOIL TEMP GRADIENT THRU BOTTOM LAYER. +! ---------------------------------------------------------------------- + CALL TDFCND (DF1N,SMC (K),QUARTZ,SMCMAX,SH2O (K),BEXP, PSISAT, SOILTYP, OPT_THCND) + + +!urban + IF ( VEGTYP == ISURBAN ) DF1N = 3.24 + + DENOM = .5 * (ZSOIL (K -1) + ZSOIL (K)) - ZBOT + +! ---------------------------------------------------------------------- +! SET MATRIX COEF, CI TO ZERO IF BOTTOM LAYER. +! ---------------------------------------------------------------------- + DTSDZ2 = (STC (K) - TBOT) / DENOM + +! ---------------------------------------------------------------------- +! IF TEMPERATURE AVERAGING INVOKED (ITAVG=TRUE; ELSE SKIP): CALCULATE +! TEMP AT BOTTOM OF LAST LAYER. +! ---------------------------------------------------------------------- + CI (K) = 0. + IF (ITAVG) THEN + CALL TBND (STC (K),TBOT,ZSOIL,ZBOT,K,NSOIL,TBK1) + END IF +! ---------------------------------------------------------------------- +! THIS ENDS SPECIAL LOOP FOR BOTTOM LAYER. + END IF +! ---------------------------------------------------------------------- +! CALCULATE RHSTS FOR THIS LAYER AFTER CALC'NG A PARTIAL PRODUCT. +! ---------------------------------------------------------------------- + DENOM = ( ZSOIL (K) - ZSOIL (K -1) ) * HCPCT + RHSTS (K) = ( DF1N * DTSDZ2- DF1K * DTSDZ ) / DENOM + QTOT = -1.0* DENOM * RHSTS (K) + + SICE = SMC (K) - SH2O (K) + IF (ITAVG) THEN + CALL TMPAVG (TAVG,TBK,STC (K),TBK1,ZSOIL,NSOIL,K) +! TSNSR = SNKSRC(TAVG,SMC(K),SH2O(K),ZSOIL,NSOIL, + IF ( (SICE > 0.) .OR. (STC (K) < T0) .OR. & + (TBK .lt. T0) .OR. (TBK1 .lt. T0) ) THEN + CALL SNKSRC (TSNSR,TAVG,SMC (K),SH2O (K),ZSOIL,NSOIL, & + SMCMAX,PSISAT,BEXP,DT,K,QTOT) + RHSTS (K) = RHSTS (K) - TSNSR / DENOM + END IF + ELSE +! TSNSR = SNKSRC(STC(K),SMC(K),SH2O(K),ZSOIL,NSOIL, + IF ( (SICE > 0.) .OR. (STC (K) < T0) ) THEN + CALL SNKSRC (TSNSR,STC (K),SMC (K),SH2O (K),ZSOIL,NSOIL, & + SMCMAX,PSISAT,BEXP,DT,K,QTOT) + RHSTS (K) = RHSTS (K) - TSNSR / DENOM + END IF + END IF + +! ---------------------------------------------------------------------- +! CALC MATRIX COEFS, AI, AND BI FOR THIS LAYER. +! ---------------------------------------------------------------------- + AI (K) = - DF1K * DDZ / ( (ZSOIL (K -1) - ZSOIL (K)) * HCPCT) + +! ---------------------------------------------------------------------- +! RESET VALUES OF DF1, DTSDZ, DDZ, AND TBK FOR LOOP TO NEXT SOIL LAYER. +! ---------------------------------------------------------------------- + BI (K) = - (AI (K) + CI (K)) + TBK = TBK1 + DF1K = DF1N + DTSDZ = DTSDZ2 + DDZ = DDZ2 + END DO +! ---------------------------------------------------------------------- + END SUBROUTINE HRT +! ---------------------------------------------------------------------- + + SUBROUTINE HSTEP (STCOUT,STCIN,RHSTS,DT,NSOIL,AI,BI,CI) + +! ---------------------------------------------------------------------- +! SUBROUTINE HSTEP +! ---------------------------------------------------------------------- +! CALCULATE/UPDATE THE SOIL TEMPERATURE FIELD. +! ---------------------------------------------------------------------- + IMPLICIT NONE + INTEGER, INTENT(IN) :: NSOIL + INTEGER :: K + + REAL, DIMENSION(1:NSOIL), INTENT(IN):: STCIN + REAL, DIMENSION(1:NSOIL), INTENT(OUT):: STCOUT + REAL, DIMENSION(1:NSOIL), INTENT(INOUT):: RHSTS + REAL, DIMENSION(1:NSOIL), INTENT(INOUT):: AI,BI,CI + REAL, DIMENSION(1:NSOIL) :: RHSTSin + REAL, DIMENSION(1:NSOIL) :: CIin + REAL :: DT + +! ---------------------------------------------------------------------- +! CREATE FINITE DIFFERENCE VALUES FOR USE IN ROSR12 ROUTINE +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + RHSTS (K) = RHSTS (K) * DT + AI (K) = AI (K) * DT + BI (K) = 1. + BI (K) * DT + CI (K) = CI (K) * DT + END DO +! ---------------------------------------------------------------------- +! COPY VALUES FOR INPUT VARIABLES BEFORE CALL TO ROSR12 +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + RHSTSin (K) = RHSTS (K) + END DO + DO K = 1,NSOIL + CIin (K) = CI (K) + END DO +! ---------------------------------------------------------------------- +! SOLVE THE TRI-DIAGONAL MATRIX EQUATION +! ---------------------------------------------------------------------- + CALL ROSR12 (CI,AI,BI,CIin,RHSTSin,RHSTS,NSOIL) +! ---------------------------------------------------------------------- +! CALC/UPDATE THE SOIL TEMPS USING MATRIX SOLUTION +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + STCOUT (K) = STCIN (K) + CI (K) + END DO +! ---------------------------------------------------------------------- + END SUBROUTINE HSTEP +! ---------------------------------------------------------------------- + + SUBROUTINE NOPAC (ETP,ETA,PRCP,SMC,SMCMAX,SMCWLT, & + SMCREF,SMCDRY,CMC,CMCMAX,NSOIL,DT,SHDFAC, & + SBETA,Q2,T1,SFCTMP,T24,TH2,FDOWN,F1,EMISSI, & + SSOIL, & + STC,EPSCA,BEXP,PC,RCH,RR,CFACTR, & + SH2O,SLOPE,KDT,FRZFACT,PSISAT,ZSOIL, & + DKSAT,DWSAT,TBOT,ZBOT,RUNOFF1,RUNOFF2, & + RUNOFF3,EDIR,EC,ET,ETT,NROOT,RTDIS, & + QUARTZ,FXEXP,CSOIL, & + BETA,DRIP,DEW,FLX1,FLX3,VEGTYP,ISURBAN, & + SFHEAD1RT,INFXS1RT,ETPND1,SOILTYP,OPT_THCND & + ,XSDA_QFX,QFX_PHY,XQNORM,fasdas,HCPCT_FASDAS, & + SIGMA,CPH2O) !fasdas + +! ---------------------------------------------------------------------- +! SUBROUTINE NOPAC +! ---------------------------------------------------------------------- +! CALCULATE SOIL MOISTURE AND HEAT FLUX VALUES AND UPDATE SOIL MOISTURE +! CONTENT AND SOIL HEAT CONTENT VALUES FOR THE CASE WHEN NO SNOW PACK IS +! PRESENT. +! ---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER, INTENT(IN) :: OPT_THCND + INTEGER, INTENT(IN) :: NROOT,NSOIL,VEGTYP,SOILTYP + INTEGER, INTENT(IN) :: ISURBAN + INTEGER :: K + + REAL, INTENT(IN) :: BEXP,CFACTR, CMCMAX,CSOIL,DKSAT,DT,DWSAT, & + EPSCA,ETP,FDOWN,F1,FXEXP,FRZFACT,KDT,PC, & + PRCP,PSISAT,Q2,QUARTZ,RCH,RR,SBETA,SFCTMP,& + SHDFAC,SLOPE,SMCDRY,SMCMAX,SMCREF,SMCWLT, & + T24,TBOT,TH2,ZBOT,EMISSI,SIGMA,CPH2O + REAL, INTENT(INOUT) :: CMC,BETA,T1 + REAL, INTENT(OUT) :: DEW,DRIP,EC,EDIR,ETA,ETT,FLX1,FLX3, & + RUNOFF1,RUNOFF2,RUNOFF3,SSOIL +!DJG NDHMS/WRF-Hydro edit... + REAL, INTENT(INOUT) :: SFHEAD1RT,INFXS1RT,ETPND1 + + REAL, DIMENSION(1:NSOIL),INTENT(IN) :: RTDIS,ZSOIL + REAL, DIMENSION(1:NSOIL),INTENT(OUT) :: ET + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: SMC,SH2O,STC + REAL, DIMENSION(1:NSOIL) :: ET1 + REAL :: EC1,EDIR1,ETT1,DF1,ETA1,ETP1,PRCP1,YY, & + YYNUM,ZZ1 +! +! FASDAS +! + REAL :: XSDA_QFX, QFX_PHY, XQNORM + INTEGER :: fasdas + REAL , DIMENSION(1:NSOIL) :: EFT(NSOIL), wetty(1:NSOIL) + REAL :: EFDIR, EFC, EALL_now + REAL, INTENT( OUT) :: HCPCT_FASDAS +! +! END FASDAS +! +! ---------------------------------------------------------------------- +! EXECUTABLE CODE BEGINS HERE: +! CONVERT ETP Fnd PRCP FROM KG M-2 S-1 TO M S-1 AND INITIALIZE DEW. +! ---------------------------------------------------------------------- + PRCP1 = PRCP * 0.001 + ETP1 = ETP * 0.001 + DEW = 0.0 +! ---------------------------------------------------------------------- +! INITIALIZE EVAP TERMS. +! ---------------------------------------------------------------------- +! +! FASDAS +! + QFX_PHY = 0.0 +! +! END FASDAS +! + EDIR = 0. + EDIR1 = 0. + EC1 = 0. + EC = 0. + DO K = 1,NSOIL + ET(K) = 0. + ET1(K) = 0. +! +! FASDAS +! + wetty(K) = 1.0 +! +! END FASDAS +! + END DO + ETT = 0. + ETT1 = 0. + +!DJG NDHMS/WRF-Hydro edit... + ETPND1 = 0. + + + IF (ETP > 0.0) THEN + CALL EVAPO (ETA1,SMC,NSOIL,CMC,ETP1,DT,ZSOIL, & + SH2O, & + SMCMAX,BEXP,PC,SMCWLT,DKSAT,DWSAT, & + SMCREF,SHDFAC,CMCMAX, & + SMCDRY,CFACTR, & + EDIR1,EC1,ET1,ETT1,SFCTMP,Q2,NROOT,RTDIS,FXEXP, & + SFHEAD1RT,ETPND1 ) +! +! FASDAS +! + IF( fasdas == 1 ) THEN + DO K=1,NSOIL + QFX_PHY = QFX_PHY + ET1(K) ! m/s +! dont add moisture fluxes if soil moisture is = or > smcref + IF(SMC(K).GE.SMCREF.and.XSDA_QFX.gt.0.0) wetty(K)=0.0 + END DO + QFX_PHY = EDIR1+EC1+QFX_PHY ! m/s + EALL_now = QFX_PHY ! m/s + QFX_PHY = QFX_PHY*1000.0 ! Kg/m2/s + + if(EALL_now.ne.0.0) then + EFDIR = (EDIR1/EALL_now)*XSDA_QFX*1.0E-03*XQNORM + EFDIR = EFDIR * wetty(1) + !TWG2015 Bugfix Flip Sign to conform to Net upward Flux + EDIR1 = EDIR1 + EFDIR ! new value + + EFC = (EC1/EALL_now)*XSDA_QFX*1.0E-03*XQNORM + !TWG2015 Bugfix Flip Sign to conform to Net upward Flux + EC1 = EC1 + EFC ! new value + + + DO K=1,NSOIL + EFT(K) = (ET1(K)/EALL_now)*XSDA_QFX*1.0E-03*XQNORM + EFT(K) = EFT(K) * wetty(K) + !TWG2015 Bugfix Flip Sign to conform to Net upward Flux + ET1(K) = ET1(K) + EFT(K) ! new value + END DO + + + END IF ! for non-zero eall_now + ELSE + QFX_PHY = 0.0 + ENDIF +! +! END FASDAS +! + CALL SMFLX (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, & + SH2O,SLOPE,KDT,FRZFACT, & + SMCMAX,BEXP,SMCWLT,DKSAT,DWSAT, & + SHDFAC,CMCMAX, & + RUNOFF1,RUNOFF2,RUNOFF3, & + EDIR1,EC1,ET1, & + DRIP, SFHEAD1RT,INFXS1RT) + +! ---------------------------------------------------------------------- +! CONVERT MODELED EVAPOTRANSPIRATION FROM M S-1 TO KG M-2 S-1. +! ---------------------------------------------------------------------- + + ETA = ETA1 * 1000.0 + +! ---------------------------------------------------------------------- +! IF ETP < 0, ASSUME DEW FORMS (TRANSFORM ETP1 INTO DEW AND REINITIALIZE +! ETP1 TO ZERO). +! ---------------------------------------------------------------------- + ELSE + DEW = - ETP1 + +! ---------------------------------------------------------------------- +! CONVERT PRCP FROM 'KG M-2 S-1' TO 'M S-1' AND ADD DEW AMOUNT. +! ---------------------------------------------------------------------- + + PRCP1 = PRCP1+ DEW +! +! FASDAS +! + IF( fasdas == 1 ) THEN + DO K=1,NSOIL + QFX_PHY = QFX_PHY + ET1(K) ! m/s +! dont add moisture fluxes if soil moisture is = or > smcref + IF(SMC(K).GE.SMCREF.and.XSDA_QFX.gt.0.0) wetty(K)=0.0 + END DO + QFX_PHY = EDIR1+EC1+QFX_PHY ! m/s + EALL_now = QFX_PHY ! m/s + QFX_PHY = QFX_PHY*1000.0 ! Kg/m2/s + + IF(EALL_now.ne.0.0) then + EFDIR = (EDIR1/EALL_now)*XSDA_QFX*1.0E-03*XQNORM + EFDIR = EFDIR * wetty(1) + !TWG2015 Bugfix Flip Sign to conform to Net Upward Flux + EDIR1 = EDIR1 + EFDIR ! new value + + EFC = (EC1/EALL_now)*XSDA_QFX*1.0E-03*XQNORM + !TWG2015 Bugfix Flip Sign to conform to Net Upward Flux + EC1 = EC1+ EFC ! new value + + DO K=1,NSOIL + EFT(K) = (ET1(K)/EALL_now)*XSDA_QFX*1.0E-03*XQNORM + EFT(K) = EFT(K) * wetty(K) + !TWG2015 Bugfix Flip Sign to conform to Net Upward Flux + ET1(K) = ET1(K) + EFT(K) ! new value + END DO + + END IF ! for non-zero eall_now + ELSE + QFX_PHY = 0.0 + ENDIF +! +! END FASDAS +! + CALL SMFLX (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, & + SH2O,SLOPE,KDT,FRZFACT, & + SMCMAX,BEXP,SMCWLT,DKSAT,DWSAT, & + SHDFAC,CMCMAX, & + RUNOFF1,RUNOFF2,RUNOFF3, & + EDIR1,EC1,ET1, & + DRIP, SFHEAD1RT,INFXS1RT) + +! ---------------------------------------------------------------------- +! CONVERT MODELED EVAPOTRANSPIRATION FROM 'M S-1' TO 'KG M-2 S-1'. +! ---------------------------------------------------------------------- +! ETA = ETA1 * 1000.0 + END IF + +! ---------------------------------------------------------------------- +! BASED ON ETP AND E VALUES, DETERMINE BETA +! ---------------------------------------------------------------------- + + IF ( ETP <= 0.0 ) THEN + BETA = 0.0 + ETA = ETP + IF ( ETP < 0.0 ) THEN + BETA = 1.0 + END IF + ELSE + BETA = ETA / ETP + END IF + +! ---------------------------------------------------------------------- +! CONVERT MODELED EVAPOTRANSPIRATION COMPONENTS 'M S-1' TO 'KG M-2 S-1'. +! ---------------------------------------------------------------------- + EDIR = EDIR1*1000. + EC = EC1*1000. + DO K = 1,NSOIL + ET(K) = ET1(K)*1000. + END DO + ETT = ETT1*1000. + +! ---------------------------------------------------------------------- +! GET SOIL THERMAL DIFFUXIVITY/CONDUCTIVITY FOR TOP SOIL LYR, +! CALC. ADJUSTED TOP LYR SOIL TEMP AND ADJUSTED SOIL FLUX, THEN +! CALL SHFLX TO COMPUTE/UPDATE SOIL HEAT FLUX AND SOIL TEMPS. +! ---------------------------------------------------------------------- + + CALL TDFCND (DF1,SMC (1),QUARTZ,SMCMAX,SH2O (1),BEXP, PSISAT, SOILTYP, OPT_THCND) + +!urban + IF ( VEGTYP == ISURBAN ) DF1=3.24 +! + +! ---------------------------------------------------------------------- +! VEGETATION GREENNESS FRACTION REDUCTION IN SUBSURFACE HEAT FLUX +! VIA REDUCTION FACTOR, WHICH IS CONVENIENT TO APPLY HERE TO THERMAL +! DIFFUSIVITY THAT IS LATER USED IN HRT TO COMPUTE SUB SFC HEAT FLUX +! (SEE ADDITIONAL COMMENTS ON VEG EFFECT SUB-SFC HEAT FLX IN +! ROUTINE SFLX) +! ---------------------------------------------------------------------- + DF1 = DF1 * EXP (SBETA * SHDFAC) +! ---------------------------------------------------------------------- +! COMPUTE INTERMEDIATE TERMS PASSED TO ROUTINE HRT (VIA ROUTINE +! SHFLX BELOW) FOR USE IN COMPUTING SUBSURFACE HEAT FLUX IN HRT +! ---------------------------------------------------------------------- + YYNUM = FDOWN - EMISSI*SIGMA * T24 + YY = SFCTMP + (YYNUM / RCH + TH2- SFCTMP - BETA * EPSCA) / RR + + ZZ1 = DF1 / ( -0.5 * ZSOIL (1) * RCH * RR ) + 1.0 +!urban + CALL SHFLX (SSOIL,STC,SMC,SMCMAX,NSOIL,T1,DT,YY,ZZ1,ZSOIL, & + TBOT,ZBOT,SMCWLT,PSISAT,SH2O,BEXP,F1,DF1, & + QUARTZ,CSOIL,VEGTYP,ISURBAN,SOILTYP,OPT_THCND & + ,HCPCT_FASDAS ) !fasdas + +! ---------------------------------------------------------------------- +! SET FLX1 AND FLX3 (SNOPACK PHASE CHANGE HEAT FLUXES) TO ZERO SINCE +! THEY ARE NOT USED HERE IN SNOPAC. FLX2 (FREEZING RAIN HEAT FLUX) WAS +! SIMILARLY INITIALIZED IN THE PENMAN ROUTINE. +! ---------------------------------------------------------------------- + FLX1 = CPH2O * PRCP * (T1- SFCTMP) + FLX3 = 0.0 + +! ---------------------------------------------------------------------- + END SUBROUTINE NOPAC +! ---------------------------------------------------------------------- + + SUBROUTINE PENMAN (SFCTMP,SFCPRS,CH,T2V,TH2,PRCP,FDOWN,T24,SSOIL, & + & Q2,Q2SAT,ETP,RCH,EPSCA,RR,SNOWNG,FRZGRA, & + & DQSDT2,FLX2,EMISSI_IN,SNEQV,T1,SNCOVR,AOASIS, & + & ALBEDO,SOLDN,FVB,GAMA,STC1,ETPN,FLX4,UA_PHYS, & + & CP,RD,SIGMA,CPH2O,CPICE,LSUBF) + +! ---------------------------------------------------------------------- +! SUBROUTINE PENMAN +! ---------------------------------------------------------------------- +! CALCULATE POTENTIAL EVAPORATION FOR THE CURRENT POINT. VARIOUS +! PARTIAL SUMS/PRODUCTS ARE ALSO CALCULATED AND PASSED BACK TO THE +! CALLING ROUTINE FOR LATER USE. +! ---------------------------------------------------------------------- + IMPLICIT NONE + LOGICAL, INTENT(IN) :: SNOWNG, FRZGRA + REAL, INTENT(IN) :: CH, DQSDT2,FDOWN,PRCP, & + Q2, Q2SAT,SSOIL, SFCPRS, SFCTMP, & + T2V, TH2,EMISSI_IN,SNEQV,AOASIS, & + CP, RD, SIGMA, CPH2O, CPICE, LSUBF + REAL, INTENT(IN) :: T1 , SNCOVR + REAL, INTENT(IN) :: ALBEDO,SOLDN,FVB,GAMA,STC1 + LOGICAL, INTENT(IN) :: UA_PHYS +! + REAL, INTENT(OUT) :: EPSCA,ETP,FLX2,RCH,RR,T24 + REAL, INTENT(OUT) :: FLX4,ETPN + REAL :: A, DELTA, FNET,RAD,RHO,EMISSI,ELCP1,LVS + REAL :: TOTABS,UCABS,SIGNCK,FNETN,RADN,EPSCAN + + REAL, PARAMETER :: ELCP = 2.4888E+3, LSUBC = 2.501000E+6 + REAL, PARAMETER :: LSUBS = 2.83E+6 + REAL, PARAMETER :: ALGDSN = 0.5, ALVGSN = 0.13 + +! ---------------------------------------------------------------------- +! EXECUTABLE CODE BEGINS HERE: +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! PREPARE PARTIAL QUANTITIES FOR PENMAN EQUATION. +! ---------------------------------------------------------------------- + EMISSI=EMISSI_IN + ELCP1 = (1.0-SNCOVR)*ELCP + SNCOVR*ELCP*LSUBS/LSUBC + LVS = (1.0-SNCOVR)*LSUBC + SNCOVR*LSUBS + + FLX2 = 0.0 +! DELTA = ELCP * DQSDT2 + DELTA = ELCP1 * DQSDT2 + T24 = SFCTMP * SFCTMP * SFCTMP * SFCTMP +! RR = T24 * 6.48E-8 / (SFCPRS * CH) + 1.0 + RR = EMISSI*T24 * 6.48E-8 / (SFCPRS * CH) + 1.0 + RHO = SFCPRS / (RD * T2V) + +! ---------------------------------------------------------------------- +! ADJUST THE PARTIAL SUMS / PRODUCTS WITH THE LATENT HEAT +! EFFECTS CAUSED BY FALLING PRECIPITATION. +! ---------------------------------------------------------------------- + RCH = RHO * CP * CH + IF (.NOT. SNOWNG) THEN + IF (PRCP > 0.0) RR = RR + CPH2O * PRCP / RCH + ELSE + RR = RR + CPICE * PRCP / RCH + END IF + +! ---------------------------------------------------------------------- +! INCLUDE THE LATENT HEAT EFFECTS OF FRZNG RAIN CONVERTING TO ICE ON +! IMPACT IN THE CALCULATION OF FLX2 AND FNET. +! ---------------------------------------------------------------------- +! FNET = FDOWN - SIGMA * T24- SSOIL + FNET = FDOWN - EMISSI*SIGMA * T24- SSOIL + + FLX4 = 0.0 + IF(UA_PHYS) THEN + IF(SNEQV > 0. .AND. FNET > 0. .AND. SOLDN > 0. ) THEN + TOTABS = (1.-ALBEDO)*SOLDN*FVB ! solar radiation absorbed + ! by vegetated fraction + UCABS = MIN(TOTABS,((1.0-ALGDSN)*(1.0-ALVGSN)*SOLDN*GAMA)*FVB) +! print*,'penman',UCABS,TOTABS,SOLDN,GAMA,FVB +! UCABS = MIN(TOTABS,(0.44*SOLDN*GAMA)*FVB) + ! UCABS -> solar radiation + ! absorbed under canopy + FLX4 = MIN(TOTABS - UCABS, MIN(250., 0.5*(1.-ALBEDO)*SOLDN)) + ENDIF + + SIGNCK = (STC1-273.15)*(SFCTMP-273.15) + + IF(FLX4 > 0. .AND. (SIGNCK <= 0. .OR. STC1 < 273.15)) THEN + IF(FNET >= FLX4) THEN + FNETN = FNET - FLX4 + ELSE + FLX4 = FNET + FNETN = 0. + ENDIF + ELSE + FLX4 = 0.0 + FNETN = 0. + ENDIF + ENDIF + + IF (FRZGRA) THEN + FLX2 = - LSUBF * PRCP + FNET = FNET - FLX2 + IF(UA_PHYS) FNETN = FNETN - FLX2 +! ---------------------------------------------------------------------- +! FINISH PENMAN EQUATION CALCULATIONS. +! ---------------------------------------------------------------------- + END IF + RAD = FNET / RCH + TH2- SFCTMP +! A = ELCP * (Q2SAT - Q2) + A = ELCP1 * (Q2SAT - Q2) + EPSCA = (A * RR + RAD * DELTA) / (DELTA + RR) +! Fei-Mike + IF (EPSCA>0.) EPSCA = EPSCA * AOASIS +! ETP = EPSCA * RCH / LSUBC + ETP = EPSCA * RCH / LVS + + IF(UA_PHYS) THEN + RADN = FNETN / RCH + TH2- SFCTMP + EPSCAN = (A * RR + RADN * DELTA) / (DELTA + RR) + ETPN = EPSCAN * RCH / LVS + END IF +! ---------------------------------------------------------------------- + END SUBROUTINE PENMAN +! ---------------------------------------------------------------------- + + SUBROUTINE REDPRM (VEGTYP,SOILTYP,SLOPETYP,CFACTR,CMCMAX,RSMAX, & + TOPT, & + REFKDT,KDT,SBETA, SHDFAC,RSMIN,RGL,HS,ZBOT,FRZX, & + PSISAT,SLOPE,SNUP,SALP,BEXP,DKSAT,DWSAT, & + SMCMAX,SMCWLT,SMCREF,SMCDRY,F1,QUARTZ,FXEXP, & + RTDIS,SLDPTH,ZSOIL, NROOT,NSOIL,CZIL, & + LAIMIN, LAIMAX, EMISSMIN, EMISSMAX, ALBEDOMIN, & + ALBEDOMAX, Z0MIN, Z0MAX, CSOIL, PTU, LLANDUSE, & + LSOIL, LOCAL,LVCOEF,ZTOPV,ZBOTV,errmsg,errflg) + + IMPLICIT NONE +! ---------------------------------------------------------------------- +! Internally set (default valuess) +! all soil and vegetation parameters required for the execusion oF +! the Noah lsm are defined in VEGPARM.TBL, SOILPARM.TB, and GENPARM.TBL. +! ---------------------------------------------------------------------- +! Vegetation parameters: +! ALBBRD: SFC background snow-free albedo +! CMXTBL: MAX CNPY Capacity +! Z0BRD: Background roughness length +! SHDFAC: Green vegetation fraction +! NROOT: Rooting depth +! RSMIN: Mimimum stomatal resistance +! RSMAX: Max. stomatal resistance +! RGL: Parameters used in radiation stress function +! HS: Parameter used in vapor pressure deficit functio +! TOPT: Optimum transpiration air temperature. +! CMCMAX: Maximum canopy water capacity +! CFACTR: Parameter used in the canopy inteception calculation +! SNUP: Threshold snow depth (in water equivalent m) that +! implies 100 percent snow cover +! LAI: Leaf area index +! +! ---------------------------------------------------------------------- +! Soil parameters: +! SMCMAX: MAX soil moisture content (porosity) +! SMCREF: Reference soil moisture (field capacity) +! SMCWLT: Wilting point soil moisture +! SMCWLT: Air dry soil moist content limits +! SSATPSI: SAT (saturation) soil potential +! DKSAT: SAT soil conductivity +! BEXP: B parameter +! SSATDW: SAT soil diffusivity +! F1: Soil thermal diffusivity/conductivity coef. +! QUARTZ: Soil quartz content +! Modified by F. Chen (12/22/97) to use the STATSGO soil map +! Modified By F. Chen (01/22/00) to include PLaya, Lava, and White San +! Modified By F. Chen (08/05/02) to include additional parameters for the Noah +! NOTE: SATDW = BB*SATDK*(SATPSI/MAXSMC) +! F11 = ALOG10(SATPSI) + BB*ALOG10(MAXSMC) + 2.0 +! REFSMC1=MAXSMC*(5.79E-9/SATDK)**(1/(2*BB+3)) 5.79E-9 m/s= 0.5 mm +! REFSMC=REFSMC1+1./3.(MAXSMC-REFSMC1) +! WLTSMC1=MAXSMC*(200./SATPSI)**(-1./BB) (Wetzel and Chang, 198 +! WLTSMC=WLTSMC1-0.5*WLTSMC1 +! Note: the values for playa is set for it to have a thermal conductivit +! as sand and to have a hydrulic conductivity as clay +! +! ---------------------------------------------------------------------- +! Class parameter 'SLOPETYP' was included to estimate linear reservoir +! coefficient 'SLOPE' to the baseflow runoff out of the bottom layer. +! lowest class (slopetyp=0) means highest slope parameter = 1. +! definition of slopetyp from 'zobler' slope type: +! slope class percent slope +! 1 0-8 +! 2 8-30 +! 3 > 30 +! 4 0-30 +! 5 0-8 & > 30 +! 6 8-30 & > 30 +! 7 0-8, 8-30, > 30 +! 9 GLACIAL ICE +! BLANK OCEAN/SEA +! SLOPE_DATA: linear reservoir coefficient +! SBETA_DATA: parameter used to caluculate vegetation effect on soil heat +! FXEXP_DAT: soil evaporation exponent used in DEVAP +! CSOIL_DATA: soil heat capacity [J M-3 K-1] +! SALP_DATA: shape parameter of distribution function of snow cover +! REFDK_DATA and REFKDT_DATA: parameters in the surface runoff parameteriz +! FRZK_DATA: frozen ground parameter +! ZBOT_DATA: depth[M] of lower boundary soil temperature +! CZIL_DATA: calculate roughness length of heat +! SMLOW_DATA and MHIGH_DATA: two soil moisture wilt, soil moisture referen +! parameters +! Set maximum number of soil-, veg-, and slopetyp in data statement. +! ---------------------------------------------------------------------- + INTEGER, PARAMETER :: MAX_SLOPETYP=30,MAX_SOILTYP=30,MAX_VEGTYP=30 + LOGICAL :: LOCAL + CHARACTER (LEN=256), INTENT(IN):: LLANDUSE, LSOIL + +! Veg parameters + INTEGER, INTENT(IN) :: VEGTYP + INTEGER, INTENT(OUT) :: NROOT + REAL, INTENT(INOUT) :: SHDFAC + REAL, INTENT(OUT) :: HS,RSMIN,RGL,SNUP, & + CMCMAX,RSMAX,TOPT, & + EMISSMIN, EMISSMAX, & + LAIMIN, LAIMAX, & + Z0MIN, Z0MAX, & + ALBEDOMIN, ALBEDOMAX, ZTOPV, ZBOTV +! Soil parameters + INTEGER, INTENT(IN) :: SOILTYP + REAL, INTENT(OUT) :: BEXP,DKSAT,DWSAT,F1,QUARTZ,SMCDRY, & + SMCMAX,SMCREF,SMCWLT,PSISAT +! General parameters + INTEGER, INTENT(IN) :: SLOPETYP,NSOIL + INTEGER :: I + + REAL, INTENT(OUT) :: SLOPE,CZIL,SBETA,FXEXP, & + CSOIL,SALP,FRZX,KDT,CFACTR, & + ZBOT,REFKDT,PTU + REAL, INTENT(OUT) :: LVCOEF + REAL,DIMENSION(1:NSOIL),INTENT(IN) :: SLDPTH,ZSOIL + REAL,DIMENSION(1:NSOIL),INTENT(OUT):: RTDIS + REAL :: FRZFACT,FRZK,REFDK + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + CHARACTER*256 :: err_message + errmsg = '' + errflg = 0 + +! SAVE +! ---------------------------------------------------------------------- +! + IF (SOILTYP .gt. SLCATS) THEN + errflg = 1 + errmsg = 'Warning: too many input soil types' + return + END IF + IF (VEGTYP .gt. LUCATS) THEN + errflg = 1 + errmsg = 'Warning: too many input landuse types' + return + END IF + IF (SLOPETYP .gt. SLPCATS) THEN + errflg = 1 + errmsg = 'Warning: too many input slope types' + return + END IF + +! ---------------------------------------------------------------------- +! SET-UP SOIL PARAMETERS +! ---------------------------------------------------------------------- + CSOIL = CSOIL_DATA + BEXP = BB (SOILTYP) + DKSAT = SATDK (SOILTYP) + DWSAT = SATDW (SOILTYP) + F1 = F11 (SOILTYP) + PSISAT = SATPSI (SOILTYP) + QUARTZ = QTZ (SOILTYP) + SMCDRY = DRYSMC (SOILTYP) + SMCMAX = MAXSMC (SOILTYP) + SMCREF = REFSMC (SOILTYP) + SMCWLT = WLTSMC (SOILTYP) +! ---------------------------------------------------------------------- +! Set-up universal parameters (not dependent on SOILTYP, VEGTYP or +! SLOPETYP) +! ---------------------------------------------------------------------- + ZBOT = ZBOT_DATA + SALP = SALP_DATA + SBETA = SBETA_DATA + REFDK = REFDK_DATA + FRZK = FRZK_DATA + FXEXP = FXEXP_DATA + REFKDT = REFKDT_DATA + PTU = 0. ! (not used yet) to satisify intent(out) + KDT = REFKDT * DKSAT / REFDK + CZIL = CZIL_DATA + SLOPE = SLOPE_DATA (SLOPETYP) + LVCOEF = LVCOEF_DATA + +! ---------------------------------------------------------------------- +! TO ADJUST FRZK PARAMETER TO ACTUAL SOIL TYPE: FRZK * FRZFACT +! ---------------------------------------------------------------------- + FRZFACT = (SMCMAX / SMCREF) * (0.412 / 0.468) + FRZX = FRZK * FRZFACT + +! ---------------------------------------------------------------------- +! SET-UP VEGETATION PARAMETERS +! ---------------------------------------------------------------------- + TOPT = TOPT_DATA + CMCMAX = CMCMAX_DATA + CFACTR = CFACTR_DATA + RSMAX = RSMAX_DATA + NROOT = NROTBL (VEGTYP) + SNUP = SNUPTBL (VEGTYP) + RSMIN = RSTBL (VEGTYP) + RGL = RGLTBL (VEGTYP) + HS = HSTBL (VEGTYP) + EMISSMIN = EMISSMINTBL (VEGTYP) + EMISSMAX = EMISSMAXTBL (VEGTYP) + LAIMIN = LAIMINTBL (VEGTYP) + LAIMAX = LAIMAXTBL (VEGTYP) + Z0MIN = Z0MINTBL (VEGTYP) + Z0MAX = Z0MAXTBL (VEGTYP) + ALBEDOMIN = ALBEDOMINTBL (VEGTYP) + ALBEDOMAX = ALBEDOMAXTBL (VEGTYP) + ZTOPV = ZTOPVTBL (VEGTYP) + ZBOTV = ZBOTVTBL (VEGTYP) + + IF (VEGTYP .eq. BARE) SHDFAC = 0.0 + IF (NROOT .gt. NSOIL) THEN + errflg = 1 + WRITE (err_message,*) 'Error: too many root layers ', & + NSOIL,NROOT + errmsg = TRIM(err_message) + return +! ---------------------------------------------------------------------- +! CALCULATE ROOT DISTRIBUTION. PRESENT VERSION ASSUMES UNIFORM +! DISTRIBUTION BASED ON SOIL LAYER DEPTHS. +! ---------------------------------------------------------------------- + END IF + DO I = 1,NROOT + RTDIS (I) = - SLDPTH (I)/ ZSOIL (NROOT) +! ---------------------------------------------------------------------- +! SET-UP SLOPE PARAMETER +! ---------------------------------------------------------------------- + END DO + +! print*,'end of PRMRED' +! print*,'VEGTYP',VEGTYP,'SOILTYP',SOILTYP,'SLOPETYP',SLOPETYP, & +! & 'CFACTR',CFACTR,'CMCMAX',CMCMAX,'RSMAX',RSMAX,'TOPT',TOPT, & +! & 'REFKDT',REFKDT,'KDT',KDT,'SBETA',SBETA, 'SHDFAC',SHDFAC, & +! & 'RSMIN',RSMIN,'RGL',RGL,'HS',HS,'ZBOT',ZBOT,'FRZX',FRZX, & +! & 'PSISAT',PSISAT,'SLOPE',SLOPE,'SNUP',SNUP,'SALP',SALP,'BEXP', & +! & BEXP, & +! & 'DKSAT',DKSAT,'DWSAT',DWSAT, & +! & 'SMCMAX',SMCMAX,'SMCWLT',SMCWLT,'SMCREF',SMCREF,'SMCDRY',SMCDRY, & +! & 'F1',F1,'QUARTZ',QUARTZ,'FXEXP',FXEXP, & +! & 'RTDIS',RTDIS,'SLDPTH',SLDPTH,'ZSOIL',ZSOIL, 'NROOT',NROOT, & +! & 'NSOIL',NSOIL,'Z0',Z0,'CZIL',CZIL,'LAI',LAI, & +! & 'CSOIL',CSOIL,'PTU',PTU, & +! & 'LOCAL', LOCAL + + END SUBROUTINE REDPRM + + SUBROUTINE ROSR12 (P,A,B,C,D,DELTA,NSOIL) + +! ---------------------------------------------------------------------- +! SUBROUTINE ROSR12 +! ---------------------------------------------------------------------- +! INVERT (SOLVE) THE TRI-DIAGONAL MATRIX PROBLEM SHOWN BELOW: +! ### ### ### ### ### ### +! #B(1), C(1), 0 , 0 , 0 , . . . , 0 # # # # # +! #A(2), B(2), C(2), 0 , 0 , . . . , 0 # # # # # +! # 0 , A(3), B(3), C(3), 0 , . . . , 0 # # # # D(3) # +! # 0 , 0 , A(4), B(4), C(4), . . . , 0 # # P(4) # # D(4) # +! # 0 , 0 , 0 , A(5), B(5), . . . , 0 # # P(5) # # D(5) # +! # . . # # . # = # . # +! # . . # # . # # . # +! # . . # # . # # . # +! # 0 , . . . , 0 , A(M-2), B(M-2), C(M-2), 0 # #P(M-2)# #D(M-2)# +! # 0 , . . . , 0 , 0 , A(M-1), B(M-1), C(M-1)# #P(M-1)# #D(M-1)# +! # 0 , . . . , 0 , 0 , 0 , A(M) , B(M) # # P(M) # # D(M) # +! ### ### ### ### ### ### +! ---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER, INTENT(IN) :: NSOIL + INTEGER :: K, KK + + REAL, DIMENSION(1:NSOIL), INTENT(IN):: A, B, D + REAL, DIMENSION(1:NSOIL),INTENT(INOUT):: C,P,DELTA + +! ---------------------------------------------------------------------- +! INITIALIZE EQN COEF C FOR THE LOWEST SOIL LAYER +! ---------------------------------------------------------------------- + C (NSOIL) = 0.0 + P (1) = - C (1) / B (1) +! ---------------------------------------------------------------------- +! SOLVE THE COEFS FOR THE 1ST SOIL LAYER +! ---------------------------------------------------------------------- + +! ---------------------------------------------------------------------- +! SOLVE THE COEFS FOR SOIL LAYERS 2 THRU NSOIL +! ---------------------------------------------------------------------- + DELTA (1) = D (1) / B (1) + DO K = 2,NSOIL + P (K) = - C (K) * ( 1.0 / (B (K) + A (K) * P (K -1)) ) + DELTA (K) = (D (K) - A (K)* DELTA (K -1))* (1.0/ (B (K) + A (K)& + * P (K -1))) + END DO +! ---------------------------------------------------------------------- +! SET P TO DELTA FOR LOWEST SOIL LAYER +! ---------------------------------------------------------------------- + P (NSOIL) = DELTA (NSOIL) + +! ---------------------------------------------------------------------- +! ADJUST P FOR SOIL LAYERS 2 THRU NSOIL +! ---------------------------------------------------------------------- + DO K = 2,NSOIL + KK = NSOIL - K + 1 + P (KK) = P (KK) * P (KK +1) + DELTA (KK) + END DO +! ---------------------------------------------------------------------- + END SUBROUTINE ROSR12 +! ---------------------------------------------------------------------- + + + SUBROUTINE SHFLX (SSOIL,STC,SMC,SMCMAX,NSOIL,T1,DT,YY,ZZ1,ZSOIL, & + TBOT,ZBOT,SMCWLT,PSISAT,SH2O,BEXP,F1,DF1, & + QUARTZ,CSOIL,VEGTYP,ISURBAN,SOILTYP,OPT_THCND & + ,HCPCT_FASDAS ) ! fasdas + +! ---------------------------------------------------------------------- +! SUBROUTINE SHFLX +! ---------------------------------------------------------------------- +! UPDATE THE TEMPERATURE STATE OF THE SOIL COLUMN BASED ON THE THERMAL +! DIFFUSION EQUATION AND UPDATE THE FROZEN SOIL MOISTURE CONTENT BASED +! ON THE TEMPERATURE. +! ---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER, INTENT(IN) :: OPT_THCND + INTEGER, INTENT(IN) :: NSOIL, VEGTYP, ISURBAN, SOILTYP + INTEGER :: I + + REAL, INTENT(IN) :: BEXP,CSOIL,DF1,DT,F1,PSISAT,QUARTZ, & + SMCMAX, SMCWLT, TBOT,YY, ZBOT,ZZ1 + REAL, INTENT(INOUT) :: T1 + REAL, INTENT(OUT) :: SSOIL + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC,ZSOIL + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: SH2O + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: STC + REAL, DIMENSION(1:NSOIL) :: AI, BI, CI, STCF,RHSTS + REAL, PARAMETER :: T0 = 273.15 + +! +! FASDAS +! + REAL, INTENT( OUT) :: HCPCT_FASDAS +! +! END FASDAS +! +! ---------------------------------------------------------------------- +! HRT ROUTINE CALCS THE RIGHT HAND SIDE OF THE SOIL TEMP DIF EQN +! ---------------------------------------------------------------------- + + ! Land case + + CALL HRT (RHSTS,STC,SMC,SMCMAX,NSOIL,ZSOIL,YY,ZZ1,TBOT, & + ZBOT,PSISAT,SH2O,DT,BEXP,SOILTYP,OPT_THCND, & + F1,DF1,QUARTZ,CSOIL,AI,BI,CI,VEGTYP,ISURBAN & + ,HCPCT_FASDAS ) !fasdas + + CALL HSTEP (STCF,STC,RHSTS,DT,NSOIL,AI,BI,CI) + + DO I = 1,NSOIL + STC (I) = STCF (I) + ENDDO + +! ---------------------------------------------------------------------- +! IN THE NO SNOWPACK CASE (VIA ROUTINE NOPAC BRANCH,) UPDATE THE GRND +! (SKIN) TEMPERATURE HERE IN RESPONSE TO THE UPDATED SOIL TEMPERATURE +! PROFILE ABOVE. (NOTE: INSPECTION OF ROUTINE SNOPAC SHOWS THAT T1 +! BELOW IS A DUMMY VARIABLE ONLY, AS SKIN TEMPERATURE IS UPDATED +! DIFFERENTLY IN ROUTINE SNOPAC) +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! CALCULATE SURFACE SOIL HEAT FLUX +! ---------------------------------------------------------------------- + T1 = (YY + (ZZ1- 1.0) * STC (1)) / ZZ1 + SSOIL = DF1 * (STC (1) - T1) / (0.5 * ZSOIL (1)) + +! ---------------------------------------------------------------------- + END SUBROUTINE SHFLX +! ---------------------------------------------------------------------- + + SUBROUTINE SMFLX (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, & + & SH2O,SLOPE,KDT,FRZFACT, & + & SMCMAX,BEXP,SMCWLT,DKSAT,DWSAT, & + & SHDFAC,CMCMAX, & + & RUNOFF1,RUNOFF2,RUNOFF3, & + & EDIR,EC,ET, & + & DRIP, SFHEAD1RT,INFXS1RT) + +! ---------------------------------------------------------------------- +! SUBROUTINE SMFLX +! ---------------------------------------------------------------------- +! CALCULATE SOIL MOISTURE FLUX. THE SOIL MOISTURE CONTENT (SMC - A PER +! UNIT VOLUME MEASUREMENT) IS A DEPENDENT VARIABLE THAT IS UPDATED WITH +! PROGNOSTIC EQNS. THE CANOPY MOISTURE CONTENT (CMC) IS ALSO UPDATED. +! FROZEN GROUND VERSION: NEW STATES ADDED: SH2O, AND FROZEN GROUND +! CORRECTION FACTOR, FRZFACT AND PARAMETER SLOPE. +! ---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER, INTENT(IN) :: NSOIL + INTEGER :: I,K + + REAL, INTENT(IN) :: BEXP, CMCMAX, DKSAT,DWSAT, DT, EC, EDIR, & + KDT, PRCP1, SHDFAC, SLOPE, SMCMAX, SMCWLT + REAL, INTENT(OUT) :: DRIP, RUNOFF1, RUNOFF2, RUNOFF3 + REAL, INTENT(INOUT) :: CMC + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ET,ZSOIL + REAL, DIMENSION(1:NSOIL), INTENT(INOUT):: SMC, SH2O + REAL, DIMENSION(1:NSOIL) :: AI, BI, CI, STCF,RHSTS, RHSTT, & + SICE, SH2OA, SH2OFG + REAL :: DUMMY, EXCESS,FRZFACT,PCPDRP,RHSCT,TRHSCT + REAL :: FAC2 + REAL :: FLIMIT + + REAL, INTENT(INOUT) :: SFHEAD1RT,INFXS1RT + +! ---------------------------------------------------------------------- +! EXECUTABLE CODE BEGINS HERE. +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! COMPUTE THE RIGHT HAND SIDE OF THE CANOPY EQN TERM ( RHSCT ) +! ---------------------------------------------------------------------- + DUMMY = 0. + +! ---------------------------------------------------------------------- +! CONVERT RHSCT (A RATE) TO TRHSCT (AN AMOUNT) AND ADD IT TO EXISTING +! CMC. IF RESULTING AMT EXCEEDS MAX CAPACITY, IT BECOMES DRIP AND WILL +! FALL TO THE GRND. +! ---------------------------------------------------------------------- + RHSCT = SHDFAC * PRCP1- EC + DRIP = 0. + TRHSCT = DT * RHSCT + EXCESS = CMC + TRHSCT + +! ---------------------------------------------------------------------- +! PCPDRP IS THE COMBINED PRCP1 AND DRIP (FROM CMC) THAT GOES INTO THE +! SOIL +! ---------------------------------------------------------------------- + IF (EXCESS > CMCMAX) DRIP = EXCESS - CMCMAX + PCPDRP = (1. - SHDFAC) * PRCP1+ DRIP / DT + +! ---------------------------------------------------------------------- +! STORE ICE CONTENT AT EACH SOIL LAYER BEFORE CALLING SRT and SSTEP +! + DO I = 1,NSOIL + SICE (I) = SMC (I) - SH2O (I) + END DO +! ---------------------------------------------------------------------- +! CALL SUBROUTINES SRT AND SSTEP TO SOLVE THE SOIL MOISTURE +! TENDENCY EQUATIONS. +! IF THE INFILTRATING PRECIP RATE IS NONTRIVIAL, +! (WE CONSIDER NONTRIVIAL TO BE A PRECIP TOTAL OVER THE TIME STEP +! EXCEEDING ONE ONE-THOUSANDTH OF THE WATER HOLDING CAPACITY OF +! THE FIRST SOIL LAYER) +! THEN CALL THE SRT/SSTEP SUBROUTINE PAIR TWICE IN THE MANNER OF +! TIME SCHEME "F" (IMPLICIT STATE, AVERAGED COEFFICIENT) +! OF SECTION 2 OF KALNAY AND KANAMITSU (1988, MWR, VOL 116, +! PAGES 1945-1958)TO MINIMIZE 2-DELTA-T OSCILLATIONS IN THE +! SOIL MOISTURE VALUE OF THE TOP SOIL LAYER THAT CAN ARISE BECAUSE +! OF THE EXTREME NONLINEAR DEPENDENCE OF THE SOIL HYDRAULIC +! DIFFUSIVITY COEFFICIENT AND THE HYDRAULIC CONDUCTIVITY ON THE +! SOIL MOISTURE STATE +! OTHERWISE CALL THE SRT/SSTEP SUBROUTINE PAIR ONCE IN THE MANNER OF +! TIME SCHEME "D" (IMPLICIT STATE, EXPLICIT COEFFICIENT) +! OF SECTION 2 OF KALNAY AND KANAMITSU +! PCPDRP IS UNITS OF KG/M**2/S OR MM/S, ZSOIL IS NEGATIVE DEPTH IN M +! ---------------------------------------------------------------------- +! According to Dr. Ken Mitchell's suggestion, add the second contraint +! to remove numerical instability of runoff and soil moisture +! FLIMIT is a limit value for FAC2 + FAC2=0.0 + DO I=1,NSOIL + FAC2=MAX(FAC2,SH2O(I)/SMCMAX) + ENDDO + CALL FAC2MIT(SMCMAX,FLIMIT) + +! ---------------------------------------------------------------------- +! FROZEN GROUND VERSION: +! SMC STATES REPLACED BY SH2O STATES IN SRT SUBR. SH2O & SICE STATES +! INC&UDED IN SSTEP SUBR. FROZEN GROUND CORRECTION FACTOR, FRZFACT +! ADDED. ALL WATER BALANCE CALCULATIONS USING UNFROZEN WATER +! ---------------------------------------------------------------------- + +#ifdef WRF_HYDRO +!DJG NDHMS/WRF-Hydro edit... Add previous ponded water to new precip drip... + PCPDRP = PCPDRP + SFHEAD1RT/1000./DT ! convert SFHEAD1RT to (m/s) +#endif + + + IF ( ( (PCPDRP * DT) > (0.0001*1000.0* (- ZSOIL (1))* SMCMAX) ) & + .OR. (FAC2 > FLIMIT) ) THEN + CALL SRT (RHSTT,EDIR,ET,SH2O,SH2O,NSOIL,PCPDRP,ZSOIL, & + DWSAT,DKSAT,SMCMAX,BEXP,RUNOFF1, & + RUNOFF2,DT,SMCWLT,SLOPE,KDT,FRZFACT,SICE,AI,BI,CI, & + SFHEAD1RT,INFXS1RT) + CALL SSTEP (SH2OFG,SH2O,DUMMY,RHSTT,RHSCT,DT,NSOIL,SMCMAX, & + CMCMAX,RUNOFF3,ZSOIL,SMC,SICE,AI,BI,CI,INFXS1RT) + DO K = 1,NSOIL + SH2OA (K) = (SH2O (K) + SH2OFG (K)) * 0.5 + END DO + CALL SRT (RHSTT,EDIR,ET,SH2O,SH2OA,NSOIL,PCPDRP,ZSOIL, & + DWSAT,DKSAT,SMCMAX,BEXP,RUNOFF1, & + RUNOFF2,DT,SMCWLT,SLOPE,KDT,FRZFACT,SICE,AI,BI,CI, & + SFHEAD1RT,INFXS1RT) + CALL SSTEP (SH2O,SH2O,CMC,RHSTT,RHSCT,DT,NSOIL,SMCMAX, & + CMCMAX,RUNOFF3,ZSOIL,SMC,SICE,AI,BI,CI,INFXS1RT) + + ELSE + CALL SRT (RHSTT,EDIR,ET,SH2O,SH2O,NSOIL,PCPDRP,ZSOIL, & + DWSAT,DKSAT,SMCMAX,BEXP,RUNOFF1, & + RUNOFF2,DT,SMCWLT,SLOPE,KDT,FRZFACT,SICE,AI,BI,CI, & + SFHEAD1RT,INFXS1RT) + CALL SSTEP (SH2O,SH2O,CMC,RHSTT,RHSCT,DT,NSOIL,SMCMAX, & + CMCMAX,RUNOFF3,ZSOIL,SMC,SICE,AI,BI,CI,INFXS1RT) +! RUNOF = RUNOFF + + END IF + +! ---------------------------------------------------------------------- + END SUBROUTINE SMFLX +! ---------------------------------------------------------------------- + + + SUBROUTINE SNFRAC (SNEQV,SNUP,SALP,SNOWH,SNCOVR, & + XLAI,SHDFAC,FVB,GAMA,FBUR, & + FGSN,ZTOPV,ZBOTV,UA_PHYS) + +! ---------------------------------------------------------------------- +! SUBROUTINE SNFRAC +! ---------------------------------------------------------------------- +! CALCULATE SNOW FRACTION (0 -> 1) +! SNEQV SNOW WATER EQUIVALENT (M) +! SNUP THRESHOLD SNEQV DEPTH ABOVE WHICH SNCOVR=1 +! SALP TUNING PARAMETER +! SNCOVR FRACTIONAL SNOW COVER +! ---------------------------------------------------------------------- + IMPLICIT NONE + + REAL, INTENT(IN) :: SNEQV,SNUP,SALP,SNOWH + REAL, INTENT(OUT) :: SNCOVR + REAL :: RSNOW, Z0N + LOGICAL, INTENT(IN) :: UA_PHYS ! UA: flag for UA option + REAL, INTENT(IN) :: ZTOPV ! UA: height of canopy top + REAL, INTENT(IN) :: ZBOTV ! UA: height of canopy bottom + REAL, INTENT(IN) :: SHDFAC ! UA: vegetation fraction + REAL, INTENT(INOUT) :: XLAI ! UA: LAI modified by snow + REAL, INTENT(OUT) :: FVB ! UA: frac. veg. w/snow beneath + REAL, INTENT(OUT) :: GAMA ! UA: = EXP(-1.* XLAI) + REAL, INTENT(OUT) :: FBUR ! UA: fraction of canopy buried + REAL, INTENT(OUT) :: FGSN ! UA: ground snow cover fraction + + REAL :: SNUPGRD = 0.02 ! UA: SWE limit for ground cover + +! ---------------------------------------------------------------------- +! SNUP IS VEG-CLASS DEPENDENT SNOWDEPTH THRESHHOLD (SET IN ROUTINE +! REDPRM) ABOVE WHICH SNOCVR=1. +! ---------------------------------------------------------------------- + IF (SNEQV < SNUP) THEN + RSNOW = SNEQV / SNUP + SNCOVR = 1. - ( EXP ( - SALP * RSNOW) - RSNOW * EXP ( - SALP)) + ELSE + SNCOVR = 1.0 + END IF + +! FORMULATION OF DICKINSON ET AL. 1986 +! Z0N = 0.035 + +! SNCOVR=SNOWH/(SNOWH + 5*Z0N) + +! FORMULATION OF MARSHALL ET AL. 1994 +! SNCOVR=SNEQV/(SNEQV + 2*Z0N) + + IF(UA_PHYS) THEN + +!--------------------------------------------------------------------- +! FGSN: FRACTION OF SOIL COVERED WITH SNOW +!--------------------------------------------------------------------- + IF (SNEQV < SNUPGRD) THEN + FGSN = SNEQV / SNUPGRD + ELSE + FGSN = 1.0 + END IF +!------------------------------------------------------------------ +! FBUR: VERTICAL FRACTION OF VEGETATION COVERED BY SNOW +! GRASS, CROP, AND SHRUB: MULTIPLY 0.4 BY ZTOPV AND ZBOTV BECAUSE +! THEY WILL BE PRESSED DOWN BY THE SNOW. +! FOREST: DON'T NEED TO CHANGE ZTOPV AND ZBOTV. + + IF(ZBOTV > 0. .AND. SNOWH > ZBOTV) THEN + IF(ZBOTV <= 0.5) THEN + FBUR = (SNOWH - 0.4*ZBOTV) / (0.4*(ZTOPV-ZBOTV)) ! short veg. + ELSE + FBUR = (SNOWH - ZBOTV) / (ZTOPV-ZBOTV) ! tall veg. + ENDIF + ELSE + FBUR = 0. + ENDIF + + FBUR = MIN(MAX(FBUR,0.0),1.0) + +! XLAI IS ADJUSTED FOR VERTICAL BURYING BY SNOW + XLAI = XLAI * (1.0 - FBUR) +! ---------------------------------------------------------------------- +! SNOW-COVERED SOIL: (1-SHDFAC)*FGSN +! VEGETATION WITH SNOW ABOVE DUE TO BURIAL FVEG_SN_AB = SHDFAC*FBUR +! SNOW ON THE GROUND THAT CAN BE "SEEN" BY SATELLITE +! (IF XLAI GOES TO ZERO): GAMA*FVB +! Where GAMA = exp(-XLAI) +! ---------------------------------------------------------------------- + +! VEGETATION WITH SNOW BELOW + FVB = SHDFAC * FGSN * (1.0 - FBUR) + +! GAMA IS USED TO DIVIDE FVB INTO TWO PARTS: +! GAMA=1 FOR XLAI=0 AND GAMA=0 FOR XLAI=6 + GAMA = EXP(-1.* XLAI) + ELSE + ! Define intent(out) terms for .NOT. UA_PHYS case + FVB = 0.0 + GAMA = 0.0 + FBUR = 0.0 + FGSN = 0.0 + END IF ! UA_PHYS + +! ---------------------------------------------------------------------- + END SUBROUTINE SNFRAC +! ---------------------------------------------------------------------- + + SUBROUTINE SNKSRC (TSNSR,TAVG,SMC,SH2O,ZSOIL,NSOIL, & + & SMCMAX,PSISAT,BEXP,DT,K,QTOT) +! ---------------------------------------------------------------------- +! SUBROUTINE SNKSRC +! ---------------------------------------------------------------------- +! CALCULATE SINK/SOURCE TERM OF THE TERMAL DIFFUSION EQUATION. (SH2O) IS +! AVAILABLE LIQUED WATER. +! ---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER, INTENT(IN) :: K,NSOIL + REAL, INTENT(IN) :: BEXP, DT, PSISAT, QTOT, SMC, SMCMAX, & + TAVG + REAL, INTENT(INOUT) :: SH2O + + REAL, DIMENSION(1:NSOIL), INTENT(IN):: ZSOIL + + REAL :: DF, DZ, DZH, FREE, TSNSR, & + TDN, TM, TUP, TZ, X0, XDN, XH2O, XUP + + REAL, PARAMETER :: DH2O = 1.0000E3, HLICE = 3.3350E5, & + T0 = 2.7315E2 + + IF (K == 1) THEN + DZ = - ZSOIL (1) + ELSE + DZ = ZSOIL (K -1) - ZSOIL (K) + END IF +! ---------------------------------------------------------------------- +! VIA FUNCTION FRH2O, COMPUTE POTENTIAL OR 'EQUILIBRIUM' UNFROZEN +! SUPERCOOLED FREE WATER FOR GIVEN SOIL TYPE AND SOIL LAYER TEMPERATURE. +! FUNCTION FRH20 INVOKES EQN (17) FROM V. KOREN ET AL (1999, JGR, VOL. +! 104, PG 19573). (ASIDE: LATTER EQN IN JOURNAL IN CENTIGRADE UNITS. +! ROUTINE FRH2O USE FORM OF EQN IN KELVIN UNITS.) +! ---------------------------------------------------------------------- +! FREE = FRH2O(TAVG,SMC,SH2O,SMCMAX,BEXP,PSISAT) + +! ---------------------------------------------------------------------- +! IN NEXT BLOCK OF CODE, INVOKE EQN 18 OF V. KOREN ET AL (1999, JGR, +! VOL. 104, PG 19573.) THAT IS, FIRST ESTIMATE THE NEW AMOUNTOF LIQUID +! WATER, 'XH2O', IMPLIED BY THE SUM OF (1) THE LIQUID WATER AT THE BEGIN +! OF CURRENT TIME STEP, AND (2) THE FREEZE OF THAW CHANGE IN LIQUID +! WATER IMPLIED BY THE HEAT FLUX 'QTOT' PASSED IN FROM ROUTINE HRT. +! SECOND, DETERMINE IF XH2O NEEDS TO BE BOUNDED BY 'FREE' (EQUIL AMT) OR +! IF 'FREE' NEEDS TO BE BOUNDED BY XH2O. +! ---------------------------------------------------------------------- + CALL FRH2O (FREE,TAVG,SMC,SH2O,SMCMAX,BEXP,PSISAT) + +! ---------------------------------------------------------------------- +! FIRST, IF FREEZING AND REMAINING LIQUID LESS THAN LOWER BOUND, THEN +! REDUCE EXTENT OF FREEZING, THEREBY LETTING SOME OR ALL OF HEAT FLUX +! QTOT COOL THE SOIL TEMP LATER IN ROUTINE HRT. +! ---------------------------------------------------------------------- + XH2O = SH2O + QTOT * DT / (DH2O * HLICE * DZ) + IF ( XH2O < SH2O .AND. XH2O < FREE) THEN + IF ( FREE > SH2O ) THEN + XH2O = SH2O + ELSE + XH2O = FREE + END IF + END IF +! ---------------------------------------------------------------------- +! SECOND, IF THAWING AND THE INCREASE IN LIQUID WATER GREATER THAN UPPER +! BOUND, THEN REDUCE EXTENT OF THAW, THEREBY LETTING SOME OR ALL OF HEAT +! FLUX QTOT WARM THE SOIL TEMP LATER IN ROUTINE HRT. +! ---------------------------------------------------------------------- + IF ( XH2O > SH2O .AND. XH2O > FREE ) THEN + IF ( FREE < SH2O ) THEN + XH2O = SH2O + ELSE + XH2O = FREE + END IF + END IF + +! ---------------------------------------------------------------------- +! CALCULATE PHASE-CHANGE HEAT SOURCE/SINK TERM FOR USE IN ROUTINE HRT +! AND UPDATE LIQUID WATER TO REFLCET FINAL FREEZE/THAW INCREMENT. +! ---------------------------------------------------------------------- +! SNKSRC = -DH2O*HLICE*DZ*(XH2O-SH2O)/DT + IF (XH2O < 0.) XH2O = 0. + IF (XH2O > SMC) XH2O = SMC + TSNSR = - DH2O * HLICE * DZ * (XH2O - SH2O)/ DT + SH2O = XH2O + +! ---------------------------------------------------------------------- + END SUBROUTINE SNKSRC +! ---------------------------------------------------------------------- + + SUBROUTINE SNOPAC (ETP,ETA,PRCP,PRCPF,SNOWNG,SMC,SMCMAX,SMCWLT, & + SMCREF,SMCDRY,CMC,CMCMAX,NSOIL,DT, & + SBETA,DF1, & + Q2,T1,SFCTMP,T24,TH2,FDOWN,F1,SSOIL,STC,EPSCA,& + SFCPRS,BEXP,PC,RCH,RR,CFACTR,SNCOVR,ESD,SNDENS,& + SNOWH,SH2O,SLOPE,KDT,FRZFACT,PSISAT, & + ZSOIL,DWSAT,DKSAT,TBOT,ZBOT,SHDFAC,RUNOFF1, & + RUNOFF2,RUNOFF3,EDIR,EC,ET,ETT,NROOT,SNOMLT, & + RTDIS,QUARTZ,FXEXP,CSOIL, & + BETA,DRIP,DEW,FLX1,FLX2,FLX3,ESNOW,ETNS,EMISSI,& + RIBB,SOLDN, & + ISURBAN, & + VEGTYP, & + ETPN,FLX4,UA_PHYS, & + SFHEAD1RT,INFXS1RT,ETPND1,SOILTYP,OPT_THCND & + ,QFX_PHY,fasdas,HCPCT_FASDAS, & !fasdas + SIGMA,CPH2O,CPICE,LSUBF) +! ---------------------------------------------------------------------- +! SUBROUTINE SNOPAC +! ---------------------------------------------------------------------- +! CALCULATE SOIL MOISTURE AND HEAT FLUX VALUES & UPDATE SOIL MOISTURE +! CONTENT AND SOIL HEAT CONTENT VALUES FOR THE CASE WHEN A SNOW PACK IS +! PRESENT. +! ---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER, INTENT(IN) :: OPT_THCND + INTEGER, INTENT(IN) :: NROOT, NSOIL,VEGTYP,SOILTYP + INTEGER, INTENT(IN) :: ISURBAN + INTEGER :: K +! +! kmh 09/03/2006 add IT16 for surface temperature iteration +! + INTEGER :: IT16 + LOGICAL, INTENT(IN) :: SNOWNG + +!DJG NDHMS/WRF-Hydro edit... + REAL, INTENT(INOUT) :: SFHEAD1RT,INFXS1RT,ETPND1 + + REAL, INTENT(IN) :: BEXP,CFACTR, CMCMAX,CSOIL,DF1,DKSAT, & + DT,DWSAT, EPSCA,FDOWN,F1,FXEXP, & + FRZFACT,KDT,PC, PRCP,PSISAT,Q2,QUARTZ, & + RCH,RR,SBETA,SFCPRS, SFCTMP, SHDFAC, & + SLOPE,SMCDRY,SMCMAX,SMCREF,SMCWLT, T24, & + TBOT,TH2,ZBOT,EMISSI,SOLDN,SIGMA,CPH2O, & + CPICE,LSUBF + REAL, INTENT(INOUT) :: CMC, BETA, ESD,FLX2,PRCPF,SNOWH,SNCOVR, & + SNDENS, T1, RIBB, ETP + REAL, INTENT(OUT) :: DEW,DRIP,EC,EDIR, ETNS, ESNOW,ETT, & + FLX1,FLX3, RUNOFF1,RUNOFF2,RUNOFF3, & + SSOIL,SNOMLT + REAL, DIMENSION(1:NSOIL),INTENT(IN) :: RTDIS,ZSOIL + REAL, DIMENSION(1:NSOIL),INTENT(OUT) :: ET + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: SMC,SH2O,STC + REAL, DIMENSION(1:NSOIL) :: ET1 + REAL :: DENOM,DSOIL,DTOT,EC1,EDIR1,ESDFLX,ETA, & + ETT1, ESNOW1, ESNOW2, ETA1,ETP1,ETP2, & + ETP3, ETNS1, ETANRG, ETAX, EX, FLX3X, & + FRCSNO,FRCSOI, PRCP1, QSAT,RSNOW, SEH, & + SNCOND,SSOIL1, T11,T12, T12A, T12AX, & + T12B, T14, YY, ZZ1 +! T12B, T14, YY, ZZ1,EMISSI_S +! +! kmh 01/11/2007 add T15, T16, and DTOT2 for SFC T iteration and snow heat flux +! + REAL :: T15, T16, DTOT2 + REAL, PARAMETER :: ESDMIN = 1.E-6, LSUBC = 2.501000E+6, & + LSUBS = 2.83E+6, TFREEZ = 273.15, & + SNOEXP = 2.0 + LOGICAL, INTENT(IN) :: UA_PHYS ! UA: flag for UA option + REAL, INTENT(INOUT) :: FLX4 ! UA: energy removed by canopy + REAL, INTENT(IN) :: ETPN ! UA: adjusted pot. evap. [mm/s] + REAL :: ETP1N ! UA: adjusted pot. evap. [m/s] + +! +! FASDAS +! + REAL :: QFX_PHY + INTEGER :: fasdas + REAL, INTENT( OUT) :: HCPCT_FASDAS +! +! END FASDAS +! +! ---------------------------------------------------------------------- +! EXECUTABLE CODE BEGINS HERE: +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! INITIALIZE EVAP TERMS. +! ---------------------------------------------------------------------- +! conversions: +! ESNOW [KG M-2 S-1] +! ESDFLX [KG M-2 S-1] .le. ESNOW +! ESNOW1 [M S-1] +! ESNOW2 [M] +! ETP [KG M-2 S-1] +! ETP1 [M S-1] +! ETP2 [M] +! ---------------------------------------------------------------------- + DEW = 0. + EDIR = 0. + EDIR1 = 0. + EC1 = 0. + EC = 0. +! EMISSI_S=0.95 ! For snow + + DO K = 1,NSOIL + ET (K) = 0. + ET1 (K) = 0. + END DO + ETT = 0. + ETT1 = 0. + +!DJG NDHMS/WRF-Hydro edit... + ETPND1 = 0. + + + ETNS = 0. + ETNS1 = 0. + ESNOW = 0. + ESNOW1 = 0. + ESNOW2 = 0. + +! ---------------------------------------------------------------------- +! CONVERT POTENTIAL EVAP (ETP) FROM KG M-2 S-1 TO ETP1 IN M S-1 +! ---------------------------------------------------------------------- + PRCP1 = PRCPF *0.001 +! ---------------------------------------------------------------------- +! IF ETP<0 (DOWNWARD) THEN DEWFALL (=FROSTFALL IN THIS CASE). +! ---------------------------------------------------------------------- + BETA = 1.0 + IF (ETP <= 0.0) THEN + IF ( ( RIBB >= 0.1 ) .AND. ( FDOWN > 150.0 ) ) THEN + ETP=(MIN(ETP*(1.0-RIBB),0.)*SNCOVR/0.980 + ETP*(0.980-SNCOVR))/0.980 + ENDIF + IF(ETP == 0.) BETA = 0.0 + ETP1 = ETP * 0.001 + IF(UA_PHYS) ETP1N = ETPN * 0.001 + DEW = -ETP1 + ESNOW2 = ETP1*DT + ETANRG = ETP*((1.-SNCOVR)*LSUBC + SNCOVR*LSUBS) + ELSE + ETP1 = ETP * 0.001 + IF(UA_PHYS) ETP1N = ETPN * 0.001 + ! LAND CASE + IF (SNCOVR < 1.) THEN + CALL EVAPO (ETNS1,SMC,NSOIL,CMC,ETP1,DT,ZSOIL, & + SH2O, & + SMCMAX,BEXP,PC,SMCWLT,DKSAT,DWSAT, & + SMCREF,SHDFAC,CMCMAX, & + SMCDRY,CFACTR, & + EDIR1,EC1,ET1,ETT1,SFCTMP,Q2,NROOT,RTDIS, & + FXEXP, SFHEAD1RT,ETPND1) +! ---------------------------------------------------------------------------- + EDIR1 = EDIR1* (1. - SNCOVR) + EC1 = EC1* (1. - SNCOVR) + DO K = 1,NSOIL + ET1 (K) = ET1 (K)* (1. - SNCOVR) + END DO + ETT1 = ETT1*(1.-SNCOVR) +! ETNS1 = EDIR1+ EC1+ ETT1 + ETNS1 = ETNS1*(1.-SNCOVR) +! ---------------------------------------------------------------------------- + EDIR = EDIR1*1000. + EC = EC1*1000. + DO K = 1,NSOIL + ET (K) = ET1 (K)*1000. + END DO +! +! FASDAS +! + if( fasdas == 1 ) then + QFX_PHY = EDIR + EC + DO K=1,NSOIL + QFX_PHY = QFX_PHY + ET(K) + END DO + endif +! +! END FASDAS +! + ETT = ETT1*1000. + ETNS = ETNS1*1000. + + +!DJG NDHMS/WRF-Hydro edit... + ETPND1 = ETPND1*1000. + + +! ---------------------------------------------------------------------- + + ENDIF + ESNOW = ETP*SNCOVR + IF(UA_PHYS) ESNOW = ETPN*SNCOVR ! USE ADJUSTED ETP + ESNOW1 = ESNOW*0.001 + ESNOW2 = ESNOW1*DT + ETANRG = ESNOW*LSUBS + ETNS*LSUBC + ENDIF + +! ---------------------------------------------------------------------- +! IF PRECIP IS FALLING, CALCULATE HEAT FLUX FROM SNOW SFC TO NEWLY +! ACCUMULATING PRECIP. NOTE THAT THIS REFLECTS THE FLUX APPROPRIATE FOR +! THE NOT-YET-UPDATED SKIN TEMPERATURE (T1). ASSUMES TEMPERATURE OF THE +! SNOWFALL STRIKING THE GROUND IS =SFCTMP (LOWEST MODEL LEVEL AIR TEMP). +! ---------------------------------------------------------------------- + FLX1 = 0.0 + IF (SNOWNG) THEN + FLX1 = CPICE * PRCP * (T1- SFCTMP) + ELSE + IF (PRCP > 0.0) FLX1 = CPH2O * PRCP * (T1- SFCTMP) +! ---------------------------------------------------------------------- +! CALCULATE AN 'EFFECTIVE SNOW-GRND SFC TEMP' (T12) BASED ON HEAT FLUXES +! BETWEEN THE SNOW PACK AND THE SOIL AND ON NET RADIATION. +! INCLUDE FLX1 (PRECIP-SNOW SFC) AND FLX2 (FREEZING RAIN LATENT HEAT) +! FLUXES. FLX1 FROM ABOVE, FLX2 BROUGHT IN VIA COMMOM BLOCK RITE. +! FLX2 REFLECTS FREEZING RAIN LATENT HEAT FLUX USING T1 CALCULATED IN +! PENMAN. +! ---------------------------------------------------------------------- + END IF + DSOIL = - (0.5 * ZSOIL (1)) + DTOT = SNOWH + DSOIL + DENOM = 1.0+ DF1 / (DTOT * RR * RCH) +! surface emissivity weighted by snow cover fraction +! T12A = ( (FDOWN - FLX1 - FLX2 - & +! & ((SNCOVR*EMISSI_S)+EMISSI*(1.0-SNCOVR))*SIGMA *T24)/RCH & +! & + TH2 - SFCTMP - ETANRG/RCH ) / RR + T12A = ( (FDOWN - FLX1- FLX2- EMISSI * SIGMA * T24)/ RCH & + + TH2- SFCTMP - ETANRG / RCH ) / RR + + T12B = DF1 * STC (1) / (DTOT * RR * RCH) + +! ---------------------------------------------------------------------- +! IF THE 'EFFECTIVE SNOW-GRND SFC TEMP' IS AT OR BELOW FREEZING, NO SNOW +! MELT WILL OCCUR. SET THE SKIN TEMP TO THIS EFFECTIVE TEMP. REDUCE +! (BY SUBLIMINATION ) OR INCREASE (BY FROST) THE DEPTH OF THE SNOWPACK, +! DEPENDING ON SIGN OF ETP. +! UPDATE SOIL HEAT FLUX (SSOIL) USING NEW SKIN TEMPERATURE (T1) +! SINCE NO SNOWMELT, SET ACCUMULATED SNOWMELT TO ZERO, SET 'EFFECTIVE' +! PRECIP FROM SNOWMELT TO ZERO, SET PHASE-CHANGE HEAT FLUX FROM SNOWMELT +! TO ZERO. +! ---------------------------------------------------------------------- +! SUB-FREEZING BLOCK +! ---------------------------------------------------------------------- + T12 = (SFCTMP + T12A + T12B) / DENOM + IF (T12 <= TFREEZ) THEN + T1 = T12 + SSOIL = DF1 * (T1- STC (1)) / DTOT +! ESD = MAX (0.0, ESD- ETP2) + ESD = MAX(0.0, ESD-ESNOW2) + FLX3 = 0.0 + EX = 0.0 + + SNOMLT = 0.0 + IF(UA_PHYS) FLX4 = 0.0 +! ---------------------------------------------------------------------- +! IF THE 'EFFECTIVE SNOW-GRND SFC TEMP' IS ABOVE FREEZING, SNOW MELT +! WILL OCCUR. CALL THE SNOW MELT RATE,EX AND AMT, SNOMLT. REVISE THE +! EFFECTIVE SNOW DEPTH. REVISE THE SKIN TEMP BECAUSE IT WOULD HAVE CHGD +! DUE TO THE LATENT HEAT RELEASED BY THE MELTING. CALC THE LATENT HEAT +! RELEASED, FLX3. SET THE EFFECTIVE PRECIP, PRCP1 TO THE SNOW MELT RATE, +! EX FOR USE IN SMFLX. ADJUSTMENT TO T1 TO ACCOUNT FOR SNOW PATCHES. +! CALCULATE QSAT VALID AT FREEZING POINT. NOTE THAT ESAT (SATURATION +! VAPOR PRESSURE) VALUE OF 6.11E+2 USED HERE IS THAT VALID AT FRZZING +! POINT. NOTE THAT ETP FROM CALL PENMAN IN SFLX IS IGNORED HERE IN +! FAVOR OF BULK ETP OVER 'OPEN WATER' AT FREEZING TEMP. +! UPDATE SOIL HEAT FLUX (S) USING NEW SKIN TEMPERATURE (T1) +! ---------------------------------------------------------------------- +! ABOVE FREEZING BLOCK +! ---------------------------------------------------------------------- + ELSE +! From V3.9 original code (commented) replaced to allow complete melting of small snow amounts +! T1 = TFREEZ * SNCOVR ** SNOEXP + T12 * (1.0- SNCOVR ** SNOEXP) + T1 = TFREEZ * max(0.01,SNCOVR ** SNOEXP) + T12 * (1.0- max(0.01,SNCOVR ** SNOEXP)) + BETA = 1.0 + +! ---------------------------------------------------------------------- +! IF POTENTIAL EVAP (SUBLIMATION) GREATER THAN DEPTH OF SNOWPACK. +! BETA<1 +! SNOWPACK HAS SUBLIMATED AWAY, SET DEPTH TO ZERO. +! ---------------------------------------------------------------------- + SSOIL = DF1 * (T1- STC (1)) / DTOT + IF (ESD-ESNOW2 <= ESDMIN) THEN + ESD = 0.0 + EX = 0.0 + SNOMLT = 0.0 + FLX3 = 0.0 + IF(UA_PHYS) FLX4 = 0.0 +! ---------------------------------------------------------------------- +! SUBLIMATION LESS THAN DEPTH OF SNOWPACK +! SNOWPACK (ESD) REDUCED BY ESNOW2 (DEPTH OF SUBLIMATED SNOW) +! ---------------------------------------------------------------------- + ELSE + ESD = ESD-ESNOW2 + ETP3 = ETP * LSUBC + SEH = RCH * (T1- TH2) + T14 = T1* T1 + T14 = T14* T14 +! FLX3 = FDOWN - FLX1 - FLX2 - & +! ((SNCOVR*EMISSI_S)+EMISSI*(1-SNCOVR))*SIGMA*T14 - & +! SSOIL - SEH - ETANRG + FLX3 = FDOWN - FLX1- FLX2- EMISSI*SIGMA * T14- SSOIL - SEH - ETANRG + IF (FLX3 <= 0.0) FLX3 = 0.0 + + IF(UA_PHYS .AND. FLX4 > 0. .AND. FLX3 > 0.) THEN + IF(FLX3 >= FLX4) THEN + FLX3 = FLX3 - FLX4 + ELSE + FLX4 = FLX3 + FLX3 = 0. + ENDIF + ELSE + FLX4 = 0.0 + ENDIF + +! ---------------------------------------------------------------------- +! SNOWMELT REDUCTION DEPENDING ON SNOW COVER +! ---------------------------------------------------------------------- + EX = FLX3*0.001/ LSUBF + +! ---------------------------------------------------------------------- +! ESDMIN REPRESENTS A SNOWPACK DEPTH THRESHOLD VALUE BELOW WHICH WE +! CHOOSE NOT TO RETAIN ANY SNOWPACK, AND INSTEAD INCLUDE IT IN SNOWMELT. +! ---------------------------------------------------------------------- + SNOMLT = EX * DT + IF (ESD- SNOMLT >= ESDMIN) THEN + ESD = ESD- SNOMLT +! ---------------------------------------------------------------------- +! SNOWMELT EXCEEDS SNOW DEPTH +! ---------------------------------------------------------------------- + ELSE + EX = ESD / DT + FLX3 = EX *1000.0* LSUBF + SNOMLT = ESD + + ESD = 0.0 +! ---------------------------------------------------------------------- +! END OF 'ESD .LE. ETP2' IF-BLOCK +! ---------------------------------------------------------------------- + END IF + END IF + +! ---------------------------------------------------------------------- +! END OF 'T12 .LE. TFREEZ' IF-BLOCK +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! IF NON-GLACIAL LAND, ADD SNOWMELT RATE (EX) TO PRECIP RATE TO BE USED +! IN SUBROUTINE SMFLX (SOIL MOISTURE EVOLUTION) VIA INFILTRATION. +! +! RUNOFF/BASEFLOW LATER NEAR THE END OF SFLX (AFTER RETURN FROM CALL TO +! SUBROUTINE SNOPAC) +! ---------------------------------------------------------------------- + PRCP1 = PRCP1+ EX + +! ---------------------------------------------------------------------- +! SET THE EFFECTIVE POTNL EVAPOTRANSP (ETP1) TO ZERO SINCE THIS IS SNOW +! CASE, SO SURFACE EVAP NOT CALCULATED FROM EDIR, EC, OR ETT IN SMFLX +! (BELOW). +! SMFLX RETURNS UPDATED SOIL MOISTURE VALUES FOR NON-GLACIAL LAND. +! ---------------------------------------------------------------------- + END IF + CALL SMFLX (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, & + SH2O,SLOPE,KDT,FRZFACT, & + SMCMAX,BEXP,SMCWLT,DKSAT,DWSAT, & + SHDFAC,CMCMAX, & + RUNOFF1,RUNOFF2,RUNOFF3, & + EDIR1,EC1,ET1, & + DRIP, SFHEAD1RT,INFXS1RT) +! ---------------------------------------------------------------------- +! BEFORE CALL SHFLX IN THIS SNOWPACK CASE, SET ZZ1 AND YY ARGUMENTS TO +! SPECIAL VALUES THAT ENSURE THAT GROUND HEAT FLUX CALCULATED IN SHFLX +! MATCHES THAT ALREADY COMPUTER FOR BELOW THE SNOWPACK, THUS THE SFC +! HEAT FLUX TO BE COMPUTED IN SHFLX WILL EFFECTIVELY BE THE FLUX AT THE +! SNOW TOP SURFACE. T11 IS A DUMMY ARGUEMENT SO WE WILL NOT USE THE +! SKIN TEMP VALUE AS REVISED BY SHFLX. +! ---------------------------------------------------------------------- + ZZ1 = 1.0 + YY = STC (1) -0.5* SSOIL * ZSOIL (1)* ZZ1/ DF1 + +! ---------------------------------------------------------------------- +! SHFLX WILL CALC/UPDATE THE SOIL TEMPS. NOTE: THE SUB-SFC HEAT FLUX +! (SSOIL1) AND THE SKIN TEMP (T11) OUTPUT FROM THIS SHFLX CALL ARE NOT +! USED IN ANY SUBSEQUENT CALCULATIONS. RATHER, THEY ARE DUMMY VARIABLES +! HERE IN THE SNOPAC CASE, SINCE THE SKIN TEMP AND SUB-SFC HEAT FLUX ARE +! UPDATED INSTEAD NEAR THE BEGINNING OF THE CALL TO SNOPAC. +! ---------------------------------------------------------------------- + T11 = T1 + CALL SHFLX (SSOIL1,STC,SMC,SMCMAX,NSOIL,T11,DT,YY,ZZ1,ZSOIL, & + TBOT,ZBOT,SMCWLT,PSISAT,SH2O,BEXP,F1,DF1, & + QUARTZ,CSOIL,VEGTYP,ISURBAN,SOILTYP,OPT_THCND & + ,HCPCT_FASDAS ) !fasdas + +! ---------------------------------------------------------------------- +! SNOW DEPTH AND DENSITY ADJUSTMENT BASED ON SNOW COMPACTION. YY IS +! ASSUMED TO BE THE SOIL TEMPERTURE AT THE TOP OF THE SOIL COLUMN. +! ---------------------------------------------------------------------- + ! LAND + IF (ESD > 0.) THEN + CALL SNOWPACK (ESD,DT,SNOWH,SNDENS,T1,YY,SNOMLT,UA_PHYS) + ELSE + ESD = 0. + SNOWH = 0. + SNDENS = 0. + SNCOND = 1. + SNCOVR = 0. + END IF + +! ---------------------------------------------------------------------- + END SUBROUTINE SNOPAC +! ---------------------------------------------------------------------- + + + SUBROUTINE SNOWPACK (ESD,DTSEC,SNOWH,SNDENS,TSNOW,TSOIL,SNOMLT,UA_PHYS) + +! ---------------------------------------------------------------------- +! SUBROUTINE SNOWPACK +! ---------------------------------------------------------------------- +! CALCULATE COMPACTION OF SNOWPACK UNDER CONDITIONS OF INCREASING SNOW +! DENSITY, AS OBTAINED FROM AN APPROXIMATE SOLUTION OF E. ANDERSON'S +! DIFFERENTIAL EQUATION (3.29), NOAA TECHNICAL REPORT NWS 19, BY VICTOR +! KOREN, 03/25/95. +! ---------------------------------------------------------------------- +! ESD WATER EQUIVALENT OF SNOW (M) +! DTSEC TIME STEP (SEC) +! SNOWH SNOW DEPTH (M) +! SNDENS SNOW DENSITY (G/CM3=DIMENSIONLESS FRACTION OF H2O DENSITY) +! TSNOW SNOW SURFACE TEMPERATURE (K) +! TSOIL SOIL SURFACE TEMPERATURE (K) + +! SUBROUTINE WILL RETURN NEW VALUES OF SNOWH AND SNDENS +! ---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER :: IPOL, J + REAL, INTENT(IN) :: ESD, DTSEC,TSNOW,TSOIL + REAL, INTENT(INOUT) :: SNOWH, SNDENS + REAL :: BFAC,DSX,DTHR,DW,SNOWHC,PEXP, & + TAVGC,TSNOWC,TSOILC,ESDC,ESDCX + REAL, PARAMETER :: C1 = 0.01, C2 = 21.0, G = 9.81, & + KN = 4000.0 + LOGICAL, INTENT(IN) :: UA_PHYS ! UA: flag for UA option + REAL, INTENT(IN) :: SNOMLT ! UA: snow melt [m] + REAL :: SNOMLTC ! UA: snow melt [cm] +! ---------------------------------------------------------------------- +! CONVERSION INTO SIMULATION UNITS +! ---------------------------------------------------------------------- + SNOWHC = SNOWH *100. + ESDC = ESD *100. + IF(UA_PHYS) SNOMLTC = SNOMLT *100. + DTHR = DTSEC /3600. + TSNOWC = TSNOW -273.15 + TSOILC = TSOIL -273.15 + +! ---------------------------------------------------------------------- +! CALCULATING OF AVERAGE TEMPERATURE OF SNOW PACK +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! CALCULATING OF SNOW DEPTH AND DENSITY AS A RESULT OF COMPACTION +! SNDENS=DS0*(EXP(BFAC*ESD)-1.)/(BFAC*ESD) +! BFAC=DTHR*C1*EXP(0.08*TAVGC-C2*DS0) +! NOTE: BFAC*ESD IN SNDENS EQN ABOVE HAS TO BE CAREFULLY TREATED +! NUMERICALLY BELOW: +! C1 IS THE FRACTIONAL INCREASE IN DENSITY (1/(CM*HR)) +! C2 IS A CONSTANT (CM3/G) KOJIMA ESTIMATED AS 21 CMS/G +! ---------------------------------------------------------------------- + TAVGC = 0.5* (TSNOWC + TSOILC) + IF (ESDC > 1.E-2) THEN + ESDCX = ESDC + ELSE + ESDCX = 1.E-2 + END IF + +! DSX = SNDENS*((DEXP(BFAC*ESDC)-1.)/(BFAC*ESDC)) +! ---------------------------------------------------------------------- +! THE FUNCTION OF THE FORM (e**x-1)/x EMBEDDED IN ABOVE EXPRESSION +! FOR DSX WAS CAUSING NUMERICAL DIFFICULTIES WHEN THE DENOMINATOR "x" +! (I.E. BFAC*ESDC) BECAME ZERO OR APPROACHED ZERO (DESPITE THE FACT THAT +! THE ANALYTICAL FUNCTION (e**x-1)/x HAS A WELL DEFINED LIMIT AS +! "x" APPROACHES ZERO), HENCE BELOW WE REPLACE THE (e**x-1)/x +! EXPRESSION WITH AN EQUIVALENT, NUMERICALLY WELL-BEHAVED +! POLYNOMIAL EXPANSION. + +! NUMBER OF TERMS OF POLYNOMIAL EXPANSION, AND HENCE ITS ACCURACY, +! IS GOVERNED BY ITERATION LIMIT "IPOL". +! IPOL GREATER THAN 9 ONLY MAKES A DIFFERENCE ON DOUBLE +! PRECISION (RELATIVE ERRORS GIVEN IN PERCENT %). +! IPOL=9, FOR REL.ERROR <~ 1.6 E-6 % (8 SIGNIFICANT DIGITS) +! IPOL=8, FOR REL.ERROR <~ 1.8 E-5 % (7 SIGNIFICANT DIGITS) +! IPOL=7, FOR REL.ERROR <~ 1.8 E-4 % ... +! ---------------------------------------------------------------------- + BFAC = DTHR * C1* EXP (0.08* TAVGC - C2* SNDENS) + IPOL = 4 + PEXP = 0. +! PEXP = (1. + PEXP)*BFAC*ESDC/REAL(J+1) + DO J = IPOL,1, -1 + PEXP = (1. + PEXP)* BFAC * ESDCX / REAL (J +1) + END DO + + PEXP = PEXP + 1. +! ---------------------------------------------------------------------- +! ABOVE LINE ENDS POLYNOMIAL SUBSTITUTION +! ---------------------------------------------------------------------- +! END OF KOREAN FORMULATION + +! BASE FORMULATION (COGLEY ET AL., 1990) +! CONVERT DENSITY FROM G/CM3 TO KG/M3 +! DSM=SNDENS*1000.0 + +! DSX=DSM+DTSEC*0.5*DSM*G*ESD/ +! & (1E7*EXP(-0.02*DSM+KN/(TAVGC+273.16)-14.643)) + +! & CONVERT DENSITY FROM KG/M3 TO G/CM3 +! DSX=DSX/1000.0 + +! END OF COGLEY ET AL. FORMULATION + +! ---------------------------------------------------------------------- +! SET UPPER/LOWER LIMIT ON SNOW DENSITY +! ---------------------------------------------------------------------- + DSX = SNDENS * (PEXP) + IF (DSX > 0.40) DSX = 0.40 + IF (DSX < 0.05) DSX = 0.05 +! ---------------------------------------------------------------------- +! UPDATE OF SNOW DEPTH AND DENSITY DEPENDING ON LIQUID WATER DURING +! SNOWMELT. ASSUMED THAT 13% OF LIQUID WATER CAN BE STORED IN SNOW PER +! DAY DURING SNOWMELT TILL SNOW DENSITY 0.40. +! ---------------------------------------------------------------------- + SNDENS = DSX + IF (TSNOWC >= 0.) THEN + DW = 0.13* DTHR /24. + IF ( UA_PHYS .AND. TSOILC >= 0.) THEN + DW = MIN (DW, 0.13*SNOMLTC/(ESDCX+0.13*SNOMLTC)) + ENDIF + SNDENS = SNDENS * (1. - DW) + DW + IF (SNDENS >= 0.40) SNDENS = 0.40 +! ---------------------------------------------------------------------- +! CALCULATE SNOW DEPTH (CM) FROM SNOW WATER EQUIVALENT AND SNOW DENSITY. +! CHANGE SNOW DEPTH UNITS TO METERS +! ---------------------------------------------------------------------- + END IF + SNOWHC = ESDC / SNDENS + SNOWH = SNOWHC *0.01 + +! ---------------------------------------------------------------------- + END SUBROUTINE SNOWPACK +! ---------------------------------------------------------------------- + + SUBROUTINE SNOWZ0 (SNCOVR,Z0, Z0BRD, SNOWH,FBUR,FGSN,SHDMAX,UA_PHYS) + +! ---------------------------------------------------------------------- +! SUBROUTINE SNOWZ0 +! ---------------------------------------------------------------------- +! CALCULATE TOTAL ROUGHNESS LENGTH OVER SNOW +! SNCOVR FRACTIONAL SNOW COVER +! Z0 ROUGHNESS LENGTH (m) +! Z0S SNOW ROUGHNESS LENGTH:=0.001 (m) +! ---------------------------------------------------------------------- + IMPLICIT NONE + REAL, INTENT(IN) :: SNCOVR, Z0BRD + REAL, INTENT(OUT) :: Z0 + REAL, PARAMETER :: Z0S=0.001 + REAL, INTENT(IN) :: SNOWH + REAL :: BURIAL + REAL :: Z0EFF + LOGICAL, INTENT(IN) :: UA_PHYS ! UA: flag for UA option + REAL, INTENT(IN) :: FBUR ! UA: fraction of canopy buried + REAL, INTENT(IN) :: FGSN ! UA: ground snow cover fraction + REAL, INTENT(IN) :: SHDMAX ! UA: maximum vegetation fraction + REAL, PARAMETER :: Z0G=0.01 ! UA: soil roughness + REAL :: FV,A1,A2 + + IF(UA_PHYS) THEN + + FV = SHDMAX * (1.-FBUR) + A1 = (1.-FV)**2*((1.-FGSN**2)*LOG(Z0G) + (FGSN**2)*LOG(Z0S)) + A2 = (1.-(1.-FV)**2)*LOG(Z0BRD) + Z0 = EXP(A1+A2) + + ELSE + +!m Z0 = (1.- SNCOVR)* Z0BRD + SNCOVR * Z0S + BURIAL = 7.0*Z0BRD - SNOWH + IF(BURIAL.LE.0.0007) THEN + Z0EFF = Z0S + ELSE + Z0EFF = BURIAL/7.0 + ENDIF + + Z0 = (1.- SNCOVR)* Z0BRD + SNCOVR * Z0EFF + + ENDIF +! ---------------------------------------------------------------------- + END SUBROUTINE SNOWZ0 +! ---------------------------------------------------------------------- + + + SUBROUTINE SNOW_NEW (TEMP,NEWSN,SNOWH,SNDENS) + +! ---------------------------------------------------------------------- +! SUBROUTINE SNOW_NEW +! ---------------------------------------------------------------------- +! CALCULATE SNOW DEPTH AND DENSITY TO ACCOUNT FOR THE NEW SNOWFALL. +! NEW VALUES OF SNOW DEPTH & DENSITY RETURNED. + +! TEMP AIR TEMPERATURE (K) +! NEWSN NEW SNOWFALL (M) +! SNOWH SNOW DEPTH (M) +! SNDENS SNOW DENSITY (G/CM3=DIMENSIONLESS FRACTION OF H2O DENSITY) +! ---------------------------------------------------------------------- + IMPLICIT NONE + REAL, INTENT(IN) :: NEWSN, TEMP + REAL, INTENT(INOUT) :: SNDENS, SNOWH + REAL :: DSNEW, HNEWC, SNOWHC,NEWSNC,TEMPC + +! ---------------------------------------------------------------------- +! CONVERSION INTO SIMULATION UNITS +! ---------------------------------------------------------------------- + SNOWHC = SNOWH *100. + NEWSNC = NEWSN *100. + +! ---------------------------------------------------------------------- +! CALCULATING NEW SNOWFALL DENSITY DEPENDING ON TEMPERATURE +! EQUATION FROM GOTTLIB L. 'A GENERAL RUNOFF MODEL FOR SNOWCOVERED +! AND GLACIERIZED BASIN', 6TH NORDIC HYDROLOGICAL CONFERENCE, +! VEMADOLEN, SWEDEN, 1980, 172-177PP. +!----------------------------------------------------------------------- + TEMPC = TEMP -273.15 + IF (TEMPC <= -15.) THEN + DSNEW = 0.05 + ELSE + DSNEW = 0.05+0.0017* (TEMPC +15.)**1.5 + END IF +! ---------------------------------------------------------------------- +! ADJUSTMENT OF SNOW DENSITY DEPENDING ON NEW SNOWFALL +! ---------------------------------------------------------------------- + HNEWC = NEWSNC / DSNEW + IF (SNOWHC + HNEWC .LT. 1.0E-3) THEN + SNDENS = MAX(DSNEW,SNDENS) + ELSE + SNDENS = (SNOWHC * SNDENS + HNEWC * DSNEW)/ (SNOWHC + HNEWC) + ENDIF + SNOWHC = SNOWHC + HNEWC + SNOWH = SNOWHC *0.01 + +! ---------------------------------------------------------------------- + END SUBROUTINE SNOW_NEW +! ---------------------------------------------------------------------- + + SUBROUTINE SRT (RHSTT,EDIR,ET,SH2O,SH2OA,NSOIL,PCPDRP, & + ZSOIL,DWSAT,DKSAT,SMCMAX,BEXP,RUNOFF1, & + RUNOFF2,DT,SMCWLT,SLOPE,KDT,FRZX,SICE,AI,BI,CI, & + SFHEAD1RT,INFXS1RT ) + +! ---------------------------------------------------------------------- +! SUBROUTINE SRT +! ---------------------------------------------------------------------- +! CALCULATE THE RIGHT HAND SIDE OF THE TIME TENDENCY TERM OF THE SOIL +! WATER DIFFUSION EQUATION. ALSO TO COMPUTE ( PREPARE ) THE MATRIX +! COEFFICIENTS FOR THE TRI-DIAGONAL MATRIX OF THE IMPLICIT TIME SCHEME. +! ---------------------------------------------------------------------- + IMPLICIT NONE + INTEGER, INTENT(IN) :: NSOIL + INTEGER :: IALP1, IOHINF, J, JJ, K, KS + +!DJG NDHMS/WRF-Hydro edit... Variables used in OV routing infiltration calcs + REAL, INTENT(INOUT) :: SFHEAD1RT, INFXS1RT + REAL :: SFCWATR,chcksm + + + + REAL, INTENT(IN) :: BEXP, DKSAT, DT, DWSAT, EDIR, FRZX, & + KDT, PCPDRP, SLOPE, SMCMAX, SMCWLT + REAL, INTENT(OUT) :: RUNOFF1, RUNOFF2 + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ET, SH2O, SH2OA, SICE, & + ZSOIL + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: RHSTT + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: AI, BI, CI + REAL, DIMENSION(1:NSOIL) :: DMAX + REAL :: ACRT, DD, DDT, DDZ, DDZ2, DENOM, & + DENOM2,DICE, DSMDZ, DSMDZ2, DT1, & + FCR,INFMAX,MXSMC,MXSMC2,NUMER,PDDUM, & + PX, SICEMAX,SLOPX, SMCAV, SSTT, & + SUM, VAL, WCND, WCND2, WDF, WDF2 + INTEGER, PARAMETER :: CVFRZ = 3 + +! ---------------------------------------------------------------------- +! FROZEN GROUND VERSION: +! REFERENCE FROZEN GROUND PARAMETER, CVFRZ, IS A SHAPE PARAMETER OF +! AREAL DISTRIBUTION FUNCTION OF SOIL ICE CONTENT WHICH EQUALS 1/CV. +! CV IS A COEFFICIENT OF SPATIAL VARIATION OF SOIL ICE CONTENT. BASED +! ON FIELD DATA CV DEPENDS ON AREAL MEAN OF FROZEN DEPTH, AND IT CLOSE +! TO CONSTANT = 0.6 IF AREAL MEAN FROZEN DEPTH IS ABOVE 20 CM. THAT IS +! WHY PARAMETER CVFRZ = 3 (INT{1/0.6*0.6}). +! CURRENT LOGIC DOESN'T ALLOW CVFRZ BE BIGGER THAN 3 +! ---------------------------------------------------------------------- + +! ---------------------------------------------------------------------- +! DETERMINE RAINFALL INFILTRATION RATE AND RUNOFF. INCLUDE THE +! INFILTRATION FORMULE FROM SCHAAKE AND KOREN MODEL. +! MODIFIED BY Q DUAN +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! LET SICEMAX BE THE GREATEST, IF ANY, FROZEN WATER CONTENT WITHIN SOIL +! LAYERS. +! ---------------------------------------------------------------------- + IOHINF = 1 + SICEMAX = 0.0 + DO KS = 1,NSOIL + IF (SICE (KS) > SICEMAX) SICEMAX = SICE (KS) +! ---------------------------------------------------------------------- +! DETERMINE RAINFALL INFILTRATION RATE AND RUNOFF +! ---------------------------------------------------------------------- + END DO + +#ifdef WRF_HYDRO +!DJG NDHMS/WRF-Hydro edit... +!DJG Use previously merged Precip and Sfchead for infil. cap. calc. + SFCWATR = PCPDRP + PDDUM = SFCWATR +!DJG original PDDUM = PCPDRP + RUNOFF1 = 0.0 + INFXS1RT = 0.0 +#else + PDDUM = PCPDRP + RUNOFF1 = 0.0 +#endif + + + +! ---------------------------------------------------------------------- +! MODIFIED BY Q. DUAN, 5/16/94 +! ---------------------------------------------------------------------- +! IF (IOHINF == 1) THEN + +#ifdef WRF_HYDRO +!DJG NDHMS/WRF-Hydro edit... +!DJG IF (PCPDRP /= 0.0) THEN + IF (SFCWATR /= 0.0) THEN +#else + IF (PCPDRP /= 0.0) THEN +#endif + DT1 = DT /86400. + SMCAV = SMCMAX - SMCWLT + +! ---------------------------------------------------------------------- +! FROZEN GROUND VERSION: +! ---------------------------------------------------------------------- + DMAX (1)= - ZSOIL (1)* SMCAV + + DICE = - ZSOIL (1) * SICE (1) + DMAX (1)= DMAX (1)* (1.0- (SH2OA (1) + SICE (1) - SMCWLT)/ & + SMCAV) + + DD = DMAX (1) + +! ---------------------------------------------------------------------- +! FROZEN GROUND VERSION: +! ---------------------------------------------------------------------- + DO KS = 2,NSOIL + + DICE = DICE+ ( ZSOIL (KS -1) - ZSOIL (KS) ) * SICE (KS) + DMAX (KS) = (ZSOIL (KS -1) - ZSOIL (KS))* SMCAV + DMAX (KS) = DMAX (KS)* (1.0- (SH2OA (KS) + SICE (KS) & + - SMCWLT)/ SMCAV) + DD = DD+ DMAX (KS) +! ---------------------------------------------------------------------- +! VAL = (1.-EXP(-KDT*SQRT(DT1))) +! IN BELOW, REMOVE THE SQRT IN ABOVE +! ---------------------------------------------------------------------- + END DO + VAL = (1. - EXP ( - KDT * DT1)) + DDT = DD * VAL +#ifdef WRF_HYDRO +!DJG NDHMS/WRF-Hydro edit... +!DJG PX = PCPDRP * DT + PX = SFCWATR * DT +#else + PX = PCPDRP * DT +#endif + IF (PX < 0.0) PX = 0.0 + + + +! ---------------------------------------------------------------------- +! FROZEN GROUND VERSION: +! REDUCTION OF INFILTRATION BASED ON FROZEN GROUND PARAMETERS +! ---------------------------------------------------------------------- + INFMAX = (PX * (DDT / (PX + DDT)))/ DT + FCR = 1. + IF (DICE > 1.E-2) THEN + ACRT = CVFRZ * FRZX / DICE + SUM = 1. + IALP1 = CVFRZ - 1 + DO J = 1,IALP1 + K = 1 + DO JJ = J +1,IALP1 + K = K * JJ + END DO + SUM = SUM + (ACRT ** ( CVFRZ - J)) / FLOAT (K) + END DO + FCR = 1. - EXP ( - ACRT) * SUM + END IF + +! ---------------------------------------------------------------------- +! CORRECTION OF INFILTRATION LIMITATION: +! IF INFMAX .LE. HYDROLIC CONDUCTIVITY ASSIGN INFMAX THE VALUE OF +! HYDROLIC CONDUCTIVITY +! ---------------------------------------------------------------------- +! MXSMC = MAX ( SH2OA(1), SH2OA(2) ) + INFMAX = INFMAX * FCR + + MXSMC = SH2OA (1) + CALL WDFCND (WDF,WCND,MXSMC,SMCMAX,BEXP,DKSAT,DWSAT, & + SICEMAX) + INFMAX = MAX (INFMAX,WCND) + + INFMAX = MIN (INFMAX,PX/DT) +#ifdef WRF_HYDRO +!DJG NDHMS/WRF-Hydro edit... +!DJG IF (PCPDRP > INFMAX) THEN + IF (SFCWATR > INFMAX) THEN +!DJG RUNOFF1 = PCPDRP - INFMAX + RUNOFF1 = SFCWATR - INFMAX +#else + IF (PCPDRP > INFMAX) THEN + RUNOFF1 = PCPDRP - INFMAX +#endif + INFXS1RT = RUNOFF1*DT*1000. + PDDUM = INFMAX + END IF + +! ---------------------------------------------------------------------- +! TO AVOID SPURIOUS DRAINAGE BEHAVIOR, 'UPSTREAM DIFFERENCING' IN LINE +! BELOW REPLACED WITH NEW APPROACH IN 2ND LINE: +! 'MXSMC = MAX(SH2OA(1), SH2OA(2))' +! ---------------------------------------------------------------------- + END IF + + MXSMC = SH2OA (1) + CALL WDFCND (WDF,WCND,MXSMC,SMCMAX,BEXP,DKSAT,DWSAT, & + SICEMAX) +! ---------------------------------------------------------------------- +! CALC THE MATRIX COEFFICIENTS AI, BI, AND CI FOR THE TOP LAYER +! ---------------------------------------------------------------------- + DDZ = 1. / ( - .5 * ZSOIL (2) ) + AI (1) = 0.0 + BI (1) = WDF * DDZ / ( - ZSOIL (1) ) + +! ---------------------------------------------------------------------- +! CALC RHSTT FOR THE TOP LAYER AFTER CALC'NG THE VERTICAL SOIL MOISTURE +! GRADIENT BTWN THE TOP AND NEXT TO TOP LAYERS. +! ---------------------------------------------------------------------- + CI (1) = - BI (1) + DSMDZ = ( SH2O (1) - SH2O (2) ) / ( - .5 * ZSOIL (2) ) + RHSTT (1) = (WDF * DSMDZ + WCND- PDDUM + EDIR + ET (1))/ ZSOIL (1) + +! ---------------------------------------------------------------------- +! INITIALIZE DDZ2 +! ---------------------------------------------------------------------- + SSTT = WDF * DSMDZ + WCND+ EDIR + ET (1) + +! ---------------------------------------------------------------------- +! LOOP THRU THE REMAINING SOIL LAYERS, REPEATING THE ABV PROCESS +! ---------------------------------------------------------------------- + DDZ2 = 0.0 + DO K = 2,NSOIL + DENOM2 = (ZSOIL (K -1) - ZSOIL (K)) + IF (K /= NSOIL) THEN + +! ---------------------------------------------------------------------- +! AGAIN, TO AVOID SPURIOUS DRAINAGE BEHAVIOR, 'UPSTREAM DIFFERENCING' IN +! LINE BELOW REPLACED WITH NEW APPROACH IN 2ND LINE: +! 'MXSMC2 = MAX (SH2OA(K), SH2OA(K+1))' +! ---------------------------------------------------------------------- + SLOPX = 1. + + MXSMC2 = SH2OA (K) + CALL WDFCND (WDF2,WCND2,MXSMC2,SMCMAX,BEXP,DKSAT,DWSAT, & + SICEMAX) +! ----------------------------------------------------------------------- +! CALC SOME PARTIAL PRODUCTS FOR LATER USE IN CALC'NG RHSTT +! ---------------------------------------------------------------------- + DENOM = (ZSOIL (K -1) - ZSOIL (K +1)) + +! ---------------------------------------------------------------------- +! CALC THE MATRIX COEF, CI, AFTER CALC'NG ITS PARTIAL PRODUCT +! ---------------------------------------------------------------------- + DSMDZ2 = (SH2O (K) - SH2O (K +1)) / (DENOM * 0.5) + DDZ2 = 2.0 / DENOM + CI (K) = - WDF2 * DDZ2 / DENOM2 + + ELSE +! ---------------------------------------------------------------------- +! SLOPE OF BOTTOM LAYER IS INTRODUCED +! ---------------------------------------------------------------------- + +! ---------------------------------------------------------------------- +! RETRIEVE THE SOIL WATER DIFFUSIVITY AND HYDRAULIC CONDUCTIVITY FOR +! THIS LAYER +! ---------------------------------------------------------------------- + SLOPX = SLOPE + CALL WDFCND (WDF2,WCND2,SH2OA (NSOIL),SMCMAX,BEXP,DKSAT,DWSAT, & + SICEMAX) + +! ---------------------------------------------------------------------- +! CALC A PARTIAL PRODUCT FOR LATER USE IN CALC'NG RHSTT +! ---------------------------------------------------------------------- + +! ---------------------------------------------------------------------- +! SET MATRIX COEF CI TO ZERO +! ---------------------------------------------------------------------- + DSMDZ2 = 0.0 + CI (K) = 0.0 +! ---------------------------------------------------------------------- +! CALC RHSTT FOR THIS LAYER AFTER CALC'NG ITS NUMERATOR +! ---------------------------------------------------------------------- + END IF + NUMER = (WDF2 * DSMDZ2) + SLOPX * WCND2- (WDF * DSMDZ) & + - WCND+ ET (K) + +! ---------------------------------------------------------------------- +! CALC MATRIX COEFS, AI, AND BI FOR THIS LAYER +! ---------------------------------------------------------------------- + RHSTT (K) = NUMER / ( - DENOM2) + AI (K) = - WDF * DDZ / DENOM2 + +! ---------------------------------------------------------------------- +! RESET VALUES OF WDF, WCND, DSMDZ, AND DDZ FOR LOOP TO NEXT LYR +! RUNOFF2: SUB-SURFACE OR BASEFLOW RUNOFF +! ---------------------------------------------------------------------- + BI (K) = - ( AI (K) + CI (K) ) + IF (K .eq. NSOIL) THEN + RUNOFF2 = SLOPX * WCND2 + END IF + IF (K .ne. NSOIL) THEN + WDF = WDF2 + WCND = WCND2 + DSMDZ = DSMDZ2 + DDZ = DDZ2 + END IF + END DO +! ---------------------------------------------------------------------- + END SUBROUTINE SRT +! ---------------------------------------------------------------------- + + SUBROUTINE SSTEP (SH2OOUT,SH2OIN,CMC,RHSTT,RHSCT,DT, & + NSOIL,SMCMAX,CMCMAX,RUNOFF3,ZSOIL,SMC,SICE, & + AI,BI,CI, INFXS1RT) + +! ---------------------------------------------------------------------- +! SUBROUTINE SSTEP +! ---------------------------------------------------------------------- +! CALCULATE/UPDATE SOIL MOISTURE CONTENT VALUES AND CANOPY MOISTURE +! CONTENT VALUES. +! ---------------------------------------------------------------------- + IMPLICIT NONE + INTEGER, INTENT(IN) :: NSOIL + INTEGER :: I, K, KK11 + +!!DJG NDHMS/WRF-Hydro edit... + REAL, INTENT(INOUT) :: INFXS1RT + REAL :: AVAIL + + REAL, INTENT(IN) :: CMCMAX, DT, SMCMAX + REAL, INTENT(OUT) :: RUNOFF3 + REAL, INTENT(INOUT) :: CMC + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SH2OIN, SICE, ZSOIL + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: SH2OOUT + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: RHSTT, SMC + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: AI, BI, CI + REAL, DIMENSION(1:NSOIL) :: RHSTTin + REAL, DIMENSION(1:NSOIL) :: CIin + REAL :: DDZ, RHSCT, STOT, WPLUS + +! ---------------------------------------------------------------------- +! CREATE 'AMOUNT' VALUES OF VARIABLES TO BE INPUT TO THE +! TRI-DIAGONAL MATRIX ROUTINE. +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + RHSTT (K) = RHSTT (K) * DT + AI (K) = AI (K) * DT + BI (K) = 1. + BI (K) * DT + CI (K) = CI (K) * DT + END DO +! ---------------------------------------------------------------------- +! COPY VALUES FOR INPUT VARIABLES BEFORE CALL TO ROSR12 +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + RHSTTin (K) = RHSTT (K) + END DO + DO K = 1,NSOIL + CIin (K) = CI (K) + END DO +! ---------------------------------------------------------------------- +! CALL ROSR12 TO SOLVE THE TRI-DIAGONAL MATRIX +! ---------------------------------------------------------------------- + CALL ROSR12 (CI,AI,BI,CIin,RHSTTin,RHSTT,NSOIL) +! ---------------------------------------------------------------------- +! SUM THE PREVIOUS SMC VALUE AND THE MATRIX SOLUTION TO GET A +! NEW VALUE. MIN ALLOWABLE VALUE OF SMC WILL BE 0.02. +! RUNOFF3: RUNOFF WITHIN SOIL LAYERS +! ---------------------------------------------------------------------- + WPLUS = 0.0 + RUNOFF3 = 0. + + DDZ = - ZSOIL (1) + DO K = 1,NSOIL + IF (K /= 1) DDZ = ZSOIL (K - 1) - ZSOIL (K) + SH2OOUT (K) = SH2OIN (K) + CI (K) + WPLUS / DDZ + STOT = SH2OOUT (K) + SICE (K) + IF (STOT > SMCMAX) THEN + IF (K .eq. 1) THEN + DDZ = - ZSOIL (1) + ELSE + KK11 = K - 1 + DDZ = - ZSOIL (K) + ZSOIL (KK11) + END IF + WPLUS = (STOT - SMCMAX) * DDZ + ELSE + WPLUS = 0. + END IF + SMC (K) = MAX ( MIN (STOT,SMCMAX),0.02 ) + SH2OOUT (K) = MAX ( (SMC (K) - SICE (K)),0.0) + END DO +#ifdef WRF_HYDRO +!DJG NDHMS/WRF-Hydro edit... +!DJG Modifications to redstribute WPLUS/RUNOFF3 (soil moisture closure error) to soil profile +!DJG beginning at bottom layer (NSOIL) + IF (WPLUS > 0.) THEN + DO K=NSOIL,2,-1 + + IF (K .eq. 2) THEN !Assign soil depths + DDZ = -ZSOIL(1) + ELSE + DDZ = ZSOIL(K-2)-ZSOIL(K-1) + END IF + + AVAIL = (SMCMAX - SMC(K-1)) * DDZ !Det. Avail. Stor. + +! print *, "ZZZZZ", K,DDZ,AVAIL,WPLUS,SMC(K),SMC(K-1),SMCMAX + + IF (WPLUS <= AVAIL) THEN + SMC(K-1) = SMC(K-1) + WPLUS/DDZ + WPLUS = 0. + ELSE + SMC(K-1) = SMCMAX + WPLUS = WPLUS - AVAIL + IF (K-1 .eq. 1) THEN + INFXS1RT = INFXS1RT + WPLUS*1000 + WPLUS = 0. + END IF + END IF + +! SMC (K) = MAX ( MIN (STOT,SMCMAX),0.02 ) + SH2OOUT (K) = MAX ( (SMC (K) - SICE (K)),0.0) + + END DO + END IF +!DJG NDHMS/WRF-Hydro edit...End of modification +#endif + + +! ---------------------------------------------------------------------- +! UPDATE CANOPY WATER CONTENT/INTERCEPTION (CMC). CONVERT RHSCT TO +! AN 'AMOUNT' VALUE AND ADD TO PREVIOUS CMC VALUE TO GET NEW CMC. +! ---------------------------------------------------------------------- + RUNOFF3 = WPLUS + CMC = CMC + DT * RHSCT + IF (CMC < 1.E-20) CMC = 0.0 + CMC = MIN (CMC,CMCMAX) + +! ---------------------------------------------------------------------- + END SUBROUTINE SSTEP +! ---------------------------------------------------------------------- + + SUBROUTINE TBND (TU,TB,ZSOIL,ZBOT,K,NSOIL,TBND1) + +! ---------------------------------------------------------------------- +! SUBROUTINE TBND +! ---------------------------------------------------------------------- +! CALCULATE TEMPERATURE ON THE BOUNDARY OF THE LAYER BY INTERPOLATION OF +! THE MIDDLE LAYER TEMPERATURES +! ---------------------------------------------------------------------- + IMPLICIT NONE + INTEGER, INTENT(IN) :: NSOIL + INTEGER :: K + REAL, INTENT(IN) :: TB, TU, ZBOT + REAL, INTENT(OUT) :: TBND1 + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ZSOIL + REAL :: ZB, ZUP + REAL, PARAMETER :: T0 = 273.15 + +! ---------------------------------------------------------------------- +! USE SURFACE TEMPERATURE ON THE TOP OF THE FIRST LAYER +! ---------------------------------------------------------------------- + IF (K == 1) THEN + ZUP = 0. + ELSE + ZUP = ZSOIL (K -1) + END IF +! ---------------------------------------------------------------------- +! USE DEPTH OF THE CONSTANT BOTTOM TEMPERATURE WHEN INTERPOLATE +! TEMPERATURE INTO THE LAST LAYER BOUNDARY +! ---------------------------------------------------------------------- + IF (K == NSOIL) THEN + ZB = 2.* ZBOT - ZSOIL (K) + ELSE + ZB = ZSOIL (K +1) + END IF +! ---------------------------------------------------------------------- +! LINEAR INTERPOLATION BETWEEN THE AVERAGE LAYER TEMPERATURES +! ---------------------------------------------------------------------- + + TBND1 = TU + (TB - TU)* (ZUP - ZSOIL (K))/ (ZUP - ZB) +! ---------------------------------------------------------------------- + END SUBROUTINE TBND +! ---------------------------------------------------------------------- + + + SUBROUTINE TDFCND ( DF, SMC, QZ, SMCMAX, SH2O, BEXP, PSISAT, SOILTYP, OPT_THCND) + +! ---------------------------------------------------------------------- +! SUBROUTINE TDFCND +! ---------------------------------------------------------------------- +! CALCULATE THERMAL DIFFUSIVITY AND CONDUCTIVITY OF THE SOIL FOR A GIVEN +! POINT AND TIME. +! ---------------------------------------------------------------------- +! PETERS-LIDARD APPROACH (PETERS-LIDARD et al., 1998) +! June 2001 CHANGES: FROZEN SOIL CONDITION. +! ---------------------------------------------------------------------- + IMPLICIT NONE + INTEGER, INTENT(IN) :: SOILTYP, OPT_THCND + REAL, INTENT(IN) :: QZ, SMC, SMCMAX, SH2O, BEXP, PSISAT + REAL, INTENT(OUT) :: DF + REAL :: AKE, GAMMD, THKDRY, THKICE, THKO, & + THKQTZ,THKSAT,THKS,THKW,SATRATIO,XU, & + XUNFROZ,AKEI,AKEL,PSIF,PF + +! ---------------------------------------------------------------------- +! WE NOW GET QUARTZ AS AN INPUT ARGUMENT (SET IN ROUTINE REDPRM): +! DATA QUARTZ /0.82, 0.10, 0.25, 0.60, 0.52, +! & 0.35, 0.60, 0.40, 0.82/ +! ---------------------------------------------------------------------- +! IF THE SOIL HAS ANY MOISTURE CONTENT COMPUTE A PARTIAL SUM/PRODUCT +! OTHERWISE USE A CONSTANT VALUE WHICH WORKS WELL WITH MOST SOILS +! ---------------------------------------------------------------------- +! THKW ......WATER THERMAL CONDUCTIVITY +! THKQTZ ....THERMAL CONDUCTIVITY FOR QUARTZ +! THKO ......THERMAL CONDUCTIVITY FOR OTHER SOIL COMPONENTS +! THKS ......THERMAL CONDUCTIVITY FOR THE SOLIDS COMBINED(QUARTZ+OTHER) +! THKICE ....ICE THERMAL CONDUCTIVITY +! SMCMAX ....POROSITY (= SMCMAX) +! QZ .........QUARTZ CONTENT (SOIL TYPE DEPENDENT) +! ---------------------------------------------------------------------- +! USE AS IN PETERS-LIDARD, 1998 (MODIF. FROM JOHANSEN, 1975). + +! PABLO GRUNMANN, 08/17/98 +! REFS.: +! FAROUKI, O.T.,1986: THERMAL PROPERTIES OF SOILS. SERIES ON ROCK +! AND SOIL MECHANICS, VOL. 11, TRANS TECH, 136 PP. +! JOHANSEN, O., 1975: THERMAL CONDUCTIVITY OF SOILS. PH.D. THESIS, +! UNIVERSITY OF TRONDHEIM, +! PETERS-LIDARD, C. D., ET AL., 1998: THE EFFECT OF SOIL THERMAL +! CONDUCTIVITY PARAMETERIZATION ON SURFACE ENERGY FLUXES +! AND TEMPERATURES. JOURNAL OF THE ATMOSPHERIC SCIENCES, +! VOL. 55, PP. 1209-1224. +! ---------------------------------------------------------------------- + +IF ( OPT_THCND == 1 .OR. ( OPT_THCND == 2 .AND. (SOILTYP /= 4 .AND. SOILTYP /= 3)) )THEN + +! NEEDS PARAMETERS +! POROSITY(SOIL TYPE): +! POROS = SMCMAX +! SATURATION RATIO: +! PARAMETERS W/(M.K) + SATRATIO = SMC / SMCMAX +! ICE CONDUCTIVITY: + THKICE = 2.2 +! WATER CONDUCTIVITY: + THKW = 0.57 +! THERMAL CONDUCTIVITY OF "OTHER" SOIL COMPONENTS +! IF (QZ .LE. 0.2) THKO = 3.0 + THKO = 2.0 +! QUARTZ' CONDUCTIVITY + THKQTZ = 7.7 +! SOLIDS' CONDUCTIVITY + THKS = (THKQTZ ** QZ)* (THKO ** (1. - QZ)) + +! UNFROZEN FRACTION (FROM 1., i.e., 100%LIQUID, TO 0. (100% FROZEN)) + XUNFROZ = SH2O / SMC +! UNFROZEN VOLUME FOR SATURATION (POROSITY*XUNFROZ) + XU = XUNFROZ * SMCMAX + +! SATURATED THERMAL CONDUCTIVITY + THKSAT = THKS ** (1. - SMCMAX)* THKICE ** (SMCMAX - XU)* THKW ** & + (XU) + +! DRY DENSITY IN KG/M3 + GAMMD = (1. - SMCMAX)*2700. + +! DRY THERMAL CONDUCTIVITY IN W.M-1.K-1 + THKDRY = (0.135* GAMMD+ 64.7)/ (2700. - 0.947* GAMMD) +! FROZEN + AKEI = SATRATIO +! UNFROZEN +! RANGE OF VALIDITY FOR THE KERSTEN NUMBER (AKE) + +! KERSTEN NUMBER (USING "FINE" FORMULA, VALID FOR SOILS CONTAINING AT +! LEAST 5% OF PARTICLES WITH DIAMETER LESS THAN 2.E-6 METERS.) +! (FOR "COARSE" FORMULA, SEE PETERS-LIDARD ET AL., 1998). + + IF ( SATRATIO > 0.1 ) THEN + + AKEL = LOG10 (SATRATIO) + 1.0 + +! USE K = KDRY + ELSE + + AKEL = 0.0 + END IF + AKE = ((SMC-SH2O)*AKEI + SH2O*AKEL)/SMC +! THERMAL CONDUCTIVITY + + + DF = AKE * (THKSAT - THKDRY) + THKDRY + + ELSE + +! use the Mccumber and Pielke approach for silt loam (4), sandy loam (3) + + PSIF = PSISAT*100.*(SMCMAX/(SMC))**BEXP +!--- PSIF should be in [CM] to compute PF + PF=log10(abs(PSIF)) +!--- HK is for McCumber thermal conductivity + IF(PF.LE.5.1) THEN + DF=420.*EXP(-(PF+2.7)) + ELSE + DF=.1744 + END IF + + ENDIF ! for OPT_THCND OPTIONS +! ---------------------------------------------------------------------- + END SUBROUTINE TDFCND +! ---------------------------------------------------------------------- + + SUBROUTINE TMPAVG (TAVG,TUP,TM,TDN,ZSOIL,NSOIL,K) + +! ---------------------------------------------------------------------- +! SUBROUTINE TMPAVG +! ---------------------------------------------------------------------- +! CALCULATE SOIL LAYER AVERAGE TEMPERATURE (TAVG) IN FREEZING/THAWING +! LAYER USING UP, DOWN, AND MIDDLE LAYER TEMPERATURES (TUP, TDN, TM), +! WHERE TUP IS AT TOP BOUNDARY OF LAYER, TDN IS AT BOTTOM BOUNDARY OF +! LAYER. TM IS LAYER PROGNOSTIC STATE TEMPERATURE. +! ---------------------------------------------------------------------- + IMPLICIT NONE + INTEGER K + + INTEGER NSOIL + REAL DZ + REAL DZH + REAL T0 + REAL TAVG + REAL TDN + REAL TM + REAL TUP + REAL X0 + REAL XDN + REAL XUP + + REAL ZSOIL (NSOIL) + +! ---------------------------------------------------------------------- + PARAMETER (T0 = 2.7315E2) + IF (K .eq. 1) THEN + DZ = - ZSOIL (1) + ELSE + DZ = ZSOIL (K -1) - ZSOIL (K) + END IF + + DZH = DZ *0.5 + IF (TUP .lt. T0) THEN + IF (TM .lt. T0) THEN +! ---------------------------------------------------------------------- +! TUP, TM, TDN < T0 +! ---------------------------------------------------------------------- + IF (TDN .lt. T0) THEN + TAVG = (TUP + 2.0* TM + TDN)/ 4.0 +! ---------------------------------------------------------------------- +! TUP & TM < T0, TDN .ge. T0 +! ---------------------------------------------------------------------- + ELSE + X0 = (T0- TM) * DZH / (TDN - TM) + TAVG = 0.5 * (TUP * DZH + TM * (DZH + X0) + T0* ( & + & 2.* DZH - X0)) / DZ + END IF + ELSE +! ---------------------------------------------------------------------- +! TUP < T0, TM .ge. T0, TDN < T0 +! ---------------------------------------------------------------------- + IF (TDN .lt. T0) THEN + XUP = (T0- TUP) * DZH / (TM - TUP) + XDN = DZH - (T0- TM) * DZH / (TDN - TM) + TAVG = 0.5 * (TUP * XUP + T0* (2.* DZ - XUP - XDN) & + & + TDN * XDN) / DZ +! ---------------------------------------------------------------------- +! TUP < T0, TM .ge. T0, TDN .ge. T0 +! ---------------------------------------------------------------------- + ELSE + XUP = (T0- TUP) * DZH / (TM - TUP) + TAVG = 0.5 * (TUP * XUP + T0* (2.* DZ - XUP)) / DZ + END IF + END IF + ELSE + IF (TM .lt. T0) THEN +! ---------------------------------------------------------------------- +! TUP .ge. T0, TM < T0, TDN < T0 +! ---------------------------------------------------------------------- + IF (TDN .lt. T0) THEN + XUP = DZH - (T0- TUP) * DZH / (TM - TUP) + TAVG = 0.5 * (T0* (DZ - XUP) + TM * (DZH + XUP) & + & + TDN * DZH) / DZ +! ---------------------------------------------------------------------- +! TUP .ge. T0, TM < T0, TDN .ge. T0 +! ---------------------------------------------------------------------- + ELSE + XUP = DZH - (T0- TUP) * DZH / (TM - TUP) + XDN = (T0- TM) * DZH / (TDN - TM) + TAVG = 0.5 * (T0* (2.* DZ - XUP - XDN) + TM * & + & (XUP + XDN)) / DZ + END IF + ELSE +! ---------------------------------------------------------------------- +! TUP .ge. T0, TM .ge. T0, TDN < T0 +! ---------------------------------------------------------------------- + IF (TDN .lt. T0) THEN + XDN = DZH - (T0- TM) * DZH / (TDN - TM) + TAVG = (T0* (DZ - XDN) +0.5* (T0+ TDN)* XDN) / DZ +! ---------------------------------------------------------------------- +! TUP .ge. T0, TM .ge. T0, TDN .ge. T0 +! ---------------------------------------------------------------------- + ELSE + TAVG = (TUP + 2.0* TM + TDN) / 4.0 + END IF + END IF + END IF +! ---------------------------------------------------------------------- + END SUBROUTINE TMPAVG +! ---------------------------------------------------------------------- + + SUBROUTINE TRANSP (ET,NSOIL,ETP1,SMC,CMC,ZSOIL,SHDFAC,SMCWLT, & + & CMCMAX,PC,CFACTR,SMCREF,SFCTMP,Q2,NROOT, & + & RTDIS) + +! ---------------------------------------------------------------------- +! SUBROUTINE TRANSP +! ---------------------------------------------------------------------- +! CALCULATE TRANSPIRATION FOR THE VEG CLASS. +! ---------------------------------------------------------------------- + IMPLICIT NONE + INTEGER I + INTEGER K + INTEGER NSOIL + + INTEGER NROOT + REAL CFACTR + REAL CMC + REAL CMCMAX + REAL DENOM + REAL ET (NSOIL) + REAL ETP1 + REAL ETP1A +!.....REAL PART(NSOIL) + REAL GX (NROOT) + REAL PC + REAL Q2 + REAL RTDIS (NSOIL) + REAL RTX + REAL SFCTMP + REAL SGX + REAL SHDFAC + REAL SMC (NSOIL) + REAL SMCREF + REAL SMCWLT + +! ---------------------------------------------------------------------- +! INITIALIZE PLANT TRANSP TO ZERO FOR ALL SOIL LAYERS. +! ---------------------------------------------------------------------- + REAL ZSOIL (NSOIL) + DO K = 1,NSOIL + ET (K) = 0. +! ---------------------------------------------------------------------- +! CALCULATE AN 'ADJUSTED' POTENTIAL TRANSPIRATION +! IF STATEMENT BELOW TO AVOID TANGENT LINEAR PROBLEMS NEAR ZERO +! NOTE: GX AND OTHER TERMS BELOW REDISTRIBUTE TRANSPIRATION BY LAYER, +! ET(K), AS A FUNCTION OF SOIL MOISTURE AVAILABILITY, WHILE PRESERVING +! TOTAL ETP1A. +! ---------------------------------------------------------------------- + END DO + IF (CMC .ne. 0.0) THEN + ETP1A = SHDFAC * PC * ETP1 * (1.0- (CMC / CMCMAX) ** CFACTR) + ELSE + ETP1A = SHDFAC * PC * ETP1 + END IF + SGX = 0.0 + DO I = 1,NROOT + GX (I) = ( SMC (I) - SMCWLT ) / ( SMCREF - SMCWLT ) + GX (I) = MAX ( MIN ( GX (I), 1. ), 0. ) + SGX = SGX + GX (I) + END DO + + SGX = SGX / NROOT + DENOM = 0. + DO I = 1,NROOT + RTX = RTDIS (I) + GX (I) - SGX + GX (I) = GX (I) * MAX ( RTX, 0. ) + DENOM = DENOM + GX (I) + END DO + + IF (DENOM .le. 0.0) DENOM = 1. + DO I = 1,NROOT + ET (I) = ETP1A * GX (I) / DENOM +! ---------------------------------------------------------------------- +! ABOVE CODE ASSUMES A VERTICALLY UNIFORM ROOT DISTRIBUTION +! CODE BELOW TESTS A VARIABLE ROOT DISTRIBUTION +! ---------------------------------------------------------------------- +! ET(1) = ( ZSOIL(1) / ZSOIL(NROOT) ) * GX * ETP1A +! ET(1) = ( ZSOIL(1) / ZSOIL(NROOT) ) * ETP1A +! ---------------------------------------------------------------------- +! USING ROOT DISTRIBUTION AS WEIGHTING FACTOR +! ---------------------------------------------------------------------- +! ET(1) = RTDIS(1) * ETP1A +! ET(1) = ETP1A * PART(1) +! ---------------------------------------------------------------------- +! LOOP DOWN THRU THE SOIL LAYERS REPEATING THE OPERATION ABOVE, +! BUT USING THE THICKNESS OF THE SOIL LAYER (RATHER THAN THE +! ABSOLUTE DEPTH OF EACH LAYER) IN THE FINAL CALCULATION. +! ---------------------------------------------------------------------- +! DO K = 2,NROOT +! GX = ( SMC(K) - SMCWLT ) / ( SMCREF - SMCWLT ) +! GX = MAX ( MIN ( GX, 1. ), 0. ) +! TEST CANOPY RESISTANCE +! GX = 1.0 +! ET(K) = ((ZSOIL(K)-ZSOIL(K-1))/ZSOIL(NROOT))*GX*ETP1A +! ET(K) = ((ZSOIL(K)-ZSOIL(K-1))/ZSOIL(NROOT))*ETP1A +! ---------------------------------------------------------------------- +! USING ROOT DISTRIBUTION AS WEIGHTING FACTOR +! ---------------------------------------------------------------------- +! ET(K) = RTDIS(K) * ETP1A +! ET(K) = ETP1A*PART(K) +! END DO + END DO +! ---------------------------------------------------------------------- + END SUBROUTINE TRANSP +! ---------------------------------------------------------------------- + + SUBROUTINE WDFCND (WDF,WCND,SMC,SMCMAX,BEXP,DKSAT,DWSAT, & + & SICEMAX) + +! ---------------------------------------------------------------------- +! SUBROUTINE WDFCND +! ---------------------------------------------------------------------- +! CALCULATE SOIL WATER DIFFUSIVITY AND SOIL HYDRAULIC CONDUCTIVITY. +! ---------------------------------------------------------------------- + IMPLICIT NONE + REAL BEXP + REAL DKSAT + REAL DWSAT + REAL EXPON + REAL FACTR1 + REAL FACTR2 + REAL SICEMAX + REAL SMC + REAL SMCMAX + REAL VKwgt + REAL WCND + +! ---------------------------------------------------------------------- +! CALC THE RATIO OF THE ACTUAL TO THE MAX PSBL SOIL H2O CONTENT +! ---------------------------------------------------------------------- + REAL WDF + FACTR1 = 0.05 / SMCMAX + +! ---------------------------------------------------------------------- +! PREP AN EXPNTL COEF AND CALC THE SOIL WATER DIFFUSIVITY +! ---------------------------------------------------------------------- + FACTR2 = SMC / SMCMAX + FACTR1 = MIN(FACTR1,FACTR2) + EXPON = BEXP + 2.0 + +! ---------------------------------------------------------------------- +! FROZEN SOIL HYDRAULIC DIFFUSIVITY. VERY SENSITIVE TO THE VERTICAL +! GRADIENT OF UNFROZEN WATER. THE LATTER GRADIENT CAN BECOME VERY +! EXTREME IN FREEZING/THAWING SITUATIONS, AND GIVEN THE RELATIVELY +! FEW AND THICK SOIL LAYERS, THIS GRADIENT SUFFERES SERIOUS +! TRUNCTION ERRORS YIELDING ERRONEOUSLY HIGH VERTICAL TRANSPORTS OF +! UNFROZEN WATER IN BOTH DIRECTIONS FROM HUGE HYDRAULIC DIFFUSIVITY. +! THEREFORE, WE FOUND WE HAD TO ARBITRARILY CONSTRAIN WDF +! -- +! VERSION D_10CM: ........ FACTR1 = 0.2/SMCMAX +! WEIGHTED APPROACH...................... PABLO GRUNMANN, 28_SEP_1999. +! ---------------------------------------------------------------------- + WDF = DWSAT * FACTR2 ** EXPON + IF (SICEMAX .gt. 0.0) THEN + VKWGT = 1./ (1. + (500.* SICEMAX)**3.) + WDF = VKWGT * WDF + (1. - VKWGT)* DWSAT * FACTR1** EXPON +! ---------------------------------------------------------------------- +! RESET THE EXPNTL COEF AND CALC THE HYDRAULIC CONDUCTIVITY +! ---------------------------------------------------------------------- + END IF + EXPON = (2.0 * BEXP) + 3.0 + WCND = DKSAT * FACTR2 ** EXPON + +! ---------------------------------------------------------------------- + END SUBROUTINE WDFCND +! ---------------------------------------------------------------------- + + SUBROUTINE SFCDIF_off (ZLM,Z0,THZ0,THLM,SFCSPD,CZIL,AKMS,AKHS) + +! ---------------------------------------------------------------------- +! SUBROUTINE SFCDIF (renamed SFCDIF_off to avoid clash with Eta PBL) +! ---------------------------------------------------------------------- +! CALCULATE SURFACE LAYER EXCHANGE COEFFICIENTS VIA ITERATIVE PROCESS. +! SEE CHEN ET AL (1997, BLM) +! ---------------------------------------------------------------------- + + IMPLICIT NONE + REAL WWST, WWST2, G, VKRM, EXCM, BETA, BTG, ELFC, WOLD, WNEW + REAL PIHF, EPSU2, EPSUST, EPSIT, EPSA, ZTMIN, ZTMAX, HPBL, & + & SQVISC + REAL RIC, RRIC, FHNEU, RFC, RFAC, ZZ, PSLMU, PSLMS, PSLHU, & + & PSLHS + REAL XX, PSPMU, YY, PSPMS, PSPHU, PSPHS, ZLM, Z0, THZ0, THLM + REAL SFCSPD, CZIL, AKMS, AKHS, ZILFC, ZU, ZT, RDZ, CXCH + REAL DTHV, DU2, BTGH, WSTAR2, USTAR, ZSLU, ZSLT, RLOGU, RLOGT + REAL RLMO, ZETALT, ZETALU, ZETAU, ZETAT, XLU4, XLT4, XU4, XT4 +!CC ......REAL ZTFC + + REAL XLU, XLT, XU, XT, PSMZ, SIMM, PSHZ, SIMH, USTARK, RLMN, & + & RLMA + + INTEGER ITRMX, ILECH, ITR + PARAMETER & + & (WWST = 1.2,WWST2 = WWST * WWST,G = 9.8,VKRM = 0.40, & + & EXCM = 0.001 & + & ,BETA = 1./270.,BTG = BETA * G,ELFC = VKRM * BTG & + & ,WOLD =.15,WNEW = 1. - WOLD,ITRMX = 05, & + & PIHF = 3.14159265/2.) + PARAMETER & + & (EPSU2 = 1.E-4,EPSUST = 0.07,EPSIT = 1.E-4,EPSA = 1.E-8 & + & ,ZTMIN = -5.,ZTMAX = 1.,HPBL = 1000.0 & + & ,SQVISC = 258.2) + PARAMETER & + & (RIC = 0.183,RRIC = 1.0/ RIC,FHNEU = 0.8,RFC = 0.191 & + & ,RFAC = RIC / (FHNEU * RFC * RFC)) + +! ---------------------------------------------------------------------- +! NOTE: THE TWO CODE BLOCKS BELOW DEFINE FUNCTIONS +! ---------------------------------------------------------------------- +! LECH'S SURFACE FUNCTIONS +! ---------------------------------------------------------------------- + PSLMU (ZZ)= -0.96* log (1.0-4.5* ZZ) + PSLMS (ZZ)= ZZ * RRIC -2.076* (1. -1./ (ZZ +1.)) + PSLHU (ZZ)= -0.96* log (1.0-4.5* ZZ) + +! ---------------------------------------------------------------------- +! PAULSON'S SURFACE FUNCTIONS +! ---------------------------------------------------------------------- + PSLHS (ZZ)= ZZ * RFAC -2.076* (1. -1./ (ZZ +1.)) + PSPMU (XX)= -2.* log ( (XX +1.)*0.5) - log ( (XX * XX +1.)*0.5) & + & +2.* ATAN (XX) & + &- PIHF + PSPMS (YY)= 5.* YY + PSPHU (XX)= -2.* log ( (XX * XX +1.)*0.5) + +! ---------------------------------------------------------------------- +! THIS ROUTINE SFCDIF CAN HANDLE BOTH OVER OPEN WATER (SEA, OCEAN) AND +! OVER SOLID SURFACE (LAND, SEA-ICE). +! ---------------------------------------------------------------------- + PSPHS (YY)= 5.* YY + +! ---------------------------------------------------------------------- +! ZTFC: RATIO OF ZOH/ZOM LESS OR EQUAL THAN 1 +! C......ZTFC=0.1 +! CZIL: CONSTANT C IN Zilitinkevich, S. S.1995,:NOTE ABOUT ZT +! ---------------------------------------------------------------------- + ILECH = 0 + +! ---------------------------------------------------------------------- + ZILFC = - CZIL * VKRM * SQVISC +! C.......ZT=Z0*ZTFC + ZU = Z0 + RDZ = 1./ ZLM + CXCH = EXCM * RDZ + DTHV = THLM - THZ0 + +! ---------------------------------------------------------------------- +! BELJARS CORRECTION OF USTAR +! ---------------------------------------------------------------------- + DU2 = MAX (SFCSPD * SFCSPD,EPSU2) +!cc If statements to avoid TANGENT LINEAR problems near zero + BTGH = BTG * HPBL + IF (BTGH * AKHS * DTHV .ne. 0.0) THEN + WSTAR2 = WWST2* ABS (BTGH * AKHS * DTHV)** (2./3.) + ELSE + WSTAR2 = 0.0 + END IF + +! ---------------------------------------------------------------------- +! ZILITINKEVITCH APPROACH FOR ZT +! ---------------------------------------------------------------------- + USTAR = MAX (SQRT (AKMS * SQRT (DU2+ WSTAR2)),EPSUST) + +! ---------------------------------------------------------------------- + ZT = EXP (ZILFC * SQRT (USTAR * Z0))* Z0 + ZSLU = ZLM + ZU +! PRINT*,'ZSLT=',ZSLT +! PRINT*,'ZLM=',ZLM +! PRINT*,'ZT=',ZT + + ZSLT = ZLM + ZT + RLOGU = log (ZSLU / ZU) + + RLOGT = log (ZSLT / ZT) +! PRINT*,'RLMO=',RLMO +! PRINT*,'ELFC=',ELFC +! PRINT*,'AKHS=',AKHS +! PRINT*,'DTHV=',DTHV +! PRINT*,'USTAR=',USTAR + + RLMO = ELFC * AKHS * DTHV / USTAR **3 +! ---------------------------------------------------------------------- +! 1./MONIN-OBUKKHOV LENGTH-SCALE +! ---------------------------------------------------------------------- + DO ITR = 1,ITRMX + ZETALT = MAX (ZSLT * RLMO,ZTMIN) + RLMO = ZETALT / ZSLT + ZETALU = ZSLU * RLMO + ZETAU = ZU * RLMO + + ZETAT = ZT * RLMO + IF (ILECH .eq. 0) THEN + IF (RLMO .lt. 0.)THEN + XLU4 = 1. -16.* ZETALU + XLT4 = 1. -16.* ZETALT + XU4 = 1. -16.* ZETAU + + XT4 = 1. -16.* ZETAT + XLU = SQRT (SQRT (XLU4)) + XLT = SQRT (SQRT (XLT4)) + XU = SQRT (SQRT (XU4)) + + XT = SQRT (SQRT (XT4)) +! PRINT*,'-----------1------------' +! PRINT*,'PSMZ=',PSMZ +! PRINT*,'PSPMU(ZETAU)=',PSPMU(ZETAU) +! PRINT*,'XU=',XU +! PRINT*,'------------------------' + PSMZ = PSPMU (XU) + SIMM = PSPMU (XLU) - PSMZ + RLOGU + PSHZ = PSPHU (XT) + SIMH = PSPHU (XLT) - PSHZ + RLOGT + ELSE + ZETALU = MIN (ZETALU,ZTMAX) + ZETALT = MIN (ZETALT,ZTMAX) +! PRINT*,'-----------2------------' +! PRINT*,'PSMZ=',PSMZ +! PRINT*,'PSPMS(ZETAU)=',PSPMS(ZETAU) +! PRINT*,'ZETAU=',ZETAU +! PRINT*,'------------------------' + PSMZ = PSPMS (ZETAU) + SIMM = PSPMS (ZETALU) - PSMZ + RLOGU + PSHZ = PSPHS (ZETAT) + SIMH = PSPHS (ZETALT) - PSHZ + RLOGT + END IF +! ---------------------------------------------------------------------- +! LECH'S FUNCTIONS +! ---------------------------------------------------------------------- + ELSE + IF (RLMO .lt. 0.)THEN +! PRINT*,'-----------3------------' +! PRINT*,'PSMZ=',PSMZ +! PRINT*,'PSLMU(ZETAU)=',PSLMU(ZETAU) +! PRINT*,'ZETAU=',ZETAU +! PRINT*,'------------------------' + PSMZ = PSLMU (ZETAU) + SIMM = PSLMU (ZETALU) - PSMZ + RLOGU + PSHZ = PSLHU (ZETAT) + SIMH = PSLHU (ZETALT) - PSHZ + RLOGT + ELSE + ZETALU = MIN (ZETALU,ZTMAX) + + ZETALT = MIN (ZETALT,ZTMAX) +! PRINT*,'-----------4------------' +! PRINT*,'PSMZ=',PSMZ +! PRINT*,'PSLMS(ZETAU)=',PSLMS(ZETAU) +! PRINT*,'ZETAU=',ZETAU +! PRINT*,'------------------------' + PSMZ = PSLMS (ZETAU) + SIMM = PSLMS (ZETALU) - PSMZ + RLOGU + PSHZ = PSLHS (ZETAT) + SIMH = PSLHS (ZETALT) - PSHZ + RLOGT + END IF +! ---------------------------------------------------------------------- +! BELJAARS CORRECTION FOR USTAR +! ---------------------------------------------------------------------- + END IF + +! ---------------------------------------------------------------------- +! ZILITINKEVITCH FIX FOR ZT +! ---------------------------------------------------------------------- + USTAR = MAX (SQRT (AKMS * SQRT (DU2+ WSTAR2)),EPSUST) + + ZT = EXP (ZILFC * SQRT (USTAR * Z0))* Z0 + ZSLT = ZLM + ZT +!----------------------------------------------------------------------- + RLOGT = log (ZSLT / ZT) + USTARK = USTAR * VKRM + AKMS = MAX (USTARK / SIMM,CXCH) +!----------------------------------------------------------------------- +! IF STATEMENTS TO AVOID TANGENT LINEAR PROBLEMS NEAR ZERO +!----------------------------------------------------------------------- + AKHS = MAX (USTARK / SIMH,CXCH) + IF (BTGH * AKHS * DTHV .ne. 0.0) THEN + WSTAR2 = WWST2* ABS (BTGH * AKHS * DTHV)** (2./3.) + ELSE + WSTAR2 = 0.0 + END IF +!----------------------------------------------------------------------- + RLMN = ELFC * AKHS * DTHV / USTAR **3 +!----------------------------------------------------------------------- +! IF(ABS((RLMN-RLMO)/RLMA).LT.EPSIT) GO TO 110 +!----------------------------------------------------------------------- + RLMA = RLMO * WOLD+ RLMN * WNEW +!----------------------------------------------------------------------- + RLMO = RLMA +! PRINT*,'----------------------------' +! PRINT*,'SFCDIF OUTPUT ! ! ! ! ! ! ! ! ! ! ! !' + +! PRINT*,'ZLM=',ZLM +! PRINT*,'Z0=',Z0 +! PRINT*,'THZ0=',THZ0 +! PRINT*,'THLM=',THLM +! PRINT*,'SFCSPD=',SFCSPD +! PRINT*,'CZIL=',CZIL +! PRINT*,'AKMS=',AKMS +! PRINT*,'AKHS=',AKHS +! PRINT*,'----------------------------' + + END DO +! ---------------------------------------------------------------------- + END SUBROUTINE SFCDIF_off +! ---------------------------------------------------------------------- + +END MODULE module_sf_noahlsm diff --git a/physics/module_sf_noahlsm_glacial_only.F90 b/physics/module_sf_noahlsm_glacial_only.F90 new file mode 100644 index 000000000..602b21e3b --- /dev/null +++ b/physics/module_sf_noahlsm_glacial_only.F90 @@ -0,0 +1,1285 @@ +MODULE module_sf_noahlsm_glacial_only + + USE module_sf_noahlsm, ONLY : EMISSI_S, ROSR12 + USE module_sf_noahlsm, ONLY : LVCOEF_DATA + + PRIVATE :: ALCALC + PRIVATE :: CSNOW + PRIVATE :: HRTICE + PRIVATE :: HSTEP + PRIVATE :: PENMAN + PRIVATE :: SHFLX + PRIVATE :: SNOPAC + PRIVATE :: SNOWPACK + PRIVATE :: SNOWZ0 + PRIVATE :: SNOW_NEW + + integer, private :: iloc, jloc +!$omp threadprivate(iloc, jloc) + +CONTAINS + + SUBROUTINE SFLX_GLACIAL (IILOC,JJLOC,ISICE,FFROZP,DT,ZLVL,NSOIL,SLDPTH, & !C + & LWDN,SOLNET,SFCPRS,PRCP,SFCTMP,Q2, & !F + & TH2,Q2SAT,DQSDT2, & !I + & ALB, SNOALB,TBOT, Z0BRD, Z0, EMISSI, EMBRD, & !S + & T1,STC,SNOWH,SNEQV,ALBEDO,CH, & !H + & CP, RD, SIGMA, CPH2O, CPICE, LSUBF, & +! ---------------------------------------------------------------------- +! OUTPUTS, DIAGNOSTICS, PARAMETERS BELOW GENERALLY NOT NECESSARY WHEN +! COUPLED WITH E.G. A NWP MODEL (SUCH AS THE NOAA/NWS/NCEP MESOSCALE ETA +! MODEL). OTHER APPLICATIONS MAY REQUIRE DIFFERENT OUTPUT VARIABLES. +! ---------------------------------------------------------------------- + & ETA,SHEAT, ETA_KINEMATIC,FDOWN, & !O + & ESNOW,DEW, & !O + & ETP,SSOIL, & !O + & FLX1,FLX2,FLX3, & !O + & SNOMLT,SNCOVR, & !O + & RUNOFF1, & !O + & Q1, & !D + & SNOTIME1, & + & RIBB,errflg, errmsg) +! ---------------------------------------------------------------------- +! SUB-DRIVER FOR "Noah LSM" FAMILY OF PHYSICS SUBROUTINES FOR A +! SOIL/VEG/SNOWPACK LAND-SURFACE MODEL TO UPDATE ICE TEMPERATURE, SKIN +! TEMPERATURE, SNOWPACK WATER CONTENT, SNOWDEPTH, AND ALL TERMS OF THE +! SURFACE ENERGY BALANCE (EXCLUDING INPUT ATMOSPHERIC FORCINGS OF +! DOWNWARD RADIATION AND PRECIP) +! ---------------------------------------------------------------------- +! SFLX ARGUMENT LIST KEY: +! ---------------------------------------------------------------------- +! C CONFIGURATION INFORMATION +! F FORCING DATA +! I OTHER (INPUT) FORCING DATA +! S SURFACE CHARACTERISTICS +! H HISTORY (STATE) VARIABLES +! O OUTPUT VARIABLES +! D DIAGNOSTIC OUTPUT +! ---------------------------------------------------------------------- +! 1. CONFIGURATION INFORMATION (C): +! ---------------------------------------------------------------------- +! DT TIMESTEP (SEC) (DT SHOULD NOT EXCEED 3600 SECS, RECOMMEND +! 1800 SECS OR LESS) +! ZLVL HEIGHT (M) ABOVE GROUND OF ATMOSPHERIC FORCING VARIABLES +! NSOIL NUMBER OF SOIL LAYERS (AT LEAST 2, AND NOT GREATER THAN +! PARAMETER NSOLD SET BELOW) +! SLDPTH THE THICKNESS OF EACH SOIL LAYER (M) +! ---------------------------------------------------------------------- +! 3. FORCING DATA (F): +! ---------------------------------------------------------------------- +! LWDN LW DOWNWARD RADIATION (W M-2; POSITIVE, NOT NET LONGWAVE) +! SOLNET NET DOWNWARD SOLAR RADIATION ((W M-2; POSITIVE) +! SFCPRS PRESSURE AT HEIGHT ZLVL ABOVE GROUND (PASCALS) +! PRCP PRECIP RATE (KG M-2 S-1) (NOTE, THIS IS A RATE) +! SFCTMP AIR TEMPERATURE (K) AT HEIGHT ZLVL ABOVE GROUND +! TH2 AIR POTENTIAL TEMPERATURE (K) AT HEIGHT ZLVL ABOVE GROUND +! Q2 MIXING RATIO AT HEIGHT ZLVL ABOVE GROUND (KG KG-1) +! FFROZP FRACTION OF FROZEN PRECIPITATION +! ---------------------------------------------------------------------- +! 4. OTHER FORCING (INPUT) DATA (I): +! ---------------------------------------------------------------------- +! Q2SAT SAT SPECIFIC HUMIDITY AT HEIGHT ZLVL ABOVE GROUND (KG KG-1) +! DQSDT2 SLOPE OF SAT SPECIFIC HUMIDITY CURVE AT T=SFCTMP +! (KG KG-1 K-1) +! ---------------------------------------------------------------------- +! 5. CANOPY/SOIL CHARACTERISTICS (S): +! ---------------------------------------------------------------------- +! ALB BACKROUND SNOW-FREE SURFACE ALBEDO (FRACTION), FOR JULIAN +! DAY OF YEAR (USUALLY FROM TEMPORAL INTERPOLATION OF +! MONTHLY MEAN VALUES' CALLING PROG MAY OR MAY NOT +! INCLUDE DIURNAL SUN ANGLE EFFECT) +! SNOALB UPPER BOUND ON MAXIMUM ALBEDO OVER DEEP SNOW (E.G. FROM +! ROBINSON AND KUKLA, 1985, J. CLIM. & APPL. METEOR.) +! TBOT BOTTOM SOIL TEMPERATURE (LOCAL YEARLY-MEAN SFC AIR +! TEMPERATURE) +! Z0BRD Background fixed roughness length (M) +! Z0 Time varying roughness length (M) as function of snow depth +! EMBRD Background surface emissivity (between 0 and 1) +! EMISSI Surface emissivity (between 0 and 1) +! ---------------------------------------------------------------------- +! 6. HISTORY (STATE) VARIABLES (H): +! ---------------------------------------------------------------------- +! T1 GROUND/CANOPY/SNOWPACK) EFFECTIVE SKIN TEMPERATURE (K) +! STC(NSOIL) SOIL TEMP (K) +! SNOWH ACTUAL SNOW DEPTH (M) +! SNEQV LIQUID WATER-EQUIVALENT SNOW DEPTH (M) +! NOTE: SNOW DENSITY = SNEQV/SNOWH +! ALBEDO SURFACE ALBEDO INCLUDING SNOW EFFECT (UNITLESS FRACTION) +! =SNOW-FREE ALBEDO (ALB) WHEN SNEQV=0, OR +! =FCT(MSNOALB,ALB,SHDFAC,SHDMIN) WHEN SNEQV>0 +! CH SURFACE EXCHANGE COEFFICIENT FOR HEAT AND MOISTURE +! (M S-1); NOTE: CH IS TECHNICALLY A CONDUCTANCE SINCE +! IT HAS BEEN MULTIPLIED BY WIND SPEED. +! ---------------------------------------------------------------------- +! 7. OUTPUT (O): +! ---------------------------------------------------------------------- +! OUTPUT VARIABLES NECESSARY FOR A COUPLED NUMERICAL WEATHER PREDICTION +! MODEL, E.G. NOAA/NWS/NCEP MESOSCALE ETA MODEL. FOR THIS APPLICATION, +! THE REMAINING OUTPUT/DIAGNOSTIC/PARAMETER BLOCKS BELOW ARE NOT +! NECESSARY. OTHER APPLICATIONS MAY REQUIRE DIFFERENT OUTPUT VARIABLES. +! ETA ACTUAL LATENT HEAT FLUX (W m-2: NEGATIVE, IF UP FROM +! SURFACE) +! ETA_KINEMATIC atctual latent heat flux in Kg m-2 s-1 +! SHEAT SENSIBLE HEAT FLUX (W M-2: NEGATIVE, IF UPWARD FROM +! SURFACE) +! FDOWN Radiation forcing at the surface (W m-2) = SOLDN*(1-alb)+LWDN +! ---------------------------------------------------------------------- +! ESNOW SUBLIMATION FROM (OR DEPOSITION TO IF <0) SNOWPACK +! (W m-2) +! DEW DEWFALL (OR FROSTFALL FOR T<273.15) (M) +! ---------------------------------------------------------------------- +! ETP POTENTIAL EVAPORATION (W m-2) +! SSOIL SOIL HEAT FLUX (W M-2: NEGATIVE IF DOWNWARD FROM SURFACE) +! ---------------------------------------------------------------------- +! FLX1 PRECIP-SNOW SFC (W M-2) +! FLX2 FREEZING RAIN LATENT HEAT FLUX (W M-2) +! FLX3 PHASE-CHANGE HEAT FLUX FROM SNOWMELT (W M-2) +! ---------------------------------------------------------------------- +! SNOMLT SNOW MELT (M) (WATER EQUIVALENT) +! SNCOVR FRACTIONAL SNOW COVER (UNITLESS FRACTION, 0-1) +! ---------------------------------------------------------------------- +! RUNOFF1 SURFACE RUNOFF (M S-1), NOT INFILTRATING THE SURFACE +! ---------------------------------------------------------------------- +! 8. DIAGNOSTIC OUTPUT (D): +! ---------------------------------------------------------------------- +! Q1 Effective mixing ratio at surface (kg kg-1), used for +! diagnosing the mixing ratio at 2 meter for coupled model +! Documentation for SNOTIME1 and SNOABL2 ????? +! What categories of arguments do these variables fall into ???? +! Documentation for RIBB ????? +! What category of argument does RIBB fall into ????? +! ---------------------------------------------------------------------- + + IMPLICIT NONE +! ---------------------------------------------------------------------- + integer, intent(in) :: iiloc, jjloc + INTEGER, INTENT(IN) :: ISICE +! ---------------------------------------------------------------------- + LOGICAL :: FRZGRA, SNOWNG + +! ---------------------------------------------------------------------- +! 1. CONFIGURATION INFORMATION (C): +! ---------------------------------------------------------------------- + INTEGER, INTENT(IN) :: NSOIL + INTEGER :: KZ + +! ---------------------------------------------------------------------- +! 2. LOGICAL: +! ---------------------------------------------------------------------- + + REAL, INTENT(IN) :: DT,DQSDT2,LWDN,PRCP, & + & Q2,Q2SAT,SFCPRS,SFCTMP, SNOALB, & + & SOLNET,TBOT,TH2,ZLVL,FFROZP + REAL, INTENT(IN) :: CP, RD, SIGMA, CPH2O, CPICE, LSUBF + REAL, INTENT(OUT) :: EMBRD, ALBEDO + REAL, INTENT(INOUT):: CH,SNEQV,SNCOVR,SNOWH,T1,Z0BRD,EMISSI,ALB + REAL, INTENT(INOUT):: SNOTIME1 + REAL, INTENT(INOUT):: RIBB + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SLDPTH + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: STC + REAL, DIMENSION(1:NSOIL) :: ZSOIL + + REAL,INTENT(OUT) :: ETA_KINEMATIC,DEW,ESNOW,ETA, & + & ETP,FLX1,FLX2,FLX3,SHEAT,RUNOFF1, & + & SSOIL,SNOMLT,FDOWN,Q1 + REAL :: DF1,DSOIL,DTOT,FRCSNO,FRCSOI, & + & PRCP1,RCH,RR,RSNOW,SNDENS,SNCOND,SN_NEW, & + & T1V,T24,T2V,TH2V,TSNOW,Z0,PRCPF,RHO + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +! ---------------------------------------------------------------------- +! DECLARATIONS - PARAMETERS +! ---------------------------------------------------------------------- + REAL, PARAMETER :: TFREEZ = 273.15 + REAL, PARAMETER :: LVH2O = 2.501E+6 + REAL, PARAMETER :: LSUBS = 2.83E+6 + REAL, PARAMETER :: R = 287.04 + + errmsg = '' + errflg = 0 + +! ---------------------------------------------------------------------- + iloc = iiloc + jloc = jjloc +! ---------------------------------------------------------------------- + ZSOIL (1) = - SLDPTH (1) + DO KZ = 2,NSOIL + ZSOIL (KZ) = - SLDPTH (KZ) + ZSOIL (KZ -1) + END DO + +! ---------------------------------------------------------------------- +! IF S.W.E. (SNEQV) BELOW THRESHOLD LOWER BOUND (0.10 M FOR GLACIAL +! ICE), THEN SET AT LOWER BOUND +! ---------------------------------------------------------------------- + IF ( SNEQV < 0.10 ) THEN + SNEQV = 0.10 + SNOWH = 0.50 + ENDIF +! ---------------------------------------------------------------------- +! IF INPUT SNOWPACK IS NONZERO, THEN COMPUTE SNOW DENSITY "SNDENS" AND +! SNOW THERMAL CONDUCTIVITY "SNCOND" +! ---------------------------------------------------------------------- + SNDENS = SNEQV / SNOWH + IF(SNDENS > 1.0) THEN + errmsg = 'Physical snow depth is less than snow water equiv.' + errflg = 1 + return + ENDIF + + CALL CSNOW (SNCOND,SNDENS) +! ---------------------------------------------------------------------- +! DETERMINE IF IT'S PRECIPITATING AND WHAT KIND OF PRECIP IT IS. +! IF IT'S PRCPING AND THE AIR TEMP IS COLDER THAN 0 C, IT'S SNOWING! +! IF IT'S PRCPING AND THE AIR TEMP IS WARMER THAN 0 C, BUT THE GRND +! TEMP IS COLDER THAN 0 C, FREEZING RAIN IS PRESUMED TO BE FALLING. +! ---------------------------------------------------------------------- + + SNOWNG = .FALSE. + FRZGRA = .FALSE. + IF (PRCP > 0.0) THEN +! ---------------------------------------------------------------------- +! Snow defined when fraction of frozen precip (FFROZP) > 0.5, +! passed in from model microphysics. +! ---------------------------------------------------------------------- + IF (FFROZP .GT. 0.5) THEN + SNOWNG = .TRUE. + ELSE + IF (T1 <= TFREEZ) FRZGRA = .TRUE. + END IF + END IF +! ---------------------------------------------------------------------- +! IF EITHER PRCP FLAG IS SET, DETERMINE NEW SNOWFALL (CONVERTING PRCP +! RATE FROM KG M-2 S-1 TO A LIQUID EQUIV SNOW DEPTH IN METERS) AND ADD +! IT TO THE EXISTING SNOWPACK. +! NOTE THAT SINCE ALL PRECIP IS ADDED TO SNOWPACK, NO PRECIP INFILTRATES +! INTO THE SOIL SO THAT PRCP1 IS SET TO ZERO. +! ---------------------------------------------------------------------- + IF ( (SNOWNG) .OR. (FRZGRA) ) THEN + SN_NEW = PRCP * DT * 0.001 + SNEQV = SNEQV + SN_NEW + PRCPF = 0.0 + +! ---------------------------------------------------------------------- +! UPDATE SNOW DENSITY BASED ON NEW SNOWFALL, USING OLD AND NEW SNOW. +! UPDATE SNOW THERMAL CONDUCTIVITY +! ---------------------------------------------------------------------- + CALL SNOW_NEW (SFCTMP,SN_NEW,SNOWH,SNDENS) + +! ---------------------------------------------------------------------- +! kmh 09/04/2006 set Snow Density at 0.2 g/cm**3 +! for "cold permanent ice" or new "dry" snow +! if soil temperature less than 268.15 K, treat as typical +! Antarctic/Greenland snow firn +! ---------------------------------------------------------------------- + IF ( SNCOVR .GT. 0.99 ) THEN + IF ( STC(1) .LT. (TFREEZ - 5.) ) SNDENS = 0.2 + IF ( SNOWNG .AND. (T1.LT.273.) .AND. (SFCTMP.LT.273.) ) SNDENS=0.2 + ENDIF + + CALL CSNOW (SNCOND,SNDENS) + +! ---------------------------------------------------------------------- +! PRECIP IS LIQUID (RAIN), HENCE SAVE IN THE PRECIP VARIABLE THAT +! LATER CAN WHOLELY OR PARTIALLY INFILTRATE THE SOIL +! ---------------------------------------------------------------------- + ELSE + PRCPF = PRCP + ENDIF + +! ---------------------------------------------------------------------- +! DETERMINE SNOW FRACTIONAL COVERAGE. +! KWM: Set SNCOVR to 1.0 because SNUP is set small in VEGPARM.TBL, +! and SNEQV is at least 0.1 (as set above) +! ---------------------------------------------------------------------- + SNCOVR = 1.0 + +! ---------------------------------------------------------------------- +! DETERMINE SURFACE ALBEDO MODIFICATION DUE TO SNOWDEPTH STATE. +! ---------------------------------------------------------------------- + + CALL ALCALC (ALB,SNOALB,EMBRD,T1,ALBEDO,EMISSI, & + & DT,SNOWNG,SNOTIME1) + +! ---------------------------------------------------------------------- +! THERMAL CONDUCTIVITY +! ---------------------------------------------------------------------- + DF1 = SNCOND + + DSOIL = - (0.5 * ZSOIL (1)) + DTOT = SNOWH + DSOIL + FRCSNO = SNOWH / DTOT + +! 1. HARMONIC MEAN (SERIES FLOW) +! DF1 = (SNCOND*DF1)/(FRCSOI*SNCOND+FRCSNO*DF1) + FRCSOI = DSOIL / DTOT + +! 3. GEOMETRIC MEAN (INTERMEDIATE BETWEEN HARMONIC AND ARITHMETIC MEAN) +! DF1 = (SNCOND**FRCSNO)*(DF1**FRCSOI) + DF1 = FRCSNO * SNCOND + FRCSOI * DF1 + +! ---------------------------------------------------------------------- +! CALCULATE SUBSURFACE HEAT FLUX, SSOIL, FROM FINAL THERMAL DIFFUSIVITY +! OF SURFACE MEDIUMS, DF1 ABOVE, AND SKIN TEMPERATURE AND TOP +! MID-LAYER SOIL TEMPERATURE +! ---------------------------------------------------------------------- + IF ( DTOT .GT. 2.*DSOIL ) then + DTOT = 2.*DSOIL + ENDIF + SSOIL = DF1 * ( T1 - STC(1) ) / DTOT + +! ---------------------------------------------------------------------- +! DETERMINE SURFACE ROUGHNESS OVER SNOWPACK USING SNOW CONDITION FROM +! THE PREVIOUS TIMESTEP. +! ---------------------------------------------------------------------- + + CALL SNOWZ0 (Z0,Z0BRD,SNOWH) + +! ---------------------------------------------------------------------- +! CALCULATE TOTAL DOWNWARD RADIATION (SOLAR PLUS LONGWAVE) NEEDED IN +! PENMAN EP SUBROUTINE THAT FOLLOWS +! ---------------------------------------------------------------------- + + FDOWN = SOLNET + LWDN + +! ---------------------------------------------------------------------- +! CALC VIRTUAL TEMPS AND VIRTUAL POTENTIAL TEMPS NEEDED BY SUBROUTINES +! PENMAN. +! ---------------------------------------------------------------------- + + T2V = SFCTMP * (1.0+ 0.61 * Q2 ) + RHO = SFCPRS / (RD * T2V) + RCH = RHO * 1004.6 * CH + T24 = SFCTMP * SFCTMP * SFCTMP * SFCTMP + +! ---------------------------------------------------------------------- +! CALL PENMAN SUBROUTINE TO CALCULATE POTENTIAL EVAPORATION (ETP), AND +! OTHER PARTIAL PRODUCTS AND SUMS SAVE IN COMMON/RITE FOR LATER +! CALCULATIONS. +! ---------------------------------------------------------------------- + + ! PENMAN returns ETP, FLX2, and RR + CALL PENMAN (SFCTMP,SFCPRS,CH,TH2,PRCP,FDOWN,T24,SSOIL, & + & Q2,Q2SAT,ETP,RCH,RR,SNOWNG,FRZGRA, & + & DQSDT2,FLX2,EMISSI,T1,SIGMA,CPH2O,CPICE,LSUBF) + + CALL SNOPAC (ETP,ETA,PRCP,PRCPF,SNOWNG,NSOIL,DT,DF1, & + & Q2,T1,SFCTMP,T24,TH2,FDOWN,SSOIL,STC, & + & SFCPRS,RCH,RR,SNEQV,SNDENS,SNOWH,ZSOIL,TBOT, & + & SNOMLT,DEW,FLX1,FLX2,FLX3,ESNOW,EMISSI,RIBB, & + & SIGMA,CPH2O,CPICE,LSUBF) + +! ETA_KINEMATIC = ESNOW + ETA_KINEMATIC = ETP + +! ---------------------------------------------------------------------- +! Effective mixing ratio at grnd level (skin) +! ---------------------------------------------------------------------- + Q1=Q2+ETA_KINEMATIC*CP/RCH + +! ---------------------------------------------------------------------- +! DETERMINE SENSIBLE HEAT (H) IN ENERGY UNITS (W M-2) +! ---------------------------------------------------------------------- + SHEAT = - (CH * CP * SFCPRS)/ (R * T2V) * ( TH2- T1 ) + +! ---------------------------------------------------------------------- +! CONVERT EVAP TERMS FROM KINEMATIC (KG M-2 S-1) TO ENERGY UNITS (W M-2) +! ---------------------------------------------------------------------- + ESNOW = ESNOW * LSUBS + ETP = ETP * LSUBS + IF (ETP .GT. 0.) THEN + ETA = ESNOW + ELSE + ETA = ETP + ENDIF + +! ---------------------------------------------------------------------- +! CONVERT THE SIGN OF SOIL HEAT FLUX SO THAT: +! SSOIL>0: WARM THE SURFACE (NIGHT TIME) +! SSOIL<0: COOL THE SURFACE (DAY TIME) +! ---------------------------------------------------------------------- + SSOIL = -1.0* SSOIL + +! ---------------------------------------------------------------------- +! FOR THE CASE OF GLACIAL-ICE, ADD ANY SNOWMELT DIRECTLY TO SURFACE +! RUNOFF (RUNOFF1) SINCE THERE IS NO SOIL MEDIUM +! ---------------------------------------------------------------------- + RUNOFF1 = SNOMLT / DT + +! ---------------------------------------------------------------------- + END SUBROUTINE SFLX_GLACIAL +! ---------------------------------------------------------------------- + + SUBROUTINE ALCALC (ALB,SNOALB,EMBRD,TSNOW,ALBEDO,EMISSI, & + & DT,SNOWNG,SNOTIME1) + +! ---------------------------------------------------------------------- +! CALCULATE ALBEDO INCLUDING SNOW EFFECT (0 -> 1) +! ALB SNOWFREE ALBEDO +! SNOALB MAXIMUM (DEEP) SNOW ALBEDO +! ALBEDO SURFACE ALBEDO INCLUDING SNOW EFFECT +! TSNOW SNOW SURFACE TEMPERATURE (K) +! ---------------------------------------------------------------------- + IMPLICIT NONE + +! ---------------------------------------------------------------------- +! SNOALB IS ARGUMENT REPRESENTING MAXIMUM ALBEDO OVER DEEP SNOW, +! AS PASSED INTO SFLX, AND ADAPTED FROM THE SATELLITE-BASED MAXIMUM +! SNOW ALBEDO FIELDS PROVIDED BY D. ROBINSON AND G. KUKLA +! (1985, JCAM, VOL 24, 402-411) +! ---------------------------------------------------------------------- + REAL, INTENT(IN) :: ALB, SNOALB, EMBRD, TSNOW + REAL, INTENT(IN) :: DT + LOGICAL, INTENT(IN) :: SNOWNG + REAL, INTENT(INOUT) :: SNOTIME1 + REAL, INTENT(OUT) :: ALBEDO, EMISSI + REAL :: SNOALB2 + REAL :: TM,SNOALB1 + REAL, PARAMETER :: SNACCA=0.94,SNACCB=0.58,SNTHWA=0.82,SNTHWB=0.46 +! turn off vegetation effect +! ALBEDO = ALB + (1.0- (SHDFAC - SHDMIN))* SNCOVR * (SNOALB - ALB) +! ALBEDO = (1.0-SNCOVR)*ALB + SNCOVR*SNOALB !this is equivalent to below + ALBEDO = ALB + (SNOALB-ALB) + EMISSI = EMBRD + (EMISSI_S - EMBRD) + +! BASE FORMULATION (DICKINSON ET AL., 1986, COGLEY ET AL., 1990) +! IF (TSNOW.LE.263.16) THEN +! ALBEDO=SNOALB +! ELSE +! IF (TSNOW.LT.273.16) THEN +! TM=0.1*(TSNOW-263.16) +! SNOALB1=0.5*((0.9-0.2*(TM**3))+(0.8-0.16*(TM**3))) +! ELSE +! SNOALB1=0.67 +! IF(SNCOVR.GT.0.95) SNOALB1= 0.6 +! SNOALB1 = ALB + SNCOVR*(SNOALB-ALB) +! ENDIF +! ENDIF +! ALBEDO = ALB + SNCOVR*(SNOALB1-ALB) + +! ISBA FORMULATION (VERSEGHY, 1991; BAKER ET AL., 1990) +! SNOALB1 = SNOALB+COEF*(0.85-SNOALB) +! SNOALB2=SNOALB1 +!!m LSTSNW=LSTSNW+1 +! SNOTIME1 = SNOTIME1 + DT +! IF (SNOWNG) THEN +! SNOALB2=SNOALB +!!m LSTSNW=0 +! SNOTIME1 = 0.0 +! ELSE +! IF (TSNOW.LT.273.16) THEN +!! SNOALB2=SNOALB-0.008*LSTSNW*DT/86400 +!!m SNOALB2=SNOALB-0.008*SNOTIME1/86400 +! SNOALB2=(SNOALB2-0.65)*EXP(-0.05*DT/3600)+0.65 +!! SNOALB2=(ALBEDO-0.65)*EXP(-0.01*DT/3600)+0.65 +! ELSE +! SNOALB2=(SNOALB2-0.5)*EXP(-0.0005*DT/3600)+0.5 +!! SNOALB2=(SNOALB-0.5)*EXP(-0.24*LSTSNW*DT/86400)+0.5 +!!m SNOALB2=(SNOALB-0.5)*EXP(-0.24*SNOTIME1/86400)+0.5 +! ENDIF +! ENDIF +! +!! print*,'SNOALB2',SNOALB2,'ALBEDO',ALBEDO,'DT',DT +! ALBEDO = ALB + SNCOVR*(SNOALB2-ALB) +! IF (ALBEDO .GT. SNOALB2) ALBEDO=SNOALB2 +!!m LSTSNW1=LSTSNW +!! SNOTIME = SNOTIME1 + +! formulation by Livneh +! ---------------------------------------------------------------------- +! SNOALB IS CONSIDERED AS THE MAXIMUM SNOW ALBEDO FOR NEW SNOW, AT +! A VALUE OF 85%. SNOW ALBEDO CURVE DEFAULTS ARE FROM BRAS P.263. SHOULD +! NOT BE CHANGED EXCEPT FOR SERIOUS PROBLEMS WITH SNOW MELT. +! TO IMPLEMENT ACCUMULATIN PARAMETERS, SNACCA AND SNACCB, ASSERT THAT IT +! IS INDEED ACCUMULATION SEASON. I.E. THAT SNOW SURFACE TEMP IS BELOW +! ZERO AND THE DATE FALLS BETWEEN OCTOBER AND FEBRUARY +! ---------------------------------------------------------------------- + SNOALB1 = SNOALB+LVCOEF_DATA*(0.85-SNOALB) + SNOALB2=SNOALB1 +! ---------------- Initial LSTSNW -------------------------------------- + IF (SNOWNG) THEN + SNOTIME1 = 0. + ELSE + SNOTIME1=SNOTIME1+DT +! IF (TSNOW.LT.273.16) THEN + SNOALB2=SNOALB1*(SNACCA**((SNOTIME1/86400.0)**SNACCB)) +! ELSE +! SNOALB2 =SNOALB1*(SNTHWA**((SNOTIME1/86400.0)**SNTHWB)) +! ENDIF + ENDIF + + SNOALB2 = MAX ( SNOALB2, ALB ) + ALBEDO = ALB + (SNOALB2-ALB) + IF (ALBEDO .GT. SNOALB2) ALBEDO=SNOALB2 + +! IF (TSNOW.LT.273.16) THEN +! ALBEDO=SNOALB-0.008*DT/86400 +! ELSE +! ALBEDO=(SNOALB-0.5)*EXP(-0.24*DT/86400)+0.5 +! ENDIF + +! IF (ALBEDO > SNOALB) ALBEDO = SNOALB + +! ---------------------------------------------------------------------- + END SUBROUTINE ALCALC +! ---------------------------------------------------------------------- + + SUBROUTINE CSNOW (SNCOND,DSNOW) + +! ---------------------------------------------------------------------- +! CALCULATE SNOW TERMAL CONDUCTIVITY +! ---------------------------------------------------------------------- + IMPLICIT NONE + REAL, INTENT(IN) :: DSNOW + REAL, INTENT(OUT) :: SNCOND + REAL :: C + REAL, PARAMETER :: UNIT = 0.11631 + +! ---------------------------------------------------------------------- +! SNCOND IN UNITS OF CAL/(CM*HR*C), RETURNED IN W/(M*C) +! CSNOW IN UNITS OF CAL/(CM*HR*C), RETURNED IN W/(M*C) +! BASIC VERSION IS DYACHKOVA EQUATION (1960), FOR RANGE 0.1-0.4 +! ---------------------------------------------------------------------- + C = 0.328*10** (2.25* DSNOW) +! CSNOW=UNIT*C + +! ---------------------------------------------------------------------- +! DE VAUX EQUATION (1933), IN RANGE 0.1-0.6 +! ---------------------------------------------------------------------- +! SNCOND=0.0293*(1.+100.*DSNOW**2) +! CSNOW=0.0293*(1.+100.*DSNOW**2) + +! ---------------------------------------------------------------------- +! E. ANDERSEN FROM FLERCHINGER +! ---------------------------------------------------------------------- +! SNCOND=0.021+2.51*DSNOW**2 +! CSNOW=0.021+2.51*DSNOW**2 + +! SNCOND = UNIT * C +! double snow thermal conductivity + SNCOND = 2.0 * UNIT * C + +! ---------------------------------------------------------------------- + END SUBROUTINE CSNOW +! ---------------------------------------------------------------------- + + SUBROUTINE HRTICE (RHSTS,STC,TBOT,NSOIL,ZSOIL,YY,ZZ1,DF1,AI,BI,CI) + +! ---------------------------------------------------------------------- +! CALCULATE THE RIGHT HAND SIDE OF THE TIME TENDENCY TERM OF THE SOIL +! THERMAL DIFFUSION EQUATION IN THE CASE OF SEA-ICE (ICE=1) OR GLACIAL +! ICE (ICE=-1). COMPUTE (PREPARE) THE MATRIX COEFFICIENTS FOR THE +! TRI-DIAGONAL MATRIX OF THE IMPLICIT TIME SCHEME. +! +! (NOTE: THIS SUBROUTINE ONLY CALLED FOR SEA-ICE OR GLACIAL ICE, BUT +! NOT FOR NON-GLACIAL LAND (ICE = 0). +! ---------------------------------------------------------------------- + IMPLICIT NONE + + + INTEGER, INTENT(IN) :: NSOIL + REAL, INTENT(IN) :: DF1,YY,ZZ1 + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: AI, BI,CI + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: STC, ZSOIL + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: RHSTS + REAL, INTENT(IN) :: TBOT + INTEGER :: K + REAL :: DDZ,DDZ2,DENOM,DTSDZ,DTSDZ2,SSOIL,HCPCT + REAL :: DF1K,DF1N + REAL :: ZMD + REAL, PARAMETER :: ZBOT = -25.0 + +! ---------------------------------------------------------------------- +! SET A NOMINAL UNIVERSAL VALUE OF GLACIAL-ICE SPECIFIC HEAT CAPACITY, +! HCPCT = 2100.0*900.0 = 1.89000E+6 (SOURCE: BOB GRUMBINE, 2005) +! TBOT PASSED IN AS ARGUMENT, VALUE FROM GLOBAL DATA SET + ! + ! A least-squares fit for the four points provided by + ! Keith Hines for the Yen (1981) values for Antarctic + ! snow firn. + ! + HCPCT = 1.E6 * (0.8194 - 0.1309*0.5*ZSOIL(1)) + DF1K = DF1 + +! ---------------------------------------------------------------------- +! THE INPUT ARGUMENT DF1 IS A UNIVERSALLY CONSTANT VALUE OF SEA-ICE +! THERMAL DIFFUSIVITY, SET IN ROUTINE SNOPAC AS DF1 = 2.2. +! ---------------------------------------------------------------------- +! SET ICE PACK DEPTH. USE TBOT AS ICE PACK LOWER BOUNDARY TEMPERATURE +! (THAT OF UNFROZEN SEA WATER AT BOTTOM OF SEA ICE PACK). ASSUME ICE +! PACK IS OF N=NSOIL LAYERS SPANNING A UNIFORM CONSTANT ICE PACK +! THICKNESS AS DEFINED BY ZSOIL(NSOIL) IN ROUTINE SFLX. +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! CALC THE MATRIX COEFFICIENTS AI, BI, AND CI FOR THE TOP LAYER +! ---------------------------------------------------------------------- + DDZ = 1.0 / ( -0.5 * ZSOIL (2) ) + AI (1) = 0.0 + CI (1) = (DF1 * DDZ) / (ZSOIL (1) * HCPCT) + +! ---------------------------------------------------------------------- +! CALC THE VERTICAL SOIL TEMP GRADIENT BTWN THE TOP AND 2ND SOIL LAYERS. +! RECALC/ADJUST THE SOIL HEAT FLUX. USE THE GRADIENT AND FLUX TO CALC +! RHSTS FOR THE TOP SOIL LAYER. +! ---------------------------------------------------------------------- + BI (1) = - CI (1) + DF1/ (0.5 * ZSOIL (1) * ZSOIL (1) * HCPCT * & + & ZZ1) + DTSDZ = ( STC (1) - STC (2) ) / ( -0.5 * ZSOIL (2) ) + SSOIL = DF1 * ( STC (1) - YY ) / ( 0.5 * ZSOIL (1) * ZZ1 ) + +! ---------------------------------------------------------------------- +! INITIALIZE DDZ2 +! ---------------------------------------------------------------------- + RHSTS (1) = ( DF1 * DTSDZ - SSOIL ) / ( ZSOIL (1) * HCPCT ) + +! ---------------------------------------------------------------------- +! LOOP THRU THE REMAINING SOIL LAYERS, REPEATING THE ABOVE PROCESS +! ---------------------------------------------------------------------- + DDZ2 = 0.0 + DF1K = DF1 + DF1N = DF1 + DO K = 2,NSOIL + + ZMD = 0.5 * (ZSOIL(K)+ZSOIL(K-1)) + ! For the land-ice case +! kmh 09/03/2006 use Yen (1981)'s values for Antarctic snow firn +! IF ( K .eq. 2 ) HCPCT = 0.855108E6 +! IF ( K .eq. 3 ) HCPCT = 0.922906E6 +! IF ( K .eq. 4 ) HCPCT = 1.009986E6 + + ! Least squares fit to the four points supplied by Keith Hines + ! from Yen (1981) for Antarctic snow firn. Not optimal, but + ! probably better than just a constant. + HCPCT = 1.E6 * ( 0.8194 - 0.1309*ZMD ) + +! IF ( K .eq. 2 ) DF1N = 0.345356 +! IF ( K .eq. 3 ) DF1N = 0.398777 +! IF ( K .eq. 4 ) DF1N = 0.472653 + + ! Least squares fit to the three points supplied by Keith Hines + ! from Yen (1981) for Antarctic snow firn. Not optimal, but + ! probably better than just a constant. + DF1N = 0.32333 - ( 0.10073 * ZMD ) +! ---------------------------------------------------------------------- +! CALC THE VERTICAL SOIL TEMP GRADIENT THRU THIS LAYER. +! ---------------------------------------------------------------------- + IF (K /= NSOIL) THEN + DENOM = 0.5 * ( ZSOIL (K -1) - ZSOIL (K +1) ) + +! ---------------------------------------------------------------------- +! CALC THE MATRIX COEF, CI, AFTER CALC'NG ITS PARTIAL PRODUCT. +! ---------------------------------------------------------------------- + DTSDZ2 = ( STC (K) - STC (K +1) ) / DENOM + DDZ2 = 2. / (ZSOIL (K -1) - ZSOIL (K +1)) + CI (K) = - DF1N * DDZ2 / ( (ZSOIL (K -1) - ZSOIL (K))*HCPCT) + +! ---------------------------------------------------------------------- +! CALC THE VERTICAL SOIL TEMP GRADIENT THRU THE LOWEST LAYER. +! ---------------------------------------------------------------------- + ELSE + +! ---------------------------------------------------------------------- +! SET MATRIX COEF, CI TO ZERO. +! ---------------------------------------------------------------------- + DTSDZ2 = (STC (K) - TBOT)/ (.5 * (ZSOIL (K -1) + ZSOIL (K)) & + & - ZBOT) + CI (K) = 0. +! ---------------------------------------------------------------------- +! CALC RHSTS FOR THIS LAYER AFTER CALC'NG A PARTIAL PRODUCT. +! ---------------------------------------------------------------------- + END IF + DENOM = ( ZSOIL (K) - ZSOIL (K -1) ) * HCPCT + +! ---------------------------------------------------------------------- +! CALC MATRIX COEFS, AI, AND BI FOR THIS LAYER. +! ---------------------------------------------------------------------- + RHSTS (K) = ( DF1N * DTSDZ2- DF1K * DTSDZ ) / DENOM + AI (K) = - DF1K * DDZ / ( (ZSOIL (K -1) - ZSOIL (K)) * HCPCT) + +! ---------------------------------------------------------------------- +! RESET VALUES OF DTSDZ AND DDZ FOR LOOP TO NEXT SOIL LYR. +! ---------------------------------------------------------------------- + BI (K) = - (AI (K) + CI (K)) + DF1K = DF1N + DTSDZ = DTSDZ2 + DDZ = DDZ2 + END DO +! ---------------------------------------------------------------------- + END SUBROUTINE HRTICE +! ---------------------------------------------------------------------- + + SUBROUTINE HSTEP (STCOUT,STCIN,RHSTS,DT,NSOIL,AI,BI,CI) + +! ---------------------------------------------------------------------- +! CALCULATE/UPDATE THE SOIL TEMPERATURE FIELD. +! ---------------------------------------------------------------------- + IMPLICIT NONE + INTEGER, INTENT(IN) :: NSOIL + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: STCIN + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: STCOUT + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: RHSTS + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: AI,BI,CI + REAL, DIMENSION(1:NSOIL) :: RHSTSin + REAL, DIMENSION(1:NSOIL) :: CIin + REAL :: DT + INTEGER :: K + +! ---------------------------------------------------------------------- +! CREATE FINITE DIFFERENCE VALUES FOR USE IN ROSR12 ROUTINE +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + RHSTS (K) = RHSTS (K) * DT + AI (K) = AI (K) * DT + BI (K) = 1. + BI (K) * DT + CI (K) = CI (K) * DT + END DO +! ---------------------------------------------------------------------- +! COPY VALUES FOR INPUT VARIABLES BEFORE CALL TO ROSR12 +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + RHSTSin (K) = RHSTS (K) + END DO + DO K = 1,NSOIL + CIin (K) = CI (K) + END DO +! ---------------------------------------------------------------------- +! SOLVE THE TRI-DIAGONAL MATRIX EQUATION +! ---------------------------------------------------------------------- + CALL ROSR12 (CI,AI,BI,CIin,RHSTSin,RHSTS,NSOIL) +! ---------------------------------------------------------------------- +! CALC/UPDATE THE SOIL TEMPS USING MATRIX SOLUTION +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + STCOUT (K) = STCIN (K) + CI (K) + END DO +! ---------------------------------------------------------------------- + END SUBROUTINE HSTEP +! ---------------------------------------------------------------------- + + SUBROUTINE PENMAN (SFCTMP,SFCPRS,CH,TH2,PRCP,FDOWN,T24,SSOIL, & + & Q2,Q2SAT,ETP,RCH,RR,SNOWNG,FRZGRA, & + & DQSDT2,FLX2,EMISSI,T1,SIGMA,CPH2O,CPICE,LSUBF) + +! ---------------------------------------------------------------------- +! CALCULATE POTENTIAL EVAPORATION FOR THE CURRENT POINT. VARIOUS +! PARTIAL SUMS/PRODUCTS ARE ALSO CALCULATED AND PASSED BACK TO THE +! CALLING ROUTINE FOR LATER USE. +! ---------------------------------------------------------------------- + IMPLICIT NONE + LOGICAL, INTENT(IN) :: SNOWNG, FRZGRA + REAL, INTENT(IN) :: CH, DQSDT2,FDOWN,PRCP,Q2,Q2SAT,SSOIL,SFCPRS, & + & SFCTMP,TH2,EMISSI,T1,RCH,T24 + REAL, INTENT(IN) :: SIGMA, CPH2O, CPICE, LSUBF + REAL, INTENT(OUT) :: ETP,FLX2,RR + + REAL :: A, DELTA, FNET,RAD,ELCP1,LVS,EPSCA + + REAL, PARAMETER :: ELCP = 2.4888E+3, LSUBC = 2.501000E+6 + REAL, PARAMETER :: LSUBS = 2.83E+6 + +! ---------------------------------------------------------------------- +! PREPARE PARTIAL QUANTITIES FOR PENMAN EQUATION. +! ---------------------------------------------------------------------- + IF ( T1 > 273.15 ) THEN + ELCP1 = ELCP + LVS = LSUBC + ELSE + ELCP1 = ELCP*LSUBS/LSUBC + LVS = LSUBS + ENDIF + DELTA = ELCP1 * DQSDT2 + A = ELCP1 * (Q2SAT - Q2) + RR = EMISSI*T24 * 6.48E-8 / (SFCPRS * CH) + 1.0 + +! ---------------------------------------------------------------------- +! ADJUST THE PARTIAL SUMS / PRODUCTS WITH THE LATENT HEAT +! EFFECTS CAUSED BY FALLING PRECIPITATION. +! ---------------------------------------------------------------------- + IF (.NOT. SNOWNG) THEN + IF (PRCP > 0.0) RR = RR + CPH2O * PRCP / RCH + ELSE + RR = RR + CPICE * PRCP / RCH + END IF + +! ---------------------------------------------------------------------- +! INCLUDE THE LATENT HEAT EFFECTS OF FREEZING RAIN CONVERTING TO ICE ON +! IMPACT IN THE CALCULATION OF FLX2 AND FNET. +! ---------------------------------------------------------------------- + IF (FRZGRA) THEN + FLX2 = - LSUBF * PRCP + ELSE + FLX2 = 0.0 + ENDIF + FNET = FDOWN - ( EMISSI * SIGMA * T24 ) - SSOIL - FLX2 + +! ---------------------------------------------------------------------- +! FINISH PENMAN EQUATION CALCULATIONS. +! ---------------------------------------------------------------------- + RAD = FNET / RCH + TH2 - SFCTMP + EPSCA = (A * RR + RAD * DELTA) / (DELTA + RR) + ETP = EPSCA * RCH / LVS + +! ---------------------------------------------------------------------- + END SUBROUTINE PENMAN +! ---------------------------------------------------------------------- + + SUBROUTINE SHFLX (STC,NSOIL,DT,YY,ZZ1,ZSOIL,TBOT,DF1) +! ---------------------------------------------------------------------- +! UPDATE THE TEMPERATURE STATE OF THE SOIL COLUMN BASED ON THE THERMAL +! DIFFUSION EQUATION AND UPDATE THE FROZEN SOIL MOISTURE CONTENT BASED +! ON THE TEMPERATURE. +! ---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER, INTENT(IN) :: NSOIL + REAL, INTENT(IN) :: DF1,DT,TBOT,YY, ZZ1 + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ZSOIL + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: STC + + REAL, DIMENSION(1:NSOIL) :: AI, BI, CI, STCF,RHSTS + INTEGER :: I + REAL, PARAMETER :: T0 = 273.15 + +! ---------------------------------------------------------------------- +! HRT ROUTINE CALCS THE RIGHT HAND SIDE OF THE SOIL TEMP DIF EQN +! ---------------------------------------------------------------------- + + CALL HRTICE (RHSTS,STC,TBOT, NSOIL,ZSOIL,YY,ZZ1,DF1,AI,BI,CI) + + CALL HSTEP (STCF,STC,RHSTS,DT,NSOIL,AI,BI,CI) + + DO I = 1,NSOIL + STC (I) = STCF (I) + END DO +! ---------------------------------------------------------------------- + END SUBROUTINE SHFLX +! ---------------------------------------------------------------------- + + SUBROUTINE SNOPAC (ETP,ETA,PRCP,PRCPF,SNOWNG,NSOIL,DT,DF1, & + & Q2,T1,SFCTMP,T24,TH2,FDOWN,SSOIL,STC, & + & SFCPRS,RCH,RR,SNEQV,SNDENS,SNOWH,ZSOIL,TBOT, & + & SNOMLT,DEW,FLX1,FLX2,FLX3,ESNOW,EMISSI,RIBB, & + & SIGMA,CPH2O,CPICE,LSUBF) + +! ---------------------------------------------------------------------- +! CALCULATE SOIL MOISTURE AND HEAT FLUX VALUES & UPDATE SOIL MOISTURE +! CONTENT AND SOIL HEAT CONTENT VALUES FOR THE CASE WHEN A SNOW PACK IS +! PRESENT. +! ---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER, INTENT(IN) :: NSOIL + LOGICAL, INTENT(IN) :: SNOWNG + REAL, INTENT(IN) :: DF1,DT,FDOWN,PRCP,Q2,RCH,RR,SFCPRS,SFCTMP, & + & T24,TBOT,TH2,EMISSI + REAL, INTENT(IN) :: SIGMA, CPH2O, CPICE, LSUBF + REAL, INTENT(INOUT) :: SNEQV,FLX2,PRCPF,SNOWH,SNDENS,T1,RIBB,ETP + REAL, INTENT(OUT) :: DEW,ESNOW,FLX1,FLX3,SSOIL,SNOMLT + REAL, DIMENSION(1:NSOIL),INTENT(IN) :: ZSOIL + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: STC + REAL, DIMENSION(1:NSOIL) :: ET1 + INTEGER :: K + REAL :: DENOM,DSOIL,DTOT,ESDFLX,ETA, & + & ESNOW1,ESNOW2,ETA1,ETP1,ETP2, & + & ETP3,ETANRG,EX, & + & FRCSNO,FRCSOI,PRCP1,QSAT,RSNOW,SEH, & + & SNCOND,T12,T12A,T12B,T14,YY,ZZ1 + + REAL, PARAMETER :: ESDMIN = 1.E-6, LSUBC = 2.501000E+6, & + & LSUBS = 2.83E+6, TFREEZ = 273.15, & + & SNOEXP = 2.0 + +! ---------------------------------------------------------------------- +! FOR GLACIAL-ICE, SNOWCOVER FRACTION = 1.0, AND SUBLIMATION IS AT THE +! POTENTIAL RATE. +! ---------------------------------------------------------------------- +! INITIALIZE EVAP TERMS. +! ---------------------------------------------------------------------- +! conversions: +! ESNOW [KG M-2 S-1] +! ESDFLX [KG M-2 S-1] .le. ESNOW +! ESNOW1 [M S-1] +! ESNOW2 [M] +! ETP [KG M-2 S-1] +! ETP1 [M S-1] +! ETP2 [M] +! ---------------------------------------------------------------------- + SNOMLT = 0.0 + DEW = 0. + ESNOW = 0. + ESNOW1 = 0. + ESNOW2 = 0. + +! ---------------------------------------------------------------------- +! CONVERT POTENTIAL EVAP (ETP) FROM KG M-2 S-1 TO ETP1 IN M S-1 +! ---------------------------------------------------------------------- + PRCP1 = PRCPF *0.001 +! ---------------------------------------------------------------------- +! IF ETP<0 (DOWNWARD) THEN DEWFALL (=FROSTFALL IN THIS CASE). +! ---------------------------------------------------------------------- + IF (ETP <= 0.0) THEN + IF ( ( RIBB >= 0.1 ) .AND. ( FDOWN > 150.0 ) ) THEN + ETP=(MIN(ETP*(1.0-RIBB),0.)/0.980 + ETP*(0.980-1.0))/0.980 + ENDIF + ETP1 = ETP * 0.001 + DEW = -ETP1 + ESNOW2 = ETP1*DT + ETANRG = ETP*LSUBS + ELSE + ETP1 = ETP * 0.001 + ESNOW = ETP + ESNOW1 = ESNOW*0.001 + ESNOW2 = ESNOW1*DT + ETANRG = ESNOW*LSUBS + END IF + +! ---------------------------------------------------------------------- +! IF PRECIP IS FALLING, CALCULATE HEAT FLUX FROM SNOW SFC TO NEWLY +! ACCUMULATING PRECIP. NOTE THAT THIS REFLECTS THE FLUX APPROPRIATE FOR +! THE NOT-YET-UPDATED SKIN TEMPERATURE (T1). ASSUMES TEMPERATURE OF THE +! SNOWFALL STRIKING THE GROUND IS =SFCTMP (LOWEST MODEL LEVEL AIR TEMP). +! ---------------------------------------------------------------------- + FLX1 = 0.0 + IF (SNOWNG) THEN + FLX1 = CPICE * PRCP * (T1- SFCTMP) + ELSE + IF (PRCP > 0.0) FLX1 = CPH2O * PRCP * (T1- SFCTMP) + END IF +! ---------------------------------------------------------------------- +! CALCULATE AN 'EFFECTIVE SNOW-GRND SFC TEMP' (T12) BASED ON HEAT FLUXES +! BETWEEN THE SNOW PACK AND THE SOIL AND ON NET RADIATION. +! INCLUDE FLX1 (PRECIP-SNOW SFC) AND FLX2 (FREEZING RAIN LATENT HEAT) +! FLUXES. FLX1 FROM ABOVE, FLX2 BROUGHT IN VIA COMMOM BLOCK RITE. +! FLX2 REFLECTS FREEZING RAIN LATENT HEAT FLUX USING T1 CALCULATED IN +! PENMAN. +! ---------------------------------------------------------------------- + DSOIL = - (0.5 * ZSOIL (1)) + DTOT = SNOWH + DSOIL + DENOM = 1.0+ DF1 / (DTOT * RR * RCH) + T12A = ( (FDOWN - FLX1- FLX2- EMISSI * SIGMA * T24)/ RCH & + + TH2- SFCTMP - ETANRG / RCH ) / RR + T12B = DF1 * STC (1) / (DTOT * RR * RCH) + + T12 = (SFCTMP + T12A + T12B) / DENOM + IF (T12 <= TFREEZ) THEN +! ---------------------------------------------------------------------- +! SUB-FREEZING BLOCK +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! IF THE 'EFFECTIVE SNOW-GRND SFC TEMP' IS AT OR BELOW FREEZING, NO SNOW +! MELT WILL OCCUR. SET THE SKIN TEMP TO THIS EFFECTIVE TEMP. REDUCE +! (BY SUBLIMINATION ) OR INCREASE (BY FROST) THE DEPTH OF THE SNOWPACK, +! DEPENDING ON SIGN OF ETP. +! UPDATE SOIL HEAT FLUX (SSOIL) USING NEW SKIN TEMPERATURE (T1) +! SINCE NO SNOWMELT, SET ACCUMULATED SNOWMELT TO ZERO, SET 'EFFECTIVE' +! PRECIP FROM SNOWMELT TO ZERO, SET PHASE-CHANGE HEAT FLUX FROM SNOWMELT +! TO ZERO. +! ---------------------------------------------------------------------- + T1 = T12 + SSOIL = DF1 * (T1- STC (1)) / DTOT + SNEQV = MAX(0.0, SNEQV-ESNOW2) + FLX3 = 0.0 + EX = 0.0 + SNOMLT = 0.0 + ELSE +! ---------------------------------------------------------------------- +! ABOVE FREEZING BLOCK +! ---------------------------------------------------------------------- +! IF THE 'EFFECTIVE SNOW-GRND SFC TEMP' IS ABOVE FREEZING, SNOW MELT +! WILL OCCUR. CALL THE SNOW MELT RATE,EX AND AMT, SNOMLT. REVISE THE +! EFFECTIVE SNOW DEPTH. REVISE THE SKIN TEMP BECAUSE IT WOULD HAVE CHGD +! DUE TO THE LATENT HEAT RELEASED BY THE MELTING. CALC THE LATENT HEAT +! RELEASED, FLX3. SET THE EFFECTIVE PRECIP, PRCP1 TO THE SNOW MELT RATE, +! EX FOR USE IN SMFLX. ADJUSTMENT TO T1 TO ACCOUNT FOR SNOW PATCHES. +! CALCULATE QSAT VALID AT FREEZING POINT. NOTE THAT ESAT (SATURATION +! VAPOR PRESSURE) VALUE OF 6.11E+2 USED HERE IS THAT VALID AT FRZZING +! POINT. NOTE THAT ETP FROM CALL PENMAN IN SFLX IS IGNORED HERE IN +! FAVOR OF BULK ETP OVER 'OPEN WATER' AT FREEZING TEMP. +! UPDATE SOIL HEAT FLUX (S) USING NEW SKIN TEMPERATURE (T1) +! ---------------------------------------------------------------------- + T1 = TFREEZ + IF ( DTOT .GT. 2.0*DSOIL ) THEN + DTOT = 2.0*DSOIL + ENDIF + SSOIL = DF1 * (T1- STC (1)) / DTOT + IF (SNEQV-ESNOW2 <= ESDMIN) THEN + SNEQV = 0.0 + EX = 0.0 + SNOMLT = 0.0 + FLX3 = 0.0 +! ---------------------------------------------------------------------- +! SUBLIMATION LESS THAN DEPTH OF SNOWPACK +! SNOWPACK (SNEQV) REDUCED BY ESNOW2 (DEPTH OF SUBLIMATED SNOW) +! ---------------------------------------------------------------------- + ELSE + SNEQV = SNEQV-ESNOW2 + ETP3 = ETP * LSUBC + SEH = RCH * (T1- TH2) + T14 = ( T1 * T1 ) * ( T1 * T1 ) + FLX3 = FDOWN - FLX1- FLX2- EMISSI*SIGMA * T14- SSOIL - SEH - ETANRG + IF (FLX3 <= 0.0) FLX3 = 0.0 + EX = FLX3*0.001/ LSUBF + SNOMLT = EX * DT +! ---------------------------------------------------------------------- +! ESDMIN REPRESENTS A SNOWPACK DEPTH THRESHOLD VALUE BELOW WHICH WE +! CHOOSE NOT TO RETAIN ANY SNOWPACK, AND INSTEAD INCLUDE IT IN SNOWMELT. +! ---------------------------------------------------------------------- + IF (SNEQV- SNOMLT >= ESDMIN) THEN + SNEQV = SNEQV- SNOMLT + ELSE +! ---------------------------------------------------------------------- +! SNOWMELT EXCEEDS SNOW DEPTH +! ---------------------------------------------------------------------- + EX = SNEQV / DT + FLX3 = EX *1000.0* LSUBF + SNOMLT = SNEQV + + SNEQV = 0.0 + ENDIF + ENDIF + +! ---------------------------------------------------------------------- +! FOR GLACIAL ICE, THE SNOWMELT WILL BE ADDED TO SUBSURFACE +! RUNOFF/BASEFLOW LATER NEAR THE END OF SFLX (AFTER RETURN FROM CALL TO +! SUBROUTINE SNOPAC) +! ---------------------------------------------------------------------- + + ENDIF + +! ---------------------------------------------------------------------- +! BEFORE CALL SHFLX IN THIS SNOWPACK CASE, SET ZZ1 AND YY ARGUMENTS TO +! SPECIAL VALUES THAT ENSURE THAT GROUND HEAT FLUX CALCULATED IN SHFLX +! MATCHES THAT ALREADY COMPUTED FOR BELOW THE SNOWPACK, THUS THE SFC +! HEAT FLUX TO BE COMPUTED IN SHFLX WILL EFFECTIVELY BE THE FLUX AT THE +! SNOW TOP SURFACE. +! ---------------------------------------------------------------------- + ZZ1 = 1.0 + YY = STC (1) -0.5* SSOIL * ZSOIL (1)* ZZ1/ DF1 + +! ---------------------------------------------------------------------- +! SHFLX WILL CALC/UPDATE THE SOIL TEMPS. +! ---------------------------------------------------------------------- + CALL SHFLX (STC,NSOIL,DT,YY,ZZ1,ZSOIL,TBOT,DF1) + +! ---------------------------------------------------------------------- +! SNOW DEPTH AND DENSITY ADJUSTMENT BASED ON SNOW COMPACTION. YY IS +! ASSUMED TO BE THE SOIL TEMPERTURE AT THE TOP OF THE SOIL COLUMN. +! ---------------------------------------------------------------------- + IF (SNEQV .GE. 0.10) THEN + CALL SNOWPACK (SNEQV,DT,SNOWH,SNDENS,T1,YY) + ELSE + SNEQV = 0.10 + SNOWH = 0.50 +!KWM???? SNDENS = +!KWM???? SNCOND = + ENDIF +! ---------------------------------------------------------------------- + END SUBROUTINE SNOPAC +! ---------------------------------------------------------------------- + + SUBROUTINE SNOWPACK (SNEQV,DTSEC,SNOWH,SNDENS,TSNOW,TSOIL) + +! ---------------------------------------------------------------------- +! CALCULATE COMPACTION OF SNOWPACK UNDER CONDITIONS OF INCREASING SNOW +! DENSITY, AS OBTAINED FROM AN APPROXIMATE SOLUTION OF E. ANDERSON'S +! DIFFERENTIAL EQUATION (3.29), NOAA TECHNICAL REPORT NWS 19, BY VICTOR +! KOREN, 03/25/95. +! ---------------------------------------------------------------------- +! SNEQV WATER EQUIVALENT OF SNOW (M) +! DTSEC TIME STEP (SEC) +! SNOWH SNOW DEPTH (M) +! SNDENS SNOW DENSITY (G/CM3=DIMENSIONLESS FRACTION OF H2O DENSITY) +! TSNOW SNOW SURFACE TEMPERATURE (K) +! TSOIL SOIL SURFACE TEMPERATURE (K) + +! SUBROUTINE WILL RETURN NEW VALUES OF SNOWH AND SNDENS +! ---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER :: IPOL, J + REAL, INTENT(IN) :: SNEQV, DTSEC,TSNOW,TSOIL + REAL, INTENT(INOUT) :: SNOWH, SNDENS + REAL :: BFAC,DSX,DTHR,DW,SNOWHC,PEXP, & + TAVGC,TSNOWC,TSOILC,ESDC,ESDCX + REAL, PARAMETER :: C1 = 0.01, C2 = 21.0, G = 9.81, & + KN = 4000.0 +! ---------------------------------------------------------------------- +! CONVERSION INTO SIMULATION UNITS +! ---------------------------------------------------------------------- + SNOWHC = SNOWH *100. + ESDC = SNEQV *100. + DTHR = DTSEC /3600. + TSNOWC = TSNOW -273.15 + TSOILC = TSOIL -273.15 + +! ---------------------------------------------------------------------- +! CALCULATING OF AVERAGE TEMPERATURE OF SNOW PACK +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! CALCULATING OF SNOW DEPTH AND DENSITY AS A RESULT OF COMPACTION +! SNDENS=DS0*(EXP(BFAC*SNEQV)-1.)/(BFAC*SNEQV) +! BFAC=DTHR*C1*EXP(0.08*TAVGC-C2*DS0) +! NOTE: BFAC*SNEQV IN SNDENS EQN ABOVE HAS TO BE CAREFULLY TREATED +! NUMERICALLY BELOW: +! C1 IS THE FRACTIONAL INCREASE IN DENSITY (1/(CM*HR)) +! C2 IS A CONSTANT (CM3/G) KOJIMA ESTIMATED AS 21 CMS/G +! ---------------------------------------------------------------------- + TAVGC = 0.5* (TSNOWC + TSOILC) + IF (ESDC > 1.E-2) THEN + ESDCX = ESDC + ELSE + ESDCX = 1.E-2 + END IF + +! DSX = SNDENS*((DEXP(BFAC*ESDC)-1.)/(BFAC*ESDC)) +! ---------------------------------------------------------------------- +! THE FUNCTION OF THE FORM (e**x-1)/x IMBEDDED IN ABOVE EXPRESSION +! FOR DSX WAS CAUSING NUMERICAL DIFFICULTIES WHEN THE DENOMINATOR "x" +! (I.E. BFAC*ESDC) BECAME ZERO OR APPROACHED ZERO (DESPITE THE FACT THAT +! THE ANALYTICAL FUNCTION (e**x-1)/x HAS A WELL DEFINED LIMIT AS +! "x" APPROACHES ZERO), HENCE BELOW WE REPLACE THE (e**x-1)/x +! EXPRESSION WITH AN EQUIVALENT, NUMERICALLY WELL-BEHAVED +! POLYNOMIAL EXPANSION. + +! NUMBER OF TERMS OF POLYNOMIAL EXPANSION, AND HENCE ITS ACCURACY, +! IS GOVERNED BY ITERATION LIMIT "IPOL". +! IPOL GREATER THAN 9 ONLY MAKES A DIFFERENCE ON DOUBLE +! PRECISION (RELATIVE ERRORS GIVEN IN PERCENT %). +! IPOL=9, FOR REL.ERROR <~ 1.6 E-6 % (8 SIGNIFICANT DIGITS) +! IPOL=8, FOR REL.ERROR <~ 1.8 E-5 % (7 SIGNIFICANT DIGITS) +! IPOL=7, FOR REL.ERROR <~ 1.8 E-4 % ... +! ---------------------------------------------------------------------- + BFAC = DTHR * C1* EXP (0.08* TAVGC - C2* SNDENS) + IPOL = 4 + PEXP = 0. +! PEXP = (1. + PEXP)*BFAC*ESDC/REAL(J+1) + DO J = IPOL,1, -1 + PEXP = (1. + PEXP)* BFAC * ESDCX / REAL (J +1) + END DO + + PEXP = PEXP + 1. +! ---------------------------------------------------------------------- +! ABOVE LINE ENDS POLYNOMIAL SUBSTITUTION +! ---------------------------------------------------------------------- +! END OF KOREAN FORMULATION + +! BASE FORMULATION (COGLEY ET AL., 1990) +! CONVERT DENSITY FROM G/CM3 TO KG/M3 +! DSM=SNDENS*1000.0 + +! DSX=DSM+DTSEC*0.5*DSM*G*SNEQV/ +! & (1E7*EXP(-0.02*DSM+KN/(TAVGC+273.16)-14.643)) + +! & CONVERT DENSITY FROM KG/M3 TO G/CM3 +! DSX=DSX/1000.0 + +! END OF COGLEY ET AL. FORMULATION + +! ---------------------------------------------------------------------- +! SET UPPER/LOWER LIMIT ON SNOW DENSITY +! ---------------------------------------------------------------------- + DSX = SNDENS * (PEXP) + IF (DSX > 0.40) DSX = 0.40 + IF (DSX < 0.05) DSX = 0.05 +! ---------------------------------------------------------------------- +! UPDATE OF SNOW DEPTH AND DENSITY DEPENDING ON LIQUID WATER DURING +! SNOWMELT. ASSUMED THAT 13% OF LIQUID WATER CAN BE STORED IN SNOW PER +! DAY DURING SNOWMELT TILL SNOW DENSITY 0.40. +! ---------------------------------------------------------------------- + SNDENS = DSX + IF (TSNOWC >= 0.) THEN + DW = 0.13* DTHR /24. + SNDENS = SNDENS * (1. - DW) + DW + IF (SNDENS >= 0.40) SNDENS = 0.40 +! ---------------------------------------------------------------------- +! CALCULATE SNOW DEPTH (CM) FROM SNOW WATER EQUIVALENT AND SNOW DENSITY. +! CHANGE SNOW DEPTH UNITS TO METERS +! ---------------------------------------------------------------------- + END IF + SNOWHC = ESDC / SNDENS + SNOWH = SNOWHC * 0.01 + +! ---------------------------------------------------------------------- + END SUBROUTINE SNOWPACK +! ---------------------------------------------------------------------- + + SUBROUTINE SNOWZ0 (Z0, Z0BRD, SNOWH) +! ---------------------------------------------------------------------- +! CALCULATE TOTAL ROUGHNESS LENGTH OVER SNOW +! Z0 ROUGHNESS LENGTH (m) +! Z0S SNOW ROUGHNESS LENGTH:=0.001 (m) +! ---------------------------------------------------------------------- + IMPLICIT NONE + REAL, INTENT(IN) :: Z0BRD + REAL, INTENT(OUT) :: Z0 + REAL, PARAMETER :: Z0S=0.001 + REAL, INTENT(IN) :: SNOWH + REAL :: BURIAL + REAL :: Z0EFF + + BURIAL = 7.0*Z0BRD - SNOWH + IF(BURIAL.LE.0.0007) THEN + Z0EFF = Z0S + ELSE + Z0EFF = BURIAL/7.0 + ENDIF + + Z0 = Z0EFF + +! ---------------------------------------------------------------------- + END SUBROUTINE SNOWZ0 +! ---------------------------------------------------------------------- + + SUBROUTINE SNOW_NEW (TEMP,NEWSN,SNOWH,SNDENS) + +! ---------------------------------------------------------------------- +! CALCULATE SNOW DEPTH AND DENSITY TO ACCOUNT FOR THE NEW SNOWFALL. +! UPDATED VALUES OF SNOW DEPTH AND DENSITY ARE RETURNED. + +! TEMP AIR TEMPERATURE (K) +! NEWSN NEW SNOWFALL (M) +! SNOWH SNOW DEPTH (M) +! SNDENS SNOW DENSITY (G/CM3=DIMENSIONLESS FRACTION OF H2O DENSITY) +! ---------------------------------------------------------------------- + IMPLICIT NONE + REAL, INTENT(IN) :: NEWSN, TEMP + REAL, INTENT(INOUT) :: SNDENS, SNOWH + REAL :: DSNEW, HNEWC, SNOWHC,NEWSNC,TEMPC + +! ---------------------------------------------------------------------- +! CALCULATING NEW SNOWFALL DENSITY DEPENDING ON TEMPERATURE +! EQUATION FROM GOTTLIB L. 'A GENERAL RUNOFF MODEL FOR SNOWCOVERED +! AND GLACIERIZED BASIN', 6TH NORDIC HYDROLOGICAL CONFERENCE, +! VEMADOLEN, SWEDEN, 1980, 172-177PP. +!----------------------------------------------------------------------- + TEMPC = TEMP - 273.15 + IF ( TEMPC <= -15. ) THEN + DSNEW = 0.05 + ELSE + DSNEW = 0.05 + 0.0017 * ( TEMPC + 15. ) ** 1.5 + ENDIF + +! ---------------------------------------------------------------------- +! CONVERSION INTO SIMULATION UNITS +! ---------------------------------------------------------------------- + SNOWHC = SNOWH * 100. + NEWSNC = NEWSN * 100. + +! ---------------------------------------------------------------------- +! ADJUSTMENT OF SNOW DENSITY DEPENDING ON NEW SNOWFALL +! ---------------------------------------------------------------------- + HNEWC = NEWSNC / DSNEW + IF ( SNOWHC + HNEWC < 1.0E-3 ) THEN + SNDENS = MAX ( DSNEW , SNDENS ) + ELSE + SNDENS = ( SNOWHC * SNDENS + HNEWC * DSNEW ) / ( SNOWHC + HNEWC ) + ENDIF + SNOWHC = SNOWHC + HNEWC + SNOWH = SNOWHC * 0.01 + +! ---------------------------------------------------------------------- + END SUBROUTINE SNOW_NEW +! ---------------------------------------------------------------------- + +END MODULE module_sf_noahlsm_glacial_only diff --git a/physics/sfc_drv.f b/physics/sfc_drv.f index 75afaa6ff..2ec722b4a 100644 --- a/physics/sfc_drv.f +++ b/physics/sfc_drv.f @@ -31,7 +31,20 @@ subroutine lsm_noah_init(me, isot, ivegsrc, nlunit, ! Initialize CCPP error handling variables errmsg = '' errflg = 0 - + + if (ivegsrc > 2) then + errmsg = 'The NOAH LSM expects that the ivegsrc physics '// + & 'namelist parameter is 0, 1, or 2. Exiting...' + errflg = 1 + return + end if + if (isot > 1) then + errmsg = 'The NOAH LSM expects that the isot physics '// + & 'namelist parameter is 0, or 1. Exiting...' + errflg = 1 + return + end if + !--- initialize soil vegetation call set_soilveg(me, isot, ivegsrc, nlunit) diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index 3b4b8a118..dcef59fd0 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -36,6 +36,17 @@ subroutine lsm_ruc_init (me, isot, ivegsrc, nlunit, & errmsg = '' errflg = 0 + if (ivegsrc /= 1) then + errmsg = 'The RUC LSM expects that the ivegsrc physics namelist parameter is 1. Exiting...' + errflg = 1 + return + end if + if (isot > 1) then + errmsg = 'The RUC LSM expects that the isot physics namelist parameter is 0, or 1. Exiting...' + errflg = 1 + return + end if + !--- initialize soil vegetation call set_soilveg_ruc(me, isot, ivegsrc, nlunit) diff --git a/physics/sfc_noah_wrfv4.F90 b/physics/sfc_noah_wrfv4.F90 new file mode 100644 index 000000000..c435b2d38 --- /dev/null +++ b/physics/sfc_noah_wrfv4.F90 @@ -0,0 +1,261 @@ +!> \file sfc_noah_wrfv4.F90 +!! This file contains the Noah land surface scheme driver for the version of the scheme found in WRF v4.0. + +!> This module contains the CCPP-compliant Noah land surface scheme driver for +!! the version found in WRF v4.0. + module sfc_noah_wrfv4 + + implicit none + + private + + public :: sfc_noah_wrfv4_init, sfc_noah_wrfv4_run, sfc_noah_wrfv4_finalize + + contains + +!> \ingroup NOAH_LSM_WRFv4 +!! \section arg_table_sfc_noah_wrfv4_init Argument Table +!! \htmlinclude sfc_noah_wrfv4_init.html +!! + subroutine sfc_noah_wrfv4_init(lsm, lsm_noah_wrfv4, nsoil, ua_phys, fasdas, restart, errmsg, errflg) + + use machine, only : kind_phys + + implicit none + + integer, intent(in) :: lsm, lsm_noah_wrfv4, nsoil, fasdas + logical, intent(in) :: ua_phys, restart + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (lsm/=lsm_noah_wrfv4) then + write(errmsg,'(*(a))') "Logic error: namelist choice of LSM is different from NOAH WRFv4" + errflg = 1 + return + end if + + if (nsoil < 2) then + write(errmsg,'(*(a))') "The NOAH WRFv4 scheme expects at least 2 soil layers." + errflg = 1 + return + end if + + if (ua_phys) then + write(errmsg,'(*(a))') "The NOAH WRFv4 scheme has not been tested with ua_phys = T" + errflg = 1 + return + end if + + + if (fasdas > 0) then + write(errmsg,'(*(a))') "The NOAH WRFv4 scheme has not been tested with fasdas > 0" + errflg = 1 + return + end if + + if (restart) then + !GJF: for restart functionality, the host model will need to write/read snotime (time_since_last_snowfall (s)) + write(errmsg,'(*(a))') "The NOAH WRFv4 scheme has not been configured for restarts." + errflg = 1 + return + end if + + !GJF: check for rdlai != F? + !GJF: check for usemonalb != T? + + end subroutine sfc_noah_wrfv4_init + + +!! \section arg_table_sfc_noah_wrfv4_finalize Argument Table +!! \htmlinclude sfc_noah_wrfv4_finalize.html +!! + subroutine sfc_noah_wrfv4_finalize(errmsg, errflg) + + implicit none + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + end subroutine sfc_noah_wrfv4_finalize + + +!> \defgroup NOAH_LSM_WRFv4 Noah LSM Model from WRF v4.0 +!! \section arg_table_sfc_noah_wrfv4_run Argument Table +!! \htmlinclude sfc_noah_wrfv4_run.html +!! +!> \section general_noah_wrfv4_drv NOAH LSM WRFv4 General Algorithm +!> @{ + subroutine sfc_noah_wrfv4_run (im, isice, flag_lsm, flag_lsm_glacier, srflag, isurban, rdlai, & + ua_phys, usemonalb, aoasis, fasdas, dt, zlvl, & + nsoil, sthick, lwdn, soldn, solnet, sfcprs, prcp, sfctmp, q1k, & + th1, qs1, dqsdt2, vegtyp, soiltyp, slopetyp, shdfac, shmin, & + shmax, albbrd, snoalb, tbot, z0brd, z0k, emissi, embrd, cmc, t1,& + stc, smc, swc, snowhk, sneqv, chk, cp, rd, sigma, cph2o, cpice, & + lsubf, sheat, eta, ec, edir, ett, esnow, etp, ssoil, & + flx1, flx2, flx3, sncovr, runoff1, runoff2, soilm, qsurf, ribb, & + smcwlt, smcref, smcmax, opt_thcnd, snotime, errmsg, errflg) + + use machine , only : kind_phys + use module_sf_noahlsm, only: sflx, lutype, sltype + use module_sf_noahlsm_glacial_only, only: sflx_glacial + + implicit none + + integer, intent(in) :: im, isice, isurban, nsoil, opt_thcnd, fasdas + logical, intent(in) :: rdlai, ua_phys, usemonalb + !GJF: usemonalb = True if the surface diffused shortwave albedo is EITHER read from input OR + ! provided by a previous scheme (like radiation: as is done in GFS_rrtmgp_sw_pre) + real(kind=kind_phys), intent(in) :: aoasis + + real(kind=kind_phys), intent(in) :: dt, cp, rd, sigma, cph2o, cpice, lsubf + + integer, dimension(im), intent(in) :: vegtyp, soiltyp, slopetyp + logical, dimension(im), intent(in) :: flag_lsm, flag_lsm_glacier + real(kind=kind_phys), dimension(im), intent(in) :: srflag, zlvl, lwdn, soldn, solnet, & + sfcprs, prcp, sfctmp, q1k, th1, qs1, & + dqsdt2, shmin, shmax, snoalb, tbot + real(kind=kind_phys), dimension(nsoil), intent(in) :: sthick + + real(kind=kind_phys), dimension(im), intent(inout) :: shdfac, albbrd, z0brd, z0k, emissi, & + cmc, t1, snowhk, sneqv, chk, flx1, & + flx2, flx3, ribb, snotime + real(kind=kind_phys), dimension(im,nsoil), intent(inout) :: stc, smc, swc + + !variables that are intent(out) in module_sf_noahlsm, but are inout here due to being set within an IF statement + real(kind=kind_phys), dimension(im), intent(inout) :: embrd, sheat, eta, ec, & + edir, ett, esnow, etp, ssoil, sncovr, & + runoff1, runoff2, soilm, qsurf, smcwlt, & + smcref, smcmax + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + !GJF: There is some confusion regarding specific humidities vs mixing ratios in NOAH LSM. + ! Looking at module_sf_noahlsm.F, sometimes the comments say mixing ratio and sometimes + ! specific humidity. The WRF code (module_sf_noahdrv.F) specifically converts from mixing + ! ratio to specific humidity in preparation for calling SFLX, so I am assuming that + ! all inputs/outputs into SFLX should be specific humidities, despite some comments in + ! module_sf_noahdrv.F describing arguments saying "mixing ratios". This applies to many + ! arguments into SFLX (q1k, qs1, dqsdt2, eta, qsurf, etc.). + +! local Variables + integer :: i, k + logical, parameter :: local = .false. !(not actually used in SFLX) described in module_sf_noahlsm as: + ! Flag for local-site simulation (where there is no maps for albedo, veg fraction, and roughness + ! true: all LSM parameters (inluding albedo, veg fraction and roughness length) will be defined by three tables + + real(kind=kind_phys) :: dummy + + !GJF: The following variables are part of the interface to SFLX but not required as diagnostic + ! output or otherwise outside of this subroutine (at least as part of a GFS-based suite). + ! If any of these variables are needed by other schemes or diagnostics, one needs to add it to + ! the host model and CCPP metadata. Alternatively, none of these variables NEED to be allocated + ! and one could also just pass in dummy arguments. + ! + ! The variables descriptions are from module_sf_noahlsm.F: + ! + ! albedok (output from SFLX): surface albedo including snow effect (unitless fraction) + ! =snow-free albedo (alb) when sneqv=0, or + ! =fct(msnoalb,alb,vegtyp,shdfac,shdmin) when sneqv>0 + ! eta_kinematic (output from SFLX), eta is what is passed out instead of eta_kinematic + ! fdown (output from SFLX) : Radiation forcing at the surface (W m-2) = SOLDN*(1-alb)+LWDN + ! et (output from SFLX): plant transpiration from a particular root (soil) layer (W m-2) + ! drip (output from SFLX): through-fall of precip and/or dew in excess of canopy water-holding capacity (m) + ! dew (output from SFLX): dewfall (or frostfall for t<273.15) (m) + ! beta (output from SFLX): ratio of actual/potential evap (dimensionless) + ! snomlt (output from SFLX): snow melt (m) (water equivalent) + ! runoff3 (output from SFLX): numerical trunctation in excess of porosity (smcmax) for a given soil layer at the end of a time step (m s-1). + ! rc (output from SFLX): canopy resistance (s m-1) + ! pc (output from SFLX): plant coefficient (unitless fraction, 0-1) where pc*etp = actual transp + ! rsmin (output from SFLX): minimum canopy resistance (s m-1) + ! xlai (output from SFLX): leaf area index (dimensionless) + ! rcs (output from SFLX): incoming solar rc factor (dimensionless) + ! rct (output from SFLX): air temperature rc factor (dimensionless) + ! rcq (output from SFLX): atmos vapor pressure deficit rc factor (dimensionless) + ! rcsoil (output from SFLX): soil moisture rc factor (dimensionless) + ! soilw (output from SFLX): available soil moisture in root zone (unitless fraction between smcwlt and smcmax) + ! smav (output from SFLX): soil moisture availability for each layer, as a fraction between smcwlt and smcmax. + ! smcdry (output from SFLX): dry soil moisture threshold where direct evap frm top layer ends (volumetric) + ! smcmax (output from SFLX): porosity, i.e. saturated value of soil moisture (volumetric) + ! nroot (output from SFLX): number of root layers, a function of veg type, determined in subroutine redprm. + + integer :: nroot + real(kind=kind_phys) :: albedok, eta_kinematic, fdown, drip, dew, beta, snomlt, & + runoff3, rc, pc, rsmin, xlai, rcs, rct, rcq, & + rcsoil, soilw, smcdry + real (kind=kind_phys), dimension(nsoil) :: et, smav + real(kind=kind_phys) :: sfcheadrt, infxsrt, etpnd1 !don't appear to be used unless WRF_HYDRO preprocessor directive is defined and no documentation + real(kind=kind_phys) :: xsda_qfx, hfx_phy, qfx_phy, xqnorm, hcpct_fasdas !only used if fasdas = 1 + + !variables associated with UA_PHYS (not used for now) + real(kind=kind_phys) :: flx4, fvb, fbur, fgsn + + errmsg = '' + errflg = 0 + + do i=1, im + if (flag_lsm(i)) then + !GJF: Why do LSMs want the dynamics time step instead of the physics time step? + call sflx (i, 1, srflag(i), & + isurban, dt, zlvl(i), nsoil, sthick, & !c + local, & !L + lutype, sltype, & !CL + lwdn(i), soldn(i), solnet(i), sfcprs(i), prcp(i), & !F + sfctmp(i), q1k(i), dummy, dummy, dummy, dummy, & !F + th1(i), qs1(i), dqsdt2(i), & !I + vegtyp(i), soiltyp(i), slopetyp(i), shdfac(i), & !I + shmin(i), shmax(i), & !I + albbrd(i), snoalb(i), tbot(i), z0brd(i), z0k(i), & !S + emissi(i), embrd(i), & !S + cmc(i), t1(i), stc(i,:), smc(i,:), swc(i,:), & !H + snowhk(i), sneqv(i), albedok, chk(i), dummy, & !H + cp, rd, sigma, cph2o, cpice, lsubf, & + eta(i), sheat(i), eta_kinematic, fdown, & !O + ec(i), edir(i), et, ett(i), esnow(i), drip, dew, & !O + beta, etp(i), ssoil(i), flx1(i), flx2(i), flx3(i),& !O + flx4, fvb, fbur, fgsn, ua_phys, & !UA + snomlt, sncovr(i), runoff1(i), runoff2(i),runoff3,& !O + rc, pc, rsmin, xlai, rcs, rct, rcq, rcsoil, & !O + soilw, soilm(i), qsurf(i), smav, & !D + rdlai, usemonalb, snotime(i), ribb(i), & + smcwlt(i), smcdry, smcref(i), smcmax(i), nroot, & + sfcheadrt, infxsrt, etpnd1, opt_thcnd, aoasis, & + xsda_qfx, hfx_phy, qfx_phy, xqnorm, fasdas, & !fasdas + hcpct_fasdas, & !fasdas + errflg, errmsg) + if (errflg > 0) return + else if (flag_lsm_glacier(i)) then + !set values that sflx updates, but sflx_glacial does not + soilm(i) = 0.0 + runoff2(i) = 0.0 + swc(i,:) = 1.0 + smc(i,:) = 1.0 + + call sflx_glacial (i, 1, isice, srflag(i), dt, zlvl(i), & + nsoil, sthick, lwdn(i), solnet(i), sfcprs(i), & + prcp(i), sfctmp(i), q1k(i), th1(i), qs1(i), & + dqsdt2(i), albbrd(i), snoalb(i), tbot(i), & + z0brd(i), z0k(i), emissi(i), embrd(i), t1(i), & + stc(i,:), snowhk(i), sneqv(i), albedok, chk(i), & + cp, rd, sigma, cph2o, cpice, lsubf, & + eta(i), sheat(i), eta_kinematic, fdown, esnow(i), & + dew, etp(i), ssoil(i), flx1(i), flx2(i), flx3(i), & + snomlt, sncovr(i), runoff1(i), qsurf(i), & + snotime(i), ribb(i), errflg, errmsg) + if (errflg > 0) return + end if + end do + + end subroutine sfc_noah_wrfv4_run +!> @} + +end module sfc_noah_wrfv4 diff --git a/physics/sfc_noah_wrfv4.meta b/physics/sfc_noah_wrfv4.meta new file mode 100644 index 000000000..781a21d3b --- /dev/null +++ b/physics/sfc_noah_wrfv4.meta @@ -0,0 +1,764 @@ +[ccpp-arg-table] + name = sfc_noah_wrfv4_init + type = scheme +[lsm] + standard_name = flag_for_land_surface_scheme + long_name = flag for land surface model + units = flag + dimensions = () + type = integer + intent = in + optional = F +[lsm_noah_wrfv4] + standard_name = flag_for_noah_wrfv4_land_surface_scheme + long_name = flag for NOAH WRFv4 land surface model + units = flag + dimensions = () + type = integer + intent = in + optional = F +[nsoil] + standard_name = soil_vertical_dimension + long_name = soil vertical layer dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[ua_phys] + standard_name = flag_for_noah_lsm_ua_extension + long_name = flag for using University of Arizona(?) extension for NOAH LSM (see module_sf_noahlsm.F) + units = flag + dimensions = () + type = logical + intent = in + optional = F +[fasdas] + standard_name = flag_flux_adjusting_surface_data_assimilation_system + long_name = flag to use the flux adjusting surface data assimilation system for NOAH LSM WRFv4 (see module_sf_noahlsm.F) + units = flag + dimensions = () + type = integer + intent = in + optional = F +[restart] + standard_name = flag_for_restart + long_name = flag for restart (warmstart) or coldstart + units = flag + dimensions = () + type = logical + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-arg-table] + name = sfc_noah_wrfv4_finalize + type = scheme +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-arg-table] + name = sfc_noah_wrfv4_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[isice] + standard_name = ice_vegetation_category + long_name = index of the permanent snow/ice category in the chosen vegetation dataset + units = index + dimensions = () + type = integer + intent = in + optional = F +[flag_lsm] + standard_name = flag_for_calling_land_surface_model + long_name = flag for calling land surface model + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in + optional = F +[flag_lsm_glacier] + standard_name = flag_for_calling_land_surface_model_glacier + long_name = flag for calling land surface model over glacier + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in + optional = F +[srflag] + standard_name = flag_for_precipitation_type + long_name = flag for snow or rain precipitation + units = flag + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[isurban] + standard_name = urban_vegetation_category + long_name = index of the urban vegetation category in the chosen vegetation dataset + units = index + dimensions = () + type = integer + intent = in + optional = F +[rdlai] + standard_name = flag_for_reading_leaf_area_index_from_input + long_name = flag for reading leaf area index from initial conditions + units = flag + dimensions = () + type = logical + intent = in + optional = F +[ua_phys] + standard_name = flag_for_noah_lsm_ua_extension + long_name = flag for using University of Arizona(?) extension for NOAH LSM (see module_sf_noahlsm.F) + units = flag + dimensions = () + type = logical + intent = in + optional = F +[usemonalb] + standard_name = flag_for_reading_surface_diffused_shortwave_albedo_from_input + long_name = flag for reading surface diffused shortwave albedo for NOAH LSM WRFv4 (see module_sf_noahlsm.F) + units = flag + dimensions = () + type = logical + intent = in + optional = F +[aoasis] + standard_name = potential_evaporation_multiplicative_factor + long_name = potential evaporation multiplicative factor for NOAH LSM WRFv4 (see module_sf_noahlsm.F) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[fasdas] + standard_name = flag_flux_adjusting_surface_data_assimilation_system + long_name = flag to use the flux adjusting surface data assimilation system for NOAH LSM WRFv4 (see module_sf_noahlsm.F) + units = flag + dimensions = () + type = integer + intent = in + optional = F +[dt] + standard_name = time_step_for_dynamics + long_name = dynamics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[zlvl] + standard_name = height_above_ground_at_lowest_model_layer + long_name = height above ground at 1st model layer + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[nsoil] + standard_name = soil_vertical_dimension + long_name = soil vertical layer dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[sthick] + standard_name = soil_layer_thickness + long_name = soil layer thickness + units = m + dimensions = (soil_vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[lwdn] + standard_name = surface_downwelling_longwave_flux_absorbed_by_ground_over_land + long_name = total sky surface downward longwave flux absorbed by the ground over land + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[soldn] + standard_name = surface_downwelling_shortwave_flux + long_name = total sky surface downward shortwave flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[solnet] + standard_name = surface_net_downwelling_shortwave_flux + long_name = total sky surface net shortwave flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[sfcprs] + standard_name = air_pressure_at_lowest_model_layer + long_name = Model layer 1 mean pressure + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[prcp] + standard_name = total_precipitation_rate_on_dynamics_timestep_over_land + long_name = total precipitation rate in each time step over land + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[sfctmp] + standard_name = air_temperature_at_lowest_model_layer + long_name = 1st model layer air temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[q1k] + standard_name = bounded_specific_humidity_at_lowest_model_layer_over_land + long_name = specific humidity at lowest model layer over land bounded between a nonzero epsilon and saturation + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[th1] + standard_name = potential_temperature_at_lowest_model_layer + long_name = potential_temperature_at_lowest_model_layer + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[qs1] + standard_name = saturation_specific_humidity_at_lowest_model_layer + long_name = saturation specific humidity at lowest model layer + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[dqsdt2] + standard_name = saturation_specific_humidity_slope + long_name = saturation specific humidity slope at lowest model layer + units = K-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[vegtyp] + standard_name = vegetation_type_classification + long_name = vegetation type at each grid cell + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in + optional = F +[soiltyp] + standard_name = soil_type_classification + long_name = soil type at each grid cell + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in + optional = F +[slopetyp] + standard_name = surface_slope_classification + long_name = surface slope type at each grid cell + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in + optional = F +[shdfac] + standard_name = bounded_vegetation_area_fraction + long_name = areal fractional cover of green vegetation bounded on the bottom + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[shmin] + standard_name = minimum_vegetation_area_fraction + long_name = min fractional coverage of green vegetation + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[shmax] + standard_name = maximum_vegetation_area_fraction + long_name = max fractional coverage of green vegetation + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[albbrd] + standard_name = surface_diffused_shortwave_albedo + long_name = mean surface diffused shortwave albedo + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[snoalb] + standard_name = upper_bound_on_max_albedo_over_deep_snow + long_name = maximum snow albedo + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[tbot] + standard_name = deep_soil_temperature + long_name = bottom soil temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[z0brd] + standard_name = baseline_surface_roughness_length + long_name = baseline surface roughness length for momentum in meter + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[z0k] + standard_name = surface_roughness_length_over_land_interstitial + long_name = surface roughness length over land (temporary use as interstitial) + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[emissi] + standard_name = surface_longwave_emissivity_over_land_interstitial + long_name = surface lw emissivity in fraction over land (temporary use as interstitial) + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[embrd] + standard_name = baseline_surface_longwave_emissivity + long_name = baseline surface lw emissivity in fraction + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[cmc] + standard_name = canopy_water_amount_in_m + long_name = canopy water amount in m + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[t1] + standard_name = surface_skin_temperature_after_iteration_over_land + long_name = surface skin temperature after iteration over land + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[stc] + standard_name = soil_temperature + long_name = soil temperature + units = K + dimensions = (horizontal_loop_extent,soil_vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[smc] + standard_name = volume_fraction_of_soil_moisture + long_name = volumetric fraction of soil moisture + units = frac + dimensions = (horizontal_loop_extent,soil_vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[swc] + standard_name = volume_fraction_of_unfrozen_soil_moisture + long_name = volume fraction of unfrozen soil moisture + units = frac + dimensions = (horizontal_loop_extent,soil_vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[snowhk] + standard_name = actual_snow_depth + long_name = actual snow depth + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[sneqv] + standard_name = water_equivalent_accumulated_snow_depth_over_land + long_name = water equiv of acc snow depth over land + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[chk] + standard_name = surface_conductance_for_heat_and_moisture_in_air_over_land + long_name = surface conductance for heat & moisture over land + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[rd] + standard_name = gas_constant_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[sigma] + standard_name = stefan_boltzmann_constant + long_name = Steffan-Boltzmann constant + units = W m-2 K-4 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[cph2o] + standard_name = specific_heat_of_liquid_water_at_constant_pressure + long_name = specific heat of liquid water at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[cpice] + standard_name = specific_heat_of_ice_at_constant_pressure + long_name = specific heat of ice at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[lsubf] + standard_name = latent_heat_of_fusion_of_water_at_0C + long_name = latent heat of fusion + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[sheat] + standard_name = instantaneous_surface_upward_sensible_heat_flux + long_name = surface upward sensible heat flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[eta] + standard_name = instantaneous_surface_upward_latent_heat_flux + long_name = surface upward latent heat flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[ec] + standard_name = canopy_upward_latent_heat_flux + long_name = canopy upward latent heat flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[edir] + standard_name = soil_upward_latent_heat_flux + long_name = soil upward latent heat flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[ett] + standard_name = transpiration_flux + long_name = total plant transpiration rate + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[esnow] + standard_name = snow_deposition_sublimation_upward_latent_heat_flux + long_name = latent heat flux from snow depo/subl + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[etp] + standard_name = surface_upward_potential_latent_heat_flux_over_land + long_name = surface upward potential latent heat flux over land + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[ssoil] + standard_name = upward_heat_flux_in_soil_over_land + long_name = soil heat flux over land + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[flx1] + standard_name = latent_heat_flux_from_precipitating_snow + long_name = latent heat flux due to precipitating snow + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[flx2] + standard_name = latent_heat_flux_from_freezing_rain + long_name = latent heat flux due to freezing rain + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[flx3] + standard_name = latent_heat_flux_due_to_snowmelt + long_name = latent heat flux due to snowmelt phase change + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[sncovr] + standard_name = surface_snow_area_fraction_over_land + long_name = surface snow area fraction + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[runoff1] + standard_name = surface_runoff_flux_in_m_sm1 + long_name = surface runoff flux in m s-1 + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[runoff2] + standard_name = subsurface_runoff_flux_in_m_sm1 + long_name = subsurface runoff flux in m s-1 + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[soilm] + standard_name = soil_moisture_content_in_m + long_name = soil moisture in meters + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[qsurf] + standard_name = surface_specific_humidity_over_land + long_name = surface air saturation specific humidity over land + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[ribb] + standard_name = bulk_richardson_number_at_lowest_model_level_over_land + long_name = bulk Richardson number at the surface over land + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[smcwlt] + standard_name = volume_fraction_of_condensed_water_in_soil_at_wilting_point + long_name = soil water fraction at wilting point + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[smcref] + standard_name = threshold_volume_fraction_of_condensed_water_in_soil + long_name = soil moisture threshold + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[smcmax] + standard_name = soil_porosity + long_name = volumetric soil porosity + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[opt_thcnd] + standard_name = flag_for_thermal_conductivity_option + long_name = choice for thermal conductivity option (see module_sf_noahlsm) + units = index + dimensions = () + type = integer + intent = in + optional = F +[snotime] + standard_name = time_since_last_snowfall + long_name = elapsed time since last snowfall + units = s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F diff --git a/physics/sfc_noah_wrfv4_interstitial.F90 b/physics/sfc_noah_wrfv4_interstitial.F90 new file mode 100644 index 000000000..b30f8a131 --- /dev/null +++ b/physics/sfc_noah_wrfv4_interstitial.F90 @@ -0,0 +1,758 @@ +!> \file sfc_noah_wrfv4_interstitial.F90 +!! This file contains data preparation for the WRFv4 version of Noah LSM as part of a GFS-based suite. + +!> This module contains the CCPP-compliant data preparation for the WRFv4 version of Noah LSM. + module sfc_noah_wrfv4_pre + + implicit none + + public :: sfc_noah_wrfv4_pre_init, sfc_noah_wrfv4_pre_run, sfc_noah_wrfv4_pre_finalize + + private + + logical :: is_initialized = .false. + + contains + +!> \ingroup NOAH_LSM_WRFv4 +!! \section arg_table_sfc_noah_wrfv4_pre_init Argument Table +!! \htmlinclude sfc_noah_wrfv4_pre_init.html +!! + subroutine sfc_noah_wrfv4_pre_init(lsm, lsm_noah_wrfv4, veg_data_choice, & + soil_data_choice, isurban, isice, iswater, errmsg, errflg) + + use machine, only : kind_phys + + implicit none + + integer, intent(in) :: lsm, lsm_noah_wrfv4, & + veg_data_choice, soil_data_choice + + integer, intent(inout) :: isurban, isice, iswater + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variables + + character(len=256) :: mminlu, mminsl + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (is_initialized) return + + if (lsm/=lsm_noah_wrfv4) then + write(errmsg,'(*(a))') "Logic error: namelist choice of LSM is different from NOAH WRFv4" + errflg = 1 + return + end if + + select case (veg_data_choice) + case (0) + mminlu = 'USGS' + isurban = 1 + isice = 24 + iswater = 16 + case (1) + mminlu = 'MODIFIED_IGBP_MODIS_NOAH' + isurban = 13 + isice = 15 + iswater = 17 + case (3) + mminlu = 'NLCD40' + isurban = 13 + isice = 15 !or 22? + iswater = 17 !or 21? + case (4) + mminlu = 'USGS-RUC' + isurban = 1 + isice = 24 + iswater = 16 + case (5) + mminlu = 'MODI-RUC' + isurban = 13 + isice = 15 + iswater = 17 + case default + errmsg = 'The value of the ivegsrc physics namelist parameter is incompatible with this version of NOAH LSM' + errflg = 1 + return + end select + + select case (soil_data_choice) + case (1) + mminsl = 'STAS' + case (2) + mminsl = 'STAS-RUC' + case default + errmsg = 'The value of the isot physics namelist parameter is incompatible with this version of NOAH LSM' + errflg = 1 + return + end select + + call soil_veg_gen_parm(trim(mminlu), trim(mminsl), errmsg, errflg) + + is_initialized = .true. + + end subroutine sfc_noah_wrfv4_pre_init + + +!! \section arg_table_sfc_noah_wrfv4_pre_finalize Argument Table +!! \htmlinclude sfc_noah_wrfv4_pre_finalize.html +!! + subroutine sfc_noah_wrfv4_pre_finalize(errmsg, errflg) + + implicit none + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + end subroutine sfc_noah_wrfv4_pre_finalize + + +!> \ingroup NOAH_LSM_WRFv4 Noah LSM from WRFv4 pre-scheme data preparation +!! \section arg_table_sfc_noah_wrfv4_pre_run Argument Table +!! \htmlinclude sfc_noah_wrfv4_pre_run.html +!! +!> \section general_noah_wrfv4_pre NOAH LSM WRFv4 pre-scheme data preparation General Algorithm +!> @{ + subroutine sfc_noah_wrfv4_pre_run (im, nsoil, ialb, isice, land, & + flag_guess, flag_iter, restart, first_time_step, flag_lsm, & + flag_lsm_glacier, dt, rhowater, rd, rvrdm1, eps, epsm1, sfcprs, tprcp, & + sfctmp, q1, prslki, wind, snwdph, cm, ch, weasd, tsfc, vtype, smc, & + stc, slc, snoalb, prcp, q2k, rho1, qs1, th1, dqsdt2, canopy, cmc, & + snowhk, chk, cmm, chh, weasd_save, snwdph_save, tsfc_save, canopy_save,& + smc_save, stc_save, slc_save, ep, evap, hflx, gflux, drain, evbs, evcw,& + trans, sbsno, snowc, snohf, sthick, errmsg, errflg) + + use machine , only : kind_phys + use funcphys, only : fpvs + use module_sf_noahlsm, only: maxalb + + implicit none + + !GJF: Data preparation and output preparation from SFLX follows the GFS physics code (sfc_drv.F) + ! rather than the WRF code (module_sf_noahdrv.F) in order to "fit in" with other GFS physics-based + ! suites. Another version of this scheme (and the associated post) could potentially be + ! created from the WRF version. No attempt was made to test sensitivities to either approach. + ! Note that the version of NOAH LSM expected here is "generic" - there are no urban, fasdas, or + ! or University of Arizona(?) additions. + + integer, intent(in) :: im, nsoil, ialb, isice + logical, intent(in) :: restart, first_time_step + real(kind=kind_phys), intent(in) :: dt, rhowater, rd, rvrdm1, eps, epsm1 + + logical, dimension(im), intent(in) :: flag_guess, flag_iter, land + real(kind=kind_phys), dimension(im), intent(in) :: sfcprs, tprcp, sfctmp, q1, prslki, wind, cm, ch, snwdph + real(kind=kind_phys), dimension(im), intent(in) :: weasd, tsfc, vtype + real(kind=kind_phys), dimension(im,nsoil), intent(in) :: smc, stc, slc + + logical, dimension(im), intent(inout) :: flag_lsm, flag_lsm_glacier + real(kind=kind_phys), dimension(im), intent(inout) :: snoalb, prcp, q2k, rho1, qs1, th1, dqsdt2, canopy, cmc, snowhk, chk, cmm, chh + real(kind=kind_phys), dimension(im), intent(inout) :: weasd_save, snwdph_save, tsfc_save, canopy_save + real(kind=kind_phys), dimension(im,nsoil), intent(inout) :: smc_save, stc_save, slc_save + real(kind=kind_phys), dimension(im), intent(inout) :: ep, evap, hflx, gflux, drain, evbs, evcw, trans, sbsno, snowc, snohf + real(kind=kind_phys), dimension(nsoil), intent(inout) :: sthick + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +! local Variables + integer :: i, k + real(kind=kind_phys) :: sneqv + + REAL, PARAMETER :: A2=17.67,A3=273.15,A4=29.65, & + A23M4=A2*(A3-A4) + real(kind=kind_phys), parameter, dimension(4) :: zsoil = (/ -0.1,-0.4,-1.0,-2.0/) !what if nsoil /= 4? + +!> - Initialize CCPP error handling variables + + errmsg = '' + errflg = 0 + + !from module_sf_noahdrv.F/lsminit + if (.not. restart .and. first_time_step .and. ialb == 0) then + do i = 1, im + snoalb(i) = maxalb(int(0.5 + vtype(i)))*0.01 + end do + end if + + do i=1, im + if (land(i) .and. flag_guess(i)) then + weasd_save(i) = weasd(i) + snwdph_save(i) = snwdph(i) + tsfc_save(i) = tsfc(i) + canopy_save(i) = canopy(i) + + do k=1,nsoil + smc_save(i,k) = smc(i,k) + stc_save(i,k) = stc(i,k) + slc_save(i,k) = slc(i,k) + end do + end if + end do + + sthick(1) = - zsoil(1) + do k = 2, nsoil + sthick(k) = zsoil(k-1) - zsoil(k) + enddo + + flag_lsm(:) = .false. + flag_lsm_glacier(:) = .false. + do i=1, im + if (flag_iter(i) .and. land(i)) then + if (vtype(i) == isice) then + flag_lsm_glacier(i) = .true. + else + flag_lsm(i) = .true. + end if + !GJF: module_sf_noahdrv.F from WRF has hardcoded slopetyp = 1; why? replicate here? + !GJF: shdfac is zeroed out for particular combinations of vegetation table source and vegetation types; replicate here? + + ep(i) = 0.0 + evap (i) = 0.0 + hflx (i) = 0.0 + gflux(i) = 0.0 + drain(i) = 0.0 + + evbs (i) = 0.0 + evcw (i) = 0.0 + trans(i) = 0.0 + sbsno(i) = 0.0 + snowc(i) = 0.0 + snohf(i) = 0.0 + + !GJF: could potentially pass in pre-calculated rates instead of calculating here + prcp(i) = rhowater * tprcp(i) / dt + + !GJF: The GFS version of NOAH prepares the specific humidity in sfc_drv.f as follows: + q2k(i) = max(q1(i), 1.e-8) + rho1(i) = sfcprs(i) / (rd*sfctmp(i)*(1.0+rvrdm1*q2k(i))) + + qs1(i) = fpvs( sfctmp(i) ) + qs1(i) = max(eps*qs1(i) / (sfcprs(i)+epsm1*qs1(i)), 1.e-8) + q2k(i) = min(qs1(i), q2k(i)) + + !GJF: could potentially pass in pre-calcualted potential temperature if other schemes also need it (to avoid redundant calculation) + th1(i) = sfctmp(i) * prslki(i) + + !GJF: module_sf_noahdrv.F from WRF modifies dqsdt2 if the surface has snow. + dqsdt2(i)=qs1(i)*a23m4/(sfctmp(i)-a4)**2 + + !GJF: convert canopy moisture from kg m-2 to m + canopy(i) = max(canopy(i), 0.0) !check for positive values in sfc_drv.f + cmc(i) = canopy(i)/rhowater + + !GJF: snow depth passed in to NOAH is conditionally modified differently in GFS and WRF: + sneqv = weasd(i) * 0.001 + snowhk(i) = snwdph(i) * 0.001 + if ( (sneqv /= 0.0 .and. snowhk(i) == 0.) .or. (snowhk(i) <= sneqv) ) then + snowhk(i) = 5.*sneqv + end if + !GJF: GFS version: + ! if (sneqv(i) /= 0.0 .and. snwdph(i) == 0.0) then + ! snowhk(i) = 10.0 * sneqv(i) + ! endif + + !GJF: calculate conductance from surface exchange coefficient + chk(i) = ch(i) * wind(i) + + chh(i) = chk(i) * rho1(i) + cmm(i) = cm(i) * wind(i) + + +!GJF: If the perturbations of vegetation fraction is desired, one could uncomment this code +! and add appropriate arguments to make this work. This is from the GFS version of NOAH LSM +! in sfc_drv.f. + +!> - Call surface_perturbation::ppfbet() to perturb vegetation fraction that goes into gsflx(). +! perturb vegetation fraction that goes into sflx, use the same +! perturbation strategy as for albedo (percentile matching) +!! Following Gehne et al. (2018) \cite gehne_et_al_2018, a perturbation of vegetation +!! fraction is added to account for the uncertainty. A percentile matching technique +!! is applied to guarantee the perturbed vegetation fraction is bounded between 0 and +!! 1. The standard deviation of the perturbations is 0.25 for vegetation fraction of +!! 0.5 and the perturbations go to zero as vegetation fraction approaches its upper +!! or lower bound. + ! vegfp = vegfpert(i) ! sfc-perts, mgehne + ! if (pertvegf(1)>0.0) then + ! ! compute beta distribution parameters for vegetation fraction + ! mv = shdfac + ! sv = pertvegf(1)*mv*(1.-mv) + ! alphav = mv*mv*(1.0-mv)/(sv*sv)-mv + ! betav = alphav*(1.0-mv)/mv + ! ! compute beta distribution value corresponding + ! ! to the given percentile albPpert to use as new albedo + ! call ppfbet(vegfp,alphav,betav,iflag,vegftmp) + ! shdfac = vegftmp + ! endif +! *** sfc-perts, mgehne + endif + end do + + + end subroutine sfc_noah_wrfv4_pre_run + + subroutine soil_veg_gen_parm( mminlu, mminsl, errmsg, errflg) + !this routine is mostly taken from module_sf_noahdrv.F in WRF + use module_sf_noahlsm, only: shdtbl, nrotbl, rstbl, rgltbl, hstbl, snuptbl, & ! begin land use / vegetation variables + maxalb, laimintbl, laimaxtbl, z0mintbl, z0maxtbl, & + albedomintbl, albedomaxtbl, ztopvtbl,zbotvtbl, & + emissmintbl, emissmaxtbl, topt_data, cmcmax_data, & + cfactr_data, rsmax_data, bare, natural, & + low_density_residential, high_density_residential, & + high_intensity_industrial, lucats, lutype, & !end land use / vegetation variables + bb,drysmc,f11, & ! begin soil variables + maxsmc, refsmc,satpsi,satdk,satdw, wltsmc,qtz,& + slcats, sltype, & ! end soil variables + slope_data, sbeta_data,fxexp_data,csoil_data,salp_data,refdk_data, & ! begin NOAH "general" variables + refkdt_data,frzk_data,zbot_data, smlow_data,smhigh_data, & + czil_data, lvcoef_data, slpcats ! end NOAH "general" variables + implicit none + + character(len=*), intent(in) :: mminlu, mminsl + character(len=*), intent(inout) :: errmsg + integer, intent(inout) :: errflg + + integer :: lumatch, iindex, lc, num_slope, iunit_noah + integer :: ierr + integer , parameter :: open_ok = 0 + logical :: opened + + character*128 :: mess , message + character*256 :: a_string + integer , parameter :: loop_max = 10 + integer :: loop_count, i + +!-----SPECIFY VEGETATION RELATED CHARACTERISTICS : +! ALBBCK: SFC albedo (in percentage) +! Z0: Roughness length (m) +! SHDFAC: Green vegetation fraction (in percentage) +! Note: The ALBEDO, Z0, and SHDFAC values read from the following table +! ALBEDO, amd Z0 are specified in LAND-USE TABLE; and SHDFAC is +! the monthly green vegetation data +! CMXTBL: MAX CNPY Capacity (m) +! NROTBL: Rooting depth (layer) +! RSMIN: Mimimum stomatal resistance (s m-1) +! RSMAX: Max. stomatal resistance (s m-1) +! RGL: Parameters used in radiation stress function +! HS: Parameter used in vapor pressure deficit functio +! TOPT: Optimum transpiration air temperature. (K) +! CMCMAX: Maximum canopy water capacity +! CFACTR: Parameter used in the canopy inteception calculati +! SNUP: Threshold snow depth (in water equivalent m) that +! implies 100% snow cover +! LAI: Leaf area index (dimensionless) +! MAXALB: Upper bound on maximum albedo over deep snow +! +!-----READ IN VEGETAION PROPERTIES FROM VEGPARM.TBL +! + iunit_noah = -1 + do i = 20,99 + inquire ( i , opened = opened ) + if ( .not. opened ) then + iunit_noah = i + exit + endif + enddo + + if ( iunit_noah < 0 ) then + errflg = 1 + errmsg = 'sfc_noah_wrfv4_interstitial: set_soil_veg_parm: '// & + 'can not find unused fortran unit to read.' + return + endif + + open(iunit_noah, file='VEGPARM.TBL',form='formatted',status='old',iostat=ierr) + if(ierr .ne. open_ok ) then + errflg = 1 + errmsg = 'sfc_noah_wrfv4_interstitial: set_soil_veg_parm: failure opening VEGPARM.TBL' + return + end if + + lumatch=0 + + loop_count = 0 + read (iunit_noah,fmt='(a)',end=2002) a_string + find_lutype : do while (lumatch == 0) + read (iunit_noah,*,end=2002)lutype + read (iunit_noah,*)lucats,iindex + if(lutype.eq.mminlu)then + !write( mess , * ) 'landuse type = ' // trim ( lutype ) // ' found', lucats,' categories' + !call wrf_message( mess ) + lumatch=1 + else + loop_count = loop_count+1 + !call wrf_message ( "skipping over lutype = " // trim ( lutype ) ) + find_vegetation_parameter_flag : do + read (iunit_noah,fmt='(a)', end=2002) a_string + if ( a_string(1:21) .eq. 'Vegetation Parameters' ) then + exit find_vegetation_parameter_flag + else if ( loop_count .ge. loop_max ) then + errflg = 1 + errmsg = 'sfc_noah_wrfv4_interstitial: set_soil_veg_parm: too many loops in VEGPARM.TBL' + return + endif + enddo find_vegetation_parameter_flag + endif + enddo find_lutype + +! prevent possible array overwrite, Bill Bovermann, IBM, May 6, 2008 + if ( size(shdtbl) < lucats .or. & + size(nrotbl) < lucats .or. & + size(rstbl) < lucats .or. & + size(rgltbl) < lucats .or. & + size(hstbl) < lucats .or. & + size(snuptbl) < lucats .or. & + size(maxalb) < lucats .or. & + size(laimintbl) < lucats .or. & + size(laimaxtbl) < lucats .or. & + size(z0mintbl) < lucats .or. & + size(z0maxtbl) < lucats .or. & + size(albedomintbl) < lucats .or. & + size(albedomaxtbl) < lucats .or. & + size(ztopvtbl) < lucats .or. & + size(zbotvtbl) < lucats .or. & + size(emissmintbl ) < lucats .or. & + size(emissmaxtbl ) < lucats ) then + errflg = 1 + errmsg = 'sfc_noah_wrfv4_interstitial: set_soil_veg_parm: table sizes too small for value of lucats' + return + endif + + if(lutype.eq.mminlu)then + do lc=1,lucats + read (iunit_noah,*)iindex,shdtbl(lc), & + nrotbl(lc),rstbl(lc),rgltbl(lc),hstbl(lc), & + snuptbl(lc),maxalb(lc), laimintbl(lc), & + laimaxtbl(lc),emissmintbl(lc), & + emissmaxtbl(lc), albedomintbl(lc), & + albedomaxtbl(lc), z0mintbl(lc), z0maxtbl(lc),& + ztopvtbl(lc), zbotvtbl(lc) + enddo + + read (iunit_noah,*) + read (iunit_noah,*)topt_data + read (iunit_noah,*) + read (iunit_noah,*)cmcmax_data + read (iunit_noah,*) + read (iunit_noah,*)cfactr_data + read (iunit_noah,*) + read (iunit_noah,*)rsmax_data + read (iunit_noah,*) + read (iunit_noah,*)bare + read (iunit_noah,*) + read (iunit_noah,*)natural + read (iunit_noah,*) + read (iunit_noah,*) + read (iunit_noah,fmt='(a)') a_string + if ( a_string(1:21) .eq. 'Vegetation Parameters' ) then + errflg = 1 + errmsg = 'sfc_noah_wrfv4_interstitial: set_soil_veg_parm: expected low and high density residential, and high density industrial information in VEGPARM.TBL' + return + endif + read (iunit_noah,*)low_density_residential + read (iunit_noah,*) + read (iunit_noah,*)high_density_residential + read (iunit_noah,*) + read (iunit_noah,*)high_intensity_industrial + endif + +2002 continue + + close (iunit_noah) + if (lumatch == 0) then + errflg = 1 + errmsg = 'sfc_noah_wrfv4_interstitial: set_soil_veg_parm: land use dataset '//mminlu//' not found in VEGPARM.TBL.' + return + endif + + + !CALL wrf_dm_bcast_string ( LUTYPE , 4 ) + !CALL wrf_dm_bcast_integer ( LUCATS , 1 ) + !CALL wrf_dm_bcast_integer ( IINDEX , 1 ) + !CALL wrf_dm_bcast_integer ( LUMATCH , 1 ) + !CALL wrf_dm_bcast_real ( SHDTBL , NLUS ) + !CALL wrf_dm_bcast_real ( NROTBL , NLUS ) + !CALL wrf_dm_bcast_real ( RSTBL , NLUS ) + !CALL wrf_dm_bcast_real ( RGLTBL , NLUS ) + !CALL wrf_dm_bcast_real ( HSTBL , NLUS ) + !CALL wrf_dm_bcast_real ( SNUPTBL , NLUS ) + !CALL wrf_dm_bcast_real ( LAIMINTBL , NLUS ) + !CALL wrf_dm_bcast_real ( LAIMAXTBL , NLUS ) + !CALL wrf_dm_bcast_real ( Z0MINTBL , NLUS ) + !CALL wrf_dm_bcast_real ( Z0MAXTBL , NLUS ) + !CALL wrf_dm_bcast_real ( EMISSMINTBL , NLUS ) + !CALL wrf_dm_bcast_real ( EMISSMAXTBL , NLUS ) + !CALL wrf_dm_bcast_real ( ALBEDOMINTBL , NLUS ) + !CALL wrf_dm_bcast_real ( ALBEDOMAXTBL , NLUS ) + !CALL wrf_dm_bcast_real ( ZTOPVTBL , NLUS ) + !CALL wrf_dm_bcast_real ( ZBOTVTBL , NLUS ) + !CALL wrf_dm_bcast_real ( MAXALB , NLUS ) + !CALL wrf_dm_bcast_real ( TOPT_DATA , 1 ) + !CALL wrf_dm_bcast_real ( CMCMAX_DATA , 1 ) + !CALL wrf_dm_bcast_real ( CFACTR_DATA , 1 ) + !CALL wrf_dm_bcast_real ( RSMAX_DATA , 1 ) + !CALL wrf_dm_bcast_integer ( BARE , 1 ) + !CALL wrf_dm_bcast_integer ( NATURAL , 1 ) + !CALL wrf_dm_bcast_integer ( LOW_DENSITY_RESIDENTIAL , 1 ) + !CALL wrf_dm_bcast_integer ( HIGH_DENSITY_RESIDENTIAL , 1 ) + !CALL wrf_dm_bcast_integer ( HIGH_INTENSITY_INDUSTRIAL , 1 ) + +! +!-----READ IN SOIL PROPERTIES FROM SOILPARM.TBL +! + + open(iunit_noah, file='SOILPARM.TBL',form='formatted',status='old',iostat=ierr) + if(ierr .ne. open_ok ) then + errflg = 1 + errmsg = 'sfc_noah_wrfv4_interstitial: set_soil_veg_parm: failure opening SOILPARM.TBL' + return + end if + + !write(mess,*) 'input soil texture classification = ', trim ( mminsl ) + !call wrf_message( mess ) + + lumatch=0 + + read (iunit_noah,*) + read (iunit_noah,2000,end=2003)sltype +2000 format (a4) + read (iunit_noah,*)slcats,iindex + if(sltype.eq.mminsl)then + !write( mess , * ) 'soil texture classification = ', trim ( sltype ) , ' found', & + ! slcats,' categories' + !call wrf_message ( mess ) + lumatch=1 + endif +! prevent possible array overwrite, bill bovermann, ibm, may 6, 2008 + if ( size(bb ) < slcats .or. & + size(drysmc) < slcats .or. & + size(f11 ) < slcats .or. & + size(maxsmc) < slcats .or. & + size(refsmc) < slcats .or. & + size(satpsi) < slcats .or. & + size(satdk ) < slcats .or. & + size(satdw ) < slcats .or. & + size(wltsmc) < slcats .or. & + size(qtz ) < slcats ) then + errflg = 1 + errmsg = 'sfc_noah_wrfv4_interstitial: set_soil_veg_parm: table sizes too small for value of slcats' + return + endif + if(sltype.eq.mminsl)then + do lc=1,slcats + read (iunit_noah,*) iindex,bb(lc),drysmc(lc),f11(lc),maxsmc(lc),& + refsmc(lc),satpsi(lc),satdk(lc), satdw(lc), & + wltsmc(lc), qtz(lc) + enddo + endif + +2003 continue + + close (iunit_noah) + + + ! CALL wrf_dm_bcast_integer ( LUMATCH , 1 ) + ! CALL wrf_dm_bcast_string ( SLTYPE , 4 ) + ! CALL wrf_dm_bcast_string ( MMINSL , 4 ) ! since this is reset above, see oct2 ^ + ! CALL wrf_dm_bcast_integer ( SLCATS , 1 ) + ! CALL wrf_dm_bcast_integer ( IINDEX , 1 ) + ! CALL wrf_dm_bcast_real ( BB , NSLTYPE ) + ! CALL wrf_dm_bcast_real ( DRYSMC , NSLTYPE ) + ! CALL wrf_dm_bcast_real ( F11 , NSLTYPE ) + ! CALL wrf_dm_bcast_real ( MAXSMC , NSLTYPE ) + ! CALL wrf_dm_bcast_real ( REFSMC , NSLTYPE ) + ! CALL wrf_dm_bcast_real ( SATPSI , NSLTYPE ) + ! CALL wrf_dm_bcast_real ( SATDK , NSLTYPE ) + ! CALL wrf_dm_bcast_real ( SATDW , NSLTYPE ) + ! CALL wrf_dm_bcast_real ( WLTSMC , NSLTYPE ) + ! CALL wrf_dm_bcast_real ( QTZ , NSLTYPE ) + + if(lumatch.eq.0)then + errflg = 1 + errmsg = 'sfc_noah_wrfv4_interstitial: set_soil_veg_parm: soil texture dataset '//mminsl//' not found in SOILPARM.TBL.' + return + endif + +! +!-----READ IN GENERAL PARAMETERS FROM GENPARM.TBL +! + + open(iunit_noah, file='GENPARM.TBL',form='formatted',status='old',iostat=ierr) + if(ierr .ne. open_ok ) then + errflg = 1 + errmsg = 'sfc_noah_wrfv4_interstitial: set_soil_veg_parm: failure opening GENPARM.TBL' + return + end if + + read (iunit_noah,*) + read (iunit_noah,*) + read (iunit_noah,*) num_slope + + slpcats=num_slope +! prevent possible array overwrite, bill bovermann, ibm, may 6, 2008 + if ( size(slope_data) < num_slope ) then + errflg = 1 + errmsg = 'sfc_noah_wrfv4_interstitial: set_soil_veg_parm: num_slope too large for slope_data array' + return + endif + + do lc=1,slpcats + read (iunit_noah,*)slope_data(lc) + enddo + + read (iunit_noah,*) + read (iunit_noah,*)sbeta_data + read (iunit_noah,*) + read (iunit_noah,*)fxexp_data + read (iunit_noah,*) + read (iunit_noah,*)csoil_data + read (iunit_noah,*) + read (iunit_noah,*)salp_data + read (iunit_noah,*) + read (iunit_noah,*)refdk_data + read (iunit_noah,*) + read (iunit_noah,*)refkdt_data + read (iunit_noah,*) + read (iunit_noah,*)frzk_data + read (iunit_noah,*) + read (iunit_noah,*)zbot_data + read (iunit_noah,*) + read (iunit_noah,*)czil_data + read (iunit_noah,*) + read (iunit_noah,*)smlow_data + read (iunit_noah,*) + read (iunit_noah,*)smhigh_data + read (iunit_noah,*) + read (iunit_noah,*)lvcoef_data + close (iunit_noah) + + + ! call wrf_dm_bcast_integer ( num_slope , 1 ) + ! call wrf_dm_bcast_integer ( slpcats , 1 ) + ! call wrf_dm_bcast_real ( slope_data , nslope ) + ! call wrf_dm_bcast_real ( sbeta_data , 1 ) + ! call wrf_dm_bcast_real ( fxexp_data , 1 ) + ! call wrf_dm_bcast_real ( csoil_data , 1 ) + ! call wrf_dm_bcast_real ( salp_data , 1 ) + ! call wrf_dm_bcast_real ( refdk_data , 1 ) + ! call wrf_dm_bcast_real ( refkdt_data , 1 ) + ! call wrf_dm_bcast_real ( frzk_data , 1 ) + ! call wrf_dm_bcast_real ( zbot_data , 1 ) + ! call wrf_dm_bcast_real ( czil_data , 1 ) + ! call wrf_dm_bcast_real ( smlow_data , 1 ) + ! call wrf_dm_bcast_real ( smhigh_data , 1 ) + ! call wrf_dm_bcast_real ( lvcoef_data , 1 ) + + end subroutine soil_veg_gen_parm +!----------------------------- +!> @} + + end module sfc_noah_wrfv4_pre + + module sfc_noah_wrfv4_post + + implicit none + + private + + public :: sfc_noah_wrfv4_post_init, sfc_noah_wrfv4_post_run, sfc_noah_wrfv4_post_finalize + + contains + + subroutine sfc_noah_wrfv4_post_init () + end subroutine sfc_noah_wrfv4_post_init + + subroutine sfc_noah_wrfv4_post_finalize () + end subroutine sfc_noah_wrfv4_post_finalize + +!! \section arg_table_sfc_noah_wrfv4_post_run Argument Table +!! \htmlinclude sfc_noah_wrfv4_post_run.html +!! + subroutine sfc_noah_wrfv4_post_run (im, nsoil, land, flag_guess, flag_lsm, & + rhowater, cp, hvap, cmc, rho1, sheat, eta, flx1, flx2, flx3, sncovr, runoff1,& + runoff2, soilm, snowhk, weasd_save, snwdph_save, tsfc_save, tsurf, & + canopy_save, smc_save, stc_save, slc_save, smcmax, canopy, shflx, & + lhflx, snohf, snowc, runoff, drain, stm, weasd, snwdph, tsfc, smc, stc,& + slc, wet1, errmsg, errflg) + + use machine, only : kind_phys + + implicit none + + integer, intent(in) :: im, nsoil + logical, dimension(im), intent(in) :: land, flag_guess, flag_lsm + real(kind=kind_phys), intent(in) :: rhowater, cp, hvap + real(kind=kind_phys), dimension(im), intent(in) :: cmc, rho1, sheat, eta, & + flx1, flx2, flx3, sncovr, runoff1, runoff2, soilm, snowhk + real(kind=kind_phys), dimension(im), intent(in) :: weasd_save, snwdph_save, tsfc_save, tsurf, canopy_save, smcmax + real(kind=kind_phys), dimension(im,nsoil), intent(in) :: smc_save, stc_save, slc_save + + real(kind=kind_phys), dimension(im), intent(inout) :: canopy, shflx, lhflx, & + snohf, snowc, runoff, drain, stm, wet1 + real(kind=kind_phys), dimension(im), intent(inout) :: weasd, snwdph, tsfc + real(kind=kind_phys), dimension(im, nsoil), intent(inout) :: smc, stc, slc + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + !local variables + integer :: i, k + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + do i=1, im + if (flag_lsm(i)) then + canopy(i) = cmc(i)*rhowater + snwdph(i) = 1000.0*snowhk(i) + + shflx(i) = sheat(i) / (cp*rho1(i)) + lhflx(i) = eta(i) / (hvap*rho1(i)) + + !aggregating several outputs into one like GFS sfc_drv.F + snohf(i) = flx1(i) + flx2(i) + flx3(i) + + snowc(i) = sncovr(i) !GJF: redundant? + + !convert from m s-1 to kg m-2 s-1 by multiplying by rhowater + runoff(i) = runoff1(i) * rhowater + drain(i) = runoff2(i) * rhowater + + stm(i) = soilm(i) * rhowater + + wet1(i) = smc(i,1) / smcmax(i) !Sarah Lu added 09/09/2010 (for GOCART) + end if + end do + + do i=1, im + if (land(i)) then + if (flag_guess(i)) then + weasd(i) = weasd_save(i) + snwdph(i) = snwdph_save(i) + tsfc(i) = tsfc_save(i) + canopy(i) = canopy_save(i) + + do k=1,nsoil + smc(i,k) = smc_save(i,k) + stc(i,k) = stc_save(i,k) + slc(i,k) = slc_save(i,k) + end do + + else + tsfc(i) = tsurf(i) + end if + end if + end do + + end subroutine sfc_noah_wrfv4_post_run + + end module sfc_noah_wrfv4_post diff --git a/physics/sfc_noah_wrfv4_interstitial.meta b/physics/sfc_noah_wrfv4_interstitial.meta new file mode 100644 index 000000000..e993780fd --- /dev/null +++ b/physics/sfc_noah_wrfv4_interstitial.meta @@ -0,0 +1,1098 @@ +[ccpp-arg-table] + name = sfc_noah_wrfv4_pre_init + type = scheme +[lsm] + standard_name = flag_for_land_surface_scheme + long_name = flag for land surface model + units = flag + dimensions = () + type = integer + intent = in + optional = F +[lsm_noah_wrfv4] + standard_name = flag_for_noah_wrfv4_land_surface_scheme + long_name = flag for NOAH WRFv4 land surface model + units = flag + dimensions = () + type = integer + intent = in + optional = F +[veg_data_choice] + standard_name = vegetation_type_dataset_choice + long_name = land use dataset choice + units = index + dimensions = () + type = integer + intent = in + optional = F +[soil_data_choice] + standard_name = soil_type_dataset_choice + long_name = soil type dataset choice + units = index + dimensions = () + type = integer + intent = in + optional = F +[isurban] + standard_name = urban_vegetation_category + long_name = index of the urban vegetation category in the chosen vegetation dataset + units = index + dimensions = () + type = integer + intent = inout + optional = F +[isice] + standard_name = ice_vegetation_category + long_name = index of the permanent snow/ice category in the chosen vegetation dataset + units = index + dimensions = () + type = integer + intent = inout + optional = F +[iswater] + standard_name = water_vegetation_category + long_name = index of the water body vegetation category in the chosen vegetation dataset + units = index + dimensions = () + type = integer + intent = inout + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-arg-table] + name = sfc_noah_wrfv4_pre_finalize + type = scheme +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-arg-table] + name = sfc_noah_wrfv4_pre_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[nsoil] + standard_name = soil_vertical_dimension + long_name = soil vertical layer dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[ialb] + standard_name = flag_for_using_climatology_albedo + long_name = flag for using climatology alb, based on sfc type + units = flag + dimensions = () + type = integer + intent = in + optional = F +[isice] + standard_name = ice_vegetation_category + long_name = index of the permanent snow/ice category in the chosen vegetation dataset + units = index + dimensions = () + type = integer + intent = in + optional = F +[land] + standard_name = flag_nonzero_land_surface_fraction + long_name = flag indicating presence of some land surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in + optional = F +[flag_guess] + standard_name = flag_for_guess_run + long_name = flag for guess run + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in + optional = F +[flag_iter] + standard_name = flag_for_iteration + long_name = flag for iteration + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in + optional = F +[restart] + standard_name = flag_for_restart + long_name = flag for restart (warmstart) or coldstart + units = flag + dimensions = () + type = logical + intent = in + optional = F +[first_time_step] + standard_name = flag_for_first_time_step + long_name = flag for first time step for time integration loop (cold/warmstart) + units = flag + dimensions = () + type = logical + intent = in + optional = F +[flag_lsm] + standard_name = flag_for_calling_land_surface_model + long_name = flag for calling land surface model + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = inout + optional = F +[flag_lsm_glacier] + standard_name = flag_for_calling_land_surface_model_glacier + long_name = flag for calling land surface model over glacier + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = inout + optional = F +[dt] + standard_name = time_step_for_dynamics + long_name = dynamics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[rhowater] + standard_name = liquid_water_density + long_name = density of liquid water + units = kg m-3 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[rd] + standard_name = gas_constant_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[rvrdm1] + standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one + long_name = (rv/rd) - 1 (rv = ideal gas constant for water vapor) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[eps] + standard_name = ratio_of_dry_air_to_water_vapor_gas_constants + long_name = rd/rv + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[epsm1] + standard_name = ratio_of_dry_air_to_water_vapor_gas_constants_minus_one + long_name = (rd/rv) - 1 + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[sfcprs] + standard_name = air_pressure_at_lowest_model_layer + long_name = Model layer 1 mean pressure + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[tprcp] + standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_land + long_name = total precipitation amount in each time step over land + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[sfctmp] + standard_name = air_temperature_at_lowest_model_layer + long_name = 1st model layer air temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[q1] + standard_name = water_vapor_specific_humidity_at_lowest_model_layer + long_name = 1st model layer specific humidity + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[prslki] + standard_name = ratio_of_exner_function_between_midlayer_and_interface_at_lowest_model_layer + long_name = Exner function ratio bt midlayer and interface at 1st layer + units = ratio + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[wind] + standard_name = wind_speed_at_lowest_model_layer + long_name = wind speed at lowest model level + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[snwdph] + standard_name = surface_snow_thickness_water_equivalent_over_land + long_name = water equivalent snow depth over land + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[cm] + standard_name = surface_drag_coefficient_for_momentum_in_air_over_land + long_name = surface exchange coeff for momentum over land + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[ch] + standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air_over_land + long_name = surface exchange coeff heat & moisture over land + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[weasd] + standard_name = water_equivalent_accumulated_snow_depth_over_land + long_name = water equiv of acc snow depth over land + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[tsfc] + standard_name = surface_skin_temperature_over_land_interstitial + long_name = surface skin temperature over land (temporary use as interstitial) + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[vtype] + standard_name = vegetation_type_classification_real + long_name = vegetation type for lsm + units = index + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[smc] + standard_name = volume_fraction_of_soil_moisture + long_name = volumetric fraction of soil moisture + units = frac + dimensions = (horizontal_loop_extent,soil_vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[stc] + standard_name = soil_temperature + long_name = soil temperature + units = K + dimensions = (horizontal_loop_extent,soil_vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[slc] + standard_name = volume_fraction_of_unfrozen_soil_moisture + long_name = liquid soil moisture + units = frac + dimensions = (horizontal_loop_extent,soil_vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[snoalb] + standard_name = upper_bound_on_max_albedo_over_deep_snow + long_name = maximum snow albedo + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[prcp] + standard_name = total_precipitation_rate_on_dynamics_timestep_over_land + long_name = total precipitation rate in each time step over land + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[q2k] + standard_name = bounded_specific_humidity_at_lowest_model_layer_over_land + long_name = specific humidity at lowest model layer over land bounded between a nonzero epsilon and saturation + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[rho1] + standard_name = air_density_at_lowest_model_layer + long_name = air density at lowest model layer + units = kg m-3 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[qs1] + standard_name = saturation_specific_humidity_at_lowest_model_layer + long_name = saturation specific humidity at lowest model layer + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[th1] + standard_name = potential_temperature_at_lowest_model_layer + long_name = potential_temperature_at_lowest_model_layer + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[dqsdt2] + standard_name = saturation_specific_humidity_slope + long_name = saturation specific humidity slope at lowest model layer + units = K-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[canopy] + standard_name = canopy_water_amount + long_name = canopy moisture content + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[cmc] + standard_name = canopy_water_amount_in_m + long_name = canopy water amount in m + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[snowhk] + standard_name = actual_snow_depth + long_name = actual snow depth + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[chk] + standard_name = surface_conductance_for_heat_and_moisture_in_air_over_land + long_name = surface conductance for heat & moisture over land + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[cmm] + standard_name = surface_drag_wind_speed_for_momentum_in_air_over_land + long_name = momentum exchange coefficient over land + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[chh] + standard_name = surface_drag_mass_flux_for_heat_and_moisture_in_air_over_land + long_name = thermal exchange coefficient over land + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[weasd_save] + standard_name = water_equivalent_accumulated_snow_depth_over_land_save + long_name = water equiv of acc snow depth over land before entering a physics scheme + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[snwdph_save] + standard_name = surface_snow_thickness_water_equivalent_over_land_save + long_name = water equivalent snow depth over land before entering a physics scheme + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tsfc_save] + standard_name = surface_skin_temperature_over_land_interstitial_save + long_name = surface skin temperature over land before entering a physics scheme (temporary use as interstitial) + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[canopy_save] + standard_name = canopy_water_amount_save + long_name = canopy water amount before entering a physics scheme + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[smc_save] + standard_name = volume_fraction_of_soil_moisture_save + long_name = total soil moisture before entering a physics scheme + units = frac + dimensions = (horizontal_loop_extent,soil_vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[stc_save] + standard_name = soil_temperature_save + long_name = soil temperature before entering a physics scheme + units = K + dimensions = (horizontal_loop_extent,soil_vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[slc_save] + standard_name = volume_fraction_of_unfrozen_soil_moisture_save + long_name = liquid soil moisture before entering a physics scheme + units = frac + dimensions = (horizontal_loop_extent,soil_vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ep] + standard_name = surface_upward_potential_latent_heat_flux_over_land + long_name = surface upward potential latent heat flux over land + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[evap] + standard_name = kinematic_surface_upward_latent_heat_flux_over_land + long_name = kinematic surface upward latent heat flux over land + units = kg kg-1 m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[hflx] + standard_name = kinematic_surface_upward_sensible_heat_flux_over_land + long_name = kinematic surface upward sensible heat flux over land + units = K m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[gflux] + standard_name = upward_heat_flux_in_soil_over_land + long_name = soil heat flux over land + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[drain] + standard_name = subsurface_runoff_flux + long_name = subsurface runoff flux + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[evbs] + standard_name = soil_upward_latent_heat_flux + long_name = soil upward latent heat flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[evcw] + standard_name = canopy_upward_latent_heat_flux + long_name = canopy upward latent heat flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[trans] + standard_name = transpiration_flux + long_name = total plant transpiration rate + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[sbsno] + standard_name = snow_deposition_sublimation_upward_latent_heat_flux + long_name = latent heat flux from snow depo/subl + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[snowc] + standard_name = surface_snow_area_fraction + long_name = surface snow area fraction + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[snohf] + standard_name = snow_freezing_rain_upward_latent_heat_flux + long_name = latent heat flux due to snow and frz rain + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[sthick] + standard_name = soil_layer_thickness + long_name = soil layer thickness + units = m + dimensions = (soil_vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-arg-table] + name = sfc_noah_wrfv4_post_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[nsoil] + standard_name = soil_vertical_dimension + long_name = soil vertical layer dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[land] + standard_name = flag_nonzero_land_surface_fraction + long_name = flag indicating presence of some land surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in + optional = F +[flag_guess] + standard_name = flag_for_guess_run + long_name = flag for guess run + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in + optional = F +[flag_lsm] + standard_name = flag_for_calling_land_surface_model + long_name = flag for calling land surface model + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in + optional = F +[rhowater] + standard_name = liquid_water_density + long_name = density of liquid water + units = kg m-3 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[hvap] + standard_name = latent_heat_of_vaporization_of_water_at_0C + long_name = latent heat of evaporation/sublimation + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[cmc] + standard_name = canopy_water_amount_in_m + long_name = canopy water amount in m + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[rho1] + standard_name = air_density_at_lowest_model_layer + long_name = air density at lowest model layer + units = kg m-3 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[sheat] + standard_name = instantaneous_surface_upward_sensible_heat_flux + long_name = surface upward sensible heat flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[eta] + standard_name = instantaneous_surface_upward_latent_heat_flux + long_name = surface upward latent heat flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[flx1] + standard_name = latent_heat_flux_from_precipitating_snow + long_name = latent heat flux due to precipitating snow + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[flx2] + standard_name = latent_heat_flux_from_freezing_rain + long_name = latent heat flux due to freezing rain + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[flx3] + standard_name = latent_heat_flux_due_to_snowmelt + long_name = latent heat flux due to snowmelt phase change + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[sncovr] + standard_name = surface_snow_area_fraction_over_land + long_name = surface snow area fraction + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[runoff1] + standard_name = surface_runoff_flux_in_m_sm1 + long_name = surface runoff flux in m s-1 + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[runoff2] + standard_name = subsurface_runoff_flux_in_m_sm1 + long_name = subsurface runoff flux in m s-1 + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[soilm] + standard_name = soil_moisture_content_in_m + long_name = soil moisture in meters + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[snowhk] + standard_name = actual_snow_depth + long_name = actual snow depth + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[weasd_save] + standard_name = water_equivalent_accumulated_snow_depth_over_land_save + long_name = water equiv of acc snow depth over land before entering a physics scheme + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[snwdph_save] + standard_name = surface_snow_thickness_water_equivalent_over_land_save + long_name = water equivalent snow depth over land before entering a physics scheme + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[tsfc_save] + standard_name = surface_skin_temperature_over_land_interstitial_save + long_name = surface skin temperature over land before entering a physics scheme (temporary use as interstitial) + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[tsurf] + standard_name = surface_skin_temperature_after_iteration_over_land + long_name = surface skin temperature after iteration over land + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[canopy_save] + standard_name = canopy_water_amount_save + long_name = canopy water amount before entering a physics scheme + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[smc_save] + standard_name = volume_fraction_of_soil_moisture_save + long_name = total soil moisture before entering a physics scheme + units = frac + dimensions = (horizontal_loop_extent,soil_vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[stc_save] + standard_name = soil_temperature_save + long_name = soil temperature before entering a physics scheme + units = K + dimensions = (horizontal_loop_extent,soil_vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[slc_save] + standard_name = volume_fraction_of_unfrozen_soil_moisture_save + long_name = liquid soil moisture before entering a physics scheme + units = frac + dimensions = (horizontal_loop_extent,soil_vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[smcmax] + standard_name = soil_porosity + long_name = volumetric soil porosity + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[canopy] + standard_name = canopy_water_amount + long_name = canopy moisture content + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[shflx] + standard_name = kinematic_surface_upward_sensible_heat_flux_over_land + long_name = kinematic surface upward sensible heat flux over land + units = K m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[lhflx] + standard_name = kinematic_surface_upward_latent_heat_flux_over_land + long_name = kinematic surface upward latent heat flux over land + units = kg kg-1 m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[snohf] + standard_name = snow_freezing_rain_upward_latent_heat_flux + long_name = latent heat flux due to snow and frz rain + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[snowc] + standard_name = surface_snow_area_fraction + long_name = surface snow area fraction + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[runoff] + standard_name = surface_runoff_flux + long_name = surface runoff flux + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[drain] + standard_name = subsurface_runoff_flux + long_name = subsurface runoff flux + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[stm] + standard_name = soil_moisture_content + long_name = soil moisture + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[weasd] + standard_name = water_equivalent_accumulated_snow_depth_over_land + long_name = water equiv of acc snow depth over land + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[snwdph] + standard_name = surface_snow_thickness_water_equivalent_over_land + long_name = water equivalent snow depth over land + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tsfc] + standard_name = surface_skin_temperature_over_land_interstitial + long_name = surface skin temperature over land (temporary use as interstitial) + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[smc] + standard_name = volume_fraction_of_soil_moisture + long_name = volumetric fraction of soil moisture + units = frac + dimensions = (horizontal_loop_extent,soil_vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[stc] + standard_name = soil_temperature + long_name = soil temperature + units = K + dimensions = (horizontal_loop_extent,soil_vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[slc] + standard_name = volume_fraction_of_unfrozen_soil_moisture + long_name = liquid soil moisture + units = frac + dimensions = (horizontal_loop_extent,soil_vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[wet1] + standard_name = normalized_soil_wetness + long_name = normalized soil wetness + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F diff --git a/physics/sfc_noahmp_drv.f b/physics/sfc_noahmp_drv.f index 5ddd5aefc..934d4797c 100644 --- a/physics/sfc_noahmp_drv.f +++ b/physics/sfc_noahmp_drv.f @@ -39,6 +39,19 @@ subroutine noahmpdrv_init(me, isot, ivegsrc, nlunit, errmsg, & errmsg = '' errflg = 0 + if (ivegsrc /= 1) then + errmsg = 'The NOAHMP LSM expects that the ivegsrc physics '// + & 'namelist parameter is 1. Exiting...' + errflg = 1 + return + end if + if (isot /= 1) then + errmsg = 'The NOAHMP LSM expects that the isot physics '// + & 'namelist parameter is 1. Exiting...' + errflg = 1 + return + end if + !--- initialize soil vegetation call set_soilveg(me, isot, ivegsrc, nlunit) From d9c5e06bddb2ad529f169b34248a6054a46abf26 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Fri, 15 May 2020 14:46:12 -0600 Subject: [PATCH 23/42] Update GFS_rrtmgp_pre.F90 with progcld changes, update GFS_rrtmgp_setup.meta with standard name changes --- physics/GFS_rrtmgp_pre.F90 | 44 ++++++++++++++++++++++++++++++++--- physics/GFS_rrtmgp_setup.meta | 16 ++++++------- 2 files changed, 49 insertions(+), 11 deletions(-) diff --git a/physics/GFS_rrtmgp_pre.F90 b/physics/GFS_rrtmgp_pre.F90 index 1344f269c..0835f9e9b 100644 --- a/physics/GFS_rrtmgp_pre.F90 +++ b/physics/GFS_rrtmgp_pre.F90 @@ -37,7 +37,8 @@ module GFS_rrtmgp_pre progcld1, & ! Zhao/Moorthi's prognostic cloud scheme progcld3, & ! Zhao/Moorthi's prognostic cloud+pdfcld progcld4, & ! GFDL cloud scheme - progcld5, & ! Thompson / WSM6 cloud micrphysics scheme + progcld5, & ! Ferrier Aligo microphysics scheme + progcld6, & ! Thompson cloud microphysics scheme progclduni ! Unified cloud-scheme use surface_perturbation, only: & cdfnor ! Routine to compute CDF (used to compute percentiles) @@ -740,10 +741,47 @@ subroutine cloud_microphysics(Model, Tbd, Grid, Sfcprop, ncol, tracer, p_lay, t_ mbota, & ! OUT - vertical indices for low, mid, hi cloud bases (NCOL,3) de_lgth) ! OUT - clouds decorrelation length (km) endif - ! *) Thompson / WSM6 cloud micrphysics scheme - elseif(Model%imp_physics == 8 .or. Model%imp_physics == 6) then + ! *) Ferrier-Aligo cloud microphysics scheme + elseif(Model%imp_physics == 15) then call progcld5 ( & ! IN + p_lay/100., & ! IN - Pressure at model layer centers (mb) + p_lev/100., & ! IN - Pressure at model interfaces (mb) + t_lay, & ! IN - Temperature at layer centers (K) + tv_lay, & ! IN - Virtual temperature at layer centers (K) + q_lay, & ! IN - Specific humidity at layer center (kg/kg) + qs_lay, & ! IN - Saturation specific humidity at layer center (kg/kg) + relhum, & ! IN - Relative humidity at layer center (1) + tracer, & ! IN - Cloud condensate amount in layer by type () + Grid%xlat, & ! IN - Latitude (radians) + Grid%xlon, & ! IN - Longitude (radians) + Sfcprop%slmsk, & ! IN - Land/Sea mask () + deltaZ, & ! IN - Layer thickness (km) + deltaP/100., & ! IN - Layer thickness (hPa) + Model%ntrac-1, & ! IN - Number of tracers + Model%ntcw-1, & ! IN - Tracer index for cloud condensate (or liquid water) + Model%ntiw-1, & ! IN - Tracer index for ice + Model%ntrw-1, & ! IN - Tracer index for rain + NCOL, & ! IN - Number of horizontal gridpoints + MODEL%LEVS, & ! IN - Number of model layers + MODEL%LEVS+1, & ! IN - Number of model levels + Model%icloud, & ! IN - cloud effect to the optical depth and cloud fraction in radiation + Model%uni_cld, & ! IN - True for cloud fraction from shoc + Model%lmfshal, & ! IN - True for mass flux shallow convection + Model%lmfdeep2, & ! IN - True for mass flux deep convection + cldcov(:,1:Model%levs), & ! IN - Layer cloud fraction (used if uni_cld=.true.) + Tbd%phy_f3d(:,:,1), & ! IN - Liquid-water effective radius (microns) + Tbd%phy_f3d(:,:,2), & ! IN - Ice-water effective radius (microns) + Tbd%phy_f3d(:,:,3), & ! IN - LSnow-water effective radius (microns) + clouds, & ! OUT - Cloud properties (NCOL,Model%levs,NF_CLDS) + cldsa, & ! OUT - fraction of clouds for low, mid, hi, tot, bl (NCOL,5) + mtopa, & ! OUT - vertical indices for low, mid, hi cloud tops (NCOL,3) + mbota, & ! OUT - vertical indices for low, mid, hi cloud bases (NCOL,3) + de_lgth) ! OUT - clouds decorrelation length (km) + ! *) Thompson cloud microphysics scheme + elseif(Model%imp_physics == 8) then + + call progcld6 ( & ! IN p_lay/100., & ! IN - Pressure at model layer centers (mb) p_lev/100., & ! IN - Pressure at model interfaces (mb) t_lay, & ! IN - Temperature at layer centers (K) diff --git a/physics/GFS_rrtmgp_setup.meta b/physics/GFS_rrtmgp_setup.meta index e40ad865a..e419c7252 100644 --- a/physics/GFS_rrtmgp_setup.meta +++ b/physics/GFS_rrtmgp_setup.meta @@ -99,32 +99,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 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 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 From b850fe7c98d9c195f62fd0887907685c120549c3 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Mon, 18 May 2020 21:26:32 -0600 Subject: [PATCH 24/42] add limits to fh, fh2 --- physics/gfdl_sfc_layer.F90 | 124 ++++++++++++++++++++++++++----------- 1 file changed, 87 insertions(+), 37 deletions(-) diff --git a/physics/gfdl_sfc_layer.F90 b/physics/gfdl_sfc_layer.F90 index edd3f0c30..1b29c166c 100644 --- a/physics/gfdl_sfc_layer.F90 +++ b/physics/gfdl_sfc_layer.F90 @@ -154,6 +154,8 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & integer :: i, its, ite, ims, ime + logical :: ch_bound_excursion + !GJF: the vonKarman constant should come in through the CCPP and be defined by the host model real (kind=kind_phys), parameter :: karman = 0.4 real (kind=kind_phys), parameter :: log01=log(0.01), log05=log(0.05), & @@ -180,7 +182,8 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & xxfh2, tzot real(kind=kind_phys), dimension(1:30) :: maxsmc, drysmc real(kind=kind_phys) :: smcmax, smcdry, zhalf, cd10, & - esat, fm_lnd_old, fh_lnd_old, tem1, tem2, czilc, cdlimit + esat, fm_lnd_old, fh_lnd_old, tem1, tem2, czilc, cd_low_limit, & + cd_high_limit, ch_low_limit, ch_high_limit !#### This block will become unnecessary when maxsmc and drysmc come through the CCPP #### if (lsm == lsm_noah) then @@ -273,8 +276,13 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & zkmax(i) = z1(i) z1_cm(i) = 100.0*z1(i) - !GJF: this drag coefficient lower limit was suggested by Chunxi Zhang via his module_sf_sfclayrev.f90 - cdlimit = 1.0e-5/zkmax(i) + !GJF: these drag coefficient limits were suggested by Chunxi Zhang via his module_sf_sfclayrev.f90 + cd_low_limit = 1.0e-5/zkmax(i) + cd_high_limit = 0.1 + !GJF: use the lower of 0.1 from Chunxi Zhang or 0.05/wspd from WRF's module_sf_gfdl.F + ! (this will always be the latter if wspd has a minimum of 1.0 m s-1 from above) + ch_low_limit = cd_low_limit + ch_high_limit = min(0.1,0.05/wspd(i)) !slwdc... GFDL downward net flux in units of cal/(cm**2/min) !also divide by 10**4 to convert from /m**2 to /cm**2 @@ -396,23 +404,37 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & !taux(i) = fxmx(i)/10. ! gopal's doing for Ocean coupling !tauy(i) = fxmy(i)/10. ! gopal's doing for Ocean coupling + cdm_lnd(i) = max(cdm_lnd(i), cd_low_limit) + cdm_lnd(i) = min(cdm_lnd(i), cd_high_limit) fm_lnd(i) = karman/sqrt(cdm_lnd(i)) + + !1) try fh_lnd from MFLUX2 fh_lnd(i) = karman*xxfh(i) - !GJF: Other CCPP schemes (PBL) ask for fm/fh instead of psim/psih - !psim_lnd(i)=gz1oz0(i)-fm_lnd(i) - !psih_lnd(i)=gz1oz0(i)-fh_lnd(i) + !2) calc ch_lnd from fm_lnd and fh_lnd + ch_lnd(i) = karman*karman/(fm_lnd(i) * fh_lnd(i)) + !3) check if ch_lnd is out of bounds (if so, recalculate fh_lnd from bounded value) + ch_bound_excursion = .false. + if (ch_lnd(i) < ch_low_limit) then + ch_bound_excursion = .true. + ch_lnd(i) = ch_low_limit + else if (ch_lnd(i) > ch_high_limit) then + ch_bound_excursion = .true. + ch_lnd(i) = ch_high_limit + end if + + if (ch_bound_excursion) then + fh_lnd(i) = karman*karman/(fm_lnd(i)*ch_lnd(i)) + end if + + !4) try fh2_lnd, limit to be less than or equal to constant*fh_lnd? fh2_lnd(i) = karman*xxfh2(i) - ch_lnd(i) = karman*karman/(fm_lnd(i) * fh_lnd(i)) + fh2_lnd(i) = min(fh2_lnd(i), fh_lnd(i)) !fh2_lnd > fh_lnd leads to bad values in sfc_diag.f - !GJF: these bounds on drag coefficients are from Chunxi Zhang's module_sf_sfclayrev.f90 - cdm_lnd(i) = max(cdm_lnd(i), cdlimit) - cdm_lnd(i) = min(cdm_lnd(i), 0.1) - ch_lnd(i) = max(ch_lnd(i), cdlimit) - ch_lnd(i) = min(ch_lnd(i), 0.1) - !GJF: this bound is from WRF's module_sf_gfdl.F (I'm not sure if both are needed or which is more restrictive.) - ch_lnd(i) = min(ch_lnd(i), 0.05/wspd(i)) + !GJF: Other CCPP schemes (PBL) ask for fm/fh instead of psim/psih + !psim_lnd(i)=gz1oz0(i)-fm_lnd(i) + !psih_lnd(i)=gz1oz0(i)-fh_lnd(i) !GJF: from WRF's module_sf_gfdl.F ustar_lnd(i) = 0.01*sqrt(cdm_lnd(i)* & @@ -532,23 +554,37 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & !taux(i) = fxmx(i)/10. ! gopal's doing for Ocean coupling !tauy(i) = fxmy(i)/10. ! gopal's doing for Ocean coupling + cdm_ice(i) = max(cdm_ice(i), cd_low_limit) + cdm_ice(i) = min(cdm_ice(i), cd_high_limit) fm_ice(i) = karman/sqrt(cdm_ice(i)) + + !1) try fh_ice from MFLUX2 fh_ice(i) = karman*xxfh(i) - !Other CCPP schemes (PBL) ask for fm/fh instead of psim/psih - !psim_ice(i)=gz1oz0(i)-fm_ice(i) - !psih_ice(i)=gz1oz0(i)-fh_ice(i) + !2) calc ch_ice from fm_ice and fh_ice + ch_ice(i) = karman*karman/(fm_ice(i) * fh_ice(i)) + + !3) check if ch_ice is out of bounds (if so, recalculate fh_ice from bounded value) + ch_bound_excursion = .false. + if (ch_ice(i) < ch_low_limit) then + ch_bound_excursion = .true. + ch_ice(i) = ch_low_limit + else if (ch_ice(i) > ch_high_limit) then + ch_bound_excursion = .true. + ch_ice(i) = ch_high_limit + end if + if (ch_bound_excursion) then + fh_ice(i) = karman*karman/(fm_ice(i)*ch_ice(i)) + end if + + !4) try fh2_ice, limit to be less than or equal to constant*fh_ice? fh2_ice(i) = karman*xxfh2(i) - ch_ice(i) = karman*karman/(fm_ice(i) * fh_ice(i)) + fh2_ice(i) = min(fh2_ice(i), fh_ice(i)) !fh2_ice > fh_ice leads to bad values in sfc_diag.f - !GJF: these bounds on drag coefficients are from Chunxi Zhang's module_sf_sfclayrev.f90 - cdm_ice(i) = max(cdm_ice(i), cdlimit) - cdm_ice(i) = min(cdm_ice(i), 0.1) - ch_ice(i) = max(ch_ice(i), cdlimit) - ch_ice(i) = min(ch_ice(i), 0.1) - !GJF: this bound is from WRF's module_sf_gfdl.F (I'm not sure if both are needed or which is more restrictive.) - ch_ice(i) = min(ch_ice(i), 0.05/wspd(i)) + !Other CCPP schemes (PBL) ask for fm/fh instead of psim/psih + !psim_ice(i)=gz1oz0(i)-fm_ice(i) + !psih_ice(i)=gz1oz0(i)-fh_ice(i) ustar_ice(i) = 0.01*sqrt(cdm_ice(i)* & (upc(i)*upc(i) + vpc(i)*vpc(i))) @@ -627,24 +663,38 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & !gz1oz0(i) = alog(zkmax(i)/znt_ocn(i)) !taux(i) = fxmx(i)/10. ! gopal's doing for Ocean coupling !tauy(i) = fxmy(i)/10. ! gopal's doing for Ocean coupling - + + cdm_ocn(i) = max(cdm_ocn(i), cd_low_limit) + cdm_ocn(i) = min(cdm_ocn(i), cd_high_limit) fm_ocn(i) = karman/sqrt(cdm_ocn(i)) + + !1) try fh_ocn from MFLUX2 fh_ocn(i) = karman*xxfh(i) - !Other CCPP schemes (PBL) ask for fm/fh instead of psim/psih - !psim_ocn(i)=gz1oz0(i)-fm_ocn(i) - !psih_ocn(i)=gz1oz0(i)-fh_ocn(i) + !2) calc ch_ocn from fm_ocn and fh_ocn + ch_ocn(i) = karman*karman/(fm_ocn(i) * fh_ocn(i)) + + !3) check if ch_lnd is out of bounds (if so, recalculate fh_lnd from bounded value) + ch_bound_excursion = .false. + if (ch_ocn(i) < ch_low_limit) then + ch_bound_excursion = .true. + ch_ocn(i) = ch_low_limit + else if (ch_ocn(i) > ch_high_limit) then + ch_bound_excursion = .true. + ch_ocn(i) = ch_high_limit + end if + + if (ch_bound_excursion) then + fh_ocn(i) = karman*karman/(fm_ocn(i)*ch_ocn(i)) + end if + !4) try fh2_ocn, limit to be less than or equal to constant*fh_ocn? fh2_ocn(i) = karman*xxfh2(i) - ch_ocn(i) = karman*karman/(fm_ocn(i) * fh_ocn(i)) + fh2_ocn(i) = min(fh2_ocn(i), fh_ocn(i)) !fh2_ocn > fh_ocn leads to bad values in sfc_diag.F - !GJF: these bounds on drag coefficients are from Chunxi Zhang's module_sf_sfclayrev.f90 - cdm_ocn(i) = max(cdm_ocn(i), cdlimit) - cdm_ocn(i) = min(cdm_ocn(i), 0.1) - ch_ocn(i) = max(ch_ocn(i), cdlimit) - ch_ocn(i) = min(ch_ocn(i), 0.1) - !GJF: this bound is from WRF's module_sf_gfdl.F (I'm not sure if both are needed or which is more restrictive.) - ch_ocn(i) = min(ch_ocn(i), 0.05/wspd(i)) + !Other CCPP schemes (PBL) ask for fm/fh instead of psim/psih + !psim_ocn(i)=gz1oz0(i)-fm_ocn(i) + !psih_ocn(i)=gz1oz0(i)-fh_ocn(i) ustar_ocn(i) = 0.01*sqrt(cdm_ocn(i)* & (upc(i)*upc(i) + vpc(i)*vpc(i))) From 6d3ce4f8ec86d90a25747f6fbc150caa96427e6e Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Tue, 19 May 2020 16:06:19 -0600 Subject: [PATCH 25/42] use precalculated wind speed with convective gustiness component in gfdl_sfc_layer instead of recalculating --- physics/gfdl_sfc_layer.F90 | 35 +++++++++++++---------------------- physics/gfdl_sfc_layer.meta | 9 +++++++++ 2 files changed, 22 insertions(+), 22 deletions(-) diff --git a/physics/gfdl_sfc_layer.F90 b/physics/gfdl_sfc_layer.F90 index 1b29c166c..3f4426613 100644 --- a/physics/gfdl_sfc_layer.F90 +++ b/physics/gfdl_sfc_layer.F90 @@ -103,13 +103,13 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & lsm_noah, lsm_noahmp, lsm_ruc, lsm_noah_wrfv4, icoef_sf, cplwav, & cplwav2atm, lcurr_sf, pert_Cd, ntsflg, sfenth, z1, shdmax, ivegsrc, & vegtype, sigmaf, dt, wet, dry, icy, isltyp, rd, grav, ep1, ep2, smois, & - psfc, prsl1, q1, t1, u1, v1, u10, v10, gsw, glw, tsurf_ocn, tsurf_lnd, & - tsurf_ice, tskin_ocn, tskin_lnd, tskin_ice, ustar_ocn, ustar_lnd, & - ustar_ice, znt_ocn, znt_lnd, znt_ice, cdm_ocn, cdm_lnd, cdm_ice, & - stress_ocn, stress_lnd, stress_ice, rib_ocn, rib_lnd, rib_ice, fm_ocn, & - fm_lnd, fm_ice, fh_ocn, fh_lnd, fh_ice, fh2_ocn, fh2_lnd, fh2_ice, & - ch_ocn, ch_lnd, ch_ice, fm10_ocn, fm10_lnd, fm10_ice, qss_ocn, qss_lnd, & - qss_ice, errmsg, errflg) + psfc, prsl1, q1, t1, u1, v1, wspd, u10, v10, gsw, glw, tsurf_ocn, & + tsurf_lnd, tsurf_ice, tskin_ocn, tskin_lnd, tskin_ice, ustar_ocn, & + ustar_lnd, ustar_ice, znt_ocn, znt_lnd, znt_ice, cdm_ocn, cdm_lnd, & + cdm_ice, stress_ocn, stress_lnd, stress_ice, rib_ocn, rib_lnd, rib_ice, & + fm_ocn, fm_lnd, fm_ice, fh_ocn, fh_lnd, fh_ice, fh2_ocn, fh2_lnd, & + fh2_ice, ch_ocn, ch_lnd, ch_ice, fm10_ocn, fm10_lnd, fm10_ice, qss_ocn, & + qss_lnd, qss_ice, errmsg, errflg) use funcphys, only: fpvs @@ -136,8 +136,8 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & real(kind=kind_phys), intent(in) :: rd,grav,ep1,ep2 real(kind=kind_phys), dimension(im,nsoil), intent(in) :: smois real(kind=kind_phys), dimension(im), intent(in) :: psfc, prsl1, & - q1, t1, u1, v1, u10, v10, gsw, glw, z1, shdmax, sigmaf, xlat, xlon, & - tsurf_ocn, tsurf_lnd, tsurf_ice + q1, t1, u1, v1, wspd, u10, v10, gsw, glw, z1, shdmax, sigmaf, xlat, & + xlon, tsurf_ocn, tsurf_lnd, tsurf_ice real(kind=kind_phys), intent(inout), dimension(im) :: tskin_ocn, & tskin_lnd, tskin_ice, ustar_ocn, ustar_lnd, ustar_ice, & @@ -167,7 +167,7 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & real(kind=kind_phys) :: ens_Cdamp real(kind=kind_phys), dimension(im) :: wetc, pspc, pkmax, tstrc, upc, & - vpc, mznt, slwdc, wspd, wind10, qfx, qgh, zkmax, z1_cm, z0max, ztmax + vpc, mznt, slwdc, wind10, qfx, qgh, zkmax, z1_cm, z0max, ztmax real(kind=kind_phys), dimension(im) :: u10_lnd, u10_ocn, u10_ice, & v10_lnd, v10_ocn, v10_ice @@ -254,13 +254,6 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & upc(i) = u1(i)*100. ! convert from m s-1 to cm s-1 vpc(i) = v1(i)*100. ! convert from m s-1 to cm s-1 - !GJF: wind speed at the lowest model layer is calculated in a scheme prior to this (if this scheme - ! is part of a GFS-based suite), but it is recalculated here because this one DOES NOT include - ! a convective wind enhancement component (convective gustiness factor) to follow the original - ! GFDL surface layer scheme; this may not be necessary - wspd(i) = sqrt(u1(i)*u1(i) + v1(i)*v1(i)) - wspd(i) = amax1(wspd(i),1.0) !wspd is in m s-1 - !Wang: use previous u10 v10 to compute wind10, input to MFLUX2 to compute z0 (for first time step, u10 and v10 may be zero) wind10(i)=sqrt(u10(i)*u10(i)+v10(i)*v10(i)) !m s-1 @@ -373,8 +366,7 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & !GJF: from WRF's module_sf_gfdl.F if (wind10(i) <= 1.0e-10 .or. wind10(i) > 150.0) then - !GJF: why not use wspd(i) to save compute? - wind10(i)=sqrt(u1(i)*u1(i)+v1(i)*v1(i))*alog(10.0/z0max(i))/alog(z1(i)/z0max(i)) !m s-1 + wind10(i)=wspd(i)*alog(10.0/z0max(i))/alog(z1(i)/z0max(i)) !m s-1 end if wind10(i)=wind10(i)*100.0 !convert from m/s to cm/s @@ -523,8 +515,7 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & !GJF: from WRF's module_sf_gfdl.F if (wind10(i) <= 1.0e-10 .or. wind10(i) > 150.0) then - !GJF: why not use wspd(i) to save compute? - wind10(i)=sqrt(u1(i)*u1(i)+v1(i)*v1(i))*alog(10.0/z0max(i))/alog(z1(i)/z0max(i)) + wind10(i)=wspd(i)*alog(10.0/z0max(i))/alog(z1(i)/z0max(i)) end if wind10(i)=wind10(i)*100.0 !! m/s to cm/s @@ -628,7 +619,7 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & !GJF: from WRF's module_sf_gfdl.F if (wind10(i) <= 1.0e-10 .or. wind10(i) > 150.0) then - wind10(i)=sqrt(u1(i)*u1(i)+v1(i)*v1(i))*alog(10.0/(0.01*znt_ocn(i)))/alog(z1(i)/(0.01*znt_ocn(i))) + wind10(i)=wspd(i)*alog(10.0/(0.01*znt_ocn(i)))/alog(z1(i)/(0.01*znt_ocn(i))) end if wind10(i)=wind10(i)*100.0 !! m/s to cm/s diff --git a/physics/gfdl_sfc_layer.meta b/physics/gfdl_sfc_layer.meta index 738216d1a..5a245cd69 100644 --- a/physics/gfdl_sfc_layer.meta +++ b/physics/gfdl_sfc_layer.meta @@ -401,6 +401,15 @@ kind = kind_phys intent = in optional = F +[wspd] + standard_name = wind_speed_at_lowest_model_layer + long_name = wind speed at lowest model level + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F [u10] standard_name = x_wind_at_10m long_name = 10 meter u wind speed From b8629ee129fd81f7ed515c5faf85533cb1e88af3 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Tue, 19 May 2020 21:25:54 -0600 Subject: [PATCH 26/42] add logic to maintain ratio between fh and fh2 to attempt to reign in spuriously large 2m T,q diagnostics --- physics/gfdl_sfc_layer.F90 | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/physics/gfdl_sfc_layer.F90 b/physics/gfdl_sfc_layer.F90 index 3f4426613..6bd969ac3 100644 --- a/physics/gfdl_sfc_layer.F90 +++ b/physics/gfdl_sfc_layer.F90 @@ -183,7 +183,7 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & real(kind=kind_phys), dimension(1:30) :: maxsmc, drysmc real(kind=kind_phys) :: smcmax, smcdry, zhalf, cd10, & esat, fm_lnd_old, fh_lnd_old, tem1, tem2, czilc, cd_low_limit, & - cd_high_limit, ch_low_limit, ch_high_limit + cd_high_limit, ch_low_limit, ch_high_limit, fh2_fh_ratio !#### This block will become unnecessary when maxsmc and drysmc come through the CCPP #### if (lsm == lsm_noah) then @@ -416,14 +416,14 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & ch_lnd(i) = ch_high_limit end if + fh2_lnd(i) = karman*xxfh2(i) + if (ch_bound_excursion) then + fh2_fh_ratio = min(xxfh2(i)/xxfh(i), 1.0) fh_lnd(i) = karman*karman/(fm_lnd(i)*ch_lnd(i)) + fh2_lnd(i) = fh2_fh_ratio*fh_lnd(i) end if - !4) try fh2_lnd, limit to be less than or equal to constant*fh_lnd? - fh2_lnd(i) = karman*xxfh2(i) - fh2_lnd(i) = min(fh2_lnd(i), fh_lnd(i)) !fh2_lnd > fh_lnd leads to bad values in sfc_diag.f - !GJF: Other CCPP schemes (PBL) ask for fm/fh instead of psim/psih !psim_lnd(i)=gz1oz0(i)-fm_lnd(i) !psih_lnd(i)=gz1oz0(i)-fh_lnd(i) @@ -565,14 +565,14 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & ch_ice(i) = ch_high_limit end if + fh2_ice(i) = karman*xxfh2(i) + if (ch_bound_excursion) then + fh2_fh_ratio = min(xxfh2(i)/xxfh(i), 1.0) fh_ice(i) = karman*karman/(fm_ice(i)*ch_ice(i)) + fh2_ice(i) = fh2_fh_ratio*fh_ice(i) end if - !4) try fh2_ice, limit to be less than or equal to constant*fh_ice? - fh2_ice(i) = karman*xxfh2(i) - fh2_ice(i) = min(fh2_ice(i), fh_ice(i)) !fh2_ice > fh_ice leads to bad values in sfc_diag.f - !Other CCPP schemes (PBL) ask for fm/fh instead of psim/psih !psim_ice(i)=gz1oz0(i)-fm_ice(i) !psih_ice(i)=gz1oz0(i)-fh_ice(i) @@ -675,14 +675,14 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & ch_ocn(i) = ch_high_limit end if + fh2_ocn(i) = karman*xxfh2(i) + if (ch_bound_excursion) then + fh2_fh_ratio = min(xxfh2(i)/xxfh(i), 1.0) fh_ocn(i) = karman*karman/(fm_ocn(i)*ch_ocn(i)) + fh2_ocn(i) = fh2_fh_ratio*fh_ocn(i) end if - !4) try fh2_ocn, limit to be less than or equal to constant*fh_ocn? - fh2_ocn(i) = karman*xxfh2(i) - fh2_ocn(i) = min(fh2_ocn(i), fh_ocn(i)) !fh2_ocn > fh_ocn leads to bad values in sfc_diag.F - !Other CCPP schemes (PBL) ask for fm/fh instead of psim/psih !psim_ocn(i)=gz1oz0(i)-fm_ocn(i) !psih_ocn(i)=gz1oz0(i)-fh_ocn(i) From 0298cebeeaf6f2d1cd88b8ae087a910a288a99d0 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Wed, 27 May 2020 12:22:32 -0600 Subject: [PATCH 27/42] add time-averaged calculation of skin temperature and soil temperature in HWRF Noah LSM to try to reduce spurious values of t2m and q2m --- physics/module_sf_noahlsm.F90 | 24 ++++++++++++++++++++++-- 1 file changed, 22 insertions(+), 2 deletions(-) diff --git a/physics/module_sf_noahlsm.F90 b/physics/module_sf_noahlsm.F90 index 9336abf65..13d8e9813 100644 --- a/physics/module_sf_noahlsm.F90 +++ b/physics/module_sf_noahlsm.F90 @@ -2631,6 +2631,7 @@ SUBROUTINE SHFLX (SSOIL,STC,SMC,SMCMAX,NSOIL,T1,DT,YY,ZZ1,ZSOIL, & INTEGER, INTENT(IN) :: OPT_THCND INTEGER, INTENT(IN) :: NSOIL, VEGTYP, ISURBAN, SOILTYP INTEGER :: I + LOGICAL, PARAMETER :: TIME_AVERAGE_T_UPDATE = .TRUE. REAL, INTENT(IN) :: BEXP,CSOIL,DF1,DT,F1,PSISAT,QUARTZ, & SMCMAX, SMCWLT, TBOT,YY, ZBOT,ZZ1 @@ -2641,7 +2642,10 @@ SUBROUTINE SHFLX (SSOIL,STC,SMC,SMCMAX,NSOIL,T1,DT,YY,ZZ1,ZSOIL, & REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: STC REAL, DIMENSION(1:NSOIL) :: AI, BI, CI, STCF,RHSTS REAL, PARAMETER :: T0 = 273.15 - + REAL :: OLDT1 + REAL, DIMENSION(1:NSOIL) :: OLDSTC + REAL, PARAMETER :: CTFIL1 = 0.5 + REAL, PARAMETER :: CTFIL2 = 1.0 - CTFIL1 ! ! FASDAS ! @@ -2652,7 +2656,14 @@ SUBROUTINE SHFLX (SSOIL,STC,SMC,SMCMAX,NSOIL,T1,DT,YY,ZZ1,ZSOIL, & ! ---------------------------------------------------------------------- ! HRT ROUTINE CALCS THE RIGHT HAND SIDE OF THE SOIL TEMP DIF EQN ! ---------------------------------------------------------------------- - + + IF (TIME_AVERAGE_T_UPDATE) THEN + OLDT1 = T1 + DO I = 1, NSOIL + OLDSTC(I) = STC(I) + ENDDO + ENDIF + ! Land case CALL HRT (RHSTS,STC,SMC,SMCMAX,NSOIL,ZSOIL,YY,ZZ1,TBOT, & @@ -2677,6 +2688,15 @@ SUBROUTINE SHFLX (SSOIL,STC,SMC,SMCMAX,NSOIL,T1,DT,YY,ZZ1,ZSOIL, & ! CALCULATE SURFACE SOIL HEAT FLUX ! ---------------------------------------------------------------------- T1 = (YY + (ZZ1- 1.0) * STC (1)) / ZZ1 + + !GJF: Following the GFS version of Noah, time average the updating of skin temperature and soil temperature + IF (TIME_AVERAGE_T_UPDATE) THEN + T1 = CTFIL1*T1 + CTFIL2*OLDT1 + DO I = 1, NSOIL + STC(I) = CTFIL1*STC(I) + CTFIL2*OLDSTC(I) + ENDDO + ENDIF + SSOIL = DF1 * (STC (1) - T1) / (0.5 * ZSOIL (1)) ! ---------------------------------------------------------------------- From 807dd0b0aa72d071451082144dac7218a7f0fb86 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 7 Oct 2020 08:55:55 -0600 Subject: [PATCH 28/42] Update HWRF physics (except FA) after merge, add CCPP dependencies to metadata --- physics/GFS_rrtmg_pre.F90 | 11 +++++++---- physics/GFS_rrtmg_setup.meta | 2 +- physics/gfdl_sfc_layer.meta | 10 ++++++++-- physics/radiation_clouds.f | 2 +- physics/sfc_noah_wrfv4.meta | 6 ++++++ physics/sfc_noah_wrfv4_interstitial.meta | 14 +++++++++++++- 6 files changed, 36 insertions(+), 9 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 3b57878bb..9852a77b8 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -172,6 +172,9 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP,NBDSW,NF_AESW) ::faersw real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP,NBDLW,NF_AELW) ::faerlw + integer :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte real(kind=kind_phys) :: qvs ! !===> ... begin here @@ -937,7 +940,7 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input ! clouds, cldsa, mtopa, mbota, de_lgth) ! --- outputs endif - elseif(Model%imp_physics == 6 .or. Model%imp_physics == 15) then + elseif(Model%imp_physics == 15) then if (Model%kdt == 1) then Tbd%phy_f3d(:,:,Model%nleffr) = 10. Tbd%phy_f3d(:,:,Model%nieffr) = 50. @@ -947,12 +950,12 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input 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, & +!mz 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), & - clouds,cldsa,mtopa,mbota, de_lgth) ! --- outputs - + clouds,cldsa,mtopa,mbota, de_lgth) ! --- outputs elseif(Model%imp_physics == Model%imp_physics_thompson) then ! Thompson MP @@ -975,7 +978,7 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input else ! MYNN PBL or GF convective are not used - call progcld5 (plyr,plvl,tlyr,qlyr,qstl,rhly,tracer1, & ! --- inputs + 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, & diff --git a/physics/GFS_rrtmg_setup.meta b/physics/GFS_rrtmg_setup.meta index 8f7b650dc..03e2bd602 100644 --- a/physics/GFS_rrtmg_setup.meta +++ b/physics/GFS_rrtmg_setup.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_rrtmg_setup type = scheme - dependencies = iounitdef.f,module_bfmicrophysics.f,physparam.f,radcons.f90,radiation_aerosols.f,radiation_astronomy.f,radiation_clouds.f,radiation_gases.f,radiation_surface.f,radlw_main.f,radlw_param.f,radsw_main.f,radsw_param.f + dependencies = iounitdef.f,module_bfmicrophysics.f,physparam.f,radcons.f90,radiation_aerosols.f,radiation_astronomy.f,radiation_clouds.f,radiation_gases.f,radiation_surface.f,radlw_main.F90,radlw_param.f,radsw_main.F90,radsw_param.f ######################################################################## [ccpp-arg-table] diff --git a/physics/gfdl_sfc_layer.meta b/physics/gfdl_sfc_layer.meta index 5a245cd69..77024c813 100644 --- a/physics/gfdl_sfc_layer.meta +++ b/physics/gfdl_sfc_layer.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = gfdl_sfc_layer + type = scheme + dependencies = machine.F,module_sf_exchcoef.f90,namelist_soilveg_ruc.F90,noahmp_tables.f90 + +######################################################################## [ccpp-arg-table] name = gfdl_sfc_layer_init type = scheme @@ -98,7 +104,7 @@ [xlat] standard_name = latitude long_name = latitude - units = radians + units = radian dimensions = (horizontal_loop_extent) type = real kind = kind_phys @@ -107,7 +113,7 @@ [xlon] standard_name = longitude long_name = longitude - units = radians + units = radian dimensions = (horizontal_loop_extent) type = real kind = kind_phys diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index b9dc9f9da..9f80824f1 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -246,7 +246,7 @@ module module_radiation_clouds public progcld1, progcld2, progcld3, progcld4, progclduni, & & cld_init, progcld5, progcld6, progcld4o, cal_cldfra3, & & find_cloudLayers, adjust_cloudIce, adjust_cloudH2O, & - & adjust_cloudFinal, get_alpha_dcorr, get_alpha_exp + & adjust_cloudFinal, gethml, get_alpha_dcorr, get_alpha_exp ! ================= diff --git a/physics/sfc_noah_wrfv4.meta b/physics/sfc_noah_wrfv4.meta index 781a21d3b..1895c56bf 100644 --- a/physics/sfc_noah_wrfv4.meta +++ b/physics/sfc_noah_wrfv4.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = sfc_noah_wrfv4 + type = scheme + dependencies = machine.F,module_sf_noahlsm_glacial_only.F90,module_sf_noahlsm.F90 + +######################################################################## [ccpp-arg-table] name = sfc_noah_wrfv4_init type = scheme diff --git a/physics/sfc_noah_wrfv4_interstitial.meta b/physics/sfc_noah_wrfv4_interstitial.meta index e993780fd..b6ebcfe39 100644 --- a/physics/sfc_noah_wrfv4_interstitial.meta +++ b/physics/sfc_noah_wrfv4_interstitial.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = sfc_noah_wrfv4_pre + type = scheme + dependencies = machine.F + +######################################################################## [ccpp-arg-table] name = sfc_noah_wrfv4_pre_init type = scheme @@ -683,7 +689,13 @@ type = integer intent = out optional = F - + +######################################################################## +[ccpp-table-properties] + name = sfc_noah_wrfv4_post + type = scheme + dependencies = machine.F + ######################################################################## [ccpp-arg-table] name = sfc_noah_wrfv4_post_run From 2ad28e61cf226a86dc006fceeec1130f1f629094 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Sat, 10 Oct 2020 15:08:54 -0600 Subject: [PATCH 29/42] Apply boundds to znt_ocn in physics/gfdl_sfc_layer.F90 before trying to divide by it --- physics/gfdl_sfc_layer.F90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/physics/gfdl_sfc_layer.F90 b/physics/gfdl_sfc_layer.F90 index 6bd969ac3..b74d16161 100644 --- a/physics/gfdl_sfc_layer.F90 +++ b/physics/gfdl_sfc_layer.F90 @@ -617,6 +617,9 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & !GJF: or WRF module_sf_gfdl.F: !tstrc(i) = tskin_ocn(i) + ! DH* 20201009: these bounds on ocean roughness lengths are from Chunxi Zhang's module_sf_sfclayrev.f90 (in cm) + znt_ocn(i)=min(2.85e-1,max(znt_ocn(i),1.27e-5)) + !GJF: from WRF's module_sf_gfdl.F if (wind10(i) <= 1.0e-10 .or. wind10(i) > 150.0) then wind10(i)=wspd(i)*alog(10.0/(0.01*znt_ocn(i)))/alog(z1(i)/(0.01*znt_ocn(i))) From fce80a170a02f85c0ced5412768a5badb2090133 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Sat, 10 Oct 2020 15:14:54 -0600 Subject: [PATCH 30/42] physics/module_mp_thompson.F90: adjust lower bounds of cloud effective radii to work with HWRF RRTMG settings --- physics/module_mp_thompson.F90 | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index 304afc6d5..5c2a2acb5 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -1452,17 +1452,17 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & IF (has_reqc.ne.0 .and. has_reqi.ne.0 .and. has_reqs.ne.0) THEN do k = kts, kte - re_qc1d(k) = 2.49E-6 - re_qi1d(k) = 4.99E-6 - re_qs1d(k) = 9.99E-6 + re_qc1d(k) = 2.50E-6 ! 2.49E-6 + re_qi1d(k) = 5.00E-6 ! 4.99E-6 + re_qs1d(k) = 1.00E-5 ! 9.99E-6 enddo !> - Call calc_effectrad() call calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & re_qc1d, re_qi1d, re_qs1d, kts, kte) do k = kts, kte - re_cloud(i,k,j) = MAX(2.49E-6, MIN(re_qc1d(k), 50.E-6)) - re_ice(i,k,j) = MAX(4.99E-6, MIN(re_qi1d(k), 125.E-6)) - re_snow(i,k,j) = MAX(9.99E-6, MIN(re_qs1d(k), 999.E-6)) + re_cloud(i,k,j) = MAX(2.50E-6, MIN(re_qc1d(k), 50.E-6)) ! MAX(2.49E-6, MIN(re_qc1d(k), 50.E-6)) + re_ice(i,k,j) = MAX(5.00E-6, MIN(re_qi1d(k), 125.E-6)) ! MAX(4.99E-6, MIN(re_qi1d(k), 125.E-6)) + re_snow(i,k,j) = MAX(1.00E-5, MIN(re_qs1d(k), 999.E-6)) ! MAX(9.99E-6, MIN(re_qs1d(k), 999.E-6)) enddo ENDIF @@ -5277,9 +5277,9 @@ subroutine calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & ! as before this change, use the WRF v3.8.1 settings throughout. #if 1 !ifdef WRF381 - re_qc1d(:) = 2.49E-6 - re_qi1d(:) = 4.99E-6 - re_qs1d(:) = 9.99E-6 + re_qc1d(:) = 2.50E-6 ! 2.49E-6 + re_qi1d(:) = 5.00E-6 ! 4.99E-6 + re_qs1d(:) = 1.00E-5 ! 9.99E-6 #else re_qc1d(:) = 2.49E-6 re_qi1d(:) = 2.49E-6 @@ -5375,7 +5375,7 @@ subroutine calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & smoc = a_ * smo2**b_ #if 1 !ifdef WRF381 - re_qs1d(k) = MAX(10.E-6, MIN(0.5*(smoc/smob), 999.E-6)) + re_qs1d(k) = MAX(1.01E-5, MIN(0.5*(smoc/smob), 999.E-6)) #else re_qs1d(k) = MAX(5.01E-6, MIN(0.5*(smoc/smob), 999.E-6)) #endif From 030dcfd2cb3fd95a38c7f720d300af13543e635c Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Sat, 10 Oct 2020 15:17:00 -0600 Subject: [PATCH 31/42] Add CCPP dependencies to physics/radlw_main.meta and physics/radsw_main.meta; remove trailing whitespaces in physics/mp_fer_hires.F90 --- physics/mp_fer_hires.F90 | 46 ++++++++++++++++++++-------------------- physics/radlw_main.meta | 2 +- physics/radsw_main.meta | 2 +- 3 files changed, 25 insertions(+), 25 deletions(-) diff --git a/physics/mp_fer_hires.F90 b/physics/mp_fer_hires.F90 index cebf53b74..576f7fdab 100644 --- a/physics/mp_fer_hires.F90 +++ b/physics/mp_fer_hires.F90 @@ -1,9 +1,9 @@ !>\file mp_fer_hires.F90 -!! This file contains the Ferrier-Aligo microphysics scheme driver. +!! This file contains the Ferrier-Aligo microphysics scheme driver. ! module mp_fer_hires - + use machine, only : kind_phys use module_mp_fer_hires, only : ferrier_init_hr, FER_HIRES, & @@ -12,11 +12,11 @@ module mp_fer_hires implicit none public :: mp_fer_hires_init, mp_fer_hires_run, mp_fer_hires_finalize - + private logical :: is_initialized = .False. - + ! * T_ICE - temperature (C) threshold at which all remaining liquid water ! is glaciated to ice ! * T_ICE_init - maximum temperature (C) at which ice nucleation occurs @@ -66,7 +66,7 @@ subroutine mp_fer_hires_init(ncol, nlev, dtp, imp_physics, & ! Initialize the CCPP error handling variables errmsg = '' errflg = 0 - + if (is_initialized) return ! Set internal dimensions @@ -74,7 +74,7 @@ subroutine mp_fer_hires_init(ncol, nlev, dtp, imp_physics, & ime = ncol lm = nlev - ! MZ* temporary + ! MZ* temporary if (mpirank==mpiroot) then write(0,*) ' -----------------------------------------------' write(0,*) ' --- !!! WARNING !!! ---' @@ -90,9 +90,9 @@ subroutine mp_fer_hires_init(ncol, nlev, dtp, imp_physics, & errflg = 1 return end if - + !MZ: fer_hires_init() in HWRF - if (mpirank==mpiroot) write (0,*) 'F-A: F_ICE,F_RAIN AND F_RIMEF IS REINITIALIZED' + if (mpirank==mpiroot) write (0,*) 'F-A: F_ICE, F_RAIN AND F_RIMEF ARE REINITIALIZED' DO K = 1,lm DO I= ims,ime F_ICE(i,k)=0. @@ -101,16 +101,16 @@ subroutine mp_fer_hires_init(ncol, nlev, dtp, imp_physics, & ENDDO ENDDO !MZ: fer_hires_init() in HWRF - + if (mpirank==mpiroot) write (0,*) 'F-A: calling FERRIER_INIT_HR ...' CALL FERRIER_INIT_HR(dtp,mpicomm,mpirank,mpiroot,threads,errmsg,errflg) if (mpirank==mpiroot) write (0,*)'F-A: FERRIER_INIT_HR finished ...' if (errflg /= 0 ) return - + is_initialized = .true. - + end subroutine mp_fer_hires_init !>\defgroup hafs_famp HWRF Ferrier-Aligo Microphysics Scheme @@ -124,8 +124,8 @@ SUBROUTINE mp_fer_hires_run(NCOL, NLEV, DT ,SPEC_ADV & ,T,Q,CWM & ,TRAIN,SR & ,F_ICE,F_RAIN,F_RIMEF & - ,QC,QR,QI,QG & - ,PREC & + ,QC,QR,QI,QG & + ,PREC & ,mpirank, mpiroot, threads & ,refl_10cm & ,RHGRD,dx & @@ -162,7 +162,7 @@ SUBROUTINE mp_fer_hires_run(NCOL, NLEV, DT ,SPEC_ADV & real(kind_phys), intent(inout) :: train(1:ncol,1:nlev) real(kind_phys), intent(out ) :: sr(1:ncol) real(kind_phys), intent(inout) :: f_ice(1:ncol,1:nlev) - real(kind_phys), intent(inout) :: f_rain(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: f_rain(1:ncol,1:nlev) real(kind_phys), intent(inout) :: f_rimef(1:ncol,1:nlev) real(kind_phys), intent(inout) :: qc(1:ncol,1:nlev) real(kind_phys), intent(inout) :: qr(1:ncol,1:nlev) @@ -205,7 +205,7 @@ SUBROUTINE mp_fer_hires_run(NCOL, NLEV, DT ,SPEC_ADV & write(errmsg, fmt='((a))') 'mp_fer_hires_run called before mp_fer_hires_init' errflg = 1 return - end if + end if ! Set internal dimensions ims = 1 @@ -248,7 +248,7 @@ SUBROUTINE mp_fer_hires_run(NCOL, NLEV, DT ,SPEC_ADV & !----------------------------------------------------------------------- ! DO K=LM,1,-1 !mz* We are moving down from the top in the flipped arrays - + !*** CALL MICROPHYSICS !MZ* in HWRF @@ -274,8 +274,8 @@ SUBROUTINE mp_fer_hires_run(NCOL, NLEV, DT ,SPEC_ADV & !--------------------------------------------------------------------- !aligo - DO K = 1, LM - DO I= IMS, IME + DO K = 1, LM + DO I= IMS, IME cwm(i,k) = cwm(i,k)/(1.0_kind_phys-q(i,k)) qr(i,k) = qr(i,k)/(1.0_kind_phys-q(i,k)) qi(i,k) = qi(i,k)/(1.0_kind_phys-q(i,k)) @@ -284,7 +284,7 @@ SUBROUTINE mp_fer_hires_run(NCOL, NLEV, DT ,SPEC_ADV & ENDDO !aligo !--------------------------------------------------------------------- - + CALL FER_HIRES( & DT=DT,RHgrd=RHGRD & ,PRSI=prsi,P_PHY=p_phy,T_PHY=t & @@ -311,7 +311,7 @@ SUBROUTINE mp_fer_hires_run(NCOL, NLEV, DT ,SPEC_ADV & qi(i,k) = qi(i,k)/(1.0_kind_phys+q(i,k)) qr(i,k) = qr(i,k)/(1.0_kind_phys+q(i,k)) ENDDO - ENDDO + ENDDO !----------------------------------------------------------- DO K=1,LM @@ -321,7 +321,7 @@ SUBROUTINE mp_fer_hires_run(NCOL, NLEV, DT ,SPEC_ADV & !*** Calculate graupel from total ice array and rime factor !--------------------------------------------------------------------- -!MZ +!MZ IF (SPEC_ADV) then QG(I,K)=QI(I,K)*F_RIMEF(I,K) ENDIF @@ -345,7 +345,7 @@ SUBROUTINE mp_fer_hires_run(NCOL, NLEV, DT ,SPEC_ADV & DO I=IMS,IME PCPCOL=RAINNCV(I)*1.E-3 !MZ:unit:m PREC(I)=PREC(I)+PCPCOL -!MZ ACPREC(I)=ACPREC(I)+PCPCOL !MZ: not used +!MZ ACPREC(I)=ACPREC(I)+PCPCOL !MZ: not used ! ! NOTE: RAINNC IS ACCUMULATED INSIDE MICROPHYSICS BUT NMM ZEROES IT OUT ABOVE ! SINCE IT IS ONLY A LOCAL ARRAY FOR NOW @@ -353,7 +353,7 @@ SUBROUTINE mp_fer_hires_run(NCOL, NLEV, DT ,SPEC_ADV & ENDDO !----------------------------------------------------------------------- ! - end subroutine mp_fer_hires_run + end subroutine mp_fer_hires_run !> \section arg_table_mp_fer_hires_finalize Argument Table diff --git a/physics/radlw_main.meta b/physics/radlw_main.meta index d857f665b..ef7d72c9b 100644 --- a/physics/radlw_main.meta +++ b/physics/radlw_main.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = rrtmg_lw type = scheme - dependencies = mersenne_twister.f,physcons.F90,physparam.f,radlw_datatb.f,radlw_param.f + dependencies = mersenne_twister.f,physcons.F90,physparam.f,radlw_datatb.f,radlw_param.f,HWRF_mcica_random_numbers.F90,HWRF_mersenne_twister.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/radsw_main.meta b/physics/radsw_main.meta index 9a8b1ce91..d32688ad1 100644 --- a/physics/radsw_main.meta +++ b/physics/radsw_main.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = rrtmg_sw type = scheme - dependencies = mersenne_twister.f,physcons.F90,physparam.f,radsw_datatb.f,radsw_param.f + dependencies = mersenne_twister.f,physcons.F90,physparam.f,radsw_datatb.f,radsw_param.f,HWRF_mcica_random_numbers.F90,HWRF_mersenne_twister.F90 ######################################################################## [ccpp-arg-table] From 3c012843dc5626377313af4748d29e6facc923dd Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Sat, 10 Oct 2020 15:17:24 -0600 Subject: [PATCH 32/42] Bugfix in physics/samfdeepcnv.f for uninitialized variable crtlame --- physics/samfdeepcnv.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f index 67576af15..47ffbb1c3 100644 --- a/physics/samfdeepcnv.f +++ b/physics/samfdeepcnv.f @@ -423,10 +423,10 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & cxlamu = 1.0e-3 else aafac = .05 - crtlame = 1.0e-4 cxlame = 1.0e-4 endif crtlamd = 1.0e-4 + crtlame = 1.0e-4 cxlamd = 1.0e-4 xlamde = 1.0e-4 xlamdd = 1.0e-4 From afa335fcaaee3722183056165cfd240153f5dfa6 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Sat, 10 Oct 2020 15:19:19 -0600 Subject: [PATCH 33/42] physics/module_MP_FER_HIRES.F90: bugfixes for MPI calls in init routine --- physics/module_MP_FER_HIRES.F90 | 65 +++++++++++++++------------------ 1 file changed, 29 insertions(+), 36 deletions(-) diff --git a/physics/module_MP_FER_HIRES.F90 b/physics/module_MP_FER_HIRES.F90 index 776898f93..092a2f941 100644 --- a/physics/module_MP_FER_HIRES.F90 +++ b/physics/module_MP_FER_HIRES.F90 @@ -2405,7 +2405,7 @@ END SUBROUTINE EGCP01COLUMN_hr !----------------------------------------------------------------------- !>\ingroup hafs_famp - SUBROUTINE FERRIER_INIT_hr (GSMDT,MPI_COMM_COMP,MYPE,mpiroot,THREADS, & + SUBROUTINE FERRIER_INIT_hr (GSMDT,MPI_COMM_COMP,MPIRANK,MPIROOT,THREADS, & errmsg,errflg) !----------------------------------------------------------------------- !------------------------------------------------------------------------------- @@ -2463,7 +2463,7 @@ SUBROUTINE FERRIER_INIT_hr (GSMDT,MPI_COMM_COMP,MYPE,mpiroot,THREADS, & ! ! VARIABLES PASSED IN REAL, INTENT(IN) :: GSMDT - INTEGER, INTENT(IN) :: MYPE + INTEGER, INTENT(IN) :: MPIRANK INTEGER, INTENT(IN) :: MPIROOT INTEGER, INTENT(IN) :: MPI_COMM_COMP INTEGER, INTENT(IN) :: THREADS @@ -2479,21 +2479,18 @@ SUBROUTINE FERRIER_INIT_hr (GSMDT,MPI_COMM_COMP,MYPE,mpiroot,THREADS, & LOGICAL :: opened INTEGER :: IRTN,rc CHARACTER*80 errmess - INTEGER :: mpi_communicator,ierr - INTEGER :: good + INTEGER :: ierr, good LOGICAL :: lexist,lopen, force_read_ferhires ! !----------------------------------------------------------------------- ! - ! Assign mpicomm to module variable - mpi_communicator= mpi_comm_comp - DTPH=GSMDT !-- Time step in s + DTPH=GSMDT !-- Time step in s ! !--- Create lookup tables for saturation vapor pressure w/r/t water & ice ! - CALL GPVS_hr + CALL GPVS_hr ! !zhang: if (.NOT. ALLOCATED(ventr1)) ALLOCATE(ventr1(MDRmin:MDRmax)) @@ -2509,16 +2506,15 @@ SUBROUTINE FERRIER_INIT_hr (GSMDT,MPI_COMM_COMP,MYPE,mpiroot,THREADS, & if (.NOT. ALLOCATED(vsnowi)) ALLOCATE(vsnowi(MDImin:MDImax)) if (.NOT. ALLOCATED(vel_rf)) ALLOCATE(vel_rf(2:9,0:Nrime)) +#ifdef MPI + call MPI_BARRIER(MPI_COMM_COMP,ierr) +#endif - + only_root_reads: if (MPIRANK==MPIROOT) then force_read_ferhires = .true. good = 0 INQUIRE(FILE="DETAMPNEW_DATA.expanded_rain_LE",EXIST=lexist) -#ifdef MPI - call MPI_BARRIER(mpi_communicator,ierr) -#endif - IF (lexist) THEN OPEN(63,FILE="DETAMPNEW_DATA.expanded_rain_LE", & & FORM="UNFORMATTED",STATUS="OLD",ERR=1234) @@ -2543,17 +2539,19 @@ SUBROUTINE FERRIER_INIT_hr (GSMDT,MPI_COMM_COMP,MYPE,mpiroot,THREADS, & INQUIRE(63,opened=lopen) IF (lopen) THEN IF( force_read_ferhires ) THEN - write(0,*) "Error reading DETAMPNEW_DATA.expanded_rain_LE. Aborting because force_read_ferhires is .true." + errmsg = "Error reading DETAMPNEW_DATA.expanded_rain_LE. Aborting because force_read_ferhires is .true." + errflg = 1 return ENDIF CLOSE(63) ELSE IF( force_read_ferhires ) THEN - write(0,*) "Error opening DETAMPNEW_DATA.expanded_rain_LE. Aborting because force_read_ferhires is .true." + errmsg = "Error opening DETAMPNEW_DATA.expanded_rain_LE. Aborting because force_read_ferhires is .true." + errflg = 1 return ENDIF ENDIF - ELSE + ELSE INQUIRE(63,opened=lopen) IF (lopen) THEN CLOSE(63) @@ -2561,25 +2559,26 @@ SUBROUTINE FERRIER_INIT_hr (GSMDT,MPI_COMM_COMP,MYPE,mpiroot,THREADS, & ENDIF ELSE IF( force_read_ferhires ) THEN - write(0,*) "Non-existent DETAMPNEW_DATA.expanded_rain_LE. Aborting because force_read_ferhires is .true." + errmsg = "Non-existent DETAMPNEW_DATA.expanded_rain_LE. Aborting because force_read_ferhires is .true." + errflg = 1 return ENDIF ENDIF - + endif only_root_reads ! #ifdef MPI - CALL MPI_BCAST(VENTR1,SIZE(VENTR1),MPI_DOUBLE_PRECISION,0,MPI_COMM_COMP,IRTN) - CALL MPI_BCAST(VENTR2,SIZE(VENTR2),MPI_DOUBLE_PRECISION,0,MPI_COMM_COMP,IRTN) - CALL MPI_BCAST(ACCRR,SIZE(ACCRR) ,MPI_DOUBLE_PRECISION,0,MPI_COMM_COMP,IRTN) - CALL MPI_BCAST(MASSR,SIZE(MASSR) ,MPI_DOUBLE_PRECISION,0,MPI_COMM_COMP,IRTN) - CALL MPI_BCAST(VRAIN,SIZE(VRAIN) ,MPI_DOUBLE_PRECISION,0,MPI_COMM_COMP,IRTN) - CALL MPI_BCAST(RRATE,SIZE(RRATE) ,MPI_DOUBLE_PRECISION,0,MPI_COMM_COMP,IRTN) - CALL MPI_BCAST(VENTI1,SIZE(VENTI1),MPI_DOUBLE_PRECISION,0,MPI_COMM_COMP,IRTN) - CALL MPI_BCAST(VENTI2,SIZE(VENTI2),MPI_DOUBLE_PRECISION,0,MPI_COMM_COMP,IRTN) - CALL MPI_BCAST(ACCRI,SIZE(ACCRI) ,MPI_DOUBLE_PRECISION,0,MPI_COMM_COMP,IRTN) - CALL MPI_BCAST(MASSI,SIZE(MASSI) ,MPI_DOUBLE_PRECISION,0,MPI_COMM_COMP,IRTN) - CALL MPI_BCAST(VSNOWI,SIZE(VSNOWI),MPI_DOUBLE_PRECISION,0,MPI_COMM_COMP,IRTN) - CALL MPI_BCAST(VEL_RF,SIZE(VEL_RF),MPI_DOUBLE_PRECISION,0,MPI_COMM_COMP,IRTN) + CALL MPI_BCAST(VENTR1,SIZE(VENTR1),MPI_DOUBLE_PRECISION,MPIROOT,MPI_COMM_COMP,IRTN) + CALL MPI_BCAST(VENTR2,SIZE(VENTR2),MPI_DOUBLE_PRECISION,MPIROOT,MPI_COMM_COMP,IRTN) + CALL MPI_BCAST(ACCRR, SIZE(ACCRR), MPI_DOUBLE_PRECISION,MPIROOT,MPI_COMM_COMP,IRTN) + CALL MPI_BCAST(MASSR, SIZE(MASSR), MPI_DOUBLE_PRECISION,MPIROOT,MPI_COMM_COMP,IRTN) + CALL MPI_BCAST(VRAIN, SIZE(VRAIN), MPI_DOUBLE_PRECISION,MPIROOT,MPI_COMM_COMP,IRTN) + CALL MPI_BCAST(RRATE, SIZE(RRATE), MPI_DOUBLE_PRECISION,MPIROOT,MPI_COMM_COMP,IRTN) + CALL MPI_BCAST(VENTI1,SIZE(VENTI1),MPI_DOUBLE_PRECISION,MPIROOT,MPI_COMM_COMP,IRTN) + CALL MPI_BCAST(VENTI2,SIZE(VENTI2),MPI_DOUBLE_PRECISION,MPIROOT,MPI_COMM_COMP,IRTN) + CALL MPI_BCAST(ACCRI, SIZE(ACCRI), MPI_DOUBLE_PRECISION,MPIROOT,MPI_COMM_COMP,IRTN) + CALL MPI_BCAST(MASSI, SIZE(MASSI), MPI_DOUBLE_PRECISION,MPIROOT,MPI_COMM_COMP,IRTN) + CALL MPI_BCAST(VSNOWI,SIZE(VSNOWI),MPI_DOUBLE_PRECISION,MPIROOT,MPI_COMM_COMP,IRTN) + CALL MPI_BCAST(VEL_RF,SIZE(VEL_RF),MPI_DOUBLE_PRECISION,MPIROOT,MPI_COMM_COMP,IRTN) #endif ! @@ -2721,12 +2720,6 @@ SUBROUTINE FERRIER_INIT_hr (GSMDT,MPI_COMM_COMP,MYPE,mpiroot,THREADS, & RETURN ! -!----------------------------------------------------------------------- -! -9061 CONTINUE - WRITE(0,*)' module_mp_etanew: error opening ETAMPNEW_DATA.expanded_rain on unit ',etampnew_unit1 - STOP -! !----------------------------------------------------------------------- END SUBROUTINE FERRIER_INIT_hr ! From b871fb9287a13bdef8047ee143e700e49a369a82 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Sat, 10 Oct 2020 15:34:31 -0600 Subject: [PATCH 34/42] Remove trailing whitespaces from physics/gfdl_sfc_layer.F90 --- physics/gfdl_sfc_layer.F90 | 366 ++++++++++++++++++------------------- 1 file changed, 183 insertions(+), 183 deletions(-) diff --git a/physics/gfdl_sfc_layer.F90 b/physics/gfdl_sfc_layer.F90 index b74d16161..93e38c982 100644 --- a/physics/gfdl_sfc_layer.F90 +++ b/physics/gfdl_sfc_layer.F90 @@ -16,57 +16,57 @@ module gfdl_sfc_layer !> \section arg_table_gfdl_sfc_layer_init Argument Table !! \htmlinclude gfdl_sfc_layer_init.html -!! +!! subroutine gfdl_sfc_layer_init (icoef_sf, cplwav, cplwav2atm, lcurr_sf, & pert_cd, ntsflg, errmsg, errflg) - + implicit none - + integer, intent(in) :: icoef_sf, ntsflg logical, intent(in) :: cplwav, cplwav2atm, lcurr_sf, pert_cd - + character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg - + ! Initialize CCPP error handling variables errmsg = '' errflg = 0 - + #if HWRF==1 write(errmsg,'(*(a))') 'The GFDL surface layer scheme does not support '& //'use of the HWRF preprocessor flag in gfdl_sfc_layer.F90' errflg = 1 return -#endif - +#endif + if (icoef_sf < 0 .or. icoef_sf > 8) then write(errmsg,'(*(a))') 'The value of icoef_sf is outside of the ' & //'supported range (0-8) in gfdl_sfc_layer.F90' errflg = 1 return end if - + if (cplwav .or. cplwav2atm) then write(errmsg,'(*(a))') 'The GFDL surface layer scheme is not set up ' & //'to be coupled to waves in gfdl_sfc_layer.F90' errflg = 1 return end if - + if (lcurr_sf) then write(errmsg,'(*(a))') 'The GFDL surface layer scheme is not set up ' & //'to be used with the lcurr_sf option in gfdl_sfc_layer.F90' errflg = 1 return end if - + if (pert_cd) then write(errmsg,'(*(a))') 'The GFDL surface layer scheme is not set up ' & //'to be used with the pert_cd option in gfdl_sfc_layer.F90' errflg = 1 return end if - + if (ntsflg > 0) then !GJF: In order to enable ntsflg > 0, the variable 'tstrc' passed into MFLUX2 should be set ! to the surface_skin_temperature_over_X_interstitial rather than the average of it and @@ -75,8 +75,8 @@ subroutine gfdl_sfc_layer_init (icoef_sf, cplwav, cplwav2atm, lcurr_sf, & //' in gfdl_sfc_layer.F90' errflg = 1 return - end if - + end if + !GJF: Initialization notes: In WRF, the subroutine module_sf_myjsfc/myjsfcinit ! is called for initialization of the GFDL surface layer scheme from ! the module_physics_init subroutine. It contains the following @@ -90,7 +90,7 @@ subroutine gfdl_sfc_layer_init (icoef_sf, cplwav, cplwav2atm, lcurr_sf, & ! ENDDO ! ENDIF !also initialize surface roughness length - + end subroutine gfdl_sfc_layer_init subroutine gfdl_sfc_layer_finalize () @@ -99,7 +99,7 @@ end subroutine gfdl_sfc_layer_finalize !> \section arg_table_gfdl_sfc_layer_run Argument Table !! \htmlinclude gfdl_sfc_layer_run.html !! - subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & + subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & lsm_noah, lsm_noahmp, lsm_ruc, lsm_noah_wrfv4, icoef_sf, cplwav, & cplwav2atm, lcurr_sf, pert_Cd, ntsflg, sfenth, z1, shdmax, ivegsrc, & vegtype, sigmaf, dt, wet, dry, icy, isltyp, rd, grav, ep1, ep2, smois, & @@ -110,9 +110,9 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & fm_ocn, fm_lnd, fm_ice, fh_ocn, fh_lnd, fh_ice, fh2_ocn, fh2_lnd, & fh2_ice, ch_ocn, ch_lnd, ch_ice, fm10_ocn, fm10_lnd, fm10_ice, qss_ocn, & qss_lnd, qss_ice, errmsg, errflg) - + use funcphys, only: fpvs - + !#### GJF: temporarily grab parameters from LSM-specific modules -- should go through CCPP #### ! (fixing this involves replacing the functionality of set_soilveg and namelist_soilveg) use namelist_soilveg, only: maxsmc_noah => maxsmc, drysmc_noah => drysmc @@ -120,7 +120,7 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & use noahmp_tables, only: maxsmc_noahmp => smcmax_table, drysmc_noahmp => smcdry_table use module_sf_noahlsm, only: maxsmc_noah_wrfv4 => maxsmc, drysmc_noah_wrfv4 => drysmc !################################################################################################ - + implicit none integer, intent(in) :: im, nsoil, km, ivegsrc @@ -138,53 +138,53 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & real(kind=kind_phys), dimension(im), intent(in) :: psfc, prsl1, & q1, t1, u1, v1, wspd, u10, v10, gsw, glw, z1, shdmax, sigmaf, xlat, & xlon, tsurf_ocn, tsurf_lnd, tsurf_ice - - real(kind=kind_phys), intent(inout), dimension(im) :: tskin_ocn, & + + real(kind=kind_phys), intent(inout), dimension(im) :: tskin_ocn, & tskin_lnd, tskin_ice, ustar_ocn, ustar_lnd, ustar_ice, & znt_ocn, znt_lnd, znt_ice, cdm_ocn, cdm_lnd, cdm_ice, & stress_ocn, stress_lnd, stress_ice, rib_ocn, rib_lnd, rib_ice, & fm_ocn, fm_lnd, fm_ice, fh_ocn, fh_lnd, fh_ice, fh2_ocn, fh2_lnd, & fh2_ice, ch_ocn, ch_lnd, ch_ice, fm10_ocn, fm10_lnd, fm10_ice, & qss_ocn, qss_lnd, qss_ice - + character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg - + !local variables - + integer :: i, its, ite, ims, ime - + logical :: ch_bound_excursion - + !GJF: the vonKarman constant should come in through the CCPP and be defined by the host model real (kind=kind_phys), parameter :: karman = 0.4 real (kind=kind_phys), parameter :: log01=log(0.01), log05=log(0.05), & log07=log(0.07) - + !GJF: if the following variables will be used, they should be turned into intent(in) namelist options integer :: iwavecpl, ens_random_seed, issflx logical :: diag_wind10m, diag_qss real(kind=kind_phys) :: ens_Cdamp - + real(kind=kind_phys), dimension(im) :: wetc, pspc, pkmax, tstrc, upc, & vpc, mznt, slwdc, wind10, qfx, qgh, zkmax, z1_cm, z0max, ztmax real(kind=kind_phys), dimension(im) :: u10_lnd, u10_ocn, u10_ice, & v10_lnd, v10_ocn, v10_ice - + !GJF: the following variables are identified as: !"SCURX" "Surface Currents(X)" "m s-1" !"SCURY" "Surface Currents(Y)" "m s-1 !"CHARN" "Charnock Coeff" " " !"MSANG" "Wind/Stress Angle" "Radian" real(kind=kind_phys), dimension(im) :: charn, msang, scurx, scury - + real(kind=kind_phys), dimension(im) :: fxh, fxe, fxmx, fxmy, xxfh, & xxfh2, tzot real(kind=kind_phys), dimension(1:30) :: maxsmc, drysmc real(kind=kind_phys) :: smcmax, smcdry, zhalf, cd10, & esat, fm_lnd_old, fh_lnd_old, tem1, tem2, czilc, cd_low_limit, & cd_high_limit, ch_low_limit, ch_high_limit, fh2_fh_ratio - + !#### This block will become unnecessary when maxsmc and drysmc come through the CCPP #### if (lsm == lsm_noah) then maxsmc = maxsmc_noah @@ -215,88 +215,88 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/ end if !######################################################################## - - !GJF: This code has not been tested with iwavecpl = 1; the variables 'charn' and 'msang' (and others?) need to be input in order to use this + + !GJF: This code has not been tested with iwavecpl = 1; the variables 'charn' and 'msang' (and others?) need to be input in order to use this ! if (cplwav .or. cplwav2atm) then ! iwavecpl = 1 ! else ! iwavecpl = 0 ! end if iwavecpl = 0 - + !GJF: temporary setting of variables that should be moved to namelist is they are used ens_random_seed = 0 !used for HWRF ensemble? ens_Cdamp = 0.0 !used for HWRF ensemble? issflx = 0 !GJF: 1 = calculate surface fluxes, 0 = don't - diag_wind10m = .false. !GJF: if one wants 10m wind speeds to come from this scheme, set this to True, + diag_wind10m = .false. !GJF: if one wants 10m wind speeds to come from this scheme, set this to True, ! put [u,v]10_[lnd/ocn/ice] in the scheme argument list (and metadata), and modify ! GFS_surface_compsites to receive the individual components and calculate an all-grid value diag_qss = .false. !GJF: saturation specific humidities are calculated by LSM, sea surface, and sea ice schemes in ! GFS-based suites - + ! Initialize CCPP error handling variables errmsg = '' errflg = 0 - + its = 1 ims = 1 ite = im ime = im - + do i=its, ite if (flag_iter(i)) then !GJF: Perform data preparation that is the same for all surface types - + pspc(i) = psfc(i)*10. ! convert from Pa to cgs pkmax(i) = prsl1(i)*10. ! convert from Pa to cgs upc(i) = u1(i)*100. ! convert from m s-1 to cm s-1 vpc(i) = v1(i)*100. ! convert from m s-1 to cm s-1 - + !Wang: use previous u10 v10 to compute wind10, input to MFLUX2 to compute z0 (for first time step, u10 and v10 may be zero) wind10(i)=sqrt(u10(i)*u10(i)+v10(i)*v10(i)) !m s-1 - + !Wang: calulate height of the first half level ! if (wind10(i) <= 1.0e-10 .or. wind10(i) > 150.0) then ! zhalf = -rd*t1(i)*alog(pkmax(i)/pspc(i))/grav !m ! endif - + !GJF: rather than calculate the height of the first half level, if it is precalculated ! in a different scheme, pass it in and use it; note that in FV3, calculating via the hypsometric equation ! occasionally produced values much shallower than those passed in !zkmax(i) = -rd*t1(i)*alog(pkmax(i)/pspc(i))/grav !m zkmax(i) = z1(i) z1_cm(i) = 100.0*z1(i) - + !GJF: these drag coefficient limits were suggested by Chunxi Zhang via his module_sf_sfclayrev.f90 cd_low_limit = 1.0e-5/zkmax(i) cd_high_limit = 0.1 - !GJF: use the lower of 0.1 from Chunxi Zhang or 0.05/wspd from WRF's module_sf_gfdl.F + !GJF: use the lower of 0.1 from Chunxi Zhang or 0.05/wspd from WRF's module_sf_gfdl.F ! (this will always be the latter if wspd has a minimum of 1.0 m s-1 from above) ch_low_limit = cd_low_limit ch_high_limit = min(0.1,0.05/wspd(i)) - + !slwdc... GFDL downward net flux in units of cal/(cm**2/min) !also divide by 10**4 to convert from /m**2 to /cm**2 slwdc(i)=gsw(i)+glw(i) slwdc(i)=0.239*60.*slwdc(i)*1.e-4 - + !GJF: these variables should be passed in if these options are used charn(i) = 0.0 !used with wave coupling (iwavecpl == 1) msang(i) = 0.0 !used with wave coupling (iwavecpl == 1) scurx(i) = 0.0 !used with ocean currents? (lcurr_sf == T) scury(i) = 0.0 !used with ocean currents? (lcurr_sf == T) - + if (diag_qss) then esat = fpvs(t1(i)) qgh(i) = ep2*esat/(psfc(i)-esat) end if - + !GJF: these vars are not needed in a GFS-based suite !rho1(i)=prsl1(i)/(rd*t1(i)*(1.+ep1*q1(i))) !cpm(i)=cp*(1.+0.8*q1(i)) - + !GJF: perform data preparation that depends on surface types and call the mflux2 subroutine for each surface type ! Note that this is different than the original WRF module_sf_gfdl.F where mflux2 is called once for all surface ! types, with negative roughness lengths denoting open ocean. @@ -306,24 +306,24 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & smcmax=maxsmc(isltyp(i)) wetc(i)=(smois(i,1)-smcdry)/(smcmax-smcdry) wetc(i)=amin1(1.,amax1(wetc(i),0.)) - + !GJF: the lower boundary temperature passed in to MFLUX2 either follows GFS: tstrc(i) = 0.5*(tskin_lnd(i) + tsurf_lnd(i)) !averaging tskin_lnd and tsurf_lnd as in GFS surface layer breaks ntsflg functionality !GJF: or WRF module_sf_gfdl.F: !tstrc(i) = tskin_lnd(i) - + !GJF: Roughness Length Limitation section ! The WRF version of module_sf_gfdl.F has no checks on the roughness lengths prior to entering MFLUX2. ! The following limits were placed on roughness lengths from the GFS surface layer scheme at the suggestion ! of Chunxi Zhang. Using the GFDL surface layer without such checks can lead to instability in the UFS. - + !znt_lnd is in cm, z0max/ztmax are in m at this point z0max(i) = max(1.0e-6, min(0.01 * znt_lnd(i), zkmax(i))) - + tem1 = 1.0 - shdmax(i) tem2 = tem1 * tem1 tem1 = 1.0 - tem2 - + if( ivegsrc == 1 ) then if (vegtype(i) == 10) then z0max(i) = exp( tem2*log01 + tem1*log07 ) @@ -353,7 +353,7 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & z0max(i) = exp( tem2*log01 + tem1*log(z0max(i)) ) endif endif - + z0max(i) = max(z0max(i), 1.0e-6) ! czilc = 10.0 ** (- (0.40/0.07) * z0) ! fei's canopy height dependance of czil @@ -363,16 +363,16 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & ztmax(i) = z0max(i)*exp( - tem1*tem1 & & * czilc*karman*sqrt(ustar_lnd(i)*(0.01/1.5e-05))) ztmax(i) = max(ztmax(i), 1.0e-6) - + !GJF: from WRF's module_sf_gfdl.F if (wind10(i) <= 1.0e-10 .or. wind10(i) > 150.0) then wind10(i)=wspd(i)*alog(10.0/z0max(i))/alog(z1(i)/z0max(i)) !m s-1 end if wind10(i)=wind10(i)*100.0 !convert from m/s to cm/s - + ztmax(i) = ztmax(i)*100.0 !convert from m to cm z0max(i) = z0max(i)*100.0 !convert from m to cm - + call mflux2 (fxh(i), fxe(i), fxmx(i), fxmy(i), cdm_lnd(i), rib_lnd(i), & xxfh(i), ztmax(i), z0max(i), tstrc(i), & pspc(i), pkmax(i), wetc(i), slwdc(i), z1_cm(i), icoef_sf, iwavecpl, lcurr_sf, charn(i), msang(i), & @@ -380,62 +380,62 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & dt, wind10(i), xxfh2(i), ntsflg, sfenth, tzot(i), errmsg, & errflg) if (errflg /= 0) return - + !GJF: this is broken when tstrc is set to an average of two variables if (ntsflg==1) then - tskin_lnd(i) = tstrc(i) ! gopal's doing + tskin_lnd(i) = tstrc(i) ! gopal's doing end if - + if (diag_wind10m) then u10_lnd(i) = u1(i)*(0.01*wind10(i)/wspd(i)) v10_lnd(i) = v1(i)*(0.01*wind10(i)/wspd(i)) end if - + !GJF: these variables are not needed in a GFS-based suite, but are found in WRF's module_sf_gfdl.F and kept in comments for legacy - !gz1oz0(i) = alog(zkmax(i)/(0.01*znt_lnd(i))) + !gz1oz0(i) = alog(zkmax(i)/(0.01*znt_lnd(i))) !taux(i) = fxmx(i)/10. ! gopal's doing for Ocean coupling !tauy(i) = fxmy(i)/10. ! gopal's doing for Ocean coupling - + cdm_lnd(i) = max(cdm_lnd(i), cd_low_limit) cdm_lnd(i) = min(cdm_lnd(i), cd_high_limit) fm_lnd(i) = karman/sqrt(cdm_lnd(i)) - + !1) try fh_lnd from MFLUX2 fh_lnd(i) = karman*xxfh(i) - + !2) calc ch_lnd from fm_lnd and fh_lnd ch_lnd(i) = karman*karman/(fm_lnd(i) * fh_lnd(i)) - + !3) check if ch_lnd is out of bounds (if so, recalculate fh_lnd from bounded value) ch_bound_excursion = .false. - if (ch_lnd(i) < ch_low_limit) then + if (ch_lnd(i) < ch_low_limit) then ch_bound_excursion = .true. ch_lnd(i) = ch_low_limit else if (ch_lnd(i) > ch_high_limit) then ch_bound_excursion = .true. ch_lnd(i) = ch_high_limit end if - + fh2_lnd(i) = karman*xxfh2(i) - + if (ch_bound_excursion) then fh2_fh_ratio = min(xxfh2(i)/xxfh(i), 1.0) fh_lnd(i) = karman*karman/(fm_lnd(i)*ch_lnd(i)) fh2_lnd(i) = fh2_fh_ratio*fh_lnd(i) end if - + !GJF: Other CCPP schemes (PBL) ask for fm/fh instead of psim/psih !psim_lnd(i)=gz1oz0(i)-fm_lnd(i) !psih_lnd(i)=gz1oz0(i)-fh_lnd(i) - + !GJF: from WRF's module_sf_gfdl.F ustar_lnd(i) = 0.01*sqrt(cdm_lnd(i)* & (upc(i)*upc(i) + vpc(i)*vpc(i))) !GJF: from Chunxi Zhang's module_sf_sfclayrev.f90 (I'm not sure it's necessary.) ustar_lnd(i) = amax1(ustar_lnd(i),0.001) - + stress_lnd(i) = cdm_lnd(i)*wspd(i)*wspd(i) - + !GJF: from WRF's module_sf_gfdl.F ! convert cd, ch to values at 10m, for output cd10 = cdm_lnd(i) @@ -446,48 +446,48 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & ! (alog(zkmax(i)/tmp9)/alog(10.0/tmp9)) end if fm10_lnd(i) = karman/sqrt(cd10) - - !GJF: conductances aren't used in other CCPP schemes, but this limit + + !GJF: conductances aren't used in other CCPP schemes, but this limit ! might be able to replace the limits on drag coefficients above - + !chs_lnd(i)=ch_lnd(i)*wspd (i) !conductance !chs2_lnd(i)=ustar_lnd(i)*karman/fh2_lnd(i) !2m conductance - + !!!2014-0922 cap CHS over land points ! chs_lnd(i)=amin1(chs_lnd(i), 0.05) ! chs2_lnd(i)=amin1(chs2_lnd(i), 0.05) ! if (chs2_lnd(i) < 0) chs2_lnd(i)=1.0e-6 - + if (diag_qss) then esat = fpvs(tskin_lnd(i)) qss_lnd(i) = ep2*esat/(psfc(i)-esat) end if - + !GJF: not used in CCPP !flhc_lnd(i)=cpm(i)*rho1(i)*chs_lnd(i) !flqc_lnd(i)=rho1(i)*chs_lnd(i) !cqs2_lnd(i)=chs2_lnd(i) end if !dry - + if (icy(i)) then !GJF: from WRF's module_sf_gfdl.F smcdry=drysmc(isltyp(i)) smcmax=maxsmc(isltyp(i)) wetc(i)=(smois(i,1)-smcdry)/(smcmax-smcdry) wetc(i)=amin1(1.,amax1(wetc(i),0.)) - - + + !GJF: the lower boundary temperature passed in to MFLUX2 either follows GFS: tstrc(i) = 0.5*(tskin_ice(i) + tsurf_ice(i)) !averaging tskin_ice and tsurf_ice as in GFS surface layer breaks ntsflg functionality !GJF: or WRF module_sf_gfdl.F: !tstrc(i) = tskin_ice(i) !averaging tskin_ice and tsurf_ice as in GFS surface layer breaks ntsflg functionality - + !GJF: Roughness Length Limitation section ! The WRF version of module_sf_gfdl.F has no checks on the roughness lengths prior to entering MFLUX2. ! The following limits were placed on roughness lengths from the GFS surface layer scheme at the suggestion ! of Chunxi Zhang. Using the GFDL surface layer without such checks can lead to instability in the UFS. - + !znt_ice is in cm, z0max/ztmax are in m at this point z0max(i) = max(1.0e-6, min(0.01 * znt_ice(i), zkmax(i))) !** xubin's new z0 over land and sea ice @@ -511,17 +511,17 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & ztmax(i) = z0max(i)*exp( - tem1*tem1 & & * czilc*karman*sqrt(ustar_ice(i)*(0.01/1.5e-05))) ztmax(i) = max(ztmax(i), 1.0e-6) - - + + !GJF: from WRF's module_sf_gfdl.F if (wind10(i) <= 1.0e-10 .or. wind10(i) > 150.0) then wind10(i)=wspd(i)*alog(10.0/z0max(i))/alog(z1(i)/z0max(i)) end if wind10(i)=wind10(i)*100.0 !! m/s to cm/s - + ztmax(i) = ztmax(i)*100.0 !m to cm z0max(i) = z0max(i)*100.0 !m to cm - + call mflux2 (fxh(i), fxe(i), fxmx(i), fxmy(i), cdm_ice(i), rib_ice(i), & xxfh(i), ztmax(i), z0max(i), tstrc(i), & pspc(i), pkmax(i), wetc(i), slwdc(i), z1_cm(i), icoef_sf, iwavecpl, lcurr_sf, charn(i), msang(i), & @@ -529,61 +529,61 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & dt, wind10(i), xxfh2(i), ntsflg, sfenth, tzot(i), errmsg, & errflg) if (errflg /= 0) return - + !GJF: this is broken when tstrc is set to an average of two variables if (ntsflg==1) then - tskin_ice(i) = tstrc(i) ! gopal's doing + tskin_ice(i) = tstrc(i) ! gopal's doing end if - + if (diag_wind10m) then u10_ice(i) = u1(i)*(0.01*wind10(i)/wspd(i)) v10_ice(i) = v1(i)*(0.01*wind10(i)/wspd(i)) end if - + !GJF: these variables are not needed in a GFS-based suite, but are found in WRF's module_sf_gfdl.F and kept in comments for legacy !gz1oz0(i) = alog(zkmax(i)/znt_ice(i)) !taux(i) = fxmx(i)/10. ! gopal's doing for Ocean coupling !tauy(i) = fxmy(i)/10. ! gopal's doing for Ocean coupling - + cdm_ice(i) = max(cdm_ice(i), cd_low_limit) cdm_ice(i) = min(cdm_ice(i), cd_high_limit) fm_ice(i) = karman/sqrt(cdm_ice(i)) - + !1) try fh_ice from MFLUX2 fh_ice(i) = karman*xxfh(i) - + !2) calc ch_ice from fm_ice and fh_ice ch_ice(i) = karman*karman/(fm_ice(i) * fh_ice(i)) - + !3) check if ch_ice is out of bounds (if so, recalculate fh_ice from bounded value) ch_bound_excursion = .false. - if (ch_ice(i) < ch_low_limit) then + if (ch_ice(i) < ch_low_limit) then ch_bound_excursion = .true. ch_ice(i) = ch_low_limit else if (ch_ice(i) > ch_high_limit) then ch_bound_excursion = .true. ch_ice(i) = ch_high_limit end if - + fh2_ice(i) = karman*xxfh2(i) - + if (ch_bound_excursion) then fh2_fh_ratio = min(xxfh2(i)/xxfh(i), 1.0) fh_ice(i) = karman*karman/(fm_ice(i)*ch_ice(i)) fh2_ice(i) = fh2_fh_ratio*fh_ice(i) end if - + !Other CCPP schemes (PBL) ask for fm/fh instead of psim/psih !psim_ice(i)=gz1oz0(i)-fm_ice(i) !psih_ice(i)=gz1oz0(i)-fh_ice(i) - + ustar_ice(i) = 0.01*sqrt(cdm_ice(i)* & (upc(i)*upc(i) + vpc(i)*vpc(i))) !GJF: from Chunxi Zhang's module_sf_sfclayrev.f90 (I'm not sure it's necessary.) ustar_ice(i) = amax1(ustar_ice(i),0.001) - + stress_ice(i) = cdm_ice(i)*wspd(i)*wspd(i) - + !GJF: from WRF's module_sf_gfdl.F !!! convert cd, ch to values at 10m, for output cd10 = cdm_ice(i) @@ -594,29 +594,29 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & ! (alog(zkmax(i)/tmp9)/alog(10.0/tmp9)) end if fm10_ice(i) = karman/sqrt(cd10) - + !GJF: conductances aren't used in other CCPP schemes !chs_ice(i)=ch_ice(i)*wspd (i) !conductance !chs2_ice(i)=ustar_ice(i)*karman/fh2_ice(i) !2m conductance - + if (diag_qss) then esat = fpvs(tskin_ice(i)) qss_ice(i) = ep2*esat/(psfc(i)-esat) end if - + !flhc_ice(i)=cpm(i)*rho1(i)*chs_ice(i) !flqc_ice(i)=rho1(i)*chs_ice(i) !cqs2_ice(i)=chs2_ice(i) end if !ice - + if (wet(i)) then wetc(i) = 1.0 - + !GJF: the lower boundary temperature passed in to MFLUX2 either follows GFS: tstrc(i) = 0.5*(tskin_ocn(i) + tsurf_ocn(i)) !averaging tskin_ocn and tsurf_ocn as in GFS surface layer breaks ntsflg functionality !GJF: or WRF module_sf_gfdl.F: !tstrc(i) = tskin_ocn(i) - + ! DH* 20201009: these bounds on ocean roughness lengths are from Chunxi Zhang's module_sf_sfclayrev.f90 (in cm) znt_ocn(i)=min(2.85e-1,max(znt_ocn(i),1.27e-5)) @@ -625,10 +625,10 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & wind10(i)=wspd(i)*alog(10.0/(0.01*znt_ocn(i)))/alog(z1(i)/(0.01*znt_ocn(i))) end if wind10(i)=wind10(i)*100.0 !! m/s to cm/s - + !GJF: mflux2 expects negative roughness length for ocean points znt_ocn(i) = -znt_ocn(i) - + call mflux2 (fxh(i), fxe(i), fxmx(i), fxmy(i), cdm_ocn(i), rib_ocn(i), & xxfh(i), znt_ocn(i), mznt(i), tstrc(i), & pspc(i), pkmax(i), wetc(i), slwdc(i), z1_cm(i), icoef_sf, iwavecpl, lcurr_sf, charn(i), msang(i), & @@ -636,67 +636,67 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & dt, wind10(i), xxfh2(i), ntsflg, sfenth, tzot(i), errmsg, & errflg) if (errflg /= 0) return - + !GJF: this is broken when tstrc is set to an average of two variables if (ntsflg==1) then - tskin_ocn(i) = tstrc(i) ! gopal's doing + tskin_ocn(i) = tstrc(i) ! gopal's doing end if - + znt_ocn(i)= abs(znt_ocn(i)) mznt(i)= abs(mznt(i)) - + !GJF: these bounds on ocean roughness lengths are from Chunxi Zhang's module_sf_sfclayrev.f90 (in cm) znt_ocn(i)=min(2.85e-1,max(znt_ocn(i),1.27e-5)) - + if (diag_wind10m) then u10_ocn(i) = u1(i)*(0.01*wind10(i)/wspd(i)) v10_ocn(i) = v1(i)*(0.01*wind10(i)/wspd(i)) end if - + !GJF: these variables are not needed in a GFS-based suite, but are found in WRF's module_sf_gfdl.F and kept in comments for legacy !gz1oz0(i) = alog(zkmax(i)/znt_ocn(i)) !taux(i) = fxmx(i)/10. ! gopal's doing for Ocean coupling !tauy(i) = fxmy(i)/10. ! gopal's doing for Ocean coupling - + cdm_ocn(i) = max(cdm_ocn(i), cd_low_limit) cdm_ocn(i) = min(cdm_ocn(i), cd_high_limit) fm_ocn(i) = karman/sqrt(cdm_ocn(i)) - + !1) try fh_ocn from MFLUX2 fh_ocn(i) = karman*xxfh(i) - + !2) calc ch_ocn from fm_ocn and fh_ocn ch_ocn(i) = karman*karman/(fm_ocn(i) * fh_ocn(i)) - + !3) check if ch_lnd is out of bounds (if so, recalculate fh_lnd from bounded value) ch_bound_excursion = .false. - if (ch_ocn(i) < ch_low_limit) then + if (ch_ocn(i) < ch_low_limit) then ch_bound_excursion = .true. ch_ocn(i) = ch_low_limit else if (ch_ocn(i) > ch_high_limit) then ch_bound_excursion = .true. ch_ocn(i) = ch_high_limit end if - + fh2_ocn(i) = karman*xxfh2(i) - + if (ch_bound_excursion) then fh2_fh_ratio = min(xxfh2(i)/xxfh(i), 1.0) fh_ocn(i) = karman*karman/(fm_ocn(i)*ch_ocn(i)) fh2_ocn(i) = fh2_fh_ratio*fh_ocn(i) end if - + !Other CCPP schemes (PBL) ask for fm/fh instead of psim/psih !psim_ocn(i)=gz1oz0(i)-fm_ocn(i) !psih_ocn(i)=gz1oz0(i)-fh_ocn(i) - + ustar_ocn(i) = 0.01*sqrt(cdm_ocn(i)* & (upc(i)*upc(i) + vpc(i)*vpc(i))) !GJF: from Chunxi Zhang's module_sf_sfclayrev.f90 (I'm not sure it's necessary.) ustar_ocn(i) = amax1(ustar_ocn(i),0.001) - + stress_ocn(i) = cdm_ocn(i)*wspd(i)*wspd(i) - + !GJF: from WRF's module_sf_gfdl.F !!! convert cd, ch to values at 10m, for output cd10 = cdm_ocn(i) @@ -707,23 +707,23 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & ! (alog(zkmax(i)/tmp9)/alog(10.0/tmp9)) end if fm10_ocn(i) = karman/sqrt(cd10) - + !GJF: conductances aren't used in other CCPP schemes !chs_ocn(i)=ch_ocn(i)*wspd (i) !conductance !chs2_ocn(i)=ustar_ocn(i)*karman/fh2_ocn(i) !2m conductance - + if (diag_qss) then esat = fpvs(tskin_ocn(i)) qss_ocn(i) = ep2*esat/(psfc(i)-esat) end if end if !wet - + !flhc_ocn(i)=cpm(i)*rho1(i)*chs_ocn(i) !flqc_ocn(i)=rho1(i)*chs_ocn(i) !cqs2_ocn(i)=chs2_ocn(i) end if !flag_iter end do - + !GJF: this code has not been updated since GFS suites don't require this; one would need to have different values of hfx, qfx, lh for each surface type ! if (isfflx.eq.0) then ! do i=its,ite @@ -737,7 +737,7 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & ! !water ! hfx(i)= -10.*cp*fxh(i) ! else if (islmsk == 1) then - ! hfx(i)= -10.*cp*fxh(i) + ! hfx(i)= -10.*cp*fxh(i) ! hfx(i)=amax1(hfx(i),-250.) ! end if ! qfx(j)=-10.*fxe(i) @@ -745,8 +745,8 @@ subroutine gfdl_sfc_layer_run (im, nsoil, km, xlat, xlon, flag_iter, lsm, & ! lh(i)=xlv*qfx(i) ! enddo ! endif - - + + end subroutine gfdl_sfc_layer_run !--------------------------------- @@ -757,13 +757,13 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m pert_Cd, ens_random_seed, ens_Cdamp, & upc,vpc,tpc,rpc,dt,wind10,xxfh2,ntsflg,sfenth, & tzot, errmsg, errflg) - + !------------------------------------------------------------------------ ! -! MFLUX2 computes surface fluxes of momentum, heat,and moisture -! using monin-obukhov. the roughness length "z0" is prescribed +! MFLUX2 computes surface fluxes of momentum, heat,and moisture +! using monin-obukhov. the roughness length "z0" is prescribed ! over land and over ocean "z0" is computed using charnocks formula. -! the universal functions (from similarity theory approach) are +! the universal functions (from similarity theory approach) are ! those of hicks. This is Bob's doing. ! !------------------------------------------------------------------------ @@ -785,7 +785,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m integer,intent(in) :: icoef_sf integer,intent(in) :: iwavecpl logical,intent(in) :: lcurr_sf - logical,intent(in) :: pert_Cd + logical,intent(in) :: pert_Cd integer,intent(in) :: ens_random_seed real(kind=kind_phys),intent(in) :: ens_Cdamp @@ -818,7 +818,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m real(kind=kind_phys), intent ( in), dimension (ims :ime ) :: vpc real(kind=kind_phys), intent ( in), dimension (ims :ime ) :: tpc real(kind=kind_phys), intent ( in), dimension (ims :ime ) :: rpc - + character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -844,7 +844,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m real(kind=kind_phys), dimension(1 :ime) :: estsop real(kind=kind_phys), dimension(1 :ime) :: fmz1 real(kind=kind_phys), dimension(1 :ime) :: fmz10 - real(kind=kind_phys), dimension(1 :ime) :: fmz2 + real(kind=kind_phys), dimension(1 :ime) :: fmz2 real(kind=kind_phys), dimension(1 :ime) :: fmzo1 real(kind=kind_phys), dimension(1 :ime) :: foft real(kind=kind_phys), dimension(1 :ime) :: foftm @@ -858,7 +858,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m real(kind=kind_phys), dimension(1 :ime) :: rstso real(kind=kind_phys), dimension(1 :ime) :: rstsop real(kind=kind_phys), dimension(1 :ime) :: sf10 - real(kind=kind_phys), dimension(1 :ime) :: sf2 + real(kind=kind_phys), dimension(1 :ime) :: sf2 real(kind=kind_phys), dimension(1 :ime) :: sfm real(kind=kind_phys), dimension(1 :ime) :: sfzo real(kind=kind_phys), dimension(1 :ime) :: sgzm @@ -879,7 +879,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m real(kind=kind_phys), dimension(1 :ime) :: tss real(kind=kind_phys), dimension(1 :ime) :: ucom real(kind=kind_phys), dimension(1 :ime) :: uf10 - real(kind=kind_phys), dimension(1 :ime) :: uf2 + real(kind=kind_phys), dimension(1 :ime) :: uf2 real(kind=kind_phys), dimension(1 :ime) :: ufh real(kind=kind_phys), dimension(1 :ime) :: ufm real(kind=kind_phys), dimension(1 :ime) :: ufzo @@ -897,7 +897,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m real(kind=kind_phys), dimension(1 :ime) :: xxfm real(kind=kind_phys), dimension(1 :ime) :: xxsh real(kind=kind_phys), dimension(1 :ime) :: z10 - real(kind=kind_phys), dimension(1 :ime) :: z2 + real(kind=kind_phys), dimension(1 :ime) :: z2 real(kind=kind_phys), dimension(1 :ime) :: zeta real(kind=kind_phys), dimension(1 :ime) :: zkmax @@ -913,7 +913,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m real(kind=kind_phys) :: ux13, yo, y,xo,x,ux21,ugzzo,ux11,ux12,uzetao,xnum,alll real(kind=kind_phys) :: ux1,ugz,x10,uzo,uq,ux2,ux3,xtan,xden,y10,uzet1o,ugz10 - real(kind=kind_phys) :: szet2, zal2,ugz2 + real(kind=kind_phys) :: szet2, zal2,ugz2 real(kind=kind_phys) :: rovcp,boycon,cmo2,psps1,zog,enrca,rca,cmo1,amask,en,ca,a,c real(kind=kind_phys) :: sgz,zal10,szet10,fmz,szo,sq,fmzo,rzeta1,zal1g,szetao,rzeta2,zal2g real(kind=kind_phys) :: hcap,xks,pith,teps,diffot,delten,alevp,psps2,alfus,nstep @@ -928,7 +928,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m ! internal variables !----------------------------------------------------------------------- - real(kind=kind_phys), dimension (223) :: tab + real(kind=kind_phys), dimension (223) :: tab real(kind=kind_phys), dimension (223) :: table real(kind=kind_phys), dimension (101) :: tab11 real(kind=kind_phys), dimension (41) :: table4 @@ -950,7 +950,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m data amask/ -98.0/ !----------------------------------------------------------------------- -! tables used to obtain the vapor pressures or saturated vapor +! tables used to obtain the vapor pressures or saturated vapor ! pressure !----------------------------------------------------------------------- @@ -1006,7 +1006,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m data table3/.7520e+03,.7980e+03,.8470e+03,.8980e+03,.9520e+03, & &.1008e+04,.1067e+04,.1129e+04,.1194e+04,.1263e+04,.1334e+04, & &.1409e+04,.1488e+04,.1569e+04,.1656e+04,.1745e+04,.1840e+04, & - &.1937e+04,.2041e+04,.2147e+04,.2259e+04,.2375e+04,.2497e+04, & + &.1937e+04,.2041e+04,.2147e+04,.2259e+04,.2375e+04,.2497e+04, & &.2624e+04,.2756e+04,.2893e+04,.3036e+04,.3186e+04,.3340e+04, & &.3502e+04,.3670e+04,.3843e+04,.4025e+04,.4213e+04,.4408e+04, & &.4611e+04,.4821e+04,.5035e+04,.5270e+04,.5500e+04,.5740e+04, & @@ -1030,7 +1030,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m real,parameter :: rgas = 2.87e6 real,parameter :: og = 1./g integer :: ntstep = 0 - + ! Initialize CCPP error handling variables errmsg = '' errflg = 0 @@ -1075,7 +1075,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m ! routine = 'mflux2' ! !------------------------------------------------------------------------ -! set water availability constant "ecof" and land mask "land". +! set water availability constant "ecof" and land mask "land". ! limit minimum wind speed to 100 cm/s !------------------------------------------------------------------------ ! constants for 10 m winds (correction for knots @@ -1165,13 +1165,13 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m enddo !------------------------------------------------------------------------ -! define constants: -! a and c = constants used in evaluating universal function for -! stable case -! ca = karmen constant -! cm01 = constant part of vertical integral of universal -! function; stable case ( 0.5 < zeta < or = 10.0) -! cm02 = constant part of vertical integral of universal +! define constants: +! a and c = constants used in evaluating universal function for +! stable case +! ca = karmen constant +! cm01 = constant part of vertical integral of universal +! function; stable case ( 0.5 < zeta < or = 10.0) +! cm02 = constant part of vertical integral of universal ! function; stable case ( zeta > 10.0) !------------------------------------------------------------------------ @@ -1207,14 +1207,14 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m if(psps1 .EQ. 0.0)then psps1 = .1 endif - rstso(i) = 0.622*estso(i)/psps1 + rstso(i) = 0.622*estso(i)/psps1 vrts (i) = 1. + boycon*ecof(i)*rstso(i) enddo !------------------------------------------------------------------------ ! check if consideration of virtual temperature changes stability. -! if so, set "dthetav" to near neutral value (1.0e-4). also check -! for very small lapse rates; if ABS(tempa1) <1.0e-4 then +! if so, set "dthetav" to near neutral value (1.0e-4). also check +! for very small lapse rates; if ABS(tempa1) <1.0e-4 then ! tempa1=1.0e-4 !------------------------------------------------------------------------ @@ -1241,13 +1241,13 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m enddo !------------------------------------------------------------------------ -! begin looping through points on line, solving wegsteins iteration +! begin looping through points on line, solving wegsteins iteration ! for zeta at each point, and using hicks functions !------------------------------------------------------------------------ !------------------------------------------------------------------------ -! set initial guess of zeta=non - dimensional height "szeta" for -! stable points +! set initial guess of zeta=non - dimensional height "szeta" for +! stable points !------------------------------------------------------------------------ rca = 1./ca @@ -1349,14 +1349,14 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m if (szet2 .LE. 0.5) then fmz2 (i) = (zal2 + a*szet2 )*rca else if (szet2 .GT. 0.5 .AND. szet2 .LE. 2.) then - rzeta2 = 1./szet2 + rzeta2 = 1./szet2 fmz2 (i) = (8.*zal2 + 4.25*rzeta2 - & 0.5*rzeta2*rzeta2 + cmo1)*rca else if (szet2 .GT. 2.) then fmz2 (i) = (c*szet2 + cmo2)*rca endif sf2 (i) = fmz2 (i) - fmzo1(i) - + sfm(i) = fmz1(i) - fmzo1(i) sfh(i) = fmz1(i) - fhzo1(i) sgz = ca*rib(istb(i))*sfm(i)*sfm(i)/ & @@ -1388,7 +1388,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m go to 130 110 continue - + write(errmsg,'(*(a))') 'NON-CONVERGENCE FOR STABLE ZETA IN gfdl_sfc_layer.F90/MFLUX2' errflg = 1 return @@ -1397,7 +1397,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m !------------------------------------------------------------------------ ! update "zo" for ocean points. "zo"cannot be updated within the ! wegsteins iteration as the scheme (for the near neutral case) -! can become unstable +! can become unstable !------------------------------------------------------------------------ 130 continue @@ -1419,7 +1419,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m ustar = sqrt( -szo / zog) restar = -ustar * szo / vis - restar = max(restar,cons_p000001) + restar = max(restar,cons_p000001) ! Rat taken from Zeng, Zhao and Dickinson 1997 rat = 2.67 * restar ** .25 - 2.57 rat = min(rat ,cons_7) !constant @@ -1428,7 +1428,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m else zot(istb(i)) = zoc(istb(i)) endif - + ! in hwrf thermal znot is loaded back into the zoc array for next step zoc(istb(i)) = szo enddo @@ -1453,7 +1453,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m endif ! the above correction done by GFDL in centi-kts!!!-change back wind10(istb(i)) = wind10(istb(i)) / 1.944 - enddo + enddo !------------------------------------------------------------------------ ! unstable points @@ -1540,7 +1540,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m ugz2 = ALOG(z2 (iutb(i))/ABS(zoc(iutb(i)))) uzet1o = ABS(z2 (iutb(i)))/zkmax(iutb(i))*uzeta(i) uzetao = ABS(zoc(iutb(i)))/zkmax(iutb(i))*uzeta(i) - ux11 = 1. - 16.*uzet1o + ux11 = 1. - 16.*uzet1o ux12 = 1. - 16.*uzetao y = SQRT(ux11) yo = SQRT(ux12) @@ -1582,7 +1582,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m 'uq is 1 ',ux2,ugz,ugzm(i),uzeta(i),uzetam(i) errflg = 1 return - + ! call MPI_CLOSE(1,routine) !------------------------------------------------------------------------ @@ -1594,7 +1594,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m !------------------------------------------------------------------------ ! update "zo" for ocean points. zo cannot be updated within the ! wegsteins iteration as the scheme (for the near neutral case) -! can become unstable. +! can become unstable. !------------------------------------------------------------------------ do i = 1,iq @@ -1639,7 +1639,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m endif ! the above correction done by GFDL in centi-kts!!!-change back wind10(iutb(i)) = wind10(iutb(i)) / 1.944 - enddo + enddo do i = 1,iq xxfm(iutb(i)) = ufm(i) @@ -1664,7 +1664,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m enddo ! do land sfc temperature prediction if ntsflg=1 -! ntsflg = 1 ! gopal's doing +! ntsflg = 1 ! gopal's doing if (ntsflg .EQ. 0) go to 370 alll = 600. @@ -1674,7 +1674,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m alfus = alll/2.39e-8 teps = 0.1 ! slwdc... in units of cal/min ???? -! slwa... in units of ergs/sec/cm*2 +! slwa... in units of ergs/sec/cm*2 ! 1 erg=2.39e-8 cal !------------------------------------------------------------------------ ! pack land and sea ice points @@ -1735,7 +1735,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m if(psps2 .EQ. 0.0)then psps2 = .1 endif - rstsop(i) = 0.622*estsop(i)/psps2 + rstsop(i) = 0.622*estsop(i)/psps2 rdiff (i) = amin1(0.0,(rkmaxp(i) - rstsop(i))) foft(i) = tss(i) + delsrad(i)*(slwa(i) - aap(i)*tsp(i)**4 - & @@ -1745,7 +1745,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m frac(i) = ABS((foft(i) - tsp(i))/tsp(i)) !------------------------------------------------------------------------ -! check for convergence of all points use wegstein iteration +! check for convergence of all points use wegstein iteration !------------------------------------------------------------------------ if (frac(i) .GE. teps) then @@ -1773,7 +1773,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m ! call MPI_CLOSE(1,routine) endif enddo - + do i = 1,ip ii = indx(i) tstrc(ii) = tsp (i) @@ -1785,7 +1785,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m 370 continue do i = its,ite -!!! +!!! if ( iwavecpl .eq. 1 .and. zoc(i) .le. 0.0 ) then windmks = wind10(i) * 0.01 call znot_wind10m(windmks,znott,znotm,icoef_sf) @@ -1819,5 +1819,5 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m ntstep = ntstep + 1 return end subroutine MFLUX2 - + end module gfdl_sfc_layer From d2573475a773ce3cece181d5b86af676229fdcce Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Sat, 10 Oct 2020 15:34:48 -0600 Subject: [PATCH 35/42] Fix error handling in physics/radlw_main.F90 --- physics/radlw_main.F90 | 36 +++++++++++++++++++++++------------- 1 file changed, 23 insertions(+), 13 deletions(-) diff --git a/physics/radlw_main.F90 b/physics/radlw_main.F90 index f5278ed33..b7e93d06b 100644 --- a/physics/radlw_main.F90 +++ b/physics/radlw_main.F90 @@ -1213,8 +1213,10 @@ subroutine rrtmg_lw_run & call cldprmc(nlay, inflglw, iceflglw, liqflglw, & & cldfmc, ciwpmc, & & clwpmc, cswpmc, reicmc, relqmc, resnmc, & - & ncbands, taucmc) - endif + & ncbands, taucmc, errmsg, errflg) + ! return immediately if cldprmc throws an error + if (errflg/=0) return + endif ! if (lprnt) then ! print *,' after cldprop' @@ -7959,7 +7961,7 @@ end subroutine rtrnmc_mcica ! ------------------------------------------------------------------------------ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & - & ciwpmc, clwpmc, cswpmc, reicmc, relqmc, resnmc, ncbands, taucmc) + & ciwpmc, clwpmc, cswpmc, reicmc, relqmc, resnmc, ncbands, taucmc, errmsg, errflg) ! ------------------------------------------------------------------------------ ! Purpose: Compute the cloud optical depth(s) for each cloudy layer. @@ -7998,9 +8000,11 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & ! ------- Output ------- - integer(kind=im), intent(out) :: ncbands ! number of cloud spectral bands - real(kind=rb), intent(inout) :: taucmc(:,:) ! cloud optical depth [mcica] + integer(kind=im), intent(out) :: ncbands ! number of cloud spectral bands + real(kind=rb), intent(inout) :: taucmc(:,:) ! cloud optical depth [mcica] ! Dimensions: (ngptlw,nlayers) + character(len=*), intent(inout) :: errmsg + integer, intent(inout) :: errflg ! ------- Local ------- @@ -8027,7 +8031,6 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 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 ------- @@ -8784,10 +8787,11 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 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)' ) & + write(errmsg,'(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) + & ,ig, lay, ciwpmc(ig,lay), radice + errflg = 1 + return end if ncbands = 16 factor = (radice - 2._rb)/3._rb @@ -8806,10 +8810,11 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 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)' ) & + write(errmsg,'(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) + errflg = 1 + return end if ncbands = 16 factor = (radsno - 2._rb)/3._rb @@ -8833,8 +8838,13 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & 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' + if (radliq .lt. 2.5_rb .or. radliq .gt. 60._rb) then + write(errmsg,'(a,i5,i5,f8.2,f8.2)' ) & +& 'ERROR: LIQUID EFFECTIVE SIZE OUT OF BOUNDS' & +& ,ig, lay, clwpmc(ig,lay), radliq + errflg = 1 + return + end if index = int(radliq - 1.5_rb) if (index .eq. 0) index = 1 if (index .eq. 58) index = 57 From 57d1b4d9f4a77bc5c0b8dcc797c0bfa7249a78cb Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Tue, 13 Oct 2020 20:14:21 -0600 Subject: [PATCH 36/42] Bugfixes following update from master --- physics/GFS_rrtmg_pre.F90 | 10 +- physics/GFS_rrtmg_pre.meta | 10 +- physics/moninedmf.f | 4 +- physics/radiation_clouds.f | 883 +++++++++++++++++++------------------ physics/radlw_main.F90 | 2 +- 5 files changed, 466 insertions(+), 443 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 9bde61c62..109df3b65 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -27,7 +27,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & lmfdeep2, fhswr, fhlwr, solhr, sup, eps, epsm1, fvirt, & rog, rocp, con_rd, xlat_d, xlat, xlon, coslat, sinlat, tsfc, slmsk, & prsi, prsl, prslk, tgrs, sfc_wts, mg_cld, effrr_in, & - cnvw_in, cnvc_in, qgrs, aer_nm, dx, & !inputs from here and above + cnvw_in, cnvc_in, qgrs, aer_nm, dx, icloud, & !inputs from here and above coszen, coszdg, effrl_inout, effri_inout, effrs_inout, & clouds1, clouds2, clouds3, clouds4, clouds5, & !in/out from here and above kd, kt, kb, mtopa, mbota, raddt, tsfg, tsfa, de_lgth, alb1d, delp, dz, & !output from here and below @@ -91,7 +91,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & imp_physics_zhao_carr_pdf, & imp_physics_mg, imp_physics_wsm6, & imp_physics_fer_hires, & - yearlen + yearlen, icloud character(len=3), dimension(:), intent(in) :: lndp_var_list @@ -104,7 +104,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & real(kind=kind_phys), dimension(:), intent(in) :: xlat_d, xlat, xlon, & coslat, sinlat, tsfc, & - slmsk + slmsk, dx real(kind=kind_phys), dimension(:,:), intent(in) :: prsi, prsl, prslk, & tgrs, sfc_wts, & @@ -846,7 +846,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & endif !mz HWRF physics: icloud=3 - if(Model%icloud == 3) then + if(icloud == 3) then ! Set internal dimensions ids = 1 @@ -1023,7 +1023,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & else ! MYNN PBL or GF convective are not used - call progcld5 (plyr,plvl,tlyr,qlyr,qstl,rhly,tracer1, & ! --- inputs + call progcld6 (plyr,plvl,tlyr,qlyr,qstl,rhly,tracer1, & ! --- inputs xlat,xlon,slmsk,dz,delp, & ntrac-1, ntcw-1,ntiw-1,ntrw-1, & ntsw-1,ntgl-1, & diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index f3571b49d..2876f295d 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -675,11 +675,19 @@ standard_name = cell_size long_name = relative dx for the grid cell units = m - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in optional = F +[icloud] + standard_name = cloud_effect_to_optical_depth_and_cloud_fraction + long_name = cloud effect to the optical depth and cloud fraction in radiation + units = flag + dimensions = () + type = integer + intent = in + optional = F [coszen] standard_name = cosine_of_zenith_angle long_name = mean cos of zenith angle over rad call period diff --git a/physics/moninedmf.f b/physics/moninedmf.f index 4951c7056..d5cb2ded3 100644 --- a/physics/moninedmf.f +++ b/physics/moninedmf.f @@ -65,7 +65,7 @@ subroutine hedmf_run (im,km,ntrac,ntcw,dv,du,tau,rtg, & & dusfc,dvsfc,dtsfc,dqsfc,hpbl,hgamt,hgamq,dkt, & & kinver,xkzm_m,xkzm_h,xkzm_s,lprnt,ipr, & & xkzminv,moninq_fac,hurr_pbl,islimsk,var_ric, & - & coef_ric_l,coef_ric_s,lssav,ldiag3d,qdiag3d,lsidea,ntoz, & + & coef_ric_l,coef_ric_s,lssav,ldiag3d,qdiag3d,ntoz, & & du3dt_PBL,dv3dt_PBL,dt3dt_PBL,dq3dt_PBL,do3dt_PBL, & & flag_for_pbl_generic_tend,errmsg,errflg) ! @@ -82,7 +82,7 @@ subroutine hedmf_run (im,km,ntrac,ntcw,dv,du,tau,rtg, & ! arguments ! logical, intent(in) :: lprnt, hurr_pbl, lssav, ldiag3d, qdiag3d - logical, intent(in) :: lsidea, flag_for_pbl_generic_tend + logical, intent(in) :: flag_for_pbl_generic_tend integer, intent(in) :: ipr, islimsk(im) integer, intent(in) :: im, km, ntrac, ntcw, kinver(im), ntoz integer, intent(out) :: kpbl(im) diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index 160b47167..552037da2 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -198,7 +198,7 @@ !! !! Sub-grid cloud approximation (namelist control parameter - \b ISUBC_LW=2, \b ISUBC_SW=2) !!\n ISUBC=0: grid averaged quantities, without sub-grid cloud approximation -!!\n ISUBC=1: with McICA sub-grid approximation (use prescribed permutation seeds) +!!\n ISUBC=1: with McICA sub-grid approximation (use prescribed permutation seeds) !!\n ISUBC=2: with McICA sub-grid approximation (use random permutation seeds) !! !!\version NCEP-Radiation_clouds v5.1 Nov 2012 @@ -206,7 +206,7 @@ !! @} !> This module computes cloud related quantities for radiation computations. - module module_radiation_clouds + module module_radiation_clouds ! use physparam, only : icldflg, iovrsw, iovrlw, & & lcrick, lcnorm, lnoprec, & @@ -657,7 +657,7 @@ subroutine progcld1 & enddo endif -!> - Compute SFC/low/middle/high cloud top pressure for each cloud +!> - Compute SFC/low/middle/high cloud 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) @@ -786,14 +786,14 @@ subroutine progcld1 & enddo endif -!> - Compute effective ice cloud droplet radius following Heymsfield +!> - Compute effective ice cloud droplet radius following Heymsfield !! and McFarquhar (1996) \cite heymsfield_and_mcfarquhar_1996. if(.not.effr_in) then 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)) @@ -840,7 +840,7 @@ subroutine progcld1 & endif !> - Call subroutine get_alpha_exp to define alpha parameter for EXP and ER cloud overlap options - if ( iovr == 4 .or. iovr == 5 ) then + if ( iovr == 4 .or. iovr == 5 ) then call get_alpha_exp & ! --- inputs: & (ix, nlay, dzlay, iovr, latdeg, julian, yearlen, cldtot, & @@ -851,8 +851,8 @@ subroutine progcld1 & !> - 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. The three cloud domain boundaries are defined by -!! ptopc. The cloud overlapping method is defined by control flag +!! 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: @@ -893,7 +893,7 @@ end subroutine progcld1 !!\param delp (IX,NLAY), model layer pressure thickness in mb (100Pa) !!\param IX horizontal dimention !!\param NLAY,NLP1 vertical layer/level dimensions -!!\param lmfshal flag for mass-flux shallow convection scheme in the cloud fraction calculation +!!\param lmfshal flag for mass-flux shallow convection scheme in the cloud fraction calculation !!\param lmfdeep2 flag for mass-flux deep convection scheme in the cloud fraction calculation !!\param dzlay(ix,nlay) distance between model layer centers !!\param latdeg(ix) latitude (in degrees 90 -> -90) @@ -917,9 +917,9 @@ end subroutine progcld1 !> @{ subroutine progcld2 & & ( plyr,plvl,tlyr,qlyr,qstl,rhly,tvly,clw, & ! --- inputs: - & xlat,xlon,slmsk,dz,delp, & + & xlat,xlon,slmsk,dz,delp, & & ntrac, ntcw, ntiw, ntrw, & - & IX, NLAY, NLP1, lmfshal, lmfdeep2, & + & IX, NLAY, NLP1, lmfshal, lmfdeep2, & & dzlay, latdeg, julian, yearlen, & & clouds,clds,mtop,mbot,de_lgth,alpha & ! --- outputs: & ) @@ -1111,7 +1111,7 @@ subroutine progcld2 & enddo !> - Compute cloud ice effective radii - + do k = 1, NLAY do i = 1, IX tem2 = tlyr(i,k) - con_ttp @@ -1219,7 +1219,7 @@ subroutine progcld2 & 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,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) @@ -1236,7 +1236,7 @@ subroutine progcld2 & endif !> - Call subroutine get_alpha_exp to define alpha parameter for EXP and ER cloud overlap options - if ( iovr == 4 .or. iovr == 5 ) then + if ( iovr == 4 .or. iovr == 5 ) then call get_alpha_exp & ! --- inputs: & (ix, nlay, dzlay, iovr, latdeg, julian, yearlen, cldtot, & @@ -1295,7 +1295,7 @@ end subroutine progcld2 !!\param nlay,nlp1 vertical layer/level dimensions !!\param deltaq (ix,nlay), half total water distribution width !!\param sup supersaturation -!!\param kdt +!!\param kdt !!\param me print control flag !!\param dzlay(ix,nlay) distance between model layer centers !!\param latdeg(ix) latitude (in degrees 90 -> -90) @@ -1663,7 +1663,7 @@ subroutine progcld3 & endif !> - Call subroutine get_alpha_exp to define alpha parameter for EXP and ER cloud overlap options - if ( iovr == 4 .or. iovr == 5 ) then + if ( iovr == 4 .or. iovr == 5 ) then call get_alpha_exp & ! --- inputs: & (ix, nlay, dzlay, iovr, latdeg, julian, yearlen, cldtot, & @@ -1699,7 +1699,7 @@ end subroutine progcld3 !----------------------------------- !> \ingroup module_radiation_clouds -!> This subroutine computes cloud related quantities using +!> This subroutine computes cloud related quantities using !! GFDL Lin MP prognostic cloud microphysics scheme. !!\param plyr (ix,nlay), model layer mean pressure in mb (100Pa) !!\param plvl (ix,nlp1), model level pressure in mb (100Pa) @@ -1726,7 +1726,7 @@ end subroutine progcld3 !!\param julian day of the year (fractional julian day) !!\param yearlen current length of the year (365/366 days) !!\param clouds (ix,nlay,nf_clds), cloud profiles -!!\n clouds(:,:,1) - layer total cloud fraction +!!\n clouds(:,:,1) - layer total cloud fraction !!\n clouds(:,:,2) - layer cloud liquid water path (\f$g m^{-2}\f$) !!\n clouds(:,:,3) - mean effective radius for liquid cloud (micron) !!\n clouds(:,:,4) - layer cloud ice water path (\f$g m^{-2}\f$) @@ -1742,10 +1742,10 @@ end subroutine progcld3 !!\param alpha (IX,NLAY), alpha decorrelation parameter !>\section gen_progcld4 progcld4 General Algorithm !! @{ - subroutine progcld4 & + 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, & & dzlay, latdeg, julian, yearlen, & & clouds,clds,mtop,mbot,de_lgth,alpha & ! --- outputs: & ) @@ -2026,7 +2026,7 @@ subroutine progcld4 & endif !> - Call subroutine get_alpha_exp to define alpha parameter for EXP and ER cloud overlap options - if ( iovr == 4 .or. iovr == 5 ) then + if ( iovr == 4 .or. iovr == 5 ) then call get_alpha_exp & ! --- inputs: & (ix, nlay, dzlay, iovr, latdeg, julian, yearlen, cldtot, & @@ -2102,9 +2102,9 @@ end subroutine progcld4 !!\n clouds(:,:,8) - layer snow flake water path (\f$g m^{-2}\f$) !!\n clouds(:,:,9) - mean effective radius for snow flake (micron) !>\param clds (ix,5), fraction of clouds for low, mid, hi, tot, bl -!>\param mtop (ix,3), vertical indices for low, mid, hi cloud tops +!>\param mtop (ix,3), vertical indices for low, mid, hi cloud tops !>\param mbot (ix,3), vertical indices for low, mid, hi cloud bases -!>\param de_lgth clouds decorrelation length (km) +!>\param de_lgth clouds decorrelation length (km) !!\param alpha (IX,NLAY), alpha decorrelation parameter !>\section gen_progcld4o progcld4o General Algorithm !! @{ @@ -2363,7 +2363,7 @@ subroutine progcld4o & 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) + clouds(i,k,6) = crp(i,k) clouds(i,k,7) = rer(i,k) clouds(i,k,8) = csp(i,k) clouds(i,k,9) = rei(i,k) @@ -2380,7 +2380,7 @@ subroutine progcld4o & endif !> - Call subroutine get_alpha_exp to define alpha parameter for EXP and ER cloud overlap options - if ( iovr == 4 .or. iovr == 5 ) then + if ( iovr == 4 .or. iovr == 5 ) then call get_alpha_exp & ! --- inputs: & (ix, nlay, dzlay, iovr, latdeg, julian, yearlen, cldtot, & @@ -2513,12 +2513,12 @@ subroutine progcld5 & ! --- inputs integer, intent(in) :: IX, NLAY, NLP1, ICLOUD - integer, intent(in) :: ntrac, ntcw, ntiw, ntrw + integer, intent(in) :: ntrac, ntcw, ntiw, ntrw logical, intent(in) :: uni_cld, lmfshal, lmfdeep2 real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & - & tlyr, tvly, qlyr, qstl, rhly, cldcov, delp, dz + & tlyr, tvly, qlyr, qstl, rhly, cldcov, delp, dz, dzlay real (kind=kind_phys), dimension(:,:), intent(inout) :: & & re_cloud, re_ice, re_snow @@ -2577,9 +2577,9 @@ subroutine progcld5 & crp (i,k) = 0.0 csp (i,k) = 0.0 rew (i,k) = re_cloud(i,k) - rei (i,k) = re_ice(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) + 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 @@ -2605,7 +2605,7 @@ subroutine progcld5 & do k = 1, NLAY do i = 1, IX - clwf(i,k) = clw(i,k,ntcw) + clw(i,k,ntiw) + clwf(i,k) = clw(i,k,ntcw) + clw(i,k,ntiw) enddo enddo !> - Find top pressure for each cloud domain for given latitude. @@ -2726,7 +2726,7 @@ subroutine progcld5 & enddo enddo endif -!mz +!mz if (icloud .ne. 0) then ! assign/calculate efective radii for cloud water, ice, rain, snow @@ -2748,7 +2748,7 @@ subroutine progcld5 & endif enddo -!> -# Compute effective ice cloud droplet radius following Heymsfield +!> -# Compute effective ice cloud droplet radius following Heymsfield !! and McFarquhar (1996) \cite heymsfield_and_mcfarquhar_1996. do k = 1, NLAY @@ -2770,13 +2770,13 @@ subroutine progcld5 & rei(i,k) = max(25.,rei(i,k)) !mz* HWRF endif rei(i,k) = min(rei(i,k), 135.72) !- 1.0315*rei<= 140 microns - enddo - enddo + enddo + enddo -!mz +!mz !> -# Compute effective snow cloud droplet radius - do k = 1, NLAY - do i = 1, IX + do k = 1, NLAY + do i = 1, IX res(i,k) = 10.0 enddo enddo @@ -2790,14 +2790,14 @@ subroutine progcld5 & 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,6) = crp(i,k) ! added for Thompson clouds(i,k,7) = rer(i,k) !mz inflg .ne.5 - clouds(i,k,8) = 0. + 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_ice(i,k) = rei(i,k) re_snow(i,k) = 10. enddo @@ -2813,7 +2813,7 @@ subroutine progcld5 & endif !> - Call subroutine get_alpha_exp to define alpha parameter for EXP and ER cloud overlap options - if ( iovr == 4 .or. iovr == 5 ) then + if ( iovr == 4 .or. iovr == 5 ) then call get_alpha_exp & ! --- inputs: & (ix, nlay, dzlay, iovr, latdeg, julian, yearlen, cldtot, & @@ -2856,7 +2856,8 @@ subroutine progcld6 & & IX, NLAY, NLP1, & & uni_cld, lmfshal, lmfdeep2, cldcov, & & re_cloud,re_ice,re_snow, & - & clouds,clds,mtop,mbot,de_lgth & ! --- outputs: + & dzlay, latdeg, julian, yearlen, & + & clouds,clds,mtop,mbot,de_lgth,alpha & ! --- outputs: & ) ! ================= subprogram documentation block ================ ! @@ -2876,296 +2877,301 @@ subroutine progcld6 & ! 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 ===================== ! -! +! 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) + logical, intent(in) :: uni_cld, lmfshal, lmfdeep2 + + real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & + & tlyr, qlyr, qstl, rhly, cldcov, delp, dz, dzlay, & + & re_cloud, re_ice, re_snow + + real (kind=kind_phys), dimension(:,:,:), intent(in) :: clw + + real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & + & slmsk + + real(kind=kind_phys), dimension(:), intent(in) :: latdeg + real(kind=kind_phys), intent(in) :: julian + integer, intent(in) :: yearlen + +! --- 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 + real (kind=kind_phys), dimension(:,:), intent(out) :: alpha + + 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 - + +! --- 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 + 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 @@ -3173,9 +3179,19 @@ subroutine progcld6 & enddo endif +!> - Call subroutine get_alpha_exp to define alpha parameter for EXP and ER cloud overlap options + if ( iovr == 4 .or. iovr == 5 ) then + call get_alpha_exp & +! --- inputs: + & (ix, nlay, dzlay, iovr, latdeg, julian, yearlen, cldtot, & +! --- outputs: + & alpha & + & ) + 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. +!! 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 @@ -3184,15 +3200,14 @@ subroutine progcld6 & call gethml & ! --- inputs: - & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, & + & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, alpha, & & IX,NLAY, & ! --- outputs: & clds, mtop, mbot & & ) - ! - return + return !............................................ end subroutine progcld6 @@ -3233,9 +3248,9 @@ end subroutine progcld6 !!\n (:,:,3) - mean eff radius for liq cloud (micron) !!\n (:,:,4) - layer cloud ice water path \f$(g/m^2)\f$ !!\n (:,:,5) - mean eff radius for ice cloud (micron) -!!\n (:,:,6) - layer rain drop water path +!!\n (:,:,6) - layer rain drop water path !!\n (:,:,7) - mean eff radius for rain drop (micron) -!!\n (:,:,8) - layer snow flake water path +!!\n (:,:,8) - layer snow flake water path !!\n (:,:,9) - mean eff radius for snow flake (micron) !!\param clds (IX,5), fraction of clouds for low, mid, hi, tot, bl !!\param mtop (IX,3), vertical indices for low, mid, hi cloud tops @@ -3494,7 +3509,7 @@ subroutine progclduni & endif enddo -!> -# Compute effective ice cloud droplet radius following Heymsfield +!> -# Compute effective ice cloud droplet radius following Heymsfield !! and McFarquhar (1996) \cite heymsfield_and_mcfarquhar_1996. do k = 1, NLAY @@ -3562,7 +3577,7 @@ subroutine progclduni & endif !> - Call subroutine get_alpha_exp to define alpha parameter for EXP and ER cloud overlap options - if ( iovr == 4 .or. iovr == 5 ) then + if ( iovr == 4 .or. iovr == 5 ) then call get_alpha_exp & ! --- inputs: & (ix, nlay, dzlay, iovr, latdeg, julian, yearlen, cldtot, & @@ -4034,18 +4049,18 @@ end subroutine gethml ! ######################################################################################### subroutine get_alpha_dcorr(nCol, nLev, lat, con_pi, deltaZ, & & de_lgth, cloud_overlap_param) - + integer, intent(in) :: nCol, nLev real(kind_phys), intent(in) :: con_pi real(kind_phys), dimension(nCol), intent(in) :: lat real(kind_phys), dimension(nCol,nLev),intent(in) :: deltaZ - real(kind_phys), dimension(nCol),intent(out) :: de_lgth + real(kind_phys), dimension(nCol),intent(out) :: de_lgth real(kind_phys), dimension(nCol,nLev),intent(out) :: & & cloud_overlap_param - + ! Local - integer :: iCol, iLay - + integer :: iCol, iLay + do iCol =1,nCol de_lgth(iCol) = max( 0.6, 2.78-4.6*abs(lat(iCol)/con_pi) ) do iLay=nLev,2,-1 @@ -4057,7 +4072,7 @@ subroutine get_alpha_dcorr(nCol, nLev, lat, con_pi, deltaZ, & enddo enddo end subroutine get_alpha_dcorr - + ! ######################################################################################### !> \ingroup module_radiation_clouds !! This program derives the exponential transition, alpha, from maximum to @@ -4065,10 +4080,10 @@ end subroutine get_alpha_dcorr !! for the exponential (EXP, iovrlp=4) or the exponential-random (ER, iovrlp=5) !! cloud overlap options for RRTMG/RRTMGP. For exponential, the transition from !! maximum to random with distance through model layers occurs without regard -!! to the configuration of clear and cloudy layers. For the ER method, each +!! to the configuration of clear and cloudy layers. For the ER method, each !! block of adjacent cloudy layers is treated with a separate transition from !! maximum to random, and blocks of cloudy layers separated by one or more -!! clear layers are correlated randomly. +!! clear layers are correlated randomly. !> /param nlon : number of model longitude points !> /param nlay : vertical layer dimension !> /param dzlay(nlon,nlay) : distance between the center of model layers @@ -4188,21 +4203,21 @@ subroutine get_alpha_exp & ! !===> ... begin here ! -! If exponential or exponential-random cloud overlap is used: +! If exponential or exponential-random cloud overlap is used: ! derive day-of-year and latitude-varying decorrelation lendth if requested; ! otherwise use the constant decorrelation length, decorr_con, specified in physcons.F90 do i = 1, nlon if (iovrlp == 4 .or. iovrlp == 5) then - if (idcor .eq. 1) then + if (idcor .eq. 1) then if (juldat .gt. 181._kind_phys) then am3 = -4._kind_phys * amr * (juldat - 272._kind_phys) & / yearlen else - am3 = 4._kind_phys * amr * (juldat - 91._kind_phys) + am3 = 4._kind_phys * amr * (juldat - 91._kind_phys) & / yearlen endif ! For latitude in degrees, decorr_len in km - decorr_len(i) = am1 + am2 * exp( -(latdeg(i) - am3)**2 + decorr_len(i) = am1 + am2 * exp( -(latdeg(i) - am3)**2 & / am4**2) else decorr_len(i) = decorr_con @@ -4294,17 +4309,17 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, & !+---+ !..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)) +!.. 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 + DO i = its,ite RHI_max = 0.0 CLDFRA(I,K,J) = 0.0 @@ -4377,11 +4392,11 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, & ENDDO ! if (debug_flag) then -! WRITE (dbg_msg,*) 'DEBUG-GT: finding cloud layers at point (', i, ', ', j, ')' +! WRITE (dbg_msg,*) 'DEBUG-GT: finding cloud layers at point (', i, ', ', j, ')' ! CALL wrf_debug (150, dbg_msg) -! endif +! endif call find_cloudLayers(qvs1d, cfr1d, T1d, P1d, R1d, entrmnt, & - & debug_flag, qc1d, qi1d, qs1d, kts,kte) + & debug_flag, qc1d, qi1d, qs1d, kts,kte) DO k = kts,kte cldfra(i,k,j) = cfr1d(k) @@ -4399,7 +4414,7 @@ END SUBROUTINE cal_cldfra3 !.. unless existing LWC/IWC is already there. SUBROUTINE find_cloudLayers(qvs1d, cfr1d, T1d, P1d, R1d, entrmnt, & - & debugfl, qc1d, qi1d, qs1d, kts,kte) + & debugfl, qc1d, qi1d, qs1d, kts,kte) ! IMPLICIT NONE @@ -4439,8 +4454,8 @@ SUBROUTINE find_cloudLayers(qvs1d, cfr1d, T1d, P1d, R1d, entrmnt, & 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 +!.. 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 @@ -4504,103 +4519,103 @@ SUBROUTINE find_cloudLayers(qvs1d, cfr1d, T1d, P1d, R1d, entrmnt, & 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 + 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 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 + & 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 + & 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 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 + & 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 - + & 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 +!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)') & +! 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 +! 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)') & +! 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 - +! 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, & diff --git a/physics/radlw_main.F90 b/physics/radlw_main.F90 index 0bfc332ab..daa20e45d 100644 --- a/physics/radlw_main.F90 +++ b/physics/radlw_main.F90 @@ -1713,7 +1713,7 @@ end subroutine rlwinit !> @{ subroutine cldprop & & ( cfrac,cliqp,reliq,cicep,reice,cdat1,cdat2,cdat3,cdat4, & ! --- inputs - & nlay, nlp1, ipseed, dz, de_lgth, iovrlw, alpha & + & nlay, nlp1, ipseed, dz, de_lgth, iovrlw, alpha, & & cldfmc, taucld & ! --- outputs & ) From b580c58233620793d530e419d17604b592a9eb7f Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Fri, 16 Oct 2020 09:14:10 -0600 Subject: [PATCH 37/42] Always calculate Julian day, since it is getting used by more and more parameterizations --- physics/GFS_time_vary_pre.fv3.F90 | 67 +++++++++++++++--------------- physics/GFS_time_vary_pre.scm.F90 | 68 +++++++++++++++---------------- 2 files changed, 65 insertions(+), 70 deletions(-) diff --git a/physics/GFS_time_vary_pre.fv3.F90 b/physics/GFS_time_vary_pre.fv3.F90 index dc9332bb9..27e36b649 100644 --- a/physics/GFS_time_vary_pre.fv3.F90 +++ b/physics/GFS_time_vary_pre.fv3.F90 @@ -121,41 +121,38 @@ subroutine GFS_time_vary_pre_run (jdat, idat, dtp, lkm, lsm, lsm_noahmp, nsswr, fhour = (sec + dtp)/con_hr kdt = nint((sec + dtp)/dtp) - if(lsm == lsm_noahmp .or. lkm == 1) then -! flake need this too - !GJF* These calculations were originally in GFS_physics_driver.F90 for - ! NoahMP. They were moved to this routine since they only depend - ! on time (not space). Note that this code is included as-is from - ! GFS_physics_driver.F90, but it may be simplified by using more - ! NCEP W3 library calls (e.g., see W3DOXDAT, W3FS13 for Julian day - ! of year and W3DIFDAT to determine the integer number of days in - ! a given year). *GJF - ! Julian day calculation (fcst day of the year) - ! we need yearln and julian to - ! pass to noah mp sflx, idate is init, jdat is fcst;idate = jdat when kdt=1 - ! jdat is changing - ! - - jd1 = iw3jdn(jdat(1),jdat(2),jdat(3)) - jd0 = iw3jdn(jdat(1),1,1) - fjd = float(jdat(5))/24.0 + float(jdat(6))/1440.0 - - julian = float(jd1-jd0) + fjd - - ! - ! Year length - ! - ! what if the integration goes from one year to another? - ! iyr or jyr ? from 365 to 366 or from 366 to 365 - ! - ! is this against model's noleap yr assumption? - if (mod(jdat(1),4) == 0) then - yearlen = 366 - if (mod(jdat(1),100) == 0) then - yearlen = 365 - if (mod(jdat(1),400) == 0) then - yearlen = 366 - endif + !GJF* These calculations were originally in GFS_physics_driver.F90 for + ! NoahMP. They were moved to this routine since they only depend + ! on time (not space). Note that this code is included as-is from + ! GFS_physics_driver.F90, but it may be simplified by using more + ! NCEP W3 library calls (e.g., see W3DOXDAT, W3FS13 for Julian day + ! of year and W3DIFDAT to determine the integer number of days in + ! a given year). *GJF + ! Julian day calculation (fcst day of the year) + ! we need yearln and julian to + ! pass to noah mp sflx, idate is init, jdat is fcst;idate = jdat when kdt=1 + ! jdat is changing + ! + + jd1 = iw3jdn(jdat(1),jdat(2),jdat(3)) + jd0 = iw3jdn(jdat(1),1,1) + fjd = float(jdat(5))/24.0 + float(jdat(6))/1440.0 + + julian = float(jd1-jd0) + fjd + + ! + ! Year length + ! + ! what if the integration goes from one year to another? + ! iyr or jyr ? from 365 to 366 or from 366 to 365 + ! + ! is this against model's noleap yr assumption? + if (mod(jdat(1),4) == 0) then + yearlen = 366 + if (mod(jdat(1),100) == 0) then + yearlen = 365 + if (mod(jdat(1),400) == 0) then + yearlen = 366 endif endif endif diff --git a/physics/GFS_time_vary_pre.scm.F90 b/physics/GFS_time_vary_pre.scm.F90 index 2fa352710..ad98b14e3 100644 --- a/physics/GFS_time_vary_pre.scm.F90 +++ b/physics/GFS_time_vary_pre.scm.F90 @@ -122,44 +122,42 @@ subroutine GFS_time_vary_pre_run (jdat, idat, dtp, lsm, lsm_noahmp, nsswr, & fhour = (sec + dtp)/con_hr kdt = nint((sec + dtp)/dtp) - if(lsm == lsm_noahmp) then - !GJF* These calculations were originally in GFS_physics_driver.F90 for - ! NoahMP. They were moved to this routine since they only depends - ! on time (not space). Note that this code is included as-is from - ! GFS_physics_driver.F90, but it may be simplified by using more - ! NCEP W3 library calls (e.g., see W3DOXDAT, W3FS13 for Julian day - ! of year and W3DIFDAT to determine the integer number of days in - ! a given year). *GJF - ! Julian day calculation (fcst day of the year) - ! we need yearln and julian to - ! pass to noah mp sflx, idate is init, jdat is fcst;idate = jdat when kdt=1 - ! jdat is changing - ! - - jd1 = iw3jdn(jdat(1),jdat(2),jdat(3)) - jd0 = iw3jdn(jdat(1),1,1) - fjd = float(jdat(5))/24.0 + float(jdat(6))/1440.0 - - julian = float(jd1-jd0) + fjd - - ! - ! Year length - ! - ! what if the integration goes from one year to another? - ! iyr or jyr ? from 365 to 366 or from 366 to 365 - ! - ! is this against model's noleap yr assumption? - if (mod(jdat(1),4) == 0) then - yearlen = 366 - if (mod(jdat(1),100) == 0) then - yearlen = 365 - if (mod(jdat(1),400) == 0) then - yearlen = 366 - endif + !GJF* These calculations were originally in GFS_physics_driver.F90 for + ! NoahMP. They were moved to this routine since they only depends + ! on time (not space). Note that this code is included as-is from + ! GFS_physics_driver.F90, but it may be simplified by using more + ! NCEP W3 library calls (e.g., see W3DOXDAT, W3FS13 for Julian day + ! of year and W3DIFDAT to determine the integer number of days in + ! a given year). *GJF + ! Julian day calculation (fcst day of the year) + ! we need yearln and julian to + ! pass to noah mp sflx, idate is init, jdat is fcst;idate = jdat when kdt=1 + ! jdat is changing + ! + + jd1 = iw3jdn(jdat(1),jdat(2),jdat(3)) + jd0 = iw3jdn(jdat(1),1,1) + fjd = float(jdat(5))/24.0 + float(jdat(6))/1440.0 + + julian = float(jd1-jd0) + fjd + + ! + ! Year length + ! + ! what if the integration goes from one year to another? + ! iyr or jyr ? from 365 to 366 or from 366 to 365 + ! + ! is this against model's noleap yr assumption? + if (mod(jdat(1),4) == 0) then + yearlen = 366 + if (mod(jdat(1),100) == 0) then + yearlen = 365 + if (mod(jdat(1),400) == 0) then + yearlen = 366 endif endif endif - + ipt = 1 lprnt = .false. lssav = .true. From 9b6366826c22ea81a1ca1966db99a874d674cbfd Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Fri, 16 Oct 2020 20:39:44 -0600 Subject: [PATCH 38/42] Fix metadata, remove moninedmf_hafs, remove dkudiagnostic from satmedmfvdifq --- physics/moninedmf.meta | 2 +- physics/moninedmf_hafs.f | 1560 ----------------------------------- physics/moninedmf_hafs.meta | 533 ------------ physics/satmedmfvdifq.F | 11 +- 4 files changed, 3 insertions(+), 2103 deletions(-) delete mode 100644 physics/moninedmf_hafs.f delete mode 100644 physics/moninedmf_hafs.meta diff --git a/physics/moninedmf.meta b/physics/moninedmf.meta index d518ed21e..b14dbd2fc 100644 --- a/physics/moninedmf.meta +++ b/physics/moninedmf.meta @@ -509,7 +509,7 @@ standard_name = sea_land_ice_mask long_name = sea/land/ice mask (=0/1/2) units = flag - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = integer intent = in optional = F diff --git a/physics/moninedmf_hafs.f b/physics/moninedmf_hafs.f deleted file mode 100644 index 25ad5ca02..000000000 --- a/physics/moninedmf_hafs.f +++ /dev/null @@ -1,1560 +0,0 @@ -!> \file moninedmf_hafs.f -!! Contains most of the hybrid eddy-diffusivity mass-flux scheme except for the -!! subroutine that calculates the mass flux and updraft properties. - -!> This module contains the CCPP-compliant hybrid eddy-diffusivity mass-flux -!! scheme. - module hedmf_hafs - - contains - -!> \section arg_table_hedmf_hafs_init Argument Table -!! \htmlinclude hedmf_hafs_init.html -!! - subroutine hedmf_hafs_init (moninq_fac,errmsg,errflg) - use machine, only : kind_phys - implicit none - real(kind=kind_phys), intent(in ) :: moninq_fac - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (moninq_fac == 0) then - errflg = 1 - write(errmsg,'(*(a))') 'Logic error: moninq_fac == 0', & - & ' is incompatible with moninedmf_hafs' - end if - end subroutine hedmf_hafs_init - - subroutine hedmf_hafs_finalize () - end subroutine hedmf_hafs_finalize - - -!> \defgroup HEDMF GFS Hybrid Eddy-Diffusivity Mass-Flux (HEDMF) Scheme Module -!! @{ -!! \brief This subroutine contains all of logic for the -!! Hybrid EDMF PBL scheme except for the calculation of -!! the updraft properties and mass flux. -!! -!> \section arg_table_hedmf_hafs_run Argument Table -!! \htmlinclude hedmf_hafs_run.html -!! -!! \section general_edmf GFS Hybrid EDMF General Algorithm -!! -# Compute preliminary variables from input arguments. -!! -# Calculate the first estimate of the PBL height ("Predictor step"). -!! -# Calculate Monin-Obukhov similarity parameters. -!! -# Update thermal properties of surface parcel and recompute PBL height ("Corrector step"). -!! -# Determine whether stratocumulus layers exist and compute quantities needed for enhanced diffusion. -!! -# Calculate the inverse Prandtl number. -!! -# Compute diffusion coefficients below the PBL top. -!! -# Compute diffusion coefficients above the PBL top. -!! -# If the PBL is convective, call the mass flux scheme to replace the countergradient terms. -!! -# Compute enhanced diffusion coefficients related to stratocumulus-topped PBLs. -!! -# Solve for the temperature and moisture tendencies due to vertical mixing. -!! -# Calculate heating due to TKE dissipation and add to the tendency for temperature. -!! -# Solve for the horizontal momentum tendencies and add them to output tendency terms. -!! \section detailed_hedmf GFS Hybrid HEDMF Detailed Algorithm -!! @{ - subroutine hedmf_hafs_run(im,km,ntrac,ntcw,dv,du,tau,rtg, & - & u1,v1,t1,q1,swh,hlw,xmu, & - & psk,rbsoil,zorl,u10m,v10m,fm,fh, & - & tsea,heat,evap,stress,spd1,kpbl, & - & prsi,del,prsl,prslk,phii,phil,delt,dspheat, & - & dusfc,dvsfc,dtsfc,dqsfc,hpbl,hgamt,hgamq,dkt, & - & kinver,xkzm_m,xkzm_h,xkzm_s,lprnt,ipr, & - & xkzminv,moninq_fac,islimsk,dkudiagnostic,errmsg,errflg) -! - use machine , only : kind_phys - use funcphys , only : fpvs - use physcons, grav => con_g, rd => con_rd, cp => con_cp & - &, hvap => con_hvap, fv => con_fvirt - implicit none -! -! arguments -! - logical, intent(in) :: lprnt - integer, intent(in) :: ipr - integer, intent(in) :: im, km, ntrac, ntcw, kinver(im) - integer, intent(in) :: islimsk(1:im) - integer, intent(out) :: kpbl(im) - -! - real(kind=kind_phys), intent(in) :: delt, xkzm_m, xkzm_h, xkzm_s - real(kind=kind_phys), intent(in) :: xkzminv, moninq_fac - real(kind=kind_phys), intent(inout) :: dv(im,km), du(im,km), & - & tau(im,km), rtg(im,km,ntrac) - real(kind=kind_phys), intent(in) :: & - & u1(im,km), v1(im,km), & - & t1(im,km), q1(im,km,ntrac), & - & swh(im,km), hlw(im,km), & - & xmu(im), psk(im), & - & rbsoil(im), zorl(im), & - & u10m(im), v10m(im), & - & fm(im), fh(im), & - & tsea(im), & - & heat(im), evap(im), & - & stress(im), spd1(im) - real(kind=kind_phys), intent(in) :: & - & prsi(im,km+1), del(im,km), & - & prsl(im,km), prslk(im,km), & - & phii(im,km+1), phil(im,km) - real(kind=kind_phys), intent(out) :: & - & dusfc(im), dvsfc(im), & - & dtsfc(im), dqsfc(im), & - & hpbl(im), dkt(im,km-1) - - real(kind=kind_phys), intent(inout) :: & - & hgamt(im), hgamq(im) -! - logical, intent(in) :: dspheat -! flag for tke dissipative heating - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - -! -! locals -! - integer i,iprt,is,iun,k,kk,km1,kmpbl,latd,lond - integer lcld(im),icld(im),kcld(im),krad(im) - integer kx1(im), kpblx(im) -! -! real(kind=kind_phys) betaq(im), betat(im), betaw(im), - real(kind=kind_phys) phih(im), phim(im), hpblx(im), & - & rbdn(im), rbup(im), & - & beta(im), sflux(im), & - & z0(im), crb(im), wstar(im), & - & zol(im), ustmin(im), ustar(im), & - & thermal(im),wscale(im), wscaleu(im) -! - real(kind=kind_phys) theta(im,km),thvx(im,km), thlvx(im,km), & - & qlx(im,km), thetae(im,km), & - & qtx(im,km), bf(im,km-1), diss(im,km), & - & radx(im,km-1), & - & govrth(im), hrad(im), & -! & hradm(im), radmin(im), vrad(im), & - & radmin(im), vrad(im), & - & zd(im), zdd(im), thlvx1(im) -! - real(kind=kind_phys) rdzt(im,km-1),dktx(im,km-1), & - & zi(im,km+1), zl(im,km), xkzo(im,km-1), & - & dku(im,km-1), xkzmo(im,km-1), & - & cku(im,km-1), ckt(im,km-1), & - & ti(im,km-1), shr2(im,km-1), & - & al(im,km-1), ad(im,km), & - & au(im,km-1), a1(im,km), & - & a2(im,km*ntrac), dkudiagnostic(im,km-1) -! - real(kind=kind_phys) tcko(im,km), qcko(im,km,ntrac), & - & ucko(im,km), vcko(im,km), xmf(im,km) -! - real(kind=kind_phys) prinv(im), rent(im) -! - logical pblflg(im), sfcflg(im), scuflg(im), flg(im) - logical ublflg(im), pcnvflg(im) -! -! pcnvflg: true for convective(strongly unstable) pbl -! ublflg: true for unstable but not convective(strongly unstable) pbl -! - real(kind=kind_phys) aphi16, aphi5, bvf2, wfac, - & cfac, conq, cont, conw, - & dk, dkmax, dkmin, - & dq1, dsdz2, dsdzq, dsdzt, - & dsdzu, dsdzv, - & dsig, dt2, dthe1, dtodsd, - & dtodsu, dw2, dw2min, g, - & gamcrq, gamcrt, gocp, - & gravi, f0, - & prnum, prmax, prmin, pfac, crbcon, - & qmin, tdzmin, qtend, crbmin,crbmax, - & rbint, rdt, rdz, qlmin, - & ri, rimin, rl2, rlam, rlamun, - & rone, rzero, sfcfrac, - & spdk2, sri, zol1, zolcr, zolcru, - & robn, ttend, - & utend, vk, vk2, - & ust3, wst3, - & vtend, zfac, vpert, cteit, - & rentf1, rentf2, radfac, - & zfmin, zk, tem, tem1, tem2, - & xkzm, xkzmu, - & ptem, ptem1, ptem2, tx1(im), tx2(im) -! - real(kind=kind_phys) zstblmax,h1, h2, qlcr, actei, - & cldtime - -!! for aplha - real(kind=kind_phys) WSPM(IM,KM-1) - integer kLOC ! RGF - real :: xDKU, ALPHA ! RGF - - integer :: useshape - real :: smax,ashape,sz2h, sksfc,skmax,ashape1,skminusk0, hmax - - -!cc - parameter(gravi=1.0/grav) - parameter(g=grav) - parameter(gocp=g/cp) - parameter(cont=cp/g,conq=hvap/g,conw=1.0/g) ! for del in pa -! parameter(cont=1000.*cp/g,conq=1000.*hvap/g,conw=1000./g) ! for del in kpa - parameter(rlam=30.0,vk=0.4,vk2=vk*vk) - parameter(prmin=0.25,prmax=4.,zolcr=0.2,zolcru=-0.5) - parameter(dw2min=0.0001,dkmin=0.0,dkmax=1000.,rimin=-100.) - parameter(crbcon=0.25,crbmin=0.15,crbmax=0.35) - parameter(wfac=7.0,cfac=6.5,pfac=2.0,sfcfrac=0.1) -! parameter(qmin=1.e-8,xkzm=1.0,zfmin=1.e-8,aphi5=5.,aphi16=16.) - parameter(qmin=1.e-8, zfmin=1.e-8,aphi5=5.,aphi16=16.) - parameter(tdzmin=1.e-3,qlmin=1.e-12,f0=1.e-4) - parameter(h1=0.33333333,h2=0.66666667) -! parameter(cldtime=500.,xkzminv=0.3) - parameter(cldtime=500.) -! parameter(cldtime=500.,xkzmu=3.0,xkzminv=0.3) -! parameter(gamcrt=3.,gamcrq=2.e-3,rlamun=150.0) - parameter(gamcrt=3.,gamcrq=0.,rlamun=150.0) - parameter(rentf1=0.2,rentf2=1.0,radfac=0.85) - parameter(iun=84) -! -! parameter (zstblmax = 2500., qlcr=1.0e-5) -! parameter (zstblmax = 2500., qlcr=3.0e-5) -! parameter (zstblmax = 2500., qlcr=3.5e-5) -! parameter (zstblmax = 2500., qlcr=1.0e-4) - parameter (zstblmax = 2500., qlcr=3.5e-5) -! parameter (actei = 0.23) - parameter (actei = 0.7) - -! HAFS PBL: height-dependent ALPHA - useshape=2 !0-- no change, origincal ALPHA adjustment,1-- shape1, 2-- shape2(adjust above sfc) - alpha=moninq_fac - - ! write(0,*)'in PBL,alpha=',alpha - - ! write(0,*)'islimsk=',(islimsk(i),i=1,im) - -c -c----------------------------------------------------------------------- -c - 601 format(1x,' moninp lat lon step hour ',3i6,f6.1) - 602 format(1x,' k',' z',' t',' th', - 1 ' tvh',' q',' u',' v', - 2 ' sp') - 603 format(1x,i5,8f9.1) - 604 format(1x,' sfc',9x,f9.1,18x,f9.1) - 605 format(1x,' k zl spd2 thekv the1v' - 1 ,' thermal rbup') - 606 format(1x,i5,6f8.2) - 607 format(1x,' kpbl hpbl fm fh hgamt', - 1 ' hgamq ws ustar cd ch') - 608 format(1x,i5,9f8.2) - 609 format(1x,' k pr dkt dku ',i5,3f8.2) - 610 format(1x,' k pr dkt dku ',i5,3f8.2,' l2 ri t2', - 1 ' sr2 ',2f8.2,2e10.2) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 -!> ## Compute preliminary variables from input arguments - -! compute preliminary variables -! -! iprt = 0 -! if(iprt.eq.1) then -!cc latd = 0 -! lond = 0 -! else -!cc latd = 0 -! lond = 0 -! endif -! - dt2 = delt - rdt = 1. / dt2 - km1 = km - 1 - kmpbl = km / 2 -!> - Compute physical height of the layer centers and interfaces from the geopotential height (zi and zl) - do k=1,km - do i=1,im - zi(i,k) = phii(i,k) * gravi - zl(i,k) = phil(i,k) * gravi - enddo - enddo - do i=1,im - zi(i,km+1) = phii(i,km+1) * gravi - enddo -!> - Compute reciprocal of \f$ \Delta z \f$ (rdzt) - do k = 1,km1 - do i=1,im - rdzt(i,k) = 1.0 / (zl(i,k+1) - zl(i,k)) - enddo - enddo -!> - Compute reciprocal of pressure (tx1, tx2) - do i=1,im - kx1(i) = 1 - tx1(i) = 1.0 / prsi(i,1) - tx2(i) = tx1(i) - enddo -!> - Compute background vertical diffusivities for scalars and momentum (xkzo and xkzmo) - do k = 1,km1 - do i=1,im - xkzo(i,k) = 0.0 - xkzmo(i,k) = 0.0 - if (k < kinver(i)) then -! vertical background diffusivity - ptem = prsi(i,k+1) * tx1(i) - tem1 = 1.0 - ptem - tem1 = tem1 * tem1 * 10.0 - xkzo(i,k) = xkzm_h * min(1.0, exp(-tem1)) - -! vertical background diffusivity for momentum - if (ptem >= xkzm_s) then - xkzmo(i,k) = xkzm_m - kx1(i) = k + 1 - else - if (k == kx1(i) .and. k > 1) tx2(i) = 1.0 / prsi(i,k) - tem1 = 1.0 - prsi(i,k+1) * tx2(i) - tem1 = tem1 * tem1 * 5.0 - xkzmo(i,k) = xkzm_m * min(1.0, exp(-tem1)) - endif - endif - enddo - enddo - -! if (lprnt) then -! print *,' xkzo=',(xkzo(ipr,k),k=1,km1) -! print *,' xkzmo=',(xkzmo(ipr,k),k=1,km1) -! endif -! -! diffusivity in the inversion layer is set to be xkzminv (m^2/s) -!> - The background scalar vertical diffusivity is limited to be less than or equal to xkzminv - do k = 1,kmpbl - do i=1,im -! if(zi(i,k+1) > 200..and.zi(i,k+1) < zstblmax) then - if(zi(i,k+1) > 250.) then - tem1 = (t1(i,k+1)-t1(i,k)) * rdzt(i,k) - if(tem1 > 1.e-5) then - xkzo(i,k) = min(xkzo(i,k),xkzminv) - endif - endif - enddo - enddo -!> - Some output variables and logical flags are initialized - do i = 1,im - z0(i) = 0.01 * zorl(i) - dusfc(i) = 0. - dvsfc(i) = 0. - dtsfc(i) = 0. - dqsfc(i) = 0. - wscale(i)= 0. - wscaleu(i)= 0. - kpbl(i) = 1 - hpbl(i) = zi(i,1) - hpblx(i) = zi(i,1) - pblflg(i)= .true. - sfcflg(i)= .true. - if(rbsoil(i) > 0.) sfcflg(i) = .false. - ublflg(i)= .false. - pcnvflg(i)= .false. - scuflg(i)= .true. - if(scuflg(i)) then - radmin(i)= 0. - rent(i) = rentf1 - hrad(i) = zi(i,1) -! hradm(i) = zi(i,1) - krad(i) = 1 - icld(i) = 0 - lcld(i) = km1 - kcld(i) = km1 - zd(i) = 0. - endif - enddo -!> - Compute \f$\theta\f$ (theta), \f$q_l\f$ (qlx), \f$q_t\f$ (qtx), \f$\theta_e\f$ (thetae), \f$\theta_v\f$ (thvx), \f$\theta_{l,v}\f$ (thlvx) - do k = 1,km - do i = 1,im - theta(i,k) = t1(i,k) * psk(i) / prslk(i,k) - qlx(i,k) = max(q1(i,k,ntcw),qlmin) - qtx(i,k) = max(q1(i,k,1),qmin)+qlx(i,k) - ptem = qlx(i,k) - ptem1 = hvap*max(q1(i,k,1),qmin)/(cp*t1(i,k)) - thetae(i,k)= theta(i,k)*(1.+ptem1) - thvx(i,k) = theta(i,k)*(1.+fv*max(q1(i,k,1),qmin)-ptem) - ptem2 = theta(i,k)-(hvap/cp)*ptem - thlvx(i,k) = ptem2*(1.+fv*qtx(i,k)) - enddo - enddo -!> - Initialize diffusion coefficients to 0 and calculate the total radiative heating rate (dku, dkt, radx) - do k = 1,km1 - do i = 1,im - dku(i,k) = 0. - dkt(i,k) = 0. - dktx(i,k) = 0. - cku(i,k) = 0. - ckt(i,k) = 0. - tem = zi(i,k+1)-zi(i,k) - radx(i,k) = tem*(swh(i,k)*xmu(i)+hlw(i,k)) - enddo - enddo -!> - Set lcld to first index above 2.5km - do i=1,im - flg(i) = scuflg(i) - enddo - do k = 1, km1 - do i=1,im - if(flg(i).and.zl(i,k) >= zstblmax) then - lcld(i)=k - flg(i)=.false. - endif - enddo - enddo -! -! compute virtual potential temp gradient (bf) and winshear square -!> - Compute \f$\frac{\partial \theta_v}{\partial z}\f$ (bf) and the wind shear squared (shr2) - do k = 1, km1 - do i = 1, im - rdz = rdzt(i,k) - bf(i,k) = (thvx(i,k+1)-thvx(i,k))*rdz - ti(i,k) = 2./(t1(i,k)+t1(i,k+1)) - dw2 = (u1(i,k)-u1(i,k+1))**2 - & + (v1(i,k)-v1(i,k+1))**2 - shr2(i,k) = max(dw2,dw2min)*rdz*rdz - enddo - enddo -!> - Calculate \f$\frac{g}{\theta}\f$ (govrth), \f$\beta = \frac{\Delta t}{\Delta z}\f$ (beta), \f$u_*\f$ (ustar), total surface flux (sflux), and set pblflag to false if the total surface energy flux is into the surface - do i = 1,im - govrth(i) = g/theta(i,1) - enddo -! - do i=1,im - beta(i) = dt2 / (zi(i,2)-zi(i,1)) - enddo -! - do i=1,im - ustar(i) = sqrt(stress(i)) - enddo -! - do i = 1,im - sflux(i) = heat(i) + evap(i)*fv*theta(i,1) - if(.not.sfcflg(i) .or. sflux(i) <= 0.) pblflg(i)=.false. - enddo -!> ## Calculate the first estimate of the PBL height (``Predictor step") -!! The calculation of the boundary layer height follows Troen and Mahrt (1986) \cite troen_and_mahrt_1986 section 3. The approach is to find the level in the column where a modified bulk Richardson number exceeds a critical value. -!! -!! The temperature of the thermal is of primary importance. For the initial estimate of the PBL height, the thermal is assumed to have one of two temperatures. If the boundary layer is stable, the thermal is assumed to have a temperature equal to the surface virtual temperature. Otherwise, the thermal is assumed to have the same virtual potential temperature as the lowest model level. For the stable case, the critical bulk Richardson number becomes a function of the wind speed and roughness length, otherwise it is set to a tunable constant. -! compute the pbl height -! - do i=1,im - flg(i) = .false. - rbup(i) = rbsoil(i) - - IF ( ALPHA .GT. 0.0) THEN ! ALPHA - - if(pblflg(i)) then - thermal(i) = thvx(i,1) - crb(i) = crbcon - else - thermal(i) = tsea(i)*(1.+fv*max(q1(i,1,1),qmin)) - tem = sqrt(u10m(i)**2+v10m(i)**2) - tem = max(tem, 1.) - robn = tem / (f0 * z0(i)) - tem1 = 1.e-7 * robn - crb(i) = 0.16 * (tem1 ** (-0.18)) - crb(i) = max(min(crb(i), crbmax), crbmin) - endif - - ELSE -! use variable Ri for all conditions - if(pblflg(i)) then - thermal(i) = thvx(i,1) - else - thermal(i) = tsea(i)*(1.+fv*max(q1(i,1,1),qmin)) - endif - tem = sqrt(u10m(i)**2+v10m(i)**2) - tem = max(tem, 1.) - robn = tem / (f0 * z0(i)) - tem1 = 1.e-7 * robn -! crb(i) = 0.16 * (tem1 ** (-0.18)) - crb(i) = crbcon - IF(islimsk(i).ne.0) crb(I) = 0.16*(tem1)**(-0.18) - IF(islimsk(i).eq.0) crb(I) = 0.25*(tem1)**(-0.18) - crb(i) = max(min(crb(i), crbmax), crbmin) - ENDIF ! ALPHA - - enddo - -!> Given the thermal's properties and the critical Richardson number, a loop is executed to find the first level above the surface where the modified Richardson number is greater than the critical Richardson number, using equation 10a from Troen and Mahrt (1986) \cite troen_and_mahrt_1986 (also equation 8 from Hong and Pan (1996) \cite hong_and_pan_1996): -!! \f[ -!! h = Ri\frac{T_0\left|\vec{v}(h)\right|^2}{g\left(\theta_v(h) - \theta_s\right)} -!! \f] -!! where \f$h\f$ is the PBL height, \f$Ri\f$ is the Richardson number, \f$T_0\f$ is the virtual potential temperature near the surface, \f$\left|\vec{v}\right|\f$ is the wind speed, and \f$\theta_s\f$ is for the thermal. Rearranging this equation to calculate the modified Richardson number at each level, k, for comparison with the critical value yields: -!! \f[ -!! Ri_k = gz(k)\frac{\left(\theta_v(k) - \theta_s\right)}{\theta_v(1)*\vec{v}(k)} -!! \f] - do k = 1, kmpbl - do i = 1, im - if(.not.flg(i)) then - rbdn(i) = rbup(i) - spdk2 = max((u1(i,k)**2+v1(i,k)**2),1.) - rbup(i) = (thvx(i,k)-thermal(i))* - & (g*zl(i,k)/thvx(i,1))/spdk2 - kpbl(i) = k - flg(i) = rbup(i) > crb(i) - endif - enddo - enddo - -!> Once the level is found, some linear interpolation is performed to find the exact height of the boundary layer top (where \f$Ri = Ri_{cr}\f$) and the PBL height and the PBL top index are saved (hpblx and kpblx, respectively) - do i = 1,im - if(kpbl(i) > 1) then - k = kpbl(i) - if(rbdn(i) >= crb(i)) then - rbint = 0. - elseif(rbup(i) <= crb(i)) then - rbint = 1. - else - rbint = (crb(i)-rbdn(i))/(rbup(i)-rbdn(i)) - endif - hpbl(i) = zl(i,k-1) + rbint*(zl(i,k)-zl(i,k-1)) - if(hpbl(i) < zi(i,kpbl(i))) kpbl(i) = kpbl(i) - 1 - else - hpbl(i) = zl(i,1) - kpbl(i) = 1 - endif - kpblx(i) = kpbl(i) - hpblx(i) = hpbl(i) - enddo -! -! compute similarity parameters -!> ## Calculate Monin-Obukhov similarity parameters -!! Using the initial guess for the PBL height, Monin-Obukhov similarity parameters are calculated. They are needed to refine the PBL height calculation and for calculating diffusion coefficients. -!! -!! First, calculate the Monin-Obukhov nondimensional stability parameter, commonly referred to as \f$\zeta\f$ using the following equation from Businger et al. (1971) \cite businger_et_al_1971 (equation 28): -!! \f[ -!! \zeta = Ri_{sfc}\frac{F_m^2}{F_h} = \frac{z}{L} -!! \f] -!! where \f$F_m\f$ and \f$F_h\f$ are surface Monin-Obukhov stability functions calculated in sfc_diff.f and \f$L\f$ is the Obukhov length. Then, the nondimensional gradients of momentum and temperature (phim and phih) are calculated using equations 5 and 6 from Hong and Pan (1996) \cite hong_and_pan_1996 depending on the surface layer stability. Then, the velocity scale valid for the surface layer (\f$w_s\f$, wscale) is calculated using equation 3 from Hong and Pan (1996) \cite hong_and_pan_1996. For the neutral and unstable PBL above the surface layer, the convective velocity scale, \f$w_*\f$, is calculated according to: -!! \f[ -!! w_* = \left(\frac{g}{\theta_0}h\overline{w'\theta_0'}\right)^{1/3} -!! \f] -!! and the mixed layer velocity scale is then calculated with equation 6 from Troen and Mahrt (1986) \cite troen_and_mahrt_1986 -!! \f[ -!! w_s = (u_*^3 + 7\epsilon k w_*^3)^{1/3} -!! \f] - do i=1,im - zol(i) = max(rbsoil(i)*fm(i)*fm(i)/fh(i),rimin) - if(sfcflg(i)) then - zol(i) = min(zol(i),-zfmin) - else - zol(i) = max(zol(i),zfmin) - endif - zol1 = zol(i)*sfcfrac*hpbl(i)/zl(i,1) - if(sfcflg(i)) then -! phim(i) = (1.-aphi16*zol1)**(-1./4.) -! phih(i) = (1.-aphi16*zol1)**(-1./2.) - tem = 1.0 / (1. - aphi16*zol1) - phih(i) = sqrt(tem) - phim(i) = sqrt(phih(i)) - else - phim(i) = 1. + aphi5*zol1 - phih(i) = phim(i) - endif - wscale(i) = ustar(i)/phim(i) - ustmin(i) = ustar(i)/aphi5 - wscale(i) = max(wscale(i),ustmin(i)) - enddo - do i=1,im - if(pblflg(i)) then - if(zol(i) < zolcru .and. kpbl(i) > 1) then - pcnvflg(i) = .true. - else - ublflg(i) = .true. - endif - wst3 = govrth(i)*sflux(i)*hpbl(i) - wstar(i)= wst3**h1 - ust3 = ustar(i)**3. - wscaleu(i) = (ust3+wfac*vk*wst3*sfcfrac)**h1 - wscaleu(i) = max(wscaleu(i),ustmin(i)) - endif - enddo -! -! compute counter-gradient mixing term for heat and moisture -!> ## Update thermal properties of surface parcel and recompute PBL height ("Corrector step"). -!! Next, the counter-gradient terms for temperature and humidity are calculated using equation 4 of Hong and Pan (1996) \cite hong_and_pan_1996 and are used to calculate the "scaled virtual temperature excess near the surface" (equation 9 in Hong and Pan (1996) \cite hong_and_pan_1996) so that the properties of the thermal are updated to recalculate the PBL height. - do i = 1,im - if(ublflg(i)) then - hgamt(i) = min(cfac*heat(i)/wscaleu(i),gamcrt) - hgamq(i) = min(cfac*evap(i)/wscaleu(i),gamcrq) - vpert = hgamt(i) + hgamq(i)*fv*theta(i,1) - vpert = min(vpert,gamcrt) - thermal(i)= thermal(i)+max(vpert,0.) - hgamt(i) = max(hgamt(i),0.0) - hgamq(i) = max(hgamq(i),0.0) - endif - enddo -! -! enhance the pbl height by considering the thermal excess -!> The PBL height calculation follows the same procedure as the predictor step, except that it uses an updated virtual potential temperature for the thermal. - do i=1,im - flg(i) = .true. - if(ublflg(i)) then - flg(i) = .false. - rbup(i) = rbsoil(i) - endif - enddo - do k = 2, kmpbl - do i = 1, im - if(.not.flg(i)) then - rbdn(i) = rbup(i) - spdk2 = max((u1(i,k)**2+v1(i,k)**2),1.) - rbup(i) = (thvx(i,k)-thermal(i))* - & (g*zl(i,k)/thvx(i,1))/spdk2 - kpbl(i) = k - flg(i) = rbup(i) > crb(i) - endif - enddo - enddo - do i = 1,im - if(ublflg(i)) then - k = kpbl(i) - if(rbdn(i) >= crb(i)) then - rbint = 0. - elseif(rbup(i) <= crb(i)) then - rbint = 1. - else - rbint = (crb(i)-rbdn(i))/(rbup(i)-rbdn(i)) - endif - hpbl(i) = zl(i,k-1) + rbint*(zl(i,k)-zl(i,k-1)) - if(hpbl(i) < zi(i,kpbl(i))) kpbl(i) = kpbl(i) - 1 - if(kpbl(i) <= 1) then - ublflg(i) = .false. - pblflg(i) = .false. - endif - endif - enddo -! -! look for stratocumulus -!> ## Determine whether stratocumulus layers exist and compute quantities needed for enhanced diffusion -!! - Starting at the PBL top and going downward, if the level is less than 2.5 km and \f$q_l>q_{l,cr}\f$ then set kcld = k (find the cloud top index in the PBL). If no cloud water above the threshold is found, scuflg is set to F. - do i = 1, im - flg(i)=scuflg(i) - enddo - do k = kmpbl,1,-1 - do i = 1, im - if(flg(i) .and. k <= lcld(i)) then - if(qlx(i,k).ge.qlcr) then - kcld(i)=k - flg(i)=.false. - endif - endif - enddo - enddo - do i = 1, im - if(scuflg(i) .and. kcld(i)==km1) scuflg(i)=.false. - enddo -!> - Starting at the PBL top and going downward, if the level is less than the cloud top, find the level of the minimum radiative heating rate within the cloud. If the level of the minimum is the lowest model level or the minimum radiative heating rate is positive, then set scuflg to F. - do i = 1, im - flg(i)=scuflg(i) - enddo - do k = kmpbl,1,-1 - do i = 1, im - if(flg(i) .and. k <= kcld(i)) then - if(qlx(i,k) >= qlcr) then - if(radx(i,k) < radmin(i)) then - radmin(i)=radx(i,k) - krad(i)=k - endif - else - flg(i)=.false. - endif - endif - enddo - enddo - do i = 1, im - if(scuflg(i) .and. krad(i) <= 1) scuflg(i)=.false. - if(scuflg(i) .and. radmin(i)>=0.) scuflg(i)=.false. - enddo -!> - Starting at the PBL top and going downward, count the number of levels below the minimum radiative heating rate level that have cloud water above the threshold. If there are none, then set the scuflg to F. - do i = 1, im - flg(i)=scuflg(i) - enddo - do k = kmpbl,2,-1 - do i = 1, im - if(flg(i) .and. k <= krad(i)) then - if(qlx(i,k) >= qlcr) then - icld(i)=icld(i)+1 - else - flg(i)=.false. - endif - endif - enddo - enddo - do i = 1, im - if(scuflg(i) .and. icld(i) < 1) scuflg(i)=.false. - enddo -!> - Find the height of the interface where the minimum in radiative heating rate is located. If this height is less than the second model interface height, then set the scuflg to F. - do i = 1, im - if(scuflg(i)) then - hrad(i) = zi(i,krad(i)+1) -! hradm(i)= zl(i,krad(i)) - endif - enddo -! - do i = 1, im - if(scuflg(i) .and. hrad(i) - Calculate the hypothetical \f$\theta_v\f$ at the minimum radiative heating level that a parcel would reach due to radiative cooling after a typical cloud turnover time spent at that level. - do i = 1, im - if(scuflg(i)) then - k = krad(i) - tem = zi(i,k+1)-zi(i,k) - tem1 = cldtime*radmin(i)/tem - thlvx1(i) = thlvx(i,k)+tem1 -! if(thlvx1(i) > thlvx(i,k-1)) scuflg(i)=.false. - endif - enddo -!> - Determine the distance that a parcel would sink downwards starting from the level of minimum radiative heating rate by comparing the hypothetical minimum \f$\theta_v\f$ calculated above with the environmental \f$\theta_v\f$. - do i = 1, im - flg(i)=scuflg(i) - enddo - do k = kmpbl,1,-1 - do i = 1, im - if(flg(i) .and. k <= krad(i))then - if(thlvx1(i) <= thlvx(i,k))then - tem=zi(i,k+1)-zi(i,k) - zd(i)=zd(i)+tem - else - flg(i)=.false. - endif - endif - enddo - enddo -!> - Calculate the cloud thickness, where the cloud top is the in-cloud minimum radiative heating level and the bottom is determined previously. - do i = 1, im - if(scuflg(i))then - kk = max(1, krad(i)+1-icld(i)) - zdd(i) = hrad(i)-zi(i,kk) - endif - enddo -!> - Find the largest between the cloud thickness and the distance of a sinking parcel, then determine the smallest of that number and the height of the minimum in radiative heating rate. Set this number to \f$zd\f$. Using \f$zd\f$, calculate the characteristic velocity scale of cloud-top radiative cooling-driven turbulence. - do i = 1, im - if(scuflg(i))then - zd(i) = max(zd(i),zdd(i)) - zd(i) = min(zd(i),hrad(i)) - tem = govrth(i)*zd(i)*(-radmin(i)) - vrad(i)= tem**h1 - endif - enddo -! -! compute inverse prandtl number -!> ## Calculate the inverse Prandtl number -!! For an unstable PBL, the Prandtl number is calculated according to Hong and Pan (1996) \cite hong_and_pan_1996, equation 10, whereas for a stable boundary layer, the Prandtl number is simply \f$Pr = \frac{\phi_h}{\phi_m}\f$. - do i = 1, im - if(ublflg(i)) then - tem = phih(i)/phim(i)+cfac*vk*sfcfrac - else - tem = phih(i)/phim(i) - endif - prinv(i) = 1.0 / tem - prinv(i) = min(prinv(i),prmax) - prinv(i) = max(prinv(i),prmin) - enddo - do i = 1, im - if(zol(i) > zolcr) then - kpbl(i) = 1 - endif - enddo - -!!! HAFS PBL, Bgin adjustment -! RGF determine wspd at roughly 500 m above surface, or as close as possible, -! reuse SPDK2 -! zi(i,k) is AGL, right? May not matter if applied only to water grid points - if(moninq_fac.lt.0)then - - DO I=1,IM - SPDK2 = 0. - WSPM(i,1) = 0. - DO K = 1, KMPBL ! kmpbl is like a max possible pbl height - if(zi(i,k).le.500.and.zi(i,k+1).gt.500.)then ! find level bracketing 500 m - SPDK2 = SQRT(U1(i,k)*U1(i,k)+V1(i,k)*V1(i,k)) ! wspd near 500 m - WSPM(i,1) = SPDK2/0.6 ! now the Km limit for 500 m. just store in K=1 - WSPM(i,2) = float(k) ! height of level at gridpoint i. store in K=2 -! if(i.eq.25) print *,' IK ',i,k,' ZI ',zi(i,k), ' WSPM1 ',wspm(i,1),' -! KMPBL ',kmpbl,' KPBL ',kpbl(i) - endif - ENDDO - ENDDO ! i - - endif ! moninq_fac < 0 - - -! -! compute diffusion coefficients below pbl -!> ## Compute diffusion coefficients below the PBL top -!! Below the PBL top, the diffusion coefficients (\f$K_m\f$ and \f$K_h\f$) are calculated according to equation 2 in Hong and Pan (1996) \cite hong_and_pan_1996 where a different value for \f$w_s\f$ (PBL vertical velocity scale) is used depending on the PBL stability. \f$K_h\f$ is calculated from \f$K_m\f$ using the Prandtl number. The calculated diffusion coefficients are checked so that they are bounded by maximum values and the local background diffusion coefficients. - - IF (ALPHA > 0) THEN ! AAAAAAAAAAAAAAAAAAAAAAAAAAA - - do k = 1, kmpbl - do i=1,im - if(k < kpbl(i)) then -! zfac = max((1.-(zi(i,k+1)-zl(i,1))/ -! 1 (hpbl(i)-zl(i,1))), zfmin) - zfac = max((1.-zi(i,k+1)/hpbl(i)), zfmin) - tem = zi(i,k+1) * (zfac**pfac) * moninq_fac ! lmh suggested by kg - if(pblflg(i)) then - tem1 = vk * wscaleu(i) * tem -! dku(i,k) = xkzmo(i,k) + tem1 -! dkt(i,k) = xkzo(i,k) + tem1 * prinv(i) - dku(i,k) = tem1 - dkt(i,k) = tem1 * prinv(i) - else - tem1 = vk * wscale(i) * tem -! dku(i,k) = xkzmo(i,k) + tem1 -! dkt(i,k) = xkzo(i,k) + tem1 * prinv(i) - dku(i,k) = tem1 - dkt(i,k) = tem1 * prinv(i) - endif - dku(i,k) = min(dku(i,k),dkmax) - dku(i,k) = max(dku(i,k),xkzmo(i,k)) - dkt(i,k) = min(dkt(i,k),dkmax) - dkt(i,k) = max(dkt(i,k),xkzo(i,k)) - dktx(i,k)= dkt(i,k) - endif - enddo - enddo - - ELSE ! ALPHA <0 AAAAAAAAAAAAA - - do i=1,im - do k = 1, kmpbl - if(k < kpbl(i)) then -! zfac = max((1.-(zi(i,k+1)-zl(i,1))/ -! 1 (hpbl(i)-zl(i,1))), zfmin) - zfac = max((1.-zi(i,k+1)/hpbl(i)), zfmin) - ! tem = zi(i,k+1) * (zfac**pfac) * moninq_fac ! lmh suggested by kg - tem = zi(i,k+1) * (zfac**pfac) * abs( moninq_fac) - -!!!! CHANGES FOR HEIGHT-DEPENDENT K ADJUSTMENT, WANG W - if(useshape .ge. 1) then - sz2h=(ZI(I,K+1)-ZL(I,1))/(HPBL(I)-ZL(I,1)) - sz2h=max(sz2h,zfmin) - sz2h=min(sz2h,1.0) - zfac=(1.0-sz2h)**pfac -! smax=0.148 !! max value of this shape function - smax=0.148 !! max value of this shape function - hmax=0.333 !! roughly height if max K - skmax=hmax*(1.0-hmax)**pfac - sksfc=min(ZI(I,2)/HPBL(I),0.05) ! surface layer top, 0.05H or ZI(2) (Zi(1)=0) - sksfc=sksfc*(1-sksfc)**pfac - - zfac=max(zfac,zfmin) - ashape=max(ABS(moninq_fac),0.2) ! should not be smaller than 0.2, otherwise too much adjustment(?) - if(useshape ==1) then - ashape=( 1.0 - ((sz2h*zfac/smax)**0.25) - & *( 1.0 - ashape ) ) - tem = zi(i,k+1) * (zfac) * ashape - endif - - if (useshape == 2) then !only adjus K that is > K_surface_top - ashape1=1.0 - if (skmax > sksfc) ashape1=(skmax*ashape-sksfc)/ - & (skmax-sksfc) - skminusk0=ZI(I,K+1)*zfac - HPBL(i)*sksfc - tem = zi(i,k+1) * (zfac) ! no adjustment - if (skminusk0 > 0) then ! only adjust K which is > surface top K - tem = skminusk0*ashape1 + HPBL(i)*sksfc - endif - endif - endif ! endif useshape>1 -!!!! END OF CHAGES , WANG W - - - if(pblflg(i)) then - tem1 = vk * wscaleu(i) * tem -! dku(i,k) = xkzmo(i,k) + tem1 -! dkt(i,k) = xkzo(i,k) + tem1 * prinv(i) - dku(i,k) = tem1 - dkt(i,k) = tem1 * prinv(i) - else - tem1 = vk * wscale(i) * tem -! dku(i,k) = xkzmo(i,k) + tem1 -! dkt(i,k) = xkzo(i,k) + tem1 * prinv(i) - dku(i,k) = tem1 - dkt(i,k) = tem1 * prinv(i) - endif - dku(i,k) = min(dku(i,k),dkmax) - dku(i,k) = max(dku(i,k),xkzmo(i,k)) - dkt(i,k) = min(dkt(i,k),dkmax) - dkt(i,k) = max(dkt(i,k),xkzo(i,k)) - dktx(i,k)= dkt(i,k) - endif - enddo !K loop - -! possible modification of first guess DKU, under certain conditions -! (1) this applies only to columns over water - - IF(islimsk(i).eq.0)then ! sea only - -! (2) alpha test -! if alpha < 0, find alpha for each column and do the loop again -! if alpha > 0, we are finished - - - if(alpha.lt.0)then ! variable alpha test - -! k-level of layer around 500 m - kLOC = INT(WSPM(i,2)) -! print *,' kLOC ',kLOC,' KPBL ',KPBL(I) - -! (3) only do this IF KPBL(I) >= kLOC. Otherwise, we are finished, with DKU as -! if alpha = +1 - - if(KPBL(I).gt.kLOC)then - - xDKU = DKU(i,kLOC) ! Km at k-level -! (4) DKU check. -! WSPM(i,1) is the KM cap for the 500-m level. -! if DKU at 500-m level < WSPM(i,1), do not limit Km ANYWHERE. Alpha = -! abs(alpha). No need to recalc. -! if DKU at 500-m level > WSPM(i,1), then alpha = WSPM(i,1)/xDKU for entire -! column - if(xDKU.ge.WSPM(i,1)) then ! ONLY if DKU at 500-m exceeds cap, otherwise already done - - WSPM(i,3) = WSPM(i,1)/xDKU ! ratio of cap to Km at k-level, store in WSPM(i,3) - !WSPM(i,4) = amin1(WSPM(I,3),1.0) ! this is new column alpha. cap at 1. ! should never be needed - WSPM(i,4) = min(WSPM(I,3),1.0) ! this is new column alpha. cap at 1. ! should never be needed - !! recalculate K capped by WSPM(i,1) - do k = 1, kmpbl - if(k < kpbl(i)) then -! zfac = max((1.-(zi(i,k+1)-zl(i,1))/ -! 1 (hpbl(i)-zl(i,1))), zfmin) - zfac = max((1.-zi(i,k+1)/hpbl(i)), zfmin) - ! tem = zi(i,k+1) * (zfac**pfac) - tem = zi(i,k+1) * (zfac**pfac) * WSPM(i,4) - - -!!!! CHANGES FOR HEIGHT-DEPENDENT K ADJUSTMENT, WANG W - if(useshape .ge. 1) then - sz2h=(ZI(I,K+1)-ZL(I,1))/(HPBL(I)-ZL(I,1)) - sz2h=max(sz2h,zfmin) - sz2h=min(sz2h,1.0) - zfac=(1.0-sz2h)**pfac - smax=0.148 !! max value of this shape function - hmax=0.333 !! roughly height if max K - skmax=hmax*(1.0-hmax)**pfac - sksfc=min(ZI(I,2)/HPBL(I),0.05) ! surface layer top, 0.05H or ZI(2) (Zi(1)=0) - sksfc=sksfc*(1-sksfc)**pfac - - zfac=max(zfac,zfmin) - ashape=max(WSPM(i,4),0.2) !! adjustment coef should not smaller than 0.2 - if(useshape ==1) then - ashape=( 1.0 - ((sz2h*zfac/smax)**0.25) - & *( 1.0 - ashape ) ) - tem = zi(i,k+1) * (zfac) * ashape -! if(k ==5) write(0,*)'min alf, height-depend alf',WSPM(i,4),ashape - endif ! endif useshape=1 - - if (useshape == 2) then !only adjus K that is > K_surface_top - ashape1=1.0 - if (skmax > sksfc) ashape1=(skmax*ashape-sksfc)/ - & (skmax-sksfc) - - skminusk0=ZI(I,K+1)*zfac - HPBL(i)*sksfc - tem = zi(i,k+1) * (zfac) ! no adjustment -! if(k ==5) write(0,*)'before, dku,ashape,ashpe1', -! & tem*wscaleu(i)*vk,ashape,ashape1 - if (skminusk0 > 0) then ! only adjust K which is > surface top K - tem = skminusk0*ashape1 + HPBL(i)*sksfc - endif -! if(k ==5)write(0,*) -! & 'after,dku,k_sfc,skmax,sksfc,zi(2),hpbl' -! & ,tem*wscaleu(i)*vk,WSCALEU(I)*VK*HPBL(i)*sksfc, skmax, -! & sksfc,ZI(I,2),HPBL(I) - - endif ! endif useshape=2 - endif ! endif useshape>1 -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - if(pblflg(i)) then - tem1 = vk * wscaleu(i) * tem -! dku(i,k) = xkzmo(i,k) + tem1 -! dkt(i,k) = xkzo(i,k) + tem1 * prinv(i) - dku(i,k) = tem1 - dkt(i,k) = tem1 * prinv(i) - else - tem1 = vk * wscale(i) * tem -! dku(i,k) = xkzmo(i,k) + tem1 -! dkt(i,k) = xkzo(i,k) + tem1 * prinv(i) - dku(i,k) = tem1 - dkt(i,k) = tem1 * prinv(i) - endif - dku(i,k) = min(dku(i,k),dkmax) - dku(i,k) = max(dku(i,k),xkzmo(i,k)) - dkt(i,k) = min(dkt(i,k),dkmax) - dkt(i,k) = max(dkt(i,k),xkzo(i,k)) - dktx(i,k)= dkt(i,k) - endif - enddo !K loop - endif ! xDKU.ge.WSPM(i,1) - endif ! KPBL(I).ge.kLOC - endif ! alpha < 0 - endif ! islimsk=0 - - enddo !I loop - ENDIF !AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA - -! -! compute diffusion coefficients based on local scheme above pbl -!> ## Compute diffusion coefficients above the PBL top -!! Diffusion coefficients above the PBL top are computed as a function of local stability (gradient Richardson number), shear, and a length scale from Louis (1979) \cite louis_1979 : -!! \f[ -!! K_{m,h}=l^2f_{m,h}(Ri_g)\left|\frac{\partial U}{\partial z}\right| -!! \f] -!! The functions used (\f$f_{m,h}\f$) depend on the local stability. First, the gradient Richardson number is calculated as -!! \f[ -!! Ri_g=\frac{\frac{g}{T}\frac{\partial \theta_v}{\partial z}}{\frac{\partial U}{\partial z}^2} -!! \f] -!! where \f$U\f$ is the horizontal wind. For the unstable case (\f$Ri_g < 0\f$), the Richardson number-dependent functions are given by -!! \f[ -!! f_h(Ri_g) = 1 + \frac{8\left|Ri_g\right|}{1 + 1.286\sqrt{\left|Ri_g\right|}}\\ -!! \f] -!! \f[ -!! f_m(Ri_g) = 1 + \frac{8\left|Ri_g\right|}{1 + 1.746\sqrt{\left|Ri_g\right|}}\\ -!! \f] -!! For the stable case, the following formulas are used -!! \f[ -!! f_h(Ri_g) = \frac{1}{\left(1 + 5Ri_g\right)^2}\\ -!! \f] -!! \f[ -!! Pr = \frac{K_h}{K_m} = 1 + 2.1Ri_g -!! \f] -!! The source for the formulas used for the Richardson number-dependent functions is unclear. They are different than those used in Hong and Pan (1996) \cite hong_and_pan_1996 as the previous documentation suggests. They follow equation 14 of Louis (1979) \cite louis_1979 for the unstable case, but it is unclear where the values of the coefficients \f$b\f$ and \f$c\f$ from that equation used in this scheme originate. Finally, the length scale, \f$l\f$ is calculated according to the following formula from Hong and Pan (1996) \cite hong_and_pan_1996 -!! \f[ -!! \frac{1}{l} = \frac{1}{kz} + \frac{1}{l_0}\\ -!! \f] -!! \f[ -!! or\\ -!! \f] -!! \f[ -!! l=\frac{l_0kz}{l_0+kz} -!! \f] -!! where \f$l_0\f$ is currently 30 m for stable conditions and 150 m for unstable. Finally, the diffusion coefficients are kept in a range bounded by the background diffusion and the maximum allowable values. - do k = 1, km1 - do i=1,im - if(k >= kpbl(i)) then - bvf2 = g*bf(i,k)*ti(i,k) - ri = max(bvf2/shr2(i,k),rimin) - zk = vk*zi(i,k+1) - if(ri < 0.) then ! unstable regime - rl2 = zk*rlamun/(rlamun+zk) - dk = rl2*rl2*sqrt(shr2(i,k)) - sri = sqrt(-ri) -! dku(i,k) = xkzmo(i,k) + dk*(1+8.*(-ri)/(1+1.746*sri)) -! dkt(i,k) = xkzo(i,k) + dk*(1+8.*(-ri)/(1+1.286*sri)) - dku(i,k) = dk*(1+8.*(-ri)/(1+1.746*sri)) - dkt(i,k) = dk*(1+8.*(-ri)/(1+1.286*sri)) - else ! stable regime - rl2 = zk*rlam/(rlam+zk) -!! tem = rlam * sqrt(0.01*prsi(i,k)) -!! rl2 = zk*tem/(tem+zk) - dk = rl2*rl2*sqrt(shr2(i,k)) - tem1 = dk/(1+5.*ri)**2 -! - if(k >= kpblx(i)) then - prnum = 1.0 + 2.1*ri - prnum = min(prnum,prmax) - else - prnum = 1.0 - endif -! dku(i,k) = xkzmo(i,k) + tem1 * prnum -! dkt(i,k) = xkzo(i,k) + tem1 - dku(i,k) = tem1 * prnum - dkt(i,k) = tem1 - endif -! - dku(i,k) = min(dku(i,k),dkmax) - dku(i,k) = max(dku(i,k),xkzmo(i,k)) - dkt(i,k) = min(dkt(i,k),dkmax) - dkt(i,k) = max(dkt(i,k),xkzo(i,k)) -! - endif -! - enddo - enddo -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! compute components for mass flux mixing by large thermals -!> ## If the PBL is convective, call the mass flux scheme to replace the countergradient terms. -!! If the PBL is convective, the updraft properties are initialized to be the same as the state variables and the subroutine mfpbl is called. - do k = 1, km - do i = 1, im - if(pcnvflg(i)) then - tcko(i,k) = t1(i,k) - ucko(i,k) = u1(i,k) - vcko(i,k) = v1(i,k) - xmf(i,k) = 0. - endif - enddo - enddo - do kk = 1, ntrac - do k = 1, km - do i = 1, im - if(pcnvflg(i)) then - qcko(i,k,kk) = q1(i,k,kk) - endif - enddo - enddo - enddo -!> For details of the mfpbl subroutine, step into its documentation ::mfpbl - call mfpbl(im,im,km,ntrac,dt2,pcnvflg, - & zl,zi,thvx,q1,t1,u1,v1,hpbl,kpbl, - & sflux,ustar,wstar,xmf,tcko,qcko,ucko,vcko) -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! compute diffusion coefficients for cloud-top driven diffusion -! if the condition for cloud-top instability is met, -! increase entrainment flux at cloud top -! -!> ## Compute enhanced diffusion coefficients related to stratocumulus-topped PBLs -!! If a stratocumulus layer has been identified in the PBL, the diffusion coefficients in the PBL are modified in the following way. -!! -!! -# First, the criteria for CTEI is checked, using the threshold from equation 13 of Macvean and Mason (1990) \cite macvean_and_mason_1990. If the criteria is met, the cloud top diffusion is increased: -!! \f[ -!! K_h^{Sc} = -c\frac{\Delta F_R}{\rho c_p}\frac{1}{\frac{\partial \theta_v}{\partial z}} -!! \f] -!! where the constant \f$c\f$ is set to 0.2 if the CTEI criterion is not met and 1.0 if it is. -!! -!! -# Calculate the diffusion coefficients due to stratocumulus mixing according to equation 5 in Lock et al. (2000) \cite lock_et_al_2000 for every level below the stratocumulus top using the characteristic stratocumulus velocity scale previously calculated. The diffusion coefficient for momentum is calculated assuming a constant inverse Prandtl number of 0.75. - do i = 1, im - if(scuflg(i)) then - k = krad(i) - tem = thetae(i,k) - thetae(i,k+1) - tem1 = qtx(i,k) - qtx(i,k+1) - if (tem > 0. .and. tem1 > 0.) then - cteit= cp*tem/(hvap*tem1) - if(cteit > actei) rent(i) = rentf2 - endif - endif - enddo - do i = 1, im - if(scuflg(i)) then - k = krad(i) - tem1 = max(bf(i,k),tdzmin) - ckt(i,k) = -rent(i)*radmin(i)/tem1 - cku(i,k) = ckt(i,k) - endif - enddo -! - do k = 1, kmpbl - do i=1,im - if(scuflg(i) .and. k < krad(i)) then - tem1=hrad(i)-zd(i) - tem2=zi(i,k+1)-tem1 - if(tem2 > 0.) then - ptem= tem2/zd(i) - if(ptem.ge.1.) ptem= 1. - ptem= tem2*ptem*sqrt(1.-ptem) - ckt(i,k) = radfac*vk*vrad(i)*ptem - cku(i,k) = 0.75*ckt(i,k) - ckt(i,k) = max(ckt(i,k),dkmin) - ckt(i,k) = min(ckt(i,k),dkmax) - cku(i,k) = max(cku(i,k),dkmin) - cku(i,k) = min(cku(i,k),dkmax) - endif - endif - enddo - enddo -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!> After \f$K_h^{Sc}\f$ has been determined from the surface to the top of the stratocumulus layer, it is added to the value for the diffusion coefficient calculated previously using surface-based mixing [see equation 6 of Lock et al. (2000) \cite lock_et_al_2000 ]. - do k = 1, kmpbl - do i=1,im - if(scuflg(i)) then - ! dkt(i,k) = dkt(i,k)+ckt(i,k) - ! dku(i,k) = dku(i,k)+cku(i,k) - !! if K needs to be adjusted by alpha, then no need to add this term - if(alpha .ge. 0.0) dkt(i,k) = dkt(i,k)+ckt(i,k) - if(alpha .ge. 0.0) dku(i,k) = dku(i,k)+cku(i,k) - - dkt(i,k) = min(dkt(i,k),dkmax) - dku(i,k) = min(dku(i,k),dkmax) - endif - enddo - enddo -! -! compute tridiagonal matrix elements for heat and moisture -! -!> ## Solve for the temperature and moisture tendencies due to vertical mixing. -!! The tendencies of heat, moisture, and momentum due to vertical diffusion are calculated using a two-part process. First, a solution is obtained using an implicit time-stepping scheme, then the time tendency terms are "backed out". The tridiagonal matrix elements for the implicit solution for temperature and moisture are prepared in this section, with differing algorithms depending on whether the PBL was convective (substituting the mass flux term for counter-gradient term), unstable but not convective (using the computed counter-gradient terms), or stable (no counter-gradient terms). - do i=1,im - ad(i,1) = 1. - a1(i,1) = t1(i,1) + beta(i) * heat(i) - a2(i,1) = q1(i,1,1) + beta(i) * evap(i) - enddo - - if(ntrac >= 2) then - do k = 2, ntrac - is = (k-1) * km - do i = 1, im - a2(i,1+is) = q1(i,1,k) - enddo - enddo - endif -! - do k = 1,km1 - do i = 1,im - dtodsd = dt2/del(i,k) - dtodsu = dt2/del(i,k+1) - dsig = prsl(i,k)-prsl(i,k+1) - rdz = rdzt(i,k) - tem1 = dsig * dkt(i,k) * rdz - dsdz2 = tem1 * rdz - au(i,k) = -dtodsd*dsdz2 - al(i,k) = -dtodsu*dsdz2 -! - if(pcnvflg(i) .and. k < kpbl(i)) then - tem2 = dsig * rdz - ptem = 0.5 * tem2 * xmf(i,k) - ptem1 = dtodsd * ptem - ptem2 = dtodsu * ptem - ad(i,k) = ad(i,k)-au(i,k)-ptem1 - ad(i,k+1) = 1.-al(i,k)+ptem2 - au(i,k) = au(i,k)-ptem1 - al(i,k) = al(i,k)+ptem2 - ptem = tcko(i,k) + tcko(i,k+1) - dsdzt = tem1 * gocp - a1(i,k) = a1(i,k)+dtodsd*dsdzt-ptem1*ptem - a1(i,k+1) = t1(i,k+1)-dtodsu*dsdzt+ptem2*ptem - ptem = qcko(i,k,1) + qcko(i,k+1,1) - a2(i,k) = a2(i,k) - ptem1 * ptem - a2(i,k+1) = q1(i,k+1,1) + ptem2 * ptem - elseif(ublflg(i) .and. k < kpbl(i)) then - ptem1 = dsig * dktx(i,k) * rdz - tem = 1.0 / hpbl(i) - dsdzt = tem1 * gocp - ptem1 * hgamt(i) * tem - dsdzq = - ptem1 * hgamq(i) * tem - ad(i,k) = ad(i,k)-au(i,k) - ad(i,k+1) = 1.-al(i,k) - a1(i,k) = a1(i,k)+dtodsd*dsdzt - a1(i,k+1) = t1(i,k+1)-dtodsu*dsdzt - a2(i,k) = a2(i,k)+dtodsd*dsdzq - a2(i,k+1) = q1(i,k+1,1)-dtodsu*dsdzq - else - ad(i,k) = ad(i,k)-au(i,k) - ad(i,k+1) = 1.-al(i,k) - dsdzt = tem1 * gocp - a1(i,k) = a1(i,k)+dtodsd*dsdzt - a1(i,k+1) = t1(i,k+1)-dtodsu*dsdzt - a2(i,k+1) = q1(i,k+1,1) - endif -! - enddo - enddo -! - if(ntrac >= 2) then - do kk = 2, ntrac - is = (kk-1) * km - do k = 1, km1 - do i = 1, im - if(pcnvflg(i) .and. k < kpbl(i)) then - dtodsd = dt2/del(i,k) - dtodsu = dt2/del(i,k+1) - dsig = prsl(i,k)-prsl(i,k+1) - tem = dsig * rdzt(i,k) - ptem = 0.5 * tem * xmf(i,k) - ptem1 = dtodsd * ptem - ptem2 = dtodsu * ptem - tem1 = qcko(i,k,kk) + qcko(i,k+1,kk) - a2(i,k+is) = a2(i,k+is) - ptem1*tem1 - a2(i,k+1+is)= q1(i,k+1,kk) + ptem2*tem1 - else - a2(i,k+1+is) = q1(i,k+1,kk) - endif - enddo - enddo - enddo - endif -! -! solve tridiagonal problem for heat and moisture -! -!> The tridiagonal system is solved by calling the internal ::tridin subroutine. - call tridin99(im,km,ntrac,al,ad,au,a1,a2,au,a1,a2) - -! -! recover tendencies of heat and moisture -! -!> After returning with the solution, the tendencies for temperature and moisture are recovered. - do k = 1,km - do i = 1,im - ttend = (a1(i,k)-t1(i,k)) * rdt - qtend = (a2(i,k)-q1(i,k,1))*rdt - tau(i,k) = tau(i,k)+ttend - rtg(i,k,1) = rtg(i,k,1)+qtend - dtsfc(i) = dtsfc(i)+cont*del(i,k)*ttend - dqsfc(i) = dqsfc(i)+conq*del(i,k)*qtend - enddo - enddo - if(ntrac >= 2) then - do kk = 2, ntrac - is = (kk-1) * km - do k = 1, km - do i = 1, im - qtend = (a2(i,k+is)-q1(i,k,kk))*rdt - rtg(i,k,kk) = rtg(i,k,kk)+qtend - enddo - enddo - enddo - endif -! -! compute tke dissipation rate -! -!> ## Calculate heating due to TKE dissipation and add to the tendency for temperature -!! Following Han et al. (2015) \cite han_et_al_2015 , turbulence dissipation contributes to the tendency of temperature in the following way. First, turbulence dissipation is calculated by equation 17 of Han et al. (2015) \cite han_et_al_2015 for the PBL and equation 16 for the surface layer. - if(dspheat) then -! - do k = 1,km1 - do i = 1,im - diss(i,k) = dku(i,k)*shr2(i,k)-g*ti(i,k)*dkt(i,k)*bf(i,k) -! diss(i,k) = dku(i,k)*shr2(i,k) - enddo - enddo -! -! add dissipative heating at the first model layer -! -!> Next, the temperature tendency is updated following equation 14. - do i = 1,im - tem = govrth(i)*sflux(i) - tem1 = tem + stress(i)*spd1(i)/zl(i,1) - tem2 = 0.5 * (tem1+diss(i,1)) - tem2 = max(tem2, 0.) - ttend = tem2 / cp - if (alpha .gt. 0.0) then - tau(i,1) = tau(i,1)+0.5*ttend - else - tau(i,1) = tau(i,1)+0.7*ttend ! in HWRF/HMON, use 0.7 - endif - enddo -! -! add dissipative heating above the first model layer -! - do k = 2,km1 - do i = 1,im - tem = 0.5 * (diss(i,k-1)+diss(i,k)) - tem = max(tem, 0.) - ttend = tem / cp - tau(i,k) = tau(i,k) + 0.5*ttend - enddo - enddo -! - endif -! -! compute tridiagonal matrix elements for momentum -! -!> ## Solve for the horizontal momentum tendencies and add them to the output tendency terms -!! As with the temperature and moisture tendencies, the horizontal momentum tendencies are calculated by solving tridiagonal matrices after the matrices are prepared in this section. - do i=1,im - ad(i,1) = 1.0 + beta(i) * stress(i) / spd1(i) - a1(i,1) = u1(i,1) - a2(i,1) = v1(i,1) - enddo -! - do k = 1,km1 - do i=1,im - dtodsd = dt2/del(i,k) - dtodsu = dt2/del(i,k+1) - dsig = prsl(i,k)-prsl(i,k+1) - rdz = rdzt(i,k) - tem1 = dsig*dku(i,k)*rdz - dsdz2 = tem1 * rdz - au(i,k) = -dtodsd*dsdz2 - al(i,k) = -dtodsu*dsdz2 -! - if(pcnvflg(i) .and. k < kpbl(i)) then - tem2 = dsig * rdz - ptem = 0.5 * tem2 * xmf(i,k) - ptem1 = dtodsd * ptem - ptem2 = dtodsu * ptem - ad(i,k) = ad(i,k)-au(i,k)-ptem1 - ad(i,k+1) = 1.-al(i,k)+ptem2 - au(i,k) = au(i,k)-ptem1 - al(i,k) = al(i,k)+ptem2 - ptem = ucko(i,k) + ucko(i,k+1) - a1(i,k) = a1(i,k) - ptem1 * ptem - a1(i,k+1) = u1(i,k+1) + ptem2 * ptem - ptem = vcko(i,k) + vcko(i,k+1) - a2(i,k) = a2(i,k) - ptem1 * ptem - a2(i,k+1) = v1(i,k+1) + ptem2 * ptem - else - ad(i,k) = ad(i,k)-au(i,k) - ad(i,k+1) = 1.-al(i,k) - a1(i,k+1) = u1(i,k+1) - a2(i,k+1) = v1(i,k+1) - endif -! - enddo - enddo - - do k = 1,km1 - do i=1,im - dkudiagnostic(i,k) = dku(i,k) - enddo - enddo - -! -! solve tridiagonal problem for momentum -! - call tridi299(im,km,al,ad,au,a1,a2,au,a1,a2) -! -! recover tendencies of momentum -! -!> Finally, the tendencies are recovered from the tridiagonal solutions. - do k = 1,km - do i = 1,im - utend = (a1(i,k)-u1(i,k))*rdt - vtend = (a2(i,k)-v1(i,k))*rdt - du(i,k) = du(i,k) + utend - dv(i,k) = dv(i,k) + vtend - dusfc(i) = dusfc(i) + conw*del(i,k)*utend - dvsfc(i) = dvsfc(i) + conw*del(i,k)*vtend -! -! for dissipative heating for ecmwf model -! -! tem1 = 0.5*(a1(i,k)+u1(i,k)) -! tem2 = 0.5*(a2(i,k)+v1(i,k)) -! diss(i,k) = -(tem1*utend+tem2*vtend) -! diss(i,k) = max(diss(i,k),0.) -! ttend = diss(i,k) / cp -! tau(i,k) = tau(i,k) + ttend -! - enddo - enddo -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! - do i = 1, im - hpbl(i) = hpblx(i) - kpbl(i) = kpblx(i) - enddo -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - return - end subroutine hedmf_hafs_run - -!> @} - -c----------------------------------------------------------------------- -!> \ingroup PBL -!! \brief Routine to solve the tridiagonal system to calculate temperature and moisture at \f$ t + \Delta t \f$; part of two-part process to calculate time tendencies due to vertical diffusion. -!! -!! Origin of subroutine unknown. - subroutine tridi299(l,n,cl,cm,cu,r1,r2,au,a1,a2) -cc - use machine , only : kind_phys - implicit none - integer k,n,l,i - real(kind=kind_phys) fk -cc - real(kind=kind_phys) cl(l,2:n),cm(l,n),cu(l,n-1),r1(l,n),r2(l,n), & - & au(l,n-1),a1(l,n),a2(l,n) -c----------------------------------------------------------------------- - do i=1,l - fk = 1./cm(i,1) - au(i,1) = fk*cu(i,1) - a1(i,1) = fk*r1(i,1) - a2(i,1) = fk*r2(i,1) - enddo - do k=2,n-1 - do i=1,l - fk = 1./(cm(i,k)-cl(i,k)*au(i,k-1)) - au(i,k) = fk*cu(i,k) - a1(i,k) = fk*(r1(i,k)-cl(i,k)*a1(i,k-1)) - a2(i,k) = fk*(r2(i,k)-cl(i,k)*a2(i,k-1)) - enddo - enddo - do i=1,l - fk = 1./(cm(i,n)-cl(i,n)*au(i,n-1)) - a1(i,n) = fk*(r1(i,n)-cl(i,n)*a1(i,n-1)) - a2(i,n) = fk*(r2(i,n)-cl(i,n)*a2(i,n-1)) - enddo - do k=n-1,1,-1 - do i=1,l - a1(i,k) = a1(i,k)-au(i,k)*a1(i,k+1) - a2(i,k) = a2(i,k)-au(i,k)*a2(i,k+1) - enddo - enddo -c----------------------------------------------------------------------- - return - end subroutine tridi299 -c----------------------------------------------------------------------- -!> \ingroup PBL -!! \brief Routine to solve the tridiagonal system to calculate u- and v-momentum at \f$ t + \Delta t \f$; part of two-part process to calculate time tendencies due to vertical diffusion. -!! -!! Origin of subroutine unknown. - subroutine tridin99(l,n,nt,cl,cm,cu,r1,r2,au,a1,a2) -cc - use machine , only : kind_phys - implicit none - integer is,k,kk,n,nt,l,i - real(kind=kind_phys) fk(l) -cc - real(kind=kind_phys) cl(l,2:n), cm(l,n), cu(l,n-1), & - & r1(l,n), r2(l,n*nt), & - & au(l,n-1), a1(l,n), a2(l,n*nt), & - & fkk(l,2:n-1) -c----------------------------------------------------------------------- - do i=1,l - fk(i) = 1./cm(i,1) - au(i,1) = fk(i)*cu(i,1) - a1(i,1) = fk(i)*r1(i,1) - enddo - do k = 1, nt - is = (k-1) * n - do i = 1, l - a2(i,1+is) = fk(i) * r2(i,1+is) - enddo - enddo - do k=2,n-1 - do i=1,l - fkk(i,k) = 1./(cm(i,k)-cl(i,k)*au(i,k-1)) - au(i,k) = fkk(i,k)*cu(i,k) - a1(i,k) = fkk(i,k)*(r1(i,k)-cl(i,k)*a1(i,k-1)) - enddo - enddo - do kk = 1, nt - is = (kk-1) * n - do k=2,n-1 - do i=1,l - a2(i,k+is) = fkk(i,k)*(r2(i,k+is)-cl(i,k)*a2(i,k+is-1)) - enddo - enddo - enddo - do i=1,l - fk(i) = 1./(cm(i,n)-cl(i,n)*au(i,n-1)) - a1(i,n) = fk(i)*(r1(i,n)-cl(i,n)*a1(i,n-1)) - enddo - do k = 1, nt - is = (k-1) * n - do i = 1, l - a2(i,n+is) = fk(i)*(r2(i,n+is)-cl(i,n)*a2(i,n+is-1)) - enddo - enddo - do k=n-1,1,-1 - do i=1,l - a1(i,k) = a1(i,k) - au(i,k)*a1(i,k+1) - enddo - enddo - do kk = 1, nt - is = (kk-1) * n - do k=n-1,1,-1 - do i=1,l - a2(i,k+is) = a2(i,k+is) - au(i,k)*a2(i,k+is+1) - enddo - enddo - enddo -c----------------------------------------------------------------------- - return - end subroutine tridin99 - -!> @} - - end module hedmf_hafs diff --git a/physics/moninedmf_hafs.meta b/physics/moninedmf_hafs.meta deleted file mode 100644 index 6f084e08b..000000000 --- a/physics/moninedmf_hafs.meta +++ /dev/null @@ -1,533 +0,0 @@ -[ccpp-table-properties] - name = hedmf_hafs - type = scheme - dependencies = funcphys.f90,machine.F,mfpbl.f,physcons.F90 - -######################################################################## -[ccpp-arg-table] - name = hedmf_hafs_init - type = scheme -[moninq_fac] - standard_name = atmosphere_diffusivity_coefficient_factor - long_name = multiplicative constant for atmospheric diffusivities - units = none - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out - optional = F -[errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag - dimensions = () - type = integer - intent = out - optional = F - -######################################################################## -[ccpp-arg-table] - name = hedmf_hafs_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in - optional = F -[km] - standard_name = vertical_dimension - long_name = vertical layer dimension - units = count - dimensions = () - type = integer - intent = in - optional = F -[ntrac] - standard_name = number_of_vertical_diffusion_tracers - long_name = number of tracers to diffuse vertically - units = count - dimensions = () - type = integer - intent = in - optional = F -[ntcw] - standard_name = index_for_liquid_cloud_condensate - long_name = cloud condensate index in tracer array - units = index - dimensions = () - type = integer - intent = in - optional = F -[dv] - standard_name = tendency_of_y_wind_due_to_model_physics - long_name = updated tendency of the y wind - units = m s-2 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[du] - standard_name = tendency_of_x_wind_due_to_model_physics - long_name = updated tendency of the x wind - units = m s-2 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[tau] - standard_name = tendency_of_air_temperature_due_to_model_physics - long_name = updated tendency of the temperature - units = K s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[rtg] - standard_name = tendency_of_vertically_diffused_tracer_concentration - long_name = updated tendency of the tracers due to vertical diffusion in PBL scheme - units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_dimension,number_of_vertical_diffusion_tracers) - type = real - kind = kind_phys - intent = inout - optional = F -[u1] - standard_name = x_wind - long_name = x component of layer wind - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[v1] - standard_name = y_wind - long_name = y component of layer wind - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[t1] - standard_name = air_temperature - long_name = layer mean air temperature - units = K - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[q1] - standard_name = vertically_diffused_tracer_concentration - long_name = tracer concentration diffused by PBL scheme - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension,number_of_vertical_diffusion_tracers) - type = real - kind = kind_phys - intent = in - optional = F -[swh] - standard_name = tendency_of_air_temperature_due_to_shortwave_heating_on_radiation_time_step - long_name = total sky shortwave heating rate - units = K s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[hlw] - standard_name = tendency_of_air_temperature_due_to_longwave_heating_on_radiation_time_step - long_name = total sky longwave heating rate - units = K s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[xmu] - standard_name = zenith_angle_temporal_adjustment_factor_for_shortwave_fluxes - long_name = zenith angle temporal adjustment factor for shortwave - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[psk] - standard_name = dimensionless_exner_function_at_lowest_model_interface - long_name = dimensionless Exner function at the surface interface - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[rbsoil] - standard_name = bulk_richardson_number_at_lowest_model_level - long_name = bulk Richardson number at the surface - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[zorl] - standard_name = surface_roughness_length - long_name = surface roughness length in cm - units = cm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[u10m] - standard_name = x_wind_at_10m - long_name = x component of wind at 10 m - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[v10m] - standard_name = y_wind_at_10m - long_name = y component of wind at 10 m - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[fm] - standard_name = Monin_Obukhov_similarity_function_for_momentum - long_name = Monin-Obukhov similarity function for momentum - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[fh] - standard_name = Monin_Obukhov_similarity_function_for_heat - long_name = Monin-Obukhov similarity function for heat - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[tsea] - standard_name = surface_skin_temperature - long_name = surface skin temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[heat] - standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness - long_name = kinematic surface upward sensible heat flux - units = K m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[evap] - standard_name = kinematic_surface_upward_latent_heat_flux_reduced_by_surface_roughness - long_name = kinematic surface upward latent heat flux - units = kg kg-1 m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[stress] - standard_name = surface_wind_stress - long_name = surface wind stress - units = m2 s-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[spd1] - standard_name = wind_speed_at_lowest_model_layer - long_name = wind speed at lowest model level - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[kpbl] - standard_name = vertical_index_at_top_of_atmosphere_boundary_layer - long_name = PBL top model level index - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = out - optional = F -[prsi] - standard_name = air_pressure_at_interface - long_name = air pressure at model layer interfaces - units = Pa - dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) - type = real - kind = kind_phys - intent = in - optional = F -[del] - standard_name = air_pressure_difference_between_midlayers - long_name = pres(k) - pres(k+1) - units = Pa - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[prsl] - standard_name = air_pressure - long_name = mean layer pressure - units = Pa - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[prslk] - standard_name = dimensionless_exner_function_at_model_layers - long_name = Exner function at layers - units = none - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[phii] - standard_name = geopotential_at_interface - long_name = geopotential at model layer interfaces - units = m2 s-2 - dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) - type = real - kind = kind_phys - intent = in - optional = F -[phil] - standard_name = geopotential - long_name = geopotential at model layer centers - units = m2 s-2 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[delt] - standard_name = time_step_for_physics - long_name = time step for physics - units = s - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[dspheat] - standard_name = flag_TKE_dissipation_heating - long_name = flag for using TKE dissipation heating - units = flag - dimensions = () - type = logical - intent = in - optional = F -[dusfc] - standard_name = instantaneous_surface_x_momentum_flux - long_name = x momentum flux - units = Pa - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out - optional = F -[dvsfc] - standard_name = instantaneous_surface_y_momentum_flux - long_name = y momentum flux - units = Pa - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out - optional = F -[dtsfc] - standard_name = instantaneous_surface_upward_sensible_heat_flux - long_name = surface upward sensible heat flux - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out - optional = F -[dqsfc] - standard_name = instantaneous_surface_upward_latent_heat_flux - long_name = surface upward latent heat flux - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out - optional = F -[hpbl] - standard_name = atmosphere_boundary_layer_thickness - long_name = PBL thickness - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out - optional = F -[hgamt] - standard_name = countergradient_mixing_term_for_temperature - long_name = countergradient mixing term for temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[hgamq] - standard_name = countergradient_mixing_term_for_water_vapor - long_name = countergradient mixing term for water vapor - units = kg kg-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[dkt] - standard_name = atmosphere_heat_diffusivity - long_name = diffusivity for heat - units = m2 s-1 - dimensions = (horizontal_loop_extent,vertical_dimension_minus_one) - type = real - kind = kind_phys - intent = out - optional = F -[kinver] - standard_name = index_of_highest_temperature_inversion - long_name = index of highest temperature inversion - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = in - optional = F -[xkzm_m] - standard_name = atmosphere_momentum_diffusivity_background - long_name = background value of momentum diffusivity - units = m2 s-1 - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[xkzm_h] - standard_name = atmosphere_heat_diffusivity_background - long_name = background value of heat diffusivity - units = m2 s-1 - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[xkzm_s] - standard_name = diffusivity_background_sigma_level - long_name = sigma level threshold for background diffusivity - units = none - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[lprnt] - standard_name = flag_print - long_name = flag for printing diagnostics to output - units = flag - dimensions = () - type = logical - intent = in - optional = F -[ipr] - standard_name = horizontal_index_of_printed_column - long_name = horizontal index of printed column - units = index - dimensions = () - type = integer - intent = in - optional = F -[xkzminv] - standard_name = atmosphere_heat_diffusivity_background_maximum - long_name = maximum background value of heat diffusivity - units = m2 s-1 - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[moninq_fac] - standard_name = atmosphere_diffusivity_coefficient_factor - long_name = multiplicative constant for atmospheric diffusivities - units = none - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[islimsk] - standard_name = sea_land_ice_mask - long_name = sea/land/ice mask (=0/1/2) - units = flag - dimensions = (horizontal_loop_extent) - type = integer - intent = in - optional = F -[dkudiagnostic] - standard_name = atmosphere_momentum_diffusivity - long_name = diffusivity for momentum - units = m2 s-1 - dimensions = (horizontal_dimension,vertical_dimension_minus_one) - type = real - kind = kind_phys - intent = out - optional = F -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out - optional = F -[errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag - dimensions = () - type = integer - intent = out - optional = F diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index 3741b502f..63a67c810 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -66,7 +66,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & & dspheat,dusfc,dvsfc,dtsfc,dqsfc,hpbl, & & kinver,xkzm_m,xkzm_h,xkzm_s,dspfac,bl_upfr,bl_dnfr, & & ntoz,du3dt,dv3dt,dt3dt,dq3dt,do3dt,gen_tend,ldiag3d,qdiag3d, & - & dkudiagnostic,errmsg,errflg) + & errmsg,errflg) ! use machine , only : kind_phys use funcphys , only : fpvs @@ -131,8 +131,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & & slx(im,km), svx(im,km), qtx(im,km), & tvx(im,km), pix(im,km), radx(im,km-1), & dku(im,km-1),dkt(im,km-1), dkq(im,km-1), - & cku(im,km-1),ckt(im,km-1), - & dkudiagnostic(im,km-1) + & cku(im,km-1),ckt(im,km-1) ! real(kind=kind_phys) plyr(im,km), rhly(im,km), cfly(im,km), & qstl(im,km) @@ -1539,12 +1538,6 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & ! enddo enddo - - do k = 1,km1 - do i=1,im - dkudiagnostic(i,k) = dku(i,k) - enddo - enddo c !> - Call tridi2() to solve tridiagonal problem for momentum c From c3105d8247746aa4a3591d12de9e6f0a697c372b Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Fri, 16 Oct 2020 20:56:29 -0600 Subject: [PATCH 39/42] Bugfix: remove dkudiagnostic from satmedmfvdifq.meta --- physics/satmedmfvdifq.meta | 9 --------- 1 file changed, 9 deletions(-) diff --git a/physics/satmedmfvdifq.meta b/physics/satmedmfvdifq.meta index af6e23914..a57ce3839 100644 --- a/physics/satmedmfvdifq.meta +++ b/physics/satmedmfvdifq.meta @@ -670,15 +670,6 @@ type = logical intent = inout optional = F -[dkudiagnostic] - standard_name = atmosphere_momentum_diffusivity - long_name = diffusivity for momentum - units = m2 s-1 - dimensions = (horizontal_loop_extent,vertical_dimension_minus_one) - type = real - kind = kind_phys - intent = out - optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From b7eff6b604ffbe8b27d8c45498411fa5a908fb31 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Tue, 20 Oct 2020 14:02:59 -0600 Subject: [PATCH 40/42] Fix uninitialized variable mvd_r in physics/module_mp_thompson.F90 --- physics/module_mp_thompson.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index 5c2a2acb5..7d449473b 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -1797,6 +1797,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & rho(k) = 0.622*pres(k)/(R*temp(k)*(qv(k)+0.622)) nwfa(k) = MAX(11.1E6, MIN(9999.E6, nwfa1d(k)*rho(k))) nifa(k) = MAX(naIN1*0.01, MIN(9999.E6, nifa1d(k)*rho(k))) + mvd_r(k) = D0r if (qc1d(k) .gt. R1) then no_micro = .false. From 390ec2160239c49f395f18150f19521fdd4f409a Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Tue, 20 Oct 2020 14:10:10 -0600 Subject: [PATCH 41/42] Fix calls to mcica_subcol_sw in radsw_main.F90 --- physics/radsw_main.F90 | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/physics/radsw_main.F90 b/physics/radsw_main.F90 index d74d4a63f..cf9e0e524 100644 --- a/physics/radsw_main.F90 +++ b/physics/radsw_main.F90 @@ -1012,14 +1012,16 @@ subroutine rrtmg_sw_run & enddo enddo - 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) + call mcica_subcol_sw (1, 1, nlay, iovrsw, permuteseed, & + & irng, plyr(j1:j1,:), hgt(j1:j1,:), & + & cld_cf(j1:j1,:), cld_iwp(j1:j1,:), cld_lwp(j1:j1,:), & + & cld_swp(j1:j1,:), cld_ref_ice(j1:j1,:), cld_ref_liq(j1:j1,:), & + & cld_ref_snow(j1:j1,:), taucld3(:,j1:j1,:), ssacld3(:,j1:j1,:), & + & asmcld3(:,j1:j1,:), fsfcld3(:,j1:j1,:), cldfmcl(:,j1:j1,:), & !--output + & ciwpmcl(:,j1:j1,:), clwpmcl(:,j1:j1,:), cswpmcl(:,j1:j1,:), & + & reicmcl(j1:j1,:), relqmcl(j1:j1,:), resnmcl(j1:j1,:), & + & taucmcl(:,j1:j1,:), ssacmcl(:,j1:j1,:), asmcmcl(:,j1:j1,:), & + & fsfcmcl(:,j1:j1,:)) endif !mz* end @@ -5769,7 +5771,7 @@ subroutine mcica_subcol_sw(iplon, ncol, nlay, icld, permuteseed, & & ssac, asmc, fsfc, & & cldfmcl, ciwpmcl, clwpmcl, cswpmcl, reicmcl, & & relqmcl, resnmcl, & - & taucmcl, ssacmcl, asmcmcl, fsfcmcl) + & taucmcl, ssacmcl, asmcmcl, fsfcmcl) ! ----- Input ----- ! Control From e7b4531d5fa5d0aae4ec4f96105354c3ffb68df2 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Tue, 3 Nov 2020 07:25:36 -0700 Subject: [PATCH 42/42] physics/GFS_surface_composites.F90: update tsfc correctly when there is ice on open water grid points --- physics/GFS_surface_composites.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index b3000b008..cc61662d2 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -547,6 +547,7 @@ subroutine GFS_surface_composites_post_run ( if (.not. flag_cice(i)) then tisfc(i) = tice(i) ! over lake ice (and sea ice when uncoupled) zorl(i) = cice(i) * zorl_ice(i) + (one - cice(i)) * zorl_wat(i) + tsfc(i) = tsfc_ice(i) elseif (wet(i)) then if (cice(i) > min_seaice) then ! this was already done for lake ice in sfc_sice txi = cice(i)