v7.0.0/sci_doc/module__bl__mynn_8_f90_source.html

! **********************************************************************

! *   An improved Mellor-Yamada turbulence closure model               *

! *                                                                    *

! *      Original author: M. Nakanishi (N.D.A), naka@nda.ac.jp         *

! *      Translated into F90 and implemented in WRF-ARW by:            *

! *                       Mariusz Pagowski (NOAA-GSL)                  *

! *      Subsequently developed by:                                    *

! *                 Joseph Olson, Jaymes Kenyon (NOAA/GSL),            *

! *                 Wayne Angevine (NOAA/CSL), Kay Suselj (NASA/JPL),  *

! *                 Franciano Puhales (UFSM), Laura Fowler (NCAR),     *

! *                 Elynn Wu (UCSD), and Jordan Schnell (NOAA/GSL)     *

! *                                                                    *

! *   Contents:                                                        *

! *                                                                    *

! *   mynn_bl_driver - main subroutine which calls all other routines  *

! *   --------------                                                   *

! *     1. mym_initialize  (to be called once initially)               *

! *        gives the closure constants and initializes the turbulent   *

! *        quantities.                                                 *

! *     2. get_pblh                                                    *

! *        Calculates the boundary layer height                        *

! *     3. scale_aware                                                 *

! *        Calculates scale-adaptive tapering functions                *

! *     4. mym_condensation                                            *

! *        determines the liquid water content and the cloud fraction  *

! *        diagnostically.                                             *

! *     5. dmp_mf                                                      *

! *        Calls the (nonlocal) mass-flux component                    *

! *     6. ddmf_jpl                                                    *

! *        Calls the downdraft mass-flux component                     *

! *    (-) mym_level2      (called in the other subroutines)           *

! *        calculates the stability functions at Level 2.              *

! *    (-) mym_length      (called in the other subroutines)           *

! *        calculates the master length scale.                         *

! *     7. mym_turbulence                                              *

! *        calculates the vertical diffusivity coefficients and the    *

! *        production terms for the turbulent quantities.              *

! *     8. mym_predict                                                 *

! *        predicts the turbulent quantities at the next step.         *

! *                                                                    *

! *             call mym_initialize                                    *

! *                  |                                                 *

! *                  |<----------------+                               *

! *                  |                 |                               *

! *             call get_pblh          |                               *

! *             call scale_aware       |                               *

! *             call mym_condensation  |                               *

! *             call dmp_mf            |                               *

! *             call ddmf_jpl          |                               *

! *             call mym_turbulence    |                               *

! *             call mym_predict       |                               *

! *                  |                 |                               *

! *                  |-----------------+                               *

! *                  |                                                 *

! *                 end                                                *

! *                                                                    *

! *   Variables worthy of special mention:                             *

! *     tref   : Reference temperature                                 *

! *     thl    : Liquid water potential temperature                    *

! *     qw     : Total water (water vapor+liquid water) content        *

! *     ql     : Liquid water content                                  *

! *     vt, vq : Functions for computing the buoyancy flux             *

! *     qke    : 2 * TKE                                               *

! *     el     : mixing length                                         *

! *                                                                    *

! *     If the water contents are unnecessary, e.g., in the case of    *

! *     ocean models, thl is the potential temperature and qw, ql, vt  *

! *     and vq are all zero.                                           *

! *                                                                    *

! *   Grid arrangement:                                                *

! *             k+1 +---------+                                        *

! *                 |         |     i = 1 - nx                         *

! *             (k) |    *    |     k = 1 - nz                         *

! *                 |         |                                        *

! *              k  +---------+                                        *

! *                 i   (i)  i+1                                       *

! *                                                                    *

! *     All the predicted variables are defined at the center (*) of   *

! *     the grid boxes. The diffusivity coefficients and two of their  *

! *     components (el and stability functions sh & sm) are, however,  *

! *     defined on the walls of the grid boxes.                        *

! *     # Upper boundary values are given at k=nz.                     *

! *                                                                    *

! *   References:                                                      *

! *     1. Nakanishi, M., 2001:                                        *

! *        Boundary-Layer Meteor., 99, 349-378.                        *

! *     2. Nakanishi, M. and H. Niino, 2004:                           *

! *        Boundary-Layer Meteor., 112, 1-31.                          *

! *     3. Nakanishi, M. and H. Niino, 2006:                           *

! *        Boundary-Layer Meteor., 119, 397-407.                       *

! *     4. Nakanishi, M. and H. Niino, 2009:                           *

! *        Jour. Meteor. Soc. Japan, 87, 895-912.                      *

! *     5. Olson J. and coauthors, 2019: A description of the          *

! *        MYNN-EDMF scheme and coupling to other components in        *

! *        WRF-ARW. NOAA Tech. Memo. OAR GSD, 61, 37 pp.,              *

! *        https://doi.org/10.25923/n9wm-be49.                         *

! *     6. Puhales, Franciano S. and coauthors, 2020: Turbulent        *

! *        Kinetic Energy Budget for MYNN-EDMF PBL Scheme in WRF model.*

! *        Universidade Federal de Santa Maria Technical Note. 9 pp.   *

! **********************************************************************

! ==================================================================

! Notes on original implementation into WRF-ARW

! changes to original code:

! 1. code is 1D (in z)

! 2. option to advect TKE, but not the covariances and variances

! 3. Cranck-Nicholson replaced with the implicit scheme

! 4. removed terrain-dependent grid since input in WRF in actual

!    distances in z[m]

! 5. cosmetic changes to adhere to WRF standard (remove common blocks,

!            intent etc)

!-------------------------------------------------------------------

! Further modifications post-implementation

!

! 1. Addition of BouLac mixing length in the free atmosphere.

! 2. Changed the turbulent mixing length to be integrated from the

!    surface to the top of the BL + a transition layer depth.

! v3.4.1:    Option to use Kitamura/Canuto modification which removes

!            the critical Richardson number and negative TKE (default).

!            Hybrid PBL height diagnostic, which blends a theta-v-based

!            definition in neutral/convective BL and a TKE-based definition

!            in stable conditions.

!            TKE budget output option

! v3.5.0:    TKE advection option (bl_mynn_tkeadvect)

! v3.5.1:    Fog deposition related changes.

! v3.6.0:    Removed fog deposition from the calculation of tendencies

!            Added mixing of qc, qi, qni

!            Added output for wstar, delta, TKE_PBL, & KPBL for correct

!                   coupling to shcu schemes

! v3.8.0:    Added subgrid scale cloud output for coupling to radiation

!            schemes (activated by setting icloud_bl =1 in phys namelist).

!            Added WRF_DEBUG prints (at level 3000)

!            Added Tripoli and Cotton (1981) correction.

!            Added namelist option bl_mynn_cloudmix to test effect of mixing

!                cloud species (default = 1: on).

!            Added mass-flux option (bl_mynn_edmf, = 1 for DMP mass-flux, 0: off).

!                Related options:

!                 bl_mynn_edmf_mom = 1 : activate momentum transport in MF scheme

!                 bl_mynn_edmf_tke = 1 : activate TKE transport in MF scheme

!            Added mixing length option (bl_mynn_mixlength, see notes below)

!            Added more sophisticated saturation checks, following Thompson scheme

!            Added new cloud PDF option (bl_mynn_cloudpdf = 2) from Chaboureau

!                and Bechtold (2002, JAS, with mods)

!            Added capability to mix chemical species when env variable

!                WRF_CHEM = 1, thanks to Wayne Angevine.

!            Added scale-aware mixing length, following Junshi Ito's work

!                Ito et al. (2015, BLM).

! v3.9.0    Improvement to the mass-flux scheme (dynamic number of plumes,

!                better plume/cloud depth, significant speed up, better cloud

!                fraction).

!            Added Stochastic Parameter Perturbation (SPP) implementation.

!            Many miscellaneous tweaks to the mixing lengths and stratus

!                component of the subgrid clouds.

! v.4.0      Removed or added alternatives to WRF-specific functions/modules

!                for the sake of portability to other models.

!                the sake of portability to other models.

!            Further refinement of mass-flux scheme from SCM experiments with

!                Wayne Angevine: switch to linear entrainment and back to

!                Simpson and Wiggert-type w-equation.

!            Addition of TKE production due to radiation cooling at top of

!                clouds (proto-version); not activated by default.

!            Some code rewrites to move if-thens out of loops in an attempt to

!                improve computational efficiency.

!            New tridiagonal solver, which is supposedly 14% faster and more

!                conservative. Impact seems very small.

!            Many miscellaneous tweaks to the mixing lengths and stratus

!                component of the subgrid-scale (SGS) clouds.

! v4.1       Big improvements in downward SW radiation due to revision of subgrid clouds

!                - better cloud fraction and subgrid scale mixing ratios.

!                - may experience a small cool bias during the daytime now that high

!                  SW-down bias is greatly reduced...

!            Some tweaks to increase the turbulent mixing during the daytime for

!                bl_mynn_mixlength option 2 to alleviate cool bias (very small impact).

!            Improved ensemble spread from changes to SPP in MYNN

!                - now perturbing eddy diffusivity and eddy viscosity directly

!                - now perturbing background rh (in SGS cloud calc only)

!                - now perturbing entrainment rates in mass-flux scheme

!            Added IF checks (within IFDEFS) to protect mixchem code from being used

!                when HRRR smoke is used (no impact on regular non-wrf chem use)

!            Important bug fix for wrf chem when transporting chemical species in MF scheme

!            Removed 2nd mass-flux scheme (no only bl_mynn_edmf = 1, no option 2)

!            Removed unused stochastic code for mass-flux scheme

!            Changed mass-flux scheme to be integrated on interface levels instead of

!                mass levels - impact is small

!            Added option to mix 2nd moments in MYNN as opposed to the scalar_pblmix option.

!                - activated with bl_mynn_mixscalars = 1; this sets scalar_pblmix = 0

!                - added tridagonal solver used in scalar_pblmix option to duplicate tendencies

!                - this alone changes the interface call considerably from v4.0.

!            Slight revision to TKE production due to radiation cooling at top of clouds

!            Added the non-Guassian buoyancy flux function of Bechtold and Siebesma (1998, JAS).

!                - improves TKE in SGS clouds

!            Added heating due to dissipation of TKE (small impact, maybe + 0.1 C daytime PBL temp)

!            Misc changes made for FV3/MPAS compatibility

! v4.2       A series of small tweaks to help reduce a cold bias in the PBL:

!                - slight increase in diffusion in convective conditions

!                - relaxed criteria for mass-flux activation/strength

!                - added capability to cycle TKE for continuity in hourly updating HRRR

!                - added effects of compensational environmental subsidence in mass-flux scheme,

!                  which resulted in tweaks to detrainment rates.

!            Bug fix for diagnostic-decay of SGS clouds - noticed by Greg Thompson. This has

!                a very small, but primarily  positive, impact on SW-down biases.

!            Tweak to calculation of KPBL - urged by Laura Fowler - to make more intuitive.

!            Tweak to temperature range of blending for saturation check (water to ice). This

!                slightly reduces excessive SGS clouds in polar region. No impact warm clouds.

!            Added namelist option bl_mynn_output (0 or 1) to suppress or activate the

!                allocation and output of 10 3D variables. Most people will want this

!                set to 0 (default) to save memory and disk space.

!            Added new array qi_bl as opposed to using qc_bl for both SGS qc and qi. This

!                gives us more control of the magnitudes which can be confounded by using

!                a single array. As a results, many subroutines needed to be modified,

!                especially mym_condensation.

!            Added the blending of the stratus component of the SGS clouds to the mass-flux

!                clouds to account for situations where stratus and cumulus may exist in the

!                grid cell.

!            Misc small-impact bugfixes:

!                1) dz was incorrectly indexed in mym_condensation

!                2) configurations with icloud_bl = 0 were using uninitialized arrays

! v4.5 / CCPP

!            This version includes many modifications that proved valuable in the global

!            framework and removes some key lingering bugs in the mixing of chemical species.

!            TKE Budget output fixed (Puhales, 2020-12)

!            New option for stability function: (Puhales, 2020-12)

!                bl_mynn_stfunc = 0 (original, Kansas-type function, Paulson, 1970 )

!                bl_mynn_stfunc = 1 (expanded range, same as used for Jimenez et al (MWR)

!                see the Technical Note for this implementation (small impact).

!            Improved conservation of momentum and higher-order moments.

!            Important bug fixes for mixing of chemical species.

!            Addition of pressure-gradient effects on updraft momentum transport.

!            Addition of bl_mynn_closure option = 2.5, 2.6, or 3.0

!            Addition of higher-order moments for sigma when using

!                bl_mynn_cloudpdf = 2 (Chab-Becht).

!            Removed WRF_CHEM dependencies.

!            Many miscellaneous tweaks.

! v4.5.2 / CCPP

!            Some code optimization. Removed many conditions from loops. Redesigned the mass-

!                flux scheme to use 8 plumes instead of a variable n plumes. This results in

!                the removal of the output variable "nudprafts" and adds maxwidth and ztop_plume.

!            Revision option bl_mynn_cloudpdf = 2, which now ensures cloud fractions for all

!                optically relevant mixing ratios (tip from Greg Thompson). Also, added flexibility

!                for tuning near-surface cloud fractions to remove excess fog/low ceilings.

!            Now outputs all SGS cloud mixing ratios as grid-mean values, not in-cloud. This

!                results in a change in the pre-radiation code to no longer multiply mixing ratios

!                by cloud fractions.

!            Lots of code cleanup: removal of test code, comments, changing text case, etc.

!            Many misc tuning/tweaks.

!

! Many of these changes are now documented in references listed above.

!====================================================================


MODULE module_bl_mynn


  use bl_mynn_common,only: &

        cp        , cpv       , cliq       , cice      , &

        p608      , ep_2      , ep_3       , gtr       , &

        grav      , g_inv     , karman     , p1000mb   , &

        rcp       , r_d       , r_v        , rk        , &

        rvovrd    , svp1      , svp2       , svp3      , &

        xlf       , xlv       , xls        , xlscp     , &

        xlvcp     , tv0       , tv1        , tref      , &

        zero      , half      , one        , two       , &

        onethird  , twothirds , tkmin      , t0c       , &

        tice      , kind_phys


  IMPLICIT NONE


!===================================================================

! From here on, these are MYNN-specific parameters:

! The parameters below depend on stability functions of module_sf_mynn.

  real(kind_phys), parameter :: cphm_st=5.0, cphm_unst=16.0, &

                                cphh_st=5.0, cphh_unst=16.0


! Closure constants

  real(kind_phys), parameter ::  &

       &pr  =  0.74,             &

       &g1  =  0.235,            &  ! NN2009 = 0.235

       &b1  = 24.0,              &

       &b2  = 15.0,              &  ! CKmod     NN2009

       &c2  =  0.729,            &  ! 0.729, & !0.75, &

       &c3  =  0.340,            &  ! 0.340, & !0.352, &

       &c4  =  0.0,              &

       &c5  =  0.2,              &

       &a1  = b1*( 1.0-3.0*g1 )/6.0, &

!       &c1  = g1 -1.0/( 3.0*a1*b1**(1.0/3.0) ), &

       &c1  = g1 -1.0/( 3.0*a1*2.88449914061481660), &

       &a2  = a1*( g1-c1 )/( g1*pr ), &

       &g2  = b2/b1*( 1.0-c3 ) +2.0*a1/b1*( 3.0-2.0*c2 )


  real(kind_phys), parameter ::  &

       &cc2 =  1.0-c2,           &

       &cc3 =  1.0-c3,           &

       &e1c =  3.0*a2*b2*cc3,    &

       &e2c =  9.0*a1*a2*cc2,    &

       &e3c =  9.0*a2*a2*cc2*( 1.0-c5 ), &

       &e4c = 12.0*a1*a2*cc2,    &

       &e5c =  6.0*a1*a1


! Constants for min tke in elt integration (qmin), max z/L in els (zmax),

! and factor for eddy viscosity for TKE (Kq = Sqfac*Km):

  real(kind_phys), parameter :: qmin=0.0, zmax=1.0, sqfac=3.0

! Note that the following mixing-length constants are now specified in mym_length

!      &cns=3.5, alp1=0.23, alp2=0.3, alp3=3.0, alp4=10.0, alp5=0.2


  real(kind_phys), parameter :: gpw=5./3., qcgmin=1.e-8, qkemin=1.e-12

  real(kind_phys), parameter :: tliq = 269. !all hydrometeors are liquid when T > tliq


! Constants for cloud PDF (mym_condensation)

  real(kind_phys), parameter :: rr2=0.7071068, rrp=0.3989423


  real(kind_phys), parameter :: ckmod=1.


  real(kind_phys), parameter :: scaleaware=1.


  integer, parameter :: bl_mynn_topdown = 0

  integer, parameter :: bl_mynn_edmf_dd = 0


  integer, parameter :: dheat_opt = 1


  !Option to activate environmental subsidence in mass-flux scheme

  logical, parameter :: env_subs = .false.


  !Option to switch flux-profile relationship for surface (from Puhales et al. 2020)

  !0: use original Dyer-Hicks, 1: use Cheng-Brustaert and Blended COARE

  integer, parameter :: bl_mynn_stfunc = 1


  !option to print out more stuff for debugging purposes

  logical, parameter :: debug_code = .false.

  integer, parameter :: idbg = 23 !specific i-point to write out


  ! Used in WRF-ARW module_physics_init.F

  integer :: mynn_level


CONTAINS


! ==================================================================


  SUBROUTINE mynn_bl_driver(            &

       &initflag,restart,cycling,       &

       &delt,dz,dx,znt,                 &

       &u,v,w,th,sqv3d,sqc3d,sqi3d,     &

       &sqs3d,qnc,qni,                  &

       &qnwfa,qnifa,qnbca,ozone,        &

       &p,exner,rho,t3d,                &

       &xland,ts,qsfc,ps,               &

       &ust,ch,hfx,qfx,rmol,wspd,       &

       &uoce,voce,                      & !ocean current

       &qke,qke_adv,                    &

       &sh3d,sm3d,                      &

       &nchem,kdvel,ndvel,              & !Smoke/Chem variables

       &chem3d,vdep,smoke_dbg,          &

       &frp,emis_ant_no,                & ! JLS/RAR to adjust exchange coeffs

       &mix_chem,enh_mix,rrfs_sd,       & ! end smoke/chem variables

       &tsq,qsq,cov,                    &

       &rublten,rvblten,rthblten,       &

       &rqvblten,rqcblten,rqiblten,     &

       &rqncblten,rqniblten,rqsblten,   &

       &rqnwfablten,rqnifablten,        &

       &rqnbcablten,dozone,             &

       &exch_h,exch_m,                  &

       &pblh,kpbl,                      &

       &el_pbl,                         &

       &dqke,qwt,qshear,qbuoy,qdiss,    &

       &qc_bl,qi_bl,cldfra_bl,          &

       &bl_mynn_tkeadvect,              &

       &tke_budget,                     &

       &bl_mynn_cloudpdf,               &

       &bl_mynn_mixlength,              &

       &icloud_bl,                      &

       &closure,                        &

       &bl_mynn_edmf,                   &

       &bl_mynn_edmf_mom,               &

       &bl_mynn_edmf_tke,               &

       &bl_mynn_mixscalars,             &

       &bl_mynn_output,                 &

       &bl_mynn_cloudmix,bl_mynn_mixqt, &

       &edmf_a,edmf_w,edmf_qt,          &

       &edmf_thl,edmf_ent,edmf_qc,      &

       &sub_thl3D,sub_sqv3D,            &

       &det_thl3D,det_sqv3D,            &

       &maxwidth,maxMF,ztop_plume,      &

       &ktop_plume,                     &

       &spp_pbl,pattern_spp_pbl,        &

       &rthraten,                       &

       &FLAG_QC,FLAG_QI,FLAG_QNC,       &

       &FLAG_QNI,FLAG_QS,               &

       &FLAG_QNWFA,FLAG_QNIFA,          &

       &FLAG_QNBCA,FLAG_OZONE,          &

       &IDS,IDE,JDS,JDE,KDS,KDE,        &

       &IMS,IME,JMS,JME,KMS,KME,        &

       &ITS,ITE,JTS,JTE,KTS,KTE         )


!-------------------------------------------------------------------


    integer, intent(in) :: initflag

    !INPUT NAMELIST OPTIONS:

    logical, intent(in) :: restart,cycling

    integer, intent(in) :: tke_budget

    integer, intent(in) :: bl_mynn_cloudpdf

    integer, intent(in) :: bl_mynn_mixlength

    integer, intent(in) :: bl_mynn_edmf

    logical, intent(in) :: bl_mynn_tkeadvect

    integer, intent(in) :: bl_mynn_edmf_mom

    integer, intent(in) :: bl_mynn_edmf_tke

    integer, intent(in) :: bl_mynn_mixscalars

    integer, intent(in) :: bl_mynn_output

    integer, intent(in) :: bl_mynn_cloudmix

    integer, intent(in) :: bl_mynn_mixqt

    integer, intent(in) :: icloud_bl

    real(kind_phys), intent(in) :: closure


    logical, intent(in) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,&

                           FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA, &

                           FLAG_OZONE,FLAG_QS


    logical, intent(in) :: mix_chem,enh_mix,rrfs_sd,smoke_dbg


    integer, intent(in) ::                                   &

                         & IDS,IDE,JDS,JDE,KDS,KDE           &

                         &,IMS,IME,JMS,JME,KMS,KME           &

                         &,ITS,ITE,JTS,JTE,KTS,KTE


#ifdef HARDCODE_VERTICAL

# define kts 1

# define kte HARDCODE_VERTICAL

#endif


! initflag > 0  for TRUE

! else        for FALSE

!       closure       : <= 2.5;  Level 2.5

!                  2.5< and <3;  Level 2.6

!                        =   3;  Level 3


    real(kind_phys), intent(in) :: delt

    real(kind_phys), dimension(:),   intent(in) :: dx

    real(kind_phys), dimension(:,:), intent(in) :: dz,       &

         &u,v,w,th,sqv3D,p,exner,rho,T3D

    real(kind_phys), dimension(:,:), intent(in) ::           &

         &sqc3D,sqi3D,sqs3D,qni,qnc,qnwfa,qnifa,qnbca

    real(kind_phys), dimension(:,:), intent(in):: ozone

    real(kind_phys), dimension(:),   intent(in):: ust,       &

         &ch,qsfc,ps,wspd

    real(kind_phys), dimension(:,:), intent(inout), optional :: &

         &Qke,Tsq,Qsq,Cov

    real(kind_phys), dimension(:,:), intent(inout) ::        &

         &qke_adv

    real(kind_phys), dimension(:,:), intent(inout) ::        &

         &rublten,rvblten,rthblten,rqvblten,rqcblten,        &

         &rqiblten,rqsblten,rqniblten,rqncblten,             &

         &rqnwfablten,rqnifablten,rqnbcablten

    real(kind_phys), dimension(:,:), intent(inout) :: dozone

    real(kind_phys), dimension(:,:), intent(in)    :: rthraten


    real(kind_phys), dimension(:,:), intent(out), optional   :: exch_h,exch_m

    real(kind_phys), dimension(:),   intent(in)    :: xland, &

         &ts,znt,hfx,qfx,uoce,voce


   !These 10 arrays are only allocated when bl_mynn_output > 0

   real(kind_phys), dimension(:,:), intent(inout), optional :: &

         & edmf_a,edmf_w,edmf_qt,edmf_thl,edmf_ent,edmf_qc,  &

         & sub_thl3D,sub_sqv3D,det_thl3D,det_sqv3D


!   real, dimension(ims:ime,kms:kme)   ::                                       &

!         & edmf_a_dd,edmf_w_dd,edmf_qt_dd,edmf_thl_dd,edmf_ent_dd,edmf_qc_dd


    real(kind_phys), dimension(:), intent(inout) :: Pblh

    real(kind_phys), dimension(:), intent(inout) :: rmol


    real(kind_phys), dimension(ims:ime) :: psig_bl,psig_shcu


    integer,dimension(:),intent(INOUT) ::                    &

         &KPBL

    integer,dimension(:),intent(INOUT), optional ::                    &

         &ktop_plume


    real(kind_phys), dimension(:), intent(out), optional ::            &

         &maxmf,maxwidth,ztop_plume


    real(kind_phys), dimension(:,:), intent(inout), optional :: el_pbl


    real(kind_phys), dimension(:,:), intent(inout), optional :: &

         &qWT,qSHEAR,qBUOY,qDISS,dqke

    ! 3D budget arrays are not allocated when tke_budget == 0

    ! 1D (local) budget arrays are used for passing between subroutines.

    real(kind_phys), dimension(kts:kte) ::                   &

         &qwt1,qshear1,qbuoy1,qdiss1,dqke1,diss_heat


    real(kind_phys), dimension(:,:), intent(out), optional :: Sh3D,Sm3D


    real(kind_phys), dimension(:,:), intent(inout), optional :: &

         &qc_bl,qi_bl,cldfra_bl

    real(kind_phys), dimension(kts:kte) :: qc_bl1D,qi_bl1D,                     &

         &cldfra_bl1D,qc_bl1D_old,qi_bl1D_old,cldfra_bl1D_old


! smoke/chemical arrays

    integer, intent(IN   ) ::   nchem, kdvel, ndvel

    real(kind_phys), dimension(:,:,:), intent(INOUT), optional :: chem3d

    real(kind_phys), dimension(:,:),   intent(IN), optional    :: vdep

    real(kind_phys), dimension(:),     intent(IN), optional    :: frp

    real(kind_phys), dimension(:),     intent(IN)    :: EMIS_ANT_NO

    !local

    real(kind_phys), dimension(kts:kte  ,nchem)      :: chem1

    real(kind_phys), dimension(kts:kte+1,nchem)      :: s_awchem1

    real(kind_phys), dimension(ndvel)                :: vd1

    integer :: ic


!local vars

    integer :: ITF,JTF,KTF, IMD,JMD

    integer :: i,j,k,kproblem

    real(kind_phys), dimension(kts:kte) ::                  &

         &thl,tl,qv1,qc1,qi1,qs1,sqw,                       &

         &el, dfm, dfh, dfq, tcd, qcd, pdk, pdt, pdq, pdc,  &

         &vt, vq, sgm, kzero

    real(kind_phys), dimension(kts:kte) ::                  &

         &thetav,sh,sm,u1,v1,w1,p1,                         &

         &ex1,dz1,th1,tk1,rho1,qke1,tsq1,qsq1,cov1,         &

         &sqv,sqi,sqc,sqs,                                  &

         &du1,dv1,dth1,dqv1,dqc1,dqi1,dqs1,ozone1,          &

         &k_m1,k_h1,qni1,dqni1,qnc1,dqnc1,qnwfa1,qnifa1,    &

         &qnbca1,dqnwfa1,dqnifa1,dqnbca1,dozone1


    !mass-flux variables

    real(kind_phys), dimension(kts:kte) ::                  &

         &dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf

    real(kind_phys), dimension(kts:kte) ::                  &

         &edmf_a1,edmf_w1,edmf_qt1,edmf_thl1,               &

         &edmf_ent1,edmf_qc1

    real(kind_phys), dimension(kts:kte) ::                  &

         &edmf_a_dd1,edmf_w_dd1,edmf_qt_dd1,edmf_thl_dd1,   &

         &edmf_ent_dd1,edmf_qc_dd1

    real(kind_phys), dimension(kts:kte) ::                  &

         &sub_thl,sub_sqv,sub_u,sub_v,                      &

         &det_thl,det_sqv,det_sqc,det_u,det_v

    real(kind_phys), dimension(kts:kte+1) ::                &

         &s_aw1,s_awthl1,s_awqt1,                           &

         &s_awqv1,s_awqc1,s_awu1,s_awv1,s_awqke1,           &

         &s_awqnc1,s_awqni1,s_awqnwfa1,s_awqnifa1,          &

         &s_awqnbca1

    real(kind_phys), dimension(kts:kte+1) ::                &

         &sd_aw1,sd_awthl1,sd_awqt1,                        &

         &sd_awqv1,sd_awqc1,sd_awu1,sd_awv1,sd_awqke1


    real(kind_phys), dimension(kts:kte+1) :: zw

    real(kind_phys) :: cpm,sqcg,flt,fltv,flq,flqv,flqc,     &

         &pmz,phh,exnerg,zet,phi_m,                         &

         &afk,abk,ts_decay, qc_bl2, qi_bl2,                 &

         &th_sfc,wsp


    !top-down diffusion

    real(kind_phys), dimension(ITS:ITE) :: maxKHtopdown

    real(kind_phys), dimension(kts:kte) :: KHtopdown,TKEprodTD


    logical :: INITIALIZE_QKE,problem


    ! Stochastic fields

    integer,  intent(IN)                         :: spp_pbl

    real(kind_phys), dimension(:,:), intent(IN), optional  :: pattern_spp_pbl

    real(kind_phys), dimension(KTS:KTE)          :: rstoch_col


    ! Substepping TKE

    integer :: nsub

    real(kind_phys) :: delt2


    if (debug_code) then !check incoming values

      do i=its,ite

        problem = .false.

        do k=kts,kte

          wsp  = sqrt(u(i,k)**2 + v(i,k)**2)

          if (abs(hfx(i)) > 1200. .or. abs(qfx(i)) > 0.001 .or.         &

              wsp > 200. .or. t3d(i,k) > 360. .or. t3d(i,k) < 160. .or. &

              sqv3d(i,k)< 0.0 .or. sqc3d(i,k)< 0.0 ) then

             kproblem = k

             problem = .true.

             print*,"Incoming problem at: i=",i," k=1"

             print*," QFX=",qfx(i)," HFX=",hfx(i)

             print*," wsp=",wsp," T=",t3d(i,k)

             print*," qv=",sqv3d(i,k)," qc=",sqc3d(i,k)

             print*," u*=",ust(i)," wspd=",wspd(i)

             print*," xland=",xland(i)," ts=",ts(i)

             print*," z/L=",0.5*dz(i,1)*rmol(i)," ps=",ps(i)

             print*," znt=",znt(i)," dx=",dx(i)

          endif

        enddo

        if (problem) then

          print*,"===tk:",t3d(i,max(kproblem-3,1):min(kproblem+3,kte))

          print*,"===qv:",sqv3d(i,max(kproblem-3,1):min(kproblem+3,kte))

          print*,"===qc:",sqc3d(i,max(kproblem-3,1):min(kproblem+3,kte))

          print*,"===qi:",sqi3d(i,max(kproblem-3,1):min(kproblem+3,kte))

          print*,"====u:",u(i,max(kproblem-3,1):min(kproblem+3,kte))

          print*,"====v:",v(i,max(kproblem-3,1):min(kproblem+3,kte))

        endif

      enddo

    endif


!***  Begin debugging

    imd=(ims+ime)/2

    jmd=(jms+jme)/2

!***  End debugging


    jtf=jte

    itf=ite

    ktf=kte


    IF (bl_mynn_output > 0) THEN !research mode

       edmf_a(its:ite,kts:kte)=0.

       edmf_w(its:ite,kts:kte)=0.

       edmf_qt(its:ite,kts:kte)=0.

       edmf_thl(its:ite,kts:kte)=0.

       edmf_ent(its:ite,kts:kte)=0.

       edmf_qc(its:ite,kts:kte)=0.

       sub_thl3d(its:ite,kts:kte)=0.

       sub_sqv3d(its:ite,kts:kte)=0.

       det_thl3d(its:ite,kts:kte)=0.

       det_sqv3d(its:ite,kts:kte)=0.


       !edmf_a_dd(its:ite,kts:kte)=0.

       !edmf_w_dd(its:ite,kts:kte)=0.

       !edmf_qt_dd(its:ite,kts:kte)=0.

       !edmf_thl_dd(its:ite,kts:kte)=0.

       !edmf_ent_dd(its:ite,kts:kte)=0.

       !edmf_qc_dd(its:ite,kts:kte)=0.

    ENDIF

    ktop_plume(its:ite)=0   !int

    ztop_plume(its:ite)=0.

    maxwidth(its:ite)=0.

    maxmf(its:ite)=0.

    maxkhtopdown(its:ite)=0.

    kzero(kts:kte)=0.


    ! DH* CHECK HOW MUCH OF THIS INIT IF-BLOCK IS ACTUALLY NEEDED FOR RESTARTS

    IF (initflag > 0 .and. .not.restart) THEN


       !Test to see if we want to initialize qke

       IF ( (restart .or. cycling)) THEN

          IF (maxval(qke(its:ite,kts)) < 0.0002) THEN

             initialize_qke = .true.

             !print*,"QKE is too small, must initialize"

          ELSE

             initialize_qke = .false.

             !print*,"Using background QKE, will not initialize"

          ENDIF

       ELSE ! not cycling or restarting:

          initialize_qke = .true.

          !print*,"not restart nor cycling, must initialize QKE"

       ENDIF


       if (.not.restart .or. .not.cycling) THEN

         sh3d(its:ite,kts:kte)=0.

         sm3d(its:ite,kts:kte)=0.

         el_pbl(its:ite,kts:kte)=0.

         tsq(its:ite,kts:kte)=0.

         qsq(its:ite,kts:kte)=0.

         cov(its:ite,kts:kte)=0.

         cldfra_bl(its:ite,kts:kte)=0.

         qc_bl(its:ite,kts:kte)=0.

         qke(its:ite,kts:kte)=0.

       else

         qc_bl1d(kts:kte)=0.0

         qi_bl1d(kts:kte)=0.0

         cldfra_bl1d(kts:kte)=0.0

       end if

       dqc1(kts:kte)=0.0

       dqi1(kts:kte)=0.0

       dqni1(kts:kte)=0.0

       dqnc1(kts:kte)=0.0

       dqnwfa1(kts:kte)=0.0

       dqnifa1(kts:kte)=0.0

       dqnbca1(kts:kte)=0.0

       dozone1(kts:kte)=0.0

       qc_bl1d_old(kts:kte)=0.0

       cldfra_bl1d_old(kts:kte)=0.0

       edmf_a1(kts:kte)=0.0

       edmf_w1(kts:kte)=0.0

       edmf_qc1(kts:kte)=0.0

       edmf_a_dd1(kts:kte)=0.0

       edmf_w_dd1(kts:kte)=0.0

       edmf_qc_dd1(kts:kte)=0.0

       sgm(kts:kte)=0.0

       vt(kts:kte)=0.0

       vq(kts:kte)=0.0


       DO k=kts,kte

          DO i=its,itf

             exch_m(i,k)=0.

             exch_h(i,k)=0.

          ENDDO

       ENDDO


       IF (tke_budget .eq. 1) THEN

          DO k=kts,kte

             DO i=its,itf

                qwt(i,k)=0.

                qshear(i,k)=0.

                qbuoy(i,k)=0.

                qdiss(i,k)=0.

                dqke(i,k)=0.

             ENDDO

          ENDDO

       ENDIF


       DO i=its,itf

          if (flag_qi ) then

             sqi(:)=sqi3d(i,:)

          else

             sqi = 0.0

          endif

          if (flag_qs ) then

             sqs(:)=sqs3d(i,:)

          else

             sqs = 0.0

          endif

          if (icloud_bl > 0) then

             cldfra_bl1d(:)=cldfra_bl(i,:)

             qc_bl1d(:)=qc_bl(i,:)

             qi_bl1d(:)=qi_bl(i,:)

          endif


          do k=kts,kte !KTF

                dz1(k)=dz(i,k)

                u1(k) = u(i,k)

                v1(k) = v(i,k)

                w1(k) = w(i,k)

                th1(k)=th(i,k)

                tk1(k)=t3d(i,k)

                ex1(k)=exner(i,k)

                rho1(k)=rho(i,k)

                sqc(k)=sqc3d(i,k) !/(1.+qv(i,k))

                sqv(k)=sqv3d(i,k) !/(1.+qv(i,k))

                thetav(k)=th(i,k)*(1.+p608*sqv(k))

                !keep snow out for now - increases ceiling bias

                sqw(k)=sqv(k)+sqc(k)+sqi(k)!+sqs(k)

                thl(k)=th1(k) - xlvcp/ex1(k)*sqc(k) &

                    &         - xlscp/ex1(k)*(sqi(k))!+sqs(k))

                !Use form from Tripoli and Cotton (1981) with their

                !suggested min temperature to improve accuracy.

                !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) &

                !    &               - xlscp/MAX(tk1(k),TKmin)*sqi(k))


                IF (k==kts) THEN

                   zw(k)=0.

                ELSE

                   zw(k)=zw(k-1)+dz(i,k-1)

                ENDIF

                IF (initialize_qke) THEN

                   !Initialize tke for initial PBLH calc only - using

                   !simple PBLH form of Koracin and Berkowicz (1988, BLM)

                   !to linearly taper off tke towards top of PBL.

                   qke1(k)=5.*ust(i) * max((ust(i)*700. - zw(k))/(max(ust(i),0.01)*700.), 0.01)

                ELSE

                   qke1(k)=qke(i,k)

                ENDIF

                el(k)=el_pbl(i,k)

                sh(k)=sh3d(i,k)

                sm(k)=sm3d(i,k)

                tsq1(k)=tsq(i,k)

                qsq1(k)=qsq(i,k)

                cov1(k)=cov(i,k)

                if (spp_pbl==1) then

                    rstoch_col(k)=pattern_spp_pbl(i,k)

                else

                    rstoch_col(k)=0.0

                endif


             ENDDO


             zw(kte+1)=zw(kte)+dz(i,kte)


             CALL get_pblh(kts,kte,pblh(i),thetav,&

               &  qke1,zw,dz1,xland(i),kpbl(i))


             IF (scaleaware > 0.) THEN

                CALL scale_aware(dx(i),pblh(i),psig_bl(i),psig_shcu(i))

             ELSE

                psig_bl(i)=1.0

                psig_shcu(i)=1.0

             ENDIF


             ! DH* CHECK IF WE CAN DO WITHOUT CALLING THIS ROUTINE FOR RESTARTS

             CALL mym_initialize (                &

                  &kts,kte,xland(i),              &

                  &dz1, dx(i), zw,                &

                  &u1, v1, thl, sqv,              &

                  &pblh(i), th1, thetav, sh, sm,  &

                  &ust(i), rmol(i),               &

                  &el, qke1, tsq1, qsq1, cov1,    &

                  &psig_bl(i), cldfra_bl1d,       &

                  &bl_mynn_mixlength,             &

                  &edmf_w1,edmf_a1,               &

                  &initialize_qke,                &

                  &spp_pbl,rstoch_col             )


             IF (.not.restart) THEN

                !UPDATE 3D VARIABLES

                DO k=kts,kte !KTF

                   el_pbl(i,k)=el(k)

                   sh3d(i,k)=sh(k)

                   sm3d(i,k)=sm(k)

                   qke(i,k)=qke1(k)

                   tsq(i,k)=tsq1(k)

                   qsq(i,k)=qsq1(k)

                   cov(i,k)=cov1(k)

                ENDDO

                !initialize qke_adv array if using advection

                IF (bl_mynn_tkeadvect) THEN

                   DO k=kts,kte

                      qke_adv(i,k)=qke1(k)

                   ENDDO

                ENDIF

             ENDIF


!***  Begin debugging

!             IF(I==IMD .AND. J==JMD)THEN

!               PRINT*,"MYNN DRIVER INIT: k=",1," sh=",sh(k)

!               PRINT*," sqw=",sqw(k)," thl=",thl(k)," k_m=",exch_m(i,k)

!               PRINT*," xland=",xland(i)," rmol=",rmol(i)," ust=",ust(i)

!               PRINT*," qke=",qke(i,k)," el=",el_pbl(i,k)," tsq=",Tsq(i,k)

!               PRINT*," PBLH=",PBLH(i)," u=",u(i,k)," v=",v(i,k)

!             ENDIF

!***  End debugging


       ENDDO !end i-loop


    ENDIF ! end initflag


    !ACF- copy qke_adv array into qke if using advection

    IF (bl_mynn_tkeadvect) THEN

       qke=qke_adv

    ENDIF


    DO i=its,itf

       !Initialize some arrays

       if (tke_budget .eq. 1) then

          dqke(i,:)=qke(i,:)

       endif

       if (flag_qi ) then

          sqi(:)=sqi3d(i,:)

       else

          sqi = 0.0

       endif

       if (flag_qs ) then

          sqs(:)=sqs3d(i,:)

       else

          sqs = 0.0

       endif

       if (icloud_bl > 0) then

          cldfra_bl1d(:)=cldfra_bl(i,:)

          qc_bl1d(:)   =qc_bl(i,:)

          qi_bl1d(:)   =qi_bl(i,:)

          cldfra_bl1d_old(:)=cldfra_bl(i,:)

          qc_bl1d_old(:)=qc_bl(i,:)

          qi_bl1d_old(:)=qi_bl(i,:)

       else

          cldfra_bl1d  =0.0

          qc_bl1d      =0.0

          qi_bl1d      =0.0

          cldfra_bl1d_old=0.0

          qc_bl1d_old  =0.0

          qi_bl1d_old  =0.0

       endif

       dz1(kts:kte)    =dz(i,kts:kte)

       u1(kts:kte)     =u(i,kts:kte)

       v1(kts:kte)     =v(i,kts:kte)

       w1(kts:kte)     =w(i,kts:kte)

       th1(kts:kte)    =th(i,kts:kte)

       tk1(kts:kte)    =t3d(i,kts:kte)

       p1(kts:kte)     =p(i,kts:kte)

       ex1(kts:kte)    =exner(i,kts:kte)

       rho1(kts:kte)   =rho(i,kts:kte)

       sqv(kts:kte)    =sqv3d(i,kts:kte) !/(1.+qv(i,kts:kte))

       sqc(kts:kte)    =sqc3d(i,kts:kte) !/(1.+qv(i,kts:kte))

       qv1(kts:kte)    =sqv(kts:kte)/(1.-sqv(kts:kte))

       qc1(kts:kte)    =sqc(kts:kte)/(1.-sqv(kts:kte))

       qi1(kts:kte)    =sqi(kts:kte)/(1.-sqv(kts:kte))

       qs1(kts:kte)    =sqs(kts:kte)/(1.-sqv(kts:kte))

       dqc1(kts:kte)   =0.0

       dqi1(kts:kte)   =0.0

       dqs1(kts:kte)   =0.0

       dqni1(kts:kte)  =0.0

       dqnc1(kts:kte)  =0.0

       dqnwfa1(kts:kte)=0.0

       dqnifa1(kts:kte)=0.0

       dqnbca1(kts:kte)=0.0

       dozone1(kts:kte)=0.0

       IF (flag_qni ) THEN

          qni1(kts:kte)=qni(i,kts:kte)

       ELSE

          qni1(kts:kte)=0.0

       ENDIF

       IF (flag_qnc ) THEN

          qnc1(kts:kte)=qnc(i,kts:kte)

       ELSE

          qnc1(kts:kte)=0.0

       ENDIF

       IF (flag_qnwfa ) THEN

          qnwfa1(kts:kte)=qnwfa(i,kts:kte)

       ELSE

          qnwfa1(kts:kte)=0.0

       ENDIF

       IF (flag_qnifa ) THEN

          qnifa1(kts:kte)=qnifa(i,kts:kte)

       ELSE

          qnifa1(kts:kte)=0.0

       ENDIF

       IF (flag_qnbca ) THEN

          qnbca1(kts:kte)=qnbca(i,kts:kte)

       ELSE

          qnbca1(kts:kte)=0.0

       ENDIF

       IF (flag_ozone ) THEN

          ozone1(kts:kte)=ozone(i,kts:kte)

       ELSE

          ozone1(kts:kte)=0.0

       ENDIF

       el(kts:kte)  =el_pbl(i,kts:kte)

       qke1(kts:kte)=qke(i,kts:kte)

       sh(kts:kte)  =sh3d(i,kts:kte)

       sm(kts:kte)  =sm3d(i,kts:kte)

       tsq1(kts:kte)=tsq(i,kts:kte)

       qsq1(kts:kte)=qsq(i,kts:kte)

       cov1(kts:kte)=cov(i,kts:kte)

       if (spp_pbl==1) then

          rstoch_col(kts:kte)=pattern_spp_pbl(i,kts:kte)

       else

          rstoch_col(kts:kte)=0.0

       endif

       !edmf

       edmf_a1    =0.0

       edmf_w1    =0.0

       edmf_qc1   =0.0

       s_aw1      =0.0

       s_awthl1   =0.0

       s_awqt1    =0.0

       s_awqv1    =0.0

       s_awqc1    =0.0

       s_awu1     =0.0

       s_awv1     =0.0

       s_awqke1   =0.0

       s_awqnc1   =0.0

       s_awqni1   =0.0

       s_awqnwfa1 =0.0

       s_awqnifa1 =0.0

       s_awqnbca1 =0.0

       ![EWDD]

       edmf_a_dd1 =0.0

       edmf_w_dd1 =0.0

       edmf_qc_dd1=0.0

       sd_aw1     =0.0

       sd_awthl1  =0.0

       sd_awqt1   =0.0

       sd_awqv1   =0.0

       sd_awqc1   =0.0

       sd_awu1    =0.0

       sd_awv1    =0.0

       sd_awqke1  =0.0

       sub_thl    =0.0

       sub_sqv    =0.0

       sub_u      =0.0

       sub_v      =0.0

       det_thl    =0.0

       det_sqv    =0.0

       det_sqc    =0.0

       det_u      =0.0

       det_v      =0.0


       do k = kts,kte

          if (k==kts) then

             zw(k)=0.

          else

             zw(k)=zw(k-1)+dz(i,k-1)

          endif

          !keep snow out for now - increases ceiling bias

          sqw(k)= sqv(k)+sqc(k)+sqi(k)!+sqs(k)

          thl(k)= th1(k) - xlvcp/ex1(k)*sqc(k) &

               &         - xlscp/ex1(k)*(sqi(k))!+sqs(k))

          !Use form from Tripoli and Cotton (1981) with their

          !suggested min temperature to improve accuracy.

          !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) &

          !    &               - xlscp/MAX(tk1(k),TKmin)*sqi(k))

          thetav(k)=th1(k)*(1.+p608*sqv(k))

       enddo ! end k

       zw(kte+1)=zw(kte)+dz(i,kte)


       !initialize smoke/chem arrays (if used):

       if ( mix_chem ) then

          do ic = 1,ndvel

             vd1(ic) = vdep(i,ic) ! dry deposition velocity

          enddo

          do k = kts,kte

             do ic = 1,nchem

                chem1(k,ic) = chem3d(i,k,ic)

             enddo

          enddo

       else

          do ic = 1,ndvel

             vd1(ic) = 0. ! dry deposition velocity

          enddo

          do k = kts,kte

             do ic = 1,nchem

                chem1(k,ic) = 0.

             enddo

          enddo

       endif

       s_awchem1 = 0.0


       CALL get_pblh(kts,kte,pblh(i),thetav,&

       & qke1,zw,dz1,xland(i),kpbl(i))


       if (scaleaware > 0.) then

          call scale_aware(dx(i),pblh(i),psig_bl(i),psig_shcu(i))

       else

          psig_bl(i)=1.0

          psig_shcu(i)=1.0

       endif


       sqcg= 0.0   !ill-defined variable; qcg has been removed

       cpm=cp*(1.+0.84*qv1(kts))

       exnerg=(ps(i)/p1000mb)**rcp


       !-----------------------------------------------------

       !ORIGINAL CODE

       !flt = hfx(i)/( rho(i,kts)*cpm ) &

       ! +xlvcp*ch(i)*(sqc(kts)/exner(i,kts) -sqcg/exnerg)

       !flq = qfx(i)/  rho(i,kts)       &

       !    -ch(i)*(sqc(kts)   -sqcg )

       !-----------------------------------------------------

       flqv = qfx(i)/rho1(kts)

       flqc = 0.0 !currently no sea-spray fluxes, fog settling handled elsewhere

       th_sfc = ts(i)/ex1(kts)


       ! TURBULENT FLUX FOR TKE BOUNDARY CONDITIONS

       flq =flqv+flqc                   !! LATENT

       flt =hfx(i)/(rho1(kts)*cpm )-xlvcp*flqc/ex1(kts)  !! Temperature flux

       fltv=flt + flqv*p608*th_sfc      !! Virtual temperature flux


       ! Update 1/L using updated sfc heat flux and friction velocity

       rmol(i) = -karman*gtr*fltv/max(ust(i)**3,1.0e-6)

       zet = 0.5*dz(i,kts)*rmol(i)

       zet = max(zet, -20.)

       zet = min(zet,  20.)

       !if(i.eq.idbg)print*,"updated z/L=",zet

       if (bl_mynn_stfunc == 0) then

          !Original Kansas-type stability functions

          if ( zet >= 0.0 ) then

             pmz = 1.0 + (cphm_st-1.0) * zet

             phh = 1.0 +  cphh_st      * zet

          else

             pmz = 1.0/    (1.0-cphm_unst*zet)**0.25 - zet

             phh = 1.0/sqrt(1.0-cphh_unst*zet)

          end if

       else

          !Updated stability functions (Puhales, 2020)

          phi_m = phim(zet)

          pmz   = phi_m - zet

          phh   = phih(zet)

       end if


       call mym_condensation (kts,kte,                   &

            &dx(i),dz1,zw,xland(i),                      &

            &thl,sqw,sqv,sqc,sqi,sqs,                    &

            &p1,ex1,tsq1,qsq1,cov1,                      &

            &sh,el,bl_mynn_cloudpdf,                     &

            &qc_bl1d,qi_bl1d,cldfra_bl1d,                &

            &pblh(i),hfx(i),                             &

            &vt, vq, th1, sgm, rmol(i),                  &

            &spp_pbl, rstoch_col                         )


       if (bl_mynn_topdown.eq.1) then

          call topdown_cloudrad(kts,kte,dz1,zw,          &

               &xland(i),kpbl(i),pblh(i),                &

               &sqc,sqi,sqw,thl,th1,ex1,p1,rho1,thetav,  &

               &cldfra_bl1d,rthraten(i,:),               &

               &maxkhtopdown(i),khtopdown,tkeprodtd      )

       else

          maxkhtopdown(i)  = 0.0

          khtopdown(kts:kte) = 0.0

          tkeprodtd(kts:kte) = 0.0

       endif


       if (bl_mynn_edmf > 0) then

          !PRINT*,"Calling DMP Mass-Flux: i= ",i

          call dmp_mf(                                   &

               &kts,kte,delt,zw,dz1,p1,rho1,             &

               &bl_mynn_edmf_mom,                        &

               &bl_mynn_edmf_tke,                        &

               &bl_mynn_mixscalars,                      &

               &u1,v1,w1,th1,thl,thetav,tk1,             &

               &sqw,sqv,sqc,qke1,                        &

               &qnc1,qni1,qnwfa1,qnifa1,qnbca1,          &

               &ex1,vt,vq,sgm,                           &

               &ust(i),flt,fltv,flq,flqv,                &

               &pblh(i),kpbl(i),dx(i),                   &

               &xland(i),th_sfc,                         &

            ! now outputs - tendencies

            ! &,dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf         &

            ! outputs - updraft properties

               &edmf_a1,edmf_w1,edmf_qt1,                &

               &edmf_thl1,edmf_ent1,edmf_qc1,            &

            ! for the solver

               &s_aw1,s_awthl1,s_awqt1,                  &

               &s_awqv1,s_awqc1,                         &

               &s_awu1,s_awv1,s_awqke1,                  &

               &s_awqnc1,s_awqni1,                       &

               &s_awqnwfa1,s_awqnifa1,s_awqnbca1,        &

               &sub_thl,sub_sqv,                         &

               &sub_u,sub_v,                             &

               &det_thl,det_sqv,det_sqc,                 &

               &det_u,det_v,                             &

            ! chem/smoke mixing

               &nchem,chem1,s_awchem1,                   &

               &mix_chem,                                &

               &qc_bl1d,cldfra_bl1d,                     &

               &qc_bl1d_old,cldfra_bl1d_old,             &

               &flag_qc,flag_qi,                         &

               &flag_qnc,flag_qni,                       &

               &flag_qnwfa,flag_qnifa,flag_qnbca,        &

               &psig_shcu(i),                            &

               &maxwidth(i),ktop_plume(i),               &

               &maxmf(i),ztop_plume(i),                  &

               &spp_pbl,rstoch_col                       )

       endif


       if (bl_mynn_edmf_dd == 1) then

          call ddmf_jpl(kts,kte,delt,zw,dz1,p1,          &

               &u1,v1,th1,thl,thetav,tk1,                &

               &sqw,sqv,sqc,rho1,ex1,                    &

               &ust(i),flt,flq,                          &

               &pblh(i),kpbl(i),                         &

               &edmf_a_dd1,edmf_w_dd1,edmf_qt_dd1,       &

               &edmf_thl_dd1,edmf_ent_dd1,               &

               &edmf_qc_dd1,                             &

               &sd_aw1,sd_awthl1,sd_awqt1,               &

               &sd_awqv1,sd_awqc1,sd_awu1,sd_awv1,       &

               &sd_awqke1,                               &

               &qc_bl1d,cldfra_bl1d,                     &

               &rthraten(i,:)                            )

       endif


       !Capability to substep the eddy-diffusivity portion

       !do nsub = 1,2

       delt2 = delt !*0.5    !only works if topdown=0


       call mym_turbulence(                              &

               &kts,kte,xland(i),closure,                &

               &dz1, dx(i), zw,                          &

               &u1, v1, thl, thetav, sqc, sqw,           &

               &qke1, tsq1, qsq1, cov1,                  &

               &vt, vq,                                  &

               &rmol(i), flt, fltv, flq,                 &

               &pblh(i),th1,                             &

               &sh,sm,el,                                &

               &dfm,dfh,dfq,                             &

               &tcd,qcd,pdk,                             &

               &pdt,pdq,pdc,                             &

               &qwt1,qshear1,qbuoy1,qdiss1,              &

               &tke_budget,                              &

               &psig_bl(i),psig_shcu(i),                 &

               &cldfra_bl1d,bl_mynn_mixlength,           &

               &edmf_w1,edmf_a1,                         &

               &tkeprodtd,                               &

               &spp_pbl,rstoch_col                       )


       call mym_predict(kts,kte,closure,                 &

               &delt2, dz1,                              &

               &ust(i), flt, flq, pmz, phh,              &

               &el, dfq, rho1, pdk, pdt, pdq, pdc,       &

               &qke1, tsq1, qsq1, cov1,                  &

               &s_aw1, s_awqke1, bl_mynn_edmf_tke,       &

               &qwt1, qdiss1, tke_budget                 )


       if (dheat_opt > 0) then

          do k=kts,kte-1

             ! Set max dissipative heating rate to 7.2 K per hour

             diss_heat(k) = min(max(1.0*(qke1(k)**1.5)/(b1*max(0.5*(el(k)+el(k+1)),1.))/cp, 0.0),0.002)

             ! Limit heating above 100 mb:

             diss_heat(k) = diss_heat(k) * exp(-10000./max(p1(k),1.))

          enddo

          diss_heat(kte) = 0.

       else

          diss_heat(1:kte) = 0.

       endif


       call mynn_tendencies(kts,kte,i,                   &

               &delt, dz1, rho1,                         &

               &u1, v1, th1, tk1, qv1,                   &

               &qc1, qi1, kzero, qnc1, qni1,             & !kzero replaces qs1 - not mixing snow

               &ps(i), p1, ex1, thl,                     &

               &sqv, sqc, sqi, kzero, sqw,               & !kzero replaces sqs - not mixing snow

               &qnwfa1, qnifa1, qnbca1, ozone1,          &

               &ust(i),flt,flq,flqv,flqc,                &

               &wspd(i),uoce(i),voce(i),                 &

               &tsq1, qsq1, cov1,                        &

               &tcd, qcd,                                &

               &dfm, dfh, dfq,                           &

               &du1, dv1, dth1, dqv1,                    &

               &dqc1, dqi1, dqs1, dqnc1, dqni1,          &

               &dqnwfa1, dqnifa1, dqnbca1,               &

               &dozone1,                                 &

               &diss_heat,                               &

               ! mass flux components

               &s_aw1,s_awthl1,s_awqt1,                  &

               &s_awqv1,s_awqc1,s_awu1,s_awv1,           &

               &s_awqnc1,s_awqni1,                       &

               &s_awqnwfa1,s_awqnifa1,s_awqnbca1,        &

               &sd_aw1,sd_awthl1,sd_awqt1,               &

               &sd_awqv1,sd_awqc1,                       &

               &sd_awu1,sd_awv1,                         &

               &sub_thl,sub_sqv,                         &

               &sub_u,sub_v,                             &

               &det_thl,det_sqv,det_sqc,                 &

               &det_u,det_v,                             &

               &flag_qc,flag_qi,flag_qnc,                &

               &flag_qni,flag_qs,                        &

               &flag_qnwfa,flag_qnifa,                   &

               &flag_qnbca,                              &

               &cldfra_bl1d,                             &

               &bl_mynn_cloudmix,                        &

               &bl_mynn_mixqt,                           &

               &bl_mynn_edmf,                            &

               &bl_mynn_edmf_mom,                        &

               &bl_mynn_mixscalars                       )


       if ( mix_chem ) then

          if ( rrfs_sd ) then

             call mynn_mix_chem(kts,kte,i,               &

                  &delt, dz1, pblh(i),                   &

                  &nchem, kdvel, ndvel,                  &

                  &chem1, vd1,                           &

                  &rho1,flt,                             &

                  &tcd, qcd,                             &

                  &dfh,                                  &

                  &s_aw1,s_awchem1,                      &

                  &emis_ant_no(i),                       &

                  &frp(i), rrfs_sd,                      &

                  &enh_mix, smoke_dbg                    )

          else

             call mynn_mix_chem(kts,kte,i,               &

                  &delt, dz1, pblh(i),                   &

                  &nchem, kdvel, ndvel,                  &

                  &chem1, vd1,                           &

                  &rho1,flt,                             &

                  &tcd, qcd,                             &

                  &dfh,                                  &

                  &s_aw1,s_awchem1,                      &

                  &zero,                                 &

                  &zero, rrfs_sd,                        &

                  &enh_mix, smoke_dbg                    )

          endif

          do ic = 1,nchem

             do k = kts,kte

                chem3d(i,k,ic) = max(1.e-12, chem1(k,ic))

             enddo

          enddo

       endif


       call retrieve_exchange_coeffs(kts,kte,            &

            &dfm, dfh, dz1, k_m1, k_h1                   )


       !UPDATE 3D ARRAYS

       exch_m(i,kts:kte)  =k_m1(kts:kte)

       exch_h(i,kts:kte)  =k_h1(kts:kte)

       rublten(i,kts:kte) =du1(kts:kte)

       rvblten(i,kts:kte) =dv1(kts:kte)

       rthblten(i,kts:kte)=dth1(kts:kte)

       rqvblten(i,kts:kte)=dqv1(kts:kte)

       if (bl_mynn_cloudmix > 0) then

          if (flag_qc) rqcblten(i,kts:kte)=dqc1(kts:kte)

          if (flag_qi) rqiblten(i,kts:kte)=dqi1(kts:kte)

          if (flag_qs) rqsblten(i,kts:kte)=dqs1(kts:kte)

       else

          if (flag_qc) rqcblten(i,:)=0.

          if (flag_qi) rqiblten(i,:)=0.

          if (flag_qs) rqsblten(i,:)=0.

       endif

       if (bl_mynn_cloudmix > 0 .and. bl_mynn_mixscalars > 0) then

          if (flag_qnc) rqncblten(i,kts:kte)    =dqnc1(kts:kte)

          if (flag_qni) rqniblten(i,kts:kte)    =dqni1(kts:kte)

          if (flag_qnwfa) rqnwfablten(i,kts:kte)=dqnwfa1(kts:kte)

          if (flag_qnifa) rqnifablten(i,kts:kte)=dqnifa1(kts:kte)

          if (flag_qnbca) rqnbcablten(i,kts:kte)=dqnbca1(kts:kte)

       else

          if (flag_qnc) rqncblten(i,:)    =0.

          if (flag_qni) rqniblten(i,:)    =0.

          if (flag_qnwfa) rqnwfablten(i,:)=0.

          if (flag_qnifa) rqnifablten(i,:)=0.

          if (flag_qnbca) rqnbcablten(i,:)=0.

       endif

       dozone(i,kts:kte)=dozone1(kts:kte)

       if (icloud_bl > 0) then

          qc_bl(i,kts:kte)    =qc_bl1d(kts:kte)

          qi_bl(i,kts:kte)    =qi_bl1d(kts:kte)

          cldfra_bl(i,kts:kte)=cldfra_bl1d(kts:kte)

       endif

       el_pbl(i,kts:kte)=el(kts:kte)

       qke(i,kts:kte)   =qke1(kts:kte)

       tsq(i,kts:kte)   =tsq1(kts:kte)

       qsq(i,kts:kte)   =qsq1(kts:kte)

       cov(i,kts:kte)   =cov1(kts:kte)

       sh3d(i,kts:kte)  =sh(kts:kte)

       sm3d(i,kts:kte)  =sm(kts:kte)


       if (tke_budget .eq. 1) then

          !! TKE budget is now given in m**2/s**-3 (Puhales, 2020)

          !! Lower boundary condtions (using similarity relationships such as the prognostic equation for Qke)

          k=kts

          qshear1(k)    =4.*(ust(i)**3*phi_m/(karman*dz(i,k)))-qshear1(k+1) !! staggered

          qbuoy1(k)     =4.*(-ust(i)**3*zet/(karman*dz(i,k)))-qbuoy1(k+1) !! staggered

          !! unstaggering SHEAR and BUOY and trasfering all TKE budget to 3D array

          do k = kts,kte-1

             qshear(i,k)=0.5*(qshear1(k)+qshear1(k+1)) !!! unstaggering in z

             qbuoy(i,k) =0.5*(qbuoy1(k)+qbuoy1(k+1)) !!! unstaggering in z

             qwt(i,k)   =qwt1(k)

             qdiss(i,k) =qdiss1(k)

             dqke(i,k)  =(qke1(k)-dqke(i,k))*0.5/delt

          enddo

          !! Upper boundary conditions

          k=kte

          qshear(i,k)   =0.

          qbuoy(i,k)    =0.

          qwt(i,k)      =0.

          qdiss(i,k)    =0.

          dqke(i,k)     =0.

       endif


       !update updraft/downdraft properties

       if (bl_mynn_output > 0) then !research mode == 1

          if (bl_mynn_edmf > 0) then

             edmf_a(i,kts:kte)   =edmf_a1(kts:kte)

             edmf_w(i,kts:kte)   =edmf_w1(kts:kte)

             edmf_qt(i,kts:kte)  =edmf_qt1(kts:kte)

             edmf_thl(i,kts:kte) =edmf_thl1(kts:kte)

             edmf_ent(i,kts:kte) =edmf_ent1(kts:kte)

             edmf_qc(i,kts:kte)  =edmf_qc1(kts:kte)

             sub_thl3d(i,kts:kte)=sub_thl(kts:kte)

             sub_sqv3d(i,kts:kte)=sub_sqv(kts:kte)

             det_thl3d(i,kts:kte)=det_thl(kts:kte)

             det_sqv3d(i,kts:kte)=det_sqv(kts:kte)

          endif

          !if (bl_mynn_edmf_dd > 0) THEN

          !   edmf_a_dd(i,kts:kte)  =edmf_a_dd1(kts:kte)

          !   edmf_w_dd(i,kts:kte)  =edmf_w_dd1(kts:kte)

          !   edmf_qt_dd(i,kts:kte) =edmf_qt_dd1(kts:kte)

          !   edmf_thl_dd(i,kts:kte)=edmf_thl_dd1(kts:kte)

          !   edmf_ent_dd(i,kts:kte)=edmf_ent_dd1(kts:kte)

          !   edmf_qc_dd(i,kts:kte) =edmf_qc_dd1(kts:kte)

          !endif

       endif


       !***  Begin debug prints

       if ( debug_code .and. (i .eq. idbg)) THEN

          if ( abs(qfx(i))>.001)print*,&

             "SUSPICIOUS VALUES AT: i=",i," QFX=",qfx(i)

          if ( abs(hfx(i))>1100.)print*,&

             "SUSPICIOUS VALUES AT: i=",i," HFX=",hfx(i)

          do k = kts,kte

             IF ( sh(k) < 0. .OR. sh(k)> 200.)print*,&

                "SUSPICIOUS VALUES AT: i,k=",i,k," sh=",sh(k)

             IF ( abs(vt(k)) > 2.0 )print*,&

                "SUSPICIOUS VALUES AT: i,k=",i,k," vt=",vt(k)

             IF ( abs(vq(k)) > 7000.)print*,&

                "SUSPICIOUS VALUES AT: i,k=",i,k," vq=",vq(k)

             IF ( qke(i,k) < -1. .OR. qke(i,k)> 200.)print*,&

                "SUSPICIOUS VALUES AT: i,k=",i,k," qke=",qke(i,k)

             IF ( el_pbl(i,k) < 0. .OR. el_pbl(i,k)> 1500.)print*,&

                "SUSPICIOUS VALUES AT: i,k=",i,k," el_pbl=",el_pbl(i,k)

             IF ( exch_m(i,k) < 0. .OR. exch_m(i,k)> 2000.)print*,&

                "SUSPICIOUS VALUES AT: i,k=",i,k," exxch_m=",exch_m(i,k)

             IF (icloud_bl > 0) then

                IF ( cldfra_bl(i,k) < 0.0 .OR. cldfra_bl(i,k)> 1.)THEN

                   print*,"SUSPICIOUS VALUES: CLDFRA_BL=",cldfra_bl(i,k)," qc_bl=",qc_bl(i,k)

                ENDIF

             ENDIF


             !IF (I==IMD .AND. J==JMD) THEN

             !   PRINT*,"MYNN DRIVER END: k=",k," sh=",sh(k)

             !   PRINT*," sqw=",sqw(k)," thl=",thl(k)," exch_m=",exch_m(i,k)

             !   PRINT*," xland=",xland(i)," rmol=",rmol(i)," ust=",ust(i)

             !   PRINT*," qke=",qke(i,k)," el=",el_pbl(i,k)," tsq=",tsq(i,k)

             !   PRINT*," PBLH=",PBLH(i)," u=",u(i,k)," v=",v(i,k)

             !   PRINT*," vq=",vq(k)," vt=",vt(k)

             !ENDIF

          enddo !end-k

       endif


    enddo !end i-loop


!ACF copy qke into qke_adv if using advection

    IF (bl_mynn_tkeadvect) THEN

       qke_adv=qke

    ENDIF

!ACF-end


#ifdef HARDCODE_VERTICAL

# undef kts

# undef kte

#endif


  END SUBROUTINE mynn_bl_driver


!=======================================================================

!     SUBROUTINE  mym_initialize:

!

!     Input variables:

!       iniflag         : <>0; turbulent quantities will be initialized

!                         = 0; turbulent quantities have been already

!                              given, i.e., they will not be initialized

!       nx, nz          : Dimension sizes of the

!                         x and z directions, respectively

!       tref            : Reference temperature                      (K)

!       dz(nz)          : Vertical grid spacings                     (m)

!                         # dz(nz)=dz(nz-1)

!       zw(nz+1)        : Heights of the walls of the grid boxes     (m)

!                         # zw(1)=0.0 and zw(k)=zw(k-1)+dz(k-1)

!       exner(nx,nz)    : Exner function at zw*h+zg             (J/kg K)

!                         defined by c_p*( p_basic/1000hPa )^kappa

!                         This is usually computed by integrating

!                         d(pi0)/dz = -h*g/tref.

!       rmo(nx)         : Inverse of the Obukhov length         (m^(-1))

!       flt, flq(nx)    : Turbulent fluxes of potential temperature and

!                         total water, respectively:

!                                    flt=-u_*Theta_*             (K m/s)

!                                    flq=-u_*qw_*            (kg/kg m/s)

!       ust(nx)         : Friction velocity                        (m/s)

!       pmz(nx)         : phi_m-zeta at z1*h+z0, where z1 (=0.5*dz(1))

!                         is the first grid point above the surafce, z0

!                         the roughness length and zeta=(z1*h+z0)*rmo

!       phh(nx)         : phi_h at z1*h+z0

!       u, v(nx,nz)     : Components of the horizontal wind        (m/s)

!       thl(nx,nz)      : Liquid water potential temperature

!                                                                    (K)

!       qw(nx,nz)       : Total water content Q_w                (kg/kg)

!

!     Output variables:

!       ql(nx,nz)       : Liquid water content                   (kg/kg)

!       vt, vq(nx,nz)   : Functions for computing the buoyancy flux

!       qke(nx,nz)      : Twice the turbulent kinetic energy q^2

!                                                              (m^2/s^2)

!       tsq(nx,nz)      : Variance of Theta_l                      (K^2)

!       qsq(nx,nz)      : Variance of Q_w

!       cov(nx,nz)      : Covariance of Theta_l and Q_w              (K)

!       el(nx,nz)       : Master length scale L                      (m)

!                         defined on the walls of the grid boxes

!

!     Work arrays:        see subroutine mym_level2

!       pd?(nx,nz,ny) : Half of the production terms at Level 2

!                         defined on the walls of the grid boxes

!       qkw(nx,nz,ny) : q on the walls of the grid boxes         (m/s)

!

!     # As to dtl, ...gh, see subroutine mym_turbulence.

!

!-------------------------------------------------------------------


  SUBROUTINE  mym_initialize (                                &

       &            kts,kte,xland,                            &

       &            dz, dx, zw,                               &

       &            u, v, thl, qw,                            &

!       &            ust, rmo, pmz, phh, flt, flq,             &

       &            zi, theta, thetav, sh, sm,                &

       &            ust, rmo, el,                             &

       &            Qke, Tsq, Qsq, Cov, Psig_bl, cldfra_bl1D, &

       &            bl_mynn_mixlength,                        &

       &            edmf_w1,edmf_a1,                          &

       &            INITIALIZE_QKE,                           &

       &            spp_pbl,rstoch_col)

!

!-------------------------------------------------------------------


    integer, intent(in)           :: kts,kte

    integer, intent(in)           :: bl_mynn_mixlength

    logical, intent(in)           :: INITIALIZE_QKE

!    real(kind_phys), intent(in)   :: ust, rmo, pmz, phh, flt, flq

    real(kind_phys), intent(in)   :: rmo, Psig_bl, xland

    real(kind_phys), intent(in)   :: dx, ust, zi

    real(kind_phys), dimension(kts:kte),   intent(in) :: dz

    real(kind_phys), dimension(kts:kte+1), intent(in) :: zw

    real(kind_phys), dimension(kts:kte),   intent(in) :: u,v,thl,&

         &qw,cldfra_bl1D,edmf_w1,edmf_a1

    real(kind_phys), dimension(kts:kte),   intent(out) :: tsq,qsq,cov

    real(kind_phys), dimension(kts:kte),   intent(inout) :: el,qke

    real(kind_phys), dimension(kts:kte) ::                       &

         &ql,pdk,pdt,pdq,pdc,dtl,dqw,dtv,                        &

         &gm,gh,sm,sh,qkw,vt,vq

    integer :: k,l,lmax

    real(kind_phys):: phm,vkz,elq,elv,b1l,b2l,pmz=1.,phh=1.,     &

         &flt=0.,fltv=0.,flq=0.,tmpq

    real(kind_phys), dimension(kts:kte) :: theta,thetav

    real(kind_phys), dimension(kts:kte) :: rstoch_col

    integer ::spp_pbl


    DO k = kts,kte

       ql(k) = 0.0

       vt(k) = 0.0

       vq(k) = 0.0

    END DO

!

    CALL mym_level2 ( kts,kte,                      &

         &            dz,                           &

         &            u, v, thl, thetav, qw,        &

         &            ql, vt, vq,                   &

         &            dtl, dqw, dtv, gm, gh, sm, sh )

!

!   **  Preliminary setting  **


    el(kts) = 0.0

    IF (initialize_qke) THEN

       !qke(kts) = ust**2 * ( b1*pmz )**(2.0/3.0)

       qke(kts) = 1.5 * ust**2 * ( b1*pmz )**(2.0/3.0)

       DO k = kts+1,kte

          !qke(k) = 0.0

          !linearly taper off towards top of pbl

          qke(k)=qke(kts)*max((ust*700. - zw(k))/(max(ust,0.01)*700.), 0.01)

       ENDDO

    ENDIF

!

    phm      = phh*b2 / ( b1*pmz )**(1.0/3.0)

    tsq(kts) = phm*( flt/ust )**2

    qsq(kts) = phm*( flq/ust )**2

    cov(kts) = phm*( flt/ust )*( flq/ust )

!

    DO k = kts+1,kte

       vkz = karman*zw(k)

       el(k) = vkz/( 1.0 + vkz/100.0 )

!       qke(k) = 0.0

!

       tsq(k) = 0.0

       qsq(k) = 0.0

       cov(k) = 0.0

    END DO

!

!   **  Initialization with an iterative manner          **

!   **  lmax is the iteration count. This is arbitrary.  **

    lmax = 5

!

    DO l = 1,lmax

!

       CALL mym_length (                          &

            &            kts,kte,xland,           &

            &            dz, dx, zw,              &

            &            rmo, flt, fltv, flq,     &

            &            vt, vq,                  &

            &            u, v, qke,               &

            &            dtv,                     &

            &            el,                      &

            &            zi,theta,                &

            &            qkw,psig_bl,cldfra_bl1d, &

            &            bl_mynn_mixlength,       &

            &            edmf_w1,edmf_a1          )

!

       DO k = kts+1,kte

          elq = el(k)*qkw(k)

          pdk(k) = elq*( sm(k)*gm(k) + &

               &         sh(k)*gh(k) )

          pdt(k) = elq*  sh(k)*dtl(k)**2

          pdq(k) = elq*  sh(k)*dqw(k)**2

          pdc(k) = elq*  sh(k)*dtl(k)*dqw(k)

       END DO

!

!   **  Strictly, vkz*h(i,j) -> karman*( 0.5*dz(1)*h(i,j)+z0 )  **

       vkz = karman*0.5*dz(kts)

       elv = 0.5*( el(kts+1)+el(kts) ) /  vkz

       IF (initialize_qke)THEN

          !qke(kts) = ust**2 * ( b1*pmz*elv    )**(2.0/3.0)

          qke(kts) = 1.0 * max(ust,0.02)**2 * ( b1*pmz*elv    )**(2.0/3.0)

       ENDIF


       phm      = phh*b2 / ( b1*pmz/elv**2 )**(1.0/3.0)

       tsq(kts) = phm*( flt/ust )**2

       qsq(kts) = phm*( flq/ust )**2

       cov(kts) = phm*( flt/ust )*( flq/ust )


       DO k = kts+1,kte-1

          b1l = b1*0.25*( el(k+1)+el(k) )

          !tmpq=MAX(b1l*( pdk(k+1)+pdk(k) ),qkemin)

          !add MIN to limit unreasonable QKE

          tmpq=min(max(b1l*( pdk(k+1)+pdk(k) ),qkemin),125.)

!          PRINT *,'tmpqqqqq',tmpq,pdk(k+1),pdk(k)

          IF (initialize_qke)THEN

             qke(k) = tmpq**twothirds

          ENDIF


          IF ( qke(k) .LE. 0.0 ) THEN

             b2l = 0.0

          ELSE

             b2l = b2*( b1l/b1 ) / sqrt( qke(k) )

          END IF


          tsq(k) = b2l*( pdt(k+1)+pdt(k) )

          qsq(k) = b2l*( pdq(k+1)+pdq(k) )

          cov(k) = b2l*( pdc(k+1)+pdc(k) )

       END DO


    END DO


!!    qke(kts)=qke(kts+1)

!!    tsq(kts)=tsq(kts+1)

!!    qsq(kts)=qsq(kts+1)

!!    cov(kts)=cov(kts+1)


    IF (initialize_qke)THEN

       qke(kts)=0.5*(qke(kts)+qke(kts+1))

       qke(kte)=qke(kte-1)

    ENDIF

    tsq(kte)=tsq(kte-1)

    qsq(kte)=qsq(kte-1)

    cov(kte)=cov(kte-1)


!

!    RETURN


  END SUBROUTINE mym_initialize


!

! ==================================================================

!     SUBROUTINE  mym_level2:

!

!     Input variables:    see subroutine mym_initialize

!

!     Output variables:

!       dtl(nx,nz,ny) : Vertical gradient of Theta_l             (K/m)

!       dqw(nx,nz,ny) : Vertical gradient of Q_w

!       dtv(nx,nz,ny) : Vertical gradient of Theta_V             (K/m)

!       gm (nx,nz,ny) : G_M divided by L^2/q^2                (s^(-2))

!       gh (nx,nz,ny) : G_H divided by L^2/q^2                (s^(-2))

!       sm (nx,nz,ny) : Stability function for momentum, at Level 2

!       sh (nx,nz,ny) : Stability function for heat, at Level 2

!

!       These are defined on the walls of the grid boxes.

!


  SUBROUTINE  mym_level2 (kts,kte,                &

       &            dz,                           &

       &            u, v, thl, thetav, qw,        &

       &            ql, vt, vq,                   &

       &            dtl, dqw, dtv, gm, gh, sm, sh )

!

!-------------------------------------------------------------------


    integer, intent(in)   :: kts,kte


#ifdef HARDCODE_VERTICAL

# define kts 1

# define kte HARDCODE_VERTICAL

#endif


    real(kind_phys), dimension(kts:kte), intent(in)  :: dz

    real(kind_phys), dimension(kts:kte), intent(in)  :: u,v, &

         &thl,qw,ql,vt,vq,thetav

    real(kind_phys), dimension(kts:kte), intent(out) ::      &

         &dtl,dqw,dtv,gm,gh,sm,sh


    integer :: k


    real(kind_phys):: rfc,f1,f2,rf1,rf2,smc,shc,             &

         &ri1,ri2,ri3,ri4,duz,dtz,dqz,vtt,vqq,dtq,dzk,       &

         &afk,abk,ri,rf


    real(kind_phys)::   a2fac


!    ev  = 2.5e6

!    tv0 = 0.61*tref

!    tv1 = 1.61*tref

!    gtr = 9.81/tref

!

    rfc = g1/( g1+g2 )

    f1  = b1*( g1-c1 ) +3.0*a2*( 1.0    -c2 )*( 1.0-c5 ) &

    &                   +2.0*a1*( 3.0-2.0*c2 )

    f2  = b1*( g1+g2 ) -3.0*a1*( 1.0    -c2 )

    rf1 = b1*( g1-c1 )/f1

    rf2 = b1*  g1     /f2

    smc = a1 /a2*  f1/f2

    shc = 3.0*a2*( g1+g2 )

!

    ri1 = 0.5/smc

    ri2 = rf1*smc

    ri3 = 4.0*rf2*smc -2.0*ri2

    ri4 = ri2**2

!

    DO k = kts+1,kte

       dzk = 0.5  *( dz(k)+dz(k-1) )

       afk = dz(k)/( dz(k)+dz(k-1) )

       abk = 1.0 -afk

       duz = ( u(k)-u(k-1) )**2 +( v(k)-v(k-1) )**2

       duz =   duz                    /dzk**2

       dtz = ( thl(k)-thl(k-1) )/( dzk )

       dqz = ( qw(k)-qw(k-1) )/( dzk )

!

       vtt =  1.0 +vt(k)*abk +vt(k-1)*afk  ! Beta-theta in NN09, Eq. 39

       vqq =  tv0 +vq(k)*abk +vq(k-1)*afk  ! Beta-q

       dtq =  vtt*dtz +vqq*dqz

       !Alternatively, use theta-v without the SGS clouds

       !dtq = ( thetav(k)-thetav(k-1) )/( dzk )

!

       dtl(k) =  dtz

       dqw(k) =  dqz

       dtv(k) =  dtq

!?      dtv(i,j,k) =  dtz +tv0*dqz

!?   :              +( xlv/pi0(i,j,k)-tv1 )

!?   :              *( ql(i,j,k)-ql(i,j,k-1) )/( dzk*h(i,j) )

!

       gm(k) =  duz

       gh(k) = -dtq*gtr

!

!   **  Gradient Richardson number  **

       ri = -gh(k)/max( duz, 1.0e-10 )


    !a2fac is needed for the Canuto/Kitamura mod

    IF (ckmod .eq. 1) THEN

       a2fac = 1./(1. + max(ri,0.0))

    ELSE

       a2fac = 1.

    ENDIF


       rfc = g1/( g1+g2 )

       f1  = b1*( g1-c1 ) +3.0*a2*a2fac *( 1.0    -c2 )*( 1.0-c5 ) &

    &                     +2.0*a1*( 3.0-2.0*c2 )

       f2  = b1*( g1+g2 ) -3.0*a1*( 1.0    -c2 )

       rf1 = b1*( g1-c1 )/f1

       rf2 = b1*  g1     /f2

       smc = a1 /(a2*a2fac)*  f1/f2

       shc = 3.0*(a2*a2fac)*( g1+g2 )


       ri1 = 0.5/smc

       ri2 = rf1*smc

       ri3 = 4.0*rf2*smc -2.0*ri2

       ri4 = ri2**2


!   **  Flux Richardson number  **

       rf = min( ri1*( ri + ri2-sqrt(ri**2 - ri3*ri + ri4) ), rfc )

!

       sh(k) = shc*( rfc-rf )/( 1.0-rf )

       sm(k) = smc*( rf1-rf )/( rf2-rf ) * sh(k)

    END DO

!

!    RETURN


#ifdef HARDCODE_VERTICAL

# undef kts

# undef kte

#endif


  END SUBROUTINE mym_level2

!! @}


! ==================================================================

!     SUBROUTINE  mym_length:

!

!     Input variables:    see subroutine mym_initialize

!

!     Output variables:   see subroutine mym_initialize

!

!     Work arrays:

!       elt(nx,ny)      : Length scale depending on the PBL depth    (m)

!       vsc(nx,ny)      : Velocity scale q_c                       (m/s)

!                         at first, used for computing elt

!

!     NOTE: the mixing lengths are meant to be calculated at the full-

!           sigmal levels (or interfaces beween the model layers).

!


  SUBROUTINE  mym_length (                     &

    &            kts,kte,xland,                &

    &            dz, dx, zw,                   &

    &            rmo, flt, fltv, flq,          &

    &            vt, vq,                       &

    &            u1, v1, qke,                  &

    &            dtv,                          &

    &            el,                           &

    &            zi, theta, qkw,               &

    &            Psig_bl, cldfra_bl1D,         &

    &            bl_mynn_mixlength,            &

    &            edmf_w1,edmf_a1               )


!-------------------------------------------------------------------


    integer, intent(in)   :: kts,kte


#ifdef HARDCODE_VERTICAL

# define kts 1

# define kte HARDCODE_VERTICAL

#endif


    integer, intent(in)   :: bl_mynn_mixlength

    real(kind_phys), dimension(kts:kte), intent(in)   :: dz

    real(kind_phys), dimension(kts:kte+1), intent(in) :: zw

    real(kind_phys), intent(in) :: rmo,flt,fltv,flq,Psig_bl,xland

    real(kind_phys), intent(in) :: dx,zi

    real(kind_phys), dimension(kts:kte), intent(in)   :: u1,v1,  &

         &qke,vt,vq,cldfra_bl1D,edmf_w1,edmf_a1

    real(kind_phys), dimension(kts:kte), intent(out)  :: qkw, el

    real(kind_phys), dimension(kts:kte), intent(in)   :: dtv

    real(kind_phys):: elt,vsc

    real(kind_phys), dimension(kts:kte), intent(in) :: theta

    real(kind_phys), dimension(kts:kte) :: qtke,elBLmin,elBLavg,thetaw

    real(kind_phys):: wt,wt2,zi2,h1,h2,hs,elBLmin0,elBLavg0,cldavg


    ! THE FOLLOWING CONSTANTS ARE IMPORTANT FOR REGULATING THE

    ! MIXING LENGTHS:

    real(kind_phys):: cns,   &   !< for surface layer (els) in stable conditions

            alp1,            &   !< for turbulent length scale (elt)

            alp2,            &   !< for buoyancy length scale (elb)

            alp3,            &   !< for buoyancy enhancement factor of elb

            alp4,            &   !< for surface layer (els) in unstable conditions

            alp5,            &   !< for BouLac mixing length or above PBLH

            alp6


    !THE FOLLOWING LIMITS DO NOT DIRECTLY AFFECT THE ACTUAL PBLH.

    !THEY ONLY IMPOSE LIMITS ON THE CALCULATION OF THE MIXING LENGTH

    !SCALES SO THAT THE BOULAC MIXING LENGTH (IN FREE ATMOS) DOES

    !NOT ENCROACH UPON THE BOUNDARY LAYER MIXING LENGTH (els, elb & elt).

    real(kind_phys), parameter :: minzi = 300.

    real(kind_phys), parameter :: maxdz = 750.

    real(kind_phys), parameter :: mindz = 300.


    !SURFACE LAYER LENGTH SCALE MODS TO REDUCE IMPACT IN UPPER BOUNDARY LAYER

    real(kind_phys), parameter :: ZSLH = 100.

    real(kind_phys), parameter :: CSL = 2.


    integer :: i,j,k

    real(kind_phys):: afk,abk,zwk,zwk1,dzk,qdz,vflx,bv,tau_cloud,     &

            & wstar,elb,els,elf,el_stab,el_mf,el_stab_mf,elb_mf,      &

            & PBLH_PLUS_ENT,Uonset,Ugrid,wt_u,el_les

    real(kind_phys), parameter :: ctau = 1000. !constant for tau_cloud


!    tv0 = 0.61*tref

!    gtr = 9.81/tref


    SELECT CASE(bl_mynn_mixlength)


      CASE (0) ! ORIGINAL MYNN MIXING LENGTH + BouLac


        cns  = 2.7

        alp1 = 0.23

        alp2 = 1.0

        alp3 = 5.0

        alp4 = 100.

        alp5 = 0.3


        ! Impose limits on the height integration for elt and the transition layer depth

        zi2  = min(10000.,zw(kte-2))  !originally integrated to model top, not just 10 km.

        h1=max(0.3*zi2,mindz)

        h1=min(h1,maxdz)         ! 1/2 transition layer depth

        h2=h1/2.0                ! 1/4 transition layer depth


        qkw(kts) = sqrt(max(qke(kts),1.0e-10))

        DO k = kts+1,kte

           afk = dz(k)/( dz(k)+dz(k-1) )

           abk = 1.0 -afk

           qkw(k) = sqrt(max(qke(k)*abk+qke(k-1)*afk,1.0e-3))

        END DO


        elt = 1.0e-5

        vsc = 1.0e-5


        !   **  Strictly, zwk*h(i,j) -> ( zwk*h(i,j)+z0 )  **

        k = kts+1

        zwk = zw(k)

        DO WHILE (zwk .LE. zi2+h1)

           dzk = 0.5*( dz(k)+dz(k-1) )

           qdz = max( qkw(k)-qmin, 0.03 )*dzk

           elt = elt +qdz*zwk

           vsc = vsc +qdz

           k   = k+1

           zwk = zw(k)

        END DO


        elt =  alp1*elt/vsc

        vflx = ( vt(kts)+1.0 )*flt +( vq(kts)+tv0 )*flq

        vsc = ( gtr*elt*max( vflx, 0.0 ) )**(1.0/3.0)


        !   **  Strictly, el(i,k=1) is not zero.  **

        el(kts) = 0.0

        zwk1    = zw(kts+1)


        DO k = kts+1,kte

           zwk = zw(k)              !full-sigma levels


           !   **  Length scale limited by the buoyancy effect  **

           IF ( dtv(k) .GT. 0.0 ) THEN

              bv  = sqrt( gtr*dtv(k) )

              elb = alp2*qkw(k) / bv &

                  &       *( 1.0 + alp3/alp2*&

                  &sqrt( vsc/( bv*elt ) ) )

              elf = alp2 * qkw(k)/bv


           ELSE

              elb = 1.0e10

              elf = elb

           ENDIF


           !   **  Length scale in the surface layer  **

           IF ( rmo .GT. 0.0 ) THEN

              els  = karman*zwk/(1.0+cns*min( zwk*rmo, zmax ))

           ELSE

              els  =  karman*zwk*( 1.0 - alp4* zwk*rmo )**0.2

           END IF


           !   ** HARMONC AVERGING OF MIXING LENGTH SCALES:

           !       el(k) =      MIN(elb/( elb/elt+elb/els+1.0 ),elf)

           !       el(k) =      elb/( elb/elt+elb/els+1.0 )


           wt=.5*tanh((zwk - (zi2+h1))/h2) + .5


           el(k) = min(elb/( elb/elt+elb/els+1.0 ),elf)


        END DO


      CASE (1) !NONLOCAL (using BouLac) FORM OF MIXING LENGTH


        ugrid = sqrt(u1(kts)**2 + v1(kts)**2)

        uonset= 15.

        wt_u = (1.0 - min(max(ugrid - uonset, 0.0)/30.0, 0.5))

        cns  = 2.7 !was 3.5

        alp1 = 0.23

        alp2 = 0.3

        alp3 = 2.5 * wt_u !taper off bouyancy enhancement in shear-driven pbls

        alp4 = 5.0

        alp5 = 0.3

        alp6 = 50.


        ! Impose limits on the height integration for elt and the transition layer depth

        zi2=max(zi,300.) !minzi)

        h1=max(0.3*zi2,300.)

        h1=min(h1,600.)          ! 1/2 transition layer depth

        h2=h1/2.0                ! 1/4 transition layer depth


        qtke(kts)=max(0.5*qke(kts), 0.01) !tke at full sigma levels

        thetaw(kts)=theta(kts)            !theta at full-sigma levels

        qkw(kts) = sqrt(max(qke(kts),1.0e-10))


        DO k = kts+1,kte

           afk = dz(k)/( dz(k)+dz(k-1) )

           abk = 1.0 -afk

           qkw(k) = sqrt(max(qke(k)*abk+qke(k-1)*afk,1.0e-3))

           qtke(k) = 0.5*(qkw(k)**2)     ! q -> TKE

           thetaw(k)= theta(k)*abk + theta(k-1)*afk

        END DO


        elt = 1.0e-5

        vsc = 1.0e-5


        !   **  Strictly, zwk*h(i,j) -> ( zwk*h(i,j)+z0 )  **

        k = kts+1

        zwk = zw(k)

        DO WHILE (zwk .LE. zi2+h1)

           dzk = 0.5*( dz(k)+dz(k-1) )

           qdz = min(max( qkw(k)-qmin, 0.03 ), 30.0)*dzk

           elt = elt +qdz*zwk

           vsc = vsc +qdz

           k   = k+1

           zwk = zw(k)

        END DO


        elt = min( max( alp1*elt/vsc, 10.), 400.)

        !avoid use of buoyancy flux functions which are ill-defined at the surface

        !vflx = ( vt(kts)+1.0 )*flt + ( vq(kts)+tv0 )*flq

        vflx = fltv

        vsc = ( gtr*elt*max( vflx, 0.0 ) )**onethird


        !   **  Strictly, el(i,j,1) is not zero.  **

        el(kts) = 0.0

        zwk1    = zw(kts+1)              !full-sigma levels


        ! COMPUTE BouLac mixing length

        CALL boulac_length(kts,kte,zw,dz,qtke,thetaw,elblmin,elblavg)


        DO k = kts+1,kte

           zwk = zw(k)              !full-sigma levels


           !   **  Length scale limited by the buoyancy effect  **

           IF ( dtv(k) .GT. 0.0 ) THEN

              bv  = max( sqrt( gtr*dtv(k) ), 0.0001)

              elb = max(alp2*qkw(k),                          &

                  &    alp6*edmf_a1(k-1)*edmf_w1(k-1)) / bv   &

                  &  *( 1.0 + alp3*sqrt( vsc/(bv*elt) ) )

              elb = min(elb, zwk)

              elf = 1.0 * qkw(k)/bv

              elblavg(k) = max(elblavg(k), alp6*edmf_a1(k-1)*edmf_w1(k-1)/bv)

           ELSE

              elb = 1.0e10

              elf = elb

           ENDIF


           !   **  Length scale in the surface layer  **

           IF ( rmo .GT. 0.0 ) THEN

              els  = karman*zwk/(1.0+cns*min( zwk*rmo, zmax ))

           ELSE

              els  =  karman*zwk*( 1.0 - alp4* zwk*rmo )**0.2

           END IF


           !   ** NOW BLEND THE MIXING LENGTH SCALES:

           wt=.5*tanh((zwk - (zi2+h1))/h2) + .5


           !add blending to use BouLac mixing length in free atmos;

           !defined relative to the PBLH (zi) + transition layer (h1)

           !el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf)

           !try squared-blending - but take out elb (makes it underdiffusive)

           !el(k) = SQRT( els**2/(1. + (els**2/elt**2) +(els**2/elb**2)))

           el(k) = sqrt( els**2/(1. + (els**2/elt**2)))

           el(k) = min(el(k), elb)

           el(k) = min(el(k), elf)

           el(k) = el(k)*(1.-wt) + alp5*elblavg(k)*wt


           ! include scale-awareness, except for original MYNN

           el(k) = el(k)*psig_bl


         END DO


      CASE (2) !Local (mostly) mixing length formulation


        uonset = 3.5 + dz(kts)*0.1

        ugrid  = sqrt(u1(kts)**2 + v1(kts)**2)

        cns  = 3.5 !JOE-test  * (1.0 - MIN(MAX(Ugrid - Uonset, 0.0)/10.0, 1.0))

        alp1 = 0.22

        alp2 = 0.30

        alp3 = 2.0

        alp4 = 5.0

        alp5 = alp2 !like alp2, but for free atmosphere

        alp6 = 50.0 !used for MF mixing length


        ! Impose limits on the height integration for elt and the transition layer depth

        !zi2=MAX(zi,minzi)

        zi2=max(zi,    300.)

        !h1=MAX(0.3*zi2,mindz)

        !h1=MIN(h1,maxdz)         ! 1/2 transition layer depth

        h1=max(0.3*zi2,300.)

        h1=min(h1,600.)

        h2=h1*0.5                ! 1/4 transition layer depth


        qtke(kts)=max(0.5*qke(kts),0.01) !tke at full sigma levels

        qkw(kts) = sqrt(max(qke(kts),1.0e-4))


        DO k = kts+1,kte

           afk = dz(k)/( dz(k)+dz(k-1) )

           abk = 1.0 -afk

           qkw(k) = sqrt(max(qke(k)*abk+qke(k-1)*afk,1.0e-3))

           qtke(k) = 0.5*qkw(k)**2  ! qkw -> TKE

        END DO


        elt = 1.0e-5

        vsc = 1.0e-5


        !   **  Strictly, zwk*h(i,j) -> ( zwk*h(i,j)+z0 )  **

        pblh_plus_ent = max(zi+h1, 100.)

        k = kts+1

        zwk = zw(k)

        DO WHILE (zwk .LE. pblh_plus_ent)

           dzk = 0.5*( dz(k)+dz(k-1) )

           qdz = min(max( qkw(k)-qmin, 0.03 ), 30.0)*dzk

           elt = elt +qdz*zwk

           vsc = vsc +qdz

           k   = k+1

           zwk = zw(k)

        END DO


        elt = min( max(alp1*elt/vsc, 10.), 400.)

        !avoid use of buoyancy flux functions which are ill-defined at the surface

        !vflx = ( vt(kts)+1.0 )*flt +( vq(kts)+tv0 )*flq

        vflx = fltv

        vsc = ( gtr*elt*max( vflx, 0.0 ) )**onethird


        !   **  Strictly, el(i,j,1) is not zero.  **

        el(kts) = 0.0

        zwk1    = zw(kts+1)


        DO k = kts+1,kte

           zwk = zw(k)              !full-sigma levels

           dzk = 0.5*( dz(k)+dz(k-1) )

           cldavg = 0.5*(cldfra_bl1d(k-1)+cldfra_bl1d(k))


           !   **  Length scale limited by the buoyancy effect  **

           IF ( dtv(k) .GT. 0.0 ) THEN

              !impose min value on bv

              bv  = max( sqrt( gtr*dtv(k) ), 0.001)

              !elb_mf = alp2*qkw(k) / bv  &

              elb_mf = max(alp2*qkw(k),                    &

                  &    alp6*edmf_a1(k-1)*edmf_w1(k-1)) / bv    &

                  &  *( 1.0 + alp3*sqrt( vsc/( bv*elt ) ) )

              elb = min(max(alp5*qkw(k), alp6*edmf_a1(k)*edmf_w1(k))/bv, zwk)


              !tau_cloud = MIN(MAX(0.5*zi/((gtr*zi*MAX(vflx,1.0e-4))**onethird),30.),150.)

              wstar = 1.25*(gtr*zi*max(vflx,1.0e-4))**onethird

              tau_cloud = min(max(ctau * wstar/grav, 30.), 150.)

              !minimize influence of surface heat flux on tau far away from the PBLH.

              wt=.5*tanh((zwk - (zi2+h1))/h2) + .5

              tau_cloud = tau_cloud*(1.-wt) + 50.*wt

              elf = min(max(tau_cloud*sqrt(min(qtke(k),40.)), &

                  &         alp6*edmf_a1(k)*edmf_w1(k)/bv), zwk)


              !IF (zwk > zi .AND. elf > 400.) THEN

              !   ! COMPUTE BouLac mixing length

              !   !CALL boulac_length0(k,kts,kte,zw,dz,qtke,thetaw,elBLmin0,elBLavg0)

              !   !elf = alp5*elBLavg0

              !   elf = MIN(MAX(50.*SQRT(qtke(k)), 400.), zwk)

              !ENDIF


           ELSE

              ! use version in development for RAP/HRRR 2016

              ! JAYMES-

              ! tau_cloud is an eddy turnover timescale;

              ! see Teixeira and Cheinet (2004), Eq. 1, and

              ! Cheinet and Teixeira (2003), Eq. 7.  The

              ! coefficient 0.5 is tuneable. Expression in

              ! denominator is identical to vsc (a convective

              ! velocity scale), except that elt is relpaced

              ! by zi, and zero is replaced by 1.0e-4 to

              ! prevent division by zero.

              !tau_cloud = MIN(MAX(0.5*zi/((gtr*zi*MAX(vflx,1.0e-4))**onethird),50.),150.)

              wstar = 1.25*(gtr*zi*max(vflx,1.0e-4))**onethird

              tau_cloud = min(max(ctau * wstar/grav, 50.), 200.)

              !minimize influence of surface heat flux on tau far away from the PBLH.

              wt=.5*tanh((zwk - (zi2+h1))/h2) + .5

              !tau_cloud = tau_cloud*(1.-wt) + 50.*wt

              tau_cloud = tau_cloud*(1.-wt) + max(100.,dzk*0.25)*wt


              elb = min(tau_cloud*sqrt(min(qtke(k),40.)), zwk)

              !elf = elb

              elf = elb !/(1. + (elb/800.))  !bound free-atmos mixing length to < 800 m.

              elb_mf = elb

         END IF

         elf    = elf/(1. + (elf/800.))  !bound free-atmos mixing length to < 800 m.

         elb_mf = max(elb_mf, 0.01) !to avoid divide-by-zero below


         !   **  Length scale in the surface layer  **

         IF ( rmo .GT. 0.0 ) THEN

            els  = karman*zwk/(1.0+cns*min( zwk*rmo, zmax ))

         ELSE

            els  =  karman*zwk*( 1.0 - alp4* zwk*rmo )**0.2

         END IF


         !   ** NOW BLEND THE MIXING LENGTH SCALES:

         wt=.5*tanh((zwk - (zi2+h1))/h2) + .5


         !try squared-blending

         el(k) = sqrt( els**2/(1. + (els**2/elt**2) +(els**2/elb_mf**2)))

         el(k) = el(k)*(1.-wt) + elf*wt


         ! include scale-awareness. For now, use simple asymptotic kz -> 12 m (should be ~dz).

         el_les= min(els/(1. + (els/12.)), elb_mf)

         el(k) = el(k)*psig_bl + (1.-psig_bl)*el_les


       END DO


    END SELECT


#ifdef HARDCODE_VERTICAL

# undef kts

# undef kte

#endif


  END SUBROUTINE mym_length


! ==================================================================

!\param dlu  the distance a parcel can be lifted upwards give a finite

!  amount of TKE.

!\param dld  the distance a parcel can be displaced downwards given a

!  finite amount of TKE.

!\param lb1  the minimum of the length up and length down

!\param lb2  the average of the length up and length down


  SUBROUTINE boulac_length0(k,kts,kte,zw,dz,qtke,theta,lb1,lb2)

!

!    NOTE: This subroutine was taken from the BouLac scheme in WRF-ARW

!          and modified for integration into the MYNN PBL scheme.

!          WHILE loops were added to reduce the computational expense.

!          This subroutine computes the length scales up and down

!          and then computes the min, average of the up/down

!          length scales, and also considers the distance to the

!          surface.

!

!      dlu = the distance a parcel can be lifted upwards give a finite

!            amount of TKE.

!      dld = the distance a parcel can be displaced downwards given a

!            finite amount of TKE.

!      lb1 = the minimum of the length up and length down

!      lb2 = the average of the length up and length down

!-------------------------------------------------------------------


     integer, intent(in) :: k,kts,kte

     real(kind_phys), dimension(kts:kte), intent(in) :: qtke,dz,theta

     real(kind_phys), intent(out) :: lb1,lb2

     real(kind_phys), dimension(kts:kte+1), intent(in) :: zw


     !LOCAL VARS

     integer :: izz, found

     real(kind_phys):: dlu,dld

     real(kind_phys):: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz


     !----------------------------------

     ! FIND DISTANCE UPWARD

     !----------------------------------

     zup=0.

     dlu=zw(kte+1)-zw(k)-dz(k)*0.5

     zzz=0.

     zup_inf=0.

     beta=gtr           !Buoyancy coefficient (g/tref)


     !print*,"FINDING Dup, k=",k," zw=",zw(k)


     if (k .lt. kte) then      !cant integrate upwards from highest level

        found = 0

        izz=k

        DO WHILE (found .EQ. 0)


           if (izz .lt. kte) then

              dzt=dz(izz)                   ! layer depth above

              zup=zup-beta*theta(k)*dzt     ! initial PE the parcel has at k

              !print*,"  ",k,izz,theta(izz),dz(izz)

              zup=zup+beta*(theta(izz+1)+theta(izz))*dzt*0.5 ! PE gained by lifting a parcel to izz+1

              zzz=zzz+dzt                   ! depth of layer k to izz+1

              !print*,"  PE=",zup," TKE=",qtke(k)," z=",zw(izz)

              if (qtke(k).lt.zup .and. qtke(k).ge.zup_inf) then

                 bbb=(theta(izz+1)-theta(izz))/dzt

                 if (bbb .ne. 0.) then

                    !fractional distance up into the layer where TKE becomes < PE

                    tl=(-beta*(theta(izz)-theta(k)) + &

                      & sqrt( max(0.,(beta*(theta(izz)-theta(k)))**2 + &

                      &       2.*bbb*beta*(qtke(k)-zup_inf))))/bbb/beta

                 else

                    if (theta(izz) .ne. theta(k))then

                       tl=(qtke(k)-zup_inf)/(beta*(theta(izz)-theta(k)))

                    else

                       tl=0.

                    endif

                 endif

                 dlu=zzz-dzt+tl

                 !print*,"  FOUND Dup:",dlu," z=",zw(izz)," tl=",tl

                 found =1

              endif

              zup_inf=zup

              izz=izz+1

           ELSE

              found = 1

           ENDIF


        ENDDO


     endif


     !----------------------------------

     ! FIND DISTANCE DOWN

     !----------------------------------

     zdo=0.

     zdo_sup=0.

     dld=zw(k)

     zzz=0.


     !print*,"FINDING Ddown, k=",k," zwk=",zw(k)

     if (k .gt. kts) then  !cant integrate downwards from lowest level


        found = 0

        izz=k

        DO WHILE (found .EQ. 0)


           if (izz .gt. kts) then

              dzt=dz(izz-1)

              zdo=zdo+beta*theta(k)*dzt

              !print*,"  ",k,izz,theta(izz),dz(izz-1)

              zdo=zdo-beta*(theta(izz-1)+theta(izz))*dzt*0.5

              zzz=zzz+dzt

              !print*,"  PE=",zdo," TKE=",qtke(k)," z=",zw(izz)

              if (qtke(k).lt.zdo .and. qtke(k).ge.zdo_sup) then

                 bbb=(theta(izz)-theta(izz-1))/dzt

                 if (bbb .ne. 0.) then

                    tl=(beta*(theta(izz)-theta(k))+ &

                      & sqrt( max(0.,(beta*(theta(izz)-theta(k)))**2 + &

                      &       2.*bbb*beta*(qtke(k)-zdo_sup))))/bbb/beta

                 else

                    if (theta(izz) .ne. theta(k)) then

                       tl=(qtke(k)-zdo_sup)/(beta*(theta(izz)-theta(k)))

                    else

                       tl=0.

                    endif

                 endif

                 dld=zzz-dzt+tl

                 !print*,"  FOUND Ddown:",dld," z=",zw(izz)," tl=",tl

                 found = 1

              endif

              zdo_sup=zdo

              izz=izz-1

           ELSE

              found = 1

           ENDIF

        ENDDO


     endif


     !----------------------------------

     ! GET MINIMUM (OR AVERAGE)

     !----------------------------------

     !The surface layer length scale can exceed z for large z/L,

     !so keep maximum distance down > z.

     dld = min(dld,zw(k+1))!not used in PBL anyway, only free atmos

     lb1 = min(dlu,dld)     !minimum

     !JOE-fight floating point errors

     dlu=max(0.1,min(dlu,1000.))

     dld=max(0.1,min(dld,1000.))

     lb2 = sqrt(dlu*dld)    !average - biased towards smallest

     !lb2 = 0.5*(dlu+dld)   !average


     if (k .eq. kte) then

        lb1 = 0.

        lb2 = 0.

     endif

     !print*,"IN MYNN-BouLac",k,lb1

     !print*,"IN MYNN-BouLac",k,dld,dlu


  END SUBROUTINE boulac_length0


! ==================================================================


  SUBROUTINE boulac_length(kts,kte,zw,dz,qtke,theta,lb1,lb2)

!      dlu = the distance a parcel can be lifted upwards give a finite

!            amount of TKE.

!      dld = the distance a parcel can be displaced downwards given a

!            finite amount of TKE.

!      lb1 = the minimum of the length up and length down

!      lb2 = the average of the length up and length down

!-------------------------------------------------------------------


     integer, intent(in) :: kts,kte

     real(kind_phys), dimension(kts:kte),   intent(in) :: qtke,dz,theta

     real(kind_phys), dimension(kts:kte),   intent(out):: lb1,lb2

     real(kind_phys), dimension(kts:kte+1), intent(in) :: zw


     !LOCAL VARS

     integer :: iz, izz, found

     real(kind_phys), dimension(kts:kte) :: dlu,dld

     real(kind_phys), parameter :: Lmax=2000.  !soft limit

     real(kind_phys):: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz


     !print*,"IN MYNN-BouLac",kts, kte


     do iz=kts,kte


        !----------------------------------

        ! FIND DISTANCE UPWARD

        !----------------------------------

        zup=0.

        dlu(iz)=zw(kte+1)-zw(iz)-dz(iz)*0.5

        zzz=0.

        zup_inf=0.

        beta=gtr           !Buoyancy coefficient (g/tref)


        !print*,"FINDING Dup, k=",iz," zw=",zw(iz)


        if (iz .lt. kte) then      !cant integrate upwards from highest level


          found = 0

          izz=iz

          DO WHILE (found .EQ. 0)


            if (izz .lt. kte) then

              dzt=dz(izz)                    ! layer depth above

              zup=zup-beta*theta(iz)*dzt     ! initial PE the parcel has at iz

              !print*,"  ",iz,izz,theta(izz),dz(izz)

              zup=zup+beta*(theta(izz+1)+theta(izz))*dzt*0.5 ! PE gained by lifting a parcel to izz+1

              zzz=zzz+dzt                   ! depth of layer iz to izz+1

              !print*,"  PE=",zup," TKE=",qtke(iz)," z=",zw(izz)

              if (qtke(iz).lt.zup .and. qtke(iz).ge.zup_inf) then

                 bbb=(theta(izz+1)-theta(izz))/dzt

                 if (bbb .ne. 0.) then

                    !fractional distance up into the layer where TKE becomes < PE

                    tl=(-beta*(theta(izz)-theta(iz)) + &

                      & sqrt( max(0.,(beta*(theta(izz)-theta(iz)))**2 + &

                      &       2.*bbb*beta*(qtke(iz)-zup_inf))))/bbb/beta

                 else

                    if (theta(izz) .ne. theta(iz))then

                       tl=(qtke(iz)-zup_inf)/(beta*(theta(izz)-theta(iz)))

                    else

                       tl=0.

                    endif

                 endif

                 dlu(iz)=zzz-dzt+tl

                 !print*,"  FOUND Dup:",dlu(iz)," z=",zw(izz)," tl=",tl

                 found =1

              endif

              zup_inf=zup

              izz=izz+1

             ELSE

              found = 1

            ENDIF


          ENDDO


        endif


        !----------------------------------

        ! FIND DISTANCE DOWN

        !----------------------------------

        zdo=0.

        zdo_sup=0.

        dld(iz)=zw(iz)

        zzz=0.


        !print*,"FINDING Ddown, k=",iz," zwk=",zw(iz)

        if (iz .gt. kts) then  !cant integrate downwards from lowest level


          found = 0

          izz=iz

          DO WHILE (found .EQ. 0)


            if (izz .gt. kts) then

              dzt=dz(izz-1)

              zdo=zdo+beta*theta(iz)*dzt

              !print*,"  ",iz,izz,theta(izz),dz(izz-1)

              zdo=zdo-beta*(theta(izz-1)+theta(izz))*dzt*0.5

              zzz=zzz+dzt

              !print*,"  PE=",zdo," TKE=",qtke(iz)," z=",zw(izz)

              if (qtke(iz).lt.zdo .and. qtke(iz).ge.zdo_sup) then

                 bbb=(theta(izz)-theta(izz-1))/dzt

                 if (bbb .ne. 0.) then

                    tl=(beta*(theta(izz)-theta(iz))+ &

                      & sqrt( max(0.,(beta*(theta(izz)-theta(iz)))**2 + &

                      &       2.*bbb*beta*(qtke(iz)-zdo_sup))))/bbb/beta

                 else

                    if (theta(izz) .ne. theta(iz)) then

                       tl=(qtke(iz)-zdo_sup)/(beta*(theta(izz)-theta(iz)))

                    else

                       tl=0.

                    endif

                 endif

                 dld(iz)=zzz-dzt+tl

                 !print*,"  FOUND Ddown:",dld(iz)," z=",zw(izz)," tl=",tl

                 found = 1

              endif

              zdo_sup=zdo

              izz=izz-1

            ELSE

              found = 1

            ENDIF

          ENDDO


        endif


        !----------------------------------

        ! GET MINIMUM (OR AVERAGE)

        !----------------------------------

        !The surface layer length scale can exceed z for large z/L,

        !so keep maximum distance down > z.

        dld(iz) = min(dld(iz),zw(iz+1))!not used in PBL anyway, only free atmos

        lb1(iz) = min(dlu(iz),dld(iz))     !minimum

        !JOE-fight floating point errors

        dlu(iz)=max(0.1,min(dlu(iz),1000.))

        dld(iz)=max(0.1,min(dld(iz),1000.))

        lb2(iz) = sqrt(dlu(iz)*dld(iz))    !average - biased towards smallest

        !lb2(iz) = 0.5*(dlu(iz)+dld(iz))   !average


        !Apply soft limit (only impacts very large lb; lb=100 by 5%, lb=500 by 20%).

        lb1(iz) = lb1(iz)/(1. + (lb1(iz)/lmax))

        lb2(iz) = lb2(iz)/(1. + (lb2(iz)/lmax))


        if (iz .eq. kte) then

           lb1(kte) = lb1(kte-1)

           lb2(kte) = lb2(kte-1)

        endif

        !print*,"IN MYNN-BouLac",kts, kte,lb1(iz)

        !print*,"IN MYNN-BouLac",iz,dld(iz),dlu(iz)


     ENDDO


  END SUBROUTINE boulac_length

!

! ==================================================================

!     SUBROUTINE  mym_turbulence:

!

!     Input variables:    see subroutine mym_initialize

!       closure        : closure level (2.5, 2.6, or 3.0)

!

!     # ql, vt, vq, qke, tsq, qsq and cov are changed to input variables.

!

!     Output variables:   see subroutine mym_initialize

!       dfm(nx,nz,ny) : Diffusivity coefficient for momentum,

!                         divided by dz (not dz*h(i,j))            (m/s)

!       dfh(nx,nz,ny) : Diffusivity coefficient for heat,

!                         divided by dz (not dz*h(i,j))            (m/s)

!       dfq(nx,nz,ny) : Diffusivity coefficient for q^2,

!                         divided by dz (not dz*h(i,j))            (m/s)

!       tcd(nx,nz,ny)   : Countergradient diffusion term for Theta_l

!                                                                  (K/s)

!       qcd(nx,nz,ny)   : Countergradient diffusion term for Q_w

!                                                              (kg/kg s)

!       pd?(nx,nz,ny) : Half of the production terms

!

!       Only tcd and qcd are defined at the center of the grid boxes

!

!     # DO NOT forget that tcd and qcd are added on the right-hand side

!       of the equations for Theta_l and Q_w, respectively.

!

!     Work arrays:        see subroutine mym_initialize and level2

!

!     # dtl, dqw, dtv, gm and gh are allowed to share storage units with

!       dfm, dfh, dfq, tcd and qcd, respectively, for saving memory.

!


  SUBROUTINE  mym_turbulence (                                &

    &            kts,kte,                                     &

    &            xland,closure,                               &

    &            dz, dx, zw,                                  &

    &            u, v, thl, thetav, ql, qw,                   &

    &            qke, tsq, qsq, cov,                          &

    &            vt, vq,                                      &

    &            rmo, flt, fltv, flq,                         &

    &            zi,theta,                                    &

    &            sh, sm,                                      &

    &            El,                                          &

    &            Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc, &

    &        qWT1D,qSHEAR1D,qBUOY1D,qDISS1D,              &

    &            tke_budget,                                  &

    &            Psig_bl,Psig_shcu,cldfra_bl1D,               &

    &            bl_mynn_mixlength,                           &

    &            edmf_w1,edmf_a1,                             &

    &            TKEprodTD,                                   &

    &            spp_pbl,rstoch_col                           )


!-------------------------------------------------------------------


    integer, intent(in)   :: kts,kte


#ifdef HARDCODE_VERTICAL

# define kts 1

# define kte HARDCODE_VERTICAL

#endif


    integer, intent(in)               :: bl_mynn_mixlength,tke_budget

    real(kind_phys), intent(in)       :: closure

    real(kind_phys), dimension(kts:kte),   intent(in) :: dz

    real(kind_phys), dimension(kts:kte+1), intent(in) :: zw

    real(kind_phys), intent(in)       :: rmo,flt,fltv,flq,                 &

         &Psig_bl,Psig_shcu,xland,dx,zi

    real(kind_phys), dimension(kts:kte), intent(in) :: u,v,thl,thetav,qw,  &

         &ql,vt,vq,qke,tsq,qsq,cov,cldfra_bl1D,edmf_w1,edmf_a1,            &

         &TKEprodTD


    real(kind_phys), dimension(kts:kte), intent(out) :: dfm,dfh,dfq,       &

         &pdk,pdt,pdq,pdc,tcd,qcd,el


    real(kind_phys), dimension(kts:kte), intent(inout) ::                  &

         qWT1D,qSHEAR1D,qBUOY1D,qDISS1D

    real(kind_phys):: q3sq_old,dlsq1,qWTP_old,qWTP_new

    real(kind_phys):: dudz,dvdz,dTdz,upwp,vpwp,Tpwp


    real(kind_phys), dimension(kts:kte) :: qkw,dtl,dqw,dtv,gm,gh,sm,sh


    integer :: k

!    real(kind_phys):: cc2,cc3,e1c,e2c,e3c,e4c,e5c

    real(kind_phys):: e6c,dzk,afk,abk,vtt,vqq,                             &

         &cw25,clow,cupp,gamt,gamq,smd,gamv,elq,elh


    real(kind_phys):: cldavg

    real(kind_phys), dimension(kts:kte), intent(in) :: theta


    real(kind_phys)::  a2fac, duz, ri !JOE-Canuto/Kitamura mod


    real:: auh,aum,adh,adm,aeh,aem,Req,Rsl,Rsl2,                           &

           gmelq,sm20,sh20,sm25max,sh25max,sm25min,sh25min,                &

           sm_pbl,sh_pbl,zi2,wt,slht,wtpr


    DOUBLE PRECISION  q2sq, t2sq, r2sq, c2sq, elsq, gmel, ghel

    DOUBLE PRECISION  q3sq, t3sq, r3sq, c3sq, dlsq, qdiv

    DOUBLE PRECISION  e1, e2, e3, e4, enum, eden, wden


!   Stochastic

    integer,         intent(in)                   ::    spp_pbl

    real(kind_phys), dimension(kts:kte)           ::    rstoch_col

    real(kind_phys):: Prnum, shb

    real(kind_phys), parameter :: Prlimit = 5.0


!

!    tv0 = 0.61*tref

!    gtr = 9.81/tref

!

!    cc2 =  1.0-c2

!    cc3 =  1.0-c3

!    e1c =  3.0*a2*b2*cc3

!    e2c =  9.0*a1*a2*cc2

!    e3c =  9.0*a2*a2*cc2*( 1.0-c5 )

!    e4c = 12.0*a1*a2*cc2

!    e5c =  6.0*a1*a1

!


    CALL mym_level2 (kts,kte,                   &

    &            dz,                            &

    &            u, v, thl, thetav, qw,         &

    &            ql, vt, vq,                    &

    &            dtl, dqw, dtv, gm, gh, sm, sh  )

!

    CALL mym_length (                           &

    &            kts,kte,xland,                 &

    &            dz, dx, zw,                    &

    &            rmo, flt, fltv, flq,           &

    &            vt, vq,                        &

    &            u, v, qke,                     &

    &            dtv,                           &

    &            el,                            &

    &            zi,theta,                      &

    &            qkw,psig_bl,cldfra_bl1d,       &

    &            bl_mynn_mixlength,             &

    &            edmf_w1,edmf_a1                )

!


    DO k = kts+1,kte

       dzk = 0.5  *( dz(k)+dz(k-1) )

       afk = dz(k)/( dz(k)+dz(k-1) )

       abk = 1.0 -afk

       elsq = el(k)**2

       q3sq = qkw(k)**2

       q2sq = b1*elsq*( sm(k)*gm(k)+sh(k)*gh(k) )


       sh20 = max(sh(k), 1e-5)

       sm20 = max(sm(k), 1e-5)

       sh(k)= max(sh(k), 1e-5)


       !Canuto/Kitamura mod

       duz = ( u(k)-u(k-1) )**2 +( v(k)-v(k-1) )**2

       duz =   duz                    /dzk**2

       !   **  Gradient Richardson number  **

       ri = -gh(k)/max( duz, 1.0e-10 )

       IF (ckmod .eq. 1) THEN

          a2fac = 1./(1. + max(ri,0.0))

       ELSE

          a2fac = 1.

       ENDIF

       !end Canuto/Kitamura mod


       !level 2.0 Prandtl number

       !Prnum = MIN(sm20/sh20, 4.0)

       !The form of Zilitinkevich et al. (2006) but modified

       !half-way towards Esau and Grachev (2007, Wind Eng)

       !Prnum = MIN(0.76 + 3.0*MAX(ri,0.0), Prlimit)

       prnum = min(0.76 + 4.0*max(ri,0.0), prlimit)

       !Prnum = MIN(0.76 + 5.0*MAX(ri,0.0), Prlimit)

!

!  Modified: Dec/22/2005, from here, (dlsq -> elsq)

       gmel = gm(k)*elsq

       ghel = gh(k)*elsq

!  Modified: Dec/22/2005, up to here


       ! Level 2.0 debug prints

       IF ( debug_code ) THEN

         IF (sh(k)<0.0 .OR. sm(k)<0.0) THEN

           print*,"MYNN; mym_turbulence 2.0; sh=",sh(k)," k=",k

           print*," gm=",gm(k)," gh=",gh(k)," sm=",sm(k)

           print*," q2sq=",q2sq," q3sq=",q3sq," q3/q2=",q3sq/q2sq

           print*," qke=",qke(k)," el=",el(k)," ri=",ri

           print*," PBLH=",zi," u=",u(k)," v=",v(k)

         ENDIF

       ENDIF


!     **  Since qkw is set to more than 0.0, q3sq > 0.0.  **


!     new stability criteria in level 2.5 (as well as level 3) - little/no impact

!     **  Limitation on q, instead of L/q  **

       dlsq =  elsq

       IF ( q3sq/dlsq .LT. -gh(k) ) q3sq = -dlsq*gh(k)


       IF ( q3sq .LT. q2sq ) THEN

          !Apply Helfand & Labraga mod

          qdiv = sqrt( q3sq/q2sq )   !HL89: (1-alfa)

!

          !Use level 2.5 stability functions

          !e1   = q3sq - e1c*ghel*a2fac

          !e2   = q3sq - e2c*ghel*a2fac

          !e3   = e1   + e3c*ghel*a2fac**2

          !e4   = e1   - e4c*ghel*a2fac

          !eden = e2*e4 + e3*e5c*gmel

          !eden = MAX( eden, 1.0d-20 )

          !sm(k) = q3sq*a1*( e3-3.0*c1*e4       )/eden

          !!JOE-Canuto/Kitamura mod

          !!sh(k) = q3sq*a2*( e2+3.0*c1*e5c*gmel )/eden

          !sh(k) = q3sq*(a2*a2fac)*( e2+3.0*c1*e5c*gmel )/eden

          !sm(k) = Prnum*sh(k)

          !sm(k) = sm(k) * qdiv


          !Use level 2.0 functions as in original MYNN

          sh(k) = sh(k) * qdiv

          sm(k) = sm(k) * qdiv

        !  !sm_pbl = sm(k) * qdiv

        !

        !  !Or, use the simple Pr relationship

        !  sm(k) = Prnum*sh(k)

        !

        !  !or blend them:

        !  zi2   = MAX(zi, 300.)

        !  wt    =.5*TANH((zw(k) - zi2)/200.) + .5

        !  sm(k) = sm_pbl*(1.-wt) + sm(k)*wt


          !Recalculate terms for later use

          !JOE-Canuto/Kitamura mod

          !e1   = q3sq - e1c*ghel * qdiv**2

          !e2   = q3sq - e2c*ghel * qdiv**2

          !e3   = e1   + e3c*ghel * qdiv**2

          !e4   = e1   - e4c*ghel * qdiv**2

          e1   = q3sq - e1c*ghel*a2fac * qdiv**2

          e2   = q3sq - e2c*ghel*a2fac * qdiv**2

          e3   = e1   + e3c*ghel*a2fac**2 * qdiv**2

          e4   = e1   - e4c*ghel*a2fac * qdiv**2

          eden = e2*e4 + e3*e5c*gmel * qdiv**2

          eden = max( eden, 1.0d-20 )

          !!JOE-Canuto/Kitamura mod

          !!sh(k) = q3sq*a2*( e2+3.0*c1*e5c*gmel )/eden  - retro 5

          !sh(k) = q3sq*(a2*a2fac)*( e2+3.0*c1*e5c*gmel )/eden

          !sm(k) = Prnum*sh(k)

       ELSE

          !JOE-Canuto/Kitamura mod

          !e1   = q3sq - e1c*ghel

          !e2   = q3sq - e2c*ghel

          !e3   = e1   + e3c*ghel

          !e4   = e1   - e4c*ghel

          e1   = q3sq - e1c*ghel*a2fac

          e2   = q3sq - e2c*ghel*a2fac

          e3   = e1   + e3c*ghel*a2fac**2

          e4   = e1   - e4c*ghel*a2fac

          eden = e2*e4 + e3*e5c*gmel

          eden = max( eden, 1.0d-20 )


          qdiv = 1.0

          !Use level 2.5 stability functions

          sm(k) = q3sq*a1*( e3-3.0*c1*e4       )/eden

        !  sm_pbl = q3sq*a1*( e3-3.0*c1*e4       )/eden

          !!JOE-Canuto/Kitamura mod

          !!sh(k) = q3sq*a2*( e2+3.0*c1*e5c*gmel )/eden

          sh(k) = q3sq*(a2*a2fac)*( e2+3.0*c1*e5c*gmel )/eden

        !  sm(k) = Prnum*sh(k)


        !  !or blend them:

        !  zi2   = MAX(zi, 300.)

        !  wt    = .5*TANH((zw(k) - zi2)/200.) + .5

        !  sm(k) = sm_pbl*(1.-wt) + sm(k)*wt

       END IF !end Helfand & Labraga check


       !Impose broad limits on Sh and Sm:

       gmelq    = max(gmel/q3sq, 1e-8)

       sm25max  = 4.  !MIN(sm20*3.0, SQRT(.1936/gmelq))

       sh25max  = 4.  !MIN(sh20*3.0, 0.76*b2)

       sm25min  = 0.0 !MAX(sm20*0.1, 1e-6)

       sh25min  = 0.0 !MAX(sh20*0.1, 1e-6)


       !JOE: Level 2.5 debug prints

       ! HL88 , lev2.5 criteria from eqs. 3.17, 3.19, & 3.20

       IF ( debug_code ) THEN

         IF ((sh(k)<sh25min .OR. sm(k)<sm25min .OR. &

              sh(k)>sh25max .OR. sm(k)>sm25max) ) THEN

           print*,"In mym_turbulence 2.5: k=",k

           print*," sm=",sm(k)," sh=",sh(k)

           print*," ri=",ri," Pr=",sm(k)/max(sh(k),1e-8)

           print*," gm=",gm(k)," gh=",gh(k)

           print*," q2sq=",q2sq," q3sq=",q3sq, q3sq/q2sq

           print*," qke=",qke(k)," el=",el(k)

           print*," PBLH=",zi," u=",u(k)," v=",v(k)

           print*," SMnum=",q3sq*a1*( e3-3.0*c1*e4)," SMdenom=",eden

           print*," SHnum=",q3sq*(a2*a2fac)*( e2+3.0*c1*e5c*gmel ),&

                  " SHdenom=",eden

         ENDIF

       ENDIF


       !Enforce constraints for level 2.5 functions

       IF ( sh(k) > sh25max ) sh(k) = sh25max

       IF ( sh(k) < sh25min ) sh(k) = sh25min

       !IF ( sm(k) > sm25max ) sm(k) = sm25max

       !IF ( sm(k) < sm25min ) sm(k) = sm25min

       !sm(k) = Prnum*sh(k)


       !surface layer PR

       !slht  = zi*0.1

       !wtpr  = min( max( (slht - zw(k))/slht, 0.0), 1.0) ! 1 at z=0, 0 above sfc layer

       !Prlim = 1.0*wtpr + (1.0 - wtpr)*Prlimit

       !Prlim = 2.0*wtpr + (1.0 - wtpr)*Prlimit

       !sm(k) = MIN(sm(k), Prlim*Sh(k))

       !Pending more testing, keep same Pr limit in sfc layer

       shb   = max(sh(k), 0.002)

       sm(k) = min(sm(k), prlimit*shb)


!   **  Level 3 : start  **

       IF ( closure .GE. 3.0 ) THEN

          t2sq = qdiv*b2*elsq*sh(k)*dtl(k)**2

          r2sq = qdiv*b2*elsq*sh(k)*dqw(k)**2

          c2sq = qdiv*b2*elsq*sh(k)*dtl(k)*dqw(k)

          t3sq = max( tsq(k)*abk+tsq(k-1)*afk, 0.0 )

          r3sq = max( qsq(k)*abk+qsq(k-1)*afk, 0.0 )

          c3sq =      cov(k)*abk+cov(k-1)*afk


!  Modified: Dec/22/2005, from here

          c3sq = sign( min( abs(c3sq), sqrt(t3sq*r3sq) ), c3sq )

!

          vtt  = 1.0 +vt(k)*abk +vt(k-1)*afk

          vqq  = tv0 +vq(k)*abk +vq(k-1)*afk


          t2sq = vtt*t2sq +vqq*c2sq

          r2sq = vtt*c2sq +vqq*r2sq

          c2sq = max( vtt*t2sq+vqq*r2sq, 0.0d0 )

          t3sq = vtt*t3sq +vqq*c3sq

          r3sq = vtt*c3sq +vqq*r3sq

          c3sq = max( vtt*t3sq+vqq*r3sq, 0.0d0 )

!

          cw25 = e1*( e2 + 3.0*c1*e5c*gmel*qdiv**2 )/( 3.0*eden )

!

!     **  Limitation on q, instead of L/q  **

          dlsq =  elsq

          IF ( q3sq/dlsq .LT. -gh(k) ) q3sq = -dlsq*gh(k)

!

!     **  Limitation on c3sq (0.12 =< cw =< 0.76) **

          ! Use Janjic's (2001; p 13-17) methodology (eqs 4.11-414 and 5.7-5.10)

          ! to calculate an exact limit for c3sq:

          auh = 27.*a1*((a2*a2fac)**2)*b2*(gtr)**2

          aum = 54.*(a1**2)*(a2*a2fac)*b2*c1*(gtr)

          adh = 9.*a1*((a2*a2fac)**2)*(12.*a1 + 3.*b2)*(gtr)**2

          adm = 18.*(a1**2)*(a2*a2fac)*(b2 - 3.*(a2*a2fac))*(gtr)


          aeh = (9.*a1*((a2*a2fac)**2)*b1 +9.*a1*((a2*a2fac)**2)* &

                (12.*a1 + 3.*b2))*(gtr)

          aem = 3.*a1*(a2*a2fac)*b1*(3.*(a2*a2fac) + 3.*b2*c1 + &

                (18.*a1*c1 - b2)) + &

                (18.)*(a1**2)*(a2*a2fac)*(b2 - 3.*(a2*a2fac))


          req = -aeh/aem

          rsl = (auh + aum*req)/(3.*adh + 3.*adm*req)

          !For now, use default values, since tests showed little/no sensitivity

          rsl = .12             !lower limit

          rsl2= 1.0 - 2.*rsl    !upper limit

          !IF (k==2)print*,"Dynamic limit RSL=",Rsl

          !IF (Rsl < 0.10 .OR. Rsl > 0.18) THEN

          !   print*,'--- ERROR: MYNN: Dynamic Cw '// &

          !        'limit exceeds reasonable limits'

          !   print*," MYNN: Dynamic Cw limit needs attention=",Rsl

          !ENDIF


          !JOE-Canuto/Kitamura mod

          !e2   = q3sq - e2c*ghel * qdiv**2

          !e3   = q3sq + e3c*ghel * qdiv**2

          !e4   = q3sq - e4c*ghel * qdiv**2

          e2   = q3sq - e2c*ghel*a2fac * qdiv**2

          e3   = q3sq + e3c*ghel*a2fac**2 * qdiv**2

          e4   = q3sq - e4c*ghel*a2fac * qdiv**2

          eden = e2*e4  + e3 *e5c*gmel * qdiv**2


          !JOE-Canuto/Kitamura mod

          !wden = cc3*gtr**2 * dlsq**2/elsq * qdiv**2 &

          !     &        *( e2*e4c - e3c*e5c*gmel * qdiv**2 )

          wden = cc3*gtr**2 * dlsq**2/elsq * qdiv**2 &

               &        *( e2*e4c*a2fac - e3c*e5c*gmel*a2fac**2 * qdiv**2 )


          IF ( wden .NE. 0.0 ) THEN

             !JOE: test dynamic limits

             clow = q3sq*( 0.12-cw25 )*eden/wden

             cupp = q3sq*( 0.76-cw25 )*eden/wden

             !clow = q3sq*( Rsl -cw25 )*eden/wden

             !cupp = q3sq*( Rsl2-cw25 )*eden/wden

!

             IF ( wden .GT. 0.0 ) THEN

                c3sq  = min( max( c3sq, c2sq+clow ), c2sq+cupp )

             ELSE

                c3sq  = max( min( c3sq, c2sq+clow ), c2sq+cupp )

             END IF

          END IF

!

          e1   = e2 + e5c*gmel * qdiv**2

          eden = max( eden, 1.0d-20 )

!  Modified: Dec/22/2005, up to here


          !JOE-Canuto/Kitamura mod

          !e6c  = 3.0*a2*cc3*gtr * dlsq/elsq

          e6c  = 3.0*(a2*a2fac)*cc3*gtr * dlsq/elsq


          !============================

          !     **  for Gamma_theta  **

          !!          enum = qdiv*e6c*( t3sq-t2sq )

          IF ( t2sq .GE. 0.0 ) THEN

             enum = max( qdiv*e6c*( t3sq-t2sq ), 0.0d0 )

          ELSE

             enum = min( qdiv*e6c*( t3sq-t2sq ), 0.0d0 )

          ENDIF

          gamt =-e1  *enum    /eden


          !============================

          !     **  for Gamma_q  **

          !!          enum = qdiv*e6c*( r3sq-r2sq )

          IF ( r2sq .GE. 0.0 ) THEN

             enum = max( qdiv*e6c*( r3sq-r2sq ), 0.0d0 )

          ELSE

             enum = min( qdiv*e6c*( r3sq-r2sq ), 0.0d0 )

          ENDIF

          gamq =-e1  *enum    /eden


          !============================

          !     **  for Sm' and Sh'd(Theta_V)/dz  **

          !!          enum = qdiv*e6c*( c3sq-c2sq )

          enum = max( qdiv*e6c*( c3sq-c2sq ), 0.0d0)


          !JOE-Canuto/Kitamura mod

          !smd  = dlsq*enum*gtr/eden * qdiv**2 * (e3c+e4c)*a1/a2

          smd  = dlsq*enum*gtr/eden * qdiv**2 * (e3c*a2fac**2 + &

               & e4c*a2fac)*a1/(a2*a2fac)


          gamv = e1  *enum*gtr/eden

          sm(k) = sm(k) +smd


          !============================

          !     **  For elh (see below), qdiv at Level 3 is reset to 1.0.  **

          qdiv = 1.0


          ! Level 3 debug prints

          IF ( debug_code ) THEN

            IF (sh(k)<-0.3 .OR. sm(k)<-0.3 .OR. &

              qke(k) < -0.1 .or. abs(smd) .gt. 2.0) THEN

              print*," MYNN; mym_turbulence3.0; sh=",sh(k)," k=",k

              print*," gm=",gm(k)," gh=",gh(k)," sm=",sm(k)

              print*," q2sq=",q2sq," q3sq=",q3sq," q3/q2=",q3sq/q2sq

              print*," qke=",qke(k)," el=",el(k)," ri=",ri

              print*," PBLH=",zi," u=",u(k)," v=",v(k)

            ENDIF

          ENDIF


!   **  Level 3 : end  **


       ELSE

!     **  At Level 2.5, qdiv is not reset.  **

          gamt = 0.0

          gamq = 0.0

          gamv = 0.0

       END IF

!

!      Add min background stability function (diffusivity) within model levels

!      with active plumes and clouds.

       cldavg = 0.5*(cldfra_bl1d(k-1) + cldfra_bl1d(k))

       IF (edmf_a1(k) > 0.001 .OR. cldavg > 0.02) THEN

           ! for mass-flux columns

           sm(k) = max(sm(k), 0.03*min(10.*edmf_a1(k)*edmf_w1(k),1.0) )

           sh(k) = max(sh(k), 0.03*min(10.*edmf_a1(k)*edmf_w1(k),1.0) )

           ! for clouds

           sm(k) = max(sm(k), 0.05*min(cldavg,1.0) )

           sh(k) = max(sh(k), 0.05*min(cldavg,1.0) )

       ENDIF

!

       elq = el(k)*qkw(k)

       elh = elq*qdiv


       ! Production of TKE (pdk), T-variance (pdt),

       ! q-variance (pdq), and covariance (pdc)

       pdk(k) = elq*( sm(k)*gm(k)                &

            &        +sh(k)*gh(k)+gamv ) +       &

            &    0.5*tkeprodtd(k)        ! xmchen

       pdt(k) = elh*( sh(k)*dtl(k)+gamt )*dtl(k)

       pdq(k) = elh*( sh(k)*dqw(k)+gamq )*dqw(k)

       pdc(k) = elh*( sh(k)*dtl(k)+gamt )        &

            &   *dqw(k)*0.5                      &

            & + elh*( sh(k)*dqw(k)+gamq )*dtl(k)*0.5


       ! Contergradient terms

       tcd(k) = elq*gamt

       qcd(k) = elq*gamq


       ! Eddy Diffusivity/Viscosity divided by dz

       dfm(k) = elq*sm(k) / dzk

       dfh(k) = elq*sh(k) / dzk

!  Modified: Dec/22/2005, from here

!   **  In sub.mym_predict, dfq for the TKE and scalar variance **

!   **  are set to 3.0*dfm and 1.0*dfm, respectively. (Sqfac)   **

       dfq(k) =     dfm(k)

!  Modified: Dec/22/2005, up to here


   IF (tke_budget .eq. 1) THEN

       !TKE BUDGET

!       dudz = ( u(k)-u(k-1) )/dzk

!       dvdz = ( v(k)-v(k-1) )/dzk

!       dTdz = ( thl(k)-thl(k-1) )/dzk


!       upwp = -elq*sm(k)*dudz

!       vpwp = -elq*sm(k)*dvdz

!       Tpwp = -elq*sh(k)*dTdz

!       Tpwp = SIGN(MAX(ABS(Tpwp),1.E-6),Tpwp)


!!  TKE budget  (Puhales, 2020, WRF 4.2.1)  << EOB


       !!!Shear Term

       !!!qSHEAR1D(k)=-(upwp*dudz + vpwp*dvdz)

       qshear1d(k) = elq*sm(k)*gm(k) !staggered


       !!!Buoyancy Term

       !!!qBUOY1D(k)=grav*Tpwp/thl(k)

       !qBUOY1D(k)= elq*(sh(k)*gh(k) + gamv)

       !qBUOY1D(k) = elq*(sh(k)*(-dTdz*grav/thl(k)) + gamv) !! ORIGINAL CODE


       !! Buoyncy term takes the TKEprodTD(k) production now

       qbuoy1d(k) = elq*(sh(k)*gh(k)+gamv)+0.5*tkeprodtd(k) ! xmchen


       !!!Dissipation Term (now it evaluated in mym_predict)

       !qDISS1D(k) = (q3sq**(3./2.))/(b1*MAX(el(k),1.)) !! ORIGINAL CODE


       !! >> EOB

    ENDIF


    END DO

!


    dfm(kts) = 0.0

    dfh(kts) = 0.0

    dfq(kts) = 0.0

    tcd(kts) = 0.0

    qcd(kts) = 0.0


    tcd(kte) = 0.0

    qcd(kte) = 0.0


!

    DO k = kts,kte-1

       dzk = dz(k)

       tcd(k) = ( tcd(k+1)-tcd(k) )/( dzk )

       qcd(k) = ( qcd(k+1)-qcd(k) )/( dzk )

    END DO

!

    if (spp_pbl==1) then

       DO k = kts,kte

          dfm(k)= dfm(k) + dfm(k)* rstoch_col(k) * 1.5 * max(exp(-max(zw(k)-8000.,0.0)/2000.),0.001)

          dfh(k)= dfh(k) + dfh(k)* rstoch_col(k) * 1.5 * max(exp(-max(zw(k)-8000.,0.0)/2000.),0.001)

       END DO

    endif


!    RETURN

#ifdef HARDCODE_VERTICAL

# undef kts

# undef kte

#endif


  END SUBROUTINE mym_turbulence


! ==================================================================

!     SUBROUTINE  mym_predict:

!

!     Input variables:    see subroutine mym_initialize and turbulence

!       qke(nx,nz,ny) : qke at (n)th time level

!       tsq, ...cov     : ditto

!

!     Output variables:

!       qke(nx,nz,ny) : qke at (n+1)th time level

!       tsq, ...cov     : ditto

!

!     Work arrays:

!       qkw(nx,nz,ny)   : q at the center of the grid boxes        (m/s)

!       bp (nx,nz,ny)   : = 1/2*F,     see below

!       rp (nx,nz,ny)   : = P-1/2*F*Q, see below

!

!     # The equation for a turbulent quantity Q can be expressed as

!          dQ/dt + Ah + Av = Dh + Dv + P - F*Q,                      (1)

!       where A is the advection, D the diffusion, P the production,

!       F*Q the dissipation and h and v denote horizontal and vertical,

!       respectively. If Q is q^2, F is 2q/B_1L.

!       Using the Crank-Nicholson scheme for Av, Dv and F*Q, a finite

!       difference equation is written as

!          Q{n+1} - Q{n} = dt  *( Dh{n}   - Ah{n}   + P{n} )

!                        + dt/2*( Dv{n}   - Av{n}   - F*Q{n}   )

!                        + dt/2*( Dv{n+1} - Av{n+1} - F*Q{n+1} ),    (2)

!       where n denotes the time level.

!       When the advection and diffusion terms are discretized as

!          dt/2*( Dv - Av ) = a(k)Q(k+1) - b(k)Q(k) + c(k)Q(k-1),    (3)

!       Eq.(2) can be rewritten as

!          - a(k)Q(k+1) + [ 1 + b(k) + dt/2*F ]Q(k) - c(k)Q(k-1)

!                 = Q{n} + dt  *( Dh{n}   - Ah{n}   + P{n} )

!                        + dt/2*( Dv{n}   - Av{n}   - F*Q{n}   ),    (4)

!       where Q on the left-hand side is at (n+1)th time level.

!

!       In this subroutine, a(k), b(k) and c(k) are obtained from

!       subprogram coefvu and are passed to subprogram tinteg via

!       common. 1/2*F and P-1/2*F*Q are stored in bp and rp,

!       respectively. Subprogram tinteg solves Eq.(4).

!

!       Modify this subroutine according to your numerical integration

!       scheme (program).

!

!-------------------------------------------------------------------


  SUBROUTINE  mym_predict (kts,kte,                                     &

       &            closure,                                            &

       &            delt,                                               &

       &            dz,                                                 &

       &            ust, flt, flq, pmz, phh,                            &

       &            el,  dfq, rho,                                      &

       &            pdk, pdt, pdq, pdc,                                 &

       &            qke, tsq, qsq, cov,                                 &

       &            s_aw,s_awqke,bl_mynn_edmf_tke,                      &

       &            qWT1D, qDISS1D,tke_budget)  !! TKE budget  (Puhales, 2020)


!-------------------------------------------------------------------

    integer, intent(in) :: kts,kte


#ifdef HARDCODE_VERTICAL

# define kts 1

# define kte HARDCODE_VERTICAL

#endif


    real(kind_phys), intent(in)    :: closure

    integer, intent(in) :: bl_mynn_edmf_tke,tke_budget

    real(kind_phys), dimension(kts:kte), intent(in) :: dz, dfq, el, rho

    real(kind_phys), dimension(kts:kte), intent(inout) :: pdk, pdt, pdq, pdc

    real(kind_phys), intent(in)    :: flt, flq, pmz, phh

    real(kind_phys), intent(in)    :: ust, delt

    real(kind_phys), dimension(kts:kte), intent(inout) :: qke,tsq, qsq, cov

! WA 8/3/15

    real(kind_phys), dimension(kts:kte+1), intent(inout) :: s_awqke,s_aw


    !!  TKE budget  (Puhales, 2020, WRF 4.2.1)  << EOB

    real(kind_phys), dimension(kts:kte), intent(out) :: qWT1D, qDISS1D

    real(kind_phys), dimension(kts:kte) :: tke_up,dzinv

    !! >> EOB


    integer :: k

    real(kind_phys), dimension(kts:kte) :: qkw, bp, rp, df3q

    real(kind_phys):: vkz,pdk1,phm,pdt1,pdq1,pdc1,b1l,b2l,onoff

    real(kind_phys), dimension(kts:kte) :: dtz

    real(kind_phys), dimension(kts:kte) :: a,b,c,d,x


    real(kind_phys), dimension(kts:kte) :: rhoinv

    real(kind_phys), dimension(kts:kte+1) :: rhoz,kqdz,kmdz


    ! REGULATE THE MOMENTUM MIXING FROM THE MASS-FLUX SCHEME (on or off)

    IF (bl_mynn_edmf_tke == 0) THEN

       onoff=0.0

    ELSE

       onoff=1.0

    ENDIF


!   **  Strictly, vkz*h(i,j) -> karman*( 0.5*dz(1)*h(i,j)+z0 )  **

    vkz = karman*0.5*dz(kts)

!

!   **  dfq for the TKE is 3.0*dfm.  **

!

    DO k = kts,kte

!!       qke(k) = MAX(qke(k), 0.0)

       qkw(k) = sqrt( max( qke(k), 0.0 ) )

       df3q(k)=sqfac*dfq(k)

       dtz(k)=delt/dz(k)

    END DO

!

!JOE-add conservation + stability criteria

    !Prepare "constants" for diffusion equation.

    !khdz = rho*Kh/dz = rho*dfh

    rhoz(kts)  =rho(kts)

    rhoinv(kts)=1./rho(kts)

    kqdz(kts)  =rhoz(kts)*df3q(kts)

    kmdz(kts)  =rhoz(kts)*dfq(kts)

    DO k=kts+1,kte

       rhoz(k)  =(rho(k)*dz(k-1) + rho(k-1)*dz(k))/(dz(k-1)+dz(k))

       rhoz(k)  =  max(rhoz(k),1e-4)

       rhoinv(k)=1./max(rho(k),1e-4)

       kqdz(k)  = rhoz(k)*df3q(k) ! for TKE

       kmdz(k)  = rhoz(k)*dfq(k)  ! for T'2, q'2, and T'q'

    ENDDO

    rhoz(kte+1)=rhoz(kte)

    kqdz(kte+1)=rhoz(kte+1)*df3q(kte)

    kmdz(kte+1)=rhoz(kte+1)*dfq(kte)


    !stability criteria for mf

    DO k=kts+1,kte-1

       kqdz(k) = max(kqdz(k),  0.5* s_aw(k))

       kqdz(k) = max(kqdz(k), -0.5*(s_aw(k)-s_aw(k+1)))

       kmdz(k) = max(kmdz(k),  0.5* s_aw(k))

       kmdz(k) = max(kmdz(k), -0.5*(s_aw(k)-s_aw(k+1)))

    ENDDO

    !end conservation mods


    pdk1 = 2.0*ust**3*pmz/( vkz )

    phm  = 2.0/ust   *phh/( vkz )

    pdt1 = phm*flt**2

    pdq1 = phm*flq**2

    pdc1 = phm*flt*flq

!

!   **  pdk(1)+pdk(2) corresponds to pdk1.  **

    pdk(kts) = pdk1 - pdk(kts+1)


!!    pdt(kts) = pdt1 -pdt(kts+1)

!!    pdq(kts) = pdq1 -pdq(kts+1)

!!    pdc(kts) = pdc1 -pdc(kts+1)

    pdt(kts) = pdt(kts+1)

    pdq(kts) = pdq(kts+1)

    pdc(kts) = pdc(kts+1)

!

!   **  Prediction of twice the turbulent kinetic energy  **

!!    DO k = kts+1,kte-1

    DO k = kts,kte-1

       b1l = b1*0.5*( el(k+1)+el(k) )

       bp(k) = 2.*qkw(k) / b1l

       rp(k) = pdk(k+1) + pdk(k)

    END DO


!!    a(1)=0.

!!    b(1)=1.

!!    c(1)=-1.

!!    d(1)=0.


! Since df3q(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*df3q(k+1)+bp(k)*delt.

    DO k=kts,kte-1

!       a(k-kts+1)=-dtz(k)*df3q(k)

!       b(k-kts+1)=1.+dtz(k)*(df3q(k)+df3q(k+1))+bp(k)*delt

!       c(k-kts+1)=-dtz(k)*df3q(k+1)

!       d(k-kts+1)=rp(k)*delt + qke(k)

! WA 8/3/15 add EDMF contribution

!       a(k)=   - dtz(k)*df3q(k) + 0.5*dtz(k)*s_aw(k)*onoff

!       b(k)=1. + dtz(k)*(df3q(k)+df3q(k+1)) &

!               + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*onoff + bp(k)*delt

!       c(k)=   - dtz(k)*df3q(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff

!       d(k)=rp(k)*delt + qke(k) + dtz(k)*(s_awqke(k)-s_awqke(k+1))*onoff

!JOE 8/22/20 improve conservation

       a(k)=   - dtz(k)*kqdz(k)*rhoinv(k)                       &

           &   + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*onoff

       b(k)=1. + dtz(k)*(kqdz(k)+kqdz(k+1))*rhoinv(k)           &

           &   + 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*onoff &

           &   + bp(k)*delt

       c(k)=   - dtz(k)*kqdz(k+1)*rhoinv(k)                     &

           &   - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff

       d(k)=rp(k)*delt + qke(k)                                 &

           &   + dtz(k)*rhoinv(k)*(s_awqke(k)-s_awqke(k+1))*onoff

    ENDDO


!!    DO k=kts+1,kte-1

!!       a(k-kts+1)=-dtz(k)*df3q(k)

!!       b(k-kts+1)=1.+dtz(k)*(df3q(k)+df3q(k+1))

!!       c(k-kts+1)=-dtz(k)*df3q(k+1)

!!       d(k-kts+1)=rp(k)*delt + qke(k) - qke(k)*bp(k)*delt

!!    ENDDO


!! "no flux at top"

!    a(kte)=-1. !0.

!    b(kte)=1.

!    c(kte)=0.

!    d(kte)=0.

!! "prescribed value"

    a(kte)=0.

    b(kte)=1.

    c(kte)=0.

    d(kte)=qke(kte)


!    CALL tridiag(kte,a,b,c,d)

    CALL tridiag2(kte,a,b,c,d,x)


    DO k=kts,kte

!       qke(k)=max(d(k-kts+1), 1.e-4)

       qke(k)=max(x(k), 1.e-4)

       qke(k)=min(qke(k), 150.)

    ENDDO


!!  TKE budget  (Puhales, 2020, WRF 4.2.1)  << EOB

    IF (tke_budget .eq. 1) THEN

       !! TKE Vertical transport << EOBvt

        tke_up=0.5*qke

        dzinv=1./dz

        k=kts

        qwt1d(k)=dzinv(k)*(                                    &

            &  (kqdz(k+1)*(tke_up(k+1)-tke_up(k))-kqdz(k)*tke_up(k)) &

            &  + 0.5*rhoinv(k)*(s_aw(k+1)*tke_up(k+1)          &

            &  +      (s_aw(k+1)-s_aw(k))*tke_up(k)            &

            &  +      (s_awqke(k)-s_awqke(k+1)))*onoff) !unstaggered

        DO k=kts+1,kte-1

            qwt1d(k)=dzinv(k)*(                                &

            & (kqdz(k+1)*(tke_up(k+1)-tke_up(k))-kqdz(k)*(tke_up(k)-tke_up(k-1))) &

            &  + 0.5*rhoinv(k)*(s_aw(k+1)*tke_up(k+1)          &

            &  +      (s_aw(k+1)-s_aw(k))*tke_up(k)            &

            &  -                  s_aw(k)*tke_up(k-1)          &

            &  +      (s_awqke(k)-s_awqke(k+1)))*onoff) !unstaggered

        ENDDO

        k=kte

        qwt1d(k)=dzinv(k)*(-kqdz(k)*(tke_up(k)-tke_up(k-1)) &

            &  + 0.5*rhoinv(k)*(-s_aw(k)*tke_up(k)-s_aw(k)*tke_up(k-1)+s_awqke(k))*onoff) !unstaggered

        !!  >> EOBvt

        qdiss1d=bp*tke_up !! TKE dissipation rate !unstaggered

    END IF

!! >> EOB


    IF ( closure > 2.5 ) THEN


       !   **  Prediction of the moisture variance  **

       DO k = kts,kte-1

          b2l   = b2*0.5*( el(k+1)+el(k) )

          bp(k) = 2.*qkw(k) / b2l

          rp(k) = pdq(k+1) + pdq(k)

       END DO


       !zero gradient for qsq at bottom and top

       !a(1)=0.

       !b(1)=1.

       !c(1)=-1.

       !d(1)=0.


       ! Since dfq(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*dfq(k+1)+bp(k)*delt.

       DO k=kts,kte-1

          a(k)=   - dtz(k)*kmdz(k)*rhoinv(k)

          b(k)=1. + dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + bp(k)*delt

          c(k)=   - dtz(k)*kmdz(k+1)*rhoinv(k)

          d(k)=rp(k)*delt + qsq(k)

       ENDDO


       a(kte)=-1. !0.

       b(kte)=1.

       c(kte)=0.

       d(kte)=0.


!       CALL tridiag(kte,a,b,c,d)

    CALL tridiag2(kte,a,b,c,d,x)


       DO k=kts,kte

          !qsq(k)=d(k-kts+1)

          qsq(k)=max(x(k),1e-17)

       ENDDO

    ELSE

       !level 2.5 - use level 2 diagnostic

       DO k = kts,kte-1

          IF ( qkw(k) .LE. 0.0 ) THEN

             b2l = 0.0

          ELSE

             b2l = b2*0.25*( el(k+1)+el(k) )/qkw(k)

          END IF

          qsq(k) = b2l*( pdq(k+1)+pdq(k) )

       END DO

       qsq(kte)=qsq(kte-1)

    END IF

!!!!!!!!!!!!!!!!!!!!!!end level 2.6


    IF ( closure .GE. 3.0 ) THEN

!

!   **  dfq for the scalar variance is 1.0*dfm.  **

!

!   **  Prediction of the temperature variance  **

!!       DO k = kts+1,kte-1

       DO k = kts,kte-1

          b2l = b2*0.5*( el(k+1)+el(k) )

          bp(k) = 2.*qkw(k) / b2l

          rp(k) = pdt(k+1) + pdt(k)

       END DO


!zero gradient for tsq at bottom and top


!!       a(1)=0.

!!       b(1)=1.

!!       c(1)=-1.

!!       d(1)=0.


! Since dfq(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*dfq(k+1)+bp(k)*delt.

       DO k=kts,kte-1

          !a(k-kts+1)=-dtz(k)*dfq(k)

          !b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))+bp(k)*delt

          !c(k-kts+1)=-dtz(k)*dfq(k+1)

          !d(k-kts+1)=rp(k)*delt + tsq(k)

!JOE 8/22/20 improve conservation

          a(k)=   - dtz(k)*kmdz(k)*rhoinv(k)

          b(k)=1. + dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + bp(k)*delt

          c(k)=   - dtz(k)*kmdz(k+1)*rhoinv(k)

          d(k)=rp(k)*delt + tsq(k)

       ENDDO


!!       DO k=kts+1,kte-1

!!          a(k-kts+1)=-dtz(k)*dfq(k)

!!          b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))

!!          c(k-kts+1)=-dtz(k)*dfq(k+1)

!!          d(k-kts+1)=rp(k)*delt + tsq(k) - tsq(k)*bp(k)*delt

!!       ENDDO


       a(kte)=-1. !0.

       b(kte)=1.

       c(kte)=0.

       d(kte)=0.


!       CALL tridiag(kte,a,b,c,d)

       CALL tridiag2(kte,a,b,c,d,x)


       DO k=kts,kte

!          tsq(k)=d(k-kts+1)

           tsq(k)=x(k)

       ENDDO


!   **  Prediction of the temperature-moisture covariance  **

!!       DO k = kts+1,kte-1

       DO k = kts,kte-1

          b2l = b2*0.5*( el(k+1)+el(k) )

          bp(k) = 2.*qkw(k) / b2l

          rp(k) = pdc(k+1) + pdc(k)

       END DO


!zero gradient for tqcov at bottom and top


!!       a(1)=0.

!!       b(1)=1.

!!       c(1)=-1.

!!       d(1)=0.


! Since dfq(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*dfq(k+1)+bp(k)*delt.

       DO k=kts,kte-1

          !a(k-kts+1)=-dtz(k)*dfq(k)

          !b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))+bp(k)*delt

          !c(k-kts+1)=-dtz(k)*dfq(k+1)

          !d(k-kts+1)=rp(k)*delt + cov(k)

!JOE 8/22/20 improve conservation

          a(k)=   - dtz(k)*kmdz(k)*rhoinv(k)

          b(k)=1. + dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + bp(k)*delt

          c(k)=   - dtz(k)*kmdz(k+1)*rhoinv(k)

          d(k)=rp(k)*delt + cov(k)

       ENDDO


!!       DO k=kts+1,kte-1

!!          a(k-kts+1)=-dtz(k)*dfq(k)

!!          b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))

!!          c(k-kts+1)=-dtz(k)*dfq(k+1)

!!          d(k-kts+1)=rp(k)*delt + cov(k) - cov(k)*bp(k)*delt

!!       ENDDO


       a(kte)=-1. !0.

       b(kte)=1.

       c(kte)=0.

       d(kte)=0.


!       CALL tridiag(kte,a,b,c,d)

    CALL tridiag2(kte,a,b,c,d,x)


       DO k=kts,kte

!          cov(k)=d(k-kts+1)

          cov(k)=x(k)

       ENDDO


    ELSE


       !Not level 3 - default to level 2 diagnostic

       DO k = kts,kte-1

          IF ( qkw(k) .LE. 0.0 ) THEN

             b2l = 0.0

          ELSE

             b2l = b2*0.25*( el(k+1)+el(k) )/qkw(k)

          END IF

!

          tsq(k) = b2l*( pdt(k+1)+pdt(k) )

          cov(k) = b2l*( pdc(k+1)+pdc(k) )

       END DO


       tsq(kte)=tsq(kte-1)

       cov(kte)=cov(kte-1)


    END IF


#ifdef HARDCODE_VERTICAL

# undef kts

# undef kte

#endif


  END SUBROUTINE mym_predict


! ==================================================================

!     SUBROUTINE  mym_condensation:

!

!     Input variables:    see subroutine mym_initialize and turbulence

!       exner(nz)    : Perturbation of the Exner function    (J/kg K)

!                         defined on the walls of the grid boxes

!                         This is usually computed by integrating

!                         d(pi)/dz = h*g*tv/tref**2

!                         from the upper boundary, where tv is the

!                         virtual potential temperature minus tref.

!

!     Output variables:   see subroutine mym_initialize

!       cld(nx,nz,ny)   : Cloud fraction

!

!     Work arrays/variables:

!       qmq             : Q_w-Q_{sl}, where Q_{sl} is the saturation

!                         specific humidity at T=Tl

!       alp(nx,nz,ny)   : Functions in the condensation process

!       bet(nx,nz,ny)   : ditto

!       sgm(nx,nz,ny)   : Combined standard deviation sigma_s

!                         multiplied by 2/alp

!

!     # qmq, alp, bet and sgm are allowed to share storage units with

!       any four of other work arrays for saving memory.

!

!     # Results are sensitive particularly to values of cp and r_d.

!       Set these values to those adopted by you.

!

!-------------------------------------------------------------------


  SUBROUTINE  mym_condensation (kts,kte,   &

    &            dx, dz, zw, xland,        &

    &            thl, qw, qv, qc, qi, qs,  &

    &            p,exner,                  &

    &            tsq, qsq, cov,            &

    &            Sh, el, bl_mynn_cloudpdf, &

    &            qc_bl1D, qi_bl1D,         &

    &            cldfra_bl1D,              &

    &            PBLH1,HFX1,               &

    &            Vt, Vq, th, sgm, rmo,     &

    &            spp_pbl,rstoch_col        )


!-------------------------------------------------------------------


    integer, intent(in)   :: kts,kte, bl_mynn_cloudpdf


#ifdef HARDCODE_VERTICAL

# define kts 1

# define kte HARDCODE_VERTICAL

#endif


    real(kind_phys), intent(in)      :: HFX1,rmo,xland

    real(kind_phys), intent(in)      :: dx,pblh1

    real(kind_phys), dimension(kts:kte), intent(in) :: dz

    real(kind_phys), dimension(kts:kte+1), intent(in) :: zw

    real(kind_phys), dimension(kts:kte), intent(in) :: p,exner,thl,qw,   &

         &qv,qc,qi,qs,tsq,qsq,cov,th


    real(kind_phys), dimension(kts:kte), intent(inout) :: vt,vq,sgm


    real(kind_phys), dimension(kts:kte) :: alp,a,bet,b,ql,q1,RH

    real(kind_phys), dimension(kts:kte), intent(out) :: qc_bl1D,qi_bl1D, &

         &cldfra_bl1D

    DOUBLE PRECISION :: t3sq, r3sq, c3sq


    real(kind_phys):: qsl,esat,qsat,dqsl,cld0,q1k,qlk,eq1,qll,           &

         &q2p,pt,rac,qt,t,xl,rsl,cpm,Fng,qww,alpha,beta,bb,              &

         &ls,wt,wt2,qpct,cld_factor,fac_damp,liq_frac,ql_ice,ql_water,   &

         &qmq,qsat_tk,q1_rh,rh_hack,dzm1,zsl,maxqc

    real(kind_phys), parameter :: qpct_sfc=0.025

    real(kind_phys), parameter :: qpct_pbl=0.030

    real(kind_phys), parameter :: qpct_trp=0.040

    real(kind_phys), parameter :: rhcrit  =0.83 !for cloudpdf = 2

    real(kind_phys), parameter :: rhmax   =1.02 !for cloudpdf = 2

    integer :: i,j,k


    real(kind_phys):: erf


    !VARIABLES FOR ALTERNATIVE SIGMA

    real:: dth,dtl,dqw,dzk,els

    real(kind_phys), dimension(kts:kte), intent(in) :: Sh,el


    !variables for SGS BL clouds

    real(kind_phys)           :: zagl,damp,PBLH2

    real(kind_phys)           :: cfmax


    !JAYMES:  variables for tropopause-height estimation

    real(kind_phys)           :: theta1, theta2, ht1, ht2

    integer                   :: k_tropo


!   Stochastic

    integer,  intent(in)      :: spp_pbl

    real(kind_phys), dimension(kts:kte) ::    rstoch_col

    real(kind_phys)           :: qw_pert


! First, obtain an estimate for the tropopause height (k), using the method employed in the

! Thompson subgrid-cloud scheme.  This height will be a consideration later when determining

! the "final" subgrid-cloud properties.

! JAYMES:  added 3 Nov 2016, adapted from G. Thompson


    DO k = kte-3, kts, -1

       theta1 = th(k)

       theta2 = th(k+2)

       ht1 = 44307.692 * (1.0 - (p(k)/101325.)**0.190)

       ht2 = 44307.692 * (1.0 - (p(k+2)/101325.)**0.190)

       if ( (((theta2-theta1)/(ht2-ht1)) .lt. 10./1500. ) .AND.       &

     &                       (ht1.lt.19000.) .and. (ht1.gt.4000.) ) then

          goto 86

       endif

    ENDDO

 86   continue

    k_tropo = max(kts+2, k+2)


    zagl = 0.


    SELECT CASE(bl_mynn_cloudpdf)


      CASE (0) ! ORIGINAL MYNN PARTIAL-CONDENSATION SCHEME


        DO k = kts,kte-1

           t  = th(k)*exner(k)


!x      if ( ct .gt. 0.0 ) then

!       a  =  17.27

!       b  = 237.3

!x      else

!x        a  =  21.87

!x        b  = 265.5

!x      end if

!

!   **  3.8 = 0.622*6.11 (hPa)  **


           !SATURATED VAPOR PRESSURE

           esat = esat_blend(t)

           !SATURATED SPECIFIC HUMIDITY

           !qsl=ep_2*esat/(p(k)-ep_3*esat)

           qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat))

           !dqw/dT: Clausius-Clapeyron

           dqsl = qsl*ep_2*xlv/( r_d*t**2 )


           alp(k) = 1.0/( 1.0+dqsl*xlvcp )

           bet(k) = dqsl*exner(k)


           !Sommeria and Deardorff (1977) scheme, as implemented

           !in Nakanishi and Niino (2009), Appendix B

           t3sq = max( tsq(k), 0.0 )

           r3sq = max( qsq(k), 0.0 )

           c3sq =      cov(k)

           c3sq = sign( min( abs(c3sq), sqrt(t3sq*r3sq) ), c3sq )

           r3sq = r3sq +bet(k)**2*t3sq -2.0*bet(k)*c3sq

           !DEFICIT/EXCESS WATER CONTENT

           qmq  = qw(k) -qsl

           !ORIGINAL STANDARD DEVIATION

           sgm(k) = sqrt( max( r3sq, 1.0d-10 ))

           !NORMALIZED DEPARTURE FROM SATURATION

           q1(k)   = qmq / sgm(k)

           !CLOUD FRACTION. rr2 = 1/SQRT(2) = 0.707

           cldfra_bl1d(k) = 0.5*( 1.0+erf( q1(k)*rr2 ) )


           q1k  = q1(k)

           eq1  = rrp*exp( -0.5*q1k*q1k )

           qll  = max( cldfra_bl1d(k)*q1k + eq1, 0.0 )

           !ESTIMATED LIQUID WATER CONTENT (UNNORMALIZED)

           ql(k) = alp(k)*sgm(k)*qll

           !LIMIT SPECIES TO TEMPERATURE RANGES

           liq_frac = min(1.0, max(0.0,(t-240.0)/29.0))

           qc_bl1d(k) = liq_frac*ql(k)

           qi_bl1d(k) = (1.0 - liq_frac)*ql(k)


           !Now estimate the buoyancy flux functions

           q2p = xlvcp/exner(k)

           pt = thl(k) +q2p*ql(k) ! potential temp


           !qt is a THETA-V CONVERSION FOR TOTAL WATER (i.e., THETA-V = qt*THETA)

           qt   = 1.0 +p608*qw(k) -(1.+p608)*(qc_bl1d(k)+qi_bl1d(k))*cldfra_bl1d(k)

           rac  = alp(k)*( cldfra_bl1d(k)-qll*eq1 )*( q2p*qt-(1.+p608)*pt )


           !BUOYANCY FACTORS: wherever vt and vq are used, there is a

           !"+1" and "+tv0", respectively, so these are subtracted out here.

           !vt is unitless and vq has units of K.

           vt(k) =      qt-1.0 -rac*bet(k)

           vq(k) = p608*pt-tv0 +rac


        END DO


      CASE (1, -1) !ALTERNATIVE FORM (Nakanishi & Niino 2004 BLM, eq. B6, and

                       !Kuwano-Yoshida et al. 2010 QJRMS, eq. 7):

        DO k = kts,kte-1

           t  = th(k)*exner(k)

           !SATURATED VAPOR PRESSURE

           esat = esat_blend(t)

           !SATURATED SPECIFIC HUMIDITY

           !qsl=ep_2*esat/(p(k)-ep_3*esat)

           qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat))

           !dqw/dT: Clausius-Clapeyron

           dqsl = qsl*ep_2*xlv/( r_d*t**2 )


           alp(k) = 1.0/( 1.0+dqsl*xlvcp )

           bet(k) = dqsl*exner(k)


           if (k .eq. kts) then

             dzk = 0.5*dz(k)

           else

             dzk = dz(k)

           end if

           dth = 0.5*(thl(k+1)+thl(k)) - 0.5*(thl(k)+thl(max(k-1,kts)))

           dqw = 0.5*(qw(k+1) + qw(k)) - 0.5*(qw(k) + qw(max(k-1,kts)))

           sgm(k) = sqrt( max( (alp(k)**2 * max(el(k)**2,0.1) * &

                             b2 * max(sh(k),0.03))/4. * &

                      (dqw/dzk - bet(k)*(dth/dzk ))**2 , 1.0e-10) )

           qmq   = qw(k) -qsl

           q1(k) = qmq / sgm(k)

           cldfra_bl1d(k) = 0.5*( 1.0+erf( q1(k)*rr2 ) )


           !now compute estimated lwc for PBL scheme's use

           !qll IS THE NORMALIZED LIQUID WATER CONTENT (Sommeria and

           !Deardorff (1977, eq 29a). rrp = 1/(sqrt(2*pi)) = 0.3989

           q1k  = q1(k)

           eq1  = rrp*exp( -0.5*q1k*q1k )

           qll  = max( cldfra_bl1d(k)*q1k + eq1, 0.0 )

           !ESTIMATED LIQUID WATER CONTENT (UNNORMALIZED)

           ql(k) = alp(k)*sgm(k)*qll

           liq_frac = min(1.0, max(0.0,(t-240.0)/29.0))

           qc_bl1d(k) = liq_frac*ql(k)

           qi_bl1d(k) = (1.0 - liq_frac)*ql(k)


           !Now estimate the buoyancy flux functions

           q2p = xlvcp/exner(k)

           pt = thl(k) +q2p*ql(k) ! potential temp


           !qt is a THETA-V CONVERSION FOR TOTAL WATER (i.e., THETA-V = qt*THETA)

           qt   = 1.0 +p608*qw(k) -(1.+p608)*(qc_bl1d(k)+qi_bl1d(k))*cldfra_bl1d(k)

           rac  = alp(k)*( cldfra_bl1d(k)-qll*eq1 )*( q2p*qt-(1.+p608)*pt )


           !BUOYANCY FACTORS: wherever vt and vq are used, there is a

           !"+1" and "+tv0", respectively, so these are subtracted out here.

           !vt is unitless and vq has units of K.

           vt(k) =      qt-1.0 -rac*bet(k)

           vq(k) = p608*pt-tv0 +rac


        END DO


      CASE (2, -2)


        !Diagnostic statistical scheme of Chaboureau and Bechtold (2002), JAS

        !but with use of higher-order moments to estimate sigma

        pblh2=max(10._kind_phys,pblh1)

        zagl = 0.

        dzm1 = 0.

        DO k = kts,kte-1

           zagl   = zagl + 0.5*(dz(k) + dzm1)

           dzm1   = dz(k)


           t      = th(k)*exner(k)

           xl     = xl_blend(t)              ! obtain latent heat

           qsat_tk= qsat_blend(t,  p(k))     ! saturation water vapor mixing ratio at tk and p

           rh(k)  = max(min(rhmax, qw(k)/max(1.e-10,qsat_tk)),0.001_kind_phys)


           !dqw/dT: Clausius-Clapeyron

           dqsl   = qsat_tk*ep_2*xlv/( r_d*t**2 )

           alp(k) = 1.0/( 1.0+dqsl*xlvcp )

           bet(k) = dqsl*exner(k)


           rsl    = xl*qsat_tk / (r_v*t**2)  ! slope of C-C curve at t (=abs temperature)

                                             ! CB02, Eqn. 4

           cpm    = cp + qw(k)*cpv           ! CB02, sec. 2, para. 1

           a(k)   = 1./(1. + xl*rsl/cpm)     ! CB02 variable "a"

           b(k)   = a(k)*rsl                 ! CB02 variable "b"


           !SPP

           qw_pert= qw(k) + qw(k)*0.5*rstoch_col(k)*real(spp_pbl)


           !This form of qmq (the numerator of Q1) no longer uses the a(k) factor

           qmq    = qw_pert - qsat_tk          ! saturation deficit/excess;


           !Use the form of Eq. (6) in Chaboureau and Bechtold (2002)

           !except neglect all but the first term for sig_r

           r3sq   = max( qsq(k), 0.0 )

           !Calculate sigma using higher-order moments:

           sgm(k) = sqrt( r3sq )

           !Set constraints on sigma relative to saturation water vapor

           sgm(k) = min( sgm(k), qsat_tk*0.666 )

           !sgm(k) = max( sgm(k), qsat_tk*0.035 )


           !introduce vertical grid spacing dependence on min sgm

           wt     = max(500. - max(dz(k)-100.,0.0), 0.0_kind_phys)/500. !=1 for dz < 100 m, =0 for dz > 600 m

           sgm(k) = sgm(k) + sgm(k)*0.2*(1.0-wt) !inflate sgm for coarse dz


           !allow min sgm to vary with dz and z.

           qpct   = qpct_pbl*wt + qpct_trp*(1.0-wt)

           qpct   = min(qpct, max(qpct_sfc, qpct_pbl*zagl/500.) )

           sgm(k) = max( sgm(k), qsat_tk*qpct )


           q1(k)  = qmq  / sgm(k)  ! Q1, the normalized saturation


           !Add condition for falling/settling into low-RH layers, so at least

           !some cloud fraction is applied for all qc, qs, and qi.

           rh_hack= rh(k)

           wt2    = min(max( zagl - pblh2, 0.0 )/300., 1.0)

           !ensure adequate RH & q1 when qi is at least 1e-9 (above the PBLH)

           if ((qi(k)+qs(k))>1.e-9 .and. (zagl .gt. pblh2)) then

              rh_hack =min(rhmax, rhcrit + wt2*0.045*(9.0 + log10(qi(k)+qs(k))))

              rh(k)   =max(rh(k), rh_hack)

              !add rh-based q1

              q1_rh   =-3. + 3.*(rh(k)-rhcrit)/(1.-rhcrit)

              q1(k)   =max(q1_rh, q1(k) )

           endif

           !ensure adequate rh & q1 when qc is at least 1e-6 (above the PBLH)

           if (qc(k)>1.e-6 .and. (zagl .gt. pblh2)) then

              rh_hack =min(rhmax, rhcrit + wt2*0.08*(6.0 + log10(qc(k))))

              rh(k)   =max(rh(k), rh_hack)

              !add rh-based q1

              q1_rh   =-3. + 3.*(rh(k)-rhcrit)/(1.-rhcrit)

              q1(k)   =max(q1_rh, q1(k) )

           endif


           q1k   = q1(k)          ! backup Q1 for later modification


           ! Specify cloud fraction

           !Original C-B cloud fraction, allows cloud fractions out to q1 = -3.5

           !cldfra_bl1D(K) = max(0., min(1., 0.5+0.36*atan(1.55*q1(k)))) ! Eq. 7 in CB02

           !Waynes LES fit  - over-diffuse, when limits removed from vt & vq & fng

           !cldfra_bl1D(K) = max(0., min(1., 0.5+0.36*atan(1.2*(q1(k)+0.4))))

           !Best compromise: Improves marine stratus without adding much cold bias.

           cldfra_bl1d(k) = max(0., min(1., 0.5+0.36*atan(1.8*(q1(k)+0.2))))


           ! Specify hydrometeors

           ! JAYMES- this option added 8 May 2015

           ! The cloud water formulations are taken from CB02, Eq. 8.

           maxqc = max(qw(k) - qsat_tk, 0.0)

           if (q1k < 0.) then        !unsaturated

              ql_water = sgm(k)*exp(1.2*q1k-1.)

              ql_ice   = sgm(k)*exp(1.2*q1k-1.)

           elseif (q1k > 2.) then    !supersaturated

              ql_water = min(sgm(k)*q1k, maxqc)

              ql_ice   =     sgm(k)*q1k

           else                      !slightly saturated (0 > q1 < 2)

              ql_water = min(sgm(k)*(exp(-1.) + 0.66*q1k + 0.086*q1k**2), maxqc)

              ql_ice   =     sgm(k)*(exp(-1.) + 0.66*q1k + 0.086*q1k**2)

           endif


           !In saturated grid cells, use average of SGS and resolved values

           !if ( qc(k) > 1.e-6 ) ql_water = 0.5 * ( ql_water + qc(k) )

           !ql_ice is actually the total frozen condensate (snow+ice),

           !if ( (qi(k)+qs(k)) > 1.e-9 ) ql_ice = 0.5 * ( ql_ice + (qi(k)+qs(k)) )


           if (cldfra_bl1d(k) < 0.001) then

              ql_ice   = 0.0

              ql_water = 0.0

              cldfra_bl1d(k) = 0.0

           endif


           liq_frac = min(1.0, max(0.0, (t-tice)/(tliq-tice)))

           qc_bl1d(k) = liq_frac*ql_water       ! apply liq_frac to ql_water and ql_ice

           qi_bl1d(k) = (1.0-liq_frac)*ql_ice


           !Above tropopause:  eliminate subgrid clouds from CB scheme. Note that this was

           !"k_tropo - 1" as of 20 Feb 2023. Changed to allow more high-level clouds.

           if (k .ge. k_tropo) then

              cldfra_bl1d(k) = 0.

              qc_bl1d(k)     = 0.

              qi_bl1d(k)     = 0.

           endif


           !Buoyancy-flux-related calculations follow...

           !limiting Q1 to avoid too much diffusion in cloud layers

           !q1k=max(Q1(k),-2.0)

           if ((xland-1.5).GE.0) then   ! water

              q1k=max(q1(k),-2.5)

           else                         ! land

              q1k=max(q1(k),-2.0)

           endif

           ! "Fng" represents the non-Gaussian transport factor

           ! (non-dimensional) from Bechtold et al. 1995

           ! (hereafter BCMT95), section 3(c).  Their suggested

           ! forms for Fng (from their Eq. 20) are:

           !IF (q1k < -2.) THEN

           !  Fng = 2.-q1k

           !ELSE IF (q1k > 0.) THEN

           !  Fng = 1.

           !ELSE

           !  Fng = 1.-1.5*q1k

           !ENDIF

           ! Use the form of "Fng" from Bechtold and Siebesma (1998, JAS)

           if (q1k .ge. 1.0) then

              fng = 1.0

           elseif (q1k .ge. -1.7 .and. q1k .lt. 1.0) then

              fng = exp(-0.4*(q1k-1.0))

           elseif (q1k .ge. -2.5 .and. q1k .lt. -1.7) then

              fng = 3.0 + exp(-3.8*(q1k+1.7))

           else

              fng = min(23.9 + exp(-1.6*(q1k+2.5)), 60._kind_phys)

           endif


           cfmax = min(cldfra_bl1d(k), 0.6_kind_phys)

           !Further limit the cf going into vt & vq near the surface

           zsl   = min(max(25., 0.1*pblh2), 100.)

           wt    = min(zagl/zsl, 1.0) !=0 at z=0 m, =1 above ekman layer

           cfmax = cfmax*wt


           bb = b(k)*t/th(k) ! bb is "b" in BCMT95.  Their "b" differs from

                             ! "b" in CB02 (i.e., b(k) above) by a factor

                             ! of T/theta.  Strictly, b(k) above is formulated in

                             ! terms of sat. mixing ratio, but bb in BCMT95 is

                             ! cast in terms of sat. specific humidity.  The

                             ! conversion is neglected here.

           qww   = 1.+0.61*qw(k)

           alpha = 0.61*th(k)

           beta  = (th(k)/t)*(xl/cp) - 1.61*th(k)

           vt(k) = qww   - cfmax*beta*bb*fng   - 1.

           vq(k) = alpha + cfmax*beta*a(k)*fng - tv0

           ! vt and vq correspond to beta-theta and beta-q, respectively,

           ! in NN09, Eq. B8.  They also correspond to the bracketed

           ! expressions in BCMT95, Eq. 15, since (s*ql/sigma^2) = cldfra*Fng

           ! The "-1" and "-tv0" terms are included for consistency with

           ! the legacy vt and vq formulations (above).


           ! dampen amplification factor where need be

           fac_damp = min(zagl * 0.0025, 1.0)

           !cld_factor = 1.0 + fac_damp*MAX(0.0, ( RH(k) - 0.75 ) / 0.26 )**1.9 !HRRRv4

           !cld_factor = 1.0 + fac_damp*min((max(0.0, ( RH(k) - 0.92 )) / 0.25 )**2, 0.3)

           cld_factor = 1.0 + fac_damp*min((max(0.0, ( rh(k) - 0.92 )) / 0.145)**2, 0.37)

           cldfra_bl1d(k) = min( 1., cld_factor*cldfra_bl1d(k) )

        enddo


      END SELECT !end cloudPDF option


      !For testing purposes only, option for isolating on the mass-flux clouds.

      IF (bl_mynn_cloudpdf .LT. 0) THEN

         DO k = kts,kte-1

            cldfra_bl1d(k) = 0.0

            qc_bl1d(k) = 0.0

            qi_bl1d(k) = 0.0

         END DO

      ENDIF

!

      ql(kte) = ql(kte-1)

      vt(kte) = vt(kte-1)

      vq(kte) = vq(kte-1)

      qc_bl1d(kte)=0.

      qi_bl1d(kte)=0.

      cldfra_bl1d(kte)=0.

    RETURN


#ifdef HARDCODE_VERTICAL

# undef kts

# undef kte

#endif


  END SUBROUTINE mym_condensation


! ==================================================================


  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                    )


!-------------------------------------------------------------------

    integer, intent(in) :: kts,kte,i


#ifdef HARDCODE_VERTICAL

# define kts 1

# define kte HARDCODE_VERTICAL

#endif


    integer, intent(in) :: bl_mynn_cloudmix,bl_mynn_mixqt,                &

                           bl_mynn_edmf,bl_mynn_edmf_mom,                 &

                           bl_mynn_mixscalars

    logical, intent(IN) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QS,              &

         &FLAG_QNC,FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA


! thl - liquid water potential temperature

! qw - total water

! dfm,dfh,dfq - diffusivities i.e., dfh(k) = elq*sh(k) / dzk

! flt - surface flux of thl

! flq - surface flux of qw


! mass-flux plumes

    real(kind_phys), dimension(kts:kte+1), intent(in) :: s_aw,            &

         &s_awthl,s_awqt,s_awqnc,s_awqni,s_awqv,s_awqc,s_awu,s_awv,       &

         &s_awqnwfa,s_awqnifa,s_awqnbca,                                  &

         &sd_aw,sd_awthl,sd_awqt,sd_awqv,sd_awqc,sd_awu,sd_awv

! tendencies from mass-flux environmental subsidence and detrainment

    real(kind_phys), dimension(kts:kte), intent(in) :: sub_thl,sub_sqv,   &

         &sub_u,sub_v,det_thl,det_sqv,det_sqc,det_u,det_v

    real(kind_phys), dimension(kts:kte), intent(in) :: u,v,th,tk,qv,qc,qi,&

         &qs,qni,qnc,rho,p,exner,dfq,dz,tsq,qsq,cov,tcd,qcd,              &

         &cldfra_bl1d,diss_heat

    real(kind_phys), dimension(kts:kte), intent(inout) :: thl,sqw,sqv,sqc,&

         &sqi,sqs,qnwfa,qnifa,qnbca,ozone,dfm,dfh

    real(kind_phys), dimension(kts:kte), intent(inout) :: du,dv,dth,dqv,  &

         &dqc,dqi,dqs,dqni,dqnc,dqnwfa,dqnifa,dqnbca,dozone

    real(kind_phys), intent(in) :: flt,flq,flqv,flqc,uoce,voce

    real(kind_phys), intent(in) :: ust,delt,psfc,wspd

    !debugging

    real(kind_phys):: wsp,wsp2,tk2,th2

    logical :: problem

    integer :: kproblem


!    real(kind_phys), intent(in) :: gradu_top,gradv_top,gradth_top,gradqv_top


!local vars


    real(kind_phys), dimension(kts:kte) :: dtz,dfhc,dfmc,delp

    real(kind_phys), dimension(kts:kte) :: sqv2,sqc2,sqi2,sqs2,sqw2,      &

          &qni2,qnc2,qnwfa2,qnifa2,qnbca2,ozone2

    real(kind_phys), dimension(kts:kte) :: zfac,plumeKh,rhoinv

    real(kind_phys), dimension(kts:kte) :: a,b,c,d,x

    real(kind_phys), dimension(kts:kte+1) :: rhoz,                        & !rho on model interface

          &khdz,kmdz

    real(kind_phys):: rhs,gfluxm,gfluxp,dztop,maxdfh,mindfh,maxcf,maxKh,zw

    real(kind_phys):: t,esat,qsl,onoff,kh,km,dzk,rhosfc

    real(kind_phys):: ustdrag,ustdiff,qvflux

    real(kind_phys):: th_new,portion_qc,portion_qi,condensate,qsat

    integer :: k,kk


    !Activate nonlocal mixing from the mass-flux scheme for

    !number concentrations and aerosols (0.0 = no; 1.0 = yes)

    real(kind_phys), parameter :: nonloc = 1.0


    dztop=.5*(dz(kte)+dz(kte-1))


    ! REGULATE THE MOMENTUM MIXING FROM THE MASS-FLUX SCHEME (on or off)

    ! Note that s_awu and s_awv already come in as 0.0 if bl_mynn_edmf_mom == 0, so

    ! we only need to zero-out the MF term

    IF (bl_mynn_edmf_mom == 0) THEN

       onoff=0.0

    ELSE

       onoff=1.0

    ENDIF


    !Prepare "constants" for diffusion equation.

    !khdz = rho*Kh/dz = rho*dfh

    rhosfc     = psfc/(r_d*(tk(kts)+p608*qv(kts)))

    dtz(kts)   =delt/dz(kts)

    rhoz(kts)  =rho(kts)

    rhoinv(kts)=1./rho(kts)

    khdz(kts)  =rhoz(kts)*dfh(kts)

    kmdz(kts)  =rhoz(kts)*dfm(kts)

    delp(kts)  = psfc - (p(kts+1)*dz(kts) + p(kts)*dz(kts+1))/(dz(kts)+dz(kts+1))

    DO k=kts+1,kte

       dtz(k)   =delt/dz(k)

       rhoz(k)  =(rho(k)*dz(k-1) + rho(k-1)*dz(k))/(dz(k-1)+dz(k))

       rhoz(k)  =  max(rhoz(k),1e-4)

       rhoinv(k)=1./max(rho(k),1e-4)

       dzk      = 0.5  *( dz(k)+dz(k-1) )

       khdz(k)  = rhoz(k)*dfh(k)

       kmdz(k)  = rhoz(k)*dfm(k)

    ENDDO

    DO k=kts+1,kte-1

       delp(k)  = (p(k)*dz(k-1) + p(k-1)*dz(k))/(dz(k)+dz(k-1)) - &

                  (p(k+1)*dz(k) + p(k)*dz(k+1))/(dz(k)+dz(k+1))

    ENDDO

    delp(kte)  =delp(kte-1)

    rhoz(kte+1)=rhoz(kte)

    khdz(kte+1)=rhoz(kte+1)*dfh(kte)

    kmdz(kte+1)=rhoz(kte+1)*dfm(kte)


    !stability criteria for mf

    DO k=kts+1,kte-1

       khdz(k) = max(khdz(k),  0.5*s_aw(k))

       khdz(k) = max(khdz(k), -0.5*(s_aw(k)-s_aw(k+1)))

       kmdz(k) = max(kmdz(k),  0.5*s_aw(k))

       kmdz(k) = max(kmdz(k), -0.5*(s_aw(k)-s_aw(k+1)))

    ENDDO


    ustdrag = min(ust*ust,0.99)/wspd  ! limit at ~ 20 m/s

    ustdiff = min(ust*ust,0.01)/wspd  ! limit at ~ 2 m/s

    dth(kts:kte) = 0.0  ! must initialize for moisture_check routine


!!============================================

!! u

!!============================================


    k=kts


!rho-weighted (drag in b-vector):

    a(k)=  -dtz(k)*kmdz(k)*rhoinv(k)

    b(k)=1.+dtz(k)*(kmdz(k+1)+rhosfc*ust**2/wspd)*rhoinv(k)     &

           & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff             &

           & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff

    c(k)=  -dtz(k)*kmdz(k+1)*rhoinv(k) &

           & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff             &

           & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff

    d(k)=u(k)  + dtz(k)*uoce*ust**2/wspd                        &

           & - dtz(k)*rhoinv(k)*s_awu(k+1)*onoff                &

           & + dtz(k)*rhoinv(k)*sd_awu(k+1)*onoff               &

           & + sub_u(k)*delt + det_u(k)*delt


    do k=kts+1,kte-1

       a(k)=  -dtz(k)*kmdz(k)*rhoinv(k)                         &

           &  + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*onoff              &

           &  + 0.5*dtz(k)*rhoinv(k)*sd_aw(k)*onoff

       b(k)=1.+ dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k)            &

           &  + 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*onoff  &

           &  + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1))*onoff

       c(k)=  - dtz(k)*kmdz(k+1)*rhoinv(k)                      &

           &  - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff            &

           &  - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff

       d(k)=u(k) + dtz(k)*rhoinv(k)*(s_awu(k)-s_awu(k+1))*onoff &

           &  - dtz(k)*rhoinv(k)*(sd_awu(k)-sd_awu(k+1))*onoff  &

           &  + sub_u(k)*delt + det_u(k)*delt

    enddo


!! no flux at the top

!    a(kte)=-1.

!    b(kte)=1.

!    c(kte)=0.

!    d(kte)=0.


!! specified gradient at the top

!    a(kte)=-1.

!    b(kte)=1.

!    c(kte)=0.

!    d(kte)=gradu_top*dztop


!! prescribed value

    a(kte)=0

    b(kte)=1.

    c(kte)=0.

    d(kte)=u(kte)


!    CALL tridiag(kte,a,b,c,d)

    CALL tridiag2(kte,a,b,c,d,x)

!    CALL tridiag3(kte,a,b,c,d,x)


    DO k=kts,kte

!       du(k)=(d(k-kts+1)-u(k))/delt

       du(k)=(x(k)-u(k))/delt

    ENDDO


!!============================================

!! v

!!============================================


    k=kts


!rho-weighted (drag in b-vector):

    a(k)=  -dtz(k)*kmdz(k)*rhoinv(k)

    b(k)=1.+dtz(k)*(kmdz(k+1) + rhosfc*ust**2/wspd)*rhoinv(k)   &

        &  - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff               &

        &  - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff

    c(k)=  -dtz(k)*kmdz(k+1)*rhoinv(k)                          &

        &  - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff               &

        &  - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff

    d(k)=v(k)  + dtz(k)*voce*ust**2/wspd                        &

        &  - dtz(k)*rhoinv(k)*s_awv(k+1)*onoff                  &

        &  + dtz(k)*rhoinv(k)*sd_awv(k+1)*onoff                 &

        &  + sub_v(k)*delt + det_v(k)*delt


    do k=kts+1,kte-1

       a(k)=  -dtz(k)*kmdz(k)*rhoinv(k)                         &

         & + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*onoff                 &

         & + 0.5*dtz(k)*rhoinv(k)*sd_aw(k)*onoff

       b(k)=1.+dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k)             &

         & + 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*onoff     &

         & + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1))*onoff

       c(k)=  -dtz(k)*kmdz(k+1)*rhoinv(k)                       &

         & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff               &

         & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff

       d(k)=v(k) + dtz(k)*rhoinv(k)*(s_awv(k)-s_awv(k+1))*onoff &

         & - dtz(k)*rhoinv(k)*(sd_awv(k)-sd_awv(k+1))*onoff     &

         & + sub_v(k)*delt + det_v(k)*delt

    enddo


!! no flux at the top

!    a(kte)=-1.

!    b(kte)=1.

!    c(kte)=0.

!    d(kte)=0.


!! specified gradient at the top

!    a(kte)=-1.

!    b(kte)=1.

!    c(kte)=0.

!    d(kte)=gradv_top*dztop


!! prescribed value

    a(kte)=0

    b(kte)=1.

    c(kte)=0.

    d(kte)=v(kte)


!    CALL tridiag(kte,a,b,c,d)

    CALL tridiag2(kte,a,b,c,d,x)

!    CALL tridiag3(kte,a,b,c,d,x)


    DO k=kts,kte

!       dv(k)=(d(k-kts+1)-v(k))/delt

       dv(k)=(x(k)-v(k))/delt

    ENDDO


!!============================================

!! thl tendency

!!============================================

    k=kts


!    a(k)=0.

!    b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1)

!    c(k)=  -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1)

!    d(k)=thl(k) + dtz(k)*flt + tcd(k)*delt &

!        & -dtz(k)*s_awthl(kts+1) + diss_heat(k)*delt + &

!        & sub_thl(k)*delt + det_thl(k)*delt

!

!    DO k=kts+1,kte-1

!       a(k)=  -dtz(k)*dfh(k)            + 0.5*dtz(k)*s_aw(k)

!       b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))

!       c(k)=  -dtz(k)*dfh(k+1)          - 0.5*dtz(k)*s_aw(k+1)

!       d(k)=thl(k) + tcd(k)*delt + dtz(k)*(s_awthl(k)-s_awthl(k+1)) &

!           &       + diss_heat(k)*delt + &

!           &         sub_thl(k)*delt + det_thl(k)*delt

!    ENDDO


!rho-weighted: rhosfc*X*rhoinv(k)

    a(k)=  -dtz(k)*khdz(k)*rhoinv(k)

    b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)

    c(k)=  -dtz(k)*khdz(k+1)*rhoinv(k)           - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)

    d(k)=thl(k)  + dtz(k)*rhosfc*flt*rhoinv(k) + tcd(k)*delt &

       & - dtz(k)*rhoinv(k)*s_awthl(k+1) -dtz(k)*rhoinv(k)*sd_awthl(k+1) + &

       & diss_heat(k)*delt + sub_thl(k)*delt + det_thl(k)*delt


    DO k=kts+1,kte-1

       a(k)=  -dtz(k)*khdz(k)*rhoinv(k)     + 0.5*dtz(k)*rhoinv(k)*s_aw(k) + 0.5*dtz(k)*rhoinv(k)*sd_aw(k)

       b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + &

           &   0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1)) + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1))

       c(k)=  -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)

       d(k)=thl(k) + tcd(k)*delt + &

          & dtz(k)*rhoinv(k)*(s_awthl(k)-s_awthl(k+1)) + dtz(k)*rhoinv(k)*(sd_awthl(k)-sd_awthl(k+1)) + &

          &       diss_heat(k)*delt + &

          &       sub_thl(k)*delt + det_thl(k)*delt

    ENDDO


!! no flux at the top

!    a(kte)=-1.

!    b(kte)=1.

!    c(kte)=0.

!    d(kte)=0.


!! specified gradient at the top

!assume gradthl_top=gradth_top

!    a(kte)=-1.

!    b(kte)=1.

!    c(kte)=0.

!    d(kte)=gradth_top*dztop


!! prescribed value

    a(kte)=0.

    b(kte)=1.

    c(kte)=0.

    d(kte)=thl(kte)


!    CALL tridiag(kte,a,b,c,d)

    CALL tridiag2(kte,a,b,c,d,x)

!    CALL tridiag3(kte,a,b,c,d,x)


    DO k=kts,kte

       !thl(k)=d(k-kts+1)

       thl(k)=x(k)

    ENDDO


IF (bl_mynn_mixqt > 0) THEN

 !============================================

 ! MIX total water (sqw = sqc + sqv + sqi)

 ! NOTE: no total water tendency is output; instead, we must calculate

 !       the saturation specific humidity and then

 !       subtract out the moisture excess (sqc & sqi)

 !============================================


    k=kts


!    a(k)=0.

!    b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1)

!    c(k)=  -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1)

!    !rhs= qcd(k) !+ (gfluxp - gfluxm)/dz(k)&

!    d(k)=sqw(k) + dtz(k)*flq + qcd(k)*delt - dtz(k)*s_awqt(k+1)

!

!    DO k=kts+1,kte-1

!       a(k)=  -dtz(k)*dfh(k)            + 0.5*dtz(k)*s_aw(k)

!       b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))

!       c(k)=  -dtz(k)*dfh(k+1)          - 0.5*dtz(k)*s_aw(k+1)

!       d(k)=sqw(k) + qcd(k)*delt + dtz(k)*(s_awqt(k)-s_awqt(k+1))

!    ENDDO


!rho-weighted:

    a(k)=  -dtz(k)*khdz(k)*rhoinv(k)

    b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)

    c(k)=  -dtz(k)*khdz(k+1)*rhoinv(k)           - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)

    d(k)=sqw(k)  + dtz(k)*rhosfc*flq*rhoinv(k) + qcd(k)*delt - dtz(k)*rhoinv(k)*s_awqt(k+1) - dtz(k)*rhoinv(k)*sd_awqt(k+1)


    DO k=kts+1,kte-1

       a(k)=  -dtz(k)*khdz(k)*rhoinv(k)     + 0.5*dtz(k)*rhoinv(k)*s_aw(k) + 0.5*dtz(k)*rhoinv(k)*sd_aw(k)

       b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + &

           &    0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1)) + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1))

       c(k)=  -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)

       d(k)=sqw(k) + qcd(k)*delt + dtz(k)*rhoinv(k)*(s_awqt(k)-s_awqt(k+1)) + dtz(k)*rhoinv(k)*(sd_awqt(k)-sd_awqt(k+1))

    ENDDO


!! no flux at the top

!    a(kte)=-1.

!    b(kte)=1.

!    c(kte)=0.

!    d(kte)=0.

!! specified gradient at the top

!assume gradqw_top=gradqv_top

!    a(kte)=-1.

!    b(kte)=1.

!    c(kte)=0.

!    d(kte)=gradqv_top*dztop

!! prescribed value

    a(kte)=0.

    b(kte)=1.

    c(kte)=0.

    d(kte)=sqw(kte)


!    CALL tridiag(kte,a,b,c,d)

    CALL tridiag2(kte,a,b,c,d,sqw2)

!    CALL tridiag3(kte,a,b,c,d,sqw2)


!    DO k=kts,kte

!       sqw2(k)=d(k-kts+1)

!    ENDDO

ELSE

    sqw2=sqw

ENDIF


IF (bl_mynn_mixqt == 0) THEN

!============================================

! cloud water ( sqc ). If mixing total water (bl_mynn_mixqt > 0),

! then sqc will be backed out of saturation check (below).

!============================================

  IF (bl_mynn_cloudmix > 0 .AND. flag_qc) THEN


    k=kts


!    a(k)=0.

!    b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1)

!    c(k)=  -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1)

!    d(k)=sqc(k) + dtz(k)*flqc + qcd(k)*delt - &

!         dtz(k)*s_awqc(k+1)  + det_sqc(k)*delt

!

!    DO k=kts+1,kte-1

!       a(k)=  -dtz(k)*dfh(k)            + 0.5*dtz(k)*s_aw(k)

!       b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))

!       c(k)=  -dtz(k)*dfh(k+1)          - 0.5*dtz(k)*s_aw(k+1)

!       d(k)=sqc(k) + qcd(k)*delt + dtz(k)*(s_awqc(k)-s_awqc(k+1)) + &

!            det_sqc(k)*delt

!    ENDDO


!rho-weighted:

    a(k)=  -dtz(k)*khdz(k)*rhoinv(k)

    b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)

    c(k)=  -dtz(k)*khdz(k+1)*rhoinv(k)           - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)

    d(k)=sqc(k)  + dtz(k)*rhosfc*flqc*rhoinv(k) + qcd(k)*delt &

       &  - dtz(k)*rhoinv(k)*s_awqc(k+1) - dtz(k)*rhoinv(k)*sd_awqc(k+1) + &

       &  det_sqc(k)*delt


    DO k=kts+1,kte-1

       a(k)=  -dtz(k)*khdz(k)*rhoinv(k)     + 0.5*dtz(k)*rhoinv(k)*s_aw(k) + 0.5*dtz(k)*rhoinv(k)*sd_aw(k)

       b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + &

           &    0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1)) + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1))

       c(k)=  -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)

       d(k)=sqc(k) + qcd(k)*delt + dtz(k)*rhoinv(k)*(s_awqc(k)-s_awqc(k+1)) + dtz(k)*rhoinv(k)*(sd_awqc(k)-sd_awqc(k+1)) + &

          & det_sqc(k)*delt

    ENDDO


! prescribed value

    a(kte)=0.

    b(kte)=1.

    c(kte)=0.

    d(kte)=sqc(kte)


!    CALL tridiag(kte,a,b,c,d)

    CALL tridiag2(kte,a,b,c,d,sqc2)

!    CALL tridiag3(kte,a,b,c,d,sqc2)


!    DO k=kts,kte

!       sqc2(k)=d(k-kts+1)

!    ENDDO

  ELSE

    !If not mixing clouds, set "updated" array equal to original array

    sqc2=sqc

  ENDIF

ENDIF


IF (bl_mynn_mixqt == 0) THEN

  !============================================

  ! MIX WATER VAPOR ONLY ( sqv ). If mixing total water (bl_mynn_mixqt > 0),

  ! then sqv will be backed out of saturation check (below).

  !============================================


    k=kts


!    a(k)=0.

!    b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1)

!    c(k)=  -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1)

!    d(k)=sqv(k) + dtz(k)*flqv + qcd(k)*delt - dtz(k)*s_awqv(k+1) + &

!       & sub_sqv(k)*delt + det_sqv(k)*delt

!

!    DO k=kts+1,kte-1

!       a(k)=  -dtz(k)*dfh(k)            + 0.5*dtz(k)*s_aw(k)

!       b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))

!       c(k)=  -dtz(k)*dfh(k+1)          - 0.5*dtz(k)*s_aw(k+1)

!       d(k)=sqv(k) + qcd(k)*delt + dtz(k)*(s_awqv(k)-s_awqv(k+1)) + &

!          & sub_sqv(k)*delt + det_sqv(k)*delt

!    ENDDO


    !limit unreasonably large negative fluxes:

    qvflux = flqv

    if (qvflux < 0.0) then

       !do not allow specified surface flux to reduce qv below 1e-8 kg/kg

       qvflux = max(qvflux, (min(0.9*sqv(kts) - 1e-8, 0.0)/dtz(kts)))

    endif


!rho-weighted:  rhosfc*X*rhoinv(k)

    a(k)=  -dtz(k)*khdz(k)*rhoinv(k)

    b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)

    c(k)=  -dtz(k)*khdz(k+1)*rhoinv(k)           - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)

    d(k)=sqv(k)  + dtz(k)*rhosfc*qvflux*rhoinv(k) + qcd(k)*delt &

       &  - dtz(k)*rhoinv(k)*s_awqv(k+1) - dtz(k)*rhoinv(k)*sd_awqv(k+1) + &

       & sub_sqv(k)*delt + det_sqv(k)*delt


    DO k=kts+1,kte-1

       a(k)=  -dtz(k)*khdz(k)*rhoinv(k)     + 0.5*dtz(k)*rhoinv(k)*s_aw(k) + 0.5*dtz(k)*rhoinv(k)*sd_aw(k)

       b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + &

           &    0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1)) + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1))

       c(k)=  -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)

       d(k)=sqv(k) + qcd(k)*delt + dtz(k)*rhoinv(k)*(s_awqv(k)-s_awqv(k+1)) + dtz(k)*rhoinv(k)*(sd_awqv(k)-sd_awqv(k+1)) + &

          & sub_sqv(k)*delt + det_sqv(k)*delt

    ENDDO


! no flux at the top

!    a(kte)=-1.

!    b(kte)=1.

!    c(kte)=0.

!    d(kte)=0.


! specified gradient at the top

! assume gradqw_top=gradqv_top

!    a(kte)=-1.

!    b(kte)=1.

!    c(kte)=0.

!    d(kte)=gradqv_top*dztop


! prescribed value

    a(kte)=0.

    b(kte)=1.

    c(kte)=0.

    d(kte)=sqv(kte)


!    CALL tridiag(kte,a,b,c,d)

    CALL tridiag2(kte,a,b,c,d,sqv2)

!    CALL tridiag3(kte,a,b,c,d,sqv2)


!    DO k=kts,kte

!       sqv2(k)=d(k-kts+1)

!    ENDDO

ELSE

    sqv2=sqv

ENDIF


!============================================

! MIX CLOUD ICE ( sqi )

!============================================

IF (bl_mynn_cloudmix > 0 .AND. flag_qi) THEN


    k=kts

!rho-weighted:

    a(k)=  -dtz(k)*khdz(k)*rhoinv(k)

    b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k)

    c(k)=  -dtz(k)*khdz(k+1)*rhoinv(k)

    d(k)=sqi(k)


    DO k=kts+1,kte-1

       a(k)=  -dtz(k)*khdz(k)*rhoinv(k)

       b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k)

       c(k)=  -dtz(k)*khdz(k+1)*rhoinv(k)

       d(k)=sqi(k)

    ENDDO


!! no flux at the top

!    a(kte)=-1.

!    b(kte)=1.

!    c(kte)=0.

!    d(kte)=0.


!! specified gradient at the top

!assume gradqw_top=gradqv_top

!    a(kte)=-1.

!    b(kte)=1.

!    c(kte)=0.

!    d(kte)=gradqv_top*dztop


!! prescribed value

    a(kte)=0.

    b(kte)=1.

    c(kte)=0.

    d(kte)=sqi(kte)


!    CALL tridiag(kte,a,b,c,d)

    CALL tridiag2(kte,a,b,c,d,sqi2)

!    CALL tridiag3(kte,a,b,c,d,sqi2)


!    DO k=kts,kte

!       sqi2(k)=d(k-kts+1)

!    ENDDO

ELSE

   sqi2=sqi

ENDIF


!============================================

! MIX SNOW ( sqs )

!============================================

!hard-code to not mix snow

IF (bl_mynn_cloudmix > 0 .AND. .false.) THEN


    k=kts

!rho-weighted:

    a(k)=  -dtz(k)*khdz(k)*rhoinv(k)

    b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k)

    c(k)=  -dtz(k)*khdz(k+1)*rhoinv(k)

    d(k)=sqs(k)


    DO k=kts+1,kte-1

       a(k)=  -dtz(k)*khdz(k)*rhoinv(k)

       b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k)

       c(k)=  -dtz(k)*khdz(k+1)*rhoinv(k)

       d(k)=sqs(k)

    ENDDO


!! prescribed value

    a(kte)=0.

    b(kte)=1.

    c(kte)=0.

    d(kte)=sqs(kte)


!    CALL tridiag(kte,a,b,c,d)

    CALL tridiag2(kte,a,b,c,d,sqs2)

!    CALL tridiag3(kte,a,b,c,d,sqs2)


!    DO k=kts,kte

!       sqs2(k)=d(k-kts+1)

!    ENDDO

ELSE

   sqs2=sqs

ENDIF


!!============================================

!! cloud ice number concentration (qni)

!!============================================

IF (bl_mynn_cloudmix > 0 .AND. flag_qni .AND. &

      bl_mynn_mixscalars > 0) THEN


    k=kts


    a(k)=  -dtz(k)*khdz(k)*rhoinv(k)

    b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc

    c(k)=  -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc

    d(k)=qni(k)  - dtz(k)*rhoinv(k)*s_awqni(k+1)*nonloc


    DO k=kts+1,kte-1

       a(k)=  -dtz(k)*khdz(k)*rhoinv(k)     + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*nonloc

       b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + &

           &    0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*nonloc

       c(k)=  -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc

       d(k)=qni(k) + dtz(k)*rhoinv(k)*(s_awqni(k)-s_awqni(k+1))*nonloc

    ENDDO


!! prescribed value

    a(kte)=0.

    b(kte)=1.

    c(kte)=0.

    d(kte)=qni(kte)


!    CALL tridiag(kte,a,b,c,d)

    CALL tridiag2(kte,a,b,c,d,x)

!    CALL tridiag3(kte,a,b,c,d,x)


    DO k=kts,kte

       !qni2(k)=d(k-kts+1)

       qni2(k)=x(k)

    ENDDO


ELSE

    qni2=qni

ENDIF


!!============================================

!! cloud water number concentration (qnc)

!! include non-local transport

!!============================================

  IF (bl_mynn_cloudmix > 0 .AND. flag_qnc .AND. &

      bl_mynn_mixscalars > 0) THEN


    k=kts


    a(k)=  -dtz(k)*khdz(k)*rhoinv(k)

    b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc

    c(k)=  -dtz(k)*khdz(k+1)*rhoinv(k)           - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc

    d(k)=qnc(k)  - dtz(k)*rhoinv(k)*s_awqnc(k+1)*nonloc


    DO k=kts+1,kte-1

       a(k)=  -dtz(k)*khdz(k)*rhoinv(k)     + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*nonloc

       b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + &

           &    0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*nonloc

       c(k)=  -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc

       d(k)=qnc(k) + dtz(k)*rhoinv(k)*(s_awqnc(k)-s_awqnc(k+1))*nonloc

    ENDDO


!! prescribed value

    a(kte)=0.

    b(kte)=1.

    c(kte)=0.

    d(kte)=qnc(kte)


!    CALL tridiag(kte,a,b,c,d)

    CALL tridiag2(kte,a,b,c,d,x)

!    CALL tridiag3(kte,a,b,c,d,x)


    DO k=kts,kte

       !qnc2(k)=d(k-kts+1)

       qnc2(k)=x(k)

    ENDDO


ELSE

    qnc2=qnc

ENDIF


!============================================

! Water-friendly aerosols ( qnwfa ).

!============================================

IF (bl_mynn_cloudmix > 0 .AND. flag_qnwfa .AND. &

      bl_mynn_mixscalars > 0) THEN


    k=kts


    a(k)=  -dtz(k)*khdz(k)*rhoinv(k)

    b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) - &

           &    0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc

    c(k)=  -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc

    d(k)=qnwfa(k)  - dtz(k)*rhoinv(k)*s_awqnwfa(k+1)*nonloc


    DO k=kts+1,kte-1

       a(k)=  -dtz(k)*khdz(k)*rhoinv(k)     + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*nonloc

       b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) + &

           &    0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*nonloc

       c(k)=  -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc

       d(k)=qnwfa(k) + dtz(k)*rhoinv(k)*(s_awqnwfa(k)-s_awqnwfa(k+1))*nonloc

    ENDDO


! prescribed value

    a(kte)=0.

    b(kte)=1.

    c(kte)=0.

    d(kte)=qnwfa(kte)


!    CALL tridiag(kte,a,b,c,d)

    CALL tridiag2(kte,a,b,c,d,x)

!    CALL tridiag3(kte,a,b,c,d,x)


    DO k=kts,kte

       !qnwfa2(k)=d(k)

       qnwfa2(k)=x(k)

    ENDDO


ELSE

    !If not mixing aerosols, set "updated" array equal to original array

    qnwfa2=qnwfa

ENDIF


!============================================

! Ice-friendly aerosols ( qnifa ).

!============================================

IF (bl_mynn_cloudmix > 0 .AND. flag_qnifa .AND. &

      bl_mynn_mixscalars > 0) THEN


   k=kts


    a(k)=  -dtz(k)*khdz(k)*rhoinv(k)

    b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) - &

           &    0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc

    c(k)=  -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc

    d(k)=qnifa(k)  - dtz(k)*rhoinv(k)*s_awqnifa(k+1)*nonloc


    DO k=kts+1,kte-1

       a(k)=  -dtz(k)*khdz(k)*rhoinv(k)     + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*nonloc

       b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) + &

           &    0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*nonloc

       c(k)=  -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc

       d(k)=qnifa(k) + dtz(k)*rhoinv(k)*(s_awqnifa(k)-s_awqnifa(k+1))*nonloc

    ENDDO


! prescribed value

    a(kte)=0.

    b(kte)=1.

    c(kte)=0.

    d(kte)=qnifa(kte)


!    CALL tridiag(kte,a,b,c,d)

    CALL tridiag2(kte,a,b,c,d,x)

!    CALL tridiag3(kte,a,b,c,d,x)


    DO k=kts,kte

       !qnifa2(k)=d(k-kts+1)

       qnifa2(k)=x(k)

    ENDDO


ELSE

    !If not mixing aerosols, set "updated" array equal to original array

    qnifa2=qnifa

ENDIF


!============================================

! Black-carbon aerosols ( qnbca ).

!============================================

IF (bl_mynn_cloudmix > 0 .AND. flag_qnbca .AND. &

      bl_mynn_mixscalars > 0) THEN


   k=kts


    a(k)=  -dtz(k)*khdz(k)*rhoinv(k)

    b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) - &

           &    0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc

    c(k)=  -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc

    d(k)=qnbca(k)  - dtz(k)*rhoinv(k)*s_awqnbca(k+1)*nonloc


    DO k=kts+1,kte-1

       a(k)=  -dtz(k)*khdz(k)*rhoinv(k)     + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*nonloc

       b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) + &

           &    0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*nonloc

       c(k)=  -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc

       d(k)=qnbca(k) + dtz(k)*rhoinv(k)*(s_awqnbca(k)-s_awqnbca(k+1))*nonloc

    ENDDO


! prescribed value

    a(kte)=0.

    b(kte)=1.

    c(kte)=0.

    d(kte)=qnbca(kte)


!    CALL tridiag(kte,a,b,c,d)

   CALL tridiag2(kte,a,b,c,d,x)

!    CALL tridiag3(kte,a,b,c,d,x)


    DO k=kts,kte

       !qnbca2(k)=d(k-kts+1)

       qnbca2(k)=x(k)

    ENDDO


ELSE

    !If not mixing aerosols, set "updated" array equal to original array

    qnbca2=qnbca

ENDIF


!============================================

! Ozone - local mixing only

!============================================


    k=kts


!rho-weighted:

    a(k)=  -dtz(k)*khdz(k)*rhoinv(k)

    b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k)

    c(k)=  -dtz(k)*khdz(k+1)*rhoinv(k)

    d(k)=ozone(k)


    DO k=kts+1,kte-1

       a(k)=  -dtz(k)*khdz(k)*rhoinv(k)

       b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k)

       c(k)=  -dtz(k)*khdz(k+1)*rhoinv(k)

       d(k)=ozone(k)

    ENDDO


! prescribed value

    a(kte)=0.

    b(kte)=1.

    c(kte)=0.

    d(kte)=ozone(kte)


!    CALL tridiag(kte,a,b,c,d)

    CALL tridiag2(kte,a,b,c,d,x)

!    CALL tridiag3(kte,a,b,c,d,x)


    DO k=kts,kte

       !ozone2(k)=d(k-kts+1)

       dozone(k)=(x(k)-ozone(k))/delt

    ENDDO


!!============================================

!! Compute tendencies and convert to mixing ratios for WRF.

!! Note that the momentum tendencies are calculated above.

!!============================================


   IF (bl_mynn_mixqt > 0) THEN

      DO k=kts,kte

         !compute updated theta using updated thl and old condensate

         th_new = thl(k) + xlvcp/exner(k)*sqc(k) &

           &             + xlscp/exner(k)*sqi(k)


         t  = th_new*exner(k)

         qsat = qsat_blend(t,p(k))

         !SATURATED VAPOR PRESSURE

         !esat=esat_blend(t)

         !SATURATED SPECIFIC HUMIDITY

         !qsl=ep_2*esat/(p(k)-ep_3*esat)

         !qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat))


         IF (sqc(k) > 0.0 .or. sqi(k) > 0.0) THEN !initially saturated

            sqv2(k) = min(sqw2(k),qsat)

            portion_qc = sqc(k)/(sqc(k) + sqi(k))

            portion_qi = sqi(k)/(sqc(k) + sqi(k))

            condensate = max(sqw2(k) - qsat, 0.0)

            sqc2(k) = condensate*portion_qc

            sqi2(k) = condensate*portion_qi

         ELSE                     ! initially unsaturated -----

            sqv2(k) = sqw2(k)     ! let microphys decide what to do

            sqi2(k) = 0.0         ! if sqw2 > qsat

            sqc2(k) = 0.0

         ENDIF

      ENDDO

   ENDIF


    !=====================

    ! WATER VAPOR TENDENCY

    !=====================

    DO k=kts,kte

       dqv(k)=(sqv2(k) - sqv(k))/delt

       !if (sqv2(k) < 0.0)print*,"neg qv:",sqv2(k),k

    ENDDO


    IF (bl_mynn_cloudmix > 0) THEN

      !=====================

      ! CLOUD WATER TENDENCY

      !=====================

      !print*,"FLAG_QC:",FLAG_QC

      IF (flag_qc) THEN

         DO k=kts,kte

            dqc(k)=(sqc2(k) - sqc(k))/delt

            !if (sqc2(k) < 0.0)print*,"neg qc:",sqc2(k),k

         ENDDO

      ELSE

         DO k=kts,kte

           dqc(k) = 0.

         ENDDO

      ENDIF


      !===================

      ! CLOUD WATER NUM CONC TENDENCY

      !===================

      IF (flag_qnc .AND. bl_mynn_mixscalars > 0) THEN

         DO k=kts,kte

           dqnc(k) = (qnc2(k)-qnc(k))/delt

           !IF(Dqnc(k)*delt + qnc(k) < 0.)Dqnc(k)=-qnc(k)/delt

         ENDDO

      ELSE

         DO k=kts,kte

           dqnc(k) = 0.

         ENDDO

      ENDIF


      !===================

      ! CLOUD ICE TENDENCY

      !===================

      IF (flag_qi) THEN

         DO k=kts,kte

           dqi(k)=(sqi2(k) - sqi(k))/delt

           !if (sqi2(k) < 0.0)print*,"neg qi:",sqi2(k),k

         ENDDO

      ELSE

         DO k=kts,kte

           dqi(k) = 0.

         ENDDO

      ENDIF


      !===================

      ! CLOUD SNOW TENDENCY

      !===================

      IF (.false.) THEN !disabled

         DO k=kts,kte

           dqs(k)=(sqs2(k) - sqs(k))/delt

         ENDDO

      ELSE

         DO k=kts,kte

           dqs(k) = 0.

         ENDDO

      ENDIF


      !===================

      ! CLOUD ICE NUM CONC TENDENCY

      !===================

      IF (flag_qni .AND. bl_mynn_mixscalars > 0) THEN

         DO k=kts,kte

           dqni(k)=(qni2(k)-qni(k))/delt

           !IF(Dqni(k)*delt + qni(k) < 0.)Dqni(k)=-qni(k)/delt

         ENDDO

      ELSE

         DO k=kts,kte

           dqni(k)=0.

         ENDDO

      ENDIF

    ELSE !-MIX CLOUD SPECIES?

      !CLOUDS ARE NOT NIXED (when bl_mynn_cloudmix == 0)

      DO k=kts,kte

         dqc(k) =0.

         dqnc(k)=0.

         dqi(k) =0.

         dqni(k)=0.

         dqs(k) =0.

      ENDDO

    ENDIF


    !ensure non-negative moist species

    CALL moisture_check(kte, delt, delp, exner,        &

                        sqv2, sqc2, sqi2, sqs2, thl,   &

                        dqv, dqc, dqi, dqs, dth        )


    !=====================

    ! OZONE TENDENCY CHECK

    !=====================

    DO k=kts,kte

       IF(dozone(k)*delt + ozone(k) < 0.) THEN

         dozone(k)=-ozone(k)*0.99/delt

       ENDIF

    ENDDO


    !===================

    ! THETA TENDENCY

    !===================

    IF (flag_qi) THEN

      DO k=kts,kte

         dth(k)=(thl(k) + xlvcp/exner(k)*sqc2(k)          &

           &            + xlscp/exner(k)*(sqi2(k)+sqs(k)) &

           &            - th(k))/delt

         !Use form from Tripoli and Cotton (1981) with their

         !suggested min temperature to improve accuracy:

         !Dth(k)=(thl(k)*(1.+ xlvcp/MAX(tk(k),TKmin)*sqc(k)  &

         !  &               + xlscp/MAX(tk(k),TKmin)*sqi(k)) &

         !  &               - th(k))/delt

      ENDDO

    ELSE

      DO k=kts,kte

         dth(k)=(thl(k)+xlvcp/exner(k)*sqc2(k) - th(k))/delt

         !Use form from Tripoli and Cotton (1981) with their

         !suggested min temperature to improve accuracy.

         !Dth(k)=(thl(k)*(1.+ xlvcp/MAX(tk(k),TKmin)*sqc(k))  &

         !&               - th(k))/delt

      ENDDO

    ENDIF


    !===================

    ! AEROSOL TENDENCIES

    !===================

    IF (flag_qnwfa .AND. flag_qnifa .AND. &

        bl_mynn_mixscalars > 0) THEN

       DO k=kts,kte

          !=====================

          ! WATER-friendly aerosols

          !=====================

          dqnwfa(k)=(qnwfa2(k) - qnwfa(k))/delt

          !=====================

          ! Ice-friendly aerosols

          !=====================

          dqnifa(k)=(qnifa2(k) - qnifa(k))/delt

       ENDDO

    ELSE

       DO k=kts,kte

          dqnwfa(k)=0.

          dqnifa(k)=0.

       ENDDO

    ENDIF


    !========================

    ! BLACK-CARBON TENDENCIES

    !========================

    IF (flag_qnbca .AND. bl_mynn_mixscalars > 0) THEN

       DO k=kts,kte

          dqnbca(k)=(qnbca2(k) - qnbca(k))/delt

       ENDDO

    ELSE

       DO k=kts,kte

          dqnbca(k)=0.

       ENDDO

    ENDIF


    !ensure non-negative moist species

    !note: if called down here, dth needs to be updated, but

    !      if called before the theta-tendency calculation, do not compute dth

    !CALL moisture_check(kte, delt, delp, exner,     &

    !                    sqv, sqc, sqi, thl,         &

    !                    dqv, dqc, dqi, dth )


    if (debug_code) then

       problem = .false.

       do k=kts,kte

          wsp  = sqrt(u(k)**2 + v(k)**2)

          wsp2 = sqrt((u(k)+du(k)*delt)**2 + (v(k)+du(k)*delt)**2)

          th2  = th(k) + dth(k)*delt

          tk2  = th2*exner(k)

          if (wsp2 > 200. .or. tk2 > 360. .or. tk2 < 160.) then

             problem = .true.

             print*,"Outgoing problem at: i=",i," k=",k

             print*," incoming wsp=",wsp," outgoing wsp=",wsp2

             print*," incoming T=",th(k)*exner(k),"outgoing T:",tk2

             print*," du=",du(k)*delt," dv=",dv(k)*delt," dth=",dth(k)*delt

             print*," km=",kmdz(k)*dz(k)," kh=",khdz(k)*dz(k)

             print*," u*=",ust," wspd=",wspd,"rhosfc=",rhosfc

             print*," LH=",flq*rhosfc*1004.," HFX=",flt*rhosfc*1004.

             print*," drag term=",ust**2/wspd*dtz(k)*rhosfc/rho(kts)

             kproblem = k

          endif

       enddo

       if (problem) then

          print*,"==thl:",thl(max(kproblem-3,1):min(kproblem+3,kte))

          print*,"===qv:",sqv2(max(kproblem-3,1):min(kproblem+3,kte))

          print*,"===qc:",sqc2(max(kproblem-3,1):min(kproblem+3,kte))

          print*,"===qi:",sqi2(max(kproblem-3,1):min(kproblem+3,kte))

          print*,"====u:",u(max(kproblem-3,1):min(kproblem+3,kte))

          print*,"====v:",v(max(kproblem-3,1):min(kproblem+3,kte))

       endif

    endif


#ifdef HARDCODE_VERTICAL

# undef kts

# undef kte

#endif


  END SUBROUTINE mynn_tendencies


! ==================================================================


  SUBROUTINE moisture_check(kte, delt, dp, exner,   &

                            qv, qc, qi, qs, th,     &

                            dqv, dqc, dqi, dqs, dth )


  ! This subroutine was adopted from the CAM-UW ShCu scheme and

  ! adapted for use here.

  !

  ! If qc < qcmin, qi < qimin, or qv < qvmin happens in any layer,

  ! force them to be larger than minimum value by (1) condensating

  ! water vapor into liquid or ice, and (2) by transporting water vapor

  ! from the very lower layer.

  !

  ! We then update the final state variables and tendencies associated

  ! with this correction. If any condensation happens, update theta too.

  ! Note that (qv,qc,qi,th) are the final state variables after

  ! applying corresponding input tendencies and corrective tendencies.


    implicit none

    integer,         intent(in)     :: kte

    real(kind_phys), intent(in)     :: delt

    real(kind_phys), dimension(kte), intent(in)     :: dp, exner

    real(kind_phys), dimension(kte), intent(inout)  :: qv, qc, qi, qs, th

    real(kind_phys), dimension(kte), intent(inout)  :: dqv, dqc, dqi, dqs, dth

    integer   k

    real(kind_phys)::  dqc2, dqi2, dqs2, dqv2, sum, aa, dum

    real(kind_phys), parameter :: qvmin = 1e-20,       &

                                  qcmin = 0.0,         &

                                  qimin = 0.0


    do k = kte, 1, -1  ! From the top to the surface

       dqc2 = max(0.0, qcmin-qc(k)) !qc deficit (>=0)

       dqi2 = max(0.0, qimin-qi(k)) !qi deficit (>=0)

       dqs2 = max(0.0, qimin-qs(k)) !qs deficit (>=0)


       !fix tendencies

       dqc(k) = dqc(k) +  dqc2/delt

       dqi(k) = dqi(k) +  dqi2/delt

       dqs(k) = dqs(k) +  dqs2/delt

       dqv(k) = dqv(k) - (dqc2+dqi2+dqs2)/delt

       dth(k) = dth(k) + xlvcp/exner(k)*(dqc2/delt) + &

                         xlscp/exner(k)*((dqi2+dqs2)/delt)

       !update species

       qc(k)  = qc(k)  +  dqc2

       qi(k)  = qi(k)  +  dqi2

       qs(k)  = qs(k)  +  dqs2

       qv(k)  = qv(k)  -  dqc2 - dqi2 - dqs2

       th(k)  = th(k)  +  xlvcp/exner(k)*dqc2 + &

                          xlscp/exner(k)*(dqi2+dqs2)


       !then fix qv

       dqv2   = max(0.0, qvmin-qv(k)) !qv deficit (>=0)

       dqv(k) = dqv(k) + dqv2/delt

       qv(k)  = qv(k)  + dqv2

       if( k .ne. 1 ) then

           qv(k-1)   = qv(k-1)  - dqv2*dp(k)/dp(k-1)

           dqv(k-1)  = dqv(k-1) - dqv2*dp(k)/dp(k-1)/delt

       endif

       qv(k) = max(qv(k),qvmin)

       qc(k) = max(qc(k),qcmin)

       qi(k) = max(qi(k),qimin)

       qs(k) = max(qs(k),qimin)

    end do

    ! Extra moisture used to satisfy 'qv(1)>=qvmin' is proportionally

    ! extracted from all the layers that has 'qv > 2*qvmin'. This fully

    ! preserves column moisture.

    if( dqv2 .gt. 1.e-20 ) then

        sum = 0.0

        do k = 1, kte

           if( qv(k) .gt. 2.0*qvmin ) sum = sum + qv(k)*dp(k)

        enddo

        aa = dqv2*dp(1)/max(1.e-20,sum)

        if( aa .lt. 0.5 ) then

            do k = 1, kte

               if( qv(k) .gt. 2.0*qvmin ) then

                   dum    = aa*qv(k)

                   qv(k)  = qv(k) - dum

                   dqv(k) = dqv(k) - dum/delt

               endif

            enddo

        else

        ! For testing purposes only (not yet found in any output):

        !    write(*,*) 'Full moisture conservation is impossible'

        endif

    endif


    return


  END SUBROUTINE moisture_check


! ==================================================================


  SUBROUTINE mynn_mix_chem(kts,kte,i,     &

       delt,dz,pblh,                      &

       nchem, kdvel, ndvel,               &

       chem1, vd1,                        &

       rho,                               &

       flt, tcd, qcd,                     &

       dfh,                               &

       s_aw, s_awchem,                    &

       emis_ant_no, frp, rrfs_sd,         &

       enh_mix, smoke_dbg                 )


!-------------------------------------------------------------------

    integer, intent(in) :: kts,kte,i

    real(kind_phys), dimension(kts:kte), intent(in)    :: dfh,dz,tcd,qcd

    real(kind_phys), dimension(kts:kte), intent(inout) :: rho

    real(kind_phys), intent(in)    :: flt

    real(kind_phys), intent(in)    :: delt,pblh

    integer, intent(in) :: nchem, kdvel, ndvel

    real(kind_phys), dimension( kts:kte+1), intent(in) :: s_aw

    real(kind_phys), dimension( kts:kte, nchem ), intent(inout) :: chem1

    real(kind_phys), dimension( kts:kte+1,nchem), intent(in) :: s_awchem

    real(kind_phys), dimension( ndvel ), intent(in) :: vd1

    real(kind_phys), intent(in) :: emis_ant_no,frp

    logical, intent(in) :: rrfs_sd,enh_mix,smoke_dbg

!local vars


    real(kind_phys), dimension(kts:kte)     :: dtz

    real(kind_phys), dimension(kts:kte) :: a,b,c,d,x

    real(kind_phys):: rhs,dztop

    real(kind_phys):: t,dzk

    real(kind_phys):: hght

    real(kind_phys):: khdz_old, khdz_back

    integer :: k,kk,kmaxfire                         ! JLS 12/21/21

    integer :: ic  ! Chemical array loop index


    integer, SAVE :: icall


    real(kind_phys), dimension(kts:kte) :: rhoinv

    real(kind_phys), dimension(kts:kte+1) :: rhoz,khdz

    real(kind_phys), parameter :: NO_threshold    = 10.0     ! For anthropogenic sources

    real(kind_phys), parameter :: frp_threshold   = 10.0     ! RAR 02/11/22: I increased the frp threshold to enhance mixing over big fires

    real(kind_phys), parameter :: pblh_threshold  = 100.0


    dztop=.5*(dz(kte)+dz(kte-1))


    DO k=kts,kte

       dtz(k)=delt/dz(k)

    ENDDO


    !Prepare "constants" for diffusion equation.

    !khdz = rho*Kh/dz = rho*dfh

    rhoz(kts)  =rho(kts)

    rhoinv(kts)=1./rho(kts)

    khdz(kts)  =rhoz(kts)*dfh(kts)


    DO k=kts+1,kte

       rhoz(k)  =(rho(k)*dz(k-1) + rho(k-1)*dz(k))/(dz(k-1)+dz(k))

       rhoz(k)  =  max(rhoz(k),1e-4)

       rhoinv(k)=1./max(rho(k),1e-4)

       dzk      = 0.5  *( dz(k)+dz(k-1) )

       khdz(k)  = rhoz(k)*dfh(k)

    ENDDO

    rhoz(kte+1)=rhoz(kte)

    khdz(kte+1)=rhoz(kte+1)*dfh(kte)


    !stability criteria for mf

    DO k=kts+1,kte-1

       khdz(k) = max(khdz(k),  0.5*s_aw(k))

       khdz(k) = max(khdz(k), -0.5*(s_aw(k)-s_aw(k+1)))

    ENDDO


    !Enhanced mixing over fires

    IF ( rrfs_sd .and. enh_mix ) THEN

       DO k=kts+1,kte-1

          khdz_old  = khdz(k)

          khdz_back = pblh * 0.15 / dz(k)

          !Modify based on anthropogenic emissions of NO and FRP

          IF ( pblh < pblh_threshold ) THEN

             IF ( emis_ant_no > no_threshold ) THEN

                khdz(k) = max(1.1*khdz(k),sqrt((emis_ant_no / no_threshold)) / dz(k) * rhoz(k)) ! JLS 12/21/21

!                khdz(k) = MAX(khdz(k),khdz_back)

             ENDIF

             IF ( frp > frp_threshold ) THEN

                kmaxfire = ceiling(log(frp))

                khdz(k) = max(1.1*khdz(k), (1. - k/(kmaxfire*2.)) * ((log(frp))**2.- 2.*log(frp)) / dz(k)*rhoz(k)) ! JLS 12/21/21

!                khdz(k) = MAX(khdz(k),khdz_back)

             ENDIF

          ENDIF

       ENDDO

    ENDIF


  !============================================

  ! Patterned after mixing of water vapor in mynn_tendencies.

  !============================================


    DO ic = 1,nchem

       k=kts


       a(k)=  -dtz(k)*khdz(k)*rhoinv(k)

       b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)

       c(k)=  -dtz(k)*khdz(k+1)*rhoinv(k)           - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)

       d(k)=chem1(k,ic) & !dtz(k)*flt  !neglecting surface sources

            & - dtz(k)*vd1(ic)*chem1(k,ic) &

            & - dtz(k)*rhoinv(k)*s_awchem(k+1,ic)


       DO k=kts+1,kte-1

          a(k)=  -dtz(k)*khdz(k)*rhoinv(k)     + 0.5*dtz(k)*rhoinv(k)*s_aw(k)

          b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + &

             &    0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))

          c(k)=  -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)

          d(k)=chem1(k,ic) + dtz(k)*rhoinv(k)*(s_awchem(k,ic)-s_awchem(k+1,ic))

       ENDDO


      ! prescribed value at top

       a(kte)=0.

       b(kte)=1.

       c(kte)=0.

       d(kte)=chem1(kte,ic)


       CALL tridiag3(kte,a,b,c,d,x)


       IF ( smoke_dbg ) THEN

            print*,'aerosol mixing ic,chem1,chem2(k,ic)',ic,(chem1(kts:kts+10,ic)),(x(kts:kts+10))

            print*,'aerosol PBL mixing ic,vd1(ic)',ic,vd1(ic)

       END IF


       DO k=kts,kte

          chem1(k,ic)=x(k)

       ENDDO

    ENDDO


  END SUBROUTINE mynn_mix_chem


! ==================================================================


  SUBROUTINE retrieve_exchange_coeffs(kts,kte,&

       &dfm,dfh,dz,K_m,K_h)


!-------------------------------------------------------------------


    integer , intent(in) :: kts,kte


    real(kind_phys), dimension(KtS:KtE), intent(in) :: dz,dfm,dfh


    real(kind_phys), dimension(KtS:KtE), intent(out) :: K_m, K_h


    integer :: k

    real(kind_phys):: dzk


    k_m(kts)=0.

    k_h(kts)=0.


    DO k=kts+1,kte

       dzk = 0.5  *( dz(k)+dz(k-1) )

       k_m(k)=dfm(k)*dzk

       k_h(k)=dfh(k)*dzk

    ENDDO


  END SUBROUTINE retrieve_exchange_coeffs


! ==================================================================


  SUBROUTINE tridiag(n,a,b,c,d)


!! to solve system of linear eqs on tridiagonal matrix n times n

!! after Peaceman and Rachford, 1955

!! a,b,c,d - are vectors of order n

!! a,b,c - are coefficients on the LHS

!! d - is initially RHS on the output becomes a solution vector


!-------------------------------------------------------------------


    integer, intent(in):: n

    real(kind_phys), dimension(n), intent(in) :: a,b

    real(kind_phys), dimension(n), intent(inout) :: c,d


    integer :: i

    real(kind_phys):: p

    real(kind_phys), dimension(n) :: q


    c(n)=0.

    q(1)=-c(1)/b(1)

    d(1)=d(1)/b(1)


    DO i=2,n

       p=1./(b(i)+a(i)*q(i-1))

       q(i)=-c(i)*p

       d(i)=(d(i)-a(i)*d(i-1))*p

    ENDDO


    DO i=n-1,1,-1

       d(i)=d(i)+q(i)*d(i+1)

    ENDDO


  END SUBROUTINE tridiag


! ==================================================================


      subroutine tridiag2(n,a,b,c,d,x)

      implicit none

!      a - sub-diagonal (means it is the diagonal below the main diagonal)

!      b - the main diagonal

!      c - sup-diagonal (means it is the diagonal above the main diagonal)

!      d - right part

!      x - the answer

!      n - number of unknowns (levels)


        integer,intent(in) :: n

        real(kind_phys), dimension(n), intent(in) :: a,b,c,d

        real(kind_phys), dimension(n), intent(out):: x

        real(kind_phys), dimension(n)  :: cp,dp

        real(kind_phys):: m

        integer :: i


        ! initialize c-prime and d-prime

        cp(1) = c(1)/b(1)

        dp(1) = d(1)/b(1)

        ! solve for vectors c-prime and d-prime

        do i = 2,n

           m = b(i)-cp(i-1)*a(i)

           cp(i) = c(i)/m

           dp(i) = (d(i)-dp(i-1)*a(i))/m

        enddo

        ! initialize x

        x(n) = dp(n)

        ! solve for x from the vectors c-prime and d-prime

        do i = n-1, 1, -1

           x(i) = dp(i)-cp(i)*x(i+1)

        end do


    end subroutine tridiag2

! ==================================================================


       subroutine tridiag3(kte,a,b,c,d,x)


!ccccccccccccccccccccccccccccccc

! Aim: Inversion and resolution of a tridiagonal matrix

!          A X = D

! Input:

!  a(*) lower diagonal (Ai,i-1)

!  b(*) principal diagonal (Ai,i)

!  c(*) upper diagonal (Ai,i+1)

!  d

! Output

!  x     results

!ccccccccccccccccccccccccccccccc


       implicit none

        integer,intent(in)   :: kte

        integer, parameter   :: kts=1

        real(kind_phys), dimension(kte) :: a,b,c,d

        real(kind_phys), dimension(kte), intent(out) :: x

        integer :: in


!       integer kms,kme,kts,kte,in

!       real(kind_phys)a(kms:kme,3),c(kms:kme),x(kms:kme)


        do in=kte-1,kts,-1

         d(in)=d(in)-c(in)*d(in+1)/b(in+1)

         b(in)=b(in)-c(in)*a(in+1)/b(in+1)

        enddo


        do in=kts+1,kte

         d(in)=d(in)-a(in)*d(in-1)/b(in-1)

        enddo


        do in=kts,kte

         x(in)=d(in)/b(in)

        enddo


        return


        end subroutine tridiag3


! ==================================================================


  SUBROUTINE get_pblh(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea,kzi)


    !---------------------------------------------------------------

    !             NOTES ON THE PBLH FORMULATION

    !

    !The 1.5-theta-increase method defines PBL heights as the level at

    !which the potential temperature first exceeds the minimum potential

    !temperature within the boundary layer by 1.5 K. When applied to

    !observed temperatures, this method has been shown to produce PBL-

    !height estimates that are unbiased relative to profiler-based

    !estimates (Nielsen-Gammon et al. 2008). However, their study did not

    !include LLJs. Banta and Pichugina (2008) show that a TKE-based

    !threshold is a good estimate of the PBL height in LLJs. Therefore,

    !a hybrid definition is implemented that uses both methods, weighting

    !the TKE-method more during stable conditions (PBLH < 400 m).

    !A variable tke threshold (TKEeps) is used since no hard-wired

    !value could be found to work best in all conditions.

    !---------------------------------------------------------------


    integer,intent(in) :: KTS,KTE


#ifdef HARDCODE_VERTICAL

# define kts 1

# define kte HARDCODE_VERTICAL

#endif


    real(kind_phys), intent(out) :: zi

    real(kind_phys), intent(in) :: landsea

    real(kind_phys), dimension(kts:kte), intent(in) :: thetav1D, qke1D, dz1D

    real(kind_phys), dimension(kts:kte+1), intent(in) :: zw1D

    !LOCAL VARS

    real(kind_phys)::  PBLH_TKE,qtke,qtkem1,wt,maxqke,TKEeps,minthv

    real(kind_phys):: delt_thv   !delta theta-v; dependent on land/sea point

    real(kind_phys), parameter :: sbl_lim  = 200. !upper limit of stable BL height (m).

    real(kind_phys), parameter :: sbl_damp = 400. !transition length for blending (m).

    integer :: I,J,K,kthv,ktke,kzi


    !Initialize KPBL (kzi)

    kzi = 2


    k = kts+1

    kthv = 1

    minthv = 9.e9

    DO WHILE (zw1d(k) .LE. 200.)

    !DO k=kts+1,kte-1

       IF (minthv > thetav1d(k)) then

           minthv = thetav1d(k)

           kthv = k

       ENDIF

       k = k+1

       !IF (zw1D(k) .GT. sbl_lim) exit

    ENDDO


    zi=0.

    k = kthv+1

    IF((landsea-1.5).GE.0)THEN

        ! WATER

        delt_thv = 1.0

    ELSE

        ! LAND

        delt_thv = 1.25

    ENDIF


    zi=0.

    k = kthv+1

!    DO WHILE (zi .EQ. 0.)

    DO k=kts+1,kte-1

       IF (thetav1d(k) .GE. (minthv + delt_thv))THEN

          zi = zw1d(k) - dz1d(k-1)* &

             & min((thetav1d(k)-(minthv + delt_thv))/ &

             & max(thetav1d(k)-thetav1d(k-1),1e-6),1.0)

       ENDIF

       !k = k+1

       IF (k .EQ. kte-1) zi = zw1d(kts+1) !EXIT SAFEGUARD

       IF (zi .NE. 0.0) exit

    ENDDO

    !print*,"IN GET_PBLH:",thsfc,zi


    ktke = 1

    maxqke = max(qke1d(kts),0.)

    !Use 5% of tke max (Kosovic and Curry, 2000; JAS)

    !TKEeps = maxtke/20. = maxqke/40.

    tkeeps = maxqke/40.

    tkeeps = max(tkeeps,0.02) !0.025)

    pblh_tke=0.


    k = ktke+1

!    DO WHILE (PBLH_TKE .EQ. 0.)

    DO k=kts+1,kte-1

       !QKE CAN BE NEGATIVE (IF CKmod == 0)... MAKE TKE NON-NEGATIVE.

       qtke  =max(qke1d(k)/2.,0.)      ! maximum TKE

       qtkem1=max(qke1d(k-1)/2.,0.)

       IF (qtke .LE. tkeeps) THEN

           pblh_tke = zw1d(k) - dz1d(k-1)* &

             & min((tkeeps-qtke)/max(qtkem1-qtke, 1e-6), 1.0)

           !IN CASE OF NEAR ZERO TKE, SET PBLH = LOWEST LEVEL.

           pblh_tke = max(pblh_tke,zw1d(kts+1))

           !print *,"PBLH_TKE:",i,PBLH_TKE, Qke1D(k)/2., zw1D(kts+1)

       ENDIF

       !k = k+1

       IF (k .EQ. kte-1) pblh_tke = zw1d(kts+1) !EXIT SAFEGUARD

       IF (pblh_tke .NE. 0.) exit

    ENDDO


    pblh_tke = min(pblh_tke,zi+350.)

    pblh_tke = max(pblh_tke,max(zi-350.,10.))


    wt=.5*tanh((zi - sbl_lim)/sbl_damp) + .5

    IF (maxqke <= 0.05) THEN

       !Cold pool situation - default to theta_v-based def

    ELSE

       !BLEND THE TWO PBLH TYPES HERE:

       zi=pblh_tke*(1.-wt) + zi*wt

    ENDIF


    !Compute KPBL (kzi)

    DO k=kts+1,kte-1

       IF ( zw1d(k) >= zi) THEN

          kzi = k-1

          exit

       ENDIF

    ENDDO


#ifdef HARDCODE_VERTICAL

# undef kts

# undef kte

#endif


  END SUBROUTINE get_pblh


! ==================================================================


  SUBROUTINE dmp_mf(                            &

                 & kts,kte,dt,zw,dz,p,rho,      &

                 & momentum_opt,                &

                 & tke_opt,                     &

                 & scalar_opt,                  &

                 & u,v,w,th,thl,thv,tk,         &

                 & qt,qv,qc,qke,                &

                 & qnc,qni,qnwfa,qnifa,qnbca,   &

                 & exner,vt,vq,sgm,             &

                 & ust,flt,fltv,flq,flqv,       &

                 & pblh,kpbl,dx,landsea,ts,     &

            ! outputs - updraft properties

                 & edmf_a,edmf_w,               &

                 & edmf_qt,edmf_thl,            &

                 & edmf_ent,edmf_qc,            &

            ! outputs - variables needed for solver

                 & s_aw,s_awthl,s_awqt,         &

                 & s_awqv,s_awqc,               &

                 & s_awu,s_awv,s_awqke,         &

                 & s_awqnc,s_awqni,             &

                 & s_awqnwfa,s_awqnifa,         &

                 & s_awqnbca,                   &

                 & sub_thl,sub_sqv,             &

                 & sub_u,sub_v,                 &

                 & det_thl,det_sqv,det_sqc,     &

                 & det_u,det_v,                 &

            ! chem/smoke

                 & nchem,chem1,s_awchem,        &

                 & mix_chem,                    &

            ! in/outputs - subgrid scale clouds

                 & qc_bl1d,cldfra_bl1d,         &

                 & qc_bl1D_old,cldfra_bl1D_old, &

            ! inputs - flags for moist arrays

                 & F_QC,F_QI,                   &

                 & F_QNC,F_QNI,                 &

                 & F_QNWFA,F_QNIFA,F_QNBCA,     &

                 & Psig_shcu,                   &

            ! output info

                 & maxwidth,ktop,maxmf,ztop,    &

            ! inputs for stochastic perturbations

                 & spp_pbl,rstoch_col           )


  ! inputs:

     integer, intent(in) :: KTS,KTE,KPBL,momentum_opt,tke_opt,scalar_opt


#ifdef HARDCODE_VERTICAL

# define kts 1

# define kte HARDCODE_VERTICAL

#endif


! Stochastic

     integer,  intent(in)                 :: spp_pbl

     real(kind_phys), dimension(kts:kte)  :: rstoch_col


     real(kind_phys),dimension(kts:kte), intent(in) ::                 &

          &U,V,W,TH,THL,TK,QT,QV,QC,                                   &

          &exner,dz,THV,P,rho,qke,qnc,qni,qnwfa,qnifa,qnbca

     real(kind_phys),dimension(kts:kte+1), intent(in) :: zw    !height at full-sigma

     real(kind_phys), intent(in) :: flt,fltv,flq,flqv,Psig_shcu,       &

          &landsea,ts,dx,dt,ust,pblh

     logical, optional :: F_QC,F_QI,F_QNC,F_QNI,F_QNWFA,F_QNIFA,F_QNBCA


  ! outputs - updraft properties

     real(kind_phys),dimension(kts:kte), intent(out) :: edmf_a,edmf_w, &

                      & edmf_qt,edmf_thl,edmf_ent,edmf_qc

     !add one local edmf variable:

     real(kind_phys),dimension(kts:kte) :: edmf_th

  ! output

     integer, intent(out) :: ktop

     real(kind_phys), intent(out) :: maxmf,ztop,maxwidth

  ! outputs - variables needed for solver

     real(kind_phys),dimension(kts:kte+1) :: s_aw,                     & !sum ai*rho*wis_awphi

          &s_awthl,s_awqt,s_awqv,s_awqc,s_awqnc,s_awqni,               &

          &s_awqnwfa,s_awqnifa,s_awqnbca,s_awu,s_awv,                  &

          &s_awqke,s_aw2


     real(kind_phys),dimension(kts:kte), intent(inout) ::              &

          &qc_bl1d,cldfra_bl1d,qc_bl1d_old,cldfra_bl1d_old


    integer, parameter :: nup=8, debug_mf=0

    real(kind_phys)    :: nup2


  !------------- local variables -------------------

  ! updraft properties defined on interfaces (k=1 is the top of the

  ! first model layer

     real(kind_phys),dimension(kts:kte+1,1:NUP) ::                     &

          &UPW,UPTHL,UPQT,UPQC,UPQV,                                   &

          &UPA,UPU,UPV,UPTHV,UPQKE,UPQNC,                              &

          &UPQNI,UPQNWFA,UPQNIFA,UPQNBCA

  ! entrainment variables

     real(kind_phys),dimension(kts:kte,1:NUP) :: ENT,ENTf

     integer,dimension(kts:kte,1:NUP)         :: ENTi

  ! internal variables

     integer :: K,I,k50

     real(kind_phys):: fltv2,wstar,qstar,thstar,sigmaW,sigmaQT,        &

          &sigmaTH,z0,pwmin,pwmax,wmin,wmax,wlv,Psig_w,maxw,maxqc,wpbl

     real(kind_phys):: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,QNCn,QNIn,       &

          &  QNWFAn,QNIFAn,QNBCAn,                                     &

          &  Wn2,Wn,EntEXP,EntEXM,EntW,BCOEFF,THVkm1,THVk,Pk,rho_int


  ! w parameters

     real(kind_phys), parameter ::                                     &

          &Wa=2./3.,                                                   &

          &Wb=0.002,                                                   &

          &Wc=1.5


  ! Lateral entrainment parameters ( L0=100 and ENT0=0.1) were taken from

  ! Suselj et al (2013, jas). Note that Suselj et al (2014,waf) use L0=200 and ENT0=0.2.

     real(kind_phys),parameter ::                                      &

          & L0=100.,                                                   &

          & ENT0=0.1


  ! Parameters/variables for regulating plumes:

     real(kind_phys), parameter :: Atot = 0.10 ! Maximum total fractional area of all updrafts

     real(kind_phys), parameter :: lmax = 1000.! diameter of largest plume (absolute maximum, can be smaller)

     real(kind_phys), parameter :: lmin = 300. ! diameter of smallest plume (absolute minimum, can be larger)

     real(kind_phys), parameter :: dlmin = 0.  ! delta increase in the diameter of smallest plume (large fltv)

     real(kind_phys)            :: minwidth    ! actual width of smallest plume

     real(kind_phys)            :: dl          ! variable increment of plume size

     real(kind_phys), parameter :: dcut = 1.2  ! max diameter of plume to parameterize relative to dx (km)

     real(kind_phys)::  d     != -2.3 to -1.7  ;=-1.9 in Neggers paper; power law exponent for number density (N=Cl^d).

          ! Note that changing d to -2.0 makes each size plume equally contribute to the total coverage of all plumes.

          ! Note that changing d to -1.7 doubles the area coverage of the largest plumes relative to the smallest plumes.

     real(kind_phys):: cn,c,l,n,an2,hux,wspd_pbl,cloud_base,width_flx


  ! chem/smoke

     integer, intent(in) :: nchem

     real(kind_phys),dimension(:, :) :: chem1

     real(kind_phys),dimension(kts:kte+1, nchem) :: s_awchem

     real(kind_phys),dimension(nchem) :: chemn

     real(kind_phys),dimension(kts:kte+1,1:NUP, nchem) :: UPCHEM

     integer :: ic

     real(kind_phys),dimension(kts:kte+1, nchem) :: edmf_chem

     logical, intent(in) :: mix_chem


  !JOE: add declaration of ERF

   real(kind_phys):: ERF


   logical :: superadiabatic


  ! VARIABLES FOR CHABOUREAU-BECHTOLD CLOUD FRACTION

   real(kind_phys),dimension(kts:kte), intent(inout) :: vt, vq, sgm

   real(kind_phys):: sigq,xl,rsl,cpm,a,qmq,mf_cf,Aup,Q1,diffqt,qsat_tk,&

           Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9,satvp,rhgrid,           &

           Ac_mf,Ac_strat,qc_mf

   real(kind_phys), parameter :: cf_thresh = 0.5 ! only overwrite stratus CF less than this value


  ! Variables for plume interpolation/saturation check

   real(kind_phys),dimension(kts:kte) :: exneri,dzi,rhoz

   real(kind_phys):: THp, QTp, QCp, QCs, esat, qsl

   real(kind_phys):: csigma,acfac,ac_wsp


   !plume overshoot

   integer :: overshoot

   real(kind_phys):: bvf, Frz, dzp


   !Flux limiter: not let mass-flux of heat between k=1&2 exceed (fluxportion)*(surface heat flux).

   !This limiter makes adjustments to the entire column.

   real(kind_phys):: adjustment, flx1

   real(kind_phys), parameter :: fluxportion=0.75 ! set liberally, so has minimal impact. Note that

                                       ! 0.5 starts to have a noticeable impact

                                       ! over land (decrease maxMF by 10-20%), but no impact over water.


   !Subsidence

   real(kind_phys),dimension(kts:kte) :: sub_thl,sub_sqv,sub_u,sub_v,  &  !tendencies due to subsidence

                      det_thl,det_sqv,det_sqc,det_u,det_v,             &  !tendencied due to detrainment

                 envm_a,envm_w,envm_thl,envm_sqv,envm_sqc,             &

                                       envm_u,envm_v  !environmental variables defined at middle of layer

   real(kind_phys),dimension(kts:kte+1) ::  envi_a,envi_w        !environmental variables defined at model interface

   real(kind_phys):: temp,sublim,qc_ent,qv_ent,qt_ent,thl_ent,detrate, &

           detrateUV,oow,exc_fac,aratio,detturb,qc_grid,qc_sgs,        &

           qc_plume,exc_heat,exc_moist,tk_int,tvs

   real(kind_phys), parameter :: Cdet   = 1./45.

   real(kind_phys), parameter :: dzpmax = 300. !limit dz used in detrainment - can be excessing in thick layers

   !parameter "Csub" determines the propotion of upward vertical velocity that contributes to

   !environmenatal subsidence. Some portion is expected to be compensated by downdrafts instead of

   !gentle environmental subsidence. 1.0 assumes all upward vertical velocity in the mass-flux scheme

   !is compensated by "gentle" environmental subsidence.

   real(kind_phys), parameter :: Csub=0.25


   !Factor for the pressure gradient effects on momentum transport

   real(kind_phys), parameter :: pgfac = 0.00  ! Zhang and Wu showed 0.4 is more appropriate for lower troposphere

   real(kind_phys):: Uk,Ukm1,Vk,Vkm1,dxsa


! check the inputs

!     print *,'dt',dt

!     print *,'dz',dz

!     print *,'u',u

!     print *,'v',v

!     print *,'thl',thl

!     print *,'qt',qt

!     print *,'ust',ust

!     print *,'flt',flt

!     print *,'flq',flq

!     print *,'pblh',pblh


! Initialize individual updraft properties

  upw=0.

  upthl=0.

  upthv=0.

  upqt=0.

  upa=0.

  upu=0.

  upv=0.

  upqc=0.

  upqv=0.

  upqke=0.

  upqnc=0.

  upqni=0.

  upqnwfa=0.

  upqnifa=0.

  upqnbca=0.

  if ( mix_chem ) then

     upchem(kts:kte+1,1:nup,1:nchem)=0.0

  endif


  ent=0.001

! Initialize mean updraft properties

  edmf_a  =0.

  edmf_w  =0.

  edmf_qt =0.

  edmf_thl=0.

  edmf_ent=0.

  edmf_qc =0.

  if ( mix_chem ) then

     edmf_chem(kts:kte+1,1:nchem) = 0.0

  endif


! Initialize the variables needed for implicit solver

  s_aw=0.

  s_awthl=0.

  s_awqt=0.

  s_awqv=0.

  s_awqc=0.

  s_awu=0.

  s_awv=0.

  s_awqke=0.

  s_awqnc=0.

  s_awqni=0.

  s_awqnwfa=0.

  s_awqnifa=0.

  s_awqnbca=0.

  if ( mix_chem ) then

     s_awchem(kts:kte+1,1:nchem) = 0.0

  endif


! Initialize explicit tendencies for subsidence & detrainment

  sub_thl = 0.

  sub_sqv = 0.

  sub_u   = 0.

  sub_v   = 0.

  det_thl = 0.

  det_sqv = 0.

  det_sqc = 0.

  det_u   = 0.

  det_v   = 0.

  nup2    = nup !start with nup, but set to zero if activation criteria fails


  ! Taper off MF scheme when significant resolved-scale motions

  ! are present This function needs to be asymetric...

  maxw    = 0.0

  cloud_base  = 9000.0

  do k=1,kte-1

     if (zw(k) > pblh + 500.) exit


     wpbl = w(k)

     if (w(k) < 0.)wpbl = 2.*w(k)

     maxw = max(maxw,abs(wpbl))


     !Find highest k-level below 50m AGL

     if (zw(k)<=50.)k50=k


     !Search for cloud base

     qc_sgs = max(qc(k), qc_bl1d(k))

     if (qc_sgs> 1e-5 .and. (cldfra_bl1d(k) .ge. 0.5) .and. cloud_base == 9000.0) then

       cloud_base = 0.5*(zw(k)+zw(k+1))

     endif

  enddo


  !do nothing for small w (< 1 m/s), but linearly taper off for w > 1.0 m/s

  maxw = max(0.,maxw - 1.0)

  psig_w = max(0.0, 1.0 - maxw)

  psig_w = min(psig_w, psig_shcu)


  !Completely shut off MF scheme for strong resolved-scale vertical velocities.

  fltv2 = fltv

  if(psig_w == 0.0 .and. fltv > 0.0) fltv2 = -1.*fltv


  ! If surface buoyancy is positive we do integration, otherwise no.

  ! Also, ensure that it is at least slightly superadiabatic up through 50 m

  superadiabatic = .false.

  if ((landsea-1.5).ge.0) then

     hux = -0.001   ! WATER  ! dT/dz must be < - 0.1 K per 100 m.

  else

     hux = -0.005  ! LAND    ! dT/dz must be < - 0.5 K per 100 m.

  endif

  tvs = ts*(1.0+p608*qv(kts))

  do k=1,max(1,k50-1) !use "-1" because k50 used interface heights (zw).

    if (k == 1) then

      if ((thv(k)-tvs)/(0.5*dz(k)) < hux) then

        superadiabatic = .true.

      else

        superadiabatic = .false.

        exit

      endif

    else

      if ((thv(k)-thv(k-1))/(0.5*(dz(k)+dz(k-1))) < hux) then

        superadiabatic = .true.

      else

        superadiabatic = .false.

        exit

      endif

    endif

  enddo


  ! Determine the numer of updrafts/plumes in the grid column:

  ! Some of these criteria may be a little redundant but useful for bullet-proofing.

  !   (1) largest plume = 1.2 * dx.

  !   (2) Apply a scale-break, assuming no plumes with diameter larger than 1.1*PBLH can exist.

  !   (3) max plume size beneath clouds deck approx = 0.5 * cloud_base.

  !   (4) add wspd-dependent limit, when plume model breaks down. (hurricanes)

  !   (5) limit to reduce max plume sizes in weakly forced conditions. This is only

  !       meant to "soften" the activation of the mass-flux scheme.

  ! Criteria (1)

    maxwidth = min(dx*dcut, lmax)

  !Criteria (2)

    maxwidth = min(maxwidth, 1.1_kind_phys*pblh)

  ! Criteria (3)

    if ((landsea-1.5) .lt. 0) then  !land

       maxwidth = min(maxwidth, 0.5_kind_phys*cloud_base)

    else                            !water

       maxwidth = min(maxwidth, 0.9_kind_phys*cloud_base)

    endif

  ! Criteria (4)

    wspd_pbl=sqrt(max(u(kts)**2 + v(kts)**2, 0.01_kind_phys))

    !Note: area fraction (acfac) is modified below

  ! Criteria (5) - only a function of flt (not fltv)

    if ((landsea-1.5).LT.0) then  !land

      width_flx = max(min(1000.*(0.6*tanh((fltv - 0.040)/0.04) + .5),1000._kind_phys), 0._kind_phys)

    else                          !water

      width_flx = max(min(1000.*(0.6*tanh((fltv - 0.007)/0.02) + .5),1000._kind_phys), 0._kind_phys)

    endif

    maxwidth = min(maxwidth, width_flx)

    minwidth = lmin

    !allow min plume size to increase in large flux conditions (eddy diffusivity should be

    !large enough to handle the representation of small plumes).

    if (maxwidth .ge. (lmax - 1.0) .and. fltv .gt. 0.2)minwidth = lmin + dlmin*min((fltv-0.2)/0.3, 1._kind_phys)


    if (maxwidth .le. minwidth) then ! deactivate MF component

       nup2 = 0

       maxwidth = 0.0

    endif


  ! Initialize values for 2d output fields:

    ktop = 0

    ztop = 0.0

    maxmf= 0.0


!Begin plume processing if passes criteria

if ( fltv2 > 0.002 .AND. (maxwidth > minwidth) .AND. superadiabatic) then


    ! Find coef C for number size density N

    cn = 0.

    d  =-1.9  !set d to value suggested by Neggers 2015 (JAMES).

    dl = (maxwidth - minwidth)/real(nup-1,kind=kind_phys)

    do i=1,nup

       ! diameter of plume

       l = minwidth + dl*real(i-1)

       cn = cn + l**d * (l*l)/(dx*dx) * dl  ! sum fractional area of each plume

    enddo

    c = atot/cn   !Normalize C according to the defined total fraction (Atot)


    ! Make updraft area (UPA) a function of the buoyancy flux

    if ((landsea-1.5).LT.0) then  !land

       acfac = .5*tanh((fltv2 - 0.02)/0.05) + .5

    else                          !water

       acfac = .5*tanh((fltv2 - 0.01)/0.03) + .5

    endif

    !add a windspeed-dependent adjustment to acfac that tapers off

    !the mass-flux scheme linearly above sfc wind speeds of 10 m/s.

    !Note: this effect may be better represented by an increase in

    !entrainment rate for high wind consitions (more ambient turbulence).

    if (wspd_pbl .le. 10.) then

       ac_wsp = 1.0

    else

       ac_wsp = 1.0 - min((wspd_pbl - 10.0)/15., 1.0)

    endif

    acfac  = acfac * ac_wsp


    ! Find the portion of the total fraction (Atot) of each plume size:

    an2 = 0.

    do i=1,nup

       ! diameter of plume

       l  = minwidth + dl*real(i-1)

       n  = c*l**d                          ! number density of plume n

       upa(1,i) = n*l*l/(dx*dx) * dl        ! fractional area of plume n


       upa(1,i) = upa(1,i)*acfac

       an2 = an2 + upa(1,i)                 ! total fractional area of all plumes

       !print*," plume size=",l,"; area=",UPA(1,I),"; total=",An2

    end do


    ! set initial conditions for updrafts

    z0=50.

    pwmin=0.1       ! was 0.5

    pwmax=0.4       ! was 3.0


    wstar=max(1.e-2,(gtr*fltv2*pblh)**(onethird))

    qstar=max(flq,1.0e-5)/wstar

    thstar=flt/wstar


    if ((landsea-1.5) .ge. 0) then

       csigma = 1.34   ! WATER

    else

       csigma = 1.34   ! LAND

    endif


    if (env_subs) then

       exc_fac = 0.0

    else

       if ((landsea-1.5).GE.0) then

         !water: increase factor to compensate for decreased pwmin/pwmax

         exc_fac = 0.58*4.0

       else

         !land: no need to increase factor - already sufficiently large superadiabatic layers

         exc_fac = 0.58

       endif

    endif

    !decrease excess for large wind speeds

    exc_fac = exc_fac * ac_wsp


    !Note: sigmaW is typically about 0.5*wstar

    sigmaw =csigma*wstar*(z0/pblh)**(onethird)*(1 - 0.8*z0/pblh)

    sigmaqt=csigma*qstar*(z0/pblh)**(onethird)

    sigmath=csigma*thstar*(z0/pblh)**(onethird)


    !Note: Given the pwmin & pwmax set above, these max/mins are

    !      rarely exceeded.

    wmin=min(sigmaw*pwmin,0.1)

    wmax=min(sigmaw*pwmax,0.5)


    !SPECIFY SURFACE UPDRAFT PROPERTIES AT MODEL INTERFACE BETWEEN K = 1 & 2

    do i=1,nup

       wlv=wmin+(wmax-wmin)/nup2*(i-1)


       !SURFACE UPDRAFT VERTICAL VELOCITY

       upw(1,i)=wmin + real(i)/real(nup)*(wmax-wmin)

       upu(1,i)=(u(kts)*dz(kts+1)+u(kts+1)*dz(kts))/(dz(kts)+dz(kts+1))

       upv(1,i)=(v(kts)*dz(kts+1)+v(kts+1)*dz(kts))/(dz(kts)+dz(kts+1))

       upqc(1,i)=0.0

       !UPQC(1,I)=(QC(KTS)*DZ(KTS+1)+QC(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))


       exc_heat = exc_fac*upw(1,i)*sigmath/sigmaw

       upthv(1,i)=(thv(kts)*dz(kts+1)+thv(kts+1)*dz(kts))/(dz(kts)+dz(kts+1)) &

           &     + exc_heat

       upthl(1,i)=(thl(kts)*dz(kts+1)+thl(kts+1)*dz(kts))/(dz(kts)+dz(kts+1)) &

           &     + exc_heat


       !calculate exc_moist by use of surface fluxes

       exc_moist=exc_fac*upw(1,i)*sigmaqt/sigmaw

       upqt(1,i)=(qt(kts)*dz(kts+1)+qt(kts+1)*dz(kts))/(dz(kts)+dz(kts+1))&

            &     +exc_moist


       upqke(1,i)=(qke(kts)*dz(kts+1)+qke(kts+1)*dz(kts))/(dz(kts)+dz(kts+1))

       upqnc(1,i)=(qnc(kts)*dz(kts+1)+qnc(kts+1)*dz(kts))/(dz(kts)+dz(kts+1))

       upqni(1,i)=(qni(kts)*dz(kts+1)+qni(kts+1)*dz(kts))/(dz(kts)+dz(kts+1))

       upqnwfa(1,i)=(qnwfa(kts)*dz(kts+1)+qnwfa(kts+1)*dz(kts))/(dz(kts)+dz(kts+1))

       upqnifa(1,i)=(qnifa(kts)*dz(kts+1)+qnifa(kts+1)*dz(kts))/(dz(kts)+dz(kts+1))

       upqnbca(1,i)=(qnbca(kts)*dz(kts+1)+qnbca(kts+1)*dz(kts))/(dz(kts)+dz(kts+1))

    enddo


    if ( mix_chem ) then

      do i=1,nup

        do ic = 1,nchem

          upchem(1,i,ic)=(chem1(kts,ic)*dz(kts+1)+chem1(kts+1,ic)*dz(kts))/(dz(kts)+dz(kts+1))

        enddo

      enddo

    endif


    !Initialize environmental variables which can be modified by detrainment

    envm_thl(kts:kte)=thl(kts:kte)

    envm_sqv(kts:kte)=qv(kts:kte)

    envm_sqc(kts:kte)=qc(kts:kte)

    envm_u(kts:kte)=u(kts:kte)

    envm_v(kts:kte)=v(kts:kte)

    do k=kts,kte-1

       rhoz(k)  = (rho(k)*dz(k+1)+rho(k+1)*dz(k))/(dz(k+1)+dz(k))

    enddo

    rhoz(kte) = rho(kte)


    !dxsa is scale-adaptive factor governing the pressure-gradient term of the momentum transport

    dxsa = 1. - min(max((12000.0-dx)/(12000.0-3000.0), 0.), 1.)


    ! do integration  updraft

    do i=1,nup

       qcn = 0.

       overshoot = 0

       l  = minwidth + dl*real(i-1)            ! diameter of plume

       do k=kts+1,kte-1

          !Entrainment from Tian and Kuang (2016)

          !ENT(k,i) = 0.35/(MIN(MAX(UPW(K-1,I),0.75),1.9)*l)

          wmin = 0.3 + l*0.0005 !* MAX(pblh-ZW(k+1), 0.0)/pblh

          ent(k,i) = 0.33/(min(max(upw(k-1,i),wmin),0.9)*l)


          !Entrainment from Negggers (2015, JAMES)

          !ENT(k,i) = 0.02*l**-0.35 - 0.0009

          !ENT(k,i) = 0.04*l**-0.50 - 0.0009   !more plume diversity

          !ENT(k,i) = 0.04*l**-0.495 - 0.0009  !"neg1+"


          !Minimum background entrainment

          ent(k,i) = max(ent(k,i),0.0003)

          !ENT(k,i) = max(ENT(k,i),0.05/ZW(k))  !not needed for Tian and Kuang


          !increase entrainment for plumes extending very high.

          IF(zw(k) >= min(pblh+1500., 4000.))THEN

            ent(k,i)=ent(k,i) + (zw(k)-min(pblh+1500.,4000.))*5.0e-6

          ENDIF


          !SPP

          ent(k,i) = ent(k,i) * (1.0 - rstoch_col(k))


          ent(k,i) = min(ent(k,i),0.9/(zw(k+1)-zw(k)))


          ! Define environment U & V at the model interface levels

          uk  =(u(k)*dz(k+1)+u(k+1)*dz(k))/(dz(k+1)+dz(k))

          ukm1=(u(k-1)*dz(k)+u(k)*dz(k-1))/(dz(k-1)+dz(k))

          vk  =(v(k)*dz(k+1)+v(k+1)*dz(k))/(dz(k+1)+dz(k))

          vkm1=(v(k-1)*dz(k)+v(k)*dz(k-1))/(dz(k-1)+dz(k))


          ! Linear entrainment:

          entexp= ent(k,i)*(zw(k+1)-zw(k))

          entexm= entexp*0.3333    !reduce entrainment for momentum

          qtn =upqt(k-1,i) *(1.-entexp) + qt(k)*entexp

          thln=upthl(k-1,i)*(1.-entexp) + thl(k)*entexp

          un  =upu(k-1,i)  *(1.-entexm) + u(k)*entexm + dxsa*pgfac*(uk - ukm1)

          vn  =upv(k-1,i)  *(1.-entexm) + v(k)*entexm + dxsa*pgfac*(vk - vkm1)

          qken=upqke(k-1,i)*(1.-entexp) + qke(k)*entexp

          qncn=upqnc(k-1,i)*(1.-entexp) + qnc(k)*entexp

          qnin=upqni(k-1,i)*(1.-entexp) + qni(k)*entexp

          qnwfan=upqnwfa(k-1,i)*(1.-entexp) + qnwfa(k)*entexp

          qnifan=upqnifa(k-1,i)*(1.-entexp) + qnifa(k)*entexp

          qnbcan=upqnbca(k-1,i)*(1.-entexp) + qnbca(k)*entexp


          !capture the updated qc, qt & thl modified by entranment alone,

          !since they will be modified later if condensation occurs.

          qc_ent  = qcn

          qt_ent  = qtn

          thl_ent = thln


          ! Exponential Entrainment:

          !EntExp= exp(-ENT(K,I)*(ZW(k)-ZW(k-1)))

          !QTn =QT(K) *(1-EntExp)+UPQT(K-1,I)*EntExp

          !THLn=THL(K)*(1-EntExp)+UPTHL(K-1,I)*EntExp

          !Un  =U(K)  *(1-EntExp)+UPU(K-1,I)*EntExp

          !Vn  =V(K)  *(1-EntExp)+UPV(K-1,I)*EntExp

          !QKEn=QKE(k)*(1-EntExp)+UPQKE(K-1,I)*EntExp


          if ( mix_chem ) then

            do ic = 1,nchem

              ! Exponential Entrainment:

              !chemn(ic) = chem(k,ic)*(1-EntExp)+UPCHEM(K-1,I,ic)*EntExp

              ! Linear entrainment:

              chemn(ic)=upchem(k-1,i,ic)*(1.-entexp) + chem1(k,ic)*entexp

            enddo

          endif


          ! Define pressure at model interface

          pk    =(p(k)*dz(k+1)+p(k+1)*dz(k))/(dz(k+1)+dz(k))

          ! Compute plume properties thvn and qcn

          call condensation_edmf(qtn,thln,pk,zw(k+1),thvn,qcn)


          ! Define environment THV at the model interface levels

          thvk  =(thv(k)*dz(k+1)+thv(k+1)*dz(k))/(dz(k+1)+dz(k))

          thvkm1=(thv(k-1)*dz(k)+thv(k)*dz(k-1))/(dz(k-1)+dz(k))


!          B=g*(0.5*(THVn+UPTHV(k-1,I))/THV(k-1) - 1.0)

          b=grav*(thvn/thvk - 1.0)

          IF(b>0.)THEN

            bcoeff = 0.15        !w typically stays < 2.5, so doesnt hit the limits nearly as much

          ELSE

            bcoeff = 0.2 !0.33

          ENDIF


          ! Original StEM with exponential entrainment

          !EntW=exp(-2.*(Wb+Wc*ENT(K,I))*(ZW(k)-ZW(k-1)))

          !Wn2=UPW(K-1,I)**2*EntW + (1.-EntW)*0.5*Wa*B/(Wb+Wc*ENT(K,I))

          ! Original StEM with linear entrainment

          !Wn2=UPW(K-1,I)**2*(1.-EntExp) + EntExp*0.5*Wa*B/(Wb+Wc*ENT(K,I))

          !Wn2=MAX(Wn2,0.0)

          !WA: TEMF form

!          IF (B>0.0 .AND. UPW(K-1,I) < 0.2 ) THEN

          IF (upw(k-1,i) < 0.2 ) THEN

             wn = upw(k-1,i) + (-2. * ent(k,i) * upw(k-1,i) + bcoeff*b / max(upw(k-1,i),0.2)) * min(zw(k)-zw(k-1), 250.)

          ELSE

             wn = upw(k-1,i) + (-2. * ent(k,i) * upw(k-1,i) + bcoeff*b / upw(k-1,i)) * min(zw(k)-zw(k-1), 250.)

          ENDIF

          !Do not allow a parcel to accelerate more than 1.25 m/s over 200 m.

          !Add max increase of 2.0 m/s for coarse vertical resolution.

          IF(wn > upw(k-1,i) + min(1.25*(zw(k)-zw(k-1))/200., 2.0) ) THEN

             wn = upw(k-1,i) + min(1.25*(zw(k)-zw(k-1))/200., 2.0)

          ENDIF

          !Add symmetrical max decrease in w

          IF(wn < upw(k-1,i) - min(1.25*(zw(k)-zw(k-1))/200., 2.0) ) THEN

             wn = upw(k-1,i) - min(1.25*(zw(k)-zw(k-1))/200., 2.0)

          ENDIF

          wn = min(max(wn,0.0), 3.0)


          !Check to make sure that the plume made it up at least one level.

          !if it failed, then set nup2=0 and exit the mass-flux portion.

          IF (k==kts+1 .AND. wn == 0.) THEN

             nup2=0

             exit

          ENDIF


          IF (debug_mf == 1) THEN

            IF (wn .GE. 3.0) THEN

              ! surface values

              print *," **** SUSPICIOUSLY LARGE W:"

              print *,' QCn:',qcn,' ENT=',ent(k,i),' Nup2=',nup2

              print *,'pblh:',pblh,' Wn:',wn,' UPW(k-1)=',upw(k-1,i)

              print *,'K=',k,' B=',b,' dz=',zw(k)-zw(k-1)

            ENDIF

          ENDIF


          !Allow strongly forced plumes to overshoot if KE is sufficient

          IF (wn <= 0.0 .AND. overshoot == 0) THEN

             overshoot = 1

             IF ( thvk-thvkm1 .GT. 0.0 ) THEN

                bvf = sqrt( gtr*(thvk-thvkm1)/dz(k) )

                !vertical Froude number

                frz = upw(k-1,i)/(bvf*dz(k))

                !IF ( Frz >= 0.5 ) Wn =  MIN(Frz,1.0)*UPW(K-1,I)

                dzp = dz(k)*max(min(frz,1.0),0.0) ! portion of highest layer the plume penetrates

             ENDIF

          ELSE

             dzp = dz(k)

          ENDIF


          !minimize the plume penetratration in stratocu-topped PBL

          !IF (fltv2 < 0.06) THEN

          !   IF(ZW(k+1) >= pblh-200. .AND. qc(k) > 1e-5 .AND. I > 4) Wn=0.

          !ENDIF


          !Modify environment variables (representative of the model layer - envm*)

          !following the updraft dynamical detrainment of Asai and Kasahara (1967, JAS).

          !Reminder: w is limited to be non-negative (above)

          aratio   = min(upa(k-1,i)/(1.-upa(k-1,i)), 0.5) !limit should never get hit

          detturb  = 0.00008

          oow      = -0.060/max(1.0,(0.5*(wn+upw(k-1,i))))   !coef for dynamical detrainment rate

          detrate  = min(max(oow*(wn-upw(k-1,i))/dz(k), detturb), .0002) ! dynamical detrainment rate (m^-1)

          detrateuv= min(max(oow*(wn-upw(k-1,i))/dz(k), detturb), .0001) ! dynamical detrainment rate (m^-1)

          envm_thl(k)=envm_thl(k) + (0.5*(thl_ent + upthl(k-1,i)) - thl(k))*detrate*aratio*min(dzp,dzpmax)

          qv_ent = 0.5*(max(qt_ent-qc_ent,0.) + max(upqt(k-1,i)-upqc(k-1,i),0.))

          envm_sqv(k)=envm_sqv(k) + (qv_ent-qv(k))*detrate*aratio*min(dzp,dzpmax)

          IF (upqc(k-1,i) > 1e-8) THEN

             IF (qc(k) > 1e-6) THEN

                qc_grid = qc(k)

             ELSE

                qc_grid = cldfra_bl1d(k)*qc_bl1d(k)

             ENDIF

             envm_sqc(k)=envm_sqc(k) + max(upa(k-1,i)*0.5*(qcn + upqc(k-1,i)) - qc_grid, 0.0)*detrate*aratio*min(dzp,dzpmax)

          ENDIF

          envm_u(k)  =envm_u(k)   + (0.5*(un + upu(k-1,i)) - u(k))*detrateuv*aratio*min(dzp,dzpmax)

          envm_v(k)  =envm_v(k)   + (0.5*(vn + upv(k-1,i)) - v(k))*detrateuv*aratio*min(dzp,dzpmax)


          IF (wn > 0.) THEN

             !Update plume variables at current k index

             upw(k,i)=wn  !sqrt(Wn2)

             upthv(k,i)=thvn

             upthl(k,i)=thln

             upqt(k,i)=qtn

             upqc(k,i)=qcn

             upu(k,i)=un

             upv(k,i)=vn

             upqke(k,i)=qken

             upqnc(k,i)=qncn

             upqni(k,i)=qnin

             upqnwfa(k,i)=qnwfan

             upqnifa(k,i)=qnifan

             upqnbca(k,i)=qnbcan

             upa(k,i)=upa(k-1,i)

             IF ( mix_chem ) THEN

               do ic = 1,nchem

                 upchem(k,i,ic) = chemn(ic)

               enddo

             ENDIF

             ktop = max(ktop,k)

          ELSE

             exit  !exit k-loop

          END IF

       ENDDO


       IF (debug_mf == 1) THEN

          IF (maxval(upw(:,i)) > 10.0 .OR. minval(upa(:,i)) < 0.0 .OR. &

              maxval(upa(:,i)) > atot .OR. nup2 > 10) THEN

             ! surface values

             print *,'flq:',flq,' fltv:',fltv2,' Nup2=',nup2

             print *,'pblh:',pblh,' wstar:',wstar,' ktop=',ktop

             print *,'sigmaW=',sigmaw,' sigmaTH=',sigmath,' sigmaQT=',sigmaqt

             ! means

             print *,'u:',u

             print *,'v:',v

             print *,'thl:',thl

             print *,'UPA:',upa(:,i)

             print *,'UPW:',upw(:,i)

             print *,'UPTHL:',upthl(:,i)

             print *,'UPQT:',upqt(:,i)

             print *,'ENT:',ent(:,i)

          ENDIF

       ENDIF

    ENDDO

ELSE

    !At least one of the conditions was not met for activating the MF scheme.

    nup2=0.

END IF !end criteria check for mass-flux scheme


ktop=min(ktop,kte-1)

IF (ktop == 0) THEN

   ztop = 0.0

ELSE

   ztop=zw(ktop)

ENDIF


IF (nup2 > 0) THEN

   !Calculate the fluxes for each variable

   !All s_aw* variable are == 0 at k=1

   DO i=1,nup

      DO k=kts,kte-1

        s_aw(k+1)   = s_aw(k+1)    + rhoz(k)*upa(k,i)*upw(k,i)*psig_w

        s_awthl(k+1)= s_awthl(k+1) + rhoz(k)*upa(k,i)*upw(k,i)*upthl(k,i)*psig_w

        s_awqt(k+1) = s_awqt(k+1)  + rhoz(k)*upa(k,i)*upw(k,i)*upqt(k,i)*psig_w

        !to conform to grid mean properties, move qc to qv in grid mean

        !saturated layers, so total water fluxes are preserved but

        !negative qc fluxes in unsaturated layers is reduced.

!        if (qc(k) > 1e-12 .or. qc(k+1) > 1e-12) then

          qc_plume = upqc(k,i)

!        else

!          qc_plume = 0.0

!        endif

        s_awqc(k+1) = s_awqc(k+1)  + rhoz(k)*upa(k,i)*upw(k,i)*qc_plume*psig_w

        s_awqv(k+1) = s_awqt(k+1)  - s_awqc(k+1)

      ENDDO

   ENDDO

   !momentum

   if (momentum_opt > 0) then

      do i=1,nup

         do k=kts,kte-1

            s_awu(k+1)  = s_awu(k+1)   + rhoz(k)*upa(k,i)*upw(k,i)*upu(k,i)*psig_w

            s_awv(k+1)  = s_awv(k+1)   + rhoz(k)*upa(k,i)*upw(k,i)*upv(k,i)*psig_w

         enddo

      enddo

   endif

   !tke

   if (tke_opt > 0) then

      do i=1,nup

         do k=kts,kte-1

            s_awqke(k+1)= s_awqke(k+1) + rhoz(k)*upa(k,i)*upw(k,i)*upqke(k,i)*psig_w

         enddo

      enddo

   endif

   !chem

   if ( mix_chem ) then

      do k=kts,kte

         do i=1,nup

            do ic = 1,nchem

              s_awchem(k+1,ic) = s_awchem(k+1,ic) + rhoz(k)*upa(k,i)*upw(k,i)*upchem(k,i,ic)*psig_w

            enddo

         enddo

      enddo

   endif


   if (scalar_opt > 0) then

      do k=kts,kte

         do i=1,nup

            s_awqnc(k+1)  = s_awqnc(k+1)   + rhoz(k)*upa(k,i)*upw(k,i)*upqnc(k,i)*psig_w

            s_awqni(k+1)  = s_awqni(k+1)   + rhoz(k)*upa(k,i)*upw(k,i)*upqni(k,i)*psig_w

            s_awqnwfa(k+1)= s_awqnwfa(k+1) + rhoz(k)*upa(k,i)*upw(k,i)*upqnwfa(k,i)*psig_w

            s_awqnifa(k+1)= s_awqnifa(k+1) + rhoz(k)*upa(k,i)*upw(k,i)*upqnifa(k,i)*psig_w

            s_awqnbca(k+1)= s_awqnbca(k+1) + rhoz(k)*upa(k,i)*upw(k,i)*upqnbca(k,i)*psig_w

         enddo

      enddo

   endif


   !Flux limiter: Check ratio of heat flux at top of first model layer

   !and at the surface. Make sure estimated flux out of the top of the

   !layer is < fluxportion*surface_heat_flux

   IF (s_aw(kts+1) /= 0.) THEN

       dzi(kts) = 0.5*(dz(kts)+dz(kts+1)) !dz centered at model interface

       flx1   = max(s_aw(kts+1)*(th(kts)-th(kts+1))/dzi(kts),1.0e-5)

   ELSE

       flx1 = 0.0

       !print*,"ERROR: s_aw(kts+1) == 0, NUP=",NUP," NUP2=",NUP2,&

       !       " superadiabatic=",superadiabatic," KTOP=",KTOP

   ENDIF

   adjustment=1.0

   !Print*,"Flux limiter in MYNN-EDMF, adjustment=",fluxportion*flt/dz(kts)/flx1

   !Print*,"flt/dz=",flt/dz(kts)," flx1=",flx1," s_aw(kts+1)=",s_aw(kts+1)

   IF (flx1 > fluxportion*flt/dz(kts) .AND. flx1>0.0) THEN

       adjustment= fluxportion*flt/dz(kts)/flx1

       s_aw      = s_aw*adjustment

       s_awthl   = s_awthl*adjustment

       s_awqt    = s_awqt*adjustment

       s_awqc    = s_awqc*adjustment

       s_awqv    = s_awqv*adjustment

       s_awqnc   = s_awqnc*adjustment

       s_awqni   = s_awqni*adjustment

       s_awqnwfa = s_awqnwfa*adjustment

       s_awqnifa = s_awqnifa*adjustment

       s_awqnbca = s_awqnbca*adjustment

       IF (momentum_opt > 0) THEN

          s_awu  = s_awu*adjustment

          s_awv  = s_awv*adjustment

       ENDIF

       IF (tke_opt > 0) THEN

          s_awqke= s_awqke*adjustment

       ENDIF

       IF ( mix_chem ) THEN

          s_awchem = s_awchem*adjustment

       ENDIF

       upa = upa*adjustment

   ENDIF

   !Print*,"adjustment=",adjustment," fluxportion=",fluxportion," flt=",flt


   !Calculate mean updraft properties for output:

   !all edmf_* variables at k=1 correspond to the interface at top of first model layer

   do k=kts,kte-1

      do i=1,nup

         edmf_a(k)  =edmf_a(k)  +upa(k,i)

         edmf_w(k)  =edmf_w(k)  +rhoz(k)*upa(k,i)*upw(k,i)

         edmf_qt(k) =edmf_qt(k) +rhoz(k)*upa(k,i)*upqt(k,i)

         edmf_thl(k)=edmf_thl(k)+rhoz(k)*upa(k,i)*upthl(k,i)

         edmf_ent(k)=edmf_ent(k)+rhoz(k)*upa(k,i)*ent(k,i)

         edmf_qc(k) =edmf_qc(k) +rhoz(k)*upa(k,i)*upqc(k,i)

      enddo

   enddo

   do k=kts,kte-1

      !Note that only edmf_a is multiplied by Psig_w. This takes care of the

      !scale-awareness of the subsidence below:

      if (edmf_a(k)>0.) then

         edmf_w(k)=edmf_w(k)/edmf_a(k)

         edmf_qt(k)=edmf_qt(k)/edmf_a(k)

         edmf_thl(k)=edmf_thl(k)/edmf_a(k)

         edmf_ent(k)=edmf_ent(k)/edmf_a(k)

         edmf_qc(k)=edmf_qc(k)/edmf_a(k)

         edmf_a(k)=edmf_a(k)*psig_w

         !FIND MAXIMUM MASS-FLUX IN THE COLUMN:

         if(edmf_a(k)*edmf_w(k) > maxmf) maxmf = edmf_a(k)*edmf_w(k)

      endif

   enddo ! end k


   !smoke/chem

   if ( mix_chem ) then

      do k=kts,kte-1

        do i=1,nup

          do ic = 1,nchem

            edmf_chem(k,ic) = edmf_chem(k,ic) + rhoz(k)*upa(k,i)*upchem(k,i,ic)

          enddo

        enddo

      enddo

      do k=kts,kte-1

        if (edmf_a(k)>0.) then

          do ic = 1,nchem

            edmf_chem(k,ic) = edmf_chem(k,ic)/edmf_a(k)

          enddo

        endif

      enddo ! end k

   endif


   !Calculate the effects environmental subsidence.

   !All envi_*variables are valid at the interfaces, like the edmf_* variables

   IF (env_subs) THEN

       DO k=kts+1,kte-1

          !First, smooth the profiles of w & a, since sharp vertical gradients

          !in plume variables are not likely extended to env variables

          !Note1: w is treated as negative further below

          !Note2: both w & a will be transformed into env variables further below

          envi_w(k) = onethird*(edmf_w(k-1)+edmf_w(k)+edmf_w(k+1))

          envi_a(k) = onethird*(edmf_a(k-1)+edmf_a(k)+edmf_a(k+1))*adjustment

       ENDDO

       !define env variables at k=1 (top of first model layer)

       envi_w(kts) = edmf_w(kts)

       envi_a(kts) = edmf_a(kts)

       !define env variables at k=kte

       envi_w(kte) = 0.0

       envi_a(kte) = edmf_a(kte)

       !define env variables at k=kte+1

       envi_w(kte+1) = 0.0

       envi_a(kte+1) = edmf_a(kte)

       !Add limiter for very long time steps (i.e. dt > 300 s)

       !Note that this is not a robust check - only for violations in

       !   the first model level.

       IF (envi_w(kts) > 0.9*dz(kts)/dt) THEN

          sublim = 0.9*dz(kts)/dt/envi_w(kts)

       ELSE

          sublim = 1.0

       ENDIF

       !Transform w & a into env variables

       DO k=kts,kte

          temp=envi_a(k)

          envi_a(k)=1.0-temp

          envi_w(k)=csub*sublim*envi_w(k)*temp/(1.-temp)

       ENDDO

       !calculate tendencies from subsidence and detrainment valid at the middle of

       !each model layer. The lowest model layer uses an assumes w=0 at the surface.

       dzi(kts)    = 0.5*(dz(kts)+dz(kts+1))

       sub_thl(kts)= 0.5*envi_w(kts)*envi_a(kts)*                               &

                     (rho(kts+1)*thl(kts+1)-rho(kts)*thl(kts))/dzi(kts)/rhoz(k)

       sub_sqv(kts)= 0.5*envi_w(kts)*envi_a(kts)*                               &

                     (rho(kts+1)*qv(kts+1)-rho(kts)*qv(kts))/dzi(kts)/rhoz(k)

       DO k=kts+1,kte-1

          dzi(k)    = 0.5*(dz(k)+dz(k+1))

          sub_thl(k)= 0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * &

                      (rho(k+1)*thl(k+1)-rho(k)*thl(k))/dzi(k)/rhoz(k)

          sub_sqv(k)= 0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * &

                      (rho(k+1)*qv(k+1)-rho(k)*qv(k))/dzi(k)/rhoz(k)

       ENDDO


       DO k=kts,kte-1

          det_thl(k)=cdet*(envm_thl(k)-thl(k))*envi_a(k)*psig_w

          det_sqv(k)=cdet*(envm_sqv(k)-qv(k))*envi_a(k)*psig_w

          det_sqc(k)=cdet*(envm_sqc(k)-qc(k))*envi_a(k)*psig_w

       ENDDO


       IF (momentum_opt > 0) THEN

         sub_u(kts)=0.5*envi_w(kts)*envi_a(kts)*                               &

                    (rho(kts+1)*u(kts+1)-rho(kts)*u(kts))/dzi(kts)/rhoz(k)

         sub_v(kts)=0.5*envi_w(kts)*envi_a(kts)*                               &

                    (rho(kts+1)*v(kts+1)-rho(kts)*v(kts))/dzi(kts)/rhoz(k)

         DO k=kts+1,kte-1

            sub_u(k)=0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * &

                      (rho(k+1)*u(k+1)-rho(k)*u(k))/dzi(k)/rhoz(k)

            sub_v(k)=0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * &

                      (rho(k+1)*v(k+1)-rho(k)*v(k))/dzi(k)/rhoz(k)

         ENDDO


         DO k=kts,kte-1

           det_u(k) = cdet*(envm_u(k)-u(k))*envi_a(k)*psig_w

           det_v(k) = cdet*(envm_v(k)-v(k))*envi_a(k)*psig_w

         ENDDO

       ENDIF

   ENDIF !end subsidence/env detranment


   !First, compute exner, plume theta, and dz centered at interface

   !Here, k=1 is the top of the first model layer. These values do not

   !need to be defined at k=kte (unused level).

   DO k=kts,kte-1

       exneri(k) = (exner(k)*dz(k+1)+exner(k+1)*dz(k))/(dz(k+1)+dz(k))

       edmf_th(k)= edmf_thl(k) + xlvcp/exneri(k)*edmf_qc(k)

       dzi(k)    = 0.5*(dz(k)+dz(k+1))

   ENDDO


!JOE: ADD CLDFRA_bl1d, qc_bl1d. Note that they have already been defined in

!     mym_condensation. Here, a shallow-cu component is added, but no cumulus

!     clouds can be added at k=1 (start loop at k=2).

   do k=kts+1,kte-2

      if (k > ktop) exit

         if(0.5*(edmf_qc(k)+edmf_qc(k-1))>0.0 .and. (cldfra_bl1d(k) < cf_thresh))THEN

            !interpolate plume quantities to mass levels

            aup = (edmf_a(k)*dzi(k-1)+edmf_a(k-1)*dzi(k))/(dzi(k-1)+dzi(k))

            thp = (edmf_th(k)*dzi(k-1)+edmf_th(k-1)*dzi(k))/(dzi(k-1)+dzi(k))

            qtp = (edmf_qt(k)*dzi(k-1)+edmf_qt(k-1)*dzi(k))/(dzi(k-1)+dzi(k))

            !convert TH to T

!            t = THp*exner(k)

            !SATURATED VAPOR PRESSURE

            esat = esat_blend(tk(k))

            !SATURATED SPECIFIC HUMIDITY

            qsl=ep_2*esat/max(1.e-7,(p(k)-ep_3*esat))


            !condensed liquid in the plume on mass levels

            if (edmf_qc(k)>0.0 .and. edmf_qc(k-1)>0.0) then

              qcp = (edmf_qc(k)*dzi(k-1)+edmf_qc(k-1)*dzi(k))/(dzi(k-1)+dzi(k))

            else

              qcp = max(edmf_qc(k),edmf_qc(k-1))

            endif


            !COMPUTE CLDFRA & QC_BL FROM MASS-FLUX SCHEME and recompute vt & vq

            xl = xl_blend(tk(k))                ! obtain blended heat capacity

            qsat_tk = qsat_blend(tk(k),p(k))    ! get saturation water vapor mixing ratio

                                                !   at t and p

            rsl = xl*qsat_tk / (r_v*tk(k)**2)   ! slope of C-C curve at t (abs temp)

                                                ! CB02, Eqn. 4

            cpm = cp + qt(k)*cpv                ! CB02, sec. 2, para. 1

            a   = 1./(1. + xl*rsl/cpm)          ! CB02 variable "a"

            b9  = a*rsl                         ! CB02 variable "b"


            q2p  = xlvcp/exner(k)

            pt = thl(k) +q2p*qcp*aup ! potential temp (env + plume)

            bb = b9*tk(k)/pt ! bb is "b9" in BCMT95.  Their "b9" differs from

                           ! "b9" in CB02 by a factor

                           ! of T/theta.  Strictly, b9 above is formulated in

                           ! terms of sat. mixing ratio, but bb in BCMT95 is

                           ! cast in terms of sat. specific humidity.  The

                           ! conversion is neglected here.

            qww   = 1.+0.61*qt(k)

            alpha = 0.61*pt

            beta  = pt*xl/(tk(k)*cp) - 1.61*pt

            !Buoyancy flux terms have been moved to the end of this section...


            !Now calculate convective component of the cloud fraction:

            if (a > 0.0) then

               f = min(1.0/a, 4.0)              ! f is vertical profile scaling function (CB2005)

            else

               f = 1.0

            endif


            !CB form:

            !sigq = 3.5E-3 * Aup * 0.5*(edmf_w(k)+edmf_w(k-1)) * f  ! convective component of sigma (CB2005)

            !sigq = SQRT(sigq**2 + sgm(k)**2)    ! combined conv + stratus components

            !Per S.DeRoode 2009?

            !sigq = 5. * Aup * (QTp - qt(k))

            sigq = 10. * aup * (qtp - qt(k))

            !constrain sigq wrt saturation:

            sigq = max(sigq, qsat_tk*0.02 )

            sigq = min(sigq, qsat_tk*0.25 )


            qmq = a * (qt(k) - qsat_tk)           ! saturation deficit/excess;

            q1  = qmq/sigq                        !   the numerator of Q1


            if ((landsea-1.5).GE.0) then      ! WATER

               !modified form from LES

               !mf_cf = min(max(0.5 + 0.36 * atan(1.20*(Q1+0.2)),0.01),0.6)

               !Original CB

               mf_cf = min(max(0.5 + 0.36 * atan(1.55*q1),0.01),0.6)

               mf_cf = max(mf_cf, 1.2 * aup)

               mf_cf = min(mf_cf, 5.0 * aup)

            else                              ! LAND

               !LES form

               !mf_cf = min(max(0.5 + 0.36 * atan(1.20*(Q1+0.4)),0.01),0.6)

               !Original CB

               mf_cf = min(max(0.5 + 0.36 * atan(1.55*q1),0.01),0.6)

               mf_cf = max(mf_cf, 1.8 * aup)

               mf_cf = min(mf_cf, 5.0 * aup)

            endif


            !IF ( debug_code ) THEN

            !   print*,"In MYNN, StEM edmf"

            !   print*,"  CB: env qt=",qt(k)," qsat=",qsat_tk

            !   print*,"  k=",k," satdef=",QTp - qsat_tk," sgm=",sgm(k)

            !   print*,"  CB: sigq=",sigq," qmq=",qmq," tk=",tk(k)

            !   print*,"  CB: mf_cf=",mf_cf," cldfra_bl=",cldfra_bl1d(k)," edmf_a=",edmf_a(k)

            !ENDIF


            ! Update cloud fractions and specific humidities in grid cells

            ! where the mass-flux scheme is active. The specific humidities

            ! are converted to grid means (not in-cloud quantities).

            if ((landsea-1.5).GE.0) then     ! water

               if (qcp * aup > 5e-5) then

                  qc_bl1d(k) = 1.86 * (qcp * aup) - 2.2e-5

               else

                  qc_bl1d(k) = 1.18 * (qcp * aup)

               endif

               cldfra_bl1d(k) = mf_cf

               ac_mf          = mf_cf

            else                             ! land

               if (qcp * aup > 5e-5) then

                  qc_bl1d(k) = 1.86 * (qcp * aup) - 2.2e-5

               else

                  qc_bl1d(k) = 1.18 * (qcp * aup)

               endif

               cldfra_bl1d(k) = mf_cf

               ac_mf          = mf_cf

            endif


            !Now recalculate the terms for the buoyancy flux for mass-flux clouds:

            !See mym_condensation for details on these formulations.

            !Use Bechtold and Siebesma (1998) piecewise estimation of Fng with

            !limits ,since they really should be recalculated after all the other changes...:

            !Only overwrite vt & vq in non-stratus condition

            !if ((landsea-1.5).GE.0) then      ! WATER

               q1=max(q1,-2.25)

            !else

            !   Q1=max(Q1,-2.0)

            !endif


            if (q1 .ge. 1.0) then

               fng = 1.0

            elseif (q1 .ge. -1.7 .and. q1 .lt. 1.0) then

               fng = exp(-0.4*(q1-1.0))

            elseif (q1 .ge. -2.5 .and. q1 .lt. -1.7) then

               fng = 3.0 + exp(-3.8*(q1+1.7))

            else

               fng = min(23.9 + exp(-1.6*(q1+2.5)), 60.)

            endif


            !link the buoyancy flux function to active clouds only (c*Aup):

            vt(k) = qww   - (1.5*aup)*beta*bb*fng - 1.

            vq(k) = alpha + (1.5*aup)*beta*a*fng  - tv0

         endif !check for (qc in plume) .and. (cldfra_bl < threshold)

      enddo !k-loop


ENDIF  !end nup2 > 0


!modify output (negative: dry plume, positive: moist plume)

if (ktop > 0) then

   maxqc = maxval(edmf_qc(1:ktop))

   if ( maxqc < 1.e-8) maxmf = -1.0*maxmf

endif


!

! debugging

!

if (edmf_w(1) > 4.0) then

! surface values

    print *,'flq:',flq,' fltv:',fltv2

    print *,'pblh:',pblh,' wstar:',wstar

    print *,'sigmaW=',sigmaw,' sigmaTH=',sigmath,' sigmaQT=',sigmaqt

! means

!   print *,'u:',u

!   print *,'v:',v

!   print *,'thl:',thl

!   print *,'thv:',thv

!   print *,'qt:',qt

!   print *,'p:',p


! updrafts

! DO I=1,NUP2

!   print *,'up:A',i

!   print *,UPA(:,i)

!   print *,'up:W',i

!   print*,UPW(:,i)

!   print *,'up:thv',i

!   print *,UPTHV(:,i)

!   print *,'up:thl',i

!   print *,UPTHL(:,i)

!   print *,'up:qt',i

!   print *,UPQT(:,i)

!   print *,'up:tQC',i

!   print *,UPQC(:,i)

!   print *,'up:ent',i

!   print *,ENT(:,i)

! ENDDO


! mean updrafts

   print *,' edmf_a',edmf_a(1:14)

   print *,' edmf_w',edmf_w(1:14)

   print *,' edmf_qt:',edmf_qt(1:14)

   print *,' edmf_thl:',edmf_thl(1:14)


ENDIF !END Debugging


#ifdef HARDCODE_VERTICAL

# undef kts

# undef kte

#endif


END SUBROUTINE dmp_mf

!=================================================================


subroutine condensation_edmf(QT,THL,P,zagl,THV,QC)

!

! zero or one condensation for edmf: calculates THV and QC

!

real(kind_phys),intent(in)   :: QT,THL,P,zagl

real(kind_phys),intent(out)  :: THV

real(kind_phys),intent(inout):: QC


integer :: niter,i

real(kind_phys):: diff,exn,t,th,qs,qcold


! constants used from module_model_constants.F

! p1000mb

! rcp ... Rd/cp

! xlv ... latent heat for water (2.5e6)

! cp

! rvord .. r_v/r_d  (1.6)


! number of iterations

  niter=50

! minimum difference (usually converges in < 8 iterations with diff = 2e-5)

  diff=1.e-6


  exn=(p/p1000mb)**rcp

  !QC=0.  !better first guess QC is incoming from lower level, do not set to zero

  do i=1,niter

     t=exn*thl + xlvcp*qc

     qs=qsat_blend(t,p)

     qcold=qc

     qc=0.5*qc + 0.5*max((qt-qs),0.)

     if (abs(qc-qcold)<diff) exit

  enddo


  t=exn*thl + xlvcp*qc

  qs=qsat_blend(t,p)

  qc=max(qt-qs,0.)


  !Do not allow saturation below 100 m

  if(zagl < 100.)qc=0.


  !THV=(THL+xlv/cp*QC).*(1+(1-rvovrd)*(QT-QC)-QC);

  thv=(thl+xlvcp*qc)*(1.+qt*(rvovrd-1.)-rvovrd*qc)


!  IF (QC > 0.0) THEN

!    PRINT*,"EDMF SAT, p:",p," iterations:",i

!    PRINT*," T=",T," THL=",THL," THV=",THV

!    PRINT*," QS=",QS," QT=",QT," QC=",QC,"ratio=",qc/qs

!  ENDIF


  !THIS BASICALLY GIVE THE SAME RESULT AS THE PREVIOUS LINE

  !TH = THL + xlv/cp/EXN*QC

  !THV= TH*(1. + p608*QT)


  !print *,'t,p,qt,qs,qc'

  !print *,t,p,qt,qs,qc


end subroutine condensation_edmf


!===============================================================


subroutine condensation_edmf_r(QT,THL,P,zagl,THV,QC)

!

! zero or one condensation for edmf: calculates THL and QC

! similar to condensation_edmf but with different inputs

!

real(kind_phys),intent(in)   :: QT,THV,P,zagl

real(kind_phys),intent(out)  :: THL, QC


integer :: niter,i

real(kind_phys):: diff,exn,t,th,qs,qcold


! number of iterations

  niter=50

! minimum difference

  diff=2.e-5


  exn=(p/p1000mb)**rcp

  ! assume first that th = thv

  t = thv*exn

  !QS = qsat_blend(T,P)

  !QC = QS - QT


  qc=0.


  do i=1,niter

     qcold = qc

     t = exn*thv/(1.+qt*(rvovrd-1.)-rvovrd*qc)

     qs=qsat_blend(t,p)

     qc= max((qt-qs),0.)

     if (abs(qc-qcold)<diff) exit

  enddo

  thl = (t - xlv/cp*qc)/exn


end subroutine condensation_edmf_r


!===============================================================

! ===================================================================

! This is the downdraft mass flux scheme - analogus to edmf_JPL but

! flipped updraft to downdraft. This scheme is currently only tested

! for Stratocumulus cloud conditions. For a detailed desctiption of the

! model, see paper.


SUBROUTINE ddmf_jpl(kts,kte,dt,zw,dz,p,              &

              &u,v,th,thl,thv,tk,qt,qv,qc,           &

              &rho,exner,                            &

              &ust,wthl,wqt,pblh,kpbl,               &

              &edmf_a_dd,edmf_w_dd, edmf_qt_dd,      &

              &edmf_thl_dd,edmf_ent_dd,edmf_qc_dd,   &

              &sd_aw,sd_awthl,sd_awqt,               &

              &sd_awqv,sd_awqc,sd_awu,sd_awv,        &

              &sd_awqke,                             &

              &qc_bl1d,cldfra_bl1d,                  &

              &rthraten                              )


        integer, intent(in) :: KTS,KTE,KPBL

        real(kind_phys), dimension(kts:kte), intent(in) ::            &

            U,V,TH,THL,TK,QT,QV,QC,THV,P,rho,exner,dz

        real(kind_phys), dimension(kts:kte), intent(in) :: rthraten

        ! zw .. heights of the downdraft levels (edges of boxes)

        real(kind_phys), dimension(kts:kte+1), intent(in) :: ZW

        real(kind_phys), intent(in)  :: WTHL,WQT

        real(kind_phys), intent(in)  :: dt,ust,pblh

  ! outputs - downdraft properties

        real(kind_phys), dimension(kts:kte), intent(out) ::           &

            edmf_a_dd,edmf_w_dd,                                      &

            edmf_qt_dd,edmf_thl_dd, edmf_ent_dd,edmf_qc_dd


  ! outputs - variables needed for solver (sd_aw - sum ai*wi, sd_awphi - sum ai*wi*phii)

        real(kind_phys), dimension(kts:kte+1) ::                      &

            sd_aw, sd_awthl, sd_awqt, sd_awu,                         &

            sd_awv, sd_awqc, sd_awqv, sd_awqke, sd_aw2


        real(kind_phys), dimension(kts:kte), intent(in) ::            &

            qc_bl1d, cldfra_bl1d


        integer, parameter:: ndown = 5

  ! draw downdraft starting height randomly between cloud base and cloud top

        integer,         dimension(1:NDOWN) :: DD_initK

        real(kind_phys), dimension(1:NDOWN) :: randNum

  ! downdraft properties

        real(kind_phys), dimension(kts:kte+1,1:NDOWN) ::              &

            DOWNW,DOWNTHL,DOWNQT,DOWNQC,DOWNA,DOWNU,DOWNV,DOWNTHV


  ! entrainment variables

        real(kind_phys), dimension(KTS+1:KTE+1,1:NDOWN) :: ENT,ENTf

        integer,         dimension(KTS+1:KTE+1,1:NDOWN) :: ENTi


  ! internal variables

        integer :: K,I,ki, kminrad, qlTop, p700_ind, qlBase

        real(kind_phys):: wthv,wstar,qstar,thstar,sigmaW,sigmaQT,     &

            sigmaTH,z0,pwmin,pwmax,wmin,wmax,wlv,wtv,went,mindownw

        real(kind_phys):: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,Wn2,Wn,      &

            THVk,Pk,EntEXP,EntW,beta_dm,EntExp_M,rho_int

        real(kind_phys):: jump_thetav, jump_qt, jump_thetal,          &

                refTHL, refTHV, refQT

  ! DD specific internal variables

        real(kind_phys):: minrad,zminrad, radflux, F0, wst_rad, wst_dd

        logical :: cloudflg

        real(kind_phys):: sigq,xl,rsl,cpm,a,mf_cf,diffqt,             &

               Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9,satvp,rhgrid


  ! w parameters

        real(kind_phys),parameter ::                                  &

            &Wa=1., Wb=1.5, Z00=100., BCOEFF=0.2

  ! entrainment parameters

        real(kind_phys),parameter ::                                  &

            &L0=80, ENT0=0.2

   !downdraft properties

        real(kind_phys)::                                             &

            & dp,                    &   !diameter of plume

            & dl,                    &   !diameter increment

            & Adn                        !total area of downdrafts

   !additional printouts for debugging

        integer, parameter :: debug_mf=0


   dl = (1000.-500.)/real(ndown)

   pwmin=-3. ! drawing from the negative tail -3sigma to -1sigma

   pwmax=-1.


  ! initialize downdraft properties

   downw=0.

   downthl=0.

   downthv=0.

   downqt=0.

   downa=0.

   downu=0.

   downv=0.

   downqc=0.

   ent=0.

   dd_initk=0


   edmf_a_dd  =0.

   edmf_w_dd  =0.

   edmf_qt_dd =0.

   edmf_thl_dd=0.

   edmf_ent_dd=0.

   edmf_qc_dd =0.


   sd_aw=0.

   sd_awthl=0.

   sd_awqt=0.

   sd_awqv=0.

   sd_awqc=0.

   sd_awu=0.

   sd_awv=0.

   sd_awqke=0.


  ! FIRST, CHECK FOR STRATOCUMULUS-TOPPED BOUNDARY LAYERS

   cloudflg=.false.

   minrad=100.

   kminrad=kpbl

   zminrad=pblh

   qltop = 1 !initialize at 0

   qlbase = 1

   wthv=wthl+svp1*wqt

   do k = max(3,kpbl-2),kpbl+3

      if (qc(k).gt. 1.e-6 .AND. cldfra_bl1d(k).gt.0.5) then

          cloudflg=.true. ! found Sc cloud

          qltop = k       ! index for Sc cloud top

      endif

   enddo


   do k = qltop, kts, -1

      if (qc(k) .gt. 1e-6) then

         qlbase = k ! index for Sc cloud base

      endif

   enddo

   qlbase = (qltop+qlbase)/2 ! changed base to half way through the cloud


!   call init_random_seed_1()

!   call RANDOM_NUMBER(randNum)

   do i=1,ndown

      ! downdraft starts somewhere between cloud base to cloud top

      ! the probability is equally distributed

      dd_initk(i) = qltop ! nint(randNum(i)*real(qlTop-qlBase)) + qlBase

   enddo


   ! LOOP RADFLUX

   f0 = 0.

   do k = 1, qltop ! Snippet from YSU, YSU loops until qlTop - 1

      radflux = rthraten(k) * exner(k) ! Converts theta/s to temperature/s

      radflux = radflux * cp / grav * ( p(k) - p(k+1) ) ! Converts K/s to W/m^2

      if ( radflux < 0.0 ) f0 = abs(radflux) + f0

   enddo

   f0 = max(f0, 1.0)


   !Allow the total fractional area of the downdrafts to be proportional

   !to the radiative forcing:

   !for  50 W/m2, Adn = 0.10

   !for 100 W/m2, Adn = 0.15

   !for 150 W/m2, Adn = 0.20

   adn = min( 0.05 + f0*0.001, 0.3)


   !found Sc cloud and cloud not at surface, trigger downdraft

   if (cloudflg) then


!      !get entrainent coefficient

!      do i=1,NDOWN

!         do k=kts+1,kte

!            ENTf(k,i)=(ZW(k+1)-ZW(k))/L0

!         enddo

!      enddo

!

!      ! get Poisson P(dz/L0)

!      call Poisson(1,NDOWN,kts+1,kte,ENTf,ENTi)


!      ! entrainent: Ent=Ent0/dz*P(dz/L0)

!      do i=1,NDOWN

!         do k=kts+1,kte

!!            ENT(k,i)=real(ENTi(k,i))*Ent0/(ZW(k+1)-ZW(k))

!            ENT(k,i) = 0.002

!            ENT(k,i) = min(ENT(k,i),0.9/(ZW(k+1)-ZW(k)))

!         enddo

!      enddo


      !!![EW: INVJUMP] find 700mb height then subtract trpospheric lapse rate!!!

      p700_ind = minloc(abs(p-70000),1)!p1D is 70000

      jump_thetav = thv(p700_ind) - thv(1) - (thv(p700_ind)-thv(qltop+3))/(zw(p700_ind)-zw(qltop+3))*(zw(p700_ind)-zw(qltop))

      jump_qt = qc(p700_ind) + qv(p700_ind) - qc(1) - qv(1)

      jump_thetal = thl(p700_ind) - thl(1) - (thl(p700_ind)-thl(qltop+3))/(zw(p700_ind)-zw(qltop+3))*(zw(p700_ind)-zw(qltop))


      refthl = thl(qltop) !sum(thl(1:qlTop)) / (qlTop) ! avg over BL for now or just at qlTop

      refthv = thv(qltop) !sum(thv(1:qlTop)) / (qlTop)

      refqt  = qt(qltop)  !sum(qt(1:qlTop))  / (qlTop)


      ! wstar_rad, following Lock and MacVean (1999a)

      wst_rad = ( grav * zw(qltop) * f0 / (refthl * rho(qltop) * cp) ) ** (0.333)

      wst_rad = max(wst_rad, 0.1)

      wstar   = max(0.,(grav/thv(1)*wthv*pblh)**(onethird))

      went    = thv(1) / ( grav * jump_thetav * zw(qltop) ) * &

                (0.15 * (wstar**3 + 5*ust**3) + 0.35 * wst_rad**3 )

      qstar  = abs(went*jump_qt/wst_rad)

      thstar = f0/rho(qltop)/cp/wst_rad - went*jump_thetav/wst_rad

      !wstar_dd = mixrad + surface wst

      wst_dd = (0.15 * (wstar**3 + 5*ust**3) + 0.35 * wst_rad**3 ) ** (0.333)


      print*,"qstar=",qstar," thstar=",thstar," wst_dd=",wst_dd

      print*,"F0=",f0," wst_rad=",wst_rad," jump_thv=",jump_thetav

      print*,"entrainment velocity=",went


      sigmaw  = 0.2*wst_dd  ! 0.8*wst_dd !wst_rad tuning parameter ! 0.5 was good

      sigmaqt = 40  * qstar ! 50 was good

      sigmath = 1.0 * thstar! 0.5 was good


      wmin=sigmaw*pwmin

      wmax=sigmaw*pwmax

      !print*,"sigw=",sigmaW," wmin=",wmin," wmax=",wmax


      do i=1,ndown !downdraft now starts at different height

         ki = dd_initk(i)


         wlv=wmin+(wmax-wmin)/real(ndown)*(i-1)

         wtv=wmin+(wmax-wmin)/real(ndown)*i


         !DOWNW(ki,I)=0.5*(wlv+wtv)

         downw(ki,i)=wlv

         !multiply downa by cloud fraction, so it's impact will diminish if

         !clouds are mixed away over the course of the longer radiation time step

         !DOWNA(ki,I)=0.5*ERF(wtv/(sqrt(2.)*sigmaW))-0.5*ERF(wlv/(sqrt(2.)*sigmaW))

         downa(ki,i)=adn/real(ndown)

         downu(ki,i)=(u(ki-1)*dz(ki) + u(ki)*dz(ki-1)) /(dz(ki)+dz(ki-1))

         downv(ki,i)=(v(ki-1)*dz(ki) + v(ki)*dz(ki-1)) /(dz(ki)+dz(ki-1))


         !reference now depends on where dd starts

!         refTHL = 0.5 * (thl(ki) + thl(ki-1))

!         refTHV = 0.5 * (thv(ki) + thv(ki-1))

!         refQT  = 0.5 * (qt(ki)  + qt(ki-1) )


         refthl = (thl(ki-1)*dz(ki) + thl(ki)*dz(ki-1)) /(dz(ki)+dz(ki-1))

         refthv = (thv(ki-1)*dz(ki) + thv(ki)*dz(ki-1)) /(dz(ki)+dz(ki-1))

         refqt  = (qt(ki-1)*dz(ki)  + qt(ki)*dz(ki-1))  /(dz(ki)+dz(ki-1))


         !DOWNQC(ki,I) = 0.0

         downqc(ki,i) = (qc(ki-1)*dz(ki) + qc(ki)*dz(ki-1)) /(dz(ki)+dz(ki-1))

         downqt(ki,i) = refqt  !+ 0.5  *DOWNW(ki,I)*sigmaQT/sigmaW

         downthv(ki,i)= refthv + 0.01 *downw(ki,i)*sigmath/sigmaw

         downthl(ki,i)= refthl + 0.01 *downw(ki,i)*sigmath/sigmaw


         !input :: QT,THV,P,zagl,  output :: THL, QC

!         Pk  =(P(ki-1)*DZ(ki)+P(ki)*DZ(ki-1))/(DZ(ki)+DZ(ki-1))

!         call condensation_edmf_r(DOWNQT(ki,I),   &

!              &        DOWNTHL(ki,I),Pk,ZW(ki),   &

!              &     DOWNTHV(ki,I),DOWNQC(ki,I)    )


      enddo


      !print*, " Begin integration of downdrafts:"

      DO i=1,ndown

         dp = 500. + dl*real(i)  ! diameter of plume (meters)

         !print *, "Plume # =", I,"======================="

         DO k=dd_initk(i)-1,kts+1,-1


            !Entrainment from Tian and Kuang (2016), with constraints

            wmin = 0.3 + dp*0.0005

            ent(k,i) = 0.33/(min(max(-1.0*downw(k+1,i),wmin),0.9)*dp)


            !starting at the first interface level below cloud top

            !EntExp=exp(-ENT(K,I)*dz(k))

            !EntExp_M=exp(-ENT(K,I)/3.*dz(k))

            entexp  =ent(k,i)*dz(k)        !for all scalars

            entexp_m=ent(k,i)*0.333*dz(k)  !test for momentum


            qtn =downqt(k+1,i) *(1.-entexp) + qt(k)*entexp

            thln=downthl(k+1,i)*(1.-entexp) + thl(k)*entexp

            un  =downu(k+1,i)  *(1.-entexp) + u(k)*entexp_m

            vn  =downv(k+1,i)  *(1.-entexp) + v(k)*entexp_m

            !QKEn=DOWNQKE(k-1,I)*(1.-EntExp) + QKE(k)*EntExp


!            QTn =DOWNQT(K+1,I) +(QT(K) -DOWNQT(K+1,I)) *(1.-EntExp)

!            THLn=DOWNTHL(K+1,I)+(THL(K)-DOWNTHL(K+1,I))*(1.-EntExp)

!            Un  =DOWNU(K+1,I)  +(U(K)  -DOWNU(K+1,I))*(1.-EntExp_M)

!            Vn  =DOWNV(K+1,I)  +(V(K)  -DOWNV(K+1,I))*(1.-EntExp_M)


            ! given new p & z, solve for thvn & qcn

            pk  =(p(k-1)*dz(k)+p(k)*dz(k-1))/(dz(k)+dz(k-1))

            call condensation_edmf(qtn,thln,pk,zw(k),thvn,qcn)

!            B=grav*(0.5*(THVn+DOWNTHV(k+1,I))/THV(k)-1.)

            thvk  =(thv(k-1)*dz(k)+thv(k)*dz(k-1))/(dz(k)+dz(k-1))

            b=grav*(thvn/thvk - 1.0)

!            Beta_dm = 2*Wb*ENT(K,I) + 0.5/(ZW(k)-dz(k)) * &

!                 &    max(1. - exp((ZW(k) -dz(k))/Z00 - 1. ) , 0.)

!            EntW=exp(-Beta_dm * dz(k))

            entw=entexp

!            if (Beta_dm >0) then

!               Wn2=DOWNW(K+1,I)**2*EntW - Wa*B/Beta_dm * (1. - EntW)

!            else

!               Wn2=DOWNW(K+1,I)**2      - 2.*Wa*B*dz(k)

!            end if


            mindownw = min(downw(k+1,i),-0.2)

            wn = downw(k+1,i) + (-2.*ent(k,i)*downw(k+1,i) - &

                    bcoeff*b/mindownw)*min(dz(k), 250.)


            !Do not allow a parcel to accelerate more than 1.25 m/s over 200 m.

            !Add max acceleration of -2.0 m/s for coarse vertical resolution.

            IF (wn < downw(k+1,i) - min(1.25*dz(k)/200., -2.0))THEN

                wn = downw(k+1,i) - min(1.25*dz(k)/200., -2.0)

            ENDIF

            !Add symmetrical max decrease in velocity (less negative)

            IF (wn > downw(k+1,i) + min(1.25*dz(k)/200., 2.0))THEN

                wn = downw(k+1,i) + min(1.25*dz(k)/200., 2.0)

            ENDIF

            wn = max(min(wn,0.0), -3.0)


            !print *, "  k       =",      k,      " z    =", ZW(k)

            !print *, "  entw    =",ENT(K,I),     " Bouy =", B

            !print *, "  downthv =",   THVn,      " thvk =", thvk

            !print *, "  downthl =",   THLn,      " thl  =", thl(k)

            !print *, "  downqt  =",   QTn ,      " qt   =", qt(k)

            !print *, "  downw+1 =",DOWNW(K+1,I), " Wn2  =", Wn


            IF (wn .lt. 0.) THEN !terminate when velocity is too small

               downw(k,i)  = wn !-sqrt(Wn2)

               downthv(k,i)= thvn

               downthl(k,i)= thln

               downqt(k,i) = qtn

               downqc(k,i) = qcn

               downu(k,i)  = un

               downv(k,i)  = vn

               downa(k,i)  = downa(k+1,i)

            ELSE

               !plumes must go at least 2 levels

               if (dd_initk(i) - k .lt. 2) then

                  downw(:,i)  = 0.0

                  downthv(:,i)= 0.0

                  downthl(:,i)= 0.0

                  downqt(:,i) = 0.0

                  downqc(:,i) = 0.0

                  downu(:,i)  = 0.0

                  downv(:,i)  = 0.0

               endif

               exit

            ENDIF

         ENDDO

      ENDDO

   endif ! end cloud flag


   downw(1,:) = 0. !make sure downdraft does not go to the surface

   downa(1,:) = 0.


   ! Combine both moist and dry plume, write as one averaged plume

   ! Even though downdraft starts at different height, average all up to qlTop

   DO k=qltop,kts,-1

      DO i=1,ndown

         edmf_a_dd(k)  =edmf_a_dd(k)  +downa(k-1,i)

         edmf_w_dd(k)  =edmf_w_dd(k)  +downa(k-1,i)*downw(k-1,i)

         edmf_qt_dd(k) =edmf_qt_dd(k) +downa(k-1,i)*downqt(k-1,i)

         edmf_thl_dd(k)=edmf_thl_dd(k)+downa(k-1,i)*downthl(k-1,i)

         edmf_ent_dd(k)=edmf_ent_dd(k)+downa(k-1,i)*ent(k-1,i)

         edmf_qc_dd(k) =edmf_qc_dd(k) +downa(k-1,i)*downqc(k-1,i)

      ENDDO


      IF (edmf_a_dd(k) >0.) THEN

          edmf_w_dd(k)  =edmf_w_dd(k)  /edmf_a_dd(k)

          edmf_qt_dd(k) =edmf_qt_dd(k) /edmf_a_dd(k)

          edmf_thl_dd(k)=edmf_thl_dd(k)/edmf_a_dd(k)

          edmf_ent_dd(k)=edmf_ent_dd(k)/edmf_a_dd(k)

          edmf_qc_dd(k) =edmf_qc_dd(k) /edmf_a_dd(k)

      ENDIF

   ENDDO


   !

   ! computing variables needed for solver

   !


   DO k=kts,qltop

      rho_int = (rho(k)*dz(k+1)+rho(k+1)*dz(k))/(dz(k+1)+dz(k))

      DO i=1,ndown

         sd_aw(k)   =sd_aw(k)   +rho_int*downa(k,i)*downw(k,i)

         sd_awthl(k)=sd_awthl(k)+rho_int*downa(k,i)*downw(k,i)*downthl(k,i)

         sd_awqt(k) =sd_awqt(k) +rho_int*downa(k,i)*downw(k,i)*downqt(k,i)

         sd_awqc(k) =sd_awqc(k) +rho_int*downa(k,i)*downw(k,i)*downqc(k,i)

         sd_awu(k)  =sd_awu(k)  +rho_int*downa(k,i)*downw(k,i)*downu(k,i)

         sd_awv(k)  =sd_awv(k)  +rho_int*downa(k,i)*downw(k,i)*downv(k,i)

      ENDDO

      sd_awqv(k) = sd_awqt(k)  - sd_awqc(k)

   ENDDO


END SUBROUTINE ddmf_jpl

!===============================================================


SUBROUTINE scale_aware(dx,PBL1,Psig_bl,Psig_shcu)


    !---------------------------------------------------------------

    !             NOTES ON SCALE-AWARE FORMULATION

    !

    !JOE: add scale-aware factor (Psig) here, taken from Honnert et al. (2011,

    !     JAS) and/or from Hyeyum Hailey Shin and Song-You Hong (2013, JAS)

    !

    ! Psig_bl tapers local mixing

    ! Psig_shcu tapers nonlocal mixing


    real(kind_phys), intent(in)  :: dx,pbl1

    real(kind_phys), intent(out) :: Psig_bl,Psig_shcu

    real(kind_phys)              :: dxdh


    psig_bl=1.0

    psig_shcu=1.0

    dxdh=max(2.5*dx,10.)/min(pbl1,3000.)

    ! Honnert et al. 2011, TKE in PBL  *** original form used until 201605

    !Psig_bl= ((dxdh**2) + 0.07*(dxdh**0.667))/((dxdh**2) + &

    !         (3./21.)*(dxdh**0.67) + (3./42.))

    ! Honnert et al. 2011, TKE in entrainment layer

    !Psig_bl= ((dxdh**2) + (4./21.)*(dxdh**0.667))/((dxdh**2) + &

     !        (3./20.)*(dxdh**0.67) + (7./21.))

    ! New form to preseve parameterized mixing - only down 5% at dx = 750 m

     psig_bl= ((dxdh**2) + 0.106*(dxdh**0.667))/((dxdh**2) +0.066*(dxdh**0.667) + 0.071)


    !assume a 500 m cloud depth for shallow-cu clods

    dxdh=max(2.5*dx,10.)/min(pbl1+500.,3500.)

    ! Honnert et al. 2011, TKE in entrainment layer *** original form used until 201605

    !Psig_shcu= ((dxdh**2) + (4./21.)*(dxdh**0.667))/((dxdh**2) + &

    !         (3./20.)*(dxdh**0.67) + (7./21.))


    ! Honnert et al. 2011, TKE in cumulus

    !Psig(i)= ((dxdh**2) + 1.67*(dxdh**1.4))/((dxdh**2) +1.66*(dxdh**1.4) +

    !0.2)


    ! Honnert et al. 2011, w'q' in PBL

    !Psig(i)= 0.5 + 0.5*((dxdh**2) + 0.03*(dxdh**1.4) -

    !(4./13.))/((dxdh**2) + 0.03*(dxdh**1.4) + (4./13.))

    ! Honnert et al. 2011, w'q' in cumulus

    !Psig(i)= ((dxdh**2) - 0.07*(dxdh**1.4))/((dxdh**2) -0.07*(dxdh**1.4) +

    !0.02)


    ! Honnert et al. 2011, q'q' in PBL

    !Psig(i)= 0.5 + 0.5*((dxdh**2) + 0.25*(dxdh**0.667) -0.73)/((dxdh**2)

    !-0.03*(dxdh**0.667) + 0.73)

    ! Honnert et al. 2011, q'q' in cumulus

    !Psig(i)= ((dxdh**2) - 0.34*(dxdh**1.4))/((dxdh**2) - 0.35*(dxdh**1.4)

    !+ 0.37)


    ! Hyeyum Hailey Shin and Song-You Hong 2013, TKE in PBL (same as Honnert's above)

    !Psig_shcu= ((dxdh**2) + 0.070*(dxdh**0.667))/((dxdh**2)

    !+0.142*(dxdh**0.667) + 0.071)

    ! Hyeyum Hailey Shin and Song-You Hong 2013, TKE in entrainment zone  *** switch to this form 201605

    psig_shcu= ((dxdh**2) + 0.145*(dxdh**0.667))/((dxdh**2) +0.172*(dxdh**0.667) + 0.170)


    ! Hyeyum Hailey Shin and Song-You Hong 2013, w'theta' in PBL

    !Psig(i)= 0.5 + 0.5*((dxdh**2) -0.098)/((dxdh**2) + 0.106)

    ! Hyeyum Hailey Shin and Song-You Hong 2013, w'theta' in entrainment zone

    !Psig(i)= 0.5 + 0.5*((dxdh**2) - 0.112*(dxdh**0.25) -0.071)/((dxdh**2)

    !+ 0.054*(dxdh**0.25) + 0.10)


    !print*,"in scale_aware; dx, dxdh, Psig(i)=",dx,dxdh,Psig(i)

    !If(Psig_bl(i) < 0.0 .OR. Psig(i) > 1.)print*,"dx, dxdh, Psig(i)=",dx,dxdh,Psig_bl(i)

    If(psig_bl > 1.0) psig_bl=1.0

    If(psig_bl < 0.0) psig_bl=0.0


    If(psig_shcu > 1.0) psig_shcu=1.0

    If(psig_shcu < 0.0) psig_shcu=0.0


  END SUBROUTINE scale_aware


! =====================================================================


  FUNCTION esat_blend(t)


      IMPLICIT NONE


      real(kind_phys), intent(in):: t

      real(kind_phys):: esat_blend,xc,esl,esi,chi

      !liquid

      real(kind_phys), parameter:: j0= .611583699e03

      real(kind_phys), parameter:: j1= .444606896e02

      real(kind_phys), parameter:: j2= .143177157e01

      real(kind_phys), parameter:: j3= .264224321e-1

      real(kind_phys), parameter:: j4= .299291081e-3

      real(kind_phys), parameter:: j5= .203154182e-5

      real(kind_phys), parameter:: j6= .702620698e-8

      real(kind_phys), parameter:: j7= .379534310e-11

      real(kind_phys), parameter:: j8=-.321582393e-13

      !ice

      real(kind_phys), parameter:: k0= .609868993e03

      real(kind_phys), parameter:: k1= .499320233e02

      real(kind_phys), parameter:: k2= .184672631e01

      real(kind_phys), parameter:: k3= .402737184e-1

      real(kind_phys), parameter:: k4= .565392987e-3

      real(kind_phys), parameter:: k5= .521693933e-5

      real(kind_phys), parameter:: k6= .307839583e-7

      real(kind_phys), parameter:: k7= .105785160e-9

      real(kind_phys), parameter:: k8= .161444444e-12


      xc=max(-80.,t - t0c) !note t0c = 273.15, tice is set in module mynn_common to 240


! For 240 < t < 268.16 K, the vapor pressures are "blended" as a function of temperature,

! using the approach similar to Chaboureau and Bechtold (2002), JAS, p. 2363.  The resulting

! values are returned from the function.

      IF (t .GE. (t0c-6.)) THEN

          esat_blend = j0+xc*(j1+xc*(j2+xc*(j3+xc*(j4+xc*(j5+xc*(j6+xc*(j7+xc*j8)))))))

      ELSE IF (t .LE. tice) THEN

          esat_blend = k0+xc*(k1+xc*(k2+xc*(k3+xc*(k4+xc*(k5+xc*(k6+xc*(k7+xc*k8)))))))

      ELSE

          esl = j0+xc*(j1+xc*(j2+xc*(j3+xc*(j4+xc*(j5+xc*(j6+xc*(j7+xc*j8)))))))

          esi = k0+xc*(k1+xc*(k2+xc*(k3+xc*(k4+xc*(k5+xc*(k6+xc*(k7+xc*k8)))))))

          chi = ((t0c-6.) - t)/((t0c-6.) - tice)

          esat_blend = (1.-chi)*esl  + chi*esi

      END IF


  END FUNCTION esat_blend


! ====================================================================


  FUNCTION qsat_blend(t, P)


      IMPLICIT NONE


      real(kind_phys), intent(in):: t, p

      real(kind_phys):: qsat_blend,xc,esl,esi,rslf,rsif,chi

      !liquid

      real(kind_phys), parameter:: j0= .611583699e03

      real(kind_phys), parameter:: j1= .444606896e02

      real(kind_phys), parameter:: j2= .143177157e01

      real(kind_phys), parameter:: j3= .264224321e-1

      real(kind_phys), parameter:: j4= .299291081e-3

      real(kind_phys), parameter:: j5= .203154182e-5

      real(kind_phys), parameter:: j6= .702620698e-8

      real(kind_phys), parameter:: j7= .379534310e-11

      real(kind_phys), parameter:: j8=-.321582393e-13

      !ice

      real(kind_phys), parameter:: k0= .609868993e03

      real(kind_phys), parameter:: k1= .499320233e02

      real(kind_phys), parameter:: k2= .184672631e01

      real(kind_phys), parameter:: k3= .402737184e-1

      real(kind_phys), parameter:: k4= .565392987e-3

      real(kind_phys), parameter:: k5= .521693933e-5

      real(kind_phys), parameter:: k6= .307839583e-7

      real(kind_phys), parameter:: k7= .105785160e-9

      real(kind_phys), parameter:: k8= .161444444e-12


      xc=max(-80.,t - t0c)


      IF (t .GE. (t0c-6.)) THEN

          esl  = j0+xc*(j1+xc*(j2+xc*(j3+xc*(j4+xc*(j5+xc*(j6+xc*(j7+xc*j8)))))))

          esl  = min(esl, p*0.15) ! Even with P=1050mb and T=55C, the sat. vap. pres only contributes to ~15% of total pres.

          qsat_blend = 0.622*esl/max(p-esl, 1e-5)

      ELSE IF (t .LE. tice) THEN

          esi  = k0+xc*(k1+xc*(k2+xc*(k3+xc*(k4+xc*(k5+xc*(k6+xc*(k7+xc*k8)))))))

          esi  = min(esi, p*0.15)

          qsat_blend = 0.622*esi/max(p-esi, 1e-5)

      ELSE

          esl  = j0+xc*(j1+xc*(j2+xc*(j3+xc*(j4+xc*(j5+xc*(j6+xc*(j7+xc*j8)))))))

          esl  = min(esl, p*0.15)

          esi  = k0+xc*(k1+xc*(k2+xc*(k3+xc*(k4+xc*(k5+xc*(k6+xc*(k7+xc*k8)))))))

          esi  = min(esi, p*0.15)

          rslf = 0.622*esl/max(p-esl, 1e-5)

          rsif = 0.622*esi/max(p-esi, 1e-5)

!          chi  = (268.16-t)/(268.16-240.)

          chi  = ((t0c-6.) - t)/((t0c-6.) - tice)

         qsat_blend = (1.-chi)*rslf + chi*rsif

      END IF


  END FUNCTION qsat_blend


! ===================================================================


  FUNCTION xl_blend(t)


      IMPLICIT NONE


      real(kind_phys), intent(in):: t

      real(kind_phys):: xl_blend,xlvt,xlst,chi

      !note: t0c = 273.15, tice is set in mynn_common


      IF (t .GE. t0c) THEN

          xl_blend = xlv + (cpv-cliq)*(t-t0c)  !vaporization/condensation

      ELSE IF (t .LE. tice) THEN

          xl_blend = xls + (cpv-cice)*(t-t0c)  !sublimation/deposition

      ELSE

          xlvt = xlv + (cpv-cliq)*(t-t0c)  !vaporization/condensation

          xlst = xls + (cpv-cice)*(t-t0c)  !sublimation/deposition

!          chi  = (273.16-t)/(273.16-240.)

          chi  = (t0c - t)/(t0c - tice)

          xl_blend = (1.-chi)*xlvt + chi*xlst     !blended

      END IF


  END FUNCTION xl_blend


! ===================================================================


  FUNCTION phim(zet)

     ! New stability function parameters for momentum (Puhales, 2020, WRF 4.2.1)

     ! The forms in unstable conditions (z/L < 0) use Grachev et al. (2000), which are a blend of

     ! the classical (Kansas) forms (i.e., Paulson 1970, Dyer and Hicks 1970), valid for weakly

     ! unstable conditions (-1 < z/L < 0). The stability functions for stable conditions use an

     ! updated form taken from Cheng and Brutsaert (2005), which extends the validity into very

     ! stable conditions [z/L ~ O(10)].

      IMPLICIT NONE


      real(kind_phys), intent(in):: zet

      real(kind_phys):: dummy_0,dummy_1,dummy_11,dummy_2,dummy_22,dummy_3,dummy_33,dummy_4,dummy_44,dummy_psi

      real(kind_phys), parameter :: am_st=6.1, bm_st=2.5, rbm_st=1./bm_st

      real(kind_phys), parameter :: ah_st=5.3, bh_st=1.1, rbh_st=1./bh_st

      real(kind_phys), parameter :: am_unst=10., ah_unst=34.

      real(kind_phys):: phi_m,phim


      if ( zet >= 0.0 ) then

         dummy_0=1+zet**bm_st

         dummy_1=zet+dummy_0**(rbm_st)

         dummy_11=1+dummy_0**(rbm_st-1)*zet**(bm_st-1)

         dummy_2=(-am_st/dummy_1)*dummy_11

         phi_m = 1-zet*dummy_2

      else

         dummy_0 = (1.0-cphm_unst*zet)**0.25

         phi_m = 1./dummy_0

         dummy_psi = 2.*log(0.5*(1.+dummy_0))+log(0.5*(1.+dummy_0**2))-2.*atan(dummy_0)+1.570796


         dummy_0=(1.-am_unst*zet)          ! parentesis arg

         dummy_1=dummy_0**0.333333         ! y

         dummy_11=-0.33333*am_unst*dummy_0**(-0.6666667) ! dy/dzet

         dummy_2 = 0.33333*(dummy_1**2.+dummy_1+1.)    ! f

         dummy_22 = 0.3333*dummy_11*(2.*dummy_1+1.)    ! df/dzet

         dummy_3 = 0.57735*(2.*dummy_1+1.) ! g

         dummy_33 = 1.1547*dummy_11        ! dg/dzet

         dummy_4 = 1.5*log(dummy_2)-1.73205*atan(dummy_3)+1.813799364 !psic

         dummy_44 = (1.5/dummy_2)*dummy_22-1.73205*dummy_33/(1.+dummy_3**2)! dpsic/dzet


         dummy_0 = zet**2

         dummy_1 = 1./(1.+dummy_0) ! denon

         dummy_11 = 2.*zet         ! denon/dzet

         dummy_2 = ((1-phi_m)/zet+dummy_11*dummy_4+dummy_0*dummy_44)*dummy_1

         dummy_22 = -dummy_11*(dummy_psi+dummy_0*dummy_4)*dummy_1**2


         phi_m = 1.-zet*(dummy_2+dummy_22)

      end if


      !phim = phi_m - zet

      phim = phi_m


  END FUNCTION phim

! ===================================================================


  FUNCTION phih(zet)

    ! New stability function parameters for heat (Puhales, 2020, WRF 4.2.1)

    ! The forms in unstable conditions (z/L < 0) use Grachev et al. (2000), which are a blend of

    ! the classical (Kansas) forms (i.e., Paulson 1970, Dyer and Hicks 1970), valid for weakly

    ! unstable conditions (-1 < z/L < 0). The stability functions for stable conditions use an

    ! updated form taken from Cheng and Brutsaert (2005), which extends the validity into very

    ! stable conditions [z/L ~ O(10)].

      IMPLICIT NONE


      real(kind_phys), intent(in):: zet

      real(kind_phys):: dummy_0,dummy_1,dummy_11,dummy_2,dummy_22,dummy_3,dummy_33,dummy_4,dummy_44,dummy_psi

      real(kind_phys), parameter :: am_st=6.1, bm_st=2.5, rbm_st=1./bm_st

      real(kind_phys), parameter :: ah_st=5.3, bh_st=1.1, rbh_st=1./bh_st

      real(kind_phys), parameter :: am_unst=10., ah_unst=34.

      real(kind_phys):: phh,phih


      if ( zet >= 0.0 ) then

         dummy_0=1+zet**bh_st

         dummy_1=zet+dummy_0**(rbh_st)

         dummy_11=1+dummy_0**(rbh_st-1)*zet**(bh_st-1)

         dummy_2=(-ah_st/dummy_1)*dummy_11

         phih = 1-zet*dummy_2

      else

         dummy_0 = (1.0-cphh_unst*zet)**0.5

         phh = 1./dummy_0

         dummy_psi = 2.*log(0.5*(1.+dummy_0))


         dummy_0=(1.-ah_unst*zet)          ! parentesis arg

         dummy_1=dummy_0**0.333333         ! y

         dummy_11=-0.33333*ah_unst*dummy_0**(-0.6666667) ! dy/dzet

         dummy_2 = 0.33333*(dummy_1**2.+dummy_1+1.)    ! f

         dummy_22 = 0.3333*dummy_11*(2.*dummy_1+1.)    ! df/dzet

         dummy_3 = 0.57735*(2.*dummy_1+1.) ! g

         dummy_33 = 1.1547*dummy_11        ! dg/dzet

         dummy_4 = 1.5*log(dummy_2)-1.73205*atan(dummy_3)+1.813799364 !psic

         dummy_44 = (1.5/dummy_2)*dummy_22-1.73205*dummy_33/(1.+dummy_3**2)! dpsic/dzet


         dummy_0 = zet**2

         dummy_1 = 1./(1.+dummy_0)         ! denon

         dummy_11 = 2.*zet                 ! ddenon/dzet

         dummy_2 = ((1-phh)/zet+dummy_11*dummy_4+dummy_0*dummy_44)*dummy_1

         dummy_22 = -dummy_11*(dummy_psi+dummy_0*dummy_4)*dummy_1**2


         phih = 1.-zet*(dummy_2+dummy_22)

      end if


END FUNCTION phih

! ==================================================================


 SUBROUTINE topdown_cloudrad(kts,kte,dz1,zw,xland,kpbl,PBLH,  &

               &sqc,sqi,sqw,thl,th1,ex1,p1,rho1,thetav,       &

               &cldfra_bl1D,rthraten,                         &

               &maxKHtopdown,KHtopdown,TKEprodTD              )


    !input

    integer,         intent(in) :: kte,kts

    real(kind_phys), dimension(kts:kte), intent(in) :: dz1,sqc,sqi,sqw,&

          thl,th1,ex1,p1,rho1,thetav,cldfra_bl1D

    real(kind_phys), dimension(kts:kte), intent(in) :: rthraten

    real(kind_phys), dimension(kts:kte+1), intent(in) :: zw

    real(kind_phys), intent(in) :: pblh

    real(kind_phys), intent(in) :: xland

    integer        , intent(in) :: kpbl

    !output

    real(kind_phys), intent(out) :: maxKHtopdown

    real(kind_phys), dimension(kts:kte), intent(out) :: KHtopdown,TKEprodTD

    !local

    real(kind_phys), dimension(kts:kte) :: zfac,wscalek2,zfacent

    real(kind_phys) :: bfx0,sflux,wm2,wm3,h1,h2,bfxpbl,dthvx,tmp1

    real(kind_phys) :: temps,templ,zl1,wstar3_2

    real(kind_phys) :: ent_eff,radsum,radflux,we,rcldb,rvls,minrad,zminrad

    real(kind_phys), parameter :: pfac =2.0, zfmin = 0.01, phifac=8.0

    integer :: k,kk,kminrad

    logical :: cloudflg


    cloudflg=.false.

    minrad=100.

    kminrad=kpbl

    zminrad=pblh

    khtopdown(kts:kte)=0.0

    tkeprodtd(kts:kte)=0.0

    maxkhtopdown=0.0


    !CHECK FOR STRATOCUMULUS-TOPPED BOUNDARY LAYERS

    DO kk = max(1,kpbl-2),kpbl+3

       if (sqc(kk).gt. 1.e-6 .OR. sqi(kk).gt. 1.e-6 .OR. &

           cldfra_bl1d(kk).gt.0.5) then

          cloudflg=.true.

       endif

       if (rthraten(kk) < minrad)then

          minrad=rthraten(kk)

          kminrad=kk

          zminrad=zw(kk) + 0.5*dz1(kk)

       endif

    ENDDO


    IF (max(kminrad,kpbl) < 2)cloudflg = .false.

    IF (cloudflg) THEN

       zl1 = dz1(kts)

       k = max(kpbl-1, kminrad-1)

       !Best estimate of height of TKE source (top of downdrafts):

       !zminrad = 0.5*pblh(i) + 0.5*zminrad


       templ=thl(k)*ex1(k)

       !rvls is ws at full level

       rvls=100.*6.112*exp(17.67*(templ-273.16)/(templ-29.65))*(ep_2/p1(k+1))

       temps=templ + (sqw(k)-rvls)/(cp/xlv  +  ep_2*xlv*rvls/(r_d*templ**2))

       rvls=100.*6.112*exp(17.67*(temps-273.15)/(temps-29.65))*(ep_2/p1(k+1))

       rcldb=max(sqw(k)-rvls,0.)


       !entrainment efficiency

       dthvx     = (thl(k+2) + th1(k+2)*p608*sqw(k+2)) &

                 - (thl(k)   + th1(k)  *p608*sqw(k))

       dthvx     = max(dthvx,0.1)

       tmp1      = xlvcp * rcldb/(ex1(k)*dthvx)

       !Originally from Nichols and Turton (1986), where a2 = 60, but lowered

       !here to 8, as in Grenier and Bretherton (2001).

       ent_eff   = 0.2 + 0.2*8.*tmp1


       radsum=0.

       DO kk = max(1,kpbl-3),kpbl+3

          radflux=rthraten(kk)*ex1(kk)         !converts theta/s to temp/s

          radflux=radflux*cp/grav*(p1(kk)-p1(kk+1)) ! converts temp/s to W/m^2

          if (radflux < 0.0 ) radsum=abs(radflux)+radsum

       ENDDO


       !More strict limits over land to reduce stable-layer mixouts

       if ((xland-1.5).GE.0)THEN      ! WATER

          radsum=min(radsum,90.0)

          bfx0 = max(radsum/rho1(k)/cp,0.)

       else                           ! LAND

          radsum=min(0.25*radsum,30.0)!practically turn off over land

          bfx0 = max(radsum/rho1(k)/cp - max(sflux,0.0),0.)

       endif


       !entrainment from PBL top thermals

       wm3    = grav/thetav(k)*bfx0*min(pblh,1500.) ! this is wstar3(i)

       wm2    = wm2 + wm3**h2

       bfxpbl = - ent_eff * bfx0

       dthvx  = max(thetav(k+1)-thetav(k),0.1)

       we     = max(bfxpbl/dthvx,-sqrt(wm3**h2))


       DO kk = kts,kpbl+3

          !Analytic vertical profile

          zfac(kk) = min(max((1.-(zw(kk+1)-zl1)/(zminrad-zl1)),zfmin),1.)

          zfacent(kk) = 10.*max((zminrad-zw(kk+1))/zminrad,0.0)*(1.-zfac(kk))**3


          !Calculate an eddy diffusivity profile (not used at the moment)

          wscalek2(kk) = (phifac*karman*wm3*(zfac(kk)))**h1

          !Modify shape of Kh to be similar to Lock et al (2000): use pfac = 3.0

          khtopdown(kk) = wscalek2(kk)*karman*(zminrad-zw(kk+1))*(1.-zfac(kk))**3 !pfac

          khtopdown(kk) = max(khtopdown(kk),0.0)


          !Calculate TKE production = 2(g/TH)(w'TH'), where w'TH' = A(TH/g)wstar^3/PBLH,

          !A = ent_eff, and wstar is associated with the radiative cooling at top of PBL.

          !An analytic profile controls the magnitude of this TKE prod in the vertical.

          tkeprodtd(kk)=2.*ent_eff*wm3/max(pblh,100.)*zfacent(kk)

          tkeprodtd(kk)= max(tkeprodtd(kk),0.0)

       ENDDO

    ENDIF !end cloud check

    maxkhtopdown=maxval(khtopdown(:))


 END SUBROUTINE topdown_cloudrad

! ==================================================================

! ===================================================================

! ===================================================================


END MODULE module_bl_mynn

module_bl_mynn::mym_turbulence
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...
Definition module_bl_mynn.F90:2638

module_bl_mynn::get_pblh
subroutine get_pblh(kts, kte, zi, thetav1d, qke1d, zw1d, dz1d, landsea, kzi)
This subroutine calculates hybrid diagnotic boundary-layer height (PBLH).
Definition module_bl_mynn.F90:5520

module_bl_mynn::dmp_mf
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.
Definition module_bl_mynn.F90:5722

module_bl_mynn::mym_length
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.
Definition module_bl_mynn.F90:1862

module_bl_mynn::mym_level2
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...
Definition module_bl_mynn.F90:1724

module_bl_mynn::qsat_blend
real(kind_phys) function qsat_blend(t, p)
This function extends function "esat" and returns a "blended" saturation mixing ratio....
Definition module_bl_mynn.F90:7448

module_bl_mynn::tridiag2
subroutine tridiag2(n, a, b, c, d, x)
Definition module_bl_mynn.F90:5425

module_bl_mynn::tridiag
subroutine tridiag(n, a, b, c, d)
Definition module_bl_mynn.F90:5389

module_bl_mynn::mynn_bl_driver
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...
Definition module_bl_mynn.F90:415

module_bl_mynn::mym_condensation
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...
Definition module_bl_mynn.F90:3614

module_bl_mynn::boulac_length0
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...
Definition module_bl_mynn.F90:2260

module_bl_mynn::condensation_edmf
subroutine condensation_edmf(qt, thl, p, zagl, thv, qc)
This subroutine.
Definition module_bl_mynn.F90:6832

module_bl_mynn::mym_initialize
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 .
Definition module_bl_mynn.F90:1527

module_bl_mynn::xl_blend
real(kind_phys) function xl_blend(t)
This function interpolates the latent heats of vaporization and sublimation into a single,...
Definition module_bl_mynn.F90:7506

module_bl_mynn::boulac_length
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...
Definition module_bl_mynn.F90:2419

module_bl_mynn::mynn_tendencies
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.
Definition module_bl_mynn.F90:4061

module_bl_mynn::tridiag3
subroutine tridiag3(kte, a, b, c, d, x)
Definition module_bl_mynn.F90:5460

module_bl_mynn::esat_blend
real(kind_phys) function esat_blend(t)
Definition module_bl_mynn.F90:7397

module_bl_mynn::mym_predict
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.
Definition module_bl_mynn.F90:3207

module_bl_mynn::retrieve_exchange_coeffs
subroutine retrieve_exchange_coeffs(kts, kte, dfm, dfh, dz, k_m, k_h)
Definition module_bl_mynn.F90:5362

bl_mynn_common
This module defines model-specific constants/parameters.
Definition bl_mynn_common.f90:11

module_bl_mynn
This module contains the entity of MYNN-EDMF PBL scheme.
Definition module_bl_mynn.F90:252