phys/module_cu_mskf.F

   1 !
   2 !ckay=Kiran Alapaty, EPA
   3 !CGM = Chris Marciano, NCSU
   4 !TWG = Tim Glotfelty, NCSU/EPA
   5 !JTR = Jacob Radford, NCSU
   6 !
   7 !multi-scale KF scheme
   8 !  (1) With diagnosed deep and shallow KF cloud fraction using
   9 !       CAM3-CAM5 methodology, along with captured liquid and ice condensates.
  10 !       and linking with the RRTMG & Other radiation schemes
  11 ! (2) Scale-dependent Dynamic adjustment timescale for KF clouds (both shallow
  12 !     and deep)
  13 ! (3) Scale-dependent LCL-based entrainment Methodology that avoids 2-km cloud
  14 !     radius method
  15 ! (4) Scale-dependent Fallout Rate
  16 ! (5) Scale-dependent Stabilization Capacity
  17 ! (6) Elimination of "double counting" when environment is saturated
  18 ! (7) Inclusion of Convective Momentum Transport (CMT):Zhang&McFarlane,JGR,100,1995
  19 !
  20 ! Alapaty et al., 2012: Introducing subgrid-scale cloud feedbacks to radiation
  21 !    for regional meteorological and climate modeling. GRL, V39, I24.
  22 !
  23 ! Alapaty et al., 2013:  The Kain-Fritsch Scheme: Science Updates and revisiting
  24 !     gray-scale issues from the NWP and regional climate perspectives. 2013 WRF
  25 !     workshop: URL:
  26 !     http://www.mmm.ucar.edu/wrf/users/workshops/WS2013/ppts/9.2.pdf
  27 !
  28 ! Herwehe et al., 2014: Increasing the credibility of regional climate
  29 !     simulations by introducing subgrid-scale cloud-radiation interactions. JGR, 119,
  30 !     5317-5330, doi:10.1002/2014JD021504.
  31 !
  32 ! Zheng et al., 2016: Improving High-Resolution Weather Forecasts using the
  33 !     Weather Research and Forecasting (WRF) Model with an Updated Kain-Fritsch
  34 !     Scheme. Mon. Wea. Rev., 144, 833-860
  35 !
  36 ! He, J., and K. Alapaty, 2018:  Precipitation partitioning in multiscale
  37 !     atmospheric simulations: Impacts of stability restoration methods. Journal of
  38 !     Geophysical Research: Atmospheres, 123. https://doi.org/10.1029/2018JD028710
  39 !
  40 ! Glotfelty, T., K. Alapaty, J. He, P. Hawbecker, X. Song, and G. Zhang, 2019:
  41 !     The Weather Research and Forecasting Model with Aerosol Cloud Interactions
  42 !     (WRF-ACI): Development, Evaluation, and Initial Application. Mon. Wea.
  43 !     Rev., 147, 1491-1511
  44 !................................................................
  45
  46 ! begin double moment convective microphysics for MSKF
  47
  48  module module_cu_mp
  49
  50 !module  mskf_microphysics
  51 ! Adapted to WRF3.8 by Kiran Alapaty
  52 !  !ckay = !dkay = Kiran Alapaty, EPA
  53 ! PSH : Sep 2015: copuled with CESM global climatological aerosol data
  54 ! TWG : Jun 2016: porting to WRFV3.8
  55 ! TWG & cKAY: Feb 2017: replaced sheet cloud microphysics with that of cumulus clouds
  56
  57 ! Purpose:
  58 !!!!#define WRF_PORT
  59 !   CAM Interface for cumulus microphysics
  60 !
  61 ! Initial Authors: Xiaoliang Song and Guang Jun Zhang, June 2010
  62 ! MSKF adaptation authors: Kiran Alapaty, Tim Glotfelty, and Patrick Hawbecker
  63 !
  64 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  65 ! Adapted to MSKF scheme: Kiran Alapaty at EPA March 2013 (WRF version)
  66 !
  67 !---------------------------------------------------------------------------------
  68   use shr_kind_mod,  only: r8=>shr_kind_r8
  69
  70   use error_function, only: erf,erfc
  71
  72 !wrf  use rad_constituents, only: rad_cnst_get_clim_info,
  73 !rad_cnst_get_clim_aer_props
  74 !xsong 2013-08-22  use module_ra_cam_support, only: naer_cu, idxsul,
  75 !idxDUSTfirst, idxbcphi
  76
  77   implicit none
  78   private
  79 ! save
  80
  81   public :: mskf_mphyi, mskf_mphy, mskf_GAMMA, mskf_polysvp
  82
  83 ! Private module data
  84
  85   integer, parameter :: naer_cu = 10
  86   integer, parameter :: pcols = 1
  87
  88 !constants remaped
  89   real(r8), private::  g              !gravity
  90   real(r8), private::  mw             !molecular weight of water
  91   real(r8), private::   r        !Dry air Gas constant
  92   real(r8), private::   rv       !water vapor gas contstant
  93   real(r8), private::   rr   !universal gas constant
  94   real(r8), private::   cpp                  !specific heat of dry air
  95   real(r8), private::   rhow               !density of liquid water
  96   real(r8), private::  xlf !latent heat of freezing
  97
  98 !from physconst
  99   real(r8), private, parameter ::  gravit = 9.80616_r8      ! acceleration of gravity ~ m/s^2
 100   real(r8), private, parameter ::  rair   = 287.04239_r8    ! Dry air gas constant     ~ J/K/kg
 101   real(r8), private, parameter ::  tmelt  = 273.15_r8       ! freezing T of fresh water  ~ K
 102   real(r8), private, parameter ::  cpair  = 1.00464e3_r8    ! specific heat of dry air   ~ J/kg/K
 103   real(r8), private, parameter ::  rh2o   = 461.915_r8      ! Water vapor gas constant ~ J/K/kg
 104   real(r8), private, parameter ::  r_universal = 8.31447e3_r8  ! Universal gas constant ~ J/K/kmole
 105   real(r8), private, parameter ::  mwh2o  = 18._r8          ! molecular weight h2o
 106   real(r8), private, parameter ::  rhoh2o = 1.000e3_R8      ! density of fresh water     ~ kg/m^3
 107   real(r8), private, parameter ::  latvap = 2.501e6_r8      ! latent heat of evaporation ~ J/kg
 108   real(r8), private, parameter ::  latice = 3.337e5_r8      ! latent heat of fusion      ~ J/kg
 109   real(r8), private, parameter ::  epsilo = 0.622_r8        ! ratio of h2o to dry air molecular weights
 110
 111 !from 'microconstants'
 112   real(r8), private:: rhosn  ! bulk density snow
 113   real(r8), private:: rhoi   ! bulk density ice
 114
 115   real(r8), private:: ac,bc,as,bs,ai,bi,ar,br  !fall speed parameters
 116   real(r8), private:: ci,di    !ice mass-diameter relation parameters
 117   real(r8), private:: cs,ds    !snow mass-diameter relation parameters
 118   real(r8), private:: cr,dr    !drop mass-diameter relation parameters
 119   real(r8), private:: Eii      !collection efficiency aggregation of ice
 120   real(r8), private:: Ecc      !collection efficiency
 121   real(r8), private:: Ecr      !collection efficiency cloud droplets/rain
 122   real(r8), private:: DCS      !autoconversion size threshold
 123   real(r8), private:: F14      !Ferrier (1994) Time scale parameter
 124   real(r8), private:: qsmall   !min mixing ratio
 125   real(r8), private:: bimm,aimm !immersion freezing
 126   real(r8), private:: rhosu     !typical 850mn air density
 127   real(r8), private:: mi0       ! new crystal mass
 128   real(r8), private:: rin       ! radius of contact nuclei
 129   real(r8), private:: pi       ! pi
 130
 131   real(r8), private:: rn_dst1, rn_dst2, rn_dst3, rn_dst4  !dust number mean radius for contact freezing
 132 !..........................................................................
 133
 134 !needed for findsp
 135 real(r8), private:: t0       ! Freezing temperature
 136
 137 ! activate parameters
 138
 139       integer, private:: psat
 140       parameter (psat=6) ! number of supersaturations to calc ccn concentration
 141       real(r8), private:: aten
 142 !
 143       real(r8), private:: alogsig(naer_cu) ! natl log of geometric standard dev of aerosol
 144       real(r8), private:: exp45logsig(naer_cu)
 145       real(r8), private:: argfactor(naer_cu)
 146       real(r8), private:: amcube(naer_cu) ! cube of dry mode radius (m)
 147       real(r8), private:: smcrit(naer_cu) ! critical supersatuation for activation
 148       real(r8), private:: lnsm(naer_cu) ! ln(smcrit)
 149       real(r8), private:: amcubesulfate(pcols) ! cube of dry mode radius (m) of sulfate
 150       real(r8), private:: smcritsulfate(pcols) ! critical supersatuation for activation of sulfate
 151       real(r8), private:: amcubefactor(naer_cu) ! factors for calculating mode radius
 152       real(r8), private:: smcritfactor(naer_cu) ! factors for calculating critical supersaturation
 153       real(r8), private:: super(psat)
 154       real(r8), private:: alogten,alog2,alog3,alogaten
 155       real(r8), private, parameter :: supersat(psat)= &! supersaturation (%) to determine ccn concentration
 156                (/0.02,0.05,0.1,0.2,0.5,1.0/)
 157       real(r8), private:: ccnfact(psat,naer_cu)
 158
 159       real(r8), private:: f1(naer_cu),f2(naer_cu) ! abdul-razzak functions of width
 160       real(r8), private:: third, sixth,zero
 161       real(r8), private:: sq2, sqpi
 162
 163
 164 !wrf      integer :: naer_all    ! number of aerosols affecting climate
 165 !xsong 2013-08-22---------------
 166       integer :: idxsul = 1 ! index in aerosol list for sulfate
 167       integer :: idxdst1 = 3 ! index in aerosol list for dust1
 168       integer :: idxdst2 = 4 ! index in aerosol list for dust2
 169       integer :: idxdst3 = 5 ! index in aerosol list for dust3
 170       integer :: idxdst4 = 6 ! index in aerosol list for dust4
 171       integer :: idxbcphi = 10 ! index in aerosol list for Soot (BCPHI)
 172 !xsong 2013-08-22---------------
 173       ! aerosol properties
 174       character(len=20)  aername(naer_cu)
 175       real(r8) dryrad_aer(naer_cu)
 176       real(r8) density_aer(naer_cu)
 177       real(r8) hygro_aer(naer_cu)
 178       real(r8) dispersion_aer(naer_cu)
 179       real(r8) num_to_mass_aer(naer_cu)
 180
 181 !xsong 2013-08-22--------------------
 182    data aername /"SULFATE","SEASALT2","DUST1","DUST2","DUST3","DUST4","OCPHO","BCPHO",   &
 183                  "OCPHI","BCPHI"/
 184    data dryrad_aer /0.695E-7_r8,0.200E-5_r8,0.151E-5_r8,0.151E-5_r8,0.151E-5_r8,0.151E-5_r8,     &
 185                     0.212E-7_r8,0.118E-7_r8,0.212E-7_r8, 0.118E-7_r8/
 186    data density_aer /1770._r8,2200._r8,2600._r8,2600._r8,2600._r8,2600._r8,1800._r8,  &
 187                      1000._r8,2600._r8,1000._r8/
 188    data hygro_aer /0.507_r8,1.160_r8,0.140_r8,0.140_r8,0.140_r8,0.140_r8,0.100_r8,0.100_r8,  &
 189                    0.140_r8,0.100_r8/
 190    data dispersion_aer /2.030_r8,1.3732_r8,1.900_r8,1.900_r8,1.900_r8,1.900_r8,2.240_r8,  &
 191                         2.000_r8,2.240_r8,2.000_r8/
 192    data num_to_mass_aer /42097098109277080._r8,8626504211623._r8,3484000000000000._r8,213800000000000._r8,&
 193                          22050000000000._r8,3165000000000._r8,0.745645E+18_r8,0.167226E+20_r8,&
 194                          0.516216E+18_r8,0.167226E+20_r8/
 195 !xsong 2013-08-22-----------------------
 196
 197
 198 contains
 199
 200 !===============================================================================
 201
 202 subroutine mskf_mphyi
 203
 204 !-----------------------------------------------------------------------
 205 !
 206 ! Purpose:
 207 ! initialize constants for the cumulus microphysics
 208 ! called from zm_conv_init() in zm_conv_intr.F90
 209 !
 210 ! Author: Xiaoliang Song, June 2010
 211 !
 212 !-----------------------------------------------------------------------
 213
 214 !     save    ! sep6
 215 !wrf   use pmgrid, only: plev, plevp
 216       integer k
 217
 218       integer l,m, iaer
 219       real(r8) surften       ! surface tension of water w/respect to air (N/m)
 220 !      real(r8) arg
 221
 222 ! hm modify to use my error function
 223
 224
 225 !declarations for morrison codes (transforms variable names)
 226
 227 !   g= gravit                  !gravity
 228 !   mw = mwh2o / 1000._r8      !molecular weight of water
 229 !   r= rair                   !Dry air Gas constant: note units(phys_constants
 230 !   are in J/K/kmol)
 231 !   rv= rh2o                   !water vapor gas contstant
 232 !   rr = r_universal           !universal gas constant
 233 !   cpp = cpair                 !specific heat of dry air
 234 !   rhow = rhoh2o              !density of liquid water
 235
 236 !NOTE:
 237 ! latent heats should probably be fixed with temperature
 238 ! for energy conservation with the rest of the model
 239 ! (this looks like a +/- 3 or 4% effect, but will mess up energy balance)
 240
 241    xlf = latice          ! latent heat freezing
 242
 243
 244 ! from microconstants
 245
 246 ! parameters below from Reisner et al. (1998)
 247 ! density parameters (kg/m3)
 248
 249       rhosn = 100._r8    ! bulk density snow
 250       rhoi = 500._r8     ! bulk density ice
 251       rhow = 1000._r8    ! bulk density liquid
 252
 253 ! fall speed parameters, V = aD^b
 254 ! V is in m/s
 255
 256 ! droplets
 257         ac = 3.e7_r8
 258         bc = 2._r8
 259
 260 ! snow
 261         as = 11.72_r8
 262         bs = 0.41_r8
 263
 264 ! cloud ice
 265         ai = 700._r8
 266         bi = 1._r8
 267
 268 ! rain
 269         ar = 841.99667_r8
 270         br = 0.8_r8
 271
 272 ! particle mass-diameter relationship
 273 ! currently we assume spherical particles for cloud ice/snow
 274 ! m = cD^d
 275
 276         pi= 3.1415927_r8
 277
 278 ! cloud ice mass-diameter relationship
 279
 280         ci = rhoi*pi/6._r8
 281         di = 3._r8
 282
 283 ! snow mass-diameter relationship
 284
 285         cs = rhosn*pi/6._r8
 286         ds = 3._r8
 287
 288 ! drop mass-diameter relationship
 289
 290         cr = rhow*pi/6._r8
 291         dr = 3._r8
 292
 293 ! collection efficiency, aggregation of cloud ice and snow
 294
 295         Eii = 0.1_r8
 296
 297 ! collection efficiency, accretion of cloud water by rain
 298
 299         Ecr = 1.0_r8
 300
 301 ! autoconversion size threshold for cloud ice to snow (m)
 302
 303 !          Dcs = 100.e-6_r8
 304         Dcs = 200.e-6_r8
 305
 306 ! Ferrier [1994] time period parameter ! TWG Feb17
 307          F14 = 100.0 !180.0 Original
 308
 309
 310 ! smallest mixing ratio considered in microphysics
 311
 312         qsmall = 1.e-28_r8 !Shaocai   !1.e-18_r8
 313
 314 ! immersion freezing parameters, bigg 1953
 315
 316         bimm = 100._r8
 317         aimm = 0.66_r8
 318
 319 ! contact freezing due to dust
 320 ! dust number mean radius (m), Zender et al JGR 2003 assuming number mode radius
 321 ! of 0.6 micron, sigma=2
 322
 323         rn_dst1=0.258e-6_r8
 324         rn_dst2=0.717e-6_r8
 325         rn_dst3=1.576e-6_r8
 326         rn_dst4=3.026e-6_r8
 327
 328 ! typical air density at 850 mb
 329
 330         rhosu = 85000._r8/(rair * tmelt)
 331
 332 ! mass of new crystal due to aerosol freezing and growth (kg)
 333
 334         mi0 = 4._r8/3._r8*pi*rhoi*(10.e-6_r8)*(10.e-6_r8)*(10.e-6_r8)
 335
 336 ! radius of contact nuclei aerosol (m)
 337
 338         rin = 0.1e-6_r8
 339
 340 ! freezing temperature
 341         t0=273.15_r8
 342
 343 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 344
 345 ! set parameters for droplet activation, following abdul-razzak and ghan 2000,
 346 ! JGR
 347
 348 !      mathematical constants
 349
 350       zero=0._r8
 351       third=1./3._r8
 352       sixth=1./6._r8
 353       sq2=sqrt(2._r8)
 354       pi=4._r8*atan(1.0_r8)
 355       sqpi=sqrt(pi)
 356
 357       surften=0.076_r8
 358       aten=2.*mwh2o*surften/(r_universal*t0*rhoh2o)
 359       alogaten=log(aten)
 360       alog2=log(2._r8)
 361       alog3=log(3._r8)
 362       super(:)=0.01*supersat(:)
 363
 364       do m=1,naer_cu
 365 !         use only if width of size distribution is prescribed
 366           alogsig(m)=log(dispersion_aer(m))
 367           exp45logsig(m)=exp(4.5*alogsig(m)*alogsig(m))
 368           argfactor(m)=2./(3.*sqrt(2.)*alogsig(m))
 369           f1(m)=0.5*exp(2.5*alogsig(m)*alogsig(m))
 370           f2(m)=1.+0.25*alogsig(m)
 371           amcubefactor(m)=3._r8/(4._r8*pi*exp45logsig(m)*density_aer(m))
 372           smcritfactor(m)=2._r8*aten*sqrt(aten/(27._r8*max(1.e-10_r8,hygro_aer(m))))
 373 !         use only if mode radius of size distribution is prescribed
 374           amcube(m)=amcubefactor(m)/(num_to_mass_aer(m))
 375 !         use only if only one component per mode
 376           if(hygro_aer(m).gt.1.e-10) then
 377              smcrit(m)=smcritfactor(m)/sqrt(amcube(m))
 378           else
 379              smcrit(m)=100.
 380           endif
 381           lnsm(m)=log(smcrit(m))
 382
 383       end do
 384
 385    return
 386  end subroutine mskf_mphyi
 387
 388 !===============================================================================
 389
 390 subroutine mskf_mphy(su,    qu,   mu,   du,   cmel, cmei, zf,  pm,  te,   qe, eps0,    &
 391                    jb,    jt,   jlcl, msg,  il2g, grav, cp,  rd,  qc,   qi, qr, qni, & ! TWG
 392                     rprd,  wu,    eu,   nc,   ni, nr, ns, dum2l, sprd, frz, aer_mmr, deltat, & !TWG
 393                    Pver,PverP,gamhat,qsatzm,wu_mskf_act,qc_mskf_act,qi_mskf_act,effc,effi,effs)
 394
 395 ! Purpose:
 396 ! microphysic parameterization for Zhang-McFarlane convection scheme
 397 ! called from cldprp() in zm_conv.F90
 398 !
 399 ! Author: Xiaoliang Song, June 2010
 400 !
 401 ! Adaptation: Kiran Alapaty at EPA 2013 for MSKF convection scheme in WRF
 402
 403 !wrf  use time_manager,    only: get_nstep, get_step_size
 404
 405 ! variable declarations
 406
 407   implicit none
 408
 409 ! input variables
 410
 411   integer, parameter :: naer_cu = 10
 412   integer, parameter :: pcols = 1
 413
 414   integer :: pver                  ! number of vertical levels(mid-layer)
 415   integer :: pverp                 ! number of vertical levels(interface)
 416   real(r8) :: su(pcols,pver)        ! normalized dry stat energy of updraft
 417   real(r8) :: qu(pcols,pver)        ! spec hum of updraft
 418   real(r8) :: mu(pcols,pver)        ! updraft mass flux
 419   real(r8) :: du(pcols,pver)        ! detrainement rate of updraft
 420   real(r8) :: cmel(pcols,pver)      ! condensation rate of updraft
 421   real(r8) :: cmei(pcols,pver)      ! condensation rate of updraft
 422   real(r8) :: zf(pcols,pverp)       ! height of interfaces
 423   real(r8) :: pm(pcols,pver)        ! pressure of env
 424   real(r8) :: te(pcols,pver)        ! temp of env
 425   real(r8) :: qe(pcols,pver)        ! spec. humidity of env
 426   real(r8) :: eps0(pcols)
 427   real(r8) :: eu(pcols,pver)        ! entrainment rate of updraft
 428 !ckay  real(r8) :: aer_mmr(:,:,:)        ! aerosol mass mixing ratio
 429   real(r8) :: aer_mmr(Pcols,Pver,naer_cu)        ! aerosol mass mixing ratio
 430 !  real(r8) :: gamhat(pcols,pver)    ! kf_GAMMA=L/cp(dq*/dT) at interface
 431 !ckay
 432   real(r8) :: qsatzm(pcols,pver)        ! spec hum of updraft
 433   real(r8) :: wu_mskf_act(pver)        ! KF incloud updraft velocity
 434   real(r8) :: qc_mskf_act(pver)        ! KF incloud updraft velocity
 435   real(r8) :: qi_mskf_act(pver)        ! KF incloud updraft velocity
 436
 437   integer :: jb(pcols)              ! updraft base level
 438   integer :: jt(pcols)              ! updraft plume top
 439   integer :: jlcl(pcols)            ! updraft lifting cond level
 440   integer :: msg                    ! missing moisture vals
 441   integer :: il2g                   ! CORE GROUP REMOVE
 442
 443   real(r8) grav                                 ! gravity
 444   real(r8) cp                                   ! heat capacity of dry air
 445   real(r8) rd                                   ! gas constant for dry air
 446
 447 ! output variables
 448 !ckay
 449   real(r8) qc(pcols,pver)       ! cloud water mixing ratio (kg/kg)
 450   real(r8) qi(pcols,pver)       ! cloud ice mixing ratio (kg/kg)
 451   real(r8) nc(pcols,pver)       ! cloud water number conc (1/kg)
 452   real(r8) ni(pcols,pver)       ! cloud ice number conc (1/kg)
 453   real(r8)  qni(pcols,pver)      ! snow mixing ratio
 454   real(r8)  qr(pcols,pver)       ! rain mixing ratio
 455   real(r8)  ns(pcols,pver)       ! snow number conc
 456   real(r8)  nr(pcols,pver)       ! rain number conc
 457   real(r8) rprd(pcols,pver)     ! rate of production of precip at that layer
 458 !ckay  real(r8), intent(out) :: rprd(pcols,pver)     ! rate of production of
 459 !precip at that layer
 460   real(r8) sprd(pcols,pver)     ! rate of production of snow at that layer
 461   real(r8) frz(pcols,pver)      ! rate of freezing
 462
 463 ! tendency for output
 464
 465   real(r8) :: autolm(pcols,pver)    !mass tendency due to autoconversion of droplets to rain
 466   real(r8) :: accrlm(pcols,pver)    !mass tendency due to accretion of droplets by rain
 467   real(r8) :: bergnm(pcols,pver)    !mass tendency due to Bergeron process
 468   real(r8) :: fhtimm(pcols,pver)    !mass tendency due to immersion freezing
 469   real(r8) :: fhtctm(pcols,pver)    !mass tendency due to contact freezing
 470   real(r8) :: fhmlm (pcols,pver)    !mass tendency due to homogeneous freezing
 471   real(r8) :: hmpim (pcols,pver)    !mass tendency due to HM process
 472   real(r8) :: accslm(pcols,pver)    !mass tendency due to accretion of droplets by snow
 473   real(r8) :: dlfm  (pcols,pver)    !mass tendency due to detrainment of droplet
 474   real(r8) :: autoln(pcols,pver)    !num tendency due to autoconversion of droplets to rain
 475   real(r8) :: accrln(pcols,pver)    !num tendency due to accretion of droplets by rain
 476   real(r8) :: bergnn(pcols,pver)    !num tendency due to Bergeron process
 477   real(r8) :: fhtimn(pcols,pver)    !num tendency due to immersion freezing
 478   real(r8) :: fhtctn(pcols,pver)    !num tendency due to contact freezing
 479   real(r8) :: fhmln (pcols,pver)    !num tendency due to homogeneous freezing
 480   real(r8) :: accsln(pcols,pver)    !num tendency due to accretion of droplets by snow
 481   real(r8) :: activn(pcols,pver)    !num tendency due to droplets activation
 482   real(r8) :: dlfn  (pcols,pver)    !num tendency due to detrainment of droplet
 483   real(r8) :: autoim(pcols,pver)    !mass tendency due to autoconversion of cloud ice to snow
 484   real(r8) :: accsim(pcols,pver)    !mass tendency due to accretion of cloud ice by snow
 485   real(r8) :: difm  (pcols,pver)    !mass tendency due to detrainment of cloud ice
 486   real(r8) :: nuclin(pcols,pver)    !num tendency due to ice nucleation
 487   real(r8) :: nuclim(pcols,pver)    !mass tendency due to ice nucleation
 488   real(r8) :: collrm(pcols,pver)    !mass tendency due to rain-ice collection
 489   real(r8) :: collrn(pcols,pver)    !number tendency due to rain-ce collection
 490   real(r8) :: fhtcrm(pcols,pver)    !mass tendency due to rain freezing to snow
 491   real(r8) :: fhtcrn(pcols,pver)    !num tendency due to rain freezing to snow
 492   real(r8) :: autorn(pcols,pver)    !num tendency for autoconversion of clouds to rain (rain term)
 493   real(r8) :: aggrn(pcols,pver)     !num tendency for self collection of rain
 494   real(r8) :: aggsn(pcols,pver)     !num tendency for self collection of snow
 495   real(r8) :: autoin(pcols,pver)    !num tendency due to autoconversion of cloud ice to snow
 496   real(r8) :: accsin(pcols,pver)    !num tendency due to accretion of cloud ice by snow
 497   real(r8) :: hmpin (pcols,pver)    !num tendency due to HM process
 498   real(r8) :: difn  (pcols,pver)    !num tendency due to detrainment of cloud ice
 499   real(r8) :: trspcm(pcols,pver)    !LWC tendency due to convective transport
 500   real(r8) :: trspcn(pcols,pver)    !droplet num tendency due to convective transport
 501   real(r8) :: trspim(pcols,pver)    !IWC tendency due to convective transport
 502   real(r8) :: trspin(pcols,pver)    !ice crystal num tendency due to convective transport
 503
 504   real(r8) :: ncadj(pcols,pver)     !droplet num tendency due to adjustment
 505   real(r8) :: niadj(pcols,pver)     !ice crystal num tendency due to adjustment
 506   real(r8) :: qcadj(pcols,pver)     !droplet mass tendency due to adjustment
 507   real(r8) :: qiadj(pcols,pver)     !ice crystal mass tendency due to adjustment
 508
 509 ! output for ice nucleation
 510   real(r8) :: nimey(pcols,pver)     !output number conc of ice nuclei due to meyers deposition (1/m3)
 511   real(r8) :: nihf(pcols,pver)      !output number conc of ice nuclei due to heterogenous freezing (1/m3)
 512   real(r8) :: nidep(pcols,pver)     !output number conc of ice nuclei due to deoposion nucleation (hetero nuc) (1/m3)
 513   real(r8) :: niimm(pcols,pver)     !output number conc of ice nuclei due to immersion freezing (hetero nuc) (1/m3)
 514   real(r8) :: effc(pcols,pver)    ! droplet effective radius (micron)
 515   real(r8) :: effi(pcols,pver)    ! cloud ice effective radius (micron)
 516   real(r8) :: effs(pcols,pver)    ! snow effective radius (micron)
 517
 518 !................................................................................
 519 ! local workspace
 520 ! all units mks unless otherwise stated
 521   real(r8) :: deltat                ! time step (s)
 522   real(r8) :: omsm                  ! number near unity for round-off issues
 523   real(r8) :: dum                   ! temporary dummy variable
 524   real(r8) :: arg                   ! argument of erfc
 525   real(r8) :: dum1                  ! temporary dummy variable
 526   real(r8) :: dum2                  ! temporary dummy variable
 527
 528   real(r8) :: q(pcols,pver)         ! water vapor mixing ratio (kg/kg)
 529   real(r8) :: t(pcols,pver)         ! temperature (K)
 530   real(r8) :: rho(pcols,pver)       ! air density (kg m-3)
 531   real(r8) :: dz(pcols,pver)        ! height difference across model verticallevel
 532
 533   real(r8) :: qcic(pcols,pver)      ! in-cloud cloud liquid mixing ratio
 534   real(r8) :: qiic(pcols,pver)      ! in-cloud cloud ice mixing ratio
 535 !dkay
 536   real (r8) :: tot_qc_qi
 537   real(r8) :: qniic(pcols,pver)     ! in-precip snow mixing ratio
 538   real(r8) :: qric(pcols,pver)      ! in-precip rain mixing ratio
 539   real(r8) :: ncic(pcols,pver)      ! in-cloud droplet number conc
 540   real(r8) :: niic(pcols,pver)      ! in-cloud cloud ice number conc
 541   real(r8) :: nsic(pcols,pver)      ! in-precip snow number conc
 542   real(r8) :: nric(pcols,pver)      ! in-precip rain number conc
 543
 544   real(r8) :: lami(pver)            ! slope of cloud ice size distr
 545   real(r8) :: n0i(pver)             ! intercept of cloud ice size distr
 546   real(r8) :: lamc(pver)            ! slope of cloud liquid size distr
 547   real(r8) :: n0c(pver)             ! intercept of cloud liquid size distr
 548   real(r8) :: lams(pver)            ! slope of snow size distr
 549   real(r8) :: n0s(pver)             ! intercept of snow size distr
 550   real(r8) :: lamr(pver)            ! slope of rain size distr
 551   real(r8) :: n0r(pver)             ! intercept of rain size distr
 552   real(r8) :: cdist1(pver)          ! size distr parameter to calculate droplet freezing
 553   real(r8) :: pgam(pver)            ! spectral width parameter of droplet size distr
 554   real(r8) :: lammax                ! maximum allowed slope of size distr
 555   real(r8) :: lammin                ! minimum allowed slope of size distr
 556
 557   real(r8) :: mnuccc(pver)          ! mixing ratio tendency due to freezing of cloud water
 558   real(r8) :: nnuccc(pver)          ! number conc tendency due to freezing of cloud water
 559   real(r8) :: mnucct(pver)          ! mixing ratio tendency due to contact freezing of cloud water
 560   real(r8) :: nnucct(pver)          ! number conc tendency due to contact freezing of cloud water
 561   real(r8) :: msacwi(pver)          ! mixing ratio tendency due to HM ice multiplication
 562   real(r8) :: nsacwi(pver)          ! number conc tendency due to HM ice multiplication
 563   real(r8) :: prf(pver)             ! mixing ratio tendency due to fallout of rain
 564   real(r8) :: psf(pver)             ! mixing ratio tendency due to fallout of snow
 565   real(r8) :: pnrf(pver)            ! number conc tendency due to fallout of rain
 566   real(r8) :: pnsf(pver)            ! number conc tendency due to fallout of snow
 567   real(r8) :: prc(pver)             ! mixing ratio tendency due to autoconversion of cloud droplets
 568   real(r8) :: nprc(pver)            ! number conc tendency due to autoconversion of cloud droplets
 569   real(r8) :: nprc1(pver)           ! qr tendency due to autoconversion of cloud droplets
 570   real(r8) :: nsagg(pver)           ! ns tendency due to self-aggregation of snow
 571   real(r8) :: dc0                   ! mean size droplet size distr
 572   real(r8) :: ds0                   ! mean size snow size distr (area weighted)
 573   real(r8) :: eci                   ! collection efficiency for riming of snow by droplets
 574   real(r8) :: dv(pcols,pver)        ! diffusivity of water vapor in air
 575   real(r8) :: mua(pcols,pver)       ! viscocity of air
 576   real(r8) :: psacws(pver)          ! mixing rat tendency due to collection of droplets by snow
 577   real(r8) :: npsacws(pver)         ! number conc tendency due to collection of droplets by snow
 578   real(r8) :: pracs(pver)           ! mixing rat tendency due to collection of rain by snow
 579   real(r8) :: npracs(pver)          ! number conc tendency due to collection of rain by snow
 580   real(r8) :: mnuccr(pver)          ! mixing rat tendency due to freezing of rain
 581   real(r8) :: nnuccr(pver)          ! number conc tendency due to freezing of rain
 582   real(r8) :: pra(pver)             ! mixing rat tendnency due to accretion of droplets by rain
 583   real(r8) :: npra(pver)            ! nc tendnency due to accretion of droplets by rain
 584   real(r8) :: nragg(pver)           ! nr tendency due to self-collection of rain
 585   real(r8) :: prci(pver)            ! mixing rat tendency due to autoconversion of cloud ice to snow
 586   real(r8) :: nprci(pver)           ! number conc tendency due to autoconversion of cloud ice to snow
 587   real(r8) :: prai(pver)            ! mixing rat tendency due to accretion of cloud ice by snow
 588   real(r8) :: nprai(pver)           ! number conc tendency due to accretion of cloud ice by snow
 589   real(r8) :: prb(pver)             ! rain mixing rat tendency due to Bergeron process
 590   real(r8) :: nprb(pver)            ! number conc tendency due to Bergeron process
 591
 592
 593 ! fall speed
 594   real(r8) :: arn(pcols,pver)       ! air density corrected rain fallspeed
 595   real(r8) :: asn(pcols,pver)       ! air density corrected snow fallspeed
 596   real(r8) :: acn(pcols,pver)       ! air density corrected cloud droplet fallspeed parameter
 597   real(r8) :: ain(pcols,pver)       ! air density corrected cloud ice fallspeed
 598   real(r8) :: uns(pver)             ! number-weighted snow fallspeed
 599   real(r8) :: ums(pver)             ! mass-weighted snow fallspeed
 600   real(r8) :: unr(pver)             ! number-weighted rain fallspeed
 601   real(r8) :: umr(pver)             ! mass-weighted rain fallspeed
 602
 603 ! conservation check
 604   real(r8) :: qce                   ! dummy qc for conservation check
 605   real(r8) :: qie                   ! dummy qi for conservation check
 606   real(r8) :: nce                   ! dummy nc for conservation check
 607   real(r8) :: nie                   ! dummy ni for conservation check
 608   real(r8) :: qre                   ! dummy qr for conservation check
 609   real(r8) :: nre                   ! dummy nr for conservation check
 610   real(r8) :: qnie                  ! dummy qni for conservation check
 611   real(r8) :: nse                   ! dummy ns for conservation check
 612   real(r8) :: ratio                 ! parameter for conservation check
 613
 614 ! sum of source/sink terms for cloud hydrometeor
 615   real(r8) :: qctend(pcols,pver)    ! microphysical tendency qc (1/s)
 616   real(r8) :: qitend(pcols,pver)    ! microphysical tendency qi (1/s)
 617   real(r8) :: nctend(pcols,pver)    ! microphysical tendency nc (1/(kg*s))
 618   real(r8) :: nitend(pcols,pver)    ! microphysical tendency ni (1/(kg*s))
 619   real(r8) :: qnitend(pcols,pver)   ! snow mixing ratio source/sink term
 620   real(r8) :: nstend(pcols,pver)    ! snow number concentration source/sink term
 621   real(r8) :: qrtend(pcols,pver)    ! rain mixing ratio source/sink term
 622   real(r8) :: nrtend(pcols,pver)    ! rain number concentration source/sink term
 623
 624 ! terms for Bergeron process
 625   real(r8) :: bergtsf               !bergeron timescale to remove all liquid
 626   real(r8) :: plevap                ! cloud liquid water evaporation rate
 627
 628 ! aerosol variables
 629   real(r8) :: naermod(naer_cu)      ! aerosol number concentration (/m3)
 630   real(r8) :: naer2(pcols,pver,naer_cu)    ! new aerosol number concentration (/m3)
 631   real(r8) :: naer2h(pcols,pver,naer_cu)   ! new aerosol number concentration (/m3)
 632   real(r8) :: maerosol(1,naer_cu)   ! aerosol mass conc (kg/m3)
 633   real(r8) naer(pcols)
 634
 635 ! droplet activation
 636   real(r8) :: dum2l(pcols,pver)     ! number conc of CCN (1/kg)
 637   real(r8) :: npccn(pver)           ! droplet activation rate
 638   real(r8) :: ncmax
 639   real(r8) :: mtimec                ! factor to account for droplet activation timescale
 640
 641 ! ice nucleation
 642   real(r8) :: dum2i(pcols,pver)     ! number conc of ice nuclei available (1/kg)
 643   real(r8) :: qs(pcols,pver)        ! liquid-ice weighted sat mixing rat (kg/kg)
 644   real(r8) :: es(pcols,pver)        ! sat vapor press (pa) over water
 645   real(r8) :: relhum(pcols,pver)    ! relative humidity
 646   real(r8) :: esi(pcols,pver)       ! sat vapor press (pa) over ice
 647   real(r8) :: nnuccd(pver)          ! ice nucleation rate from deposition/cond.-freezing
 648   real(r8) :: mnuccd(pver)          ! mass tendency from ice nucleation
 649   real(r8) :: nimax
 650   real(r8) :: mtime                 ! factor to account for ice nucleation timescale
 651   real(r8) :: gamhat(pcols,pver)    ! kf_GAMMA=L/cp(dq*/dT) at interface
 652
 653
 654 ! loop array variables
 655   integer i,k,nstep,n, l
 656   integer ii,kk, m
 657
 658 ! loop variables for iteration solution
 659   integer iter,it,ltrue(pcols)
 660
 661 ! used in contact freezing via dust particles
 662   real(r8)  tcnt, viscosity, mfp
 663   real(r8)  slip1, slip2, slip3, slip4
 664   real(r8)  dfaer1, dfaer2, dfaer3, dfaer4
 665   real(r8)  nacon1,nacon2,nacon3,nacon4
 666
 667 ! used in immersion freezing via soot
 668   real(r8) ttend(pver)
 669   real(r8) naimm
 670   real(r8) :: ntaer(pcols,pver)
 671   real(r8) :: ntaerh(pcols,pver)
 672
 673 ! used in secondary ice production
 674   real(r8) ni_secp
 675
 676 ! used in vertical velocity calculation
 677   real(r8) th(pcols,pver)
 678   real(r8) qh(pcols,pver)
 679   real(r8) wu(pcols,pver)
 680   real(r8) zkine(pcols,pver)
 681   real(r8) zbuo(pcols,pver)
 682   real(r8) zfacbuo, cwdrag, cwifrac, retv,  zbuoc
 683   real(r8) zbc, zbe,  zdkbuo, zdken
 684   real(r8) arcf(pcols,pver)
 685   real(r8) p(pcols,pver)
 686   real(r8) ph(pcols,pver)
 687
 688   real(r8) :: rhoh(pcols,pver)    ! air density (kg m-3) at interface
 689   real(r8) :: rhom(pcols,pver)    ! air density (kg m-3) at mid-level
 690   real(r8) :: tu(pcols,pver)      ! temperature in updraft (K)
 691
 692   real(r8) :: fhmrm (pcols,pver)  !mass tendency due to homogeneous freezing of rain
 693
 694   real(r8) ncorg,niorg,qcorg,qiorg
 695
 696   integer  kqi(pcols),kqc(pcols)
 697   logical  lcbase(pcols), libase(pcols)
 698
 699 !ckay introduced save sep6
 700 ! save
 701
 702 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 703 ! initialization
 704 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 705
 706
 707 ! parameters for scheme
 708         omsm=0.99999_r8
 709         zfacbuo = 0.5_r8/(1._r8+0.5_r8)
 710         cwdrag  = 1.875_r8*0.506_r8
 711         cwifrac = 0.5_r8
 712         retv    = 0.608_r8
 713         bergtsf = 1800._r8
 714
 715 ! initialize multi-level fields
 716         do i=1,il2g
 717           do k=1,pver
 718             q(i,k)= qu(i,k)
 719             tu(i,k)= su(i,k) - grav/cp*zf(i,k)
 720             t(i,k)= su(i,k) - grav/cp*zf(i,k)
 721             p(i,k) = 100._r8*pm(i,k)
 722             wu(i,k)  = 0._r8
 723             zkine(i,k)= 0._r8
 724             arcf(i,k) = 0._r8
 725             zbuo(i,k) = 0._r8
 726             nc(i,k) = 0._r8
 727             ni(i,k) = 0._r8
 728             qc(i,k) = 0._r8
 729             qi(i,k) = 0._r8
 730             qcic(i,k) = 0._r8
 731             qiic(i,k) = 0._r8
 732             ncic(i,k) = nc(i,k)
 733             niic(i,k) = ni(i,k)
 734             qr(i,k) = 0._r8
 735             qni(i,k)= 0._r8
 736             nr(i,k) = 0._r8
 737             ns(i,k) = 0._r8
 738             qric(i,k) = qr(i,k)
 739             qniic(i,k) = qni(i,k)
 740             nric(i,k) = nr(i,k)
 741             nsic(i,k) = ns(i,k)
 742             nimey(i,k) = 0._r8
 743             nihf(i,k)  = 0._r8
 744             nidep(i,k) = 0._r8
 745             niimm(i,k) = 0._r8
 746
 747             autolm(i,k) = 0._r8
 748             accrlm(i,k) = 0._r8
 749             bergnm(i,k) = 0._r8
 750             fhtimm(i,k) = 0._r8
 751             fhtctm(i,k) = 0._r8
 752             fhmlm (i,k) = 0._r8
 753             hmpim (i,k) = 0._r8
 754             accslm(i,k) = 0._r8
 755             dlfm  (i,k) = 0._r8
 756             collrm(i,k) = 0._r8
 757             collrn(i,k) = 0._r8
 758             fhtcrm(i,k) = 0._r8
 759             fhtcrn(i,k) = 0._r8
 760             autorn(i,k) = 0._r8
 761              aggrn(i,k) = 0._r8
 762              aggsn(i,k) = 0._r8
 763
 764             autoln(i,k) = 0._r8
 765
 766             accrln(i,k) = 0._r8
 767             bergnn(i,k) = 0._r8
 768             fhtimn(i,k) = 0._r8
 769             fhtctn(i,k) = 0._r8
 770             fhmln (i,k) = 0._r8
 771             accsln(i,k) = 0._r8
 772             activn(i,k) = 0._r8
 773             dlfn  (i,k) = 0._r8
 774             ncadj (i,k) = 0._r8
 775             qcadj (i,k) = 0._r8
 776 !cloud ice------------------------
 777            autoim(i,k) = 0._r8
 778             accsim(i,k) = 0._r8
 779             difm  (i,k) = 0._r8
 780             nuclin(i,k) = 0._r8
 781             nuclim(i,k) = 0._r8
 782             autoin(i,k) = 0._r8
 783             accsin(i,k) = 0._r8
 784             hmpin (i,k) = 0._r8
 785             difn  (i,k) = 0._r8
 786             niadj (i,k) = 0._r8
 787             qiadj (i,k) = 0._r8
 788
 789             trspcm(i,k) = 0._r8
 790             trspcn(i,k) = 0._r8
 791             trspim(i,k) = 0._r8
 792             trspin(i,k) = 0._r8
 793
 794             effc(i,k) = 0._r8
 795             effi(i,k) = 0._r8
 796             effs(i,k) = 0._r8
 797
 798             fhmrm (i,k) = 0._r8
 799           end do
 800         end do
 801
 802
 803 ! initialize time-varying parameters
 804         do k=1,pver
 805           do i=1,il2g
 806 !-------------Shaocai Yu
 807              if (k .eq.1) then
 808                 rhoh(i,k) = p(i,k)/(t(i,k)*rd)
 809                 rhom(i,k) = p(i,k)/(t(i,k)*rd)
 810                 th (i,k) = te(i,k)
 811                 qh (i,k) = qe(i,k)
 812                 dz (i,k)  = zf(i,k) - zf(i,k+1)
 813                 ph(i,k)   = p(i,k)
 814              else
 815
 816                rhoh(i,k) = 0.5_r8*(p(i,k)+p(i,k-1))/(t(i,k)*rd)
 817                 if (k .eq. pver) then
 818                   rhom(i,k) = p(i,k)/(rd*t(i,k))
 819                 else
 820                   rhom(i,k) = 2.0_r8*p(i,k)/(rd*(t(i,k)+t(i,k+1)))
 821                 end if
 822                 th (i,k) = 0.5_r8*(te(i,k)+te(i,k-1))
 823                 qh (i,k) = 0.5_r8*(qe(i,k)+qe(i,k-1))
 824                 dz(i,k)  = zf(i,k-1) - zf(i,k)
 825                 ph(i,k)  = 0.5_r8*(p(i,k) + p(i,k-1))
 826              end if
 827
 828             dv(i,k) = 8.794E-5_r8*t(i,k)**1.81_r8/ph(i,k)
 829             mua(i,k) = 1.496E-6_r8*t(i,k)**1.5_r8/ &
 830                      (t(i,k)+120._r8)
 831
 832             rho(i,k) = rhoh(i,k)
 833
 834 ! air density adjustment for fallspeed parameters
 835 ! add air density correction factor to the power of
 836 ! 0.54 following Heymsfield and Bansemer 2006
 837
 838             arn(i,k)=ar*(rhosu/rho(i,k))**0.54
 839             asn(i,k)=as*(rhosu/rho(i,k))**0.54
 840             acn(i,k)=ac*(rhosu/rho(i,k))**0.54
 841             ain(i,k)=ai*(rhosu/rho(i,k))**0.54
 842
 843           end do
 844         end do
 845
 846 ! initialize aerosol number
 847         do k=1,pver
 848           do i=1,il2g
 849             naer2(i,k,:)=0._r8
 850             naer2h(i,k,:)=0._r8
 851             dum2l(i,k)=0._r8
 852             dum2i(i,k)=0._r8
 853           end do
 854         end do
 855
 856         do k=1,pver
 857           do i=1,il2g
 858             ntaer(i,k) = 0.0_r8
 859             ntaerh(i,k) = 0.0_r8
 860             do m=1,naer_cu
 861
 862               maerosol(1,m)=aer_mmr(i,k,m)*rhom(i,k)
 863
 864 !------------------------------------------------------------------
 865
 866 ! set number nucleated for sulfate based on Lohmann et al. 2000 (JGR) Eq.2
 867 !    Na=340.*(massSO4)^0.58  where Na=cm-3 and massSO4=ug/m3
 868 ! convert units to Na [m-3] and SO4 [kgm-3]
 869 !    Na(m-3)= 1.e6 cm3 m-3 Na(cm-3)=340. *(massSO4[kg/m3]*1.e9ug/kg)^0.58
 870 !    or Na(m-3)= 1.e6* 340.*(1.e9ug/kg)^0.58 * (massSO4[kg/m3])^0.58
 871               if(m .eq. idxsul) then
 872                 naer2(i,k,m)= 5.64259e13_r8 * maerosol(1,m)**0.58
 873               else
 874                 naer2(i,k,m)=maerosol(1,m)*num_to_mass_aer(m)
 875               endif
 876                 ntaer(i,k) = ntaer(i,k) + naer2(i,k,m)
 877             enddo
 878           end do ! i loop
 879         end do ! k loop
 880
 881         do i=1,il2g
 882           ltrue(i)=0
 883           do k=1,pver
 884             if (qc(i,k).ge.qsmall.or.qi(i,k).ge.qsmall.or.cmel(i,k).ge.qsmall.or.cmei(i,k).ge.qsmall) ltrue(i)=1
 885 !            print *,'qc flag =',ltrue(i)
 886           end do
 887         end do
 888
 889 ! skip microphysical calculations if no cloud water
 890       do i=1,il2g
 891         if (ltrue(i).eq.0) then
 892           do k=1,pver
 893             qctend(i,k)=0._r8
 894             qitend(i,k)=0._r8
 895             qnitend(i,k)=0._r8
 896             qrtend(i,k)=0._r8
 897             nctend(i,k)=0._r8
 898             nitend(i,k)=0._r8
 899             nrtend(i,k)=0._r8
 900             nstend(i,k)=0._r8
 901             qniic(i,k)=0._r8
 902             qric(i,k)=0._r8
 903             nsic(i,k)=0._r8
 904             nric(i,k)=0._r8
 905             qni(i,k)=0._r8
 906             qr(i,k)=0._r8
 907             ns(i,k)=0._r8
 908             nr(i,k)=0._r8
 909             qc(i,k) = 0._r8
 910             qi(i,k) = 0._r8
 911             nc(i,k) = 0._r8
 912             ni(i,k) = 0._r8
 913             rprd(i,k) = 0._r8
 914             sprd(i,k) = 0._r8
 915             frz(i,k) = 0._r8
 916           end do
 917           goto 300
 918         end if
 919
 920         kqc(i) = 1
 921         kqi(i) = 1
 922         lcbase(i) = .true.
 923         libase(i) = .true.
 924
 925 ! assign number of steps for iteration
 926 ! use 2 steps following Song and Zhang, 2011, J. Clim.
 927         iter = 2  !5 !Shaocai Yu !2
 928
 929 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 930 !  iteration
 931 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 932
 933         do it=1,iter
 934 ! initialize sub-step microphysical tendencies
 935          do k=1,pver
 936            qctend(i,k)=0._r8
 937            qitend(i,k)=0._r8
 938            qnitend(i,k)=0._r8
 939            qrtend(i,k)=0._r8
 940            nctend(i,k)=0._r8
 941            nitend(i,k)=0._r8
 942            nrtend(i,k)=0._r8
 943            nstend(i,k)=0._r8
 944            rprd(i,k) = 0._r8
 945            sprd(i,k) = 0._r8
 946            frz(i,k)  = 0._r8
 947            qniic(i,k)=0._r8
 948            qric(i,k)=0._r8
 949            nsic(i,k)=0._r8
 950            nric(i,k)=0._r8
 951            qiic(i,k)=0._r8
 952            qcic(i,k)=0._r8
 953            niic(i,k)=0._r8
 954            ncic(i,k)=0._r8
 955 !<songxl 2012-01-06---------------
 956             accrlm(i,k) = 0._r8
 957             bergnm(i,k) = 0._r8
 958             fhtimm(i,k) = 0._r8
 959             fhtctm(i,k) = 0._r8
 960             fhmlm (i,k) = 0._r8
 961             hmpim (i,k) = 0._r8
 962             accslm(i,k) = 0._r8
 963             dlfm  (i,k) = 0._r8
 964
 965             autoln(i,k) = 0._r8
 966             accrln(i,k) = 0._r8
 967             bergnn(i,k) = 0._r8
 968             fhtimn(i,k) = 0._r8
 969             fhtctn(i,k) = 0._r8
 970             fhmln (i,k) = 0._r8
 971             accsln(i,k) = 0._r8
 972             activn(i,k) = 0._r8
 973             dlfn  (i,k) = 0._r8
 974             ncadj (i,k) = 0._r8
 975             qcadj (i,k) = 0._r8
 976
 977             autoim(i,k) = 0._r8
 978             accsim(i,k) = 0._r8
 979             difm  (i,k) = 0._r8
 980
 981             nuclin(i,k) = 0._r8
 982             nuclim(i,k) = 0._r8
 983             autoin(i,k) = 0._r8
 984             accsin(i,k) = 0._r8
 985             hmpin (i,k) = 0._r8
 986             difn  (i,k) = 0._r8
 987             niadj (i,k) = 0._r8
 988             qiadj (i,k) = 0._r8
 989
 990             trspcm(i,k) = 0._r8
 991             trspcn(i,k) = 0._r8
 992             trspim(i,k) = 0._r8
 993             trspin(i,k) = 0._r8
 994
 995             effc(i,k) = 0._r8
 996             effi(i,k) = 0._r8
 997             effs(i,k) = 0._r8
 998
 999             fhmrm (i,k) = 0._r8
1000 !songxl 2012-01-06>---------------
1001 !songxl 2012-01-06>---------------
1002          end do
1003
1004 !---------------------Shaocai
1005 !        goto 9910  !Stop2
1006
1007          do k = pver,msg+2,-1
1008
1009 !within the cloud processing...
1010             if (k > jt(i) .and. k <= jb(i) .and. eps0(i) > 0._r8      &
1011               .and.mu(i,k).gt.0._r8 .and. mu(i,k-1).gt.0._r8) then
1012
1013 ! initialize precip fallspeeds to zero
1014             ums(k)=0._r8
1015             uns(k)=0._r8
1016             umr(k)=0._r8
1017             unr(k)=0._r8
1018             prf(k)=0._r8
1019             pnrf(k)=0._r8
1020             psf(k) =0._r8
1021             pnsf(k) = 0._r8
1022             ttend(k)=0._r8
1023             nnuccd(k)=0._r8
1024             npccn(k)=0._r8
1025
1026 !************************************************************************************
1027 ! obtain values of cloud water/ice mixing ratios and number concentrations in
1028 ! updraft
1029 ! for microphysical process calculations
1030 ! units are kg/kg for mixing ratio, 1/kg for number conc
1031 !************************************************************************************
1032
1033 ! limit values to 0.005 kg/kg
1034 !dkay      qc(i,k)=min(qc(i,k),5.e-3_r8)
1035 !dkay      qi(i,k)=min(qi(i,k),5.e-3_r8)
1036            nc(i,k)=max(nc(i,k),0._r8)
1037            ni(i,k)=max(ni(i,k),0._r8)
1038            if (it.eq.1) then
1039              qcic(i,k) = qc(i,k)
1040              qiic(i,k) = qi(i,k)
1041 !             print *,'at it=1',qcic(i,k),k,it
1042 !dkay
1043 !            qcic(i,k) = qc_kf_act(k)
1044 !            qiic(i,k) = qi_kf_act(k)
1045 !dkay
1046              ncic(i,k) = nc(i,k)
1047              niic(i,k) = ni(i,k)
1048              qniic(i,k)= qni(i,k)
1049              qric(i,k) = qr(i,k)
1050              nsic(i,k) = ns(i,k)
1051              nric(i,k) = nr(i,k)
1052            else  ! for it
1053              if (k.le.kqc(i)) then
1054                 qcic(i,k) = qc(i,k)
1055                 ncic(i,k) = nc(i,k)
1056                 if (k.eq.kqc(i)) then
1057                   qcic(i,k) = qc(i,k-1)
1058                   ncic(i,k) = nc(i,k-1)
1059                 end if
1060 ! consider rain falling from above
1061                 do kk= k,jt(i)+2,-1
1062                    qric(i,k) = qr(i,k) + max(0._r8, qr(i,kk-1)-qr(i,kk-2) )
1063                    if (qr(i,kk-1) .gt. 0._r8)  &
1064                    nric(i,k) = nr(i,k) + max(0._r8,qr(i,kk-1)-qr(i,kk-2))/qr(i,kk-1)*nr(i,kk-1)
1065                 end do
1066              end if
1067              if(k.le.kqi(i)) then
1068                 qiic(i,k) = qi(i,k)
1069                 niic(i,k) = ni(i,k)
1070                 if(k.eq.kqi(i)) then
1071                   qiic(i,k) = qi(i,k-1)
1072                   niic(i,k) = ni(i,k-1)
1073                 end if
1074 ! consider snow falling from above
1075                 do kk= k,jt(i)+2,-1
1076                   qniic(i,k) = qni(i,k) + max(0._r8, qni(i,kk-1)-qni(i,kk-2) )
1077                   if (qni(i,kk-1) .gt. 0._r8)  &
1078                   nsic(i,k) = ns(i,k) + max(0._r8,qni(i,kk-1)-qni(i,kk-2))/qni(i,kk-1)*ns(i,kk-1)
1079                 end do
1080              end if
1081            end if
1082
1083             if(it.eq.1) then
1084 !              print
1085 !              *,'qcic,qiic=',qcic(i,k),qiic(i,k),i,k,cmel(i,k),cmei(i,k),tu(i,k),it
1086             end if
1087 !**********************************************************************
1088 ! boundary condition for cloud liquid water and cloud ice
1089 !***********************************************************************
1090
1091 ! boundary condition for provisional cloud water
1092         if (cmel(i,k-1).gt.qsmall .and. lcbase(i) .and. it.eq.1 ) then
1093              kqc(i) = k
1094              lcbase(i) = .false.
1095              qcic(i,k) = dz(i,k)*cmel(i,k-1)/(mu(i,k-1)+dz(i,k)*du(i,k-1))
1096              if(qcic(i,k).eq.0.0) then
1097               if(it.eq.1) then
1098 !              print *,'dz,cmel...',
1099 !              dz(i,k),cmel(i,k+1),mu(i,k+1),dz(i,k),du(i,k+1)
1100               end if
1101              end if
1102              ncic(i,k) = qcic(i,k)/(4._r8/3._r8*pi*11.e-6_r8**3*rhow)
1103          end if
1104
1105 ! boundary condition for provisional cloud ice
1106          if (qiic(i,k).gt.qsmall .and. libase(i) .and. it.eq.1 ) then
1107              kqi(i) = k
1108              libase(i) = .false.
1109          else if ( cmei(i,k-1).gt.qsmall .and.   &
1110              cmei(i,k).lt.qsmall .and. k.lt.jb(i) .and. libase(i) .and. it.eq.1) then
1111              kqi(i)=k
1112              libase(i) = .false.
1113              qiic(i,k) = dz(i,k)*cmei(i,k-1)/(mu(i,k-1)+dz(i,k)*du(i,k-1))
1114              niic(i,k) = qiic(i,k)/(4._r8/3._r8*pi*25.e-6_r8**3*rhoi)
1115          end if
1116
1117 !***************************************************************************
1118 ! get size distribution parameters based on in-cloud cloud water/ice
1119 ! these calculations also ensure consistency between number and mixing ratio
1120 !***************************************************************************
1121 ! cloud ice
1122            if (qiic(i,k).ge.qsmall) then
1123 ! add upper limit to in-cloud number concentration to prevent numerical error
1124               niic(i,k)=min(niic(i,k),qiic(i,k)*1.e20_r8)
1125               lami(k) = (mskf_GAMMA(1._r8+di)*ci* &
1126                   niic(i,k)/qiic(i,k))**(1._r8/di)
1127               n0i(k) = niic(i,k)*lami(k)
1128 ! check for slope
1129               lammax = 1._r8/10.e-6_r8
1130               lammin = 1._r8/(2._r8*dcs)
1131 ! adjust vars
1132               if (lami(k).lt.lammin) then
1133                 lami(k) = lammin
1134                 n0i(k) = lami(k)**(di+1._r8)*qiic(i,k)/(ci*mskf_GAMMA(1._r8+di))
1135                 niic(i,k) = n0i(k)/lami(k)
1136               else if (lami(k).gt.lammax) then
1137                 lami(k) = lammax
1138                 n0i(k) = lami(k)**(di+1._r8)*qiic(i,k)/(ci*mskf_GAMMA(1._r8+di))
1139                 niic(i,k) = n0i(k)/lami(k)
1140               end if
1141            else
1142               lami(k) = 0._r8
1143               n0i(k) = 0._r8
1144            end if
1145
1146 !cloud water
1147            if (qcic(i,k).ge.qsmall) then
1148
1149 ! add upper limit to in-cloud number concentration to prevent numerical error
1150               ncic(i,k)=min(ncic(i,k),qcic(i,k)*1.e20_r8)
1151
1152 ! get pgam from fit to observations of martin et al. 1994
1153
1154               pgam(k)=0.0005714_r8*(ncic(i,k)/1.e6_r8*rho(i,k))+0.2714_r8  ! TWG 2017 change / to * for consistenct with Morrison
1155               pgam(k)=1._r8/(pgam(k)**2)-1._r8
1156               pgam(k)=max(pgam(k),2._r8)
1157               pgam(k)=min(pgam(k),15._r8)
1158
1159 ! calculate lamc
1160               lamc(k) = (pi/6._r8*rhow*ncic(i,k)*mskf_GAMMA(pgam(k)+4._r8)/ &
1161                  (qcic(i,k)*mskf_GAMMA(pgam(k)+1._r8)))**(1._r8/3._r8)
1162
1163 ! lammin, 50 micron diameter max mean size
1164               lammin = (pgam(k)+1._r8)/50.e-6_r8
1165               lammax = (pgam(k)+1._r8)/2.e-6_r8
1166
1167               if (lamc(k).lt.lammin) then
1168                  lamc(k) = lammin
1169                  ncic(i,k) = 6._r8*lamc(k)**3*qcic(i,k)* &
1170                       mskf_GAMMA(pgam(k)+1._r8)/ &
1171                       (pi*rhow*mskf_GAMMA(pgam(k)+4._r8))
1172               else if (lamc(k).gt.lammax) then
1173                  lamc(k) = lammax
1174                  ncic(i,k) = 6._r8*lamc(k)**3*qcic(i,k)* &
1175                        mskf_GAMMA(pgam(k)+1._r8)/ &
1176                       (pi*rhow*mskf_GAMMA(pgam(k)+4._r8))
1177               end if
1178
1179 ! parameter to calculate droplet freezing
1180
1181               cdist1(k) = ncic(i,k)/mskf_GAMMA(pgam(k)+1._r8)
1182            else
1183               lamc(k) = 0._r8
1184               cdist1(k) = 0._r8
1185            end if
1186 ! boundary condition for cloud liquid water
1187          if ( kqc(i) .eq. k  ) then
1188               qc(i,k) =  0._r8
1189               nc(i,k) = 0._r8
1190           end if
1191 ! boundary condition for cloud ice
1192           if (kqi(i).eq.k  ) then
1193              qi(i,k) = 0._r8
1194              ni(i,k) = 0._r8
1195           end if
1196
1197 !**************************************************************************
1198 ! begin micropysical process calculations
1199 !**************************************************************************
1200
1201 !.................................................................
1202 ! autoconversion of cloud liquid water to rain
1203 ! formula from Khrouditnov and Kogan (2000)
1204 ! minimum qc of 1 x 10^-8 prevents floating point error
1205
1206            if (qcic(i,k).ge.1.e-8_r8) then
1207
1208 ! nprc is increase in rain number conc due to autoconversion
1209 ! nprc1 is decrease in cloud droplet conc due to autoconversion
1210
1211 !TWG Feb 2017 Update from Khrouditnov and Kogan (2000) to Kogan (2013) for
1212 !convection
1213
1214 !              prc(k) = 1350._r8*qcic(i,k)**2.47_r8*    &
1215 !                    (ncic(i,k)/1.e6_r8*rho(i,k))**(-1.79_r8)
1216               prc(k) = 7.98E10_r8*qcic(i,k)**4.22_r8*    &
1217                     (ncic(i,k)/1.e6_r8*rho(i,k))**(-3.01_r8)
1218
1219               nprc(k) = prc(k)/(4._r8/3._r8*pi*rhow*(25.e-6_r8)**3)
1220               nprc1(k) = prc(k)/(qcic(i,k)/ncic(i,k))
1221            else
1222               prc(k)=0._r8
1223               nprc(k)=0._r8
1224               nprc1(k)=0._r8
1225            end if
1226
1227 ! provisional rain mixing ratio and number concentration (qric and nric)
1228 ! at boundary are estimated via autoconversion
1229
1230          if (k.eq.kqc(i) .and. it.eq.1) then
1231              qric(i,k) = prc(k)*dz(i,k)/0.55_r8
1232              nric(i,k) = nprc(k)*dz(i,k)/0.55_r8
1233              qr(i,k) = 0.0_r8
1234              nr(i,k) = 0.0_r8
1235          end if
1236 !          print *,'qric,nric,qr,nr afer autoconversion cld water to rain'
1237 !          print *, 'qric=',qric
1238 !          print *,
1239 !          'nric=',nric(i,15),i,nprc(15),prc(15),ncic(i,15),rhow,qcic(i,15)
1240 !          print *, 'qr=',qr
1241 !          print *, 'qr=',qr
1242
1243 !.......................................................................
1244
1245 ! similar to Ferrier (1994)
1246
1247            if (t(i,k).le.273.15_r8.and.qiic(i,k).ge.qsmall) then
1248
1249 ! note: assumes autoconversion timescale of 180 sec  !TWG Feb17 adjust
1250 ! autoconversion time scale
1251               ! nprci(k) = n0i(k)/(lami(k)*180._r8)*exp(-lami(k)*dcs)
1252               nprci(k) = n0i(k)/(lami(k)*F14)*exp(-lami(k)*dcs)
1253              ! prci(k) = pi*rhoi*n0i(k)/(6._r8*180._r8)* &
1254                prci(k) = pi*rhoi*n0i(k)/(6._r8*F14)* &
1255                   (dcs**3/lami(k)+3._r8*dcs**2/lami(k)**2+ &
1256                   6._r8*dcs/lami(k)**3+6._r8/lami(k)**4)*exp(-lami(k)*dcs)
1257            else
1258               prci(k)=0._r8
1259               nprci(k)=0._r8
1260            end if
1261
1262 ! provisional snow mixing ratio and number concentration (qniic and nsic)
1263 ! at boundary are estimated via autoconversion
1264
1265            if (k.eq.kqi(i) .and. it.eq.1) then
1266               qniic(i,k)= prci(k)*dz(i,k)*0.25_r8
1267               nsic(i,k)= nprci(k)*dz(i,k)*0.25_r8
1268               qni(i,k)= 0.0_r8
1269               ns(i,k)= 0.0_r8
1270            end if
1271 ! if precip mix ratio is zero so should number concentration
1272            if (qniic(i,k).lt.qsmall) then
1273               qniic(i,k)=0._r8
1274               nsic(i,k)=0._r8
1275            end if
1276            if (qric(i,k).lt.qsmall) then
1277               qric(i,k)=0._r8
1278               nric(i,k)=0._r8
1279            end if
1280
1281 ! make sure number concentration is a positive number to avoid
1282 ! taking root of negative later
1283            nric(i,k)=max(nric(i,k),0._r8)
1284            nsic(i,k)=max(nsic(i,k),0._r8)
1285
1286 !**********************************************************************
1287 ! get size distribution parameters for precip
1288 !**********************************************************************
1289 ! rain
1290
1291            if (qric(i,k).ge.qsmall) then
1292              lamr(k) = (pi*rhow*nric(i,k)/qric(i,k))**(1._r8/3._r8)
1293              n0r(k) = nric(i,k)*lamr(k)
1294 ! check for slope
1295              lammax = 1._r8/20.e-6_r8
1296              lammin = 1._r8/500.e-6_r8
1297 ! adjust vars
1298              if (lamr(k).lt.lammin) then
1299                lamr(k) = lammin
1300                n0r(k) = lamr(k)**4*qric(i,k)/(pi*rhow)
1301                nric(i,k) = n0r(k)/lamr(k)
1302              else if (lamr(k).gt.lammax) then
1303                lamr(k) = lammax
1304                n0r(k) = lamr(k)**4*qric(i,k)/(pi*rhow)
1305                nric(i,k) = n0r(k)/lamr(k)
1306              end if
1307
1308 ! provisional rain number and mass weighted mean fallspeed (m/s)
1309 ! Eq.18 of Morrison and Gettelman, 2008, J. Climate
1310              unr(k) = min(arn(i,k)*mskf_GAMMA(1._r8+br)/lamr(k)**br,10._r8)
1311              umr(k) = min(arn(i,k)*mskf_GAMMA(4._r8+br)/(6._r8*lamr(k)**br),10._r8)
1312            else
1313              lamr(k) = 0._r8
1314              n0r(k) = 0._r8
1315              umr(k) = 0._r8
1316              unr(k) = 0._r8
1317            end if
1318 !......................................................................
1319 ! snow
1320            if (qniic(i,k).ge.qsmall) then
1321              lams(k) = (mskf_GAMMA(1._r8+ds)*cs*nsic(i,k)/ &
1322                        qniic(i,k))**(1._r8/ds)
1323              n0s(k) = nsic(i,k)*lams(k)
1324
1325 ! check for slope
1326              lammax = 1._r8/10.e-6_r8
1327              lammin = 1._r8/2000.e-6_r8
1328 ! adjust vars
1329              if (lams(k).lt.lammin) then
1330                lams(k) = lammin
1331                n0s(k) = lams(k)**(ds+1._r8)*qniic(i,k)/(cs*mskf_GAMMA(1._r8+ds))
1332                nsic(i,k) = n0s(k)/lams(k)
1333              else if (lams(k).gt.lammax) then
1334                lams(k) = lammax
1335                n0s(k) = lams(k)**(ds+1._r8)*qniic(i,k)/(cs*mskf_GAMMA(1._r8+ds))
1336                nsic(i,k) = n0s(k)/lams(k)
1337              end if
1338
1339 ! provisional snow number and mass weighted mean fallspeed (m/s)
1340              ums(k) = min(asn(i,k)*mskf_GAMMA(4._r8+bs)/(6._r8*lams(k)**bs),3.6_r8)
1341              uns(k) = min(asn(i,k)*mskf_GAMMA(1._r8+bs)/lams(k)**bs,3.6_r8)
1342            else
1343              lams(k) = 0._r8
1344              n0s(k) = 0._r8
1345              ums(k) = 0._r8
1346              uns(k) = 0._r8
1347            end if
1348
1349 !.......................................................................
1350 ! snow self-aggregation from passarelli, 1978, used by Reisner(1998,Eq.A.35)
1351 ! this is hard-wired for bs = 0.4 for now
1352 ! ignore self-collection of cloud ice
1353
1354           if (qniic(i,k).ge.qsmall .and. t(i,k).le.273.15_r8) then
1355               nsagg(k) = -1108._r8*asn(i,k)*Eii* &
1356                    pi**((1._r8-bs)/3._r8)*rhosn**((-2._r8-bs)/3._r8)*rho(i,k)** &
1357                    ((2._r8+bs)/3._r8)*qniic(i,k)**((2._r8+bs)/3._r8)* &
1358                    (nsic(i,k)*rho(i,k))**((4._r8-bs)/3._r8)/ &
1359                    (4._r8*720._r8*rho(i,k))
1360            else
1361               nsagg(k)=0._r8
1362            end if
1363
1364 !.......................................................................
1365 ! accretion of cloud droplets onto snow/graupel
1366 ! here use continuous collection equation with
1367 ! simple gravitational collection kernel
1368 ! ignore collisions between droplets/cloud ice
1369
1370 ! ignore collision of snow with droplets above freezing
1371
1372            if (qniic(i,k).ge.qsmall .and. t(i,k).le.273.15_r8 .and. &
1373               qcic(i,k).ge.qsmall) then
1374
1375 ! put in size dependent collection efficiency
1376 ! mean diameter of snow is area-weighted, since
1377 ! accretion is function of crystal geometric area
1378 ! collection efficiency is from stoke's law (Thompson et al. 2004)
1379
1380               dc0 = (pgam(k)+1._r8)/lamc(k)
1381               ds0 = 1._r8/lams(k)
1382               dum = dc0*dc0*uns(k)*rhow/(9._r8*mua(i,k)*ds0)
1383               eci = dum*dum/((dum+0.4_r8)*(dum+0.4_r8))
1384               eci = max(eci,0._r8)
1385               eci = min(eci,1._r8)
1386
1387               psacws(k) = pi/4._r8*asn(i,k)*qcic(i,k)*rho(i,k)* &
1388                   n0s(k)*Eci*mskf_GAMMA(bs+3._r8)/ &
1389                   lams(k)**(bs+3._r8)
1390               npsacws(k) = pi/4._r8*asn(i,k)*ncic(i,k)*rho(i,k)* &
1391                   n0s(k)*Eci*mskf_GAMMA(bs+3._r8)/ &
1392                   lams(k)**(bs+3._r8)
1393            else
1394               psacws(k)=0._r8
1395               npsacws(k)=0._r8
1396            end if
1397
1398 ! secondary ice production due to accretion of droplets by snow
1399 ! (Hallet-Mossop process) (from Cotton et al., 1986)
1400            if((t(i,k).lt.270.16_r8) .and. (t(i,k).ge.268.16_r8)) then
1401               ni_secp   = 3.5e8_r8*(270.16_r8-t(i,k))/2.0_r8*psacws(k)
1402               nsacwi(k) = ni_secp
1403               msacwi(k) = min(ni_secp*mi0,psacws(k))
1404            else if((t(i,k).lt.268.16_r8) .and. (t(i,k).ge.265.16_r8)) then
1405               ni_secp   = 3.5e8_r8*(t(i,k)-265.16_r8)/3.0_r8*psacws(k)
1406               nsacwi(k) = ni_secp
1407               msacwi(k) = min(ni_secp*mi0,psacws(k))
1408            else
1409               ni_secp   = 0.0_r8
1410               nsacwi(k) = 0.0_r8
1411               msacwi(k) = 0.0_r8
1412            endif
1413            psacws(k) = max(0.0_r8,psacws(k)-ni_secp*mi0)
1414
1415 !.......................................................................
1416 ! accretion of rain water by snow
1417 ! formula from ikawa and saito, 1991, used by reisner et al., 1998
1418
1419            if (qric(i,k).ge.1.e-8_r8 .and. qniic(i,k).ge.1.e-8_r8 .and. &
1420               t(i,k).le.273.15_r8) then
1421
1422               pracs(k) = pi*pi*ecr*(((1.2_r8*umr(k)-0.95_r8*ums(k))**2+ &
1423                   0.08_r8*ums(k)*umr(k))**0.5_r8*rhow*rho(i,k)* &
1424                   n0r(k)*n0s(k)* &
1425                   (5._r8/(lamr(k)**6*lams(k))+ &
1426                   2._r8/(lamr(k)**5*lams(k)**2)+ &
1427                   0.5_r8/(lamr(k)**4*lams(k)**3)))
1428
1429               npracs(k) = pi/2._r8*rho(i,k)*ecr*(1.7_r8*(unr(k)-uns(k))**2+ &
1430                   0.3_r8*unr(k)*uns(k))**0.5_r8*n0r(k)*n0s(k)* &
1431                   (1._r8/(lamr(k)**3*lams(k))+ &
1432                   1._r8/(lamr(k)**2*lams(k)**2)+ &
1433                   1._r8/(lamr(k)*lams(k)**3))
1434            else
1435               pracs(k)=0._r8
1436               npracs(k)=0._r8
1437            end if
1438
1439 !.......................................................................
1440 ! heterogeneous freezing of rain drops
1441 ! follows from Bigg (1953)
1442
1443            if (t(i,k).lt.269.15_r8 .and. qric(i,k).ge.qsmall) then
1444
1445               mnuccr(k) = 20._r8*pi*pi*rhow*nric(i,k)*bimm* &
1446                   exp(aimm*(273.15_r8-t(i,k)))/lamr(k)**3 &
1447                   /lamr(k)**3
1448
1449               nnuccr(k) = pi*nric(i,k)*bimm* &
1450                    exp(aimm*(273.15_r8-t(i,k)))/lamr(k)**3
1451            else
1452               mnuccr(k)=0._r8
1453               nnuccr(k)=0._r8
1454            end if
1455
1456 !.......................................................................
1457 ! accretion of cloud liquid water by rain
1458 ! formula from Khrouditnov and Kogan (2000)
1459 ! gravitational collection kernel, droplet fall speed neglected
1460
1461            if (qric(i,k).ge.qsmall .and. qcic(i,k).ge.qsmall) then
1462               pra(k) = 67._r8*(qcic(i,k)*qric(i,k))**1.15_r8
1463               npra(k) = pra(k)/(qcic(i,k)/ncic(i,k))
1464            else
1465               pra(k)=0._r8
1466               npra(k)=0._r8
1467            end if
1468
1469 !.......................................................................
1470 ! Self-collection of rain drops
1471 ! from Beheng(1994)
1472
1473            if (qric(i,k).ge.qsmall) then
1474               nragg(k) = -8._r8*nric(i,k)*qric(i,k)*rho(i,k)
1475            else
1476               nragg(k)=0._r8
1477            end if
1478
1479 !.......................................................................
1480 ! Accretion of cloud ice by snow
1481 ! For this calculation, it is assumed that the Vs >> Vi
1482 ! and Ds >> Di for continuous collection
1483
1484            if (qniic(i,k).ge.qsmall.and.qiic(i,k).ge.qsmall &
1485               .and.t(i,k).le.273.15_r8) then
1486               prai(k) = pi/4._r8*asn(i,k)*qiic(i,k)*rho(i,k)* &
1487                    n0s(k)*Eii*mskf_GAMMA(bs+3._r8)/ &
1488                    lams(k)**(bs+3._r8)
1489               nprai(k) = pi/4._r8*asn(i,k)*niic(i,k)* &
1490                    rho(i,k)*n0s(k)*Eii*mskf_GAMMA(bs+3._r8)/ &
1491                    lams(k)**(bs+3._r8)
1492            else
1493               prai(k)=0._r8
1494               nprai(k)=0._r8
1495            end if
1496
1497 !.......................................................................
1498 ! fallout term
1499         prf(k)  = -umr(k)*qric(i,k)/dz(i,k)
1500         pnrf(k) = -unr(k)*nric(i,k)/dz(i,k)
1501         psf(k)  = -ums(k)*qniic(i,k)/dz(i,k)
1502         pnsf(k) = -uns(k)*nsic(i,k)/dz(i,k)
1503
1504 !........................................................................
1505 ! calculate vertical velocity in cumulus updraft
1506
1507      if (k.eq.jb(i)) then
1508        zkine(i,jb(i)) = 0.5_r8
1509        wu   (i,jb(i)) = 1._r8
1510        zbuo (i,jb(i)) = (tu(i,jb(i))*(1._r8+retv*qu(i,jb(i)))-    &
1511                      th(i,jb(i))*(1._r8+retv*qh(i,jb(i))))/   &
1512                      (th(i,jb(i))*(1._r8+retv*qh(i,jb(i))))
1513      else
1514        if (.true.) then
1515 !          print *,'before ecmwf qcs=',qc(i,k),qi(i,k),qr(i,k),k
1516 ! ECMWF formula
1517   !          print *,'using ecmwrf CKE, retv=',retv
1518            zbc = tu(i,k)*(1._r8+retv*qu(i,k)-qr(i,k)-qni(i,k)-qi(i,k)-qc(i,k))
1519            zbe = th(i,k)*(1._r8+retv*qh(i,k))
1520            zbuo(i,k) = (zbc-zbe)/zbe
1521            zbuoc= (zbuo(i,k)+zbuo(i,k+1))*0.5_r8
1522            zdkbuo = dz(i,k+1)*grav*zfacbuo*zbuoc
1523            zdken = min(.99_r8,(1._r8+cwdrag)*max(du(i,k),eu(i,k))*dz(i,k+1)/ &
1524                       max(1.e-10_r8,mu(i,k+1)))
1525            zkine(i,k) = (zkine(i,k+1)*(1._r8-zdken)+zdkbuo)/      &
1526                       (1._r8+zdken)
1527 !        print *,'zkine=',(zkine(i,k)),dz(i,k),k
1528         else
1529 ! Gregory formula
1530            write(*,*) "Gregory vertical velocity"
1531            zbc = tu(i,k)*(1._r8+retv*qu(i,k))
1532            zbe = th(i,k)*(1._r8+retv*qh(i,k))
1533            zbuo(i,k) = (zbc-zbe)/zbe-qr(i,k)-qni(i,k)-qi(i,k)-qc(i,k)
1534            zbuoc= (zbuo(i,k)+zbuo(i,k+1))*0.5_r8
1535            zdkbuo = dz(i,k+1)*grav*zbuoc*(1.0-0.25)/6.
1536            zdken = du(i,k)*dz(i,k+1)/max(1.e-10_r8,mu(i,k+1))
1537            zkine(i,k) = (zkine(i,k+1)*(1._r8-zdken)+zdkbuo)/      &
1538                       (1._r8+zdken)
1539          end if
1540               wu(i,k) = min(15._r8,sqrt(2._r8*max(0.1_r8,zkine(i,k) )))
1541 !dkay         wu(i,k) = wu_kf_act(k)
1542        end if
1543 !             print *,'wu from cke= & kf',wu(i,k),wu_kf_act(k),k
1544 !ckay
1545        arcf(i,k)= mu(i,k)/wu(i,k)
1546
1547 !............................................................................
1548 ! droplet activation
1549 ! calculate potential for droplet activation if cloud water is present
1550 ! formulation from Abdul-Razzak and Ghan (2000) and Abdul-Razzak et al. (1998),
1551 ! AR98
1552
1553        naer2h(i,k,:) = 0.5_r8*(naer2(i,k,:) + naer2(i,k+1,:))
1554        ntaerh(i,k)   = 0.5_r8*(ntaer(i,k) + ntaer(i,k+1))
1555
1556 !      write(*,*)'naer2h(i,k,:)',naer2h(i,k,:)
1557
1558        if (qcic(i,k).ge.qsmall.or.cmel(i,k+1).ge.qsmall ) then
1559
1560 !dkay
1561 ! added qsatzm
1562 !         print *, 'before activate'
1563          call mskf_activate(wu(i,k),t(i,k),rho(i,k), &
1564                  naer2h(i,k,:), naer_cu,naer_cu, maerosol,  &
1565                  dispersion_aer,hygro_aer, density_aer, dum2,qsatzm(i,k))
1566 !             print *,'ccn, massmixing ratio of aerosols='
1567 !            print *, dum2, maerosol
1568          dum2l(i,k) = dum2
1569        else
1570          dum2l(i,k) = 0._r8
1571        end if
1572
1573 ! get droplet activation rate
1574        if (qcic(i,k).ge.qsmall .and. t(i,k).gt.238.15_r8 .and. k.gt.jt(i)+2) then
1575
1576 ! assume aerosols already activated are equal number of existing droplets for
1577 ! simplicity
1578          if (k.eq.kqc(i))  then
1579               npccn(k) = dum2l(i,k)/deltat
1580          else
1581               npccn(k) = (dum2l(i,k)-ncic(i,k))/deltat
1582          end if
1583 ! make sure number activated > 0
1584          npccn(k) = max(0._r8,npccn(k))
1585          ncmax = dum2l(i,k)
1586        else
1587          npccn(k)=0._r8
1588          ncmax = 0._r8
1589        end if
1590
1591 !..............................................................................
1592 !ice nucleation
1593
1594        esi(i,k)= mskf_polysvp(t(i,k),1)      ! over ice
1595        es(i,k) = mskf_polysvp(t(i,k),0)
1596        qs(i,k) = 0.622_r8*es(i,k)/(ph(i,k) - (1.0_r8-0.622_r8)*es(i,k))
1597        qs(i,k) = min(1.0_r8,qs(i,k))
1598        if (qs(i,k) < 0.0_r8)  qs(i,k) = 1.0_r8
1599
1600        relhum(i,k)= 1.0_r8
1601
1602        if (t(i,k).lt.tmelt ) then
1603          if (.true.) then
1604
1605 ! Liu et al.,J. climate, 2007
1606 !         print *, 'before ice nuke'
1607
1608             call mskf_nucleati(wu(i,k),t(i,k),p(i,k),q(i,k),qcic(i,k),rho(i,k),  & ! TWG add p and replace relhum with q
1609                          naer2h(i,k,:),naer_cu,dum2i(i,k) &
1610                         , nihf(i,k),     &
1611                         niimm(i,k),nidep(i,k),nimey(i,k))
1612
1613              nihf(i,k)=nihf(i,k)*rho(i,k)           !  convert from #/kg -> #/m3)
1614              niimm(i,k)=niimm(i,k)*rho(i,k)
1615              nidep(i,k)=nidep(i,k)*rho(i,k)
1616              nimey(i,k)=nimey(i,k)*rho(i,k)
1617           else
1618
1619 ! cooper curve (factor of 1000 is to convert from L-1 to m-3)
1620             dum2i(i,k)=0.005_r8*exp(0.304_r8*(273.15_r8-t(i,k)))*1000._r8
1621 ! put limit on number of nucleated crystals, set to number at T=-30 C
1622 ! cooper (limit to value at -35 C)
1623             dum2i(i,k)=min(dum2i(i,k),208.9e3_r8)/rho(i,k) ! convert from m-3 to kg-1
1624           endif
1625         else
1626           dum2i(i,k)=0._r8
1627         end if
1628 !ckay
1629 !       print *,'nucleated ccn=',dum2i(i,k),k
1630
1631 ! ice nucleation if activated nuclei exist at t<0C
1632
1633         if (dum2i(i,k).gt.0._r8.and.t(i,k).lt.tmelt.and. &
1634            relhum(i,k)*es(i,k)/esi(i,k).gt. 1.05_r8  .and. k.gt.jt(i)+1) then
1635
1636            if (k.eq.kqi(i)) then
1637                 nnuccd(k)=dum2i(i,k)/deltat
1638            else
1639                 nnuccd(k)=(dum2i(i,k)-niic(i,k))/deltat
1640            end if
1641            nnuccd(k)=max(nnuccd(k),0._r8)
1642            nimax = dum2i(i,k)
1643
1644 !Calc mass of new particles using new crystal mass...
1645 !also this will be multiplied by mtime as nnuccd is...
1646            mnuccd(k) = nnuccd(k) * mi0
1647          else
1648            nnuccd(k)=0._r8
1649            nimax = 0._r8
1650            mnuccd(k) = 0._r8
1651          end if
1652 !................................................................................
1653 ! Bergeron process
1654 ! If 0C< T <-40C and both ice and liquid exist
1655
1656          if (t(i,k).le.273.15_r8 .and. t(i,k).gt.233.15_r8 .and.  &
1657               qiic(i,k).gt.0.5e-6_r8 .and. qcic(i,k).gt. qsmall)  then
1658               plevap = qcic(i,k)/bergtsf
1659               prb(k) = max(0._r8,plevap)
1660               nprb(k) = prb(k)/(qcic(i,k)/ncic(i,k))
1661          else
1662               prb(k)=0._r8
1663               nprb(k)=0._r8
1664          end if
1665
1666 !................................................................................
1667 ! heterogeneous freezing of cloud water (-5C < T < -35C)
1668
1669         if (qcic(i,k).ge.qsmall .and.ncic(i,k).gt.0._r8 .and. ntaerh(i,k).gt.0._r8 .and.  &
1670               t(i,k).le.268.15_r8 .and. t(i,k).gt.238.15_r8 ) then
1671
1672           if (.false.)  then
1673 ! immersion freezing (Diehl and Wurzler, 2004)
1674               ttend(k) = -grav*wu(i,k)/cp/(1.0_r8+gamhat(i,k))
1675               naimm = (0.00291_r8*naer2h(i,k,idxbcphi)+32.3_r8*(naer2h(i,k,idxdst1)  &
1676                       +naer2h(i,k,idxdst2)+naer2h(i,k,idxdst3)+              &
1677                        naer2h(i,k,idxdst4)))/ntaerh(i,k)             !m-3
1678               if (ttend(k) .lt. 0._r8) then
1679                  nnuccc(k) = -naimm*exp(273.15_r8-t(i,k))*ttend(k)*qcic(i,k)/rhow   ! kg-1s-1
1680                  mnuccc(k) = nnuccc(k)*qcic(i,k)/ncic(i,k)
1681               end if
1682           else
1683
1684
1685 ! immersion freezing (Bigg, 1953)
1686               mnuccc(k) = pi*pi/36._r8*rhow* &
1687                     cdist1(k)*mskf_GAMMA(7._r8+pgam(k))* &
1688                     bimm*exp(aimm*(273.15_r8-t(i,k)))/ &
1689                     lamc(k)**3/lamc(k)**3
1690
1691               nnuccc(k) = pi/6._r8*cdist1(k)*mskf_GAMMA(pgam(k)+4._r8) &
1692                     *bimm*exp(aimm*(273.15_r8-t(i,k)))/lamc(k)**3
1693            end if
1694
1695 ! contact freezing (Young, 1974) with hooks into simulated dust
1696
1697            tcnt=(270.16_r8-t(i,k))**1.3_r8
1698            viscosity=1.8e-5_r8*(t(i,k)/298.0_r8)**0.85_r8    ! Viscosity (kg/m/s)
1699            mfp=2.0_r8*viscosity/(ph(i,k)  &                  ! Mean free path (m)
1700                *sqrt(8.0_r8*28.96e-3_r8/(pi*8.314409_r8*t(i,k))))
1701
1702            slip1=1.0_r8+(mfp/rn_dst1)*(1.257_r8+(0.4_r8*Exp(-(1.1_r8*rn_dst1/mfp))))! Slip correction factor
1703            slip2=1.0_r8+(mfp/rn_dst2)*(1.257_r8+(0.4_r8*Exp(-(1.1_r8*rn_dst2/mfp))))
1704            slip3=1.0_r8+(mfp/rn_dst3)*(1.257_r8+(0.4_r8*Exp(-(1.1_r8*rn_dst3/mfp))))
1705            slip4=1.0_r8+(mfp/rn_dst4)*(1.257_r8+(0.4_r8*Exp(-(1.1_r8*rn_dst4/mfp))))
1706
1707            dfaer1=1.381e-23_r8*t(i,k)*slip1/(6._r8*pi*viscosity*rn_dst1)  !aerosol diffusivity (m2/s)
1708            dfaer2=1.381e-23_r8*t(i,k)*slip2/(6._r8*pi*viscosity*rn_dst2)
1709            dfaer3=1.381e-23_r8*t(i,k)*slip3/(6._r8*pi*viscosity*rn_dst3)
1710            dfaer4=1.381e-23_r8*t(i,k)*slip4/(6._r8*pi*viscosity*rn_dst4)
1711
1712            nacon1=0.0_r8
1713            nacon2=0.0_r8
1714            nacon3=0.0_r8
1715            nacon4=0.0_r8
1716
1717
1718            if (idxdst1.gt.0) then
1719               nacon1=naer2(i,k,idxdst1)*tcnt *0.0_r8
1720            endif
1721            if (idxdst2.gt.0) then
1722               nacon2=naer2(i,k,idxdst2)*tcnt ! 1/m3
1723            endif
1724            if (idxdst3.gt.0) then
1725               nacon3=naer2(i,k,idxdst3)*tcnt
1726            endif
1727            if (idxdst4.gt.0) then
1728               nacon4=naer2(i,k,idxdst4)*tcnt
1729            endif
1730
1731            mnucct(k) = (dfaer1*nacon1+dfaer2*nacon2+dfaer3*nacon3+dfaer4*nacon4)*pi*pi/3._r8*rhow* &
1732                        cdist1(k)*mskf_GAMMA(pgam(k)+5._r8)/lamc(k)**4
1733
1734            nnucct(k) = (dfaer1*nacon1+dfaer2*nacon2+dfaer3*nacon3+dfaer4*nacon4)*2._r8*pi*  &
1735                        cdist1(k)*mskf_GAMMA(pgam(k)+2._r8)/lamc(k)
1736
1737 !              if (nnuccc(k).gt.nnuccd(k)) then
1738 !                 dum=nnuccd(k)/nnuccc(k)
1739 ! scale mixing ratio of droplet freezing with limit
1740 !                 mnuccc(k)=mnuccc(k)*dum
1741 !                 nnuccc(k)=nnuccd(k)
1742 !              end if
1743
1744            else
1745              mnuccc(k) = 0._r8
1746              nnuccc(k) = 0._r8
1747              mnucct(k) = 0._r8
1748              nnucct(k) = 0._r8
1749            end if
1750
1751 !****************************************************************************************
1752 ! conservation to ensure no negative values of cloud water/precipitation
1753 ! in case microphysical process rates are large
1754 ! note: for check on conservation, processes are multiplied by omsm
1755 ! to prevent problems due to round off error
1756
1757 ! since activation/nucleation processes are fast, need to take into account
1758 ! factor mtime = mixing timescale in cloud / model time step
1759 ! for now mixing timescale is assumed to be 15 min
1760 !*****************************************************************************************
1761
1762        mtime=deltat/900._r8
1763        mtimec=deltat/900._r8
1764
1765        mtime = max(1.0_r8,mtime)   !TWG remove time scale limitation from CAM5
1766        mtimec = max(1.0_r8,mtimec)
1767
1768 ! conservation of qc
1769
1770         qce = mu(i,k)*qc(i,k)+dz(i,k)*(cmel(i,k-1)-du(i,k-1)*qc(i,k))
1771         dum = arcf(i,k)*(pra(k)+prc(k)+prb(k)+mnuccc(k)+mnucct(k)+msacwi(k)+   &
1772                          psacws(k)  )*dz(i,k)
1773         if( qce.lt.0._r8)  then
1774           prc(k) = 0._r8
1775           pra(k) = 0._r8
1776           prb(k) = 0._r8
1777           mnuccc(k) = 0._r8
1778           mnucct(k) = 0._r8
1779           msacwi(k) = 0._r8
1780           psacws(k) = 0._r8
1781         else  if (dum.gt.qce) then
1782           ratio = qce/dum*omsm
1783           prc(k) = prc(k)*ratio
1784           pra(k) = pra(k)*ratio
1785           prb(k) = prb(k)*ratio
1786           mnuccc(k) = mnuccc(k)*ratio
1787           mnucct(k) = mnucct(k)*ratio
1788           msacwi(k) = msacwi(k)*ratio
1789           psacws(k) = psacws(k)*ratio
1790         end if
1791
1792 ! conservation of nc
1793         nce = mu(i,k)*nc(i,k)+(arcf(i,k)*npccn(k)*mtimec-du(i,k-1)*nc(i,k))*dz(i,k)
1794         dum = arcf(i,k)*dz(i,k)*(nprc1(k)+npra(k)+nnuccc(k)+nnucct(k)+ &
1795               npsacws(k)+ nprb(k) )
1796         if (nce.lt.0._r8) then
1797           nprc1(k) = 0._r8
1798 !          nprc(k) = 0._r8
1799           npra(k) = 0._r8
1800           nnuccc(k) = 0._r8
1801           nnucct(k) = 0._r8
1802           npsacws(k) = 0._r8
1803           nprb(k) = 0._r8
1804         else if (dum.gt.nce) then
1805           ratio = nce/dum*omsm
1806           nprc1(k) = nprc1(k)*ratio
1807           npra(k) = npra(k)*ratio
1808           nnuccc(k) = nnuccc(k)*ratio
1809           nnucct(k) = nnucct(k)*ratio
1810           npsacws(k) = npsacws(k)*ratio
1811           nprb(k) = nprb(k)*ratio
1812         end if
1813
1814 ! conservation of qi
1815         qie = mu(i,k)*qi(i,k)+dz(i,k)*(cmei(i,k-1)-du(i,k-1)*qi(i,k)+  &
1816                    ( mnuccc(k)+mnucct(k)+msacwi(k)+prb(k))*arcf(i,k) )
1817         dum = arcf(i,k)*(prci(k)+ prai(k))*dz(i,k)
1818         if (qie.lt.0._r8) then
1819           prci(k) = 0._r8
1820           prai(k) = 0._r8
1821         else if (dum.gt.qie) then
1822           ratio = qie/dum*omsm
1823           prci(k) = prci(k)*ratio
1824           prai(k) = prai(k)*ratio
1825         end if
1826
1827 ! conservation of ni
1828          nie = mu(i,k)*ni(i,k)+dz(i,k)*(nnuccd(k)*mtime*arcf(i,k)-du(i,k-1)*ni(i,k)  &
1829                        + nnucct(k)*arcf(i,k) )
1830          dum = arcf(i,k)*dz(i,k)*(-nsacwi(k)+nprci(k)+ &
1831                nprai(k))
1832          if( nie.lt.0._r8) then
1833            nsacwi(k)= 0._r8
1834            nprci(k) = 0._r8
1835            nprai(k) = 0._r8
1836          else  if (dum.gt.nie) then
1837            ratio = nie/dum*omsm
1838            nsacwi(k)= nsacwi(k)*ratio
1839            nprci(k) = nprci(k)*ratio
1840            nprai(k) = nprai(k)*ratio
1841          end if
1842
1843 ! conservation of qr
1844
1845         qre = mu(i,k)*qr(i,k)+dz(i,k)*(pra(k)+prc(k))*arcf(i,k)
1846         dum = arcf(i,k)*dz(i,k)*(pracs(k)+ mnuccr(k)-prf(k))
1847         if (qre.lt.0._r8) then
1848            prf(k) = 0._r8
1849            pracs(k) = 0._r8
1850            mnuccr(k) = 0._r8
1851         else if (dum.gt.qre) then
1852            ratio = qre/dum*omsm
1853            prf(k) = prf(k)*ratio
1854            pracs(k) = pracs(k)*ratio
1855            mnuccr(k) = mnuccr(k)*ratio
1856         end if
1857
1858 ! conservation of nr
1859          nre = mu(i,k)*nr(i,k)
1860          dum = arcf(i,k)*dz(i,k)*(-nprc(k)+npracs(k)+nnuccr(k) &
1861                    -nragg(k)-pnrf(k))
1862          if(nre.lt.0._r8) then
1863            nprc(k) = 0._r8
1864            npracs(k)= 0._r8
1865            nnuccr(k)= 0._r8
1866            nragg(k) = 0._r8
1867            pnrf(k) = 0._r8
1868          else if (dum.gt.nre) then
1869            ratio = nre/dum*omsm
1870            nprc(k) = nprc(k)*ratio
1871            npracs(k)= npracs(k)*ratio
1872            nnuccr(k)= nnuccr(k)*ratio
1873            nragg(k) = nragg(k)*ratio
1874            pnrf(k) = pnrf(k)*ratio
1875          end if
1876
1877 ! conservation of qni
1878
1879         qnie = mu(i,k)*qni(i,k)+dz(i,k)*( (prai(k)+psacws(k)+prci(k)+     &
1880                    pracs(k)+mnuccr(k))*arcf(i,k) )
1881         dum = arcf(i,k)*dz(i,k)*(-psf(k))
1882
1883         if(qnie.lt.0._r8) then
1884            psf(k) = 0._r8
1885         else if (dum.gt.qnie) then
1886            ratio = qnie/dum*omsm
1887            psf(k) = psf(k)*ratio
1888         end if
1889
1890 ! conservation of ns
1891         nse = mu(i,k)*ns(i,k)+dz(i,k)*(nprci(k)+nnuccr(k))*arcf(i,k)
1892         dum = arcf(i,k)*dz(i,k)*(-nsagg(k)-pnsf(k))
1893         if (nse.lt.0._r8) then
1894            nsagg(k) = 0._r8
1895            pnsf(k) = 0._r8
1896         else if (dum.gt.nse) then
1897            ratio = nse/dum*omsm
1898            nsagg(k) = nsagg(k)*ratio
1899            pnsf(k) = pnsf(k)*ratio
1900         end if
1901
1902 !*****************************************************************************
1903 ! get tendencies due to microphysical conversion processes
1904 !*****************************************************************************
1905
1906       if (k.le.kqc(i))   then
1907         qctend(i,k) = qctend(i,k)+  &
1908                  (-pra(k)-prc(k)-prb(k)-mnuccc(k)-mnucct(k)-msacwi(k)- &
1909                   psacws(k))
1910
1911 !             print *,'qctend components=',qctend(i,k),pra(k),prc(k), &
1912 !             mnuccc(k)-mnucct(k)-msacwi(k),psacws(k)
1913
1914         qitend(i,k) = qitend(i,k)+  &
1915                   (prb(k)+mnuccc(k)+mnucct(k)+msacwi(k)-prci(k)- &
1916                   prai(k)+mnuccd(k)*mtimec) !TWG ice nucleation change
1917
1918         qrtend(i,k) = qrtend(i,k)+ &
1919                  (pra(k)+prc(k))+(-pracs(k)- &
1920                   mnuccr(k))
1921
1922
1923         qnitend(i,k) = qnitend(i,k)+ &
1924                 (prai(k)+psacws(k)+prci(k))+( &
1925                    pracs(k)+mnuccr(k))
1926
1927 ! multiply activation/nucleation by mtime to account for fast timescale
1928
1929         nctend(i,k) = nctend(i,k)+ npccn(k)*mtimec+&
1930                   (-nnuccc(k)-nnucct(k)-npsacws(k) &
1931                   -npra(k)-nprc1(k)-nprb(k))
1932
1933         nitend(i,k) = nitend(i,k)+ nnuccd(k)*mtime+&
1934                   (nnuccc(k)+ nnucct(k)+nsacwi(k)-nprci(k)- &
1935                   nprai(k))
1936
1937         nstend(i,k) = nstend(i,k)+( &
1938                   nsagg(k)+nnuccr(k))+nprci(k)
1939
1940         nrtend(i,k) = nrtend(i,k)+ &
1941                   nprc(k)+(-npracs(k)-nnuccr(k) +nragg(k))
1942
1943 ! for output
1944 ! cloud liquid water-------------
1945         autolm(i,k) = -prc(k)*arcf(i,k)
1946         accrlm(i,k) = -pra(k)*arcf(i,k)
1947         bergnm(i,k) = -prb(k)*arcf(i,k)
1948         fhtimm(i,k) = -mnuccc(k)*arcf(i,k)
1949         fhtctm(i,k) = -mnucct(k)*arcf(i,k)
1950         hmpim (i,k) = -msacwi(k)*arcf(i,k)
1951         accslm(i,k) = -psacws(k)*arcf(i,k)
1952         collrm(i,k) = -pracs(k)*arcf(i,k)
1953         collrn(i,k) = -npracs(k)*arcf(i,k)
1954         fhtcrm(i,k) = -mnuccr(k)*arcf(i,k)
1955         fhtcrn(i,k) = -nnuccr(k)*arcf(i,k)
1956         dlfm  (i,k) = -du(i,k)*qc(i,k)
1957
1958         autoln(i,k) = -nprc1(k)*arcf(i,k)*rho(i,k)
1959         autorn(i,k) = -nprc(k)*arcf(i,k)*rho(i,k)
1960         aggrn(i,k) =  nragg(k)*arcf(i,k)*rho(i,k)
1961         aggsn(i,k) =  nsagg(k)*arcf(i,k)*rho(i,k)
1962         accrln(i,k) = -npra(k)*arcf(i,k)*rho(i,k)
1963         bergnn(i,k) = -nprb(k)*arcf(i,k)*rho(i,k)
1964         fhtimn(i,k) = -nnuccc(k)*arcf(i,k)*rho(i,k)
1965         fhtctn(i,k) = -nnucct(k)*arcf(i,k)*rho(i,k)
1966         accsln(i,k) = -npsacws(k)*arcf(i,k)*rho(i,k)
1967         activn(i,k) = npccn(k)*mtimec*arcf(i,k)*rho(i,k)
1968         dlfn  (i,k) = -du(i,k)*nc(i,k)*rho(i,k)
1969 !cloud ice------------------------
1970         autoim(i,k) = -prci(k)*arcf(i,k)
1971         accsim(i,k) = -prai(k)*arcf(i,k)
1972         difm  (i,k) = -du(i,k)*qi(i,k)             !TWG 2017 change -du(i,k+1)*qi(i,k)
1973
1974         nuclin(i,k) = nnuccd(k)*mtime*arcf(i,k)*rho(i,k)
1975         nuclim(i,k) = mnuccd(k)*mtime*arcf(i,k)*rho(i,k)
1976         autoin(i,k) = -nprci(k)*arcf(i,k)*rho(i,k)
1977         accsin(i,k) = -nprai(k)*arcf(i,k)*rho(i,k)
1978         hmpin (i,k)  = nsacwi(k)*arcf(i,k)*rho(i,k)
1979         difn  (i,k) = -du(i,k)*ni(i,k)*rho(i,k)
1980       else
1981         qctend(i,k) = 0._r8
1982         qitend(i,k) = 0._r8
1983         qrtend(i,k) = 0._r8
1984         qnitend(i,k) = 0._r8
1985         nctend(i,k) = 0._r8
1986         nitend(i,k) = 0._r8
1987         nstend(i,k) = 0._r8
1988         nrtend(i,k) = 0._r8
1989       end if
1990
1991 !********************************************************************************
1992 !  vertical integration
1993 !********************************************************************************
1994 ! snow
1995         if ( k.le.kqi(i) ) then
1996           qni(i,k-1) = 1._r8/mu(i,k-1)*                                    &
1997                    (mu(i,k)*qni(i,k)+dz(i,k)*(qnitend(i,k)+psf(k))*arcf(i,k) )
1998
1999           ns(i,k-1) = 1._r8/mu(i,k-1)*                                    &
2000                    (mu(i,k)*ns(i,k)+dz(i,k)*(nstend(i,k)+pnsf(k))*arcf(i,k) )
2001
2002          else
2003            qni(i,k-1)=0._r8
2004            ns(i,k-1)=0._r8
2005          end if
2006
2007          if (qni(i,k-1).le.0._r8) then
2008           qni(i,k-1)=0._r8
2009           ns(i,k-1)=0._r8
2010          end if
2011
2012 ! rain
2013          if (k.le.kqc(i) ) then
2014           qr(i,k-1) = 1._r8/mu(i,k-1)*                                    &
2015                    (mu(i,k)*qr(i,k)+dz(i,k)*(qrtend(i,k)+prf(k))*arcf(i,k) )
2016
2017           nr(i,k-1) = 1._r8/mu(i,k-1)*                                    &
2018                    (mu(i,k)*nr(i,k)+dz(i,k)*(nrtend(i,k)+pnrf(k))*arcf(i,k) )
2019
2020         else
2021           qr(i,k-1)=0._r8
2022           nr(i,k-1)=0._r8
2023         end if
2024
2025         if( qr(i,k-1) .le. 0._r8) then
2026           qr(i,k-1)=0._r8
2027           nr(i,k-1)=0._r8
2028         end if
2029
2030 ! freeze rain homogeneously at -40 C
2031
2032          if (t(i,k-1) < 233.15_r8 .and. qr(i,k-1) > 0._r8) then
2033
2034 ! make sure freezing rain doesn't increase temperature above threshold
2035           dum = xlf/cp*qr(i,k-1)
2036           if (t(i,k-1)+dum.gt.233.15_r8) then
2037               dum = -(t(i,k-1)-233.15_r8)*cp/xlf
2038 !bugfix 2012-01-06              dum = dum/(xlf/cp*qr(i,k-1))
2039               dum = dum/qr(i,k-1)
2040               dum = max(0._r8,dum)
2041               dum = min(1._r8,dum)
2042           else
2043               dum = 1._r8
2044           end if
2045           qni(i,k-1)=qni(i,k-1)+dum*qr(i,k-1)
2046           ns(i,k-1)=ns(i,k-1)+dum*nr(i,k-1)
2047           qr(i,k-1)=(1._r8-dum)*qr(i,k-1)
2048           nr(i,k-1)=(1._r8-dum)*nr(i,k-1)
2049           fhmrm(i,k-1) = -mu(i,k-1)*dum*qr(i,k-1)/dz(i,k)
2050         end if
2051
2052 !        if( qr(i,k-1) .le. 0._r8) then
2053 !          qr(i,k-1)=0._r8
2054 !          nr(i,k-1)=0._r8
2055 !        end if
2056
2057 ! cloud water
2058          if ( k.le.kqc(i) ) then
2059           qc(i,k-1) = 1._r8/mu(i,k-1)*                                    &
2060                    (mu(i,k)*qc(i,k)-dz(i,k)*du(i,k-1)*qc(i,k)             &
2061                     +dz(i,k)*qctend(i,k)*arcf(i,k)+dz(i,k)*cmel(i,k-1) )
2062
2063           nc(i,k-1) = 1._r8/mu(i,k-1)*                                    &
2064                    (mu(i,k)*nc(i,k)-dz(i,k)*du(i,k-1)*nc(i,k)             &
2065                     +dz(i,k)*nctend(i,k)*arcf(i,k) )
2066
2067         else
2068           qc(i,k-1)=0._r8
2069           nc(i,k-1)=0._r8
2070         end if
2071
2072         qcorg = qc(i,k-1)
2073         ncorg = nc(i,k-1)
2074         if (qc(i,k-1).le. 0._r8) then
2075           qc(i,k-1)=0._r8
2076           nc(i,k-1)=0._r8
2077         end if
2078         qcadj(i,k-1)= (qc(i,k-1)- qcorg)*mu(i,k-1)/dz(i,k)*rho(i,k)
2079         ncadj(i,k-1)= (nc(i,k-1)- ncorg)*mu(i,k-1)/dz(i,k)*rho(i,k)
2080
2081 ! cloud ice
2082          if( k.le.kqi(i)) then
2083            qi(i,k-1) = 1._r8/mu(i,k-1)*                                    &
2084                    (mu(i,k)*qi(i,k)-dz(i,k)*du(i,k-1)*qi(i,k)             &
2085                     +dz(i,k)*qitend(i,k)*arcf(i,k)+dz(i,k)*cmei(i,k-1) )
2086
2087            ni(i,k-1) = 1._r8/mu(i,k-1)*                                    &
2088                    (mu(i,k)*ni(i,k)-dz(i,k)*du(i,k-1)*ni(i,k)             &
2089                     +dz(i,k)*nitend(i,k)*arcf(i,k) )
2090
2091          else
2092           qi(i,k-1)=0._r8
2093           ni(i,k-1)=0._r8
2094          end if
2095
2096         qiorg = qi(i,k-1)
2097         niorg = ni(i,k-1)
2098         if (qi(i,k-1).le. 0._r8) then
2099           qi(i,k-1)=0._r8
2100           ni(i,k-1)=0._r8
2101         end if
2102         qiadj(i,k-1)= (qi(i,k-1)- qiorg)*mu(i,k-1)/dz(i,k)*rho(i,k)
2103         niadj(i,k-1)= (ni(i,k-1)- niorg)*mu(i,k-1)/dz(i,k)*rho(i,k)
2104
2105 !        trspcm(i,k-1) = (mu(i,k)*qc(i,k) - mu(i,k-1)*qc(i,k-1))/dz(i,k)
2106 !        trspcn(i,k-1) = (mu(i,k)*nc(i,k) -
2107 !        mu(i,k-1)*nc(i,k-1))/dz(i,k)*rho(i,k)
2108 !        trspim(i,k-1) = (mu(i,k)*qi(i,k) - mu(i,k-1)*qi(i,k-1))/dz(i,k)
2109 !        trspin(i,k-1) = (mu(i,k)*ni(i,k) -
2110 !        mu(i,k-1)*ni(i,k-1))/dz(i,k)*rho(i,k)
2111
2112
2113 ! freeze rain homogeneously at -38 C
2114          if (t(i,k-1) < 233.15_r8 .and. qc(i,k-1) > 0._r8) then
2115 ! make sure freezing rain doesn't increase temperature above threshold
2116           dum = xlf/cp*qc(i,k-1)
2117           if (t(i,k-1)+dum.gt.233.15_r8) then
2118               dum = -(t(i,k-1)-233.15_r8)*cp/xlf
2119 !bugfix 2012-01-06      dum = dum/(xlf/cp*qc(i,k-1))
2120               dum = dum/qc(i,k-1)
2121               dum = max(0._r8,dum)
2122               dum = min(1._r8,dum)
2123           else
2124               dum = 1._r8
2125           end if
2126           qi(i,k-1)=qi(i,k-1)+dum*qc(i,k-1)
2127           ni(i,k-1)=ni(i,k-1)+dum*nc(i,k-1)
2128           fhmlm(i,k-1) = -mu(i,k-1)*dum*qc(i,k-1)/dz(i,k)
2129           fhmln(i,k-1) = -mu(i,k-1)*dum*nc(i,k-1)/dz(i,k)*rho(i,k)
2130           qc(i,k-1)=(1._r8-dum)*qc(i,k-1)
2131           nc(i,k-1)=(1._r8-dum)*nc(i,k-1)
2132         end if
2133
2134         frz(i,k-1) = cmei(i,k-1) + arcf(i,k)*(prb(k)+mnuccc(k)+mnucct(k)+msacwi(k)+   &
2135                      pracs(k)+mnuccr(k)+psacws(k) )-fhmlm(i,k-1)-fhmrm(i,k-1)
2136
2137 !******************************************************************************
2138 ! get size distribution parameters based on in-cloud cloud water/ice
2139 ! these calculations also ensure consistency between number and mixing ratio
2140
2141 ! following equation(2,3,4) of Morrison and Gettelman, 2008, J. Climate.
2142 ! Gamma(n)= (n-1)!
2143 ! lamc <-> lambda for cloud liquid water
2144 ! pgam <-> meu    for cloud liquid water
2145 ! meu=0 for ice,rain and snow
2146 !*******************************************************************************
2147 !songxl 2011-12-31
2148
2149            niorg = ni(i,k-1)
2150
2151 ! cloud ice
2152            if (qi(i,k-1).ge.qsmall) then
2153 ! add upper limit to in-cloud number concentration to prevent numerical error
2154               ni(i,k-1)=min(ni(i,k-1),qi(i,k-1)*1.e20_r8)
2155               lami(k-1) = (mskf_gamma(1._r8+di)*ci* &
2156                   ni(i,k-1)/qi(i,k-1))**(1._r8/di)
2157               n0i(k-1) = ni(i,k-1)*lami(k-1)
2158 ! check for slope
2159               lammax = 1._r8/10.e-6_r8
2160               lammin = 1._r8/(2._r8*dcs)
2161 ! adjust vars
2162               if (lami(k-1).lt.lammin) then
2163                 lami(k-1) = lammin
2164                 n0i(k-1) = lami(k-1)**(di+1._r8)*qi(i,k-1)/(ci*mskf_gamma(1._r8+di))
2165                 ni(i,k-1) = n0i(k-1)/lami(k-1)
2166               else if (lami(k-1).gt.lammax) then
2167                 lami(k-1) = lammax
2168                 n0i(k-1) = lami(k-1)**(di+1._r8)*qi(i,k-1)/(ci*mskf_gamma(1._r8+di))
2169                 ni(i,k-1) = n0i(k-1)/lami(k-1)
2170               end if
2171               effi(i,k-1) = 1.5_r8/lami(k-1)*1.e6_r8
2172            else
2173               lami(k-1) = 0._r8
2174               n0i(k-1) = 0._r8
2175               effi(i,k-1) = 0._r8
2176            end if
2177
2178 !songxl 2011-12-31-----
2179            niadj(i,k-1)= niadj(i,k-1)+(ni(i,k-1)-niorg)*mu(i,k-1)/dz(i,k)*rho(i,k)
2180 !................................................................................
2181 !songxl 2011-12-31
2182               ncorg = nc(i,k-1)
2183
2184 !cloud water
2185            if (qc(i,k-1).ge.qsmall) then
2186
2187 ! add upper limit to in-cloud number concentration to prevent numerical error
2188               nc(i,k-1)=min(nc(i,k-1),qc(i,k-1)*1.e20_r8)
2189
2190 ! get pgam from fit to observations of martin et al. 1994
2191
2192               pgam(k-1)=0.0005714_r8*(nc(i,k-1)/1.e6_r8*rho(i,k-1))+0.2714_r8 !TWG 2017 change / to * in front of rho
2193               pgam(k-1)=1._r8/(pgam(k-1)**2)-1._r8
2194               pgam(k-1)=max(pgam(k-1),2._r8)
2195               pgam(k-1)=min(pgam(k-1),15._r8)
2196 ! calculate lamc
2197
2198               lamc(k-1) = (pi/6._r8*rhow*nc(i,k-1)*mskf_gamma(pgam(k-1)+4._r8)/ &
2199                  (qc(i,k-1)*mskf_gamma(pgam(k-1)+1._r8)))**(1._r8/3._r8)
2200
2201 ! lammin, 50 micron diameter max mean size
2202               lammin = (pgam(k)+1._r8)/50.e-6_r8
2203               lammax = (pgam(k-1)+1._r8)/2.e-6_r8
2204
2205               if (lamc(k-1).lt.lammin) then
2206                  lamc(k-1) = lammin
2207                  nc(i,k-1) = 6._r8*lamc(k-1)**3*qc(i,k-1)* &
2208                       mskf_gamma(pgam(k-1)+1._r8)/ &
2209                       (pi*rhow*mskf_gamma(pgam(k-1)+4._r8))
2210               else if (lamc(k-1).gt.lammax) then
2211                  lamc(k-1) = lammax
2212                  nc(i,k-1) = 6._r8*lamc(k-1)**3*qc(i,k-1)* &
2213                        mskf_gamma(pgam(k-1)+1._r8)/ &
2214                       (pi*rhow*mskf_gamma(pgam(k-1)+4._r8))
2215               end if
2216               effc(i,k-1) = mskf_gamma(pgam(k-1)+4._r8)/ &
2217                             mskf_gamma(pgam(k-1)+3._r8)/lamc(k-1)/2._r8*1.e6_r8
2218 ! parameter to calculate droplet freezing
2219
2220               cdist1(k-1) = nc(i,k-1)/mskf_gamma(pgam(k-1)+1._r8)
2221            else
2222               lamc(k-1) = 0._r8
2223               cdist1(k-1) = 0._r8
2224               effc(i,k-1) = 0._r8
2225            end if
2226
2227 !songxl 2011-12-31-----
2228            ncadj(i,k-1) = ncadj(i,k-1)+ (nc(i,k-1)-ncorg)*mu(i,k-1)/dz(i,k)*rho(i,k)
2229
2230            trspcm(i,k-1) = (mu(i,k)*qc(i,k) - mu(i,k-1)*qc(i,k-1))/dz(i,k)
2231            trspcn(i,k-1) = (mu(i,k)*nc(i,k) - mu(i,k-1)*nc(i,k-1))/dz(i,k)*rho(i,k)
2232            trspim(i,k-1) = (mu(i,k)*qi(i,k) - mu(i,k-1)*qi(i,k-1))/dz(i,k)
2233            trspin(i,k-1) = (mu(i,k)*ni(i,k) - mu(i,k-1)*ni(i,k-1))/dz(i,k)*rho(i,k)
2234
2235            if (k-1 .eq. jt(i)+1)  then
2236              trspcm(i,k-2) =  mu(i,k-1)*qc(i,k-1)/dz(i,k)
2237              trspcn(i,k-2) =  mu(i,k-1)*nc(i,k-1)/dz(i,k)*rho(i,k)
2238              trspim(i,k-2) =  mu(i,k-1)*qi(i,k-1)/dz(i,k)
2239              trspin(i,k-2) =  mu(i,k-1)*ni(i,k-1)/dz(i,k)*rho(i,k)
2240              dlfm  (i,k-2) = -du(i,k-2)*qc(i,k-1)
2241              dlfn  (i,k-2) = -du(i,k-2)*nc(i,k-1)*rho(i,k)
2242              difm  (i,k-2) = -du(i,k-2)*qi(i,k-1)
2243              difn  (i,k-2) = -du(i,k-2)*ni(i,k-1)*rho(i,k)
2244            end if
2245 !.......................................................................
2246 ! get size distribution parameters for precip
2247 !......................................................................
2248 ! rain
2249            if (qr(i,k-1).ge.qsmall) then
2250
2251              lamr(k-1) = (pi*rhow*nr(i,k-1)/qr(i,k-1))**(1._r8/3._r8)
2252              n0r(k-1) = nr(i,k-1)*lamr(k-1)
2253 ! check for slope
2254              lammax = 1._r8/20.e-6_r8
2255              lammin = 1._r8/500.e-6_r8
2256 ! adjust vars
2257              if (lamr(k-1).lt.lammin) then
2258                lamr(k-1) = lammin
2259                n0r(k-1) = lamr(k-1)**4*qr(i,k-1)/(pi*rhow)
2260                nr(i,k-1) = n0r(k-1)/lamr(k-1)
2261              else if (lamr(k-1).gt.lammax) then
2262                lamr(k-1) = lammax
2263                n0r(k-1) = lamr(k-1)**4*qr(i,k-1)/(pi*rhow)
2264                nr(i,k-1) = n0r(k-1)/lamr(k-1)
2265              end if
2266            else
2267              lamr(k-1) = 0._r8
2268              n0r(k-1) = 0._r8
2269            end if
2270 !......................................................................
2271 ! snow
2272            if (qni(i,k-1).ge.qsmall) then
2273              lams(k-1) = (mskf_gamma(1._r8+ds)*cs*ns(i,k-1)/ &
2274                        qni(i,k-1))**(1._r8/ds)
2275              n0s(k-1) = ns(i,k-1)*lams(k-1)
2276
2277 ! check for slope
2278              lammax = 1._r8/10.e-6_r8
2279              lammin = 1._r8/2000.e-6_r8
2280 ! adjust vars
2281              if (lams(k-1).lt.lammin) then
2282                lams(k-1) = lammin
2283                n0s(k-1) = lams(k-1)**(ds+1._r8)*qni(i,k-1)/(cs*mskf_gamma(1._r8+ds))
2284                ns(i,k-1) = n0s(k-1)/lams(k-1)
2285              else if (lams(k-1).gt.lammax) then
2286                lams(k-1) = lammax
2287                n0s(k-1) = lams(k-1)**(ds+1._r8)*qni(i,k-1)/(cs*mskf_gamma(1._r8+ds))
2288                ns(i,k-1) = n0s(k-1)/lams(k-1)
2289              end if
2290              effs(i,k-1) = 1.5_r8/lams(k-1)*1.e6_r8
2291            else
2292              lams(k-1) = 0._r8
2293              n0s(k-1) = 0._r8
2294              effs(i,k-1) = 0._r8
2295            end if
2296
2297 !dkay : since KF treats rain and snow separately, no need to add snow to the
2298 !rprd (kg/kg/m)
2299 !dkay        rprd(i,k-1)= (qnitend(i,k) + qrtend(i,k))*arcf(i,k)    ! original
2300         rprd(i,k-1)=  qrtend(i,k)  *arcf(i,k)
2301         sprd(i,k-1)=  qnitend(i,k) *arcf(i,k)
2302
2303 !dkay
2304 !dkay       print *,'k,rprd,qrtend,qcic
2305 !=',k,rprd(i,k-1),qrtend(i,k-1),qcic(i,k-1)
2306 !dkay
2307      end if  ! k<jlcl
2308
2309 ! if rain/snow mix ratio is zero so should number concentration
2310
2311          if (qni(i,k-1).lt.qsmall) then
2312            qni(i,k-1)=0._r8
2313            ns(i,k-1)=0._r8
2314          end if
2315
2316          if (qr(i,k-1).lt.qsmall) then
2317            qr(i,k-1)=0._r8
2318            nr(i,k-1)=0._r8
2319          end if
2320          if (qi(i,k-1).lt.qsmall) then
2321            qi(i,k-1)=0._r8
2322            ni(i,k-1)=0._r8
2323          end if
2324
2325          if (qc(i,k-1).lt.qsmall) then
2326            qc(i,k-1)=0._r8
2327            nc(i,k-1)=0._r8
2328          end if
2329
2330 ! make sure number concentration is a positive number to avoid
2331 ! taking root of negative
2332
2333          nr(i,k-1)=max(nr(i,k-1),0._r8)
2334          ns(i,k-1)=max(ns(i,k-1),0._r8)
2335          ni(i,k-1)=max(ni(i,k-1),0._r8)
2336          nc(i,k-1)=max(nc(i,k-1),0._r8)
2337 !!......................................................................
2338 !dkay
2339   !      frz(i,k) = amin1(1.E-07, frz(i,k))  ! constrain frz
2340        end do ! k loop
2341 !dkay          print *,'jb, jt=',jb(i), jt(i)
2342        end do ! it loop, iteration
2343 300    continue  ! continue if no cloud water
2344        end do ! i loop
2345 !........................................................................
2346
2347 !        deallocate( &
2348 !         naermod,  &
2349 !         naer2,    &
2350 !         naer2h,    &
2351 !         maerosol)
2352
2353 !        deallocate( &
2354 !         naermod,  &
2355 !         naer2,    &
2356 !         naer2h,    &
2357 !         maerosol)
2358
2359 return
2360 end subroutine mskf_mphy
2361
2362 !##############################################################################
2363
2364
2365 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
2366
2367       FUNCTION mskf_GAMMA(X)
2368
2369 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
2370
2371 !D    DOUBLE PRECISION FUNCTION DGAMMA(X)
2372 !----------------------------------------------------------------------
2373 !
2374 ! THIS ROUTINE CALCULATES THE GAMMA FUNCTION FOR A REAL ARGUMENT X.
2375 !   COMPUTATION IS BASED ON AN ALGORITHM OUTLINED IN REFERENCE 1.
2376 !   THE PROGRAM USES RATIONAL FUNCTIONS THAT APPROXIMATE THE GAMMA
2377 !   FUNCTION TO AT LEAST 20 SIGNIFICANT DECIMAL DIGITS.  COEFFICIENTS
2378 !   FOR THE APPROXIMATION OVER THE INTERVAL (1,2) ARE UNPUBLISHED.
2379 !   THOSE FOR THE APPROXIMATION FOR X .GE. 12 ARE FROM REFERENCE 2.
2380 !   THE ACCURACY ACHIEVED DEPENDS ON THE ARITHMETIC SYSTEM, THE
2381 !   COMPILER, THE INTRINSIC FUNCTIONS, AND PROPER SELECTION OF THE
2382 !   MACHINE-DEPENDENT CONSTANTS.
2383 !
2384 !
2385 !*******************************************************************
2386 !*******************************************************************
2387 !
2388 ! EXPLANATION OF MACHINE-DEPENDENT CONSTANTS
2389 !
2390 ! BETA   - RADIX FOR THE FLOATING-POINT REPRESENTATION
2391 ! MAXEXP - THE SMALLEST POSITIVE POWER OF BETA THAT OVERFLOWS
2392 ! XBIG   - THE LARGEST ARGUMENT FOR WHICH GAMMA(X) IS REPRESENTABLE
2393 !          IN THE MACHINE, I.E., THE SOLUTION TO THE EQUATION
2394 !                  GAMMA(XBIG) = BETA**MAXEXP
2395 ! XINF   - THE LARGEST MACHINE REPRESENTABLE FLOATING-POINT NUMBER;
2396 !          APPROXIMATELY BETA**MAXEXP
2397 ! EPS    - THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH THAT
2398 !          1.0+EPS .GT. 1.0
2399 ! XMININ - THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH THAT
2400 !          1/XMININ IS MACHINE REPRESENTABLE
2401 !
2402 !     APPROXIMATE VALUES FOR SOME IMPORTANT MACHINES ARE:
2403 !
2404 !                            BETA       MAXEXP        XBIG
2405 !
2406 ! CRAY-1         (S.P.)        2         8191        966.961
2407 ! CYBER 180/855
2408 !   UNDER NOS    (S.P.)        2         1070        177.803
2409 ! IEEE (IBM/XT,
2410 !   SUN, ETC.)   (S.P.)        2          128        35.040
2411 ! IEEE (IBM/XT,
2412 !   SUN, ETC.)   (D.P.)        2         1024        171.624
2413 ! IBM 3033       (D.P.)       16           63        57.574
2414 ! VAX D-FORMAT   (D.P.)        2          127        34.844
2415 ! VAX G-FORMAT   (D.P.)        2         1023        171.489
2416 !
2417 !                            XINF         EPS        XMININ
2418 !
2419 ! CRAY-1         (S.P.)   5.45E+2465   7.11E-15    1.84E-2466
2420 ! CYBER 180/855
2421 !   UNDER NOS    (S.P.)   1.26E+322    3.55E-15    3.14E-294
2422 ! IEEE (IBM/XT,
2423 !   SUN, ETC.)   (S.P.)   3.40E+38     1.19E-7     1.18E-38
2424 ! IEEE (IBM/XT,
2425 !   SUN, ETC.)   (D.P.)   1.79D+308    2.22D-16    2.23D-308
2426 ! IBM 3033       (D.P.)   7.23D+75     2.22D-16    1.39D-76
2427 ! VAX D-FORMAT   (D.P.)   1.70D+38     1.39D-17    5.88D-39
2428 ! VAX G-FORMAT   (D.P.)   8.98D+307    1.11D-16    1.12D-308
2429 !
2430 !*******************************************************************
2431 !*******************************************************************
2432 !
2433 ! ERROR RETURNS
2434 !
2435 !  THE PROGRAM RETURNS THE VALUE XINF FOR SINGULARITIES OR
2436 !     WHEN OVERFLOW WOULD OCCUR.  THE COMPUTATION IS BELIEVED
2437 !     TO BE FREE OF UNDERFLOW AND OVERFLOW.
2438 !
2439 !
2440 !  INTRINSIC FUNCTIONS REQUIRED ARE:
2441 !
2442 !     INT, DBLE, EXP, LOG, REAL, SIN
2443 !
2444 !
2445 ! REFERENCES:  AN OVERVIEW OF SOFTWARE DEVELOPMENT FOR SPECIAL
2446 !              FUNCTIONS   W. J. CODY, LECTURE NOTES IN MATHEMATICS,
2447 !              506, NUMERICAL ANALYSIS DUNDEE, 1975, G. A. WATSON
2448 !              (ED.), SPRINGER VERLAG, BERLIN, 1976.
2449 !
2450 !              COMPUTER APPROXIMATIONS, HART, ET. AL., WILEY AND
2451 !              SONS, NEW YORK, 1968.
2452 !
2453 !  LATEST MODIFICATION: OCTOBER 12, 1989
2454 !
2455 !  AUTHORS: W. J. CODY AND L. STOLTZ
2456 !           APPLIED MATHEMATICS DIVISION
2457 !           ARGONNE NATIONAL LABORATORY
2458 !           ARGONNE, IL 60439
2459 !
2460 !----------------------------------------------------------------------
2461       INTEGER I,N
2462       LOGICAL PARITY
2463
2464       real(r8) mskf_GAMMA
2465       REAL(r8) &
2466 !D    DOUBLE PRECISION
2467          C,CONV,EPS,FACT,HALF,ONE,P,PI,Q,RES,SQRTPI,SUM,TWELVE, &
2468          TWO,X,XBIG,XDEN,XINF,XMININ,XNUM,Y,Y1,YSQ,Z,ZERO
2469       DIMENSION C(7),P(8),Q(8)
2470 !----------------------------------------------------------------------
2471 !  MATHEMATICAL CONSTANTS
2472 !----------------------------------------------------------------------
2473       DATA ONE,HALF,TWELVE,TWO,ZERO/1.0E0_r8,0.5E0_r8,12.0E0_r8,2.0E0_r8,0.0E0_r8/, &
2474           SQRTPI/0.9189385332046727417803297E0_r8/, &
2475           PI/3.1415926535897932384626434E0_r8/
2476 !D    DATA ONE,HALF,TWELVE,TWO,ZERO/1.0D0,0.5D0,12.0D0,2.0D0,0.0D0/,
2477 !D   1     SQRTPI/0.9189385332046727417803297D0/,
2478 !D   2     PI/3.1415926535897932384626434D0/
2479 !----------------------------------------------------------------------
2480 !  MACHINE DEPENDENT PARAMETERS
2481 !----------------------------------------------------------------------
2482       DATA XBIG,XMININ,EPS/35.040E0_r8,1.18E-38_r8,1.19E-7_r8/, &
2483           XINF/3.4E38_r8/
2484 !D    DATA XBIG,XMININ,EPS/171.624D0,2.23D-308,2.22D-16/,
2485 !D   1     XINF/1.79D308/
2486 !----------------------------------------------------------------------
2487 !  NUMERATOR AND DENOMINATOR COEFFICIENTS FOR RATIONAL MINIMAX
2488 !     APPROXIMATION OVER (1,2).
2489 !----------------------------------------------------------------------
2490       DATA P/-1.71618513886549492533811E+0_r8,2.47656508055759199108314E+1_r8,&
2491             -3.79804256470945635097577E+2_r8,6.29331155312818442661052E+2_r8,&
2492             8.66966202790413211295064E+2_r8,-3.14512729688483675254357E+4_r8,&
2493             -3.61444134186911729807069E+4_r8,6.64561438202405440627855E+4_r8/
2494       DATA Q/-3.08402300119738975254353E+1_r8,3.15350626979604161529144E+2_r8,&
2495            -1.01515636749021914166146E+3_r8,-3.10777167157231109440444E+3_r8,&
2496              2.25381184209801510330112E+4_r8,4.75584627752788110767815E+3_r8,&
2497            -1.34659959864969306392456E+5_r8,-1.15132259675553483497211E+5_r8/
2498 !D    DATA P/-1.71618513886549492533811D+0,2.47656508055759199108314D+1,
2499 !D   1       -3.79804256470945635097577D+2,6.29331155312818442661052D+2,
2500 !D   2       8.66966202790413211295064D+2,-3.14512729688483675254357D+4,
2501 !D   3       -3.61444134186911729807069D+4,6.64561438202405440627855D+4/
2502 !D    DATA Q/-3.08402300119738975254353D+1,3.15350626979604161529144D+2,
2503 !D   1      -1.01515636749021914166146D+3,-3.10777167157231109440444D+3,
2504 !D   2        2.25381184209801510330112D+4,4.75584627752788110767815D+3,
2505 !D   3      -1.34659959864969306392456D+5,-1.15132259675553483497211D+5/
2506 !----------------------------------------------------------------------
2507 !  COEFFICIENTS FOR MINIMAX APPROXIMATION OVER (12, INF).
2508 !----------------------------------------------------------------------
2509       DATA C/-1.910444077728E-03_r8,8.4171387781295E-04_r8, &
2510           -5.952379913043012E-04_r8,7.93650793500350248E-04_r8,&
2511           -2.777777777777681622553E-03_r8,8.333333333333333331554247E-02_r8,&
2512            5.7083835261E-03_r8/
2513 !D    DATA C/-1.910444077728D-03,8.4171387781295D-04,
2514 !D   1     -5.952379913043012D-04,7.93650793500350248D-04,
2515 !D   2     -2.777777777777681622553D-03,8.333333333333333331554247D-02,
2516 !D   3      5.7083835261D-03/
2517 !----------------------------------------------------------------------
2518 !  STATEMENT FUNCTIONS FOR CONVERSION BETWEEN INTEGER AND FLOAT
2519 !----------------------------------------------------------------------
2520       CONV(I) = REAL(I,r8)
2521 !D    CONV(I) = DBLE(I)
2522       PARITY=.FALSE.
2523       FACT=ONE
2524       N=0
2525       Y=X
2526       IF(Y.LE.ZERO)THEN
2527 !----------------------------------------------------------------------
2528 !  ARGUMENT IS NEGATIVE
2529 !----------------------------------------------------------------------
2530         Y=-X
2531         Y1=AINT(Y)
2532         RES=Y-Y1
2533         IF(RES.NE.ZERO)THEN
2534           IF(Y1.NE.AINT(Y1*HALF)*TWO)PARITY=.TRUE.
2535           FACT=-PI/SIN(PI*RES)
2536           Y=Y+ONE
2537         ELSE
2538           RES=XINF
2539           GOTO 900
2540         ENDIF
2541       ENDIF
2542 !----------------------------------------------------------------------
2543 !  ARGUMENT IS POSITIVE
2544 !----------------------------------------------------------------------
2545       IF(Y.LT.EPS)THEN
2546 !----------------------------------------------------------------------
2547 !  ARGUMENT .LT. EPS
2548 !----------------------------------------------------------------------
2549         IF(Y.GE.XMININ)THEN
2550           RES=ONE/Y
2551         ELSE
2552           RES=XINF
2553           GOTO 900
2554         ENDIF
2555       ELSEIF(Y.LT.TWELVE)THEN
2556         Y1=Y
2557         IF(Y.LT.ONE)THEN
2558 !----------------------------------------------------------------------
2559 !  0.0 .LT. ARGUMENT .LT. 1.0
2560 !----------------------------------------------------------------------
2561           Z=Y
2562           Y=Y+ONE
2563         ELSE
2564 !----------------------------------------------------------------------
2565 !  1.0 .LT. ARGUMENT .LT. 12.0, REDUCE ARGUMENT IF NECESSARY
2566 !----------------------------------------------------------------------
2567           N=INT(Y)-1
2568           Y=Y-CONV(N)
2569           Z=Y-ONE
2570         ENDIF
2571 !----------------------------------------------------------------------
2572 !  EVALUATE APPROXIMATION FOR 1.0 .LT. ARGUMENT .LT. 2.0
2573 !----------------------------------------------------------------------
2574         XNUM=ZERO
2575         XDEN=ONE
2576         DO 260 I=1,8
2577           XNUM=(XNUM+P(I))*Z
2578           XDEN=XDEN*Z+Q(I)
2579   260   CONTINUE
2580         RES=XNUM/XDEN+ONE
2581         IF(Y1.LT.Y)THEN
2582 !----------------------------------------------------------------------
2583 !  ADJUST RESULT FOR CASE  0.0 .LT. ARGUMENT .LT. 1.0
2584 !----------------------------------------------------------------------
2585           RES=RES/Y1
2586         ELSEIF(Y1.GT.Y)THEN
2587 !----------------------------------------------------------------------
2588 !  ADJUST RESULT FOR CASE  2.0 .LT. ARGUMENT .LT. 12.0
2589 !----------------------------------------------------------------------
2590           DO 290 I=1,N
2591             RES=RES*Y
2592             Y=Y+ONE
2593   290     CONTINUE
2594         ENDIF
2595       ELSE
2596 !----------------------------------------------------------------------
2597 !  EVALUATE FOR ARGUMENT .GE. 12.0,
2598 !----------------------------------------------------------------------
2599        IF(Y.LE.XBIG)THEN
2600           YSQ=Y*Y
2601           SUM=C(7)
2602           DO 350 I=1,6
2603             SUM=SUM/YSQ+C(I)
2604   350     CONTINUE
2605           SUM=SUM/Y-Y+SQRTPI
2606           SUM=SUM+(Y-HALF)*LOG(Y)
2607           RES=EXP(SUM)
2608         ELSE
2609           RES=XINF
2610           GOTO 900
2611         ENDIF
2612       ENDIF
2613 !----------------------------------------------------------------------
2614 !  FINAL ADJUSTMENTS AND RETURN
2615 !----------------------------------------------------------------------
2616       IF(PARITY)RES=-RES
2617       IF(FACT.NE.ONE)RES=FACT/RES
2618   900 mskf_GAMMA=RES
2619 !D900 DGAMMA = RES
2620       RETURN
2621 ! ---------- LAST LINE OF mskf_GAMMA ----------
2622       END function mskf_GAMMA
2623
2624 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
2625 ! error function in single precision
2626 !
2627 !    Copyright(C) 1996 Takuya OOURA (email: ooura@mmm.t.u-tokyo.ac.jp).
2628 !    You may use, copy, modify this code for any purpose and
2629 !    without fee. You may distribute this ORIGINAL package.
2630
2631       function derf(x)
2632       implicit real (a - h, o - z)
2633       real(r8) a,b,x
2634       dimension a(0 : 64), b(0 : 64)
2635       integer i,k
2636       data (a(i), i = 0, 12) / &
2637          0.00000000005958930743d0, -0.00000000113739022964d0, &
2638          0.00000001466005199839d0, -0.00000016350354461960d0, &
2639          0.00000164610044809620d0, -0.00001492559551950604d0, &
2640          0.00012055331122299265d0, -0.00085483269811296660d0, &
2641          0.00522397762482322257d0, -0.02686617064507733420d0, &
2642          0.11283791670954881569d0, -0.37612638903183748117d0, &
2643          1.12837916709551257377d0 /
2644       data (a(i), i = 13, 25) / &
2645          0.00000000002372510631d0, -0.00000000045493253732d0, &
2646          0.00000000590362766598d0, -0.00000006642090827576d0, &
2647          0.00000067595634268133d0, -0.00000621188515924000d0, &
2648          0.00005103883009709690d0, -0.00037015410692956173d0, &
2649          0.00233307631218880978d0, -0.01254988477182192210d0, &
2650          0.05657061146827041994d0, -0.21379664776456006580d0, &
2651          0.84270079294971486929d0 /
2652       data (a(i), i = 26, 38) / &
2653          0.00000000000949905026d0, -0.00000000018310229805d0, &
2654          0.00000000239463074000d0, -0.00000002721444369609d0, &
2655          0.00000028045522331686d0, -0.00000261830022482897d0, &
2656          0.00002195455056768781d0, -0.00016358986921372656d0, &
2657          0.00107052153564110318d0, -0.00608284718113590151d0, &
2658          0.02986978465246258244d0, -0.13055593046562267625d0, &
2659          0.67493323603965504676d0 /
2660       data (a(i), i = 39, 51) / &
2661          0.00000000000382722073d0, -0.00000000007421598602d0, &
2662          0.00000000097930574080d0, -0.00000001126008898854d0, &
2663          0.00000011775134830784d0, -0.00000111992758382650d0, &
2664          0.00000962023443095201d0, -0.00007404402135070773d0, &
2665          0.00050689993654144881d0, -0.00307553051439272889d0, &
2666          0.01668977892553165586d0, -0.08548534594781312114d0, &
2667          0.56909076642393639985d0 /
2668       data (a(i), i = 52, 64) / &
2669          0.00000000000155296588d0, -0.00000000003032205868d0, &
2670          0.00000000040424830707d0, -0.00000000471135111493d0, &
2671          0.00000005011915876293d0, -0.00000048722516178974d0, &
2672          0.00000430683284629395d0, -0.00003445026145385764d0, &
2673          0.00024879276133931664d0, -0.00162940941748079288d0, &
2674          0.00988786373932350462d0, -0.05962426839442303805d0, &
2675          0.49766113250947636708d0 /
2676      data (b(i), i = 0, 12) / &
2677          -0.00000000029734388465d0, 0.00000000269776334046d0, &
2678          -0.00000000640788827665d0, -0.00000001667820132100d0, &
2679          -0.00000021854388148686d0, 0.00000266246030457984d0, &
2680          0.00001612722157047886d0, -0.00025616361025506629d0, &
2681          0.00015380842432375365d0, 0.00815533022524927908d0, &
2682          -0.01402283663896319337d0, -0.19746892495383021487d0,&
2683          0.71511720328842845913d0 /
2684       data (b(i), i = 13, 25) / &
2685          -0.00000000001951073787d0, -0.00000000032302692214d0, &
2686          0.00000000522461866919d0, 0.00000000342940918551d0, &
2687          -0.00000035772874310272d0, 0.00000019999935792654d0, &
2688          0.00002687044575042908d0, -0.00011843240273775776d0, &
2689          -0.00080991728956032271d0, 0.00661062970502241174d0, &
2690          0.00909530922354827295d0, -0.20160072778491013140d0, &
2691          0.51169696718727644908d0 /
2692       data (b(i), i = 26, 38) / &
2693          0.00000000003147682272d0, -0.00000000048465972408d0, &
2694          0.00000000063675740242d0, 0.00000003377623323271d0, &
2695          -0.00000015451139637086d0, -0.00000203340624738438d0,&
2696          0.00001947204525295057d0, 0.00002854147231653228d0, &
2697          -0.00101565063152200272d0, 0.00271187003520095655d0, &
2698          0.02328095035422810727d0, -0.16725021123116877197d0, &
2699          0.32490054966649436974d0 /
2700       data (b(i), i = 39, 51) / &
2701          0.00000000002319363370d0, -0.00000000006303206648d0, &
2702          -0.00000000264888267434d0, 0.00000002050708040581d0, &
2703          0.00000011371857327578d0, -0.00000211211337219663d0, &
2704          0.00000368797328322935d0, 0.00009823686253424796d0, &
2705          -0.00065860243990455368d0, -0.00075285814895230877d0,&
2706          0.02585434424202960464d0, -0.11637092784486193258d0, &
2707          0.18267336775296612024d0 /
2708       data (b(i), i = 52, 64) / &
2709          -0.00000000000367789363d0, 0.00000000020876046746d0, &
2710          -0.00000000193319027226d0, -0.00000000435953392472d0, &
2711          0.00000018006992266137d0, -0.00000078441223763969d0, &
2712          -0.00000675407647949153d0, 0.00008428418334440096d0, &
2713          -0.00017604388937031815d0, -0.00239729611435071610d0, &
2714          0.02064129023876022970d0, -0.06905562880005864105d0, &
2715          0.09084526782065478489d0 /
2716       w = abs(x)
2717       if (w .lt. 2.2d0) then
2718           t = w * w
2719           k = int(t)
2720           t = t - k
2721           k = k * 13
2722           y = ((((((((((((a(k) * t + a(k + 1)) * t + &
2723              a(k + 2)) * t + a(k + 3)) * t + a(k + 4)) * t + &
2724              a(k + 5)) * t + a(k + 6)) * t + a(k + 7)) * t + &
2725              a(k + 8)) * t + a(k + 9)) * t + a(k + 10)) * t + &
2726              a(k + 11)) * t + a(k + 12)) * w
2727       else if (w .lt. 6.9d0) then
2728           k = int(w)
2729           t = w - k
2730           k = 13 * (k - 2)
2731           y = (((((((((((b(k) * t + b(k + 1)) * t + &
2732              b(k + 2)) * t + b(k + 3)) * t + b(k + 4)) * t + &
2733              b(k + 5)) * t + b(k + 6)) * t + b(k + 7)) * t + &
2734              b(k + 8)) * t + b(k + 9)) * t + b(k + 10)) * t + &
2735              b(k + 11)) * t + b(k + 12)
2736           y = y * y
2737           y = y * y
2738           y = y * y
2739           y = 1 - y * y
2740       else
2741           y = 1
2742       end if
2743       if (x .lt. 0) y = -y
2744       derf = y
2745       end function derf
2746
2747 !-----------------------------------------------------------------------
2748         real function erfc_num_recipes( x )
2749 !
2750 !   from press et al, numerical recipes, 1990, page 164
2751 !
2752         implicit none
2753         real x
2754         double precision erfc_dbl, dum, t, zz
2755
2756         zz = abs(x)
2757         t = 1.0/(1.0 + 0.5*zz)
2758
2759 !       erfc_num_recipes =
2760 !     &   t*exp( -zz*zz - 1.26551223 + t*(1.00002368 + t*(0.37409196 +
2761 !     &   t*(0.09678418 + t*(-0.18628806 + t*(0.27886807 +
2762 !     &                                    t*(-1.13520398 +
2763 !     &   t*(1.48851587 + t*(-0.82215223 + t*0.17087277 )))))))))
2764
2765         dum =  ( -zz*zz - 1.26551223 + t*(1.00002368 + t*(0.37409196 +   &
2766           t*(0.09678418 + t*(-0.18628806 + t*(0.27886807 +   &
2767                                            t*(-1.13520398 +   &
2768           t*(1.48851587 + t*(-0.82215223 + t*0.17087277 )))))))))
2769
2770         erfc_dbl = t * exp(dum)
2771         if (x .lt. 0.0) erfc_dbl = 2.0d0 - erfc_dbl
2772
2773         erfc_num_recipes = erfc_dbl
2774
2775         return
2776         end function erfc_num_recipes
2777
2778 !-----------------------------------------------------------------------
2779     real function erf_alt( x )
2780
2781     implicit none
2782
2783     real,intent(in) :: x
2784
2785     erf_alt = 1. - erfc_num_recipes(x)
2786
2787     end function erf_alt
2788       subroutine mskf_activate(wbar, tair, rhoair,  &
2789                  na, pmode, nmode, ma, sigman, hygro, rhodry, nact,qs)
2790 !      calculates number, surface, and mass fraction of aerosols activated as
2791 !      CCN
2792 !      calculates flux of cloud droplets, surface area, and aerosol mass into
2793 !      cloud
2794 !      assumes an internal mixture within each of up to pmode multiple aerosol
2795 !      modes
2796 !      a gaussiam spectrum of updrafts can be treated.
2797
2798 !      mks units
2799
2800 !      Abdul-Razzak and Ghan, A parameterization of aerosol activation.
2801 !      2. Multiple aerosol types. J. Geophys. Res., 105, 6837-6844.
2802
2803 !      use physconst, only: rair, epsilo, cpair, rh2o, latvap, gravit,   &
2804 !                                 rhoh2o, mwh2o, r_universal
2805 !ckay      use wv_saturation, only: estblf, epsqs
2806
2807       implicit none
2808
2809 !      save  ! sep6
2810
2811 !      input
2812
2813       integer pmode,ptype ! dimension of modes, types in modes
2814       real(r8) wbar          ! grid cell mean vertical velocity (m/s)
2815       real(r8) tair          ! air temperature (K)
2816       real(r8) rhoair        ! air density (kg/m3)
2817       real(r8) na(pmode)           ! aerosol number concentration (/m3)
2818       integer nmode      ! number of aerosol modes
2819       real(r8) ma(pmode)     ! aerosol mass concentration (kg/m3)
2820       real(r8) rhodry(pmode) ! density of aerosol material
2821       real(r8) sigman(pmode)  ! geometric standard deviation of aerosol size distribution
2822       real(r8) hygro(pmode)  ! hygroscopicity of aerosol mode
2823
2824
2825 !      output
2826
2827       real(r8) nact      ! number fraction of aerosols activated
2828
2829 !      local
2830 #if (defined AIX)
2831 #define ERF erf
2832 #define ERFC erfc
2833 #else
2834 #define ERF derf
2835 #define ERFC derfc
2836 #define ERF_ALT erf_alt
2837       real(r8) derf,derfc, erf_alt
2838 #endif
2839
2840       integer, parameter:: nx=200
2841       integer :: maxmodes
2842
2843       real(r8) surften       ! surface tension of water w/respect to air (N/m)
2844       data surften/0.076/
2845       save surften
2846       real(r8) p0     ! reference pressure (Pa)
2847       data p0/1013.25e2/
2848       save p0
2849
2850       real(r8) :: volc(naer_cu) ! total aerosol volume  concentration (m3/m3)
2851       real(r8) tmass ! total aerosol mass concentration (g/cm3)
2852       real(r8) rm ! number mode radius of aerosol at max supersat (cm)
2853       real(r8) pres ! pressure (Pa)
2854       real(r8) path ! mean free path (m)
2855       real(r8) diff ! diffusivity (m2/s)
2856       real(r8) conduct ! thermal conductivity (Joule/m/sec/deg)
2857       real(r8) diff0,conduct0
2858       real(r8) qs ! water vapor saturation mixing ratio
2859       real(r8) dqsdt ! change in qs with temperature
2860       real(r8) dqsdp ! change in qs with pressure
2861       real(r8) gloc ! thermodynamic function (m2/s)
2862       real(r8) zeta
2863       real(r8) :: eta(naer_cu)
2864       real(r8) :: smc(naer_cu)
2865       real(r8) lnsmax ! ln(smax)
2866       real(r8) alpha
2867       real(r8) gammaloc
2868       real(r8) beta
2869       real(r8) sqrtg
2870       real(r8) alogam
2871       real(r8) rlo,rhi,xint1,xint2,xint3,xint4
2872       real(r8) w,wnuc,wb
2873       real(r8) alw,sqrtalw
2874       real(r8) smax
2875       real(r8) x,arg
2876       real(r8) xmincoeff,xcut,volcut,surfcut
2877       real(r8) z,z1,z2,wf1,wf2,zf1,zf2,gf1,gf2,gf
2878       real(r8) :: etafactor1,etafactor2max
2879       real(r8) :: etafactor2(naer_cu)
2880       real(r8) es
2881       integer m,n
2882
2883       real(r8) :: amcubeloc(naer_cu)
2884       real(r8) :: lnsmloc(naer_cu)
2885       maxmodes = naer_cu
2886
2887       if(maxmodes<pmode)then
2888 !         write(*,*)'maxmodes,pmode in activate =',maxmodes,pmode
2889 !         call endrun('kf_activate')
2890       endif
2891
2892       nact=0._r8
2893
2894       if(nmode.eq.1.and.na(1).lt.1.e-20)return
2895
2896       if(wbar.le.0.)return
2897
2898       pres=rair*rhoair*tair
2899       diff0=0.211e-4*(p0/pres)*(tair/t0)**1.94
2900       conduct0=(5.69+0.017*(tair-t0))*4.186e2*1.e-5 ! convert to J/m/s/deg
2901 !ckay      es = estblf(tair)
2902 !ckay      qs = epsilo*es/(pres-(1.0_r8 - epsqs)*es)
2903 !        print *,'rh2o=',rh2o
2904       dqsdt=latvap/(rh2o*tair*tair)*qs
2905       alpha=gravit*(latvap/(cpair*rh2o*tair*tair)-1./(rair*tair))
2906       gammaloc=(1+latvap/cpair*dqsdt)/(rhoair*qs)
2907 !     growth coefficent Abdul-Razzak & Ghan 1998 eqn 16
2908 !     should depend on mean radius of mode to account for gas kinetic effects
2909       gloc=1./(rhoh2o/(diff0*rhoair*qs)                                    &
2910           +latvap*rhoh2o/(conduct0*tair)*(latvap/(rh2o*tair)-1.))
2911       sqrtg=sqrt(gloc)
2912       beta=4.*pi*rhoh2o*gloc*gammaloc
2913       etafactor2max=1.e10/(alpha*wbar)**1.5 ! this should make eta big if na is very small.
2914
2915       do m=1,nmode
2916 !         internal mixture of aerosols
2917           volc(m)=ma(m)/(rhodry(m)) ! only if variable size dist
2918          if(volc(m).gt.1.e-39_r8.and.na(m).gt.1.e-39_r8)then
2919             etafactor2(m)=1./(na(m)*beta*sqrtg)  !fixed or variable size dist
2920 !            number mode radius (m)
2921             amcubeloc(m)=(3.*volc(m)/(4.*pi*exp45logsig(m)*na(m)))  ! only if variable size dist
2922             smc(m)=smcrit(m) ! only for prescribed size dist
2923
2924 !May30,2014
2925                  if(hygro(m).gt.1.e-10)then   ! loop only if variable size dist
2926                     smc(m)=2.*aten*sqrt(aten/(27.*hygro(m)*amcubeloc(m)))
2927                  else
2928                    smc(m)=100.
2929                  endif
2930          else
2931             smc(m)=1.
2932             etafactor2(m)=etafactor2max ! this should make eta big if na is very small.
2933          endif
2934          lnsmloc(m)=log(smc(m)) ! only if variable size dist
2935       enddo
2936
2937 !         single  updraft
2938          wnuc=wbar
2939 !        write(iulog,*)'uniform updraft =',wnuc
2940
2941             w=wbar
2942             alw=alpha*wnuc
2943             sqrtalw=sqrt(alw)
2944             zeta=2.*sqrtalw*aten/(3.*sqrtg)
2945             etafactor1=2.*alw*sqrtalw
2946
2947             do m=1,nmode
2948                eta(m)=etafactor1*etafactor2(m)
2949             enddo
2950
2951 !             print *,' kf_maxsat '
2952             call mskf_maxsat(zeta,eta,nmode,smc,smax)
2953
2954             lnsmax=log(smax)
2955 !           print *,'smc,smax=',smc,smax
2956             xmincoeff=alogaten-2.*third*(lnsmax-alog2)-alog3
2957
2958             nact=0._r8
2959             do m=1,nmode
2960                x=2*(lnsmloc(m)-lnsmax)/(3*sq2*alogsig(m))
2961 !original ghan code
2962 !               nact=nact+0.5*(1.-ERF(x))*na(m)
2963 !++ag replace sg erf with hm derf pre 1.68
2964 !               nact=nact+0.5*(1.-derf(x))*na(m)
2965 !++ag 1.68 new error function
2966                 nact=nact+0.5*(1.-erf(x))*na(m)
2967 !               nact=nact+0.5*(1.-derf(x))*na(m)
2968 !       write(*,*)'nact',nact,derf(x),na(m),m
2969 !       write(*,*) 'lnsmloc(m)',lnsmloc(m),lnsmax,alogsig(m)
2970 !                write(*,*) 'wbar=',wbar
2971             enddo
2972             nact=nact/rhoair ! convert from #/m3 to #/kg
2973
2974 !      write(*,*)'na(m),qs',na(m),m,qs
2975 !      write(*,*)'nact',nact
2976 !      deallocate( &
2977 !         volc,       &
2978 !         eta,        &
2979 !         smc,        &
2980 !         etafactor2, &
2981 !         amcubeloc,  &
2982 !         lnsmloc     )
2983
2984       return
2985       end subroutine mskf_activate
2986
2987       subroutine mskf_maxsat(zeta,eta,nmode,smc,smax)
2988
2989 !      calculates maximum supersaturation for multiple
2990 !      competing aerosol modes.
2991
2992 !      Abdul-Razzak and Ghan, A parameterization of aerosol activation.
2993 !      2. Multiple aerosol types. J. Geophys. Res., 105, 6837-6844.
2994
2995       implicit none
2996 !     save ! sep6
2997       integer nmode ! number of modes
2998       real(r8) :: smc(:) ! critical supersaturation for number mode radius
2999       real(r8) zeta
3000       real(r8) :: eta(:)
3001       real(r8) smax ! maximum supersaturation
3002       integer m  ! mode index
3003       real(r8) sum, g1, g2
3004
3005       do m=1,nmode
3006          if(zeta.gt.1.e5*eta(m).or.smc(m)*smc(m).gt.1.e5*eta(m))then
3007 !            weak forcing. essentially none activated
3008             smax=1.e-20
3009          else
3010 !            significant activation of this mode. calc activation all modes.
3011             go to 1
3012          endif
3013       enddo
3014
3015       return
3016
3017   1   continue
3018
3019       sum=0
3020       do m=1,nmode
3021          if(eta(m).gt.1.e-20)then
3022             g1=sqrt(zeta/eta(m))
3023             g1=g1*g1*g1
3024             g2=smc(m)/sqrt(eta(m)+3*zeta)
3025             g2=sqrt(g2)
3026             g2=g2*g2*g2
3027             sum=sum+(f1(m)*g1+f2(m)*g2)/(smc(m)*smc(m))
3028 !    write(*,*)'f1(m)',f1(m),m
3029          else
3030             sum=1.e20
3031          endif
3032       enddo
3033
3034       smax=1./sqrt(sum)
3035
3036       return
3037
3038       end subroutine mskf_maxsat
3039
3040 subroutine mskf_nucleati(wbar, tair, pair, qv,  qc,  rhoair, & ! TWG add pair and replace relhum with qv
3041        na,  naer_all, nuci  &
3042        , onihf, oniimm, onidep, onimey)
3043
3044 !---------------------------------------------------------------
3045 ! Purpose:
3046 !  The parameterization of ice nucleation.
3047 !
3048 ! Method: The current method is based on Liu & Penner (2005)
3049 !  It related the ice nucleation with the aerosol number, temperature and the
3050 !  updraft velocity. It includes homogeneous freezing of sulfate, immersion
3051 !  freezing of soot, and Meyers et al. (1992) deposition nucleation
3052 !
3053 ! Authors: Xiaohong Liu, 01/2005, modifications by A. Gettelman 2009-2010
3054 !----------------------------------------------------------------
3055 ! Input Arguments
3056 !
3057 !    save   ! sep6
3058   integer  naer_all
3059   real(r8) :: wbar                ! grid cell mean vertical velocity (m/s)
3060   real(r8) :: tair                ! temperature (K)
3061   real(r8) :: qv                  ! water vapor mixing ratio (kg/kg)
3062   real(r8) :: pair                ! pressure (Pa)
3063
3064   real(r8) :: qc                  ! liquid water mixing ratio (kg/kg)
3065   real(r8) :: rhoair              ! air density (kg/m3)
3066   real(r8) :: na(naer_all)        ! aerosol number concentration (/m3)
3067
3068 !
3069 ! Output Arguments
3070 !
3071   real(r8) :: nuci               ! ice number nucleated (#/kg)
3072   real(r8) :: onihf              ! nucleated number from homogeneous freezing of so4
3073   real(r8) :: oniimm             ! nucleated number from immersion freezing
3074   real(r8) :: onidep             ! nucleated number from deposition nucleation
3075   real(r8) :: onimey             ! nucleated number from deposition nucleation (meyers: mixed phase)
3076 !
3077 ! Local workspace
3078 !
3079   real(r8)  so4_num                                      ! so4 aerosol number (#/cm^3)
3080   real(r8)  soot_num                                     ! soot (hydrophilic) aerosol number (#/cm^3)
3081   real(r8)  dst1_num,dst2_num,dst3_num,dst4_num          ! dust aerosol number (#/cm^3)
3082   real(r8)  dst_num                                      ! total dust aerosol number (#/cm^3)
3083   real(r8)  nihf                                         ! nucleated number from homogeneous freezing of so4
3084   real(r8)  niimm                                        ! nucleated number from immersion freezing
3085   real(r8)  nidep                                        ! nucleated number from deposition nucleation
3086   real(r8)  nimey                                        ! nucleated number from deposition nucleation (meyers)
3087   real(r8)  n1,ni                                        ! nucleated number
3088   real(r8)  tc,A,B,C,regm                                ! work variable
3089   real(r8)  esl,esi,deles,qsi,qsl,relhum                 ! work variable
3090   real(r8)  dst_scale
3091   real(r8)  subgrid
3092   real(r8)  dmc,ssmc         ! variables for modal scheme.
3093
3094     so4_num=0.0_r8
3095     soot_num=0.0_r8
3096     dst_num=0.0_r8
3097     dst1_num = 0.0_r8
3098     dst2_num = 0.0_r8
3099     dst3_num = 0.0_r8
3100     dst4_num = 0.0_r8
3101
3102 !For modal aerosols, assume for the upper troposphere:
3103 ! soot = accumulation mode
3104 ! sulfate = aiken mode
3105 ! dust = coarse mode
3106 ! since modal has internal mixtures.
3107
3108     if(idxsul .gt. 0) then
3109       so4_num=na(idxsul)*1.0e-6_r8 ! #/cm^3
3110     end if
3111
3112     if(idxbcphi .gt. 0) then
3113       soot_num=na(idxbcphi)*1.0e-6_r8 !#/cm^3
3114     end if
3115
3116     if(idxdst1 .gt. 0) then
3117        dst1_num=na(idxdst1)*1.0e-6_r8 !#/cm^3
3118     end if
3119
3120     if(idxdst2 .gt. 0) then
3121        dst2_num=na(idxdst2)*1.0e-6_r8 !#/cm^3
3122     end if
3123
3124     if(idxdst3 .gt. 0) then
3125        dst3_num=na(idxdst3)*1.0e-6_r8 !#/cm^3
3126     end if
3127
3128     if(idxdst4 .gt. 0) then
3129        dst4_num=na(idxdst4)*1.0e-6_r8 !#/cm^3
3130     end if
3131
3132     dst_num =dst1_num+dst2_num+dst3_num+dst4_num
3133 ! no soot nucleation for now.
3134    ! soot_num=0.0_r8
3135
3136     ni=0._r8
3137     tc=tair-273.15_r8
3138
3139 !TWG calculate Ice saturation ratio
3140     esi = 611.2*exp(21.87*(tair-273.16)/(tair-7.66))
3141     esl = 611.2*exp(17.67*(tair-273.16)/(243.5+tair-273.16))
3142     qsi = 0.622*esi/(pair-esi)
3143     qsl = 0.622*esl/(pair-esl)
3144     deles = qv/qsi
3145     relhum = qv/qsl
3146
3147     ! initialize
3148     niimm=0._r8
3149     nidep=0._r8
3150     nihf=0._r8
3151
3152     if(so4_num.ge.1.0e-10_r8 .and. (soot_num+dst_num).ge.1.0e-10_r8 ) then
3153
3154       subgrid = 1.0_r8
3155
3156 !          print *,'nucleiate wbar=', wbar
3157      if((wbar.lt.4.0_r8) .and. (tc.le.-35.0_r8) .and.((deles*subgrid).ge.1.0_r8)) then !TWG Make RHi consistent
3158 !< regm => T in Eq.10 of Liu et al., J. Climate, 2007>
3159        print*,'Aerosol Ice Nucleation is Doing Something'
3160        A = -1.4938_r8 * log(soot_num+dst_num) + 12.884_r8
3161        B = -10.41_r8  * log(soot_num+dst_num) - 67.69_r8
3162        regm = A * log(wbar) + B
3163
3164 !         print *,'before bunch of hetero'
3165        if(tc.gt.regm) then    ! heterogeneous nucleation only
3166          if(tc.lt.-40._r8 .and. wbar.gt.1._r8) then ! exclude T<-40 & W>1m/s from hetero. nucleation
3167            call mskf_hf(tc,wbar,relhum,subgrid,so4_num,nihf)
3168            niimm=0._r8
3169            nidep=0._r8
3170            n1=nihf
3171          else
3172            call mskf_hetero(tc,wbar,soot_num+dst_num,niimm,nidep)
3173            nihf=0._r8
3174            n1=niimm+nidep
3175          endif
3176        elseif (tc.lt.regm-5._r8) then ! homogeneous nucleation only
3177          call mskf_hf(tc,wbar,relhum,subgrid,so4_num,nihf)
3178          niimm=0._r8
3179          nidep=0._r8
3180          n1=nihf
3181        else        ! transition between homogeneous and heterogeneous: interpolate in-between
3182          if(tc.lt.-40._r8 .and. wbar.gt.1._r8) then ! exclude T<-40 & W>1m/s from hetero. nucleation
3183            call mskf_hf(tc,wbar,relhum,subgrid,so4_num,nihf)
3184            niimm=0._r8
3185            nidep=0._r8
3186            n1=nihf
3187          else
3188            call mskf_hf(regm-5._r8,wbar,relhum,subgrid,so4_num,nihf)
3189            call mskf_hetero(regm,wbar,soot_num+dst_num,niimm,nidep)
3190            if(nihf.le.(niimm+nidep)) then
3191              n1=nihf
3192            else
3193               n1=(niimm+nidep)*((niimm+nidep)/nihf)**((tc-regm)/5._r8)
3194            endif
3195          endif
3196        endif
3197
3198        ni=n1
3199
3200     endif
3201     endif
3202 1100  continue
3203
3204 ! deposition/condensation nucleation in mixed clouds (-37<T<0C) (Meyers, 1992)
3205 !<Eq.12 of Liu et al., J. Climate, 2007
3206 ! Nid(L-1)*1.e-3 => Nid(m-3)
3207 ! Question:  RHi=RHw*esl/esi
3208
3209     if(tc.lt.0._r8 .and. tc.gt.-37._r8 .and. qc.gt.1.e-12_r8) then
3210 !     if(tc.lt.0._r8 .and. tc.gt.-37._r8) then  ! TWG  remove cloud water constraint
3211 !      esl = kf_polysvp(tair,0)     ! over water in mixed clouds
3212 !      esi = kf_polysvp(tair,1)     ! over ice
3213 !songxl      deles = (esl - esi)
3214 !      deles = (relhum*esl - esi)
3215        if (deles.gt.1.5) THEN
3216              deles = 1.5
3217         end if
3218       nimey=1.e-3_r8*exp(12.96_r8*(deles-1.0_r8) - 0.639_r8) ! TWG fix Meyers formulation
3219     else
3220       nimey=0._r8
3221     endif
3222
3223     nuci=ni+nimey
3224     if(nuci.gt.9999._r8.or.nuci.lt.0._r8) then
3225        write(*, *) 'incorrect ice nucleation number'
3226        write(*, *) ni, tair, relhum, wbar, nihf, niimm,nidep,deles,esi,dst2_num,dst3_num,dst4_num
3227        nuci=0._r8
3228          CALL wrf_error_fatal ( 'Incorrect Ice Nucleation Number, diags' )
3229     endif
3230
3231     nuci=nuci*1.e+6_r8/rhoair    ! change unit from #/cm3 to #/kg
3232     onimey=nimey*1.e+6_r8/rhoair
3233     onidep=nidep*1.e+6_r8/rhoair
3234     oniimm=niimm*1.e+6_r8/rhoair
3235     onihf=nihf*1.e+6_r8/rhoair
3236
3237 !     print *,'inputs=',wbar, tair, relhum,  qc,  rhoair, &
3238 !      na,  naer_all, nuci,onimey,onidep,oniimm,onihf
3239 !     print *,'na,tari,nuci.. =', na,tair,nuci,onimey,onidep,oniimm,onihf
3240   return
3241   end subroutine mskf_nucleati
3242
3243   subroutine mskf_hetero(T,ww,Ns,Nis,Nid)
3244
3245     real(r8) :: T, ww, Ns
3246     real(r8) :: Nis, Nid
3247
3248     real(r8) A11,A12,A21,A22,B11,B12,B21,B22
3249     real(r8) A,B,C
3250
3251 !    save    ! spe6
3252 !---------------------------------------------------------------------
3253 ! parameters
3254
3255       A11 = 0.0263_r8
3256       A12 = -0.0185_r8
3257       A21 = 2.758_r8
3258       A22 = 1.3221_r8
3259       B11 = -0.008_r8
3260       B12 = -0.0468_r8
3261       B21 = -0.2667_r8
3262       B22 = -1.4588_r8
3263 !<Eq.11 of Liu et al., J. Climate, 2007>
3264 !     ice from immersion nucleation (cm-3)
3265
3266       B = (A11+B11*log(Ns)) * log(ww) + (A12+B12*log(Ns))
3267       C =  A21+B21*log(Ns)
3268
3269       Nis = exp(A22) * Ns**B22 * exp(B*T) * ww**C
3270       Nis = min(Nis,Ns)
3271
3272       Nid = 0.0_r8    ! don't include deposition nucleation for cirrus clouds when T<-37C
3273
3274       return
3275   end subroutine mskf_hetero
3276
3277  subroutine mskf_hf(T,ww,RH,subgrid,Na,Ni)
3278
3279       real(r8) :: T, ww, RH, subgrid, Na
3280       real(r8), intent(out) :: Ni
3281
3282       real(r8)    A1_fast,A21_fast,A22_fast,B1_fast,B21_fast,B22_fast
3283       real(r8)    A2_fast,B2_fast
3284       real(r8)    C1_fast,C2_fast,k1_fast,k2_fast
3285       real(r8)    A1_slow,A2_slow,B1_slow,B2_slow,B3_slow
3286       real(r8)    C1_slow,C2_slow,k1_slow,k2_slow
3287       real(r8)    regm
3288       real(r8)    A,B,C
3289       real(r8)    RHw
3290
3291 !     save   ! sep6
3292 !---------------------------------------------------------------------
3293 !<Table 1 of  Liu et al., J. Climate, 2007>
3294 ! parameters
3295
3296       A1_fast  =0.0231_r8
3297       A21_fast =-1.6387_r8  !(T>-64 deg)
3298       A22_fast =-6.045_r8   !(T<=-64 deg)
3299       B1_fast  =-0.008_r8
3300       B21_fast =-0.042_r8   !(T>-64 deg)
3301       B22_fast =-0.112_r8   !(T<=-64 deg)
3302       C1_fast  =0.0739_r8
3303       C2_fast  =1.2372_r8
3304
3305       A1_slow  =-0.3949_r8
3306       A2_slow  =1.282_r8
3307       B1_slow  =-0.0156_r8
3308       B2_slow  =0.0111_r8
3309       B3_slow  =0.0217_r8
3310       C1_slow  =0.120_r8
3311       C2_slow  =2.312_r8
3312
3313       Ni = 0.0_r8
3314
3315 !----------------------------
3316 !<Eq.6 of Liu et al., J. Climate, 2007
3317 ! w~m/s, T~degree C, RHw~% => RHw*0.01~fraction  >
3318 !RHw xiaohong's parameter
3319       A = 6.0e-4_r8*log(ww)+6.6e-3_r8
3320       B = 6.0e-2_r8*log(ww)+1.052_r8
3321       C = 1.68_r8  *log(ww)+129.35_r8
3322       RHw=(A*T*T+B*T+C)*0.01_r8
3323
3324       if((T.le.-37.0_r8) .and. ((RH*subgrid).ge.RHw)) then
3325
3326 !<Eq.9 of Liu et al., J. Climate, 2007>
3327         regm = 6.07_r8*log(ww)-55.0_r8
3328
3329         if(T.ge.regm) then    ! fast-growth regime
3330
3331           if(T.gt.-64.0_r8) then
3332             A2_fast=A21_fast
3333             B2_fast=B21_fast
3334           else
3335             A2_fast=A22_fast
3336             B2_fast=B22_fast
3337           endif
3338 !<Eq.7 of Liu et al., J. Climate, 2007>
3339           k1_fast = exp(A2_fast + B2_fast*T + C2_fast*log(ww))
3340           k2_fast = A1_fast+B1_fast*T+C1_fast*log(ww)
3341
3342           Ni = k1_fast*Na**(k2_fast)
3343           Ni = min(Ni,Na)
3344         else       ! slow-growth regime
3345 !<Eq.7 of Liu et al., J. Climate, 2007>
3346           k1_slow = exp(A2_slow + (B2_slow+B3_slow*log(ww))*T + C2_slow*log(ww))
3347           k2_slow = A1_slow+B1_slow*T+C1_slow*log(ww)
3348
3349           Ni = k1_slow*Na**(k2_slow)
3350           Ni = min(Ni,Na)
3351         endif
3352       end if
3353
3354       return
3355   end subroutine mskf_hf
3356
3357       function mskf_polysvp (T,type)
3358 !  Compute saturation vapor pressure by using
3359 ! function from Goff and Gatch (1946)
3360
3361 !  Polysvp returned in units of pa.
3362 !  T is input in units of K.
3363 !  type refers to saturation with respect to liquid (0) or ice (1)
3364
3365       real(r8) dum
3366
3367       real(r8) T,mskf_polysvp
3368
3369       integer type
3370
3371 ! ice
3372
3373       if (type.eq.1) then
3374
3375 ! Goff Gatch equation (good down to -100 C)
3376
3377          mskf_polysvp = 10._r8**(-9.09718_r8*(273.16_r8/t-1._r8)-3.56654_r8* &
3378           log10(273.16_r8/t)+0.876793_r8*(1._r8-t/273.16_r8)+ &
3379           log10(6.1071_r8))*100._r8
3380
3381       end if
3382
3383
3384 ! Goff Gatch equation, uncertain below -70 C
3385
3386       if (type.eq.0) then
3387          mskf_polysvp = 10._r8**(-7.90298_r8*(373.16_r8/t-1._r8)+ &
3388              5.02808_r8*log10(373.16_r8/t)- &
3389              1.3816e-7_r8*(10._r8**(11.344_r8*(1._r8-t/373.16_r8))-1._r8)+ &
3390              8.1328e-3_r8*(10._r8**(-3.49149_r8*(373.16_r8/t-1._r8))-1._r8)+ &
3391              log10(1013.246_r8))*100._r8
3392          end if
3393
3394
3395       end function mskf_polysvp
3396
3397  end module module_cu_mp
3398 !end module zm_microphysics
3399
3400 !----------------------------------------------------------------------------------------------
3401 !dkay begin MSKF
3402 !.........................................
3403
3404 MODULE module_cu_mskf
3405
3406    USE module_wrf_error
3407
3408    !dkay
3409    USE module_cu_mp
3410 !
3411 !--------------------------------------------------------------------
3412 ! Lookup table variables:
3413       INTEGER, PARAMETER :: KFNT=250,KFNP=220
3414       REAL, DIMENSION(KFNT,KFNP),PRIVATE, SAVE :: TTAB,QSTAB
3415       REAL, DIMENSION(KFNP),PRIVATE, SAVE :: THE0K
3416       REAL, DIMENSION(200),PRIVATE, SAVE :: ALU
3417       REAL, PRIVATE, SAVE :: RDPR,RDTHK,PLUTOP
3418 ! Note:  KF Lookup table is used by subroutines KF_eta_PARA, TPMIX2,
3419 !        TPMIX2DD, ENVIRTHT
3420 ! End of Lookup table variables:
3421
3422 CONTAINS
3423
3424    SUBROUTINE MSKF_CPS(                                      &
3425               ids,ide, jds,jde, kds,kde                      &
3426              ,ims,ime, jms,jme, kms,kme                      &
3427              ,its,ite, jts,jte, kts,kte                      &
3428              ,trigger                                        &
3429              ,DT,KTAU,DX,CUDT,ADAPT_STEP_FLAG                &
3430              ,rho,RAINCV,PRATEC,NCA                          &
3431              ,U,V,TH,T,W,dz8w,Pcps,pi                        &
3432              ,W0AVG,XLV0,XLV1,XLS0,XLS1,CP,R,G,EP1           &
3433              ,EP2,SVP1,SVP2,SVP3,SVPT0                       &
3434              ,STEPCU,CU_ACT_FLAG,warm_rain,CUTOP,CUBOT       &
3435              ,QV                                             &
3436             ! optionals
3437              ,F_QV    ,F_QC    ,F_QR    ,F_QI    ,F_QS       &
3438              ,RTHCUTEN,RQVCUTEN,RQCCUTEN,RQRCUTEN            &
3439              ,RQICUTEN,RQSCUTEN, RQVFTEN                     &
3440 !ckay
3441              ,cldfra_dp_KF,cldfra_sh_KF                      &
3442              ,qc_KF,qi_KF,qr_KF,qs_KF                        & ! TWG
3443              ,nc_KF,ni_KF,nr_KF,ns_KF                        & ! TWG
3444              ,ccn_KF,ainc_frac                               & ! TWG
3445 !kf_edrates
3446              ,UDR_KF,DDR_KF                                  &
3447              ,UER_KF,DER_KF                                  &
3448              ,TIMEC_KF,KF_EDRATES                            &
3449              ,ZOL,HFX,UST,PBLH                               &   !ckay
3450              ,aerocu,no_src_types_cu,aercu_fct,aercu_opt     & !PSH/TWG
3451              ,EFCS,EFIS,EFSS                                 &
3452              ,RUCUTEN,RVCUTEN,XLAND)                                 !JTR
3453 !
3454 !-------------------------------------------------------------
3455    IMPLICIT NONE
3456 !  SAVE !TWG 2017 Add to avoid memory issues
3457 !-------------------------------------------------------------
3458    INTEGER,      INTENT(IN   ) ::                            &
3459                                   ids,ide, jds,jde, kds,kde, &
3460                                   ims,ime, jms,jme, kms,kme, &
3461                                   its,ite, jts,jte, kts,kte
3462
3463    INTEGER,      INTENT(IN   ) :: trigger
3464    INTEGER,      INTENT(IN   ) :: STEPCU
3465    LOGICAL,      INTENT(IN   ) :: warm_rain
3466
3467    REAL,         INTENT(IN   ) :: XLV0,XLV1,XLS0,XLS1
3468    REAL,         INTENT(IN   ) :: CP,R,G,EP1,EP2
3469    REAL,         INTENT(IN   ) :: SVP1,SVP2,SVP3,SVPT0
3470
3471    INTEGER,      INTENT(IN   ) :: KTAU
3472
3473    REAL,  DIMENSION( ims:ime , kms:kme , jms:jme )         , &
3474           INTENT(IN   ) ::                                   &
3475                                                           U, &
3476                                                           V, &
3477                                                           W, &
3478                                                          TH, &
3479                                                           T, &
3480                                                          QV, &
3481                                                        dz8w, &
3482                                                        Pcps, &
3483                                                         rho, &
3484                                                          pi
3485
3486   INTEGER,      INTENT(IN   ) :: no_src_types_cu !PSH/TWG
3487   INTEGER,      INTENT(IN   ) :: aercu_opt       !PSH/TWG
3488   REAL,         INTENT(IN   ) :: aercu_fct       !PSH/TWG
3489   REAL,  DIMENSION( ims:ime, kms:kme, jms:jme, no_src_types_cu), OPTIONAL, &
3490           INTENT(INOUT) ::                                   aerocu !PSH/TWG
3491 !
3492    REAL,  DIMENSION( ims:ime , kms:kme , jms:jme )         , &
3493           INTENT(INOUT) ::                                   &
3494                                                       W0AVG
3495
3496    REAL,  INTENT(IN   ) :: DT, DX
3497    REAL,  INTENT(IN   ) :: CUDT
3498    LOGICAL,OPTIONAL,INTENT(IN   ) :: ADAPT_STEP_FLAG
3499 !
3500    REAL, DIMENSION( ims:ime , jms:jme ),                     &
3501           INTENT(INOUT) ::                           RAINCV
3502
3503    REAL,    DIMENSION( ims:ime , jms:jme ),                  &
3504           INTENT(INOUT) ::                           PRATEC
3505
3506    REAL,    DIMENSION( ims:ime , jms:jme ),                  &
3507             INTENT(INOUT) ::                            NCA
3508
3509    REAL, DIMENSION( ims:ime , jms:jme ),                     &
3510           INTENT(OUT) ::                              CUBOT, &
3511                                                       CUTOP
3512
3513    LOGICAL, DIMENSION( ims:ime , jms:jme ),                  &
3514           INTENT(INOUT) :: CU_ACT_FLAG
3515 !
3516 ! Optional arguments
3517 !
3518    REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),           &
3519          INTENT(INOUT) ::                                    &
3520                                                    RTHCUTEN, &
3521                                                    RQVCUTEN, &
3522                                                    RQCCUTEN, &
3523                                                    RQRCUTEN, &
3524                                                    RQICUTEN, &
3525                                                    RQSCUTEN, &
3526                                                    RQVFTEN,  &
3527                                                    RUCUTEN,  & !JTR
3528                                                    RVCUTEN
3529 !
3530 ! Flags relating to the optional tendency arrays declared above
3531 ! Models that carry the optional tendencies will provdide the
3532 ! optional arguments at compile time; these flags all the model
3533 ! to determine at run-time whether a particular tracer is in
3534 ! use or not.
3535 !
3536    LOGICAL, OPTIONAL ::                                      &
3537                                                    F_QV      &
3538                                                   ,F_QC      &
3539                                                   ,F_QR      &
3540                                                   ,F_QI      &
3541                                                   ,F_QS
3542
3543 !ckay
3544    REAL,  DIMENSION( ims:ime , kms:kme , jms:jme )         , &
3545           INTENT(INOUT) ::                                   &
3546                                                cldfra_dp_KF, &
3547                                                cldfra_sh_KF, &
3548                                                       qc_KF, &
3549                                                       qi_KF
3550
3551    REAL,  DIMENSION( ims:ime , kms:kme , jms:jme )         , &
3552           INTENT(INOUT) ::                                   &
3553                                                       qr_KF, & ! TWG
3554                                                       qs_KF, & ! TWG
3555                                                       nc_KF, & ! TWG
3556                                                       ni_KF, & ! TWG
3557                                                       nr_KF, & ! TWG
3558                                                       ns_KF, & ! TWG
3559                                                      ccn_KF, & ! TWG
3560                                                        EFCS, & ! TWG
3561                                                        EFIS, & ! TWG
3562                                                        EFSS
3563
3564    REAL, DIMENSION( ims:ime , jms:jme ),                     & !TWG
3565           INTENT(INOUT) ::                           ainc_frac
3566
3567 !kf_edrates
3568    REAL,  DIMENSION( ims:ime , kms:kme , jms:jme )         , &
3569           INTENT(INOUT) ::                         &
3570                                                      UDR_KF, &
3571                                                      DDR_KF, &
3572                                                      UER_KF, &
3573                                                      DER_KF
3574
3575    REAL,  DIMENSION( ims:ime , jms:jme )                   , &
3576           INTENT(INOUT) ::                         &
3577                                                    TIMEC_KF
3578
3579    INTEGER, INTENT(IN) ::              KF_EDRATES
3580
3581 !ckay
3582    REAL, DIMENSION( ims:ime, jms:jme )                     , &
3583          INTENT(   IN) ::                               ZOL, &
3584                                                         HFX, &
3585                                                         UST, &
3586                                                        PBLH, &
3587                                                        XLAND
3588
3589 ! LOCAL VARS
3590
3591    LOGICAL :: flag_qr, flag_qi, flag_qs
3592
3593    REAL, DIMENSION( kts:kte ) ::                             &
3594                                                         U1D, &
3595                                                         V1D, &
3596                                                         T1D, &
3597                                                        DZ1D, &
3598                                                        QV1D, &
3599                                                         P1D, &
3600                                                       RHO1D, &
3601                                                   tpart_v1D, &
3602                                                   tpart_h1D, &
3603                                                     W0AVG1D
3604
3605    REAL, DIMENSION( kts:kte )::                              &
3606                                                        DQDT, &
3607                                                       DQIDT, &
3608                                                       DQCDT, &
3609                                                       DQRDT, &
3610                                                       DQSDT, &
3611                                                        DTDT
3612
3613   REAL, DIMENSION (its-1:ite+1,kts:kte,jts-1:jte+1) ::  aveh_t, aveh_q
3614   REAL, DIMENSION (its:ite,kts:kte,jts:jte) :: aveh_qmax, aveh_qmin
3615   REAL, DIMENSION (its:ite,kts:kte,jts:jte) ::  avev_t, avev_q
3616   REAL, DIMENSION (its:ite,kts:kte,jts:jte) :: avev_qmax, avev_qmin
3617   REAL, DIMENSION (its:ite,kts:kte,jts:jte) ::  coef_v, coef_h, tpart_h, tpart_v
3618   INTEGER :: ii,jj,kk
3619
3620   REAL :: ttop
3621   REAL, DIMENSION (kts:kte)  :: z0
3622
3623    REAL    ::         TST,tv,PRS,RHOE,W0,SCR1,DXSQ,tmp
3624    integer :: ibegh,iendh,jbegh,jendh
3625    integer :: istart,iend,jstart,jend
3626    INTEGER :: i,j,k,NTST
3627    REAL    :: lastdt = -1.0
3628    REAL    :: W0AVGfctr, W0fctr, W0den
3629
3630 !JTR 06/26/19: Added tendency variables and CMT flag
3631    REAL, DIMENSION( kts:kte ) :: DUDT, DVDT
3632    LOGICAL :: cmt_opt_flag
3633
3634 !JTR: CMT on by default
3635    cmt_opt_flag = .TRUE.
3636 !
3637    DXSQ=DX*DX
3638
3639 !----------------------
3640    NTST=STEPCU
3641    TST=float(NTST*2)
3642    flag_qr = .FALSE.
3643    flag_qi = .FALSE.
3644    flag_qs = .FALSE.
3645    IF ( PRESENT(F_QR) ) flag_qr = F_QR
3646    IF ( PRESENT(F_QI) ) flag_qi = F_QI
3647    IF ( PRESENT(F_QS) ) flag_qs = F_QS
3648 !
3649    if (lastdt < 0) then
3650       lastdt = dt
3651    endif
3652
3653    if (ADAPT_STEP_FLAG) then
3654       W0AVGfctr = 2 * MAX(CUDT*60,dt) - dt
3655       W0fctr = dt
3656       W0den = 2 * MAX(CUDT*60,dt)
3657    else
3658       W0AVGfctr = (TST-1.)
3659       W0fctr = 1.
3660       W0den = TST
3661    endif
3662
3663   DO J = jts,jte
3664       DO K=kts,kte
3665          DO I= its,ite
3666 !            SCR1=-5.0E-4*G*rho(I,K,J)*(w(I,K,J)+w(I,K+1,J))
3667 !            TV=T(I,K,J)*(1.+EP1*QV(I,K,J))
3668 !            RHOE=Pcps(I,K,J)/(R*TV)
3669 !            W0=-101.9368*SCR1/RHOE
3670             W0=0.5*(w(I,K,J)+w(I,K+1,J))
3671
3672 !           Old:
3673 !
3674 !            W0AVG(I,K,J)=(W0AVG(I,K,J)*(TST-1.)+W0)/TST
3675 !
3676 !           New, to support adaptive time step:
3677 !
3678             W0AVG(I,K,J) = ( W0AVG(I,K,J) * W0AVGfctr + W0 * W0fctr ) / W0den
3679          ENDDO
3680       ENDDO
3681    ENDDO
3682
3683
3684    lastdt = dt
3685
3686 ! New trigger function
3687      IF (trigger.eq.2) THEN
3688 !
3689 ! calculate 9-point average of moisture advection and temperature using halo (Horizontal)
3690 !
3691      aveh_t=-999   ! horizontal 9-point ave
3692      aveh_q=-999
3693      avev_t=0   ! vertical 3-level ave
3694      avev_q=0
3695      avev_qmax=0
3696      avev_qmin=0
3697      aveh_qmax=0
3698      aveh_qmin=0
3699      tpart_h=0
3700      tpart_v=0
3701      coef_h=0
3702      coef_v=0
3703      ibegh=max(its-1, ids+1)   ! start from 2
3704      jbegh=max(jts-1, jds+1)
3705      iendh=min(ite+1, ide-2)   ! end at ide-2
3706      jendh=min(jte+1, jde-2)
3707         DO J = jbegh,jendh
3708         DO K = kts,kte
3709         DO I = ibegh,iendh
3710           aveh_t(i,k,j)=(T(i-1,k,j-1)+T(i-1,k,j)  +T(i-1,k,j+1)+ &
3711                          T(i,k,j-1)   +T(i,k,j)   +T(i,k,j+1)+         &
3712                          T(i+1,k,j-1) +T(i+1,k,j) +T(i+1,k,j+1))/9.
3713           aveh_q(i,k,j)=(rqvften(i-1,k,j-1)+rqvften(i-1,k,j)  +rqvften(i-1,k,j+1)+ &
3714                          rqvften(i,k,j-1)   +rqvften(i,k,j)   +rqvften(i,k,j+1)+         &
3715                          rqvften(i+1,k,j-1) +rqvften(i+1,k,j) +rqvften(i+1,k,j+1))/9.
3716         ENDDO
3717         ENDDO
3718         ENDDO
3719 ! boundary value ( all processors will do the following? Or just those processsors handling sub-area including boundary)
3720         DO K = kts,kte
3721            DO J = jts-1,jte+1
3722             DO I = its-1,ite+1
3723
3724             if(i.eq.ids) then
3725             aveh_t(i,k,j)=aveh_t(i+1,k,j)
3726             aveh_q(i,k,j)=aveh_q(i+1,k,j)
3727             elseif(i.eq.ide-1) then
3728             aveh_t(i,k,j)=aveh_t(i-1,k,j)
3729             aveh_q(i,k,j)=aveh_q(i-1,k,j)
3730             endif
3731
3732             if(j.eq.jds) then
3733              aveh_t(i,k,j)=aveh_t(i,k,j+1)
3734              aveh_q(i,k,j)=aveh_q(i,k,j+1)
3735             elseif(j.eq.jde-1) then
3736             aveh_t(i,k,j)=aveh_t(i,k,j-1)
3737             aveh_q(i,k,j)=aveh_q(i,k,j-1)
3738             endif
3739
3740             if(j.eq.jds.and.i.eq.ids) then
3741             aveh_q(i,k,j)=aveh_q(i+1,k,j+1)
3742             aveh_t(i,k,j)=aveh_t(i+1,k,j+1)
3743             endif
3744
3745             if(j.eq.jde-1.and.i.eq.ids) then
3746             aveh_q(i,k,j)=aveh_q(i+1,k,j-1)
3747             aveh_t(i,k,j)=aveh_t(i+1,k,j-1)
3748             endif
3749
3750             if(j.eq.jde-1.and.i.eq.ide-1) then
3751             aveh_q(i,k,j)=aveh_q(i-1,k,j-1)
3752             aveh_t(i,k,j)=aveh_t(i-1,k,j-1)
3753             endif
3754
3755             if(j.eq.jds.and.i.eq.ide-1) then
3756             aveh_q(i,k,j)=aveh_q(i-1,k,j+1)
3757             aveh_t(i,k,j)=aveh_t(i-1,k,j+1)
3758             endif
3759
3760             ENDDO
3761            ENDDO
3762         ENDDO
3763 ! search for max/min moisture advection in 9-point range, calculate horizontal T-perturbation (tpart_h)
3764      istart=max(its, ids+1)   ! start from 2
3765      jstart=max(jts, jds+1)
3766      iend=min(ite, ide-2)   ! end at ide-2
3767      jend=min(jte, jde-2)
3768         DO K = kts,kte
3769         DO J = jstart,jend
3770         DO I = istart,iend
3771            aveh_qmax(i,k,j)=aveh_q(i,k,j)
3772            aveh_qmin(i,k,j)=aveh_q(i,k,j)
3773           DO ii=-1, 1
3774            DO jj=-1,1
3775              if(aveh_q(i+II,k,j+JJ).gt.aveh_qmax(i,k,j)) aveh_qmax(i,k,j)=aveh_q(i+II,k,j+JJ)
3776              if(aveh_q(i+II,k,j+JJ).lt.aveh_qmin(i,k,j)) aveh_qmin(i,k,j)=aveh_q(i+II,k,j+JJ)
3777            ENDDO
3778           ENDDO
3779           if(aveh_qmax(i,k,j).gt.aveh_qmin(i,k,j))then
3780           coef_h(i,k,j)=(aveh_q(i,k,j)-aveh_qmin(i,k,j))/(aveh_qmax(i,k,j)-aveh_qmin(i,k,j))
3781           else
3782           coef_h(i,k,j)=0.
3783           endif
3784           coef_h(i,k,j)=amin1(coef_h(i,k,j),1.0)
3785           coef_h(i,k,j)=amax1(coef_h(i,k,j),0.0)
3786           tpart_h(i,k,j)=coef_h(i,k,j)*(T(i,k,j)-aveh_t(i,k,j))
3787         ENDDO
3788         ENDDO
3789         ENDDO
3790     89 continue
3791 ! vertical 3-layer calculation
3792         DO J = jts, jte
3793         DO I = its, ite
3794           z0(1) = 0.5 * dz8w(i,1,j)
3795           DO K = 2, kte
3796             Z0(K) = Z0(K-1) + .5 * (DZ8W(i,K,j) + DZ8W(i,K-1,j))
3797           ENDDO
3798         DO K = kts+1,kte-1
3799           ttop = t(i,k,j) + ((t(i,k,j) - t(i,k+1,j)) / (z0(k) - z0(k+1))) * (z0(k)-z0(k-1))
3800           avev_t(i,k,j)=(T(i,k-1,j) + T(i,k,j) + ttop)/3.
3801 !         avev_t(i,k,j)=(T(i,k-1,j)+T(i,k,j) + T(i,k+1,j))/3.
3802           avev_q(i,k,j)=(rqvften(i,k-1,j)+rqvften(i,k,j) + rqvften(i,k+1,j))/3.
3803         ENDDO
3804           avev_t(i,kts,j)=avev_t(i,kts+1,j)   ! lowest level value, is it the same as avev_t(i,kds,j)=avev_t(i,kds+1,j)?
3805           avev_q(i,kts,j)=avev_q(i,kts+1,j)
3806           avev_t(i,kte,j)=avev_t(i,kte-1,j)   ! highest level value
3807           avev_q(i,kte,j)=avev_q(i,kte-1,j)
3808         ENDDO
3809         ENDDO
3810 ! max /min value
3811         DO J = jts, jte
3812         DO I = its, ite
3813         DO K = kts+1,kte-1
3814           avev_qmax(i,k,j)=avev_q(i,k,j)
3815           avev_qmin(i,k,j)=avev_q(i,k,j)
3816          DO kk=-1,1
3817          if(avev_q(i,k+kk,j).gt.avev_qmax(i,k,j)) avev_qmax(i,k,j)=avev_q(i,k+kk,j)
3818          if(avev_q(i,k+kk,j).lt.avev_qmin(i,k,j)) avev_qmin(i,k,j)=avev_q(i,k+kk,j)
3819          ENDDO
3820          if(avev_qmax(i,k,j).gt.avev_qmin(i,k,j)) then
3821          coef_v(i,k,j)=(avev_q(i,k,j)-avev_qmin(i,k,j))/(avev_qmax(i,k,j)-avev_qmin(i,k,j))
3822          else
3823          coef_v(i,k,j)=0
3824          endif
3825          tpart_v(i,k,j)=coef_v(i,k,j)*(T(i,k,j)-avev_t(i,k,j))
3826         ENDDO
3827          tpart_v(i,kts,j)= tpart_v(i,kts+1,j)    ! lowest level
3828          tpart_v(i,kte,j)= tpart_v(i,kte-1,j)    ! highest level
3829         ENDDO
3830         ENDDO
3831      ENDIF       ! endif (trigger.eq.2)
3832 !
3833      DO J = jts,jte
3834      DO I= its,ite
3835         CU_ACT_FLAG(i,j) = .true.
3836      ENDDO
3837      ENDDO
3838
3839      DO J = jts,jte
3840        DO I=its,ite
3841
3842
3843          IF ( NCA(I,J) .ge. 0.5*DT ) then
3844             CU_ACT_FLAG(i,j) = .false.
3845          ELSE
3846
3847             DO k=kts,kte
3848                DQDT(k)=0.
3849                DQIDT(k)=0.
3850                DQCDT(k)=0.
3851                DQRDT(k)=0.
3852                DQSDT(k)=0.
3853                DTDT(k)=0.
3854                DUDT(k)=0.
3855                DVDT(k)=0.
3856 !ckay
3857                cldfra_dp_KF(I,k,J)=0.
3858                cldfra_sh_KF(I,k,J)=0.
3859                qc_KF(I,k,J)=0.
3860                qi_KF(I,k,J)=0.
3861              IF (aercu_opt.gt.0) THEN
3862                qr_KF(I,k,J)=0.
3863                qs_KF(I,k,J)=0.
3864                nc_KF(I,k,J)=0.
3865                ni_KF(I,k,J)=0.
3866                nr_KF(I,k,J)=0.
3867                ns_KF(I,k,J)=0.
3868                ccn_KF(I,k,J)=0.
3869                EFSS(I,k,J)=10.01
3870                EFCS(I,k,J)=2.51
3871                EFIS(I,k,J)=5.01
3872               END IF
3873             ENDDO
3874              IF (aercu_opt.gt.0) THEN
3875                ainc_frac(I,J) = 0. ! TWG
3876              END IF
3877             IF (KF_EDRATES == 1) THEN
3878                DO k=kts,kte
3879                   UDR_KF(I,k,J)=0.
3880                   DDR_KF(I,k,J)=0.
3881                   UER_KF(I,k,J)=0.
3882                   DER_KF(I,k,J)=0.
3883                ENDDO
3884                TIMEC_KF(I,J)=0.
3885             ENDIF
3886             RAINCV(I,J)=0.
3887             CUTOP(I,J)=KTS
3888             CUBOT(I,J)=KTE+1
3889             PRATEC(I,J)=0.
3890 !
3891 ! assign vars from 3D to 1D
3892
3893             DO K=kts,kte
3894                U1D(K) =U(I,K,J)
3895                V1D(K) =V(I,K,J)
3896                T1D(K) =T(I,K,J)
3897                RHO1D(K) =rho(I,K,J)
3898                QV1D(K)=QV(I,K,J)
3899                P1D(K) =Pcps(I,K,J)
3900                W0AVG1D(K) =W0AVG(I,K,J)
3901                DZ1D(k)=dz8w(I,K,J)
3902
3903                IF (trigger.eq.2) THEN
3904                   tpart_h1D(K) =tpart_h(I,K,J)
3905                   tpart_v1D(K) =tpart_v(I,K,J)
3906                ELSE
3907                   tpart_h1D(K) = 0.
3908                   tpart_v1D(K) = 0.
3909                ENDIF
3910             ENDDO
3911 !dkay
3912             IF (aercu_opt.gt.0) THEN
3913                 call mskf_mphyi ()
3914             END IF
3915
3916             CALL MSKF_eta_PARA(I, J,                  &
3917                  U1D,V1D,T1D,QV1D,P1D,DZ1D,W0AVG1D, &
3918                  tpart_h1D,tpart_v1D,               &
3919                  trigger,                           &
3920                  DT,DX,DXSQ,RHO1D,                  &
3921                  XLV0,XLV1,XLS0,XLS1,CP,R,G,        &
3922                  EP2,SVP1,SVP2,SVP3,SVPT0,          &
3923                  DQDT,DQIDT,DQCDT,DQRDT,DQSDT,DTDT, &
3924                  RAINCV,PRATEC,NCA,                 &
3925                  flag_QI,flag_QS,warm_rain,         &
3926                  CUTOP,CUBOT,CUDT,                  &
3927                  ids,ide, jds,jde, kds,kde,         &
3928                  ims,ime, jms,jme, kms,kme,         &
3929                  its,ite, jts,jte, kts,kte,         &
3930 !ckay
3931                  cldfra_dp_KF,cldfra_sh_KF,         &
3932                  qc_KF,qi_KF,qr_KF,qs_KF,           &
3933                  nc_KF,ni_KF,nr_KF,ns_KF,ccn_KF,    & !TWG
3934                  ainc_frac,                         & !TWG
3935 !kf_edrates
3936                  UDR_KF,DDR_KF,                     &
3937                  UER_KF,DER_KF,                     &
3938                  TIMEC_KF,KF_EDRATES,               &
3939                  ZOL,HFX,UST,PBLH,                  &
3940                  aerocu,no_src_types_cu,aercu_fct,  &
3941                  aercu_opt,EFCS,EFIS,EFSS,          & !PSH/TWG
3942                  DUDT, DVDT, cmt_opt_flag,XLAND)      !JTR
3943
3944 !JTR: Pass 1D tendency arrays to 3D arrays
3945               IF(cmt_opt_flag) THEN
3946                  DO K=kts,kte
3947                     RUCUTEN(I,K,J) = DUDT(K)
3948                     RVCUTEN(I,K,J) = DVDT(K)
3949                  ENDDO
3950               ENDIF
3951               DO K=kts,kte
3952                  RTHCUTEN(I,K,J)=DTDT(K)/pi(I,K,J)
3953                  RQVCUTEN(I,K,J)=DQDT(K)
3954               ENDDO
3955
3956               IF( F_QR )THEN
3957                 DO K=kts,kte
3958                    RQRCUTEN(I,K,J)=DQRDT(K)
3959                    RQCCUTEN(I,K,J)=DQCDT(K)
3960                 ENDDO
3961               ELSE
3962 ! This is the case for Eta microphysics without 3d rain field
3963                 DO K=kts,kte
3964                    RQRCUTEN(I,K,J)=0.
3965                    RQCCUTEN(I,K,J)=DQRDT(K)+DQCDT(K)
3966                 ENDDO
3967               ENDIF
3968
3969 !......     QSTEN STORES GRAUPEL TENDENCY IF IT EXISTS, OTHERISE SNOW (V2)
3970
3971               IF ( F_QI ) THEN
3972                 DO K=kts,kte
3973                    RQICUTEN(I,K,J)=DQIDT(K)
3974                 ENDDO
3975               ENDIF
3976
3977               IF ( F_QS ) THEN
3978                 DO K=kts,kte
3979                    RQSCUTEN(I,K,J)=DQSDT(K)
3980                 ENDDO
3981               ENDIF
3982 !
3983          ENDIF
3984        ENDDO     ! i-loop
3985      ENDDO       ! j-loop
3986 !
3987    END SUBROUTINE MSKF_CPS
3988 ! ****************************************************************************
3989 !-----------------------------------------------------------
3990    SUBROUTINE MSKF_eta_PARA (I, J,                           &
3991                       U0,V0,T0,QV0,P0,DZQ,W0AVG1D,         &
3992                       TPART_H0,TPART_V0,                   &
3993                       trigger,                             &
3994                       DT,DX,DXSQ,rhoe,                     &
3995                       XLV0,XLV1,XLS0,XLS1,CP,R,G,          &
3996                       EP2,SVP1,SVP2,SVP3,SVPT0,            &
3997                       DQDT,DQIDT,DQCDT,DQRDT,DQSDT,DTDT,   &
3998                       RAINCV,PRATEC,NCA,                   &
3999                       F_QI,F_QS,warm_rain,                 &
4000                       CUTOP,CUBOT,CUDT,                    &
4001                       ids,ide, jds,jde, kds,kde,           &
4002                       ims,ime, jms,jme, kms,kme,           &
4003                       its,ite, jts,jte, kts,kte,           &
4004 !ckay
4005                       cldfra_dp_KF,cldfra_sh_KF,           &
4006                       qc_KF,qi_KF,qr_KF,qs_KF,             & !TWG
4007                       nc_KF,ni_KF,nr_KF,ns_KF,ccn_KF,      & !TWG
4008                       ainc_frac,                           & !TWG
4009 !kf_edrates
4010                       UDR_KF,DDR_KF,                       &
4011                       UER_KF,DER_KF,                       &
4012                       TIMEC_KF,KF_EDRATES,                 &
4013                       ZOL,HFX,UST,PBLH,                    &
4014                       aerocu,no_src_types_cu,aercu_fct,    &
4015                       aercu_opt,EFCS,EFIS,EFSS,            & !PSH/TWG
4016                       DUDT,DVDT,cmt_opt_flag,XLAND)          !JTR
4017
4018 !-----------------------------------------------------------
4019 !***** The KF scheme that is currently used in experimental runs of EMCs
4020 !***** Eta model....jsk 8/00
4021 !
4022       IMPLICIT NONE
4023 !     SAVE  !TWG 2017 Add to avoid memory issues
4024 !-----------------------------------------------------------
4025       INTEGER, INTENT(IN   ) :: ids,ide, jds,jde, kds,kde, &
4026                                 ims,ime, jms,jme, kms,kme, &
4027                                 its,ite, jts,jte, kts,kte, &
4028                                 I,J
4029           ! ,P_QI,P_QS,P_FIRST_SCALAR
4030       INTEGER, INTENT(IN   ) ::  trigger
4031
4032       LOGICAL, INTENT(IN   ) :: F_QI, F_QS
4033
4034       LOGICAL, INTENT(IN   ) :: warm_rain
4035 !
4036       REAL, DIMENSION( kts:kte ),                          &
4037             INTENT(IN   ) ::                           U0, &
4038                                                        V0, &
4039                                                  TPART_H0, &
4040                                                  TPART_V0, &
4041                                                        T0, &
4042                                                       QV0, &
4043                                                        P0, &
4044                                                      rhoe, &
4045                                                       DZQ, &
4046                                                   W0AVG1D
4047 !
4048       REAL,  INTENT(IN   ) :: DT,DX,DXSQ
4049 !
4050
4051       REAL,  INTENT(IN   ) :: XLV0,XLV1,XLS0,XLS1,CP,R,G
4052       REAL,  INTENT(IN   ) :: EP2,SVP1,SVP2,SVP3,SVPT0
4053
4054       INTEGER, INTENT(IN   ) :: no_src_types_cu  !PSH/TWG
4055       REAL,    INTENT(IN   ) :: aercu_fct        !PSH/TWG
4056       INTEGER, INTENT(IN   ) :: aercu_opt        !PSH/TWG
4057       REAL,  DIMENSION( ims:ime, kms:kme, jms:jme, no_src_types_cu), OPTIONAL, &
4058       INTENT(INOUT) ::                                   aerocu !PSH/TWG
4059
4060
4061 !ckay
4062       REAL, DIMENSION( ims:ime, jms:jme ),                 &
4063             INTENT(   IN) ::                          ZOL, &
4064                                                       HFX, &
4065                                                       UST, &
4066                                                      PBLH, &
4067                                                      XLAND
4068 !
4069       REAL, DIMENSION( kts:kte ), INTENT(INOUT) ::         &
4070                                                      DQDT, &
4071                                                     DQIDT, &
4072                                                     DQCDT, &
4073                                                     DQRDT, &
4074                                                     DQSDT, &
4075                                                      DTDT
4076
4077       REAL,    DIMENSION( ims:ime , jms:jme ),             &
4078             INTENT(INOUT) ::                          NCA
4079
4080       REAL,    DIMENSION( ims:ime , jms:jme ),             & !TWG
4081             INTENT(INOUT) ::                      ainc_frac
4082
4083 !ckay
4084       REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),      &
4085             INTENT(INOUT) ::                 cldfra_dp_KF, &
4086                                              cldfra_sh_KF, &
4087                                                     qc_KF, &
4088                                                     qi_KF
4089
4090       REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),      &
4091             INTENT(INOUT) ::                        qr_KF, & !TWG
4092                                                     qs_KF, & !TWG
4093                                                     nc_KF, & !TWG
4094                                                     ni_KF, & !TWG
4095                                                     nr_KF, & !TWG
4096                                                     ns_KF, & !TWG
4097                                                    ccn_KF, & !TWG
4098                                                      EFCS, & !TWG
4099                                                      EFIS, & !TWG
4100                                                      EFSS
4101
4102 !kf_edrates
4103       REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),      &
4104             INTENT(INOUT) ::       UDR_KF,       &
4105                                              DDR_KF,       &
4106                                              UER_KF,       &
4107                                              DER_KF
4108
4109       REAL, DIMENSION( ims:ime , jms:jme ),                &
4110             INTENT(INOUT) ::     TIMEC_KF
4111
4112       INTEGER, INTENT(IN) ::         KF_EDRATES
4113
4114       REAL, DIMENSION( ims:ime , jms:jme ),                &
4115             INTENT(INOUT) ::                       RAINCV
4116
4117       REAL, DIMENSION( ims:ime , jms:jme ),                &
4118             INTENT(INOUT) ::                       PRATEC
4119
4120       REAL, DIMENSION( ims:ime , jms:jme ),                &
4121             INTENT(OUT) ::                          CUBOT, &
4122                                                     CUTOP
4123       REAL,  INTENT(IN   ) :: CUDT
4124 !
4125 !...DEFINE LOCAL VARIABLES...
4126 !
4127       REAL, DIMENSION( kts:kte ) ::                        &
4128             Q0,Z0,TV0,TU,TVU,QU,TZ,TVD,                    &
4129             QD,QES,THTES,TG,TVG,QG,WU,WD,W0,EMS,EMSD,      &
4130             UMF,UER,UDR,DMF,DER,DDR,UMF2,UER2,             &
4131             UDR2,DMF2,DER2,DDR2,DZA,THTA0,THETEE,          &
4132             THTAU,THETEU,THTAD,THETED,QLIQ,QICE,           &
4133 !TWG 06/14/16
4134             QRAIN,QSNOW,NLIQ,NICE,NRAIN,NSNOW,CCN,         &
4135             EFFCH,EFFIH,EFFSH, &
4136
4137 !EBD TWG
4138             QLQOUT,QICOUT,PPTLIQ,PPTICE,DETLQ,DETIC,       &
4139             DETLQ2,DETIC2,RATIO,RATIO2
4140
4141
4142       REAL, DIMENSION( kts:kte ) ::                        &
4143             DOMGDP,EXN,TVQU,DP,RH,EQFRC,WSPD,              &
4144             QDT,FXM,THTAG,THPA,THFXOUT,                    &
4145             THFXIN,QPA,QFXOUT,QFXIN,QLPA,QLFXIN,           &
4146             QLFXOUT,QIPA,QIFXIN,QIFXOUT,QRPA,              &
4147             QRFXIN,QRFXOUT,QSPA,QSFXIN,QSFXOUT,            &
4148             QL0,QLG,QI0,QIG,QR0,QRG,QS0,QSG
4149
4150
4151       REAL, DIMENSION( kts:kte+1 ) :: OMG
4152       REAL, DIMENSION( kts:kte ) :: RAINFB,SNOWFB
4153       REAL, DIMENSION( kts:kte ) ::                        &
4154             CLDHGT,QSD,DILFRC,DDILFRC,TKE,TGU,QGU,THTEEG
4155
4156 ! LOCAL VARS
4157
4158       REAL    :: P00,T00,RLF,RHIC,RHBC,PIE,         &
4159                  TTFRZ,TBFRZ,C5,RATE
4160       REAL    :: GDRY,ROCP,ALIQ,BLIQ,                      &
4161                  CLIQ,DLIQ
4162       REAL    :: FBFRC,P300,DPTHMX,THMIX,QMIX,ZMIX,PMIX,   &
4163                  ROCPQ,TMIX,EMIX,TLOG,TDPT,TLCL,TVLCL,     &
4164                  CPORQ,PLCL,ES,DLP,TENV,QENV,TVEN,TVBAR,   &
4165                  ZLCL,WKL,WABS,TRPPT,WSIGNE,DTLCL,GDT,WLCL,&
4166                  TVAVG,QESE,WTW,RHOLCL,AU0,VMFLCL,UPOLD,   &
4167                  UPNEW,ABE,WKLCL,TTEMP,FRC1,   &
4168                  QNEWIC,RL,R1,QNWFRZ,EFFQ,BE,BOTERM,ENTERM,&
4169                  DZZ,UDLBE,REI,EE2,UD2,TTMP,F1,F2,         &
4170                  THTTMP,QTMP,TMPLIQ,TMPICE,TU95,TU10,EE1,  &
4171                  UD1,DPTT,QNEWLQ,DUMFDP,EE,TSAT,           &
4172                  THTA,VCONV,TIMEC,SHSIGN,VWS,PEF, &
4173                  CBH,RCBH,PEFCBH,PEFF,PEFF2,TDER,THTMIN,   &
4174                  DTMLTD,QS,TADVEC,DPDD,FRC,DPT,RDD,A1,     &
4175                  DSSDT,DTMP,T1RH,QSRH,PPTFLX,CPR,CNDTNF,   &
4176                  UPDINC,AINCM2,DEVDMF,PPR,RCED,DPPTDF,     &
4177                  DMFLFS,DMFLFS2,RCED2,DDINC,AINCMX,AINCM1, &
4178                  AINC,TDER2,PPTFL2,FABE,STAB,DTT,DTT1,     &
4179                  DTIME,TMA,TMB,TMM,BCOEFF,ACOEFF,QVDIFF,   &
4180                  TOPOMG,CPM,DQ,ABEG,DABE,DFDA,FRC2,DR,     &
4181                  UDFRC,TUC,QGS,RH0,RHG,QINIT,QFNL,ERR2,    &
4182                  RELERR,RLC,RLS,RNC,FABEOLD,AINCOLD,UEFRC, &
4183                  DDFRC,TDC,DEFRC,RHBAR,DMFFRC,DPMIN,DILBE
4184    REAL    ::    ASTRT,TP,VALUE,AINTRP,TKEMAX,QFRZ,&
4185                  QSS,PPTMLT,DTMELT,RHH,EVAC,BINC
4186 !
4187       INTEGER :: INDLU,NU,NUCHM,NNN,KLFS
4188    REAL    :: CHMIN,PM15,CHMAX,DTRH,RAD,DPPP
4189    REAL    :: TVDIFF,DTTOT,ABSOMG,ABSOMGTC,FRDP
4190 !ckay
4191    REAL    :: xcldfra,UMF_new,DMF_new,FXM_new
4192    REAL    :: sourceht, Scale_Fac, TOKIOKA, RATE_kay
4193    REAL    :: capeDX, tempKay
4194    REAL    :: SCLvel, ZLCL_KAY, zz_kay
4195
4196 !ckaywup
4197    REAL    :: envEsat, envQsat, envRH, envRHavg, denSplume
4198    REAL    :: updil, Drag, WST, thetav
4199 !TWG Mar 2017
4200    REAL, PARAMETER :: P1_HU10 = 7.6725
4201    REAL, PARAMETER :: P2_HU10 = 1.0118
4202    REAL, PARAMETER :: P3_HU10 = 0.1422
4203    REAL, PARAMETER :: P4_HU10 = 0.0106
4204    REAL, PARAMETER :: P5_HU10 = 3.39E-4
4205    REAL, PARAMETER :: P6_HU10 = 3.95E-6
4206    REAL    :: SF_HU10, TC_HU10
4207 !END TWG
4208 !dkay for dccmp
4209    real :: a1kay
4210    LOGICAL :: DCCMP
4211    REAL :: eps1u, alatent, Qsu
4212    LOGICAL :: onetime
4213    Data onetime/.true./
4214    integer, parameter :: r8 = 8
4215    integer, parameter :: naer_cu = 10
4216    integer, parameter :: pcols = 1
4217    REAL(r8) muu(pcols, KTS:KTE)
4218    REAL(r8) su(pcols, KTS:KTE)
4219    REAL(r8) quu(pcols, KTS:KTE)
4220    REAL(r8) duu(pcols, KTS:KTE)
4221    REAL(r8) euu(pcols, KTS:KTE)
4222    REAL(r8) cmel(pcols, KTS:KTE)
4223    REAL(r8) cmei(pcols, KTS:KTE)
4224    REAL(r8) zfu(pcols, KTS:KTE+1)
4225    REAL(r8) zf_wrf(0:KTE)
4226    REAL(r8) pru(pcols, KTS:KTE)
4227    REAL(r8) tee(pcols, KTS:KTE)
4228    REAL(r8) qee(pcols, KTS:KTE)
4229    REAL(r8) qsatzm(pcols, KTS:KTE)
4230    REAL(r8) gamhat(pcols, KTS:KTE)
4231    REAL(r8) aer_mmr(pcols, KTS:KTE,naer_cu)
4232    REAL(r8) Aqnewic(KTS:KTE)
4233    REAL(r8) Aqnewlq(KTS:KTE)
4234    REAL(r8) wu_mskf_act(KTS:KTE)
4235    REAL(r8) qc_mskf_act(KTS:KTE)
4236    REAL(r8) qi_mskf_act(KTS:KTE)
4237    REAL(r8) effc(pcols, KTS:KTE)
4238    REAL(r8) effi(pcols, KTS:KTE)
4239    REAL(r8) effs(pcols, KTS:KTE)
4240    real(r8) QSATu(KTS:KTE), oldQU(KTS:KTE),oldTU(KTS:KTE)      ! rate of freezing
4241    REAL(r8) EPSI0(pcols)
4242    REAL(r8) dLfmzmp(pcols,KTS:KTE),dIfmzmp(pcols,KTS:KTE)
4243 !junk
4244    REAL(r8) oldpptliq(KTS:KTE)
4245    REAL(r8) oldpptice(KTS:KTE)
4246
4247    REAL(r8) wump(pcols, KTS:KTE)
4248    real(r8) zmqliq(pcols,KTS:KTE)       ! cloud water mixing ratio (kg/kg)
4249    real(r8) zmqice(pcols,KTS:KTE)       ! cloud ice mixing ratio (kg/kg)
4250    real(r8) zmqrain(pcols,KTS:KTE)      ! rain mixing ratio (kg/kg) !TWG
4251    real(r8) zmqsnow(pcols,KTS:KTE)      ! snow mixing ratio (kg/kg) !TWG
4252    real(r8) ncmp(pcols,KTS:KTE)       ! cloud water number conc (1/kg)
4253    real(r8) nimp(pcols,KTS:KTE)       ! cloud ice number conc (1/kg)
4254    real(r8) nrmp(pcols,KTS:KTE)       ! rain number conc (1/kg) !TWG
4255    real(r8) nsmp(pcols,KTS:KTE)       ! snow number conc (1/kg) !TWG
4256    real(r8) zmccn(pcols,KTS:KTE)       ! ccn conc (1/kg) !TWG
4257    real(r8) rprd(pcols,KTS:KTE)     ! rate of production of precip at that layer
4258    real(r8) sprd(pcols,KTS:KTE)     ! rate of production of snow at that layer
4259    real(r8) frz(pcols,KTS:KTE)      ! rate of freezing
4260
4261    REAL(r8) grav, Rdry , DTZMP, CPIN, psh_fac
4262
4263    Integer KQ, JK, JBB(1), JTT(1), JLCL(1), msg1, il2g , JZM, KA
4264    Integer NLEVZM, NLEVZMP1, KKAY, Miter, Itest, KC
4265 !dkay
4266
4267       INTEGER :: KX,K,KL
4268 !
4269       INTEGER :: NCHECK
4270       INTEGER, DIMENSION (kts:kte) :: KCHECK
4271
4272       INTEGER :: ISTOP,ML,L5,KMIX,LOW,                     &
4273                  LC,MXLAYR,LLFC,NLAYRS,NK,                 &
4274                  KPBL,KLCL,LCL,LET,IFLAG,                  &
4275                  NK1,LTOP,NJ,LTOP1,                        &
4276                  LTOPM1,LVF,KSTART,KMIN,LFS,               &
4277                  ND,NIC,LDB,LDT,ND1,NDK,                   &
4278                  NM,LMAX,NCOUNT,NOITR,                     &
4279                  NSTEP,NTC,NCHM,ISHALL,NSHALL
4280       LOGICAL :: IPRNT
4281       REAL :: u00,qslcl,rhlcl,dqssdt    !jfb
4282       CHARACTER*1024 message
4283
4284 !JTR 06/18/2019: Variables needed for CMT
4285       REAL, DIMENSION (kts:kte), INTENT(INOUT) :: DUDT, DVDT
4286       REAL, DIMENSION (kts:kte) :: TDN,TUP
4287       REAL, DIMENSION (kts:kte) :: stat_energy
4288       REAL(r8), DIMENSION (pcols,kts:kte) :: DUDTnew, DVDTnew,   &
4289                                              DPDX, DPDY, MC,     &
4290                                              DERconvF, UERconvF, &
4291                                              UMFconvF, DMFconvF, &
4292                                              DPconvF, U0F, V0F,  &
4293                                              Z0F, SUU, SDD,      &
4294                                              SHAT, QHAT, QDN,QUP
4295       Logical :: CMTprint
4296       Data CMTprint/.false./
4297       INTEGER :: JDD(1), IL1G, ILG
4298       REAL(r8) :: DSUBCLD(1), VMFLCLconv(1), DTnew
4299       LOGICAL :: cmt_opt_flag
4300
4301 !
4302       DATA P00,T00/1.E5,273.16/
4303       DATA RLF/3.339E5/
4304       DATA RHIC,RHBC/1.,0.90/
4305       DATA PIE,TTFRZ,TBFRZ,C5/3.141592654,268.16,248.16,1.0723E-3/
4306       DATA RATE/0.03/   ! wrf default
4307 !      DATA RATE/0.01/  ! value used in NRCM
4308 !      DATA RATE/0.001/  ! effectively turn off autoconversion
4309 !-----------------------------------------------------------
4310    IF (aercu_opt.gt.0) THEN
4311      DCCMP = .TRUE.
4312    ELSE
4313      DCCMP = .FALSE.
4314    END IF
4315
4316       IPRNT=.FALSE.
4317       GDRY=-G/CP
4318       ROCP=R/CP
4319       NSHALL = 0
4320       KL=kte
4321       KX=kte
4322 !
4323 !     ALIQ = 613.3
4324 !     BLIQ = 17.502
4325 !     CLIQ = 4780.8
4326 !     DLIQ = 32.19
4327       ALIQ = SVP1*1000.
4328       BLIQ = SVP2
4329       CLIQ = SVP2*SVPT0
4330       DLIQ = SVP3
4331 !
4332       IF(DX.GE.24.999E3) THEN
4333          Scale_Fac = 1.0
4334          capeDX = 0.1
4335       ELSE
4336          Scale_Fac = 1.0 + (log(25.E3/DX))
4337          capeDX = 0.1 *SQRT(Scale_Fac)
4338       END IF
4339 !
4340 !****************************************************************************
4341 !                                                      ! PPT FB MODS
4342 !...OPTION TO FEED CONVECTIVELY GENERATED RAINWATER    ! PPT FB MODS
4343 !...INTO GRID-RESOLVED RAINWATER (OR SNOW/GRAUPEL)     ! PPT FB MODS
4344 !...FIELD.  "FBFRC" IS THE FRACTION OF AVAILABLE       ! PPT FB MODS
4345 !...PRECIPITATION TO BE FED BACK (0.0 - 1.0)...        ! PPT FB MODS
4346       FBFRC=0.0                                        ! PPT FB MODS
4347 !...mods to allow shallow convection...
4348       NCHM = 0
4349       ISHALL = 0
4350       DPMIN = 5.E3
4351 !...
4352       P300=P0(1)-30000.
4353 !
4354 !...PRESSURE PERTURBATION TERM IS ONLY DEFINED AT MID-POINT OF
4355 !...VERTICAL LAYERS...SINCE TOTAL PRESSURE IS NEEDED AT THE TOP AND
4356 !...BOTTOM OF LAYERS BELOW, DO AN INTERPOLATION...
4357 !
4358 !...INPUT A VERTICAL SOUNDING ... NOTE THAT MODEL LAYERS ARE NUMBERED
4359 !...FROM BOTTOM-UP IN THE KF SCHEME...
4360 !
4361       ML=0
4362 !SUE  tmprpsb=1./PSB(I,J)
4363 !SUE  CELL=PTOP*tmprpsb
4364 !
4365       DO K=1,KX
4366 !
4367 !  Saturation vapor pressure (ES) is calculated following Buck (1981)
4368 !...IF Q0 IS ABOVE SATURATION VALUE, REDUCE IT TO SATURATION LEVEL...
4369 !
4370          ES=ALIQ*EXP((BLIQ*T0(K)-CLIQ)/(T0(K)-DLIQ))
4371          QES(K)=0.622*ES/(P0(K)-ES)
4372          Q0(K)=AMIN1(QES(K),QV0(K))
4373          Q0(K)=AMAX1(0.000001,Q0(K))
4374          QL0(K)=0.
4375          QI0(K)=0.
4376          QR0(K)=0.
4377          QS0(K)=0.
4378          RH(K) = Q0(K)/QES(K)
4379          DILFRC(K) = 1.
4380          TV0(K)=T0(K)*(1.+0.608*Q0(K))
4381 !        RHOE(K)=P0(K)/(R*TV0(K))
4382 !   DP IS THE PRESSURE INTERVAL BETWEEN FULL SIGMA LEVELS...
4383          DP(K)=rhoe(k)*g*DZQ(k)
4384 ! IF Turbulent Kinetic Energy (TKE) is available from turbulent mixing scheme
4385 ! use it for shallow convection...For now, assume it is not available....
4386 !         TKE(K) = Q2(I,J,NK)
4387          TKE(K) = 0.
4388          CLDHGT(K) = 0.
4389 !        IF(P0(K).GE.500E2)L5=K
4390          IF(P0(K).GE.0.5*P0(1))L5=K
4391          IF(P0(K).GE.P300)LLFC=K
4392       ENDDO
4393 !
4394 !...DZQ IS DZ BETWEEN SIGMA SURFACES, DZA IS DZ BETWEEN MODEL HALF LEVEL
4395         Z0(1)=.5*DZQ(1)
4396 !cdir novector
4397         DO K=2,KL
4398           Z0(K)=Z0(K-1)+.5*(DZQ(K)+DZQ(K-1))
4399           DZA(K-1)=Z0(K)-Z0(K-1)
4400         ENDDO
4401         DZA(KL)=0.
4402 !
4403 !
4404 !  To save time, specify a pressure interval to move up in sequential
4405 !  check of different ~50 mb deep groups of adjacent model layers in
4406 !  the process of identifying updraft source layer (USL).  Note that
4407 !  this search is terminated as soon as a buoyant parcel is found and
4408 !  this parcel can produce a cloud greater than specifed minimum depth
4409 !  (CHMIN)...For now, set interval at 15 mb...
4410 !
4411        NCHECK = 1
4412        KCHECK(NCHECK)=1
4413        PM15 = P0(1)-15.E2
4414        DO K=2,LLFC
4415          IF(P0(K).LT.PM15)THEN
4416            NCHECK = NCHECK+1
4417            KCHECK(NCHECK) = K
4418            PM15 = PM15-15.E2
4419          ENDIF
4420        ENDDO
4421 !
4422        NU=0
4423        NUCHM=0
4424 usl:   DO
4425            NU = NU+1
4426            IF(NU.GT.NCHECK)THEN
4427              IF(ISHALL.EQ.1)THEN
4428                CHMAX = 0.
4429                NCHM = 0
4430                DO NK = 1,NCHECK
4431                  NNN=KCHECK(NK)
4432                  IF(CLDHGT(NNN).GT.CHMAX)THEN
4433                    NCHM = NNN
4434                    NUCHM = NK
4435                    CHMAX = CLDHGT(NNN)
4436                  ENDIF
4437                ENDDO
4438                NU = NUCHM-1
4439                FBFRC=1.
4440                CYCLE usl
4441              ELSE
4442                RETURN
4443              ENDIF
4444            ENDIF
4445            KMIX = KCHECK(NU)
4446            LOW=KMIX
4447 !...
4448            LC = LOW
4449 !
4450 !...ASSUME THAT IN ORDER TO SUPPORT A DEEP UPDRAFT YOU NEED A LAYER OF
4451 !...UNSTABLE AIR AT LEAST 50 mb DEEP...TO APPROXIMATE THIS, ISOLATE A
4452 !...GROUP OF ADJACENT INDIVIDUAL MODEL LAYERS, WITH THE BASE AT LEVEL
4453 !...LC, SUCH THAT THE COMBINED DEPTH OF THESE LAYERS IS AT LEAST 50 mb..
4454 !
4455            NLAYRS=0
4456            DPTHMX=0.
4457            NK=LC-1
4458            IF ( NK+1 .LT. KTS ) THEN
4459              WRITE(message,*)'WOULD GO OFF BOTTOM: MSKF_PARA I,J,NK',I,J,NK
4460              CALL wrf_message (TRIM(message))
4461            ELSE
4462              DO
4463                NK=NK+1
4464                IF ( NK .GT. KTE ) THEN
4465                  WRITE(message,*)'WOULD GO OFF TOP: MSKF_PARA I,J,DPTHMX,DPMIN',I,J,DPTHMX,DPMIN
4466                  CALL wrf_message (TRIM(message))
4467                  EXIT
4468                ENDIF
4469                DPTHMX=DPTHMX+DP(NK)
4470                NLAYRS=NLAYRS+1
4471                IF(DPTHMX.GT.DPMIN)THEN
4472                  EXIT
4473                ENDIF
4474              END DO
4475            ENDIF
4476            IF(DPTHMX.LT.DPMIN)THEN
4477              RETURN
4478            ENDIF
4479            KPBL=LC+NLAYRS-1
4480 !
4481 !...********************************************************
4482 !...for computational simplicity without much loss in accuracy,
4483 !...mix temperature instead of theta for evaluating convective
4484 !...initiation (triggering) potential...
4485 !          THMIX=0.
4486            TMIX=0.
4487            QMIX=0.
4488            ZMIX=0.
4489            PMIX=0.
4490 !
4491 !...FIND THE THERMODYNAMIC CHARACTERISTICS OF THE LAYER BY
4492 !...MASS-WEIGHTING THE CHARACTERISTICS OF THE INDIVIDUAL MODEL
4493 !...LAYERS...
4494 !
4495 !cdir novector
4496            DO NK=LC,KPBL
4497              TMIX=TMIX+DP(NK)*T0(NK)
4498              QMIX=QMIX+DP(NK)*Q0(NK)
4499              ZMIX=ZMIX+DP(NK)*Z0(NK)
4500              PMIX=PMIX+DP(NK)*P0(NK)
4501            ENDDO
4502 !         THMIX=THMIX/DPTHMX
4503           TMIX=TMIX/DPTHMX
4504           QMIX=QMIX/DPTHMX
4505           ZMIX=ZMIX/DPTHMX
4506           PMIX=PMIX/DPTHMX
4507           EMIX=QMIX*PMIX/(0.622+QMIX)
4508 !
4509 !...FIND THE TEMPERATURE OF THE MIXTURE AT ITS LCL...
4510 !
4511 !        TLOG=ALOG(EMIX/ALIQ)
4512 ! ...calculate dewpoint using lookup table...
4513 !
4514           astrt=1.e-3
4515           ainc=0.075
4516           a1=emix/aliq
4517           tp=(a1-astrt)/ainc
4518           indlu=int(tp)+1
4519           value=(indlu-1)*ainc+astrt
4520           aintrp=(a1-value)/ainc
4521           tlog=aintrp*alu(indlu+1)+(1-aintrp)*alu(indlu)
4522           TDPT=(CLIQ-DLIQ*TLOG)/(BLIQ-TLOG)
4523           TLCL=TDPT-(.212+1.571E-3*(TDPT-T00)-4.36E-4*(TMIX-T00))*(TMIX-TDPT)
4524           TLCL=AMIN1(TLCL,TMIX)
4525           TVLCL=TLCL*(1.+0.608*QMIX)
4526           ZLCL = ZMIX+(TLCL-TMIX)/GDRY
4527      !     NK = LC-1
4528      !     DO
4529      !       NK = NK+1
4530      !       KLCL=NK
4531      !       IF(ZLCL.LE.Z0(NK) .or. NK.GT.KL)THEN
4532      !         EXIT
4533      !       ENDIF
4534      !     ENDDO
4535      !     IF(NK.GT.KL)THEN
4536      !       RETURN
4537      !     ENDIF
4538
4539        DO NK = LC, KL
4540          KLCL = NK
4541          IF ( ZLCL.LE.Z0(NK) )  EXIT
4542      END DO
4543      IF ( ZLCL.GT.Z0(KL) )  RETURN
4544
4545           K=KLCL-1
4546 ! calculate DLP using Z instead of log(P)
4547           DLP=(ZLCL-Z0(K))/(Z0(KLCL)-Z0(K))
4548 !
4549 !...ESTIMATE ENVIRONMENTAL TEMPERATURE AND MIXING RATIO AT THE LCL...
4550 !
4551           TENV=T0(K)+(T0(KLCL)-T0(K))*DLP
4552           QENV=Q0(K)+(Q0(KLCL)-Q0(K))*DLP
4553           TVEN=TENV*(1.+0.608*QENV)
4554 !
4555 ! ww: this needs to be initialized
4556           DTRH = 0.
4557
4558 ! Bechtold 2001 trigger with my Beta parameter
4559            DTLCL = W0AVG1D(KLCL)/Scale_Fac
4560            if(DTLCL.lt.0.0) then
4561               tempKay = -1.0
4562               DTLCL = tempKay * DTLCL
4563               DTLCL = (DTLCL)**0.3333
4564            else
4565               tempKay = 1.0
4566               DTLCL = tempKay * DTLCL
4567               DTLCL = (DTLCL)**0.3333
4568            end if
4569
4570            DTLCL = 6.0 * tempKay * DTLCL
4571 !
4572 ! old trigger
4573 ! Stick with the old trigger for now... CGM July 2015
4574 !
4575           IF(ZLCL.LT.2.E3)THEN        ! Kain (2004) Eq. 2
4576             WKLCL=0.02*ZLCL/2.E3
4577           ELSE
4578             WKLCL=0.02                ! units of m/s
4579           ENDIF
4580 !TWG.ckay c
4581          if(DX.GE.25.E3) then
4582            WKL=(W0AVG1D(K)+(W0AVG1D(KLCL)-W0AVG1D(K))*DLP)*DX/25.E3-WKLCL
4583          else
4584            WKL=(W0AVG1D(K)+(W0AVG1D(KLCL)-W0AVG1D(K))*DLP)-WKLCL
4585          end if
4586 !TWG ckay, Modified WKL
4587           IF(WKL.LT.0.0001)THEN
4588             DTLCL=0.
4589           ELSE
4590             DTLCL=4.64*WKL**0.33      ! Kain (2004) Eq. 1
4591           ENDIF
4592
4593
4594 !         IF(ISHALL.EQ.1)IPRNT=.TRUE.
4595 !         IPRNT=.TRUE.
4596 !         IF(TLCL+DTLCL.GT.TENV)GOTO 45
4597
4598            IF(TLCL+DTLCL.LT.TENV)THEN
4599 !
4600 ! Parcel not buoyant, CYCLE back to start of trigger and evaluate next potential
4601 ! USL...
4602 !
4603             CYCLE usl
4604 !
4605           ELSE                            ! Parcel is buoyant, determine updraft
4606 !
4607 !...CONVECTIVE TRIGGERING CRITERIA HAS BEEN SATISFIED...COMPUTE
4608 !...EQUIVALENT POTENTIAL TEMPERATURE
4609 !...(THETEU) AND VERTICAL VELOCITY OF THE RISING PARCEL AT THE LCL...
4610 !
4611             CALL ENVIRTHT(PMIX,TMIX,QMIX,THETEU(K),ALIQ,BLIQ,CLIQ,DLIQ)
4612 !
4613 !...modify calculation of initial parcel vertical velocity...jsk 11/26/97
4614 !
4615             DTTOT = DTLCL+DTRH
4616             IF(DTTOT.GT.1.E-4)THEN
4617               GDT=2.*G*DTTOT*500./TVEN     ! Kain (2004) Eq. 3  (sort of)
4618               WLCL=1.+0.5*SQRT(GDT)
4619               WLCL = AMIN1(WLCL,3.)
4620             ELSE
4621               WLCL=1.
4622             ENDIF
4623             PLCL=P0(K)+(P0(KLCL)-P0(K))*DLP
4624             WTW=WLCL*WLCL
4625 !
4626             TVLCL=TLCL*(1.+0.608*QMIX)
4627             RHOLCL=PLCL/(R*TVLCL)
4628 !
4629             LCL=KLCL
4630             LET=LCL
4631 !ckay
4632 ! new formulation based on the LCL replacing the cloud radius concept
4633 !introduce LCL instead of RAD based on WKL here
4634             RAD = ZLCL
4635 !ckay Dec20
4636             sourceht = Z0(KPBL)
4637             RAD = amax1(sourceht, RAD)
4638
4639             RAD = AMIN1(4000.,RAD)  ! max trap
4640             RAD = AMAX1(500.,RAD)  ! min trap
4641
4642 !
4643 !*******************************************************************
4644 !                                                                  *
4645 !                 COMPUTE UPDRAFT PROPERTIES                       *
4646 !                                                                  *
4647 !*******************************************************************
4648 !
4649 !
4650 !...
4651 !...ESTIMATE INITIAL UPDRAFT MASS FLUX (UMF(K))...
4652 !
4653             WU(K)=WLCL
4654             AU0=0.01*DXSQ
4655             UMF(K)=RHOLCL*AU0
4656
4657             VMFLCL=UMF(K)
4658             UPOLD=VMFLCL
4659             UPNEW=UPOLD
4660 !
4661 !...RATIO2 IS THE DEGREE OF GLACIATION IN THE CLOUD (0 TO 1),
4662 !...UER IS THE ENVIR ENTRAINMENT RATE, ABE IS AVAILABLE
4663 !...BUOYANT ENERGY, TRPPT IS THE TOTAL RATE OF PRECIPITATION
4664 !...PRODUCTION...
4665 !
4666             RATIO2(K)=0.
4667             UER(K)=0.
4668             ABE=0.
4669             TRPPT=0.
4670             TU(K)=TLCL
4671             TVU(K)=TVLCL
4672             QU(K)=QMIX
4673             EQFRC(K)=1.
4674             QLIQ(K)=0.
4675             QICE(K)=0.
4676          IF (aercu_opt .GT. 0) THEN
4677             QRAIN(K)=0.
4678             QSNOW(K)=0.
4679             NLIQ(K)=0.
4680             NICE(K)=0.
4681             NRAIN(K)=0.
4682             NSNOW(K)=0.
4683             CCN(K)=0.
4684             EFFCH(K) = 2.5
4685             EFFIH(K) = 4.99
4686             EFFSH(K) = 9.99
4687          END IF
4688             QLQOUT(K)=0.
4689             QICOUT(K)=0.
4690             DETLQ(K)=0.
4691             DETIC(K)=0.
4692             PPTLIQ(K)=0.
4693             PPTICE(K)=0.
4694             IFLAG=0
4695 !
4696 !...TTEMP IS USED DURING CALCULATION OF THE LINEAR GLACIATION
4697 !...PROCESS; IT IS INITIALLY SET TO THE TEMPERATURE AT WHICH
4698 !...FREEZING IS SPECIFIED TO BEGIN.  WITHIN THE GLACIATION
4699 !...INTERVAL, IT IS SET EQUAL TO THE UPDRAFT TEMP AT THE
4700 !...PREVIOUS MODEL LEVEL...
4701 !
4702             TTEMP=TTFRZ
4703 !
4704 !...ENTER THE LOOP FOR UPDRAFT CALCULATIONS...CALCULATE UPDRAFT TEMP,
4705 !...MIXING RATIO, VERTICAL MASS FLUX, LATERAL DETRAINMENT OF MASS AND
4706 !...MOISTURE, PRECIPITATION RATES AT EACH MODEL LEVEL...
4707 !
4708 !    **1 variables indicate the bottom of a model layer
4709 !    **2 variables indicate the top of a model layer
4710 !
4711             EE1=1.
4712             UD1=0.
4713             REI = 0.
4714             DILBE = 0.
4715
4716 !dkay
4717       IF (aercu_opt.gt.0) THEN
4718                 zf_wrf(0) = 0.0  ! ground
4719                 DO KQ=KTS,KTE
4720                  zf_wrf(KQ) = zf_wrf(KQ-1)+DZQ(KQ)
4721                  Aqnewlq(kq) = 0.0
4722                  Aqnewic(kq) = 0.0
4723                  rprd(1,kq) = 0.0
4724                  wump(1,kq) =0.0
4725                  ncmp(1,kq) =0.0
4726                  nimp(1,kq) =0.0
4727                  sprd(1,kq) =0.0
4728                  frz(1,kq) =0.0
4729                  jk = kq
4730                  muu(1,JK) = 0.0
4731                  duu(1,JK) =0.0
4732                  EUU(1,JK) =0.0
4733                  cmel(1,JK) =0.0
4734                  cmei(1,JK) =0.0
4735                  oldTU(kq) = t0(kq)
4736                  oldQU(kq) = Q0(kq)
4737                 End do
4738               Miter = 0
4739       END IF
4740
4741 updraft:    DO NK=K,KL-1
4742               NK1=NK+1
4743               RATIO2(NK1)=RATIO2(NK)
4744               FRC1=0.
4745               TU(NK1)=T0(NK1)
4746               THETEU(NK1)=THETEU(NK)
4747               QU(NK1)=QU(NK)
4748 !dkay
4749      IF (aercu_opt.gt.0) THEN
4750               oldQU(NK) = QU(NK)
4751               oldTU(NK) = TU(NK)
4752      END IF
4753 !dkay
4754               QLIQ(NK1)=QLIQ(NK)
4755               QICE(NK1)=QICE(NK)
4756               call tpmix2(p0(nk1),theteu(nk1),tu(nk1),qu(nk1),qliq(nk1),        &
4757                      qice(nk1),qnewlq,qnewic,XLV1,XLV0,QSu)
4758
4759 !dkay QSu has been added to the tpmix2
4760
4761 !dkay
4762 ! saturation value of Q of updraft for use with gamma hat in DCCMP routine
4763 !   IF (aercu_opt.gt.0) THEN
4764 !        QSATu(NK) = QSu/(1.+QSu)   ! saturated specific hum
4765 !         Aqnewlq(NK) = qnewlq
4766 !         Aqnewic(NK) = qnewic
4767
4768 !        Aqnewlq(NK) = qnewlq + Qliq(nk )   This is to be removed
4769 !        Aqnewic(NK) = qnewic + Qice(nk )
4770
4771 !dkaydec26
4772      !    if(TU(NK).le.273.) then
4773      !     Aqnewlq(NK) = 0.0
4774      !     Aqnewic(NK) = qnewlq + qnewic
4775       !   else
4776        !   Aqnewlq(NK) = qnewlq + qnewic
4777         !  Aqnewic(NK) = 0.0
4778         ! end if
4779 !   END IF
4780 !
4781 !
4782 !...CHECK TO SEE IF UPDRAFT TEMP IS ABOVE THE TEMPERATURE AT WHICH
4783 !/dec26...GLACIATION IS ASSUMED TO INITIATE; IF IT IS, CALCULATE THE
4784 !...FRACTION OF REMAINING LIQUID WATER TO FREEZE...TTFRZ IS THE
4785 !...TEMP AT WHICH FREEZING BEGINS, TBFRZ THE TEMP BELOW WHICH ALL
4786 !...LIQUID WATER IS FROZEN AT EACH LEVEL...
4787 !
4788               IF(TU(NK1).LE.TTFRZ)THEN
4789                 IF(TU(NK1).GT.TBFRZ)THEN
4790                   IF(TTEMP.GT.TTFRZ)TTEMP=TTFRZ
4791                   FRC1=(TTEMP-TU(NK1))/(TTEMP-TBFRZ)
4792                 ELSE
4793                   FRC1=1.
4794                   IFLAG=1
4795                 ENDIF
4796                 TTEMP=TU(NK1)
4797                 !print*,'OLD FRC1',FRC1
4798
4799 !TWG Mar 2017
4800 !Refine FRC1 to match super cooled water path estimate from Hu et al. [2010]
4801            IF (aercu_opt.gt.0) THEN
4802             IF(TU(NK1).GT.TBFRZ)THEN
4803              TC_HU10 = TU(NK1)-273.15
4804              SF_HU10 = -1.0*(P1_HU10+(P2_HU10*TC_HU10)+(P3_HU10*(TC_HU10**2))+ &
4805              (P4_HU10*(TC_HU10**3))+(P5_HU10*(TC_HU10**4))+(P6_HU10*(TC_HU10**5)))
4806              FRC1 = 1.0 - (1.0/(1.0 + EXP(SF_HU10)))
4807             ELSE
4808              FRC1=1.
4809              IFLAG=1
4810             ENDIF
4811            END IF
4812 !END TWG
4813 !
4814 !  DETERMINE THE EFFECTS OF LIQUID WATER FREEZING WHEN TEMPERATURE
4815 !...IS BELOW TTFRZ...
4816 !
4817                 QFRZ = (QLIQ(NK1)+QNEWLQ)*FRC1
4818                 QNEWIC=QNEWIC+QNEWLQ*FRC1
4819                 QNEWLQ=QNEWLQ-QNEWLQ*FRC1
4820                 QICE(NK1) = QICE(NK1)+QLIQ(NK1)*FRC1
4821                 QLIQ(NK1) = QLIQ(NK1)-QLIQ(NK1)*FRC1
4822                 CALL DTFRZNEW(TU(NK1),P0(NK1),THETEU(NK1),QU(NK1),QFRZ,         &
4823                           QICE(NK1),ALIQ,BLIQ,CLIQ,DLIQ)
4824               ENDIF
4825               TVU(NK1)=TU(NK1)*(1.+0.608*QU(NK1))
4826
4827    IF (aercu_opt.gt.0) THEN
4828         QSATu(NK) = QSu/(1.+QSu)   ! saturated specific hum
4829          Aqnewlq(NK) = qnewlq
4830          Aqnewic(NK) = qnewic
4831    END IF
4832
4833 !
4834 !  CALCULATE UPDRAFT VERTICAL VELOCITY AND PRECIPITATION FALLOUT...
4835 !
4836               IF(NK.EQ.K)THEN
4837                 BE=(TVLCL+TVU(NK1))/(TVEN+TV0(NK1))-1.
4838                 BOTERM=2.*(Z0(NK1)-ZLCL)*G*BE/1.5
4839                 DZZ=Z0(NK1)-ZLCL
4840               ELSE
4841                 BE=(TVU(NK)+TVU(NK1))/(TV0(NK)+TV0(NK1))-1.
4842                 BOTERM=2.*DZA(NK)*G*BE/1.5
4843                 DZZ=DZA(NK)
4844               ENDIF
4845               ENTERM=2.*REI*WTW/UPOLD
4846 !
4847 ! ckay
4848 ! using corrected RATE_kay for Test simulation #2... CGM July 2015
4849 !
4850               IF(DX.GE.24.999E3) then
4851                 RATE_kay = RATE
4852               else
4853                 RATE_kay = RATE / Scale_Fac
4854                end if
4855               CALL CONDLOAD(QLIQ(NK1),QICE(NK1),WTW,DZZ,BOTERM,ENTERM,      &
4856                    RATE_kay,QNEWLQ,QNEWIC,QLQOUT(NK1),QICOUT(NK1),G)
4857
4858 !
4859 !...IF VERT VELOCITY IS LESS THAN ZERO, EXIT THE UPDRAFT LOOP AND,
4860 !...IF CLOUD IS TALL ENOUGH, FINALIZE UPDRAFT CALCULATIONS...
4861 !
4862               IF(WTW.LT.1.E-3)THEN
4863                 EXIT
4864               ELSE
4865                 WU(NK1)=SQRT(WTW)
4866               ENDIF
4867 !...Calculate value of THETA-E in environment to entrain into updraft...
4868 !
4869               CALL ENVIRTHT(P0(NK1),T0(NK1),Q0(NK1),THETEE(NK1),ALIQ,BLIQ,CLIQ,DLIQ)
4870 !
4871 !...REI IS THE RATE OF ENVIRONMENTAL INFLOW...
4872 ! New formulation for entrainment
4873 !ckay introduce DX dependcy for the TOKIOKA Parameter =0.03
4874 !ckay Kim et al 2011; Kang et al 2009; Lin et al 2013;  GCM findings
4875
4876               TOKIOKA = 0.03
4877               TOKIOKA = TOKIOKA * Scale_Fac
4878               REI=VMFLCL*DP(NK1)*TOKIOKA/RAD
4879 !ckay
4880               TVQU(NK1)=TU(NK1)*(1.+0.608*QU(NK1)-QLIQ(NK1)-QICE(NK1))
4881               IF(NK.EQ.K)THEN
4882                 DILBE=((TVLCL+TVQU(NK1))/(TVEN+TV0(NK1))-1.)*DZZ
4883               ELSE
4884                 DILBE=((TVQU(NK)+TVQU(NK1))/(TV0(NK)+TV0(NK1))-1.)*DZZ
4885               ENDIF
4886               IF(DILBE.GT.0.)ABE=ABE+DILBE*G
4887 !
4888 !...IF CLOUD PARCELS ARE VIRTUALLY COLDER THAN THE ENVIRONMENT, MINIMAL
4889 !...ENTRAINMENT (0.5*REI) IS IMPOSED...
4890 !
4891               IF(TVQU(NK1).LE.TV0(NK1))THEN    ! Entrain/Detrain IF BLOCK
4892                 EE2=0.5       ! Kain (2004)  Eq. 4
4893                 UD2=1.
4894                 EQFRC(NK1)=0.
4895               ELSE
4896                 LET=NK1
4897                 TTMP=TVQU(NK1)
4898 !
4899 !...DETERMINE THE CRITICAL MIXED FRACTION OF UPDRAFT AND ENVIRONMENTAL AIR...
4900 !
4901                 F1=0.95
4902                 F2=1.-F1
4903                 THTTMP=F1*THETEE(NK1)+F2*THETEU(NK1)
4904                 QTMP=F1*Q0(NK1)+F2*QU(NK1)
4905                 TMPLIQ=F2*QLIQ(NK1)
4906                 TMPICE=F2*QICE(NK1)
4907                 call tpmix2(p0(nk1),thttmp,ttmp,qtmp,tmpliq,tmpice,        &
4908                            qnewlq,qnewic,XLV1,XLV0,QSu)
4909                 TU95=TTMP*(1.+0.608*QTMP-TMPLIQ-TMPICE)
4910                 IF(TU95.GT.TV0(NK1))THEN
4911                   EE2=1.
4912                   UD2=0.
4913                   EQFRC(NK1)=1.0
4914                 ELSE
4915                   F1=0.10
4916                   F2=1.-F1
4917                   THTTMP=F1*THETEE(NK1)+F2*THETEU(NK1)
4918                   QTMP=F1*Q0(NK1)+F2*QU(NK1)
4919                   TMPLIQ=F2*QLIQ(NK1)
4920                   TMPICE=F2*QICE(NK1)
4921                   call tpmix2(p0(nk1),thttmp,ttmp,qtmp,tmpliq,tmpice,        &
4922                                qnewlq,qnewic,XLV1,XLV0,QSu)
4923                   TU10=TTMP*(1.+0.608*QTMP-TMPLIQ-TMPICE)
4924                   TVDIFF = ABS(TU10-TVQU(NK1))
4925                   IF(TVDIFF.LT.1.e-3)THEN
4926                     EE2=1.
4927                     UD2=0.
4928                     EQFRC(NK1)=1.0
4929                   ELSE
4930                     EQFRC(NK1)=(TV0(NK1)-TVQU(NK1))*F1/(TU10-TVQU(NK1))
4931                     EQFRC(NK1)=AMAX1(0.0,EQFRC(NK1))
4932                     EQFRC(NK1)=AMIN1(1.0,EQFRC(NK1))
4933                     IF(EQFRC(NK1).EQ.1)THEN
4934                       EE2=1.
4935                       UD2=0.
4936                     ELSEIF(EQFRC(NK1).EQ.0.)THEN
4937                       EE2=0.
4938                       UD2=1.
4939                     ELSE
4940 !
4941 !...SUBROUTINE PROF5 INTEGRATES OVER THE GAUSSIAN DIST TO DETERMINE THE
4942 !   FRACTIONAL ENTRAINMENT AND DETRAINMENT RATES...
4943 !
4944                       CALL PROF5(EQFRC(NK1),EE2,UD2)
4945                     ENDIF
4946                   ENDIF
4947                 ENDIF
4948               ENDIF                            ! End of Entrain/Detrain IF BLOCK
4949 !
4950 !
4951 !...NET ENTRAINMENT AND DETRAINMENT RATES ARE GIVEN BY THE AVERAGE FRACTIONAL
4952 !   VALUES IN THE LAYER...
4953 !
4954               EE2 = AMAX1(EE2,0.5)
4955               UD2 = 1.5*UD2
4956               UER(NK1)=0.5*REI*(EE1+EE2)
4957               UDR(NK1)=0.5*REI*(UD1+UD2)
4958 !
4959 !...IF THE CALCULATED UPDRAFT DETRAINMENT RATE IS GREATER THAN THE TOTAL
4960 !   UPDRAFT MASS FLUX, ALL CLOUD MASS DETRAINS, EXIT UPDRAFT CALCULATIONS...
4961 !
4962               IF(UMF(NK)-UDR(NK1).LT.10.)THEN
4963 !
4964 !...IF THE CALCULATED DETRAINED MASS FLUX IS GREATER THAN THE TOTAL UPD MASS
4965 !   FLUX, IMPOSE TOTAL DETRAINMENT OF UPDRAFT MASS AT THE PREVIOUS MODEL LVL..
4966 !   First, correct ABE calculation if needed...
4967 !
4968                 IF(DILBE.GT.0.)THEN
4969                   ABE=ABE-DILBE*G
4970                 ENDIF
4971                 LET=NK
4972 !               WRITE(98,1015)P0(NK1)/100.
4973                 EXIT
4974               ELSE
4975                 EE1=EE2
4976                 UD1=UD2
4977                 UPOLD=UMF(NK)-UDR(NK1)
4978                 UPNEW=UPOLD+UER(NK1)
4979                 UMF(NK1)=UPNEW
4980                 DILFRC(NK1) = UPNEW/UPOLD
4981 !
4982 !...DETLQ AND DETIC ARE THE RATES OF DETRAINMENT OF LIQUID AND
4983 !...ICE IN THE DETRAINING UPDRAFT MASS...
4984 !
4985                 DETLQ(NK1)=QLIQ(NK1)*UDR(NK1)
4986                 DETIC(NK1)=QICE(NK1)*UDR(NK1)
4987                 QDT(NK1)=QU(NK1)
4988                 QU(NK1)=(UPOLD*QU(NK1)+UER(NK1)*Q0(NK1))/UPNEW
4989                 THETEU(NK1)=(THETEU(NK1)*UPOLD+THETEE(NK1)*UER(NK1))/UPNEW
4990                 QLIQ(NK1)=QLIQ(NK1)*UPOLD/UPNEW
4991                 QICE(NK1)=QICE(NK1)*UPOLD/UPNEW
4992 !
4993 !...PPTLIQ IS THE RATE OF GENERATION (FALLOUT) OF
4994 !...LIQUID PRECIP AT A GIVEN MODEL LVL, PPTICE THE SAME FOR ICE,
4995 !...TRPPT IS THE TOTAL RATE OF PRODUCTION OF PRECIP UP TO THE
4996 !...CURRENT MODEL LEVEL...
4997 !
4998                 PPTLIQ(NK1)=QLQOUT(NK1)*UMF(NK)
4999                 PPTICE(NK1)=QICOUT(NK1)*UMF(NK)
5000 !
5001                 TRPPT=TRPPT+PPTLIQ(NK1)+PPTICE(NK1)
5002                 IF(NK1.LE.KPBL)UER(NK1)=UER(NK1)+VMFLCL*DP(NK1)/DPTHMX
5003               ENDIF
5004
5005 !dkay
5006               IF (aercu_opt.gt.0) THEN
5007                   eps1u = 0.622
5008                   alatent = 2.54E6
5009                   KQ = NK
5010                   JK = KTE-KQ+1
5011                    muu(1,JK) = UMF(KQ)/VMFLCL     ! normalized updraft mass flux
5012                    duu(1,JK) = UDR(KQ)/DZQ(KQ)/VMFLCL  ! fractional detrainment rate in units of per meter
5013                    EUU(1,JK) = UER(KQ)/DZQ(KQ)/VMFLCL  ! normalized entrainment rate in unts of per meter
5014                    cmel(1,JK) = muu(1,JK)*AQNEWLQ(KQ)/DZQ(KQ)
5015                    cmei(1,JK) = muu(1,JK)*AQNEWIC(KQ)/DZQ(KQ)
5016                   gamhat(1,JK) = QSATu(KQ)*(1.+QSATu(KQ)/eps1u)   &
5017                  *eps1u*alatent/(R*oldTU(KQ)**2)*alatent/CP
5018                    wu_mskf_act(JK) = WU(KQ)  ! kf updraft velocity incloud
5019                    qc_mskf_act(JK) = AQNEWLQ(KQ)
5020                    qi_mskf_act(JK)=AQNEWIC(KQ)
5021               END IF
5022 !end dkay
5023
5024
5025 !
5026             END DO updraft
5027
5028 !dkay
5029           IF (aercu_opt.gt.0) THEN
5030             Zfu(1,KTE+1) = 0.0
5031
5032                 CPin   = CP
5033
5034             EPSI0(1) = 2.0E-4
5035             DO KQ=KTS,KTE
5036               JK = KTE-KQ+1
5037                    zfu(1,JK) = zf_wrf(KQ)
5038                    su(1,JK) = oldTU(KQ)*(1.0+0.622*QSATu(KQ)) + (G*zf_wrf(KQ))/CP !TWG updraft temperature calulation
5039                    quu(1,JK) = oldQU(KQ)/(1.+oldQU(KQ)) ! specific humidity of updraft
5040                    pru(1,JK) = P0(KQ)/100.0    ! in millibars
5041                    TEE(1,JK) = T0(KQ)    ! ccc
5042                    QEE(1,JK) = Q0(KQ)/(1.+Q0(KQ))           ! specific humidity of environment
5043
5044                    qee(1,JK) = oldQU(KQ)/(1.+oldQU(KQ)) ! specific humidity of updraft
5045                    QSATZM(1,JK) = QSATu(KQ)
5046 !
5047 !psh: Now, using aerosol concs from CESM
5048 !
5049                     denSplume = P0(KQ)/(R*oldTU(KQ))
5050                     psh_fac = 1.0E-09/denSplume        ! convert ug/m3 to kg/kg
5051
5052                     aer_mmr(1,JK, 1) = aercu_fct*aerocu(I,KQ,J, 6)*psh_fac
5053                     aer_mmr(1,JK, 2) = aercu_fct*aerocu(I,KQ,J, 5)*psh_fac
5054                     aer_mmr(1,JK, 3) = aercu_fct*1.44*aerocu(I,KQ,J, 1)*psh_fac
5055                     aer_mmr(1,JK, 4) = aercu_fct*1.44*aerocu(I,KQ,J, 2)*psh_fac
5056                     aer_mmr(1,JK, 5) = aercu_fct*1.44*aerocu(I,KQ,J, 3)*psh_fac
5057                     aer_mmr(1,JK, 6) = aercu_fct*1.44*aerocu(I,KQ,J, 4)*psh_fac
5058                     aer_mmr(1,JK, 7) = aercu_fct*1.54*aerocu(I,KQ,J, 9)*psh_fac
5059                     aer_mmr(1,JK, 8) = aercu_fct*1.37*aerocu(I,KQ,J, 7)*psh_fac
5060                     aer_mmr(1,JK, 9) = aercu_fct*1.25*aerocu(I,KQ,J,10)*psh_fac
5061                     aer_mmr(1,JK,10) = aercu_fct*1.37*aerocu(I,KQ,J, 8)*psh_fac
5062
5063 !psh
5064                   gamhat(1,JK) = QSATu(KQ)*(1.+QSATu(KQ)/eps1u)   &
5065                  *eps1u*alatent/(R*oldTU(KQ)**2)*alatent/CP
5066
5067               END DO
5068                   JTT(1) = KX-NK+1
5069                   JBB(1) = KX-K+1  ! updraft base level   =====>>> flipped for CAM5 indexing
5070                   if(jtt(1).gt.jbb(1))  then
5071                    JTT(1) = JBB(1)
5072                   end if
5073                   JLCL(1) = JBB(1) - 1
5074                   msg1 = 0
5075                   il2g = 1
5076                   grav  = G
5077                   Rdry = R
5078                   DTzmp = DT
5079 !                 print *,'jtt,jbb=', JTT(1), JBB(1)
5080
5081 !dkay: call the new DCCMP scheme here
5082               NLEVZM = KTE-KTS+1      !  this is equal to pver in zm_mp
5083               NLEVZMP1 = NLEVZM + 1   !  pverp
5084
5085                 if(jtt(1).eq.1) then
5086                    print *,' cloud bottom is on ground!'
5087                    print*,'I ',I,' J ',J
5088                    CALL wrf_error_fatal ('MSKF Cloud Bottom IS ON THE GROUND, diags' )
5089                  end if
5090                 if(jbb(1).eq.KTE) then
5091                    print *,' cloud top went through the roof!'
5092                    print *,'JTT, jbb, jlcl=',JTT(1),JBB(1),JLCL(1)
5093                    CALL wrf_error_fatal ( 'MSKF CLOUD TOP WENT OVER MODEL TOP, diags' )
5094                  end if
5095             if(DCCMP) then
5096
5097 !           do kq=KTE,1,-1
5098 !             print *,'wrf dz=',dzq(kq),(KTE-KQ+1)
5099 !           end do
5100
5101           call mskf_mphy(su,quu,muu,duu,cmel,cmei,zfu, pru,tee,qee,epsi0, &
5102                jbb,jtt,jlcl, msg1,il2g, grav, cpin, rdry,zmqliq,zmqice,zmqrain,zmqsnow,&
5103                rprd,wump, euu, ncmp,nimp,nrmp,nsmp,zmccn,sprd, frz, aer_mmr, dtzmp, &
5104                NLEVZM,NLEVZMP1,gamhat,qsatzm,wu_mskf_act,qc_mskf_act,qi_mskf_act,effc,effi,effs)
5105               end if
5106
5107                Itest = 0
5108                 if(Itest.eq.1) then
5109
5110                write(121,*) 'k,nk, kq,jk,su,quuE3,muu,duu,cmel,zfu,pru,tee,&
5111               &qeeE3,zmqliqE4,zmqiceE4,rprd,wump,euu,ncmp,nimp,sprd,frz'
5112                do kq=K,NK
5113                JK = KTE-KQ+1
5114                write (121,2021) k,nk,kq,jk,su(1,jk),quu(1,jk)*1000,muu(1,jk),duu(1,jk),cmel(1,jk)
5115                write (121,2022) zfu(1,jk),pru(1,jk),tee(1,jk),qee(1,jk)*1000,zmqliq(1,jk)*1.e3,zmqice(1,jk)*1.e3
5116                write (121,2022) rprd(1,jk),wump(1,jk),euu(1,jk),ncmp(1,jk),nimp(1,jk),sprd(1,jk)
5117                write (121,2023) frz(1,jk)
5118
5119 2021          format(4I3,6(1x,E13.6))
5120 2022          format(6(1x,e13.6))
5121 2023          format(2(1x,e13.6))
5122                end do
5123                 end if ! itest
5124
5125
5126                if(DCCMP) then
5127               do kq=KTS,KTE
5128                QLIQ(KQ) = 0.0
5129                QICE(KQ) = 0.0
5130                QRAIN(KQ) = 0.0
5131                QSNOW(KQ) = 0.0
5132                NLIQ(KQ) = 0.0
5133                NICE(KQ) = 0.0
5134                NRAIN(KQ) = 0.0
5135                NSNOW(KQ) = 0.0
5136                CCN(KQ) = 0.0
5137                EFFCH(KQ) = 2.51
5138                EFFIH(KQ) = 4.99
5139                EFFSH(KQ) = 9.99
5140                PPTLIQ(KQ)=0.0  ! nov23
5141                PPTICE(KQ)=0.0  ! nov23
5142                QLQOUT(KQ)=0.0  ! nov23
5143                QICOUT(KQ)=0.0  ! nov23
5144                DETLQ(KQ)=0.0  ! dec26
5145                DETIC(KQ)=0.0  ! dec26
5146               end do
5147               TRPPT = 0.0
5148               DO KQ=KTS, KTE
5149
5150                JK = KX-KQ+1
5151 !               print *,'kf qliq=', QLIQ(KQ)
5152                  QLIQ(KQ) = max(0._r8,zmqliq(1,JK))
5153                  QICE(KQ) = max(0._r8,zmqice(1,JK))
5154 !TWG 06/14/16
5155                  QRAIN(KQ) = max(0._r8,zmqrain(1,JK))
5156                  QSNOW(KQ) = max(0._r8,zmqsnow(1,JK))
5157                  NLIQ(KQ) = max(0._r8,ncmp(1,JK))
5158                  NICE(KQ) = max(0._r8,nimp(1,JK))
5159                  NRAIN(KQ) = max(0._r8,nrmp(1,JK))
5160                  NSNOW(KQ) = max(0._r8,nsmp(1,JK))
5161                  CCN(KQ) = max(0._r8,zmccn(1,JK))
5162                  EFFCH(KQ) = max(2.49_r8, min(effc(1,JK), 50._r8))
5163                  EFFIH(KQ) = max(4.99_r8, min(effi(1,JK), 125._r8))
5164                  EFFSH(KQ) = max(9.99_r8, min(effs(1,JK), 999._r8))
5165 ! END TWG
5166                   DETLQ(KQ)= QLIQ(KQ)*UDR(KQ)
5167                   DETIC(KQ)= QICE(KQ)*UDR(KQ)
5168 !               print *,'zm qliq=', QLIQ(KQ)
5169                    densPlume = PPTLIQ(KQ)
5170 !nov23
5171                   if(rprd(1,JK).lt.0.0) rprd(1,JK) = 0.0
5172                   if(sprd(1,JK).lt.0.0) sprd(1,JK) = 0.0
5173
5174                    QLQOUT(KQ)=rprd(1,JK)*dzq(KQ)
5175                   QICOUT(KQ)=sprd(1,JK)*dzq(KQ)
5176                   PPTLIQ(KQ)=QLQOUT(KQ)*VMFLCL   ! check this out
5177                   PPTICE(KQ)=QICOUT(KQ)*VMFLCL   !   ditto
5178
5179                  TRPPT=TRPPT+PPTLIQ(KQ)+PPTICE(KQ)
5180 !                  if(densPlume.gt.0.0) then
5181 !               print *,'zm pptliq=', &
5182 !        PPTLIQ(KQ),'kf pptliq=',oldPPTLIQ(kq),'KQ=',KQ
5183 !               end if
5184 !                 print *,'zmQliqout=',kq,densPlume,VMFLCL,pptliq(kq)
5185 !                if((i.ge.60.and.i.le.65).and.(j.ge.60.and.j.le.65)) then
5186 !                     print *, 'KF & MP qliq=', Aqnewlq(nk),QLIQ(NK)
5187 !                     print *, 'mu & du=', muu(1,JK), duu(1,JK)
5188 !                      print *,'i,j,k=',I,J,KQ
5189 !                   end if
5190
5191               END DO
5192
5193               end if  ! dccmp
5194 !dkay
5195
5196 2999         CONTINUE
5197      END IF
5198
5199
5200 !
5201 !...CHECK CLOUD DEPTH...IF CLOUD IS TALL ENOUGH, ESTIMATE THE EQUILIBRIUM
5202 !   TEMPERATURE LEVEL (LET) AND ADJUST MASS FLUX PROFILE AT CLOUD TOP SO
5203 !   THAT MASS FLUX DECREASES TO ZERO AS A LINEAR FUNCTION OF PRESSURE BETWEEN
5204 !   THE LET AND CLOUD TOP...
5205 !
5206 !...LTOP IS THE MODEL LEVEL JUST BELOW THE LEVEL AT WHICH VERTICAL VELOCITY
5207 !   FIRST BECOMES NEGATIVE...
5208 !
5209             LTOP=NK
5210             CLDHGT(LC)=Z0(LTOP)-ZLCL
5211 !
5212 !...Instead of using the same minimum cloud height (for deep convection)
5213 !...everywhere, try specifying minimum cloud depth as a function of TLCL...
5214 !
5215 !   Kain (2004)  Eq. 7
5216 !
5217             IF(TLCL.GT.293.)THEN
5218               CHMIN = 4.E3
5219             ELSEIF(TLCL.LE.293. .and. TLCL.GE.273)THEN
5220               CHMIN = 2.E3 + 100.*(TLCL-273.)
5221             ELSEIF(TLCL.LT.273.)THEN
5222               CHMIN = 2.E3
5223             ENDIF
5224 !ckay
5225             DO NK=K,LTOP
5226               qc_KF(I,NK,J)=QLIQ(NK)
5227               qi_KF(I,NK,J)=QICE(NK)
5228 ! TWG 06/14/16
5229              IF (aercu_opt .GT. 0) THEN
5230               qr_KF(I,NK,J)=QRAIN(NK)
5231               qs_KF(I,NK,J)=QSNOW(NK)
5232               nc_KF(I,NK,J)=NLIQ(NK)
5233               ni_KF(I,NK,J)=NICE(NK)
5234               nr_KF(I,NK,J)=NRAIN(NK)
5235               ns_KF(I,NK,J)=NSNOW(NK)
5236               ccn_KF(I,NK,J)=CCN(NK)
5237               EFCS(I,NK,J)=MAX(2.49, MIN(EFFCH(NK), 50.))
5238               EFIS(I,NK,J)=MAX(4.99, MIN(EFFIH(NK), 120.))
5239               EFSS(I,NK,J)=MAX(9.99, MIN(EFFSH(NK), 999.))
5240              END IF
5241 ! END TWG
5242             END DO
5243 !ckay: if mean env RH with respect to water/ice is over 99% then dont allow KF
5244 !ckay: added saturation w.r.to ice june 10, 2015
5245 ! to avoid double counting
5246           envRHavg = 0.0
5247           DO NK=K-1,LTOP+1
5248            if(T0(NK).LE.273.16) then
5249              envEsat = 6.112*exp(21.87*(T0(NK)-273.16)/(T0(NK)-7.66))
5250            else
5251              envEsat = 6.112*exp(17.67*(T0(NK)-273.16)/(243.5+T0(NK)-273.16))
5252            end if
5253            envEsat = envEsat * 100.0  ! to hPa
5254            envQsat = 0.622*envEsat/(P0(NK)-envEsat)
5255            envRH  = Q0(NK)/envQsat
5256             if(NK.GT.K.and.envRH.LT.0.99)  then
5257               envRHavg = 0.0
5258               goto 2020
5259             end if
5260             envRHavg = envRHavg + envRH
5261           END DO
5262 !ckay ; get vertically averaged envRHavg
5263          envRHavg = envRHavg / float(LTOP-K+1+2)
5264 2020     continue
5265
5266 !
5267 !...If cloud top height is less than the specified minimum for deep
5268 !...convection, save value to consider this level as source for
5269 !...shallow convection, go back up to check next level...
5270 !
5271 !...Try specifying minimum cloud depth as a function of TLCL...
5272 !
5273 !
5274 !...DO NOT ALLOW ANY CLOUD FROM THIS LAYER IF:
5275 !
5276 !...            1.) if there is no CAPE, or
5277 !...            2.) cloud top is at model level just above LCL, or
5278 !...            3.) cloud top is within updraft source layer, or
5279 !...            4.) cloud-top detrainment layer begins within
5280 !...                updraft source layer.
5281 !...ckay        5.) if the environment is supersaturated i.e., RH > 100%
5282 !...ckay            For now, with respect to water
5283 !
5284
5285             IF(LTOP.LE.KLCL .or. LTOP.LE.KPBL .or. LET+1.LE.KPBL &
5286               .or. envRHavg.ge.1.01)THEN  ! No Convection Allowed
5287 !ckay
5288
5289               CLDHGT(LC)=0.
5290               DO NK=K,LTOP
5291                 UMF(NK)=0.
5292                 UDR(NK)=0.
5293                 UER(NK)=0.
5294                 DETLQ(NK)=0.
5295                 DETIC(NK)=0.
5296                 PPTLIQ(NK)=0.
5297                 PPTICE(NK)=0.
5298 !ckay
5299                 cldfra_dp_KF(I,NK,J)=0.
5300                 cldfra_sh_KF(I,NK,J)=0.
5301                 qc_KF(I,NK,J)=0.
5302                 qi_KF(I,NK,J)=0.
5303 !TWG 06/14/16
5304               IF (aercu_opt .GT. 0) THEN
5305                 qr_KF(I,NK,J)=0.
5306                 qs_KF(I,NK,J)=0.
5307                 nc_KF(I,NK,J)=0.
5308                 ni_KF(I,NK,J)=0.
5309                 nr_KF(I,NK,J)=0.
5310                 ns_KF(I,NK,J)=0.
5311                 ccn_KF(I,NK,J)=0.
5312                 EFCS(I,NK,J)=2.51
5313                 EFIS(I,NK,J)=5.01
5314                 EFSS(I,NK,J)=10.01
5315               END IF
5316 ! END TWG
5317               ENDDO
5318 !
5319             ELSEIF(CLDHGT(LC).GT.CHMIN .and. ABE.GT.1)THEN      ! Deep Convection allowed
5320               ISHALL=0
5321 !ckay
5322               DO NK=K,LTOP
5323                 cldfra_sh_KF(I,NK,J)=0.
5324               ENDDO
5325               EXIT usl
5326             ELSE
5327 !
5328 !...TO DISALLOW SHALLOW CONVECTION, COMMENT OUT NEXT LINE !!!!!!!!
5329               ISHALL = 1
5330 !ckay
5331               DO NK=K,LTOP
5332                 cldfra_dp_KF(I,NK,J)=0.
5333               ENDDO
5334               IF(NU.EQ.NUCHM)THEN
5335                 EXIT usl               ! Shallow Convection from this layer
5336               ELSE
5337 ! Remember this layer (by virtue of non-zero CLDHGT) as potential shallow-cloud layer
5338                 DO NK=K,LTOP
5339                   UMF(NK)=0.
5340                   UDR(NK)=0.
5341                   UER(NK)=0.
5342                   DETLQ(NK)=0.
5343                   DETIC(NK)=0.
5344                   PPTLIQ(NK)=0.
5345                   PPTICE(NK)=0.
5346 !ckay
5347                   cldfra_dp_KF(I,NK,J)=0.
5348                   cldfra_sh_KF(I,NK,J)=0.
5349                   qc_KF(I,NK,J)=0.
5350                   qi_KF(I,NK,J)=0.
5351 !TWG 06/14/16
5352                 IF (aercu_opt .GT. 0) THEN
5353                   qr_KF(I,NK,J)=0.
5354                   qs_KF(I,NK,J)=0.
5355                   nc_KF(I,NK,J)=0.
5356                   ni_KF(I,NK,J)=0.
5357                   nr_KF(I,NK,J)=0.
5358                   ns_KF(I,NK,J)=0.
5359                   ccn_KF(I,NK,J)=0.
5360                   EFCS(I,NK,J)=2.51
5361                   EFIS(I,NK,J)=5.01
5362                   EFSS(I,NK,J)=10.01
5363                 END IF
5364 ! END TWG
5365                 ENDDO
5366               ENDIF
5367             ENDIF
5368           ENDIF  ! for trigger
5369         END DO usl
5370     IF(ISHALL.EQ.1)THEN
5371       KSTART=MAX0(KPBL,KLCL)
5372       LET=KSTART
5373     endif
5374 !
5375 !...IF THE LET AND LTOP ARE THE SAME, DETRAIN ALL OF THE UPDRAFT MASS FL
5376 !   THIS LEVEL...
5377 !
5378     IF(LET.EQ.LTOP)THEN
5379       UDR(LTOP)=UMF(LTOP)+UDR(LTOP)-UER(LTOP)
5380       DETLQ(LTOP)=QLIQ(LTOP)*UDR(LTOP)*UPNEW/UPOLD
5381       DETIC(LTOP)=QICE(LTOP)*UDR(LTOP)*UPNEW/UPOLD
5382       UER(LTOP)=0.
5383       UMF(LTOP)=0.
5384     ELSE
5385 !
5386 !   BEGIN TOTAL DETRAINMENT AT THE LEVEL ABOVE THE LET...
5387 !
5388       DPTT=0.
5389       DO NJ=LET+1,LTOP
5390         DPTT=DPTT+DP(NJ)
5391       ENDDO
5392       DUMFDP=UMF(LET)/DPTT
5393 !
5394 !...ADJUST MASS FLUX PROFILES, DETRAINMENT RATES, AND PRECIPITATION FALL
5395 !   RATES TO REFLECT THE LINEAR DECREASE IN MASS FLX BETWEEN THE LET AND
5396 !
5397       DO NK=LET+1,LTOP
5398 !
5399 !...entrainment is allowed at every level except for LTOP, so disallow
5400 !...entrainment at LTOP and adjust entrainment rates between LET and LTOP
5401 !...so the the dilution factor due to entrainment is not changed but
5402 !...the actual entrainment rate will change due due forced total
5403 !...detrainment in this layer...
5404 !
5405         IF(NK.EQ.LTOP)THEN
5406           UDR(NK) = UMF(NK-1)
5407           UER(NK) = 0.
5408           DETLQ(NK) = UDR(NK)*QLIQ(NK)*DILFRC(NK)
5409           DETIC(NK) = UDR(NK)*QICE(NK)*DILFRC(NK)
5410         ELSE
5411           UMF(NK)=UMF(NK-1)-DP(NK)*DUMFDP
5412           UER(NK)=UMF(NK)*(1.-1./DILFRC(NK))
5413           UDR(NK)=UMF(NK-1)-UMF(NK)+UER(NK)
5414           DETLQ(NK)=UDR(NK)*QLIQ(NK)*DILFRC(NK)
5415           DETIC(NK)=UDR(NK)*QICE(NK)*DILFRC(NK)
5416         ENDIF
5417         IF(NK.GE.LET+2)THEN
5418           TRPPT=TRPPT-PPTLIQ(NK)-PPTICE(NK)
5419           PPTLIQ(NK)=UMF(NK-1)*QLQOUT(NK)
5420           PPTICE(NK)=UMF(NK-1)*QICOUT(NK)
5421           TRPPT=TRPPT+PPTLIQ(NK)+PPTICE(NK)
5422         ENDIF
5423       ENDDO
5424     ENDIF
5425 !
5426 ! Initialize some arrays below cloud base and above cloud top...
5427 !
5428     DO NK=1,LTOP
5429       IF(T0(NK).GT.T00)ML=NK
5430     ENDDO
5431     DO NK=1,K
5432       IF(NK.GE.LC)THEN
5433         IF(NK.EQ.LC)THEN
5434           UMF(NK)=VMFLCL*DP(NK)/DPTHMX
5435           UER(NK)=VMFLCL*DP(NK)/DPTHMX
5436         ELSEIF(NK.LE.KPBL)THEN
5437           UER(NK)=VMFLCL*DP(NK)/DPTHMX
5438           UMF(NK)=UMF(NK-1)+UER(NK)
5439         ELSE
5440           UMF(NK)=VMFLCL
5441           UER(NK)=0.
5442         ENDIF
5443         TU(NK)=TMIX+(Z0(NK)-ZMIX)*GDRY
5444         QU(NK)=QMIX
5445         WU(NK)=WLCL
5446       ELSE
5447         TU(NK)=0.
5448         QU(NK)=0.
5449         UMF(NK)=0.
5450         WU(NK)=0.
5451         UER(NK)=0.
5452 !ckay
5453         cldfra_dp_KF(I,NK,J)=0.
5454         cldfra_sh_KF(I,NK,J)=0.
5455         qc_KF(I,NK,J)=0.
5456         qi_KF(I,NK,J)=0.
5457 !TWG 06/14/16
5458        IF (aercu_opt .GT. 0) THEN
5459         qr_KF(I,NK,J)=0.
5460         qs_KF(I,NK,J)=0.
5461         nc_KF(I,NK,J)=0.
5462         ni_KF(I,NK,J)=0.
5463         nr_KF(I,NK,J)=0.
5464         ns_KF(I,NK,J)=0.
5465         ccn_KF(I,NK,J)=0.
5466         EFCS(I,NK,J)=2.51
5467         EFIS(I,NK,J)=5.01
5468         EFSS(I,NK,J)=10.01
5469        END IF
5470 ! END TWG
5471       ENDIF
5472       UDR(NK)=0.
5473       QDT(NK)=0.
5474       QLIQ(NK)=0.
5475       QICE(NK)=0.
5476       QLQOUT(NK)=0.
5477       QICOUT(NK)=0.
5478       PPTLIQ(NK)=0.
5479       PPTICE(NK)=0.
5480       DETLQ(NK)=0.
5481       DETIC(NK)=0.
5482       RATIO2(NK)=0.
5483       CALL ENVIRTHT(P0(NK),T0(NK),Q0(NK),THETEE(NK),ALIQ,BLIQ,CLIQ,DLIQ)
5484       EQFRC(NK)=1.0
5485     ENDDO
5486 !
5487       LTOP1=LTOP+1
5488       LTOPM1=LTOP-1
5489 !
5490 !...DEFINE VARIABLES ABOVE CLOUD TOP...
5491 !
5492       DO NK=LTOP1,KX
5493         UMF(NK)=0.
5494         UDR(NK)=0.
5495         UER(NK)=0.
5496         QDT(NK)=0.
5497         QLIQ(NK)=0.
5498         QICE(NK)=0.
5499         QLQOUT(NK)=0.
5500         QICOUT(NK)=0.
5501         DETLQ(NK)=0.
5502         DETIC(NK)=0.
5503         PPTLIQ(NK)=0.
5504         PPTICE(NK)=0.
5505         IF(NK.GT.LTOP1)THEN
5506           TU(NK)=0.
5507           QU(NK)=0.
5508           WU(NK)=0.
5509 !ckay
5510           cldfra_dp_KF(I,NK,J)=0.
5511           cldfra_sh_KF(I,NK,J)=0.
5512           qc_KF(I,NK,J)=0.
5513           qi_KF(I,NK,J)=0.
5514 !TWG 06/14/16
5515          IF (aercu_opt .GT. 0) THEN
5516           qr_KF(I,NK,J)=0.
5517           qs_KF(I,NK,J)=0.
5518           nc_KF(I,NK,J)=0.
5519           ni_KF(I,NK,J)=0.
5520           nr_KF(I,NK,J)=0.
5521           ns_KF(I,NK,J)=0.
5522           ccn_KF(I,NK,J)=0.
5523           EFSS(I,NK,J)=10.01
5524           EFCS(I,NK,J)=2.51
5525           EFIS(I,NK,J)=5.01
5526          END IF
5527 ! END TWG
5528         ENDIF
5529         THTA0(NK)=0.
5530         THTAU(NK)=0.
5531         EMS(NK)=0.
5532         EMSD(NK)=0.
5533         TG(NK)=T0(NK)
5534         QG(NK)=Q0(NK)
5535         QLG(NK)=0.
5536         QIG(NK)=0.
5537         QRG(NK)=0.
5538         QSG(NK)=0.
5539         OMG(NK)=0.
5540       ENDDO
5541         OMG(KX+1)=0.
5542         DO NK=1,LTOP
5543           EMS(NK)=DP(NK)*DXSQ/G
5544           EMSD(NK)=1./EMS(NK)
5545 !
5546 !...INITIALIZE SOME VARIABLES TO BE USED LATER IN THE VERT ADVECTION SCHEME
5547 !
5548           EXN(NK)=(P00/P0(NK))**(0.2854*(1.-0.28*QDT(NK)))
5549           THTAU(NK)=TU(NK)*EXN(NK)
5550           EXN(NK)=(P00/P0(NK))**(0.2854*(1.-0.28*Q0(NK)))
5551           THTA0(NK)=T0(NK)*EXN(NK)
5552           DDILFRC(NK) = 1./DILFRC(NK)
5553           OMG(NK)=0.
5554         ENDDO
5555 !     IF (XTIME.LT.10.)THEN
5556 !      WRITE(98,1025)KLCL,ZLCL,DTLCL,LTOP,P0(LTOP),IFLAG,
5557 !    * TMIX-T00,PMIX,QMIX,ABE
5558 !      WRITE(98,1030)P0(LET)/100.,P0(LTOP)/100.,VMFLCL,PLCL/100.,
5559 !    * WLCL,CLDHGT
5560 !     ENDIF
5561 !
5562 !...COMPUTE CONVECTIVE TIME SCALE(TIMEC). THE MEAN WIND AT THE LCL
5563 !...AND MIDTROPOSPHERE IS USED.
5564 !
5565         WSPD(KLCL)=SQRT(U0(KLCL)*U0(KLCL)+V0(KLCL)*V0(KLCL))
5566         WSPD(L5)=SQRT(U0(L5)*U0(L5)+V0(L5)*V0(L5))
5567         WSPD(LTOP)=SQRT(U0(LTOP)*U0(LTOP)+V0(LTOP)*V0(LTOP))
5568         VCONV=.5*(WSPD(KLCL)+WSPD(L5))
5569 !...for ETA model, DX is a function of location...
5570         TIMEC=DX/VCONV
5571         TADVEC=TIMEC
5572 !
5573 !ckay
5574 !new dynTau based on subcloud layer scales : note Z0(KPBL)=altitude of source layer
5575
5576          TIMEC = Amax1(CHMIN,CLDHGT(LC))
5577          TIMEC = TIMEC*Scale_Fac
5578
5579 !ckay SCLvel = SubCloudLayerVELOCITY = Wsb
5580 !ckay estimate WSTAR to allow most of the PBL schemes here...
5581          densPlume = P0(1)/R/T0(1)
5582          WST = HFX(I,J)/densPlume/CP  ! hfx in kinematic units  CKAY
5583          WST = amax1(0.,WST)  ! +ve hfx only
5584          WST = G*PBLH(I,J)*WST
5585          thetav = (1.E5/P0(1))**(R/CP)
5586          thetav = T0(1) * thetav
5587          eps1u = 0.622
5588          thetav = thetav*(1.+Q0(1)*eps1u)
5589          WST = WST/thetav
5590          WST = WST**0.3333
5591
5592          SCLvel = WST**3
5593          ZLCL_KAY = amax1(ZLCL,Z0(KPBL))
5594          SCLvel = SCLvel/PBLH(I,J)
5595          SCLvel = SCLvel*ZLCL_kay
5596          SCLvel = SCLvel**0.333   ! Wsb=SubCloudLayerVelocity for ConvectivePBL
5597          if(ZOL(i,J).le.0.0) then
5598            FRC2=3.8*Ust(I,J)*Ust(I,J)
5599            FRC2 = FRC2 + 0.22*SCLvel*SCLvel
5600            zz_kay = -1.0*ZOL(I,j)
5601            ZLCL_KAY = zz_kay**(2./3.)
5602            ZLCL_KAY = ZLCL_KAY * (1.9*Ust(I,J)*Ust(I,J))
5603            FRC2 = FRC2 + ZLCL_KAY
5604          else
5605            FRC2=3.8*Ust(I,J)*Ust(I,J)
5606          end if
5607
5608           FRC2 = SQRT(FRC2)
5609           SCLvel =  FRC2  ! Wsb=new subcloud layer velocity scale for all conditions
5610          IF(SCLvel.lt.0.1) SCLvel = 0.1
5611          if(ABE.le.0.0) ABE = 1.0
5612          TIMEC = TIMEC/((0.03*SCLvel*ABE)**0.3333)
5613
5614 !ckay: this dynTau is good for the Deep as well as Shallow Cu clouds
5615         TIMEC = AMAX1(TADVEC, TIMEC)
5616
5617          NIC=NINT(TIMEC/DT)
5618          TIMEC=FLOAT(NIC)*DT
5619          TIMEC=MIN(TIMEC,86400.)  !JRJ Ramboll: cap convective time scale at 24 hrs
5620 !
5621 !...COMPUTE WIND SHEAR AND PRECIPITATION EFFICIENCY.
5622 !
5623         IF(WSPD(LTOP).GT.WSPD(KLCL))THEN
5624           SHSIGN=1.
5625         ELSE
5626           SHSIGN=-1.
5627         ENDIF
5628         VWS=(U0(LTOP)-U0(KLCL))*(U0(LTOP)-U0(KLCL))+(V0(LTOP)-V0(KLCL))*   &
5629             (V0(LTOP)-V0(KLCL))
5630         VWS=1.E3*SHSIGN*SQRT(VWS)/(Z0(LTOP)-Z0(LCL))
5631         PEF=1.591+VWS*(-.639+VWS*(9.53E-2-VWS*4.96E-3))
5632         PEF=AMAX1(PEF,.2)
5633         PEF=AMIN1(PEF,.9)
5634 !
5635 !...PRECIPITATION EFFICIENCY IS A FUNCTION OF THE HEIGHT OF CLOUD BASE.
5636 !
5637         CBH=(ZLCL-Z0(1))*3.281E-3
5638         IF(CBH.LT.3.)THEN
5639           RCBH=.02
5640         ELSE
5641           RCBH=.96729352+CBH*(-.70034167+CBH*(.162179896+CBH*(-            &
5642                1.2569798E-2+CBH*(4.2772E-4-CBH*5.44E-6))))
5643         ENDIF
5644         IF(CBH.GT.25)RCBH=2.4
5645         PEFCBH=1./(1.+RCBH)
5646         PEFCBH=AMIN1(PEFCBH,.9)
5647 !
5648 !... MEAN PEF. IS USED TO COMPUTE RAINFALL.
5649 !
5650         PEFF=.5*(PEF+PEFCBH)
5651         PEFF2 = PEFF                                ! JSK MODS
5652        IF(IPRNT)THEN
5653 !         WRITE(98,1035)PEF,PEFCBH,LC,LET,WKL,VWS
5654          WRITE(message,1035)PEF,PEFCBH,LC,LET,WKL,VWS
5655          CALL wrf_message( message )
5656 !       flush(98)
5657        endif
5658 !        WRITE(98,1035)PEF,PEFCBH,LC,LET,WKL,VWS
5659 !*****************************************************************
5660 !                                                                *
5661 !                  COMPUTE DOWNDRAFT PROPERTIES                  *
5662 !                                                                *
5663 !*****************************************************************
5664 !
5665 !
5666        TDER=0.
5667  devap:IF(ISHALL.EQ.1)THEN
5668          LFS = 1
5669        ELSE
5670 !
5671 !...start downdraft about 150 mb above cloud base...
5672 !
5673 !        KSTART=MAX0(KPBL,KLCL)
5674 !        KSTART=KPBL                                  ! Changed 7/23/99
5675          KSTART=KPBL+1                                ! Changed 7/23/99
5676          KLFS = LET-1
5677          DO NK = KSTART+1,KL
5678            DPPP = P0(KSTART)-P0(NK)
5679 !          IF(DPPP.GT.200.E2)THEN
5680            IF(DPPP.GT.150.E2)THEN
5681              KLFS = NK
5682              EXIT
5683            ENDIF
5684          ENDDO
5685          KLFS = MIN0(KLFS,LET-1)
5686          LFS = KLFS
5687 !
5688 !...if LFS is not at least 50 mb above cloud base (implying that the
5689 !...level of equil temp, LET, is just above cloud base) do not allow a
5690 !...downdraft...
5691 !
5692         IF((P0(KSTART)-P0(LFS)).GT.50.E2)THEN
5693           THETED(LFS) = THETEE(LFS)
5694           QD(LFS) = Q0(LFS)
5695 !
5696 !...call tpmix2dd to find wet-bulb temp, qv...
5697 !
5698           call tpmix2dd(p0(lfs),theted(lfs),tz(lfs),qss,i,j)
5699           THTAD(LFS)=TZ(LFS)*(P00/P0(LFS))**(0.2854*(1.-0.28*QSS))
5700 !
5701 !...TAKE A FIRST GUESS AT THE INITIAL DOWNDRAFT MASS FLUX...
5702 !
5703           TVD(LFS)=TZ(LFS)*(1.+0.608*QSS)
5704           RDD=P0(LFS)/(R*TVD(LFS))
5705           A1=(1.-PEFF)*AU0
5706           DMF(LFS)=-A1*RDD
5707           DER(LFS)=DMF(LFS)
5708           DDR(LFS)=0.
5709           RHBAR = RH(LFS)*DP(LFS)
5710           DPTT = DP(LFS)
5711           DO ND = LFS-1,KSTART,-1
5712             ND1 = ND+1
5713             DER(ND)=DER(LFS)*EMS(ND)/EMS(LFS)
5714             DDR(ND)=0.
5715             DMF(ND)=DMF(ND1)+DER(ND)
5716             THETED(ND)=(THETED(ND1)*DMF(ND1)+THETEE(ND)*DER(ND))/DMF(ND)
5717             QD(ND)=(QD(ND1)*DMF(ND1)+Q0(ND)*DER(ND))/DMF(ND)
5718             DPTT = DPTT+DP(ND)
5719             RHBAR = RHBAR+RH(ND)*DP(ND)
5720           ENDDO
5721           RHBAR = RHBAR/DPTT
5722           DMFFRC = 2.*(1.-RHBAR)    ! Kain (2004) eq. 11
5723           DPDD = 0.
5724 !...Calculate melting effect
5725 !... first, compute total frozen precipitation generated...
5726 !
5727           pptmlt = 0.
5728           DO NK = KLCL,LTOP
5729             PPTMLT = PPTMLT+PPTICE(NK)
5730           ENDDO
5731           if(lc.lt.ml)then
5732 !...For now, calculate melting effect as if DMF = -UMF at KLCL, i.e., as
5733 !...if DMFFRC=1.  Otherwise, for small DMFFRC, DTMELT gets too large!
5734 !...12/14/98 jsk...
5735             DTMELT = RLF*PPTMLT/(CP*UMF(KLCL))
5736           else
5737             DTMELT = 0.
5738           endif
5739           LDT = MIN0(LFS-1,KSTART-1)
5740 !
5741           call tpmix2dd(p0(kstart),theted(kstart),tz(kstart),qss,i,j)
5742 !
5743           tz(kstart) = tz(kstart)-dtmelt
5744           ES=ALIQ*EXP((BLIQ*TZ(KSTART)-CLIQ)/(TZ(KSTART)-DLIQ))
5745           QSS=0.622*ES/(P0(KSTART)-ES)
5746           THETED(KSTART)=TZ(KSTART)*(1.E5/P0(KSTART))**(0.2854*(1.-0.28*QSS))*    &
5747                 EXP((3374.6525/TZ(KSTART)-2.5403)*QSS*(1.+0.81*QSS))
5748 !....
5749           LDT = MIN0(LFS-1,KSTART-1)
5750           DO ND = LDT,1,-1
5751             DPDD = DPDD+DP(ND)
5752             THETED(ND) = THETED(KSTART)
5753             QD(ND)     = QD(KSTART)
5754 !
5755 !...call tpmix2dd to find wet bulb temp, saturation mixing ratio...
5756 !
5757             call tpmix2dd(p0(nd),theted(nd),tz(nd),qss,i,j)
5758             qsd(nd) = qss
5759 !
5760 !...specify RH decrease of 20%/km in downdraft...
5761 !
5762             RHH = 1.-0.2/1000.*(Z0(KSTART)-Z0(ND))
5763 !
5764 !...adjust downdraft TEMP, Q to specified RH:
5765 !
5766             IF(RHH.LT.1.)THEN
5767               DSSDT=(CLIQ-BLIQ*DLIQ)/((TZ(ND)-DLIQ)*(TZ(ND)-DLIQ))
5768               RL=XLV0-XLV1*TZ(ND)
5769               DTMP=RL*QSS*(1.-RHH)/(CP+RL*RHH*QSS*DSSDT)
5770               T1RH=TZ(ND)+DTMP
5771               ES=RHH*ALIQ*EXP((BLIQ*T1RH-CLIQ)/(T1RH-DLIQ))
5772               QSRH=0.622*ES/(P0(ND)-ES)
5773 !
5774 !...CHECK TO SEE IF MIXING RATIO AT SPECIFIED RH IS LESS THAN ACTUAL
5775 !...MIXING RATIO...IF SO, ADJUST TO GIVE ZERO EVAPORATION...
5776 !
5777               IF(QSRH.LT.QD(ND))THEN
5778                 QSRH=QD(ND)
5779                 T1RH=TZ(ND)+(QSS-QSRH)*RL/CP
5780               ENDIF
5781               TZ(ND)=T1RH
5782               QSS=QSRH
5783               QSD(ND) = QSS
5784             ENDIF
5785             TVD(nd) = tz(nd)*(1.+0.608*qsd(nd))
5786             IF(TVD(ND).GT.TV0(ND).OR.ND.EQ.1)THEN
5787               LDB=ND
5788               EXIT
5789             ENDIF
5790           ENDDO
5791           IF((P0(LDB)-P0(LFS)) .gt. 50.E2)THEN   ! minimum Downdraft depth!
5792             DO ND=LDT,LDB,-1
5793               ND1 = ND+1
5794               DDR(ND) = -DMF(KSTART)*DP(ND)/DPDD
5795               DER(ND) = 0.
5796               DMF(ND) = DMF(ND1)+DDR(ND)
5797               TDER=TDER+(QSD(nd)-QD(ND))*DDR(ND)
5798               QD(ND)=QSD(nd)
5799               THTAD(ND)=TZ(ND)*(P00/P0(ND))**(0.2854*(1.-0.28*QD(ND)))
5800             ENDDO
5801           ENDIF
5802         ENDIF
5803       ENDIF devap
5804
5805 !...IF DOWNDRAFT DOES NOT EVAPORATE ANY WATER FOR SPECIFIED RELATIVE
5806 !...HUMIDITY, NO DOWNDRAFT IS ALLOWED...
5807 !
5808 d_mf:   IF(TDER.LT.1.)THEN
5809 !           WRITE(98,3004)I,J
5810 !3004       FORMAT(' ','No Downdraft!;  I=',I3,2X,'J=',I3,'ISHALL =',I2)
5811           PPTFLX=TRPPT
5812           CPR=TRPPT
5813           TDER=0.
5814           CNDTNF=0.
5815           UPDINC=1.
5816           LDB=LFS
5817           DO NDK=1,LTOP
5818             DMF(NDK)=0.
5819             DER(NDK)=0.
5820             DDR(NDK)=0.
5821             THTAD(NDK)=0.
5822             WD(NDK)=0.
5823             TZ(NDK)=0.
5824             QD(NDK)=0.
5825           ENDDO
5826           AINCM2=100.
5827         ELSE
5828           DDINC = -DMFFRC*UMF(KLCL)/DMF(KSTART)
5829           UPDINC=1.
5830           IF(TDER*DDINC.GT.TRPPT)THEN
5831             DDINC = TRPPT/TDER
5832           ENDIF
5833           TDER = TDER*DDINC
5834           DO NK=LDB,LFS
5835             DMF(NK)=DMF(NK)*DDINC
5836             DER(NK)=DER(NK)*DDINC
5837             DDR(NK)=DDR(NK)*DDINC
5838           ENDDO
5839          CPR=TRPPT
5840          PPTFLX = TRPPT-TDER
5841          PEFF=PPTFLX/TRPPT
5842          IF(IPRNT)THEN
5843 !           write(98,*)'PRECIP EFFICIENCY =',PEFF
5844            write(message,*)'PRECIP EFFICIENCY =',PEFF
5845            CALL wrf_message(message)
5846 !          flush(98)
5847          ENDIF
5848 !
5849 !
5850 !...ADJUST UPDRAFT MASS FLUX, MASS DETRAINMENT RATE, AND LIQUID WATER AN
5851 !   DETRAINMENT RATES TO BE CONSISTENT WITH THE TRANSFER OF THE ESTIMATE
5852 !   FROM THE UPDRAFT TO THE DOWNDRAFT AT THE LFS...
5853 !
5854 !         DO NK=LC,LFS
5855 !           UMF(NK)=UMF(NK)*UPDINC
5856 !           UDR(NK)=UDR(NK)*UPDINC
5857 !           UER(NK)=UER(NK)*UPDINC
5858 !           PPTLIQ(NK)=PPTLIQ(NK)*UPDINC
5859 !           PPTICE(NK)=PPTICE(NK)*UPDINC
5860 !           DETLQ(NK)=DETLQ(NK)*UPDINC
5861 !           DETIC(NK)=DETIC(NK)*UPDINC
5862 !         ENDDO
5863 !
5864
5865 !...ZERO OUT THE ARRAYS FOR DOWNDRAFT DATA AT LEVELS ABOVE AND BELOW THE
5866 !...DOWNDRAFT...
5867 !
5868          IF(LDB.GT.1)THEN
5869            DO NK=1,LDB-1
5870              DMF(NK)=0.
5871              DER(NK)=0.
5872              DDR(NK)=0.
5873              WD(NK)=0.
5874              TZ(NK)=0.
5875              QD(NK)=0.
5876              THTAD(NK)=0.
5877            ENDDO
5878          ENDIF
5879          DO NK=LFS+1,KX
5880            DMF(NK)=0.
5881            DER(NK)=0.
5882            DDR(NK)=0.
5883            WD(NK)=0.
5884            TZ(NK)=0.
5885            QD(NK)=0.
5886            THTAD(NK)=0.
5887          ENDDO
5888          DO NK=LDT+1,LFS-1
5889            TZ(NK)=0.
5890            QD(NK)=0.
5891            THTAD(NK)=0.
5892          ENDDO
5893        ENDIF d_mf
5894 !
5895 !...SET LIMITS ON THE UPDRAFT AND DOWNDRAFT MASS FLUXES SO THAT THE INFLOW
5896 !   INTO CONVECTIVE DRAFTS FROM A GIVEN LAYER IS NO MORE THAN IS AVAILABLE
5897 !   IN THAT LAYER INITIALLY...
5898 !
5899        AINCMX=1000.
5900        LMAX=MAX0(KLCL,LFS)
5901        DO NK=LC,LMAX
5902          IF((UER(NK)-DER(NK)).GT.1.e-3)THEN
5903            AINCM1=EMS(NK)/((UER(NK)-DER(NK))*TIMEC)
5904            AINCMX=AMIN1(AINCMX,AINCM1)
5905          ENDIF
5906        ENDDO
5907        AINC=1.
5908        IF(AINCMX.LT.AINC)AINC=AINCMX
5909 !
5910 !...SAVE THE RELEVENT VARIABLES FOR A UNIT UPDRAFT AND DOWNDRAFT...THEY WILL
5911 !...BE ITERATIVELY ADJUSTED BY THE FACTOR AINC TO SATISFY THE STABILIZATION
5912 !...CLOSURE...
5913 !
5914        TDER2=TDER
5915        PPTFL2=PPTFLX
5916        DO NK=1,LTOP
5917          DETLQ2(NK)=DETLQ(NK)
5918          DETIC2(NK)=DETIC(NK)
5919          UDR2(NK)=UDR(NK)
5920          UER2(NK)=UER(NK)
5921          DDR2(NK)=DDR(NK)
5922          DER2(NK)=DER(NK)
5923          UMF2(NK)=UMF(NK)
5924          DMF2(NK)=DMF(NK)
5925        ENDDO
5926        FABE=1.
5927        STAB=0.95
5928        NOITR=0
5929        ISTOP=0
5930 !
5931         IF(ISHALL.EQ.1)THEN                              ! First for shallow convection
5932 !
5933 ! No iteration for shallow convection; if turbulent kinetic energy (TKE) is available
5934 ! from a turbulence parameterization, scale cloud-base updraft mass flux as a function
5935 ! of TKE, but for now, just specify shallow-cloud mass flux using TKEMAX = 5...
5936 !
5937 !...find the maximum TKE value between LC and KLCL...
5938 !         TKEMAX = 0.
5939           TKEMAX = 5.
5940 !          DO 173 K = LC,KLCL
5941 !            NK = KX-K+1
5942 !            TKEMAX = AMAX1(TKEMAX,Q2(I,J,NK))
5943 ! 173      CONTINUE
5944 !          TKEMAX = AMIN1(TKEMAX,10.)
5945 !          TKEMAX = AMAX1(TKEMAX,5.)
5946 !c         TKEMAX = 10.
5947 !c...3_24_99...DPMIN was changed for shallow convection so that it is the
5948 !c...          the same as for deep convection (5.E3).  Since this doubles
5949 !c...          (roughly) the value of DPTHMX, add a factor of 0.5 to calcu-
5950 !c...          lation of EVAC...
5951 !c         EVAC  = TKEMAX*0.1
5952           EVAC  = 0.5*TKEMAX*0.1
5953 !         AINC = 0.1*DPTHMX*DXIJ*DXIJ/(VMFLCL*G*TIMEC)
5954 !          AINC = EVAC*DPTHMX*DX(I,J)*DX(I,J)/(VMFLCL*G*TIMEC)
5955           AINC = EVAC*DPTHMX*DXSQ/(VMFLCL*G*TIMEC)
5956           TDER=TDER2*AINC
5957           PPTFLX=PPTFL2*AINC
5958           DO NK=1,LTOP
5959             UMF(NK)=UMF2(NK)*AINC
5960             DMF(NK)=DMF2(NK)*AINC
5961             DETLQ(NK)=DETLQ2(NK)*AINC
5962             DETIC(NK)=DETIC2(NK)*AINC
5963             UDR(NK)=UDR2(NK)*AINC
5964             UER(NK)=UER2(NK)*AINC
5965             DER(NK)=DER2(NK)*AINC
5966             DDR(NK)=DDR2(NK)*AINC
5967           ENDDO
5968         ENDIF                                           ! Otherwise for deep convection
5969 ! use iterative procedure to find mass fluxes...
5970 iter:     DO NCOUNT=1,10
5971 !
5972 !*****************************************************************
5973 !                                                                *
5974 !           COMPUTE PROPERTIES FOR COMPENSATIONAL SUBSIDENCE     *
5975 !                                                                *
5976 !*****************************************************************
5977 !
5978 !...DETERMINE OMEGA VALUE NECESSARY AT TOP AND BOTTOM OF EACH LAYER TO
5979 !...SATISFY MASS CONTINUITY...
5980 !
5981             DTT=TIMEC
5982             DO NK=1,LTOP
5983               DOMGDP(NK)=-(UER(NK)-DER(NK)-UDR(NK)-DDR(NK))*EMSD(NK)
5984               IF(NK.GT.1)THEN
5985                 OMG(NK)=OMG(NK-1)-DP(NK-1)*DOMGDP(NK-1)
5986                 ABSOMG = ABS(OMG(NK))
5987                 ABSOMGTC = ABSOMG*TIMEC
5988                 FRDP = 0.75*DP(NK-1)
5989                 IF(ABSOMGTC.GT.FRDP)THEN
5990                   DTT1 = FRDP/ABSOMG
5991                   DTT=AMIN1(DTT,DTT1)
5992                 ENDIF
5993               ENDIF
5994             ENDDO
5995             DO NK=1,LTOP
5996               THPA(NK)=THTA0(NK)
5997               QPA(NK)=Q0(NK)
5998               NSTEP=NINT(TIMEC/DTT+1)
5999               DTIME=TIMEC/FLOAT(NSTEP)
6000               FXM(NK)=OMG(NK)*DXSQ/G
6001             ENDDO
6002 !
6003 !...DO AN UPSTREAM/FORWARD-IN-TIME ADVECTION OF THETA, QV...
6004 !
6005         DO NTC=1,NSTEP
6006 !
6007 !...ASSIGN THETA AND Q VALUES AT THE TOP AND BOTTOM OF EACH LAYER BASED ON
6008 !...SIGN OF OMEGA...
6009 !
6010             DO  NK=1,LTOP
6011               THFXIN(NK)=0.
6012               THFXOUT(NK)=0.
6013               QFXIN(NK)=0.
6014               QFXOUT(NK)=0.
6015             ENDDO
6016             DO NK=2,LTOP
6017               IF(OMG(NK).LE.0.)THEN
6018                 THFXIN(NK)=-FXM(NK)*THPA(NK-1)
6019                 QFXIN(NK)=-FXM(NK)*QPA(NK-1)
6020                 THFXOUT(NK-1)=THFXOUT(NK-1)+THFXIN(NK)
6021                 QFXOUT(NK-1)=QFXOUT(NK-1)+QFXIN(NK)
6022               ELSE
6023                 THFXOUT(NK)=FXM(NK)*THPA(NK)
6024                 QFXOUT(NK)=FXM(NK)*QPA(NK)
6025                 THFXIN(NK-1)=THFXIN(NK-1)+THFXOUT(NK)
6026                 QFXIN(NK-1)=QFXIN(NK-1)+QFXOUT(NK)
6027               ENDIF
6028             ENDDO
6029 !
6030 !...UPDATE THE THETA AND QV VALUES AT EACH LEVEL...
6031 !
6032             DO NK=1,LTOP
6033               THPA(NK)=THPA(NK)+(THFXIN(NK)+UDR(NK)*THTAU(NK)+DDR(NK)*      &
6034                        THTAD(NK)-THFXOUT(NK)-(UER(NK)-DER(NK))*THTA0(NK))*  &
6035                        DTIME*EMSD(NK)
6036               QPA(NK)=QPA(NK)+(QFXIN(NK)+UDR(NK)*QDT(NK)+DDR(NK)*QD(NK)-    &
6037                       QFXOUT(NK)-(UER(NK)-DER(NK))*Q0(NK))*DTIME*EMSD(NK)
6038             ENDDO
6039           ENDDO
6040           DO NK=1,LTOP
6041             THTAG(NK)=THPA(NK)
6042             QG(NK)=QPA(NK)
6043           ENDDO
6044 !
6045 !...CHECK TO SEE IF MIXING RATIO DIPS BELOW ZERO ANYWHERE;  IF SO, BORROW
6046 !...MOISTURE FROM ADJACENT LAYERS TO BRING IT BACK UP ABOVE ZERO...
6047 !
6048         DO NK=1,LTOP
6049           IF(QG(NK).LT.0.)THEN
6050             IF(NK.EQ.1)THEN                             ! JSK MODS
6051 !              PRINT *,' PROBLEM WITH KF SCHEME:  ' ! JSK MODS
6052 !              PRINT *,'QG = 0 AT THE SURFACE!!!!!!!'    ! JSK MODS
6053               CALL wrf_error_fatal ( 'QG, QG(NK).LT.0') ! JSK MODS
6054             ENDIF                                       ! JSK MODS
6055             NK1=NK+1
6056             IF(NK.EQ.LTOP)THEN
6057               NK1=KLCL
6058             ENDIF
6059             TMA=QG(NK1)*EMS(NK1)
6060             TMB=QG(NK-1)*EMS(NK-1)
6061             TMM=(QG(NK)-1.E-9)*EMS(NK  )
6062             BCOEFF=-TMM/((TMA*TMA)/TMB+TMB)
6063             ACOEFF=BCOEFF*TMA/TMB
6064             TMB=TMB*(1.-BCOEFF)
6065             TMA=TMA*(1.-ACOEFF)
6066             IF(NK.EQ.LTOP)THEN
6067               QVDIFF=(QG(NK1)-TMA*EMSD(NK1))*100./QG(NK1)
6068 !              IF(ABS(QVDIFF).GT.1.)THEN
6069 !             PRINT *,'!!!WARNING!!! CLOUD BASE WATER VAPOR CHANGES BY ',     &
6070 !                      QVDIFF,                                                &
6071 !                     '% WHEN MOISTURE IS BORROWED TO PREVENT NEGATIVE ',     &
6072 !                     'VALUES IN KAIN-FRITSCH'
6073 !              ENDIF
6074             ENDIF
6075             QG(NK)=1.E-9
6076             QG(NK1)=TMA*EMSD(NK1)
6077             QG(NK-1)=TMB*EMSD(NK-1)
6078           ENDIF
6079         ENDDO
6080         TOPOMG=(UDR(LTOP)-UER(LTOP))*DP(LTOP)*EMSD(LTOP)
6081         IF(ABS(TOPOMG-OMG(LTOP)).GT.1.E-3)THEN
6082 !       WRITE(99,*)'ERROR:  MASS DOES NOT BALANCE IN KF SCHEME;            &
6083 !      TOPOMG, OMG =',TOPOMG,OMG(LTOP)
6084 !      TOPOMG, OMG =',TOPOMG,OMG(LTOP)
6085           ISTOP=1
6086           IPRNT=.TRUE.
6087           EXIT iter
6088         ENDIF
6089 !
6090 !...CONVERT THETA TO T...
6091 !
6092         DO NK=1,LTOP
6093           EXN(NK)=(P00/P0(NK))**(0.2854*(1.-0.28*QG(NK)))
6094           TG(NK)=THTAG(NK)/EXN(NK)
6095           TVG(NK)=TG(NK)*(1.+0.608*QG(NK))
6096         ENDDO
6097         IF(ISHALL.EQ.1)THEN
6098           EXIT iter
6099         ENDIF
6100 !
6101 !*******************************************************************
6102 !                                                                  *
6103 !     COMPUTE NEW CLOUD AND CHANGE IN AVAILABLE BUOYANT ENERGY.    *
6104 !                                                                  *
6105 !*******************************************************************
6106 !
6107 !...THE FOLLOWING COMPUTATIONS ARE SIMILAR TO THAT FOR UPDRAFT
6108 !
6109 !        THMIX=0.
6110           TMIX=0.
6111           QMIX=0.
6112 !
6113 !...FIND THE THERMODYNAMIC CHARACTERISTICS OF THE LAYER BY
6114 !...MASS-WEIGHTING THE CHARACTERISTICS OF THE INDIVIDUAL MODEL
6115 !...LAYERS...
6116 !
6117           DO NK=LC,KPBL
6118             TMIX=TMIX+DP(NK)*TG(NK)
6119             QMIX=QMIX+DP(NK)*QG(NK)
6120           ENDDO
6121           TMIX=TMIX/DPTHMX
6122           QMIX=QMIX/DPTHMX
6123           ES=ALIQ*EXP((TMIX*BLIQ-CLIQ)/(TMIX-DLIQ))
6124           QSS=0.622*ES/(PMIX-ES)
6125 !
6126 !...REMOVE SUPERSATURATION FOR DIAGNOSTIC PURPOSES, IF NECESSARY...
6127 !
6128           IF(QMIX.GT.QSS)THEN
6129             RL=XLV0-XLV1*TMIX
6130             CPM=CP*(1.+0.887*QMIX)
6131             DSSDT=QSS*(CLIQ-BLIQ*DLIQ)/((TMIX-DLIQ)*(TMIX-DLIQ))
6132             DQ=(QMIX-QSS)/(1.+RL*DSSDT/CPM)
6133             TMIX=TMIX+RL/CP*DQ
6134             QMIX=QMIX-DQ
6135             TLCL=TMIX
6136           ELSE
6137             QMIX=AMAX1(QMIX,0.)
6138             EMIX=QMIX*PMIX/(0.622+QMIX)
6139             astrt=1.e-3
6140             binc=0.075
6141             a1=emix/aliq
6142             tp=(a1-astrt)/binc
6143             indlu=int(tp)+1
6144             value=(indlu-1)*binc+astrt
6145             aintrp=(a1-value)/binc
6146             tlog=aintrp*alu(indlu+1)+(1-aintrp)*alu(indlu)
6147             TDPT=(CLIQ-DLIQ*TLOG)/(BLIQ-TLOG)
6148             TLCL=TDPT-(.212+1.571E-3*(TDPT-T00)-4.36E-4*(TMIX-T00))*(TMIX-TDPT)
6149             TLCL=AMIN1(TLCL,TMIX)
6150           ENDIF
6151           TVLCL=TLCL*(1.+0.608*QMIX)
6152           ZLCL = ZMIX+(TLCL-TMIX)/GDRY
6153           DO NK = LC,KL
6154             KLCL=NK
6155             IF(ZLCL.LE.Z0(NK))THEN
6156               EXIT
6157             ENDIF
6158           ENDDO
6159           K=KLCL-1
6160           DLP=(ZLCL-Z0(K))/(Z0(KLCL)-Z0(K))
6161 !
6162 !...ESTIMATE ENVIRONMENTAL TEMPERATURE AND MIXING RATIO AT THE LCL...
6163 !
6164           TENV=TG(K)+(TG(KLCL)-TG(K))*DLP
6165           QENV=QG(K)+(QG(KLCL)-QG(K))*DLP
6166           TVEN=TENV*(1.+0.608*QENV)
6167           PLCL=P0(K)+(P0(KLCL)-P0(K))*DLP
6168           THETEU(K)=TMIX*(1.E5/PMIX)**(0.2854*(1.-0.28*QMIX))*             &
6169                   EXP((3374.6525/TLCL-2.5403)*QMIX*(1.+0.81*QMIX))
6170 !
6171 !...COMPUTE ADJUSTED ABE(ABEG).
6172 !
6173           ABEG=0.
6174           DO NK=K,LTOPM1
6175             NK1=NK+1
6176
6177 !new ckay adding FRZ effect 01-30-2015
6178          IF (aercu_opt.GT.0.0) THEN
6179             JK = KX-NK+1
6180             a1kay =  FRZ(1,JK)*DZA(NK)*3.337E5/CP
6181             a1kay = a1kay * ((1.E5/P0(NK))**ROCP)
6182             THETEU(NK)  =  a1kay + THETEU(NK)
6183          END IF
6184 !ckay freezing effect included in ThetaU for cape calculation
6185
6186             THETEU(NK1) = THETEU(NK)
6187 !
6188             call tpmix2dd(p0(nk1),theteu(nk1),tgu(nk1),qgu(nk1),i,j)
6189 !
6190             TVQU(NK1)=TGU(NK1)*(1.+0.608*QGU(NK1)-QLIQ(NK1)-QICE(NK1))
6191             IF(NK.EQ.K)THEN
6192               DZZ=Z0(KLCL)-ZLCL
6193               DILBE=((TVLCL+TVQU(NK1))/(TVEN+TVG(NK1))-1.)*DZZ
6194             ELSE
6195               DZZ=DZA(NK)
6196               DILBE=((TVQU(NK)+TVQU(NK1))/(TVG(NK)+TVG(NK1))-1.)*DZZ
6197             ENDIF
6198             IF(DILBE.GT.0.)ABEG=ABEG+DILBE*G
6199 !
6200 !...DILUTE BY ENTRAINMENT BY THE RATE AS ORIGINAL UPDRAFT...
6201 !
6202             CALL ENVIRTHT(P0(NK1),TG(NK1),QG(NK1),THTEEG(NK1),ALIQ,BLIQ,CLIQ,DLIQ)
6203             THETEU(NK1)=THETEU(NK1)*DDILFRC(NK1)+THTEEG(NK1)*(1.-DDILFRC(NK1))
6204           ENDDO
6205 !
6206 !...ASSUME AT LEAST 90% OF CAPE (ABE) IS REMOVED BY CONVECTION DURING
6207 !...THE PERIOD TIMEC...
6208 !
6209           IF(NOITR.EQ.1)THEN
6210 !         write(98,*)' '
6211 !         write(98,*)'TAU, I, J, =',NTSD,I,J
6212 !         WRITE(98,1060)FABE
6213 !          GOTO 265
6214           EXIT iter
6215           ENDIF
6216           DABE=AMAX1(ABE-ABEG,capeDX*ABE)
6217
6218           FABE=ABEG/ABE
6219           IF(FABE.GT.1. .and. ISHALL.EQ.0)THEN
6220 !          WRITE(98,*)'UPDRAFT/DOWNDRAFT COUPLET INCREASES CAPE AT THIS
6221 !     *GRID POINT; NO CONVECTION ALLOWED!'
6222             RETURN
6223           ENDIF
6224           IF(NCOUNT.NE.1)THEN
6225             IF(ABS(AINC-AINCOLD).LT.0.0001)THEN
6226               NOITR=1
6227               AINC=AINCOLD
6228               CYCLE iter
6229             ENDIF
6230             DFDA=(FABE-FABEOLD)/(AINC-AINCOLD)
6231             IF(DFDA.GT.0.)THEN
6232               NOITR=1
6233               AINC=AINCOLD
6234               CYCLE iter
6235             ENDIF
6236           ENDIF
6237           AINCOLD=AINC
6238           FABEOLD=FABE
6239           IF(AINC/AINCMX.GT.0.999.AND.FABE.GT.1.05-STAB)THEN
6240 !           write(98,*)' '
6241 !           write(98,*)'TAU, I, J, =',NTSD,I,J
6242 !           WRITE(98,1055)FABE
6243 !            GOTO 265
6244             EXIT
6245           ENDIF
6246           IF((FABE.LE.1.05-STAB.AND.FABE.GE.0.95-STAB) .or. NCOUNT.EQ.10)THEN
6247             EXIT iter
6248           ELSE
6249             IF(NCOUNT.GT.10)THEN
6250 !             write(98,*)' '
6251 !             write(98,*)'TAU, I, J, =',NTSD,I,J
6252 !             WRITE(98,1060)FABE
6253 !             GOTO 265
6254               EXIT
6255             ENDIF
6256 !
6257 !...IF MORE THAN 10% OF THE ORIGINAL CAPE REMAINS, INCREASE THE CONVECTIVE
6258 !...MASS FLUX BY THE FACTOR AINC:
6259 !
6260             IF(FABE.EQ.0.)THEN
6261               AINC=AINC*0.5
6262             ELSE
6263               IF(DABE.LT.1.e-4)THEN
6264                 NOITR=1
6265                 AINC=AINCOLD
6266                 CYCLE iter
6267               ELSE
6268                 AINC=AINC*STAB*ABE/DABE
6269               ENDIF
6270             ENDIF
6271 !           AINC=AMIN1(AINCMX,AINC)
6272             AINC=AMIN1(AINCMX,AINC)
6273 !...IF AINC BECOMES VERY SMALL, EFFECTS OF CONVECTION ! JSK MODS
6274 !...WILL BE MINIMAL SO JUST IGNORE IT...              ! JSK MODS
6275             IF(AINC.LT.0.05)then
6276               RETURN                          ! JSK MODS
6277             ENDIF
6278 !            AINC=AMAX1(AINC,0.05)                        ! JSK MODS
6279             TDER=TDER2*AINC
6280             PPTFLX=PPTFL2*AINC
6281 !           IF (XTIME.LT.10.)THEN
6282 !           WRITE(98,1080)LFS,LDB,LDT,TIMEC,TADVEC,NSTEP,NCOUNT,
6283 !          *              FABEOLD,AINCOLD
6284 !           ENDIF
6285             DO NK=1,LTOP
6286               UMF(NK)=UMF2(NK)*AINC
6287               DMF(NK)=DMF2(NK)*AINC
6288               DETLQ(NK)=DETLQ2(NK)*AINC
6289               DETIC(NK)=DETIC2(NK)*AINC
6290               UDR(NK)=UDR2(NK)*AINC
6291               UER(NK)=UER2(NK)*AINC
6292               DER(NK)=DER2(NK)*AINC
6293               DDR(NK)=DDR2(NK)*AINC
6294             ENDDO
6295 !
6296 !...GO BACK UP FOR ANOTHER ITERATION...
6297 !
6298           ENDIF
6299         ENDDO iter
6300
6301 !ckay
6302 ! get the cloud fraction for layer NK+1=NK1
6303             updil = (100.-AINC)
6304             updil = updil/100.
6305            IF (aercu_opt .GT. 0) THEN
6306             ainc_frac(I,J) = 1.0-updil !TWG
6307            END IF
6308             updil = updil*dxsq
6309             Drag = 0.5
6310
6311         IF(ISHALL.EQ.1) THEN
6312           DO NK=KLCL, LTOP
6313             UMF_new = UMF(NK)/updil
6314             denSplume = P0(NK)/(R*TU(NK))
6315             xcldfra = 0.07*alog(1.+(500.*UMF_new))
6316             xcldfra = amax1(0.01,xcldfra)
6317             cldfra_sh_KF(I,NK,J) = amin1(0.2,xcldfra)
6318 !ckaywup
6319             DMF_new=DMF(NK)/updil
6320             FXM_new=FXM(NK)/dxsq
6321           ENDDO
6322         ELSE
6323           DO NK=KLCL, LTOP
6324 ! ww: moved the next line up
6325             UMF_new = UMF(NK)/updil
6326             denSplume = P0(NK)/(R*TU(NK))
6327             xcldfra = 0.14*alog(1.+(500.*UMF_new))
6328             xcldfra = amax1(0.01,xcldfra)
6329             cldfra_dp_KF(I,NK,J) = amin1(0.6,xcldfra)
6330 !new added downdraft impact
6331             DMF_new = DMF(NK)/updil
6332             FXM_new = FXM(NK)/dxsq
6333           ENDDO
6334         ENDIF
6335 !ckaywup
6336           envRHavg = 0.0
6337           DO NK=KLCL-1,LTOP1
6338            envEsat = 6.112*exp(17.67*(T0(NK)-273.16)/(243.5+T0(NK)-273.16))
6339            envEsat = envEsat * 100.0  ! to hPa
6340            envQsat = 0.622*envEsat/(P0(NK)-envEsat)
6341            envRH  = Q0(NK)/envQsat
6342             envRHavg = envRHavg + envRH
6343           END DO
6344
6345 !kf_edrates
6346 !Save up/down entrainment/detrainment rates as 3D variables
6347         IF (KF_EDRATES == 1) THEN
6348            DO NK=1,LTOP
6349              UDR_KF(I,NK,J)=UDR(NK)
6350              DDR_KF(I,NK,J)=DDR(NK)
6351              UER_KF(I,NK,J)=UER(NK)
6352              DER_KF(I,NK,J)=DER(NK)
6353            ENDDO
6354         ENDIF
6355
6356 !
6357 !...COMPUTE HYDROMETEOR TENDENCIES AS IS DONE FOR T, QV...
6358 !
6359 !...FRC2 IS THE FRACTION OF TOTAL CONDENSATE      !  PPT FB MODS
6360 !...GENERATED THAT GOES INTO PRECIPITIATION       !  PPT FB MODS
6361 !
6362 !  Redistribute hydormeteors according to the final mass-flux values:
6363 !
6364         IF(CPR.GT.0.)THEN
6365           FRC2=PPTFLX/(CPR*AINC)                    !  PPT FB MODS
6366         ELSE
6367            FRC2=0.
6368         ENDIF
6369         DO NK=1,LTOP
6370           QLPA(NK)=QL0(NK)
6371           QIPA(NK)=QI0(NK)
6372           QRPA(NK)=QR0(NK)
6373           QSPA(NK)=QS0(NK)
6374           RAINFB(NK)=PPTLIQ(NK)*AINC*FBFRC*FRC2   !  PPT FB MODS
6375           SNOWFB(NK)=PPTICE(NK)*AINC*FBFRC*FRC2   !  PPT FB MODS
6376         ENDDO
6377         DO NTC=1,NSTEP
6378 !
6379 !...ASSIGN HYDROMETEORS CONCENTRATIONS AT THE TOP AND BOTTOM OF EACH LAYER
6380 !...BASED ON THE SIGN OF OMEGA...
6381 !
6382           DO NK=1,LTOP
6383             QLFXIN(NK)=0.
6384             QLFXOUT(NK)=0.
6385             QIFXIN(NK)=0.
6386             QIFXOUT(NK)=0.
6387             QRFXIN(NK)=0.
6388             QRFXOUT(NK)=0.
6389             QSFXIN(NK)=0.
6390             QSFXOUT(NK)=0.
6391           ENDDO
6392           DO NK=2,LTOP
6393             IF(OMG(NK).LE.0.)THEN
6394               QLFXIN(NK)=-FXM(NK)*QLPA(NK-1)
6395               QIFXIN(NK)=-FXM(NK)*QIPA(NK-1)
6396               QRFXIN(NK)=-FXM(NK)*QRPA(NK-1)
6397               QSFXIN(NK)=-FXM(NK)*QSPA(NK-1)
6398               QLFXOUT(NK-1)=QLFXOUT(NK-1)+QLFXIN(NK)
6399               QIFXOUT(NK-1)=QIFXOUT(NK-1)+QIFXIN(NK)
6400               QRFXOUT(NK-1)=QRFXOUT(NK-1)+QRFXIN(NK)
6401               QSFXOUT(NK-1)=QSFXOUT(NK-1)+QSFXIN(NK)
6402             ELSE
6403               QLFXOUT(NK)=FXM(NK)*QLPA(NK)
6404               QIFXOUT(NK)=FXM(NK)*QIPA(NK)
6405               QRFXOUT(NK)=FXM(NK)*QRPA(NK)
6406               QSFXOUT(NK)=FXM(NK)*QSPA(NK)
6407               QLFXIN(NK-1)=QLFXIN(NK-1)+QLFXOUT(NK)
6408               QIFXIN(NK-1)=QIFXIN(NK-1)+QIFXOUT(NK)
6409               QRFXIN(NK-1)=QRFXIN(NK-1)+QRFXOUT(NK)
6410               QSFXIN(NK-1)=QSFXIN(NK-1)+QSFXOUT(NK)
6411             ENDIF
6412           ENDDO
6413 !
6414 !...UPDATE THE HYDROMETEOR CONCENTRATION VALUES AT EACH LEVEL...
6415 !
6416           DO NK=1,LTOP
6417             QLPA(NK)=QLPA(NK)+(QLFXIN(NK)+DETLQ(NK)-QLFXOUT(NK))*DTIME*EMSD(NK)
6418             QIPA(NK)=QIPA(NK)+(QIFXIN(NK)+DETIC(NK)-QIFXOUT(NK))*DTIME*EMSD(NK)
6419             QRPA(NK)=QRPA(NK)+(QRFXIN(NK)-QRFXOUT(NK)+RAINFB(NK))*DTIME*EMSD(NK)         !  PPT FB MODS
6420             QSPA(NK)=QSPA(NK)+(QSFXIN(NK)-QSFXOUT(NK)+SNOWFB(NK))*DTIME*EMSD(NK)         !  PPT FB MODS
6421           ENDDO
6422         ENDDO
6423         DO NK=1,LTOP
6424           QLG(NK)=QLPA(NK)
6425           QIG(NK)=QIPA(NK)
6426           QRG(NK)=QRPA(NK)
6427           QSG(NK)=QSPA(NK)
6428         ENDDO
6429
6430 !kf_edrates
6431 !Save convective timescale (TIMEC) as 2D variable
6432         IF (KF_EDRATES == 1) THEN
6433            TIMEC_KF(I,J)=TIMEC
6434         ENDIF
6435
6436 !
6437 !...CLEAN THINGS UP, CALCULATE CONVECTIVE FEEDBACK TENDENCIES FOR THIS
6438 !...GRID POINT...
6439 !
6440 !     IF (XTIME.LT.10.)THEN
6441 !     WRITE(98,1080)LFS,LDB,LDT,TIMEC,TADVEC,NSTEP,NCOUNT,FABE,AINC
6442 !     ENDIF
6443        IF(IPRNT)THEN
6444 !         WRITE(98,1080)LFS,LDB,LDT,TIMEC,TADVEC,NSTEP,NCOUNT,FABE,AINC
6445          WRITE(message,1080)LFS,LDB,LDT,TIMEC,TADVEC,NSTEP,NCOUNT,FABE,AINC
6446          CALL wrf_message(message)
6447 !        flush(98)
6448        endif
6449 !
6450 !...SEND FINAL PARAMETERIZED VALUES TO OUTPUT FILES...
6451 !
6452 !297   IF(IPRNT)then
6453        IF(IPRNT)then
6454 !    if(I.eq.16 .and. J.eq.41)then
6455 !      IF(ISTOP.EQ.1)THEN
6456 !        write(98,*)
6457 !        write(98,*)'At t(h), I, J =',float(NTSD)*72./3600.,I,J
6458          write(message,*)'P(LC), DTP, WKL, WKLCL =',p0(LC)/100.,       &
6459                      TLCL+DTLCL+dtrh-TENV,WKL,WKLCL
6460          call wrf_message(message)
6461          write(message,*)'TLCL, DTLCL, DTRH, TENV =',TLCL,DTLCL,       &
6462                       DTRH,TENV
6463          call wrf_message(message)
6464          WRITE(message,1025)KLCL,ZLCL,DTLCL,LTOP,P0(LTOP),IFLAG,       &
6465          TMIX-T00,PMIX,QMIX,ABE
6466          call wrf_message(message)
6467          WRITE(message,1030)P0(LET)/100.,P0(LTOP)/100.,VMFLCL,PLCL/100.,  &
6468          WLCL,CLDHGT(LC)
6469          call wrf_message(message)
6470          WRITE(message,1035)PEF,PEFCBH,LC,LET,WKL,VWS
6471          call wrf_message(message)
6472          write(message,*)'PRECIP EFFICIENCY =',PEFF
6473          call wrf_message(message)
6474       WRITE(message,1080)LFS,LDB,LDT,TIMEC,TADVEC,NSTEP,NCOUNT,FABE,AINC
6475          call wrf_message(message)
6476 !      ENDIF
6477 !!!!! HERE !!!!!!!
6478            WRITE(message,1070)'  P  ','   DP ',' DT K/D ',' DR K/D ','   OMG  ',        &
6479           ' DOMGDP ','   UMF  ','   UER  ','   UDR  ','   DMF  ','   DER  '        &
6480           ,'   DDR  ','   EMS  ','    W0  ','  DETLQ ',' DETIC '
6481          call wrf_message(message)
6482            write(message,*)'just before DO 300...'
6483          call wrf_message(message)
6484 !          flush(98)
6485            DO NK=1,LTOP
6486              K=LTOP-NK+1
6487              DTT=(TG(K)-T0(K))*86400./TIMEC
6488              RL=XLV0-XLV1*TG(K)
6489              DR=-(QG(K)-Q0(K))*RL*86400./(TIMEC*CP)
6490              UDFRC=UDR(K)*TIMEC*EMSD(K)
6491              UEFRC=UER(K)*TIMEC*EMSD(K)
6492              DDFRC=DDR(K)*TIMEC*EMSD(K)
6493              DEFRC=-DER(K)*TIMEC*EMSD(K)
6494              WRITE(message,1075)P0(K)/100.,DP(K)/100.,DTT,DR,OMG(K),DOMGDP(K)*1.E4,       &
6495              UMF(K)/1.E6,UEFRC,UDFRC,DMF(K)/1.E6,DEFRC,DDFRC,EMS(K)/1.E11,           &
6496              W0AVG1D(K)*1.E2,DETLQ(K)*TIMEC*EMSD(K)*1.E3,DETIC(K)*                   &
6497              TIMEC*EMSD(K)*1.E3
6498          call wrf_message(message)
6499            ENDDO
6500            WRITE(message,1085)'K','P','Z','T0','TG','DT','TU','TD','Q0','QG',             &
6501                   'DQ','QU','QD','QLG','QIG','QRG','QSG','RH0','RHG'
6502          call wrf_message(message)
6503            DO NK=1,KL
6504              K=KX-NK+1
6505              DTT=TG(K)-T0(K)
6506              TUC=TU(K)-T00
6507              IF(K.LT.LC.OR.K.GT.LTOP)TUC=0.
6508              TDC=TZ(K)-T00
6509              IF((K.LT.LDB.OR.K.GT.LDT).AND.K.NE.LFS)TDC=0.
6510              IF(T0(K).LT.T00)THEN
6511                ES=ALIQ*EXP((BLIQ*TG(K)-CLIQ)/(TG(K)-DLIQ))
6512              ELSE
6513                ES=ALIQ*EXP((BLIQ*TG(K)-CLIQ)/(TG(K)-DLIQ))
6514              ENDIF
6515              QGS=ES*0.622/(P0(K)-ES)
6516              RH0=Q0(K)/QES(K)
6517              RHG=QG(K)/QGS
6518              WRITE(message,1090)K,P0(K)/100.,Z0(K),T0(K)-T00,TG(K)-T00,DTT,TUC,            &
6519              TDC,Q0(K)*1000.,QG(K)*1000.,(QG(K)-Q0(K))*1000.,QU(K)*                   &
6520              1000.,QD(K)*1000.,QLG(K)*1000.,QIG(K)*1000.,QRG(K)*1000.,                &
6521              QSG(K)*1000.,RH0,RHG
6522          call wrf_message(message)
6523            ENDDO
6524 !
6525 !...IF CALCULATIONS ABOVE SHOW AN ERROR IN THE MASS BUDGET, PRINT OUT A
6526 !...TO BE USED LATER FOR DIAGNOSTIC PURPOSES, THEN ABORT RUN...
6527 !
6528 !         IF(ISTOP.EQ.1 .or. ISHALL.EQ.1)THEN
6529
6530 !         IF(ISHALL.NE.1)THEN
6531 !            write(98,4421)i,j,iyr,imo,idy,ihr,imn
6532 !           write(98)i,j,iyr,imo,idy,ihr,imn,kl
6533 ! 4421       format(7i4)
6534 !            write(98,4422)kl
6535 ! 4422       format(i6)
6536             DO 310 NK = 1,KL
6537               k = kl - nk + 1
6538 !             write(98,4455) p0(k)/100.,t0(k)-273.16,q0(k)*1000.,       &
6539 !                      u0(k),v0(k),W0AVG1D(K),dp(k),tke(k)
6540 !             write(98) p0,t0,q0,u0,v0,w0,dp,tke
6541 !           WRITE(98,1115)Z0(K),P0(K)/100.,T0(K)-273.16,Q0(K)*1000.,
6542 !    *               U0(K),V0(K),DP(K)/100.,W0AVG(I,J,K)
6543  310        CONTINUE
6544             IF(ISTOP.EQ.1)THEN
6545               CALL wrf_error_fatal ( 'KAIN-FRITSCH, istop=1, diags' )
6546             ENDIF
6547 !         ENDIF
6548   4455  format(8f11.3)
6549        ENDIF
6550         CNDTNF=(1.-EQFRC(LFS))*(QLIQ(LFS)+QICE(LFS))*DMF(LFS)
6551         PRATEC(I,J)=PPTFLX*(1.-FBFRC)/DXSQ
6552         RAINCV(I,J)=DT*PRATEC(I,J)     !  PPT FB MODS
6553 !        RAINCV(I,J)=.1*.5*DT*PPTFLX/DXSQ               !  PPT FB MODS
6554 !         RNC=0.1*TIMEC*PPTFLX/DXSQ
6555         RNC=RAINCV(I,J)*NIC
6556 !       IF(ISHALL.EQ.0.AND.IPRNT)write (98,909)I,J,RNC
6557
6558 !     WRITE(98,1095)CPR*AINC,TDER+PPTFLX+CNDTNF
6559 !
6560 !  EVALUATE MOISTURE BUDGET...
6561 !
6562
6563         QINIT=0.
6564         QFNL=0.
6565         DPT=0.
6566         DO 315 NK=1,LTOP
6567           DPT=DPT+DP(NK)
6568           QINIT=QINIT+Q0(NK)*EMS(NK)
6569           QFNL=QFNL+QG(NK)*EMS(NK)
6570           QFNL=QFNL+(QLG(NK)+QIG(NK)+QRG(NK)+QSG(NK))*EMS(NK)
6571   315   CONTINUE
6572         QFNL=QFNL+PPTFLX*TIMEC*(1.-FBFRC)       !  PPT FB MODS
6573 !        QFNL=QFNL+PPTFLX*TIMEC                 !  PPT FB MODS
6574         ERR2=(QFNL-QINIT)*100./QINIT
6575 !       IF(IPRNT)WRITE(98,1110)QINIT,QFNL,ERR2
6576       IF(ABS(ERR2).GT.0.05 .AND. ISTOP.EQ.0)THEN
6577 !       write(99,*)'!!!!!!!! MOISTURE BUDGET ERROR IN KFPARA !!!'
6578 !       WRITE(99,1110)QINIT,QFNL,ERR2
6579         IPRNT=.FALSE.
6580         ISTOP=1
6581 !            write(98,4422)kl
6582  4422       format(i6)
6583             DO 311 NK = 1,KL
6584               k = kl - nk + 1
6585 !             write(99,4455) p0(k)/100.,t0(k)-273.16,q0(k)*1000.,       &
6586 !                      u0(k),v0(k),W0AVG1D(K),dp(k)
6587 !             write(98) p0,t0,q0,u0,v0,w0,dp,tke
6588 !           WRITE(98,1115)P0(K)/100.,T0(K)-273.16,Q0(K)*1000.,          &
6589 !                    U0(K),V0(K),W0AVG1D(K),dp(k)/100.,tke(k)
6590 !            WRITE(98,4456)P0(K)/100.,T0(K)-273.16,Q0(K)*1000.,          &
6591 !                     U0(K),V0(K),W0AVG1D(K),dp(k)/100.,tke(k)
6592  311        CONTINUE
6593 !           flush(98)
6594
6595 !        GOTO 297
6596 !         STOP 'QVERR'
6597       ENDIF
6598  1115 FORMAT (2X,F7.2,2X,F5.1,2X,F6.3,2(2X,F5.1),2X,F7.2,2X,F7.4)
6599  4456  format(8f12.3)
6600         IF(PPTFLX.GT.0.)THEN
6601           RELERR=ERR2*QINIT/(PPTFLX*TIMEC)
6602         ELSE
6603           RELERR=0.
6604         ENDIF
6605      IF(IPRNT)THEN
6606 !        WRITE(98,1120)RELERR
6607 !        WRITE(98,*)'TDER, CPR, TRPPT =',              &
6608 !          TDER,CPR*AINC,TRPPT*AINC
6609      ENDIF
6610 !
6611 !...FEEDBACK TO RESOLVABLE SCALE TENDENCIES.
6612 !
6613 !...IF THE ADVECTIVE TIME PERIOD (TADVEC) IS LESS THAN SPECIFIED MINIMUM
6614 !...TIMEC, ALLOW FEEDBACK TO OCCUR ONLY DURING TADVEC...
6615 !
6616         IF(TADVEC.LT.TIMEC)NIC=NINT(TADVEC/DT)
6617         NCA(I,J) = REAL(NIC)*DT
6618         IF(ISHALL.EQ.1)THEN
6619 !          TIMEC = 2400.
6620            NCA(I,J) = CUDT*60.
6621            NSHALL = NSHALL+1
6622         ENDIF
6623
6624         DO K=1,KX
6625 !         IF(IMOIST(INEST).NE.2)THEN
6626 !
6627 !...IF HYDROMETEORS ARE NOT ALLOWED, THEY MUST BE EVAPORATED OR SUBLIMATED
6628 !...AND FED BACK AS VAPOR, ALONG WITH ASSOCIATED CHANGES IN TEMPERATURE.
6629 !...NOTE:  THIS WILL INTRODUCE CHANGES IN THE CONVECTIVE TEMPERATURE AND
6630 !...WATER VAPOR FEEDBACK TENDENCIES AND MAY LEAD TO SUPERSATURATED VALUE
6631 !...OF QG...
6632 !
6633 !           RLC=XLV0-XLV1*TG(K)
6634 !           RLS=XLS0-XLS1*TG(K)
6635 !           CPM=CP*(1.+0.887*QG(K))
6636 !           TG(K)=TG(K)-(RLC*(QLG(K)+QRG(K))+RLS*(QIG(K)+QSG(K)))/CPM
6637 !           QG(K)=QG(K)+(QLG(K)+QRG(K)+QIG(K)+QSG(K))
6638 !           DQLDT(I,J,NK)=0.
6639 !           DQIDT(I,J,NK)=0.
6640 !           DQRDT(I,J,NK)=0.
6641 !           DQSDT(I,J,NK)=0.
6642 !         ELSE
6643 !
6644 !...IF ICE PHASE IS NOT ALLOWED, MELT ALL FROZEN HYDROMETEORS...
6645 !
6646           IF(warm_rain)THEN
6647
6648             CPM=CP*(1.+0.887*QG(K))
6649             TG(K)=TG(K)-(QIG(K)+QSG(K))*RLF/CPM
6650             DQCDT(K)=(QLG(K)+QIG(K)-QL0(K)-QI0(K))/TIMEC
6651             DQIDT(K)=0.
6652             DQRDT(K)=(QRG(K)+QSG(K)-QR0(K)-QS0(K))/TIMEC
6653             DQSDT(K)=0.
6654           ELSEIF(.NOT. F_QS)THEN
6655 !
6656 !...IF ICE PHASE IS ALLOWED, BUT MIXED PHASE IS NOT, MELT FROZEN HYDROMETEORS
6657 !...BELOW THE MELTING LEVEL, FREEZE LIQUID WATER ABOVE THE MELTING LEVEL
6658 !
6659             CPM=CP*(1.+0.887*QG(K))
6660             IF(K.LE.ML)THEN
6661               TG(K)=TG(K)-(QIG(K)+QSG(K))*RLF/CPM
6662             ELSEIF(K.GT.ML)THEN
6663               TG(K)=TG(K)+(QLG(K)+QRG(K))*RLF/CPM
6664             ENDIF
6665             DQCDT(K)=(QLG(K)+QIG(K)-QL0(K)-QI0(K))/TIMEC
6666             DQIDT(K)=0.
6667             DQRDT(K)=(QRG(K)+QSG(K)-QR0(K)-QS0(K))/TIMEC
6668             DQSDT(K)=0.
6669           ELSEIF(F_QS) THEN
6670 !
6671 !...IF MIXED PHASE HYDROMETEORS ARE ALLOWED, FEED BACK CONVECTIVE TENDENCIES
6672 !...OF HYDROMETEORS DIRECTLY...
6673 !
6674             DQCDT(K)=(QLG(K)-QL0(K))/TIMEC
6675             DQSDT(K)=(QSG(K)-QS0(K))/TIMEC
6676             DQRDT(K)=(QRG(K)-QR0(K))/TIMEC
6677             IF (F_QI) THEN
6678                DQIDT(K)=(QIG(K)-QI0(K))/TIMEC
6679             ELSE
6680                DQSDT(K)=DQSDT(K)+(QIG(K)-QI0(K))/TIMEC
6681             ENDIF
6682           ELSE
6683 !              PRINT *,'THIS COMBINATION OF IMOIST, IEXICE, IICE NOT ALLOWED!'
6684               CALL wrf_error_fatal ( 'KAIN-FRITSCH, THIS MICROPHYSICS CHOICE IS NOT ALLOWED' )
6685           ENDIF
6686           DTDT(K)=(TG(K)-T0(K))/TIMEC
6687           DQDT(K)=(QG(K)-Q0(K))/TIMEC
6688         ENDDO
6689
6690 !JTR Begin CMT
6691         IF(cmt_opt_flag) THEN
6692
6693               DO KQ=KTS,KTE
6694                  JK = KTE-KQ+1
6695                  DPconvF(1,JK)=0.0
6696                  DERconvF(1,JK)=0.0
6697                  UERconvF(1,JK)=0.0
6698                  MC(1,JK)=0.0
6699                  UMFconvF(1,JK)=0.0
6700                  PRU(1,JK)=0.0
6701                  QDN(1,JK)=0.0
6702                  QUP(1,JK)=0.0
6703                  QHAT(1,JK)=0.0
6704                  SDD(1,JK)=0.0
6705                  SUU(1,JK)=0.0
6706                  SHAT(1,JK)=0.0
6707                  TEE(1,JK)=0.0
6708                  U0F(1,JK)=0.0
6709                  V0F(1,JK)=0.0
6710                  Z0F(1,JK)=0.0
6711                  ZFU(1,JK)=0.0
6712               END DO
6713
6714               zf_wrf(0) = 0.0  ! ground
6715               grav = 9.8
6716               cpin = CP
6717               Rdry = R
6718               Zfu(1,KTE+1) = 0.0
6719                  DTnew = DT
6720                  DSUBCLD(1) = ZLCL
6721                  VMFLCLconv(1) = ((VMFLCL/DXSQ)*G)/100.
6722                  IL1G = 1
6723                  IL2G = 1
6724                  ILG = 1
6725                  MSG1 = 0
6726 !ckay
6727                  JBB(1) = KTE-KLCL+1  ! updraft base level   =====>>> flipped for CAM5 indexing
6728                  JDD(1) = KTE-LFS+1
6729                  JTT(1) = KTE-LTOP+1
6730 !ckay
6731                   if(JDD(1).LT.JTT(1).or.JDD(1).GT.JBB(1)) then
6732                       JDD(1)=JBB(1)-1  ! for cases no downdraft
6733                    end if
6734                   if(jtt(1).gt.jbb(1))  then
6735                    JTT(1) = JBB(1)
6736                   end if
6737
6738 !JTR Begin CMT Variable Prep
6739 ! CKAY fill in grid-scale values for below cloud and above cloud portions
6740 ! Ckay and then fill in-cloud updraft and downdraft properties
6741                DO KQ=KTS,KTE
6742                  TDN(KQ) = T0(KQ)
6743                  TUP(KQ) = T0(KQ)
6744                end do
6745
6746
6747                !JTRnew: Added conditionals in case up/downdraft temps are 0.0
6748                DO KQ= KLCL,LTOP
6749                  if(TZ(KQ).NE.0.0) then
6750                         TDN(KQ) = TZ(KQ)
6751                  endif
6752                  if(TU(KQ).NE.0.0) then
6753                         TUP(KQ) = TU(KQ)
6754                  endif
6755                end do
6756
6757                !JTRnew: Pulled this out of the main loop so the entire column
6758                !gets defined before use in the main loop
6759                DO KQ=KTS,KTE
6760                   zf_wrf(KQ) = zf_wrf(KQ-1)+DZQ(KQ)
6761                   stat_energy(KQ) = CP*(T0(KQ)*(1.0+0.622*Q0(KQ))) + G*Zf_wrf(KQ)
6762                ENDDO
6763
6764                DO KQ=KTS,KTE
6765                  JK = KTE-KQ+1
6766                  DUDTnew(1,JK) = 0.0
6767                  DVDTnew(1,JK) = 0.0
6768                  DPDX(1,JK) = 0.0
6769                  DPDY(1,JK) = 0.0
6770
6771                  zf_wrf(KQ) = zf_wrf(KQ-1)+DZQ(KQ)
6772                  zfu(1,JK) = zf_wrf(KQ)
6773
6774                  IF(KQ.EQ.KTE) THEN
6775                      qhat(1,JK) = Q0(KQ)
6776                      shat(1,JK) = stat_energy(KQ)
6777                  ELSE
6778                      qhat(1,JK) = 0.5*(Q0(KQ)/(1.+Q0(KQ)) + Q0(KQ+1)/(1.+Q0(KQ+1)))
6779                      shat(1,JK) = 0.5*(stat_energy(KQ) + stat_energy(KQ+1))
6780                  ENDIF
6781
6782 !ckay fill in clear and cloudy layers properly
6783                IF(KQ.LT.KLCL .OR. KQ.GT.LTOP) then  ! subcloud layer or above-cloud layer
6784                    QUP(1,JK) = Q0(KQ)/(1.+Q0(KQ))
6785                    QDN(1,JK) = Q0(KQ)/(1.+Q0(KQ))
6786                    SUU(1,JK) = CP*(T0(KQ)*(1.0+0.622*Q0(KQ))) + G*Zf_wrf(KQ)
6787                    SDD(1,JK) = CP*(T0(KQ)*(1.0+0.622*Q0(KQ))) + G*Zf_wrf(KQ)
6788                Else
6789                  QUP(1,JK) = QU(KQ)/(1.+QU(KQ))
6790                  QDN(1,JK) = QD(KQ)/(1.+QD(KQ))
6791
6792                  !JTRnew: Replaced TU and TZ with TUP and TDN
6793                  !Ckay replaced Qu and Qd with QUP & QDN
6794                  SUU(1,JK) = CP*(TUP(KQ)*(1.0+0.622*QUP(1,JK))) + G*Zf_wrf(KQ)
6795                  SDD(1,JK) = CP*(TDN(KQ)*(1.0+0.622*QDN(1,JK))) + G*Zf_wrf(KQ)
6796                End if ! for subcloud and above-cloud layers
6797                  DERconvF(1,JK) = (((DER(KQ)/DXSQ)*G)/100.)/DZQ(KQ)
6798                  UERconvF(1,JK) = (((UER(KQ)/DXSQ)*G)/100.)/DZQ(KQ)
6799                  DMFconvF(1,JK) = ((DMF(KQ)/DXSQ)*G)/100.
6800                  !JTR Updraft mass flux from kg/s to hpa/s
6801                  UMFconvF(1,JK) = ((UMF(KQ)/DXSQ)*G)/100.
6802                  MC(1,JK) = DMFconvF(1,JK) + UMFconvF(1,JK)
6803                  DPconvF(1,JK) = DP(KQ)/100.
6804                  PRU(1,JK) = P0(KQ)/100.0    ! in millibars or hPa
6805                  U0F(1,JK) = U0(KQ)
6806                  V0F(1,JK) = V0(KQ)
6807                  Z0F(1,JK) = Z0(KQ)
6808                  TEE(1,JK) = T0(KQ)
6809                END DO ! for k loop
6810
6811 !JTR End CMT Variable Prep
6812               if(CMTprint) then
6813                 print *,'DP',minval(DPconvF),maxval(DPconvF)
6814                 print *,'DER',minval(DERconvF),maxval(DERconvF)
6815                 print *,'UER',minval(UERconvF),maxval(UERconvF)
6816                 print *,'MC',minval(MC),maxval(MC)
6817                 print *,'DMF',minval(DMFconvF),maxval(DMFconvF)
6818                 print *,'UMF',minval(UMFconvF),maxval(UMFconvF)
6819                 print *,'VMFLCL',VMFLCLconv(ILG)
6820                 print *,'PRU',minval(PRU),maxval(PRU)
6821                 print *,'QDD',maxval(QDn)
6822                 print *,'QUU',minval(QUp),maxval(QUp)
6823                 print *,'QHAT',minval(QHAT),maxval(QHAT)
6824                 print *,'SDD',minval(SDD),maxval(SDD)
6825                 print *,'SUU',minval(SUU),maxval(SUU)
6826                 print *,'SHAT',minval(SHAT),maxval(SHAT)
6827                 print *,'TEE',minval(TEE),maxval(TEE)
6828                 print *,'U0F',minval(U0F),maxval(U0F)
6829                 print *,'V0F',minval(V0F),maxval(V0F)
6830                 print *,'Z0F',minval(Z0F),maxval(Z0F)
6831                 print *,'ZFU',minval(ZFU),maxval(ZFU)
6832                 print *,'DSUBCLD',DSUBCLD(ILG)
6833                 print *,'JBB',JBB(ILG)
6834                 print *,'JDD',JDD(ILG)
6835                 print *,'JTT',JTT(ILG)
6836                 print *,'msg1',msg1
6837                 print *,'DT',DTnew
6838                 print *,'grav',grav
6839                 print *,'cpin',CPIN
6840                 print *,'rdry',Rdry
6841                 print *,'KTE',KTE
6842                 print *,'IL1G',IL1G
6843                 print *,'IL2G',IL2G
6844                 print *,'ILG',ILG
6845               end if ! CMTpring
6846
6847                 CALL MSKF_CMT(DUDTnew,DVDTnew,dpdx,dpdy,     &
6848                        DPconvF,DERconvF,UERconvF,          &
6849                        MC,DMFconvF,                        &
6850                        UMFconvF,VMFLCLconv,PRU,       &
6851                        QDN,QUP,QHAT,SDD,SUU,SHAT,TEE,U0F,  &
6852                        V0F,Z0F,ZFU,DSUBCLD,JBB,  &
6853                        JDD,JTT,msg1,DTnew,       &
6854                        grav,CPIN,Rdry,KTE,IL1G,IL2G,ILG)
6855            !Invert tendency arrays
6856            DO KQ=kts,kte
6857               JK = KTE-KQ+1
6858               DUDT(KQ) =  DUDTnew(1,JK)
6859               DVDT(KQ) =  DVDTnew(1,JK)
6860            ENDDO
6861
6862               if(CMTprint) then
6863            print *,'max/min dudt=',maxval(DUDT), minval(DUDT)
6864            print *,'max/min dVdt=',maxval(DVDT), minval(DVDT)
6865               end if ! for CMTprint
6866         ENDIF  ! for cmt flag
6867 !JTR End CMT
6868
6869         PRATEC(I,J)=PPTFLX*(1.-FBFRC)/DXSQ
6870         RAINCV(I,J)=DT*PRATEC(I,J)
6871 !        RAINCV(I,J)=.1*.5*DT*PPTFLX/DXSQ               !  PPT FB MODS
6872 !         RNC=0.1*TIMEC*PPTFLX/DXSQ
6873         RNC=RAINCV(I,J)*NIC
6874  909     FORMAT('AT I, J =',i3,1x,i3,' CONVECTIVE RAINFALL =',F8.4,' mm')
6875 !      write (98,909)I,J,RNC
6876 !      write (6,909)I,J,RNC
6877 !      WRITE(98,*)'at NTSD =',NTSD,',No. of KF points activated =',
6878 !     *            NCCNT
6879 !      flush(98)
6880 1000  FORMAT(' ',10A8)
6881 1005  FORMAT(' ',F6.0,2X,F6.4,2X,F7.3,1X,F6.4,2X,4(F6.3,2X),2(F7.3,1X))
6882 1010  FORMAT(' ',' VERTICAL VELOCITY IS NEGATIVE AT ',F4.0,' MB')
6883 1015   FORMAT(' ','ALL REMAINING MASS DETRAINS BELOW ',F4.0,' MB')
6884 1025   FORMAT(5X,' KLCL=',I2,' ZLCL=',F7.1,'M',                         &
6885         ' DTLCL=',F5.2,' LTOP=',I2,' P0(LTOP)=',-2PF5.1,'MB FRZ LV=',   &
6886         I2,' TMIX=',0PF4.1,1X,'PMIX=',-2PF6.1,' QMIX=',3PF5.1,          &
6887         ' CAPE=',0PF7.1)
6888 1030   FORMAT(' ',' P0(LET) = ',F6.1,' P0(LTOP) = ',F6.1,' VMFLCL =',   &
6889       E12.3,' PLCL =',F6.1,' WLCL =',F6.3,' CLDHGT =',                  &
6890       F8.1)
6891 1035  FORMAT(1X,'PEF(WS)=',F4.2,'(CB)=',F4.2,'LC,LET=',2I3,'WKL='       &
6892       ,F6.3,'VWS=',F5.2)
6893 !1055  FORMAT('*** DEGREE OF STABILIZATION =',F5.3,                  &
6894 !      ', NO MORE MASS FLUX IS ALLOWED!')
6895 !1060     FORMAT(' ITERATION DOES NOT CONVERGE TO GIVE THE SPECIFIED    &
6896 !      &DEGREE OF STABILIZATION!  FABE= ',F6.4)
6897  1070 FORMAT (16A8)
6898  1075 FORMAT (F8.2,3(F8.2),2(F8.3),F8.2,2F8.3,F8.2,6F8.3)
6899  1080 FORMAT(2X,'LFS,LDB,LDT =',3I3,' TIMEC, TADVEC, NSTEP=',           &
6900               2(1X,F5.0),I3,'NCOUNT, FABE, AINC=',I2,1X,F5.3,F6.2)
6901  1085 FORMAT (A3,16A7,2A8)
6902  1090 FORMAT (I3,F7.2,F7.0,10F7.2,4F7.3,2F8.3)
6903  1095 FORMAT(' ','  PPT PRODUCTION RATE= ',F10.0,' TOTAL EVAP+PPT= ',F10.0)
6904 1105   FORMAT(' ','NET LATENT HEAT RELEASE =',E12.5,' ACTUAL HEATING =',&
6905        E12.5,' J/KG-S, DIFFERENCE = ',F9.3,'%')
6906 1110   FORMAT(' ','INITIAL WATER =',E12.5,' FINAL WATER =',E12.5,       &
6907        ' TOTAL WATER CHANGE =',F8.2,'%')
6908 ! 1115 FORMAT (2X,F6.0,2X,F7.2,2X,F5.1,2X,F6.3,2(2X,F5.1),2X,F7.2,2X,F7.4)
6909 1120   FORMAT(' ','MOISTURE ERROR AS FUNCTION OF TOTAL PPT =',F9.3,'%')
6910 !
6911 !-----------------------------------------------------------------------
6912 !--------------SAVE CLOUD TOP AND BOTTOM FOR RADIATION------------------
6913 !-----------------------------------------------------------------------
6914 !
6915       CUTOP(I,J)=REAL(LTOP)
6916       CUBOT(I,J)=REAL(LCL)
6917 !
6918 !-----------------------------------------------------------------------
6919    END SUBROUTINE  MSKF_eta_PARA
6920 !********************************************************************
6921 ! ***********************************************************************
6922 !dkay
6923 !dkay: added QSu as output to get saturated Q of updraft
6924
6925    SUBROUTINE TPMIX2(p,thes,tu,qu,qliq,qice,qnewlq,qnewic,XLV1,XLV0,Qsu)
6926 !
6927 ! Lookup table variables:
6928 !     INTEGER, PARAMETER :: (KFNT=250,KFNP=220)
6929 !     REAL, SAVE, DIMENSION(1:KFNT,1:KFNP) :: TTAB,QSTAB
6930 !     REAL, SAVE, DIMENSION(1:KFNP) :: THE0K
6931 !     REAL, SAVE, DIMENSION(1:200) :: ALU
6932 !     REAL, SAVE :: RDPR,RDTHK,PLUTOP
6933 ! End of Lookup table variables:
6934 !-----------------------------------------------------------------------
6935    IMPLICIT NONE
6936 !  SAVE !TWG 2017 add to avoid memory issues
6937 !-----------------------------------------------------------------------
6938    REAL,         INTENT(IN   )   :: P,THES,XLV1,XLV0
6939    REAL,         INTENT(OUT  )   :: QNEWLQ,QNEWIC,QSu
6940    REAL,         INTENT(INOUT)   :: TU,QU,QLIQ,QICE
6941    REAL    ::    TP,QQ,BTH,TTH,PP,T00,T10,T01,T11,Q00,Q10,Q01,Q11,          &
6942                  TEMP,QS,QNEW,DQ,QTOT,RLL,CPP
6943    INTEGER ::    IPTB,ITHTB
6944 !-----------------------------------------------------------------------
6945
6946 !c******** LOOKUP TABLE VARIABLES... ****************************
6947 !      parameter(kfnt=250,kfnp=220)
6948 !c
6949 !      COMMON/KFLUT/ ttab(kfnt,kfnp),qstab(kfnt,kfnp),the0k(kfnp),
6950 !     *              alu(200),rdpr,rdthk,plutop
6951 !C***************************************************************
6952 !c
6953 !c***********************************************************************
6954 !c     scaling pressure and tt table index
6955 !c***********************************************************************
6956 !c
6957       tp=(p-plutop)*rdpr
6958       qq=tp-aint(tp)
6959       iptb=int(tp)+1
6960
6961 !
6962 !***********************************************************************
6963 !              base and scaling factor for the
6964 !***********************************************************************
6965 !
6966 !  scaling the and tt table index
6967       bth=(the0k(iptb+1)-the0k(iptb))*qq+the0k(iptb)
6968       tth=(thes-bth)*rdthk
6969       pp   =tth-aint(tth)
6970       ithtb=int(tth)+1
6971        IF(IPTB.GE.220 .OR. IPTB.LE.1 .OR. ITHTB.GE.250 .OR. ITHTB.LE.1)THEN
6972 !         write(98,*)'**** OUT OF BOUNDS *********'
6973 !        flush(98)
6974        ENDIF
6975 !
6976       t00=ttab(ithtb  ,iptb  )
6977       t10=ttab(ithtb+1,iptb  )
6978       t01=ttab(ithtb  ,iptb+1)
6979       t11=ttab(ithtb+1,iptb+1)
6980 !
6981       q00=qstab(ithtb  ,iptb  )
6982       q10=qstab(ithtb+1,iptb  )
6983       q01=qstab(ithtb  ,iptb+1)
6984       q11=qstab(ithtb+1,iptb+1)
6985 !
6986 !***********************************************************************
6987 !              parcel temperature
6988 !***********************************************************************
6989 !
6990       temp=(t00+(t10-t00)*pp+(t01-t00)*qq+(t00-t10-t01+t11)*pp*qq)
6991 !
6992       qs=(q00+(q10-q00)*pp+(q01-q00)*qq+(q00-q10-q01+q11)*pp*qq)
6993
6994 !dkay
6995        QSu = qs
6996 !
6997
6998 !
6999       DQ=QS-QU
7000       IF(DQ.LE.0.)THEN
7001         QNEW=QU-QS
7002         QU=QS
7003       ELSE
7004 !
7005 !   IF THE PARCEL IS SUBSATURATED, TEMPERATURE AND MIXING RATIO MUST BE
7006 !   ADJUSTED...IF LIQUID WATER IS PRESENT, IT IS ALLOWED TO EVAPORATE
7007 !
7008         QNEW=0.
7009         QTOT=QLIQ+QICE
7010 !
7011 !   IF THERE IS ENOUGH LIQUID OR ICE TO SATURATE THE PARCEL, TEMP STAYS AT ITS
7012 !   WET BULB VALUE, VAPOR MIXING RATIO IS AT SATURATED LEVEL, AND THE MIXING
7013 !   RATIOS OF LIQUID AND ICE ARE ADJUSTED TO MAKE UP THE ORIGINAL SATURATION
7014 !   DEFICIT... OTHERWISE, ANY AVAILABLE LIQ OR ICE VAPORIZES AND APPROPRIATE
7015 !   ADJUSTMENTS TO PARCEL TEMP; VAPOR, LIQUID, AND ICE MIXING RATIOS ARE MADE.
7016 !
7017 !...subsaturated values only occur in calculations involving various mixtures of
7018 !...updraft and environmental air for estimation of entrainment and detrainment.
7019 !...For these purposes, assume that reasonable estimates can be given using
7020 !...liquid water saturation calculations only - i.e., ignore the effect of the
7021 !...ice phase in this process only...will not affect conservative properties...
7022 !
7023         IF(QTOT.GE.DQ)THEN
7024           qliq=qliq-dq*qliq/(qtot+1.e-10)
7025           qice=qice-dq*qice/(qtot+1.e-10)
7026           QU=QS
7027         ELSE
7028           RLL=XLV0-XLV1*TEMP
7029           CPP=1004.5*(1.+0.89*QU)
7030           IF(QTOT.LT.1.E-10)THEN
7031 !
7032 !...IF NO LIQUID WATER OR ICE IS AVAILABLE, TEMPERATURE IS GIVEN BY:
7033             TEMP=TEMP+RLL*(DQ/(1.+DQ))/CPP
7034           ELSE
7035 !
7036 !...IF SOME LIQ WATER/ICE IS AVAILABLE, BUT NOT ENOUGH TO ACHIEVE SATURATION,
7037 !   THE TEMPERATURE IS GIVEN BY:
7038 !
7039             TEMP=TEMP+RLL*((DQ-QTOT)/(1+DQ-QTOT))/CPP
7040             QU=QU+QTOT
7041             QTOT=0.
7042             QLIQ=0.
7043             QICE=0.
7044           ENDIF
7045         ENDIF
7046       ENDIF
7047       TU=TEMP
7048       qnewlq=qnew
7049       qnewic=0.
7050 !
7051    END SUBROUTINE TPMIX2
7052 !******************************************************************************
7053       SUBROUTINE DTFRZNEW(TU,P,THTEU,QU,QFRZ,QICE,ALIQ,BLIQ,CLIQ,DLIQ)
7054 !-----------------------------------------------------------------------
7055    IMPLICIT NONE
7056 !  SAVE !TWG 2017 Add to avoid memory issues
7057 !-----------------------------------------------------------------------
7058    REAL,         INTENT(IN   )   :: P,QFRZ,ALIQ,BLIQ,CLIQ,DLIQ
7059    REAL,         INTENT(INOUT)   :: TU,THTEU,QU,QICE
7060    REAL    ::    RLC,RLS,RLF,CPP,A,DTFRZ,ES,QS,DQEVAP,PII
7061 !-----------------------------------------------------------------------
7062 !
7063 !...ALLOW THE FREEZING OF LIQUID WATER IN THE UPDRAFT TO PROCEED AS AN
7064 !...APPROXIMATELY LINEAR FUNCTION OF TEMPERATURE IN THE TEMPERATURE RANGE
7065 !...TTFRZ TO TBFRZ...
7066 !...FOR COLDER TEMPERATURES, FREEZE ALL LIQUID WATER...
7067 !...THERMODYNAMIC PROPERTIES ARE STILL CALCULATED WITH RESPECT TO LIQUID WATER
7068 !...TO ALLOW THE USE OF LOOKUP TABLE TO EXTRACT TMP FROM THETAE...
7069 !
7070       RLC=2.5E6-2369.276*(TU-273.16)
7071       RLS=2833922.-259.532*(TU-273.16)
7072       RLF=RLS-RLC
7073       CPP=1004.5*(1.+0.89*QU)
7074 !
7075 !  A = D(es)/DT IS THAT CALCULATED FROM BUCK (1981) EMPERICAL FORMULAS
7076 !  FOR SATURATION VAPOR PRESSURE...
7077 !
7078       A=(CLIQ-BLIQ*DLIQ)/((TU-DLIQ)*(TU-DLIQ))
7079       DTFRZ = RLF*QFRZ/(CPP+RLS*QU*A)
7080       TU = TU+DTFRZ
7081
7082       ES = ALIQ*EXP((BLIQ*TU-CLIQ)/(TU-DLIQ))
7083       QS = ES*0.622/(P-ES)
7084 !
7085 !...FREEZING WARMS THE AIR AND IT BECOMES UNSATURATED...ASSUME THAT SOME OF THE
7086 !...LIQUID WATER THAT IS AVAILABLE FOR FREEZING EVAPORATES TO MAINTAIN SATURA-
7087 !...TION...SINCE THIS WATER HAS ALREADY BEEN TRANSFERRED TO THE ICE CATEGORY,
7088 !...SUBTRACT IT FROM ICE CONCENTRATION, THEN SET UPDRAFT MIXING RATIO AT THE NEW
7089 !...TEMPERATURE TO THE SATURATION VALUE...
7090 !
7091       DQEVAP = QS-QU
7092       QICE = QICE-DQEVAP
7093       QU = QU+DQEVAP
7094       PII=(1.E5/P)**(0.2854*(1.-0.28*QU))
7095       THTEU=TU*PII*EXP((3374.6525/TU-2.5403)*QU*(1.+0.81*QU))
7096 !
7097    END SUBROUTINE DTFRZNEW
7098 ! --------------------------------------------------------------------------------
7099
7100       SUBROUTINE CONDLOAD(QLIQ,QICE,WTW,DZ,BOTERM,ENTERM,RATE,QNEWLQ,           &
7101                           QNEWIC,QLQOUT,QICOUT,G)
7102
7103 !-----------------------------------------------------------------------
7104    IMPLICIT NONE
7105 !  SAVE !TWG 2017 add to avoid memory issues
7106 !-----------------------------------------------------------------------
7107 !  9/18/88...THIS PRECIPITATION FALLOUT SCHEME IS BASED ON THE SCHEME US
7108 !  BY OGURA AND CHO (1973).  LIQUID WATER FALLOUT FROM A PARCEL IS CAL-
7109 !  CULATED USING THE EQUATION DQ=-RATE*Q*DT, BUT TO SIMULATE A QUASI-
7110 !  CONTINUOUS PROCESS, AND TO ELIMINATE A DEPENDENCY ON VERTICAL
7111 !  RESOLUTION THIS IS EXPRESSED AS Q=Q*EXP(-RATE*DZ).
7112
7113       REAL, INTENT(IN   )   :: G
7114       REAL, INTENT(IN   )   :: DZ,BOTERM,ENTERM,RATE
7115       REAL, INTENT(INOUT)   :: QLQOUT,QICOUT,WTW,QLIQ,QICE,QNEWLQ,QNEWIC
7116       REAL :: QTOT,QNEW,QEST,G1,WAVG,CONV,RATIO3,OLDQ,RATIO4,DQ,PPTDRG
7117 !
7118       QTOT=QLIQ+QICE
7119       QNEW=QNEWLQ+QNEWIC
7120 !
7121 !  ESTIMATE THE VERTICAL VELOCITY SO THAT AN AVERAGE VERTICAL VELOCITY
7122 !  BE CALCULATED TO ESTIMATE THE TIME REQUIRED FOR ASCENT BETWEEN MODEL
7123 !  LEVELS...
7124 !
7125       QEST=0.5*(QTOT+QNEW)
7126       G1=WTW+BOTERM-ENTERM-2.*G*DZ*QEST/1.5
7127       IF(G1.LT.0.0)G1=0.
7128       WAVG=0.5*(SQRT(WTW)+SQRT(G1))
7129       CONV=RATE*DZ/WAVG               ! KF90  Eq. 9
7130 !
7131 !  RATIO3 IS THE FRACTION OF LIQUID WATER IN FRESH CONDENSATE, RATIO4 IS
7132 !  THE FRACTION OF LIQUID WATER IN THE TOTAL AMOUNT OF CONDENSATE INVOLV
7133 !  IN THE PRECIPITATION PROCESS - NOTE THAT ONLY 60% OF THE FRESH CONDEN
7134 !  SATE IS IS ALLOWED TO PARTICIPATE IN THE CONVERSION PROCESS...
7135 !
7136       RATIO3=QNEWLQ/(QNEW+1.E-8)
7137 !     OLDQ=QTOT
7138       QTOT=QTOT+0.6*QNEW
7139       OLDQ=QTOT
7140       RATIO4=(0.6*QNEWLQ+QLIQ)/(QTOT+1.E-8)
7141       QTOT=QTOT*EXP(-CONV)            ! KF90  Eq. 9
7142 !
7143 !  DETERMINE THE AMOUNT OF PRECIPITATION THAT FALLS OUT OF THE UPDRAFT
7144 !  PARCEL AT THIS LEVEL...
7145 !
7146       DQ=OLDQ-QTOT
7147       QLQOUT=RATIO4*DQ
7148       QICOUT=(1.-RATIO4)*DQ
7149 !
7150 !  ESTIMATE THE MEAN LOAD OF CONDENSATE ON THE UPDRAFT IN THE LAYER, CAL
7151 !  LATE VERTICAL VELOCITY
7152 !
7153       PPTDRG=0.5*(OLDQ+QTOT-0.2*QNEW)
7154       WTW=WTW+BOTERM-ENTERM-2.*G*DZ*PPTDRG/1.5
7155       IF(ABS(WTW).LT.1.E-4)WTW=1.E-4
7156 !
7157 !  DETERMINE THE NEW LIQUID WATER AND ICE CONCENTRATIONS INCLUDING LOSSE
7158 !  DUE TO PRECIPITATION AND GAINS FROM CONDENSATION...
7159 !
7160       QLIQ=RATIO4*QTOT+RATIO3*0.4*QNEW
7161       QICE=(1.-RATIO4)*QTOT+(1.-RATIO3)*0.4*QNEW
7162       QNEWLQ=0.
7163       QNEWIC=0.
7164
7165    END SUBROUTINE CONDLOAD
7166
7167 ! ----------------------------------------------------------------------
7168    SUBROUTINE PROF5(EQ,EE,UD)
7169 !
7170 !***********************************************************************
7171 !*****    GAUSSIAN TYPE MIXING PROFILE....******************************
7172 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7173 !  THIS SUBROUTINE INTEGRATES THE AREA UNDER THE CURVE IN THE GAUSSIAN
7174 !  DISTRIBUTION...THE NUMERICAL APPROXIMATION TO THE INTEGRAL IS TAKEN FROM
7175 !  "HANDBOOK OF MATHEMATICAL FUNCTIONS WITH FORMULAS, GRAPHS AND MATHEMATICS TABLES"
7176 !  ED. BY ABRAMOWITZ AND STEGUN, NATL BUREAU OF STANDARDS APPLIED
7177 !  MATHEMATICS SERIES.  JUNE, 1964., MAY, 1968.
7178 !                                     JACK KAIN
7179 !                                     7/6/89
7180 !  Solves for KF90 Eq. 2
7181 !
7182 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7183 !-----------------------------------------------------------------------
7184    IMPLICIT NONE
7185 !  SAVE !TWG 2017 add to avoid memory issues
7186 !-----------------------------------------------------------------------
7187    REAL,         INTENT(IN   )   :: EQ
7188    REAL,         INTENT(INOUT)   :: EE,UD
7189    REAL ::       SQRT2P,A1,A2,A3,P,SIGMA,FE,X,Y,EY,E45,T1,T2,C1,C2
7190
7191       DATA SQRT2P,A1,A2,A3,P,SIGMA,FE/2.506628,0.4361836,-0.1201676,       &
7192            0.9372980,0.33267,0.166666667,0.202765151/
7193       X=(EQ-0.5)/SIGMA
7194       Y=6.*EQ-3.
7195       EY=EXP(Y*Y/(-2))
7196       E45=EXP(-4.5)
7197       T2=1./(1.+P*ABS(Y))
7198       T1=0.500498
7199       C1=A1*T1+A2*T1*T1+A3*T1*T1*T1
7200       C2=A1*T2+A2*T2*T2+A3*T2*T2*T2
7201       IF(Y.GE.0.)THEN
7202         EE=SIGMA*(0.5*(SQRT2P-E45*C1-EY*C2)+SIGMA*(E45-EY))-E45*EQ*EQ/2.
7203         UD=SIGMA*(0.5*(EY*C2-E45*C1)+SIGMA*(E45-EY))-E45*(0.5+EQ*EQ/2.-    &
7204            EQ)
7205       ELSE
7206         EE=SIGMA*(0.5*(EY*C2-E45*C1)+SIGMA*(E45-EY))-E45*EQ*EQ/2.
7207         UD=SIGMA*(0.5*(SQRT2P-E45*C1-EY*C2)+SIGMA*(E45-EY))-E45*(0.5+EQ*   &
7208            EQ/2.-EQ)
7209       ENDIF
7210       EE=EE/FE
7211       UD=UD/FE
7212
7213    END SUBROUTINE PROF5
7214
7215 ! ------------------------------------------------------------------------
7216    SUBROUTINE TPMIX2DD(p,thes,ts,qs,i,j)
7217 !
7218 ! Lookup table variables:
7219 !     INTEGER, PARAMETER :: (KFNT=250,KFNP=220)
7220 !     REAL, SAVE, DIMENSION(1:KFNT,1:KFNP) :: TTAB,QSTAB
7221 !     REAL, SAVE, DIMENSION(1:KFNP) :: THE0K
7222 !     REAL, SAVE, DIMENSION(1:200) :: ALU
7223 !     REAL, SAVE :: RDPR,RDTHK,PLUTOP
7224 ! End of Lookup table variables:
7225 !-----------------------------------------------------------------------
7226    IMPLICIT NONE
7227 !  SAVE !TWG 2017 add to avoid memory issues
7228 !-----------------------------------------------------------------------
7229    REAL,         INTENT(IN   )   :: P,THES
7230    REAL,         INTENT(INOUT)   :: TS,QS
7231    INTEGER,      INTENT(IN   )   :: i,j     ! avail for debugging
7232    REAL    ::    TP,QQ,BTH,TTH,PP,T00,T10,T01,T11,Q00,Q10,Q01,Q11
7233    INTEGER ::    IPTB,ITHTB
7234    CHARACTER*256 :: MESS
7235 !-----------------------------------------------------------------------
7236
7237 !
7238 !******** LOOKUP TABLE VARIABLES (F77 format)... ****************************
7239 !     parameter(kfnt=250,kfnp=220)
7240 !
7241 !     COMMON/KFLUT/ ttab(kfnt,kfnp),qstab(kfnt,kfnp),the0k(kfnp),        &
7242 !                   alu(200),rdpr,rdthk,plutop
7243 !***************************************************************
7244 !
7245 !***********************************************************************
7246 !     scaling pressure and tt table index
7247 !***********************************************************************
7248 !
7249       tp=(p-plutop)*rdpr
7250       qq=tp-aint(tp)
7251       iptb=int(tp)+1
7252 !
7253 !***********************************************************************
7254 !              base and scaling factor for the
7255 !***********************************************************************
7256 !
7257 !  scaling the and tt table index
7258       bth=(the0k(iptb+1)-the0k(iptb))*qq+the0k(iptb)
7259       tth=(thes-bth)*rdthk
7260       pp   =tth-aint(tth)
7261       ithtb=int(tth)+1
7262 !
7263       t00=ttab(ithtb  ,iptb  )
7264       t10=ttab(ithtb+1,iptb  )
7265       t01=ttab(ithtb  ,iptb+1)
7266       t11=ttab(ithtb+1,iptb+1)
7267 !
7268       q00=qstab(ithtb  ,iptb  )
7269       q10=qstab(ithtb+1,iptb  )
7270       q01=qstab(ithtb  ,iptb+1)
7271       q11=qstab(ithtb+1,iptb+1)
7272 !
7273 !***********************************************************************
7274 !              parcel temperature and saturation mixing ratio
7275 !***********************************************************************
7276 !
7277       ts=(t00+(t10-t00)*pp+(t01-t00)*qq+(t00-t10-t01+t11)*pp*qq)
7278 !
7279       qs=(q00+(q10-q00)*pp+(q01-q00)*qq+(q00-q10-q01+q11)*pp*qq)
7280 !
7281    END SUBROUTINE TPMIX2DD
7282
7283 ! -----------------------------------------------------------------------
7284   SUBROUTINE ENVIRTHT(P1,T1,Q1,THT1,ALIQ,BLIQ,CLIQ,DLIQ)
7285 !
7286 !-----------------------------------------------------------------------
7287    IMPLICIT NONE
7288 !  SAVE !TWG 2017 add to avoid memory issues
7289 !-----------------------------------------------------------------------
7290    REAL,         INTENT(IN   )   :: P1,T1,Q1,ALIQ,BLIQ,CLIQ,DLIQ
7291    REAL,         INTENT(INOUT)   :: THT1
7292    REAL    ::    EE,TLOG,ASTRT,AINC,A1,TP,VALUE,AINTRP,TDPT,TSAT,THT,      &
7293                  T00,P00,C1,C2,C3,C4,C5
7294    INTEGER ::    INDLU
7295 !-----------------------------------------------------------------------
7296       DATA T00,P00,C1,C2,C3,C4,C5/273.16,1.E5,3374.6525,2.5403,3114.834,   &
7297            0.278296,1.0723E-3/
7298 !
7299 !  CALCULATE ENVIRONMENTAL EQUIVALENT POTENTIAL TEMPERATURE...
7300 !
7301 ! NOTE: Calculations for mixed/ice phase no longer used...jsk 8/00
7302 !        For example, KF90 Eq. 10 no longer used
7303 !
7304       EE=Q1*P1/(0.622+Q1)
7305 !     TLOG=ALOG(EE/ALIQ)
7306 ! ...calculate LOG term using lookup table...
7307 !
7308       astrt=1.e-3
7309       ainc=0.075
7310       a1=ee/aliq
7311       tp=(a1-astrt)/ainc
7312       indlu=int(tp)+1
7313       value=(indlu-1)*ainc+astrt
7314       aintrp=(a1-value)/ainc
7315       tlog=aintrp*alu(indlu+1)+(1-aintrp)*alu(indlu)
7316 !
7317       TDPT=(CLIQ-DLIQ*TLOG)/(BLIQ-TLOG)
7318       TSAT=TDPT-(.212+1.571E-3*(TDPT-T00)-4.36E-4*(T1-T00))*(T1-TDPT)
7319       THT=T1*(P00/P1)**(0.2854*(1.-0.28*Q1))
7320       THT1=THT*EXP((C1/TSAT-C2)*Q1*(1.+0.81*Q1))
7321 !
7322   END SUBROUTINE ENVIRTHT
7323 ! ***********************************************************************
7324 !====================================================================
7325    SUBROUTINE mskf_init(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQRCUTEN,        &
7326                      RQICUTEN,RQSCUTEN,NCA,W0AVG,P_QI,P_QS,         &
7327                      SVP1,SVP2,SVP3,SVPT0,                          &
7328                      P_FIRST_SCALAR,restart,allowed_to_read,        &
7329                      ids, ide, jds, jde, kds, kde,                  &
7330                      ims, ime, jms, jme, kms, kme,                  &
7331                      its, ite, jts, jte, kts, kte,                  &
7332                      RUCUTEN, RVCUTEN                               ) !JTR
7333 !--------------------------------------------------------------------
7334    IMPLICIT NONE
7335 !  SAVE !TWG 2017 add to avoid memeory issues
7336 !--------------------------------------------------------------------
7337    LOGICAL , INTENT(IN)           ::  restart,allowed_to_read
7338    INTEGER , INTENT(IN)           ::  ids, ide, jds, jde, kds, kde, &
7339                                       ims, ime, jms, jme, kms, kme, &
7340                                       its, ite, jts, jte, kts, kte
7341    INTEGER , INTENT(IN)           ::  P_QI,P_QS,P_FIRST_SCALAR
7342
7343
7344    REAL,     DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) ::       &
7345                                                           RTHCUTEN, &
7346                                                           RQVCUTEN, &
7347                                                           RQCCUTEN, &
7348                                                           RQRCUTEN, &
7349                                                           RQICUTEN, &
7350                                                           RQSCUTEN, &
7351                                                            RUCUTEN, &
7352                                                            RVCUTEN
7353
7354    REAL ,   DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: W0AVG
7355
7356    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT):: NCA
7357
7358    INTEGER :: i, j, k, itf, jtf, ktf
7359    REAL, INTENT(IN)    :: SVP1,SVP2,SVP3,SVPT0
7360
7361    jtf=min0(jte,jde-1)
7362    ktf=min0(kte,kde-1)
7363    itf=min0(ite,ide-1)
7364
7365    IF(.not.restart)THEN
7366
7367       DO j=jts,jtf
7368       DO k=kts,ktf
7369       DO i=its,itf
7370          RTHCUTEN(i,k,j)=0.
7371          RQVCUTEN(i,k,j)=0.
7372          RQCCUTEN(i,k,j)=0.
7373          RQRCUTEN(i,k,j)=0.
7374          !JTR Momentum tendencies
7375          RUCUTEN(i,k,j)=0.
7376          RVCUTEN(i,k,j)=0.
7377       ENDDO
7378       ENDDO
7379       ENDDO
7380
7381       IF (P_QI .ge. P_FIRST_SCALAR) THEN
7382          DO j=jts,jtf
7383          DO k=kts,ktf
7384          DO i=its,itf
7385             RQICUTEN(i,k,j)=0.
7386          ENDDO
7387          ENDDO
7388          ENDDO
7389       ENDIF
7390
7391       IF (P_QS .ge. P_FIRST_SCALAR) THEN
7392          DO j=jts,jtf
7393          DO k=kts,ktf
7394          DO i=its,itf
7395             RQSCUTEN(i,k,j)=0.
7396          ENDDO
7397          ENDDO
7398          ENDDO
7399       ENDIF
7400
7401       DO j=jts,jtf
7402       DO i=its,itf
7403          NCA(i,j)=-100.
7404       ENDDO
7405       ENDDO
7406
7407       DO j=jts,jtf
7408       DO k=kts,ktf
7409       DO i=its,itf
7410          W0AVG(i,k,j)=0.
7411       ENDDO
7412       ENDDO
7413       ENDDO
7414
7415    endif
7416
7417    CALL MSKF_LUTAB(SVP1,SVP2,SVP3,SVPT0)
7418
7419
7420    END SUBROUTINE mskf_init
7421
7422 !-------------------------------------------------------
7423
7424       subroutine mskf_lutab(SVP1,SVP2,SVP3,SVPT0)
7425 !
7426 !  This subroutine is a lookup table.
7427 !  Given a series of series of saturation equivalent potential
7428 !  temperatures, the temperature is calculated.
7429 !
7430 !--------------------------------------------------------------------
7431    IMPLICIT NONE
7432 !  SAVE !TWG 2017 add to avoid memory issues
7433 !--------------------------------------------------------------------
7434 ! Lookup table variables
7435 !     INTEGER, SAVE, PARAMETER :: KFNT=250,KFNP=220
7436 !     REAL, SAVE, DIMENSION(1:KFNT,1:KFNP) :: TTAB,QSTAB
7437 !     REAL, SAVE, DIMENSION(1:KFNP) :: THE0K
7438 !     REAL, SAVE, DIMENSION(1:200) :: ALU
7439 !     REAL, SAVE :: RDPR,RDTHK,PLUTOP
7440 ! End of Lookup table variables
7441
7442      INTEGER :: KP,IT,ITCNT,I
7443      REAL :: DTH,TMIN,TOLER,PBOT,DPR,                               &
7444              TEMP,P,ES,QS,PI,THES,TGUES,THGUES,F0,T1,T0,THGS,F1,DT, &
7445              ASTRT,AINC,A1,THTGS
7446 !    REAL    :: ALIQ,BLIQ,CLIQ,DLIQ,SVP1,SVP2,SVP3,SVPT0
7447      REAL    :: ALIQ,BLIQ,CLIQ,DLIQ
7448      REAL, INTENT(IN)    :: SVP1,SVP2,SVP3,SVPT0
7449 !
7450 ! equivalent potential temperature increment
7451       data dth/1./
7452 ! minimum starting temp
7453       data tmin/150./
7454 ! tolerance for accuracy of temperature
7455       data toler/0.001/
7456 ! top pressure (pascals)
7457       plutop=5000.0
7458 ! bottom pressure (pascals)
7459       pbot=110000.0
7460
7461       ALIQ = SVP1*1000.
7462       BLIQ = SVP2
7463       CLIQ = SVP2*SVPT0
7464       DLIQ = SVP3
7465
7466 !
7467 ! compute parameters
7468 !
7469 ! 1._over_(sat. equiv. theta increment)
7470       rdthk=1./dth
7471 ! pressure increment
7472 !
7473       DPR=(PBOT-PLUTOP)/REAL(KFNP-1)
7474 !      dpr=(pbot-plutop)/REAL(kfnp-1)
7475 ! 1._over_(pressure increment)
7476       rdpr=1./dpr
7477 ! compute the spread of thes
7478 !     thespd=dth*(kfnt-1)
7479 !
7480 ! calculate the starting sat. equiv. theta
7481 !
7482       temp=tmin
7483       p=plutop-dpr
7484       do kp=1,kfnp
7485         p=p+dpr
7486         es=aliq*exp((bliq*temp-cliq)/(temp-dliq))
7487         qs=0.622*es/(p-es)
7488         pi=(1.e5/p)**(0.2854*(1.-0.28*qs))
7489         the0k(kp)=temp*pi*exp((3374.6525/temp-2.5403)*qs*        &
7490                (1.+0.81*qs))
7491       enddo
7492 !
7493 ! compute temperatures for each sat. equiv. potential temp.
7494 !
7495       p=plutop-dpr
7496       do kp=1,kfnp
7497         thes=the0k(kp)-dth
7498         p=p+dpr
7499         do it=1,kfnt
7500 ! define sat. equiv. pot. temp.
7501           thes=thes+dth
7502 ! iterate to find temperature
7503 ! find initial guess
7504           if(it.eq.1) then
7505             tgues=tmin
7506           else
7507             tgues=ttab(it-1,kp)
7508           endif
7509           es=aliq*exp((bliq*tgues-cliq)/(tgues-dliq))
7510           qs=0.622*es/(p-es)
7511           pi=(1.e5/p)**(0.2854*(1.-0.28*qs))
7512           thgues=tgues*pi*exp((3374.6525/tgues-2.5403)*qs*      &
7513                (1.+0.81*qs))
7514           f0=thgues-thes
7515           t1=tgues-0.5*f0
7516           t0=tgues
7517           itcnt=0
7518 ! iteration loop
7519           do itcnt=1,11
7520             es=aliq*exp((bliq*t1-cliq)/(t1-dliq))
7521             qs=0.622*es/(p-es)
7522             pi=(1.e5/p)**(0.2854*(1.-0.28*qs))
7523             thtgs=t1*pi*exp((3374.6525/t1-2.5403)*qs*(1.+0.81*qs))
7524             f1=thtgs-thes
7525             if(abs(f1).lt.toler)then
7526               exit
7527             endif
7528 !           itcnt=itcnt+1
7529             dt=f1*(t1-t0)/(f1-f0)
7530             t0=t1
7531             f0=f1
7532             t1=t1-dt
7533           enddo
7534           ttab(it,kp)=t1
7535           qstab(it,kp)=qs
7536         enddo
7537       enddo
7538 !
7539 ! lookup table for tlog(emix/aliq)
7540 !
7541 ! set up intial values for lookup tables
7542 !
7543        astrt=1.e-3
7544        ainc=0.075
7545 !
7546        a1=astrt-ainc
7547        do i=1,200
7548          a1=a1+ainc
7549          alu(i)=alog(a1)
7550        enddo
7551 !
7552    END SUBROUTINE MSKF_LUTAB
7553
7554 !JTR 06/18/2019: Inserted momentum transport subroutine
7555     SUBROUTINE MSKF_CMT(DUDT,DVDT,dpdx,dpdy, &
7556     DP,ED,EU,MC,MD,MU,MB, &
7557     P,QD,QU,QHAT,SD,SU,SHAT,T,U,V,Z,ZF, &
7558     DSUBCLD,JB,JD,JT, &
7559     MSG,DT,GRAV,CPRES,RGAS,ILEV,IL1G,IL2G,ILG)
7560
7561 !     * JULY 17/92. - GUANG JUN ZHANG, M.LAZARE.
7562
7563 !     * PERFORMS MOMENTUM MIXING DUE TO CUMULUS PARAMETRIZATION.
7564
7565 ! ongxl 20060901---------------------
7566     use shr_kind_mod, only: r8=>shr_kind_r8
7567     implicit none
7568     integer, parameter :: NBF = 10
7569 ! ongxl      PARAMETER(NBF=10)
7570 ! ongxl      PARAMETER(JLG=128, JLEV=18)
7571 ! ongxl 20060901---------------------
7572
7573     real(r8) DUDT(ILG,ILEV),  DVDT(ILG,ILEV), &
7574     dpdx(ILG,ILEV),  dpdy(ILG,ILEV), &
7575     ALPHA(ILG,ILEV), DP(ILG,ILEV), &
7576     ED(ILG,ILEV),    EU(ILG,ILEV),    MB(ILG), &
7577     MC(ILG,ILEV),    MD(ILG,ILEV),    MU(ILG,ILEV), &
7578     P(ILG,ILEV),     QD(ILG,ILEV),    QU(ILG,ILEV), &
7579     QHAT(ILG,ILEV),  SD(ILG,ILEV),    SU(ILG,ILEV), &
7580     SHAT(ILG,ILEV),  T(ILG,ILEV),     U(ILG,ILEV), &
7581     V(ILG,ILEV),     Z(ILG,ILEV),     ZF(ILG,ILEV+1)    !songxl
7582 ! ongxl     7     V(ILG,ILEV),     Z(ILG,ILEV),     ZF(ILG,ILEV)
7583
7584     real(r8) DSUBCLD(ILG)
7585 ! ongxl 20060901-----------------
7586     real(r8) DT, GRAV, CPRES, RGAS
7587     integer :: MSG, ILEV, IL1G, IL2G, ILG
7588 ! ongxl 20060901-----------------
7589
7590     INTEGER ::   JB(ILG),    JD(ILG),         JT(ILG)
7591
7592 !     * INTERNAL WORK FIELDS.
7593
7594     real(r8) AC(ILG,ILEV),    AD(ILG,ILEV),    AU(ILG,ILEV), &
7595     ACFL(ILG,ILEV),  ADFL(ILG,ILEV),  AUFL(ILG,ILEV), &
7596     B1(ILG,ILEV),    B1FL(ILG,ILEV),  BD(ILG,ILEV), &
7597     BU(ILG,ILEV),    D0(ILG,ILEV),    D0HAT(ILG,ILEV), &
7598     DELPX(ILG,ILEV), DELPY(ILG,ILEV), DZ(ILG,ILEV), &
7599     DZF(ILG,ILEV),   EC(ILG,ILEV),    E(ILG,ILEV), &
7600     EHAT(ILG,ILEV),  RHO(ILG,ILEV),   RHOHAT(ILG,ILEV), &
7601     UHAT(ILG,ILEV),  VHAT(ILG,ILEV),  UC(ILG,ILEV), &
7602     VC(ILG,ILEV),    W0(ILG,ILEV),    W1(ILG,ILEV), &
7603     W0FL(ILG,ILEV),  W1FL(ILG,ILEV)
7604
7605     real(r8) COSA(ILG),    SINA(ILG),    CCX(ILG),     CCY(ILG), &
7606     UMN(ILG),     VMN(ILG),     DEP(ILG)
7607
7608     real(r8) FX(ILG,ILEV,NBF), DX(ILG,ILEV,NBF), &
7609     AA(ILG,ILEV,NBF), BB(ILG,ILEV,NBF),  CC(ILG,ILEV,NBF), &
7610     FY(ILG,ILEV,NBF), DY(ILG,ILEV,NBF)
7611
7612 ! ongxl      COMMON/CONST/ALFA1(NBF),ALFA2(NBF),BSJ0(NBF),BSJ1(NBF),
7613 ! ongxl     1             BSJ0CHI,FACTOR
7614 ! ongxl      COMMON/TAU/TAU(NBF)
7615 ! ongxl 20060901-----------------
7616     real(r8) ALFA1(NBF),ALFA2(NBF),BSJ0(NBF),BSJ1(NBF),BSJ0CHI,FACTOR,TAU(NBF)
7617 ! ongxl 20060901-----------------
7618     DATA ALFA1/4.33675e-05_r8, 7.88429e-05_r8, 1.13065e-04_r8, 1.45836e-04_r8, &
7619     &            1.76823e-04_r8, 2.05660e-04_r8, 2.32101e-04_r8, 2.55829e-04_r8, &
7620     &            2.76672e-04_r8, 2.94347e-04_r8/
7621     DATA ALFA2/-8.64731e-05_r8,-1.56092e-04_r8,-2.21315e-04_r8,-2.80995e-04_r8, &
7622     -3.33799e-04_r8,-3.78455e-04_r8,-4.14020e-04_r8,-4.39600e-04_r8, &
7623     -4.54652e-04_r8,-4.58761e-04_r8/
7624     DATA BSJ0/-4.02759e-01_r8, 3.00116e-01_r8, -2.49705e-01_r8, 2.18359e-01_r8, &
7625     -1.96465e-01_r8, 1.80062e-01_r8, -1.67183e-01_r8, 1.56722e-01_r8, &
7626     -1.48011e-01_r8, 1.40605e-01_r8/
7627     DATA BSJ1/1.14193e-01_r8, 2.05841e-01_r8, 2.91209e-01_r8, 3.68619e-01_r8, &
7628     &           4.36201e-01_r8, 4.92233e-01_r8, 5.35486e-01_r8, 5.64886e-01_r8, &
7629     &           5.79879e-01_r8, 5.80195e-01_r8/
7630     DATA BSJ0CHI/-0.402759_r8/
7631     DATA FACTOR/0.179503_r8/
7632     DATA TAU/ 3.83170e+00_r8, 7.01560e+00_r8, 1.01735e+01_r8, 1.33237e+01_r8, &
7633     &           1.64705e+01_r8, 1.96120e+01_r8, 2.27560e+01_r8, 2.58980e+01_r8, &
7634     &           2.90480e+01_r8, 3.21926e+01_r8/
7635 ! ongxl 20060901------------------------
7636     integer :: J, IL, N ,jj
7637     real(r8) RC, RMAX, CHI, SHAPE, RNU, WINDMAG
7638 ! ongxl 20060901-----------------------
7639
7640 !----------------------------------------------------------------------
7641 !***********************************************************************
7642 ! CCC INITIALIZE RELEVANT INTERFACIAL AND MIDLAYER VARIABLES     CCCCC
7643 !***********************************************************************
7644     RC=3000._r8         ! cloud radius (m)
7645     RMAX=50000._r8      ! distance where perturb. vanishes (m)
7646     CHI=3.8317_r8/RC
7647     SHAPE=0.8_r8
7648     DO 5 J=MSG+1,ILEV
7649         DO 5 IL=IL1G,IL2G
7650             BU(IL,J)=0._r8
7651             ALPHA(IL,J)=0.5_r8
7652             BD(IL,J)=0._r8
7653             DELPX(IL,J)=0._r8
7654             DELPY(IL,J)=0._r8
7655             EC(IL,J)=EU(IL,J)+ED(IL,J)     ! unit: 1/s
7656             IF(T(IL,J) > 0._r8)        THEN
7657                 RHO(IL,J)=100._r8*P(IL,J)/(RGAS*T(IL,J))
7658             ENDIF
7659     5 END DO
7660
7661     DO 10 N=1,NBF
7662         DO 10 J=MSG+1,ILEV
7663             DO 10 IL=IL1G,IL2G
7664                 FX(IL,J,N)=0._r8
7665                 FY(IL,J,N)=0._r8
7666     10 END DO
7667
7668     DO 15 J=MSG+2,ILEV
7669         DO 15 IL=IL1G,IL2G
7670             BU(IL,J)=(   SU(IL,J)-SHAT(IL,J)+0.608_r8*( QU(IL,J) &
7671             *(SU(IL,J)-GRAV/CPRES*ZF(IL,J))-QHAT(IL,J) &
7672             *(SHAT(IL,J)-GRAV/CPRES*ZF(IL,J)) )  ) &
7673             /( (SHAT(IL,J)-GRAV/CPRES*ZF(IL,J)) &
7674             *(1._r8+.608_r8*QHAT(IL,J)) )*GRAV
7675             BD(IL,J)=(   SD(IL,J)-SHAT(IL,J)+0.608_r8*( QD(IL,J) &
7676             *(SD(IL,J)-GRAV/CPRES*ZF(IL,J))-QHAT(IL,J) &
7677             *(SHAT(IL,J)-GRAV/CPRES*ZF(IL,J)) )  ) &
7678             /( (SHAT(IL,J)-GRAV/CPRES*ZF(IL,J)) &
7679             *(1._r8+.608_r8*QHAT(IL,J)) )*GRAV
7680     15 END DO
7681
7682     DO 20 IL=IL1G,IL2G
7683         UMN(IL)=0._r8
7684         VMN(IL)=0._r8
7685     !       DEP(IL)=0.
7686         COSA(IL)=0._r8
7687         SINA(IL)=0._r8
7688         CCX(IL)=0._r8
7689         CCY(IL)=0._r8
7690     20 END DO
7691
7692     DO 25 J=1,ILEV
7693         DO 25 IL=IL1G,IL2G
7694             IF(J >= JT(IL) .AND. J < JB(IL))     THEN
7695                 UMN(IL)=UMN(IL)+U(IL,J)*P(IL,J)/T(IL,J)* &
7696                 (ZF(IL,J)-ZF(IL,J+1))
7697                 VMN(IL)=VMN(IL)+V(IL,J)*P(IL,J)/T(IL,J)* &
7698                 (ZF(IL,J)-ZF(IL,J+1))
7699             !         DEP(IL)=DEP(IL)+P(IL,J)/T(IL,J)*(ZF(IL,J)-ZF(IL,J+1))
7700             ENDIF
7701     25 END DO
7702
7703     DO 30 IL=IL1G,IL2G
7704         WINDMAG=SQRT(UMN(IL)**2+VMN(IL)**2)
7705     !       IF(DEP(IL).NE.0. .AND. WINDMAG.NE.0.)   THEN
7706         IF(WINDMAG /= 0._r8)                       THEN
7707             COSA(IL)=UMN(IL)/WINDMAG
7708             SINA(IL)=VMN(IL)/WINDMAG
7709         !         CCX(IL)=0.*UMN(IL)/DEP(IL)
7710         !         CCY(IL)=0.*VMN(IL)/DEP(IL)
7711         ENDIF
7712     30 END DO
7713
7714     DO 35 J=MSG+1,ILEV
7715         DO 35 IL=IL1G,IL2G
7716             IF(J > MSG+1)                          THEN
7717                 RHOHAT(IL,J)=ALPHA(IL,J)*RHO(IL,J-1)+(1._r8-ALPHA(IL,J))*RHO(IL,J)
7718                 DZF(IL,J)=Z(IL,J-1)-Z(IL,J)
7719                 UHAT(IL,J)=ALPHA(IL,J)*U(IL,J-1)+(1._r8-ALPHA(IL,J))*U(IL,J)
7720                 VHAT(IL,J)=ALPHA(IL,J)*V(IL,J-1)+(1._r8-ALPHA(IL,J))*V(IL,J)
7721             ELSE
7722                 RHOHAT(IL,J)=RHO(IL,J)
7723                 DZF(IL,J)=ZF(IL,J)-Z(IL,J)
7724                 UHAT(IL,J)=U(IL,J)
7725                 VHAT(IL,J)=V(IL,J)
7726             ENDIF
7727             UC(IL,J)=UHAT(IL,J)
7728             VC(IL,J)=VHAT(IL,J)
7729     35 END DO
7730
7731     DO 40 J=MSG+1,ILEV
7732         DO 40 IL=IL1G,IL2G
7733             IF(J < ILEV)                       THEN
7734                 DZ(IL,J)=ZF(IL,J)-ZF(IL,J+1)
7735             ELSE
7736             !          DZ(IL,ILEV)=ZF(IL,ILEV)
7737                 DZ(IL,ILEV)=DP(IL,ILEV)*100._r8/(RHO(IL,ILEV)*GRAV) !m
7738             ENDIF
7739     40 END DO
7740 !     ******************************************************************
7741 !     AU, AD,AC ARE ACTUAL FRACTIONAL CLOUD AREA TIMES GRAV
7742 !     ******************************************************************
7743     DO 75 J=MSG+1,ILEV
7744         DO 75 IL=IL1G,IL2G
7745             IF(J >= JT(IL))                     THEN
7746                 AU(IL,J)=MU(IL,JB(IL))*100._r8/GRAV/RHOHAT(IL,JB(IL))
7747             ELSE
7748                 AU(IL,J)=0._r8
7749             ENDIF
7750             IF(J >= JD(IL))                     THEN
7751                 AD(IL,J)=-MD(IL,JD(IL))*100._r8/GRAV/RHOHAT(IL,JD(IL))
7752             ELSE
7753                 AD(IL,J)=0._r8
7754             ENDIF
7755             AC(IL,J)=AU(IL,J)+AD(IL,J)
7756             IF(AC(IL,J) > 0._r8)                  THEN
7757                 W0(IL,J)=MC(IL,J)*100._r8/GRAV/(RHOHAT(IL,J)*AC(IL,J))
7758             ELSE
7759                 W0(IL,J)=0._r8
7760             ENDIF
7761     75 END DO
7762
7763     DO 80 J=MSG+1,ILEV
7764         DO 80 IL=IL1G,IL2G
7765             IF(J < ILEV)                       THEN
7766                 ACFL(IL,J)=ALPHA(IL,J)*AC(IL,J)+(1._r8-ALPHA(IL,J))*AC(IL,J+1)
7767                 AUFL(IL,J)=ALPHA(IL,J)*AU(IL,J)+(1._r8-ALPHA(IL,J))*AU(IL,J+1)
7768                 ADFL(IL,J)=ALPHA(IL,J)*AD(IL,J)+(1._r8-ALPHA(IL,J))*AD(IL,J+1)
7769                 W0FL(IL,J)=ALPHA(IL,J)*W0(IL,J)+(1._r8-ALPHA(IL,J))*W0(IL,J+1)
7770             ELSE
7771                 ACFL(IL,J)=ALPHA(IL,J)*AC(IL,J)
7772                 AUFL(IL,J)=ALPHA(IL,J)*AU(IL,J)
7773                 ADFL(IL,J)=ALPHA(IL,J)*AD(IL,J)
7774                 W0FL(IL,J)=ALPHA(IL,J)*W0(IL,J)
7775             ENDIF
7776     80 END DO
7777
7778     DO 250 J=MSG+1,ILEV
7779         DO 250 IL=IL1G,IL2G
7780             IF(J < JB(IL) .AND. J >= JT(IL) .AND. ACFL(IL,J) > 0._r8) THEN
7781                 D0(IL,J)=( MC(IL,J+1)-MC(IL,J) )*100._r8/GRAV &
7782                 /(RHO(IL,J)*DZ(IL,J)*ACFL(IL,J))
7783             ELSE
7784                 IF(J == JB(IL) .AND. ACFL(IL,J) > 0._r8 )               THEN
7785                     D0(IL,J)= -MC(IL,J)*100._r8/GRAV &
7786                     /(RHO(IL,J)*DZ(IL,J)*ACFL(IL,J))
7787                 ELSE
7788                     D0(IL,J)=0._r8
7789                 ENDIF
7790             ENDIF
7791             IF(J < JB(IL) .AND. J >= JT(IL) .AND. ACFL(IL,J) > 0._r8 &
7792              .AND. ADFL(IL,J) > 0._r8 .AND. AUFL(IL,J) > 0._r8)        THEN
7793                 E(IL,J)=1._r8/CHI**2*ADFL(IL,J)/(ACFL(IL,J)*RHO(IL,J)) &
7794                 *( 1._r8/(AUFL(IL,J)*DZ(IL,J)) &
7795                 *(MU(IL,J)-MU(IL,J+1))*100._r8/GRAV - &
7796                 &                 1._r8/(ADFL(IL,J)*DZ(IL,J)) &
7797                 *(MD(IL,J)-MD(IL,J+1))*100._r8/GRAV ) &
7798                 *SHAPE/FACTOR
7799
7800             ELSE
7801                 E(IL,J)=0._r8
7802             ENDIF
7803     250 END DO
7804
7805     DO 275 J=MSG+1,ILEV
7806         DO 275 IL=IL1G,IL2G
7807             IF(J > MSG+1)                                           THEN
7808                 D0HAT(IL,J)=ALPHA(IL,J)*D0(IL,J-1)+(1._r8-ALPHA(IL,J))*D0(IL,J)
7809                 EHAT(IL,J)=ALPHA(IL,J)*E(IL,J-1)+(1._r8-ALPHA(IL,J))*E(IL,J)
7810             ELSE
7811                 D0HAT(IL,J)=(1._r8-ALPHA(IL,J))*D0(IL,J)
7812                 EHAT(IL,J)=(1._r8-ALPHA(IL,J))*E(IL,J)
7813             ENDIF
7814     275 END DO
7815
7816 !     **********************************************
7817 !     CALCULATE FIRST HARMONICS IN THERMODYNAMICS
7818 !     **********************************************
7819     DO 325 J=MSG+1,ILEV
7820         DO 325 IL=IL1G,IL2G
7821             IF( J >= JD(IL) .AND. J <= JB(IL) .AND. AU(IL,J) > 0._r8 &
7822              .AND. AD(IL,J) > 0._r8 .AND. AC(IL,J) > 0._r8 )          THEN
7823                 W1(IL,J)=SHAPE/FACTOR*(MU(IL,J)/AU(IL,J)-MD(IL,J)/AD(IL,J)) &
7824                 *100._r8/GRAV*AD(IL,J)/(AC(IL,J)*RHOHAT(IL,J))
7825                 B1(IL,J)=SHAPE/FACTOR*(BU(IL,J)-BD(IL,J))*AD(IL,J)/AC(IL,J)
7826             ELSE
7827                 W1(IL,J)=0._r8
7828                 B1(IL,J)=0._r8
7829             ENDIF
7830     325 END DO
7831
7832     DO 350 J=MSG+1,ILEV
7833         DO 350 IL=IL1G,IL2G
7834             IF(J < ILEV)                                      THEN
7835                 W1FL(IL,J)=ALPHA(IL,J)*W1(IL,J)+(1._r8-ALPHA(IL,J))*W1(IL,J+1)
7836                 B1FL(IL,J)=ALPHA(IL,J)*B1(IL,J)+(1._r8-ALPHA(IL,J))*B1(IL,J+1)
7837             ELSE
7838                 W1FL(IL,J)=ALPHA(IL,J)*W1(IL,J)
7839                 B1FL(IL,J)=ALPHA(IL,J)*B1(IL,J)
7840             ENDIF
7841     350 END DO
7842
7843     DO 500 N=1,NBF
7844         DO 500 J=MSG+1,ILEV
7845             DO 500 IL=IL1G,IL2G
7846                 IF(J < JB(IL) .AND. J >= JT(IL) .AND. MC(IL,J) > 0._r8 &
7847                  .AND. MC(IL,J+1) > 0._r8)                          THEN
7848                     FX(IL,J,N)=2._r8*RHO(IL,J)/BSJ0(N)**2 &
7849                     *( D0(IL,J)*E(IL,J)*CHI**2*COSA(IL)*ALFA1(N) &
7850                     +2._r8*W0FL(IL,J)*RC/RMAX**2*BSJ1(N) &
7851                     *( (EHAT(IL,J)-EHAT(IL,J+1))/DZ(IL,J)*CHI*COSA(IL) &
7852                     *BSJ0CHI+(UHAT(IL,J)-UHAT(IL,J+1))/DZ(IL,J) ) &
7853                     -(D0HAT(IL,J)-D0HAT(IL,J+1))/DZ(IL,J)*W1FL(IL,J)*COSA(IL) &
7854                     *(ALFA2(N)-ALFA1(N))    -2._r8*( (W0(IL,J)-W0(IL,J+1)) &
7855                     *(W1(IL,J)-W1(IL,J+1))/DZ(IL,J)**2 &
7856                     -W0FL(IL,J)*W1FL(IL,J) &
7857                     *( LOG(RHO(IL,J-1))/(DZ(IL,J)*DZF(IL,J)) &
7858                     -(1._r8/DZF(IL,J)+1._r8/DZF(IL,J+1))/DZ(IL,J) &
7859                     *LOG(RHO(IL,J)) &
7860                     +LOG(RHO(IL,J+1))/(DZ(IL,J)*DZF(IL,J+1)) ) ) &
7861                     *COSA(IL)*ALFA1(N) &
7862                     +(RHOHAT(IL,J)*B1(IL,J)-RHOHAT(IL,J+1)*B1(IL,J+1)) &
7863                     /(DZ(IL,J)*RHO(IL,J))*COSA(IL)*ALFA1(N) )
7864                     FY(IL,J,N)=2._r8*RHO(IL,J)/BSJ0(N)**2 &
7865                     *( D0(IL,J)*E(IL,J)*CHI**2*SINA(IL)*ALFA1(N) &
7866                     +2._r8*W0FL(IL,J)*RC/RMAX**2*BSJ1(N) &
7867                     *( (EHAT(IL,J)-EHAT(IL,J+1))/DZ(IL,J)*CHI*SINA(IL) &
7868                     *BSJ0CHI+(VHAT(IL,J)-VHAT(IL,J+1))/DZ(IL,J) ) &
7869                     -(D0HAT(IL,J)-D0HAT(IL,J+1))/DZ(IL,J)*W1FL(IL,J)*SINA(IL) &
7870                     *(ALFA2(N)-ALFA1(N))    -2._r8*( (W0(IL,J)-W0(IL,J+1)) &
7871                     *(W1(IL,J)-W1(IL,J+1))/DZ(IL,J)**2 &
7872                     -W0FL(IL,J)*W1FL(IL,J) &
7873                     *( LOG(RHO(IL,J-1))/(DZ(IL,J)*DZF(IL,J)) &
7874                     -(1._r8/DZF(IL,J)+1._r8/DZF(IL,J+1))/DZ(IL,J) &
7875                     *LOG(RHO(IL,J)) &
7876                     +LOG(RHO(IL,J+1))/(DZ(IL,J)*DZF(IL,J+1)) ) ) &
7877                     *SINA(IL)*ALFA1(N) &
7878                     +(RHOHAT(IL,J)*B1(IL,J)-RHOHAT(IL,J+1)*B1(IL,J+1)) &
7879                     /(DZ(IL,J)*RHO(IL,J))*SINA(IL)*ALFA1(N) )
7880                 ENDIF
7881     500 END DO
7882
7883     DO 525 N=1,NBF
7884         DO 525 IL=IL1G,IL2G
7885             AA(IL,MSG+1,N)=0._r8
7886             BB(IL,MSG+1,N)=1._r8/ DZF(IL,MSG+2)
7887             CC(IL,MSG+1,N)=-1._r8/ DZF(IL,MSG+2)
7888
7889             AA(IL,ILEV,N)=1._r8/ DZF(IL,ILEV)
7890             BB(IL,ILEV,N)=-1._r8/ DZF(IL,ILEV)
7891             CC(IL,ILEV,N)=0._r8
7892
7893             DX(IL,MSG+1,N)=B1(IL,MSG+2)*ALFA1(N)*2._r8 &
7894             *COSA(IL)/BSJ0(N)**2
7895             DX(IL,ILEV,N)=B1(IL,ILEV)*ALFA1(N)*2._r8 &
7896             *COSA(IL)/BSJ0(N)**2
7897
7898             DY(IL,MSG+1,N)=B1(IL,MSG+2)*ALFA1(N)*2._r8 &
7899             *SINA(IL)/BSJ0(N)**2
7900             DY(IL,ILEV,N)=B1(IL,ILEV)*ALFA1(N)*2._r8 &
7901             *SINA(IL)/BSJ0(N)**2
7902     525 END DO
7903
7904     DO 550 N=1,NBF
7905         DO 550 J=MSG+2,ILEV-1
7906             DO 550 IL=IL1G,IL2G
7907                 AA(IL,J,N)=1._r8/( DZ(IL,J)*DZF(IL,J) )
7908                 BB(IL,J,N)=-( 1._r8/DZ(IL,J)*(1._r8/DZF(IL,J)+1._r8/DZF(IL,J+1)) &
7909                 +(TAU(N)/RMAX)**2 )
7910                 CC(IL,J,N)=1._r8/( DZ(IL,J)*DZF(IL,J+1) )
7911
7912                 DX(IL,J,N)=FX(IL,J,N)
7913                 DY(IL,J,N)=FY(IL,J,N)
7914     550 END DO
7915
7916
7917     DO 575 N=1,NBF
7918         DO 575 IL=IL1G,IL2G
7919             CC(IL,MSG+1,N)=CC(IL,MSG+1,N)/BB(IL,MSG+1,N)
7920             DX(IL,MSG+1,N)=DX(IL,MSG+1,N)/BB(IL,MSG+1,N)
7921             DY(IL,MSG+1,N)=DY(IL,MSG+1,N)/BB(IL,MSG+1,N)
7922     575 END DO
7923
7924     DO 600 N=1,NBF
7925         DO 600 J=MSG+2,ILEV
7926             DO 600 IL=IL1G,IL2G
7927                 CC(IL,J,N)=CC(IL,J,N)/(BB(IL,J,N)-AA(IL,J,N)*CC(IL,J-1,N))
7928                 DX(IL,J,N)=(DX(IL,J,N)-AA(IL,J,N)*DX(IL,J-1,N)) &
7929                 /(BB(IL,J,N)-AA(IL,J,N)*CC(IL,J-1,N))
7930                 DY(IL,J,N)=(DY(IL,J,N)-AA(IL,J,N)*DY(IL,J-1,N)) &
7931                 /(BB(IL,J,N)-AA(IL,J,N)*CC(IL,J-1,N))
7932     600 END DO
7933
7934     DO 650 N=1,NBF
7935         DO 650 J=ILEV-1,MSG+1,-1
7936             DO 650 IL=IL1G,IL2G
7937                 DX(IL,J,N)=DX(IL,J,N)-CC(IL,J,N)*DX(IL,J+1,N)
7938                 DY(IL,J,N)=DY(IL,J,N)-CC(IL,J,N)*DY(IL,J+1,N)
7939     650 END DO
7940
7941     DO 700 N=1,NBF
7942         DO 700 J=MSG+1,ILEV
7943             DO 700 IL=IL1G,IL2G
7944                 DELPX(IL,J)=DELPX(IL,J)+DX(IL,J,N)*BSJ1(N)   !kg/m/s**2
7945                 DELPY(IL,J)=DELPY(IL,J)+DY(IL,J,N)*BSJ1(N)   !kg/m/s**2
7946     700 END DO
7947
7948     DO 850 J=MSG+1,ILEV
7949         DO 850 IL=IL1G,IL2G
7950             DELPX(IL,J)=DELPX(IL,J)/RC             !kg/m**2/s**2
7951             DELPY(IL,J)=DELPY(IL,J)/RC             !kg/m**2/s**2
7952         ! to get cloud-scale pressure gradient by multiplying cloud fraction
7953             DELPX(IL,J)=ACFL(IL,J)*DELPX(IL,J)/RHO(IL,J)  !m/s/s
7954             DELPY(IL,J)=ACFL(IL,J)*DELPY(IL,J)/RHO(IL,J)  !m/s/s
7955             dpdx(IL,J)=DELPX(IL,J)
7956             dpdy(IL,J)=DELPY(IL,J)
7957     850 END DO
7958
7959 !     ************************************
7960 !     CALCULATE THE CLOUD MEAN WIND
7961 !     ************************************
7962
7963     DO 875 J=ILEV-1,MSG+1,-1
7964         DO 875 IL=IL1G,IL2G
7965             IF(MC(IL,J) > 0._r8 .AND. MC(IL,J+1) > 0._r8 &
7966              .AND. J > JT(IL) .AND. J < JB(IL))      THEN
7967                 UC(IL,J)=UC(IL,J+1) + RHO(IL,J)*DZ(IL,J) &
7968                 /((MC(IL,J)+MC(IL,J+1))*0.5_r8*100._r8/GRAV) &
7969                 *( EC(IL,J)*(U(IL,J)-UC(IL,J+1))-DELPX(IL,J) )
7970                 VC(IL,J)=VC(IL,J+1) + RHO(IL,J)*DZ(IL,J) &
7971                 /((MC(IL,J)+MC(IL,J+1))*0.5_r8*100._r8/GRAV) &
7972                 *( EC(IL,J)*(V(IL,J)-VC(IL,J+1))-DELPY(IL,J) )
7973             ENDIF
7974     875 END DO
7975
7976 !     RNU=1.
7977     RNU=0._r8
7978     DO 950 J=MSG+1,ILEV
7979         DO 950 IL=IL1G,IL2G
7980             IF( J >= JT(IL) .AND. J <= JB(IL) )                 THEN
7981                 UHAT(IL,J)=UHAT(IL,J)+RNU*ALPHA(IL,J)*DT*DUDT(IL,J-1)
7982                 VHAT(IL,J)=VHAT(IL,J)+RNU*ALPHA(IL,J)*DT*DVDT(IL,J-1)
7983                 IF(J == JT(IL))                                     THEN
7984                     DUDT(IL,J)=1._r8/(1._r8+RNU*ALPHA(IL,J+1)*MC(IL,J+1)*DT/DP(IL,J))* &
7985                     MC(IL,J+1)*(UC(IL,J+1)-UHAT(IL,J+1))/DP(IL,J)
7986                     DVDT(IL,J)=1._r8/(1._r8+RNU*ALPHA(IL,J+1)*MC(IL,J+1)*DT/DP(IL,J))* &
7987                     MC(IL,J+1)*(VC(IL,J+1)-VHAT(IL,J+1))/DP(IL,J)
7988                 ELSE IF(J < JB(IL))                                THEN
7989                     DUDT(IL,J)=1._r8/(1._r8+RNU*ALPHA(IL,J+1)*MC(IL,J+1)*DT/DP(IL,J)) &
7990                     *(MC(IL,J+1)*(UC(IL,J+1)-UHAT(IL,J+1)) &
7991                     -MC(IL,J)*(UC(IL,J)-UHAT(IL,J)))/DP(IL,J)
7992                     DVDT(IL,J)=1._r8/(1._r8+RNU*ALPHA(IL,J+1)*MC(IL,J+1)*DT/DP(IL,J)) &
7993                     *(MC(IL,J+1)*(VC(IL,J+1)-VHAT(IL,J+1)) &
7994                     -MC(IL,J)*(VC(IL,J)-VHAT(IL,J)))/DP(IL,J)
7995                 ELSE
7996                     DUDT(IL,J)=-1._r8/DSUBCLD(IL)*MC(IL,J)*(UC(IL,J)-UHAT(IL,J))
7997                     DVDT(IL,J)=-1._r8/DSUBCLD(IL)*MC(IL,J)*(VC(IL,J)-VHAT(IL,J))
7998                 ENDIF
7999             ENDIF
8000         ! dudt and dvdt (m/s/s)
8001
8002             if (abs(dudt(il,j)) > 5.0e-2_r8 .OR. abs(dvdt(il,j)) > 5.0e-2_r8) then
8003                 print*,'moment',il,j,dt,jt(il),jb(il) &
8004                 ,dudt(il,j),dvdt(il,j),dp(il,j) &
8005                 ,MC(IL,J+1),UC(IL,J+1),VC(IL,J+1),uhat(il,j+1),vhat(il,j+1) &
8006                 ,DSUBCLD(IL),MC(IL,J),UC(IL,J),VC(IL,J),UHAT(IL,J),VHAT(IL,J)
8007                 print*,'mb,msg,ilev=',mb(il),msg,ilev
8008                 print*,'uc=',(uc(il,jj),jj=msg+1,ilev)
8009                 print*,'vc=',(vc(il,jj),jj=msg+1,ilev)
8010                 print*,'mc=',(mc(il,jj),jj=msg+1,ilev)
8011                 print*,'mu=',(mu(il,jj),jj=msg+1,ilev)
8012                 print*,'md=',(md(il,jj),jj=msg+1,ilev)
8013                 print*,'u=',(u(il,jj),jj=msg+1,ilev)
8014                 print*,'v=',(v(il,jj),jj=msg+1,ilev)
8015                 print*,'ec=',(ec(il,jj),jj=msg+1,ilev)
8016                 print*,'delpx=',(delpx(il,jj),jj=msg+1,ilev)
8017                 print*,'delpy=',(delpy(il,jj),jj=msg+1,ilev)
8018                 print*,'RHO=',(RHO(il,jj),jj=msg+1,ilev)
8019                 print*,'dz=',(dz(il,jj),jj=msg+1,ilev)
8020             endif
8021
8022         !     if (abs(dudt(il,j)).gt.1.0e-2.or.abs(dvdt(il,j)).gt.1.0e-2) then
8023         !      do i9=IL1G,IL2G
8024         !      do j9=MSG+1,ILEV
8025         !      print* ,'bad',i9,j9,dt,jt(i9),jb(i9)
8026         !    $       ,dudt(i9,j9),dvdt(i9,j9),dp(i9,j9),dz(i9,j9)
8027         !    $       ,mc(i9,j9+1),uc(i9,j9+1),vc(i9,j9+1),ec(i9,j9+1)
8028         !    $       ,du(i9,j9+1)
8029         !    $       ,uhat(i9,j9+1),vhat(i9,j9+1),delpx(i9,j9),delpx(i9,j9+1)
8030         !    $       ,delpy(i9,j9),delpy(i9,j9+1)
8031         !      enddo
8032         !      enddo
8033         !     endif
8034     950 END DO
8035
8036
8037     RETURN
8038     END SUBROUTINE MSKF_CMT
8039
8040
8041 END MODULE module_cu_mskf