diff --git a/.gitmodules b/.gitmodules index 5d206bcbf5..41f7345dd5 100644 --- a/.gitmodules +++ b/.gitmodules @@ -4,3 +4,6 @@ [submodule ".ci/hpc-workflows"] path = .ci/hpc-workflows url = https://github.com/islas/hpc-workflows +[submodule "phys/MYNN-EDMF"] + path = phys/MYNN-EDMF + url = https://github.com/NCAR/MYNN-EDMF diff --git a/Makefile b/Makefile index 2bdff94d81..c242e4f6be 100644 --- a/Makefile +++ b/Makefile @@ -124,6 +124,20 @@ wrf : framework_only echo "NoahMP submodule files populating WRF directories" ; \ echo "------------------------------------------------------------------------------" ; \ fi + if [ \( ! -f phys/module_bl_mynnedmf.F \) -o \ + \( ! -f phys/module_bl_mynnedmf_common.F \) -o \ + \( ! -f phys/module_bl_mynnedmf_common.F \) ] ; then \ + echo " " ; \ + echo "------------------------------------------------------------------------------" ; \ + echo "Error Error Error MYNN-EDMF submodule files not populating WRF directories" ; \ + echo "------------------------------------------------------------------------------" ; \ + echo " " ; \ + exit 31 ; \ + else \ + echo "------------------------------------------------------------------------------" ; \ + echo "MYNN-EDMF submodule files populating WRF directories" ; \ + echo "------------------------------------------------------------------------------" ; \ + fi if [ $(WRF_CHEM) -eq 1 ] ; then $(MAKE) MODULE_DIRS="$(ALL_MODULES)" chemics ; fi if [ $(WRF_EM_CORE) -eq 1 ] ; then $(MAKE) MODULE_DIRS="$(ALL_MODULES)" em_core ; fi if [ $(WRF_HYDRO) -eq 1 ] ; then $(MAKE) MODULE_DIRS="$(ALL_MODULES)" wrf_hydro ; fi diff --git a/Registry/Registry.EM_COMMON b/Registry/Registry.EM_COMMON index 76f485293d..c248b48827 100644 --- a/Registry/Registry.EM_COMMON +++ b/Registry/Registry.EM_COMMON @@ -1142,7 +1142,6 @@ state real sub_thl3D ikj misc 1 - h "s state real sub_sqv3D ikj misc 1 - h "sub_sqv3D" "qv subsidence tendency from EDMF" "kg kg-1 s-1" state real det_thl3D ikj misc 1 - h "det_thl3D" "thetaL detrainment tendency from EDMF" "K s-1" state real det_sqv3D ikj misc 1 - h "det_sqv3D" "qv detrainment tendency from EDMF" "kg kg-1 s-1" -state integer ktop_plume ij misc 1 - h "ktop_plume" "k-level of highest pentrating plume" "" state real maxMF ij misc 1 - h "maxMF" "Maximum mass-flux (neg: all dry, pos: moist)" "m/s * area" state real maxwidth ij misc 1 - h "maxwidth" "Maximum plume width" "m" state real ztop_plume ij misc 1 - h "ztop_plume" "Height of tallest plume" "m" @@ -2476,7 +2475,7 @@ rconfig integer bl_mynn_mixlength namelist,physics 1 1 rconfig integer bl_mynn_edmf namelist,physics max_domains 1 irh "bl_mynn_edmf" "0:off,1:activate mass-flux in mynn" "" rconfig integer bl_mynn_edmf_mom namelist,physics max_domains 1 irh "bl_mynn_edmf_mom" "0:off,1:activate mass-flux transport of momentum" "" rconfig integer bl_mynn_edmf_tke namelist,physics max_domains 0 irh "bl_mynn_edmf_tke" "0:off,1:activate mass-flux transport of tke" "" -rconfig integer bl_mynn_mixscalars namelist,physics max_domains 0 irh "bl_mynn_mixscalars" "0:off,1:activate mixing of scalars (qnx, qnxfa) in MYNN" "" +rconfig integer bl_mynn_mixscalars namelist,physics max_domains 1 irh "bl_mynn_mixscalars" "0:off,1:activate mixing of scalars (qnx, qnxfa) in MYNN" "" rconfig integer bl_mynn_output namelist,physics max_domains 0 irh "bl_mynn_output" "0:off,1:Allocate and output extra 3D arrays" "" rconfig integer bl_mynn_cloudmix namelist,physics max_domains 1 irh "bl_mynn_cloudmix" "0:off,1:activate mixing of all cloud species" "" rconfig integer bl_mynn_mixqt namelist,physics max_domains 0 irh "bl_mynn_mixqt" "0:mix moisture species separate,1: mix total water" "" @@ -3177,7 +3176,7 @@ package kepsscheme bl_pbl_physics==17 - scalar:tke_ad package mrfscheme bl_pbl_physics==99 - - package tkebudget tke_budget==1 - state:qSHEAR,qBUOY,qDISS,qWT,dqke -package mynn_dmp_edmf bl_mynn_edmf==1 - state:ktop_plume,ztop_plume,maxmf,maxwidth +package mynn_dmp_edmf bl_mynn_edmf==1 - state:ztop_plume,maxmf,maxwidth package mynn_3Doutput bl_mynn_output==1 - state:edmf_a,edmf_w,edmf_thl,edmf_qt,edmf_ent,edmf_qc,sub_thl3D,sub_sqv3D,det_thl3D,det_sqv3D package pbl_cloud icloud_bl==1 - state:cldfra_bl,qc_bl,qi_bl diff --git a/clean b/clean index a4af6a3a21..bf063ba4d1 100755 --- a/clean +++ b/clean @@ -83,6 +83,8 @@ if ( "$arg" == '-a' || "$arg" == '-aa' ) then /bin/rm -f phys/module_sf_noahmpdrv.F phys/module_sf_noahmp_glacier.F \ phys/module_sf_noahmp_groundwater.F phys/module_sf_noahmplsm.F \ run/MPTABLE.TBL + /bin/rm -f phys/module_bl_mynnedmf.F phys/module_bl_mynnedmf_common.F \ + phys/module_bl_mynnedmf_driver.F endif endif diff --git a/dyn_em/module_first_rk_step_part1.F b/dyn_em/module_first_rk_step_part1.F index 6623cab7bd..d3438f1976 100644 --- a/dyn_em/module_first_rk_step_part1.F +++ b/dyn_em/module_first_rk_step_part1.F @@ -1232,7 +1232,7 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,qcg=grid%qcg, grav_settling=config_flags%grav_settling & ! & ,K_m=grid%K_m, K_h=grid%K_h, K_q=grid%K_q & & ,vdfg=grid%vdfg,maxwidth=grid%maxwidth,maxMF=grid%maxmf & - & ,ztop_plume=grid%ztop_plume,ktop_plume=grid%ktop_plume & + & ,ztop_plume=grid%ztop_plume & & ,spp_pbl=config_flags%spp_pbl & & ,pattern_spp_pbl=grid%pattern_spp_pbl & & ,restart=config_flags%restart,cycling=config_flags%cycling & diff --git a/main/depend.common b/main/depend.common index 9ca1327f5f..b93dd1693e 100644 --- a/main/depend.common +++ b/main/depend.common @@ -663,13 +663,13 @@ module_bl_gfsedmf.o: \ module_gfs_physcons.o -module_bl_mynn.o: \ - module_bl_mynn_common.o +module_bl_mynnedmf.o: \ + module_bl_mynnedmf_common.o -module_bl_mynn_wrapper.o: \ - module_bl_mynn.o \ - module_bl_mynn_common.o +module_bl_mynnedmf_driver.o: \ + module_bl_mynnedmf.o \ + module_bl_mynnedmf_common.o module_bl_gwdo.o: \ @@ -735,7 +735,6 @@ module_bl_camuwpbl_driver.o: \ module_sf_mynn.o: \ - module_bl_mynn.o \ ../share/module_model_constants.o \ ../frame/module_wrf_error.o @@ -1300,8 +1299,8 @@ module_physics_init.o: \ module_bl_acm.o \ module_bl_myjpbl.o \ module_bl_qnsepbl.o \ - module_bl_mynn.o \ - module_bl_mynn_wrapper.o \ + module_bl_mynnedmf.o \ + module_bl_mynnedmf_driver.o \ module_bl_myjurb.o \ module_bl_boulac.o \ module_bl_camuwpbl_driver.o \ @@ -1476,8 +1475,8 @@ module_pbl_driver.o: \ module_bl_camuwpbl_driver.o \ module_bl_gfs.o \ module_bl_gfsedmf.o \ - module_bl_mynn.o \ - module_bl_mynn_wrapper.o \ + module_bl_mynnedmf.o \ + module_bl_mynnedmf_driver.o \ module_bl_fogdes.o \ module_bl_gwdo.o \ module_bl_gwdo_gsl.o \ @@ -2780,8 +2779,7 @@ module_bl_mfshconvpbl.o: \ ../share/module_model_constants.o -module_bl_mynn_common.o: \ - module_gfs_machine.o \ +module_bl_mynnedmf_common.o: \ ../share/module_model_constants.o \ ccpp_kind_types.o diff --git a/phys/MYNN-EDMF b/phys/MYNN-EDMF new file mode 160000 index 0000000000..90f36c2525 --- /dev/null +++ b/phys/MYNN-EDMF @@ -0,0 +1 @@ +Subproject commit 90f36c25259ec1960b24325f5b29ac7c5adeac73 diff --git a/phys/Makefile b/phys/Makefile index a7fb3dafe4..30ed8aca1c 100644 --- a/phys/Makefile +++ b/phys/Makefile @@ -43,9 +43,9 @@ MODULES = \ module_bl_myjpbl.o \ module_bl_qnsepbl.o \ module_bl_acm.o \ - module_bl_mynn_common.o \ - module_bl_mynn.o \ - module_bl_mynn_wrapper.o \ + module_bl_mynnedmf_common.o \ + module_bl_mynnedmf.o \ + module_bl_mynnedmf_driver.o \ module_bl_fogdes.o \ module_bl_gwdo.o \ module_bl_gwdo_gsl.o \ @@ -270,7 +270,17 @@ submodules : else \ echo No action required for NoahMP submodule ; \ fi - + @if [ \( ! -f module_bl_mynnedmf.F \) -o \( ! -f module_bl_mynedmf_common.F \) -o \ + \( ! -f module_bl_mynnedmf_driver.F \) ] ; then \ + echo Pulling in MYNN-EDMF submodule ; \ + ( cd .. ; git submodule update --init --recursive ) ; \ + ln -sf MYNN-EDMF/module_bl_mynnedmf.F90 module_bl_mynnedmf.F ; \ + ln -sf MYNN-EDMF/WRF/module_bl_mynnedmf_common.F90 module_bl_mynnedmf_common.F ; \ + ln -sf MYNN-EDMF/WRF/module_bl_mynnedmf_driver.F90 module_bl_mynnedmf_driver.F ; \ + else \ + echo No action required for MYNN-EDMF submodule ; \ + fi + clean: @ echo 'use the clean script' diff --git a/phys/module_bl_mynn.F b/phys/module_bl_mynn.F deleted file mode 100644 index c1ea9c6417..0000000000 --- a/phys/module_bl_mynn.F +++ /dev/null @@ -1,7743 +0,0 @@ -!>\file module_bl_mynn.F90 -!! This file contains the entity of MYNN-EDMF PBL scheme. -! ********************************************************************** -! * An improved Mellor-Yamada turbulence closure model * -! * * -! * Original author: M. Nakanishi (N.D.A), naka@nda.ac.jp * -! * Translated into F90 and implemented in WRF-ARW by: * -! * Mariusz Pagowski (NOAA-GSL) * -! * Subsequently developed by: * -! * Joseph Olson, Jaymes Kenyon (NOAA/GSL), * -! * Wayne Angevine (NOAA/CSL), Kay Suselj (NASA/JPL), * -! * Franciano Puhales (UFSM), Laura Fowler (NCAR), * -! * Elynn Wu (UCSD), and Jordan Schnell (NOAA/GSL) * -! * * -! * Contents: * -! * * -! * mynn_bl_driver - main subroutine which calls all other routines * -! * -------------- * -! * 1. mym_initialize (to be called once initially) * -! * gives the closure constants and initializes the turbulent * -! * quantities. * -! * 2. get_pblh * -! * Calculates the boundary layer height * -! * 3. scale_aware * -! * Calculates scale-adaptive tapering functions * -! * 4. mym_condensation * -! * determines the liquid water content and the cloud fraction * -! * diagnostically. * -! * 5. dmp_mf * -! * Calls the (nonlocal) mass-flux component * -! * 6. ddmf_jpl * -! * Calls the downdraft mass-flux component * -! * (-) mym_level2 (called in the other subroutines) * -! * calculates the stability functions at Level 2. * -! * (-) mym_length (called in the other subroutines) * -! * calculates the master length scale. * -! * 7. mym_turbulence * -! * calculates the vertical diffusivity coefficients and the * -! * production terms for the turbulent quantities. * -! * 8. mym_predict * -! * predicts the turbulent quantities at the next step. * -! * * -! * call mym_initialize * -! * | * -! * |<----------------+ * -! * | | * -! * call get_pblh | * -! * call scale_aware | * -! * call mym_condensation | * -! * call dmp_mf | * -! * call ddmf_jpl | * -! * call mym_turbulence | * -! * call mym_predict | * -! * | | * -! * |-----------------+ * -! * | * -! * end * -! * * -! * Variables worthy of special mention: * -! * tref : Reference temperature * -! * thl : Liquid water potential temperature * -! * qw : Total water (water vapor+liquid water) content * -! * ql : Liquid water content * -! * vt, vq : Functions for computing the buoyancy flux * -! * qke : 2 * TKE * -! * el : mixing length * -! * * -! * If the water contents are unnecessary, e.g., in the case of * -! * ocean models, thl is the potential temperature and qw, ql, vt * -! * and vq are all zero. * -! * * -! * Grid arrangement: * -! * k+1 +---------+ * -! * | | i = 1 - nx * -! * (k) | * | k = 1 - nz * -! * | | * -! * k +---------+ * -! * i (i) i+1 * -! * * -! * All the predicted variables are defined at the center (*) of * -! * the grid boxes. The diffusivity coefficients and two of their * -! * components (el and stability functions sh & sm) are, however, * -! * defined on the walls of the grid boxes. * -! * # Upper boundary values are given at k=nz. * -! * * -! * References: * -! * 1. Nakanishi, M., 2001: * -! * Boundary-Layer Meteor., 99, 349-378. * -! * 2. Nakanishi, M. and H. Niino, 2004: * -! * Boundary-Layer Meteor., 112, 1-31. * -! * 3. Nakanishi, M. and H. Niino, 2006: * -! * Boundary-Layer Meteor., 119, 397-407. * -! * 4. Nakanishi, M. and H. Niino, 2009: * -! * Jour. Meteor. Soc. Japan, 87, 895-912. * -! * 5. Olson J. and coauthors, 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. * -! * 6. Puhales, Franciano S. and coauthors, 2020: Turbulent * -! * Kinetic Energy Budget for MYNN-EDMF PBL Scheme in WRF model.* -! * Universidade Federal de Santa Maria Technical Note. 9 pp. * -! ********************************************************************** -! ================================================================== -! Notes on original implementation into WRF-ARW -! changes to original code: -! 1. code is 1D (in z) -! 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 -! distances in z[m] -! 5. cosmetic changes to adhere to WRF standard (remove common blocks, -! intent etc) -!------------------------------------------------------------------- -! Further modifications post-implementation -! -! 1. Addition of BouLac mixing length in the free atmosphere. -! 2. Changed the turbulent mixing length to be integrated from the -! surface to the top of the BL + a transition layer depth. -! v3.4.1: Option to use Kitamura/Canuto modification which removes -! the critical Richardson number and negative TKE (default). -! Hybrid PBL height diagnostic, which blends a theta-v-based -! definition in neutral/convective BL and a TKE-based definition -! in stable conditions. -! TKE budget output option -! v3.5.0: TKE advection option (bl_mynn_tkeadvect) -! v3.5.1: Fog deposition related changes. -! v3.6.0: Removed fog deposition from the calculation of tendencies -! Added mixing of qc, qi, qni -! Added output for wstar, delta, TKE_PBL, & KPBL for correct -! coupling to shcu schemes -! v3.8.0: Added subgrid scale cloud output for coupling to radiation -! schemes (activated by setting icloud_bl =1 in phys namelist). -! Added WRF_DEBUG prints (at level 3000) -! Added Tripoli and Cotton (1981) correction. -! Added namelist option bl_mynn_cloudmix to test effect of mixing -! cloud species (default = 1: on). -! Added mass-flux option (bl_mynn_edmf, = 1 for DMP mass-flux, 0: off). -! Related options: -! bl_mynn_edmf_mom = 1 : activate momentum transport in MF scheme -! bl_mynn_edmf_tke = 1 : activate TKE transport in MF scheme -! Added mixing length option (bl_mynn_mixlength, see notes below) -! Added more sophisticated saturation checks, following Thompson scheme -! Added new cloud PDF option (bl_mynn_cloudpdf = 2) from Chaboureau -! and Bechtold (2002, JAS, with mods) -! Added capability to mix chemical species when env variable -! WRF_CHEM = 1, thanks to Wayne Angevine. -! Added scale-aware mixing length, following Junshi Ito's work -! Ito et al. (2015, BLM). -! v3.9.0 Improvement to the mass-flux scheme (dynamic number of plumes, -! better plume/cloud depth, significant speed up, better cloud -! fraction). -! Added Stochastic Parameter Perturbation (SPP) implementation. -! Many miscellaneous tweaks to the mixing lengths and stratus -! component of the subgrid clouds. -! v.4.0 Removed or added alternatives to WRF-specific functions/modules -! for the sake of portability to other models. -! the sake of portability to other models. -! Further refinement of mass-flux scheme from SCM experiments with -! Wayne Angevine: switch to linear entrainment and back to -! Simpson and Wiggert-type w-equation. -! Addition of TKE production due to radiation cooling at top of -! clouds (proto-version); not activated by default. -! Some code rewrites to move if-thens out of loops in an attempt to -! improve computational efficiency. -! New tridiagonal solver, which is supposedly 14% faster and more -! conservative. Impact seems very small. -! Many miscellaneous tweaks to the mixing lengths and stratus -! component of the subgrid-scale (SGS) clouds. -! v4.1 Big improvements in downward SW radiation due to revision of subgrid clouds -! - better cloud fraction and subgrid scale mixing ratios. -! - may experience a small cool bias during the daytime now that high -! SW-down bias is greatly reduced... -! Some tweaks to increase the turbulent mixing during the daytime for -! bl_mynn_mixlength option 2 to alleviate cool bias (very small impact). -! Improved ensemble spread from changes to SPP in MYNN -! - now perturbing eddy diffusivity and eddy viscosity directly -! - now perturbing background rh (in SGS cloud calc only) -! - now perturbing entrainment rates in mass-flux scheme -! Added IF checks (within IFDEFS) to protect mixchem code from being used -! when HRRR smoke is used (no impact on regular non-wrf chem use) -! Important bug fix for wrf chem when transporting chemical species in MF scheme -! Removed 2nd mass-flux scheme (no only bl_mynn_edmf = 1, no option 2) -! Removed unused stochastic code for mass-flux scheme -! Changed mass-flux scheme to be integrated on interface levels instead of -! mass levels - impact is small -! Added option to mix 2nd moments in MYNN as opposed to the scalar_pblmix option. -! - activated with bl_mynn_mixscalars = 1; this sets scalar_pblmix = 0 -! - added tridagonal solver used in scalar_pblmix option to duplicate tendencies -! - this alone changes the interface call considerably from v4.0. -! Slight revision to TKE production due to radiation cooling at top of clouds -! Added the non-Guassian buoyancy flux function of Bechtold and Siebesma (1998, JAS). -! - improves TKE in SGS clouds -! Added heating due to dissipation of TKE (small impact, maybe + 0.1 C daytime PBL temp) -! Misc changes made for FV3/MPAS compatibility -! v4.2 A series of small tweaks to help reduce a cold bias in the PBL: -! - slight increase in diffusion in convective conditions -! - relaxed criteria for mass-flux activation/strength -! - added capability to cycle TKE for continuity in hourly updating HRRR -! - added effects of compensational environmental subsidence in mass-flux scheme, -! which resulted in tweaks to detrainment rates. -! Bug fix for diagnostic-decay of SGS clouds - noticed by Greg Thompson. This has -! a very small, but primarily positive, impact on SW-down biases. -! Tweak to calculation of KPBL - urged by Laura Fowler - to make more intuitive. -! Tweak to temperature range of blending for saturation check (water to ice). This -! slightly reduces excessive SGS clouds in polar region. No impact warm clouds. -! Added namelist option bl_mynn_output (0 or 1) to suppress or activate the -! allocation and output of 10 3D variables. Most people will want this -! set to 0 (default) to save memory and disk space. -! Added new array qi_bl as opposed to using qc_bl for both SGS qc and qi. This -! gives us more control of the magnitudes which can be confounded by using -! a single array. As a results, many subroutines needed to be modified, -! especially mym_condensation. -! Added the blending of the stratus component of the SGS clouds to the mass-flux -! clouds to account for situations where stratus and cumulus may exist in the -! grid cell. -! Misc small-impact bugfixes: -! 1) dz was incorrectly indexed in mym_condensation -! 2) configurations with icloud_bl = 0 were using uninitialized arrays -! v4.5 / 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 (expanded range, same as used for Jimenez et al (MWR) -! see the Technical Note for this implementation (small impact). -! 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 higher-order moments for sigma when using -! bl_mynn_cloudpdf = 2 (Chab-Becht). -! Removed WRF_CHEM dependencies. -! Many miscellaneous tweaks. -! v4.6 / CCPP -! Some code optimization. Removed many conditions from loops. Redesigned the mass- -! flux scheme to use 8 plumes instead of a variable n plumes. This results in -! the removal of the output variable "nudprafts" and adds maxwidth and ztop_plume. -! Revision option bl_mynn_cloudpdf = 2, which now ensures cloud fractions for all -! optically relevant mixing ratios (tip from Greg Thompson). Also, added flexibility -! for tuning near-surface cloud fractions to remove excess fog/low ceilings. -! Now outputs all SGS cloud mixing ratios as grid-mean values, not in-cloud. This -! results in a change in the pre-radiation code to no longer multiply mixing ratios -! by cloud fractions. -! Bug fix for the momentum transport. -! Lots of code cleanup: removal of test code, comments, changing text case, etc. -! Many misc tuning/tweaks. -! -! Many of these changes are now documented in references listed above. -!==================================================================== - -MODULE module_bl_mynn - - use module_bl_mynn_common,only: & - cp , cpv , cliq , cice , & - p608 , ep_2 , ep_3 , gtr , & - grav , g_inv , karman , p1000mb , & - rcp , r_d , r_v , rk , & - rvovrd , svp1 , svp2 , svp3 , & - xlf , xlv , xls , xlscp , & - xlvcp , tv0 , tv1 , tref , & - zero , half , one , two , & - onethird , twothirds , tkmin , t0c , & - tice , kind_phys - - - IMPLICIT NONE - -!=================================================================== -! From here on, these are MYNN-specific parameters: -! The parameters below depend on stability functions of module_sf_mynn. - real(kind_phys), parameter :: cphm_st=5.0, cphm_unst=16.0, & - cphh_st=5.0, cphh_unst=16.0 - -! Closure constants - real(kind_phys), parameter :: & - &pr = 0.74, & - &g1 = 0.235, & ! NN2009 = 0.235 - &b1 = 24.0, & - &b2 = 15.0, & ! CKmod NN2009 - &c2 = 0.729, & ! 0.729, & !0.75, & - &c3 = 0.340, & ! 0.340, & !0.352, & - &c4 = 0.0, & - &c5 = 0.2, & - &a1 = b1*( 1.0-3.0*g1 )/6.0, & -! &c1 = g1 -1.0/( 3.0*a1*b1**(1.0/3.0) ), & - &c1 = g1 -1.0/( 3.0*a1*2.88449914061481660), & - &a2 = a1*( g1-c1 )/( g1*pr ), & - &g2 = b2/b1*( 1.0-c3 ) +2.0*a1/b1*( 3.0-2.0*c2 ) - - real(kind_phys), parameter :: & - &cc2 = 1.0-c2, & - &cc3 = 1.0-c3, & - &e1c = 3.0*a2*b2*cc3, & - &e2c = 9.0*a1*a2*cc2, & - &e3c = 9.0*a2*a2*cc2*( 1.0-c5 ), & - &e4c = 12.0*a1*a2*cc2, & - &e5c = 6.0*a1*a1 - -! Constants for min tke in elt integration (qmin), max z/L in els (zmax), -! and factor for eddy viscosity for TKE (Kq = Sqfac*Km): - real(kind_phys), 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.2 - - real(kind_phys), parameter :: qkemin=1.e-3 - real(kind_phys), parameter :: tliq = 269. !all hydrometeors are liquid when T > tliq - -! Constants for cloud PDF (mym_condensation) - real(kind_phys), parameter :: rr2=0.7071068, rrp=0.3989423 - - !>Use Canuto/Kitamura mod (remove Ric and negative TKE) (1:yes, 0:no) - !!For more info, see Canuto et al. (2008 JAS) and Kitamura (Journal of the - !!Meteorological Society of Japan, Vol. 88, No. 5, pp. 857-864, 2010). - !!Note that this change required further modification of other parameters - !!above (c2, c3). If you want to remove this option, set c2 and c3 constants - !!(above) back to NN2009 values (see commented out lines next to the - !!parameters above). This only removes the negative TKE problem - !!but does not necessarily improve performance - neutral impact. - real(kind_phys), parameter :: CKmod=1. - - !>Use Ito et al. (2015, BLM) scale-aware (0: no, 1: yes). Note that this also has impacts - !!on the cloud PDF and mass-flux scheme, using LES-derived similarity function. - real(kind_phys), parameter :: scaleaware=1. - - !>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) - integer, parameter :: bl_mynn_edmf_dd = 0 - - !>Option to activate heating due to dissipation of TKE (to activate, set to 1.0) - integer, parameter :: dheat_opt = 1 - - !Option to activate environmental subsidence in mass-flux scheme - logical, parameter :: env_subs = .false. - - !Option to switch flux-profile relationship for surface (from Puhales et al. 2020) - !0: use original Dyer-Hicks, 1: use Cheng-Brustaert and Blended COARE - integer, parameter :: bl_mynn_stfunc = 1 - - !option to print out more stuff for debugging purposes - logical, parameter :: debug_code = .false. - integer, parameter :: idbg = 23 !specific i-point to write out - - ! Used in WRF-ARW module_physics_init.F - integer :: mynn_level - - -CONTAINS - -! ================================================================== -!>\ingroup gsd_mynn_edmf -!! This subroutine is the GSD MYNN-EDNF PBL driver routine,which -!! encompassed the majority of the subroutines that comprise the -!! procedures that ultimately solve for tendencies of -!! \f$U, V, \theta, q_v, q_c, and q_i\f$. -!!\section gen_mynn_bl_driver GSD mynn_bl_driver General Algorithm -!> @{ - SUBROUTINE mynn_bl_driver( & - &initflag,restart,cycling, & - &delt,dz,dx,znt, & - &u,v,w,th,sqv3d,sqc3d,sqi3d, & - &sqs3d,qnc,qni, & - &qnwfa,qnifa,qnbca,ozone, & - &p,exner,rho,t3d, & - &xland,ts,qsfc,ps, & - &ust,ch,hfx,qfx,rmol,wspd, & - &uoce,voce, & !ocean current - &qke,qke_adv, & - &sh3d,sm3d, & - &nchem,kdvel,ndvel, & !smoke/chem variables - &chem3d,vdep, & - &frp,emis_ant_no, & - &mix_chem,enh_mix, & !note: these arrays/flags are still under development - &rrfs_sd,smoke_dbg, & !end smoke/chem variables - &tsq,qsq,cov, & - &rublten,rvblten,rthblten, & - &rqvblten,rqcblten,rqiblten, & - &rqncblten,rqniblten,rqsblten, & - &rqnwfablten,rqnifablten, & - &rqnbcablten,dozone, & - &exch_h,exch_m, & - &pblh,kpbl, & - &el_pbl, & - &dqke,qwt,qshear,qbuoy,qdiss, & - &qc_bl,qi_bl,cldfra_bl, & - &bl_mynn_tkeadvect, & - &tke_budget, & - &bl_mynn_cloudpdf, & - &bl_mynn_mixlength, & - &icloud_bl, & - &closure, & - &bl_mynn_edmf, & - &bl_mynn_edmf_mom, & - &bl_mynn_edmf_tke, & - &bl_mynn_mixscalars, & - &bl_mynn_output, & - &bl_mynn_cloudmix,bl_mynn_mixqt, & - &edmf_a,edmf_w,edmf_qt, & - &edmf_thl,edmf_ent,edmf_qc, & - &sub_thl3D,sub_sqv3D, & - &det_thl3D,det_sqv3D, & - &maxwidth,maxMF,ztop_plume, & - &ktop_plume, & - &spp_pbl,pattern_spp_pbl, & - &rthraten, & - &FLAG_QC,FLAG_QI,FLAG_QNC, & - &FLAG_QNI,FLAG_QS, & - &FLAG_QNWFA,FLAG_QNIFA, & - &FLAG_QNBCA,FLAG_OZONE, & - &IDS,IDE,JDS,JDE,KDS,KDE, & - &IMS,IME,JMS,JME,KMS,KME, & - &ITS,ITE,JTS,JTE,KTS,KTE ) - -!------------------------------------------------------------------- - - integer, intent(in) :: initflag - !INPUT NAMELIST OPTIONS: - logical, intent(in) :: restart,cycling - integer, intent(in) :: tke_budget - integer, intent(in) :: bl_mynn_cloudpdf - integer, intent(in) :: bl_mynn_mixlength - integer, intent(in) :: bl_mynn_edmf - logical, intent(in) :: bl_mynn_tkeadvect - integer, intent(in) :: bl_mynn_edmf_mom - integer, intent(in) :: bl_mynn_edmf_tke - integer, intent(in) :: bl_mynn_mixscalars - integer, intent(in) :: bl_mynn_output - integer, intent(in) :: bl_mynn_cloudmix - integer, intent(in) :: bl_mynn_mixqt - integer, intent(in) :: icloud_bl - real(kind_phys), intent(in) :: closure - - logical, intent(in) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,& - FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA, & - FLAG_OZONE,FLAG_QS - - logical, intent(in) :: mix_chem,enh_mix,rrfs_sd,smoke_dbg - - integer, intent(in) :: & - & IDS,IDE,JDS,JDE,KDS,KDE & - &,IMS,IME,JMS,JME,KMS,KME & - &,ITS,ITE,JTS,JTE,KTS,KTE - -#ifdef HARDCODE_VERTICAL -# define kts 1 -# define kte HARDCODE_VERTICAL -#endif - -! initflag > 0 for TRUE -! else for FALSE -! closure : <= 2.5; Level 2.5 -! 2.5< and <3; Level 2.6 -! = 3; Level 3 - -! SGT: Changed this to use assumed shape arrays (dimension(:,:,:)) with no "optional" arguments -! to prevent a crash on Cheyenne. Do not change it back without testing if the code runs -! on Cheyenne with the GNU compiler. - - real(kind_phys), intent(in) :: delt - real(kind_phys), dimension(ims:ime), intent(in) :: dx - real(kind_phys), dimension(ims:ime,kms:kme), intent(in) :: dz, & - &u,v,w,th,sqv3D,p,exner,rho,T3D - real(kind_phys), dimension(ims:ime,kms:kme), optional, intent(in) :: & - &sqc3D,sqi3D,sqs3D,qni,qnc,qnwfa,qnifa,qnbca - real(kind_phys), dimension(ims:ime,kms:kme), optional,intent(in):: ozone - real(kind_phys), dimension(ims:ime), intent(in):: ust, & - &ch,qsfc,ps,wspd - real(kind_phys), dimension(ims:ime,kms:kme), intent(inout) :: & - &Qke,Tsq,Qsq,Cov,qke_adv - real(kind_phys), dimension(ims:ime,kms:kme), intent(inout) :: & - &rublten,rvblten,rthblten,rqvblten,rqcblten, & - &rqiblten,rqsblten,rqniblten,rqncblten, & - &rqnwfablten,rqnifablten,rqnbcablten - real(kind_phys), dimension(ims:ime,kms:kme), intent(inout) :: dozone - real(kind_phys), dimension(ims:ime,kms:kme), intent(in) :: rthraten - - real(kind_phys), dimension(ims:ime,kms:kme), intent(out) :: exch_h,exch_m - real(kind_phys), dimension(ims:ime), intent(in) :: xland, & - &ts,znt,hfx,qfx,uoce,voce - - !These 10 arrays are only allocated when bl_mynn_output > 0 - real(kind_phys), dimension(ims:ime,kms:kme), optional, intent(inout) :: & - & 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(kind_phys), dimension(ims:ime), intent(inout) :: pblh - real(kind_phys), dimension(ims:ime), intent(inout) :: rmol - - real(kind_phys), dimension(ims:ime) :: psig_bl,psig_shcu - - integer,dimension(ims:ime),intent(inout) :: & - &KPBL,ktop_plume - - real(kind_phys), dimension(ims:ime), intent(out) :: & - &maxmf,maxwidth,ztop_plume - - real(kind_phys), dimension(ims:ime,kms:kme), intent(inout) :: el_pbl - - real(kind_phys), dimension(ims:ime,kms:kme), optional, intent(inout) :: & - &qWT,qSHEAR,qBUOY,qDISS,dqke - ! 3D budget arrays are not allocated when tke_budget == 0 - ! 1D (local) budget arrays are used for passing between subroutines. - real(kind_phys), dimension(kts:kte) :: & - &qwt1,qshear1,qbuoy1,qdiss1,dqke1,diss_heat - - real(kind_phys), dimension(ims:ime,kms:kme), intent(out) :: Sh3D,Sm3D - - real(kind_phys), dimension(ims:ime,kms:kme), intent(inout) :: & - &qc_bl,qi_bl,cldfra_bl - real(kind_phys), dimension(kts:kte) :: qc_bl1D,qi_bl1D, & - &cldfra_bl1D,qc_bl1D_old,qi_bl1D_old,cldfra_bl1D_old - -! smoke/chemical arrays - integer, intent(IN ) :: nchem, kdvel, ndvel - real(kind_phys), dimension(ims:ime,kms:kme,nchem), optional, intent(inout) :: chem3d - real(kind_phys), dimension(ims:ime, ndvel), optional, intent(in) :: vdep - real(kind_phys), dimension(ims:ime), optional, intent(in) :: frp,EMIS_ANT_NO - !local - real(kind_phys), dimension(kts:kte ,nchem) :: chem1 - real(kind_phys), dimension(kts:kte+1,nchem) :: s_awchem1 - real(kind_phys), dimension(ndvel) :: vd1 - integer :: ic - -!local vars - integer :: ITF,JTF,KTF, IMD,JMD - integer :: i,j,k,kproblem - real(kind_phys), dimension(kts:kte) :: & - &thl,tl,qv1,qc1,qi1,qs1,sqw, & - &el, dfm, dfh, dfq, tcd, qcd, pdk, pdt, pdq, pdc, & - &vt, vq, sgm, kzero - real(kind_phys), dimension(kts:kte) :: & - &thetav,sh,sm,u1,v1,w1,p1, & - &ex1,dz1,th1,tk1,rho1,qke1,tsq1,qsq1,cov1, & - &sqv,sqi,sqc,sqs, & - &du1,dv1,dth1,dqv1,dqc1,dqi1,dqs1,ozone1, & - &k_m1,k_h1,qni1,dqni1,qnc1,dqnc1,qnwfa1,qnifa1, & - &qnbca1,dqnwfa1,dqnifa1,dqnbca1,dozone1 - - !mass-flux variables - real(kind_phys), dimension(kts:kte) :: & - &dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf - real(kind_phys), dimension(kts:kte) :: & - &edmf_a1,edmf_w1,edmf_qt1,edmf_thl1, & - &edmf_ent1,edmf_qc1 - real(kind_phys), dimension(kts:kte) :: & - &edmf_a_dd1,edmf_w_dd1,edmf_qt_dd1,edmf_thl_dd1, & - &edmf_ent_dd1,edmf_qc_dd1 - real(kind_phys), dimension(kts:kte) :: & - &sub_thl,sub_sqv,sub_u,sub_v, & - &det_thl,det_sqv,det_sqc,det_u,det_v - real(kind_phys), 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, & - &s_awqnbca1 - real(kind_phys), dimension(kts:kte+1) :: & - &sd_aw1,sd_awthl1,sd_awqt1, & - &sd_awqv1,sd_awqc1,sd_awu1,sd_awv1,sd_awqke1 - - real(kind_phys), dimension(kts:kte+1) :: zw - real(kind_phys) :: cpm,sqcg,flt,fltv,flq,flqv,flqc, & - &pmz,phh,exnerg,zet,phi_m, & - &afk,abk,ts_decay, qc_bl2, qi_bl2, & - &th_sfc,wsp - - !top-down diffusion - real(kind_phys), dimension(ITS:ITE) :: maxKHtopdown - real(kind_phys), dimension(kts:kte) :: KHtopdown,TKEprodTD - - logical :: INITIALIZE_QKE,problem - - ! Stochastic fields - integer, intent(in) :: spp_pbl - real(kind_phys), dimension(ims:ime,kms:kme), optional, intent(in) :: pattern_spp_pbl - real(kind_phys), dimension(kts:kte) :: rstoch_col - - ! Substepping TKE - integer :: nsub - real(kind_phys) :: delt2 - - - if (debug_code) then !check incoming values - do i=its,ite - problem = .false. - do k=kts,kte - wsp = sqrt(u(i,k)**2 + v(i,k)**2) - if (abs(hfx(i)) > 1200. .or. abs(qfx(i)) > 0.001 .or. & - wsp > 200. .or. t3d(i,k) > 360. .or. t3d(i,k) < 160. .or. & - sqv3d(i,k)< 0.0 .or. sqc3d(i,k)< 0.0 ) then - kproblem = k - problem = .true. - print*,"Incoming problem at: i=",i," k=1" - print*," QFX=",qfx(i)," HFX=",hfx(i) - print*," wsp=",wsp," T=",t3d(i,k) - print*," qv=",sqv3d(i,k)," qc=",sqc3d(i,k) - print*," u*=",ust(i)," wspd=",wspd(i) - print*," xland=",xland(i)," ts=",ts(i) - print*," z/L=",0.5*dz(i,1)*rmol(i)," ps=",ps(i) - print*," znt=",znt(i)," dx=",dx(i) - endif - enddo - if (problem) then - print*,"===tk:",t3d(i,max(kproblem-3,1):min(kproblem+3,kte)) - print*,"===qv:",sqv3d(i,max(kproblem-3,1):min(kproblem+3,kte)) - print*,"===qc:",sqc3d(i,max(kproblem-3,1):min(kproblem+3,kte)) - print*,"===qi:",sqi3d(i,max(kproblem-3,1):min(kproblem+3,kte)) - print*,"====u:",u(i,max(kproblem-3,1):min(kproblem+3,kte)) - print*,"====v:",v(i,max(kproblem-3,1):min(kproblem+3,kte)) - endif - enddo - endif - -!*** Begin debugging - IMD=(IMS+IME)/2 - JMD=(JMS+JME)/2 -!*** End debugging - - JTF=JTE - ITF=ITE - KTF=KTE - - 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 - ztop_plume(its:ite)=0. - maxwidth(its:ite)=0. - maxmf(its:ite)=0. - maxKHtopdown(its:ite)=0. - kzero(kts:kte)=0. - - ! 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, -!! several arrays are initialized and k-oriented (vertical) subroutines are called -!! at every i and j point, corresponding to the x- and y- directions, respectively. - IF (initflag > 0 .and. .not.restart) THEN - - !Test to see if we want to initialize qke - IF ( (restart .or. cycling)) THEN - IF (MAXVAL(QKE(its:ite,kts)) < 0.0002) THEN - INITIALIZE_QKE = .TRUE. - !print*,"QKE is too small, must initialize" - ELSE - INITIALIZE_QKE = .FALSE. - !print*,"Using background QKE, will not initialize" - ENDIF - ELSE ! not cycling or restarting: - INITIALIZE_QKE = .TRUE. - !print*,"not restart nor cycling, must initialize QKE" - ENDIF - - if (.not.restart .or. .not.cycling) THEN - Sh3D(its:ite,kts:kte)=0. - Sm3D(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 - cldfra_bl1D(kts:kte)=0.0 - end if - dqc1(kts:kte)=0.0 - dqi1(kts:kte)=0.0 - dqni1(kts:kte)=0.0 - dqnc1(kts:kte)=0.0 - dqnwfa1(kts:kte)=0.0 - dqnifa1(kts:kte)=0.0 - dqnbca1(kts:kte)=0.0 - dozone1(kts:kte)=0.0 - qc_bl1D_old(kts:kte)=0.0 - cldfra_bl1D_old(kts:kte)=0.0 - 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 - - DO k=KTS,KTE - DO i=ITS,ITF - exch_m(i,k)=0. - exch_h(i,k)=0. - ENDDO - ENDDO - - IF (tke_budget .eq. 1) THEN - 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 i=ITS,ITF - if (FLAG_QI ) then - sqi(:)=sqi3D(i,:) - else - sqi = 0.0 - endif - if (FLAG_QS ) then - sqs(:)=sqs3D(i,:) - else - sqs = 0.0 - endif - if (icloud_bl > 0) then - cldfra_bl1d(:)=cldfra_bl(i,:) - qc_bl1d(:)=qc_bl(i,:) - qi_bl1d(:)=qi_bl(i,:) - endif - - 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) - 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)) - thetav(k)=th(i,k)*(1.+p608*sqv(k)) - !keep snow out for now - increases ceiling bias - sqw(k)=sqv(k)+sqc(k)+sqi(k)!+sqs(k) - thl(k)=th1(k) - xlvcp/ex1(k)*sqc(k) & - & - xlscp/ex1(k)*(sqi(k))!+sqs(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) & - ! & - xlscp/MAX(tk1(k),TKmin)*sqi(k)) - - IF (k==kts) THEN - zw(k)=0. - ELSE - 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) * MAX((ust(i)*700. - zw(k))/(MAX(ust(i),0.01)*700.), 0.01) - ELSE - qke1(k)=qke(i,k) - ENDIF - el(k)=el_pbl(i,k) - sh(k)=Sh3D(i,k) - sm(k)=Sm3D(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) - else - rstoch_col(k)=0.0 - endif - - ENDDO - - zw(kte+1)=zw(kte)+dz(i,kte) - -!> - Call get_pblh() to calculate hybrid (\f$\theta_{v}-TKE\f$) PBL height. - CALL GET_PBLH(KTS,KTE,PBLH(i),thetav,& - & 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),PBLH(i),Psig_bl(i),Psig_shcu(i)) - ELSE - Psig_bl(i)=1.0 - Psig_shcu(i)=1.0 - ENDIF - - ! DH* CHECK IF WE CAN DO WITHOUT CALLING THIS ROUTINE FOR RESTARTS -!> - Call mym_initialize() to initializes the mixing length, TKE, \f$\theta^{'2}\f$, -!! \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,xland(i), & - &dz1, dx(i), zw, & - &u1, v1, thl, sqv, & - &PBLH(i), th1, thetav, sh, sm, & - &ust(i), rmol(i), & - &el, Qke1, Tsq1, Qsq1, Cov1, & - &Psig_bl(i), cldfra_bl1D, & - &bl_mynn_mixlength, & - &edmf_w1,edmf_a1, & - &INITIALIZE_QKE, & - &spp_pbl,rstoch_col ) - - IF (.not.restart) THEN - !UPDATE 3D VARIABLES - DO k=KTS,KTE !KTF - el_pbl(i,k)=el(k) - sh3d(i,k)=sh(k) - sm3d(i,k)=sm(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 -! 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) -! 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 !end i-loop - - ENDIF ! end initflag - -!> - After initializing all required variables, the regular procedures -!! performed at every time step are ready for execution. - !ACF- copy qke_adv array into qke if using advection - IF (bl_mynn_tkeadvect) THEN - qke=qke_adv - ENDIF - - DO i=ITS,ITF - !Initialize some arrays - if (tke_budget .eq. 1) then - dqke(i,:)=qke(i,:) - endif - if (FLAG_QI ) then - sqi(:)=sqi3D(i,:) - else - sqi = 0.0 - endif - if (FLAG_QS ) then - sqs(:)=sqs3D(i,:) - else - sqs = 0.0 - endif - if (icloud_bl > 0) then - CLDFRA_BL1D(:)=CLDFRA_BL(i,:) - QC_BL1D(:) =QC_BL(i,:) - QI_BL1D(:) =QI_BL(i,:) - cldfra_bl1D_old(:)=cldfra_bl(i,:) - qc_bl1D_old(:)=qc_bl(i,:) - qi_bl1D_old(:)=qi_bl(i,:) - else - CLDFRA_BL1D =0.0 - QC_BL1D =0.0 - QI_BL1D =0.0 - cldfra_bl1D_old=0.0 - qc_bl1D_old =0.0 - qi_bl1D_old =0.0 - endif - dz1(kts:kte) =dz(i,kts:kte) - u1(kts:kte) =u(i,kts:kte) - v1(kts:kte) =v(i,kts:kte) - w1(kts:kte) =w(i,kts:kte) - th1(kts:kte) =th(i,kts:kte) - tk1(kts:kte) =T3D(i,kts:kte) - p1(kts:kte) =p(i,kts:kte) - ex1(kts:kte) =exner(i,kts:kte) - rho1(kts:kte) =rho(i,kts:kte) - sqv(kts:kte) =sqv3D(i,kts:kte) !/(1.+qv(i,kts:kte)) - sqc(kts:kte) =sqc3D(i,kts:kte) !/(1.+qv(i,kts:kte)) - qv1(kts:kte) =sqv(kts:kte)/(1.-sqv(kts:kte)) - qc1(kts:kte) =sqc(kts:kte)/(1.-sqv(kts:kte)) - qi1(kts:kte) =sqi(kts:kte)/(1.-sqv(kts:kte)) - qs1(kts:kte) =sqs(kts:kte)/(1.-sqv(kts:kte)) - dqc1(kts:kte) =0.0 - dqi1(kts:kte) =0.0 - dqs1(kts:kte) =0.0 - dqni1(kts:kte) =0.0 - dqnc1(kts:kte) =0.0 - dqnwfa1(kts:kte)=0.0 - dqnifa1(kts:kte)=0.0 - dqnbca1(kts:kte)=0.0 - dozone1(kts:kte)=0.0 - IF (FLAG_QNI ) THEN - qni1(kts:kte)=qni(i,kts:kte) - ELSE - qni1(kts:kte)=0.0 - ENDIF - IF (FLAG_QNC ) THEN - qnc1(kts:kte)=qnc(i,kts:kte) - ELSE - qnc1(kts:kte)=0.0 - ENDIF - IF (FLAG_QNWFA ) THEN - qnwfa1(kts:kte)=qnwfa(i,kts:kte) - ELSE - qnwfa1(kts:kte)=0.0 - ENDIF - IF (FLAG_QNIFA ) THEN - qnifa1(kts:kte)=qnifa(i,kts:kte) - ELSE - qnifa1(kts:kte)=0.0 - ENDIF - IF (FLAG_QNBCA ) THEN - qnbca1(kts:kte)=qnbca(i,kts:kte) - ELSE - qnbca1(kts:kte)=0.0 - ENDIF - IF (FLAG_OZONE ) THEN - ozone1(kts:kte)=ozone(i,kts:kte) - ELSE - ozone1(kts:kte)=0.0 - ENDIF - el(kts:kte) =el_pbl(i,kts:kte) - qke1(kts:kte)=qke(i,kts:kte) - sh(kts:kte) =sh3d(i,kts:kte) - sm(kts:kte) =sm3d(i,kts:kte) - tsq1(kts:kte)=tsq(i,kts:kte) - qsq1(kts:kte)=qsq(i,kts:kte) - cov1(kts:kte)=cov(i,kts:kte) - if (spp_pbl==1) then - rstoch_col(kts:kte)=pattern_spp_pbl(i,kts:kte) - else - rstoch_col(kts:kte)=0.0 - endif - !edmf - edmf_a1 =0.0 - edmf_w1 =0.0 - edmf_qc1 =0.0 - s_aw1 =0.0 - s_awthl1 =0.0 - s_awqt1 =0.0 - s_awqv1 =0.0 - s_awqc1 =0.0 - s_awu1 =0.0 - s_awv1 =0.0 - s_awqke1 =0.0 - s_awqnc1 =0.0 - s_awqni1 =0.0 - s_awqnwfa1 =0.0 - s_awqnifa1 =0.0 - s_awqnbca1 =0.0 - ![EWDD] - edmf_a_dd1 =0.0 - edmf_w_dd1 =0.0 - edmf_qc_dd1=0.0 - sd_aw1 =0.0 - sd_awthl1 =0.0 - sd_awqt1 =0.0 - sd_awqv1 =0.0 - sd_awqc1 =0.0 - sd_awu1 =0.0 - sd_awv1 =0.0 - sd_awqke1 =0.0 - sub_thl =0.0 - sub_sqv =0.0 - sub_u =0.0 - sub_v =0.0 - det_thl =0.0 - det_sqv =0.0 - det_sqc =0.0 - det_u =0.0 - det_v =0.0 - - do k = kts,kte - if (k==kts) then - zw(k)=0. - else - zw(k)=zw(k-1)+dz(i,k-1) - endif - !keep snow out for now - increases ceiling bias - sqw(k)= sqv(k)+sqc(k)+sqi(k)!+sqs(k) - thl(k)= th1(k) - xlvcp/ex1(k)*sqc(k) & - & - xlscp/ex1(k)*(sqi(k))!+sqs(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) & - ! & - xlscp/MAX(tk1(k),TKmin)*sqi(k)) - thetav(k)=th1(k)*(1.+p608*sqv(k)) - enddo ! end k - zw(kte+1)=zw(kte)+dz(i,kte) - - !initialize smoke/chem arrays (if used): - if ( mix_chem ) then - do ic = 1,ndvel - vd1(ic) = vdep(i,ic) ! dry deposition velocity - enddo - do k = kts,kte - do ic = 1,nchem - chem1(k,ic) = chem3d(i,k,ic) - enddo - enddo - else - do ic = 1,ndvel - vd1(ic) = 0. ! dry deposition velocity - enddo - do k = kts,kte - do ic = 1,nchem - chem1(k,ic) = 0. - enddo - enddo - endif - s_awchem1(kts:kte+1,1:nchem) = 0.0 - -!> - Call get_pblh() to calculate the hybrid \f$\theta_{v}-TKE\f$ -!! PBL height diagnostic. - CALL GET_PBLH(KTS,KTE,PBLH(i),thetav,& - & 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),PBLH(i),Psig_bl(i),Psig_shcu(i)) - else - Psig_bl(i)=1.0 - Psig_shcu(i)=1.0 - endif - - sqcg= 0.0 !ill-defined variable; qcg has been removed - cpm=cp*(1.+0.84*qv1(kts)) - exnerg=(ps(i)/p1000mb)**rcp - - !----------------------------------------------------- - !ORIGINAL CODE - !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 ) - !----------------------------------------------------- - flqv = qfx(i)/rho1(kts) - flqc = 0.0 !currently no sea-spray fluxes, fog settling handled elsewhere - th_sfc = ts(i)/ex1(kts) - - ! TURBULENT FLUX FOR TKE BOUNDARY CONDITIONS - flq =flqv+flqc !! LATENT - flt =hfx(i)/(rho1(kts)*cpm )-xlvcp*flqc/ex1(kts) !! Temperature flux - fltv=flt + flqv*p608*th_sfc !! Virtual temperature flux - - ! Update 1/L using updated sfc heat flux and friction velocity - rmol(i) = -karman*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(i.eq.idbg)print*,"updated z/L=",zet - 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 - !Updated stability functions (Puhales, 2020) - phi_m = phim(zet) - pmz = phi_m - zet - phh = phih(zet) - end if - -!> - 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 -!! selected by use of the namelist parameter \p bl_mynn_cloudpdf. - - call mym_condensation (kts,kte, & - &dx(i),dz1,zw,xland(i), & - &thl,sqw,sqv,sqc,sqi,sqs, & - &p1,ex1,tsq1,qsq1,cov1, & - &Sh,el,bl_mynn_cloudpdf, & - &qc_bl1D,qi_bl1D,cldfra_bl1D, & - &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,fltv, & - &xland(i),kpbl(i),PBLH(i), & - &sqc,sqi,sqw,thl,th1,ex1,p1,rho1,thetav, & - &cldfra_bl1D,rthraten(i,:), & - &maxKHtopdown(i),KHtopdown,TKEprodTD ) - else - 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 - call DMP_mf( & - &kts,kte,delt,zw,dz1,p1,rho1, & - &bl_mynn_edmf_mom, & - &bl_mynn_edmf_tke, & - &bl_mynn_mixscalars, & - &u1,v1,w1,th1,thl,thetav,tk1, & - &sqw,sqv,sqc,qke1, & - &qnc1,qni1,qnwfa1,qnifa1,qnbca1, & - &ex1,Vt,Vq,sgm, & - &ust(i),flt,fltv,flq,flqv, & - &PBLH(i),KPBL(i),DX(i), & - &xland(i),th_sfc, & - ! now outputs - tendencies - ! &,dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf & - ! outputs - updraft properties - &edmf_a1,edmf_w1,edmf_qt1, & - &edmf_thl1,edmf_ent1,edmf_qc1, & - ! for the solver - &s_aw1,s_awthl1,s_awqt1, & - &s_awqv1,s_awqc1, & - &s_awu1,s_awv1,s_awqke1, & - &s_awqnc1,s_awqni1, & - &s_awqnwfa1,s_awqnifa1,s_awqnbca1, & - &sub_thl,sub_sqv, & - &sub_u,sub_v, & - &det_thl,det_sqv,det_sqc, & - &det_u,det_v, & - ! chem/smoke mixing - &nchem,chem1,s_awchem1, & - &mix_chem, & - &qc_bl1D,cldfra_bl1D, & - &qc_bl1D_old,cldfra_bl1D_old, & - &FLAG_QC,FLAG_QI, & - &FLAG_QNC,FLAG_QNI, & - &FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA, & - &Psig_shcu(i), & - &maxwidth(i),ktop_plume(i), & - &maxmf(i),ztop_plume(i), & - &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),flt,flq, & - &PBLH(i),KPBL(i), & - &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,:) ) - endif - - !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,xland(i),closure, & - &dz1, DX(i), zw, & - &u1, v1, thl, thetav, sqc, sqw, & - &qke1, tsq1, qsq1, cov1, & - &vt, vq, & - &rmol(i), flt, fltv, flq, & - &PBLH(i),th1, & - &Sh,Sm,el, & - &Dfm,Dfh,Dfq, & - &Tcd,Qcd,Pdk, & - &Pdt,Pdq,Pdc, & - &qWT1,qSHEAR1,qBUOY1,qDISS1, & - &tke_budget, & - &Psig_bl(i),Psig_shcu(i), & - &cldfra_bl1D,bl_mynn_mixlength, & - &edmf_w1,edmf_a1, & - &TKEprodTD, & - &spp_pbl,rstoch_col ) - -!> - 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,closure, & - &delt2, dz1, & - &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, & - &qWT1, qDISS1, tke_budget ) - - if (dheat_opt > 0) then - do k=kts,kte-1 - ! Set max dissipative heating rate to 7.2 K per hour - diss_heat(k) = MIN(MAX(1.0*(qke1(k)**1.5)/(b1*MAX(0.5*(el(k)+el(k+1)),1.))/cp, 0.0),0.002) - ! Limit heating above 100 mb: - diss_heat(k) = diss_heat(k) * exp(-10000./MAX(p1(k),1.)) - enddo - diss_heat(kte) = 0. - else - diss_heat(1:kte) = 0. - endif - -!> - 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,i, & - &delt, dz1, rho1, & - &u1, v1, th1, tk1, qv1, & - &qc1, qi1, kzero, qnc1, qni1, & !kzero replaces qs1 - not mixing snow - &ps(i), p1, ex1, thl, & - &sqv, sqc, sqi, kzero, sqw, & !kzero replaces sqs - not mixing snow - &qnwfa1, qnifa1, qnbca1, ozone1, & - &ust(i),flt,flq,flqv,flqc, & - &wspd(i),uoce(i),voce(i), & - &tsq1, qsq1, cov1, & - &tcd, qcd, & - &dfm, dfh, dfq, & - &Du1, Dv1, Dth1, Dqv1, & - &Dqc1, Dqi1, Dqs1, Dqnc1, Dqni1, & - &Dqnwfa1, Dqnifa1, Dqnbca1, & - &Dozone1, & - &diss_heat, & - ! mass flux components - &s_aw1,s_awthl1,s_awqt1, & - &s_awqv1,s_awqc1,s_awu1,s_awv1, & - &s_awqnc1,s_awqni1, & - &s_awqnwfa1,s_awqnifa1,s_awqnbca1, & - &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, & - &det_u,det_v, & - &FLAG_QC,FLAG_QI,FLAG_QNC, & - &FLAG_QNI,FLAG_QS, & - &FLAG_QNWFA,FLAG_QNIFA, & - &FLAG_QNBCA,FLAG_OZONE, & - &cldfra_bl1d, & - &bl_mynn_cloudmix, & - &bl_mynn_mixqt, & - &bl_mynn_edmf, & - &bl_mynn_edmf_mom, & - &bl_mynn_mixscalars ) - - - if ( mix_chem ) then - if ( rrfs_sd ) then - call mynn_mix_chem(kts,kte,i, & - &delt, dz1, pblh(i), & - &nchem, kdvel, ndvel, & - &chem1, vd1, & - &rho1,flt, & - &tcd, qcd, & - &dfh, & - &s_aw1,s_awchem1, & - &emis_ant_no(i), & - &frp(i), rrfs_sd, & - &enh_mix, smoke_dbg ) - else - call mynn_mix_chem(kts,kte,i, & - &delt, dz1, pblh(i), & - &nchem, kdvel, ndvel, & - &chem1, vd1, & - &rho1,flt, & - &tcd, qcd, & - &dfh, & - &s_aw1,s_awchem1, & - &zero, & - &zero, rrfs_sd, & - &enh_mix, smoke_dbg ) - endif - do ic = 1,nchem - do k = kts,kte - chem3d(i,k,ic) = max(1.e-12, chem1(k,ic)) - enddo - enddo - endif - - call retrieve_exchange_coeffs(kts,kte, & - &dfm, dfh, dz1, K_m1, K_h1 ) - - !UPDATE 3D ARRAYS - exch_m(i,kts:kte) =k_m1(kts:kte) - exch_h(i,kts:kte) =k_h1(kts:kte) - rublten(i,kts:kte) =du1(kts:kte) - rvblten(i,kts:kte) =dv1(kts:kte) - rthblten(i,kts:kte)=dth1(kts:kte) - rqvblten(i,kts:kte)=dqv1(kts:kte) - if (bl_mynn_cloudmix > 0) then - if (flag_qc) rqcblten(i,kts:kte)=dqc1(kts:kte) - if (flag_qi) rqiblten(i,kts:kte)=dqi1(kts:kte) - if (flag_qs) rqsblten(i,kts:kte)=dqs1(kts:kte) - else - if (flag_qc) rqcblten(i,:)=0. - if (flag_qi) rqiblten(i,:)=0. - if (flag_qs) rqsblten(i,:)=0. - endif - if (bl_mynn_cloudmix > 0 .and. bl_mynn_mixscalars > 0) then - if (flag_qnc) rqncblten(i,kts:kte) =dqnc1(kts:kte) - if (flag_qni) rqniblten(i,kts:kte) =dqni1(kts:kte) - if (flag_qnwfa) rqnwfablten(i,kts:kte)=dqnwfa1(kts:kte) - if (flag_qnifa) rqnifablten(i,kts:kte)=dqnifa1(kts:kte) - if (flag_qnbca) rqnbcablten(i,kts:kte)=dqnbca1(kts:kte) - else - if (flag_qnc) rqncblten(i,:) =0. - if (flag_qni) rqniblten(i,:) =0. - if (flag_qnwfa) rqnwfablten(i,:)=0. - if (flag_qnifa) rqnifablten(i,:)=0. - if (flag_qnbca) rqnbcablten(i,:)=0. - endif - dozone(i,kts:kte)=dozone1(kts:kte) - if (icloud_bl > 0) then - qc_bl(i,kts:kte) =qc_bl1D(kts:kte) - qi_bl(i,kts:kte) =qi_bl1D(kts:kte) - cldfra_bl(i,kts:kte)=cldfra_bl1D(kts:kte) - endif - el_pbl(i,kts:kte)=el(kts:kte) - qke(i,kts:kte) =qke1(kts:kte) - tsq(i,kts:kte) =tsq1(kts:kte) - qsq(i,kts:kte) =qsq1(kts:kte) - cov(i,kts:kte) =cov1(kts:kte) - sh3d(i,kts:kte) =sh(kts:kte) - sm3d(i,kts:kte) =sm(kts:kte) - - if (tke_budget .eq. 1) then - !! 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)**3*phi_m/(karman*dz(i,k)))-qSHEAR1(k+1) !! staggered - qBUOY1(k) =4.*(-ust(i)**3*zet/(karman*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)=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) =0. - qBUOY(i,k) =0. - qWT(i,k) =0. - qDISS(i,k) =0. - dqke(i,k) =0. - endif - - !update updraft/downdraft properties - if (bl_mynn_output > 0) then !research mode == 1 - if (bl_mynn_edmf > 0) then - edmf_a(i,kts:kte) =edmf_a1(kts:kte) - edmf_w(i,kts:kte) =edmf_w1(kts:kte) - edmf_qt(i,kts:kte) =edmf_qt1(kts:kte) - edmf_thl(i,kts:kte) =edmf_thl1(kts:kte) - edmf_ent(i,kts:kte) =edmf_ent1(kts:kte) - edmf_qc(i,kts:kte) =edmf_qc1(kts:kte) - sub_thl3D(i,kts:kte)=sub_thl(kts:kte) - sub_sqv3D(i,kts:kte)=sub_sqv(kts:kte) - det_thl3D(i,kts:kte)=det_thl(kts:kte) - det_sqv3D(i,kts:kte)=det_sqv(kts:kte) - endif - !if (bl_mynn_edmf_dd > 0) THEN - ! edmf_a_dd(i,kts:kte) =edmf_a_dd1(kts:kte) - ! edmf_w_dd(i,kts:kte) =edmf_w_dd1(kts:kte) - ! edmf_qt_dd(i,kts:kte) =edmf_qt_dd1(kts:kte) - ! edmf_thl_dd(i,kts:kte)=edmf_thl_dd1(kts:kte) - ! edmf_ent_dd(i,kts:kte)=edmf_ent_dd1(kts:kte) - ! edmf_qc_dd(i,kts:kte) =edmf_qc_dd1(kts:kte) - !endif - endif - - !*** Begin debug prints - if ( debug_code .and. (i .eq. idbg)) THEN - if ( ABS(QFX(i))>.001)print*,& - "SUSPICIOUS VALUES AT: i=",i," QFX=",QFX(i) - if ( ABS(HFX(i))>1100.)print*,& - "SUSPICIOUS VALUES AT: i=",i," HFX=",HFX(i) - do k = kts,kte - IF ( sh(k) < 0. .OR. sh(k)> 200.)print*,& - "SUSPICIOUS VALUES AT: i,k=",i,k," sh=",sh(k) - IF ( ABS(vt(k)) > 2.0 )print*,& - "SUSPICIOUS VALUES AT: i,k=",i,k," vt=",vt(k) - IF ( ABS(vq(k)) > 7000.)print*,& - "SUSPICIOUS VALUES AT: i,k=",i,k," vq=",vq(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)> 1500.)print*,& - "SUSPICIOUS VALUES AT: i,k=",i,k," el_pbl=",el_pbl(i,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 (icloud_bl > 0) then - 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) - ! 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) - !ENDIF - enddo !end-k - endif - - enddo !end i-loop - -!ACF copy qke into qke_adv if using advection - IF (bl_mynn_tkeadvect) THEN - qke_adv=qke - ENDIF -!ACF-end - -#ifdef HARDCODE_VERTICAL -# undef kts -# undef kte -#endif - - END SUBROUTINE mynn_bl_driver -!> @} - -!======================================================================= -! SUBROUTINE mym_initialize: -! -! Input variables: -! iniflag : <>0; turbulent quantities will be initialized -! = 0; turbulent quantities have been already -! given, i.e., they will not be initialized -! nx, nz : Dimension sizes of the -! x and z directions, respectively -! tref : Reference temperature (K) -! dz(nz) : Vertical grid spacings (m) -! # dz(nz)=dz(nz-1) -! zw(nz+1) : Heights of the walls of the grid boxes (m) -! # zw(1)=0.0 and zw(k)=zw(k-1)+dz(k-1) -! exner(nx,nz) : Exner function at zw*h+zg (J/kg K) -! defined by c_p*( p_basic/1000hPa )^kappa -! This is usually computed by integrating -! d(pi0)/dz = -h*g/tref. -! rmo(nx) : Inverse of the Obukhov length (m^(-1)) -! flt, flq(nx) : Turbulent fluxes of potential temperature and -! total water, respectively: -! flt=-u_*Theta_* (K m/s) -! flq=-u_*qw_* (kg/kg m/s) -! ust(nx) : Friction velocity (m/s) -! pmz(nx) : phi_m-zeta at z1*h+z0, where z1 (=0.5*dz(1)) -! is the first grid point above the surafce, z0 -! the roughness length and zeta=(z1*h+z0)*rmo -! phh(nx) : phi_h at z1*h+z0 -! u, v(nx,nz) : Components of the horizontal wind (m/s) -! thl(nx,nz) : Liquid water potential temperature -! (K) -! qw(nx,nz) : Total water content Q_w (kg/kg) -! -! Output variables: -! ql(nx,nz) : Liquid water content (kg/kg) -! vt, vq(nx,nz) : Functions for computing the buoyancy flux -! qke(nx,nz) : Twice the turbulent kinetic energy q^2 -! (m^2/s^2) -! tsq(nx,nz) : Variance of Theta_l (K^2) -! qsq(nx,nz) : Variance of Q_w -! cov(nx,nz) : Covariance of Theta_l and Q_w (K) -! el(nx,nz) : Master length scale L (m) -! defined on the walls of the grid boxes -! -! Work arrays: see subroutine mym_level2 -! pd?(nx,nz,ny) : Half of the production terms at Level 2 -! defined on the walls of the grid boxes -! qkw(nx,nz,ny) : q on the walls of the grid boxes (m/s) -! -! # As to dtl, ...gh, see subroutine mym_turbulence. -! -!------------------------------------------------------------------- - -!>\ingroup gsd_mynn_edmf -!! This subroutine initializes the mixing length, TKE, \f$\theta^{'2}\f$, -!! \f$q^{'2}\f$, and \f$\theta^{'}q^{'}\f$. -!!\section gen_mym_ini GSD MYNN-EDMF mym_initialize General Algorithm -!> @{ - SUBROUTINE mym_initialize ( & - & kts,kte,xland, & - & dz, dx, zw, & - & u, v, thl, qw, & -! & ust, rmo, pmz, phh, flt, flq, & - & zi, theta, thetav, sh, sm, & - & ust, rmo, el, & - & Qke, Tsq, Qsq, Cov, Psig_bl, cldfra_bl1D, & - & bl_mynn_mixlength, & - & edmf_w1,edmf_a1, & - & INITIALIZE_QKE, & - & spp_pbl,rstoch_col) -! -!------------------------------------------------------------------- - - integer, intent(in) :: kts,kte - integer, intent(in) :: bl_mynn_mixlength - logical, intent(in) :: INITIALIZE_QKE -! real(kind_phys), intent(in) :: ust, rmo, pmz, phh, flt, flq - real(kind_phys), intent(in) :: rmo, Psig_bl, xland - real(kind_phys), intent(in) :: dx, ust, zi - real(kind_phys), dimension(kts:kte), intent(in) :: dz - real(kind_phys), dimension(kts:kte+1), intent(in) :: zw - real(kind_phys), dimension(kts:kte), intent(in) :: u,v,thl,& - &qw,cldfra_bl1D,edmf_w1,edmf_a1 - real(kind_phys), dimension(kts:kte), intent(out) :: tsq,qsq,cov - real(kind_phys), dimension(kts:kte), intent(inout) :: el,qke - real(kind_phys), dimension(kts:kte) :: & - &ql,pdk,pdt,pdq,pdc,dtl,dqw,dtv, & - &gm,gh,sm,sh,qkw,vt,vq - integer :: k,l,lmax - real(kind_phys):: phm,vkz,elq,elv,b1l,b2l,pmz=1.,phh=1., & - &flt=0.,fltv=0.,flq=0.,tmpq - real(kind_phys), dimension(kts:kte) :: theta,thetav - real(kind_phys), dimension(kts:kte) :: rstoch_col - integer ::spp_pbl - -!> - At first ql, vt and vq are set to zero. - DO k = kts,kte - ql(k) = 0.0 - vt(k) = 0.0 - vq(k) = 0.0 - END DO -! -!> - Call mym_level2() to calculate the stability functions at level 2. - CALL mym_level2 ( kts,kte, & - & dz, & - & u, v, thl, thetav, qw, & - & ql, vt, vq, & - & dtl, dqw, dtv, gm, gh, sm, sh ) -! -! ** Preliminary setting ** - - el (kts) = 0.0 - IF (INITIALIZE_QKE) THEN - !qke(kts) = ust**2 * ( b1*pmz )**(2.0/3.0) - qke(kts) = 1.5 * ust**2 * ( b1*pmz )**(2.0/3.0) - DO k = kts+1,kte - !qke(k) = 0.0 - !linearly taper off towards top of pbl - qke(k)=qke(kts)*MAX((ust*700. - zw(k))/(MAX(ust,0.01)*700.), 0.01) - ENDDO - ENDIF -! - phm = phh*b2 / ( b1*pmz )**(1.0/3.0) - tsq(kts) = phm*( flt/ust )**2 - qsq(kts) = phm*( flq/ust )**2 - cov(kts) = phm*( flt/ust )*( flq/ust ) -! - DO k = kts+1,kte - vkz = karman*zw(k) - el (k) = vkz/( 1.0 + vkz/100.0 ) -! qke(k) = 0.0 -! - tsq(k) = 0.0 - qsq(k) = 0.0 - cov(k) = 0.0 - END DO -! -! ** Initialization with an iterative manner ** -! ** lmax is the iteration count. This is arbitrary. ** - lmax = 5 -! - DO l = 1,lmax -! -!> - call mym_length() to calculate the master length scale. - CALL mym_length ( & - & kts,kte,xland, & - & dz, dx, zw, & - & rmo, flt, fltv, flq, & - & vt, vq, & - & u, v, qke, & - & dtv, & - & el, & - & zi,theta, & - & qkw,Psig_bl,cldfra_bl1D, & - & bl_mynn_mixlength, & - & edmf_w1,edmf_a1 ) -! - DO k = kts+1,kte - elq = el(k)*qkw(k) - pdk(k) = elq*( sm(k)*gm(k) + & - & sh(k)*gh(k) ) - pdt(k) = elq* sh(k)*dtl(k)**2 - pdq(k) = elq* sh(k)*dqw(k)**2 - pdc(k) = elq* sh(k)*dtl(k)*dqw(k) - END DO -! -! ** Strictly, vkz*h(i,j) -> karman*( 0.5*dz(1)*h(i,j)+z0 ) ** - vkz = karman*0.5*dz(kts) - elv = 0.5*( el(kts+1)+el(kts) ) / vkz - IF (INITIALIZE_QKE)THEN - !qke(kts) = ust**2 * ( b1*pmz*elv )**(2.0/3.0) - qke(kts) = 1.0 * MAX(ust,0.02)**2 * ( b1*pmz*elv )**(2.0/3.0) - ENDIF - - phm = phh*b2 / ( b1*pmz/elv**2 )**(1.0/3.0) - tsq(kts) = phm*( flt/ust )**2 - qsq(kts) = phm*( flq/ust )**2 - cov(kts) = phm*( flt/ust )*( flq/ust ) - - DO k = kts+1,kte-1 - b1l = b1*0.25*( el(k+1)+el(k) ) - !tmpq=MAX(b1l*( pdk(k+1)+pdk(k) ),qkemin) - !add MIN to limit unreasonable QKE - tmpq=MIN(MAX(b1l*( pdk(k+1)+pdk(k) ),qkemin),125.) -! PRINT *,'tmpqqqqq',tmpq,pdk(k+1),pdk(k) - IF (INITIALIZE_QKE)THEN - qke(k) = tmpq**twothirds - ENDIF - - IF ( qke(k) .LE. 0.0 ) THEN - b2l = 0.0 - ELSE - b2l = b2*( b1l/b1 ) / SQRT( qke(k) ) - 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 - - END DO - -!! qke(kts)=qke(kts+1) -!! tsq(kts)=tsq(kts+1) -!! qsq(kts)=qsq(kts+1) -!! cov(kts)=cov(kts+1) - - IF (INITIALIZE_QKE)THEN - qke(kts)=0.5*(qke(kts)+qke(kts+1)) - qke(kte)=qke(kte-1) - ENDIF - tsq(kte)=tsq(kte-1) - qsq(kte)=qsq(kte-1) - cov(kte)=cov(kte-1) - -! -! RETURN - - END SUBROUTINE mym_initialize -!> @} - -! -! ================================================================== -! SUBROUTINE mym_level2: -! -! Input variables: see subroutine mym_initialize -! -! Output variables: -! dtl(nx,nz,ny) : Vertical gradient of Theta_l (K/m) -! dqw(nx,nz,ny) : Vertical gradient of Q_w -! dtv(nx,nz,ny) : Vertical gradient of Theta_V (K/m) -! gm (nx,nz,ny) : G_M divided by L^2/q^2 (s^(-2)) -! gh (nx,nz,ny) : G_H divided by L^2/q^2 (s^(-2)) -! sm (nx,nz,ny) : Stability function for momentum, at Level 2 -! sh (nx,nz,ny) : Stability function for heat, at Level 2 -! -! These are defined on the walls of the grid boxes. -! - -!>\ingroup gsd_mynn_edmf -!! This subroutine calculates the level 2, non-dimensional wind shear -!! \f$G_M\f$ and vertical temperature gradient \f$G_H\f$ as well as -!! the level 2 stability funcitons \f$S_h\f$ and \f$S_m\f$. -!!\param kts horizontal dimension -!!\param kte vertical dimension -!!\param dz vertical grid spacings (\f$m\f$) -!!\param u west-east component of the horizontal wind (\f$m s^{-1}\f$) -!!\param v south-north component of the horizontal wind (\f$m s^{-1}\f$) -!!\param thl liquid water potential temperature -!!\param qw total water content \f$Q_w\f$ -!!\param ql liquid water content (\f$kg kg^{-1}\f$) -!!\param vt -!!\param vq -!!\param dtl vertical gradient of \f$\theta_l\f$ (\f$K m^{-1}\f$) -!!\param dqw vertical gradient of \f$Q_w\f$ -!!\param dtv vertical gradient of \f$\theta_V\f$ (\f$K m^{-1}\f$) -!!\param gm \f$G_M\f$ divided by \f$L^{2}/q^{2}\f$ (\f$s^{-2}\f$) -!!\param gh \f$G_H\f$ divided by \f$L^{2}/q^{2}\f$ (\f$s^{-2}\f$) -!!\param sm stability function for momentum, at Level 2 -!!\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, thetav, qw, & - & ql, vt, vq, & - & dtl, dqw, dtv, gm, gh, sm, sh ) -! -!------------------------------------------------------------------- - - integer, intent(in) :: kts,kte - -#ifdef HARDCODE_VERTICAL -# define kts 1 -# define kte HARDCODE_VERTICAL -#endif - - real(kind_phys), dimension(kts:kte), intent(in) :: dz - real(kind_phys), dimension(kts:kte), intent(in) :: u,v, & - &thl,qw,ql,vt,vq,thetav - real(kind_phys), dimension(kts:kte), intent(out) :: & - &dtl,dqw,dtv,gm,gh,sm,sh - - integer :: k - - real(kind_phys):: rfc,f1,f2,rf1,rf2,smc,shc, & - &ri1,ri2,ri3,ri4,duz,dtz,dqz,vtt,vqq,dtq,dzk, & - &afk,abk,ri,rf - - real(kind_phys):: a2fac - -! ev = 2.5e6 -! tv0 = 0.61*tref -! tv1 = 1.61*tref -! gtr = 9.81/tref -! - rfc = g1/( g1+g2 ) - f1 = b1*( g1-c1 ) +3.0*a2*( 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* f1/f2 - shc = 3.0*a2*( g1+g2 ) -! - ri1 = 0.5/smc - ri2 = rf1*smc - ri3 = 4.0*rf2*smc -2.0*ri2 - ri4 = ri2**2 -! - DO k = kts+1,kte - dzk = 0.5 *( dz(k)+dz(k-1) ) - afk = dz(k)/( dz(k)+dz(k-1) ) - abk = 1.0 -afk - duz = ( u(k)-u(k-1) )**2 +( v(k)-v(k-1) )**2 - duz = duz /dzk**2 - dtz = ( thl(k)-thl(k-1) )/( dzk ) - dqz = ( qw(k)-qw(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 - 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 - dtv(k) = dtq -!? dtv(i,j,k) = dtz +tv0*dqz -!? : +( xlv/pi0(i,j,k)-tv1 ) -!? : *( ql(i,j,k)-ql(i,j,k-1) )/( dzk*h(i,j) ) -! - gm (k) = duz - gh (k) = -dtq*gtr -! -! ** Gradient Richardson number ** - ri = -gh(k)/MAX( duz, 1.0e-10 ) - - !a2fac is needed for the Canuto/Kitamura mod - IF (CKmod .eq. 1) THEN - a2fac = 1./(1. + MAX(ri,0.0)) - ELSE - a2fac = 1. - ENDIF - - rfc = g1/( g1+g2 ) - 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*a2fac)* f1/f2 - shc = 3.0*(a2*a2fac)*( g1+g2 ) - - ri1 = 0.5/smc - ri2 = rf1*smc - ri3 = 4.0*rf2*smc -2.0*ri2 - ri4 = ri2**2 - -! ** Flux Richardson number ** - 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) - END DO -! -! RETURN - -#ifdef HARDCODE_VERTICAL -# undef kts -# undef kte -#endif - - END SUBROUTINE mym_level2 -!! @} - -! ================================================================== -! SUBROUTINE mym_length: -! -! Input variables: see subroutine mym_initialize -! -! Output variables: see subroutine mym_initialize -! -! Work arrays: -! elt(nx,ny) : Length scale depending on the PBL depth (m) -! vsc(nx,ny) : Velocity scale q_c (m/s) -! at first, used for computing elt -! -! NOTE: the mixing lengths are meant to be calculated at the full- -! sigmal levels (or interfaces beween the model layers). -! -!>\ingroup gsd_mynn_edmf -!! This subroutine calculates the mixing lengths. - SUBROUTINE mym_length ( & - & kts,kte,xland, & - & dz, dx, zw, & - & rmo, flt, fltv, flq, & - & vt, vq, & - & u1, v1, qke, & - & dtv, & - & el, & - & zi, theta, qkw, & - & Psig_bl, cldfra_bl1D, & - & bl_mynn_mixlength, & - & edmf_w1,edmf_a1 ) - -!------------------------------------------------------------------- - - integer, intent(in) :: kts,kte - -#ifdef HARDCODE_VERTICAL -# define kts 1 -# define kte HARDCODE_VERTICAL -#endif - - integer, intent(in) :: bl_mynn_mixlength - real(kind_phys), dimension(kts:kte), intent(in) :: dz - real(kind_phys), dimension(kts:kte+1), intent(in) :: zw - real(kind_phys), intent(in) :: rmo,flt,fltv,flq,Psig_bl,xland - real(kind_phys), intent(in) :: dx,zi - real(kind_phys), dimension(kts:kte), intent(in) :: u1,v1, & - &qke,vt,vq,cldfra_bl1D,edmf_w1,edmf_a1 - real(kind_phys), dimension(kts:kte), intent(out) :: qkw, el - real(kind_phys), dimension(kts:kte), intent(in) :: dtv - real(kind_phys):: elt,vsc - real(kind_phys), dimension(kts:kte), intent(in) :: theta - real(kind_phys), dimension(kts:kte) :: qtke,elBLmin,elBLavg,thetaw - real(kind_phys):: wt,wt2,zi2,h1,h2,hs,elBLmin0,elBLavg0,cldavg - - ! THE FOLLOWING CONSTANTS ARE IMPORTANT FOR REGULATING THE - ! MIXING LENGTHS: - real(kind_phys):: cns, & !< for surface layer (els) in stable conditions - alp1, & !< for turbulent length scale (elt) - alp2, & !< for buoyancy length scale (elb) - alp3, & !< for buoyancy enhancement factor of elb - alp4, & !< for surface layer (els) in unstable conditions - alp5, & !< for BouLac mixing length or above PBLH - alp6 !< for mass-flux/ - - !THE FOLLOWING LIMITS DO NOT DIRECTLY AFFECT THE ACTUAL PBLH. - !THEY ONLY IMPOSE LIMITS ON THE CALCULATION OF THE MIXING LENGTH - !SCALES SO THAT THE BOULAC MIXING LENGTH (IN FREE ATMOS) DOES - !NOT ENCROACH UPON THE BOUNDARY LAYER MIXING LENGTH (els, elb & elt). - real(kind_phys), parameter :: minzi = 300. !< min mixed-layer height - real(kind_phys), parameter :: maxdz = 750. !< max (half) transition layer depth - !! =0.3*2500 m PBLH, so the transition - !! layer stops growing for PBLHs > 2.5 km. - real(kind_phys), parameter :: mindz = 300. !< 300 !min (half) transition layer depth - - !SURFACE LAYER LENGTH SCALE MODS TO REDUCE IMPACT IN UPPER BOUNDARY LAYER - real(kind_phys), parameter :: ZSLH = 100. !< Max height correlated to surface conditions (m) - real(kind_phys), parameter :: CSL = 2. !< CSL = constant of proportionality to L O(1) - real(kind_phys), parameter :: qke_elb_min = 0.018 - - integer :: i,j,k - real(kind_phys):: afk,abk,zwk,zwk1,dzk,qdz,vflx,bv,tau_cloud, & - & wstar,elb,els,elf,el_stab,el_mf,el_stab_mf,elb_mf, & - & PBLH_PLUS_ENT,Uonset,Ugrid,wt_u,el_les - real(kind_phys), parameter :: ctau = 1000. !constant for tau_cloud - -! tv0 = 0.61*tref -! gtr = 9.81/tref - - SELECT CASE(bl_mynn_mixlength) - - CASE (0) ! ORIGINAL MYNN MIXING LENGTH + BouLac - - cns = 2.7 - alp1 = 0.23 - alp2 = 1.0 - alp3 = 5.0 - alp4 = 100. - alp5 = 0.3 - - ! 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. - h1=MAX(0.3*zi2,mindz) - h1=MIN(h1,maxdz) ! 1/2 transition layer depth - h2=h1/2.0 ! 1/4 transition layer depth - - qkw(kts) = SQRT(MAX(qke(kts), qkemin)) - 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, qkemin)) - END DO - - elt = 1.0e-5 - vsc = 1.0e-5 - - ! ** Strictly, zwk*h(i,j) -> ( zwk*h(i,j)+z0 ) ** - k = kts+1 - zwk = zw(k) - DO WHILE (zwk .LE. zi2+h1) - dzk = 0.5*( dz(k)+dz(k-1) ) - qdz = MAX( qkw(k)-qmin, 0.03 )*dzk - elt = elt +qdz*zwk - vsc = vsc +qdz - k = k+1 - zwk = zw(k) - END DO - - elt = alp1*elt/vsc - vflx = ( vt(kts)+1.0 )*flt +( vq(kts)+tv0 )*flq - vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**onethird - - ! ** Strictly, el(i,k=1) is not zero. ** - el(kts) = 0.0 - zwk1 = zw(kts+1) - - DO k = kts+1,kte - zwk = zw(k) !full-sigma levels - - ! ** Length scale limited by the buoyancy effect ** - IF ( dtv(k) .GT. 0.0 ) THEN - bv = SQRT( gtr*dtv(k) ) - elb = alp2*qkw(k) / bv & - & *( 1.0 + alp3/alp2*& - &SQRT( vsc/( bv*elt ) ) ) - elf = alp2 * qkw(k)/bv - - ELSE - elb = 1.0e10 - elf = elb - ENDIF - - ! ** Length scale in the surface layer ** - IF ( rmo .GT. 0.0 ) THEN - els = karman*zwk/(1.0+cns*MIN( zwk*rmo, zmax )) - ELSE - els = karman*zwk*( 1.0 - alp4* zwk*rmo )**0.2 - END IF - - ! ** HARMONC AVERGING OF MIXING LENGTH SCALES: - ! el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf) - ! el(k) = elb/( elb/elt+elb/els+1.0 ) - - wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 - - el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf) - - END DO - - CASE (1) !NONLOCAL (using BouLac) FORM OF MIXING LENGTH - - ugrid = sqrt(u1(kts)**2 + v1(kts)**2) - uonset= 15. - wt_u = (1.0 - min(max(ugrid - uonset, 0.0)/30.0, 0.5)) - cns = 3.5 - alp1 = 0.23 - alp2 = 0.3 - alp3 = 2.5 * wt_u !taper off bouyancy enhancement in shear-driven pbls - alp4 = 5.0 - alp5 = 0.3 - alp6 = 50. - - ! Impose limits on the height integration for elt and the transition layer depth - zi2 = MAX(zi,300.) !minzi) - h1 = MAX(0.3*zi2,300.) - h1 = MIN(h1,600.) ! 1/2 transition layer depth - h2 = h1/2.0 ! 1/4 transition layer depth - - qtke(kts) = MAX(0.5*qke(kts), 0.5*qkemin) !tke at full sigma levels - thetaw(kts) = theta(kts) !theta at full-sigma levels - qkw(kts) = SQRT(MAX(qke(kts), qkemin)) - - 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, qkemin)) - qtke(k) = max(0.5*(qkw(k)**2), 0.005) ! q -> TKE - thetaw(k)= theta(k)*abk + theta(k-1)*afk - END DO - - elt = 1.0e-5 - vsc = 1.0e-5 - - ! ** Strictly, zwk*h(i,j) -> ( zwk*h(i,j)+z0 ) ** - k = kts+1 - zwk = zw(k) - DO WHILE (zwk .LE. zi2+h1) - dzk = 0.5*( dz(k)+dz(k-1) ) - qdz = min(max( qkw(k)-qmin, 0.01 ), 30.0)*dzk - elt = elt +qdz*zwk - vsc = vsc +qdz - k = k+1 - zwk = zw(k) - END DO - - elt = MIN( MAX( alp1*elt/vsc, 8.), 400.) - !avoid use of buoyancy flux functions which are ill-defined at the surface - !vflx = ( vt(kts)+1.0 )*flt + ( vq(kts)+tv0 )*flq - vflx = fltv - vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**onethird - - ! ** Strictly, el(i,j,1) is not zero. ** - el(kts) = 0.0 - zwk1 = zw(kts+1) !full-sigma levels - - ! COMPUTE BouLac mixing length - CALL boulac_length(kts,kte,zw,dz,qtke,thetaw,elBLmin,elBLavg) - - DO k = kts+1,kte - zwk = zw(k) !full-sigma levels - - ! ** Length scale limited by the buoyancy effect ** - IF ( dtv(k) .GT. 0.0 ) THEN - bv = max( sqrt( gtr*dtv(k) ), 0.0001) - elb = MAX(alp2*max(qkw(k), qke_elb_min), & - & alp6*edmf_a1(k-1)*edmf_w1(k-1)) / bv & - & *( 1.0 + alp3*SQRT( vsc/(bv*elt) ) ) - elb = MIN(elb, zwk) - elf = 1.0 * max(qkw(k), qke_elb_min)/bv - elBLavg(k) = MAX(elBLavg(k), alp6*edmf_a1(k-1)*edmf_w1(k-1)/bv) - ELSE - elb = 1.0e10 - elf = elb - ENDIF - - ! ** Length scale in the surface layer ** - IF ( rmo .GT. 0.0 ) THEN - els = karman*zwk/(1.0+cns*MIN( zwk*rmo, zmax )) - ELSE - els = karman*zwk*( 1.0 - alp4* zwk*rmo )**0.2 - END IF - - ! ** NOW BLEND THE MIXING LENGTH SCALES: - wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 - - !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) - !try squared-blending - but take out elb (makes it underdiffusive) - !el(k) = SQRT( els**2/(1. + (els**2/elt**2) +(els**2/elb**2))) - el(k) = sqrt( els**2/(1. + (els**2/elt**2))) - el(k) = min(el(k), elb) - 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) !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.22 - alp2 = 0.30 - alp3 = 2.0 - alp4 = 5.0 - 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, 300.) - !h1=MAX(0.3*zi2,mindz) - !h1=MIN(h1,maxdz) ! 1/2 transition layer depth - h1=MAX(0.3*zi2,300.) - h1=MIN(h1,600.) - h2=h1*0.5 ! 1/4 transition layer depth - - qtke(kts)=MAX(0.5*qke(kts), 0.5*qkemin) !tke at full sigma levels - qkw(kts) = SQRT(MAX(qke(kts), qkemin)) - - 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, qkemin)) - qtke(k) = 0.5*qkw(k)**2 ! qkw -> TKE - END DO - - elt = 1.0e-5 - vsc = 1.0e-5 - - ! ** Strictly, zwk*h(i,j) -> ( zwk*h(i,j)+z0 ) ** - PBLH_PLUS_ENT = MAX(zi+h1, 100.) - k = kts+1 - zwk = zw(k) - DO WHILE (zwk .LE. PBLH_PLUS_ENT) - dzk = 0.5*( dz(k)+dz(k-1) ) - qdz = min(max( qkw(k)-qmin, 0.03 ), 30.0)*dzk - elt = elt +qdz*zwk - vsc = vsc +qdz - k = k+1 - zwk = zw(k) - END DO - - elt = MIN( MAX(alp1*elt/vsc, 10.), 400.) - !avoid use of buoyancy flux functions which are ill-defined at the surface - !vflx = ( vt(kts)+1.0 )*flt +( vq(kts)+tv0 )*flq - vflx = fltv - vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**onethird - - ! ** Strictly, el(i,j,1) is not zero. ** - el(kts) = 0.0 - zwk1 = zw(kts+1) - - 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 - !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), & - & alp6*edmf_a1(k-1)*edmf_w1(k-1)) / bv & - & *( 1.0 + alp3*SQRT( vsc/( bv*elt ) ) ) - elb = MIN(MAX(alp5*qkw(k), alp6*edmf_a1(k)*edmf_w1(k))/bv, zwk) - - !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/grav, 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) - ! !elf = alp5*elBLavg0 - ! elf = MIN(MAX(50.*SQRT(qtke(k)), 400.), zwk) - !ENDIF - - ELSE - ! use version in development for RAP/HRRR 2016 - ! JAYMES- - ! tau_cloud is an eddy turnover timescale; - ! see Teixeira and Cheinet (2004), Eq. 1, and - ! Cheinet and Teixeira (2003), Eq. 7. The - ! coefficient 0.5 is tuneable. Expression in - ! denominator is identical to vsc (a convective - ! 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(vflx,1.0e-4))**onethird),50.),150.) - wstar = 1.25*(gtr*zi*MAX(vflx,1.0e-4))**onethird - tau_cloud = MIN(MAX(ctau * wstar/grav, 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) + MAX(100.,dzk*0.25)*wt - - 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 = MAX(elb_mf, 0.01) !to avoid divide-by-zero below - - ! ** Length scale in the surface layer ** - IF ( rmo .GT. 0.0 ) THEN - els = karman*zwk/(1.0+cns*MIN( zwk*rmo, zmax )) - ELSE - els = karman*zwk*( 1.0 - alp4* zwk*rmo )**0.2 - END IF - - ! ** NOW BLEND THE MIXING LENGTH SCALES: - wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 - - !try squared-blending - el(k) = SQRT( els**2/(1. + (els**2/elt**2) +(els**2/elb_mf**2))) - el(k) = el(k)*(1.-wt) + elf*wt - - ! include scale-awareness. For now, use simple asymptotic kz -> 12 m (should be ~dz). - el_les= MIN(els/(1. + (els/12.)), elb_mf) - el(k) = el(k)*Psig_bl + (1.-Psig_bl)*el_les - - END DO - - END SELECT - - -#ifdef HARDCODE_VERTICAL -# undef kts -# undef kte -#endif - - END SUBROUTINE mym_length - -! ================================================================== -!>\ingroup gsd_mynn_edmf -!! This subroutine was taken from the BouLac scheme in WRF-ARW and modified for -!! integration into the MYNN PBL scheme. WHILE loops were added to reduce the -!! computational expense. This subroutine computes the length scales up and down -!! and then computes the min, average of the up/down length scales, and also -!! considers the distance to the surface. -!\param dlu the distance a parcel can be lifted upwards give a finite -! amount of TKE. -!\param dld the distance a parcel can be displaced downwards given a -! finite amount of TKE. -!\param lb1 the minimum of the length up and length down -!\param lb2 the average of the length up and length down - SUBROUTINE boulac_length0(k,kts,kte,zw,dz,qtke,theta,lb1,lb2) -! -! NOTE: This subroutine was taken from the BouLac scheme in WRF-ARW -! and modified for integration into the MYNN PBL scheme. -! WHILE loops were added to reduce the computational expense. -! This subroutine computes the length scales up and down -! and then computes the min, average of the up/down -! length scales, and also considers the distance to the -! surface. -! -! dlu = the distance a parcel can be lifted upwards give a finite -! amount of TKE. -! dld = the distance a parcel can be displaced downwards given a -! finite amount of TKE. -! lb1 = the minimum of the length up and length down -! lb2 = the average of the length up and length down -!------------------------------------------------------------------- - - integer, intent(in) :: k,kts,kte - real(kind_phys), dimension(kts:kte), intent(in) :: qtke,dz,theta - real(kind_phys), intent(out) :: lb1,lb2 - real(kind_phys), dimension(kts:kte+1), intent(in) :: zw - - !LOCAL VARS - integer :: izz, found - real(kind_phys):: dlu,dld - real(kind_phys):: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz - - - !---------------------------------- - ! FIND DISTANCE UPWARD - !---------------------------------- - zup=0. - dlu=zw(kte+1)-zw(k)-dz(k)*0.5 - zzz=0. - zup_inf=0. - beta=gtr !Buoyancy coefficient (g/tref) - - !print*,"FINDING Dup, k=",k," zw=",zw(k) - - if (k .lt. kte) then !cant integrate upwards from highest level - found = 0 - izz=k - DO WHILE (found .EQ. 0) - - if (izz .lt. kte) then - dzt=dz(izz) ! layer depth above - zup=zup-beta*theta(k)*dzt ! initial PE the parcel has at k - !print*," ",k,izz,theta(izz),dz(izz) - zup=zup+beta*(theta(izz+1)+theta(izz))*dzt*0.5 ! PE gained by lifting a parcel to izz+1 - zzz=zzz+dzt ! depth of layer k to izz+1 - !print*," PE=",zup," TKE=",qtke(k)," z=",zw(izz) - if (qtke(k).lt.zup .and. qtke(k).ge.zup_inf) then - bbb=(theta(izz+1)-theta(izz))/dzt - if (bbb .ne. 0.) then - !fractional distance up into the layer where TKE becomes < PE - tl=(-beta*(theta(izz)-theta(k)) + & - & sqrt( max(0.,(beta*(theta(izz)-theta(k)))**2 + & - & 2.*bbb*beta*(qtke(k)-zup_inf))))/bbb/beta - else - if (theta(izz) .ne. theta(k))then - tl=(qtke(k)-zup_inf)/(beta*(theta(izz)-theta(k))) - else - tl=0. - endif - endif - dlu=zzz-dzt+tl - !print*," FOUND Dup:",dlu," z=",zw(izz)," tl=",tl - found =1 - endif - zup_inf=zup - izz=izz+1 - ELSE - found = 1 - ENDIF - - ENDDO - - endif - - !---------------------------------- - ! FIND DISTANCE DOWN - !---------------------------------- - zdo=0. - zdo_sup=0. - dld=zw(k) - zzz=0. - - !print*,"FINDING Ddown, k=",k," zwk=",zw(k) - if (k .gt. kts) then !cant integrate downwards from lowest level - - found = 0 - izz=k - DO WHILE (found .EQ. 0) - - if (izz .gt. kts) then - dzt=dz(izz-1) - zdo=zdo+beta*theta(k)*dzt - !print*," ",k,izz,theta(izz),dz(izz-1) - zdo=zdo-beta*(theta(izz-1)+theta(izz))*dzt*0.5 - zzz=zzz+dzt - !print*," PE=",zdo," TKE=",qtke(k)," z=",zw(izz) - if (qtke(k).lt.zdo .and. qtke(k).ge.zdo_sup) then - bbb=(theta(izz)-theta(izz-1))/dzt - if (bbb .ne. 0.) then - tl=(beta*(theta(izz)-theta(k))+ & - & sqrt( max(0.,(beta*(theta(izz)-theta(k)))**2 + & - & 2.*bbb*beta*(qtke(k)-zdo_sup))))/bbb/beta - else - if (theta(izz) .ne. theta(k)) then - tl=(qtke(k)-zdo_sup)/(beta*(theta(izz)-theta(k))) - else - tl=0. - endif - endif - dld=zzz-dzt+tl - !print*," FOUND Ddown:",dld," z=",zw(izz)," tl=",tl - found = 1 - endif - zdo_sup=zdo - izz=izz-1 - ELSE - found = 1 - ENDIF - ENDDO - - endif - - !---------------------------------- - ! GET MINIMUM (OR AVERAGE) - !---------------------------------- - !The surface layer length scale can exceed z for large z/L, - !so keep maximum distance down > z. - dld = min(dld,zw(k+1))!not used in PBL anyway, only free atmos - lb1 = min(dlu,dld) !minimum - !JOE-fight floating point errors - dlu=MAX(0.1,MIN(dlu,1000.)) - dld=MAX(0.1,MIN(dld,1000.)) - lb2 = sqrt(dlu*dld) !average - biased towards smallest - !lb2 = 0.5*(dlu+dld) !average - - if (k .eq. kte) then - lb1 = 0. - lb2 = 0. - endif - !print*,"IN MYNN-BouLac",k,lb1 - !print*,"IN MYNN-BouLac",k,dld,dlu - - END SUBROUTINE boulac_length0 - -! ================================================================== -!>\ingroup gsd_mynn_edmf -!! This subroutine was taken from the BouLac scheme in WRF-ARW -!! and modified for integration into the MYNN PBL scheme. -!! WHILE loops were added to reduce the computational expense. -!! This subroutine computes the length scales up and down -!! and then computes the min, average of the up/down -!! length scales, and also considers the distance to the -!! surface. - SUBROUTINE boulac_length(kts,kte,zw,dz,qtke,theta,lb1,lb2) -! dlu = the distance a parcel can be lifted upwards give a finite -! amount of TKE. -! dld = the distance a parcel can be displaced downwards given a -! finite amount of TKE. -! lb1 = the minimum of the length up and length down -! lb2 = the average of the length up and length down -!------------------------------------------------------------------- - - integer, intent(in) :: kts,kte - real(kind_phys), dimension(kts:kte), intent(in) :: qtke,dz,theta - real(kind_phys), dimension(kts:kte), intent(out):: lb1,lb2 - real(kind_phys), dimension(kts:kte+1), intent(in) :: zw - - !LOCAL VARS - integer :: iz, izz, found - real(kind_phys), dimension(kts:kte) :: dlu,dld - real(kind_phys), parameter :: Lmax=2000. !soft limit - real(kind_phys):: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz - - !print*,"IN MYNN-BouLac",kts, kte - - do iz=kts,kte - - !---------------------------------- - ! FIND DISTANCE UPWARD - !---------------------------------- - zup=0. - dlu(iz)=zw(kte+1)-zw(iz)-dz(iz)*0.5 - zzz=0. - zup_inf=0. - beta=gtr !Buoyancy coefficient (g/tref) - - !print*,"FINDING Dup, k=",iz," zw=",zw(iz) - - if (iz .lt. kte) then !cant integrate upwards from highest level - - found = 0 - izz=iz - DO WHILE (found .EQ. 0) - - if (izz .lt. kte) then - dzt=dz(izz) ! layer depth above - zup=zup-beta*theta(iz)*dzt ! initial PE the parcel has at iz - !print*," ",iz,izz,theta(izz),dz(izz) - zup=zup+beta*(theta(izz+1)+theta(izz))*dzt*0.5 ! PE gained by lifting a parcel to izz+1 - zzz=zzz+dzt ! depth of layer iz to izz+1 - !print*," PE=",zup," TKE=",qtke(iz)," z=",zw(izz) - if (qtke(iz).lt.zup .and. qtke(iz).ge.zup_inf) then - bbb=(theta(izz+1)-theta(izz))/dzt - if (bbb .ne. 0.) then - !fractional distance up into the layer where TKE becomes < PE - tl=(-beta*(theta(izz)-theta(iz)) + & - & sqrt( max(0.,(beta*(theta(izz)-theta(iz)))**2 + & - & 2.*bbb*beta*(qtke(iz)-zup_inf))))/bbb/beta - else - if (theta(izz) .ne. theta(iz))then - tl=(qtke(iz)-zup_inf)/(beta*(theta(izz)-theta(iz))) - else - tl=0. - endif - endif - dlu(iz)=zzz-dzt+tl - !print*," FOUND Dup:",dlu(iz)," z=",zw(izz)," tl=",tl - found =1 - endif - zup_inf=zup - izz=izz+1 - ELSE - found = 1 - ENDIF - - ENDDO - - endif - - !---------------------------------- - ! FIND DISTANCE DOWN - !---------------------------------- - zdo=0. - zdo_sup=0. - dld(iz)=zw(iz) - zzz=0. - - !print*,"FINDING Ddown, k=",iz," zwk=",zw(iz) - if (iz .gt. kts) then !cant integrate downwards from lowest level - - found = 0 - izz=iz - DO WHILE (found .EQ. 0) - - if (izz .gt. kts) then - dzt=dz(izz-1) - zdo=zdo+beta*theta(iz)*dzt - !print*," ",iz,izz,theta(izz),dz(izz-1) - zdo=zdo-beta*(theta(izz-1)+theta(izz))*dzt*0.5 - zzz=zzz+dzt - !print*," PE=",zdo," TKE=",qtke(iz)," z=",zw(izz) - if (qtke(iz).lt.zdo .and. qtke(iz).ge.zdo_sup) then - bbb=(theta(izz)-theta(izz-1))/dzt - if (bbb .ne. 0.) then - tl=(beta*(theta(izz)-theta(iz))+ & - & sqrt( max(0.,(beta*(theta(izz)-theta(iz)))**2 + & - & 2.*bbb*beta*(qtke(iz)-zdo_sup))))/bbb/beta - else - if (theta(izz) .ne. theta(iz)) then - tl=(qtke(iz)-zdo_sup)/(beta*(theta(izz)-theta(iz))) - else - tl=0. - endif - endif - dld(iz)=zzz-dzt+tl - !print*," FOUND Ddown:",dld(iz)," z=",zw(izz)," tl=",tl - found = 1 - endif - zdo_sup=zdo - izz=izz-1 - ELSE - found = 1 - ENDIF - ENDDO - - endif - - !---------------------------------- - ! GET MINIMUM (OR AVERAGE) - !---------------------------------- - !The surface layer length scale can exceed z for large z/L, - !so keep maximum distance down > z. - dld(iz) = min(dld(iz),zw(iz+1))!not used in PBL anyway, only free atmos - lb1(iz) = min(dlu(iz),dld(iz)) !minimum - !JOE-fight floating point errors - dlu(iz)=MAX(0.1,MIN(dlu(iz),1000.)) - dld(iz)=MAX(0.1,MIN(dld(iz),1000.)) - lb2(iz) = sqrt(dlu(iz)*dld(iz)) !average - biased towards smallest - !lb2(iz) = 0.5*(dlu(iz)+dld(iz)) !average - - !Apply soft limit (only impacts very large lb; lb=100 by 5%, lb=500 by 20%). - lb1(iz) = lb1(iz)/(1. + (lb1(iz)/Lmax)) - lb2(iz) = lb2(iz)/(1. + (lb2(iz)/Lmax)) - - if (iz .eq. kte) then - lb1(kte) = lb1(kte-1) - lb2(kte) = lb2(kte-1) - endif - !print*,"IN MYNN-BouLac",kts, kte,lb1(iz) - !print*,"IN MYNN-BouLac",iz,dld(iz),dlu(iz) - - ENDDO - - END SUBROUTINE boulac_length -! -! ================================================================== -! SUBROUTINE mym_turbulence: -! -! Input variables: see subroutine mym_initialize -! closure : closure level (2.5, 2.6, or 3.0) -! -! # ql, vt, vq, qke, tsq, qsq and cov are changed to input variables. -! -! Output variables: see subroutine mym_initialize -! dfm(nx,nz,ny) : Diffusivity coefficient for momentum, -! divided by dz (not dz*h(i,j)) (m/s) -! dfh(nx,nz,ny) : Diffusivity coefficient for heat, -! divided by dz (not dz*h(i,j)) (m/s) -! dfq(nx,nz,ny) : Diffusivity coefficient for q^2, -! divided by dz (not dz*h(i,j)) (m/s) -! tcd(nx,nz,ny) : Countergradient diffusion term for Theta_l -! (K/s) -! qcd(nx,nz,ny) : Countergradient diffusion term for Q_w -! (kg/kg s) -! pd?(nx,nz,ny) : Half of the production terms -! -! Only tcd and qcd are defined at the center of the grid boxes -! -! # DO NOT forget that tcd and qcd are added on the right-hand side -! of the equations for Theta_l and Q_w, respectively. -! -! Work arrays: see subroutine mym_initialize and level2 -! -! # dtl, dqw, dtv, gm and gh are allowed to share storage units with -! dfm, dfh, dfq, tcd and qcd, respectively, for saving memory. -! -!>\ingroup gsd_mynn_edmf -!! This subroutine calculates the vertical diffusivity coefficients and the -!! production terms for the turbulent quantities. -!>\section gen_mym_turbulence GSD mym_turbulence General Algorithm -!! Two subroutines mym_level2() and mym_length() are called within this -!!subrouine to collect variable to carry out successive calculations: -!! - mym_level2() calculates the level 2 nondimensional wind shear \f$G_M\f$ -!! and vertical temperature gradient \f$G_H\f$ as well as the level 2 stability -!! functions \f$S_h\f$ and \f$S_m\f$. -!! - mym_length() calculates the mixing lengths. -!! - The stability criteria from Helfand and Labraga (1989) are applied. -!! - The stability functions for level 2.5 or level 3.0 are calculated. -!! - If level 3.0 is used, counter-gradient terms are calculated. -!! - Production terms of TKE,\f$\theta^{'2}\f$,\f$q^{'2}\f$, and \f$\theta^{'}q^{'}\f$ -!! are calculated. -!! - Eddy diffusivity \f$K_h\f$ and eddy viscosity \f$K_m\f$ are calculated. -!! - TKE budget terms are calculated (if the namelist parameter \p tke_budget -!! is set to True) - SUBROUTINE mym_turbulence ( & - & kts,kte, & - & xland,closure, & - & dz, dx, zw, & - & u, v, thl, thetav, ql, qw, & - & qke, tsq, qsq, cov, & - & vt, vq, & - & rmo, flt, fltv, flq, & - & zi,theta, & - & sh, sm, & - & El, & - & Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc, & - & qWT1D,qSHEAR1D,qBUOY1D,qDISS1D, & - & tke_budget, & - & Psig_bl,Psig_shcu,cldfra_bl1D, & - & bl_mynn_mixlength, & - & edmf_w1,edmf_a1, & - & TKEprodTD, & - & spp_pbl,rstoch_col ) - -!------------------------------------------------------------------- - - integer, intent(in) :: kts,kte - -#ifdef HARDCODE_VERTICAL -# define kts 1 -# define kte HARDCODE_VERTICAL -#endif - - integer, intent(in) :: bl_mynn_mixlength,tke_budget - real(kind_phys), intent(in) :: closure - real(kind_phys), dimension(kts:kte), intent(in) :: dz - real(kind_phys), dimension(kts:kte+1), intent(in) :: zw - real(kind_phys), intent(in) :: rmo,flt,fltv,flq, & - &Psig_bl,Psig_shcu,xland,dx,zi - real(kind_phys), dimension(kts:kte), intent(in) :: u,v,thl,thetav,qw, & - &ql,vt,vq,qke,tsq,qsq,cov,cldfra_bl1D,edmf_w1,edmf_a1, & - &TKEprodTD - - real(kind_phys), dimension(kts:kte), intent(out) :: dfm,dfh,dfq, & - &pdk,pdt,pdq,pdc,tcd,qcd,el - - real(kind_phys), dimension(kts:kte), intent(inout) :: & - qWT1D,qSHEAR1D,qBUOY1D,qDISS1D - real(kind_phys):: q3sq_old,dlsq1,qWTP_old,qWTP_new - real(kind_phys):: dudz,dvdz,dTdz,upwp,vpwp,Tpwp - - real(kind_phys), dimension(kts:kte) :: qkw,dtl,dqw,dtv,gm,gh,sm,sh - - integer :: k -! real(kind_phys):: cc2,cc3,e1c,e2c,e3c,e4c,e5c - real(kind_phys):: e6c,dzk,afk,abk,vtt,vqq, & - &cw25,clow,cupp,gamt,gamq,smd,gamv,elq,elh - - real(kind_phys):: cldavg - real(kind_phys), dimension(kts:kte), intent(in) :: theta - - real(kind_phys):: a2fac, duz, ri !JOE-Canuto/Kitamura mod - - real:: auh,aum,adh,adm,aeh,aem,Req,Rsl,Rsl2, & - gmelq,sm20,sh20,sm25max,sh25max,sm25min,sh25min, & - sm_pbl,sh_pbl,zi2,wt,slht,wtpr - - DOUBLE PRECISION q2sq, t2sq, r2sq, c2sq, elsq, gmel, ghel - DOUBLE PRECISION q3sq, t3sq, r3sq, c3sq, dlsq, qdiv - DOUBLE PRECISION e1, e2, e3, e4, enum, eden, wden - -! Stochastic - integer, intent(in) :: spp_pbl - real(kind_phys), dimension(kts:kte) :: rstoch_col - real(kind_phys):: Prnum, shb - real(kind_phys), parameter :: Prlimit = 5.0 - -! -! tv0 = 0.61*tref -! gtr = 9.81/tref -! -! cc2 = 1.0-c2 -! cc3 = 1.0-c3 -! e1c = 3.0*a2*b2*cc3 -! e2c = 9.0*a1*a2*cc2 -! e3c = 9.0*a2*a2*cc2*( 1.0-c5 ) -! e4c = 12.0*a1*a2*cc2 -! e5c = 6.0*a1*a1 -! - - CALL mym_level2 (kts,kte, & - & dz, & - & u, v, thl, thetav, qw, & - & ql, vt, vq, & - & dtl, dqw, dtv, gm, gh, sm, sh ) -! - CALL mym_length ( & - & kts,kte,xland, & - & dz, dx, zw, & - & rmo, flt, fltv, flq, & - & vt, vq, & - & u, v, qke, & - & dtv, & - & el, & - & zi,theta, & - & qkw,Psig_bl,cldfra_bl1D, & - & bl_mynn_mixlength, & - & edmf_w1,edmf_a1 ) -! - - DO k = kts+1,kte - dzk = 0.5 *( dz(k)+dz(k-1) ) - afk = dz(k)/( dz(k)+dz(k-1) ) - abk = 1.0 -afk - elsq = el (k)**2 - q3sq = qkw(k)**2 - q2sq = b1*elsq*( sm(k)*gm(k)+sh(k)*gh(k) ) - - 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 - duz = duz /dzk**2 - ! ** Gradient Richardson number ** - ri = -gh(k)/MAX( duz, 1.0e-10 ) - IF (CKmod .eq. 1) THEN - a2fac = 1./(1. + MAX(ri,0.0)) - ELSE - a2fac = 1. - ENDIF - !end Canuto/Kitamura mod - - !level 2.0 Prandtl number - !Prnum = MIN(sm20/sh20, 4.0) - !The form of Zilitinkevich et al. (2006) but modified - !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 - ghel = gh (k)*elsq -! Modified: Dec/22/2005, up to here - - ! Level 2.0 debug prints - IF ( debug_code ) THEN - IF (sh(k)<0.0 .OR. sm(k)<0.0) THEN - 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 - print*," PBLH=",zi," u=",u(k)," v=",v(k) - ENDIF - ENDIF - -! ** Since qkw is set to more than 0.0, q3sq > 0.0. ** - -! new stability criteria in level 2.5 (as well as level 3) - little/no impact -! ** Limitation on q, instead of L/q ** - dlsq = elsq - IF ( q3sq/dlsq .LT. -gh(k) ) q3sq = -dlsq*gh(k) - - IF ( q3sq .LT. q2sq ) THEN - !Apply Helfand & Labraga mod - qdiv = SQRT( q3sq/q2sq ) !HL89: (1-alfa) -! - !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) = sm(k) * qdiv - ! !sm_pbl = sm(k) * qdiv - ! - ! !Or, use the simple Pr relationship - ! sm(k) = Prnum*sh(k) - ! - ! !or blend them: - ! zi2 = MAX(zi, 300.) - ! wt =.5*TANH((zw(k) - zi2)/200.) + .5 - ! sm(k) = sm_pbl*(1.-wt) + sm(k)*wt - - !Recalculate terms for later use - !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*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 ) - !!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) - 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*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 - !Use level 2.5 stability functions - sm(k) = q3sq*a1*( e3-3.0*c1*e4 )/eden - ! sm_pbl = 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) - - ! !or blend them: - ! zi2 = MAX(zi, 300.) - ! wt = .5*TANH((zw(k) - zi2)/200.) + .5 - ! sm(k) = sm_pbl*(1.-wt) + sm(k)*wt - END IF !end Helfand & Labraga check - - !Impose broad limits on Sh and Sm: - gmelq = MAX(gmel/q3sq, 1e-8) - sm25max = 4. !MIN(sm20*3.0, SQRT(.1936/gmelq)) - sh25max = 4. !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 - IF ( debug_code ) THEN - IF ((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) - 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) - - !surface layer PR - !slht = zi*0.1 - !wtpr = min( max( (slht - zw(k))/slht, 0.0), 1.0) ! 1 at z=0, 0 above sfc layer - !Prlim = 1.0*wtpr + (1.0 - wtpr)*Prlimit - !Prlim = 2.0*wtpr + (1.0 - wtpr)*Prlimit - !sm(k) = MIN(sm(k), Prlim*Sh(k)) - !Pending more testing, keep same Pr limit in sfc layer - shb = max(sh(k), 0.02) - sm(k) = MIN(sm(k), Prlimit*shb) - -! ** Level 3 : start ** - 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) - t3sq = MAX( tsq(k)*abk+tsq(k-1)*afk, 0.0 ) - r3sq = MAX( qsq(k)*abk+qsq(k-1)*afk, 0.0 ) - c3sq = cov(k)*abk+cov(k-1)*afk - -! Modified: Dec/22/2005, from here - c3sq = SIGN( MIN( ABS(c3sq), SQRT(t3sq*r3sq) ), c3sq ) -! - 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 ) - t3sq = vtt*t3sq +vqq*c3sq - r3sq = vtt*c3sq +vqq*r3sq - c3sq = MAX( vtt*t3sq+vqq*r3sq, 0.0d0 ) -! - cw25 = e1*( e2 + 3.0*c1*e5c*gmel*qdiv**2 )/( 3.0*eden ) -! -! ** Limitation on q, instead of L/q ** - dlsq = elsq - IF ( q3sq/dlsq .LT. -gh(k) ) q3sq = -dlsq*gh(k) -! -! ** Limitation on c3sq (0.12 =< cw =< 0.76) ** - ! 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*a2fac)**2)*b2*(gtr)**2 - aum = 54.*(a1**2)*(a2*a2fac)*b2*c1*(gtr) - adh = 9.*a1*((a2*a2fac)**2)*(12.*a1 + 3.*b2)*(gtr)**2 - adm = 18.*(a1**2)*(a2*a2fac)*(b2 - 3.*(a2*a2fac))*(gtr) - - aeh = (9.*a1*((a2*a2fac)**2)*b1 +9.*a1*((a2*a2fac)**2)* & - (12.*a1 + 3.*b2))*(gtr) - aem = 3.*a1*(a2*a2fac)*b1*(3.*(a2*a2fac) + 3.*b2*c1 + & - (18.*a1*c1 - b2)) + & - (18.)*(a1**2)*(a2*a2fac)*(b2 - 3.*(a2*a2fac)) - - Req = -aeh/aem - Rsl = (auh + aum*Req)/(3.*adh + 3.*adm*Req) - !For now, use default values, since tests showed little/no sensitivity - Rsl = .12 !lower limit - Rsl2= 1.0 - 2.*Rsl !upper limit - !IF (k==2)print*,"Dynamic limit RSL=",Rsl - !IF (Rsl < 0.10 .OR. Rsl > 0.18) THEN - ! print*,'--- ERROR: MYNN: Dynamic Cw '// & - ! 'limit exceeds reasonable limits' - ! print*," MYNN: Dynamic Cw limit needs attention=",Rsl - !ENDIF - - !JOE-Canuto/Kitamura mod - !e2 = q3sq - e2c*ghel * qdiv**2 - !e3 = q3sq + e3c*ghel * qdiv**2 - !e4 = q3sq - e4c*ghel * 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*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 -! - IF ( wden .GT. 0.0 ) THEN - c3sq = MIN( MAX( c3sq, c2sq+clow ), c2sq+cupp ) - ELSE - c3sq = MAX( MIN( c3sq, c2sq+clow ), c2sq+cupp ) - END IF - END IF -! - e1 = e2 + e5c*gmel * qdiv**2 - eden = MAX( eden, 1.0d-20 ) -! Modified: Dec/22/2005, up to here - - !JOE-Canuto/Kitamura mod - !e6c = 3.0*a2*cc3*gtr * dlsq/elsq - e6c = 3.0*(a2*a2fac)*cc3*gtr * dlsq/elsq - - !============================ - ! ** for Gamma_theta ** - !! enum = qdiv*e6c*( t3sq-t2sq ) - IF ( t2sq .GE. 0.0 ) THEN - enum = MAX( qdiv*e6c*( t3sq-t2sq ), 0.0d0 ) - ELSE - enum = MIN( qdiv*e6c*( t3sq-t2sq ), 0.0d0 ) - ENDIF - gamt =-e1 *enum /eden - - !============================ - ! ** for Gamma_q ** - !! enum = qdiv*e6c*( r3sq-r2sq ) - IF ( r2sq .GE. 0.0 ) THEN - enum = MAX( qdiv*e6c*( r3sq-r2sq ), 0.0d0 ) - ELSE - enum = MIN( qdiv*e6c*( r3sq-r2sq ), 0.0d0 ) - ENDIF - gamq =-e1 *enum /eden - - !============================ - ! ** for Sm' and Sh'd(Theta_V)/dz ** - !! enum = qdiv*e6c*( c3sq-c2sq ) - enum = MAX( qdiv*e6c*( c3sq-c2sq ), 0.0d0) - - !JOE-Canuto/Kitamura mod - !smd = dlsq*enum*gtr/eden * qdiv**2 * (e3c+e4c)*a1/a2 - 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 - - !============================ - ! ** For elh (see below), qdiv at Level 3 is reset to 1.0. ** - qdiv = 1.0 - - ! Level 3 debug prints - IF ( debug_code ) THEN - IF (sh(k)<-0.3 .OR. sm(k)<-0.3 .OR. & - qke(k) < -0.1 .or. ABS(smd) .gt. 2.0) THEN - print*," MYNN; mym_turbulence3.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 - print*," PBLH=",zi," u=",u(k)," v=",v(k) - ENDIF - ENDIF - -! ** Level 3 : end ** - - ELSE -! ** At Level 2.5, qdiv is not reset. ** - gamt = 0.0 - gamq = 0.0 - gamv = 0.0 - END IF -! -! Add min background stability function (diffusivity) within model levels -! with active plumes and clouds. - cldavg = 0.5*(cldfra_bl1D(k-1) + cldfra_bl1D(k)) - IF (edmf_a1(k) > 0.001 .OR. cldavg > 0.02) THEN - ! for mass-flux columns - sm(k) = MAX(sm(k), 0.03*MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) - sh(k) = MAX(sh(k), 0.03*MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) - ! for clouds - sm(k) = MAX(sm(k), 0.05*MIN(cldavg,1.0) ) - sh(k) = MAX(sh(k), 0.05*MIN(cldavg,1.0) ) - ENDIF -! - elq = el(k)*qkw(k) - elh = elq*qdiv - - ! 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 ) + & - & 0.5*TKEprodTD(k) ! xmchen - 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 ) & - & *dqw(k)*0.5 & - & + elh*( sh(k)*dqw(k)+gamq )*dtl(k)*0.5 - - ! Contergradient terms - tcd(k) = elq*gamt - qcd(k) = elq*gamq - - ! Eddy Diffusivity/Viscosity divided by dz - dfm(k) = elq*sm(k) / dzk - dfh(k) = elq*sh(k) / dzk -! Modified: Dec/22/2005, from here -! ** In sub.mym_predict, dfq for the TKE and scalar variance ** -! ** are set to 3.0*dfm and 1.0*dfm, respectively. (Sqfac) ** - dfq(k) = dfm(k) -! Modified: Dec/22/2005, up to here - - IF (tke_budget .eq. 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) - - -!! TKE budget (Puhales, 2020, WRF 4.2.1) << EOB - - !!!Shear Term - !!!qSHEAR1D(k)=-(upwp*dudz + vpwp*dvdz) - qSHEAR1D(k) = elq*sm(k)*gm(k) !staggered - - !!!Buoyancy Term - !!!qBUOY1D(k)=grav*Tpwp/thl(k) - !qBUOY1D(k)= elq*(sh(k)*gh(k) + gamv) - !qBUOY1D(k) = elq*(sh(k)*(-dTdz*grav/thl(k)) + gamv) !! ORIGINAL CODE - - !! Buoyncy term takes the TKEprodTD(k) production now - qBUOY1D(k) = elq*(sh(k)*gh(k)+gamv)+0.5*TKEprodTD(k) ! xmchen - - !!!Dissipation Term (now it evaluated in mym_predict) - !qDISS1D(k) = (q3sq**(3./2.))/(b1*MAX(el(k),1.)) !! ORIGINAL CODE - - !! >> EOB - ENDIF - - END DO -! - - dfm(kts) = 0.0 - dfh(kts) = 0.0 - dfq(kts) = 0.0 - tcd(kts) = 0.0 - qcd(kts) = 0.0 - - tcd(kte) = 0.0 - qcd(kte) = 0.0 - -! - DO k = kts,kte-1 - dzk = dz(k) - tcd(k) = ( tcd(k+1)-tcd(k) )/( dzk ) - qcd(k) = ( qcd(k+1)-qcd(k) )/( dzk ) - END DO -! - if (spp_pbl==1) then - DO k = kts,kte - dfm(k)= dfm(k) + dfm(k)* rstoch_col(k) * 1.5 * MAX(exp(-MAX(zw(k)-8000.,0.0)/2000.),0.001) - dfh(k)= dfh(k) + dfh(k)* rstoch_col(k) * 1.5 * MAX(exp(-MAX(zw(k)-8000.,0.0)/2000.),0.001) - END DO - endif - -! RETURN -#ifdef HARDCODE_VERTICAL -# undef kts -# undef kte -#endif - - END SUBROUTINE mym_turbulence - -! ================================================================== -! SUBROUTINE mym_predict: -! -! Input variables: see subroutine mym_initialize and turbulence -! qke(nx,nz,ny) : qke at (n)th time level -! tsq, ...cov : ditto -! -! Output variables: -! qke(nx,nz,ny) : qke at (n+1)th time level -! tsq, ...cov : ditto -! -! Work arrays: -! qkw(nx,nz,ny) : q at the center of the grid boxes (m/s) -! bp (nx,nz,ny) : = 1/2*F, see below -! rp (nx,nz,ny) : = P-1/2*F*Q, see below -! -! # The equation for a turbulent quantity Q can be expressed as -! dQ/dt + Ah + Av = Dh + Dv + P - F*Q, (1) -! where A is the advection, D the diffusion, P the production, -! F*Q the dissipation and h and v denote horizontal and vertical, -! respectively. If Q is q^2, F is 2q/B_1L. -! Using the Crank-Nicholson scheme for Av, Dv and F*Q, a finite -! difference equation is written as -! Q{n+1} - Q{n} = dt *( Dh{n} - Ah{n} + P{n} ) -! + dt/2*( Dv{n} - Av{n} - F*Q{n} ) -! + dt/2*( Dv{n+1} - Av{n+1} - F*Q{n+1} ), (2) -! where n denotes the time level. -! When the advection and diffusion terms are discretized as -! dt/2*( Dv - Av ) = a(k)Q(k+1) - b(k)Q(k) + c(k)Q(k-1), (3) -! Eq.(2) can be rewritten as -! - a(k)Q(k+1) + [ 1 + b(k) + dt/2*F ]Q(k) - c(k)Q(k-1) -! = Q{n} + dt *( Dh{n} - Ah{n} + P{n} ) -! + dt/2*( Dv{n} - Av{n} - F*Q{n} ), (4) -! where Q on the left-hand side is at (n+1)th time level. -! -! In this subroutine, a(k), b(k) and c(k) are obtained from -! subprogram coefvu and are passed to subprogram tinteg via -! common. 1/2*F and P-1/2*F*Q are stored in bp and rp, -! respectively. Subprogram tinteg solves Eq.(4). -! -! Modify this subroutine according to your numerical integration -! scheme (program). -! -!------------------------------------------------------------------- -!>\ingroup gsd_mynn_edmf -!! This subroutine predicts the turbulent quantities at the next step. - SUBROUTINE mym_predict (kts,kte, & - & closure, & - & delt, & - & dz, & - & ust, flt, flq, pmz, phh, & - & el, dfq, rho, & - & pdk, pdt, pdq, pdc, & - & qke, tsq, qsq, cov, & - & s_aw,s_awqke,bl_mynn_edmf_tke, & - & qWT1D, qDISS1D,tke_budget) !! TKE budget (Puhales, 2020) - -!------------------------------------------------------------------- - integer, intent(in) :: kts,kte - -#ifdef HARDCODE_VERTICAL -# define kts 1 -# define kte HARDCODE_VERTICAL -#endif - - real(kind_phys), intent(in) :: closure - integer, intent(in) :: bl_mynn_edmf_tke,tke_budget - real(kind_phys), dimension(kts:kte), intent(in) :: dz, dfq, el, rho - real(kind_phys), dimension(kts:kte), intent(inout) :: pdk, pdt, pdq, pdc - real(kind_phys), intent(in) :: flt, flq, pmz, phh - real(kind_phys), intent(in) :: ust, delt - real(kind_phys), dimension(kts:kte), intent(inout) :: qke,tsq, qsq, cov -! WA 8/3/15 - real(kind_phys), dimension(kts:kte+1), intent(inout) :: s_awqke,s_aw - - !! TKE budget (Puhales, 2020, WRF 4.2.1) << EOB - real(kind_phys), dimension(kts:kte), intent(out) :: qWT1D, qDISS1D - real(kind_phys), dimension(kts:kte) :: tke_up,dzinv - !! >> EOB - - integer :: k - real(kind_phys), dimension(kts:kte) :: qkw, bp, rp, df3q - real(kind_phys):: vkz,pdk1,phm,pdt1,pdq1,pdc1,b1l,b2l,onoff - real(kind_phys), dimension(kts:kte) :: dtz - real(kind_phys), dimension(kts:kte) :: a,b,c,d,x - - real(kind_phys), dimension(kts:kte) :: rhoinv - real(kind_phys), 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 - onoff=0.0 - ELSE - onoff=1.0 - ENDIF - -! ** Strictly, vkz*h(i,j) -> karman*( 0.5*dz(1)*h(i,j)+z0 ) ** - vkz = karman*0.5*dz(kts) -! -! ** dfq for the TKE is 3.0*dfm. ** -! - DO k = kts,kte -!! qke(k) = MAX(qke(k), 0.0) - qkw(k) = SQRT( MAX( qke(k), 0.0 ) ) - df3q(k)=Sqfac*dfq(k) - 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* 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 - !end conservation mods - - pdk1 = 2.0*ust**3*pmz/( vkz ) - phm = 2.0/ust *phh/( vkz ) - pdt1 = phm*flt**2 - pdq1 = phm*flq**2 - pdc1 = phm*flt*flq -! -! ** pdk(1)+pdk(2) corresponds to pdk1. ** - pdk(kts) = pdk1 - pdk(kts+1) - -!! pdt(kts) = pdt1 -pdt(kts+1) -!! pdq(kts) = pdq1 -pdq(kts+1) -!! pdc(kts) = pdc1 -pdc(kts+1) - pdt(kts) = pdt(kts+1) - pdq(kts) = pdq(kts+1) - pdc(kts) = pdc(kts+1) -! -! ** Prediction of twice the turbulent kinetic energy ** -!! DO k = kts+1,kte-1 - DO k = kts,kte-1 - b1l = b1*0.5*( el(k+1)+el(k) ) - bp(k) = 2.*qkw(k) / b1l - rp(k) = pdk(k+1) + pdk(k) - END DO - -!! a(1)=0. -!! b(1)=1. -!! c(1)=-1. -!! d(1)=0. - -! Since df3q(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*df3q(k+1)+bp(k)*delt. - DO k=kts,kte-1 -! a(k-kts+1)=-dtz(k)*df3q(k) -! b(k-kts+1)=1.+dtz(k)*(df3q(k)+df3q(k+1))+bp(k)*delt -! 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)= - 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)*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 -!! a(k-kts+1)=-dtz(k)*df3q(k) -!! b(k-kts+1)=1.+dtz(k)*(df3q(k)+df3q(k+1)) -!! c(k-kts+1)=-dtz(k)*df3q(k+1) -!! d(k-kts+1)=rp(k)*delt + qke(k) - qke(k)*bp(k)*delt -!! ENDDO - -!! "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)=qke(kte) - -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,x) - - DO k=kts,kte -! qke(k)=max(d(k-kts+1), qkemin) - qke(k)=max(x(k), qkemin) - qke(k)=min(qke(k), 150.) - ENDDO - - -!! TKE budget (Puhales, 2020, WRF 4.2.1) << EOB - IF (tke_budget .eq. 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*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*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*rhoinv(k)*(-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 -!! >> EOB - - IF ( closure > 2.5 ) THEN - - ! ** 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) = pdq(k+1) + pdq(k) - END DO - - !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)= - 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 - - 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) - - DO k=kts,kte - !qsq(k)=d(k-kts+1) - qsq(k)=MAX(x(k),1e-17) - ENDDO - 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) = pdt(k+1) + pdt(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. - 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) -!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 + 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) - - DO k=kts,kte -! 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 - b2l = b2*0.5*( el(k+1)+el(k) ) - bp(k) = 2.*qkw(k) / b2l - rp(k) = pdc(k+1) + pdc(k) - END DO - -!zero gradient for tqcov 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 + 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 -!! 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 + cov(k) - cov(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) - - DO k=kts,kte -! cov(k)=d(k-kts+1) - cov(k)=x(k) - ENDDO - - ELSE - - !Not level 3 - default to 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 -! - tsq(k) = b2l*( pdt(k+1)+pdt(k) ) - cov(k) = b2l*( pdc(k+1)+pdc(k) ) - END DO - - tsq(kte)=tsq(kte-1) - cov(kte)=cov(kte-1) - - END IF - -#ifdef HARDCODE_VERTICAL -# undef kts -# undef kte -#endif - - END SUBROUTINE mym_predict - -! ================================================================== -! SUBROUTINE mym_condensation: -! -! Input variables: see subroutine mym_initialize and turbulence -! exner(nz) : Perturbation of the Exner function (J/kg K) -! defined on the walls of the grid boxes -! This is usually computed by integrating -! d(pi)/dz = h*g*tv/tref**2 -! from the upper boundary, where tv is the -! virtual potential temperature minus tref. -! -! Output variables: see subroutine mym_initialize -! cld(nx,nz,ny) : Cloud fraction -! -! Work arrays/variables: -! qmq : Q_w-Q_{sl}, where Q_{sl} is the saturation -! specific humidity at T=Tl -! alp(nx,nz,ny) : Functions in the condensation process -! bet(nx,nz,ny) : ditto -! sgm(nx,nz,ny) : Combined standard deviation sigma_s -! multiplied by 2/alp -! -! # qmq, alp, bet and sgm are allowed to share storage units with -! any four of other work arrays for saving memory. -! -! # Results are sensitive particularly to values of cp and r_d. -! Set these values to those adopted by you. -! -!------------------------------------------------------------------- -!>\ingroup gsd_mynn_edmf -!! This subroutine calculates 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 selected by -!! use of the namelist parameter \p bl_mynn_cloudpdf . - SUBROUTINE mym_condensation (kts,kte, & - & dx, dz, zw, xland, & - & thl, qw, qv, qc, qi, qs, & - & p,exner, & - & tsq, qsq, cov, & - & Sh, el, bl_mynn_cloudpdf, & - & qc_bl1D, qi_bl1D, & - & cldfra_bl1D, & - & PBLH1,HFX1, & - & Vt, Vq, th, sgm, rmo, & - & spp_pbl,rstoch_col ) - -!------------------------------------------------------------------- - - integer, intent(in) :: kts,kte, bl_mynn_cloudpdf - -#ifdef HARDCODE_VERTICAL -# define kts 1 -# define kte HARDCODE_VERTICAL -#endif - - real(kind_phys), intent(in) :: HFX1,rmo,xland - real(kind_phys), intent(in) :: dx,pblh1 - real(kind_phys), dimension(kts:kte), intent(in) :: dz - real(kind_phys), dimension(kts:kte+1), intent(in) :: zw - real(kind_phys), dimension(kts:kte), intent(in) :: p,exner,thl,qw, & - &qv,qc,qi,qs,tsq,qsq,cov,th - - real(kind_phys), dimension(kts:kte), intent(inout) :: vt,vq,sgm - - real(kind_phys), dimension(kts:kte) :: alp,a,bet,b,ql,q1,RH - real(kind_phys), dimension(kts:kte), intent(out) :: qc_bl1D,qi_bl1D, & - &cldfra_bl1D - DOUBLE PRECISION :: t3sq, r3sq, c3sq - - real(kind_phys):: qsl,esat,qsat,dqsl,cld0,q1k,qlk,eq1,qll, & - &q2p,pt,rac,qt,t,xl,rsl,cpm,Fng,qww,alpha,beta,bb, & - &ls,wt,wt2,qpct,cld_factor,fac_damp,liq_frac,ql_ice,ql_water, & - &qmq,qsat_tk,q1_rh,rh_hack,dzm1,zsl,maxqc - real(kind_phys), parameter :: qpct_sfc=0.025 - real(kind_phys), parameter :: qpct_pbl=0.030 - real(kind_phys), parameter :: qpct_trp=0.040 - real(kind_phys), parameter :: rhcrit =0.83 !for cloudpdf = 2 - real(kind_phys), parameter :: rhmax =1.02 !for cloudpdf = 2 - integer :: i,j,k - - real(kind_phys):: erf - - !VARIABLES FOR ALTERNATIVE SIGMA - real:: dth,dtl,dqw,dzk,els - real(kind_phys), dimension(kts:kte), intent(in) :: Sh,el - - !variables for SGS BL clouds - real(kind_phys) :: zagl,damp,PBLH2 - real(kind_phys) :: cfmax - - !JAYMES: variables for tropopause-height estimation - real(kind_phys) :: theta1, theta2, ht1, ht2 - integer :: k_tropo - -! Stochastic - integer, intent(in) :: spp_pbl - real(kind_phys), dimension(kts:kte) :: rstoch_col - real(kind_phys) :: qw_pert - -! First, obtain an estimate for the tropopause height (k), using the method employed in the -! Thompson subgrid-cloud scheme. This height will be a consideration later when determining -! the "final" subgrid-cloud properties. -! JAYMES: added 3 Nov 2016, adapted from G. Thompson - - DO k = kte-3, kts, -1 - theta1 = th(k) - theta2 = th(k+2) - ht1 = 44307.692 * (1.0 - (p(k)/101325.)**0.190) - ht2 = 44307.692 * (1.0 - (p(k+2)/101325.)**0.190) - if ( (((theta2-theta1)/(ht2-ht1)) .lt. 10./1500. ) .AND. & - & (ht1.lt.19000.) .and. (ht1.gt.4000.) ) then - goto 86 - endif - ENDDO - 86 continue - k_tropo = MAX(kts+2, k+2) - - zagl = 0. - - SELECT CASE(bl_mynn_cloudpdf) - - CASE (0) ! ORIGINAL MYNN PARTIAL-CONDENSATION SCHEME - - DO k = kts,kte-1 - t = th(k)*exner(k) - -!x if ( ct .gt. 0.0 ) then -! a = 17.27 -! b = 237.3 -!x else -!x a = 21.87 -!x b = 265.5 -!x end if -! -! ** 3.8 = 0.622*6.11 (hPa) ** - - !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*xlv/( r_d*t**2 ) - - alp(k) = 1.0/( 1.0+dqsl*xlvcp ) - bet(k) = dqsl*exner(k) - - !Sommeria and Deardorff (1977) scheme, as implemented - !in Nakanishi and Niino (2009), Appendix B - t3sq = MAX( tsq(k), 0.0 ) - r3sq = MAX( qsq(k), 0.0 ) - c3sq = cov(k) - c3sq = SIGN( MIN( ABS(c3sq), SQRT(t3sq*r3sq) ), c3sq ) - r3sq = r3sq +bet(k)**2*t3sq -2.0*bet(k)*c3sq - !DEFICIT/EXCESS WATER CONTENT - qmq = qw(k) -qsl - !ORIGINAL STANDARD DEVIATION - sgm(k) = SQRT( MAX( r3sq, 1.0d-10 )) - !NORMALIZED DEPARTURE FROM SATURATION - q1(k) = qmq / sgm(k) - !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) - ql(k) = alp(k)*sgm(k)*qll - !LIMIT SPECIES TO TEMPERATURE RANGES - liq_frac = min(1.0, max(0.0,(t-240.0)/29.0)) - qc_bl1D(k) = liq_frac*ql(k) - qi_bl1D(k) = (1.0 - liq_frac)*ql(k) - - !Now estimate the buoyancy flux functions - q2p = xlvcp/exner(k) - pt = thl(k) +q2p*ql(k) ! potential temp - - !qt is a THETA-V CONVERSION FOR TOTAL WATER (i.e., THETA-V = qt*THETA) - qt = 1.0 +p608*qw(k) -(1.+p608)*(qc_bl1D(k)+qi_bl1D(k))*cldfra_bl1D(k) - rac = alp(k)*( cldfra_bl1D(K)-qll*eq1 )*( q2p*qt-(1.+p608)*pt ) - - !BUOYANCY FACTORS: wherever vt and vq are used, there is a - !"+1" and "+tv0", respectively, so these are subtracted out here. - !vt is unitless and vq has units of K. - vt(k) = qt-1.0 -rac*bet(k) - vq(k) = p608*pt-tv0 +rac - - END DO - - CASE (1, -1) !ALTERNATIVE FORM (Nakanishi & Niino 2004 BLM, eq. B6, and - !Kuwano-Yoshida et al. 2010 QJRMS, eq. 7): - 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*xlv/( r_d*t**2 ) - - alp(k) = 1.0/( 1.0+dqsl*xlvcp ) - bet(k) = dqsl*exner(k) - - if (k .eq. kts) then - dzk = 0.5*dz(k) - else - dzk = dz(k) - end if - dth = 0.5*(thl(k+1)+thl(k)) - 0.5*(thl(k)+thl(MAX(k-1,kts))) - dqw = 0.5*(qw(k+1) + qw(k)) - 0.5*(qw(k) + qw(MAX(k-1,kts))) - sgm(k) = SQRT( MAX( (alp(k)**2 * MAX(el(k)**2,0.1) * & - b2 * MAX(Sh(k),0.03))/4. * & - (dqw/dzk - bet(k)*(dth/dzk ))**2 , 1.0e-10) ) - qmq = qw(k) -qsl - q1(k) = qmq / sgm(k) - cldfra_bl1D(K) = 0.5*( 1.0+erf( q1(k)*rr2 ) ) - - !now compute estimated lwc for PBL scheme's use - !qll IS THE NORMALIZED LIQUID WATER CONTENT (Sommeria and - !Deardorff (1977, eq 29a). rrp = 1/(sqrt(2*pi)) = 0.3989 - q1k = q1(k) - eq1 = rrp*EXP( -0.5*q1k*q1k ) - qll = MAX( cldfra_bl1D(K)*q1k + eq1, 0.0 ) - !ESTIMATED LIQUID WATER CONTENT (UNNORMALIZED) - ql (k) = alp(k)*sgm(k)*qll - liq_frac = min(1.0, max(0.0,(t-240.0)/29.0)) - qc_bl1D(k) = liq_frac*ql(k) - qi_bl1D(k) = (1.0 - liq_frac)*ql(k) - - !Now estimate the buoyancy flux functions - q2p = xlvcp/exner(k) - pt = thl(k) +q2p*ql(k) ! potential temp - - !qt is a THETA-V CONVERSION FOR TOTAL WATER (i.e., THETA-V = qt*THETA) - qt = 1.0 +p608*qw(k) -(1.+p608)*(qc_bl1D(k)+qi_bl1D(k))*cldfra_bl1D(k) - rac = alp(k)*( cldfra_bl1D(K)-qll*eq1 )*( q2p*qt-(1.+p608)*pt ) - - !BUOYANCY FACTORS: wherever vt and vq are used, there is a - !"+1" and "+tv0", respectively, so these are subtracted out here. - !vt is unitless and vq has units of K. - vt(k) = qt-1.0 -rac*bet(k) - vq(k) = p608*pt-tv0 +rac - - END DO - - CASE (2, -2) - - !Diagnostic statistical scheme of Chaboureau and Bechtold (2002), JAS - !but with use of higher-order moments to estimate sigma - pblh2=MAX(10._kind_phys,pblh1) - zagl = 0. - dzm1 = 0. - DO k = kts,kte-1 - zagl = zagl + 0.5*(dz(k) + dzm1) - dzm1 = dz(k) - - t = th(k)*exner(k) - xl = xl_blend(t) ! obtain latent heat - qsat_tk= qsat_blend(t, p(k)) ! saturation water vapor mixing ratio at tk and p - rh(k) = MAX(MIN(rhmax, qw(k)/MAX(1.E-10,qsat_tk)),0.001_kind_phys) - - !dqw/dT: Clausius-Clapeyron - dqsl = qsat_tk*ep_2*xlv/( r_d*t**2 ) - alp(k) = 1.0/( 1.0+dqsl*xlvcp ) - bet(k) = dqsl*exner(k) - - rsl = xl*qsat_tk / (r_v*t**2) ! slope of C-C curve at t (=abs temperature) - ! 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 = qw_pert - qsat_tk ! 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 constraints on sigma relative to saturation water vapor - sgm(k) = min( sgm(k), qsat_tk*0.666 ) - !sgm(k) = max( sgm(k), qsat_tk*0.035 ) - - !introduce vertical grid spacing dependence on min sgm - wt = max(500. - max(dz(k)-100.,0.0), 0.0_kind_phys)/500. !=1 for dz < 100 m, =0 for dz > 600 m - sgm(k) = sgm(k) + sgm(k)*0.2*(1.0-wt) !inflate sgm for coarse dz - - !allow min sgm to vary with dz and z. - qpct = qpct_pbl*wt + qpct_trp*(1.0-wt) - qpct = min(qpct, max(qpct_sfc, qpct_pbl*zagl/500.) ) - sgm(k) = max( sgm(k), qsat_tk*qpct ) - - q1(k) = qmq / sgm(k) ! Q1, the normalized saturation - - !Add condition for falling/settling into low-RH layers, so at least - !some cloud fraction is applied for all qc, qs, and qi. - rh_hack= rh(k) - wt2 = min(max( zagl - pblh2, 0.0 )/300., 1.0) - !ensure adequate RH & q1 when qi is at least 1e-9 (above the PBLH) - if ((qi(k)+qs(k))>1.e-9 .and. (zagl .gt. pblh2)) then - rh_hack =min(rhmax, rhcrit + wt2*0.045*(9.0 + log10(qi(k)+qs(k)))) - rh(k) =max(rh(k), rh_hack) - !add rh-based q1 - q1_rh =-3. + 3.*(rh(k)-rhcrit)/(1.-rhcrit) - q1(k) =max(q1_rh, q1(k) ) - endif - !ensure adequate rh & q1 when qc is at least 1e-6 (above the PBLH) - if (qc(k)>1.e-6 .and. (zagl .gt. pblh2)) then - rh_hack =min(rhmax, rhcrit + wt2*0.08*(6.0 + log10(qc(k)))) - rh(k) =max(rh(k), rh_hack) - !add rh-based q1 - q1_rh =-3. + 3.*(rh(k)-rhcrit)/(1.-rhcrit) - q1(k) =max(q1_rh, q1(k) ) - endif - - q1k = q1(k) ! backup Q1 for later modification - - ! Specify cloud fraction - !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 - !Waynes LES fit - over-diffuse, when limits removed from vt & vq & fng - !cldfra_bl1D(K) = max(0., min(1., 0.5+0.36*atan(1.2*(q1(k)+0.4)))) - !Best compromise: Improves marine stratus without adding much cold bias. - cldfra_bl1D(k) = max(0., min(1., 0.5+0.36*atan(1.8*(q1(k)+0.2)))) - - ! Specify hydrometeors - ! JAYMES- this option added 8 May 2015 - ! The cloud water formulations are taken from CB02, Eq. 8. - maxqc = max(qw(k) - qsat_tk, 0.0) - if (q1k < 0.) then !unsaturated - ql_water = sgm(k)*exp(1.2*q1k-1.) - ql_ice = sgm(k)*exp(1.2*q1k-1.) - elseif (q1k > 2.) then !supersaturated - ql_water = min(sgm(k)*q1k, maxqc) - ql_ice = sgm(k)*q1k - else !slightly saturated (0 > q1 < 2) - ql_water = min(sgm(k)*(exp(-1.) + 0.66*q1k + 0.086*q1k**2), maxqc) - ql_ice = sgm(k)*(exp(-1.) + 0.66*q1k + 0.086*q1k**2) - endif - - !In saturated grid cells, use average of SGS and resolved values - !if ( qc(k) > 1.e-6 ) ql_water = 0.5 * ( ql_water + qc(k) ) - !ql_ice is actually the total frozen condensate (snow+ice), - !if ( (qi(k)+qs(k)) > 1.e-9 ) ql_ice = 0.5 * ( ql_ice + (qi(k)+qs(k)) ) - - if (cldfra_bl1D(k) < 0.001) then - ql_ice = 0.0 - ql_water = 0.0 - cldfra_bl1D(k) = 0.0 - endif - - liq_frac = MIN(1.0, MAX(0.0, (t-tice)/(tliq-tice))) - qc_bl1D(k) = liq_frac*ql_water ! apply liq_frac to ql_water and ql_ice - qi_bl1D(k) = (1.0-liq_frac)*ql_ice - - !Above tropopause: eliminate subgrid clouds from CB scheme. Note that this was - !"k_tropo - 1" as of 20 Feb 2023. Changed to allow more high-level clouds. - if (k .ge. k_tropo) then - cldfra_bl1D(K) = 0. - qc_bl1D(k) = 0. - qi_bl1D(k) = 0. - endif - - !Buoyancy-flux-related calculations follow... - !limiting Q1 to avoid too much diffusion in cloud layers - !q1k=max(Q1(k),-2.0) - if ((xland-1.5).GE.0) then ! water - q1k=max(Q1(k),-2.5) - else ! land - q1k=max(Q1(k),-2.0) - endif - ! "Fng" represents the non-Gaussian transport factor - ! (non-dimensional) from Bechtold et al. 1995 - ! (hereafter BCMT95), section 3(c). Their suggested - ! forms for Fng (from their Eq. 20) are: - !IF (q1k < -2.) THEN - ! Fng = 2.-q1k - !ELSE IF (q1k > 0.) THEN - ! Fng = 1. - !ELSE - ! Fng = 1.-1.5*q1k - !ENDIF - ! Use the form of "Fng" from Bechtold and Siebesma (1998, JAS) - if (q1k .ge. 1.0) then - Fng = 1.0 - 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*(q1k+2.5)), 60._kind_phys) - endif - - cfmax = min(cldfra_bl1D(k), 0.6_kind_phys) - !Further limit the cf going into vt & vq near the surface - zsl = min(max(25., 0.1*pblh2), 100.) - wt = min(zagl/zsl, 1.0) !=0 at z=0 m, =1 above ekman layer - cfmax = cfmax*wt - - bb = b(k)*t/th(k) ! bb is "b" in BCMT95. Their "b" differs from - ! "b" in CB02 (i.e., b(k) above) by a factor - ! of T/theta. Strictly, b(k) above is formulated in - ! terms of sat. mixing ratio, but bb in BCMT95 is - ! cast in terms of sat. specific humidity. The - ! conversion is neglected here. - qww = 1.+0.61*qw(k) - alpha = 0.61*th(k) - beta = (th(k)/t)*(xl/cp) - 1.61*th(k) - vt(k) = qww - cfmax*beta*bb*Fng - 1. - vq(k) = alpha + cfmax*beta*a(k)*Fng - tv0 - ! vt and vq correspond to beta-theta and beta-q, respectively, - ! in NN09, Eq. B8. They also correspond to the bracketed - ! expressions in BCMT95, Eq. 15, since (s*ql/sigma^2) = cldfra*Fng - ! The "-1" and "-tv0" terms are included for consistency with - ! the legacy vt and vq formulations (above). - - ! dampen amplification factor where need be - fac_damp = min(zagl * 0.0025, 1.0) - !cld_factor = 1.0 + fac_damp*MAX(0.0, ( RH(k) - 0.75 ) / 0.26 )**1.9 !HRRRv4 - !cld_factor = 1.0 + fac_damp*min((max(0.0, ( RH(k) - 0.92 )) / 0.25 )**2, 0.3) - cld_factor = 1.0 + fac_damp*min((max(0.0, ( RH(k) - 0.92 )) / 0.145)**2, 0.37) - cldfra_bl1D(K) = min( 1., cld_factor*cldfra_bl1D(K) ) - enddo - - END SELECT !end cloudPDF option - - !For testing purposes only, option for isolating on the mass-flux clouds. - IF (bl_mynn_cloudpdf .LT. 0) THEN - DO k = kts,kte-1 - cldfra_bl1D(k) = 0.0 - qc_bl1D(k) = 0.0 - qi_bl1D(k) = 0.0 - END DO - ENDIF -! - ql(kte) = ql(kte-1) - vt(kte) = vt(kte-1) - vq(kte) = vq(kte-1) - qc_bl1D(kte)=0. - qi_bl1D(kte)=0. - cldfra_bl1D(kte)=0. - RETURN - -#ifdef HARDCODE_VERTICAL -# undef kts -# undef kte -#endif - - END SUBROUTINE mym_condensation - -! ================================================================== -!>\ingroup gsd_mynn_edmf -!! This subroutine solves for tendencies of U, V, \f$\theta\f$, qv, -!! qc, and qi - SUBROUTINE mynn_tendencies(kts,kte,i, & - &delt,dz,rho, & - &u,v,th,tk,qv,qc,qi,qs,qnc,qni, & - &psfc,p,exner, & - &thl,sqv,sqc,sqi,sqs,sqw, & - &qnwfa,qnifa,qnbca,ozone, & - &ust,flt,flq,flqv,flqc,wspd, & - &uoce,voce, & - &tsq,qsq,cov, & - &tcd,qcd, & - &dfm,dfh,dfq, & - &Du,Dv,Dth,Dqv,Dqc,Dqi,Dqs,Dqnc,Dqni, & - &Dqnwfa,Dqnifa,Dqnbca,Dozone, & - &diss_heat, & - &s_aw,s_awthl,s_awqt,s_awqv,s_awqc, & - &s_awu,s_awv, & - &s_awqnc,s_awqni, & - &s_awqnwfa,s_awqnifa,s_awqnbca, & - &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, & - &det_u,det_v, & - &FLAG_QC,FLAG_QI,FLAG_QNC,FLAG_QNI, & - &FLAG_QS, & - &FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA, & - &FLAG_OZONE, & - &cldfra_bl1d, & - &bl_mynn_cloudmix, & - &bl_mynn_mixqt, & - &bl_mynn_edmf, & - &bl_mynn_edmf_mom, & - &bl_mynn_mixscalars ) - -!------------------------------------------------------------------- - integer, intent(in) :: kts,kte,i - -#ifdef HARDCODE_VERTICAL -# define kts 1 -# define kte HARDCODE_VERTICAL -#endif - - integer, intent(in) :: bl_mynn_cloudmix,bl_mynn_mixqt, & - bl_mynn_edmf,bl_mynn_edmf_mom, & - bl_mynn_mixscalars - logical, intent(in) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QS, & - &FLAG_QNC,FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA,FLAG_OZONE - -! thl - liquid water potential temperature -! qw - total water -! dfm,dfh,dfq - diffusivities i.e., dfh(k) = elq*sh(k) / dzk -! flt - surface flux of thl -! flq - surface flux of qw - -! mass-flux plumes - real(kind_phys), 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_awqnbca, & - &sd_aw,sd_awthl,sd_awqt,sd_awqv,sd_awqc,sd_awu,sd_awv -! tendencies from mass-flux environmental subsidence and detrainment - real(kind_phys), dimension(kts:kte), intent(in) :: sub_thl,sub_sqv, & - &sub_u,sub_v,det_thl,det_sqv,det_sqc,det_u,det_v - real(kind_phys), dimension(kts:kte), intent(in) :: u,v,th,tk,qv,qc,qi,& - &qs,qni,qnc,rho,p,exner,dfq,dz,tsq,qsq,cov,tcd,qcd, & - &cldfra_bl1d,diss_heat - real(kind_phys), dimension(kts:kte), intent(inout) :: thl,sqw,sqv,sqc,& - &sqi,sqs,qnwfa,qnifa,qnbca,ozone,dfm,dfh - real(kind_phys), dimension(kts:kte), intent(inout) :: du,dv,dth,dqv, & - &dqc,dqi,dqs,dqni,dqnc,dqnwfa,dqnifa,dqnbca,dozone - real(kind_phys), intent(in) :: flt,flq,flqv,flqc,uoce,voce - real(kind_phys), intent(in) :: ust,delt,psfc,wspd - !debugging - real(kind_phys):: wsp,wsp2,tk2,th2 - logical :: problem - integer :: kproblem - -! real(kind_phys), intent(in) :: gradu_top,gradv_top,gradth_top,gradqv_top - -!local vars - - real(kind_phys), dimension(kts:kte) :: dtz,dfhc,dfmc,delp - real(kind_phys), dimension(kts:kte) :: sqv2,sqc2,sqi2,sqs2,sqw2, & - &qni2,qnc2,qnwfa2,qnifa2,qnbca2,ozone2 - real(kind_phys), dimension(kts:kte) :: zfac,plumeKh,rhoinv - real(kind_phys), dimension(kts:kte) :: a,b,c,d,x - real(kind_phys), dimension(kts:kte+1) :: rhoz, & !rho on model interface - &khdz,kmdz - real(kind_phys):: rhs,gfluxm,gfluxp,dztop,maxdfh,mindfh,maxcf,maxKh,zw - real(kind_phys):: t,esat,qsl,onoff,kh,km,dzk,rhosfc - real(kind_phys):: ustdrag,ustdiff,qvflux - real(kind_phys):: th_new,portion_qc,portion_qi,condensate,qsat - integer :: k,kk - - !Activate nonlocal mixing from the mass-flux scheme for - !number concentrations and aerosols (0.0 = no; 1.0 = yes) - real(kind_phys), parameter :: nonloc = 1.0 - - dztop=.5*(dz(kte)+dz(kte-1)) - - ! REGULATE THE MOMENTUM MIXING FROM THE MASS-FLUX SCHEME (on or off) - ! Note that s_awu and s_awv already come in as 0.0 if bl_mynn_edmf_mom == 0, so - ! we only need to zero-out the MF term - IF (bl_mynn_edmf_mom == 0) THEN - onoff=0.0 - ELSE - onoff=1.0 - ENDIF - - !Prepare "constants" for diffusion equation. - !khdz = rho*Kh/dz = rho*dfh - rhosfc = psfc/(R_d*(tk(kts)+p608*qv(kts))) - dtz(kts) =delt/dz(kts) - rhoz(kts) =rho(kts) - 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)) - 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) - 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*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 - ustdiff = MIN(ust*ust,0.01)/wspd ! limit at ~ 2 m/s - dth(kts:kte) = 0.0 ! must initialize for moisture_check routine - -!!============================================ -!! u -!!============================================ - - k=kts - -!rho-weighted (drag in b-vector): - a(k)= -dtz(k)*kmdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(kmdz(k+1)+rhosfc*ust**2/wspd)*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) + dtz(k)*uoce*ust**2/wspd & - & - 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)*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)*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 - -!! no flux at the top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=0. - -!! specified gradient at the top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=gradu_top*dztop - -!! prescribed value - a(kte)=0 - b(kte)=1. - c(kte)=0. - d(kte)=u(kte) - -! 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 -! du(k)=(d(k-kts+1)-u(k))/delt - du(k)=(x(k)-u(k))/delt - ENDDO - -!!============================================ -!! v -!!============================================ - - k=kts - -!rho-weighted (drag in b-vector): - a(k)= -dtz(k)*kmdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(kmdz(k+1) + rhosfc*ust**2/wspd)*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) + dtz(k)*voce*ust**2/wspd & - & - 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)*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)*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 - -!! no flux at the top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=0. - -!! specified gradient at the top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=gradv_top*dztop - -!! prescribed value - a(kte)=0 - b(kte)=1. - c(kte)=0. - d(kte)=v(kte) - -! 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 -! dv(k)=(d(k-kts+1)-v(k))/delt - dv(k)=(x(k)-v(k))/delt - ENDDO - -!!============================================ -!! thl tendency -!!============================================ - k=kts - -! a(k)=0. -! b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) -! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) -! d(k)=thl(k) + dtz(k)*flt + tcd(k)*delt & -! & -dtz(k)*s_awthl(kts+1) + diss_heat(k)*delt + & -! & sub_thl(k)*delt + det_thl(k)*delt -! -! 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(k)=thl(k) + tcd(k)*delt + dtz(k)*(s_awthl(k)-s_awthl(k+1)) & -! & + diss_heat(k)*delt + & -! & sub_thl(k)*delt + det_thl(k)*delt -! ENDDO - -!rho-weighted: rhosfc*X*rhoinv(k) - a(k)= -dtz(k)*khdz(k)*rhoinv(k) - 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)*rhosfc*flt*rhoinv(k) + tcd(k)*delt & - & - dtz(k)*rhoinv(k)*s_awthl(k+1) -dtz(k)*rhoinv(k)*sd_awthl(k+1) + & - & diss_heat(k)*delt + 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)*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)*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)*rhoinv(k)*(s_awthl(k)-s_awthl(k+1)) + dtz(k)*rhoinv(k)*(sd_awthl(k)-sd_awthl(k+1)) + & - & diss_heat(k)*delt + & - & sub_thl(k)*delt + det_thl(k)*delt - ENDDO - -!! no flux at the top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=0. - -!! specified gradient at the top -!assume gradthl_top=gradth_top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=gradth_top*dztop - -!! prescribed value - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=thl(kte) - -! 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 - !thl(k)=d(k-kts+1) - thl(k)=x(k) - ENDDO - -IF (bl_mynn_mixqt > 0) THEN - !============================================ - ! MIX total water (sqw = sqc + sqv + sqi) - ! NOTE: no total water tendency is output; instead, we must calculate - ! the saturation specific humidity and then - ! subtract out the moisture excess (sqc & sqi) - !============================================ - - k=kts - -! a(k)=0. -! b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) -! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) -! !rhs= qcd(k) !+ (gfluxp - gfluxm)/dz(k)& -! d(k)=sqw(k) + dtz(k)*flq + qcd(k)*delt - dtz(k)*s_awqt(k+1) -! -! 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(k)=sqw(k) + qcd(k)*delt + dtz(k)*(s_awqt(k)-s_awqt(k+1)) -! 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)*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)*rhosfc*flq*rhoinv(k) + 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)*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)*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 -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=0. -!! specified gradient at the top -!assume gradqw_top=gradqv_top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=gradqv_top*dztop -!! prescribed value - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=sqw(kte) - -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,sqw2) -! CALL tridiag3(kte,a,b,c,d,sqw2) - -! DO k=kts,kte -! sqw2(k)=d(k-kts+1) -! ENDDO -ELSE - sqw2=sqw -ENDIF - -IF (bl_mynn_mixqt == 0) THEN -!============================================ -! cloud water ( sqc ). If mixing total water (bl_mynn_mixqt > 0), -! then sqc will be backed out of saturation check (below). -!============================================ - IF (bl_mynn_cloudmix > 0 .AND. FLAG_QC) THEN - - k=kts - -! a(k)=0. -! b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) -! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) -! d(k)=sqc(k) + dtz(k)*flqc + qcd(k)*delt - & -! dtz(k)*s_awqc(k+1) + det_sqc(k)*delt -! -! 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(k)=sqc(k) + qcd(k)*delt + dtz(k)*(s_awqc(k)-s_awqc(k+1)) + & -! det_sqc(k)*delt -! 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)*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)*rhosfc*flqc*rhoinv(k) + 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)*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)*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 - -! prescribed value - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=sqc(kte) - -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,sqc2) -! CALL tridiag3(kte,a,b,c,d,sqc2) - -! DO k=kts,kte -! sqc2(k)=d(k-kts+1) -! ENDDO - ELSE - !If not mixing clouds, set "updated" array equal to original array - sqc2=sqc - ENDIF -ENDIF - -IF (bl_mynn_mixqt == 0) THEN - !============================================ - ! MIX WATER VAPOR ONLY ( sqv ). If mixing total water (bl_mynn_mixqt > 0), - ! then sqv will be backed out of saturation check (below). - !============================================ - - k=kts - -! a(k)=0. -! b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) -! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) -! d(k)=sqv(k) + dtz(k)*flqv + qcd(k)*delt - dtz(k)*s_awqv(k+1) + & -! & sub_sqv(k)*delt + det_sqv(k)*delt -! -! 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(k)=sqv(k) + qcd(k)*delt + dtz(k)*(s_awqv(k)-s_awqv(k+1)) + & -! & sub_sqv(k)*delt + det_sqv(k)*delt -! ENDDO - - !limit unreasonably large negative fluxes: - qvflux = flqv - if (qvflux < 0.0) then - !do not allow specified surface flux to reduce qv below 1e-8 kg/kg - qvflux = max(qvflux, (min(0.9*sqv(kts) - 1e-8, 0.0)/dtz(kts))) - endif - -!rho-weighted: rhosfc*X*rhoinv(k) - a(k)= -dtz(k)*khdz(k)*rhoinv(k) - 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)*rhosfc*qvflux*rhoinv(k) + 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)*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)*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 - -! no flux at the top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=0. - -! specified gradient at the top -! assume gradqw_top=gradqv_top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=gradqv_top*dztop - -! prescribed value - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=sqv(kte) - -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,sqv2) -! CALL tridiag3(kte,a,b,c,d,sqv2) - -! DO k=kts,kte -! sqv2(k)=d(k-kts+1) -! ENDDO -ELSE - sqv2=sqv -ENDIF - -!============================================ -! MIX CLOUD ICE ( sqi ) -!============================================ -IF (bl_mynn_cloudmix > 0 .AND. FLAG_QI) THEN - - k=kts -!rho-weighted: - a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - d(k)=sqi(k) - - DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - d(k)=sqi(k) - ENDDO - -!! no flux at the top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=0. - -!! specified gradient at the top -!assume gradqw_top=gradqv_top -! a(kte)=-1. -! b(kte)=1. -! c(kte)=0. -! d(kte)=gradqv_top*dztop - -!! prescribed value - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=sqi(kte) - -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,sqi2) -! CALL tridiag3(kte,a,b,c,d,sqi2) - -! DO k=kts,kte -! sqi2(k)=d(k-kts+1) -! ENDDO -ELSE - sqi2=sqi -ENDIF - -!============================================ -! MIX SNOW ( sqs ) -!============================================ -!hard-code to not mix snow -IF (bl_mynn_cloudmix > 0 .AND. .false.) THEN - - k=kts -!rho-weighted: - a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - d(k)=sqs(k) - - DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - d(k)=sqs(k) - ENDDO - -!! prescribed value - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=sqs(kte) - -! CALL tridiag(kte,a,b,c,d) - CALL tridiag2(kte,a,b,c,d,sqs2) -! CALL tridiag3(kte,a,b,c,d,sqs2) - -! DO k=kts,kte -! sqs2(k)=d(k-kts+1) -! ENDDO -ELSE - sqs2=sqs -ENDIF - -!!============================================ -!! cloud ice number concentration (qni) -!!============================================ -IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNI .AND. & - bl_mynn_mixscalars > 0) THEN - - 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)*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)*rhoinv(k)*s_aw(k)*nonloc - b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & - & 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 - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=qni(kte) - -! 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 - !qni2(k)=d(k-kts+1) - qni2(k)=x(k) - ENDDO - -ELSE - qni2=qni -ENDIF - -!!============================================ -!! cloud water number concentration (qnc) -!! include non-local transport -!!============================================ - IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNC .AND. & - bl_mynn_mixscalars > 0) THEN - - 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)*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)*rhoinv(k)*s_aw(k)*nonloc - b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & - & 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 - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=qnc(kte) - -! 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 - !qnc2(k)=d(k-kts+1) - qnc2(k)=x(k) - ENDDO - -ELSE - qnc2=qnc -ENDIF - -!============================================ -! Water-friendly aerosols ( qnwfa ). -!============================================ -IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNWFA .AND. & - bl_mynn_mixscalars > 0) THEN - - k=kts - - a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*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)=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)*rhoinv(k)*s_aw(k)*nonloc - b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) + & - & 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 - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=qnwfa(kte) - -! 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 - !qnwfa2(k)=d(k) - qnwfa2(k)=x(k) - ENDDO - -ELSE - !If not mixing aerosols, set "updated" array equal to original array - qnwfa2=qnwfa -ENDIF - -!============================================ -! Ice-friendly aerosols ( qnifa ). -!============================================ -IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNIFA .AND. & - bl_mynn_mixscalars > 0) THEN - - k=kts - - a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*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)=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)*rhoinv(k)*s_aw(k)*nonloc - b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) + & - & 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 - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=qnifa(kte) - -! 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 - !qnifa2(k)=d(k-kts+1) - qnifa2(k)=x(k) - ENDDO - -ELSE - !If not mixing aerosols, set "updated" array equal to original array - qnifa2=qnifa -ENDIF - -!============================================ -! Black-carbon aerosols ( qnbca ). -!============================================ -IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNBCA .AND. & - bl_mynn_mixscalars > 0) THEN - - k=kts - - a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*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)=qnbca(k) - dtz(k)*rhoinv(k)*s_awqnbca(k+1)*nonloc - - DO k=kts+1,kte-1 - 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)*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)=qnbca(k) + dtz(k)*rhoinv(k)*(s_awqnbca(k)-s_awqnbca(k+1))*nonloc - ENDDO - -! prescribed value - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=qnbca(kte) - -! 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 - !qnbca2(k)=d(k-kts+1) - qnbca2(k)=x(k) - ENDDO - -ELSE - !If not mixing aerosols, set "updated" array equal to original array - qnbca2=qnbca -ENDIF - -!============================================ -! Ozone - local mixing only -!============================================ -IF (FLAG_OZONE) THEN - k=kts - -!rho-weighted: - a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - d(k)=ozone(k) - - DO k=kts+1,kte-1 - a(k)= -dtz(k)*khdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) - c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - d(k)=ozone(k) - ENDDO - -! prescribed value - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=ozone(kte) - -! 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 - !ozone2(k)=d(k-kts+1) - dozone(k)=(x(k)-ozone(k))/delt - ENDDO -ELSE - dozone(:)=0.0 -ENDIF - -!!============================================ -!! Compute tendencies and convert to mixing ratios for WRF. -!! Note that the momentum tendencies are calculated above. -!!============================================ - - IF (bl_mynn_mixqt > 0) THEN - DO k=kts,kte - !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) - !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 (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 - ENDDO - ENDIF - - - !===================== - ! WATER VAPOR TENDENCY - !===================== - DO k=kts,kte - Dqv(k)=(sqv2(k) - sqv(k))/delt - !if (sqv2(k) < 0.0)print*,"neg qv:",sqv2(k),k - ENDDO - - IF (bl_mynn_cloudmix > 0) THEN - !===================== - ! CLOUD WATER TENDENCY - !===================== - !print*,"FLAG_QC:",FLAG_QC - IF (FLAG_QC) THEN - DO k=kts,kte - Dqc(k)=(sqc2(k) - sqc(k))/delt - !if (sqc2(k) < 0.0)print*,"neg qc:",sqc2(k),k - ENDDO - ELSE - DO k=kts,kte - Dqc(k) = 0. - ENDDO - ENDIF - - !=================== - ! CLOUD WATER NUM CONC TENDENCY - !=================== - IF (FLAG_QNC .AND. bl_mynn_mixscalars > 0) THEN - DO k=kts,kte - Dqnc(k) = (qnc2(k)-qnc(k))/delt - !IF(Dqnc(k)*delt + qnc(k) < 0.)Dqnc(k)=-qnc(k)/delt - ENDDO - ELSE - DO k=kts,kte - Dqnc(k) = 0. - ENDDO - ENDIF - - !=================== - ! CLOUD ICE TENDENCY - !=================== - IF (FLAG_QI) THEN - DO k=kts,kte - Dqi(k)=(sqi2(k) - sqi(k))/delt - !if (sqi2(k) < 0.0)print*,"neg qi:",sqi2(k),k - ENDDO - ELSE - DO k=kts,kte - Dqi(k) = 0. - ENDDO - ENDIF - - !=================== - ! CLOUD SNOW TENDENCY - !=================== - IF (.false.) THEN !disabled - DO k=kts,kte - Dqs(k)=(sqs2(k) - sqs(k))/delt - ENDDO - ELSE - DO k=kts,kte - Dqs(k) = 0. - ENDDO - ENDIF - - !=================== - ! CLOUD ICE NUM CONC TENDENCY - !=================== - IF (FLAG_QNI .AND. bl_mynn_mixscalars > 0) THEN - DO k=kts,kte - Dqni(k)=(qni2(k)-qni(k))/delt - !IF(Dqni(k)*delt + qni(k) < 0.)Dqni(k)=-qni(k)/delt - ENDDO - ELSE - DO k=kts,kte - Dqni(k)=0. - ENDDO - ENDIF - ELSE !-MIX CLOUD SPECIES? - !CLOUDS ARE NOT NIXED (when bl_mynn_cloudmix == 0) - DO k=kts,kte - Dqc(k) =0. - Dqnc(k)=0. - Dqi(k) =0. - Dqni(k)=0. - Dqs(k) =0. - ENDDO - ENDIF - - !ensure non-negative moist species - CALL moisture_check(kte, delt, delp, exner, & - sqv2, sqc2, sqi2, sqs2, thl, & - dqv, dqc, dqi, dqs, dth ) - - !===================== - ! 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 - !=================== - IF (FLAG_QI) THEN - DO k=kts,kte - Dth(k)=(thl(k) + xlvcp/exner(k)*sqc2(k) & - & + xlscp/exner(k)*(sqi2(k)) & !+sqs(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) & - ! & + xlscp/MAX(tk(k),TKmin)*sqi(k)) & - ! & - th(k))/delt - ENDDO - ELSE - DO k=kts,kte - 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)) & - !& - th(k))/delt - ENDDO - ENDIF - - !=================== - ! AEROSOL TENDENCIES - !=================== - IF (FLAG_QNWFA .AND. FLAG_QNIFA .AND. & - bl_mynn_mixscalars > 0) THEN - DO k=kts,kte - !===================== - ! WATER-friendly aerosols - !===================== - Dqnwfa(k)=(qnwfa2(k) - qnwfa(k))/delt - !===================== - ! Ice-friendly aerosols - !===================== - Dqnifa(k)=(qnifa2(k) - qnifa(k))/delt - ENDDO - ELSE - DO k=kts,kte - Dqnwfa(k)=0. - Dqnifa(k)=0. - ENDDO - ENDIF - - !======================== - ! BLACK-CARBON TENDENCIES - !======================== - IF (FLAG_QNBCA .AND. bl_mynn_mixscalars > 0) THEN - DO k=kts,kte - Dqnbca(k)=(qnbca2(k) - qnbca(k))/delt - ENDDO - ELSE - DO k=kts,kte - Dqnbca(k)=0. - 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 ) - - if (debug_code) then - problem = .false. - do k=kts,kte - wsp = sqrt(u(k)**2 + v(k)**2) - wsp2 = sqrt((u(k)+du(k)*delt)**2 + (v(k)+du(k)*delt)**2) - th2 = th(k) + Dth(k)*delt - tk2 = th2*exner(k) - if (wsp2 > 200. .or. tk2 > 360. .or. tk2 < 160.) then - problem = .true. - print*,"Outgoing problem at: i=",i," k=",k - print*," incoming wsp=",wsp," outgoing wsp=",wsp2 - print*," incoming T=",th(k)*exner(k),"outgoing T:",tk2 - print*," du=",du(k)*delt," dv=",dv(k)*delt," dth=",dth(k)*delt - print*," km=",kmdz(k)*dz(k)," kh=",khdz(k)*dz(k) - print*," u*=",ust," wspd=",wspd,"rhosfc=",rhosfc - print*," LH=",flq*rhosfc*1004.," HFX=",flt*rhosfc*1004. - print*," drag term=",ust**2/wspd*dtz(k)*rhosfc/rho(kts) - kproblem = k - endif - enddo - if (problem) then - print*,"==thl:",thl(max(kproblem-3,1):min(kproblem+3,kte)) - print*,"===qv:",sqv2(max(kproblem-3,1):min(kproblem+3,kte)) - print*,"===qc:",sqc2(max(kproblem-3,1):min(kproblem+3,kte)) - print*,"===qi:",sqi2(max(kproblem-3,1):min(kproblem+3,kte)) - print*,"====u:",u(max(kproblem-3,1):min(kproblem+3,kte)) - print*,"====v:",v(max(kproblem-3,1):min(kproblem+3,kte)) - endif - endif - -#ifdef HARDCODE_VERTICAL -# undef kts -# undef kte -#endif - - END SUBROUTINE mynn_tendencies - -! ================================================================== - SUBROUTINE moisture_check(kte, delt, dp, exner, & - qv, qc, qi, qs, th, & - dqv, dqc, dqi, dqs, 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(kind_phys), intent(in) :: delt - real(kind_phys), dimension(kte), intent(in) :: dp, exner - real(kind_phys), dimension(kte), intent(inout) :: qv, qc, qi, qs, th - real(kind_phys), dimension(kte), intent(inout) :: dqv, dqc, dqi, dqs, dth - integer k - real(kind_phys):: dqc2, dqi2, dqs2, dqv2, sum, aa, dum - real(kind_phys), 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) - dqs2 = max(0.0, qimin-qs(k)) !qs deficit (>=0) - - !fix tendencies - dqc(k) = dqc(k) + dqc2/delt - dqi(k) = dqi(k) + dqi2/delt - dqs(k) = dqs(k) + dqs2/delt - dqv(k) = dqv(k) - (dqc2+dqi2+dqs2)/delt - dth(k) = dth(k) + xlvcp/exner(k)*(dqc2/delt) + & - xlscp/exner(k)*((dqi2+dqs2)/delt) - !update species - qc(k) = qc(k) + dqc2 - qi(k) = qi(k) + dqi2 - qs(k) = qs(k) + dqs2 - qv(k) = qv(k) - dqc2 - dqi2 - dqs2 - th(k) = th(k) + xlvcp/exner(k)*dqc2 + & - xlscp/exner(k)*(dqi2+dqs2) - - !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) - qs(k) = max(qs(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 - -! ================================================================== - - SUBROUTINE mynn_mix_chem(kts,kte,i, & - delt,dz,pblh, & - nchem, kdvel, ndvel, & - chem1, vd1, & - rho, & - flt, tcd, qcd, & - dfh, & - s_aw, s_awchem, & - emis_ant_no, frp, rrfs_sd, & - enh_mix, smoke_dbg ) - -!------------------------------------------------------------------- - integer, intent(in) :: kts,kte,i - real(kind_phys), dimension(kts:kte), intent(in) :: dfh,dz,tcd,qcd - real(kind_phys), dimension(kts:kte), intent(inout) :: rho - real(kind_phys), intent(in) :: flt - real(kind_phys), intent(in) :: delt,pblh - integer, intent(in) :: nchem, kdvel, ndvel - real(kind_phys), dimension( kts:kte+1), intent(in) :: s_aw - real(kind_phys), dimension( kts:kte, nchem ), intent(inout) :: chem1 - real(kind_phys), dimension( kts:kte+1,nchem), intent(in) :: s_awchem - real(kind_phys), dimension( ndvel ), intent(in) :: vd1 - real(kind_phys), intent(in) :: emis_ant_no,frp - logical, intent(in) :: rrfs_sd,enh_mix,smoke_dbg -!local vars - - real(kind_phys), dimension(kts:kte) :: dtz - real(kind_phys), dimension(kts:kte) :: a,b,c,d,x - real(kind_phys):: rhs,dztop - real(kind_phys):: t,dzk - real(kind_phys):: hght - real(kind_phys):: khdz_old, khdz_back - integer :: k,kk,kmaxfire ! JLS 12/21/21 - integer :: ic ! Chemical array loop index - - integer, SAVE :: icall - - real(kind_phys), dimension(kts:kte) :: rhoinv - real(kind_phys), dimension(kts:kte+1) :: rhoz,khdz - real(kind_phys), parameter :: NO_threshold = 10.0 ! For anthropogenic sources - real(kind_phys), parameter :: frp_threshold = 10.0 ! RAR 02/11/22: I increased the frp threshold to enhance mixing over big fires - real(kind_phys), parameter :: pblh_threshold = 100.0 - - dztop=.5*(dz(kte)+dz(kte-1)) - - DO k=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) - - 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 - rhoz(kte+1)=rhoz(kte) - 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*s_aw(k)) - khdz(k) = MAX(khdz(k), -0.5*(s_aw(k)-s_aw(k+1))) - ENDDO - - !Enhanced mixing over fires - IF ( rrfs_sd .and. enh_mix ) THEN - DO k=kts+1,kte-1 - khdz_old = khdz(k) - khdz_back = pblh * 0.15 / dz(k) - !Modify based on anthropogenic emissions of NO and FRP - IF ( pblh < pblh_threshold ) THEN - IF ( emis_ant_no > NO_threshold ) THEN - khdz(k) = MAX(1.1*khdz(k),sqrt((emis_ant_no / NO_threshold)) / dz(k) * rhoz(k)) ! JLS 12/21/21 -! khdz(k) = MAX(khdz(k),khdz_back) - ENDIF - IF ( frp > frp_threshold ) THEN - kmaxfire = ceiling(log(frp)) - khdz(k) = MAX(1.1*khdz(k), (1. - k/(kmaxfire*2.)) * ((log(frp))**2.- 2.*log(frp)) / dz(k)*rhoz(k)) ! JLS 12/21/21 -! khdz(k) = MAX(khdz(k),khdz_back) - ENDIF - ENDIF - ENDDO - ENDIF - - !============================================ - ! Patterned after mixing of water vapor in mynn_tendencies. - !============================================ - - DO ic = 1,nchem - 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)*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(k,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)*rhoinv(k)*s_aw(k) - b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & - & 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 - a(kte)=0. - b(kte)=1. - c(kte)=0. - d(kte)=chem1(kte,ic) - - CALL tridiag3(kte,a,b,c,d,x) - - DO k=kts,kte - chem1(k,ic)=x(k) - ENDDO - ENDDO - - END SUBROUTINE mynn_mix_chem - -! ================================================================== -!>\ingroup gsd_mynn_edmf - SUBROUTINE retrieve_exchange_coeffs(kts,kte,& - &dfm,dfh,dz,K_m,K_h) - -!------------------------------------------------------------------- - - integer , intent(in) :: kts,kte - - real(kind_phys), dimension(KtS:KtE), intent(in) :: dz,dfm,dfh - - real(kind_phys), dimension(KtS:KtE), intent(out) :: K_m, K_h - - - integer :: k - real(kind_phys):: dzk - - K_m(kts)=0. - K_h(kts)=0. - - DO k=kts+1,kte - dzk = 0.5 *( dz(k)+dz(k-1) ) - K_m(k)=dfm(k)*dzk - K_h(k)=dfh(k)*dzk - ENDDO - - END SUBROUTINE retrieve_exchange_coeffs - -! ================================================================== -!>\ingroup gsd_mynn_edmf - SUBROUTINE tridiag(n,a,b,c,d) - -!! to solve system of linear eqs on tridiagonal matrix n times n -!! after Peaceman and Rachford, 1955 -!! a,b,c,d - are vectors of order n -!! a,b,c - are coefficients on the LHS -!! d - is initially RHS on the output becomes a solution vector - -!------------------------------------------------------------------- - - integer, intent(in):: n - real(kind_phys), dimension(n), intent(in) :: a,b - real(kind_phys), dimension(n), intent(inout) :: c,d - - integer :: i - real(kind_phys):: p - real(kind_phys), dimension(n) :: q - - c(n)=0. - q(1)=-c(1)/b(1) - d(1)=d(1)/b(1) - - DO i=2,n - p=1./(b(i)+a(i)*q(i-1)) - q(i)=-c(i)*p - d(i)=(d(i)-a(i)*d(i-1))*p - ENDDO - - DO i=n-1,1,-1 - d(i)=d(i)+q(i)*d(i+1) - ENDDO - - END SUBROUTINE tridiag - -! ================================================================== -!>\ingroup gsd_mynn_edmf - subroutine tridiag2(n,a,b,c,d,x) - implicit none -! a - sub-diagonal (means it is the diagonal below the main diagonal) -! b - the main diagonal -! c - sup-diagonal (means it is the diagonal above the main diagonal) -! d - right part -! x - the answer -! n - number of unknowns (levels) - - integer,intent(in) :: n - real(kind_phys), dimension(n), intent(in) :: a,b,c,d - real(kind_phys), dimension(n), intent(out):: x - real(kind_phys), dimension(n) :: cp,dp - real(kind_phys):: m - integer :: i - - ! initialize c-prime and d-prime - cp(1) = c(1)/b(1) - dp(1) = d(1)/b(1) - ! solve for vectors c-prime and d-prime - do i = 2,n - m = b(i)-cp(i-1)*a(i) - cp(i) = c(i)/m - dp(i) = (d(i)-dp(i-1)*a(i))/m - enddo - ! initialize x - x(n) = dp(n) - ! solve for x from the vectors c-prime and d-prime - do i = n-1, 1, -1 - x(i) = dp(i)-cp(i)*x(i+1) - end do - - end subroutine tridiag2 -! ================================================================== -!>\ingroup gsd_mynn_edmf - subroutine tridiag3(kte,a,b,c,d,x) - -!ccccccccccccccccccccccccccccccc -! Aim: Inversion and resolution of a tridiagonal matrix -! A X = D -! Input: -! a(*) lower diagonal (Ai,i-1) -! b(*) principal diagonal (Ai,i) -! c(*) upper diagonal (Ai,i+1) -! d -! Output -! x results -!ccccccccccccccccccccccccccccccc - - implicit none - integer,intent(in) :: kte - integer, parameter :: kts=1 - real(kind_phys), dimension(kte) :: a,b,c,d - real(kind_phys), dimension(kte), intent(out) :: x - integer :: in - -! integer kms,kme,kts,kte,in -! real(kind_phys)a(kms:kme,3),c(kms:kme),x(kms:kme) - - do in=kte-1,kts,-1 - d(in)=d(in)-c(in)*d(in+1)/b(in+1) - b(in)=b(in)-c(in)*a(in+1)/b(in+1) - enddo - - do in=kts+1,kte - d(in)=d(in)-a(in)*d(in-1)/b(in-1) - enddo - - do in=kts,kte - x(in)=d(in)/b(in) - enddo - - return - end subroutine tridiag3 - -! ================================================================== -!>\ingroup gsd_mynn_edmf -!! This subroutine calculates hybrid diagnotic boundary-layer height (PBLH). -!! -!! NOTES ON THE PBLH FORMULATION: The 1.5-theta-increase method defines -!!PBL heights as the level at. -!!which the potential temperature first exceeds the minimum potential. -!!temperature within the boundary layer by 1.5 K. When applied to. -!!observed temperatures, this method has been shown to produce PBL- -!!height estimates that are unbiased relative to profiler-based. -!!estimates (Nielsen-Gammon et al. 2008 \cite Nielsen_Gammon_2008). -!! However, their study did not -!!include LLJs. Banta and Pichugina (2008) \cite Pichugina_2008 show that a TKE-based. -!!threshold is a good estimate of the PBL height in LLJs. Therefore, -!!a hybrid definition is implemented that uses both methods, weighting -!!the TKE-method more during stable conditions (PBLH < 400 m). -!!A variable tke threshold (TKEeps) is used since no hard-wired -!!value could be found to work best in all conditions. -!>\section gen_get_pblh GSD get_pblh General Algorithm -!> @{ - SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea,kzi) - - !--------------------------------------------------------------- - ! NOTES ON THE PBLH FORMULATION - ! - !The 1.5-theta-increase method defines PBL heights as the level at - !which the potential temperature first exceeds the minimum potential - !temperature within the boundary layer by 1.5 K. When applied to - !observed temperatures, this method has been shown to produce PBL- - !height estimates that are unbiased relative to profiler-based - !estimates (Nielsen-Gammon et al. 2008). However, their study did not - !include LLJs. Banta and Pichugina (2008) show that a TKE-based - !threshold is a good estimate of the PBL height in LLJs. Therefore, - !a hybrid definition is implemented that uses both methods, weighting - !the TKE-method more during stable conditions (PBLH < 400 m). - !A variable tke threshold (TKEeps) is used since no hard-wired - !value could be found to work best in all conditions. - !--------------------------------------------------------------- - - integer,intent(in) :: KTS,KTE - -#ifdef HARDCODE_VERTICAL -# define kts 1 -# define kte HARDCODE_VERTICAL -#endif - - real(kind_phys), intent(out) :: zi - real(kind_phys), intent(in) :: landsea - real(kind_phys), dimension(kts:kte), intent(in) :: thetav1D, qke1D, dz1D - real(kind_phys), dimension(kts:kte+1), intent(in) :: zw1D - !LOCAL VARS - real(kind_phys):: PBLH_TKE,qtke,qtkem1,wt,maxqke,TKEeps,minthv - real(kind_phys):: delt_thv !delta theta-v; dependent on land/sea point - real(kind_phys), parameter :: sbl_lim = 200. !upper limit of stable BL height (m). - real(kind_phys), parameter :: sbl_damp = 400. !transition length for blending (m). - integer :: I,J,K,kthv,ktke,kzi - - !Initialize KPBL (kzi) - kzi = 2 - - !> - FIND MIN THETAV IN THE LOWEST 200 M AGL - k = kts+1 - kthv = 1 - minthv = 9.E9 - DO WHILE (zw1D(k) .LE. 200.) - !DO k=kts+1,kte-1 - IF (minthv > thetav1D(k)) then - minthv = thetav1D(k) - kthv = k - ENDIF - k = k+1 - !IF (zw1D(k) .GT. sbl_lim) exit - ENDDO - - !> - FIND THETAV-BASED PBLH (BEST FOR DAYTIME). - zi=0. - k = kthv+1 - IF((landsea-1.5).GE.0)THEN - ! WATER - delt_thv = 1.0 - ELSE - ! LAND - delt_thv = 1.25 - ENDIF - - zi=0. - k = kthv+1 -! DO WHILE (zi .EQ. 0.) - DO k=kts+1,kte-1 - IF (thetav1D(k) .GE. (minthv + delt_thv))THEN - zi = zw1D(k) - dz1D(k-1)* & - & MIN((thetav1D(k)-(minthv + delt_thv))/ & - & MAX(thetav1D(k)-thetav1D(k-1),1E-6),1.0) - ENDIF - !k = k+1 - IF (k .EQ. kte-1) zi = zw1D(kts+1) !EXIT SAFEGUARD - IF (zi .NE. 0.0) exit - ENDDO - !print*,"IN GET_PBLH:",thsfc,zi - - !> - FOR STABLE BOUNDARY LAYERS, USE TKE METHOD TO COMPLEMENT THE - !! THETAV-BASED DEFINITION (WHEN THE THETA-V BASED PBLH IS BELOW ~0.5 KM). - !!THE TANH WEIGHTING FUNCTION WILL MAKE THE TKE-BASED DEFINITION NEGLIGIBLE - !!WHEN THE THETA-V-BASED DEFINITION IS ABOVE ~1 KM. - ktke = 1 - maxqke = MAX(Qke1D(kts),0.) - !Use 5% of tke max (Kosovic and Curry, 2000; JAS) - !TKEeps = maxtke/20. = maxqke/40. - TKEeps = maxqke/40. - TKEeps = MAX(TKEeps,0.02) !0.025) - PBLH_TKE=0. - - k = ktke+1 -! DO WHILE (PBLH_TKE .EQ. 0.) - DO k=kts+1,kte-1 - !QKE CAN BE NEGATIVE (IF CKmod == 0)... MAKE TKE NON-NEGATIVE. - qtke =MAX(Qke1D(k)/2.,0.) ! maximum TKE - qtkem1=MAX(Qke1D(k-1)/2.,0.) - IF (qtke .LE. TKEeps) THEN - PBLH_TKE = zw1D(k) - dz1D(k-1)* & - & 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,PBLH_TKE, Qke1D(k)/2., zw1D(kts+1) - ENDIF - !k = k+1 - IF (k .EQ. kte-1) PBLH_TKE = zw1D(kts+1) !EXIT SAFEGUARD - IF (PBLH_TKE .NE. 0.) exit - ENDDO - - !> - With TKE advection turned on, the TKE-based PBLH can be very large - !! in grid points with convective precipitation (> 8 km!), - !! so an artificial limit is imposed to not let PBLH_TKE exceed the - !!theta_v-based PBL height +/- 350 m. - !!This has no impact on 98-99% of the domain, but is the simplest patch - !!that adequately addresses these extremely large PBLHs. - PBLH_TKE = MIN(PBLH_TKE,zi+350.) - PBLH_TKE = MAX(PBLH_TKE,MAX(zi-350.,10.)) - - wt=.5*TANH((zi - sbl_lim)/sbl_damp) + .5 - IF (maxqke <= 0.05) THEN - !Cold pool situation - default to theta_v-based def - ELSE - !BLEND THE TWO PBLH TYPES HERE: - zi=PBLH_TKE*(1.-wt) + zi*wt - ENDIF - - !Compute KPBL (kzi) - DO k=kts+1,kte-1 - IF ( zw1D(k) >= zi) THEN - kzi = k-1 - exit - ENDIF - ENDDO - -#ifdef HARDCODE_VERTICAL -# undef kts -# undef kte -#endif - - END SUBROUTINE GET_PBLH -!> @} - -! ================================================================== -!>\ingroup gsd_mynn_edmf -!! This subroutine is the Dynamic Multi-Plume (DMP) Mass-Flux Scheme. -!! -!! dmp_mf() calculates the nonlocal turbulent transport from the dynamic -!! multiplume mass-flux scheme as well as the shallow-cumulus component of -!! the subgrid clouds. Note that this mass-flux scheme is called when the -!! namelist paramter \p bl_mynn_edmf is set to 1 (recommended). -!! -!! Much thanks to Kay Suslj of NASA-JPL for contributing the original version -!! of this mass-flux scheme. Considerable changes have been made from it's -!! original form. Some additions include: -!! -# scale-aware tapering as dx -> 0 -!! -# transport of TKE (extra namelist option) -!! -# Chaboureau-Bechtold cloud fraction & coupling to radiation (when icloud_bl > 0) -!! -# some extra limits for numerical stability -!! -!! This scheme remains under development, so consider it experimental code. -!! - SUBROUTINE DMP_mf( & - & kts,kte,dt,zw,dz,p,rho, & - & momentum_opt, & - & tke_opt, & - & scalar_opt, & - & u,v,w,th,thl,thv,tk, & - & qt,qv,qc,qke, & - & qnc,qni,qnwfa,qnifa,qnbca, & - & exner,vt,vq,sgm, & - & ust,flt,fltv,flq,flqv, & - & pblh,kpbl,dx,landsea,ts, & - ! outputs - updraft properties - & edmf_a,edmf_w, & - & edmf_qt,edmf_thl, & - & edmf_ent,edmf_qc, & - ! outputs - variables needed for solver - & s_aw,s_awthl,s_awqt, & - & s_awqv,s_awqc, & - & s_awu,s_awv,s_awqke, & - & s_awqnc,s_awqni, & - & s_awqnwfa,s_awqnifa, & - & s_awqnbca, & - & sub_thl,sub_sqv, & - & sub_u,sub_v, & - & det_thl,det_sqv,det_sqc, & - & det_u,det_v, & - ! chem/smoke - & nchem,chem1,s_awchem, & - & mix_chem, & - ! in/outputs - subgrid scale clouds - & qc_bl1d,cldfra_bl1d, & - & qc_bl1D_old,cldfra_bl1D_old, & - ! inputs - flags for moist arrays - & F_QC,F_QI, & - & F_QNC,F_QNI, & - & F_QNWFA,F_QNIFA,F_QNBCA, & - & Psig_shcu, & - ! output info - & maxwidth,ktop,maxmf,ztop, & - ! inputs for stochastic perturbations - & spp_pbl,rstoch_col ) - - ! inputs: - integer, intent(in) :: KTS,KTE,KPBL,momentum_opt,tke_opt,scalar_opt - -#ifdef HARDCODE_VERTICAL -# define kts 1 -# define kte HARDCODE_VERTICAL -#endif - -! Stochastic - integer, intent(in) :: spp_pbl - real(kind_phys), dimension(kts:kte) :: rstoch_col - - real(kind_phys),dimension(kts:kte), intent(in) :: & - &U,V,W,TH,THL,TK,QT,QV,QC, & - &exner,dz,THV,P,rho,qke,qnc,qni,qnwfa,qnifa,qnbca - real(kind_phys),dimension(kts:kte+1), intent(in) :: zw !height at full-sigma - real(kind_phys), intent(in) :: flt,fltv,flq,flqv,Psig_shcu, & - &landsea,ts,dx,dt,ust,pblh - logical, optional :: F_QC,F_QI,F_QNC,F_QNI,F_QNWFA,F_QNIFA,F_QNBCA - - ! outputs - updraft properties - real(kind_phys),dimension(kts:kte), intent(out) :: edmf_a,edmf_w, & - & edmf_qt,edmf_thl,edmf_ent,edmf_qc - !add one local edmf variable: - real(kind_phys),dimension(kts:kte) :: edmf_th - ! output - integer, intent(out) :: ktop - real(kind_phys), intent(out) :: maxmf,ztop,maxwidth - ! outputs - variables needed for solver - real(kind_phys),dimension(kts:kte+1) :: s_aw, & !sum ai*rho*wis_awphi - &s_awthl,s_awqt,s_awqv,s_awqc,s_awqnc,s_awqni, & - &s_awqnwfa,s_awqnifa,s_awqnbca,s_awu,s_awv, & - &s_awqke,s_aw2 - - real(kind_phys),dimension(kts:kte), intent(inout) :: & - &qc_bl1d,cldfra_bl1d,qc_bl1d_old,cldfra_bl1d_old - - integer, parameter :: nup=8, debug_mf=0 - real(kind_phys) :: nup2 - - !------------- local variables ------------------- - ! updraft properties defined on interfaces (k=1 is the top of the - ! first model layer - real(kind_phys),dimension(kts:kte+1,1:NUP) :: & - &UPW,UPTHL,UPQT,UPQC,UPQV, & - &UPA,UPU,UPV,UPTHV,UPQKE,UPQNC, & - &UPQNI,UPQNWFA,UPQNIFA,UPQNBCA - ! entrainment variables - real(kind_phys),dimension(kts:kte,1:NUP) :: ENT,ENTf - integer,dimension(kts:kte,1:NUP) :: ENTi - ! internal variables - integer :: K,I,k50 - real(kind_phys):: fltv2,wstar,qstar,thstar,sigmaW,sigmaQT, & - &sigmaTH,z0,pwmin,pwmax,wmin,wmax,wlv,Psig_w,maxw,maxqc,wpbl - real(kind_phys):: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,QNCn,QNIn, & - & QNWFAn,QNIFAn,QNBCAn, & - & Wn2,Wn,EntEXP,EntEXM,EntW,BCOEFF,THVkm1,THVk,Pk,rho_int - - ! w parameters - real(kind_phys), parameter :: & - &Wa=2./3., & - &Wb=0.002, & - &Wc=1.5 - - ! Lateral entrainment parameters ( L0=100 and ENT0=0.1) were taken from - ! Suselj et al (2013, jas). Note that Suselj et al (2014,waf) use L0=200 and ENT0=0.2. - real(kind_phys),parameter :: & - & L0=100., & - & ENT0=0.1 - - ! Parameters/variables for regulating plumes: - real(kind_phys), parameter :: Atot = 0.10 ! Maximum total fractional area of all updrafts - real(kind_phys), parameter :: lmax = 1000.! diameter of largest plume (absolute maximum, can be smaller) - real(kind_phys), parameter :: lmin = 300. ! diameter of smallest plume (absolute minimum, can be larger) - real(kind_phys), parameter :: dlmin = 0. ! delta increase in the diameter of smallest plume (large fltv) - real(kind_phys) :: minwidth ! actual width of smallest plume - real(kind_phys) :: dl ! variable increment of plume size - real(kind_phys), parameter :: dcut = 1.2 ! max diameter of plume to parameterize relative to dx (km) - real(kind_phys):: d != -2.3 to -1.7 ;=-1.9 in Neggers paper; power law exponent for number density (N=Cl^d). - ! Note that changing d to -2.0 makes each size plume equally contribute to the total coverage of all plumes. - ! Note that changing d to -1.7 doubles the area coverage of the largest plumes relative to the smallest plumes. - real(kind_phys):: cn,c,l,n,an2,hux,wspd_pbl,cloud_base,width_flx - - ! chem/smoke - integer, intent(in) :: nchem - real(kind_phys),dimension(:, :) :: chem1 - real(kind_phys),dimension(kts:kte+1, nchem) :: s_awchem - real(kind_phys),dimension(nchem) :: chemn - real(kind_phys),dimension(kts:kte+1,1:NUP, nchem) :: UPCHEM - integer :: ic - real(kind_phys),dimension(kts:kte+1, nchem) :: edmf_chem - logical, intent(in) :: mix_chem - - !JOE: add declaration of ERF - real(kind_phys):: ERF - - logical :: superadiabatic - - ! VARIABLES FOR CHABOUREAU-BECHTOLD CLOUD FRACTION - real(kind_phys),dimension(kts:kte), intent(inout) :: vt, vq, sgm - real(kind_phys):: sigq,xl,rsl,cpm,a,qmq,mf_cf,Aup,Q1,diffqt,qsat_tk,& - Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9,satvp,rhgrid, & - Ac_mf,Ac_strat,qc_mf - real(kind_phys), parameter :: cf_thresh = 0.5 ! only overwrite stratus CF less than this value - - ! Variables for plume interpolation/saturation check - real(kind_phys),dimension(kts:kte) :: exneri,dzi,rhoz - real(kind_phys):: THp, QTp, QCp, QCs, esat, qsl - real(kind_phys):: csigma,acfac,ac_wsp - - !plume overshoot - integer :: overshoot - real(kind_phys):: bvf, Frz, dzp - - !Flux limiter: not let mass-flux of heat between k=1&2 exceed (fluxportion)*(surface heat flux). - !This limiter makes adjustments to the entire column. - real(kind_phys):: adjustment, flx1, flt2 - real(kind_phys), parameter :: fluxportion=0.75 ! set liberally, so has minimal impact. Note that - ! 0.5 starts to have a noticeable impact - ! over land (decrease maxMF by 10-20%), but no impact over water. - - !Subsidence - real(kind_phys),dimension(kts:kte) :: sub_thl,sub_sqv,sub_u,sub_v, & !tendencies due to subsidence - det_thl,det_sqv,det_sqc,det_u,det_v, & !tendencied due to detrainment - envm_a,envm_w,envm_thl,envm_sqv,envm_sqc, & - envm_u,envm_v !environmental variables defined at middle of layer - real(kind_phys),dimension(kts:kte+1) :: envi_a,envi_w !environmental variables defined at model interface - real(kind_phys):: temp,sublim,qc_ent,qv_ent,qt_ent,thl_ent,detrate, & - detrateUV,oow,exc_fac,aratio,detturb,qc_grid,qc_sgs, & - qc_plume,exc_heat,exc_moist,tk_int,tvs - real(kind_phys), parameter :: Cdet = 1./45. - real(kind_phys), 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 - !gentle environmental subsidence. 1.0 assumes all upward vertical velocity in the mass-flux scheme - !is compensated by "gentle" environmental subsidence. - real(kind_phys), parameter :: Csub=0.25 - - !Factor for the pressure gradient effects on momentum transport - real(kind_phys), parameter :: pgfac = 0.00 ! Zhang and Wu showed 0.4 is more appropriate for lower troposphere - real(kind_phys):: Uk,Ukm1,Vk,Vkm1,dxsa - -! check the inputs -! print *,'dt',dt -! print *,'dz',dz -! print *,'u',u -! print *,'v',v -! print *,'thl',thl -! print *,'qt',qt -! print *,'ust',ust -! print *,'flt',flt -! print *,'flq',flq -! print *,'pblh',pblh - -! Initialize individual updraft properties - UPW=0. - UPTHL=0. - UPTHV=0. - UPQT=0. - UPA=0. - UPU=0. - UPV=0. - UPQC=0. - UPQV=0. - UPQKE=0. - UPQNC=0. - UPQNI=0. - UPQNWFA=0. - UPQNIFA=0. - UPQNBCA=0. - if ( mix_chem ) then - UPCHEM(kts:kte+1,1:NUP,1:nchem)=0.0 - endif - - ENT=0.001 -! Initialize mean updraft properties - edmf_a =0. - edmf_w =0. - edmf_qt =0. - edmf_thl=0. - edmf_ent=0. - edmf_qc =0. - if ( mix_chem ) then - edmf_chem(kts:kte+1,1:nchem) = 0.0 - endif - -! Initialize the variables needed for implicit solver - s_aw=0. - s_awthl=0. - s_awqt=0. - s_awqv=0. - s_awqc=0. - s_awu=0. - s_awv=0. - s_awqke=0. - s_awqnc=0. - s_awqni=0. - s_awqnwfa=0. - s_awqnifa=0. - s_awqnbca=0. - if ( mix_chem ) then - s_awchem(kts:kte+1,1:nchem) = 0.0 - endif - -! Initialize explicit tendencies for subsidence & detrainment - sub_thl = 0. - sub_sqv = 0. - sub_u = 0. - sub_v = 0. - det_thl = 0. - det_sqv = 0. - det_sqc = 0. - det_u = 0. - det_v = 0. - nup2 = nup !start with nup, but set to zero if activation criteria fails - - ! Taper off MF scheme when significant resolved-scale motions - ! are present This function needs to be asymetric... - maxw = 0.0 - cloud_base = 9000.0 - do k=1,kte-1 - if (zw(k) > pblh + 500.) exit - - wpbl = w(k) - if (w(k) < 0.)wpbl = 2.*w(k) - maxw = max(maxw,abs(wpbl)) - - !Find highest k-level below 50m AGL - if (ZW(k)<=50.)k50=k - - !Search for cloud base - qc_sgs = max(qc(k), qc_bl1d(k)) - if (qc_sgs> 1E-5 .and. (cldfra_bl1d(k) .ge. 0.5) .and. cloud_base == 9000.0) then - cloud_base = 0.5*(ZW(k)+ZW(k+1)) - endif - enddo - - !do nothing for small w (< 1 m/s), but linearly taper off for w > 1.0 m/s - maxw = max(0.,maxw - 1.0) - Psig_w = max(0.0, 1.0 - maxw) - Psig_w = min(Psig_w, Psig_shcu) - - !Completely shut off MF scheme for strong resolved-scale vertical velocities. - fltv2 = fltv - if(Psig_w == 0.0 .and. fltv > 0.0) fltv2 = -1.*fltv - - ! If surface buoyancy is positive we do integration, otherwise no. - ! Also, ensure that it is at least slightly superadiabatic up through 50 m - superadiabatic = .false. - if ((landsea-1.5).ge.0) then - hux = -0.001 ! WATER ! dT/dz must be < - 0.1 K per 100 m. - else - hux = -0.005 ! LAND ! dT/dz must be < - 0.5 K per 100 m. - endif - tvs = ts*(1.0+p608*qv(kts)) - do k=1,max(1,k50-1) !use "-1" because k50 used interface heights (zw). - if (k == 1) then - if ((thv(k)-tvs)/(0.5*dz(k)) < hux) then - superadiabatic = .true. - else - superadiabatic = .false. - exit - endif - else - if ((thv(k)-thv(k-1))/(0.5*(dz(k)+dz(k-1))) < hux) then - superadiabatic = .true. - else - superadiabatic = .false. - exit - endif - endif - enddo - - ! Determine the numer of updrafts/plumes in the grid column: - ! Some of these criteria may be a little redundant but useful for bullet-proofing. - ! (1) largest plume = 1.2 * dx. - ! (2) Apply a scale-break, assuming no plumes with diameter larger than 1.1*PBLH can exist. - ! (3) max plume size beneath clouds deck approx = 0.5 * cloud_base. - ! (4) add wspd-dependent limit, when plume model breaks down. (hurricanes) - ! (5) limit to reduce max plume sizes in weakly forced conditions. This is only - ! meant to "soften" the activation of the mass-flux scheme. - ! Criteria (1) - maxwidth = min(dx*dcut, lmax) - !Criteria (2) - maxwidth = min(maxwidth, 1.1_kind_phys*PBLH) - ! Criteria (3) - if ((landsea-1.5) .lt. 0) then !land - maxwidth = MIN(maxwidth, 0.5_kind_phys*cloud_base) - else !water - maxwidth = MIN(maxwidth, 0.9_kind_phys*cloud_base) - endif - ! Criteria (4) - wspd_pbl=SQRT(MAX(u(kts)**2 + v(kts)**2, 0.01_kind_phys)) - !Note: area fraction (acfac) is modified below - ! Criteria (5) - only a function of flt (not fltv) - if ((landsea-1.5).LT.0) then !land - width_flx = MAX(MIN(1000.*(0.6*tanh((fltv - 0.040)/0.04) + .5),1000._kind_phys), 0._kind_phys) - else !water - width_flx = MAX(MIN(1000.*(0.6*tanh((fltv - 0.007)/0.02) + .5),1000._kind_phys), 0._kind_phys) - endif - maxwidth = MIN(maxwidth, width_flx) - minwidth = lmin - !allow min plume size to increase in large flux conditions (eddy diffusivity should be - !large enough to handle the representation of small plumes). - if (maxwidth .ge. (lmax - 1.0) .and. fltv .gt. 0.2)minwidth = lmin + dlmin*min((fltv-0.2)/0.3, 1._kind_phys) - - if (maxwidth .le. minwidth) then ! deactivate MF component - nup2 = 0 - maxwidth = 0.0 - endif - - ! Initialize values for 2d output fields: - ktop = 0 - ztop = 0.0 - maxmf= 0.0 - -!Begin plume processing if passes criteria -if ( fltv2 > 0.002 .AND. (maxwidth > minwidth) .AND. superadiabatic) then - - ! Find coef C for number size density N - cn = 0. - d =-1.9 !set d to value suggested by Neggers 2015 (JAMES). - dl = (maxwidth - minwidth)/real(nup-1,kind=kind_phys) - do i=1,NUP - ! diameter of plume - l = minwidth + dl*real(i-1) - cn = cn + l**d * (l*l)/(dx*dx) * dl ! sum fractional area of each plume - enddo - C = Atot/cn !Normalize C according to the defined total fraction (Atot) - - ! Make updraft area (UPA) a function of the buoyancy flux - acfac = .5*tanh((fltv2 - 0.02)/0.05) + .5 - - !add a windspeed-dependent adjustment to acfac that tapers off - !the mass-flux scheme linearly above sfc wind speeds of 10 m/s. - !Note: this effect may be better represented by an increase in - !entrainment rate for high wind consitions (more ambient turbulence). - if (wspd_pbl .le. 10.) then - ac_wsp = 1.0 - else - ac_wsp = 1.0 - min((wspd_pbl - 10.0)/15., 1.0) - endif - acfac = acfac * ac_wsp - - ! Find the portion of the total fraction (Atot) of each plume size: - An2 = 0. - do i=1,NUP - ! diameter of plume - l = minwidth + dl*real(i-1) - N = C*l**d ! number density of plume n - UPA(1,i) = N*l*l/(dx*dx) * dl ! fractional area of plume n - - UPA(1,i) = UPA(1,i)*acfac - An2 = An2 + UPA(1,i) ! total fractional area of all plumes - !print*," plume size=",l,"; area=",UPA(1,I),"; total=",An2 - end do - - ! set initial conditions for updrafts - z0=50. - pwmin=0.1 ! was 0.5 - pwmax=0.4 ! was 3.0 - - wstar=max(1.E-2,(gtr*fltv2*pblh)**(onethird)) - qstar=max(flq,1.0E-5)/wstar - thstar=flt/wstar - - if ((landsea-1.5) .ge. 0) then - csigma = 1.34 ! WATER - else - csigma = 1.34 ! LAND - endif - - if (env_subs) then - exc_fac = 0.0 - else - if ((landsea-1.5).GE.0) then - !water: increase factor to compensate for decreased pwmin/pwmax - exc_fac = 0.58*4.0 - else - !land: no need to increase factor - already sufficiently large superadiabatic layers - exc_fac = 0.58 - endif - endif - !decrease excess for large wind speeds - exc_fac = exc_fac * ac_wsp - - !Note: sigmaW is typically about 0.5*wstar - sigmaW =csigma*wstar*(z0/pblh)**(onethird)*(1 - 0.8*z0/pblh) - sigmaQT=csigma*qstar*(z0/pblh)**(onethird) - sigmaTH=csigma*thstar*(z0/pblh)**(onethird) - - !Note: Given the pwmin & pwmax set above, these max/mins are - ! rarely exceeded. - wmin=MIN(sigmaW*pwmin,0.1) - wmax=MIN(sigmaW*pwmax,0.5) - - !SPECIFY SURFACE UPDRAFT PROPERTIES AT MODEL INTERFACE BETWEEN K = 1 & 2 - do i=1,NUP - wlv=wmin+(wmax-wmin)/NUP2*(i-1) - - !SURFACE UPDRAFT VERTICAL VELOCITY - UPW(1,I)=wmin + real(i)/real(NUP)*(wmax-wmin) - UPU(1,I)=(U(KTS)*DZ(KTS+1)+U(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) - UPV(1,I)=(V(KTS)*DZ(KTS+1)+V(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) - UPQC(1,I)=0.0 - !UPQC(1,I)=(QC(KTS)*DZ(KTS+1)+QC(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) - - exc_heat = exc_fac*UPW(1,I)*sigmaTH/sigmaW - UPTHV(1,I)=(THV(KTS)*DZ(KTS+1)+THV(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) & - & + exc_heat - UPTHL(1,I)=(THL(KTS)*DZ(KTS+1)+THL(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) & - & + exc_heat - - !calculate exc_moist by use of surface fluxes - exc_moist=exc_fac*UPW(1,I)*sigmaQT/sigmaW - UPQT(1,I)=(QT(KTS)*DZ(KTS+1)+QT(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))& - & +exc_moist - - UPQKE(1,I)=(QKE(KTS)*DZ(KTS+1)+QKE(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) - UPQNC(1,I)=(QNC(KTS)*DZ(KTS+1)+QNC(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) - UPQNI(1,I)=(QNI(KTS)*DZ(KTS+1)+QNI(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) - UPQNWFA(1,I)=(QNWFA(KTS)*DZ(KTS+1)+QNWFA(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) - UPQNIFA(1,I)=(QNIFA(KTS)*DZ(KTS+1)+QNIFA(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) - UPQNBCA(1,I)=(QNBCA(KTS)*DZ(KTS+1)+QNBCA(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) - enddo - - if ( mix_chem ) then - do i=1,NUP - do ic = 1,nchem - UPCHEM(1,i,ic)=(chem1(KTS,ic)*DZ(KTS+1)+chem1(KTS+1,ic)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) - enddo - enddo - endif - - !Initialize environmental variables which can be modified by detrainment - envm_thl(kts:kte)=THL(kts:kte) - envm_sqv(kts:kte)=QV(kts:kte) - envm_sqc(kts:kte)=QC(kts:kte) - envm_u(kts:kte)=U(kts:kte) - envm_v(kts:kte)=V(kts:kte) - do k=kts,kte-1 - rhoz(k) = (rho(k)*dz(k+1)+rho(k+1)*dz(k))/(dz(k+1)+dz(k)) - enddo - rhoz(kte) = rho(kte) - - !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.) - - ! do integration updraft - do i=1,NUP - QCn = 0. - overshoot = 0 - l = minwidth + dl*real(i-1) ! diameter of plume - do k=kts+1,kte-1 - !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),0.9)*l) - - !Entrainment from Negggers (2015, JAMES) - !ENT(k,i) = 0.02*l**-0.35 - 0.0009 - !ENT(k,i) = 0.04*l**-0.50 - 0.0009 !more plume diversity - !ENT(k,i) = 0.04*l**-0.495 - 0.0009 !"neg1+" - - !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 - - !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 - ENDIF - - !SPP - ENT(k,i) = ENT(k,i) * (1.0 - rstoch_col(k)) - - 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)) - EntExm= EntExp*0.3333 !reduce entrainment for momentum - 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.-EntExm) + U(k)*EntExm + dxsa*pgfac*(Uk - Ukm1) - Vn =UPV(k-1,I) *(1.-EntExm) + V(k)*EntExm + 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 - QNWFAn=UPQNWFA(k-1,I)*(1.-EntExp) + QNWFA(k)*EntExp - QNIFAn=UPQNIFA(k-1,I)*(1.-EntExp) + QNIFA(k)*EntExp - QNBCAn=UPQNBCA(k-1,I)*(1.-EntExp) + QNBCA(k)*EntExp - - !capture the updated qc, qt & thl modified by entranment alone, - !since they will be modified later if condensation occurs. - qc_ent = QCn - qt_ent = QTn - thl_ent = THLn - - ! Exponential Entrainment: - !EntExp= exp(-ENT(K,I)*(ZW(k)-ZW(k-1))) - !QTn =QT(K) *(1-EntExp)+UPQT(K-1,I)*EntExp - !THLn=THL(K)*(1-EntExp)+UPTHL(K-1,I)*EntExp - !Un =U(K) *(1-EntExp)+UPU(K-1,I)*EntExp - !Vn =V(K) *(1-EntExp)+UPV(K-1,I)*EntExp - !QKEn=QKE(k)*(1-EntExp)+UPQKE(K-1,I)*EntExp - - if ( mix_chem ) then - do ic = 1,nchem - ! Exponential Entrainment: - !chemn(ic) = chem(k,ic)*(1-EntExp)+UPCHEM(K-1,I,ic)*EntExp - ! Linear entrainment: - chemn(ic)=UPCHEM(k-1,i,ic)*(1.-EntExp) + chem1(k,ic)*EntExp - enddo - endif - - ! Define pressure at model interface - Pk =(P(k)*DZ(k+1)+P(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) - ! Compute 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*(0.5*(THVn+UPTHV(k-1,I))/THV(k-1) - 1.0) - B=grav*(THVn/THVk - 1.0) - IF(B>0.)THEN - BCOEFF = 0.15 !w typically stays < 2.5, so doesnt hit the limits nearly as much - ELSE - BCOEFF = 0.2 !0.33 - ENDIF - - ! Original StEM with exponential entrainment - !EntW=exp(-2.*(Wb+Wc*ENT(K,I))*(ZW(k)-ZW(k-1))) - !Wn2=UPW(K-1,I)**2*EntW + (1.-EntW)*0.5*Wa*B/(Wb+Wc*ENT(K,I)) - ! Original StEM with linear entrainment - !Wn2=UPW(K-1,I)**2*(1.-EntExp) + EntExp*0.5*Wa*B/(Wb+Wc*ENT(K,I)) - !Wn2=MAX(Wn2,0.0) - !WA: TEMF form -! IF (B>0.0 .AND. UPW(K-1,I) < 0.2 ) THEN - 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 - !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 > UPW(K-1,I) + MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0) ) THEN - Wn = UPW(K-1,I) + MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0) - ENDIF - !Add symmetrical max decrease in w - IF(Wn < UPW(K-1,I) - MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0) ) THEN - 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) - - !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 - NUP2=0 - exit - ENDIF - - IF (debug_mf == 1) THEN - IF (Wn .GE. 3.0) THEN - ! surface values - print *," **** SUSPICIOUSLY LARGE W:" - print *,' QCn:',QCn,' ENT=',ENT(k,i),' Nup2=',Nup2 - print *,'pblh:',pblh,' Wn:',Wn,' UPW(k-1)=',UPW(K-1,I) - print *,'K=',k,' B=',B,' dz=',ZW(k)-ZW(k-1) - ENDIF - ENDIF - - !Allow strongly forced plumes to overshoot if KE is sufficient - IF (Wn <= 0.0 .AND. overshoot == 0) THEN - overshoot = 1 - IF ( THVk-THVkm1 .GT. 0.0 ) THEN - bvf = SQRT( gtr*(THVk-THVkm1)/dz(k) ) - !vertical Froude number - Frz = UPW(K-1,I)/(bvf*dz(k)) - !IF ( Frz >= 0.5 ) Wn = MIN(Frz,1.0)*UPW(K-1,I) - dzp = dz(k)*MAX(MIN(Frz,1.0),0.0) ! portion of highest layer the plume penetrates - ENDIF - ELSE - dzp = dz(k) - ENDIF - - !minimize the plume penetratration in stratocu-topped PBL - !IF (fltv2 < 0.06) THEN - ! IF(ZW(k+1) >= pblh-200. .AND. qc(k) > 1e-5 .AND. I > 4) Wn=0. - !ENDIF - - !Modify environment variables (representative of the model layer - envm*) - !following the updraft dynamical detrainment of Asai and Kasahara (1967, JAS). - !Reminder: w is limited to be non-negative (above) - aratio = MIN(UPA(K-1,I)/(1.-UPA(K-1,I)), 0.5) !limit should never get hit - detturb = 0.00008 - oow = -0.060/MAX(1.0,(0.5*(Wn+UPW(K-1,I)))) !coef for dynamical detrainment rate - detrate = MIN(MAX(oow*(Wn-UPW(K-1,I))/dz(k), detturb), .0002) ! dynamical detrainment rate (m^-1) - detrateUV= MIN(MAX(oow*(Wn-UPW(K-1,I))/dz(k), detturb), .0001) ! dynamical detrainment rate (m^-1) - envm_thl(k)=envm_thl(k) + (0.5*(thl_ent + UPTHL(K-1,I)) - thl(k))*detrate*aratio*MIN(dzp,dzpmax) - qv_ent = 0.5*(MAX(qt_ent-qc_ent,0.) + MAX(UPQT(K-1,I)-UPQC(K-1,I),0.)) - envm_sqv(k)=envm_sqv(k) + (qv_ent-QV(K))*detrate*aratio*MIN(dzp,dzpmax) - IF (UPQC(K-1,I) > 1E-8) THEN - IF (QC(K) > 1E-6) THEN - qc_grid = QC(K) - ELSE - qc_grid = cldfra_bl1d(k)*qc_bl1d(K) - ENDIF - envm_sqc(k)=envm_sqc(k) + MAX(UPA(K-1,I)*0.5*(QCn + UPQC(K-1,I)) - qc_grid, 0.0)*detrate*aratio*MIN(dzp,dzpmax) - ENDIF - envm_u(k) =envm_u(k) + (0.5*(Un + UPU(K-1,I)) - U(K))*detrateUV*aratio*MIN(dzp,dzpmax) - envm_v(k) =envm_v(k) + (0.5*(Vn + UPV(K-1,I)) - V(K))*detrateUV*aratio*MIN(dzp,dzpmax) - - IF (Wn > 0.) THEN - !Update plume variables at current k index - UPW(K,I)=Wn !sqrt(Wn2) - UPTHV(K,I)=THVn - UPTHL(K,I)=THLn - UPQT(K,I)=QTn - UPQC(K,I)=QCn - UPU(K,I)=Un - UPV(K,I)=Vn - UPQKE(K,I)=QKEn - UPQNC(K,I)=QNCn - UPQNI(K,I)=QNIn - UPQNWFA(K,I)=QNWFAn - UPQNIFA(K,I)=QNIFAn - UPQNBCA(K,I)=QNBCAn - UPA(K,I)=UPA(K-1,I) - IF ( mix_chem ) THEN - do ic = 1,nchem - UPCHEM(k,I,ic) = chemn(ic) - enddo - ENDIF - ktop = MAX(ktop,k) - ELSE - exit !exit k-loop - END IF - ENDDO - - IF (debug_mf == 1) THEN - IF (MAXVAL(UPW(:,I)) > 10.0 .OR. MINVAL(UPA(:,I)) < 0.0 .OR. & - MAXVAL(UPA(:,I)) > Atot .OR. NUP2 > 10) THEN - ! surface values - print *,'flq:',flq,' fltv:',fltv2,' Nup2=',Nup2 - print *,'pblh:',pblh,' wstar:',wstar,' ktop=',ktop - print *,'sigmaW=',sigmaW,' sigmaTH=',sigmaTH,' sigmaQT=',sigmaQT - ! means - print *,'u:',u - print *,'v:',v - print *,'thl:',thl - print *,'UPA:',UPA(:,I) - print *,'UPW:',UPW(:,I) - print *,'UPTHL:',UPTHL(:,I) - print *,'UPQT:',UPQT(:,I) - print *,'ENT:',ENT(:,I) - ENDIF - ENDIF - ENDDO -ELSE - !At least one of the conditions was not met for activating the MF scheme. - NUP2=0. -END IF !end criteria check for mass-flux scheme - -ktop=MIN(ktop,KTE-1) -IF (ktop == 0) THEN - ztop = 0.0 -ELSE - ztop=zw(ktop) -ENDIF - -IF (nup2 > 0) THEN - !Calculate the fluxes for each variable - !All s_aw* variable are == 0 at k=1 - DO i=1,NUP - DO k=KTS,KTE-1 - s_aw(k+1) = s_aw(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*Psig_w - s_awthl(k+1)= s_awthl(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPTHL(K,i)*Psig_w - s_awqt(k+1) = s_awqt(k+1) + rhoz(k)*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 preserved 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) + rhoz(k)*UPA(K,i)*UPW(K,i)*qc_plume*Psig_w - s_awqv(k+1) = s_awqt(k+1) - s_awqc(k+1) - ENDDO - ENDDO - !momentum - if (momentum_opt > 0) then - do i=1,nup - do k=kts,kte-1 - s_awu(k+1) = s_awu(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPU(K,i)*Psig_w - s_awv(k+1) = s_awv(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPV(K,i)*Psig_w - enddo - enddo - endif - !tke - if (tke_opt > 0) then - do i=1,nup - do k=kts,kte-1 - s_awqke(k+1)= s_awqke(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQKE(K,i)*Psig_w - enddo - enddo - endif - !chem - if ( mix_chem ) then - do k=kts,kte - do i=1,nup - do ic = 1,nchem - s_awchem(k+1,ic) = s_awchem(k+1,ic) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPCHEM(K,i,ic)*Psig_w - enddo - enddo - enddo - endif - - if (scalar_opt > 0) then - do k=kts,kte - do I=1,nup - s_awqnc(k+1) = s_awqnc(K+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQNC(K,i)*Psig_w - s_awqni(k+1) = s_awqni(K+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQNI(K,i)*Psig_w - s_awqnwfa(k+1)= s_awqnwfa(K+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQNWFA(K,i)*Psig_w - s_awqnifa(k+1)= s_awqnifa(K+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQNIFA(K,i)*Psig_w - s_awqnbca(k+1)= s_awqnbca(K+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQNBCA(K,i)*Psig_w - enddo - enddo - endif - - !Flux limiter: Check ratio of heat flux at top of first model layer - !and at the surface. Make sure estimated flux out of the top of the - !layer is < fluxportion*surface_heat_flux - IF (s_aw(kts+1) /= 0.) THEN - dzi(kts) = 0.5*(DZ(kts)+DZ(kts+1)) !dz centered at model interface - flx1 = MAX(s_aw(kts+1)*(TH(kts)-TH(kts+1))/dzi(kts),1.0e-5) - ELSE - flx1 = 0.0 - !print*,"ERROR: s_aw(kts+1) == 0, NUP=",NUP," NUP2=",NUP2,& - ! " superadiabatic=",superadiabatic," KTOP=",KTOP - ENDIF - adjustment=1.0 - flt2=max(flt,0.0) !need because activation is now based on fltv, not flt - !Print*,"Flux limiter in MYNN-EDMF, adjustment=",fluxportion*flt/dz(kts)/flx1 - !Print*,"flt/dz=",flt/dz(kts)," flx1=",flx1," s_aw(kts+1)=",s_aw(kts+1) - IF (flx1 > fluxportion*flt2/dz(kts) .AND. flx1>0.0) THEN - adjustment= fluxportion*flt2/dz(kts)/flx1 - s_aw = s_aw*adjustment - s_awthl = s_awthl*adjustment - s_awqt = s_awqt*adjustment - s_awqc = s_awqc*adjustment - s_awqv = s_awqv*adjustment - s_awqnc = s_awqnc*adjustment - s_awqni = s_awqni*adjustment - s_awqnwfa = s_awqnwfa*adjustment - s_awqnifa = s_awqnifa*adjustment - s_awqnbca = s_awqnbca*adjustment - IF (momentum_opt > 0) THEN - s_awu = s_awu*adjustment - s_awv = s_awv*adjustment - ENDIF - IF (tke_opt > 0) THEN - s_awqke= s_awqke*adjustment - ENDIF - IF ( mix_chem ) THEN - s_awchem = s_awchem*adjustment - ENDIF - UPA = UPA*adjustment - ENDIF - !Print*,"adjustment=",adjustment," fluxportion=",fluxportion," flt=",flt - - !Calculate mean updraft properties for output: - !all edmf_* variables at k=1 correspond to the interface at top of first model layer - do k=kts,kte-1 - do I=1,nup - 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) - enddo - enddo - do k=kts,kte-1 - !Note that only edmf_a is multiplied by Psig_w. This takes care of the - !scale-awareness of the subsidence below: - if (edmf_a(k)>0.) then - edmf_w(k)=edmf_w(k)/edmf_a(k) - edmf_qt(k)=edmf_qt(k)/edmf_a(k) - edmf_thl(k)=edmf_thl(k)/edmf_a(k) - edmf_ent(k)=edmf_ent(k)/edmf_a(k) - edmf_qc(k)=edmf_qc(k)/edmf_a(k) - edmf_a(k)=edmf_a(k)*Psig_w - !FIND MAXIMUM MASS-FLUX IN THE COLUMN: - if(edmf_a(k)*edmf_w(k) > maxmf) maxmf = edmf_a(k)*edmf_w(k) - endif - enddo ! end k - - !smoke/chem - if ( mix_chem ) then - do k=kts,kte-1 - do I=1,nup - do ic = 1,nchem - edmf_chem(k,ic) = edmf_chem(k,ic) + rhoz(k)*UPA(K,I)*UPCHEM(k,i,ic) - enddo - enddo - enddo - do k=kts,kte-1 - if (edmf_a(k)>0.) then - do ic = 1,nchem - edmf_chem(k,ic) = edmf_chem(k,ic)/edmf_a(k) - enddo - endif - enddo ! end k - endif - - !Calculate the effects environmental subsidence. - !All envi_*variables are valid at the interfaces, like the edmf_* variables - IF (env_subs) THEN - DO k=kts+1,kte-1 - !First, smooth the profiles of w & a, since sharp vertical gradients - !in plume variables are not likely extended to env variables - !Note1: w is treated as negative further below - !Note2: both w & a will be transformed into env variables further below - envi_w(k) = onethird*(edmf_w(k-1)+edmf_w(k)+edmf_w(k+1)) - envi_a(k) = onethird*(edmf_a(k-1)+edmf_a(k)+edmf_a(k+1))*adjustment - ENDDO - !define env variables at k=1 (top of first model layer) - envi_w(kts) = edmf_w(kts) - envi_a(kts) = edmf_a(kts) - !define env variables at k=kte - envi_w(kte) = 0.0 - envi_a(kte) = edmf_a(kte) - !define env variables at k=kte+1 - envi_w(kte+1) = 0.0 - envi_a(kte+1) = edmf_a(kte) - !Add limiter for very long time steps (i.e. dt > 300 s) - !Note that this is not a robust check - only for violations in - ! the first model level. - IF (envi_w(kts) > 0.9*DZ(kts)/dt) THEN - sublim = 0.9*DZ(kts)/dt/envi_w(kts) - ELSE - sublim = 1.0 - ENDIF - !Transform w & a into env variables - DO k=kts,kte - temp=envi_a(k) - envi_a(k)=1.0-temp - envi_w(k)=csub*sublim*envi_w(k)*temp/(1.-temp) - ENDDO - !calculate tendencies from subsidence and detrainment valid at the middle of - !each model layer. The lowest model layer uses an assumes w=0 at the surface. - dzi(kts) = 0.5*(dz(kts)+dz(kts+1)) - sub_thl(kts)= 0.5*envi_w(kts)*envi_a(kts)* & - (rho(kts+1)*thl(kts+1)-rho(kts)*thl(kts))/dzi(kts)/rhoz(k) - sub_sqv(kts)= 0.5*envi_w(kts)*envi_a(kts)* & - (rho(kts+1)*qv(kts+1)-rho(kts)*qv(kts))/dzi(kts)/rhoz(k) - DO k=kts+1,kte-1 - dzi(k) = 0.5*(dz(k)+dz(k+1)) - sub_thl(k)= 0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * & - (rho(k+1)*thl(k+1)-rho(k)*thl(k))/dzi(k)/rhoz(k) - sub_sqv(k)= 0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * & - (rho(k+1)*qv(k+1)-rho(k)*qv(k))/dzi(k)/rhoz(k) - ENDDO - - DO k=KTS,KTE-1 - det_thl(k)=Cdet*(envm_thl(k)-thl(k))*envi_a(k)*Psig_w - 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)* & - (rho(kts+1)*u(kts+1)-rho(kts)*u(kts))/dzi(kts)/rhoz(k) - sub_v(kts)=0.5*envi_w(kts)*envi_a(kts)* & - (rho(kts+1)*v(kts+1)-rho(kts)*v(kts))/dzi(kts)/rhoz(k) - DO k=kts+1,kte-1 - sub_u(k)=0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * & - (rho(k+1)*u(k+1)-rho(k)*u(k))/dzi(k)/rhoz(k) - sub_v(k)=0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * & - (rho(k+1)*v(k+1)-rho(k)*v(k))/dzi(k)/rhoz(k) - ENDDO - - DO k=KTS,KTE-1 - det_u(k) = Cdet*(envm_u(k)-u(k))*envi_a(k)*Psig_w - det_v(k) = Cdet*(envm_v(k)-v(k))*envi_a(k)*Psig_w - ENDDO - ENDIF - ENDIF !end subsidence/env detranment - - !First, compute exner, plume theta, and dz centered at interface - !Here, k=1 is the top of the first model layer. These values do not - !need to be defined at k=kte (unused level). - DO K=KTS,KTE-1 - exneri(k) = (exner(k)*dz(k+1)+exner(k+1)*dz(k))/(dz(k+1)+dz(k)) - edmf_th(k)= edmf_thl(k) + xlvcp/exneri(k)*edmf_qc(K) - dzi(k) = 0.5*(dz(k)+dz(k+1)) - ENDDO - -!JOE: ADD CLDFRA_bl1d, qc_bl1d. Note that they have already been defined in -! mym_condensation. Here, a shallow-cu component is added, but no cumulus -! clouds can be added at k=1 (start loop at k=2). - do k=kts+1,kte-2 - if (k > KTOP) exit - if(0.5*(edmf_qc(k)+edmf_qc(k-1))>0.0 .and. (cldfra_bl1d(k) < cf_thresh))THEN - !interpolate plume quantities to mass levels - Aup = (edmf_a(k)*dzi(k-1)+edmf_a(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) - THp = (edmf_th(k)*dzi(k-1)+edmf_th(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) - QTp = (edmf_qt(k)*dzi(k-1)+edmf_qt(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) - !convert TH to T -! t = THp*exner(k) - !SATURATED VAPOR PRESSURE - esat = esat_blend(tk(k)) - !SATURATED SPECIFIC HUMIDITY - qsl=ep_2*esat/max(1.e-7,(p(k)-ep_3*esat)) - - !condensed liquid in the plume on mass levels - if (edmf_qc(k)>0.0 .and. edmf_qc(k-1)>0.0) then - QCp = (edmf_qc(k)*dzi(k-1)+edmf_qc(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) - else - QCp = max(edmf_qc(k),edmf_qc(k-1)) - endif - - !COMPUTE CLDFRA & QC_BL FROM MASS-FLUX SCHEME and recompute vt & vq - xl = xl_blend(tk(k)) ! obtain blended heat capacity - qsat_tk = qsat_blend(tk(k),p(k)) ! get saturation water vapor mixing ratio - ! at t and p - rsl = xl*qsat_tk / (r_v*tk(k)**2) ! slope of C-C curve at t (abs temp) - ! CB02, Eqn. 4 - cpm = cp + qt(k)*cpv ! CB02, sec. 2, para. 1 - a = 1./(1. + xl*rsl/cpm) ! CB02 variable "a" - b9 = a*rsl ! CB02 variable "b" - - q2p = xlvcp/exner(k) - pt = thl(k) +q2p*QCp*Aup ! potential temp (env + plume) - bb = b9*tk(k)/pt ! bb is "b9" in BCMT95. Their "b9" differs from - ! "b9" in CB02 by a factor - ! of T/theta. Strictly, b9 above is formulated in - ! terms of sat. mixing ratio, but bb in BCMT95 is - ! cast in terms of sat. specific humidity. The - ! conversion is neglected here. - qww = 1.+0.61*qt(k) - alpha = 0.61*pt - beta = pt*xl/(tk(k)*cp) - 1.61*pt - !Buoyancy flux terms have been moved to the end of this section... - - !Now calculate convective component of the cloud fraction: - if (a > 0.0) then - f = MIN(1.0/a, 4.0) ! f is vertical profile scaling function (CB2005) - else - f = 1.0 - endif - - !CB form: - !sigq = 3.5E-3 * Aup * 0.5*(edmf_w(k)+edmf_w(k-1)) * f ! convective component of sigma (CB2005) - !sigq = SQRT(sigq**2 + sgm(k)**2) ! combined conv + stratus components - !Per S.DeRoode 2009? - !sigq = 5. * Aup * (QTp - qt(k)) - sigq = 10. * Aup * (QTp - qt(k)) - !constrain sigq wrt saturation: - sigq = max(sigq, qsat_tk*0.02 ) - sigq = min(sigq, qsat_tk*0.25 ) - - qmq = a * (qt(k) - qsat_tk) ! saturation deficit/excess; - Q1 = qmq/sigq ! the numerator of Q1 - - if ((landsea-1.5).GE.0) then ! WATER - !modified form from LES - !mf_cf = min(max(0.5 + 0.36 * atan(1.20*(Q1+0.2)),0.01),0.6) - !Original CB - mf_cf = min(max(0.5 + 0.36 * atan(1.55*Q1),0.01),0.6) - mf_cf = max(mf_cf, 1.2 * Aup) - mf_cf = min(mf_cf, 5.0 * Aup) - else ! LAND - !LES form - !mf_cf = min(max(0.5 + 0.36 * atan(1.20*(Q1+0.4)),0.01),0.6) - !Original CB - mf_cf = min(max(0.5 + 0.36 * atan(1.55*Q1),0.01),0.6) - mf_cf = max(mf_cf, 1.8 * Aup) - mf_cf = min(mf_cf, 5.0 * Aup) - endif - - !IF ( debug_code ) THEN - ! print*,"In MYNN, StEM edmf" - ! print*," CB: env qt=",qt(k)," qsat=",qsat_tk - ! print*," k=",k," satdef=",QTp - qsat_tk," sgm=",sgm(k) - ! print*," CB: sigq=",sigq," qmq=",qmq," tk=",tk(k) - ! print*," CB: mf_cf=",mf_cf," cldfra_bl=",cldfra_bl1d(k)," edmf_a=",edmf_a(k) - !ENDIF - - ! Update cloud fractions and specific humidities in grid cells - ! where the mass-flux scheme is active. The specific humidities - ! are converted to grid means (not in-cloud quantities). - if ((landsea-1.5).GE.0) then ! water - if (QCp * Aup > 5e-5) then - qc_bl1d(k) = 1.86 * (QCp * Aup) - 2.2e-5 - else - qc_bl1d(k) = 1.18 * (QCp * Aup) - endif - cldfra_bl1d(k) = mf_cf - Ac_mf = mf_cf - else ! land - if (QCp * Aup > 5e-5) then - qc_bl1d(k) = 1.86 * (QCp * Aup) - 2.2e-5 - else - qc_bl1d(k) = 1.18 * (QCp * Aup) - endif - cldfra_bl1d(k) = mf_cf - Ac_mf = mf_cf - endif - - !Now recalculate the terms for the buoyancy flux for mass-flux clouds: - !See mym_condensation for details on these formulations. - !Use Bechtold and Siebesma (1998) piecewise estimation of Fng with - !limits ,since they really should be recalculated after all the other changes...: - !Only overwrite vt & vq in non-stratus condition - !if ((landsea-1.5).GE.0) then ! WATER - Q1=max(Q1,-2.25) - !else - ! Q1=max(Q1,-2.0) - !endif - - if (Q1 .ge. 1.0) then - Fng = 1.0 - elseif (Q1 .ge. -1.7 .and. Q1 .lt. 1.0) then - Fng = EXP(-0.4*(Q1-1.0)) - elseif (Q1 .ge. -2.5 .and. Q1 .lt. -1.7) then - Fng = 3.0 + EXP(-3.8*(Q1+1.7)) - else - Fng = min(23.9 + EXP(-1.6*(Q1+2.5)), 60.) - endif - - !link the buoyancy flux function to active clouds only (c*Aup): - vt(k) = qww - (1.5*Aup)*beta*bb*Fng - 1. - vq(k) = alpha + (1.5*Aup)*beta*a*Fng - tv0 - endif !check for (qc in plume) .and. (cldfra_bl < threshold) - enddo !k-loop - -ENDIF !end nup2 > 0 - -!modify output (negative: dry plume, positive: moist plume) -if (ktop > 0) then - maxqc = maxval(edmf_qc(1:ktop)) - if ( maxqc < 1.E-8) maxmf = -1.0*maxmf -endif - -! -! debugging -! -if (edmf_w(1) > 4.0) then -! surface values - print *,'flq:',flq,' fltv:',fltv2 - print *,'pblh:',pblh,' wstar:',wstar - print *,'sigmaW=',sigmaW,' sigmaTH=',sigmaTH,' sigmaQT=',sigmaQT -! means -! print *,'u:',u -! print *,'v:',v -! print *,'thl:',thl -! print *,'thv:',thv -! print *,'qt:',qt -! print *,'p:',p - -! updrafts -! DO I=1,NUP2 -! print *,'up:A',i -! print *,UPA(:,i) -! print *,'up:W',i -! print*,UPW(:,i) -! print *,'up:thv',i -! print *,UPTHV(:,i) -! print *,'up:thl',i -! print *,UPTHL(:,i) -! print *,'up:qt',i -! print *,UPQT(:,i) -! print *,'up:tQC',i -! print *,UPQC(:,i) -! print *,'up:ent',i -! print *,ENT(:,i) -! ENDDO - -! mean updrafts - print *,' edmf_a',edmf_a(1:14) - print *,' edmf_w',edmf_w(1:14) - print *,' edmf_qt:',edmf_qt(1:14) - print *,' edmf_thl:',edmf_thl(1:14) - -ENDIF !END Debugging - - -#ifdef HARDCODE_VERTICAL -# undef kts -# undef kte -#endif - -END SUBROUTINE DMP_MF -!================================================================= -!>\ingroup gsd_mynn_edmf -!! This subroutine -subroutine condensation_edmf(QT,THL,P,zagl,THV,QC) -! -! zero or one condensation for edmf: calculates THV and QC -! -real(kind_phys),intent(in) :: QT,THL,P,zagl -real(kind_phys),intent(out) :: THV -real(kind_phys),intent(inout):: QC - -integer :: niter,i -real(kind_phys):: diff,exn,t,th,qs,qcold - -! constants used from module_model_constants.F -! p1000mb -! rcp ... Rd/cp -! xlv ... latent heat for water (2.5e6) -! cp -! rvord .. r_v/r_d (1.6) - -! number of iterations - niter=50 -! minimum difference (usually converges in < 8 iterations with diff = 2e-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 - QS=qsat_blend(T,P) - QCOLD=QC - QC=0.5*QC + 0.5*MAX((QT-QS),0.) - if (abs(QC-QCOLD) 0.0) THEN -! PRINT*,"EDMF SAT, p:",p," iterations:",i -! PRINT*," T=",T," THL=",THL," THV=",THV -! PRINT*," QS=",QS," QT=",QT," QC=",QC,"ratio=",qc/qs -! ENDIF - - !THIS BASICALLY GIVE THE SAME RESULT AS THE PREVIOUS LINE - !TH = THL + xlv/cp/EXN*QC - !THV= TH*(1. + p608*QT) - - !print *,'t,p,qt,qs,qc' - !print *,t,p,qt,qs,qc - - -end subroutine condensation_edmf - -!=============================================================== - -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(kind_phys),intent(in) :: QT,THV,P,zagl -real(kind_phys),intent(out) :: THL, QC - -integer :: niter,i -real(kind_phys):: 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*dz(k) -! 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(dz(k), 250.) - - !Do not allow a parcel to accelerate more than 1.25 m/s over 200 m. - !Add max acceleration of -2.0 m/s for coarse vertical resolution. - IF (Wn < DOWNW(K+1,I) - MIN(1.25*dz(k)/200., -2.0))THEN - Wn = DOWNW(K+1,I) - MIN(1.25*dz(k)/200., -2.0) - ENDIF - !Add symmetrical max decrease in velocity (less negative) - IF (Wn > DOWNW(K+1,I) + MIN(1.25*dz(k)/200., 2.0))THEN - Wn = DOWNW(K+1,I) + MIN(1.25*dz(k)/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 - 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 - 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 -!=============================================================== - - -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 - - real(kind_phys), intent(in) :: dx,pbl1 - real(kind_phys), intent(out) :: Psig_bl,Psig_shcu - real(kind_phys) :: dxdh - - Psig_bl=1.0 - Psig_shcu=1.0 - dxdh=MAX(2.5*dx,10.)/MIN(PBL1,3000.) - ! Honnert et al. 2011, TKE in PBL *** original form used until 201605 - !Psig_bl= ((dxdh**2) + 0.07*(dxdh**0.667))/((dxdh**2) + & - ! (3./21.)*(dxdh**0.67) + (3./42.)) - ! Honnert et al. 2011, TKE in entrainment layer - !Psig_bl= ((dxdh**2) + (4./21.)*(dxdh**0.667))/((dxdh**2) + & - ! (3./20.)*(dxdh**0.67) + (7./21.)) - ! New form to preseve parameterized mixing - only down 5% at dx = 750 m - Psig_bl= ((dxdh**2) + 0.106*(dxdh**0.667))/((dxdh**2) +0.066*(dxdh**0.667) + 0.071) - - !assume a 500 m cloud depth for shallow-cu clods - dxdh=MAX(2.5*dx,10.)/MIN(PBL1+500.,3500.) - ! Honnert et al. 2011, TKE in entrainment layer *** original form used until 201605 - !Psig_shcu= ((dxdh**2) + (4./21.)*(dxdh**0.667))/((dxdh**2) + & - ! (3./20.)*(dxdh**0.67) + (7./21.)) - - ! Honnert et al. 2011, TKE in cumulus - !Psig(i)= ((dxdh**2) + 1.67*(dxdh**1.4))/((dxdh**2) +1.66*(dxdh**1.4) + - !0.2) - - ! Honnert et al. 2011, w'q' in PBL - !Psig(i)= 0.5 + 0.5*((dxdh**2) + 0.03*(dxdh**1.4) - - !(4./13.))/((dxdh**2) + 0.03*(dxdh**1.4) + (4./13.)) - ! Honnert et al. 2011, w'q' in cumulus - !Psig(i)= ((dxdh**2) - 0.07*(dxdh**1.4))/((dxdh**2) -0.07*(dxdh**1.4) + - !0.02) - - ! Honnert et al. 2011, q'q' in PBL - !Psig(i)= 0.5 + 0.5*((dxdh**2) + 0.25*(dxdh**0.667) -0.73)/((dxdh**2) - !-0.03*(dxdh**0.667) + 0.73) - ! Honnert et al. 2011, q'q' in cumulus - !Psig(i)= ((dxdh**2) - 0.34*(dxdh**1.4))/((dxdh**2) - 0.35*(dxdh**1.4) - !+ 0.37) - - ! Hyeyum Hailey Shin and Song-You Hong 2013, TKE in PBL (same as Honnert's above) - !Psig_shcu= ((dxdh**2) + 0.070*(dxdh**0.667))/((dxdh**2) - !+0.142*(dxdh**0.667) + 0.071) - ! Hyeyum Hailey Shin and Song-You Hong 2013, TKE in entrainment zone *** switch to this form 201605 - Psig_shcu= ((dxdh**2) + 0.145*(dxdh**0.667))/((dxdh**2) +0.172*(dxdh**0.667) + 0.170) - - ! Hyeyum Hailey Shin and Song-You Hong 2013, w'theta' in PBL - !Psig(i)= 0.5 + 0.5*((dxdh**2) -0.098)/((dxdh**2) + 0.106) - ! Hyeyum Hailey Shin and Song-You Hong 2013, w'theta' in entrainment zone - !Psig(i)= 0.5 + 0.5*((dxdh**2) - 0.112*(dxdh**0.25) -0.071)/((dxdh**2) - !+ 0.054*(dxdh**0.25) + 0.10) - - !print*,"in scale_aware; dx, dxdh, Psig(i)=",dx,dxdh,Psig(i) - !If(Psig_bl(i) < 0.0 .OR. Psig(i) > 1.)print*,"dx, dxdh, Psig(i)=",dx,dxdh,Psig_bl(i) - If(Psig_bl > 1.0) Psig_bl=1.0 - If(Psig_bl < 0.0) Psig_bl=0.0 - - If(Psig_shcu > 1.0) Psig_shcu=1.0 - If(Psig_shcu < 0.0) Psig_shcu=0.0 - - END SUBROUTINE SCALE_AWARE - -! ===================================================================== -!>\ingroup gsd_mynn_edmf -!! \author JAYMES- added 22 Apr 2015 -!! This function calculates saturation vapor pressure. Separate ice and liquid functions -!! are used (identical to those in module_mp_thompson.F, v3.6). Then, the -!! final returned value is a temperature-dependant "blend". Because the final -!! value is "phase-aware", this formulation may be preferred for use throughout -!! the module (replacing "svp"). - FUNCTION esat_blend(t) - - IMPLICIT NONE - - real(kind_phys), intent(in):: t - real(kind_phys):: esat_blend,XC,ESL,ESI,chi - !liquid - real(kind_phys), parameter:: J0= .611583699E03 - real(kind_phys), parameter:: J1= .444606896E02 - real(kind_phys), parameter:: J2= .143177157E01 - real(kind_phys), parameter:: J3= .264224321E-1 - real(kind_phys), parameter:: J4= .299291081E-3 - real(kind_phys), parameter:: J5= .203154182E-5 - real(kind_phys), parameter:: J6= .702620698E-8 - real(kind_phys), parameter:: J7= .379534310E-11 - real(kind_phys), parameter:: J8=-.321582393E-13 - !ice - real(kind_phys), parameter:: K0= .609868993E03 - real(kind_phys), parameter:: K1= .499320233E02 - real(kind_phys), parameter:: K2= .184672631E01 - real(kind_phys), parameter:: K3= .402737184E-1 - real(kind_phys), parameter:: K4= .565392987E-3 - real(kind_phys), parameter:: K5= .521693933E-5 - real(kind_phys), parameter:: K6= .307839583E-7 - real(kind_phys), parameter:: K7= .105785160E-9 - real(kind_phys), parameter:: K8= .161444444E-12 - - XC=MAX(-80.,t - t0c) !note t0c = 273.15, tice is set in module mynn_common to 240 - -! For 240 < t < 268.16 K, the vapor pressures are "blended" as a function of temperature, -! using the approach similar to Chaboureau and Bechtold (2002), JAS, p. 2363. The resulting -! values are returned from the function. - IF (t .GE. (t0c-6.)) THEN - esat_blend = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) - ELSE IF (t .LE. tice) THEN - esat_blend = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) - ELSE - ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) - ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) - chi = ((t0c-6.) - t)/((t0c-6.) - tice) - esat_blend = (1.-chi)*ESL + chi*ESI - END IF - - END FUNCTION esat_blend - -! ==================================================================== - -!>\ingroup gsd_mynn_edmf -!! This function extends function "esat" and returns a "blended" -!! saturation mixing ratio. Tice currently set to 240 K, t0c = 273.15 K. -!!\author JAYMES - FUNCTION qsat_blend(t, P) - - IMPLICIT NONE - - real(kind_phys), intent(in):: t, P - real(kind_phys):: qsat_blend,XC,ESL,ESI,RSLF,RSIF,chi - !liquid - real(kind_phys), parameter:: J0= .611583699E03 - real(kind_phys), parameter:: J1= .444606896E02 - real(kind_phys), parameter:: J2= .143177157E01 - real(kind_phys), parameter:: J3= .264224321E-1 - real(kind_phys), parameter:: J4= .299291081E-3 - real(kind_phys), parameter:: J5= .203154182E-5 - real(kind_phys), parameter:: J6= .702620698E-8 - real(kind_phys), parameter:: J7= .379534310E-11 - real(kind_phys), parameter:: J8=-.321582393E-13 - !ice - real(kind_phys), parameter:: K0= .609868993E03 - real(kind_phys), parameter:: K1= .499320233E02 - real(kind_phys), parameter:: K2= .184672631E01 - real(kind_phys), parameter:: K3= .402737184E-1 - real(kind_phys), parameter:: K4= .565392987E-3 - real(kind_phys), parameter:: K5= .521693933E-5 - real(kind_phys), parameter:: K6= .307839583E-7 - real(kind_phys), parameter:: K7= .105785160E-9 - real(kind_phys), parameter:: K8= .161444444E-12 - - XC=MAX(-80.,t - t0c) - - IF (t .GE. (t0c-6.)) THEN - ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) - ESL = min(ESL, P*0.15) ! Even with P=1050mb and T=55C, the sat. vap. pres only contributes to ~15% of total pres. - qsat_blend = 0.622*ESL/max(P-ESL, 1e-5) - ELSE IF (t .LE. tice) THEN - ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) - ESI = min(ESI, P*0.15) - qsat_blend = 0.622*ESI/max(P-ESI, 1e-5) - ELSE - ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) - ESL = min(ESL, P*0.15) - ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) - ESI = min(ESI, P*0.15) - RSLF = 0.622*ESL/max(P-ESL, 1e-5) - RSIF = 0.622*ESI/max(P-ESI, 1e-5) -! chi = (268.16-t)/(268.16-240.) - chi = ((t0c-6.) - t)/((t0c-6.) - tice) - qsat_blend = (1.-chi)*RSLF + chi*RSIF - END IF - - END FUNCTION qsat_blend - -! =================================================================== - -!>\ingroup gsd_mynn_edmf -!! This function interpolates the latent heats of vaporization and sublimation into -!! a single, temperature-dependent, "blended" value, following -!! Chaboureau and Bechtold (2002) \cite Chaboureau_2002, Appendix. -!!\author JAYMES - FUNCTION xl_blend(t) - - IMPLICIT NONE - - real(kind_phys), intent(in):: t - real(kind_phys):: xl_blend,xlvt,xlst,chi - !note: t0c = 273.15, tice is set in mynn_common - - IF (t .GE. t0c) THEN - xl_blend = xlv + (cpv-cliq)*(t-t0c) !vaporization/condensation - ELSE IF (t .LE. tice) THEN - xl_blend = xls + (cpv-cice)*(t-t0c) !sublimation/deposition - ELSE - xlvt = xlv + (cpv-cliq)*(t-t0c) !vaporization/condensation - xlst = xls + (cpv-cice)*(t-t0c) !sublimation/deposition -! chi = (273.16-t)/(273.16-240.) - chi = (t0c - t)/(t0c - tice) - xl_blend = (1.-chi)*xlvt + chi*xlst !blended - END IF - - 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(kind_phys), intent(in):: zet - real(kind_phys):: dummy_0,dummy_1,dummy_11,dummy_2,dummy_22,dummy_3,dummy_33,dummy_4,dummy_44,dummy_psi - real(kind_phys), parameter :: am_st=6.1, bm_st=2.5, rbm_st=1./bm_st - real(kind_phys), parameter :: ah_st=5.3, bh_st=1.1, rbh_st=1./bh_st - real(kind_phys), parameter :: am_unst=10., ah_unst=34. - real(kind_phys):: 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 ! 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 - - 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(kind_phys), intent(in):: zet - real(kind_phys):: dummy_0,dummy_1,dummy_11,dummy_2,dummy_22,dummy_3,dummy_33,dummy_4,dummy_44,dummy_psi - real(kind_phys), parameter :: am_st=6.1, bm_st=2.5, rbm_st=1./bm_st - real(kind_phys), parameter :: ah_st=5.3, bh_st=1.1, rbh_st=1./bh_st - real(kind_phys), parameter :: am_unst=10., ah_unst=34. - real(kind_phys):: 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,fltv,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(kind_phys), dimension(kts:kte), intent(in) :: dz1,sqc,sqi,sqw,& - thl,th1,ex1,p1,rho1,thetav,cldfra_bl1D - real(kind_phys), dimension(kts:kte), intent(in) :: rthraten - real(kind_phys), dimension(kts:kte+1), intent(in) :: zw - real(kind_phys), intent(in) :: pblh,fltv - real(kind_phys), intent(in) :: xland - integer , intent(in) :: kpbl - !output - real(kind_phys), intent(out) :: maxKHtopdown - real(kind_phys), dimension(kts:kte), intent(out) :: KHtopdown,TKEprodTD - !local - real(kind_phys), dimension(kts:kte) :: zfac,wscalek2,zfacent - real(kind_phys) :: bfx0,wm3,bfxpbl,dthvx,tmp1 - real(kind_phys) :: temps,templ,zl1,wstar3_2 - real(kind_phys) :: ent_eff,radsum,radflux,we,rcldb,rvls,minrad,zminrad - real(kind_phys), 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) + 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/(r_d*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)*p608*sqw(k+2)) & - - (thl(k) + th1(k) *p608*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/grav*(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(fltv,0.0),0.) - endif - - !entrainment from PBL top thermals - wm3 = grav/thetav(k)*bfx0*MIN(pblh,1500.) ! this is wstar3(i) - bfxpbl = - ent_eff * bfx0 - dthvx = max(thetav(k+1)-thetav(k),0.1) - we = max(bfxpbl/dthvx,-sqrt(wm3**twothirds)) - - 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)))**onethird - !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 -! ================================================================== -! =================================================================== -! =================================================================== - -END MODULE module_bl_mynn diff --git a/phys/module_bl_mynn_common.F b/phys/module_bl_mynn_common.F deleted file mode 100644 index 7d4057b27a..0000000000 --- a/phys/module_bl_mynn_common.F +++ /dev/null @@ -1,101 +0,0 @@ -!==================================================================== - - module module_bl_mynn_common - -!------------------------------------------ -!Define Model-specific constants/parameters. -!This module will be used at the initialization stage -!where all model-specific constants are read and saved into -!memory. This module is then used again in the MYNN-EDMF. All -!MYNN-specific constants are declared globally in the main -!module (module_bl_mynn) further below: -!------------------------------------------ -! -! The following 5-6 lines are the only lines in this file that are not -! universal for all dycores... Any ideas how to universalize it? -! For MPAS: -! use mpas_kind_types,only: kind_phys => RKIND -! For CCPP: - use ccpp_kind_types, only : kind_phys -! For WRF -! use module_gfs_machine, only : kind_phys - -!WRF CONSTANTS - use module_model_constants, only: & - & karman, g, p1000mb, & - & cp, r_d, r_v, rcp, xlv, xlf, xls, & - & svp1, svp2, svp3, p608, ep_2, rvovrd, & - & cpv, cliq, cice, svpt0 - - implicit none - save -! save :: cp, cpv, cice, cliq, p608, karman, rcp, & !taken directly from module_model_constants -! r_d, r_v, xls, xlv, xlf, rvovrd, ep_2, & !taken directly from module_model_constants -! p1000mb, svp1, svp2, svp3, & !taken directly from module_model_constants -! grav, t0c, & !renamed from module_model_constants -! zero, half, one, two, onethird, & !set here -! twothirds, tref, tkmin, tice, & !set here -! ep_3, gtr, rk, tv0, tv1, xlscp, xlvcp, & !derived here -! g_inv !derived here - -! To be specified from dycore -! real:: cp != 7.*r_d/2. (J/kg/K) -! real:: cpv != 4.*r_v (J/kg/K) Spec heat H2O gas -! real:: cice != 2106. (J/kg/K) Spec heat H2O ice -! real:: cliq != 4190. (J/kg/K) Spec heat H2O liq -! real:: p608 != R_v/R_d-1. -! real:: ep_2 != R_d/R_v -!! real:: grav != accel due to gravity -! real:: karman != von Karman constant -!! real:: t0c != temperature of water at freezing, 273.15 K -! real:: rcp != r_d/cp -! real:: r_d != 287. (J/kg/K) gas const dry air -! real:: r_v != 461.6 (J/kg/K) gas const water -! real:: xlf != 0.35E6 (J/kg) fusion at 0 C -! real:: xlv != 2.50E6 (J/kg) vaporization at 0 C -! real:: xls != 2.85E6 (J/kg) sublimation -! real:: rvovrd != r_v/r_d != 1.608 - -! Specified locally -! Define single & double precision - integer, parameter :: sp = selected_real_kind(6, 37) - integer, parameter :: dp = selected_real_kind(15, 307) -! integer, parameter :: kind_phys = sp - real(kind_phys),parameter:: zero = 0.0 - real(kind_phys),parameter:: half = 0.5 - real(kind_phys),parameter:: one = 1.0 - real(kind_phys),parameter:: two = 2.0 - real(kind_phys),parameter:: onethird = 1./3. - real(kind_phys),parameter:: twothirds = 2./3. - real(kind_phys),parameter:: tref = 300.0 ! reference temperature (K) - real(kind_phys),parameter:: TKmin = 253.0 ! for total water conversion, Tripoli and Cotton (1981) -! real(kind_phys),parameter:: p1000mb=100000.0 -! real(kind_phys),parameter:: svp1 = 0.6112 !(kPa) -! real(kind_phys),parameter:: svp2 = 17.67 !(dimensionless) -! real(kind_phys),parameter:: svp3 = 29.65 !(K) - real(kind_phys),parameter:: tice = 240.0 !-33 (C), temp at saturation w.r.t. ice - real(kind_phys),parameter:: grav = g - real(kind_phys),parameter:: t0c = svpt0 != 273.15 - -! To be derived in the init routine - real(kind_phys),parameter:: ep_3 = 1.-ep_2 != 0.378 - real(kind_phys),parameter:: gtr = grav/tref - real(kind_phys),parameter:: rk = cp/r_d - real(kind_phys),parameter:: tv0 = p608*tref - real(kind_phys),parameter:: tv1 = (1.+p608)*tref - real(kind_phys),parameter:: xlscp = (xlv+xlf)/cp - real(kind_phys),parameter:: xlvcp = xlv/cp - real(kind_phys),parameter:: g_inv = 1./grav - -! grav = g -! t0c = svpt0 != 273.15 -! ep_3 = 1.-ep_2 != 0.378 -! gtr = grav/tref -! rk = cp/r_d -! tv0 = p608*tref -! tv1 = (1.+p608)*tref -! xlscp = (xlv+xlf)/cp -! xlvcp = xlv/cp -! g_inv = 1./grav - - end module module_bl_mynn_common diff --git a/phys/module_bl_mynn_wrapper.F b/phys/module_bl_mynn_wrapper.F deleted file mode 100644 index 72ce6dbaaa..0000000000 --- a/phys/module_bl_mynn_wrapper.F +++ /dev/null @@ -1,812 +0,0 @@ -!> \file module_bl_mynn_wrapper.F90 -!! This serves as the interface between the WRF PBL driver and the MYNN -!! eddy-diffusivity mass-flux scheme in module_bl_mynn.F. - -!>\ingroup gsd_mynn_edmf -!> The following references best describe the code within -!! Olson et al. (2019, NOAA Technical Memorandum) -!! Nakanishi and Niino (2009) \cite NAKANISHI_2009 - MODULE module_bl_mynn_wrapper - - use module_bl_mynn_common - - contains - -!> \section arg_table_mynnedmf_wrapper_init Argument Table -!! \htmlinclude mynnedmf_wrapper_init.html -!! - subroutine mynnedmf_wrapper_init ( & - & RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN,RQCBLTEN,& - & RQIBLTEN,QKE, & - & restart,allowed_to_read, & - & P_QC,P_QI,PARAM_FIRST_SCALAR, & - & IDS,IDE,JDS,JDE,KDS,KDE, & - & IMS,IME,JMS,JME,KMS,KME, & - & ITS,ITE,JTS,JTE,KTS,KTE ) - - implicit none - - LOGICAL,INTENT(IN) :: ALLOWED_TO_READ,RESTART - - INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE, & - & IMS,IME,JMS,JME,KMS,KME, & - & ITS,ITE,JTS,JTE,KTS,KTE - - - REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: & - &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, & - &RQCBLTEN,RQIBLTEN,QKE - - INTEGER, intent(in) :: P_QC,P_QI,PARAM_FIRST_SCALAR - - INTEGER :: I,J,K,ITF,JTF,KTF - - JTF=MIN0(JTE,JDE-1) - KTF=MIN0(KTE,KDE-1) - 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. - ENDDO - ENDDO - ENDDO - ENDIF - - end subroutine mynnedmf_wrapper_init - - subroutine mynnedmf_wrapper_finalize () - end subroutine mynnedmf_wrapper_finalize - -! \brief This scheme (1) performs pre-mynnedmf work, (2) runs the mynnedmf, and (3) performs post-mynnedmf work -!> \section arg_table_mynnedmf_wrapper_run Argument Table -!! \htmlinclude mynnedmf_wrapper_run.html -!! -SUBROUTINE mynnedmf_wrapper_run( & - & initflag,restart,cycling, & - & delt,dz,dxc,znt, & - & u,v,w,th, & - & qv,qc,qi,qs,qnc,qni,qnwfa,qnifa,qnbca, & -! & ozone, & - & p,exner,rho,t3d, & - & xland,ts,qsfc,ps, & - & ust,ch,hfx,qfx,rmol,wspd, & - & uoce,voce, & - & qke,qke_adv,sh3d,sm3d, & -!--- chem/smoke -#if (WRF_CHEM == 1) - & mix_chem,chem3d,vd3d,nchem,kdvel, & - & ndvel,num_vert_mix, & -! & frp_mean,emis_ant_no,enh_mix, & !to be included soon -#endif -!--- end chem/smoke - & Tsq,Qsq,Cov, & - & rublten,rvblten,rthblten, & - & rqvblten,rqcblten,rqiblten,rqsblten, & - & rqncblten,rqniblten, & - & rqnwfablten,rqnifablten,rqnbcablten, & -! & ro3blten, & - & exch_h,exch_m,pblh,kpbl,el_pbl, & - & dqke,qwt,qshear,qbuoy,qdiss, & - & qc_bl,qi_bl,cldfra_bl, & - & edmf_a,edmf_w,edmf_qt, & - & edmf_thl,edmf_ent,edmf_qc, & - & sub_thl3d,sub_sqv3d, & - & det_thl3d,det_sqv3d, & - & maxwidth,maxMF,ztop_plume,ktop_plume, & - & rthraten, & - & tke_budget, bl_mynn_tkeadvect, & - & bl_mynn_cloudpdf, bl_mynn_mixlength, & - & icloud_bl, bl_mynn_edmf, & - & bl_mynn_edmf_mom, bl_mynn_edmf_tke, & - & bl_mynn_cloudmix, bl_mynn_mixqt, & - & bl_mynn_output, bl_mynn_closure, & - & bl_mynn_mixscalars, & - & spp_pbl,pattern_spp_pbl, & - & flag_qc,flag_qi,flag_qs, & - & flag_qnc,flag_qni, & - & flag_qnwfa,flag_qnifa,flag_qnbca, & - & ids,ide,jds,jde,kds,kde, & - & ims,ime,jms,jme,kms,kme, & - & its,ite,jts,jte,kts,kte ) - - use module_bl_mynn, only: mynn_bl_driver - -!------------------------------------------------------------------- - implicit none -!------------------------------------------------------------------- - - !smoke/chem: disclaimer: all smoke-related variables are still - !considered under development in CCPP. Until that work is - !completed, these flags/arrays must be kept hard-coded as is. -#if (WRF_CHEM == 1) - logical, intent(in) :: mix_chem - integer, intent(in) :: nchem, ndvel, kdvel, num_vert_mix - logical, parameter :: & - & rrfs_sd =.false., & - & smoke_dbg =.false., & - & enh_mix =.false. -#else - logical, parameter :: & - & mix_chem =.false., & - & enh_mix =.false., & - & rrfs_sd =.false., & - & smoke_dbg =.false. - integer, parameter :: nchem=2, ndvel=2, kdvel=1, & - num_vert_mix = 1 -#endif - -! NAMELIST OPTIONS (INPUT): - logical, intent(in) :: & - & bl_mynn_tkeadvect, & - & cycling - integer, intent(in) :: & - & bl_mynn_cloudpdf, & - & bl_mynn_mixlength, & - & icloud_bl, & - & bl_mynn_edmf, & - & bl_mynn_edmf_mom, & - & bl_mynn_edmf_tke, & - & bl_mynn_cloudmix, & - & bl_mynn_mixqt, & - & bl_mynn_output, & - & bl_mynn_mixscalars, & - & spp_pbl, & - & tke_budget - real(kind_phys), intent(in) :: & - & bl_mynn_closure - - logical, intent(in) :: & - & FLAG_QI, FLAG_QNI, FLAG_QC, FLAG_QNC, & - & FLAG_QS, FLAG_QNWFA, FLAG_QNIFA, FLAG_QNBCA - logical, parameter :: FLAG_OZONE = .false. - -!MYNN-1D - REAL(kind_phys), intent(in) :: delt, dxc - LOGICAL, intent(in) :: restart - INTEGER :: i, j, k, itf, jtf, ktf, n - INTEGER, intent(in) :: initflag, & - & IDS,IDE,JDS,JDE,KDS,KDE, & - & IMS,IME,JMS,JME,KMS,KME, & - & ITS,ITE,JTS,JTE,KTS,KTE - -!MYNN-3D - real(kind_phys), dimension(ims:ime,kms:kme,jms:jme), intent(in) :: & - & u,v,w,t3d,th,rho,exner,p,dz - real(kind_phys), dimension(ims:ime,kms:kme,jms:jme), intent(inout) :: & - & rublten,rvblten,rthblten, & - & rqvblten,rqcblten,rqiblten,rqsblten, & - & rqncblten,rqniblten, & - & rqnwfablten,rqnifablten,rqnbcablten !,ro3blten - real(kind_phys), dimension(ims:ime,kms:kme,jms:jme), intent(inout) :: & - & qke, qke_adv, el_pbl, sh3d, sm3d - real(kind_phys), dimension(ims:ime,kms:kme,jms:jme), intent(inout) :: & - & Tsq, Qsq, Cov, exch_h, exch_m - real(kind_phys), dimension(ims:ime,kms:kme,jms:jme), intent(in) :: rthraten - -!optional 3D arrays - real(kind_phys), dimension(ims:ime,kms:kme,jms:jme), optional, intent(in) :: & - & pattern_spp_pbl - real(kind_phys), dimension(ims:ime,kms:kme,jms:jme), optional, intent(inout) :: & - & qc_bl, qi_bl, cldfra_bl - real(kind_phys), dimension(ims:ime,kms:kme,jms:jme), optional, intent(inout) :: & - & edmf_a,edmf_w,edmf_qt, & - & edmf_thl,edmf_ent,edmf_qc, & - & sub_thl3d,sub_sqv3d,det_thl3d,det_sqv3d - real(kind_phys), dimension(ims:ime,kms:kme,jms:jme), optional, intent(inout) :: & - & dqke,qWT,qSHEAR,qBUOY,qDISS - real(kind_phys), dimension(ims:ime,kms:kme,jms:jme), optional, intent(inout) :: & - & qv,qc,qi,qs,qnc,qni,qnwfa,qnifa,qnbca!,o3 - -!optional 2D arrays for passing into module_bl_myn.F - real(kind_phys), allocatable, dimension(:,:) :: & - & qc_bl2d, qi_bl2d, cldfra_bl2d, pattern_spp_pbl2d - real(kind_phys), allocatable, dimension(:,:) :: & - & edmf_a2d,edmf_w2d,edmf_qt2d, & - & edmf_thl2d,edmf_ent2d,edmf_qc2d, & - & sub_thl2d,sub_sqv2d,det_thl2d,det_sqv2d - real(kind_phys), allocatable, dimension(:,:) :: & - & dqke2d,qWT2d,qSHEAR2d,qBUOY2d,qDISS2d - real(kind_phys), allocatable, dimension(:,:) :: & - & qc2d,qi2d,qs2d,qnc2d,qni2d,qnwfa2d,qnifa2d,qnbca2d!,o32d - -!smoke/chem arrays - no if-defs in module_bl_mynn.F, so must define arrays -#if (WRF_CHEM == 1) - real(kind_phys), dimension(ims:ime,kms:kme,jms:jme,nchem), intent(in) :: chem3d - real(kind_phys), dimension(ims:ime,kdvel,jms:jme, ndvel), intent(in) :: vd3d - real(kind_phys), dimension(ims:ime,kms:kme,nchem) :: chem - real(kind_phys), dimension(ims:ime,ndvel) :: vd - real(kind_phys), dimension(ims:ime) :: frp_mean, emis_ant_no -#else - real(kind_phys), dimension(ims:ime,kms:kme,nchem) :: chem - real(kind_phys), dimension(ims:ime,ndvel) :: vd - real(kind_phys), dimension(ims:ime) :: frp_mean, emis_ant_no -#endif - -!MYNN-2D - real(kind_phys), dimension(ims:ime,jms:jme), intent(in) :: & - & xland,ts,qsfc,ps,ch - real(kind_phys), dimension(ims:ime,jms:jme), intent(inout) :: & - & znt,pblh,maxwidth,maxmf,ztop_plume,rmol,hfx,qfx,ust,wspd, & - & uoce,voce - integer, dimension(ims:ime,jms:jme), intent(inout) :: & - & kpbl,ktop_plume - -!Local - real(kind_phys), dimension(ims:ime,kms:kme) :: delp,sqv,sqc,sqi,sqs,ikzero - real(kind_phys), dimension(ims:ime) :: dx - logical, parameter :: debug = .false. - real(kind_phys), dimension(ims:ime,kms:kme,jms:jme) :: ozone,rO3blten - - !write(0,*)"==============================================" - !write(0,*)"in mynn wrapper..." - !write(0,*)"initflag=",initflag - !write(0,*)"restart =",restart - - jtf=MIN0(JTE,JDE-1) - ktf=MIN0(KTE,KDE-1) - itf=MIN0(ITE,IDE-1) - - !For now, initialized bogus array - ozone=0.0 - rO3blten=0.0 - ikzero=0.0 - - !Allocate any arrays being used - if (icloud_bl > 0) then - allocate(qc_bl2d(ims:ime,kms:kme)) - allocate(qi_bl2d(ims:ime,kms:kme)) - allocate(cldfra_bl2d(ims:ime,kms:kme)) - qc_bl2d=0.0 - qi_bl2d=0.0 - cldfra_bl2d=0.0 - endif - if (spp_pbl > 0) then - allocate(pattern_spp_pbl2d(ims:ime,kms:kme)) - endif - if (bl_mynn_output > 0) then - allocate(edmf_a2d(ims:ime,kms:kme)) - allocate(edmf_w2d(ims:ime,kms:kme)) - allocate(edmf_qt2d(ims:ime,kms:kme)) - allocate(edmf_thl2d(ims:ime,kms:kme)) - allocate(edmf_ent2d(ims:ime,kms:kme)) - allocate(edmf_qc2d(ims:ime,kms:kme)) - allocate(sub_thl2d(ims:ime,kms:kme)) - allocate(sub_sqv2d(ims:ime,kms:kme)) - allocate(det_thl2d(ims:ime,kms:kme)) - allocate(det_sqv2d(ims:ime,kms:kme)) - endif - if (tke_budget .eq. 1) then - allocate(dqke2d(ims:ime,kms:kme)) - allocate(qWT2d(ims:ime,kms:kme)) - allocate(qSHEAR2d(ims:ime,kms:kme)) - allocate(qBUOY2d(ims:ime,kms:kme)) - allocate(qDISS2d(ims:ime,kms:kme)) - dqke2d =0.0 - qWT2d =0.0 - qSHEAR2d=0.0 - qBUOY2d =0.0 - qDISS2d =0.0 - endif - if (flag_qc) then - allocate(qc2d(ims:ime,kms:kme)) - qc2d=0.0 - endif - if (flag_qi) then - allocate(qi2d(ims:ime,kms:kme)) - qi2d=0.0 - endif - if (flag_qs) then - allocate(qs2d(ims:ime,kms:kme)) - qs2d=0.0 - endif - if (flag_qnc) then - allocate(qnc2d(ims:ime,kms:kme)) - qnc2d=0.0 - endif - if (flag_qni) then - allocate(qni2d(ims:ime,kms:kme)) - qni2d=0.0 - endif - if (flag_qnwfa) then - allocate(qnwfa2d(ims:ime,kms:kme)) - qnwfa2d=0.0 - endif - if (flag_qnifa) then - allocate(qnifa2d(ims:ime,kms:kme)) - qnifa2d=0.0 - endif - if (flag_qnbca) then - allocate(qnbca2d(ims:ime,kms:kme)) - qnbca2d=0.0 - endif - !--------------------------------- - !Begin looping in the j-direction - !--------------------------------- - do j = jts,jtf - - !need sgs cloud info input for diagnostic-decay - if (icloud_bl > 0) then - do k=kts,ktf - do i=its,itf - qc_bl2d(i,k) = qc_bl(i,k,j) - qi_bl2d(i,k) = qi_bl(i,k,j) - cldfra_bl2d(i,k) = cldfra_bl(i,k,j) - enddo - enddo - endif - - !spp input - if (spp_pbl > 0) then - do k=kts,ktf - do i=its,itf - pattern_spp_pbl2d(i,k) = pattern_spp_pbl(i,k,j) - enddo - enddo - endif - - !intialize moist species - if (flag_qc) then - do k=kts,ktf - do i=its,itf - qc2d(i,k) = qc(i,k,j) - enddo - enddo - endif - if (flag_qi) then - do k=kts,ktf - do i=its,itf - qi2d(i,k) = qi(i,k,j) - enddo - enddo - endif - if (flag_qs) then - do k=kts,ktf - do i=its,itf - qs2d(i,k) = qs(i,k,j) - enddo - enddo - endif - if (flag_qnc) then - do k=kts,ktf - do i=its,itf - qnc2d(i,k) = qnc(i,k,j) - enddo - enddo - endif - if (flag_qni) then - do k=kts,ktf - do i=its,itf - qni2d(i,k) = qni(i,k,j) - enddo - enddo - endif - if (flag_qnwfa) then - do k=kts,ktf - do i=its,itf - qnwfa2d(i,k) = qnwfa(i,k,j) - enddo - enddo - endif - if (flag_qnifa) then - do k=kts,ktf - do i=its,itf - qnifa2d(i,k) = qnifa(i,k,j) - enddo - enddo - endif - if (flag_qnbca) then - do k=kts,ktf - do i=its,itf - qnbca2d(i,k) = qnbca(i,k,j) - enddo - enddo - endif - -#if (WRF_CHEM == 1) - if (mix_chem) then - do n=1,nchem - do k=kts,ktf - do i=its,itf - chem(i,k,n)=chem3d(i,k,j,n) - enddo - enddo - enddo - - !set kdvel =1 - do n=1,ndvel - do i=its,itf - vd(i,n) =vd3d(i,1,j,n) - enddo - enddo - endif - frp_mean = 0.0 - emis_ant_no = 0.0 -#else - chem = 0.0 - vd = 0.0 - frp_mean = 0.0 - emis_ant_no = 0.0 -#endif - - ! Check incoming moist species to ensure non-negative values - ! First, create pressure differences (delp) across model layers - do i=its,itf - dx(i)=dxc - enddo - -! do i=its,itf -! call moisture_check2(kte, delt, & -! delp(i,:), exner(i,:,j), & -! qv(i,:,j), qc(i,:,j), & -! qi(i,:,j), t3d(i,:,j) ) -! enddo - - !In WRF, mixing ratio is incoming. Convert to specific humidity: - do k=kts,ktf - do i=its,itf - sqv(i,k)=qv(i,k,j)/(1.0 + qv(i,k,j)) - sqc(i,k)=qc2d(i,k)/(1.0 + qv(i,k,j)) - enddo - enddo - if (flag_qi) then - do k=kts,ktf - do i=its,itf - sqi(i,k)=qi2d(i,k)/(1.0 + qv(i,k,j)) - enddo - enddo - else - sqi(:,:)=0.0 - endif - if (flag_qs) then - do k=kts,ktf - do i=its,itf - sqs(i,k)=qs2d(i,k)/(1.0 + qv(i,k,j)) - enddo - enddo - else - sqs(:,:)=0.0 - endif - - if (debug) then - print* - write(0,*)"===CALLING mynn_bl_driver; input:" - print*,"tke_budget=",tke_budget - print*,"bl_mynn_tkeadvect=",bl_mynn_tkeadvect - print*,"bl_mynn_cloudpdf=",bl_mynn_cloudpdf - print*,"bl_mynn_mixlength=",bl_mynn_mixlength - print*,"bl_mynn_edmf=",bl_mynn_edmf - print*,"bl_mynn_edmf_mom=",bl_mynn_edmf_mom - print*,"bl_mynn_edmf_tke=",bl_mynn_edmf_tke - print*,"bl_mynn_cloudmix=",bl_mynn_cloudmix - print*,"bl_mynn_mixqt=",bl_mynn_mixqt - print*,"icloud_bl=",icloud_bl - print*,"T:",t3d(its,1,j),t3d(its,2,j),t3d(its,kte,j) - print*,"TH:",th(its,1,j),th(its,2,j),th(its,kte,j) - print*,"rho:",rho(its,1,j),rho(its,2,j),rho(its,kte,j) - print*,"exner:",exner(its,1,j),exner(its,2,j),exner(its,kte,j) - print*,"p:",p(its,1,j),p(its,2,j),p(its,kte,j) - print*,"dz:",dz(its,1,j),dz(its,2,j),dz(its,kte,j) - print*,"u:",u(its,1,j),u(its,2,j),u(its,kte,j) - print*,"v:",v(its,1,j),v(its,2,j),v(its,kte,j) - print*,"sqv:",sqv(its,1),sqv(its,2),sqv(its,kte) - print*,"sqc:",sqc(its,1),sqc(its,2),sqc(its,kte) - print*,"sqi:",sqi(its,1),sqi(its,2),sqi(its,kte) - print*,"rmol:",rmol(its,j)," ust:",ust(its,j) - print*,"dx=",dx(its),"initflag=",initflag - print*,"Thetasurf:",ts(its,j) - print*,"HFX:",hfx(its,j)," qfx",qfx(its,j) - print*,"qsfc:",qsfc(its,j)," ps:",ps(its,j) - print*,"wspd:",wspd(its,j) - print*,"znt:",znt(its,j)," delt=",delt - print*,"ite=",ite," kte=",kte - print*,"PBLH=",pblh(its,j)," KPBL=",KPBL(its,j)," xland=",xland(its,j) - print*," ch=",ch(its,j) - print*,"qke:",qke(its,1,j),qke(its,2,j),qke(its,kte,j) - print*,"el_pbl:",el_pbl(its,1,j),el_pbl(its,2,j),el_pbl(its,kte,j) - print*,"Sh3d:",Sh3d(its,1,j),sh3d(its,2,j),sh3d(its,kte,j) - print*,"max cf_bl:",maxval(cldfra_bl(its,:,j)) - endif - -!print*,"In mynn wrapper, calling mynn_bl_driver" - CALL mynn_bl_driver( & - & initflag=initflag,restart=restart,cycling=cycling, & - & delt=delt,dz=dz(:,:,j),dx=dx,znt=znt(:,j), & - & u=u(:,:,j),v=v(:,:,j),w=w(:,:,j), & - & th=th(:,:,j),sqv3D=sqv,sqc3D=sqc, & - & sqi3D=sqi,sqs3D=sqs,qnc=qnc2d,qni=qni2d, & - & qnwfa=qnwfa2d,qnifa=qnifa2d,qnbca=qnbca2d, & - & ozone=ozone(:,:,j), & - & p=p(:,:,j),exner=exner(:,:,j),rho=rho(:,:,j), & - & T3D=t3d(:,:,j),xland=xland(:,j), & - & ts=ts(:,j),qsfc=qsfc(:,j),ps=ps(:,j), & - & ust=ust(:,j),ch=ch(:,j),hfx=hfx(:,j),qfx=qfx(:,j), & - & rmol=rmol(:,j),wspd=wspd(:,j), & - & uoce=uoce(:,j),voce=voce(:,j), & !input - & qke=QKE(:,:,j),qke_adv=qke_adv(:,:,j), & !output - & sh3d=Sh3d(:,:,j),sm3d=Sm3d(:,:,j), & !output - & nchem=nchem,kdvel=kdvel,ndvel=ndvel, & !chem/smoke - & Chem3d=chem,Vdep=vd, & - & FRP=frp_mean,EMIS_ANT_NO=emis_ant_no, & - & mix_chem=mix_chem,enh_mix=enh_mix, & - & rrfs_sd=rrfs_sd,smoke_dbg=smoke_dbg, & !end chem/smoke - & tsq=tsq(:,:,j),qsq=qsq(:,:,j),cov=cov(:,:,j), & !output - & RUBLTEN=RUBLTEN(:,:,j),RVBLTEN=RVBLTEN(:,:,j), & !output - & RTHBLTEN=RTHBLTEN(:,:,j),RQVBLTEN=RQVBLTEN(:,:,j), & !output - & RQCBLTEN=rqcblten(:,:,j),RQIBLTEN=rqiblten(:,:,j), & !output - & RQNCBLTEN=rqncblten(:,:,j),RQNIBLTEN=rqniblten(:,:,j), & !output - & RQSBLTEN=ikzero, & !there is no RQSBLTEN, so use dummy arary - & RQNWFABLTEN=RQNWFABLTEN(:,:,j), & !output - & RQNIFABLTEN=RQNIFABLTEN(:,:,j), & !output - & RQNBCABLTEN=RQNBCABLTEN(:,:,j), & !output - & dozone=rO3blten(:,:,j), & !output - & EXCH_H=exch_h(:,:,j),EXCH_M=exch_m(:,:,j), & !output - & pblh=pblh(:,j),KPBL=KPBL(:,j), & !output - & el_pbl=el_pbl(:,:,j), & !output - & dqke=dqke2d,qWT=qWT2d,qSHEAR=qSHEAR2d, & !output - & qBUOY=qBUOY2d,qDISS=qDISS2d, & !output - & qc_bl=qc_bl2d,qi_bl=qi_bl2d,cldfra_bl=cldfra_bl2d, & !output - & bl_mynn_tkeadvect=bl_mynn_tkeadvect, & !input parameter - & tke_budget=tke_budget, & !input parameter - & bl_mynn_cloudpdf=bl_mynn_cloudpdf, & !input parameter - & bl_mynn_mixlength=bl_mynn_mixlength, & !input parameter - & icloud_bl=icloud_bl, & !input parameter - & closure=bl_mynn_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 - & bl_mynn_output=bl_mynn_output, & !input parameter - & bl_mynn_cloudmix=bl_mynn_cloudmix, & !input parameter - & bl_mynn_mixqt=bl_mynn_mixqt, & !input parameter - & edmf_a=edmf_a2d,edmf_w=edmf_w2d, & !output - & edmf_qt=edmf_qt2d,edmf_thl=edmf_thl2d, & !output - & edmf_ent=edmf_ent2d,edmf_qc=edmf_qc2d, & !output - & sub_thl3D=sub_thl2d,sub_sqv3D=sub_sqv2d, & !output - & det_thl3D=det_thl2d,det_sqv3D=det_sqv2d, & !output - & maxwidth=maxwidth(:,j),maxMF=maxMF(:,j), & !output - & ztop_plume=ztop_plume(:,j),ktop_plume=ktop_plume(:,j), & !output - & spp_pbl=spp_pbl,pattern_spp_pbl=pattern_spp_pbl2d, & !input - & RTHRATEN=rthraten(:,:,j), & !input - & FLAG_QI=flag_qi,FLAG_QNI=flag_qni,FLAG_QS=flag_qs, & !input - & FLAG_QC=flag_qc,FLAG_QNC=flag_qnc, & !input - & FLAG_QNWFA=FLAG_QNWFA,FLAG_QNIFA=FLAG_QNIFA, & !input - & FLAG_QNBCA=FLAG_QNBCA,FLAG_OZONE=flag_ozone, & !input - & IDS=ids,IDE=ide,JDS=jds,JDE=jde,KDS=kds,KDE=kde, & !input - & IMS=ims,IME=ime,JMS=jms,JME=jme,KMS=kms,KME=kme, & !input - & ITS=its,ITE=itf,JTS=jts,JTE=jtf,KTS=kts,KTE=kte) !input -!print*,"In mynn wrapper, after bl_mynn_driver" - - !- Convert spec hum to mixing ratio: - do k=kts,ktf - do i=its,itf - RQVBLTEN(i,k,j) = RQVBLTEN(i,k,j)/(1.0 - sqv(i,k)) - RQCBLTEN(i,k,j) = RQCBLTEN(i,k,j)/(1.0 - sqv(i,k)) - RQIBLTEN(i,k,j) = RQIBLTEN(i,k,j)/(1.0 - sqv(i,k)) - enddo - enddo - if (.false.) then !as of now, there is no RQSBLTEN in WRF - do k=kts,ktf - do i=its,itf - RQSBLTEN(i,k,j) = RQSBLTEN(i,k,j)/(1.0 - sqv(i,k)) - enddo - enddo - endif - - !- Collect 3D ouput: - if (icloud_bl > 0) then - do k=kts,ktf - do i=its,itf - qc_bl(i,k,j) = qc_bl2d(i,k)/(1.0 - sqv(i,k)) - qi_bl(i,k,j) = qi_bl2d(i,k)/(1.0 - sqv(i,k)) - cldfra_bl(i,k,j) = cldfra_bl2d(i,k) - enddo - enddo - endif - - if (tke_budget .eq. 1) then - do k=kts,ktf - do i=its,itf - dqke(i,k,j) = dqke2d(i,k) - qwt(i,k,j) = qwt2d(i,k) - qshear(i,k,j) = qshear2d(i,k) - qbuoy(i,k,j) = qbuoy2d(i,k) - qdiss(i,k,j) = qdiss2d(i,k) - enddo - enddo - endif - - if (bl_mynn_output > 0) then - do k=kts,ktf - do i=its,itf - edmf_a(i,k,j) = edmf_a2d(i,k) - edmf_w(i,k,j) = edmf_w2d(i,k) - edmf_qt(i,k,j) = edmf_qt2d(i,k) - edmf_thl(i,k,j) = edmf_thl2d(i,k) - edmf_ent(i,k,j) = edmf_ent2d(i,k) - edmf_qc(i,k,j) = edmf_qc2d(i,k) - sub_thl3d(i,k,j) = sub_thl2d(i,k) - sub_sqv3d(i,k,j) = sub_sqv2d(i,k) - det_thl3d(i,k,j) = det_thl2d(i,k) - det_sqv3d(i,k,j) = det_sqv2d(i,k) - enddo - enddo - endif - - if (debug) then - print* - print*,"===Finished with mynn_bl_driver; output:" - print*,"T:",t3d(its,1,j),t3d(its,2,j),t3d(its,kte,j) - print*,"TH:",th(its,1,j),th(its,2,j),th(its,kte,j) - print*,"rho:",rho(its,1,j),rho(its,2,j),rho(its,kte,j) - print*,"exner:",exner(its,1,j),exner(its,2,j),exner(its,kte,j) - print*,"p:",p(its,1,j),p(its,2,j),p(its,kte,j) - print*,"dz:",dz(its,1,j),dz(its,2,j),dz(its,kte,j) - print*,"u:",u(its,1,j),u(its,2,j),u(its,kte,j) - print*,"v:",v(its,1,j),v(its,2,j),v(its,kte,j) - print*,"sqv:",sqv(its,1),sqv(its,2),sqv(its,kte) - print*,"sqc:",sqc(its,1),sqc(its,2),sqc(its,kte) - print*,"sqi:",sqi(its,1),sqi(its,2),sqi(its,kte) - print*,"rmol:",rmol(its,j)," ust:",ust(its,j) - print*,"dx(its,j)=",dx(its),"initflag=",initflag - print*,"Thetasurf:",ts(its,j) - print*,"HFX:",hfx(its,j)," qfx",qfx(its,j) - print*,"qsfc:",qsfc(its,j)," ps:",ps(its,j) - print*,"wspd:",wspd(its,j) - print*,"znt:",znt(its,j)," delt=",delt - print*,"im=",ite," kte=",kte - print*,"PBLH=",pblh(its,j)," KPBL=",KPBL(its,j)," xland=",xland(its,j) - print*,"ch=",ch(its,j) - print*,"qke:",qke(its,1,j),qke(its,2,j),qke(its,kte,j) - print*,"el_pbl:",el_pbl(its,1,j),el_pbl(its,2,j),el_pbl(its,kte,j) - print*,"Sh3d:",Sh3d(its,1,j),sh3d(its,2,j),sh3d(its,kte,j) - print*,"exch_h:",exch_h(its,1,j),exch_h(its,2,j),exch_h(its,kte,j) - print*,"exch_m:",exch_m(its,1,j),exch_m(its,2,j),exch_m(its,kte,j) - print*,"max cf_bl:",maxval(cldfra_bl(its,:,j)) - print*,"max qc_bl:",maxval(qc_bl(its,:,j)) - print*,"dtdt:",rthblten(its,1,j),rthblten(its,2,j),rthblten(its,kte,j) - print*,"dudt:",rublten(its,1,j),rublten(its,2,j),rublten(its,kte,j) - print*,"dvdt:",rvblten(its,1,j),rvblten(its,2,j),rvblten(its,kte,j) - print*,"dqdt:",rqvblten(its,1,j),rqvblten(its,2,j),rqvblten(its,kte,j) - print*,"ztop_plume:",ztop_plume(its,j)," maxmf:",maxmf(its,j) - print* - endif - - enddo !end j-loop - - !Deallocate all temporary interface arrays - if (bl_mynn_output > 0) then - deallocate(edmf_a2d) - deallocate(edmf_w2d) - deallocate(edmf_qt2d) - deallocate(edmf_thl2d) - deallocate(edmf_ent2d) - deallocate(edmf_qc2d) - deallocate(sub_thl2d) - deallocate(sub_sqv2d) - deallocate(det_thl2d) - deallocate(det_sqv2d) - endif - if (tke_budget .eq. 1) then - deallocate(dqke2d) - deallocate(qwt2d) - deallocate(qshear2d) - deallocate(qbuoy2d) - deallocate(qdiss2d) - endif - if (icloud_bl > 0) then - deallocate(qc_bl2d) - deallocate(qi_bl2d) - deallocate(cldfra_bl2d) - endif - if (flag_qc) deallocate(qc2d) - if (flag_qi) deallocate(qi2d) - if (flag_qs) deallocate(qs2d) - if (flag_qnc) deallocate(qnc2d) - if (flag_qni) deallocate(qni2d) - if (flag_qnwfa)deallocate(qnwfa2d) - if (flag_qnifa)deallocate(qnifa2d) - if (flag_qnbca)deallocate(qnbca2d) - if (spp_pbl > 0) then - deallocate(pattern_spp_pbl2d) - endif - -!print*,"In mynn wrapper, at end" - - CONTAINS - -! ================================================================== - SUBROUTINE moisture_check2(kte, delt, dp, exner, & - qv, qc, qi, th ) - ! - ! 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/temperature 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 - real, dimension(kte), intent(in) :: exner - real, dimension(kte), intent(inout) :: qv, qc, qi, th - integer k - real :: dqc2, dqi2, dqv2, sum, aa, dum - real, parameter :: qvmin1= 1e-8, & !min at k=1 - qvmin = 1e-20, & !min above k=1 - 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) - - !update species - qc(k) = qc(k) + dqc2 - qi(k) = qi(k) + dqi2 - qv(k) = qv(k) - dqc2 - dqi2 - !for theta - !th(k) = th(k) + xlvcp/exner(k)*dqc2 + & - ! xlscp/exner(k)*dqi2 - !for temperature - th(k) = th(k) + xlvcp*dqc2 + & - xlscp*dqi2 - - !then fix qv if lending qv made it negative - if (k .eq. 1) then - dqv2 = max(0.0, qvmin1-qv(k)) !qv deficit (>=0) - qv(k) = qv(k) + dqv2 - qv(k) = max(qv(k),qvmin1) - dqv2 = 0.0 - else - dqv2 = max(0.0, qvmin-qv(k)) !qv deficit (>=0) - qv(k) = qv(k) + dqv2 - qv(k-1)= qv(k-1) - dqv2*dp(k)/dp(k-1) - qv(k) = max(qv(k),qvmin) - endif - 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 - 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_check2 - - END SUBROUTINE mynnedmf_wrapper_run - -!###================================================================= - -END MODULE module_bl_mynn_wrapper diff --git a/phys/module_pbl_driver.F b/phys/module_pbl_driver.F index f703071765..57fb8f0db5 100644 --- a/phys/module_pbl_driver.F +++ b/phys/module_pbl_driver.F @@ -54,7 +54,7 @@ SUBROUTINE pbl_driver( & ,sub_thl3D,sub_sqv3D & ,det_thl3D,det_sqv3D & ,vdfg & - ,maxwidth,maxMF,ztop_plume,ktop_plume & + ,maxwidth,maxMF,ztop_plume & ,spp_pbl,pattern_spp_pbl & ! EEPS ,pek,pep,pek_adv,pep_adv & @@ -199,7 +199,7 @@ SUBROUTINE pbl_driver( & USE module_bl_mfshconvpbl USE module_bl_gbmpbl #if (EM_CORE==1) - USE module_bl_mynn_wrapper + USE module_bl_mynnedmf_driver USE module_bl_eeps USE module_bl_keps USE module_bl_fogdes @@ -595,8 +595,6 @@ SUBROUTINE pbl_driver( & REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, & & INTENT(INOUT):: vdfg - INTEGER, OPTIONAL, DIMENSION( ims:ime , jms:jme ), & - & INTENT(OUT) :: ktop_plume REAL, OPTIONAL, DIMENSION( ims:ime , jms:jme ), & & INTENT(OUT) :: maxwidth,maxMF,ztop_plume @@ -1634,7 +1632,7 @@ SUBROUTINE pbl_driver( & PRESENT( rqniblten ) .AND. PRESENT( qni_curr ) .AND.& PRESENT(qke) .AND. PRESENT(tsq) .AND. & PRESENT(qsq) .AND. PRESENT(cov) .AND. & - PRESENT(rmol) .AND. PRESENT(ch) .AND. & + PRESENT(ch) .AND. & PRESENT(tke_budget) .AND. PRESENT(qke_adv) .AND. & PRESENT(bl_mynn_tkeadvect) ) THEN @@ -1657,7 +1655,7 @@ SUBROUTINE pbl_driver( & ims, ime, jms, jme, kms, kme, kts, kte) end if - CALL mynnedmf_wrapper_run( & + CALL mynnedmf_driver( & &initflag=initflag,restart=restart,cycling=cycling, & &delt=dtbl,dz=dz8w,dxc=dx,znt=znt, & &u=u_phy,v=v_phy,w=w,th=th_phy,qv=qv_curr, & @@ -1667,7 +1665,7 @@ SUBROUTINE pbl_driver( & ! &ozone=ozone, & &p=p_phy,exner=pi_phy,rho=rho,T3D=t_phy, & &xland=xland,ts=tsk,qsfc=qsfc,ps=psfc, & - &ust=ust,ch=ch,hfx=hfx,qfx=qfx,rmol=rmol,wspd=wspd, & + &ust=ust,ch=ch,hfx=hfx,qfx=qfx,wspd=wspd, & &uoce=uoce,voce=voce, & !Ocean currents &Qke=qke,qke_adv=qke_adv,Sh3d=Sh3d,Sm3d=Sm3d, & #if (WRF_CHEM == 1) @@ -1696,7 +1694,7 @@ SUBROUTINE pbl_driver( & &sub_thl3D=sub_thl3D,sub_sqv3D=sub_sqv3D, & &det_thl3D=det_thl3D,det_sqv3D=det_sqv3D, & &maxwidth=maxwidth,maxMF=maxMF, & - &ztop_plume=ztop_plume,ktop_plume=ktop_plume, & + &ztop_plume=ztop_plume, & &RTHRATEN=RTHRATEN, & &bl_mynn_tkeadvect=bl_mynn_tkeadvect, & &tke_budget=tke_budget, & @@ -1731,7 +1729,7 @@ SUBROUTINE pbl_driver( & deallocate (qke_tmp) end if ELSE - WRITE ( message , FMT = '(A,17(L1,1X))' ) & + WRITE ( message , FMT = '(A,16(L1,1X))' ) & 'present: '// & 'qv_curr, '// & 'qc_curr, '// & @@ -1745,7 +1743,6 @@ SUBROUTINE pbl_driver( & 'tsq, '// & 'qsq, '// & 'cov, '// & - 'rmol, '// & 'ch, '// & 'tke_budget, '// & 'qke_adv, '// & @@ -1762,7 +1759,6 @@ SUBROUTINE pbl_driver( & PRESENT( tsq ) , & PRESENT( qsq ) , & PRESENT( cov ) , & - PRESENT( rmol ) , & PRESENT( ch ) , & PRESENT( tke_budget) , & PRESENT( qke_adv ) , & diff --git a/phys/module_physics_init.F b/phys/module_physics_init.F index 9d419edf7d..0e1933dd3f 100644 --- a/phys/module_physics_init.F +++ b/phys/module_physics_init.F @@ -2660,7 +2660,7 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & USE module_bl_mfshconvpbl USE module_bl_gbmpbl #if ( EM_CORE == 1 ) - USE module_bl_mynn_wrapper + USE module_bl_mynnedmf_driver USE module_bl_eeps USE module_bl_temf #if ( WRFPLUS == 1 ) @@ -3840,7 +3840,7 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & IF ((SF_URBAN_PHYSICS.eq.2).OR.(SF_URBAN_PHYSICS.EQ.3)) CALL wrf_error_fatal & ( 'module_physics_init: use ysu (option1), myj (option 2), or boulac (option 8) with BEP/BEM urban scheme' ) - CALL mynnedmf_wrapper_init( & + CALL mynnedmf_init( & &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN,RQCBLTEN, & &RQIBLTEN,QKE, & &restart,allowed_to_read, &