From 9841a990779b8b50ed6b5bcd3d04f2330048fb0e Mon Sep 17 00:00:00 2001 From: Joseph Olson Date: Tue, 22 Jun 2021 01:38:25 +0000 Subject: [PATCH 01/85] Updating MYNN-EDMF --- physics/module_MYNNPBL_wrapper.F90 | 19 +- physics/module_MYNNPBL_wrapper.meta | 8 - physics/module_bl_mynn.F90 | 2297 +++++++++++++++++++-------- 3 files changed, 1640 insertions(+), 684 deletions(-) diff --git a/physics/module_MYNNPBL_wrapper.F90 b/physics/module_MYNNPBL_wrapper.F90 index 532fc7b16..4daa648d1 100644 --- a/physics/module_MYNNPBL_wrapper.F90 +++ b/physics/module_MYNNPBL_wrapper.F90 @@ -4,7 +4,7 @@ !>\ingroup gsd_mynn_edmf !> The following references best describe the code within -!! Olson et al. (2018, NOAA Technical Memorandum) +!! Olson et al. (2019, NOAA Technical Memorandum) !! Nakanishi and Niino (2009 ) \cite NAKANISHI_2009 MODULE mynnedmf_wrapper @@ -101,7 +101,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & grav_settling, bl_mynn_tkebudget, bl_mynn_tkeadvect, & & bl_mynn_cloudpdf, bl_mynn_mixlength, & & bl_mynn_edmf, bl_mynn_edmf_mom, bl_mynn_edmf_tke, & - & bl_mynn_edmf_part, bl_mynn_cloudmix, bl_mynn_mixqt,& + & bl_mynn_cloudmix, bl_mynn_mixqt, & & bl_mynn_output, & & icloud_bl, do_mynnsfclay, & & imp_physics, imp_physics_gfdl, & @@ -212,7 +212,6 @@ SUBROUTINE mynnedmf_wrapper_run( & & bl_mynn_edmf, & & bl_mynn_edmf_mom, & & bl_mynn_edmf_tke, & - & bl_mynn_edmf_part, & & bl_mynn_cloudmix, & & bl_mynn_mixqt, & & bl_mynn_tkebudget, & @@ -231,8 +230,9 @@ SUBROUTINE mynnedmf_wrapper_run( & !MISC CONFIGURATION OPTIONS INTEGER, PARAMETER :: & & spp_pbl=0, & - & bl_mynn_mixscalars=1, & - & levflag=2 + & bl_mynn_mixscalars=1 + REAL, PARAMETER :: & + & closure=2.5 !2.5, 2.6 or 3.0 LOGICAL :: & & FLAG_QI, FLAG_QNI, FLAG_QC, FLAG_QNC, & & FLAG_QNWFA, FLAG_QNIFA @@ -565,11 +565,6 @@ SUBROUTINE mynnedmf_wrapper_run( & else rmol(i)=ABS(rb(i))*1./(dz(i,1)*0.5) endif - !if (rb(i) .ge. 0.)then - ! rmol(i)=rb(i)*8./(dz(i,1)*0.5) - !else - ! rmol(i)=MAX(rb(i)*5.,-10.)/(dz(i,1)*0.5) - !endif endif ts(i)=tsurf(i)/exner(i,1) !theta ! qsfc(i)=qss(i) @@ -622,7 +617,7 @@ SUBROUTINE mynnedmf_wrapper_run( & print*,"bl_mynn_tkebudget=",bl_mynn_tkebudget," bl_mynn_tkeadvect=",bl_mynn_tkeadvect print*,"bl_mynn_cloudpdf=",bl_mynn_cloudpdf," bl_mynn_mixlength=",bl_mynn_mixlength print*,"bl_mynn_edmf=",bl_mynn_edmf," bl_mynn_edmf_mom=",bl_mynn_edmf_mom - print*,"bl_mynn_edmf_tke=",bl_mynn_edmf_tke," bl_mynn_edmf_part=",bl_mynn_edmf_part + print*,"bl_mynn_edmf_tke=",bl_mynn_edmf_tke print*,"bl_mynn_cloudmix=",bl_mynn_cloudmix," bl_mynn_mixqt=",bl_mynn_mixqt print*,"icloud_bl=",icloud_bl print*,"T:",t3d(1,1),t3d(1,2),t3d(1,levs) @@ -691,7 +686,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & ,bl_mynn_mixlength=bl_mynn_mixlength & !input parameter & ,icloud_bl=icloud_bl & !input parameter & ,qc_bl=qc_bl,qi_bl=qi_bl,cldfra_bl=cldfra_bl & !output - & ,levflag=levflag,bl_mynn_edmf=bl_mynn_edmf & !input parameter + & ,closure=closure,bl_mynn_edmf=bl_mynn_edmf & !input parameter & ,bl_mynn_edmf_mom=bl_mynn_edmf_mom & !input parameter & ,bl_mynn_edmf_tke=bl_mynn_edmf_tke & !input parameter & ,bl_mynn_mixscalars=bl_mynn_mixscalars & !input parameter diff --git a/physics/module_MYNNPBL_wrapper.meta b/physics/module_MYNNPBL_wrapper.meta index 453fb8963..1b77d101e 100644 --- a/physics/module_MYNNPBL_wrapper.meta +++ b/physics/module_MYNNPBL_wrapper.meta @@ -1231,14 +1231,6 @@ type = integer intent = in optional = F -[bl_mynn_edmf_part] - standard_name = edmf_partition_flag - long_name = flag to partitioning of the MF and ED areas - units = flag - dimensions = () - type = integer - intent = in - optional = F [bl_mynn_cloudmix] standard_name = cloud_specie_mix_flag long_name = flag to activate mixing of cloud species diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index d691de909..b63da6223 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -2,7 +2,7 @@ !! This file contains the entity of MYNN-EDMF PBL scheme. !WRF:MODEL_LAYER:PHYSICS ! -! translated from NN f77 to F90 and put into WRF by Mariusz Pagowski +! Translated from NN f77 to F90 and put into WRF by Mariusz Pagowski ! NOAA/GSD & CIRA/CSU, Feb 2008 ! changes to original code: ! 1. code is 1D (in z) @@ -13,7 +13,8 @@ ! 5. cosmetic changes to adhere to WRF standard (remove common blocks, ! intent etc) !------------------------------------------------------------------- -!Modifications implemented by Joseph Olson and Jaymes Kenyon NOAA/GSD/MDB - CU/CIRES +!Modifications implemented by Joseph Olson and Jaymes Kenyon (NOAA/GSL), +!Wayne Angevine (NOAA/CSL), Kay Suselj (NASA/JPL), Franciano Puhales (UFSM) ! ! Departures from original MYNN (Nakanish & Niino 2009) ! 1. Addition of BouLac mixing length in the free atmosphere. @@ -119,11 +120,31 @@ ! Misc small-impact bugfixes: ! 1) dz was incorrectly indexed in mym_condensation ! 2) configurations with icloud_bl = 0 were using uninitialized arrays +! v4.3 / CCPP +! This version includes many modifications that proved valuable in the global +! framework and removes some key lingering bugs in the mixing of chemical species. +! TKE Budget output fixed (Puhales, 2020-12) +! New option for stability function: (Puhales, 2020-12) +! bl_mynn_stfunc = 0 (original, Kansas-type function, Paulson, 1970 ) +! bl_mynn_stfunc = 1 (new (for test), same used for Jimenez et al (MWR) +! see the Technical Note for this implementation). +! Improved conservation of momentum and higher-order moments. +! Important bug fixes for mixing of chemical species. +! Addition of pressure-gradient effects on updraft momentum transport. +! Addition of bl_mynn_closure option = 2.5, 2.6, or 3.0 +! Addition of sig_order to regulate the use of higher-order moments +! for sigma when using bl_mynn_cloudpdf = 2 (Chab-Becht). This +! new option is set in the subroutine mym_condensation. +! Not yet: Addition of Greg Thompsons SGS cloud option (bl_mynn_cloudpdf = 3). +! Many miscellaneous tweaks. ! -! Many of these changes are now documented in Olson et al. (2019, -! NOAA Technical Memorandum) -! -! For more explanation of some configuration options, see "JOE's mods" below: +! Many of these changes are now documented in: +! Olson, J. B., J. S. Kenyon, W. M. Angevine, J. M. Brown, M. Pagowski, and K. Sušelj, 2019: +! A description of the MYNN-EDMF scheme and coupling to other components in WRF-ARW. +! NOAA Tech. Memo. OAR GSD, 61, 37 pp., https://doi.org/10.25923/n9wm-be49. +! Puhales, Franciano S., Joseph B. Olson, Jimy Dudhia, Douglas Lima de Bem, Rafael Maroneze, +! Otávio C. Acevedo, Felipe D. Costa, and Vagner Anabor, 2020: Turbulent Kinetic Energy +! Budget for MYNN-EDMF PBL Scheme in WRF model. Universidade Federal de Santa Maria Technical Note. 9 pp. !------------------------------------------------------------------- MODULE module_bl_mynn @@ -250,11 +271,15 @@ MODULE module_bl_mynn !!for TKE in the upper PBL/cloud layer. REAL, PARAMETER :: scaleaware=1. - !>Temporary switch to deactivate the mixing of chemical species (already done when WRF_CHEM = 1) - INTEGER, PARAMETER :: bl_mynn_mixchem = 0 + !>Temporary switch to deactivate the mixing of chemical species (if WRF_CHEM = 1) + LOGICAL, PARAMETER :: mynn_chem_vertmx = .false. + LOGICAL, PARAMETER :: enh_vermix = .false. + !>Of the following teo options, use one OR the other, not both. !>Adding top-down diffusion driven by cloud-top radiative cooling - INTEGER, PARAMETER :: bl_mynn_topdown = 1 + INTEGER, PARAMETER :: bl_mynn_topdown = 0 + !>Option to activate downdrafts, from Elynn Wu (0: deactive, 1: active) + INTEGER, PARAMETER :: bl_mynn_edmf_dd = 0 !>Option to activate heating due to dissipation of TKE (to activate, set to 1.0) REAL, PARAMETER :: dheat_opt = 1. @@ -262,6 +287,9 @@ MODULE module_bl_mynn !Option to activate environmental subsidence in mass-flux scheme LOGICAL, PARAMETER :: env_subs = .true. + !Option to switch flux-profile relationship for surface (from Puhales et al. 2020) + INTEGER, PARAMETER :: bl_mynn_stfunc = 1 + !option to print out more stuff for debugging purposes LOGICAL, PARAMETER :: debug_code = .false. @@ -294,7 +322,6 @@ MODULE module_bl_mynn !JOE & JAYMES'S mods ! ! Mixing Length Options -!\authors Joe and Jaymes ! specifed through namelist: bl_mynn_mixlength ! added: 16 Apr 2015 ! @@ -462,7 +489,7 @@ SUBROUTINE mym_initialize ( & & dz, dx, zw, & & u, v, thl, qw, & ! & ust, rmo, pmz, phh, flt, flq, & - & zi, theta, sh, & + & zi, theta, sh, sm, & & ust, rmo, el, & & Qke, Tsq, Qsq, Cov, Psig_bl, cldfra_bl1D, & & bl_mynn_mixlength, & @@ -503,10 +530,10 @@ SUBROUTINE mym_initialize ( & END DO ! !> - Call mym_level2() to calculate the stability functions at level 2. - CALL mym_level2 ( kts,kte,& - & dz, & - & u, v, thl, qw, & - & ql, vt, vq, & + CALL mym_level2 ( kts,kte, & + & dz, & + & u, v, thl, qw, & + & ql, vt, vq, & & dtl, dqw, dtv, gm, gh, sm, sh ) ! ! ** Preliminary setting ** @@ -661,10 +688,10 @@ END SUBROUTINE mym_initialize !!\param sh stability function for heat, at Level 2 !!\section gen_mym_level2 GSD MYNN-EDMF mym_level2 General Algorithm !! @ { - SUBROUTINE mym_level2 (kts,kte,& - & dz, & - & u, v, thl, qw, & - & ql, vt, vq, & + SUBROUTINE mym_level2 (kts,kte, & + & dz, & + & u, v, thl, qw, & + & ql, vt, vq, & & dtl, dqw, dtv, gm, gh, sm, sh ) ! !------------------------------------------------------------------- @@ -687,7 +714,7 @@ SUBROUTINE mym_level2 (kts,kte,& REAL :: rfc,f1,f2,rf1,rf2,smc,shc,& &ri1,ri2,ri3,ri4,duz,dtz,dqz,vtt,vqq,dtq,dzk,afk,abk,ri,rf - REAL :: a2den + REAL :: a2fac ! ev = 2.5e6 ! tv0 = 0.61*tref @@ -719,6 +746,7 @@ SUBROUTINE mym_level2 (kts,kte,& ! vtt = 1.0 +vt(k)*abk +vt(k-1)*afk ! Beta-theta in NN09, Eq. 39 vqq = tv0 +vq(k)*abk +vq(k-1)*afk ! Beta-q + dtq = vtt*dtz +vqq*dqz ! dtl(k) = dtz @@ -734,21 +762,21 @@ SUBROUTINE mym_level2 (kts,kte,& ! ** Gradient Richardson number ** ri = -gh(k)/MAX( duz, 1.0e-10 ) - !a2den is needed for the Canuto/Kitamura mod + !a2fac is needed for the Canuto/Kitamura mod IF (CKmod .eq. 1) THEN - a2den = 1. + MAX(ri,0.0) + a2fac = 1./(1. + MAX(ri,0.0)) ELSE - a2den = 1. + 0.0 + a2fac = 1. ENDIF rfc = g1/( g1+g2 ) - f1 = b1*( g1-c1 ) +3.0*(a2/a2den)*( 1.0 -c2 )*( 1.0-c5 ) & + f1 = b1*( g1-c1 ) +3.0*a2*a2fac *( 1.0 -c2 )*( 1.0-c5 ) & & +2.0*a1*( 3.0-2.0*c2 ) f2 = b1*( g1+g2 ) -3.0*a1*( 1.0 -c2 ) rf1 = b1*( g1-c1 )/f1 rf2 = b1* g1 /f2 - smc = a1 /(a2/a2den)* f1/f2 - shc = 3.0*(a2/a2den)*( g1+g2 ) + smc = a1 /(a2*a2fac)* f1/f2 + shc = 3.0*(a2*a2fac)*( g1+g2 ) ri1 = 0.5/smc ri2 = rf1*smc @@ -756,7 +784,7 @@ SUBROUTINE mym_level2 (kts,kte,& ri4 = ri2**2 ! ** Flux Richardson number ** - rf = MIN( ri1*( ri+ri2-SQRT(ri**2-ri3*ri+ri4) ), rfc ) + rf = MIN( ri1*( ri + ri2-SQRT(ri**2 - ri3*ri + ri4) ), rfc ) ! sh (k) = shc*( rfc-rf )/( 1.0-rf ) sm (k) = smc*( rf1-rf )/( rf2-rf ) * sh(k) @@ -852,9 +880,10 @@ SUBROUTINE mym_length ( & INTEGER :: i,j,k - REAL :: afk,abk,zwk,zwk1,dzk,qdz,vflx,bv,tau_cloud,elb,els,els1,elf, & - & el_stab,el_unstab,el_mf,el_stab_mf,elb_mf,PBLH_PLUS_ENT, & - & Uonset,Ugrid,el_les + REAL :: afk,abk,zwk,zwk1,dzk,qdz,vflx,bv,tau_cloud,wstar,elb,els, & + & els1,elf,el_stab,el_unstab,el_mf,el_stab_mf,elb_mf, & + & PBLH_PLUS_ENT,Uonset,Ugrid,el_les + REAL, PARAMETER :: ctau = 1000. !constant for tau_cloud ! tv0 = 0.61*tref ! gtr = 9.81/tref @@ -1038,31 +1067,37 @@ SUBROUTINE mym_length ( & CASE (2) !Experimental mixing length formulation - Uonset = 2.5 + dz(kts)*0.1 + Uonset = 3.5 + dz(kts)*0.1 Ugrid = sqrt(u1(kts)**2 + v1(kts)**2) - cns = 3.5 * (1.0 - MIN(MAX(Ugrid - Uonset, 0.0)/10.0, 1.0)) + cns = 3.5 !JOE-test * (1.0 - MIN(MAX(Ugrid - Uonset, 0.0)/10.0, 1.0)) alp1 = 0.23 - alp2 = 0.30 + 0.3*MIN(MAX((dx - 3000.)/10000., 0.0), 1.0) - alp3 = 2.0 - alp4 = 20. !10. + alp2 = 0.30 + alp3 = 2.0 !JOE-test 2.0 + alp4 = 10.0 !JOE-test 20. !10. alp5 = alp2 !like alp2, but for free atmosphere alp6 = 50.0 !used for MF mixing length ! Impose limits on the height integration for elt and the transition layer depth !zi2=MAX(zi,minzi) - zi2=MAX(zi, 100.) - h1=MAX(0.3*zi2,mindz) - h1=MIN(h1,maxdz) ! 1/2 transition layer depth +!JOE-test +! zi2=MAX(zi, 100.) + zi2=MAX(zi, 200.) +!JOE-test +! h1=MAX(0.3*zi2,mindz) +! h1=MIN(h1,maxdz) ! 1/2 transition layer depth +! h1=MAX(0.3*zi2,100.) + h1=MAX(0.3*zi2,200.) + h1=MIN(h1,500.) h2=h1*0.5 ! 1/4 transition layer depth qtke(kts)=MAX(0.5*qke(kts),0.01) !tke at full sigma levels - qkw(kts) = SQRT(MAX(qke(kts),1.0e-10)) + qkw(kts) = SQRT(MAX(qke(kts),1.0e-4)) DO k = kts+1,kte afk = dz(k)/( dz(k)+dz(k-1) ) abk = 1.0 -afk qkw(k) = SQRT(MAX(qke(k)*abk+qke(k-1)*afk,1.0e-3)) - qtke(k) = 0.5*qkw(k) ! qkw -> TKE + qtke(k) = 0.5*qkw(k)**2 ! qkw -> TKE END DO elt = 1.0e-5 @@ -1091,18 +1126,29 @@ SUBROUTINE mym_length ( & DO k = kts+1,kte zwk = zw(k) !full-sigma levels + dzk = 0.5*( dz(k)+dz(k-1) ) cldavg = 0.5*(cldfra_bl1D(k-1)+cldfra_bl1D(k)) ! ** Length scale limited by the buoyancy effect ** IF ( dtv(k) .GT. 0.0 ) THEN - bv = SQRT( gtr*dtv(k) ) + !impose min value on bv + bv = MAX( SQRT( gtr*dtv(k) ), 0.001) !elb_mf = alp2*qkw(k) / bv & - elb_mf = MAX(alp2*qkw(k), & -! &MAX(1.-0.5*cldavg,0.0)**0.5 * alp6*edmf_a1(k)*edmf_w1(k)) / bv & - & alp6*edmf_a1(k)*edmf_w1(k)) / bv & + elb_mf = MAX(alp2*qkw(k), & + & alp6*edmf_a1(k)*edmf_w1(k)) / bv & & *( 1.0 + alp3*SQRT( vsc/( bv*elt ) ) ) - elb = MIN(alp5*qkw(k)/bv, zwk) - elf = elb/(1. + (elb/600.)) !bound free-atmos mixing length to < 600 m. + elb = MIN(MAX(alp5*qkw(k), alp6*edmf_a1(k)*edmf_w1(k))/bv, zwk) +! elf = elb/(1. + (elb/600.)) !bound free-atmos mixing length to < 600 m. + +!orig: tau_cloud = MIN(MAX(0.5*zi/((gtr*zi*MAX(vflx,1.0e-4))**onethird),30.),150.) + wstar = 1.25*(gtr*zi*MAX(vflx,1.0e-4))**onethird + tau_cloud = MIN(MAX(ctau * wstar/g, 30.), 150.) + !minimize influence of surface heat flux on tau far away from the PBLH. + wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 + tau_cloud = tau_cloud*(1.-wt) + 50.*wt + elf = MIN(MAX(tau_cloud*SQRT(MIN(qtke(k),40.)), & + & alp6*edmf_a1(k)*edmf_w1(k)/bv), zwk) + !IF (zwk > zi .AND. elf > 400.) THEN ! ! COMPUTE BouLac mixing length ! !CALL boulac_length0(k,kts,kte,zw,dz,qtke,thetaw,elBLmin0,elBLavg0) @@ -1121,15 +1167,22 @@ SUBROUTINE mym_length ( & ! velocity scale), except that elt is relpaced ! by zi, and zero is replaced by 1.0e-4 to ! prevent division by zero. - tau_cloud = MIN(MAX(0.5*zi/((gtr*zi*MAX(flt,1.0e-4))**onethird),50.),150.) +!orig: tau_cloud = MIN(MAX(0.5*zi/((gtr*zi*MAX(vflx,1.0e-4))**onethird),50.),150.) + wstar = 1.25*(gtr*zi*MAX(vflx,1.0e-4))**onethird + tau_cloud = MIN(MAX(ctau * wstar/g, 50.), 200.) !minimize influence of surface heat flux on tau far away from the PBLH. wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 - tau_cloud = tau_cloud*(1.-wt) + 50.*wt +! tau_cloud = tau_cloud*(1.-wt) + 50.*wt + tau_cloud = tau_cloud*(1.-wt) + MAX(100.,dzk*0.25)*wt - elb = MIN(tau_cloud*SQRT(MIN(qtke(k),30.)), zwk) - elf = elb + elb = MIN(tau_cloud*SQRT(MIN(qtke(k),40.)), zwk) + !elf = elb + elf = elb !/(1. + (elb/800.)) !bound free-atmos mixing length to < 800 m. elb_mf = elb END IF + elf = elf/(1. + (elf/800.)) !bound free-atmos mixing length to < 800 m. +! elb_mf = elb_mf/(1. + (elb_mf/800.)) !bound buoyancy mixing length to < 800 m. + elb_mf = MAX(elb_mf, 0.01) !to avoid divide-by-zero below z_m = MAX(0.,zwk - 4.) @@ -1146,8 +1199,10 @@ SUBROUTINE mym_length ( & wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 ! "el_unstab" = blended els-elt - el_unstab = els/(1. + (els1/elt)) - el(k) = MIN(el_unstab, elb_mf) +! el_unstab = els/(1. + (els1/elt)) +! el(k) = MIN(el_unstab, elb_mf) +!try squared-blending + el(k) = SQRT( els**2/(1. + (els1**2/elt**2) +(els1**2/elb_mf**2))) el(k) = el(k)*(1.-wt) + elf*wt ! include scale-awareness. For now, use simple asymptotic kz -> 12 m. @@ -1494,8 +1549,7 @@ END SUBROUTINE boulac_length ! SUBROUTINE mym_turbulence: ! ! Input variables: see subroutine mym_initialize -! levflag : <>3; Level 2.5 -! = 3; Level 3 +! closure : closure level (2.5, 2.6, or 3.0) ! ! # ql, vt, vq, qke, tsq, qsq and cov are changed to input variables. ! @@ -1542,14 +1596,14 @@ END SUBROUTINE boulac_length !! is set to True) SUBROUTINE mym_turbulence ( & & kts,kte, & - & levflag, & + & closure, & & dz, dx, zw, & & u, v, thl, ql, qw, & & qke, tsq, qsq, cov, & & vt, vq, & & rmo, flt, flq, & & zi,theta, & - & sh, & + & sh, sm, & & El, & & Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc, & & qWT1D,qSHEAR1D,qBUOY1D,qDISS1D, & @@ -1568,7 +1622,8 @@ SUBROUTINE mym_turbulence ( & # define kte HARDCODE_VERTICAL #endif - INTEGER, INTENT(IN) :: levflag,bl_mynn_mixlength,bl_mynn_edmf + INTEGER, INTENT(IN) :: bl_mynn_mixlength,bl_mynn_edmf + REAL, INTENT(IN) :: closure REAL, DIMENSION(kts:kte), INTENT(in) :: dz REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw REAL, INTENT(in) :: rmo,flt,flq,Psig_bl,Psig_shcu,dx @@ -1596,10 +1651,10 @@ SUBROUTINE mym_turbulence ( & REAL :: zi, cldavg REAL, DIMENSION(kts:kte), INTENT(in) :: theta - REAL :: a2den, duz, ri, HLmod !JOE-Canuto/Kitamura mod -!JOE-stability criteria for cw - REAL:: auh,aum,adh,adm,aeh,aem,Req,Rsl,Rsl2 -!JOE-end + REAL :: a2fac, duz, ri !JOE-Canuto/Kitamura mod + + REAL:: auh,aum,adh,adm,aeh,aem,Req,Rsl,Rsl2,& + gmelq,sm20,sh20,sm25max,sh25max,sm25min,sh25min DOUBLE PRECISION q2sq, t2sq, r2sq, c2sq, elsq, gmel, ghel DOUBLE PRECISION q3sq, t3sq, r3sq, c3sq, dlsq, qdiv @@ -1608,7 +1663,8 @@ SUBROUTINE mym_turbulence ( & ! Stochastic INTEGER, INTENT(IN) :: spp_pbl REAL, DIMENSION(KTS:KTE) :: rstoch_col - REAL :: prlimit + REAL :: Prnum + REAL, PARAMETER :: Prlimit = 10.0 ! @@ -1624,11 +1680,11 @@ SUBROUTINE mym_turbulence ( & ! e5c = 6.0*a1*a1 ! - CALL mym_level2 (kts,kte,& - & dz, & - & u, v, thl, qw, & - & ql, vt, vq, & - & dtl, dqw, dtv, gm, gh, sm, sh ) + CALL mym_level2 (kts,kte, & + & dz, & + & u, v, thl, qw, & + & ql, vt, vq, & + & dtl, dqw, dtv, gm, gh, sm, sh ) ! CALL mym_length ( & & kts,kte, & @@ -1648,20 +1704,35 @@ SUBROUTINE mym_turbulence ( & afk = dz(k)/( dz(k)+dz(k-1) ) abk = 1.0 -afk elsq = el (k)**2 - q2sq = b1*elsq*( sm(k)*gm(k)+sh(k)*gh(k) ) q3sq = qkw(k)**2 - -!JOE-Canuto/Kitamura mod + q2sq = b1*elsq*( sm(k)*gm(k)+sh(k)*gh(k) ) + !Remove possiblity of contamination due to spikes, but + !allow for very large variations - no impact on idealized cases +! elsq = MIN(MAX(elsq,0.1), 160000.) !max el = 400 m +! q3sq = MIN(MAX(q3sq,0.01), 75.) !max tke = 75 m2/s2 +! q2sq = MIN(MAX(q2sq,0.01), 75.) + !end constraints + sh20 = MAX(sh(k), 1e-6) + sm20 = MAX(sm(k), 1e-6) + sh(k)= MAX(sh(k), 1e-6) + + !Canuto/Kitamura mod duz = ( u(k)-u(k-1) )**2 +( v(k)-v(k-1) )**2 duz = duz /dzk**2 ! ** Gradient Richardson number ** ri = -gh(k)/MAX( duz, 1.0e-10 ) IF (CKmod .eq. 1) THEN - a2den = 1. + MAX(ri,0.0) + a2fac = 1./(1. + MAX(ri,0.0)) ELSE - a2den = 1. + 0.0 + a2fac = 1. ENDIF -!JOE-end + !end Canuto/Kitamura mod + + !level 2.0 Prandtl number + !Prnum = MIN(sm20/sh20, 4.0) + !The form of Zilitinkevich et al. (2006) but modified + !following Esau and Grachev (2007, Wind Eng) + Prnum = MIN(0.8 + 4.0*MAX(ri,-0.013), Prlimit) ! ! Modified: Dec/22/2005, from here, (dlsq -> elsq) gmel = gm (k)*elsq @@ -1671,7 +1742,7 @@ SUBROUTINE mym_turbulence ( & ! Level 2.0 debug prints IF ( debug_code ) THEN IF (sh(k)<0.0 .OR. sm(k)<0.0) THEN - print*,"MYNN; mym_turbulence2.0; sh=",sh(k)," k=",k + print*,"MYNN; mym_turbulence 2.0; sh=",sh(k)," k=",k print*," gm=",gm(k)," gh=",gh(k)," sm=",sm(k) print*," q2sq=",q2sq," q3sq=",q3sq," q3/q2=",q3sq/q2sq print*," qke=",qke(k)," el=",el(k)," ri=",ri @@ -1679,14 +1750,6 @@ SUBROUTINE mym_turbulence ( & ENDIF ENDIF -!JOE-Apply Helfand & Labraga stability check for all Ric -! when CKmod == 1. (currently not forced below) - IF (CKmod .eq. 1) THEN - HLmod = q2sq -1. - ELSE - HLmod = q3sq - ENDIF - ! ** Since qkw is set to more than 0.0, q3sq > 0.0. ** !JOE-test new stability criteria in level 2.5 (as well as level 3) - little/no impact @@ -1696,58 +1759,85 @@ SUBROUTINE mym_turbulence ( & !JOE-end IF ( q3sq .LT. q2sq ) THEN - !IF ( HLmod .LT. q2sq ) THEN !Apply Helfand & Labraga mod qdiv = SQRT( q3sq/q2sq ) !HL89: (1-alfa) - sm(k) = sm(k) * qdiv - sh(k) = sh(k) * qdiv + ! sm(k) = sm(k) * qdiv + ! sh(k) = sh(k) * qdiv ! !JOE-Canuto/Kitamura mod !e1 = q3sq - e1c*ghel * qdiv**2 !e2 = q3sq - e2c*ghel * qdiv**2 !e3 = e1 + e3c*ghel * qdiv**2 !e4 = e1 - e4c*ghel * qdiv**2 - e1 = q3sq - e1c*ghel/a2den * qdiv**2 - e2 = q3sq - e2c*ghel/a2den * qdiv**2 - e3 = e1 + e3c*ghel/(a2den**2) * qdiv**2 - e4 = e1 - e4c*ghel/a2den * qdiv**2 + e1 = q3sq - e1c*ghel*a2fac * qdiv**2 + e2 = q3sq - e2c*ghel*a2fac * qdiv**2 + e3 = e1 + e3c*ghel*a2fac**2 * qdiv**2 + e4 = e1 - e4c*ghel*a2fac * qdiv**2 eden = e2*e4 + e3*e5c*gmel * qdiv**2 eden = MAX( eden, 1.0d-20 ) + + !Use level 2.5 stability functions + !sm(k) = q3sq*a1*( e3-3.0*c1*e4 )/eden + !!JOE-Canuto/Kitamura mod + !!sh(k) = q3sq*a2*( e2+3.0*c1*e5c*gmel )/eden + ! sh(k) = q3sq*(a2*a2fac)*( e2+3.0*c1*e5c*gmel )/eden + sm(k) = Prnum*sh(k) ELSE !JOE-Canuto/Kitamura mod !e1 = q3sq - e1c*ghel !e2 = q3sq - e2c*ghel !e3 = e1 + e3c*ghel !e4 = e1 - e4c*ghel - e1 = q3sq - e1c*ghel/a2den - e2 = q3sq - e2c*ghel/a2den - e3 = e1 + e3c*ghel/(a2den**2) - e4 = e1 - e4c*ghel/a2den + e1 = q3sq - e1c*ghel*a2fac + e2 = q3sq - e2c*ghel*a2fac + e3 = e1 + e3c*ghel*a2fac**2 + e4 = e1 - e4c*ghel*a2fac eden = e2*e4 + e3*e5c*gmel eden = MAX( eden, 1.0d-20 ) qdiv = 1.0 - sm(k) = q3sq*a1*( e3-3.0*c1*e4 )/eden - !JOE-Canuto/Kitamura mod - !sh(k) = q3sq*a2*( e2+3.0*c1*e5c*gmel )/eden - sh(k) = q3sq*(a2/a2den)*( e2+3.0*c1*e5c*gmel )/eden + !Use level 2.5 stability functions + !sm(k) = q3sq*a1*( e3-3.0*c1*e4 )/eden + !!JOE-Canuto/Kitamura mod + !!sh(k) = q3sq*a2*( e2+3.0*c1*e5c*gmel )/eden + sh(k) = q3sq*(a2*a2fac)*( e2+3.0*c1*e5c*gmel )/eden + sm(k) = Prnum*sh(k) END IF !end Helfand & Labraga check + !Impose broad limits on Sh and Sm from HL88: + gmelq = MAX(gmel/q3sq, 1e-8) + sm25max = MIN(sm20*3.0, SQRT(.1936/gmelq)) + sh25max = MIN(sh20*3.0, 0.76*b2) + sm25min = MAX(sm20*0.1, 1e-6) + sh25min = MAX(sh20*0.1, 1e-6) + !JOE: Level 2.5 debug prints ! HL88 , lev2.5 criteria from eqs. 3.17, 3.19, & 3.20 IF ( debug_code ) THEN - IF (sh(k)<0.0 .OR. sm(k)<0.0 .OR. & - sh(k) > 0.76*b2 .or. (sm(k)**2*gm(k) .gt. .44**2)) THEN - print*,"MYNN; mym_turbulence2.5; sh=",sh(k)," k=",k - print*," gm=",gm(k)," gh=",gh(k)," sm=",sm(k) - print*," q2sq=",q2sq," q3sq=",q3sq," q3/q2=",q3sq/q2sq - print*," qke=",qke(k)," el=",el(k)," ri=",ri + IF ((sh(k)sh25max .OR. sm(k)>sm25max) .AND. ri < 0.5) THEN + print*,"MYNN; mym_turbulence2.5: k=",k + print*," sm=",sm(k)," sh=",sh(k) + print*," ri=",ri," Pr=",sm(k)/MAX(sh(k),1e-8) + print*," gm=",gm(k)," gh=",gh(k) + print*," q2sq=",q2sq," q3sq=",q3sq, q3sq/q2sq + print*," qke=",qke(k)," el=",el(k) print*," PBLH=",zi," u=",u(k)," v=",v(k) + print*," SMnum=",q3sq*a1*( e3-3.0*c1*e4)," SMdenom=",eden + print*," SHnum=",q3sq*(a2*a2fac)*( e2+3.0*c1*e5c*gmel ),& + " SHdenom=",eden ENDIF ENDIF + !Enforce constraints for level 2.5 functions +! IF ( sh(k) > sh25max ) sh(k) = sh25max +! IF ( sh(k) < sh25min ) sh(k) = sh25min +!! IF ( sm(k) > sm25max ) sm(k) = sm25max +!! IF ( sm(k) < sm25min ) sm(k) = sm25min +! sm(k) = Prnum*sh(k) + ! ** Level 3 : start ** - IF ( levflag .EQ. 3 ) THEN + IF ( closure .GE. 3.0 ) THEN t2sq = qdiv*b2*elsq*sh(k)*dtl(k)**2 r2sq = qdiv*b2*elsq*sh(k)*dqw(k)**2 c2sq = qdiv*b2*elsq*sh(k)*dtl(k)*dqw(k) @@ -1760,6 +1850,7 @@ SUBROUTINE mym_turbulence ( & ! vtt = 1.0 +vt(k)*abk +vt(k-1)*afk vqq = tv0 +vq(k)*abk +vq(k-1)*afk + t2sq = vtt*t2sq +vqq*c2sq r2sq = vtt*c2sq +vqq*r2sq c2sq = MAX( vtt*t2sq+vqq*r2sq, 0.0d0 ) @@ -1774,18 +1865,18 @@ SUBROUTINE mym_turbulence ( & IF ( q3sq/dlsq .LT. -gh(k) ) q3sq = -dlsq*gh(k) ! ! ** Limitation on c3sq (0.12 =< cw =< 0.76) ** - !JOE: use Janjic's (2001; p 13-17) methodology (eqs 4.11-414 and 5.7-5.10) + ! Use Janjic's (2001; p 13-17) methodology (eqs 4.11-414 and 5.7-5.10) ! to calculate an exact limit for c3sq: - auh = 27.*a1*((a2/a2den)**2)*b2*(g/tref)**2 - aum = 54.*(a1**2)*(a2/a2den)*b2*c1*(g/tref) - adh = 9.*a1*((a2/a2den)**2)*(12.*a1 + 3.*b2)*(g/tref)**2 - adm = 18.*(a1**2)*(a2/a2den)*(b2 - 3.*(a2/a2den))*(g/tref) + auh = 27.*a1*((a2*a2fac)**2)*b2*(g/tref)**2 + aum = 54.*(a1**2)*(a2*a2fac)*b2*c1*(g/tref) + adh = 9.*a1*((a2*a2fac)**2)*(12.*a1 + 3.*b2)*(g/tref)**2 + adm = 18.*(a1**2)*(a2*a2fac)*(b2 - 3.*(a2*a2fac))*(g/tref) - aeh = (9.*a1*((a2/a2den)**2)*b1 +9.*a1*((a2/a2den)**2)* & + aeh = (9.*a1*((a2*a2fac)**2)*b1 +9.*a1*((a2*a2fac)**2)* & (12.*a1 + 3.*b2))*(g/tref) - aem = 3.*a1*(a2/a2den)*b1*(3.*(a2/a2den) + 3.*b2*c1 + & + aem = 3.*a1*(a2*a2fac)*b1*(3.*(a2*a2fac) + 3.*b2*c1 + & (18.*a1*c1 - b2)) + & - (18.)*(a1**2)*(a2/a2den)*(b2 - 3.*(a2/a2den)) + (18.)*(a1**2)*(a2*a2fac)*(b2 - 3.*(a2*a2fac)) Req = -aeh/aem Rsl = (auh + aum*Req)/(3.*adh + 3.*adm*Req) @@ -1803,23 +1894,23 @@ SUBROUTINE mym_turbulence ( & !e2 = q3sq - e2c*ghel * qdiv**2 !e3 = q3sq + e3c*ghel * qdiv**2 !e4 = q3sq - e4c*ghel * qdiv**2 - e2 = q3sq - e2c*ghel/a2den * qdiv**2 - e3 = q3sq + e3c*ghel/(a2den**2) * qdiv**2 - e4 = q3sq - e4c*ghel/a2den * qdiv**2 + e2 = q3sq - e2c*ghel*a2fac * qdiv**2 + e3 = q3sq + e3c*ghel*a2fac**2 * qdiv**2 + e4 = q3sq - e4c*ghel*a2fac * qdiv**2 eden = e2*e4 + e3 *e5c*gmel * qdiv**2 !JOE-Canuto/Kitamura mod !wden = cc3*gtr**2 * dlsq**2/elsq * qdiv**2 & ! & *( e2*e4c - e3c*e5c*gmel * qdiv**2 ) wden = cc3*gtr**2 * dlsq**2/elsq * qdiv**2 & - & *( e2*e4c/a2den - e3c*e5c*gmel/(a2den**2) * qdiv**2 ) + & *( e2*e4c*a2fac - e3c*e5c*gmel*a2fac**2 * qdiv**2 ) IF ( wden .NE. 0.0 ) THEN !JOE: test dynamic limits - !clow = q3sq*( 0.12-cw25 )*eden/wden - !cupp = q3sq*( 0.76-cw25 )*eden/wden - clow = q3sq*( Rsl -cw25 )*eden/wden - cupp = q3sq*( Rsl2-cw25 )*eden/wden + clow = q3sq*( 0.12-cw25 )*eden/wden + cupp = q3sq*( 0.76-cw25 )*eden/wden +!JOE clow = q3sq*( Rsl -cw25 )*eden/wden +!JOE cupp = q3sq*( Rsl2-cw25 )*eden/wden ! IF ( wden .GT. 0.0 ) THEN c3sq = MIN( MAX( c3sq, c2sq+clow ), c2sq+cupp ) @@ -1834,7 +1925,7 @@ SUBROUTINE mym_turbulence ( & !JOE-Canuto/Kitamura mod !e6c = 3.0*a2*cc3*gtr * dlsq/elsq - e6c = 3.0*(a2/a2den)*cc3*gtr * dlsq/elsq + e6c = 3.0*(a2*a2fac)*cc3*gtr * dlsq/elsq !============================ ! ** for Gamma_theta ** @@ -1863,8 +1954,8 @@ SUBROUTINE mym_turbulence ( & !JOE-Canuto/Kitamura mod !smd = dlsq*enum*gtr/eden * qdiv**2 * (e3c+e4c)*a1/a2 - smd = dlsq*enum*gtr/eden * qdiv**2 * (e3c/(a2den**2) + & - & e4c/a2den)*a1/(a2/a2den) + smd = dlsq*enum*gtr/eden * qdiv**2 * (e3c*a2fac**2 + & + & e4c*a2fac)*a1/(a2*a2fac) gamv = e1 *enum*gtr/eden sm(k) = sm(k) +smd @@ -1893,15 +1984,19 @@ SUBROUTINE mym_turbulence ( & gamq = 0.0 gamv = 0.0 END IF + +! Prandtl number limit +! Prlimit = 4.0 +! IF (sm(k) > sh(k)*Prlimit) sm(k) = sh(k)*Prlimit ! ! Add min background stability function (diffusivity) within model levels ! with active plumes and low cloud fractions. cldavg = 0.5*(cldfra_bl1D(k-1) + cldfra_bl1D(k)) IF (edmf_a1(k) > 0.001 .OR. cldavg > 0.02) THEN cldavg = 0.5*(cldfra_bl1D(k-1) + cldfra_bl1D(k)) - !sm(k) = MAX(sm(k), MAX(1.0 - 2.0*cldavg, 0.0)**0.33 * 0.03 * & + !sm(k) = MAX(sm(k), MAX(1.0 - 2.0*cldavg, 0.0)**0.33 * 0.03 * & ! & MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) - !sh(k) = MAX(sh(k), MAX(1.0 - 2.0*cldavg, 0.0)**0.33 * 0.03 * & + !sh(k) = MAX(sh(k), MAX(1.0 - 2.0*cldavg, 0.0)**0.33 * 0.03 * & ! & MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) ! for mass-flux columns @@ -1910,7 +2005,6 @@ SUBROUTINE mym_turbulence ( & ! for clouds sm(k) = MAX(sm(k), 0.03*MIN(cldavg,1.0) ) sh(k) = MAX(sh(k), 0.03*MIN(cldavg,1.0) ) - ENDIF ! elq = el(k)*qkw(k) @@ -1919,8 +2013,8 @@ SUBROUTINE mym_turbulence ( & ! Production of TKE (pdk), T-variance (pdt), ! q-variance (pdq), and covariance (pdc) pdk(k) = elq*( sm(k)*gm(k) & - & +sh(k)*gh(k)+gamv ) + & ! JAYMES TKE - & TKEprodTD(k) ! JOE-top-down + & +sh(k)*gh(k)+gamv ) + & + & TKEprodTD(k) pdt(k) = elh*( sh(k)*dtl(k)+gamt )*dtl(k) pdq(k) = elh*( sh(k)*dqw(k)+gamq )*dqw(k) pdc(k) = elh*( sh(k)*dtl(k)+gamt )& @@ -1942,41 +2036,35 @@ SUBROUTINE mym_turbulence ( & IF ( bl_mynn_tkebudget == 1) THEN !TKE BUDGET - dudz = ( u(k)-u(k-1) )/dzk - dvdz = ( v(k)-v(k-1) )/dzk - dTdz = ( thl(k)-thl(k-1) )/dzk - - upwp = -elq*sm(k)*dudz - vpwp = -elq*sm(k)*dvdz - Tpwp = -elq*sh(k)*dTdz - Tpwp = SIGN(MAX(ABS(Tpwp),1.E-6),Tpwp) - - IF ( k .EQ. kts+1 ) THEN - qWT1D(kts)=0. - q3sq_old =0. - qWTP_old =0. - !** Limitation on q, instead of L/q ** - dlsq1 = MAX(el(kts)**2,1.0) - IF ( q3sq_old/dlsq1 .LT. -gh(k) ) q3sq_old = -dlsq1*gh(k) - ENDIF +! dudz = ( u(k)-u(k-1) )/dzk +! dvdz = ( v(k)-v(k-1) )/dzk +! dTdz = ( thl(k)-thl(k-1) )/dzk + +! upwp = -elq*sm(k)*dudz +! vpwp = -elq*sm(k)*dvdz +! Tpwp = -elq*sh(k)*dTdz +! Tpwp = SIGN(MAX(ABS(Tpwp),1.E-6),Tpwp) - !!!Vertical Transport Term - qWTP_new = elq*Sqfac*sm(k)*(q3sq - q3sq_old)/dzk - qWT1D(k) = 0.5*(qWTP_new - qWTP_old)/dzk - qWTP_old = elq*Sqfac*sm(k)*(q3sq - q3sq_old)/dzk - q3sq_old = q3sq + +!! TKE budget (Puhales, 2020, WRF 4.2.1) << EOB !!!Shear Term !!!qSHEAR1D(k)=-(upwp*dudz + vpwp*dvdz) - qSHEAR1D(k) = elq*sm(k)*gm(k) + qSHEAR1D(k) = elq*sm(k)*gm(k) !staggared !!!Buoyancy Term !!!qBUOY1D(k)=g*Tpwp/thl(k) !qBUOY1D(k)= elq*(sh(k)*gh(k) + gamv) - qBUOY1D(k) = elq*(sh(k)*(-dTdz*g/thl(k)) + gamv) + !qBUOY1D(k) = elq*(sh(k)*(-dTdz*g/thl(k)) + gamv) !! ORIGINAL CODE + + !! Buoyncy term takes the TKEprodTD(k) production now + qBUOY1D(k) = elq*(sh(k)*gh(k)+gamv)+TKEprodTD(k) !staggared + !! - !!!Dissipation Term - qDISS1D(k) = (q3sq**(3./2.))/(b1*MAX(el(k),1.)) + !!!Dissipation Term (now it evaluated on mym_predict) + !qDISS1D(k) = (q3sq**(3./2.))/(b1*MAX(el(k),1.)) !! ORIGINAL CODE + + !! >> EOB ENDIF END DO @@ -1999,13 +2087,6 @@ SUBROUTINE mym_turbulence ( & END DO ! - IF ( bl_mynn_tkebudget == 1) THEN - !JOE-TKE BUDGET - qWT1D(kts)=0. - qSHEAR1D(kts)=qSHEAR1D(kts+1) - qBUOY1D(kts)=qBUOY1D(kts+1) - qDISS1D(kts)=qDISS1D(kts+1) - ENDIF if (spp_pbl==1) then DO k = kts,kte @@ -2069,15 +2150,15 @@ END SUBROUTINE mym_turbulence !>\ingroup gsd_mynn_edmf !! This subroutine predicts the turbulent quantities at the next step. SUBROUTINE mym_predict (kts,kte, & - & levflag, & + & closure, & & delt, & & dz, & & ust, flt, flq, pmz, phh, & - & el, dfq, & + & el, dfq, rho, & & pdk, pdt, pdq, pdc, & & qke, tsq, qsq, cov, & - & s_aw,s_awqke,bl_mynn_edmf_tke & - &) + & s_aw,s_awqke,bl_mynn_edmf_tke, & + & qWT1D, qDISS1D,bl_mynn_tkebudget) !! TKE budget (Puhales, 2020) !------------------------------------------------------------------- INTEGER, INTENT(IN) :: kts,kte @@ -2087,22 +2168,30 @@ SUBROUTINE mym_predict (kts,kte, & # define kte HARDCODE_VERTICAL #endif - INTEGER, INTENT(IN) :: levflag + REAL, INTENT(IN) :: closure INTEGER, INTENT(IN) :: bl_mynn_edmf_tke REAL, INTENT(IN) :: delt - REAL, DIMENSION(kts:kte), INTENT(IN) :: dz, dfq,el + REAL, DIMENSION(kts:kte), INTENT(IN) :: dz, dfq, el, rho REAL, DIMENSION(kts:kte), INTENT(INOUT) :: pdk, pdt, pdq, pdc REAL, INTENT(IN) :: flt, flq, ust, pmz, phh REAL, DIMENSION(kts:kte), INTENT(INOUT) :: qke,tsq, qsq, cov ! WA 8/3/15 REAL, DIMENSION(kts:kte+1), INTENT(INOUT) :: s_awqke,s_aw - + + !! TKE budget (Puhales, 2020, WRF 4.2.1) << EOB + REAL, DIMENSION(kts:kte), INTENT(OUT) :: qWT1D, qDISS1D + INTEGER, INTENT(IN) :: bl_mynn_tkebudget + REAL, DIMENSION(kts:kte) :: tke_up,dzinv + !! >> EOB + INTEGER :: k REAL, DIMENSION(kts:kte) :: qkw, bp, rp, df3q REAL :: vkz,pdk1,phm,pdt1,pdq1,pdc1,b1l,b2l,onoff REAL, DIMENSION(kts:kte) :: dtz REAL, DIMENSION(kts:kte) :: a,b,c,d,x + REAL, DIMENSION(kts:kte) :: rhoinv + REAL, DIMENSION(kts:kte+1) :: rhoz,kqdz,kmdz ! REGULATE THE MOMENTUM MIXING FROM THE MASS-FLUX SCHEME (on or off) IF (bl_mynn_edmf_tke == 0) THEN @@ -2123,6 +2212,33 @@ SUBROUTINE mym_predict (kts,kte, & dtz(k)=delt/dz(k) END DO ! +!JOE-add conservation + stability criteria + !Prepare "constants" for diffusion equation. + !khdz = rho*Kh/dz = rho*dfh + rhoz(kts) =rho(kts) + rhoinv(kts)=1./rho(kts) + kqdz(kts) =rhoz(kts)*df3q(kts) + kmdz(kts) =rhoz(kts)*dfq(kts) + DO k=kts+1,kte + rhoz(k) =(rho(k)*dz(k-1) + rho(k-1)*dz(k))/(dz(k-1)+dz(k)) + rhoz(k) = MAX(rhoz(k),1E-4) + rhoinv(k)=1./MAX(rho(k),1E-4) + kqdz(k) = rhoz(k)*df3q(k) ! for TKE + kmdz(k) = rhoz(k)*dfq(k) ! for T'2, q'2, and T'q' + ENDDO + rhoz(kte+1)=rhoz(kte) + kqdz(kte+1)=rhoz(kte+1)*df3q(kte) + kmdz(kte+1)=rhoz(kte+1)*dfq(kte) + + !stability criteria for mf + DO k=kts+1,kte-1 + kqdz(k) = MAX(kqdz(k), 0.5*rho(k)* s_aw(k)) + kqdz(k) = MAX(kqdz(k), -0.5*rho(k)*(s_aw(k)-s_aw(k+1))) + kmdz(k) = MAX(kmdz(k), 0.5*rho(k)* s_aw(k)) + kmdz(k) = MAX(kmdz(k), -0.5*rho(k)*(s_aw(k)-s_aw(k+1))) + ENDDO +!JOE-end conservation mods + pdk1 = 2.0*ust**3*pmz/( vkz ) phm = 2.0/ust *phh/( vkz ) pdt1 = phm*flt**2 @@ -2159,11 +2275,17 @@ SUBROUTINE mym_predict (kts,kte, & ! c(k-kts+1)=-dtz(k)*df3q(k+1) ! d(k-kts+1)=rp(k)*delt + qke(k) ! WA 8/3/15 add EDMF contribution - a(k-kts+1)=-dtz(k)*df3q(k) + 0.5*dtz(k)*s_aw(k)*onoff - b(k-kts+1)=1. + dtz(k)*(df3q(k)+df3q(k+1)) & - + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*onoff + bp(k)*delt - c(k-kts+1)=-dtz(k)*df3q(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff - d(k-kts+1)=rp(k)*delt + qke(k) + dtz(k)*(s_awqke(k)-s_awqke(k+1))*onoff +! a(k)= - dtz(k)*df3q(k) + 0.5*dtz(k)*s_aw(k)*onoff +! b(k)=1. + dtz(k)*(df3q(k)+df3q(k+1)) & +! + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*onoff + bp(k)*delt +! c(k)= - dtz(k)*df3q(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff +! d(k)=rp(k)*delt + qke(k) + dtz(k)*(s_awqke(k)-s_awqke(k+1))*onoff +!JOE 8/22/20 improve conservation + a(k)= - dtz(k)*kqdz(k)*rhoinv(k) + 0.5*dtz(k)*s_aw(k)*onoff + b(k)=1. + dtz(k)*(kqdz(k)+kqdz(k+1))*rhoinv(k) & + & + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*onoff + bp(k)*delt + c(k)= - dtz(k)*kqdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*onoff + d(k)=rp(k)*delt + qke(k) + dtz(k)*(s_awqke(k)-s_awqke(k+1))*onoff ENDDO !! DO k=kts+1,kte-1 @@ -2179,73 +2301,96 @@ SUBROUTINE mym_predict (kts,kte, & d(kte)=0. ! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,x) + CALL tridiag3(kte,a,b,c,d,x) DO k=kts,kte ! qke(k)=max(d(k-kts+1), 1.e-4) qke(k)=max(x(k), 1.e-4) + qke(k)=min(qke(k), 150.) ENDDO + +!! TKE budget (Puhales, 2020, WRF 4.2.1) << EOB + IF (bl_mynn_tkebudget == 1) THEN + !! TKE Vertical transport << EOBvt + tke_up=0.5*qke + dzinv=1./dz + k=kts + qWT1D(k)=dzinv(k)*((kqdz(k+1)*(tke_up(k+1)-tke_up(k))-kqdz(k)*tke_up(k))+& + 0.5*(s_aw(k+1)*tke_up(k+1)+(s_aw(k+1)-s_aw(k))*tke_up(k)+(s_awqke(k)-s_awqke(k+1)))*onoff) !unstaggered + DO k=kts+1,kte-1 + qWT1D(k)=dzinv(k)*((kqdz(k+1)*(tke_up(k+1)-tke_up(k))-kqdz(k)*(tke_up(k)-tke_up(k-1)))+& + 0.5*(s_aw(k+1)*tke_up(k+1)+(s_aw(k+1)-s_aw(k))*tke_up(k)-s_aw(k)*tke_up(k-1)+(s_awqke(k)-s_awqke(k+1)))*onoff) !unstaggered + ENDDO + k=kte + qWT1D(k)=dzinv(k)*(-kqdz(k)*(tke_up(k)-tke_up(k-1))+0.5*(-s_aw(k)*tke_up(k)-s_aw(k)*tke_up(k-1)+s_awqke(k))*onoff) !unstaggared + !! >> EOBvt + qDISS1D=bp*tke_up !! TKE dissipation rate !unstaggered + END IF +!! >> EOB + + IF ( closure > 2.5 ) THEN - IF ( levflag .EQ. 3 ) THEN -! -! Modified: Dec/22/2005, from here -! ** dfq for the scalar variance is 1.0*dfm. ** -! CALL coefvu ( dfq, 1.0 ) make change here -! Modified: Dec/22/2005, up to here -! -! ** Prediction of the temperature variance ** -!! DO k = kts+1,kte-1 + ! ** Prediction of the moisture variance ** DO k = kts,kte-1 b2l = b2*0.5*( el(k+1)+el(k) ) bp(k) = 2.*qkw(k) / b2l - rp(k) = pdt(k+1) + pdt(k) + rp(k) = pdq(k+1) +pdq(k) END DO - -!zero gradient for tsq at bottom and top - -!! a(1)=0. -!! b(1)=1. -!! c(1)=-1. -!! d(1)=0. -! Since dfq(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*dfq(k+1)+bp(k)*delt. + !zero gradient for qsq at bottom and top + !a(1)=0. + !b(1)=1. + !c(1)=-1. + !d(1)=0. + + ! Since dfq(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*dfq(k+1)+bp(k)*delt. DO k=kts,kte-1 - a(k-kts+1)=-dtz(k)*dfq(k) - b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))+bp(k)*delt - c(k-kts+1)=-dtz(k)*dfq(k+1) - d(k-kts+1)=rp(k)*delt + tsq(k) + a(k)= - dtz(k)*kmdz(k)*rhoinv(k) + b(k)=1. + dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + bp(k)*delt + c(k)= - dtz(k)*kmdz(k+1)*rhoinv(k) + d(k)=rp(k)*delt + qsq(k) ENDDO -!! DO k=kts+1,kte-1 -!! a(k-kts+1)=-dtz(k)*dfq(k) -!! b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1)) -!! c(k-kts+1)=-dtz(k)*dfq(k+1) -!! d(k-kts+1)=rp(k)*delt + tsq(k) - tsq(k)*bp(k)*delt -!! ENDDO - a(kte)=-1. !0. b(kte)=1. c(kte)=0. d(kte)=0. -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,x) - + !CALL tridiag(kte,a,b,c,d) + CALL tridiag3(kte,a,b,c,d,x) + DO k=kts,kte -! tsq(k)=d(k-kts+1) - tsq(k)=x(k) + !qsq(k)=d(k-kts+1) + qsq(k)=MAX(x(k),1e-12) ENDDO - -! ** Prediction of the moisture variance ** + ELSE + !level 2.5 - use level 2 diagnostic + DO k = kts,kte-1 + IF ( qkw(k) .LE. 0.0 ) THEN + b2l = 0.0 + ELSE + b2l = b2*0.25*( el(k+1)+el(k) )/qkw(k) + END IF + qsq(k) = b2l*( pdq(k+1)+pdq(k) ) + END DO + qsq(kte)=qsq(kte-1) + END IF +!!!!!!!!!!!!!!!!!!!!!!end level 2.6 + + IF ( closure .GE. 3.0 ) THEN +! +! ** dfq for the scalar variance is 1.0*dfm. ** +! +! ** Prediction of the temperature variance ** !! DO k = kts+1,kte-1 DO k = kts,kte-1 b2l = b2*0.5*( el(k+1)+el(k) ) bp(k) = 2.*qkw(k) / b2l - rp(k) = pdq(k+1) +pdq(k) + rp(k) = pdt(k+1) + pdt(k) END DO -!zero gradient for qsq at bottom and top +!zero gradient for tsq at bottom and top !! a(1)=0. !! b(1)=1. @@ -2254,32 +2399,37 @@ SUBROUTINE mym_predict (kts,kte, & ! Since dfq(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*dfq(k+1)+bp(k)*delt. DO k=kts,kte-1 - a(k-kts+1)=-dtz(k)*dfq(k) - b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))+bp(k)*delt - c(k-kts+1)=-dtz(k)*dfq(k+1) - d(k-kts+1)=rp(k)*delt + qsq(k) + !a(k-kts+1)=-dtz(k)*dfq(k) + !b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))+bp(k)*delt + !c(k-kts+1)=-dtz(k)*dfq(k+1) + !d(k-kts+1)=rp(k)*delt + tsq(k) +!JOE 8/22/20 improve conservation + a(k)= - dtz(k)*kmdz(k)*rhoinv(k) + b(k)=1. + dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + bp(k)*delt + c(k)= - dtz(k)*kmdz(k+1)*rhoinv(k) + d(k)=rp(k)*delt + tsq(k) ENDDO !! DO k=kts+1,kte-1 !! a(k-kts+1)=-dtz(k)*dfq(k) !! b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1)) !! c(k-kts+1)=-dtz(k)*dfq(k+1) -!! d(k-kts+1)=rp(k)*delt + qsq(k) -qsq(k)*bp(k)*delt +!! d(k-kts+1)=rp(k)*delt + tsq(k) - tsq(k)*bp(k)*delt !! ENDDO a(kte)=-1. !0. b(kte)=1. c(kte)=0. d(kte)=0. - -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,x) +! CALL tridiag(kte,a,b,c,d) + CALL tridiag3(kte,a,b,c,d,x) + DO k=kts,kte -! qsq(k)=d(k-kts+1) - qsq(k)=x(k) +! tsq(k)=d(k-kts+1) + tsq(k)=x(k) ENDDO - + ! ** Prediction of the temperature-moisture covariance ** !! DO k = kts+1,kte-1 DO k = kts,kte-1 @@ -2297,10 +2447,15 @@ SUBROUTINE mym_predict (kts,kte, & ! Since dfq(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*dfq(k+1)+bp(k)*delt. DO k=kts,kte-1 - a(k-kts+1)=-dtz(k)*dfq(k) - b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))+bp(k)*delt - c(k-kts+1)=-dtz(k)*dfq(k+1) - d(k-kts+1)=rp(k)*delt + cov(k) + !a(k-kts+1)=-dtz(k)*dfq(k) + !b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))+bp(k)*delt + !c(k-kts+1)=-dtz(k)*dfq(k+1) + !d(k-kts+1)=rp(k)*delt + cov(k) +!JOE 8/22/20 improve conservation + a(k)= - dtz(k)*kmdz(k)*rhoinv(k) + b(k)=1. + dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + bp(k)*delt + c(k)= - dtz(k)*kmdz(k+1)*rhoinv(k) + d(k)=rp(k)*delt + cov(k) ENDDO !! DO k=kts+1,kte-1 @@ -2316,15 +2471,16 @@ SUBROUTINE mym_predict (kts,kte, & d(kte)=0. ! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,x) - + CALL tridiag3(kte,a,b,c,d,x) + DO k=kts,kte ! cov(k)=d(k-kts+1) cov(k)=x(k) ENDDO ELSE -!! DO k = kts+1,kte-1 + + !Not level 3 - default to level 2 diagnostic DO k = kts,kte-1 IF ( qkw(k) .LE. 0.0 ) THEN b2l = 0.0 @@ -2333,16 +2489,10 @@ SUBROUTINE mym_predict (kts,kte, & END IF ! tsq(k) = b2l*( pdt(k+1)+pdt(k) ) - qsq(k) = b2l*( pdq(k+1)+pdq(k) ) cov(k) = b2l*( pdc(k+1)+pdc(k) ) END DO -!! tsq(kts)=tsq(kts+1) -!! qsq(kts)=qsq(kts+1) -!! cov(kts)=cov(kts+1) - tsq(kte)=tsq(kte-1) - qsq(kte)=qsq(kte-1) cov(kte)=cov(kte-1) END IF @@ -2422,7 +2572,7 @@ SUBROUTINE mym_condensation (kts,kte, & cldfra_bl1D DOUBLE PRECISION :: t3sq, r3sq, c3sq - REAL :: qsl,esat,qsat,tlk,qsat_tl,dqsl,cld0,q1k,eq1,qll,& + REAL :: qsl,esat,qsat,tlk,qsat_tl,dqsl,cld0,q1k,qlk,eq1,qll,& &q2p,pt,rac,qt,t,xl,rsl,cpm,cdhdz,Fng,qww,alpha,beta,bb,& &ls_min,ls,wt,cld_factor,fac_damp,liq_frac,ql_ice,ql_water,& &low_weight @@ -2430,13 +2580,14 @@ SUBROUTINE mym_condensation (kts,kte, & REAL :: erf - !JOE: NEW VARIABLES FOR ALTERNATE SIGMA + !VARIABLES FOR ALTERNATIVE SIMGA REAL::dth,dtl,dqw,dzk,els REAL, DIMENSION(kts:kte), INTENT(IN) :: Sh,el - !JOE: variables for BL clouds - REAL::zagl,damp,PBLH2,ql_limit + !variables for SGS BL clouds + REAL :: zagl,damp,PBLH2 REAL :: lfac + INTEGER, PARAMETER :: sig_order = 2 !sigma form, 1: use state variables, 2: higher-order variables !JAYMES: variables for tropopause-height estimation REAL :: theta1, theta2, ht1, ht2 @@ -2511,6 +2662,7 @@ SUBROUTINE mym_condensation (kts,kte, & !CLOUD FRACTION. rr2 = 1/SQRT(2) = 0.707 cldfra_bl1D(k) = 0.5*( 1.0+erf( q1(k)*rr2 ) ) + q1k = q1(k) eq1 = rrp*EXP( -0.5*q1k*q1k ) qll = MAX( cldfra_bl1D(k)*q1k + eq1, 0.0 ) !ESTIMATED LIQUID WATER CONTENT (UNNORMALIZED) @@ -2523,7 +2675,7 @@ SUBROUTINE mym_condensation (kts,kte, & if(cldfra_bl1D(k)>0.01 .and. qc_bl1D(k)<1.E-6)qc_bl1D(k)=1.E-6 if(cldfra_bl1D(k)>0.01 .and. qi_bl1D(k)<1.E-8)qi_bl1D(k)=1.E-8 - !Now estimate the buiyancy flux functions + !Now estimate the buoyancy flux functions q2p = xlvcp/exner(k) pt = thl(k) +q2p*ql(k) ! potential temp @@ -2600,84 +2752,147 @@ SUBROUTINE mym_condensation (kts,kte, & END DO CASE (2, -2) - !Diagnostic statistical scheme of Chaboureau and Bechtold (2002), JAS - !JAYMES- this added 27 Apr 2015 - PBLH2=MAX(10.,PBLH1) - zagl = 0. - DO k = kts,kte-1 - t = th(k)*exner(k) - !SATURATED VAPOR PRESSURE - esat = esat_blend(t) - !SATURATED SPECIFIC HUMIDITY - !qsl=ep_2*esat/(p(k)-ep_3*esat) - qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) - !dqw/dT: Clausius-Clapeyron - dqsl = qsl*ep_2*ev/( rd*t**2 ) - !RH (0 to 1.0) - RH(k)=MAX(MIN(1.0,qw(k)/MAX(1.E-8,qsl)),0.001) - alp(k) = 1.0/( 1.0+dqsl*xlvcp ) - bet(k) = dqsl*exner(k) - - xl = xl_blend(t) ! obtain latent heat - tlk = thl(k)*(p(k)/p1000mb)**rcp ! recover liquid temp (tl) from thl - qsat_tl = qsat_blend(tlk,p(k)) ! get saturation water vapor mixing ratio - ! at tl and p - rsl = xl*qsat_tl / (r_v*tlk**2) ! slope of C-C curve at t = tl - ! CB02, Eqn. 4 - cpm = cp + qw(k)*cpv ! CB02, sec. 2, para. 1 - a(k) = 1./(1. + xl*rsl/cpm) ! CB02 variable "a" - !SPP - qw_pert = qw(k) + qw(k)*0.5*rstoch_col(k)*real(spp_pbl) - !qmq(k) = a(k) * (qw(k) - qsat_tl) ! saturation deficit/excess; + if (sig_order == 1) then + !Diagnostic statistical scheme of Chaboureau and Bechtold (2002), JAS + !using the first-order version of sigma (their eq. 5). + !JAYMES- this added 27 Apr 2015 + PBLH2=MAX(10.,PBLH1) + zagl = 0. + DO k = kts,kte-1 + t = th(k)*exner(k) + !SATURATED VAPOR PRESSURE + esat = esat_blend(t) + !SATURATED SPECIFIC HUMIDITY + !qsl=ep_2*esat/(p(k)-ep_3*esat) + qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) + !dqw/dT: Clausius-Clapeyron + dqsl = qsl*ep_2*ev/( rd*t**2 ) + !RH (0 to 1.0) + RH(k)=MAX(MIN(1.0,qw(k)/MAX(1.E-8,qsl)),0.001) + + alp(k) = 1.0/( 1.0+dqsl*xlvcp ) + bet(k) = dqsl*exner(k) + + xl = xl_blend(t) ! obtain latent heat + tlk = thl(k)*(p(k)/p1000mb)**rcp ! recover liquid temp (tl) from thl + qsat_tl = qsat_blend(tlk,p(k)) ! get saturation water vapor mixing ratio + ! at tl and p + rsl = xl*qsat_tl / (r_v*tlk**2) ! slope of C-C curve at t = tl + ! CB02, Eqn. 4 + cpm = cp + qw(k)*cpv ! CB02, sec. 2, para. 1 + a(k) = 1./(1. + xl*rsl/cpm) ! CB02 variable "a" + !SPP + qw_pert = qw(k) + qw(k)*0.5*rstoch_col(k)*real(spp_pbl) + !qmq(k) = a(k) * (qw(k) - qsat_tl) ! saturation deficit/excess; ! the numerator of Q1 - qmq(k) = a(k) * (qw_pert - qsat_tl) - b(k) = a(k)*rsl ! CB02 variable "b" - dtl = 0.5*(thl(k+1)*(p(k+1)/p1000mb)**rcp + tlk) & + qmq(k) = a(k) * (qw_pert - qsat_tl) + b(k) = a(k)*rsl ! CB02 variable "b" + + dtl = 0.5*(thl(k+1)*(p(k+1)/p1000mb)**rcp + tlk) & & - 0.5*(tlk + thl(MAX(k-1,kts))*(p(MAX(k-1,kts))/p1000mb)**rcp) - dqw = 0.5*(qw(k+1) + qw(k)) - 0.5*(qw(k) + qw(MAX(k-1,kts))) + dqw = 0.5*(qw(k+1) + qw(k)) - 0.5*(qw(k) + qw(MAX(k-1,kts))) - if (k .eq. kts) then - dzk = 0.5*dz(k) - else - dzk = dz(k) - end if + if (k .eq. kts) then + dzk = 0.5*dz(k) + else + dzk = dz(k) + end if - cdhdz = dtl/dzk + (g/cpm)*(1.+qw(k)) ! expression below Eq. 9 + cdhdz = dtl/dzk + (g/cpm)*(1.+qw(k)) ! expression below Eq. 9 ! in CB02 - zagl = zagl + dz(k) - !Use analog to surface layer length scale to make the cloud mixing length scale - !become less than z in stable conditions. - els = zagl !save for more testing: /(1.0 + 1.0*MIN( 0.5*dz(1)*MAX(rmo,0.0), 1. )) - - !ls_min = 300. + MIN(3.*MAX(HFX1,0.),300.) - ls_min = 300. + MIN(2.*MAX(HFX1,0.),150.) - ls_min = MIN(MAX(els,25.),ls_min) ! Let this be the minimum possible length scale: - if (zagl > PBLH1+2000.) ls_min = MAX(ls_min + 0.5*(PBLH1+2000.-zagl),300.) - ! 25 m < ls_min(=zagl) < 300 m - lfac=MIN(4.25+dx/4000.,6.) ! A dx-dependent multiplier for the master length scale: - ! lfac(750 m) = 4.4 - ! lfac(3 km) = 5.0 - ! lfac(13 km) = 6.0 - ls = MAX(MIN(lfac*el(k),600.),ls_min) ! Bounded: ls_min < ls < 600 m - ! Note: CB02 use 900 m as a constant free-atmosphere length scale. - - ! Above 300 m AGL, ls_min remains 300 m. For dx = 3 km, the - ! MYNN master length scale (el) must exceed 60 m before ls - ! becomes responsive to el, otherwise ls = ls_min = 300 m. - - sgm(k) = MAX(1.e-10, 0.225*ls*SQRT(MAX(0., & ! Eq. 9 in CB02: - & (a(k)*dqw/dzk)**2 & ! < 1st term in brackets, - & -2*a(k)*b(k)*cdhdz*dqw/dzk & ! < 2nd term, - & +b(k)**2 * cdhdz**2))) ! < 3rd term - ! CB02 use a multiplier of 0.2, but 0.225 is chosen - ! based on tests - - q1(k) = qmq(k) / sgm(k) ! Q1, the normalized saturation - cldfra_bl1D(K) = MAX(0., MIN(1., 0.5+0.36*ATAN(1.55*q1(k)))) ! Eq. 7 in CB02 - - END DO - + zagl = zagl + dz(k) + !Use analog to surface layer length scale to make the cloud mixing length scale + !become less than z in stable conditions. + els = zagl !save for more testing: /(1.0 + 1.0*MIN( 0.5*dz(1)*MAX(rmo,0.0), 1. )) + + !ls_min = 300. + MIN(3.*MAX(HFX1,0.),300.) + ls_min = 300. + MIN(2.*MAX(HFX1,0.),150.) + ls_min = MIN(MAX(els,25.),ls_min) ! Let this be the minimum possible length scale: + if (zagl > PBLH1+2000.) ls_min = MAX(ls_min + 0.5*(PBLH1+2000.-zagl),300.) + ! 25 m < ls_min(=zagl) < 300 m + lfac=MIN(4.25+dx/4000.,6.) ! A dx-dependent multiplier for the master length scale: + ! lfac(750 m) = 4.4 + ! lfac(3 km) = 5.0 + ! lfac(13 km) = 6.0 + ls = MAX(MIN(lfac*el(k),600.),ls_min) ! Bounded: ls_min < ls < 600 m + ! Note: CB02 use 900 m as a constant free-atmosphere length scale. + + ! Above 300 m AGL, ls_min remains 300 m. For dx = 3 km, the + ! MYNN master length scale (el) must exceed 60 m before ls + ! becomes responsive to el, otherwise ls = ls_min = 300 m. + + sgm(k) = MAX(1.e-10, 0.225*ls*SQRT(MAX(0., & ! Eq. 9 in CB02: + & (a(k)*dqw/dzk)**2 & ! < 1st term in brackets, + & -2*a(k)*b(k)*cdhdz*dqw/dzk & ! < 2nd term, + & +b(k)**2 * cdhdz**2))) ! < 3rd term + ! CB02 use a multiplier of 0.2, but 0.225 is chosen + ! based on tests + + q1(k) = qmq(k) / sgm(k) ! Q1, the normalized saturation + cldfra_bl1D(K) = MAX(0., MIN(1., 0.5+0.36*ATAN(1.55*q1(k)))) ! Eq. 7 in CB02 + END DO + + else + + !Diagnostic statistical scheme of Chaboureau and Bechtold (2002), JAS + !but with use of higher-order moments to estimate sigma + PBLH2=MAX(10.,PBLH1) + zagl = 0. + DO k = kts,kte-1 + t = th(k)*exner(k) + !SATURATED VAPOR PRESSURE + esat = esat_blend(t) + !SATURATED SPECIFIC HUMIDITY + !qsl=ep_2*esat/(p(k)-ep_3*esat) + qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) + !dqw/dT: Clausius-Clapeyron + dqsl = qsl*ep_2*ev/( rd*t**2 ) + !RH (0 to 1.0) + RH(k)=MAX(MIN(1.0,qw(k)/MAX(1.E-8,qsl)),0.001) + + alp(k) = 1.0/( 1.0+dqsl*xlvcp ) + bet(k) = dqsl*exner(k) + + xl = xl_blend(t) ! obtain latent heat + tlk = thl(k)*(p(k)/p1000mb)**rcp ! recover liquid temp (tl) from thl + qsat_tl = qsat_blend(tlk,p(k)) ! get saturation water vapor mixing ratio + ! at tl and p + rsl = xl*qsat_tl / (r_v*tlk**2) ! slope of C-C curve at t = tl + ! CB02, Eqn. 4 + cpm = cp + qw(k)*cpv ! CB02, sec. 2, para. 1 + a(k) = 1./(1. + xl*rsl/cpm) ! CB02 variable "a" + b(k) = a(k)*rsl ! CB02 variable "b" + + !SPP + qw_pert = qw(k) + qw(k)*0.5*rstoch_col(k)*real(spp_pbl) + + !This form of qmq (the numerator of Q1) no longer uses the a(k) factor + qmq(k) = qw_pert - qsat_tl ! saturation deficit/excess; + + !Use the form of Eq. (6) in Chaboureau and Bechtold (2002) + !except neglect all but the first term for sig_r + r3sq = MAX( qsq(k), 0.0 ) + !Calculate sigma using higher-order moments: + sgm(k) = SQRT( r3sq ) + !Set limits on sigma relative to saturation water vapor + sgm(k) = MIN( sgm(k), qsat_tl*0.666 ) !500 ) + sgm(k) = MAX( sgm(k), qsat_tl*0.050 ) !Note: 0.02 results in SWDOWN similar + !to the first-order version of sigma + q1(k) = qmq(k) / sgm(k) ! Q1, the normalized saturation + + !Original C-B cloud fraction, allows cloud fractions out to q1 = -3.5 + cldfra_bl1D(K) = MAX(0., MIN(1., 0.5+0.36*ATAN(1.55*q1(k)))) ! Eq. 7 in CB02 + !This form only allows cloud fractions out to q1 = -1.8 + !cldfra_bl1D(K) = MAX(0., MIN(1., 0.5+0.41*ATAN(1.55*q1(k)))) + !This form only allows cloud fractions out to q1 = -1 + !cldfra_bl1D(K) = MAX(0., MIN(1., 0.5+0.50*ATAN(1.55*q1(k)))) + + END DO + + endif !end sig_order option + + ! Specify hydrometeors ! JAYMES- this option added 8 May 2015 ! The cloud water formulations are taken from CB02, Eq. 8. ! "fng" represents the non-Gaussian contribution to the liquid @@ -2691,7 +2906,7 @@ SUBROUTINE mym_condensation (kts,kte, & zagl = zagl + dz(k) !CLOUD WATER AND ICE - IF (q1k < 0.) THEN !unstaurated + IF (q1k < 0.) THEN !unsaturated ql_water = sgm(k)*EXP(1.2*q1k-1) ql_ice = sgm(k)*EXP(1.2*q1k-1.) !Reduce ice mixing ratios in the upper troposphere @@ -2700,24 +2915,28 @@ SUBROUTINE mym_condensation (kts,kte, & ! + (1.-low_weight) * sgm(k)*EXP(1.1*q1k-2.8)!upper-lev ELSE IF (q1k > 2.) THEN !supersaturated ql_water = sgm(k)*q1k - ql_ice = MIN(80.*qv(k),0.1)*sgm(k)*q1k + ql_ice = sgm(k)*q1k + !ql_ice = MIN(80.*qv(k),0.1)*sgm(k)*q1k ELSE !slightly saturated (0 > q1 < 2) ql_water = sgm(k)*(EXP(-1.) + 0.66*q1k + 0.086*q1k**2) - ql_ice = MIN(80.*qv(k),0.1)*sgm(k)*(EXP(-1.) + 0.66*q1k + 0.086*q1k**2) + ql_ice = sgm(k)*(EXP(-1.) + 0.66*q1k + 0.086*q1k**2) + !ql_ice = MIN(80.*qv(k),0.1)*sgm(k)*(EXP(-1.) + 0.66*q1k + 0.086*q1k**2) ENDIF !In saturated grid cells, use average of current estimate and prev time step IF ( qc(k) > 1.e-7 ) ql_water = 0.5 * ( ql_water + qc(k) ) IF ( qi(k) > 1.e-9 ) ql_ice = 0.5 * ( ql_ice + qi(k) ) - IF (cldfra_bl1D(K) < 0.005) THEN + IF (cldfra_bl1D(k) < 0.01) THEN ql_ice = 0.0 ql_water = 0.0 + cldfra_bl1D(k) = 0.0 ENDIF - !PHASE PARTITIONING: Make some inferences about the relative amounts of subgrid cloud water vs. ice - !based on collocated explicit clouds. Otherise, use a simple temperature-dependent partitioning. - IF ( qc(k) + qi(k) > 0.0 ) THEN ! explicit condensate exists, so attempt to retain its phase partitioning + !PHASE PARTITIONING: Make some inferences about the relative amounts of + !subgrid cloud water vs. ice based on collocated explicit clouds. Otherise, + !use a simple temperature-dependent partitioning. + IF ( qc(k) + qi(k) > 0.0 ) THEN ! explicit condensate exists, retain its phase partitioning IF ( qi(k) == 0.0 ) THEN ! explicit contains no ice; assume subgrid liquid liq_frac = 1.0 ELSE IF ( qc(k) == 0.0 ) THEN ! explicit contains no liquid; assume subgrid ice @@ -2744,8 +2963,12 @@ SUBROUTINE mym_condensation (kts,kte, & qc_bl1D(k) = 0. qi_bl1D(k) = 0. endif - - !Buoyancy-flux-related calculations follow... + ENDDO + + !Buoyancy-flux-related calculations follow... + DO k = kts,kte-1 + t = th(k)*exner(k) + ! "Fng" represents the non-Gaussian transport factor ! (non-dimensional) from Bechtold et al. 1995 ! (hereafter BCMT95), section 3(c). Their suggested @@ -2757,17 +2980,16 @@ SUBROUTINE mym_condensation (kts,kte, & !ELSE ! Fng = 1.-1.5*q1k !ENDIF - ! For purposes of the buoyancy flux in stratus, we will use Fng = 1 - !Fng = 1. - Q1(k)=MAX(Q1(k),-5.0) - IF (Q1(k) .GE. 1.0) THEN + !limiting to avoid mixing away stratus, was -5 + q1k=MAX(Q1(k),-1.0) + IF (q1k .GE. 1.0) THEN Fng = 1.0 - ELSEIF (Q1(k) .GE. -1.7 .AND. Q1(k) .LT. 1.0) THEN - Fng = EXP(-0.4*(Q1(k)-1.0)) - ELSEIF (Q1(k) .GE. -2.5 .AND. Q1(k) .LT. -1.7) THEN - Fng = 3.0 + EXP(-3.8*(Q1(k)+1.7)) + ELSEIF (q1k .GE. -1.7 .AND. q1k .LT. 1.0) THEN + Fng = EXP(-0.4*(q1k-1.0)) + ELSEIF (q1k .GE. -2.5 .AND. q1k .LT. -1.7) THEN + Fng = 3.0 + EXP(-3.8*(q1k+1.7)) ELSE - Fng = MIN(23.9 + EXP(-1.6*(Q1(k)+2.5)), 60.) + Fng = MIN(23.9 + EXP(-1.6*(q1k+2.5)), 60.) ENDIF Fng = MIN(Fng, 20.) @@ -2796,8 +3018,7 @@ SUBROUTINE mym_condensation (kts,kte, & !cld_factor = 1.0 + fac_damp*MAX(0.0, ( RH(k) - 0.5 ) / 0.51 )**3.3 cld_factor = 1.0 + fac_damp*MAX(0.0, ( RH(k) - 0.75 ) / 0.26 )**1.9 cldfra_bl1D(K) = MIN( 1., cld_factor*cldfra_bl1D(K) ) - - END DO + ENDDO END SELECT !end cloudPDF option @@ -2816,7 +3037,6 @@ SUBROUTINE mym_condensation (kts,kte, & qc_bl1D(kte)=0. qi_bl1D(kte)=0. cldfra_bl1D(kte)=0. - RETURN #ifdef HARDCODE_VERTICAL @@ -2831,10 +3051,10 @@ END SUBROUTINE mym_condensation !! This subroutine solves for tendencies of U, V, \f$\theta\f$, qv, !! qc, and qi SUBROUTINE mynn_tendencies(kts,kte, & - &levflag,grav_settling, & + &closure,grav_settling, & &delt,dz,rho, & &u,v,th,tk,qv,qc,qi,qnc,qni, & - &p,exner, & + &psfc,p,exner, & &thl,sqv,sqc,sqi,sqw, & &qnwfa,qnifa,ozone, & &ust,flt,flq,flqv,flqc,wspd,qcg, & @@ -2849,6 +3069,8 @@ SUBROUTINE mynn_tendencies(kts,kte, & &s_awu,s_awv, & &s_awqnc,s_awqni, & &s_awqnwfa,s_awqnifa, & + &sd_aw,sd_awthl,sd_awqt,sd_awqv, & + &sd_awqc,sd_awu,sd_awv, & &sub_thl,sub_sqv, & &sub_u,sub_v, & &det_thl,det_sqv,det_sqc, & @@ -2870,7 +3092,8 @@ SUBROUTINE mynn_tendencies(kts,kte, & # define kte HARDCODE_VERTICAL #endif - INTEGER, INTENT(in) :: grav_settling,levflag + INTEGER, INTENT(in) :: grav_settling + REAL, INTENT(in) :: closure INTEGER, INTENT(in) :: bl_mynn_cloudmix,bl_mynn_mixqt,& bl_mynn_edmf,bl_mynn_edmf_mom, & bl_mynn_mixscalars @@ -2887,7 +3110,9 @@ SUBROUTINE mynn_tendencies(kts,kte, & ! mass-flux plumes REAL, DIMENSION(kts:kte+1), INTENT(in) :: s_aw,s_awthl,s_awqt,& - &s_awqnc,s_awqni,s_awqv,s_awqc,s_awu,s_awv,s_awqnwfa,s_awqnifa + &s_awqnc,s_awqni,s_awqv,s_awqc,s_awu,s_awv, & + &s_awqnwfa,s_awqnifa, & + &sd_aw,sd_awthl,sd_awqt,sd_awqv,sd_awqc,sd_awu,sd_awv ! tendencies from mass-flux environmental subsidence and detrainment REAL, DIMENSION(kts:kte), INTENT(in) :: sub_thl,sub_sqv, & &sub_u,sub_v,det_thl,det_sqv,det_sqc,det_u,det_v @@ -2897,14 +3122,14 @@ SUBROUTINE mynn_tendencies(kts,kte, & &qnwfa,qnifa,ozone,dfm,dfh REAL, DIMENSION(kts:kte), INTENT(inout) :: du,dv,dth,dqv,dqc,dqi,& &dqni,dqnc,dqnwfa,dqnifa,dozone - REAL, INTENT(IN) :: delt,ust,flt,flq,flqv,flqc,wspd,uoce,voce,qcg + REAL, INTENT(IN) :: delt,ust,flt,flq,flqv,flqc,wspd,uoce,voce,qcg,psfc ! REAL, INTENT(IN) :: delt,ust,flt,flq,qcg,& ! &gradu_top,gradv_top,gradth_top,gradqv_top !local vars - REAL, DIMENSION(kts:kte) :: dtz,vt,vq,dfhc,dfmc !Kh for clouds (Pr < 2) + REAL, DIMENSION(kts:kte) :: dtz,dfhc,dfmc !Kh for clouds (Pr < 2) REAL, DIMENSION(kts:kte) :: sqv2,sqc2,sqi2,sqw2,qni2,qnc2, & !AFTER MIXING qnwfa2,qnifa2,ozone2 REAL, DIMENSION(kts:kte) :: zfac,plumeKh,rhoinv @@ -2913,12 +3138,13 @@ SUBROUTINE mynn_tendencies(kts,kte, & & khdz, kmdz REAL :: rhs,gfluxm,gfluxp,dztop,maxdfh,mindfh,maxcf,maxKh,zw REAL :: grav_settling2,vdfg1 !Katata-fogdes - REAL :: t,esat,qsl,onoff,kh,km,dzk + REAL :: t,esat,qsl,onoff,kh,km,dzk,rhosfc + REAL :: ustdrag,ustdiff INTEGER :: k,kk !Activate nonlocal mixing from the mass-flux scheme for - !scalars (0.0 = no; 1.0 = yes) - REAL, PARAMETER :: nonloc = 0.0 + !number concentrations and aerosols (0.0 = no; 1.0 = yes) + REAL, PARAMETER :: nonloc = 1.0 dztop=.5*(dz(kte)+dz(kte-1)) @@ -2933,6 +3159,7 @@ SUBROUTINE mynn_tendencies(kts,kte, & !Prepare "constants" for diffusion equation. !khdz = rho*Kh/dz = rho*dfh + rhosfc = psfc/(Rd*(Tk(kts)+0.608*qv(kts))) dtz(kts) =delt/dz(kts) rhoz(kts) =rho(kts) rhoinv(kts)=1./rho(kts) @@ -2959,46 +3186,43 @@ SUBROUTINE mynn_tendencies(kts,kte, & kmdz(k) = MAX(kmdz(k), -0.5*rho(k)*(s_aw(k)-s_aw(k+1))) ENDDO + ustdrag = MIN(ust*ust,0.99)/wspd ! limit at ~ 20 m/s + ustdiff = MIN(ust*ust,0.01)/wspd ! limit at ~ 2 m/s + !!============================================ !! u !!============================================ k=kts +!original approach ! a(1)=0. ! b(1)=1. + dtz(k)*(dfm(k+1)+ust**2/wspd) - 0.5*dtz(k)*s_aw(k+1)*onoff ! c(1)=-dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff ! d(1)=u(k) + dtz(k)*uoce*ust**2/wspd - dtz(k)*s_awu(k+1)*onoff + & ! sub_u(k)*delt + det_u(k)*delt -! -! DO k=kts+1,kte-1 -! a(k)= - dtz(k)*dfm(k) + 0.5*dtz(k)*s_aw(k)*onoff -! b(k)=1. + dtz(k)*(dfm(k)+dfm(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*onoff -! c(k)= - dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff -! d(k)=u(k) + dtz(k)*(s_awu(k)-s_awu(k+1))*onoff + & -! sub_u(k)*delt + det_u(k)*delt -! ENDDO !rho-weighted: +! a(k)= -dtz(k)*kmdz(k)*rhoinv(k) +! b(k)=1.+dtz(k)*(kmdz(k+1)+ust**2/wspd)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*onoff +! c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*onoff +! d(k)=u(k) + dtz(k)*uoce*ust**2/wspd - dtz(k)*s_awu(k+1)*onoff + & +! & sub_u(k)*delt + det_u(k)*delt + +!rho-weighted with drag term moved out of b-array a(k)= -dtz(k)*kmdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(kmdz(k+1)+ust**2/wspd)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*onoff - c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*onoff - d(k)=u(k) + dtz(k)*uoce*ust**2/wspd - dtz(k)*s_awu(k+1)*onoff + & - & sub_u(k)*delt + det_u(k)*delt - -!!JOE - tend test -!! a(k)=0. -!! b(k)=1.+dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*onoff -!! c(k) =-dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*onoff -!! d(k)=u(k)*(1.-ust**2/wspd*dtz(k)) + & -!! dtz(k)*uoce*ust**2/wspd - dtz(k)*s_awu(k+1)*onoff + b(k)=1.+dtz(k)*(kmdz(k+1))*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*sd_aw(k+1)*onoff + c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*sd_aw(k+1)*onoff + d(k)=u(k)*(1.-ust**2/wspd*dtz(k)*rhosfc/rho(k)) + dtz(k)*uoce*ust**2/wspd - & + !d(k)=u(k)*(1.-ust**2/wspd*dtz(k)) + dtz(k)*uoce*ust**2/wspd - & + & dtz(k)*s_awu(k+1)*onoff - dtz(k)*sd_awu(k+1)*onoff + sub_u(k)*delt + det_u(k)*delt DO k=kts+1,kte-1 - a(k)= -dtz(k)*kmdz(k)*rhoinv(k) + 0.5*dtz(k)*s_aw(k)*onoff + a(k)= -dtz(k)*kmdz(k)*rhoinv(k) + 0.5*dtz(k)*s_aw(k)*onoff + 0.5*dtz(k)*sd_aw(k)*onoff b(k)=1.+dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*onoff - c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*onoff - d(k)=u(k) + dtz(k)*(s_awu(k)-s_awu(k+1))*onoff + & + & 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*onoff + 0.5*dtz(k)*(sd_aw(k)-sd_aw(k+1))*onoff + c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*sd_aw(k+1)*onoff + d(k)=u(k) + dtz(k)*(s_awu(k)-s_awu(k+1))*onoff + dtz(k)*(sd_awu(k)-sd_awu(k+1))*onoff + & & sub_u(k)*delt + det_u(k)*delt ENDDO @@ -3034,41 +3258,34 @@ SUBROUTINE mynn_tendencies(kts,kte, & k=kts +!original approach ! a(1)=0. ! b(1)=1. + dtz(k)*(dfm(k+1)+ust**2/wspd) - 0.5*dtz(k)*s_aw(k+1)*onoff ! c(1)= - dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff -!! d(1)=v(k) ! d(1)=v(k) + dtz(k)*voce*ust**2/wspd - dtz(k)*s_awv(k+1)*onoff + & ! sub_v(k)*delt + det_v(k)*delt -! -! DO k=kts+1,kte-1 -! a(k)= - dtz(k)*dfm(k) + 0.5*dtz(k)*s_aw(k)*onoff -! b(k)=1. + dtz(k)*(dfm(k)+dfm(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*onoff -! c(k)= - dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff -! d(k)=v(k) + dtz(k)*(s_awv(k)-s_awv(k+1))*onoff + & -! sub_v(k)*delt + det_v(k)*delt -! ENDDO !rho-weighted: +! a(k)= -dtz(k)*kmdz(k)*rhoinv(k) +! b(k)=1.+dtz(k)*(kmdz(k+1)+ust**2/wspd)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*onoff +! c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*onoff +! d(k)=v(k) + dtz(k)*voce*ust**2/wspd - dtz(k)*s_awv(k+1)*onoff + & +! & sub_v(k)*delt + det_v(k)*delt + +!rho-weighted with drag term moved out of b-array a(k)= -dtz(k)*kmdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(kmdz(k+1)+ust**2/wspd)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*onoff - c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*onoff - d(k)=v(k) + dtz(k)*voce*ust**2/wspd - dtz(k)*s_awv(k+1)*onoff + & - & sub_v(k)*delt + det_v(k)*delt - -!!JOE - tend test -!! a(k)=0. -!! b(k)=1.+dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*onoff -!! c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*onoff -!! d(k)=v(k)*(1.-ust**2/wspd*dtz(k)) + & -!! dtz(k)*voce*ust**2/wspd - dtz(k)*s_awv(k+1)*onoff + b(k)=1.+dtz(k)*(kmdz(k+1))*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*sd_aw(k+1)*onoff + c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*sd_aw(k+1)*onoff + d(k)=v(k)*(1.-ust**2/wspd*dtz(k)*rhosfc/rho(k)) + dtz(k)*voce*ust**2/wspd - & + !d(k)=v(k)*(1.-ust**2/wspd*dtz(k)) + dtz(k)*voce*ust**2/wspd - & + & dtz(k)*s_awv(k+1)*onoff - dtz(k)*sd_awv(k+1)*onoff + sub_v(k)*delt + det_v(k)*delt DO k=kts+1,kte-1 - a(k)= -dtz(k)*kmdz(k)*rhoinv(k) + 0.5*dtz(k)*s_aw(k)*onoff + a(k)= -dtz(k)*kmdz(k)*rhoinv(k) + 0.5*dtz(k)*s_aw(k)*onoff + 0.5*dtz(k)*sd_aw(k)*onoff b(k)=1.+dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*onoff - c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*onoff - d(k)=v(k) + dtz(k)*(s_awv(k)-s_awv(k+1))*onoff + & + & 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*onoff + 0.5*dtz(k)*(sd_aw(k)-sd_aw(k+1))*onoff + c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*sd_aw(k+1)*onoff + d(k)=v(k) + dtz(k)*(s_awv(k)-s_awv(k+1))*onoff + dtz(k)*(sd_awv(k)-sd_awv(k+1))*onoff + & & sub_v(k)*delt + det_v(k)*delt ENDDO @@ -3120,21 +3337,22 @@ SUBROUTINE mynn_tendencies(kts,kte, & ! & sub_thl(k)*delt + det_thl(k)*delt ! ENDDO -!rho-weighted: +!rho-weighted: a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) - d(k)=thl(k) + dtz(k)*flt + tcd(k)*delt - dtz(k)*s_awthl(k+1) + & + b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) - 0.5*dtz(k)*sd_aw(k+1) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) - 0.5*dtz(k)*sd_aw(k+1) + d(k)=thl(k) + dtz(k)*flt + tcd(k)*delt - dtz(k)*s_awthl(k+1) -dtz(k)*sd_awthl(k+1) + & & diss_heat(k)*delt*dheat_opt + sub_thl(k)*delt + det_thl(k)*delt DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*s_aw(k) + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*s_aw(k) + 0.5*dtz(k)*sd_aw(k) b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) - d(k)=thl(k) + tcd(k)*delt + dtz(k)*(s_awthl(k)-s_awthl(k+1)) + & - & diss_heat(k)*delt*dheat_opt + & - & sub_thl(k)*delt + det_thl(k)*delt + & 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) + 0.5*dtz(k)*(sd_aw(k)-sd_aw(k+1)) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) - 0.5*dtz(k)*sd_aw(k+1) + d(k)=thl(k) + tcd(k)*delt + & + & dtz(k)*(s_awthl(k)-s_awthl(k+1)) + dtz(k)*(sd_awthl(k)-sd_awthl(k+1)) + & + & diss_heat(k)*delt*dheat_opt + & + & sub_thl(k)*delt + det_thl(k)*delt ENDDO !! no flux at the top @@ -3190,16 +3408,16 @@ SUBROUTINE mynn_tendencies(kts,kte, & !rho-weighted: a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) - d(k)=sqw(k) + dtz(k)*flq + qcd(k)*delt - dtz(k)*s_awqt(k+1) + b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) - 0.5*dtz(k)*sd_aw(k+1) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) - 0.5*dtz(k)*sd_aw(k+1) + d(k)=sqw(k) + dtz(k)*flq + qcd(k)*delt - dtz(k)*s_awqt(k+1) - dtz(k)*sd_awqt(k+1) DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*s_aw(k) + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*s_aw(k) + 0.5*dtz(k)*sd_aw(k) b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) - d(k)=sqw(k) + qcd(k)*delt + dtz(k)*(s_awqt(k)-s_awqt(k+1)) + & 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) + 0.5*dtz(k)*(sd_aw(k)-sd_aw(k+1)) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) - 0.5*dtz(k)*sd_aw(k+1) + d(k)=sqw(k) + qcd(k)*delt + dtz(k)*(s_awqt(k)-s_awqt(k+1)) + dtz(k)*(sd_awqt(k)-sd_awqt(k+1)) ENDDO !! no flux at the top @@ -3255,17 +3473,17 @@ SUBROUTINE mynn_tendencies(kts,kte, & !rho-weighted: a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) - d(k)=sqc(k) + dtz(k)*flqc + qcd(k)*delt - dtz(k)*s_awqc(k+1) + & + b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) - 0.5*dtz(k)*sd_aw(k+1) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) - 0.5*dtz(k)*sd_aw(k+1) + d(k)=sqc(k) + dtz(k)*flqc + qcd(k)*delt - dtz(k)*s_awqc(k+1) - dtz(k)*sd_awqc(k+1) + & & det_sqc(k)*delt DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*s_aw(k) + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*s_aw(k) + 0.5*dtz(k)*sd_aw(k) b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) - d(k)=sqc(k) + qcd(k)*delt + dtz(k)*(s_awqc(k)-s_awqc(k+1)) + & + & 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) + 0.5*dtz(k)*(sd_aw(k)-sd_aw(k+1)) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) - 0.5*dtz(k)*sd_aw(k+1) + d(k)=sqc(k) + qcd(k)*delt + dtz(k)*(s_awqc(k)-s_awqc(k+1)) + dtz(k)*(sd_awqc(k)-sd_awqc(k+1)) + & & det_sqc(k)*delt ENDDO @@ -3312,17 +3530,17 @@ SUBROUTINE mynn_tendencies(kts,kte, & !rho-weighted: a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) - d(k)=sqv(k) + dtz(k)*flqv + qcd(k)*delt - dtz(k)*s_awqv(k+1) + & + b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) - 0.5*dtz(k)*sd_aw(k+1) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) - 0.5*dtz(k)*sd_aw(k+1) + d(k)=sqv(k) + dtz(k)*flqv + qcd(k)*delt - dtz(k)*s_awqv(k+1) - dtz(k)*sd_awqv(k+1) + & & sub_sqv(k)*delt + det_sqv(k)*delt DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*s_aw(k) + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*s_aw(k) + 0.5*dtz(k)*sd_aw(k) b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) - d(k)=sqv(k) + qcd(k)*delt + dtz(k)*(s_awqv(k)-s_awqv(k+1)) + & + & 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) + 0.5*dtz(k)*(sd_aw(k)-sd_aw(k+1)) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) - 0.5*dtz(k)*sd_aw(k+1) + d(k)=sqv(k) + qcd(k)*delt + dtz(k)*(s_awqv(k)-s_awqv(k+1)) + dtz(k)*(sd_awqv(k)-sd_awqv(k+1)) + & & sub_sqv(k)*delt + det_sqv(k)*delt ENDDO @@ -3793,48 +4011,58 @@ END SUBROUTINE mynn_tendencies ! ================================================================== #if (WRF_CHEM == 1) -!>\ingroup gsd_mynn_edmf - SUBROUTINE mynn_mix_chem(kts,kte, & - levflag,grav_settling, & - delt,dz, & + SUBROUTINE mynn_mix_chem(kts,kte,i,j, & + grav_settling, & + delt,dz,pblh, & nchem, kdvel, ndvel, num_vert_mix, & chem1, vd1, & qnc,qni, & p,exner, & - thl,sqv,sqc,sqi,sqw, & + thl,sqv,sqc,sqi,sqw,rho, & ust,flt,flq,flqv,flqc,wspd,qcg, & - uoce,voce, & - tsq,qsq,cov, & tcd,qcd, & dfm,dfh,dfq, & s_aw, & s_awchem, & - bl_mynn_cloudmix) + bl_mynn_cloudmix, & + emis_ant_no, & + frp_mean, & + enh_vermix ) !------------------------------------------------------------------- - INTEGER, INTENT(in) :: kts,kte - INTEGER, INTENT(in) :: grav_settling,levflag + INTEGER, INTENT(in) :: kts,kte,i,j + INTEGER, INTENT(in) :: grav_settling INTEGER, INTENT(in) :: bl_mynn_cloudmix REAL, DIMENSION(kts:kte), INTENT(IN) :: qni,qnc,& - &p,exner,dfm,dfh,dfq,dz,tsq,qsq,cov,tcd,qcd - REAL, DIMENSION(kts:kte), INTENT(INOUT) :: thl,sqw,sqv,sqc,sqi - REAL, INTENT(IN) :: delt,ust,flt,flq,flqv,flqc,wspd,uoce,voce,qcg + &p,exner,dfm,dfh,dfq,dz,tcd,qcd + REAL, DIMENSION(kts:kte), INTENT(INOUT) :: thl,sqw,sqv,sqc,sqi,rho + REAL, INTENT(IN) :: delt,ust,flt,flq,flqv,flqc,qcg INTEGER, INTENT(IN ) :: nchem, kdvel, ndvel, num_vert_mix REAL, DIMENSION( kts:kte+1), INTENT(IN) :: s_aw REAL, DIMENSION( kts:kte, nchem ), INTENT(INOUT) :: chem1 REAL, DIMENSION( kts:kte+1,nchem), INTENT(IN) :: s_awchem - REAL, DIMENSION( ndvel ), INTENT(INOUT) :: vd1 - + REAL, DIMENSION( ndvel ), INTENT(IN) :: vd1 + REAL, INTENT(IN) :: emis_ant_no,frp_mean,pblh + LOGICAL, INTENT(IN) :: enh_vermix !local vars - REAL, DIMENSION(kts:kte) :: dtz,vt,vq - REAL, DIMENSION(1:kte-kts+1) :: a,b,c,d + REAL, DIMENSION(kts:kte) :: dtz + REAL, DIMENSION(1:kte-kts+1) :: a,b,c,d,x REAL :: rhs,gfluxm,gfluxp,dztop - REAL :: t,esl,qsl + REAL :: t,esl,qsl,dzk + REAL :: hght + REAL :: khdz_old, khdz_back INTEGER :: k,kk INTEGER :: ic ! Chemical array loop index - REAL, DIMENSION( kts:kte, nchem ) :: chem_new + + INTEGER, SAVE :: icall + + REAL, DIMENSION(kts:kte) :: rhoinv + REAL, DIMENSION(kts:kte+1) :: rhoz,khdz + REAL, PARAMETER :: no_threshold = 0.1 + REAL, PARAMETER :: frp_threshold = 0.0 + REAL, PARAMETER :: pblh_threshold = 250.0 dztop=.5*(dz(kte)+dz(kte-1)) @@ -3842,6 +4070,53 @@ SUBROUTINE mynn_mix_chem(kts,kte, & dtz(k)=delt/dz(k) ENDDO + !Prepare "constants" for diffusion equation. + !khdz = rho*Kh/dz = rho*dfh + rhoz(kts) =rho(kts) + rhoinv(kts)=1./rho(kts) + khdz(kts) =rhoz(kts)*dfh(kts) +! JLS + khdz_old = khdz(kts) + khdz_back = pblh * 0.15 / dz(kts) + IF ( enh_vermix ) THEN + IF ( pblh < pblh_threshold ) THEN + IF ( emis_ant_no > no_threshold ) THEN + khdz(k) = MAX(khdz(k),khdz_back) + ENDIF + IF ( frp_mean > frp_threshold ) THEN + khdz(k) = MAX(khdz(k),khdz_back) + ENDIF + ENDIF + ENDIF + DO k=kts+1,kte + rhoz(k) =(rho(k)*dz(k-1) + rho(k-1)*dz(k))/(dz(k-1)+dz(k)) + rhoz(k) = MAX(rhoz(k),1E-4) + rhoinv(k)=1./MAX(rho(k),1E-4) + dzk = 0.5 *( dz(k)+dz(k-1) ) + khdz(k) = rhoz(k)*dfh(k) + ENDDO + khdz(kte+1)=rhoz(kte+1)*dfh(kte) + + !stability criteria for mf + DO k=kts+1,kte-1 + khdz(k) = MAX(khdz(k), 0.5*rho(k)* s_aw(k)) + khdz(k) = MAX(khdz(k), -0.5*rho(k)*(s_aw(k)-s_aw(k+1))) + + khdz_old = khdz(k) + khdz_back = pblh * 0.15 / dz(k) + IF ( enh_vermix ) THEN + !Modify based on anthropogenic emissions of NO and FRP + IF ( pblh < pblh_threshold ) THEN + IF ( emis_ant_no > no_threshold ) THEN + khdz(k) = MAX(khdz(k),khdz_back) + ENDIF + IF ( frp_mean > frp_threshold ) THEN + khdz(k) = MAX(khdz(k),khdz_back) + ENDIF + ENDIF + ENDIF + ENDDO + !============================================ ! Patterned after mixing of water vapor in mynn_tendencies. !============================================ @@ -3849,17 +4124,33 @@ SUBROUTINE mynn_mix_chem(kts,kte, & DO ic = 1,nchem k=kts - a(1)=0. - b(1)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) - c(1)=-dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) - d(1)=chem1(k,ic) + dtz(k) * -vd1(ic)*chem1(1,ic) - dtz(k)*s_awchem(k+1,ic) + !a(1)=0. + !b(1)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + !c(1)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + !d(1)=chem1(k,ic) + dtz(k) * -vd1(ic)*chem1(1,ic) - dtz(k)*s_awchem(k+1,ic) + + !DO k=kts+1,kte-1 + ! a(k)= -dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k) + ! b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) + ! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + ! ! d(kk)=chem1(k,ic) + qcd(k)*delt + ! d(k)=chem1(k,ic) + rhs*delt + dtz(k)*(s_awchem(k,ic)-s_awchem(k+1,ic)) + !ENDDO + +!rho-weighted: + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) + d(k)=chem1(k,ic) & !dtz(k)*flt !neglecting surface sources + & + dtz(k) * -vd1(ic)*chem1(1,ic) & + & - dtz(k)*s_awchem(k+1,ic) DO k=kts+1,kte-1 - a(k)=-dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k) - b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) - c(k)=-dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) - ! d(kk)=chem1(k,ic) + qcd(k)*delt - d(k)=chem1(k,ic) + rhs*delt + dtz(k)*(s_awchem(k,ic)-s_awchem(k+1,ic)) + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*s_aw(k) + b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & + & 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) + d(k)=chem1(k,ic) + dtz(k)*(s_awchem(k,ic)-s_awchem(k+1,ic)) ENDDO ! prescribed value at top @@ -3868,10 +4159,12 @@ SUBROUTINE mynn_mix_chem(kts,kte, & c(kte)=0. d(kte)=chem1(kte,ic) - CALL tridiag(kte,a,b,c,d) + !CALL tridiag(kte,a,b,c,d) + CALL tridiag3(kte,a,b,c,d,x) DO k=kts,kte - chem_new(k,ic)=d(k-kts+1) + !chem_new(k,ic)=d(k) + chem1(k,ic)=x(k) ENDDO ENDDO @@ -4043,6 +4336,9 @@ SUBROUTINE mynn_bl_driver( & #if (WRF_CHEM == 1) chem3d, vd3d, nchem, & ! WA 7/29/15 For WRF-Chem kdvel, ndvel, num_vert_mix, & + FRP_MEAN,EMIS_ANT_NO, & ! JLS/RAR to adjust exchange coeffs + mynn_chem_vertmx, & ! JLS/RAR + enh_vermix, & ! JLS/RAR #endif &Tsq,Qsq,Cov, & &RUBLTEN,RVBLTEN,RTHBLTEN, & @@ -4058,11 +4354,12 @@ SUBROUTINE mynn_bl_driver( & &bl_mynn_cloudpdf,Sh3D, & &bl_mynn_mixlength, & &icloud_bl,qc_bl,qi_bl,cldfra_bl,& - &levflag,bl_mynn_edmf, & + &bl_mynn_edmf, & &bl_mynn_edmf_mom,bl_mynn_edmf_tke, & &bl_mynn_mixscalars, & &bl_mynn_output, & &bl_mynn_cloudmix,bl_mynn_mixqt, & + &closure, & &edmf_a,edmf_w,edmf_qt, & &edmf_thl,edmf_ent,edmf_qc, & &sub_thl3D,sub_sqv3D, & @@ -4080,8 +4377,7 @@ SUBROUTINE mynn_bl_driver( & INTEGER, INTENT(in) :: initflag !INPUT NAMELIST OPTIONS: - LOGICAL, INTENT(in) :: restart,cycling - INTEGER, INTENT(in) :: levflag + LOGICAL, INTENT(IN) :: restart,cycling INTEGER, INTENT(in) :: grav_settling INTEGER, INTENT(in) :: bl_mynn_tkebudget INTEGER, INTENT(in) :: bl_mynn_cloudpdf @@ -4095,10 +4391,14 @@ SUBROUTINE mynn_bl_driver( & INTEGER, INTENT(in) :: bl_mynn_cloudmix INTEGER, INTENT(in) :: bl_mynn_mixqt INTEGER, INTENT(in) :: icloud_bl + REAL, INTENT(in) :: closure LOGICAL, INTENT(in) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,& FLAG_QNWFA,FLAG_QNIFA - +#if (WRF_CHEM == 1) + LOGICAL, INTENT(IN) :: mynn_chem_vertmx,enh_vermix +#endif + INTEGER,INTENT(in) :: & & IDS,IDE,JDS,JDE,KDS,KDE & &,IMS,IME,JMS,JME,KMS,KME & @@ -4111,8 +4411,9 @@ SUBROUTINE mynn_bl_driver( & ! initflag > 0 for TRUE ! else for FALSE -! levflag : <>3; Level 2.5 -! = 3; Level 3 +! closure : <= 2.5; Level 2.5 +! 2.5< and <3; Level 2.6 +! = 3; Level 3 ! grav_settling = 1 when gravitational settling accounted for ! grav_settling = 0 when gravitational settling NOT accounted for @@ -4129,12 +4430,12 @@ SUBROUTINE mynn_bl_driver( & &sqc3D,sqi3D,qni,qnc,qnwfa,qnifa REAL, DIMENSION(IMS:IME,KMS:KME), OPTIONAL, INTENT(in):: ozone REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(in) :: xland,ust,& - &ch,rmol,ts,qsfc,qcg,ps,hfx,qfx,wspd,uoce,voce,vdfg,znt + &ch,ts,qsfc,qcg,ps,hfx,qfx,wspd,uoce,voce,vdfg,znt REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(inout) :: & &Qke,Tsq,Qsq,Cov, & !&tke_pbl, & !JOE-added for coupling (TKE_PBL = QKE/2) - &qke_adv !ACF for QKE advection + &qke_adv !ACF for QKE advection REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(inout) :: & &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN,RQCBLTEN,& @@ -4153,8 +4454,11 @@ SUBROUTINE mynn_bl_driver( & & edmf_a,edmf_w,edmf_qt,edmf_thl,edmf_ent,edmf_qc, & & sub_thl3D,sub_sqv3D,det_thl3D,det_sqv3D + REAL, DIMENSION(IMS:IME,KMS:KME) :: & + & edmf_a_dd,edmf_w_dd,edmf_qt_dd,edmf_thl_dd,edmf_ent_dd,edmf_qc_dd + REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(inout) :: & - &Pblh,wstar,delta !JOE-added for GRIMS + &Pblh,wstar,delta,rmol REAL, DIMENSION(IMS:IME,JMS:JME) :: & &Psig_bl,Psig_shcu @@ -4176,7 +4480,7 @@ SUBROUTINE mynn_bl_driver( & REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: Sh3D - REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(inout) :: & + REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(inout), optional :: & &qc_bl,qi_bl,cldfra_bl REAL, DIMENSION(KTS:KTE) :: qc_bl1D,qi_bl1D,cldfra_bl1D,& qc_bl1D_old,qi_bl1D_old,cldfra_bl1D_old @@ -4186,6 +4490,8 @@ SUBROUTINE mynn_bl_driver( & INTEGER, INTENT(IN ) :: nchem, kdvel, ndvel, num_vert_mix REAL, DIMENSION( ims:ime, kms:kme, jms:jme, nchem ), INTENT(INOUT), OPTIONAL :: chem3d REAL, DIMENSION( ims:ime, kdvel, jms:jme, ndvel ), INTENT(IN), OPTIONAL :: vd3d + REAL, DIMENSION(ims:ime,jms:jme), INTENT(IN), OPTIONAL ::FRP_MEAN,EMIS_ANT_NO + REAL, DIMENSION( kts:kte, nchem ) :: chem1 REAL, DIMENSION( kts:kte+1, nchem ) :: s_awchem1 REAL, DIMENSION( ndvel ) :: vd1 @@ -4198,8 +4504,7 @@ SUBROUTINE mynn_bl_driver( & REAL, DIMENSION(KTS:KTE) :: thl,thvl,tl,qv1,qc1,qi1,sqw,& &El, Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc, & &Vt, Vq, sgm, thlsg - - REAL, DIMENSION(KTS:KTE) :: thetav,sh,u1,v1,w1,p1,ex1,dz1,th1,tk1,rho1,& + REAL, DIMENSION(KTS:KTE) :: thetav,sh,sm,u1,v1,w1,p1,ex1,dz1,th1,tk1,rho1,& & qke1,tsq1,qsq1,cov1,sqv,sqi,sqc,du1,dv1,dth1,dqv1,dqc1,dqi1,ozone1, & & k_m1,k_h1,qni1,dqni1,qnc1,dqnc1,qnwfa1,qnifa1,dqnwfa1,dqnifa1,dozone1 @@ -4207,36 +4512,26 @@ SUBROUTINE mynn_bl_driver( & REAL, DIMENSION(KTS:KTE) :: dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf REAL, DIMENSION(KTS:KTE) :: edmf_a1,edmf_w1,edmf_qt1,edmf_thl1,& edmf_ent1,edmf_qc1 + REAL, DIMENSION(KTS:KTE) :: edmf_a_dd1,edmf_w_dd1,edmf_qt_dd1,edmf_thl_dd1,& + edmf_ent_dd1,edmf_qc_dd1 REAL, DIMENSION(KTS:KTE) :: sub_thl,sub_sqv,sub_u,sub_v, & det_thl,det_sqv,det_sqc,det_u,det_v REAL,DIMENSION(KTS:KTE+1) :: s_aw1,s_awthl1,s_awqt1,& s_awqv1,s_awqc1,s_awu1,s_awv1,s_awqke1,& s_awqnc1,s_awqni1,s_awqnwfa1,s_awqnifa1 + REAL,DIMENSION(KTS:KTE+1) :: sd_aw1,sd_awthl1,sd_awqt1,& + sd_awqv1,sd_awqc1,sd_awu1,sd_awv1,sd_awqke1 REAL, DIMENSION(KTS:KTE+1) :: zw - REAL :: cpm,sqcg,flt,flq,flqv,flqc,pmz,phh,exnerg,zet,& - & afk,abk,ts_decay, qc_bl2, qi_bl2, & + REAL :: cpm,sqcg,flt,fltv,flq,flqv,flqc,pmz,phh,exnerg,zet,phi_m,& + & afk,abk,ts_decay, qc_bl2, qi_bl2, & & th_sfc,ztop_plume,sqc9,sqi9 -!JOE-add GRIMS parameters & variables - real,parameter :: d1 = 0.02, d2 = 0.05, d3 = 0.001 - real,parameter :: h1 = 0.33333335, h2 = 0.6666667 - REAL :: govrth, sflux, bfx0, wstar3, wm2, wm3, delb -!JOE-end GRIMS !JOE-top-down diffusion REAL, DIMENSION(ITS:ITE,JTS:JTE) :: maxKHtopdown - REAL,DIMENSION(KTS:KTE) :: KHtopdown,zfac,wscalek2,& - zfacent,TKEprodTD - REAL :: bfxpbl,dthvx,tmp1,temps,templ,zl1,wstar3_2 - real :: ent_eff,radsum,radflux,we,rcldb,rvls,& - minrad,zminrad - real, parameter :: pfac =2.0, zfmin = 0.01, phifac=8.0 - integer :: kk,kminrad - logical :: cloudflg + REAL,DIMENSION(KTS:KTE) :: KHtopdown,TKEprodTD !JOE-end top down -!for WRF INTEGER, SAVE :: levflag - LOGICAL :: INITIALIZE_QKE ! Stochastic fields @@ -4263,9 +4558,6 @@ SUBROUTINE mynn_bl_driver( & ITF=ITE KTF=KTE -!WRF -! levflag=mynn_level - IF (bl_mynn_edmf > 0) THEN ! setup random seed !call init_random_seed @@ -4288,6 +4580,15 @@ SUBROUTINE mynn_bl_driver( & ENDIF maxKHtopdown(its:ite,jts:jte)=0. + IF (bl_mynn_edmf_dd > 0) THEN + edmf_a_dd(its:ite,kts:kte)=0. + edmf_w_dd(its:ite,kts:kte)=0. + edmf_qt_dd(its:ite,kts:kte)=0. + edmf_thl_dd(its:ite,kts:kte)=0. + edmf_ent_dd(its:ite,kts:kte)=0. + edmf_qc_dd(its:ite,kts:kte)=0. + ENDIF + ! DH* CHECK HOW MUCH OF THIS INIT IF-BLOCK IS ACTUALLY NEEDED FOR RESTARTS !> - Within the MYNN-EDMF, there is a dependecy check for the first time step, !! If true, a three-dimensional initialization loop is entered. Within this loop, @@ -4335,6 +4636,9 @@ SUBROUTINE mynn_bl_driver( & edmf_a1(kts:kte)=0.0 edmf_w1(kts:kte)=0.0 edmf_qc1(kts:kte)=0.0 + edmf_a_dd1(kts:kte)=0.0 + edmf_w_dd1(kts:kte)=0.0 + edmf_qc_dd1(kts:kte)=0.0 sgm(kts:kte)=0.0 vt(kts:kte)=0.0 vq(kts:kte)=0.0 @@ -4470,7 +4774,7 @@ SUBROUTINE mynn_bl_driver( & &kts,kte, & &dz1, dx(i,j), zw, & &u1, v1, thl, sqv, & - &PBLH(i,j), th1, sh, & + &PBLH(i,j), th1, sh, sm, & &ust(i,j), rmol(i,j), & &el, Qke1, Tsq1, Qsq1, Cov1, & &Psig_bl(i,j), cldfra_bl1D, & @@ -4532,6 +4836,13 @@ SUBROUTINE mynn_bl_driver( & cldfra_bl1D_old(k)=cldfra_bl(i,k,j) qc_bl1D_old(k)=qc_bl(i,k,j) qi_bl1D_old(k)=qi_bl(i,k,j) + else + CLDFRA_BL1D(k)=0.0 + QC_BL1D(k)=0.0 + QI_BL1D(k)=0.0 + cldfra_bl1D_old(k)=0.0 + qc_bl1D_old(k)=0.0 + qi_bl1D_old(k)=0.0 ENDIF dz1(k)= dz(i,k,j) u1(k) = u(i,k,j) @@ -4591,7 +4902,7 @@ SUBROUTINE mynn_bl_driver( & & - xlscp/exner(i,k,j)*sqi9 ENDIF thetav(k)=th(i,k,j)*(1.+0.608*sqv(k)) - thvl(k)=thlsg(k)*(1.+0.61*sqv(k)) + thvl(k) =thlsg(k) *(1.+0.608*sqv(k)) IF (PRESENT(qni) .AND. FLAG_QNI ) THEN qni1(k)=qni(i,k,j) @@ -4649,6 +4960,18 @@ SUBROUTINE mynn_bl_driver( & s_awqni1(k)=0. s_awqnwfa1(k)=0. s_awqnifa1(k)=0. + ![EWDD] + edmf_a_dd1(k)=0.0 + edmf_w_dd1(k)=0.0 + edmf_qc_dd1(k)=0.0 + sd_aw1(k)=0. + sd_awthl1(k)=0. + sd_awqt1(k)=0. + sd_awqv1(k)=0. + sd_awqc1(k)=0. + sd_awu1(k)=0. + sd_awv1(k)=0. + sd_awqke1(k)=0. sub_thl(k)=0. sub_sqv(k)=0. sub_u(k)=0. @@ -4660,7 +4983,7 @@ SUBROUTINE mynn_bl_driver( & det_v(k)=0. #if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN + IF ( mynn_chem_vertmx ) THEN IF (PRESENT(chem3d) .AND. PRESENT(vd3d)) THEN ! WA 7/29/15 Set up chemical arrays DO ic = 1,nchem @@ -4707,6 +5030,14 @@ SUBROUTINE mynn_bl_driver( & s_awqni1(kte+1)=0. s_awqnwfa1(kte+1)=0. s_awqnifa1(kte+1)=0. + sd_aw1(kte+1)=0. + sd_awthl1(kte+1)=0. + sd_awqt1(kte+1)=0. + sd_awqv1(kte+1)=0. + sd_awqc1(kte+1)=0. + sd_awu1(kte+1)=0. + sd_awv1(kte+1)=0. + sd_awqke1(kte+1)=0. #if (WRF_CHEM == 1) DO ic = 1,nchem s_awchem1(kte+1,ic)=0. @@ -4743,42 +5074,44 @@ SUBROUTINE mynn_bl_driver( & !----------------------------------------------------- ! Katata-added - The deposition velocity of cloud (fog) ! water is used instead of CH. - flt = hfx(i,j)/( rho(i,kts,j)*cpm ) & - & +xlvcp*vdfg(i,j)*(sqc(kts)/exner(i,kts,j)- sqcg/exnerg) - flq = qfx(i,j)/ rho(i,kts,j) & - & -vdfg(i,j)*(sqc(kts) - sqcg ) -!JOE-test- should this be after the call to mym_condensation?-using old vt & vq -!same as original form -! flt = flt + xlvcp*ch(i,j)*(sqc(kts)/exner(i,kts,j) -sqcg/exnerg) - flqv = qfx(i,j)/rho(i,kts,j) + !flt = hfx(i,j)/( rho(i,kts,j)*cpm ) & + ! & +xlvcp*vdfg(i,j)*(sqc(kts)/exner(i,kts,j)- sqcg/exnerg) + !flq = qfx(i,j)/ rho(i,kts,j) & + ! & -vdfg(i,j)*(sqc(kts) - sqcg ) + !----------------------------------------------------- + flqv = qfx(i,j)/rho1(kts) flqc = -vdfg(i,j)*(sqc(kts) - sqcg ) th_sfc = ts(i,j)/ex1(kts) + ! TURBULENT FLUX FOR TKE BOUNDARY CONDITIONS + flq =flqv+flqc !! LATENT + flt =hfx(i,j)/(rho1(kts)*cpm )-xlvcp*flqc/exner(i,kts,j) !! Temperature flux + fltv=flt + flqv*ep_1*th_sfc !! Virtual temperature flux + + ! Update 1/L using updated sfc heat flux and friction velocity + rmol(i,j) = -vk*gtr*fltv/max(ust(i,j)**3,1.0e-6) zet = 0.5*dz(i,kts,j)*rmol(i,j) - if ( zet >= 0.0 ) then - pmz = 1.0 + (cphm_st-1.0) * zet - phh = 1.0 + cphh_st * zet + zet = MAX(zet, -20.) + zet = MIN(zet, 20.) + if (bl_mynn_stfunc == 0) then + !Original Kansas-type stability functions + if ( zet >= 0.0 ) then + pmz = 1.0 + (cphm_st-1.0) * zet + phh = 1.0 + cphh_st * zet + else + pmz = 1.0/ (1.0-cphm_unst*zet)**0.25 - zet + phh = 1.0/SQRT(1.0-cphh_unst*zet) + end if else - pmz = 1.0/ (1.0-cphm_unst*zet)**0.25 - zet - phh = 1.0/SQRT(1.0-cphh_unst*zet) + !Updated stability functions (Puhales, 2020) + phi_m = phim(zet) + pmz = phi_m - zet + phh = phih(zet) end if - !-- Estimate wstar & delta for GRIMS shallow-cu------- - govrth = g/th1(kts) - sflux = hfx(i,j)/rho(i,kts,j)/cpm + & - qfx(i,j)/rho(i,kts,j)*ep_1*th1(kts) - bfx0 = max(sflux,0.) - wstar3 = (govrth*bfx0*pblh(i,j)) - wstar(i,j) = wstar3**h1 - wm3 = wstar3 + 5.*ust(i,j)**3. - wm2 = wm3**h2 - delb = govrth*d3*pblh(i,j) - delta(i,j) = min(d1*pblh(i,j) + d2*wm2/delb, 100.) - !-- End GRIMS----------------------------------------- - !> - Call mym_condensation() to calculate the nonconvective component !! of the subgrid cloud fraction and mixing ratio as well as the functions -!! used to calculate the buoyancy flux. Different cloud PDFs can be +!! used to calculate the buoyancy flux. Different cloud PDFs can be !! selected by use of the namelist parameter \p bl_mynn_cloudpdf. CALL mym_condensation ( kts,kte, & @@ -4790,103 +5123,20 @@ SUBROUTINE mynn_bl_driver( & &Vt, Vq, th1, sgm, rmol(i,j), & &spp_pbl, rstoch_col ) - !ADD TKE source driven by cloud top cooling -!> - Calculate the buoyancy production of TKE from cloud-top cooling when +!> - Add TKE source driven by cloud top cooling +!! Calculate the buoyancy production of TKE from cloud-top cooling when !! \p bl_mynn_topdown =1. IF (bl_mynn_topdown.eq.1)then - cloudflg=.false. - minrad=100. - kminrad=kpbl(i,j) - zminrad=PBLH(i,j) - KHtopdown(kts:kte)=0.0 - TKEprodTD(kts:kte)=0.0 - maxKHtopdown(i,j)=0.0 - !CHECK FOR STRATOCUMULUS-TOPPED BOUNDARY LAYERS - DO kk = MAX(1,kpbl(i,j)-2),kpbl(i,j)+3 - if(sqc(kk).gt. 1.e-6 .OR. sqi(kk).gt. 1.e-6 .OR. & - cldfra_bl1D(kk).gt.0.5) then - cloudflg=.true. - endif - if(rthraten(i,kk,j) < minrad)then - minrad=rthraten(i,kk,j) - kminrad=kk - zminrad=zw(kk) + 0.5*dz1(kk) - endif - ENDDO - IF (MAX(kminrad,kpbl(i,j)) < 2)cloudflg = .false. - IF (cloudflg) THEN - zl1 = dz1(kts) - k = MAX(kpbl(i,j)-1, kminrad-1) - !Best estimate of height of TKE source (top of downdrafts): - !zminrad = 0.5*pblh(i,j) + 0.5*zminrad - - templ=thl(k)*ex1(k) - !rvls is ws at full level - rvls=100.*6.112*EXP(17.67*(templ-273.16)/(templ-29.65))*(ep_2/p1(k+1)) - temps=templ + (sqw(k)-rvls)/(cp/xlv + ep_2*xlv*rvls/(rd*templ**2)) - rvls=100.*6.112*EXP(17.67*(temps-273.15)/(temps-29.65))*(ep_2/p1(k+1)) - rcldb=max(sqw(k)-rvls,0.) - - !entrainment efficiency - dthvx = (thl(k+2) + th1(k+2)*ep_1*sqw(k+2)) & - - (thl(k) + th1(k) *ep_1*sqw(k)) - dthvx = max(dthvx,0.1) - tmp1 = xlvcp * rcldb/(ex1(k)*dthvx) - !Originally from Nichols and Turton (1986), where a2 = 60, but lowered - !here to 8, as in Grenier and Bretherton (2001). - ent_eff = 0.2 + 0.2*8.*tmp1 - - radsum=0. - DO kk = MAX(1,kpbl(i,j)-3),kpbl(i,j)+3 - radflux=rthraten(i,kk,j)*ex1(kk) !converts theta/s to temp/s - radflux=radflux*cp/g*(p1(kk)-p1(kk+1)) ! converts temp/s to W/m^2 - if (radflux < 0.0 ) radsum=abs(radflux)+radsum - ENDDO - - !More strict limits over land to reduce stable-layer mixouts - if ((xland(i,j)-1.5).GE.0)THEN ! WATER - radsum=MIN(radsum,90.0) - bfx0 = max(radsum/rho1(k)/cp,0.) - else ! LAND - radsum=MIN(0.25*radsum,30.0)!practically turn off over land - bfx0 = max(radsum/rho1(k)/cp - max(sflux,0.0),0.) - endif - - !entrainment from PBL top thermals - wm3 = g/thetav(k)*bfx0*MIN(pblh(i,j),1500.) ! this is wstar3(i) - wm2 = wm2 + wm3**h2 - bfxpbl = - ent_eff * bfx0 - dthvx = max(thetav(k+1)-thetav(k),0.1) - we = max(bfxpbl/dthvx,-sqrt(wm3**h2)) - - DO kk = kts,kpbl(i,j)+3 - !Analytic vertical profile - zfac(kk) = min(max((1.-(zw(kk+1)-zl1)/(zminrad-zl1)),zfmin),1.) - zfacent(kk) = 10.*MAX((zminrad-zw(kk+1))/zminrad,0.0)*(1.-zfac(kk))**3 - - !Calculate an eddy diffusivity profile (not used at the moment) - wscalek2(kk) = (phifac*karman*wm3*(zfac(kk)))**h1 - !Modify shape of KH to be similar to Lock et al (2000): use pfac = 3.0 - KHtopdown(kk) = wscalek2(kk)*karman*(zminrad-zw(kk+1))*(1.-zfac(kk))**3 !pfac - KHtopdown(kk) = MAX(KHtopdown(kk),0.0) - !Do not include xkzm at kpbl-1 since it changes entrainment - !if (kk.eq.kpbl(i,j)-1 .and. cloudflg .and. we.lt.0.0) then - ! KHtopdown(kk) = 0.0 - !endif - - !Calculate TKE production = 2(g/TH)(w'TH'), where w'TH' = A(TH/g)wstar^3/PBLH, - !A = ent_eff, and wstar is associated with the radiative cooling at top of PBL. - !An analytic profile controls the magnitude of this TKE prod in the vertical. - TKEprodTD(kk)=2.*ent_eff*wm3/MAX(pblh(i,j),100.)*zfacent(kk) - TKEprodTD(kk)= MAX(TKEprodTD(kk),0.0) - ENDDO - ENDIF !end cloud check - maxKHtopdown(i,j)=MAXVAL(KHtopdown(:)) + CALL topdown_cloudrad(kts,kte,dz1,zw, & + &xland(i,j),kpbl(i,j),PBLH(i,j), & + &sqc,sqi,sqw,thl,th1,ex1,p1,rho1,thetav, & + &cldfra_bl1D,rthraten, & + &maxKHtopdown(i,j),KHtopdown,TKEprodTD ) ELSE - maxKHtopdown(i,j)=0.0 + maxKHtopdown(i,j) = 0.0 KHtopdown(kts:kte) = 0.0 - TKEprodTD(kts:kte)=0.0 - ENDIF !end top-down check + TKEprodTD(kts:kte) = 0.0 + ENDIF IF (bl_mynn_edmf > 0) THEN !PRINT*,"Calling DMP Mass-Flux: i= ",i," j=",j @@ -4919,6 +5169,7 @@ SUBROUTINE mynn_bl_driver( & & det_u,det_v, & #if (WRF_CHEM == 1) & nchem,chem1,s_awchem1, & + & mynn_chem_vertmx, & #endif & qc_bl1D,cldfra_bl1D, & & qc_bl1D_old,cldfra_bl1D_old, & @@ -4928,22 +5179,36 @@ SUBROUTINE mynn_bl_driver( & & Psig_shcu(i,j), & & nupdraft(i,j),ktop_plume(i,j), & & maxmf(i,j),ztop_plume, & - & spp_pbl,rstoch_col & - ) + & spp_pbl,rstoch_col ) + ENDIF + IF (bl_mynn_edmf_dd == 1) THEN + CALL DDMF_JPL(kts,kte,delt,zw,dz1,p1, & + &u1,v1,th1,thl,thetav,tk1, & + sqw,sqv,sqc,rho1,ex1, & + &ust(i,j),flt,flq, & + &PBLH(i,j),KPBL(i,j), & + &edmf_a_dd1,edmf_w_dd1,edmf_qt_dd1, & + &edmf_thl_dd1,edmf_ent_dd1, & + &edmf_qc_dd1, & + &sd_aw1,sd_awthl1,sd_awqt1, & + &sd_awqv1,sd_awqc1,sd_awu1,sd_awv1, & + &sd_awqke1, & + &qc_bl1d,cldfra_bl1d, & + &rthraten(i,:,j) ) ENDIF !> - Call mym_turbulence() to collect the necessary variable !! to carry out successive claculations. CALL mym_turbulence ( & - &kts,kte,levflag, & + &kts,kte,closure, & &dz1, DX(i,j), zw, & &u1, v1, thl, sqc, sqw, & &qke1, tsq1, qsq1, cov1, & &vt, vq, & &rmol(i,j), flt, flq, & &PBLH(i,j),th1, & - &Sh,el, & + &Sh,Sm,el, & &Dfm,Dfh,Dfq, & &Tcd,Qcd,Pdk, & &Pdt,Pdq,Pdc, & @@ -4958,27 +5223,29 @@ SUBROUTINE mynn_bl_driver( & !> - Call mym_predict() to solve TKE and !! \f$\theta^{'2}, q^{'2}, and \theta^{'}q^{'}\f$ !! for the following time step. - CALL mym_predict (kts,kte,levflag, & + CALL mym_predict (kts,kte,closure, & &delt, dz1, & &ust(i,j), flt, flq, pmz, phh, & - &el, dfq, pdk, pdt, pdq, pdc, & + &el, dfq, rho1, pdk, pdt, pdq, pdc,& &Qke1, Tsq1, Qsq1, Cov1, & - &s_aw1, s_awqke1, bl_mynn_edmf_tke) + &s_aw1, s_awqke1, bl_mynn_edmf_tke,& + &qWT1, qDISS1,bl_mynn_tkebudget) !! TKE budget (Puhales, 2020) DO k=kts,kte-1 - ! Set max dissipative heating rate close to 0.1 K per hour (=0.000027...) - diss_heat(k) = MIN(MAX(twothirds*(qke1(k)**1.5)/(b1*MAX(0.5*(el(k)+el(k+1)),1.))/cp, 0.0),0.00003) + ! Set max dissipative heating rate to 7.2 K per hour + diss_heat(k) = MIN(MAX(0.75*(qke1(k)**1.5)/(b1*MAX(0.5*(el(k)+el(k+1)),1.))/cp, 0.0),0.002) ENDDO diss_heat(kte) = 0. !> - Call mynn_tendencies() to solve for tendencies of !! \f$U, V, \theta, q_{v}, q_{c}, and q_{i}\f$. CALL mynn_tendencies(kts,kte, & - &levflag,grav_settling, & + &closure,grav_settling, & &delt, dz1, rho1, & &u1, v1, th1, tk1, qv1, & &qc1, qi1, qnc1, qni1, & - &p1, ex1, thl, sqv, sqc, sqi, sqw,& + &ps(i,j), p1, ex1, thl, & + &sqv, sqc, sqi, sqw, & &qnwfa1, qnifa1, ozone1, & &ust(i,j),flt,flq,flqv,flqc, & &wspd(i,j),qcg(i,j), & @@ -4995,6 +5262,8 @@ SUBROUTINE mynn_bl_driver( & &s_awqv1,s_awqc1,s_awu1,s_awv1, & &s_awqnc1,s_awqni1, & &s_awqnwfa1,s_awqnifa1, & + &sd_aw1,sd_awthl1,sd_awqt1, & + &sd_awqv1,sd_awqc1,sd_awu1,sd_awv1,& &sub_thl,sub_sqv, & &sub_u,sub_v, & &det_thl,det_sqv,det_sqc, & @@ -5009,29 +5278,36 @@ SUBROUTINE mynn_bl_driver( & &bl_mynn_mixscalars ) #if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN - CALL mynn_mix_chem(kts,kte, & - levflag,grav_settling, & - delt, dz1, & + IF ( mynn_chem_vertmx ) THEN + CALL mynn_mix_chem(kts,kte,i,j, & + grav_settling, & + delt, dz1, pblh(i,j), & nchem, kdvel, ndvel, num_vert_mix, & chem1, vd1, & qnc1,qni1, & p1, ex1, thl, sqv, sqc, sqi, sqw,& - ust(i,j),flt,flq,flqv,flqc, & + rho1, ust(i,j),flt,flq,flqv,flqc,& wspd(i,j),qcg(i,j), & - uoce(i,j),voce(i,j), & - tsq1, qsq1, cov1, & tcd, qcd, & &dfm, dfh, dfq, & ! mass flux components & s_aw1, & & s_awchem1, & - &bl_mynn_cloudmix) + &bl_mynn_cloudmix, & + EMIS_ANT_NO(i,j), & + FRP_MEAN(i,j), & + enh_vermix) + IF (PRESENT(chem3d) ) THEN + DO ic = 1,nchem + DO k = kts,kte + chem3d(i,k,j,ic) = chem1(k,ic) + ENDDO + ENDDO + ENDIF ENDIF #endif -!> - Call retrieve_exchange_coeffs() to retrieve K_m1 -!! and K_h1. + CALL retrieve_exchange_coeffs(kts,kte,& &dfm, dfh, dz1, K_m1, K_h1) @@ -5101,13 +5377,26 @@ SUBROUTINE mynn_bl_driver( & ENDDO !end-k IF ( bl_mynn_tkebudget == 1) THEN - DO k = kts,kte - dqke(i,k,j) = (qke1(k)-dqke(i,k,j))*0.5 !qke->tke - qWT(i,k,j) = qWT1(k)*delt - qSHEAR(i,k,j)= qSHEAR1(k)*delt - qBUOY(i,k,j) = qBUOY1(k)*delt - qDISS(i,k,j) = qDISS1(k)*delt + !! TKE budget is now given in m**2/s**-3 (Puhales, 2020) + !! Lower boundary condtions (using similarity relationships such as the prognostic equation for Qke) + k=kts + qSHEAR1(k)=4.*(ust(i,j)**3*phi_m/(vk*dz(i,k,j)))-qSHEAR1(k+1) !! staggered + qBUOY1(k)=4.*(-ust(i,j)**3*zet/(vk*dz(i,k,j)))-qBUOY1(k+1) !! staggered + !! unstaggering SHEAR and BUOY and trasfering all TKE budget to 3D array + DO k = kts,kte-1 + qSHEAR(i,k,j)=0.5*(qSHEAR1(k)+qSHEAR1(k+1)) !!! unstaggering in z + qBUOY(i,k,j)=0.5*(qBUOY1(k)+qBUOY1(k+1)) !!! unstaggering in z + qWT(i,k,j)=qWT1(k) + qDISS(i,k,j)=qDISS1(k) + dqke(i,k,j)=(qke1(k)-dqke(i,k,j))*0.5/delt ENDDO + !! Upper boundary conditions + k=kte + qSHEAR(i,k,j)=0. + qBUOY(i,k,j)=0. + qWT(i,k,j)=0. + qDISS(i,k,j)=0. + dqke(i,k,j)=0. ENDIF !update updraft properties @@ -5124,6 +5413,15 @@ SUBROUTINE mynn_bl_driver( & det_thl3D(i,k)=det_thl(k) det_sqv3D(i,k)=det_sqv(k) ENDDO + if (bl_mynn_edmf_dd > 0) THEN + !update downdraft properties + edmf_a_dd(i,k)=edmf_a_dd1(k) + edmf_w_dd(i,k)=edmf_w_dd1(k) + edmf_qt_dd(i,k)=edmf_qt_dd1(k) + edmf_thl_dd(i,k)=edmf_thl_dd1(k) + edmf_ent_dd(i,k)=edmf_ent_dd1(k) + edmf_qc_dd(i,k)=edmf_qc_dd1(k) + ENDIF ENDIF !*** Begin debug prints @@ -5441,7 +5739,7 @@ SUBROUTINE DMP_mf( & & scalar_opt, & & u,v,w,th,thl,thv,tk, & & qt,qv,qc,qke, & - qnc,qni,qnwfa,qnifa, & + & qnc,qni,qnwfa,qnifa, & & exner,vt,vq,sgm, & & ust,flt,flq,flqv,flqc, & & pblh,kpbl,DX,landsea,ts, & @@ -5461,6 +5759,7 @@ SUBROUTINE DMP_mf( & & det_u,det_v, & #if (WRF_CHEM == 1) & nchem,chem,s_awchem, & + & mynn_chem_vertmx, & #endif ! in/outputs - subgrid scale clouds & qc_bl1d,cldfra_bl1d, & @@ -5489,7 +5788,7 @@ SUBROUTINE DMP_mf( & REAL,DIMENSION(KTS:KTE), INTENT(IN) :: U,V,W,TH,THL,TK,QT,QV,QC,& exner,dz,THV,P,qke,qnc,qni,qnwfa,qnifa - REAL,DIMENSION(KTS:KTE+1), INTENT(IN) :: ZW !height at full-sigma + REAL,DIMENSION(KTS:KTE+1), INTENT(IN) :: ZW !height at full-sigma REAL, INTENT(IN) :: DT,UST,FLT,FLQ,FLQV,FLQC,PBLH,& DX,Psig_shcu,landsea,ts LOGICAL, OPTIONAL :: F_QC,F_QI,F_QNC,F_QNI,F_QNWFA,F_QNIFA @@ -5567,6 +5866,7 @@ SUBROUTINE DMP_mf( & REAL,DIMENSION(KTS:KTE+1,1:NUP, nchem) :: UPCHEM INTEGER :: ic REAL,DIMENSION(KTS:KTE+1, nchem) :: edmf_chem + LOGICAL, INTENT(IN) :: mynn_chem_vertmx #endif !JOE: add declaration of ERF @@ -5604,8 +5904,8 @@ SUBROUTINE DMP_mf( & envm_u,envm_v !environmental variables defined at middle of layer REAL,DIMENSION(KTS:KTE+1) :: envi_a,envi_w !environmental variables defined at model interface REAL :: temp,sublim,qc_ent,qv_ent,qt_ent,thl_ent,detrate, & - detrateUV,oow,exc_fac,aratio,detturb,qc_grid - REAL, PARAMETER :: Cdet = 1./45. + detrateUV,oow,exc_fac,aratio,detturb,qc_grid,qc_sgs + REAL, PARAMETER :: Cdet = 1./45. REAL, PARAMETER :: dzpmax = 300. !limit dz used in detrainment - can be excessing in thick layers !parameter "Csub" determines the propotion of upward vertical velocity that contributes to !environmenatal subsidence. Some portion is expected to be compensated by downdrafts instead of @@ -5613,6 +5913,10 @@ SUBROUTINE DMP_mf( & !is compensated by "gentle" environmental subsidence. REAL, PARAMETER :: Csub=0.25 + !Factor for the pressure gradient effects on momentum transport + REAL, PARAMETER :: pgfac = 0.00 ! Zhang and Wu showed 0.4 is more appropriate for lower troposphere + REAL :: Uk,Ukm1,Vk,Vkm1,dxsa + ! check the inputs ! print *,'dt',dt ! print *,'dz',dz @@ -5641,7 +5945,7 @@ SUBROUTINE DMP_mf( & UPQNWFA=0. UPQNIFA=0. #if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN + IF ( mynn_chem_vertmx ) THEN UPCHEM(KTS:KTE+1,1:NUP,1:nchem)=0.0 ENDIF #endif @@ -5654,7 +5958,7 @@ SUBROUTINE DMP_mf( & edmf_ent=0. edmf_qc =0. #if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN + IF ( mynn_chem_vertmx ) THEN edmf_chem(kts:kte+1,1:nchem) = 0.0 ENDIF #endif @@ -5672,7 +5976,7 @@ SUBROUTINE DMP_mf( & s_awqnwfa=0. s_awqnifa=0. #if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN + IF ( mynn_chem_vertmx ) THEN s_awchem(kts:kte+1,1:nchem) = 0.0 ENDIF #endif @@ -5704,7 +6008,9 @@ SUBROUTINE DMP_mf( & IF(ZW(k)<=50.)k50=k !Search for cloud base - IF(qc(k)>1E-5 .AND. cloud_base == 9000.0)THEN + qc_sgs = MAX(qc(k), qc_bl1d(k)*cldfra_bl1d(k)) + !IF(qc(k) >1E-5 .AND. cloud_base == 9000.0)THEN + IF(qc_sgs> 1E-5 .AND. cloud_base == 9000.0)THEN cloud_base = 0.5*(ZW(k)+ZW(k+1)) ENDIF @@ -5875,7 +6181,7 @@ SUBROUTINE DMP_mf( & ENDDO #if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN + IF ( mynn_chem_vertmx ) THEN DO I=1,NUP !NUP2 IF(I > NUP2) exit do ic = 1,nchem @@ -5894,6 +6200,9 @@ SUBROUTINE DMP_mf( & envm_v(k)=V(k) ENDDO + !dxsa is scale-adaptive factor governing the pressure-gradient term of the momentum transport + dxsa = 1. - MIN(MAX((12000.0-dx)/(12000.0-3000.0), 0.), 1.) + !QCn = 0. ! do integration updraft DO I=1,NUP !NUP2 @@ -5921,12 +6230,18 @@ SUBROUTINE DMP_mf( & ENT(k,i) = min(ENT(k,i),0.9/(ZW(k+1)-ZW(k))) + ! Define environment U & V at the model interface levels + Uk =(U(k)*DZ(k+1)+U(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) + Ukm1=(U(k-1)*DZ(k)+U(k)*DZ(k-1))/(DZ(k-1)+DZ(k)) + Vk =(V(k)*DZ(k+1)+V(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) + Vkm1=(V(k-1)*DZ(k)+V(k)*DZ(k-1))/(DZ(k-1)+DZ(k)) + ! Linear entrainment: EntExp= ENT(K,I)*(ZW(k+1)-ZW(k)) QTn =UPQT(k-1,I) *(1.-EntExp) + QT(k)*EntExp THLn=UPTHL(k-1,I)*(1.-EntExp) + THL(k)*EntExp - Un =UPU(k-1,I) *(1.-EntExp) + U(k)*EntExp - Vn =UPV(k-1,I) *(1.-EntExp) + V(k)*EntExp + Un =UPU(k-1,I) *(1.-EntExp) + U(k)*EntExp + dxsa*pgfac*(Uk - Ukm1) + Vn =UPV(k-1,I) *(1.-EntExp) + V(k)*EntExp + dxsa*pgfac*(Vk - Vkm1) QKEn=UPQKE(k-1,I)*(1.-EntExp) + QKE(k)*EntExp QNCn=UPQNC(k-1,I)*(1.-EntExp) + QNC(k)*EntExp QNIn=UPQNI(k-1,I)*(1.-EntExp) + QNI(k)*EntExp @@ -5948,7 +6263,7 @@ SUBROUTINE DMP_mf( & !QKEn=QKE(k)*(1-EntExp)+UPQKE(K-1,I)*EntExp #if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN + IF ( mynn_chem_vertmx ) THEN do ic = 1,nchem ! Exponential Entrainment: !chemn(ic) = chem(k,ic)*(1-EntExp)+UPCHEM(K-1,I,ic)*EntExp @@ -5998,6 +6313,46 @@ SUBROUTINE DMP_mf( & Wn = UPW(K-1,I) - MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0) ENDIF Wn = MIN(MAX(Wn,0.0), 3.0) +! WA TEST 5/7/20 for accelerating plumes above cloud base, add entrainment +! and recalculate updraft variables + IF (QCn > 0.0 .AND. Wn > UPW(K-1,I)) THEN + ENT = ENT * 2.0 + EntExp= ENT(K,I)*(ZW(k+1)-ZW(k)) + QTn =UPQT(k-1,I) *(1.-EntExp) + QT(k)*EntExp + THLn=UPTHL(k-1,I)*(1.-EntExp) + THL(k)*EntExp + Un =UPU(k-1,I) *(1.-EntExp) + U(k)*EntExp + Vn =UPV(k-1,I) *(1.-EntExp) + V(k)*EntExp + QKEn=UPQKE(k-1,I)*(1.-EntExp) + QKE(k)*EntExp + QNCn=UPQNC(k-1,I)*(1.-EntExp) + QNC(k)*EntExp + QNIn=UPQNI(k-1,I)*(1.-EntExp) + QNI(k)*EntExp + QNWFAn=UPQNWFA(k-1,I)*(1.-EntExp) + QNWFA(k)*EntExp + QNIFAn=UPQNIFA(k-1,I)*(1.-EntExp) + QNIFA(k)*EntExp + ! Define pressure at model interface + Pk =(P(k)*DZ(k+1)+P(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) + ! Compute new plume properties thvn and qcn + call condensation_edmf(QTn,THLn,Pk,ZW(k+1),THVn,QCn) + ! Define environment THV at the model interface levels + THVk =(THV(k)*DZ(k+1)+THV(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) + THVkm1=(THV(k-1)*DZ(k)+THV(k)*DZ(k-1))/(DZ(k-1)+DZ(k)) + B=g*(THVn/THVk - 1.0) + IF(B>0.)THEN + BCOEFF = 0.15 + ELSE + BCOEFF = 0.2 !0.33 + ENDIF + + IF (UPW(K-1,I) < 0.2 ) THEN + Wn = UPW(K-1,I) + (-2. * ENT(K,I) * UPW(K-1,I) + BCOEFF*B / MAX(UPW(K-1,I),0.2)) * MIN(ZW(k)-ZW(k-1), 250.) + ELSE + Wn = UPW(K-1,I) + (-2. * ENT(K,I) * UPW(K-1,I) + BCOEFF*B / UPW(K-1,I)) * MIN(ZW(k)-ZW(k-1), 250.) + ENDIF + IF (UPW(K-1,I) < 0.2 ) THEN + Wn = UPW(K-1,I) + (-2. * ENT(K,I) * UPW(K-1,I) + BCOEFF*B / MAX(UPW(K-1,I),0.2)) * MIN(ZW(k)-ZW(k-1), 250.) + ELSE + Wn = UPW(K-1,I) + (-2. * ENT(K,I) * UPW(K-1,I) + BCOEFF*B / UPW(K-1,I)) * MIN(ZW(k)-ZW(k-1), 250.) + ENDIF + ENDIF +! END WA TEST !Check to make sure that the plume made it up at least one level. !if it failed, then set nup2=0 and exit the mass-flux portion. IF (k==kts+1 .AND. Wn == 0.) THEN @@ -6081,7 +6436,7 @@ SUBROUTINE DMP_mf( & UPQNIFA(K,I)=QNIFAn UPA(K,I)=UPA(K-1,I) #if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN + IF ( mynn_chem_vertmx ) THEN do ic = 1,nchem UPCHEM(k,I,ic) = chemn(ic) enddo @@ -6146,7 +6501,7 @@ SUBROUTINE DMP_mf( & s_awqv(k+1) = s_awqt(k+1) - s_awqc(k+1) ENDDO #if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN + IF ( mynn_chem_vertmx ) THEN DO k=KTS,KTE IF(k > KTOP) exit DO i=1,NUP !NUP2 @@ -6205,7 +6560,7 @@ SUBROUTINE DMP_mf( & s_awqke= s_awqke*adjustment ENDIF #if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN + IF ( mynn_chem_vertmx ) THEN s_awchem = s_awchem*adjustment ENDIF #endif @@ -6226,7 +6581,7 @@ SUBROUTINE DMP_mf( & edmf_ent(K)=edmf_ent(K)+UPA(K,i)*ENT(K,i) edmf_qc(K) =edmf_qc(K) +UPA(K,i)*UPQC(K,i) #if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN + IF ( mynn_chem_vertmx ) THEN do ic = 1,nchem edmf_chem(k,ic) = edmf_chem(k,ic) + UPA(K,I)*UPCHEM(k,i,ic) enddo @@ -6243,7 +6598,7 @@ SUBROUTINE DMP_mf( & edmf_ent(k)=edmf_ent(k)/edmf_a(k) edmf_qc(k)=edmf_qc(k)/edmf_a(k) #if (WRF_CHEM == 1) - IF (bl_mynn_mixchem == 1) THEN + IF ( mynn_chem_vertmx ) THEN do ic = 1,nchem edmf_chem(k,ic) = edmf_chem(k,ic)/edmf_a(k) enddo @@ -6308,6 +6663,7 @@ SUBROUTINE DMP_mf( & det_sqv(k)=Cdet*(envm_sqv(k)-qv(k))*envi_a(k)*Psig_w det_sqc(k)=Cdet*(envm_sqc(k)-qc(k))*envi_a(k)*Psig_w ENDDO + IF (momentum_opt > 0) THEN sub_u(kts)=0.5*envi_w(kts)*envi_a(kts)*(u(kts+1)-u(kts))/dzi(kts) sub_v(kts)=0.5*envi_w(kts)*envi_a(kts)*(v(kts+1)-v(kts))/dzi(kts) @@ -6397,11 +6753,11 @@ SUBROUTINE DMP_mf( & sigq = 9.E-3 * 0.5*(edmf_a(k)+edmf_a(k-1)) * & & 0.5*(edmf_w(k)+edmf_w(k-1)) * f ! convective component of sigma (CB2005) - !sigq = MAX(sigq, 1.0E-4) sigq = SQRT(sigq**2 + sgm(k)**2) ! combined conv + stratus components + sigq = MAX(sigq, 1.0E-6) qmq = a * (qt(k) - qsat_tl) ! saturation deficit/excess; - ! the numerator of Q1 + ! the numerator of Q1 mf_cf = min(max(0.5 + 0.36 * atan(1.55*(qmq/sigq)),0.01),0.6) IF ( debug_code ) THEN print*,"In MYNN, StEM edmf" @@ -6442,7 +6798,7 @@ SUBROUTINE DMP_mf( & qc_bl1d(k) = (QCp*Ac_mf + QCs*Ac_strat)/cldfra_bl1d(k) ENDIF ELSE - Ac_mf = mf_cf + Ac_mf = mf_cf ENDIF !Now recalculate the terms for the buoyancy flux for mass-flux clouds: @@ -6451,7 +6807,7 @@ SUBROUTINE DMP_mf( & !following RAP and HRRR testing. !Fng = 2.05 ! the non-Gaussian transport factor (assumed constant) !Use Bechtold and Siebesma (1998) piecewise estimation of Fng: - Q1 = qmq/MAX(sigq,1E-10) + Q1 = qmq/MAX(sigq,1E-6) Q1=MAX(Q1,-5.0) IF (Q1 .GE. 1.0) THEN Fng = 1.0 @@ -6466,7 +6822,6 @@ SUBROUTINE DMP_mf( & vt(k) = qww - MIN(0.40,Ac_mf)*beta*bb*Fng - 1. vq(k) = alpha + MIN(0.40,Ac_mf)*beta*a*Fng - tv0 ENDIF - ENDDO ENDIF !end nup2 > 0 @@ -6589,17 +6944,417 @@ subroutine condensation_edmf(QT,THL,P,zagl,THV,QC) end subroutine condensation_edmf !=============================================================== -!>\ingroup gsd_mynn_edmf -!! This subroutine calculates the similarity functions, -!!\f$P_{\sigma-PBL}\f$ and \f$P_{\sigma-shcu}\f$, to control the -!! scale-adaptive behavior for the local and nonlocal components, -!! respectively. -!! -!! NOTES ON SCALE-AWARE FORMULATION: -!!JOE: add scale-aware factor (Psig) here, taken from Honnert et al. (2011, -!! JAS) and/or from Hyeyum Hailey Shin and Song-You Hong (2013, JAS) + +subroutine condensation_edmf_r(QT,THL,P,zagl,THV,QC) +! +! zero or one condensation for edmf: calculates THL and QC +! similar to condensation_edmf but with different inputs +! +real,intent(in) :: QT,THV,P,zagl +real,intent(out) :: THL, QC + +integer :: niter,i +real :: diff,exn,t,th,qs,qcold + +! number of iterations + niter=50 +! minimum difference + diff=2.e-5 + + EXN=(P/p1000mb)**rcp + ! assume first that th = thv + T = THV*EXN + !QS = qsat_blend(T,P) + !QC = QS - QT + + QC=0. + + do i=1,NITER + QCOLD = QC + T = EXN*THV/(1.+QT*(rvovrd-1.)-rvovrd*QC) + QS=qsat_blend(T,P) + QC= MAX((QT-QS),0.) + if (abs(QC-QCOLD)0) then +! Wn2=DOWNW(K+1,I)**2*EntW - Wa*B/Beta_dm * (1. - EntW) +! else +! Wn2=DOWNW(K+1,I)**2 - 2.*Wa*B*deltaZ +! end if + + mindownw = MIN(DOWNW(K+1,I),-0.2) + Wn = DOWNW(K+1,I) + (-2.*ENT(K,I)*DOWNW(K+1,I) - & + BCOEFF*B/mindownw)*MIN(deltaZ, 250.) + + !Do not allow a parcel to accelerate more than 1.25 m/s over 200 m. + !Add max increase of 2.0 m/s for coarse vertical resolution. + IF(Wn < DOWNW(K+1,I) - MIN(1.25*deltaZ/200., 2.0))THEN + Wn = DOWNW(K+1,I) - MIN(1.25*deltaZ/200., 2.0) + ENDIF + !Add symmetrical max decrease in w + IF(Wn > DOWNW(K+1,I) + MIN(1.25*deltaZ/200., 2.0))THEN + Wn = DOWNW(K+1,I) + MIN(1.25*deltaZ/200., 2.0) + ENDIF + Wn = MAX(MIN(Wn,0.0), -3.0) + + print *, " k =", k, " z =", ZW(k) + print *, " entw =",ENT(K,I), " Bouy =", B + print *, " downthv =", THVn, " thvk =", thvk + print *, " downthl =", THLn, " thl =", thl(k) + print *, " downqt =", QTn , " qt =", qt(k) + print *, " downw+1 =",DOWNW(K+1,I), " Wn2 =", Wn + + IF (Wn .lt. 0.) THEN !terminate when velocity is too small + DOWNW(K,I) = Wn !-sqrt(Wn2) + DOWNTHV(K,I)= THVn + DOWNTHL(K,I)= THLn + DOWNQT(K,I) = QTn + DOWNQC(K,I) = QCn + DOWNU(K,I) = Un + DOWNV(K,I) = Vn + DOWNA(K,I) = DOWNA(K+1,I) + ELSE + !plumes must go at least 2 levels + if (DD_initK(I) - K .lt. 2) then + DOWNW(:,I) = 0.0 + DOWNTHV(:,I)= 0.0 + DOWNTHL(:,I)= 0.0 + DOWNQT(:,I) = 0.0 + DOWNQC(:,I) = 0.0 + DOWNU(:,I) = 0.0 + DOWNV(:,I) = 0.0 + endif + exit + ENDIF + ENDDO + ENDDO + endif ! end cloud flag + + DOWNW(1,:) = 0. !make sure downdraft does not go to the surface + DOWNA(1,:) = 0. + + ! Combine both moist and dry plume, write as one averaged plume + ! Even though downdraft starts at different height, average all up to qlTop + DO k=qlTop,KTS,-1 + DO I=1,NDOWN + IF (I > NDOWN) exit + edmf_a_dd(K) =edmf_a_dd(K) +DOWNA(K-1,I) + edmf_w_dd(K) =edmf_w_dd(K) +DOWNA(K-1,I)*DOWNW(K-1,I) + edmf_qt_dd(K) =edmf_qt_dd(K) +DOWNA(K-1,I)*DOWNQT(K-1,I) + edmf_thl_dd(K)=edmf_thl_dd(K)+DOWNA(K-1,I)*DOWNTHL(K-1,I) + edmf_ent_dd(K)=edmf_ent_dd(K)+DOWNA(K-1,I)*ENT(K-1,I) + edmf_qc_dd(K) =edmf_qc_dd(K) +DOWNA(K-1,I)*DOWNQC(K-1,I) + ENDDO + + IF (edmf_a_dd(k) >0.) THEN + edmf_w_dd(k) =edmf_w_dd(k) /edmf_a_dd(k) + edmf_qt_dd(k) =edmf_qt_dd(k) /edmf_a_dd(k) + edmf_thl_dd(k)=edmf_thl_dd(k)/edmf_a_dd(k) + edmf_ent_dd(k)=edmf_ent_dd(k)/edmf_a_dd(k) + edmf_qc_dd(k) =edmf_qc_dd(k) /edmf_a_dd(k) + ENDIF + ENDDO + + ! + ! computing variables needed for solver + ! + + DO k=KTS,qlTop + DO I=1,NDOWN + sd_aw(k) =sd_aw(k) +DOWNA(k,i)*DOWNW(k,i) + sd_awthl(k)=sd_awthl(k)+DOWNA(k,i)*DOWNW(k,i)*DOWNTHL(k,i) + sd_awqt(k) =sd_awqt(k) +DOWNA(k,i)*DOWNW(k,i)*DOWNQT(k,i) + sd_awqc(k) =sd_awqc(k) +DOWNA(k,i)*DOWNW(k,i)*DOWNQC(k,i) + sd_awu(k) =sd_awu(k) +DOWNA(k,i)*DOWNW(k,i)*DOWNU(k,i) + sd_awv(k) =sd_awv(k) +DOWNA(k,i)*DOWNW(k,i)*DOWNV(k,i) + ENDDO + sd_awqv(k) = sd_awqt(k) - sd_awqc(k) + ENDDO + +END SUBROUTINE DDMF_JPL +!=============================================================== + + SUBROUTINE SCALE_AWARE(dx,PBL1,Psig_bl,Psig_shcu) + !--------------------------------------------------------------- + ! NOTES ON SCALE-AWARE FORMULATION + ! + !JOE: add scale-aware factor (Psig) here, taken from Honnert et al. (2011, + ! JAS) and/or from Hyeyum Hailey Shin and Song-You Hong (2013, JAS) + ! ! Psig_bl tapers local mixing ! Psig_shcu tapers nonlocal mixing @@ -6766,6 +7521,220 @@ FUNCTION xl_blend(t) END FUNCTION xl_blend ! =================================================================== + + FUNCTION phim(zet) + !! New stability function parameters for momentum (Puhales, 2020, WRF 4.2.1) + !! The forms in unstable conditions (z/L < 0) use Grachev et al. (2000), which are a blend of + !! the classical “Kansas” forms (i.e., Paulson 1970, Dyer and Hicks 1970), valid for weakly + !! unstable conditions (−1 < z/L < 0). The stability functions for stable conditions use an + !! updated form taken from Cheng and Brutsaert (2005), which extends the validity into very + !! stable conditions [z/L ~ O(10)]. + IMPLICIT NONE + + REAL, INTENT(IN):: zet + REAL :: dummy_0,dummy_1,dummy_11,dummy_2,dummy_22,dummy_3,dummy_33,dummy_4,dummy_44,dummy_psi + REAL, PARAMETER :: am_st=6.1, bm_st=2.5, rbm_st=1./bm_st + REAL, PARAMETER :: ah_st=5.3, bh_st=1.1, rbh_st=1./bh_st + REAL, PARAMETER :: am_unst=10., ah_unst=34. + REAL :: phi_m,phim + + if ( zet >= 0.0 ) then + dummy_0=1+zet**bm_st + dummy_1=zet+dummy_0**(rbm_st) + dummy_11=1+dummy_0**(rbm_st-1)*zet**(bm_st-1) + dummy_2=(-am_st/dummy_1)*dummy_11 + phi_m = 1-zet*dummy_2 + else + dummy_0 = (1.0-cphm_unst*zet)**0.25 + phi_m = 1./dummy_0 + dummy_psi = 2.*log(0.5*(1.+dummy_0))+log(0.5*(1.+dummy_0**2))-2.*atan(dummy_0)+1.570796 + + dummy_0=(1.-am_unst*zet) ! parentesis arg + dummy_1=dummy_0**0.333333 ! y + dummy_11=-0.33333*am_unst*dummy_0**-0.6666667 ! dy/dzet + dummy_2 = 0.33333*(dummy_1**2.+dummy_1+1.) ! f + dummy_22 = 0.3333*dummy_11*(2.*dummy_1+1.) ! df/dzet + dummy_3 = 0.57735*(2.*dummy_1+1.) ! g + dummy_33 = 1.1547*dummy_11 ! dg/dzet + dummy_4 = 1.5*log(dummy_2)-1.73205*atan(dummy_3)+1.813799364 !psic + dummy_44 = (1.5/dummy_2)*dummy_22-1.73205*dummy_33/(1.+dummy_3**2)! dpsic/dzet + + dummy_0 = zet**2 + dummy_1 = 1./(1.+dummy_0) ! denon + dummy_11 = 2.*zet ! ddenon/dzet + dummy_2 = ((1-phi_m)/zet+dummy_11*dummy_4+dummy_0*dummy_44)*dummy_1 + dummy_22 = -dummy_11*(dummy_psi+dummy_0*dummy_4)*dummy_1**2 + + phi_m = 1.-zet*(dummy_2+dummy_22) + end if + + !phim = phi_m - zet + phim = phi_m + + END FUNCTION phim +! =================================================================== + + FUNCTION phih(zet) + !! New stability function parameters for heat (Puhales, 2020, WRF 4.2.1) + !! The forms in unstable conditions (z/L < 0) use Grachev et al. (2000), which are a blend of + !! the classical “Kansas” forms (i.e., Paulson 1970, Dyer and Hicks 1970), valid for weakly + !! unstable conditions (−1 < z/L < 0). The stability functions for stable conditions use an + !! updated form taken from Cheng and Brutsaert (2005), which extends the validity into very + !! stable conditions [z/L ~ O(10)]. + IMPLICIT NONE + + REAL, INTENT(IN):: zet + REAL :: dummy_0,dummy_1,dummy_11,dummy_2,dummy_22,dummy_3,dummy_33,dummy_4,dummy_44,dummy_psi + REAL, PARAMETER :: am_st=6.1, bm_st=2.5, rbm_st=1./bm_st + REAL, PARAMETER :: ah_st=5.3, bh_st=1.1, rbh_st=1./bh_st + REAL, PARAMETER :: am_unst=10., ah_unst=34. + REAL :: phh,phih + + if ( zet >= 0.0 ) then + dummy_0=1+zet**bh_st + dummy_1=zet+dummy_0**(rbh_st) + dummy_11=1+dummy_0**(rbh_st-1)*zet**(bh_st-1) + dummy_2=(-ah_st/dummy_1)*dummy_11 + phih = 1-zet*dummy_2 + else + dummy_0 = (1.0-cphh_unst*zet)**0.5 + phh = 1./dummy_0 + dummy_psi = 2.*log(0.5*(1.+dummy_0)) + + dummy_0=(1.-ah_unst*zet) ! parentesis arg + dummy_1=dummy_0**0.333333 ! y + dummy_11=-0.33333*ah_unst*dummy_0**-0.6666667 ! dy/dzet + dummy_2 = 0.33333*(dummy_1**2.+dummy_1+1.) ! f + dummy_22 = 0.3333*dummy_11*(2.*dummy_1+1.) ! df/dzet + dummy_3 = 0.57735*(2.*dummy_1+1.) ! g + dummy_33 = 1.1547*dummy_11 ! dg/dzet + dummy_4 = 1.5*log(dummy_2)-1.73205*atan(dummy_3)+1.813799364 !psic + dummy_44 = (1.5/dummy_2)*dummy_22-1.73205*dummy_33/(1.+dummy_3**2)! dpsic/dzet + + dummy_0 = zet**2 + dummy_1 = 1./(1.+dummy_0) ! denon + dummy_11 = 2.*zet ! ddenon/dzet + dummy_2 = ((1-phh)/zet+dummy_11*dummy_4+dummy_0*dummy_44)*dummy_1 + dummy_22 = -dummy_11*(dummy_psi+dummy_0*dummy_4)*dummy_1**2 + + phih = 1.-zet*(dummy_2+dummy_22) + end if + +END FUNCTION phih +! ================================================================== + SUBROUTINE topdown_cloudrad(kts,kte,dz1,zw,xland,kpbl,PBLH, & + &sqc,sqi,sqw,thl,th1,ex1,p1,rho1,thetav, & + &cldfra_bl1D,rthraten, & + &maxKHtopdown,KHtopdown,TKEprodTD ) + + !input + integer, intent(in) :: kte,kts + real, dimension(kts:kte), intent(in) :: dz1,sqc,sqi,sqw,& + thl,th1,ex1,p1,rho1,thetav,cldfra_bl1D,rthraten + real, dimension(kts:kte+1), intent(in) :: zw + real, intent(in) :: pblh,xland + integer,intent(in) :: kpbl + !output + real, intent(out) :: maxKHtopdown + real, dimension(kts:kte), intent(out) :: KHtopdown,TKEprodTD + !local + real, dimension(kts:kte) :: zfac,wscalek2,zfacent + real :: bfx0,sflux,wm2,wm3,h1,h2,bfxpbl,dthvx,tmp1 + real :: temps,templ,zl1,wstar3_2 + real :: ent_eff,radsum,radflux,we,rcldb,rvls,minrad,zminrad + real, parameter :: pfac =2.0, zfmin = 0.01, phifac=8.0 + integer :: k,kk,kminrad + logical :: cloudflg + + cloudflg=.false. + minrad=100. + kminrad=kpbl + zminrad=PBLH + KHtopdown(kts:kte)=0.0 + TKEprodTD(kts:kte)=0.0 + maxKHtopdown=0.0 + + !CHECK FOR STRATOCUMULUS-TOPPED BOUNDARY LAYERS + DO kk = MAX(1,kpbl-2),kpbl+3 + if (sqc(kk).gt. 1.e-6 .OR. sqi(kk).gt. 1.e-6 .OR. & + cldfra_bl1D(kk).gt.0.5) then + cloudflg=.true. + endif + if (rthraten(kk) < minrad)then + minrad=rthraten(kk) + kminrad=kk + zminrad=zw(kk) + 0.5*dz1(kk) + endif + ENDDO + + IF (MAX(kminrad,kpbl) < 2)cloudflg = .false. + IF (cloudflg) THEN + zl1 = dz1(kts) + k = MAX(kpbl-1, kminrad-1) + !Best estimate of height of TKE source (top of downdrafts): + !zminrad = 0.5*pblh(i,j) + 0.5*zminrad + + templ=thl(k)*ex1(k) + !rvls is ws at full level + rvls=100.*6.112*EXP(17.67*(templ-273.16)/(templ-29.65))*(ep_2/p1(k+1)) + temps=templ + (sqw(k)-rvls)/(cp/xlv + ep_2*xlv*rvls/(rd*templ**2)) + rvls=100.*6.112*EXP(17.67*(temps-273.15)/(temps-29.65))*(ep_2/p1(k+1)) + rcldb=max(sqw(k)-rvls,0.) + + !entrainment efficiency + dthvx = (thl(k+2) + th1(k+2)*ep_1*sqw(k+2)) & + - (thl(k) + th1(k) *ep_1*sqw(k)) + dthvx = max(dthvx,0.1) + tmp1 = xlvcp * rcldb/(ex1(k)*dthvx) + !Originally from Nichols and Turton (1986), where a2 = 60, but lowered + !here to 8, as in Grenier and Bretherton (2001). + ent_eff = 0.2 + 0.2*8.*tmp1 + + radsum=0. + DO kk = MAX(1,kpbl-3),kpbl+3 + radflux=rthraten(kk)*ex1(kk) !converts theta/s to temp/s + radflux=radflux*cp/g*(p1(kk)-p1(kk+1)) ! converts temp/s to W/m^2 + if (radflux < 0.0 ) radsum=abs(radflux)+radsum + ENDDO + + !More strict limits over land to reduce stable-layer mixouts + if ((xland-1.5).GE.0)THEN ! WATER + radsum=MIN(radsum,90.0) + bfx0 = max(radsum/rho1(k)/cp,0.) + else ! LAND + radsum=MIN(0.25*radsum,30.0)!practically turn off over land + bfx0 = max(radsum/rho1(k)/cp - max(sflux,0.0),0.) + endif + + !entrainment from PBL top thermals + wm3 = g/thetav(k)*bfx0*MIN(pblh,1500.) ! this is wstar3(i) + wm2 = wm2 + wm3**h2 + bfxpbl = - ent_eff * bfx0 + dthvx = max(thetav(k+1)-thetav(k),0.1) + we = max(bfxpbl/dthvx,-sqrt(wm3**h2)) + + DO kk = kts,kpbl+3 + !Analytic vertical profile + zfac(kk) = min(max((1.-(zw(kk+1)-zl1)/(zminrad-zl1)),zfmin),1.) + zfacent(kk) = 10.*MAX((zminrad-zw(kk+1))/zminrad,0.0)*(1.-zfac(kk))**3 + + !Calculate an eddy diffusivity profile (not used at the moment) + wscalek2(kk) = (phifac*karman*wm3*(zfac(kk)))**h1 + !Modify shape of Kh to be similar to Lock et al (2000): use pfac = 3.0 + KHtopdown(kk) = wscalek2(kk)*karman*(zminrad-zw(kk+1))*(1.-zfac(kk))**3 !pfac + KHtopdown(kk) = MAX(KHtopdown(kk),0.0) + + !Calculate TKE production = 2(g/TH)(w'TH'), where w'TH' = A(TH/g)wstar^3/PBLH, + !A = ent_eff, and wstar is associated with the radiative cooling at top of PBL. + !An analytic profile controls the magnitude of this TKE prod in the vertical. + TKEprodTD(kk)=2.*ent_eff*wm3/MAX(pblh,100.)*zfacent(kk) + TKEprodTD(kk)= MAX(TKEprodTD(kk),0.0) + ENDDO + ENDIF !end cloud check + maxKHtopdown=MAXVAL(KHtopdown(:)) + + END SUBROUTINE topdown_cloudrad +! ================================================================== ! =================================================================== ! =================================================================== From c02da687ab6dc80a9b8905f2d6d646ca42467bc9 Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Fri, 9 Jul 2021 20:27:10 +0000 Subject: [PATCH 02/85] Final updates for the MYNN-EDMF for HFIP --- physics/module_bl_mynn.F90 | 244 ++++++++++++++++++++----------------- 1 file changed, 133 insertions(+), 111 deletions(-) diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index b63da6223..04c6049f5 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -275,7 +275,7 @@ MODULE module_bl_mynn LOGICAL, PARAMETER :: mynn_chem_vertmx = .false. LOGICAL, PARAMETER :: enh_vermix = .false. - !>Of the following teo options, use one OR the other, not both. + !>Of the following the options, use one OR the other, not both. !>Adding top-down diffusion driven by cloud-top radiative cooling INTEGER, PARAMETER :: bl_mynn_topdown = 0 !>Option to activate downdrafts, from Elynn Wu (0: deactive, 1: active) @@ -322,6 +322,7 @@ MODULE module_bl_mynn !JOE & JAYMES'S mods ! ! Mixing Length Options +!\authors Joe and Jaymes ! specifed through namelist: bl_mynn_mixlength ! added: 16 Apr 2015 ! @@ -489,7 +490,7 @@ SUBROUTINE mym_initialize ( & & dz, dx, zw, & & u, v, thl, qw, & ! & ust, rmo, pmz, phh, flt, flq, & - & zi, theta, sh, sm, & + & zi, theta, thetav, sh, sm, & & ust, rmo, el, & & Qke, Tsq, Qsq, Cov, Psig_bl, cldfra_bl1D, & & bl_mynn_mixlength, & @@ -517,7 +518,7 @@ SUBROUTINE mym_initialize ( & INTEGER :: k,l,lmax REAL :: phm,vkz,elq,elv,b1l,b2l,pmz=1.,phh=1.,flt=0.,flq=0.,tmpq REAL :: zi - REAL, DIMENSION(kts:kte) :: theta + REAL, DIMENSION(kts:kte) :: theta, thetav REAL, DIMENSION(kts:kte) :: rstoch_col INTEGER ::spp_pbl @@ -532,7 +533,7 @@ SUBROUTINE mym_initialize ( & !> - Call mym_level2() to calculate the stability functions at level 2. CALL mym_level2 ( kts,kte, & & dz, & - & u, v, thl, qw, & + & u, v, thl, thetav, qw, & & ql, vt, vq, & & dtl, dqw, dtv, gm, gh, sm, sh ) ! @@ -690,7 +691,7 @@ END SUBROUTINE mym_initialize !! @ { SUBROUTINE mym_level2 (kts,kte, & & dz, & - & u, v, thl, qw, & + & u, v, thl, thetav, qw, & & ql, vt, vq, & & dtl, dqw, dtv, gm, gh, sm, sh ) ! @@ -704,8 +705,8 @@ SUBROUTINE mym_level2 (kts,kte, & #endif REAL, DIMENSION(kts:kte), INTENT(in) :: dz - REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,qw,ql,vt,vq - + REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,qw,ql,vt,vq,& + thetav REAL, DIMENSION(kts:kte), INTENT(out) :: & &dtl,dqw,dtv,gm,gh,sm,sh @@ -746,8 +747,9 @@ SUBROUTINE mym_level2 (kts,kte, & ! vtt = 1.0 +vt(k)*abk +vt(k-1)*afk ! Beta-theta in NN09, Eq. 39 vqq = tv0 +vq(k)*abk +vq(k-1)*afk ! Beta-q - dtq = vtt*dtz +vqq*dqz + !Alternatively, use theta-v without the SGS clouds + !dtq = ( thetav(k)-thetav(k-1) )/( dzk ) ! dtl(k) = dtz dqw(k) = dqz @@ -972,30 +974,31 @@ SUBROUTINE mym_length ( & END DO - CASE (1) !OPERATIONAL FORM OF MIXING LENGTH + CASE (1, 2) !NONLOCAL (using BouLac) FORM OF MIXING LENGTH - cns = 2.3 + cns = 3.5 alp1 = 0.23 - alp2 = 0.65 - alp3 = 3.0 - alp4 = 20. + alp2 = 0.3 + alp3 = 1.5 + alp4 = 5. alp5 = 0.4 + alp6 = 50. ! Impose limits on the height integration for elt and the transition layer depth - zi2=MAX(zi,minzi) - h1=MAX(0.3*zi2,mindz) - h1=MIN(h1,maxdz) ! 1/2 transition layer depth + zi2=MAX(zi,200.) !minzi) + h1=MAX(0.3*zi2,200.) + h1=MIN(h1,500.) ! 1/2 transition layer depth h2=h1/2.0 ! 1/4 transition layer depth - qtke(kts)=MAX(qke(kts)/2.,0.01) !tke at full sigma levels - thetaw(kts)=theta(kts) !theta at full-sigma levels + qtke(kts)=MAX(0.5*qke(kts),0.01) !tke at full sigma levels + thetaw(kts)=theta(kts) !theta at full-sigma levels qkw(kts) = SQRT(MAX(qke(kts),1.0e-10)) DO k = kts+1,kte afk = dz(k)/( dz(k)+dz(k-1) ) abk = 1.0 -afk qkw(k) = SQRT(MAX(qke(k)*abk+qke(k-1)*afk,1.0e-3)) - qtke(k) = (qkw(k)**2.)/2. ! q -> TKE + qtke(k) = 0.5*(qkw(k)**2) ! q -> TKE thetaw(k)= theta(k)*abk + theta(k-1)*afk END DO @@ -1014,9 +1017,9 @@ SUBROUTINE mym_length ( & zwk = zw(k) END DO - elt = alp1*elt/vsc + elt = MIN( MAX( alp1*elt/vsc, 10.), 400.) vflx = ( vt(kts)+1.0 )*flt +( vq(kts)+tv0 )*flq - vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**(1.0/3.0) + vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**onethird ! ** Strictly, el(i,j,1) is not zero. ** el(kts) = 0.0 @@ -1031,11 +1034,14 @@ SUBROUTINE mym_length ( & ! ** Length scale limited by the buoyancy effect ** IF ( dtv(k) .GT. 0.0 ) THEN bv = SQRT( gtr*dtv(k) ) - elb = alp2*qkw(k) / bv & ! formulation, - & *( 1.0 + alp3/alp2*& ! except keep - &SQRT( vsc/( bv*elt ) ) ) ! elb bounded by - elb = MIN(elb, zwk) ! zwk - elf = alp2 * qkw(k)/bv + !elb = alp2*qkw(k) / bv & ! formulation, + ! & *( 1.0 + alp3/alp2*& ! except keep + ! &SQRT( vsc/( bv*elt ) ) ) ! elb bounded by zwk + elb = MAX(alp2*qkw(k), & + & alp6*edmf_a1(k)*edmf_w1(k)) / bv & + & *( 1.0 + alp3*SQRT( vsc/(bv*elt) ) ) + elb = MIN(elb, zwk) + elf = 0.65 * qkw(k)/bv ELSE elb = 1.0e10 elf = elb @@ -1057,35 +1063,35 @@ SUBROUTINE mym_length ( & !add blending to use BouLac mixing length in free atmos; !defined relative to the PBLH (zi) + transition layer (h1) - el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf) - el(k) = el(k)*(1.-wt) + alp5*elBLmin(k)*wt + !el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf) + !try squared-blending + !el_unstab = SQRT( els**2/(1. + (els1**2/elt**2) )) + el(k) = SQRT( els**2/(1. + (els1**2/elt**2) +(els1**2/elb**2))) + el(k) = MIN (el(k), elf) + el(k) = el(k)*(1.-wt) + alp5*elBLavg(k)*wt ! include scale-awareness, except for original MYNN el(k) = el(k)*Psig_bl END DO - CASE (2) !Experimental mixing length formulation + CASE (3) !Experimental mixing length formulation Uonset = 3.5 + dz(kts)*0.1 Ugrid = sqrt(u1(kts)**2 + v1(kts)**2) cns = 3.5 !JOE-test * (1.0 - MIN(MAX(Ugrid - Uonset, 0.0)/10.0, 1.0)) alp1 = 0.23 alp2 = 0.30 - alp3 = 2.0 !JOE-test 2.0 - alp4 = 10.0 !JOE-test 20. !10. + alp3 = 1.5 + alp4 = 10.0 !was 20. alp5 = alp2 !like alp2, but for free atmosphere alp6 = 50.0 !used for MF mixing length ! Impose limits on the height integration for elt and the transition layer depth !zi2=MAX(zi,minzi) -!JOE-test -! zi2=MAX(zi, 100.) zi2=MAX(zi, 200.) -!JOE-test -! h1=MAX(0.3*zi2,mindz) -! h1=MIN(h1,maxdz) ! 1/2 transition layer depth -! h1=MAX(0.3*zi2,100.) + !h1=MAX(0.3*zi2,mindz) + !h1=MIN(h1,maxdz) ! 1/2 transition layer depth h1=MAX(0.3*zi2,200.) h1=MIN(h1,500.) h2=h1*0.5 ! 1/4 transition layer depth @@ -1109,14 +1115,14 @@ SUBROUTINE mym_length ( & zwk = zw(k) DO WHILE (zwk .LE. PBLH_PLUS_ENT) dzk = 0.5*( dz(k)+dz(k-1) ) - qdz = MAX( qkw(k)-qmin, 0.03 )*dzk !consider reducing 0.3 + qdz = MAX( qkw(k)-qmin, 0.03 )*dzk elt = elt +qdz*zwk vsc = vsc +qdz k = k+1 zwk = zw(k) END DO - elt = MAX(alp1*elt/vsc, 10.) + elt = MIN( MAX(alp1*elt/vsc, 10.), 400.) vflx = ( vt(kts)+1.0 )*flt +( vq(kts)+tv0 )*flq vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**onethird @@ -1138,9 +1144,8 @@ SUBROUTINE mym_length ( & & alp6*edmf_a1(k)*edmf_w1(k)) / bv & & *( 1.0 + alp3*SQRT( vsc/( bv*elt ) ) ) elb = MIN(MAX(alp5*qkw(k), alp6*edmf_a1(k)*edmf_w1(k))/bv, zwk) -! elf = elb/(1. + (elb/600.)) !bound free-atmos mixing length to < 600 m. -!orig: tau_cloud = MIN(MAX(0.5*zi/((gtr*zi*MAX(vflx,1.0e-4))**onethird),30.),150.) + !tau_cloud = MIN(MAX(0.5*zi/((gtr*zi*MAX(vflx,1.0e-4))**onethird),30.),150.) wstar = 1.25*(gtr*zi*MAX(vflx,1.0e-4))**onethird tau_cloud = MIN(MAX(ctau * wstar/g, 30.), 150.) !minimize influence of surface heat flux on tau far away from the PBLH. @@ -1167,12 +1172,12 @@ SUBROUTINE mym_length ( & ! velocity scale), except that elt is relpaced ! by zi, and zero is replaced by 1.0e-4 to ! prevent division by zero. -!orig: tau_cloud = MIN(MAX(0.5*zi/((gtr*zi*MAX(vflx,1.0e-4))**onethird),50.),150.) + !tau_cloud = MIN(MAX(0.5*zi/((gtr*zi*MAX(vflx,1.0e-4))**onethird),50.),150.) wstar = 1.25*(gtr*zi*MAX(vflx,1.0e-4))**onethird tau_cloud = MIN(MAX(ctau * wstar/g, 50.), 200.) !minimize influence of surface heat flux on tau far away from the PBLH. wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 -! tau_cloud = tau_cloud*(1.-wt) + 50.*wt + !tau_cloud = tau_cloud*(1.-wt) + 50.*wt tau_cloud = tau_cloud*(1.-wt) + MAX(100.,dzk*0.25)*wt elb = MIN(tau_cloud*SQRT(MIN(qtke(k),40.)), zwk) @@ -1199,10 +1204,11 @@ SUBROUTINE mym_length ( & wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 ! "el_unstab" = blended els-elt -! el_unstab = els/(1. + (els1/elt)) -! el(k) = MIN(el_unstab, elb_mf) -!try squared-blending + !el_unstab = els/(1. + (els1/elt)) + !try squared-blending + !el(k) = SQRT( els**2/(1. + (els1**2/elt**2) )) el(k) = SQRT( els**2/(1. + (els1**2/elt**2) +(els1**2/elb_mf**2))) + !el(k) = MIN(el_unstab, elb_mf) el(k) = el(k)*(1.-wt) + elf*wt ! include scale-awareness. For now, use simple asymptotic kz -> 12 m. @@ -1598,7 +1604,7 @@ SUBROUTINE mym_turbulence ( & & kts,kte, & & closure, & & dz, dx, zw, & - & u, v, thl, ql, qw, & + & u, v, thl, thetav, ql, qw, & & qke, tsq, qsq, cov, & & vt, vq, & & rmo, flt, flq, & @@ -1627,7 +1633,7 @@ SUBROUTINE mym_turbulence ( & REAL, DIMENSION(kts:kte), INTENT(in) :: dz REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw REAL, INTENT(in) :: rmo,flt,flq,Psig_bl,Psig_shcu,dx - REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,qw,& + REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,thetav,qw,& &ql,vt,vq,qke,tsq,qsq,cov,cldfra_bl1D,edmf_w1,edmf_a1,edmf_qc1,& &TKEprodTD @@ -1664,7 +1670,7 @@ SUBROUTINE mym_turbulence ( & INTEGER, INTENT(IN) :: spp_pbl REAL, DIMENSION(KTS:KTE) :: rstoch_col REAL :: Prnum - REAL, PARAMETER :: Prlimit = 10.0 + REAL, PARAMETER :: Prlimit = 5.0 ! @@ -1682,7 +1688,7 @@ SUBROUTINE mym_turbulence ( & CALL mym_level2 (kts,kte, & & dz, & - & u, v, thl, qw, & + & u, v, thl, theta, qw, & & ql, vt, vq, & & dtl, dqw, dtv, gm, gh, sm, sh ) ! @@ -1706,15 +1712,10 @@ SUBROUTINE mym_turbulence ( & elsq = el (k)**2 q3sq = qkw(k)**2 q2sq = b1*elsq*( sm(k)*gm(k)+sh(k)*gh(k) ) - !Remove possiblity of contamination due to spikes, but - !allow for very large variations - no impact on idealized cases -! elsq = MIN(MAX(elsq,0.1), 160000.) !max el = 400 m -! q3sq = MIN(MAX(q3sq,0.01), 75.) !max tke = 75 m2/s2 -! q2sq = MIN(MAX(q2sq,0.01), 75.) - !end constraints - sh20 = MAX(sh(k), 1e-6) - sm20 = MAX(sm(k), 1e-6) - sh(k)= MAX(sh(k), 1e-6) + + sh20 = MAX(sh(k), 1e-5) + sm20 = MAX(sm(k), 1e-5) + sh(k)= MAX(sh(k), 1e-5) !Canuto/Kitamura mod duz = ( u(k)-u(k-1) )**2 +( v(k)-v(k-1) )**2 @@ -1732,7 +1733,7 @@ SUBROUTINE mym_turbulence ( & !Prnum = MIN(sm20/sh20, 4.0) !The form of Zilitinkevich et al. (2006) but modified !following Esau and Grachev (2007, Wind Eng) - Prnum = MIN(0.8 + 4.0*MAX(ri,-0.013), Prlimit) + Prnum = MIN(0.76 + 4.0*MAX(ri,0.0), Prlimit) ! ! Modified: Dec/22/2005, from here, (dlsq -> elsq) gmel = gm (k)*elsq @@ -1761,9 +1762,26 @@ SUBROUTINE mym_turbulence ( & IF ( q3sq .LT. q2sq ) THEN !Apply Helfand & Labraga mod qdiv = SQRT( q3sq/q2sq ) !HL89: (1-alfa) - ! sm(k) = sm(k) * qdiv - ! sh(k) = sh(k) * qdiv ! + !Use level 2.5 stability functions + !e1 = q3sq - e1c*ghel*a2fac + !e2 = q3sq - e2c*ghel*a2fac + !e3 = e1 + e3c*ghel*a2fac**2 + !e4 = e1 - e4c*ghel*a2fac + !eden = e2*e4 + e3*e5c*gmel + !eden = MAX( eden, 1.0d-20 ) + !sm(k) = q3sq*a1*( e3-3.0*c1*e4 )/eden + !!JOE-Canuto/Kitamura mod + !!sh(k) = q3sq*a2*( e2+3.0*c1*e5c*gmel )/eden + !sh(k) = q3sq*(a2*a2fac)*( e2+3.0*c1*e5c*gmel )/eden + !sm(k) = Prnum*sh(k) + !sm(k) = sm(k) * qdiv + + !Use level 2.0 functions as in original MYNN + !sh(k) = sh(k) * qdiv + !sm(k) = Prnum*sh(k) + + !Recalculate terms for later use !JOE-Canuto/Kitamura mod !e1 = q3sq - e1c*ghel * qdiv**2 !e2 = q3sq - e2c*ghel * qdiv**2 @@ -1775,12 +1793,9 @@ SUBROUTINE mym_turbulence ( & e4 = e1 - e4c*ghel*a2fac * qdiv**2 eden = e2*e4 + e3*e5c*gmel * qdiv**2 eden = MAX( eden, 1.0d-20 ) - - !Use level 2.5 stability functions - !sm(k) = q3sq*a1*( e3-3.0*c1*e4 )/eden !!JOE-Canuto/Kitamura mod - !!sh(k) = q3sq*a2*( e2+3.0*c1*e5c*gmel )/eden - ! sh(k) = q3sq*(a2*a2fac)*( e2+3.0*c1*e5c*gmel )/eden + !!sh(k) = q3sq*a2*( e2+3.0*c1*e5c*gmel )/eden - retro 5 + sh(k) = q3sq*(a2*a2fac)*( e2+3.0*c1*e5c*gmel )/eden sm(k) = Prnum*sh(k) ELSE !JOE-Canuto/Kitamura mod @@ -1804,7 +1819,7 @@ SUBROUTINE mym_turbulence ( & sm(k) = Prnum*sh(k) END IF !end Helfand & Labraga check - !Impose broad limits on Sh and Sm from HL88: + !Impose broad limits on Sh and Sm: gmelq = MAX(gmel/q3sq, 1e-8) sm25max = MIN(sm20*3.0, SQRT(.1936/gmelq)) sh25max = MIN(sh20*3.0, 0.76*b2) @@ -1815,8 +1830,8 @@ SUBROUTINE mym_turbulence ( & ! HL88 , lev2.5 criteria from eqs. 3.17, 3.19, & 3.20 IF ( debug_code ) THEN IF ((sh(k)sh25max .OR. sm(k)>sm25max) .AND. ri < 0.5) THEN - print*,"MYNN; mym_turbulence2.5: k=",k + sh(k)>sh25max .OR. sm(k)>sm25max) ) THEN + print*,"In mym_turbulence 2.5: k=",k print*," sm=",sm(k)," sh=",sh(k) print*," ri=",ri," Pr=",sm(k)/MAX(sh(k),1e-8) print*," gm=",gm(k)," gh=",gh(k) @@ -1829,12 +1844,12 @@ SUBROUTINE mym_turbulence ( & ENDIF ENDIF - !Enforce constraints for level 2.5 functions -! IF ( sh(k) > sh25max ) sh(k) = sh25max -! IF ( sh(k) < sh25min ) sh(k) = sh25min -!! IF ( sm(k) > sm25max ) sm(k) = sm25max -!! IF ( sm(k) < sm25min ) sm(k) = sm25min -! sm(k) = Prnum*sh(k) + !Enforce additional constraints for level 2.5 functions + IF ( sh(k) > sh25max ) sh(k) = sh25max + IF ( sh(k) < sh25min ) sh(k) = sh25min + !IF ( sm(k) > sm25max ) sm(k) = sm25max + !IF ( sm(k) < sm25min ) sm(k) = sm25min + sm(k) = Prnum*sh(k) ! ** Level 3 : start ** IF ( closure .GE. 3.0 ) THEN @@ -1909,8 +1924,8 @@ SUBROUTINE mym_turbulence ( & !JOE: test dynamic limits clow = q3sq*( 0.12-cw25 )*eden/wden cupp = q3sq*( 0.76-cw25 )*eden/wden -!JOE clow = q3sq*( Rsl -cw25 )*eden/wden -!JOE cupp = q3sq*( Rsl2-cw25 )*eden/wden + !clow = q3sq*( Rsl -cw25 )*eden/wden + !cupp = q3sq*( Rsl2-cw25 )*eden/wden ! IF ( wden .GT. 0.0 ) THEN c3sq = MIN( MAX( c3sq, c2sq+clow ), c2sq+cupp ) @@ -1984,10 +1999,6 @@ SUBROUTINE mym_turbulence ( & gamq = 0.0 gamv = 0.0 END IF - -! Prandtl number limit -! Prlimit = 4.0 -! IF (sm(k) > sh(k)*Prlimit) sm(k) = sh(k)*Prlimit ! ! Add min background stability function (diffusivity) within model levels ! with active plumes and low cloud fractions. @@ -2059,7 +2070,6 @@ SUBROUTINE mym_turbulence ( & !! Buoyncy term takes the TKEprodTD(k) production now qBUOY1D(k) = elq*(sh(k)*gh(k)+gamv)+TKEprodTD(k) !staggared - !! !!!Dissipation Term (now it evaluated on mym_predict) !qDISS1D(k) = (q3sq**(3./2.))/(b1*MAX(el(k),1.)) !! ORIGINAL CODE @@ -2301,7 +2311,7 @@ SUBROUTINE mym_predict (kts,kte, & d(kte)=0. ! CALL tridiag(kte,a,b,c,d) - CALL tridiag3(kte,a,b,c,d,x) + CALL tridiag2(kte,a,b,c,d,x) DO k=kts,kte ! qke(k)=max(d(k-kts+1), 1.e-4) @@ -2357,9 +2367,9 @@ SUBROUTINE mym_predict (kts,kte, & c(kte)=0. d(kte)=0. - !CALL tridiag(kte,a,b,c,d) - CALL tridiag3(kte,a,b,c,d,x) - +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,x) + DO k=kts,kte !qsq(k)=d(k-kts+1) qsq(k)=MAX(x(k),1e-12) @@ -2421,10 +2431,10 @@ SUBROUTINE mym_predict (kts,kte, & b(kte)=1. c(kte)=0. d(kte)=0. - -! CALL tridiag(kte,a,b,c,d) - CALL tridiag3(kte,a,b,c,d,x) +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,x) + DO k=kts,kte ! tsq(k)=d(k-kts+1) tsq(k)=x(k) @@ -2471,8 +2481,8 @@ SUBROUTINE mym_predict (kts,kte, & d(kte)=0. ! CALL tridiag(kte,a,b,c,d) - CALL tridiag3(kte,a,b,c,d,x) - + CALL tridiag2(kte,a,b,c,d,x) + DO k=kts,kte ! cov(k)=d(k-kts+1) cov(k)=x(k) @@ -2580,14 +2590,14 @@ SUBROUTINE mym_condensation (kts,kte, & REAL :: erf - !VARIABLES FOR ALTERNATIVE SIMGA + !VARIABLES FOR ALTERNATIVE SIGMA REAL::dth,dtl,dqw,dzk,els REAL, DIMENSION(kts:kte), INTENT(IN) :: Sh,el !variables for SGS BL clouds REAL :: zagl,damp,PBLH2 REAL :: lfac - INTEGER, PARAMETER :: sig_order = 2 !sigma form, 1: use state variables, 2: higher-order variables + INTEGER, PARAMETER :: sig_order = 1 !sigma form, 1: use state variables, 2: higher-order variables !JAYMES: variables for tropopause-height estimation REAL :: theta1, theta2, ht1, ht2 @@ -2735,7 +2745,7 @@ SUBROUTINE mym_condensation (kts,kte, & if(cldfra_bl1D(k)>0.01 .and. qc_bl1D(k)<1.E-6)qc_bl1D(k)=1.E-6 if(cldfra_bl1D(k)>0.01 .and. qi_bl1D(k)<1.E-8)qi_bl1D(k)=1.E-8 - !Now estimate the buiyancy flux functions + !Now estimate the buoyancy flux functions q2p = xlvcp/exner(k) pt = thl(k) +q2p*ql(k) ! potential temp @@ -3874,8 +3884,11 @@ SUBROUTINE mynn_tendencies(kts,kte, & !===================== DO k=kts,kte !Dqv(k)=(sqv2(k)/(1.-sqv2(k)) - qv(k))/delt !mixing ratio - Dqv(k)=(sqv2(k) - sqv(k))/delt !spec humidity - !IF(-Dqv(k) > qv(k)) Dqv(k)=-qv(k) + Dqv(k)=(sqv2(k) - sqv(k))/delt !spec humidity + IF(Dqv(k)*delt + sqv(k) < 0.) THEN + !print*,' neg qv:',qsl,sqv(k),sqv2(k),sqc(k),sqi(k),tk(k) + Dqv(k)=-sqv(k)*0.99/delt + ENDIF ENDDO IF (bl_mynn_cloudmix > 0) THEN @@ -3956,6 +3969,15 @@ SUBROUTINE mynn_tendencies(kts,kte, & ENDDO ENDIF + !===================== + ! OZONE TENDENCY CHECK + !===================== + DO k=kts,kte + IF(Dozone(k)*delt + ozone(k) < 0.) THEN + Dozone(k)=-ozone(k)*0.99/delt + ENDIF + ENDDO + !=================== ! THETA TENDENCY !=================== @@ -4678,7 +4700,7 @@ SUBROUTINE mynn_bl_driver( & rho1(k)=rho(i,k,j) sqc(k)=sqc3D(i,k,j) !/(1.+qv(i,k,j)) sqv(k)=sqv3D(i,k,j) !/(1.+qv(i,k,j)) - thetav(k)=th(i,k,j)*(1.+0.61*sqv(k)) + thetav(k)=th(i,k,j)*(1.+0.608*sqv(k)) IF (icloud_bl > 0) THEN CLDFRA_BL1D(k)=CLDFRA_BL(i,k,j) QC_BL1D(k)=QC_BL(i,k,j) @@ -4770,17 +4792,17 @@ SUBROUTINE mynn_bl_driver( & !! \f$q^{'2}\f$, and \f$\theta^{'}q^{'}\f$. These variables are calculated after !! obtaining prerequisite variables by calling the following subroutines from !! within mym_initialize(): mym_level2() and mym_length(). - CALL mym_initialize ( & - &kts,kte, & - &dz1, dx(i,j), zw, & - &u1, v1, thl, sqv, & - &PBLH(i,j), th1, sh, sm, & - &ust(i,j), rmol(i,j), & - &el, Qke1, Tsq1, Qsq1, Cov1, & - &Psig_bl(i,j), cldfra_bl1D, & - &bl_mynn_mixlength, & + CALL mym_initialize ( & + &kts,kte, & + &dz1, dx(i,j), zw, & + &u1, v1, thl, sqv, & + &PBLH(i,j), th1, thetav, sh, sm,& + &ust(i,j), rmol(i,j), & + &el, Qke1, Tsq1, Qsq1, Cov1, & + &Psig_bl(i,j), cldfra_bl1D, & + &bl_mynn_mixlength, & &edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf,& - &INITIALIZE_QKE, & + &INITIALIZE_QKE, & &spp_pbl,rstoch_col ) IF (.not.restart) THEN @@ -5203,7 +5225,7 @@ SUBROUTINE mynn_bl_driver( & CALL mym_turbulence ( & &kts,kte,closure, & &dz1, DX(i,j), zw, & - &u1, v1, thl, sqc, sqw, & + &u1, v1, thl, thetav, sqc, sqw, & &qke1, tsq1, qsq1, cov1, & &vt, vq, & &rmol(i,j), flt, flq, & @@ -6313,10 +6335,10 @@ SUBROUTINE DMP_mf( & Wn = UPW(K-1,I) - MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0) ENDIF Wn = MIN(MAX(Wn,0.0), 3.0) -! WA TEST 5/7/20 for accelerating plumes above cloud base, add entrainment +! WA ACP mod 5/7/20 for accelerating plumes above cloud base, add entrainment ! and recalculate updraft variables IF (QCn > 0.0 .AND. Wn > UPW(K-1,I)) THEN - ENT = ENT * 2.0 + ENT(K,I) = ENT(K,I) * 2.0 EntExp= ENT(K,I)*(ZW(k+1)-ZW(k)) QTn =UPQT(k-1,I) *(1.-EntExp) + QT(k)*EntExp THLn=UPTHL(k-1,I)*(1.-EntExp) + THL(k)*EntExp From d35b3d56ac9c07a9899ad78dac6e9f6a8c13c21b Mon Sep 17 00:00:00 2001 From: hannah barnes Date: Fri, 9 Jul 2021 14:39:33 -0600 Subject: [PATCH 03/85] Update of GF aerosol treatment and tunings --- physics/cu_gf_deep.F90 | 181 +++++++++++++++++++++++--------------- physics/cu_gf_driver.F90 | 106 ++++++++++++++++------ physics/cu_gf_driver.meta | 25 ++++++ 3 files changed, 213 insertions(+), 99 deletions(-) diff --git a/physics/cu_gf_deep.F90 b/physics/cu_gf_deep.F90 index a07523342..039ff7f75 100644 --- a/physics/cu_gf_deep.F90 +++ b/physics/cu_gf_deep.F90 @@ -28,9 +28,9 @@ module cu_gf_deep real(kind=kind_phys), parameter :: pgcd = 0.1 ! !> aerosol awareness, do not user yet! - integer, parameter :: autoconv=1 - integer, parameter :: aeroevap=1 - real(kind=kind_phys), parameter :: ccnclean=250. + integer, parameter :: autoconv=2 !1 + integer, parameter :: aeroevap=3 !1 + real(kind=kind_phys), parameter :: scav_factor = 0.5 !> still 16 ensembles for clousres integer, parameter:: maxens3=16 @@ -56,6 +56,7 @@ subroutine cu_gf_deep_run( & ,ichoice & ! choice of closure, use "0" for ensemble average ,ipr & ! this flag can be used for debugging prints ,ccn & ! not well tested yet + ,ccnclean & ,dtime & ! dt over which forcing is applied ,imid & ! flag to turn on mid level convection ,kpbl & ! level of boundary layer height @@ -176,15 +177,15 @@ subroutine cu_gf_deep_run( & q,qo,zuo,zdo,zdm real(kind=kind_phys), dimension (its:ite) & ,intent (in ) :: & - dx,ccn,z1,psur,xland + dx,z1,psur,xland real(kind=kind_phys), dimension (its:ite) & ,intent (inout ) :: & - mconv + mconv,ccn real(kind=kind_phys) & ,intent (in ) :: & - dtime + dtime,ccnclean ! @@ -291,7 +292,7 @@ subroutine cu_gf_deep_run( & real(kind=kind_phys), dimension (its:ite) :: & edt,edto,edtm,aa1,aa0,xaa0,hkb, & hkbo,xhkb, & - xmb,pwavo, & + xmb,pwavo,ccnloss, & pwevo,bu,bud,cap_max, & cap_max_increment,closure_n,psum,psumh,sig,sigd real(kind=kind_phys), dimension (its:ite) :: & @@ -305,7 +306,7 @@ subroutine cu_gf_deep_run( & integer :: & iloop,nens3,ki,kk,i,k real(kind=kind_phys) :: & - dz,dzo,mbdt,radius, & + dz,dzo,mbdt,radius,pefc, & zcutdown,depth_min,zkbmax,z_detr,zktop, & dh,cap_maxs,trash,trash2,frh,sig_thresh real(kind=kind_phys) entdo,dp,subin,detdo,entup, & @@ -504,8 +505,8 @@ subroutine cu_gf_deep_run( & ! !--- minimum depth (m), clouds must have ! - depth_min=1000. - if(imid.eq.1)depth_min=500. + depth_min=3000. + if(imid.eq.1)depth_min=2500. ! !--- maximum depth (mb) of capping !--- inversion (larger cap = no convection) @@ -844,8 +845,8 @@ subroutine cu_gf_deep_run( & exit endif enddo - ktop(i)=ktopkeep(i) - if(ierr(i).eq.0)ktop(i)=ktopkeep(i) + !ktop(i)=ktopkeep(i) + !if(ierr(i).eq.0)ktop(i)=ktopkeep(i) enddo do 37 i=its,itf kzdown(i)=0 @@ -947,14 +948,14 @@ subroutine cu_gf_deep_run( & call cup_up_moisture('mid',ierr,zo_cup,qco,qrco,pwo,pwavo, & p_cup,kbcon,ktop,dbyo,clw_all,xland1, & qo,gammao_cup,zuo,qeso_cup,k22,qo_cup,c0, & - zqexec,ccn,rho,c1d,tn_cup,up_massentr,up_massdetr,psum,psumh, & + zqexec,ccn,ccnclean,rho,c1d,tn_cup,autoconv,up_massentr,up_massdetr,psum,psumh, & 1,itf,ktf, & its,ite, kts,kte) else call cup_up_moisture('deep',ierr,zo_cup,qco,qrco,pwo,pwavo, & p_cup,kbcon,ktop,dbyo,clw_all,xland1, & qo,gammao_cup,zuo,qeso_cup,k22,qo_cup,c0, & - zqexec,ccn,rho,c1d,tn_cup,up_massentr,up_massdetr,psum,psumh, & + zqexec,ccn,ccnclean,rho,c1d,tn_cup,autoconv,up_massentr,up_massdetr,psum,psumh, & 1,itf,ktf, & its,ite, kts,kte) endif @@ -1022,8 +1023,8 @@ subroutine cu_gf_deep_run( & exit endif enddo - ktop(i)=ktopkeep(i) - if(ierr(i).eq.0)ktop(i)=ktopkeep(i) + !ktop(i)=ktopkeep(i) + !if(ierr(i).eq.0)ktop(i)=ktopkeep(i) enddo 41 continue do i=its,itf @@ -1478,8 +1479,8 @@ subroutine cu_gf_deep_run( & !> - Call cup_dd_edt() to determine downdraft strength in terms of windshear ! call cup_dd_edt(ierr,us,vs,zo,ktop,kbcon,edt,po,pwavo, & - pwo,ccn,pwevo,edtmax,edtmin,edtc,psum,psumh, & - rho,aeroevap,itf,ktf, & + pwo,ccn,ccnclean,pwevo,edtmax,edtmin,edtc,psum,psumh, & + rho,aeroevap,pefc,itf,ktf, & its,ite, kts,kte) do i=its,itf if(ierr(i)/=0)cycle @@ -1715,6 +1716,14 @@ subroutine cu_gf_deep_run( & xt(i,k)= dellat(i,k)*mbdt+tn(i,k) xt(i,k)=max(190.,xt(i,k)) enddo + + ! Smooth dellas (HCB) + do k=kts+1,ktf + xt(i,k)=tn(i,k)+0.25*(dellat(i,k-1) + 2.*dellat(i,k) + dellat(i,k+1)) * mbdt + xt(i,k)=max(190.,xt(i,k)) + xq(i,k)=max(1.e-16, qo(i,k)+0.25*(dellaq(i,k-1) + 2.*dellaq(i,k) + dellaq(i,k+1)) * mbdt) + xhe(i,k)=heo(i,k)+0.25*(dellah(i,k-1) + 2.*dellah(i,k) + dellah(i,k+1)) * mbdt + enddo endif enddo do i=its,itf @@ -2019,6 +2028,16 @@ subroutine cu_gf_deep_run( & endif enddo endif + + do i=its,itf + if(ierr(i).eq.0) then + if(aeroevap.gt.1)then + ! aerosol scavagening + ccnloss(i)=ccn(i)*pefc*xmb(i) ! HCB + ccn(i) = ccn(i) - ccnloss(i)*scav_factor + endif + endif + enddo ! ! since kinetic energy is being dissipated, add heating accordingly (from ecmwf) ! @@ -2317,8 +2336,8 @@ end subroutine rain_evap_below_cloudbase subroutine cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, & - pw,ccn,pwev,edtmax,edtmin,edtc,psum2,psumh, & - rho,aeroevap,itf,ktf, & + pw,ccn,ccnclean,pwev,edtmax,edtmin,edtc,psum2,psumh, & + rho,aeroevap,pefc,itf,ktf, & its,ite, kts,kte ) implicit none @@ -2336,15 +2355,22 @@ subroutine cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, & real(kind=kind_phys), dimension (its:ite,1) & ,intent (out ) :: & edtc + real(kind=kind_phys), intent (out ) :: & + pefc real(kind=kind_phys), dimension (its:ite) & ,intent (out ) :: & edt real(kind=kind_phys), dimension (its:ite) & ,intent (in ) :: & - pwav,pwev,ccn,psum2,psumh,edtmax,edtmin + pwav,pwev,psum2,psumh,edtmax,edtmin integer, dimension (its:ite) & ,intent (in ) :: & ktop,kbcon + real(kind=kind_phys), intent (in ) :: & !HCB + ccnclean + real(kind=kind_phys), dimension (its:ite) & + ,intent (inout ) :: & + ccn integer, dimension (its:ite) & ,intent (inout) :: & ierr @@ -2356,11 +2382,13 @@ subroutine cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, & real(kind=kind_phys) einc,pef,pefb,prezk,zkbc real(kind=kind_phys), dimension (its:ite) :: & vshear,sdp,vws - real(kind=kind_phys) :: prop_c,pefc,aeroadd,alpha3,beta3 - prop_c=8. !10.386 - alpha3 = 1.9 - beta3 = -1.13 + real(kind=kind_phys) :: prop_c,aeroadd,alpha3,beta3 + prop_c=0. !10.386 + alpha3 = 0.75 + beta3 = -0.15 pefc=0. + pefb=0. + pef=0. ! !--- determine downdraft strength in terms of windshear @@ -2410,18 +2438,23 @@ subroutine cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, & pefb=1./(1.+prezk) if(pefb.gt.0.9)pefb=0.9 if(pefb.lt.0.1)pefb=0.1 + pefb=pef + edt(i)=1.-.5*(pefb+pef) if(aeroevap.gt.1)then - aeroadd=(ccnclean**beta3)*((psumh(i))**(alpha3-1)) !*1.e6 -! prop_c=.9/aeroadd + aeroadd=0. + if((psumh(i)>0.).and.(psum2(i)>0.))then + aeroadd=((1.e-2*ccnclean)**beta3)*((psumh(i)*1.e0)**(alpha3-1)) prop_c=.5*(pefb+pef)/aeroadd - aeroadd=(ccn(i)**beta3)*((psum2(i))**(alpha3-1)) !*1.e6 + aeroadd=((1.e-2*ccn(i))**beta3)*((psum2(i)*1.e0)**(alpha3-1)) aeroadd=prop_c*aeroadd pefc=aeroadd + if(pefc.gt.0.9)pefc=0.9 if(pefc.lt.0.1)pefc=0.1 edt(i)=1.-pefc if(aeroevap.eq.2)edt(i)=1.-.25*(pefb+pef+2.*pefc) + endif endif @@ -3105,12 +3138,12 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 xf_ens(i,5)=max(0.,xff_ens3(5)) xf_ens(i,6)=max(0.,xff_ens3(6)) xf_ens(i,14)=max(0.,xff_ens3(14)) - a1=max(1.e-5,pr_ens(i,7)) + a1=max(1.e-3,pr_ens(i,7)) xf_ens(i,7)=max(0.,xff_ens3(7)/a1) - a1=max(1.e-5,pr_ens(i,8)) + a1=max(1.e-3,pr_ens(i,8)) xf_ens(i,8)=max(0.,xff_ens3(8)/a1) ! forcing(i,7)=xf_ens(i,8) - a1=max(1.e-5,pr_ens(i,9)) + a1=max(1.e-3,pr_ens(i,9)) xf_ens(i,9)=max(0.,xff_ens3(9)/a1) a1=max(1.e-3,pr_ens(i,15)) xf_ens(i,15)=max(0.,xff_ens3(15)/a1) @@ -3875,7 +3908,7 @@ end subroutine cup_output_ens_3d subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & p_cup,kbcon,ktop,dby,clw_all,xland1, & q,gamma_cup,zu,qes_cup,k22,qe_cup,c0, & - zqexec,ccn,rho,c1d,t, & + zqexec,ccn,ccnclean,rho,c1d,t,autoconv, & up_massentr,up_massdetr,psum,psumh, & itest,itf,ktf, & its,ite, kts,kte ) @@ -3891,6 +3924,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & integer & ,intent (in ) :: & + autoconv, & itest,itf,ktf, & its,ite, kts,kte ! cd= detrainment function @@ -3914,7 +3948,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & ,intent (in ) :: & kbcon,ktop,k22,xland1 real(kind=kind_phys), intent (in ) :: & ! HCB - c0 + c0,ccnclean ! ! input and output ! @@ -3937,9 +3971,9 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & ,intent (out ) :: & qc,qrc,pw,clw_all real(kind=kind_phys), dimension (its:ite,kts:kte) :: & - qch,qrcb,pwh,clw_allh,c1d,t + qch,qrcb,pwh,clw_allh,c1d,c1d_b,t real(kind=kind_phys), dimension (its:ite) :: & - pwavh + pwavh,kklev real(kind=kind_phys), dimension (its:ite) & ,intent (out ) :: & pwav,psum,psumh @@ -3963,7 +3997,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & ! prop_b(kts:kte)=0 iall=0 - clwdet=50. + c1d_b=c1d bdsp=bdispm ! !--- no precip for small clouds @@ -4016,11 +4050,12 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & ! ! if(name == "deep" )then do k=k22(i)+1,kbcon(i) - if(t(i,k) > 273.16) then - c0t = c0 - else - c0t = c0 * exp(0.07 * (t(i,k) - 273.16)) - endif + c0t = c0 + !if(t(i,k) > 273.16) then + ! c0t = c0 + !else + ! c0t = c0 * exp(0.07 * (t(i,k) - 273.16)) + !endif qc(i,k)= (qc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)* qc(i,k-1)+ & up_massentr(i,k-1)*q(i,k-1)) / & (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) @@ -4041,13 +4076,12 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & !now do the rest ! do k=kbcon(i)+1,ktop(i) - !c0=.004 HCB tuning - !if(t(i,k).lt.270.)c0=.002 HCB tuning - if(t(i,k) > 273.16) then - c0t = c0 - else - c0t = c0 * exp(0.07 * (t(i,k) - 273.16)) - endif + c0t = c0 + !if(t(i,k) > 273.16) then + ! c0t = c0 + !else + ! c0t = c0 * exp(0.07 * (t(i,k) - 273.16)) + !endif denom=zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1) if(denom.lt.1.e-16)then ierr(i)=51 @@ -4084,13 +4118,19 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & ! !------- total condensed water before rainout ! + if(name == "deep" )then + clwdet=0.1 ! 05/11/2021 + kklev(i)=maxloc(zu(i,:),1) ! 05/05/2021 + if(k.lt.kklev(i)) clwdet=0. ! 05/05/2021 + else + clwdet=0.1 ! 05/05/2021 + endif + if(k.gt.kbcon(i)+1)c1d(i,k)=clwdet*up_massdetr(i,k-1) + if(k.gt.kbcon(i)+1)c1d_b(i,k)=clwdet*up_massdetr(i,k-1) clw_all(i,k)=max(0.,qc(i,k)-qrch) - qrc(i,k)=max(0.,(qc(i,k)-qrch)) ! /(1.+c0*dz*zu(i,k)) clw_allh(i,k)=max(0.,qch(i,k)-qrch) - qrcb(i,k)=max(0.,(qch(i,k)-qrch)) ! /(1.+c0*dz*zu(i,k)) - if(autoconv.eq.2) then - + if(autoconv.eq.2) then ! ! normalized berry ! @@ -4098,41 +4138,38 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & ! this will also determine proportionality constant prop_b, which, if applied, ! would give the same results as c0 under these conditions ! - q1=1.e3*rhoc*qrcb(i,k) ! g/m^3 ! g[h2o]/cm^3 - berryc0=q1*q1/(60.0*(5.0 + 0.0366*ccnclean/ & + q1=1.e3*rhoc*clw_allh(i,k) ! g/m^3 ! g[h2o]/cm^3 + berryc0=q1*q1/(60.0*(5.0 + 0.0366*ccnclean/ & ( q1 * bdsp) ) ) !/( - qrcb_h=((qch(i,k)-qrch)*zu(i,k)-qrcb(i,k-1)*(.5*up_massdetr(i,k-1)))/ & - (zu(i,k)+.5*up_massdetr(i,k-1)+c0t*dz*zu(i,k)) - prop_b(k)=c0t*qrcb_h*zu(i,k)/(1.e-3*berryc0) + qrcb_h=(qch(i,k)-qrch)/(1.+(c1d_b(i,k)+c0t)*dz) + prop_b(k)=(c0t*qrcb_h)/max(1.e-8,(1.e-3*berryc0)) + if(prop_b(k)>5.) prop_b(k)=5. pwh(i,k)=zu(i,k)*1.e-3*berryc0*dz*prop_b(k) ! 2. - berryc=qrcb(i,k) - qrcb(i,k)=((qch(i,k)-qrch)*zu(i,k)-pwh(i,k)-qrcb(i,k-1)*(.5*up_massdetr(i,k-1)))/ & - (zu(i,k)+.5*up_massdetr(i,k-1)) + qrcb(i,k)=(max(0.,(qch(i,k)-qrch))*zu(i,k)-pwh(i,k))/(zu(i,k)*(1+c1d_b(i,k)*dz)) if(qrcb(i,k).lt.0.)then - berryc0=(qrcb(i,k-1)*(.5*up_massdetr(i,k-1))-(qch(i,k)-qrch)*zu(i,k))/zu(i,k)*1.e-3*dz*prop_b(k) + berryc0=max(0.,(qch(i,k)-qrch))/(1.e-3*dz*prop_b(k)) pwh(i,k)=zu(i,k)*1.e-3*berryc0*dz*prop_b(k) qrcb(i,k)=0. endif qch(i,k)=qrcb(i,k)+qrch pwavh(i)=pwavh(i)+pwh(i,k) - psumh(i)=psumh(i)+clw_allh(i,k)*zu(i,k) *dz + psumh(i)=psumh(i)+pwh(i,k) ! HCB + !psumh(i)=psumh(i)+clw_allh(i,k)*zu(i,k) *dz ! ! then the real berry ! - q1=1.e3*rhoc*qrc(i,k) ! g/m^3 ! g[h2o]/cm^3 - berryc0=q1*q1/(60.0*(5.0 + 0.0366*ccn(i)/ & + q1=1.e3*rhoc*clw_all(i,k) ! g/m^3 ! g[h2o]/cm^3 + berryc0=q1*q1/(60.0*(5.0 + 0.0366*ccn(i)/ & ( q1 * bdsp) ) ) !/( berryc0=1.e-3*berryc0*dz*prop_b(k) ! 2. - berryc=qrc(i,k) - qrc(i,k)=((qc(i,k)-qrch)*zu(i,k)-zu(i,k)*berryc0-qrc(i,k-1)*(.5*up_massdetr(i,k-1)))/ & - (zu(i,k)+.5*up_massdetr(i,k-1)) + qrc(i,k)=(max(0.,(qc(i,k)-qrch))*zu(i,k)-zu(i,k)*berryc0)/(zu(i,k)*(1+c1d(i,k)*dz)) if(qrc(i,k).lt.0.)then - berryc0=((qc(i,k)-qrch)*zu(i,k)-qrc(i,k-1)*(.5*up_massdetr(i,k-1)))/zu(i,k) + berryc0=max(0.,(qc(i,k)-qrch))/(1.e-3*dz*prop_b(k)) qrc(i,k)=0. endif pw(i,k)=berryc0*zu(i,k) qc(i,k)=qrc(i,k)+qrch -! + ! if not running with berry at all, do the following ! else !c0=.002 @@ -4149,7 +4186,8 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & if(qrc(i,k).lt.0.)then ! hli new test 02/12/19 qrc(i,k)=0. endif - pw(i,k)=c0t*dz*qrc(i,k)*zu(i,k) + pw(i,k)=c0t*dz*qrc(i,k)*zu(i,k) + !-----srf-08aug2017-----begin ! pw(i,k)=(c1d(i,k)+c0)*dz*max(0.,qrc(i,k) -qrc_crit)! units kg[rain]/kg[air] !-----srf-08aug2017-----end @@ -4161,7 +4199,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & qc(i,k)=qrc(i,k)+qrch endif !autoconv pwav(i)=pwav(i)+pw(i,k) - psum(i)=psum(i)+clw_all(i,k)*zu(i,k) *dz + psum(i)=psum(i)+pw(i,k) ! HCB enddo ! k=kbcon,ktop ! do not include liquid/ice in qc do k=k22(i)+1,ktop(i) @@ -4304,6 +4342,7 @@ subroutine rates_up_pdf(rand_vmas,ipr,name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo kfinalzu=ktf-2 ktop(i)=kfinalzu 412 continue + ktop(i)=ktopdby(i) ! HCB kklev=min(kklev+3,ktop(i)-2) ! ! at least overshoot by one level diff --git a/physics/cu_gf_driver.F90 b/physics/cu_gf_driver.F90 index 157247f6a..025cbf7bd 100644 --- a/physics/cu_gf_driver.F90 +++ b/physics/cu_gf_driver.F90 @@ -7,7 +7,7 @@ module cu_gf_driver ! DH* TODO: replace constants with arguments to cu_gf_driver_run use physcons , g => con_g, cp => con_cp, xlv => con_hvap, r_v => con_rv use machine , only: kind_phys - use cu_gf_deep, only: cu_gf_deep_run,neg_check,autoconv,aeroevap,fct1d3 + use cu_gf_deep, only: cu_gf_deep_run,neg_check,fct1d3 use cu_gf_sh , only: cu_gf_sh_run implicit none @@ -75,14 +75,14 @@ end subroutine cu_gf_driver_finalize !! !>\section gen_gf_driver GSD GF Cumulus Scheme General Algorithm !> @{ - subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,cactiv, & + subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,cactiv,cactiv_m, & forcet,forceqv_spechum,phil,raincv,qv_spechum,t,cld1d, & us,vs,t2di,w,qv2di_spechum,p2di,psuri, & - hbot,htop,kcnv,xland,hfx2,qfx2,cliw,clcw, & + hbot,htop,kcnv,xland,hfx2,qfx2,aod_gf,cliw,clcw, & pbl,ud_mf,dd_mf,dt_mf,cnvw_moist,cnvc,imfshalcnv, & flag_for_scnv_generic_tend,flag_for_dcnv_generic_tend, & dtend,dtidx,ntqv,ntiw,ntcw,index_of_temperature,index_of_x_wind, & - index_of_y_wind,index_of_process_scnv,index_of_process_dcnv, & + index_of_y_wind,index_of_process_scnv,index_of_process_dcnv, & ldiag3d,qci_conv,errmsg,errflg) !------------------------------------------------------------- implicit none @@ -97,7 +97,9 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,cactiv, & !integer, parameter :: ichoicem=5 ! 0 2 5 13 integer, parameter :: ichoicem=13 ! 0 2 5 13 integer, parameter :: ichoice_s=3 ! 0 1 2 3 - real(kind=kind_phys), parameter :: aodccn=0.1 + + real(kind=kind_phys), parameter :: aodc0=0.14 + real(kind=kind_phys), parameter :: aodreturn=30. real(kind=kind_phys) :: dts,fpi,fp integer, parameter :: dicycle=0 ! diurnal cycle flag integer, parameter :: dicycle_m=0 !- diurnal cycle flag @@ -105,14 +107,14 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,cactiv, & !------------------------------------------------------------- integer :: its,ite, jts,jte, kts,kte integer, intent(in ) :: im,km,ntracer - logical, intent(in ) :: flag_for_scnv_generic_tend,flag_for_dcnv_generic_tend + logical, intent(in ) :: flag_for_scnv_generic_tend,flag_for_dcnv_generic_tend,flag_init logical, intent(in ) :: ldiag3d real(kind=kind_phys), optional, intent(inout) :: dtend(:,:,:) integer, intent(in) :: dtidx(:,:), & index_of_x_wind, index_of_y_wind, index_of_temperature, & index_of_process_scnv, index_of_process_dcnv, ntqv, ntcw, ntiw - + real(kind=kind_phys), dimension( : , : ), intent(in ) :: forcet,forceqv_spechum,w,phil real(kind=kind_phys), dimension( : , : ), intent(inout ) :: t,us,vs real(kind=kind_phys), dimension( : , : ), intent(inout ) :: qci_conv @@ -133,6 +135,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,cactiv, & ! Specific humidity from FV3 real(kind=kind_phys), dimension (:,:), intent(in) :: qv2di_spechum real(kind=kind_phys), dimension (:,:), intent(inout) :: qv_spechum + real(kind=kind_phys), dimension (:), intent(inout) :: aod_gf ! Local water vapor mixing ratios and cloud water mixing ratios real(kind=kind_phys), dimension (im,km) :: qv2di, qv, forceqv, cnvw ! @@ -140,7 +143,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,cactiv, & real(kind=kind_phys), intent(in ) :: dt integer, intent(in ) :: imfshalcnv - integer, dimension(:), intent(inout) :: cactiv + integer, dimension(:), intent(inout) :: cactiv,cactiv_m character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -151,6 +154,8 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,cactiv, & real(kind=kind_phys), dimension (im,4) :: rand_clos real(kind=kind_phys), dimension (im,km,11) :: gdc,gdc2 real(kind=kind_phys), dimension (im) :: ht + real(kind=kind_phys), dimension (im) :: ccn_gf,ccn_m + real(kind=kind_phys) :: ccnclean real(kind=kind_phys), dimension (im) :: dx real(kind=kind_phys), dimension (im,km) :: outt,outq,outqc,phh,subm,cupclw,cupclws real(kind=kind_phys), dimension (im,km) :: dhdt,zu,zus,zd,phf,zum,zdm,outum,outvm @@ -179,9 +184,9 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,cactiv, & ! omega (omeg), windspeed (us,vs), and a flag (ierr) to turn off ! convection for this call only and at that particular gridpoint ! - real(kind=kind_phys), dimension (im,km) :: qcheck,zo,t2d,q2d,po,p2d,rhoi + real(kind=kind_phys), dimension (im,km) :: qcheck,zo,t2d,q2d,po,p2d,rhoi,clw_ten real(kind=kind_phys), dimension (im,km) :: tn,qo,tshall,qshall,dz8w,omeg - real(kind=kind_phys), dimension (im) :: ccn,z1,psur,cuten,cutens,cutenm + real(kind=kind_phys), dimension (im) :: z1,psur,cuten,cutens,cutenm real(kind=kind_phys), dimension (im) :: umean,vmean,pmean real(kind=kind_phys), dimension (im) :: xmbs,xmbs2,xmb,xmbm,xmb_dumm,mconv @@ -190,7 +195,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,cactiv, & integer :: high_resolution real(kind=kind_phys) :: clwtot,clwtot1,excess,tcrit,tscl_kf,dp,dq,sub_spread,subcenter real(kind=kind_phys) :: dsubclw,dsubclws,dsubclwm,dtime_max,ztm,ztq,hfm,qfm,rkbcon,rktop - real(kind=kind_phys), dimension(km) :: massflx,trcflx_in1,clw_in1,clw_ten1,po_cup + real(kind=kind_phys), dimension(km) :: massflx,trcflx_in1,clw_in1,po_cup ! real(kind=kind_phys), dimension(km) :: trcflx_in2,clw_in2,clw_ten2 real(kind=kind_phys), dimension (im) :: flux_tun,tun_rad_mid,tun_rad_shall,tun_rad_deep character*50 :: ierrc(im),ierrcm(im) @@ -200,7 +205,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,cactiv, & ! qfx2 -- latent heat flux (kg/kg m/s), positive upward from sfc ! gf needs them in w/m2. define hfx and qfx after simple unit conversion real(kind=kind_phys), dimension (im) :: hfx,qfx - real(kind=kind_phys) tem,tem1,tf,tcr,tcrf + real(kind=kind_phys) trash,tem,tem1,tf,tcr,tcrf real(kind=kind_phys) :: cliw_shal,clcw_shal,tem_shal, cliw_both, weight_sum real(kind=kind_phys) :: cliw_deep,clcw_deep,tem_deep, clcw_both integer :: cliw_deep_idx, clcw_deep_idx, cliw_shal_idx, clcw_shal_idx @@ -280,7 +285,6 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,cactiv, & ! dx for scale awareness ! dx=40075000./float(lonf) ! tscl_kf=dx/25000. - ccn(its:ite)=150. if (imfshalcnv == 3) then ishallow_g3 = 1 @@ -335,7 +339,24 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,cactiv, & do i= its,itf forcing(i,:)=0. forcing2(i,:)=0. - ccn(i)=100. + ccn_gf(i) = 0. + ccn_m(i) = 0. + + ! set aod and ccn + if (flag_init) then + aod_gf(i)=aodc0 + else + if((cactiv(i).eq.0) .and. (cactiv_m(i).eq.0))then + if(aodc0>aod_gf(i)) aod_gf(i)=aod_gf(i)+((aodc0-aod_gf(i))*(dt/(aodreturn*60))) + if(aod_gf(i)>aodc0) aod_gf(i)=aodc0 + endif + endif + + ccn_gf(i)=max(5., (aod_gf(i)/0.0027)**(1/0.640)) + ccn_m(i)=ccn_gf(i) + + ccnclean=max(5., (aodc0/0.0027)**(1/0.640)) + hbot(i) =kte htop(i) =kts raincv(i)=0. @@ -558,7 +579,8 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,cactiv, & ,dicycle_m & ,ichoicem & ,ipr & - ,ccn & + ,ccn_m & + ,ccnclean & ,dt & ,imid_gf & ,kpbli & @@ -638,7 +660,8 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,cactiv, & ,dicycle & ,ichoice & ,ipr & - ,ccn & + ,ccn_gf & + ,ccnclean & ,dt & ,0 & @@ -761,7 +784,9 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,cactiv, & massflx(:)=0. trcflx_in1(:)=0. clw_in1(:)=0. - clw_ten1(:)=0. + do k=kts,ktf + clw_ten(i, k)=0. + enddo po_cup(:)=0. kstop=kts if(ktopm(i).gt.kts .or. ktop(i).gt.kts)kstop=max(ktopm(i),ktop(i)) @@ -851,20 +876,22 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,cactiv, & massflx (1)=0. trcflx_in1(1)=0. call fct1d3 (kstop,kte,dtime_max,po_cup, & - clw_in1,massflx,trcflx_in1,clw_ten1,g) + clw_in1,massflx,trcflx_in1,clw_ten(i,:),g) do k=1,kstop tem = dt*(outqcs(i,k)*cutens(i)+outqc(i,k)*cuten(i) & +outqcm(i,k)*cutenm(i) & - +clw_ten1(k) & + +clw_ten(i,k) & ) - tem1 = max(0.0, min(1.0, (tcr-t(i,k))*tcrf)) - if (clcw(i,k) .gt. -999.0) then - cliw(i,k) = max(0.,cliw(i,k) + tem * tem1) ! ice - clcw(i,k) = max(0.,clcw(i,k) + tem *(1.0-tem1)) ! water - else - cliw(i,k) = max(0.,cliw(i,k) + tem) - endif + !tem1 = max(0.0, min(1.0, (tcr-t(i,k))*tcrf)) + !if (clcw(i,k) .gt. -999.0) then + ! cliw(i,k) = max(0.,cliw(i,k) + tem * tem1) ! ice + ! clcw(i,k) = max(0.,clcw(i,k) + tem *(1.0-tem1)) ! water + !else + ! cliw(i,k) = max(0.,cliw(i,k) + tem) + !endif + if(t(i,k).le.270.) cliw(i,k) = max(0.,cliw(i,k) + tem) ! HCB + if(t(i,k).gt.270) clcw(i,k) = max(0.,clcw(i,k) + tem) enddo @@ -893,6 +920,29 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,cactiv, & cactiv(i)=0 if(pretm(i).gt.0)raincv(i)=.001*cutenm(i)*pretm(i)*dt endif ! pret > 0 + + if(pretm(i).gt.0)then + cactiv_m(i)=1 + else + cactiv_m(i)=0 + endif + + ! Unify ccn + if(ccn_m(i).lt.ccn_gf(i))then + ccn_gf(i)=ccn_m(i) + endif + + if(ccn_gf(i)<0) ccn_gf(i)=0 + + ! Convert ccn back to aod + aod_gf(i)=0.0027*(ccn_gf(i)**0.64) + if(aod_gf(i)<0.007)then + aod_gf(i)=0.007 + ccn_gf(i)=(aod_gf(i)/0.0027)**(1/0.640) + elseif(aod_gf(i)>aodc0)then + aod_gf(i)=aodc0 + ccn_gf(i)=(aod_gf(i)/0.0027)**(1/0.640) + endif enddo 100 continue ! @@ -958,7 +1008,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,cactiv, & if(qidx>=1) then do k=kts,ktf do i=its,itf - tem = (cuten(i)*outq(i,k) + cutenm(i)*outqm(i,k))* dt + tem = (cuten(i)*outq(i,k) + cutenm(i)*outqm(i,k))* dt tem = tem/(1.0_kind_phys+tem) dtend(i,k,qidx) = dtend(i,k,qidx) + tem enddo @@ -976,7 +1026,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,cactiv, & if(weight_sum<1e-12) then cycle endif - + if (clcw_save(i,k) .gt. -999.0) then cliw_both = max(0.,cliw_save(i,k) + tem * tem1) - cliw_save(i,k) clcw_both = max(0.,clcw_save(i,k) + tem) - clcw_save(i,k) diff --git a/physics/cu_gf_driver.meta b/physics/cu_gf_driver.meta index 84db197bc..cb7ceabd9 100644 --- a/physics/cu_gf_driver.meta +++ b/physics/cu_gf_driver.meta @@ -119,6 +119,14 @@ kind = kind_phys intent = in optional = F +[flag_init] + standard_name = flag_for_first_time_step + long_name = flag signaling first time step for time integration loop + units = flag + dimensions = () + type = logical + intent = in + optional = F [cactiv] standard_name = conv_activity_counter long_name = convective activity memory @@ -127,6 +135,14 @@ type = integer intent = inout optional = F +[cactiv_m] + standard_name = mid_conv_activity_counter + long_name = mid-level cloud convective activity memory + units = none + dimensions = (horizontal_loop_extent) + type = integer + intent = inout + optional = F [forcet] standard_name = temperature_tendency_due_to_dynamics long_name = temperature tendency due to dynamics only @@ -303,6 +319,15 @@ kind = kind_phys intent = in optional = F +[aod_gf] + standard_name = aod_gf_deep + long_name = aerosol optical depth used in Grell-Freitas Convective Parameterization + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F [cliw] standard_name = ice_water_mixing_ratio_convective_transport_tracer long_name = ratio of mass of ice water to mass of dry air plus vapor (without condensates) in the convectively transported tracer array From 3cb6b75726987dfe766ff1b60c32afa20b770f5e Mon Sep 17 00:00:00 2001 From: hannah barnes Date: Mon, 12 Jul 2021 09:38:02 -0600 Subject: [PATCH 04/85] Bug fix --- physics/cu_gf_driver.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/cu_gf_driver.F90 b/physics/cu_gf_driver.F90 index 025cbf7bd..d1dd7171a 100644 --- a/physics/cu_gf_driver.F90 +++ b/physics/cu_gf_driver.F90 @@ -1019,7 +1019,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,cactiv,cactiv_m, & do k=kts,ktf do i=its,itf tem_shal = dt*(outqcs(i,k)*cutens(i)+outqcm(i,k)*cutenm(i)) - tem_deep = dt*(outqc(i,k)*cuten(i)+clw_ten1(k)) + tem_deep = dt*(outqc(i,k)*cuten(i)+clw_ten(i,k)) tem = tem_shal+tem_deep tem1 = max(0.0, min(1.0, (tcr-t(i,k))*tcrf)) weight_sum = abs(tem_shal)+abs(tem_deep) From 42b95180f64684824ef7985b287a4d341b13ecea Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Mon, 12 Jul 2021 19:55:14 +0000 Subject: [PATCH 05/85] Bug fixes/clean up: (1) removing doxygen bug, (2) removing j indices from the driver. --- physics/module_bl_mynn.F90 | 678 ++++++++++++++++++------------------- 1 file changed, 333 insertions(+), 345 deletions(-) diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 04c6049f5..9f9d69d5d 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -135,11 +135,10 @@ ! Addition of sig_order to regulate the use of higher-order moments ! for sigma when using bl_mynn_cloudpdf = 2 (Chab-Becht). This ! new option is set in the subroutine mym_condensation. -! Not yet: Addition of Greg Thompsons SGS cloud option (bl_mynn_cloudpdf = 3). ! Many miscellaneous tweaks. ! ! Many of these changes are now documented in: -! Olson, J. B., J. S. Kenyon, W. M. Angevine, J. M. Brown, M. Pagowski, and K. Sušelj, 2019: +! Olson, J. B., J. S. Kenyon, W. M. Angevine, J. M. Brown, M. Pagowski, and K. Suselj, 2019: ! A description of the MYNN-EDMF scheme and coupling to other components in WRF-ARW. ! NOAA Tech. Memo. OAR GSD, 61, 37 pp., https://doi.org/10.25923/n9wm-be49. ! Puhales, Franciano S., Joseph B. Olson, Jimy Dudhia, Douglas Lima de Bem, Rafael Maroneze, @@ -933,7 +932,7 @@ SUBROUTINE mym_length ( & vflx = ( vt(kts)+1.0 )*flt +( vq(kts)+tv0 )*flq vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**(1.0/3.0) - ! ** Strictly, el(i,j,1) is not zero. ** + ! ** Strictly, el(i,k=1) is not zero. ** el(kts) = 0.0 zwk1 = zw(kts+1) @@ -4444,31 +4443,30 @@ SUBROUTINE mynn_bl_driver( & ! REAL, INTENT(in) :: dx !END WRF !FV3 - REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(in) :: dx + REAL, DIMENSION(IMS:IME), INTENT(in) :: dx !END FV3 - REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(in) :: dz,& + REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(in) :: dz,& &u,v,w,th,sqv3D,p,exner,rho,T3D - REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), OPTIONAL, INTENT(in)::& + REAL, DIMENSION(IMS:IME,KMS:KME), OPTIONAL, INTENT(in)::& &sqc3D,sqi3D,qni,qnc,qnwfa,qnifa REAL, DIMENSION(IMS:IME,KMS:KME), OPTIONAL, INTENT(in):: ozone - REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(in) :: xland,ust,& + REAL, DIMENSION(IMS:IME), INTENT(in) :: xland,ust,& &ch,ts,qsfc,qcg,ps,hfx,qfx,wspd,uoce,voce,vdfg,znt - REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(inout) :: & + REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & &Qke,Tsq,Qsq,Cov, & !&tke_pbl, & !JOE-added for coupling (TKE_PBL = QKE/2) &qke_adv !ACF for QKE advection - REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(inout) :: & + REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN,RQCBLTEN,& &RQIBLTEN,RQNIBLTEN,RQNCBLTEN, & &RQNWFABLTEN,RQNIFABLTEN REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: DOZONE - REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(in) :: & - &RTHRATEN + REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(in) :: RTHRATEN - REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(out) :: & + REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(out) :: & &exch_h,exch_m !These 10 arrays are only allocated when bl_mynn_output > 0 @@ -4476,33 +4474,32 @@ SUBROUTINE mynn_bl_driver( & & edmf_a,edmf_w,edmf_qt,edmf_thl,edmf_ent,edmf_qc, & & sub_thl3D,sub_sqv3D,det_thl3D,det_sqv3D - REAL, DIMENSION(IMS:IME,KMS:KME) :: & + !REAL, DIMENSION(:,:), OPTIONAL :: & + REAL, DIMENSION(IMS:IME,KMS:KME) :: & & edmf_a_dd,edmf_w_dd,edmf_qt_dd,edmf_thl_dd,edmf_ent_dd,edmf_qc_dd - REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(inout) :: & - &Pblh,wstar,delta,rmol + REAL, DIMENSION(IMS:IME), INTENT(inout) :: Pblh,wstar,delta,rmol - REAL, DIMENSION(IMS:IME,JMS:JME) :: & - &Psig_bl,Psig_shcu + REAL, DIMENSION(IMS:IME) :: Psig_bl,Psig_shcu - INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: & + INTEGER,DIMENSION(IMS:IME),INTENT(INOUT) :: & &KPBL,nupdraft,ktop_plume - REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(OUT) :: & + REAL, DIMENSION(IMS:IME), INTENT(OUT) :: & &maxmf - REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(inout) :: & + REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & &el_pbl - REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(out) :: & + REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(out) :: & &qWT,qSHEAR,qBUOY,qDISS,dqke ! 3D budget arrays are not allocated when bl_mynn_tkebudget == 0. ! 1D (local) budget arrays are used for passing between subroutines. REAL, DIMENSION(KTS:KTE) :: qWT1,qSHEAR1,qBUOY1,qDISS1,dqke1,diss_heat - REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: Sh3D + REAL, DIMENSION(IMS:IME,KMS:KME) :: Sh3D - REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(inout), optional :: & + REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout), optional :: & &qc_bl,qi_bl,cldfra_bl REAL, DIMENSION(KTS:KTE) :: qc_bl1D,qi_bl1D,cldfra_bl1D,& qc_bl1D_old,qi_bl1D_old,cldfra_bl1D_old @@ -4510,9 +4507,9 @@ SUBROUTINE mynn_bl_driver( & ! WA 7/29/15 Mix chemical arrays #if (WRF_CHEM == 1) INTEGER, INTENT(IN ) :: nchem, kdvel, ndvel, num_vert_mix - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, nchem ), INTENT(INOUT), OPTIONAL :: chem3d - REAL, DIMENSION( ims:ime, kdvel, jms:jme, ndvel ), INTENT(IN), OPTIONAL :: vd3d - REAL, DIMENSION(ims:ime,jms:jme), INTENT(IN), OPTIONAL ::FRP_MEAN,EMIS_ANT_NO + REAL, DIMENSION( ims:ime, kms:kme, nchem ), INTENT(INOUT), OPTIONAL :: chem3d + REAL, DIMENSION( ims:ime, kdvel, ndvel ), INTENT(IN), OPTIONAL :: vd3d + REAL, DIMENSION(ims:ime), INTENT(IN), OPTIONAL ::FRP_MEAN,EMIS_ANT_NO REAL, DIMENSION( kts:kte, nchem ) :: chem1 REAL, DIMENSION( kts:kte+1, nchem ) :: s_awchem1 @@ -4550,15 +4547,15 @@ SUBROUTINE mynn_bl_driver( & & th_sfc,ztop_plume,sqc9,sqi9 !JOE-top-down diffusion - REAL, DIMENSION(ITS:ITE,JTS:JTE) :: maxKHtopdown + REAL, DIMENSION(ITS:ITE) :: maxKHtopdown REAL,DIMENSION(KTS:KTE) :: KHtopdown,TKEprodTD !JOE-end top down LOGICAL :: INITIALIZE_QKE ! Stochastic fields - INTEGER, INTENT(IN) ::spp_pbl - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN),OPTIONAL ::pattern_spp_pbl + INTEGER, INTENT(IN) ::spp_pbl + REAL, DIMENSION( ims:ime, kms:kme), INTENT(IN),OPTIONAL ::pattern_spp_pbl REAL, DIMENSION(KTS:KTE) :: rstoch_col @@ -4596,19 +4593,21 @@ SUBROUTINE mynn_bl_driver( & det_thl3D(its:ite,kts:kte)=0. det_sqv3D(its:ite,kts:kte)=0. ENDIF - ktop_plume(its:ite,jts:jte)=0 !int - nupdraft(its:ite,jts:jte)=0 !int - maxmf(its:ite,jts:jte)=0. + ktop_plume(its:ite)=0 !int + nupdraft(its:ite)=0 !int + maxmf(its:ite)=0. ENDIF - maxKHtopdown(its:ite,jts:jte)=0. + maxKHtopdown(its:ite)=0. IF (bl_mynn_edmf_dd > 0) THEN - edmf_a_dd(its:ite,kts:kte)=0. - edmf_w_dd(its:ite,kts:kte)=0. - edmf_qt_dd(its:ite,kts:kte)=0. - edmf_thl_dd(its:ite,kts:kte)=0. - edmf_ent_dd(its:ite,kts:kte)=0. - edmf_qc_dd(its:ite,kts:kte)=0. + IF (bl_mynn_output > 0) THEN + edmf_a_dd(its:ite,kts:kte)=0. + edmf_w_dd(its:ite,kts:kte)=0. + edmf_qt_dd(its:ite,kts:kte)=0. + edmf_thl_dd(its:ite,kts:kte)=0. + edmf_ent_dd(its:ite,kts:kte)=0. + edmf_qc_dd(its:ite,kts:kte)=0. + ENDIF ENDIF ! DH* CHECK HOW MUCH OF THIS INIT IF-BLOCK IS ACTUALLY NEEDED FOR RESTARTS @@ -4620,7 +4619,7 @@ SUBROUTINE mynn_bl_driver( & !Test to see if we want to initialize qke IF ( (restart .or. cycling)) THEN - IF (MAXVAL(QKE(its:ite,kts,jts:jte)) < 0.0002) THEN + IF (MAXVAL(QKE(its:ite,kts)) < 0.0002) THEN INITIALIZE_QKE = .TRUE. !print*,"QKE is too small, must initialize" ELSE @@ -4633,14 +4632,14 @@ SUBROUTINE mynn_bl_driver( & ENDIF if (.not.restart .or. .not.cycling) THEN - Sh3D(its:ite,kts:kte,jts:jte)=0. - el_pbl(its:ite,kts:kte,jts:jte)=0. - tsq(its:ite,kts:kte,jts:jte)=0. - qsq(its:ite,kts:kte,jts:jte)=0. - cov(its:ite,kts:kte,jts:jte)=0. - cldfra_bl(its:ite,kts:kte,jts:jte)=0. - qc_bl(its:ite,kts:kte,jts:jte)=0. - qke(its:ite,kts:kte,jts:jte)=0. + Sh3D(its:ite,kts:kte)=0. + el_pbl(its:ite,kts:kte)=0. + tsq(its:ite,kts:kte)=0. + qsq(its:ite,kts:kte)=0. + cov(its:ite,kts:kte)=0. + cldfra_bl(its:ite,kts:kte)=0. + qc_bl(its:ite,kts:kte)=0. + qke(its:ite,kts:kte)=0. else qc_bl1D(kts:kte)=0.0 qi_bl1D(kts:kte)=0.0 @@ -4665,55 +4664,50 @@ SUBROUTINE mynn_bl_driver( & vt(kts:kte)=0.0 vq(kts:kte)=0.0 - DO j=JTS,JTF - DO k=KTS,KTE - DO i=ITS,ITF - exch_m(i,k,j)=0. - exch_h(i,k,j)=0. - ENDDO - ENDDO + DO k=KTS,KTE + DO i=ITS,ITF + exch_m(i,k)=0. + exch_h(i,k)=0. + ENDDO ENDDO IF ( bl_mynn_tkebudget == 1) THEN - DO j=JTS,JTF - DO k=KTS,KTE - DO i=ITS,ITF - qWT(i,k,j)=0. - qSHEAR(i,k,j)=0. - qBUOY(i,k,j)=0. - qDISS(i,k,j)=0. - dqke(i,k,j)=0. - ENDDO - ENDDO - ENDDO + DO k=KTS,KTE + DO i=ITS,ITF + qWT(i,k)=0. + qSHEAR(i,k)=0. + qBUOY(i,k)=0. + qDISS(i,k)=0. + dqke(i,k)=0. + ENDDO + ENDDO ENDIF - DO j=JTS,JTF - DO i=ITS,ITF - DO k=KTS,KTE !KTF - dz1(k)=dz(i,k,j) - u1(k) = u(i,k,j) - v1(k) = v(i,k,j) - w1(k) = w(i,k,j) - th1(k)=th(i,k,j) - tk1(k)=T3D(i,k,j) - rho1(k)=rho(i,k,j) - sqc(k)=sqc3D(i,k,j) !/(1.+qv(i,k,j)) - sqv(k)=sqv3D(i,k,j) !/(1.+qv(i,k,j)) - thetav(k)=th(i,k,j)*(1.+0.608*sqv(k)) + DO i=ITS,ITF + DO k=KTS,KTE !KTF + dz1(k)=dz(i,k) + u1(k) = u(i,k) + v1(k) = v(i,k) + w1(k) = w(i,k) + th1(k)=th(i,k) + tk1(k)=T3D(i,k) + rho1(k)=rho(i,k) + sqc(k)=sqc3D(i,k) !/(1.+qv(i,k)) + sqv(k)=sqv3D(i,k) !/(1.+qv(i,k)) + thetav(k)=th(i,k)*(1.+0.608*sqv(k)) IF (icloud_bl > 0) THEN - CLDFRA_BL1D(k)=CLDFRA_BL(i,k,j) - QC_BL1D(k)=QC_BL(i,k,j) - QI_BL1D(k)=QI_BL(i,k,j) + CLDFRA_BL1D(k)=CLDFRA_BL(i,k) + QC_BL1D(k)=QC_BL(i,k) + QI_BL1D(k)=QI_BL(i,k) ENDIF IF (PRESENT(sqi3D) .AND. FLAG_QI ) THEN - sqi(k)=sqi3D(i,k,j) !/(1.+qv(i,k,j)) + sqi(k)=sqi3D(i,k) !/(1.+qv(i,k)) sqw(k)=sqv(k)+sqc(k)+sqi(k) - thl(k)=th(i,k,j)- xlvcp/exner(i,k,j)*sqc(k) & - & - xlscp/exner(i,k,j)*sqi(k) + thl(k)=th(i,k)- xlvcp/exner(i,k)*sqc(k) & + & - xlscp/exner(i,k)*sqi(k) !Use form from Tripoli and Cotton (1981) with their !suggested min temperature to improve accuracy. - !thl(k)=th(i,k,j)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) & + !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) & ! & - xlscp/MAX(tk1(k),TKmin)*sqi(k)) !COMPUTE THL USING SGS CLOUDS FOR PBLH DIAG IF(sqc(k)<1e-6 .and. sqi(k)<1e-8 .and. CLDFRA_BL1D(k)>0.001)THEN @@ -4723,15 +4717,15 @@ SUBROUTINE mynn_bl_driver( & sqc9=sqc(k) sqi9=sqi(k) ENDIF - thlsg(k)=th(i,k,j)- xlvcp/exner(i,k,j)*sqc9 & - & - xlscp/exner(i,k,j)*sqi9 + thlsg(k)=th(i,k)- xlvcp/exner(i,k)*sqc9 & + & - xlscp/exner(i,k)*sqi9 ELSE sqi(k)=0.0 sqw(k)=sqv(k)+sqc(k) - thl(k)=th(i,k,j)-xlvcp/exner(i,k,j)*sqc(k) + thl(k)=th(i,k)-xlvcp/exner(i,k)*sqc(k) !Use form from Tripoli and Cotton (1981) with their !suggested min temperature to improve accuracy. - !thl(k)=th(i,k,j)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k)) + !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k)) !COMPUTE THL USING SGS CLOUDS FOR PBLH DIAG IF(sqc(k)<1e-6 .and. CLDFRA_BL1D(k)>0.001)THEN sqc9=QC_BL1D(k)*CLDFRA_BL1D(k) @@ -4740,51 +4734,51 @@ SUBROUTINE mynn_bl_driver( & sqc9=sqc(k) sqi9=0.0 ENDIF - thlsg(k)=th(i,k,j)- xlvcp/exner(i,k,j)*sqc9 & - & - xlscp/exner(i,k,j)*sqi9 + thlsg(k)=th(i,k)- xlvcp/exner(i,k)*sqc9 & + & - xlscp/exner(i,k)*sqi9 ENDIF thvl(k)=thlsg(k)*(1.+0.61*sqv(k)) IF (k==kts) THEN zw(k)=0. ELSE - zw(k)=zw(k-1)+dz(i,k-1,j) + zw(k)=zw(k-1)+dz(i,k-1) ENDIF IF (INITIALIZE_QKE) THEN !Initialize tke for initial PBLH calc only - using !simple PBLH form of Koracin and Berkowicz (1988, BLM) !to linearly taper off tke towards top of PBL. - qke1(k)=5.*ust(i,j) * MAX((ust(i,j)*700. - zw(k))/(MAX(ust(i,j),0.01)*700.), 0.01) + qke1(k)=5.*ust(i) * MAX((ust(i)*700. - zw(k))/(MAX(ust(i),0.01)*700.), 0.01) ELSE - qke1(k)=qke(i,k,j) + qke1(k)=qke(i,k) ENDIF - el(k)=el_pbl(i,k,j) - sh(k)=Sh3D(i,k,j) - tsq1(k)=tsq(i,k,j) - qsq1(k)=qsq(i,k,j) - cov1(k)=cov(i,k,j) + el(k)=el_pbl(i,k) + sh(k)=Sh3D(i,k) + tsq1(k)=tsq(i,k) + qsq1(k)=qsq(i,k) + cov1(k)=cov(i,k) if (spp_pbl==1) then - rstoch_col(k)=pattern_spp_pbl(i,k,j) + rstoch_col(k)=pattern_spp_pbl(i,k) else rstoch_col(k)=0.0 endif ENDDO - zw(kte+1)=zw(kte)+dz(i,kte,j) + zw(kte+1)=zw(kte)+dz(i,kte) !> - Call get_pblh() to calculate hybrid (\f$\theta_{vli}-TKE\f$) PBL height. -! CALL GET_PBLH(KTS,KTE,PBLH(i,j),thetav,& - CALL GET_PBLH(KTS,KTE,PBLH(i,j),thvl,& - & Qke1,zw,dz1,xland(i,j),KPBL(i,j)) +! CALL GET_PBLH(KTS,KTE,PBLH(i),thetav,& + CALL GET_PBLH(KTS,KTE,PBLH(i),thvl, & + & Qke1,zw,dz1,xland(i),KPBL(i)) !> - Call scale_aware() to calculate similarity functions for scale-adaptive control !! (\f$P_{\sigma-PBL}\f$ and \f$P_{\sigma-shcu}\f$). IF (scaleaware > 0.) THEN - CALL SCALE_AWARE(dx(i,j),PBLH(i,j),Psig_bl(i,j),Psig_shcu(i,j)) + CALL SCALE_AWARE(dx(i),PBLH(i),Psig_bl(i),Psig_shcu(i)) ELSE - Psig_bl(i,j)=1.0 - Psig_shcu(i,j)=1.0 + Psig_bl(i)=1.0 + Psig_shcu(i)=1.0 ENDIF ! DH* CHECK IF WE CAN DO WITHOUT CALLING THIS ROUTINE FOR RESTARTS @@ -4794,12 +4788,12 @@ SUBROUTINE mynn_bl_driver( & !! within mym_initialize(): mym_level2() and mym_length(). CALL mym_initialize ( & &kts,kte, & - &dz1, dx(i,j), zw, & + &dz1, dx(i), zw, & &u1, v1, thl, sqv, & - &PBLH(i,j), th1, thetav, sh, sm,& - &ust(i,j), rmol(i,j), & + &PBLH(i), th1, thetav, sh, sm, & + &ust(i), rmol(i), & &el, Qke1, Tsq1, Qsq1, Cov1, & - &Psig_bl(i,j), cldfra_bl1D, & + &Psig_bl(i), cldfra_bl1D, & &bl_mynn_mixlength, & &edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf,& &INITIALIZE_QKE, & @@ -4808,32 +4802,33 @@ SUBROUTINE mynn_bl_driver( & IF (.not.restart) THEN !UPDATE 3D VARIABLES DO k=KTS,KTE !KTF - el_pbl(i,k,j)=el(k) - sh3d(i,k,j)=sh(k) - qke(i,k,j)=qke1(k) - tsq(i,k,j)=tsq1(k) - qsq(i,k,j)=qsq1(k) - cov(i,k,j)=cov1(k) - !ACF,JOE- initialize qke_adv array if using advection - IF (bl_mynn_tkeadvect) THEN - qke_adv(i,k,j)=qke1(k) - ENDIF + el_pbl(i,k)=el(k) + sh3d(i,k)=sh(k) + qke(i,k)=qke1(k) + tsq(i,k)=tsq1(k) + qsq(i,k)=qsq1(k) + cov(i,k)=cov1(k) ENDDO + !initialize qke_adv array if using advection + IF (bl_mynn_tkeadvect) THEN + DO k=KTS,KTE + qke_adv(i,k)=qke1(k) + ENDDO + ENDIF ENDIF !*** Begin debugging ! k=kdebug ! IF(I==IMD .AND. J==JMD)THEN ! PRINT*,"MYNN DRIVER INIT: k=",1," sh=",sh(k) -! PRINT*," sqw=",sqw(k)," thl=",thl(k)," k_m=",exch_m(i,k,j) -! PRINT*," xland=",xland(i,j)," rmol=",rmol(i,j)," ust=",ust(i,j) -! PRINT*," qke=",qke(i,k,j)," el=",el_pbl(i,k,j)," tsq=",Tsq(i,k,j) -! PRINT*," PBLH=",PBLH(i,j)," u=",u(i,k,j)," v=",v(i,k,j) +! PRINT*," sqw=",sqw(k)," thl=",thl(k)," k_m=",exch_m(i,k) +! PRINT*," xland=",xland(i)," rmol=",rmol(i)," ust=",ust(i) +! PRINT*," qke=",qke(i,k)," el=",el_pbl(i,k)," tsq=",Tsq(i,k) +! PRINT*," PBLH=",PBLH(i)," u=",u(i,k)," v=",v(i,k) ! ENDIF !*** End debugging - ENDDO - ENDDO + ENDDO !end i-loop ENDIF ! end initflag @@ -4844,20 +4839,19 @@ SUBROUTINE mynn_bl_driver( & qke=qke_adv ENDIF - DO j=JTS,JTF - DO i=ITS,ITF - DO k=KTS,KTE !KTF + DO i=ITS,ITF + DO k=KTS,KTE !KTF !JOE-TKE BUDGET IF ( bl_mynn_tkebudget == 1) THEN - dqke(i,k,j)=qke(i,k,j) + dqke(i,k)=qke(i,k) END IF IF (icloud_bl > 0) THEN - CLDFRA_BL1D(k)=CLDFRA_BL(i,k,j) - QC_BL1D(k)=QC_BL(i,k,j) - QI_BL1D(k)=QI_BL(i,k,j) - cldfra_bl1D_old(k)=cldfra_bl(i,k,j) - qc_bl1D_old(k)=qc_bl(i,k,j) - qi_bl1D_old(k)=qi_bl(i,k,j) + CLDFRA_BL1D(k)=CLDFRA_BL(i,k) + QC_BL1D(k)=QC_BL(i,k) + QI_BL1D(k)=QI_BL(i,k) + cldfra_bl1D_old(k)=cldfra_bl(i,k) + qc_bl1D_old(k)=qc_bl(i,k) + qi_bl1D_old(k)=qi_bl(i,k) else CLDFRA_BL1D(k)=0.0 QC_BL1D(k)=0.0 @@ -4866,17 +4860,17 @@ SUBROUTINE mynn_bl_driver( & qc_bl1D_old(k)=0.0 qi_bl1D_old(k)=0.0 ENDIF - dz1(k)= dz(i,k,j) - u1(k) = u(i,k,j) - v1(k) = v(i,k,j) - w1(k) = w(i,k,j) - th1(k)= th(i,k,j) - tk1(k)=T3D(i,k,j) - rho1(k)=rho(i,k,j) - qv1(k)= sqv3D(i,k,j)/(1.-sqv3D(i,k,j)) - qc1(k)= sqc3D(i,k,j)/(1.-sqv3D(i,k,j)) - sqv(k)= sqv3D(i,k,j) !/(1.+qv(i,k,j)) - sqc(k)= sqc3D(i,k,j) !/(1.+qv(i,k,j)) + dz1(k)= dz(i,k) + u1(k) = u(i,k) + v1(k) = v(i,k) + w1(k) = w(i,k) + th1(k)= th(i,k) + tk1(k)=T3D(i,k) + rho1(k)=rho(i,k) + qv1(k)= sqv3D(i,k)/(1.-sqv3D(i,k)) + qc1(k)= sqc3D(i,k)/(1.-sqv3D(i,k)) + sqv(k)= sqv3D(i,k) !/(1.+qv(i,k)) + sqc(k)= sqc3D(i,k) !/(1.+qv(i,k)) dqc1(k)=0.0 dqi1(k)=0.0 dqni1(k)=0.0 @@ -4885,14 +4879,14 @@ SUBROUTINE mynn_bl_driver( & dqnifa1(k)=0.0 dozone1(k)=0.0 IF(PRESENT(sqi3D) .AND. FLAG_QI)THEN - qi1(k)= sqi3D(i,k,j)/(1.-sqv3D(i,k,j)) - sqi(k)= sqi3D(i,k,j) !/(1.+qv(i,k,j)) + qi1(k)= sqi3D(i,k)/(1.-sqv3D(i,k)) + sqi(k)= sqi3D(i,k) !/(1.+qv(i,k)) sqw(k)= sqv(k)+sqc(k)+sqi(k) - thl(k)= th(i,k,j) - xlvcp/exner(i,k,j)*sqc(k) & - & - xlscp/exner(i,k,j)*sqi(k) + thl(k)= th(i,k) - xlvcp/exner(i,k)*sqc(k) & + & - xlscp/exner(i,k)*sqi(k) !Use form from Tripoli and Cotton (1981) with their !suggested min temperature to improve accuracy. - !thl(k)=th(i,k,j)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) & + !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) & ! & - xlscp/MAX(tk1(k),TKmin)*sqi(k)) !COMPUTE THL USING SGS CLOUDS FOR PBLH DIAG IF(sqc(k)<1e-6 .and. sqi(k)<1e-8 .and. CLDFRA_BL1D(k)>0.001)THEN @@ -4902,16 +4896,16 @@ SUBROUTINE mynn_bl_driver( & sqc9=sqc(k) sqi9=sqi(k) ENDIF - thlsg(k)=th(i,k,j)- xlvcp/exner(i,k,j)*sqc9 & - & - xlscp/exner(i,k,j)*sqi9 + thlsg(k)=th(i,k)- xlvcp/exner(i,k)*sqc9 & + & - xlscp/exner(i,k)*sqi9 ELSE qi1(k)=0.0 sqi(k)=0.0 sqw(k)= sqv(k)+sqc(k) - thl(k)= th(i,k,j)-xlvcp/exner(i,k,j)*sqc(k) + thl(k)= th(i,k)-xlvcp/exner(i,k)*sqc(k) !Use form from Tripoli and Cotton (1981) with their !suggested min temperature to improve accuracy. - !thl(k)=th(i,k,j)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k)) + !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k)) !COMPUTE THL USING SGS CLOUDS FOR PBLH DIAG IF(sqc(k)<1e-6 .and. CLDFRA_BL1D(k)>0.001)THEN sqc9=QC_BL1D(k)*CLDFRA_BL1D(k) @@ -4920,29 +4914,29 @@ SUBROUTINE mynn_bl_driver( & sqc9=sqc(k) sqi9=0.0 ENDIF - thlsg(k)=th(i,k,j)- xlvcp/exner(i,k,j)*sqc9 & - & - xlscp/exner(i,k,j)*sqi9 + thlsg(k)=th(i,k)- xlvcp/exner(i,k)*sqc9 & + & - xlscp/exner(i,k)*sqi9 ENDIF - thetav(k)=th(i,k,j)*(1.+0.608*sqv(k)) + thetav(k)=th(i,k)*(1.+0.608*sqv(k)) thvl(k) =thlsg(k) *(1.+0.608*sqv(k)) IF (PRESENT(qni) .AND. FLAG_QNI ) THEN - qni1(k)=qni(i,k,j) + qni1(k)=qni(i,k) ELSE qni1(k)=0.0 ENDIF IF (PRESENT(qnc) .AND. FLAG_QNC ) THEN - qnc1(k)=qnc(i,k,j) + qnc1(k)=qnc(i,k) ELSE qnc1(k)=0.0 ENDIF IF (PRESENT(qnwfa) .AND. FLAG_QNWFA ) THEN - qnwfa1(k)=qnwfa(i,k,j) + qnwfa1(k)=qnwfa(i,k) ELSE qnwfa1(k)=0.0 ENDIF IF (PRESENT(qnifa) .AND. FLAG_QNIFA ) THEN - qnifa1(k)=qnifa(i,k,j) + qnifa1(k)=qnifa(i,k) ELSE qnifa1(k)=0.0 ENDIF @@ -4951,16 +4945,16 @@ SUBROUTINE mynn_bl_driver( & ELSE ozone1(k)=0.0 ENDIF - p1(k) = p(i,k,j) - ex1(k)= exner(i,k,j) - el(k) = el_pbl(i,k,j) - qke1(k)=qke(i,k,j) - sh(k) = sh3d(i,k,j) - tsq1(k)=tsq(i,k,j) - qsq1(k)=qsq(i,k,j) - cov1(k)=cov(i,k,j) + p1(k) = p(i,k) + ex1(k)= exner(i,k) + el(k) = el_pbl(i,k) + qke1(k)=qke(i,k) + sh(k) = sh3d(i,k) + tsq1(k)=tsq(i,k) + qsq1(k)=qsq(i,k) + cov1(k)=cov(i,k) if (spp_pbl==1) then - rstoch_col(k)=pattern_spp_pbl(i,k,j) + rstoch_col(k)=pattern_spp_pbl(i,k) else rstoch_col(k)=0.0 endif @@ -5009,12 +5003,12 @@ SUBROUTINE mynn_bl_driver( & IF (PRESENT(chem3d) .AND. PRESENT(vd3d)) THEN ! WA 7/29/15 Set up chemical arrays DO ic = 1,nchem - chem1(k,ic) = chem3d(i,k,j,ic) + chem1(k,ic) = chem3d(i,k,ic) s_awchem1(k,ic)=0. ENDDO DO ic = 1,ndvel IF (k == KTS) THEN - vd1(ic) = vd3d(i,1,j,ic) + vd1(ic) = vd3d(i,1,ic) ENDIF ENDDO ELSE @@ -5034,11 +5028,11 @@ SUBROUTINE mynn_bl_driver( & IF (k==kts) THEN zw(k)=0. ELSE - zw(k)=zw(k-1)+dz(i,k-1,j) + zw(k)=zw(k-1)+dz(i,k-1) ENDIF ENDDO ! end k - zw(kte+1)=zw(kte)+dz(i,kte,j) + zw(kte+1)=zw(kte)+dz(i,kte) !EDMF s_aw1(kte+1)=0. s_awthl1(kte+1)=0. @@ -5068,51 +5062,51 @@ SUBROUTINE mynn_bl_driver( & !> - Call get_pblh() to calculate the hybrid \f$\theta_{vli}-TKE\f$ !! PBL height diagnostic. -! CALL GET_PBLH(KTS,KTE,PBLH(i,j),thetav,& - CALL GET_PBLH(KTS,KTE,PBLH(i,j),thvl,& - & Qke1,zw,dz1,xland(i,j),KPBL(i,j)) +! CALL GET_PBLH(KTS,KTE,PBLH(i),thetav,& + CALL GET_PBLH(KTS,KTE,PBLH(i),thvl,& + & Qke1,zw,dz1,xland(i),KPBL(i)) !> - Call scale_aware() to calculate the similarity functions, !! \f$P_{\sigma-PBL}\f$ and \f$P_{\sigma-shcu}\f$, to control !! the scale-adaptive behaviour for the local and nonlocal !! components, respectively. IF (scaleaware > 0.) THEN - CALL SCALE_AWARE(dx(i,j),PBLH(i,j),Psig_bl(i,j),Psig_shcu(i,j)) + CALL SCALE_AWARE(dx(i),PBLH(i),Psig_bl(i),Psig_shcu(i)) ELSE - Psig_bl(i,j)=1.0 - Psig_shcu(i,j)=1.0 + Psig_bl(i)=1.0 + Psig_shcu(i)=1.0 ENDIF - sqcg= 0.0 !JOE, it was: qcg(i,j)/(1.+qcg(i,j)) + sqcg= 0.0 !JOE, it was: qcg(i)/(1.+qcg(i)) cpm=cp*(1.+0.84*qv1(kts)) - exnerg=(ps(i,j)/p1000mb)**rcp + exnerg=(ps(i)/p1000mb)**rcp !----------------------------------------------------- !ORIGINAL CODE - !flt = hfx(i,j)/( rho(i,kts,j)*cpm ) & - ! +xlvcp*ch(i,j)*(sqc(kts)/exner(i,kts,j) -sqcg/exnerg) - !flq = qfx(i,j)/ rho(i,kts,j) & - ! -ch(i,j)*(sqc(kts) -sqcg ) + !flt = hfx(i)/( rho(i,kts)*cpm ) & + ! +xlvcp*ch(i)*(sqc(kts)/exner(i,kts) -sqcg/exnerg) + !flq = qfx(i)/ rho(i,kts) & + ! -ch(i)*(sqc(kts) -sqcg ) !----------------------------------------------------- ! Katata-added - The deposition velocity of cloud (fog) ! water is used instead of CH. - !flt = hfx(i,j)/( rho(i,kts,j)*cpm ) & - ! & +xlvcp*vdfg(i,j)*(sqc(kts)/exner(i,kts,j)- sqcg/exnerg) - !flq = qfx(i,j)/ rho(i,kts,j) & - ! & -vdfg(i,j)*(sqc(kts) - sqcg ) + !flt = hfx(i)/( rho(i,kts)*cpm ) & + ! & +xlvcp*vdfg(i)*(sqc(kts)/exner(i,kts)- sqcg/exnerg) + !flq = qfx(i)/ rho(i,kts) & + ! & -vdfg(i)*(sqc(kts) - sqcg ) !----------------------------------------------------- - flqv = qfx(i,j)/rho1(kts) - flqc = -vdfg(i,j)*(sqc(kts) - sqcg ) - th_sfc = ts(i,j)/ex1(kts) + flqv = qfx(i)/rho1(kts) + flqc = -vdfg(i)*(sqc(kts) - sqcg ) + th_sfc = ts(i)/ex1(kts) ! TURBULENT FLUX FOR TKE BOUNDARY CONDITIONS flq =flqv+flqc !! LATENT - flt =hfx(i,j)/(rho1(kts)*cpm )-xlvcp*flqc/exner(i,kts,j) !! Temperature flux + flt =hfx(i)/(rho1(kts)*cpm )-xlvcp*flqc/exner(i,kts) !! Temperature flux fltv=flt + flqv*ep_1*th_sfc !! Virtual temperature flux ! Update 1/L using updated sfc heat flux and friction velocity - rmol(i,j) = -vk*gtr*fltv/max(ust(i,j)**3,1.0e-6) - zet = 0.5*dz(i,kts,j)*rmol(i,j) + rmol(i) = -vk*gtr*fltv/max(ust(i)**3,1.0e-6) + zet = 0.5*dz(i,kts)*rmol(i) zet = MAX(zet, -20.) zet = MIN(zet, 20.) if (bl_mynn_stfunc == 0) then @@ -5137,31 +5131,31 @@ SUBROUTINE mynn_bl_driver( & !! selected by use of the namelist parameter \p bl_mynn_cloudpdf. CALL mym_condensation ( kts,kte, & - &dx(i,j),dz1,zw,thl,sqw,sqv,sqc,sqi,& + &dx(i),dz1,zw,thl,sqw,sqv,sqc,sqi,& &p1,ex1,tsq1,qsq1,cov1, & &Sh,el,bl_mynn_cloudpdf, & &qc_bl1D,qi_bl1D,cldfra_bl1D, & - &PBLH(i,j),HFX(i,j), & - &Vt, Vq, th1, sgm, rmol(i,j), & + &PBLH(i),HFX(i), & + &Vt, Vq, th1, sgm, rmol(i), & &spp_pbl, rstoch_col ) !> - Add TKE source driven by cloud top cooling !! Calculate the buoyancy production of TKE from cloud-top cooling when !! \p bl_mynn_topdown =1. IF (bl_mynn_topdown.eq.1)then - CALL topdown_cloudrad(kts,kte,dz1,zw, & - &xland(i,j),kpbl(i,j),PBLH(i,j), & - &sqc,sqi,sqw,thl,th1,ex1,p1,rho1,thetav, & - &cldfra_bl1D,rthraten, & - &maxKHtopdown(i,j),KHtopdown,TKEprodTD ) + CALL topdown_cloudrad(kts,kte,dz1,zw, & + &xland(i),kpbl(i),PBLH(i), & + &sqc,sqi,sqw,thl,th1,ex1,p1,rho1,thetav, & + &cldfra_bl1D,rthraten, & + &maxKHtopdown(i),KHtopdown,TKEprodTD ) ELSE - maxKHtopdown(i,j) = 0.0 + maxKHtopdown(i) = 0.0 KHtopdown(kts:kte) = 0.0 TKEprodTD(kts:kte) = 0.0 ENDIF IF (bl_mynn_edmf > 0) THEN - !PRINT*,"Calling DMP Mass-Flux: i= ",i," j=",j + !PRINT*,"Calling DMP Mass-Flux: i= ",i," j=" CALL DMP_mf( & &kts,kte,delt,zw,dz1,p1, & &bl_mynn_edmf_mom, & @@ -5171,11 +5165,11 @@ SUBROUTINE mynn_bl_driver( & &sqw,sqv,sqc,qke1, & &qnc1,qni1,qnwfa1,qnifa1, & &ex1,Vt,Vq,sgm, & - &ust(i,j),flt,flq,flqv,flqc, & - &PBLH(i,j),KPBL(i,j),DX(i,j), & - &xland(i,j),th_sfc, & + &ust(i),flt,flq,flqv,flqc, & + &PBLH(i),KPBL(i),DX(i), & + &xland(i),th_sfc, & ! now outputs - tendencies - ! &,dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf & + ! &,dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf & ! outputs - updraft properties & edmf_a1,edmf_w1,edmf_qt1, & & edmf_thl1,edmf_ent1,edmf_qc1, & @@ -5198,9 +5192,9 @@ SUBROUTINE mynn_bl_driver( & & FLAG_QC,FLAG_QI, & & FLAG_QNC,FLAG_QNI, & & FLAG_QNWFA,FLAG_QNIFA, & - & Psig_shcu(i,j), & - & nupdraft(i,j),ktop_plume(i,j), & - & maxmf(i,j),ztop_plume, & + & Psig_shcu(i), & + & nupdraft(i),ktop_plume(i), & + & maxmf(i),ztop_plume, & & spp_pbl,rstoch_col ) ENDIF @@ -5208,8 +5202,8 @@ SUBROUTINE mynn_bl_driver( & CALL DDMF_JPL(kts,kte,delt,zw,dz1,p1, & &u1,v1,th1,thl,thetav,tk1, & sqw,sqv,sqc,rho1,ex1, & - &ust(i,j),flt,flq, & - &PBLH(i,j),KPBL(i,j), & + &ust(i),flt,flq, & + &PBLH(i),KPBL(i), & &edmf_a_dd1,edmf_w_dd1,edmf_qt_dd1, & &edmf_thl_dd1,edmf_ent_dd1, & &edmf_qc_dd1, & @@ -5217,26 +5211,26 @@ SUBROUTINE mynn_bl_driver( & &sd_awqv1,sd_awqc1,sd_awu1,sd_awv1, & &sd_awqke1, & &qc_bl1d,cldfra_bl1d, & - &rthraten(i,:,j) ) + &rthraten(i,:) ) ENDIF !> - Call mym_turbulence() to collect the necessary variable !! to carry out successive claculations. CALL mym_turbulence ( & &kts,kte,closure, & - &dz1, DX(i,j), zw, & + &dz1, DX(i), zw, & &u1, v1, thl, thetav, sqc, sqw, & &qke1, tsq1, qsq1, cov1, & &vt, vq, & - &rmol(i,j), flt, flq, & - &PBLH(i,j),th1, & + &rmol(i), flt, flq, & + &PBLH(i),th1, & &Sh,Sm,el, & &Dfm,Dfh,Dfq, & &Tcd,Qcd,Pdk, & &Pdt,Pdq,Pdc, & &qWT1,qSHEAR1,qBUOY1,qDISS1, & &bl_mynn_tkebudget, & - &Psig_bl(i,j),Psig_shcu(i,j), & + &Psig_bl(i),Psig_shcu(i), & &cldfra_bl1D,bl_mynn_mixlength, & &edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf, & &TKEprodTD, & @@ -5247,7 +5241,7 @@ SUBROUTINE mynn_bl_driver( & !! for the following time step. CALL mym_predict (kts,kte,closure, & &delt, dz1, & - &ust(i,j), flt, flq, pmz, phh, & + &ust(i), flt, flq, pmz, phh, & &el, dfq, rho1, pdk, pdt, pdq, pdc,& &Qke1, Tsq1, Qsq1, Cov1, & &s_aw1, s_awqke1, bl_mynn_edmf_tke,& @@ -5266,19 +5260,19 @@ SUBROUTINE mynn_bl_driver( & &delt, dz1, rho1, & &u1, v1, th1, tk1, qv1, & &qc1, qi1, qnc1, qni1, & - &ps(i,j), p1, ex1, thl, & + &ps(i), p1, ex1, thl, & &sqv, sqc, sqi, sqw, & &qnwfa1, qnifa1, ozone1, & - &ust(i,j),flt,flq,flqv,flqc, & - &wspd(i,j),qcg(i,j), & - &uoce(i,j),voce(i,j), & + &ust(i),flt,flq,flqv,flqc, & + &wspd(i),qcg(i), & + &uoce(i),voce(i), & &tsq1, qsq1, cov1, & &tcd, qcd, & &dfm, dfh, dfq, & &Du1, Dv1, Dth1, Dqv1, & &Dqc1, Dqi1, Dqnc1, Dqni1, & &Dqnwfa1, Dqnifa1, Dozone1, & - &vdfg(i,j), diss_heat, & + &vdfg(i), diss_heat, & ! mass flux components &s_aw1,s_awthl1,s_awqt1, & &s_awqv1,s_awqc1,s_awu1,s_awv1, & @@ -5297,32 +5291,32 @@ SUBROUTINE mynn_bl_driver( & &bl_mynn_mixqt, & &bl_mynn_edmf, & &bl_mynn_edmf_mom, & - &bl_mynn_mixscalars ) + &bl_mynn_mixscalars ) #if (WRF_CHEM == 1) IF ( mynn_chem_vertmx ) THEN - CALL mynn_mix_chem(kts,kte,i,j, & - grav_settling, & - delt, dz1, pblh(i,j), & - nchem, kdvel, ndvel, num_vert_mix, & - chem1, vd1, & - qnc1,qni1, & - p1, ex1, thl, sqv, sqc, sqi, sqw,& - rho1, ust(i,j),flt,flq,flqv,flqc,& - wspd(i,j),qcg(i,j), & - tcd, qcd, & - &dfm, dfh, dfq, & + CALL mynn_mix_chem(kts,kte,i, & + grav_settling, & + delt, dz1, pblh(i), & + nchem, kdvel, ndvel, num_vert_mix,& + chem1, vd1, & + qnc1,qni1, & + p1, ex1, thl, sqv, sqc, sqi, sqw, & + rho1, ust(i),flt,flq,flqv,flqc, & + wspd(i),qcg(i), & + tcd, qcd, & + &dfm, dfh, dfq, & ! mass flux components - & s_aw1, & - & s_awchem1, & - &bl_mynn_cloudmix, & - EMIS_ANT_NO(i,j), & - FRP_MEAN(i,j), & + & s_aw1, & + & s_awchem1, & + &bl_mynn_cloudmix, & + EMIS_ANT_NO(i), & + FRP_MEAN(i), & enh_vermix) IF (PRESENT(chem3d) ) THEN DO ic = 1,nchem DO k = kts,kte - chem3d(i,k,j,ic) = chem1(k,ic) + chem3d(i,k,ic) = chem1(k,ic) ENDDO ENDDO ENDIF @@ -5335,29 +5329,29 @@ SUBROUTINE mynn_bl_driver( & !UPDATE 3D ARRAYS DO k=KTS,KTE !KTF - exch_m(i,k,j)=K_m1(k) - exch_h(i,k,j)=K_h1(k) - RUBLTEN(i,k,j)=du1(k) - RVBLTEN(i,k,j)=dv1(k) - RTHBLTEN(i,k,j)=dth1(k) - RQVBLTEN(i,k,j)=dqv1(k) + exch_m(i,k)=K_m1(k) + exch_h(i,k)=K_h1(k) + RUBLTEN(i,k)=du1(k) + RVBLTEN(i,k)=dv1(k) + RTHBLTEN(i,k)=dth1(k) + RQVBLTEN(i,k)=dqv1(k) IF(bl_mynn_cloudmix > 0)THEN - IF (PRESENT(sqc3D) .AND. FLAG_QC) RQCBLTEN(i,k,j)=dqc1(k) - IF (PRESENT(sqi3D) .AND. FLAG_QI) RQIBLTEN(i,k,j)=dqi1(k) + IF (PRESENT(sqc3D) .AND. FLAG_QC) RQCBLTEN(i,k)=dqc1(k) + IF (PRESENT(sqi3D) .AND. FLAG_QI) RQIBLTEN(i,k)=dqi1(k) ELSE - IF (PRESENT(sqc3D) .AND. FLAG_QC) RQCBLTEN(i,k,j)=0. - IF (PRESENT(sqi3D) .AND. FLAG_QI) RQIBLTEN(i,k,j)=0. + IF (PRESENT(sqc3D) .AND. FLAG_QC) RQCBLTEN(i,k)=0. + IF (PRESENT(sqi3D) .AND. FLAG_QI) RQIBLTEN(i,k)=0. ENDIF IF(bl_mynn_cloudmix > 0 .AND. bl_mynn_mixscalars > 0)THEN - IF (PRESENT(qnc) .AND. FLAG_QNC) RQNCBLTEN(i,k,j)=dqnc1(k) - IF (PRESENT(qni) .AND. FLAG_QNI) RQNIBLTEN(i,k,j)=dqni1(k) - IF (PRESENT(qnwfa) .AND. FLAG_QNWFA) RQNWFABLTEN(i,k,j)=dqnwfa1(k) - IF (PRESENT(qnifa) .AND. FLAG_QNIFA) RQNIFABLTEN(i,k,j)=dqnifa1(k) + IF (PRESENT(qnc) .AND. FLAG_QNC) RQNCBLTEN(i,k)=dqnc1(k) + IF (PRESENT(qni) .AND. FLAG_QNI) RQNIBLTEN(i,k)=dqni1(k) + IF (PRESENT(qnwfa) .AND. FLAG_QNWFA) RQNWFABLTEN(i,k)=dqnwfa1(k) + IF (PRESENT(qnifa) .AND. FLAG_QNIFA) RQNIFABLTEN(i,k)=dqnifa1(k) ELSE - IF (PRESENT(qnc) .AND. FLAG_QNC) RQNCBLTEN(i,k,j)=0. - IF (PRESENT(qni) .AND. FLAG_QNI) RQNIBLTEN(i,k,j)=0. - IF (PRESENT(qnwfa) .AND. FLAG_QNWFA) RQNWFABLTEN(i,k,j)=0. - IF (PRESENT(qnifa) .AND. FLAG_QNIFA) RQNIFABLTEN(i,k,j)=0. + IF (PRESENT(qnc) .AND. FLAG_QNC) RQNCBLTEN(i,k)=0. + IF (PRESENT(qni) .AND. FLAG_QNI) RQNIBLTEN(i,k)=0. + IF (PRESENT(qnwfa) .AND. FLAG_QNWFA) RQNWFABLTEN(i,k)=0. + IF (PRESENT(qnifa) .AND. FLAG_QNIFA) RQNIFABLTEN(i,k)=0. ENDIF DOZONE(i,k)=DOZONE1(k) @@ -5367,34 +5361,34 @@ SUBROUTINE mynn_bl_driver( & !DECAY TIMESCALE FOR CALM CONDITION IS THE EDDY TURNOVER !TIMESCALE, BUT FOR WINDY CONDITIONS, IT IS THE ADVECTIVE !TIMESCALE. USE THE MINIMUM OF THE TWO. - ts_decay = MIN( 1800., 3.*dx(i,j)/MAX(SQRT(u1(k)**2 + v1(k)**2),1.0) ) - cldfra_bl(i,k,j)= MAX(cldfra_bl1D(k),cldfra_bl1D_old(k)-(0.25*delt/ts_decay)) + ts_decay = MIN( 1800., 3.*dx(i)/MAX(SQRT(u1(k)**2 + v1(k)**2),1.0) ) + cldfra_bl(i,k)= MAX(cldfra_bl1D(k),cldfra_bl1D_old(k)-(0.25*delt/ts_decay)) ! qc_bl2 and qi_bl2 are decay rates qc_bl2 = MAX(qc_bl1D(k),qc_bl1D_old(k)) qc_bl2 = MAX(qc_bl2,1.0E-5) qi_bl2 = MAX(qi_bl1D(k),qi_bl1D_old(k)) qi_bl2 = MAX(qi_bl2,1.0E-6) - qc_bl(i,k,j) = MAX(qc_bl1D(k),qc_bl1D_old(k)-(MIN(qc_bl2,1.0E-4) * delt/ts_decay)) - qi_bl(i,k,j) = MAX(qi_bl1D(k),qi_bl1D_old(k)-(MIN(qi_bl2,1.0E-5) * delt/ts_decay)) - IF (cldfra_bl(i,k,j) < 0.005 .OR. & - (qc_bl(i,k,j) + qi_bl(i,k,j)) < 1E-9) THEN - CLDFRA_BL(i,k,j)= 0. - QC_BL(i,k,j) = 0. - QI_BL(i,k,j) = 0. + qc_bl(i,k) = MAX(qc_bl1D(k),qc_bl1D_old(k)-(MIN(qc_bl2,1.0E-4) * delt/ts_decay)) + qi_bl(i,k) = MAX(qi_bl1D(k),qi_bl1D_old(k)-(MIN(qi_bl2,1.0E-5) * delt/ts_decay)) + IF (cldfra_bl(i,k) < 0.005 .OR. & + (qc_bl(i,k) + qi_bl(i,k)) < 1E-9) THEN + CLDFRA_BL(i,k)= 0. + QC_BL(i,k) = 0. + QI_BL(i,k) = 0. ENDIF ELSE - qc_bl(i,k,j)=qc_bl1D(k) - qi_bl(i,k,j)=qi_bl1D(k) - cldfra_bl(i,k,j)=cldfra_bl1D(k) + qc_bl(i,k)=qc_bl1D(k) + qi_bl(i,k)=qi_bl1D(k) + cldfra_bl(i,k)=cldfra_bl1D(k) ENDIF ENDIF - el_pbl(i,k,j)=el(k) - qke(i,k,j)=qke1(k) - tsq(i,k,j)=tsq1(k) - qsq(i,k,j)=qsq1(k) - cov(i,k,j)=cov1(k) - sh3d(i,k,j)=sh(k) + el_pbl(i,k)=el(k) + qke(i,k)=qke1(k) + tsq(i,k)=tsq1(k) + qsq(i,k)=qsq1(k) + cov(i,k)=cov1(k) + sh3d(i,k)=sh(k) ENDDO !end-k @@ -5402,23 +5396,23 @@ SUBROUTINE mynn_bl_driver( & !! TKE budget is now given in m**2/s**-3 (Puhales, 2020) !! Lower boundary condtions (using similarity relationships such as the prognostic equation for Qke) k=kts - qSHEAR1(k)=4.*(ust(i,j)**3*phi_m/(vk*dz(i,k,j)))-qSHEAR1(k+1) !! staggered - qBUOY1(k)=4.*(-ust(i,j)**3*zet/(vk*dz(i,k,j)))-qBUOY1(k+1) !! staggered + qSHEAR1(k)=4.*(ust(i)**3*phi_m/(vk*dz(i,k)))-qSHEAR1(k+1) !! staggered + qBUOY1(k)=4.*(-ust(i)**3*zet/(vk*dz(i,k)))-qBUOY1(k+1) !! staggered !! unstaggering SHEAR and BUOY and trasfering all TKE budget to 3D array DO k = kts,kte-1 - qSHEAR(i,k,j)=0.5*(qSHEAR1(k)+qSHEAR1(k+1)) !!! unstaggering in z - qBUOY(i,k,j)=0.5*(qBUOY1(k)+qBUOY1(k+1)) !!! unstaggering in z - qWT(i,k,j)=qWT1(k) - qDISS(i,k,j)=qDISS1(k) - dqke(i,k,j)=(qke1(k)-dqke(i,k,j))*0.5/delt + qSHEAR(i,k)=0.5*(qSHEAR1(k)+qSHEAR1(k+1)) !!! unstaggering in z + qBUOY(i,k)=0.5*(qBUOY1(k)+qBUOY1(k+1)) !!! unstaggering in z + qWT(i,k)=qWT1(k) + qDISS(i,k)=qDISS1(k) + dqke(i,k)=(qke1(k)-dqke(i,k))*0.5/delt ENDDO !! Upper boundary conditions k=kte - qSHEAR(i,k,j)=0. - qBUOY(i,k,j)=0. - qWT(i,k,j)=0. - qDISS(i,k,j)=0. - dqke(i,k,j)=0. + qSHEAR(i,k)=0. + qBUOY(i,k)=0. + qWT(i,k)=0. + qDISS(i,k)=0. + dqke(i,k)=0. ENDIF !update updraft properties @@ -5450,36 +5444,36 @@ SUBROUTINE mynn_bl_driver( & IF ( debug_code ) THEN DO k = kts,kte IF ( sh(k) < 0. .OR. sh(k)> 200.)print*,& - "SUSPICIOUS VALUES AT: i,j,k=",i,j,k," sh=",sh(k) - IF ( qke(i,k,j) < -1. .OR. qke(i,k,j)> 200.)print*,& - "SUSPICIOUS VALUES AT: i,j,k=",i,j,k," qke=",qke(i,k,j) - IF ( el_pbl(i,k,j) < 0. .OR. el_pbl(i,k,j)> 2000.)print*,& - "SUSPICIOUS VALUES AT: i,j,k=",i,j,k," el_pbl=",el_pbl(i,k,j) + "SUSPICIOUS VALUES AT: i,k=",i,k," sh=",sh(k) + IF ( qke(i,k) < -1. .OR. qke(i,k)> 200.)print*,& + "SUSPICIOUS VALUES AT: i,k=",i,k," qke=",qke(i,k) + IF ( el_pbl(i,k) < 0. .OR. el_pbl(i,k)> 2000.)print*,& + "SUSPICIOUS VALUES AT: i,k=",i,k," el_pbl=",el_pbl(i,k) IF ( ABS(vt(k)) > 0.8 )print*,& - "SUSPICIOUS VALUES AT: i,j,k=",i,j,k," vt=",vt(k) + "SUSPICIOUS VALUES AT: i,k=",i,k," vt=",vt(k) IF ( ABS(vq(k)) > 6000.)print*,& - "SUSPICIOUS VALUES AT: i,j,k=",i,j,k," vq=",vq(k) - IF ( exch_m(i,k,j) < 0. .OR. exch_m(i,k,j)> 2000.)print*,& - "SUSPICIOUS VALUES AT: i,j,k=",i,j,k," exxch_m=",exch_m(i,k,j) - IF ( vdfg(i,j) < 0. .OR. vdfg(i,j)>5. )print*,& - "SUSPICIOUS VALUES AT: i,j,k=",i,j,k," vdfg=",vdfg(i,j) - IF ( ABS(QFX(i,j))>.001)print*,& - "SUSPICIOUS VALUES AT: i,j=",i,j," QFX=",QFX(i,j) - IF ( ABS(HFX(i,j))>1000.)print*,& - "SUSPICIOUS VALUES AT: i,j=",i,j," HFX=",HFX(i,j) + "SUSPICIOUS VALUES AT: i,k=",i,k," vq=",vq(k) + IF ( exch_m(i,k) < 0. .OR. exch_m(i,k)> 2000.)print*,& + "SUSPICIOUS VALUES AT: i,k=",i,k," exxch_m=",exch_m(i,k) + IF ( vdfg(i) < 0. .OR. vdfg(i)>5. )print*,& + "SUSPICIOUS VALUES AT: i,k=",i,k," vdfg=",vdfg(i) + IF ( ABS(QFX(i))>.001)print*,& + "SUSPICIOUS VALUES AT: i=",i," QFX=",QFX(i) + IF ( ABS(HFX(i))>1000.)print*,& + "SUSPICIOUS VALUES AT: i=",i," HFX=",HFX(i) IF (icloud_bl > 0) then - IF( cldfra_bl(i,k,j) < 0.0 .OR. cldfra_bl(i,k,j)> 1.)THEN - PRINT*,"SUSPICIOUS VALUES: CLDFRA_BL=",cldfra_bl(i,k,j)," qc_bl=",QC_BL(i,k,j) + IF( cldfra_bl(i,k) < 0.0 .OR. cldfra_bl(i,k)> 1.)THEN + PRINT*,"SUSPICIOUS VALUES: CLDFRA_BL=",cldfra_bl(i,k)," qc_bl=",QC_BL(i,k) ENDIF ENDIF !IF (I==IMD .AND. J==JMD) THEN ! PRINT*,"MYNN DRIVER END: k=",k," sh=",sh(k) - ! PRINT*," sqw=",sqw(k)," thl=",thl(k)," exch_m=",exch_m(i,k,j) - ! PRINT*," xland=",xland(i,j)," rmol=",rmol(i,j)," ust=",ust(i,j) - ! PRINT*," qke=",qke(i,k,j)," el=",el_pbl(i,k,j)," tsq=",tsq(i,k,j) - ! PRINT*," PBLH=",PBLH(i,j)," u=",u(i,k,j)," v=",v(i,k,j) - ! PRINT*," vq=",vq(k)," vt=",vt(k)," vdfg=",vdfg(i,j) + ! PRINT*," sqw=",sqw(k)," thl=",thl(k)," exch_m=",exch_m(i,k) + ! PRINT*," xland=",xland(i)," rmol=",rmol(i)," ust=",ust(i) + ! PRINT*," qke=",qke(i,k)," el=",el_pbl(i,k)," tsq=",tsq(i,k) + ! PRINT*," PBLH=",PBLH(i)," u=",u(i,k)," v=",v(i,k) + ! PRINT*," vq=",vq(k)," vt=",vt(k)," vdfg=",vdfg(i) !ENDIF ENDDO !end-k ENDIF @@ -5487,15 +5481,14 @@ SUBROUTINE mynn_bl_driver( & !JOE-add tke_pbl for coupling w/shallow-cu schemes (TKE_PBL = QKE/2.) ! TKE_PBL is defined on interfaces, while QKE is at middle of layer. - !tke_pbl(i,kts,j) = 0.5*MAX(qke(i,kts,j),1.0e-10) + !tke_pbl(i,kts) = 0.5*MAX(qke(i,kts),1.0e-10) !DO k = kts+1,kte ! afk = dz1(k)/( dz1(k)+dz1(k-1) ) ! abk = 1.0 -afk - ! tke_pbl(i,k,j) = 0.5*MAX(qke(i,k,j)*abk+qke(i,k-1,j)*afk,1.0e-3) + ! tke_pbl(i,k) = 0.5*MAX(qke(i,k)*abk+qke(i,k-1)*afk,1.0e-3) !ENDDO - ENDDO - ENDDO + ENDDO !end i-loop !ACF copy qke into qke_adv if using advection IF (bl_mynn_tkeadvect) THEN @@ -5533,14 +5526,11 @@ SUBROUTINE mynn_bl_init_driver( & & ITS,ITE,JTS,JTE,KTS,KTE - REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: & - &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, & + REAL,DIMENSION(IMS:IME,KMS:KME),INTENT(INOUT) :: & + &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, & &RQCBLTEN,RQIBLTEN,& !RQNIBLTEN,RQNCBLTEN & &QKE,EXCH_H -! REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: & -! &qc_bl,cldfra_bl - INTEGER :: I,J,K,ITF,JTF,KTF JTF=MIN0(JTE,JDE-1) @@ -5548,22 +5538,20 @@ SUBROUTINE mynn_bl_init_driver( & ITF=MIN0(ITE,IDE-1) IF(.NOT.RESTART)THEN - DO J=JTS,JTF - DO K=KTS,KTF - DO I=ITS,ITF - RUBLTEN(i,k,j)=0. - RVBLTEN(i,k,j)=0. - RTHBLTEN(i,k,j)=0. - RQVBLTEN(i,k,j)=0. - if( p_qc >= param_first_scalar ) RQCBLTEN(i,k,j)=0. - if( p_qi >= param_first_scalar ) RQIBLTEN(i,k,j)=0. - !if( p_qnc >= param_first_scalar ) RQNCBLTEN(i,k,j)=0. - !if( p_qni >= param_first_scalar ) RQNIBLTEN(i,k,j)=0. - !QKE(i,k,j)=0. - EXCH_H(i,k,j)=0. -! if(icloud_bl > 0) qc_bl(i,k,j)=0. -! if(icloud_bl > 0) cldfra_bl(i,k,j)=0. - ENDDO + DO K=KTS,KTF + DO I=ITS,ITF + RUBLTEN(i,k)=0. + RVBLTEN(i,k)=0. + RTHBLTEN(i,k)=0. + RQVBLTEN(i,k)=0. + if( p_qc >= param_first_scalar ) RQCBLTEN(i,k)=0. + if( p_qi >= param_first_scalar ) RQIBLTEN(i,k)=0. + !if( p_qnc >= param_first_scalar ) RQNCBLTEN(i,k)=0. + !if( p_qni >= param_first_scalar ) RQNIBLTEN(i,k)=0. + !QKE(i,k)=0. + EXCH_H(i,k)=0. +! if(icloud_bl > 0) qc_bl(i,k)=0. +! if(icloud_bl > 0) cldfra_bl(i,k)=0. ENDDO ENDDO ENDIF @@ -5695,7 +5683,7 @@ SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea,kzi) & MIN((TKEeps-qtke)/MAX(qtkem1-qtke, 1E-6), 1.0) !IN CASE OF NEAR ZERO TKE, SET PBLH = LOWEST LEVEL. PBLH_TKE = MAX(PBLH_TKE,zw1D(kts+1)) - !print *,"PBLH_TKE:",i,j,PBLH_TKE, Qke1D(k)/2., zw1D(kts+1) + !print *,"PBLH_TKE:",i,PBLH_TKE, Qke1D(k)/2., zw1D(kts+1) ENDIF !k = k+1 IF (k .EQ. kte-1) PBLH_TKE = zw1D(kts+1) !EXIT SAFEGUARD @@ -7694,7 +7682,7 @@ SUBROUTINE topdown_cloudrad(kts,kte,dz1,zw,xland,kpbl,PBLH, & zl1 = dz1(kts) k = MAX(kpbl-1, kminrad-1) !Best estimate of height of TKE source (top of downdrafts): - !zminrad = 0.5*pblh(i,j) + 0.5*zminrad + !zminrad = 0.5*pblh(i) + 0.5*zminrad templ=thl(k)*ex1(k) !rvls is ws at full level From e2126f1c3a09ee160b7c545b018271a4ac6c8b30 Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Mon, 12 Jul 2021 20:00:33 +0000 Subject: [PATCH 06/85] Bug fixes - removing a 2nd doxygen bug --- physics/module_bl_mynn.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 9f9d69d5d..694a4a0d6 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -142,7 +142,7 @@ ! A description of the MYNN-EDMF scheme and coupling to other components in WRF-ARW. ! NOAA Tech. Memo. OAR GSD, 61, 37 pp., https://doi.org/10.25923/n9wm-be49. ! Puhales, Franciano S., Joseph B. Olson, Jimy Dudhia, Douglas Lima de Bem, Rafael Maroneze, -! Otávio C. Acevedo, Felipe D. Costa, and Vagner Anabor, 2020: Turbulent Kinetic Energy +! Otavio C. Acevedo, Felipe D. Costa, and Vagner Anabor, 2020: Turbulent Kinetic Energy ! Budget for MYNN-EDMF PBL Scheme in WRF model. Universidade Federal de Santa Maria Technical Note. 9 pp. !------------------------------------------------------------------- From 9a1dc8d8cdb4cce79c6d678ebb64b184310c694d Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Mon, 12 Jul 2021 20:03:04 +0000 Subject: [PATCH 07/85] Bug fixes - removing a 3rd doxygen bug --- physics/module_bl_mynn.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 694a4a0d6..0daad2442 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -7535,7 +7535,7 @@ END FUNCTION xl_blend FUNCTION phim(zet) !! New stability function parameters for momentum (Puhales, 2020, WRF 4.2.1) !! The forms in unstable conditions (z/L < 0) use Grachev et al. (2000), which are a blend of - !! the classical “Kansas” forms (i.e., Paulson 1970, Dyer and Hicks 1970), valid for weakly + !! the classical (Kansas) forms (i.e., Paulson 1970, Dyer and Hicks 1970), valid for weakly !! unstable conditions (−1 < z/L < 0). The stability functions for stable conditions use an !! updated form taken from Cheng and Brutsaert (2005), which extends the validity into very !! stable conditions [z/L ~ O(10)]. From 3fe76cad35ff409b30f80f0a1003e19bc8ac55b7 Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Mon, 12 Jul 2021 20:06:23 +0000 Subject: [PATCH 08/85] Bug fixes - complaining about comments again... --- physics/module_bl_mynn.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 0daad2442..1506691c7 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -7533,12 +7533,12 @@ END FUNCTION xl_blend ! =================================================================== FUNCTION phim(zet) - !! New stability function parameters for momentum (Puhales, 2020, WRF 4.2.1) - !! The forms in unstable conditions (z/L < 0) use Grachev et al. (2000), which are a blend of - !! the classical (Kansas) forms (i.e., Paulson 1970, Dyer and Hicks 1970), valid for weakly - !! unstable conditions (−1 < z/L < 0). The stability functions for stable conditions use an - !! updated form taken from Cheng and Brutsaert (2005), which extends the validity into very - !! stable conditions [z/L ~ O(10)]. + ! New stability function parameters for momentum (Puhales, 2020, WRF 4.2.1) + ! The forms in unstable conditions (z/L < 0) use Grachev et al. (2000), which are a blend of + ! the classical (Kansas) forms (i.e., Paulson 1970, Dyer and Hicks 1970), valid for weakly + ! unstable conditions (−1 < z/L < 0). The stability functions for stable conditions use an + ! updated form taken from Cheng and Brutsaert (2005), which extends the validity into very + ! stable conditions [z/L ~ O(10)]. IMPLICIT NONE REAL, INTENT(IN):: zet From a5909a7e49aa448959881a27bd4dabf9e8688d01 Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Mon, 12 Jul 2021 20:23:08 +0000 Subject: [PATCH 09/85] more doxygen complaints (I think), but they dont make sense. Testing changes by trial and error... --- physics/module_bl_mynn.F90 | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 1506691c7..66d3cc962 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -7536,8 +7536,8 @@ FUNCTION phim(zet) ! New stability function parameters for momentum (Puhales, 2020, WRF 4.2.1) ! The forms in unstable conditions (z/L < 0) use Grachev et al. (2000), which are a blend of ! the classical (Kansas) forms (i.e., Paulson 1970, Dyer and Hicks 1970), valid for weakly - ! unstable conditions (−1 < z/L < 0). The stability functions for stable conditions use an - ! updated form taken from Cheng and Brutsaert (2005), which extends the validity into very + ! unstable conditions (-1 < z/L < 0). The stability functions for stable conditions use an + ! updated form taken from Cheng and Brutsaert (2005), which extends the validity into very ! stable conditions [z/L ~ O(10)]. IMPLICIT NONE @@ -7571,7 +7571,7 @@ FUNCTION phim(zet) dummy_0 = zet**2 dummy_1 = 1./(1.+dummy_0) ! denon - dummy_11 = 2.*zet ! ddenon/dzet + dummy_11 = 2.*zet ! denon/dzet dummy_2 = ((1-phi_m)/zet+dummy_11*dummy_4+dummy_0*dummy_44)*dummy_1 dummy_22 = -dummy_11*(dummy_psi+dummy_0*dummy_4)*dummy_1**2 @@ -7585,12 +7585,12 @@ END FUNCTION phim ! =================================================================== FUNCTION phih(zet) - !! New stability function parameters for heat (Puhales, 2020, WRF 4.2.1) - !! The forms in unstable conditions (z/L < 0) use Grachev et al. (2000), which are a blend of - !! the classical “Kansas” forms (i.e., Paulson 1970, Dyer and Hicks 1970), valid for weakly - !! unstable conditions (−1 < z/L < 0). The stability functions for stable conditions use an - !! updated form taken from Cheng and Brutsaert (2005), which extends the validity into very - !! stable conditions [z/L ~ O(10)]. + ! New stability function parameters for heat (Puhales, 2020, WRF 4.2.1) + ! The forms in unstable conditions (z/L < 0) use Grachev et al. (2000), which are a blend of + ! the classical “Kansas” forms (i.e., Paulson 1970, Dyer and Hicks 1970), valid for weakly + ! unstable conditions (-1 < z/L < 0). The stability functions for stable conditions use an + ! updated form taken from Cheng and Brutsaert (2005), which extends the validity into very + ! stable conditions [z/L ~ O(10)]. IMPLICIT NONE REAL, INTENT(IN):: zet From c127524cd6938bf1a867a9e12ee43e2db873526b Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Mon, 12 Jul 2021 20:25:10 +0000 Subject: [PATCH 10/85] more doxygen complaints (I think), but they dont make sense. Testing changes by trial and error... --- physics/module_bl_mynn.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 66d3cc962..82d23bf57 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -7587,7 +7587,7 @@ END FUNCTION phim FUNCTION phih(zet) ! New stability function parameters for heat (Puhales, 2020, WRF 4.2.1) ! The forms in unstable conditions (z/L < 0) use Grachev et al. (2000), which are a blend of - ! the classical “Kansas” forms (i.e., Paulson 1970, Dyer and Hicks 1970), valid for weakly + ! the classical (Kansas) forms (i.e., Paulson 1970, Dyer and Hicks 1970), valid for weakly ! unstable conditions (-1 < z/L < 0). The stability functions for stable conditions use an ! updated form taken from Cheng and Brutsaert (2005), which extends the validity into very ! stable conditions [z/L ~ O(10)]. From adf420e50e183c8e175847255e62201cdfbac9b3 Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Mon, 12 Jul 2021 20:27:40 +0000 Subject: [PATCH 11/85] fix spelling --- physics/module_bl_mynn.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 82d23bf57..36bb3d0e2 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -2060,7 +2060,7 @@ SUBROUTINE mym_turbulence ( & !!!Shear Term !!!qSHEAR1D(k)=-(upwp*dudz + vpwp*dvdz) - qSHEAR1D(k) = elq*sm(k)*gm(k) !staggared + qSHEAR1D(k) = elq*sm(k)*gm(k) !staggered !!!Buoyancy Term !!!qBUOY1D(k)=g*Tpwp/thl(k) @@ -2068,7 +2068,7 @@ SUBROUTINE mym_turbulence ( & !qBUOY1D(k) = elq*(sh(k)*(-dTdz*g/thl(k)) + gamv) !! ORIGINAL CODE !! Buoyncy term takes the TKEprodTD(k) production now - qBUOY1D(k) = elq*(sh(k)*gh(k)+gamv)+TKEprodTD(k) !staggared + qBUOY1D(k) = elq*(sh(k)*gh(k)+gamv)+TKEprodTD(k) !staggered !!!Dissipation Term (now it evaluated on mym_predict) !qDISS1D(k) = (q3sq**(3./2.))/(b1*MAX(el(k),1.)) !! ORIGINAL CODE @@ -2332,7 +2332,7 @@ SUBROUTINE mym_predict (kts,kte, & 0.5*(s_aw(k+1)*tke_up(k+1)+(s_aw(k+1)-s_aw(k))*tke_up(k)-s_aw(k)*tke_up(k-1)+(s_awqke(k)-s_awqke(k+1)))*onoff) !unstaggered ENDDO k=kte - qWT1D(k)=dzinv(k)*(-kqdz(k)*(tke_up(k)-tke_up(k-1))+0.5*(-s_aw(k)*tke_up(k)-s_aw(k)*tke_up(k-1)+s_awqke(k))*onoff) !unstaggared + qWT1D(k)=dzinv(k)*(-kqdz(k)*(tke_up(k)-tke_up(k-1))+0.5*(-s_aw(k)*tke_up(k)-s_aw(k)*tke_up(k-1)+s_awqke(k))*onoff) !unstaggered !! >> EOBvt qDISS1D=bp*tke_up !! TKE dissipation rate !unstaggered END IF From da8a13a62ab872aded4907e9bc5fcf15852267e5 Mon Sep 17 00:00:00 2001 From: hannah barnes Date: Mon, 12 Jul 2021 14:57:17 -0600 Subject: [PATCH 12/85] Remove unneeded variable --- physics/cu_gf_driver.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/cu_gf_driver.F90 b/physics/cu_gf_driver.F90 index d1dd7171a..4579ed88d 100644 --- a/physics/cu_gf_driver.F90 +++ b/physics/cu_gf_driver.F90 @@ -205,7 +205,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,cactiv,cactiv_m, & ! qfx2 -- latent heat flux (kg/kg m/s), positive upward from sfc ! gf needs them in w/m2. define hfx and qfx after simple unit conversion real(kind=kind_phys), dimension (im) :: hfx,qfx - real(kind=kind_phys) trash,tem,tem1,tf,tcr,tcrf + real(kind=kind_phys) tem,tem1,tf,tcr,tcrf real(kind=kind_phys) :: cliw_shal,clcw_shal,tem_shal, cliw_both, weight_sum real(kind=kind_phys) :: cliw_deep,clcw_deep,tem_deep, clcw_both integer :: cliw_deep_idx, clcw_deep_idx, cliw_shal_idx, clcw_shal_idx From 5799e6f289573ebb9ef8ad4e65fb494b1b07dd2d Mon Sep 17 00:00:00 2001 From: hannah barnes Date: Wed, 14 Jul 2021 10:40:31 -0600 Subject: [PATCH 13/85] Bug fix for clw_allh --- physics/cu_gf_deep.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/cu_gf_deep.F90 b/physics/cu_gf_deep.F90 index 039ff7f75..08f5fdc12 100644 --- a/physics/cu_gf_deep.F90 +++ b/physics/cu_gf_deep.F90 @@ -4113,7 +4113,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & qc(i,k)=qrch endif if(qch(i,k).le.qrch)then - qch(i,k)=qrch + qch(i,k)=qrch+1e-8 endif ! !------- total condensed water before rainout From 2c67750a3a4c16cf2683d46c7558ea6701728c53 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 14 Jul 2021 14:42:19 -0600 Subject: [PATCH 14/85] Another bugfix in physics/cu_gf_deep.F90 to prevent qc(i,k) being zero --- physics/cu_gf_deep.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/cu_gf_deep.F90 b/physics/cu_gf_deep.F90 index 08f5fdc12..f025c4ec0 100644 --- a/physics/cu_gf_deep.F90 +++ b/physics/cu_gf_deep.F90 @@ -4110,7 +4110,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) if(qc(i,k).le.qrch)then - qc(i,k)=qrch + qc(i,k)=qrch+1e-8 endif if(qch(i,k).le.qrch)then qch(i,k)=qrch+1e-8 From 64d85fed97876a4ce932db01f68a4d9d90f41513 Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Wed, 14 Jul 2021 22:16:59 +0000 Subject: [PATCH 15/85] Removing some commented out code. --- physics/module_bl_mynn.F90 | 14 -------------- 1 file changed, 14 deletions(-) diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 36bb3d0e2..9bac94186 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -4145,20 +4145,6 @@ SUBROUTINE mynn_mix_chem(kts,kte,i,j, & DO ic = 1,nchem k=kts - !a(1)=0. - !b(1)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) - !c(1)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) - !d(1)=chem1(k,ic) + dtz(k) * -vd1(ic)*chem1(1,ic) - dtz(k)*s_awchem(k+1,ic) - - !DO k=kts+1,kte-1 - ! a(k)= -dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k) - ! b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) - ! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) - ! ! d(kk)=chem1(k,ic) + qcd(k)*delt - ! d(k)=chem1(k,ic) + rhs*delt + dtz(k)*(s_awchem(k,ic)-s_awchem(k+1,ic)) - !ENDDO - -!rho-weighted: a(k)= -dtz(k)*khdz(k)*rhoinv(k) b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) From 60380d1ea02bdda8e37f8eb956f295edf5027f86 Mon Sep 17 00:00:00 2001 From: hannah barnes Date: Thu, 15 Jul 2021 10:17:53 -0600 Subject: [PATCH 16/85] Modified aod_gf and cactiv_m so that work appriopriately with restart Minor code clean up --- physics/cu_gf_deep.F90 | 2 +- physics/cu_gf_driver.F90 | 6 +++--- physics/cu_gf_driver_post.F90 | 9 ++++++++- physics/cu_gf_driver_post.meta | 17 +++++++++++++++++ physics/cu_gf_driver_pre.F90 | 6 +++++- physics/cu_gf_driver_pre.meta | 17 +++++++++++++++++ 6 files changed, 51 insertions(+), 6 deletions(-) diff --git a/physics/cu_gf_deep.F90 b/physics/cu_gf_deep.F90 index 08f5fdc12..f025c4ec0 100644 --- a/physics/cu_gf_deep.F90 +++ b/physics/cu_gf_deep.F90 @@ -4110,7 +4110,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) if(qc(i,k).le.qrch)then - qc(i,k)=qrch + qc(i,k)=qrch+1e-8 endif if(qch(i,k).le.qrch)then qch(i,k)=qrch+1e-8 diff --git a/physics/cu_gf_driver.F90 b/physics/cu_gf_driver.F90 index 4579ed88d..b2eb7660b 100644 --- a/physics/cu_gf_driver.F90 +++ b/physics/cu_gf_driver.F90 @@ -75,9 +75,9 @@ end subroutine cu_gf_driver_finalize !! !>\section gen_gf_driver GSD GF Cumulus Scheme General Algorithm !> @{ - subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,cactiv,cactiv_m, & - forcet,forceqv_spechum,phil,raincv,qv_spechum,t,cld1d, & - us,vs,t2di,w,qv2di_spechum,p2di,psuri, & + subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init, & + cactiv,cactiv_m,forcet,forceqv_spechum,phil,raincv,qv_spechum, & + t,cld1d,us,vs,t2di,w,qv2di_spechum,p2di,psuri, & hbot,htop,kcnv,xland,hfx2,qfx2,aod_gf,cliw,clcw, & pbl,ud_mf,dd_mf,dt_mf,cnvw_moist,cnvc,imfshalcnv, & flag_for_scnv_generic_tend,flag_for_dcnv_generic_tend, & diff --git a/physics/cu_gf_driver_post.F90 b/physics/cu_gf_driver_post.F90 index 4e172ed5a..eab5eefd6 100644 --- a/physics/cu_gf_driver_post.F90 +++ b/physics/cu_gf_driver_post.F90 @@ -20,7 +20,7 @@ end subroutine cu_gf_driver_post_finalize !> \section arg_table_cu_gf_driver_post_run Argument Table !! \htmlinclude cu_gf_driver_post_run.html !! - subroutine cu_gf_driver_post_run (im, t, q, prevst, prevsq, cactiv, conv_act, errmsg, errflg) + subroutine cu_gf_driver_post_run (im, t, q, prevst, prevsq, cactiv, cactiv_m, conv_act, conv_act_m, errmsg, errflg) use machine, only: kind_phys @@ -33,7 +33,9 @@ subroutine cu_gf_driver_post_run (im, t, q, prevst, prevsq, cactiv, conv_act, er real(kind_phys), intent(out) :: prevst(:,:) real(kind_phys), intent(out) :: prevsq(:,:) integer, intent(in) :: cactiv(:) + integer, intent(in) :: cactiv_m(:) real(kind_phys), intent(out) :: conv_act(:) + real(kind_phys), intent(out) :: conv_act_m(:) character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -53,6 +55,11 @@ subroutine cu_gf_driver_post_run (im, t, q, prevst, prevsq, cactiv, conv_act, er else conv_act(i)=0.0 endif + if (cactiv_m(i).gt.0) then + conv_act_m(i) = conv_act_m(i)+1.0 + else + conv_act_m(i)=0.0 + endif enddo end subroutine cu_gf_driver_post_run diff --git a/physics/cu_gf_driver_post.meta b/physics/cu_gf_driver_post.meta index 152409fbd..6e68d62f9 100644 --- a/physics/cu_gf_driver_post.meta +++ b/physics/cu_gf_driver_post.meta @@ -59,6 +59,14 @@ type = integer intent = in optional = F +[cactiv_m] + standard_name = conv_mid_activity_counter + long_name = midlevel convective activity memory + units = none + dimensions = (horizontal_loop_extent) + type = integer + intent = in + optional = F [conv_act] standard_name = gf_memory_counter long_name = Memory counter for GF @@ -68,6 +76,15 @@ kind = kind_phys intent = out optional = F +[conv_act_m] + standard_name = gf_mid_memory_counter + long_name = Memory counter for GF midlevel + units = none + dimensions = (horizontal_loop_extent) + 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/cu_gf_driver_pre.F90 b/physics/cu_gf_driver_pre.F90 index 3512f65f9..4d4ae9162 100644 --- a/physics/cu_gf_driver_pre.F90 +++ b/physics/cu_gf_driver_pre.F90 @@ -21,7 +21,8 @@ end subroutine cu_gf_driver_pre_finalize !! \htmlinclude cu_gf_driver_pre_run.html !! subroutine cu_gf_driver_pre_run (flag_init, flag_restart, kdt, fhour, dtp, t, q, prevst, prevsq, & - forcet, forceq, cactiv, conv_act, errmsg, errflg) + forcet, forceq, cactiv, cactiv_m, conv_act, conv_act_m, & + errmsg, errflg) use machine, only: kind_phys @@ -39,7 +40,9 @@ subroutine cu_gf_driver_pre_run (flag_init, flag_restart, kdt, fhour, dtp, t, q, real(kind_phys), intent(out) :: forcet(:,:) real(kind_phys), intent(out) :: forceq(:,:) integer, intent(out) :: cactiv(:) + integer, intent(out) :: cactiv_m(:) real(kind_phys), intent(in) :: conv_act(:) + real(kind_phys), intent(in) :: conv_act_m(:) character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -68,6 +71,7 @@ subroutine cu_gf_driver_pre_run (flag_init, flag_restart, kdt, fhour, dtp, t, q, endif cactiv(:)=nint(conv_act(:)) + cactiv_m(:)=nint(conv_act_m(:)) end subroutine cu_gf_driver_pre_run diff --git a/physics/cu_gf_driver_pre.meta b/physics/cu_gf_driver_pre.meta index 1a7fbe4a3..ee64fb5a9 100644 --- a/physics/cu_gf_driver_pre.meta +++ b/physics/cu_gf_driver_pre.meta @@ -111,6 +111,14 @@ type = integer intent = out optional = F +[cactiv_m] + standard_name = conv_mid_activity_counter + long_name = midlevel convective activity memory + units = none + dimensions = (horizontal_loop_extent) + type = integer + intent = out + optional = F [conv_act] standard_name = gf_memory_counter long_name = Memory counter for GF @@ -120,6 +128,15 @@ kind = kind_phys intent = in optional = F +[conv_act_m] + standard_name = gf_mid_memory_counter + long_name = Memory counter for GF midlevel + units = none + 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 From 73f6a4742f83d74ac31873122549e841e014f100 Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Thu, 15 Jul 2021 17:42:46 +0000 Subject: [PATCH 17/85] Taking out OPTIONAL declaration, as it was before. --- physics/module_bl_mynn.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 9bac94186..f74b8f9c4 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -4485,7 +4485,7 @@ SUBROUTINE mynn_bl_driver( & REAL, DIMENSION(IMS:IME,KMS:KME) :: Sh3D - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout), optional :: & + REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & &qc_bl,qi_bl,cldfra_bl REAL, DIMENSION(KTS:KTE) :: qc_bl1D,qi_bl1D,cldfra_bl1D,& qc_bl1D_old,qi_bl1D_old,cldfra_bl1D_old From a786194c8bdc3089a0312f4748a500fcf82bdaa7 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Thu, 15 Jul 2021 11:45:19 -0600 Subject: [PATCH 18/85] Correct wrong standard names in physics/cu_gf_driver_post.meta and physics/cu_gf_driver_pre.meta --- physics/cu_gf_driver_post.meta | 2 +- physics/cu_gf_driver_pre.meta | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/cu_gf_driver_post.meta b/physics/cu_gf_driver_post.meta index 6e68d62f9..62af7f5b9 100644 --- a/physics/cu_gf_driver_post.meta +++ b/physics/cu_gf_driver_post.meta @@ -60,7 +60,7 @@ intent = in optional = F [cactiv_m] - standard_name = conv_mid_activity_counter + standard_name = mid_conv_activity_counter long_name = midlevel convective activity memory units = none dimensions = (horizontal_loop_extent) diff --git a/physics/cu_gf_driver_pre.meta b/physics/cu_gf_driver_pre.meta index ee64fb5a9..3c619b4f0 100644 --- a/physics/cu_gf_driver_pre.meta +++ b/physics/cu_gf_driver_pre.meta @@ -112,7 +112,7 @@ intent = out optional = F [cactiv_m] - standard_name = conv_mid_activity_counter + standard_name = mid_conv_activity_counter long_name = midlevel convective activity memory units = none dimensions = (horizontal_loop_extent) From eac0587da61fbf6c207d8f2d504fd951f35ea1a0 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Fri, 16 Jul 2021 10:20:38 -0600 Subject: [PATCH 19/85] Remove trailing whitespaces in physics/cu_gf_driver.F90; bug fixes in physics/cu_gf_driver.F90 to achieve b4b identical results in restart runs --- physics/cu_gf_driver.F90 | 85 ++++++++++++++++++++------------------- physics/cu_gf_driver.meta | 8 ++++ 2 files changed, 51 insertions(+), 42 deletions(-) diff --git a/physics/cu_gf_driver.F90 b/physics/cu_gf_driver.F90 index b2eb7660b..a931223ec 100644 --- a/physics/cu_gf_driver.F90 +++ b/physics/cu_gf_driver.F90 @@ -27,18 +27,18 @@ subroutine cu_gf_driver_init(imfshalcnv, imfshalcnv_gf, imfdeepcnv, & imfdeepcnv_gf,mpirank, mpiroot, errmsg, errflg) implicit none - + integer, intent(in) :: imfshalcnv, imfshalcnv_gf - integer, intent(in) :: imfdeepcnv, imfdeepcnv_gf + integer, intent(in) :: imfdeepcnv, imfdeepcnv_gf integer, intent(in) :: mpirank integer, intent(in) :: mpiroot character(len=*), intent( out) :: errmsg integer, intent( out) :: errflg - + ! initialize ccpp error handling variables errmsg = '' errflg = 0 - + ! DH* temporary if (mpirank==mpiroot) then write(0,*) ' -----------------------------------------------------------------------------------------------------------------------------' @@ -75,14 +75,14 @@ end subroutine cu_gf_driver_finalize !! !>\section gen_gf_driver GSD GF Cumulus Scheme General Algorithm !> @{ - subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init, & + subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& cactiv,cactiv_m,forcet,forceqv_spechum,phil,raincv,qv_spechum, & t,cld1d,us,vs,t2di,w,qv2di_spechum,p2di,psuri, & hbot,htop,kcnv,xland,hfx2,qfx2,aod_gf,cliw,clcw, & pbl,ud_mf,dd_mf,dt_mf,cnvw_moist,cnvc,imfshalcnv, & flag_for_scnv_generic_tend,flag_for_dcnv_generic_tend, & dtend,dtidx,ntqv,ntiw,ntcw,index_of_temperature,index_of_x_wind, & - index_of_y_wind,index_of_process_scnv,index_of_process_dcnv, & + index_of_y_wind,index_of_process_scnv,index_of_process_dcnv, & ldiag3d,qci_conv,errmsg,errflg) !------------------------------------------------------------- implicit none @@ -99,15 +99,16 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init, & integer, parameter :: ichoice_s=3 ! 0 1 2 3 real(kind=kind_phys), parameter :: aodc0=0.14 - real(kind=kind_phys), parameter :: aodreturn=30. + real(kind=kind_phys), parameter :: aodreturn=30. real(kind=kind_phys) :: dts,fpi,fp integer, parameter :: dicycle=0 ! diurnal cycle flag integer, parameter :: dicycle_m=0 !- diurnal cycle flag integer :: ishallow_g3 ! depend on imfshalcnv !------------------------------------------------------------- - integer :: its,ite, jts,jte, kts,kte + integer :: its,ite, jts,jte, kts,kte integer, intent(in ) :: im,km,ntracer - logical, intent(in ) :: flag_for_scnv_generic_tend,flag_for_dcnv_generic_tend,flag_init + logical, intent(in ) :: flag_init, flag_restart + logical, intent(in ) :: flag_for_scnv_generic_tend,flag_for_dcnv_generic_tend logical, intent(in ) :: ldiag3d real(kind=kind_phys), optional, intent(inout) :: dtend(:,:,:) @@ -140,7 +141,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init, & real(kind=kind_phys), dimension (im,km) :: qv2di, qv, forceqv, cnvw ! real(kind=kind_phys), dimension(:),intent(in) :: garea - real(kind=kind_phys), intent(in ) :: dt + real(kind=kind_phys), intent(in ) :: dt integer, intent(in ) :: imfshalcnv integer, dimension(:), intent(inout) :: cactiv,cactiv_m @@ -202,7 +203,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init, & character*50 :: ierrcs(im) ! ruc variable ! hfx2 -- sensible heat flux (k m/s), positive upward from sfc -! qfx2 -- latent heat flux (kg/kg m/s), positive upward from sfc +! qfx2 -- latent heat flux (kg/kg m/s), positive upward from sfc ! gf needs them in w/m2. define hfx and qfx after simple unit conversion real(kind=kind_phys), dimension (im) :: hfx,qfx real(kind=kind_phys) tem,tem1,tf,tcr,tcrf @@ -268,7 +269,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init, & kts=1 kte=km ktf=kte-1 -! +! tropics(:)=0 ! !> - Set tuning constants for radiation coupling @@ -281,11 +282,11 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init, & edtd(:)=0. zdd(:,:)=0. flux_tun(:)=5. -! 10/11/2016 dx and tscl_kf are replaced with input dx(i), is dlength. +! 10/11/2016 dx and tscl_kf are replaced with input dx(i), is dlength. ! dx for scale awareness ! dx=40075000./float(lonf) ! tscl_kf=dx/25000. - + if (imfshalcnv == 3) then ishallow_g3 = 1 else @@ -343,7 +344,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init, & ccn_m(i) = 0. ! set aod and ccn - if (flag_init) then + if (flag_init .and. .not.flag_restart) then aod_gf(i)=aodc0 else if((cactiv(i).eq.0) .and. (cactiv_m(i).eq.0))then @@ -361,8 +362,8 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init, & htop(i) =kts raincv(i)=0. xlandi(i)=real(xland(i)) -! if(abs(xlandi(i)-1.).le.1.e-3) tun_rad_shall(i)=.15 -! if(abs(xlandi(i)-1.).le.1.e-3) flux_tun(i)=1.5 +! if(abs(xlandi(i)-1.).le.1.e-3) tun_rad_shall(i)=.15 +! if(abs(xlandi(i)-1.).le.1.e-3) flux_tun(i)=1.5 enddo do i= its,itf mconv(i)=0. @@ -468,7 +469,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init, & subm(:,:)=0. dhdt(:,:)=0. - + do k=kts,ktf do i=its,itf p2d(i,k)=0.01*p2di(i,k) @@ -503,7 +504,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init, & do i=its,itf do k=kts,kpbli(i) - tn(i,k)=t(i,k) + tn(i,k)=t(i,k) qo(i,k)=max(1.e-16,qv(i,k)) enddo enddo @@ -511,10 +512,10 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init, & nend=0 do i=its,itf do k=kts,kpbli(i) - dhdt(i,k)=cp*(forcet(i,k)+(t(i,k)-t2di(i,k))/dt) + & - xlv*(forceqv(i,k)+(qv(i,k)-qv2di(i,k))/dt) -! tshall(i,k)=t(i,k) -! qshall(i,k)=qv(i,k) + dhdt(i,k)=cp*(forcet(i,k)+(t(i,k)-t2di(i,k))/dt) + & + xlv*(forceqv(i,k)+(qv(i,k)-qv2di(i,k))/dt) +! tshall(i,k)=t(i,k) +! qshall(i,k)=qv(i,k) enddo enddo do k= kts+1,ktf-1 @@ -631,7 +632,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init, & ,rand_vmas & ! for stochastics vertmass, if temporal and spatial patterns exist ,rand_clos & ! for stochastics closures, if temporal and spatial patterns exist ,0 & ! flag to what you want perturbed - ! 1 = momentum transport + ! 1 = momentum transport ! 2 = normalized vertical mass flux profile ! 3 = closures ! more is possible, talk to developer or @@ -713,7 +714,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init, & ,rand_vmas & ! for stochastics vertmass, if temporal and spatial patterns exist ,rand_clos & ! for stochastics closures, if temporal and spatial patterns exist ,0 & ! flag to what you want perturbed - ! 1 = momentum transport + ! 1 = momentum transport ! 2 = normalized vertical mass flux profile ! 3 = closures ! more is possible, talk to developer or @@ -737,19 +738,19 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init, & ! endif ! do i=its,itf -! kcnv(i)=0 +! kcnv(i)=0 ! if(pret(i).gt.0.)then ! cuten(i)=1. -! kcnv(i)= 1 !jmin(i) -! else +! kcnv(i)= 1 !jmin(i) +! else ! kbcon(i)=0 ! ktop(i)=0 ! cuten(i)=0. ! endif ! pret > 0 ! if(pretm(i).gt.0.)then -! kcnv(i)= 1 !jmin(i) +! kcnv(i)= 1 !jmin(i) ! cutenm(i)=1. -! else +! else ! kbconm(i)=0 ! ktopm(i)=0 ! cutenm(i)=0. @@ -758,7 +759,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init, & do i=its,itf kcnv(i)=0 if(pretm(i).gt.0.)then - kcnv(i)= 1 !jmin(i) + kcnv(i)= 1 !jmin(i) cutenm(i)=1. else kbconm(i)=0 @@ -770,7 +771,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init, & cuten(i)=1. cutenm(i)=0. pretm(i)=0. - kcnv(i)= 1 !jmin(i) + kcnv(i)= 1 !jmin(i) ktopm(i)=0 kbconm(i)=0 else @@ -784,9 +785,9 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init, & massflx(:)=0. trcflx_in1(:)=0. clw_in1(:)=0. - do k=kts,ktf + do k=kts,ktf clw_ten(i, k)=0. - enddo + enddo po_cup(:)=0. kstop=kts if(ktopm(i).gt.kts .or. ktop(i).gt.kts)kstop=max(ktopm(i),ktop(i)) @@ -817,11 +818,11 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init, & gdc2(i,k,1)=max(0.,tun_rad_deep(i)*(cupclwm(i,k)*cutenm(i)+cupclw(i,k)*cuten(i))) qci_conv(i,k)=gdc2(i,k,1) gdc(i,k,2)=(outt(i,k))*86400. - gdc(i,k,3)=(outtm(i,k))*86400. + gdc(i,k,3)=(outtm(i,k))*86400. gdc(i,k,4)=(outts(i,k))*86400. gdc(i,k,7)=-(gdc(i,k,7)-sqrt(us(i,k)**2 +vs(i,k)**2))/dt !gdc(i,k,8)=(outq(i,k))*86400.*xlv/cp - gdc(i,k,8)=(outqm(i,k)+outqs(i,k)+outq(i,k))*86400.*xlv/cp + gdc(i,k,8)=(outqm(i,k)+outqs(i,k)+outq(i,k))*86400.*xlv/cp gdc(i,k,9)=gdc(i,k,2)+gdc(i,k,3)+gdc(i,k,4) ! !> - Calculate subsidence effect on clw @@ -838,9 +839,9 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init, & ! dsubclwm=((-edtm(i)*zdm(i,k+1)+zum(i,k+1))*clwtot1 & ! -(-edtm(i)*zdm(i,k) +zum(i,k)) *clwtot )*g/dp ! dsubclws=(zus(i,k+1)*clwtot1-zus(i,k)*clwtot)*g/dp -! dsubclw=dsubclw+(zu(i,k+1)*clwtot1-zu(i,k)*clwtot)*g/dp -! dsubclwm=dsubclwm+(zum(i,k+1)*clwtot1-zum(i,k)*clwtot)*g/dp -! dsubclws=dsubclws+(zus(i,k+1)*clwtot1-zus(i,k)*clwtot)*g/dp +! dsubclw=dsubclw+(zu(i,k+1)*clwtot1-zu(i,k)*clwtot)*g/dp +! dsubclwm=dsubclwm+(zum(i,k+1)*clwtot1-zum(i,k)*clwtot)*g/dp +! dsubclws=dsubclws+(zus(i,k+1)*clwtot1-zus(i,k)*clwtot)*g/dp ! endif ! tem = dt*(outqcs(i,k)*cutens(i)+outqc(i,k)*cuten(i) & ! +outqcm(i,k)*cutenm(i) & @@ -890,8 +891,8 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init, & !else ! cliw(i,k) = max(0.,cliw(i,k) + tem) !endif - if(t(i,k).le.270.) cliw(i,k) = max(0.,cliw(i,k) + tem) ! HCB - if(t(i,k).gt.270) clcw(i,k) = max(0.,clcw(i,k) + tem) + if(t(i,k).le.270.) cliw(i,k) = max(0.,cliw(i,k) + tem) ! HCB + if(t(i,k).gt.270) clcw(i,k) = max(0.,clcw(i,k) + tem) enddo @@ -1008,7 +1009,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init, & if(qidx>=1) then do k=kts,ktf do i=its,itf - tem = (cuten(i)*outq(i,k) + cutenm(i)*outqm(i,k))* dt + tem = (cuten(i)*outq(i,k) + cutenm(i)*outqm(i,k))* dt tem = tem/(1.0_kind_phys+tem) dtend(i,k,qidx) = dtend(i,k,qidx) + tem enddo diff --git a/physics/cu_gf_driver.meta b/physics/cu_gf_driver.meta index cb7ceabd9..e1121863b 100644 --- a/physics/cu_gf_driver.meta +++ b/physics/cu_gf_driver.meta @@ -127,6 +127,14 @@ type = logical intent = in optional = F +[flag_restart] + standard_name = flag_for_restart + long_name = flag for restart (warmstart) or coldstart + units = flag + dimensions = () + type = logical + intent = in + optional = F [cactiv] standard_name = conv_activity_counter long_name = convective activity memory From 88258273f7c0d86c6114696eaa79a62e88316a88 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Fri, 16 Jul 2021 13:23:54 -0600 Subject: [PATCH 20/85] Add GF variables to physics/GFS_debug.F90 --- physics/GFS_debug.F90 | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 567cbbd32..da88303fb 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -609,6 +609,11 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%in_nm' , Tbd%in_nm) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%ccn_nm' , Tbd%ccn_nm) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%aer_nm' , Tbd%aer_nm) + if (Model%imfdeepcnv == Model%imfdeepcnv_gf) then + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%cactiv' , Tbd%cactiv) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%cactiv_m' , Tbd%cactiv_m) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%aod_gf' , Tbd%aod_gf) + end if ! Diag !call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%fluxr ', Diag%fluxr) !do n=1,size(Diag%fluxr(1,:)) From 0e0b7f1e888cc250000f051252c41476859d7de3 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 21 Jul 2021 14:02:45 -0600 Subject: [PATCH 21/85] Revert change to CODEOWNERS --- CODEOWNERS | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CODEOWNERS b/CODEOWNERS index 0d5230f89..b6c597371 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 +* @DomHeinzeller # Order is important. The last matching pattern has the most precedence. # So if a pull request only touches javascript files, only these owners From 638b159989538b7c7af2c817b7d134434bb8895c Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Fri, 23 Jul 2021 17:29:52 -0600 Subject: [PATCH 22/85] Fix b4b differences for GSD v0 (RUC LSM, tiice) --- physics/sfc_drv_ruc.F90 | 20 +++++++++++--------- physics/sfc_drv_ruc.meta | 2 +- 2 files changed, 12 insertions(+), 10 deletions(-) diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index f313f2fba..f20b51141 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -99,7 +99,7 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & ! --- out real (kind=kind_phys), dimension(:), intent(out) :: zs real (kind=kind_phys), dimension(:), intent(inout) :: sfalb_lnd_bck - real (kind=kind_phys), dimension(:,:), intent(out) :: tsice + real (kind=kind_phys), dimension(:,:), intent(inout) :: tsice real (kind=kind_phys), dimension(:), intent(out) :: semisbase real (kind=kind_phys), dimension(:), intent(out) :: pores, resid @@ -221,16 +221,17 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & enddo ! i - call init_soil_depth_3 ( zs , dzs , lsoil_ruc ) + call init_soil_depth_3 ( zs , dzs , lsoil_ruc ) - call rucinit (flag_restart, im, lsoil_ruc, lsoil, nlev, & ! in - me, master, lsm_ruc, lsm, slmsk, & ! in - soiltyp, vegtype, & ! in - tsfc_lnd, tsfc_wat, tg3, & ! in - zs, dzs, smc, slc, stc, & ! in - sh2o, smfrkeep, tslb, smois, & ! out - wetness, errmsg, errflg) + call rucinit (flag_restart, im, lsoil_ruc, lsoil, nlev, & ! in + me, master, lsm_ruc, lsm, slmsk, & ! in + soiltyp, vegtype, & ! in + tsfc_lnd, tsfc_wat, tg3, & ! in + zs, dzs, smc, slc, stc, & ! in + sh2o, smfrkeep, tslb, smois, & ! out + wetness, errmsg, errflg) + if (.not.flag_restart) then do i = 1, im ! i - horizontal loop do k = 1, min(kice,lsoil_ruc) ! - at initial time set sea ice T (tsice) @@ -238,6 +239,7 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & tsice (i,k) = tslb(i,k) enddo enddo ! i + endif ! .not. restart !-- end of initialization diff --git a/physics/sfc_drv_ruc.meta b/physics/sfc_drv_ruc.meta index 1e6d38fc5..cf37670fe 100644 --- a/physics/sfc_drv_ruc.meta +++ b/physics/sfc_drv_ruc.meta @@ -531,7 +531,7 @@ dimensions = (horizontal_dimension,ice_vertical_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = F [pores] standard_name = maximum_soil_moisture_content_for_land_surface_model From fa2253b1b3776822820e0f501998207a29ee803a Mon Sep 17 00:00:00 2001 From: hannah barnes Date: Tue, 27 Jul 2021 12:16:55 -0600 Subject: [PATCH 23/85] - Turn off aerosols in GF - Improve GF-radiation coupling when GF substituted for SAS in the GFS physics suite --- physics/GFS_rrtmg_pre.F90 | 15 +++++++++- physics/GFS_rrtmg_pre.meta | 9 ++++++ physics/cu_gf_deep.F90 | 48 +++++++++++++++++------------- physics/cu_gf_driver.F90 | 28 ++++++++--------- physics/cu_gf_sh.F90 | 13 ++++---- physics/module_SGSCloud_RadPre.F90 | 4 +-- 6 files changed, 72 insertions(+), 45 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 158067c05..b5174ea86 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -29,7 +29,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & prsi, prsl, prslk, tgrs, sfc_wts, mg_cld, effrr_in, pert_clds, & sppt_wts, sppt_amp, 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 + clouds1, clouds2, clouds3, clouds4, clouds5,qci_conv, & !in/out from here and above kd, kt, kb, mtopa, mbota, raddt, tsfg, tsfa, de_lgth, alb1d, delp, dz, & !output from here and below plvl, plyr, tlvl, tlyr, qlyr, olyr, gasvmr_co2, gasvmr_n2o, gasvmr_ch4,& gasvmr_o2, gasvmr_co, gasvmr_cfc11, gasvmr_cfc12, gasvmr_cfc22, & @@ -125,6 +125,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & real(kind=kind_phys), dimension(:,:), intent(inout) :: clouds1, & clouds2, clouds3, & clouds4, clouds5 + real(kind=kind_phys), dimension(im,levs), intent(inout) :: qci_conv integer, intent(out) :: kd, kt, kb @@ -737,6 +738,18 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & endif enddo enddo + elseif (imfdeepcnv == imfdeepcnv_gf .and. kdt>1) THEN + do k=1,lm + k1 = k + kd + do i=1,im + if (qci_conv(i,k)>0.) then + ! GF sub-grid cloud fraction + cldcov(i,k1) = clouds1(i,k1) + else + cldcov(i,k1) = tracer1(I,k1,ntclamt) + endif + enddo + enddo else ! GFDL cloud fraction cldcov(1:IM,1+kd:LM+kd) = tracer1(1:IM,1:LM,ntclamt) diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 344befa97..f47863f24 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -804,6 +804,15 @@ kind = kind_phys intent = inout optional = F +[qci_conv] + standard_name = convective_cloud_condesate_after_rainout + long_name = convective cloud condesate after rainout + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F [kd] standard_name = vertical_index_difference_between_inout_and_local long_name = vertical index difference between in/out and local diff --git a/physics/cu_gf_deep.F90 b/physics/cu_gf_deep.F90 index f025c4ec0..b138f23f4 100644 --- a/physics/cu_gf_deep.F90 +++ b/physics/cu_gf_deep.F90 @@ -28,8 +28,8 @@ module cu_gf_deep real(kind=kind_phys), parameter :: pgcd = 0.1 ! !> aerosol awareness, do not user yet! - integer, parameter :: autoconv=2 !1 - integer, parameter :: aeroevap=3 !1 + integer, parameter :: autoconv=1 + integer, parameter :: aeroevap=1 real(kind=kind_phys), parameter :: scav_factor = 0.5 !> still 16 ensembles for clousres integer, parameter:: maxens3=16 @@ -389,6 +389,7 @@ subroutine cu_gf_deep_run( & !---------------------------------------------------- ! HCB ! Set cloud water to rain water conversion rate (c0) c0=0.004 + if(xland1(i).eq.1)c0=.002 if(imid.eq.1)then c0=0.002 endif @@ -1996,7 +1997,7 @@ subroutine cu_gf_deep_run( & do k = ktop(i), 1, -1 rain = pwo(i,k) + edto(i) * pwdo(i,k) rn(i) = rn(i) + rain * xmb(i) * .001 * dtime - if(po(i,k).gt.400.)then + !if(po(i,k).gt.400.)then if(flg(i))then q1=qo(i,k)+(outq(i,k))*dtime t1=tn(i,k)+(outt(i,k))*dtime @@ -2021,7 +2022,7 @@ subroutine cu_gf_deep_run( & pre(i)=max(pre(i),0.) delqev(i) = delqev(i) + .001*dp*qevap(i)/g endif - endif ! 400mb + !endif ! 400mb endif enddo ! pre(i)=1000.*rn(i)/dtime @@ -3991,12 +3992,14 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & prop_ave,qrcb_h,bdsp,dp,rhoc,qrch,qaver,clwdet, & dz,berryc0,q1,berryc real(kind=kind_phys) :: & - denom, c0t + denom, c0t, c0_iceconv real(kind=kind_phys), dimension (kts:kte) :: & prop_b ! prop_b(kts:kte)=0 iall=0 + clwdet=0.02 + c0_iceconv=.01 c1d_b=c1d bdsp=bdispm ! @@ -4050,12 +4053,11 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & ! ! if(name == "deep" )then do k=k22(i)+1,kbcon(i) - c0t = c0 - !if(t(i,k) > 273.16) then - ! c0t = c0 - !else - ! c0t = c0 * exp(0.07 * (t(i,k) - 273.16)) - !endif + if(t(i,k) > 273.16) then + c0t = c0 + else + c0t = c0 * exp(c0_iceconv * (t(i,k) - 273.16)) + endif qc(i,k)= (qc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)* qc(i,k-1)+ & up_massentr(i,k-1)*q(i,k-1)) / & (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) @@ -4076,12 +4078,13 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & !now do the rest ! do k=kbcon(i)+1,ktop(i) - c0t = c0 - !if(t(i,k) > 273.16) then - ! c0t = c0 - !else - ! c0t = c0 * exp(0.07 * (t(i,k) - 273.16)) - !endif + if(t(i,k) > 273.16) then + c0t = c0 + else + c0t = c0 * exp(c0_iceconv * (t(i,k) - 273.16)) + endif + if(name == "mid")c0t=.004 + denom=zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1) if(denom.lt.1.e-16)then ierr(i)=51 @@ -4118,12 +4121,17 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & ! !------- total condensed water before rainout ! + clw_all(i,k)=max(0.,qc(i,k)-qrch) + qrc(i,k)=max(0.,(qc(i,k)-qrch)) ! /(1.+c0*dz*zu(i,k)) + clw_allh(i,k)=max(0.,qch(i,k)-qrch) + qrcb(i,k)=max(0.,(qch(i,k)-qrch)) ! /(1.+c0*dz*zu(i,k)) if(name == "deep" )then - clwdet=0.1 ! 05/11/2021 + clwdet=0.02 ! 05/11/2021 kklev(i)=maxloc(zu(i,:),1) ! 05/05/2021 if(k.lt.kklev(i)) clwdet=0. ! 05/05/2021 else - clwdet=0.1 ! 05/05/2021 + clwdet=0.02 ! 05/05/2021 + if(k.lt.kklev(i)) clwdet=0. ! 05/25/2021 endif if(k.gt.kbcon(i)+1)c1d(i,k)=clwdet*up_massdetr(i,k-1) if(k.gt.kbcon(i)+1)c1d_b(i,k)=clwdet*up_massdetr(i,k-1) @@ -4181,7 +4189,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & ! create clw detrainment profile that depends on mass detrainment and ! in-cloud clw/ice ! - c1d(i,k)=clwdet*up_massdetr(i,k-1)*qrc(i,k-1) + !c1d(i,k)=clwdet*up_massdetr(i,k-1)*qrc(i,k-1) qrc(i,k)=(qc(i,k)-qrch)/(1.+(c1d(i,k)+c0t)*dz) if(qrc(i,k).lt.0.)then ! hli new test 02/12/19 qrc(i,k)=0. diff --git a/physics/cu_gf_driver.F90 b/physics/cu_gf_driver.F90 index a931223ec..600a30d67 100644 --- a/physics/cu_gf_driver.F90 +++ b/physics/cu_gf_driver.F90 @@ -255,7 +255,8 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ! ! these should be coming in from outside ! -! cactiv(:) = 0 + cactiv(:) = 0 + cactiv_m(:) = 0 rand_mom(:) = 0. rand_vmas(:) = 0. rand_clos(:,:) = 0. @@ -274,9 +275,9 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ! !> - Set tuning constants for radiation coupling ! - tun_rad_shall(:)=.02 - tun_rad_mid(:)=.15 - tun_rad_deep(:)=.13 + tun_rad_shall(:)=.01 + tun_rad_mid(:)=.02 + tun_rad_deep(:)=.065 edt(:)=0. edtm(:)=0. edtd(:)=0. @@ -815,7 +816,8 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& vs(i,k)=vs(i,k)+outv(i,k)*cuten(i)*dt +outvm(i,k)*cutenm(i)*dt +outvs(i,k)*cutens(i)*dt gdc(i,k,1)= max(0.,tun_rad_shall(i)*cupclws(i,k)*cutens(i)) ! my mod - gdc2(i,k,1)=max(0.,tun_rad_deep(i)*(cupclwm(i,k)*cutenm(i)+cupclw(i,k)*cuten(i))) + !gdc2(i,k,1)=max(0.,tun_rad_deep(i)*(cupclwm(i,k)*cutenm(i)+cupclw(i,k)*cuten(i))) + gdc2(i,k,1)=max(0.,tun_rad_mid(i)*cupclwm(i,k)*cutenm(i)+tun_rad_deep(i)*cupclw(i,k)*cuten(i)+tun_rad_shall(i)*cupclws(i,k)*cutens(i)) qci_conv(i,k)=gdc2(i,k,1) gdc(i,k,2)=(outt(i,k))*86400. gdc(i,k,3)=(outtm(i,k))*86400. @@ -884,15 +886,13 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& +outqcm(i,k)*cutenm(i) & +clw_ten(i,k) & ) - !tem1 = max(0.0, min(1.0, (tcr-t(i,k))*tcrf)) - !if (clcw(i,k) .gt. -999.0) then - ! cliw(i,k) = max(0.,cliw(i,k) + tem * tem1) ! ice - ! clcw(i,k) = max(0.,clcw(i,k) + tem *(1.0-tem1)) ! water - !else - ! cliw(i,k) = max(0.,cliw(i,k) + tem) - !endif - if(t(i,k).le.270.) cliw(i,k) = max(0.,cliw(i,k) + tem) ! HCB - if(t(i,k).gt.270) clcw(i,k) = max(0.,clcw(i,k) + tem) + tem1 = max(0.0, min(1.0, (tcr-t(i,k))*tcrf)) + if (clcw(i,k) .gt. -999.0) then + cliw(i,k) = max(0.,cliw(i,k) + tem * tem1) ! ice + clcw(i,k) = max(0.,clcw(i,k) + tem *(1.0-tem1)) ! water + else + cliw(i,k) = max(0.,cliw(i,k) + tem) + endif enddo diff --git a/physics/cu_gf_sh.F90 b/physics/cu_gf_sh.F90 index 7f88d0c14..e30ca95bc 100644 --- a/physics/cu_gf_sh.F90 +++ b/physics/cu_gf_sh.F90 @@ -245,7 +245,7 @@ subroutine cu_gf_sh_run ( & xz(i,k)=zo(i,k) qrco(i,k)=0. pwo(i,k)=0. - cd(i,k)=.1*entr_rate(i) + cd(i,k)=.75*entr_rate(i) dellaqc(i,k)=0. cupclw(i,k)=0. enddo @@ -415,7 +415,7 @@ subroutine cu_gf_sh_run ( & do k=kts,ktf frh = 2.*min(qo_cup(i,k)/qeso_cup(i,k),1.) entr_rate_2d(i,k)=entr_rate(i) !*(2.3-frh) - cd(i,k)=.1*entr_rate_2d(i,k) + cd(i,k)=.75*entr_rate_2d(i,k) enddo ! ! first estimate for shallow convection @@ -576,14 +576,11 @@ subroutine cu_gf_sh_run ( & if(qco(i,k)>=trash ) then dz=z_cup(i,k)-z_cup(i,k-1) ! cloud liquid water -! qrco(i,k)= (qco(i,k)-trash)/(1.+c0_shal*dz) -! qrco(i,k)= (qco(i,k)-trash)/(1.+(c0_shal+c1_shal)*dz) - qrco(i,k)= (qco(i,k)-trash)/(1.+c0_shal*dz) - c1d(i,k-1)=10.*up_massdetr(i,k-1)*.5*(qrco(i,k-1)+qrco(i,k)) - qrco(i,k)= qrco(i,k)-c1d(i,k-1)*dz*qrco(i,k) + c1d(i,k)=.02*up_massdetr(i,k-1) + qrco(i,k)= (qco(i,k)-trash)/(1.+(c0_shal+c1d(i,k))*dz) if(qrco(i,k).lt.0.)then ! hli new test 02/12/19 qrco(i,k)=0. - c1d(i,k-1)=1./dz + c1d(i,k)=0. endif pwo(i,k)=c0_shal*dz*qrco(i,k)*zuo(i,k) ! cloud water vapor diff --git a/physics/module_SGSCloud_RadPre.F90 b/physics/module_SGSCloud_RadPre.F90 index bea33c2b7..59c0fcfb0 100644 --- a/physics/module_SGSCloud_RadPre.F90 +++ b/physics/module_SGSCloud_RadPre.F90 @@ -266,7 +266,7 @@ subroutine sgscloud_radpre_run( & if(qi(i,k)>1.E-8)clouds5(i,k)=max(173.45 + 2.14*Tc, 20.) endif - if ( do_mynnedmf .or. (imp_physics == imp_physics_gfdl) ) then + if ( do_mynnedmf ) then !print *,'MYNN PBL or GFDL MP cldcov used' else !print *,'GF with Xu-Randall cloud fraction' @@ -290,7 +290,7 @@ subroutine sgscloud_radpre_run( & endif !print*,"XuRandla- cf:",clouds1(i,k)," rh:",rhgrid," qt:",h2oliq !print*,"XuRandlb- clwt:",clwt," qsat:",qsat," p:",p3d(i,k) - endif ! not MYNN PBL or GFDL MP + endif ! not MYNN PBL endif ! qci_conv enddo enddo From ca81d5f27dcdd19495ff6cafc40619af1d783986 Mon Sep 17 00:00:00 2001 From: hannah barnes Date: Tue, 27 Jul 2021 13:00:05 -0600 Subject: [PATCH 24/85] Remove an extra space --- physics/cu_gf_deep.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/cu_gf_deep.F90 b/physics/cu_gf_deep.F90 index b138f23f4..30315eec4 100644 --- a/physics/cu_gf_deep.F90 +++ b/physics/cu_gf_deep.F90 @@ -4124,7 +4124,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & clw_all(i,k)=max(0.,qc(i,k)-qrch) qrc(i,k)=max(0.,(qc(i,k)-qrch)) ! /(1.+c0*dz*zu(i,k)) clw_allh(i,k)=max(0.,qch(i,k)-qrch) - qrcb(i,k)=max(0.,(qch(i,k)-qrch)) ! /(1.+c0*dz*zu(i,k)) + qrcb(i,k)=max(0.,(qch(i,k)-qrch)) ! /(1.+c0*dz*zu(i,k)) if(name == "deep" )then clwdet=0.02 ! 05/11/2021 kklev(i)=maxloc(zu(i,:),1) ! 05/05/2021 From d3a0c6fe6768b19e0138783c0c21c6480afcd4e4 Mon Sep 17 00:00:00 2001 From: hannah barnes Date: Tue, 27 Jul 2021 13:22:22 -0600 Subject: [PATCH 25/85] Code clean up for GFS_rrtmg_pre.F90 --- physics/GFS_rrtmg_pre.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index b5174ea86..02f460723 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -29,7 +29,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & prsi, prsl, prslk, tgrs, sfc_wts, mg_cld, effrr_in, pert_clds, & sppt_wts, sppt_amp, 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,qci_conv, & !in/out from here and above + clouds1, clouds2, clouds3, clouds4, clouds5, qci_conv, & !in/out from here and above kd, kt, kb, mtopa, mbota, raddt, tsfg, tsfa, de_lgth, alb1d, delp, dz, & !output from here and below plvl, plyr, tlvl, tlyr, qlyr, olyr, gasvmr_co2, gasvmr_n2o, gasvmr_ch4,& gasvmr_o2, gasvmr_co, gasvmr_cfc11, gasvmr_cfc12, gasvmr_cfc22, & @@ -125,7 +125,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & real(kind=kind_phys), dimension(:,:), intent(inout) :: clouds1, & clouds2, clouds3, & clouds4, clouds5 - real(kind=kind_phys), dimension(im,levs), intent(inout) :: qci_conv + real(kind=kind_phys), dimension(:,:), intent(inout) :: qci_conv integer, intent(out) :: kd, kt, kb @@ -731,7 +731,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & do i=1,im if (tracer1(i,k1,ntrw)>1.0e-7 .OR. tracer1(i,k1,ntsw)>1.0e-7) then ! GFDL cloud fraction - cldcov(i,k1) = tracer1(I,k1,ntclamt) + cldcov(i,k1) = tracer1(i,k1,ntclamt) else ! MYNN sub-grid cloud fraction cldcov(i,k1) = clouds1(i,k1) From eb0efcaca497c02f3ab11fe5e7d4e9445bafd31d Mon Sep 17 00:00:00 2001 From: hannah barnes Date: Tue, 27 Jul 2021 13:25:32 -0600 Subject: [PATCH 26/85] Code clean up in GFS_rrtmg_pre.F90 --- physics/GFS_rrtmg_pre.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 02f460723..575bd51d7 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -746,7 +746,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & ! GF sub-grid cloud fraction cldcov(i,k1) = clouds1(i,k1) else - cldcov(i,k1) = tracer1(I,k1,ntclamt) + cldcov(i,k1) = tracer1(i,k1,ntclamt) endif enddo enddo From e765012a998c65a980c8f88c1809313e6233e143 Mon Sep 17 00:00:00 2001 From: hannah barnes Date: Thu, 29 Jul 2021 07:12:52 -0600 Subject: [PATCH 27/85] Updates to prepare for merger with latest version of master --- physics/GFS_rrtmg_pre.F90 | 13 ++++--------- physics/GFS_rrtmg_pre.meta | 8 -------- 2 files changed, 4 insertions(+), 17 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 575bd51d7..77bef1880 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -18,7 +18,7 @@ end subroutine GFS_rrtmg_pre_init ! in the CCPP version - they are defined in the interstitial_create routine subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & imfdeepcnv, imfdeepcnv_gf, me, ncnd, ntrac, num_p3d, npdf3d, ncnvcld3d,& - ntqv, ntcw,ntiw, ntlnc, ntinc, ncld, ntrw, ntsw, ntgl, ntwa, ntoz, & + ntqv, ntcw,ntiw, ntlnc, ntinc, ntrw, ntsw, ntgl, ntwa, ntoz, & ntclamt, nleffr, nieffr, nseffr, lndp_type, kdt, imp_physics, & imp_physics_thompson, imp_physics_gfdl, imp_physics_zhao_carr, & imp_physics_zhao_carr_pdf, imp_physics_mg, imp_physics_wsm6, & @@ -83,7 +83,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & imfdeepcnv, & imfdeepcnv_gf, me, ncnd, ntrac, & num_p3d, npdf3d, ncnvcld3d, ntqv, & - ntcw, ntiw, ntlnc, ntinc, ncld, & + ntcw, ntiw, ntlnc, ntinc, & ntrw, ntsw, ntgl, ntwa, ntoz, & ntclamt, nleffr, nieffr, nseffr, & lndp_type, & @@ -595,7 +595,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & !! call module_radiation_clouds::progcld1() !! - For Zhao/Moorthi's prognostic cloud+pdfcld, !! call module_radiation_clouds::progcld3() -!! call module_radiation_clouds::progclduni() for unified cloud and ncld=2 +!! call module_radiation_clouds::progclduni() for unified cloud and ncnd>=2 ! --- ... obtain cloud information for radiation calculations @@ -691,11 +691,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & ccnd(:,:,1) = ccnd(:,:,1) + tracer1(:,1:LMK,ntiw) ccnd(:,:,1) = ccnd(:,:,1) + tracer1(:,1:LMK,ntsw) ccnd(:,:,1) = ccnd(:,:,1) + tracer1(:,1:LMK,ntgl) - -! else -! do j=1,ncld -! ccnd(:,:,1) = ccnd(:,:,1) + tracer1(:,1:LMK,ntcw+j-1) ! cloud condensate amount -! enddo endif do k=1,LMK do i=1,IM @@ -962,7 +957,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & if (imp_physics == imp_physics_zhao_carr .or. imp_physics == imp_physics_mg) then ! zhao/moorthi's prognostic cloud scheme ! or unified cloud and/or with MG microphysics - if (uni_cld .and. ncld >= 2) then + if (uni_cld .and. ncndl >= 2) then call progclduni (plyr, plvl, tlyr, tvly, ccnd, ncndl, & ! --- inputs xlat, xlon, slmsk, dz, delp, & IM, LMK, LMP, cldcov, & diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index f47863f24..3c7115732 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -161,14 +161,6 @@ type = integer intent = in optional = F -[ncld] - standard_name = number_of_hydrometeors - long_name = choice of cloud scheme / number of hydrometeors - units = count - dimensions = () - type = integer - intent = in - optional = F [ntrw] standard_name = index_for_rain_water long_name = tracer index for rain water From 26d08706229064ec2c461b88a60118e3248ac774 Mon Sep 17 00:00:00 2001 From: hannah barnes Date: Thu, 29 Jul 2021 14:02:42 -0600 Subject: [PATCH 28/85] Fix component issue with xland --- physics/cu_gf_deep.F90 | 30 ++++++++++++++++-------------- 1 file changed, 16 insertions(+), 14 deletions(-) diff --git a/physics/cu_gf_deep.F90 b/physics/cu_gf_deep.F90 index 30315eec4..533e743eb 100644 --- a/physics/cu_gf_deep.F90 +++ b/physics/cu_gf_deep.F90 @@ -339,7 +339,7 @@ subroutine cu_gf_deep_run( & integer :: turn,pmin_lev(its:ite),start_level(its:ite),ktopkeep(its:ite) real(kind=kind_phys), dimension (its:ite,kts:kte) :: dtempdz integer, dimension (its:ite,kts:kte) :: k_inv_layers - real(kind=kind_phys) :: c0 ! HCB + real(kind=kind_phys), dimension (its:ite) :: c0 ! HCB ! rainevap from sas real(kind=kind_phys) zuh2(40) @@ -388,11 +388,13 @@ subroutine cu_gf_deep_run( & ! !---------------------------------------------------- ! HCB ! Set cloud water to rain water conversion rate (c0) - c0=0.004 - if(xland1(i).eq.1)c0=.002 - if(imid.eq.1)then - c0=0.002 - endif + do i=its,itf + c0(i)=0.004 + if(xland1(i).eq.1)c0(i)=.002 + if(imid.eq.1)then + c0(i)=0.002 + endif + enddo !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ztexec(:) = 0. @@ -3943,13 +3945,13 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & up_massentr,up_massdetr,dby,qes_cup,z_cup real(kind=kind_phys), dimension (its:ite) & ,intent (in ) :: & - zqexec + zqexec,c0 ! entr= entrainment rate integer, dimension (its:ite) & ,intent (in ) :: & kbcon,ktop,k22,xland1 real(kind=kind_phys), intent (in ) :: & ! HCB - c0,ccnclean + ccnclean ! ! input and output ! @@ -4054,9 +4056,9 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & ! if(name == "deep" )then do k=k22(i)+1,kbcon(i) if(t(i,k) > 273.16) then - c0t = c0 + c0t = c0(i) else - c0t = c0 * exp(c0_iceconv * (t(i,k) - 273.16)) + c0t = c0(i) * exp(c0_iceconv * (t(i,k) - 273.16)) endif qc(i,k)= (qc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)* qc(i,k-1)+ & up_massentr(i,k-1)*q(i,k-1)) / & @@ -4079,9 +4081,9 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & ! do k=kbcon(i)+1,ktop(i) if(t(i,k) > 273.16) then - c0t = c0 + c0t = c0(i) else - c0t = c0 * exp(c0_iceconv * (t(i,k) - 273.16)) + c0t = c0(i) * exp(c0_iceconv * (t(i,k) - 273.16)) endif if(name == "mid")c0t=.004 @@ -4122,9 +4124,9 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & !------- total condensed water before rainout ! clw_all(i,k)=max(0.,qc(i,k)-qrch) - qrc(i,k)=max(0.,(qc(i,k)-qrch)) ! /(1.+c0*dz*zu(i,k)) + qrc(i,k)=max(0.,(qc(i,k)-qrch)) ! /(1.+c0(i)*dz*zu(i,k)) clw_allh(i,k)=max(0.,qch(i,k)-qrch) - qrcb(i,k)=max(0.,(qch(i,k)-qrch)) ! /(1.+c0*dz*zu(i,k)) + qrcb(i,k)=max(0.,(qch(i,k)-qrch)) ! /(1.+c0(i)*dz*zu(i,k)) if(name == "deep" )then clwdet=0.02 ! 05/11/2021 kklev(i)=maxloc(zu(i,:),1) ! 05/05/2021 From 733017bbae81ec88ddc2692bb3a88ebd88023800 Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Tue, 3 Aug 2021 22:57:34 +0000 Subject: [PATCH 29/85] MYNN-EDMF updates and bug fixes --- physics/module_bl_mynn.F90 | 148 +++++++++++++++++++------------------ 1 file changed, 76 insertions(+), 72 deletions(-) diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index f74b8f9c4..860dc99ae 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -1669,7 +1669,7 @@ SUBROUTINE mym_turbulence ( & INTEGER, INTENT(IN) :: spp_pbl REAL, DIMENSION(KTS:KTE) :: rstoch_col REAL :: Prnum - REAL, PARAMETER :: Prlimit = 5.0 + REAL, PARAMETER :: Prlimit = 10.0 ! @@ -1777,8 +1777,8 @@ SUBROUTINE mym_turbulence ( & !sm(k) = sm(k) * qdiv !Use level 2.0 functions as in original MYNN - !sh(k) = sh(k) * qdiv - !sm(k) = Prnum*sh(k) + sh(k) = sh(k) * qdiv + sm(k) = Prnum*sh(k) !Recalculate terms for later use !JOE-Canuto/Kitamura mod @@ -1794,8 +1794,8 @@ SUBROUTINE mym_turbulence ( & eden = MAX( eden, 1.0d-20 ) !!JOE-Canuto/Kitamura mod !!sh(k) = q3sq*a2*( e2+3.0*c1*e5c*gmel )/eden - retro 5 - sh(k) = q3sq*(a2*a2fac)*( e2+3.0*c1*e5c*gmel )/eden - sm(k) = Prnum*sh(k) + !sh(k) = q3sq*(a2*a2fac)*( e2+3.0*c1*e5c*gmel )/eden + !sm(k) = Prnum*sh(k) ELSE !JOE-Canuto/Kitamura mod !e1 = q3sq - e1c*ghel @@ -1822,8 +1822,8 @@ SUBROUTINE mym_turbulence ( & gmelq = MAX(gmel/q3sq, 1e-8) sm25max = MIN(sm20*3.0, SQRT(.1936/gmelq)) sh25max = MIN(sh20*3.0, 0.76*b2) - sm25min = MAX(sm20*0.1, 1e-6) - sh25min = MAX(sh20*0.1, 1e-6) + sm25min = 0.0 + sh25min = 0.0 !JOE: Level 2.5 debug prints ! HL88 , lev2.5 criteria from eqs. 3.17, 3.19, & 3.20 @@ -2304,10 +2304,16 @@ SUBROUTINE mym_predict (kts,kte, & !! d(k-kts+1)=rp(k)*delt + qke(k) - qke(k)*bp(k)*delt !! ENDDO - a(kte)=-1. !0. +!! "no flux at top" +! a(kte)=-1. !0. +! b(kte)=1. +! c(kte)=0. +! d(kte)=0. +!! "prescribed value" + a(kte)=0. b(kte)=1. c(kte)=0. - d(kte)=0. + d(kte)=qke(kte) ! CALL tridiag(kte,a,b,c,d) CALL tridiag2(kte,a,b,c,d,x) @@ -4032,7 +4038,7 @@ END SUBROUTINE mynn_tendencies ! ================================================================== #if (WRF_CHEM == 1) - SUBROUTINE mynn_mix_chem(kts,kte,i,j, & + SUBROUTINE mynn_mix_chem(kts,kte,i, & grav_settling, & delt,dz,pblh, & nchem, kdvel, ndvel, num_vert_mix, & @@ -4051,7 +4057,7 @@ SUBROUTINE mynn_mix_chem(kts,kte,i,j, & enh_vermix ) !------------------------------------------------------------------- - INTEGER, INTENT(in) :: kts,kte,i,j + INTEGER, INTENT(in) :: kts,kte,i INTEGER, INTENT(in) :: grav_settling INTEGER, INTENT(in) :: bl_mynn_cloudmix @@ -4460,9 +4466,8 @@ SUBROUTINE mynn_bl_driver( & & edmf_a,edmf_w,edmf_qt,edmf_thl,edmf_ent,edmf_qc, & & sub_thl3D,sub_sqv3D,det_thl3D,det_sqv3D - !REAL, DIMENSION(:,:), OPTIONAL :: & - REAL, DIMENSION(IMS:IME,KMS:KME) :: & - & edmf_a_dd,edmf_w_dd,edmf_qt_dd,edmf_thl_dd,edmf_ent_dd,edmf_qc_dd +! REAL, DIMENSION(IMS:IME,KMS:KME) :: & +! & edmf_a_dd,edmf_w_dd,edmf_qt_dd,edmf_thl_dd,edmf_ent_dd,edmf_qc_dd REAL, DIMENSION(IMS:IME), INTENT(inout) :: Pblh,wstar,delta,rmol @@ -4563,39 +4568,30 @@ SUBROUTINE mynn_bl_driver( & ITF=ITE KTF=KTE - IF (bl_mynn_edmf > 0) THEN - ! setup random seed - !call init_random_seed - - IF (bl_mynn_output > 0) THEN !research mode - edmf_a(its:ite,kts:kte)=0. - edmf_w(its:ite,kts:kte)=0. - edmf_qt(its:ite,kts:kte)=0. - edmf_thl(its:ite,kts:kte)=0. - edmf_ent(its:ite,kts:kte)=0. - edmf_qc(its:ite,kts:kte)=0. - sub_thl3D(its:ite,kts:kte)=0. - sub_sqv3D(its:ite,kts:kte)=0. - det_thl3D(its:ite,kts:kte)=0. - det_sqv3D(its:ite,kts:kte)=0. - ENDIF - ktop_plume(its:ite)=0 !int - nupdraft(its:ite)=0 !int - maxmf(its:ite)=0. + IF (bl_mynn_output > 0) THEN !research mode + edmf_a(its:ite,kts:kte)=0. + edmf_w(its:ite,kts:kte)=0. + edmf_qt(its:ite,kts:kte)=0. + edmf_thl(its:ite,kts:kte)=0. + edmf_ent(its:ite,kts:kte)=0. + edmf_qc(its:ite,kts:kte)=0. + sub_thl3D(its:ite,kts:kte)=0. + sub_sqv3D(its:ite,kts:kte)=0. + det_thl3D(its:ite,kts:kte)=0. + det_sqv3D(its:ite,kts:kte)=0. + + !edmf_a_dd(its:ite,kts:kte)=0. + !edmf_w_dd(its:ite,kts:kte)=0. + !edmf_qt_dd(its:ite,kts:kte)=0. + !edmf_thl_dd(its:ite,kts:kte)=0. + !edmf_ent_dd(its:ite,kts:kte)=0. + !edmf_qc_dd(its:ite,kts:kte)=0. ENDIF + ktop_plume(its:ite)=0 !int + nupdraft(its:ite)=0 !int + maxmf(its:ite)=0. maxKHtopdown(its:ite)=0. - IF (bl_mynn_edmf_dd > 0) THEN - IF (bl_mynn_output > 0) THEN - edmf_a_dd(its:ite,kts:kte)=0. - edmf_w_dd(its:ite,kts:kte)=0. - edmf_qt_dd(its:ite,kts:kte)=0. - edmf_thl_dd(its:ite,kts:kte)=0. - edmf_ent_dd(its:ite,kts:kte)=0. - edmf_qc_dd(its:ite,kts:kte)=0. - ENDIF - ENDIF - ! DH* CHECK HOW MUCH OF THIS INIT IF-BLOCK IS ACTUALLY NEEDED FOR RESTARTS !> - Within the MYNN-EDMF, there is a dependecy check for the first time step, !! If true, a three-dimensional initialization loop is entered. Within this loop, @@ -5236,6 +5232,7 @@ SUBROUTINE mynn_bl_driver( & DO k=kts,kte-1 ! Set max dissipative heating rate to 7.2 K per hour diss_heat(k) = MIN(MAX(0.75*(qke1(k)**1.5)/(b1*MAX(0.5*(el(k)+el(k+1)),1.))/cp, 0.0),0.002) + diss_heat(k) = diss_heat(k) * exp(-10000./MAX(p1(k),1.)) ENDDO diss_heat(kte) = 0. @@ -5401,29 +5398,32 @@ SUBROUTINE mynn_bl_driver( & dqke(i,k)=0. ENDIF - !update updraft properties - IF (bl_mynn_output > 0) THEN !research mode == 1 - DO k = kts,kte - edmf_a(i,k)=edmf_a1(k) - edmf_w(i,k)=edmf_w1(k) - edmf_qt(i,k)=edmf_qt1(k) - edmf_thl(i,k)=edmf_thl1(k) - edmf_ent(i,k)=edmf_ent1(k) - edmf_qc(i,k)=edmf_qc1(k) - sub_thl3D(i,k)=sub_thl(k) - sub_sqv3D(i,k)=sub_sqv(k) - det_thl3D(i,k)=det_thl(k) - det_sqv3D(i,k)=det_sqv(k) - ENDDO - if (bl_mynn_edmf_dd > 0) THEN - !update downdraft properties - edmf_a_dd(i,k)=edmf_a_dd1(k) - edmf_w_dd(i,k)=edmf_w_dd1(k) - edmf_qt_dd(i,k)=edmf_qt_dd1(k) - edmf_thl_dd(i,k)=edmf_thl_dd1(k) - edmf_ent_dd(i,k)=edmf_ent_dd1(k) - edmf_qc_dd(i,k)=edmf_qc_dd1(k) - ENDIF + !update updraft/downdraft properties + if (bl_mynn_output > 0) THEN !research mode == 1 + if (bl_mynn_edmf > 0) THEN + DO k = kts,kte + edmf_a(i,k)=edmf_a1(k) + edmf_w(i,k)=edmf_w1(k) + edmf_qt(i,k)=edmf_qt1(k) + edmf_thl(i,k)=edmf_thl1(k) + edmf_ent(i,k)=edmf_ent1(k) + edmf_qc(i,k)=edmf_qc1(k) + sub_thl3D(i,k)=sub_thl(k) + sub_sqv3D(i,k)=sub_sqv(k) + det_thl3D(i,k)=det_thl(k) + det_sqv3D(i,k)=det_sqv(k) + ENDDO + endif +! if (bl_mynn_edmf_dd > 0) THEN +! DO k = kts,kte +! edmf_a_dd(i,k)=edmf_a_dd1(k) +! edmf_w_dd(i,k)=edmf_w_dd1(k) +! edmf_qt_dd(i,k)=edmf_qt_dd1(k) +! edmf_thl_dd(i,k)=edmf_thl_dd1(k) +! edmf_ent_dd(i,k)=edmf_ent_dd1(k) +! edmf_qc_dd(i,k)=edmf_qc_dd1(k) +! ENDDO +! ENDIF ENDIF !*** Begin debug prints @@ -6063,7 +6063,7 @@ SUBROUTINE DMP_mf( & !Criteria (2) maxwidth = 1.2*PBLH ! Criteria (3) - maxwidth = MIN(maxwidth,0.75*cloud_base) + maxwidth = MIN(maxwidth,0.666*cloud_base) ! Criteria (4) wspd_pbl=SQRT(MAX(u(kts)**2 + v(kts)**2, 0.01)) !Note: area fraction (acfac) is modified below @@ -6207,15 +6207,19 @@ SUBROUTINE DMP_mf( & overshoot = 0 l = dl*I ! diameter of plume DO k=KTS+1,KTE-1 - !w-dependency for entrainment a la Tian and Kuang (2016) + !Entrainment from Tian and Kuang (2016) !ENT(k,i) = 0.35/(MIN(MAX(UPW(K-1,I),0.75),1.9)*l) - wmin = 0.3 + l*0.0005 !* MAX(pblh-ZW(k+1), 0.0)/pblh - ENT(k,i) = 0.33/(MIN(MAX(UPW(K-1,I),wmin),1.9)*l) + !wmin = 0.3 + l*0.0005 !* MAX(pblh-ZW(k+1), 0.0)/pblh + !ENT(k,i) = 0.33/(MIN(MAX(UPW(K-1,I),wmin),1.9)*l) + !Entrainment from Negggers (2015, JAMES) !ENT(k,i) = 0.02*l**-0.35 - 0.0009 + ENT(k,i) = 0.07*l**-0.60 - 0.00079 !diverse-b + !Minimum background entrainment ENT(k,i) = max(ENT(k,i),0.0003) - !ENT(k,i) = max(ENT(k,i),0.05/ZW(k)) !not needed for Tian and Kuang + ENT(k,i) = max(ENT(k,i),0.05/ZW(k)) !not needed for Tian and Kuang + !JOE - increase entrainment for plumes extending very high. IF(ZW(k) >= MIN(pblh+1500., 4000.))THEN ENT(k,i)=ENT(k,i) + (ZW(k)-MIN(pblh+1500.,4000.))*5.0E-6 From 13c0438b15279e61a63cb2b9bc000ed824e202f2 Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Wed, 4 Aug 2021 13:26:59 +0000 Subject: [PATCH 30/85] Update to the entrainment formula - allows removal of contraint on accelerating plumes. --- physics/module_bl_mynn.F90 | 41 +------------------------------------- 1 file changed, 1 insertion(+), 40 deletions(-) diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 860dc99ae..42c550cad 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -6214,7 +6214,7 @@ SUBROUTINE DMP_mf( & !Entrainment from Negggers (2015, JAMES) !ENT(k,i) = 0.02*l**-0.35 - 0.0009 - ENT(k,i) = 0.07*l**-0.60 - 0.00079 !diverse-b + ENT(k,i) = 0.04*l**-0.50 - 0.0009 !more plume diversity !Minimum background entrainment ENT(k,i) = max(ENT(k,i),0.0003) @@ -6313,46 +6313,7 @@ SUBROUTINE DMP_mf( & Wn = UPW(K-1,I) - MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0) ENDIF Wn = MIN(MAX(Wn,0.0), 3.0) -! WA ACP mod 5/7/20 for accelerating plumes above cloud base, add entrainment -! and recalculate updraft variables - IF (QCn > 0.0 .AND. Wn > UPW(K-1,I)) THEN - ENT(K,I) = ENT(K,I) * 2.0 - EntExp= ENT(K,I)*(ZW(k+1)-ZW(k)) - QTn =UPQT(k-1,I) *(1.-EntExp) + QT(k)*EntExp - THLn=UPTHL(k-1,I)*(1.-EntExp) + THL(k)*EntExp - Un =UPU(k-1,I) *(1.-EntExp) + U(k)*EntExp - Vn =UPV(k-1,I) *(1.-EntExp) + V(k)*EntExp - QKEn=UPQKE(k-1,I)*(1.-EntExp) + QKE(k)*EntExp - QNCn=UPQNC(k-1,I)*(1.-EntExp) + QNC(k)*EntExp - QNIn=UPQNI(k-1,I)*(1.-EntExp) + QNI(k)*EntExp - QNWFAn=UPQNWFA(k-1,I)*(1.-EntExp) + QNWFA(k)*EntExp - QNIFAn=UPQNIFA(k-1,I)*(1.-EntExp) + QNIFA(k)*EntExp - ! Define pressure at model interface - Pk =(P(k)*DZ(k+1)+P(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) - ! Compute new plume properties thvn and qcn - call condensation_edmf(QTn,THLn,Pk,ZW(k+1),THVn,QCn) - ! Define environment THV at the model interface levels - THVk =(THV(k)*DZ(k+1)+THV(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) - THVkm1=(THV(k-1)*DZ(k)+THV(k)*DZ(k-1))/(DZ(k-1)+DZ(k)) - B=g*(THVn/THVk - 1.0) - IF(B>0.)THEN - BCOEFF = 0.15 - ELSE - BCOEFF = 0.2 !0.33 - ENDIF - IF (UPW(K-1,I) < 0.2 ) THEN - Wn = UPW(K-1,I) + (-2. * ENT(K,I) * UPW(K-1,I) + BCOEFF*B / MAX(UPW(K-1,I),0.2)) * MIN(ZW(k)-ZW(k-1), 250.) - ELSE - Wn = UPW(K-1,I) + (-2. * ENT(K,I) * UPW(K-1,I) + BCOEFF*B / UPW(K-1,I)) * MIN(ZW(k)-ZW(k-1), 250.) - ENDIF - IF (UPW(K-1,I) < 0.2 ) THEN - Wn = UPW(K-1,I) + (-2. * ENT(K,I) * UPW(K-1,I) + BCOEFF*B / MAX(UPW(K-1,I),0.2)) * MIN(ZW(k)-ZW(k-1), 250.) - ELSE - Wn = UPW(K-1,I) + (-2. * ENT(K,I) * UPW(K-1,I) + BCOEFF*B / UPW(K-1,I)) * MIN(ZW(k)-ZW(k-1), 250.) - ENDIF - ENDIF -! END WA TEST !Check to make sure that the plume made it up at least one level. !if it failed, then set nup2=0 and exit the mass-flux portion. IF (k==kts+1 .AND. Wn == 0.) THEN From d52079aa4cb55ab39d69e0ed2c5fadebdaf89eed Mon Sep 17 00:00:00 2001 From: hannah barnes Date: Wed, 11 Aug 2021 14:55:54 -0600 Subject: [PATCH 31/85] Fix cactiv_m error --- physics/cu_gf_driver.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/cu_gf_driver.F90 b/physics/cu_gf_driver.F90 index 600a30d67..c24a58d4b 100644 --- a/physics/cu_gf_driver.F90 +++ b/physics/cu_gf_driver.F90 @@ -607,7 +607,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,mconv & ,omeg & - ,cactiv & + ,cactiv_m & ,cnvwtm & ,zum & ,zdm & ! hli From 866a0f93a0615f769e3f9810c8d8d1a195b40410 Mon Sep 17 00:00:00 2001 From: hannah barnes Date: Fri, 13 Aug 2021 10:46:42 -0600 Subject: [PATCH 32/85] Fix for uninitialized kklev for mid clouds --- physics/cu_gf_deep.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/cu_gf_deep.F90 b/physics/cu_gf_deep.F90 index 533e743eb..d4b786c46 100644 --- a/physics/cu_gf_deep.F90 +++ b/physics/cu_gf_deep.F90 @@ -4127,9 +4127,9 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & qrc(i,k)=max(0.,(qc(i,k)-qrch)) ! /(1.+c0(i)*dz*zu(i,k)) clw_allh(i,k)=max(0.,qch(i,k)-qrch) qrcb(i,k)=max(0.,(qch(i,k)-qrch)) ! /(1.+c0(i)*dz*zu(i,k)) + kklev(i)=maxloc(zu(i,:),1) ! 05/05/2021 if(name == "deep" )then clwdet=0.02 ! 05/11/2021 - kklev(i)=maxloc(zu(i,:),1) ! 05/05/2021 if(k.lt.kklev(i)) clwdet=0. ! 05/05/2021 else clwdet=0.02 ! 05/05/2021 From 28a920c573b2ad476eefee06a78f18b9ab141e26 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Fri, 13 Aug 2021 16:57:05 +0000 Subject: [PATCH 33/85] 1. Changes for fracional grid (frac_grid=.true.) 2. Replace logical variable for lakes from 'lake' to 'use_flake' 3. Added spp code from WRF version of RUC LSM in case it would be needed for RRFS. So far it is not hooked up to SPP weights. --- physics/module_sf_ruclsm.F90 | 19 +++----- physics/sfc_drv_ruc.F90 | 85 ++++++++++++++++++++++++++---------- physics/sfc_drv_ruc.meta | 11 ++++- 3 files changed, 77 insertions(+), 38 deletions(-) diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 1e0ec2fe2..b5238f366 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -708,8 +708,7 @@ SUBROUTINE LSMRUC( & ENDIF !> - Call soilvegin() to initialize soil and surface properties - IF((XLAND(I,J)-1.5).LT.0..and. xice(i,j).lt.xice_threshold)THEN - !-- land + !-- land or ice CALL SOILVEGIN ( debug_print, & soilfrac,nscat,shdmin(i,j),shdmax(i,j),mosaic_lu, mosaic_soil,& NLCAT,ILAND,ISOIL,iswater,MYJ,IFOREST,lufrac,VEGFRA(I,J), & @@ -724,16 +723,10 @@ SUBROUTINE LSMRUC( & print *,'after SOILVEGIN - z0,znt(1,26),lai(1,26)',z0(i,j),znt(i,j),lai(i,j) if(init)then -! print *,'NLCAT,iland,lufrac,EMISSL(I,J),PC(I,J),ZNT(I,J),LAI(I,J)', & -! NLCAT,iland,lufrac,EMISSL(I,J),PC(I,J),ZNT(I,J),LAI(I,J),i,j print *,'NLCAT,iland,EMISSL(I,J),PC(I,J),ZNT(I,J),LAI(I,J)', & NLCAT,iland,EMISSL(I,J),PC(I,J),ZNT(I,J),LAI(I,J),i,j - -! print *,'NSCAT,soilfrac,QWRTZ,RHOCS,BCLH,DQM,KSAT,PSIS,QMIN,REF,WILT',& -! NSCAT,soilfrac,QWRTZ,RHOCS,BCLH,DQM,KSAT,PSIS,QMIN,REF,WILT,i,j print *,'NSCAT,QWRTZ,RHOCS,BCLH,DQM,KSAT,PSIS,QMIN,REF,WILT',& NSCAT,QWRTZ,RHOCS,BCLH,DQM,KSAT,PSIS,QMIN,REF,WILT,i,j - endif ENDIF @@ -784,7 +777,6 @@ SUBROUTINE LSMRUC( & print *,'NROOT, meltfactor, iforest, ivgtyp, i,j ', nroot,meltfactor,iforest,ivgtyp(I,J),I,J ENDIF - ENDIF ! land !!*** SET ZERO-VALUE FOR SOME OUTPUT DIAGNOSTIC ARRAYS ! if(i.eq.397.and.j.eq.562) then ! print *,'RUC LSM - xland(i,j),xice(i,j),snow(i,j)',i,j,xland(i,j),xice(i,j),snow(i,j) @@ -7052,7 +7044,7 @@ END SUBROUTINE SOILVEGIN !> This subroutine computes liquid and forezen soil moisture from the !! total soil moisture, and also computes soil moisture availability in !! the top soil layer. - SUBROUTINE RUCLSMINIT( debug_print, slmsk, & + SUBROUTINE RUCLSMINIT( debug_print, landfrac, fice, min_seaice, & nzs, isltyp, ivgtyp, mavail, & sh2o, smfr3d, tslb, smois, & ims,ime, jms,jme, kms,kme, & @@ -7065,7 +7057,8 @@ SUBROUTINE RUCLSMINIT( debug_print, slmsk, & #endif IMPLICIT NONE LOGICAL, INTENT(IN ) :: debug_print - REAL, DIMENSION( ims:ime), INTENT(IN ) :: slmsk + REAL, DIMENSION( ims:ime), INTENT(IN ) :: landfrac, fice + REAL, INTENT(IN ) :: min_seaice INTEGER, INTENT(IN ) :: & ims,ime, jms,jme, kms,kme, & @@ -7125,7 +7118,7 @@ SUBROUTINE RUCLSMINIT( debug_print, slmsk, & ! has isltyp=14 for water if (isltyp(i,j) == 0) isltyp(i,j)=14 - if(slmsk(i) == 1. ) then + if(landfrac(i) > 0. ) then !-- land !-- Computate volumetric content of ice in soil !-- and initialize MAVAIL @@ -7158,7 +7151,7 @@ SUBROUTINE RUCLSMINIT( debug_print, slmsk, & endif ENDDO - elseif( slmsk(i) == 2.) then + elseif( fice(i) > min_seaice) then !-- ice mavail(i,j) = 1. DO L=1,NZS diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index f20b51141..8f7243fc3 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -33,7 +33,7 @@ module lsm_ruc subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & flag_restart, flag_init, con_fvirt, con_rd, & im, lsoil_ruc, lsoil, kice, nlev, & ! in - lsm_ruc, lsm, slmsk, stype, vtype, & ! in + lsm_ruc, lsm, slmsk, stype, vtype, landfrac, & ! in q1, prsl1, tsfc_lnd, tsfc_ice, tsfc_wat, & ! in tg3, smc, slc, stc, fice, min_seaice, & ! in sncovr_lnd, sncovr_ice, snoalb, & ! in @@ -64,6 +64,7 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & real (kind=kind_phys), dimension(:), intent(in) :: slmsk real (kind=kind_phys), dimension(:), intent(in) :: stype real (kind=kind_phys), dimension(:), intent(in) :: vtype + real (kind=kind_phys), dimension(:), intent(in) :: landfrac real (kind=kind_phys), dimension(:), intent(in) :: q1 real (kind=kind_phys), dimension(:), intent(in) :: prsl1 real (kind=kind_phys), dimension(:), intent(in) :: tsfc_lnd @@ -168,7 +169,8 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & vegtype(:) = 0 do i = 1, im ! i - horizontal loop - if (slmsk(i) == 2.) then + !if (slmsk(i) == 2.) then + if (fice(i) > min_seaice) then !-- ice if (isot == 1) then soiltyp(i) = 16 @@ -225,8 +227,8 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & call rucinit (flag_restart, im, lsoil_ruc, lsoil, nlev, & ! in me, master, lsm_ruc, lsm, slmsk, & ! in - soiltyp, vegtype, & ! in - tsfc_lnd, tsfc_wat, tg3, & ! in + soiltyp, vegtype, landfrac, fice, & ! in + min_seaice, tsfc_lnd, tsfc_wat, tg3, & ! in zs, dzs, smc, slc, stc, & ! in sh2o, smfrkeep, tslb, smois, & ! out wetness, errmsg, errflg) @@ -346,7 +348,7 @@ subroutine lsm_ruc_run & ! inputs & imp_physics, imp_physics_gfdl, imp_physics_thompson, & & do_mynnsfclay, lsoil_ruc, lsoil, rdlai, zs, & & t1, q1, qc, soiltyp, vegtype, sigmaf, laixy, & - & dlwflx, dswsfc, tg3, coszen, land, icy, lake, & + & dlwflx, dswsfc, tg3, coszen, land, icy, use_lake, & & rainnc, rainc, ice, snow, graupel, & & prsl1, zf, wind, shdmin, shdmax, & & srflag, sfalb_lnd_bck, snoalb, & @@ -414,7 +416,7 @@ subroutine lsm_ruc_run & ! inputs con_hvap, con_fvirt logical, dimension(:), intent(in) :: flag_iter, flag_guess - logical, dimension(:), intent(in) :: land, icy, lake + logical, dimension(:), intent(in) :: land, icy, use_lake logical, dimension(:), intent(in) :: flag_cice logical, intent(in) :: frac_grid logical, intent(in) :: do_mynnsfclay @@ -465,6 +467,10 @@ subroutine lsm_ruc_run & ! inputs character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg +! --- SPP - should be INTENT(IN) + integer :: spp_lsm + real(kind=kind_phys), dimension(im,nlev) :: pattern_spp + ! --- locals: real (kind=kind_phys), dimension(im) :: rho, & & q0, qs1, albbcksol, & @@ -480,6 +486,8 @@ subroutine lsm_ruc_run & ! inputs & sfcqv_ice_old, sfcqc_ice_old, z0rl_ice_old, & & sncovr1_ice_old + !-- local spp pattern array + real (kind=kind_phys), dimension(im,lsoil_ruc,1) :: pattern_spp_lsm real (kind=kind_phys), dimension(lsoil_ruc) :: et @@ -571,7 +579,7 @@ subroutine lsm_ruc_run & ! inputs endif ! - Set flag for ice points for uncoupled model (islmsk(i) == 4 when coupled to CICE) ! - Exclude ice on the lakes if the lake model is turned on. - flag_ice_uncoupled(i) = (flag_ice(i) .and. .not. lake(i)) + flag_ice_uncoupled(i) = (flag_ice(i) .and. .not. use_lake(i)) !> - Set flag for land and ice points. !- 10may19 - ice points are turned off. flag(i) = land(i) .or. flag_ice_uncoupled(i) @@ -622,6 +630,12 @@ subroutine lsm_ruc_run & ! inputs landusef (:,:,:) = 0.0 soilctop (:,:,:) = 0.0 + !-- spp + spp_lsm = 0 ! so far (10May2021) + if(spp_lsm == 0) then + pattern_spp (:,:) = 0.0 + endif + !> -- number of soil categories !if(isot == 1) then !nscat = 19 ! stasgo @@ -852,11 +866,6 @@ subroutine lsm_ruc_run & ! inputs !acsn(i,j) = acsnow(i) acsn(i,j) = 0.0 - ! --- units % - shdfac(i,j) = sigmaf(i)*100. - shdmin1d(i,j) = shdmin(i)*100. - shdmax1d(i,j) = shdmax(i)*100. - tbot(i,j) = tg3(i) !> - 3. canopy/soil characteristics (s): @@ -901,6 +910,10 @@ subroutine lsm_ruc_run & ! inputs endif semis_bck(i,j) = semisbase(i) + ! --- units % + shdfac(i,j) = sigmaf(i)*100. + shdmin1d(i,j) = shdmin(i)*100. + shdmax1d(i,j) = shdmax(i)*100. if (land(i)) then ! at least some land in the grid cell @@ -947,6 +960,27 @@ subroutine lsm_ruc_run & ! inputs snoalb1d_lnd(i,j) = snoalb(i) albbck_lnd(i,j) = albbcksol(i) !sfalb_lnd_bck(i) + + + !-- spp_lsm + if (spp_lsm == 1) then + !-- spp for LSM is dimentioned as (1:lsoil_ruc) + do k = 1, lsoil_ruc + pattern_spp_lsm (i,k,j) = pattern_spp(i,k) + enddo + !-- stochastic perturbation of snow-free albedo, emissivity and veg. + !-- fraction + albbck_lnd(i,j) = min(albbck_lnd(i,j) * (1. + 0.4*pattern_spp_lsm(i,1,j)), 1.) + sfcems_lnd(i,j) = min(sfcems_lnd(i,j) * (1. + 0.1*pattern_spp_lsm(i,1,j)), 1.) + shdfac(i,j) = min(0.01*shdfac(i,j) * (1. + 0.33*pattern_spp_lsm(i,1,j)),1.)*100. + if (kdt == 2) then + !-- stochastic perturbation of soil moisture at time step 2 + do k = 1, lsoil_ruc + smois(i,k) = smois(i,k)*(1+1.5*pattern_spp_lsm(i,k,j)) + enddo + endif + endif + alb_lnd(i,j) = albbck_lnd(i,j) * (1.-sncovr_lnd(i,j)) + snoalb(i) * sncovr_lnd(i,j) ! sfalb_lnd(i) solnet_lnd(i,j) = dswsfc(i)*(1.-alb_lnd(i,j)) !..net sw rad flx (dn-up) at sfc in w/m2 @@ -1486,8 +1520,8 @@ end subroutine lsm_ruc_run !! This subroutine contains RUC LSM initialization. subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in me, master, lsm_ruc, lsm, slmsk, & ! in - soiltyp, vegtype, & ! in - tskin_lnd, tskin_wat, tg3, & ! !in + soiltyp, vegtype, landfrac, fice, & ! in + min_seaice, tskin_lnd, tskin_wat, tg3, & ! in zs, dzs, smc, slc, stc, & ! in sh2o, smfrkeep, tslb, smois, & ! out wetness, errmsg, errflg) @@ -1500,7 +1534,10 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in integer, intent(in ) :: im, nlev integer, intent(in ) :: lsoil_ruc integer, intent(in ) :: lsoil + real (kind=kind_phys), intent(in ) :: min_seaice real (kind=kind_phys), dimension(im), intent(in ) :: slmsk + real (kind=kind_phys), dimension(im), intent(in ) :: landfrac + real (kind=kind_phys), dimension(im), intent(in ) :: fice real (kind=kind_phys), dimension(im), intent(in ) :: tskin_lnd, tskin_wat real (kind=kind_phys), dimension(im), intent(in ) :: tg3 real (kind=kind_phys), dimension(1:lsoil_ruc), intent(in ) :: zs @@ -1658,14 +1695,14 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in tbot(i,j) = tg3(i) ivgtyp(i,j) = vegtype(i) isltyp(i,j) = soiltyp(i) - if (slmsk(i) == 0.) then - !-- water - tsk(i,j) = tskin_wat(i) - landmask(i,j)=0. - else + if (landfrac(i) > 0. .or. fice(i) > 0.) then !-- land or ice tsk(i,j) = tskin_lnd(i) landmask(i,j)=1. + else + !-- water + tsk(i,j) = tskin_wat(i) + landmask(i,j)=0. endif ! land(i) enddo @@ -1680,7 +1717,7 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in sm_input(i,1,j)=0. !--- initialize smcwlt2 and smcref2 with Noah values - if(slmsk(i) == 1.) then + if(landfrac(i) > 0.) then smcref2 (i) = REFSMCnoah(soiltyp(i)) smcwlt2 (i) = WLTSMCnoah(soiltyp(i)) else @@ -1691,7 +1728,7 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in do k=1,lsoil st_input(i,k+1,j)=stc(i,k) ! convert volumetric soil moisture to SWI (soil wetness index) - if(slmsk(i) == 1. .and. swi_init) then + if(landfrac(i) > 0. .and. swi_init) then sm_input(i,k+1,j)=min(1.,max(0.,(smc(i,k) - smcwlt2(i))/ & (smcref2(i) - smcwlt2(i)))) else @@ -1726,7 +1763,7 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in do j=jts,jte do i=its,ite - if (slmsk(i) == 1.) then + if (landfrac(i) == 1.) then !-- land do k=1,lsoil_ruc ! convert from SWI to RUC volumetric soil moisture @@ -1767,7 +1804,7 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in do j=jts,jte do i=its,ite - if (slmsk(i) == 1.) then + if (landfrac(i) > 0.) then ! initialize factor do k=1,lsoil_ruc @@ -1844,7 +1881,7 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in ! and soil temperature, and also soil moisture availability in the top ! layer - call ruclsminit( debug_print, slmsk, & + call ruclsminit( debug_print, landfrac, fice, min_seaice, & lsoil_ruc, isltyp, ivgtyp, mavail, & soilh2o, smfr, soiltemp, soilm, & ims,ime, jms,jme, kms,kme, & diff --git a/physics/sfc_drv_ruc.meta b/physics/sfc_drv_ruc.meta index cf37670fe..fd542b67b 100644 --- a/physics/sfc_drv_ruc.meta +++ b/physics/sfc_drv_ruc.meta @@ -164,6 +164,15 @@ kind = kind_phys intent = in optional = F +[landfrac] + standard_name = land_area_fraction + long_name = fraction of horizontal grid area occupied by land + units = frac + dimensions = (horizontal_dimension) + 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 @@ -844,7 +853,7 @@ type = logical intent = in optional = F -[lake] +[use_lake] standard_name = flag_for_using_flake long_name = flag indicating lake points using flake model units = flag From 87eb895bd45687981be9cc858cc0bcebc5c0f04f Mon Sep 17 00:00:00 2001 From: hannah barnes Date: Fri, 13 Aug 2021 11:05:43 -0600 Subject: [PATCH 34/85] Slight cleanup to kklev --- physics/cu_gf_deep.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/cu_gf_deep.F90 b/physics/cu_gf_deep.F90 index d4b786c46..a064cf73a 100644 --- a/physics/cu_gf_deep.F90 +++ b/physics/cu_gf_deep.F90 @@ -4079,6 +4079,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & ! !now do the rest ! + kklev(i)=maxloc(zu(i,:),1) do k=kbcon(i)+1,ktop(i) if(t(i,k) > 273.16) then c0t = c0(i) @@ -4127,7 +4128,6 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & qrc(i,k)=max(0.,(qc(i,k)-qrch)) ! /(1.+c0(i)*dz*zu(i,k)) clw_allh(i,k)=max(0.,qch(i,k)-qrch) qrcb(i,k)=max(0.,(qch(i,k)-qrch)) ! /(1.+c0(i)*dz*zu(i,k)) - kklev(i)=maxloc(zu(i,:),1) ! 05/05/2021 if(name == "deep" )then clwdet=0.02 ! 05/11/2021 if(k.lt.kklev(i)) clwdet=0. ! 05/05/2021 From 897f8aa7cd6a1556ca0358c4788c8714579bf64b Mon Sep 17 00:00:00 2001 From: hannah barnes Date: Mon, 16 Aug 2021 08:44:49 -0600 Subject: [PATCH 35/85] Clean up of code syntax --- physics/GFS_rrtmg_pre.F90 | 2 +- physics/cu_gf_deep.F90 | 10 +++++----- physics/module_SGSCloud_RadPre.F90 | 2 +- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 77bef1880..ccaff7335 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -125,7 +125,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & real(kind=kind_phys), dimension(:,:), intent(inout) :: clouds1, & clouds2, clouds3, & clouds4, clouds5 - real(kind=kind_phys), dimension(:,:), intent(inout) :: qci_conv + real(kind=kind_phys), dimension(:,:), intent(in) :: qci_conv integer, intent(out) :: kd, kt, kb diff --git a/physics/cu_gf_deep.F90 b/physics/cu_gf_deep.F90 index a064cf73a..a01caf55b 100644 --- a/physics/cu_gf_deep.F90 +++ b/physics/cu_gf_deep.F90 @@ -390,7 +390,7 @@ subroutine cu_gf_deep_run( & ! Set cloud water to rain water conversion rate (c0) do i=its,itf c0(i)=0.004 - if(xland1(i).eq.1)c0(i)=.002 + if(xland1(i).eq.1)c0(i)=0.002 if(imid.eq.1)then c0(i)=0.002 endif @@ -3976,7 +3976,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & real(kind=kind_phys), dimension (its:ite,kts:kte) :: & qch,qrcb,pwh,clw_allh,c1d,c1d_b,t real(kind=kind_phys), dimension (its:ite) :: & - pwavh,kklev + pwavh real(kind=kind_phys), dimension (its:ite) & ,intent (out ) :: & pwav,psum,psumh @@ -3989,7 +3989,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & integer :: & iprop,iall,i,k - integer :: start_level(its:ite) + integer :: start_level(its:ite),kklev(its:ite) real(kind=kind_phys) :: & prop_ave,qrcb_h,bdsp,dp,rhoc,qrch,qaver,clwdet, & dz,berryc0,q1,berryc @@ -4001,7 +4001,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & prop_b(kts:kte)=0 iall=0 clwdet=0.02 - c0_iceconv=.01 + c0_iceconv=0.01 c1d_b=c1d bdsp=bdispm ! @@ -4086,7 +4086,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & else c0t = c0(i) * exp(c0_iceconv * (t(i,k) - 273.16)) endif - if(name == "mid")c0t=.004 + if(name == "mid")c0t=0.004 denom=zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1) if(denom.lt.1.e-16)then diff --git a/physics/module_SGSCloud_RadPre.F90 b/physics/module_SGSCloud_RadPre.F90 index 59c0fcfb0..75a65f88b 100644 --- a/physics/module_SGSCloud_RadPre.F90 +++ b/physics/module_SGSCloud_RadPre.F90 @@ -267,7 +267,7 @@ subroutine sgscloud_radpre_run( & endif if ( do_mynnedmf ) then - !print *,'MYNN PBL or GFDL MP cldcov used' + !print *,'MYNN PBL cldcov used' else !print *,'GF with Xu-Randall cloud fraction' ! Xu-Randall (1996) cloud fraction From 9bf6335bde366b812a5820b94f4e9487fa68d81f Mon Sep 17 00:00:00 2001 From: hannah barnes Date: Thu, 19 Aug 2021 12:52:10 -0600 Subject: [PATCH 36/85] Clean up code Fix definition of xland1 --- physics/GFS_rrtmg_pre.meta | 2 +- physics/cu_gf_deep.F90 | 10 ++++++---- physics/cu_gf_driver.F90 | 4 ++++ 3 files changed, 11 insertions(+), 5 deletions(-) diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 3c7115732..5139c6d92 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -803,7 +803,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys - intent = inout + intent = in optional = F [kd] standard_name = vertical_index_difference_between_inout_and_local diff --git a/physics/cu_gf_deep.F90 b/physics/cu_gf_deep.F90 index a01caf55b..9bee635d0 100644 --- a/physics/cu_gf_deep.F90 +++ b/physics/cu_gf_deep.F90 @@ -390,7 +390,9 @@ subroutine cu_gf_deep_run( & ! Set cloud water to rain water conversion rate (c0) do i=its,itf c0(i)=0.004 + xland1(i)=int(xland(i)+.0001) ! 1. if(xland1(i).eq.1)c0(i)=0.002 + if(imid.eq.1)then c0(i)=0.002 endif @@ -435,7 +437,6 @@ subroutine cu_gf_deep_run( & ! ! for water or ice ! - xland1(i)=int(xland(i)+.0001) ! 1. if(xland(i).gt.1.5 .or. xland(i).lt.0.5)then xland1(i)=0 ! if(imid.eq.0)cap_max(i)=cap_maxs-25. @@ -3973,8 +3974,11 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (out ) :: & qc,qrc,pw,clw_all + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (inout) :: & + c1d real(kind=kind_phys), dimension (its:ite,kts:kte) :: & - qch,qrcb,pwh,clw_allh,c1d,c1d_b,t + qch,qrcb,pwh,clw_allh,c1d_b,t real(kind=kind_phys), dimension (its:ite) :: & pwavh real(kind=kind_phys), dimension (its:ite) & @@ -4137,8 +4141,6 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & endif if(k.gt.kbcon(i)+1)c1d(i,k)=clwdet*up_massdetr(i,k-1) if(k.gt.kbcon(i)+1)c1d_b(i,k)=clwdet*up_massdetr(i,k-1) - clw_all(i,k)=max(0.,qc(i,k)-qrch) - clw_allh(i,k)=max(0.,qch(i,k)-qrch) if(autoconv.eq.2) then ! diff --git a/physics/cu_gf_driver.F90 b/physics/cu_gf_driver.F90 index c24a58d4b..20006f4d2 100644 --- a/physics/cu_gf_driver.F90 +++ b/physics/cu_gf_driver.F90 @@ -260,6 +260,10 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& rand_mom(:) = 0. rand_vmas(:) = 0. rand_clos(:,:) = 0. + + cnvwtm(:,:) = 0. + cnvwts(:,:) = 0. + cnvwt(:,:) = 0. ! its=1 ite=im From 4ec7d99a2e2a8b119019dba14cb71afe57425bf7 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Thu, 19 Aug 2021 13:52:06 -0600 Subject: [PATCH 37/85] Update standard names mid_conv_activity_counter and gf_mid_memory_counter --- physics/cu_gf_driver.meta | 2 +- physics/cu_gf_driver_post.meta | 4 ++-- physics/cu_gf_driver_pre.meta | 4 ++-- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/physics/cu_gf_driver.meta b/physics/cu_gf_driver.meta index 32888dfb5..1648d4664 100644 --- a/physics/cu_gf_driver.meta +++ b/physics/cu_gf_driver.meta @@ -144,7 +144,7 @@ intent = inout optional = F [cactiv_m] - standard_name = mid_conv_activity_counter + standard_name = counter_for_grell_freitas_mid_level_convection long_name = mid-level cloud convective activity memory units = none dimensions = (horizontal_loop_extent) diff --git a/physics/cu_gf_driver_post.meta b/physics/cu_gf_driver_post.meta index 025094b75..26aeade5d 100644 --- a/physics/cu_gf_driver_post.meta +++ b/physics/cu_gf_driver_post.meta @@ -60,7 +60,7 @@ intent = in optional = F [cactiv_m] - standard_name = mid_conv_activity_counter + standard_name = counter_for_grell_freitas_mid_level_convection long_name = midlevel convective activity memory units = none dimensions = (horizontal_loop_extent) @@ -77,7 +77,7 @@ intent = out optional = F [conv_act_m] - standard_name = gf_mid_memory_counter + standard_name = consecutive_calls_for_grell_freitas_mid_level_convection long_name = Memory counter for GF midlevel units = none dimensions = (horizontal_loop_extent) diff --git a/physics/cu_gf_driver_pre.meta b/physics/cu_gf_driver_pre.meta index 123cdae63..f3a0e977d 100644 --- a/physics/cu_gf_driver_pre.meta +++ b/physics/cu_gf_driver_pre.meta @@ -112,7 +112,7 @@ intent = out optional = F [cactiv_m] - standard_name = mid_conv_activity_counter + standard_name = counter_for_grell_freitas_mid_level_convection long_name = midlevel convective activity memory units = none dimensions = (horizontal_loop_extent) @@ -129,7 +129,7 @@ intent = in optional = F [conv_act_m] - standard_name = gf_mid_memory_counter + standard_name = consecutive_calls_for_grell_freitas_mid_level_convection long_name = Memory counter for GF midlevel units = none dimensions = (horizontal_loop_extent) From 7b6808777f0c4125e044d94b633133068519fe8a Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 23 Aug 2021 07:42:57 -0600 Subject: [PATCH 38/85] Update physics/GFS_debug.F90 with latest changes to GFS_interstitial DDT --- physics/GFS_debug.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index f4fd9e808..5be810f07 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -1267,6 +1267,7 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%kpbl ', Interstitial%kpbl ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%kt ', Interstitial%kt ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ktop ', Interstitial%ktop ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%max_hourly_reset ', Interstitial%max_hourly_reset ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%mbota ', Interstitial%mbota ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%mtopa ', Interstitial%mtopa ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%nday ', Interstitial%nday ) @@ -1291,7 +1292,6 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%rb_ice ', Interstitial%rb_ice ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%rb_land ', Interstitial%rb_land ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%rb_water ', Interstitial%rb_water ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%reset ', Interstitial%reset ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%rhc ', Interstitial%rhc ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%runoff ', Interstitial%runoff ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%save_q ', Interstitial%save_q ) From 6b88aaa7b738e2812029b574f65b6cf7b1fce819 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 23 Aug 2021 07:45:32 -0600 Subject: [PATCH 39/85] Bug fixes for uninitialized variables in physics/cu_gf_deep.F90 and physics/cu_gf_driver.F90 --- physics/cu_gf_deep.F90 | 12 +++++++----- physics/cu_gf_driver.F90 | 1 + 2 files changed, 8 insertions(+), 5 deletions(-) diff --git a/physics/cu_gf_deep.F90 b/physics/cu_gf_deep.F90 index a01caf55b..810de8813 100644 --- a/physics/cu_gf_deep.F90 +++ b/physics/cu_gf_deep.F90 @@ -388,8 +388,12 @@ subroutine cu_gf_deep_run( & ! !---------------------------------------------------- ! HCB ! Set cloud water to rain water conversion rate (c0) + c0(:)=0.004 do i=its,itf - c0(i)=0.004 + xland1(i)=int(xland(i)+.0001) ! 1. + if(xland(i).gt.1.5 .or. xland(i).lt.0.5)then + xland1(i)=0 + endif if(xland1(i).eq.1)c0(i)=0.002 if(imid.eq.1)then c0(i)=0.002 @@ -435,9 +439,7 @@ subroutine cu_gf_deep_run( & ! ! for water or ice ! - xland1(i)=int(xland(i)+.0001) ! 1. - if(xland(i).gt.1.5 .or. xland(i).lt.0.5)then - xland1(i)=0 + if (xland1(i)==0) then ! if(imid.eq.0)cap_max(i)=cap_maxs-25. ! if(imid.eq.1)cap_max(i)=cap_maxs-50. cap_max_increment(i)=20. @@ -4079,7 +4081,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & ! !now do the rest ! - kklev(i)=maxloc(zu(i,:),1) + kklev(i)=maxloc(zu(i,:),1) do k=kbcon(i)+1,ktop(i) if(t(i,k) > 273.16) then c0t = c0(i) diff --git a/physics/cu_gf_driver.F90 b/physics/cu_gf_driver.F90 index c24a58d4b..b3b42060e 100644 --- a/physics/cu_gf_driver.F90 +++ b/physics/cu_gf_driver.F90 @@ -442,6 +442,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& cnvwt(:,:)=0. cnvwts(:,:)=0. + cnvwtm(:,:)=0. hco(:,:)=0. hcom(:,:)=0. From a0d11ca75cf3125e6230d06b8d8d4233cba1c83a Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 23 Aug 2021 07:46:53 -0600 Subject: [PATCH 40/85] Fix intent of variable qci_conv in physics/GFS_rrtmg_pre.meta --- physics/GFS_rrtmg_pre.meta | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 3c7115732..5139c6d92 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -803,7 +803,7 @@ dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys - intent = inout + intent = in optional = F [kd] standard_name = vertical_index_difference_between_inout_and_local From 163f82d69d431a58f95d87e4f22af118bbeb12c2 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 23 Aug 2021 10:17:20 -0600 Subject: [PATCH 41/85] Update to physics/cu_gf_driver.meta following CCPP standard names update --- physics/cu_gf_driver.meta | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/cu_gf_driver.meta b/physics/cu_gf_driver.meta index 1648d4664..2e62fd834 100644 --- a/physics/cu_gf_driver.meta +++ b/physics/cu_gf_driver.meta @@ -120,7 +120,7 @@ intent = in optional = F [flag_init] - standard_name = flag_for_first_time_step + standard_name = flag_for_first_timestep long_name = flag signaling first time step for time integration loop units = flag dimensions = () From 3a1f931d4f1f265b96b2128899ff0f580c1d4ab6 Mon Sep 17 00:00:00 2001 From: hannah barnes Date: Thu, 14 Oct 2021 12:51:35 -0600 Subject: [PATCH 42/85] Turn on GF aerosol-awareness Tune clwdet (cloud-water detrainment) Make evfact (evaporation factor) and radiation tuning factors scale-aware --- physics/cu_gf_deep.F90 | 23 ++++++++++++++--------- physics/cu_gf_driver.F90 | 14 +++++++++----- 2 files changed, 23 insertions(+), 14 deletions(-) diff --git a/physics/cu_gf_deep.F90 b/physics/cu_gf_deep.F90 index 17347d6c3..59bbd566d 100644 --- a/physics/cu_gf_deep.F90 +++ b/physics/cu_gf_deep.F90 @@ -28,8 +28,8 @@ module cu_gf_deep real(kind=kind_phys), parameter :: pgcd = 0.1 ! !> aerosol awareness, do not user yet! - integer, parameter :: autoconv=1 - integer, parameter :: aeroevap=1 + integer, parameter :: autoconv=2 + integer, parameter :: aeroevap=3 real(kind=kind_phys), parameter :: scav_factor = 0.5 !> still 16 ensembles for clousres integer, parameter:: maxens3=16 @@ -98,6 +98,7 @@ subroutine cu_gf_deep_run( & ,kbcon & ! lfc of parcel from k22 ,ktop & ! cloud top ,cupclw & ! used for direct coupling to radiation, but with tuning factors + ,frh_out & ! fractional coverage ,ierr & ! ierr flags are error flags, used for debugging ,ierrc & ! the following should be set to zero if not available ,rand_mom & ! for stochastics mom, if temporal and spatial patterns exist @@ -149,6 +150,9 @@ subroutine cu_gf_deep_run( & real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (inout ) :: & cnvwt,outu,outv,outt,outq,outqc,cupclw + real(kind=kind_phys), dimension (its:ite) & + ,intent (out ) :: & + frh_out real(kind=kind_phys), dimension (its:ite) & ,intent (inout ) :: & pre,xmb_out @@ -364,8 +368,8 @@ subroutine cu_gf_deep_run( & c1_max=c1 elocp=xlv/cp el2orc=xlv*xlv/(r_v*cp) - evfact=.4 ! .2 - evfactl=.2 + evfact=0.25 ! .4 + evfactl=0.25 ! .2 !evfact=.0 ! for 4F5f !evfactl=.4 @@ -473,6 +477,7 @@ subroutine cu_gf_deep_run( & entr_rate(i)=.2/radius endif sig(i)=(1.-frh)**2 + frh_out(i) = frh enddo sig_thresh = (1.-frh_thresh)**2 @@ -1996,8 +2001,8 @@ subroutine cu_gf_deep_run( & qevap(i) = 0. flg(i) = .true. if(ierr(i).eq.0)then - evef = edt(i) * evfact - if(xland(i).gt.0.5 .and. xland(i).lt.1.5) evef=edt(i) * evfactl + evef = edt(i) * evfact * sig(i)**2 + if(xland(i).gt.0.5 .and. xland(i).lt.1.5) evef = edt(i) * evfactl * sig(i)**2 do k = ktop(i), 1, -1 rain = pwo(i,k) + edto(i) * pwdo(i,k) rn(i) = rn(i) + rain * xmb(i) * .001 * dtime @@ -4005,7 +4010,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & ! prop_b(kts:kte)=0 iall=0 - clwdet=0.02 + clwdet=0.1 !0.02 c0_iceconv=0.01 c1d_b=c1d bdsp=bdispm @@ -4134,10 +4139,10 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & clw_allh(i,k)=max(0.,qch(i,k)-qrch) qrcb(i,k)=max(0.,(qch(i,k)-qrch)) ! /(1.+c0(i)*dz*zu(i,k)) if(name == "deep" )then - clwdet=0.02 ! 05/11/2021 + clwdet=0.1 !0.02 ! 05/11/2021 if(k.lt.kklev(i)) clwdet=0. ! 05/05/2021 else - clwdet=0.02 ! 05/05/2021 + clwdet=0.1 !0.02 ! 05/05/2021 if(k.lt.kklev(i)) clwdet=0. ! 05/25/2021 endif if(k.gt.kbcon(i)+1)c1d(i,k)=clwdet*up_massdetr(i,k-1) diff --git a/physics/cu_gf_driver.F90 b/physics/cu_gf_driver.F90 index b03729695..d134b7d02 100644 --- a/physics/cu_gf_driver.F90 +++ b/physics/cu_gf_driver.F90 @@ -159,6 +159,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& real(kind=kind_phys), dimension (im) :: ccn_gf,ccn_m real(kind=kind_phys) :: ccnclean real(kind=kind_phys), dimension (im) :: dx + real(kind=kind_phys), dimension (im) :: frhm,frhd real(kind=kind_phys), dimension (im,km) :: outt,outq,outqc,phh,subm,cupclw,cupclws real(kind=kind_phys), dimension (im,km) :: dhdt,zu,zus,zd,phf,zum,zdm,outum,outvm real(kind=kind_phys), dimension (im,km) :: outts,outqs,outqcs,outu,outv,outus,outvs @@ -256,8 +257,8 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ! ! these should be coming in from outside ! - cactiv(:) = 0 - cactiv_m(:) = 0 +! cactiv(:) = 0 +! cactiv_m(:) = 0 rand_mom(:) = 0. rand_vmas(:) = 0. rand_clos(:,:) = 0. @@ -277,8 +278,8 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& !> - Set tuning constants for radiation coupling ! tun_rad_shall(:)=.01 - tun_rad_mid(:)=.02 - tun_rad_deep(:)=.065 + tun_rad_mid(:)=.3 !.02 + tun_rad_deep(:)=.3 !.065 edt(:)=0. edtm(:)=0. edtd(:)=0. @@ -628,6 +629,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,kbconm & ,ktopm & ,cupclwm & + ,frhm & ,ierrm & ,ierrcm & ! the following should be set to zero if not available @@ -710,6 +712,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,kbcon & ,ktop & ,cupclw & + ,frhd & ,ierr & ,ierrc & ! the following should be set to zero if not available @@ -819,7 +822,8 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& gdc(i,k,1)= max(0.,tun_rad_shall(i)*cupclws(i,k)*cutens(i)) ! my mod !gdc2(i,k,1)=max(0.,tun_rad_deep(i)*(cupclwm(i,k)*cutenm(i)+cupclw(i,k)*cuten(i))) - gdc2(i,k,1)=max(0.,tun_rad_mid(i)*cupclwm(i,k)*cutenm(i)+tun_rad_deep(i)*cupclw(i,k)*cuten(i)+tun_rad_shall(i)*cupclws(i,k)*cutens(i)) + !gdc2(i,k,1)=max(0.,tun_rad_mid(i)*cupclwm(i,k)*cutenm(i)+tun_rad_deep(i)*cupclw(i,k)*cuten(i)+tun_rad_shall(i)*cupclws(i,k)*cutens(i)) + gdc2(i,k,1) = min(0.1, max(0.01, tun_rad_mid(i)*frhm(i)))*cupclwm(i,k)*cutenm(i) + min(0.1, max(0.01, tun_rad_deep(i)*(frhd(i))))*cupclw(i,k)*cuten(i) + tun_rad_shall(i)*cupclws(i,k)*cutens(i) qci_conv(i,k)=gdc2(i,k,1) gdc(i,k,2)=(outt(i,k))*86400. gdc(i,k,3)=(outtm(i,k))*86400. From e7f1496c8a5f7c5b990654dd12d6ffbc5d10d6c4 Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Tue, 19 Oct 2021 23:06:38 +0000 Subject: [PATCH 43/85] Updates to MYNN-EDMF --- physics/module_MYNNPBL_wrapper.F90 | 2 +- physics/module_bl_mynn.F90 | 1236 ++++++++++++++++------------ 2 files changed, 699 insertions(+), 539 deletions(-) diff --git a/physics/module_MYNNPBL_wrapper.F90 b/physics/module_MYNNPBL_wrapper.F90 index d8e8d7107..961809a72 100644 --- a/physics/module_MYNNPBL_wrapper.F90 +++ b/physics/module_MYNNPBL_wrapper.F90 @@ -223,7 +223,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & spp_pbl=0, & & bl_mynn_mixscalars=1 REAL, PARAMETER :: & - & closure=2.5 !2.5, 2.6 or 3.0 + & closure=2.6 !2.5, 2.6 or 3.0 LOGICAL :: & & FLAG_QI, FLAG_QNI, FLAG_QC, FLAG_QNC, & & FLAG_QNWFA, FLAG_QNIFA diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 42c550cad..5c83ab8c2 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -6,15 +6,16 @@ ! NOAA/GSD & CIRA/CSU, Feb 2008 ! changes to original code: ! 1. code is 1D (in z) -! 2. no advection of TKE, covariances and variances +! 2. option to advect TKE, but not the covariances and variances ! 3. Cranck-Nicholson replaced with the implicit scheme -! 4. removed terrain dependent grid since input in WRF in actual +! 4. removed terrain-dependent grid since input in WRF in actual ! distances in z[m] -! 5. cosmetic changes to adhere to WRF standard (remove common blocks, +! 5. cosmetic changes to adhere to WRF standard (remove common blocks, ! intent etc) !------------------------------------------------------------------- !Modifications implemented by Joseph Olson and Jaymes Kenyon (NOAA/GSL), -!Wayne Angevine (NOAA/CSL), Kay Suselj (NASA/JPL), Franciano Puhales (UFSM) +!Wayne Angevine (NOAA/CSL), Kay Suselj (NASA/JPL), Franciano Puhales (UFSM), +!Laura Fowler (NCAR), and Elynn Wu (UCSD) ! ! Departures from original MYNN (Nakanish & Niino 2009) ! 1. Addition of BouLac mixing length in the free atmosphere. @@ -241,7 +242,7 @@ MODULE module_bl_mynn ! and factor for eddy viscosity for TKE (Kq = Sqfac*Km): REAL, PARAMETER :: qmin=0.0, zmax=1.0, Sqfac=3.0 ! Note that the following mixing-length constants are now specified in mym_length -! &cns=3.5, alp1=0.23, alp2=0.3, alp3=3.0, alp4=10.0, alp5=0.4 +! &cns=3.5, alp1=0.23, alp2=0.3, alp3=3.0, alp4=10.0, alp5=0.2 ! Constants for gravitational settling ! REAL, PARAMETER :: gno=1.e6/(1.e8)**(2./3.), gpw=5./3., qcgmin=1.e-8 @@ -488,6 +489,7 @@ SUBROUTINE mym_initialize ( & & kts,kte, & & dz, dx, zw, & & u, v, thl, qw, & + & thlsg, qwsg, & ! & ust, rmo, pmz, phh, flt, flq, & & zi, theta, thetav, sh, sm, & & ust, rmo, el, & @@ -517,7 +519,7 @@ SUBROUTINE mym_initialize ( & INTEGER :: k,l,lmax REAL :: phm,vkz,elq,elv,b1l,b2l,pmz=1.,phh=1.,flt=0.,flq=0.,tmpq REAL :: zi - REAL, DIMENSION(kts:kte) :: theta, thetav + REAL, DIMENSION(kts:kte) :: theta,thetav,thlsg,qwsg REAL, DIMENSION(kts:kte) :: rstoch_col INTEGER ::spp_pbl @@ -533,6 +535,7 @@ SUBROUTINE mym_initialize ( & CALL mym_level2 ( kts,kte, & & dz, & & u, v, thl, thetav, qw, & + & thlsg, qwsg, & & ql, vt, vq, & & dtl, dqw, dtv, gm, gh, sm, sh ) ! @@ -691,6 +694,7 @@ END SUBROUTINE mym_initialize SUBROUTINE mym_level2 (kts,kte, & & dz, & & u, v, thl, thetav, qw, & + & thlsg, qwsg, & & ql, vt, vq, & & dtl, dqw, dtv, gm, gh, sm, sh ) ! @@ -705,7 +709,7 @@ SUBROUTINE mym_level2 (kts,kte, & REAL, DIMENSION(kts:kte), INTENT(in) :: dz REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,qw,ql,vt,vq,& - thetav + thetav,thlsg,qwsg REAL, DIMENSION(kts:kte), INTENT(out) :: & &dtl,dqw,dtv,gm,gh,sm,sh @@ -742,7 +746,11 @@ SUBROUTINE mym_level2 (kts,kte, & duz = ( u(k)-u(k-1) )**2 +( v(k)-v(k-1) )**2 duz = duz /dzk**2 dtz = ( thl(k)-thl(k-1) )/( dzk ) + !Alternatively, use SGS clouds for thl + !dtz = ( thlsg(k)-thlsg(k-1) )/( dzk ) dqz = ( qw(k)-qw(k-1) )/( dzk ) + !Alternatively, use SGS clouds for qw + !dqz = ( qwsg(k)-qwsg(k-1) )/( dzk ) ! vtt = 1.0 +vt(k)*abk +vt(k-1)*afk ! Beta-theta in NN09, Eq. 39 vqq = tv0 +vq(k)*abk +vq(k-1)*afk ! Beta-q @@ -891,14 +899,14 @@ SUBROUTINE mym_length ( & SELECT CASE(bl_mynn_mixlength) - CASE (0) ! ORIGINAL MYNN MIXING LENGTH + CASE (0) ! ORIGINAL MYNN MIXING LENGTH + BouLac cns = 2.7 alp1 = 0.23 alp2 = 1.0 alp3 = 5.0 alp4 = 100. - alp5 = 0.4 + alp5 = 0.2 ! Impose limits on the height integration for elt and the transition layer depth zi2 = MIN(10000.,zw(kte-2)) !originally integrated to model top, not just 10 km. @@ -976,11 +984,11 @@ SUBROUTINE mym_length ( & CASE (1, 2) !NONLOCAL (using BouLac) FORM OF MIXING LENGTH cns = 3.5 - alp1 = 0.23 + alp1 = 0.21 alp2 = 0.3 alp3 = 1.5 - alp4 = 5. - alp5 = 0.4 + alp4 = 5.0 + alp5 = 0.2 alp6 = 50. ! Impose limits on the height integration for elt and the transition layer depth @@ -989,8 +997,8 @@ SUBROUTINE mym_length ( & h1=MIN(h1,500.) ! 1/2 transition layer depth h2=h1/2.0 ! 1/4 transition layer depth - qtke(kts)=MAX(0.5*qke(kts),0.01) !tke at full sigma levels - thetaw(kts)=theta(kts) !theta at full-sigma levels + qtke(kts)=MAX(0.5*qke(kts), 0.01) !tke at full sigma levels + thetaw(kts)=theta(kts) !theta at full-sigma levels qkw(kts) = SQRT(MAX(qke(kts),1.0e-10)) DO k = kts+1,kte @@ -1074,15 +1082,15 @@ SUBROUTINE mym_length ( & END DO - CASE (3) !Experimental mixing length formulation + CASE (3) !Local (mostly) mixing length formulation Uonset = 3.5 + dz(kts)*0.1 Ugrid = sqrt(u1(kts)**2 + v1(kts)**2) cns = 3.5 !JOE-test * (1.0 - MIN(MAX(Ugrid - Uonset, 0.0)/10.0, 1.0)) - alp1 = 0.23 + alp1 = 0.21 alp2 = 0.30 alp3 = 1.5 - alp4 = 10.0 !was 20. + alp4 = 5.0 alp5 = alp2 !like alp2, but for free atmosphere alp6 = 50.0 !used for MF mixing length @@ -1604,6 +1612,7 @@ SUBROUTINE mym_turbulence ( & & closure, & & dz, dx, zw, & & u, v, thl, thetav, ql, qw, & + & thlsg, qwsg, & & qke, tsq, qsq, cov, & & vt, vq, & & rmo, flt, flq, & @@ -1634,7 +1643,7 @@ SUBROUTINE mym_turbulence ( & REAL, INTENT(in) :: rmo,flt,flq,Psig_bl,Psig_shcu,dx REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,thetav,qw,& &ql,vt,vq,qke,tsq,qsq,cov,cldfra_bl1D,edmf_w1,edmf_a1,edmf_qc1,& - &TKEprodTD + &TKEprodTD,thlsg,qwsg REAL, DIMENSION(kts:kte), INTENT(out) :: dfm,dfh,dfq,& &pdk,pdt,pdq,pdc,tcd,qcd,el @@ -1687,7 +1696,8 @@ SUBROUTINE mym_turbulence ( & CALL mym_level2 (kts,kte, & & dz, & - & u, v, thl, theta, qw, & + & u, v, thl, thetav, qw, & + & thlsg, qwsg, & & ql, vt, vq, & & dtl, dqw, dtv, gm, gh, sm, sh ) ! @@ -1731,8 +1741,10 @@ SUBROUTINE mym_turbulence ( & !level 2.0 Prandtl number !Prnum = MIN(sm20/sh20, 4.0) !The form of Zilitinkevich et al. (2006) but modified - !following Esau and Grachev (2007, Wind Eng) + !half-way towards Esau and Grachev (2007, Wind Eng) + !Prnum = MIN(0.76 + 3.0*MAX(ri,0.0), Prlimit) Prnum = MIN(0.76 + 4.0*MAX(ri,0.0), Prlimit) + !Prnum = MIN(0.76 + 5.0*MAX(ri,0.0), Prlimit) ! ! Modified: Dec/22/2005, from here, (dlsq -> elsq) gmel = gm (k)*elsq @@ -1778,7 +1790,9 @@ SUBROUTINE mym_turbulence ( & !Use level 2.0 functions as in original MYNN sh(k) = sh(k) * qdiv - sm(k) = Prnum*sh(k) + sm(k) = sm(k) * qdiv + !Or, use the simple Pr relationship + !sm(k) = Prnum*sh(k) !Recalculate terms for later use !JOE-Canuto/Kitamura mod @@ -1811,19 +1825,19 @@ SUBROUTINE mym_turbulence ( & qdiv = 1.0 !Use level 2.5 stability functions - !sm(k) = q3sq*a1*( e3-3.0*c1*e4 )/eden + sm(k) = q3sq*a1*( e3-3.0*c1*e4 )/eden !!JOE-Canuto/Kitamura mod !!sh(k) = q3sq*a2*( e2+3.0*c1*e5c*gmel )/eden sh(k) = q3sq*(a2*a2fac)*( e2+3.0*c1*e5c*gmel )/eden - sm(k) = Prnum*sh(k) + !sm(k) = Prnum*sh(k) END IF !end Helfand & Labraga check !Impose broad limits on Sh and Sm: gmelq = MAX(gmel/q3sq, 1e-8) - sm25max = MIN(sm20*3.0, SQRT(.1936/gmelq)) - sh25max = MIN(sh20*3.0, 0.76*b2) - sm25min = 0.0 - sh25min = 0.0 + sm25max = 10. !MIN(sm20*3.0, SQRT(.1936/gmelq)) + sh25max = 10. !MIN(sh20*3.0, 0.76*b2) + sm25min = 0.0 !MAX(sm20*0.1, 1e-6) + sh25min = 0.0 !MAX(sh20*0.1, 1e-6) !JOE: Level 2.5 debug prints ! HL88 , lev2.5 criteria from eqs. 3.17, 3.19, & 3.20 @@ -1843,12 +1857,13 @@ SUBROUTINE mym_turbulence ( & ENDIF ENDIF - !Enforce additional constraints for level 2.5 functions + !Enforce constraints for level 2.5 functions IF ( sh(k) > sh25max ) sh(k) = sh25max IF ( sh(k) < sh25min ) sh(k) = sh25min !IF ( sm(k) > sm25max ) sm(k) = sm25max !IF ( sm(k) < sm25min ) sm(k) = sm25min - sm(k) = Prnum*sh(k) + !sm(k) = Prnum*sh(k) + sm(k) = MIN(sm(k), Prlimit*Sh(k)) ! ** Level 3 : start ** IF ( closure .GE. 3.0 ) THEN @@ -2241,10 +2256,10 @@ SUBROUTINE mym_predict (kts,kte, & !stability criteria for mf DO k=kts+1,kte-1 - kqdz(k) = MAX(kqdz(k), 0.5*rho(k)* s_aw(k)) - kqdz(k) = MAX(kqdz(k), -0.5*rho(k)*(s_aw(k)-s_aw(k+1))) - kmdz(k) = MAX(kmdz(k), 0.5*rho(k)* s_aw(k)) - kmdz(k) = MAX(kmdz(k), -0.5*rho(k)*(s_aw(k)-s_aw(k+1))) + kqdz(k) = MAX(kqdz(k), 0.5* s_aw(k)) + kqdz(k) = MAX(kqdz(k), -0.5*(s_aw(k)-s_aw(k+1))) + kmdz(k) = MAX(kmdz(k), 0.5* s_aw(k)) + kmdz(k) = MAX(kmdz(k), -0.5*(s_aw(k)-s_aw(k+1))) ENDDO !JOE-end conservation mods @@ -2290,11 +2305,15 @@ SUBROUTINE mym_predict (kts,kte, & ! c(k)= - dtz(k)*df3q(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff ! d(k)=rp(k)*delt + qke(k) + dtz(k)*(s_awqke(k)-s_awqke(k+1))*onoff !JOE 8/22/20 improve conservation - a(k)= - dtz(k)*kqdz(k)*rhoinv(k) + 0.5*dtz(k)*s_aw(k)*onoff - b(k)=1. + dtz(k)*(kqdz(k)+kqdz(k+1))*rhoinv(k) & - & + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*onoff + bp(k)*delt - c(k)= - dtz(k)*kqdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*onoff - d(k)=rp(k)*delt + qke(k) + dtz(k)*(s_awqke(k)-s_awqke(k+1))*onoff + a(k)= - dtz(k)*kqdz(k)*rhoinv(k) & + & + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*onoff + b(k)=1. + dtz(k)*(kqdz(k)+kqdz(k+1))*rhoinv(k) & + & + 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*onoff & + & + bp(k)*delt + c(k)= - dtz(k)*kqdz(k+1)*rhoinv(k) & + & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff + d(k)=rp(k)*delt + qke(k) & + & + dtz(k)*rhoinv(k)*(s_awqke(k)-s_awqke(k+1))*onoff ENDDO !! DO k=kts+1,kte-1 @@ -2331,14 +2350,22 @@ SUBROUTINE mym_predict (kts,kte, & tke_up=0.5*qke dzinv=1./dz k=kts - qWT1D(k)=dzinv(k)*((kqdz(k+1)*(tke_up(k+1)-tke_up(k))-kqdz(k)*tke_up(k))+& - 0.5*(s_aw(k+1)*tke_up(k+1)+(s_aw(k+1)-s_aw(k))*tke_up(k)+(s_awqke(k)-s_awqke(k+1)))*onoff) !unstaggered + qWT1D(k)=dzinv(k)*( & + & (kqdz(k+1)*(tke_up(k+1)-tke_up(k))-kqdz(k)*tke_up(k)) & + & + 0.5*rhoinv(k)*(s_aw(k+1)*tke_up(k+1) & + & + (s_aw(k+1)-s_aw(k))*tke_up(k) & + & + (s_awqke(k)-s_awqke(k+1)))*onoff) !unstaggered DO k=kts+1,kte-1 - qWT1D(k)=dzinv(k)*((kqdz(k+1)*(tke_up(k+1)-tke_up(k))-kqdz(k)*(tke_up(k)-tke_up(k-1)))+& - 0.5*(s_aw(k+1)*tke_up(k+1)+(s_aw(k+1)-s_aw(k))*tke_up(k)-s_aw(k)*tke_up(k-1)+(s_awqke(k)-s_awqke(k+1)))*onoff) !unstaggered + qWT1D(k)=dzinv(k)*( & + & (kqdz(k+1)*(tke_up(k+1)-tke_up(k))-kqdz(k)*(tke_up(k)-tke_up(k-1))) & + & + 0.5*rhoinv(k)*(s_aw(k+1)*tke_up(k+1) & + & + (s_aw(k+1)-s_aw(k))*tke_up(k) & + & - s_aw(k)*tke_up(k-1) & + & + (s_awqke(k)-s_awqke(k+1)))*onoff) !unstaggered ENDDO k=kte - qWT1D(k)=dzinv(k)*(-kqdz(k)*(tke_up(k)-tke_up(k-1))+0.5*(-s_aw(k)*tke_up(k)-s_aw(k)*tke_up(k-1)+s_awqke(k))*onoff) !unstaggered + qWT1D(k)=dzinv(k)*(-kqdz(k)*(tke_up(k)-tke_up(k-1)) & + & + 0.5*rhoinv(k)*(-s_aw(k)*tke_up(k)-s_aw(k)*tke_up(k-1)+s_awqke(k))*onoff) !unstaggared !! >> EOBvt qDISS1D=bp*tke_up !! TKE dissipation rate !unstaggered END IF @@ -2602,7 +2629,7 @@ SUBROUTINE mym_condensation (kts,kte, & !variables for SGS BL clouds REAL :: zagl,damp,PBLH2 REAL :: lfac - INTEGER, PARAMETER :: sig_order = 1 !sigma form, 1: use state variables, 2: higher-order variables + INTEGER, PARAMETER :: sig_order = 2 !sigma form, 1: use state variables, 2: higher-order variables !JAYMES: variables for tropopause-height estimation REAL :: theta1, theta2, ht1, ht2 @@ -2953,14 +2980,14 @@ SUBROUTINE mym_condensation (kts,kte, & !use a simple temperature-dependent partitioning. IF ( qc(k) + qi(k) > 0.0 ) THEN ! explicit condensate exists, retain its phase partitioning IF ( qi(k) == 0.0 ) THEN ! explicit contains no ice; assume subgrid liquid - liq_frac = 1.0 + liq_frac = 1.0 ELSE IF ( qc(k) == 0.0 ) THEN ! explicit contains no liquid; assume subgrid ice liq_frac = 0.0 ELSE IF ( (qc(k) >= 1.E-10) .AND. (qi(k) >= 1.E-10) ) THEN ! explicit contains mixed phase of workably ! large amounts; assume subgrid follows ! same partioning liq_frac = qc(k) / ( qc(k) + qi(k) ) - ELSE + ELSE liq_frac = MIN(1.0, MAX(0.0, (t-238.)/31.)) ! explicit contains mixed phase, but at least one ! species is very small, so make a temperature- ! depedent guess @@ -3144,7 +3171,7 @@ SUBROUTINE mynn_tendencies(kts,kte, & !local vars - REAL, DIMENSION(kts:kte) :: dtz,dfhc,dfmc !Kh for clouds (Pr < 2) + REAL, DIMENSION(kts:kte) :: dtz,dfhc,dfmc,delp REAL, DIMENSION(kts:kte) :: sqv2,sqc2,sqi2,sqw2,qni2,qnc2, & !AFTER MIXING qnwfa2,qnifa2,ozone2 REAL, DIMENSION(kts:kte) :: zfac,plumeKh,rhoinv @@ -3155,6 +3182,7 @@ SUBROUTINE mynn_tendencies(kts,kte, & REAL :: grav_settling2,vdfg1 !Katata-fogdes REAL :: t,esat,qsl,onoff,kh,km,dzk,rhosfc REAL :: ustdrag,ustdiff + REAL :: th_new,portion_qc,portion_qi,condensate,qsat INTEGER :: k,kk !Activate nonlocal mixing from the mass-flux scheme for @@ -3180,6 +3208,7 @@ SUBROUTINE mynn_tendencies(kts,kte, & rhoinv(kts)=1./rho(kts) khdz(kts) =rhoz(kts)*dfh(kts) kmdz(kts) =rhoz(kts)*dfm(kts) + delp(kts) = psfc - (p(kts+1)*dz(kts) + p(kts)*dz(kts+1))/(dz(kts)+dz(kts+1)) DO k=kts+1,kte dtz(k) =delt/dz(k) rhoz(k) =(rho(k)*dz(k-1) + rho(k-1)*dz(k))/(dz(k-1)+dz(k)) @@ -3189,16 +3218,21 @@ SUBROUTINE mynn_tendencies(kts,kte, & khdz(k) = rhoz(k)*dfh(k) kmdz(k) = rhoz(k)*dfm(k) ENDDO + DO k=kts+1,kte-1 + delp(k) = (p(k)*dz(k-1) + p(k-1)*dz(k))/(dz(k)+dz(k-1)) - & + (p(k+1)*dz(k) + p(k)*dz(k+1))/(dz(k)+dz(k+1)) + ENDDO + delp(kte) =delp(kte-1) rhoz(kte+1)=rhoz(kte) khdz(kte+1)=rhoz(kte+1)*dfh(kte) kmdz(kte+1)=rhoz(kte+1)*dfm(kte) !stability criteria for mf DO k=kts+1,kte-1 - khdz(k) = MAX(khdz(k), 0.5*rho(k)* s_aw(k)) - khdz(k) = MAX(khdz(k), -0.5*rho(k)*(s_aw(k)-s_aw(k+1))) - kmdz(k) = MAX(kmdz(k), 0.5*rho(k)* s_aw(k)) - kmdz(k) = MAX(kmdz(k), -0.5*rho(k)*(s_aw(k)-s_aw(k+1))) + khdz(k) = MAX(khdz(k), 0.5*s_aw(k)) + khdz(k) = MAX(khdz(k), -0.5*(s_aw(k)-s_aw(k+1))) + kmdz(k) = MAX(kmdz(k), 0.5*s_aw(k)) + kmdz(k) = MAX(kmdz(k), -0.5*(s_aw(k)-s_aw(k+1))) ENDDO ustdrag = MIN(ust*ust,0.99)/wspd ! limit at ~ 20 m/s @@ -3226,18 +3260,18 @@ SUBROUTINE mynn_tendencies(kts,kte, & !rho-weighted with drag term moved out of b-array a(k)= -dtz(k)*kmdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(kmdz(k+1))*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*sd_aw(k+1)*onoff - c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*sd_aw(k+1)*onoff + b(k)=1.+dtz(k)*(kmdz(k+1))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff + c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff d(k)=u(k)*(1.-ust**2/wspd*dtz(k)*rhosfc/rho(k)) + dtz(k)*uoce*ust**2/wspd - & !d(k)=u(k)*(1.-ust**2/wspd*dtz(k)) + dtz(k)*uoce*ust**2/wspd - & - & dtz(k)*s_awu(k+1)*onoff - dtz(k)*sd_awu(k+1)*onoff + sub_u(k)*delt + det_u(k)*delt + & dtz(k)*rhoinv(k)*s_awu(k+1)*onoff - dtz(k)*rhoinv(k)*sd_awu(k+1)*onoff + sub_u(k)*delt + det_u(k)*delt DO k=kts+1,kte-1 - a(k)= -dtz(k)*kmdz(k)*rhoinv(k) + 0.5*dtz(k)*s_aw(k)*onoff + 0.5*dtz(k)*sd_aw(k)*onoff + a(k)= -dtz(k)*kmdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*onoff + 0.5*dtz(k)*rhoinv(k)*sd_aw(k)*onoff b(k)=1.+dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*onoff + 0.5*dtz(k)*(sd_aw(k)-sd_aw(k+1))*onoff - c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*sd_aw(k+1)*onoff - d(k)=u(k) + dtz(k)*(s_awu(k)-s_awu(k+1))*onoff + dtz(k)*(sd_awu(k)-sd_awu(k+1))*onoff + & + & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*onoff + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1))*onoff + c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff + d(k)=u(k) + dtz(k)*rhoinv(k)*(s_awu(k)-s_awu(k+1))*onoff + dtz(k)*rhoinv(k)*(sd_awu(k)-sd_awu(k+1))*onoff + & & sub_u(k)*delt + det_u(k)*delt ENDDO @@ -3289,18 +3323,18 @@ SUBROUTINE mynn_tendencies(kts,kte, & !rho-weighted with drag term moved out of b-array a(k)= -dtz(k)*kmdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(kmdz(k+1))*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*sd_aw(k+1)*onoff - c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*sd_aw(k+1)*onoff + b(k)=1.+dtz(k)*(kmdz(k+1))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff + c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff d(k)=v(k)*(1.-ust**2/wspd*dtz(k)*rhosfc/rho(k)) + dtz(k)*voce*ust**2/wspd - & !d(k)=v(k)*(1.-ust**2/wspd*dtz(k)) + dtz(k)*voce*ust**2/wspd - & - & dtz(k)*s_awv(k+1)*onoff - dtz(k)*sd_awv(k+1)*onoff + sub_v(k)*delt + det_v(k)*delt + & dtz(k)*rhoinv(k)*s_awv(k+1)*onoff - dtz(k)*rhoinv(k)*sd_awv(k+1)*onoff + sub_v(k)*delt + det_v(k)*delt DO k=kts+1,kte-1 - a(k)= -dtz(k)*kmdz(k)*rhoinv(k) + 0.5*dtz(k)*s_aw(k)*onoff + 0.5*dtz(k)*sd_aw(k)*onoff + a(k)= -dtz(k)*kmdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*onoff + 0.5*dtz(k)*rhoinv(k)*sd_aw(k)*onoff b(k)=1.+dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*onoff + 0.5*dtz(k)*(sd_aw(k)-sd_aw(k+1))*onoff - c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*sd_aw(k+1)*onoff - d(k)=v(k) + dtz(k)*(s_awv(k)-s_awv(k+1))*onoff + dtz(k)*(sd_awv(k)-sd_awv(k+1))*onoff + & + & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*onoff + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1))*onoff + c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff + d(k)=v(k) + dtz(k)*rhoinv(k)*(s_awv(k)-s_awv(k+1))*onoff + dtz(k)*rhoinv(k)*(sd_awv(k)-sd_awv(k+1))*onoff + & & sub_v(k)*delt + det_v(k)*delt ENDDO @@ -3354,18 +3388,18 @@ SUBROUTINE mynn_tendencies(kts,kte, & !rho-weighted: a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) - 0.5*dtz(k)*sd_aw(k+1) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) - 0.5*dtz(k)*sd_aw(k+1) - d(k)=thl(k) + dtz(k)*flt + tcd(k)*delt - dtz(k)*s_awthl(k+1) -dtz(k)*sd_awthl(k+1) + & + b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) + d(k)=thl(k) + dtz(k)*flt + tcd(k)*delt - dtz(k)*rhoinv(k)*s_awthl(k+1) -dtz(k)*rhoinv(k)*sd_awthl(k+1) + & & diss_heat(k)*delt*dheat_opt + sub_thl(k)*delt + det_thl(k)*delt DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*s_aw(k) + 0.5*dtz(k)*sd_aw(k) + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k) + 0.5*dtz(k)*rhoinv(k)*sd_aw(k) b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) + 0.5*dtz(k)*(sd_aw(k)-sd_aw(k+1)) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) - 0.5*dtz(k)*sd_aw(k+1) + & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1)) + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1)) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) d(k)=thl(k) + tcd(k)*delt + & - & dtz(k)*(s_awthl(k)-s_awthl(k+1)) + dtz(k)*(sd_awthl(k)-sd_awthl(k+1)) + & + & dtz(k)*rhoinv(k)*(s_awthl(k)-s_awthl(k+1)) + dtz(k)*rhoinv(k)*(sd_awthl(k)-sd_awthl(k+1)) + & & diss_heat(k)*delt*dheat_opt + & & sub_thl(k)*delt + det_thl(k)*delt ENDDO @@ -3423,16 +3457,16 @@ SUBROUTINE mynn_tendencies(kts,kte, & !rho-weighted: a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) - 0.5*dtz(k)*sd_aw(k+1) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) - 0.5*dtz(k)*sd_aw(k+1) - d(k)=sqw(k) + dtz(k)*flq + qcd(k)*delt - dtz(k)*s_awqt(k+1) - dtz(k)*sd_awqt(k+1) + b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) + d(k)=sqw(k) + dtz(k)*flq + qcd(k)*delt - dtz(k)*rhoinv(k)*s_awqt(k+1) - dtz(k)*rhoinv(k)*sd_awqt(k+1) DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*s_aw(k) + 0.5*dtz(k)*sd_aw(k) + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k) + 0.5*dtz(k)*rhoinv(k)*sd_aw(k) b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) + 0.5*dtz(k)*(sd_aw(k)-sd_aw(k+1)) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) - 0.5*dtz(k)*sd_aw(k+1) - d(k)=sqw(k) + qcd(k)*delt + dtz(k)*(s_awqt(k)-s_awqt(k+1)) + dtz(k)*(sd_awqt(k)-sd_awqt(k+1)) + & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1)) + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1)) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) + d(k)=sqw(k) + qcd(k)*delt + dtz(k)*rhoinv(k)*(s_awqt(k)-s_awqt(k+1)) + dtz(k)*rhoinv(k)*(sd_awqt(k)-sd_awqt(k+1)) ENDDO !! no flux at the top @@ -3488,17 +3522,17 @@ SUBROUTINE mynn_tendencies(kts,kte, & !rho-weighted: a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) - 0.5*dtz(k)*sd_aw(k+1) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) - 0.5*dtz(k)*sd_aw(k+1) - d(k)=sqc(k) + dtz(k)*flqc + qcd(k)*delt - dtz(k)*s_awqc(k+1) - dtz(k)*sd_awqc(k+1) + & + b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) + d(k)=sqc(k) + dtz(k)*flqc + qcd(k)*delt - dtz(k)*rhoinv(k)*s_awqc(k+1) - dtz(k)*rhoinv(k)*sd_awqc(k+1) + & & det_sqc(k)*delt DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*s_aw(k) + 0.5*dtz(k)*sd_aw(k) + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k) + 0.5*dtz(k)*rhoinv(k)*sd_aw(k) b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) + 0.5*dtz(k)*(sd_aw(k)-sd_aw(k+1)) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) - 0.5*dtz(k)*sd_aw(k+1) - d(k)=sqc(k) + qcd(k)*delt + dtz(k)*(s_awqc(k)-s_awqc(k+1)) + dtz(k)*(sd_awqc(k)-sd_awqc(k+1)) + & + & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1)) + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1)) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) + d(k)=sqc(k) + qcd(k)*delt + dtz(k)*rhoinv(k)*(s_awqc(k)-s_awqc(k+1)) + dtz(k)*rhoinv(k)*(sd_awqc(k)-sd_awqc(k+1)) + & & det_sqc(k)*delt ENDDO @@ -3545,17 +3579,17 @@ SUBROUTINE mynn_tendencies(kts,kte, & !rho-weighted: a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) - 0.5*dtz(k)*sd_aw(k+1) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) - 0.5*dtz(k)*sd_aw(k+1) - d(k)=sqv(k) + dtz(k)*flqv + qcd(k)*delt - dtz(k)*s_awqv(k+1) - dtz(k)*sd_awqv(k+1) + & + b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) + d(k)=sqv(k) + dtz(k)*flqv + qcd(k)*delt - dtz(k)*rhoinv(k)*s_awqv(k+1) - dtz(k)*rhoinv(k)*sd_awqv(k+1) + & & sub_sqv(k)*delt + det_sqv(k)*delt DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*s_aw(k) + 0.5*dtz(k)*sd_aw(k) + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k) + 0.5*dtz(k)*rhoinv(k)*sd_aw(k) b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) + 0.5*dtz(k)*(sd_aw(k)-sd_aw(k+1)) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) - 0.5*dtz(k)*sd_aw(k+1) - d(k)=sqv(k) + qcd(k)*delt + dtz(k)*(s_awqv(k)-s_awqv(k+1)) + dtz(k)*(sd_awqv(k)-sd_awqv(k+1)) + & + & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1)) + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1)) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) + d(k)=sqv(k) + qcd(k)*delt + dtz(k)*rhoinv(k)*(s_awqv(k)-s_awqv(k+1)) + dtz(k)*rhoinv(k)*(sd_awqv(k)-sd_awqv(k+1)) + & & sub_sqv(k)*delt + det_sqv(k)*delt ENDDO @@ -3660,16 +3694,16 @@ SUBROUTINE mynn_tendencies(kts,kte, & k=kts a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*nonloc - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*nonloc - d(k)=qni(k) - dtz(k)*s_awqni(k+1)*nonloc + b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + d(k)=qni(k) - dtz(k)*rhoinv(k)*s_awqni(k+1)*nonloc DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*s_aw(k)*nonloc + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*nonloc b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*nonloc - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*nonloc - d(k)=qni(k) + dtz(k)*(s_awqni(k)-s_awqni(k+1))*nonloc + & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*nonloc + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + d(k)=qni(k) + dtz(k)*rhoinv(k)*(s_awqni(k)-s_awqni(k+1))*nonloc ENDDO !! prescribed value @@ -3701,16 +3735,16 @@ SUBROUTINE mynn_tendencies(kts,kte, & k=kts a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*nonloc - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*nonloc - d(k)=qnc(k) - dtz(k)*s_awqnc(k+1)*nonloc + b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + d(k)=qnc(k) - dtz(k)*rhoinv(k)*s_awqnc(k+1)*nonloc DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*s_aw(k)*nonloc + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*nonloc b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*nonloc - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*nonloc - d(k)=qnc(k) + dtz(k)*(s_awqnc(k)-s_awqnc(k+1))*nonloc + & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*nonloc + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + d(k)=qnc(k) + dtz(k)*rhoinv(k)*(s_awqnc(k)-s_awqnc(k+1))*nonloc ENDDO !! prescribed value @@ -3742,16 +3776,16 @@ SUBROUTINE mynn_tendencies(kts,kte, & a(k)= -dtz(k)*khdz(k)*rhoinv(k) b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) - & - & 0.5*dtz(k)*s_aw(k+1)*nonloc - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*nonloc - d(k)=qnwfa(k) - dtz(k)*s_awqnwfa(k+1)*nonloc + & 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + d(k)=qnwfa(k) - dtz(k)*rhoinv(k)*s_awqnwfa(k+1)*nonloc DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*s_aw(k)*nonloc + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*nonloc b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*nonloc - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*nonloc - d(k)=qnwfa(k) + dtz(k)*(s_awqnwfa(k)-s_awqnwfa(k+1))*nonloc + & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*nonloc + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + d(k)=qnwfa(k) + dtz(k)*rhoinv(k)*(s_awqnwfa(k)-s_awqnwfa(k+1))*nonloc ENDDO ! prescribed value @@ -3784,16 +3818,16 @@ SUBROUTINE mynn_tendencies(kts,kte, & a(k)= -dtz(k)*khdz(k)*rhoinv(k) b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) - & - & 0.5*dtz(k)*s_aw(k+1)*nonloc - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*nonloc - d(k)=qnifa(k) - dtz(k)*s_awqnifa(k+1)*nonloc + & 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + d(k)=qnifa(k) - dtz(k)*rhoinv(k)*s_awqnifa(k+1)*nonloc DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*s_aw(k)*nonloc + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*nonloc b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*nonloc - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*nonloc - d(k)=qnifa(k) + dtz(k)*(s_awqnifa(k)-s_awqnifa(k+1))*nonloc + & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*nonloc + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + d(k)=qnifa(k) + dtz(k)*rhoinv(k)*(s_awqnifa(k)-s_awqnifa(k+1))*nonloc ENDDO ! prescribed value @@ -3855,45 +3889,45 @@ SUBROUTINE mynn_tendencies(kts,kte, & !! Note that the momentum tendencies are calculated above. !!============================================ - IF (bl_mynn_mixqt > 0) THEN + IF (bl_mynn_mixqt > 0) THEN DO k=kts,kte - t = th(k)*exner(k) + !compute updated theta using updated thl and old condensate + th_new = thl(k) + xlvcp/exner(k)*sqc(k) & + & + xlscp/exner(k)*sqi(k) + + t = th_new*exner(k) + qsat = qsat_blend(t,p(k)) !SATURATED VAPOR PRESSURE - esat=esat_blend(t) + !esat=esat_blend(t) !SATURATED SPECIFIC HUMIDITY !qsl=ep_2*esat/(p(k)-ep_3*esat) - qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) - - !IF (qsl >= sqw2(k)) THEN !unsaturated - ! sqv2(k) = MAX(0.0,sqw2(k)) - ! sqi2(k) = MAX(0.0,sqi2(k)) - ! sqc2(k) = MAX(0.0,sqw2(k) - sqv2(k) - sqi2(k)) - !ELSE !saturated - IF (FLAG_QI) THEN - !sqv2(k) = qsl - sqi2(k) = MAX(0., sqi2(k)) - sqc2(k) = MAX(0., sqw2(k) - sqi2(k) - qsl) !updated cloud water - sqv2(k) = MAX(0., sqw2(k) - sqc2(k) - sqi2(k)) !updated water vapor - ELSE - !sqv2(k) = qsl - sqi2(k) = 0.0 - sqc2(k) = MAX(0., sqw2(k) - qsl) !updated cloud water - sqv2(k) = MAX(0., sqw2(k) - sqc2(k)) ! updated water vapor - ENDIF - !ENDIF + !qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) + + IF (sqc(k) > 0.0 .or. sqi(k) > 0.0) THEN !initially saturated + sqv2(k) = MIN(sqw2(k),qsat) + portion_qc = sqc(k)/(sqc(k) + sqi(k)) + portion_qi = sqi(k)/(sqc(k) + sqi(k)) + condensate = MAX(sqw2(k) - qsat, 0.0) + sqc2(k) = condensate*portion_qc + sqi2(k) = condensate*portion_qi + ELSE ! initially unsaturated ----- + sqv2(k) = sqw2(k) ! let microphys decide what to do + sqi2(k) = 0.0 ! if sqw2 > qsat + sqc2(k) = 0.0 + ENDIF + !dqv(k) = (sqv2(k) - sqv(k))/delt + !dqc(k) = (sqc2(k) - sqc(k))/delt + !dqi(k) = (sqi2(k) - sqi(k))/delt ENDDO - ENDIF + ENDIF + !===================== ! WATER VAPOR TENDENCY !===================== DO k=kts,kte - !Dqv(k)=(sqv2(k)/(1.-sqv2(k)) - qv(k))/delt !mixing ratio - Dqv(k)=(sqv2(k) - sqv(k))/delt !spec humidity - IF(Dqv(k)*delt + sqv(k) < 0.) THEN - !print*,' neg qv:',qsl,sqv(k),sqv2(k),sqc(k),sqi(k),tk(k) - Dqv(k)=-sqv(k)*0.99/delt - ENDIF + Dqv(k)=(sqv2(k)/(1.-sqv2(k)) - qv(k))/delt + !if (sqv2(k) < 0.0)print*,"neg qv:",sqv2(k),k ENDDO IF (bl_mynn_cloudmix > 0) THEN @@ -3905,12 +3939,8 @@ SUBROUTINE mynn_tendencies(kts,kte, & !print*,"FLAG_QC:",FLAG_QC IF (FLAG_QC) THEN DO k=kts,kte - !Dqc(k)=(sqc2(k)/(1.-sqv2(k)) - qc(k))/delt !mixing ratio - Dqc(k)=(sqc2(k) - sqc(k))/delt !spec humidity - IF(Dqc(k)*delt + sqc(k) < 0.) THEN - !print*,' neg qc:',qsl,sqw2(k),sqi2(k),sqc2(k),qc(k),tk(k) - Dqc(k)=-sqc(k)/delt - ENDIF + Dqc(k)=(sqc2(k)/(1.-sqv2(k)) - qc(k))/delt + !if (sqc2(k) < 0.0)print*,"neg qc:",sqc2(k),k ENDDO ELSE DO k=kts,kte @@ -3923,7 +3953,6 @@ SUBROUTINE mynn_tendencies(kts,kte, & !=================== IF (FLAG_QNC .AND. bl_mynn_mixscalars > 0) THEN DO k=kts,kte - !IF(sqc2(k)>1.e-9)qnc2(k)=MAX(qnc2(k),1.e6) Dqnc(k) = (qnc2(k)-qnc(k))/delt !IF(Dqnc(k)*delt + qnc(k) < 0.)Dqnc(k)=-qnc(k)/delt ENDDO @@ -3938,12 +3967,8 @@ SUBROUTINE mynn_tendencies(kts,kte, & !=================== IF (FLAG_QI) THEN DO k=kts,kte - !Dqi(k)=(sqi2(k)/(1.-sqv2(k)) - qi(k))/delt !mixing ratio - Dqi(k)=(sqi2(k) - sqi(k))/delt !spec humidity - IF(Dqi(k)*delt + sqi(k) < 0.) THEN - ! !print*,' neg qi;',qsl,sqw2(k),sqi2(k),sqc2(k),qi(k),tk(k) - Dqi(k)=-sqi(k)/delt - ENDIF + Dqi(k)=(sqi2(k)/(1.-sqv2(k)) - qi(k))/delt + !if (sqi2(k) < 0.0)print*,"neg qi:",sqi2(k),k ENDDO ELSE DO k=kts,kte @@ -3974,6 +3999,11 @@ SUBROUTINE mynn_tendencies(kts,kte, & ENDDO ENDIF + !ensure non-negative moist species + CALL moisture_check(kte, delt, delp, exner, & + sqv2, sqc2, sqi2, thl, & + dqv, dqc, dqi, dth ) + !===================== ! OZONE TENDENCY CHECK !===================== @@ -3988,8 +4018,8 @@ SUBROUTINE mynn_tendencies(kts,kte, & !=================== IF (FLAG_QI) THEN DO k=kts,kte - Dth(k)=(thl(k) + xlvcp/exner(k)*sqc(k) & - & + xlscp/exner(k)*sqi(k) & + Dth(k)=(thl(k) + xlvcp/exner(k)*sqc2(k) & + & + xlscp/exner(k)*sqi2(k) & & - th(k))/delt !Use form from Tripoli and Cotton (1981) with their !suggested min temperature to improve accuracy: @@ -3999,7 +4029,7 @@ SUBROUTINE mynn_tendencies(kts,kte, & ENDDO ELSE DO k=kts,kte - Dth(k)=(thl(k)+xlvcp/exner(k)*sqc(k) - th(k))/delt + Dth(k)=(thl(k)+xlvcp/exner(k)*sqc2(k) - th(k))/delt !Use form from Tripoli and Cotton (1981) with their !suggested min temperature to improve accuracy. !Dth(k)=(thl(k)*(1.+ xlvcp/MAX(tk(k),TKmin)*sqc(k)) & @@ -4029,6 +4059,13 @@ SUBROUTINE mynn_tendencies(kts,kte, & ENDDO ENDIF + !ensure non-negative moist species + !note: if called down here, dth needs to be updated, but + ! if called before the theta-tendency calculation, do not compute dth + !CALL moisture_check(kte, delt, delp, exner, & + ! sqv, sqc, sqi, thl, & + ! dqv, dqc, dqi, dth ) + #ifdef HARDCODE_VERTICAL # undef kts # undef kte @@ -4036,6 +4073,92 @@ SUBROUTINE mynn_tendencies(kts,kte, & END SUBROUTINE mynn_tendencies +! ================================================================== + SUBROUTINE moisture_check(kte, delt, dp, exner, & + qv, qc, qi, th, & + dqv, dqc, dqi, dth ) + + ! This subroutine was adopted from the CAM-UW ShCu scheme and + ! adapted for use here. + ! + ! If qc < qcmin, qi < qimin, or qv < qvmin happens in any layer, + ! force them to be larger than minimum value by (1) condensating + ! water vapor into liquid or ice, and (2) by transporting water vapor + ! from the very lower layer. + ! + ! We then update the final state variables and tendencies associated + ! with this correction. If any condensation happens, update theta too. + ! Note that (qv,qc,qi,th) are the final state variables after + ! applying corresponding input tendencies and corrective tendencies. + + implicit none + integer, intent(in) :: kte + real, intent(in) :: delt + real, dimension(kte), intent(in) :: dp, exner + real, dimension(kte), intent(inout) :: qv, qc, qi, th + real, dimension(kte), intent(inout) :: dqv, dqc, dqi, dth + integer k + real :: dqc2, dqi2, dqv2, sum, aa, dum + real, parameter :: qvmin = 1e-20, & + qcmin = 0.0, & + qimin = 0.0 + + do k = kte, 1, -1 ! From the top to the surface + dqc2 = max(0.0, qcmin-qc(k)) !qc deficit (>=0) + dqi2 = max(0.0, qimin-qi(k)) !qi deficit (>=0) + + !fix tendencies + dqc(k) = dqc(k) + dqc2/delt + dqi(k) = dqi(k) + dqi2/delt + dqv(k) = dqv(k) - (dqc2+dqi2)/delt + dth(k) = dth(k) + xlvcp/exner(k)*(dqc2/delt) + & + xlscp/exner(k)*(dqi2/delt) + !update species + qc(k) = qc(k) + dqc2 + qi(k) = qi(k) + dqi2 + qv(k) = qv(k) - dqc2 - dqi2 + th(k) = th(k) + xlvcp/exner(k)*dqc2 + & + xlscp/exner(k)*dqi2 + + !then fix qv + dqv2 = max(0.0, qvmin-qv(k)) !qv deficit (>=0) + dqv(k) = dqv(k) + dqv2/delt + qv(k) = qv(k) + dqv2 + if( k .ne. 1 ) then + qv(k-1) = qv(k-1) - dqv2*dp(k)/dp(k-1) + dqv(k-1) = dqv(k-1) - dqv2*dp(k)/dp(k-1)/delt + endif + qv(k) = max(qv(k),qvmin) + qc(k) = max(qc(k),qcmin) + qi(k) = max(qi(k),qimin) + end do + ! Extra moisture used to satisfy 'qv(1)>=qvmin' is proportionally + ! extracted from all the layers that has 'qv > 2*qvmin'. This fully + ! preserves column moisture. + if( dqv2 .gt. 1.e-20 ) then + sum = 0.0 + do k = 1, kte + if( qv(k) .gt. 2.0*qvmin ) sum = sum + qv(k)*dp(k) + enddo + aa = dqv2*dp(1)/max(1.e-20,sum) + if( aa .lt. 0.5 ) then + do k = 1, kte + if( qv(k) .gt. 2.0*qvmin ) then + dum = aa*qv(k) + qv(k) = qv(k) - dum + dqv(k) = dqv(k) - dum/delt + endif + enddo + else + ! For testing purposes only (not yet found in any output): + ! write(*,*) 'Full moisture conservation is impossible' + endif + endif + + return + + END SUBROUTINE moisture_check + ! ================================================================== #if (WRF_CHEM == 1) SUBROUTINE mynn_mix_chem(kts,kte,i, & @@ -4126,8 +4249,8 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & !stability criteria for mf DO k=kts+1,kte-1 - khdz(k) = MAX(khdz(k), 0.5*rho(k)* s_aw(k)) - khdz(k) = MAX(khdz(k), -0.5*rho(k)*(s_aw(k)-s_aw(k+1))) + khdz(k) = MAX(khdz(k), 0.5*s_aw(k)) + khdz(k) = MAX(khdz(k), -0.5*(s_aw(k)-s_aw(k+1))) khdz_old = khdz(k) khdz_back = pblh * 0.15 / dz(k) @@ -4152,18 +4275,18 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & k=kts a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) + b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) d(k)=chem1(k,ic) & !dtz(k)*flt !neglecting surface sources & + dtz(k) * -vd1(ic)*chem1(1,ic) & - & - dtz(k)*s_awchem(k+1,ic) + & - dtz(k)*rhoinv(k)*s_awchem(k+1,ic) DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*s_aw(k) + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k) b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) - d(k)=chem1(k,ic) + dtz(k)*(s_awchem(k,ic)-s_awchem(k+1,ic)) + & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1)) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) + d(k)=chem1(k,ic) + dtz(k)*rhoinv(k)*(s_awchem(k,ic)-s_awchem(k+1,ic)) ENDDO ! prescribed value at top @@ -4513,7 +4636,7 @@ SUBROUTINE mynn_bl_driver( & INTEGER :: i,j,k REAL, DIMENSION(KTS:KTE) :: thl,thvl,tl,qv1,qc1,qi1,sqw,& &El, Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc, & - &Vt, Vq, sgm, thlsg + &Vt, Vq, sgm, thlsg, sqwsg REAL, DIMENSION(KTS:KTE) :: thetav,sh,sm,u1,v1,w1,p1,ex1,dz1,th1,tk1,rho1,& & qke1,tsq1,qsq1,cov1,sqv,sqi,sqc,du1,dv1,dth1,dqv1,dqc1,dqi1,ozone1, & & k_m1,k_h1,qni1,dqni1,qnc1,dqnc1,qnwfa1,qnifa1,dqnwfa1,dqnifa1,dozone1 @@ -4549,6 +4672,9 @@ SUBROUTINE mynn_bl_driver( & REAL, DIMENSION( ims:ime, kms:kme), INTENT(IN),OPTIONAL ::pattern_spp_pbl REAL, DIMENSION(KTS:KTE) :: rstoch_col +! Substepping TKE + INTEGER :: nsub + real :: delt2 IF ( debug_code ) THEN print*,'in MYNN driver; at beginning' @@ -4673,6 +4799,7 @@ SUBROUTINE mynn_bl_driver( & w1(k) = w(i,k) th1(k)=th(i,k) tk1(k)=T3D(i,k) + ex1(k)=exner(i,k) rho1(k)=rho(i,k) sqc(k)=sqc3D(i,k) !/(1.+qv(i,k)) sqv(k)=sqv3D(i,k) !/(1.+qv(i,k)) @@ -4685,8 +4812,8 @@ SUBROUTINE mynn_bl_driver( & IF (PRESENT(sqi3D) .AND. FLAG_QI ) THEN sqi(k)=sqi3D(i,k) !/(1.+qv(i,k)) sqw(k)=sqv(k)+sqc(k)+sqi(k) - thl(k)=th(i,k)- xlvcp/exner(i,k)*sqc(k) & - & - xlscp/exner(i,k)*sqi(k) + thl(k)=th1(k) - xlvcp/ex1(k)*sqc(k) & + & - xlscp/ex1(k)*sqi(k) !Use form from Tripoli and Cotton (1981) with their !suggested min temperature to improve accuracy. !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) & @@ -4699,12 +4826,13 @@ SUBROUTINE mynn_bl_driver( & sqc9=sqc(k) sqi9=sqi(k) ENDIF - thlsg(k)=th(i,k)- xlvcp/exner(i,k)*sqc9 & - & - xlscp/exner(i,k)*sqi9 + thlsg(k)=th1(k) - xlvcp/ex1(k)*sqc9 & + & - xlscp/ex1(k)*sqi9 + sqwsg(k)=sqv(k)+sqc9+sqi9 ELSE sqi(k)=0.0 sqw(k)=sqv(k)+sqc(k) - thl(k)=th(i,k)-xlvcp/exner(i,k)*sqc(k) + thl(k)=th1(k)-xlvcp/ex1(k)*sqc(k) !Use form from Tripoli and Cotton (1981) with their !suggested min temperature to improve accuracy. !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k)) @@ -4716,8 +4844,9 @@ SUBROUTINE mynn_bl_driver( & sqc9=sqc(k) sqi9=0.0 ENDIF - thlsg(k)=th(i,k)- xlvcp/exner(i,k)*sqc9 & - & - xlscp/exner(i,k)*sqi9 + thlsg(k)=th1(k) - xlvcp/ex1(k)*sqc9 & + & - xlscp/ex1(k)*sqi9 + sqwsg(k)=sqv(k)+sqc9+sqi9 ENDIF thvl(k)=thlsg(k)*(1.+0.61*sqv(k)) @@ -4772,6 +4901,7 @@ SUBROUTINE mynn_bl_driver( & &kts,kte, & &dz1, dx(i), zw, & &u1, v1, thl, sqv, & + &thlsg, sqwsg, & &PBLH(i), th1, thetav, sh, sm, & &ust(i), rmol(i), & &el, Qke1, Tsq1, Qsq1, Cov1, & @@ -4848,6 +4978,8 @@ SUBROUTINE mynn_bl_driver( & w1(k) = w(i,k) th1(k)= th(i,k) tk1(k)=T3D(i,k) + p1(k) = p(i,k) + ex1(k)= exner(i,k) rho1(k)=rho(i,k) qv1(k)= sqv3D(i,k)/(1.-sqv3D(i,k)) qc1(k)= sqc3D(i,k)/(1.-sqv3D(i,k)) @@ -4864,8 +4996,8 @@ SUBROUTINE mynn_bl_driver( & qi1(k)= sqi3D(i,k)/(1.-sqv3D(i,k)) sqi(k)= sqi3D(i,k) !/(1.+qv(i,k)) sqw(k)= sqv(k)+sqc(k)+sqi(k) - thl(k)= th(i,k) - xlvcp/exner(i,k)*sqc(k) & - & - xlscp/exner(i,k)*sqi(k) + thl(k)= th1(k) - xlvcp/ex1(k)*sqc(k) & + & - xlscp/ex1(k)*sqi(k) !Use form from Tripoli and Cotton (1981) with their !suggested min temperature to improve accuracy. !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) & @@ -4878,13 +5010,14 @@ SUBROUTINE mynn_bl_driver( & sqc9=sqc(k) sqi9=sqi(k) ENDIF - thlsg(k)=th(i,k)- xlvcp/exner(i,k)*sqc9 & - & - xlscp/exner(i,k)*sqi9 + thlsg(k)=th1(k) - xlvcp/ex1(k)*sqc9 & + & - xlscp/ex1(k)*sqi9 + sqwsg(k)=sqv(k)+sqc9+sqi9 ELSE qi1(k)=0.0 sqi(k)=0.0 sqw(k)= sqv(k)+sqc(k) - thl(k)= th(i,k)-xlvcp/exner(i,k)*sqc(k) + thl(k)= th1(k)-xlvcp/ex1(k)*sqc(k) !Use form from Tripoli and Cotton (1981) with their !suggested min temperature to improve accuracy. !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k)) @@ -4896,10 +5029,10 @@ SUBROUTINE mynn_bl_driver( & sqc9=sqc(k) sqi9=0.0 ENDIF - thlsg(k)=th(i,k)- xlvcp/exner(i,k)*sqc9 & - & - xlscp/exner(i,k)*sqi9 + thlsg(k)=th1(k) - xlvcp/ex1(k)*sqc9 & + & - xlscp/ex1(k)*sqi9 ENDIF - thetav(k)=th(i,k)*(1.+0.608*sqv(k)) + thetav(k)=th1(k)*(1.+0.608*sqv(k)) thvl(k) =thlsg(k) *(1.+0.608*sqv(k)) IF (PRESENT(qni) .AND. FLAG_QNI ) THEN @@ -4927,8 +5060,6 @@ SUBROUTINE mynn_bl_driver( & ELSE ozone1(k)=0.0 ENDIF - p1(k) = p(i,k) - ex1(k)= exner(i,k) el(k) = el_pbl(i,k) qke1(k)=qke(i,k) sh(k) = sh3d(i,k) @@ -4941,7 +5072,6 @@ SUBROUTINE mynn_bl_driver( & rstoch_col(k)=0.0 endif - !edmf edmf_a1(k)=0.0 edmf_w1(k)=0.0 @@ -5083,7 +5213,7 @@ SUBROUTINE mynn_bl_driver( & ! TURBULENT FLUX FOR TKE BOUNDARY CONDITIONS flq =flqv+flqc !! LATENT - flt =hfx(i)/(rho1(kts)*cpm )-xlvcp*flqc/exner(i,kts) !! Temperature flux + flt =hfx(i)/(rho1(kts)*cpm )-xlvcp*flqc/ex1(kts) !! Temperature flux fltv=flt + flqv*ep_1*th_sfc !! Virtual temperature flux ! Update 1/L using updated sfc heat flux and friction velocity @@ -5137,9 +5267,9 @@ SUBROUTINE mynn_bl_driver( & ENDIF IF (bl_mynn_edmf > 0) THEN - !PRINT*,"Calling DMP Mass-Flux: i= ",i," j=" + !PRINT*,"Calling DMP Mass-Flux: i= ",i CALL DMP_mf( & - &kts,kte,delt,zw,dz1,p1, & + &kts,kte,delt,zw,dz1,p1,rho1, & &bl_mynn_edmf_mom, & &bl_mynn_edmf_tke, & &bl_mynn_mixscalars, & @@ -5196,12 +5326,15 @@ SUBROUTINE mynn_bl_driver( & &rthraten(i,:) ) ENDIF -!> - Call mym_turbulence() to collect the necessary variable -!! to carry out successive claculations. + !Capability to substep the eddy-diffusivity portion + !do nsub = 1,2 + delt2 = delt !*0.5 !only works if topdown=0 + CALL mym_turbulence ( & &kts,kte,closure, & &dz1, DX(i), zw, & &u1, v1, thl, thetav, sqc, sqw, & + &thlsg, sqwsg, & &qke1, tsq1, qsq1, cov1, & &vt, vq, & &rmol(i), flt, flq, & @@ -5222,7 +5355,7 @@ SUBROUTINE mynn_bl_driver( & !! \f$\theta^{'2}, q^{'2}, and \theta^{'}q^{'}\f$ !! for the following time step. CALL mym_predict (kts,kte,closure, & - &delt, dz1, & + &delt2, dz1, & &ust(i), flt, flq, pmz, phh, & &el, dfq, rho1, pdk, pdt, pdq, pdc,& &Qke1, Tsq1, Qsq1, Cov1, & @@ -5345,14 +5478,12 @@ SUBROUTINE mynn_bl_driver( & !TIMESCALE, BUT FOR WINDY CONDITIONS, IT IS THE ADVECTIVE !TIMESCALE. USE THE MINIMUM OF THE TWO. ts_decay = MIN( 1800., 3.*dx(i)/MAX(SQRT(u1(k)**2 + v1(k)**2),1.0) ) - cldfra_bl(i,k)= MAX(cldfra_bl1D(k),cldfra_bl1D_old(k)-(0.25*delt/ts_decay)) - ! qc_bl2 and qi_bl2 are decay rates + cldfra_bl(i,k)= MAX(cldfra_bl1D(k),cldfra_bl1D_old(k)-(0.20*delt/ts_decay)) + ! qc_bl2 and qi_bl2 are linked to decay rates qc_bl2 = MAX(qc_bl1D(k),qc_bl1D_old(k)) - qc_bl2 = MAX(qc_bl2,1.0E-5) qi_bl2 = MAX(qi_bl1D(k),qi_bl1D_old(k)) - qi_bl2 = MAX(qi_bl2,1.0E-6) - qc_bl(i,k) = MAX(qc_bl1D(k),qc_bl1D_old(k)-(MIN(qc_bl2,1.0E-4) * delt/ts_decay)) - qi_bl(i,k) = MAX(qi_bl1D(k),qi_bl1D_old(k)-(MIN(qi_bl2,1.0E-5) * delt/ts_decay)) + qc_bl(i,k) = MAX(qc_bl1D(k),qc_bl1D_old(k)-(MIN(qc_bl2,1.0E-5) * delt/ts_decay)) + qi_bl(i,k) = MAX(qi_bl1D(k),qi_bl1D_old(k)-(MIN(qi_bl2,1.0E-6) * delt/ts_decay)) IF (cldfra_bl(i,k) < 0.005 .OR. & (qc_bl(i,k) + qi_bl(i,k)) < 1E-9) THEN CLDFRA_BL(i,k)= 0. @@ -5728,8 +5859,8 @@ END SUBROUTINE GET_PBLH !! !! This scheme remains under development, so consider it experimental code. !! - SUBROUTINE DMP_mf( & - & kts,kte,dt,zw,dz,p, & + SUBROUTINE DMP_mf( & + & kts,kte,dt,zw,dz,p,rho, & & momentum_opt, & & tke_opt, & & scalar_opt, & @@ -5783,7 +5914,7 @@ SUBROUTINE DMP_mf( & REAL, DIMENSION(KTS:KTE) :: rstoch_col REAL,DIMENSION(KTS:KTE), INTENT(IN) :: U,V,W,TH,THL,TK,QT,QV,QC,& - exner,dz,THV,P,qke,qnc,qni,qnwfa,qnifa + exner,dz,THV,P,rho,qke,qnc,qni,qnwfa,qnifa REAL,DIMENSION(KTS:KTE+1), INTENT(IN) :: ZW !height at full-sigma REAL, INTENT(IN) :: DT,UST,FLT,FLQ,FLQV,FLQC,PBLH,& DX,Psig_shcu,landsea,ts @@ -5798,8 +5929,8 @@ SUBROUTINE DMP_mf( & INTEGER, INTENT(OUT) :: nup2,ktop REAL, INTENT(OUT) :: maxmf,ztop ! outputs - variables needed for solver - REAL,DIMENSION(KTS:KTE+1) :: s_aw, & !sum ai*wis_awphi - s_awthl, & !sum ai*wi*phii + REAL,DIMENSION(KTS:KTE+1) :: s_aw, & !sum ai*rho*wis_awphi + s_awthl, & !sum ai*rho*wi*phii s_awqt, & s_awqv, & s_awqc, & @@ -5830,7 +5961,7 @@ SUBROUTINE DMP_mf( & REAL :: fltv,wstar,qstar,thstar,sigmaW,sigmaQT,sigmaTH,z0, & pwmin,pwmax,wmin,wmax,wlv,Psig_w,maxw,maxqc,wpbl REAL :: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,QNCn,QNIn,QNWFAn,QNIFAn, & - Wn2,Wn,EntEXP,EntW,BCOEFF,THVkm1,THVk,Pk + Wn2,Wn,EntEXP,EntW,BCOEFF,THVkm1,THVk,Pk,rho_int ! w parameters REAL,PARAMETER :: & @@ -5900,7 +6031,8 @@ SUBROUTINE DMP_mf( & envm_u,envm_v !environmental variables defined at middle of layer REAL,DIMENSION(KTS:KTE+1) :: envi_a,envi_w !environmental variables defined at model interface REAL :: temp,sublim,qc_ent,qv_ent,qt_ent,thl_ent,detrate, & - detrateUV,oow,exc_fac,aratio,detturb,qc_grid,qc_sgs + detrateUV,oow,exc_fac,aratio,detturb,qc_grid,qc_sgs,& + qc_plume REAL, PARAMETER :: Cdet = 1./45. REAL, PARAMETER :: dzpmax = 300. !limit dz used in detrainment - can be excessing in thick layers !parameter "Csub" determines the propotion of upward vertical velocity that contributes to @@ -6146,9 +6278,6 @@ SUBROUTINE DMP_mf( & wmin=MIN(sigmaW*pwmin,0.05) wmax=MIN(sigmaW*pwmax,0.4) - !recompute acfac for plume excess - acfac = .5*tanh((fltv - 0.03)/0.07) + .5 - !SPECIFY SURFACE UPDRAFT PROPERTIES AT MODEL INTERFACE BETWEEN K = 1 & 2 DO I=1,NUP !NUP2 IF(I > NUP2) exit @@ -6210,7 +6339,7 @@ SUBROUTINE DMP_mf( & !Entrainment from Tian and Kuang (2016) !ENT(k,i) = 0.35/(MIN(MAX(UPW(K-1,I),0.75),1.9)*l) !wmin = 0.3 + l*0.0005 !* MAX(pblh-ZW(k+1), 0.0)/pblh - !ENT(k,i) = 0.33/(MIN(MAX(UPW(K-1,I),wmin),1.9)*l) + !ENT(k,i) = 0.33/(MIN(MAX(UPW(K-1,I),wmin),0.9)*l) !Entrainment from Negggers (2015, JAMES) !ENT(k,i) = 0.02*l**-0.35 - 0.0009 @@ -6383,7 +6512,7 @@ SUBROUTINE DMP_mf( & IF (Wn > 0.) THEN !Update plume variables at current k index - UPW(K,I)=Wn !Wn !sqrt(Wn2) + UPW(K,I)=Wn !sqrt(Wn2) UPTHV(K,I)=THVn UPTHL(K,I)=THLn UPQT(K,I)=QTn @@ -6429,7 +6558,7 @@ SUBROUTINE DMP_mf( & ENDDO ELSE !At least one of the conditions was not met for activating the MF scheme. - NUP2=0. + NUP2=0. END IF !end criteria for mass-flux scheme ktop=MIN(ktop,KTE-1) ! Just to be safe... @@ -6443,32 +6572,60 @@ SUBROUTINE DMP_mf( & !Calculate the fluxes for each variable !All s_aw* variable are == 0 at k=1 - DO k=KTS,KTE - IF(k > KTOP) exit - DO i=1,NUP !NUP2 - IF(I > NUP2) exit - s_aw(k+1) = s_aw(k+1) + UPA(K,i)*UPW(K,i)*Psig_w - s_awthl(k+1)= s_awthl(k+1) + UPA(K,i)*UPW(K,i)*UPTHL(K,i)*Psig_w - s_awqt(k+1) = s_awqt(k+1) + UPA(K,i)*UPW(K,i)*UPQT(K,i)*Psig_w - s_awqc(k+1) = s_awqc(k+1) + UPA(K,i)*UPW(K,i)*UPQC(K,i)*Psig_w +! DO k=KTS,KTE +! IF(k > KTOP) exit +! DO i=1,NUP !NUP2 +! IF(I > NUP2) exit +! s_aw(k+1) = s_aw(k+1) + UPA(K,i)*UPW(K,i)*Psig_w +! s_awthl(k+1)= s_awthl(k+1) + UPA(K,i)*UPW(K,i)*UPTHL(K,i)*Psig_w +! s_awqt(k+1) = s_awqt(k+1) + UPA(K,i)*UPW(K,i)*UPQT(K,i)*Psig_w +! s_awqc(k+1) = s_awqc(k+1) + UPA(K,i)*UPW(K,i)*UPQC(K,i)*Psig_w +! IF (momentum_opt > 0) THEN +! s_awu(k+1) = s_awu(k+1) + UPA(K,i)*UPW(K,i)*UPU(K,i)*Psig_w +! s_awv(k+1) = s_awv(k+1) + UPA(K,i)*UPW(K,i)*UPV(K,i)*Psig_w +! ENDIF +! IF (tke_opt > 0) THEN +! s_awqke(k+1)= s_awqke(k+1) + UPA(K,i)*UPW(K,i)*UPQKE(K,i)*Psig_w +! ENDIF +! ENDDO +! s_awqv(k+1) = s_awqt(k+1) - s_awqc(k+1) +! ENDDO + DO i=1,NUP !NUP2 + IF(I > NUP2) exit + DO k=KTS,KTE-1 + IF(k > ktop) exit + rho_int = (rho(k)*DZ(k+1)+rho(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) + s_aw(k+1) = s_aw(k+1) + rho_int*UPA(K,i)*UPW(K,i)*Psig_w + s_awthl(k+1)= s_awthl(k+1) + rho_int*UPA(K,i)*UPW(K,i)*UPTHL(K,i)*Psig_w + s_awqt(k+1) = s_awqt(k+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQT(K,i)*Psig_w + !to conform to grid mean properties, move qc to qv in grid mean + !saturated layers, so total water fluxes are preserve but + !negative qc fluxes in unsaturated layers is reduced. + IF (qc(k) > 1e-12 .OR. qc(k+1) > 1e-12) then + qc_plume = UPQC(K,i) + ELSE + qc_plume = 0.0 + ENDIF + s_awqc(k+1) = s_awqc(k+1) + rho_int*UPA(K,i)*UPW(K,i)*qc_plume*Psig_w IF (momentum_opt > 0) THEN - s_awu(k+1) = s_awu(k+1) + UPA(K,i)*UPW(K,i)*UPU(K,i)*Psig_w - s_awv(k+1) = s_awv(k+1) + UPA(K,i)*UPW(K,i)*UPV(K,i)*Psig_w + s_awu(k+1) = s_awu(k+1) + rho_int*UPA(K,i)*UPW(K,i)*UPU(K,i)*Psig_w + s_awv(k+1) = s_awv(k+1) + rho_int*UPA(K,i)*UPW(K,i)*UPV(K,i)*Psig_w ENDIF IF (tke_opt > 0) THEN - s_awqke(k+1)= s_awqke(k+1) + UPA(K,i)*UPW(K,i)*UPQKE(K,i)*Psig_w + s_awqke(k+1)= s_awqke(k+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQKE(K,i)*Psig_w ENDIF + s_awqv(k+1) = s_awqt(k+1) - s_awqc(k+1) ENDDO - s_awqv(k+1) = s_awqt(k+1) - s_awqc(k+1) ENDDO #if (WRF_CHEM == 1) IF ( mynn_chem_vertmx ) THEN DO k=KTS,KTE IF(k > KTOP) exit + rho_int = (rho(k)*DZ(k+1)+rho(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) DO i=1,NUP !NUP2 IF(I > NUP2) exit do ic = 1,nchem - s_awchem(k+1,ic) = s_awchem(k+1,ic) + UPA(K,i)*UPW(K,i)*UPCHEM(K,i,ic)*Psig_w + s_awchem(k+1,ic) = s_awchem(k+1,ic) + rho_int*UPA(K,i)*UPW(K,i)*UPCHEM(K,i,ic)*Psig_w enddo ENDDO ENDDO @@ -6478,12 +6635,13 @@ SUBROUTINE DMP_mf( & IF (scalar_opt > 0) THEN DO k=KTS,KTE IF(k > KTOP) exit + rho_int = (rho(k)*DZ(k+1)+rho(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) DO I=1,NUP !NUP2 IF (I > NUP2) exit - s_awqnc(k+1)= s_awqnc(K+1) + UPA(K,i)*UPW(K,i)*UPQNC(K,i)*Psig_w - s_awqni(k+1)= s_awqni(K+1) + UPA(K,i)*UPW(K,i)*UPQNI(K,i)*Psig_w - s_awqnwfa(k+1)= s_awqnwfa(K+1) + UPA(K,i)*UPW(K,i)*UPQNWFA(K,i)*Psig_w - s_awqnifa(k+1)= s_awqnifa(K+1) + UPA(K,i)*UPW(K,i)*UPQNIFA(K,i)*Psig_w + s_awqnc(k+1)= s_awqnc(K+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQNC(K,i)*Psig_w + s_awqni(k+1)= s_awqni(K+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQNI(K,i)*Psig_w + s_awqnwfa(k+1)= s_awqnwfa(K+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQNWFA(K,i)*Psig_w + s_awqnifa(k+1)= s_awqnifa(K+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQNIFA(K,i)*Psig_w ENDDO ENDDO ENDIF @@ -6533,18 +6691,19 @@ SUBROUTINE DMP_mf( & !all edmf_* variables at k=1 correspond to the interface at top of first model layer DO k=KTS,KTE-1 IF(k > KTOP) exit + rho_int = (rho(k)*DZ(k+1)+rho(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) DO I=1,NUP !NUP2 IF(I > NUP2) exit edmf_a(K) =edmf_a(K) +UPA(K,i) - edmf_w(K) =edmf_w(K) +UPA(K,i)*UPW(K,i) - edmf_qt(K) =edmf_qt(K) +UPA(K,i)*UPQT(K,i) - edmf_thl(K)=edmf_thl(K)+UPA(K,i)*UPTHL(K,i) - edmf_ent(K)=edmf_ent(K)+UPA(K,i)*ENT(K,i) - edmf_qc(K) =edmf_qc(K) +UPA(K,i)*UPQC(K,i) + edmf_w(K) =edmf_w(K) +rho_int*UPA(K,i)*UPW(K,i) + edmf_qt(K) =edmf_qt(K) +rho_int*UPA(K,i)*UPQT(K,i) + edmf_thl(K)=edmf_thl(K)+rho_int*UPA(K,i)*UPTHL(K,i) + edmf_ent(K)=edmf_ent(K)+rho_int*UPA(K,i)*ENT(K,i) + edmf_qc(K) =edmf_qc(K) +rho_int*UPA(K,i)*UPQC(K,i) #if (WRF_CHEM == 1) IF ( mynn_chem_vertmx ) THEN do ic = 1,nchem - edmf_chem(k,ic) = edmf_chem(k,ic) + UPA(K,I)*UPCHEM(k,i,ic) + edmf_chem(k,ic) = edmf_chem(k,ic) + rho_int*UPA(K,I)*UPCHEM(k,i,ic) enddo ENDIF #endif @@ -6866,12 +7025,12 @@ subroutine condensation_edmf(QT,THL,P,zagl,THV,QC) ! number of iterations niter=50 ! minimum difference (usually converges in < 8 iterations with diff = 2e-5) - diff=2.e-5 + diff=1.e-6 EXN=(P/p1000mb)**rcp !QC=0. !better first guess QC is incoming from lower level, do not set to zero do i=1,NITER - T=EXN*THL + xlvcp*QC + T=EXN*THL + xlvcp*QC QS=qsat_blend(T,P) QCOLD=QC QC=0.5*QC + 0.5*MAX((QT-QS),0.) @@ -6967,342 +7126,343 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & REAL,DIMENSION(KTS:KTE+1), INTENT(IN) :: ZW REAL, INTENT(IN) :: DT,UST,WTHL,WQT,PBLH - ! outputs - downdraft properties + ! outputs - downdraft properties REAL,DIMENSION(KTS:KTE), INTENT(OUT) :: edmf_a_dd,edmf_w_dd, & & edmf_qt_dd,edmf_thl_dd, edmf_ent_dd,edmf_qc_dd - ! outputs - variables needed for solver (sd_aw - sum ai*wi, sd_awphi - sum ai*wi*phii) + ! outputs - variables needed for solver (sd_aw - sum ai*wi, sd_awphi - sum ai*wi*phii) REAL,DIMENSION(KTS:KTE+1) :: sd_aw, sd_awthl, sd_awqt, sd_awu, & sd_awv, sd_awqc, sd_awqv, sd_awqke, sd_aw2 REAL,DIMENSION(KTS:KTE), INTENT(IN) :: qc_bl1d, cldfra_bl1d INTEGER, PARAMETER :: NDOWN=5, debug_mf=0 !fixing number of plumes to 5 - ! draw downdraft starting height randomly between cloud base and cloud top + ! draw downdraft starting height randomly between cloud base and cloud top INTEGER, DIMENSION(1:NDOWN) :: DD_initK REAL , DIMENSION(1:NDOWN) :: randNum - ! downdraft properties + ! downdraft properties REAL,DIMENSION(KTS:KTE+1,1:NDOWN) :: DOWNW,DOWNTHL,DOWNQT,& DOWNQC,DOWNA,DOWNU,DOWNV,DOWNTHV - ! entrainment variables + ! entrainment variables REAl,DIMENSION(KTS+1:KTE+1,1:NDOWN) :: ENT,ENTf INTEGER,DIMENSION(KTS+1:KTE+1,1:NDOWN) :: ENTi - ! internal variables + ! internal variables INTEGER :: K,I,ki, kminrad, qlTop, p700_ind, qlBase REAL :: wthv,wstar,qstar,thstar,sigmaW,sigmaQT,sigmaTH,z0, & pwmin,pwmax,wmin,wmax,wlv,wtv,went,mindownw REAL :: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,Wn2,Wn,THVk,Pk, & - EntEXP,EntW, Beta_dm, EntExp_M + EntEXP,EntW, Beta_dm, EntExp_M, rho_int REAL :: jump_thetav, jump_qt, jump_thetal, & refTHL, refTHV, refQT - ! DD specific internal variables + ! DD specific internal variables REAL :: minrad,zminrad, radflux, F0, wst_rad, wst_dd, deltaZ logical :: cloudflg REAL :: sigq,xl,tlk,qsat_tl,rsl,cpm,a,qmq,mf_cf,diffqt,& Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9,satvp,rhgrid - ! w parameters + ! w parameters REAL,PARAMETER :: & &Wa=1., & &Wb=1.5,& &Z00=100.,& &BCOEFF=0.2 - ! entrainment parameters + ! entrainment parameters REAL,PARAMETER :: & & L0=80,& & ENT0=0.2 - pwmin=-3. ! drawing from the neagtive tail -3sigma to -1sigma - pwmax=-1. - - ! initialize downdraft properties - DOWNW=0. - DOWNTHL=0. - DOWNTHV=0. - DOWNQT=0. - DOWNA=0. - DOWNU=0. - DOWNV=0. - DOWNQC=0. - ENT=0. - DD_initK=0 - - edmf_a_dd =0. - edmf_w_dd =0. - edmf_qt_dd =0. - edmf_thl_dd=0. - edmf_ent_dd=0. - edmf_qc_dd =0. - - sd_aw=0. - sd_awthl=0. - sd_awqt=0. - sd_awqv=0. - sd_awqc=0. - sd_awu=0. - sd_awv=0. - sd_awqke=0. - - ! FIRST, CHECK FOR STRATOCUMULUS-TOPPED BOUNDARY LAYERS - cloudflg=.false. - minrad=100. - kminrad=kpbl - zminrad=PBLH - qlTop = 1 !initialize at 0 - qlBase = 1 - wthv=wthl+svp1*wqt - do k = MAX(3,kpbl-2),kpbl+3 - if(qc(k).gt. 1.e-6 .AND. cldfra_bl1D(k).gt.0.5) then - cloudflg=.true. ! found Sc cloud - qlTop = k ! index for Sc cloud top - endif - enddo - - do k = qlTop, kts, -1 - if(qc(k) .gt. 1E-6) then - qlBase = k ! index for Sc cloud base - endif - enddo - qlBase = (qlTop+qlBase)/2 ! changed base to half way through the cloud - -! call init_random_seed_1() -! call RANDOM_NUMBER(randNum) - do i=1,NDOWN - ! downdraft starts somewhere between cloud base to cloud top - ! the probability is equally distributed - DD_initK(i) = qlTop ! nint(randNum(i)*REAL(qlTop-qlBase)) + qlBase - enddo - - ! LOOP RADFLUX - F0 = 0. - do k = 1, qlTop ! Snippet from YSU, YSU loops until qlTop - 1 - radflux = rthraten(k) * exner(k) ! Converts theta/s to temperature/s - radflux = radflux * cp / g * ( p(k) - p(k+1) ) ! Converts K/s to W/m^2 - if ( radflux < 0.0 ) F0 = abs(radflux) + F0 - enddo - F0 = max(F0, 1.0) - !found Sc cloud and cloud not at surface, trigger downdraft - if (cloudflg) then - -! !get entrainent coefficient -! do i=1,NDOWN -! do k=kts+1,kte -! ENTf(k,i)=(ZW(k+1)-ZW(k))/L0 -! enddo -! enddo + pwmin=-3. ! drawing from the neagtive tail -3sigma to -1sigma + pwmax=-1. + + ! initialize downdraft properties + DOWNW=0. + DOWNTHL=0. + DOWNTHV=0. + DOWNQT=0. + DOWNA=0. + DOWNU=0. + DOWNV=0. + DOWNQC=0. + ENT=0. + DD_initK=0 + + edmf_a_dd =0. + edmf_w_dd =0. + edmf_qt_dd =0. + edmf_thl_dd=0. + edmf_ent_dd=0. + edmf_qc_dd =0. + + sd_aw=0. + sd_awthl=0. + sd_awqt=0. + sd_awqv=0. + sd_awqc=0. + sd_awu=0. + sd_awv=0. + sd_awqke=0. + + ! FIRST, CHECK FOR STRATOCUMULUS-TOPPED BOUNDARY LAYERS + cloudflg=.false. + minrad=100. + kminrad=kpbl + zminrad=PBLH + qlTop = 1 !initialize at 0 + qlBase = 1 + wthv=wthl+svp1*wqt + do k = MAX(3,kpbl-2),kpbl+3 + if (qc(k).gt. 1.e-6 .AND. cldfra_bl1D(k).gt.0.5) then + cloudflg=.true. ! found Sc cloud + qlTop = k ! index for Sc cloud top + endif + enddo + + do k = qlTop, kts, -1 + if (qc(k) .gt. 1E-6) then + qlBase = k ! index for Sc cloud base + endif + enddo + qlBase = (qlTop+qlBase)/2 ! changed base to half way through the cloud + +! call init_random_seed_1() +! call RANDOM_NUMBER(randNum) + do i=1,NDOWN + ! downdraft starts somewhere between cloud base to cloud top + ! the probability is equally distributed + DD_initK(i) = qlTop ! nint(randNum(i)*REAL(qlTop-qlBase)) + qlBase + enddo + + ! LOOP RADFLUX + F0 = 0. + do k = 1, qlTop ! Snippet from YSU, YSU loops until qlTop - 1 + radflux = rthraten(k) * exner(k) ! Converts theta/s to temperature/s + radflux = radflux * cp / g * ( p(k) - p(k+1) ) ! Converts K/s to W/m^2 + if ( radflux < 0.0 ) F0 = abs(radflux) + F0 + enddo + F0 = max(F0, 1.0) + !found Sc cloud and cloud not at surface, trigger downdraft + if (cloudflg) then + +! !get entrainent coefficient +! do i=1,NDOWN +! do k=kts+1,kte +! ENTf(k,i)=(ZW(k+1)-ZW(k))/L0 +! enddo +! enddo ! -! ! get Poisson P(dz/L0) -! call Poisson(1,NDOWN,kts+1,kte,ENTf,ENTi) - - - ! entrainent: Ent=Ent0/dz*P(dz/L0) - do i=1,NDOWN - do k=kts+1,kte -! ENT(k,i)=real(ENTi(k,i))*Ent0/(ZW(k+1)-ZW(k)) - ENT(k,i) = 0.002 - ENT(k,i) = min(ENT(k,i),0.9/(ZW(k+1)-ZW(k))) - enddo - enddo - - !!![EW: INVJUMP] find 700mb height then subtract trpospheric lapse rate!!! - p700_ind = MINLOC(ABS(p-70000),1)!p1D is 70000 - jump_thetav = thv(p700_ind) - thv(1) - (thv(p700_ind)-thv(qlTop+3))/(ZW(p700_ind)-ZW(qlTop+3))*(ZW(p700_ind)-ZW(qlTop)) - jump_qt = qc(p700_ind) + qv(p700_ind) - qc(1) - qv(1) - jump_thetal = thl(p700_ind) - thl(1) - (thl(p700_ind)-thl(qlTop+3))/(ZW(p700_ind)-ZW(qlTop+3))*(ZW(p700_ind)-ZW(qlTop)) - - refTHL = thl(qlTop) !sum(thl(1:qlTop)) / (qlTop) ! avg over BL for now or just at qlTop - refTHV = thv(qlTop) !sum(thv(1:qlTop)) / (qlTop) - refQT = qt(qlTop) !sum(qt(1:qlTop)) / (qlTop) - - ! wstar_rad, following Lock and MacVean (1999a) - wst_rad = ( g * zw(qlTop) * F0 / (refTHL * rho(qlTop) * cp) ) ** (0.333) - wst_rad = max(wst_rad, 0.1) - wstar = max(0.,(g/thv(1)*wthv*pblh)**(1./3.)) - went = thv(1) / ( g * jump_thetav * zw(qlTop) ) * & - (0.15 * (wstar**3 + 5*ust**3) + 0.35 * wst_rad**3 ) - qstar = abs(went*jump_qt/wst_rad) - thstar = F0/rho(qlTop)/cp/wst_rad - went*jump_thetav/wst_rad - !wstar_dd = mixrad + surface wst - wst_dd = (0.15 * (wstar**3 + 5*ust**3) + 0.35 * wst_rad**3 ) ** (0.333) - - print*,"qstar=",qstar," thstar=",thstar," wst_dd=",wst_dd - print*,"F0=",F0," wst_rad=",wst_rad," jump_thv=",jump_thetav - print*,"entrainment velocity=",went - - sigmaW = 0.2*wst_dd ! 0.8*wst_dd !wst_rad tuning parameter ! 0.5 was good - sigmaQT = 40 * qstar ! 50 was good - sigmaTH = 1.0 * thstar! 0.5 was good - - wmin=sigmaW*pwmin - wmax=sigmaW*pwmax - print*,"sigw=",sigmaW," wmin=",wmin," wmax=",wmax - - do I=1,NDOWN !downdraft now starts at different height - ki = DD_initK(I) - - wlv=wmin+(wmax-wmin)/REAL(NDOWN)*(i-1) - wtv=wmin+(wmax-wmin)/REAL(NDOWN)*i - - !DOWNW(ki,I)=0.5*(wlv+wtv) - DOWNW(ki,I)=wlv - !DOWNA(ki,I)=0.5*ERF(wtv/(sqrt(2.)*sigmaW))-0.5*ERF(wlv/(sqrt(2.)*sigmaW)) - DOWNA(ki,I)=.1/REAL(NDOWN) - DOWNU(ki,I)=(u(ki-1)*DZ(ki) + u(ki)*DZ(ki-1)) /(DZ(ki)+DZ(ki-1)) - DOWNV(ki,I)=(v(ki-1)*DZ(ki) + v(ki)*DZ(ki-1)) /(DZ(ki)+DZ(ki-1)) - - !reference now depends on where dd starts -! refTHL = 0.5 * (thl(ki) + thl(ki-1)) -! refTHV = 0.5 * (thv(ki) + thv(ki-1)) -! refQT = 0.5 * (qt(ki) + qt(ki-1) ) - - refTHL = (thl(ki-1)*DZ(ki) + thl(ki)*DZ(ki-1)) /(DZ(ki)+DZ(ki-1)) - refTHV = (thv(ki-1)*DZ(ki) + thv(ki)*DZ(ki-1)) /(DZ(ki)+DZ(ki-1)) - refQT = (qt(ki-1)*DZ(ki) + qt(ki)*DZ(ki-1)) /(DZ(ki)+DZ(ki-1)) - - !DOWNQC(ki,I) = 0.0 - DOWNQC(ki,I) = (qc(ki-1)*DZ(ki) + qc(ki)*DZ(ki-1)) /(DZ(ki)+DZ(ki-1)) - DOWNQT(ki,I) = refQT !+ 0.5 *DOWNW(ki,I)*sigmaQT/sigmaW - DOWNTHV(ki,I)= refTHV + 0.01 *DOWNW(ki,I)*sigmaTH/sigmaW - DOWNTHL(ki,I)= refTHL + 0.01 *DOWNW(ki,I)*sigmaTH/sigmaW - - !input :: QT,THV,P,zagl, output :: THL, QC -! Pk =(P(ki-1)*DZ(ki)+P(ki)*DZ(ki-1))/(DZ(ki)+DZ(ki-1)) -! call condensation_edmf_r(DOWNQT(ki,I), & -! & DOWNTHL(ki,I),Pk,ZW(ki), & -! & DOWNTHV(ki,I),DOWNQC(ki,I) ) - - enddo +! ! get Poisson P(dz/L0) +! call Poisson(1,NDOWN,kts+1,kte,ENTf,ENTi) - print*, " Begin integration of downdrafts:" - DO I=1,NDOWN - print *, "Plume # =", I,"=======================" - DO k=DD_initK(I)-1,KTS+1,-1 - !starting at the first interface level below cloud top - deltaZ = ZW(k+1)-ZW(k) - !EntExp=exp(-ENT(K,I)*deltaZ) - !EntExp_M=exp(-ENT(K,I)/3.*deltaZ) - EntExp =ENT(K,I)*deltaZ - EntExp_M=ENT(K,I)*0.333*deltaZ - - QTn =DOWNQT(k+1,I) *(1.-EntExp) + QT(k)*EntExp - THLn=DOWNTHL(k+1,I)*(1.-EntExp) + THL(k)*EntExp - Un =DOWNU(k+1,I) *(1.-EntExp) + U(k)*EntExp_M - Vn =DOWNV(k+1,I) *(1.-EntExp) + V(k)*EntExp_M - !QKEn=DOWNQKE(k-1,I)*(1.-EntExp) + QKE(k)*EntExp - -! QTn =DOWNQT(K+1,I) +(QT(K) -DOWNQT(K+1,I)) *(1.-EntExp) -! THLn=DOWNTHL(K+1,I)+(THL(K)-DOWNTHL(K+1,I))*(1.-EntExp) -! Un =DOWNU(K+1,I) +(U(K) -DOWNU(K+1,I))*(1.-EntExp_M) -! Vn =DOWNV(K+1,I) +(V(K) -DOWNV(K+1,I))*(1.-EntExp_M) - - ! given new p & z, solve for thvn & qcn - Pk =(P(k-1)*DZ(k)+P(k)*DZ(k-1))/(DZ(k)+DZ(k-1)) - call condensation_edmf(QTn,THLn,Pk,ZW(k),THVn,QCn) -! B=g*(0.5*(THVn+DOWNTHV(k+1,I))/THV(k)-1.) - THVk =(THV(k-1)*DZ(k)+THV(k)*DZ(k-1))/(DZ(k)+DZ(k-1)) - B=g*(THVn/THVk - 1.0) -! Beta_dm = 2*Wb*ENT(K,I) + 0.5/(ZW(k)-deltaZ) * & -! & max(1. - exp((ZW(k) -deltaZ)/Z00 - 1. ) , 0.) -! EntW=exp(-Beta_dm * deltaZ) - EntW=EntExp -! if (Beta_dm >0) then -! Wn2=DOWNW(K+1,I)**2*EntW - Wa*B/Beta_dm * (1. - EntW) -! else -! Wn2=DOWNW(K+1,I)**2 - 2.*Wa*B*deltaZ -! end if - - mindownw = MIN(DOWNW(K+1,I),-0.2) - Wn = DOWNW(K+1,I) + (-2.*ENT(K,I)*DOWNW(K+1,I) - & - BCOEFF*B/mindownw)*MIN(deltaZ, 250.) - - !Do not allow a parcel to accelerate more than 1.25 m/s over 200 m. - !Add max increase of 2.0 m/s for coarse vertical resolution. - IF(Wn < DOWNW(K+1,I) - MIN(1.25*deltaZ/200., 2.0))THEN - Wn = DOWNW(K+1,I) - MIN(1.25*deltaZ/200., 2.0) - ENDIF - !Add symmetrical max decrease in w - IF(Wn > DOWNW(K+1,I) + MIN(1.25*deltaZ/200., 2.0))THEN - Wn = DOWNW(K+1,I) + MIN(1.25*deltaZ/200., 2.0) - ENDIF - Wn = MAX(MIN(Wn,0.0), -3.0) - - print *, " k =", k, " z =", ZW(k) - print *, " entw =",ENT(K,I), " Bouy =", B - print *, " downthv =", THVn, " thvk =", thvk - print *, " downthl =", THLn, " thl =", thl(k) - print *, " downqt =", QTn , " qt =", qt(k) - print *, " downw+1 =",DOWNW(K+1,I), " Wn2 =", Wn - - IF (Wn .lt. 0.) THEN !terminate when velocity is too small - DOWNW(K,I) = Wn !-sqrt(Wn2) - DOWNTHV(K,I)= THVn - DOWNTHL(K,I)= THLn - DOWNQT(K,I) = QTn - DOWNQC(K,I) = QCn - DOWNU(K,I) = Un - DOWNV(K,I) = Vn - DOWNA(K,I) = DOWNA(K+1,I) - ELSE - !plumes must go at least 2 levels - if (DD_initK(I) - K .lt. 2) then - DOWNW(:,I) = 0.0 - DOWNTHV(:,I)= 0.0 - DOWNTHL(:,I)= 0.0 - DOWNQT(:,I) = 0.0 - DOWNQC(:,I) = 0.0 - DOWNU(:,I) = 0.0 - DOWNV(:,I) = 0.0 - endif - exit - ENDIF - ENDDO - ENDDO - endif ! end cloud flag - - DOWNW(1,:) = 0. !make sure downdraft does not go to the surface - DOWNA(1,:) = 0. - - ! Combine both moist and dry plume, write as one averaged plume - ! Even though downdraft starts at different height, average all up to qlTop - DO k=qlTop,KTS,-1 - DO I=1,NDOWN - IF (I > NDOWN) exit - edmf_a_dd(K) =edmf_a_dd(K) +DOWNA(K-1,I) - edmf_w_dd(K) =edmf_w_dd(K) +DOWNA(K-1,I)*DOWNW(K-1,I) - edmf_qt_dd(K) =edmf_qt_dd(K) +DOWNA(K-1,I)*DOWNQT(K-1,I) - edmf_thl_dd(K)=edmf_thl_dd(K)+DOWNA(K-1,I)*DOWNTHL(K-1,I) - edmf_ent_dd(K)=edmf_ent_dd(K)+DOWNA(K-1,I)*ENT(K-1,I) - edmf_qc_dd(K) =edmf_qc_dd(K) +DOWNA(K-1,I)*DOWNQC(K-1,I) - ENDDO - - IF (edmf_a_dd(k) >0.) THEN - edmf_w_dd(k) =edmf_w_dd(k) /edmf_a_dd(k) - edmf_qt_dd(k) =edmf_qt_dd(k) /edmf_a_dd(k) - edmf_thl_dd(k)=edmf_thl_dd(k)/edmf_a_dd(k) - edmf_ent_dd(k)=edmf_ent_dd(k)/edmf_a_dd(k) - edmf_qc_dd(k) =edmf_qc_dd(k) /edmf_a_dd(k) - ENDIF - ENDDO + ! entrainent: Ent=Ent0/dz*P(dz/L0) + do i=1,NDOWN + do k=kts+1,kte +! ENT(k,i)=real(ENTi(k,i))*Ent0/(ZW(k+1)-ZW(k)) + ENT(k,i) = 0.002 + ENT(k,i) = min(ENT(k,i),0.9/(ZW(k+1)-ZW(k))) + enddo + enddo + + !!![EW: INVJUMP] find 700mb height then subtract trpospheric lapse rate!!! + p700_ind = MINLOC(ABS(p-70000),1)!p1D is 70000 + jump_thetav = thv(p700_ind) - thv(1) - (thv(p700_ind)-thv(qlTop+3))/(ZW(p700_ind)-ZW(qlTop+3))*(ZW(p700_ind)-ZW(qlTop)) + jump_qt = qc(p700_ind) + qv(p700_ind) - qc(1) - qv(1) + jump_thetal = thl(p700_ind) - thl(1) - (thl(p700_ind)-thl(qlTop+3))/(ZW(p700_ind)-ZW(qlTop+3))*(ZW(p700_ind)-ZW(qlTop)) + + refTHL = thl(qlTop) !sum(thl(1:qlTop)) / (qlTop) ! avg over BL for now or just at qlTop + refTHV = thv(qlTop) !sum(thv(1:qlTop)) / (qlTop) + refQT = qt(qlTop) !sum(qt(1:qlTop)) / (qlTop) + + ! wstar_rad, following Lock and MacVean (1999a) + wst_rad = ( g * zw(qlTop) * F0 / (refTHL * rho(qlTop) * cp) ) ** (0.333) + wst_rad = max(wst_rad, 0.1) + wstar = max(0.,(g/thv(1)*wthv*pblh)**(1./3.)) + went = thv(1) / ( g * jump_thetav * zw(qlTop) ) * & + (0.15 * (wstar**3 + 5*ust**3) + 0.35 * wst_rad**3 ) + qstar = abs(went*jump_qt/wst_rad) + thstar = F0/rho(qlTop)/cp/wst_rad - went*jump_thetav/wst_rad + !wstar_dd = mixrad + surface wst + wst_dd = (0.15 * (wstar**3 + 5*ust**3) + 0.35 * wst_rad**3 ) ** (0.333) + + print*,"qstar=",qstar," thstar=",thstar," wst_dd=",wst_dd + print*,"F0=",F0," wst_rad=",wst_rad," jump_thv=",jump_thetav + print*,"entrainment velocity=",went + + sigmaW = 0.2*wst_dd ! 0.8*wst_dd !wst_rad tuning parameter ! 0.5 was good + sigmaQT = 40 * qstar ! 50 was good + sigmaTH = 1.0 * thstar! 0.5 was good + + wmin=sigmaW*pwmin + wmax=sigmaW*pwmax + !print*,"sigw=",sigmaW," wmin=",wmin," wmax=",wmax + + do I=1,NDOWN !downdraft now starts at different height + ki = DD_initK(I) + + wlv=wmin+(wmax-wmin)/REAL(NDOWN)*(i-1) + wtv=wmin+(wmax-wmin)/REAL(NDOWN)*i + + !DOWNW(ki,I)=0.5*(wlv+wtv) + DOWNW(ki,I)=wlv + !DOWNA(ki,I)=0.5*ERF(wtv/(sqrt(2.)*sigmaW))-0.5*ERF(wlv/(sqrt(2.)*sigmaW)) + DOWNA(ki,I)=.1/REAL(NDOWN) + DOWNU(ki,I)=(u(ki-1)*DZ(ki) + u(ki)*DZ(ki-1)) /(DZ(ki)+DZ(ki-1)) + DOWNV(ki,I)=(v(ki-1)*DZ(ki) + v(ki)*DZ(ki-1)) /(DZ(ki)+DZ(ki-1)) + + !reference now depends on where dd starts +! refTHL = 0.5 * (thl(ki) + thl(ki-1)) +! refTHV = 0.5 * (thv(ki) + thv(ki-1)) +! refQT = 0.5 * (qt(ki) + qt(ki-1) ) + + refTHL = (thl(ki-1)*DZ(ki) + thl(ki)*DZ(ki-1)) /(DZ(ki)+DZ(ki-1)) + refTHV = (thv(ki-1)*DZ(ki) + thv(ki)*DZ(ki-1)) /(DZ(ki)+DZ(ki-1)) + refQT = (qt(ki-1)*DZ(ki) + qt(ki)*DZ(ki-1)) /(DZ(ki)+DZ(ki-1)) + + !DOWNQC(ki,I) = 0.0 + DOWNQC(ki,I) = (qc(ki-1)*DZ(ki) + qc(ki)*DZ(ki-1)) /(DZ(ki)+DZ(ki-1)) + DOWNQT(ki,I) = refQT !+ 0.5 *DOWNW(ki,I)*sigmaQT/sigmaW + DOWNTHV(ki,I)= refTHV + 0.01 *DOWNW(ki,I)*sigmaTH/sigmaW + DOWNTHL(ki,I)= refTHL + 0.01 *DOWNW(ki,I)*sigmaTH/sigmaW + + !input :: QT,THV,P,zagl, output :: THL, QC +! Pk =(P(ki-1)*DZ(ki)+P(ki)*DZ(ki-1))/(DZ(ki)+DZ(ki-1)) +! call condensation_edmf_r(DOWNQT(ki,I), & +! & DOWNTHL(ki,I),Pk,ZW(ki), & +! & DOWNTHV(ki,I),DOWNQC(ki,I) ) + + enddo + + + !print*, " Begin integration of downdrafts:" + DO I=1,NDOWN + !print *, "Plume # =", I,"=======================" + DO k=DD_initK(I)-1,KTS+1,-1 + !starting at the first interface level below cloud top + deltaZ = ZW(k+1)-ZW(k) + !EntExp=exp(-ENT(K,I)*deltaZ) + !EntExp_M=exp(-ENT(K,I)/3.*deltaZ) + EntExp =ENT(K,I)*deltaZ + EntExp_M=ENT(K,I)*0.333*deltaZ + + QTn =DOWNQT(k+1,I) *(1.-EntExp) + QT(k)*EntExp + THLn=DOWNTHL(k+1,I)*(1.-EntExp) + THL(k)*EntExp + Un =DOWNU(k+1,I) *(1.-EntExp) + U(k)*EntExp_M + Vn =DOWNV(k+1,I) *(1.-EntExp) + V(k)*EntExp_M + !QKEn=DOWNQKE(k-1,I)*(1.-EntExp) + QKE(k)*EntExp + +! QTn =DOWNQT(K+1,I) +(QT(K) -DOWNQT(K+1,I)) *(1.-EntExp) +! THLn=DOWNTHL(K+1,I)+(THL(K)-DOWNTHL(K+1,I))*(1.-EntExp) +! Un =DOWNU(K+1,I) +(U(K) -DOWNU(K+1,I))*(1.-EntExp_M) +! Vn =DOWNV(K+1,I) +(V(K) -DOWNV(K+1,I))*(1.-EntExp_M) + + ! given new p & z, solve for thvn & qcn + Pk =(P(k-1)*DZ(k)+P(k)*DZ(k-1))/(DZ(k)+DZ(k-1)) + call condensation_edmf(QTn,THLn,Pk,ZW(k),THVn,QCn) +! B=g*(0.5*(THVn+DOWNTHV(k+1,I))/THV(k)-1.) + THVk =(THV(k-1)*DZ(k)+THV(k)*DZ(k-1))/(DZ(k)+DZ(k-1)) + B=g*(THVn/THVk - 1.0) +! Beta_dm = 2*Wb*ENT(K,I) + 0.5/(ZW(k)-deltaZ) * & +! & max(1. - exp((ZW(k) -deltaZ)/Z00 - 1. ) , 0.) +! EntW=exp(-Beta_dm * deltaZ) + EntW=EntExp +! if (Beta_dm >0) then +! Wn2=DOWNW(K+1,I)**2*EntW - Wa*B/Beta_dm * (1. - EntW) +! else +! Wn2=DOWNW(K+1,I)**2 - 2.*Wa*B*deltaZ +! end if + + mindownw = MIN(DOWNW(K+1,I),-0.2) + Wn = DOWNW(K+1,I) + (-2.*ENT(K,I)*DOWNW(K+1,I) - & + BCOEFF*B/mindownw)*MIN(deltaZ, 250.) + + !Do not allow a parcel to accelerate more than 1.25 m/s over 200 m. + !Add max increase of 2.0 m/s for coarse vertical resolution. + IF (Wn < DOWNW(K+1,I) - MIN(1.25*deltaZ/200., 2.0))THEN + Wn = DOWNW(K+1,I) - MIN(1.25*deltaZ/200., 2.0) + ENDIF + !Add symmetrical max decrease in w + IF (Wn > DOWNW(K+1,I) + MIN(1.25*deltaZ/200., 2.0))THEN + Wn = DOWNW(K+1,I) + MIN(1.25*deltaZ/200., 2.0) + ENDIF + Wn = MAX(MIN(Wn,0.0), -3.0) + + !print *, " k =", k, " z =", ZW(k) + !print *, " entw =",ENT(K,I), " Bouy =", B + !print *, " downthv =", THVn, " thvk =", thvk + !print *, " downthl =", THLn, " thl =", thl(k) + !print *, " downqt =", QTn , " qt =", qt(k) + !print *, " downw+1 =",DOWNW(K+1,I), " Wn2 =", Wn + + IF (Wn .lt. 0.) THEN !terminate when velocity is too small + DOWNW(K,I) = Wn !-sqrt(Wn2) + DOWNTHV(K,I)= THVn + DOWNTHL(K,I)= THLn + DOWNQT(K,I) = QTn + DOWNQC(K,I) = QCn + DOWNU(K,I) = Un + DOWNV(K,I) = Vn + DOWNA(K,I) = DOWNA(K+1,I) + ELSE + !plumes must go at least 2 levels + if (DD_initK(I) - K .lt. 2) then + DOWNW(:,I) = 0.0 + DOWNTHV(:,I)= 0.0 + DOWNTHL(:,I)= 0.0 + DOWNQT(:,I) = 0.0 + DOWNQC(:,I) = 0.0 + DOWNU(:,I) = 0.0 + DOWNV(:,I) = 0.0 + endif + exit + ENDIF + ENDDO + ENDDO + endif ! end cloud flag + + DOWNW(1,:) = 0. !make sure downdraft does not go to the surface + DOWNA(1,:) = 0. + + ! Combine both moist and dry plume, write as one averaged plume + ! Even though downdraft starts at different height, average all up to qlTop + DO k=qlTop,KTS,-1 + DO I=1,NDOWN + IF (I > NDOWN) exit + edmf_a_dd(K) =edmf_a_dd(K) +DOWNA(K-1,I) + edmf_w_dd(K) =edmf_w_dd(K) +DOWNA(K-1,I)*DOWNW(K-1,I) + edmf_qt_dd(K) =edmf_qt_dd(K) +DOWNA(K-1,I)*DOWNQT(K-1,I) + edmf_thl_dd(K)=edmf_thl_dd(K)+DOWNA(K-1,I)*DOWNTHL(K-1,I) + edmf_ent_dd(K)=edmf_ent_dd(K)+DOWNA(K-1,I)*ENT(K-1,I) + edmf_qc_dd(K) =edmf_qc_dd(K) +DOWNA(K-1,I)*DOWNQC(K-1,I) + ENDDO - ! - ! computing variables needed for solver - ! - - DO k=KTS,qlTop - DO I=1,NDOWN - sd_aw(k) =sd_aw(k) +DOWNA(k,i)*DOWNW(k,i) - sd_awthl(k)=sd_awthl(k)+DOWNA(k,i)*DOWNW(k,i)*DOWNTHL(k,i) - sd_awqt(k) =sd_awqt(k) +DOWNA(k,i)*DOWNW(k,i)*DOWNQT(k,i) - sd_awqc(k) =sd_awqc(k) +DOWNA(k,i)*DOWNW(k,i)*DOWNQC(k,i) - sd_awu(k) =sd_awu(k) +DOWNA(k,i)*DOWNW(k,i)*DOWNU(k,i) - sd_awv(k) =sd_awv(k) +DOWNA(k,i)*DOWNW(k,i)*DOWNV(k,i) - ENDDO - sd_awqv(k) = sd_awqt(k) - sd_awqc(k) - ENDDO + IF (edmf_a_dd(k) >0.) THEN + edmf_w_dd(k) =edmf_w_dd(k) /edmf_a_dd(k) + edmf_qt_dd(k) =edmf_qt_dd(k) /edmf_a_dd(k) + edmf_thl_dd(k)=edmf_thl_dd(k)/edmf_a_dd(k) + edmf_ent_dd(k)=edmf_ent_dd(k)/edmf_a_dd(k) + edmf_qc_dd(k) =edmf_qc_dd(k) /edmf_a_dd(k) + ENDIF + ENDDO + + ! + ! computing variables needed for solver + ! + + DO k=KTS,qlTop + rho_int = (rho(k)*DZ(k+1)+rho(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) + DO I=1,NDOWN + sd_aw(k) =sd_aw(k) +rho_int*DOWNA(k,i)*DOWNW(k,i) + sd_awthl(k)=sd_awthl(k)+rho_int*DOWNA(k,i)*DOWNW(k,i)*DOWNTHL(k,i) + sd_awqt(k) =sd_awqt(k) +rho_int*DOWNA(k,i)*DOWNW(k,i)*DOWNQT(k,i) + sd_awqc(k) =sd_awqc(k) +rho_int*DOWNA(k,i)*DOWNW(k,i)*DOWNQC(k,i) + sd_awu(k) =sd_awu(k) +rho_int*DOWNA(k,i)*DOWNW(k,i)*DOWNU(k,i) + sd_awv(k) =sd_awv(k) +rho_int*DOWNA(k,i)*DOWNW(k,i)*DOWNV(k,i) + ENDDO + sd_awqv(k) = sd_awqt(k) - sd_awqc(k) + ENDDO END SUBROUTINE DDMF_JPL !=============================================================== From 6702381194529ba31c14adc5458b3797bf444705 Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Wed, 20 Oct 2021 21:21:57 +0000 Subject: [PATCH 44/85] bug fix: must initialize dth prior to moisture_check routine --- physics/module_bl_mynn.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 5c83ab8c2..fb0f1455d 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -3237,6 +3237,7 @@ SUBROUTINE mynn_tendencies(kts,kte, & ustdrag = MIN(ust*ust,0.99)/wspd ! limit at ~ 20 m/s ustdiff = MIN(ust*ust,0.01)/wspd ! limit at ~ 2 m/s + dth(kts:kte) = 0.0 ! must initialize for moisture_check routine !!============================================ !! u From b07a965ecf5223f8e096b98546c86da9449aa120 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Thu, 21 Oct 2021 10:07:20 -0600 Subject: [PATCH 45/85] Fix bugs in sfc_drv_ruc.F90 introduced by the merge process --- physics/sfc_drv_ruc.F90 | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index 1c3cd9143..8208f9a00 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -64,6 +64,7 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & real (kind=kind_phys), dimension(:), intent(in) :: slmsk integer, dimension(:), intent(in) :: stype integer, dimension(:), intent(in) :: vtype + real (kind=kind_phys), dimension(:), intent(in) :: landfrac real (kind=kind_phys), dimension(:), intent(in) :: q1 real (kind=kind_phys), dimension(:), intent(in) :: prsl1 real (kind=kind_phys), dimension(:), intent(in) :: tsfc_lnd @@ -324,7 +325,7 @@ subroutine lsm_ruc_run & ! inputs & imp_physics, imp_physics_gfdl, imp_physics_thompson, & & do_mynnsfclay, lsoil_ruc, lsoil, rdlai, zs, & & t1, q1, qc, stype, vtype, sigmaf, laixy, & - & dlwflx, dswsfc, tg3, coszen, land, icy, lake, & + & dlwflx, dswsfc, tg3, coszen, land, icy, use_lake, & & rainnc, rainc, ice, snow, graupel, & & prsl1, zf, wind, shdmin, shdmax, & & srflag, sfalb_lnd_bck, snoalb, & @@ -1694,8 +1695,8 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in !--- initialize smcwlt2 and smcref2 with Noah values if(landfrac(i) > 0.) then - smcref2 (i) = REFSMCnoah(soiltyp(i)) - smcwlt2 (i) = WLTSMCnoah(soiltyp(i)) + smcref2 (i) = REFSMCnoah(stype(i)) + smcwlt2 (i) = WLTSMCnoah(stype(i)) else smcref2 (i) = 1. smcwlt2 (i) = 0. From 5e6eb79f01e6799d82c0573f322ca44f1469ba97 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Tue, 26 Oct 2021 08:16:25 -0600 Subject: [PATCH 46/85] Bug fix in physics/GFS_rrtmg_pre.meta, use correct vertical dimension --- physics/GFS_rrtmg_pre.meta | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 7c36ad656..1973a81a8 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -800,7 +800,7 @@ standard_name = convective_cloud_condesate_after_rainout long_name = convective cloud condesate after rainout units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = in From df022f12c29988dbf06dfcac4af79dacffe0e592 Mon Sep 17 00:00:00 2001 From: Tanya Smirnova Date: Sun, 31 Oct 2021 19:15:14 +0000 Subject: [PATCH 47/85] Pass into the RUC driver lat/lons for debugging. --- physics/sfc_drv_ruc.F90 | 50 +++++++++++++++++++++++++++++++++++++++- physics/sfc_drv_ruc.meta | 18 +++++++++++++++ 2 files changed, 67 insertions(+), 1 deletion(-) diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index dbcfb566d..ecea7a670 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -323,7 +323,7 @@ end subroutine lsm_ruc_finalize subroutine lsm_ruc_run & ! inputs & ( iter, me, master, delt, kdt, im, nlev, lsm_ruc, lsm, & & imp_physics, imp_physics_gfdl, imp_physics_thompson, & - & do_mynnsfclay, lsoil_ruc, lsoil, rdlai, zs, & + & do_mynnsfclay, lsoil_ruc, lsoil, rdlai, xlat_d, xlon_d, zs,& & t1, q1, qc, stype, vtype, sigmaf, laixy, & & dlwflx, dswsfc, tg3, coszen, land, icy, use_lake, & & rainnc, rainc, ice, snow, graupel, & @@ -372,6 +372,7 @@ subroutine lsm_ruc_run & ! inputs integer, intent(in) :: im, nlev, iter, lsoil_ruc, lsoil, kdt, isot, ivegsrc integer, intent(in) :: lsm_ruc, lsm integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson + real (kind=kind_phys), dimension(:), intent(in) :: xlat_d, xlon_d real (kind=kind_phys), dimension(:), intent(in) :: & & t1, sigmaf, laixy, dlwflx, dswsfc, tg3, & @@ -527,12 +528,20 @@ subroutine lsm_ruc_run & ! inputs logical :: flag(im), flag_ice(im), flag_ice_uncoupled(im) logical :: rdlai2d, myj, frpcpn logical :: debug_print + + !-- diagnostic point + real (kind=kind_phys) :: testptlat, testptlon ! ! Initialize CCPP error handling variables errmsg = '' errflg = 0 ipr = 10 + + !-- + testptlat = 74.12 !29.5 + testptlon = 164.0 !283.0 + !-- debug_print=.false. @@ -833,6 +842,26 @@ subroutine lsm_ruc_run & ! inputs rainncv(i,j) = rhoh2o * rainnc(i) ! total time-step explicit precip graupelncv(i,j) = rhoh2o * graupel(i) snowncv(i,j) = rhoh2o * snow(i) + if (debug_print) then + !-- diagnostics for a test point with known lat/lon + if (abs(xlat_d(i)-testptlat).lt.2.5 .and. & + abs(xlon_d(i)-testptlon).lt.6.5)then + if(weasd_lnd(i) > 0.) & + print 100,'(ruc_lsm_drv) i=',i, & + ' lat,lon=',xlat_d(i),xlon_d(i), & + 'rainc',rainc(i),'rainnc',rainnc(i), & + 'graupel',graupel(i),'qc',qc(i),'sfcqv_lnd',sfcqv_lnd(i),& + 'dlwflx',dlwflx(i),'dswsfc',dswsfc(i), & + 'sncovr1_lnd',sncovr1_lnd(i),'sfalb_lnd_bck',sfalb_lnd_bck(i),& + 'prsl1',prsl1(i),'t1',t1(i), & + !'snow',snow(i), 'snowncv',snowncv(i,j), & + 'srflag',srflag(i),'weasd_lnd',weasd_lnd(i), & + 'tsurf_lnd',tsurf_lnd(i),'tslb(i,1)',tslb(i,1) + endif + endif + 100 format (";;; ",a,i4,a,2f9.2/(4(a10,'='es9.2))) + !-- + ! ice precipitation is not used ! precipfr(i,j) = rainncv(i,j) * ffrozp(i,j) @@ -1245,6 +1274,25 @@ subroutine lsm_ruc_run & ! inputs if (flag_ice_uncoupled(i)) then ! at least some ice in the grid cell !-- ice point + if (debug_print) then + if (abs(xlat_d(i)-testptlat).lt.2.5 .and. & + abs(xlon_d(i)-testptlon).lt.6.5)then + if(weasd_lnd(i) > 0.) & + print 101,'(ruc_lsm_drv ice) i=',i, & + ' lat,lon=',xlat_d(i),xlon_d(i),'flag_ice',flag_ice(i),& + !'rainc',rainc(i),'rainnc',rainnc(i), & + 'sfcqv_ice',sfcqv_ice(i),& + !'dlwflx',dlwflx(i),'dswsfc',dswsfc(i), & + 'sncovr1_ice',sncovr1_ice(i),'sfalb_ice',sfalb_ice(i),& + 'sfcqc_ice',sfcqc_ice(i),'tsnow_ice',tsnow_ice(i), & + 'prsl1',prsl1(i),'t1',t1(i), & + !'snow',snow(i), 'snowncv',snowncv(i,j), & + 'srflag',srflag(i),'weasd_ice',weasd_ice(i), & + 'tsurf_ice',tsurf_ice(i),'tslb(i,1)',tslb(i,1) + endif + endif + 101 format (";;; ",a,i4,a,2f9.2/(4(a10,'='es9.2))) + sncovr_ice(i,j) = sncovr1_ice(i) !-- alb_ice* is computed in setalb called from rrtmg_sw_pre. snoalb1d_ice(i,j) = 0.75 !alb_ice_snow(i) !0.75 is RAP value for max snow alb on ice diff --git a/physics/sfc_drv_ruc.meta b/physics/sfc_drv_ruc.meta index 8333746ec..bd587c78a 100644 --- a/physics/sfc_drv_ruc.meta +++ b/physics/sfc_drv_ruc.meta @@ -729,6 +729,24 @@ type = logical intent = in optional = F +[xlat_d] + standard_name = latitude_in_degree + long_name = latitude in degree north + units = degree_north + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[xlon_d] + standard_name = longitude_in_degree + long_name = longitude in degree east + units = degree_east + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F [zs] standard_name = depth_of_soil_layers long_name = depth of soil levels for land surface model From d4964e1de85e0434034243554cb9869e8c877614 Mon Sep 17 00:00:00 2001 From: Tanya Smirnova Date: Sun, 31 Oct 2021 19:16:22 +0000 Subject: [PATCH 48/85] Fixed bugs in MYNN surface layer scheme in land/ice/water parts of the code to avoid using in computations "huge" numbers of qsfc_lnd, qsfc_ice and qsfc_wat. Also, fixed bugs in MYNN surface layer scheme for initializattion and consistent use of surface QV from RUC LSM over land and ice. --- physics/module_MYNNSFC_wrapper.F90 | 11 +- physics/module_sf_mynn.F90 | 214 ++++++++++++++++------------- 2 files changed, 126 insertions(+), 99 deletions(-) diff --git a/physics/module_MYNNSFC_wrapper.F90 b/physics/module_MYNNSFC_wrapper.F90 index 271ca5a24..9e302e26f 100644 --- a/physics/module_MYNNSFC_wrapper.F90 +++ b/physics/module_MYNNSFC_wrapper.F90 @@ -194,7 +194,7 @@ SUBROUTINE mynnsfc_wrapper_run( & real, dimension(im) :: & & hfx, znt, psim, psih, & & chs, ck, cd, mavail, xland, GZ1OZ0, & - & cpm, qgh, qfx, qsfc_ruc, snowh_wat + & cpm, qgh, qfx, snowh_wat real(kind=kind_phys), dimension(im,levs) :: & & pattern_spp_pbl, dz, th, qv @@ -249,10 +249,9 @@ SUBROUTINE mynnsfc_wrapper_run( & where (icy) znt_ice=znt_ice*0.01 ! qsfc ruc - qsfc_ruc = 0.0 if (lsm==lsm_ruc) then - where (dry) qsfc_ruc = qsfc_lnd_ruc - where (icy) qsfc_ruc = qsfc_ice_ruc + where (dry) qsfc_lnd = qsfc_lnd_ruc/(1.+qsfc_lnd_ruc) ! spec. hum + where (icy) qsfc_ice = qsfc_ice_ruc/(1.+qsfc_ice_ruc) ! spec. hum. end if ! if (lprnt) then @@ -291,7 +290,7 @@ SUBROUTINE mynnsfc_wrapper_run( & CP=cp,G=g,ROVCP=rcp,R=r_d,XLV=xlv, & SVP1=svp1,SVP2=svp2,SVP3=svp3,SVPT0=svpt0, & EP1=ep_1,EP2=ep_2,KARMAN=karman, & - ISFFLX=isfflx,isftcflx=isftcflx,LSM=lsm, & + ISFFLX=isfflx,isftcflx=isftcflx,LSM=lsm,LSM_RUC=lsm_ruc, & iz0tlnd=iz0tlnd,psi_opt=psi_opt, & & sigmaf=sigmaf,vegtype=vegtype,shdmax=shdmax,ivegsrc=ivegsrc, & !intent(in) & z0pert=z0pert,ztpert=ztpert, & !intent(in) @@ -318,7 +317,7 @@ SUBROUTINE mynnsfc_wrapper_run( & ZNT=znt,USTM=ustm,ZOL=zol,MOL=mol,RMOL=rmol, & psim=psim,psih=psih, & HFLX=hflx,HFX=hfx,QFLX=qflx,QFX=qfx,LH=lh,FLHC=flhc,FLQC=flqc, & - QGH=qgh,QSFC=qsfc,QSFC_RUC=qsfc_ruc, & + QGH=qgh,QSFC=qsfc, & U10=u10,V10=v10,TH2=th2,T2=t2,Q2=q2, & GZ1OZ0=GZ1OZ0,WSPD=wspd,wstar=wstar, & spp_pbl=spp_pbl,pattern_spp_pbl=pattern_spp_pbl, & diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90 index fc987b627..ec2c33f33 100644 --- a/physics/module_sf_mynn.F90 +++ b/physics/module_sf_mynn.F90 @@ -131,7 +131,8 @@ SUBROUTINE SFCLAY_mynn( & PSFCPA,PBLH,MAVAIL,XLAND,DX, & !in CP,G,ROVCP,R,XLV, & !in SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN, & !in - ISFFLX,isftcflx,lsm,iz0tlnd,psi_opt, & !in + ISFFLX,isftcflx,lsm,lsm_ruc, & !in + iz0tlnd,psi_opt, & !in & sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) & z0pert,ztpert, & !intent(in) & redrag,sfc_z0_type, & !intent(in) @@ -157,7 +158,7 @@ SUBROUTINE SFCLAY_mynn( & ZNT,USTM,ZOL,MOL,RMOL, & PSIM,PSIH, & HFLX,HFX,QFLX,QFX,LH,FLHC,FLQC, & - QGH,QSFC,QSFC_RUC, & + QGH,QSFC, & U10,V10,TH2,T2,Q2, & GZ1OZ0,WSPD,WSTAR, & spp_pbl,pattern_spp_pbl, & @@ -268,7 +269,7 @@ SUBROUTINE SFCLAY_mynn( & REAL, INTENT(IN) :: EP1,EP2,KARMAN REAL, INTENT(IN) :: CP,G,ROVCP,R,XLV !,DX !NAMELIST/CONFIGURATION OPTIONS: - INTEGER, INTENT(IN) :: ISFFLX, LSM + INTEGER, INTENT(IN) :: ISFFLX, LSM, LSM_RUC INTEGER, OPTIONAL, INTENT(IN) :: ISFTCFLX, IZ0TLND INTEGER, OPTIONAL, INTENT(IN) :: spp_pbl, psi_opt integer, intent(in) :: ivegsrc @@ -334,8 +335,7 @@ SUBROUTINE SFCLAY_mynn( & REAL, DIMENSION( ims:ime ), INTENT(IN) :: & & tskin_wat, tskin_lnd, tskin_ice, & & tsurf_wat, tsurf_lnd, tsurf_ice, & - & snowh_wat, snowh_lnd, snowh_ice, & - & qsfc_ruc + & snowh_wat, snowh_lnd, snowh_ice REAL, DIMENSION( ims:ime), INTENT(INOUT) :: & & ZNT_wat, ZNT_lnd, ZNT_ice, & @@ -410,22 +410,22 @@ SUBROUTINE SFCLAY_mynn( & UST_LND(i)=MAX(0.04*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001) UST_ICE(i)=MAX(0.04*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001) MOL(i)=0.0 - QSFC(i)=QV3D(i,kts)/(1.+QV3D(i,kts)) - QSFC_WAT(i)=QSFC(i) - QSFC_LND(i)=QSFC(i) - QSFC_ICE(i)=QSFC(i) qstar(i)=0.0 QFX(i)=0. HFX(i)=0. QFLX(i)=0. HFLX(i)=0. + if ( LSM == LSM_RUC ) then + !- qsfc_lnd and qsfc_ice are already available + QSFC(i)=QV3D(i,kts)/(1.+QV3D(i,kts)) + QSFC_WAT(i)=QSFC(i) + else + QSFC(i)=QV3D(i,kts)/(1.+QV3D(i,kts)) + QSFC_WAT(i)=QSFC(i) + QSFC_LND(i)=QSFC(i) + QSFC_ICE(i)=QSFC(i) + endif ! lsm==lsm_ruc ENDDO - ELSE - IF (LSM == 3) THEN - DO i=its,ite - QSFC_LND(i)=QSFC_RUC(i) - ENDDO - ENDIF ENDIF CALL SFCLAY1D_mynn( & @@ -438,7 +438,7 @@ SUBROUTINE SFCLAY_mynn( & sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) z0pert,ztpert, & !intent(in) redrag,sfc_z0_type, & !intent(in) - itimestep,iter, & + itimestep,iter,lsm,lsm_ruc, & wet, dry, icy, & !intent(in) tskin_wat, tskin_lnd, tskin_ice, & !intent(in) tsurf_wat, tsurf_lnd, tsurf_ice, & !intent(in) @@ -485,7 +485,7 @@ SUBROUTINE SFCLAY1D_mynn( & sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) z0pert,ztpert, & !intent(in) redrag,sfc_z0_type, & !intent(in) - itimestep,iter, & + itimestep,iter,lsm,lsm_ruc, & wet, dry, icy, & !intent(in) tskin_wat, tskin_lnd, tskin_ice, & !intent(in) tsurf_wat, tsurf_lnd, tsurf_ice, & !intent(in) @@ -524,7 +524,7 @@ SUBROUTINE SFCLAY1D_mynn( & INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & - J, itimestep, iter + J, itimestep, iter, lsm, lsm_ruc REAL, PARAMETER :: XKA=2.4E-5 !molecular diffusivity REAL, PARAMETER :: PRT=1. !prandlt number @@ -659,12 +659,73 @@ SUBROUTINE SFCLAY1D_mynn( & REAL :: restar,VISC,DQG,OLDUST,OLDTST !------------------------------------------------------------------- + DO I=its,ite + + IF (ITIMESTEP == 1) THEN + !initialize surface specific humidity and mixing ratios for land, ice and water + IF (wet(i)) THEN + IF (TSK_wat(I) .LT. 273.15) THEN + !SATURATION VAPOR PRESSURE WRT ICE (SVP1=.6112; 10*mb) + E1=SVP1*EXP(4648*(1./273.15 - 1./TSK_wat(I)) - & + & 11.64*LOG(273.15/TSK_wat(I)) + 0.02265*(273.15 - TSK_wat(I))) + ELSE + !SATURATION VAPOR PRESSURE WRT WATER (Bolton 1980) + E1=SVP1*EXP(SVP2*(TSK_wat(I)-SVPT0)/(TSK_wat(i)-SVP3)) + ENDIF + QSFC_wat(I)=EP2*E1/(PSFC(I)-ep_3*E1) !specific humidity + QSFCMR_wat(I)=EP2*E1/(PSFC(I)-E1) !mixing ratio + ENDIF + IF (dry(i)) THEN + if( lsm == lsm_ruc) then + QSFCMR_lnd(I)=QSFC_lnd(I)/(1.-QSFC_lnd(I)) !mixing ratio + else + TABS = 0.5*(TSK_lnd(I) + T1D(I)) + IF (TABS .LT. 273.15) THEN + !SATURATION VAPOR PRESSURE WRT ICE (SVP1=.6112; 10*mb) + E1=SVP1*EXP(4648*(1./273.15 - 1./TABS) - & + & 11.64*LOG(273.15/TABS) + 0.02265*(273.15 - TABS)) + ELSE + !SATURATION VAPOR PRESSURE WRT WATER (Bolton 1980) + E1=SVP1*EXP(SVP2*(TABS-SVPT0)/(TABS-SVP3)) + ENDIF + QSFC_lnd(I)=EP2*E1/(PSFC(I)-ep_3*E1) !specific humidity + QSFC_lnd(I)=0.5*(QSFC_lnd(I) + QSFC(I)) + QSFCMR_lnd(I)=QSFC_lnd(I)/(1.-QSFC_lnd(I)) !mixing ratio + endif ! lsm + ENDIF + IF (icy(i)) THEN + if( lsm == lsm_ruc) then + QSFCMR_ice(I)=QSFC_ice(I)/(1.-QSFC_ice(I)) !mixing ratio + else + IF (TSK_ice(I) .LT. 273.15) THEN + !SATURATION VAPOR PRESSURE WRT ICE (SVP1=.6112; 10*mb) + E1=SVP1*EXP(4648*(1./273.15 - 1./TSK_ice(I)) - & + & 11.64*LOG(273.15/TSK_ice(I)) + 0.02265*(273.15 - TSK_ice(I))) + ELSE + !SATURATION VAPOR PRESSURE WRT WATER (Bolton 1980) + E1=SVP1*EXP(SVP2*(TSK_ice(I)-SVPT0)/(TSK_ice(i)-SVP3)) + ENDIF + QSFC_ice(I)=EP2*E1/(PSFC(I)-ep_3*E1) !specific humidity + QSFCMR_ice(I)=EP2*E1/(PSFC(I)-E1) !mixing ratio + endif ! lsm + ENDIF + + ELSE + + ! Use what comes out of the LSM, NST, and CICE + IF (wet(i)) QSFCMR_wat(I)=QSFC_wat(I)/(1.-QSFC_wat(I)) + IF (dry(i)) QSFCMR_lnd(I)=QSFC_lnd(I)/(1.-QSFC_lnd(I)) + IF (icy(i)) QSFCMR_ice(I)=QSFC_ice(I)/(1.-QSFC_ice(I)) + + ENDIF + ENDDO + IF (debug_code >= 1) THEN write(0,*)"ITIMESTEP=",ITIMESTEP," iter=",iter DO I=its,ite write(0,*)"=== important input to mynnsfclayer, i:", i IF (dry(i)) THEN - write(0,*)"dry=",dry(i)," pblh=",pblh(i)," tsk=", tskin_lnd(i),& + write(0,*)"dry=",dry(i)," =",pblh(i)," tsk=", tskin_lnd(i),& " tsurf=", tsurf_lnd(i)," qsfc=", qsfc_lnd(i)," znt=", znt_lnd(i),& " ust=", ust_lnd(i)," snowh=", snowh_lnd(i)," psfcpa=",PSFCPA(i), & " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) @@ -687,26 +748,33 @@ SUBROUTINE SFCLAY1D_mynn( & DO I=its,ite ! PSFC ( in cmb) is used later in saturation checks PSFC(I)=PSFCPA(I)/1000. - ! DEFINE SKIN TEMPERATURES FOR LAND/WATER/ICE - TSK_lnd(I) = 0.5 * (tsurf_lnd(i)+tskin_lnd(i)) - TSK_ice(I) = 0.5 * (tsurf_ice(i)+tskin_ice(i)) - TSK_wat(I) = 0.5 * (tsurf_wat(i)+tskin_wat(i)) QVSH(I)=QV1D(I)/(1.+QV1D(I)) !CONVERT TO SPEC HUM (kg/kg) THCON(I)=(100000./PSFCPA(I))**ROVCP - ENDDO - - DO I=its,ite - ! CONVERT SKIN TEMPERATURES TO POTENTIAL TEMPERATURE: - THSK_lnd(I) = TSK_lnd(I)*THCON(I) !(K) - THSK_ice(I) = TSK_ice(I)*THCON(I) !(K) - THSK_wat(I) = TSK_wat(I)*THCON(I) !(K) - ENDDO - - DO I=its,ite - ! CONVERT SKIN POTENTIAL TEMPERATURES TO VIRTUAL POTENTIAL TEMPERATURE: - THVSK_lnd(I) = THSK_lnd(I)*(1.+EP1*QVSH(I)) !(K) - THVSK_ice(I) = THSK_ice(I)*(1.+EP1*QVSH(I)) !(K) - THVSK_wat(I) = THSK_wat(I)*(1.+EP1*QVSH(I)) !(K) + ! DEFINE SKIN TEMPERATURES FOR LAND/WATER/ICE + if(dry(i)) then + TSK_lnd(I) = 0.5 * (tsurf_lnd(i)+tskin_lnd(i)) + ! CONVERT SKIN TEMPERATURES TO POTENTIAL TEMPERATURE: + THSK_lnd(I) = TSK_lnd(I)*THCON(I) !(K) + THVSK_lnd(I) = THSK_lnd(I)*(1.+EP1*qsfc_lnd(I)) + if(THVSK_lnd(I) < 170. .or. THVSK_lnd(I) > 350.) & + print *,'THVSK_lnd(I)',i,THVSK_lnd(I),THSK_lnd(i),tsurf_lnd(i),tskin_lnd(i),qsfc_lnd(i) + endif + if(icy(i)) then + TSK_ice(I) = 0.5 * (tsurf_ice(i)+tskin_ice(i)) + ! CONVERT SKIN TEMPERATURES TO POTENTIAL TEMPERATURE: + THSK_ice(I) = TSK_ice(I)*THCON(I) !(K) + THVSK_ice(I) = THSK_ice(I)*(1.+EP1*qsfc_ice(I)) !(K) + if(THVSK_ice(I) < 170. .or. THVSK_ice(I) > 350.) & + print *,'THVSK_ice(I)',i,THVSK_ice(I),THSK_ice(i),tsurf_ice(i),tskin_ice(i),qsfc_ice(i) + endif + if(wet(i)) then + TSK_wat(I) = 0.5 * (tsurf_wat(i)+tskin_wat(i)) + ! CONVERT SKIN TEMPERATURES TO POTENTIAL TEMPERATURE: + THSK_wat(I) = TSK_wat(I)*THCON(I) !(K) + THVSK_wat(I) = THSK_wat(I)*(1.+EP1*QVSH(I)) !(K) + if(THVSK_wat(I) < 170. .or. THVSK_wat(I) > 350.) & + print *,'THVSK_wat(I)',i,THVSK_wat(I),THSK_wat(i),tsurf_wat(i),tskin_wat(i),qsfc_wat(i) + endif ENDDO DO I=its,ite @@ -728,6 +796,7 @@ SUBROUTINE SFCLAY1D_mynn( & GOVRTH(I)=G/TH1D(I) ENDDO + !tgs - should QFX and HFX be separate for land, ice and water? DO I=its,ite QFX(i)=QFLX(i)*RHO1D(I) HFX(i)=HFLX(i)*RHO1D(I)*cp @@ -747,56 +816,6 @@ SUBROUTINE SFCLAY1D_mynn( & ENDIF DO I=its,ite - - IF (ITIMESTEP == 1) THEN - IF (wet(i)) THEN - IF (TSK_wat(I) .LT. 273.15) THEN - !SATURATION VAPOR PRESSURE WRT ICE (SVP1=.6112; 10*mb) - E1=SVP1*EXP(4648*(1./273.15 - 1./TSK_wat(I)) - & - & 11.64*LOG(273.15/TSK_wat(I)) + 0.02265*(273.15 - TSK_wat(I))) - ELSE - !SATURATION VAPOR PRESSURE WRT WATER (Bolton 1980) - E1=SVP1*EXP(SVP2*(TSK_wat(I)-SVPT0)/(TSK_wat(i)-SVP3)) - ENDIF - QSFC_wat(I)=EP2*E1/(PSFC(I)-ep_3*E1) !specific humidity - QSFCMR_wat(I)=EP2*E1/(PSFC(I)-E1) !mixing ratio - ENDIF - IF (dry(i)) THEN - TABS = 0.5*(TSK_lnd(I) + T1D(I)) - IF (TABS .LT. 273.15) THEN - !SATURATION VAPOR PRESSURE WRT ICE (SVP1=.6112; 10*mb) - E1=SVP1*EXP(4648*(1./273.15 - 1./TABS) - & - & 11.64*LOG(273.15/TABS) + 0.02265*(273.15 - TABS)) - ELSE - !SATURATION VAPOR PRESSURE WRT WATER (Bolton 1980) - E1=SVP1*EXP(SVP2*(TABS-SVPT0)/(TABS-SVP3)) - ENDIF - QSFC_lnd(I)=EP2*E1/(PSFC(I)-ep_3*E1) !specific humidity - QSFC_lnd(I)=0.5*(QSFC_lnd(I) + QSFC(I)) - QSFCMR_lnd(I)=QSFC_lnd(I)/(1.-QSFC_lnd(I)) !mixing ratio - ENDIF - IF (icy(i)) THEN - IF (TSK_ice(I) .LT. 273.15) THEN - !SATURATION VAPOR PRESSURE WRT ICE (SVP1=.6112; 10*mb) - E1=SVP1*EXP(4648*(1./273.15 - 1./TSK_ice(I)) - & - & 11.64*LOG(273.15/TSK_ice(I)) + 0.02265*(273.15 - TSK_ice(I))) - ELSE - !SATURATION VAPOR PRESSURE WRT WATER (Bolton 1980) - E1=SVP1*EXP(SVP2*(TSK_ice(I)-SVPT0)/(TSK_ice(i)-SVP3)) - ENDIF - QSFC_ice(I)=EP2*E1/(PSFC(I)-ep_3*E1) !specific humidity - QSFCMR_ice(I)=EP2*E1/(PSFC(I)-E1) !mixing ratio - ENDIF - - ELSE - - ! Use what comes out of the LSM, NST, and CICE - IF (wet(i)) QSFCMR_wat(I)=QSFC_wat(I)/(1.-QSFC_wat(I)) - IF (dry(i)) QSFCMR_lnd(I)=QSFC_lnd(I)/(1.-QSFC_lnd(I)) - IF (icy(i)) QSFCMR_ice(I)=QSFC_ice(I)/(1.-QSFC_ice(I)) - - ENDIF - ! QGH CHANGED TO USE LOWEST-LEVEL AIR TEMP ! Q2SAT = QGH IN LSM IF (T1D(I) .LT. 273.15) THEN @@ -1194,6 +1213,7 @@ SUBROUTINE SFCLAY1D_mynn( & ENDIF !end ice point !Capture a representative ZNT + !tgs - should this be changed for fractional grid or fractional sea ice? IF (dry(i)) THEN ZNT(i)=ZNTstoch_lnd(I) ELSEIF (wet(i)) THEN @@ -1616,6 +1636,7 @@ SUBROUTINE SFCLAY1D_mynn( & ! Compute u* without vconv for use in HFX calc when isftcflx > 0 WSPDI(I)=MAX(SQRT(U1D(I)*U1D(I)+V1D(I)*V1D(I)), wmin) + !tgs - should USTM be separater for dry, icy, wet? USTM(I)=0.5*USTM(I)+0.5*KARMAN*WSPDI(I)/PSIX_wat(I) ! for possible future changes in sea-ice fraction from 0 to >0: @@ -1638,6 +1659,7 @@ SUBROUTINE SFCLAY1D_mynn( & stress_lnd(i)=ust_lnd(i)**2 !set ustm = ust over land. + !tgs - should USTM be separater for dry, icy, wet? USTM(I)=UST_lnd(I) ENDIF ! end water points @@ -1651,9 +1673,11 @@ SUBROUTINE SFCLAY1D_mynn( & stress_ice(i)=ust_ice(i)**2 !Set ustm = ust over ice. + !tgs - should USTM be separate for for dry, icy, wet? USTM(I)=UST_ice(I) ! for possible future changes in sea-ice fraction from 1 to <1: + !tgs - sea ice can be <1 now if (.not. wet(i)) ust_wat(i)=ust_ice(i) ENDIF ! end ice points @@ -1662,6 +1686,7 @@ SUBROUTINE SFCLAY1D_mynn( & !----AND COMPUTE THE MOISTURE SCALE (or q*) !---------------------------------------------------- + !tgs - should we have MOL and qstar separate for dry, icy and wet? IF (wet(I)) THEN DTG=THV1D(I)-THVSK_wat(I) OLDTST=MOL(I) @@ -1750,6 +1775,7 @@ SUBROUTINE SFCLAY1D_mynn( & ! CALCULATE THE EXCHANGE COEFFICIENTS FOR HEAT (FLHC) ! AND MOISTURE (FLQC) !------------------------------------------ + !tgs - should FLQC, FLHC be separate for dry, icy and wet? FLQC(I)=RHO1D(I)*MAVAIL(I)*UST_lnd(I)*KARMAN/PSIQ_lnd(i) FLHC(I)=RHO1D(I)*CPM(I)*UST_lnd(I)*KARMAN/PSIT_lnd(I) @@ -1757,8 +1783,8 @@ SUBROUTINE SFCLAY1D_mynn( & !---------------------------------- ! COMPUTE SURFACE MOISTURE FLUX: !---------------------------------- - !QFX(I)=FLQC(I)*(QSFCMR_lnd(I)-QV1D(I)) - QFX(I)=FLQC(I)*(QSFC_lnd(I)-QV1D(I)) + QFX(I)=FLQC(I)*(QSFCMR_lnd(I)-QV1D(I)) + !QFX(I)=FLQC(I)*(QSFC_lnd(I)-QV1D(I)) QFX(I)=MAX(QFX(I),-0.02) !allows small neg QFX LH(i)=XLV*QFX(i) ! BWG, 2020-06-17: Mod next 2 lines for fractional @@ -1778,6 +1804,8 @@ SUBROUTINE SFCLAY1D_mynn( & !TRANSFER COEFF FOR SOME LSMs: !CHS(I)=UST(I)*KARMAN/(ALOG(KARMAN*UST(I)*ZA(I) & ! /XKA+ZA(I)/ZL)-PSIH(I)) + + !tgs - should QSFC, CHS, CHS2 and CQS2 be separate for dry, icy and wet? CHS(I)=UST_lnd(I)*KARMAN/PSIT_lnd(I) !THESE ARE USED FOR 2-M DIAGNOSTICS ONLY @@ -1799,8 +1827,8 @@ SUBROUTINE SFCLAY1D_mynn( & !---------------------------------- ! COMPUTE SURFACE MOISTURE FLUX: !---------------------------------- - !QFX(I)=FLQC(I)*(QSFCMR_wat(I)-QV1D(I)) - QFX(I)=FLQC(I)*(QSFC_wat(I)-QV1D(I)) + QFX(I)=FLQC(I)*(QSFCMR_wat(I)-QV1D(I)) + !QFX(I)=FLQC(I)*(QSFC_wat(I)-QV1D(I)) QFX(I)=MAX(QFX(I),-0.02) !allows small neg QFX LH(I)=XLV*QFX(I) ! BWG, 2020-06-17: Mod next 2 lines for fractional @@ -1846,8 +1874,8 @@ SUBROUTINE SFCLAY1D_mynn( & !---------------------------------- ! COMPUTE SURFACE MOISTURE FLUX: !---------------------------------- - !QFX(I)=FLQC(I)*(QSFCMR_ice(I)-QV1D(I)) - QFX(I)=FLQC(I)*(QSFC_ice(I)-QV1D(I)) + QFX(I)=FLQC(I)*(QSFCMR_ice(I)-QV1D(I)) + !QFX(I)=FLQC(I)*(QSFC_ice(I)-QV1D(I)) QFX(I)=MAX(QFX(I),-0.02) !allows small neg QFX LH(I)=XLF*QFX(I) ! BWG, 2020-06-17: Mod next 2 lines for fractional From 75ccdc03c3b9e059505ed792b0b8387f9e569981 Mon Sep 17 00:00:00 2001 From: Tanya Smirnova Date: Mon, 1 Nov 2021 16:50:31 +0000 Subject: [PATCH 49/85] Restored modified by accident print statement. --- physics/module_sf_mynn.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90 index ec2c33f33..caf532869 100644 --- a/physics/module_sf_mynn.F90 +++ b/physics/module_sf_mynn.F90 @@ -725,7 +725,7 @@ SUBROUTINE SFCLAY1D_mynn( & DO I=its,ite write(0,*)"=== important input to mynnsfclayer, i:", i IF (dry(i)) THEN - write(0,*)"dry=",dry(i)," =",pblh(i)," tsk=", tskin_lnd(i),& + write(0,*)"dry=",dry(i)," pblh=",pblh(i)," tsk=", tskin_lnd(i),& " tsurf=", tsurf_lnd(i)," qsfc=", qsfc_lnd(i)," znt=", znt_lnd(i),& " ust=", ust_lnd(i)," snowh=", snowh_lnd(i)," psfcpa=",PSFCPA(i), & " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) From d9c7bb36f705203ef4c62c9cab4e570a4d90ebf7 Mon Sep 17 00:00:00 2001 From: Tanya Smirnova Date: Tue, 2 Nov 2021 03:22:37 +0000 Subject: [PATCH 50/85] Fixed the bug in horizontal dimension for xlon_d. --- physics/sfc_drv_ruc.meta | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/sfc_drv_ruc.meta b/physics/sfc_drv_ruc.meta index bd587c78a..e37e1ea36 100644 --- a/physics/sfc_drv_ruc.meta +++ b/physics/sfc_drv_ruc.meta @@ -742,7 +742,7 @@ standard_name = longitude_in_degree long_name = longitude in degree east units = degree_east - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in From 4155201ce26c2c62256324880cdff2e7260974e0 Mon Sep 17 00:00:00 2001 From: Tanya Smirnova Date: Tue, 2 Nov 2021 17:54:22 +0000 Subject: [PATCH 51/85] Added computations of local TSK_wat, TSK_ice and TSK_lnd at ITIMESTEP=1 before they get used. --- physics/module_sf_mynn.F90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90 index caf532869..1ddee4bca 100644 --- a/physics/module_sf_mynn.F90 +++ b/physics/module_sf_mynn.F90 @@ -664,6 +664,7 @@ SUBROUTINE SFCLAY1D_mynn( & IF (ITIMESTEP == 1) THEN !initialize surface specific humidity and mixing ratios for land, ice and water IF (wet(i)) THEN + TSK_wat(I) = 0.5 * (tsurf_wat(i)+tskin_wat(i)) IF (TSK_wat(I) .LT. 273.15) THEN !SATURATION VAPOR PRESSURE WRT ICE (SVP1=.6112; 10*mb) E1=SVP1*EXP(4648*(1./273.15 - 1./TSK_wat(I)) - & @@ -676,6 +677,7 @@ SUBROUTINE SFCLAY1D_mynn( & QSFCMR_wat(I)=EP2*E1/(PSFC(I)-E1) !mixing ratio ENDIF IF (dry(i)) THEN + TSK_lnd(I) = 0.5 * (tsurf_lnd(i)+tskin_lnd(i)) if( lsm == lsm_ruc) then QSFCMR_lnd(I)=QSFC_lnd(I)/(1.-QSFC_lnd(I)) !mixing ratio else @@ -694,6 +696,7 @@ SUBROUTINE SFCLAY1D_mynn( & endif ! lsm ENDIF IF (icy(i)) THEN + TSK_ice(I) = 0.5 * (tsurf_ice(i)+tskin_ice(i)) if( lsm == lsm_ruc) then QSFCMR_ice(I)=QSFC_ice(I)/(1.-QSFC_ice(I)) !mixing ratio else From 3c29791f04731be638e857c1be9388091ecd4722 Mon Sep 17 00:00:00 2001 From: Tanya Smirnova Date: Wed, 3 Nov 2021 14:04:25 +0000 Subject: [PATCH 52/85] Move PSFC computation to the beginning before it is used. --- physics/module_sf_mynn.F90 | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90 index 1ddee4bca..6ae052491 100644 --- a/physics/module_sf_mynn.F90 +++ b/physics/module_sf_mynn.F90 @@ -661,6 +661,9 @@ SUBROUTINE SFCLAY1D_mynn( & !------------------------------------------------------------------- DO I=its,ite + ! PSFC ( in cmb) is used later in saturation checks + PSFC(I)=PSFCPA(I)/1000. + IF (ITIMESTEP == 1) THEN !initialize surface specific humidity and mixing ratios for land, ice and water IF (wet(i)) THEN @@ -870,6 +873,9 @@ SUBROUTINE SFCLAY1D_mynn( & ! subgrid-scale velocity (VSGD) following Beljaars (1995, QJRMS) ! and Mahrt and Sun (1995, MWR), respectively !------------------------------------------------------- + !tgs - the line below could be used when hflx_wat,qflx_wat are moved from + ! Interstitial to Sfcprop + !fluxc = max(hflx_wat(i) + ep1*THVSK_wat(I)*qflx_wat(i),0.) fluxc = max(hfx(i)/RHO1D(i)/cp & & + ep1*THVSK_wat(I)*qfx(i)/RHO1D(i),0.) !WSTAR(I) = vconvc*(g/TSK(i)*pblh(i)*fluxc)**onethird @@ -902,6 +908,9 @@ SUBROUTINE SFCLAY1D_mynn( & ! subgrid-scale velocity (VSGD) following Beljaars (1995, QJRMS) ! and Mahrt and Sun (1995, MWR), respectively !------------------------------------------------------- + !tgs - the line below could be used when hflx_lnd,qflx_wat are moved from + ! Interstitial to Sfcprop + !fluxc = max(hflx_lnd(i) + ep1*THVSK_lnd(I)*qflx_lnd(i),0.) fluxc = max(hfx(i)/RHO1D(i)/cp & & + ep1*THVSK_lnd(I)*qfx(i)/RHO1D(i),0.) ! WSTAR(I) = vconvc*(g/TSK(i)*pblh(i)*fluxc)**onethird @@ -942,6 +951,9 @@ SUBROUTINE SFCLAY1D_mynn( & ! subgrid-scale velocity (VSGD) following Beljaars (1995, QJRMS) ! and Mahrt and Sun (1995, MWR), respectively !------------------------------------------------------- + !tgs - the line below could be used when hflx_ice,qflx_ice are moved from + ! Interstitial to Sfcprop + !fluxc = max(hflx_ice(i) + ep1*THVSK_ice(I)*qflx_ice(i)/RHO1D(i),0.) fluxc = max(hfx(i)/RHO1D(i)/cp & & + ep1*THVSK_ice(I)*qfx(i)/RHO1D(i),0.) ! WSTAR(I) = vconvc*(g/TSK(i)*pblh(i)*fluxc)**onethird @@ -1175,6 +1187,15 @@ SUBROUTINE SFCLAY1D_mynn( & UST_lnd(I),KARMAN,1.0,0,spp_pbl,rstoch1D(i)) ENDIF ENDIF + IF (ZNTstoch_lnd(i) < 1E-8 .OR. Zt_lnd(i) < 1E-10) THEN + write(0,*)"===(land) capture bad input in mynn sfc layer, i=:",i + write(0,*)" ZNT=", ZNTstoch_lnd(i)," ZT=",Zt_lnd(i) + write(0,*)" tsk=", tskin_lnd(i)," restar=",restar,& + " tsurf=", tsurf_lnd(i)," qsfc=", qsfc_lnd(i)," znt=", znt_lnd(i),& + " ust=", ust_lnd(i)," snowh=", snowh_lnd(i),"psfcpa=",PSFCPA(i), & + " dz=",dz8w1d(i)," qflx=",qflx_lnd(i)," hflx=",hflx_lnd(i)," hpbl=",pblh(i) + ENDIF + GZ1OZ0_lnd(I)= LOG((ZA(I)+ZNTstoch_lnd(I))/ZNTstoch_lnd(I)) GZ1OZt_lnd(I)= LOG((ZA(I)+ZNTstoch_lnd(i))/ZT_lnd(i)) From 3a037aec11a3f5ce44bda80d5fc74f5430323b43 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Fri, 5 Nov 2021 13:59:53 +0000 Subject: [PATCH 53/85] 1. Pass in flag_iter to MYNNSFC_wrapper for consistency with iterations in LSM, ice and ocean. ! when iter = 1, flag_iter = .true. for all grids ! when iter = 2, flag_iter = .true. when wind < 2 for both land and ocean (when nstf_name1 > 0) 2.Added flag_iter to all computations in MYNN surface layer scheme to avoid inconsistencies with iterations in LSM, ice andocean models. 3.Removed averaging: 0.5*(tsurf + tskin) and used tskin instead, because tsurf could be not defined. 4.Added checks on QSFC for non-defined values in LSM, ice and ocean models. If there are not defined values, compute QSFC as at itimestep=1. --- physics/module_MYNNSFC_wrapper.F90 | 14 ++++- physics/module_MYNNSFC_wrapper.meta | 8 +++ physics/module_sf_mynn.F90 | 96 +++++++++++++++++++++++------ 3 files changed, 97 insertions(+), 21 deletions(-) diff --git a/physics/module_MYNNSFC_wrapper.F90 b/physics/module_MYNNSFC_wrapper.F90 index 9e302e26f..c8c5c1db4 100644 --- a/physics/module_MYNNSFC_wrapper.F90 +++ b/physics/module_MYNNSFC_wrapper.F90 @@ -57,7 +57,7 @@ end subroutine mynnsfc_wrapper_finalize !###=================================================================== SUBROUTINE mynnsfc_wrapper_run( & & im,levs, & - & itimestep,iter, & + & itimestep,iter,flag_iter, & & flag_init,flag_restart,lsm,lsm_ruc,& & sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) & z0pert,ztpert, & !intent(in) @@ -111,6 +111,15 @@ SUBROUTINE mynnsfc_wrapper_run( & ! & EP_2 => con_eps ! USE module_sf_mynn, only : SFCLAY_mynn +!tgs - info on iterations: +! flag_iter- logical, execution or not (im) +! when iter = 1, flag_iter = .true. for all grids im ! +! when iter = 2, flag_iter = .true. when wind < 2 im ! +! for both land and ocean (when nstf_name1 > 0) im ! +! flag_guess-logical, .true.= guess step to get CD et al im ! +! when iter = 1, flag_guess = .true. when wind < 2 im ! +! when iter = 2, flag_guess = .false. for all grids im ! + !------------------------------------------------------------------- implicit none @@ -141,6 +150,7 @@ SUBROUTINE mynnsfc_wrapper_run( & integer, intent(in) :: im, levs integer, intent(in) :: iter, itimestep, lsm, lsm_ruc + logical, dimension(:), intent(in) :: flag_iter logical, intent(in) :: flag_init,flag_restart,lprnt integer, intent(in) :: ivegsrc integer, intent(in) :: sfc_z0_type ! option for calculating surface roughness length over ocean @@ -295,7 +305,7 @@ SUBROUTINE mynnsfc_wrapper_run( & & sigmaf=sigmaf,vegtype=vegtype,shdmax=shdmax,ivegsrc=ivegsrc, & !intent(in) & z0pert=z0pert,ztpert=ztpert, & !intent(in) & redrag=redrag,sfc_z0_type=sfc_z0_type, & !intent(in) - itimestep=itimestep,iter=iter, & + itimestep=itimestep,iter=iter,flag_iter=flag_iter, & wet=wet, dry=dry, icy=icy, & !intent(in) tskin_wat=tskin_wat, tskin_lnd=tskin_lnd, tskin_ice=tskin_ice, & !intent(in) tsurf_wat=tsurf_wat, tsurf_lnd=tsurf_lnd, tsurf_ice=tsurf_ice, & !intent(in) diff --git a/physics/module_MYNNSFC_wrapper.meta b/physics/module_MYNNSFC_wrapper.meta index b91a026e3..c6301ec21 100644 --- a/physics/module_MYNNSFC_wrapper.meta +++ b/physics/module_MYNNSFC_wrapper.meta @@ -69,6 +69,14 @@ type = integer 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 [flag_init] standard_name = flag_for_first_timestep long_name = flag signaling first time step for time integration loop diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90 index 6ae052491..c98dc2169 100644 --- a/physics/module_sf_mynn.F90 +++ b/physics/module_sf_mynn.F90 @@ -136,7 +136,7 @@ SUBROUTINE SFCLAY_mynn( & & sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) & z0pert,ztpert, & !intent(in) & redrag,sfc_z0_type, & !intent(in) - itimestep,iter, & !in + itimestep,iter,flag_iter, & !in wet, dry, icy, & !intent(in) tskin_wat, tskin_lnd, tskin_ice, & !intent(in) tsurf_wat, tsurf_lnd, tsurf_ice, & !intent(in) @@ -330,7 +330,7 @@ SUBROUTINE SFCLAY_mynn( & WSTAR LOGICAL, DIMENSION( ims:ime ), INTENT(IN) :: & - & wet, dry, icy +& wet, dry, icy, flag_iter REAL, DIMENSION( ims:ime ), INTENT(IN) :: & & tskin_wat, tskin_lnd, tskin_ice, & @@ -428,7 +428,7 @@ SUBROUTINE SFCLAY_mynn( & ENDDO ENDIF - CALL SFCLAY1D_mynn( & + CALL SFCLAY1D_mynn(flag_iter, & J,U1D,V1D,T1D,QV1D,P1D,dz8w1d, & U1D2,V1D2,dz2w1d, & PSFCPA,PBLH,MAVAIL,XLAND,DX, & @@ -476,7 +476,7 @@ END SUBROUTINE SFCLAY_MYNN !! which are passed to subsequent scheme to calculate the fluxes. !! This scheme has options to calculate the fluxes and near-surface !! diagnostics, as was needed in WRF, but these are skipped for FV3. - SUBROUTINE SFCLAY1D_mynn( & + SUBROUTINE SFCLAY1D_mynn(flag_iter, & J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,U1D2,V1D2,dz2w1d, & PSFCPA,PBLH,MAVAIL,XLAND,DX, & CP,G,ROVCP,R,XLV,SVP1,SVP2,SVP3,SVPT0, & @@ -580,7 +580,7 @@ SUBROUTINE SFCLAY1D_mynn( & USTM LOGICAL, DIMENSION( ims:ime ), INTENT(IN) :: & - & wet, dry, icy + & wet, dry, icy, flag_iter REAL, DIMENSION( ims:ime ), INTENT(in) :: & & tskin_wat, tskin_lnd, tskin_ice, & @@ -661,13 +661,15 @@ SUBROUTINE SFCLAY1D_mynn( & !------------------------------------------------------------------- DO I=its,ite - ! PSFC ( in cmb) is used later in saturation checks - PSFC(I)=PSFCPA(I)/1000. + ! PSFC ( in cmb) is used later in saturation checks + PSFC(I)=PSFCPA(I)/1000. + !tgs - do computations if flag_iter(i) = .true. + if ( flag_iter(i) ) then IF (ITIMESTEP == 1) THEN !initialize surface specific humidity and mixing ratios for land, ice and water IF (wet(i)) THEN - TSK_wat(I) = 0.5 * (tsurf_wat(i)+tskin_wat(i)) + TSK_wat(I) = tskin_wat(i) IF (TSK_wat(I) .LT. 273.15) THEN !SATURATION VAPOR PRESSURE WRT ICE (SVP1=.6112; 10*mb) E1=SVP1*EXP(4648*(1./273.15 - 1./TSK_wat(I)) - & @@ -678,9 +680,10 @@ SUBROUTINE SFCLAY1D_mynn( & ENDIF QSFC_wat(I)=EP2*E1/(PSFC(I)-ep_3*E1) !specific humidity QSFCMR_wat(I)=EP2*E1/(PSFC(I)-E1) !mixing ratio + IF(QSFC_wat(I)>1..or.QSFC_wat(I)<0.) print *,' QSFC_wat(I)',itimestep,i,QSFC_wat(I),TSK_wat(i) ENDIF IF (dry(i)) THEN - TSK_lnd(I) = 0.5 * (tsurf_lnd(i)+tskin_lnd(i)) + TSK_lnd(I) = tskin_lnd(i) if( lsm == lsm_ruc) then QSFCMR_lnd(I)=QSFC_lnd(I)/(1.-QSFC_lnd(I)) !mixing ratio else @@ -697,9 +700,10 @@ SUBROUTINE SFCLAY1D_mynn( & QSFC_lnd(I)=0.5*(QSFC_lnd(I) + QSFC(I)) QSFCMR_lnd(I)=QSFC_lnd(I)/(1.-QSFC_lnd(I)) !mixing ratio endif ! lsm + IF(QSFC_lnd(I)>1..or.QSFC_lnd(I)<0.) print *,' QSFC_lnd(I)',itimestep,i,QSFC_lnd(I),Tskin_lnd(i),tsurf_lnd(i),qsfc(i) ENDIF IF (icy(i)) THEN - TSK_ice(I) = 0.5 * (tsurf_ice(i)+tskin_ice(i)) + TSK_ice(I) = tskin_ice(i) if( lsm == lsm_ruc) then QSFCMR_ice(I)=QSFC_ice(I)/(1.-QSFC_ice(I)) !mixing ratio else @@ -714,16 +718,57 @@ SUBROUTINE SFCLAY1D_mynn( & QSFC_ice(I)=EP2*E1/(PSFC(I)-ep_3*E1) !specific humidity QSFCMR_ice(I)=EP2*E1/(PSFC(I)-E1) !mixing ratio endif ! lsm + IF(QSFC_ice(I)>1..or.QSFC_ice(I)<0.) print *,' QSFC_ice(I)',itimestep,i,QSFC_ice(I),TSK_ice(i) ENDIF ELSE - ! Use what comes out of the LSM, NST, and CICE + ! Use what comes out of the NST, LSM, SICE after check + IF (wet(i)) then + TSK_wat(I) = tskin_wat(i) + IF (TSK_wat(I) .LT. 273.15) THEN + !SATURATION VAPOR PRESSURE WRT ICE (SVP1=.6112; 10*mb) + E1=SVP1*EXP(4648*(1./273.15 - 1./TSK_wat(I)) - & + & 11.64*LOG(273.15/TSK_wat(I)) + 0.02265*(273.15 - TSK_wat(I))) + ELSE + !SATURATION VAPOR PRESSURE WRT WATER (Bolton 1980) + E1=SVP1*EXP(SVP2*(TSK_wat(I)-SVPT0)/(TSK_wat(i)-SVP3)) + ENDIF + QSFC_wat(I)=EP2*E1/(PSFC(I)-ep_3*E1) !specific humidity + ENDIF + IF (dry(i).and.(QSFC_lnd(I)>1..or.QSFC_lnd(I)<0.)) then + !print *,'bad QSFC_lnd(I)',itimestep,iter,i,QSFC_lnd(I),TSKin_lnd(I) + TABS = 0.5*(TSKin_lnd(I) + T1D(I)) + IF (TABS .LT. 273.15) THEN + !SATURATION VAPOR PRESSURE WRT ICE (SVP1=.6112; 10*mb) + E1=SVP1*EXP(4648*(1./273.15 - 1./TABS) - & + & 11.64*LOG(273.15/TABS) + 0.02265*(273.15 - TABS)) + ELSE + !SATURATION VAPOR PRESSURE WRT WATER (Bolton 1980) + E1=SVP1*EXP(SVP2*(TABS-SVPT0)/(TABS-SVP3)) + ENDIF + QSFC_lnd(I)=EP2*E1/(PSFC(I)-ep_3*E1) !specific humidity + QSFC_lnd(I)=0.5*(QSFC_lnd(I) + QSFC(I)) + ENDIF + IF (icy(i).and.(QSFC_ice(I)>1..or.QSFC_ice(I)<0.)) then + !print *,'bad QSFC_ice(I)',itimestep,iter,i,QSFC_ice(I),TSKin_ice(I) + IF (TSKin_ice(I) .LT. 273.15) THEN + !SATURATION VAPOR PRESSURE WRT ICE (SVP1=.6112; 10*mb) + E1=SVP1*EXP(4648*(1./273.15 - 1./TSKin_ice(I)) - & + & 11.64*LOG(273.15/TSKin_ice(I)) + 0.02265*(273.15 - TSKin_ice(I))) + ELSE + !SATURATION VAPOR PRESSURE WRT WATER (Bolton 1980) + E1=SVP1*EXP(SVP2*(TSKin_ice(I)-SVPT0)/(TSKin_ice(i)-SVP3)) + ENDIF + QSFC_ice(I)=EP2*E1/(PSFC(I)-ep_3*E1) !specific humidity + ENDIF + IF (wet(i)) QSFCMR_wat(I)=QSFC_wat(I)/(1.-QSFC_wat(I)) IF (dry(i)) QSFCMR_lnd(I)=QSFC_lnd(I)/(1.-QSFC_lnd(I)) IF (icy(i)) QSFCMR_ice(I)=QSFC_ice(I)/(1.-QSFC_ice(I)) ENDIF + endif ! flag_iter ENDDO IF (debug_code >= 1) THEN @@ -756,31 +801,36 @@ SUBROUTINE SFCLAY1D_mynn( & PSFC(I)=PSFCPA(I)/1000. QVSH(I)=QV1D(I)/(1.+QV1D(I)) !CONVERT TO SPEC HUM (kg/kg) THCON(I)=(100000./PSFCPA(I))**ROVCP + if( flag_iter(i) ) then ! DEFINE SKIN TEMPERATURES FOR LAND/WATER/ICE if(dry(i)) then - TSK_lnd(I) = 0.5 * (tsurf_lnd(i)+tskin_lnd(i)) + TSK_lnd(I) = tskin_lnd(i) + !TSK_lnd(I) = 0.5 * (tsurf_lnd(i)+tskin_lnd(i)) ! CONVERT SKIN TEMPERATURES TO POTENTIAL TEMPERATURE: THSK_lnd(I) = TSK_lnd(I)*THCON(I) !(K) THVSK_lnd(I) = THSK_lnd(I)*(1.+EP1*qsfc_lnd(I)) - if(THVSK_lnd(I) < 170. .or. THVSK_lnd(I) > 350.) & - print *,'THVSK_lnd(I)',i,THVSK_lnd(I),THSK_lnd(i),tsurf_lnd(i),tskin_lnd(i),qsfc_lnd(i) + if(THVSK_lnd(I) < 170. .or. THVSK_lnd(I) > 360.) & + print *,'THVSK_lnd(I)',itimestep,i,THVSK_lnd(I),THSK_lnd(i),tsurf_lnd(i),tskin_lnd(i),qsfc_lnd(i) endif if(icy(i)) then - TSK_ice(I) = 0.5 * (tsurf_ice(i)+tskin_ice(i)) + TSK_ice(I) = tskin_ice(i) + !TSK_ice(I) = 0.5 * (tsurf_ice(i)+tskin_ice(i)) ! CONVERT SKIN TEMPERATURES TO POTENTIAL TEMPERATURE: THSK_ice(I) = TSK_ice(I)*THCON(I) !(K) THVSK_ice(I) = THSK_ice(I)*(1.+EP1*qsfc_ice(I)) !(K) - if(THVSK_ice(I) < 170. .or. THVSK_ice(I) > 350.) & - print *,'THVSK_ice(I)',i,THVSK_ice(I),THSK_ice(i),tsurf_ice(i),tskin_ice(i),qsfc_ice(i) + if(THVSK_ice(I) < 170. .or. THVSK_ice(I) > 360.) & + print *,'THVSK_ice(I)',itimestep,i,THVSK_ice(I),THSK_ice(i),tsurf_ice(i),tskin_ice(i),qsfc_ice(i) endif if(wet(i)) then - TSK_wat(I) = 0.5 * (tsurf_wat(i)+tskin_wat(i)) + TSK_wat(I) = tskin_wat(i) + !TSK_wat(I) = 0.5 * (tsurf_wat(i)+tskin_wat(i)) ! CONVERT SKIN TEMPERATURES TO POTENTIAL TEMPERATURE: THSK_wat(I) = TSK_wat(I)*THCON(I) !(K) THVSK_wat(I) = THSK_wat(I)*(1.+EP1*QVSH(I)) !(K) - if(THVSK_wat(I) < 170. .or. THVSK_wat(I) > 350.) & + if(THVSK_wat(I) < 170. .or. THVSK_wat(I) > 360.) & print *,'THVSK_wat(I)',i,THVSK_wat(I),THSK_wat(i),tsurf_wat(i),tskin_wat(i),qsfc_wat(i) endif + endif ! flag_iter ENDDO DO I=its,ite @@ -857,6 +907,7 @@ SUBROUTINE SFCLAY1D_mynn( & ENDIF DO I=its,ite + if( flag_iter(i) ) then ! DH* 20200401 - note. A weird bug in Intel 18 on hera prevents using the ! normal -O2 optimization in REPRO and PROD mode for this file. Not reproducible ! by every user, the bug manifests itself in the resulting wind speed WSPD(I) @@ -999,6 +1050,7 @@ SUBROUTINE SFCLAY1D_mynn( & ! IF(MOL(I).LT.0.)BR(I)=MIN(BR(I),0.0) !ENDIF + endif ! flag_iter ENDDO 1006 format(A,F7.3,A,f9.4,A,f9.5,A,f9.4) @@ -1011,6 +1063,7 @@ SUBROUTINE SFCLAY1D_mynn( & !-------------------------------------------------------------------- DO I=its,ite + if( flag_iter(i) ) then !COMPUTE KINEMATIC VISCOSITY (m2/s) Andreas (1989) CRREL Rep. 89-11 !valid between -173 and 277 degrees C. @@ -1744,6 +1797,7 @@ SUBROUTINE SFCLAY1D_mynn( & qstar(I)=KARMAN*DQG/PSIQ_ice(I)/PRT ENDIF + endif ! flag_iter ENDDO ! end i-loop IF (debug_code == 2) THEN @@ -1771,6 +1825,7 @@ SUBROUTINE SFCLAY1D_mynn( & ! COMPUTE SURFACE HEAT AND MOISTURE FLUXES !---------------------------------------------------------- DO I=its,ite + if( flag_iter(i) ) then IF (ISFFLX .LT. 1) THEN @@ -1957,10 +2012,12 @@ SUBROUTINE SFCLAY1D_mynn( & ENDIF ENDIF !end ISFFLX option + endif ! flag_iter ENDDO ! end i-loop IF (compute_diag) then DO I=its,ite + if( flag_iter(i) ) then !----------------------------------------------------- !COMPUTE DIAGNOSTICS !----------------------------------------------------- @@ -2065,6 +2122,7 @@ SUBROUTINE SFCLAY1D_mynn( & Q2(I)= MAX(Q2(I), MIN(QSFC_ice(I), QV1D(I))) Q2(I)= MIN(Q2(I), 1.05*QV1D(I)) ENDIF + endif ! flag_iter ENDDO ENDIF ! end compute_diag From 19b929aa4153d142f56186a798b9c2fc0bde694c Mon Sep 17 00:00:00 2001 From: Michael Toy Date: Mon, 8 Nov 2021 22:14:38 +0000 Subject: [PATCH 54/85] Fixed sign error in SSGWD component of drag_suite.F90 --- physics/drag_suite.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/drag_suite.F90 b/physics/drag_suite.F90 index e997122f7..d2d435e4c 100644 --- a/physics/drag_suite.F90 +++ b/physics/drag_suite.F90 @@ -984,7 +984,7 @@ subroutine drag_suite_run( & MAX(0.,beta_ss*(varss(i)-varmax_ss)) ! Note: This is a semi-implicit treatment of the time differencing var_temp2 = 0.5*XNBV*xlinv(i)*(2.*var_temp)**2*ro(i,kvar) ! this is greater than zero - tauwavex0=-var_temp2*u1(i,kvar)/(1.+var_temp2*deltim) + tauwavex0=var_temp2*u1(i,kvar)/(1.+var_temp2*deltim) tauwavex0=tauwavex0*ss_taper(i) else tauwavex0=0. @@ -999,7 +999,7 @@ subroutine drag_suite_run( & MAX(0.,beta_ss*(varss(i)-varmax_ss)) ! Note: This is a semi-implicit treatment of the time differencing var_temp2 = 0.5*XNBV*xlinv(i)*(2.*var_temp)**2*ro(i,kvar) ! this is greater than zero - tauwavey0=-var_temp2*v1(i,kvar)/(1.+var_temp2*deltim) + tauwavey0=var_temp2*v1(i,kvar)/(1.+var_temp2*deltim) tauwavey0=tauwavey0*ss_taper(i) else tauwavey0=0. From 29db559173428a05c6509a7d2f886bf521dfc8ef Mon Sep 17 00:00:00 2001 From: Greg Thompson Date: Tue, 16 Nov 2021 13:44:09 -0700 Subject: [PATCH 55/85] added a new cloud fraction scheme (actually upgraded cal_cldfra3) designed with Thompson-MP for GFSv17-prototype8 --- physics/GFS_rrtmg_post.F90 | 9 +- physics/GFS_rrtmg_post.meta | 9 + physics/GFS_rrtmg_pre.F90 | 66 ++- physics/GFS_rrtmg_pre.meta | 67 ++- physics/module_mp_thompson.F90 | 4 +- physics/radiation_clouds.f | 919 ++++++++++++++++++++++----------- 6 files changed, 743 insertions(+), 331 deletions(-) diff --git a/physics/GFS_rrtmg_post.F90 b/physics/GFS_rrtmg_post.F90 index b882930bf..e0278c45e 100644 --- a/physics/GFS_rrtmg_post.F90 +++ b/physics/GFS_rrtmg_post.F90 @@ -17,7 +17,7 @@ subroutine GFS_rrtmg_post_run (im, km, kmp1, lm, ltp, kt, kb, kd, nspc1, & nfxr, nday, lsswr, lslwr, lssav, fhlwr, fhswr, raddt, coszen, & coszdg, prsi, tgrs, aerodp, cldsa, mtopa, mbota, clouds1, & cldtaulw, cldtausw, sfcflw, sfcfsw, topflw, topfsw, scmpsw, & - fluxr, errmsg, errflg) + fluxr, total_albedo, errmsg, errflg) use machine, only: kind_phys use module_radsw_parameters, only: topfsw_type, sfcfsw_type, & @@ -43,6 +43,7 @@ subroutine GFS_rrtmg_post_run (im, km, kmp1, lm, ltp, kt, kb, kd, nspc1, & real(kind=kind_phys), dimension(im,lm+LTP), intent(in) :: clouds1 real(kind=kind_phys), dimension(im,lm+LTP), intent(in) :: cldtausw real(kind=kind_phys), dimension(im,lm+LTP), intent(in) :: cldtaulw + real(kind=kind_phys), dimension(im), intent(out) :: total_albedo type(sfcflw_type), dimension(im), intent(in) :: sfcflw type(sfcfsw_type), dimension(im), intent(in) :: sfcfsw @@ -196,6 +197,12 @@ subroutine GFS_rrtmg_post_run (im, km, kmp1, lm, ltp, kt, kb, kd, nspc1, & endif endif ! end_if_lssav + +! --- The total sky (with clouds) shortwave albedo + + do i=1,im + total_albedo(i) = topfsw(i)%upfxc/topfsw(i)%dnfxc + enddo ! end subroutine GFS_rrtmg_post_run diff --git a/physics/GFS_rrtmg_post.meta b/physics/GFS_rrtmg_post.meta index 6564f5025..7a5144739 100644 --- a/physics/GFS_rrtmg_post.meta +++ b/physics/GFS_rrtmg_post.meta @@ -275,6 +275,15 @@ type = topfsw_type intent = in optional = F +[total_albedo] + standard_name = total_sky_albedo + long_name = total sky albedo at toa + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F [scmpsw] standard_name = components_of_surface_downward_shortwave_fluxes long_name = derived type for special components of surface downward shortwave fluxes diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index dbea66985..17c8fa2e7 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -34,8 +34,9 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & plvl, plyr, tlvl, tlyr, qlyr, olyr, gasvmr_co2, gasvmr_n2o, gasvmr_ch4,& gasvmr_o2, gasvmr_co, gasvmr_cfc11, gasvmr_cfc12, gasvmr_cfc22, & gasvmr_ccl4, gasvmr_cfc113, aerodp, clouds6, clouds7, clouds8, & - clouds9, cldsa, cldfra, faersw1, faersw2, faersw3, faerlw1, faerlw2, & - faerlw3, alpha, errmsg, errflg) + clouds9, cldsa, cldfra, cldfra2d, lwp_ex,iwp_ex, lwp_fc,iwp_fc, & + faersw1, faersw2, faersw3, & + faerlw1, faerlw2, faerlw3, alpha, errmsg, errflg) use machine, only: kind_phys @@ -54,6 +55,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & & progcld2, & & progcld4, progcld5, & & progcld6, & + & progcld_thompson, & & progclduni, & & cal_cldfra3, & & find_cloudLayers, & @@ -125,6 +127,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & real(kind=kind_phys), dimension(:,:), intent(inout) :: clouds1, & clouds2, clouds3, & clouds4, clouds5 + real(kind=kind_phys), dimension(:), intent(out) :: lwp_ex,iwp_ex, & + & lwp_fc,iwp_fc integer, intent(out) :: kd, kt, kb @@ -158,6 +162,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & clouds8, & clouds9, & cldfra + real(kind=kind_phys), dimension(:), intent(out) :: cldfra2d real(kind=kind_phys), dimension(:,:), intent(out) :: cldsa real(kind=kind_phys), dimension(:,:,:), intent(out) :: faersw1,& @@ -228,6 +233,15 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & LP1 = LM + 1 ! num of in/out levels + gridkm = sqrt(2.0)*sqrt(dx(1)*0.001*dx(1)*0.001) + + do i = 1, IM + lwp_ex(i) = 0.0 + iwp_ex(i) = 0.0 + lwp_fc(i) = 0.0 + iwp_fc(i) = 0.0 + enddo + ! --- ... set local /level/layer indexes corresponding to in/out ! variables @@ -637,7 +651,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo ! for Thompson MP - prepare variables for calc_effr if_thompson: if (imp_physics == imp_physics_thompson .and. ltaerosol) then - do k=1,LMK + do k=1,LM do i=1,IM qvs = qlyr(i,k) qv_mp (i,k) = qvs/(1.-qvs) @@ -652,7 +666,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo enddo elseif (imp_physics == imp_physics_thompson) then - do k=1,LMK + do k=1,LM do i=1,IM qvs = qlyr(i,k) qv_mp (i,k) = qvs/(1.-qvs) @@ -892,8 +906,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & endif enddo - gridkm = sqrt(2.0)*sqrt(dx(1)*0.001*dx(1)*0.001) - do i =1, im do k =1, lmk qc_save(i,k) = ccnd(i,k,1) @@ -903,11 +915,11 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & 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) +! 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 @@ -1031,14 +1043,26 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & else ! MYNN PBL or GF convective are not used - call progcld6 (plyr,plvl,tlyr,qlyr,qstl,rhly,tracer1, & ! --- inputs - xlat,xlon,slmsk,dz,delp, & +! 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, & +! im, lmk, lmp, uni_cld, lmfshal, lmfdeep2, & +! cldcov(:,1:LMK), effrl_inout, & +! effri_inout, effrs_inout, & +! lwp_ex, iwp_ex, lwp_fc, iwp_fc, & +! dzb, xlat_d, julian, yearlen, & +! clouds, cldsa, mtopa ,mbota, de_lgth, alpha) ! --- outputs + + call progcld_thompson (plyr,plvl,tlyr,qlyr,qstl,rhly, & ! --- inputs + tracer1,xlat,xlon,slmsk,dz,delp, & ntrac-1, ntcw-1,ntiw-1,ntrw-1, & ntsw-1,ntgl-1, & - im, lmk, lmp, uni_cld, lmfshal, lmfdeep2, & - cldcov(:,1:LMK), effrl_inout(:,:), & - effri_inout(:,:), effrs_inout(:,:), & - dzb, xlat_d, julian, yearlen, & + im, lm, lmp, uni_cld, lmfshal, lmfdeep2, & + cldcov(:,1:LM), effrl_inout, & + effri_inout, effrs_inout, & + lwp_ex, iwp_ex, lwp_fc, iwp_fc, & + dzb, xlat_d, julian, yearlen, gridkm, & clouds, cldsa, mtopa ,mbota, de_lgth, alpha) ! --- outputs endif ! MYNN PBL or GF @@ -1071,7 +1095,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo ! end_do_i_loop enddo ! end_do_k_loop endif - do k = 1, LMK + do k = 1, LM do i = 1, IM clouds1(i,k) = clouds(i,k,1) clouds2(i,k) = clouds(i,k,2) @@ -1085,6 +1109,12 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & cldfra(i,k) = clouds(i,k,1) enddo enddo + do i = 1, IM + cldfra2d(i) = 0.0 + do k = 1, LM-1 + cldfra2d(i) = max(cldfra2d(i), cldfra(i,k)) + enddo + enddo ! mg, sfc-perts ! --- scale random patterns for surface perturbations with diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 48ddc586d..6fac1ef2d 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -646,7 +646,7 @@ optional = F [sppt_amp] standard_name = total_amplitude_of_sppt_perturbation - long_name = toal ampltidue of stochastic sppt perturbation + long_name = total ampltidue of stochastic sppt perturbation units = none dimensions = () type = real @@ -755,7 +755,7 @@ standard_name = total_cloud_fraction long_name = layer total cloud fraction units = frac - dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -764,7 +764,7 @@ standard_name = cloud_liquid_water_path long_name = layer cloud liquid water path units = g m-2 - dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -773,7 +773,7 @@ standard_name = mean_effective_radius_for_liquid_cloud long_name = mean effective radius for liquid cloud units = um - dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -782,7 +782,7 @@ standard_name = cloud_ice_water_path long_name = layer cloud ice water path units = g m-2 - dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -791,7 +791,7 @@ standard_name = mean_effective_radius_for_ice_cloud long_name = mean effective radius for ice cloud units = um - dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -1056,7 +1056,7 @@ standard_name = cloud_rain_water_path long_name = cloud rain water path units = g m-2 - dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = out @@ -1065,7 +1065,7 @@ standard_name = mean_effective_radius_for_rain_drop long_name = mean effective radius for rain drop units = um - dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = out @@ -1074,7 +1074,7 @@ standard_name = cloud_snow_water_path long_name = cloud snow water path units = g m-2 - dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = out @@ -1083,7 +1083,7 @@ standard_name = mean_effective_radius_for_snow_flake long_name = mean effective radius for snow flake units = um - dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = out @@ -1101,7 +1101,52 @@ standard_name = instantaneous_3d_cloud_fraction long_name = instantaneous 3D cloud fraction for all MPs units = frac - dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[cldfra2d] + standard_name = max_in_column_cloud_fraction + long_name = instantaneous 2D (max-in-column) cloud fraction + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[lwp_ex] + standard_name = liq_water_path_from_microphysics + long_name = total liquid water path from explicit microphysics + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[iwp_ex] + standard_name = ice_water_path_from_microphysics + long_name = total ice water path from explicit microphysics + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[lwp_fc] + standard_name = liq_water_path_from_cloud_fraction + long_name = total liquid water path from cloud fraction scheme + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[iwp_fc] + standard_name = ice_water_path_from_cloud_fraction + long_name = total ice water path from cloud fraction scheme + units = kg m-2 + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index f05aa8ba2..028395285 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -2458,7 +2458,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & tau = 3.72/(rc(k)*taud) prr_wau(k) = zeta/tau prr_wau(k) = MIN(DBLE(rc(k)*odts), prr_wau(k)) - pnr_wau(k) = prr_wau(k) / (am_r*nu_c*200.*D0r*D0r*D0r) ! RAIN2M + pnr_wau(k) = prr_wau(k) / (am_r*nu_c*10.*D0r*D0r*D0r) ! RAIN2M pnc_wau(k) = MIN(DBLE(nc(k)*odts), prr_wau(k) & / (am_r*mvd_c(k)*mvd_c(k)*mvd_c(k))) ! Qc2M endif @@ -3826,7 +3826,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & t3_vts = Kap0*csg(1)*ils1**cse(1) t4_vts = Kap1*Mrat**mu_s*csg(7)*ils2**cse(7) vts = rhof(k)*av_s * (t1_vts+t2_vts)/(t3_vts+t4_vts) - if (temp(k).gt. (T_0+0.1)) then + if (prr_sml(k) .gt. 0.0) then ! vtsk(k) = MAX(vts*vts_boost(k), & ! & vts*((vtrk(k)-vts*vts_boost(k))/(temp(k)-T_0))) SR = rs(k)/(rs(k)+rr(k)) diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index dacf6e38e..39a40ed67 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -59,7 +59,7 @@ ! ! ! 'progcld4o' --- inactive ! ! ! -! 'progcld5' --- thompson/wsm6 cloud microphysics ! +! 'progcld5' --- wsm6 cloud microphysics ! ! inputs: ! ! (plyr,plvl,tlyr,qlyr,qstl,rhly,clw, ! ! xlat,xlon,slmsk, dz, delp, ! @@ -258,8 +258,28 @@ module module_radiation_clouds integer :: llyr = 2 !< upper limit of boundary layer clouds + ! Default ice crystal sizes vs. temperature following Kristjansson and Mitchell + real (kind=kind_phys), dimension(95), parameter :: retab =(/ & + & 5.92779, 6.26422, 6.61973, 6.99539, 7.39234, & + & 7.81177, 8.25496, 8.72323, 9.21800, 9.74075, 10.2930, & + & 10.8765, 11.4929, 12.1440, 12.8317, 13.5581, 14.2319, & + & 15.0351, 15.8799, 16.7674, 17.6986, 18.6744, 19.6955, & + & 20.7623, 21.8757, 23.0364, 24.2452, 25.5034, 26.8125, & + & 27.7895, 28.6450, 29.4167, 30.1088, 30.7306, 31.2943, & + & 31.8151, 32.3077, 32.7870, 33.2657, 33.7540, 34.2601, & + & 34.7892, 35.3442, 35.9255, 36.5316, 37.1602, 37.8078, & + & 38.4720, 39.1508, 39.8442, 40.5552, 41.2912, 42.0635, & + & 42.8876, 43.7863, 44.7853, 45.9170, 47.2165, 48.7221, & + & 50.4710, 52.4980, 54.8315, 57.4898, 60.4785, 63.7898, & + & 65.5604, 71.2885, 75.4113, 79.7368, 84.2351, 88.8833, & + & 93.6658, 98.5739, 103.603, 108.752, 114.025, 119.424, & + & 124.954, 130.630, 136.457, 142.446, 148.608, 154.956, & + & 161.503, 168.262, 175.248, 182.473, 189.952, 197.699, & + & 205.728, 214.055, 222.694, 231.661, 240.971, 250.639/) + public progcld1, progcld2, progcld3, progcld4, progclduni, & - & cld_init, progcld5, progcld6, progcld4o, cal_cldfra3, & + & cld_init, progcld5, progcld4o, & + & progcld6, progcld_thompson, cal_cldfra3, & & find_cloudLayers, adjust_cloudIce, adjust_cloudH2O, & & adjust_cloudFinal, gethml @@ -934,7 +954,7 @@ subroutine progcld2 & ! ================= subprogram documentation block ================ ! ! ! ! subprogram: progcld2 computes cloud related quantities using ! -! Thompson/WSM6 cloud microphysics scheme. ! +! WSM6 cloud microphysics scheme. ! ! ! ! abstract: this program computes cloud fractions from cloud ! ! condensates, ! @@ -2644,7 +2664,7 @@ subroutine progcld5 & enddo !mz* if (uni_cld) then ! use unified sgs clouds generated outside -!mz* use unified sgs or thompson clouds generated outside +!mz* use unified sgs clouds generated outside if (uni_cld .or. icloud == 3) then do k = 1, NLAY do i = 1, IX @@ -2797,7 +2817,7 @@ 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) clouds(i,k,7) = rer(i,k) !mz inflg .ne.5 clouds(i,k,8) = 0. @@ -2863,6 +2883,7 @@ subroutine progcld6 & & IX, NLAY, NLP1, & & uni_cld, lmfshal, lmfdeep2, cldcov, & & re_cloud,re_ice,re_snow, & + & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & & dzlay, latdeg, julian, yearlen, & & clouds,clds,mtop,mbot,de_lgth,alpha & ! --- outputs: & ) @@ -2956,6 +2977,8 @@ subroutine progcld6 & 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(inout) :: & + & lwp_ex, iwp_ex, lwp_fc, iwp_fc real (kind=kind_phys), dimension(:,:,:), intent(in) :: clw @@ -3063,7 +3086,7 @@ subroutine progcld6 & !> - Compute cloud liquid/ice condensate path in \f$ g/m^2 \f$ . - do k = 1, NLAY + do k = 1, NLAY-1 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)) @@ -3073,6 +3096,19 @@ subroutine progcld6 & enddo enddo +!> - Sum the liquid water and ice paths that come from explicit micro + + do i = 1, IX + lwp_ex(i) = 0.0 + iwp_ex(i) = 0.0 + lwp_fc(i) = 0.0 + iwp_fc(i) = 0.0 + do k = 1, NLAY-1 + lwp_ex(i) = lwp_ex(i) + cwp(i,k) + iwp_ex(i) = iwp_ex(i) + cip(i,k) + csp(i,k) + enddo + enddo + if (uni_cld) then ! use unified sgs clouds generated outside do k = 1, NLAY do i = 1, IX @@ -3085,54 +3121,32 @@ subroutine progcld6 & !> - 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 + do k = 1, NLAY-1 + do i = 1, IX + clwt = 1.0e-6 * (plyr(i,k)*0.001) - onemrh= max( 1.e-10, 1.0-rhly(i,k) ) - clwm = clwmin / max( 0.01, 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 ) + if (.not. lmfshal) then 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 ) -! + else 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 + + 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 ! if (uni_cld) then @@ -3222,6 +3236,364 @@ end subroutine progcld6 !mz + +! This subroutine added by G. Thompson specifically to account for +! explicit (microphysics-produced) cloud liquid water, cloud ice, and +! snow with 100% cloud fraction. Also, a parameterization for cloud +! fraction less than 1.0 but greater than 0.0 follows Mocko and Cotton +! (1996) from Sundqvist et al. (1989) with cloud fraction increasing +! as RH increases above a critical value. In locations with non-zero +! (but less than 1.0) cloud fraction, there MUST be a value assigned +! to cloud liquid water and ice or else there is zero impact in the +! RRTMG radiation scheme. + subroutine progcld_thompson & + & ( 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, & + & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & + & dzlay, latdeg, julian, yearlen, gridkm, & + & clouds,clds,mtop,mbot,de_lgth,alpha & ! --- outputs: + & ) + +! ================= subprogram documentation block ================ ! +! ! +! subprogram: progcld6 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 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) ! +! gridkm : grid length in km ! +! 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, dzlay, & + & re_cloud, re_ice, re_snow + real (kind=kind_phys), dimension(:), intent(inout) :: & + & lwp_ex, iwp_ex, lwp_fc, iwp_fc + + 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, gridkm + 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 + + real (kind=kind_phys), dimension(NLAY) :: cldfra1d, qv1d, & + & qc1d, qi1d, qs1d, dz1d, p1d, t1d + + real (kind=kind_phys) :: ptop1(IX,NK_CLDS+1), rxlat(ix) + + real (kind=kind_phys) :: clwmin, tem1 + real (kind=kind_phys) :: corr, xland, snow_mass_factor + real (kind=kind_phys), parameter :: max_relh = 1.5 + real (kind=kind_phys), parameter :: snow_max_radius = 130.0 + + integer :: i, k, id, nf, idx_rei +! +!===> ... begin here +! + + if (ivflip .ne. 1) then + STOP ' K must be bottom to top oriented by this point.' + endif + + clwmin = 1.0E-9 + + do nf=1,nf_clds + do k=1,nlay + do i=1,ix + clouds(i,k,nf) = 0.0 + enddo + enddo + enddo + + 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) + 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$ . +!> - Since using Thompson MP, assume 25 percent of snow is actually in +!! ice sizes. + + do k = 1, NLAY-1 + do i = 1, IX + cwp(i,k) = max(0.0, clw(i,k,ntcw) * dz(i,k)*1.E6) + crp(i,k) = max(0.0, clw(i,k,ntrw) * dz(i,k)*1.E6) + snow_mass_factor = 0.75 + cip(i,k) = max(0.0, (clw(i,k,ntiw) & + & + (1.0-snow_mass_factor)*clw(i,k,ntsw))*dz(i,k)*1.E6) + if (re_snow(i,k) .gt. snow_max_radius)then + snow_mass_factor = min(snow_mass_factor, & + & (snow_max_radius/re_snow(i,k)) & + & *(snow_max_radius/re_snow(i,k))) + res(i,k) = snow_max_radius + endif + csp(i,k) = max(0.,snow_mass_factor*clw(i,k,ntsw)*dz(i,k)*1.E6) + enddo + enddo + +!> - Sum the liquid water and ice paths that come from explicit micro + + do i = 1, IX + lwp_ex(i) = 0.0 + iwp_ex(i) = 0.0 + do k = 1, NLAY-1 + lwp_ex(i) = lwp_ex(i) + cwp(i,k) + iwp_ex(i) = iwp_ex(i) + cip(i,k) + csp(i,k) + enddo + enddo + +!> - Now determine the cloud fraction. Here, we will use the scheme of +!! G. Thompson that implements a variannt of Mocko and Cotton (1995) +!! based on work within HWRF and WRF. Where the bulk microphysics +!! scheme already has explicit clouds, assume cloud fraction of one, +!! but, otherwise, use a Sundqvist et al (1989) scheme and RH-critical +!! to account for sub-grid-scale clouds, include those in the water +!! and ice paths _seen_ by the radiation scheme, but do not actually +!! include these fake clouds into anything other than radiation. + + do i = 1, IX + if (slmsk(i)-0.5 .gt. 0.5 .and. slmsk(i)+0.5 .lt. 1.5) then + xland = 1.0 + else + xland = 2.0 + endif + + cldfra1d(:) = 0.0 + do k = 1, NLAY-1 + qv1d(k) = qlyr(i,k) + qc1d(k) = max(0.0, clw(i,k,ntcw)) + qi1d(k) = max(0.0, clw(i,k,ntiw)) + qs1d(k) = max(0.0, clw(i,k,ntsw)) + dz1d(k) = dz(i,k)*1.E3 + p1d(k) = plyr(i,k)*100.0 + t1d(k) = tlyr(i,k) + enddo + + call cal_cldfra3(cldfra1d, qv1d, qc1d, qi1d, qs1d, dz1d, & + & p1d, t1d, xland, gridkm, & + & .false., max_relh, 1, nlay-1, .false.) + + do k = 1, NLAY-1 + cldtot(i,k) = cldfra1d(k) + if (qc1d(k).gt.clwmin .and. cldfra1d(k).lt.ovcst) then + cwp(i,k) = qc1d(k) * dz1d(k)*1000. + if ((xland-1.5).GT.0.) then !--- Ocean + rew(i,k) = 9.5 + else !--- Land + rew(i,k) = 5.5 + endif + endif + if (qi1d(k).gt.clwmin .and. cldfra1d(k).lt.ovcst) then + cip(i,k) = qi1d(k) * dz1d(k)*1000. + idx_rei = int(t1d(k)-179.) + idx_rei = min(max(idx_rei,1),75) + corr = t1d(k) - int(t1d(k)) + rei(i,K) = max(5.0, retab(idx_rei)*(1.-corr) + & + & retab(idx_rei+1)*corr) + endif + enddo + enddo + + 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) + clouds(i,k,7) = rer(i,k) + clouds(i,k,8) = csp(i,k) + clouds(i,k,9) = res(i,k) + enddo + enddo + +!> - Sum the liquid water and ice paths that come from fractional clouds + + do i = 1, IX + lwp_fc(i) = 0.0 + iwp_fc(i) = 0.0 + do k = 1, NLAY-1 + lwp_fc(i) = lwp_fc(i) + cwp(i,k) + iwp_fc(i) = iwp_fc(i) + cip(i,k) + csp(i,k) + enddo + lwp_fc(i) = MAX(0.0, lwp_fc(i) - lwp_ex(i)) + iwp_fc(i) = MAX(0.0, iwp_fc(i) - iwp_ex(i)) + lwp_fc(i) = lwp_fc(i)*1.E-3 + iwp_fc(i) = iwp_fc(i)*1.E-3 + lwp_ex(i) = lwp_ex(i)*1.E-3 + iwp_ex(i) = iwp_ex(i)*1.E-3 + enddo + + ! Compute cloud decorrelation length + if (idcor == 1) then + call cmp_dcorr_lgth(ix, xlat, con_pi, de_lgth) + endif + if (idcor == 2) then + call cmp_dcorr_lgth(ix, latdeg, julian, yearlen, de_lgth) + endif + if (idcor == 0) then + de_lgth(:) = decorr_con + endif + + ! Call subroutine get_alpha_exp to define alpha parameter for exponential cloud overlap options + if ( iovr == 3 .or. iovr == 4 .or. iovr == 5) then + call get_alpha_exp(ix, nLay, dzlay, de_lgth, alpha) + else + de_lgth(:) = 0. + alpha(:,:) = 0. + 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, alpha, & + & IX,NLAY, & +! --- outputs: + & clds, mtop, mbot & + & ) + +! + return + +!............................................ + end subroutine progcld_thompson +!............................................ +!mz + + !> \ingroup module_radiation_clouds !> This subroutine computes cloud related quantities using !! for unified cloud microphysics scheme. @@ -4050,6 +4422,7 @@ subroutine gethml & end subroutine gethml !----------------------------------- !! @} + !+---+-----------------------------------------------------------------+ !..Cloud fraction scheme by G. Thompson (NCAR-RAL), not intended for !.. combining with any cumulus or shallow cumulus parameterization @@ -4065,249 +4438,257 @@ end subroutine gethml ! !+---+-----------------------------------------------------------------+ - 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) + SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, dz, & + & p, t, XLAND, gridkm, & + & modify_qvapor, max_relh, & + & kts,kte, debug_flag) ! 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 + INTEGER, INTENT(IN):: kts, kte + LOGICAL, INTENT(IN):: modify_qvapor + REAL, DIMENSION(kts:kte), INTENT(INOUT):: qv, qc, qi, cldfra + REAL, DIMENSION(kts:kte), INTENT(IN):: p, t, dz, qs + REAL, INTENT(IN):: gridkm, XLAND, max_relh + LOGICAL, INTENT(IN):: debug_flag !..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 + REAL:: RH_00L, RH_00O, RH_00 + REAL:: entrmnt=0.5 + INTEGER:: k + REAL:: TC, qvsi, qvsw, RHUM, delz + REAL, DIMENSION(kts:kte):: qvs, rh, rhoa + integer:: ndebug = 0 character*512 dbg_msg - LOGICAL:: debug_flag !+---+ +!..Initialize cloud fraction, compute RH, and rho-air. + + DO k = kts,kte + CLDFRA(K) = 0.0 + + qvsw = rslf(P(k), t(k)) + qvsi = rsif(P(k), t(k)) + + tc = t(k) - 273.15 + if (tc .ge. -12.0) then + qvs(k) = qvsw + elseif (tc .lt. -35.0) then + qvs(k) = qvsi + else + qvs(k) = qvsw - (qvsw-qvsi)*(-12.0-tc)/(-12.0+35.) + endif + + if (modify_qvapor) then + if (qc(k).gt.1.E-8) then + qv(k) = MAX(qv(k), qvsw) + qvs(k) = qvsw + endif + if (qc(k).le.1.E-8 .and. qi(k).ge.1.E-9) then + qv(k) = MAX(qv(k), qvsi*1.005) !..To ensure a tiny bit ice supersaturated + qvs(k) = qvsi + endif + endif + + rh(k) = MAX(0.01, qv(k)/qvs(k)) + rhoa(k) = p(k)/(287.0*t(k)) + + ENDDO + + !..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) + delz = MAX(100., dz(k)) + RH_00L = 0.63+MIN(0.36,SQRT(1./(50.0+gridkm*gridkm*delz*0.01))) + RH_00O = 0.79+MIN(0.20,SQRT(1./(50.0+gridkm*gridkm*delz*0.01))) + RHUM = rh(k) - 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 (qc(k).ge.1.E-8 .or. qi(k).ge.1.E-9 & + & .or. (qs(k).gt.1.E-6 .and. t(k).lt.273.)) then + CLDFRA(K) = 1.0 + else - IF ((XLAND(I,J)-1.5).GT.0.) THEN !--- Ocean + IF ((XLAND-1.5).GT.0.) THEN !--- Ocean RH_00 = RH_00O - ELSE !--- Land + 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))) + tc = t(k) - 273.15 + if (tc .lt. -12.0) RH_00 = RH_00L + + if (tc .gt. 20.0) then + CLDFRA(K) = 0.0 + elseif (tc .ge. -12.0) then + RHUM = MIN(rh(k), 1.0) + CLDFRA(K) = MAX(0., 1.0-SQRT((1.001-RHUM)/(1.001-RH_00))) + else + if (max_relh.gt.1.12 .or. (.NOT.(modify_qvapor)) ) then +!..For HRRR model, the following look OK. + RHUM = MIN(rh(k), 1.45) + RH_00 = RH_00 + (1.45-RH_00)*(-12.0-tc)/(-12.0+112.) + CLDFRA(K) = MAX(0.,1.0-SQRT((1.46-RHUM)/(1.46-RH_00))) + else +!..but for the GFS model, RH is way lower. + RHUM = MIN(rh(k), 1.05) + RH_00 = RH_00 + (1.05-RH_00)*(-12.0-tc)/(-12.0+112.) + CLDFRA(K) = MAX(0.,1.0-SQRT((1.06-RHUM)/(1.06-RH_00))) + endif endif - CLDFRA(I,K,J) = MIN(0.90, CLDFRA(I,K,J)) + if (CLDFRA(K).gt.0.) CLDFRA(K)=MAX(0.01,MIN(CLDFRA(K),0.99)) endif ENDDO - ENDDO - ENDDO + call find_cloudLayers(qvs, cldfra, T, P, Dz, entrmnt, & + & debug_flag, qc, qi, qs, kts,kte) -!..Prepare for a 1-D column to find various cloud layers. +!..Do a final total column adjustment since we may have added more than 1 mm +!.. LWP/IWP for multiple cloud decks. - 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 + call adjust_cloudFinal(cldfra, qc, qi, rhoa, dz, kts,kte) -! 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 +!..Last adjustment to cloud fraction already set to 1.0 when the explicit +!.. clouds are present but extremely low mixing ratios. Also, no way in this +!.. world should we permit clouds above the 70 hPa level. - 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 + DO k = kts,kte + if (cldfra(k).eq.1.0 .and. ((qc(k)+qi(k)).gt.1.E-10) .and. & + & ((qc(k)+qi(k)).lt.1.E-6)) then + CLDFRA(K) = MIN(0.99, 0.25*(10.0 + log10(qc(k)+qi(k)))) + endif + if (cldfra(k).gt.0.0 .and. p(k).gt.7000.0) CLDFRA(K) = 0.0 + if (debug_flag .and. ndebug.lt.25) then + write(6,'(a,x,i3,x,f8.2,f7.1,f7.2,f6.1,x,f5.3,f12.7,f12.7, + & f12.7)') ' DEBUG-GT: ', k, p(k)*0.01, dz(k), t(k)-273.15, & + & rh(k)*100., cldfra(k), qc(k)*1.E3, qi(k)*1.E3, qs(k)*1.E3 + if (k.eq.kte) ndebug = ndebug + 1 + endif + 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) +!..Intended for cold start model runs, we use modify_qvapor to ensure that cloudy +!.. areas are actually saturated such that the inserted clouds do not evaporate a +!.. timestep later. + if (modify_qvapor) then DO k = kts,kte - cldfra(i,k,j) = cfr1d(k) - qc(i,k,j) = qc1d(k) - qi(i,k,j) = qi1d(k) + if (cldfra(k).gt.0.2 .and. cldfra(k).lt.1.0) then + qv(k) = MAX(qv(k),qvs(k)) + endif ENDDO - ENDDO - ENDDO + endif 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, & + SUBROUTINE find_cloudLayers(qvs1d, cfr1d, T1d, P1d, Dz1d, 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 + REAL, DIMENSION(kts:kte), INTENT(IN):: qs1d,qvs1d,T1d,P1d,Dz1d + REAL, DIMENSION(kts:kte), INTENT(INOUT):: cfr1d, qc1d, qi1d !..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 + REAL, DIMENSION(kts:kte):: theta + REAL:: theta1, theta2, delz + INTEGER:: k, k2, k_tropo, k_m12C, k_cldb, k_cldt, kbot, k_p200 LOGICAL:: in_cloud character*512 dbg_msg +!+---+ k_m12C = 0 - k_m40C = 0 + k_p200 = 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) + if (T1d(k)-273.16 .gt. -12.0 .and. P1d(k).gt.10100.0) & + & k_m12C = MAX(k_m12C, k) + if (P1d(k).gt.19999.0 .and. k_p200.eq.0) k_p200 = 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 +!.. 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. +!.. k_tropo level is above 700hPa. - DO k = kte-3, kts, -1 + if ( (kte-k_p200) .lt. 3) k_p200 = kte-3 + DO k = k_p200-2, 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 + delz = 0.5*dz1d(k) + dz1d(k+1) + 0.5*dz1d(k+2) + if ( (((theta2-theta1)/delz).lt.10./1500.) .OR. & + & P1d(k).gt.70000.) EXIT 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 + k_tropo = MAX(kts+2, MIN(k+2, kte-1)) + + if (k_tropo .gt. k_p200) then + DO k = kte-3, k_p200-2, -1 + theta1 = theta(k) + theta2 = theta(k+2) + delz = 0.5*dz1d(k) + dz1d(k+1) + 0.5*dz1d(k+2) + if ( (((theta2-theta1)/delz).lt.10./1500.) .AND. & + & P1d(k).gt.9000.) EXIT + ENDDO + k_tropo = MAX(k_p200-1, MIN(k+2, kte-1)) + 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 + if (cfr1d(k).gt.0.0 .and. cfr1d(k).lt.1.0) 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. +!..Be a bit more conservative with lower cloud fraction in scenario with +!.. well-mixed convective boundary layer below LCL. - kbot = kts+2 + kbot = kts+1 DO k = kbot, k_m12C - if ( (theta(k)-theta(k-1)) .gt. 0.05E-3*dz(k)) EXIT + if ( (theta(k)-theta(k-1)) .gt. 0.010E-3*Dz1d(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. + if (cfr1d(k).gt.0.0 .and. cfr1d(k).lt.1.0) & + & cfr1d(k) = MAX(0.01,0.33*cfr1d(k)) + ENDDO + DO k = kts,k_tropo + if (cfr1d(k).gt.0.0) kbot = MIN(k,kbot) 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 +!.. 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. - +!.. 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) + DO WHILE (.not. in_cloud .AND. k.gt.k_m12C+1) k_cldt = 0 if (cfr1d(k).ge.0.01) then in_cloud = .true. @@ -4324,30 +4705,20 @@ SUBROUTINE find_cloudLayers(qvs1d, cfr1d, T1d, P1d, R1d, entrmnt, & 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, & + call adjust_cloudIce(cfr1d, qi1d, qs1d, qvs1d, T1d, Dz1d, & & 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) + elseif ((k_cldt - k_cldb + 1) .eq. 1) then + if (cfr1d(k_cldb).gt.0.and.cfr1d(k_cldb).lt.1.) & + & qi1d(k_cldb)=qi1d(k_cldb)+0.05*qvs1d(k_cldb)*cfr1d(k_cldb) + k = k_cldb endif - - k = k - 1 ENDDO - - - k_cldb = k_tropo + k_cldb = k_m12C + 5 in_cloud = .false. - k = k_m12C + 2 + k = k_m12C + 4 DO WHILE (.not. in_cloud .AND. k.gt.kbot) k_cldt = 0 if (cfr1d(k).ge.0.01) then @@ -4365,78 +4736,43 @@ SUBROUTINE find_cloudLayers(qvs1d, cfr1d, T1d, P1d, R1d, entrmnt, & 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, & + call adjust_cloudH2O(cfr1d, qc1d, qvs1d, T1d, Dz1d, & & 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) + elseif ((k_cldt - k_cldb + 1) .eq. 1) then + if (cfr1d(k_cldb).gt.0.and.cfr1d(k_cldb).lt.1.) & + & qc1d(k_cldb)=qc1d(k_cldb)+0.05*qvs1d(k_cldb)*cfr1d(k_cldb) + k = 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) + SUBROUTINE adjust_cloudIce(cfr,qi,qs,qvs,T,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 + REAL, DIMENSION(kts:kte), INTENT(IN):: cfr, qs, qvs, T, dz + REAL, DIMENSION(kts:kte), INTENT(INOUT):: qi + REAL:: iwc, max_iwc, tdz, this_iwc, this_dz + INTEGER:: k 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 + max_iwc = ABS(qvs(k2)-qvs(k1)) - iwp_exists = 0. do k = k1, k2 - iwp_exists = iwp_exists + (qi(k)+qs(k))*Rho(k)*dz(k) + max_iwc = MAX(1.E-5, max_iwc - (qi(k)+qs(k))) enddo - if (iwp_exists .gt. 1.0) RETURN + max_iwc = MIN(2.E-3, max_iwc) this_dz = 0.0 do k = k1, k2 @@ -4446,12 +4782,9 @@ SUBROUTINE adjust_cloudIce(cfr,qi,qs,qvs, T,Rho,dz, entr, k1,k2, & 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 + iwc = MAX(5.E-6, this_iwc*(1.-entr)) + if (cfr(k).gt.0.0.and.cfr(k).lt.1.0.and.T(k).ge.203.16) then + qi(k) = qi(k) + cfr(k)*cfr(k)*iwc endif enddo @@ -4459,30 +4792,28 @@ END SUBROUTINE adjust_cloudIce !+---+-----------------------------------------------------------------+ - SUBROUTINE adjust_cloudH2O(cfr, qc, qvs, T,Rho,dz, entr, k1,k2, & - & kts,kte) + SUBROUTINE adjust_cloudH2O(cfr, qc, qvs,T,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 + REAL, DIMENSION(kts:kte), INTENT(IN):: cfr, qvs, T, dz + REAL, DIMENSION(kts:kte), INTENT(INOUT):: qc + REAL:: lwc, max_lwc, tdz, this_lwc, this_dz + INTEGER:: k 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)) + max_lwc = ABS(qvs(k2)-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) + max_lwc = MAX(1.E-5, max_lwc - qc(k)) enddo - if (lwp_exists .gt. 1.0) RETURN + max_lwc = MIN(2.E-3, max_lwc) this_dz = 0.0 do k = k1, k2 @@ -4492,68 +4823,58 @@ SUBROUTINE adjust_cloudH2O(cfr, qc, qvs, T,Rho,dz, entr, k1,k2, & 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 + lwc = MAX(5.E-6, this_lwc*(1.-entr)) + if (cfr(k).gt.0.0.and.cfr(k).lt.1.0.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) + SUBROUTINE adjust_cloudFinal(cfr, qc, qi, Rho,dz, kts,kte) ! IMPLICIT NONE ! - INTEGER, INTENT(IN):: kts,kte,k_tropo + INTEGER, INTENT(IN):: kts,kte 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 + do k = kts, kte + if (cfr(k).gt.0.0 .and. cfr(k).lt.1.0) then + lwp = lwp + qc(k)*Rho(k)*dz(k) 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 + if (lwp .gt. 1.0) then + xfac = 1.0/lwp + do k = kts, kte + if (cfr(k).gt.0.0 .and. cfr(k).lt.1.0) 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 + if (iwp .gt. 1.0) then + xfac = 1.0/iwp + do k = kts, kte + if (cfr(k).gt.0.0 .and. cfr(k).lt.1.0) then qi(k) = qi(k)*xfac endif enddo endif - END SUBROUTINE adjust_cloudFinal -! + END SUBROUTINE adjust_cloudFinal! + !........................................! end module module_radiation_clouds ! !! @} From 052145c70dd0d95fa93d349be29c224a57b264d3 Mon Sep 17 00:00:00 2001 From: Greg Thompson Date: Tue, 16 Nov 2021 14:16:38 -0700 Subject: [PATCH 56/85] correct a dumb mistake --- physics/radiation_clouds.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index 39a40ed67..0c31623fd 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -4566,7 +4566,7 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, dz, & & ((qc(k)+qi(k)).lt.1.E-6)) then CLDFRA(K) = MIN(0.99, 0.25*(10.0 + log10(qc(k)+qi(k)))) endif - if (cldfra(k).gt.0.0 .and. p(k).gt.7000.0) CLDFRA(K) = 0.0 + if (cldfra(k).gt.0.0 .and. p(k).lt.7000.0) CLDFRA(K) = 0.0 if (debug_flag .and. ndebug.lt.25) then write(6,'(a,x,i3,x,f8.2,f7.1,f7.2,f6.1,x,f5.3,f12.7,f12.7, & f12.7)') ' DEBUG-GT: ', k, p(k)*0.01, dz(k), t(k)-273.15, & From 8da0705fd02df720f80cb4a1ee2330582ab3789c Mon Sep 17 00:00:00 2001 From: Greg Thompson Date: Tue, 16 Nov 2021 15:23:28 -0700 Subject: [PATCH 57/85] make icloud=3 call cldfra3 compatible with updated subroutine --- physics/GFS_rrtmg_pre.F90 | 42 +++++++++++++++++++++------------------ 1 file changed, 23 insertions(+), 19 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 17c8fa2e7..ca3bf0e70 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -196,9 +196,10 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & real(kind=kind_phys), dimension(im,lm+LTP) :: & re_cloud, re_ice, re_snow, qv_mp, qc_mp, & qi_mp, qs_mp, nc_mp, ni_mp, nwfa + real (kind=kind_phys), dimension(lm) :: cldfra1d, qv1d, & + & qc1d, qi1d, qs1d, dz1d, p1d, t1d ! for F-A MP - real(kind=kind_phys), dimension(im,lm+LTP) :: qc_save, qi_save, qs_save real(kind=kind_phys), dimension(im,lm+LTP+1) :: tem2db, hz real(kind=kind_phys), dimension(im,lm+LTP,min(4,ncnd)) :: ccnd @@ -211,6 +212,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & ! for stochastic cloud perturbations real(kind=kind_phys), dimension(im) :: cldp1d real (kind=kind_phys) :: alpha0,beta0,m,s,cldtmp,tmp_wt,cdfz + real (kind=kind_phys) :: max_relh integer :: iflag integer :: ids, ide, jds, jde, kds, kde, & @@ -906,27 +908,29 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & endif enddo + if (imp_physics == imp_physics_thompson) then + max_relh = 1.5 + else + max_relh = 1.1 + 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) + cldfra1d(:) = 0.0 + do k = 1, lm-1 + qv1d(k) = qlyr(i,k) + qc1d(k) = max(0.0, tracer1(i,k,ntcw)) + qi1d(k) = max(0.0, tracer1(i,k,ntiw)) + qs1d(k) = max(0.0, tracer1(i,k,ntsw)) + dz1d(k) = dz(i,k)*1.E3 + p1d(k) = plyr(i,k)*100.0 + t1d(k) = tlyr(i,k) 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) - - !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) + call cal_cldfra3(cldfra1d, qv1d, qc1d, qi1d, qs1d, dz1d, & + & p1d, t1d, xland(i), gridkm, & + & .false., max_relh, 1, lm-1, .false.) + do k = 1, lm-1 + cldcov(i,k) = cldfra1d(k) enddo enddo From 3787899c6e84edc1e739a91fc8a1bd773ed6f49f Mon Sep 17 00:00:00 2001 From: Greg Thompson Date: Wed, 17 Nov 2021 10:55:39 -0700 Subject: [PATCH 58/85] bug fix lwp_ex and iwp_ex inside progcld6; factor of 1000 --- physics/radiation_clouds.f | 2 ++ 1 file changed, 2 insertions(+) diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index 0c31623fd..13f0ae76b 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -3107,6 +3107,8 @@ subroutine progcld6 & lwp_ex(i) = lwp_ex(i) + cwp(i,k) iwp_ex(i) = iwp_ex(i) + cip(i,k) + csp(i,k) enddo + lwp_ex(i) = lwp_ex(i)*1.E-3 + iwp_ex(i) = iwp_ex(i)*1.E-3 enddo if (uni_cld) then ! use unified sgs clouds generated outside From 4742485d4e279c7d97f00f557ec0ba03552e5cd0 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Fri, 19 Nov 2021 15:04:38 -0700 Subject: [PATCH 59/85] Fix compilation error with gfortran in physics/radiation_clouds.f --- physics/radiation_clouds.f | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index 13f0ae76b..39296aec0 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -4570,8 +4570,8 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, dz, & endif if (cldfra(k).gt.0.0 .and. p(k).lt.7000.0) CLDFRA(K) = 0.0 if (debug_flag .and. ndebug.lt.25) then - write(6,'(a,x,i3,x,f8.2,f7.1,f7.2,f6.1,x,f5.3,f12.7,f12.7, - & f12.7)') ' DEBUG-GT: ', k, p(k)*0.01, dz(k), t(k)-273.15, & + write(6,'(a,x,i3,x,f8.2,f7.1,f7.2,f6.1,x,f5.3,f12.7,f12.7,f12.7)')& + & ' DEBUG-GT: ', k, p(k)*0.01, dz(k), t(k)-273.15, & & rh(k)*100., cldfra(k), qc(k)*1.E3, qi(k)*1.E3, qs(k)*1.E3 if (k.eq.kte) ndebug = ndebug + 1 endif From 30ae919d7dda5d816c2a6acf05c7254bd371c982 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 22 Nov 2021 06:36:21 -0700 Subject: [PATCH 60/85] Avoid dividing by zero in physics/GFS_rrtmg_post.F90 --- physics/GFS_rrtmg_post.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/physics/GFS_rrtmg_post.F90 b/physics/GFS_rrtmg_post.F90 index e0278c45e..f8a63789a 100644 --- a/physics/GFS_rrtmg_post.F90 +++ b/physics/GFS_rrtmg_post.F90 @@ -199,10 +199,10 @@ subroutine GFS_rrtmg_post_run (im, km, kmp1, lm, ltp, kt, kb, kd, nspc1, & endif ! end_if_lssav ! --- The total sky (with clouds) shortwave albedo - - do i=1,im - total_albedo(i) = topfsw(i)%upfxc/topfsw(i)%dnfxc - enddo + total_albedo = 0.0 + if (lsswr) then + where(topfsw(:)%dnfxc>0) total_albedo(:) = topfsw(:)%upfxc/topfsw(:)%dnfxc + endif ! end subroutine GFS_rrtmg_post_run From 74cae0c8fd5ec3907b45ff5b8edf2bf274ac86f2 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 22 Nov 2021 06:44:22 -0700 Subject: [PATCH 61/85] Move total albedo to right place in physics/GFS_rrtmg_post.meta, make intent(inout) --- physics/GFS_rrtmg_post.F90 | 2 +- physics/GFS_rrtmg_post.meta | 16 ++++++++-------- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/physics/GFS_rrtmg_post.F90 b/physics/GFS_rrtmg_post.F90 index f8a63789a..8584f8463 100644 --- a/physics/GFS_rrtmg_post.F90 +++ b/physics/GFS_rrtmg_post.F90 @@ -43,7 +43,7 @@ subroutine GFS_rrtmg_post_run (im, km, kmp1, lm, ltp, kt, kb, kd, nspc1, & real(kind=kind_phys), dimension(im,lm+LTP), intent(in) :: clouds1 real(kind=kind_phys), dimension(im,lm+LTP), intent(in) :: cldtausw real(kind=kind_phys), dimension(im,lm+LTP), intent(in) :: cldtaulw - real(kind=kind_phys), dimension(im), intent(out) :: total_albedo + real(kind=kind_phys), dimension(im), intent(inout) :: total_albedo type(sfcflw_type), dimension(im), intent(in) :: sfcflw type(sfcfsw_type), dimension(im), intent(in) :: sfcfsw diff --git a/physics/GFS_rrtmg_post.meta b/physics/GFS_rrtmg_post.meta index 3332589de..761affd53 100644 --- a/physics/GFS_rrtmg_post.meta +++ b/physics/GFS_rrtmg_post.meta @@ -243,14 +243,6 @@ dimensions = (horizontal_loop_extent) type = topfsw_type intent = in -[total_albedo] - standard_name = total_sky_albedo - long_name = total sky albedo at toa - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out [scmpsw] standard_name = components_of_surface_downward_shortwave_fluxes long_name = derived type for special components of surface downward shortwave fluxes @@ -266,6 +258,14 @@ type = real kind = kind_phys intent = inout +[total_albedo] + standard_name = total_sky_albedo + long_name = total sky albedo at toa + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From fe6677fe1f9a1ac115d838c7880a9eedc92d5303 Mon Sep 17 00:00:00 2001 From: Greg Thompson Date: Mon, 22 Nov 2021 09:03:53 -0700 Subject: [PATCH 62/85] minor adjustments to reduce coverage of partly cloudy conditions --- physics/radiation_clouds.f | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index 13f0ae76b..3384b1f72 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -3437,14 +3437,14 @@ subroutine progcld_thompson & enddo !> - Compute cloud liquid/ice condensate path in \f$ g/m^2 \f$ . -!> - Since using Thompson MP, assume 25 percent of snow is actually in +!> - Since using Thompson MP, assume 20 percent of snow is actually in !! ice sizes. do k = 1, NLAY-1 do i = 1, IX cwp(i,k) = max(0.0, clw(i,k,ntcw) * dz(i,k)*1.E6) crp(i,k) = max(0.0, clw(i,k,ntrw) * dz(i,k)*1.E6) - snow_mass_factor = 0.75 + snow_mass_factor = 0.80 cip(i,k) = max(0.0, (clw(i,k,ntiw) & & + (1.0-snow_mass_factor)*clw(i,k,ntsw))*dz(i,k)*1.E6) if (re_snow(i,k) .gt. snow_max_radius)then @@ -4510,11 +4510,11 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, dz, & DO k = kts,kte delz = MAX(100., dz(k)) - RH_00L = 0.63+MIN(0.36,SQRT(1./(50.0+gridkm*gridkm*delz*0.01))) + RH_00L = 0.68+MIN(0.31,SQRT(1./(50.0+gridkm*gridkm*delz*0.01))) RH_00O = 0.79+MIN(0.20,SQRT(1./(50.0+gridkm*gridkm*delz*0.01))) RHUM = rh(k) - if (qc(k).ge.1.E-8 .or. qi(k).ge.1.E-9 & + if (qc(k).ge.1.E-7 .or. qi(k).ge.1.E-7 & & .or. (qs(k).gt.1.E-6 .and. t(k).lt.273.)) then CLDFRA(K) = 1.0 else @@ -4569,9 +4569,10 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, dz, & CLDFRA(K) = MIN(0.99, 0.25*(10.0 + log10(qc(k)+qi(k)))) endif if (cldfra(k).gt.0.0 .and. p(k).lt.7000.0) CLDFRA(K) = 0.0 + if (debug_flag .and. ndebug.lt.25) then - write(6,'(a,x,i3,x,f8.2,f7.1,f7.2,f6.1,x,f5.3,f12.7,f12.7, - & f12.7)') ' DEBUG-GT: ', k, p(k)*0.01, dz(k), t(k)-273.15, & + write(6,'(a,i3,f9.2,f7.1,f7.2,f6.1,f6.3,f12.7,f12.7,f12.7)') & + & ' DEBUG-GT: ', k, p(k)*0.01, dz(k), t(k)-273.15, & & rh(k)*100., cldfra(k), qc(k)*1.E3, qi(k)*1.E3, qs(k)*1.E3 if (k.eq.kte) ndebug = ndebug + 1 endif From b4d7ab0694eba3a49bad228cc5807bf2ac0722c2 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 22 Nov 2021 13:49:29 -0700 Subject: [PATCH 63/85] Use correct vertical dimension for several cloud arrays in physics/GFS_rrtmg_post.meta and physics/GFS_rrtmg_pre.meta --- physics/GFS_rrtmg_post.meta | 2 +- physics/GFS_rrtmg_pre.meta | 20 ++++++++++---------- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/physics/GFS_rrtmg_post.meta b/physics/GFS_rrtmg_post.meta index 761affd53..6cff0cad4 100644 --- a/physics/GFS_rrtmg_post.meta +++ b/physics/GFS_rrtmg_post.meta @@ -195,7 +195,7 @@ standard_name = total_cloud_fraction long_name = layer total cloud fraction units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) + dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) type = real kind = kind_phys intent = in diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 3debc33e4..85f29dc9c 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -667,7 +667,7 @@ standard_name = total_cloud_fraction long_name = layer total cloud fraction units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) + dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) type = real kind = kind_phys intent = inout @@ -675,7 +675,7 @@ standard_name = cloud_liquid_water_path long_name = layer cloud liquid water path units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) + dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) type = real kind = kind_phys intent = inout @@ -683,7 +683,7 @@ standard_name = mean_effective_radius_for_liquid_cloud long_name = mean effective radius for liquid cloud units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) + dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) type = real kind = kind_phys intent = inout @@ -691,7 +691,7 @@ standard_name = cloud_ice_water_path long_name = layer cloud ice water path units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) + dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) type = real kind = kind_phys intent = inout @@ -699,7 +699,7 @@ standard_name = mean_effective_radius_for_ice_cloud long_name = mean effective radius for ice cloud units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) + dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) type = real kind = kind_phys intent = inout @@ -934,7 +934,7 @@ standard_name = cloud_rain_water_path long_name = cloud rain water path units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) + dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) type = real kind = kind_phys intent = out @@ -942,7 +942,7 @@ standard_name = mean_effective_radius_for_rain_drop long_name = mean effective radius for rain drop units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) + dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) type = real kind = kind_phys intent = out @@ -950,7 +950,7 @@ standard_name = cloud_snow_water_path long_name = cloud snow water path units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) + dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) type = real kind = kind_phys intent = out @@ -958,7 +958,7 @@ standard_name = mean_effective_radius_for_snow_flake long_name = mean effective radius for snow flake units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) + dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) type = real kind = kind_phys intent = out @@ -974,7 +974,7 @@ standard_name = instantaneous_3d_cloud_fraction long_name = instantaneous 3D cloud fraction for all MPs units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) + dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) type = real kind = kind_phys intent = out From 6f91aea381633b45dea5d172354713a2079f1fc0 Mon Sep 17 00:00:00 2001 From: Greg Thompson Date: Tue, 23 Nov 2021 09:26:49 -0700 Subject: [PATCH 64/85] silly stray comment/exclamation point --- physics/radiation_clouds.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index 3384b1f72..114bd3108 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -4876,7 +4876,7 @@ SUBROUTINE adjust_cloudFinal(cfr, qc, qi, Rho,dz, kts,kte) enddo endif - END SUBROUTINE adjust_cloudFinal! + END SUBROUTINE adjust_cloudFinal !........................................! end module module_radiation_clouds ! From 211a41311a9ef07e86e84d157e9cb569d729f4b0 Mon Sep 17 00:00:00 2001 From: Greg Thompson Date: Tue, 23 Nov 2021 09:29:46 -0700 Subject: [PATCH 65/85] fix a few comment lines per review of pull request 781 --- physics/radiation_clouds.f | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index 114bd3108..be45b0b50 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -3262,8 +3262,8 @@ subroutine progcld_thompson & ! ================= subprogram documentation block ================ ! ! ! -! subprogram: progcld6 computes cloud related quantities using ! -! Thompson/WSM6 cloud microphysics scheme. ! +! subprogram: progcld_thompson computes cloud related quantities ! +! using Thompson cloud microphysics scheme. ! ! ! ! abstract: this program computes cloud fractions from cloud ! ! condensates, ! @@ -3272,7 +3272,7 @@ subroutine progcld_thompson & ! top and base. the three vertical cloud domains are set up in the ! ! initial subroutine "cld_init". ! ! ! -! usage: call progcld6 ! +! usage: call progcld_thompson ! ! ! ! subprograms called: gethml ! ! ! From 0a54eecbebb14140685c8c9e0203cf30ca2b0a7e Mon Sep 17 00:00:00 2001 From: Greg Thompson Date: Tue, 23 Nov 2021 09:39:33 -0700 Subject: [PATCH 66/85] per discussions with Ruiyu, increasing min snow and graupel size seems advantageous --- physics/module_mp_thompson.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index 271535581..353f83c78 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -149,7 +149,7 @@ MODULE module_mp_thompson REAL, PARAMETER, PRIVATE:: fv_s = 100.0 REAL, PARAMETER, PRIVATE:: av_g = 442.0 REAL, PARAMETER, PRIVATE:: bv_g = 0.89 - REAL, PARAMETER, PRIVATE:: av_i = 1847.5 + REAL, PARAMETER, PRIVATE:: av_i = 1493.9 REAL, PARAMETER, PRIVATE:: bv_i = 1.0 REAL, PARAMETER, PRIVATE:: av_c = 0.316946E8 REAL, PARAMETER, PRIVATE:: bv_c = 2.0 @@ -214,8 +214,8 @@ MODULE module_mp_thompson REAL, PARAMETER, PRIVATE:: xm0i = 1.E-12 REAL, PARAMETER, PRIVATE:: D0c = 1.E-6 REAL, PARAMETER, PRIVATE:: D0r = 50.E-6 - REAL, PARAMETER, PRIVATE:: D0s = 200.E-6 - REAL, PARAMETER, PRIVATE:: D0g = 250.E-6 + REAL, PARAMETER, PRIVATE:: D0s = 300.E-6 + REAL, PARAMETER, PRIVATE:: D0g = 350.E-6 REAL, PRIVATE:: D0i, xm0s, xm0g !..Min and max radiative effective radius of cloud water, cloud ice, and snow; From 112077914442e3555effbba0a4a231483206ce8a Mon Sep 17 00:00:00 2001 From: Greg Thompson Date: Tue, 23 Nov 2021 10:03:08 -0700 Subject: [PATCH 67/85] tiny adjustment of indent/format consistency --- physics/GFS_rrtmg_pre.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index ca3bf0e70..3ffc0d1be 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -35,8 +35,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & gasvmr_o2, gasvmr_co, gasvmr_cfc11, gasvmr_cfc12, gasvmr_cfc22, & gasvmr_ccl4, gasvmr_cfc113, aerodp, clouds6, clouds7, clouds8, & clouds9, cldsa, cldfra, cldfra2d, lwp_ex,iwp_ex, lwp_fc,iwp_fc, & - faersw1, faersw2, faersw3, & - faerlw1, faerlw2, faerlw3, alpha, errmsg, errflg) + faersw1, faersw2, faersw3, faerlw1, faerlw2, faerlw3, alpha, & + errmsg, errflg) use machine, only: kind_phys @@ -653,7 +653,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo ! for Thompson MP - prepare variables for calc_effr if_thompson: if (imp_physics == imp_physics_thompson .and. ltaerosol) then - do k=1,LM + do k=1,LMK do i=1,IM qvs = qlyr(i,k) qv_mp (i,k) = qvs/(1.-qvs) @@ -668,7 +668,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo enddo elseif (imp_physics == imp_physics_thompson) then - do k=1,LM + do k=1,LMK do i=1,IM qvs = qlyr(i,k) qv_mp (i,k) = qvs/(1.-qvs) From 7e119fc859eb7c3fe705538e2da701b5a9dad2f5 Mon Sep 17 00:00:00 2001 From: Greg Thompson Date: Tue, 23 Nov 2021 11:00:23 -0700 Subject: [PATCH 68/85] re-use icloud=3 option for progcld_thompson --- physics/GFS_rrtmg_pre.F90 | 131 +++++++++++--------------------------- 1 file changed, 37 insertions(+), 94 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 3ffc0d1be..722ada210 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -237,6 +237,12 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & gridkm = sqrt(2.0)*sqrt(dx(1)*0.001*dx(1)*0.001) + if (imp_physics == imp_physics_thompson) then + max_relh = 1.5 + else + max_relh = 1.1 + endif + do i = 1, IM lwp_ex(i) = 0.0 iwp_ex(i) = 0.0 @@ -870,88 +876,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo endif - !mz HWRF physics: icloud=3 - if(icloud == 3) then - - ! Set internal dimensions - ids = 1 - ims = 1 - its = 1 - ide = size(xlon,1) - ime = size(xlon,1) - ite = size(xlon,1) - jds = 1 - jms = 1 - jts = 1 - jde = 1 - jme = 1 - jte = 1 - kds = 1 - kms = 1 - kts = 1 - kde = lm+LTP ! should this be lmk instead of lm? no, or? - kme = lm+LTP - kte = lm+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 (slmsk(i)==1. .or. 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 - - if (imp_physics == imp_physics_thompson) then - max_relh = 1.5 - else - max_relh = 1.1 - endif - - do i =1, im - cldfra1d(:) = 0.0 - do k = 1, lm-1 - qv1d(k) = qlyr(i,k) - qc1d(k) = max(0.0, tracer1(i,k,ntcw)) - qi1d(k) = max(0.0, tracer1(i,k,ntiw)) - qs1d(k) = max(0.0, tracer1(i,k,ntsw)) - dz1d(k) = dz(i,k)*1.E3 - p1d(k) = plyr(i,k)*100.0 - t1d(k) = tlyr(i,k) - enddo - - call cal_cldfra3(cldfra1d, qv1d, qc1d, qi1d, qs1d, dz1d, & - & p1d, t1d, xland(i), gridkm, & - & .false., max_relh, 1, lm-1, .false.) - do k = 1, lm-1 - cldcov(i,k) = cldfra1d(k) - enddo - enddo - - endif ! icloud == 3 - - if (lextop) then - do i=1,im - cldcov(i,lyb) = cldcov(i,lya) - deltaq(i,lyb) = deltaq(i,lya) - cnvw (i,lyb) = cnvw (i,lya) - cnvc (i,lyb) = cnvc (i,lya) - enddo - if (effr_in) then - do i=1,im - effrl(i,lyb) = effrl(i,lya) - effri(i,lyb) = effri(i,lya) - effrr(i,lyb) = effrr(i,lya) - effrs(i,lyb) = effrs(i,lya) - enddo - endif - endif if (imp_physics == imp_physics_zhao_carr) then ccnd(1:IM,1:LMK,1) = ccnd(1:IM,1:LMK,1) + cnvw(1:IM,1:LMK) @@ -1028,6 +952,20 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & elseif(imp_physics == imp_physics_thompson) then ! Thompson MP if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf ) then ! MYNN PBL or GF conv + + if (icloud .eq. 3) then + call progcld_thompson (plyr,plvl,tlyr,qlyr,qstl,rhly, & ! --- inputs + tracer1,xlat,xlon,slmsk,dz,delp, & + ntrac-1, ntcw-1,ntiw-1,ntrw-1, & + ntsw-1,ntgl-1, & + im, lm, lmp, uni_cld, lmfshal, lmfdeep2, & + cldcov(:,1:LM), effrl_inout, & + effri_inout, effrs_inout, & + lwp_ex, iwp_ex, lwp_fc, iwp_fc, & + dzb, xlat_d, julian, yearlen, gridkm, & + clouds, cldsa, mtopa ,mbota, de_lgth, alpha) ! --- outputs + else + !-- MYNN PBL or convective GF !-- use cloud fractions with SGS clouds do k=1,lmk @@ -1044,21 +982,13 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & effrl, effri, effrr, effrs, effr_in , & dzb, xlat_d, julian, yearlen, & clouds, cldsa, mtopa, mbota, de_lgth, alpha) ! --- outputs + endif else ! MYNN PBL or GF convective are not used -! 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, & -! im, lmk, lmp, uni_cld, lmfshal, lmfdeep2, & -! cldcov(:,1:LMK), effrl_inout, & -! effri_inout, effrs_inout, & -! lwp_ex, iwp_ex, lwp_fc, iwp_fc, & -! dzb, xlat_d, julian, yearlen, & -! clouds, cldsa, mtopa ,mbota, de_lgth, alpha) ! --- outputs - - call progcld_thompson (plyr,plvl,tlyr,qlyr,qstl,rhly, & ! --- inputs + + if (icloud .eq. 3) then + call progcld_thompson (plyr,plvl,tlyr,qlyr,qstl,rhly, & ! --- inputs tracer1,xlat,xlon,slmsk,dz,delp, & ntrac-1, ntcw-1,ntiw-1,ntrw-1, & ntsw-1,ntgl-1, & @@ -1068,6 +998,19 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & dzb, xlat_d, julian, yearlen, gridkm, & clouds, cldsa, mtopa ,mbota, de_lgth, alpha) ! --- outputs + + else + call progcld6 (plyr,plvl,tlyr,qlyr,qstl,rhly, & ! --- inputs + tracer1,xlat,xlon,slmsk,dz,delp, & + ntrac-1, ntcw-1,ntiw-1,ntrw-1, & + ntsw-1,ntgl-1, & + im, lmk, lmp, uni_cld, lmfshal, lmfdeep2, & + cldcov(:,1:LMK), effrl_inout, & + effri_inout, effrs_inout, & + lwp_ex, iwp_ex, lwp_fc, iwp_fc, & + dzb, xlat_d, julian, yearlen, & + clouds, cldsa, mtopa ,mbota, de_lgth, alpha) ! --- outputs + endif endif ! MYNN PBL or GF endif ! end if_imp_physics From bc8c26d8796767d0b2b2c648a8fa31200e3d0e81 Mon Sep 17 00:00:00 2001 From: Greg Thompson Date: Tue, 23 Nov 2021 16:50:44 -0700 Subject: [PATCH 69/85] per review by climbfuji, make suggested changes --- physics/GFS_rrtmg_pre.F90 | 4 ++-- physics/radiation_clouds.f | 46 +++++++++++++++++++++++--------------- 2 files changed, 30 insertions(+), 20 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 722ada210..973ac02fd 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -953,7 +953,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf ) then ! MYNN PBL or GF conv - if (icloud .eq. 3) then + if (icloud == 3) then call progcld_thompson (plyr,plvl,tlyr,qlyr,qstl,rhly, & ! --- inputs tracer1,xlat,xlon,slmsk,dz,delp, & ntrac-1, ntcw-1,ntiw-1,ntrw-1, & @@ -987,7 +987,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & else ! MYNN PBL or GF convective are not used - if (icloud .eq. 3) then + if (icloud == 3) then call progcld_thompson (plyr,plvl,tlyr,qlyr,qstl,rhly, & ! --- inputs tracer1,xlat,xlon,slmsk,dz,delp, & ntrac-1, ntcw-1,ntiw-1,ntrw-1, & diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index be45b0b50..e6e11131a 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -2665,7 +2665,7 @@ subroutine progcld5 & !mz* if (uni_cld) then ! use unified sgs clouds generated outside !mz* use unified sgs clouds generated outside - if (uni_cld .or. icloud == 3) then + if (uni_cld) then do k = 1, NLAY do i = 1, IX cldtot(i,k) = cldcov(i,k) @@ -3385,15 +3385,11 @@ subroutine progcld_thompson & real (kind=kind_phys), parameter :: max_relh = 1.5 real (kind=kind_phys), parameter :: snow_max_radius = 130.0 - integer :: i, k, id, nf, idx_rei + integer :: i, k, k2, id, nf, idx_rei ! !===> ... begin here ! - if (ivflip .ne. 1) then - STOP ' K must be bottom to top oriented by this point.' - endif - clwmin = 1.0E-9 do nf=1,nf_clds @@ -3485,21 +3481,35 @@ subroutine progcld_thompson & endif cldfra1d(:) = 0.0 - do k = 1, NLAY-1 - qv1d(k) = qlyr(i,k) - qc1d(k) = max(0.0, clw(i,k,ntcw)) - qi1d(k) = max(0.0, clw(i,k,ntiw)) - qs1d(k) = max(0.0, clw(i,k,ntsw)) - dz1d(k) = dz(i,k)*1.E3 - p1d(k) = plyr(i,k)*100.0 - t1d(k) = tlyr(i,k) - enddo + + if (ivflip .eq. 1) then + do k = 1, NLAY + qv1d(k) = qlyr(i,k) + qc1d(k) = max(0.0, clw(i,k,ntcw)) + qi1d(k) = max(0.0, clw(i,k,ntiw)) + qs1d(k) = max(0.0, clw(i,k,ntsw)) + dz1d(k) = dz(i,k)*1.E3 + p1d(k) = plyr(i,k)*100.0 + t1d(k) = tlyr(i,k) + enddo + else + do k = NLAY, 1, -1 + k2 = NLAY - k + 1 + qv1d(k2) = qlyr(i,k) + qc1d(k2) = max(0.0, clw(i,k,ntcw)) + qi1d(k2) = max(0.0, clw(i,k,ntiw)) + qs1d(k2) = max(0.0, clw(i,k,ntsw)) + dz1d(k2) = dz(i,k)*1.E3 + p1d(k2) = plyr(i,k)*100.0 + t1d(k2) = tlyr(i,k) + enddo + endif call cal_cldfra3(cldfra1d, qv1d, qc1d, qi1d, qs1d, dz1d, & & p1d, t1d, xland, gridkm, & - & .false., max_relh, 1, nlay-1, .false.) + & .false., max_relh, 1, nlay, .false.) - do k = 1, NLAY-1 + do k = 1, NLAY cldtot(i,k) = cldfra1d(k) if (qc1d(k).gt.clwmin .and. cldfra1d(k).lt.ovcst) then cwp(i,k) = qc1d(k) * dz1d(k)*1000. @@ -3539,7 +3549,7 @@ subroutine progcld_thompson & do i = 1, IX lwp_fc(i) = 0.0 iwp_fc(i) = 0.0 - do k = 1, NLAY-1 + do k = 1, NLAY lwp_fc(i) = lwp_fc(i) + cwp(i,k) iwp_fc(i) = iwp_fc(i) + cip(i,k) + csp(i,k) enddo From 2b2e3b195d47ed2bdea7ffc99e5183d467ad2b62 Mon Sep 17 00:00:00 2001 From: Greg Thompson Date: Wed, 24 Nov 2021 12:04:23 -0700 Subject: [PATCH 70/85] disallow rain in Thompson to be used in radiation scheme; also set fractional cloudy LWP and IWP inside progcld6 --- physics/radiation_clouds.f | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index e6e11131a..c5b94053c 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -3164,6 +3164,18 @@ subroutine progcld6 & enddo enddo + ! What portion of water and ice contents is associated with the partly cloudy boxes + do i = 1, IX + do k = 1, NLAY-1 + if (cldtot(i,k).ge.climit .and. cldtot(i,k).lt.ovcst) then + lwp_fc(i) = lwp_fc(i) + cwp(i,k) + iwp_fc(i) = iwp_fc(i) + cip(i,k) + csp(i,k) + endif + enddo + lwp_fc(i) = lwp_fc(i)*1.E-3 + iwp_fc(i) = iwp_fc(i)*1.E-3 + enddo + if ( lcnorm ) then do k = 1, NLAY do i = 1, IX @@ -3439,7 +3451,7 @@ subroutine progcld_thompson & do k = 1, NLAY-1 do i = 1, IX cwp(i,k) = max(0.0, clw(i,k,ntcw) * dz(i,k)*1.E6) - crp(i,k) = max(0.0, clw(i,k,ntrw) * dz(i,k)*1.E6) + crp(i,k) = 0.0 snow_mass_factor = 0.80 cip(i,k) = max(0.0, (clw(i,k,ntiw) & & + (1.0-snow_mass_factor)*clw(i,k,ntsw))*dz(i,k)*1.E6) From 7d0d7364007310a28afc3ae6af97df73a73c0eb3 Mon Sep 17 00:00:00 2001 From: Greg Thompson Date: Fri, 26 Nov 2021 09:45:52 -0700 Subject: [PATCH 71/85] minor rearrangement of cloud fraction with very low mixing ratios --- physics/radiation_clouds.f | 26 ++++++++++---------------- 1 file changed, 10 insertions(+), 16 deletions(-) diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index c5b94053c..e73f91ea2 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -4536,9 +4536,12 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, dz, & RH_00O = 0.79+MIN(0.20,SQRT(1./(50.0+gridkm*gridkm*delz*0.01))) RHUM = rh(k) - if (qc(k).ge.1.E-7 .or. qi(k).ge.1.E-7 & + if (qc(k).ge.1.E-6 .or. qi(k).ge.1.E-6 & & .or. (qs(k).gt.1.E-6 .and. t(k).lt.273.)) then CLDFRA(K) = 1.0 + elseif (((qc(k)+qi(k)).gt.1.E-10) .and. & + & ((qc(k)+qi(k)).lt.1.E-6)) then + CLDFRA(K) = MIN(0.99, 0.25*(10.0 + log10(qc(k)+qi(k)))) else IF ((XLAND-1.5).GT.0.) THEN !--- Ocean @@ -4571,6 +4574,7 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, dz, & if (CLDFRA(K).gt.0.) CLDFRA(K)=MAX(0.01,MIN(CLDFRA(K),0.99)) endif + if (cldfra(k).gt.0.0 .and. p(k).lt.7000.0) CLDFRA(K) = 0.0 ENDDO call find_cloudLayers(qvs, cldfra, T, P, Dz, entrmnt, & @@ -4581,24 +4585,14 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, dz, & call adjust_cloudFinal(cldfra, qc, qi, rhoa, dz, kts,kte) -!..Last adjustment to cloud fraction already set to 1.0 when the explicit -!.. clouds are present but extremely low mixing ratios. Also, no way in this -!.. world should we permit clouds above the 70 hPa level. - - DO k = kts,kte - if (cldfra(k).eq.1.0 .and. ((qc(k)+qi(k)).gt.1.E-10) .and. & - & ((qc(k)+qi(k)).lt.1.E-6)) then - CLDFRA(K) = MIN(0.99, 0.25*(10.0 + log10(qc(k)+qi(k)))) - endif - if (cldfra(k).gt.0.0 .and. p(k).lt.7000.0) CLDFRA(K) = 0.0 - - if (debug_flag .and. ndebug.lt.25) then + if (debug_flag .and. ndebug.lt.25) then + do k = kts,kte write(6,'(a,i3,f9.2,f7.1,f7.2,f6.1,f6.3,f12.7,f12.7,f12.7)') & & ' DEBUG-GT: ', k, p(k)*0.01, dz(k), t(k)-273.15, & & rh(k)*100., cldfra(k), qc(k)*1.E3, qi(k)*1.E3, qs(k)*1.E3 - if (k.eq.kte) ndebug = ndebug + 1 - endif - ENDDO + enddo + ndebug = ndebug + 1 + endif !..Intended for cold start model runs, we use modify_qvapor to ensure that cloudy !.. areas are actually saturated such that the inserted clouds do not evaporate a From 79d8adeabfa9ea9d4abbcd69d23adb6f568fbaea Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 29 Nov 2021 07:55:33 -0700 Subject: [PATCH 72/85] Adjust format statement in physics/mp_thompson.F90 --- physics/mp_thompson.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/mp_thompson.F90 b/physics/mp_thompson.F90 index c31d90b09..1e0895140 100644 --- a/physics/mp_thompson.F90 +++ b/physics/mp_thompson.F90 @@ -506,7 +506,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & dtstep = dtp end if if (first_time_step .and. istep==1 .and. mpirank==mpiroot .and. blkno==1) then - write(*,'(a,i0,a,a,f6.2,a)') 'Thompson MP is using ', nsteps, ' substep(s) per time step', & + write(*,'(a,i0,a,a,f8.2,a)') 'Thompson MP is using ', nsteps, ' substep(s) per time step', & ' with an effective time step of ', dtstep, ' seconds' end if From 2522f2ea53c1f63b8075120569a3cd4b81d468c9 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 29 Nov 2021 07:55:54 -0700 Subject: [PATCH 73/85] Update GFS_debug.F90, add GFS_checktracers debugging routine --- physics/GFS_debug.F90 | 141 +++++++++++++++++++-- physics/GFS_debug.meta | 278 +++++++++++++++++++++++++++++++++++++++++ 2 files changed, 408 insertions(+), 11 deletions(-) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 094037f5f..a1ac44e53 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -695,7 +695,7 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%tdoms ', Diag%tdoms) ! CCPP/RUC only if (Model%lsm == Model%lsm_ruc) then - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%wet1 ', Sfcprop%wetness) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%wetness ', Sfcprop%wetness) else call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%wet1 ', Diag%wet1) end if @@ -1310,18 +1310,12 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%scmpsw%nirdf ', Interstitial%scmpsw%nirdf ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%scmpsw%visbm ', Interstitial%scmpsw%visbm ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%scmpsw%visdf ', Interstitial%scmpsw%visdf ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%semis_ice ', Interstitial%semis_ice ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%semis_land ', Interstitial%semis_land ) -! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%semis_water ', Interstitial%semis_water ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%sfcalb ', Interstitial%sfcalb ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%sigma ', Interstitial%sigma ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%sigmaf ', Interstitial%sigmaf ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%sigmafrac ', Interstitial%sigmafrac ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%sigmatot ', Interstitial%sigmatot ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowc ', Interstitial%snowc ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowd_ice ', Interstitial%snowd_ice ) -! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowd_land ', Interstitial%snowd_land ) -! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowd_water ', Interstitial%snowd_water ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snohf ', Interstitial%snohf ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowmt ', Interstitial%snowmt ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%stress ', Interstitial%stress ) @@ -1337,7 +1331,6 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%trans ', Interstitial%trans ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tseal ', Interstitial%tseal ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tsfa ', Interstitial%tsfa ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tsfc_ice ', Interstitial%tsfc_ice ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tsfc_water ', Interstitial%tsfc_water ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tsfg ', Interstitial%tsfg ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tsurf_ice ', Interstitial%tsurf_ice ) @@ -1350,9 +1343,6 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%vdftra ', Interstitial%vdftra ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%vegf1d ', Interstitial%vegf1d ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%wcbmax ', Interstitial%wcbmax ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%weasd_ice ', Interstitial%weasd_ice ) -! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%weasd_land ', Interstitial%weasd_land ) -! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%weasd_water ', Interstitial%weasd_water ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%wind ', Interstitial%wind ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%work1 ', Interstitial%work1 ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%work2 ', Interstitial%work2 ) @@ -1637,3 +1627,132 @@ subroutine GFS_checkland_run (me, master, blkno, im, kdt, iter, flag_iter, flag_ end subroutine GFS_checkland_run end module GFS_checkland + + module GFS_checktracers + + private + + public GFS_checktracers_init, GFS_checktracers_timestep_init, GFS_checktracers_run + + contains + +!> \section arg_table_GFS_checktracers_init Argument Table +!! \htmlinclude GFS_checktracers_init.html +!! + subroutine GFS_checktracers_init (me, master, im, levs, ntracer, kdt, qgrs, gq0, errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + ! Interface variables + integer, intent(in ) :: me + integer, intent(in ) :: master + integer, intent(in ) :: im + integer, intent(in ) :: levs + integer, intent(in ) :: ntracer + integer, intent(in ) :: kdt + real(kind_phys), intent(in ) :: qgrs(:,:,:) + real(kind_phys), intent(in ) :: gq0(:,:,:) + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + + call GFS_checktracers_timestep_init (me, master, im, levs, ntracer, kdt, qgrs, gq0, errmsg, errflg) + + end subroutine GFS_checktracers_init + +!> \section arg_table_GFS_checktracers_timestep_init Argument Table +!! \htmlinclude GFS_checktracers_timestep_init.html +!! + subroutine GFS_checktracers_timestep_init (me, master, im, levs, ntracer, kdt, qgrs, gq0, errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + ! Interface variables + integer, intent(in ) :: me + integer, intent(in ) :: master + integer, intent(in ) :: im + integer, intent(in ) :: levs + integer, intent(in ) :: ntracer + integer, intent(in ) :: kdt + real(kind_phys), intent(in ) :: qgrs(:,:,:) + real(kind_phys), intent(in ) :: gq0(:,:,:) + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + + ! Local variables + integer :: i, k, n + + errflg = 0 + errmsg = '' + + write(0,'(a,i5)') 'YYY: me :', me + write(0,'(a,i5)') 'YYY: master :', master + write(0,'(a,i5)') 'YYY: im :', im + write(0,'(a,i5)') 'YYY: levs :', levs + write(0,'(a,i5)') 'YYY: ntracer :', ntracer + write(0,'(a,i5)') 'YYY: kdt :', kdt + + do n=1,ntracer + do i=1,im + do k=1,levs + if (qgrs(i,k,n)<0 .or. gq0(i,k,n)<0) then + write(0,'(a,4i5,1x,2e16.7)') 'YYY: blk, n, i, k, qgrs, gq0 :', -999, n, i, k, qgrs(i,k,n), gq0(i,k,n) + end if + end do + end do + end do + + end subroutine GFS_checktracers_timestep_init + +!> \section arg_table_GFS_checktracers_run Argument Table +!! \htmlinclude GFS_checktracers_run.html +!! + subroutine GFS_checktracers_run (me, master, blkno, im, levs, ntracer, kdt, qgrs, gq0, errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + ! Interface variables + integer, intent(in ) :: me + integer, intent(in ) :: master + integer, intent(in ) :: blkno + integer, intent(in ) :: im + integer, intent(in ) :: levs + integer, intent(in ) :: ntracer + integer, intent(in ) :: kdt + real(kind_phys), intent(in ) :: qgrs(:,:,:) + real(kind_phys), intent(in ) :: gq0(:,:,:) + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + + ! Local variables + integer :: i, k, n + + errflg = 0 + errmsg = '' + + write(0,'(a,i5)') 'YYY: me :', me + write(0,'(a,i5)') 'YYY: master :', master + write(0,'(a,i5)') 'YYY: blkno :', blkno + write(0,'(a,i5)') 'YYY: im :', im + write(0,'(a,i5)') 'YYY: levs :', levs + write(0,'(a,i5)') 'YYY: ntracer :', ntracer + write(0,'(a,i5)') 'YYY: kdt :', kdt + + do n=1,ntracer + do i=1,im + do k=1,levs + if (qgrs(i,k,n)<0 .or. gq0(i,k,n)<0) then + write(0,'(a,4i5,1x,2e16.7)') 'YYY: blk, n, i, k, qgrs, gq0 :', blkno, n, i, k, qgrs(i,k,n), gq0(i,k,n) + end if + end do + end do + end do + + end subroutine GFS_checktracers_run + + end module GFS_checktracers diff --git a/physics/GFS_debug.meta b/physics/GFS_debug.meta index fb77772eb..7a2a5c6a6 100644 --- a/physics/GFS_debug.meta +++ b/physics/GFS_debug.meta @@ -773,3 +773,281 @@ type = integer intent = out optional = F + +######################################################################## +[ccpp-table-properties] + name = GFS_checktracers + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = GFS_checktracers_init + type = scheme +[me] + standard_name = mpi_rank + long_name = current MPI-rank + units = index + dimensions = () + type = integer + intent = in + optional = F +[master] + standard_name = mpi_root + long_name = master MPI-rank + units = index + dimensions = () + type = integer + intent = in + optional = F +[im] + standard_name = horizontal_dimension + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[levs] + standard_name = vertical_layer_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in + optional = F +[ntracer] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in + optional = F +[kdt] + standard_name = index_of_timestep + long_name = current number of time steps + units = index + dimensions = () + type = integer + intent = in + optional = F +[qgrs] + standard_name = tracer_concentration + long_name = model layer mean tracer concentration + units = kg kg-1 + dimensions = (horizontal_dimension,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = in + optional = F +[gq0] + standard_name = tracer_concentration_of_new_state + long_name = tracer concentration updated by physics + units = kg kg-1 + dimensions = (horizontal_dimension,vertical_layer_dimension,number_of_tracers) + 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 = GFS_checktracers_timestep_init + type = scheme +[me] + standard_name = mpi_rank + long_name = current MPI-rank + units = index + dimensions = () + type = integer + intent = in + optional = F +[master] + standard_name = mpi_root + long_name = master MPI-rank + units = index + dimensions = () + type = integer + intent = in + optional = F +[im] + standard_name = horizontal_dimension + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[levs] + standard_name = vertical_layer_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in + optional = F +[ntracer] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in + optional = F +[kdt] + standard_name = index_of_timestep + long_name = current number of time steps + units = index + dimensions = () + type = integer + intent = in + optional = F +[qgrs] + standard_name = tracer_concentration + long_name = model layer mean tracer concentration + units = kg kg-1 + dimensions = (horizontal_dimension,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = in + optional = F +[gq0] + standard_name = tracer_concentration_of_new_state + long_name = tracer concentration updated by physics + units = kg kg-1 + dimensions = (horizontal_dimension,vertical_layer_dimension,number_of_tracers) + 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 = GFS_checktracers_run + type = scheme +[me] + standard_name = mpi_rank + long_name = current MPI-rank + units = index + dimensions = () + type = integer + intent = in + optional = F +[master] + standard_name = mpi_root + long_name = master MPI-rank + units = index + dimensions = () + type = integer + intent = in + optional = F +[blkno] + standard_name = ccpp_block_number + long_name = number of block for explicit data blocking in CCPP + units = index + dimensions = () + type = integer + intent = in + optional = F +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[levs] + standard_name = vertical_layer_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in + optional = F +[ntracer] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in + optional = F +[kdt] + standard_name = index_of_timestep + long_name = current number of time steps + units = index + dimensions = () + type = integer + intent = in + optional = F +[qgrs] + standard_name = tracer_concentration + long_name = model layer mean tracer concentration + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = in + optional = F +[gq0] + standard_name = tracer_concentration_of_new_state + long_name = tracer concentration updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + 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 From aa0918c1c98b82b2e21e486dad07ca6ecd2203d7 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 29 Nov 2021 07:56:08 -0700 Subject: [PATCH 74/85] Fix wrong dimensions in physics/drag_suite.meta --- physics/drag_suite.meta | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/drag_suite.meta b/physics/drag_suite.meta index 0511aa073..6ab375cf9 100644 --- a/physics/drag_suite.meta +++ b/physics/drag_suite.meta @@ -558,7 +558,7 @@ standard_name = multiplicative_tunable_parameters_for_mountain_blocking_and_orographic_gravity_wave_drag long_name = multiplic. factors for (1) mountain blocking drag coeff. and (2) ref. level orographic gravity wave drag units = none - dimensions = (2) + dimensions = (4) type = real kind = kind_phys intent = in From 18549f3110ad5a71f8007587aded62d6053ff0af Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 1 Dec 2021 07:32:18 -0700 Subject: [PATCH 75/85] Remove additional newline in CODEOWNERS --- CODEOWNERS | 1 - 1 file changed, 1 deletion(-) diff --git a/CODEOWNERS b/CODEOWNERS index 72b534a32..c163e7b80 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -5,7 +5,6 @@ #* @defunkt * @climbfuji @llpcarson @grantfirl @mzhangw @panll @mkavulich - # Order is important. The last matching pattern has the most precedence. # So if a pull request only touches javascript files, only these owners # will be requested to review. From 7acaa92e1a9ad4100838d1385e4e4e25a9bf12ed Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Fri, 3 Dec 2021 07:22:51 -0700 Subject: [PATCH 76/85] Major cleanup of cmake build config --- CMakeLists.txt | 196 ++++++++++++++----------------------------------- 1 file changed, 54 insertions(+), 142 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 4d5c8eae4..c83a0d41e 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -1,22 +1,9 @@ -# Set default project to unknown -if(NOT PROJECT) - message(STATUS "Setting CCPP project to 'unknown' as none was specified.") - set(PROJECT "Unknown") -endif (NOT PROJECT) - -#------------------------------------------------------------------------------ cmake_minimum_required(VERSION 3.0) project(ccpp_physics VERSION 5.0.0 LANGUAGES Fortran) -# Use rpaths on MacOSX -set(CMAKE_MACOSX_RPATH 1) -if(POLICY CMP0042) - cmake_policy(SET CMP0042 NEW) -endif(POLICY CMP0042) - # CMP0057: Support new IN_LIST if() operator if(POLICY CMP0057) cmake_policy(SET CMP0057 NEW) @@ -29,11 +16,7 @@ set(AUTHORS "Grant Firl" "Dom Heinzeller" "Man Zhang" "Laurie Carson") #------------------------------------------------------------------------------ # Set OpenMP flags for C/C++/Fortran if (OPENMP) - include(detect_openmp) - detect_openmp() - message(STATUS "Enable OpenMP support") -else (OPENMP) - message (STATUS "Disable OpenMP support") + find_package(OpenMP REQUIRED) endif() #------------------------------------------------------------------------------ @@ -41,11 +24,16 @@ endif() if(NOT CMAKE_BUILD_TYPE AND NOT CMAKE_CONFIGURATION_TYPES) message(STATUS "Setting build type to 'Release' as none was specified.") set(CMAKE_BUILD_TYPE Release CACHE STRING "Choose the type of build." FORCE) - # Set the possible values of build type for cmake-gui set_property(CACHE CMAKE_BUILD_TYPE PROPERTY STRINGS "Debug" "Bitforbit" "Release" "Coverage") endif() +#------------------------------------------------------------------------------ +# Pass debug/release flag to Fortran files for preprocessor +if(CMAKE_BUILD_TYPE STREQUAL "Debug") + add_definitions(-DDEBUG) +endif() + #------------------------------------------------------------------------------ # Request a static build option(BUILD_SHARED_LIBS "Build a shared library" OFF) @@ -85,18 +73,13 @@ else(CAPS) message(STATUS "Got CCPP CAPS from cmakefile include file: ${CAPS}") endif(CAPS) -# Create empty lists for schemes with special compiler optimization flags -set(SCHEMES_SFX_OPT "") -# Create empty lists for schemes with special floating point precision flags -set(SCHEMES_SFX_PREC "") -# Create a duplicate of the SCHEMES list for handling floating point precision flags -set(SCHEMES2 ${SCHEMES}) - # Schemes and caps from the CCPP code generator use full paths with symlinks # resolved, we need to do the same here for the below logic to work get_filename_component(FULL_PATH_TO_CMAKELISTS CMakeLists.txt REALPATH BASE_DIR ${LOCAL_CURRENT_SOURCE_DIR}) get_filename_component(LOCAL_CURRENT_SOURCE_DIR ${FULL_PATH_TO_CMAKELISTS} DIRECTORY) +#------------------------------------------------------------------------------ + # List of files that need to be compiled without OpenMP set(SCHEMES_OPENMP_OFF ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_gas_optics.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_rrtmgp_constants.F90 @@ -140,113 +123,44 @@ set(SCHEMES_OPENMP_OFF ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_ ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/mo_rte_kind.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/mo_optical_props.F90) -#------------------------------------------------------------------------------ -if (${CMAKE_Fortran_COMPILER_ID} STREQUAL "GNU") - - if (PROJECT STREQUAL "CCPP-FV3") - # Set 32-bit floating point precision flags for certain files - # that are executed in the dynamics (fast physics part) - if (DYN32) - if (${LOCAL_CURRENT_SOURCE_DIR}/physics/gfdl_fv_sat_adj.F90 IN_LIST SCHEMES) - # Reduce floating point precision from 64-bit to 32-bit, if necessary - set(CMAKE_Fortran_FLAGS_PREC32 ${CMAKE_Fortran_FLAGS_DEFAULT_PREC}) - string(REPLACE "-fdefault-real-8" "" - CMAKE_Fortran_FLAGS_PREC32 "${CMAKE_Fortran_FLAGS_PREC32}") - string(REPLACE "-fdefault-double-8" "" - CMAKE_Fortran_FLAGS_PREC32 "${CMAKE_Fortran_FLAGS_PREC32}") - SET_PROPERTY(SOURCE ${LOCAL_CURRENT_SOURCE_DIR}/physics/gfdl_fv_sat_adj.F90 - APPEND_STRING PROPERTY COMPILE_FLAGS " ${CMAKE_Fortran_FLAGS_PREC32} ${OpenMP_Fortran_FLAGS} ") - # Add all of the above files to the list of schemes with special floating point precision flags - list(APPEND SCHEMES_SFX_PREC ${LOCAL_CURRENT_SOURCE_DIR}/physics/gfdl_fv_sat_adj.F90) - endif() - endif() +# List of files that need to be compiled with different precision +set(SCHEMES_DYNAMICS) - # Remove files with special floating point precision flags from list - # of files with standard floating point precision flags - if (SCHEMES_SFX_PREC) - list(REMOVE_ITEM SCHEMES2 ${SCHEMES_SFX_PREC}) - endif () - - if (PROJECT STREQUAL "CCPP-FV3") - # Remove files that need to be compiled without OpenMP from list - # of files with standard compiler flags, and assign no-OpenMP flags - if (SCHEMES_OPENMP_OFF) - list(REMOVE_ITEM SCHEMES2 ${SCHEMES_OPENMP_OFF}) - endif () - # Assign standard floating point precision flags to all remaining schemes and caps - SET_PROPERTY(SOURCE ${SCHEMES_OPENMP_OFF} - APPEND_STRING PROPERTY COMPILE_FLAGS " ${CMAKE_Fortran_FLAGS_DEFAULT_PREC} ") - endif() - - # Assign standard floating point precision flags to all remaining schemes and caps - SET_PROPERTY(SOURCE ${SCHEMES2} ${CAPS} - APPEND_STRING PROPERTY COMPILE_FLAGS " ${CMAKE_Fortran_FLAGS_DEFAULT_PREC} ${OpenMP_Fortran_FLAGS} ") - - endif (PROJECT STREQUAL "CCPP-FV3") - -elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") - # Adjust settings for bit-for-bit reproducibility of NEMSfv3gfs - if (PROJECT STREQUAL "CCPP-FV3") - - if (${LOCAL_CURRENT_SOURCE_DIR}/physics/module_sf_mynn.F90 IN_LIST SCHEMES) - # Reduce optimization for module_sf_mynn.F90 (to avoid an apparent compiler bug with Intel 18 on Hera) - SET_SOURCE_FILES_PROPERTIES(${LOCAL_CURRENT_SOURCE_DIR}/physics/module_sf_mynn.F90 - PROPERTIES COMPILE_FLAGS "${CMAKE_Fortran_FLAGS_OPT} -O1") - list(APPEND SCHEMES_SFX_OPT ${LOCAL_CURRENT_SOURCE_DIR}/physics/module_sf_mynn.F90) - endif() - - # Remove files with special compiler flags from list of files with standard compiler flags - if (SCHEMES_SFX_OPT) - list(REMOVE_ITEM SCHEMES ${SCHEMES_SFX_OPT}) - endif(SCHEMES_SFX_OPT) - # Assign standard compiler flags to all remaining schemes and caps - SET_SOURCE_FILES_PROPERTIES(${SCHEMES} ${CAPS} - PROPERTIES COMPILE_FLAGS "${CMAKE_Fortran_FLAGS_OPT}") - - # Set 32-bit floating point precision flags for certain files - # that are executed in the dynamics (fast physics part) - if (DYN32) - if (${LOCAL_CURRENT_SOURCE_DIR}/physics/gfdl_fv_sat_adj.F90 IN_LIST SCHEMES) - # Reduce floating point precision from 64-bit to 32-bit, if necessary - set(CMAKE_Fortran_FLAGS_PREC32 ${CMAKE_Fortran_FLAGS_DEFAULT_PREC}) - string(REPLACE "-real-size 64" "-real-size 32" - CMAKE_Fortran_FLAGS_PREC32 "${CMAKE_Fortran_FLAGS_PREC32}") - SET_PROPERTY(SOURCE ${LOCAL_CURRENT_SOURCE_DIR}/physics/gfdl_fv_sat_adj.F90 - APPEND_STRING PROPERTY COMPILE_FLAGS " ${CMAKE_Fortran_FLAGS_PREC32} ${OpenMP_Fortran_FLAGS} ") - # Add all of the above files to the list of schemes with special floating point precision flags - list(APPEND SCHEMES_SFX_PREC ${LOCAL_CURRENT_SOURCE_DIR}/physics/gfdl_fv_sat_adj.F90) - endif() - endif() - - # Remove files with special floating point precision flags from list - # of files with standard floating point precision flags flags - if (SCHEMES_SFX_PREC) - list(REMOVE_ITEM SCHEMES2 ${SCHEMES_SFX_PREC}) - endif (SCHEMES_SFX_PREC) +if(${LOCAL_CURRENT_SOURCE_DIR}/physics/gfdl_fv_sat_adj.F90 IN_LIST SCHEMES) + list(APPEND SCHEMES_DYNAMICS ${LOCAL_CURRENT_SOURCE_DIR}/physics/gfdl_fv_sat_adj.F90) +endif() - # Remove files that need to be compiled without OpenMP from list - # of files with standard compiler flags, and assign no-OpenMP flags - if (SCHEMES_OPENMP_OFF) - list(REMOVE_ITEM SCHEMES2 ${SCHEMES_OPENMP_OFF}) - # Assign standard floating point precision flags to all remaining schemes and caps - SET_PROPERTY(SOURCE ${SCHEMES_OPENMP_OFF} - APPEND_STRING PROPERTY COMPILE_FLAGS " ${CMAKE_Fortran_FLAGS_DEFAULT_PREC} ") - endif () +# Remove files that need to be compiled with different precision +# of files with standard compiler flags, and assign OpenMP flags +if(SCHEMES_DYNAMICS) + SET_PROPERTY(SOURCE ${SCHEMES_DYNAMICS} + APPEND_STRING PROPERTY COMPILE_FLAGS " ${CMAKE_Fortran_FLAGS_DYNAMICS} ${OpenMP_Fortran_FLAGS}") + list(REMOVE_ITEM SCHEMES ${SCHEMES_DYNAMICS}) +endif() - # Assign standard floating point precision flags to all remaining schemes and caps - SET_PROPERTY(SOURCE ${SCHEMES2} ${CAPS} - APPEND_STRING PROPERTY COMPILE_FLAGS " ${CMAKE_Fortran_FLAGS_DEFAULT_PREC} ${OpenMP_Fortran_FLAGS} ") +# Remove files that need to be compiled without OpenMP from list +# of files with standard compiler flags, and assign no-OpenMP flags +if(SCHEMES_OPENMP_OFF) + SET_PROPERTY(SOURCE ${SCHEMES_OPENMP_OFF} + APPEND_STRING PROPERTY COMPILE_FLAGS " ${CMAKE_Fortran_FLAGS_PHYSICS}") + list(REMOVE_ITEM SCHEMES ${SCHEMES_OPENMP_OFF}) +endif() - endif (PROJECT STREQUAL "CCPP-FV3") +# Assign standard floating point precision flags to all remaining schemes and caps +SET_PROPERTY(SOURCE ${SCHEMES} ${CAPS} + APPEND_STRING PROPERTY COMPILE_FLAGS " ${CMAKE_Fortran_FLAGS_PHYSICS} ${OpenMP_Fortran_FLAGS}") -else() - message ("CMAKE_Fortran_COMPILER full path: " ${CMAKE_Fortran_COMPILER}) - message ("Fortran compiler: " ${CMAKE_Fortran_COMPILER_ID}) - message (FATAL_ERROR "This program has only been compiled with gfortran and ifort. If another compiler is needed, the appropriate flags must be added in ${GFS_PHYS_SRC}/CMakeLists.txt") +# Reduce optimization for module_sf_mynn.F90 (to avoid an apparent compiler bug with Intel 18 on Hera) +if(${LOCAL_CURRENT_SOURCE_DIR}/physics/module_sf_mynn.F90 IN_LIST SCHEMES AND + (CMAKE_BUILD_TYPE STREQUAL "Release" OR CMAKE_BUILD_TYPE STREQUAL "Bitforbit") AND + ${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") + SET_SOURCE_FILES_PROPERTIES(${LOCAL_CURRENT_SOURCE_DIR}/physics/module_sf_mynn.F90 + APPEND_STRING PROPERTY COMPILE_FLAGS " ${CMAKE_Fortran_FLAGS_PHYSICS} ${OpenMP_Fortran_FLAGS} -O1") endif() #------------------------------------------------------------------------------ -add_library(ccpp_physics STATIC ${SCHEMES} ${SCHEMES_SFX_OPT} ${CAPS}) + +add_library(ccpp_physics STATIC ${SCHEMES} ${SCHEMES_OPENMP_OFF} ${SCHEMES_DYNAMICS} ${CAPS}) # Generate list of Fortran modules from defined sources foreach(source_f90 ${CAPS}) get_filename_component(tmp_source_f90 ${source_f90} NAME) @@ -263,20 +177,18 @@ target_include_directories(ccpp_physics PUBLIC target_link_libraries(ccpp_physics PUBLIC w3nco::w3nco_d NetCDF::NetCDF_Fortran) -if (PROJECT STREQUAL "CCPP-FV3") - # Define where to install the library - install(TARGETS ccpp_physics - EXPORT ccpp_physics-targets - ARCHIVE DESTINATION lib - LIBRARY DESTINATION lib - RUNTIME DESTINATION lib - ) - # Export our configuration - install(EXPORT ccpp_physics-targets - FILE ccpp_physics-config.cmake - DESTINATION lib/cmake - ) - # Define where to install the C headers and Fortran modules - #install(FILES ${HEADERS_C} DESTINATION include) - install(FILES ${MODULES_F90} DESTINATION include) -endif (PROJECT STREQUAL "CCPP-FV3") +# Define where to install the library +install(TARGETS ccpp_physics + EXPORT ccpp_physics-targets + ARCHIVE DESTINATION lib + LIBRARY DESTINATION lib + RUNTIME DESTINATION lib +) +# Export our configuration +install(EXPORT ccpp_physics-targets + FILE ccpp_physics-config.cmake + DESTINATION lib/cmake +) +# Define where to install the C headers and Fortran modules +#install(FILES ${HEADERS_C} DESTINATION include) +install(FILES ${MODULES_F90} DESTINATION include) From 41232ceee114d351f96b0912a4be15fc42ac1656 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Fri, 3 Dec 2021 10:50:51 -0700 Subject: [PATCH 77/85] Update minimum cmake version to remove legacy code, reduce chatter --- CMakeLists.txt | 19 +++++++------------ 1 file changed, 7 insertions(+), 12 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index c83a0d41e..0b1b3d4b1 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -1,14 +1,9 @@ -cmake_minimum_required(VERSION 3.0) +cmake_minimum_required(VERSION 3.3) project(ccpp_physics VERSION 5.0.0 LANGUAGES Fortran) -# CMP0057: Support new IN_LIST if() operator -if(POLICY CMP0057) - cmake_policy(SET CMP0057 NEW) -endif(POLICY CMP0057) - #------------------------------------------------------------------------------ set(PACKAGE "ccpp-physics") set(AUTHORS "Grant Firl" "Dom Heinzeller" "Man Zhang" "Laurie Carson") @@ -42,10 +37,10 @@ option(BUILD_SHARED_LIBS "Build a shared library" OFF) # Set the sources: physics type definitions set(TYPEDEFS $ENV{CCPP_TYPEDEFS}) if(TYPEDEFS) - message(STATUS "Got CCPP TYPEDEFS from environment variable: ${TYPEDEFS}") + message(STATUS "Got CCPP TYPEDEFS from environment variable") else(TYPEDEFS) include(${CMAKE_CURRENT_BINARY_DIR}/CCPP_TYPEDEFS.cmake) - message(STATUS "Got CCPP TYPEDEFS from cmakefile include file: ${TYPEDEFS}") + message(STATUS "Got CCPP TYPEDEFS from cmakefile include file") endif(TYPEDEFS) # Generate list of Fortran modules from the CCPP type @@ -58,19 +53,19 @@ endforeach() # Set the sources: physics schemes set(SCHEMES $ENV{CCPP_SCHEMES}) if(SCHEMES) - message(STATUS "Got CCPP SCHEMES from environment variable: ${SCHEMES}") + message(STATUS "Got CCPP SCHEMES from environment variable") else(SCHEMES) include(${CMAKE_CURRENT_BINARY_DIR}/CCPP_SCHEMES.cmake) - message(STATUS "Got CCPP SCHEMES from cmakefile include file: ${SCHEMES}") + message(STATUS "Got CCPP SCHEMES from cmakefile include file") endif(SCHEMES) # Set the sources: physics scheme caps set(CAPS $ENV{CCPP_CAPS}) if(CAPS) - message(STATUS "Got CCPP CAPS from environment variable: ${CAPS}") + message(STATUS "Got CCPP CAPS from environment variable") else(CAPS) include(${CMAKE_CURRENT_BINARY_DIR}/CCPP_CAPS.cmake) - message(STATUS "Got CCPP CAPS from cmakefile include file: ${CAPS}") + message(STATUS "Got CCPP CAPS from cmakefile include file") endif(CAPS) # Schemes and caps from the CCPP code generator use full paths with symlinks From 472987f8df3ce53850801d7531923306fc7b6849 Mon Sep 17 00:00:00 2001 From: Greg Thompson Date: Tue, 7 Dec 2021 15:06:49 -0700 Subject: [PATCH 78/85] permit few max ice number conc; scale back cloud fraction a little; reduce assumed snow as ice in IWP for radiation --- physics/module_mp_thompson.F90 | 12 ++++++------ physics/radiation_clouds.f | 14 +++++++------- 2 files changed, 13 insertions(+), 13 deletions(-) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index fb1a4a5f2..3183ca4bf 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -2188,7 +2188,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & ni(k) = MAX(R2, ni1d(k)*rho(k)) if (ni(k).le. R2) then lami = cie(2)/5.E-6 - ni(k) = MIN(9999.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i) + ni(k) = MIN(999.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i) endif L_qi(k) = .true. lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi @@ -2196,7 +2196,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & xDi = (bm_i + mu_i + 1.) * ilami if (xDi.lt. 5.E-6) then lami = cie(2)/5.E-6 - ni(k) = MIN(9999.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i) + ni(k) = MIN(999.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i) elseif (xDi.gt. 300.E-6) then lami = cie(2)/300.E-6 ni(k) = cig(1)*oig2*ri(k)/am_i*lami**bm_i @@ -3237,7 +3237,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & xDi = (bm_i + mu_i + 1.) * ilami if (xDi.lt. 5.E-6) then lami = cie(2)/5.E-6 - xni = MIN(9999.D3, cig(1)*oig2*xri/am_i*lami**bm_i) + xni = MIN(999.D3, cig(1)*oig2*xri/am_i*lami**bm_i) niten(k) = (xni-ni1d(k)*rho(k))*odts*orho elseif (xDi.gt. 300.E-6) then lami = cie(2)/300.E-6 @@ -3248,8 +3248,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & niten(k) = -ni1d(k)*odts endif xni=MAX(0.,(ni1d(k) + niten(k)*dtsave)*rho(k)) - if (xni.gt.9999.E3) & - niten(k) = (9999.E3-ni1d(k)*rho(k))*odts*orho + if (xni.gt.999.E3) & + niten(k) = (999.E3-ni1d(k)*rho(k))*odts*orho !> - Rain tendency qrten(k) = qrten(k) + (prr_wau(k) + prr_rcw(k) & @@ -4187,7 +4187,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & lami = cie(2)/300.E-6 endif ni1d(k) = MIN(cig(1)*oig2*qi1d(k)/am_i*lami**bm_i, & - 9999.D3/rho(k)) + 999.D3/rho(k)) endif qr1d(k) = qr1d(k) + qrten(k)*DT nr1d(k) = MAX(R2/rho(k), nr1d(k) + nrten(k)*DT) diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index e73f91ea2..f58ec8d11 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -3452,7 +3452,7 @@ subroutine progcld_thompson & do i = 1, IX cwp(i,k) = max(0.0, clw(i,k,ntcw) * dz(i,k)*1.E6) crp(i,k) = 0.0 - snow_mass_factor = 0.80 + snow_mass_factor = 0.85 cip(i,k) = max(0.0, (clw(i,k,ntiw) & & + (1.0-snow_mass_factor)*clw(i,k,ntsw))*dz(i,k)*1.E6) if (re_snow(i,k) .gt. snow_max_radius)then @@ -4532,16 +4532,16 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, dz, & DO k = kts,kte delz = MAX(100., dz(k)) - RH_00L = 0.68+MIN(0.31,SQRT(1./(50.0+gridkm*gridkm*delz*0.01))) - RH_00O = 0.79+MIN(0.20,SQRT(1./(50.0+gridkm*gridkm*delz*0.01))) + RH_00L = 0.74+MIN(0.25,SQRT(1./(50.0+gridkm*gridkm*delz*0.01))) + RH_00O = 0.82+MIN(0.17,SQRT(1./(50.0+gridkm*gridkm*delz*0.01))) RHUM = rh(k) - if (qc(k).ge.1.E-6 .or. qi(k).ge.1.E-6 & - & .or. (qs(k).gt.1.E-6 .and. t(k).lt.273.)) then + if (qc(k).ge.1.E-5 .or. qi(k).ge.1.E-5 & + & .or. (qs(k).gt.1.E-5 .and. t(k).lt.273.)) then CLDFRA(K) = 1.0 elseif (((qc(k)+qi(k)).gt.1.E-10) .and. & - & ((qc(k)+qi(k)).lt.1.E-6)) then - CLDFRA(K) = MIN(0.99, 0.25*(10.0 + log10(qc(k)+qi(k)))) + & ((qc(k)+qi(k)).lt.1.E-5)) then + CLDFRA(K) = MIN(0.99, 0.20*(10.0 + log10(qc(k)+qi(k)))) else IF ((XLAND-1.5).GT.0.) THEN !--- Ocean From 2c391975a79d2932c346bb5791612e6cc0055ca0 Mon Sep 17 00:00:00 2001 From: Laurie Carson Date: Wed, 8 Dec 2021 08:27:54 -0700 Subject: [PATCH 79/85] Remove Laurie from CODEOWNERS --- CODEOWNERS | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CODEOWNERS b/CODEOWNERS index c163e7b80..5080ce409 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 @mzhangw @panll @mkavulich +* @climbfuji @grantfirl @mzhangw @panll @mkavulich # Order is important. The last matching pattern has the most precedence. # So if a pull request only touches javascript files, only these owners From c1e17709b70f80561a9e6cc9dc14e02d6feb06e5 Mon Sep 17 00:00:00 2001 From: Tanya Smirnova Date: Wed, 8 Dec 2021 17:13:18 +0000 Subject: [PATCH 80/85] Bug fix in the computation of soil moisture conductivity. The bug was causing cold/moist bias. --- physics/module_sf_ruclsm.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index b5238f366..a2b0f398a 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -6278,10 +6278,10 @@ SUBROUTINE SOILPROP( debug_print, & if((ws-a).lt.0.12)then diffu(K)=0. else - H=max(0.,(soilmoism(K)+qmin-a)/(max(1.e-8,(dqm-a)))) + H=max(0.,(soilmoism(K)+qmin-a)/(max(1.e-8,(ws-a)))) facd=1. if(a.ne.0.)facd=1.-a/max(1.e-8,soilmoism(K)) - ame=max(1.e-8,dqm-riw*soilicem(K)) + ame=max(1.e-8,ws-riw*soilicem(K)) !--- DIFFU is diffusional conductivity of soil water diffu(K)=-BCLH*KSAT*PSIS/ame* & (ws/ame)**3. & From 6788593c46a44463a2f6491ce2ea345764114aa8 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Thu, 9 Dec 2021 20:52:04 -0700 Subject: [PATCH 81/85] Add -O1 for RRTMGP file physics/rte-rrtmgp/rrtmgp/kernels/mo_gas_optics_kernels.F90 back in --- CMakeLists.txt | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/CMakeLists.txt b/CMakeLists.txt index 4d5c8eae4..e9689636d 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -195,6 +195,13 @@ elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") list(APPEND SCHEMES_SFX_OPT ${LOCAL_CURRENT_SOURCE_DIR}/physics/module_sf_mynn.F90) endif() + if (${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/kernels/mo_gas_optics_kernels.F90 IN_LIST SCHEMES) + # Reduce optimization for mo_gas_optics_kernels.F90 (to avoid an apparent compiler bug with Intel 19+) + SET_SOURCE_FILES_PROPERTIES(${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/kernels/mo_gas_optics_kernels.F90 + PROPERTIES COMPILE_FLAGS "${CMAKE_Fortran_FLAGS_OPT} -O1") + list(APPEND SCHEMES_SFX_OPT ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/kernels/mo_gas_optics_kernels.F90) + endif() + # Remove files with special compiler flags from list of files with standard compiler flags if (SCHEMES_SFX_OPT) list(REMOVE_ITEM SCHEMES ${SCHEMES_SFX_OPT}) From fcedb92185abf95bdeff7242770e20fc4a101995 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Fri, 10 Dec 2021 10:29:51 -0700 Subject: [PATCH 82/85] Remove variables that no longer exist from physics/GFS_debug.F90 --- physics/GFS_debug.F90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 11b5bac94..d9b260cf1 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -1432,8 +1432,6 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cld_rwp ', Interstitial%cld_rwp ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cld_rerain ', Interstitial%cld_rerain ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%precip_frac ', Interstitial%precip_frac ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%icseed_lw ', Interstitial%icseed_lw ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%icseed_sw ', Interstitial%icseed_sw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%fluxlwUP_clrsky ', Interstitial%fluxlwUP_clrsky ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%fluxlwDOWN_clrsky ', Interstitial%fluxlwDOWN_clrsky ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%fluxswUP_allsky ', Interstitial%fluxswUP_allsky ) From 83ff12942727e78660b38c9d9eb6bbe722fe0081 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Fri, 10 Dec 2021 10:50:00 -0700 Subject: [PATCH 83/85] Address reviewer comments --- physics/GFS_rrtmg_pre.F90 | 46 ++++++++++++++++++++------------------ physics/cu_gf_deep.F90 | 4 ++-- physics/cu_gf_driver.meta | 2 +- physics/module_bl_mynn.F90 | 2 +- 4 files changed, 28 insertions(+), 26 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 5a45b2203..3a3378e15 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -742,31 +742,33 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo endif elseif (imp_physics == imp_physics_gfdl) then ! GFDL MP - if (do_mynnedmf .and. kdt>1) THEN - do k=1,lm - k1 = k + kd - do i=1,im - if (tracer1(i,k1,ntrw)>1.0e-7 .OR. tracer1(i,k1,ntsw)>1.0e-7) then - ! GFDL cloud fraction - cldcov(i,k1) = tracer1(i,k1,ntclamt) - else - ! MYNN sub-grid cloud fraction + if ((imfdeepcnv==imfdeepcnv_gf .or. do_mynnedmf) .and. kdt>1) then + if (do_mynnedmf) then + do k=1,lm + k1 = k + kd + do i=1,im + if (tracer1(i,k1,ntrw)>1.0e-7 .OR. tracer1(i,k1,ntsw)>1.0e-7) then + ! GFDL cloud fraction + cldcov(i,k1) = tracer1(i,k1,ntclamt) + else + ! MYNN sub-grid cloud fraction + cldcov(i,k1) = clouds1(i,k1) + endif + enddo + enddo + else ! imfdeepcnv==imfdeepcnv_gf + do k=1,lm + k1 = k + kd + do i=1,im + if (qci_conv(i,k)>0.) then + ! GF sub-grid cloud fraction cldcov(i,k1) = clouds1(i,k1) + else + cldcov(i,k1) = tracer1(i,k1,ntclamt) endif + enddo enddo - enddo - elseif (imfdeepcnv == imfdeepcnv_gf .and. kdt>1) THEN - do k=1,lm - k1 = k + kd - do i=1,im - if (qci_conv(i,k)>0.) then - ! GF sub-grid cloud fraction - cldcov(i,k1) = clouds1(i,k1) - else - cldcov(i,k1) = tracer1(i,k1,ntclamt) - endif - enddo - enddo + endif else ! GFDL cloud fraction cldcov(1:IM,1+kd:LM+kd) = tracer1(1:IM,1:LM,ntclamt) diff --git a/physics/cu_gf_deep.F90 b/physics/cu_gf_deep.F90 index 59bbd566d..102179bee 100644 --- a/physics/cu_gf_deep.F90 +++ b/physics/cu_gf_deep.F90 @@ -2454,9 +2454,9 @@ subroutine cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, & if(aeroevap.gt.1)then aeroadd=0. if((psumh(i)>0.).and.(psum2(i)>0.))then - aeroadd=((1.e-2*ccnclean)**beta3)*((psumh(i)*1.e0)**(alpha3-1)) + aeroadd=((1.e-2*ccnclean)**beta3)*(psumh(i)**(alpha3-1)) prop_c=.5*(pefb+pef)/aeroadd - aeroadd=((1.e-2*ccn(i))**beta3)*((psum2(i)*1.e0)**(alpha3-1)) + aeroadd=((1.e-2*ccn(i))**beta3)*(psum2(i)**(alpha3-1)) aeroadd=prop_c*aeroadd pefc=aeroadd diff --git a/physics/cu_gf_driver.meta b/physics/cu_gf_driver.meta index eeeb45868..3a54a9ecc 100644 --- a/physics/cu_gf_driver.meta +++ b/physics/cu_gf_driver.meta @@ -323,7 +323,7 @@ kind = kind_phys intent = in [aod_gf] - standard_name = aod_gf_deep + standard_name = aerosol_optical_depth_for_grell_freitas_deep_convection long_name = aerosol optical depth used in Grell-Freitas Convective Parameterization units = none dimensions = (horizontal_loop_extent) diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index fb0f1455d..a492e50e0 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -519,7 +519,7 @@ SUBROUTINE mym_initialize ( & INTEGER :: k,l,lmax REAL :: phm,vkz,elq,elv,b1l,b2l,pmz=1.,phh=1.,flt=0.,flq=0.,tmpq REAL :: zi - REAL, DIMENSION(kts:kte) :: theta,thetav,thlsg,qwsg + REAL, DIMENSION(kts:kte) :: theta,thetav,thlsg,qwsg REAL, DIMENSION(kts:kte) :: rstoch_col INTEGER ::spp_pbl From 2649dce585c08362f967ca653fdb483d1fb7b18e Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Fri, 10 Dec 2021 11:14:56 -0700 Subject: [PATCH 84/85] Update DDTs in physics/GFS_debug.F90 --- physics/GFS_debug.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index d9b260cf1..23d1be573 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -901,8 +901,6 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, end if if (Model%do_RRTMGP) then call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%fluxlwUP_jac', Coupling%fluxlwUP_jac) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%fluxlwUP_allsky', Coupling%fluxlwUP_allsky) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%fluxlwDOWN_allsky', Coupling%fluxlwDOWN_allsky) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%htrlw', Coupling%htrlw) end if ! @@ -1432,6 +1430,8 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cld_rwp ', Interstitial%cld_rwp ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cld_rerain ', Interstitial%cld_rerain ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%precip_frac ', Interstitial%precip_frac ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%fluxlwUP_allsky ', Interstitial%fluxlwUP_allsky ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%fluxlwDOWN_allsky ', Interstitial%fluxlwDOWN_allsky ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%fluxlwUP_clrsky ', Interstitial%fluxlwUP_clrsky ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%fluxlwDOWN_clrsky ', Interstitial%fluxlwDOWN_clrsky ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%fluxswUP_allsky ', Interstitial%fluxswUP_allsky ) From 30704407b6984f0a885fcc0d15e99e7a26d7f32d Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 13 Dec 2021 08:16:33 -0700 Subject: [PATCH 85/85] Remove a non-existing file from list of SCHEMES_OPENMP_OFF, compile mo_gas_optic_kernels.F90 with -O1 in PROD/REPRO mode --- CMakeLists.txt | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 18b37f820..b8cb88418 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -88,7 +88,6 @@ set(SCHEMES_OPENMP_OFF ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_ ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/tests/mo_testing_io.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/tests/clear_sky_regression.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/extensions/mo_rrtmgp_clr_all_sky.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/extensions/mo_fluxes_byband_kernels.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/extensions/mo_fluxes_byband.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/extensions/solar_variability/mo_solar_variability.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/extensions/mo_heating_rates.F90 @@ -153,8 +152,8 @@ if(${LOCAL_CURRENT_SOURCE_DIR}/physics/module_sf_mynn.F90 IN_LIST SCHEMES AND APPEND_STRING PROPERTY COMPILE_FLAGS " ${CMAKE_Fortran_FLAGS_PHYSICS} ${OpenMP_Fortran_FLAGS} -O1") endif() -# Reduce optimization for module_sf_mynn.F90 (to avoid an apparent compiler bug with Intel 18 on Hera) -if(${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/kernels/mo_gas_optics_kernels.F90 IN_LIST SCHEMES AND +# Reduce optimization for mo_gas_optics_kernels.F90 (to avoid an apparent compiler bug with Intel 19+) +if(${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/kernels/mo_gas_optics_kernels.F90 IN_LIST SCHEMES_OPENMP_OFF AND (CMAKE_BUILD_TYPE STREQUAL "Release" OR CMAKE_BUILD_TYPE STREQUAL "Bitforbit") AND ${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") SET_SOURCE_FILES_PROPERTIES(${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/kernels/mo_gas_optics_kernels.F90