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