LCOV - code coverage report
Current view: top level - atmos_phys/schemes/hack_shallow - hack_convect_shallow.F90 (source / functions) Hit Total Coverage
Test: coverage.info Lines: 386 452 85.4 %
Date: 2025-04-28 18:57:11 Functions: 3 3 100.0 %

          Line data    Source code
       1             : ! Hack shallow convective scheme.
       2             : ! The main subroutine was formerly named "cmfmca", and its initialization "mfinti".
       3             : !
       4             : ! Original Author: J. Hack
       5             : ! CCPPized: Haipeng Lin, October 2024
       6             : module hack_convect_shallow
       7             :   use ccpp_kinds,           only: kind_phys
       8             :   implicit none
       9             :   private
      10             :   save
      11             : 
      12             :   ! public CCPP-compliant subroutines
      13             :   public :: hack_convect_shallow_init
      14             :   public :: hack_convect_shallow_run
      15             : 
      16             :   ! namelist variables for tuning of hack shallow convective scheme
      17             :   real(kind_phys) :: cmftau                     ! characteristic adjustment time scale [s]
      18             :   real(kind_phys) :: c0                         ! rain water autoconversion coefficient [m-1]
      19             : 
      20             :   ! host-model physical constants and shorthands
      21             :   real(kind_phys) :: cp                         ! specific heat of dry air [J K-1 kg-1]
      22             :   real(kind_phys) :: rgas                       ! gas constant for dry air [J K-1 kg-1]
      23             :   real(kind_phys) :: grav                       ! gravitational constant [m s-2]
      24             :   real(kind_phys) :: hlat                       ! latent heat of vaporization [J kg-1]
      25             :   real(kind_phys) :: rhoh2o                     ! density of liquid water at STP [kg m-3]
      26             : 
      27             :   real(kind_phys) :: rcp                        ! reciprocal of cp
      28             :   real(kind_phys) :: rgrav                      ! reciprocal of grav
      29             :   real(kind_phys) :: rhlat                      ! reciprocal of hlat
      30             : 
      31             :   integer         :: limcnv                     ! top vertical interface level limit for convection [index]
      32             :                                                 ! derived from reference pressures to below 40 mb
      33             : 
      34             :   ! internal parameters
      35             :   real(kind_phys) :: betamn = 0.10_kind_phys    ! minimum overshoot parameter [???]
      36             :   real(kind_phys) :: dzmin  = 0.0_kind_phys     ! minimum convective depth for precipitation [m]
      37             :   logical         :: rlxclm = .true.            ! control for relaxing column versus cloud triplet (default: true)
      38             :                                                 ! true: relaxation timescale should be applied to column as opposed to triplets individually
      39             :   real(kind_phys) :: ssfac  = 1.001_kind_phys   ! detrained air supersaturation bound [???]
      40             : 
      41             :   ! internal parameters for tolerance
      42             :   real(kind_phys) :: tiny   = 1.0e-36_kind_phys ! arbitrary small num in scalar transport estimates
      43             :   real(kind_phys) :: eps    = 1.0e-13_kind_phys ! machine dependent convergence criteria
      44             :   real(kind_phys) :: tpmax  = 1.50_kind_phys    ! maximum acceptable T perturbation [K]
      45             :   real(kind_phys) :: shpmax = 1.50e-3_kind_phys ! maximum acceptable Q perturbation [g g-1]
      46             : 
      47             :   ! diagnostic only
      48             :   logical         :: debug_verbose = .false.    ! control for debug messages
      49             : 
      50             : 
      51             : contains
      52             :   ! Initialization of moist convective mass procedure including namelist read.
      53             : !> \section arg_table_hack_convect_shallow_init Argument Table
      54             : !! \htmlinclude hack_convect_shallow_init.html
      55        1024 :   subroutine hack_convect_shallow_init( &
      56             :     pver, &
      57             :     amIRoot, iulog, &
      58             :     cmftau_in, c0_in, &
      59             :     rair, cpair, gravit, latvap, rhoh2o_in, &
      60        1024 :     pref_edge, &
      61        1024 :     use_shfrc, shfrc, &
      62             :     top_lev, &
      63        1024 :     errmsg, errflg)
      64             : 
      65             :     integer,            intent(in)  :: pver         ! number of vertical levels
      66             :     logical,            intent(in)  :: amIRoot
      67             :     integer,            intent(in)  :: iulog        ! log output unit
      68             :     real(kind_phys),    intent(in)  :: cmftau_in    ! characteristic adjustment time scale [s]
      69             :     real(kind_phys),    intent(in)  :: c0_in        ! rain water autoconversion coefficient [m-1]
      70             :     real(kind_phys),    intent(in)  :: rair         ! gas constant for dry air [J K-1 kg-1]
      71             :     real(kind_phys),    intent(in)  :: cpair        ! specific heat of dry air [J K-1 kg-1]
      72             :     real(kind_phys),    intent(in)  :: gravit       ! gravitational constant [m s-2]
      73             :     real(kind_phys),    intent(in)  :: latvap       ! latent heat of vaporization [J kg-1]
      74             :     real(kind_phys),    intent(in)  :: rhoh2o_in    ! density of liquid water [kg m-3]
      75             :     real(kind_phys),    intent(in)  :: pref_edge(:) ! reference pressures at interface [Pa]
      76             : 
      77             :     logical,            intent(out) :: use_shfrc    ! this shallow scheme provides convective cloud fractions? [flag]
      78             :     real(kind_phys),    intent(out) :: shfrc(:,:)   ! (dummy) shallow convective cloud fractions calculated in-scheme [fraction]
      79             : 
      80             :     integer,            intent(out) :: top_lev      ! top level for cloud fraction [index]
      81             : 
      82             :     character(len=512), intent(out) :: errmsg
      83             :     integer,            intent(out) :: errflg
      84             : 
      85             :     ! local variables
      86             :     integer :: k
      87             : 
      88        1024 :     errmsg = ''
      89        1024 :     errflg = 0
      90             : 
      91             :     ! namelist variables
      92        1024 :     cmftau  = cmftau_in
      93        1024 :     c0      = c0_in
      94             : 
      95        1024 :     if(amIRoot) then
      96           2 :       write(iulog,*) 'tuning parameters hack_convect_shallow: cmftau',cmftau
      97           2 :       write(iulog,*) 'tuning parameters hack_convect_shallow: c0',c0
      98             :     endif
      99             : 
     100             :     ! host model physical constants
     101        1024 :     cp      = cpair
     102        1024 :     rcp     = 1.0_kind_phys/cp
     103        1024 :     hlat    = latvap
     104        1024 :     rhlat   = 1.0_kind_phys/hlat
     105        1024 :     grav    = gravit
     106        1024 :     rgrav   = 1.0_kind_phys/gravit
     107        1024 :     rgas    = rair
     108        1024 :     rhoh2o  = rhoh2o_in
     109             : 
     110             :     ! determine limit of shallow convection: regions below 40 mb
     111             :     ! logic ported from convect_shallow_init with note that this calculation is repeated in the deep
     112             :     ! convection interface.
     113        1024 :     if(pref_edge(1) >= 4.e3_kind_phys) then
     114           0 :       limcnv = 1
     115             :     else
     116        1024 :       limcnv = pver + 1
     117       27648 :       do k = 1, pver
     118       27648 :         if(pref_edge(k) < 4.e3_kind_phys .and. pref_edge(k+1) >= 4.e3_kind_phys) then
     119        1024 :           limcnv = k
     120             :         endif
     121             :       enddo
     122             :     endif
     123             : 
     124        1024 :     if(amIRoot) then
     125           2 :       write(iulog,*) "hack_convect_shallow_init: convection will be capped at interface ", limcnv, &
     126           4 :                      "which is ", pref_edge(limcnv), " pascals"
     127             :     endif
     128             : 
     129             :     ! flags for whether this shallow convection scheme
     130             :     ! calculates and provides convective cloud fractions
     131             :     ! to convective cloud cover scheme.
     132             :     !
     133             :     ! the Hack scheme does not provide this.
     134             :     ! a dummy shfrc is provided and is never used.
     135        1024 :     use_shfrc = .false.
     136      453632 :     shfrc(:,:) = 0._kind_phys
     137             : 
     138             :     ! for Hack shallow convection (CAM4 physics), do not limit cloud fraction
     139             :     ! (extend all the way to model top)
     140        1024 :     top_lev = 1
     141        1024 :   end subroutine hack_convect_shallow_init
     142             : 
     143             :   ! Moist convective mass flux procedure.
     144             :   !
     145             :   ! If stratification is unstable to nonentraining parcel ascent,
     146             :   ! complete an adjustment making successive use of a simple cloud model
     147             :   ! consisting of three layers (sometimes referred to as a triplet)
     148             :   !
     149             :   ! Code generalized to allow specification of parcel ("updraft")
     150             :   ! properties, as well as convective transport of an arbitrary
     151             :   ! number of passive constituents (see q array).  The code
     152             :   ! is written so the water vapor field is passed independently
     153             :   ! in the calling list from the block of other transported
     154             :   ! constituents, even though as currently designed, it is the
     155             :   ! first component in the constituents field.
     156             :   !
     157             :   ! Reports tendencies in cmfdt and dq instead of updating profiles.
     158             :   !
     159             :   ! Original author: J. Hack, BAB
     160             : !> \section arg_table_hack_convect_shallow_run Argument Table
     161             : !! \htmlinclude hack_convect_shallow_run.html
     162       70392 :   subroutine hack_convect_shallow_run( &
     163             :     ncol, pver, pcnst, &
     164             :     iulog, &
     165       70392 :     const_props, &
     166             :     ztodt, &
     167      140784 :     pmid, pmiddry, &
     168      140784 :     pdel, pdeldry, rpdel, rpdeldry, &
     169       70392 :     zm, &
     170       70392 :     qpert_in, &
     171       70392 :     phis, &
     172       70392 :     pblh, &
     173       70392 :     t, &
     174       70392 :     q, & ! ... below are output arguments:
     175       70392 :     dq, &
     176       70392 :     qc_sh, &
     177       70392 :     cmfdt, &
     178       70392 :     cmfmc_sh, &
     179       70392 :     cmfdqr, &
     180       70392 :     cmfsl, &
     181       70392 :     cmflq, &
     182       70392 :     precc, &
     183       70392 :     cnt_sh, &
     184       70392 :     cnb_sh, &
     185       70392 :     icwmr, &
     186       70392 :     rliq_sh, &
     187           0 :     scheme_name, &
     188       70392 :     flx_cnd, &
     189       70392 :     errmsg, errflg &
     190             :   )
     191             :     ! framework dependency for const_props
     192             :     use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t
     193             : 
     194             :     ! dependency to get constituent index
     195             :     use ccpp_const_utils,          only: ccpp_const_get_idx
     196             : 
     197             :     ! to_be_ccppized
     198             :     use wv_saturation,             only: qsat
     199             : 
     200             :     ! Input arguments
     201             :     integer,         intent(in)     :: ncol               ! number of atmospheric columns
     202             :     integer,         intent(in)     :: pver               ! number of vertical levels
     203             :     integer,         intent(in)     :: pcnst              ! number of ccpp constituents
     204             :     integer,         intent(in)     :: iulog              ! log output unit
     205             :     type(ccpp_constituent_prop_ptr_t), &
     206             :                      intent(in)     :: const_props(:)     ! ccpp constituent properties pointer
     207             :     real(kind_phys), intent(in)     :: ztodt              ! physics timestep [s]
     208             : 
     209             :     real(kind_phys), intent(in)     :: pmid(:,:)          ! midpoint pressures [Pa]
     210             :     real(kind_phys), intent(in)     :: pmiddry(:,:)       ! dry pressure at midpoints [Pa]
     211             :     real(kind_phys), intent(in)     :: pdel(:,:)          ! layer thickness (delta-p) [Pa]
     212             :     real(kind_phys), intent(in)     :: pdeldry(:,:)       ! dry layer thickness [Pa]
     213             :     real(kind_phys), intent(in)     :: rpdel(:,:)         ! 1.0 / pdel
     214             :     real(kind_phys), intent(in)     :: rpdeldry(:,:)      ! 1.0 / pdeldry
     215             : 
     216             :     real(kind_phys), intent(in)     :: zm(:,:)            ! geopotential height at midpoints [m]
     217             :     real(kind_phys), intent(in)     :: qpert_in(:)        ! PBL perturbation specific humidity (convective humidity excess) [kg kg-1]
     218             :     real(kind_phys), intent(in)     :: phis(:)            ! surface geopotential [m2 s-2]
     219             :     real(kind_phys), intent(in)     :: pblh(:)            ! PBL height [m]
     220             :     real(kind_phys), intent(in)     :: t(:,:)             ! temperature [K]
     221             :     real(kind_phys), intent(in)     :: q(:,:,:)           ! constituents [kg kg-1]
     222             : 
     223             :     ! Output arguments
     224             :     real(kind_phys), intent(out)    :: dq(:,:,:)          ! constituent tendencies [kg kg-1 s-1]
     225             :     real(kind_phys), intent(out)    :: qc_sh(:,:)         ! dq/dt due to export of cloud water / shallow reserved cloud condensate [kg kg-1 s-1]
     226             :     real(kind_phys), intent(out)    :: cmfdt(:,:)         ! heating rate (to ptend%s) [J kg-1 s-1]
     227             :     real(kind_phys), intent(out)    :: cmfmc_sh(:,:)      ! convective updraft mass flux, shallow [kg s-1 m-2]
     228             :     real(kind_phys), intent(out)    :: cmfdqr(:,:)        ! q tendency due to shallow convective rainout [kg kg-1 s-1]
     229             :     real(kind_phys), intent(out)    :: cmfsl(:,:)         ! moist shallow convection liquid water static energy flux [W m-2]
     230             :     real(kind_phys), intent(out)    :: cmflq(:,:)         ! moist shallow convection total water flux [W m-2]
     231             :     real(kind_phys), intent(out)    :: precc(:)           ! shallow convective precipitation rate [m s-1]
     232             :     integer,         intent(out)    :: cnt_sh(:)          ! top level of shallow convective activity [index]
     233             :     integer,         intent(out)    :: cnb_sh(:)          ! bottom level of shallow convective activity [index]
     234             :     real(kind_phys), intent(out)    :: icwmr(:,:)         ! shallow convection in-cloud water mixing ratio [kg kg-1]
     235             :     real(kind_phys), intent(out)    :: rliq_sh(:)         ! vertically-integrated shallow reserved cloud condensate [m s-1]
     236             : 
     237             :     character(len=64),  intent(out) :: scheme_name        ! scheme name
     238             :     real(kind_phys), intent(out)    :: flx_cnd(:)         ! net_liquid_and_lwe_ice_fluxes_through_top_and_bottom_of_atmosphere_column [m s-1] for check_energy_chng
     239             : 
     240             :     character(len=512), intent(out) :: errmsg
     241             :     integer,            intent(out) :: errflg
     242             : 
     243             :     ! Local variables
     244      140784 :     real(kind_phys)                 :: tpert(ncol)        ! PBL perturbation temperature (convective temperature excess) [K]
     245             : 
     246             :     character(len=256) :: const_standard_name ! temp: constituent standard name
     247             :     logical            :: const_is_dry        ! temp: constituent is dry flag
     248             :     integer            :: const_wv_idx        ! temp: index of water vapor
     249             : 
     250      140784 :     real(kind_phys) :: pm(ncol,pver)       ! pressure [Pa]
     251      140784 :     real(kind_phys) :: pd(ncol,pver)       ! delta-p [Pa]
     252      140784 :     real(kind_phys) :: rpd(ncol,pver)      ! 1./pdel [Pa-1]
     253      140784 :     real(kind_phys) :: cmfdq(ncol,pver)    ! dq(wv)/dt due to moist convection (later copied to dq(:,:,const_wv_idx)) [kg kg-1 s-1]
     254      140784 :     real(kind_phys) :: gam(ncol,pver)      ! 1/cp (d(qsat)/dT) change in saturation mixing ratio with temp
     255      140784 :     real(kind_phys) :: sb(ncol,pver)       ! dry static energy (s bar) [J kg-1]
     256      140784 :     real(kind_phys) :: hb(ncol,pver)       ! moist static energy (h bar) [J kg-1]
     257      140784 :     real(kind_phys) :: shbs(ncol,pver)     ! sat. specific humidity (sh bar star)
     258      140784 :     real(kind_phys) :: hbs(ncol,pver)      ! sat. moist static energy (h bar star)
     259      140784 :     real(kind_phys) :: shbh(ncol,pver+1)   ! specific humidity on interfaces
     260      140784 :     real(kind_phys) :: sbh(ncol,pver+1)    ! s bar on interfaces
     261      140784 :     real(kind_phys) :: hbh(ncol,pver+1)    ! h bar on interfaces
     262      140784 :     real(kind_phys) :: cmrh(ncol,pver+1)   ! interface constituent mixing ratio
     263      140784 :     real(kind_phys) :: prec(ncol)          ! instantaneous total precipitation
     264      140784 :     real(kind_phys) :: dzcld(ncol)         ! depth of convective layer (m)
     265      140784 :     real(kind_phys) :: beta(ncol)          ! overshoot parameter (fraction)
     266      140784 :     real(kind_phys) :: betamx(ncol)        ! local maximum on overshoot
     267      140784 :     real(kind_phys) :: eta(ncol)           ! convective mass flux (kg/m^2 s)
     268      140784 :     real(kind_phys) :: etagdt(ncol)        ! eta*grav*dt
     269      140784 :     real(kind_phys) :: cldwtr(ncol)        ! cloud water (mass)
     270      140784 :     real(kind_phys) :: rnwtr(ncol)         ! rain water  (mass)
     271      140784 :     real(kind_phys) :: totcond(ncol)       ! total condensate; mix of precip and cloud water (mass)
     272      140784 :     real(kind_phys) :: sc  (ncol)          ! dry static energy   ("in-cloud")
     273      140784 :     real(kind_phys) :: shc (ncol)          ! specific humidity   ("in-cloud")
     274      140784 :     real(kind_phys) :: hc  (ncol)          ! moist static energy ("in-cloud")
     275      140784 :     real(kind_phys) :: cmrc(ncol)          ! constituent mix rat ("in-cloud")
     276      140784 :     real(kind_phys) :: dq1(ncol)           ! shb  convective change (lower lvl)
     277      140784 :     real(kind_phys) :: dq2(ncol)           ! shb  convective change (mid level)
     278      140784 :     real(kind_phys) :: dq3(ncol)           ! shb  convective change (upper lvl)
     279      140784 :     real(kind_phys) :: ds1(ncol)           ! sb   convective change (lower lvl)
     280      140784 :     real(kind_phys) :: ds2(ncol)           ! sb   convective change (mid level)
     281      140784 :     real(kind_phys) :: ds3(ncol)           ! sb   convective change (upper lvl)
     282      140784 :     real(kind_phys) :: dcmr1(ncol)         ! q convective change (lower lvl)
     283      140784 :     real(kind_phys) :: dcmr2(ncol)         ! q convective change (mid level)
     284      140784 :     real(kind_phys) :: dcmr3(ncol)         ! q convective change (upper lvl)
     285      140784 :     real(kind_phys) :: estemp(ncol,pver)   ! saturation vapor pressure (scratch)
     286      140784 :     real(kind_phys) :: vtemp1(2*ncol)      ! intermediate scratch vector
     287      140784 :     real(kind_phys) :: vtemp2(2*ncol)      ! intermediate scratch vector
     288      140784 :     real(kind_phys) :: vtemp3(2*ncol)      ! intermediate scratch vector
     289      140784 :     real(kind_phys) :: vtemp4(2*ncol)      ! intermediate scratch vector
     290      140784 :     real(kind_phys) :: vtemp5(2*ncol)      ! intermediate scratch vector
     291      140784 :     integer         :: indx1(ncol)         ! longitude indices for condition true
     292             :     logical         :: etagt0              ! true if eta > 0.0
     293             :     real(kind_phys) :: cats                ! modified characteristic adj. time
     294             :     real(kind_phys) :: rtdt                ! 1./ztodt
     295             :     real(kind_phys) :: qprime              ! modified specific humidity pert.
     296             :     real(kind_phys) :: tprime              ! modified thermal perturbation
     297             :     real(kind_phys) :: pblhgt              ! bounded pbl height (max[pblh,1m])
     298             :     real(kind_phys) :: fac1                ! intermediate scratch variable
     299             :     real(kind_phys) :: shprme              ! intermediate specific humidity pert.
     300             :     real(kind_phys) :: qsattp              ! sat mix rat for thermally pert PBL parcels
     301             :     real(kind_phys) :: dz                  ! local layer depth
     302             :     real(kind_phys) :: temp1               ! intermediate scratch variable
     303             :     real(kind_phys) :: b1                  ! bouyancy measure in detrainment lvl
     304             :     real(kind_phys) :: b2                  ! bouyancy measure in condensation lvl
     305             :     real(kind_phys) :: temp2               ! intermediate scratch variable
     306             :     real(kind_phys) :: temp3               ! intermediate scratch variable
     307             :     real(kind_phys) :: g                   ! bounded vertical gradient of hb
     308             :     real(kind_phys) :: tmass               ! total mass available for convective exch
     309             :     real(kind_phys) :: denom               ! intermediate scratch variable
     310             :     real(kind_phys) :: qtest1              ! used in negative q test (middle lvl)
     311             :     real(kind_phys) :: qtest2              ! used in negative q test (lower lvl)
     312             :     real(kind_phys) :: fslkp               ! flux lw static energy (bot interface)
     313             :     real(kind_phys) :: fslkm               ! flux lw static energy (top interface)
     314             :     real(kind_phys) :: fqlkp               ! flux total water (bottom interface)
     315             :     real(kind_phys) :: fqlkm               ! flux total water (top interface)
     316             :     real(kind_phys) :: botflx              ! bottom constituent mixing ratio flux
     317             :     real(kind_phys) :: topflx              ! top constituent mixing ratio flux
     318             :     real(kind_phys) :: efac1               ! ratio q to convectively induced chg (btm lvl)
     319             :     real(kind_phys) :: efac2               ! ratio q to convectively induced chg (mid lvl)
     320             :     real(kind_phys) :: efac3               ! ratio q to convectively induced chg (top lvl)
     321      140784 :     real(kind_phys) :: tb(ncol,pver)       ! working storage for temp (t bar)
     322       70392 :     real(kind_phys) :: shb(ncol,pver)      ! working storage for spec hum (sh bar)
     323             :     real(kind_phys) :: adjfac              ! adjustment factor (relaxation related)
     324             :     integer         :: i,k                 ! longitude, level indices
     325             :     integer         :: ii                  ! index on "gathered" vectors
     326             :     integer         :: len1                ! vector length of "gathered" vectors
     327             :     integer         :: m                   ! constituent index
     328             :     integer         :: ktp                 ! tmp indx used to track top of convective layer
     329             : 
     330             :     ! debug use quantities
     331             :     real(kind_phys) :: rh                  ! relative humidity
     332             :     real(kind_phys) :: es                  ! sat vapor pressure
     333             :     real(kind_phys) :: hsum1               ! moist static energy integral
     334             :     real(kind_phys) :: qsum1               ! total water integral
     335             :     real(kind_phys) :: hsum2               ! final moist static energy integral
     336             :     real(kind_phys) :: qsum2               ! final total water integral
     337             :     real(kind_phys) :: fac                 ! intermediate scratch variable
     338             :     integer         :: n                   ! vertical index     (diagnostics)
     339             :     integer         :: kp                  ! vertical index     (diagnostics)
     340             :     integer         :: kpp                 ! index offset, kp+1 (diagnostics)
     341             :     integer         :: kpm1                ! index offset, kp-1 (diagnostics)
     342             : 
     343       70392 :     errmsg = ''
     344       70392 :     errflg = 0
     345             : 
     346       70392 :     scheme_name = 'hack_convect_shallow'
     347             : 
     348             :     !---------------------------------------------------
     349             :     ! Initialize output tendencies
     350             :     !---------------------------------------------------
     351    28436184 :     cmfdt   (:ncol,:)     = 0._kind_phys
     352    28436184 :     cmfdq   (:ncol,:)     = 0._kind_phys
     353    29527176 :     cmfmc_sh(:ncol,:)     = 0._kind_phys
     354    28436184 :     cmfdqr  (:ncol,:)     = 0._kind_phys
     355    28436184 :     cmfsl   (:ncol,:)     = 0._kind_phys
     356    28436184 :     cmflq   (:ncol,:)     = 0._kind_phys
     357    28436184 :     qc_sh   (:ncol,:)     = 0._kind_phys
     358     1090992 :     rliq_sh (:ncol)       = 0._kind_phys
     359             : 
     360             :     ! Check constituents list and locate water vapor index
     361             :     ! (not assumed to be 1)
     362           0 :     call ccpp_const_get_idx(const_props, &
     363             :          'water_vapor_mixing_ratio_wrt_moist_air_and_condensed_water', &
     364       70392 :          const_wv_idx, errmsg, errflg)
     365             : 
     366             :     !---------------------------------------------------
     367             :     ! copy q to dq for passive tracer transport.
     368             :     ! this is NOT an initialization. the dq at this point
     369             :     ! is not physical (used as temporary here) only at the end
     370             :     ! dq is updated to be an actual tendency.
     371             :     !---------------------------------------------------
     372       70392 :     if(pcnst > 1) then
     373             :       ! set dq for passive tracer transport from q as temporary...
     374    85378944 :       dq(:ncol,:,:) = q(:ncol,:,:)
     375             : 
     376             :       ! except for water vapor
     377    28436184 :       dq(:ncol,:,const_wv_idx) = 0._kind_phys
     378             :     endif
     379             : 
     380             :     !---------------------------------------------------
     381             :     ! Quantity preparations from convect_shallow.F90.
     382             :     !---------------------------------------------------
     383             : 
     384             :     ! convect_shallow.F90 is not linked to pbuf tpert and always sets to zero.
     385             :     ! "This field probably should reference the pbuf tpert field but it doesnt"
     386     1090992 :     tpert(:ncol) = 0.0_kind_phys
     387             : 
     388             :     !---------------------------------------------------
     389             :     ! Preparation of working arrays
     390             :     !---------------------------------------------------
     391             :     ! Ensure that characteristic adjustment time scale (cmftau) assumed
     392             :     ! in estimate of eta isn't smaller than model time scale (ztodt)
     393             :     ! The time over which the convection is assumed to act (the adjustment
     394             :     ! time scale) can be applied with each application of the three-level
     395             :     ! cloud model, or applied to the column tendencies after a "hard"
     396             :     ! adjustment (i.e., on a 2-delta t time scale) is evaluated
     397       70392 :     if (rlxclm) then
     398       70392 :        cats   = ztodt             ! relaxation applied to column
     399       70392 :        adjfac = ztodt/(max(ztodt,cmftau))
     400             :     else
     401           0 :        cats   = max(ztodt,cmftau) ! relaxation applied to triplet
     402           0 :        adjfac = 1.0_kind_phys
     403             :     endif
     404       70392 :     rtdt = 1.0_kind_phys/ztodt
     405             : 
     406             :     ! Move temperature and moisture into working storage
     407     1619016 :     do k=limcnv,pver
     408    24072216 :        do i=1,ncol
     409    22453200 :           tb (i,k) = t(i,k)
     410    24001824 :           shb(i,k) = q(i,k,const_wv_idx)
     411             :        end do
     412             :     end do
     413     1900584 :     do k=1,pver
     414    28436184 :        do i=1,ncol
     415    28365792 :           icwmr(i,k) = 0._kind_phys
     416             :        end do
     417             :     end do
     418             : 
     419             :     ! Compute sb,hb,shbs,hbs
     420     1619016 :     do k = limcnv,pver
     421           0 :        call qsat(tb(1:ncol,k), pmid(1:ncol,k), &
     422           0 :             estemp(1:ncol,k), shbs(1:ncol,k), ncol, &
     423     1619016 :             gam=gam(1:ncol,k))
     424             :     end do
     425             : 
     426     1619016 :     do k=limcnv,pver
     427    24072216 :        do i=1,ncol
     428    22453200 :           sb (i,k) = cp*tb(i,k) + zm(i,k)*grav + phis(i)
     429    22453200 :           hb (i,k) = sb(i,k) + hlat*shb(i,k)
     430    24001824 :           hbs(i,k) = sb(i,k) + hlat*shbs(i,k)
     431             :        end do
     432             :     end do
     433             : 
     434             :     ! Compute sbh, shbh
     435     1548624 :     do k=limcnv+1,pver
     436    22981224 :        do i=1,ncol
     437    21432600 :           sbh (i,k) = 0.5_kind_phys*(sb(i,k-1) + sb(i,k))
     438    21432600 :           shbh(i,k) = qhalf(shb(i,k-1),shb(i,k),shbs(i,k-1),shbs(i,k))
     439    22910832 :           hbh (i,k) = sbh(i,k) + hlat*shbh(i,k)
     440             :        end do
     441             :     end do
     442             : 
     443             :     ! Specify properties at top of model (not used, but filling anyway)
     444     1090992 :     do i=1,ncol
     445     1020600 :        sbh (i,limcnv) = sb(i,limcnv)
     446     1020600 :        shbh(i,limcnv) = shb(i,limcnv)
     447     1090992 :        hbh (i,limcnv) = hb(i,limcnv)
     448             :     end do
     449             : 
     450             :     ! Zero vertically independent control, tendency & diagnostic arrays
     451     1090992 :     do i=1,ncol
     452     1020600 :        prec(i)  = 0.0_kind_phys
     453     1020600 :        dzcld(i) = 0.0_kind_phys
     454     1020600 :        cnb_sh(i)= 0
     455     1090992 :        cnt_sh(i)= pver+1
     456             :     end do
     457             : 
     458       70392 :     if(debug_verbose) then
     459             :       ! DEBUG DIAGNOSTICS - Output initial thermodynamic profile
     460           0 :       do i=1,ncol
     461           0 :         if(i == 1) then
     462             :           ! Approximate vertical integral of moist static energy
     463             :           ! and total precipitable water
     464           0 :           hsum1 = 0.0_kind_phys
     465           0 :           qsum1 = 0.0_kind_phys
     466           0 :           do k=limcnv,pver
     467           0 :             hsum1 = hsum1 + pdel(i,k)*rgrav*hb(i,k)
     468           0 :             qsum1 = qsum1 + pdel(i,k)*rgrav*shb(i,k)
     469             :           end do
     470             : 
     471           0 :           write(iulog,8010)
     472           0 :           fac = grav*864._kind_phys
     473           0 :           do k=limcnv,pver
     474           0 :             rh = shb(i,k)/shbs(i,k)
     475           0 :             write(iulog,8020) shbh(i,k),sbh(i,k),hbh(i,k),fac*cmfmc_sh(i,k),cmfsl(i,k), cmflq(i,k)
     476           0 :             write(iulog,8040) tb(i,k),shb(i,k),rh,sb(i,k),hb(i,k),hbs(i,k),ztodt*cmfdt(i,k), &
     477           0 :                           ztodt*cmfdq(i,k),ztodt*cmfdqr(i,k)
     478             :           end do
     479           0 :           write(iulog, 8000) prec(i)
     480             :         end if
     481             :       end do
     482             :     endif
     483             : 
     484             :     !---------------------------------------------------
     485             :     ! Begin moist convective mass flux adjustment procedure.
     486             :     ! Formalism ensures that negative cloud liquid water can never occur
     487             :     !---------------------------------------------------
     488     1478232 :     kloop: do k = pver-1,limcnv+1,-1
     489    21819840 :       do i = 1, ncol
     490    20412000 :         etagdt(i) = 0.0_kind_phys
     491    20412000 :         eta   (i) = 0.0_kind_phys
     492    20412000 :         beta  (i) = 0.0_kind_phys
     493    20412000 :         ds1   (i) = 0.0_kind_phys
     494    20412000 :         ds2   (i) = 0.0_kind_phys
     495    20412000 :         ds3   (i) = 0.0_kind_phys
     496    20412000 :         dq1   (i) = 0.0_kind_phys
     497    20412000 :         dq2   (i) = 0.0_kind_phys
     498    20412000 :         dq3   (i) = 0.0_kind_phys
     499             :         ! Specification of "cloud base" conditions
     500    20412000 :         qprime    = 0.0_kind_phys
     501    20412000 :         tprime    = 0.0_kind_phys
     502             : 
     503             :         ! Assign tprime within the PBL to be proportional to the quantity
     504             :         ! tpert (which will be bounded by tpmax), passed to this routine by
     505             :         ! the PBL routine.  Don't allow perturbation to produce a dry
     506             :         ! adiabatically unstable parcel.  Assign qprime within the PBL to be
     507             :         ! an appropriately modified value of the quantity qpert (which will be
     508             :         ! bounded by shpmax) passed to this routine by the PBL routine.  The
     509             :         ! quantity qprime should be less than the local saturation value
     510             :         ! (qsattp=qsat[t+tprime,p]).  In both cases, tpert and qpert are
     511             :         ! linearly reduced toward zero as the PBL top is approached.
     512    20412000 :         pblhgt = max(pblh(i),1.0_kind_phys)
     513    20412000 :         if ( (zm(i,k+1) <= pblhgt) .and. dzcld(i) == 0.0_kind_phys ) then
     514     2001755 :            fac1   = max(0.0_kind_phys,1.0_kind_phys-zm(i,k+1)/pblhgt)
     515     2001755 :            tprime = min(tpert(i),tpmax)*fac1
     516     2001755 :            qsattp = shbs(i,k+1) + cp*rhlat*gam(i,k+1)*tprime
     517     2001755 :            shprme = min(min(qpert_in(i),shpmax)*fac1,max(qsattp-shb(i,k+1),0.0_kind_phys))
     518     2001755 :            qprime = max(qprime,shprme)
     519             :         else
     520    18410245 :            tprime = 0.0_kind_phys
     521    18410245 :            qprime = 0.0_kind_phys
     522             :         end if
     523             : 
     524             :         ! Specify "updraft" (in-cloud) thermodynamic properties
     525    20412000 :         sc (i)    = sb (i,k+1) + cp*tprime
     526    20412000 :         shc(i)    = shb(i,k+1) + qprime
     527    20412000 :         hc (i)    = sc (i    ) + hlat*shc(i)
     528    20412000 :         vtemp4(i) = hc(i) - hbs(i,k)
     529    20412000 :         dz        = pdel(i,k)*rgas*tb(i,k)*rgrav/pmid(i,k)
     530    21819840 :         if (vtemp4(i) > 0.0_kind_phys) then
     531      990058 :            dzcld(i) = dzcld(i) + dz
     532             :         else
     533    19421942 :            dzcld(i) = 0.0_kind_phys
     534             :         end if
     535             :       enddo
     536             : 
     537     1407840 :       if(debug_verbose) then
     538             :         ! DEBUG DIAGNOSTICS - output thermodynamic perturbation information
     539           0 :         do i=1,ncol
     540           0 :           if(i == 1) then
     541           0 :             write(iulog,8090) k+1,sc(i),shc(i),hc(i)
     542             :           end if
     543             :         enddo
     544             :       endif
     545             : 
     546             : 
     547             :       ! Check on moist convective instability
     548             :       ! Build index vector of points where instability exists
     549     1407840 :       len1 = 0
     550    21819840 :       do i=1,ncol
     551    21819840 :          if (vtemp4(i) > 0.0_kind_phys) then
     552      990058 :             len1 = len1 + 1
     553      990058 :             indx1(len1) = i
     554             :          end if
     555             :       end do
     556             : 
     557     1407840 :       if (len1 <= 0) cycle kloop
     558             : 
     559             :       ! Current level just below top level => no overshoot
     560      177473 :       if (k <= limcnv+1) then
     561           0 :          do ii=1,len1
     562           0 :             i = indx1(ii)
     563           0 :             temp1     = vtemp4(i)/(1.0_kind_phys + gam(i,k))
     564           0 :             cldwtr(i) = max(0.0_kind_phys,(sb(i,k) - sc(i) + temp1))
     565           0 :             beta(i)   = 0.0_kind_phys
     566           0 :             vtemp3(i) = (1.0_kind_phys + gam(i,k))*(sc(i) - sbh(i,k))
     567             :          end do
     568             :       else
     569             :         ! First guess at overshoot parameter using crude buoyancy closure
     570             :         ! 10% overshoot assumed as a minimum and 1-c0*dz maximum to start
     571             :         ! If pre-existing supersaturation in detrainment layer, beta=0
     572             :         ! cldwtr is temporarily equal to hlat*l (l=> liquid water)
     573     1167531 :         do ii=1,len1
     574      990058 :           i = indx1(ii)
     575      990058 :           temp1     = vtemp4(i)/(1.0_kind_phys + gam(i,k))
     576      990058 :           cldwtr(i) = max(0.0_kind_phys,(sb(i,k)-sc(i)+temp1))
     577      990058 :           betamx(i) = 1.0_kind_phys - c0*max(0.0_kind_phys,(dzcld(i)-dzmin))
     578      990058 :           b1        = (hc(i) - hbs(i,k-1))*pdel(i,k-1)
     579      990058 :           b2        = (hc(i) - hbs(i,k  ))*pdel(i,k  )
     580      990058 :           beta(i)   = max(betamn,min(betamx(i), 1.0_kind_phys + b1/b2))
     581      990058 :           if (hbs(i,k-1) <= hb(i,k-1)) beta(i) = 0.0_kind_phys
     582             : 
     583             :           ! Bound maximum beta to ensure physically realistic solutions
     584             :           !
     585             :           ! First check constrains beta so that eta remains positive
     586             :           ! (assuming that eta is already positive for beta equal zero)
     587     7920464 :           vtemp1(i) = -(hbh(i,k+1) - hc(i))*pdel(i,k)*rpdel(i,k+1)+ &
     588     8910522 :                       (1.0_kind_phys + gam(i,k))*(sc(i) - sbh(i,k+1) + cldwtr(i))
     589      990058 :           vtemp2(i) = (1.0_kind_phys + gam(i,k))*(sc(i) - sbh(i,k))
     590      990058 :           vtemp3(i) = vtemp2(i)
     591     1167531 :           if ((beta(i)*vtemp2(i) - vtemp1(i)) > 0._kind_phys) then
     592         147 :             betamx(i) = 0.99_kind_phys*(vtemp1(i)/vtemp2(i))
     593         147 :             beta(i)   = max(0.0_kind_phys,min(betamx(i),beta(i)))
     594             :           end if
     595             :         end do
     596             : 
     597             :         ! Second check involves supersaturation of "detrainment layer"
     598             :         ! small amount of supersaturation acceptable (by ssfac factor)
     599     1167531 :         do ii=1,len1
     600      990058 :           i = indx1(ii)
     601     1167531 :           if (hb(i,k-1) < hbs(i,k-1)) then
     602      844030 :             vtemp1(i) = vtemp1(i)*rpdel(i,k)
     603     5064180 :             temp2 = gam(i,k-1)*(sbh(i,k) - sc(i) + cldwtr(i)) -  &
     604     5908210 :                     hbh(i,k) + hc(i) - sc(i) + sbh(i,k)
     605      844030 :             temp3 = vtemp3(i)*rpdel(i,k)
     606     3376120 :             vtemp2(i) = (ztodt/cats)*(hc(i) - hbs(i,k))*temp2/ &
     607     4220150 :                         (pdel(i,k-1)*(hbs(i,k-1) - hb(i,k-1))) + temp3
     608      844030 :             if ((beta(i)*vtemp2(i) - vtemp1(i)) > 0._kind_phys) then
     609       89940 :               betamx(i) = ssfac*(vtemp1(i)/vtemp2(i))
     610       89940 :               beta(i)   = max(0.0_kind_phys,min(betamx(i),beta(i)))
     611             :             end if
     612             :           else
     613      146028 :              beta(i) = 0.0_kind_phys
     614             :           end if
     615             :         end do
     616             : 
     617             :         ! Third check to avoid introducing 2 delta x thermodynamic
     618             :         ! noise in the vertical ... constrain adjusted h (or theta e)
     619             :         ! so that the adjustment doesn't contribute to "kinks" in h
     620     1167531 :         do ii=1,len1
     621      990058 :            i = indx1(ii)
     622      990058 :            g = min(0.0_kind_phys,hb(i,k) - hb(i,k-1))
     623      990058 :            temp1 = (hb(i,k) - hb(i,k-1) - g)*(cats/ztodt)/(hc(i) - hbs(i,k))
     624      990058 :            vtemp1(i) = temp1*vtemp1(i) + (hc(i) - hbh(i,k+1))*rpdel(i,k)
     625     7920464 :            vtemp2(i) = temp1*vtemp3(i)*rpdel(i,k) + (hc(i) - hbh(i,k) - cldwtr(i))* &
     626     8910522 :                        (rpdel(i,k) + rpdel(i,k+1))
     627     1167531 :            if ((beta(i)*vtemp2(i) - vtemp1(i)) > 0._kind_phys) then
     628       35611 :               if (vtemp2(i) /= 0.0_kind_phys) then
     629       35611 :                 betamx(i) = vtemp1(i)/vtemp2(i)
     630             :               else
     631           0 :                 betamx(i) = 0.0_kind_phys
     632             :               end if
     633       35611 :               beta(i) = max(0.0_kind_phys,min(betamx(i),beta(i)))
     634             :            end if
     635             :         end do
     636             :       end if ! (k <= limcnv+1) Current level just below top level => no overshoot
     637             : 
     638             : 
     639             :       ! Calculate mass flux required for stabilization.
     640             :       !
     641             :       ! Ensure that the convective mass flux, eta, is positive by
     642             :       ! setting negative values of eta to zero..
     643             :       ! Ensure that estimated mass flux cannot move more than the
     644             :       ! minimum of total mass contained in either layer k or layer k+1.
     645             :       ! Also test for other pathological cases that result in non-
     646             :       ! physical states and adjust eta accordingly.
     647     1167531 :       do ii=1,len1
     648      990058 :         i = indx1(ii)
     649      990058 :         beta(i) = max(0.0_kind_phys,beta(i))
     650      990058 :         temp1 = hc(i) - hbs(i,k)
     651     5940348 :         temp2 = ((1.0_kind_phys + gam(i,k))*(sc(i) - sbh(i,k+1) + cldwtr(i)) - &
     652     6930406 :                   beta(i)*vtemp3(i))*rpdel(i,k) - (hbh(i,k+1) - hc(i))*rpdel(i,k+1)
     653      990058 :         eta(i) = temp1/(temp2*grav*cats)
     654      990058 :         tmass = min(pdel(i,k),pdel(i,k+1))*rgrav
     655      990058 :         if (eta(i) > tmass*rtdt .or. eta(i) <= 0.0_kind_phys) eta(i) = 0.0_kind_phys
     656             : 
     657             :         ! Check on negative q in top layer (bound beta)
     658      990058 :         if (shc(i)-shbh(i,k) < 0.0_kind_phys .and. beta(i)*eta(i) /= 0.0_kind_phys) then
     659        2533 :            denom = eta(i)*grav*ztodt*(shc(i) - shbh(i,k))*rpdel(i,k-1)
     660        2533 :            beta(i) = max(0.0_kind_phys,min(-0.999_kind_phys*shb(i,k-1)/denom,beta(i)))
     661             :         end if
     662             : 
     663             :         ! Check on negative q in middle layer (zero eta)
     664     5940348 :         qtest1 = shb(i,k) + eta(i)*grav*ztodt*((shc(i) - shbh(i,k+1)) - &
     665     5940348 :                  (1.0_kind_phys - beta(i))*cldwtr(i)*rhlat - beta(i)*(shc(i) - shbh(i,k)))* &
     666    12870754 :            rpdel(i,k)
     667      990058 :         if (qtest1 <= 0.0_kind_phys) eta(i) = 0.0_kind_phys
     668             : 
     669             :         ! Check on negative q in lower layer (bound eta)
     670      990058 :         fac1 = -(shbh(i,k+1) - shc(i))*rpdel(i,k+1)
     671      990058 :         qtest2 = shb(i,k+1) - eta(i)*grav*ztodt*fac1
     672      990058 :         if (qtest2 < 0.0_kind_phys) then
     673           0 :            eta(i) = 0.99_kind_phys*shb(i,k+1)/(grav*ztodt*fac1)
     674             :         end if
     675     1167531 :         etagdt(i) = eta(i)*grav*ztodt
     676             :       end do
     677             : 
     678      177473 :       if(debug_verbose) then
     679           0 :         do i=1,ncol
     680           0 :           if (i == 1) then
     681           0 :             write(iulog,8080) beta(i), eta(i)
     682             :           endif
     683             :         enddo
     684             :       endif
     685             : 
     686             :       ! Calculate cloud water, rain water, and thermodynamic changes
     687     1167531 :       do ii=1,len1
     688      990058 :         i = indx1(ii)
     689      990058 :         icwmr(i,k) = cldwtr(i)*rhlat
     690      990058 :         cldwtr(i) = etagdt(i)*cldwtr(i)*rhlat*rgrav
     691             : 
     692             :         ! JJH changes to facilitate export of cloud liquid water --------------------------------
     693      990058 :         totcond(i) = (1.0_kind_phys - beta(i))*cldwtr(i)
     694      990058 :         rnwtr(i) = min(totcond(i),c0*(dzcld(i)-dzmin)*cldwtr(i))
     695      990058 :         ds1(i) = etagdt(i)*(sbh(i,k+1) - sc(i))*rpdel(i,k+1)
     696      990058 :         dq1(i) = etagdt(i)*(shbh(i,k+1) - shc(i))*rpdel(i,k+1)
     697     4950290 :         ds2(i) = (etagdt(i)*(sc(i) - sbh(i,k+1)) +  &
     698     5940348 :                  hlat*grav*cldwtr(i) - beta(i)*etagdt(i)*(sc(i) - sbh(i,k)))*rpdel(i,k)
     699             : 
     700             :         ! JJH change for export of cloud liquid water; must use total condensate
     701             :         ! since rainwater no longer represents total condensate
     702     6930406 :         dq2(i) = (etagdt(i)*(shc(i) - shbh(i,k+1)) - grav*totcond(i) - beta(i)* &
     703     7920464 :                  etagdt(i)*(shc(i) - shbh(i,k)))*rpdel(i,k)
     704     6930406 :         ds3(i) = beta(i)*(etagdt(i)*(sc(i) - sbh(i,k)) - hlat*grav*cldwtr(i))* &
     705     7920464 :                  rpdel(i,k-1)
     706      990058 :         dq3(i) = beta(i)*etagdt(i)*(shc(i) - shbh(i,k))*rpdel(i,k-1)
     707             : 
     708             :         ! Isolate convective fluxes for later diagnostics
     709      990058 :         fslkp = eta(i)*(sc(i) - sbh(i,k+1))
     710      990058 :         fslkm = beta(i)*(eta(i)*(sc(i) - sbh(i,k)) - hlat*cldwtr(i)*rtdt)
     711      990058 :         fqlkp = eta(i)*(shc(i) - shbh(i,k+1))
     712      990058 :         fqlkm = beta(i)*eta(i)*(shc(i) - shbh(i,k))
     713             : 
     714             :         ! Update thermodynamic profile (update sb, hb, & hbs later)
     715      990058 :         tb (i,k+1) = tb(i,k+1)  + ds1(i)*rcp
     716      990058 :         tb (i,k  ) = tb(i,k  )  + ds2(i)*rcp
     717      990058 :         tb (i,k-1) = tb(i,k-1)  + ds3(i)*rcp
     718      990058 :         shb(i,k+1) = shb(i,k+1) + dq1(i)
     719      990058 :         shb(i,k  ) = shb(i,k  ) + dq2(i)
     720      990058 :         shb(i,k-1) = shb(i,k-1) + dq3(i)
     721             : 
     722             :         ! ** Update diagnostic information for final budget **
     723             :         ! Tracking precipitation, temperature & specific humidity tendencies,
     724             :         ! rainout term, convective mass flux, convective liquid
     725             :         ! water static energy flux, and convective total water flux
     726             :         ! The variable afac makes the necessary adjustment to the
     727             :         ! diagnostic fluxes to account for adjustment time scale based on
     728             :         ! how relaxation time scale is to be applied (column vs. triplet)
     729      990058 :         prec(i)    = prec(i) + (rnwtr(i)/rhoh2o)*adjfac
     730             : 
     731             :         ! The following variables have units of "units"/second
     732      990058 :         cmfdt (i,k+1) = cmfdt (i,k+1) + ds1(i)*rtdt*adjfac
     733      990058 :         cmfdt (i,k  ) = cmfdt (i,k  ) + ds2(i)*rtdt*adjfac
     734      990058 :         cmfdt (i,k-1) = cmfdt (i,k-1) + ds3(i)*rtdt*adjfac
     735      990058 :         cmfdq (i,k+1) = cmfdq (i,k+1) + dq1(i)*rtdt*adjfac
     736      990058 :         cmfdq (i,k  ) = cmfdq (i,k  ) + dq2(i)*rtdt*adjfac
     737      990058 :         cmfdq (i,k-1) = cmfdq (i,k-1) + dq3(i)*rtdt*adjfac
     738             : 
     739             :         ! JJH changes to export cloud liquid water --------------------------------
     740      990058 :         qc_sh   (i,k  ) = (grav*(totcond(i)-rnwtr(i))*rpdel(i,k))*rtdt*adjfac
     741      990058 :         cmfdqr  (i,k  ) = cmfdqr(i,k  ) + (grav*rnwtr(i)*rpdel(i,k))*rtdt*adjfac
     742      990058 :         cmfmc_sh(i,k+1) = cmfmc_sh(i,k+1) + eta(i)*adjfac
     743      990058 :         cmfmc_sh(i,k  ) = cmfmc_sh(i,k  ) + beta(i)*eta(i)*adjfac
     744             : 
     745             :         ! The following variables have units of w/m**2
     746      990058 :         cmfsl (i,k+1) = cmfsl (i,k+1) + fslkp*adjfac
     747      990058 :         cmfsl (i,k  ) = cmfsl (i,k  ) + fslkm*adjfac
     748      990058 :         cmflq (i,k+1) = cmflq (i,k+1) + hlat*fqlkp*adjfac
     749     1167531 :         cmflq (i,k  ) = cmflq (i,k  ) + hlat*fqlkm*adjfac
     750             :       enddo
     751             : 
     752             :       ! Next, convectively modify passive constituents
     753             :       ! For now, when applying relaxation time scale to thermal fields after
     754             :       ! entire column has undergone convective overturning, constituents will
     755             :       ! be mixed using a "relaxed" value of the mass flux determined above
     756             :       ! Although this will be inconsistant with the treatment of the thermal
     757             :       ! fields, it's computationally much cheaper, no more-or-less justifiable,
     758             :       ! and consistent with how the history tape mass fluxes would be used in
     759             :       ! an off-line mode (i.e., using an off-line transport model)
     760      709892 :       const_modify_loop: do m = 1, pcnst
     761             :         ! Water vapor needs to be skipped in the loop.
     762      532419 :         if (m == const_wv_idx) then
     763      177473 :           cycle const_modify_loop
     764             :         endif
     765             : 
     766             :         ! assign pd, rpd, pm temporary properties based on constituent dry/moist mixing ratio
     767      354946 :         call const_props(m)%is_dry(const_is_dry, errflg, errmsg)
     768      354946 :         if(const_is_dry) then
     769           0 :           pd (:ncol,:) = pdeldry (:ncol,:)
     770           0 :           rpd(:ncol,:) = rpdeldry(:ncol,:)
     771           0 :           pm (:ncol,:) = pmiddry (:ncol,:)
     772             :         else
     773   148875006 :           pd (:ncol,:) = pdel    (:ncol,:)
     774   148875006 :           rpd(:ncol,:) = rpdel   (:ncol,:)
     775   148875006 :           pm (:ncol,:) = pmid    (:ncol,:)
     776             :         endif
     777             : 
     778     2512535 :         pcl1loop: do ii=1,len1
     779     1980116 :           i = indx1(ii)
     780             : 
     781             :           ! If any of the reported values of the constituent is negative in
     782             :           ! the three adjacent levels, nothing will be done to the profile
     783     1980116 :           if ((dq(i,k+1,m) < 0.0_kind_phys) .or. (dq(i,k,m) < 0.0_kind_phys) .or. (dq(i,k-1,m) < 0.0_kind_phys)) cycle pcl1loop
     784             : 
     785             :           ! Specify constituent interface values (linear interpolation)
     786     1980116 :           cmrh(i,k  ) = 0.5_kind_phys*(dq(i,k-1,m) + dq(i,k  ,m))
     787     1980116 :           cmrh(i,k+1) = 0.5_kind_phys*(dq(i,k  ,m) + dq(i,k+1,m))
     788             : 
     789             :           ! Specify perturbation properties of constituents in PBL
     790     1980116 :           pblhgt = max(pblh(i),1.0_kind_phys)
     791     1980116 :           if ( (zm(i,k+1) <= pblhgt) .and. dzcld(i) == 0.0_kind_phys ) then
     792           0 :               fac1 = max(0.0_kind_phys,1.0_kind_phys-zm(i,k+1)/pblhgt)
     793             :               ! cmrc(i) = dq(i,k+1,m) + qpert(i,m)*fac1
     794             :               ! hplin - qpert for m>1 is always zero
     795           0 :               cmrc(i) = dq(i,k+1,m)
     796             :           else
     797     1980116 :              cmrc(i) = dq(i,k+1,m)
     798             :           end if
     799             : 
     800             :           ! Determine fluxes, flux divergence => changes due to convection
     801             :           ! Logic must be included to avoid producing negative values. A bit
     802             :           ! messy since there are no a priori assumptions about profiles.
     803             :           ! Tendency is modified (reduced) when pending disaster detected.
     804             : 
     805     1980116 :           botflx   = etagdt(i)*(cmrc(i) - cmrh(i,k+1))*adjfac
     806     1980116 :           topflx   = beta(i)*etagdt(i)*(cmrc(i)-cmrh(i,k))*adjfac
     807     1980116 :           dcmr1(i) = -botflx*rpd(i,k+1)
     808     1980116 :           efac1    = 1.0_kind_phys
     809     1980116 :           efac2    = 1.0_kind_phys
     810     1980116 :           efac3    = 1.0_kind_phys
     811             : 
     812     1980116 :           if (dq(i,k+1,m)+dcmr1(i) < 0.0_kind_phys) then
     813           0 :              if ( abs(dcmr1(i)) > 1.e-300_kind_phys ) then
     814           0 :                 efac1 = max(tiny,abs(dq(i,k+1,m)/dcmr1(i)) - eps)
     815             :              else
     816           0 :                 efac1 = tiny
     817             :              endif
     818             :           end if
     819             : 
     820     1980116 :           if (efac1 == tiny .or. efac1 > 1.0_kind_phys) efac1 = 0.0_kind_phys
     821     1980116 :           dcmr1(i) = -efac1*botflx*rpd(i,k+1)
     822     1980116 :           dcmr2(i) = (efac1*botflx - topflx)*rpd(i,k)
     823             : 
     824     1980116 :           if (dq(i,k,m)+dcmr2(i) < 0.0_kind_phys) then
     825       50477 :              if ( abs(dcmr2(i)) > 1.e-300_kind_phys ) then
     826       50477 :                 efac2 = max(tiny,abs(dq(i,k  ,m)/dcmr2(i)) - eps)
     827             :              else
     828           0 :                 efac2 = tiny
     829             :              endif
     830             :           end if
     831             : 
     832     1980116 :           if (efac2 == tiny .or. efac2 > 1.0_kind_phys) efac2 = 0.0_kind_phys
     833     1980116 :           dcmr2(i) = (efac1*botflx - efac2*topflx)*rpd(i,k)
     834     1980116 :           dcmr3(i) = efac2*topflx*rpd(i,k-1)
     835             : 
     836     1980116 :           if ( (dq(i,k-1,m)+dcmr3(i) < 0.0_kind_phys ) ) then
     837      219248 :              if  ( abs(dcmr3(i)) > 1.e-300_kind_phys ) then
     838      219248 :                 efac3 = max(tiny,abs(dq(i,k-1,m)/dcmr3(i)) - eps)
     839             :              else
     840           0 :                 efac3 = tiny
     841             :              endif
     842             :           end if
     843             : 
     844     1980116 :           if (efac3 == tiny .or. efac3 > 1.0_kind_phys) efac3 = 0.0_kind_phys
     845     1980116 :           efac3    = min(efac2,efac3)
     846     1980116 :           dcmr2(i) = (efac1*botflx - efac3*topflx)*rpd(i,k)
     847     1980116 :           dcmr3(i) = efac3*topflx*rpd(i,k-1)
     848             : 
     849     1980116 :           dq(i,k+1,m) = dq(i,k+1,m) + dcmr1(i)
     850     1980116 :           dq(i,k  ,m) = dq(i,k  ,m) + dcmr2(i)
     851     2335062 :           dq(i,k-1,m) = dq(i,k-1,m) + dcmr3(i)
     852             :         end do pcl1loop
     853             :       end do const_modify_loop
     854             :       ! Constituent modifications complete
     855             : 
     856             :       ! This if restructured from a goto
     857      177473 :       if (k /= limcnv+1) then
     858             :         ! Complete update of thermodynamic structure at integer levels
     859             :         ! gather/scatter points that need new values of shbs and gamma
     860     1167531 :         do ii=1,len1
     861      990058 :            i = indx1(ii)
     862      990058 :            vtemp1(ii     ) = tb(i,k)
     863      990058 :            vtemp1(ii+len1) = tb(i,k-1)
     864      990058 :            vtemp2(ii     ) = pmid(i,k)
     865     1167531 :            vtemp2(ii+len1) = pmid(i,k-1)
     866             :         end do
     867           0 :         call qsat(vtemp1(1:2*len1), vtemp2(1:2*len1), &
     868      177473 :                   vtemp5(1:2*len1), vtemp3(1:2*len1), 2*len1, gam=vtemp4(1:2*len1))
     869     1167531 :         do ii=1,len1
     870      990058 :            i = indx1(ii)
     871      990058 :            shbs(i,k  ) = vtemp3(ii     )
     872      990058 :            shbs(i,k-1) = vtemp3(ii+len1)
     873      990058 :            gam(i,k  ) = vtemp4(ii     )
     874      990058 :            gam(i,k-1) = vtemp4(ii+len1)
     875      990058 :            sb (i,k  ) = sb(i,k  ) + ds2(i)
     876      990058 :            sb (i,k-1) = sb(i,k-1) + ds3(i)
     877      990058 :            hb (i,k  ) = sb(i,k  ) + hlat*shb(i,k  )
     878      990058 :            hb (i,k-1) = sb(i,k-1) + hlat*shb(i,k-1)
     879      990058 :            hbs(i,k  ) = sb(i,k  ) + hlat*shbs(i,k  )
     880     1167531 :            hbs(i,k-1) = sb(i,k-1) + hlat*shbs(i,k-1)
     881             :         end do
     882             : 
     883             :         ! Update thermodynamic information at half (i.e., interface) levels
     884     1167531 :         do ii=1,len1
     885      990058 :            i = indx1(ii)
     886      990058 :            sbh (i,k) = 0.5_kind_phys*(sb(i,k) + sb(i,k-1))
     887      990058 :            shbh(i,k) = qhalf(shb(i,k-1),shb(i,k),shbs(i,k-1),shbs(i,k))
     888      990058 :            hbh (i,k) = sbh(i,k) + hlat*shbh(i,k)
     889      990058 :            sbh (i,k-1) = 0.5_kind_phys*(sb(i,k-1) + sb(i,k-2))
     890      990058 :            shbh(i,k-1) = qhalf(shb(i,k-2),shb(i,k-1),shbs(i,k-2),shbs(i,k-1))
     891     1167531 :            hbh (i,k-1) = sbh(i,k-1) + hlat*shbh(i,k-1)
     892             :         end do
     893             :       end if ! k /= limcnv+1
     894             : 
     895             :       ! Ensure that dzcld is reset if convective mass flux zero
     896             :       ! specify the current vertical extent of the convective activity
     897             :       ! top of convective layer determined by size of overshoot param.
     898     2926547 :       do i=1,ncol
     899     2678682 :         etagt0 = eta(i).gt.0.0_kind_phys
     900     2678682 :         if ( .not. etagt0) dzcld(i) = 0.0_kind_phys
     901     2678682 :         if (etagt0 .and. beta(i) > betamn) then
     902      421788 :            ktp = k-1
     903             :         else
     904     2256894 :            ktp = k
     905             :         end if
     906     2856155 :         if (etagt0) then
     907      983841 :            cnt_sh(i) = min(cnt_sh(i),ktp)
     908      983841 :            cnb_sh(i) = max(cnb_sh(i),k)
     909             :         end if
     910             :       end do
     911             :     end do kloop
     912             : 
     913             :     !---------------------------------------------------
     914             :     ! apply final thermodynamic tendencies
     915             :     !---------------------------------------------------
     916             :     ! Set output q tendencies...
     917             :     ! ...for water vapor
     918    28436184 :     dq(:ncol,:,const_wv_idx) = cmfdq(:ncol,:)
     919             : 
     920             :     ! ...for other tracers from passive tracer transport
     921      281568 :     do m = 1, pcnst
     922      281568 :       if (m .ne. const_wv_idx) then
     923    56872368 :         dq(:ncol,:,m) = (dq(:ncol,:,m) - q(:ncol,:,m))/ztodt
     924             :       endif
     925             :     enddo
     926             : 
     927             :     ! Kludge to prevent cnb_sh-cnt_sh from being zero (in the event
     928             :     ! someone decides that they want to divide by this quantity)
     929     1090992 :     do i=1,ncol
     930     1090992 :        if (cnb_sh(i) /= 0 .and. cnb_sh(i) == cnt_sh(i)) then
     931      234347 :           cnt_sh(i) = cnt_sh(i) - 1
     932             :        end if
     933             :     end do
     934             : 
     935     1090992 :     do i=1,ncol
     936     1090992 :        precc(i) = prec(i)*rtdt
     937             :     end do
     938             : 
     939             :     ! Compute reserved liquid (not yet in cldliq) for energy integrals.
     940             :     ! Treat rliq_sh as flux out bottom, to be added back later.
     941     1900584 :     do k = 1, pver
     942    28436184 :        do i = 1, ncol
     943    28365792 :           rliq_sh(i) = rliq_sh(i) + qc_sh(i,k)*pdel(i,k)/grav
     944             :        end do
     945             :     end do
     946             : 
     947             :     ! rliq_sh is converted to precipitation units [m s-1]
     948     1090992 :     rliq_sh(:ncol) = rliq_sh(:ncol) / 1000._kind_phys
     949             : 
     950             :     ! Prepare boundary fluxes for check_energy [m s-1]
     951     1090992 :     flx_cnd(:ncol) = precc(:ncol) + rliq_sh(:ncol)
     952             : 
     953       70392 :     if(debug_verbose) then
     954             :       ! DEBUG DIAGNOSTICS - show final result
     955           0 :       do i=1,ncol
     956           0 :         if (i == 1) then
     957           0 :           fac = grav*864._kind_phys
     958           0 :           write(iulog, 8010)
     959           0 :           do k=limcnv,pver
     960           0 :             rh = shb(i,k)/shbs(i,k)
     961           0 :             write(iulog, 8020) shbh(i,k),sbh(i,k),hbh(i,k),fac*cmfmc_sh(i,k), &
     962           0 :                                cmfsl(i,k), cmflq(i,k)
     963           0 :             write(iulog, 8040) tb(i,k),shb(i,k),rh   ,sb(i,k),hb(i,k), &
     964           0 :                                hbs(i,k), ztodt*cmfdt(i,k),ztodt*cmfdq(i,k), &
     965           0 :                                ztodt*cmfdqr(i,k)
     966             :           end do
     967           0 :           write(iulog, 8000) prec(i)
     968             : 
     969             :           ! approximate vertical integral of moist static energy and
     970             :           ! total preciptable water after adjustment and output changes
     971           0 :           hsum2 = 0.0_kind_phys
     972           0 :           qsum2 = 0.0_kind_phys
     973           0 :           do k=limcnv,pver
     974           0 :             hsum2 = hsum2 + pdel(i,k)*rgrav*hb(i,k)
     975           0 :             qsum2 = qsum2 + pdel(i,k)*rgrav*shb(i,k)
     976             :           end do
     977           0 :           write(iulog,8070) hsum1, hsum2, abs(hsum2-hsum1)/hsum2, &
     978           0 :                             qsum1, qsum2, abs(qsum2-qsum1)/qsum2
     979             :         end if
     980             :       enddo
     981             :     endif
     982             : 
     983             :     ! Diagnostic use format strings
     984             : 8000              format(///,10x,'PREC = ',3pf12.6,/)
     985             : 8010              format('1**        TB      SHB      RH       SB', &
     986             :                         '       HB      HBS      CAH      CAM       PRECC ', &
     987             :                         '     ETA      FSL       FLQ     **', /)
     988             : 8020              format(' ----- ',     9x,3p,f7.3,2x,2p,     9x,-3p,f7.3,2x, &
     989             :                         f7.3, 37x, 0p,2x,f8.2,  0p,2x,f8.2,2x,f8.2, ' ----- ')
     990             : 8030              format(' ----- ',  0p,82x,f8.2,  0p,2x,f8.2,2x,f8.2, &
     991             :                          ' ----- ')
     992             : 8040              format(' - - - ',f7.3,2x,3p,f7.3,2x,2p,f7.3,2x,-3p,f7.3,2x, &
     993             :                         f7.3, 2x,f8.3,2x,0p,f7.3,3p,2x,f7.3,2x,f7.3,30x, &
     994             :                          ' - - - ')
     995             : 8050              format(' ----- ',110x,' ----- ')
     996             : 8060              format('1 K =>',  i4,/, &
     997             :                            '           TB      SHB      RH       SB', &
     998             :                            '       HB      HBS      CAH      CAM       PREC ', &
     999             :                            '     ETA      FSL       FLQ', /)
    1000             : 8070              format(' VERTICALLY INTEGRATED MOIST STATIC ENERGY BEFORE, AFTER', &
    1001             :                         ' AND PERCENTAGE DIFFERENCE => ',1p,2e15.7,2x,2p,f7.3,/, &
    1002             :                         ' VERTICALLY INTEGRATED MOISTURE            BEFORE, AFTER', &
    1003             :                         ' AND PERCENTAGE DIFFERENCE => ',1p,2e15.7,2x,2p,f7.3,/)
    1004             : 8080              format(' BETA, ETA => ', 1p,2e12.3)
    1005             : 8090              format (' k+1, sc, shc, hc => ', 1x, i2, 1p, 3e12.4)
    1006       70392 :   end subroutine hack_convect_shallow_run
    1007             : 
    1008             :   ! qhalf computes the specific humidity at interface levels between two model layers (interpolate moisture)
    1009    23412716 :   pure function qhalf(sh1,sh2,shbs1,shbs2) result(qh)
    1010             :     real(kind_phys), intent(in) :: sh1    ! humidity of layer 1 [kg kg-1]
    1011             :     real(kind_phys), intent(in) :: sh2    ! humidity of layer 2 [kg kg-1]
    1012             :     real(kind_phys), intent(in) :: shbs1  ! saturation specific humidity of layer 1 [kg kg-1]
    1013             :     real(kind_phys), intent(in) :: shbs2  ! saturation specific humidity of layer 2 [kg kg-1]
    1014             :     real(kind_phys) :: qh
    1015    23412716 :     qh = min(max(sh1,sh2),(shbs2*sh1 + shbs1*sh2)/(shbs1+shbs2))
    1016    23412716 :   end function qhalf
    1017             : end module hack_convect_shallow

Generated by: LCOV version 1.14