| blob | c1ea9c6417754c7b756890541496f089b7331d94 |
1 !>\file module_bl_mynn.F90
2 !! This file contains the entity of MYNN-EDMF PBL scheme.
3 ! **********************************************************************
4 ! * An improved Mellor-Yamada turbulence closure model *
5 ! * *
6 ! * Original author: M. Nakanishi (N.D.A), naka@nda.ac.jp *
7 ! * Translated into F90 and implemented in WRF-ARW by: *
8 ! * Mariusz Pagowski (NOAA-GSL) *
9 ! * Subsequently developed by: *
10 ! * Joseph Olson, Jaymes Kenyon (NOAA/GSL), *
11 ! * Wayne Angevine (NOAA/CSL), Kay Suselj (NASA/JPL), *
12 ! * Franciano Puhales (UFSM), Laura Fowler (NCAR), *
13 ! * Elynn Wu (UCSD), and Jordan Schnell (NOAA/GSL) *
14 ! * *
15 ! * Contents: *
16 ! * *
17 ! * mynn_bl_driver - main subroutine which calls all other routines *
18 ! * -------------- *
19 ! * 1. mym_initialize (to be called once initially) *
20 ! * gives the closure constants and initializes the turbulent *
21 ! * quantities. *
22 ! * 2. get_pblh *
23 ! * Calculates the boundary layer height *
24 ! * 3. scale_aware *
25 ! * Calculates scale-adaptive tapering functions *
26 ! * 4. mym_condensation *
27 ! * determines the liquid water content and the cloud fraction *
28 ! * diagnostically. *
29 ! * 5. dmp_mf *
30 ! * Calls the (nonlocal) mass-flux component *
31 ! * 6. ddmf_jpl *
32 ! * Calls the downdraft mass-flux component *
33 ! * (-) mym_level2 (called in the other subroutines) *
34 ! * calculates the stability functions at Level 2. *
35 ! * (-) mym_length (called in the other subroutines) *
36 ! * calculates the master length scale. *
37 ! * 7. mym_turbulence *
38 ! * calculates the vertical diffusivity coefficients and the *
39 ! * production terms for the turbulent quantities. *
40 ! * 8. mym_predict *
41 ! * predicts the turbulent quantities at the next step. *
42 ! * *
43 ! * call mym_initialize *
44 ! * | *
45 ! * |<----------------+ *
46 ! * | | *
47 ! * call get_pblh | *
48 ! * call scale_aware | *
49 ! * call mym_condensation | *
50 ! * call dmp_mf | *
51 ! * call ddmf_jpl | *
52 ! * call mym_turbulence | *
53 ! * call mym_predict | *
54 ! * | | *
55 ! * |-----------------+ *
56 ! * | *
57 ! * end *
58 ! * *
59 ! * Variables worthy of special mention: *
60 ! * tref : Reference temperature *
61 ! * thl : Liquid water potential temperature *
62 ! * qw : Total water (water vapor+liquid water) content *
63 ! * ql : Liquid water content *
64 ! * vt, vq : Functions for computing the buoyancy flux *
65 ! * qke : 2 * TKE *
66 ! * el : mixing length *
67 ! * *
68 ! * If the water contents are unnecessary, e.g., in the case of *
69 ! * ocean models, thl is the potential temperature and qw, ql, vt *
70 ! * and vq are all zero. *
71 ! * *
72 ! * Grid arrangement: *
73 ! * k+1 +---------+ *
74 ! * | | i = 1 - nx *
75 ! * (k) | * | k = 1 - nz *
76 ! * | | *
77 ! * k +---------+ *
78 ! * i (i) i+1 *
79 ! * *
80 ! * All the predicted variables are defined at the center (*) of *
81 ! * the grid boxes. The diffusivity coefficients and two of their *
82 ! * components (el and stability functions sh & sm) are, however, *
83 ! * defined on the walls of the grid boxes. *
84 ! * # Upper boundary values are given at k=nz. *
85 ! * *
86 ! * References: *
87 ! * 1. Nakanishi, M., 2001: *
88 ! * Boundary-Layer Meteor., 99, 349-378. *
89 ! * 2. Nakanishi, M. and H. Niino, 2004: *
90 ! * Boundary-Layer Meteor., 112, 1-31. *
91 ! * 3. Nakanishi, M. and H. Niino, 2006: *
92 ! * Boundary-Layer Meteor., 119, 397-407. *
93 ! * 4. Nakanishi, M. and H. Niino, 2009: *
94 ! * Jour. Meteor. Soc. Japan, 87, 895-912. *
95 ! * 5. Olson J. and coauthors, 2019: A description of the *
96 ! * MYNN-EDMF scheme and coupling to other components in *
97 ! * WRF-ARW. NOAA Tech. Memo. OAR GSD, 61, 37 pp., *
98 ! * https://doi.org/10.25923/n9wm-be49. *
99 ! * 6. Puhales, Franciano S. and coauthors, 2020: Turbulent *
100 ! * Kinetic Energy Budget for MYNN-EDMF PBL Scheme in WRF model.*
101 ! * Universidade Federal de Santa Maria Technical Note. 9 pp. *
102 ! **********************************************************************
103 ! ==================================================================
104 ! Notes on original implementation into WRF-ARW
105 ! changes to original code:
106 ! 1. code is 1D (in z)
107 ! 2. option to advect TKE, but not the covariances and variances
108 ! 3. Cranck-Nicholson replaced with the implicit scheme
109 ! 4. removed terrain-dependent grid since input in WRF in actual
110 ! distances in z[m]
111 ! 5. cosmetic changes to adhere to WRF standard (remove common blocks,
112 ! intent etc)
113 !-------------------------------------------------------------------
114 ! Further modifications post-implementation
115 !
116 ! 1. Addition of BouLac mixing length in the free atmosphere.
117 ! 2. Changed the turbulent mixing length to be integrated from the
118 ! surface to the top of the BL + a transition layer depth.
119 ! v3.4.1: Option to use Kitamura/Canuto modification which removes
120 ! the critical Richardson number and negative TKE (default).
121 ! Hybrid PBL height diagnostic, which blends a theta-v-based
122 ! definition in neutral/convective BL and a TKE-based definition
123 ! in stable conditions.
124 ! TKE budget output option
125 ! v3.5.0: TKE advection option (bl_mynn_tkeadvect)
126 ! v3.5.1: Fog deposition related changes.
127 ! v3.6.0: Removed fog deposition from the calculation of tendencies
128 ! Added mixing of qc, qi, qni
129 ! Added output for wstar, delta, TKE_PBL, & KPBL for correct
130 ! coupling to shcu schemes
131 ! v3.8.0: Added subgrid scale cloud output for coupling to radiation
132 ! schemes (activated by setting icloud_bl =1 in phys namelist).
133 ! Added WRF_DEBUG prints (at level 3000)
134 ! Added Tripoli and Cotton (1981) correction.
135 ! Added namelist option bl_mynn_cloudmix to test effect of mixing
136 ! cloud species (default = 1: on).
137 ! Added mass-flux option (bl_mynn_edmf, = 1 for DMP mass-flux, 0: off).
138 ! Related options:
139 ! bl_mynn_edmf_mom = 1 : activate momentum transport in MF scheme
140 ! bl_mynn_edmf_tke = 1 : activate TKE transport in MF scheme
141 ! Added mixing length option (bl_mynn_mixlength, see notes below)
142 ! Added more sophisticated saturation checks, following Thompson scheme
143 ! Added new cloud PDF option (bl_mynn_cloudpdf = 2) from Chaboureau
144 ! and Bechtold (2002, JAS, with mods)
145 ! Added capability to mix chemical species when env variable
146 ! WRF_CHEM = 1, thanks to Wayne Angevine.
147 ! Added scale-aware mixing length, following Junshi Ito's work
148 ! Ito et al. (2015, BLM).
149 ! v3.9.0 Improvement to the mass-flux scheme (dynamic number of plumes,
150 ! better plume/cloud depth, significant speed up, better cloud
151 ! fraction).
152 ! Added Stochastic Parameter Perturbation (SPP) implementation.
153 ! Many miscellaneous tweaks to the mixing lengths and stratus
154 ! component of the subgrid clouds.
155 ! v.4.0 Removed or added alternatives to WRF-specific functions/modules
156 ! for the sake of portability to other models.
157 ! the sake of portability to other models.
158 ! Further refinement of mass-flux scheme from SCM experiments with
159 ! Wayne Angevine: switch to linear entrainment and back to
160 ! Simpson and Wiggert-type w-equation.
161 ! Addition of TKE production due to radiation cooling at top of
162 ! clouds (proto-version); not activated by default.
163 ! Some code rewrites to move if-thens out of loops in an attempt to
164 ! improve computational efficiency.
165 ! New tridiagonal solver, which is supposedly 14% faster and more
166 ! conservative. Impact seems very small.
167 ! Many miscellaneous tweaks to the mixing lengths and stratus
168 ! component of the subgrid-scale (SGS) clouds.
169 ! v4.1 Big improvements in downward SW radiation due to revision of subgrid clouds
170 ! - better cloud fraction and subgrid scale mixing ratios.
171 ! - may experience a small cool bias during the daytime now that high
172 ! SW-down bias is greatly reduced...
173 ! Some tweaks to increase the turbulent mixing during the daytime for
174 ! bl_mynn_mixlength option 2 to alleviate cool bias (very small impact).
175 ! Improved ensemble spread from changes to SPP in MYNN
176 ! - now perturbing eddy diffusivity and eddy viscosity directly
177 ! - now perturbing background rh (in SGS cloud calc only)
178 ! - now perturbing entrainment rates in mass-flux scheme
179 ! Added IF checks (within IFDEFS) to protect mixchem code from being used
180 ! when HRRR smoke is used (no impact on regular non-wrf chem use)
181 ! Important bug fix for wrf chem when transporting chemical species in MF scheme
182 ! Removed 2nd mass-flux scheme (no only bl_mynn_edmf = 1, no option 2)
183 ! Removed unused stochastic code for mass-flux scheme
184 ! Changed mass-flux scheme to be integrated on interface levels instead of
185 ! mass levels - impact is small
186 ! Added option to mix 2nd moments in MYNN as opposed to the scalar_pblmix option.
187 ! - activated with bl_mynn_mixscalars = 1; this sets scalar_pblmix = 0
188 ! - added tridagonal solver used in scalar_pblmix option to duplicate tendencies
189 ! - this alone changes the interface call considerably from v4.0.
190 ! Slight revision to TKE production due to radiation cooling at top of clouds
191 ! Added the non-Guassian buoyancy flux function of Bechtold and Siebesma (1998, JAS).
192 ! - improves TKE in SGS clouds
193 ! Added heating due to dissipation of TKE (small impact, maybe + 0.1 C daytime PBL temp)
194 ! Misc changes made for FV3/MPAS compatibility
195 ! v4.2 A series of small tweaks to help reduce a cold bias in the PBL:
196 ! - slight increase in diffusion in convective conditions
197 ! - relaxed criteria for mass-flux activation/strength
198 ! - added capability to cycle TKE for continuity in hourly updating HRRR
199 ! - added effects of compensational environmental subsidence in mass-flux scheme,
200 ! which resulted in tweaks to detrainment rates.
201 ! Bug fix for diagnostic-decay of SGS clouds - noticed by Greg Thompson. This has
202 ! a very small, but primarily positive, impact on SW-down biases.
203 ! Tweak to calculation of KPBL - urged by Laura Fowler - to make more intuitive.
204 ! Tweak to temperature range of blending for saturation check (water to ice). This
205 ! slightly reduces excessive SGS clouds in polar region. No impact warm clouds.
206 ! Added namelist option bl_mynn_output (0 or 1) to suppress or activate the
207 ! allocation and output of 10 3D variables. Most people will want this
208 ! set to 0 (default) to save memory and disk space.
209 ! Added new array qi_bl as opposed to using qc_bl for both SGS qc and qi. This
210 ! gives us more control of the magnitudes which can be confounded by using
211 ! a single array. As a results, many subroutines needed to be modified,
212 ! especially mym_condensation.
213 ! Added the blending of the stratus component of the SGS clouds to the mass-flux
214 ! clouds to account for situations where stratus and cumulus may exist in the
215 ! grid cell.
216 ! Misc small-impact bugfixes:
217 ! 1) dz was incorrectly indexed in mym_condensation
218 ! 2) configurations with icloud_bl = 0 were using uninitialized arrays
219 ! v4.5 / CCPP
220 ! This version includes many modifications that proved valuable in the global
221 ! framework and removes some key lingering bugs in the mixing of chemical species.
222 ! TKE Budget output fixed (Puhales, 2020-12)
223 ! New option for stability function: (Puhales, 2020-12)
224 ! bl_mynn_stfunc = 0 (original, Kansas-type function, Paulson, 1970 )
225 ! bl_mynn_stfunc = 1 (expanded range, same as used for Jimenez et al (MWR)
226 ! see the Technical Note for this implementation (small impact).
227 ! Improved conservation of momentum and higher-order moments.
228 ! Important bug fixes for mixing of chemical species.
229 ! Addition of pressure-gradient effects on updraft momentum transport.
230 ! Addition of bl_mynn_closure option = 2.5, 2.6, or 3.0
231 ! Addition of higher-order moments for sigma when using
232 ! bl_mynn_cloudpdf = 2 (Chab-Becht).
233 ! Removed WRF_CHEM dependencies.
234 ! Many miscellaneous tweaks.
235 ! v4.6 / CCPP
236 ! Some code optimization. Removed many conditions from loops. Redesigned the mass-
237 ! flux scheme to use 8 plumes instead of a variable n plumes. This results in
238 ! the removal of the output variable "nudprafts" and adds maxwidth and ztop_plume.
239 ! Revision option bl_mynn_cloudpdf = 2, which now ensures cloud fractions for all
240 ! optically relevant mixing ratios (tip from Greg Thompson). Also, added flexibility
241 ! for tuning near-surface cloud fractions to remove excess fog/low ceilings.
242 ! Now outputs all SGS cloud mixing ratios as grid-mean values, not in-cloud. This
243 ! results in a change in the pre-radiation code to no longer multiply mixing ratios
244 ! by cloud fractions.
245 ! Bug fix for the momentum transport.
246 ! Lots of code cleanup: removal of test code, comments, changing text case, etc.
247 ! Many misc tuning/tweaks.
248 !
249 ! Many of these changes are now documented in references listed above.
250 !====================================================================
252 MODULE module_bl_mynn
254 use module_bl_mynn_common,only: &
255 cp , cpv , cliq , cice , &
256 p608 , ep_2 , ep_3 , gtr , &
257 grav , g_inv , karman , p1000mb , &
258 rcp , r_d , r_v , rk , &
259 rvovrd , svp1 , svp2 , svp3 , &
260 xlf , xlv , xls , xlscp , &
261 xlvcp , tv0 , tv1 , tref , &
262 zero , half , one , two , &
263 onethird , twothirds , tkmin , t0c , &
264 tice , kind_phys
267 IMPLICIT NONE
269 !===================================================================
270 ! From here on, these are MYNN-specific parameters:
271 ! The parameters below depend on stability functions of module_sf_mynn.
272 real(kind_phys), parameter :: cphm_st=5.0, cphm_unst=16.0, &
273 cphh_st=5.0, cphh_unst=16.0
275 ! Closure constants
276 real(kind_phys), parameter :: &
277 &pr = 0.74, &
278 &g1 = 0.235, & ! NN2009 = 0.235
279 &b1 = 24.0, &
280 &b2 = 15.0, & ! CKmod NN2009
281 &c2 = 0.729, & ! 0.729, & !0.75, &
282 &c3 = 0.340, & ! 0.340, & !0.352, &
283 &c4 = 0.0, &
284 &c5 = 0.2, &
285 &a1 = b1*( 1.0-3.0*g1 )/6.0, &
286 ! &c1 = g1 -1.0/( 3.0*a1*b1**(1.0/3.0) ), &
287 &c1 = g1 -1.0/( 3.0*a1*2.88449914061481660), &
288 &a2 = a1*( g1-c1 )/( g1*pr ), &
289 &g2 = b2/b1*( 1.0-c3 ) +2.0*a1/b1*( 3.0-2.0*c2 )
291 real(kind_phys), parameter :: &
292 &cc2 = 1.0-c2, &
293 &cc3 = 1.0-c3, &
294 &e1c = 3.0*a2*b2*cc3, &
295 &e2c = 9.0*a1*a2*cc2, &
296 &e3c = 9.0*a2*a2*cc2*( 1.0-c5 ), &
297 &e4c = 12.0*a1*a2*cc2, &
298 &e5c = 6.0*a1*a1
300 ! Constants for min tke in elt integration (qmin), max z/L in els (zmax),
301 ! and factor for eddy viscosity for TKE (Kq = Sqfac*Km):
302 real(kind_phys), parameter :: qmin=0.0, zmax=1.0, Sqfac=3.0
303 ! Note that the following mixing-length constants are now specified in mym_length
304 ! &cns=3.5, alp1=0.23, alp2=0.3, alp3=3.0, alp4=10.0, alp5=0.2
306 real(kind_phys), parameter :: qkemin=1.e-3
307 real(kind_phys), parameter :: tliq = 269. !all hydrometeors are liquid when T > tliq
309 ! Constants for cloud PDF (mym_condensation)
310 real(kind_phys), parameter :: rr2=0.7071068, rrp=0.3989423
312 !>Use Canuto/Kitamura mod (remove Ric and negative TKE) (1:yes, 0:no)
313 !!For more info, see Canuto et al. (2008 JAS) and Kitamura (Journal of the
314 !!Meteorological Society of Japan, Vol. 88, No. 5, pp. 857-864, 2010).
315 !!Note that this change required further modification of other parameters
316 !!above (c2, c3). If you want to remove this option, set c2 and c3 constants
317 !!(above) back to NN2009 values (see commented out lines next to the
318 !!parameters above). This only removes the negative TKE problem
319 !!but does not necessarily improve performance - neutral impact.
320 real(kind_phys), parameter :: CKmod=1.
322 !>Use Ito et al. (2015, BLM) scale-aware (0: no, 1: yes). Note that this also has impacts
323 !!on the cloud PDF and mass-flux scheme, using LES-derived similarity function.
324 real(kind_phys), parameter :: scaleaware=1.
326 !>Of the following the options, use one OR the other, not both.
327 !>Adding top-down diffusion driven by cloud-top radiative cooling
328 integer, parameter :: bl_mynn_topdown = 0
329 !>Option to activate downdrafts, from Elynn Wu (0: deactive, 1: active)
330 integer, parameter :: bl_mynn_edmf_dd = 0
332 !>Option to activate heating due to dissipation of TKE (to activate, set to 1.0)
333 integer, parameter :: dheat_opt = 1
335 !Option to activate environmental subsidence in mass-flux scheme
336 logical, parameter :: env_subs = .false.
338 !Option to switch flux-profile relationship for surface (from Puhales et al. 2020)
339 !0: use original Dyer-Hicks, 1: use Cheng-Brustaert and Blended COARE
340 integer, parameter :: bl_mynn_stfunc = 1
342 !option to print out more stuff for debugging purposes
343 logical, parameter :: debug_code = .false.
344 integer, parameter :: idbg = 23 !specific i-point to write out
346 ! Used in WRF-ARW module_physics_init.F
347 integer :: mynn_level
350 CONTAINS
352 ! ==================================================================
353 !>\ingroup gsd_mynn_edmf
354 !! This subroutine is the GSD MYNN-EDNF PBL driver routine,which
355 !! encompassed the majority of the subroutines that comprise the
356 !! procedures that ultimately solve for tendencies of
357 !! \f$U, V, \theta, q_v, q_c, and q_i\f$.
358 !!\section gen_mynn_bl_driver GSD mynn_bl_driver General Algorithm
359 !> @{
360 SUBROUTINE mynn_bl_driver( &
361 &initflag,restart,cycling, &
362 &delt,dz,dx,znt, &
363 &u,v,w,th,sqv3d,sqc3d,sqi3d, &
364 &sqs3d,qnc,qni, &
365 &qnwfa,qnifa,qnbca,ozone, &
366 &p,exner,rho,t3d, &
367 &xland,ts,qsfc,ps, &
368 &ust,ch,hfx,qfx,rmol,wspd, &
369 &uoce,voce, & !ocean current
370 &qke,qke_adv, &
371 &sh3d,sm3d, &
372 &nchem,kdvel,ndvel, & !smoke/chem variables
373 &chem3d,vdep, &
374 &frp,emis_ant_no, &
375 &mix_chem,enh_mix, & !note: these arrays/flags are still under development
376 &rrfs_sd,smoke_dbg, & !end smoke/chem variables
377 &tsq,qsq,cov, &
378 &rublten,rvblten,rthblten, &
379 &rqvblten,rqcblten,rqiblten, &
380 &rqncblten,rqniblten,rqsblten, &
381 &rqnwfablten,rqnifablten, &
382 &rqnbcablten,dozone, &
383 &exch_h,exch_m, &
384 &pblh,kpbl, &
385 &el_pbl, &
386 &dqke,qwt,qshear,qbuoy,qdiss, &
387 &qc_bl,qi_bl,cldfra_bl, &
388 &bl_mynn_tkeadvect, &
389 &tke_budget, &
390 &bl_mynn_cloudpdf, &
391 &bl_mynn_mixlength, &
392 &icloud_bl, &
393 &closure, &
394 &bl_mynn_edmf, &
395 &bl_mynn_edmf_mom, &
396 &bl_mynn_edmf_tke, &
397 &bl_mynn_mixscalars, &
398 &bl_mynn_output, &
399 &bl_mynn_cloudmix,bl_mynn_mixqt, &
400 &edmf_a,edmf_w,edmf_qt, &
401 &edmf_thl,edmf_ent,edmf_qc, &
402 &sub_thl3D,sub_sqv3D, &
403 &det_thl3D,det_sqv3D, &
404 &maxwidth,maxMF,ztop_plume, &
405 &ktop_plume, &
406 &spp_pbl,pattern_spp_pbl, &
407 &rthraten, &
408 &FLAG_QC,FLAG_QI,FLAG_QNC, &
409 &FLAG_QNI,FLAG_QS, &
410 &FLAG_QNWFA,FLAG_QNIFA, &
411 &FLAG_QNBCA,FLAG_OZONE, &
412 &IDS,IDE,JDS,JDE,KDS,KDE, &
413 &IMS,IME,JMS,JME,KMS,KME, &
414 &ITS,ITE,JTS,JTE,KTS,KTE )
416 !-------------------------------------------------------------------
418 integer, intent(in) :: initflag
419 !INPUT NAMELIST OPTIONS:
420 logical, intent(in) :: restart,cycling
421 integer, intent(in) :: tke_budget
422 integer, intent(in) :: bl_mynn_cloudpdf
423 integer, intent(in) :: bl_mynn_mixlength
424 integer, intent(in) :: bl_mynn_edmf
425 logical, intent(in) :: bl_mynn_tkeadvect
426 integer, intent(in) :: bl_mynn_edmf_mom
427 integer, intent(in) :: bl_mynn_edmf_tke
428 integer, intent(in) :: bl_mynn_mixscalars
429 integer, intent(in) :: bl_mynn_output
430 integer, intent(in) :: bl_mynn_cloudmix
431 integer, intent(in) :: bl_mynn_mixqt
432 integer, intent(in) :: icloud_bl
433 real(kind_phys), intent(in) :: closure
435 logical, intent(in) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,&
436 FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA, &
437 FLAG_OZONE,FLAG_QS
439 logical, intent(in) :: mix_chem,enh_mix,rrfs_sd,smoke_dbg
441 integer, intent(in) :: &
442 & IDS,IDE,JDS,JDE,KDS,KDE &
443 &,IMS,IME,JMS,JME,KMS,KME &
444 &,ITS,ITE,JTS,JTE,KTS,KTE
446 #ifdef HARDCODE_VERTICAL
447 # define kts 1
448 # define kte HARDCODE_VERTICAL
449 #endif
451 ! initflag > 0 for TRUE
452 ! else for FALSE
453 ! closure : <= 2.5; Level 2.5
454 ! 2.5< and <3; Level 2.6
455 ! = 3; Level 3
457 ! SGT: Changed this to use assumed shape arrays (dimension(:,:,:)) with no "optional" arguments
458 ! to prevent a crash on Cheyenne. Do not change it back without testing if the code runs
459 ! on Cheyenne with the GNU compiler.
461 real(kind_phys), intent(in) :: delt
462 real(kind_phys), dimension(ims:ime), intent(in) :: dx
463 real(kind_phys), dimension(ims:ime,kms:kme), intent(in) :: dz, &
464 &u,v,w,th,sqv3D,p,exner,rho,T3D
465 real(kind_phys), dimension(ims:ime,kms:kme), optional, intent(in) :: &
466 &sqc3D,sqi3D,sqs3D,qni,qnc,qnwfa,qnifa,qnbca
467 real(kind_phys), dimension(ims:ime,kms:kme), optional,intent(in):: ozone
468 real(kind_phys), dimension(ims:ime), intent(in):: ust, &
469 &ch,qsfc,ps,wspd
470 real(kind_phys), dimension(ims:ime,kms:kme), intent(inout) :: &
471 &Qke,Tsq,Qsq,Cov,qke_adv
472 real(kind_phys), dimension(ims:ime,kms:kme), intent(inout) :: &
473 &rublten,rvblten,rthblten,rqvblten,rqcblten, &
474 &rqiblten,rqsblten,rqniblten,rqncblten, &
475 &rqnwfablten,rqnifablten,rqnbcablten
476 real(kind_phys), dimension(ims:ime,kms:kme), intent(inout) :: dozone
477 real(kind_phys), dimension(ims:ime,kms:kme), intent(in) :: rthraten
479 real(kind_phys), dimension(ims:ime,kms:kme), intent(out) :: exch_h,exch_m
480 real(kind_phys), dimension(ims:ime), intent(in) :: xland, &
481 &ts,znt,hfx,qfx,uoce,voce
483 !These 10 arrays are only allocated when bl_mynn_output > 0
484 real(kind_phys), dimension(ims:ime,kms:kme), optional, intent(inout) :: &
485 & edmf_a,edmf_w,edmf_qt,edmf_thl,edmf_ent,edmf_qc, &
486 & sub_thl3D,sub_sqv3D,det_thl3D,det_sqv3D
488 ! real, dimension(ims:ime,kms:kme) :: &
489 ! & edmf_a_dd,edmf_w_dd,edmf_qt_dd,edmf_thl_dd,edmf_ent_dd,edmf_qc_dd
491 real(kind_phys), dimension(ims:ime), intent(inout) :: pblh
492 real(kind_phys), dimension(ims:ime), intent(inout) :: rmol
494 real(kind_phys), dimension(ims:ime) :: psig_bl,psig_shcu
496 integer,dimension(ims:ime),intent(inout) :: &
497 &KPBL,ktop_plume
499 real(kind_phys), dimension(ims:ime), intent(out) :: &
500 &maxmf,maxwidth,ztop_plume
502 real(kind_phys), dimension(ims:ime,kms:kme), intent(inout) :: el_pbl
504 real(kind_phys), dimension(ims:ime,kms:kme), optional, intent(inout) :: &
505 &qWT,qSHEAR,qBUOY,qDISS,dqke
506 ! 3D budget arrays are not allocated when tke_budget == 0
507 ! 1D (local) budget arrays are used for passing between subroutines.
508 real(kind_phys), dimension(kts:kte) :: &
509 &qwt1,qshear1,qbuoy1,qdiss1,dqke1,diss_heat
511 real(kind_phys), dimension(ims:ime,kms:kme), intent(out) :: Sh3D,Sm3D
513 real(kind_phys), dimension(ims:ime,kms:kme), intent(inout) :: &
514 &qc_bl,qi_bl,cldfra_bl
515 real(kind_phys), dimension(kts:kte) :: qc_bl1D,qi_bl1D, &
516 &cldfra_bl1D,qc_bl1D_old,qi_bl1D_old,cldfra_bl1D_old
518 ! smoke/chemical arrays
519 integer, intent(IN ) :: nchem, kdvel, ndvel
520 real(kind_phys), dimension(ims:ime,kms:kme,nchem), optional, intent(inout) :: chem3d
521 real(kind_phys), dimension(ims:ime, ndvel), optional, intent(in) :: vdep
522 real(kind_phys), dimension(ims:ime), optional, intent(in) :: frp,EMIS_ANT_NO
523 !local
524 real(kind_phys), dimension(kts:kte ,nchem) :: chem1
525 real(kind_phys), dimension(kts:kte+1,nchem) :: s_awchem1
526 real(kind_phys), dimension(ndvel) :: vd1
527 integer :: ic
529 !local vars
530 integer :: ITF,JTF,KTF, IMD,JMD
531 integer :: i,j,k,kproblem
532 real(kind_phys), dimension(kts:kte) :: &
533 &thl,tl,qv1,qc1,qi1,qs1,sqw, &
534 &el, dfm, dfh, dfq, tcd, qcd, pdk, pdt, pdq, pdc, &
535 &vt, vq, sgm, kzero
536 real(kind_phys), dimension(kts:kte) :: &
537 &thetav,sh,sm,u1,v1,w1,p1, &
538 &ex1,dz1,th1,tk1,rho1,qke1,tsq1,qsq1,cov1, &
539 &sqv,sqi,sqc,sqs, &
540 &du1,dv1,dth1,dqv1,dqc1,dqi1,dqs1,ozone1, &
541 &k_m1,k_h1,qni1,dqni1,qnc1,dqnc1,qnwfa1,qnifa1, &
542 &qnbca1,dqnwfa1,dqnifa1,dqnbca1,dozone1
544 !mass-flux variables
545 real(kind_phys), dimension(kts:kte) :: &
546 &dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf
547 real(kind_phys), dimension(kts:kte) :: &
548 &edmf_a1,edmf_w1,edmf_qt1,edmf_thl1, &
549 &edmf_ent1,edmf_qc1
550 real(kind_phys), dimension(kts:kte) :: &
551 &edmf_a_dd1,edmf_w_dd1,edmf_qt_dd1,edmf_thl_dd1, &
552 &edmf_ent_dd1,edmf_qc_dd1
553 real(kind_phys), dimension(kts:kte) :: &
554 &sub_thl,sub_sqv,sub_u,sub_v, &
555 &det_thl,det_sqv,det_sqc,det_u,det_v
556 real(kind_phys), dimension(kts:kte+1) :: &
557 &s_aw1,s_awthl1,s_awqt1, &
558 &s_awqv1,s_awqc1,s_awu1,s_awv1,s_awqke1, &
559 &s_awqnc1,s_awqni1,s_awqnwfa1,s_awqnifa1, &
560 &s_awqnbca1
561 real(kind_phys), dimension(kts:kte+1) :: &
562 &sd_aw1,sd_awthl1,sd_awqt1, &
563 &sd_awqv1,sd_awqc1,sd_awu1,sd_awv1,sd_awqke1
565 real(kind_phys), dimension(kts:kte+1) :: zw
566 real(kind_phys) :: cpm,sqcg,flt,fltv,flq,flqv,flqc, &
567 &pmz,phh,exnerg,zet,phi_m, &
568 &afk,abk,ts_decay, qc_bl2, qi_bl2, &
569 &th_sfc,wsp
571 !top-down diffusion
572 real(kind_phys), dimension(ITS:ITE) :: maxKHtopdown
573 real(kind_phys), dimension(kts:kte) :: KHtopdown,TKEprodTD
575 logical :: INITIALIZE_QKE,problem
577 ! Stochastic fields
578 integer, intent(in) :: spp_pbl
579 real(kind_phys), dimension(ims:ime,kms:kme), optional, intent(in) :: pattern_spp_pbl
580 real(kind_phys), dimension(kts:kte) :: rstoch_col
582 ! Substepping TKE
583 integer :: nsub
584 real(kind_phys) :: delt2
587 if (debug_code) then !check incoming values
588 do i=its,ite
589 problem = .false.
590 do k=kts,kte
591 wsp = sqrt(u(i,k)**2 + v(i,k)**2)
592 if (abs(hfx(i)) > 1200. .or. abs(qfx(i)) > 0.001 .or. &
593 wsp > 200. .or. t3d(i,k) > 360. .or. t3d(i,k) < 160. .or. &
594 sqv3d(i,k)< 0.0 .or. sqc3d(i,k)< 0.0 ) then
595 kproblem = k
596 problem = .true.
597 print*,"Incoming problem at: i=",i," k=1"
598 print*," QFX=",qfx(i)," HFX=",hfx(i)
599 print*," wsp=",wsp," T=",t3d(i,k)
600 print*," qv=",sqv3d(i,k)," qc=",sqc3d(i,k)
601 print*," u*=",ust(i)," wspd=",wspd(i)
602 print*," xland=",xland(i)," ts=",ts(i)
603 print*," z/L=",0.5*dz(i,1)*rmol(i)," ps=",ps(i)
604 print*," znt=",znt(i)," dx=",dx(i)
605 endif
606 enddo
607 if (problem) then
608 print*,"===tk:",t3d(i,max(kproblem-3,1):min(kproblem+3,kte))
609 print*,"===qv:",sqv3d(i,max(kproblem-3,1):min(kproblem+3,kte))
610 print*,"===qc:",sqc3d(i,max(kproblem-3,1):min(kproblem+3,kte))
611 print*,"===qi:",sqi3d(i,max(kproblem-3,1):min(kproblem+3,kte))
612 print*,"====u:",u(i,max(kproblem-3,1):min(kproblem+3,kte))
613 print*,"====v:",v(i,max(kproblem-3,1):min(kproblem+3,kte))
614 endif
615 enddo
616 endif
618 !*** Begin debugging
619 IMD=(IMS+IME)/2
620 JMD=(JMS+JME)/2
621 !*** End debugging
623 JTF=JTE
624 ITF=ITE
625 KTF=KTE
627 IF (bl_mynn_output > 0) THEN !research mode
628 edmf_a(its:ite,kts:kte)=0.
629 edmf_w(its:ite,kts:kte)=0.
630 edmf_qt(its:ite,kts:kte)=0.
631 edmf_thl(its:ite,kts:kte)=0.
632 edmf_ent(its:ite,kts:kte)=0.
633 edmf_qc(its:ite,kts:kte)=0.
634 sub_thl3D(its:ite,kts:kte)=0.
635 sub_sqv3D(its:ite,kts:kte)=0.
636 det_thl3D(its:ite,kts:kte)=0.
637 det_sqv3D(its:ite,kts:kte)=0.
639 !edmf_a_dd(its:ite,kts:kte)=0.
640 !edmf_w_dd(its:ite,kts:kte)=0.
641 !edmf_qt_dd(its:ite,kts:kte)=0.
642 !edmf_thl_dd(its:ite,kts:kte)=0.
643 !edmf_ent_dd(its:ite,kts:kte)=0.
644 !edmf_qc_dd(its:ite,kts:kte)=0.
645 ENDIF
646 ktop_plume(its:ite)=0 !int
647 ztop_plume(its:ite)=0.
648 maxwidth(its:ite)=0.
649 maxmf(its:ite)=0.
650 maxKHtopdown(its:ite)=0.
651 kzero(kts:kte)=0.
653 ! DH* CHECK HOW MUCH OF THIS INIT IF-BLOCK IS ACTUALLY NEEDED FOR RESTARTS
654 !> - Within the MYNN-EDMF, there is a dependecy check for the first time step,
655 !! If true, a three-dimensional initialization loop is entered. Within this loop,
656 !! several arrays are initialized and k-oriented (vertical) subroutines are called
657 !! at every i and j point, corresponding to the x- and y- directions, respectively.
658 IF (initflag > 0 .and. .not.restart) THEN
660 !Test to see if we want to initialize qke
661 IF ( (restart .or. cycling)) THEN
662 IF (MAXVAL(QKE(its:ite,kts)) < 0.0002) THEN
663 INITIALIZE_QKE = .TRUE.
664 !print*,"QKE is too small, must initialize"
665 ELSE
666 INITIALIZE_QKE = .FALSE.
667 !print*,"Using background QKE, will not initialize"
668 ENDIF
669 ELSE ! not cycling or restarting:
670 INITIALIZE_QKE = .TRUE.
671 !print*,"not restart nor cycling, must initialize QKE"
672 ENDIF
674 if (.not.restart .or. .not.cycling) THEN
675 Sh3D(its:ite,kts:kte)=0.
676 Sm3D(its:ite,kts:kte)=0.
677 el_pbl(its:ite,kts:kte)=0.
678 tsq(its:ite,kts:kte)=0.
679 qsq(its:ite,kts:kte)=0.
680 cov(its:ite,kts:kte)=0.
681 cldfra_bl(its:ite,kts:kte)=0.
682 qc_bl(its:ite,kts:kte)=0.
683 qke(its:ite,kts:kte)=0.
684 else
685 qc_bl1D(kts:kte)=0.0
686 qi_bl1D(kts:kte)=0.0
687 cldfra_bl1D(kts:kte)=0.0
688 end if
689 dqc1(kts:kte)=0.0
690 dqi1(kts:kte)=0.0
691 dqni1(kts:kte)=0.0
692 dqnc1(kts:kte)=0.0
693 dqnwfa1(kts:kte)=0.0
694 dqnifa1(kts:kte)=0.0
695 dqnbca1(kts:kte)=0.0
696 dozone1(kts:kte)=0.0
697 qc_bl1D_old(kts:kte)=0.0
698 cldfra_bl1D_old(kts:kte)=0.0
699 edmf_a1(kts:kte)=0.0
700 edmf_w1(kts:kte)=0.0
701 edmf_qc1(kts:kte)=0.0
702 edmf_a_dd1(kts:kte)=0.0
703 edmf_w_dd1(kts:kte)=0.0
704 edmf_qc_dd1(kts:kte)=0.0
705 sgm(kts:kte)=0.0
706 vt(kts:kte)=0.0
707 vq(kts:kte)=0.0
709 DO k=KTS,KTE
710 DO i=ITS,ITF
711 exch_m(i,k)=0.
712 exch_h(i,k)=0.
713 ENDDO
714 ENDDO
716 IF (tke_budget .eq. 1) THEN
717 DO k=KTS,KTE
718 DO i=ITS,ITF
719 qWT(i,k)=0.
720 qSHEAR(i,k)=0.
721 qBUOY(i,k)=0.
722 qDISS(i,k)=0.
723 dqke(i,k)=0.
724 ENDDO
725 ENDDO
726 ENDIF
728 DO i=ITS,ITF
729 if (FLAG_QI ) then
730 sqi(:)=sqi3D(i,:)
731 else
732 sqi = 0.0
733 endif
734 if (FLAG_QS ) then
735 sqs(:)=sqs3D(i,:)
736 else
737 sqs = 0.0
738 endif
739 if (icloud_bl > 0) then
740 cldfra_bl1d(:)=cldfra_bl(i,:)
741 qc_bl1d(:)=qc_bl(i,:)
742 qi_bl1d(:)=qi_bl(i,:)
743 endif
745 do k=KTS,KTE !KTF
746 dz1(k)=dz(i,k)
747 u1(k) = u(i,k)
748 v1(k) = v(i,k)
749 w1(k) = w(i,k)
750 th1(k)=th(i,k)
751 tk1(k)=T3D(i,k)
752 ex1(k)=exner(i,k)
753 rho1(k)=rho(i,k)
754 sqc(k)=sqc3D(i,k) !/(1.+qv(i,k))
755 sqv(k)=sqv3D(i,k) !/(1.+qv(i,k))
756 thetav(k)=th(i,k)*(1.+p608*sqv(k))
757 !keep snow out for now - increases ceiling bias
758 sqw(k)=sqv(k)+sqc(k)+sqi(k)!+sqs(k)
759 thl(k)=th1(k) - xlvcp/ex1(k)*sqc(k) &
760 & - xlscp/ex1(k)*(sqi(k))!+sqs(k))
761 !Use form from Tripoli and Cotton (1981) with their
762 !suggested min temperature to improve accuracy.
763 !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) &
764 ! & - xlscp/MAX(tk1(k),TKmin)*sqi(k))
766 IF (k==kts) THEN
767 zw(k)=0.
768 ELSE
769 zw(k)=zw(k-1)+dz(i,k-1)
770 ENDIF
771 IF (INITIALIZE_QKE) THEN
772 !Initialize tke for initial PBLH calc only - using
773 !simple PBLH form of Koracin and Berkowicz (1988, BLM)
774 !to linearly taper off tke towards top of PBL.
775 qke1(k)=5.*ust(i) * MAX((ust(i)*700. - zw(k))/(MAX(ust(i),0.01)*700.), 0.01)
776 ELSE
777 qke1(k)=qke(i,k)
778 ENDIF
779 el(k)=el_pbl(i,k)
780 sh(k)=Sh3D(i,k)
781 sm(k)=Sm3D(i,k)
782 tsq1(k)=tsq(i,k)
783 qsq1(k)=qsq(i,k)
784 cov1(k)=cov(i,k)
785 if (spp_pbl==1) then
786 rstoch_col(k)=pattern_spp_pbl(i,k)
787 else
788 rstoch_col(k)=0.0
789 endif
791 ENDDO
793 zw(kte+1)=zw(kte)+dz(i,kte)
795 !> - Call get_pblh() to calculate hybrid (\f$\theta_{v}-TKE\f$) PBL height.
796 CALL GET_PBLH(KTS,KTE,PBLH(i),thetav,&
797 & Qke1,zw,dz1,xland(i),KPBL(i))
799 !> - Call scale_aware() to calculate similarity functions for scale-adaptive control
800 !! (\f$P_{\sigma-PBL}\f$ and \f$P_{\sigma-shcu}\f$).
801 IF (scaleaware > 0.) THEN
802 CALL SCALE_AWARE(dx(i),PBLH(i),Psig_bl(i),Psig_shcu(i))
803 ELSE
804 Psig_bl(i)=1.0
805 Psig_shcu(i)=1.0
806 ENDIF
808 ! DH* CHECK IF WE CAN DO WITHOUT CALLING THIS ROUTINE FOR RESTARTS
809 !> - Call mym_initialize() to initializes the mixing length, TKE, \f$\theta^{'2}\f$,
810 !! \f$q^{'2}\f$, and \f$\theta^{'}q^{'}\f$. These variables are calculated after
811 !! obtaining prerequisite variables by calling the following subroutines from
812 !! within mym_initialize(): mym_level2() and mym_length().
813 CALL mym_initialize ( &
814 &kts,kte,xland(i), &
815 &dz1, dx(i), zw, &
816 &u1, v1, thl, sqv, &
817 &PBLH(i), th1, thetav, sh, sm, &
818 &ust(i), rmol(i), &
819 &el, Qke1, Tsq1, Qsq1, Cov1, &
820 &Psig_bl(i), cldfra_bl1D, &
821 &bl_mynn_mixlength, &
822 &edmf_w1,edmf_a1, &
823 &INITIALIZE_QKE, &
824 &spp_pbl,rstoch_col )
826 IF (.not.restart) THEN
827 !UPDATE 3D VARIABLES
828 DO k=KTS,KTE !KTF
829 el_pbl(i,k)=el(k)
830 sh3d(i,k)=sh(k)
831 sm3d(i,k)=sm(k)
832 qke(i,k)=qke1(k)
833 tsq(i,k)=tsq1(k)
834 qsq(i,k)=qsq1(k)
835 cov(i,k)=cov1(k)
836 ENDDO
837 !initialize qke_adv array if using advection
838 IF (bl_mynn_tkeadvect) THEN
839 DO k=KTS,KTE
840 qke_adv(i,k)=qke1(k)
841 ENDDO
842 ENDIF
843 ENDIF
845 !*** Begin debugging
846 ! IF(I==IMD .AND. J==JMD)THEN
847 ! PRINT*,"MYNN DRIVER INIT: k=",1," sh=",sh(k)
848 ! PRINT*," sqw=",sqw(k)," thl=",thl(k)," k_m=",exch_m(i,k)
849 ! PRINT*," xland=",xland(i)," rmol=",rmol(i)," ust=",ust(i)
850 ! PRINT*," qke=",qke(i,k)," el=",el_pbl(i,k)," tsq=",Tsq(i,k)
851 ! PRINT*," PBLH=",PBLH(i)," u=",u(i,k)," v=",v(i,k)
852 ! ENDIF
853 !*** End debugging
855 ENDDO !end i-loop
857 ENDIF ! end initflag
859 !> - After initializing all required variables, the regular procedures
860 !! performed at every time step are ready for execution.
861 !ACF- copy qke_adv array into qke if using advection
862 IF (bl_mynn_tkeadvect) THEN
863 qke=qke_adv
864 ENDIF
866 DO i=ITS,ITF
867 !Initialize some arrays
868 if (tke_budget .eq. 1) then
869 dqke(i,:)=qke(i,:)
870 endif
871 if (FLAG_QI ) then
872 sqi(:)=sqi3D(i,:)
873 else
874 sqi = 0.0
875 endif
876 if (FLAG_QS ) then
877 sqs(:)=sqs3D(i,:)
878 else
879 sqs = 0.0
880 endif
881 if (icloud_bl > 0) then
882 CLDFRA_BL1D(:)=CLDFRA_BL(i,:)
883 QC_BL1D(:) =QC_BL(i,:)
884 QI_BL1D(:) =QI_BL(i,:)
885 cldfra_bl1D_old(:)=cldfra_bl(i,:)
886 qc_bl1D_old(:)=qc_bl(i,:)
887 qi_bl1D_old(:)=qi_bl(i,:)
888 else
889 CLDFRA_BL1D =0.0
890 QC_BL1D =0.0
891 QI_BL1D =0.0
892 cldfra_bl1D_old=0.0
893 qc_bl1D_old =0.0
894 qi_bl1D_old =0.0
895 endif
896 dz1(kts:kte) =dz(i,kts:kte)
897 u1(kts:kte) =u(i,kts:kte)
898 v1(kts:kte) =v(i,kts:kte)
899 w1(kts:kte) =w(i,kts:kte)
900 th1(kts:kte) =th(i,kts:kte)
901 tk1(kts:kte) =T3D(i,kts:kte)
902 p1(kts:kte) =p(i,kts:kte)
903 ex1(kts:kte) =exner(i,kts:kte)
904 rho1(kts:kte) =rho(i,kts:kte)
905 sqv(kts:kte) =sqv3D(i,kts:kte) !/(1.+qv(i,kts:kte))
906 sqc(kts:kte) =sqc3D(i,kts:kte) !/(1.+qv(i,kts:kte))
907 qv1(kts:kte) =sqv(kts:kte)/(1.-sqv(kts:kte))
908 qc1(kts:kte) =sqc(kts:kte)/(1.-sqv(kts:kte))
909 qi1(kts:kte) =sqi(kts:kte)/(1.-sqv(kts:kte))
910 qs1(kts:kte) =sqs(kts:kte)/(1.-sqv(kts:kte))
911 dqc1(kts:kte) =0.0
912 dqi1(kts:kte) =0.0
913 dqs1(kts:kte) =0.0
914 dqni1(kts:kte) =0.0
915 dqnc1(kts:kte) =0.0
916 dqnwfa1(kts:kte)=0.0
917 dqnifa1(kts:kte)=0.0
918 dqnbca1(kts:kte)=0.0
919 dozone1(kts:kte)=0.0
920 IF (FLAG_QNI ) THEN
921 qni1(kts:kte)=qni(i,kts:kte)
922 ELSE
923 qni1(kts:kte)=0.0
924 ENDIF
925 IF (FLAG_QNC ) THEN
926 qnc1(kts:kte)=qnc(i,kts:kte)
927 ELSE
928 qnc1(kts:kte)=0.0
929 ENDIF
930 IF (FLAG_QNWFA ) THEN
931 qnwfa1(kts:kte)=qnwfa(i,kts:kte)
932 ELSE
933 qnwfa1(kts:kte)=0.0
934 ENDIF
935 IF (FLAG_QNIFA ) THEN
936 qnifa1(kts:kte)=qnifa(i,kts:kte)
937 ELSE
938 qnifa1(kts:kte)=0.0
939 ENDIF
940 IF (FLAG_QNBCA ) THEN
941 qnbca1(kts:kte)=qnbca(i,kts:kte)
942 ELSE
943 qnbca1(kts:kte)=0.0
944 ENDIF
945 IF (FLAG_OZONE ) THEN
946 ozone1(kts:kte)=ozone(i,kts:kte)
947 ELSE
948 ozone1(kts:kte)=0.0
949 ENDIF
950 el(kts:kte) =el_pbl(i,kts:kte)
951 qke1(kts:kte)=qke(i,kts:kte)
952 sh(kts:kte) =sh3d(i,kts:kte)
953 sm(kts:kte) =sm3d(i,kts:kte)
954 tsq1(kts:kte)=tsq(i,kts:kte)
955 qsq1(kts:kte)=qsq(i,kts:kte)
956 cov1(kts:kte)=cov(i,kts:kte)
957 if (spp_pbl==1) then
958 rstoch_col(kts:kte)=pattern_spp_pbl(i,kts:kte)
959 else
960 rstoch_col(kts:kte)=0.0
961 endif
962 !edmf
963 edmf_a1 =0.0
964 edmf_w1 =0.0
965 edmf_qc1 =0.0
966 s_aw1 =0.0
967 s_awthl1 =0.0
968 s_awqt1 =0.0
969 s_awqv1 =0.0
970 s_awqc1 =0.0
971 s_awu1 =0.0
972 s_awv1 =0.0
973 s_awqke1 =0.0
974 s_awqnc1 =0.0
975 s_awqni1 =0.0
976 s_awqnwfa1 =0.0
977 s_awqnifa1 =0.0
978 s_awqnbca1 =0.0
979 ![EWDD]
980 edmf_a_dd1 =0.0
981 edmf_w_dd1 =0.0
982 edmf_qc_dd1=0.0
983 sd_aw1 =0.0
984 sd_awthl1 =0.0
985 sd_awqt1 =0.0
986 sd_awqv1 =0.0
987 sd_awqc1 =0.0
988 sd_awu1 =0.0
989 sd_awv1 =0.0
990 sd_awqke1 =0.0
991 sub_thl =0.0
992 sub_sqv =0.0
993 sub_u =0.0
994 sub_v =0.0
995 det_thl =0.0
996 det_sqv =0.0
997 det_sqc =0.0
998 det_u =0.0
999 det_v =0.0
1001 do k = kts,kte
1002 if (k==kts) then
1003 zw(k)=0.
1004 else
1005 zw(k)=zw(k-1)+dz(i,k-1)
1006 endif
1007 !keep snow out for now - increases ceiling bias
1008 sqw(k)= sqv(k)+sqc(k)+sqi(k)!+sqs(k)
1009 thl(k)= th1(k) - xlvcp/ex1(k)*sqc(k) &
1010 & - xlscp/ex1(k)*(sqi(k))!+sqs(k))
1011 !Use form from Tripoli and Cotton (1981) with their
1012 !suggested min temperature to improve accuracy.
1013 !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) &
1014 ! & - xlscp/MAX(tk1(k),TKmin)*sqi(k))
1015 thetav(k)=th1(k)*(1.+p608*sqv(k))
1016 enddo ! end k
1017 zw(kte+1)=zw(kte)+dz(i,kte)
1019 !initialize smoke/chem arrays (if used):
1020 if ( mix_chem ) then
1021 do ic = 1,ndvel
1022 vd1(ic) = vdep(i,ic) ! dry deposition velocity
1023 enddo
1024 do k = kts,kte
1025 do ic = 1,nchem
1026 chem1(k,ic) = chem3d(i,k,ic)
1027 enddo
1028 enddo
1029 else
1030 do ic = 1,ndvel
1031 vd1(ic) = 0. ! dry deposition velocity
1032 enddo
1033 do k = kts,kte
1034 do ic = 1,nchem
1035 chem1(k,ic) = 0.
1036 enddo
1037 enddo
1038 endif
1039 s_awchem1(kts:kte+1,1:nchem) = 0.0
1041 !> - Call get_pblh() to calculate the hybrid \f$\theta_{v}-TKE\f$
1042 !! PBL height diagnostic.
1043 CALL GET_PBLH(KTS,KTE,PBLH(i),thetav,&
1044 & Qke1,zw,dz1,xland(i),KPBL(i))
1046 !> - Call scale_aware() to calculate the similarity functions,
1047 !! \f$P_{\sigma-PBL}\f$ and \f$P_{\sigma-shcu}\f$, to control
1048 !! the scale-adaptive behaviour for the local and nonlocal
1049 !! components, respectively.
1050 if (scaleaware > 0.) then
1051 call SCALE_AWARE(dx(i),PBLH(i),Psig_bl(i),Psig_shcu(i))
1052 else
1053 Psig_bl(i)=1.0
1054 Psig_shcu(i)=1.0
1055 endif
1057 sqcg= 0.0 !ill-defined variable; qcg has been removed
1058 cpm=cp*(1.+0.84*qv1(kts))
1059 exnerg=(ps(i)/p1000mb)**rcp
1061 !-----------------------------------------------------
1062 !ORIGINAL CODE
1063 !flt = hfx(i)/( rho(i,kts)*cpm ) &
1064 ! +xlvcp*ch(i)*(sqc(kts)/exner(i,kts) -sqcg/exnerg)
1065 !flq = qfx(i)/ rho(i,kts) &
1066 ! -ch(i)*(sqc(kts) -sqcg )
1067 !-----------------------------------------------------
1068 flqv = qfx(i)/rho1(kts)
1069 flqc = 0.0 !currently no sea-spray fluxes, fog settling handled elsewhere
1070 th_sfc = ts(i)/ex1(kts)
1072 ! TURBULENT FLUX FOR TKE BOUNDARY CONDITIONS
1073 flq =flqv+flqc !! LATENT
1074 flt =hfx(i)/(rho1(kts)*cpm )-xlvcp*flqc/ex1(kts) !! Temperature flux
1075 fltv=flt + flqv*p608*th_sfc !! Virtual temperature flux
1077 ! Update 1/L using updated sfc heat flux and friction velocity
1078 rmol(i) = -karman*gtr*fltv/max(ust(i)**3,1.0e-6)
1079 zet = 0.5*dz(i,kts)*rmol(i)
1080 zet = MAX(zet, -20.)
1081 zet = MIN(zet, 20.)
1082 !if(i.eq.idbg)print*,"updated z/L=",zet
1083 if (bl_mynn_stfunc == 0) then
1084 !Original Kansas-type stability functions
1085 if ( zet >= 0.0 ) then
1086 pmz = 1.0 + (cphm_st-1.0) * zet
1087 phh = 1.0 + cphh_st * zet
1088 else
1089 pmz = 1.0/ (1.0-cphm_unst*zet)**0.25 - zet
1090 phh = 1.0/SQRT(1.0-cphh_unst*zet)
1091 end if
1092 else
1093 !Updated stability functions (Puhales, 2020)
1094 phi_m = phim(zet)
1095 pmz = phi_m - zet
1096 phh = phih(zet)
1097 end if
1099 !> - Call mym_condensation() to calculate the nonconvective component
1100 !! of the subgrid cloud fraction and mixing ratio as well as the functions
1101 !! used to calculate the buoyancy flux. Different cloud PDFs can be
1102 !! selected by use of the namelist parameter \p bl_mynn_cloudpdf.
1104 call mym_condensation (kts,kte, &
1105 &dx(i),dz1,zw,xland(i), &
1106 &thl,sqw,sqv,sqc,sqi,sqs, &
1107 &p1,ex1,tsq1,qsq1,cov1, &
1108 &Sh,el,bl_mynn_cloudpdf, &
1109 &qc_bl1D,qi_bl1D,cldfra_bl1D, &
1110 &PBLH(i),HFX(i), &
1111 &Vt, Vq, th1, sgm, rmol(i), &
1112 &spp_pbl, rstoch_col )
1114 !> - Add TKE source driven by cloud top cooling
1115 !! Calculate the buoyancy production of TKE from cloud-top cooling when
1116 !! \p bl_mynn_topdown =1.
1117 if (bl_mynn_topdown.eq.1) then
1118 call topdown_cloudrad(kts,kte,dz1,zw,fltv, &
1119 &xland(i),kpbl(i),PBLH(i), &
1120 &sqc,sqi,sqw,thl,th1,ex1,p1,rho1,thetav, &
1121 &cldfra_bl1D,rthraten(i,:), &
1122 &maxKHtopdown(i),KHtopdown,TKEprodTD )
1123 else
1124 maxKHtopdown(i) = 0.0
1125 KHtopdown(kts:kte) = 0.0
1126 TKEprodTD(kts:kte) = 0.0
1127 endif
1129 if (bl_mynn_edmf > 0) then
1130 !PRINT*,"Calling DMP Mass-Flux: i= ",i
1131 call DMP_mf( &
1132 &kts,kte,delt,zw,dz1,p1,rho1, &
1133 &bl_mynn_edmf_mom, &
1134 &bl_mynn_edmf_tke, &
1135 &bl_mynn_mixscalars, &
1136 &u1,v1,w1,th1,thl,thetav,tk1, &
1137 &sqw,sqv,sqc,qke1, &
1138 &qnc1,qni1,qnwfa1,qnifa1,qnbca1, &
1139 &ex1,Vt,Vq,sgm, &
1140 &ust(i),flt,fltv,flq,flqv, &
1141 &PBLH(i),KPBL(i),DX(i), &
1142 &xland(i),th_sfc, &
1143 ! now outputs - tendencies
1144 ! &,dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf &
1145 ! outputs - updraft properties
1146 &edmf_a1,edmf_w1,edmf_qt1, &
1147 &edmf_thl1,edmf_ent1,edmf_qc1, &
1148 ! for the solver
1149 &s_aw1,s_awthl1,s_awqt1, &
1150 &s_awqv1,s_awqc1, &
1151 &s_awu1,s_awv1,s_awqke1, &
1152 &s_awqnc1,s_awqni1, &
1153 &s_awqnwfa1,s_awqnifa1,s_awqnbca1, &
1154 &sub_thl,sub_sqv, &
1155 &sub_u,sub_v, &
1156 &det_thl,det_sqv,det_sqc, &
1157 &det_u,det_v, &
1158 ! chem/smoke mixing
1159 &nchem,chem1,s_awchem1, &
1160 &mix_chem, &
1161 &qc_bl1D,cldfra_bl1D, &
1162 &qc_bl1D_old,cldfra_bl1D_old, &
1163 &FLAG_QC,FLAG_QI, &
1164 &FLAG_QNC,FLAG_QNI, &
1165 &FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA, &
1166 &Psig_shcu(i), &
1167 &maxwidth(i),ktop_plume(i), &
1168 &maxmf(i),ztop_plume(i), &
1169 &spp_pbl,rstoch_col )
1170 endif
1172 if (bl_mynn_edmf_dd == 1) then
1173 call DDMF_JPL(kts,kte,delt,zw,dz1,p1, &
1174 &u1,v1,th1,thl,thetav,tk1, &
1175 &sqw,sqv,sqc,rho1,ex1, &
1176 &ust(i),flt,flq, &
1177 &PBLH(i),KPBL(i), &
1178 &edmf_a_dd1,edmf_w_dd1,edmf_qt_dd1, &
1179 &edmf_thl_dd1,edmf_ent_dd1, &
1180 &edmf_qc_dd1, &
1181 &sd_aw1,sd_awthl1,sd_awqt1, &
1182 &sd_awqv1,sd_awqc1,sd_awu1,sd_awv1, &
1183 &sd_awqke1, &
1184 &qc_bl1d,cldfra_bl1d, &
1185 &rthraten(i,:) )
1186 endif
1188 !Capability to substep the eddy-diffusivity portion
1189 !do nsub = 1,2
1190 delt2 = delt !*0.5 !only works if topdown=0
1192 call mym_turbulence( &
1193 &kts,kte,xland(i),closure, &
1194 &dz1, DX(i), zw, &
1195 &u1, v1, thl, thetav, sqc, sqw, &
1196 &qke1, tsq1, qsq1, cov1, &
1197 &vt, vq, &
1198 &rmol(i), flt, fltv, flq, &
1199 &PBLH(i),th1, &
1200 &Sh,Sm,el, &
1201 &Dfm,Dfh,Dfq, &
1202 &Tcd,Qcd,Pdk, &
1203 &Pdt,Pdq,Pdc, &
1204 &qWT1,qSHEAR1,qBUOY1,qDISS1, &
1205 &tke_budget, &
1206 &Psig_bl(i),Psig_shcu(i), &
1207 &cldfra_bl1D,bl_mynn_mixlength, &
1208 &edmf_w1,edmf_a1, &
1209 &TKEprodTD, &
1210 &spp_pbl,rstoch_col )
1212 !> - Call mym_predict() to solve TKE and
1213 !! \f$\theta^{'2}, q^{'2}, and \theta^{'}q^{'}\f$
1214 !! for the following time step.
1215 call mym_predict(kts,kte,closure, &
1216 &delt2, dz1, &
1217 &ust(i), flt, flq, pmz, phh, &
1218 &el, dfq, rho1, pdk, pdt, pdq, pdc, &
1219 &Qke1, Tsq1, Qsq1, Cov1, &
1220 &s_aw1, s_awqke1, bl_mynn_edmf_tke, &
1221 &qWT1, qDISS1, tke_budget )
1223 if (dheat_opt > 0) then
1224 do k=kts,kte-1
1225 ! Set max dissipative heating rate to 7.2 K per hour
1226 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)
1227 ! Limit heating above 100 mb:
1228 diss_heat(k) = diss_heat(k) * exp(-10000./MAX(p1(k),1.))
1229 enddo
1230 diss_heat(kte) = 0.
1231 else
1232 diss_heat(1:kte) = 0.
1233 endif
1235 !> - Call mynn_tendencies() to solve for tendencies of
1236 !! \f$U, V, \theta, q_{v}, q_{c}, and q_{i}\f$.
1237 call mynn_tendencies(kts,kte,i, &
1238 &delt, dz1, rho1, &
1239 &u1, v1, th1, tk1, qv1, &
1240 &qc1, qi1, kzero, qnc1, qni1, & !kzero replaces qs1 - not mixing snow
1241 &ps(i), p1, ex1, thl, &
1242 &sqv, sqc, sqi, kzero, sqw, & !kzero replaces sqs - not mixing snow
1243 &qnwfa1, qnifa1, qnbca1, ozone1, &
1244 &ust(i),flt,flq,flqv,flqc, &
1245 &wspd(i),uoce(i),voce(i), &
1246 &tsq1, qsq1, cov1, &
1247 &tcd, qcd, &
1248 &dfm, dfh, dfq, &
1249 &Du1, Dv1, Dth1, Dqv1, &
1250 &Dqc1, Dqi1, Dqs1, Dqnc1, Dqni1, &
1251 &Dqnwfa1, Dqnifa1, Dqnbca1, &
1252 &Dozone1, &
1253 &diss_heat, &
1254 ! mass flux components
1255 &s_aw1,s_awthl1,s_awqt1, &
1256 &s_awqv1,s_awqc1,s_awu1,s_awv1, &
1257 &s_awqnc1,s_awqni1, &
1258 &s_awqnwfa1,s_awqnifa1,s_awqnbca1, &
1259 &sd_aw1,sd_awthl1,sd_awqt1, &
1260 &sd_awqv1,sd_awqc1, &
1261 &sd_awu1,sd_awv1, &
1262 &sub_thl,sub_sqv, &
1263 &sub_u,sub_v, &
1264 &det_thl,det_sqv,det_sqc, &
1265 &det_u,det_v, &
1266 &FLAG_QC,FLAG_QI,FLAG_QNC, &
1267 &FLAG_QNI,FLAG_QS, &
1268 &FLAG_QNWFA,FLAG_QNIFA, &
1269 &FLAG_QNBCA,FLAG_OZONE, &
1270 &cldfra_bl1d, &
1271 &bl_mynn_cloudmix, &
1272 &bl_mynn_mixqt, &
1273 &bl_mynn_edmf, &
1274 &bl_mynn_edmf_mom, &
1275 &bl_mynn_mixscalars )
1278 if ( mix_chem ) then
1279 if ( rrfs_sd ) then
1280 call mynn_mix_chem(kts,kte,i, &
1281 &delt, dz1, pblh(i), &
1282 &nchem, kdvel, ndvel, &
1283 &chem1, vd1, &
1284 &rho1,flt, &
1285 &tcd, qcd, &
1286 &dfh, &
1287 &s_aw1,s_awchem1, &
1288 &emis_ant_no(i), &
1289 &frp(i), rrfs_sd, &
1290 &enh_mix, smoke_dbg )
1291 else
1292 call mynn_mix_chem(kts,kte,i, &
1293 &delt, dz1, pblh(i), &
1294 &nchem, kdvel, ndvel, &
1295 &chem1, vd1, &
1296 &rho1,flt, &
1297 &tcd, qcd, &
1298 &dfh, &
1299 &s_aw1,s_awchem1, &
1300 &zero, &
1301 &zero, rrfs_sd, &
1302 &enh_mix, smoke_dbg )
1303 endif
1304 do ic = 1,nchem
1305 do k = kts,kte
1306 chem3d(i,k,ic) = max(1.e-12, chem1(k,ic))
1307 enddo
1308 enddo
1309 endif
1311 call retrieve_exchange_coeffs(kts,kte, &
1312 &dfm, dfh, dz1, K_m1, K_h1 )
1314 !UPDATE 3D ARRAYS
1315 exch_m(i,kts:kte) =k_m1(kts:kte)
1316 exch_h(i,kts:kte) =k_h1(kts:kte)
1317 rublten(i,kts:kte) =du1(kts:kte)
1318 rvblten(i,kts:kte) =dv1(kts:kte)
1319 rthblten(i,kts:kte)=dth1(kts:kte)
1320 rqvblten(i,kts:kte)=dqv1(kts:kte)
1321 if (bl_mynn_cloudmix > 0) then
1322 if (flag_qc) rqcblten(i,kts:kte)=dqc1(kts:kte)
1323 if (flag_qi) rqiblten(i,kts:kte)=dqi1(kts:kte)
1324 if (flag_qs) rqsblten(i,kts:kte)=dqs1(kts:kte)
1325 else
1326 if (flag_qc) rqcblten(i,:)=0.
1327 if (flag_qi) rqiblten(i,:)=0.
1328 if (flag_qs) rqsblten(i,:)=0.
1329 endif
1330 if (bl_mynn_cloudmix > 0 .and. bl_mynn_mixscalars > 0) then
1331 if (flag_qnc) rqncblten(i,kts:kte) =dqnc1(kts:kte)
1332 if (flag_qni) rqniblten(i,kts:kte) =dqni1(kts:kte)
1333 if (flag_qnwfa) rqnwfablten(i,kts:kte)=dqnwfa1(kts:kte)
1334 if (flag_qnifa) rqnifablten(i,kts:kte)=dqnifa1(kts:kte)
1335 if (flag_qnbca) rqnbcablten(i,kts:kte)=dqnbca1(kts:kte)
1336 else
1337 if (flag_qnc) rqncblten(i,:) =0.
1338 if (flag_qni) rqniblten(i,:) =0.
1339 if (flag_qnwfa) rqnwfablten(i,:)=0.
1340 if (flag_qnifa) rqnifablten(i,:)=0.
1341 if (flag_qnbca) rqnbcablten(i,:)=0.
1342 endif
1343 dozone(i,kts:kte)=dozone1(kts:kte)
1344 if (icloud_bl > 0) then
1345 qc_bl(i,kts:kte) =qc_bl1D(kts:kte)
1346 qi_bl(i,kts:kte) =qi_bl1D(kts:kte)
1347 cldfra_bl(i,kts:kte)=cldfra_bl1D(kts:kte)
1348 endif
1349 el_pbl(i,kts:kte)=el(kts:kte)
1350 qke(i,kts:kte) =qke1(kts:kte)
1351 tsq(i,kts:kte) =tsq1(kts:kte)
1352 qsq(i,kts:kte) =qsq1(kts:kte)
1353 cov(i,kts:kte) =cov1(kts:kte)
1354 sh3d(i,kts:kte) =sh(kts:kte)
1355 sm3d(i,kts:kte) =sm(kts:kte)
1357 if (tke_budget .eq. 1) then
1358 !! TKE budget is now given in m**2/s**-3 (Puhales, 2020)
1359 !! Lower boundary condtions (using similarity relationships such as the prognostic equation for Qke)
1360 k=kts
1361 qSHEAR1(k) =4.*(ust(i)**3*phi_m/(karman*dz(i,k)))-qSHEAR1(k+1) !! staggered
1362 qBUOY1(k) =4.*(-ust(i)**3*zet/(karman*dz(i,k)))-qBUOY1(k+1) !! staggered
1363 !! unstaggering SHEAR and BUOY and trasfering all TKE budget to 3D array
1364 do k = kts,kte-1
1365 qSHEAR(i,k)=0.5*(qSHEAR1(k)+qSHEAR1(k+1)) !!! unstaggering in z
1366 qBUOY(i,k) =0.5*(qBUOY1(k)+qBUOY1(k+1)) !!! unstaggering in z
1367 qWT(i,k) =qWT1(k)
1368 qDISS(i,k) =qDISS1(k)
1369 dqke(i,k) =(qke1(k)-dqke(i,k))*0.5/delt
1370 enddo
1371 !! Upper boundary conditions
1372 k=kte
1373 qSHEAR(i,k) =0.
1374 qBUOY(i,k) =0.
1375 qWT(i,k) =0.
1376 qDISS(i,k) =0.
1377 dqke(i,k) =0.
1378 endif
1380 !update updraft/downdraft properties
1381 if (bl_mynn_output > 0) then !research mode == 1
1382 if (bl_mynn_edmf > 0) then
1383 edmf_a(i,kts:kte) =edmf_a1(kts:kte)
1384 edmf_w(i,kts:kte) =edmf_w1(kts:kte)
1385 edmf_qt(i,kts:kte) =edmf_qt1(kts:kte)
1386 edmf_thl(i,kts:kte) =edmf_thl1(kts:kte)
1387 edmf_ent(i,kts:kte) =edmf_ent1(kts:kte)
1388 edmf_qc(i,kts:kte) =edmf_qc1(kts:kte)
1389 sub_thl3D(i,kts:kte)=sub_thl(kts:kte)
1390 sub_sqv3D(i,kts:kte)=sub_sqv(kts:kte)
1391 det_thl3D(i,kts:kte)=det_thl(kts:kte)
1392 det_sqv3D(i,kts:kte)=det_sqv(kts:kte)
1393 endif
1394 !if (bl_mynn_edmf_dd > 0) THEN
1395 ! edmf_a_dd(i,kts:kte) =edmf_a_dd1(kts:kte)
1396 ! edmf_w_dd(i,kts:kte) =edmf_w_dd1(kts:kte)
1397 ! edmf_qt_dd(i,kts:kte) =edmf_qt_dd1(kts:kte)
1398 ! edmf_thl_dd(i,kts:kte)=edmf_thl_dd1(kts:kte)
1399 ! edmf_ent_dd(i,kts:kte)=edmf_ent_dd1(kts:kte)
1400 ! edmf_qc_dd(i,kts:kte) =edmf_qc_dd1(kts:kte)
1401 !endif
1402 endif
1404 !*** Begin debug prints
1405 if ( debug_code .and. (i .eq. idbg)) THEN
1406 if ( ABS(QFX(i))>.001)print*,&
1407 "SUSPICIOUS VALUES AT: i=",i," QFX=",QFX(i)
1408 if ( ABS(HFX(i))>1100.)print*,&
1409 "SUSPICIOUS VALUES AT: i=",i," HFX=",HFX(i)
1410 do k = kts,kte
1411 IF ( sh(k) < 0. .OR. sh(k)> 200.)print*,&
1412 "SUSPICIOUS VALUES AT: i,k=",i,k," sh=",sh(k)
1413 IF ( ABS(vt(k)) > 2.0 )print*,&
1414 "SUSPICIOUS VALUES AT: i,k=",i,k," vt=",vt(k)
1415 IF ( ABS(vq(k)) > 7000.)print*,&
1416 "SUSPICIOUS VALUES AT: i,k=",i,k," vq=",vq(k)
1417 IF ( qke(i,k) < -1. .OR. qke(i,k)> 200.)print*,&
1418 "SUSPICIOUS VALUES AT: i,k=",i,k," qke=",qke(i,k)
1419 IF ( el_pbl(i,k) < 0. .OR. el_pbl(i,k)> 1500.)print*,&
1420 "SUSPICIOUS VALUES AT: i,k=",i,k," el_pbl=",el_pbl(i,k)
1421 IF ( exch_m(i,k) < 0. .OR. exch_m(i,k)> 2000.)print*,&
1422 "SUSPICIOUS VALUES AT: i,k=",i,k," exxch_m=",exch_m(i,k)
1423 IF (icloud_bl > 0) then
1424 IF ( cldfra_bl(i,k) < 0.0 .OR. cldfra_bl(i,k)> 1.)THEN
1425 PRINT*,"SUSPICIOUS VALUES: CLDFRA_BL=",cldfra_bl(i,k)," qc_bl=",QC_BL(i,k)
1426 ENDIF
1427 ENDIF
1429 !IF (I==IMD .AND. J==JMD) THEN
1430 ! PRINT*,"MYNN DRIVER END: k=",k," sh=",sh(k)
1431 ! PRINT*," sqw=",sqw(k)," thl=",thl(k)," exch_m=",exch_m(i,k)
1432 ! PRINT*," xland=",xland(i)," rmol=",rmol(i)," ust=",ust(i)
1433 ! PRINT*," qke=",qke(i,k)," el=",el_pbl(i,k)," tsq=",tsq(i,k)
1434 ! PRINT*," PBLH=",PBLH(i)," u=",u(i,k)," v=",v(i,k)
1435 ! PRINT*," vq=",vq(k)," vt=",vt(k)
1436 !ENDIF
1437 enddo !end-k
1438 endif
1440 enddo !end i-loop
1442 !ACF copy qke into qke_adv if using advection
1443 IF (bl_mynn_tkeadvect) THEN
1444 qke_adv=qke
1445 ENDIF
1446 !ACF-end
1448 #ifdef HARDCODE_VERTICAL
1449 # undef kts
1450 # undef kte
1451 #endif
1453 END SUBROUTINE mynn_bl_driver
1454 !> @}
1456 !=======================================================================
1457 ! SUBROUTINE mym_initialize:
1458 !
1459 ! Input variables:
1460 ! iniflag : <>0; turbulent quantities will be initialized
1461 ! = 0; turbulent quantities have been already
1462 ! given, i.e., they will not be initialized
1463 ! nx, nz : Dimension sizes of the
1464 ! x and z directions, respectively
1465 ! tref : Reference temperature (K)
1466 ! dz(nz) : Vertical grid spacings (m)
1467 ! # dz(nz)=dz(nz-1)
1468 ! zw(nz+1) : Heights of the walls of the grid boxes (m)
1469 ! # zw(1)=0.0 and zw(k)=zw(k-1)+dz(k-1)
1470 ! exner(nx,nz) : Exner function at zw*h+zg (J/kg K)
1471 ! defined by c_p*( p_basic/1000hPa )^kappa
1472 ! This is usually computed by integrating
1473 ! d(pi0)/dz = -h*g/tref.
1474 ! rmo(nx) : Inverse of the Obukhov length (m^(-1))
1475 ! flt, flq(nx) : Turbulent fluxes of potential temperature and
1476 ! total water, respectively:
1477 ! flt=-u_*Theta_* (K m/s)
1478 ! flq=-u_*qw_* (kg/kg m/s)
1479 ! ust(nx) : Friction velocity (m/s)
1480 ! pmz(nx) : phi_m-zeta at z1*h+z0, where z1 (=0.5*dz(1))
1481 ! is the first grid point above the surafce, z0
1482 ! the roughness length and zeta=(z1*h+z0)*rmo
1483 ! phh(nx) : phi_h at z1*h+z0
1484 ! u, v(nx,nz) : Components of the horizontal wind (m/s)
1485 ! thl(nx,nz) : Liquid water potential temperature
1486 ! (K)
1487 ! qw(nx,nz) : Total water content Q_w (kg/kg)
1488 !
1489 ! Output variables:
1490 ! ql(nx,nz) : Liquid water content (kg/kg)
1491 ! vt, vq(nx,nz) : Functions for computing the buoyancy flux
1492 ! qke(nx,nz) : Twice the turbulent kinetic energy q^2
1493 ! (m^2/s^2)
1494 ! tsq(nx,nz) : Variance of Theta_l (K^2)
1495 ! qsq(nx,nz) : Variance of Q_w
1496 ! cov(nx,nz) : Covariance of Theta_l and Q_w (K)
1497 ! el(nx,nz) : Master length scale L (m)
1498 ! defined on the walls of the grid boxes
1499 !
1500 ! Work arrays: see subroutine mym_level2
1501 ! pd?(nx,nz,ny) : Half of the production terms at Level 2
1502 ! defined on the walls of the grid boxes
1503 ! qkw(nx,nz,ny) : q on the walls of the grid boxes (m/s)
1504 !
1505 ! # As to dtl, ...gh, see subroutine mym_turbulence.
1506 !
1507 !-------------------------------------------------------------------
1509 !>\ingroup gsd_mynn_edmf
1510 !! This subroutine initializes the mixing length, TKE, \f$\theta^{'2}\f$,
1511 !! \f$q^{'2}\f$, and \f$\theta^{'}q^{'}\f$.
1512 !!\section gen_mym_ini GSD MYNN-EDMF mym_initialize General Algorithm
1513 !> @{
1514 SUBROUTINE mym_initialize ( &
1515 & kts,kte,xland, &
1516 & dz, dx, zw, &
1517 & u, v, thl, qw, &
1518 ! & ust, rmo, pmz, phh, flt, flq, &
1519 & zi, theta, thetav, sh, sm, &
1520 & ust, rmo, el, &
1521 & Qke, Tsq, Qsq, Cov, Psig_bl, cldfra_bl1D, &
1522 & bl_mynn_mixlength, &
1523 & edmf_w1,edmf_a1, &
1524 & INITIALIZE_QKE, &
1525 & spp_pbl,rstoch_col)
1526 !
1527 !-------------------------------------------------------------------
1529 integer, intent(in) :: kts,kte
1530 integer, intent(in) :: bl_mynn_mixlength
1531 logical, intent(in) :: INITIALIZE_QKE
1532 ! real(kind_phys), intent(in) :: ust, rmo, pmz, phh, flt, flq
1533 real(kind_phys), intent(in) :: rmo, Psig_bl, xland
1534 real(kind_phys), intent(in) :: dx, ust, zi
1535 real(kind_phys), dimension(kts:kte), intent(in) :: dz
1536 real(kind_phys), dimension(kts:kte+1), intent(in) :: zw
1537 real(kind_phys), dimension(kts:kte), intent(in) :: u,v,thl,&
1538 &qw,cldfra_bl1D,edmf_w1,edmf_a1
1539 real(kind_phys), dimension(kts:kte), intent(out) :: tsq,qsq,cov
1540 real(kind_phys), dimension(kts:kte), intent(inout) :: el,qke
1541 real(kind_phys), dimension(kts:kte) :: &
1542 &ql,pdk,pdt,pdq,pdc,dtl,dqw,dtv, &
1543 &gm,gh,sm,sh,qkw,vt,vq
1544 integer :: k,l,lmax
1545 real(kind_phys):: phm,vkz,elq,elv,b1l,b2l,pmz=1.,phh=1., &
1546 &flt=0.,fltv=0.,flq=0.,tmpq
1547 real(kind_phys), dimension(kts:kte) :: theta,thetav
1548 real(kind_phys), dimension(kts:kte) :: rstoch_col
1549 integer ::spp_pbl
1551 !> - At first ql, vt and vq are set to zero.
1552 DO k = kts,kte
1553 ql(k) = 0.0
1554 vt(k) = 0.0
1555 vq(k) = 0.0
1556 END DO
1557 !
1558 !> - Call mym_level2() to calculate the stability functions at level 2.
1559 CALL mym_level2 ( kts,kte, &
1560 & dz, &
1561 & u, v, thl, thetav, qw, &
1562 & ql, vt, vq, &
1563 & dtl, dqw, dtv, gm, gh, sm, sh )
1564 !
1565 ! ** Preliminary setting **
1567 el (kts) = 0.0
1568 IF (INITIALIZE_QKE) THEN
1569 !qke(kts) = ust**2 * ( b1*pmz )**(2.0/3.0)
1570 qke(kts) = 1.5 * ust**2 * ( b1*pmz )**(2.0/3.0)
1571 DO k = kts+1,kte
1572 !qke(k) = 0.0
1573 !linearly taper off towards top of pbl
1574 qke(k)=qke(kts)*MAX((ust*700. - zw(k))/(MAX(ust,0.01)*700.), 0.01)
1575 ENDDO
1576 ENDIF
1577 !
1578 phm = phh*b2 / ( b1*pmz )**(1.0/3.0)
1579 tsq(kts) = phm*( flt/ust )**2
1580 qsq(kts) = phm*( flq/ust )**2
1581 cov(kts) = phm*( flt/ust )*( flq/ust )
1582 !
1583 DO k = kts+1,kte
1584 vkz = karman*zw(k)
1585 el (k) = vkz/( 1.0 + vkz/100.0 )
1586 ! qke(k) = 0.0
1587 !
1588 tsq(k) = 0.0
1589 qsq(k) = 0.0
1590 cov(k) = 0.0
1591 END DO
1592 !
1593 ! ** Initialization with an iterative manner **
1594 ! ** lmax is the iteration count. This is arbitrary. **
1595 lmax = 5
1596 !
1597 DO l = 1,lmax
1598 !
1599 !> - call mym_length() to calculate the master length scale.
1600 CALL mym_length ( &
1601 & kts,kte,xland, &
1602 & dz, dx, zw, &
1603 & rmo, flt, fltv, flq, &
1604 & vt, vq, &
1605 & u, v, qke, &
1606 & dtv, &
1607 & el, &
1608 & zi,theta, &
1609 & qkw,Psig_bl,cldfra_bl1D, &
1610 & bl_mynn_mixlength, &
1611 & edmf_w1,edmf_a1 )
1612 !
1613 DO k = kts+1,kte
1614 elq = el(k)*qkw(k)
1615 pdk(k) = elq*( sm(k)*gm(k) + &
1616 & sh(k)*gh(k) )
1617 pdt(k) = elq* sh(k)*dtl(k)**2
1618 pdq(k) = elq* sh(k)*dqw(k)**2
1619 pdc(k) = elq* sh(k)*dtl(k)*dqw(k)
1620 END DO
1621 !
1622 ! ** Strictly, vkz*h(i,j) -> karman*( 0.5*dz(1)*h(i,j)+z0 ) **
1623 vkz = karman*0.5*dz(kts)
1624 elv = 0.5*( el(kts+1)+el(kts) ) / vkz
1625 IF (INITIALIZE_QKE)THEN
1626 !qke(kts) = ust**2 * ( b1*pmz*elv )**(2.0/3.0)
1627 qke(kts) = 1.0 * MAX(ust,0.02)**2 * ( b1*pmz*elv )**(2.0/3.0)
1628 ENDIF
1630 phm = phh*b2 / ( b1*pmz/elv**2 )**(1.0/3.0)
1631 tsq(kts) = phm*( flt/ust )**2
1632 qsq(kts) = phm*( flq/ust )**2
1633 cov(kts) = phm*( flt/ust )*( flq/ust )
1635 DO k = kts+1,kte-1
1636 b1l = b1*0.25*( el(k+1)+el(k) )
1637 !tmpq=MAX(b1l*( pdk(k+1)+pdk(k) ),qkemin)
1638 !add MIN to limit unreasonable QKE
1639 tmpq=MIN(MAX(b1l*( pdk(k+1)+pdk(k) ),qkemin),125.)
1640 ! PRINT *,'tmpqqqqq',tmpq,pdk(k+1),pdk(k)
1641 IF (INITIALIZE_QKE)THEN
1642 qke(k) = tmpq**twothirds
1643 ENDIF
1645 IF ( qke(k) .LE. 0.0 ) THEN
1646 b2l = 0.0
1647 ELSE
1648 b2l = b2*( b1l/b1 ) / SQRT( qke(k) )
1649 END IF
1651 tsq(k) = b2l*( pdt(k+1)+pdt(k) )
1652 qsq(k) = b2l*( pdq(k+1)+pdq(k) )
1653 cov(k) = b2l*( pdc(k+1)+pdc(k) )
1654 END DO
1656 END DO
1658 !! qke(kts)=qke(kts+1)
1659 !! tsq(kts)=tsq(kts+1)
1660 !! qsq(kts)=qsq(kts+1)
1661 !! cov(kts)=cov(kts+1)
1663 IF (INITIALIZE_QKE)THEN
1664 qke(kts)=0.5*(qke(kts)+qke(kts+1))
1665 qke(kte)=qke(kte-1)
1666 ENDIF
1667 tsq(kte)=tsq(kte-1)
1668 qsq(kte)=qsq(kte-1)
1669 cov(kte)=cov(kte-1)
1671 !
1672 ! RETURN
1674 END SUBROUTINE mym_initialize
1675 !> @}
1677 !
1678 ! ==================================================================
1679 ! SUBROUTINE mym_level2:
1680 !
1681 ! Input variables: see subroutine mym_initialize
1682 !
1683 ! Output variables:
1684 ! dtl(nx,nz,ny) : Vertical gradient of Theta_l (K/m)
1685 ! dqw(nx,nz,ny) : Vertical gradient of Q_w
1686 ! dtv(nx,nz,ny) : Vertical gradient of Theta_V (K/m)
1687 ! gm (nx,nz,ny) : G_M divided by L^2/q^2 (s^(-2))
1688 ! gh (nx,nz,ny) : G_H divided by L^2/q^2 (s^(-2))
1689 ! sm (nx,nz,ny) : Stability function for momentum, at Level 2
1690 ! sh (nx,nz,ny) : Stability function for heat, at Level 2
1691 !
1692 ! These are defined on the walls of the grid boxes.
1693 !
1695 !>\ingroup gsd_mynn_edmf
1696 !! This subroutine calculates the level 2, non-dimensional wind shear
1697 !! \f$G_M\f$ and vertical temperature gradient \f$G_H\f$ as well as
1698 !! the level 2 stability funcitons \f$S_h\f$ and \f$S_m\f$.
1699 !!\param kts horizontal dimension
1700 !!\param kte vertical dimension
1701 !!\param dz vertical grid spacings (\f$m\f$)
1702 !!\param u west-east component of the horizontal wind (\f$m s^{-1}\f$)
1703 !!\param v south-north component of the horizontal wind (\f$m s^{-1}\f$)
1704 !!\param thl liquid water potential temperature
1705 !!\param qw total water content \f$Q_w\f$
1706 !!\param ql liquid water content (\f$kg kg^{-1}\f$)
1707 !!\param vt
1708 !!\param vq
1709 !!\param dtl vertical gradient of \f$\theta_l\f$ (\f$K m^{-1}\f$)
1710 !!\param dqw vertical gradient of \f$Q_w\f$
1711 !!\param dtv vertical gradient of \f$\theta_V\f$ (\f$K m^{-1}\f$)
1712 !!\param gm \f$G_M\f$ divided by \f$L^{2}/q^{2}\f$ (\f$s^{-2}\f$)
1713 !!\param gh \f$G_H\f$ divided by \f$L^{2}/q^{2}\f$ (\f$s^{-2}\f$)
1714 !!\param sm stability function for momentum, at Level 2
1715 !!\param sh stability function for heat, at Level 2
1716 !!\section gen_mym_level2 GSD MYNN-EDMF mym_level2 General Algorithm
1717 !! @ {
1718 SUBROUTINE mym_level2 (kts,kte, &
1719 & dz, &
1720 & u, v, thl, thetav, qw, &
1721 & ql, vt, vq, &
1722 & dtl, dqw, dtv, gm, gh, sm, sh )
1723 !
1724 !-------------------------------------------------------------------
1726 integer, intent(in) :: kts,kte
1728 #ifdef HARDCODE_VERTICAL
1729 # define kts 1
1730 # define kte HARDCODE_VERTICAL
1731 #endif
1733 real(kind_phys), dimension(kts:kte), intent(in) :: dz
1734 real(kind_phys), dimension(kts:kte), intent(in) :: u,v, &
1735 &thl,qw,ql,vt,vq,thetav
1736 real(kind_phys), dimension(kts:kte), intent(out) :: &
1737 &dtl,dqw,dtv,gm,gh,sm,sh
1739 integer :: k
1741 real(kind_phys):: rfc,f1,f2,rf1,rf2,smc,shc, &
1742 &ri1,ri2,ri3,ri4,duz,dtz,dqz,vtt,vqq,dtq,dzk, &
1743 &afk,abk,ri,rf
1745 real(kind_phys):: a2fac
1747 ! ev = 2.5e6
1748 ! tv0 = 0.61*tref
1749 ! tv1 = 1.61*tref
1750 ! gtr = 9.81/tref
1751 !
1752 rfc = g1/( g1+g2 )
1753 f1 = b1*( g1-c1 ) +3.0*a2*( 1.0 -c2 )*( 1.0-c5 ) &
1754 & +2.0*a1*( 3.0-2.0*c2 )
1755 f2 = b1*( g1+g2 ) -3.0*a1*( 1.0 -c2 )
1756 rf1 = b1*( g1-c1 )/f1
1757 rf2 = b1* g1 /f2
1758 smc = a1 /a2* f1/f2
1759 shc = 3.0*a2*( g1+g2 )
1760 !
1761 ri1 = 0.5/smc
1762 ri2 = rf1*smc
1763 ri3 = 4.0*rf2*smc -2.0*ri2
1764 ri4 = ri2**2
1765 !
1766 DO k = kts+1,kte
1767 dzk = 0.5 *( dz(k)+dz(k-1) )
1768 afk = dz(k)/( dz(k)+dz(k-1) )
1769 abk = 1.0 -afk
1770 duz = ( u(k)-u(k-1) )**2 +( v(k)-v(k-1) )**2
1771 duz = duz /dzk**2
1772 dtz = ( thl(k)-thl(k-1) )/( dzk )
1773 dqz = ( qw(k)-qw(k-1) )/( dzk )
1774 !
1775 vtt = 1.0 +vt(k)*abk +vt(k-1)*afk ! Beta-theta in NN09, Eq. 39
1776 vqq = tv0 +vq(k)*abk +vq(k-1)*afk ! Beta-q
1777 dtq = vtt*dtz +vqq*dqz
1778 !Alternatively, use theta-v without the SGS clouds
1779 !dtq = ( thetav(k)-thetav(k-1) )/( dzk )
1780 !
1781 dtl(k) = dtz
1782 dqw(k) = dqz
1783 dtv(k) = dtq
1784 !? dtv(i,j,k) = dtz +tv0*dqz
1785 !? : +( xlv/pi0(i,j,k)-tv1 )
1786 !? : *( ql(i,j,k)-ql(i,j,k-1) )/( dzk*h(i,j) )
1787 !
1788 gm (k) = duz
1789 gh (k) = -dtq*gtr
1790 !
1791 ! ** Gradient Richardson number **
1792 ri = -gh(k)/MAX( duz, 1.0e-10 )
1794 !a2fac is needed for the Canuto/Kitamura mod
1795 IF (CKmod .eq. 1) THEN
1796 a2fac = 1./(1. + MAX(ri,0.0))
1797 ELSE
1798 a2fac = 1.
1799 ENDIF
1801 rfc = g1/( g1+g2 )
1802 f1 = b1*( g1-c1 ) +3.0*a2*a2fac *( 1.0 -c2 )*( 1.0-c5 ) &
1803 & +2.0*a1*( 3.0-2.0*c2 )
1804 f2 = b1*( g1+g2 ) -3.0*a1*( 1.0 -c2 )
1805 rf1 = b1*( g1-c1 )/f1
1806 rf2 = b1* g1 /f2
1807 smc = a1 /(a2*a2fac)* f1/f2
1808 shc = 3.0*(a2*a2fac)*( g1+g2 )
1810 ri1 = 0.5/smc
1811 ri2 = rf1*smc
1812 ri3 = 4.0*rf2*smc -2.0*ri2
1813 ri4 = ri2**2
1815 ! ** Flux Richardson number **
1816 rf = MIN( ri1*( ri + ri2-SQRT(ri**2 - ri3*ri + ri4) ), rfc )
1817 !
1818 sh (k) = shc*( rfc-rf )/( 1.0-rf )
1819 sm (k) = smc*( rf1-rf )/( rf2-rf ) * sh(k)
1820 END DO
1821 !
1822 ! RETURN
1824 #ifdef HARDCODE_VERTICAL
1825 # undef kts
1826 # undef kte
1827 #endif
1829 END SUBROUTINE mym_level2
1830 !! @}
1832 ! ==================================================================
1833 ! SUBROUTINE mym_length:
1834 !
1835 ! Input variables: see subroutine mym_initialize
1836 !
1837 ! Output variables: see subroutine mym_initialize
1838 !
1839 ! Work arrays:
1840 ! elt(nx,ny) : Length scale depending on the PBL depth (m)
1841 ! vsc(nx,ny) : Velocity scale q_c (m/s)
1842 ! at first, used for computing elt
1843 !
1844 ! NOTE: the mixing lengths are meant to be calculated at the full-
1845 ! sigmal levels (or interfaces beween the model layers).
1846 !
1847 !>\ingroup gsd_mynn_edmf
1848 !! This subroutine calculates the mixing lengths.
1849 SUBROUTINE mym_length ( &
1850 & kts,kte,xland, &
1851 & dz, dx, zw, &
1852 & rmo, flt, fltv, flq, &
1853 & vt, vq, &
1854 & u1, v1, qke, &
1855 & dtv, &
1856 & el, &
1857 & zi, theta, qkw, &
1858 & Psig_bl, cldfra_bl1D, &
1859 & bl_mynn_mixlength, &
1860 & edmf_w1,edmf_a1 )
1862 !-------------------------------------------------------------------
1864 integer, intent(in) :: kts,kte
1866 #ifdef HARDCODE_VERTICAL
1867 # define kts 1
1868 # define kte HARDCODE_VERTICAL
1869 #endif
1871 integer, intent(in) :: bl_mynn_mixlength
1872 real(kind_phys), dimension(kts:kte), intent(in) :: dz
1873 real(kind_phys), dimension(kts:kte+1), intent(in) :: zw
1874 real(kind_phys), intent(in) :: rmo,flt,fltv,flq,Psig_bl,xland
1875 real(kind_phys), intent(in) :: dx,zi
1876 real(kind_phys), dimension(kts:kte), intent(in) :: u1,v1, &
1877 &qke,vt,vq,cldfra_bl1D,edmf_w1,edmf_a1
1878 real(kind_phys), dimension(kts:kte), intent(out) :: qkw, el
1879 real(kind_phys), dimension(kts:kte), intent(in) :: dtv
1880 real(kind_phys):: elt,vsc
1881 real(kind_phys), dimension(kts:kte), intent(in) :: theta
1882 real(kind_phys), dimension(kts:kte) :: qtke,elBLmin,elBLavg,thetaw
1883 real(kind_phys):: wt,wt2,zi2,h1,h2,hs,elBLmin0,elBLavg0,cldavg
1885 ! THE FOLLOWING CONSTANTS ARE IMPORTANT FOR REGULATING THE
1886 ! MIXING LENGTHS:
1887 real(kind_phys):: cns, & !< for surface layer (els) in stable conditions
1888 alp1, & !< for turbulent length scale (elt)
1889 alp2, & !< for buoyancy length scale (elb)
1890 alp3, & !< for buoyancy enhancement factor of elb
1891 alp4, & !< for surface layer (els) in unstable conditions
1892 alp5, & !< for BouLac mixing length or above PBLH
1893 alp6 !< for mass-flux/
1895 !THE FOLLOWING LIMITS DO NOT DIRECTLY AFFECT THE ACTUAL PBLH.
1896 !THEY ONLY IMPOSE LIMITS ON THE CALCULATION OF THE MIXING LENGTH
1897 !SCALES SO THAT THE BOULAC MIXING LENGTH (IN FREE ATMOS) DOES
1898 !NOT ENCROACH UPON THE BOUNDARY LAYER MIXING LENGTH (els, elb & elt).
1899 real(kind_phys), parameter :: minzi = 300. !< min mixed-layer height
1900 real(kind_phys), parameter :: maxdz = 750. !< max (half) transition layer depth
1901 !! =0.3*2500 m PBLH, so the transition
1902 !! layer stops growing for PBLHs > 2.5 km.
1903 real(kind_phys), parameter :: mindz = 300. !< 300 !min (half) transition layer depth
1905 !SURFACE LAYER LENGTH SCALE MODS TO REDUCE IMPACT IN UPPER BOUNDARY LAYER
1906 real(kind_phys), parameter :: ZSLH = 100. !< Max height correlated to surface conditions (m)
1907 real(kind_phys), parameter :: CSL = 2. !< CSL = constant of proportionality to L O(1)
1908 real(kind_phys), parameter :: qke_elb_min = 0.018
1910 integer :: i,j,k
1911 real(kind_phys):: afk,abk,zwk,zwk1,dzk,qdz,vflx,bv,tau_cloud, &
1912 & wstar,elb,els,elf,el_stab,el_mf,el_stab_mf,elb_mf, &
1913 & PBLH_PLUS_ENT,Uonset,Ugrid,wt_u,el_les
1914 real(kind_phys), parameter :: ctau = 1000. !constant for tau_cloud
1916 ! tv0 = 0.61*tref
1917 ! gtr = 9.81/tref
1919 SELECT CASE(bl_mynn_mixlength)
1921 CASE (0) ! ORIGINAL MYNN MIXING LENGTH + BouLac
1923 cns = 2.7
1924 alp1 = 0.23
1925 alp2 = 1.0
1926 alp3 = 5.0
1927 alp4 = 100.
1928 alp5 = 0.3
1930 ! Impose limits on the height integration for elt and the transition layer depth
1931 zi2 = MIN(10000.,zw(kte-2)) !originally integrated to model top, not just 10 km.
1932 h1=MAX(0.3*zi2,mindz)
1933 h1=MIN(h1,maxdz) ! 1/2 transition layer depth
1934 h2=h1/2.0 ! 1/4 transition layer depth
1936 qkw(kts) = SQRT(MAX(qke(kts), qkemin))
1937 DO k = kts+1,kte
1938 afk = dz(k)/( dz(k)+dz(k-1) )
1939 abk = 1.0 -afk
1940 qkw(k) = SQRT(MAX(qke(k)*abk+qke(k-1)*afk, qkemin))
1941 END DO
1943 elt = 1.0e-5
1944 vsc = 1.0e-5
1946 ! ** Strictly, zwk*h(i,j) -> ( zwk*h(i,j)+z0 ) **
1947 k = kts+1
1948 zwk = zw(k)
1949 DO WHILE (zwk .LE. zi2+h1)
1950 dzk = 0.5*( dz(k)+dz(k-1) )
1951 qdz = MAX( qkw(k)-qmin, 0.03 )*dzk
1952 elt = elt +qdz*zwk
1953 vsc = vsc +qdz
1954 k = k+1
1955 zwk = zw(k)
1956 END DO
1958 elt = alp1*elt/vsc
1959 vflx = ( vt(kts)+1.0 )*flt +( vq(kts)+tv0 )*flq
1960 vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**onethird
1962 ! ** Strictly, el(i,k=1) is not zero. **
1963 el(kts) = 0.0
1964 zwk1 = zw(kts+1)
1966 DO k = kts+1,kte
1967 zwk = zw(k) !full-sigma levels
1969 ! ** Length scale limited by the buoyancy effect **
1970 IF ( dtv(k) .GT. 0.0 ) THEN
1971 bv = SQRT( gtr*dtv(k) )
1972 elb = alp2*qkw(k) / bv &
1973 & *( 1.0 + alp3/alp2*&
1974 &SQRT( vsc/( bv*elt ) ) )
1975 elf = alp2 * qkw(k)/bv
1977 ELSE
1978 elb = 1.0e10
1979 elf = elb
1980 ENDIF
1982 ! ** Length scale in the surface layer **
1983 IF ( rmo .GT. 0.0 ) THEN
1984 els = karman*zwk/(1.0+cns*MIN( zwk*rmo, zmax ))
1985 ELSE
1986 els = karman*zwk*( 1.0 - alp4* zwk*rmo )**0.2
1987 END IF
1989 ! ** HARMONC AVERGING OF MIXING LENGTH SCALES:
1990 ! el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf)
1991 ! el(k) = elb/( elb/elt+elb/els+1.0 )
1993 wt=.5*TANH((zwk - (zi2+h1))/h2) + .5
1995 el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf)
1997 END DO
1999 CASE (1) !NONLOCAL (using BouLac) FORM OF MIXING LENGTH
2001 ugrid = sqrt(u1(kts)**2 + v1(kts)**2)
2002 uonset= 15.
2003 wt_u = (1.0 - min(max(ugrid - uonset, 0.0)/30.0, 0.5))
2004 cns = 3.5
2005 alp1 = 0.23
2006 alp2 = 0.3
2007 alp3 = 2.5 * wt_u !taper off bouyancy enhancement in shear-driven pbls
2008 alp4 = 5.0
2009 alp5 = 0.3
2010 alp6 = 50.
2012 ! Impose limits on the height integration for elt and the transition layer depth
2013 zi2 = MAX(zi,300.) !minzi)
2014 h1 = MAX(0.3*zi2,300.)
2015 h1 = MIN(h1,600.) ! 1/2 transition layer depth
2016 h2 = h1/2.0 ! 1/4 transition layer depth
2018 qtke(kts) = MAX(0.5*qke(kts), 0.5*qkemin) !tke at full sigma levels
2019 thetaw(kts) = theta(kts) !theta at full-sigma levels
2020 qkw(kts) = SQRT(MAX(qke(kts), qkemin))
2022 DO k = kts+1,kte
2023 afk = dz(k)/( dz(k)+dz(k-1) )
2024 abk = 1.0 -afk
2025 qkw(k) = SQRT(MAX(qke(k)*abk+qke(k-1)*afk, qkemin))
2026 qtke(k) = max(0.5*(qkw(k)**2), 0.005) ! q -> TKE
2027 thetaw(k)= theta(k)*abk + theta(k-1)*afk
2028 END DO
2030 elt = 1.0e-5
2031 vsc = 1.0e-5
2033 ! ** Strictly, zwk*h(i,j) -> ( zwk*h(i,j)+z0 ) **
2034 k = kts+1
2035 zwk = zw(k)
2036 DO WHILE (zwk .LE. zi2+h1)
2037 dzk = 0.5*( dz(k)+dz(k-1) )
2038 qdz = min(max( qkw(k)-qmin, 0.01 ), 30.0)*dzk
2039 elt = elt +qdz*zwk
2040 vsc = vsc +qdz
2041 k = k+1
2042 zwk = zw(k)
2043 END DO
2045 elt = MIN( MAX( alp1*elt/vsc, 8.), 400.)
2046 !avoid use of buoyancy flux functions which are ill-defined at the surface
2047 !vflx = ( vt(kts)+1.0 )*flt + ( vq(kts)+tv0 )*flq
2048 vflx = fltv
2049 vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**onethird
2051 ! ** Strictly, el(i,j,1) is not zero. **
2052 el(kts) = 0.0
2053 zwk1 = zw(kts+1) !full-sigma levels
2055 ! COMPUTE BouLac mixing length
2056 CALL boulac_length(kts,kte,zw,dz,qtke,thetaw,elBLmin,elBLavg)
2058 DO k = kts+1,kte
2059 zwk = zw(k) !full-sigma levels
2061 ! ** Length scale limited by the buoyancy effect **
2062 IF ( dtv(k) .GT. 0.0 ) THEN
2063 bv = max( sqrt( gtr*dtv(k) ), 0.0001)
2064 elb = MAX(alp2*max(qkw(k), qke_elb_min), &
2065 & alp6*edmf_a1(k-1)*edmf_w1(k-1)) / bv &
2066 & *( 1.0 + alp3*SQRT( vsc/(bv*elt) ) )
2067 elb = MIN(elb, zwk)
2068 elf = 1.0 * max(qkw(k), qke_elb_min)/bv
2069 elBLavg(k) = MAX(elBLavg(k), alp6*edmf_a1(k-1)*edmf_w1(k-1)/bv)
2070 ELSE
2071 elb = 1.0e10
2072 elf = elb
2073 ENDIF
2075 ! ** Length scale in the surface layer **
2076 IF ( rmo .GT. 0.0 ) THEN
2077 els = karman*zwk/(1.0+cns*MIN( zwk*rmo, zmax ))
2078 ELSE
2079 els = karman*zwk*( 1.0 - alp4* zwk*rmo )**0.2
2080 END IF
2082 ! ** NOW BLEND THE MIXING LENGTH SCALES:
2083 wt=.5*TANH((zwk - (zi2+h1))/h2) + .5
2085 !add blending to use BouLac mixing length in free atmos;
2086 !defined relative to the PBLH (zi) + transition layer (h1)
2087 !el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf)
2088 !try squared-blending - but take out elb (makes it underdiffusive)
2089 !el(k) = SQRT( els**2/(1. + (els**2/elt**2) +(els**2/elb**2)))
2090 el(k) = sqrt( els**2/(1. + (els**2/elt**2)))
2091 el(k) = min(el(k), elb)
2092 el(k) = min(el(k), elf)
2093 el(k) = el(k)*(1.-wt) + alp5*elBLavg(k)*wt
2095 ! include scale-awareness, except for original MYNN
2096 el(k) = el(k)*Psig_bl
2098 END DO
2100 CASE (2) !Local (mostly) mixing length formulation
2102 Uonset = 3.5 + dz(kts)*0.1
2103 Ugrid = sqrt(u1(kts)**2 + v1(kts)**2)
2104 cns = 3.5 !JOE-test * (1.0 - MIN(MAX(Ugrid - Uonset, 0.0)/10.0, 1.0))
2105 alp1 = 0.22
2106 alp2 = 0.30
2107 alp3 = 2.0
2108 alp4 = 5.0
2109 alp5 = alp2 !like alp2, but for free atmosphere
2110 alp6 = 50.0 !used for MF mixing length
2112 ! Impose limits on the height integration for elt and the transition layer depth
2113 !zi2=MAX(zi,minzi)
2114 zi2=MAX(zi, 300.)
2115 !h1=MAX(0.3*zi2,mindz)
2116 !h1=MIN(h1,maxdz) ! 1/2 transition layer depth
2117 h1=MAX(0.3*zi2,300.)
2118 h1=MIN(h1,600.)
2119 h2=h1*0.5 ! 1/4 transition layer depth
2121 qtke(kts)=MAX(0.5*qke(kts), 0.5*qkemin) !tke at full sigma levels
2122 qkw(kts) = SQRT(MAX(qke(kts), qkemin))
2124 DO k = kts+1,kte
2125 afk = dz(k)/( dz(k)+dz(k-1) )
2126 abk = 1.0 -afk
2127 qkw(k) = SQRT(MAX(qke(k)*abk+qke(k-1)*afk, qkemin))
2128 qtke(k) = 0.5*qkw(k)**2 ! qkw -> TKE
2129 END DO
2131 elt = 1.0e-5
2132 vsc = 1.0e-5
2134 ! ** Strictly, zwk*h(i,j) -> ( zwk*h(i,j)+z0 ) **
2135 PBLH_PLUS_ENT = MAX(zi+h1, 100.)
2136 k = kts+1
2137 zwk = zw(k)
2138 DO WHILE (zwk .LE. PBLH_PLUS_ENT)
2139 dzk = 0.5*( dz(k)+dz(k-1) )
2140 qdz = min(max( qkw(k)-qmin, 0.03 ), 30.0)*dzk
2141 elt = elt +qdz*zwk
2142 vsc = vsc +qdz
2143 k = k+1
2144 zwk = zw(k)
2145 END DO
2147 elt = MIN( MAX(alp1*elt/vsc, 10.), 400.)
2148 !avoid use of buoyancy flux functions which are ill-defined at the surface
2149 !vflx = ( vt(kts)+1.0 )*flt +( vq(kts)+tv0 )*flq
2150 vflx = fltv
2151 vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**onethird
2153 ! ** Strictly, el(i,j,1) is not zero. **
2154 el(kts) = 0.0
2155 zwk1 = zw(kts+1)
2157 DO k = kts+1,kte
2158 zwk = zw(k) !full-sigma levels
2159 dzk = 0.5*( dz(k)+dz(k-1) )
2160 cldavg = 0.5*(cldfra_bl1D(k-1)+cldfra_bl1D(k))
2162 ! ** Length scale limited by the buoyancy effect **
2163 IF ( dtv(k) .GT. 0.0 ) THEN
2164 !impose min value on bv
2165 bv = MAX( SQRT( gtr*dtv(k) ), 0.001)
2166 !elb_mf = alp2*qkw(k) / bv &
2167 elb_mf = MAX(alp2*qkw(k), &
2168 & alp6*edmf_a1(k-1)*edmf_w1(k-1)) / bv &
2169 & *( 1.0 + alp3*SQRT( vsc/( bv*elt ) ) )
2170 elb = MIN(MAX(alp5*qkw(k), alp6*edmf_a1(k)*edmf_w1(k))/bv, zwk)
2172 !tau_cloud = MIN(MAX(0.5*zi/((gtr*zi*MAX(vflx,1.0e-4))**onethird),30.),150.)
2173 wstar = 1.25*(gtr*zi*MAX(vflx,1.0e-4))**onethird
2174 tau_cloud = MIN(MAX(ctau * wstar/grav, 30.), 150.)
2175 !minimize influence of surface heat flux on tau far away from the PBLH.
2176 wt=.5*TANH((zwk - (zi2+h1))/h2) + .5
2177 tau_cloud = tau_cloud*(1.-wt) + 50.*wt
2178 elf = MIN(MAX(tau_cloud*SQRT(MIN(qtke(k),40.)), &
2179 & alp6*edmf_a1(k)*edmf_w1(k)/bv), zwk)
2181 !IF (zwk > zi .AND. elf > 400.) THEN
2182 ! ! COMPUTE BouLac mixing length
2183 ! !CALL boulac_length0(k,kts,kte,zw,dz,qtke,thetaw,elBLmin0,elBLavg0)
2184 ! !elf = alp5*elBLavg0
2185 ! elf = MIN(MAX(50.*SQRT(qtke(k)), 400.), zwk)
2186 !ENDIF
2188 ELSE
2189 ! use version in development for RAP/HRRR 2016
2190 ! JAYMES-
2191 ! tau_cloud is an eddy turnover timescale;
2192 ! see Teixeira and Cheinet (2004), Eq. 1, and
2193 ! Cheinet and Teixeira (2003), Eq. 7. The
2194 ! coefficient 0.5 is tuneable. Expression in
2195 ! denominator is identical to vsc (a convective
2196 ! velocity scale), except that elt is relpaced
2197 ! by zi, and zero is replaced by 1.0e-4 to
2198 ! prevent division by zero.
2199 !tau_cloud = MIN(MAX(0.5*zi/((gtr*zi*MAX(vflx,1.0e-4))**onethird),50.),150.)
2200 wstar = 1.25*(gtr*zi*MAX(vflx,1.0e-4))**onethird
2201 tau_cloud = MIN(MAX(ctau * wstar/grav, 50.), 200.)
2202 !minimize influence of surface heat flux on tau far away from the PBLH.
2203 wt=.5*TANH((zwk - (zi2+h1))/h2) + .5
2204 !tau_cloud = tau_cloud*(1.-wt) + 50.*wt
2205 tau_cloud = tau_cloud*(1.-wt) + MAX(100.,dzk*0.25)*wt
2207 elb = MIN(tau_cloud*SQRT(MIN(qtke(k),40.)), zwk)
2208 !elf = elb
2209 elf = elb !/(1. + (elb/800.)) !bound free-atmos mixing length to < 800 m.
2210 elb_mf = elb
2211 END IF
2212 elf = elf/(1. + (elf/800.)) !bound free-atmos mixing length to < 800 m.
2213 elb_mf = MAX(elb_mf, 0.01) !to avoid divide-by-zero below
2215 ! ** Length scale in the surface layer **
2216 IF ( rmo .GT. 0.0 ) THEN
2217 els = karman*zwk/(1.0+cns*MIN( zwk*rmo, zmax ))
2218 ELSE
2219 els = karman*zwk*( 1.0 - alp4* zwk*rmo )**0.2
2220 END IF
2222 ! ** NOW BLEND THE MIXING LENGTH SCALES:
2223 wt=.5*TANH((zwk - (zi2+h1))/h2) + .5
2225 !try squared-blending
2226 el(k) = SQRT( els**2/(1. + (els**2/elt**2) +(els**2/elb_mf**2)))
2227 el(k) = el(k)*(1.-wt) + elf*wt
2229 ! include scale-awareness. For now, use simple asymptotic kz -> 12 m (should be ~dz).
2230 el_les= MIN(els/(1. + (els/12.)), elb_mf)
2231 el(k) = el(k)*Psig_bl + (1.-Psig_bl)*el_les
2233 END DO
2235 END SELECT
2238 #ifdef HARDCODE_VERTICAL
2239 # undef kts
2240 # undef kte
2241 #endif
2243 END SUBROUTINE mym_length
2245 ! ==================================================================
2246 !>\ingroup gsd_mynn_edmf
2247 !! This subroutine was taken from the BouLac scheme in WRF-ARW and modified for
2248 !! integration into the MYNN PBL scheme. WHILE loops were added to reduce the
2249 !! computational expense. This subroutine computes the length scales up and down
2250 !! and then computes the min, average of the up/down length scales, and also
2251 !! considers the distance to the surface.
2252 !\param dlu the distance a parcel can be lifted upwards give a finite
2253 ! amount of TKE.
2254 !\param dld the distance a parcel can be displaced downwards given a
2255 ! finite amount of TKE.
2256 !\param lb1 the minimum of the length up and length down
2257 !\param lb2 the average of the length up and length down
2258 SUBROUTINE boulac_length0(k,kts,kte,zw,dz,qtke,theta,lb1,lb2)
2259 !
2260 ! NOTE: This subroutine was taken from the BouLac scheme in WRF-ARW
2261 ! and modified for integration into the MYNN PBL scheme.
2262 ! WHILE loops were added to reduce the computational expense.
2263 ! This subroutine computes the length scales up and down
2264 ! and then computes the min, average of the up/down
2265 ! length scales, and also considers the distance to the
2266 ! surface.
2267 !
2268 ! dlu = the distance a parcel can be lifted upwards give a finite
2269 ! amount of TKE.
2270 ! dld = the distance a parcel can be displaced downwards given a
2271 ! finite amount of TKE.
2272 ! lb1 = the minimum of the length up and length down
2273 ! lb2 = the average of the length up and length down
2274 !-------------------------------------------------------------------
2276 integer, intent(in) :: k,kts,kte
2277 real(kind_phys), dimension(kts:kte), intent(in) :: qtke,dz,theta
2278 real(kind_phys), intent(out) :: lb1,lb2
2279 real(kind_phys), dimension(kts:kte+1), intent(in) :: zw
2281 !LOCAL VARS
2282 integer :: izz, found
2283 real(kind_phys):: dlu,dld
2284 real(kind_phys):: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz
2287 !----------------------------------
2288 ! FIND DISTANCE UPWARD
2289 !----------------------------------
2290 zup=0.
2291 dlu=zw(kte+1)-zw(k)-dz(k)*0.5
2292 zzz=0.
2293 zup_inf=0.
2294 beta=gtr !Buoyancy coefficient (g/tref)
2296 !print*,"FINDING Dup, k=",k," zw=",zw(k)
2298 if (k .lt. kte) then !cant integrate upwards from highest level
2299 found = 0
2300 izz=k
2301 DO WHILE (found .EQ. 0)
2303 if (izz .lt. kte) then
2304 dzt=dz(izz) ! layer depth above
2305 zup=zup-beta*theta(k)*dzt ! initial PE the parcel has at k
2306 !print*," ",k,izz,theta(izz),dz(izz)
2307 zup=zup+beta*(theta(izz+1)+theta(izz))*dzt*0.5 ! PE gained by lifting a parcel to izz+1
2308 zzz=zzz+dzt ! depth of layer k to izz+1
2309 !print*," PE=",zup," TKE=",qtke(k)," z=",zw(izz)
2310 if (qtke(k).lt.zup .and. qtke(k).ge.zup_inf) then
2311 bbb=(theta(izz+1)-theta(izz))/dzt
2312 if (bbb .ne. 0.) then
2313 !fractional distance up into the layer where TKE becomes < PE
2314 tl=(-beta*(theta(izz)-theta(k)) + &
2315 & sqrt( max(0.,(beta*(theta(izz)-theta(k)))**2 + &
2316 & 2.*bbb*beta*(qtke(k)-zup_inf))))/bbb/beta
2317 else
2318 if (theta(izz) .ne. theta(k))then
2319 tl=(qtke(k)-zup_inf)/(beta*(theta(izz)-theta(k)))
2320 else
2321 tl=0.
2322 endif
2323 endif
2324 dlu=zzz-dzt+tl
2325 !print*," FOUND Dup:",dlu," z=",zw(izz)," tl=",tl
2326 found =1
2327 endif
2328 zup_inf=zup
2329 izz=izz+1
2330 ELSE
2331 found = 1
2332 ENDIF
2334 ENDDO
2336 endif
2338 !----------------------------------
2339 ! FIND DISTANCE DOWN
2340 !----------------------------------
2341 zdo=0.
2342 zdo_sup=0.
2343 dld=zw(k)
2344 zzz=0.
2346 !print*,"FINDING Ddown, k=",k," zwk=",zw(k)
2347 if (k .gt. kts) then !cant integrate downwards from lowest level
2349 found = 0
2350 izz=k
2351 DO WHILE (found .EQ. 0)
2353 if (izz .gt. kts) then
2354 dzt=dz(izz-1)
2355 zdo=zdo+beta*theta(k)*dzt
2356 !print*," ",k,izz,theta(izz),dz(izz-1)
2357 zdo=zdo-beta*(theta(izz-1)+theta(izz))*dzt*0.5
2358 zzz=zzz+dzt
2359 !print*," PE=",zdo," TKE=",qtke(k)," z=",zw(izz)
2360 if (qtke(k).lt.zdo .and. qtke(k).ge.zdo_sup) then
2361 bbb=(theta(izz)-theta(izz-1))/dzt
2362 if (bbb .ne. 0.) then
2363 tl=(beta*(theta(izz)-theta(k))+ &
2364 & sqrt( max(0.,(beta*(theta(izz)-theta(k)))**2 + &
2365 & 2.*bbb*beta*(qtke(k)-zdo_sup))))/bbb/beta
2366 else
2367 if (theta(izz) .ne. theta(k)) then
2368 tl=(qtke(k)-zdo_sup)/(beta*(theta(izz)-theta(k)))
2369 else
2370 tl=0.
2371 endif
2372 endif
2373 dld=zzz-dzt+tl
2374 !print*," FOUND Ddown:",dld," z=",zw(izz)," tl=",tl
2375 found = 1
2376 endif
2377 zdo_sup=zdo
2378 izz=izz-1
2379 ELSE
2380 found = 1
2381 ENDIF
2382 ENDDO
2384 endif
2386 !----------------------------------
2387 ! GET MINIMUM (OR AVERAGE)
2388 !----------------------------------
2389 !The surface layer length scale can exceed z for large z/L,
2390 !so keep maximum distance down > z.
2391 dld = min(dld,zw(k+1))!not used in PBL anyway, only free atmos
2392 lb1 = min(dlu,dld) !minimum
2393 !JOE-fight floating point errors
2394 dlu=MAX(0.1,MIN(dlu,1000.))
2395 dld=MAX(0.1,MIN(dld,1000.))
2396 lb2 = sqrt(dlu*dld) !average - biased towards smallest
2397 !lb2 = 0.5*(dlu+dld) !average
2399 if (k .eq. kte) then
2400 lb1 = 0.
2401 lb2 = 0.
2402 endif
2403 !print*,"IN MYNN-BouLac",k,lb1
2404 !print*,"IN MYNN-BouLac",k,dld,dlu
2406 END SUBROUTINE boulac_length0
2408 ! ==================================================================
2409 !>\ingroup gsd_mynn_edmf
2410 !! This subroutine was taken from the BouLac scheme in WRF-ARW
2411 !! and modified for integration into the MYNN PBL scheme.
2412 !! WHILE loops were added to reduce the computational expense.
2413 !! This subroutine computes the length scales up and down
2414 !! and then computes the min, average of the up/down
2415 !! length scales, and also considers the distance to the
2416 !! surface.
2417 SUBROUTINE boulac_length(kts,kte,zw,dz,qtke,theta,lb1,lb2)
2418 ! dlu = the distance a parcel can be lifted upwards give a finite
2419 ! amount of TKE.
2420 ! dld = the distance a parcel can be displaced downwards given a
2421 ! finite amount of TKE.
2422 ! lb1 = the minimum of the length up and length down
2423 ! lb2 = the average of the length up and length down
2424 !-------------------------------------------------------------------
2426 integer, intent(in) :: kts,kte
2427 real(kind_phys), dimension(kts:kte), intent(in) :: qtke,dz,theta
2428 real(kind_phys), dimension(kts:kte), intent(out):: lb1,lb2
2429 real(kind_phys), dimension(kts:kte+1), intent(in) :: zw
2431 !LOCAL VARS
2432 integer :: iz, izz, found
2433 real(kind_phys), dimension(kts:kte) :: dlu,dld
2434 real(kind_phys), parameter :: Lmax=2000. !soft limit
2435 real(kind_phys):: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz
2437 !print*,"IN MYNN-BouLac",kts, kte
2439 do iz=kts,kte
2441 !----------------------------------
2442 ! FIND DISTANCE UPWARD
2443 !----------------------------------
2444 zup=0.
2445 dlu(iz)=zw(kte+1)-zw(iz)-dz(iz)*0.5
2446 zzz=0.
2447 zup_inf=0.
2448 beta=gtr !Buoyancy coefficient (g/tref)
2450 !print*,"FINDING Dup, k=",iz," zw=",zw(iz)
2452 if (iz .lt. kte) then !cant integrate upwards from highest level
2454 found = 0
2455 izz=iz
2456 DO WHILE (found .EQ. 0)
2458 if (izz .lt. kte) then
2459 dzt=dz(izz) ! layer depth above
2460 zup=zup-beta*theta(iz)*dzt ! initial PE the parcel has at iz
2461 !print*," ",iz,izz,theta(izz),dz(izz)
2462 zup=zup+beta*(theta(izz+1)+theta(izz))*dzt*0.5 ! PE gained by lifting a parcel to izz+1
2463 zzz=zzz+dzt ! depth of layer iz to izz+1
2464 !print*," PE=",zup," TKE=",qtke(iz)," z=",zw(izz)
2465 if (qtke(iz).lt.zup .and. qtke(iz).ge.zup_inf) then
2466 bbb=(theta(izz+1)-theta(izz))/dzt
2467 if (bbb .ne. 0.) then
2468 !fractional distance up into the layer where TKE becomes < PE
2469 tl=(-beta*(theta(izz)-theta(iz)) + &
2470 & sqrt( max(0.,(beta*(theta(izz)-theta(iz)))**2 + &
2471 & 2.*bbb*beta*(qtke(iz)-zup_inf))))/bbb/beta
2472 else
2473 if (theta(izz) .ne. theta(iz))then
2474 tl=(qtke(iz)-zup_inf)/(beta*(theta(izz)-theta(iz)))
2475 else
2476 tl=0.
2477 endif
2478 endif
2479 dlu(iz)=zzz-dzt+tl
2480 !print*," FOUND Dup:",dlu(iz)," z=",zw(izz)," tl=",tl
2481 found =1
2482 endif
2483 zup_inf=zup
2484 izz=izz+1
2485 ELSE
2486 found = 1
2487 ENDIF
2489 ENDDO
2491 endif
2493 !----------------------------------
2494 ! FIND DISTANCE DOWN
2495 !----------------------------------
2496 zdo=0.
2497 zdo_sup=0.
2498 dld(iz)=zw(iz)
2499 zzz=0.
2501 !print*,"FINDING Ddown, k=",iz," zwk=",zw(iz)
2502 if (iz .gt. kts) then !cant integrate downwards from lowest level
2504 found = 0
2505 izz=iz
2506 DO WHILE (found .EQ. 0)
2508 if (izz .gt. kts) then
2509 dzt=dz(izz-1)
2510 zdo=zdo+beta*theta(iz)*dzt
2511 !print*," ",iz,izz,theta(izz),dz(izz-1)
2512 zdo=zdo-beta*(theta(izz-1)+theta(izz))*dzt*0.5
2513 zzz=zzz+dzt
2514 !print*," PE=",zdo," TKE=",qtke(iz)," z=",zw(izz)
2515 if (qtke(iz).lt.zdo .and. qtke(iz).ge.zdo_sup) then
2516 bbb=(theta(izz)-theta(izz-1))/dzt
2517 if (bbb .ne. 0.) then
2518 tl=(beta*(theta(izz)-theta(iz))+ &
2519 & sqrt( max(0.,(beta*(theta(izz)-theta(iz)))**2 + &
2520 & 2.*bbb*beta*(qtke(iz)-zdo_sup))))/bbb/beta
2521 else
2522 if (theta(izz) .ne. theta(iz)) then
2523 tl=(qtke(iz)-zdo_sup)/(beta*(theta(izz)-theta(iz)))
2524 else
2525 tl=0.
2526 endif
2527 endif
2528 dld(iz)=zzz-dzt+tl
2529 !print*," FOUND Ddown:",dld(iz)," z=",zw(izz)," tl=",tl
2530 found = 1
2531 endif
2532 zdo_sup=zdo
2533 izz=izz-1
2534 ELSE
2535 found = 1
2536 ENDIF
2537 ENDDO
2539 endif
2541 !----------------------------------
2542 ! GET MINIMUM (OR AVERAGE)
2543 !----------------------------------
2544 !The surface layer length scale can exceed z for large z/L,
2545 !so keep maximum distance down > z.
2546 dld(iz) = min(dld(iz),zw(iz+1))!not used in PBL anyway, only free atmos
2547 lb1(iz) = min(dlu(iz),dld(iz)) !minimum
2548 !JOE-fight floating point errors
2549 dlu(iz)=MAX(0.1,MIN(dlu(iz),1000.))
2550 dld(iz)=MAX(0.1,MIN(dld(iz),1000.))
2551 lb2(iz) = sqrt(dlu(iz)*dld(iz)) !average - biased towards smallest
2552 !lb2(iz) = 0.5*(dlu(iz)+dld(iz)) !average
2554 !Apply soft limit (only impacts very large lb; lb=100 by 5%, lb=500 by 20%).
2555 lb1(iz) = lb1(iz)/(1. + (lb1(iz)/Lmax))
2556 lb2(iz) = lb2(iz)/(1. + (lb2(iz)/Lmax))
2558 if (iz .eq. kte) then
2559 lb1(kte) = lb1(kte-1)
2560 lb2(kte) = lb2(kte-1)
2561 endif
2562 !print*,"IN MYNN-BouLac",kts, kte,lb1(iz)
2563 !print*,"IN MYNN-BouLac",iz,dld(iz),dlu(iz)
2565 ENDDO
2567 END SUBROUTINE boulac_length
2568 !
2569 ! ==================================================================
2570 ! SUBROUTINE mym_turbulence:
2571 !
2572 ! Input variables: see subroutine mym_initialize
2573 ! closure : closure level (2.5, 2.6, or 3.0)
2574 !
2575 ! # ql, vt, vq, qke, tsq, qsq and cov are changed to input variables.
2576 !
2577 ! Output variables: see subroutine mym_initialize
2578 ! dfm(nx,nz,ny) : Diffusivity coefficient for momentum,
2579 ! divided by dz (not dz*h(i,j)) (m/s)
2580 ! dfh(nx,nz,ny) : Diffusivity coefficient for heat,
2581 ! divided by dz (not dz*h(i,j)) (m/s)
2582 ! dfq(nx,nz,ny) : Diffusivity coefficient for q^2,
2583 ! divided by dz (not dz*h(i,j)) (m/s)
2584 ! tcd(nx,nz,ny) : Countergradient diffusion term for Theta_l
2585 ! (K/s)
2586 ! qcd(nx,nz,ny) : Countergradient diffusion term for Q_w
2587 ! (kg/kg s)
2588 ! pd?(nx,nz,ny) : Half of the production terms
2589 !
2590 ! Only tcd and qcd are defined at the center of the grid boxes
2591 !
2592 ! # DO NOT forget that tcd and qcd are added on the right-hand side
2593 ! of the equations for Theta_l and Q_w, respectively.
2594 !
2595 ! Work arrays: see subroutine mym_initialize and level2
2596 !
2597 ! # dtl, dqw, dtv, gm and gh are allowed to share storage units with
2598 ! dfm, dfh, dfq, tcd and qcd, respectively, for saving memory.
2599 !
2600 !>\ingroup gsd_mynn_edmf
2601 !! This subroutine calculates the vertical diffusivity coefficients and the
2602 !! production terms for the turbulent quantities.
2603 !>\section gen_mym_turbulence GSD mym_turbulence General Algorithm
2604 !! Two subroutines mym_level2() and mym_length() are called within this
2605 !!subrouine to collect variable to carry out successive calculations:
2606 !! - mym_level2() calculates the level 2 nondimensional wind shear \f$G_M\f$
2607 !! and vertical temperature gradient \f$G_H\f$ as well as the level 2 stability
2608 !! functions \f$S_h\f$ and \f$S_m\f$.
2609 !! - mym_length() calculates the mixing lengths.
2610 !! - The stability criteria from Helfand and Labraga (1989) are applied.
2611 !! - The stability functions for level 2.5 or level 3.0 are calculated.
2612 !! - If level 3.0 is used, counter-gradient terms are calculated.
2613 !! - Production terms of TKE,\f$\theta^{'2}\f$,\f$q^{'2}\f$, and \f$\theta^{'}q^{'}\f$
2614 !! are calculated.
2615 !! - Eddy diffusivity \f$K_h\f$ and eddy viscosity \f$K_m\f$ are calculated.
2616 !! - TKE budget terms are calculated (if the namelist parameter \p tke_budget
2617 !! is set to True)
2618 SUBROUTINE mym_turbulence ( &
2619 & kts,kte, &
2620 & xland,closure, &
2621 & dz, dx, zw, &
2622 & u, v, thl, thetav, ql, qw, &
2623 & qke, tsq, qsq, cov, &
2624 & vt, vq, &
2625 & rmo, flt, fltv, flq, &
2626 & zi,theta, &
2627 & sh, sm, &
2628 & El, &
2629 & Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc, &
2630 & qWT1D,qSHEAR1D,qBUOY1D,qDISS1D, &
2631 & tke_budget, &
2632 & Psig_bl,Psig_shcu,cldfra_bl1D, &
2633 & bl_mynn_mixlength, &
2634 & edmf_w1,edmf_a1, &
2635 & TKEprodTD, &
2636 & spp_pbl,rstoch_col )
2638 !-------------------------------------------------------------------
2640 integer, intent(in) :: kts,kte
2642 #ifdef HARDCODE_VERTICAL
2643 # define kts 1
2644 # define kte HARDCODE_VERTICAL
2645 #endif
2647 integer, intent(in) :: bl_mynn_mixlength,tke_budget
2648 real(kind_phys), intent(in) :: closure
2649 real(kind_phys), dimension(kts:kte), intent(in) :: dz
2650 real(kind_phys), dimension(kts:kte+1), intent(in) :: zw
2651 real(kind_phys), intent(in) :: rmo,flt,fltv,flq, &
2652 &Psig_bl,Psig_shcu,xland,dx,zi
2653 real(kind_phys), dimension(kts:kte), intent(in) :: u,v,thl,thetav,qw, &
2654 &ql,vt,vq,qke,tsq,qsq,cov,cldfra_bl1D,edmf_w1,edmf_a1, &
2655 &TKEprodTD
2657 real(kind_phys), dimension(kts:kte), intent(out) :: dfm,dfh,dfq, &
2658 &pdk,pdt,pdq,pdc,tcd,qcd,el
2660 real(kind_phys), dimension(kts:kte), intent(inout) :: &
2661 qWT1D,qSHEAR1D,qBUOY1D,qDISS1D
2662 real(kind_phys):: q3sq_old,dlsq1,qWTP_old,qWTP_new
2663 real(kind_phys):: dudz,dvdz,dTdz,upwp,vpwp,Tpwp
2665 real(kind_phys), dimension(kts:kte) :: qkw,dtl,dqw,dtv,gm,gh,sm,sh
2667 integer :: k
2668 ! real(kind_phys):: cc2,cc3,e1c,e2c,e3c,e4c,e5c
2669 real(kind_phys):: e6c,dzk,afk,abk,vtt,vqq, &
2670 &cw25,clow,cupp,gamt,gamq,smd,gamv,elq,elh
2672 real(kind_phys):: cldavg
2673 real(kind_phys), dimension(kts:kte), intent(in) :: theta
2675 real(kind_phys):: a2fac, duz, ri !JOE-Canuto/Kitamura mod
2677 real:: auh,aum,adh,adm,aeh,aem,Req,Rsl,Rsl2, &
2678 gmelq,sm20,sh20,sm25max,sh25max,sm25min,sh25min, &
2679 sm_pbl,sh_pbl,zi2,wt,slht,wtpr
2681 DOUBLE PRECISION q2sq, t2sq, r2sq, c2sq, elsq, gmel, ghel
2682 DOUBLE PRECISION q3sq, t3sq, r3sq, c3sq, dlsq, qdiv
2683 DOUBLE PRECISION e1, e2, e3, e4, enum, eden, wden
2685 ! Stochastic
2686 integer, intent(in) :: spp_pbl
2687 real(kind_phys), dimension(kts:kte) :: rstoch_col
2688 real(kind_phys):: Prnum, shb
2689 real(kind_phys), parameter :: Prlimit = 5.0
2691 !
2692 ! tv0 = 0.61*tref
2693 ! gtr = 9.81/tref
2694 !
2695 ! cc2 = 1.0-c2
2696 ! cc3 = 1.0-c3
2697 ! e1c = 3.0*a2*b2*cc3
2698 ! e2c = 9.0*a1*a2*cc2
2699 ! e3c = 9.0*a2*a2*cc2*( 1.0-c5 )
2700 ! e4c = 12.0*a1*a2*cc2
2701 ! e5c = 6.0*a1*a1
2702 !
2704 CALL mym_level2 (kts,kte, &
2705 & dz, &
2706 & u, v, thl, thetav, qw, &
2707 & ql, vt, vq, &
2708 & dtl, dqw, dtv, gm, gh, sm, sh )
2709 !
2710 CALL mym_length ( &
2711 & kts,kte,xland, &
2712 & dz, dx, zw, &
2713 & rmo, flt, fltv, flq, &
2714 & vt, vq, &
2715 & u, v, qke, &
2716 & dtv, &
2717 & el, &
2718 & zi,theta, &
2719 & qkw,Psig_bl,cldfra_bl1D, &
2720 & bl_mynn_mixlength, &
2721 & edmf_w1,edmf_a1 )
2722 !
2724 DO k = kts+1,kte
2725 dzk = 0.5 *( dz(k)+dz(k-1) )
2726 afk = dz(k)/( dz(k)+dz(k-1) )
2727 abk = 1.0 -afk
2728 elsq = el (k)**2
2729 q3sq = qkw(k)**2
2730 q2sq = b1*elsq*( sm(k)*gm(k)+sh(k)*gh(k) )
2732 sh20 = MAX(sh(k), 1e-5)
2733 sm20 = MAX(sm(k), 1e-5)
2734 sh(k)= MAX(sh(k), 1e-5)
2736 !Canuto/Kitamura mod
2737 duz = ( u(k)-u(k-1) )**2 +( v(k)-v(k-1) )**2
2738 duz = duz /dzk**2
2739 ! ** Gradient Richardson number **
2740 ri = -gh(k)/MAX( duz, 1.0e-10 )
2741 IF (CKmod .eq. 1) THEN
2742 a2fac = 1./(1. + MAX(ri,0.0))
2743 ELSE
2744 a2fac = 1.
2745 ENDIF
2746 !end Canuto/Kitamura mod
2748 !level 2.0 Prandtl number
2749 !Prnum = MIN(sm20/sh20, 4.0)
2750 !The form of Zilitinkevich et al. (2006) but modified
2751 !half-way towards Esau and Grachev (2007, Wind Eng)
2752 !Prnum = MIN(0.76 + 3.0*MAX(ri,0.0), Prlimit)
2753 Prnum = MIN(0.76 + 4.0*MAX(ri,0.0), Prlimit)
2754 !Prnum = MIN(0.76 + 5.0*MAX(ri,0.0), Prlimit)
2755 !
2756 ! Modified: Dec/22/2005, from here, (dlsq -> elsq)
2757 gmel = gm (k)*elsq
2758 ghel = gh (k)*elsq
2759 ! Modified: Dec/22/2005, up to here
2761 ! Level 2.0 debug prints
2762 IF ( debug_code ) THEN
2763 IF (sh(k)<0.0 .OR. sm(k)<0.0) THEN
2764 print*,"MYNN; mym_turbulence 2.0; sh=",sh(k)," k=",k
2765 print*," gm=",gm(k)," gh=",gh(k)," sm=",sm(k)
2766 print*," q2sq=",q2sq," q3sq=",q3sq," q3/q2=",q3sq/q2sq
2767 print*," qke=",qke(k)," el=",el(k)," ri=",ri
2768 print*," PBLH=",zi," u=",u(k)," v=",v(k)
2769 ENDIF
2770 ENDIF
2772 ! ** Since qkw is set to more than 0.0, q3sq > 0.0. **
2774 ! new stability criteria in level 2.5 (as well as level 3) - little/no impact
2775 ! ** Limitation on q, instead of L/q **
2776 dlsq = elsq
2777 IF ( q3sq/dlsq .LT. -gh(k) ) q3sq = -dlsq*gh(k)
2779 IF ( q3sq .LT. q2sq ) THEN
2780 !Apply Helfand & Labraga mod
2781 qdiv = SQRT( q3sq/q2sq ) !HL89: (1-alfa)
2782 !
2783 !Use level 2.5 stability functions
2784 !e1 = q3sq - e1c*ghel*a2fac
2785 !e2 = q3sq - e2c*ghel*a2fac
2786 !e3 = e1 + e3c*ghel*a2fac**2
2787 !e4 = e1 - e4c*ghel*a2fac
2788 !eden = e2*e4 + e3*e5c*gmel
2789 !eden = MAX( eden, 1.0d-20 )
2790 !sm(k) = q3sq*a1*( e3-3.0*c1*e4 )/eden
2791 !!JOE-Canuto/Kitamura mod
2792 !!sh(k) = q3sq*a2*( e2+3.0*c1*e5c*gmel )/eden
2793 !sh(k) = q3sq*(a2*a2fac)*( e2+3.0*c1*e5c*gmel )/eden
2794 !sm(k) = Prnum*sh(k)
2795 !sm(k) = sm(k) * qdiv
2797 !Use level 2.0 functions as in original MYNN
2798 sh(k) = sh(k) * qdiv
2799 sm(k) = sm(k) * qdiv
2800 ! !sm_pbl = sm(k) * qdiv
2801 !
2802 ! !Or, use the simple Pr relationship
2803 ! sm(k) = Prnum*sh(k)
2804 !
2805 ! !or blend them:
2806 ! zi2 = MAX(zi, 300.)
2807 ! wt =.5*TANH((zw(k) - zi2)/200.) + .5
2808 ! sm(k) = sm_pbl*(1.-wt) + sm(k)*wt
2810 !Recalculate terms for later use
2811 !JOE-Canuto/Kitamura mod
2812 !e1 = q3sq - e1c*ghel * qdiv**2
2813 !e2 = q3sq - e2c*ghel * qdiv**2
2814 !e3 = e1 + e3c*ghel * qdiv**2
2815 !e4 = e1 - e4c*ghel * qdiv**2
2816 e1 = q3sq - e1c*ghel*a2fac * qdiv**2
2817 e2 = q3sq - e2c*ghel*a2fac * qdiv**2
2818 e3 = e1 + e3c*ghel*a2fac**2 * qdiv**2
2819 e4 = e1 - e4c*ghel*a2fac * qdiv**2
2820 eden = e2*e4 + e3*e5c*gmel * qdiv**2
2821 eden = MAX( eden, 1.0d-20 )
2822 !!JOE-Canuto/Kitamura mod
2823 !!sh(k) = q3sq*a2*( e2+3.0*c1*e5c*gmel )/eden - retro 5
2824 !sh(k) = q3sq*(a2*a2fac)*( e2+3.0*c1*e5c*gmel )/eden
2825 !sm(k) = Prnum*sh(k)
2826 ELSE
2827 !JOE-Canuto/Kitamura mod
2828 !e1 = q3sq - e1c*ghel
2829 !e2 = q3sq - e2c*ghel
2830 !e3 = e1 + e3c*ghel
2831 !e4 = e1 - e4c*ghel
2832 e1 = q3sq - e1c*ghel*a2fac
2833 e2 = q3sq - e2c*ghel*a2fac
2834 e3 = e1 + e3c*ghel*a2fac**2
2835 e4 = e1 - e4c*ghel*a2fac
2836 eden = e2*e4 + e3*e5c*gmel
2837 eden = MAX( eden, 1.0d-20 )
2839 qdiv = 1.0
2840 !Use level 2.5 stability functions
2841 sm(k) = q3sq*a1*( e3-3.0*c1*e4 )/eden
2842 ! sm_pbl = q3sq*a1*( e3-3.0*c1*e4 )/eden
2843 !!JOE-Canuto/Kitamura mod
2844 !!sh(k) = q3sq*a2*( e2+3.0*c1*e5c*gmel )/eden
2845 sh(k) = q3sq*(a2*a2fac)*( e2+3.0*c1*e5c*gmel )/eden
2846 ! sm(k) = Prnum*sh(k)
2848 ! !or blend them:
2849 ! zi2 = MAX(zi, 300.)
2850 ! wt = .5*TANH((zw(k) - zi2)/200.) + .5
2851 ! sm(k) = sm_pbl*(1.-wt) + sm(k)*wt
2852 END IF !end Helfand & Labraga check
2854 !Impose broad limits on Sh and Sm:
2855 gmelq = MAX(gmel/q3sq, 1e-8)
2856 sm25max = 4. !MIN(sm20*3.0, SQRT(.1936/gmelq))
2857 sh25max = 4. !MIN(sh20*3.0, 0.76*b2)
2858 sm25min = 0.0 !MAX(sm20*0.1, 1e-6)
2859 sh25min = 0.0 !MAX(sh20*0.1, 1e-6)
2861 !JOE: Level 2.5 debug prints
2862 ! HL88 , lev2.5 criteria from eqs. 3.17, 3.19, & 3.20
2863 IF ( debug_code ) THEN
2864 IF ((sh(k)<sh25min .OR. sm(k)<sm25min .OR. &
2865 sh(k)>sh25max .OR. sm(k)>sm25max) ) THEN
2866 print*,"In mym_turbulence 2.5: k=",k
2867 print*," sm=",sm(k)," sh=",sh(k)
2868 print*," ri=",ri," Pr=",sm(k)/MAX(sh(k),1e-8)
2869 print*," gm=",gm(k)," gh=",gh(k)
2870 print*," q2sq=",q2sq," q3sq=",q3sq, q3sq/q2sq
2871 print*," qke=",qke(k)," el=",el(k)
2872 print*," PBLH=",zi," u=",u(k)," v=",v(k)
2873 print*," SMnum=",q3sq*a1*( e3-3.0*c1*e4)," SMdenom=",eden
2874 print*," SHnum=",q3sq*(a2*a2fac)*( e2+3.0*c1*e5c*gmel ),&
2875 " SHdenom=",eden
2876 ENDIF
2877 ENDIF
2879 !Enforce constraints for level 2.5 functions
2880 IF ( sh(k) > sh25max ) sh(k) = sh25max
2881 IF ( sh(k) < sh25min ) sh(k) = sh25min
2882 !IF ( sm(k) > sm25max ) sm(k) = sm25max
2883 !IF ( sm(k) < sm25min ) sm(k) = sm25min
2884 !sm(k) = Prnum*sh(k)
2886 !surface layer PR
2887 !slht = zi*0.1
2888 !wtpr = min( max( (slht - zw(k))/slht, 0.0), 1.0) ! 1 at z=0, 0 above sfc layer
2889 !Prlim = 1.0*wtpr + (1.0 - wtpr)*Prlimit
2890 !Prlim = 2.0*wtpr + (1.0 - wtpr)*Prlimit
2891 !sm(k) = MIN(sm(k), Prlim*Sh(k))
2892 !Pending more testing, keep same Pr limit in sfc layer
2893 shb = max(sh(k), 0.02)
2894 sm(k) = MIN(sm(k), Prlimit*shb)
2896 ! ** Level 3 : start **
2897 IF ( closure .GE. 3.0 ) THEN
2898 t2sq = qdiv*b2*elsq*sh(k)*dtl(k)**2
2899 r2sq = qdiv*b2*elsq*sh(k)*dqw(k)**2
2900 c2sq = qdiv*b2*elsq*sh(k)*dtl(k)*dqw(k)
2901 t3sq = MAX( tsq(k)*abk+tsq(k-1)*afk, 0.0 )
2902 r3sq = MAX( qsq(k)*abk+qsq(k-1)*afk, 0.0 )
2903 c3sq = cov(k)*abk+cov(k-1)*afk
2905 ! Modified: Dec/22/2005, from here
2906 c3sq = SIGN( MIN( ABS(c3sq), SQRT(t3sq*r3sq) ), c3sq )
2907 !
2908 vtt = 1.0 +vt(k)*abk +vt(k-1)*afk
2909 vqq = tv0 +vq(k)*abk +vq(k-1)*afk
2911 t2sq = vtt*t2sq +vqq*c2sq
2912 r2sq = vtt*c2sq +vqq*r2sq
2913 c2sq = MAX( vtt*t2sq+vqq*r2sq, 0.0d0 )
2914 t3sq = vtt*t3sq +vqq*c3sq
2915 r3sq = vtt*c3sq +vqq*r3sq
2916 c3sq = MAX( vtt*t3sq+vqq*r3sq, 0.0d0 )
2917 !
2918 cw25 = e1*( e2 + 3.0*c1*e5c*gmel*qdiv**2 )/( 3.0*eden )
2919 !
2920 ! ** Limitation on q, instead of L/q **
2921 dlsq = elsq
2922 IF ( q3sq/dlsq .LT. -gh(k) ) q3sq = -dlsq*gh(k)
2923 !
2924 ! ** Limitation on c3sq (0.12 =< cw =< 0.76) **
2925 ! Use Janjic's (2001; p 13-17) methodology (eqs 4.11-414 and 5.7-5.10)
2926 ! to calculate an exact limit for c3sq:
2927 auh = 27.*a1*((a2*a2fac)**2)*b2*(gtr)**2
2928 aum = 54.*(a1**2)*(a2*a2fac)*b2*c1*(gtr)
2929 adh = 9.*a1*((a2*a2fac)**2)*(12.*a1 + 3.*b2)*(gtr)**2
2930 adm = 18.*(a1**2)*(a2*a2fac)*(b2 - 3.*(a2*a2fac))*(gtr)
2932 aeh = (9.*a1*((a2*a2fac)**2)*b1 +9.*a1*((a2*a2fac)**2)* &
2933 (12.*a1 + 3.*b2))*(gtr)
2934 aem = 3.*a1*(a2*a2fac)*b1*(3.*(a2*a2fac) + 3.*b2*c1 + &
2935 (18.*a1*c1 - b2)) + &
2936 (18.)*(a1**2)*(a2*a2fac)*(b2 - 3.*(a2*a2fac))
2938 Req = -aeh/aem
2939 Rsl = (auh + aum*Req)/(3.*adh + 3.*adm*Req)
2940 !For now, use default values, since tests showed little/no sensitivity
2941 Rsl = .12 !lower limit
2942 Rsl2= 1.0 - 2.*Rsl !upper limit
2943 !IF (k==2)print*,"Dynamic limit RSL=",Rsl
2944 !IF (Rsl < 0.10 .OR. Rsl > 0.18) THEN
2945 ! print*,'--- ERROR: MYNN: Dynamic Cw '// &
2946 ! 'limit exceeds reasonable limits'
2947 ! print*," MYNN: Dynamic Cw limit needs attention=",Rsl
2948 !ENDIF
2950 !JOE-Canuto/Kitamura mod
2951 !e2 = q3sq - e2c*ghel * qdiv**2
2952 !e3 = q3sq + e3c*ghel * qdiv**2
2953 !e4 = q3sq - e4c*ghel * qdiv**2
2954 e2 = q3sq - e2c*ghel*a2fac * qdiv**2
2955 e3 = q3sq + e3c*ghel*a2fac**2 * qdiv**2
2956 e4 = q3sq - e4c*ghel*a2fac * qdiv**2
2957 eden = e2*e4 + e3 *e5c*gmel * qdiv**2
2959 !JOE-Canuto/Kitamura mod
2960 !wden = cc3*gtr**2 * dlsq**2/elsq * qdiv**2 &
2961 ! & *( e2*e4c - e3c*e5c*gmel * qdiv**2 )
2962 wden = cc3*gtr**2 * dlsq**2/elsq * qdiv**2 &
2963 & *( e2*e4c*a2fac - e3c*e5c*gmel*a2fac**2 * qdiv**2 )
2965 IF ( wden .NE. 0.0 ) THEN
2966 !JOE: test dynamic limits
2967 clow = q3sq*( 0.12-cw25 )*eden/wden
2968 cupp = q3sq*( 0.76-cw25 )*eden/wden
2969 !clow = q3sq*( Rsl -cw25 )*eden/wden
2970 !cupp = q3sq*( Rsl2-cw25 )*eden/wden
2971 !
2972 IF ( wden .GT. 0.0 ) THEN
2973 c3sq = MIN( MAX( c3sq, c2sq+clow ), c2sq+cupp )
2974 ELSE
2975 c3sq = MAX( MIN( c3sq, c2sq+clow ), c2sq+cupp )
2976 END IF
2977 END IF
2978 !
2979 e1 = e2 + e5c*gmel * qdiv**2
2980 eden = MAX( eden, 1.0d-20 )
2981 ! Modified: Dec/22/2005, up to here
2983 !JOE-Canuto/Kitamura mod
2984 !e6c = 3.0*a2*cc3*gtr * dlsq/elsq
2985 e6c = 3.0*(a2*a2fac)*cc3*gtr * dlsq/elsq
2987 !============================
2988 ! ** for Gamma_theta **
2989 !! enum = qdiv*e6c*( t3sq-t2sq )
2990 IF ( t2sq .GE. 0.0 ) THEN
2991 enum = MAX( qdiv*e6c*( t3sq-t2sq ), 0.0d0 )
2992 ELSE
2993 enum = MIN( qdiv*e6c*( t3sq-t2sq ), 0.0d0 )
2994 ENDIF
2995 gamt =-e1 *enum /eden
2997 !============================
2998 ! ** for Gamma_q **
2999 !! enum = qdiv*e6c*( r3sq-r2sq )
3000 IF ( r2sq .GE. 0.0 ) THEN
3001 enum = MAX( qdiv*e6c*( r3sq-r2sq ), 0.0d0 )
3002 ELSE
3003 enum = MIN( qdiv*e6c*( r3sq-r2sq ), 0.0d0 )
3004 ENDIF
3005 gamq =-e1 *enum /eden
3007 !============================
3008 ! ** for Sm' and Sh'd(Theta_V)/dz **
3009 !! enum = qdiv*e6c*( c3sq-c2sq )
3010 enum = MAX( qdiv*e6c*( c3sq-c2sq ), 0.0d0)
3012 !JOE-Canuto/Kitamura mod
3013 !smd = dlsq*enum*gtr/eden * qdiv**2 * (e3c+e4c)*a1/a2
3014 smd = dlsq*enum*gtr/eden * qdiv**2 * (e3c*a2fac**2 + &
3015 & e4c*a2fac)*a1/(a2*a2fac)
3017 gamv = e1 *enum*gtr/eden
3018 sm(k) = sm(k) +smd
3020 !============================
3021 ! ** For elh (see below), qdiv at Level 3 is reset to 1.0. **
3022 qdiv = 1.0
3024 ! Level 3 debug prints
3025 IF ( debug_code ) THEN
3026 IF (sh(k)<-0.3 .OR. sm(k)<-0.3 .OR. &
3027 qke(k) < -0.1 .or. ABS(smd) .gt. 2.0) THEN
3028 print*," MYNN; mym_turbulence3.0; sh=",sh(k)," k=",k
3029 print*," gm=",gm(k)," gh=",gh(k)," sm=",sm(k)
3030 print*," q2sq=",q2sq," q3sq=",q3sq," q3/q2=",q3sq/q2sq
3031 print*," qke=",qke(k)," el=",el(k)," ri=",ri
3032 print*," PBLH=",zi," u=",u(k)," v=",v(k)
3033 ENDIF
3034 ENDIF
3036 ! ** Level 3 : end **
3038 ELSE
3039 ! ** At Level 2.5, qdiv is not reset. **
3040 gamt = 0.0
3041 gamq = 0.0
3042 gamv = 0.0
3043 END IF
3044 !
3045 ! Add min background stability function (diffusivity) within model levels
3046 ! with active plumes and clouds.
3047 cldavg = 0.5*(cldfra_bl1D(k-1) + cldfra_bl1D(k))
3048 IF (edmf_a1(k) > 0.001 .OR. cldavg > 0.02) THEN
3049 ! for mass-flux columns
3050 sm(k) = MAX(sm(k), 0.03*MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) )
3051 sh(k) = MAX(sh(k), 0.03*MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) )
3052 ! for clouds
3053 sm(k) = MAX(sm(k), 0.05*MIN(cldavg,1.0) )
3054 sh(k) = MAX(sh(k), 0.05*MIN(cldavg,1.0) )
3055 ENDIF
3056 !
3057 elq = el(k)*qkw(k)
3058 elh = elq*qdiv
3060 ! Production of TKE (pdk), T-variance (pdt),
3061 ! q-variance (pdq), and covariance (pdc)
3062 pdk(k) = elq*( sm(k)*gm(k) &
3063 & +sh(k)*gh(k)+gamv ) + &
3064 & 0.5*TKEprodTD(k) ! xmchen
3065 pdt(k) = elh*( sh(k)*dtl(k)+gamt )*dtl(k)
3066 pdq(k) = elh*( sh(k)*dqw(k)+gamq )*dqw(k)
3067 pdc(k) = elh*( sh(k)*dtl(k)+gamt ) &
3068 & *dqw(k)*0.5 &
3069 & + elh*( sh(k)*dqw(k)+gamq )*dtl(k)*0.5
3071 ! Contergradient terms
3072 tcd(k) = elq*gamt
3073 qcd(k) = elq*gamq
3075 ! Eddy Diffusivity/Viscosity divided by dz
3076 dfm(k) = elq*sm(k) / dzk
3077 dfh(k) = elq*sh(k) / dzk
3078 ! Modified: Dec/22/2005, from here
3079 ! ** In sub.mym_predict, dfq for the TKE and scalar variance **
3080 ! ** are set to 3.0*dfm and 1.0*dfm, respectively. (Sqfac) **
3081 dfq(k) = dfm(k)
3082 ! Modified: Dec/22/2005, up to here
3084 IF (tke_budget .eq. 1) THEN
3085 !TKE BUDGET
3086 ! dudz = ( u(k)-u(k-1) )/dzk
3087 ! dvdz = ( v(k)-v(k-1) )/dzk
3088 ! dTdz = ( thl(k)-thl(k-1) )/dzk
3090 ! upwp = -elq*sm(k)*dudz
3091 ! vpwp = -elq*sm(k)*dvdz
3092 ! Tpwp = -elq*sh(k)*dTdz
3093 ! Tpwp = SIGN(MAX(ABS(Tpwp),1.E-6),Tpwp)
3096 !! TKE budget (Puhales, 2020, WRF 4.2.1) << EOB
3098 !!!Shear Term
3099 !!!qSHEAR1D(k)=-(upwp*dudz + vpwp*dvdz)
3100 qSHEAR1D(k) = elq*sm(k)*gm(k) !staggered
3102 !!!Buoyancy Term
3103 !!!qBUOY1D(k)=grav*Tpwp/thl(k)
3104 !qBUOY1D(k)= elq*(sh(k)*gh(k) + gamv)
3105 !qBUOY1D(k) = elq*(sh(k)*(-dTdz*grav/thl(k)) + gamv) !! ORIGINAL CODE
3107 !! Buoyncy term takes the TKEprodTD(k) production now
3108 qBUOY1D(k) = elq*(sh(k)*gh(k)+gamv)+0.5*TKEprodTD(k) ! xmchen
3110 !!!Dissipation Term (now it evaluated in mym_predict)
3111 !qDISS1D(k) = (q3sq**(3./2.))/(b1*MAX(el(k),1.)) !! ORIGINAL CODE
3113 !! >> EOB
3114 ENDIF
3116 END DO
3117 !
3119 dfm(kts) = 0.0
3120 dfh(kts) = 0.0
3121 dfq(kts) = 0.0
3122 tcd(kts) = 0.0
3123 qcd(kts) = 0.0
3125 tcd(kte) = 0.0
3126 qcd(kte) = 0.0
3128 !
3129 DO k = kts,kte-1
3130 dzk = dz(k)
3131 tcd(k) = ( tcd(k+1)-tcd(k) )/( dzk )
3132 qcd(k) = ( qcd(k+1)-qcd(k) )/( dzk )
3133 END DO
3134 !
3135 if (spp_pbl==1) then
3136 DO k = kts,kte
3137 dfm(k)= dfm(k) + dfm(k)* rstoch_col(k) * 1.5 * MAX(exp(-MAX(zw(k)-8000.,0.0)/2000.),0.001)
3138 dfh(k)= dfh(k) + dfh(k)* rstoch_col(k) * 1.5 * MAX(exp(-MAX(zw(k)-8000.,0.0)/2000.),0.001)
3139 END DO
3140 endif
3142 ! RETURN
3143 #ifdef HARDCODE_VERTICAL
3144 # undef kts
3145 # undef kte
3146 #endif
3148 END SUBROUTINE mym_turbulence
3150 ! ==================================================================
3151 ! SUBROUTINE mym_predict:
3152 !
3153 ! Input variables: see subroutine mym_initialize and turbulence
3154 ! qke(nx,nz,ny) : qke at (n)th time level
3155 ! tsq, ...cov : ditto
3156 !
3157 ! Output variables:
3158 ! qke(nx,nz,ny) : qke at (n+1)th time level
3159 ! tsq, ...cov : ditto
3160 !
3161 ! Work arrays:
3162 ! qkw(nx,nz,ny) : q at the center of the grid boxes (m/s)
3163 ! bp (nx,nz,ny) : = 1/2*F, see below
3164 ! rp (nx,nz,ny) : = P-1/2*F*Q, see below
3165 !
3166 ! # The equation for a turbulent quantity Q can be expressed as
3167 ! dQ/dt + Ah + Av = Dh + Dv + P - F*Q, (1)
3168 ! where A is the advection, D the diffusion, P the production,
3169 ! F*Q the dissipation and h and v denote horizontal and vertical,
3170 ! respectively. If Q is q^2, F is 2q/B_1L.
3171 ! Using the Crank-Nicholson scheme for Av, Dv and F*Q, a finite
3172 ! difference equation is written as
3173 ! Q{n+1} - Q{n} = dt *( Dh{n} - Ah{n} + P{n} )
3174 ! + dt/2*( Dv{n} - Av{n} - F*Q{n} )
3175 ! + dt/2*( Dv{n+1} - Av{n+1} - F*Q{n+1} ), (2)
3176 ! where n denotes the time level.
3177 ! When the advection and diffusion terms are discretized as
3178 ! dt/2*( Dv - Av ) = a(k)Q(k+1) - b(k)Q(k) + c(k)Q(k-1), (3)
3179 ! Eq.(2) can be rewritten as
3180 ! - a(k)Q(k+1) + [ 1 + b(k) + dt/2*F ]Q(k) - c(k)Q(k-1)
3181 ! = Q{n} + dt *( Dh{n} - Ah{n} + P{n} )
3182 ! + dt/2*( Dv{n} - Av{n} - F*Q{n} ), (4)
3183 ! where Q on the left-hand side is at (n+1)th time level.
3184 !
3185 ! In this subroutine, a(k), b(k) and c(k) are obtained from
3186 ! subprogram coefvu and are passed to subprogram tinteg via
3187 ! common. 1/2*F and P-1/2*F*Q are stored in bp and rp,
3188 ! respectively. Subprogram tinteg solves Eq.(4).
3189 !
3190 ! Modify this subroutine according to your numerical integration
3191 ! scheme (program).
3192 !
3193 !-------------------------------------------------------------------
3194 !>\ingroup gsd_mynn_edmf
3195 !! This subroutine predicts the turbulent quantities at the next step.
3196 SUBROUTINE mym_predict (kts,kte, &
3197 & closure, &
3198 & delt, &
3199 & dz, &
3200 & ust, flt, flq, pmz, phh, &
3201 & el, dfq, rho, &
3202 & pdk, pdt, pdq, pdc, &
3203 & qke, tsq, qsq, cov, &
3204 & s_aw,s_awqke,bl_mynn_edmf_tke, &
3205 & qWT1D, qDISS1D,tke_budget) !! TKE budget (Puhales, 2020)
3207 !-------------------------------------------------------------------
3208 integer, intent(in) :: kts,kte
3210 #ifdef HARDCODE_VERTICAL
3211 # define kts 1
3212 # define kte HARDCODE_VERTICAL
3213 #endif
3215 real(kind_phys), intent(in) :: closure
3216 integer, intent(in) :: bl_mynn_edmf_tke,tke_budget
3217 real(kind_phys), dimension(kts:kte), intent(in) :: dz, dfq, el, rho
3218 real(kind_phys), dimension(kts:kte), intent(inout) :: pdk, pdt, pdq, pdc
3219 real(kind_phys), intent(in) :: flt, flq, pmz, phh
3220 real(kind_phys), intent(in) :: ust, delt
3221 real(kind_phys), dimension(kts:kte), intent(inout) :: qke,tsq, qsq, cov
3222 ! WA 8/3/15
3223 real(kind_phys), dimension(kts:kte+1), intent(inout) :: s_awqke,s_aw
3225 !! TKE budget (Puhales, 2020, WRF 4.2.1) << EOB
3226 real(kind_phys), dimension(kts:kte), intent(out) :: qWT1D, qDISS1D
3227 real(kind_phys), dimension(kts:kte) :: tke_up,dzinv
3228 !! >> EOB
3230 integer :: k
3231 real(kind_phys), dimension(kts:kte) :: qkw, bp, rp, df3q
3232 real(kind_phys):: vkz,pdk1,phm,pdt1,pdq1,pdc1,b1l,b2l,onoff
3233 real(kind_phys), dimension(kts:kte) :: dtz
3234 real(kind_phys), dimension(kts:kte) :: a,b,c,d,x
3236 real(kind_phys), dimension(kts:kte) :: rhoinv
3237 real(kind_phys), dimension(kts:kte+1) :: rhoz,kqdz,kmdz
3239 ! REGULATE THE MOMENTUM MIXING FROM THE MASS-FLUX SCHEME (on or off)
3240 IF (bl_mynn_edmf_tke == 0) THEN
3241 onoff=0.0
3242 ELSE
3243 onoff=1.0
3244 ENDIF
3246 ! ** Strictly, vkz*h(i,j) -> karman*( 0.5*dz(1)*h(i,j)+z0 ) **
3247 vkz = karman*0.5*dz(kts)
3248 !
3249 ! ** dfq for the TKE is 3.0*dfm. **
3250 !
3251 DO k = kts,kte
3252 !! qke(k) = MAX(qke(k), 0.0)
3253 qkw(k) = SQRT( MAX( qke(k), 0.0 ) )
3254 df3q(k)=Sqfac*dfq(k)
3255 dtz(k)=delt/dz(k)
3256 END DO
3257 !
3258 !JOE-add conservation + stability criteria
3259 !Prepare "constants" for diffusion equation.
3260 !khdz = rho*Kh/dz = rho*dfh
3261 rhoz(kts) =rho(kts)
3262 rhoinv(kts)=1./rho(kts)
3263 kqdz(kts) =rhoz(kts)*df3q(kts)
3264 kmdz(kts) =rhoz(kts)*dfq(kts)
3265 DO k=kts+1,kte
3266 rhoz(k) =(rho(k)*dz(k-1) + rho(k-1)*dz(k))/(dz(k-1)+dz(k))
3267 rhoz(k) = MAX(rhoz(k),1E-4)
3268 rhoinv(k)=1./MAX(rho(k),1E-4)
3269 kqdz(k) = rhoz(k)*df3q(k) ! for TKE
3270 kmdz(k) = rhoz(k)*dfq(k) ! for T'2, q'2, and T'q'
3271 ENDDO
3272 rhoz(kte+1)=rhoz(kte)
3273 kqdz(kte+1)=rhoz(kte+1)*df3q(kte)
3274 kmdz(kte+1)=rhoz(kte+1)*dfq(kte)
3276 !stability criteria for mf
3277 DO k=kts+1,kte-1
3278 kqdz(k) = MAX(kqdz(k), 0.5* s_aw(k))
3279 kqdz(k) = MAX(kqdz(k), -0.5*(s_aw(k)-s_aw(k+1)))
3280 kmdz(k) = MAX(kmdz(k), 0.5* s_aw(k))
3281 kmdz(k) = MAX(kmdz(k), -0.5*(s_aw(k)-s_aw(k+1)))
3282 ENDDO
3283 !end conservation mods
3285 pdk1 = 2.0*ust**3*pmz/( vkz )
3286 phm = 2.0/ust *phh/( vkz )
3287 pdt1 = phm*flt**2
3288 pdq1 = phm*flq**2
3289 pdc1 = phm*flt*flq
3290 !
3291 ! ** pdk(1)+pdk(2) corresponds to pdk1. **
3292 pdk(kts) = pdk1 - pdk(kts+1)
3294 !! pdt(kts) = pdt1 -pdt(kts+1)
3295 !! pdq(kts) = pdq1 -pdq(kts+1)
3296 !! pdc(kts) = pdc1 -pdc(kts+1)
3297 pdt(kts) = pdt(kts+1)
3298 pdq(kts) = pdq(kts+1)
3299 pdc(kts) = pdc(kts+1)
3300 !
3301 ! ** Prediction of twice the turbulent kinetic energy **
3302 !! DO k = kts+1,kte-1
3303 DO k = kts,kte-1
3304 b1l = b1*0.5*( el(k+1)+el(k) )
3305 bp(k) = 2.*qkw(k) / b1l
3306 rp(k) = pdk(k+1) + pdk(k)
3307 END DO
3309 !! a(1)=0.
3310 !! b(1)=1.
3311 !! c(1)=-1.
3312 !! d(1)=0.
3314 ! Since df3q(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*df3q(k+1)+bp(k)*delt.
3315 DO k=kts,kte-1
3316 ! a(k-kts+1)=-dtz(k)*df3q(k)
3317 ! b(k-kts+1)=1.+dtz(k)*(df3q(k)+df3q(k+1))+bp(k)*delt
3318 ! c(k-kts+1)=-dtz(k)*df3q(k+1)
3319 ! d(k-kts+1)=rp(k)*delt + qke(k)
3320 ! WA 8/3/15 add EDMF contribution
3321 ! a(k)= - dtz(k)*df3q(k) + 0.5*dtz(k)*s_aw(k)*onoff
3322 ! b(k)=1. + dtz(k)*(df3q(k)+df3q(k+1)) &
3323 ! + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*onoff + bp(k)*delt
3324 ! c(k)= - dtz(k)*df3q(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff
3325 ! d(k)=rp(k)*delt + qke(k) + dtz(k)*(s_awqke(k)-s_awqke(k+1))*onoff
3326 !JOE 8/22/20 improve conservation
3327 a(k)= - dtz(k)*kqdz(k)*rhoinv(k) &
3328 & + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*onoff
3329 b(k)=1. + dtz(k)*(kqdz(k)+kqdz(k+1))*rhoinv(k) &
3330 & + 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*onoff &
3331 & + bp(k)*delt
3332 c(k)= - dtz(k)*kqdz(k+1)*rhoinv(k) &
3333 & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff
3334 d(k)=rp(k)*delt + qke(k) &
3335 & + dtz(k)*rhoinv(k)*(s_awqke(k)-s_awqke(k+1))*onoff
3336 ENDDO
3338 !! DO k=kts+1,kte-1
3339 !! a(k-kts+1)=-dtz(k)*df3q(k)
3340 !! b(k-kts+1)=1.+dtz(k)*(df3q(k)+df3q(k+1))
3341 !! c(k-kts+1)=-dtz(k)*df3q(k+1)
3342 !! d(k-kts+1)=rp(k)*delt + qke(k) - qke(k)*bp(k)*delt
3343 !! ENDDO
3345 !! "no flux at top"
3346 ! a(kte)=-1. !0.
3347 ! b(kte)=1.
3348 ! c(kte)=0.
3349 ! d(kte)=0.
3350 !! "prescribed value"
3351 a(kte)=0.
3352 b(kte)=1.
3353 c(kte)=0.
3354 d(kte)=qke(kte)
3356 ! CALL tridiag(kte,a,b,c,d)
3357 CALL tridiag2(kte,a,b,c,d,x)
3359 DO k=kts,kte
3360 ! qke(k)=max(d(k-kts+1), qkemin)
3361 qke(k)=max(x(k), qkemin)
3362 qke(k)=min(qke(k), 150.)
3363 ENDDO
3366 !! TKE budget (Puhales, 2020, WRF 4.2.1) << EOB
3367 IF (tke_budget .eq. 1) THEN
3368 !! TKE Vertical transport << EOBvt
3369 tke_up=0.5*qke
3370 dzinv=1./dz
3371 k=kts
3372 qWT1D(k)=dzinv(k)*( &
3373 & (kqdz(k+1)*(tke_up(k+1)-tke_up(k))-kqdz(k)*tke_up(k)) &
3374 & + 0.5*rhoinv(k)*(s_aw(k+1)*tke_up(k+1) &
3375 & + (s_aw(k+1)-s_aw(k))*tke_up(k) &
3376 & + (s_awqke(k)-s_awqke(k+1)))*onoff) !unstaggered
3377 DO k=kts+1,kte-1
3378 qWT1D(k)=dzinv(k)*( &
3379 & (kqdz(k+1)*(tke_up(k+1)-tke_up(k))-kqdz(k)*(tke_up(k)-tke_up(k-1))) &
3380 & + 0.5*rhoinv(k)*(s_aw(k+1)*tke_up(k+1) &
3381 & + (s_aw(k+1)-s_aw(k))*tke_up(k) &
3382 & - s_aw(k)*tke_up(k-1) &
3383 & + (s_awqke(k)-s_awqke(k+1)))*onoff) !unstaggered
3384 ENDDO
3385 k=kte
3386 qWT1D(k)=dzinv(k)*(-kqdz(k)*(tke_up(k)-tke_up(k-1)) &
3387 & + 0.5*rhoinv(k)*(-s_aw(k)*tke_up(k)-s_aw(k)*tke_up(k-1)+s_awqke(k))*onoff) !unstaggered
3388 !! >> EOBvt
3389 qDISS1D=bp*tke_up !! TKE dissipation rate !unstaggered
3390 END IF
3391 !! >> EOB
3393 IF ( closure > 2.5 ) THEN
3395 ! ** Prediction of the moisture variance **
3396 DO k = kts,kte-1
3397 b2l = b2*0.5*( el(k+1)+el(k) )
3398 bp(k) = 2.*qkw(k) / b2l
3399 rp(k) = pdq(k+1) + pdq(k)
3400 END DO
3402 !zero gradient for qsq at bottom and top
3403 !a(1)=0.
3404 !b(1)=1.
3405 !c(1)=-1.
3406 !d(1)=0.
3408 ! Since dfq(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*dfq(k+1)+bp(k)*delt.
3409 DO k=kts,kte-1
3410 a(k)= - dtz(k)*kmdz(k)*rhoinv(k)
3411 b(k)=1. + dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + bp(k)*delt
3412 c(k)= - dtz(k)*kmdz(k+1)*rhoinv(k)
3413 d(k)=rp(k)*delt + qsq(k)
3414 ENDDO
3416 a(kte)=-1. !0.
3417 b(kte)=1.
3418 c(kte)=0.
3419 d(kte)=0.
3421 ! CALL tridiag(kte,a,b,c,d)
3422 CALL tridiag2(kte,a,b,c,d,x)
3424 DO k=kts,kte
3425 !qsq(k)=d(k-kts+1)
3426 qsq(k)=MAX(x(k),1e-17)
3427 ENDDO
3428 ELSE
3429 !level 2.5 - use level 2 diagnostic
3430 DO k = kts,kte-1
3431 IF ( qkw(k) .LE. 0.0 ) THEN
3432 b2l = 0.0
3433 ELSE
3434 b2l = b2*0.25*( el(k+1)+el(k) )/qkw(k)
3435 END IF
3436 qsq(k) = b2l*( pdq(k+1)+pdq(k) )
3437 END DO
3438 qsq(kte)=qsq(kte-1)
3439 END IF
3440 !!!!!!!!!!!!!!!!!!!!!!end level 2.6
3442 IF ( closure .GE. 3.0 ) THEN
3443 !
3444 ! ** dfq for the scalar variance is 1.0*dfm. **
3445 !
3446 ! ** Prediction of the temperature variance **
3447 !! DO k = kts+1,kte-1
3448 DO k = kts,kte-1
3449 b2l = b2*0.5*( el(k+1)+el(k) )
3450 bp(k) = 2.*qkw(k) / b2l
3451 rp(k) = pdt(k+1) + pdt(k)
3452 END DO
3454 !zero gradient for tsq at bottom and top
3456 !! a(1)=0.
3457 !! b(1)=1.
3458 !! c(1)=-1.
3459 !! d(1)=0.
3461 ! Since dfq(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*dfq(k+1)+bp(k)*delt.
3462 DO k=kts,kte-1
3463 !a(k-kts+1)=-dtz(k)*dfq(k)
3464 !b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))+bp(k)*delt
3465 !c(k-kts+1)=-dtz(k)*dfq(k+1)
3466 !d(k-kts+1)=rp(k)*delt + tsq(k)
3467 !JOE 8/22/20 improve conservation
3468 a(k)= - dtz(k)*kmdz(k)*rhoinv(k)
3469 b(k)=1. + dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + bp(k)*delt
3470 c(k)= - dtz(k)*kmdz(k+1)*rhoinv(k)
3471 d(k)=rp(k)*delt + tsq(k)
3472 ENDDO
3474 !! DO k=kts+1,kte-1
3475 !! a(k-kts+1)=-dtz(k)*dfq(k)
3476 !! b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))
3477 !! c(k-kts+1)=-dtz(k)*dfq(k+1)
3478 !! d(k-kts+1)=rp(k)*delt + tsq(k) - tsq(k)*bp(k)*delt
3479 !! ENDDO
3481 a(kte)=-1. !0.
3482 b(kte)=1.
3483 c(kte)=0.
3484 d(kte)=0.
3486 ! CALL tridiag(kte,a,b,c,d)
3487 CALL tridiag2(kte,a,b,c,d,x)
3489 DO k=kts,kte
3490 ! tsq(k)=d(k-kts+1)
3491 tsq(k)=x(k)
3492 ENDDO
3494 ! ** Prediction of the temperature-moisture covariance **
3495 !! DO k = kts+1,kte-1
3496 DO k = kts,kte-1
3497 b2l = b2*0.5*( el(k+1)+el(k) )
3498 bp(k) = 2.*qkw(k) / b2l
3499 rp(k) = pdc(k+1) + pdc(k)
3500 END DO
3502 !zero gradient for tqcov at bottom and top
3504 !! a(1)=0.
3505 !! b(1)=1.
3506 !! c(1)=-1.
3507 !! d(1)=0.
3509 ! Since dfq(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*dfq(k+1)+bp(k)*delt.
3510 DO k=kts,kte-1
3511 !a(k-kts+1)=-dtz(k)*dfq(k)
3512 !b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))+bp(k)*delt
3513 !c(k-kts+1)=-dtz(k)*dfq(k+1)
3514 !d(k-kts+1)=rp(k)*delt + cov(k)
3515 !JOE 8/22/20 improve conservation
3516 a(k)= - dtz(k)*kmdz(k)*rhoinv(k)
3517 b(k)=1. + dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + bp(k)*delt
3518 c(k)= - dtz(k)*kmdz(k+1)*rhoinv(k)
3519 d(k)=rp(k)*delt + cov(k)
3520 ENDDO
3522 !! DO k=kts+1,kte-1
3523 !! a(k-kts+1)=-dtz(k)*dfq(k)
3524 !! b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))
3525 !! c(k-kts+1)=-dtz(k)*dfq(k+1)
3526 !! d(k-kts+1)=rp(k)*delt + cov(k) - cov(k)*bp(k)*delt
3527 !! ENDDO
3529 a(kte)=-1. !0.
3530 b(kte)=1.
3531 c(kte)=0.
3532 d(kte)=0.
3534 ! CALL tridiag(kte,a,b,c,d)
3535 CALL tridiag2(kte,a,b,c,d,x)
3537 DO k=kts,kte
3538 ! cov(k)=d(k-kts+1)
3539 cov(k)=x(k)
3540 ENDDO
3542 ELSE
3544 !Not level 3 - default to level 2 diagnostic
3545 DO k = kts,kte-1
3546 IF ( qkw(k) .LE. 0.0 ) THEN
3547 b2l = 0.0
3548 ELSE
3549 b2l = b2*0.25*( el(k+1)+el(k) )/qkw(k)
3550 END IF
3551 !
3552 tsq(k) = b2l*( pdt(k+1)+pdt(k) )
3553 cov(k) = b2l*( pdc(k+1)+pdc(k) )
3554 END DO
3556 tsq(kte)=tsq(kte-1)
3557 cov(kte)=cov(kte-1)
3559 END IF
3561 #ifdef HARDCODE_VERTICAL
3562 # undef kts
3563 # undef kte
3564 #endif
3566 END SUBROUTINE mym_predict
3568 ! ==================================================================
3569 ! SUBROUTINE mym_condensation:
3570 !
3571 ! Input variables: see subroutine mym_initialize and turbulence
3572 ! exner(nz) : Perturbation of the Exner function (J/kg K)
3573 ! defined on the walls of the grid boxes
3574 ! This is usually computed by integrating
3575 ! d(pi)/dz = h*g*tv/tref**2
3576 ! from the upper boundary, where tv is the
3577 ! virtual potential temperature minus tref.
3578 !
3579 ! Output variables: see subroutine mym_initialize
3580 ! cld(nx,nz,ny) : Cloud fraction
3581 !
3582 ! Work arrays/variables:
3583 ! qmq : Q_w-Q_{sl}, where Q_{sl} is the saturation
3584 ! specific humidity at T=Tl
3585 ! alp(nx,nz,ny) : Functions in the condensation process
3586 ! bet(nx,nz,ny) : ditto
3587 ! sgm(nx,nz,ny) : Combined standard deviation sigma_s
3588 ! multiplied by 2/alp
3589 !
3590 ! # qmq, alp, bet and sgm are allowed to share storage units with
3591 ! any four of other work arrays for saving memory.
3592 !
3593 ! # Results are sensitive particularly to values of cp and r_d.
3594 ! Set these values to those adopted by you.
3595 !
3596 !-------------------------------------------------------------------
3597 !>\ingroup gsd_mynn_edmf
3598 !! This subroutine calculates the nonconvective component of the
3599 !! subgrid cloud fraction and mixing ratio as well as the functions used to
3600 !! calculate the buoyancy flux. Different cloud PDFs can be selected by
3601 !! use of the namelist parameter \p bl_mynn_cloudpdf .
3602 SUBROUTINE mym_condensation (kts,kte, &
3603 & dx, dz, zw, xland, &
3604 & thl, qw, qv, qc, qi, qs, &
3605 & p,exner, &
3606 & tsq, qsq, cov, &
3607 & Sh, el, bl_mynn_cloudpdf, &
3608 & qc_bl1D, qi_bl1D, &
3609 & cldfra_bl1D, &
3610 & PBLH1,HFX1, &
3611 & Vt, Vq, th, sgm, rmo, &
3612 & spp_pbl,rstoch_col )
3614 !-------------------------------------------------------------------
3616 integer, intent(in) :: kts,kte, bl_mynn_cloudpdf
3618 #ifdef HARDCODE_VERTICAL
3619 # define kts 1
3620 # define kte HARDCODE_VERTICAL
3621 #endif
3623 real(kind_phys), intent(in) :: HFX1,rmo,xland
3624 real(kind_phys), intent(in) :: dx,pblh1
3625 real(kind_phys), dimension(kts:kte), intent(in) :: dz
3626 real(kind_phys), dimension(kts:kte+1), intent(in) :: zw
3627 real(kind_phys), dimension(kts:kte), intent(in) :: p,exner,thl,qw, &
3628 &qv,qc,qi,qs,tsq,qsq,cov,th
3630 real(kind_phys), dimension(kts:kte), intent(inout) :: vt,vq,sgm
3632 real(kind_phys), dimension(kts:kte) :: alp,a,bet,b,ql,q1,RH
3633 real(kind_phys), dimension(kts:kte), intent(out) :: qc_bl1D,qi_bl1D, &
3634 &cldfra_bl1D
3635 DOUBLE PRECISION :: t3sq, r3sq, c3sq
3637 real(kind_phys):: qsl,esat,qsat,dqsl,cld0,q1k,qlk,eq1,qll, &
3638 &q2p,pt,rac,qt,t,xl,rsl,cpm,Fng,qww,alpha,beta,bb, &
3639 &ls,wt,wt2,qpct,cld_factor,fac_damp,liq_frac,ql_ice,ql_water, &
3640 &qmq,qsat_tk,q1_rh,rh_hack,dzm1,zsl,maxqc
3641 real(kind_phys), parameter :: qpct_sfc=0.025
3642 real(kind_phys), parameter :: qpct_pbl=0.030
3643 real(kind_phys), parameter :: qpct_trp=0.040
3644 real(kind_phys), parameter :: rhcrit =0.83 !for cloudpdf = 2
3645 real(kind_phys), parameter :: rhmax =1.02 !for cloudpdf = 2
3646 integer :: i,j,k
3648 real(kind_phys):: erf
3650 !VARIABLES FOR ALTERNATIVE SIGMA
3651 real:: dth,dtl,dqw,dzk,els
3652 real(kind_phys), dimension(kts:kte), intent(in) :: Sh,el
3654 !variables for SGS BL clouds
3655 real(kind_phys) :: zagl,damp,PBLH2
3656 real(kind_phys) :: cfmax
3658 !JAYMES: variables for tropopause-height estimation
3659 real(kind_phys) :: theta1, theta2, ht1, ht2
3660 integer :: k_tropo
3662 ! Stochastic
3663 integer, intent(in) :: spp_pbl
3664 real(kind_phys), dimension(kts:kte) :: rstoch_col
3665 real(kind_phys) :: qw_pert
3667 ! First, obtain an estimate for the tropopause height (k), using the method employed in the
3668 ! Thompson subgrid-cloud scheme. This height will be a consideration later when determining
3669 ! the "final" subgrid-cloud properties.
3670 ! JAYMES: added 3 Nov 2016, adapted from G. Thompson
3672 DO k = kte-3, kts, -1
3673 theta1 = th(k)
3674 theta2 = th(k+2)
3675 ht1 = 44307.692 * (1.0 - (p(k)/101325.)**0.190)
3676 ht2 = 44307.692 * (1.0 - (p(k+2)/101325.)**0.190)
3677 if ( (((theta2-theta1)/(ht2-ht1)) .lt. 10./1500. ) .AND. &
3678 & (ht1.lt.19000.) .and. (ht1.gt.4000.) ) then
3679 goto 86
3680 endif
3681 ENDDO
3682 86 continue
3683 k_tropo = MAX(kts+2, k+2)
3685 zagl = 0.
3687 SELECT CASE(bl_mynn_cloudpdf)
3689 CASE (0) ! ORIGINAL MYNN PARTIAL-CONDENSATION SCHEME
3691 DO k = kts,kte-1
3692 t = th(k)*exner(k)
3694 !x if ( ct .gt. 0.0 ) then
3695 ! a = 17.27
3696 ! b = 237.3
3697 !x else
3698 !x a = 21.87
3699 !x b = 265.5
3700 !x end if
3701 !
3702 ! ** 3.8 = 0.622*6.11 (hPa) **
3704 !SATURATED VAPOR PRESSURE
3705 esat = esat_blend(t)
3706 !SATURATED SPECIFIC HUMIDITY
3707 !qsl=ep_2*esat/(p(k)-ep_3*esat)
3708 qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat))
3709 !dqw/dT: Clausius-Clapeyron
3710 dqsl = qsl*ep_2*xlv/( r_d*t**2 )
3712 alp(k) = 1.0/( 1.0+dqsl*xlvcp )
3713 bet(k) = dqsl*exner(k)
3715 !Sommeria and Deardorff (1977) scheme, as implemented
3716 !in Nakanishi and Niino (2009), Appendix B
3717 t3sq = MAX( tsq(k), 0.0 )
3718 r3sq = MAX( qsq(k), 0.0 )
3719 c3sq = cov(k)
3720 c3sq = SIGN( MIN( ABS(c3sq), SQRT(t3sq*r3sq) ), c3sq )
3721 r3sq = r3sq +bet(k)**2*t3sq -2.0*bet(k)*c3sq
3722 !DEFICIT/EXCESS WATER CONTENT
3723 qmq = qw(k) -qsl
3724 !ORIGINAL STANDARD DEVIATION
3725 sgm(k) = SQRT( MAX( r3sq, 1.0d-10 ))
3726 !NORMALIZED DEPARTURE FROM SATURATION
3727 q1(k) = qmq / sgm(k)
3728 !CLOUD FRACTION. rr2 = 1/SQRT(2) = 0.707
3729 cldfra_bl1D(k) = 0.5*( 1.0+erf( q1(k)*rr2 ) )
3731 q1k = q1(k)
3732 eq1 = rrp*EXP( -0.5*q1k*q1k )
3733 qll = MAX( cldfra_bl1D(k)*q1k + eq1, 0.0 )
3734 !ESTIMATED LIQUID WATER CONTENT (UNNORMALIZED)
3735 ql(k) = alp(k)*sgm(k)*qll
3736 !LIMIT SPECIES TO TEMPERATURE RANGES
3737 liq_frac = min(1.0, max(0.0,(t-240.0)/29.0))
3738 qc_bl1D(k) = liq_frac*ql(k)
3739 qi_bl1D(k) = (1.0 - liq_frac)*ql(k)
3741 !Now estimate the buoyancy flux functions
3742 q2p = xlvcp/exner(k)
3743 pt = thl(k) +q2p*ql(k) ! potential temp
3745 !qt is a THETA-V CONVERSION FOR TOTAL WATER (i.e., THETA-V = qt*THETA)
3746 qt = 1.0 +p608*qw(k) -(1.+p608)*(qc_bl1D(k)+qi_bl1D(k))*cldfra_bl1D(k)
3747 rac = alp(k)*( cldfra_bl1D(K)-qll*eq1 )*( q2p*qt-(1.+p608)*pt )
3749 !BUOYANCY FACTORS: wherever vt and vq are used, there is a
3750 !"+1" and "+tv0", respectively, so these are subtracted out here.
3751 !vt is unitless and vq has units of K.
3752 vt(k) = qt-1.0 -rac*bet(k)
3753 vq(k) = p608*pt-tv0 +rac
3755 END DO
3757 CASE (1, -1) !ALTERNATIVE FORM (Nakanishi & Niino 2004 BLM, eq. B6, and
3758 !Kuwano-Yoshida et al. 2010 QJRMS, eq. 7):
3759 DO k = kts,kte-1
3760 t = th(k)*exner(k)
3761 !SATURATED VAPOR PRESSURE
3762 esat = esat_blend(t)
3763 !SATURATED SPECIFIC HUMIDITY
3764 !qsl=ep_2*esat/(p(k)-ep_3*esat)
3765 qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat))
3766 !dqw/dT: Clausius-Clapeyron
3767 dqsl = qsl*ep_2*xlv/( r_d*t**2 )
3769 alp(k) = 1.0/( 1.0+dqsl*xlvcp )
3770 bet(k) = dqsl*exner(k)
3772 if (k .eq. kts) then
3773 dzk = 0.5*dz(k)
3774 else
3775 dzk = dz(k)
3776 end if
3777 dth = 0.5*(thl(k+1)+thl(k)) - 0.5*(thl(k)+thl(MAX(k-1,kts)))
3778 dqw = 0.5*(qw(k+1) + qw(k)) - 0.5*(qw(k) + qw(MAX(k-1,kts)))
3779 sgm(k) = SQRT( MAX( (alp(k)**2 * MAX(el(k)**2,0.1) * &
3780 b2 * MAX(Sh(k),0.03))/4. * &
3781 (dqw/dzk - bet(k)*(dth/dzk ))**2 , 1.0e-10) )
3782 qmq = qw(k) -qsl
3783 q1(k) = qmq / sgm(k)
3784 cldfra_bl1D(K) = 0.5*( 1.0+erf( q1(k)*rr2 ) )
3786 !now compute estimated lwc for PBL scheme's use
3787 !qll IS THE NORMALIZED LIQUID WATER CONTENT (Sommeria and
3788 !Deardorff (1977, eq 29a). rrp = 1/(sqrt(2*pi)) = 0.3989
3789 q1k = q1(k)
3790 eq1 = rrp*EXP( -0.5*q1k*q1k )
3791 qll = MAX( cldfra_bl1D(K)*q1k + eq1, 0.0 )
3792 !ESTIMATED LIQUID WATER CONTENT (UNNORMALIZED)
3793 ql (k) = alp(k)*sgm(k)*qll
3794 liq_frac = min(1.0, max(0.0,(t-240.0)/29.0))
3795 qc_bl1D(k) = liq_frac*ql(k)
3796 qi_bl1D(k) = (1.0 - liq_frac)*ql(k)
3798 !Now estimate the buoyancy flux functions
3799 q2p = xlvcp/exner(k)
3800 pt = thl(k) +q2p*ql(k) ! potential temp
3802 !qt is a THETA-V CONVERSION FOR TOTAL WATER (i.e., THETA-V = qt*THETA)
3803 qt = 1.0 +p608*qw(k) -(1.+p608)*(qc_bl1D(k)+qi_bl1D(k))*cldfra_bl1D(k)
3804 rac = alp(k)*( cldfra_bl1D(K)-qll*eq1 )*( q2p*qt-(1.+p608)*pt )
3806 !BUOYANCY FACTORS: wherever vt and vq are used, there is a
3807 !"+1" and "+tv0", respectively, so these are subtracted out here.
3808 !vt is unitless and vq has units of K.
3809 vt(k) = qt-1.0 -rac*bet(k)
3810 vq(k) = p608*pt-tv0 +rac
3812 END DO
3814 CASE (2, -2)
3816 !Diagnostic statistical scheme of Chaboureau and Bechtold (2002), JAS
3817 !but with use of higher-order moments to estimate sigma
3818 pblh2=MAX(10._kind_phys,pblh1)
3819 zagl = 0.
3820 dzm1 = 0.
3821 DO k = kts,kte-1
3822 zagl = zagl + 0.5*(dz(k) + dzm1)
3823 dzm1 = dz(k)
3825 t = th(k)*exner(k)
3826 xl = xl_blend(t) ! obtain latent heat
3827 qsat_tk= qsat_blend(t, p(k)) ! saturation water vapor mixing ratio at tk and p
3828 rh(k) = MAX(MIN(rhmax, qw(k)/MAX(1.E-10,qsat_tk)),0.001_kind_phys)
3830 !dqw/dT: Clausius-Clapeyron
3831 dqsl = qsat_tk*ep_2*xlv/( r_d*t**2 )
3832 alp(k) = 1.0/( 1.0+dqsl*xlvcp )
3833 bet(k) = dqsl*exner(k)
3835 rsl = xl*qsat_tk / (r_v*t**2) ! slope of C-C curve at t (=abs temperature)
3836 ! CB02, Eqn. 4
3837 cpm = cp + qw(k)*cpv ! CB02, sec. 2, para. 1
3838 a(k) = 1./(1. + xl*rsl/cpm) ! CB02 variable "a"
3839 b(k) = a(k)*rsl ! CB02 variable "b"
3841 !SPP
3842 qw_pert= qw(k) + qw(k)*0.5*rstoch_col(k)*real(spp_pbl)
3844 !This form of qmq (the numerator of Q1) no longer uses the a(k) factor
3845 qmq = qw_pert - qsat_tk ! saturation deficit/excess;
3847 !Use the form of Eq. (6) in Chaboureau and Bechtold (2002)
3848 !except neglect all but the first term for sig_r
3849 r3sq = max( qsq(k), 0.0 )
3850 !Calculate sigma using higher-order moments:
3851 sgm(k) = SQRT( r3sq )
3852 !Set constraints on sigma relative to saturation water vapor
3853 sgm(k) = min( sgm(k), qsat_tk*0.666 )
3854 !sgm(k) = max( sgm(k), qsat_tk*0.035 )
3856 !introduce vertical grid spacing dependence on min sgm
3857 wt = max(500. - max(dz(k)-100.,0.0), 0.0_kind_phys)/500. !=1 for dz < 100 m, =0 for dz > 600 m
3858 sgm(k) = sgm(k) + sgm(k)*0.2*(1.0-wt) !inflate sgm for coarse dz
3860 !allow min sgm to vary with dz and z.
3861 qpct = qpct_pbl*wt + qpct_trp*(1.0-wt)
3862 qpct = min(qpct, max(qpct_sfc, qpct_pbl*zagl/500.) )
3863 sgm(k) = max( sgm(k), qsat_tk*qpct )
3865 q1(k) = qmq / sgm(k) ! Q1, the normalized saturation
3867 !Add condition for falling/settling into low-RH layers, so at least
3868 !some cloud fraction is applied for all qc, qs, and qi.
3869 rh_hack= rh(k)
3870 wt2 = min(max( zagl - pblh2, 0.0 )/300., 1.0)
3871 !ensure adequate RH & q1 when qi is at least 1e-9 (above the PBLH)
3872 if ((qi(k)+qs(k))>1.e-9 .and. (zagl .gt. pblh2)) then
3873 rh_hack =min(rhmax, rhcrit + wt2*0.045*(9.0 + log10(qi(k)+qs(k))))
3874 rh(k) =max(rh(k), rh_hack)
3875 !add rh-based q1
3876 q1_rh =-3. + 3.*(rh(k)-rhcrit)/(1.-rhcrit)
3877 q1(k) =max(q1_rh, q1(k) )
3878 endif
3879 !ensure adequate rh & q1 when qc is at least 1e-6 (above the PBLH)
3880 if (qc(k)>1.e-6 .and. (zagl .gt. pblh2)) then
3881 rh_hack =min(rhmax, rhcrit + wt2*0.08*(6.0 + log10(qc(k))))
3882 rh(k) =max(rh(k), rh_hack)
3883 !add rh-based q1
3884 q1_rh =-3. + 3.*(rh(k)-rhcrit)/(1.-rhcrit)
3885 q1(k) =max(q1_rh, q1(k) )
3886 endif
3888 q1k = q1(k) ! backup Q1 for later modification
3890 ! Specify cloud fraction
3891 !Original C-B cloud fraction, allows cloud fractions out to q1 = -3.5
3892 !cldfra_bl1D(K) = max(0., min(1., 0.5+0.36*atan(1.55*q1(k)))) ! Eq. 7 in CB02
3893 !Waynes LES fit - over-diffuse, when limits removed from vt & vq & fng
3894 !cldfra_bl1D(K) = max(0., min(1., 0.5+0.36*atan(1.2*(q1(k)+0.4))))
3895 !Best compromise: Improves marine stratus without adding much cold bias.
3896 cldfra_bl1D(k) = max(0., min(1., 0.5+0.36*atan(1.8*(q1(k)+0.2))))
3898 ! Specify hydrometeors
3899 ! JAYMES- this option added 8 May 2015
3900 ! The cloud water formulations are taken from CB02, Eq. 8.
3901 maxqc = max(qw(k) - qsat_tk, 0.0)
3902 if (q1k < 0.) then !unsaturated
3903 ql_water = sgm(k)*exp(1.2*q1k-1.)
3904 ql_ice = sgm(k)*exp(1.2*q1k-1.)
3905 elseif (q1k > 2.) then !supersaturated
3906 ql_water = min(sgm(k)*q1k, maxqc)
3907 ql_ice = sgm(k)*q1k
3908 else !slightly saturated (0 > q1 < 2)
3909 ql_water = min(sgm(k)*(exp(-1.) + 0.66*q1k + 0.086*q1k**2), maxqc)
3910 ql_ice = sgm(k)*(exp(-1.) + 0.66*q1k + 0.086*q1k**2)
3911 endif
3913 !In saturated grid cells, use average of SGS and resolved values
3914 !if ( qc(k) > 1.e-6 ) ql_water = 0.5 * ( ql_water + qc(k) )
3915 !ql_ice is actually the total frozen condensate (snow+ice),
3916 !if ( (qi(k)+qs(k)) > 1.e-9 ) ql_ice = 0.5 * ( ql_ice + (qi(k)+qs(k)) )
3918 if (cldfra_bl1D(k) < 0.001) then
3919 ql_ice = 0.0
3920 ql_water = 0.0
3921 cldfra_bl1D(k) = 0.0
3922 endif
3924 liq_frac = MIN(1.0, MAX(0.0, (t-tice)/(tliq-tice)))
3925 qc_bl1D(k) = liq_frac*ql_water ! apply liq_frac to ql_water and ql_ice
3926 qi_bl1D(k) = (1.0-liq_frac)*ql_ice
3928 !Above tropopause: eliminate subgrid clouds from CB scheme. Note that this was
3929 !"k_tropo - 1" as of 20 Feb 2023. Changed to allow more high-level clouds.
3930 if (k .ge. k_tropo) then
3931 cldfra_bl1D(K) = 0.
3932 qc_bl1D(k) = 0.
3933 qi_bl1D(k) = 0.
3934 endif
3936 !Buoyancy-flux-related calculations follow...
3937 !limiting Q1 to avoid too much diffusion in cloud layers
3938 !q1k=max(Q1(k),-2.0)
3939 if ((xland-1.5).GE.0) then ! water
3940 q1k=max(Q1(k),-2.5)
3941 else ! land
3942 q1k=max(Q1(k),-2.0)
3943 endif
3944 ! "Fng" represents the non-Gaussian transport factor
3945 ! (non-dimensional) from Bechtold et al. 1995
3946 ! (hereafter BCMT95), section 3(c). Their suggested
3947 ! forms for Fng (from their Eq. 20) are:
3948 !IF (q1k < -2.) THEN
3949 ! Fng = 2.-q1k
3950 !ELSE IF (q1k > 0.) THEN
3951 ! Fng = 1.
3952 !ELSE
3953 ! Fng = 1.-1.5*q1k
3954 !ENDIF
3955 ! Use the form of "Fng" from Bechtold and Siebesma (1998, JAS)
3956 if (q1k .ge. 1.0) then
3957 Fng = 1.0
3958 elseif (q1k .ge. -1.7 .and. q1k .lt. 1.0) then
3959 Fng = exp(-0.4*(q1k-1.0))
3960 elseif (q1k .ge. -2.5 .and. q1k .lt. -1.7) then
3961 Fng = 3.0 + exp(-3.8*(q1k+1.7))
3962 else
3963 Fng = min(23.9 + exp(-1.6*(q1k+2.5)), 60._kind_phys)
3964 endif
3966 cfmax = min(cldfra_bl1D(k), 0.6_kind_phys)
3967 !Further limit the cf going into vt & vq near the surface
3968 zsl = min(max(25., 0.1*pblh2), 100.)
3969 wt = min(zagl/zsl, 1.0) !=0 at z=0 m, =1 above ekman layer
3970 cfmax = cfmax*wt
3972 bb = b(k)*t/th(k) ! bb is "b" in BCMT95. Their "b" differs from
3973 ! "b" in CB02 (i.e., b(k) above) by a factor
3974 ! of T/theta. Strictly, b(k) above is formulated in
3975 ! terms of sat. mixing ratio, but bb in BCMT95 is
3976 ! cast in terms of sat. specific humidity. The
3977 ! conversion is neglected here.
3978 qww = 1.+0.61*qw(k)
3979 alpha = 0.61*th(k)
3980 beta = (th(k)/t)*(xl/cp) - 1.61*th(k)
3981 vt(k) = qww - cfmax*beta*bb*Fng - 1.
3982 vq(k) = alpha + cfmax*beta*a(k)*Fng - tv0
3983 ! vt and vq correspond to beta-theta and beta-q, respectively,
3984 ! in NN09, Eq. B8. They also correspond to the bracketed
3985 ! expressions in BCMT95, Eq. 15, since (s*ql/sigma^2) = cldfra*Fng
3986 ! The "-1" and "-tv0" terms are included for consistency with
3987 ! the legacy vt and vq formulations (above).
3989 ! dampen amplification factor where need be
3990 fac_damp = min(zagl * 0.0025, 1.0)
3991 !cld_factor = 1.0 + fac_damp*MAX(0.0, ( RH(k) - 0.75 ) / 0.26 )**1.9 !HRRRv4
3992 !cld_factor = 1.0 + fac_damp*min((max(0.0, ( RH(k) - 0.92 )) / 0.25 )**2, 0.3)
3993 cld_factor = 1.0 + fac_damp*min((max(0.0, ( RH(k) - 0.92 )) / 0.145)**2, 0.37)
3994 cldfra_bl1D(K) = min( 1., cld_factor*cldfra_bl1D(K) )
3995 enddo
3997 END SELECT !end cloudPDF option
3999 !For testing purposes only, option for isolating on the mass-flux clouds.
4000 IF (bl_mynn_cloudpdf .LT. 0) THEN
4001 DO k = kts,kte-1
4002 cldfra_bl1D(k) = 0.0
4003 qc_bl1D(k) = 0.0
4004 qi_bl1D(k) = 0.0
4005 END DO
4006 ENDIF
4007 !
4008 ql(kte) = ql(kte-1)
4009 vt(kte) = vt(kte-1)
4010 vq(kte) = vq(kte-1)
4011 qc_bl1D(kte)=0.
4012 qi_bl1D(kte)=0.
4013 cldfra_bl1D(kte)=0.
4014 RETURN
4016 #ifdef HARDCODE_VERTICAL
4017 # undef kts
4018 # undef kte
4019 #endif
4021 END SUBROUTINE mym_condensation
4023 ! ==================================================================
4024 !>\ingroup gsd_mynn_edmf
4025 !! This subroutine solves for tendencies of U, V, \f$\theta\f$, qv,
4026 !! qc, and qi
4027 SUBROUTINE mynn_tendencies(kts,kte,i, &
4028 &delt,dz,rho, &
4029 &u,v,th,tk,qv,qc,qi,qs,qnc,qni, &
4030 &psfc,p,exner, &
4031 &thl,sqv,sqc,sqi,sqs,sqw, &
4032 &qnwfa,qnifa,qnbca,ozone, &
4033 &ust,flt,flq,flqv,flqc,wspd, &
4034 &uoce,voce, &
4035 &tsq,qsq,cov, &
4036 &tcd,qcd, &
4037 &dfm,dfh,dfq, &
4038 &Du,Dv,Dth,Dqv,Dqc,Dqi,Dqs,Dqnc,Dqni, &
4039 &Dqnwfa,Dqnifa,Dqnbca,Dozone, &
4040 &diss_heat, &
4041 &s_aw,s_awthl,s_awqt,s_awqv,s_awqc, &
4042 &s_awu,s_awv, &
4043 &s_awqnc,s_awqni, &
4044 &s_awqnwfa,s_awqnifa,s_awqnbca, &
4045 &sd_aw,sd_awthl,sd_awqt,sd_awqv, &
4046 &sd_awqc,sd_awu,sd_awv, &
4047 &sub_thl,sub_sqv, &
4048 &sub_u,sub_v, &
4049 &det_thl,det_sqv,det_sqc, &
4050 &det_u,det_v, &
4051 &FLAG_QC,FLAG_QI,FLAG_QNC,FLAG_QNI, &
4052 &FLAG_QS, &
4053 &FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA, &
4054 &FLAG_OZONE, &
4055 &cldfra_bl1d, &
4056 &bl_mynn_cloudmix, &
4057 &bl_mynn_mixqt, &
4058 &bl_mynn_edmf, &
4059 &bl_mynn_edmf_mom, &
4060 &bl_mynn_mixscalars )
4062 !-------------------------------------------------------------------
4063 integer, intent(in) :: kts,kte,i
4065 #ifdef HARDCODE_VERTICAL
4066 # define kts 1
4067 # define kte HARDCODE_VERTICAL
4068 #endif
4070 integer, intent(in) :: bl_mynn_cloudmix,bl_mynn_mixqt, &
4071 bl_mynn_edmf,bl_mynn_edmf_mom, &
4072 bl_mynn_mixscalars
4073 logical, intent(in) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QS, &
4074 &FLAG_QNC,FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA,FLAG_OZONE
4076 ! thl - liquid water potential temperature
4077 ! qw - total water
4078 ! dfm,dfh,dfq - diffusivities i.e., dfh(k) = elq*sh(k) / dzk
4079 ! flt - surface flux of thl
4080 ! flq - surface flux of qw
4082 ! mass-flux plumes
4083 real(kind_phys), dimension(kts:kte+1), intent(in) :: s_aw, &
4084 &s_awthl,s_awqt,s_awqnc,s_awqni,s_awqv,s_awqc,s_awu,s_awv, &
4085 &s_awqnwfa,s_awqnifa,s_awqnbca, &
4086 &sd_aw,sd_awthl,sd_awqt,sd_awqv,sd_awqc,sd_awu,sd_awv
4087 ! tendencies from mass-flux environmental subsidence and detrainment
4088 real(kind_phys), dimension(kts:kte), intent(in) :: sub_thl,sub_sqv, &
4089 &sub_u,sub_v,det_thl,det_sqv,det_sqc,det_u,det_v
4090 real(kind_phys), dimension(kts:kte), intent(in) :: u,v,th,tk,qv,qc,qi,&
4091 &qs,qni,qnc,rho,p,exner,dfq,dz,tsq,qsq,cov,tcd,qcd, &
4092 &cldfra_bl1d,diss_heat
4093 real(kind_phys), dimension(kts:kte), intent(inout) :: thl,sqw,sqv,sqc,&
4094 &sqi,sqs,qnwfa,qnifa,qnbca,ozone,dfm,dfh
4095 real(kind_phys), dimension(kts:kte), intent(inout) :: du,dv,dth,dqv, &
4096 &dqc,dqi,dqs,dqni,dqnc,dqnwfa,dqnifa,dqnbca,dozone
4097 real(kind_phys), intent(in) :: flt,flq,flqv,flqc,uoce,voce
4098 real(kind_phys), intent(in) :: ust,delt,psfc,wspd
4099 !debugging
4100 real(kind_phys):: wsp,wsp2,tk2,th2
4101 logical :: problem
4102 integer :: kproblem
4104 ! real(kind_phys), intent(in) :: gradu_top,gradv_top,gradth_top,gradqv_top
4106 !local vars
4108 real(kind_phys), dimension(kts:kte) :: dtz,dfhc,dfmc,delp
4109 real(kind_phys), dimension(kts:kte) :: sqv2,sqc2,sqi2,sqs2,sqw2, &
4110 &qni2,qnc2,qnwfa2,qnifa2,qnbca2,ozone2
4111 real(kind_phys), dimension(kts:kte) :: zfac,plumeKh,rhoinv
4112 real(kind_phys), dimension(kts:kte) :: a,b,c,d,x
4113 real(kind_phys), dimension(kts:kte+1) :: rhoz, & !rho on model interface
4114 &khdz,kmdz
4115 real(kind_phys):: rhs,gfluxm,gfluxp,dztop,maxdfh,mindfh,maxcf,maxKh,zw
4116 real(kind_phys):: t,esat,qsl,onoff,kh,km,dzk,rhosfc
4117 real(kind_phys):: ustdrag,ustdiff,qvflux
4118 real(kind_phys):: th_new,portion_qc,portion_qi,condensate,qsat
4119 integer :: k,kk
4121 !Activate nonlocal mixing from the mass-flux scheme for
4122 !number concentrations and aerosols (0.0 = no; 1.0 = yes)
4123 real(kind_phys), parameter :: nonloc = 1.0
4125 dztop=.5*(dz(kte)+dz(kte-1))
4127 ! REGULATE THE MOMENTUM MIXING FROM THE MASS-FLUX SCHEME (on or off)
4128 ! Note that s_awu and s_awv already come in as 0.0 if bl_mynn_edmf_mom == 0, so
4129 ! we only need to zero-out the MF term
4130 IF (bl_mynn_edmf_mom == 0) THEN
4131 onoff=0.0
4132 ELSE
4133 onoff=1.0
4134 ENDIF
4136 !Prepare "constants" for diffusion equation.
4137 !khdz = rho*Kh/dz = rho*dfh
4138 rhosfc = psfc/(R_d*(tk(kts)+p608*qv(kts)))
4139 dtz(kts) =delt/dz(kts)
4140 rhoz(kts) =rho(kts)
4141 rhoinv(kts)=1./rho(kts)
4142 khdz(kts) =rhoz(kts)*dfh(kts)
4143 kmdz(kts) =rhoz(kts)*dfm(kts)
4144 delp(kts) = psfc - (p(kts+1)*dz(kts) + p(kts)*dz(kts+1))/(dz(kts)+dz(kts+1))
4145 DO k=kts+1,kte
4146 dtz(k) =delt/dz(k)
4147 rhoz(k) =(rho(k)*dz(k-1) + rho(k-1)*dz(k))/(dz(k-1)+dz(k))
4148 rhoz(k) = MAX(rhoz(k),1E-4)
4149 rhoinv(k)=1./MAX(rho(k),1E-4)
4150 dzk = 0.5 *( dz(k)+dz(k-1) )
4151 khdz(k) = rhoz(k)*dfh(k)
4152 kmdz(k) = rhoz(k)*dfm(k)
4153 ENDDO
4154 DO k=kts+1,kte-1
4155 delp(k) = (p(k)*dz(k-1) + p(k-1)*dz(k))/(dz(k)+dz(k-1)) - &
4156 (p(k+1)*dz(k) + p(k)*dz(k+1))/(dz(k)+dz(k+1))
4157 ENDDO
4158 delp(kte) =delp(kte-1)
4159 rhoz(kte+1)=rhoz(kte)
4160 khdz(kte+1)=rhoz(kte+1)*dfh(kte)
4161 kmdz(kte+1)=rhoz(kte+1)*dfm(kte)
4163 !stability criteria for mf
4164 DO k=kts+1,kte-1
4165 khdz(k) = MAX(khdz(k), 0.5*s_aw(k))
4166 khdz(k) = MAX(khdz(k), -0.5*(s_aw(k)-s_aw(k+1)))
4167 kmdz(k) = MAX(kmdz(k), 0.5*s_aw(k))
4168 kmdz(k) = MAX(kmdz(k), -0.5*(s_aw(k)-s_aw(k+1)))
4169 ENDDO
4171 ustdrag = MIN(ust*ust,0.99)/wspd ! limit at ~ 20 m/s
4172 ustdiff = MIN(ust*ust,0.01)/wspd ! limit at ~ 2 m/s
4173 dth(kts:kte) = 0.0 ! must initialize for moisture_check routine
4175 !!============================================
4176 !! u
4177 !!============================================
4179 k=kts
4181 !rho-weighted (drag in b-vector):
4182 a(k)= -dtz(k)*kmdz(k)*rhoinv(k)
4183 b(k)=1.+dtz(k)*(kmdz(k+1)+rhosfc*ust**2/wspd)*rhoinv(k) &
4184 & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff &
4185 & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff
4186 c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) &
4187 & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff &
4188 & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff
4189 d(k)=u(k) + dtz(k)*uoce*ust**2/wspd &
4190 & - dtz(k)*rhoinv(k)*s_awu(k+1)*onoff &
4191 & + dtz(k)*rhoinv(k)*sd_awu(k+1)*onoff &
4192 & + sub_u(k)*delt + det_u(k)*delt
4194 do k=kts+1,kte-1
4195 a(k)= -dtz(k)*kmdz(k)*rhoinv(k) &
4196 & + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*onoff &
4197 & + 0.5*dtz(k)*rhoinv(k)*sd_aw(k)*onoff
4198 b(k)=1.+ dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) &
4199 & + 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*onoff &
4200 & + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1))*onoff
4201 c(k)= - dtz(k)*kmdz(k+1)*rhoinv(k) &
4202 & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff &
4203 & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff
4204 d(k)=u(k) + dtz(k)*rhoinv(k)*(s_awu(k)-s_awu(k+1))*onoff &
4205 & - dtz(k)*rhoinv(k)*(sd_awu(k)-sd_awu(k+1))*onoff &
4206 & + sub_u(k)*delt + det_u(k)*delt
4207 enddo
4209 !! no flux at the top
4210 ! a(kte)=-1.
4211 ! b(kte)=1.
4212 ! c(kte)=0.
4213 ! d(kte)=0.
4215 !! specified gradient at the top
4216 ! a(kte)=-1.
4217 ! b(kte)=1.
4218 ! c(kte)=0.
4219 ! d(kte)=gradu_top*dztop
4221 !! prescribed value
4222 a(kte)=0
4223 b(kte)=1.
4224 c(kte)=0.
4225 d(kte)=u(kte)
4227 ! CALL tridiag(kte,a,b,c,d)
4228 CALL tridiag2(kte,a,b,c,d,x)
4229 ! CALL tridiag3(kte,a,b,c,d,x)
4231 DO k=kts,kte
4232 ! du(k)=(d(k-kts+1)-u(k))/delt
4233 du(k)=(x(k)-u(k))/delt
4234 ENDDO
4236 !!============================================
4237 !! v
4238 !!============================================
4240 k=kts
4242 !rho-weighted (drag in b-vector):
4243 a(k)= -dtz(k)*kmdz(k)*rhoinv(k)
4244 b(k)=1.+dtz(k)*(kmdz(k+1) + rhosfc*ust**2/wspd)*rhoinv(k) &
4245 & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff &
4246 & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff
4247 c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) &
4248 & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff &
4249 & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff
4250 d(k)=v(k) + dtz(k)*voce*ust**2/wspd &
4251 & - dtz(k)*rhoinv(k)*s_awv(k+1)*onoff &
4252 & + dtz(k)*rhoinv(k)*sd_awv(k+1)*onoff &
4253 & + sub_v(k)*delt + det_v(k)*delt
4255 do k=kts+1,kte-1
4256 a(k)= -dtz(k)*kmdz(k)*rhoinv(k) &
4257 & + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*onoff &
4258 & + 0.5*dtz(k)*rhoinv(k)*sd_aw(k)*onoff
4259 b(k)=1.+dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) &
4260 & + 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*onoff &
4261 & + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1))*onoff
4262 c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) &
4263 & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff &
4264 & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff
4265 d(k)=v(k) + dtz(k)*rhoinv(k)*(s_awv(k)-s_awv(k+1))*onoff &
4266 & - dtz(k)*rhoinv(k)*(sd_awv(k)-sd_awv(k+1))*onoff &
4267 & + sub_v(k)*delt + det_v(k)*delt
4268 enddo
4270 !! no flux at the top
4271 ! a(kte)=-1.
4272 ! b(kte)=1.
4273 ! c(kte)=0.
4274 ! d(kte)=0.
4276 !! specified gradient at the top
4277 ! a(kte)=-1.
4278 ! b(kte)=1.
4279 ! c(kte)=0.
4280 ! d(kte)=gradv_top*dztop
4282 !! prescribed value
4283 a(kte)=0
4284 b(kte)=1.
4285 c(kte)=0.
4286 d(kte)=v(kte)
4288 ! CALL tridiag(kte,a,b,c,d)
4289 CALL tridiag2(kte,a,b,c,d,x)
4290 ! CALL tridiag3(kte,a,b,c,d,x)
4292 DO k=kts,kte
4293 ! dv(k)=(d(k-kts+1)-v(k))/delt
4294 dv(k)=(x(k)-v(k))/delt
4295 ENDDO
4297 !!============================================
4298 !! thl tendency
4299 !!============================================
4300 k=kts
4302 ! a(k)=0.
4303 ! b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1)
4304 ! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1)
4305 ! d(k)=thl(k) + dtz(k)*flt + tcd(k)*delt &
4306 ! & -dtz(k)*s_awthl(kts+1) + diss_heat(k)*delt + &
4307 ! & sub_thl(k)*delt + det_thl(k)*delt
4308 !
4309 ! DO k=kts+1,kte-1
4310 ! a(k)= -dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k)
4311 ! b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))
4312 ! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1)
4313 ! d(k)=thl(k) + tcd(k)*delt + dtz(k)*(s_awthl(k)-s_awthl(k+1)) &
4314 ! & + diss_heat(k)*delt + &
4315 ! & sub_thl(k)*delt + det_thl(k)*delt
4316 ! ENDDO
4318 !rho-weighted: rhosfc*X*rhoinv(k)
4319 a(k)= -dtz(k)*khdz(k)*rhoinv(k)
4320 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)
4321 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)
4322 d(k)=thl(k) + dtz(k)*rhosfc*flt*rhoinv(k) + tcd(k)*delt &
4323 & - dtz(k)*rhoinv(k)*s_awthl(k+1) -dtz(k)*rhoinv(k)*sd_awthl(k+1) + &
4324 & diss_heat(k)*delt + sub_thl(k)*delt + det_thl(k)*delt
4326 DO k=kts+1,kte-1
4327 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)
4328 b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + &
4329 & 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))
4330 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)
4331 d(k)=thl(k) + tcd(k)*delt + &
4332 & dtz(k)*rhoinv(k)*(s_awthl(k)-s_awthl(k+1)) + dtz(k)*rhoinv(k)*(sd_awthl(k)-sd_awthl(k+1)) + &
4333 & diss_heat(k)*delt + &
4334 & sub_thl(k)*delt + det_thl(k)*delt
4335 ENDDO
4337 !! no flux at the top
4338 ! a(kte)=-1.
4339 ! b(kte)=1.
4340 ! c(kte)=0.
4341 ! d(kte)=0.
4343 !! specified gradient at the top
4344 !assume gradthl_top=gradth_top
4345 ! a(kte)=-1.
4346 ! b(kte)=1.
4347 ! c(kte)=0.
4348 ! d(kte)=gradth_top*dztop
4350 !! prescribed value
4351 a(kte)=0.
4352 b(kte)=1.
4353 c(kte)=0.
4354 d(kte)=thl(kte)
4356 ! CALL tridiag(kte,a,b,c,d)
4357 CALL tridiag2(kte,a,b,c,d,x)
4358 ! CALL tridiag3(kte,a,b,c,d,x)
4360 DO k=kts,kte
4361 !thl(k)=d(k-kts+1)
4362 thl(k)=x(k)
4363 ENDDO
4365 IF (bl_mynn_mixqt > 0) THEN
4366 !============================================
4367 ! MIX total water (sqw = sqc + sqv + sqi)
4368 ! NOTE: no total water tendency is output; instead, we must calculate
4369 ! the saturation specific humidity and then
4370 ! subtract out the moisture excess (sqc & sqi)
4371 !============================================
4373 k=kts
4375 ! a(k)=0.
4376 ! b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1)
4377 ! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1)
4378 ! !rhs= qcd(k) !+ (gfluxp - gfluxm)/dz(k)&
4379 ! d(k)=sqw(k) + dtz(k)*flq + qcd(k)*delt - dtz(k)*s_awqt(k+1)
4380 !
4381 ! DO k=kts+1,kte-1
4382 ! a(k)= -dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k)
4383 ! b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))
4384 ! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1)
4385 ! d(k)=sqw(k) + qcd(k)*delt + dtz(k)*(s_awqt(k)-s_awqt(k+1))
4386 ! ENDDO
4388 !rho-weighted:
4389 a(k)= -dtz(k)*khdz(k)*rhoinv(k)
4390 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)
4391 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)
4392 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)
4394 DO k=kts+1,kte-1
4395 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)
4396 b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + &
4397 & 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))
4398 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)
4399 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))
4400 ENDDO
4402 !! no flux at the top
4403 ! a(kte)=-1.
4404 ! b(kte)=1.
4405 ! c(kte)=0.
4406 ! d(kte)=0.
4407 !! specified gradient at the top
4408 !assume gradqw_top=gradqv_top
4409 ! a(kte)=-1.
4410 ! b(kte)=1.
4411 ! c(kte)=0.
4412 ! d(kte)=gradqv_top*dztop
4413 !! prescribed value
4414 a(kte)=0.
4415 b(kte)=1.
4416 c(kte)=0.
4417 d(kte)=sqw(kte)
4419 ! CALL tridiag(kte,a,b,c,d)
4420 CALL tridiag2(kte,a,b,c,d,sqw2)
4421 ! CALL tridiag3(kte,a,b,c,d,sqw2)
4423 ! DO k=kts,kte
4424 ! sqw2(k)=d(k-kts+1)
4425 ! ENDDO
4426 ELSE
4427 sqw2=sqw
4428 ENDIF
4430 IF (bl_mynn_mixqt == 0) THEN
4431 !============================================
4432 ! cloud water ( sqc ). If mixing total water (bl_mynn_mixqt > 0),
4433 ! then sqc will be backed out of saturation check (below).
4434 !============================================
4435 IF (bl_mynn_cloudmix > 0 .AND. FLAG_QC) THEN
4437 k=kts
4439 ! a(k)=0.
4440 ! b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1)
4441 ! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1)
4442 ! d(k)=sqc(k) + dtz(k)*flqc + qcd(k)*delt - &
4443 ! dtz(k)*s_awqc(k+1) + det_sqc(k)*delt
4444 !
4445 ! DO k=kts+1,kte-1
4446 ! a(k)= -dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k)
4447 ! b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))
4448 ! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1)
4449 ! d(k)=sqc(k) + qcd(k)*delt + dtz(k)*(s_awqc(k)-s_awqc(k+1)) + &
4450 ! det_sqc(k)*delt
4451 ! ENDDO
4453 !rho-weighted:
4454 a(k)= -dtz(k)*khdz(k)*rhoinv(k)
4455 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)
4456 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)
4457 d(k)=sqc(k) + dtz(k)*rhosfc*flqc*rhoinv(k) + qcd(k)*delt &
4458 & - dtz(k)*rhoinv(k)*s_awqc(k+1) - dtz(k)*rhoinv(k)*sd_awqc(k+1) + &
4459 & det_sqc(k)*delt
4461 DO k=kts+1,kte-1
4462 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)
4463 b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + &
4464 & 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))
4465 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)
4466 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)) + &
4467 & det_sqc(k)*delt
4468 ENDDO
4470 ! prescribed value
4471 a(kte)=0.
4472 b(kte)=1.
4473 c(kte)=0.
4474 d(kte)=sqc(kte)
4476 ! CALL tridiag(kte,a,b,c,d)
4477 CALL tridiag2(kte,a,b,c,d,sqc2)
4478 ! CALL tridiag3(kte,a,b,c,d,sqc2)
4480 ! DO k=kts,kte
4481 ! sqc2(k)=d(k-kts+1)
4482 ! ENDDO
4483 ELSE
4484 !If not mixing clouds, set "updated" array equal to original array
4485 sqc2=sqc
4486 ENDIF
4487 ENDIF
4489 IF (bl_mynn_mixqt == 0) THEN
4490 !============================================
4491 ! MIX WATER VAPOR ONLY ( sqv ). If mixing total water (bl_mynn_mixqt > 0),
4492 ! then sqv will be backed out of saturation check (below).
4493 !============================================
4495 k=kts
4497 ! a(k)=0.
4498 ! b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1)
4499 ! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1)
4500 ! d(k)=sqv(k) + dtz(k)*flqv + qcd(k)*delt - dtz(k)*s_awqv(k+1) + &
4501 ! & sub_sqv(k)*delt + det_sqv(k)*delt
4502 !
4503 ! DO k=kts+1,kte-1
4504 ! a(k)= -dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k)
4505 ! b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))
4506 ! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1)
4507 ! d(k)=sqv(k) + qcd(k)*delt + dtz(k)*(s_awqv(k)-s_awqv(k+1)) + &
4508 ! & sub_sqv(k)*delt + det_sqv(k)*delt
4509 ! ENDDO
4511 !limit unreasonably large negative fluxes:
4512 qvflux = flqv
4513 if (qvflux < 0.0) then
4514 !do not allow specified surface flux to reduce qv below 1e-8 kg/kg
4515 qvflux = max(qvflux, (min(0.9*sqv(kts) - 1e-8, 0.0)/dtz(kts)))
4516 endif
4518 !rho-weighted: rhosfc*X*rhoinv(k)
4519 a(k)= -dtz(k)*khdz(k)*rhoinv(k)
4520 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)
4521 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)
4522 d(k)=sqv(k) + dtz(k)*rhosfc*qvflux*rhoinv(k) + qcd(k)*delt &
4523 & - dtz(k)*rhoinv(k)*s_awqv(k+1) - dtz(k)*rhoinv(k)*sd_awqv(k+1) + &
4524 & sub_sqv(k)*delt + det_sqv(k)*delt
4526 DO k=kts+1,kte-1
4527 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)
4528 b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + &
4529 & 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))
4530 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)
4531 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)) + &
4532 & sub_sqv(k)*delt + det_sqv(k)*delt
4533 ENDDO
4535 ! no flux at the top
4536 ! a(kte)=-1.
4537 ! b(kte)=1.
4538 ! c(kte)=0.
4539 ! d(kte)=0.
4541 ! specified gradient at the top
4542 ! assume gradqw_top=gradqv_top
4543 ! a(kte)=-1.
4544 ! b(kte)=1.
4545 ! c(kte)=0.
4546 ! d(kte)=gradqv_top*dztop
4548 ! prescribed value
4549 a(kte)=0.
4550 b(kte)=1.
4551 c(kte)=0.
4552 d(kte)=sqv(kte)
4554 ! CALL tridiag(kte,a,b,c,d)
4555 CALL tridiag2(kte,a,b,c,d,sqv2)
4556 ! CALL tridiag3(kte,a,b,c,d,sqv2)
4558 ! DO k=kts,kte
4559 ! sqv2(k)=d(k-kts+1)
4560 ! ENDDO
4561 ELSE
4562 sqv2=sqv
4563 ENDIF
4565 !============================================
4566 ! MIX CLOUD ICE ( sqi )
4567 !============================================
4568 IF (bl_mynn_cloudmix > 0 .AND. FLAG_QI) THEN
4570 k=kts
4571 !rho-weighted:
4572 a(k)= -dtz(k)*khdz(k)*rhoinv(k)
4573 b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k)
4574 c(k)= -dtz(k)*khdz(k+1)*rhoinv(k)
4575 d(k)=sqi(k)
4577 DO k=kts+1,kte-1
4578 a(k)= -dtz(k)*khdz(k)*rhoinv(k)
4579 b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k)
4580 c(k)= -dtz(k)*khdz(k+1)*rhoinv(k)
4581 d(k)=sqi(k)
4582 ENDDO
4584 !! no flux at the top
4585 ! a(kte)=-1.
4586 ! b(kte)=1.
4587 ! c(kte)=0.
4588 ! d(kte)=0.
4590 !! specified gradient at the top
4591 !assume gradqw_top=gradqv_top
4592 ! a(kte)=-1.
4593 ! b(kte)=1.
4594 ! c(kte)=0.
4595 ! d(kte)=gradqv_top*dztop
4597 !! prescribed value
4598 a(kte)=0.
4599 b(kte)=1.
4600 c(kte)=0.
4601 d(kte)=sqi(kte)
4603 ! CALL tridiag(kte,a,b,c,d)
4604 CALL tridiag2(kte,a,b,c,d,sqi2)
4605 ! CALL tridiag3(kte,a,b,c,d,sqi2)
4607 ! DO k=kts,kte
4608 ! sqi2(k)=d(k-kts+1)
4609 ! ENDDO
4610 ELSE
4611 sqi2=sqi
4612 ENDIF
4614 !============================================
4615 ! MIX SNOW ( sqs )
4616 !============================================
4617 !hard-code to not mix snow
4618 IF (bl_mynn_cloudmix > 0 .AND. .false.) THEN
4620 k=kts
4621 !rho-weighted:
4622 a(k)= -dtz(k)*khdz(k)*rhoinv(k)
4623 b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k)
4624 c(k)= -dtz(k)*khdz(k+1)*rhoinv(k)
4625 d(k)=sqs(k)
4627 DO k=kts+1,kte-1
4628 a(k)= -dtz(k)*khdz(k)*rhoinv(k)
4629 b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k)
4630 c(k)= -dtz(k)*khdz(k+1)*rhoinv(k)
4631 d(k)=sqs(k)
4632 ENDDO
4634 !! prescribed value
4635 a(kte)=0.
4636 b(kte)=1.
4637 c(kte)=0.
4638 d(kte)=sqs(kte)
4640 ! CALL tridiag(kte,a,b,c,d)
4641 CALL tridiag2(kte,a,b,c,d,sqs2)
4642 ! CALL tridiag3(kte,a,b,c,d,sqs2)
4644 ! DO k=kts,kte
4645 ! sqs2(k)=d(k-kts+1)
4646 ! ENDDO
4647 ELSE
4648 sqs2=sqs
4649 ENDIF
4651 !!============================================
4652 !! cloud ice number concentration (qni)
4653 !!============================================
4654 IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNI .AND. &
4655 bl_mynn_mixscalars > 0) THEN
4657 k=kts
4659 a(k)= -dtz(k)*khdz(k)*rhoinv(k)
4660 b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc
4661 c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc
4662 d(k)=qni(k) - dtz(k)*rhoinv(k)*s_awqni(k+1)*nonloc
4664 DO k=kts+1,kte-1
4665 a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*nonloc
4666 b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + &
4667 & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*nonloc
4668 c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc
4669 d(k)=qni(k) + dtz(k)*rhoinv(k)*(s_awqni(k)-s_awqni(k+1))*nonloc
4670 ENDDO
4672 !! prescribed value
4673 a(kte)=0.
4674 b(kte)=1.
4675 c(kte)=0.
4676 d(kte)=qni(kte)
4678 ! CALL tridiag(kte,a,b,c,d)
4679 CALL tridiag2(kte,a,b,c,d,x)
4680 ! CALL tridiag3(kte,a,b,c,d,x)
4682 DO k=kts,kte
4683 !qni2(k)=d(k-kts+1)
4684 qni2(k)=x(k)
4685 ENDDO
4687 ELSE
4688 qni2=qni
4689 ENDIF
4691 !!============================================
4692 !! cloud water number concentration (qnc)
4693 !! include non-local transport
4694 !!============================================
4695 IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNC .AND. &
4696 bl_mynn_mixscalars > 0) THEN
4698 k=kts
4700 a(k)= -dtz(k)*khdz(k)*rhoinv(k)
4701 b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc
4702 c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc
4703 d(k)=qnc(k) - dtz(k)*rhoinv(k)*s_awqnc(k+1)*nonloc
4705 DO k=kts+1,kte-1
4706 a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*nonloc
4707 b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + &
4708 & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*nonloc
4709 c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc
4710 d(k)=qnc(k) + dtz(k)*rhoinv(k)*(s_awqnc(k)-s_awqnc(k+1))*nonloc
4711 ENDDO
4713 !! prescribed value
4714 a(kte)=0.
4715 b(kte)=1.
4716 c(kte)=0.
4717 d(kte)=qnc(kte)
4719 ! CALL tridiag(kte,a,b,c,d)
4720 CALL tridiag2(kte,a,b,c,d,x)
4721 ! CALL tridiag3(kte,a,b,c,d,x)
4723 DO k=kts,kte
4724 !qnc2(k)=d(k-kts+1)
4725 qnc2(k)=x(k)
4726 ENDDO
4728 ELSE
4729 qnc2=qnc
4730 ENDIF
4732 !============================================
4733 ! Water-friendly aerosols ( qnwfa ).
4734 !============================================
4735 IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNWFA .AND. &
4736 bl_mynn_mixscalars > 0) THEN
4738 k=kts
4740 a(k)= -dtz(k)*khdz(k)*rhoinv(k)
4741 b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) - &
4742 & 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc
4743 c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc
4744 d(k)=qnwfa(k) - dtz(k)*rhoinv(k)*s_awqnwfa(k+1)*nonloc
4746 DO k=kts+1,kte-1
4747 a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*nonloc
4748 b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) + &
4749 & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*nonloc
4750 c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc
4751 d(k)=qnwfa(k) + dtz(k)*rhoinv(k)*(s_awqnwfa(k)-s_awqnwfa(k+1))*nonloc
4752 ENDDO
4754 ! prescribed value
4755 a(kte)=0.
4756 b(kte)=1.
4757 c(kte)=0.
4758 d(kte)=qnwfa(kte)
4760 ! CALL tridiag(kte,a,b,c,d)
4761 CALL tridiag2(kte,a,b,c,d,x)
4762 ! CALL tridiag3(kte,a,b,c,d,x)
4764 DO k=kts,kte
4765 !qnwfa2(k)=d(k)
4766 qnwfa2(k)=x(k)
4767 ENDDO
4769 ELSE
4770 !If not mixing aerosols, set "updated" array equal to original array
4771 qnwfa2=qnwfa
4772 ENDIF
4774 !============================================
4775 ! Ice-friendly aerosols ( qnifa ).
4776 !============================================
4777 IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNIFA .AND. &
4778 bl_mynn_mixscalars > 0) THEN
4780 k=kts
4782 a(k)= -dtz(k)*khdz(k)*rhoinv(k)
4783 b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) - &
4784 & 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc
4785 c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc
4786 d(k)=qnifa(k) - dtz(k)*rhoinv(k)*s_awqnifa(k+1)*nonloc
4788 DO k=kts+1,kte-1
4789 a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*nonloc
4790 b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) + &
4791 & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*nonloc
4792 c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc
4793 d(k)=qnifa(k) + dtz(k)*rhoinv(k)*(s_awqnifa(k)-s_awqnifa(k+1))*nonloc
4794 ENDDO
4796 ! prescribed value
4797 a(kte)=0.
4798 b(kte)=1.
4799 c(kte)=0.
4800 d(kte)=qnifa(kte)
4802 ! CALL tridiag(kte,a,b,c,d)
4803 CALL tridiag2(kte,a,b,c,d,x)
4804 ! CALL tridiag3(kte,a,b,c,d,x)
4806 DO k=kts,kte
4807 !qnifa2(k)=d(k-kts+1)
4808 qnifa2(k)=x(k)
4809 ENDDO
4811 ELSE
4812 !If not mixing aerosols, set "updated" array equal to original array
4813 qnifa2=qnifa
4814 ENDIF
4816 !============================================
4817 ! Black-carbon aerosols ( qnbca ).
4818 !============================================
4819 IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNBCA .AND. &
4820 bl_mynn_mixscalars > 0) THEN
4822 k=kts
4824 a(k)= -dtz(k)*khdz(k)*rhoinv(k)
4825 b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) - &
4826 & 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc
4827 c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc
4828 d(k)=qnbca(k) - dtz(k)*rhoinv(k)*s_awqnbca(k+1)*nonloc
4830 DO k=kts+1,kte-1
4831 a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*nonloc
4832 b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) + &
4833 & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*nonloc
4834 c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc
4835 d(k)=qnbca(k) + dtz(k)*rhoinv(k)*(s_awqnbca(k)-s_awqnbca(k+1))*nonloc
4836 ENDDO
4838 ! prescribed value
4839 a(kte)=0.
4840 b(kte)=1.
4841 c(kte)=0.
4842 d(kte)=qnbca(kte)
4844 ! CALL tridiag(kte,a,b,c,d)
4845 CALL tridiag2(kte,a,b,c,d,x)
4846 ! CALL tridiag3(kte,a,b,c,d,x)
4848 DO k=kts,kte
4849 !qnbca2(k)=d(k-kts+1)
4850 qnbca2(k)=x(k)
4851 ENDDO
4853 ELSE
4854 !If not mixing aerosols, set "updated" array equal to original array
4855 qnbca2=qnbca
4856 ENDIF
4858 !============================================
4859 ! Ozone - local mixing only
4860 !============================================
4861 IF (FLAG_OZONE) THEN
4862 k=kts
4864 !rho-weighted:
4865 a(k)= -dtz(k)*khdz(k)*rhoinv(k)
4866 b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k)
4867 c(k)= -dtz(k)*khdz(k+1)*rhoinv(k)
4868 d(k)=ozone(k)
4870 DO k=kts+1,kte-1
4871 a(k)= -dtz(k)*khdz(k)*rhoinv(k)
4872 b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k)
4873 c(k)= -dtz(k)*khdz(k+1)*rhoinv(k)
4874 d(k)=ozone(k)
4875 ENDDO
4877 ! prescribed value
4878 a(kte)=0.
4879 b(kte)=1.
4880 c(kte)=0.
4881 d(kte)=ozone(kte)
4883 ! CALL tridiag(kte,a,b,c,d)
4884 CALL tridiag2(kte,a,b,c,d,x)
4885 ! CALL tridiag3(kte,a,b,c,d,x)
4887 DO k=kts,kte
4888 !ozone2(k)=d(k-kts+1)
4889 dozone(k)=(x(k)-ozone(k))/delt
4890 ENDDO
4891 ELSE
4892 dozone(:)=0.0
4893 ENDIF
4895 !!============================================
4896 !! Compute tendencies and convert to mixing ratios for WRF.
4897 !! Note that the momentum tendencies are calculated above.
4898 !!============================================
4900 IF (bl_mynn_mixqt > 0) THEN
4901 DO k=kts,kte
4902 !compute updated theta using updated thl and old condensate
4903 th_new = thl(k) + xlvcp/exner(k)*sqc(k) &
4904 & + xlscp/exner(k)*sqi(k)
4906 t = th_new*exner(k)
4907 qsat = qsat_blend(t,p(k))
4908 !SATURATED VAPOR PRESSURE
4909 !esat=esat_blend(t)
4910 !SATURATED SPECIFIC HUMIDITY
4911 !qsl=ep_2*esat/(p(k)-ep_3*esat)
4912 !qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat))
4914 IF (sqc(k) > 0.0 .or. sqi(k) > 0.0) THEN !initially saturated
4915 sqv2(k) = MIN(sqw2(k),qsat)
4916 portion_qc = sqc(k)/(sqc(k) + sqi(k))
4917 portion_qi = sqi(k)/(sqc(k) + sqi(k))
4918 condensate = MAX(sqw2(k) - qsat, 0.0)
4919 sqc2(k) = condensate*portion_qc
4920 sqi2(k) = condensate*portion_qi
4921 ELSE ! initially unsaturated -----
4922 sqv2(k) = sqw2(k) ! let microphys decide what to do
4923 sqi2(k) = 0.0 ! if sqw2 > qsat
4924 sqc2(k) = 0.0
4925 ENDIF
4926 ENDDO
4927 ENDIF
4930 !=====================
4931 ! WATER VAPOR TENDENCY
4932 !=====================
4933 DO k=kts,kte
4934 Dqv(k)=(sqv2(k) - sqv(k))/delt
4935 !if (sqv2(k) < 0.0)print*,"neg qv:",sqv2(k),k
4936 ENDDO
4938 IF (bl_mynn_cloudmix > 0) THEN
4939 !=====================
4940 ! CLOUD WATER TENDENCY
4941 !=====================
4942 !print*,"FLAG_QC:",FLAG_QC
4943 IF (FLAG_QC) THEN
4944 DO k=kts,kte
4945 Dqc(k)=(sqc2(k) - sqc(k))/delt
4946 !if (sqc2(k) < 0.0)print*,"neg qc:",sqc2(k),k
4947 ENDDO
4948 ELSE
4949 DO k=kts,kte
4950 Dqc(k) = 0.
4951 ENDDO
4952 ENDIF
4954 !===================
4955 ! CLOUD WATER NUM CONC TENDENCY
4956 !===================
4957 IF (FLAG_QNC .AND. bl_mynn_mixscalars > 0) THEN
4958 DO k=kts,kte
4959 Dqnc(k) = (qnc2(k)-qnc(k))/delt
4960 !IF(Dqnc(k)*delt + qnc(k) < 0.)Dqnc(k)=-qnc(k)/delt
4961 ENDDO
4962 ELSE
4963 DO k=kts,kte
4964 Dqnc(k) = 0.
4965 ENDDO
4966 ENDIF
4968 !===================
4969 ! CLOUD ICE TENDENCY
4970 !===================
4971 IF (FLAG_QI) THEN
4972 DO k=kts,kte
4973 Dqi(k)=(sqi2(k) - sqi(k))/delt
4974 !if (sqi2(k) < 0.0)print*,"neg qi:",sqi2(k),k
4975 ENDDO
4976 ELSE
4977 DO k=kts,kte
4978 Dqi(k) = 0.
4979 ENDDO
4980 ENDIF
4982 !===================
4983 ! CLOUD SNOW TENDENCY
4984 !===================
4985 IF (.false.) THEN !disabled
4986 DO k=kts,kte
4987 Dqs(k)=(sqs2(k) - sqs(k))/delt
4988 ENDDO
4989 ELSE
4990 DO k=kts,kte
4991 Dqs(k) = 0.
4992 ENDDO
4993 ENDIF
4995 !===================
4996 ! CLOUD ICE NUM CONC TENDENCY
4997 !===================
4998 IF (FLAG_QNI .AND. bl_mynn_mixscalars > 0) THEN
4999 DO k=kts,kte
5000 Dqni(k)=(qni2(k)-qni(k))/delt
5001 !IF(Dqni(k)*delt + qni(k) < 0.)Dqni(k)=-qni(k)/delt
5002 ENDDO
5003 ELSE
5004 DO k=kts,kte
5005 Dqni(k)=0.
5006 ENDDO
5007 ENDIF
5008 ELSE !-MIX CLOUD SPECIES?
5009 !CLOUDS ARE NOT NIXED (when bl_mynn_cloudmix == 0)
5010 DO k=kts,kte
5011 Dqc(k) =0.
5012 Dqnc(k)=0.
5013 Dqi(k) =0.
5014 Dqni(k)=0.
5015 Dqs(k) =0.
5016 ENDDO
5017 ENDIF
5019 !ensure non-negative moist species
5020 CALL moisture_check(kte, delt, delp, exner, &
5021 sqv2, sqc2, sqi2, sqs2, thl, &
5022 dqv, dqc, dqi, dqs, dth )
5024 !=====================
5025 ! OZONE TENDENCY CHECK
5026 !=====================
5027 DO k=kts,kte
5028 IF(Dozone(k)*delt + ozone(k) < 0.) THEN
5029 Dozone(k)=-ozone(k)*0.99/delt
5030 ENDIF
5031 ENDDO
5033 !===================
5034 ! THETA TENDENCY
5035 !===================
5036 IF (FLAG_QI) THEN
5037 DO k=kts,kte
5038 Dth(k)=(thl(k) + xlvcp/exner(k)*sqc2(k) &
5039 & + xlscp/exner(k)*(sqi2(k)) & !+sqs(k)) &
5040 & - th(k))/delt
5041 !Use form from Tripoli and Cotton (1981) with their
5042 !suggested min temperature to improve accuracy:
5043 !Dth(k)=(thl(k)*(1.+ xlvcp/MAX(tk(k),TKmin)*sqc(k) &
5044 ! & + xlscp/MAX(tk(k),TKmin)*sqi(k)) &
5045 ! & - th(k))/delt
5046 ENDDO
5047 ELSE
5048 DO k=kts,kte
5049 Dth(k)=(thl(k)+xlvcp/exner(k)*sqc2(k) - th(k))/delt
5050 !Use form from Tripoli and Cotton (1981) with their
5051 !suggested min temperature to improve accuracy.
5052 !Dth(k)=(thl(k)*(1.+ xlvcp/MAX(tk(k),TKmin)*sqc(k)) &
5053 !& - th(k))/delt
5054 ENDDO
5055 ENDIF
5057 !===================
5058 ! AEROSOL TENDENCIES
5059 !===================
5060 IF (FLAG_QNWFA .AND. FLAG_QNIFA .AND. &
5061 bl_mynn_mixscalars > 0) THEN
5062 DO k=kts,kte
5063 !=====================
5064 ! WATER-friendly aerosols
5065 !=====================
5066 Dqnwfa(k)=(qnwfa2(k) - qnwfa(k))/delt
5067 !=====================
5068 ! Ice-friendly aerosols
5069 !=====================
5070 Dqnifa(k)=(qnifa2(k) - qnifa(k))/delt
5071 ENDDO
5072 ELSE
5073 DO k=kts,kte
5074 Dqnwfa(k)=0.
5075 Dqnifa(k)=0.
5076 ENDDO
5077 ENDIF
5079 !========================
5080 ! BLACK-CARBON TENDENCIES
5081 !========================
5082 IF (FLAG_QNBCA .AND. bl_mynn_mixscalars > 0) THEN
5083 DO k=kts,kte
5084 Dqnbca(k)=(qnbca2(k) - qnbca(k))/delt
5085 ENDDO
5086 ELSE
5087 DO k=kts,kte
5088 Dqnbca(k)=0.
5089 ENDDO
5090 ENDIF
5092 !ensure non-negative moist species
5093 !note: if called down here, dth needs to be updated, but
5094 ! if called before the theta-tendency calculation, do not compute dth
5095 !CALL moisture_check(kte, delt, delp, exner, &
5096 ! sqv, sqc, sqi, thl, &
5097 ! dqv, dqc, dqi, dth )
5099 if (debug_code) then
5100 problem = .false.
5101 do k=kts,kte
5102 wsp = sqrt(u(k)**2 + v(k)**2)
5103 wsp2 = sqrt((u(k)+du(k)*delt)**2 + (v(k)+du(k)*delt)**2)
5104 th2 = th(k) + Dth(k)*delt
5105 tk2 = th2*exner(k)
5106 if (wsp2 > 200. .or. tk2 > 360. .or. tk2 < 160.) then
5107 problem = .true.
5108 print*,"Outgoing problem at: i=",i," k=",k
5109 print*," incoming wsp=",wsp," outgoing wsp=",wsp2
5110 print*," incoming T=",th(k)*exner(k),"outgoing T:",tk2
5111 print*," du=",du(k)*delt," dv=",dv(k)*delt," dth=",dth(k)*delt
5112 print*," km=",kmdz(k)*dz(k)," kh=",khdz(k)*dz(k)
5113 print*," u*=",ust," wspd=",wspd,"rhosfc=",rhosfc
5114 print*," LH=",flq*rhosfc*1004.," HFX=",flt*rhosfc*1004.
5115 print*," drag term=",ust**2/wspd*dtz(k)*rhosfc/rho(kts)
5116 kproblem = k
5117 endif
5118 enddo
5119 if (problem) then
5120 print*,"==thl:",thl(max(kproblem-3,1):min(kproblem+3,kte))
5121 print*,"===qv:",sqv2(max(kproblem-3,1):min(kproblem+3,kte))
5122 print*,"===qc:",sqc2(max(kproblem-3,1):min(kproblem+3,kte))
5123 print*,"===qi:",sqi2(max(kproblem-3,1):min(kproblem+3,kte))
5124 print*,"====u:",u(max(kproblem-3,1):min(kproblem+3,kte))
5125 print*,"====v:",v(max(kproblem-3,1):min(kproblem+3,kte))
5126 endif
5127 endif
5129 #ifdef HARDCODE_VERTICAL
5130 # undef kts
5131 # undef kte
5132 #endif
5134 END SUBROUTINE mynn_tendencies
5136 ! ==================================================================
5137 SUBROUTINE moisture_check(kte, delt, dp, exner, &
5138 qv, qc, qi, qs, th, &
5139 dqv, dqc, dqi, dqs, dth )
5141 ! This subroutine was adopted from the CAM-UW ShCu scheme and
5142 ! adapted for use here.
5143 !
5144 ! If qc < qcmin, qi < qimin, or qv < qvmin happens in any layer,
5145 ! force them to be larger than minimum value by (1) condensating
5146 ! water vapor into liquid or ice, and (2) by transporting water vapor
5147 ! from the very lower layer.
5148 !
5149 ! We then update the final state variables and tendencies associated
5150 ! with this correction. If any condensation happens, update theta too.
5151 ! Note that (qv,qc,qi,th) are the final state variables after
5152 ! applying corresponding input tendencies and corrective tendencies.
5154 implicit none
5155 integer, intent(in) :: kte
5156 real(kind_phys), intent(in) :: delt
5157 real(kind_phys), dimension(kte), intent(in) :: dp, exner
5158 real(kind_phys), dimension(kte), intent(inout) :: qv, qc, qi, qs, th
5159 real(kind_phys), dimension(kte), intent(inout) :: dqv, dqc, dqi, dqs, dth
5160 integer k
5161 real(kind_phys):: dqc2, dqi2, dqs2, dqv2, sum, aa, dum
5162 real(kind_phys), parameter :: qvmin = 1e-20, &
5163 qcmin = 0.0, &
5164 qimin = 0.0
5166 do k = kte, 1, -1 ! From the top to the surface
5167 dqc2 = max(0.0, qcmin-qc(k)) !qc deficit (>=0)
5168 dqi2 = max(0.0, qimin-qi(k)) !qi deficit (>=0)
5169 dqs2 = max(0.0, qimin-qs(k)) !qs deficit (>=0)
5171 !fix tendencies
5172 dqc(k) = dqc(k) + dqc2/delt
5173 dqi(k) = dqi(k) + dqi2/delt
5174 dqs(k) = dqs(k) + dqs2/delt
5175 dqv(k) = dqv(k) - (dqc2+dqi2+dqs2)/delt
5176 dth(k) = dth(k) + xlvcp/exner(k)*(dqc2/delt) + &
5177 xlscp/exner(k)*((dqi2+dqs2)/delt)
5178 !update species
5179 qc(k) = qc(k) + dqc2
5180 qi(k) = qi(k) + dqi2
5181 qs(k) = qs(k) + dqs2
5182 qv(k) = qv(k) - dqc2 - dqi2 - dqs2
5183 th(k) = th(k) + xlvcp/exner(k)*dqc2 + &
5184 xlscp/exner(k)*(dqi2+dqs2)
5186 !then fix qv
5187 dqv2 = max(0.0, qvmin-qv(k)) !qv deficit (>=0)
5188 dqv(k) = dqv(k) + dqv2/delt
5189 qv(k) = qv(k) + dqv2
5190 if( k .ne. 1 ) then
5191 qv(k-1) = qv(k-1) - dqv2*dp(k)/dp(k-1)
5192 dqv(k-1) = dqv(k-1) - dqv2*dp(k)/dp(k-1)/delt
5193 endif
5194 qv(k) = max(qv(k),qvmin)
5195 qc(k) = max(qc(k),qcmin)
5196 qi(k) = max(qi(k),qimin)
5197 qs(k) = max(qs(k),qimin)
5198 end do
5199 ! Extra moisture used to satisfy 'qv(1)>=qvmin' is proportionally
5200 ! extracted from all the layers that has 'qv > 2*qvmin'. This fully
5201 ! preserves column moisture.
5202 if( dqv2 .gt. 1.e-20 ) then
5203 sum = 0.0
5204 do k = 1, kte
5205 if( qv(k) .gt. 2.0*qvmin ) sum = sum + qv(k)*dp(k)
5206 enddo
5207 aa = dqv2*dp(1)/max(1.e-20,sum)
5208 if( aa .lt. 0.5 ) then
5209 do k = 1, kte
5210 if( qv(k) .gt. 2.0*qvmin ) then
5211 dum = aa*qv(k)
5212 qv(k) = qv(k) - dum
5213 dqv(k) = dqv(k) - dum/delt
5214 endif
5215 enddo
5216 else
5217 ! For testing purposes only (not yet found in any output):
5218 ! write(*,*) 'Full moisture conservation is impossible'
5219 endif
5220 endif
5222 return
5224 END SUBROUTINE moisture_check
5226 ! ==================================================================
5228 SUBROUTINE mynn_mix_chem(kts,kte,i, &
5229 delt,dz,pblh, &
5230 nchem, kdvel, ndvel, &
5231 chem1, vd1, &
5232 rho, &
5233 flt, tcd, qcd, &
5234 dfh, &
5235 s_aw, s_awchem, &
5236 emis_ant_no, frp, rrfs_sd, &
5237 enh_mix, smoke_dbg )
5239 !-------------------------------------------------------------------
5240 integer, intent(in) :: kts,kte,i
5241 real(kind_phys), dimension(kts:kte), intent(in) :: dfh,dz,tcd,qcd
5242 real(kind_phys), dimension(kts:kte), intent(inout) :: rho
5243 real(kind_phys), intent(in) :: flt
5244 real(kind_phys), intent(in) :: delt,pblh
5245 integer, intent(in) :: nchem, kdvel, ndvel
5246 real(kind_phys), dimension( kts:kte+1), intent(in) :: s_aw
5247 real(kind_phys), dimension( kts:kte, nchem ), intent(inout) :: chem1
5248 real(kind_phys), dimension( kts:kte+1,nchem), intent(in) :: s_awchem
5249 real(kind_phys), dimension( ndvel ), intent(in) :: vd1
5250 real(kind_phys), intent(in) :: emis_ant_no,frp
5251 logical, intent(in) :: rrfs_sd,enh_mix,smoke_dbg
5252 !local vars
5254 real(kind_phys), dimension(kts:kte) :: dtz
5255 real(kind_phys), dimension(kts:kte) :: a,b,c,d,x
5256 real(kind_phys):: rhs,dztop
5257 real(kind_phys):: t,dzk
5258 real(kind_phys):: hght
5259 real(kind_phys):: khdz_old, khdz_back
5260 integer :: k,kk,kmaxfire ! JLS 12/21/21
5261 integer :: ic ! Chemical array loop index
5263 integer, SAVE :: icall
5265 real(kind_phys), dimension(kts:kte) :: rhoinv
5266 real(kind_phys), dimension(kts:kte+1) :: rhoz,khdz
5267 real(kind_phys), parameter :: NO_threshold = 10.0 ! For anthropogenic sources
5268 real(kind_phys), parameter :: frp_threshold = 10.0 ! RAR 02/11/22: I increased the frp threshold to enhance mixing over big fires
5269 real(kind_phys), parameter :: pblh_threshold = 100.0
5271 dztop=.5*(dz(kte)+dz(kte-1))
5273 DO k=kts,kte
5274 dtz(k)=delt/dz(k)
5275 ENDDO
5277 !Prepare "constants" for diffusion equation.
5278 !khdz = rho*Kh/dz = rho*dfh
5279 rhoz(kts) =rho(kts)
5280 rhoinv(kts)=1./rho(kts)
5281 khdz(kts) =rhoz(kts)*dfh(kts)
5283 DO k=kts+1,kte
5284 rhoz(k) =(rho(k)*dz(k-1) + rho(k-1)*dz(k))/(dz(k-1)+dz(k))
5285 rhoz(k) = MAX(rhoz(k),1E-4)
5286 rhoinv(k)=1./MAX(rho(k),1E-4)
5287 dzk = 0.5 *( dz(k)+dz(k-1) )
5288 khdz(k) = rhoz(k)*dfh(k)
5289 ENDDO
5290 rhoz(kte+1)=rhoz(kte)
5291 khdz(kte+1)=rhoz(kte+1)*dfh(kte)
5293 !stability criteria for mf
5294 DO k=kts+1,kte-1
5295 khdz(k) = MAX(khdz(k), 0.5*s_aw(k))
5296 khdz(k) = MAX(khdz(k), -0.5*(s_aw(k)-s_aw(k+1)))
5297 ENDDO
5299 !Enhanced mixing over fires
5300 IF ( rrfs_sd .and. enh_mix ) THEN
5301 DO k=kts+1,kte-1
5302 khdz_old = khdz(k)
5303 khdz_back = pblh * 0.15 / dz(k)
5304 !Modify based on anthropogenic emissions of NO and FRP
5305 IF ( pblh < pblh_threshold ) THEN
5306 IF ( emis_ant_no > NO_threshold ) THEN
5307 khdz(k) = MAX(1.1*khdz(k),sqrt((emis_ant_no / NO_threshold)) / dz(k) * rhoz(k)) ! JLS 12/21/21
5308 ! khdz(k) = MAX(khdz(k),khdz_back)
5309 ENDIF
5310 IF ( frp > frp_threshold ) THEN
5311 kmaxfire = ceiling(log(frp))
5312 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
5313 ! khdz(k) = MAX(khdz(k),khdz_back)
5314 ENDIF
5315 ENDIF
5316 ENDDO
5317 ENDIF
5319 !============================================
5320 ! Patterned after mixing of water vapor in mynn_tendencies.
5321 !============================================
5323 DO ic = 1,nchem
5324 k=kts
5326 a(k)= -dtz(k)*khdz(k)*rhoinv(k)
5327 b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)
5328 c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)
5329 d(k)=chem1(k,ic) & !dtz(k)*flt !neglecting surface sources
5330 & - dtz(k)*vd1(ic)*chem1(k,ic) &
5331 & - dtz(k)*rhoinv(k)*s_awchem(k+1,ic)
5333 DO k=kts+1,kte-1
5334 a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)
5335 b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + &
5336 & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))
5337 c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)
5338 d(k)=chem1(k,ic) + dtz(k)*rhoinv(k)*(s_awchem(k,ic)-s_awchem(k+1,ic))
5339 ENDDO
5341 ! prescribed value at top
5342 a(kte)=0.
5343 b(kte)=1.
5344 c(kte)=0.
5345 d(kte)=chem1(kte,ic)
5347 CALL tridiag3(kte,a,b,c,d,x)
5349 DO k=kts,kte
5350 chem1(k,ic)=x(k)
5351 ENDDO
5352 ENDDO
5354 END SUBROUTINE mynn_mix_chem
5356 ! ==================================================================
5357 !>\ingroup gsd_mynn_edmf
5358 SUBROUTINE retrieve_exchange_coeffs(kts,kte,&
5359 &dfm,dfh,dz,K_m,K_h)
5361 !-------------------------------------------------------------------
5363 integer , intent(in) :: kts,kte
5365 real(kind_phys), dimension(KtS:KtE), intent(in) :: dz,dfm,dfh
5367 real(kind_phys), dimension(KtS:KtE), intent(out) :: K_m, K_h
5370 integer :: k
5371 real(kind_phys):: dzk
5373 K_m(kts)=0.
5374 K_h(kts)=0.
5376 DO k=kts+1,kte
5377 dzk = 0.5 *( dz(k)+dz(k-1) )
5378 K_m(k)=dfm(k)*dzk
5379 K_h(k)=dfh(k)*dzk
5380 ENDDO
5382 END SUBROUTINE retrieve_exchange_coeffs
5384 ! ==================================================================
5385 !>\ingroup gsd_mynn_edmf
5386 SUBROUTINE tridiag(n,a,b,c,d)
5388 !! to solve system of linear eqs on tridiagonal matrix n times n
5389 !! after Peaceman and Rachford, 1955
5390 !! a,b,c,d - are vectors of order n
5391 !! a,b,c - are coefficients on the LHS
5392 !! d - is initially RHS on the output becomes a solution vector
5394 !-------------------------------------------------------------------
5396 integer, intent(in):: n
5397 real(kind_phys), dimension(n), intent(in) :: a,b
5398 real(kind_phys), dimension(n), intent(inout) :: c,d
5400 integer :: i
5401 real(kind_phys):: p
5402 real(kind_phys), dimension(n) :: q
5404 c(n)=0.
5405 q(1)=-c(1)/b(1)
5406 d(1)=d(1)/b(1)
5408 DO i=2,n
5409 p=1./(b(i)+a(i)*q(i-1))
5410 q(i)=-c(i)*p
5411 d(i)=(d(i)-a(i)*d(i-1))*p
5412 ENDDO
5414 DO i=n-1,1,-1
5415 d(i)=d(i)+q(i)*d(i+1)
5416 ENDDO
5418 END SUBROUTINE tridiag
5420 ! ==================================================================
5421 !>\ingroup gsd_mynn_edmf
5422 subroutine tridiag2(n,a,b,c,d,x)
5423 implicit none
5424 ! a - sub-diagonal (means it is the diagonal below the main diagonal)
5425 ! b - the main diagonal
5426 ! c - sup-diagonal (means it is the diagonal above the main diagonal)
5427 ! d - right part
5428 ! x - the answer
5429 ! n - number of unknowns (levels)
5431 integer,intent(in) :: n
5432 real(kind_phys), dimension(n), intent(in) :: a,b,c,d
5433 real(kind_phys), dimension(n), intent(out):: x
5434 real(kind_phys), dimension(n) :: cp,dp
5435 real(kind_phys):: m
5436 integer :: i
5438 ! initialize c-prime and d-prime
5439 cp(1) = c(1)/b(1)
5440 dp(1) = d(1)/b(1)
5441 ! solve for vectors c-prime and d-prime
5442 do i = 2,n
5443 m = b(i)-cp(i-1)*a(i)
5444 cp(i) = c(i)/m
5445 dp(i) = (d(i)-dp(i-1)*a(i))/m
5446 enddo
5447 ! initialize x
5448 x(n) = dp(n)
5449 ! solve for x from the vectors c-prime and d-prime
5450 do i = n-1, 1, -1
5451 x(i) = dp(i)-cp(i)*x(i+1)
5452 end do
5454 end subroutine tridiag2
5455 ! ==================================================================
5456 !>\ingroup gsd_mynn_edmf
5457 subroutine tridiag3(kte,a,b,c,d,x)
5459 !ccccccccccccccccccccccccccccccc
5460 ! Aim: Inversion and resolution of a tridiagonal matrix
5461 ! A X = D
5462 ! Input:
5463 ! a(*) lower diagonal (Ai,i-1)
5464 ! b(*) principal diagonal (Ai,i)
5465 ! c(*) upper diagonal (Ai,i+1)
5466 ! d
5467 ! Output
5468 ! x results
5469 !ccccccccccccccccccccccccccccccc
5471 implicit none
5472 integer,intent(in) :: kte
5473 integer, parameter :: kts=1
5474 real(kind_phys), dimension(kte) :: a,b,c,d
5475 real(kind_phys), dimension(kte), intent(out) :: x
5476 integer :: in
5478 ! integer kms,kme,kts,kte,in
5479 ! real(kind_phys)a(kms:kme,3),c(kms:kme),x(kms:kme)
5481 do in=kte-1,kts,-1
5482 d(in)=d(in)-c(in)*d(in+1)/b(in+1)
5483 b(in)=b(in)-c(in)*a(in+1)/b(in+1)
5484 enddo
5486 do in=kts+1,kte
5487 d(in)=d(in)-a(in)*d(in-1)/b(in-1)
5488 enddo
5490 do in=kts,kte
5491 x(in)=d(in)/b(in)
5492 enddo
5494 return
5495 end subroutine tridiag3
5497 ! ==================================================================
5498 !>\ingroup gsd_mynn_edmf
5499 !! This subroutine calculates hybrid diagnotic boundary-layer height (PBLH).
5500 !!
5501 !! NOTES ON THE PBLH FORMULATION: The 1.5-theta-increase method defines
5502 !!PBL heights as the level at.
5503 !!which the potential temperature first exceeds the minimum potential.
5504 !!temperature within the boundary layer by 1.5 K. When applied to.
5505 !!observed temperatures, this method has been shown to produce PBL-
5506 !!height estimates that are unbiased relative to profiler-based.
5507 !!estimates (Nielsen-Gammon et al. 2008 \cite Nielsen_Gammon_2008).
5508 !! However, their study did not
5509 !!include LLJs. Banta and Pichugina (2008) \cite Pichugina_2008 show that a TKE-based.
5510 !!threshold is a good estimate of the PBL height in LLJs. Therefore,
5511 !!a hybrid definition is implemented that uses both methods, weighting
5512 !!the TKE-method more during stable conditions (PBLH < 400 m).
5513 !!A variable tke threshold (TKEeps) is used since no hard-wired
5514 !!value could be found to work best in all conditions.
5515 !>\section gen_get_pblh GSD get_pblh General Algorithm
5516 !> @{
5517 SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea,kzi)
5519 !---------------------------------------------------------------
5520 ! NOTES ON THE PBLH FORMULATION
5521 !
5522 !The 1.5-theta-increase method defines PBL heights as the level at
5523 !which the potential temperature first exceeds the minimum potential
5524 !temperature within the boundary layer by 1.5 K. When applied to
5525 !observed temperatures, this method has been shown to produce PBL-
5526 !height estimates that are unbiased relative to profiler-based
5527 !estimates (Nielsen-Gammon et al. 2008). However, their study did not
5528 !include LLJs. Banta and Pichugina (2008) show that a TKE-based
5529 !threshold is a good estimate of the PBL height in LLJs. Therefore,
5530 !a hybrid definition is implemented that uses both methods, weighting
5531 !the TKE-method more during stable conditions (PBLH < 400 m).
5532 !A variable tke threshold (TKEeps) is used since no hard-wired
5533 !value could be found to work best in all conditions.
5534 !---------------------------------------------------------------
5536 integer,intent(in) :: KTS,KTE
5538 #ifdef HARDCODE_VERTICAL
5539 # define kts 1
5540 # define kte HARDCODE_VERTICAL
5541 #endif
5543 real(kind_phys), intent(out) :: zi
5544 real(kind_phys), intent(in) :: landsea
5545 real(kind_phys), dimension(kts:kte), intent(in) :: thetav1D, qke1D, dz1D
5546 real(kind_phys), dimension(kts:kte+1), intent(in) :: zw1D
5547 !LOCAL VARS
5548 real(kind_phys):: PBLH_TKE,qtke,qtkem1,wt,maxqke,TKEeps,minthv
5549 real(kind_phys):: delt_thv !delta theta-v; dependent on land/sea point
5550 real(kind_phys), parameter :: sbl_lim = 200. !upper limit of stable BL height (m).
5551 real(kind_phys), parameter :: sbl_damp = 400. !transition length for blending (m).
5552 integer :: I,J,K,kthv,ktke,kzi
5554 !Initialize KPBL (kzi)
5555 kzi = 2
5557 !> - FIND MIN THETAV IN THE LOWEST 200 M AGL
5558 k = kts+1
5559 kthv = 1
5560 minthv = 9.E9
5561 DO WHILE (zw1D(k) .LE. 200.)
5562 !DO k=kts+1,kte-1
5563 IF (minthv > thetav1D(k)) then
5564 minthv = thetav1D(k)
5565 kthv = k
5566 ENDIF
5567 k = k+1
5568 !IF (zw1D(k) .GT. sbl_lim) exit
5569 ENDDO
5571 !> - FIND THETAV-BASED PBLH (BEST FOR DAYTIME).
5572 zi=0.
5573 k = kthv+1
5574 IF((landsea-1.5).GE.0)THEN
5575 ! WATER
5576 delt_thv = 1.0
5577 ELSE
5578 ! LAND
5579 delt_thv = 1.25
5580 ENDIF
5582 zi=0.
5583 k = kthv+1
5584 ! DO WHILE (zi .EQ. 0.)
5585 DO k=kts+1,kte-1
5586 IF (thetav1D(k) .GE. (minthv + delt_thv))THEN
5587 zi = zw1D(k) - dz1D(k-1)* &
5588 & MIN((thetav1D(k)-(minthv + delt_thv))/ &
5589 & MAX(thetav1D(k)-thetav1D(k-1),1E-6),1.0)
5590 ENDIF
5591 !k = k+1
5592 IF (k .EQ. kte-1) zi = zw1D(kts+1) !EXIT SAFEGUARD
5593 IF (zi .NE. 0.0) exit
5594 ENDDO
5595 !print*,"IN GET_PBLH:",thsfc,zi
5597 !> - FOR STABLE BOUNDARY LAYERS, USE TKE METHOD TO COMPLEMENT THE
5598 !! THETAV-BASED DEFINITION (WHEN THE THETA-V BASED PBLH IS BELOW ~0.5 KM).
5599 !!THE TANH WEIGHTING FUNCTION WILL MAKE THE TKE-BASED DEFINITION NEGLIGIBLE
5600 !!WHEN THE THETA-V-BASED DEFINITION IS ABOVE ~1 KM.
5601 ktke = 1
5602 maxqke = MAX(Qke1D(kts),0.)
5603 !Use 5% of tke max (Kosovic and Curry, 2000; JAS)
5604 !TKEeps = maxtke/20. = maxqke/40.
5605 TKEeps = maxqke/40.
5606 TKEeps = MAX(TKEeps,0.02) !0.025)
5607 PBLH_TKE=0.
5609 k = ktke+1
5610 ! DO WHILE (PBLH_TKE .EQ. 0.)
5611 DO k=kts+1,kte-1
5612 !QKE CAN BE NEGATIVE (IF CKmod == 0)... MAKE TKE NON-NEGATIVE.
5613 qtke =MAX(Qke1D(k)/2.,0.) ! maximum TKE
5614 qtkem1=MAX(Qke1D(k-1)/2.,0.)
5615 IF (qtke .LE. TKEeps) THEN
5616 PBLH_TKE = zw1D(k) - dz1D(k-1)* &
5617 & MIN((TKEeps-qtke)/MAX(qtkem1-qtke, 1E-6), 1.0)
5618 !IN CASE OF NEAR ZERO TKE, SET PBLH = LOWEST LEVEL.
5619 PBLH_TKE = MAX(PBLH_TKE,zw1D(kts+1))
5620 !print *,"PBLH_TKE:",i,PBLH_TKE, Qke1D(k)/2., zw1D(kts+1)
5621 ENDIF
5622 !k = k+1
5623 IF (k .EQ. kte-1) PBLH_TKE = zw1D(kts+1) !EXIT SAFEGUARD
5624 IF (PBLH_TKE .NE. 0.) exit
5625 ENDDO
5627 !> - With TKE advection turned on, the TKE-based PBLH can be very large
5628 !! in grid points with convective precipitation (> 8 km!),
5629 !! so an artificial limit is imposed to not let PBLH_TKE exceed the
5630 !!theta_v-based PBL height +/- 350 m.
5631 !!This has no impact on 98-99% of the domain, but is the simplest patch
5632 !!that adequately addresses these extremely large PBLHs.
5633 PBLH_TKE = MIN(PBLH_TKE,zi+350.)
5634 PBLH_TKE = MAX(PBLH_TKE,MAX(zi-350.,10.))
5636 wt=.5*TANH((zi - sbl_lim)/sbl_damp) + .5
5637 IF (maxqke <= 0.05) THEN
5638 !Cold pool situation - default to theta_v-based def
5639 ELSE
5640 !BLEND THE TWO PBLH TYPES HERE:
5641 zi=PBLH_TKE*(1.-wt) + zi*wt
5642 ENDIF
5644 !Compute KPBL (kzi)
5645 DO k=kts+1,kte-1
5646 IF ( zw1D(k) >= zi) THEN
5647 kzi = k-1
5648 exit
5649 ENDIF
5650 ENDDO
5652 #ifdef HARDCODE_VERTICAL
5653 # undef kts
5654 # undef kte
5655 #endif
5657 END SUBROUTINE GET_PBLH
5658 !> @}
5660 ! ==================================================================
5661 !>\ingroup gsd_mynn_edmf
5662 !! This subroutine is the Dynamic Multi-Plume (DMP) Mass-Flux Scheme.
5663 !!
5664 !! dmp_mf() calculates the nonlocal turbulent transport from the dynamic
5665 !! multiplume mass-flux scheme as well as the shallow-cumulus component of
5666 !! the subgrid clouds. Note that this mass-flux scheme is called when the
5667 !! namelist paramter \p bl_mynn_edmf is set to 1 (recommended).
5668 !!
5669 !! Much thanks to Kay Suslj of NASA-JPL for contributing the original version
5670 !! of this mass-flux scheme. Considerable changes have been made from it's
5671 !! original form. Some additions include:
5672 !! -# scale-aware tapering as dx -> 0
5673 !! -# transport of TKE (extra namelist option)
5674 !! -# Chaboureau-Bechtold cloud fraction & coupling to radiation (when icloud_bl > 0)
5675 !! -# some extra limits for numerical stability
5676 !!
5677 !! This scheme remains under development, so consider it experimental code.
5678 !!
5679 SUBROUTINE DMP_mf( &
5680 & kts,kte,dt,zw,dz,p,rho, &
5681 & momentum_opt, &
5682 & tke_opt, &
5683 & scalar_opt, &
5684 & u,v,w,th,thl,thv,tk, &
5685 & qt,qv,qc,qke, &
5686 & qnc,qni,qnwfa,qnifa,qnbca, &
5687 & exner,vt,vq,sgm, &
5688 & ust,flt,fltv,flq,flqv, &
5689 & pblh,kpbl,dx,landsea,ts, &
5690 ! outputs - updraft properties
5691 & edmf_a,edmf_w, &
5692 & edmf_qt,edmf_thl, &
5693 & edmf_ent,edmf_qc, &
5694 ! outputs - variables needed for solver
5695 & s_aw,s_awthl,s_awqt, &
5696 & s_awqv,s_awqc, &
5697 & s_awu,s_awv,s_awqke, &
5698 & s_awqnc,s_awqni, &
5699 & s_awqnwfa,s_awqnifa, &
5700 & s_awqnbca, &
5701 & sub_thl,sub_sqv, &
5702 & sub_u,sub_v, &
5703 & det_thl,det_sqv,det_sqc, &
5704 & det_u,det_v, &
5705 ! chem/smoke
5706 & nchem,chem1,s_awchem, &
5707 & mix_chem, &
5708 ! in/outputs - subgrid scale clouds
5709 & qc_bl1d,cldfra_bl1d, &
5710 & qc_bl1D_old,cldfra_bl1D_old, &
5711 ! inputs - flags for moist arrays
5712 & F_QC,F_QI, &
5713 & F_QNC,F_QNI, &
5714 & F_QNWFA,F_QNIFA,F_QNBCA, &
5715 & Psig_shcu, &
5716 ! output info
5717 & maxwidth,ktop,maxmf,ztop, &
5718 ! inputs for stochastic perturbations
5719 & spp_pbl,rstoch_col )
5721 ! inputs:
5722 integer, intent(in) :: KTS,KTE,KPBL,momentum_opt,tke_opt,scalar_opt
5724 #ifdef HARDCODE_VERTICAL
5725 # define kts 1
5726 # define kte HARDCODE_VERTICAL
5727 #endif
5729 ! Stochastic
5730 integer, intent(in) :: spp_pbl
5731 real(kind_phys), dimension(kts:kte) :: rstoch_col
5733 real(kind_phys),dimension(kts:kte), intent(in) :: &
5734 &U,V,W,TH,THL,TK,QT,QV,QC, &
5735 &exner,dz,THV,P,rho,qke,qnc,qni,qnwfa,qnifa,qnbca
5736 real(kind_phys),dimension(kts:kte+1), intent(in) :: zw !height at full-sigma
5737 real(kind_phys), intent(in) :: flt,fltv,flq,flqv,Psig_shcu, &
5738 &landsea,ts,dx,dt,ust,pblh
5739 logical, optional :: F_QC,F_QI,F_QNC,F_QNI,F_QNWFA,F_QNIFA,F_QNBCA
5741 ! outputs - updraft properties
5742 real(kind_phys),dimension(kts:kte), intent(out) :: edmf_a,edmf_w, &
5743 & edmf_qt,edmf_thl,edmf_ent,edmf_qc
5744 !add one local edmf variable:
5745 real(kind_phys),dimension(kts:kte) :: edmf_th
5746 ! output
5747 integer, intent(out) :: ktop
5748 real(kind_phys), intent(out) :: maxmf,ztop,maxwidth
5749 ! outputs - variables needed for solver
5750 real(kind_phys),dimension(kts:kte+1) :: s_aw, & !sum ai*rho*wis_awphi
5751 &s_awthl,s_awqt,s_awqv,s_awqc,s_awqnc,s_awqni, &
5752 &s_awqnwfa,s_awqnifa,s_awqnbca,s_awu,s_awv, &
5753 &s_awqke,s_aw2
5755 real(kind_phys),dimension(kts:kte), intent(inout) :: &
5756 &qc_bl1d,cldfra_bl1d,qc_bl1d_old,cldfra_bl1d_old
5758 integer, parameter :: nup=8, debug_mf=0
5759 real(kind_phys) :: nup2
5761 !------------- local variables -------------------
5762 ! updraft properties defined on interfaces (k=1 is the top of the
5763 ! first model layer
5764 real(kind_phys),dimension(kts:kte+1,1:NUP) :: &
5765 &UPW,UPTHL,UPQT,UPQC,UPQV, &
5766 &UPA,UPU,UPV,UPTHV,UPQKE,UPQNC, &
5767 &UPQNI,UPQNWFA,UPQNIFA,UPQNBCA
5768 ! entrainment variables
5769 real(kind_phys),dimension(kts:kte,1:NUP) :: ENT,ENTf
5770 integer,dimension(kts:kte,1:NUP) :: ENTi
5771 ! internal variables
5772 integer :: K,I,k50
5773 real(kind_phys):: fltv2,wstar,qstar,thstar,sigmaW,sigmaQT, &
5774 &sigmaTH,z0,pwmin,pwmax,wmin,wmax,wlv,Psig_w,maxw,maxqc,wpbl
5775 real(kind_phys):: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,QNCn,QNIn, &
5776 & QNWFAn,QNIFAn,QNBCAn, &
5777 & Wn2,Wn,EntEXP,EntEXM,EntW,BCOEFF,THVkm1,THVk,Pk,rho_int
5779 ! w parameters
5780 real(kind_phys), parameter :: &
5781 &Wa=2./3., &
5782 &Wb=0.002, &
5783 &Wc=1.5
5785 ! Lateral entrainment parameters ( L0=100 and ENT0=0.1) were taken from
5786 ! Suselj et al (2013, jas). Note that Suselj et al (2014,waf) use L0=200 and ENT0=0.2.
5787 real(kind_phys),parameter :: &
5788 & L0=100., &
5789 & ENT0=0.1
5791 ! Parameters/variables for regulating plumes:
5792 real(kind_phys), parameter :: Atot = 0.10 ! Maximum total fractional area of all updrafts
5793 real(kind_phys), parameter :: lmax = 1000.! diameter of largest plume (absolute maximum, can be smaller)
5794 real(kind_phys), parameter :: lmin = 300. ! diameter of smallest plume (absolute minimum, can be larger)
5795 real(kind_phys), parameter :: dlmin = 0. ! delta increase in the diameter of smallest plume (large fltv)
5796 real(kind_phys) :: minwidth ! actual width of smallest plume
5797 real(kind_phys) :: dl ! variable increment of plume size
5798 real(kind_phys), parameter :: dcut = 1.2 ! max diameter of plume to parameterize relative to dx (km)
5799 real(kind_phys):: d != -2.3 to -1.7 ;=-1.9 in Neggers paper; power law exponent for number density (N=Cl^d).
5800 ! Note that changing d to -2.0 makes each size plume equally contribute to the total coverage of all plumes.
5801 ! Note that changing d to -1.7 doubles the area coverage of the largest plumes relative to the smallest plumes.
5802 real(kind_phys):: cn,c,l,n,an2,hux,wspd_pbl,cloud_base,width_flx
5804 ! chem/smoke
5805 integer, intent(in) :: nchem
5806 real(kind_phys),dimension(:, :) :: chem1
5807 real(kind_phys),dimension(kts:kte+1, nchem) :: s_awchem
5808 real(kind_phys),dimension(nchem) :: chemn
5809 real(kind_phys),dimension(kts:kte+1,1:NUP, nchem) :: UPCHEM
5810 integer :: ic
5811 real(kind_phys),dimension(kts:kte+1, nchem) :: edmf_chem
5812 logical, intent(in) :: mix_chem
5814 !JOE: add declaration of ERF
5815 real(kind_phys):: ERF
5817 logical :: superadiabatic
5819 ! VARIABLES FOR CHABOUREAU-BECHTOLD CLOUD FRACTION
5820 real(kind_phys),dimension(kts:kte), intent(inout) :: vt, vq, sgm
5821 real(kind_phys):: sigq,xl,rsl,cpm,a,qmq,mf_cf,Aup,Q1,diffqt,qsat_tk,&
5822 Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9,satvp,rhgrid, &
5823 Ac_mf,Ac_strat,qc_mf
5824 real(kind_phys), parameter :: cf_thresh = 0.5 ! only overwrite stratus CF less than this value
5826 ! Variables for plume interpolation/saturation check
5827 real(kind_phys),dimension(kts:kte) :: exneri,dzi,rhoz
5828 real(kind_phys):: THp, QTp, QCp, QCs, esat, qsl
5829 real(kind_phys):: csigma,acfac,ac_wsp
5831 !plume overshoot
5832 integer :: overshoot
5833 real(kind_phys):: bvf, Frz, dzp
5835 !Flux limiter: not let mass-flux of heat between k=1&2 exceed (fluxportion)*(surface heat flux).
5836 !This limiter makes adjustments to the entire column.
5837 real(kind_phys):: adjustment, flx1, flt2
5838 real(kind_phys), parameter :: fluxportion=0.75 ! set liberally, so has minimal impact. Note that
5839 ! 0.5 starts to have a noticeable impact
5840 ! over land (decrease maxMF by 10-20%), but no impact over water.
5842 !Subsidence
5843 real(kind_phys),dimension(kts:kte) :: sub_thl,sub_sqv,sub_u,sub_v, & !tendencies due to subsidence
5844 det_thl,det_sqv,det_sqc,det_u,det_v, & !tendencied due to detrainment
5845 envm_a,envm_w,envm_thl,envm_sqv,envm_sqc, &
5846 envm_u,envm_v !environmental variables defined at middle of layer
5847 real(kind_phys),dimension(kts:kte+1) :: envi_a,envi_w !environmental variables defined at model interface
5848 real(kind_phys):: temp,sublim,qc_ent,qv_ent,qt_ent,thl_ent,detrate, &
5849 detrateUV,oow,exc_fac,aratio,detturb,qc_grid,qc_sgs, &
5850 qc_plume,exc_heat,exc_moist,tk_int,tvs
5851 real(kind_phys), parameter :: Cdet = 1./45.
5852 real(kind_phys), parameter :: dzpmax = 300. !limit dz used in detrainment - can be excessing in thick layers
5853 !parameter "Csub" determines the propotion of upward vertical velocity that contributes to
5854 !environmenatal subsidence. Some portion is expected to be compensated by downdrafts instead of
5855 !gentle environmental subsidence. 1.0 assumes all upward vertical velocity in the mass-flux scheme
5856 !is compensated by "gentle" environmental subsidence.
5857 real(kind_phys), parameter :: Csub=0.25
5859 !Factor for the pressure gradient effects on momentum transport
5860 real(kind_phys), parameter :: pgfac = 0.00 ! Zhang and Wu showed 0.4 is more appropriate for lower troposphere
5861 real(kind_phys):: Uk,Ukm1,Vk,Vkm1,dxsa
5863 ! check the inputs
5864 ! print *,'dt',dt
5865 ! print *,'dz',dz
5866 ! print *,'u',u
5867 ! print *,'v',v
5868 ! print *,'thl',thl
5869 ! print *,'qt',qt
5870 ! print *,'ust',ust
5871 ! print *,'flt',flt
5872 ! print *,'flq',flq
5873 ! print *,'pblh',pblh
5875 ! Initialize individual updraft properties
5876 UPW=0.
5877 UPTHL=0.
5878 UPTHV=0.
5879 UPQT=0.
5880 UPA=0.
5881 UPU=0.
5882 UPV=0.
5883 UPQC=0.
5884 UPQV=0.
5885 UPQKE=0.
5886 UPQNC=0.
5887 UPQNI=0.
5888 UPQNWFA=0.
5889 UPQNIFA=0.
5890 UPQNBCA=0.
5891 if ( mix_chem ) then
5892 UPCHEM(kts:kte+1,1:NUP,1:nchem)=0.0
5893 endif
5895 ENT=0.001
5896 ! Initialize mean updraft properties
5897 edmf_a =0.
5898 edmf_w =0.
5899 edmf_qt =0.
5900 edmf_thl=0.
5901 edmf_ent=0.
5902 edmf_qc =0.
5903 if ( mix_chem ) then
5904 edmf_chem(kts:kte+1,1:nchem) = 0.0
5905 endif
5907 ! Initialize the variables needed for implicit solver
5908 s_aw=0.
5909 s_awthl=0.
5910 s_awqt=0.
5911 s_awqv=0.
5912 s_awqc=0.
5913 s_awu=0.
5914 s_awv=0.
5915 s_awqke=0.
5916 s_awqnc=0.
5917 s_awqni=0.
5918 s_awqnwfa=0.
5919 s_awqnifa=0.
5920 s_awqnbca=0.
5921 if ( mix_chem ) then
5922 s_awchem(kts:kte+1,1:nchem) = 0.0
5923 endif
5925 ! Initialize explicit tendencies for subsidence & detrainment
5926 sub_thl = 0.
5927 sub_sqv = 0.
5928 sub_u = 0.
5929 sub_v = 0.
5930 det_thl = 0.
5931 det_sqv = 0.
5932 det_sqc = 0.
5933 det_u = 0.
5934 det_v = 0.
5935 nup2 = nup !start with nup, but set to zero if activation criteria fails
5937 ! Taper off MF scheme when significant resolved-scale motions
5938 ! are present This function needs to be asymetric...
5939 maxw = 0.0
5940 cloud_base = 9000.0
5941 do k=1,kte-1
5942 if (zw(k) > pblh + 500.) exit
5944 wpbl = w(k)
5945 if (w(k) < 0.)wpbl = 2.*w(k)
5946 maxw = max(maxw,abs(wpbl))
5948 !Find highest k-level below 50m AGL
5949 if (ZW(k)<=50.)k50=k
5951 !Search for cloud base
5952 qc_sgs = max(qc(k), qc_bl1d(k))
5953 if (qc_sgs> 1E-5 .and. (cldfra_bl1d(k) .ge. 0.5) .and. cloud_base == 9000.0) then
5954 cloud_base = 0.5*(ZW(k)+ZW(k+1))
5955 endif
5956 enddo
5958 !do nothing for small w (< 1 m/s), but linearly taper off for w > 1.0 m/s
5959 maxw = max(0.,maxw - 1.0)
5960 Psig_w = max(0.0, 1.0 - maxw)
5961 Psig_w = min(Psig_w, Psig_shcu)
5963 !Completely shut off MF scheme for strong resolved-scale vertical velocities.
5964 fltv2 = fltv
5965 if(Psig_w == 0.0 .and. fltv > 0.0) fltv2 = -1.*fltv
5967 ! If surface buoyancy is positive we do integration, otherwise no.
5968 ! Also, ensure that it is at least slightly superadiabatic up through 50 m
5969 superadiabatic = .false.
5970 if ((landsea-1.5).ge.0) then
5971 hux = -0.001 ! WATER ! dT/dz must be < - 0.1 K per 100 m.
5972 else
5973 hux = -0.005 ! LAND ! dT/dz must be < - 0.5 K per 100 m.
5974 endif
5975 tvs = ts*(1.0+p608*qv(kts))
5976 do k=1,max(1,k50-1) !use "-1" because k50 used interface heights (zw).
5977 if (k == 1) then
5978 if ((thv(k)-tvs)/(0.5*dz(k)) < hux) then
5979 superadiabatic = .true.
5980 else
5981 superadiabatic = .false.
5982 exit
5983 endif
5984 else
5985 if ((thv(k)-thv(k-1))/(0.5*(dz(k)+dz(k-1))) < hux) then
5986 superadiabatic = .true.
5987 else
5988 superadiabatic = .false.
5989 exit
5990 endif
5991 endif
5992 enddo
5994 ! Determine the numer of updrafts/plumes in the grid column:
5995 ! Some of these criteria may be a little redundant but useful for bullet-proofing.
5996 ! (1) largest plume = 1.2 * dx.
5997 ! (2) Apply a scale-break, assuming no plumes with diameter larger than 1.1*PBLH can exist.
5998 ! (3) max plume size beneath clouds deck approx = 0.5 * cloud_base.
5999 ! (4) add wspd-dependent limit, when plume model breaks down. (hurricanes)
6000 ! (5) limit to reduce max plume sizes in weakly forced conditions. This is only
6001 ! meant to "soften" the activation of the mass-flux scheme.
6002 ! Criteria (1)
6003 maxwidth = min(dx*dcut, lmax)
6004 !Criteria (2)
6005 maxwidth = min(maxwidth, 1.1_kind_phys*PBLH)
6006 ! Criteria (3)
6007 if ((landsea-1.5) .lt. 0) then !land
6008 maxwidth = MIN(maxwidth, 0.5_kind_phys*cloud_base)
6009 else !water
6010 maxwidth = MIN(maxwidth, 0.9_kind_phys*cloud_base)
6011 endif
6012 ! Criteria (4)
6013 wspd_pbl=SQRT(MAX(u(kts)**2 + v(kts)**2, 0.01_kind_phys))
6014 !Note: area fraction (acfac) is modified below
6015 ! Criteria (5) - only a function of flt (not fltv)
6016 if ((landsea-1.5).LT.0) then !land
6017 width_flx = MAX(MIN(1000.*(0.6*tanh((fltv - 0.040)/0.04) + .5),1000._kind_phys), 0._kind_phys)
6018 else !water
6019 width_flx = MAX(MIN(1000.*(0.6*tanh((fltv - 0.007)/0.02) + .5),1000._kind_phys), 0._kind_phys)
6020 endif
6021 maxwidth = MIN(maxwidth, width_flx)
6022 minwidth = lmin
6023 !allow min plume size to increase in large flux conditions (eddy diffusivity should be
6024 !large enough to handle the representation of small plumes).
6025 if (maxwidth .ge. (lmax - 1.0) .and. fltv .gt. 0.2)minwidth = lmin + dlmin*min((fltv-0.2)/0.3, 1._kind_phys)
6027 if (maxwidth .le. minwidth) then ! deactivate MF component
6028 nup2 = 0
6029 maxwidth = 0.0
6030 endif
6032 ! Initialize values for 2d output fields:
6033 ktop = 0
6034 ztop = 0.0
6035 maxmf= 0.0
6037 !Begin plume processing if passes criteria
6038 if ( fltv2 > 0.002 .AND. (maxwidth > minwidth) .AND. superadiabatic) then
6040 ! Find coef C for number size density N
6041 cn = 0.
6042 d =-1.9 !set d to value suggested by Neggers 2015 (JAMES).
6043 dl = (maxwidth - minwidth)/real(nup-1,kind=kind_phys)
6044 do i=1,NUP
6045 ! diameter of plume
6046 l = minwidth + dl*real(i-1)
6047 cn = cn + l**d * (l*l)/(dx*dx) * dl ! sum fractional area of each plume
6048 enddo
6049 C = Atot/cn !Normalize C according to the defined total fraction (Atot)
6051 ! Make updraft area (UPA) a function of the buoyancy flux
6052 acfac = .5*tanh((fltv2 - 0.02)/0.05) + .5
6054 !add a windspeed-dependent adjustment to acfac that tapers off
6055 !the mass-flux scheme linearly above sfc wind speeds of 10 m/s.
6056 !Note: this effect may be better represented by an increase in
6057 !entrainment rate for high wind consitions (more ambient turbulence).
6058 if (wspd_pbl .le. 10.) then
6059 ac_wsp = 1.0
6060 else
6061 ac_wsp = 1.0 - min((wspd_pbl - 10.0)/15., 1.0)
6062 endif
6063 acfac = acfac * ac_wsp
6065 ! Find the portion of the total fraction (Atot) of each plume size:
6066 An2 = 0.
6067 do i=1,NUP
6068 ! diameter of plume
6069 l = minwidth + dl*real(i-1)
6070 N = C*l**d ! number density of plume n
6071 UPA(1,i) = N*l*l/(dx*dx) * dl ! fractional area of plume n
6073 UPA(1,i) = UPA(1,i)*acfac
6074 An2 = An2 + UPA(1,i) ! total fractional area of all plumes
6075 !print*," plume size=",l,"; area=",UPA(1,I),"; total=",An2
6076 end do
6078 ! set initial conditions for updrafts
6079 z0=50.
6080 pwmin=0.1 ! was 0.5
6081 pwmax=0.4 ! was 3.0
6083 wstar=max(1.E-2,(gtr*fltv2*pblh)**(onethird))
6084 qstar=max(flq,1.0E-5)/wstar
6085 thstar=flt/wstar
6087 if ((landsea-1.5) .ge. 0) then
6088 csigma = 1.34 ! WATER
6089 else
6090 csigma = 1.34 ! LAND
6091 endif
6093 if (env_subs) then
6094 exc_fac = 0.0
6095 else
6096 if ((landsea-1.5).GE.0) then
6097 !water: increase factor to compensate for decreased pwmin/pwmax
6098 exc_fac = 0.58*4.0
6099 else
6100 !land: no need to increase factor - already sufficiently large superadiabatic layers
6101 exc_fac = 0.58
6102 endif
6103 endif
6104 !decrease excess for large wind speeds
6105 exc_fac = exc_fac * ac_wsp
6107 !Note: sigmaW is typically about 0.5*wstar
6108 sigmaW =csigma*wstar*(z0/pblh)**(onethird)*(1 - 0.8*z0/pblh)
6109 sigmaQT=csigma*qstar*(z0/pblh)**(onethird)
6110 sigmaTH=csigma*thstar*(z0/pblh)**(onethird)
6112 !Note: Given the pwmin & pwmax set above, these max/mins are
6113 ! rarely exceeded.
6114 wmin=MIN(sigmaW*pwmin,0.1)
6115 wmax=MIN(sigmaW*pwmax,0.5)
6117 !SPECIFY SURFACE UPDRAFT PROPERTIES AT MODEL INTERFACE BETWEEN K = 1 & 2
6118 do i=1,NUP
6119 wlv=wmin+(wmax-wmin)/NUP2*(i-1)
6121 !SURFACE UPDRAFT VERTICAL VELOCITY
6122 UPW(1,I)=wmin + real(i)/real(NUP)*(wmax-wmin)
6123 UPU(1,I)=(U(KTS)*DZ(KTS+1)+U(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))
6124 UPV(1,I)=(V(KTS)*DZ(KTS+1)+V(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))
6125 UPQC(1,I)=0.0
6126 !UPQC(1,I)=(QC(KTS)*DZ(KTS+1)+QC(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))
6128 exc_heat = exc_fac*UPW(1,I)*sigmaTH/sigmaW
6129 UPTHV(1,I)=(THV(KTS)*DZ(KTS+1)+THV(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) &
6130 & + exc_heat
6131 UPTHL(1,I)=(THL(KTS)*DZ(KTS+1)+THL(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) &
6132 & + exc_heat
6134 !calculate exc_moist by use of surface fluxes
6135 exc_moist=exc_fac*UPW(1,I)*sigmaQT/sigmaW
6136 UPQT(1,I)=(QT(KTS)*DZ(KTS+1)+QT(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))&
6137 & +exc_moist
6139 UPQKE(1,I)=(QKE(KTS)*DZ(KTS+1)+QKE(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))
6140 UPQNC(1,I)=(QNC(KTS)*DZ(KTS+1)+QNC(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))
6141 UPQNI(1,I)=(QNI(KTS)*DZ(KTS+1)+QNI(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))
6142 UPQNWFA(1,I)=(QNWFA(KTS)*DZ(KTS+1)+QNWFA(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))
6143 UPQNIFA(1,I)=(QNIFA(KTS)*DZ(KTS+1)+QNIFA(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))
6144 UPQNBCA(1,I)=(QNBCA(KTS)*DZ(KTS+1)+QNBCA(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))
6145 enddo
6147 if ( mix_chem ) then
6148 do i=1,NUP
6149 do ic = 1,nchem
6150 UPCHEM(1,i,ic)=(chem1(KTS,ic)*DZ(KTS+1)+chem1(KTS+1,ic)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))
6151 enddo
6152 enddo
6153 endif
6155 !Initialize environmental variables which can be modified by detrainment
6156 envm_thl(kts:kte)=THL(kts:kte)
6157 envm_sqv(kts:kte)=QV(kts:kte)
6158 envm_sqc(kts:kte)=QC(kts:kte)
6159 envm_u(kts:kte)=U(kts:kte)
6160 envm_v(kts:kte)=V(kts:kte)
6161 do k=kts,kte-1
6162 rhoz(k) = (rho(k)*dz(k+1)+rho(k+1)*dz(k))/(dz(k+1)+dz(k))
6163 enddo
6164 rhoz(kte) = rho(kte)
6166 !dxsa is scale-adaptive factor governing the pressure-gradient term of the momentum transport
6167 dxsa = 1. - MIN(MAX((12000.0-dx)/(12000.0-3000.0), 0.), 1.)
6169 ! do integration updraft
6170 do i=1,NUP
6171 QCn = 0.
6172 overshoot = 0
6173 l = minwidth + dl*real(i-1) ! diameter of plume
6174 do k=kts+1,kte-1
6175 !Entrainment from Tian and Kuang (2016)
6176 !ENT(k,i) = 0.35/(MIN(MAX(UPW(K-1,I),0.75),1.9)*l)
6177 wmin = 0.3 + l*0.0005 !* MAX(pblh-ZW(k+1), 0.0)/pblh
6178 ENT(k,i) = 0.33/(MIN(MAX(UPW(K-1,I),wmin),0.9)*l)
6180 !Entrainment from Negggers (2015, JAMES)
6181 !ENT(k,i) = 0.02*l**-0.35 - 0.0009
6182 !ENT(k,i) = 0.04*l**-0.50 - 0.0009 !more plume diversity
6183 !ENT(k,i) = 0.04*l**-0.495 - 0.0009 !"neg1+"
6185 !Minimum background entrainment
6186 ENT(k,i) = max(ENT(k,i),0.0003)
6187 !ENT(k,i) = max(ENT(k,i),0.05/ZW(k)) !not needed for Tian and Kuang
6189 !increase entrainment for plumes extending very high.
6190 IF(ZW(k) >= MIN(pblh+1500., 4000.))THEN
6191 ENT(k,i)=ENT(k,i) + (ZW(k)-MIN(pblh+1500.,4000.))*5.0E-6
6192 ENDIF
6194 !SPP
6195 ENT(k,i) = ENT(k,i) * (1.0 - rstoch_col(k))
6197 ENT(k,i) = min(ENT(k,i),0.9/(ZW(k+1)-ZW(k)))
6199 ! Define environment U & V at the model interface levels
6200 Uk =(U(k)*DZ(k+1)+U(k+1)*DZ(k))/(DZ(k+1)+DZ(k))
6201 Ukm1=(U(k-1)*DZ(k)+U(k)*DZ(k-1))/(DZ(k-1)+DZ(k))
6202 Vk =(V(k)*DZ(k+1)+V(k+1)*DZ(k))/(DZ(k+1)+DZ(k))
6203 Vkm1=(V(k-1)*DZ(k)+V(k)*DZ(k-1))/(DZ(k-1)+DZ(k))
6205 ! Linear entrainment:
6206 EntExp= ENT(K,I)*(ZW(k+1)-ZW(k))
6207 EntExm= EntExp*0.3333 !reduce entrainment for momentum
6208 QTn =UPQT(k-1,I) *(1.-EntExp) + QT(k)*EntExp
6209 THLn=UPTHL(k-1,I)*(1.-EntExp) + THL(k)*EntExp
6210 Un =UPU(k-1,I) *(1.-EntExm) + U(k)*EntExm + dxsa*pgfac*(Uk - Ukm1)
6211 Vn =UPV(k-1,I) *(1.-EntExm) + V(k)*EntExm + dxsa*pgfac*(Vk - Vkm1)
6212 QKEn=UPQKE(k-1,I)*(1.-EntExp) + QKE(k)*EntExp
6213 QNCn=UPQNC(k-1,I)*(1.-EntExp) + QNC(k)*EntExp
6214 QNIn=UPQNI(k-1,I)*(1.-EntExp) + QNI(k)*EntExp
6215 QNWFAn=UPQNWFA(k-1,I)*(1.-EntExp) + QNWFA(k)*EntExp
6216 QNIFAn=UPQNIFA(k-1,I)*(1.-EntExp) + QNIFA(k)*EntExp
6217 QNBCAn=UPQNBCA(k-1,I)*(1.-EntExp) + QNBCA(k)*EntExp
6219 !capture the updated qc, qt & thl modified by entranment alone,
6220 !since they will be modified later if condensation occurs.
6221 qc_ent = QCn
6222 qt_ent = QTn
6223 thl_ent = THLn
6225 ! Exponential Entrainment:
6226 !EntExp= exp(-ENT(K,I)*(ZW(k)-ZW(k-1)))
6227 !QTn =QT(K) *(1-EntExp)+UPQT(K-1,I)*EntExp
6228 !THLn=THL(K)*(1-EntExp)+UPTHL(K-1,I)*EntExp
6229 !Un =U(K) *(1-EntExp)+UPU(K-1,I)*EntExp
6230 !Vn =V(K) *(1-EntExp)+UPV(K-1,I)*EntExp
6231 !QKEn=QKE(k)*(1-EntExp)+UPQKE(K-1,I)*EntExp
6233 if ( mix_chem ) then
6234 do ic = 1,nchem
6235 ! Exponential Entrainment:
6236 !chemn(ic) = chem(k,ic)*(1-EntExp)+UPCHEM(K-1,I,ic)*EntExp
6237 ! Linear entrainment:
6238 chemn(ic)=UPCHEM(k-1,i,ic)*(1.-EntExp) + chem1(k,ic)*EntExp
6239 enddo
6240 endif
6242 ! Define pressure at model interface
6243 Pk =(P(k)*DZ(k+1)+P(k+1)*DZ(k))/(DZ(k+1)+DZ(k))
6244 ! Compute plume properties thvn and qcn
6245 call condensation_edmf(QTn,THLn,Pk,ZW(k+1),THVn,QCn)
6247 ! Define environment THV at the model interface levels
6248 THVk =(THV(k)*DZ(k+1)+THV(k+1)*DZ(k))/(DZ(k+1)+DZ(k))
6249 THVkm1=(THV(k-1)*DZ(k)+THV(k)*DZ(k-1))/(DZ(k-1)+DZ(k))
6251 ! B=g*(0.5*(THVn+UPTHV(k-1,I))/THV(k-1) - 1.0)
6252 B=grav*(THVn/THVk - 1.0)
6253 IF(B>0.)THEN
6254 BCOEFF = 0.15 !w typically stays < 2.5, so doesnt hit the limits nearly as much
6255 ELSE
6256 BCOEFF = 0.2 !0.33
6257 ENDIF
6259 ! Original StEM with exponential entrainment
6260 !EntW=exp(-2.*(Wb+Wc*ENT(K,I))*(ZW(k)-ZW(k-1)))
6261 !Wn2=UPW(K-1,I)**2*EntW + (1.-EntW)*0.5*Wa*B/(Wb+Wc*ENT(K,I))
6262 ! Original StEM with linear entrainment
6263 !Wn2=UPW(K-1,I)**2*(1.-EntExp) + EntExp*0.5*Wa*B/(Wb+Wc*ENT(K,I))
6264 !Wn2=MAX(Wn2,0.0)
6265 !WA: TEMF form
6266 ! IF (B>0.0 .AND. UPW(K-1,I) < 0.2 ) THEN
6267 IF (UPW(K-1,I) < 0.2 ) THEN
6268 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.)
6269 ELSE
6270 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.)
6271 ENDIF
6272 !Do not allow a parcel to accelerate more than 1.25 m/s over 200 m.
6273 !Add max increase of 2.0 m/s for coarse vertical resolution.
6274 IF(Wn > UPW(K-1,I) + MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0) ) THEN
6275 Wn = UPW(K-1,I) + MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0)
6276 ENDIF
6277 !Add symmetrical max decrease in w
6278 IF(Wn < UPW(K-1,I) - MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0) ) THEN
6279 Wn = UPW(K-1,I) - MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0)
6280 ENDIF
6281 Wn = MIN(MAX(Wn,0.0), 3.0)
6283 !Check to make sure that the plume made it up at least one level.
6284 !if it failed, then set nup2=0 and exit the mass-flux portion.
6285 IF (k==kts+1 .AND. Wn == 0.) THEN
6286 NUP2=0
6287 exit
6288 ENDIF
6290 IF (debug_mf == 1) THEN
6291 IF (Wn .GE. 3.0) THEN
6292 ! surface values
6293 print *," **** SUSPICIOUSLY LARGE W:"
6294 print *,' QCn:',QCn,' ENT=',ENT(k,i),' Nup2=',Nup2
6295 print *,'pblh:',pblh,' Wn:',Wn,' UPW(k-1)=',UPW(K-1,I)
6296 print *,'K=',k,' B=',B,' dz=',ZW(k)-ZW(k-1)
6297 ENDIF
6298 ENDIF
6300 !Allow strongly forced plumes to overshoot if KE is sufficient
6301 IF (Wn <= 0.0 .AND. overshoot == 0) THEN
6302 overshoot = 1
6303 IF ( THVk-THVkm1 .GT. 0.0 ) THEN
6304 bvf = SQRT( gtr*(THVk-THVkm1)/dz(k) )
6305 !vertical Froude number
6306 Frz = UPW(K-1,I)/(bvf*dz(k))
6307 !IF ( Frz >= 0.5 ) Wn = MIN(Frz,1.0)*UPW(K-1,I)
6308 dzp = dz(k)*MAX(MIN(Frz,1.0),0.0) ! portion of highest layer the plume penetrates
6309 ENDIF
6310 ELSE
6311 dzp = dz(k)
6312 ENDIF
6314 !minimize the plume penetratration in stratocu-topped PBL
6315 !IF (fltv2 < 0.06) THEN
6316 ! IF(ZW(k+1) >= pblh-200. .AND. qc(k) > 1e-5 .AND. I > 4) Wn=0.
6317 !ENDIF
6319 !Modify environment variables (representative of the model layer - envm*)
6320 !following the updraft dynamical detrainment of Asai and Kasahara (1967, JAS).
6321 !Reminder: w is limited to be non-negative (above)
6322 aratio = MIN(UPA(K-1,I)/(1.-UPA(K-1,I)), 0.5) !limit should never get hit
6323 detturb = 0.00008
6324 oow = -0.060/MAX(1.0,(0.5*(Wn+UPW(K-1,I)))) !coef for dynamical detrainment rate
6325 detrate = MIN(MAX(oow*(Wn-UPW(K-1,I))/dz(k), detturb), .0002) ! dynamical detrainment rate (m^-1)
6326 detrateUV= MIN(MAX(oow*(Wn-UPW(K-1,I))/dz(k), detturb), .0001) ! dynamical detrainment rate (m^-1)
6327 envm_thl(k)=envm_thl(k) + (0.5*(thl_ent + UPTHL(K-1,I)) - thl(k))*detrate*aratio*MIN(dzp,dzpmax)
6328 qv_ent = 0.5*(MAX(qt_ent-qc_ent,0.) + MAX(UPQT(K-1,I)-UPQC(K-1,I),0.))
6329 envm_sqv(k)=envm_sqv(k) + (qv_ent-QV(K))*detrate*aratio*MIN(dzp,dzpmax)
6330 IF (UPQC(K-1,I) > 1E-8) THEN
6331 IF (QC(K) > 1E-6) THEN
6332 qc_grid = QC(K)
6333 ELSE
6334 qc_grid = cldfra_bl1d(k)*qc_bl1d(K)
6335 ENDIF
6336 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)
6337 ENDIF
6338 envm_u(k) =envm_u(k) + (0.5*(Un + UPU(K-1,I)) - U(K))*detrateUV*aratio*MIN(dzp,dzpmax)
6339 envm_v(k) =envm_v(k) + (0.5*(Vn + UPV(K-1,I)) - V(K))*detrateUV*aratio*MIN(dzp,dzpmax)
6341 IF (Wn > 0.) THEN
6342 !Update plume variables at current k index
6343 UPW(K,I)=Wn !sqrt(Wn2)
6344 UPTHV(K,I)=THVn
6345 UPTHL(K,I)=THLn
6346 UPQT(K,I)=QTn
6347 UPQC(K,I)=QCn
6348 UPU(K,I)=Un
6349 UPV(K,I)=Vn
6350 UPQKE(K,I)=QKEn
6351 UPQNC(K,I)=QNCn
6352 UPQNI(K,I)=QNIn
6353 UPQNWFA(K,I)=QNWFAn
6354 UPQNIFA(K,I)=QNIFAn
6355 UPQNBCA(K,I)=QNBCAn
6356 UPA(K,I)=UPA(K-1,I)
6357 IF ( mix_chem ) THEN
6358 do ic = 1,nchem
6359 UPCHEM(k,I,ic) = chemn(ic)
6360 enddo
6361 ENDIF
6362 ktop = MAX(ktop,k)
6363 ELSE
6364 exit !exit k-loop
6365 END IF
6366 ENDDO
6368 IF (debug_mf == 1) THEN
6369 IF (MAXVAL(UPW(:,I)) > 10.0 .OR. MINVAL(UPA(:,I)) < 0.0 .OR. &
6370 MAXVAL(UPA(:,I)) > Atot .OR. NUP2 > 10) THEN
6371 ! surface values
6372 print *,'flq:',flq,' fltv:',fltv2,' Nup2=',Nup2
6373 print *,'pblh:',pblh,' wstar:',wstar,' ktop=',ktop
6374 print *,'sigmaW=',sigmaW,' sigmaTH=',sigmaTH,' sigmaQT=',sigmaQT
6375 ! means
6376 print *,'u:',u
6377 print *,'v:',v
6378 print *,'thl:',thl
6379 print *,'UPA:',UPA(:,I)
6380 print *,'UPW:',UPW(:,I)
6381 print *,'UPTHL:',UPTHL(:,I)
6382 print *,'UPQT:',UPQT(:,I)
6383 print *,'ENT:',ENT(:,I)
6384 ENDIF
6385 ENDIF
6386 ENDDO
6387 ELSE
6388 !At least one of the conditions was not met for activating the MF scheme.
6389 NUP2=0.
6390 END IF !end criteria check for mass-flux scheme
6392 ktop=MIN(ktop,KTE-1)
6393 IF (ktop == 0) THEN
6394 ztop = 0.0
6395 ELSE
6396 ztop=zw(ktop)
6397 ENDIF
6399 IF (nup2 > 0) THEN
6400 !Calculate the fluxes for each variable
6401 !All s_aw* variable are == 0 at k=1
6402 DO i=1,NUP
6403 DO k=KTS,KTE-1
6404 s_aw(k+1) = s_aw(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*Psig_w
6405 s_awthl(k+1)= s_awthl(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPTHL(K,i)*Psig_w
6406 s_awqt(k+1) = s_awqt(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQT(K,i)*Psig_w
6407 !to conform to grid mean properties, move qc to qv in grid mean
6408 !saturated layers, so total water fluxes are preserved but
6409 !negative qc fluxes in unsaturated layers is reduced.
6410 ! if (qc(k) > 1e-12 .or. qc(k+1) > 1e-12) then
6411 qc_plume = UPQC(K,i)
6412 ! else
6413 ! qc_plume = 0.0
6414 ! endif
6415 s_awqc(k+1) = s_awqc(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*qc_plume*Psig_w
6416 s_awqv(k+1) = s_awqt(k+1) - s_awqc(k+1)
6417 ENDDO
6418 ENDDO
6419 !momentum
6420 if (momentum_opt > 0) then
6421 do i=1,nup
6422 do k=kts,kte-1
6423 s_awu(k+1) = s_awu(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPU(K,i)*Psig_w
6424 s_awv(k+1) = s_awv(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPV(K,i)*Psig_w
6425 enddo
6426 enddo
6427 endif
6428 !tke
6429 if (tke_opt > 0) then
6430 do i=1,nup
6431 do k=kts,kte-1
6432 s_awqke(k+1)= s_awqke(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQKE(K,i)*Psig_w
6433 enddo
6434 enddo
6435 endif
6436 !chem
6437 if ( mix_chem ) then
6438 do k=kts,kte
6439 do i=1,nup
6440 do ic = 1,nchem
6441 s_awchem(k+1,ic) = s_awchem(k+1,ic) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPCHEM(K,i,ic)*Psig_w
6442 enddo
6443 enddo
6444 enddo
6445 endif
6447 if (scalar_opt > 0) then
6448 do k=kts,kte
6449 do I=1,nup
6450 s_awqnc(k+1) = s_awqnc(K+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQNC(K,i)*Psig_w
6451 s_awqni(k+1) = s_awqni(K+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQNI(K,i)*Psig_w
6452 s_awqnwfa(k+1)= s_awqnwfa(K+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQNWFA(K,i)*Psig_w
6453 s_awqnifa(k+1)= s_awqnifa(K+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQNIFA(K,i)*Psig_w
6454 s_awqnbca(k+1)= s_awqnbca(K+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQNBCA(K,i)*Psig_w
6455 enddo
6456 enddo
6457 endif
6459 !Flux limiter: Check ratio of heat flux at top of first model layer
6460 !and at the surface. Make sure estimated flux out of the top of the
6461 !layer is < fluxportion*surface_heat_flux
6462 IF (s_aw(kts+1) /= 0.) THEN
6463 dzi(kts) = 0.5*(DZ(kts)+DZ(kts+1)) !dz centered at model interface
6464 flx1 = MAX(s_aw(kts+1)*(TH(kts)-TH(kts+1))/dzi(kts),1.0e-5)
6465 ELSE
6466 flx1 = 0.0
6467 !print*,"ERROR: s_aw(kts+1) == 0, NUP=",NUP," NUP2=",NUP2,&
6468 ! " superadiabatic=",superadiabatic," KTOP=",KTOP
6469 ENDIF
6470 adjustment=1.0
6471 flt2=max(flt,0.0) !need because activation is now based on fltv, not flt
6472 !Print*,"Flux limiter in MYNN-EDMF, adjustment=",fluxportion*flt/dz(kts)/flx1
6473 !Print*,"flt/dz=",flt/dz(kts)," flx1=",flx1," s_aw(kts+1)=",s_aw(kts+1)
6474 IF (flx1 > fluxportion*flt2/dz(kts) .AND. flx1>0.0) THEN
6475 adjustment= fluxportion*flt2/dz(kts)/flx1
6476 s_aw = s_aw*adjustment
6477 s_awthl = s_awthl*adjustment
6478 s_awqt = s_awqt*adjustment
6479 s_awqc = s_awqc*adjustment
6480 s_awqv = s_awqv*adjustment
6481 s_awqnc = s_awqnc*adjustment
6482 s_awqni = s_awqni*adjustment
6483 s_awqnwfa = s_awqnwfa*adjustment
6484 s_awqnifa = s_awqnifa*adjustment
6485 s_awqnbca = s_awqnbca*adjustment
6486 IF (momentum_opt > 0) THEN
6487 s_awu = s_awu*adjustment
6488 s_awv = s_awv*adjustment
6489 ENDIF
6490 IF (tke_opt > 0) THEN
6491 s_awqke= s_awqke*adjustment
6492 ENDIF
6493 IF ( mix_chem ) THEN
6494 s_awchem = s_awchem*adjustment
6495 ENDIF
6496 UPA = UPA*adjustment
6497 ENDIF
6498 !Print*,"adjustment=",adjustment," fluxportion=",fluxportion," flt=",flt
6500 !Calculate mean updraft properties for output:
6501 !all edmf_* variables at k=1 correspond to the interface at top of first model layer
6502 do k=kts,kte-1
6503 do I=1,nup
6504 edmf_a(K) =edmf_a(K) +UPA(K,i)
6505 edmf_w(K) =edmf_w(K) +UPA(K,i)*UPW(K,i)
6506 edmf_qt(K) =edmf_qt(K) +UPA(K,i)*UPQT(K,i)
6507 edmf_thl(K)=edmf_thl(K)+UPA(K,i)*UPTHL(K,i)
6508 edmf_ent(K)=edmf_ent(K)+UPA(K,i)*ENT(K,i)
6509 edmf_qc(K) =edmf_qc(K) +UPA(K,i)*UPQC(K,i)
6510 enddo
6511 enddo
6512 do k=kts,kte-1
6513 !Note that only edmf_a is multiplied by Psig_w. This takes care of the
6514 !scale-awareness of the subsidence below:
6515 if (edmf_a(k)>0.) then
6516 edmf_w(k)=edmf_w(k)/edmf_a(k)
6517 edmf_qt(k)=edmf_qt(k)/edmf_a(k)
6518 edmf_thl(k)=edmf_thl(k)/edmf_a(k)
6519 edmf_ent(k)=edmf_ent(k)/edmf_a(k)
6520 edmf_qc(k)=edmf_qc(k)/edmf_a(k)
6521 edmf_a(k)=edmf_a(k)*Psig_w
6522 !FIND MAXIMUM MASS-FLUX IN THE COLUMN:
6523 if(edmf_a(k)*edmf_w(k) > maxmf) maxmf = edmf_a(k)*edmf_w(k)
6524 endif
6525 enddo ! end k
6527 !smoke/chem
6528 if ( mix_chem ) then
6529 do k=kts,kte-1
6530 do I=1,nup
6531 do ic = 1,nchem
6532 edmf_chem(k,ic) = edmf_chem(k,ic) + rhoz(k)*UPA(K,I)*UPCHEM(k,i,ic)
6533 enddo
6534 enddo
6535 enddo
6536 do k=kts,kte-1
6537 if (edmf_a(k)>0.) then
6538 do ic = 1,nchem
6539 edmf_chem(k,ic) = edmf_chem(k,ic)/edmf_a(k)
6540 enddo
6541 endif
6542 enddo ! end k
6543 endif
6545 !Calculate the effects environmental subsidence.
6546 !All envi_*variables are valid at the interfaces, like the edmf_* variables
6547 IF (env_subs) THEN
6548 DO k=kts+1,kte-1
6549 !First, smooth the profiles of w & a, since sharp vertical gradients
6550 !in plume variables are not likely extended to env variables
6551 !Note1: w is treated as negative further below
6552 !Note2: both w & a will be transformed into env variables further below
6553 envi_w(k) = onethird*(edmf_w(k-1)+edmf_w(k)+edmf_w(k+1))
6554 envi_a(k) = onethird*(edmf_a(k-1)+edmf_a(k)+edmf_a(k+1))*adjustment
6555 ENDDO
6556 !define env variables at k=1 (top of first model layer)
6557 envi_w(kts) = edmf_w(kts)
6558 envi_a(kts) = edmf_a(kts)
6559 !define env variables at k=kte
6560 envi_w(kte) = 0.0
6561 envi_a(kte) = edmf_a(kte)
6562 !define env variables at k=kte+1
6563 envi_w(kte+1) = 0.0
6564 envi_a(kte+1) = edmf_a(kte)
6565 !Add limiter for very long time steps (i.e. dt > 300 s)
6566 !Note that this is not a robust check - only for violations in
6567 ! the first model level.
6568 IF (envi_w(kts) > 0.9*DZ(kts)/dt) THEN
6569 sublim = 0.9*DZ(kts)/dt/envi_w(kts)
6570 ELSE
6571 sublim = 1.0
6572 ENDIF
6573 !Transform w & a into env variables
6574 DO k=kts,kte
6575 temp=envi_a(k)
6576 envi_a(k)=1.0-temp
6577 envi_w(k)=csub*sublim*envi_w(k)*temp/(1.-temp)
6578 ENDDO
6579 !calculate tendencies from subsidence and detrainment valid at the middle of
6580 !each model layer. The lowest model layer uses an assumes w=0 at the surface.
6581 dzi(kts) = 0.5*(dz(kts)+dz(kts+1))
6582 sub_thl(kts)= 0.5*envi_w(kts)*envi_a(kts)* &
6583 (rho(kts+1)*thl(kts+1)-rho(kts)*thl(kts))/dzi(kts)/rhoz(k)
6584 sub_sqv(kts)= 0.5*envi_w(kts)*envi_a(kts)* &
6585 (rho(kts+1)*qv(kts+1)-rho(kts)*qv(kts))/dzi(kts)/rhoz(k)
6586 DO k=kts+1,kte-1
6587 dzi(k) = 0.5*(dz(k)+dz(k+1))
6588 sub_thl(k)= 0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * &
6589 (rho(k+1)*thl(k+1)-rho(k)*thl(k))/dzi(k)/rhoz(k)
6590 sub_sqv(k)= 0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * &
6591 (rho(k+1)*qv(k+1)-rho(k)*qv(k))/dzi(k)/rhoz(k)
6592 ENDDO
6594 DO k=KTS,KTE-1
6595 det_thl(k)=Cdet*(envm_thl(k)-thl(k))*envi_a(k)*Psig_w
6596 det_sqv(k)=Cdet*(envm_sqv(k)-qv(k))*envi_a(k)*Psig_w
6597 det_sqc(k)=Cdet*(envm_sqc(k)-qc(k))*envi_a(k)*Psig_w
6598 ENDDO
6600 IF (momentum_opt > 0) THEN
6601 sub_u(kts)=0.5*envi_w(kts)*envi_a(kts)* &
6602 (rho(kts+1)*u(kts+1)-rho(kts)*u(kts))/dzi(kts)/rhoz(k)
6603 sub_v(kts)=0.5*envi_w(kts)*envi_a(kts)* &
6604 (rho(kts+1)*v(kts+1)-rho(kts)*v(kts))/dzi(kts)/rhoz(k)
6605 DO k=kts+1,kte-1
6606 sub_u(k)=0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * &
6607 (rho(k+1)*u(k+1)-rho(k)*u(k))/dzi(k)/rhoz(k)
6608 sub_v(k)=0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * &
6609 (rho(k+1)*v(k+1)-rho(k)*v(k))/dzi(k)/rhoz(k)
6610 ENDDO
6612 DO k=KTS,KTE-1
6613 det_u(k) = Cdet*(envm_u(k)-u(k))*envi_a(k)*Psig_w
6614 det_v(k) = Cdet*(envm_v(k)-v(k))*envi_a(k)*Psig_w
6615 ENDDO
6616 ENDIF
6617 ENDIF !end subsidence/env detranment
6619 !First, compute exner, plume theta, and dz centered at interface
6620 !Here, k=1 is the top of the first model layer. These values do not
6621 !need to be defined at k=kte (unused level).
6622 DO K=KTS,KTE-1
6623 exneri(k) = (exner(k)*dz(k+1)+exner(k+1)*dz(k))/(dz(k+1)+dz(k))
6624 edmf_th(k)= edmf_thl(k) + xlvcp/exneri(k)*edmf_qc(K)
6625 dzi(k) = 0.5*(dz(k)+dz(k+1))
6626 ENDDO
6628 !JOE: ADD CLDFRA_bl1d, qc_bl1d. Note that they have already been defined in
6629 ! mym_condensation. Here, a shallow-cu component is added, but no cumulus
6630 ! clouds can be added at k=1 (start loop at k=2).
6631 do k=kts+1,kte-2
6632 if (k > KTOP) exit
6633 if(0.5*(edmf_qc(k)+edmf_qc(k-1))>0.0 .and. (cldfra_bl1d(k) < cf_thresh))THEN
6634 !interpolate plume quantities to mass levels
6635 Aup = (edmf_a(k)*dzi(k-1)+edmf_a(k-1)*dzi(k))/(dzi(k-1)+dzi(k))
6636 THp = (edmf_th(k)*dzi(k-1)+edmf_th(k-1)*dzi(k))/(dzi(k-1)+dzi(k))
6637 QTp = (edmf_qt(k)*dzi(k-1)+edmf_qt(k-1)*dzi(k))/(dzi(k-1)+dzi(k))
6638 !convert TH to T
6639 ! t = THp*exner(k)
6640 !SATURATED VAPOR PRESSURE
6641 esat = esat_blend(tk(k))
6642 !SATURATED SPECIFIC HUMIDITY
6643 qsl=ep_2*esat/max(1.e-7,(p(k)-ep_3*esat))
6645 !condensed liquid in the plume on mass levels
6646 if (edmf_qc(k)>0.0 .and. edmf_qc(k-1)>0.0) then
6647 QCp = (edmf_qc(k)*dzi(k-1)+edmf_qc(k-1)*dzi(k))/(dzi(k-1)+dzi(k))
6648 else
6649 QCp = max(edmf_qc(k),edmf_qc(k-1))
6650 endif
6652 !COMPUTE CLDFRA & QC_BL FROM MASS-FLUX SCHEME and recompute vt & vq
6653 xl = xl_blend(tk(k)) ! obtain blended heat capacity
6654 qsat_tk = qsat_blend(tk(k),p(k)) ! get saturation water vapor mixing ratio
6655 ! at t and p
6656 rsl = xl*qsat_tk / (r_v*tk(k)**2) ! slope of C-C curve at t (abs temp)
6657 ! CB02, Eqn. 4
6658 cpm = cp + qt(k)*cpv ! CB02, sec. 2, para. 1
6659 a = 1./(1. + xl*rsl/cpm) ! CB02 variable "a"
6660 b9 = a*rsl ! CB02 variable "b"
6662 q2p = xlvcp/exner(k)
6663 pt = thl(k) +q2p*QCp*Aup ! potential temp (env + plume)
6664 bb = b9*tk(k)/pt ! bb is "b9" in BCMT95. Their "b9" differs from
6665 ! "b9" in CB02 by a factor
6666 ! of T/theta. Strictly, b9 above is formulated in
6667 ! terms of sat. mixing ratio, but bb in BCMT95 is
6668 ! cast in terms of sat. specific humidity. The
6669 ! conversion is neglected here.
6670 qww = 1.+0.61*qt(k)
6671 alpha = 0.61*pt
6672 beta = pt*xl/(tk(k)*cp) - 1.61*pt
6673 !Buoyancy flux terms have been moved to the end of this section...
6675 !Now calculate convective component of the cloud fraction:
6676 if (a > 0.0) then
6677 f = MIN(1.0/a, 4.0) ! f is vertical profile scaling function (CB2005)
6678 else
6679 f = 1.0
6680 endif
6682 !CB form:
6683 !sigq = 3.5E-3 * Aup * 0.5*(edmf_w(k)+edmf_w(k-1)) * f ! convective component of sigma (CB2005)
6684 !sigq = SQRT(sigq**2 + sgm(k)**2) ! combined conv + stratus components
6685 !Per S.DeRoode 2009?
6686 !sigq = 5. * Aup * (QTp - qt(k))
6687 sigq = 10. * Aup * (QTp - qt(k))
6688 !constrain sigq wrt saturation:
6689 sigq = max(sigq, qsat_tk*0.02 )
6690 sigq = min(sigq, qsat_tk*0.25 )
6692 qmq = a * (qt(k) - qsat_tk) ! saturation deficit/excess;
6693 Q1 = qmq/sigq ! the numerator of Q1
6695 if ((landsea-1.5).GE.0) then ! WATER
6696 !modified form from LES
6697 !mf_cf = min(max(0.5 + 0.36 * atan(1.20*(Q1+0.2)),0.01),0.6)
6698 !Original CB
6699 mf_cf = min(max(0.5 + 0.36 * atan(1.55*Q1),0.01),0.6)
6700 mf_cf = max(mf_cf, 1.2 * Aup)
6701 mf_cf = min(mf_cf, 5.0 * Aup)
6702 else ! LAND
6703 !LES form
6704 !mf_cf = min(max(0.5 + 0.36 * atan(1.20*(Q1+0.4)),0.01),0.6)
6705 !Original CB
6706 mf_cf = min(max(0.5 + 0.36 * atan(1.55*Q1),0.01),0.6)
6707 mf_cf = max(mf_cf, 1.8 * Aup)
6708 mf_cf = min(mf_cf, 5.0 * Aup)
6709 endif
6711 !IF ( debug_code ) THEN
6712 ! print*,"In MYNN, StEM edmf"
6713 ! print*," CB: env qt=",qt(k)," qsat=",qsat_tk
6714 ! print*," k=",k," satdef=",QTp - qsat_tk," sgm=",sgm(k)
6715 ! print*," CB: sigq=",sigq," qmq=",qmq," tk=",tk(k)
6716 ! print*," CB: mf_cf=",mf_cf," cldfra_bl=",cldfra_bl1d(k)," edmf_a=",edmf_a(k)
6717 !ENDIF
6719 ! Update cloud fractions and specific humidities in grid cells
6720 ! where the mass-flux scheme is active. The specific humidities
6721 ! are converted to grid means (not in-cloud quantities).
6722 if ((landsea-1.5).GE.0) then ! water
6723 if (QCp * Aup > 5e-5) then
6724 qc_bl1d(k) = 1.86 * (QCp * Aup) - 2.2e-5
6725 else
6726 qc_bl1d(k) = 1.18 * (QCp * Aup)
6727 endif
6728 cldfra_bl1d(k) = mf_cf
6729 Ac_mf = mf_cf
6730 else ! land
6731 if (QCp * Aup > 5e-5) then
6732 qc_bl1d(k) = 1.86 * (QCp * Aup) - 2.2e-5
6733 else
6734 qc_bl1d(k) = 1.18 * (QCp * Aup)
6735 endif
6736 cldfra_bl1d(k) = mf_cf
6737 Ac_mf = mf_cf
6738 endif
6740 !Now recalculate the terms for the buoyancy flux for mass-flux clouds:
6741 !See mym_condensation for details on these formulations.
6742 !Use Bechtold and Siebesma (1998) piecewise estimation of Fng with
6743 !limits ,since they really should be recalculated after all the other changes...:
6744 !Only overwrite vt & vq in non-stratus condition
6745 !if ((landsea-1.5).GE.0) then ! WATER
6746 Q1=max(Q1,-2.25)
6747 !else
6748 ! Q1=max(Q1,-2.0)
6749 !endif
6751 if (Q1 .ge. 1.0) then
6752 Fng = 1.0
6753 elseif (Q1 .ge. -1.7 .and. Q1 .lt. 1.0) then
6754 Fng = EXP(-0.4*(Q1-1.0))
6755 elseif (Q1 .ge. -2.5 .and. Q1 .lt. -1.7) then
6756 Fng = 3.0 + EXP(-3.8*(Q1+1.7))
6757 else
6758 Fng = min(23.9 + EXP(-1.6*(Q1+2.5)), 60.)
6759 endif
6761 !link the buoyancy flux function to active clouds only (c*Aup):
6762 vt(k) = qww - (1.5*Aup)*beta*bb*Fng - 1.
6763 vq(k) = alpha + (1.5*Aup)*beta*a*Fng - tv0
6764 endif !check for (qc in plume) .and. (cldfra_bl < threshold)
6765 enddo !k-loop
6767 ENDIF !end nup2 > 0
6769 !modify output (negative: dry plume, positive: moist plume)
6770 if (ktop > 0) then
6771 maxqc = maxval(edmf_qc(1:ktop))
6772 if ( maxqc < 1.E-8) maxmf = -1.0*maxmf
6773 endif
6775 !
6776 ! debugging
6777 !
6778 if (edmf_w(1) > 4.0) then
6779 ! surface values
6780 print *,'flq:',flq,' fltv:',fltv2
6781 print *,'pblh:',pblh,' wstar:',wstar
6782 print *,'sigmaW=',sigmaW,' sigmaTH=',sigmaTH,' sigmaQT=',sigmaQT
6783 ! means
6784 ! print *,'u:',u
6785 ! print *,'v:',v
6786 ! print *,'thl:',thl
6787 ! print *,'thv:',thv
6788 ! print *,'qt:',qt
6789 ! print *,'p:',p
6791 ! updrafts
6792 ! DO I=1,NUP2
6793 ! print *,'up:A',i
6794 ! print *,UPA(:,i)
6795 ! print *,'up:W',i
6796 ! print*,UPW(:,i)
6797 ! print *,'up:thv',i
6798 ! print *,UPTHV(:,i)
6799 ! print *,'up:thl',i
6800 ! print *,UPTHL(:,i)
6801 ! print *,'up:qt',i
6802 ! print *,UPQT(:,i)
6803 ! print *,'up:tQC',i
6804 ! print *,UPQC(:,i)
6805 ! print *,'up:ent',i
6806 ! print *,ENT(:,i)
6807 ! ENDDO
6809 ! mean updrafts
6810 print *,' edmf_a',edmf_a(1:14)
6811 print *,' edmf_w',edmf_w(1:14)
6812 print *,' edmf_qt:',edmf_qt(1:14)
6813 print *,' edmf_thl:',edmf_thl(1:14)
6815 ENDIF !END Debugging
6818 #ifdef HARDCODE_VERTICAL
6819 # undef kts
6820 # undef kte
6821 #endif
6823 END SUBROUTINE DMP_MF
6824 !=================================================================
6825 !>\ingroup gsd_mynn_edmf
6826 !! This subroutine
6827 subroutine condensation_edmf(QT,THL,P,zagl,THV,QC)
6828 !
6829 ! zero or one condensation for edmf: calculates THV and QC
6830 !
6831 real(kind_phys),intent(in) :: QT,THL,P,zagl
6832 real(kind_phys),intent(out) :: THV
6833 real(kind_phys),intent(inout):: QC
6835 integer :: niter,i
6836 real(kind_phys):: diff,exn,t,th,qs,qcold
6838 ! constants used from module_model_constants.F
6839 ! p1000mb
6840 ! rcp ... Rd/cp
6841 ! xlv ... latent heat for water (2.5e6)
6842 ! cp
6843 ! rvord .. r_v/r_d (1.6)
6845 ! number of iterations
6846 niter=50
6847 ! minimum difference (usually converges in < 8 iterations with diff = 2e-5)
6848 diff=1.e-6
6850 EXN=(P/p1000mb)**rcp
6851 !QC=0. !better first guess QC is incoming from lower level, do not set to zero
6852 do i=1,NITER
6853 T=EXN*THL + xlvcp*QC
6854 QS=qsat_blend(T,P)
6855 QCOLD=QC
6856 QC=0.5*QC + 0.5*MAX((QT-QS),0.)
6857 if (abs(QC-QCOLD)<Diff) exit
6858 enddo
6860 T=EXN*THL + xlvcp*QC
6861 QS=qsat_blend(T,P)
6862 QC=max(QT-QS,0.)
6864 !Do not allow saturation below 100 m
6865 if(zagl < 100.)QC=0.
6867 !THV=(THL+xlv/cp*QC).*(1+(1-rvovrd)*(QT-QC)-QC);
6868 THV=(THL+xlvcp*QC)*(1.+QT*(rvovrd-1.)-rvovrd*QC)
6870 ! IF (QC > 0.0) THEN
6871 ! PRINT*,"EDMF SAT, p:",p," iterations:",i
6872 ! PRINT*," T=",T," THL=",THL," THV=",THV
6873 ! PRINT*," QS=",QS," QT=",QT," QC=",QC,"ratio=",qc/qs
6874 ! ENDIF
6876 !THIS BASICALLY GIVE THE SAME RESULT AS THE PREVIOUS LINE
6877 !TH = THL + xlv/cp/EXN*QC
6878 !THV= TH*(1. + p608*QT)
6880 !print *,'t,p,qt,qs,qc'
6881 !print *,t,p,qt,qs,qc
6884 end subroutine condensation_edmf
6886 !===============================================================
6888 subroutine condensation_edmf_r(QT,THL,P,zagl,THV,QC)
6889 !
6890 ! zero or one condensation for edmf: calculates THL and QC
6891 ! similar to condensation_edmf but with different inputs
6892 !
6893 real(kind_phys),intent(in) :: QT,THV,P,zagl
6894 real(kind_phys),intent(out) :: THL, QC
6896 integer :: niter,i
6897 real(kind_phys):: diff,exn,t,th,qs,qcold
6899 ! number of iterations
6900 niter=50
6901 ! minimum difference
6902 diff=2.e-5
6904 EXN=(P/p1000mb)**rcp
6905 ! assume first that th = thv
6906 T = THV*EXN
6907 !QS = qsat_blend(T,P)
6908 !QC = QS - QT
6910 QC=0.
6912 do i=1,NITER
6913 QCOLD = QC
6914 T = EXN*THV/(1.+QT*(rvovrd-1.)-rvovrd*QC)
6915 QS=qsat_blend(T,P)
6916 QC= MAX((QT-QS),0.)
6917 if (abs(QC-QCOLD)<Diff) exit
6918 enddo
6919 THL = (T - xlv/cp*QC)/EXN
6921 end subroutine condensation_edmf_r
6923 !===============================================================
6924 ! ===================================================================
6925 ! This is the downdraft mass flux scheme - analogus to edmf_JPL but
6926 ! flipped updraft to downdraft. This scheme is currently only tested
6927 ! for Stratocumulus cloud conditions. For a detailed desctiption of the
6928 ! model, see paper.
6930 SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, &
6931 &u,v,th,thl,thv,tk,qt,qv,qc, &
6932 &rho,exner, &
6933 &ust,wthl,wqt,pblh,kpbl, &
6934 &edmf_a_dd,edmf_w_dd, edmf_qt_dd, &
6935 &edmf_thl_dd,edmf_ent_dd,edmf_qc_dd, &
6936 &sd_aw,sd_awthl,sd_awqt, &
6937 &sd_awqv,sd_awqc,sd_awu,sd_awv, &
6938 &sd_awqke, &
6939 &qc_bl1d,cldfra_bl1d, &
6940 &rthraten )
6942 integer, intent(in) :: KTS,KTE,KPBL
6943 real(kind_phys), dimension(kts:kte), intent(in) :: &
6944 U,V,TH,THL,TK,QT,QV,QC,THV,P,rho,exner,dz
6945 real(kind_phys), dimension(kts:kte), intent(in) :: rthraten
6946 ! zw .. heights of the downdraft levels (edges of boxes)
6947 real(kind_phys), dimension(kts:kte+1), intent(in) :: ZW
6948 real(kind_phys), intent(in) :: WTHL,WQT
6949 real(kind_phys), intent(in) :: dt,ust,pblh
6950 ! outputs - downdraft properties
6951 real(kind_phys), dimension(kts:kte), intent(out) :: &
6952 edmf_a_dd,edmf_w_dd, &
6953 edmf_qt_dd,edmf_thl_dd, edmf_ent_dd,edmf_qc_dd
6955 ! outputs - variables needed for solver (sd_aw - sum ai*wi, sd_awphi - sum ai*wi*phii)
6956 real(kind_phys), dimension(kts:kte+1) :: &
6957 sd_aw, sd_awthl, sd_awqt, sd_awu, &
6958 sd_awv, sd_awqc, sd_awqv, sd_awqke, sd_aw2
6960 real(kind_phys), dimension(kts:kte), intent(in) :: &
6961 qc_bl1d, cldfra_bl1d
6963 integer, parameter:: ndown = 5
6964 ! draw downdraft starting height randomly between cloud base and cloud top
6965 integer, dimension(1:NDOWN) :: DD_initK
6966 real(kind_phys), dimension(1:NDOWN) :: randNum
6967 ! downdraft properties
6968 real(kind_phys), dimension(kts:kte+1,1:NDOWN) :: &
6969 DOWNW,DOWNTHL,DOWNQT,DOWNQC,DOWNA,DOWNU,DOWNV,DOWNTHV
6971 ! entrainment variables
6972 real(kind_phys), dimension(KTS+1:KTE+1,1:NDOWN) :: ENT,ENTf
6973 integer, dimension(KTS+1:KTE+1,1:NDOWN) :: ENTi
6975 ! internal variables
6976 integer :: K,I,ki, kminrad, qlTop, p700_ind, qlBase
6977 real(kind_phys):: wthv,wstar,qstar,thstar,sigmaW,sigmaQT, &
6978 sigmaTH,z0,pwmin,pwmax,wmin,wmax,wlv,wtv,went,mindownw
6979 real(kind_phys):: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,Wn2,Wn, &
6980 THVk,Pk,EntEXP,EntW,beta_dm,EntExp_M,rho_int
6981 real(kind_phys):: jump_thetav, jump_qt, jump_thetal, &
6982 refTHL, refTHV, refQT
6983 ! DD specific internal variables
6984 real(kind_phys):: minrad,zminrad, radflux, F0, wst_rad, wst_dd
6985 logical :: cloudflg
6986 real(kind_phys):: sigq,xl,rsl,cpm,a,mf_cf,diffqt, &
6987 Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9,satvp,rhgrid
6989 ! w parameters
6990 real(kind_phys),parameter :: &
6991 &Wa=1., Wb=1.5, Z00=100., BCOEFF=0.2
6992 ! entrainment parameters
6993 real(kind_phys),parameter :: &
6994 &L0=80, ENT0=0.2
6995 !downdraft properties
6996 real(kind_phys):: &
6997 & dp, & !diameter of plume
6998 & dl, & !diameter increment
6999 & Adn !total area of downdrafts
7000 !additional printouts for debugging
7001 integer, parameter :: debug_mf=0
7003 dl = (1000.-500.)/real(ndown)
7004 pwmin=-3. ! drawing from the negative tail -3sigma to -1sigma
7005 pwmax=-1.
7007 ! initialize downdraft properties
7008 DOWNW=0.
7009 DOWNTHL=0.
7010 DOWNTHV=0.
7011 DOWNQT=0.
7012 DOWNA=0.
7013 DOWNU=0.
7014 DOWNV=0.
7015 DOWNQC=0.
7016 ENT=0.
7017 DD_initK=0
7019 edmf_a_dd =0.
7020 edmf_w_dd =0.
7021 edmf_qt_dd =0.
7022 edmf_thl_dd=0.
7023 edmf_ent_dd=0.
7024 edmf_qc_dd =0.
7026 sd_aw=0.
7027 sd_awthl=0.
7028 sd_awqt=0.
7029 sd_awqv=0.
7030 sd_awqc=0.
7031 sd_awu=0.
7032 sd_awv=0.
7033 sd_awqke=0.
7035 ! FIRST, CHECK FOR STRATOCUMULUS-TOPPED BOUNDARY LAYERS
7036 cloudflg=.false.
7037 minrad=100.
7038 kminrad=kpbl
7039 zminrad=PBLH
7040 qlTop = 1 !initialize at 0
7041 qlBase = 1
7042 wthv=wthl+svp1*wqt
7043 do k = MAX(3,kpbl-2),kpbl+3
7044 if (qc(k).gt. 1.e-6 .AND. cldfra_bl1D(k).gt.0.5) then
7045 cloudflg=.true. ! found Sc cloud
7046 qlTop = k ! index for Sc cloud top
7047 endif
7048 enddo
7050 do k = qlTop, kts, -1
7051 if (qc(k) .gt. 1E-6) then
7052 qlBase = k ! index for Sc cloud base
7053 endif
7054 enddo
7055 qlBase = (qlTop+qlBase)/2 ! changed base to half way through the cloud
7057 ! call init_random_seed_1()
7058 ! call RANDOM_NUMBER(randNum)
7059 do i=1,NDOWN
7060 ! downdraft starts somewhere between cloud base to cloud top
7061 ! the probability is equally distributed
7062 DD_initK(i) = qlTop ! nint(randNum(i)*real(qlTop-qlBase)) + qlBase
7063 enddo
7065 ! LOOP RADFLUX
7066 F0 = 0.
7067 do k = 1, qlTop ! Snippet from YSU, YSU loops until qlTop - 1
7068 radflux = rthraten(k) * exner(k) ! Converts theta/s to temperature/s
7069 radflux = radflux * cp / grav * ( p(k) - p(k+1) ) ! Converts K/s to W/m^2
7070 if ( radflux < 0.0 ) F0 = abs(radflux) + F0
7071 enddo
7072 F0 = max(F0, 1.0)
7074 !Allow the total fractional area of the downdrafts to be proportional
7075 !to the radiative forcing:
7076 !for 50 W/m2, Adn = 0.10
7077 !for 100 W/m2, Adn = 0.15
7078 !for 150 W/m2, Adn = 0.20
7079 Adn = min( 0.05 + F0*0.001, 0.3)
7081 !found Sc cloud and cloud not at surface, trigger downdraft
7082 if (cloudflg) then
7084 ! !get entrainent coefficient
7085 ! do i=1,NDOWN
7086 ! do k=kts+1,kte
7087 ! ENTf(k,i)=(ZW(k+1)-ZW(k))/L0
7088 ! enddo
7089 ! enddo
7090 !
7091 ! ! get Poisson P(dz/L0)
7092 ! call Poisson(1,NDOWN,kts+1,kte,ENTf,ENTi)
7095 ! ! entrainent: Ent=Ent0/dz*P(dz/L0)
7096 ! do i=1,NDOWN
7097 ! do k=kts+1,kte
7098 !! ENT(k,i)=real(ENTi(k,i))*Ent0/(ZW(k+1)-ZW(k))
7099 ! ENT(k,i) = 0.002
7100 ! ENT(k,i) = min(ENT(k,i),0.9/(ZW(k+1)-ZW(k)))
7101 ! enddo
7102 ! enddo
7104 !!![EW: INVJUMP] find 700mb height then subtract trpospheric lapse rate!!!
7105 p700_ind = MINLOC(ABS(p-70000),1)!p1D is 70000
7106 jump_thetav = thv(p700_ind) - thv(1) - (thv(p700_ind)-thv(qlTop+3))/(ZW(p700_ind)-ZW(qlTop+3))*(ZW(p700_ind)-ZW(qlTop))
7107 jump_qt = qc(p700_ind) + qv(p700_ind) - qc(1) - qv(1)
7108 jump_thetal = thl(p700_ind) - thl(1) - (thl(p700_ind)-thl(qlTop+3))/(ZW(p700_ind)-ZW(qlTop+3))*(ZW(p700_ind)-ZW(qlTop))
7110 refTHL = thl(qlTop) !sum(thl(1:qlTop)) / (qlTop) ! avg over BL for now or just at qlTop
7111 refTHV = thv(qlTop) !sum(thv(1:qlTop)) / (qlTop)
7112 refQT = qt(qlTop) !sum(qt(1:qlTop)) / (qlTop)
7114 ! wstar_rad, following Lock and MacVean (1999a)
7115 wst_rad = ( grav * zw(qlTop) * F0 / (refTHL * rho(qlTop) * cp) ) ** (0.333)
7116 wst_rad = max(wst_rad, 0.1)
7117 wstar = max(0.,(grav/thv(1)*wthv*pblh)**(onethird))
7118 went = thv(1) / ( grav * jump_thetav * zw(qlTop) ) * &
7119 (0.15 * (wstar**3 + 5*ust**3) + 0.35 * wst_rad**3 )
7120 qstar = abs(went*jump_qt/wst_rad)
7121 thstar = F0/rho(qlTop)/cp/wst_rad - went*jump_thetav/wst_rad
7122 !wstar_dd = mixrad + surface wst
7123 wst_dd = (0.15 * (wstar**3 + 5*ust**3) + 0.35 * wst_rad**3 ) ** (0.333)
7125 print*,"qstar=",qstar," thstar=",thstar," wst_dd=",wst_dd
7126 print*,"F0=",F0," wst_rad=",wst_rad," jump_thv=",jump_thetav
7127 print*,"entrainment velocity=",went
7129 sigmaW = 0.2*wst_dd ! 0.8*wst_dd !wst_rad tuning parameter ! 0.5 was good
7130 sigmaQT = 40 * qstar ! 50 was good
7131 sigmaTH = 1.0 * thstar! 0.5 was good
7133 wmin=sigmaW*pwmin
7134 wmax=sigmaW*pwmax
7135 !print*,"sigw=",sigmaW," wmin=",wmin," wmax=",wmax
7137 do I=1,NDOWN !downdraft now starts at different height
7138 ki = DD_initK(I)
7140 wlv=wmin+(wmax-wmin)/real(NDOWN)*(i-1)
7141 wtv=wmin+(wmax-wmin)/real(NDOWN)*i
7143 !DOWNW(ki,I)=0.5*(wlv+wtv)
7144 DOWNW(ki,I)=wlv
7145 !multiply downa by cloud fraction, so it's impact will diminish if
7146 !clouds are mixed away over the course of the longer radiation time step
7147 !DOWNA(ki,I)=0.5*ERF(wtv/(sqrt(2.)*sigmaW))-0.5*ERF(wlv/(sqrt(2.)*sigmaW))
7148 DOWNA(ki,I)=Adn/real(NDOWN)
7149 DOWNU(ki,I)=(u(ki-1)*DZ(ki) + u(ki)*DZ(ki-1)) /(DZ(ki)+DZ(ki-1))
7150 DOWNV(ki,I)=(v(ki-1)*DZ(ki) + v(ki)*DZ(ki-1)) /(DZ(ki)+DZ(ki-1))
7152 !reference now depends on where dd starts
7153 ! refTHL = 0.5 * (thl(ki) + thl(ki-1))
7154 ! refTHV = 0.5 * (thv(ki) + thv(ki-1))
7155 ! refQT = 0.5 * (qt(ki) + qt(ki-1) )
7157 refTHL = (thl(ki-1)*DZ(ki) + thl(ki)*DZ(ki-1)) /(DZ(ki)+DZ(ki-1))
7158 refTHV = (thv(ki-1)*DZ(ki) + thv(ki)*DZ(ki-1)) /(DZ(ki)+DZ(ki-1))
7159 refQT = (qt(ki-1)*DZ(ki) + qt(ki)*DZ(ki-1)) /(DZ(ki)+DZ(ki-1))
7161 !DOWNQC(ki,I) = 0.0
7162 DOWNQC(ki,I) = (qc(ki-1)*DZ(ki) + qc(ki)*DZ(ki-1)) /(DZ(ki)+DZ(ki-1))
7163 DOWNQT(ki,I) = refQT !+ 0.5 *DOWNW(ki,I)*sigmaQT/sigmaW
7164 DOWNTHV(ki,I)= refTHV + 0.01 *DOWNW(ki,I)*sigmaTH/sigmaW
7165 DOWNTHL(ki,I)= refTHL + 0.01 *DOWNW(ki,I)*sigmaTH/sigmaW
7167 !input :: QT,THV,P,zagl, output :: THL, QC
7168 ! Pk =(P(ki-1)*DZ(ki)+P(ki)*DZ(ki-1))/(DZ(ki)+DZ(ki-1))
7169 ! call condensation_edmf_r(DOWNQT(ki,I), &
7170 ! & DOWNTHL(ki,I),Pk,ZW(ki), &
7171 ! & DOWNTHV(ki,I),DOWNQC(ki,I) )
7173 enddo
7175 !print*, " Begin integration of downdrafts:"
7176 DO I=1,NDOWN
7177 dp = 500. + dl*real(I) ! diameter of plume (meters)
7178 !print *, "Plume # =", I,"======================="
7179 DO k=DD_initK(I)-1,KTS+1,-1
7181 !Entrainment from Tian and Kuang (2016), with constraints
7182 wmin = 0.3 + dp*0.0005
7183 ENT(k,i) = 0.33/(MIN(MAX(-1.0*DOWNW(k+1,I),wmin),0.9)*dp)
7185 !starting at the first interface level below cloud top
7186 !EntExp=exp(-ENT(K,I)*dz(k))
7187 !EntExp_M=exp(-ENT(K,I)/3.*dz(k))
7188 EntExp =ENT(K,I)*dz(k) !for all scalars
7189 EntExp_M=ENT(K,I)*0.333*dz(k) !test for momentum
7191 QTn =DOWNQT(k+1,I) *(1.-EntExp) + QT(k)*EntExp
7192 THLn=DOWNTHL(k+1,I)*(1.-EntExp) + THL(k)*EntExp
7193 Un =DOWNU(k+1,I) *(1.-EntExp) + U(k)*EntExp_M
7194 Vn =DOWNV(k+1,I) *(1.-EntExp) + V(k)*EntExp_M
7195 !QKEn=DOWNQKE(k-1,I)*(1.-EntExp) + QKE(k)*EntExp
7197 ! QTn =DOWNQT(K+1,I) +(QT(K) -DOWNQT(K+1,I)) *(1.-EntExp)
7198 ! THLn=DOWNTHL(K+1,I)+(THL(K)-DOWNTHL(K+1,I))*(1.-EntExp)
7199 ! Un =DOWNU(K+1,I) +(U(K) -DOWNU(K+1,I))*(1.-EntExp_M)
7200 ! Vn =DOWNV(K+1,I) +(V(K) -DOWNV(K+1,I))*(1.-EntExp_M)
7202 ! given new p & z, solve for thvn & qcn
7203 Pk =(P(k-1)*DZ(k)+P(k)*DZ(k-1))/(DZ(k)+DZ(k-1))
7204 call condensation_edmf(QTn,THLn,Pk,ZW(k),THVn,QCn)
7205 ! B=grav*(0.5*(THVn+DOWNTHV(k+1,I))/THV(k)-1.)
7206 THVk =(THV(k-1)*DZ(k)+THV(k)*DZ(k-1))/(DZ(k)+DZ(k-1))
7207 B=grav*(THVn/THVk - 1.0)
7208 ! Beta_dm = 2*Wb*ENT(K,I) + 0.5/(ZW(k)-dz(k)) * &
7209 ! & max(1. - exp((ZW(k) -dz(k))/Z00 - 1. ) , 0.)
7210 ! EntW=exp(-Beta_dm * dz(k))
7211 EntW=EntExp
7212 ! if (Beta_dm >0) then
7213 ! Wn2=DOWNW(K+1,I)**2*EntW - Wa*B/Beta_dm * (1. - EntW)
7214 ! else
7215 ! Wn2=DOWNW(K+1,I)**2 - 2.*Wa*B*dz(k)
7216 ! end if
7218 mindownw = MIN(DOWNW(K+1,I),-0.2)
7219 Wn = DOWNW(K+1,I) + (-2.*ENT(K,I)*DOWNW(K+1,I) - &
7220 BCOEFF*B/mindownw)*MIN(dz(k), 250.)
7222 !Do not allow a parcel to accelerate more than 1.25 m/s over 200 m.
7223 !Add max acceleration of -2.0 m/s for coarse vertical resolution.
7224 IF (Wn < DOWNW(K+1,I) - MIN(1.25*dz(k)/200., -2.0))THEN
7225 Wn = DOWNW(K+1,I) - MIN(1.25*dz(k)/200., -2.0)
7226 ENDIF
7227 !Add symmetrical max decrease in velocity (less negative)
7228 IF (Wn > DOWNW(K+1,I) + MIN(1.25*dz(k)/200., 2.0))THEN
7229 Wn = DOWNW(K+1,I) + MIN(1.25*dz(k)/200., 2.0)
7230 ENDIF
7231 Wn = MAX(MIN(Wn,0.0), -3.0)
7233 !print *, " k =", k, " z =", ZW(k)
7234 !print *, " entw =",ENT(K,I), " Bouy =", B
7235 !print *, " downthv =", THVn, " thvk =", thvk
7236 !print *, " downthl =", THLn, " thl =", thl(k)
7237 !print *, " downqt =", QTn , " qt =", qt(k)
7238 !print *, " downw+1 =",DOWNW(K+1,I), " Wn2 =", Wn
7240 IF (Wn .lt. 0.) THEN !terminate when velocity is too small
7241 DOWNW(K,I) = Wn !-sqrt(Wn2)
7242 DOWNTHV(K,I)= THVn
7243 DOWNTHL(K,I)= THLn
7244 DOWNQT(K,I) = QTn
7245 DOWNQC(K,I) = QCn
7246 DOWNU(K,I) = Un
7247 DOWNV(K,I) = Vn
7248 DOWNA(K,I) = DOWNA(K+1,I)
7249 ELSE
7250 !plumes must go at least 2 levels
7251 if (DD_initK(I) - K .lt. 2) then
7252 DOWNW(:,I) = 0.0
7253 DOWNTHV(:,I)= 0.0
7254 DOWNTHL(:,I)= 0.0
7255 DOWNQT(:,I) = 0.0
7256 DOWNQC(:,I) = 0.0
7257 DOWNU(:,I) = 0.0
7258 DOWNV(:,I) = 0.0
7259 endif
7260 exit
7261 ENDIF
7262 ENDDO
7263 ENDDO
7264 endif ! end cloud flag
7266 DOWNW(1,:) = 0. !make sure downdraft does not go to the surface
7267 DOWNA(1,:) = 0.
7269 ! Combine both moist and dry plume, write as one averaged plume
7270 ! Even though downdraft starts at different height, average all up to qlTop
7271 DO k=qlTop,KTS,-1
7272 DO I=1,NDOWN
7273 edmf_a_dd(K) =edmf_a_dd(K) +DOWNA(K-1,I)
7274 edmf_w_dd(K) =edmf_w_dd(K) +DOWNA(K-1,I)*DOWNW(K-1,I)
7275 edmf_qt_dd(K) =edmf_qt_dd(K) +DOWNA(K-1,I)*DOWNQT(K-1,I)
7276 edmf_thl_dd(K)=edmf_thl_dd(K)+DOWNA(K-1,I)*DOWNTHL(K-1,I)
7277 edmf_ent_dd(K)=edmf_ent_dd(K)+DOWNA(K-1,I)*ENT(K-1,I)
7278 edmf_qc_dd(K) =edmf_qc_dd(K) +DOWNA(K-1,I)*DOWNQC(K-1,I)
7279 ENDDO
7281 IF (edmf_a_dd(k) >0.) THEN
7282 edmf_w_dd(k) =edmf_w_dd(k) /edmf_a_dd(k)
7283 edmf_qt_dd(k) =edmf_qt_dd(k) /edmf_a_dd(k)
7284 edmf_thl_dd(k)=edmf_thl_dd(k)/edmf_a_dd(k)
7285 edmf_ent_dd(k)=edmf_ent_dd(k)/edmf_a_dd(k)
7286 edmf_qc_dd(k) =edmf_qc_dd(k) /edmf_a_dd(k)
7287 ENDIF
7288 ENDDO
7290 !
7291 ! computing variables needed for solver
7292 !
7294 DO k=KTS,qlTop
7295 rho_int = (rho(k)*DZ(k+1)+rho(k+1)*DZ(k))/(DZ(k+1)+DZ(k))
7296 DO I=1,NDOWN
7297 sd_aw(k) =sd_aw(k) +rho_int*DOWNA(k,i)*DOWNW(k,i)
7298 sd_awthl(k)=sd_awthl(k)+rho_int*DOWNA(k,i)*DOWNW(k,i)*DOWNTHL(k,i)
7299 sd_awqt(k) =sd_awqt(k) +rho_int*DOWNA(k,i)*DOWNW(k,i)*DOWNQT(k,i)
7300 sd_awqc(k) =sd_awqc(k) +rho_int*DOWNA(k,i)*DOWNW(k,i)*DOWNQC(k,i)
7301 sd_awu(k) =sd_awu(k) +rho_int*DOWNA(k,i)*DOWNW(k,i)*DOWNU(k,i)
7302 sd_awv(k) =sd_awv(k) +rho_int*DOWNA(k,i)*DOWNW(k,i)*DOWNV(k,i)
7303 ENDDO
7304 sd_awqv(k) = sd_awqt(k) - sd_awqc(k)
7305 ENDDO
7307 END SUBROUTINE DDMF_JPL
7308 !===============================================================
7311 SUBROUTINE SCALE_AWARE(dx,PBL1,Psig_bl,Psig_shcu)
7313 !---------------------------------------------------------------
7314 ! NOTES ON SCALE-AWARE FORMULATION
7315 !
7316 !JOE: add scale-aware factor (Psig) here, taken from Honnert et al. (2011,
7317 ! JAS) and/or from Hyeyum Hailey Shin and Song-You Hong (2013, JAS)
7318 !
7319 ! Psig_bl tapers local mixing
7320 ! Psig_shcu tapers nonlocal mixing
7322 real(kind_phys), intent(in) :: dx,pbl1
7323 real(kind_phys), intent(out) :: Psig_bl,Psig_shcu
7324 real(kind_phys) :: dxdh
7326 Psig_bl=1.0
7327 Psig_shcu=1.0
7328 dxdh=MAX(2.5*dx,10.)/MIN(PBL1,3000.)
7329 ! Honnert et al. 2011, TKE in PBL *** original form used until 201605
7330 !Psig_bl= ((dxdh**2) + 0.07*(dxdh**0.667))/((dxdh**2) + &
7331 ! (3./21.)*(dxdh**0.67) + (3./42.))
7332 ! Honnert et al. 2011, TKE in entrainment layer
7333 !Psig_bl= ((dxdh**2) + (4./21.)*(dxdh**0.667))/((dxdh**2) + &
7334 ! (3./20.)*(dxdh**0.67) + (7./21.))
7335 ! New form to preseve parameterized mixing - only down 5% at dx = 750 m
7336 Psig_bl= ((dxdh**2) + 0.106*(dxdh**0.667))/((dxdh**2) +0.066*(dxdh**0.667) + 0.071)
7338 !assume a 500 m cloud depth for shallow-cu clods
7339 dxdh=MAX(2.5*dx,10.)/MIN(PBL1+500.,3500.)
7340 ! Honnert et al. 2011, TKE in entrainment layer *** original form used until 201605
7341 !Psig_shcu= ((dxdh**2) + (4./21.)*(dxdh**0.667))/((dxdh**2) + &
7342 ! (3./20.)*(dxdh**0.67) + (7./21.))
7344 ! Honnert et al. 2011, TKE in cumulus
7345 !Psig(i)= ((dxdh**2) + 1.67*(dxdh**1.4))/((dxdh**2) +1.66*(dxdh**1.4) +
7346 !0.2)
7348 ! Honnert et al. 2011, w'q' in PBL
7349 !Psig(i)= 0.5 + 0.5*((dxdh**2) + 0.03*(dxdh**1.4) -
7350 !(4./13.))/((dxdh**2) + 0.03*(dxdh**1.4) + (4./13.))
7351 ! Honnert et al. 2011, w'q' in cumulus
7352 !Psig(i)= ((dxdh**2) - 0.07*(dxdh**1.4))/((dxdh**2) -0.07*(dxdh**1.4) +
7353 !0.02)
7355 ! Honnert et al. 2011, q'q' in PBL
7356 !Psig(i)= 0.5 + 0.5*((dxdh**2) + 0.25*(dxdh**0.667) -0.73)/((dxdh**2)
7357 !-0.03*(dxdh**0.667) + 0.73)
7358 ! Honnert et al. 2011, q'q' in cumulus
7359 !Psig(i)= ((dxdh**2) - 0.34*(dxdh**1.4))/((dxdh**2) - 0.35*(dxdh**1.4)
7360 !+ 0.37)
7362 ! Hyeyum Hailey Shin and Song-You Hong 2013, TKE in PBL (same as Honnert's above)
7363 !Psig_shcu= ((dxdh**2) + 0.070*(dxdh**0.667))/((dxdh**2)
7364 !+0.142*(dxdh**0.667) + 0.071)
7365 ! Hyeyum Hailey Shin and Song-You Hong 2013, TKE in entrainment zone *** switch to this form 201605
7366 Psig_shcu= ((dxdh**2) + 0.145*(dxdh**0.667))/((dxdh**2) +0.172*(dxdh**0.667) + 0.170)
7368 ! Hyeyum Hailey Shin and Song-You Hong 2013, w'theta' in PBL
7369 !Psig(i)= 0.5 + 0.5*((dxdh**2) -0.098)/((dxdh**2) + 0.106)
7370 ! Hyeyum Hailey Shin and Song-You Hong 2013, w'theta' in entrainment zone
7371 !Psig(i)= 0.5 + 0.5*((dxdh**2) - 0.112*(dxdh**0.25) -0.071)/((dxdh**2)
7372 !+ 0.054*(dxdh**0.25) + 0.10)
7374 !print*,"in scale_aware; dx, dxdh, Psig(i)=",dx,dxdh,Psig(i)
7375 !If(Psig_bl(i) < 0.0 .OR. Psig(i) > 1.)print*,"dx, dxdh, Psig(i)=",dx,dxdh,Psig_bl(i)
7376 If(Psig_bl > 1.0) Psig_bl=1.0
7377 If(Psig_bl < 0.0) Psig_bl=0.0
7379 If(Psig_shcu > 1.0) Psig_shcu=1.0
7380 If(Psig_shcu < 0.0) Psig_shcu=0.0
7382 END SUBROUTINE SCALE_AWARE
7384 ! =====================================================================
7385 !>\ingroup gsd_mynn_edmf
7386 !! \author JAYMES- added 22 Apr 2015
7387 !! This function calculates saturation vapor pressure. Separate ice and liquid functions
7388 !! are used (identical to those in module_mp_thompson.F, v3.6). Then, the
7389 !! final returned value is a temperature-dependant "blend". Because the final
7390 !! value is "phase-aware", this formulation may be preferred for use throughout
7391 !! the module (replacing "svp").
7392 FUNCTION esat_blend(t)
7394 IMPLICIT NONE
7396 real(kind_phys), intent(in):: t
7397 real(kind_phys):: esat_blend,XC,ESL,ESI,chi
7398 !liquid
7399 real(kind_phys), parameter:: J0= .611583699E03
7400 real(kind_phys), parameter:: J1= .444606896E02
7401 real(kind_phys), parameter:: J2= .143177157E01
7402 real(kind_phys), parameter:: J3= .264224321E-1
7403 real(kind_phys), parameter:: J4= .299291081E-3
7404 real(kind_phys), parameter:: J5= .203154182E-5
7405 real(kind_phys), parameter:: J6= .702620698E-8
7406 real(kind_phys), parameter:: J7= .379534310E-11
7407 real(kind_phys), parameter:: J8=-.321582393E-13
7408 !ice
7409 real(kind_phys), parameter:: K0= .609868993E03
7410 real(kind_phys), parameter:: K1= .499320233E02
7411 real(kind_phys), parameter:: K2= .184672631E01
7412 real(kind_phys), parameter:: K3= .402737184E-1
7413 real(kind_phys), parameter:: K4= .565392987E-3
7414 real(kind_phys), parameter:: K5= .521693933E-5
7415 real(kind_phys), parameter:: K6= .307839583E-7
7416 real(kind_phys), parameter:: K7= .105785160E-9
7417 real(kind_phys), parameter:: K8= .161444444E-12
7419 XC=MAX(-80.,t - t0c) !note t0c = 273.15, tice is set in module mynn_common to 240
7421 ! For 240 < t < 268.16 K, the vapor pressures are "blended" as a function of temperature,
7422 ! using the approach similar to Chaboureau and Bechtold (2002), JAS, p. 2363. The resulting
7423 ! values are returned from the function.
7424 IF (t .GE. (t0c-6.)) THEN
7425 esat_blend = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8)))))))
7426 ELSE IF (t .LE. tice) THEN
7427 esat_blend = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8)))))))
7428 ELSE
7429 ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8)))))))
7430 ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8)))))))
7431 chi = ((t0c-6.) - t)/((t0c-6.) - tice)
7432 esat_blend = (1.-chi)*ESL + chi*ESI
7433 END IF
7435 END FUNCTION esat_blend
7437 ! ====================================================================
7439 !>\ingroup gsd_mynn_edmf
7440 !! This function extends function "esat" and returns a "blended"
7441 !! saturation mixing ratio. Tice currently set to 240 K, t0c = 273.15 K.
7442 !!\author JAYMES
7443 FUNCTION qsat_blend(t, P)
7445 IMPLICIT NONE
7447 real(kind_phys), intent(in):: t, P
7448 real(kind_phys):: qsat_blend,XC,ESL,ESI,RSLF,RSIF,chi
7449 !liquid
7450 real(kind_phys), parameter:: J0= .611583699E03
7451 real(kind_phys), parameter:: J1= .444606896E02
7452 real(kind_phys), parameter:: J2= .143177157E01
7453 real(kind_phys), parameter:: J3= .264224321E-1
7454 real(kind_phys), parameter:: J4= .299291081E-3
7455 real(kind_phys), parameter:: J5= .203154182E-5
7456 real(kind_phys), parameter:: J6= .702620698E-8
7457 real(kind_phys), parameter:: J7= .379534310E-11
7458 real(kind_phys), parameter:: J8=-.321582393E-13
7459 !ice
7460 real(kind_phys), parameter:: K0= .609868993E03
7461 real(kind_phys), parameter:: K1= .499320233E02
7462 real(kind_phys), parameter:: K2= .184672631E01
7463 real(kind_phys), parameter:: K3= .402737184E-1
7464 real(kind_phys), parameter:: K4= .565392987E-3
7465 real(kind_phys), parameter:: K5= .521693933E-5
7466 real(kind_phys), parameter:: K6= .307839583E-7
7467 real(kind_phys), parameter:: K7= .105785160E-9
7468 real(kind_phys), parameter:: K8= .161444444E-12
7470 XC=MAX(-80.,t - t0c)
7472 IF (t .GE. (t0c-6.)) THEN
7473 ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8)))))))
7474 ESL = min(ESL, P*0.15) ! Even with P=1050mb and T=55C, the sat. vap. pres only contributes to ~15% of total pres.
7475 qsat_blend = 0.622*ESL/max(P-ESL, 1e-5)
7476 ELSE IF (t .LE. tice) THEN
7477 ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8)))))))
7478 ESI = min(ESI, P*0.15)
7479 qsat_blend = 0.622*ESI/max(P-ESI, 1e-5)
7480 ELSE
7481 ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8)))))))
7482 ESL = min(ESL, P*0.15)
7483 ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8)))))))
7484 ESI = min(ESI, P*0.15)
7485 RSLF = 0.622*ESL/max(P-ESL, 1e-5)
7486 RSIF = 0.622*ESI/max(P-ESI, 1e-5)
7487 ! chi = (268.16-t)/(268.16-240.)
7488 chi = ((t0c-6.) - t)/((t0c-6.) - tice)
7489 qsat_blend = (1.-chi)*RSLF + chi*RSIF
7490 END IF
7492 END FUNCTION qsat_blend
7494 ! ===================================================================
7496 !>\ingroup gsd_mynn_edmf
7497 !! This function interpolates the latent heats of vaporization and sublimation into
7498 !! a single, temperature-dependent, "blended" value, following
7499 !! Chaboureau and Bechtold (2002) \cite Chaboureau_2002, Appendix.
7500 !!\author JAYMES
7501 FUNCTION xl_blend(t)
7503 IMPLICIT NONE
7505 real(kind_phys), intent(in):: t
7506 real(kind_phys):: xl_blend,xlvt,xlst,chi
7507 !note: t0c = 273.15, tice is set in mynn_common
7509 IF (t .GE. t0c) THEN
7510 xl_blend = xlv + (cpv-cliq)*(t-t0c) !vaporization/condensation
7511 ELSE IF (t .LE. tice) THEN
7512 xl_blend = xls + (cpv-cice)*(t-t0c) !sublimation/deposition
7513 ELSE
7514 xlvt = xlv + (cpv-cliq)*(t-t0c) !vaporization/condensation
7515 xlst = xls + (cpv-cice)*(t-t0c) !sublimation/deposition
7516 ! chi = (273.16-t)/(273.16-240.)
7517 chi = (t0c - t)/(t0c - tice)
7518 xl_blend = (1.-chi)*xlvt + chi*xlst !blended
7519 END IF
7521 END FUNCTION xl_blend
7523 ! ===================================================================
7525 FUNCTION phim(zet)
7526 ! New stability function parameters for momentum (Puhales, 2020, WRF 4.2.1)
7527 ! The forms in unstable conditions (z/L < 0) use Grachev et al. (2000), which are a blend of
7528 ! the classical (Kansas) forms (i.e., Paulson 1970, Dyer and Hicks 1970), valid for weakly
7529 ! unstable conditions (-1 < z/L < 0). The stability functions for stable conditions use an
7530 ! updated form taken from Cheng and Brutsaert (2005), which extends the validity into very
7531 ! stable conditions [z/L ~ O(10)].
7532 IMPLICIT NONE
7534 real(kind_phys), intent(in):: zet
7535 real(kind_phys):: dummy_0,dummy_1,dummy_11,dummy_2,dummy_22,dummy_3,dummy_33,dummy_4,dummy_44,dummy_psi
7536 real(kind_phys), parameter :: am_st=6.1, bm_st=2.5, rbm_st=1./bm_st
7537 real(kind_phys), parameter :: ah_st=5.3, bh_st=1.1, rbh_st=1./bh_st
7538 real(kind_phys), parameter :: am_unst=10., ah_unst=34.
7539 real(kind_phys):: phi_m,phim
7541 if ( zet >= 0.0 ) then
7542 dummy_0=1+zet**bm_st
7543 dummy_1=zet+dummy_0**(rbm_st)
7544 dummy_11=1+dummy_0**(rbm_st-1)*zet**(bm_st-1)
7545 dummy_2=(-am_st/dummy_1)*dummy_11
7546 phi_m = 1-zet*dummy_2
7547 else
7548 dummy_0 = (1.0-cphm_unst*zet)**0.25
7549 phi_m = 1./dummy_0
7550 dummy_psi = 2.*log(0.5*(1.+dummy_0))+log(0.5*(1.+dummy_0**2))-2.*atan(dummy_0)+1.570796
7552 dummy_0=(1.-am_unst*zet) ! parentesis arg
7553 dummy_1=dummy_0**0.333333 ! y
7554 dummy_11=-0.33333*am_unst*dummy_0**(-0.6666667) ! dy/dzet
7555 dummy_2 = 0.33333*(dummy_1**2.+dummy_1+1.) ! f
7556 dummy_22 = 0.3333*dummy_11*(2.*dummy_1+1.) ! df/dzet
7557 dummy_3 = 0.57735*(2.*dummy_1+1.) ! g
7558 dummy_33 = 1.1547*dummy_11 ! dg/dzet
7559 dummy_4 = 1.5*log(dummy_2)-1.73205*atan(dummy_3)+1.813799364 !psic
7560 dummy_44 = (1.5/dummy_2)*dummy_22-1.73205*dummy_33/(1.+dummy_3**2)! dpsic/dzet
7562 dummy_0 = zet**2
7563 dummy_1 = 1./(1.+dummy_0) ! denon
7564 dummy_11 = 2.*zet ! denon/dzet
7565 dummy_2 = ((1-phi_m)/zet+dummy_11*dummy_4+dummy_0*dummy_44)*dummy_1
7566 dummy_22 = -dummy_11*(dummy_psi+dummy_0*dummy_4)*dummy_1**2
7568 phi_m = 1.-zet*(dummy_2+dummy_22)
7569 end if
7571 !phim = phi_m - zet
7572 phim = phi_m
7574 END FUNCTION phim
7575 ! ===================================================================
7577 FUNCTION phih(zet)
7578 ! New stability function parameters for heat (Puhales, 2020, WRF 4.2.1)
7579 ! The forms in unstable conditions (z/L < 0) use Grachev et al. (2000), which are a blend of
7580 ! the classical (Kansas) forms (i.e., Paulson 1970, Dyer and Hicks 1970), valid for weakly
7581 ! unstable conditions (-1 < z/L < 0). The stability functions for stable conditions use an
7582 ! updated form taken from Cheng and Brutsaert (2005), which extends the validity into very
7583 ! stable conditions [z/L ~ O(10)].
7584 IMPLICIT NONE
7586 real(kind_phys), intent(in):: zet
7587 real(kind_phys):: dummy_0,dummy_1,dummy_11,dummy_2,dummy_22,dummy_3,dummy_33,dummy_4,dummy_44,dummy_psi
7588 real(kind_phys), parameter :: am_st=6.1, bm_st=2.5, rbm_st=1./bm_st
7589 real(kind_phys), parameter :: ah_st=5.3, bh_st=1.1, rbh_st=1./bh_st
7590 real(kind_phys), parameter :: am_unst=10., ah_unst=34.
7591 real(kind_phys):: phh,phih
7593 if ( zet >= 0.0 ) then
7594 dummy_0=1+zet**bh_st
7595 dummy_1=zet+dummy_0**(rbh_st)
7596 dummy_11=1+dummy_0**(rbh_st-1)*zet**(bh_st-1)
7597 dummy_2=(-ah_st/dummy_1)*dummy_11
7598 phih = 1-zet*dummy_2
7599 else
7600 dummy_0 = (1.0-cphh_unst*zet)**0.5
7601 phh = 1./dummy_0
7602 dummy_psi = 2.*log(0.5*(1.+dummy_0))
7604 dummy_0=(1.-ah_unst*zet) ! parentesis arg
7605 dummy_1=dummy_0**0.333333 ! y
7606 dummy_11=-0.33333*ah_unst*dummy_0**(-0.6666667) ! dy/dzet
7607 dummy_2 = 0.33333*(dummy_1**2.+dummy_1+1.) ! f
7608 dummy_22 = 0.3333*dummy_11*(2.*dummy_1+1.) ! df/dzet
7609 dummy_3 = 0.57735*(2.*dummy_1+1.) ! g
7610 dummy_33 = 1.1547*dummy_11 ! dg/dzet
7611 dummy_4 = 1.5*log(dummy_2)-1.73205*atan(dummy_3)+1.813799364 !psic
7612 dummy_44 = (1.5/dummy_2)*dummy_22-1.73205*dummy_33/(1.+dummy_3**2)! dpsic/dzet
7614 dummy_0 = zet**2
7615 dummy_1 = 1./(1.+dummy_0) ! denon
7616 dummy_11 = 2.*zet ! ddenon/dzet
7617 dummy_2 = ((1-phh)/zet+dummy_11*dummy_4+dummy_0*dummy_44)*dummy_1
7618 dummy_22 = -dummy_11*(dummy_psi+dummy_0*dummy_4)*dummy_1**2
7620 phih = 1.-zet*(dummy_2+dummy_22)
7621 end if
7623 END FUNCTION phih
7624 ! ==================================================================
7625 SUBROUTINE topdown_cloudrad(kts,kte, &
7626 &dz1,zw,fltv,xland,kpbl,PBLH, &
7627 &sqc,sqi,sqw,thl,th1,ex1,p1,rho1,thetav, &
7628 &cldfra_bl1D,rthraten, &
7629 &maxKHtopdown,KHtopdown,TKEprodTD )
7631 !input
7632 integer, intent(in) :: kte,kts
7633 real(kind_phys), dimension(kts:kte), intent(in) :: dz1,sqc,sqi,sqw,&
7634 thl,th1,ex1,p1,rho1,thetav,cldfra_bl1D
7635 real(kind_phys), dimension(kts:kte), intent(in) :: rthraten
7636 real(kind_phys), dimension(kts:kte+1), intent(in) :: zw
7637 real(kind_phys), intent(in) :: pblh,fltv
7638 real(kind_phys), intent(in) :: xland
7639 integer , intent(in) :: kpbl
7640 !output
7641 real(kind_phys), intent(out) :: maxKHtopdown
7642 real(kind_phys), dimension(kts:kte), intent(out) :: KHtopdown,TKEprodTD
7643 !local
7644 real(kind_phys), dimension(kts:kte) :: zfac,wscalek2,zfacent
7645 real(kind_phys) :: bfx0,wm3,bfxpbl,dthvx,tmp1
7646 real(kind_phys) :: temps,templ,zl1,wstar3_2
7647 real(kind_phys) :: ent_eff,radsum,radflux,we,rcldb,rvls,minrad,zminrad
7648 real(kind_phys), parameter :: pfac =2.0, zfmin = 0.01, phifac=8.0
7649 integer :: k,kk,kminrad
7650 logical :: cloudflg
7652 cloudflg=.false.
7653 minrad=100.
7654 kminrad=kpbl
7655 zminrad=PBLH
7656 KHtopdown(kts:kte)=0.0
7657 TKEprodTD(kts:kte)=0.0
7658 maxKHtopdown=0.0
7660 !CHECK FOR STRATOCUMULUS-TOPPED BOUNDARY LAYERS
7661 DO kk = MAX(1,kpbl-2),kpbl+3
7662 if (sqc(kk).gt. 1.e-6 .OR. sqi(kk).gt. 1.e-6 .OR. &
7663 cldfra_bl1D(kk).gt.0.5) then
7664 cloudflg=.true.
7665 endif
7666 if (rthraten(kk) < minrad)then
7667 minrad=rthraten(kk)
7668 kminrad=kk
7669 zminrad=zw(kk) + 0.5*dz1(kk)
7670 endif
7671 ENDDO
7673 IF (MAX(kminrad,kpbl) < 2)cloudflg = .false.
7674 IF (cloudflg) THEN
7675 zl1 = dz1(kts)
7676 k = MAX(kpbl-1, kminrad-1)
7677 !Best estimate of height of TKE source (top of downdrafts):
7678 !zminrad = 0.5*pblh(i) + 0.5*zminrad
7680 templ=thl(k)*ex1(k)
7681 !rvls is ws at full level
7682 rvls=100.*6.112*EXP(17.67*(templ-273.16)/(templ-29.65))*(ep_2/p1(k+1))
7683 temps=templ + (sqw(k)-rvls)/(cp/xlv + ep_2*xlv*rvls/(r_d*templ**2))
7684 rvls=100.*6.112*EXP(17.67*(temps-273.15)/(temps-29.65))*(ep_2/p1(k+1))
7685 rcldb=max(sqw(k)-rvls,0.)
7687 !entrainment efficiency
7688 dthvx = (thl(k+2) + th1(k+2)*p608*sqw(k+2)) &
7689 - (thl(k) + th1(k) *p608*sqw(k))
7690 dthvx = max(dthvx,0.1)
7691 tmp1 = xlvcp * rcldb/(ex1(k)*dthvx)
7692 !Originally from Nichols and Turton (1986), where a2 = 60, but lowered
7693 !here to 8, as in Grenier and Bretherton (2001).
7694 ent_eff = 0.2 + 0.2*8.*tmp1
7696 radsum=0.
7697 DO kk = MAX(1,kpbl-3),kpbl+3
7698 radflux=rthraten(kk)*ex1(kk) !converts theta/s to temp/s
7699 radflux=radflux*cp/grav*(p1(kk)-p1(kk+1)) ! converts temp/s to W/m^2
7700 if (radflux < 0.0 ) radsum=abs(radflux)+radsum
7701 ENDDO
7703 !More strict limits over land to reduce stable-layer mixouts
7704 if ((xland-1.5).GE.0)THEN ! WATER
7705 radsum=MIN(radsum,90.0)
7706 bfx0 = max(radsum/rho1(k)/cp,0.)
7707 else ! LAND
7708 radsum=MIN(0.25*radsum,30.0)!practically turn off over land
7709 bfx0 = max(radsum/rho1(k)/cp - max(fltv,0.0),0.)
7710 endif
7712 !entrainment from PBL top thermals
7713 wm3 = grav/thetav(k)*bfx0*MIN(pblh,1500.) ! this is wstar3(i)
7714 bfxpbl = - ent_eff * bfx0
7715 dthvx = max(thetav(k+1)-thetav(k),0.1)
7716 we = max(bfxpbl/dthvx,-sqrt(wm3**twothirds))
7718 DO kk = kts,kpbl+3
7719 !Analytic vertical profile
7720 zfac(kk) = min(max((1.-(zw(kk+1)-zl1)/(zminrad-zl1)),zfmin),1.)
7721 zfacent(kk) = 10.*MAX((zminrad-zw(kk+1))/zminrad,0.0)*(1.-zfac(kk))**3
7723 !Calculate an eddy diffusivity profile (not used at the moment)
7724 wscalek2(kk) = (phifac*karman*wm3*(zfac(kk)))**onethird
7725 !Modify shape of Kh to be similar to Lock et al (2000): use pfac = 3.0
7726 KHtopdown(kk) = wscalek2(kk)*karman*(zminrad-zw(kk+1))*(1.-zfac(kk))**3 !pfac
7727 KHtopdown(kk) = MAX(KHtopdown(kk),0.0)
7729 !Calculate TKE production = 2(g/TH)(w'TH'), where w'TH' = A(TH/g)wstar^3/PBLH,
7730 !A = ent_eff, and wstar is associated with the radiative cooling at top of PBL.
7731 !An analytic profile controls the magnitude of this TKE prod in the vertical.
7732 TKEprodTD(kk)=2.*ent_eff*wm3/MAX(pblh,100.)*zfacent(kk)
7733 TKEprodTD(kk)= MAX(TKEprodTD(kk),0.0)
7734 ENDDO
7735 ENDIF !end cloud check
7736 maxKHtopdown=MAXVAL(KHtopdown(:))
7738 END SUBROUTINE topdown_cloudrad
7739 ! ==================================================================
7740 ! ===================================================================
7741 ! ===================================================================
7743 END MODULE module_bl_mynn