| blob | e1bf567411022c4807b863cfd2170d1408c4d3e5 |
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 (bl_mynn_tkebudget)
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 !
236 ! Many of these changes are now documented in references listed above.
237 !====================================================================
239 MODULE module_bl_mynn
241 use module_bl_mynn_common,only: &
242 cp , cpv , cliq , cice , &
243 p608 , ep_2 , ep_3 , gtr , &
244 grav , g_inv , karman , p1000mb , &
245 rcp , r_d , r_v , rk , &
246 rvovrd , svp1 , svp2 , svp3 , &
247 xlf , xlv , xls , xlscp , &
248 xlvcp , tv0 , tv1 , tref , &
249 zero , half , one , two , &
250 onethird , twothirds , tkmin , t0c , &
251 tice , kind_phys
254 IMPLICIT NONE
256 !===================================================================
257 ! From here on, these are MYNN-specific parameters:
258 ! The parameters below depend on stability functions of module_sf_mynn.
259 REAL, PARAMETER :: cphm_st=5.0, cphm_unst=16.0, &
260 cphh_st=5.0, cphh_unst=16.0
262 ! Closure constants
263 REAL, PARAMETER :: &
264 &pr = 0.74, &
265 &g1 = 0.235, & ! NN2009 = 0.235
266 &b1 = 24.0, &
267 &b2 = 15.0, & ! CKmod NN2009
268 &c2 = 0.729, & ! 0.729, & !0.75, &
269 &c3 = 0.340, & ! 0.340, & !0.352, &
270 &c4 = 0.0, &
271 &c5 = 0.2, &
272 &a1 = b1*( 1.0-3.0*g1 )/6.0, &
273 ! &c1 = g1 -1.0/( 3.0*a1*b1**(1.0/3.0) ), &
274 &c1 = g1 -1.0/( 3.0*a1*2.88449914061481660), &
275 &a2 = a1*( g1-c1 )/( g1*pr ), &
276 &g2 = b2/b1*( 1.0-c3 ) +2.0*a1/b1*( 3.0-2.0*c2 )
278 REAL, PARAMETER :: &
279 &cc2 = 1.0-c2, &
280 &cc3 = 1.0-c3, &
281 &e1c = 3.0*a2*b2*cc3, &
282 &e2c = 9.0*a1*a2*cc2, &
283 &e3c = 9.0*a2*a2*cc2*( 1.0-c5 ), &
284 &e4c = 12.0*a1*a2*cc2, &
285 &e5c = 6.0*a1*a1
287 ! Constants for min tke in elt integration (qmin), max z/L in els (zmax),
288 ! and factor for eddy viscosity for TKE (Kq = Sqfac*Km):
289 REAL, PARAMETER :: qmin=0.0, zmax=1.0, Sqfac=3.0
290 ! Note that the following mixing-length constants are now specified in mym_length
291 ! &cns=3.5, alp1=0.23, alp2=0.3, alp3=3.0, alp4=10.0, alp5=0.2
293 REAL, PARAMETER :: gpw=5./3., qcgmin=1.e-8, qkemin=1.e-12
294 REAL, PARAMETER :: tliq = 269. !all hydrometeors are liquid when T > tliq
296 ! Constants for cloud PDF (mym_condensation)
297 REAL, PARAMETER :: rr2=0.7071068, rrp=0.3989423
299 !>Use Canuto/Kitamura mod (remove Ric and negative TKE) (1:yes, 0:no)
300 !!For more info, see Canuto et al. (2008 JAS) and Kitamura (Journal of the
301 !!Meteorological Society of Japan, Vol. 88, No. 5, pp. 857-864, 2010).
302 !!Note that this change required further modification of other parameters
303 !!above (c2, c3). If you want to remove this option, set c2 and c3 constants
304 !!(above) back to NN2009 values (see commented out lines next to the
305 !!parameters above). This only removes the negative TKE problem
306 !!but does not necessarily improve performance - neutral impact.
307 REAL, PARAMETER :: CKmod=1.
309 !>Use Ito et al. (2015, BLM) scale-aware (0: no, 1: yes). Note that this also has impacts
310 !!on the cloud PDF and mass-flux scheme, using Honnert et al. (2011) similarity function
311 !!for TKE in the upper PBL/cloud layer.
312 REAL, PARAMETER :: scaleaware=1.
314 !>Of the following the options, use one OR the other, not both.
315 !>Adding top-down diffusion driven by cloud-top radiative cooling
316 INTEGER, PARAMETER :: bl_mynn_topdown = 0
317 !>Option to activate downdrafts, from Elynn Wu (0: deactive, 1: active)
318 INTEGER, PARAMETER :: bl_mynn_edmf_dd = 0
320 !>Option to activate heating due to dissipation of TKE (to activate, set to 1.0)
321 INTEGER, PARAMETER :: dheat_opt = 1
323 !Option to activate environmental subsidence in mass-flux scheme
324 LOGICAL, PARAMETER :: env_subs = .false.
326 !Option to switch flux-profile relationship for surface (from Puhales et al. 2020)
327 !0: use original Dyer-Hicks, 1: use Cheng-Brustaert and Blended COARE
328 INTEGER, PARAMETER :: bl_mynn_stfunc = 1
330 !option to print out more stuff for debugging purposes
331 LOGICAL, PARAMETER :: debug_code = .false.
332 INTEGER, PARAMETER :: idbg = 23 !specific i-point to write out
334 ! JAYMES-
335 !> Constants used for empirical calculations of saturation
336 !! vapor pressures (in function "esat") and saturation mixing ratios
337 !! (in function "qsat"), reproduced from module_mp_thompson.F,
338 !! v3.6
339 REAL, PARAMETER:: J0= .611583699E03
340 REAL, PARAMETER:: J1= .444606896E02
341 REAL, PARAMETER:: J2= .143177157E01
342 REAL, PARAMETER:: J3= .264224321E-1
343 REAL, PARAMETER:: J4= .299291081E-3
344 REAL, PARAMETER:: J5= .203154182E-5
345 REAL, PARAMETER:: J6= .702620698E-8
346 REAL, PARAMETER:: J7= .379534310E-11
347 REAL, PARAMETER:: J8=-.321582393E-13
349 REAL, PARAMETER:: K0= .609868993E03
350 REAL, PARAMETER:: K1= .499320233E02
351 REAL, PARAMETER:: K2= .184672631E01
352 REAL, PARAMETER:: K3= .402737184E-1
353 REAL, PARAMETER:: K4= .565392987E-3
354 REAL, PARAMETER:: K5= .521693933E-5
355 REAL, PARAMETER:: K6= .307839583E-7
356 REAL, PARAMETER:: K7= .105785160E-9
357 REAL, PARAMETER:: K8= .161444444E-12
358 ! end-
360 ! Used in WRF-ARW module_physics_init.F
361 INTEGER :: mynn_level
364 CONTAINS
366 ! ==================================================================
367 !>\ingroup gsd_mynn_edmf
368 !! This subroutine is the GSD MYNN-EDNF PBL driver routine,which
369 !! encompassed the majority of the subroutines that comprise the
370 !! procedures that ultimately solve for tendencies of
371 !! \f$U, V, \theta, q_v, q_c, and q_i\f$.
372 !!\section gen_mynn_bl_driver GSD mynn_bl_driver General Algorithm
373 !> @{
374 SUBROUTINE mynn_bl_driver( &
375 &initflag,restart,cycling, &
376 &delt,dz,dx,znt, &
377 &u,v,w,th,sqv3d,sqc3d,sqi3d, &
378 &qnc,qni, &
379 &qnwfa,qnifa,qnbca,ozone, &
380 &p,exner,rho,t3d, &
381 &xland,ts,qsfc,ps, &
382 &ust,ch,hfx,qfx,rmol,wspd, &
383 &uoce,voce, & !ocean current
384 &qke,qke_adv, &
385 &sh3d,sm3d, &
386 &nchem,kdvel,ndvel, & !smoke/chem variables
387 &chem3d,vdep, &
388 &frp,emis_ant_no, &
389 &mix_chem,enh_mix, & !note: these arrays/flags are still under development
390 &rrfs_sd,smoke_dbg, & !end smoke/chem variables
391 &tsq,qsq,cov, &
392 &rublten,rvblten,rthblten, &
393 &rqvblten,rqcblten,rqiblten, &
394 &rqncblten,rqniblten, &
395 &rqnwfablten,rqnifablten, &
396 &rqnbcablten,dozone, &
397 &exch_h,exch_m, &
398 &pblh,kpbl, &
399 &el_pbl, &
400 &dqke,qwt,qshear,qbuoy,qdiss, &
401 &qc_bl,qi_bl,cldfra_bl, &
402 &bl_mynn_tkeadvect, &
403 &tke_budget, &
404 &bl_mynn_cloudpdf, &
405 &bl_mynn_mixlength, &
406 &icloud_bl, &
407 &closure, &
408 &bl_mynn_edmf, &
409 &bl_mynn_edmf_mom, &
410 &bl_mynn_edmf_tke, &
411 &bl_mynn_mixscalars, &
412 &bl_mynn_output, &
413 &bl_mynn_cloudmix,bl_mynn_mixqt, &
414 &edmf_a,edmf_w,edmf_qt, &
415 &edmf_thl,edmf_ent,edmf_qc, &
416 &sub_thl3D,sub_sqv3D, &
417 &det_thl3D,det_sqv3D, &
418 &nupdraft,maxMF,ktop_plume, &
419 &spp_pbl,pattern_spp_pbl, &
420 &rthraten, &
421 &FLAG_QC,FLAG_QI,FLAG_QNC, &
422 &FLAG_QNI,FLAG_QNWFA,FLAG_QNIFA, &
423 &FLAG_QNBCA, &
424 &IDS,IDE,JDS,JDE,KDS,KDE, &
425 &IMS,IME,JMS,JME,KMS,KME, &
426 &ITS,ITE,JTS,JTE,KTS,KTE )
428 !-------------------------------------------------------------------
430 INTEGER, INTENT(in) :: initflag
431 !INPUT NAMELIST OPTIONS:
432 LOGICAL, INTENT(in) :: restart,cycling
433 INTEGER, INTENT(in) :: tke_budget
434 INTEGER, INTENT(in) :: bl_mynn_cloudpdf
435 INTEGER, INTENT(in) :: bl_mynn_mixlength
436 INTEGER, INTENT(in) :: bl_mynn_edmf
437 LOGICAL, INTENT(in) :: bl_mynn_tkeadvect
438 INTEGER, INTENT(in) :: bl_mynn_edmf_mom
439 INTEGER, INTENT(in) :: bl_mynn_edmf_tke
440 INTEGER, INTENT(in) :: bl_mynn_mixscalars
441 INTEGER, INTENT(in) :: bl_mynn_output
442 INTEGER, INTENT(in) :: bl_mynn_cloudmix
443 INTEGER, INTENT(in) :: bl_mynn_mixqt
444 INTEGER, INTENT(in) :: icloud_bl
445 REAL, INTENT(in) :: closure
447 LOGICAL, INTENT(in) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,&
448 FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA
450 LOGICAL, INTENT(IN) :: mix_chem,enh_mix,rrfs_sd,smoke_dbg
452 INTEGER, INTENT(in) :: &
453 & IDS,IDE,JDS,JDE,KDS,KDE &
454 &,IMS,IME,JMS,JME,KMS,KME &
455 &,ITS,ITE,JTS,JTE,KTS,KTE
457 #ifdef HARDCODE_VERTICAL
458 # define kts 1
459 # define kte HARDCODE_VERTICAL
460 #endif
462 ! initflag > 0 for TRUE
463 ! else for FALSE
464 ! closure : <= 2.5; Level 2.5
465 ! 2.5< and <3; Level 2.6
466 ! = 3; Level 3
468 REAL, INTENT(in) :: delt
469 REAL, DIMENSION(IMS:IME), INTENT(in) :: dx
470 REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(in) :: dz, &
471 &u,v,w,th,sqv3D,p,exner,rho,t3d
472 REAL, DIMENSION(IMS:IME,KMS:KME), OPTIONAL, INTENT(in):: &
473 &sqc3D,sqi3D,qni,qnc,qnwfa,qnifa,qnbca
474 REAL, DIMENSION(IMS:IME,KMS:KME), OPTIONAL, INTENT(in):: ozone
475 REAL, DIMENSION(IMS:IME), INTENT(in) :: xland,ust, &
476 &ch,ts,qsfc,ps,hfx,qfx,wspd,uoce,voce,znt
478 REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: &
479 &qke,tsq,qsq,cov,qke_adv
481 REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: &
482 &rublten,rvblten,rthblten,rqvblten,rqcblten, &
483 &rqiblten,rqniblten,rqncblten, &
484 &rqnwfablten,rqnifablten,rqnbcablten
485 REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: dozone
487 REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(in) :: rthraten
489 REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(out) :: &
490 &exch_h,exch_m
492 !These 10 arrays are only allocated when bl_mynn_output > 0
493 REAL, DIMENSION(IMS:IME,KMS:KME), OPTIONAL, INTENT(inout) :: &
494 & edmf_a,edmf_w,edmf_qt,edmf_thl,edmf_ent,edmf_qc, &
495 & sub_thl3D,sub_sqv3D,det_thl3D,det_sqv3D
497 ! REAL, DIMENSION(IMS:IME,KMS:KME) :: &
498 ! & edmf_a_dd,edmf_w_dd,edmf_qt_dd,edmf_thl_dd,edmf_ent_dd,edmf_qc_dd
500 REAL, DIMENSION(IMS:IME), INTENT(inout) :: pblh,rmol
502 REAL, DIMENSION(IMS:IME) :: psig_bl,psig_shcu
504 INTEGER,DIMENSION(IMS:IME),INTENT(INOUT) :: &
505 &kpbl,nupdraft,ktop_plume
507 REAL, DIMENSION(IMS:IME), INTENT(OUT) :: &
508 &maxmf
510 REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: &
511 &el_pbl
513 REAL, DIMENSION(IMS:IME,KMS:KME), optional, INTENT(out) :: &
514 &qwt,qshear,qbuoy,qdiss,dqke
515 ! 3D budget arrays are not allocated when tke_budget == 0
516 ! 1D (local) budget arrays are used for passing between subroutines.
517 REAL, DIMENSION(kts:kte) :: qwt1,qshear1,qbuoy1,qdiss1, &
518 &dqke1,diss_heat
520 REAL, DIMENSION(IMS:IME,KMS:KME), intent(out) :: Sh3D,Sm3D
522 REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: &
523 &qc_bl,qi_bl,cldfra_bl
524 REAL, DIMENSION(KTS:KTE) :: qc_bl1D,qi_bl1D,cldfra_bl1D,&
525 qc_bl1D_old,qi_bl1D_old,cldfra_bl1D_old
527 ! smoke/chemical arrays
528 INTEGER, INTENT(IN ) :: nchem, kdvel, ndvel
529 REAL, DIMENSION(ims:ime, kms:kme, nchem), INTENT(INOUT), optional :: chem3d
530 REAL, DIMENSION(ims:ime, ndvel), INTENT(IN), optional :: vdep
531 REAL, DIMENSION(ims:ime), INTENT(IN), optional :: frp,EMIS_ANT_NO
532 !local
533 REAL, DIMENSION(kts:kte ,nchem) :: chem1
534 REAL, DIMENSION(kts:kte+1,nchem) :: s_awchem1
535 REAL, DIMENSION(ndvel) :: vd1
536 INTEGER :: ic
538 !local vars
539 INTEGER :: ITF,JTF,KTF, IMD,JMD
540 INTEGER :: i,j,k,kproblem
541 REAL, DIMENSION(KTS:KTE) :: thl,thvl,tl,qv1,qc1,qi1,sqw,&
542 &el, dfm, dfh, dfq, tcd, qcd, pdk, pdt, pdq, pdc, &
543 &vt, vq, sgm, thlsg, sqwsg
544 REAL, DIMENSION(KTS:KTE) :: thetav,sh,sm,u1,v1,w1,p1, &
545 &ex1,dz1,th1,tk1,rho1,qke1,tsq1,qsq1,cov1, &
546 &sqv,sqi,sqc,du1,dv1,dth1,dqv1,dqc1,dqi1,ozone1, &
547 &k_m1,k_h1,qni1,dqni1,qnc1,dqnc1,qnwfa1,qnifa1, &
548 &qnbca1,dqnwfa1,dqnifa1,dqnbca1,dozone1
550 !mass-flux variables
551 REAL, DIMENSION(KTS:KTE) :: dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf
552 REAL, DIMENSION(KTS:KTE) :: edmf_a1,edmf_w1,edmf_qt1, &
553 &edmf_thl1,edmf_ent1,edmf_qc1
554 REAL, DIMENSION(KTS:KTE) :: edmf_a_dd1,edmf_w_dd1, &
555 &edmf_qt_dd1,edmf_thl_dd1, &
556 &edmf_ent_dd1,edmf_qc_dd1
557 REAL, DIMENSION(KTS:KTE) :: sub_thl,sub_sqv,sub_u,sub_v,&
558 det_thl,det_sqv,det_sqc,det_u,det_v
559 REAL,DIMENSION(KTS:KTE+1) :: s_aw1,s_awthl1,s_awqt1, &
560 s_awqv1,s_awqc1,s_awu1,s_awv1,s_awqke1, &
561 s_awqnc1,s_awqni1,s_awqnwfa1,s_awqnifa1, &
562 s_awqnbca1
563 REAL,DIMENSION(KTS:KTE+1) :: sd_aw1,sd_awthl1,sd_awqt1, &
564 sd_awqv1,sd_awqc1,sd_awu1,sd_awv1,sd_awqke1
566 REAL, DIMENSION(KTS:KTE+1) :: zw
567 REAL :: cpm,sqcg,flt,fltv,flq,flqv,flqc,pmz,phh,exnerg,zet,phi_m,&
568 & afk,abk,ts_decay, qc_bl2, qi_bl2, &
569 & th_sfc,ztop_plume,sqc9,sqi9,wsp
571 !top-down diffusion
572 REAL, DIMENSION(ITS:ITE) :: maxKHtopdown
573 REAL, DIMENSION(KTS:KTE) :: KHtopdown,TKEprodTD
575 LOGICAL :: INITIALIZE_QKE,problem
577 ! Stochastic fields
578 INTEGER, INTENT(IN) ::spp_pbl
579 REAL, DIMENSION( ims:ime, kms:kme), INTENT(IN),OPTIONAL ::pattern_spp_pbl
580 REAL, DIMENSION(KTS:KTE) ::rstoch_col
582 ! Substepping TKE
583 INTEGER :: nsub
584 real :: 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 nupdraft(its:ite)=0 !int
648 maxmf(its:ite)=0.
649 maxKHtopdown(its:ite)=0.
651 ! DH* CHECK HOW MUCH OF THIS INIT IF-BLOCK IS ACTUALLY NEEDED FOR RESTARTS
652 !> - Within the MYNN-EDMF, there is a dependecy check for the first time step,
653 !! If true, a three-dimensional initialization loop is entered. Within this loop,
654 !! several arrays are initialized and k-oriented (vertical) subroutines are called
655 !! at every i and j point, corresponding to the x- and y- directions, respectively.
656 IF (initflag > 0 .and. .not.restart) THEN
658 !Test to see if we want to initialize qke
659 IF ( (restart .or. cycling)) THEN
660 IF (MAXVAL(QKE(its:ite,kts)) < 0.0002) THEN
661 INITIALIZE_QKE = .TRUE.
662 !print*,"QKE is too small, must initialize"
663 ELSE
664 INITIALIZE_QKE = .FALSE.
665 !print*,"Using background QKE, will not initialize"
666 ENDIF
667 ELSE ! not cycling or restarting:
668 INITIALIZE_QKE = .TRUE.
669 !print*,"not restart nor cycling, must initialize QKE"
670 ENDIF
672 if (.not.restart .or. .not.cycling) THEN
673 Sh3D(its:ite,kts:kte)=0.
674 Sm3D(its:ite,kts:kte)=0.
675 el_pbl(its:ite,kts:kte)=0.
676 tsq(its:ite,kts:kte)=0.
677 qsq(its:ite,kts:kte)=0.
678 cov(its:ite,kts:kte)=0.
679 cldfra_bl(its:ite,kts:kte)=0.
680 qc_bl(its:ite,kts:kte)=0.
681 qke(its:ite,kts:kte)=0.
682 else
683 qc_bl1D(kts:kte)=0.0
684 qi_bl1D(kts:kte)=0.0
685 cldfra_bl1D(kts:kte)=0.0
686 end if
687 dqc1(kts:kte)=0.0
688 dqi1(kts:kte)=0.0
689 dqni1(kts:kte)=0.0
690 dqnc1(kts:kte)=0.0
691 dqnwfa1(kts:kte)=0.0
692 dqnifa1(kts:kte)=0.0
693 dqnbca1(kts:kte)=0.0
694 dozone1(kts:kte)=0.0
695 qc_bl1D_old(kts:kte)=0.0
696 cldfra_bl1D_old(kts:kte)=0.0
697 edmf_a1(kts:kte)=0.0
698 edmf_w1(kts:kte)=0.0
699 edmf_qc1(kts:kte)=0.0
700 edmf_a_dd1(kts:kte)=0.0
701 edmf_w_dd1(kts:kte)=0.0
702 edmf_qc_dd1(kts:kte)=0.0
703 sgm(kts:kte)=0.0
704 vt(kts:kte)=0.0
705 vq(kts:kte)=0.0
707 DO k=KTS,KTE
708 DO i=ITS,ITF
709 exch_m(i,k)=0.
710 exch_h(i,k)=0.
711 ENDDO
712 ENDDO
714 IF (tke_budget .eq. 1) THEN
715 DO k=KTS,KTE
716 DO i=ITS,ITF
717 qWT(i,k)=0.
718 qSHEAR(i,k)=0.
719 qBUOY(i,k)=0.
720 qDISS(i,k)=0.
721 dqke(i,k)=0.
722 ENDDO
723 ENDDO
724 ENDIF
726 DO i=ITS,ITF
727 DO k=KTS,KTE !KTF
728 dz1(k)=dz(i,k)
729 u1(k) = u(i,k)
730 v1(k) = v(i,k)
731 w1(k) = w(i,k)
732 th1(k)=th(i,k)
733 tk1(k)=T3D(i,k)
734 ex1(k)=exner(i,k)
735 rho1(k)=rho(i,k)
736 sqc(k)=sqc3D(i,k) !/(1.+qv(i,k))
737 sqv(k)=sqv3D(i,k) !/(1.+qv(i,k))
738 thetav(k)=th(i,k)*(1.+0.608*sqv(k))
739 IF (icloud_bl > 0) THEN
740 CLDFRA_BL1D(k)=CLDFRA_BL(i,k)
741 QC_BL1D(k)=QC_BL(i,k)
742 QI_BL1D(k)=QI_BL(i,k)
743 ENDIF
744 IF (FLAG_QI ) THEN
745 sqi(k)=sqi3D(i,k) !/(1.+qv(i,k))
746 sqw(k)=sqv(k)+sqc(k)+sqi(k)
747 thl(k)=th1(k) - xlvcp/ex1(k)*sqc(k) &
748 & - xlscp/ex1(k)*sqi(k)
749 !Use form from Tripoli and Cotton (1981) with their
750 !suggested min temperature to improve accuracy.
751 !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) &
752 ! & - xlscp/MAX(tk1(k),TKmin)*sqi(k))
753 !COMPUTE THL USING SGS CLOUDS FOR PBLH DIAG
754 IF(sqc(k)<1e-6 .and. sqi(k)<1e-8 .and. CLDFRA_BL1D(k)>0.001)THEN
755 sqc9=QC_BL1D(k)*CLDFRA_BL1D(k)
756 sqi9=QI_BL1D(k)*CLDFRA_BL1D(k)
757 ELSE
758 sqc9=sqc(k)
759 sqi9=sqi(k)
760 ENDIF
761 thlsg(k)=th1(k) - xlvcp/ex1(k)*sqc9 &
762 & - xlscp/ex1(k)*sqi9
763 sqwsg(k)=sqv(k)+sqc9+sqi9
764 ELSE
765 sqi(k)=0.0
766 sqw(k)=sqv(k)+sqc(k)
767 thl(k)=th1(k)-xlvcp/ex1(k)*sqc(k)
768 !Use form from Tripoli and Cotton (1981) with their
769 !suggested min temperature to improve accuracy.
770 !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k))
771 !COMPUTE THL USING SGS CLOUDS FOR PBLH DIAG
772 IF(sqc(k)<1e-6 .and. CLDFRA_BL1D(k)>0.001)THEN
773 sqc9=QC_BL1D(k)*CLDFRA_BL1D(k)
774 sqi9=0.0
775 ELSE
776 sqc9=sqc(k)
777 sqi9=0.0
778 ENDIF
779 thlsg(k)=th1(k) - xlvcp/ex1(k)*sqc9 &
780 & - xlscp/ex1(k)*sqi9
781 sqwsg(k)=sqv(k)+sqc9+sqi9
782 ENDIF
783 thvl(k)=thlsg(k)*(1.+0.61*sqv(k))
785 IF (k==kts) THEN
786 zw(k)=0.
787 ELSE
788 zw(k)=zw(k-1)+dz(i,k-1)
789 ENDIF
790 IF (INITIALIZE_QKE) THEN
791 !Initialize tke for initial PBLH calc only - using
792 !simple PBLH form of Koracin and Berkowicz (1988, BLM)
793 !to linearly taper off tke towards top of PBL.
794 qke1(k)=5.*ust(i) * MAX((ust(i)*700. - zw(k))/(MAX(ust(i),0.01)*700.), 0.01)
795 ELSE
796 qke1(k)=qke(i,k)
797 ENDIF
798 el(k)=el_pbl(i,k)
799 sh(k)=Sh3D(i,k)
800 sm(k)=Sm3D(i,k)
801 tsq1(k)=tsq(i,k)
802 qsq1(k)=qsq(i,k)
803 cov1(k)=cov(i,k)
804 if (spp_pbl==1) then
805 rstoch_col(k)=pattern_spp_pbl(i,k)
806 else
807 rstoch_col(k)=0.0
808 endif
810 ENDDO
812 zw(kte+1)=zw(kte)+dz(i,kte)
814 !> - Call get_pblh() to calculate hybrid (\f$\theta_{vli}-TKE\f$) PBL height.
815 CALL GET_PBLH(KTS,KTE,PBLH(i),thetav,&
816 & Qke1,zw,dz1,xland(i),KPBL(i))
818 !> - Call scale_aware() to calculate similarity functions for scale-adaptive control
819 !! (\f$P_{\sigma-PBL}\f$ and \f$P_{\sigma-shcu}\f$).
820 IF (scaleaware > 0.) THEN
821 CALL SCALE_AWARE(dx(i),PBLH(i),Psig_bl(i),Psig_shcu(i))
822 ELSE
823 Psig_bl(i)=1.0
824 Psig_shcu(i)=1.0
825 ENDIF
827 ! DH* CHECK IF WE CAN DO WITHOUT CALLING THIS ROUTINE FOR RESTARTS
828 !> - Call mym_initialize() to initializes the mixing length, TKE, \f$\theta^{'2}\f$,
829 !! \f$q^{'2}\f$, and \f$\theta^{'}q^{'}\f$. These variables are calculated after
830 !! obtaining prerequisite variables by calling the following subroutines from
831 !! within mym_initialize(): mym_level2() and mym_length().
832 CALL mym_initialize ( &
833 &kts,kte,xland(i), &
834 &dz1, dx(i), zw, &
835 &u1, v1, thl, sqv, &
836 &thlsg, sqwsg, &
837 &PBLH(i), th1, thetav, sh, sm, &
838 &ust(i), rmol(i), &
839 &el, Qke1, Tsq1, Qsq1, Cov1, &
840 &Psig_bl(i), cldfra_bl1D, &
841 &bl_mynn_mixlength, &
842 &edmf_w1,edmf_a1, &
843 &INITIALIZE_QKE, &
844 &spp_pbl,rstoch_col )
846 IF (.not.restart) THEN
847 !UPDATE 3D VARIABLES
848 DO k=KTS,KTE !KTF
849 el_pbl(i,k)=el(k)
850 sh3d(i,k)=sh(k)
851 sm3d(i,k)=sm(k)
852 qke(i,k)=qke1(k)
853 tsq(i,k)=tsq1(k)
854 qsq(i,k)=qsq1(k)
855 cov(i,k)=cov1(k)
856 ENDDO
857 !initialize qke_adv array if using advection
858 IF (bl_mynn_tkeadvect) THEN
859 DO k=KTS,KTE
860 qke_adv(i,k)=qke1(k)
861 ENDDO
862 ENDIF
863 ENDIF
865 !*** Begin debugging
866 ! IF(I==IMD .AND. J==JMD)THEN
867 ! PRINT*,"MYNN DRIVER INIT: k=",1," sh=",sh(k)
868 ! PRINT*," sqw=",sqw(k)," thl=",thl(k)," k_m=",exch_m(i,k)
869 ! PRINT*," xland=",xland(i)," rmol=",rmol(i)," ust=",ust(i)
870 ! PRINT*," qke=",qke(i,k)," el=",el_pbl(i,k)," tsq=",Tsq(i,k)
871 ! PRINT*," PBLH=",PBLH(i)," u=",u(i,k)," v=",v(i,k)
872 ! ENDIF
873 !*** End debugging
875 ENDDO !end i-loop
877 ENDIF ! end initflag
879 !> - After initializing all required variables, the regular procedures
880 !! performed at every time step are ready for execution.
881 !ACF- copy qke_adv array into qke if using advection
882 IF (bl_mynn_tkeadvect) THEN
883 qke=qke_adv
884 ENDIF
886 DO i=ITS,ITF
887 DO k=KTS,KTE !KTF
888 !JOE-TKE BUDGET
889 IF (tke_budget .eq. 1) THEN
890 dqke(i,k)=qke(i,k)
891 END IF
892 IF (icloud_bl > 0) THEN
893 CLDFRA_BL1D(k)=CLDFRA_BL(i,k)
894 QC_BL1D(k)=QC_BL(i,k)
895 QI_BL1D(k)=QI_BL(i,k)
896 cldfra_bl1D_old(k)=cldfra_bl(i,k)
897 qc_bl1D_old(k)=qc_bl(i,k)
898 qi_bl1D_old(k)=qi_bl(i,k)
899 else
900 CLDFRA_BL1D(k)=0.0
901 QC_BL1D(k)=0.0
902 QI_BL1D(k)=0.0
903 cldfra_bl1D_old(k)=0.0
904 qc_bl1D_old(k)=0.0
905 qi_bl1D_old(k)=0.0
906 ENDIF
907 dz1(k)= dz(i,k)
908 u1(k) = u(i,k)
909 v1(k) = v(i,k)
910 w1(k) = w(i,k)
911 th1(k)= th(i,k)
912 tk1(k)=T3D(i,k)
913 p1(k) = p(i,k)
914 ex1(k)= exner(i,k)
915 rho1(k)=rho(i,k)
916 sqv(k)= sqv3D(i,k) !/(1.+qv(i,k))
917 sqc(k)= sqc3D(i,k) !/(1.+qv(i,k))
918 qv1(k)= sqv(k)/(1.-sqv(k))
919 qc1(k)= sqc(k)/(1.-sqv(k))
920 dqc1(k)=0.0
921 dqi1(k)=0.0
922 dqni1(k)=0.0
923 dqnc1(k)=0.0
924 dqnwfa1(k)=0.0
925 dqnifa1(k)=0.0
926 dqnbca1(k)=0.0
927 dozone1(k)=0.0
928 IF(FLAG_QI)THEN
929 sqi(k)= sqi3D(i,k) !/(1.+qv(i,k))
930 qi1(k)= sqi(k)/(1.-sqv(k))
931 sqw(k)= sqv(k)+sqc(k)+sqi(k)
932 thl(k)= th1(k) - xlvcp/ex1(k)*sqc(k) &
933 & - xlscp/ex1(k)*sqi(k)
934 !Use form from Tripoli and Cotton (1981) with their
935 !suggested min temperature to improve accuracy.
936 !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) &
937 ! & - xlscp/MAX(tk1(k),TKmin)*sqi(k))
938 !COMPUTE THL USING SGS CLOUDS FOR PBLH DIAG
939 IF(sqc(k)<1e-6 .and. sqi(k)<1e-8 .and. CLDFRA_BL1D(k)>0.001)THEN
940 sqc9=QC_BL1D(k)*CLDFRA_BL1D(k)
941 sqi9=QI_BL1D(k)*CLDFRA_BL1D(k)
942 ELSE
943 sqc9=sqc(k)
944 sqi9=sqi(k)
945 ENDIF
946 thlsg(k)=th1(k) - xlvcp/ex1(k)*sqc9 &
947 & - xlscp/ex1(k)*sqi9
948 sqwsg(k)=sqv(k)+sqc9+sqi9
949 ELSE
950 qi1(k)=0.0
951 sqi(k)=0.0
952 sqw(k)= sqv(k)+sqc(k)
953 thl(k)= th1(k)-xlvcp/ex1(k)*sqc(k)
954 !Use form from Tripoli and Cotton (1981) with their
955 !suggested min temperature to improve accuracy.
956 !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k))
957 !COMPUTE THL USING SGS CLOUDS FOR PBLH DIAG
958 IF(sqc(k)<1e-6 .and. CLDFRA_BL1D(k)>0.001)THEN
959 sqc9=QC_BL1D(k)*CLDFRA_BL1D(k)
960 sqi9=QI_BL1D(k)*CLDFRA_BL1D(k)
961 ELSE
962 sqc9=sqc(k)
963 sqi9=0.0
964 ENDIF
965 thlsg(k)=th1(k) - xlvcp/ex1(k)*sqc9 &
966 & - xlscp/ex1(k)*sqi9
967 ENDIF
968 thetav(k)=th1(k)*(1.+0.608*sqv(k))
969 thvl(k) =thlsg(k) *(1.+0.608*sqv(k))
971 IF (FLAG_QNI ) THEN
972 qni1(k)=qni(i,k)
973 ELSE
974 qni1(k)=0.0
975 ENDIF
976 IF (FLAG_QNC ) THEN
977 qnc1(k)=qnc(i,k)
978 ELSE
979 qnc1(k)=0.0
980 ENDIF
981 IF (FLAG_QNWFA ) THEN
982 qnwfa1(k)=qnwfa(i,k)
983 ELSE
984 qnwfa1(k)=0.0
985 ENDIF
986 IF (FLAG_QNIFA ) THEN
987 qnifa1(k)=qnifa(i,k)
988 ELSE
989 qnifa1(k)=0.0
990 ENDIF
991 IF (FLAG_QNBCA .and. PRESENT(qnbca)) THEN
992 qnbca1(k)=qnbca(i,k)
993 ELSE
994 qnbca1(k)=0.0
995 ENDIF
996 IF (PRESENT(ozone)) THEN
997 ozone1(k)=ozone(i,k)
998 ELSE
999 ozone1(k)=0.0
1000 ENDIF
1001 el(k) = el_pbl(i,k)
1002 qke1(k)=qke(i,k)
1003 sh(k) =sh3d(i,k)
1004 sm(k) =sm3d(i,k)
1005 tsq1(k)=tsq(i,k)
1006 qsq1(k)=qsq(i,k)
1007 cov1(k)=cov(i,k)
1008 if (spp_pbl==1) then
1009 rstoch_col(k)=pattern_spp_pbl(i,k)
1010 else
1011 rstoch_col(k)=0.0
1012 endif
1014 !edmf
1015 edmf_a1(k)=0.0
1016 edmf_w1(k)=0.0
1017 edmf_qc1(k)=0.0
1018 s_aw1(k)=0.
1019 s_awthl1(k)=0.
1020 s_awqt1(k)=0.
1021 s_awqv1(k)=0.
1022 s_awqc1(k)=0.
1023 s_awu1(k)=0.
1024 s_awv1(k)=0.
1025 s_awqke1(k)=0.
1026 s_awqnc1(k)=0.
1027 s_awqni1(k)=0.
1028 s_awqnwfa1(k)=0.
1029 s_awqnifa1(k)=0.
1030 s_awqnbca1(k)=0.
1031 ![EWDD]
1032 edmf_a_dd1(k)=0.0
1033 edmf_w_dd1(k)=0.0
1034 edmf_qc_dd1(k)=0.0
1035 sd_aw1(k)=0.
1036 sd_awthl1(k)=0.
1037 sd_awqt1(k)=0.
1038 sd_awqv1(k)=0.
1039 sd_awqc1(k)=0.
1040 sd_awu1(k)=0.
1041 sd_awv1(k)=0.
1042 sd_awqke1(k)=0.
1043 sub_thl(k)=0.
1044 sub_sqv(k)=0.
1045 sub_u(k)=0.
1046 sub_v(k)=0.
1047 det_thl(k)=0.
1048 det_sqv(k)=0.
1049 det_sqc(k)=0.
1050 det_u(k)=0.
1051 det_v(k)=0.
1053 IF (k==kts) THEN
1054 zw(k)=0.
1055 ELSE
1056 zw(k)=zw(k-1)+dz(i,k-1)
1057 ENDIF
1058 ENDDO ! end k
1060 !initialize smoke/chem arrays (if used):
1061 if ( mix_chem ) then
1062 do ic = 1,ndvel
1063 vd1(ic) = vdep(i,ic) ! dry deposition velocity
1064 enddo
1065 do k = kts,kte
1066 do ic = 1,nchem
1067 chem1(k,ic) = chem3d(i,k,ic)
1068 s_awchem1(k,ic)=0.
1069 enddo
1070 enddo
1071 else
1072 do ic = 1,ndvel
1073 vd1(ic) = 0. ! dry deposition velocity
1074 enddo
1075 do k = kts,kte
1076 do ic = 1,nchem
1077 chem1(k,ic) = 0.
1078 s_awchem1(k,ic)=0.
1079 enddo
1080 enddo
1081 endif
1083 zw(kte+1)=zw(kte)+dz(i,kte)
1084 !EDMF
1085 s_aw1(kte+1)=0.
1086 s_awthl1(kte+1)=0.
1087 s_awqt1(kte+1)=0.
1088 s_awqv1(kte+1)=0.
1089 s_awqc1(kte+1)=0.
1090 s_awu1(kte+1)=0.
1091 s_awv1(kte+1)=0.
1092 s_awqke1(kte+1)=0.
1093 s_awqnc1(kte+1)=0.
1094 s_awqni1(kte+1)=0.
1095 s_awqnwfa1(kte+1)=0.
1096 s_awqnifa1(kte+1)=0.
1097 s_awqnbca1(kte+1)=0.
1098 sd_aw1(kte+1)=0.
1099 sd_awthl1(kte+1)=0.
1100 sd_awqt1(kte+1)=0.
1101 sd_awqv1(kte+1)=0.
1102 sd_awqc1(kte+1)=0.
1103 sd_awu1(kte+1)=0.
1104 sd_awv1(kte+1)=0.
1105 sd_awqke1(kte+1)=0.
1106 IF ( mix_chem ) THEN
1107 DO ic = 1,nchem
1108 s_awchem1(kte+1,ic)=0.
1109 ENDDO
1110 ENDIF
1112 !> - Call get_pblh() to calculate the hybrid \f$\theta_{vli}-TKE\f$
1113 !! PBL height diagnostic.
1114 CALL GET_PBLH(KTS,KTE,PBLH(i),thetav,&
1115 & Qke1,zw,dz1,xland(i),KPBL(i))
1117 !> - Call scale_aware() to calculate the similarity functions,
1118 !! \f$P_{\sigma-PBL}\f$ and \f$P_{\sigma-shcu}\f$, to control
1119 !! the scale-adaptive behaviour for the local and nonlocal
1120 !! components, respectively.
1121 IF (scaleaware > 0.) THEN
1122 CALL SCALE_AWARE(dx(i),PBLH(i),Psig_bl(i),Psig_shcu(i))
1123 ELSE
1124 Psig_bl(i)=1.0
1125 Psig_shcu(i)=1.0
1126 ENDIF
1128 sqcg= 0.0 !ill-defined variable; qcg has been removed
1129 cpm=cp*(1.+0.84*qv1(kts))
1130 exnerg=(ps(i)/p1000mb)**rcp
1132 !-----------------------------------------------------
1133 !ORIGINAL CODE
1134 !flt = hfx(i)/( rho(i,kts)*cpm ) &
1135 ! +xlvcp*ch(i)*(sqc(kts)/exner(i,kts) -sqcg/exnerg)
1136 !flq = qfx(i)/ rho(i,kts) &
1137 ! -ch(i)*(sqc(kts) -sqcg )
1138 !-----------------------------------------------------
1139 flqv = qfx(i)/rho1(kts)
1140 flqc = 0.0 !currently no sea-spray fluxes, fog settling hangled elsewhere
1141 th_sfc = ts(i)/ex1(kts)
1143 ! TURBULENT FLUX FOR TKE BOUNDARY CONDITIONS
1144 flq =flqv+flqc !! LATENT
1145 flt =hfx(i)/(rho1(kts)*cpm )-xlvcp*flqc/ex1(kts) !! Temperature flux
1146 fltv=flt + flqv*p608*th_sfc !! Virtual temperature flux
1148 ! Update 1/L using updated sfc heat flux and friction velocity
1149 rmol(i) = -karman*gtr*fltv/max(ust(i)**3,1.0e-6)
1150 zet = 0.5*dz(i,kts)*rmol(i)
1151 zet = MAX(zet, -20.)
1152 zet = MIN(zet, 20.)
1153 !if(i.eq.idbg)print*,"updated z/L=",zet
1154 if (bl_mynn_stfunc == 0) then
1155 !Original Kansas-type stability functions
1156 if ( zet >= 0.0 ) then
1157 pmz = 1.0 + (cphm_st-1.0) * zet
1158 phh = 1.0 + cphh_st * zet
1159 else
1160 pmz = 1.0/ (1.0-cphm_unst*zet)**0.25 - zet
1161 phh = 1.0/SQRT(1.0-cphh_unst*zet)
1162 end if
1163 else
1164 !Updated stability functions (Puhales, 2020)
1165 phi_m = phim(zet)
1166 pmz = phi_m - zet
1167 phh = phih(zet)
1168 end if
1170 !> - Call mym_condensation() to calculate the nonconvective component
1171 !! of the subgrid cloud fraction and mixing ratio as well as the functions
1172 !! used to calculate the buoyancy flux. Different cloud PDFs can be
1173 !! selected by use of the namelist parameter \p bl_mynn_cloudpdf.
1175 CALL mym_condensation ( kts,kte, &
1176 &dx(i),dz1,zw,xland(i), &
1177 &thl,sqw,sqv,sqc,sqi, &
1178 &p1,ex1,tsq1,qsq1,cov1, &
1179 &Sh,el,bl_mynn_cloudpdf, &
1180 &qc_bl1D,qi_bl1D,cldfra_bl1D, &
1181 &PBLH(i),HFX(i), &
1182 &Vt, Vq, th1, sgm, rmol(i), &
1183 &spp_pbl, rstoch_col )
1185 !> - Add TKE source driven by cloud top cooling
1186 !! Calculate the buoyancy production of TKE from cloud-top cooling when
1187 !! \p bl_mynn_topdown =1.
1188 IF (bl_mynn_topdown.eq.1)then
1189 CALL topdown_cloudrad(kts,kte,dz1,zw, &
1190 &xland(i),kpbl(i),PBLH(i), &
1191 &sqc,sqi,sqw,thl,th1,ex1,p1,rho1,thetav, &
1192 &cldfra_bl1D,rthraten(i,:), &
1193 &maxKHtopdown(i),KHtopdown,TKEprodTD )
1194 ELSE
1195 maxKHtopdown(i) = 0.0
1196 KHtopdown(kts:kte) = 0.0
1197 TKEprodTD(kts:kte) = 0.0
1198 ENDIF
1200 IF (bl_mynn_edmf > 0) THEN
1201 !PRINT*,"Calling DMP Mass-Flux: i= ",i
1202 CALL DMP_mf( &
1203 &kts,kte,delt,zw,dz1,p1,rho1, &
1204 &bl_mynn_edmf_mom, &
1205 &bl_mynn_edmf_tke, &
1206 &bl_mynn_mixscalars, &
1207 &u1,v1,w1,th1,thl,thetav,tk1, &
1208 &sqw,sqv,sqc,qke1, &
1209 &qnc1,qni1,qnwfa1,qnifa1,qnbca1, &
1210 &ex1,Vt,Vq,sgm, &
1211 &ust(i),flt,fltv,flq,flqv, &
1212 &PBLH(i),KPBL(i),DX(i), &
1213 &xland(i),th_sfc, &
1214 ! now outputs - tendencies
1215 ! &,dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf &
1216 ! outputs - updraft properties
1217 & edmf_a1,edmf_w1,edmf_qt1, &
1218 & edmf_thl1,edmf_ent1,edmf_qc1, &
1219 ! for the solver
1220 & s_aw1,s_awthl1,s_awqt1, &
1221 & s_awqv1,s_awqc1, &
1222 & s_awu1,s_awv1,s_awqke1, &
1223 & s_awqnc1,s_awqni1, &
1224 & s_awqnwfa1,s_awqnifa1,s_awqnbca1,&
1225 & sub_thl,sub_sqv, &
1226 & sub_u,sub_v, &
1227 & det_thl,det_sqv,det_sqc, &
1228 & det_u,det_v, &
1229 ! chem/smoke mixing
1230 & nchem,chem1,s_awchem1, &
1231 & mix_chem, &
1232 & qc_bl1D,cldfra_bl1D, &
1233 & qc_bl1D_old,cldfra_bl1D_old, &
1234 & FLAG_QC,FLAG_QI, &
1235 & FLAG_QNC,FLAG_QNI, &
1236 & FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA,&
1237 & Psig_shcu(i), &
1238 & nupdraft(i),ktop_plume(i), &
1239 & maxmf(i),ztop_plume, &
1240 & spp_pbl,rstoch_col )
1241 ENDIF
1243 IF (bl_mynn_edmf_dd == 1) THEN
1244 CALL DDMF_JPL(kts,kte,delt,zw,dz1,p1, &
1245 &u1,v1,th1,thl,thetav,tk1, &
1246 sqw,sqv,sqc,rho1,ex1, &
1247 &ust(i),flt,flq, &
1248 &PBLH(i),KPBL(i), &
1249 &edmf_a_dd1,edmf_w_dd1,edmf_qt_dd1, &
1250 &edmf_thl_dd1,edmf_ent_dd1, &
1251 &edmf_qc_dd1, &
1252 &sd_aw1,sd_awthl1,sd_awqt1, &
1253 &sd_awqv1,sd_awqc1,sd_awu1,sd_awv1, &
1254 &sd_awqke1, &
1255 &qc_bl1d,cldfra_bl1d, &
1256 &rthraten(i,:) )
1257 ENDIF
1259 !Capability to substep the eddy-diffusivity portion
1260 !do nsub = 1,2
1261 delt2 = delt !*0.5 !only works if topdown=0
1263 CALL mym_turbulence ( &
1264 &kts,kte,xland(i),closure, &
1265 &dz1, DX(i), zw, &
1266 &u1, v1, thl, thetav, sqc, sqw, &
1267 &thlsg, sqwsg, &
1268 &qke1, tsq1, qsq1, cov1, &
1269 &vt, vq, &
1270 &rmol(i), flt, flq, &
1271 &PBLH(i),th1, &
1272 &Sh,Sm,el, &
1273 &Dfm,Dfh,Dfq, &
1274 &Tcd,Qcd,Pdk, &
1275 &Pdt,Pdq,Pdc, &
1276 &qWT1,qSHEAR1,qBUOY1,qDISS1, &
1277 &tke_budget, &
1278 &Psig_bl(i),Psig_shcu(i), &
1279 &cldfra_bl1D,bl_mynn_mixlength, &
1280 &edmf_w1,edmf_a1, &
1281 &TKEprodTD, &
1282 &spp_pbl,rstoch_col)
1284 !> - Call mym_predict() to solve TKE and
1285 !! \f$\theta^{'2}, q^{'2}, and \theta^{'}q^{'}\f$
1286 !! for the following time step.
1287 CALL mym_predict (kts,kte,closure, &
1288 &delt2, dz1, &
1289 &ust(i), flt, flq, pmz, phh, &
1290 &el, dfq, rho1, pdk, pdt, pdq, pdc,&
1291 &Qke1, Tsq1, Qsq1, Cov1, &
1292 &s_aw1, s_awqke1, bl_mynn_edmf_tke,&
1293 &qWT1, qDISS1,tke_budget ) !! TKE budget (Puhales, 2020)
1295 if (dheat_opt > 0) then
1296 DO k=kts,kte-1
1297 ! Set max dissipative heating rate to 7.2 K per hour
1298 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)
1299 ! Limit heating above 100 mb:
1300 diss_heat(k) = diss_heat(k) * exp(-10000./MAX(p1(k),1.))
1301 ENDDO
1302 diss_heat(kte) = 0.
1303 else
1304 diss_heat(1:kte) = 0.
1305 endif
1307 !> - Call mynn_tendencies() to solve for tendencies of
1308 !! \f$U, V, \theta, q_{v}, q_{c}, and q_{i}\f$.
1309 CALL mynn_tendencies(kts,kte,i, &
1310 &delt, dz1, rho1, &
1311 &u1, v1, th1, tk1, qv1, &
1312 &qc1, qi1, qnc1, qni1, &
1313 &ps(i), p1, ex1, thl, &
1314 &sqv, sqc, sqi, sqw, &
1315 &qnwfa1, qnifa1, qnbca1, ozone1, &
1316 &ust(i),flt,flq,flqv,flqc, &
1317 &wspd(i),uoce(i),voce(i), &
1318 &tsq1, qsq1, cov1, &
1319 &tcd, qcd, &
1320 &dfm, dfh, dfq, &
1321 &Du1, Dv1, Dth1, Dqv1, &
1322 &Dqc1, Dqi1, Dqnc1, Dqni1, &
1323 &Dqnwfa1, Dqnifa1, Dqnbca1, &
1324 &Dozone1, &
1325 &diss_heat, &
1326 ! mass flux components
1327 &s_aw1,s_awthl1,s_awqt1, &
1328 &s_awqv1,s_awqc1,s_awu1,s_awv1, &
1329 &s_awqnc1,s_awqni1, &
1330 &s_awqnwfa1,s_awqnifa1,s_awqnbca1,&
1331 &sd_aw1,sd_awthl1,sd_awqt1, &
1332 &sd_awqv1,sd_awqc1, &
1333 sd_awu1,sd_awv1, &
1334 &sub_thl,sub_sqv, &
1335 &sub_u,sub_v, &
1336 &det_thl,det_sqv,det_sqc, &
1337 &det_u,det_v, &
1338 &FLAG_QC,FLAG_QI,FLAG_QNC, &
1339 &FLAG_QNI,FLAG_QNWFA,FLAG_QNIFA, &
1340 &FLAG_QNBCA, &
1341 &cldfra_bl1d, &
1342 &bl_mynn_cloudmix, &
1343 &bl_mynn_mixqt, &
1344 &bl_mynn_edmf, &
1345 &bl_mynn_edmf_mom, &
1346 &bl_mynn_mixscalars )
1349 IF ( mix_chem ) THEN
1350 IF ( rrfs_sd ) THEN
1351 CALL mynn_mix_chem(kts,kte,i, &
1352 &delt, dz1, pblh(i), &
1353 &nchem, kdvel, ndvel, &
1354 &chem1, vd1, &
1355 &rho1,flt, &
1356 &tcd, qcd, &
1357 &dfh, &
1358 &s_aw1,s_awchem1, &
1359 &emis_ant_no(i), &
1360 &frp(i), rrfs_sd, &
1361 &enh_mix, smoke_dbg )
1362 ELSE
1363 CALL mynn_mix_chem(kts,kte,i, &
1364 &delt, dz1, pblh(i), &
1365 &nchem, kdvel, ndvel, &
1366 &chem1, vd1, &
1367 &rho1,flt, &
1368 &tcd, qcd, &
1369 &dfh, &
1370 &s_aw1,s_awchem1, &
1371 &zero, &
1372 &zero, rrfs_sd, &
1373 &enh_mix, smoke_dbg )
1374 ENDIF
1375 DO ic = 1,nchem
1376 DO k = kts,kte
1377 chem3d(i,k,ic) = max(1.e-12, chem1(k,ic))
1378 ENDDO
1379 ENDDO
1380 ENDIF
1382 CALL retrieve_exchange_coeffs(kts,kte,&
1383 &dfm, dfh, dz1, K_m1, K_h1)
1385 !UPDATE 3D ARRAYS
1386 do k=kts,kte
1387 exch_m(i,k)=K_m1(k)
1388 exch_h(i,k)=K_h1(k)
1389 rublten(i,k)=du1(k)
1390 rvblten(i,k)=dv1(k)
1391 rthblten(i,k)=dth1(k)
1392 rqvblten(i,k)=dqv1(k)
1393 if (bl_mynn_cloudmix > 0) then
1394 if (present(sqc3D) .and. flag_qc) rqcblten(i,k)=dqc1(k)
1395 if (present(sqi3D) .and. flag_qi) rqiblten(i,k)=dqi1(k)
1396 else
1397 if (present(sqc3D) .and. flag_qc) rqcblten(i,k)=0.
1398 if (present(sqi3D) .and. flag_qi) rqiblten(i,k)=0.
1399 endif
1400 if (bl_mynn_cloudmix > 0 .and. bl_mynn_mixscalars > 0) then
1401 if (present(qnc) .and. flag_qnc) rqncblten(i,k)=dqnc1(k)
1402 if (present(qni) .and. flag_qni) rqniblten(i,k)=dqni1(k)
1403 if (present(qnwfa) .and. flag_qnwfa) rqnwfablten(i,k)=dqnwfa1(k)
1404 if (present(qnifa) .and. flag_qnifa) rqnifablten(i,k)=dqnifa1(k)
1405 if (present(qnbca) .and. flag_qnbca) rqnbcablten(i,k)=dqnbca1(k)
1406 else
1407 if (present(qnc) .and. flag_qnc) rqncblten(i,k)=0.
1408 if (present(qni) .and. flag_qni) rqniblten(i,k)=0.
1409 if (present(qnwfa) .and. flag_qnwfa) rqnwfablten(i,k)=0.
1410 if (present(qnifa) .and. flag_qnifa) rqnifablten(i,k)=0.
1411 if (present(qnbca) .and. flag_qnbca) rqnbcablten(i,k)=0.
1412 endif
1413 dozone(i,k)=dozone1(k)
1415 if (icloud_bl > 0) then
1416 qc_bl(i,k)=qc_bl1D(k)
1417 qi_bl(i,k)=qi_bl1D(k)
1418 cldfra_bl(i,k)=cldfra_bl1D(k)
1419 endif
1421 el_pbl(i,k)=el(k)
1422 qke(i,k)=qke1(k)
1423 tsq(i,k)=tsq1(k)
1424 qsq(i,k)=qsq1(k)
1425 cov(i,k)=cov1(k)
1426 sh3d(i,k)=sh(k)
1427 sm3d(i,k)=sm(k)
1428 enddo !end-k
1430 if (tke_budget .eq. 1) then
1431 !! TKE budget is now given in m**2/s**-3 (Puhales, 2020)
1432 !! Lower boundary condtions (using similarity relationships such as the prognostic equation for Qke)
1433 k=kts
1434 qSHEAR1(k)=4.*(ust(i)**3*phi_m/(karman*dz(i,k)))-qSHEAR1(k+1) !! staggered
1435 qBUOY1(k)=4.*(-ust(i)**3*zet/(karman*dz(i,k)))-qBUOY1(k+1) !! staggered
1436 !! unstaggering SHEAR and BUOY and trasfering all TKE budget to 3D array
1437 do k = kts,kte-1
1438 qSHEAR(i,k)=0.5*(qSHEAR1(k)+qSHEAR1(k+1)) !!! unstaggering in z
1439 qBUOY(i,k)=0.5*(qBUOY1(k)+qBUOY1(k+1)) !!! unstaggering in z
1440 qWT(i,k)=qWT1(k)
1441 qDISS(i,k)=qDISS1(k)
1442 dqke(i,k)=(qke1(k)-dqke(i,k))*0.5/delt
1443 enddo
1444 !! Upper boundary conditions
1445 k=kte
1446 qSHEAR(i,k)=0.
1447 qBUOY(i,k)=0.
1448 qWT(i,k)=0.
1449 qDISS(i,k)=0.
1450 dqke(i,k)=0.
1451 endif
1453 !update updraft/downdraft properties
1454 if (bl_mynn_output > 0) THEN !research mode == 1
1455 if (bl_mynn_edmf > 0) THEN
1456 DO k = kts,kte
1457 edmf_a(i,k)=edmf_a1(k)
1458 edmf_w(i,k)=edmf_w1(k)
1459 edmf_qt(i,k)=edmf_qt1(k)
1460 edmf_thl(i,k)=edmf_thl1(k)
1461 edmf_ent(i,k)=edmf_ent1(k)
1462 edmf_qc(i,k)=edmf_qc1(k)
1463 sub_thl3D(i,k)=sub_thl(k)
1464 sub_sqv3D(i,k)=sub_sqv(k)
1465 det_thl3D(i,k)=det_thl(k)
1466 det_sqv3D(i,k)=det_sqv(k)
1467 ENDDO
1468 endif
1469 ! if (bl_mynn_edmf_dd > 0) THEN
1470 ! DO k = kts,kte
1471 ! edmf_a_dd(i,k)=edmf_a_dd1(k)
1472 ! edmf_w_dd(i,k)=edmf_w_dd1(k)
1473 ! edmf_qt_dd(i,k)=edmf_qt_dd1(k)
1474 ! edmf_thl_dd(i,k)=edmf_thl_dd1(k)
1475 ! edmf_ent_dd(i,k)=edmf_ent_dd1(k)
1476 ! edmf_qc_dd(i,k)=edmf_qc_dd1(k)
1477 ! ENDDO
1478 ! ENDIF
1479 ENDIF
1481 !*** Begin debug prints
1482 IF ( debug_code .and. (i .eq. idbg)) THEN
1483 IF ( ABS(QFX(i))>.001)print*,&
1484 "SUSPICIOUS VALUES AT: i=",i," QFX=",QFX(i)
1485 IF ( ABS(HFX(i))>1100.)print*,&
1486 "SUSPICIOUS VALUES AT: i=",i," HFX=",HFX(i)
1487 DO k = kts,kte
1488 IF ( sh(k) < 0. .OR. sh(k)> 200.)print*,&
1489 "SUSPICIOUS VALUES AT: i,k=",i,k," sh=",sh(k)
1490 IF ( ABS(vt(k)) > 2.0 )print*,&
1491 "SUSPICIOUS VALUES AT: i,k=",i,k," vt=",vt(k)
1492 IF ( ABS(vq(k)) > 7000.)print*,&
1493 "SUSPICIOUS VALUES AT: i,k=",i,k," vq=",vq(k)
1494 IF ( qke(i,k) < -1. .OR. qke(i,k)> 200.)print*,&
1495 "SUSPICIOUS VALUES AT: i,k=",i,k," qke=",qke(i,k)
1496 IF ( el_pbl(i,k) < 0. .OR. el_pbl(i,k)> 1500.)print*,&
1497 "SUSPICIOUS VALUES AT: i,k=",i,k," el_pbl=",el_pbl(i,k)
1498 IF ( exch_m(i,k) < 0. .OR. exch_m(i,k)> 2000.)print*,&
1499 "SUSPICIOUS VALUES AT: i,k=",i,k," exxch_m=",exch_m(i,k)
1500 IF (icloud_bl > 0) then
1501 IF( cldfra_bl(i,k) < 0.0 .OR. cldfra_bl(i,k)> 1.)THEN
1502 PRINT*,"SUSPICIOUS VALUES: CLDFRA_BL=",cldfra_bl(i,k)," qc_bl=",QC_BL(i,k)
1503 ENDIF
1504 ENDIF
1506 !IF (I==IMD .AND. J==JMD) THEN
1507 ! PRINT*,"MYNN DRIVER END: k=",k," sh=",sh(k)
1508 ! PRINT*," sqw=",sqw(k)," thl=",thl(k)," exch_m=",exch_m(i,k)
1509 ! PRINT*," xland=",xland(i)," rmol=",rmol(i)," ust=",ust(i)
1510 ! PRINT*," qke=",qke(i,k)," el=",el_pbl(i,k)," tsq=",tsq(i,k)
1511 ! PRINT*," PBLH=",PBLH(i)," u=",u(i,k)," v=",v(i,k)
1512 ! PRINT*," vq=",vq(k)," vt=",vt(k)
1513 !ENDIF
1514 ENDDO !end-k
1515 ENDIF
1516 !*** End debug prints
1518 !JOE-add tke_pbl for coupling w/shallow-cu schemes (TKE_PBL = QKE/2.)
1519 ! TKE_PBL is defined on interfaces, while QKE is at middle of layer.
1520 !tke_pbl(i,kts) = 0.5*MAX(qke(i,kts),1.0e-10)
1521 !DO k = kts+1,kte
1522 ! afk = dz1(k)/( dz1(k)+dz1(k-1) )
1523 ! abk = 1.0 -afk
1524 ! tke_pbl(i,k) = 0.5*MAX(qke(i,k)*abk+qke(i,k-1)*afk,1.0e-3)
1525 !ENDDO
1527 ENDDO !end i-loop
1529 !ACF copy qke into qke_adv if using advection
1530 IF (bl_mynn_tkeadvect) THEN
1531 qke_adv=qke
1532 ENDIF
1533 !ACF-end
1535 #ifdef HARDCODE_VERTICAL
1536 # undef kts
1537 # undef kte
1538 #endif
1540 END SUBROUTINE mynn_bl_driver
1541 !> @}
1543 !=======================================================================
1544 ! SUBROUTINE mym_initialize:
1545 !
1546 ! Input variables:
1547 ! iniflag : <>0; turbulent quantities will be initialized
1548 ! = 0; turbulent quantities have been already
1549 ! given, i.e., they will not be initialized
1550 ! nx, nz : Dimension sizes of the
1551 ! x and z directions, respectively
1552 ! tref : Reference temperature (K)
1553 ! dz(nz) : Vertical grid spacings (m)
1554 ! # dz(nz)=dz(nz-1)
1555 ! zw(nz+1) : Heights of the walls of the grid boxes (m)
1556 ! # zw(1)=0.0 and zw(k)=zw(k-1)+dz(k-1)
1557 ! exner(nx,nz) : Exner function at zw*h+zg (J/kg K)
1558 ! defined by c_p*( p_basic/1000hPa )^kappa
1559 ! This is usually computed by integrating
1560 ! d(pi0)/dz = -h*g/tref.
1561 ! rmo(nx) : Inverse of the Obukhov length (m^(-1))
1562 ! flt, flq(nx) : Turbulent fluxes of potential temperature and
1563 ! total water, respectively:
1564 ! flt=-u_*Theta_* (K m/s)
1565 ! flq=-u_*qw_* (kg/kg m/s)
1566 ! ust(nx) : Friction velocity (m/s)
1567 ! pmz(nx) : phi_m-zeta at z1*h+z0, where z1 (=0.5*dz(1))
1568 ! is the first grid point above the surafce, z0
1569 ! the roughness length and zeta=(z1*h+z0)*rmo
1570 ! phh(nx) : phi_h at z1*h+z0
1571 ! u, v(nx,nz) : Components of the horizontal wind (m/s)
1572 ! thl(nx,nz) : Liquid water potential temperature
1573 ! (K)
1574 ! qw(nx,nz) : Total water content Q_w (kg/kg)
1575 !
1576 ! Output variables:
1577 ! ql(nx,nz) : Liquid water content (kg/kg)
1578 ! vt, vq(nx,nz) : Functions for computing the buoyancy flux
1579 ! qke(nx,nz) : Twice the turbulent kinetic energy q^2
1580 ! (m^2/s^2)
1581 ! tsq(nx,nz) : Variance of Theta_l (K^2)
1582 ! qsq(nx,nz) : Variance of Q_w
1583 ! cov(nx,nz) : Covariance of Theta_l and Q_w (K)
1584 ! el(nx,nz) : Master length scale L (m)
1585 ! defined on the walls of the grid boxes
1586 !
1587 ! Work arrays: see subroutine mym_level2
1588 ! pd?(nx,nz,ny) : Half of the production terms at Level 2
1589 ! defined on the walls of the grid boxes
1590 ! qkw(nx,nz,ny) : q on the walls of the grid boxes (m/s)
1591 !
1592 ! # As to dtl, ...gh, see subroutine mym_turbulence.
1593 !
1594 !-------------------------------------------------------------------
1596 !>\ingroup gsd_mynn_edmf
1597 !! This subroutine initializes the mixing length, TKE, \f$\theta^{'2}\f$,
1598 !! \f$q^{'2}\f$, and \f$\theta^{'}q^{'}\f$.
1599 !!\section gen_mym_ini GSD MYNN-EDMF mym_initialize General Algorithm
1600 !> @{
1601 SUBROUTINE mym_initialize ( &
1602 & kts,kte,xland, &
1603 & dz, dx, zw, &
1604 & u, v, thl, qw, &
1605 & thlsg, qwsg, &
1606 ! & ust, rmo, pmz, phh, flt, flq, &
1607 & zi, theta, thetav, sh, sm, &
1608 & ust, rmo, el, &
1609 & Qke, Tsq, Qsq, Cov, Psig_bl, cldfra_bl1D, &
1610 & bl_mynn_mixlength, &
1611 & edmf_w1,edmf_a1, &
1612 & INITIALIZE_QKE, &
1613 & spp_pbl,rstoch_col)
1614 !
1615 !-------------------------------------------------------------------
1617 INTEGER, INTENT(IN) :: kts,kte
1618 INTEGER, INTENT(IN) :: bl_mynn_mixlength
1619 LOGICAL, INTENT(IN) :: INITIALIZE_QKE
1620 ! REAL, INTENT(IN) :: ust, rmo, pmz, phh, flt, flq
1621 REAL, INTENT(IN) :: ust, rmo, Psig_bl, dx, xland
1622 REAL, DIMENSION(kts:kte), INTENT(in) :: dz
1623 REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw
1624 REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,qw,cldfra_bl1D,&
1625 edmf_w1,edmf_a1
1626 REAL, DIMENSION(kts:kte), INTENT(out) :: tsq,qsq,cov
1627 REAL, DIMENSION(kts:kte), INTENT(inout) :: el,qke
1628 REAL, DIMENSION(kts:kte) :: &
1629 &ql,pdk,pdt,pdq,pdc,dtl,dqw,dtv,&
1630 &gm,gh,sm,sh,qkw,vt,vq
1631 INTEGER :: k,l,lmax
1632 REAL :: phm,vkz,elq,elv,b1l,b2l,pmz=1.,phh=1.,flt=0.,flq=0.,tmpq
1633 REAL :: zi
1634 REAL, DIMENSION(kts:kte) :: theta,thetav,thlsg,qwsg
1636 REAL, DIMENSION(kts:kte) :: rstoch_col
1637 INTEGER ::spp_pbl
1639 !> - At first ql, vt and vq are set to zero.
1640 DO k = kts,kte
1641 ql(k) = 0.0
1642 vt(k) = 0.0
1643 vq(k) = 0.0
1644 END DO
1645 !
1646 !> - Call mym_level2() to calculate the stability functions at level 2.
1647 CALL mym_level2 ( kts,kte, &
1648 & dz, &
1649 & u, v, thl, thetav, qw, &
1650 & thlsg, qwsg, &
1651 & ql, vt, vq, &
1652 & dtl, dqw, dtv, gm, gh, sm, sh )
1653 !
1654 ! ** Preliminary setting **
1656 el (kts) = 0.0
1657 IF (INITIALIZE_QKE) THEN
1658 !qke(kts) = ust**2 * ( b1*pmz )**(2.0/3.0)
1659 qke(kts) = 1.5 * ust**2 * ( b1*pmz )**(2.0/3.0)
1660 DO k = kts+1,kte
1661 !qke(k) = 0.0
1662 !linearly taper off towards top of pbl
1663 qke(k)=qke(kts)*MAX((ust*700. - zw(k))/(MAX(ust,0.01)*700.), 0.01)
1664 ENDDO
1665 ENDIF
1666 !
1667 phm = phh*b2 / ( b1*pmz )**(1.0/3.0)
1668 tsq(kts) = phm*( flt/ust )**2
1669 qsq(kts) = phm*( flq/ust )**2
1670 cov(kts) = phm*( flt/ust )*( flq/ust )
1671 !
1672 DO k = kts+1,kte
1673 vkz = karman*zw(k)
1674 el (k) = vkz/( 1.0 + vkz/100.0 )
1675 ! qke(k) = 0.0
1676 !
1677 tsq(k) = 0.0
1678 qsq(k) = 0.0
1679 cov(k) = 0.0
1680 END DO
1681 !
1682 ! ** Initialization with an iterative manner **
1683 ! ** lmax is the iteration count. This is arbitrary. **
1684 lmax = 5
1685 !
1686 DO l = 1,lmax
1687 !
1688 !> - call mym_length() to calculate the master length scale.
1689 CALL mym_length ( &
1690 & kts,kte,xland, &
1691 & dz, dx, zw, &
1692 & rmo, flt, flq, &
1693 & vt, vq, &
1694 & u, v, qke, &
1695 & dtv, &
1696 & el, &
1697 & zi,theta, &
1698 & qkw,Psig_bl,cldfra_bl1D, &
1699 & bl_mynn_mixlength, &
1700 & edmf_w1,edmf_a1 )
1701 !
1702 DO k = kts+1,kte
1703 elq = el(k)*qkw(k)
1704 pdk(k) = elq*( sm(k)*gm(k) + &
1705 & sh(k)*gh(k) )
1706 pdt(k) = elq* sh(k)*dtl(k)**2
1707 pdq(k) = elq* sh(k)*dqw(k)**2
1708 pdc(k) = elq* sh(k)*dtl(k)*dqw(k)
1709 END DO
1710 !
1711 ! ** Strictly, vkz*h(i,j) -> karman*( 0.5*dz(1)*h(i,j)+z0 ) **
1712 vkz = karman*0.5*dz(kts)
1713 elv = 0.5*( el(kts+1)+el(kts) ) / vkz
1714 IF (INITIALIZE_QKE)THEN
1715 !qke(kts) = ust**2 * ( b1*pmz*elv )**(2.0/3.0)
1716 qke(kts) = 1.0 * MAX(ust,0.02)**2 * ( b1*pmz*elv )**(2.0/3.0)
1717 ENDIF
1719 phm = phh*b2 / ( b1*pmz/elv**2 )**(1.0/3.0)
1720 tsq(kts) = phm*( flt/ust )**2
1721 qsq(kts) = phm*( flq/ust )**2
1722 cov(kts) = phm*( flt/ust )*( flq/ust )
1724 DO k = kts+1,kte-1
1725 b1l = b1*0.25*( el(k+1)+el(k) )
1726 !tmpq=MAX(b1l*( pdk(k+1)+pdk(k) ),qkemin)
1727 !add MIN to limit unreasonable QKE
1728 tmpq=MIN(MAX(b1l*( pdk(k+1)+pdk(k) ),qkemin),125.)
1729 ! PRINT *,'tmpqqqqq',tmpq,pdk(k+1),pdk(k)
1730 IF (INITIALIZE_QKE)THEN
1731 qke(k) = tmpq**twothirds
1732 ENDIF
1734 IF ( qke(k) .LE. 0.0 ) THEN
1735 b2l = 0.0
1736 ELSE
1737 b2l = b2*( b1l/b1 ) / SQRT( qke(k) )
1738 END IF
1740 tsq(k) = b2l*( pdt(k+1)+pdt(k) )
1741 qsq(k) = b2l*( pdq(k+1)+pdq(k) )
1742 cov(k) = b2l*( pdc(k+1)+pdc(k) )
1743 END DO
1745 END DO
1747 !! qke(kts)=qke(kts+1)
1748 !! tsq(kts)=tsq(kts+1)
1749 !! qsq(kts)=qsq(kts+1)
1750 !! cov(kts)=cov(kts+1)
1752 IF (INITIALIZE_QKE)THEN
1753 qke(kts)=0.5*(qke(kts)+qke(kts+1))
1754 qke(kte)=qke(kte-1)
1755 ENDIF
1756 tsq(kte)=tsq(kte-1)
1757 qsq(kte)=qsq(kte-1)
1758 cov(kte)=cov(kte-1)
1760 !
1761 ! RETURN
1763 END SUBROUTINE mym_initialize
1764 !> @}
1766 !
1767 ! ==================================================================
1768 ! SUBROUTINE mym_level2:
1769 !
1770 ! Input variables: see subroutine mym_initialize
1771 !
1772 ! Output variables:
1773 ! dtl(nx,nz,ny) : Vertical gradient of Theta_l (K/m)
1774 ! dqw(nx,nz,ny) : Vertical gradient of Q_w
1775 ! dtv(nx,nz,ny) : Vertical gradient of Theta_V (K/m)
1776 ! gm (nx,nz,ny) : G_M divided by L^2/q^2 (s^(-2))
1777 ! gh (nx,nz,ny) : G_H divided by L^2/q^2 (s^(-2))
1778 ! sm (nx,nz,ny) : Stability function for momentum, at Level 2
1779 ! sh (nx,nz,ny) : Stability function for heat, at Level 2
1780 !
1781 ! These are defined on the walls of the grid boxes.
1782 !
1784 !>\ingroup gsd_mynn_edmf
1785 !! This subroutine calculates the level 2, non-dimensional wind shear
1786 !! \f$G_M\f$ and vertical temperature gradient \f$G_H\f$ as well as
1787 !! the level 2 stability funcitons \f$S_h\f$ and \f$S_m\f$.
1788 !!\param kts horizontal dimension
1789 !!\param kte vertical dimension
1790 !!\param dz vertical grid spacings (\f$m\f$)
1791 !!\param u west-east component of the horizontal wind (\f$m s^{-1}\f$)
1792 !!\param v south-north component of the horizontal wind (\f$m s^{-1}\f$)
1793 !!\param thl liquid water potential temperature
1794 !!\param qw total water content \f$Q_w\f$
1795 !!\param ql liquid water content (\f$kg kg^{-1}\f$)
1796 !!\param vt
1797 !!\param vq
1798 !!\param dtl vertical gradient of \f$\theta_l\f$ (\f$K m^{-1}\f$)
1799 !!\param dqw vertical gradient of \f$Q_w\f$
1800 !!\param dtv vertical gradient of \f$\theta_V\f$ (\f$K m^{-1}\f$)
1801 !!\param gm \f$G_M\f$ divided by \f$L^{2}/q^{2}\f$ (\f$s^{-2}\f$)
1802 !!\param gh \f$G_H\f$ divided by \f$L^{2}/q^{2}\f$ (\f$s^{-2}\f$)
1803 !!\param sm stability function for momentum, at Level 2
1804 !!\param sh stability function for heat, at Level 2
1805 !!\section gen_mym_level2 GSD MYNN-EDMF mym_level2 General Algorithm
1806 !! @ {
1807 SUBROUTINE mym_level2 (kts,kte, &
1808 & dz, &
1809 & u, v, thl, thetav, qw, &
1810 & thlsg, qwsg, &
1811 & ql, vt, vq, &
1812 & dtl, dqw, dtv, gm, gh, sm, sh )
1813 !
1814 !-------------------------------------------------------------------
1816 INTEGER, INTENT(IN) :: kts,kte
1818 #ifdef HARDCODE_VERTICAL
1819 # define kts 1
1820 # define kte HARDCODE_VERTICAL
1821 #endif
1823 REAL, DIMENSION(kts:kte), INTENT(in) :: dz
1824 REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,qw,ql,vt,vq,&
1825 thetav,thlsg,qwsg
1826 REAL, DIMENSION(kts:kte), INTENT(out) :: &
1827 &dtl,dqw,dtv,gm,gh,sm,sh
1829 INTEGER :: k
1831 REAL :: rfc,f1,f2,rf1,rf2,smc,shc,&
1832 &ri1,ri2,ri3,ri4,duz,dtz,dqz,vtt,vqq,dtq,dzk,afk,abk,ri,rf
1834 REAL :: a2fac
1836 ! ev = 2.5e6
1837 ! tv0 = 0.61*tref
1838 ! tv1 = 1.61*tref
1839 ! gtr = 9.81/tref
1840 !
1841 rfc = g1/( g1+g2 )
1842 f1 = b1*( g1-c1 ) +3.0*a2*( 1.0 -c2 )*( 1.0-c5 ) &
1843 & +2.0*a1*( 3.0-2.0*c2 )
1844 f2 = b1*( g1+g2 ) -3.0*a1*( 1.0 -c2 )
1845 rf1 = b1*( g1-c1 )/f1
1846 rf2 = b1* g1 /f2
1847 smc = a1 /a2* f1/f2
1848 shc = 3.0*a2*( g1+g2 )
1849 !
1850 ri1 = 0.5/smc
1851 ri2 = rf1*smc
1852 ri3 = 4.0*rf2*smc -2.0*ri2
1853 ri4 = ri2**2
1854 !
1855 DO k = kts+1,kte
1856 dzk = 0.5 *( dz(k)+dz(k-1) )
1857 afk = dz(k)/( dz(k)+dz(k-1) )
1858 abk = 1.0 -afk
1859 duz = ( u(k)-u(k-1) )**2 +( v(k)-v(k-1) )**2
1860 duz = duz /dzk**2
1861 dtz = ( thl(k)-thl(k-1) )/( dzk )
1862 !Alternatively, use SGS clouds for thl
1863 !dtz = ( thlsg(k)-thlsg(k-1) )/( dzk )
1864 dqz = ( qw(k)-qw(k-1) )/( dzk )
1865 !Alternatively, use SGS clouds for qw
1866 !dqz = ( qwsg(k)-qwsg(k-1) )/( dzk )
1867 !
1868 vtt = 1.0 +vt(k)*abk +vt(k-1)*afk ! Beta-theta in NN09, Eq. 39
1869 vqq = tv0 +vq(k)*abk +vq(k-1)*afk ! Beta-q
1870 dtq = vtt*dtz +vqq*dqz
1871 !Alternatively, use theta-v without the SGS clouds
1872 !dtq = ( thetav(k)-thetav(k-1) )/( dzk )
1873 !
1874 dtl(k) = dtz
1875 dqw(k) = dqz
1876 dtv(k) = dtq
1877 !? dtv(i,j,k) = dtz +tv0*dqz
1878 !? : +( xlv/pi0(i,j,k)-tv1 )
1879 !? : *( ql(i,j,k)-ql(i,j,k-1) )/( dzk*h(i,j) )
1880 !
1881 gm (k) = duz
1882 gh (k) = -dtq*gtr
1883 !
1884 ! ** Gradient Richardson number **
1885 ri = -gh(k)/MAX( duz, 1.0e-10 )
1887 !a2fac is needed for the Canuto/Kitamura mod
1888 IF (CKmod .eq. 1) THEN
1889 a2fac = 1./(1. + MAX(ri,0.0))
1890 ELSE
1891 a2fac = 1.
1892 ENDIF
1894 rfc = g1/( g1+g2 )
1895 f1 = b1*( g1-c1 ) +3.0*a2*a2fac *( 1.0 -c2 )*( 1.0-c5 ) &
1896 & +2.0*a1*( 3.0-2.0*c2 )
1897 f2 = b1*( g1+g2 ) -3.0*a1*( 1.0 -c2 )
1898 rf1 = b1*( g1-c1 )/f1
1899 rf2 = b1* g1 /f2
1900 smc = a1 /(a2*a2fac)* f1/f2
1901 shc = 3.0*(a2*a2fac)*( g1+g2 )
1903 ri1 = 0.5/smc
1904 ri2 = rf1*smc
1905 ri3 = 4.0*rf2*smc -2.0*ri2
1906 ri4 = ri2**2
1908 ! ** Flux Richardson number **
1909 rf = MIN( ri1*( ri + ri2-SQRT(ri**2 - ri3*ri + ri4) ), rfc )
1910 !
1911 sh (k) = shc*( rfc-rf )/( 1.0-rf )
1912 sm (k) = smc*( rf1-rf )/( rf2-rf ) * sh(k)
1913 END DO
1914 !
1915 ! RETURN
1917 #ifdef HARDCODE_VERTICAL
1918 # undef kts
1919 # undef kte
1920 #endif
1922 END SUBROUTINE mym_level2
1923 !! @}
1925 ! ==================================================================
1926 ! SUBROUTINE mym_length:
1927 !
1928 ! Input variables: see subroutine mym_initialize
1929 !
1930 ! Output variables: see subroutine mym_initialize
1931 !
1932 ! Work arrays:
1933 ! elt(nx,ny) : Length scale depending on the PBL depth (m)
1934 ! vsc(nx,ny) : Velocity scale q_c (m/s)
1935 ! at first, used for computing elt
1936 !
1937 ! NOTE: the mixing lengths are meant to be calculated at the full-
1938 ! sigmal levels (or interfaces beween the model layers).
1939 !
1940 !>\ingroup gsd_mynn_edmf
1941 !! This subroutine calculates the mixing lengths.
1942 SUBROUTINE mym_length ( &
1943 & kts,kte,xland, &
1944 & dz, dx, zw, &
1945 & rmo, flt, flq, &
1946 & vt, vq, &
1947 & u1, v1, qke, &
1948 & dtv, &
1949 & el, &
1950 & zi, theta, qkw, &
1951 & Psig_bl, cldfra_bl1D, &
1952 & bl_mynn_mixlength, &
1953 & edmf_w1,edmf_a1 )
1955 !-------------------------------------------------------------------
1957 INTEGER, INTENT(IN) :: kts,kte
1959 #ifdef HARDCODE_VERTICAL
1960 # define kts 1
1961 # define kte HARDCODE_VERTICAL
1962 #endif
1964 INTEGER, INTENT(IN) :: bl_mynn_mixlength
1965 REAL, DIMENSION(kts:kte), INTENT(in) :: dz
1966 REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw
1967 REAL, INTENT(in) :: rmo,flt,flq,Psig_bl,dx,xland
1968 REAL, DIMENSION(kts:kte), INTENT(IN) :: u1,v1,qke,vt,vq,cldfra_bl1D,&
1969 edmf_w1,edmf_a1
1970 REAL, DIMENSION(kts:kte), INTENT(out) :: qkw, el
1971 REAL, DIMENSION(kts:kte), INTENT(in) :: dtv
1973 REAL :: elt,vsc
1975 REAL, DIMENSION(kts:kte), INTENT(IN) :: theta
1976 REAL, DIMENSION(kts:kte) :: qtke,elBLmin,elBLavg,thetaw
1977 REAL :: wt,wt2,zi,zi2,h1,h2,hs,elBLmin0,elBLavg0,cldavg
1979 ! THE FOLLOWING CONSTANTS ARE IMPORTANT FOR REGULATING THE
1980 ! MIXING LENGTHS:
1981 REAL :: cns, & !< for surface layer (els) in stable conditions
1982 alp1, & !< for turbulent length scale (elt)
1983 alp2, & !< for buoyancy length scale (elb)
1984 alp3, & !< for buoyancy enhancement factor of elb
1985 alp4, & !< for surface layer (els) in unstable conditions
1986 alp5, & !< for BouLac mixing length or above PBLH
1987 alp6 !< for mass-flux/
1989 !THE FOLLOWING LIMITS DO NOT DIRECTLY AFFECT THE ACTUAL PBLH.
1990 !THEY ONLY IMPOSE LIMITS ON THE CALCULATION OF THE MIXING LENGTH
1991 !SCALES SO THAT THE BOULAC MIXING LENGTH (IN FREE ATMOS) DOES
1992 !NOT ENCROACH UPON THE BOUNDARY LAYER MIXING LENGTH (els, elb & elt).
1993 REAL, PARAMETER :: minzi = 300. !< min mixed-layer height
1994 REAL, PARAMETER :: maxdz = 750. !< max (half) transition layer depth
1995 !! =0.3*2500 m PBLH, so the transition
1996 !! layer stops growing for PBLHs > 2.5 km.
1997 REAL, PARAMETER :: mindz = 300. !< 300 !min (half) transition layer depth
1999 !SURFACE LAYER LENGTH SCALE MODS TO REDUCE IMPACT IN UPPER BOUNDARY LAYER
2000 REAL, PARAMETER :: ZSLH = 100. !< Max height correlated to surface conditions (m)
2001 REAL, PARAMETER :: CSL = 2. !< CSL = constant of proportionality to L O(1)
2004 INTEGER :: i,j,k
2005 REAL :: afk,abk,zwk,zwk1,dzk,qdz,vflx,bv,tau_cloud,wstar,elb,els, &
2006 & elf,el_stab,el_mf,el_stab_mf,elb_mf, &
2007 & PBLH_PLUS_ENT,Uonset,Ugrid,wt_u,el_les
2008 REAL, PARAMETER :: ctau = 1000. !constant for tau_cloud
2010 ! tv0 = 0.61*tref
2011 ! gtr = 9.81/tref
2013 SELECT CASE(bl_mynn_mixlength)
2015 CASE (0) ! ORIGINAL MYNN MIXING LENGTH + BouLac
2017 cns = 2.7
2018 alp1 = 0.23
2019 alp2 = 1.0
2020 alp3 = 5.0
2021 alp4 = 100.
2022 alp5 = 0.3
2024 ! Impose limits on the height integration for elt and the transition layer depth
2025 zi2 = MIN(10000.,zw(kte-2)) !originally integrated to model top, not just 10 km.
2026 h1=MAX(0.3*zi2,mindz)
2027 h1=MIN(h1,maxdz) ! 1/2 transition layer depth
2028 h2=h1/2.0 ! 1/4 transition layer depth
2030 qkw(kts) = SQRT(MAX(qke(kts),1.0e-10))
2031 DO k = kts+1,kte
2032 afk = dz(k)/( dz(k)+dz(k-1) )
2033 abk = 1.0 -afk
2034 qkw(k) = SQRT(MAX(qke(k)*abk+qke(k-1)*afk,1.0e-3))
2035 END DO
2037 elt = 1.0e-5
2038 vsc = 1.0e-5
2040 ! ** Strictly, zwk*h(i,j) -> ( zwk*h(i,j)+z0 ) **
2041 k = kts+1
2042 zwk = zw(k)
2043 DO WHILE (zwk .LE. zi2+h1)
2044 dzk = 0.5*( dz(k)+dz(k-1) )
2045 qdz = MAX( qkw(k)-qmin, 0.03 )*dzk
2046 elt = elt +qdz*zwk
2047 vsc = vsc +qdz
2048 k = k+1
2049 zwk = zw(k)
2050 END DO
2052 elt = alp1*elt/vsc
2053 vflx = ( vt(kts)+1.0 )*flt +( vq(kts)+tv0 )*flq
2054 vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**(1.0/3.0)
2056 ! ** Strictly, el(i,k=1) is not zero. **
2057 el(kts) = 0.0
2058 zwk1 = zw(kts+1)
2060 DO k = kts+1,kte
2061 zwk = zw(k) !full-sigma levels
2063 ! ** Length scale limited by the buoyancy effect **
2064 IF ( dtv(k) .GT. 0.0 ) THEN
2065 bv = SQRT( gtr*dtv(k) )
2066 elb = alp2*qkw(k) / bv &
2067 & *( 1.0 + alp3/alp2*&
2068 &SQRT( vsc/( bv*elt ) ) )
2069 elf = alp2 * qkw(k)/bv
2071 ELSE
2072 elb = 1.0e10
2073 elf = elb
2074 ENDIF
2076 ! ** Length scale in the surface layer **
2077 IF ( rmo .GT. 0.0 ) THEN
2078 els = karman*zwk/(1.0+cns*MIN( zwk*rmo, zmax ))
2079 ELSE
2080 els = karman*zwk*( 1.0 - alp4* zwk*rmo )**0.2
2081 END IF
2083 ! ** HARMONC AVERGING OF MIXING LENGTH SCALES:
2084 ! el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf)
2085 ! el(k) = elb/( elb/elt+elb/els+1.0 )
2087 wt=.5*TANH((zwk - (zi2+h1))/h2) + .5
2089 el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf)
2091 END DO
2093 CASE (1) !NONLOCAL (using BouLac) FORM OF MIXING LENGTH
2095 ugrid = sqrt(u1(kts)**2 + v1(kts)**2)
2096 uonset= 15.
2097 wt_u = (1.0 - min(max(ugrid - uonset, 0.0)/30.0, 0.5))
2098 cns = 3.5
2099 alp1 = 0.22 !was 0.21
2100 alp2 = 0.25 !was 0.3
2101 alp3 = 2.0 * wt_u !taper off bouyancy enhancement in shear-driven pbls
2102 alp4 = 5.0
2103 alp5 = 0.3
2104 alp6 = 50.
2106 ! Impose limits on the height integration for elt and the transition layer depth
2107 zi2=MAX(zi,200.) !minzi)
2108 h1=MAX(0.3*zi2,200.)
2109 h1=MIN(h1,500.) ! 1/2 transition layer depth
2110 h2=h1/2.0 ! 1/4 transition layer depth
2112 qtke(kts)=MAX(0.5*qke(kts), 0.01) !tke at full sigma levels
2113 thetaw(kts)=theta(kts) !theta at full-sigma levels
2114 qkw(kts) = SQRT(MAX(qke(kts),1.0e-10))
2116 DO k = kts+1,kte
2117 afk = dz(k)/( dz(k)+dz(k-1) )
2118 abk = 1.0 -afk
2119 qkw(k) = SQRT(MAX(qke(k)*abk+qke(k-1)*afk,1.0e-3))
2120 qtke(k) = 0.5*(qkw(k)**2) ! q -> TKE
2121 thetaw(k)= theta(k)*abk + theta(k-1)*afk
2122 END DO
2124 elt = 1.0e-5
2125 vsc = 1.0e-5
2127 ! ** Strictly, zwk*h(i,j) -> ( zwk*h(i,j)+z0 ) **
2128 k = kts+1
2129 zwk = zw(k)
2130 DO WHILE (zwk .LE. zi2+h1)
2131 dzk = 0.5*( dz(k)+dz(k-1) )
2132 qdz = min(max( qkw(k)-qmin, 0.03 ), 30.0)*dzk
2133 elt = elt +qdz*zwk
2134 vsc = vsc +qdz
2135 k = k+1
2136 zwk = zw(k)
2137 END DO
2139 elt = MIN( MAX( alp1*elt/vsc, 10.), 400.)
2140 !avoid use of buoyancy flux functions which are ill-defined at the surface
2141 !vflx = ( vt(kts)+1.0 )*flt + ( vq(kts)+tv0 )*flq
2142 vflx = flt
2143 vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**onethird
2145 ! ** Strictly, el(i,j,1) is not zero. **
2146 el(kts) = 0.0
2147 zwk1 = zw(kts+1) !full-sigma levels
2149 ! COMPUTE BouLac mixing length
2150 CALL boulac_length(kts,kte,zw,dz,qtke,thetaw,elBLmin,elBLavg)
2152 DO k = kts+1,kte
2153 zwk = zw(k) !full-sigma levels
2155 ! ** Length scale limited by the buoyancy effect **
2156 IF ( dtv(k) .GT. 0.0 ) THEN
2157 bv = max( sqrt( gtr*dtv(k) ), 0.001)
2158 elb = MAX(alp2*qkw(k), &
2159 & alp6*edmf_a1(k-1)*edmf_w1(k-1)) / bv &
2160 & *( 1.0 + alp3*SQRT( vsc/(bv*elt) ) )
2161 elb = MIN(elb, zwk)
2162 elf = 0.65 * qkw(k)/bv
2163 elBLavg(k) = MAX(elBLavg(k), alp6*edmf_a1(k-1)*edmf_w1(k-1)/bv)
2164 ELSE
2165 elb = 1.0e10
2166 elf = elb
2167 ENDIF
2169 ! ** Length scale in the surface layer **
2170 IF ( rmo .GT. 0.0 ) THEN
2171 els = karman*zwk/(1.0+cns*MIN( zwk*rmo, zmax ))
2172 ELSE
2173 els = karman*zwk*( 1.0 - alp4* zwk*rmo )**0.2
2174 END IF
2176 ! ** NOW BLEND THE MIXING LENGTH SCALES:
2177 wt=.5*TANH((zwk - (zi2+h1))/h2) + .5
2179 !add blending to use BouLac mixing length in free atmos;
2180 !defined relative to the PBLH (zi) + transition layer (h1)
2181 !el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf)
2182 !try squared-blending
2183 el(k) = SQRT( els**2/(1. + (els**2/elt**2) +(els**2/elb**2)))
2184 el(k) = MIN (el(k), elf)
2185 el(k) = el(k)*(1.-wt) + alp5*elBLavg(k)*wt
2187 ! include scale-awareness, except for original MYNN
2188 el(k) = el(k)*Psig_bl
2190 END DO
2192 CASE (2) !Local (mostly) mixing length formulation
2194 Uonset = 3.5 + dz(kts)*0.1
2195 Ugrid = sqrt(u1(kts)**2 + v1(kts)**2)
2196 cns = 3.5 !JOE-test * (1.0 - MIN(MAX(Ugrid - Uonset, 0.0)/10.0, 1.0))
2197 alp1 = 0.22 !0.21
2198 alp2 = 0.25 !0.30
2199 alp3 = 2.0 !1.5
2200 alp4 = 5.0
2201 alp5 = alp2 !like alp2, but for free atmosphere
2202 alp6 = 50.0 !used for MF mixing length
2204 ! Impose limits on the height integration for elt and the transition layer depth
2205 !zi2=MAX(zi,minzi)
2206 zi2=MAX(zi, 200.)
2207 !h1=MAX(0.3*zi2,mindz)
2208 !h1=MIN(h1,maxdz) ! 1/2 transition layer depth
2209 h1=MAX(0.3*zi2,200.)
2210 h1=MIN(h1,500.)
2211 h2=h1*0.5 ! 1/4 transition layer depth
2213 qtke(kts)=MAX(0.5*qke(kts),0.01) !tke at full sigma levels
2214 qkw(kts) = SQRT(MAX(qke(kts),1.0e-4))
2216 DO k = kts+1,kte
2217 afk = dz(k)/( dz(k)+dz(k-1) )
2218 abk = 1.0 -afk
2219 qkw(k) = SQRT(MAX(qke(k)*abk+qke(k-1)*afk,1.0e-3))
2220 qtke(k) = 0.5*qkw(k)**2 ! qkw -> TKE
2221 END DO
2223 elt = 1.0e-5
2224 vsc = 1.0e-5
2226 ! ** Strictly, zwk*h(i,j) -> ( zwk*h(i,j)+z0 ) **
2227 PBLH_PLUS_ENT = MAX(zi+h1, 100.)
2228 k = kts+1
2229 zwk = zw(k)
2230 DO WHILE (zwk .LE. PBLH_PLUS_ENT)
2231 dzk = 0.5*( dz(k)+dz(k-1) )
2232 qdz = min(max( qkw(k)-qmin, 0.03 ), 30.0)*dzk
2233 elt = elt +qdz*zwk
2234 vsc = vsc +qdz
2235 k = k+1
2236 zwk = zw(k)
2237 END DO
2239 elt = MIN( MAX(alp1*elt/vsc, 10.), 400.)
2240 !avoid use of buoyancy flux functions which are ill-defined at the surface
2241 !vflx = ( vt(kts)+1.0 )*flt +( vq(kts)+tv0 )*flq
2242 vflx = flt
2243 vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**onethird
2245 ! ** Strictly, el(i,j,1) is not zero. **
2246 el(kts) = 0.0
2247 zwk1 = zw(kts+1)
2249 DO k = kts+1,kte
2250 zwk = zw(k) !full-sigma levels
2251 dzk = 0.5*( dz(k)+dz(k-1) )
2252 cldavg = 0.5*(cldfra_bl1D(k-1)+cldfra_bl1D(k))
2254 ! ** Length scale limited by the buoyancy effect **
2255 IF ( dtv(k) .GT. 0.0 ) THEN
2256 !impose min value on bv
2257 bv = MAX( SQRT( gtr*dtv(k) ), 0.001)
2258 !elb_mf = alp2*qkw(k) / bv &
2259 elb_mf = MAX(alp2*qkw(k), &
2260 & alp6*edmf_a1(k-1)*edmf_w1(k-1)) / bv &
2261 & *( 1.0 + alp3*SQRT( vsc/( bv*elt ) ) )
2262 elb = MIN(MAX(alp5*qkw(k), alp6*edmf_a1(k)*edmf_w1(k))/bv, zwk)
2264 !tau_cloud = MIN(MAX(0.5*zi/((gtr*zi*MAX(vflx,1.0e-4))**onethird),30.),150.)
2265 wstar = 1.25*(gtr*zi*MAX(vflx,1.0e-4))**onethird
2266 tau_cloud = MIN(MAX(ctau * wstar/grav, 30.), 150.)
2267 !minimize influence of surface heat flux on tau far away from the PBLH.
2268 wt=.5*TANH((zwk - (zi2+h1))/h2) + .5
2269 tau_cloud = tau_cloud*(1.-wt) + 50.*wt
2270 elf = MIN(MAX(tau_cloud*SQRT(MIN(qtke(k),40.)), &
2271 & alp6*edmf_a1(k)*edmf_w1(k)/bv), zwk)
2273 !IF (zwk > zi .AND. elf > 400.) THEN
2274 ! ! COMPUTE BouLac mixing length
2275 ! !CALL boulac_length0(k,kts,kte,zw,dz,qtke,thetaw,elBLmin0,elBLavg0)
2276 ! !elf = alp5*elBLavg0
2277 ! elf = MIN(MAX(50.*SQRT(qtke(k)), 400.), zwk)
2278 !ENDIF
2280 ELSE
2281 ! use version in development for RAP/HRRR 2016
2282 ! JAYMES-
2283 ! tau_cloud is an eddy turnover timescale;
2284 ! see Teixeira and Cheinet (2004), Eq. 1, and
2285 ! Cheinet and Teixeira (2003), Eq. 7. The
2286 ! coefficient 0.5 is tuneable. Expression in
2287 ! denominator is identical to vsc (a convective
2288 ! velocity scale), except that elt is relpaced
2289 ! by zi, and zero is replaced by 1.0e-4 to
2290 ! prevent division by zero.
2291 !tau_cloud = MIN(MAX(0.5*zi/((gtr*zi*MAX(vflx,1.0e-4))**onethird),50.),150.)
2292 wstar = 1.25*(gtr*zi*MAX(vflx,1.0e-4))**onethird
2293 tau_cloud = MIN(MAX(ctau * wstar/grav, 50.), 200.)
2294 !minimize influence of surface heat flux on tau far away from the PBLH.
2295 wt=.5*TANH((zwk - (zi2+h1))/h2) + .5
2296 !tau_cloud = tau_cloud*(1.-wt) + 50.*wt
2297 tau_cloud = tau_cloud*(1.-wt) + MAX(100.,dzk*0.25)*wt
2299 elb = MIN(tau_cloud*SQRT(MIN(qtke(k),40.)), zwk)
2300 !elf = elb
2301 elf = elb !/(1. + (elb/800.)) !bound free-atmos mixing length to < 800 m.
2302 elb_mf = elb
2303 END IF
2304 elf = elf/(1. + (elf/800.)) !bound free-atmos mixing length to < 800 m.
2305 elb_mf = MAX(elb_mf, 0.01) !to avoid divide-by-zero below
2307 ! ** Length scale in the surface layer **
2308 IF ( rmo .GT. 0.0 ) THEN
2309 els = karman*zwk/(1.0+cns*MIN( zwk*rmo, zmax ))
2310 ELSE
2311 els = karman*zwk*( 1.0 - alp4* zwk*rmo )**0.2
2312 END IF
2314 ! ** NOW BLEND THE MIXING LENGTH SCALES:
2315 wt=.5*TANH((zwk - (zi2+h1))/h2) + .5
2317 !try squared-blending
2318 el(k) = SQRT( els**2/(1. + (els**2/elt**2) +(els**2/elb_mf**2)))
2319 el(k) = el(k)*(1.-wt) + elf*wt
2321 ! include scale-awareness. For now, use simple asymptotic kz -> 12 m (should be ~dz).
2322 el_les= MIN(els/(1. + (els/12.)), elb_mf)
2323 el(k) = el(k)*Psig_bl + (1.-Psig_bl)*el_les
2325 END DO
2327 END SELECT
2330 #ifdef HARDCODE_VERTICAL
2331 # undef kts
2332 # undef kte
2333 #endif
2335 END SUBROUTINE mym_length
2337 ! ==================================================================
2338 !>\ingroup gsd_mynn_edmf
2339 !! This subroutine was taken from the BouLac scheme in WRF-ARW and modified for
2340 !! integration into the MYNN PBL scheme. WHILE loops were added to reduce the
2341 !! computational expense. This subroutine computes the length scales up and down
2342 !! and then computes the min, average of the up/down length scales, and also
2343 !! considers the distance to the surface.
2344 !\param dlu the distance a parcel can be lifted upwards give a finite
2345 ! amount of TKE.
2346 !\param dld the distance a parcel can be displaced downwards given a
2347 ! finite amount of TKE.
2348 !\param lb1 the minimum of the length up and length down
2349 !\param lb2 the average of the length up and length down
2350 SUBROUTINE boulac_length0(k,kts,kte,zw,dz,qtke,theta,lb1,lb2)
2351 !
2352 ! NOTE: This subroutine was taken from the BouLac scheme in WRF-ARW
2353 ! and modified for integration into the MYNN PBL scheme.
2354 ! WHILE loops were added to reduce the computational expense.
2355 ! This subroutine computes the length scales up and down
2356 ! and then computes the min, average of the up/down
2357 ! length scales, and also considers the distance to the
2358 ! surface.
2359 !
2360 ! dlu = the distance a parcel can be lifted upwards give a finite
2361 ! amount of TKE.
2362 ! dld = the distance a parcel can be displaced downwards given a
2363 ! finite amount of TKE.
2364 ! lb1 = the minimum of the length up and length down
2365 ! lb2 = the average of the length up and length down
2366 !-------------------------------------------------------------------
2368 INTEGER, INTENT(IN) :: k,kts,kte
2369 REAL, DIMENSION(kts:kte), INTENT(IN) :: qtke,dz,theta
2370 REAL, INTENT(OUT) :: lb1,lb2
2371 REAL, DIMENSION(kts:kte+1), INTENT(IN) :: zw
2373 !LOCAL VARS
2374 INTEGER :: izz, found
2375 REAL :: dlu,dld
2376 REAL :: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz
2379 !----------------------------------
2380 ! FIND DISTANCE UPWARD
2381 !----------------------------------
2382 zup=0.
2383 dlu=zw(kte+1)-zw(k)-dz(k)*0.5
2384 zzz=0.
2385 zup_inf=0.
2386 beta=gtr !Buoyancy coefficient (g/tref)
2388 !print*,"FINDING Dup, k=",k," zw=",zw(k)
2390 if (k .lt. kte) then !cant integrate upwards from highest level
2391 found = 0
2392 izz=k
2393 DO WHILE (found .EQ. 0)
2395 if (izz .lt. kte) then
2396 dzt=dz(izz) ! layer depth above
2397 zup=zup-beta*theta(k)*dzt ! initial PE the parcel has at k
2398 !print*," ",k,izz,theta(izz),dz(izz)
2399 zup=zup+beta*(theta(izz+1)+theta(izz))*dzt*0.5 ! PE gained by lifting a parcel to izz+1
2400 zzz=zzz+dzt ! depth of layer k to izz+1
2401 !print*," PE=",zup," TKE=",qtke(k)," z=",zw(izz)
2402 if (qtke(k).lt.zup .and. qtke(k).ge.zup_inf) then
2403 bbb=(theta(izz+1)-theta(izz))/dzt
2404 if (bbb .ne. 0.) then
2405 !fractional distance up into the layer where TKE becomes < PE
2406 tl=(-beta*(theta(izz)-theta(k)) + &
2407 & sqrt( max(0.,(beta*(theta(izz)-theta(k)))**2 + &
2408 & 2.*bbb*beta*(qtke(k)-zup_inf))))/bbb/beta
2409 else
2410 if (theta(izz) .ne. theta(k))then
2411 tl=(qtke(k)-zup_inf)/(beta*(theta(izz)-theta(k)))
2412 else
2413 tl=0.
2414 endif
2415 endif
2416 dlu=zzz-dzt+tl
2417 !print*," FOUND Dup:",dlu," z=",zw(izz)," tl=",tl
2418 found =1
2419 endif
2420 zup_inf=zup
2421 izz=izz+1
2422 ELSE
2423 found = 1
2424 ENDIF
2426 ENDDO
2428 endif
2430 !----------------------------------
2431 ! FIND DISTANCE DOWN
2432 !----------------------------------
2433 zdo=0.
2434 zdo_sup=0.
2435 dld=zw(k)
2436 zzz=0.
2438 !print*,"FINDING Ddown, k=",k," zwk=",zw(k)
2439 if (k .gt. kts) then !cant integrate downwards from lowest level
2441 found = 0
2442 izz=k
2443 DO WHILE (found .EQ. 0)
2445 if (izz .gt. kts) then
2446 dzt=dz(izz-1)
2447 zdo=zdo+beta*theta(k)*dzt
2448 !print*," ",k,izz,theta(izz),dz(izz-1)
2449 zdo=zdo-beta*(theta(izz-1)+theta(izz))*dzt*0.5
2450 zzz=zzz+dzt
2451 !print*," PE=",zdo," TKE=",qtke(k)," z=",zw(izz)
2452 if (qtke(k).lt.zdo .and. qtke(k).ge.zdo_sup) then
2453 bbb=(theta(izz)-theta(izz-1))/dzt
2454 if (bbb .ne. 0.) then
2455 tl=(beta*(theta(izz)-theta(k))+ &
2456 & sqrt( max(0.,(beta*(theta(izz)-theta(k)))**2 + &
2457 & 2.*bbb*beta*(qtke(k)-zdo_sup))))/bbb/beta
2458 else
2459 if (theta(izz) .ne. theta(k)) then
2460 tl=(qtke(k)-zdo_sup)/(beta*(theta(izz)-theta(k)))
2461 else
2462 tl=0.
2463 endif
2464 endif
2465 dld=zzz-dzt+tl
2466 !print*," FOUND Ddown:",dld," z=",zw(izz)," tl=",tl
2467 found = 1
2468 endif
2469 zdo_sup=zdo
2470 izz=izz-1
2471 ELSE
2472 found = 1
2473 ENDIF
2474 ENDDO
2476 endif
2478 !----------------------------------
2479 ! GET MINIMUM (OR AVERAGE)
2480 !----------------------------------
2481 !The surface layer length scale can exceed z for large z/L,
2482 !so keep maximum distance down > z.
2483 dld = min(dld,zw(k+1))!not used in PBL anyway, only free atmos
2484 lb1 = min(dlu,dld) !minimum
2485 !JOE-fight floating point errors
2486 dlu=MAX(0.1,MIN(dlu,1000.))
2487 dld=MAX(0.1,MIN(dld,1000.))
2488 lb2 = sqrt(dlu*dld) !average - biased towards smallest
2489 !lb2 = 0.5*(dlu+dld) !average
2491 if (k .eq. kte) then
2492 lb1 = 0.
2493 lb2 = 0.
2494 endif
2495 !print*,"IN MYNN-BouLac",k,lb1
2496 !print*,"IN MYNN-BouLac",k,dld,dlu
2498 END SUBROUTINE boulac_length0
2500 ! ==================================================================
2501 !>\ingroup gsd_mynn_edmf
2502 !! This subroutine was taken from the BouLac scheme in WRF-ARW
2503 !! and modified for integration into the MYNN PBL scheme.
2504 !! WHILE loops were added to reduce the computational expense.
2505 !! This subroutine computes the length scales up and down
2506 !! and then computes the min, average of the up/down
2507 !! length scales, and also considers the distance to the
2508 !! surface.
2509 SUBROUTINE boulac_length(kts,kte,zw,dz,qtke,theta,lb1,lb2)
2510 ! dlu = the distance a parcel can be lifted upwards give a finite
2511 ! amount of TKE.
2512 ! dld = the distance a parcel can be displaced downwards given a
2513 ! finite amount of TKE.
2514 ! lb1 = the minimum of the length up and length down
2515 ! lb2 = the average of the length up and length down
2516 !-------------------------------------------------------------------
2518 INTEGER, INTENT(IN) :: kts,kte
2519 REAL, DIMENSION(kts:kte), INTENT(IN) :: qtke,dz,theta
2520 REAL, DIMENSION(kts:kte), INTENT(OUT) :: lb1,lb2
2521 REAL, DIMENSION(kts:kte+1), INTENT(IN) :: zw
2523 !LOCAL VARS
2524 INTEGER :: iz, izz, found
2525 REAL, DIMENSION(kts:kte) :: dlu,dld
2526 REAL, PARAMETER :: Lmax=2000. !soft limit
2527 REAL :: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz
2529 !print*,"IN MYNN-BouLac",kts, kte
2531 do iz=kts,kte
2533 !----------------------------------
2534 ! FIND DISTANCE UPWARD
2535 !----------------------------------
2536 zup=0.
2537 dlu(iz)=zw(kte+1)-zw(iz)-dz(iz)*0.5
2538 zzz=0.
2539 zup_inf=0.
2540 beta=gtr !Buoyancy coefficient (g/tref)
2542 !print*,"FINDING Dup, k=",iz," zw=",zw(iz)
2544 if (iz .lt. kte) then !cant integrate upwards from highest level
2546 found = 0
2547 izz=iz
2548 DO WHILE (found .EQ. 0)
2550 if (izz .lt. kte) then
2551 dzt=dz(izz) ! layer depth above
2552 zup=zup-beta*theta(iz)*dzt ! initial PE the parcel has at iz
2553 !print*," ",iz,izz,theta(izz),dz(izz)
2554 zup=zup+beta*(theta(izz+1)+theta(izz))*dzt*0.5 ! PE gained by lifting a parcel to izz+1
2555 zzz=zzz+dzt ! depth of layer iz to izz+1
2556 !print*," PE=",zup," TKE=",qtke(iz)," z=",zw(izz)
2557 if (qtke(iz).lt.zup .and. qtke(iz).ge.zup_inf) then
2558 bbb=(theta(izz+1)-theta(izz))/dzt
2559 if (bbb .ne. 0.) then
2560 !fractional distance up into the layer where TKE becomes < PE
2561 tl=(-beta*(theta(izz)-theta(iz)) + &
2562 & sqrt( max(0.,(beta*(theta(izz)-theta(iz)))**2 + &
2563 & 2.*bbb*beta*(qtke(iz)-zup_inf))))/bbb/beta
2564 else
2565 if (theta(izz) .ne. theta(iz))then
2566 tl=(qtke(iz)-zup_inf)/(beta*(theta(izz)-theta(iz)))
2567 else
2568 tl=0.
2569 endif
2570 endif
2571 dlu(iz)=zzz-dzt+tl
2572 !print*," FOUND Dup:",dlu(iz)," z=",zw(izz)," tl=",tl
2573 found =1
2574 endif
2575 zup_inf=zup
2576 izz=izz+1
2577 ELSE
2578 found = 1
2579 ENDIF
2581 ENDDO
2583 endif
2585 !----------------------------------
2586 ! FIND DISTANCE DOWN
2587 !----------------------------------
2588 zdo=0.
2589 zdo_sup=0.
2590 dld(iz)=zw(iz)
2591 zzz=0.
2593 !print*,"FINDING Ddown, k=",iz," zwk=",zw(iz)
2594 if (iz .gt. kts) then !cant integrate downwards from lowest level
2596 found = 0
2597 izz=iz
2598 DO WHILE (found .EQ. 0)
2600 if (izz .gt. kts) then
2601 dzt=dz(izz-1)
2602 zdo=zdo+beta*theta(iz)*dzt
2603 !print*," ",iz,izz,theta(izz),dz(izz-1)
2604 zdo=zdo-beta*(theta(izz-1)+theta(izz))*dzt*0.5
2605 zzz=zzz+dzt
2606 !print*," PE=",zdo," TKE=",qtke(iz)," z=",zw(izz)
2607 if (qtke(iz).lt.zdo .and. qtke(iz).ge.zdo_sup) then
2608 bbb=(theta(izz)-theta(izz-1))/dzt
2609 if (bbb .ne. 0.) then
2610 tl=(beta*(theta(izz)-theta(iz))+ &
2611 & sqrt( max(0.,(beta*(theta(izz)-theta(iz)))**2 + &
2612 & 2.*bbb*beta*(qtke(iz)-zdo_sup))))/bbb/beta
2613 else
2614 if (theta(izz) .ne. theta(iz)) then
2615 tl=(qtke(iz)-zdo_sup)/(beta*(theta(izz)-theta(iz)))
2616 else
2617 tl=0.
2618 endif
2619 endif
2620 dld(iz)=zzz-dzt+tl
2621 !print*," FOUND Ddown:",dld(iz)," z=",zw(izz)," tl=",tl
2622 found = 1
2623 endif
2624 zdo_sup=zdo
2625 izz=izz-1
2626 ELSE
2627 found = 1
2628 ENDIF
2629 ENDDO
2631 endif
2633 !----------------------------------
2634 ! GET MINIMUM (OR AVERAGE)
2635 !----------------------------------
2636 !The surface layer length scale can exceed z for large z/L,
2637 !so keep maximum distance down > z.
2638 dld(iz) = min(dld(iz),zw(iz+1))!not used in PBL anyway, only free atmos
2639 lb1(iz) = min(dlu(iz),dld(iz)) !minimum
2640 !JOE-fight floating point errors
2641 dlu(iz)=MAX(0.1,MIN(dlu(iz),1000.))
2642 dld(iz)=MAX(0.1,MIN(dld(iz),1000.))
2643 lb2(iz) = sqrt(dlu(iz)*dld(iz)) !average - biased towards smallest
2644 !lb2(iz) = 0.5*(dlu(iz)+dld(iz)) !average
2646 !Apply soft limit (only impacts very large lb; lb=100 by 5%, lb=500 by 20%).
2647 lb1(iz) = lb1(iz)/(1. + (lb1(iz)/Lmax))
2648 lb2(iz) = lb2(iz)/(1. + (lb2(iz)/Lmax))
2650 if (iz .eq. kte) then
2651 lb1(kte) = lb1(kte-1)
2652 lb2(kte) = lb2(kte-1)
2653 endif
2654 !print*,"IN MYNN-BouLac",kts, kte,lb1(iz)
2655 !print*,"IN MYNN-BouLac",iz,dld(iz),dlu(iz)
2657 ENDDO
2659 END SUBROUTINE boulac_length
2660 !
2661 ! ==================================================================
2662 ! SUBROUTINE mym_turbulence:
2663 !
2664 ! Input variables: see subroutine mym_initialize
2665 ! closure : closure level (2.5, 2.6, or 3.0)
2666 !
2667 ! # ql, vt, vq, qke, tsq, qsq and cov are changed to input variables.
2668 !
2669 ! Output variables: see subroutine mym_initialize
2670 ! dfm(nx,nz,ny) : Diffusivity coefficient for momentum,
2671 ! divided by dz (not dz*h(i,j)) (m/s)
2672 ! dfh(nx,nz,ny) : Diffusivity coefficient for heat,
2673 ! divided by dz (not dz*h(i,j)) (m/s)
2674 ! dfq(nx,nz,ny) : Diffusivity coefficient for q^2,
2675 ! divided by dz (not dz*h(i,j)) (m/s)
2676 ! tcd(nx,nz,ny) : Countergradient diffusion term for Theta_l
2677 ! (K/s)
2678 ! qcd(nx,nz,ny) : Countergradient diffusion term for Q_w
2679 ! (kg/kg s)
2680 ! pd?(nx,nz,ny) : Half of the production terms
2681 !
2682 ! Only tcd and qcd are defined at the center of the grid boxes
2683 !
2684 ! # DO NOT forget that tcd and qcd are added on the right-hand side
2685 ! of the equations for Theta_l and Q_w, respectively.
2686 !
2687 ! Work arrays: see subroutine mym_initialize and level2
2688 !
2689 ! # dtl, dqw, dtv, gm and gh are allowed to share storage units with
2690 ! dfm, dfh, dfq, tcd and qcd, respectively, for saving memory.
2691 !
2692 !>\ingroup gsd_mynn_edmf
2693 !! This subroutine calculates the vertical diffusivity coefficients and the
2694 !! production terms for the turbulent quantities.
2695 !>\section gen_mym_turbulence GSD mym_turbulence General Algorithm
2696 !! Two subroutines mym_level2() and mym_length() are called within this
2697 !!subrouine to collect variable to carry out successive calculations:
2698 !! - mym_level2() calculates the level 2 nondimensional wind shear \f$G_M\f$
2699 !! and vertical temperature gradient \f$G_H\f$ as well as the level 2 stability
2700 !! functions \f$S_h\f$ and \f$S_m\f$.
2701 !! - mym_length() calculates the mixing lengths.
2702 !! - The stability criteria from Helfand and Labraga (1989) are applied.
2703 !! - The stability functions for level 2.5 or level 3.0 are calculated.
2704 !! - If level 3.0 is used, counter-gradient terms are calculated.
2705 !! - Production terms of TKE,\f$\theta^{'2}\f$,\f$q^{'2}\f$, and \f$\theta^{'}q^{'}\f$
2706 !! are calculated.
2707 !! - Eddy diffusivity \f$K_h\f$ and eddy viscosity \f$K_m\f$ are calculated.
2708 !! - TKE budget terms are calculated (if the namelist parameter \p tke_budget
2709 !! is set to True)
2710 SUBROUTINE mym_turbulence ( &
2711 & kts,kte, &
2712 & xland,closure, &
2713 & dz, dx, zw, &
2714 & u, v, thl, thetav, ql, qw, &
2715 & thlsg, qwsg, &
2716 & qke, tsq, qsq, cov, &
2717 & vt, vq, &
2718 & rmo, flt, flq, &
2719 & zi,theta, &
2720 & sh, sm, &
2721 & El, &
2722 & Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc, &
2723 & qWT1D,qSHEAR1D,qBUOY1D,qDISS1D, &
2724 & tke_budget, &
2725 & Psig_bl,Psig_shcu,cldfra_bl1D, &
2726 & bl_mynn_mixlength, &
2727 & edmf_w1,edmf_a1, &
2728 & TKEprodTD, &
2729 & spp_pbl,rstoch_col)
2731 !-------------------------------------------------------------------
2732 !
2733 INTEGER, INTENT(IN) :: kts,kte
2735 #ifdef HARDCODE_VERTICAL
2736 # define kts 1
2737 # define kte HARDCODE_VERTICAL
2738 #endif
2740 INTEGER, INTENT(IN) :: bl_mynn_mixlength,tke_budget
2741 REAL, INTENT(IN) :: closure
2742 REAL, DIMENSION(kts:kte), INTENT(in) :: dz
2743 REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw
2744 REAL, INTENT(in) :: rmo,flt,flq,Psig_bl,Psig_shcu,dx,xland,zi
2745 REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,thetav,qw,&
2746 &ql,vt,vq,qke,tsq,qsq,cov,cldfra_bl1D,edmf_w1,edmf_a1,&
2747 &TKEprodTD,thlsg,qwsg
2749 REAL, DIMENSION(kts:kte), INTENT(out) :: dfm,dfh,dfq,&
2750 &pdk,pdt,pdq,pdc,tcd,qcd,el
2752 REAL, DIMENSION(kts:kte), INTENT(inout) :: &
2753 qWT1D,qSHEAR1D,qBUOY1D,qDISS1D
2754 REAL :: q3sq_old,dlsq1,qWTP_old,qWTP_new
2755 REAL :: dudz,dvdz,dTdz,&
2756 upwp,vpwp,Tpwp
2758 REAL, DIMENSION(kts:kte) :: qkw,dtl,dqw,dtv,gm,gh,sm,sh
2760 INTEGER :: k
2761 ! REAL :: cc2,cc3,e1c,e2c,e3c,e4c,e5c
2762 REAL :: e6c,dzk,afk,abk,vtt,vqq,&
2763 &cw25,clow,cupp,gamt,gamq,smd,gamv,elq,elh
2765 REAL :: cldavg
2766 REAL, DIMENSION(kts:kte), INTENT(in) :: theta
2768 REAL :: a2fac, duz, ri !JOE-Canuto/Kitamura mod
2770 REAL:: auh,aum,adh,adm,aeh,aem,Req,Rsl,Rsl2,&
2771 gmelq,sm20,sh20,sm25max,sh25max,sm25min,sh25min,&
2772 sm_pbl,sh_pbl,zi2,wt,slht,wtpr
2774 DOUBLE PRECISION q2sq, t2sq, r2sq, c2sq, elsq, gmel, ghel
2775 DOUBLE PRECISION q3sq, t3sq, r3sq, c3sq, dlsq, qdiv
2776 DOUBLE PRECISION e1, e2, e3, e4, enum, eden, wden
2778 ! Stochastic
2779 INTEGER, INTENT(IN) :: spp_pbl
2780 REAL, DIMENSION(KTS:KTE) :: rstoch_col
2781 REAL :: Prnum, Prlim
2782 REAL, PARAMETER :: Prlimit = 5.0
2785 !
2786 ! tv0 = 0.61*tref
2787 ! gtr = 9.81/tref
2788 !
2789 ! cc2 = 1.0-c2
2790 ! cc3 = 1.0-c3
2791 ! e1c = 3.0*a2*b2*cc3
2792 ! e2c = 9.0*a1*a2*cc2
2793 ! e3c = 9.0*a2*a2*cc2*( 1.0-c5 )
2794 ! e4c = 12.0*a1*a2*cc2
2795 ! e5c = 6.0*a1*a1
2796 !
2798 CALL mym_level2 (kts,kte, &
2799 & dz, &
2800 & u, v, thl, thetav, qw, &
2801 & thlsg, qwsg, &
2802 & ql, vt, vq, &
2803 & dtl, dqw, dtv, gm, gh, sm, sh )
2804 !
2805 CALL mym_length ( &
2806 & kts,kte,xland, &
2807 & dz, dx, zw, &
2808 & rmo, flt, flq, &
2809 & vt, vq, &
2810 & u, v, qke, &
2811 & dtv, &
2812 & el, &
2813 & zi,theta, &
2814 & qkw,Psig_bl,cldfra_bl1D, &
2815 & bl_mynn_mixlength, &
2816 & edmf_w1,edmf_a1 )
2817 !
2819 DO k = kts+1,kte
2820 dzk = 0.5 *( dz(k)+dz(k-1) )
2821 afk = dz(k)/( dz(k)+dz(k-1) )
2822 abk = 1.0 -afk
2823 elsq = el (k)**2
2824 q3sq = qkw(k)**2
2825 q2sq = b1*elsq*( sm(k)*gm(k)+sh(k)*gh(k) )
2827 sh20 = MAX(sh(k), 1e-5)
2828 sm20 = MAX(sm(k), 1e-5)
2829 sh(k)= MAX(sh(k), 1e-5)
2831 !Canuto/Kitamura mod
2832 duz = ( u(k)-u(k-1) )**2 +( v(k)-v(k-1) )**2
2833 duz = duz /dzk**2
2834 ! ** Gradient Richardson number **
2835 ri = -gh(k)/MAX( duz, 1.0e-10 )
2836 IF (CKmod .eq. 1) THEN
2837 a2fac = 1./(1. + MAX(ri,0.0))
2838 ELSE
2839 a2fac = 1.
2840 ENDIF
2841 !end Canuto/Kitamura mod
2843 !level 2.0 Prandtl number
2844 !Prnum = MIN(sm20/sh20, 4.0)
2845 !The form of Zilitinkevich et al. (2006) but modified
2846 !half-way towards Esau and Grachev (2007, Wind Eng)
2847 !Prnum = MIN(0.76 + 3.0*MAX(ri,0.0), Prlimit)
2848 Prnum = MIN(0.76 + 4.0*MAX(ri,0.0), Prlimit)
2849 !Prnum = MIN(0.76 + 5.0*MAX(ri,0.0), Prlimit)
2850 !
2851 ! Modified: Dec/22/2005, from here, (dlsq -> elsq)
2852 gmel = gm (k)*elsq
2853 ghel = gh (k)*elsq
2854 ! Modified: Dec/22/2005, up to here
2856 ! Level 2.0 debug prints
2857 IF ( debug_code ) THEN
2858 IF (sh(k)<0.0 .OR. sm(k)<0.0) THEN
2859 print*,"MYNN; mym_turbulence 2.0; sh=",sh(k)," k=",k
2860 print*," gm=",gm(k)," gh=",gh(k)," sm=",sm(k)
2861 print*," q2sq=",q2sq," q3sq=",q3sq," q3/q2=",q3sq/q2sq
2862 print*," qke=",qke(k)," el=",el(k)," ri=",ri
2863 print*," PBLH=",zi," u=",u(k)," v=",v(k)
2864 ENDIF
2865 ENDIF
2867 ! ** Since qkw is set to more than 0.0, q3sq > 0.0. **
2869 ! new stability criteria in level 2.5 (as well as level 3) - little/no impact
2870 ! ** Limitation on q, instead of L/q **
2871 dlsq = elsq
2872 IF ( q3sq/dlsq .LT. -gh(k) ) q3sq = -dlsq*gh(k)
2874 IF ( q3sq .LT. q2sq ) THEN
2875 !Apply Helfand & Labraga mod
2876 qdiv = SQRT( q3sq/q2sq ) !HL89: (1-alfa)
2877 !
2878 !Use level 2.5 stability functions
2879 !e1 = q3sq - e1c*ghel*a2fac
2880 !e2 = q3sq - e2c*ghel*a2fac
2881 !e3 = e1 + e3c*ghel*a2fac**2
2882 !e4 = e1 - e4c*ghel*a2fac
2883 !eden = e2*e4 + e3*e5c*gmel
2884 !eden = MAX( eden, 1.0d-20 )
2885 !sm(k) = q3sq*a1*( e3-3.0*c1*e4 )/eden
2886 !!JOE-Canuto/Kitamura mod
2887 !!sh(k) = q3sq*a2*( e2+3.0*c1*e5c*gmel )/eden
2888 !sh(k) = q3sq*(a2*a2fac)*( e2+3.0*c1*e5c*gmel )/eden
2889 !sm(k) = Prnum*sh(k)
2890 !sm(k) = sm(k) * qdiv
2892 !Use level 2.0 functions as in original MYNN
2893 sh(k) = sh(k) * qdiv
2894 sm(k) = sm(k) * qdiv
2895 ! !sm_pbl = sm(k) * qdiv
2896 !
2897 ! !Or, use the simple Pr relationship
2898 ! sm(k) = Prnum*sh(k)
2899 !
2900 ! !or blend them:
2901 ! zi2 = MAX(zi, 300.)
2902 ! wt =.5*TANH((zw(k) - zi2)/200.) + .5
2903 ! sm(k) = sm_pbl*(1.-wt) + sm(k)*wt
2905 !Recalculate terms for later use
2906 !JOE-Canuto/Kitamura mod
2907 !e1 = q3sq - e1c*ghel * qdiv**2
2908 !e2 = q3sq - e2c*ghel * qdiv**2
2909 !e3 = e1 + e3c*ghel * qdiv**2
2910 !e4 = e1 - e4c*ghel * qdiv**2
2911 e1 = q3sq - e1c*ghel*a2fac * qdiv**2
2912 e2 = q3sq - e2c*ghel*a2fac * qdiv**2
2913 e3 = e1 + e3c*ghel*a2fac**2 * qdiv**2
2914 e4 = e1 - e4c*ghel*a2fac * qdiv**2
2915 eden = e2*e4 + e3*e5c*gmel * qdiv**2
2916 eden = MAX( eden, 1.0d-20 )
2917 !!JOE-Canuto/Kitamura mod
2918 !!sh(k) = q3sq*a2*( e2+3.0*c1*e5c*gmel )/eden - retro 5
2919 !sh(k) = q3sq*(a2*a2fac)*( e2+3.0*c1*e5c*gmel )/eden
2920 !sm(k) = Prnum*sh(k)
2921 ELSE
2922 !JOE-Canuto/Kitamura mod
2923 !e1 = q3sq - e1c*ghel
2924 !e2 = q3sq - e2c*ghel
2925 !e3 = e1 + e3c*ghel
2926 !e4 = e1 - e4c*ghel
2927 e1 = q3sq - e1c*ghel*a2fac
2928 e2 = q3sq - e2c*ghel*a2fac
2929 e3 = e1 + e3c*ghel*a2fac**2
2930 e4 = e1 - e4c*ghel*a2fac
2931 eden = e2*e4 + e3*e5c*gmel
2932 eden = MAX( eden, 1.0d-20 )
2934 qdiv = 1.0
2935 !Use level 2.5 stability functions
2936 sm(k) = q3sq*a1*( e3-3.0*c1*e4 )/eden
2937 ! sm_pbl = q3sq*a1*( e3-3.0*c1*e4 )/eden
2938 !!JOE-Canuto/Kitamura mod
2939 !!sh(k) = q3sq*a2*( e2+3.0*c1*e5c*gmel )/eden
2940 sh(k) = q3sq*(a2*a2fac)*( e2+3.0*c1*e5c*gmel )/eden
2941 ! sm(k) = Prnum*sh(k)
2943 ! !or blend them:
2944 ! zi2 = MAX(zi, 300.)
2945 ! wt = .5*TANH((zw(k) - zi2)/200.) + .5
2946 ! sm(k) = sm_pbl*(1.-wt) + sm(k)*wt
2947 END IF !end Helfand & Labraga check
2949 !Impose broad limits on Sh and Sm:
2950 gmelq = MAX(gmel/q3sq, 1e-8)
2951 sm25max = 4. !MIN(sm20*3.0, SQRT(.1936/gmelq))
2952 sh25max = 4. !MIN(sh20*3.0, 0.76*b2)
2953 sm25min = 0.0 !MAX(sm20*0.1, 1e-6)
2954 sh25min = 0.0 !MAX(sh20*0.1, 1e-6)
2956 !JOE: Level 2.5 debug prints
2957 ! HL88 , lev2.5 criteria from eqs. 3.17, 3.19, & 3.20
2958 IF ( debug_code ) THEN
2959 IF ((sh(k)<sh25min .OR. sm(k)<sm25min .OR. &
2960 sh(k)>sh25max .OR. sm(k)>sm25max) ) THEN
2961 print*,"In mym_turbulence 2.5: k=",k
2962 print*," sm=",sm(k)," sh=",sh(k)
2963 print*," ri=",ri," Pr=",sm(k)/MAX(sh(k),1e-8)
2964 print*," gm=",gm(k)," gh=",gh(k)
2965 print*," q2sq=",q2sq," q3sq=",q3sq, q3sq/q2sq
2966 print*," qke=",qke(k)," el=",el(k)
2967 print*," PBLH=",zi," u=",u(k)," v=",v(k)
2968 print*," SMnum=",q3sq*a1*( e3-3.0*c1*e4)," SMdenom=",eden
2969 print*," SHnum=",q3sq*(a2*a2fac)*( e2+3.0*c1*e5c*gmel ),&
2970 " SHdenom=",eden
2971 ENDIF
2972 ENDIF
2974 !Enforce constraints for level 2.5 functions
2975 IF ( sh(k) > sh25max ) sh(k) = sh25max
2976 IF ( sh(k) < sh25min ) sh(k) = sh25min
2977 !IF ( sm(k) > sm25max ) sm(k) = sm25max
2978 !IF ( sm(k) < sm25min ) sm(k) = sm25min
2979 !sm(k) = Prnum*sh(k)
2981 !surface layer PR
2982 !slht = zi*0.1
2983 !wtpr = min( max( (slht - zw(k))/slht, 0.0), 1.0) ! 1 at z=0, 0 above sfc layer
2984 !Prlim = 1.0*wtpr + (1.0 - wtpr)*Prlimit
2985 !Prlim = 2.0*wtpr + (1.0 - wtpr)*Prlimit
2986 !sm(k) = MIN(sm(k), Prlim*Sh(k))
2987 !Pending more testing, keep same Pr limit in sfc layer
2988 sm(k) = MIN(sm(k), Prlimit*Sh(k))
2990 ! ** Level 3 : start **
2991 IF ( closure .GE. 3.0 ) THEN
2992 t2sq = qdiv*b2*elsq*sh(k)*dtl(k)**2
2993 r2sq = qdiv*b2*elsq*sh(k)*dqw(k)**2
2994 c2sq = qdiv*b2*elsq*sh(k)*dtl(k)*dqw(k)
2995 t3sq = MAX( tsq(k)*abk+tsq(k-1)*afk, 0.0 )
2996 r3sq = MAX( qsq(k)*abk+qsq(k-1)*afk, 0.0 )
2997 c3sq = cov(k)*abk+cov(k-1)*afk
2999 ! Modified: Dec/22/2005, from here
3000 c3sq = SIGN( MIN( ABS(c3sq), SQRT(t3sq*r3sq) ), c3sq )
3001 !
3002 vtt = 1.0 +vt(k)*abk +vt(k-1)*afk
3003 vqq = tv0 +vq(k)*abk +vq(k-1)*afk
3005 t2sq = vtt*t2sq +vqq*c2sq
3006 r2sq = vtt*c2sq +vqq*r2sq
3007 c2sq = MAX( vtt*t2sq+vqq*r2sq, 0.0d0 )
3008 t3sq = vtt*t3sq +vqq*c3sq
3009 r3sq = vtt*c3sq +vqq*r3sq
3010 c3sq = MAX( vtt*t3sq+vqq*r3sq, 0.0d0 )
3011 !
3012 cw25 = e1*( e2 + 3.0*c1*e5c*gmel*qdiv**2 )/( 3.0*eden )
3013 !
3014 ! ** Limitation on q, instead of L/q **
3015 dlsq = elsq
3016 IF ( q3sq/dlsq .LT. -gh(k) ) q3sq = -dlsq*gh(k)
3017 !
3018 ! ** Limitation on c3sq (0.12 =< cw =< 0.76) **
3019 ! Use Janjic's (2001; p 13-17) methodology (eqs 4.11-414 and 5.7-5.10)
3020 ! to calculate an exact limit for c3sq:
3021 auh = 27.*a1*((a2*a2fac)**2)*b2*(gtr)**2
3022 aum = 54.*(a1**2)*(a2*a2fac)*b2*c1*(gtr)
3023 adh = 9.*a1*((a2*a2fac)**2)*(12.*a1 + 3.*b2)*(gtr)**2
3024 adm = 18.*(a1**2)*(a2*a2fac)*(b2 - 3.*(a2*a2fac))*(gtr)
3026 aeh = (9.*a1*((a2*a2fac)**2)*b1 +9.*a1*((a2*a2fac)**2)* &
3027 (12.*a1 + 3.*b2))*(gtr)
3028 aem = 3.*a1*(a2*a2fac)*b1*(3.*(a2*a2fac) + 3.*b2*c1 + &
3029 (18.*a1*c1 - b2)) + &
3030 (18.)*(a1**2)*(a2*a2fac)*(b2 - 3.*(a2*a2fac))
3032 Req = -aeh/aem
3033 Rsl = (auh + aum*Req)/(3.*adh + 3.*adm*Req)
3034 !For now, use default values, since tests showed little/no sensitivity
3035 Rsl = .12 !lower limit
3036 Rsl2= 1.0 - 2.*Rsl !upper limit
3037 !IF (k==2)print*,"Dynamic limit RSL=",Rsl
3038 !IF (Rsl < 0.10 .OR. Rsl > 0.18) THEN
3039 ! print*,'--- ERROR: MYNN: Dynamic Cw '// &
3040 ! 'limit exceeds reasonable limits'
3041 ! print*," MYNN: Dynamic Cw limit needs attention=",Rsl
3042 !ENDIF
3044 !JOE-Canuto/Kitamura mod
3045 !e2 = q3sq - e2c*ghel * qdiv**2
3046 !e3 = q3sq + e3c*ghel * qdiv**2
3047 !e4 = q3sq - e4c*ghel * qdiv**2
3048 e2 = q3sq - e2c*ghel*a2fac * qdiv**2
3049 e3 = q3sq + e3c*ghel*a2fac**2 * qdiv**2
3050 e4 = q3sq - e4c*ghel*a2fac * qdiv**2
3051 eden = e2*e4 + e3 *e5c*gmel * qdiv**2
3053 !JOE-Canuto/Kitamura mod
3054 !wden = cc3*gtr**2 * dlsq**2/elsq * qdiv**2 &
3055 ! & *( e2*e4c - e3c*e5c*gmel * qdiv**2 )
3056 wden = cc3*gtr**2 * dlsq**2/elsq * qdiv**2 &
3057 & *( e2*e4c*a2fac - e3c*e5c*gmel*a2fac**2 * qdiv**2 )
3059 IF ( wden .NE. 0.0 ) THEN
3060 !JOE: test dynamic limits
3061 clow = q3sq*( 0.12-cw25 )*eden/wden
3062 cupp = q3sq*( 0.76-cw25 )*eden/wden
3063 !clow = q3sq*( Rsl -cw25 )*eden/wden
3064 !cupp = q3sq*( Rsl2-cw25 )*eden/wden
3065 !
3066 IF ( wden .GT. 0.0 ) THEN
3067 c3sq = MIN( MAX( c3sq, c2sq+clow ), c2sq+cupp )
3068 ELSE
3069 c3sq = MAX( MIN( c3sq, c2sq+clow ), c2sq+cupp )
3070 END IF
3071 END IF
3072 !
3073 e1 = e2 + e5c*gmel * qdiv**2
3074 eden = MAX( eden, 1.0d-20 )
3075 ! Modified: Dec/22/2005, up to here
3077 !JOE-Canuto/Kitamura mod
3078 !e6c = 3.0*a2*cc3*gtr * dlsq/elsq
3079 e6c = 3.0*(a2*a2fac)*cc3*gtr * dlsq/elsq
3081 !============================
3082 ! ** for Gamma_theta **
3083 !! enum = qdiv*e6c*( t3sq-t2sq )
3084 IF ( t2sq .GE. 0.0 ) THEN
3085 enum = MAX( qdiv*e6c*( t3sq-t2sq ), 0.0d0 )
3086 ELSE
3087 enum = MIN( qdiv*e6c*( t3sq-t2sq ), 0.0d0 )
3088 ENDIF
3089 gamt =-e1 *enum /eden
3091 !============================
3092 ! ** for Gamma_q **
3093 !! enum = qdiv*e6c*( r3sq-r2sq )
3094 IF ( r2sq .GE. 0.0 ) THEN
3095 enum = MAX( qdiv*e6c*( r3sq-r2sq ), 0.0d0 )
3096 ELSE
3097 enum = MIN( qdiv*e6c*( r3sq-r2sq ), 0.0d0 )
3098 ENDIF
3099 gamq =-e1 *enum /eden
3101 !============================
3102 ! ** for Sm' and Sh'd(Theta_V)/dz **
3103 !! enum = qdiv*e6c*( c3sq-c2sq )
3104 enum = MAX( qdiv*e6c*( c3sq-c2sq ), 0.0d0)
3106 !JOE-Canuto/Kitamura mod
3107 !smd = dlsq*enum*gtr/eden * qdiv**2 * (e3c+e4c)*a1/a2
3108 smd = dlsq*enum*gtr/eden * qdiv**2 * (e3c*a2fac**2 + &
3109 & e4c*a2fac)*a1/(a2*a2fac)
3111 gamv = e1 *enum*gtr/eden
3112 sm(k) = sm(k) +smd
3114 !============================
3115 ! ** For elh (see below), qdiv at Level 3 is reset to 1.0. **
3116 qdiv = 1.0
3118 ! Level 3 debug prints
3119 IF ( debug_code ) THEN
3120 IF (sh(k)<-0.3 .OR. sm(k)<-0.3 .OR. &
3121 qke(k) < -0.1 .or. ABS(smd) .gt. 2.0) THEN
3122 print*," MYNN; mym_turbulence3.0; sh=",sh(k)," k=",k
3123 print*," gm=",gm(k)," gh=",gh(k)," sm=",sm(k)
3124 print*," q2sq=",q2sq," q3sq=",q3sq," q3/q2=",q3sq/q2sq
3125 print*," qke=",qke(k)," el=",el(k)," ri=",ri
3126 print*," PBLH=",zi," u=",u(k)," v=",v(k)
3127 ENDIF
3128 ENDIF
3130 ! ** Level 3 : end **
3132 ELSE
3133 ! ** At Level 2.5, qdiv is not reset. **
3134 gamt = 0.0
3135 gamq = 0.0
3136 gamv = 0.0
3137 END IF
3138 !
3139 ! Add min background stability function (diffusivity) within model levels
3140 ! with active plumes and clouds.
3141 cldavg = 0.5*(cldfra_bl1D(k-1) + cldfra_bl1D(k))
3142 IF (edmf_a1(k) > 0.001 .OR. cldavg > 0.02) THEN
3143 ! for mass-flux columns
3144 sm(k) = MAX(sm(k), 0.03*MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) )
3145 sh(k) = MAX(sh(k), 0.03*MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) )
3146 ! for clouds
3147 sm(k) = MAX(sm(k), 0.05*MIN(cldavg,1.0) )
3148 sh(k) = MAX(sh(k), 0.05*MIN(cldavg,1.0) )
3149 ENDIF
3150 !
3151 elq = el(k)*qkw(k)
3152 elh = elq*qdiv
3154 ! Production of TKE (pdk), T-variance (pdt),
3155 ! q-variance (pdq), and covariance (pdc)
3156 pdk(k) = elq*( sm(k)*gm(k) &
3157 & +sh(k)*gh(k)+gamv ) + &
3158 & TKEprodTD(k)
3159 pdt(k) = elh*( sh(k)*dtl(k)+gamt )*dtl(k)
3160 pdq(k) = elh*( sh(k)*dqw(k)+gamq )*dqw(k)
3161 pdc(k) = elh*( sh(k)*dtl(k)+gamt ) &
3162 & *dqw(k)*0.5 &
3163 & + elh*( sh(k)*dqw(k)+gamq )*dtl(k)*0.5
3165 ! Contergradient terms
3166 tcd(k) = elq*gamt
3167 qcd(k) = elq*gamq
3169 ! Eddy Diffusivity/Viscosity divided by dz
3170 dfm(k) = elq*sm(k) / dzk
3171 dfh(k) = elq*sh(k) / dzk
3172 ! Modified: Dec/22/2005, from here
3173 ! ** In sub.mym_predict, dfq for the TKE and scalar variance **
3174 ! ** are set to 3.0*dfm and 1.0*dfm, respectively. (Sqfac) **
3175 dfq(k) = dfm(k)
3176 ! Modified: Dec/22/2005, up to here
3178 IF (tke_budget .eq. 1) THEN
3179 !TKE BUDGET
3180 ! dudz = ( u(k)-u(k-1) )/dzk
3181 ! dvdz = ( v(k)-v(k-1) )/dzk
3182 ! dTdz = ( thl(k)-thl(k-1) )/dzk
3184 ! upwp = -elq*sm(k)*dudz
3185 ! vpwp = -elq*sm(k)*dvdz
3186 ! Tpwp = -elq*sh(k)*dTdz
3187 ! Tpwp = SIGN(MAX(ABS(Tpwp),1.E-6),Tpwp)
3190 !! TKE budget (Puhales, 2020, WRF 4.2.1) << EOB
3192 !!!Shear Term
3193 !!!qSHEAR1D(k)=-(upwp*dudz + vpwp*dvdz)
3194 qSHEAR1D(k) = elq*sm(k)*gm(k) !staggered
3196 !!!Buoyancy Term
3197 !!!qBUOY1D(k)=grav*Tpwp/thl(k)
3198 !qBUOY1D(k)= elq*(sh(k)*gh(k) + gamv)
3199 !qBUOY1D(k) = elq*(sh(k)*(-dTdz*grav/thl(k)) + gamv) !! ORIGINAL CODE
3201 !! Buoyncy term takes the TKEprodTD(k) production now
3202 qBUOY1D(k) = elq*(sh(k)*gh(k)+gamv)+TKEprodTD(k) !staggered
3204 !!!Dissipation Term (now it evaluated on mym_predict)
3205 !qDISS1D(k) = (q3sq**(3./2.))/(b1*MAX(el(k),1.)) !! ORIGINAL CODE
3207 !! >> EOB
3208 ENDIF
3210 END DO
3211 !
3213 dfm(kts) = 0.0
3214 dfh(kts) = 0.0
3215 dfq(kts) = 0.0
3216 tcd(kts) = 0.0
3217 qcd(kts) = 0.0
3219 tcd(kte) = 0.0
3220 qcd(kte) = 0.0
3222 !
3223 DO k = kts,kte-1
3224 dzk = dz(k)
3225 tcd(k) = ( tcd(k+1)-tcd(k) )/( dzk )
3226 qcd(k) = ( qcd(k+1)-qcd(k) )/( dzk )
3227 END DO
3228 !
3231 if (spp_pbl==1) then
3232 DO k = kts,kte
3233 dfm(k)= dfm(k) + dfm(k)* rstoch_col(k) * 1.5 * MAX(exp(-MAX(zw(k)-8000.,0.0)/2000.),0.001)
3234 dfh(k)= dfh(k) + dfh(k)* rstoch_col(k) * 1.5 * MAX(exp(-MAX(zw(k)-8000.,0.0)/2000.),0.001)
3235 END DO
3236 endif
3238 ! RETURN
3239 #ifdef HARDCODE_VERTICAL
3240 # undef kts
3241 # undef kte
3242 #endif
3244 END SUBROUTINE mym_turbulence
3246 ! ==================================================================
3247 ! SUBROUTINE mym_predict:
3248 !
3249 ! Input variables: see subroutine mym_initialize and turbulence
3250 ! qke(nx,nz,ny) : qke at (n)th time level
3251 ! tsq, ...cov : ditto
3252 !
3253 ! Output variables:
3254 ! qke(nx,nz,ny) : qke at (n+1)th time level
3255 ! tsq, ...cov : ditto
3256 !
3257 ! Work arrays:
3258 ! qkw(nx,nz,ny) : q at the center of the grid boxes (m/s)
3259 ! bp (nx,nz,ny) : = 1/2*F, see below
3260 ! rp (nx,nz,ny) : = P-1/2*F*Q, see below
3261 !
3262 ! # The equation for a turbulent quantity Q can be expressed as
3263 ! dQ/dt + Ah + Av = Dh + Dv + P - F*Q, (1)
3264 ! where A is the advection, D the diffusion, P the production,
3265 ! F*Q the dissipation and h and v denote horizontal and vertical,
3266 ! respectively. If Q is q^2, F is 2q/B_1L.
3267 ! Using the Crank-Nicholson scheme for Av, Dv and F*Q, a finite
3268 ! difference equation is written as
3269 ! Q{n+1} - Q{n} = dt *( Dh{n} - Ah{n} + P{n} )
3270 ! + dt/2*( Dv{n} - Av{n} - F*Q{n} )
3271 ! + dt/2*( Dv{n+1} - Av{n+1} - F*Q{n+1} ), (2)
3272 ! where n denotes the time level.
3273 ! When the advection and diffusion terms are discretized as
3274 ! dt/2*( Dv - Av ) = a(k)Q(k+1) - b(k)Q(k) + c(k)Q(k-1), (3)
3275 ! Eq.(2) can be rewritten as
3276 ! - a(k)Q(k+1) + [ 1 + b(k) + dt/2*F ]Q(k) - c(k)Q(k-1)
3277 ! = Q{n} + dt *( Dh{n} - Ah{n} + P{n} )
3278 ! + dt/2*( Dv{n} - Av{n} - F*Q{n} ), (4)
3279 ! where Q on the left-hand side is at (n+1)th time level.
3280 !
3281 ! In this subroutine, a(k), b(k) and c(k) are obtained from
3282 ! subprogram coefvu and are passed to subprogram tinteg via
3283 ! common. 1/2*F and P-1/2*F*Q are stored in bp and rp,
3284 ! respectively. Subprogram tinteg solves Eq.(4).
3285 !
3286 ! Modify this subroutine according to your numerical integration
3287 ! scheme (program).
3288 !
3289 !-------------------------------------------------------------------
3290 !>\ingroup gsd_mynn_edmf
3291 !! This subroutine predicts the turbulent quantities at the next step.
3292 SUBROUTINE mym_predict (kts,kte, &
3293 & closure, &
3294 & delt, &
3295 & dz, &
3296 & ust, flt, flq, pmz, phh, &
3297 & el, dfq, rho, &
3298 & pdk, pdt, pdq, pdc, &
3299 & qke, tsq, qsq, cov, &
3300 & s_aw,s_awqke,bl_mynn_edmf_tke, &
3301 & qWT1D, qDISS1D,tke_budget) !! TKE budget (Puhales, 2020)
3303 !-------------------------------------------------------------------
3304 INTEGER, INTENT(IN) :: kts,kte
3306 #ifdef HARDCODE_VERTICAL
3307 # define kts 1
3308 # define kte HARDCODE_VERTICAL
3309 #endif
3311 REAL, INTENT(IN) :: closure
3312 INTEGER, INTENT(IN) :: bl_mynn_edmf_tke, tke_budget
3313 REAL, INTENT(IN) :: delt
3314 REAL, DIMENSION(kts:kte), INTENT(IN) :: dz, dfq, el, rho
3315 REAL, DIMENSION(kts:kte), INTENT(INOUT) :: pdk, pdt, pdq, pdc
3316 REAL, INTENT(IN) :: flt, flq, ust, pmz, phh
3317 REAL, DIMENSION(kts:kte), INTENT(INOUT) :: qke,tsq, qsq, cov
3318 ! WA 8/3/15
3319 REAL, DIMENSION(kts:kte+1), INTENT(INOUT) :: s_awqke,s_aw
3321 !! TKE budget (Puhales, 2020, WRF 4.2.1) << EOB
3322 REAL, DIMENSION(kts:kte), INTENT(OUT) :: qWT1D, qDISS1D
3323 REAL, DIMENSION(kts:kte) :: tke_up,dzinv
3324 !! >> EOB
3326 INTEGER :: k
3327 REAL, DIMENSION(kts:kte) :: qkw, bp, rp, df3q
3328 REAL :: vkz,pdk1,phm,pdt1,pdq1,pdc1,b1l,b2l,onoff
3329 REAL, DIMENSION(kts:kte) :: dtz
3330 REAL, DIMENSION(kts:kte) :: a,b,c,d,x
3332 REAL, DIMENSION(kts:kte) :: rhoinv
3333 REAL, DIMENSION(kts:kte+1) :: rhoz,kqdz,kmdz
3335 ! REGULATE THE MOMENTUM MIXING FROM THE MASS-FLUX SCHEME (on or off)
3336 IF (bl_mynn_edmf_tke == 0) THEN
3337 onoff=0.0
3338 ELSE
3339 onoff=1.0
3340 ENDIF
3342 ! ** Strictly, vkz*h(i,j) -> karman*( 0.5*dz(1)*h(i,j)+z0 ) **
3343 vkz = karman*0.5*dz(kts)
3344 !
3345 ! ** dfq for the TKE is 3.0*dfm. **
3346 !
3347 DO k = kts,kte
3348 !! qke(k) = MAX(qke(k), 0.0)
3349 qkw(k) = SQRT( MAX( qke(k), 0.0 ) )
3350 df3q(k)=Sqfac*dfq(k)
3351 dtz(k)=delt/dz(k)
3352 END DO
3353 !
3354 !JOE-add conservation + stability criteria
3355 !Prepare "constants" for diffusion equation.
3356 !khdz = rho*Kh/dz = rho*dfh
3357 rhoz(kts) =rho(kts)
3358 rhoinv(kts)=1./rho(kts)
3359 kqdz(kts) =rhoz(kts)*df3q(kts)
3360 kmdz(kts) =rhoz(kts)*dfq(kts)
3361 DO k=kts+1,kte
3362 rhoz(k) =(rho(k)*dz(k-1) + rho(k-1)*dz(k))/(dz(k-1)+dz(k))
3363 rhoz(k) = MAX(rhoz(k),1E-4)
3364 rhoinv(k)=1./MAX(rho(k),1E-4)
3365 kqdz(k) = rhoz(k)*df3q(k) ! for TKE
3366 kmdz(k) = rhoz(k)*dfq(k) ! for T'2, q'2, and T'q'
3367 ENDDO
3368 rhoz(kte+1)=rhoz(kte)
3369 kqdz(kte+1)=rhoz(kte+1)*df3q(kte)
3370 kmdz(kte+1)=rhoz(kte+1)*dfq(kte)
3372 !stability criteria for mf
3373 DO k=kts+1,kte-1
3374 kqdz(k) = MAX(kqdz(k), 0.5* s_aw(k))
3375 kqdz(k) = MAX(kqdz(k), -0.5*(s_aw(k)-s_aw(k+1)))
3376 kmdz(k) = MAX(kmdz(k), 0.5* s_aw(k))
3377 kmdz(k) = MAX(kmdz(k), -0.5*(s_aw(k)-s_aw(k+1)))
3378 ENDDO
3379 !JOE-end conservation mods
3381 pdk1 = 2.0*ust**3*pmz/( vkz )
3382 phm = 2.0/ust *phh/( vkz )
3383 pdt1 = phm*flt**2
3384 pdq1 = phm*flq**2
3385 pdc1 = phm*flt*flq
3386 !
3387 ! ** pdk(i,j,1)+pdk(i,j,2) corresponds to pdk1. **
3388 pdk(kts) = pdk1 -pdk(kts+1)
3390 !! pdt(kts) = pdt1 -pdt(kts+1)
3391 !! pdq(kts) = pdq1 -pdq(kts+1)
3392 !! pdc(kts) = pdc1 -pdc(kts+1)
3393 pdt(kts) = pdt(kts+1)
3394 pdq(kts) = pdq(kts+1)
3395 pdc(kts) = pdc(kts+1)
3396 !
3397 ! ** Prediction of twice the turbulent kinetic energy **
3398 !! DO k = kts+1,kte-1
3399 DO k = kts,kte-1
3400 b1l = b1*0.5*( el(k+1)+el(k) )
3401 bp(k) = 2.*qkw(k) / b1l
3402 rp(k) = pdk(k+1) + pdk(k)
3403 END DO
3405 !! a(1)=0.
3406 !! b(1)=1.
3407 !! c(1)=-1.
3408 !! d(1)=0.
3410 ! Since df3q(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*df3q(k+1)+bp(k)*delt.
3411 DO k=kts,kte-1
3412 ! a(k-kts+1)=-dtz(k)*df3q(k)
3413 ! b(k-kts+1)=1.+dtz(k)*(df3q(k)+df3q(k+1))+bp(k)*delt
3414 ! c(k-kts+1)=-dtz(k)*df3q(k+1)
3415 ! d(k-kts+1)=rp(k)*delt + qke(k)
3416 ! WA 8/3/15 add EDMF contribution
3417 ! a(k)= - dtz(k)*df3q(k) + 0.5*dtz(k)*s_aw(k)*onoff
3418 ! b(k)=1. + dtz(k)*(df3q(k)+df3q(k+1)) &
3419 ! + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*onoff + bp(k)*delt
3420 ! c(k)= - dtz(k)*df3q(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff
3421 ! d(k)=rp(k)*delt + qke(k) + dtz(k)*(s_awqke(k)-s_awqke(k+1))*onoff
3422 !JOE 8/22/20 improve conservation
3423 a(k)= - dtz(k)*kqdz(k)*rhoinv(k) &
3424 & + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*onoff
3425 b(k)=1. + dtz(k)*(kqdz(k)+kqdz(k+1))*rhoinv(k) &
3426 & + 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*onoff &
3427 & + bp(k)*delt
3428 c(k)= - dtz(k)*kqdz(k+1)*rhoinv(k) &
3429 & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff
3430 d(k)=rp(k)*delt + qke(k) &
3431 & + dtz(k)*rhoinv(k)*(s_awqke(k)-s_awqke(k+1))*onoff
3432 ENDDO
3434 !! DO k=kts+1,kte-1
3435 !! a(k-kts+1)=-dtz(k)*df3q(k)
3436 !! b(k-kts+1)=1.+dtz(k)*(df3q(k)+df3q(k+1))
3437 !! c(k-kts+1)=-dtz(k)*df3q(k+1)
3438 !! d(k-kts+1)=rp(k)*delt + qke(k) - qke(k)*bp(k)*delt
3439 !! ENDDO
3441 !! "no flux at top"
3442 ! a(kte)=-1. !0.
3443 ! b(kte)=1.
3444 ! c(kte)=0.
3445 ! d(kte)=0.
3446 !! "prescribed value"
3447 a(kte)=0.
3448 b(kte)=1.
3449 c(kte)=0.
3450 d(kte)=qke(kte)
3452 ! CALL tridiag(kte,a,b,c,d)
3453 CALL tridiag2(kte,a,b,c,d,x)
3455 DO k=kts,kte
3456 ! qke(k)=max(d(k-kts+1), 1.e-4)
3457 qke(k)=max(x(k), 1.e-4)
3458 qke(k)=min(qke(k), 150.)
3459 ENDDO
3462 !! TKE budget (Puhales, 2020, WRF 4.2.1) << EOB
3463 IF (tke_budget .eq. 1) THEN
3464 !! TKE Vertical transport << EOBvt
3465 tke_up=0.5*qke
3466 dzinv=1./dz
3467 k=kts
3468 qWT1D(k)=dzinv(k)*( &
3469 & (kqdz(k+1)*(tke_up(k+1)-tke_up(k))-kqdz(k)*tke_up(k)) &
3470 & + 0.5*rhoinv(k)*(s_aw(k+1)*tke_up(k+1) &
3471 & + (s_aw(k+1)-s_aw(k))*tke_up(k) &
3472 & + (s_awqke(k)-s_awqke(k+1)))*onoff) !unstaggered
3473 DO k=kts+1,kte-1
3474 qWT1D(k)=dzinv(k)*( &
3475 & (kqdz(k+1)*(tke_up(k+1)-tke_up(k))-kqdz(k)*(tke_up(k)-tke_up(k-1))) &
3476 & + 0.5*rhoinv(k)*(s_aw(k+1)*tke_up(k+1) &
3477 & + (s_aw(k+1)-s_aw(k))*tke_up(k) &
3478 & - s_aw(k)*tke_up(k-1) &
3479 & + (s_awqke(k)-s_awqke(k+1)))*onoff) !unstaggered
3480 ENDDO
3481 k=kte
3482 qWT1D(k)=dzinv(k)*(-kqdz(k)*(tke_up(k)-tke_up(k-1)) &
3483 & + 0.5*rhoinv(k)*(-s_aw(k)*tke_up(k)-s_aw(k)*tke_up(k-1)+s_awqke(k))*onoff) !unstaggared
3484 !! >> EOBvt
3485 qDISS1D=bp*tke_up !! TKE dissipation rate !unstaggered
3486 END IF
3487 !! >> EOB
3489 IF ( closure > 2.5 ) THEN
3491 ! ** Prediction of the moisture variance **
3492 DO k = kts,kte-1
3493 b2l = b2*0.5*( el(k+1)+el(k) )
3494 bp(k) = 2.*qkw(k) / b2l
3495 rp(k) = pdq(k+1) + pdq(k)
3496 END DO
3498 !zero gradient for qsq at bottom and top
3499 !a(1)=0.
3500 !b(1)=1.
3501 !c(1)=-1.
3502 !d(1)=0.
3504 ! Since dfq(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*dfq(k+1)+bp(k)*delt.
3505 DO k=kts,kte-1
3506 a(k)= - dtz(k)*kmdz(k)*rhoinv(k)
3507 b(k)=1. + dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + bp(k)*delt
3508 c(k)= - dtz(k)*kmdz(k+1)*rhoinv(k)
3509 d(k)=rp(k)*delt + qsq(k)
3510 ENDDO
3512 a(kte)=-1. !0.
3513 b(kte)=1.
3514 c(kte)=0.
3515 d(kte)=0.
3517 ! CALL tridiag(kte,a,b,c,d)
3518 CALL tridiag2(kte,a,b,c,d,x)
3520 DO k=kts,kte
3521 !qsq(k)=d(k-kts+1)
3522 qsq(k)=MAX(x(k),1e-17)
3523 ENDDO
3524 ELSE
3525 !level 2.5 - use level 2 diagnostic
3526 DO k = kts,kte-1
3527 IF ( qkw(k) .LE. 0.0 ) THEN
3528 b2l = 0.0
3529 ELSE
3530 b2l = b2*0.25*( el(k+1)+el(k) )/qkw(k)
3531 END IF
3532 qsq(k) = b2l*( pdq(k+1)+pdq(k) )
3533 END DO
3534 qsq(kte)=qsq(kte-1)
3535 END IF
3536 !!!!!!!!!!!!!!!!!!!!!!end level 2.6
3538 IF ( closure .GE. 3.0 ) THEN
3539 !
3540 ! ** dfq for the scalar variance is 1.0*dfm. **
3541 !
3542 ! ** Prediction of the temperature variance **
3543 !! DO k = kts+1,kte-1
3544 DO k = kts,kte-1
3545 b2l = b2*0.5*( el(k+1)+el(k) )
3546 bp(k) = 2.*qkw(k) / b2l
3547 rp(k) = pdt(k+1) + pdt(k)
3548 END DO
3550 !zero gradient for tsq at bottom and top
3552 !! a(1)=0.
3553 !! b(1)=1.
3554 !! c(1)=-1.
3555 !! d(1)=0.
3557 ! Since dfq(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*dfq(k+1)+bp(k)*delt.
3558 DO k=kts,kte-1
3559 !a(k-kts+1)=-dtz(k)*dfq(k)
3560 !b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))+bp(k)*delt
3561 !c(k-kts+1)=-dtz(k)*dfq(k+1)
3562 !d(k-kts+1)=rp(k)*delt + tsq(k)
3563 !JOE 8/22/20 improve conservation
3564 a(k)= - dtz(k)*kmdz(k)*rhoinv(k)
3565 b(k)=1. + dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + bp(k)*delt
3566 c(k)= - dtz(k)*kmdz(k+1)*rhoinv(k)
3567 d(k)=rp(k)*delt + tsq(k)
3568 ENDDO
3570 !! DO k=kts+1,kte-1
3571 !! a(k-kts+1)=-dtz(k)*dfq(k)
3572 !! b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))
3573 !! c(k-kts+1)=-dtz(k)*dfq(k+1)
3574 !! d(k-kts+1)=rp(k)*delt + tsq(k) - tsq(k)*bp(k)*delt
3575 !! ENDDO
3577 a(kte)=-1. !0.
3578 b(kte)=1.
3579 c(kte)=0.
3580 d(kte)=0.
3582 ! CALL tridiag(kte,a,b,c,d)
3583 CALL tridiag2(kte,a,b,c,d,x)
3585 DO k=kts,kte
3586 ! tsq(k)=d(k-kts+1)
3587 tsq(k)=x(k)
3588 ENDDO
3590 ! ** Prediction of the temperature-moisture covariance **
3591 !! DO k = kts+1,kte-1
3592 DO k = kts,kte-1
3593 b2l = b2*0.5*( el(k+1)+el(k) )
3594 bp(k) = 2.*qkw(k) / b2l
3595 rp(k) = pdc(k+1) + pdc(k)
3596 END DO
3598 !zero gradient for tqcov at bottom and top
3600 !! a(1)=0.
3601 !! b(1)=1.
3602 !! c(1)=-1.
3603 !! d(1)=0.
3605 ! Since dfq(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*dfq(k+1)+bp(k)*delt.
3606 DO k=kts,kte-1
3607 !a(k-kts+1)=-dtz(k)*dfq(k)
3608 !b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))+bp(k)*delt
3609 !c(k-kts+1)=-dtz(k)*dfq(k+1)
3610 !d(k-kts+1)=rp(k)*delt + cov(k)
3611 !JOE 8/22/20 improve conservation
3612 a(k)= - dtz(k)*kmdz(k)*rhoinv(k)
3613 b(k)=1. + dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + bp(k)*delt
3614 c(k)= - dtz(k)*kmdz(k+1)*rhoinv(k)
3615 d(k)=rp(k)*delt + cov(k)
3616 ENDDO
3618 !! DO k=kts+1,kte-1
3619 !! a(k-kts+1)=-dtz(k)*dfq(k)
3620 !! b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))
3621 !! c(k-kts+1)=-dtz(k)*dfq(k+1)
3622 !! d(k-kts+1)=rp(k)*delt + cov(k) - cov(k)*bp(k)*delt
3623 !! ENDDO
3625 a(kte)=-1. !0.
3626 b(kte)=1.
3627 c(kte)=0.
3628 d(kte)=0.
3630 ! CALL tridiag(kte,a,b,c,d)
3631 CALL tridiag2(kte,a,b,c,d,x)
3633 DO k=kts,kte
3634 ! cov(k)=d(k-kts+1)
3635 cov(k)=x(k)
3636 ENDDO
3638 ELSE
3640 !Not level 3 - default to level 2 diagnostic
3641 DO k = kts,kte-1
3642 IF ( qkw(k) .LE. 0.0 ) THEN
3643 b2l = 0.0
3644 ELSE
3645 b2l = b2*0.25*( el(k+1)+el(k) )/qkw(k)
3646 END IF
3647 !
3648 tsq(k) = b2l*( pdt(k+1)+pdt(k) )
3649 cov(k) = b2l*( pdc(k+1)+pdc(k) )
3650 END DO
3652 tsq(kte)=tsq(kte-1)
3653 cov(kte)=cov(kte-1)
3655 END IF
3657 #ifdef HARDCODE_VERTICAL
3658 # undef kts
3659 # undef kte
3660 #endif
3662 END SUBROUTINE mym_predict
3664 ! ==================================================================
3665 ! SUBROUTINE mym_condensation:
3666 !
3667 ! Input variables: see subroutine mym_initialize and turbulence
3668 ! exner(nz) : Perturbation of the Exner function (J/kg K)
3669 ! defined on the walls of the grid boxes
3670 ! This is usually computed by integrating
3671 ! d(pi)/dz = h*g*tv/tref**2
3672 ! from the upper boundary, where tv is the
3673 ! virtual potential temperature minus tref.
3674 !
3675 ! Output variables: see subroutine mym_initialize
3676 ! cld(nx,nz,ny) : Cloud fraction
3677 !
3678 ! Work arrays/variables:
3679 ! qmq : Q_w-Q_{sl}, where Q_{sl} is the saturation
3680 ! specific humidity at T=Tl
3681 ! alp(nx,nz,ny) : Functions in the condensation process
3682 ! bet(nx,nz,ny) : ditto
3683 ! sgm(nx,nz,ny) : Combined standard deviation sigma_s
3684 ! multiplied by 2/alp
3685 !
3686 ! # qmq, alp, bet and sgm are allowed to share storage units with
3687 ! any four of other work arrays for saving memory.
3688 !
3689 ! # Results are sensitive particularly to values of cp and r_d.
3690 ! Set these values to those adopted by you.
3691 !
3692 !-------------------------------------------------------------------
3693 !>\ingroup gsd_mynn_edmf
3694 !! This subroutine calculates the nonconvective component of the
3695 !! subgrid cloud fraction and mixing ratio as well as the functions used to
3696 !! calculate the buoyancy flux. Different cloud PDFs can be selected by
3697 !! use of the namelist parameter \p bl_mynn_cloudpdf .
3698 SUBROUTINE mym_condensation (kts,kte, &
3699 & dx, dz, zw, xland, &
3700 & thl, qw, qv, qc, qi, &
3701 & p,exner, &
3702 & tsq, qsq, cov, &
3703 & Sh, el, bl_mynn_cloudpdf, &
3704 & qc_bl1D, qi_bl1D, &
3705 & cldfra_bl1D, &
3706 & PBLH1,HFX1, &
3707 & Vt, Vq, th, sgm, rmo, &
3708 & spp_pbl,rstoch_col )
3710 !-------------------------------------------------------------------
3712 INTEGER, INTENT(IN) :: kts,kte, bl_mynn_cloudpdf
3714 #ifdef HARDCODE_VERTICAL
3715 # define kts 1
3716 # define kte HARDCODE_VERTICAL
3717 #endif
3719 REAL, INTENT(IN) :: dx,PBLH1,HFX1,rmo,xland
3720 REAL, DIMENSION(kts:kte), INTENT(IN) :: dz
3721 REAL, DIMENSION(kts:kte+1), INTENT(IN) :: zw
3722 REAL, DIMENSION(kts:kte), INTENT(IN) :: p,exner,thl,qw,qv,qc,qi, &
3723 &tsq, qsq, cov, th
3725 REAL, DIMENSION(kts:kte), INTENT(INOUT) :: vt,vq,sgm
3727 REAL, DIMENSION(kts:kte) :: alp,a,bet,b,ql,q1,RH
3728 REAL, DIMENSION(kts:kte), INTENT(OUT) :: qc_bl1D,qi_bl1D, &
3729 cldfra_bl1D
3730 DOUBLE PRECISION :: t3sq, r3sq, c3sq
3732 REAL :: qsl,esat,qsat,dqsl,cld0,q1k,qlk,eq1,qll,&
3733 &q2p,pt,rac,qt,t,xl,rsl,cpm,Fng,qww,alpha,beta,bb,&
3734 &ls,wt,cld_factor,fac_damp,liq_frac,ql_ice,ql_water,&
3735 &qmq,qsat_tk
3736 INTEGER :: i,j,k
3738 REAL :: erf
3740 !VARIABLES FOR ALTERNATIVE SIGMA
3741 REAL::dth,dtl,dqw,dzk,els
3742 REAL, DIMENSION(kts:kte), INTENT(IN) :: Sh,el
3744 !variables for SGS BL clouds
3745 REAL :: zagl,damp,PBLH2
3746 REAL :: cfmax
3748 !JAYMES: variables for tropopause-height estimation
3749 REAL :: theta1, theta2, ht1, ht2
3750 INTEGER :: k_tropo
3752 ! Stochastic
3753 INTEGER, INTENT(IN) :: spp_pbl
3754 REAL, DIMENSION(KTS:KTE) :: rstoch_col
3755 REAL :: qw_pert
3757 ! First, obtain an estimate for the tropopause height (k), using the method employed in the
3758 ! Thompson subgrid-cloud scheme. This height will be a consideration later when determining
3759 ! the "final" subgrid-cloud properties.
3760 ! JAYMES: added 3 Nov 2016, adapted from G. Thompson
3762 DO k = kte-3, kts, -1
3763 theta1 = th(k)
3764 theta2 = th(k+2)
3765 ht1 = 44307.692 * (1.0 - (p(k)/101325.)**0.190)
3766 ht2 = 44307.692 * (1.0 - (p(k+2)/101325.)**0.190)
3767 if ( (((theta2-theta1)/(ht2-ht1)) .lt. 10./1500. ) .AND. &
3768 & (ht1.lt.19000.) .and. (ht1.gt.4000.) ) then
3769 goto 86
3770 endif
3771 ENDDO
3772 86 continue
3773 k_tropo = MAX(kts+2, k+2)
3775 zagl = 0.
3777 SELECT CASE(bl_mynn_cloudpdf)
3779 CASE (0) ! ORIGINAL MYNN PARTIAL-CONDENSATION SCHEME
3781 DO k = kts,kte-1
3782 t = th(k)*exner(k)
3784 !x if ( ct .gt. 0.0 ) then
3785 ! a = 17.27
3786 ! b = 237.3
3787 !x else
3788 !x a = 21.87
3789 !x b = 265.5
3790 !x end if
3791 !
3792 ! ** 3.8 = 0.622*6.11 (hPa) **
3794 !SATURATED VAPOR PRESSURE
3795 esat = esat_blend(t)
3796 !SATURATED SPECIFIC HUMIDITY
3797 !qsl=ep_2*esat/(p(k)-ep_3*esat)
3798 qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat))
3799 !dqw/dT: Clausius-Clapeyron
3800 dqsl = qsl*ep_2*xlv/( r_d*t**2 )
3802 alp(k) = 1.0/( 1.0+dqsl*xlvcp )
3803 bet(k) = dqsl*exner(k)
3805 !Sommeria and Deardorff (1977) scheme, as implemented
3806 !in Nakanishi and Niino (2009), Appendix B
3807 t3sq = MAX( tsq(k), 0.0 )
3808 r3sq = MAX( qsq(k), 0.0 )
3809 c3sq = cov(k)
3810 c3sq = SIGN( MIN( ABS(c3sq), SQRT(t3sq*r3sq) ), c3sq )
3811 r3sq = r3sq +bet(k)**2*t3sq -2.0*bet(k)*c3sq
3812 !DEFICIT/EXCESS WATER CONTENT
3813 qmq = qw(k) -qsl
3814 !ORIGINAL STANDARD DEVIATION
3815 sgm(k) = SQRT( MAX( r3sq, 1.0d-10 ))
3816 !NORMALIZED DEPARTURE FROM SATURATION
3817 q1(k) = qmq / sgm(k)
3818 !CLOUD FRACTION. rr2 = 1/SQRT(2) = 0.707
3819 cldfra_bl1D(k) = 0.5*( 1.0+erf( q1(k)*rr2 ) )
3821 q1k = q1(k)
3822 eq1 = rrp*EXP( -0.5*q1k*q1k )
3823 qll = MAX( cldfra_bl1D(k)*q1k + eq1, 0.0 )
3824 !ESTIMATED LIQUID WATER CONTENT (UNNORMALIZED)
3825 ql(k) = alp(k)*sgm(k)*qll
3826 !LIMIT SPECIES TO TEMPERATURE RANGES
3827 liq_frac = min(1.0, max(0.0,(t-240.0)/29.0))
3828 qc_bl1D(k) = liq_frac*ql(k)
3829 qi_bl1D(k) = (1.0 - liq_frac)*ql(k)
3831 if(cldfra_bl1D(k)>0.01 .and. qc_bl1D(k)<1.E-6)qc_bl1D(k)=1.E-6
3832 if(cldfra_bl1D(k)>0.01 .and. qi_bl1D(k)<1.E-8)qi_bl1D(k)=1.E-8
3834 !Now estimate the buoyancy flux functions
3835 q2p = xlvcp/exner(k)
3836 pt = thl(k) +q2p*ql(k) ! potential temp
3838 !qt is a THETA-V CONVERSION FOR TOTAL WATER (i.e., THETA-V = qt*THETA)
3839 qt = 1.0 +p608*qw(k) -(1.+p608)*(qc_bl1D(k)+qi_bl1D(k))*cldfra_bl1D(k)
3840 rac = alp(k)*( cldfra_bl1D(K)-qll*eq1 )*( q2p*qt-(1.+p608)*pt )
3842 !BUOYANCY FACTORS: wherever vt and vq are used, there is a
3843 !"+1" and "+tv0", respectively, so these are subtracted out here.
3844 !vt is unitless and vq has units of K.
3845 vt(k) = qt-1.0 -rac*bet(k)
3846 vq(k) = p608*pt-tv0 +rac
3848 END DO
3850 CASE (1, -1) !ALTERNATIVE FORM (Nakanishi & Niino 2004 BLM, eq. B6, and
3851 !Kuwano-Yoshida et al. 2010 QJRMS, eq. 7):
3852 DO k = kts,kte-1
3853 t = th(k)*exner(k)
3854 !SATURATED VAPOR PRESSURE
3855 esat = esat_blend(t)
3856 !SATURATED SPECIFIC HUMIDITY
3857 !qsl=ep_2*esat/(p(k)-ep_3*esat)
3858 qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat))
3859 !dqw/dT: Clausius-Clapeyron
3860 dqsl = qsl*ep_2*xlv/( r_d*t**2 )
3862 alp(k) = 1.0/( 1.0+dqsl*xlvcp )
3863 bet(k) = dqsl*exner(k)
3865 if (k .eq. kts) then
3866 dzk = 0.5*dz(k)
3867 else
3868 dzk = dz(k)
3869 end if
3870 dth = 0.5*(thl(k+1)+thl(k)) - 0.5*(thl(k)+thl(MAX(k-1,kts)))
3871 dqw = 0.5*(qw(k+1) + qw(k)) - 0.5*(qw(k) + qw(MAX(k-1,kts)))
3872 sgm(k) = SQRT( MAX( (alp(k)**2 * MAX(el(k)**2,0.1) * &
3873 b2 * MAX(Sh(k),0.03))/4. * &
3874 (dqw/dzk - bet(k)*(dth/dzk ))**2 , 1.0e-10) )
3875 qmq = qw(k) -qsl
3876 q1(k) = qmq / sgm(k)
3877 cldfra_bl1D(K) = 0.5*( 1.0+erf( q1(k)*rr2 ) )
3879 !now compute estimated lwc for PBL scheme's use
3880 !qll IS THE NORMALIZED LIQUID WATER CONTENT (Sommeria and
3881 !Deardorff (1977, eq 29a). rrp = 1/(sqrt(2*pi)) = 0.3989
3882 q1k = q1(k)
3883 eq1 = rrp*EXP( -0.5*q1k*q1k )
3884 qll = MAX( cldfra_bl1D(K)*q1k + eq1, 0.0 )
3885 !ESTIMATED LIQUID WATER CONTENT (UNNORMALIZED)
3886 ql (k) = alp(k)*sgm(k)*qll
3887 liq_frac = min(1.0, max(0.0,(t-240.0)/29.0))
3888 qc_bl1D(k) = liq_frac*ql(k)
3889 qi_bl1D(k) = (1.0 - liq_frac)*ql(k)
3891 if(cldfra_bl1D(k)>0.01 .and. qc_bl1D(k)<1.E-6)qc_bl1D(k)=1.E-6
3892 if(cldfra_bl1D(k)>0.01 .and. qi_bl1D(k)<1.E-8)qi_bl1D(k)=1.E-8
3894 !Now estimate the buoyancy flux functions
3895 q2p = xlvcp/exner(k)
3896 pt = thl(k) +q2p*ql(k) ! potential temp
3898 !qt is a THETA-V CONVERSION FOR TOTAL WATER (i.e., THETA-V = qt*THETA)
3899 qt = 1.0 +p608*qw(k) -(1.+p608)*(qc_bl1D(k)+qi_bl1D(k))*cldfra_bl1D(k)
3900 rac = alp(k)*( cldfra_bl1D(K)-qll*eq1 )*( q2p*qt-(1.+p608)*pt )
3902 !BUOYANCY FACTORS: wherever vt and vq are used, there is a
3903 !"+1" and "+tv0", respectively, so these are subtracted out here.
3904 !vt is unitless and vq has units of K.
3905 vt(k) = qt-1.0 -rac*bet(k)
3906 vq(k) = p608*pt-tv0 +rac
3908 END DO
3910 CASE (2, -2)
3912 !Diagnostic statistical scheme of Chaboureau and Bechtold (2002), JAS
3913 !but with use of higher-order moments to estimate sigma
3914 PBLH2=MAX(10.,PBLH1)
3915 zagl = 0.
3916 DO k = kts,kte-1
3917 zagl = zagl + dz(k)
3918 t = th(k)*exner(k)
3920 xl = xl_blend(t) ! obtain latent heat
3921 qsat_tk = qsat_blend(t, p(k)) ! saturation water vapor mixing ratio at tk and p
3922 rh(k)=MAX(MIN(1.0,qw(k)/MAX(1.E-8,qsat_tk)),0.001)
3924 !dqw/dT: Clausius-Clapeyron
3925 dqsl = qsat_tk*ep_2*xlv/( r_d*t**2 )
3926 alp(k) = 1.0/( 1.0+dqsl*xlvcp )
3927 bet(k) = dqsl*exner(k)
3929 rsl = xl*qsat_tk / (r_v*t**2) ! slope of C-C curve at t (=abs temperature)
3930 ! CB02, Eqn. 4
3931 cpm = cp + qw(k)*cpv ! CB02, sec. 2, para. 1
3932 a(k) = 1./(1. + xl*rsl/cpm) ! CB02 variable "a"
3933 b(k) = a(k)*rsl ! CB02 variable "b"
3935 !SPP
3936 qw_pert = qw(k) + qw(k)*0.5*rstoch_col(k)*real(spp_pbl)
3938 !This form of qmq (the numerator of Q1) no longer uses the a(k) factor
3939 qmq = qw_pert - qsat_tk ! saturation deficit/excess;
3941 !Use the form of Eq. (6) in Chaboureau and Bechtold (2002)
3942 !except neglect all but the first term for sig_r
3943 r3sq = MAX( qsq(k), 0.0 )
3944 !Calculate sigma using higher-order moments:
3945 sgm(k) = SQRT( r3sq )
3946 !Set limits on sigma relative to saturation water vapor
3947 sgm(k) = MIN( sgm(k), qsat_tk*0.666 ) !500 )
3948 sgm(k) = MAX( sgm(k), qsat_tk*0.035 ) !Note: 0.02 results in SWDOWN similar
3949 !to the first-order version of sigma
3950 q1(k) = qmq / sgm(k) ! Q1, the normalized saturation
3951 q1k = q1(k) ! backup Q1 for later modification
3953 ! Specify cloud fraction
3954 !Original C-B cloud fraction, allows cloud fractions out to q1 = -3.5
3955 !cldfra_bl1D(K) = max(0., min(1., 0.5+0.36*atan(1.55*q1(k)))) ! Eq. 7 in CB02
3956 !Waynes LES fit - over-diffuse, when limits removed from vt & vq & fng
3957 !cldfra_bl1D(K) = max(0., min(1., 0.5+0.36*atan(1.2*(q1(k)+0.4))))
3958 !Best compromise: Improves marine stratus without adding much cold bias.
3959 cldfra_bl1D(K) = max(0., min(1., 0.5+0.36*atan(1.8*(q1(k)+0.2))))
3961 ! Specify hydrometeors
3962 ! JAYMES- this option added 8 May 2015
3963 ! The cloud water formulations are taken from CB02, Eq. 8.
3964 IF (q1k < 0.) THEN !unsaturated
3965 ql_water = sgm(k)*EXP(1.2*q1k-1)
3966 ql_ice = sgm(k)*EXP(1.2*q1k-1.)
3967 ELSE IF (q1k > 2.) THEN !supersaturated
3968 ql_water = sgm(k)*q1k
3969 ql_ice = sgm(k)*q1k
3970 ELSE !slightly saturated (0 > q1 < 2)
3971 ql_water = sgm(k)*(EXP(-1.) + 0.66*q1k + 0.086*q1k**2)
3972 ql_ice = sgm(k)*(EXP(-1.) + 0.66*q1k + 0.086*q1k**2)
3973 ENDIF
3975 !In saturated grid cells, use average of SGS and resolved values
3976 if ( qc(k) > 1.e-6 ) ql_water = 0.5 * ( ql_water + qc(k) )
3977 !since ql_ice is actually the total frozen condensate (snow+ice),
3978 !do not average with grid-scale ice alone
3979 !if ( qi(k) > 1.e-9 ) ql_ice = 0.5 * ( ql_ice + qi(k) )
3981 if (cldfra_bl1D(k) < 0.01) then
3982 ql_ice = 0.0
3983 ql_water = 0.0
3984 cldfra_bl1D(k) = 0.0
3985 endif
3987 !PHASE PARTITIONING: currently commented out since we are moving towards prognostic sgs clouds
3988 !Make some inferences about the relative amounts of
3989 !subgrid cloud water vs. ice based on collocated explicit clouds. Otherise,
3990 !use a simple temperature-dependent partitioning.
3991 ! IF ( qc(k) + qi(k) > 0.0 ) THEN ! explicit condensate exists, retain its phase partitioning
3992 ! IF ( qi(k) == 0.0 ) THEN ! explicit contains no ice; assume subgrid liquid
3993 ! liq_frac = 1.0
3994 ! ELSE IF ( qc(k) == 0.0 ) THEN ! explicit contains no liquid; assume subgrid ice
3995 ! liq_frac = 0.0
3996 ! ELSE IF ( (qc(k) >= 1.E-10) .AND. (qi(k) >= 1.E-10) ) THEN ! explicit contains mixed phase of workably
3997 ! ! large amounts; assume subgrid follows
3998 ! ! same partioning
3999 ! liq_frac = qc(k) / ( qc(k) + qi(k) )
4000 ! ELSE
4001 ! liq_frac = MIN(1.0, MAX(0.0, (t-tice)/(t0c-tice))) ! explicit contains mixed phase, but at least one
4002 ! ! species is very small, so make a temperature-
4003 ! ! depedent guess
4004 ! ENDIF
4005 ! ELSE ! no explicit condensate, so make a temperature-dependent guess
4006 liq_frac = MIN(1.0, MAX(0.0, (t-tice)/(tliq-tice)))
4007 ! ENDIF
4009 qc_bl1D(k) = liq_frac*ql_water ! apply liq_frac to ql_water and ql_ice
4010 qi_bl1D(k) = (1.0-liq_frac)*ql_ice
4012 !Above tropopause: eliminate subgrid clouds from CB scheme
4013 if (k .ge. k_tropo-1) then
4014 cldfra_bl1D(K) = 0.
4015 qc_bl1D(k) = 0.
4016 qi_bl1D(k) = 0.
4017 endif
4019 !Buoyancy-flux-related calculations follow...
4020 !limiting Q1 to avoid too much diffusion in cloud layers
4021 q1k=max(Q1(k),-2.0)
4023 ! "Fng" represents the non-Gaussian transport factor
4024 ! (non-dimensional) from Bechtold et al. 1995
4025 ! (hereafter BCMT95), section 3(c). Their suggested
4026 ! forms for Fng (from their Eq. 20) are:
4027 !IF (q1k < -2.) THEN
4028 ! Fng = 2.-q1k
4029 !ELSE IF (q1k > 0.) THEN
4030 ! Fng = 1.
4031 !ELSE
4032 ! Fng = 1.-1.5*q1k
4033 !ENDIF
4034 ! Use the form of "Fng" from Bechtold and Siebesma (1998, JAS)
4035 IF (q1k .GE. 1.0) THEN
4036 Fng = 1.0
4037 ELSEIF (q1k .GE. -1.7 .AND. q1k .LT. 1.0) THEN
4038 Fng = EXP(-0.4*(q1k-1.0))
4039 ELSEIF (q1k .GE. -2.5 .AND. q1k .LT. -1.7) THEN
4040 Fng = 3.0 + EXP(-3.8*(q1k+1.7))
4041 ELSE
4042 Fng = MIN(23.9 + EXP(-1.6*(q1k+2.5)), 60.)
4043 ENDIF
4045 cfmax= min(cldfra_bl1D(k), 0.5)
4046 bb = b(k)*t/th(k) ! bb is "b" in BCMT95. Their "b" differs from
4047 ! "b" in CB02 (i.e., b(k) above) by a factor
4048 ! of T/theta. Strictly, b(k) above is formulated in
4049 ! terms of sat. mixing ratio, but bb in BCMT95 is
4050 ! cast in terms of sat. specific humidity. The
4051 ! conversion is neglected here.
4052 qww = 1.+0.61*qw(k)
4053 alpha = 0.61*th(k)
4054 beta = (th(k)/t)*(xl/cp) - 1.61*th(k)
4055 vt(k) = qww - cfmax*beta*bb*Fng - 1.
4056 vq(k) = alpha + cfmax*beta*a(k)*Fng - tv0
4057 ! vt and vq correspond to beta-theta and beta-q, respectively,
4058 ! in NN09, Eq. B8. They also correspond to the bracketed
4059 ! expressions in BCMT95, Eq. 15, since (s*ql/sigma^2) = cldfra*Fng
4060 ! The "-1" and "-tv0" terms are included for consistency with
4061 ! the legacy vt and vq formulations (above).
4063 ! dampen amplification factor where need be
4064 fac_damp = min(zagl * 0.0025, 1.0)
4065 !cld_factor = 1.0 + fac_damp*MAX(0.0, ( RH(k) - 0.75 ) / 0.26 )**1.9 !HRRRv4
4066 !cld_factor = 1.0 + fac_damp*min((max(0.0, ( RH(k) - 0.92 )) / 0.25 )**2, 0.3)
4067 cld_factor = 1.0 + fac_damp*min((max(0.0, ( RH(k) - 0.92 )) / 0.145)**2, 0.4)
4068 cldfra_bl1D(K) = MIN( 1., cld_factor*cldfra_bl1D(K) )
4069 enddo
4071 END SELECT !end cloudPDF option
4073 !For testing purposes only, option for isolating on the mass-flux clouds.
4074 IF (bl_mynn_cloudpdf .LT. 0) THEN
4075 DO k = kts,kte-1
4076 cldfra_bl1D(k) = 0.0
4077 qc_bl1D(k) = 0.0
4078 qi_bl1D(k) = 0.0
4079 END DO
4080 ENDIF
4081 !
4082 ql(kte) = ql(kte-1)
4083 vt(kte) = vt(kte-1)
4084 vq(kte) = vq(kte-1)
4085 qc_bl1D(kte)=0.
4086 qi_bl1D(kte)=0.
4087 cldfra_bl1D(kte)=0.
4088 RETURN
4090 #ifdef HARDCODE_VERTICAL
4091 # undef kts
4092 # undef kte
4093 #endif
4095 END SUBROUTINE mym_condensation
4097 ! ==================================================================
4098 !>\ingroup gsd_mynn_edmf
4099 !! This subroutine solves for tendencies of U, V, \f$\theta\f$, qv,
4100 !! qc, and qi
4101 SUBROUTINE mynn_tendencies(kts,kte,i, &
4102 &delt,dz,rho, &
4103 &u,v,th,tk,qv,qc,qi,qnc,qni, &
4104 &psfc,p,exner, &
4105 &thl,sqv,sqc,sqi,sqw, &
4106 &qnwfa,qnifa,qnbca,ozone, &
4107 &ust,flt,flq,flqv,flqc,wspd, &
4108 &uoce,voce, &
4109 &tsq,qsq,cov, &
4110 &tcd,qcd, &
4111 &dfm,dfh,dfq, &
4112 &Du,Dv,Dth,Dqv,Dqc,Dqi,Dqnc,Dqni, &
4113 &Dqnwfa,Dqnifa,Dqnbca,Dozone, &
4114 &diss_heat, &
4115 &s_aw,s_awthl,s_awqt,s_awqv,s_awqc, &
4116 &s_awu,s_awv, &
4117 &s_awqnc,s_awqni, &
4118 &s_awqnwfa,s_awqnifa,s_awqnbca, &
4119 &sd_aw,sd_awthl,sd_awqt,sd_awqv, &
4120 &sd_awqc,sd_awu,sd_awv, &
4121 &sub_thl,sub_sqv, &
4122 &sub_u,sub_v, &
4123 &det_thl,det_sqv,det_sqc, &
4124 &det_u,det_v, &
4125 &FLAG_QC,FLAG_QI,FLAG_QNC,FLAG_QNI, &
4126 &FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA, &
4127 &cldfra_bl1d, &
4128 &bl_mynn_cloudmix, &
4129 &bl_mynn_mixqt, &
4130 &bl_mynn_edmf, &
4131 &bl_mynn_edmf_mom, &
4132 &bl_mynn_mixscalars )
4134 !-------------------------------------------------------------------
4135 INTEGER, INTENT(in) :: kts,kte,i
4137 #ifdef HARDCODE_VERTICAL
4138 # define kts 1
4139 # define kte HARDCODE_VERTICAL
4140 #endif
4142 INTEGER, INTENT(in) :: bl_mynn_cloudmix,bl_mynn_mixqt,&
4143 bl_mynn_edmf,bl_mynn_edmf_mom, &
4144 bl_mynn_mixscalars
4145 LOGICAL, INTENT(IN) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,&
4146 FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA
4148 ! thl - liquid water potential temperature
4149 ! qw - total water
4150 ! dfm,dfh,dfq - diffusivities i.e., dfh(k) = elq*sh(k) / dzk
4151 ! flt - surface flux of thl
4152 ! flq - surface flux of qw
4154 ! mass-flux plumes
4155 REAL, DIMENSION(kts:kte+1), INTENT(in) :: s_aw,s_awthl,s_awqt,&
4156 &s_awqnc,s_awqni,s_awqv,s_awqc,s_awu,s_awv, &
4157 &s_awqnwfa,s_awqnifa,s_awqnbca, &
4158 &sd_aw,sd_awthl,sd_awqt,sd_awqv,sd_awqc,sd_awu,sd_awv
4159 ! tendencies from mass-flux environmental subsidence and detrainment
4160 REAL, DIMENSION(kts:kte), INTENT(in) :: sub_thl,sub_sqv, &
4161 &sub_u,sub_v,det_thl,det_sqv,det_sqc,det_u,det_v
4162 REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,th,tk,qv,qc,qi,qni,qnc,&
4163 &rho,p,exner,dfq,dz,tsq,qsq,cov,tcd,qcd,cldfra_bl1d,diss_heat
4164 REAL, DIMENSION(kts:kte), INTENT(inout) :: thl,sqw,sqv,sqc,sqi,&
4165 &qnwfa,qnifa,qnbca,ozone,dfm,dfh
4166 REAL, DIMENSION(kts:kte), INTENT(inout) :: du,dv,dth,dqv,dqc,dqi,&
4167 &dqni,dqnc,dqnwfa,dqnifa,dqnbca,dozone
4168 REAL, INTENT(IN) :: delt,ust,flt,flq,flqv,flqc,wspd,uoce,voce,&
4169 &psfc
4170 !debugging
4171 REAL ::wsp,wsp2,tk2,th2
4172 LOGICAL :: problem
4173 integer :: kproblem
4175 ! REAL, INTENT(IN) :: gradu_top,gradv_top,gradth_top,gradqv_top
4177 !local vars
4179 REAL, DIMENSION(kts:kte) :: dtz,dfhc,dfmc,delp
4180 REAL, DIMENSION(kts:kte) :: sqv2,sqc2,sqi2,sqw2,qni2,qnc2, & !AFTER MIXING
4181 qnwfa2,qnifa2,qnbca2,ozone2
4182 REAL, DIMENSION(kts:kte) :: zfac,plumeKh,rhoinv
4183 REAL, DIMENSION(kts:kte) :: a,b,c,d,x
4184 REAL, DIMENSION(kts:kte+1) :: rhoz, & !rho on model interface
4185 & khdz, kmdz
4186 REAL :: rhs,gfluxm,gfluxp,dztop,maxdfh,mindfh,maxcf,maxKh,zw
4187 REAL :: t,esat,qsl,onoff,kh,km,dzk,rhosfc
4188 REAL :: ustdrag,ustdiff,qvflux
4189 REAL :: th_new,portion_qc,portion_qi,condensate,qsat
4190 INTEGER :: k,kk
4192 !Activate nonlocal mixing from the mass-flux scheme for
4193 !number concentrations and aerosols (0.0 = no; 1.0 = yes)
4194 REAL, PARAMETER :: nonloc = 1.0
4196 dztop=.5*(dz(kte)+dz(kte-1))
4198 ! REGULATE THE MOMENTUM MIXING FROM THE MASS-FLUX SCHEME (on or off)
4199 ! Note that s_awu and s_awv already come in as 0.0 if bl_mynn_edmf_mom == 0, so
4200 ! we only need to zero-out the MF term
4201 IF (bl_mynn_edmf_mom == 0) THEN
4202 onoff=0.0
4203 ELSE
4204 onoff=1.0
4205 ENDIF
4207 !Prepare "constants" for diffusion equation.
4208 !khdz = rho*Kh/dz = rho*dfh
4209 rhosfc = psfc/(R_d*(tk(kts)+p608*qv(kts)))
4210 dtz(kts) =delt/dz(kts)
4211 rhoz(kts) =rho(kts)
4212 rhoinv(kts)=1./rho(kts)
4213 khdz(kts) =rhoz(kts)*dfh(kts)
4214 kmdz(kts) =rhoz(kts)*dfm(kts)
4215 delp(kts) = psfc - (p(kts+1)*dz(kts) + p(kts)*dz(kts+1))/(dz(kts)+dz(kts+1))
4216 DO k=kts+1,kte
4217 dtz(k) =delt/dz(k)
4218 rhoz(k) =(rho(k)*dz(k-1) + rho(k-1)*dz(k))/(dz(k-1)+dz(k))
4219 rhoz(k) = MAX(rhoz(k),1E-4)
4220 rhoinv(k)=1./MAX(rho(k),1E-4)
4221 dzk = 0.5 *( dz(k)+dz(k-1) )
4222 khdz(k) = rhoz(k)*dfh(k)
4223 kmdz(k) = rhoz(k)*dfm(k)
4224 ENDDO
4225 DO k=kts+1,kte-1
4226 delp(k) = (p(k)*dz(k-1) + p(k-1)*dz(k))/(dz(k)+dz(k-1)) - &
4227 (p(k+1)*dz(k) + p(k)*dz(k+1))/(dz(k)+dz(k+1))
4228 ENDDO
4229 delp(kte) =delp(kte-1)
4230 rhoz(kte+1)=rhoz(kte)
4231 khdz(kte+1)=rhoz(kte+1)*dfh(kte)
4232 kmdz(kte+1)=rhoz(kte+1)*dfm(kte)
4234 !stability criteria for mf
4235 DO k=kts+1,kte-1
4236 khdz(k) = MAX(khdz(k), 0.5*s_aw(k))
4237 khdz(k) = MAX(khdz(k), -0.5*(s_aw(k)-s_aw(k+1)))
4238 kmdz(k) = MAX(kmdz(k), 0.5*s_aw(k))
4239 kmdz(k) = MAX(kmdz(k), -0.5*(s_aw(k)-s_aw(k+1)))
4240 ENDDO
4242 ustdrag = MIN(ust*ust,0.99)/wspd ! limit at ~ 20 m/s
4243 ustdiff = MIN(ust*ust,0.01)/wspd ! limit at ~ 2 m/s
4244 dth(kts:kte) = 0.0 ! must initialize for moisture_check routine
4246 !!============================================
4247 !! u
4248 !!============================================
4250 k=kts
4252 !original approach (drag in b-vector):
4253 ! a(1)=0.
4254 ! b(1)=1. + dtz(k)*(dfm(k+1)+ust**2/wspd) - 0.5*dtz(k)*s_aw(k+1)*onoff
4255 ! c(1)=-dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff
4256 ! d(1)=u(k) + dtz(k)*uoce*ust**2/wspd - dtz(k)*s_awu(k+1)*onoff + &
4257 ! sub_u(k)*delt + det_u(k)*delt
4259 !rho-weighted (drag in b-vector):
4260 a(k)= -dtz(k)*kmdz(k)*rhoinv(k)
4261 b(k)=1.+dtz(k)*(kmdz(k+1)+rhosfc*ust**2/wspd)*rhoinv(k) &
4262 & - 0.5*dtz(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff
4263 c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) &
4264 & - 0.5*dtz(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff
4265 d(k)=u(k) + dtz(k)*uoce*ust**2/wspd - dtz(k)*s_awu(k+1)*onoff - &
4266 & dtz(k)*rhoinv(k)*sd_awu(k+1)*onoff + sub_u(k)*delt + det_u(k)*delt
4268 !rho-weighted with drag term moved out of b-array
4269 ! a(k)= -dtz(k)*kmdz(k)*rhoinv(k)
4270 ! b(k)=1.+dtz(k)*(kmdz(k+1))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff
4271 ! c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff
4272 ! d(k)=u(k)*(1.-ust**2/wspd*dtz(k)*rhosfc/rho(k)) + dtz(k)*uoce*ust**2/wspd - &
4273 ! !!!d(k)=u(k)*(1.-ust**2/wspd*dtz(k)) + dtz(k)*uoce*ust**2/wspd - &
4274 ! & dtz(k)*rhoinv(k)*s_awu(k+1)*onoff - dtz(k)*rhoinv(k)*sd_awu(k+1)*onoff + sub_u(k)*delt + det_u(k)*delt
4276 DO k=kts+1,kte-1
4277 a(k)= -dtz(k)*kmdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*onoff + 0.5*dtz(k)*rhoinv(k)*sd_aw(k)*onoff
4278 b(k)=1.+dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + &
4279 & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*onoff + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1))*onoff
4280 c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff
4281 d(k)=u(k) + dtz(k)*rhoinv(k)*(s_awu(k)-s_awu(k+1))*onoff + dtz(k)*rhoinv(k)*(sd_awu(k)-sd_awu(k+1))*onoff + &
4282 & sub_u(k)*delt + det_u(k)*delt
4283 ENDDO
4285 !! no flux at the top
4286 ! a(kte)=-1.
4287 ! b(kte)=1.
4288 ! c(kte)=0.
4289 ! d(kte)=0.
4291 !! specified gradient at the top
4292 ! a(kte)=-1.
4293 ! b(kte)=1.
4294 ! c(kte)=0.
4295 ! d(kte)=gradu_top*dztop
4297 !! prescribed value
4298 a(kte)=0
4299 b(kte)=1.
4300 c(kte)=0.
4301 d(kte)=u(kte)
4303 ! CALL tridiag(kte,a,b,c,d)
4304 CALL tridiag2(kte,a,b,c,d,x)
4305 ! CALL tridiag3(kte,a,b,c,d,x)
4307 DO k=kts,kte
4308 ! du(k)=(d(k-kts+1)-u(k))/delt
4309 du(k)=(x(k)-u(k))/delt
4310 ENDDO
4312 !!============================================
4313 !! v
4314 !!============================================
4316 k=kts
4318 !original approach (drag in b-vector):
4319 ! a(1)=0.
4320 ! b(1)=1. + dtz(k)*(dfm(k+1)+ust**2/wspd) - 0.5*dtz(k)*s_aw(k+1)*onoff
4321 ! c(1)= - dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff
4322 ! d(1)=v(k) + dtz(k)*voce*ust**2/wspd - dtz(k)*s_awv(k+1)*onoff + &
4323 ! sub_v(k)*delt + det_v(k)*delt
4325 !rho-weighted (drag in b-vector):
4326 a(k)= -dtz(k)*kmdz(k)*rhoinv(k)
4327 b(k)=1.+dtz(k)*(kmdz(k+1) + rhosfc*ust**2/wspd)*rhoinv(k) &
4328 & - 0.5*dtz(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff
4329 c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff
4330 d(k)=v(k) + dtz(k)*voce*ust**2/wspd - dtz(k)*s_awv(k+1)*onoff - dtz(k)*rhoinv(k)*sd_awv(k+1)*onoff + &
4331 & sub_v(k)*delt + det_v(k)*delt
4333 !rho-weighted with drag term moved out of b-array
4334 ! a(k)= -dtz(k)*kmdz(k)*rhoinv(k)
4335 ! b(k)=1.+dtz(k)*(kmdz(k+1))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff
4336 ! c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff
4337 ! d(k)=v(k)*(1.-ust**2/wspd*dtz(k)*rhosfc/rho(k)) + dtz(k)*voce*ust**2/wspd - &
4338 ! !!!d(k)=v(k)*(1.-ust**2/wspd*dtz(k)) + dtz(k)*voce*ust**2/wspd - &
4339 ! & dtz(k)*rhoinv(k)*s_awv(k+1)*onoff - dtz(k)*rhoinv(k)*sd_awv(k+1)*onoff + sub_v(k)*delt + det_v(k)*delt
4341 DO k=kts+1,kte-1
4342 a(k)= -dtz(k)*kmdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*onoff + 0.5*dtz(k)*rhoinv(k)*sd_aw(k)*onoff
4343 b(k)=1.+dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + &
4344 & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*onoff + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1))*onoff
4345 c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff
4346 d(k)=v(k) + dtz(k)*rhoinv(k)*(s_awv(k)-s_awv(k+1))*onoff + dtz(k)*rhoinv(k)*(sd_awv(k)-sd_awv(k+1))*onoff + &
4347 & sub_v(k)*delt + det_v(k)*delt
4348 ENDDO
4350 !! no flux at the top
4351 ! a(kte)=-1.
4352 ! b(kte)=1.
4353 ! c(kte)=0.
4354 ! d(kte)=0.
4356 !! specified gradient at the top
4357 ! a(kte)=-1.
4358 ! b(kte)=1.
4359 ! c(kte)=0.
4360 ! d(kte)=gradv_top*dztop
4362 !! prescribed value
4363 a(kte)=0
4364 b(kte)=1.
4365 c(kte)=0.
4366 d(kte)=v(kte)
4368 ! CALL tridiag(kte,a,b,c,d)
4369 CALL tridiag2(kte,a,b,c,d,x)
4370 ! CALL tridiag3(kte,a,b,c,d,x)
4372 DO k=kts,kte
4373 ! dv(k)=(d(k-kts+1)-v(k))/delt
4374 dv(k)=(x(k)-v(k))/delt
4375 ENDDO
4377 !!============================================
4378 !! thl tendency
4379 !!============================================
4380 k=kts
4382 ! a(k)=0.
4383 ! b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1)
4384 ! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1)
4385 ! d(k)=thl(k) + dtz(k)*flt + tcd(k)*delt &
4386 ! & -dtz(k)*s_awthl(kts+1) + diss_heat(k)*delt + &
4387 ! & sub_thl(k)*delt + det_thl(k)*delt
4388 !
4389 ! DO k=kts+1,kte-1
4390 ! a(k)= -dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k)
4391 ! b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))
4392 ! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1)
4393 ! d(k)=thl(k) + tcd(k)*delt + dtz(k)*(s_awthl(k)-s_awthl(k+1)) &
4394 ! & + diss_heat(k)*delt + &
4395 ! & sub_thl(k)*delt + det_thl(k)*delt
4396 ! ENDDO
4398 !rho-weighted: rhosfc*X*rhoinv(k)
4399 a(k)= -dtz(k)*khdz(k)*rhoinv(k)
4400 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)
4401 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)
4402 d(k)=thl(k) + dtz(k)*rhosfc*flt*rhoinv(k) + tcd(k)*delt &
4403 & - dtz(k)*rhoinv(k)*s_awthl(k+1) -dtz(k)*rhoinv(k)*sd_awthl(k+1) + &
4404 & diss_heat(k)*delt + sub_thl(k)*delt + det_thl(k)*delt
4406 DO k=kts+1,kte-1
4407 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)
4408 b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + &
4409 & 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))
4410 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)
4411 d(k)=thl(k) + tcd(k)*delt + &
4412 & dtz(k)*rhoinv(k)*(s_awthl(k)-s_awthl(k+1)) + dtz(k)*rhoinv(k)*(sd_awthl(k)-sd_awthl(k+1)) + &
4413 & diss_heat(k)*delt + &
4414 & sub_thl(k)*delt + det_thl(k)*delt
4415 ENDDO
4417 !! no flux at the top
4418 ! a(kte)=-1.
4419 ! b(kte)=1.
4420 ! c(kte)=0.
4421 ! d(kte)=0.
4423 !! specified gradient at the top
4424 !assume gradthl_top=gradth_top
4425 ! a(kte)=-1.
4426 ! b(kte)=1.
4427 ! c(kte)=0.
4428 ! d(kte)=gradth_top*dztop
4430 !! prescribed value
4431 a(kte)=0.
4432 b(kte)=1.
4433 c(kte)=0.
4434 d(kte)=thl(kte)
4436 ! CALL tridiag(kte,a,b,c,d)
4437 CALL tridiag2(kte,a,b,c,d,x)
4438 ! CALL tridiag3(kte,a,b,c,d,x)
4440 DO k=kts,kte
4441 !thl(k)=d(k-kts+1)
4442 thl(k)=x(k)
4443 ENDDO
4445 IF (bl_mynn_mixqt > 0) THEN
4446 !============================================
4447 ! MIX total water (sqw = sqc + sqv + sqi)
4448 ! NOTE: no total water tendency is output; instead, we must calculate
4449 ! the saturation specific humidity and then
4450 ! subtract out the moisture excess (sqc & sqi)
4451 !============================================
4453 k=kts
4455 ! a(k)=0.
4456 ! b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1)
4457 ! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1)
4458 ! !rhs= qcd(k) !+ (gfluxp - gfluxm)/dz(k)&
4459 ! d(k)=sqw(k) + dtz(k)*flq + qcd(k)*delt - dtz(k)*s_awqt(k+1)
4460 !
4461 ! DO k=kts+1,kte-1
4462 ! a(k)= -dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k)
4463 ! b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))
4464 ! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1)
4465 ! d(k)=sqw(k) + qcd(k)*delt + dtz(k)*(s_awqt(k)-s_awqt(k+1))
4466 ! ENDDO
4468 !rho-weighted:
4469 a(k)= -dtz(k)*khdz(k)*rhoinv(k)
4470 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)
4471 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)
4472 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)
4474 DO k=kts+1,kte-1
4475 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)
4476 b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + &
4477 & 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))
4478 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)
4479 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))
4480 ENDDO
4482 !! no flux at the top
4483 ! a(kte)=-1.
4484 ! b(kte)=1.
4485 ! c(kte)=0.
4486 ! d(kte)=0.
4487 !! specified gradient at the top
4488 !assume gradqw_top=gradqv_top
4489 ! a(kte)=-1.
4490 ! b(kte)=1.
4491 ! c(kte)=0.
4492 ! d(kte)=gradqv_top*dztop
4493 !! prescribed value
4494 a(kte)=0.
4495 b(kte)=1.
4496 c(kte)=0.
4497 d(kte)=sqw(kte)
4499 ! CALL tridiag(kte,a,b,c,d)
4500 CALL tridiag2(kte,a,b,c,d,sqw2)
4501 ! CALL tridiag3(kte,a,b,c,d,sqw2)
4503 ! DO k=kts,kte
4504 ! sqw2(k)=d(k-kts+1)
4505 ! ENDDO
4506 ELSE
4507 sqw2=sqw
4508 ENDIF
4510 IF (bl_mynn_mixqt == 0) THEN
4511 !============================================
4512 ! cloud water ( sqc ). If mixing total water (bl_mynn_mixqt > 0),
4513 ! then sqc will be backed out of saturation check (below).
4514 !============================================
4515 IF (bl_mynn_cloudmix > 0 .AND. FLAG_QC) THEN
4517 k=kts
4519 ! a(k)=0.
4520 ! b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1)
4521 ! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1)
4522 ! d(k)=sqc(k) + dtz(k)*flqc + qcd(k)*delt - &
4523 ! dtz(k)*s_awqc(k+1) + det_sqc(k)*delt
4524 !
4525 ! DO k=kts+1,kte-1
4526 ! a(k)= -dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k)
4527 ! b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))
4528 ! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1)
4529 ! d(k)=sqc(k) + qcd(k)*delt + dtz(k)*(s_awqc(k)-s_awqc(k+1)) + &
4530 ! det_sqc(k)*delt
4531 ! ENDDO
4533 !rho-weighted:
4534 a(k)= -dtz(k)*khdz(k)*rhoinv(k)
4535 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)
4536 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)
4537 d(k)=sqc(k) + dtz(k)*rhosfc*flqc*rhoinv(k) + qcd(k)*delt &
4538 & - dtz(k)*rhoinv(k)*s_awqc(k+1) - dtz(k)*rhoinv(k)*sd_awqc(k+1) + &
4539 & det_sqc(k)*delt
4541 DO k=kts+1,kte-1
4542 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)
4543 b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + &
4544 & 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))
4545 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)
4546 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)) + &
4547 & det_sqc(k)*delt
4548 ENDDO
4550 ! prescribed value
4551 a(kte)=0.
4552 b(kte)=1.
4553 c(kte)=0.
4554 d(kte)=sqc(kte)
4556 ! CALL tridiag(kte,a,b,c,d)
4557 CALL tridiag2(kte,a,b,c,d,sqc2)
4558 ! CALL tridiag3(kte,a,b,c,d,sqc2)
4560 ! DO k=kts,kte
4561 ! sqc2(k)=d(k-kts+1)
4562 ! ENDDO
4563 ELSE
4564 !If not mixing clouds, set "updated" array equal to original array
4565 sqc2=sqc
4566 ENDIF
4567 ENDIF
4569 IF (bl_mynn_mixqt == 0) THEN
4570 !============================================
4571 ! MIX WATER VAPOR ONLY ( sqv ). If mixing total water (bl_mynn_mixqt > 0),
4572 ! then sqv will be backed out of saturation check (below).
4573 !============================================
4575 k=kts
4577 ! a(k)=0.
4578 ! b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1)
4579 ! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1)
4580 ! d(k)=sqv(k) + dtz(k)*flqv + qcd(k)*delt - dtz(k)*s_awqv(k+1) + &
4581 ! & sub_sqv(k)*delt + det_sqv(k)*delt
4582 !
4583 ! DO k=kts+1,kte-1
4584 ! a(k)= -dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k)
4585 ! b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))
4586 ! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1)
4587 ! d(k)=sqv(k) + qcd(k)*delt + dtz(k)*(s_awqv(k)-s_awqv(k+1)) + &
4588 ! & sub_sqv(k)*delt + det_sqv(k)*delt
4589 ! ENDDO
4591 !limit unreasonably large negative fluxes:
4592 qvflux = flqv
4593 if (qvflux < 0.0) then
4594 !do not allow specified surface flux to reduce qv below 1e-8 kg/kg
4595 qvflux = max(qvflux, (min(0.9*sqv(kts) - 1e-8, 0.0)/dtz(kts)))
4596 endif
4598 !rho-weighted: rhosfc*X*rhoinv(k)
4599 a(k)= -dtz(k)*khdz(k)*rhoinv(k)
4600 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)
4601 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)
4602 d(k)=sqv(k) + dtz(k)*rhosfc*qvflux*rhoinv(k) + qcd(k)*delt &
4603 & - dtz(k)*rhoinv(k)*s_awqv(k+1) - dtz(k)*rhoinv(k)*sd_awqv(k+1) + &
4604 & sub_sqv(k)*delt + det_sqv(k)*delt
4606 DO k=kts+1,kte-1
4607 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)
4608 b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + &
4609 & 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))
4610 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)
4611 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)) + &
4612 & sub_sqv(k)*delt + det_sqv(k)*delt
4613 ENDDO
4615 ! no flux at the top
4616 ! a(kte)=-1.
4617 ! b(kte)=1.
4618 ! c(kte)=0.
4619 ! d(kte)=0.
4621 ! specified gradient at the top
4622 ! assume gradqw_top=gradqv_top
4623 ! a(kte)=-1.
4624 ! b(kte)=1.
4625 ! c(kte)=0.
4626 ! d(kte)=gradqv_top*dztop
4628 ! prescribed value
4629 a(kte)=0.
4630 b(kte)=1.
4631 c(kte)=0.
4632 d(kte)=sqv(kte)
4634 ! CALL tridiag(kte,a,b,c,d)
4635 CALL tridiag2(kte,a,b,c,d,sqv2)
4636 ! CALL tridiag3(kte,a,b,c,d,sqv2)
4638 ! DO k=kts,kte
4639 ! sqv2(k)=d(k-kts+1)
4640 ! ENDDO
4641 ELSE
4642 sqv2=sqv
4643 ENDIF
4645 !============================================
4646 ! MIX CLOUD ICE ( sqi )
4647 !============================================
4648 IF (bl_mynn_cloudmix > 0 .AND. FLAG_QI) THEN
4650 k=kts
4652 ! a(k)=0.
4653 ! b(k)=1.+dtz(k)*dfh(k+1)
4654 ! c(k)= -dtz(k)*dfh(k+1)
4655 ! d(k)=sqi(k) !+ qcd(k)*delt !should we have qcd for ice?
4656 !
4657 ! DO k=kts+1,kte-1
4658 ! a(k)= -dtz(k)*dfh(k)
4659 ! b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1))
4660 ! c(k)= -dtz(k)*dfh(k+1)
4661 ! d(k)=sqi(k) !+ qcd(k)*delt
4662 ! ENDDO
4664 !rho-weighted:
4665 a(k)= -dtz(k)*khdz(k)*rhoinv(k)
4666 b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k)
4667 c(k)= -dtz(k)*khdz(k+1)*rhoinv(k)
4668 d(k)=sqi(k)
4670 DO k=kts+1,kte-1
4671 a(k)= -dtz(k)*khdz(k)*rhoinv(k)
4672 b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k)
4673 c(k)= -dtz(k)*khdz(k+1)*rhoinv(k)
4674 d(k)=sqi(k)
4675 ENDDO
4677 !! no flux at the top
4678 ! a(kte)=-1.
4679 ! b(kte)=1.
4680 ! c(kte)=0.
4681 ! d(kte)=0.
4683 !! specified gradient at the top
4684 !assume gradqw_top=gradqv_top
4685 ! a(kte)=-1.
4686 ! b(kte)=1.
4687 ! c(kte)=0.
4688 ! d(kte)=gradqv_top*dztop
4690 !! prescribed value
4691 a(kte)=0.
4692 b(kte)=1.
4693 c(kte)=0.
4694 d(kte)=sqi(kte)
4696 ! CALL tridiag(kte,a,b,c,d)
4697 CALL tridiag2(kte,a,b,c,d,sqi2)
4698 ! CALL tridiag3(kte,a,b,c,d,sqi2)
4700 ! DO k=kts,kte
4701 ! sqi2(k)=d(k-kts+1)
4702 ! ENDDO
4703 ELSE
4704 sqi2=sqi
4705 ENDIF
4707 !!============================================
4708 !! cloud ice number concentration (qni)
4709 !!============================================
4710 IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNI .AND. &
4711 bl_mynn_mixscalars > 0) THEN
4713 k=kts
4715 a(k)= -dtz(k)*khdz(k)*rhoinv(k)
4716 b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc
4717 c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc
4718 d(k)=qni(k) - dtz(k)*rhoinv(k)*s_awqni(k+1)*nonloc
4720 DO k=kts+1,kte-1
4721 a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*nonloc
4722 b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + &
4723 & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*nonloc
4724 c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc
4725 d(k)=qni(k) + dtz(k)*rhoinv(k)*(s_awqni(k)-s_awqni(k+1))*nonloc
4726 ENDDO
4728 !! prescribed value
4729 a(kte)=0.
4730 b(kte)=1.
4731 c(kte)=0.
4732 d(kte)=qni(kte)
4734 ! CALL tridiag(kte,a,b,c,d)
4735 CALL tridiag2(kte,a,b,c,d,x)
4736 ! CALL tridiag3(kte,a,b,c,d,x)
4738 DO k=kts,kte
4739 !qni2(k)=d(k-kts+1)
4740 qni2(k)=x(k)
4741 ENDDO
4743 ELSE
4744 qni2=qni
4745 ENDIF
4747 !!============================================
4748 !! cloud water number concentration (qnc)
4749 !! include non-local transport
4750 !!============================================
4751 IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNC .AND. &
4752 bl_mynn_mixscalars > 0) THEN
4754 k=kts
4756 a(k)= -dtz(k)*khdz(k)*rhoinv(k)
4757 b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc
4758 c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc
4759 d(k)=qnc(k) - dtz(k)*rhoinv(k)*s_awqnc(k+1)*nonloc
4761 DO k=kts+1,kte-1
4762 a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*nonloc
4763 b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + &
4764 & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*nonloc
4765 c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc
4766 d(k)=qnc(k) + dtz(k)*rhoinv(k)*(s_awqnc(k)-s_awqnc(k+1))*nonloc
4767 ENDDO
4769 !! prescribed value
4770 a(kte)=0.
4771 b(kte)=1.
4772 c(kte)=0.
4773 d(kte)=qnc(kte)
4775 ! CALL tridiag(kte,a,b,c,d)
4776 CALL tridiag2(kte,a,b,c,d,x)
4777 ! CALL tridiag3(kte,a,b,c,d,x)
4779 DO k=kts,kte
4780 !qnc2(k)=d(k-kts+1)
4781 qnc2(k)=x(k)
4782 ENDDO
4784 ELSE
4785 qnc2=qnc
4786 ENDIF
4788 !============================================
4789 ! Water-friendly aerosols ( qnwfa ).
4790 !============================================
4791 IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNWFA .AND. &
4792 bl_mynn_mixscalars > 0) THEN
4794 k=kts
4796 a(k)= -dtz(k)*khdz(k)*rhoinv(k)
4797 b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) - &
4798 & 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc
4799 c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc
4800 d(k)=qnwfa(k) - dtz(k)*rhoinv(k)*s_awqnwfa(k+1)*nonloc
4802 DO k=kts+1,kte-1
4803 a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*nonloc
4804 b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) + &
4805 & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*nonloc
4806 c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc
4807 d(k)=qnwfa(k) + dtz(k)*rhoinv(k)*(s_awqnwfa(k)-s_awqnwfa(k+1))*nonloc
4808 ENDDO
4810 ! prescribed value
4811 a(kte)=0.
4812 b(kte)=1.
4813 c(kte)=0.
4814 d(kte)=qnwfa(kte)
4816 ! CALL tridiag(kte,a,b,c,d)
4817 CALL tridiag2(kte,a,b,c,d,x)
4818 ! CALL tridiag3(kte,a,b,c,d,x)
4820 DO k=kts,kte
4821 !qnwfa2(k)=d(k)
4822 qnwfa2(k)=x(k)
4823 ENDDO
4825 ELSE
4826 !If not mixing aerosols, set "updated" array equal to original array
4827 qnwfa2=qnwfa
4828 ENDIF
4830 !============================================
4831 ! Ice-friendly aerosols ( qnifa ).
4832 !============================================
4833 IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNIFA .AND. &
4834 bl_mynn_mixscalars > 0) THEN
4836 k=kts
4838 a(k)= -dtz(k)*khdz(k)*rhoinv(k)
4839 b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) - &
4840 & 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc
4841 c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc
4842 d(k)=qnifa(k) - dtz(k)*rhoinv(k)*s_awqnifa(k+1)*nonloc
4844 DO k=kts+1,kte-1
4845 a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*nonloc
4846 b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) + &
4847 & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*nonloc
4848 c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc
4849 d(k)=qnifa(k) + dtz(k)*rhoinv(k)*(s_awqnifa(k)-s_awqnifa(k+1))*nonloc
4850 ENDDO
4852 ! prescribed value
4853 a(kte)=0.
4854 b(kte)=1.
4855 c(kte)=0.
4856 d(kte)=qnifa(kte)
4858 ! CALL tridiag(kte,a,b,c,d)
4859 CALL tridiag2(kte,a,b,c,d,x)
4860 ! CALL tridiag3(kte,a,b,c,d,x)
4862 DO k=kts,kte
4863 !qnifa2(k)=d(k-kts+1)
4864 qnifa2(k)=x(k)
4865 ENDDO
4867 ELSE
4868 !If not mixing aerosols, set "updated" array equal to original array
4869 qnifa2=qnifa
4870 ENDIF
4872 !============================================
4873 ! Black-carbon aerosols ( qnbca ).
4874 !============================================
4875 IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNBCA .AND. &
4876 bl_mynn_mixscalars > 0) THEN
4878 k=kts
4880 a(k)= -dtz(k)*khdz(k)*rhoinv(k)
4881 b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) - &
4882 & 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc
4883 c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc
4884 d(k)=qnbca(k) - dtz(k)*rhoinv(k)*s_awqnbca(k+1)*nonloc
4886 DO k=kts+1,kte-1
4887 a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*nonloc
4888 b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) + &
4889 & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*nonloc
4890 c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc
4891 d(k)=qnbca(k) + dtz(k)*rhoinv(k)*(s_awqnbca(k)-s_awqnbca(k+1))*nonloc
4892 ENDDO
4894 ! prescribed value
4895 a(kte)=0.
4896 b(kte)=1.
4897 c(kte)=0.
4898 d(kte)=qnbca(kte)
4900 ! CALL tridiag(kte,a,b,c,d)
4901 ! CALL tridiag2(kte,a,b,c,d,x)
4902 CALL tridiag3(kte,a,b,c,d,x)
4904 DO k=kts,kte
4905 !qnbca2(k)=d(k-kts+1)
4906 qnbca2(k)=x(k)
4907 ENDDO
4909 ELSE
4910 !If not mixing aerosols, set "updated" array equal to original array
4911 qnbca2=qnbca
4912 ENDIF
4914 !============================================
4915 ! Ozone - local mixing only
4916 !============================================
4918 k=kts
4920 !rho-weighted:
4921 a(k)= -dtz(k)*khdz(k)*rhoinv(k)
4922 b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k)
4923 c(k)= -dtz(k)*khdz(k+1)*rhoinv(k)
4924 d(k)=ozone(k)
4926 DO k=kts+1,kte-1
4927 a(k)= -dtz(k)*khdz(k)*rhoinv(k)
4928 b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k)
4929 c(k)= -dtz(k)*khdz(k+1)*rhoinv(k)
4930 d(k)=ozone(k)
4931 ENDDO
4933 ! prescribed value
4934 a(kte)=0.
4935 b(kte)=1.
4936 c(kte)=0.
4937 d(kte)=ozone(kte)
4939 ! CALL tridiag(kte,a,b,c,d)
4940 CALL tridiag2(kte,a,b,c,d,x)
4941 ! CALL tridiag3(kte,a,b,c,d,x)
4943 DO k=kts,kte
4944 !ozone2(k)=d(k-kts+1)
4945 dozone(k)=(x(k)-ozone(k))/delt
4946 ENDDO
4948 !!============================================
4949 !! Compute tendencies and convert to mixing ratios for WRF.
4950 !! Note that the momentum tendencies are calculated above.
4951 !!============================================
4953 IF (bl_mynn_mixqt > 0) THEN
4954 DO k=kts,kte
4955 !compute updated theta using updated thl and old condensate
4956 th_new = thl(k) + xlvcp/exner(k)*sqc(k) &
4957 & + xlscp/exner(k)*sqi(k)
4959 t = th_new*exner(k)
4960 qsat = qsat_blend(t,p(k))
4961 !SATURATED VAPOR PRESSURE
4962 !esat=esat_blend(t)
4963 !SATURATED SPECIFIC HUMIDITY
4964 !qsl=ep_2*esat/(p(k)-ep_3*esat)
4965 !qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat))
4967 IF (sqc(k) > 0.0 .or. sqi(k) > 0.0) THEN !initially saturated
4968 sqv2(k) = MIN(sqw2(k),qsat)
4969 portion_qc = sqc(k)/(sqc(k) + sqi(k))
4970 portion_qi = sqi(k)/(sqc(k) + sqi(k))
4971 condensate = MAX(sqw2(k) - qsat, 0.0)
4972 sqc2(k) = condensate*portion_qc
4973 sqi2(k) = condensate*portion_qi
4974 ELSE ! initially unsaturated -----
4975 sqv2(k) = sqw2(k) ! let microphys decide what to do
4976 sqi2(k) = 0.0 ! if sqw2 > qsat
4977 sqc2(k) = 0.0
4978 ENDIF
4979 !dqv(k) = (sqv2(k) - sqv(k))/delt
4980 !dqc(k) = (sqc2(k) - sqc(k))/delt
4981 !dqi(k) = (sqi2(k) - sqi(k))/delt
4982 ENDDO
4983 ENDIF
4986 !=====================
4987 ! WATER VAPOR TENDENCY
4988 !=====================
4989 DO k=kts,kte
4990 Dqv(k)=(sqv2(k)/(1.-sqv2(k)) - qv(k))/delt
4991 !if (sqv2(k) < 0.0)print*,"neg qv:",sqv2(k),k
4992 ENDDO
4994 IF (bl_mynn_cloudmix > 0) THEN
4995 !=====================
4996 ! CLOUD WATER TENDENCY
4997 !=====================
4998 !print*,"FLAG_QC:",FLAG_QC
4999 IF (FLAG_QC) THEN
5000 DO k=kts,kte
5001 Dqc(k)=(sqc2(k)/(1.-sqv2(k)) - qc(k))/delt
5002 !if (sqc2(k) < 0.0)print*,"neg qc:",sqc2(k),k
5003 ENDDO
5004 ELSE
5005 DO k=kts,kte
5006 Dqc(k) = 0.
5007 ENDDO
5008 ENDIF
5010 !===================
5011 ! CLOUD WATER NUM CONC TENDENCY
5012 !===================
5013 IF (FLAG_QNC .AND. bl_mynn_mixscalars > 0) THEN
5014 DO k=kts,kte
5015 Dqnc(k) = (qnc2(k)-qnc(k))/delt
5016 !IF(Dqnc(k)*delt + qnc(k) < 0.)Dqnc(k)=-qnc(k)/delt
5017 ENDDO
5018 ELSE
5019 DO k=kts,kte
5020 Dqnc(k) = 0.
5021 ENDDO
5022 ENDIF
5024 !===================
5025 ! CLOUD ICE TENDENCY
5026 !===================
5027 IF (FLAG_QI) THEN
5028 DO k=kts,kte
5029 Dqi(k)=(sqi2(k)/(1.-sqv2(k)) - qi(k))/delt
5030 !if (sqi2(k) < 0.0)print*,"neg qi:",sqi2(k),k
5031 ENDDO
5032 ELSE
5033 DO k=kts,kte
5034 Dqi(k) = 0.
5035 ENDDO
5036 ENDIF
5038 !===================
5039 ! CLOUD ICE NUM CONC TENDENCY
5040 !===================
5041 IF (FLAG_QNI .AND. bl_mynn_mixscalars > 0) THEN
5042 DO k=kts,kte
5043 Dqni(k)=(qni2(k)-qni(k))/delt
5044 !IF(Dqni(k)*delt + qni(k) < 0.)Dqni(k)=-qni(k)/delt
5045 ENDDO
5046 ELSE
5047 DO k=kts,kte
5048 Dqni(k)=0.
5049 ENDDO
5050 ENDIF
5051 ELSE !-MIX CLOUD SPECIES?
5052 !CLOUDS ARE NOT NIXED (when bl_mynn_cloudmix == 0)
5053 DO k=kts,kte
5054 Dqc(k)=0.
5055 Dqnc(k)=0.
5056 Dqi(k)=0.
5057 Dqni(k)=0.
5058 ENDDO
5059 ENDIF
5061 !ensure non-negative moist species
5062 CALL moisture_check(kte, delt, delp, exner, &
5063 sqv2, sqc2, sqi2, thl, &
5064 dqv, dqc, dqi, dth )
5066 !=====================
5067 ! OZONE TENDENCY CHECK
5068 !=====================
5069 DO k=kts,kte
5070 IF(Dozone(k)*delt + ozone(k) < 0.) THEN
5071 Dozone(k)=-ozone(k)*0.99/delt
5072 ENDIF
5073 ENDDO
5075 !===================
5076 ! THETA TENDENCY
5077 !===================
5078 IF (FLAG_QI) THEN
5079 DO k=kts,kte
5080 Dth(k)=(thl(k) + xlvcp/exner(k)*sqc2(k) &
5081 & + xlscp/exner(k)*sqi2(k) &
5082 & - th(k))/delt
5083 !Use form from Tripoli and Cotton (1981) with their
5084 !suggested min temperature to improve accuracy:
5085 !Dth(k)=(thl(k)*(1.+ xlvcp/MAX(tk(k),TKmin)*sqc(k) &
5086 ! & + xlscp/MAX(tk(k),TKmin)*sqi(k)) &
5087 ! & - th(k))/delt
5088 ENDDO
5089 ELSE
5090 DO k=kts,kte
5091 Dth(k)=(thl(k)+xlvcp/exner(k)*sqc2(k) - th(k))/delt
5092 !Use form from Tripoli and Cotton (1981) with their
5093 !suggested min temperature to improve accuracy.
5094 !Dth(k)=(thl(k)*(1.+ xlvcp/MAX(tk(k),TKmin)*sqc(k)) &
5095 !& - th(k))/delt
5096 ENDDO
5097 ENDIF
5099 !===================
5100 ! AEROSOL TENDENCIES
5101 !===================
5102 IF (FLAG_QNWFA .AND. FLAG_QNIFA .AND. &
5103 bl_mynn_mixscalars > 0) THEN
5104 DO k=kts,kte
5105 !=====================
5106 ! WATER-friendly aerosols
5107 !=====================
5108 Dqnwfa(k)=(qnwfa2(k) - qnwfa(k))/delt
5109 !=====================
5110 ! Ice-friendly aerosols
5111 !=====================
5112 Dqnifa(k)=(qnifa2(k) - qnifa(k))/delt
5113 !=====================
5114 ! Black-carbon aerosols
5115 !=====================
5116 Dqnbca(k)=(qnbca2(k) - qnbca(k))/delt
5117 ENDDO
5118 ELSE
5119 DO k=kts,kte
5120 Dqnwfa(k)=0.
5121 Dqnifa(k)=0.
5122 Dqnbca(k)=0.
5123 ENDDO
5124 ENDIF
5126 !ensure non-negative moist species
5127 !note: if called down here, dth needs to be updated, but
5128 ! if called before the theta-tendency calculation, do not compute dth
5129 !CALL moisture_check(kte, delt, delp, exner, &
5130 ! sqv, sqc, sqi, thl, &
5131 ! dqv, dqc, dqi, dth )
5133 if (debug_code) then
5134 problem = .false.
5135 do k=kts,kte
5136 wsp = sqrt(u(k)**2 + v(k)**2)
5137 wsp2 = sqrt((u(k)+du(k)*delt)**2 + (v(k)+du(k)*delt)**2)
5138 th2 = th(k) + Dth(k)*delt
5139 tk2 = th2*exner(k)
5140 if (wsp2 > 200. .or. tk2 > 360. .or. tk2 < 160.) then
5141 problem = .true.
5142 print*,"Outgoing problem at: i=",i," k=",k
5143 print*," incoming wsp=",wsp," outgoing wsp=",wsp2
5144 print*," incoming T=",th(k)*exner(k),"outgoing T:",tk2
5145 print*," du=",du(k)*delt," dv=",dv(k)*delt," dth=",dth(k)*delt
5146 print*," km=",kmdz(k)*dz(k)," kh=",khdz(k)*dz(k)
5147 print*," u*=",ust," wspd=",wspd,"rhosfc=",rhosfc
5148 print*," LH=",flq*rhosfc*1004.," HFX=",flt*rhosfc*1004.
5149 print*," drag term=",ust**2/wspd*dtz(k)*rhosfc/rho(kts)
5150 kproblem = k
5151 endif
5152 enddo
5153 if (problem) then
5154 print*,"==thl:",thl(max(kproblem-3,1):min(kproblem+3,kte))
5155 print*,"===qv:",sqv2(max(kproblem-3,1):min(kproblem+3,kte))
5156 print*,"===qc:",sqc2(max(kproblem-3,1):min(kproblem+3,kte))
5157 print*,"===qi:",sqi2(max(kproblem-3,1):min(kproblem+3,kte))
5158 print*,"====u:",u(max(kproblem-3,1):min(kproblem+3,kte))
5159 print*,"====v:",v(max(kproblem-3,1):min(kproblem+3,kte))
5160 endif
5161 endif
5163 #ifdef HARDCODE_VERTICAL
5164 # undef kts
5165 # undef kte
5166 #endif
5168 END SUBROUTINE mynn_tendencies
5170 ! ==================================================================
5171 SUBROUTINE moisture_check(kte, delt, dp, exner, &
5172 qv, qc, qi, th, &
5173 dqv, dqc, dqi, dth )
5175 ! This subroutine was adopted from the CAM-UW ShCu scheme and
5176 ! adapted for use here.
5177 !
5178 ! If qc < qcmin, qi < qimin, or qv < qvmin happens in any layer,
5179 ! force them to be larger than minimum value by (1) condensating
5180 ! water vapor into liquid or ice, and (2) by transporting water vapor
5181 ! from the very lower layer.
5182 !
5183 ! We then update the final state variables and tendencies associated
5184 ! with this correction. If any condensation happens, update theta too.
5185 ! Note that (qv,qc,qi,th) are the final state variables after
5186 ! applying corresponding input tendencies and corrective tendencies.
5188 implicit none
5189 integer, intent(in) :: kte
5190 real, intent(in) :: delt
5191 real, dimension(kte), intent(in) :: dp, exner
5192 real, dimension(kte), intent(inout) :: qv, qc, qi, th
5193 real, dimension(kte), intent(inout) :: dqv, dqc, dqi, dth
5194 integer k
5195 real :: dqc2, dqi2, dqv2, sum, aa, dum
5196 real, parameter :: qvmin = 1e-20, &
5197 qcmin = 0.0, &
5198 qimin = 0.0
5200 do k = kte, 1, -1 ! From the top to the surface
5201 dqc2 = max(0.0, qcmin-qc(k)) !qc deficit (>=0)
5202 dqi2 = max(0.0, qimin-qi(k)) !qi deficit (>=0)
5204 !fix tendencies
5205 dqc(k) = dqc(k) + dqc2/delt
5206 dqi(k) = dqi(k) + dqi2/delt
5207 dqv(k) = dqv(k) - (dqc2+dqi2)/delt
5208 dth(k) = dth(k) + xlvcp/exner(k)*(dqc2/delt) + &
5209 xlscp/exner(k)*(dqi2/delt)
5210 !update species
5211 qc(k) = qc(k) + dqc2
5212 qi(k) = qi(k) + dqi2
5213 qv(k) = qv(k) - dqc2 - dqi2
5214 th(k) = th(k) + xlvcp/exner(k)*dqc2 + &
5215 xlscp/exner(k)*dqi2
5217 !then fix qv
5218 dqv2 = max(0.0, qvmin-qv(k)) !qv deficit (>=0)
5219 dqv(k) = dqv(k) + dqv2/delt
5220 qv(k) = qv(k) + dqv2
5221 if( k .ne. 1 ) then
5222 qv(k-1) = qv(k-1) - dqv2*dp(k)/dp(k-1)
5223 dqv(k-1) = dqv(k-1) - dqv2*dp(k)/dp(k-1)/delt
5224 endif
5225 qv(k) = max(qv(k),qvmin)
5226 qc(k) = max(qc(k),qcmin)
5227 qi(k) = max(qi(k),qimin)
5228 end do
5229 ! Extra moisture used to satisfy 'qv(1)>=qvmin' is proportionally
5230 ! extracted from all the layers that has 'qv > 2*qvmin'. This fully
5231 ! preserves column moisture.
5232 if( dqv2 .gt. 1.e-20 ) then
5233 sum = 0.0
5234 do k = 1, kte
5235 if( qv(k) .gt. 2.0*qvmin ) sum = sum + qv(k)*dp(k)
5236 enddo
5237 aa = dqv2*dp(1)/max(1.e-20,sum)
5238 if( aa .lt. 0.5 ) then
5239 do k = 1, kte
5240 if( qv(k) .gt. 2.0*qvmin ) then
5241 dum = aa*qv(k)
5242 qv(k) = qv(k) - dum
5243 dqv(k) = dqv(k) - dum/delt
5244 endif
5245 enddo
5246 else
5247 ! For testing purposes only (not yet found in any output):
5248 ! write(*,*) 'Full moisture conservation is impossible'
5249 endif
5250 endif
5252 return
5254 END SUBROUTINE moisture_check
5256 ! ==================================================================
5258 SUBROUTINE mynn_mix_chem(kts,kte,i, &
5259 delt,dz,pblh, &
5260 nchem, kdvel, ndvel, &
5261 chem1, vd1, &
5262 rho, &
5263 flt, tcd, qcd, &
5264 dfh, &
5265 s_aw, s_awchem, &
5266 emis_ant_no, frp, rrfs_sd, &
5267 enh_mix, smoke_dbg )
5269 !-------------------------------------------------------------------
5270 INTEGER, INTENT(in) :: kts,kte,i
5271 REAL, DIMENSION(kts:kte), INTENT(IN) :: dfh,dz,tcd,qcd
5272 REAL, DIMENSION(kts:kte), INTENT(INOUT) :: rho
5273 REAL, INTENT(IN) :: delt,flt,pblh
5274 INTEGER, INTENT(IN) :: nchem, kdvel, ndvel
5275 REAL, DIMENSION( kts:kte+1), INTENT(IN) :: s_aw
5276 REAL, DIMENSION( kts:kte, nchem ), INTENT(INOUT) :: chem1
5277 REAL, DIMENSION( kts:kte+1,nchem), INTENT(IN) :: s_awchem
5278 REAL, DIMENSION( ndvel ), INTENT(IN) :: vd1
5279 REAL, INTENT(IN) :: emis_ant_no,frp
5280 LOGICAL, INTENT(IN) :: rrfs_sd,enh_mix,smoke_dbg
5281 !local vars
5283 REAL, DIMENSION(kts:kte) :: dtz
5284 REAL, DIMENSION(kts:kte) :: a,b,c,d,x
5285 REAL :: rhs,dztop
5286 REAL :: t,dzk
5287 REAL :: hght
5288 REAL :: khdz_old, khdz_back
5289 INTEGER :: k,kk,kmaxfire ! JLS 12/21/21
5290 INTEGER :: ic ! Chemical array loop index
5292 INTEGER, SAVE :: icall
5294 REAL, DIMENSION(kts:kte) :: rhoinv
5295 REAL, DIMENSION(kts:kte+1) :: rhoz,khdz
5296 REAL, PARAMETER :: NO_threshold = 10.0 ! For anthropogenic sources
5297 REAL, PARAMETER :: frp_threshold = 10.0 ! RAR 02/11/22: I increased the frp threshold to enhance mixing over big fires
5298 REAL, PARAMETER :: pblh_threshold = 100.0
5300 dztop=.5*(dz(kte)+dz(kte-1))
5302 DO k=kts,kte
5303 dtz(k)=delt/dz(k)
5304 ENDDO
5306 !Prepare "constants" for diffusion equation.
5307 !khdz = rho*Kh/dz = rho*dfh
5308 rhoz(kts) =rho(kts)
5309 rhoinv(kts)=1./rho(kts)
5310 khdz(kts) =rhoz(kts)*dfh(kts)
5312 DO k=kts+1,kte
5313 rhoz(k) =(rho(k)*dz(k-1) + rho(k-1)*dz(k))/(dz(k-1)+dz(k))
5314 rhoz(k) = MAX(rhoz(k),1E-4)
5315 rhoinv(k)=1./MAX(rho(k),1E-4)
5316 dzk = 0.5 *( dz(k)+dz(k-1) )
5317 khdz(k) = rhoz(k)*dfh(k)
5318 ENDDO
5319 rhoz(kte+1)=rhoz(kte)
5320 khdz(kte+1)=rhoz(kte+1)*dfh(kte)
5322 !stability criteria for mf
5323 DO k=kts+1,kte-1
5324 khdz(k) = MAX(khdz(k), 0.5*s_aw(k))
5325 khdz(k) = MAX(khdz(k), -0.5*(s_aw(k)-s_aw(k+1)))
5326 ENDDO
5328 !Enhanced mixing over fires
5329 IF ( rrfs_sd .and. enh_mix ) THEN
5330 DO k=kts+1,kte-1
5331 khdz_old = khdz(k)
5332 khdz_back = pblh * 0.15 / dz(k)
5333 !Modify based on anthropogenic emissions of NO and FRP
5334 IF ( pblh < pblh_threshold ) THEN
5335 IF ( emis_ant_no > NO_threshold ) THEN
5336 khdz(k) = MAX(1.1*khdz(k),sqrt((emis_ant_no / NO_threshold)) / dz(k) * rhoz(k)) ! JLS 12/21/21
5337 ! khdz(k) = MAX(khdz(k),khdz_back)
5338 ENDIF
5339 IF ( frp > frp_threshold ) THEN
5340 kmaxfire = ceiling(log(frp))
5341 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
5342 ! khdz(k) = MAX(khdz(k),khdz_back)
5343 ENDIF
5344 ENDIF
5345 ENDDO
5346 ENDIF
5348 !============================================
5349 ! Patterned after mixing of water vapor in mynn_tendencies.
5350 !============================================
5352 DO ic = 1,nchem
5353 k=kts
5355 a(k)= -dtz(k)*khdz(k)*rhoinv(k)
5356 b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)
5357 c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)
5358 d(k)=chem1(k,ic) & !dtz(k)*flt !neglecting surface sources
5359 & - dtz(k)*vd1(ic)*chem1(k,ic) &
5360 & - dtz(k)*rhoinv(k)*s_awchem(k+1,ic)
5362 DO k=kts+1,kte-1
5363 a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)
5364 b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + &
5365 & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))
5366 c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)
5367 d(k)=chem1(k,ic) + dtz(k)*rhoinv(k)*(s_awchem(k,ic)-s_awchem(k+1,ic))
5368 ENDDO
5370 ! prescribed value at top
5371 a(kte)=0.
5372 b(kte)=1.
5373 c(kte)=0.
5374 d(kte)=chem1(kte,ic)
5376 CALL tridiag3(kte,a,b,c,d,x)
5378 DO k=kts,kte
5379 chem1(k,ic)=x(k)
5380 ENDDO
5381 ENDDO
5383 END SUBROUTINE mynn_mix_chem
5385 ! ==================================================================
5386 !>\ingroup gsd_mynn_edmf
5387 SUBROUTINE retrieve_exchange_coeffs(kts,kte,&
5388 &dfm,dfh,dz,K_m,K_h)
5390 !-------------------------------------------------------------------
5392 INTEGER , INTENT(in) :: kts,kte
5394 REAL, DIMENSION(KtS:KtE), INTENT(in) :: dz,dfm,dfh
5396 REAL, DIMENSION(KtS:KtE), INTENT(out) :: K_m, K_h
5399 INTEGER :: k
5400 REAL :: dzk
5402 K_m(kts)=0.
5403 K_h(kts)=0.
5405 DO k=kts+1,kte
5406 dzk = 0.5 *( dz(k)+dz(k-1) )
5407 K_m(k)=dfm(k)*dzk
5408 K_h(k)=dfh(k)*dzk
5409 ENDDO
5411 END SUBROUTINE retrieve_exchange_coeffs
5413 ! ==================================================================
5414 !>\ingroup gsd_mynn_edmf
5415 SUBROUTINE tridiag(n,a,b,c,d)
5417 !! to solve system of linear eqs on tridiagonal matrix n times n
5418 !! after Peaceman and Rachford, 1955
5419 !! a,b,c,d - are vectors of order n
5420 !! a,b,c - are coefficients on the LHS
5421 !! d - is initially RHS on the output becomes a solution vector
5423 !-------------------------------------------------------------------
5425 INTEGER, INTENT(in):: n
5426 REAL, DIMENSION(n), INTENT(in) :: a,b
5427 REAL, DIMENSION(n), INTENT(inout) :: c,d
5429 INTEGER :: i
5430 REAL :: p
5431 REAL, DIMENSION(n) :: q
5433 c(n)=0.
5434 q(1)=-c(1)/b(1)
5435 d(1)=d(1)/b(1)
5437 DO i=2,n
5438 p=1./(b(i)+a(i)*q(i-1))
5439 q(i)=-c(i)*p
5440 d(i)=(d(i)-a(i)*d(i-1))*p
5441 ENDDO
5443 DO i=n-1,1,-1
5444 d(i)=d(i)+q(i)*d(i+1)
5445 ENDDO
5447 END SUBROUTINE tridiag
5449 ! ==================================================================
5450 !>\ingroup gsd_mynn_edmf
5451 subroutine tridiag2(n,a,b,c,d,x)
5452 implicit none
5453 ! a - sub-diagonal (means it is the diagonal below the main diagonal)
5454 ! b - the main diagonal
5455 ! c - sup-diagonal (means it is the diagonal above the main diagonal)
5456 ! d - right part
5457 ! x - the answer
5458 ! n - number of unknowns (levels)
5460 integer,intent(in) :: n
5461 real, dimension(n),intent(in) :: a,b,c,d
5462 real ,dimension(n),intent(out) :: x
5463 real ,dimension(n) :: cp,dp
5464 real :: m
5465 integer :: i
5467 ! initialize c-prime and d-prime
5468 cp(1) = c(1)/b(1)
5469 dp(1) = d(1)/b(1)
5470 ! solve for vectors c-prime and d-prime
5471 do i = 2,n
5472 m = b(i)-cp(i-1)*a(i)
5473 cp(i) = c(i)/m
5474 dp(i) = (d(i)-dp(i-1)*a(i))/m
5475 enddo
5476 ! initialize x
5477 x(n) = dp(n)
5478 ! solve for x from the vectors c-prime and d-prime
5479 do i = n-1, 1, -1
5480 x(i) = dp(i)-cp(i)*x(i+1)
5481 end do
5483 end subroutine tridiag2
5484 ! ==================================================================
5485 !>\ingroup gsd_mynn_edmf
5486 subroutine tridiag3(kte,a,b,c,d,x)
5488 !ccccccccccccccccccccccccccccccc
5489 ! Aim: Inversion and resolution of a tridiagonal matrix
5490 ! A X = D
5491 ! Input:
5492 ! a(*) lower diagonal (Ai,i-1)
5493 ! b(*) principal diagonal (Ai,i)
5494 ! c(*) upper diagonal (Ai,i+1)
5495 ! d
5496 ! Output
5497 ! x results
5498 !ccccccccccccccccccccccccccccccc
5500 implicit none
5501 integer,intent(in) :: kte
5502 integer, parameter :: kts=1
5503 real, dimension(kte) :: a,b,c,d
5504 real ,dimension(kte),intent(out) :: x
5505 integer :: in
5507 ! integer kms,kme,kts,kte,in
5508 ! real a(kms:kme,3),c(kms:kme),x(kms:kme)
5510 do in=kte-1,kts,-1
5511 d(in)=d(in)-c(in)*d(in+1)/b(in+1)
5512 b(in)=b(in)-c(in)*a(in+1)/b(in+1)
5513 enddo
5515 do in=kts+1,kte
5516 d(in)=d(in)-a(in)*d(in-1)/b(in-1)
5517 enddo
5519 do in=kts,kte
5520 x(in)=d(in)/b(in)
5521 enddo
5523 return
5524 end subroutine tridiag3
5526 ! ==================================================================
5527 !>\ingroup gsd_mynn_edmf
5528 !! This subroutine calculates hybrid diagnotic boundary-layer height (PBLH).
5529 !!
5530 !! NOTES ON THE PBLH FORMULATION: The 1.5-theta-increase method defines
5531 !!PBL heights as the level at.
5532 !!which the potential temperature first exceeds the minimum potential.
5533 !!temperature within the boundary layer by 1.5 K. When applied to.
5534 !!observed temperatures, this method has been shown to produce PBL-
5535 !!height estimates that are unbiased relative to profiler-based.
5536 !!estimates (Nielsen-Gammon et al. 2008 \cite Nielsen_Gammon_2008).
5537 !! However, their study did not
5538 !!include LLJs. Banta and Pichugina (2008) \cite Pichugina_2008 show that a TKE-based.
5539 !!threshold is a good estimate of the PBL height in LLJs. Therefore,
5540 !!a hybrid definition is implemented that uses both methods, weighting
5541 !!the TKE-method more during stable conditions (PBLH < 400 m).
5542 !!A variable tke threshold (TKEeps) is used since no hard-wired
5543 !!value could be found to work best in all conditions.
5544 !>\section gen_get_pblh GSD get_pblh General Algorithm
5545 !> @{
5546 SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea,kzi)
5548 !---------------------------------------------------------------
5549 ! NOTES ON THE PBLH FORMULATION
5550 !
5551 !The 1.5-theta-increase method defines PBL heights as the level at
5552 !which the potential temperature first exceeds the minimum potential
5553 !temperature within the boundary layer by 1.5 K. When applied to
5554 !observed temperatures, this method has been shown to produce PBL-
5555 !height estimates that are unbiased relative to profiler-based
5556 !estimates (Nielsen-Gammon et al. 2008). However, their study did not
5557 !include LLJs. Banta and Pichugina (2008) show that a TKE-based
5558 !threshold is a good estimate of the PBL height in LLJs. Therefore,
5559 !a hybrid definition is implemented that uses both methods, weighting
5560 !the TKE-method more during stable conditions (PBLH < 400 m).
5561 !A variable tke threshold (TKEeps) is used since no hard-wired
5562 !value could be found to work best in all conditions.
5563 !---------------------------------------------------------------
5565 INTEGER,INTENT(IN) :: KTS,KTE
5567 #ifdef HARDCODE_VERTICAL
5568 # define kts 1
5569 # define kte HARDCODE_VERTICAL
5570 #endif
5572 REAL, INTENT(OUT) :: zi
5573 REAL, INTENT(IN) :: landsea
5574 REAL, DIMENSION(KTS:KTE), INTENT(IN) :: thetav1D, qke1D, dz1D
5575 REAL, DIMENSION(KTS:KTE+1), INTENT(IN) :: zw1D
5576 !LOCAL VARS
5577 REAL :: PBLH_TKE,qtke,qtkem1,wt,maxqke,TKEeps,minthv
5578 REAL :: delt_thv !delta theta-v; dependent on land/sea point
5579 REAL, PARAMETER :: sbl_lim = 200. !upper limit of stable BL height (m).
5580 REAL, PARAMETER :: sbl_damp = 400. !transition length for blending (m).
5581 INTEGER :: I,J,K,kthv,ktke,kzi
5583 !Initialize KPBL (kzi)
5584 kzi = 2
5586 !> - FIND MIN THETAV IN THE LOWEST 200 M AGL
5587 k = kts+1
5588 kthv = 1
5589 minthv = 9.E9
5590 DO WHILE (zw1D(k) .LE. 200.)
5591 !DO k=kts+1,kte-1
5592 IF (minthv > thetav1D(k)) then
5593 minthv = thetav1D(k)
5594 kthv = k
5595 ENDIF
5596 k = k+1
5597 !IF (zw1D(k) .GT. sbl_lim) exit
5598 ENDDO
5600 !> - FIND THETAV-BASED PBLH (BEST FOR DAYTIME).
5601 zi=0.
5602 k = kthv+1
5603 IF((landsea-1.5).GE.0)THEN
5604 ! WATER
5605 delt_thv = 1.0
5606 ELSE
5607 ! LAND
5608 delt_thv = 1.25
5609 ENDIF
5611 zi=0.
5612 k = kthv+1
5613 ! DO WHILE (zi .EQ. 0.)
5614 DO k=kts+1,kte-1
5615 IF (thetav1D(k) .GE. (minthv + delt_thv))THEN
5616 zi = zw1D(k) - dz1D(k-1)* &
5617 & MIN((thetav1D(k)-(minthv + delt_thv))/ &
5618 & MAX(thetav1D(k)-thetav1D(k-1),1E-6),1.0)
5619 ENDIF
5620 !k = k+1
5621 IF (k .EQ. kte-1) zi = zw1D(kts+1) !EXIT SAFEGUARD
5622 IF (zi .NE. 0.0) exit
5623 ENDDO
5624 !print*,"IN GET_PBLH:",thsfc,zi
5626 !> - FOR STABLE BOUNDARY LAYERS, USE TKE METHOD TO COMPLEMENT THE
5627 !! THETAV-BASED DEFINITION (WHEN THE THETA-V BASED PBLH IS BELOW ~0.5 KM).
5628 !!THE TANH WEIGHTING FUNCTION WILL MAKE THE TKE-BASED DEFINITION NEGLIGIBLE
5629 !!WHEN THE THETA-V-BASED DEFINITION IS ABOVE ~1 KM.
5630 ktke = 1
5631 maxqke = MAX(Qke1D(kts),0.)
5632 !Use 5% of tke max (Kosovic and Curry, 2000; JAS)
5633 !TKEeps = maxtke/20. = maxqke/40.
5634 TKEeps = maxqke/40.
5635 TKEeps = MAX(TKEeps,0.02) !0.025)
5636 PBLH_TKE=0.
5638 k = ktke+1
5639 ! DO WHILE (PBLH_TKE .EQ. 0.)
5640 DO k=kts+1,kte-1
5641 !QKE CAN BE NEGATIVE (IF CKmod == 0)... MAKE TKE NON-NEGATIVE.
5642 qtke =MAX(Qke1D(k)/2.,0.) ! maximum TKE
5643 qtkem1=MAX(Qke1D(k-1)/2.,0.)
5644 IF (qtke .LE. TKEeps) THEN
5645 PBLH_TKE = zw1D(k) - dz1D(k-1)* &
5646 & MIN((TKEeps-qtke)/MAX(qtkem1-qtke, 1E-6), 1.0)
5647 !IN CASE OF NEAR ZERO TKE, SET PBLH = LOWEST LEVEL.
5648 PBLH_TKE = MAX(PBLH_TKE,zw1D(kts+1))
5649 !print *,"PBLH_TKE:",i,PBLH_TKE, Qke1D(k)/2., zw1D(kts+1)
5650 ENDIF
5651 !k = k+1
5652 IF (k .EQ. kte-1) PBLH_TKE = zw1D(kts+1) !EXIT SAFEGUARD
5653 IF (PBLH_TKE .NE. 0.) exit
5654 ENDDO
5656 !> - With TKE advection turned on, the TKE-based PBLH can be very large
5657 !! in grid points with convective precipitation (> 8 km!),
5658 !! so an artificial limit is imposed to not let PBLH_TKE exceed the
5659 !!theta_v-based PBL height +/- 350 m.
5660 !!This has no impact on 98-99% of the domain, but is the simplest patch
5661 !!that adequately addresses these extremely large PBLHs.
5662 PBLH_TKE = MIN(PBLH_TKE,zi+350.)
5663 PBLH_TKE = MAX(PBLH_TKE,MAX(zi-350.,10.))
5665 wt=.5*TANH((zi - sbl_lim)/sbl_damp) + .5
5666 IF (maxqke <= 0.05) THEN
5667 !Cold pool situation - default to theta_v-based def
5668 ELSE
5669 !BLEND THE TWO PBLH TYPES HERE:
5670 zi=PBLH_TKE*(1.-wt) + zi*wt
5671 ENDIF
5673 !Compute KPBL (kzi)
5674 DO k=kts+1,kte-1
5675 IF ( zw1D(k) >= zi) THEN
5676 kzi = k-1
5677 exit
5678 ENDIF
5679 ENDDO
5681 #ifdef HARDCODE_VERTICAL
5682 # undef kts
5683 # undef kte
5684 #endif
5686 END SUBROUTINE GET_PBLH
5687 !> @}
5689 ! ==================================================================
5690 !>\ingroup gsd_mynn_edmf
5691 !! This subroutine is the Dynamic Multi-Plume (DMP) Mass-Flux Scheme.
5692 !!
5693 !! dmp_mf() calculates the nonlocal turbulent transport from the dynamic
5694 !! multiplume mass-flux scheme as well as the shallow-cumulus component of
5695 !! the subgrid clouds. Note that this mass-flux scheme is called when the
5696 !! namelist paramter \p bl_mynn_edmf is set to 1 (recommended).
5697 !!
5698 !! Much thanks to Kay Suslj of NASA-JPL for contributing the original version
5699 !! of this mass-flux scheme. Considerable changes have been made from it's
5700 !! original form. Some additions include:
5701 !! -# scale-aware tapering as dx -> 0
5702 !! -# transport of TKE (extra namelist option)
5703 !! -# Chaboureau-Bechtold cloud fraction & coupling to radiation (when icloud_bl > 0)
5704 !! -# some extra limits for numerical stability
5705 !!
5706 !! This scheme remains under development, so consider it experimental code.
5707 !!
5708 SUBROUTINE DMP_mf( &
5709 & kts,kte,dt,zw,dz,p,rho, &
5710 & momentum_opt, &
5711 & tke_opt, &
5712 & scalar_opt, &
5713 & u,v,w,th,thl,thv,tk, &
5714 & qt,qv,qc,qke, &
5715 & qnc,qni,qnwfa,qnifa,qnbca, &
5716 & exner,vt,vq,sgm, &
5717 & ust,flt,fltv,flq,flqv, &
5718 & pblh,kpbl,dx,landsea,ts, &
5719 ! outputs - updraft properties
5720 & edmf_a,edmf_w, &
5721 & edmf_qt,edmf_thl, &
5722 & edmf_ent,edmf_qc, &
5723 ! outputs - variables needed for solver
5724 & s_aw,s_awthl,s_awqt, &
5725 & s_awqv,s_awqc, &
5726 & s_awu,s_awv,s_awqke, &
5727 & s_awqnc,s_awqni, &
5728 & s_awqnwfa,s_awqnifa, &
5729 & s_awqnbca, &
5730 & sub_thl,sub_sqv, &
5731 & sub_u,sub_v, &
5732 & det_thl,det_sqv,det_sqc, &
5733 & det_u,det_v, &
5734 ! chem/smoke
5735 & nchem,chem1,s_awchem, &
5736 & mix_chem, &
5737 ! in/outputs - subgrid scale clouds
5738 & qc_bl1d,cldfra_bl1d, &
5739 & qc_bl1D_old,cldfra_bl1D_old, &
5740 ! inputs - flags for moist arrays
5741 & F_QC,F_QI, &
5742 & F_QNC,F_QNI, &
5743 & F_QNWFA,F_QNIFA,F_QNBCA, &
5744 & Psig_shcu, &
5745 ! output info
5746 &nup2,ktop,maxmf,ztop, &
5747 ! unputs for stochastic perturbations
5748 &spp_pbl,rstoch_col )
5750 ! inputs:
5751 INTEGER, INTENT(IN) :: KTS,KTE,KPBL,momentum_opt,tke_opt,scalar_opt
5753 #ifdef HARDCODE_VERTICAL
5754 # define kts 1
5755 # define kte HARDCODE_VERTICAL
5756 #endif
5758 ! Stochastic
5759 INTEGER, INTENT(IN) :: spp_pbl
5760 REAL, DIMENSION(KTS:KTE) :: rstoch_col
5762 REAL,DIMENSION(KTS:KTE), INTENT(IN) :: &
5763 u,v,w,th,thl,tk,qt,qv,qc, &
5764 exner,dz,THV,P,rho,qke,qnc,qni,qnwfa,qnifa,qnbca
5765 REAL,DIMENSION(KTS:KTE+1), INTENT(IN) :: zw !height at full-sigma
5766 REAL, INTENT(IN) :: dt,ust,flt,fltv,flq,flqv,pblh, &
5767 dx,psig_shcu,landsea,ts
5768 LOGICAL, OPTIONAL :: f_qc,f_qi,f_qnc,f_qni, &
5769 f_qnwfa,f_qnifa,f_qnbca
5771 ! outputs - updraft properties
5772 REAL,DIMENSION(KTS:KTE), INTENT(OUT) :: edmf_a,edmf_w, &
5773 & edmf_qt,edmf_thl,edmf_ent,edmf_qc
5774 !add one local edmf variable:
5775 REAL,DIMENSION(KTS:KTE) :: edmf_th
5776 ! output
5777 INTEGER, INTENT(OUT) :: nup2,ktop
5778 REAL, INTENT(OUT) :: maxmf,ztop
5779 ! outputs - variables needed for solver - sum ai*rho*wis_awphi
5780 REAL,DIMENSION(KTS:KTE+1) :: s_aw,s_awthl,s_awqt, &
5781 s_awqv,s_awqc,s_awqnc,s_awqni, &
5782 s_awqnwfa,s_awqnifa,s_awqnbca, &
5783 s_awu,s_awv,s_awqke,s_aw2
5785 REAL,DIMENSION(KTS:KTE), INTENT(INOUT) :: qc_bl1d,cldfra_bl1d, &
5786 qc_bl1d_old,cldfra_bl1d_old
5788 INTEGER, PARAMETER :: nup=10, debug_mf=0
5790 !------------- local variables -------------------
5791 ! updraft properties defined on interfaces (k=1 is the top of the
5792 ! first model layer
5793 REAL,DIMENSION(KTS:KTE+1,1:NUP) :: UPW,UPTHL,UPQT,UPQC,UPQV, &
5794 UPA,UPU,UPV,UPTHV,UPQKE,UPQNC, &
5795 UPQNI,UPQNWFA,UPQNIFA,UPQNBCA
5796 ! entrainment variables
5797 REAL,DIMENSION(KTS:KTE,1:NUP) :: ENT,ENTf
5798 INTEGER,DIMENSION(KTS:KTE,1:NUP) :: ENTi
5799 ! internal variables
5800 INTEGER :: K,I,k50
5801 REAL :: fltv2,wstar,qstar,thstar,sigmaW,sigmaQT,sigmaTH,z0, &
5802 pwmin,pwmax,wmin,wmax,wlv,Psig_w,maxw,maxqc,wpbl
5803 REAL :: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,QNCn,QNIn, &
5804 QNWFAn,QNIFAn,QNBCAn, &
5805 Wn2,Wn,EntEXP,EntEXM,EntW,BCOEFF,THVkm1,THVk,Pk,rho_int
5807 ! w parameters
5808 REAL,PARAMETER :: &
5809 &Wa=2./3., &
5810 &Wb=0.002, &
5811 &Wc=1.5
5813 ! Lateral entrainment parameters ( L0=100 and ENT0=0.1) were taken from
5814 ! Suselj et al (2013, jas). Note that Suselj et al (2014,waf) use L0=200 and ENT0=0.2.
5815 REAL,PARAMETER :: &
5816 & L0=100., &
5817 & ENT0=0.1
5819 ! Implement ideas from Neggers (2016, JAMES):
5820 REAL, PARAMETER :: Atot = 0.10 ! Maximum total fractional area of all updrafts
5821 REAL, PARAMETER :: lmax = 1000.! diameter of largest plume
5822 REAL, PARAMETER :: dl = 100. ! diff size of each plume - the differential multiplied by the integrand
5823 REAL, PARAMETER :: dcut = 1.2 ! max diameter of plume to parameterize relative to dx (km)
5824 REAL :: d != -2.3 to -1.7 ;=-1.9 in Neggers paper; power law exponent for number density (N=Cl^d).
5825 ! Note that changing d to -2.0 makes each size plume equally contribute to the total coverage of all plumes.
5826 ! Note that changing d to -1.7 doubles the area coverage of the largest plumes relative to the smallest plumes.
5827 REAL :: cn,c,l,n,an2,hux,maxwidth,wspd_pbl,cloud_base,width_flx
5829 ! chem/smoke
5830 INTEGER, INTENT(IN) :: nchem
5831 REAL,DIMENSION(:, :) :: chem1
5832 REAL,DIMENSION(kts:kte+1, nchem) :: s_awchem
5833 REAL,DIMENSION(nchem) :: chemn
5834 REAL,DIMENSION(KTS:KTE+1,1:NUP, nchem) :: UPCHEM
5835 INTEGER :: ic
5836 REAL,DIMENSION(KTS:KTE+1, nchem) :: edmf_chem
5837 LOGICAL, INTENT(IN) :: mix_chem
5839 !JOE: add declaration of ERF
5840 REAL :: ERF
5842 LOGICAL :: superadiabatic
5844 ! VARIABLES FOR CHABOUREAU-BECHTOLD CLOUD FRACTION
5845 REAL,DIMENSION(KTS:KTE), INTENT(INOUT) :: vt, vq, sgm
5846 REAL :: sigq,xl,rsl,cpm,a,qmq,mf_cf,Aup,Q1,diffqt,qsat_tk,&
5847 Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9,satvp,rhgrid, &
5848 Ac_mf,Ac_strat,qc_mf
5849 REAL, PARAMETER :: cf_thresh = 0.5 ! only overwrite stratus CF less than this value
5851 ! Variables for plume interpolation/saturation check
5852 REAL,DIMENSION(KTS:KTE) :: exneri,dzi
5853 REAL :: THp, QTp, QCp, QCs, esat, qsl
5854 REAL :: csigma,acfac,ac_wsp,ac_cld
5856 !plume overshoot
5857 INTEGER :: overshoot
5858 REAL :: bvf, Frz, dzp
5860 !Flux limiter: not let mass-flux of heat between k=1&2 exceed (fluxportion)*(surface heat flux).
5861 !This limiter makes adjustments to the entire column.
5862 REAL :: adjustment, flx1
5863 REAL, PARAMETER :: fluxportion=0.75 ! set liberally, so has minimal impact. 0.5 starts to have a noticeable impact
5864 ! over land (decrease maxMF by 10-20%), but no impact over water.
5866 !Subsidence
5867 REAL,DIMENSION(KTS:KTE) :: sub_thl,sub_sqv,sub_u,sub_v, & !tendencies due to subsidence
5868 det_thl,det_sqv,det_sqc,det_u,det_v, & !tendencied due to detrainment
5869 envm_a,envm_w,envm_thl,envm_sqv,envm_sqc, &
5870 envm_u,envm_v !environmental variables defined at middle of layer
5871 REAL,DIMENSION(KTS:KTE+1) :: envi_a,envi_w !environmental variables defined at model interface
5872 REAL :: temp,sublim,qc_ent,qv_ent,qt_ent,thl_ent,detrate, &
5873 detrateUV,oow,exc_fac,aratio,detturb,qc_grid,qc_sgs,&
5874 qc_plume,exc_heat,exc_moist,tk_int
5875 REAL, PARAMETER :: Cdet = 1./45.
5876 REAL, PARAMETER :: dzpmax = 300. !limit dz used in detrainment - can be excessing in thick layers
5877 !parameter "Csub" determines the propotion of upward vertical velocity that contributes to
5878 !environmenatal subsidence. Some portion is expected to be compensated by downdrafts instead of
5879 !gentle environmental subsidence. 1.0 assumes all upward vertical velocity in the mass-flux scheme
5880 !is compensated by "gentle" environmental subsidence.
5881 REAL, PARAMETER :: Csub=0.25
5883 !Factor for the pressure gradient effects on momentum transport
5884 REAL, PARAMETER :: pgfac = 0.00 ! Zhang and Wu showed 0.4 is more appropriate for lower troposphere
5885 REAL :: Uk,Ukm1,Vk,Vkm1,dxsa
5887 ! check the inputs
5888 ! print *,'dt',dt
5889 ! print *,'dz',dz
5890 ! print *,'u',u
5891 ! print *,'v',v
5892 ! print *,'thl',thl
5893 ! print *,'qt',qt
5894 ! print *,'ust',ust
5895 ! print *,'flt',flt
5896 ! print *,'flq',flq
5897 ! print *,'pblh',pblh
5899 ! Initialize individual updraft properties
5900 UPW=0.
5901 UPTHL=0.
5902 UPTHV=0.
5903 UPQT=0.
5904 UPA=0.
5905 UPU=0.
5906 UPV=0.
5907 UPQC=0.
5908 UPQV=0.
5909 UPQKE=0.
5910 UPQNC=0.
5911 UPQNI=0.
5912 UPQNWFA=0.
5913 UPQNIFA=0.
5914 UPQNBCA=0.
5915 IF ( mix_chem ) THEN
5916 UPCHEM(KTS:KTE+1,1:NUP,1:nchem)=0.0
5917 ENDIF
5919 ENT=0.001
5920 ! Initialize mean updraft properties
5921 edmf_a =0.
5922 edmf_w =0.
5923 edmf_qt =0.
5924 edmf_thl=0.
5925 edmf_ent=0.
5926 edmf_qc =0.
5927 IF ( mix_chem ) THEN
5928 edmf_chem(kts:kte+1,1:nchem) = 0.0
5929 ENDIF
5931 ! Initialize the variables needed for implicit solver
5932 s_aw=0.
5933 s_awthl=0.
5934 s_awqt=0.
5935 s_awqv=0.
5936 s_awqc=0.
5937 s_awu=0.
5938 s_awv=0.
5939 s_awqke=0.
5940 s_awqnc=0.
5941 s_awqni=0.
5942 s_awqnwfa=0.
5943 s_awqnifa=0.
5944 s_awqnbca=0.
5945 IF ( mix_chem ) THEN
5946 s_awchem(kts:kte+1,1:nchem) = 0.0
5947 ENDIF
5949 ! Initialize explicit tendencies for subsidence & detrainment
5950 sub_thl = 0.
5951 sub_sqv = 0.
5952 sub_u = 0.
5953 sub_v = 0.
5954 det_thl = 0.
5955 det_sqv = 0.
5956 det_sqc = 0.
5957 det_u = 0.
5958 det_v = 0.
5960 ! Taper off MF scheme when significant resolved-scale motions
5961 ! are present This function needs to be asymetric...
5962 k = 1
5963 maxw = 0.0
5964 cloud_base = 9000.0
5965 ! DO WHILE (ZW(k) < pblh + 500.)
5966 DO k=1,kte-1
5967 IF(zw(k) > pblh + 500.) exit
5969 wpbl = w(k)
5970 IF(w(k) < 0.)wpbl = 2.*w(k)
5971 maxw = MAX(maxw,ABS(wpbl))
5973 !Find highest k-level below 50m AGL
5974 IF(ZW(k)<=50.)k50=k
5976 !Search for cloud base
5977 qc_sgs = MAX(qc(k), qc_bl1d(k)*cldfra_bl1d(k))
5978 IF(qc_sgs> 1E-5 .AND. cloud_base == 9000.0)THEN
5979 cloud_base = 0.5*(ZW(k)+ZW(k+1))
5980 ENDIF
5982 !k = k + 1
5983 ENDDO
5984 !print*," maxw before manipulation=", maxw
5985 maxw = MAX(0.,maxw - 1.0) ! do nothing for small w (< 1 m/s), but
5986 Psig_w = MAX(0.0, 1.0 - maxw) ! linearly taper off for w > 1.0 m/s
5987 Psig_w = MIN(Psig_w, Psig_shcu)
5988 !print*," maxw=", maxw," Psig_w=",Psig_w," Psig_shcu=",Psig_shcu
5990 !Completely shut off MF scheme for strong resolved-scale vertical velocities.
5991 fltv2 = fltv
5992 IF(Psig_w == 0.0 .and. fltv > 0.0) fltv2 = -1.*fltv
5994 ! If surface buoyancy is positive we do integration, otherwise no.
5995 ! Also, ensure that it is at least slightly superadiabatic up through 50 m
5996 superadiabatic = .false.
5997 IF((landsea-1.5).GE.0)THEN
5998 hux = -0.001 ! WATER ! dT/dz must be < - 0.1 K per 100 m.
5999 ELSE
6000 hux = -0.005 ! LAND ! dT/dz must be < - 0.5 K per 100 m.
6001 ENDIF
6002 DO k=1,MAX(1,k50-1) !use "-1" because k50 used interface heights (zw).
6003 IF (k == 1) then
6004 IF ((th(k)-ts)/(0.5*dz(k)) < hux) THEN
6005 superadiabatic = .true.
6006 ELSE
6007 superadiabatic = .false.
6008 exit
6009 ENDIF
6010 ELSE
6011 IF ((th(k)-th(k-1))/(0.5*(dz(k)+dz(k-1))) < hux) THEN
6012 superadiabatic = .true.
6013 ELSE
6014 superadiabatic = .false.
6015 exit
6016 ENDIF
6017 ENDIF
6018 ENDDO
6020 ! Determine the numer of updrafts/plumes in the grid column:
6021 ! Some of these criteria may be a little redundant but useful for bullet-proofing.
6022 ! (1) largest plume = 1.0 * dx.
6023 ! (2) Apply a scale-break, assuming no plumes with diameter larger than PBLH can exist.
6024 ! (3) max plume size beneath clouds deck approx = 0.5 * cloud_base.
6025 ! (4) add wspd-dependent limit, when plume model breaks down. (hurricanes)
6026 ! (5) limit to reduce max plume sizes in weakly forced conditions. This is only
6027 ! meant to "soften" the activation of the mass-flux scheme.
6028 ! Criteria (1)
6029 NUP2 = max(1,min(NUP,INT(dx*dcut/dl)))
6030 !Criteria (2)
6031 maxwidth = 1.1*PBLH
6032 ! Criteria (3)
6033 maxwidth = MIN(maxwidth,0.5*cloud_base)
6034 ! Criteria (4)
6035 wspd_pbl=SQRT(MAX(u(kts)**2 + v(kts)**2, 0.01))
6036 !Note: area fraction (acfac) is modified below
6037 ! Criteria (5) - only a function of flt (not fltv)
6038 if ((landsea-1.5).LT.0) then !land
6039 !width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.050)/0.03) + .5),1000.), 0.)
6040 width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.040)/0.03) + .5),1000.), 0.)
6041 else !water
6042 width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.003)/0.01) + .5),1000.), 0.)
6043 endif
6044 maxwidth = MIN(maxwidth,width_flx)
6045 ! Convert maxwidth to number of plumes
6046 NUP2 = MIN(MAX(INT((maxwidth - MOD(maxwidth,100.))/100), 0), NUP2)
6048 !Initialize values for 2d output fields:
6049 ktop = 0
6050 ztop = 0.0
6051 maxmf= 0.0
6053 IF ( fltv2 > 0.002 .AND. NUP2 .GE. 1 .AND. superadiabatic) then
6054 !PRINT*," Conditions met to run mass-flux scheme",fltv2,pblh
6056 ! Find coef C for number size density N
6057 cn = 0.
6058 d=-1.9 !set d to value suggested by Neggers 2015 (JAMES).
6059 !d=-1.9 + .2*tanh((fltv2 - 0.05)/0.15)
6060 do I=1,NUP !NUP2
6061 IF(I > NUP2) exit
6062 l = dl*I ! diameter of plume
6063 cn = cn + l**d * (l*l)/(dx*dx) * dl ! sum fractional area of each plume
6064 enddo
6065 C = Atot/cn !Normalize C according to the defined total fraction (Atot)
6067 ! Make updraft area (UPA) a function of the buoyancy flux
6068 if ((landsea-1.5).LT.0) then !land
6069 !acfac = .5*tanh((fltv2 - 0.03)/0.09) + .5
6070 !acfac = .5*tanh((fltv2 - 0.02)/0.09) + .5
6071 acfac = .5*tanh((fltv2 - 0.02)/0.05) + .5
6072 else !water
6073 acfac = .5*tanh((fltv2 - 0.01)/0.03) + .5
6074 endif
6075 !add a windspeed-dependent adjustment to acfac that tapers off
6076 !the mass-flux scheme linearly above sfc wind speeds of 20 m/s:
6077 ac_wsp = 1.0 - min(max(wspd_pbl - 20.0, 0.0), 10.0)/10.0
6078 !reduce area fraction beneath cloud bases < 1200 m AGL
6079 ac_cld = min(cloud_base/1200., 1.0)
6080 acfac = acfac * min(ac_wsp, ac_cld)
6082 ! Find the portion of the total fraction (Atot) of each plume size:
6083 An2 = 0.
6084 do I=1,NUP !NUP2
6085 IF(I > NUP2) exit
6086 l = dl*I ! diameter of plume
6087 N = C*l**d ! number density of plume n
6088 UPA(1,I) = N*l*l/(dx*dx) * dl ! fractional area of plume n
6090 UPA(1,I) = UPA(1,I)*acfac
6091 An2 = An2 + UPA(1,I) ! total fractional area of all plumes
6092 !print*," plume size=",l,"; area=",UPA(1,I),"; total=",An2
6093 end do
6095 ! set initial conditions for updrafts
6096 z0=50.
6097 pwmin=0.1 ! was 0.5
6098 pwmax=0.4 ! was 3.0
6100 wstar=max(1.E-2,(gtr*fltv2*pblh)**(onethird))
6101 qstar=max(flq,1.0E-5)/wstar
6102 thstar=flt/wstar
6104 IF((landsea-1.5).GE.0)THEN
6105 csigma = 1.34 ! WATER
6106 ELSE
6107 csigma = 1.34 ! LAND
6108 ENDIF
6110 if (env_subs) then
6111 exc_fac = 0.0
6112 else
6113 if ((landsea-1.5).GE.0) then
6114 !water: increase factor to compensate for decreased pwmin/pwmax
6115 exc_fac = 0.58*4.0*min(cloud_base/1000., 1.0)
6116 else
6117 !land: no need to increase factor - already sufficiently large superadiabatic layers
6118 exc_fac = 0.58
6119 endif
6120 endif
6122 !Note: sigmaW is typically about 0.5*wstar
6123 sigmaW =csigma*wstar*(z0/pblh)**(onethird)*(1 - 0.8*z0/pblh)
6124 sigmaQT=csigma*qstar*(z0/pblh)**(onethird)
6125 sigmaTH=csigma*thstar*(z0/pblh)**(onethird)
6127 !Note: Given the pwmin & pwmax set above, these max/mins are
6128 ! rarely exceeded.
6129 wmin=MIN(sigmaW*pwmin,0.1)
6130 wmax=MIN(sigmaW*pwmax,0.5)
6132 !SPECIFY SURFACE UPDRAFT PROPERTIES AT MODEL INTERFACE BETWEEN K = 1 & 2
6133 DO I=1,NUP !NUP2
6134 IF(I > NUP2) exit
6135 wlv=wmin+(wmax-wmin)/NUP2*(i-1)
6137 !SURFACE UPDRAFT VERTICAL VELOCITY
6138 UPW(1,I)=wmin + REAL(i)/REAL(NUP)*(wmax-wmin)
6139 !IF (UPW(1,I) > 0.5*ZW(2)/dt) UPW(1,I) = 0.5*ZW(2)/dt
6141 UPU(1,I)=(U(KTS)*DZ(KTS+1)+U(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))
6142 UPV(1,I)=(V(KTS)*DZ(KTS+1)+V(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))
6143 UPQC(1,I)=0.0
6144 !UPQC(1,I)=(QC(KTS)*DZ(KTS+1)+QC(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))
6146 exc_heat = exc_fac*UPW(1,I)*sigmaTH/sigmaW
6147 UPTHV(1,I)=(THV(KTS)*DZ(KTS+1)+THV(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) &
6148 & + exc_heat
6149 !was UPTHL(1,I)= UPTHV(1,I)/(1.+svp1*UPQT(1,I)) !assume no saturated parcel at surface
6150 UPTHL(1,I)=(THL(KTS)*DZ(KTS+1)+THL(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) &
6151 & + exc_heat
6153 !calculate exc_moist by use of surface fluxes
6154 exc_moist=exc_fac*UPW(1,I)*sigmaQT/sigmaW
6155 !calculate exc_moist by conserving rh:
6156 ! tk_int =(tk(kts)*dz(kts+1)+tk(kts+1)*dz(kts))/(dz(kts+1)+dz(kts))
6157 ! pk =(p(kts)*dz(kts+1)+p(kts+1)*dz(kts))/(dz(kts+1)+dz(kts))
6158 ! qtk =(qt(kts)*dz(kts+1)+qt(kts+1)*dz(kts))/(dz(kts)+dz(kts+1))
6159 ! qsat_tk = qsat_blend(tk_int, pk) ! saturation water vapor mixing ratio at tk and p
6160 ! rhgrid =MAX(MIN(1.0,qtk/MAX(1.E-8,qsat_tk)),0.001)
6161 ! tk_int = tk_int + exc_heat
6162 ! qsat_tk = qsat_blend(tk_int, pk)
6163 ! exc_moist= max(rhgrid*qsat_tk - qtk, 0.0)
6164 UPQT(1,I)=(QT(KTS)*DZ(KTS+1)+QT(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))&
6165 & +exc_moist
6167 UPQKE(1,I)=(QKE(KTS)*DZ(KTS+1)+QKE(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))
6168 UPQNC(1,I)=(QNC(KTS)*DZ(KTS+1)+QNC(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))
6169 UPQNI(1,I)=(QNI(KTS)*DZ(KTS+1)+QNI(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))
6170 UPQNWFA(1,I)=(QNWFA(KTS)*DZ(KTS+1)+QNWFA(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))
6171 UPQNIFA(1,I)=(QNIFA(KTS)*DZ(KTS+1)+QNIFA(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))
6172 UPQNBCA(1,I)=(QNBCA(KTS)*DZ(KTS+1)+QNBCA(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))
6173 ENDDO
6175 IF ( mix_chem ) THEN
6176 DO I=1,NUP !NUP2
6177 IF(I > NUP2) exit
6178 do ic = 1,nchem
6179 UPCHEM(1,I,ic)=(chem1(KTS,ic)*DZ(KTS+1)+chem1(KTS+1,ic)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))
6180 enddo
6181 ENDDO
6182 ENDIF
6184 !Initialize environmental variables which can be modified by detrainment
6185 DO k=kts,kte
6186 envm_thl(k)=THL(k)
6187 envm_sqv(k)=QV(k)
6188 envm_sqc(k)=QC(k)
6189 envm_u(k)=U(k)
6190 envm_v(k)=V(k)
6191 ENDDO
6193 !dxsa is scale-adaptive factor governing the pressure-gradient term of the momentum transport
6194 dxsa = 1. - MIN(MAX((12000.0-dx)/(12000.0-3000.0), 0.), 1.)
6196 ! do integration updraft
6197 DO I=1,NUP !NUP2
6198 IF(I > NUP2) exit
6199 QCn = 0.
6200 overshoot = 0
6201 l = dl*I ! diameter of plume
6202 DO k=KTS+1,KTE-1
6203 !Entrainment from Tian and Kuang (2016)
6204 !ENT(k,i) = 0.35/(MIN(MAX(UPW(K-1,I),0.75),1.9)*l)
6205 wmin = 0.3 + l*0.0005 !* MAX(pblh-ZW(k+1), 0.0)/pblh
6206 ENT(k,i) = 0.33/(MIN(MAX(UPW(K-1,I),wmin),0.9)*l)
6208 !Entrainment from Negggers (2015, JAMES)
6209 !ENT(k,i) = 0.02*l**-0.35 - 0.0009
6210 !ENT(k,i) = 0.04*l**-0.50 - 0.0009 !more plume diversity
6211 !ENT(k,i) = 0.04*l**-0.495 - 0.0009 !"neg1+"
6213 !Minimum background entrainment
6214 ENT(k,i) = max(ENT(k,i),0.0003)
6215 !ENT(k,i) = max(ENT(k,i),0.05/ZW(k)) !not needed for Tian and Kuang
6217 !JOE - increase entrainment for plumes extending very high.
6218 IF(ZW(k) >= MIN(pblh+1500., 4000.))THEN
6219 ENT(k,i)=ENT(k,i) + (ZW(k)-MIN(pblh+1500.,4000.))*5.0E-6
6220 ENDIF
6222 !SPP
6223 ENT(k,i) = ENT(k,i) * (1.0 - rstoch_col(k))
6225 ENT(k,i) = min(ENT(k,i),0.9/(ZW(k+1)-ZW(k)))
6227 ! Define environment U & V at the model interface levels
6228 Uk =(U(k)*DZ(k+1)+U(k+1)*DZ(k))/(DZ(k+1)+DZ(k))
6229 Ukm1=(U(k-1)*DZ(k)+U(k)*DZ(k-1))/(DZ(k-1)+DZ(k))
6230 Vk =(V(k)*DZ(k+1)+V(k+1)*DZ(k))/(DZ(k+1)+DZ(k))
6231 Vkm1=(V(k-1)*DZ(k)+V(k)*DZ(k-1))/(DZ(k-1)+DZ(k))
6233 ! Linear entrainment:
6234 EntExp= ENT(K,I)*(ZW(k+1)-ZW(k))
6235 EntExm= EntExp*0.3333 !reduce entrainment for momentum
6236 QTn =UPQT(k-1,I) *(1.-EntExp) + QT(k)*EntExp
6237 THLn=UPTHL(k-1,I)*(1.-EntExp) + THL(k)*EntExp
6238 Un =UPU(k-1,I) *(1.-EntExm) + U(k)*EntExm + dxsa*pgfac*(Uk - Ukm1)
6239 Vn =UPV(k-1,I) *(1.-EntExm) + V(k)*EntExm + dxsa*pgfac*(Vk - Vkm1)
6240 QKEn=UPQKE(k-1,I)*(1.-EntExp) + QKE(k)*EntExp
6241 QNCn=UPQNC(k-1,I)*(1.-EntExp) + QNC(k)*EntExp
6242 QNIn=UPQNI(k-1,I)*(1.-EntExp) + QNI(k)*EntExp
6243 QNWFAn=UPQNWFA(k-1,I)*(1.-EntExp) + QNWFA(k)*EntExp
6244 QNIFAn=UPQNIFA(k-1,I)*(1.-EntExp) + QNIFA(k)*EntExp
6245 QNBCAn=UPQNBCA(k-1,I)*(1.-EntExp) + QNBCA(k)*EntExp
6247 !capture the updated qc, qt & thl modified by entranment alone,
6248 !since they will be modified later if condensation occurs.
6249 qc_ent = QCn
6250 qt_ent = QTn
6251 thl_ent = THLn
6253 ! Exponential Entrainment:
6254 !EntExp= exp(-ENT(K,I)*(ZW(k)-ZW(k-1)))
6255 !QTn =QT(K) *(1-EntExp)+UPQT(K-1,I)*EntExp
6256 !THLn=THL(K)*(1-EntExp)+UPTHL(K-1,I)*EntExp
6257 !Un =U(K) *(1-EntExp)+UPU(K-1,I)*EntExp
6258 !Vn =V(K) *(1-EntExp)+UPV(K-1,I)*EntExp
6259 !QKEn=QKE(k)*(1-EntExp)+UPQKE(K-1,I)*EntExp
6261 if ( mix_chem ) then
6262 do ic = 1,nchem
6263 ! Exponential Entrainment:
6264 !chemn(ic) = chem(k,ic)*(1-EntExp)+UPCHEM(K-1,I,ic)*EntExp
6265 ! Linear entrainment:
6266 chemn(ic)=UPCHEM(k-1,i,ic)*(1.-EntExp) + chem1(k,ic)*EntExp
6267 enddo
6268 endif
6270 ! Define pressure at model interface
6271 Pk =(P(k)*DZ(k+1)+P(k+1)*DZ(k))/(DZ(k+1)+DZ(k))
6272 ! Compute plume properties thvn and qcn
6273 call condensation_edmf(QTn,THLn,Pk,ZW(k+1),THVn,QCn)
6275 ! Define environment THV at the model interface levels
6276 THVk =(THV(k)*DZ(k+1)+THV(k+1)*DZ(k))/(DZ(k+1)+DZ(k))
6277 THVkm1=(THV(k-1)*DZ(k)+THV(k)*DZ(k-1))/(DZ(k-1)+DZ(k))
6279 ! B=g*(0.5*(THVn+UPTHV(k-1,I))/THV(k-1) - 1.0)
6280 B=grav*(THVn/THVk - 1.0)
6281 IF(B>0.)THEN
6282 BCOEFF = 0.15 !w typically stays < 2.5, so doesnt hit the limits nearly as much
6283 ELSE
6284 BCOEFF = 0.2 !0.33
6285 ENDIF
6287 ! Original StEM with exponential entrainment
6288 !EntW=exp(-2.*(Wb+Wc*ENT(K,I))*(ZW(k)-ZW(k-1)))
6289 !Wn2=UPW(K-1,I)**2*EntW + (1.-EntW)*0.5*Wa*B/(Wb+Wc*ENT(K,I))
6290 ! Original StEM with linear entrainment
6291 !Wn2=UPW(K-1,I)**2*(1.-EntExp) + EntExp*0.5*Wa*B/(Wb+Wc*ENT(K,I))
6292 !Wn2=MAX(Wn2,0.0)
6293 !WA: TEMF form
6294 ! IF (B>0.0 .AND. UPW(K-1,I) < 0.2 ) THEN
6295 IF (UPW(K-1,I) < 0.2 ) THEN
6296 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.)
6297 ELSE
6298 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.)
6299 ENDIF
6300 !Do not allow a parcel to accelerate more than 1.25 m/s over 200 m.
6301 !Add max increase of 2.0 m/s for coarse vertical resolution.
6302 IF(Wn > UPW(K-1,I) + MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0) ) THEN
6303 Wn = UPW(K-1,I) + MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0)
6304 ENDIF
6305 !Add symmetrical max decrease in w
6306 IF(Wn < UPW(K-1,I) - MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0) ) THEN
6307 Wn = UPW(K-1,I) - MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0)
6308 ENDIF
6309 Wn = MIN(MAX(Wn,0.0), 3.0)
6311 !Check to make sure that the plume made it up at least one level.
6312 !if it failed, then set nup2=0 and exit the mass-flux portion.
6313 IF (k==kts+1 .AND. Wn == 0.) THEN
6314 NUP2=0
6315 exit
6316 ENDIF
6318 IF (debug_mf == 1) THEN
6319 IF (Wn .GE. 3.0) THEN
6320 ! surface values
6321 print *," **** SUSPICIOUSLY LARGE W:"
6322 print *,' QCn:',QCn,' ENT=',ENT(k,i),' Nup2=',Nup2
6323 print *,'pblh:',pblh,' Wn:',Wn,' UPW(k-1)=',UPW(K-1,I)
6324 print *,'K=',k,' B=',B,' dz=',ZW(k)-ZW(k-1)
6325 ENDIF
6326 ENDIF
6328 !Allow strongly forced plumes to overshoot if KE is sufficient
6329 IF (Wn <= 0.0 .AND. overshoot == 0) THEN
6330 overshoot = 1
6331 IF ( THVk-THVkm1 .GT. 0.0 ) THEN
6332 bvf = SQRT( gtr*(THVk-THVkm1)/dz(k) )
6333 !vertical Froude number
6334 Frz = UPW(K-1,I)/(bvf*dz(k))
6335 !IF ( Frz >= 0.5 ) Wn = MIN(Frz,1.0)*UPW(K-1,I)
6336 dzp = dz(k)*MAX(MIN(Frz,1.0),0.0) ! portion of highest layer the plume penetrates
6337 ENDIF
6338 ELSE
6339 dzp = dz(k)
6340 ENDIF
6342 !Limit very tall plumes
6343 Wn=Wn*EXP(-MAX(ZW(k+1)-MIN(pblh+2000.,3500.),0.0)/1000.)
6345 !JOE- minimize the plume penetratration in stratocu-topped PBL
6346 ! IF (fltv2 < 0.06) THEN
6347 ! IF(ZW(k+1) >= pblh-200. .AND. qc(k) > 1e-5 .AND. I > 4) Wn=0.
6348 ! ENDIF
6350 !Modify environment variables (representative of the model layer - envm*)
6351 !following the updraft dynamical detrainment of Asai and Kasahara (1967, JAS).
6352 !Reminder: w is limited to be non-negative (above)
6353 aratio = MIN(UPA(K-1,I)/(1.-UPA(K-1,I)), 0.5) !limit should never get hit
6354 detturb = 0.00008
6355 oow = -0.060/MAX(1.0,(0.5*(Wn+UPW(K-1,I)))) !coef for dynamical detrainment rate
6356 detrate = MIN(MAX(oow*(Wn-UPW(K-1,I))/dz(k), detturb), .0002) ! dynamical detrainment rate (m^-1)
6357 detrateUV= MIN(MAX(oow*(Wn-UPW(K-1,I))/dz(k), detturb), .0001) ! dynamical detrainment rate (m^-1)
6358 envm_thl(k)=envm_thl(k) + (0.5*(thl_ent + UPTHL(K-1,I)) - thl(k))*detrate*aratio*MIN(dzp,dzpmax)
6359 qv_ent = 0.5*(MAX(qt_ent-qc_ent,0.) + MAX(UPQT(K-1,I)-UPQC(K-1,I),0.))
6360 envm_sqv(k)=envm_sqv(k) + (qv_ent-QV(K))*detrate*aratio*MIN(dzp,dzpmax)
6361 IF (UPQC(K-1,I) > 1E-8) THEN
6362 IF (QC(K) > 1E-6) THEN
6363 qc_grid = QC(K)
6364 ELSE
6365 qc_grid = cldfra_bl1d(k)*qc_bl1d(K)
6366 ENDIF
6367 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)
6368 ENDIF
6369 envm_u(k) =envm_u(k) + (0.5*(Un + UPU(K-1,I)) - U(K))*detrateUV*aratio*MIN(dzp,dzpmax)
6370 envm_v(k) =envm_v(k) + (0.5*(Vn + UPV(K-1,I)) - V(K))*detrateUV*aratio*MIN(dzp,dzpmax)
6372 IF (Wn > 0.) THEN
6373 !Update plume variables at current k index
6374 UPW(K,I)=Wn !sqrt(Wn2)
6375 UPTHV(K,I)=THVn
6376 UPTHL(K,I)=THLn
6377 UPQT(K,I)=QTn
6378 UPQC(K,I)=QCn
6379 UPU(K,I)=Un
6380 UPV(K,I)=Vn
6381 UPQKE(K,I)=QKEn
6382 UPQNC(K,I)=QNCn
6383 UPQNI(K,I)=QNIn
6384 UPQNWFA(K,I)=QNWFAn
6385 UPQNIFA(K,I)=QNIFAn
6386 UPQNBCA(K,I)=QNBCAn
6387 UPA(K,I)=UPA(K-1,I)
6388 IF ( mix_chem ) THEN
6389 do ic = 1,nchem
6390 UPCHEM(k,I,ic) = chemn(ic)
6391 enddo
6392 ENDIF
6393 ktop = MAX(ktop,k)
6394 ELSE
6395 exit !exit k-loop
6396 END IF
6397 ENDDO
6398 IF (debug_mf == 1) THEN
6399 IF (MAXVAL(UPW(:,I)) > 10.0 .OR. MINVAL(UPA(:,I)) < 0.0 .OR. &
6400 MAXVAL(UPA(:,I)) > Atot .OR. NUP2 > 10) THEN
6401 ! surface values
6402 print *,'flq:',flq,' fltv:',fltv2,' Nup2=',Nup2
6403 print *,'pblh:',pblh,' wstar:',wstar,' ktop=',ktop
6404 print *,'sigmaW=',sigmaW,' sigmaTH=',sigmaTH,' sigmaQT=',sigmaQT
6405 ! means
6406 print *,'u:',u
6407 print *,'v:',v
6408 print *,'thl:',thl
6409 print *,'UPA:',UPA(:,I)
6410 print *,'UPW:',UPW(:,I)
6411 print *,'UPTHL:',UPTHL(:,I)
6412 print *,'UPQT:',UPQT(:,I)
6413 print *,'ENT:',ENT(:,I)
6414 ENDIF
6415 ENDIF
6416 ENDDO
6417 ELSE
6418 !At least one of the conditions was not met for activating the MF scheme.
6419 NUP2=0.
6420 END IF !end criteria for mass-flux scheme
6422 ktop=MIN(ktop,KTE-1) ! Just to be safe...
6423 IF (ktop == 0) THEN
6424 ztop = 0.0
6425 ELSE
6426 ztop=zw(ktop)
6427 ENDIF
6429 IF(nup2 > 0) THEN
6431 !Calculate the fluxes for each variable
6432 !All s_aw* variable are == 0 at k=1
6433 DO i=1,NUP !NUP2
6434 IF(I > NUP2) exit
6435 DO k=KTS,KTE-1
6436 IF(k > ktop) exit
6437 rho_int = (rho(k)*DZ(k+1)+rho(k+1)*DZ(k))/(DZ(k+1)+DZ(k))
6438 s_aw(k+1) = s_aw(k+1) + rho_int*UPA(K,i)*UPW(K,i)*Psig_w
6439 s_awthl(k+1)= s_awthl(k+1) + rho_int*UPA(K,i)*UPW(K,i)*UPTHL(K,i)*Psig_w
6440 s_awqt(k+1) = s_awqt(k+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQT(K,i)*Psig_w
6441 !to conform to grid mean properties, move qc to qv in grid mean
6442 !saturated layers, so total water fluxes are preserved but
6443 !negative qc fluxes in unsaturated layers is reduced.
6444 IF (qc(k) > 1e-12 .OR. qc(k+1) > 1e-12) then
6445 qc_plume = UPQC(K,i)
6446 ELSE
6447 qc_plume = 0.0
6448 ENDIF
6449 s_awqc(k+1) = s_awqc(k+1) + rho_int*UPA(K,i)*UPW(K,i)*qc_plume*Psig_w
6450 IF (momentum_opt > 0) THEN
6451 s_awu(k+1) = s_awu(k+1) + rho_int*UPA(K,i)*UPW(K,i)*UPU(K,i)*Psig_w
6452 s_awv(k+1) = s_awv(k+1) + rho_int*UPA(K,i)*UPW(K,i)*UPV(K,i)*Psig_w
6453 ENDIF
6454 IF (tke_opt > 0) THEN
6455 s_awqke(k+1)= s_awqke(k+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQKE(K,i)*Psig_w
6456 ENDIF
6457 s_awqv(k+1) = s_awqt(k+1) - s_awqc(k+1)
6458 ENDDO
6459 ENDDO
6461 IF ( mix_chem ) THEN
6462 DO k=KTS,KTE
6463 IF(k > KTOP) exit
6464 rho_int = (rho(k)*DZ(k+1)+rho(k+1)*DZ(k))/(DZ(k+1)+DZ(k))
6465 DO i=1,NUP !NUP2
6466 IF(I > NUP2) exit
6467 do ic = 1,nchem
6468 s_awchem(k+1,ic) = s_awchem(k+1,ic) + rho_int*UPA(K,i)*UPW(K,i)*UPCHEM(K,i,ic)*Psig_w
6469 enddo
6470 ENDDO
6471 ENDDO
6472 ENDIF
6474 IF (scalar_opt > 0) THEN
6475 DO k=KTS,KTE
6476 IF(k > KTOP) exit
6477 rho_int = (rho(k)*DZ(k+1)+rho(k+1)*DZ(k))/(DZ(k+1)+DZ(k))
6478 DO I=1,NUP !NUP2
6479 IF (I > NUP2) exit
6480 s_awqnc(k+1)= s_awqnc(K+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQNC(K,i)*Psig_w
6481 s_awqni(k+1)= s_awqni(K+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQNI(K,i)*Psig_w
6482 s_awqnwfa(k+1)= s_awqnwfa(K+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQNWFA(K,i)*Psig_w
6483 s_awqnifa(k+1)= s_awqnifa(K+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQNIFA(K,i)*Psig_w
6484 s_awqnbca(k+1)= s_awqnbca(K+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQNBCA(K,i)*Psig_w
6485 ENDDO
6486 ENDDO
6487 ENDIF
6489 !Flux limiter: Check ratio of heat flux at top of first model layer
6490 !and at the surface. Make sure estimated flux out of the top of the
6491 !layer is < fluxportion*surface_heat_flux
6492 IF (s_aw(kts+1) /= 0.) THEN
6493 dzi(kts) = 0.5*(DZ(kts)+DZ(kts+1)) !dz centered at model interface
6494 flx1 = MAX(s_aw(kts+1)*(TH(kts)-TH(kts+1))/dzi(kts),1.0e-5)
6495 ELSE
6496 flx1 = 0.0
6497 !print*,"ERROR: s_aw(kts+1) == 0, NUP=",NUP," NUP2=",NUP2,&
6498 ! " superadiabatic=",superadiabatic," KTOP=",KTOP
6499 ENDIF
6500 adjustment=1.0
6501 !Print*,"Flux limiter in MYNN-EDMF, adjustment=",fluxportion*flt/dz(kts)/flx1
6502 !Print*,"flt/dz=",flt/dz(kts)," flx1=",flx1," s_aw(kts+1)=",s_aw(kts+1)
6503 IF (flx1 > fluxportion*flt/dz(kts) .AND. flx1>0.0) THEN
6504 adjustment= fluxportion*flt/dz(kts)/flx1
6505 s_aw = s_aw*adjustment
6506 s_awthl= s_awthl*adjustment
6507 s_awqt = s_awqt*adjustment
6508 s_awqc = s_awqc*adjustment
6509 s_awqv = s_awqv*adjustment
6510 s_awqnc= s_awqnc*adjustment
6511 s_awqni= s_awqni*adjustment
6512 s_awqnwfa= s_awqnwfa*adjustment
6513 s_awqnifa= s_awqnifa*adjustment
6514 s_awqnbca= s_awqnbca*adjustment
6515 IF (momentum_opt > 0) THEN
6516 s_awu = s_awu*adjustment
6517 s_awv = s_awv*adjustment
6518 ENDIF
6519 IF (tke_opt > 0) THEN
6520 s_awqke= s_awqke*adjustment
6521 ENDIF
6522 IF ( mix_chem ) THEN
6523 s_awchem = s_awchem*adjustment
6524 ENDIF
6525 UPA = UPA*adjustment
6526 ENDIF
6527 !Print*,"adjustment=",adjustment," fluxportion=",fluxportion," flt=",flt
6529 !Calculate mean updraft properties for output:
6530 !all edmf_* variables at k=1 correspond to the interface at top of first model layer
6531 DO k=KTS,KTE-1
6532 IF(k > KTOP) exit
6533 rho_int = (rho(k)*DZ(k+1)+rho(k+1)*DZ(k))/(DZ(k+1)+DZ(k))
6534 DO I=1,NUP !NUP2
6535 IF(I > NUP2) exit
6536 edmf_a(K) =edmf_a(K) +UPA(K,i)
6537 edmf_w(K) =edmf_w(K) +rho_int*UPA(K,i)*UPW(K,i)
6538 edmf_qt(K) =edmf_qt(K) +rho_int*UPA(K,i)*UPQT(K,i)
6539 edmf_thl(K)=edmf_thl(K)+rho_int*UPA(K,i)*UPTHL(K,i)
6540 edmf_ent(K)=edmf_ent(K)+rho_int*UPA(K,i)*ENT(K,i)
6541 edmf_qc(K) =edmf_qc(K) +rho_int*UPA(K,i)*UPQC(K,i)
6542 ENDDO
6544 !Note that only edmf_a is multiplied by Psig_w. This takes care of the
6545 !scale-awareness of the subsidence below:
6546 IF (edmf_a(k)>0.) THEN
6547 edmf_w(k)=edmf_w(k)/edmf_a(k)
6548 edmf_qt(k)=edmf_qt(k)/edmf_a(k)
6549 edmf_thl(k)=edmf_thl(k)/edmf_a(k)
6550 edmf_ent(k)=edmf_ent(k)/edmf_a(k)
6551 edmf_qc(k)=edmf_qc(k)/edmf_a(k)
6552 edmf_a(k)=edmf_a(k)*Psig_w
6554 !FIND MAXIMUM MASS-FLUX IN THE COLUMN:
6555 IF(edmf_a(k)*edmf_w(k) > maxmf) maxmf = edmf_a(k)*edmf_w(k)
6556 ENDIF
6557 ENDDO ! end k
6559 !smoke/chem
6560 IF ( mix_chem ) THEN
6561 DO k=kts,kte-1
6562 IF(k > KTOP) exit
6563 rho_int = (rho(k)*dz(k+1)+rho(k+1)*dz(k))/(dz(k+1)+dz(k))
6564 DO I=1,NUP !NUP2
6565 IF(I > NUP2) exit
6566 do ic = 1,nchem
6567 edmf_chem(k,ic) = edmf_chem(k,ic) + rho_int*UPA(K,I)*UPCHEM(k,i,ic)
6568 enddo
6569 ENDDO
6571 IF (edmf_a(k)>0.) THEN
6572 do ic = 1,nchem
6573 edmf_chem(k,ic) = edmf_chem(k,ic)/edmf_a(k)
6574 enddo
6575 ENDIF
6576 ENDDO ! end k
6577 ENDIF
6579 !Calculate the effects environmental subsidence.
6580 !All envi_*variables are valid at the interfaces, like the edmf_* variables
6581 IF (env_subs) THEN
6582 DO k=kts+1,kte-1
6583 !First, smooth the profiles of w & a, since sharp vertical gradients
6584 !in plume variables are not likely extended to env variables
6585 !Note1: w is treated as negative further below
6586 !Note2: both w & a will be transformed into env variables further below
6587 envi_w(k) = onethird*(edmf_w(k-1)+edmf_w(k)+edmf_w(k+1))
6588 envi_a(k) = onethird*(edmf_a(k-1)+edmf_a(k)+edmf_a(k+1))*adjustment
6589 ENDDO
6590 !define env variables at k=1 (top of first model layer)
6591 envi_w(kts) = edmf_w(kts)
6592 envi_a(kts) = edmf_a(kts)
6593 !define env variables at k=kte
6594 envi_w(kte) = 0.0
6595 envi_a(kte) = edmf_a(kte)
6596 !define env variables at k=kte+1
6597 envi_w(kte+1) = 0.0
6598 envi_a(kte+1) = edmf_a(kte)
6599 !Add limiter for very long time steps (i.e. dt > 300 s)
6600 !Note that this is not a robust check - only for violations in
6601 ! the first model level.
6602 IF (envi_w(kts) > 0.9*DZ(kts)/dt) THEN
6603 sublim = 0.9*DZ(kts)/dt/envi_w(kts)
6604 ELSE
6605 sublim = 1.0
6606 ENDIF
6607 !Transform w & a into env variables
6608 DO k=kts,kte
6609 temp=envi_a(k)
6610 envi_a(k)=1.0-temp
6611 envi_w(k)=csub*sublim*envi_w(k)*temp/(1.-temp)
6612 ENDDO
6613 !calculate tendencies from subsidence and detrainment valid at the middle of
6614 !each model layer. The lowest model layer uses an assumes w=0 at the surface.
6615 dzi(kts) = 0.5*(dz(kts)+dz(kts+1))
6616 rho_int = (rho(kts)*dz(kts+1)+rho(kts+1)*dz(kts))/(dz(kts+1)+dz(kts))
6617 sub_thl(kts)= 0.5*envi_w(kts)*envi_a(kts)* &
6618 (rho(kts+1)*thl(kts+1)-rho(kts)*thl(kts))/dzi(kts)/rho_int
6619 sub_sqv(kts)= 0.5*envi_w(kts)*envi_a(kts)* &
6620 (rho(kts+1)*qv(kts+1)-rho(kts)*qv(kts))/dzi(kts)/rho_int
6621 DO k=kts+1,kte-1
6622 dzi(k) = 0.5*(dz(k)+dz(k+1))
6623 rho_int = (rho(k)*dz(k+1)+rho(k+1)*dz(k))/(dz(k+1)+dz(k))
6624 sub_thl(k)= 0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * &
6625 (rho(k+1)*thl(k+1)-rho(k)*thl(k))/dzi(k)/rho_int
6626 sub_sqv(k)= 0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * &
6627 (rho(k+1)*qv(k+1)-rho(k)*qv(k))/dzi(k)/rho_int
6628 ENDDO
6630 DO k=KTS,KTE-1
6631 det_thl(k)=Cdet*(envm_thl(k)-thl(k))*envi_a(k)*Psig_w
6632 det_sqv(k)=Cdet*(envm_sqv(k)-qv(k))*envi_a(k)*Psig_w
6633 det_sqc(k)=Cdet*(envm_sqc(k)-qc(k))*envi_a(k)*Psig_w
6634 ENDDO
6636 IF (momentum_opt > 0) THEN
6637 rho_int = (rho(kts)*dz(kts+1)+rho(kts+1)*dz(kts))/(dz(kts+1)+dz(kts))
6638 sub_u(kts)=0.5*envi_w(kts)*envi_a(kts)* &
6639 (rho(kts+1)*u(kts+1)-rho(kts)*u(kts))/dzi(kts)/rho_int
6640 sub_v(kts)=0.5*envi_w(kts)*envi_a(kts)* &
6641 (rho(kts+1)*v(kts+1)-rho(kts)*v(kts))/dzi(kts)/rho_int
6642 DO k=kts+1,kte-1
6643 rho_int = (rho(k)*dz(k+1)+rho(k+1)*dz(k))/(dz(k+1)+dz(k))
6644 sub_u(k)=0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * &
6645 (rho(k+1)*u(k+1)-rho(k)*u(k))/dzi(k)/rho_int
6646 sub_v(k)=0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * &
6647 (rho(k+1)*v(k+1)-rho(k)*v(k))/dzi(k)/rho_int
6648 ENDDO
6650 DO k=KTS,KTE-1
6651 det_u(k) = Cdet*(envm_u(k)-u(k))*envi_a(k)*Psig_w
6652 det_v(k) = Cdet*(envm_v(k)-v(k))*envi_a(k)*Psig_w
6653 ENDDO
6654 ENDIF
6655 ENDIF !end subsidence/env detranment
6657 !First, compute exner, plume theta, and dz centered at interface
6658 !Here, k=1 is the top of the first model layer. These values do not
6659 !need to be defined at k=kte (unused level).
6660 DO K=KTS,KTE-1
6661 exneri(k) = (exner(k)*DZ(k+1)+exner(k+1)*DZ(k))/(DZ(k+1)+DZ(k))
6662 edmf_th(k)= edmf_thl(k) + xlvcp/exneri(k)*edmf_qc(K)
6663 dzi(k) = 0.5*(DZ(k)+DZ(k+1))
6664 ENDDO
6666 !JOE: ADD CLDFRA_bl1d, qc_bl1d. Note that they have already been defined in
6667 ! mym_condensation. Here, a shallow-cu component is added, but no cumulus
6668 ! clouds can be added at k=1 (start loop at k=2).
6669 DO K=KTS+1,KTE-2
6670 IF(k > KTOP) exit
6671 IF(0.5*(edmf_qc(k)+edmf_qc(k-1))>0.0)THEN
6672 !interpolate plume quantities to mass levels
6673 Aup = (edmf_a(k)*dzi(k-1)+edmf_a(k-1)*dzi(k))/(dzi(k-1)+dzi(k))
6674 THp = (edmf_th(k)*dzi(k-1)+edmf_th(k-1)*dzi(k))/(dzi(k-1)+dzi(k))
6675 QTp = (edmf_qt(k)*dzi(k-1)+edmf_qt(k-1)*dzi(k))/(dzi(k-1)+dzi(k))
6676 !convert TH to T
6677 ! t = THp*exner(k)
6678 !SATURATED VAPOR PRESSURE
6679 esat = esat_blend(tk(k))
6680 !SATURATED SPECIFIC HUMIDITY
6681 qsl=ep_2*esat/max(1.e-7,(p(k)-ep_3*esat))
6683 !condensed liquid in the plume on mass levels
6684 IF (edmf_qc(k)>0.0 .AND. edmf_qc(k-1)>0.0)THEN
6685 QCp = (edmf_qc(k)*dzi(k-1)+edmf_qc(k-1)*dzi(k))/(dzi(k-1)+dzi(k))
6686 ELSE
6687 QCp = MAX(edmf_qc(k),edmf_qc(k-1))
6688 ENDIF
6690 !COMPUTE CLDFRA & QC_BL FROM MASS-FLUX SCHEME and recompute vt & vq
6691 xl = xl_blend(tk(k)) ! obtain blended heat capacity
6692 qsat_tk = qsat_blend(tk(k),p(k)) ! get saturation water vapor mixing ratio
6693 ! at t and p
6694 rsl = xl*qsat_tk / (r_v*tk(k)**2) ! slope of C-C curve at t (abs temp)
6695 ! CB02, Eqn. 4
6696 cpm = cp + qt(k)*cpv ! CB02, sec. 2, para. 1
6697 a = 1./(1. + xl*rsl/cpm) ! CB02 variable "a"
6698 b9 = a*rsl ! CB02 variable "b"
6700 q2p = xlvcp/exner(k)
6701 pt = thl(k) +q2p*QCp*Aup ! potential temp (env + plume)
6702 bb = b9*tk(k)/pt ! bb is "b9" in BCMT95. Their "b9" differs from
6703 ! "b9" in CB02 by a factor
6704 ! of T/theta. Strictly, b9 above is formulated in
6705 ! terms of sat. mixing ratio, but bb in BCMT95 is
6706 ! cast in terms of sat. specific humidity. The
6707 ! conversion is neglected here.
6708 qww = 1.+0.61*qt(k)
6709 alpha = 0.61*pt
6710 beta = pt*xl/(tk(k)*cp) - 1.61*pt
6711 !Buoyancy flux terms have been moved to the end of this section...
6713 !Now calculate convective component of the cloud fraction:
6714 if (a > 0.0) then
6715 f = MIN(1.0/a, 4.0) ! f is vertical profile scaling function (CB2005)
6716 else
6717 f = 1.0
6718 endif
6720 !CB form:
6721 !sigq = 3.5E-3 * Aup * 0.5*(edmf_w(k)+edmf_w(k-1)) * f ! convective component of sigma (CB2005)
6722 !sigq = SQRT(sigq**2 + sgm(k)**2) ! combined conv + stratus components
6723 !Per S.DeRoode 2009?
6724 !sigq = 4. * Aup * (QTp - qt(k))
6725 sigq = 10. * Aup * (QTp - qt(k))
6726 !constrain sigq wrt saturation:
6727 sigq = max(sigq, qsat_tk*0.02 )
6728 sigq = min(sigq, qsat_tk*0.25 )
6730 qmq = a * (qt(k) - qsat_tk) ! saturation deficit/excess;
6731 Q1 = qmq/sigq ! the numerator of Q1
6733 if ((landsea-1.5).GE.0) then ! WATER
6734 !modified form from LES
6735 !mf_cf = min(max(0.5 + 0.36 * atan(1.20*(Q1+0.2)),0.01),0.6)
6736 !Original CB
6737 mf_cf = min(max(0.5 + 0.36 * atan(1.55*Q1),0.01),0.6)
6738 mf_cf = max(mf_cf, 1.2 * Aup)
6739 mf_cf = min(mf_cf, 5.0 * Aup)
6740 else ! LAND
6741 !LES form
6742 !mf_cf = min(max(0.5 + 0.36 * atan(1.20*(Q1+0.4)),0.01),0.6)
6743 !Original CB
6744 mf_cf = min(max(0.5 + 0.36 * atan(1.55*Q1),0.01),0.6)
6745 mf_cf = max(mf_cf, 1.75 * Aup)
6746 mf_cf = min(mf_cf, 5.0 * Aup)
6747 endif
6749 ! WA TEST 4/15/22 use fit to Aup rather than CB
6750 !IF (Aup > 0.1) THEN
6751 ! mf_cf = 2.5 * Aup
6752 !ELSE
6753 ! mf_cf = 1.8 * Aup
6754 !ENDIF
6756 !IF ( debug_code ) THEN
6757 ! print*,"In MYNN, StEM edmf"
6758 ! print*," CB: env qt=",qt(k)," qsat=",qsat_tk
6759 ! print*," k=",k," satdef=",QTp - qsat_tk," sgm=",sgm(k)
6760 ! print*," CB: sigq=",sigq," qmq=",qmq," tk=",tk(k)
6761 ! print*," CB: mf_cf=",mf_cf," cldfra_bl=",cldfra_bl1d(k)," edmf_a=",edmf_a(k)
6762 !ENDIF
6764 ! Update cloud fractions and specific humidities in grid cells
6765 ! where the mass-flux scheme is active. The specific humidities
6766 ! are converted to grid means (not in-cloud quantities).
6768 if ((landsea-1.5).GE.0) then ! water
6769 !don't overwrite stratus CF & qc_bl - degrades marine stratus
6770 if (cldfra_bl1d(k) < cf_thresh) then
6771 if (QCp * Aup > 5e-5) then
6772 qc_bl1d(k) = 1.86 * (QCp * Aup) - 2.2e-5
6773 else
6774 qc_bl1d(k) = 1.18 * (QCp * Aup)
6775 endif
6776 if (mf_cf .ge. Aup) then
6777 qc_bl1d(k) = qc_bl1d(k) / mf_cf
6778 endif
6779 cldfra_bl1d(k) = mf_cf
6780 Ac_mf = mf_cf
6781 endif
6782 else ! land
6783 if (QCp * Aup > 5e-5) then
6784 qc_bl1d(k) = 1.86 * (QCp * Aup) - 2.2e-5
6785 else
6786 qc_bl1d(k) = 1.18 * (QCp * Aup)
6787 endif
6788 if (mf_cf .ge. Aup) then
6789 qc_bl1d(k) = qc_bl1d(k) / mf_cf
6790 endif
6791 cldfra_bl1d(k) = mf_cf
6792 Ac_mf = mf_cf
6793 endif
6795 !Now recalculate the terms for the buoyancy flux for mass-flux clouds:
6796 !See mym_condensation for details on these formulations.
6797 !Use Bechtold and Siebesma (1998) piecewise estimation of Fng with
6798 !limits ,since they really should be recalculated after all the other changes...:
6799 !Only overwrite vt & vq in non-stratus condition
6800 if (cldfra_bl1d(k) < cf_thresh) then
6801 !if ((landsea-1.5).GE.0) then ! WATER
6802 Q1=max(Q1,-2.25)
6803 !else
6804 ! Q1=max(Q1,-2.0)
6805 !endif
6807 if (Q1 .ge. 1.0) then
6808 Fng = 1.0
6809 elseif (Q1 .ge. -1.7 .and. Q1 .lt. 1.0) then
6810 Fng = EXP(-0.4*(Q1-1.0))
6811 elseif (Q1 .ge. -2.5 .and. Q1 .lt. -1.7) then
6812 Fng = 3.0 + EXP(-3.8*(Q1+1.7))
6813 else
6814 Fng = min(23.9 + EXP(-1.6*(Q1+2.5)), 60.)
6815 endif
6817 !link the buoyancy flux function to active clouds only (c*Aup):
6818 vt(k) = qww - (1.5*Aup)*beta*bb*Fng - 1.
6819 vq(k) = alpha + (1.5*Aup)*beta*a*Fng - tv0
6820 endif
6821 endif
6822 enddo !k-loop
6824 ENDIF !end nup2 > 0
6826 !modify output (negative: dry plume, positive: moist plume)
6827 IF (ktop > 0) THEN
6828 maxqc = maxval(edmf_qc(1:ktop))
6829 IF ( maxqc < 1.E-8) maxmf = -1.0*maxmf
6830 ENDIF
6832 !
6833 ! debugging
6834 !
6835 IF (edmf_w(1) > 4.0) THEN
6836 ! surface values
6837 print *,'flq:',flq,' fltv:',fltv2
6838 print *,'pblh:',pblh,' wstar:',wstar
6839 print *,'sigmaW=',sigmaW,' sigmaTH=',sigmaTH,' sigmaQT=',sigmaQT
6840 ! means
6841 ! print *,'u:',u
6842 ! print *,'v:',v
6843 ! print *,'thl:',thl
6844 ! print *,'thv:',thv
6845 ! print *,'qt:',qt
6846 ! print *,'p:',p
6848 ! updrafts
6849 ! DO I=1,NUP2
6850 ! print *,'up:A',i
6851 ! print *,UPA(:,i)
6852 ! print *,'up:W',i
6853 ! print*,UPW(:,i)
6854 ! print *,'up:thv',i
6855 ! print *,UPTHV(:,i)
6856 ! print *,'up:thl',i
6857 ! print *,UPTHL(:,i)
6858 ! print *,'up:qt',i
6859 ! print *,UPQT(:,i)
6860 ! print *,'up:tQC',i
6861 ! print *,UPQC(:,i)
6862 ! print *,'up:ent',i
6863 ! print *,ENT(:,i)
6864 ! ENDDO
6866 ! mean updrafts
6867 print *,' edmf_a',edmf_a(1:14)
6868 print *,' edmf_w',edmf_w(1:14)
6869 print *,' edmf_qt:',edmf_qt(1:14)
6870 print *,' edmf_thl:',edmf_thl(1:14)
6872 ENDIF !END Debugging
6875 #ifdef HARDCODE_VERTICAL
6876 # undef kts
6877 # undef kte
6878 #endif
6880 END SUBROUTINE DMP_MF
6881 !=================================================================
6882 !>\ingroup gsd_mynn_edmf
6883 !! This subroutine
6884 subroutine condensation_edmf(QT,THL,P,zagl,THV,QC)
6885 !
6886 ! zero or one condensation for edmf: calculates THV and QC
6887 !
6888 real,intent(in) :: QT,THL,P,zagl
6889 real,intent(out) :: THV
6890 real,intent(inout):: QC
6892 integer :: niter,i
6893 real :: diff,exn,t,th,qs,qcold
6895 ! constants used from module_model_constants.F
6896 ! p1000mb
6897 ! rcp ... Rd/cp
6898 ! xlv ... latent heat for water (2.5e6)
6899 ! cp
6900 ! rvord .. r_v/r_d (1.6)
6902 ! number of iterations
6903 niter=50
6904 ! minimum difference (usually converges in < 8 iterations with diff = 2e-5)
6905 diff=1.e-6
6907 EXN=(P/p1000mb)**rcp
6908 !QC=0. !better first guess QC is incoming from lower level, do not set to zero
6909 do i=1,NITER
6910 T=EXN*THL + xlvcp*QC
6911 QS=qsat_blend(T,P)
6912 QCOLD=QC
6913 QC=0.5*QC + 0.5*MAX((QT-QS),0.)
6914 if (abs(QC-QCOLD)<Diff) exit
6915 enddo
6917 T=EXN*THL + xlvcp*QC
6918 QS=qsat_blend(T,P)
6919 QC=max(QT-QS,0.)
6921 !Do not allow saturation below 100 m
6922 if(zagl < 100.)QC=0.
6924 !THV=(THL+xlv/cp*QC).*(1+(1-rvovrd)*(QT-QC)-QC);
6925 THV=(THL+xlvcp*QC)*(1.+QT*(rvovrd-1.)-rvovrd*QC)
6927 ! IF (QC > 0.0) THEN
6928 ! PRINT*,"EDMF SAT, p:",p," iterations:",i
6929 ! PRINT*," T=",T," THL=",THL," THV=",THV
6930 ! PRINT*," QS=",QS," QT=",QT," QC=",QC,"ratio=",qc/qs
6931 ! ENDIF
6933 !THIS BASICALLY GIVE THE SAME RESULT AS THE PREVIOUS LINE
6934 !TH = THL + xlv/cp/EXN*QC
6935 !THV= TH*(1. + 0.608*QT)
6937 !print *,'t,p,qt,qs,qc'
6938 !print *,t,p,qt,qs,qc
6941 end subroutine condensation_edmf
6943 !===============================================================
6945 subroutine condensation_edmf_r(QT,THL,P,zagl,THV,QC)
6946 !
6947 ! zero or one condensation for edmf: calculates THL and QC
6948 ! similar to condensation_edmf but with different inputs
6949 !
6950 real,intent(in) :: QT,THV,P,zagl
6951 real,intent(out) :: THL, QC
6953 integer :: niter,i
6954 real :: diff,exn,t,th,qs,qcold
6956 ! number of iterations
6957 niter=50
6958 ! minimum difference
6959 diff=2.e-5
6961 EXN=(P/p1000mb)**rcp
6962 ! assume first that th = thv
6963 T = THV*EXN
6964 !QS = qsat_blend(T,P)
6965 !QC = QS - QT
6967 QC=0.
6969 do i=1,NITER
6970 QCOLD = QC
6971 T = EXN*THV/(1.+QT*(rvovrd-1.)-rvovrd*QC)
6972 QS=qsat_blend(T,P)
6973 QC= MAX((QT-QS),0.)
6974 if (abs(QC-QCOLD)<Diff) exit
6975 enddo
6976 THL = (T - xlv/cp*QC)/EXN
6978 end subroutine condensation_edmf_r
6980 !===============================================================
6981 ! ===================================================================
6982 ! This is the downdraft mass flux scheme - analogus to edmf_JPL but
6983 ! flipped updraft to downdraft. This scheme is currently only tested
6984 ! for Stratocumulus cloud conditions. For a detailed desctiption of the
6985 ! model, see paper.
6987 SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, &
6988 &u,v,th,thl,thv,tk,qt,qv,qc, &
6989 &rho,exner, &
6990 &ust,wthl,wqt,pblh,kpbl, &
6991 &edmf_a_dd,edmf_w_dd, edmf_qt_dd, &
6992 &edmf_thl_dd,edmf_ent_dd,edmf_qc_dd, &
6993 &sd_aw,sd_awthl,sd_awqt, &
6994 &sd_awqv,sd_awqc,sd_awu,sd_awv, &
6995 &sd_awqke, &
6996 &qc_bl1d,cldfra_bl1d, &
6997 &rthraten )
6999 INTEGER, INTENT(IN) :: KTS,KTE,KPBL
7000 REAL,DIMENSION(KTS:KTE), INTENT(IN) :: U,V,TH,THL,TK,QT,QV,QC,&
7001 THV,P,rho,exner,rthraten,dz
7002 ! zw .. heights of the downdraft levels (edges of boxes)
7003 REAL,DIMENSION(KTS:KTE+1), INTENT(IN) :: ZW
7004 REAL, INTENT(IN) :: DT,UST,WTHL,WQT,PBLH
7006 ! outputs - downdraft properties
7007 REAL,DIMENSION(KTS:KTE), INTENT(OUT) :: edmf_a_dd,edmf_w_dd, &
7008 & edmf_qt_dd,edmf_thl_dd, edmf_ent_dd,edmf_qc_dd
7010 ! outputs - variables needed for solver (sd_aw - sum ai*wi, sd_awphi - sum ai*wi*phii)
7011 REAL,DIMENSION(KTS:KTE+1) :: sd_aw, sd_awthl, sd_awqt, sd_awu, &
7012 sd_awv, sd_awqc, sd_awqv, sd_awqke, sd_aw2
7014 REAL,DIMENSION(KTS:KTE), INTENT(IN) :: qc_bl1d, cldfra_bl1d
7016 INTEGER, PARAMETER :: NDOWN=5, debug_mf=0 !fixing number of plumes to 5
7017 ! draw downdraft starting height randomly between cloud base and cloud top
7018 INTEGER, DIMENSION(1:NDOWN) :: DD_initK
7019 REAL , DIMENSION(1:NDOWN) :: randNum
7020 ! downdraft properties
7021 REAL,DIMENSION(KTS:KTE+1,1:NDOWN) :: DOWNW,DOWNTHL,DOWNQT,&
7022 DOWNQC,DOWNA,DOWNU,DOWNV,DOWNTHV
7024 ! entrainment variables
7025 REAl,DIMENSION(KTS+1:KTE+1,1:NDOWN) :: ENT,ENTf
7026 INTEGER,DIMENSION(KTS+1:KTE+1,1:NDOWN) :: ENTi
7028 ! internal variables
7029 INTEGER :: K,I,ki, kminrad, qlTop, p700_ind, qlBase
7030 REAL :: wthv,wstar,qstar,thstar,sigmaW,sigmaQT,sigmaTH,z0, &
7031 pwmin,pwmax,wmin,wmax,wlv,wtv,went,mindownw
7032 REAL :: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,Wn2,Wn,THVk,Pk, &
7033 EntEXP,EntW, Beta_dm, EntExp_M, rho_int
7034 REAL :: jump_thetav, jump_qt, jump_thetal, &
7035 refTHL, refTHV, refQT
7036 ! DD specific internal variables
7037 REAL :: minrad,zminrad, radflux, F0, wst_rad, wst_dd
7038 logical :: cloudflg
7040 REAL :: sigq,xl,rsl,cpm,a,mf_cf,diffqt,&
7041 Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9,satvp,rhgrid
7043 ! w parameters
7044 REAL,PARAMETER :: &
7045 &Wa=1., &
7046 &Wb=1.5,&
7047 &Z00=100.,&
7048 &BCOEFF=0.2
7049 ! entrainment parameters
7050 REAL,PARAMETER :: &
7051 & L0=80,&
7052 & ENT0=0.2
7054 pwmin=-3. ! drawing from the negative tail -3sigma to -1sigma
7055 pwmax=-1.
7057 ! initialize downdraft properties
7058 DOWNW=0.
7059 DOWNTHL=0.
7060 DOWNTHV=0.
7061 DOWNQT=0.
7062 DOWNA=0.
7063 DOWNU=0.
7064 DOWNV=0.
7065 DOWNQC=0.
7066 ENT=0.
7067 DD_initK=0
7069 edmf_a_dd =0.
7070 edmf_w_dd =0.
7071 edmf_qt_dd =0.
7072 edmf_thl_dd=0.
7073 edmf_ent_dd=0.
7074 edmf_qc_dd =0.
7076 sd_aw=0.
7077 sd_awthl=0.
7078 sd_awqt=0.
7079 sd_awqv=0.
7080 sd_awqc=0.
7081 sd_awu=0.
7082 sd_awv=0.
7083 sd_awqke=0.
7085 ! FIRST, CHECK FOR STRATOCUMULUS-TOPPED BOUNDARY LAYERS
7086 cloudflg=.false.
7087 minrad=100.
7088 kminrad=kpbl
7089 zminrad=PBLH
7090 qlTop = 1 !initialize at 0
7091 qlBase = 1
7092 wthv=wthl+svp1*wqt
7093 do k = MAX(3,kpbl-2),kpbl+3
7094 if (qc(k).gt. 1.e-6 .AND. cldfra_bl1D(k).gt.0.5) then
7095 cloudflg=.true. ! found Sc cloud
7096 qlTop = k ! index for Sc cloud top
7097 endif
7098 enddo
7100 do k = qlTop, kts, -1
7101 if (qc(k) .gt. 1E-6) then
7102 qlBase = k ! index for Sc cloud base
7103 endif
7104 enddo
7105 qlBase = (qlTop+qlBase)/2 ! changed base to half way through the cloud
7107 ! call init_random_seed_1()
7108 ! call RANDOM_NUMBER(randNum)
7109 do i=1,NDOWN
7110 ! downdraft starts somewhere between cloud base to cloud top
7111 ! the probability is equally distributed
7112 DD_initK(i) = qlTop ! nint(randNum(i)*REAL(qlTop-qlBase)) + qlBase
7113 enddo
7115 ! LOOP RADFLUX
7116 F0 = 0.
7117 do k = 1, qlTop ! Snippet from YSU, YSU loops until qlTop - 1
7118 radflux = rthraten(k) * exner(k) ! Converts theta/s to temperature/s
7119 radflux = radflux * cp / grav * ( p(k) - p(k+1) ) ! Converts K/s to W/m^2
7120 if ( radflux < 0.0 ) F0 = abs(radflux) + F0
7121 enddo
7122 F0 = max(F0, 1.0)
7123 !found Sc cloud and cloud not at surface, trigger downdraft
7124 if (cloudflg) then
7126 ! !get entrainent coefficient
7127 ! do i=1,NDOWN
7128 ! do k=kts+1,kte
7129 ! ENTf(k,i)=(ZW(k+1)-ZW(k))/L0
7130 ! enddo
7131 ! enddo
7132 !
7133 ! ! get Poisson P(dz/L0)
7134 ! call Poisson(1,NDOWN,kts+1,kte,ENTf,ENTi)
7137 ! entrainent: Ent=Ent0/dz*P(dz/L0)
7138 do i=1,NDOWN
7139 do k=kts+1,kte
7140 ! ENT(k,i)=real(ENTi(k,i))*Ent0/(ZW(k+1)-ZW(k))
7141 ENT(k,i) = 0.002
7142 ENT(k,i) = min(ENT(k,i),0.9/(ZW(k+1)-ZW(k)))
7143 enddo
7144 enddo
7146 !!![EW: INVJUMP] find 700mb height then subtract trpospheric lapse rate!!!
7147 p700_ind = MINLOC(ABS(p-70000),1)!p1D is 70000
7148 jump_thetav = thv(p700_ind) - thv(1) - (thv(p700_ind)-thv(qlTop+3))/(ZW(p700_ind)-ZW(qlTop+3))*(ZW(p700_ind)-ZW(qlTop))
7149 jump_qt = qc(p700_ind) + qv(p700_ind) - qc(1) - qv(1)
7150 jump_thetal = thl(p700_ind) - thl(1) - (thl(p700_ind)-thl(qlTop+3))/(ZW(p700_ind)-ZW(qlTop+3))*(ZW(p700_ind)-ZW(qlTop))
7152 refTHL = thl(qlTop) !sum(thl(1:qlTop)) / (qlTop) ! avg over BL for now or just at qlTop
7153 refTHV = thv(qlTop) !sum(thv(1:qlTop)) / (qlTop)
7154 refQT = qt(qlTop) !sum(qt(1:qlTop)) / (qlTop)
7156 ! wstar_rad, following Lock and MacVean (1999a)
7157 wst_rad = ( grav * zw(qlTop) * F0 / (refTHL * rho(qlTop) * cp) ) ** (0.333)
7158 wst_rad = max(wst_rad, 0.1)
7159 wstar = max(0.,(grav/thv(1)*wthv*pblh)**(onethird))
7160 went = thv(1) / ( grav * jump_thetav * zw(qlTop) ) * &
7161 (0.15 * (wstar**3 + 5*ust**3) + 0.35 * wst_rad**3 )
7162 qstar = abs(went*jump_qt/wst_rad)
7163 thstar = F0/rho(qlTop)/cp/wst_rad - went*jump_thetav/wst_rad
7164 !wstar_dd = mixrad + surface wst
7165 wst_dd = (0.15 * (wstar**3 + 5*ust**3) + 0.35 * wst_rad**3 ) ** (0.333)
7167 print*,"qstar=",qstar," thstar=",thstar," wst_dd=",wst_dd
7168 print*,"F0=",F0," wst_rad=",wst_rad," jump_thv=",jump_thetav
7169 print*,"entrainment velocity=",went
7171 sigmaW = 0.2*wst_dd ! 0.8*wst_dd !wst_rad tuning parameter ! 0.5 was good
7172 sigmaQT = 40 * qstar ! 50 was good
7173 sigmaTH = 1.0 * thstar! 0.5 was good
7175 wmin=sigmaW*pwmin
7176 wmax=sigmaW*pwmax
7177 !print*,"sigw=",sigmaW," wmin=",wmin," wmax=",wmax
7179 do I=1,NDOWN !downdraft now starts at different height
7180 ki = DD_initK(I)
7182 wlv=wmin+(wmax-wmin)/REAL(NDOWN)*(i-1)
7183 wtv=wmin+(wmax-wmin)/REAL(NDOWN)*i
7185 !DOWNW(ki,I)=0.5*(wlv+wtv)
7186 DOWNW(ki,I)=wlv
7187 !DOWNA(ki,I)=0.5*ERF(wtv/(sqrt(2.)*sigmaW))-0.5*ERF(wlv/(sqrt(2.)*sigmaW))
7188 DOWNA(ki,I)=.1/REAL(NDOWN)
7189 DOWNU(ki,I)=(u(ki-1)*DZ(ki) + u(ki)*DZ(ki-1)) /(DZ(ki)+DZ(ki-1))
7190 DOWNV(ki,I)=(v(ki-1)*DZ(ki) + v(ki)*DZ(ki-1)) /(DZ(ki)+DZ(ki-1))
7192 !reference now depends on where dd starts
7193 ! refTHL = 0.5 * (thl(ki) + thl(ki-1))
7194 ! refTHV = 0.5 * (thv(ki) + thv(ki-1))
7195 ! refQT = 0.5 * (qt(ki) + qt(ki-1) )
7197 refTHL = (thl(ki-1)*DZ(ki) + thl(ki)*DZ(ki-1)) /(DZ(ki)+DZ(ki-1))
7198 refTHV = (thv(ki-1)*DZ(ki) + thv(ki)*DZ(ki-1)) /(DZ(ki)+DZ(ki-1))
7199 refQT = (qt(ki-1)*DZ(ki) + qt(ki)*DZ(ki-1)) /(DZ(ki)+DZ(ki-1))
7201 !DOWNQC(ki,I) = 0.0
7202 DOWNQC(ki,I) = (qc(ki-1)*DZ(ki) + qc(ki)*DZ(ki-1)) /(DZ(ki)+DZ(ki-1))
7203 DOWNQT(ki,I) = refQT !+ 0.5 *DOWNW(ki,I)*sigmaQT/sigmaW
7204 DOWNTHV(ki,I)= refTHV + 0.01 *DOWNW(ki,I)*sigmaTH/sigmaW
7205 DOWNTHL(ki,I)= refTHL + 0.01 *DOWNW(ki,I)*sigmaTH/sigmaW
7207 !input :: QT,THV,P,zagl, output :: THL, QC
7208 ! Pk =(P(ki-1)*DZ(ki)+P(ki)*DZ(ki-1))/(DZ(ki)+DZ(ki-1))
7209 ! call condensation_edmf_r(DOWNQT(ki,I), &
7210 ! & DOWNTHL(ki,I),Pk,ZW(ki), &
7211 ! & DOWNTHV(ki,I),DOWNQC(ki,I) )
7213 enddo
7216 !print*, " Begin integration of downdrafts:"
7217 DO I=1,NDOWN
7218 !print *, "Plume # =", I,"======================="
7219 DO k=DD_initK(I)-1,KTS+1,-1
7220 !starting at the first interface level below cloud top
7221 !EntExp=exp(-ENT(K,I)*dz(k))
7222 !EntExp_M=exp(-ENT(K,I)/3.*dz(k))
7223 EntExp =ENT(K,I)*dz(k)
7224 EntExp_M=ENT(K,I)*0.333*dz(k)
7226 QTn =DOWNQT(k+1,I) *(1.-EntExp) + QT(k)*EntExp
7227 THLn=DOWNTHL(k+1,I)*(1.-EntExp) + THL(k)*EntExp
7228 Un =DOWNU(k+1,I) *(1.-EntExp) + U(k)*EntExp_M
7229 Vn =DOWNV(k+1,I) *(1.-EntExp) + V(k)*EntExp_M
7230 !QKEn=DOWNQKE(k-1,I)*(1.-EntExp) + QKE(k)*EntExp
7232 ! QTn =DOWNQT(K+1,I) +(QT(K) -DOWNQT(K+1,I)) *(1.-EntExp)
7233 ! THLn=DOWNTHL(K+1,I)+(THL(K)-DOWNTHL(K+1,I))*(1.-EntExp)
7234 ! Un =DOWNU(K+1,I) +(U(K) -DOWNU(K+1,I))*(1.-EntExp_M)
7235 ! Vn =DOWNV(K+1,I) +(V(K) -DOWNV(K+1,I))*(1.-EntExp_M)
7237 ! given new p & z, solve for thvn & qcn
7238 Pk =(P(k-1)*DZ(k)+P(k)*DZ(k-1))/(DZ(k)+DZ(k-1))
7239 call condensation_edmf(QTn,THLn,Pk,ZW(k),THVn,QCn)
7240 ! B=grav*(0.5*(THVn+DOWNTHV(k+1,I))/THV(k)-1.)
7241 THVk =(THV(k-1)*DZ(k)+THV(k)*DZ(k-1))/(DZ(k)+DZ(k-1))
7242 B=grav*(THVn/THVk - 1.0)
7243 ! Beta_dm = 2*Wb*ENT(K,I) + 0.5/(ZW(k)-dz(k)) * &
7244 ! & max(1. - exp((ZW(k) -dz(k))/Z00 - 1. ) , 0.)
7245 ! EntW=exp(-Beta_dm * dz(k))
7246 EntW=EntExp
7247 ! if (Beta_dm >0) then
7248 ! Wn2=DOWNW(K+1,I)**2*EntW - Wa*B/Beta_dm * (1. - EntW)
7249 ! else
7250 ! Wn2=DOWNW(K+1,I)**2 - 2.*Wa*B*dz(k)
7251 ! end if
7253 mindownw = MIN(DOWNW(K+1,I),-0.2)
7254 Wn = DOWNW(K+1,I) + (-2.*ENT(K,I)*DOWNW(K+1,I) - &
7255 BCOEFF*B/mindownw)*MIN(dz(k), 250.)
7257 !Do not allow a parcel to accelerate more than 1.25 m/s over 200 m.
7258 !Add max increase of 2.0 m/s for coarse vertical resolution.
7259 IF (Wn < DOWNW(K+1,I) - MIN(1.25*dz(k)/200., 2.0))THEN
7260 Wn = DOWNW(K+1,I) - MIN(1.25*dz(k)/200., 2.0)
7261 ENDIF
7262 !Add symmetrical max decrease in w
7263 IF (Wn > DOWNW(K+1,I) + MIN(1.25*dz(k)/200., 2.0))THEN
7264 Wn = DOWNW(K+1,I) + MIN(1.25*dz(k)/200., 2.0)
7265 ENDIF
7266 Wn = MAX(MIN(Wn,0.0), -3.0)
7268 !print *, " k =", k, " z =", ZW(k)
7269 !print *, " entw =",ENT(K,I), " Bouy =", B
7270 !print *, " downthv =", THVn, " thvk =", thvk
7271 !print *, " downthl =", THLn, " thl =", thl(k)
7272 !print *, " downqt =", QTn , " qt =", qt(k)
7273 !print *, " downw+1 =",DOWNW(K+1,I), " Wn2 =", Wn
7275 IF (Wn .lt. 0.) THEN !terminate when velocity is too small
7276 DOWNW(K,I) = Wn !-sqrt(Wn2)
7277 DOWNTHV(K,I)= THVn
7278 DOWNTHL(K,I)= THLn
7279 DOWNQT(K,I) = QTn
7280 DOWNQC(K,I) = QCn
7281 DOWNU(K,I) = Un
7282 DOWNV(K,I) = Vn
7283 DOWNA(K,I) = DOWNA(K+1,I)
7284 ELSE
7285 !plumes must go at least 2 levels
7286 if (DD_initK(I) - K .lt. 2) then
7287 DOWNW(:,I) = 0.0
7288 DOWNTHV(:,I)= 0.0
7289 DOWNTHL(:,I)= 0.0
7290 DOWNQT(:,I) = 0.0
7291 DOWNQC(:,I) = 0.0
7292 DOWNU(:,I) = 0.0
7293 DOWNV(:,I) = 0.0
7294 endif
7295 exit
7296 ENDIF
7297 ENDDO
7298 ENDDO
7299 endif ! end cloud flag
7301 DOWNW(1,:) = 0. !make sure downdraft does not go to the surface
7302 DOWNA(1,:) = 0.
7304 ! Combine both moist and dry plume, write as one averaged plume
7305 ! Even though downdraft starts at different height, average all up to qlTop
7306 DO k=qlTop,KTS,-1
7307 DO I=1,NDOWN
7308 IF (I > NDOWN) exit
7309 edmf_a_dd(K) =edmf_a_dd(K) +DOWNA(K-1,I)
7310 edmf_w_dd(K) =edmf_w_dd(K) +DOWNA(K-1,I)*DOWNW(K-1,I)
7311 edmf_qt_dd(K) =edmf_qt_dd(K) +DOWNA(K-1,I)*DOWNQT(K-1,I)
7312 edmf_thl_dd(K)=edmf_thl_dd(K)+DOWNA(K-1,I)*DOWNTHL(K-1,I)
7313 edmf_ent_dd(K)=edmf_ent_dd(K)+DOWNA(K-1,I)*ENT(K-1,I)
7314 edmf_qc_dd(K) =edmf_qc_dd(K) +DOWNA(K-1,I)*DOWNQC(K-1,I)
7315 ENDDO
7317 IF (edmf_a_dd(k) >0.) THEN
7318 edmf_w_dd(k) =edmf_w_dd(k) /edmf_a_dd(k)
7319 edmf_qt_dd(k) =edmf_qt_dd(k) /edmf_a_dd(k)
7320 edmf_thl_dd(k)=edmf_thl_dd(k)/edmf_a_dd(k)
7321 edmf_ent_dd(k)=edmf_ent_dd(k)/edmf_a_dd(k)
7322 edmf_qc_dd(k) =edmf_qc_dd(k) /edmf_a_dd(k)
7323 ENDIF
7324 ENDDO
7326 !
7327 ! computing variables needed for solver
7328 !
7330 DO k=KTS,qlTop
7331 rho_int = (rho(k)*DZ(k+1)+rho(k+1)*DZ(k))/(DZ(k+1)+DZ(k))
7332 DO I=1,NDOWN
7333 sd_aw(k) =sd_aw(k) +rho_int*DOWNA(k,i)*DOWNW(k,i)
7334 sd_awthl(k)=sd_awthl(k)+rho_int*DOWNA(k,i)*DOWNW(k,i)*DOWNTHL(k,i)
7335 sd_awqt(k) =sd_awqt(k) +rho_int*DOWNA(k,i)*DOWNW(k,i)*DOWNQT(k,i)
7336 sd_awqc(k) =sd_awqc(k) +rho_int*DOWNA(k,i)*DOWNW(k,i)*DOWNQC(k,i)
7337 sd_awu(k) =sd_awu(k) +rho_int*DOWNA(k,i)*DOWNW(k,i)*DOWNU(k,i)
7338 sd_awv(k) =sd_awv(k) +rho_int*DOWNA(k,i)*DOWNW(k,i)*DOWNV(k,i)
7339 ENDDO
7340 sd_awqv(k) = sd_awqt(k) - sd_awqc(k)
7341 ENDDO
7343 END SUBROUTINE DDMF_JPL
7344 !===============================================================
7347 SUBROUTINE SCALE_AWARE(dx,PBL1,Psig_bl,Psig_shcu)
7349 !---------------------------------------------------------------
7350 ! NOTES ON SCALE-AWARE FORMULATION
7351 !
7352 !JOE: add scale-aware factor (Psig) here, taken from Honnert et al. (2011,
7353 ! JAS) and/or from Hyeyum Hailey Shin and Song-You Hong (2013, JAS)
7354 !
7355 ! Psig_bl tapers local mixing
7356 ! Psig_shcu tapers nonlocal mixing
7358 REAL,INTENT(IN) :: dx,PBL1
7359 REAL, INTENT(OUT) :: Psig_bl,Psig_shcu
7360 REAL :: dxdh
7362 Psig_bl=1.0
7363 Psig_shcu=1.0
7364 dxdh=MAX(2.5*dx,10.)/MIN(PBL1,3000.)
7365 ! Honnert et al. 2011, TKE in PBL *** original form used until 201605
7366 !Psig_bl= ((dxdh**2) + 0.07*(dxdh**0.667))/((dxdh**2) + &
7367 ! (3./21.)*(dxdh**0.67) + (3./42.))
7368 ! Honnert et al. 2011, TKE in entrainment layer
7369 !Psig_bl= ((dxdh**2) + (4./21.)*(dxdh**0.667))/((dxdh**2) + &
7370 ! (3./20.)*(dxdh**0.67) + (7./21.))
7371 ! New form to preseve parameterized mixing - only down 5% at dx = 750 m
7372 Psig_bl= ((dxdh**2) + 0.106*(dxdh**0.667))/((dxdh**2) +0.066*(dxdh**0.667) + 0.071)
7374 !assume a 500 m cloud depth for shallow-cu clods
7375 dxdh=MAX(2.5*dx,10.)/MIN(PBL1+500.,3500.)
7376 ! Honnert et al. 2011, TKE in entrainment layer *** original form used until 201605
7377 !Psig_shcu= ((dxdh**2) + (4./21.)*(dxdh**0.667))/((dxdh**2) + &
7378 ! (3./20.)*(dxdh**0.67) + (7./21.))
7380 ! Honnert et al. 2011, TKE in cumulus
7381 !Psig(i)= ((dxdh**2) + 1.67*(dxdh**1.4))/((dxdh**2) +1.66*(dxdh**1.4) +
7382 !0.2)
7384 ! Honnert et al. 2011, w'q' in PBL
7385 !Psig(i)= 0.5 + 0.5*((dxdh**2) + 0.03*(dxdh**1.4) -
7386 !(4./13.))/((dxdh**2) + 0.03*(dxdh**1.4) + (4./13.))
7387 ! Honnert et al. 2011, w'q' in cumulus
7388 !Psig(i)= ((dxdh**2) - 0.07*(dxdh**1.4))/((dxdh**2) -0.07*(dxdh**1.4) +
7389 !0.02)
7391 ! Honnert et al. 2011, q'q' in PBL
7392 !Psig(i)= 0.5 + 0.5*((dxdh**2) + 0.25*(dxdh**0.667) -0.73)/((dxdh**2)
7393 !-0.03*(dxdh**0.667) + 0.73)
7394 ! Honnert et al. 2011, q'q' in cumulus
7395 !Psig(i)= ((dxdh**2) - 0.34*(dxdh**1.4))/((dxdh**2) - 0.35*(dxdh**1.4)
7396 !+ 0.37)
7398 ! Hyeyum Hailey Shin and Song-You Hong 2013, TKE in PBL (same as Honnert's above)
7399 !Psig_shcu= ((dxdh**2) + 0.070*(dxdh**0.667))/((dxdh**2)
7400 !+0.142*(dxdh**0.667) + 0.071)
7401 ! Hyeyum Hailey Shin and Song-You Hong 2013, TKE in entrainment zone *** switch to this form 201605
7402 Psig_shcu= ((dxdh**2) + 0.145*(dxdh**0.667))/((dxdh**2) +0.172*(dxdh**0.667) + 0.170)
7404 ! Hyeyum Hailey Shin and Song-You Hong 2013, w'theta' in PBL
7405 !Psig(i)= 0.5 + 0.5*((dxdh**2) -0.098)/((dxdh**2) + 0.106)
7406 ! Hyeyum Hailey Shin and Song-You Hong 2013, w'theta' in entrainment zone
7407 !Psig(i)= 0.5 + 0.5*((dxdh**2) - 0.112*(dxdh**0.25) -0.071)/((dxdh**2)
7408 !+ 0.054*(dxdh**0.25) + 0.10)
7410 !print*,"in scale_aware; dx, dxdh, Psig(i)=",dx,dxdh,Psig(i)
7411 !If(Psig_bl(i) < 0.0 .OR. Psig(i) > 1.)print*,"dx, dxdh, Psig(i)=",dx,dxdh,Psig_bl(i)
7412 If(Psig_bl > 1.0) Psig_bl=1.0
7413 If(Psig_bl < 0.0) Psig_bl=0.0
7415 If(Psig_shcu > 1.0) Psig_shcu=1.0
7416 If(Psig_shcu < 0.0) Psig_shcu=0.0
7418 END SUBROUTINE SCALE_AWARE
7420 ! =====================================================================
7421 !>\ingroup gsd_mynn_edmf
7422 !! \author JAYMES- added 22 Apr 2015
7423 !! This function calculates saturation vapor pressure. Separate ice and liquid functions
7424 !! are used (identical to those in module_mp_thompson.F, v3.6). Then, the
7425 !! final returned value is a temperature-dependant "blend". Because the final
7426 !! value is "phase-aware", this formulation may be preferred for use throughout
7427 !! the module (replacing "svp").
7428 FUNCTION esat_blend(t)
7430 IMPLICIT NONE
7432 REAL, INTENT(IN):: t
7433 REAL :: esat_blend,XC,ESL,ESI,chi
7435 XC=MAX(-80.,t - t0c) !note t0c = 273.15, tice is set in module mynn_common
7437 ! For 253 < t < 273.16 K, the vapor pressures are "blended" as a function of temperature,
7438 ! using the approach of Chaboureau and Bechtold (2002), JAS, p. 2363. The resulting
7439 ! values are returned from the function.
7440 IF (t .GE. t0c) THEN
7441 esat_blend = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8)))))))
7442 ELSE IF (t .LE. tice) THEN
7443 esat_blend = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8)))))))
7444 ELSE
7445 ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8)))))))
7446 ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8)))))))
7447 chi = (t0c - t)/(t0c - tice)
7448 esat_blend = (1.-chi)*ESL + chi*ESI
7449 END IF
7451 END FUNCTION esat_blend
7453 ! ====================================================================
7455 !>\ingroup gsd_mynn_edmf
7456 !! This function extends function "esat" and returns a "blended"
7457 !! saturation mixing ratio.
7458 !!\author JAYMES
7459 FUNCTION qsat_blend(t, P, waterice)
7461 IMPLICIT NONE
7463 REAL, INTENT(IN):: t, P
7464 CHARACTER(LEN=1), OPTIONAL, INTENT(IN) :: waterice
7465 CHARACTER(LEN=1) :: wrt
7466 REAL :: qsat_blend,XC,ESL,ESI,RSLF,RSIF,chi
7468 IF ( .NOT. PRESENT(waterice) ) THEN
7469 wrt = 'b'
7470 ELSE
7471 wrt = waterice
7472 ENDIF
7474 XC=MAX(-80.,t - t0c)
7476 IF ((t .GE. t0c) .OR. (wrt .EQ. 'w')) THEN
7477 ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8)))))))
7478 qsat_blend = 0.622*ESL/max(P-ESL, 1e-5)
7479 ! ELSE IF (t .LE. 253.) THEN
7480 ELSE IF (t .LE. tice) THEN
7481 ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8)))))))
7482 qsat_blend = 0.622*ESI/max(P-ESI, 1e-5)
7483 ELSE
7484 ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8)))))))
7485 ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8)))))))
7486 RSLF = 0.622*ESL/max(P-ESL, 1e-5)
7487 RSIF = 0.622*ESI/max(P-ESI, 1e-5)
7488 ! chi = (273.16-t)/20.16
7489 chi = (t0c - t)/(t0c - tice)
7490 qsat_blend = (1.-chi)*RSLF + chi*RSIF
7491 END IF
7493 END FUNCTION qsat_blend
7495 ! ===================================================================
7497 !>\ingroup gsd_mynn_edmf
7498 !! This function interpolates the latent heats of vaporization and sublimation into
7499 !! a single, temperature-dependent, "blended" value, following
7500 !! Chaboureau and Bechtold (2002) \cite Chaboureau_2002, Appendix.
7501 !!\author JAYMES
7502 FUNCTION xl_blend(t)
7504 IMPLICIT NONE
7506 REAL, INTENT(IN):: t
7507 REAL :: xl_blend,xlvt,xlst,chi
7508 !note: t0c = 273.15, tice is set in mynn_common
7510 IF (t .GE. t0c) THEN
7511 xl_blend = xlv + (cpv-cliq)*(t-t0c) !vaporization/condensation
7512 ELSE IF (t .LE. tice) THEN
7513 xl_blend = xls + (cpv-cice)*(t-t0c) !sublimation/deposition
7514 ELSE
7515 xlvt = xlv + (cpv-cliq)*(t-t0c) !vaporization/condensation
7516 xlst = xls + (cpv-cice)*(t-t0c) !sublimation/deposition
7517 ! chi = (273.16-t)/20.16
7518 chi = (t0c - t)/(t0c - tice)
7519 xl_blend = (1.-chi)*xlvt + chi*xlst !blended
7520 END IF
7522 END FUNCTION xl_blend
7524 ! ===================================================================
7526 FUNCTION phim(zet)
7527 ! New stability function parameters for momentum (Puhales, 2020, WRF 4.2.1)
7528 ! The forms in unstable conditions (z/L < 0) use Grachev et al. (2000), which are a blend of
7529 ! the classical (Kansas) forms (i.e., Paulson 1970, Dyer and Hicks 1970), valid for weakly
7530 ! unstable conditions (-1 < z/L < 0). The stability functions for stable conditions use an
7531 ! updated form taken from Cheng and Brutsaert (2005), which extends the validity into very
7532 ! stable conditions [z/L ~ O(10)].
7533 IMPLICIT NONE
7535 REAL, INTENT(IN):: zet
7536 REAL :: dummy_0,dummy_1,dummy_11,dummy_2,dummy_22,dummy_3,dummy_33,dummy_4,dummy_44,dummy_psi
7537 REAL, PARAMETER :: am_st=6.1, bm_st=2.5, rbm_st=1./bm_st
7538 REAL, PARAMETER :: ah_st=5.3, bh_st=1.1, rbh_st=1./bh_st
7539 REAL, PARAMETER :: am_unst=10., ah_unst=34.
7540 REAL :: phi_m,phim
7542 if ( zet >= 0.0 ) then
7543 dummy_0=1+zet**bm_st
7544 dummy_1=zet+dummy_0**(rbm_st)
7545 dummy_11=1+dummy_0**(rbm_st-1)*zet**(bm_st-1)
7546 dummy_2=(-am_st/dummy_1)*dummy_11
7547 phi_m = 1-zet*dummy_2
7548 else
7549 dummy_0 = (1.0-cphm_unst*zet)**0.25
7550 phi_m = 1./dummy_0
7551 dummy_psi = 2.*log(0.5*(1.+dummy_0))+log(0.5*(1.+dummy_0**2))-2.*atan(dummy_0)+1.570796
7553 dummy_0=(1.-am_unst*zet) ! parentesis arg
7554 dummy_1=dummy_0**0.333333 ! y
7555 dummy_11=-0.33333*am_unst*dummy_0**(-0.6666667) ! dy/dzet
7556 dummy_2 = 0.33333*(dummy_1**2.+dummy_1+1.) ! f
7557 dummy_22 = 0.3333*dummy_11*(2.*dummy_1+1.) ! df/dzet
7558 dummy_3 = 0.57735*(2.*dummy_1+1.) ! g
7559 dummy_33 = 1.1547*dummy_11 ! dg/dzet
7560 dummy_4 = 1.5*log(dummy_2)-1.73205*atan(dummy_3)+1.813799364 !psic
7561 dummy_44 = (1.5/dummy_2)*dummy_22-1.73205*dummy_33/(1.+dummy_3**2)! dpsic/dzet
7563 dummy_0 = zet**2
7564 dummy_1 = 1./(1.+dummy_0) ! denon
7565 dummy_11 = 2.*zet ! denon/dzet
7566 dummy_2 = ((1-phi_m)/zet+dummy_11*dummy_4+dummy_0*dummy_44)*dummy_1
7567 dummy_22 = -dummy_11*(dummy_psi+dummy_0*dummy_4)*dummy_1**2
7569 phi_m = 1.-zet*(dummy_2+dummy_22)
7570 end if
7572 !phim = phi_m - zet
7573 phim = phi_m
7575 END FUNCTION phim
7576 ! ===================================================================
7578 FUNCTION phih(zet)
7579 ! New stability function parameters for heat (Puhales, 2020, WRF 4.2.1)
7580 ! The forms in unstable conditions (z/L < 0) use Grachev et al. (2000), which are a blend of
7581 ! the classical (Kansas) forms (i.e., Paulson 1970, Dyer and Hicks 1970), valid for weakly
7582 ! unstable conditions (-1 < z/L < 0). The stability functions for stable conditions use an
7583 ! updated form taken from Cheng and Brutsaert (2005), which extends the validity into very
7584 ! stable conditions [z/L ~ O(10)].
7585 IMPLICIT NONE
7587 REAL, INTENT(IN):: zet
7588 REAL :: dummy_0,dummy_1,dummy_11,dummy_2,dummy_22,dummy_3,dummy_33,dummy_4,dummy_44,dummy_psi
7589 REAL, PARAMETER :: am_st=6.1, bm_st=2.5, rbm_st=1./bm_st
7590 REAL, PARAMETER :: ah_st=5.3, bh_st=1.1, rbh_st=1./bh_st
7591 REAL, PARAMETER :: am_unst=10., ah_unst=34.
7592 REAL :: phh,phih
7594 if ( zet >= 0.0 ) then
7595 dummy_0=1+zet**bh_st
7596 dummy_1=zet+dummy_0**(rbh_st)
7597 dummy_11=1+dummy_0**(rbh_st-1)*zet**(bh_st-1)
7598 dummy_2=(-ah_st/dummy_1)*dummy_11
7599 phih = 1-zet*dummy_2
7600 else
7601 dummy_0 = (1.0-cphh_unst*zet)**0.5
7602 phh = 1./dummy_0
7603 dummy_psi = 2.*log(0.5*(1.+dummy_0))
7605 dummy_0=(1.-ah_unst*zet) ! parentesis arg
7606 dummy_1=dummy_0**0.333333 ! y
7607 dummy_11=-0.33333*ah_unst*dummy_0**(-0.6666667) ! dy/dzet
7608 dummy_2 = 0.33333*(dummy_1**2.+dummy_1+1.) ! f
7609 dummy_22 = 0.3333*dummy_11*(2.*dummy_1+1.) ! df/dzet
7610 dummy_3 = 0.57735*(2.*dummy_1+1.) ! g
7611 dummy_33 = 1.1547*dummy_11 ! dg/dzet
7612 dummy_4 = 1.5*log(dummy_2)-1.73205*atan(dummy_3)+1.813799364 !psic
7613 dummy_44 = (1.5/dummy_2)*dummy_22-1.73205*dummy_33/(1.+dummy_3**2)! dpsic/dzet
7615 dummy_0 = zet**2
7616 dummy_1 = 1./(1.+dummy_0) ! denon
7617 dummy_11 = 2.*zet ! ddenon/dzet
7618 dummy_2 = ((1-phh)/zet+dummy_11*dummy_4+dummy_0*dummy_44)*dummy_1
7619 dummy_22 = -dummy_11*(dummy_psi+dummy_0*dummy_4)*dummy_1**2
7621 phih = 1.-zet*(dummy_2+dummy_22)
7622 end if
7624 END FUNCTION phih
7625 ! ==================================================================
7626 SUBROUTINE topdown_cloudrad(kts,kte,dz1,zw,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, dimension(kts:kte), intent(in) :: dz1,sqc,sqi,sqw,&
7634 thl,th1,ex1,p1,rho1,thetav,cldfra_bl1D,rthraten
7635 real, dimension(kts:kte+1), intent(in) :: zw
7636 real, intent(in) :: pblh,xland
7637 integer,intent(in) :: kpbl
7638 !output
7639 real, intent(out) :: maxKHtopdown
7640 real, dimension(kts:kte), intent(out) :: KHtopdown,TKEprodTD
7641 !local
7642 real, dimension(kts:kte) :: zfac,wscalek2,zfacent
7643 real :: bfx0,sflux,wm2,wm3,h1,h2,bfxpbl,dthvx,tmp1
7644 real :: temps,templ,zl1,wstar3_2
7645 real :: ent_eff,radsum,radflux,we,rcldb,rvls,minrad,zminrad
7646 real, parameter :: pfac =2.0, zfmin = 0.01, phifac=8.0
7647 integer :: k,kk,kminrad
7648 logical :: cloudflg
7650 cloudflg=.false.
7651 minrad=100.
7652 kminrad=kpbl
7653 zminrad=PBLH
7654 KHtopdown(kts:kte)=0.0
7655 TKEprodTD(kts:kte)=0.0
7656 maxKHtopdown=0.0
7658 !CHECK FOR STRATOCUMULUS-TOPPED BOUNDARY LAYERS
7659 DO kk = MAX(1,kpbl-2),kpbl+3
7660 if (sqc(kk).gt. 1.e-6 .OR. sqi(kk).gt. 1.e-6 .OR. &
7661 cldfra_bl1D(kk).gt.0.5) then
7662 cloudflg=.true.
7663 endif
7664 if (rthraten(kk) < minrad)then
7665 minrad=rthraten(kk)
7666 kminrad=kk
7667 zminrad=zw(kk) + 0.5*dz1(kk)
7668 endif
7669 ENDDO
7671 IF (MAX(kminrad,kpbl) < 2)cloudflg = .false.
7672 IF (cloudflg) THEN
7673 zl1 = dz1(kts)
7674 k = MAX(kpbl-1, kminrad-1)
7675 !Best estimate of height of TKE source (top of downdrafts):
7676 !zminrad = 0.5*pblh(i) + 0.5*zminrad
7678 templ=thl(k)*ex1(k)
7679 !rvls is ws at full level
7680 rvls=100.*6.112*EXP(17.67*(templ-273.16)/(templ-29.65))*(ep_2/p1(k+1))
7681 temps=templ + (sqw(k)-rvls)/(cp/xlv + ep_2*xlv*rvls/(r_d*templ**2))
7682 rvls=100.*6.112*EXP(17.67*(temps-273.15)/(temps-29.65))*(ep_2/p1(k+1))
7683 rcldb=max(sqw(k)-rvls,0.)
7685 !entrainment efficiency
7686 dthvx = (thl(k+2) + th1(k+2)*p608*sqw(k+2)) &
7687 - (thl(k) + th1(k) *p608*sqw(k))
7688 dthvx = max(dthvx,0.1)
7689 tmp1 = xlvcp * rcldb/(ex1(k)*dthvx)
7690 !Originally from Nichols and Turton (1986), where a2 = 60, but lowered
7691 !here to 8, as in Grenier and Bretherton (2001).
7692 ent_eff = 0.2 + 0.2*8.*tmp1
7694 radsum=0.
7695 DO kk = MAX(1,kpbl-3),kpbl+3
7696 radflux=rthraten(kk)*ex1(kk) !converts theta/s to temp/s
7697 radflux=radflux*cp/grav*(p1(kk)-p1(kk+1)) ! converts temp/s to W/m^2
7698 if (radflux < 0.0 ) radsum=abs(radflux)+radsum
7699 ENDDO
7701 !More strict limits over land to reduce stable-layer mixouts
7702 if ((xland-1.5).GE.0)THEN ! WATER
7703 radsum=MIN(radsum,90.0)
7704 bfx0 = max(radsum/rho1(k)/cp,0.)
7705 else ! LAND
7706 radsum=MIN(0.25*radsum,30.0)!practically turn off over land
7707 bfx0 = max(radsum/rho1(k)/cp - max(sflux,0.0),0.)
7708 endif
7710 !entrainment from PBL top thermals
7711 wm3 = grav/thetav(k)*bfx0*MIN(pblh,1500.) ! this is wstar3(i)
7712 wm2 = wm2 + wm3**h2
7713 bfxpbl = - ent_eff * bfx0
7714 dthvx = max(thetav(k+1)-thetav(k),0.1)
7715 we = max(bfxpbl/dthvx,-sqrt(wm3**h2))
7717 DO kk = kts,kpbl+3
7718 !Analytic vertical profile
7719 zfac(kk) = min(max((1.-(zw(kk+1)-zl1)/(zminrad-zl1)),zfmin),1.)
7720 zfacent(kk) = 10.*MAX((zminrad-zw(kk+1))/zminrad,0.0)*(1.-zfac(kk))**3
7722 !Calculate an eddy diffusivity profile (not used at the moment)
7723 wscalek2(kk) = (phifac*karman*wm3*(zfac(kk)))**h1
7724 !Modify shape of Kh to be similar to Lock et al (2000): use pfac = 3.0
7725 KHtopdown(kk) = wscalek2(kk)*karman*(zminrad-zw(kk+1))*(1.-zfac(kk))**3 !pfac
7726 KHtopdown(kk) = MAX(KHtopdown(kk),0.0)
7728 !Calculate TKE production = 2(g/TH)(w'TH'), where w'TH' = A(TH/g)wstar^3/PBLH,
7729 !A = ent_eff, and wstar is associated with the radiative cooling at top of PBL.
7730 !An analytic profile controls the magnitude of this TKE prod in the vertical.
7731 TKEprodTD(kk)=2.*ent_eff*wm3/MAX(pblh,100.)*zfacent(kk)
7732 TKEprodTD(kk)= MAX(TKEprodTD(kk),0.0)
7733 ENDDO
7734 ENDIF !end cloud check
7735 maxKHtopdown=MAXVAL(KHtopdown(:))
7737 END SUBROUTINE topdown_cloudrad
7738 ! ==================================================================
7739 ! ===================================================================
7740 ! ===================================================================
7742 END MODULE module_bl_mynn