Merge pull request #22 from wirc-sjsu/develop-w21

[WRF-Fire-merge.git] / phys / module_mp_nssl_2mom.F

!WRF:MODEL_LAYER:PHYSICS


! prepocessed on "Sep  7 2021" at "19:37:43"








!---------------------------------------------------------------------
! IMPORTANT: Best results are attained using the 5th-order WENO (Weighted Essentially Non-Oscillatory) advection option (4) for scalars:
! moist_adv_opt                       = 4,
! scalar_adv_opt                      = 4, (can also use option 3, which is WENO without the positive definite filter)
! The WENO-5 scheme provides a 5th-order (horizontal and vertical) adaptive weighting of components that 
! better preserve monotinicity in strong gradients. The standard 5th-order formulation is prone to undershoots 
! (negative values) of mass and number concentrations at cloud edges. The WENO scheme helps 
! to prevent undershoots and results in less noise at cloud and reflectivity boundaries. This is particularly
! useful for multi-moment schemes to preserve relationships between mass and number concentration. An option is also available
! for WENO-5 advection of momentum, but this can result in excessive damping of poorly-resolved features. For both scalar and momentum
! the steps 1 and 2 of the Runge-Kutta time integration use standare 5th-order advection, and the WENO-5 is applied on the 3rd (final)
! RK step. Option 3 applies the WENO-5, and option 4 adds the positive definite filter (as also used in option 1). 
!
! WENO references: Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223; Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118;
!
! This module provides a 2-moment bulk microphysics scheme originally 
! developed by Conrad Ziegler (Zeigler, 1985, JAS) and modified/upgraded in 
! in Mansell, Zeigler, and Bruning (2010, JAS).  Two-moment adaptive sedimentation 
! follows Mansell (2010, JAS), using parameter infall = 4.
!
! Added info on graupel density and soaking is in Mansell and Ziegler (2013, JAS)
!
! Average graupel particle density is predicted, which affects fall speed as well. 
! Hail density prediction is by default disabled in this version, but may be enabled
! at some point if there is interest.
!
! Maintainer: Ted Mansell, National Severe Storms Laboratory <ted.mansell@noaa.gov>
!
! Microphysics References:
!
! Mansell, E. R., C. L. Ziegler, and E. C. Bruning, 2010: Simulated electrification of a small 
!   thunderstorm with two-moment bulk microphysics. J. Atmos. Sci., 67, 171-194, doi:10. 1175/2009JAS2965.1.
!
!  Mansell, E. R. and C. L. Ziegler, 2013: Aerosol effects on simulated storm electrification and 
!     precipitation in a two-moment bulk microphysics model. J. Atmos. Sci., 70 (7), 2032-2050, 
!     doi:10.1175/JAS-D-12-0264.1.
!
! Ziegler, C. L., 1985: Retrieval of thermal and microphysical variables in observed convective storms. 
!    Part I: Model development and preliminary testing. J. Atmos. Sci., 42, 1487-1509.
!
! Sedimentation reference:
!
! Mansell, E. R., 2010: On sedimentation and advection in multimoment bulk microphysics. 
!    J. Atmos. Sci., 67, 3084-3094, doi:10.1175/2010JAS3341.1.
!
! Possible parameters to adjust:
!
!  ccn : base cloud condensation nuclei concentration (use namelist.input value "nssl_cccn")
!  alphah, alphahl : Size distribution shape parameters for graupel (h) and hail (hl)
!  infall : changes sedimentation options to see effects (see below)
!
! lightning model references:
!
!    Fierro, A. O., E.R. Mansell, C. Ziegler and D. R. MacGorman 2013: The
!    implementation of an explicit charging and discharge lightning scheme
!    within the WRF-ARW model: Benchmark simulations of a continental squall line, a
!    tropical cyclone and a winter storm. Monthly Weather Review, Volume 141, 2390-2415 
!
!    Mansell et al. 2005: Charge structure and lightning sensitivity in a simulated 
!     multicell thunderstorm. J. Geophys. Res., 110, D12101, doi:10.1029/2004JD005287
!
! Note: Some parameters below apply to unreleased features.
!
!
!---------------------------------------------------------------------
! Sept. 2021:
! Fixes:
!   Restored previous formulation of snow reflectivity, as it was realized that the last change incorrectly assumed a fixed density independent of size. Generally lower snow reflectivity values as a result (no effect on microphysics)
! Other:
!   Generic fall speed coeffecients (axx,bxx) to accomodate future frozen drops category (no effect)
!   Reordered collection coefficients (dab1lh) to be consistent (no effect)
!   Switched to full calculation of rain number loss via collection by graupel (chacr; to be consisted with collection by hail) (minor effects)
!---------------------------------------------------------------------
! April 2021:
! Fixes:
!  Fall speed air density factor limited to air density of 0.05 (for very high model top) to mitigate excessive fall speeds
!  Fixed issue of spurious creation of large concentrations of very small droplets and transient large condensation (also increased minimum droplet size)
!  Fixed issue of negligible "seed" values of graupel from Bigg freezing at relatively high temperatures (thanks to S. Lasher-Trapp)
!  Minor bug fix in effective radius calculation of snow. (thanks to T. Iguchi)
! Updates:
!  Enabled regeneration of CCN by droplet evaporation and background restore (default time constant of 3600s)
!  Updated the routine that handles single-moment variables on the first time step. This sets a higher threshold for meaningful mixing ratios and sets a more realistic droplet concentration (also activating CCN as needed).
!  Enabled radar reflectivity from cloud ice (new formulation) ( idbzci = 1 )
!  Added internal option for ice crystal nucleation by DeMott et al. (2010, PNAS) (inucopt=4)
!  Allow greater fraction of hail to melt in one time step
!  Reduced minimum number concentration from 1e-4 to 1e-8 (based on CAPS input)
!  Added internal namelist for easier access to internal variables for development/testing and easier setup for ensemble microphysics diversity
!    (namelist read is disabled by default)
!  Increased resolution of lookup table for incomplete gamma functions
!
!---------------------------------------------------------------------
! Sept. 2019:
! Bug fixes:
!  - Effective radius calculation was only done at history times. Now every time step (though should be just before radiation is called)
!  - Snow reflectivity: Previous "fix" was incorrect and yields snow dBZ that is too low. Reverted to old version which was correct
!  - Incorrectly updated a state value in the reflectivity code. (Could cause small differences if reflectivity is not calculated)
! Updates:
!  - Added code hints to use the "axtra2d" array to communicate rates from the microphysics routine into any 3d arrays that are passed in to the driver.
!  - Graupel and hail drag coefficients are returned from fall speed subroutine to use in ventilation coeffs. for consistency (minor change)
!  - Added (compile) option flag to turn on diagnosis of cloud droplet shape parameter based on number concentration
!  - Added (compile) option flag icracr to turn off rain self-collection
!  - Added compile options 'depfac' and 'meltfac' to adjust deposition/sublimation and melting (not freezing) rates of graupel/hail by a constant factor (for experimentation). Default value is 1.0
!  - Put limit on snow volume (2 cm) in aggregation rate
!---------------------------------------------------------------------
! WRF 4.0 update:
!  Major:
!   Fixed excessive sublimation that could occur in very strong downdrafts (3.9.1.1 update)
!
!  Minor:
!    icefallopt=3 : New ice crystal fall speed that has faster speeds for small ice particles. Main effect
!                   is on anvil clouds to help them decay a bit faster. Old behavior can be recovered with icefallopt=1
!    Cosmetic: removed stray single quotes because some preprocessors complain about unclosed quotes even in comments
!
!---------------------------------------------------------------------
! WRF 3.9.1.1 update:
!
!  Added a check on overdepletion of ice by sublimation, which could sometimes result in water supersaturation
!  Bug fix: setting of t7 used 'dn' instead of 'dn1' (Thanks to Chunxi Zhang)
!
!---------------------------------------------------------------------
! WRF 3.9 updates:
!
!   2-moment scheme now creates number concentration tendencies from cumulus scheme mass mixing ratio rates
!   Renamed internal gamma function routine from 'gamma' to 'gamma_sp' to avoid name conflicts
!   Restored older settings that allow snow aggregation starting at T > -25C
!   Adjusted Meyers number of activated nuclei by the local air density to compensate for using data at surface
!   Minor updates to rain-ice crystal and hail-rain collection efficiencies
!
!   
!   Reduced minimum mean snow diameter from 100 microns to 10 microns
!
!---------------------------------------------------------------------
! WRF 3.8 updates:
!   Fixed issue with reflectivity conservation for graupel melting into rain. Rain number concentrations were too low,
!       resulting in excessive reflectivity of a couple dBZ
!   Changed default value of iusewetgraupel to 1 (turns off diagnostic meltwater on graupel for reflectivity)
!   Apply a 70 m/s fall speed limit for sedimentation
!   Changed vapor ice nucleation to Meyers-Ferrier method (original scheme)
!   New method for Bigg freezing (ibiggopt=2)
!   Reduced snow aggregration efficiency and restricted aggregation to higher temperatures (assuming dendrites and mechanical aggregation)
!   Increased maximum graupel-droplet collection efficiency when hail is turned off (nssl_2momg)
!   Updates for compatibility with WRF-NMM
!   Added calculation of hail number concentration in calcnfromq (creates number concentration from mixing ratio
!       when starting from an analysis). And fixed error in graupel intercept
!   Bug fix in snow fall speeds
!   Further fix in snow reflectivity
!   Use diameter of maximum mass rather than mean diamter when checking maximum size
!   Helped performance in sedimentation with flag "do_accurate_sedimentation" to control recalculation of fall speeds when
!       more than one sub-time step is needed (often happens with large time steps and small dz near the ground):
!        = .true. : recalculates fall speed after each substep (more accurate)
!        = .false. : (default) reuses fall speeds calculated on the first substep (typical for most schemes), theoretically could cause an occasional glitch, but none seen in practice
!   Increased maximum mean droplet radius from 40 to 60 microns, which alleviates spurious number concentration increases at low CCN concentration.
!   Removed a duplicate factor from hail reflectivity that was causing a loss of about 6 dBZ (since WRF 3.5).
!
!---------------------------------------------------------------------



MODULE module_mp_nssl_2mom

  IMPLICIT NONE
  
  public nssl_2mom_driver
  public nssl_2mom_init
  private gamma_sp,gamxinf,GAML02, GAML02d300, GAML02d500, fqvs, fqis
  private gamma_dp, gamxinfdp, gamma_dpr
  private delbk, delabk
  private gammadp
  
  logical, private :: cleardiag = .false.
  PRIVATE

#if ( WRF_CHEM == 1 )
  integer, parameter :: wrfchem_flag = 1
#else
  integer, parameter :: wrfchem_flag = 0
#endif

   LOGICAL, PRIVATE:: is_aerosol_aware = .false.
      
      logical, private :: turn_on_cin = .false.
  
  integer, private :: eqtset = 1 ! Flag for use with cm1 to use alternate equation set (changes latent heating rates)
                                 ! value of > 2 invokes the equivalent version of eqtset=2 that applies updates to both theta and Pi.
   double precision, parameter, public :: zscale = 1.0d0 ! 1.000e-10
   double precision, parameter, public :: zscaleinv = 1.0d0/zscale ! 1.000e-10

  
  real, parameter :: warmonly = 0.0 ! testing parameter, set to 1.0 to reduce to warm-rain physics (ice variables stay zero)
  
  logical, parameter :: lwsm6 = .false. ! act like wsm6 for some single moment interactions

! some constants from WSM6
  real, parameter  :: dimax = 500.e-6    ! limited maximum value for the cloud-ice diamter
  real, parameter  :: roqimax = 2.08e22*dimax**8
  
! Params for dbz:
  integer  :: iuseferrier = 1  ! =1: use dry graupel only from Ferrier 1994; = 0: Use Smith (wet graupel)
  integer  :: idbzci      = 1
  integer  :: iusewetgraupel = 1 ! =1 to turn on use of QHW for graupel reflectivity (only for ZVDM -- mixedphase)
                                 ! =2 turn on for graupel density less than 300. only 
  integer  :: iusewethail = 0 ! =1 to turn on use of QHW for graupel reflectivity (only for ZVDM -- mixedphase)
  integer  :: iusewetsnow = 1 ! =1 to turn on diagnosed bright band; =2 'old' snow reflectivity (dry), =3 'old' snow dbz + brightband

! microphysics

  real, private :: rho_qr = 1000., cnor = 8.0e5  ! cnor is set in namelist!!  rain params
  real, private :: rho_qs =  100., cnos = 3.0e6  ! set in namelist!!  snow params
  real, private :: rho_qh =  500., cnoh = 4.0e5  ! set in namelist!!  graupel params
  real, private :: rho_qhl=  900., cnohl = 4.0e4 ! set in namelist!!  hail params

  real, private :: hdnmn  = 170.0  ! minimum graupel density (for variable density graupel)
  real, private :: hldnmn = 500.0  ! minimum hail density (for variable density hail)

  real :: cnohmn  = 1.e-2 ! minimum intercept for 2-moment graupel (alphah < 0.5)
  real :: cnohlmn = 1.e-2 ! minimum intercept for 2-moment hail (alphahl < 0.5)
  
! Autoconversion parameters

  real   , private :: qcmincwrn      = 2.0e-3    ! qc threshold for autonconversion (LFO; for 10ICE use qminrncw for ircnw != 5)
  real   , private :: cwdiap         = 20.0e-6   ! threshold diameter of cloud drops (Ferrier 1994 autoconversion)
  real   , private :: cwdisp         = 0.15      ! assume droplet dispersion parameter (can be 0.3 for maritime)
  real   , private  :: ccn            = 0.6e+09   ! set in namelist!! Central plains CCN value
  real   , public  :: qccn             ! ccn "mixing ratio"
  integer, private :: iauttim        = 1         ! 10-ice rain delay flag
  real   , private :: auttim         = 300.      ! 10-ice rain delay time
  real   , private :: qcwmntim       = 1.0e-5    ! 10-ice rain delay min qc for time accrual

#if (NMM_CORE == 1)
! NMM WRF core does not have special boundary conditions for CCN, therefore set invertccn to true
      logical, parameter :: invertccn = .true. ! =true for base state of ccn=0, =false for ccn initialized in the base state
#else
      logical, parameter :: invertccn = .false. ! =true for base state of ccn=0, =false for ccn initialized in the base state
#endif
  logical :: restoreccn = .true. ! whether or not to nudge CCN back to base state (qccn) (only applies if CCNA is NOT predicted)
  real    :: ccntimeconst = 3600.  ! time constant for CCN restore (either for CCNA or when restoreccn = true)

! sedimentation flags
! itfall -> 0 = 1st order fallout (other options removed)
! iscfall, infall -> fallout options for charge and number concentration, respectively
!                    1 = mass-weighted fall speed; 2 = number-weighted fallspeed.
  integer, private :: itfall = 0
  integer, private :: iscfall = 1
  integer, private :: irfall = -1
  logical, private :: do_accurate_sedimentation = .false. ! if true, recalculate fall speeds on sub time steps; (more expensive)
                                                         ! if false, reuse fall speeds on multiple steps (can have a noticeable speedup)
                                                         ! Mainly is an issue for small dz near the surface. 
  integer, private :: interval_sedi_vt = 1 ! interval for recalculating Vt in sedimentation subloop (only when do_accurate_sedimentation = .true.)
  integer, private :: infall = 4   ! 0 -> uses number-wgt for N; NO correction applied (results in excessive size sorting)
                          ! 1 -> uses mass-weighted fallspeed for N ALWAYS
                          ! 2 -> uses number-wgt for N and mass-weighted correction for N (Method II in Mansell, 2010 JAS)
                          ! 3 -> uses number-wgt for N and Z-weighted correction for N (Method I in Mansell, 2010 JAS)
                          ! 4 -> Hybrid of 2 and 3: Uses minimum N from each method (z-wgt and m-wgt corrections) (Method I+II in Mansell, 2010 JAS)
                          ! 5 -> uses number-wgt for N and uses average of N-wgt and q-wgt instead of Max.
  real, private    :: rainfallfac = 1.0 ! factor to adjust rain fall speed (single moment only)
  real, private    :: icefallfac = 1.0 ! factor to adjust ice fall speed
  real, private    :: snowfallfac = 1.0 ! factor to adjust snow fall speed
  real, private    :: graupelfallfac = 1.0 ! factor to adjust graupel fall speed
  real, private    :: hailfallfac = 1.0 ! factor to adjust hail fall speed
  integer, private :: icefallopt = 3 ! 1= default, 2 = Ferrier ice fall speed; 3 = adjusted Ferrier (slightly high Vt)
  integer, private :: icdx = 3 ! (graupel) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc.
  integer, private :: icdxhl = 3 ! (hail) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc.
  real   , private :: cdhmin = 0.45, cdhmax = 0.8        ! defaults for graupel (icdx=4)
  real   , private :: cdhdnmin = 500., cdhdnmax = 800.0  ! defaults for graupel (icdx=4)
  real   , private :: cdhlmin = 0.45, cdhlmax = 0.6      ! defaults for hail (icdx=4)
  real   , private :: cdhldnmin = 500., cdhldnmax = 800.0  ! defaults for hail (icdx=4)
  real   , private :: vtmaxsed = 70. ! Limit on fall speed (m/s, all moments) for sedimentation calculations. Not applied to fall speeds for microphysical rates
  
  integer :: rssflg = 1   ! Rain size-sorting allowed (1, default), or disallowed (0).  If 0, sets N and Z-weighted fall speeds to q-weighted value
  integer :: sssflg = 1   ! As above but for snow
  integer :: hssflg = 1   ! As above but for graupel
  integer :: hlssflg = 1  ! As above but for hail

! input flags

  integer, private :: ndebug = -1, ncdebug = 0
  integer, private :: ipconc = 5
  integer, private :: inucopt = 0
  integer, private :: ichaff = 0
  integer, parameter :: ilimit = 0
  
  real, private :: constccw = -1.

  real, private :: cimn = 1.0e3, cimx = 1.0e6

  real   , private :: rhofrz = 900 ! density of freezing drops
  real   , private :: ifrzg = 1.0 ! fraction of frozen drops (Bigg freezing) going to graupel. 1=freeze all rain to graupel, 0=freeze all to hail
  real   , private :: ifiacrg = 1.0 ! fraction of frozen drops (3-component freezing qiacr) going to graupel. 1=freeze all rain to graupel, 0=freeze all to hail
  real   , private :: ifrzs = 1.0 ! fraction of small frozen drops going to snow. 1=freeze rain to snow, 0=freeze to cloud ice
  real   , private :: ffrzs = 0.0 ! fraction of other initiated cloud ice going to snow. 1=freeze rain to snow, 0=freeze to cloud ice
  real   , private :: f2h = 1.0 ! fraction of cloud ice conversion going to graupel (vs. frozen drops). For testing
  integer, private :: irwfrz = 1 ! compute total rain that can freeze (checks heat budget)
  integer, private :: irimtim = 0 ! future use
!  integer, private :: infdo = 1   ! 1 = calculate number-weighted fall speeds

  integer, private :: irimdenopt = 1 ! = 1 for default Macklin; = 2 for experimental Cober and List (1993)
  real   , private :: rimc1 = 300.0, rimc2 = 0.44  ! rime density coeff. and power (Default Heymsfield and Pflaum, 1985)
  real   , private :: rimc3 = 170.0                ! minimum rime density
  real    :: rimc4 = 900.0                ! maximum rime density
  real   , private :: rimtim = 120.0               ! cut-off rime time (10ICE)
  real   , private :: eqtot = 1.0e-9               ! threshold for mass budget reporting
  real, private :: rimdenvwgt = 0.0 ! weight (0-1) given to number-weighted fall speed when calculating rime density

  integer, private :: ireadmic = 0

  integer, private :: idiagnosecnu = 0 ! =1 to diagnose cnu based on Chandrakar et al. 2016 data; =2 for Geoffroy et al. (2010, ACP)
  integer, private :: iccwflg = 1     ! sets max size of first droplets in parcel to 4 micron radius (in two-moment liquid)
                             ! (first nucleation is done with a KW sat. adj. step)
  integer, private :: issfilt = 0     ! flag to turn on filtering of supersaturation field
  integer, private :: icnuclimit = 0  ! limit droplet nucleation based on Konwar et al. (2012) and Chandrakar et al. (2016)
  integer, private :: irenuc = 2      ! =1 to always allow renucleation of droplets within the cloud
                                      ! =2 renucleation following Twomey/Cohard&Pinty
                                      ! =7 New renucleation that requires prediction of the number of activated nuclei
                             ! i.e., not only at cloud base
  integer, private :: irenuc3d = 0      ! =1 to include horizontal gradient in renucleation of droplets within the cloud
  real    :: renucfrac = 0.0 ! = 0 : cnuc = cwccn
                             ! = 1 : cnuc = actual available CCN
                             ! otherwise cnuc = cwccn*(1. - renufrac) + ccnc(1:ngscnt)*renucfrac
  real    :: ssf2kmax = 10. ! max value for ssf**cck in irenuc=4 or 5
  real   , private :: cck = 0.6       ! exponent in Twomey expression
  real   , private :: ciintmx = 1.0e6 ! limit on ice concentration from primary nucleation

  real   , private :: cwccn ! , cwmasn,cwmasx
  real   , private :: ccwmx

  integer, private :: idocw = 1, idorw = 1, idoci = 1, idoir = 1, idoip = 1, idosw = 1
  integer, private :: idogl = 1, idogm = 1, idogh = 1, idofw = 1, idohw = 1, idohl = 1
!  integer, private :: ido(3:14) = / 12*1 /


! 0,2, 5.00e-10, 1, 0, 0, 0      : itype1,itype2,cimas0,icfn,ihrn,ibfc,iacr
  integer, private :: itype1 = 0, itype2 = 2  ! controls Hallett-Mossop process
  integer, private :: icenucopt = 1       ! =1 Meyers/Ferrier primary ice nucleation; =2 Thompson/Cooper, =3 Phillips (Meyers/Demott), =4 DeMott (2010)
  real, private :: naer = 1.0e6  ! background large aerosol conc. for DeMott
  integer, private :: icfn = 2                ! contact freezing: 0 = off; 1 = hack (ok for single moment); 2 = full Cotton/Meyers version
  integer, private :: ihrn = 0            ! Hobbs-Rangno ice multiplication (Ferrier, 1994; use in 10-ice only)
  integer, private :: ibfc = 1            ! Flag to use Bigg freezing on droplets (0 = off (uses alternate freezing), 1 = on)
  real, private  :: cwfrz2snowfrac = 0.0 ! fraction of freezing droplet mass to send to snow
  real, private  :: cwfrz2snowratio = 5. ! Assumed number of frozen droplets in a cluster
  integer, private :: iremoveqwfrz = 1    ! Whether to remove (=1) or not (=0) the newly-frozen cloud droplets (ibfc=1) from the CWC used for charge separation
  integer, private :: iacr = 2            ! Flag for drop contact freezing with crytals
                                 ! (0=off; 1=drops > 500micron diameter; 2 = > 300micron)
  integer, private :: icracr = 1          ! Flag to turn rain self-collection on/off (=0 to turn off)
  integer, private :: ibfr = 2            ! Flag for Bigg freezing conversion of freezing drops to graupel
                                 ! (1=min graupel size is vr1mm; 2=use min size of dfrz, 5= as for 2 and apply dbz conservation)
  integer, private :: ibiggopt = 2        ! 1 = old Bigg; 2 = experimental Bigg (only for imurain = 1, however)
  integer :: ibiggsmallrain = 0  ! 1 = When rain is too small, freeze none to graupel and send all to snow (experimental)
  integer, private :: iacrsize = 5        ! assumed min size of drops freezing by capture
                                 !  1: > 500 micron diam
                                 !  2: > 300 micron
                                 !  3: > 40 micron
                                 !  4: all sizes
                                 !  5: > 150 micron (only for imurain = 1)
  real   , private :: cimas0 = 6.62e-11   ! default mass of Hallett-Mossop crystals
                                 ! 6.62e-11kg results in half the diam. (60 microns) of old default value of 5.0e-10
  real   , private :: cimas1 = 6.88e-13   ! default mass of new ice crystals
  real   , private :: splintermass = 6.88e-13
  real   , private :: cfnfac = 0.1        ! Hack factor that goes with icfn=1
  integer, private :: iscni = 4           ! default option for ice crystal aggregation/conversion to snow
  real   , private :: fscni = 1.0         ! factor for calculating cscni
  logical, private :: imeyers5 = .false.  ! .false.=off, true=on for Meyers ice nucleation for temp > -5 C
  real   , private :: dmincw = 15.0e-6    ! minimum droplet diameter for collection for iehw=3
  integer, private :: iehw = 1            ! 0 -> ehw=ehw0; 1 -> old ehw; 2 -> test ehw with Mason table data
  integer, private :: iefw = 1            ! 0 -> ehw=ehw0; 1 -> old ehw; 2 -> test ehw with Mason table data
  integer, private :: iehlw = 1           ! 0 -> ehlw=ehlw0; 1 -> old ehlw; 2 -> test ehlw with Mason table data
                                 ! For ehw/ehlw = 1, ehw0/ehlw0 act as maximum limit on collection efficiency (defaults are 1.0)
  integer, private :: ierw = 1            ! for single-moment rain (LFO/Z)
  integer, private :: iehr0c = 0          ! 0 -> no collection for T > 0C;  1 -> turn on collection/shedding for T > 0C
  integer, private :: iehlr0c = 0         ! 0 -> no collection for T > 0C;  1 -> turn on collection/shedding for T > 0C
  real   , private :: ehw0 = 0.5          ! constant or max assumed graupel-droplet collection efficiency
  real   , private :: erw0 = 1.0          ! constant assumed rain-droplet collection efficiency
  real   , private :: ehlw0 = 0.75        ! constant or max assumed hail-droplet collection efficiency
  real   , private :: efw0 = 0.5          ! constant or max assumed graupel-droplet collection efficiency
  real    :: ehr0 = 1.0          ! constant or max assumed graupel-rain collection efficiency
  real    :: efr0 = 1.0          ! constant or max assumed graupel-rain collection efficiency
  real    :: ehlr0 = 1.0         ! constant or max assumed hail-rain collection efficiency
  real   , private :: exwmindiam = 0.0    ! minimum diameter of droplets for riming. If set > 0, will exclude that fraction of mass/number from accretion (idea from Furtado and Field 2017 JAS but also Fierro and Mansell 2017)
  

  real   , private :: esilfo0 = 1.0       ! factor for LFO collection efficiency of snow for cloud ice.
  real   , private :: ehslfo0 = 1.0       ! factor for LFO collection efficiency of hail/graupel for snow.

  integer, private :: ircnw    = 5        ! single-moment warm-rain autoconversion option.  5= Ferrier 1994.
  real   , private :: qminrncw = 2.0e-3   ! qc threshold for rain autoconversion (NA for ircnw=5)

  integer, private :: iqcinit = 2         ! For ZVDxx schemes, flag to choose which way to initialize droplets
                                 ! 1 = Soong-Ogura adjustment
                                 ! 2 = Saturation adjustment to value of ssmxinit
                                 ! 3 = KW adjustment

  real   , private :: ssmxinit = 0.4      ! saturation percentage to adjust down to for initial cloud
                                 ! formation (ZVDxx scheme only)

  real   , private :: ewfac = 1.0         ! hack factor applied to graupel and hail collection eff. for droplets
  real   , private :: eii0 = 0.1 ,eii1 = 0.1  ! graupel-crystal coll. eff. parameters: eii0*exp(eii1*min(temcg(mgs),0.0))
                                     ! set eii1 = 0 to get a constant value of eii0
  real   , private :: eii0hl = 0.2 ,eii1hl = 0.0  ! hail-crystal coll. eff. parameters: eii0hl*exp(eii1hl*min(temcg(mgs),0.0))
                                     ! set eii1hl = 0 to get a constant value of eii0hl
  real   , private :: eri0 = 0.1   ! rain efficiency to collect ice crystals
  real   , private :: eri_cimin = 10.e-6      ! minimum ice crystal diameter for collection by rain
  real   , private :: esi0 = 0.1              ! linear factor in snow-ice collection efficiency
  real   , private :: ehs0 = 0.1, ehs1 = 0.1  ! graupel-snow coll. eff. parameters: ehs0*exp(ehs1*min(temcg(mgs),0.0))
                                     ! set ehs1 = 0 to get a constant value of ehs0
  real   , private :: ess0 = 1.0, ess1 = 0.05 ! snow aggregation coefficients: ess0*exp(ess1*min(temcg(mgs),0.0))
                                     ! set ess1 = 0 to get a constant value of ess0
  real   , private :: esstem1 = -25.  ! lower temperature where snow aggregation turns on
  real   , private :: esstem2 = -20.  ! higher temperature for linear ramp of ess from zero at esstem1 to formula value at esstem2
  real   , private :: essrmax = 0.02  ! maximum snow radius (meters) for csacs
  real   , private :: essfrac1 = 0.5  ! snow mass fraction 1 for aggregation roll-off
  real   , private :: essfrac2 = 0.75 ! snow mass fraction 2 for aggregation roll-off
  integer, private :: iessec0flag = 0 ! flag to activate aggregation roll-off
  real   , private :: ehsfrac = 1.0           ! multiplier for graupel collection efficiency in wet growth
  real   , private :: ehimin = 0.0 ! Minimum collection efficiency (graupel - ice crystal)
  real   , private :: ehimax = 1.0 ! Maximum collection efficiency (graupel - ice crystal)
  real   , private :: ehsmax = 0.5 ! Maximum collection efficiency (graupel - snow)
  real   , private :: ecollmx = 0.5 ! Maximum collision efficiency for graup/hail with ice; used only for charging rates
  integer, private :: iglcnvi = 1  ! flag for riming conversion from cloud ice to rimed ice/graupel
  integer, private :: iglcnvs = 2  ! flag for conversion from snow to rimed ice/graupel

  real   , private :: rz          ! reflectivity conservation factor for graupel/rain
                         ! now calculated in icezvd_dr.F from alphah and rnu
                         ! currently only used for graupel melting to rain
  real   , private :: rzhl        ! reflectivity conservation factor for hail/rain
                         ! now calculated in icezvd_dr.F from alphahl and rnu

  real   , private :: rzs     ! reflectivity conservation factor for snow(imusnow=3) with rain (imurain=1)

  real   , private :: alphahacx = 0.0 ! assumed minimum shape parameter for zhacw and zhacr

  real   , private :: fconv = 1.0  ! factor to boost max graupel depletion by riming conversions in 10ICE

  real   , private :: rg0 = 400.0  ! reference graupel density for graupel fall speed

  integer, private :: rcond = 2    ! (Z only) rcond = 2 includes rain condensation in loop with droplet condensation
                                   ! 0 = no condensation on rain; 1 = bulk condensation on rain
  integer, parameter, private :: icond = 1    ! (Z only) icond = 1 calculates ice deposition (crystals and snow) BEFORE droplet condensation
                          ! icond = 2 does not work (intended to calc. dep in loop with droplet cond.)
  
  real   , private :: dfrz = 0.15e-3 ! 0.25e-3  ! minimum diameter of frozen drops from Bigg freezing (used for vfrz) for iacr > 1
                            ! and for ciacrf for iacr=4
  real   , private :: dmlt = 3.0e-3  ! maximum diameter for rain melting from graupel and hail
  real   , private :: dshd = 1.0e-3  ! nominal diameter for rain drops shed from graupel/hail
  integer, private :: ished2cld = 0  ! 1: Send shed liquid (from wet growth) to cloud droplets

  integer, private :: ihmlt = 2      ! 1=old melting with vmlt; 2=new melting using mean volume diam of graupel/hail
  integer, private :: imltshddmr = 2 ! 0 (default)=mean diameter of drops produced during melting+shedding as before (using mean diameter of graupel/hail
                            ! and max mean diameter of rain)
                            ! 1=new method where mean diameter of rain during melting is adjusted linearly downward 
                            ! toward 3 mm for large (> sheddiam) graupel and hail, to take into account shedding of 
                            ! smaller drops.  sheddiam0 controls the size of graupel/hail above which the assumed 
                            ! mean diameter of rain is set to 3 mm
                            ! Only valid for ihmlt = 2 for ZVD(H) but also applies to ZVD(H)M
                            ! 2 = method that sets the resulting rain size ( vshdgs ) according to the mass-weighted diameter of the ice

   real  :: mltdiam1 = 9.0e-3, mltdiam2 = 16.0e-3, mltdiam3 = 19.0e-3, mltdiam4 = 200.0e-3, mltdiam05 = 4.5e-3

  integer, private :: nsplinter = 0  ! number of ice splinters per freezing drop, if negative, then per resulting graupel particle
  real,    private :: lawson_splinter_fac = 2.5e-11  ! constant in Lawson et al. (2015, JAS) for ice particle production from freezing drops
  integer, private :: isnwfrac = 0   ! 0= no snow fragmentation; 1 = turn on snow fragmentation (Schuur, 2000)

!  integer, private :: denscale = 1  ! 1=scale num. conc. and charge by air density for advection, 0=turn off for comparison

  real, private  :: qhdpvdn = -1.
  real, private  :: qhacidn = -1.

  logical, private :: mixedphase = .false.   ! .false.=off, true=on to include mixed phase graupel
  integer, private :: imixedphase = 0
  logical, private :: qsdenmod = .false.     ! true = modify snow density by linear interpolation of snow and rain density
  logical, private :: qhdenmod = .false.     ! true = modify graupel density by linear interpolation of graupel and rain density
  logical, private :: qsvtmod = .false.      ! true = modify snow fall speed by linear interpolation of snow and rain vt
  real   , private :: sheddiam   = 8.0e-03  ! minimum diameter of graupel before shedding occurs
  real    :: sheddiamlg = 10.0e-03  ! diameter of hail to use fwmlarge
  real    :: sheddiam0  = 20.0e-03  ! diameter of hail at which all water is shed
  
  integer :: ifwmhopt = 2 ! option for calculating maximum liquid fraction when fwmh and/or fwmhl is set to -1
                          ! 1 = maximum based on size of maximum mass diameter
                          ! 2 = integrate over spectrum for maximum liquid (experimental)

  integer :: ihxw2rain = 0 ! = 0 no transfer
                           ! = 1 transfer completely melted (99.5%) graupel/hail to rain when fwmh/fwmhl is set to -1.

  real   , private :: fwms = 0.5 ! maximum liquid water fraction on snow
  real   , private :: fwmh = 0.5 ! maximum liquid water fraction on graupel
  real   , private :: fwmhl = 0.5 ! maximum liquid water fraction on hail
  real    :: fwmlarge = 0.2 ! maximum liquid water fraction on hail larger than sheddiam
  integer :: ifwmfall = 0   ! whether to interpolate toward rain fall speed for graupel and hail
                            ! when diam < sheddiam and liquid fraction is predicted (0=no, 1=yes)
  
  logical :: rescale_high_alpha = .false.  ! whether to rescale number. conc. when alpha = alphamax (3-moment only)
  logical :: rescale_low_alpha = .true.    ! whether to rescale Z (graupel/hail) when alpha = alphamin (3-moment only)
  logical :: rescale_low_alphar = .true.    ! whether to rescale Z for rain when alpha = alphamin (3-moment only)
  logical :: rescale_low_alphah = .true.    ! whether to rescale Z for rain when alpha = alphamin (3-moment only)
  logical :: rescale_low_alphahl = .true.    ! whether to rescale Z for rain when alpha = alphamin (3-moment only)

  real, parameter :: alpharmax = 8. ! limited for rwvent calculation
  
  integer, private ::  ihlcnh = 1  ! which graupel -> hail conversion to use
                          ! 1 = Milbrandt and Yau (2005) using Ziegler 1985 wet growth diameter
                          ! 2 = Straka and Mansell (2005) conversion using size threshold
  real, private :: hlcnhdia = 1.e-3 ! threshold diameter for graupel -> hail conversion for ihlcnh = 1 option.
  real, private :: hlcnhqmin = 0.1e-3 ! minimum graupel mass content for graupel -> hail conversion (ihlcnh = 1)
  real   , private :: hldia1 = 20.0e-3  ! threshold diameter for graupel -> hail conversion for ihlcnh = 2 option.
  integer, private  :: iusedw = 0    ! flag to use experimental wet growth ice diameter for gr -> hl conversion (=1 turns on)
  real   , private  :: dwmin  = 0.0  ! Minimum diameter with iusedw (can stay at 0 or be set to something larger)
  real   , private  :: dwtempmin = 242. ! lowest temperature to allow wet growth conversion to hail
  real   , private  :: dwehwmin = 0.   ! Minimum ehw to use to find wet growth diameter (if > ehw0, then wet growth diam becomes smaller)
  real   , private  :: dg0thresh = 0.15 ! graupel wet growth diameter above which we say do not bother
  integer :: icvhl2h = 0   ! allow conversion of hail back to graupel when hail density gets close to minimum allowed

  integer, private :: imurain = 1 ! 3 for gamma-volume, 1 for gamma-diameter DSD for rain.
  integer, private :: imusnow = 3 ! 3 for gamma-volume, 1 for gamma-diameter DSD for snow (=1 NOT IMPLEMENTED!!).
  integer, private :: iturbenhance = 0 ! warm-rain collision enhancement
                              ! 1 = enhance autoconversion only
                              ! 2 = add rain collection of cloud
                              ! 3 = add rain self-collection
  integer, private :: isedonly = 0 ! 1= only do sedimentation and skip other microphysics
  integer, private :: iferwisventr = 2 ! =1 for Ferrier rwvent, =2 for Wisner rwvent (imurain=1)
  integer, private :: izwisventr   = 2 ! =1 for old Ziegler rwvent, =2 for Wisner-style rwvent (imurain=3)
  integer :: iresetmoments = 0 ! if >0, then set all moments to zero when one of them is zero (3-moment only)
  integer, private :: imaxdiaopt = 3 
                               ! = 1 use mean diameter for breakup
                               ! = 2 use maximum mass diameter for breakup
                               ! = 3 use mass-weighted diameter for breakup
  integer, private :: dmrauto       = 0 
                              ! = -1 no limiter on crcnw
                              ! =  0 limit crcnw when qr > 1.2*L (Cohard-Pinty 2002)
                              ! =  1 DTD version based on MY code
                              ! =  2 DTD mass-weighted version based on MY code
                              ! =  3 Milbrandt version (from Cohard and Pinty code
  integer :: dmropt = 0 ! extra option for crcnw
  integer :: dmhlopt = 1 ! options for graupel -> conversion
  integer :: irescalerainopt = 3 ! 0 = default option
                                 ! 1 = qx(mgs,lc) > qxmin(lc) 
                                 ! 2 = qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < 3.0
                                 ! 3 = temcg(mgs) > 0.0.and. qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < 3.0 
  real    :: rescale_wthresh = 3.0
  real    :: rescale_tempthresh = 0.0
  real, parameter :: alpharaut = 0.0 ! MY2005 for autoconversion
  real    :: cxmin = 1.e-8  ! threshold cutoff for number concentration
  real    :: zxmin = 1.e-28 ! threshold cutoff for reflectivity moment
  
  integer :: ithompsoncnoh = 0 ! For single moment graupel only
                           ! 0 = fixed intercept
                           ! 1 = intercept based on graupel mass

  integer :: ivhmltsoak = 1   ! 0=off, 1=on : flag to simulate soaking (graupel/hail) during melting 
                         ! when liquid fraction is not predicted
  integer, private :: ioldlimiter = 0 ! test switch for new(=0) or old(=1) size limiter at the end of GS for 3-moment categories
  integer, private :: isnowfall = 2   ! Option for choosing between snow fall speed parameters
                         ! 1 = original Zrnic et al. (Mansell et al. 2010)
                         ! 2 = Ferrier 1994 (results in slower fall speeds)

  integer, private :: isnowdens = 1   ! Option for choosing between snow density options
                             ! 1 = constant of 100 kg m^-3
                             ! 2 = Option based on Cox 
  
  integer, private  :: ibiggsnow   = 3 ! 1 = switch conversion over to snow for small frozen drops from Bigg freezing
                                       ! 2 = switch conversion over to snow for small frozen drops from rain-ice interaction
                                       ! 3 = switch conversion over to snow for small frozen drops from both
  real    :: biggsnowdiam = -1.0 ! If >0, use for ibiggsnow threshold
  
  integer, private  :: ixtaltype = 1 ! =1 column, =2 disk (similar to Takahashi)

  real, private  :: takshedsize1 = 0.15 ! diameter (cm) of drop shed from ice with D > 1.9 cm
  real, private  :: takshedsize2 = 0.3 ! diameter (cm) of drop shed from ice with D < 1.9 cm and D > 0.8 cm
  real, private  :: takshedsize3 = 0.45 ! diameter (cm) of drop shed from ice with D < 1.6 cm and D > 0.8 cm
  integer, private  :: numshedregimes = 3
  
  real, private     :: evapfac     = 1.0 ! Multiplier on rain evaporation rate
  real, private     :: depfac      = 1.0 ! Multiplier on graupel/hail deposition/sublimation rate
  real,private,parameter :: meltfac     = 1.0 ! Multiplier on graupel/hail melting rate

  integer, private :: ibinhmlr = 0  ! =1 use incomplete gammas to determine melting from larger and smaller sizes of graupel, and appropriate shed drop sizes 
                           ! =2 to test melting by temporary bins
  integer, private :: ibinhlmlr = 0  ! =1 use incomplete gammas to determine melting from larger and smaller sizes of hail, and appropriate shed drop sizes 
                            ! =2 to test melting by temporary bins
  integer, private :: ibinnum   = 2  ! number of bins for melting of smaller ice (for ibinhmlr = 1)
  integer, private :: iqhacrmlr = 1  ! turn on/off qhacrmlr
  integer, private :: iqhlacrmlr = 1  ! turn on/off qhlacrmlr
  real, private :: binmlrmxdia = 40.e-3 ! threshold diameter (graupel/hail) to switch bin-bulk melting to use standard chmlr
  real, private :: binmlrzrrfac = 1.0 ! factor for reflectivity change ice that sheds while melting
  real, private :: snowmeltdia = 0 ! If nonzero, sets the size of rain drops from melting snow.
  real, private :: delta_alphamlr = 0.5 ! offset from alphamax at which melting does not further collapse the shape parameter
  
  integer :: iqvsopt = 0 ! =0 use old default for tabqvs; =1 use Bolton formulation (Rogers and Yau)

  integer :: imaxsupopt = 4 ! how to treat saturation adjustment in two-moment droplets
                            ! 1 = add droplets with same mean mass as current droplets
                            ! 2 = add droplets with minimum radius of 30 microns
                            ! 3 = only add 1.5*cxmin to number concentration (allow max size to apply)
                            ! 4 = add droplets with minimum radius of 20 microns
  real    :: maxsupersat = 1.9 ! maximum supersaturation ratio, above which a saturation adustment is done
  real    :: ssmxuf = 4.0 ! supersaturation at which to start using "ultrafine" CCN (if ccnuf > 0.)
  

  integer, parameter :: icespheres = 0 ! turn ice spheres (frozen droplets) on (1) or off (0). NOT COMPLETE IN WRF/ARPS/CM1 CODE!
  integer, parameter :: lqmx = 30
  integer, parameter :: lt = 1
  integer, parameter :: lv = 2
  integer, parameter :: lc = 3
  integer, parameter :: lr = 4
  integer, parameter :: li = 5
  integer, private :: lis = 0
  integer, private :: ls = 6
  integer, private :: lh = 7
  integer, private :: lf = 0
  integer, private :: lhl = 0

  integer, private  :: lccn = 9 ! 0 or 9, other indices adjusted accordingly
  integer, private :: lccnuf = 0
  integer, private :: lccna = 0
  integer, private :: lcina = 0
  integer, private :: lcin = 0
  integer, private :: lnc = 9
  integer, private :: lnr = 10
  integer, private :: lni = 11
  integer, private :: lnis = 0
  integer, private :: lns = 12
  integer, private :: lnh = 13
  integer, private :: lnf = 0
  integer, private :: lnhl = 0
  integer, private :: lnhf = 0
  integer, private :: lnhlf = 0
  integer, private :: lss = 0
  integer :: lvh = 15

  integer, private :: lhab = 8
  integer, private :: lg = 7

! Particle volume

  integer :: lvi = 0
  integer :: lvs = 0
  integer :: lvgl = 0
  integer :: lvgm = 0
  integer :: lvgh = 0
  integer :: lvf = 0
!  integer :: lvh = 16
  integer :: lvhl = 0

! liquid water fraction (not predicted here but tested for)
  integer :: lhw = 0
  integer :: lfw = 0
  integer :: lsw = 0
  integer :: lhlw = 0
  integer :: lhwlg = 0
  integer :: lhlwlg = 0

! reflectivity (6th moment) ! not predicted here but may be tested against

  integer :: lzr = 0
  integer :: lzi = 0
  integer :: lzs = 0
  integer :: lzgl = 0
  integer :: lzgm = 0
  integer :: lzgh = 0
  integer :: lzf = 0
  integer :: lzh = 0
  integer :: lzhl = 0

! Space charge

  integer :: lscw = 0
  integer :: lscr = 0
  integer :: lsci = 0
  integer :: lscis = 0
  integer :: lscs = 0
  integer :: lsch = 0
  integer :: lscf = 0
  integer :: lschl = 0
  integer :: lscwi = 0
  integer :: lscpi = 0
  integer :: lscni = 0
  integer :: lscpli = 0
  integer :: lscnli = 0
  integer :: lschab = 0

  integer :: lscb = 0
  integer :: lsce = 0
  integer :: lsceq = 0

!  integer, parameter :: lscmx = 100

  integer :: lne = 0 ! last varible for transforming

  real :: cnoh0 = 4.0e+5
  real :: hwdn1 = 700.0

  real    :: alphai  = 0.0 ! shape parameter for ZIEG ice crystals ! not currently used
  real    :: alphas  = 0.0 ! shape parameter for ZIEG snow         ! used only for single moment
  real    :: alphar  = 0.0 ! shape parameter for rain (imurain=1 only)
  real, private    :: alphah  = 0.0 ! set in namelist!! shape parameter for ZIEG graupel
  real, private    :: alphahl = 1.0 ! set in namelist!! shape parameter for ZIEG hail

  real    :: dmuh    = 1.0  ! power in exponential part (graupel)
  real    :: dmuhl   = 1.0  ! power in exponential part (hail)

  real, private   :: alphamax = 15.
  real, private   :: alphamin = 0.
  real, parameter :: rnumin = -0.8
  real, parameter :: rnumax = 15.0

  
  real            :: cnu = 0.0 ! default value of droplet shape parameter. Can be diagnosed by setting idiagnosecnu=1
  real, parameter :: rnu = -0.8, snu = -0.8, cinu = 0.0
!      parameter ( cnu = 0.0, rnu = -0.8, snu = -0.8, cinu = 0.0 )
  
  real xnu(lc:lqmx) ! 1st shape parameter (mass)
  real xmu(lc:lqmx) ! 2nd shape parameter (mass)
  real dnu(lc:lqmx) ! 1st shape parameter (diameter)
  real dmu(lc:lqmx) ! 2nd shape parameter (diameter)
  
  real ax(lc:lqmx)
  real bx(lc:lqmx)
  real fx(lc:lqmx)

      real da0 (lc:lqmx)          ! collection coefficients from Seifert 2005
      real dab0(lc:lqmx,lc:lqmx)  ! collection coefficients from Seifert 2005
      real dab1(lc:lqmx,lc:lqmx)  ! collection coefficients from Seifert 2005
      real da1 (lc:lqmx)          ! collection coefficients from Seifert 2005
      real bb  (lc:lqmx)

! put ipelec here for now....
  integer :: ipelec = 0
  integer :: isaund = 0
  logical :: idoniconly = .false.
  integer, private :: elec_on_time = -1     ! time (seconds) to turn on charge separation.
  integer, private :: elec_ramp_time = 0   ! time (interval) for linear ramp after elec_on_time 
                                   ! (i.e., linear factor on chg sep to smoothly turn on elec)
                                   ! full charging rate is achieved at time = elec_on_time + elec_ramp_time
  integer :: jchgs = 3  ! number of points near boundary where charging is turned off (to keep lightning from getting wonky)
  integer :: jchgn = 2
  integer :: ichge = 3
  integer :: ichgw = 2
  real    :: charging_border = 4000. ! width of no-charging zone from boundary
      real, private    :: delqnw = -1.0e-10!-1.0e-12 !
      real, private    :: delqxw =  1.0e-10! 1.0e-12 !
      real :: tindmn = 233, tindmx = 298.0  ! min and max temperatures where inductive charging is allowed

!
!  gamma function lookup table
!
      integer ngm0,ngm1,ngm2
      parameter (ngm0=3001,ngm1=500,ngm2=500)
      double precision, parameter :: dgam = 0.01, dgami = 100.
      double precision gmoi(0:ngm0) ! ,gmod(0:ngm1,0:ngm2),gmdi(0:ngm1,0:ngm2)

      integer, parameter :: nqiacralpha =  240 !480 ! 240 ! 120 ! 15
      integer, parameter :: nqiacrratio =  100 ! 500 !50  ! 25
!      real,    parameter :: maxratiolu = 25.
      real,    parameter :: maxratiolu = 100. ! 25.
      real,    parameter :: maxalphalu = 15.
      real,    parameter :: minalphalu = -0.95
      real,    parameter :: dqiacralpha = maxalphalu/Float(nqiacralpha), dqiacrratio = maxratiolu/Float(nqiacrratio) 
      real,    parameter :: dqiacrratioinv = 1./dqiacrratio, dqiacralphainv = 1./dqiacralpha
      integer, parameter :: ialpstart = minalphalu*dqiacralphainv
      real :: ciacrratio(0:nqiacrratio,ialpstart:nqiacralpha)
      real :: qiacrratio(0:nqiacrratio,ialpstart:nqiacralpha)
      real :: ziacrratio(0:nqiacrratio,ialpstart:nqiacralpha)
      double precision :: gamxinflu(0:nqiacrratio,ialpstart:nqiacralpha,12,2) ! last index for graupel (1) or hail (2)
!      real :: ciacrratio(0:nqiacrratio,0:nqiacralpha)
!      real :: qiacrratio(0:nqiacrratio,0:nqiacralpha)
!      real :: ziacrratio(0:nqiacrratio,0:nqiacralpha)
!      double precision :: gamxinflu(0:nqiacrratio,0:nqiacralpha,12,2) ! last index for graupel (1) or hail (2)

    integer, parameter :: ngdnmm = 9
    real :: mmgraupvt(ngdnmm,3)  ! Milbrandt and Morrison (2013) fall speed coefficients for graupel/hail

    DATA mmgraupvt(:,1) / 50., 150., 250., 350., 450., 550., 650., 750., 850./
    DATA mmgraupvt(:,2) / 62.923, 94.122, 114.74, 131.21, 145.26, 157.71, 168.98, 179.36, 189.02 /
    DATA mmgraupvt(:,3) / 0.67819, 0.63789, 0.62197, 0.61240, 0.60572, 0.60066, 0.59663, 0.59330, 0.59048 /

      integer lsc(lc:lqmx)
      integer ln(lc:lqmx)
      integer ipc(lc:lqmx)
      integer lvol(lc:lqmx)
      integer lz(lc:lqmx)
      integer lliq(li:lqmx)
      integer denscale(lc:lqmx) ! flag for density scaling (mixing ratio conversion)

      integer ido(lc:lqmx)
      logical ldovol

      real xdn0(lc:lqmx)
      real xdnmx(lc:lqmx), xdnmn(lc:lqmx)
      real cdx(lc:lqmx)
      real cno(lc:lqmx)
      real xvmn(lc:lqmx), xvmx(lc:lqmx)
      real qxmin(lc:lqmx)
      real qxmin_init(lc:lqmx)

      integer nqsat
      parameter (nqsat=1000001) ! (nqsat=20001)
      real fqsat,fqsati
      parameter (fqsat=0.002,fqsati=1./fqsat)
      real tabqvs(nqsat),tabqis(nqsat),dtabqvs(nqsat),dtabqis(nqsat)

!
!  constants
!
      real, parameter :: cp608 = 0.608          ! constant used in conversion of T to Tv
      real, parameter :: ar = 841.99666         ! rain terminal velocity power law coefficient (LFO)
      real, parameter :: br = 0.8               ! rain terminal velocity power law coefficient (LFO)
      real, parameter :: aradcw = -0.27544      !
      real, parameter :: bradcw = 0.26249e+06   !
      real, parameter :: cradcw = -1.8896e+10   !
      real, parameter :: dradcw = 4.4626e+14    !
      real, parameter :: bta1 = 0.6             ! beta-1 constant used for ice nucleation by deposition (Ferrier 94, among others)
      real, parameter :: cnit = 1.0e-02         ! No for ice nucleation by deposition (Cotton et al. 86)
      real, parameter :: dragh = 0.60           ! coefficient used to adjust fall speed for hail versus graupel (Pruppacher and Klett 78)
      real, parameter :: dnz00 = 1.225          ! reference/MSL air density
      real, parameter :: rho00 = 1.225          ! reference/MSL air density
!      cs = 4.83607122       ! snow terminal velocity power law coefficient (LFO)
!      ds = 0.25             ! snow terminal velocity power law coefficient (LFO)
!  new values for  cs and ds
      real, parameter :: cs = 12.42             ! snow terminal velocity power law coefficient 
      real, parameter :: ds = 0.42              ! snow terminal velocity power law coefficient 
      real, parameter :: pi = 3.141592653589793
      real, parameter :: piinv = 1./pi
      real, parameter :: pid4 = pi/4.0

      real, parameter :: gr = 9.8

!
! max and min mean volumes
!
      real xvrmn, xvrmx0  ! min, max rain volumes
      real xvsmn, xvsmx  ! min, max snow volumes
      real xvfmn, xvfmx  ! min, max frozen drop volumes
      real xvgmn, xvgmx  ! min, max graupel volumes
      real xvhmn, xvhmn0, xvhmx, xvhmx0  ! min, max hail volumes
      real xvhlmn, xvhlmx  ! min, max lg hail volumes

      real, parameter :: dhlmn = 0.3e-3, dhlmx = 40.e-3
      real, parameter :: dhmn0 = 0.3e-3
      real, private :: dhmn = dhmn0, dhmx = -1.

      real, parameter :: cwradn = 2.0e-6, xcradmn = cwradn    ! minimum radius
      real, parameter :: cwradx = 60.e-6, xcradmx = cwradx    ! maximum radius
      real, parameter :: cwc1 = 6.0/(pi*1000.)

!      parameter( xvcmn=4.188e-18 )   ! mks  min volume = 3 micron radius
      real, parameter :: xvcmn=0.523599*(2.*cwradn)**3    ! mks  min volume = 2.5 micron radius
      real, parameter :: xvcmx=0.523599*(2.*xcradmx)**3    ! mks  min volume = 2.5 micron radius
      real, parameter :: cwmasn = 1000.*xvcmn   ! minimum mass, defined by radius of 5.0e-6
      real, parameter :: cwmasx = 1000.*xvcmx   ! maximum mass, defined by radius of 50.0e-6
      real, parameter :: cwmasn5 = 1000.*0.523599*(2.*5.0e-6)**3 !  5.23e-13

      real, parameter :: xvimn=0.523599*(2.*5.e-6)**3    ! mks  min volume = 5 micron radius
      real, parameter :: xvimx=0.523599*(2.*1.e-3)**3    ! mks  max volume = 1 mm radius (solid sphere approx)
      
      real, private   :: xvdmx = -1.0 ! 3.0e-3
      real     :: xvrmx
      parameter( xvrmn=0.523599*(80.e-6)**3, xvrmx0=0.523599*(6.e-3)**3 ) !( was 4.1887e-9 )  ! mks
      parameter( xvsmn=0.523599*(0.01e-3)**3, xvsmx=0.523599*(10.e-3)**3 ) !( was 4.1887e-9 )  ! mks
      parameter( xvfmn=0.523599*(0.1e-3)**3, xvfmx=0.523599*(10.e-3)**3 )  ! mks xvfmx = (pi/6)*(10mm)**3
      parameter( xvgmn=0.523599*(0.1e-3)**3, xvgmx=0.523599*(10.e-3)**3 )  ! mks xvfmx = (pi/6)*(10mm)**3
      parameter( xvhmn0=0.523599*(0.3e-3)**3, xvhmx0=0.523599*(20.e-3)**3 )  ! mks xvfmx = (pi/6)*(20mm)**3
      parameter( xvhlmn=0.523599*(dhlmn)**3, xvhlmx=0.523599*(dhlmx)**3 )  ! mks xvfmx = (pi/6)*(40mm)**3

!
!  electrical permitivity of air C / (N m**2) -  check the units
!
      real eperao
      parameter (eperao  = 8.8592e-12 )

      real ec,eci  ! fundamental unit of charge
      parameter (ec = 1.602e-19)
      parameter (eci = 1.0/ec)

      real    :: scwppmx = 20.0e-12
      real    :: scippmx = 20.0e-12
!
!  constants
!
      real, parameter :: c1f3 = 1.0/3.0

      real, parameter :: cai = 21.87455
      real, parameter :: caw = 17.2693882
      real, parameter :: cbi = 7.66
      real, parameter :: cbw = 35.86

      real, parameter :: cbwbolton = 29.65 ! constants for Bolton formulation
      real, parameter :: cawbolton = 17.67

      real, parameter :: tfr = 273.15, tfrh = 233.15

      real, parameter :: cp = 1004.0, rd = 287.04
      real, parameter :: cpi = 1./cp
      real, parameter :: cap = rd/cp, poo = 1.0e+05

      real, parameter :: rw = 461.5              ! gas const. for water vapor
      real, parameter :: advisc0 = 1.832e-05     ! reference dynamic viscosity (SMT; see Beard & Pruppacher 71)
      real, parameter :: advisc1 = 1.718e-05     ! dynamic viscosity constant used in thermal conductivity calc
      real, parameter :: tka0 = 2.43e-02         ! reference thermal conductivity
      real, parameter :: tfrcbw = tfr - cbw
      real, parameter :: tfrcbi = tfr - cbi

     ! GHB: Needed for eqtset=2 in cm1
!     REAL, PRIVATE ::      cv = cp - rd
     real, private, parameter ::      cv = 717.0             ! specific heat at constant volume - air
     REAL, PRIVATE, parameter ::      cvv = 1408.5
     REAL, PRIVATE, parameter ::      cpl = 4190.0
     REAL, PRIVATE, parameter ::      cpigb = 2106.0
     ! GHB

      real, parameter ::  bfnu0 = (rnu + 2.0)/(rnu + 1.0) 
      real :: ventr, ventrn, ventc, c1sw


      real :: cckm,ccne,ccnefac,cnexp,CCNE0

      integer :: na = 9
      integer :: nxtra = 1
      real gf4p5, gf4ds, gf4br
      real gsnow1, gsnow53, gsnow73
      real gfcinu1, gfcinu1p47, gfcinu2p47
      real gfcinu1p22,gfcinu2p22
      real gfcinu1p18,gfcinu2p18

      real :: cwchtmp0 = 1.0
      real :: cwchltmp0 = 1.0

      real    :: esctot = 1.0e-13

      integer iexy(lc:lqmx,lc:lqmx)
      integer :: ieswi = 1,  ieswc = 1, ieswr = 0
      integer :: iehlsw = 1, iehli = 1,  iehlc = 1, iehlr = 0
      integer :: iehwsw = 1, iehwi = 1,  iehwc = 1, iehwr = 0

      logical, parameter :: do_satadj_for_wrfchem = .true.


! Note to users: Many of these options are for development and not guaranteed to perform well.
! Some may not be functional depending on the version of the code.
! Some may be useful for ensemble physics diversity. Feel free to contact me if you have questions
! in that regard.
  NAMELIST /nssl_mp_params/               &
                        ndebug, ncdebug,&
                        iusewetgraupel, &
                        iusewethail,    &
                        iusewetsnow,    &
                        idbzci,         &
                        vtmaxsed,       &
                        itfall,iscfall, &
                        infall,         &
                        rssflg,         &
                        sssflg,         &
                        hssflg,         &
                        hlssflg,        &
                        irimdenopt,rimdenvwgt,     &
                        rimc1, rimc2, rimc3, rimc4,   &
                        idiagnosecnu,   &
                        icnuclimit,     &
                        irenuc,         &
                        restoreccn, ccntimeconst, cck, &
                        ciintmx,        &
                        itype1, itype2, &
                        icenucopt,      &
                        naer,           &
                        icfn,           &
                        ibfc, iacr, icracr, &
                        cwfrz2snowfrac, cwfrz2snowratio, &
                        ibfr,           &
                        ibiggopt,       &
                        ibiggsmallrain, &
                        ifrzg,ifiacrg,  &
                        ifrzs,ffrzs,    &
                        iacrsize,       &
                        cimas0, cimas1, cfnfac, &
                        splintermass,   &
                        ewfac,          &
                        eii0, eii1,     &
                        eri0, esi0,     &
                        eri_cimin,      &
                        eii0hl, eii1hl, &
                        ehs0, ehs1,     &
                        ess0, ess1,     &
                        esstem1,esstem2, &
                        ircnw, qminrncw,& ! single-moment only
                        iglcnvi,        &
                        iglcnvs,        &
                        alphahacx,      &
                        fconv,          &
                        eqtot,          &
                        imeyers5,       &
                        iehw,           &
                        ierw,           &
                        iehr0c,iehlr0c, &
                        alphai,         &
                        alphar,         &
                        alphas,         & ! note that alphah and alphahl come through physics namelist
                        cnu,            &
                        iscni,fscni,    &
                        dfrz,           &
                        dmlt,           &
                        rainfallfac,    &
                        icefallfac,     &
                        snowfallfac,    &
                        graupelfallfac,    &
                        hailfallfac,    &
                        icefallopt,     &
                        icdx,icdxhl,    &
                        cdhmin, cdhmax,       &
                        cdhdnmin, cdhdnmax,   &
                        cdhlmin, cdhlmax,     &
                        cdhldnmin, cdhldnmax, &
                        ihmlt,          &
                        ehimin,         &
                        ehimax,         &
                        ehsmax,         &
                        ecollmx,        &
                        ehw0, ehlw0,    &
                        ehr0, ehlr0,    &
                        erw0,           &
                        exwmindiam,     &
                        nsplinter,      &
                        lawson_splinter_fac, &
                        iqcinit,        &
                        ssmxinit,      &
                        xvdmx,          &
                        dhmn, dhmx,     &
                        fwms,fwmh,fwmhl,  &
                        ifwmhopt,         &
                        ihxw2rain,        &
                        fwmlarge,         &
                        ifwmfall,         &
                        iturbenhance,     &
                        qsdenmod,qhdenmod, &
                        qsvtmod,          &
                        alphamin,alphamax, &
                        isnwfrac,          &
                        rescale_low_alpha, &
                        rescale_low_alphar, &
                        rescale_low_alphah, &
                        rescale_low_alphahl, &
                        rescale_high_alpha, &
                        ihlcnh, hldia1,iusedw, dwehwmin, dwmin, dwtempmin, &
                        icvhl2h, hldnmn,hdnmn,    &
                        hlcnhdia, hlcnhqmin, &
                        isedonly,           &
                        iresetmoments,      &
                        cxmin, zxmin,       &
                        imurain,            &
                        iferwisventr,       &
                        izwisventr,         &
                        qhdpvdn,            &
                        qhacidn,            &
                        sheddiam,sheddiamlg, &
                        sheddiam0,           &
                        mltdiam1,mltdiam2,mltdiam3,mltdiam4,mltdiam05, &
                        imaxdiaopt,          &
                        ithompsoncnoh,       &
                        cnohmn,             &
                        ivhmltsoak,         &
                        ioldlimiter,        &
                        isnowfall,          &
                        isnowdens,          &
                        ibiggsnow,          &
                        ixtaltype,          &
                        evapfac,    &
                        depfac,             &
                        dmrauto,irescalerainopt, dmropt,dmhlopt,     &
                        rescale_tempthresh, rescale_wthresh, &
                        ibinhmlr,ibinhlmlr,imltshddmr, binmlrmxdia, binmlrzrrfac,ibinnum,   &
                        iqhacrmlr, iqhlacrmlr, &
                        snowmeltdia,    &
                        delta_alphamlr, &
                        iqvsopt,     &
                        maxsupersat, &
                        charging_border, &
                        do_accurate_sedimentation, interval_sedi_vt
! #####################################################################
! #####################################################################

 CONTAINS

! #####################################################################
! #####################################################################


 REAL FUNCTION fqvs(t)
  implicit none
  real :: t
  fqvs = exp(caw*(t-273.15)/(t-cbw))
 END FUNCTION fqvs

 REAL FUNCTION fqis(t)
  implicit none
  real :: t
  fqis = exp(cai*(t-273.15)/(t-cbi))
 END FUNCTION fqis
 



! #####################################################################
! #####################################################################


       SUBROUTINE nssl_2mom_init(  &
     & ims,ime, jms,jme, kms,kme, nssl_params, ipctmp, mixphase,ihvol,idoniconlytmp, &
     & nssl_graupelfallfac, &
     & nssl_hailfallfac, &
     & nssl_ehw0, &
     & nssl_ehlw0, &
     & nssl_icdx, &
     & nssl_icdxhl, &
     & nssl_icefallfac, &
     & nssl_snowfallfac &
     )

  implicit none
  
   real, intent(in), optional ::  &
     & nssl_graupelfallfac, &
     & nssl_hailfallfac, &
     & nssl_ehw0, &
     & nssl_ehlw0, &
     & nssl_icefallfac, &
     & nssl_snowfallfac 
   integer, intent(in), optional ::  &
     & nssl_icdx, &
     & nssl_icdxhl

   integer, intent(in) :: ims,ime, jms,jme, kms,kme
   real,  intent(in), dimension(20) :: nssl_params



   integer, intent(in) :: ipctmp,mixphase,ihvol
   logical, optional, intent(in) :: idoniconlytmp

    logical :: wrote_namelist = .false.
    logical :: wrf_dm_on_monitor

     double precision :: arg
     real    :: temq
     integer :: igam
     integer :: i,il,j,l
     integer :: ltmp
     integer :: isub
     real    :: bxh,bxhl

      real    :: alp,ratio
      double precision  :: x,y,y2,y7
      logical :: turn_on_ccna, turn_on_cina
      integer :: istat
     

     turn_on_ccna = .false.
     turn_on_cina = .false.
!
! set some global values from namelist input
!

      ccn      = Abs( nssl_params(1) )
      alphah   = nssl_params(2)
      alphahl  = nssl_params(3)
      cnoh     = nssl_params(4)
      cnohl    = nssl_params(5)
      cnor     = nssl_params(6)
      cnos     = nssl_params(7)
      rho_qh   = nssl_params(8)
      rho_qhl  = nssl_params(9)
      rho_qs   = nssl_params(10)
      
!      ipelec   = Nint(nssl_params(11))
!      isaund   = Nint(nssl_params(12))
      IF ( present(nssl_graupelfallfac) ) graupelfallfac = nssl_graupelfallfac
      IF ( present(nssl_hailfallfac) ) hailfallfac = nssl_hailfallfac
      IF ( present(nssl_ehw0) ) ehw0 = nssl_ehw0
      IF ( present(nssl_ehlw0) ) ehlw0 = nssl_ehlw0
      IF ( present(nssl_icdx) ) icdx = nssl_icdx
      IF ( present(nssl_icdxhl) ) icdxhl = nssl_icdxhl
      IF ( present(nssl_icefallfac) ) icefallfac = nssl_icefallfac
      IF ( present(nssl_snowfallfac) ) snowfallfac = nssl_snowfallfac


      IF ( Nint(nssl_params(13)) == 1 ) THEN
      ! hack to switch CCN field to CCNA (activated ccn)
!       invertccn = .true.
        turn_on_ccna = .true.
        irenuc = 7
      ENDIF

      


      IF ( .false. ) THEN ! set to true to enable internal namelist read
      open(15,file='namelist.input',status='old',form='formatted',action='read')
      rewind(15)
      read(15,NML=nssl_mp_params,iostat=istat)
      close(15)
      IF ( istat /= 0 ) THEN
        write(0,*) 'READ_NAMELIST: PROBLEM WITH NSSL_MP_PARAMS namelist: not found or bad token'
      ENDIF
        IF ( wrf_dm_on_monitor() .and. .not. wrote_namelist ) THEN
          open(15,file='namelist.output',status='old',action='readwrite', position='append',form='formatted')
          write(15,NML=nssl_mp_params)
          close(15)
          wrote_namelist = .true.
        ENDIF
       ENDIF



      IF ( irenuc >= 5 ) THEN
        turn_on_ccna = .true.
      ENDIF

      cwccn = ccn

      lhab = 8
      lhl = 8
      IF ( icespheres >= 1 ) THEN
        lhab = lhab + 1
        lis = li + 1
        ls = ls + 1
        lh = lh + 1
        lhl = lhl + 1
      ENDIF
      IF ( ihvol <= -1 .or. ihvol == 2 ) THEN
        IF ( ihvol == -1 .or. ihvol == -2 ) THEN
        lhab = lhab - 1  ! turns off hail 
        lhl = 0
        ! past me thought it would be a good idea to change graupel factors when hail is off....
        ! ehw0 = 0.75
        ! iehw = 2
        ! dfrz = Max( dfrz, 0.5e-3 )
        ENDIF
        IF ( ihvol == -2 .or. ihvol == 2 ) THEN ! ice crystals are turned off
         ! a value of -3 means to turn off ice crystals but turn on hail
          renucfrac = 1.0
          ffrzs = 1.0
          ! idoci = 0 ! try this later
        ENDIF
      ENDIF

!      write(0,*) 'wrf_init: lhab,lhl = ',lhab,lhl

!      IF ( ipelec > 0 ) idonic = .true.

!
! Build lookup table for saturation mixing ratio (Soong and Ogura 73)
!

      do l = 1,nqsat
      temq = 163.15 + (l-1)*fqsat
      IF ( iqvsopt == 0 ) THEN
      tabqvs(l) = exp(caw*(temq-273.15)/(temq-cbw))
      dtabqvs(l) = ((-caw*(-273.15 + temq))/(temq - cbw)**2 + &
     &                 caw/(temq - cbw))*tabqvs(l)
      ELSE
      tabqvs(l) = exp(caw*(temq-273.15)/(temq-cbw))
      dtabqvs(l) = ((-cawbolton*(-273.15 + temq))/(temq - cbwbolton)**2 + &
     &                 cawbolton/(temq - cbwbolton))*tabqvs(l)
      ENDIF
      tabqis(l) = exp(cai*(temq-273.15)/(temq-cbi))
      dtabqis(l) = ((-cai*(-273.15 + temq))/(temq - cbi)**2 + &
     &                 cai/(temq - cbi))*tabqis(l)
      end do

      bx(lr) = 0.85
      ax(lr) = 1647.81
      fx(lr) = 135.477
      
      IF ( icdx == 6 ) THEN
        bx(lh) = 0.6 ! Milbrandt and Morrison (2013) for density of 550.
        ax(lh) = 157.71
      ELSEIF ( icdx > 0 ) THEN
        bx(lh) = 0.5
        ax(lh) = 75.7149
      ELSE
        bx(lh) = 0.37 ! 0.6  ! Ferrier 1994
        ax(lh) = 19.3
      ENDIF
!      bx(lh) = 0.6

      IF ( lhl .gt. 1 ) THEN
        IF ( icdxhl == 6 ) THEN
          bx(lhl) = 0.593 ! Milbrandt and Morrison (2013) for density of 750.
          ax(lhl) = 179.36
        ELSEIF (icdxhl > 0 ) THEN
          bx(lhl) = 0.5
          ax(lhl) = 75.7149
        ELSE
          ax(lhl) = 206.984  ! Ferrier 1994
          bx(lhl) = 0.6384
        ENDIF
      ENDIF

! fill in the complete gamma function lookup table
     gmoi(0) = 1.d32
     do igam = 1,ngm0
      arg = dgam*igam
      gmoi(igam) = gamma_dp(arg)
     end do

     ! build lookup table to compute the number and mass fractions of rain drops 
     ! (imurain=1) greater than a given diameter. Used for qiacr and ciacr
     ! Uses incomplete gamma functions
     ! The terms with bxh or bxhl will be off if the actual bxh or bxhl is different from the base value (icdx=6 option)
      
      bxh = bx(lh)
      bxhl = bx(Max(lh,lhl))
      
!      DO j = 0,nqiacralpha
      DO j = ialpstart,nqiacralpha
      alp = float(j)*dqiacralpha
      y = gamma_dpr(1.+alp)
      y2 = gamma_dpr(2.+alp)
      DO i = 0,nqiacrratio
        ratio = float(i)*dqiacrratio
        x = gamxinfdp( 1.+alp, ratio )
!        write(0,*) 'i, x/y = ',i, x/y
        ciacrratio(i,j) = x/y

        ! graupel (.,.,.,1)
        gamxinflu(i,j,1,1) = x/y
        gamxinflu(i,j,2,1) = gamxinfdp( 2.0+alp, ratio )/y
        gamxinflu(i,j,3,1) = gamxinfdp( 2.5+alp+0.5*bxh, ratio )/y
        gamxinflu(i,j,5,1) = (gamma_dpr(5.0+alp) - gamxinfdp( 5.0+alp, ratio ))/y
        gamxinflu(i,j,6,1) = (gamma_dpr(5.5+alp+0.5*bxh) - gamxinfdp( 5.5+alp+0.5*bxh, ratio ))/y
        gamxinflu(i,j,9,1) = gamxinfdp( 1.0+alp, ratio )/y
        gamxinflu(i,j,10,1)= gamxinfdp( 4.0+alp, ratio )/y

        gamxinflu(i,j,12,1) = gamxinfdp( 2.0+alp, ratio )/y2
       
        ! hail (.,.,.,2)
        gamxinflu(i,j,1,2) = gamxinflu(i,j,1,1)
        gamxinflu(i,j,2,2) = gamxinflu(i,j,2,1)
        gamxinflu(i,j,3,2) = gamxinfdp( 2.5+alp+0.5*bxhl, ratio )/y
        gamxinflu(i,j,5,2) = gamxinflu(i,j,5,1)
        gamxinflu(i,j,6,2) = (gamma_dpr(5.5+alp+0.5*bxhl) - gamxinfdp( 5.5+alp+0.5*bxhl, ratio ))/y
        gamxinflu(i,j,9,2) = gamxinflu(i,j,9,1)
        gamxinflu(i,j,10,2)= gamxinflu(i,j,10,1)

      IF ( alp > 1.1 ) THEN
!       gamxinflu(i,j,7,1) = gamxinfdp( alp - 1., ratio )/y
       gamxinflu(i,j,7,1) = (gamma_dpr(alp - 1.) - gamxinfdp( alp - 1., ratio ))/y
!       gamxinflu(i,j,8,1) = gamxinfdp( alp - 0.5 + 0.5*bxh, ratio )/y
       gamxinflu(i,j,8,1) = (gamma_dpr(alp - 0.5 + 0.5*bxh) - gamxinfdp( alp - 0.5 + 0.5*bxh, ratio ))/y
!       gamxinflu(i,j,8,2) = gamxinfdp( alp - 0.5 + 0.5*bxhl, ratio )/y
       gamxinflu(i,j,8,2) = (gamma_dpr(alp - 0.5 + 0.5*bxhl) - gamxinfdp( alp - 0.5 + 0.5*bxhl, ratio ))/y
      ELSE
!       gamxinflu(i,j,7,1) = gamxinfdp( .1, ratio )/y
       gamxinflu(i,j,7,1) = (gamma_dpr(0.1) - gamxinfdp( 0.1, ratio ) )/y
!       gamxinflu(i,j,8,1) = gamxinfdp( 1.1 - 0.5 + 0.5*bxh, ratio )/y
!       gamxinflu(i,j,8,2) = gamxinfdp( 1.1 - 0.5 + 0.5*bxhl, ratio )/y
       gamxinflu(i,j,8,1) = (gamma_dpr(1.1 - 0.5 + 0.5*bxh) - gamxinfdp( 1.1 - 0.5 + 0.5*bxh, ratio ) )/y
       gamxinflu(i,j,8,2) = (gamma_dpr(1.1 - 0.5 + 0.5*bxhl) - gamxinfdp( 1.1 - 0.5 + 0.5*bxhl, ratio ) )/y
      ENDIF
        
        gamxinflu(i,j,7,2) = gamxinflu(i,j,7,1)

      ENDDO
      ENDDO
      ciacrratio(0,:) = 1.0

      DO j = ialpstart,nqiacralpha
      alp = float(j)*dqiacralpha
      y = gamma_sp(4.+alp)
      y7 = gamma_sp(7.+alp)
      DO i = 0,nqiacrratio
        ratio = float(i)*dqiacrratio
        
        ! mass fraction
        x = gamxinfdp( 4.+alp, ratio )
!        write(0,*) 'i, x/y = ',i, x/y
        qiacrratio(i,j) = x/y
        gamxinflu(i,j,4,1) = x/y
        gamxinflu(i,j,4,2) = x/y

        ! reflectivity fraction
        x = gamxinfdp( 7.+alp, ratio )
        ziacrratio(i,j) = x/y7
        gamxinflu(i,j,11,1) = x/y7
        gamxinflu(i,j,11,2) = x/y7

      ENDDO
      ENDDO
      qiacrratio(0,:) = 1.0


      isub = Min( 0, Max(-1,ihvol) ) ! is -1 or 0

      lccn = 0
      lccna = 0
      lnc = 0
      lnr = 0
      lni = 0
      lnis = 0
      lns = 0
      lnh = 0
      lnhl = 0
      lvh = 0
      lvhl = 0
      lzr = 0
      lzh = 0
      lzhl = 0
      lsw = 0
      lhw = 0
      lhlw = 0

      denscale(:) = 0
      
!      lccn = 9

    ipconc = ipctmp

    IF ( ipconc == 0 ) THEN
       IF ( ihvol >= 0 ) THEN
       lvh = 9
       ltmp = 9
       denscale(lvh) = 1
       ELSE ! no hail
       ltmp = lhab
       lhl = 0
       ENDIF
    ELSEIF ( ipconc == 5 ) THEN
      lccn = lhab+1 ! 9
      lnc = lhab+2 ! 10
      lnr = lhab+3 ! 11
      lni = lhab+4 !12
      lns = lhab+5 !13
      lnh = lhab+6 !14
      ltmp = lnh
      IF ( ihvol >= 0 ) THEN
      ltmp = ltmp + 1
      lnhl = ltmp ! lhab+7 ! 15
      ENDIF
      ltmp = ltmp + 1
      lvh = ltmp ! lhab+8 + isub ! 16 + isub ! isub adjusts to 15 if hail is off
!      ltmp = lvh
      denscale(lccn:lvh) = 1
      IF ( ihvol >= 1 ) THEN
       ltmp = ltmp + 1
       lvhl = ltmp
!       ltmp = lvhl
       denscale(lvhl) = 1
      ENDIF
      IF ( mixedphase ) THEN
      ltmp = ltmp + 1
      lsw  = ltmp
      ltmp = ltmp + 1
      lhw  = ltmp
        IF ( lhl > 1 ) THEN
          ltmp = ltmp + 1
          lhlw = ltmp
        ENDIF
!      ltmp = lhlw
      ENDIF
    ELSEIF ( ipconc >= 6 ) THEN
      write(0,*) 'NSSL microphysics has not been compiled for 3-moment. Sorry.'
        STOP
      lccn = lhab+1 ! 9
      lnc = lhab+2 ! 10
      lnr = lhab+3 ! 11
      lni = lhab+4 !12
      lns = lhab+5 !13
      lnh = lhab+6 !14
      ltmp = lnh
      IF ( lhl > 0 ) THEN
      ltmp = ltmp + 1
      lnhl = ltmp ! lhab+7 ! 15
      ENDIF
      ltmp = ltmp + 1
      lvh = ltmp ! lhab+8 + isub ! 16 + isub ! isub adjusts to 15 if hail is off
!      ltmp = lvh
      denscale(lccn:lvh) = 1
      IF ( ihvol >= 1 ) THEN
       ltmp = ltmp + 1
       lvhl = ltmp
!       ltmp = lvhl
       denscale(lvhl) = 1
      ENDIF

      IF ( ipconc == 6 ) THEN
       ltmp = ltmp + 1
       lzh = ltmp
      ELSEIF ( ipconc == 7 ) THEN
       ltmp = ltmp + 1
       lzh = ltmp
       ltmp = ltmp + 1
       lzr = ltmp
      ELSEIF ( ipconc == 8 ) THEN
       ltmp = ltmp + 1
       lzh = ltmp
       ltmp = ltmp + 1
       lzr = ltmp
       ltmp = ltmp + 1
       IF ( lhl > 1 ) THEN
         ltmp = ltmp + 1
         lzhl = ltmp
       ENDIF
      ENDIF
!      ltmp = lvh
 !     denscale(lccn:lvh) = 1
      IF ( ihvol >= 1 ) THEN
       lvhl = ltmp+1
       ltmp = lvhl
       denscale(lvhl) = 1
      ENDIF
      IF ( mixedphase ) THEN
      ltmp = ltmp + 1
      lsw  = ltmp
      ltmp = ltmp + 1
      lhw  = ltmp
        IF ( lhl > 1 ) THEN
          ltmp = ltmp + 1
          lhlw = ltmp
        ENDIF
!      ltmp = lhlw
      ENDIF
    ELSE
      CALL wrf_error_fatal( 'nssl_2mom_init: Invalid value of ipctmp' )
    ENDIF



    
      ! write(0,*) 'wrf_init: irenuc, turn_on_ccna = ',irenuc, turn_on_ccna 
      IF ( turn_on_ccna ) THEN
        ltmp = ltmp + 1
        lccna = ltmp
        denscale(ltmp) = 1
      ENDIF

      IF ( turn_on_cina ) THEN
        ltmp = ltmp + 1
        lcina = ltmp
        denscale(ltmp) = 1
      ENDIF

      IF ( turn_on_cin .or. is_aerosol_aware ) THEN
        ltmp = ltmp + 1
        lcin = ltmp
        denscale(ltmp) = 1
!debug        write(0,*) 'Setting lcin to ',lcin
      ENDIF
      na = ltmp
      
      ln(lc) = lnc
      ln(lr) = lnr
      ln(li) = lni
      ln(ls) = lns
      ln(lh) = lnh
      IF ( lhl .gt. 1 ) ln(lhl) = lnhl

      ipc(lc) = 2
      ipc(lr) = 3
      ipc(li) = 1
      ipc(ls) = 4
      ipc(lh) = 5
      IF ( lhl .gt. 1 ) ipc(lhl) = 5
      
      ldovol = .false.
      lvol(:) = 0
      lvol(li) = lvi
      lvol(ls) = lvs
      lvol(lh) = lvh
      IF ( lhl .gt. 1 .and. lvhl .gt. 1 ) lvol(lhl) = lvhl
      
      lne = Max(lnh,lnhl)
      lne = Max(lne,lvh)
      lne = Max(lne,lvhl)
      lne = Max(lne,na)

      lsc(:) = 0
      lsc(lc) = lscw
      lsc(lr) = lscr
      lsc(li) = lsci
      lsc(ls) = lscs
      lsc(lh) = lsch
      IF ( lhl .gt. 1 ) lsc(lhl) = lschl


      DO il = lc,lhab
        ldovol = ldovol .or. ( lvol(il) .gt. 1 )
      ENDDO

!      write(0,*) 'nssl_2mom_init: ldovol = ',ldovol

      lz(:) = 0
      lz(lr) = lzr
      lz(li) = lzi
      lz(ls) = lzs
      lz(lh) = lzh
      IF ( lhl .gt. 1 .and. lzhl > 1 ) lz(lhl) = lzhl

      lliq(:) = 0
      lliq(ls) = lsw
      lliq(lh) = lhw
      IF ( lhl .gt. 1 ) lliq(lhl) = lhlw
      IF ( mixedphase ) THEN
!       write(0,*) 'lsw,lhw,lhlw = ',lsw,lhw,lhlw
      ENDIF



      xnu(lc) = cnu
      xmu(lc) = 1.
      
      IF ( imurain == 3 ) THEN
        xnu(lr) = rnu
        xmu(lr) = 1.
      ELSEIF ( imurain == 1 ) THEN
        xnu(lr) = (alphar - 2.0)/3.0
        xmu(lr) = 1./3.
      ENDIF

      xnu(li) = cinu
      xmu(li) = 1.

      IF ( lis >= 1 ) THEN
      xnu(lis) = 0.0
      xmu(lis) = 1.
      ENDIF

      dnu(lc) = 3.*xnu(lc) + 2. ! alphac
      dmu(lc) = 3.*xmu(lc)

      dnu(lr) = 3.*xnu(lr) + 2. ! alphar
      dmu(lr) = 3.*xmu(lr)

      xnu(ls) = snu
      xmu(ls) = 1.

      dnu(ls) = 3.*xnu(ls) + 2.  ! -0.4 ! alphas
      dmu(ls) = 3.*xmu(ls)


      dnu(lh) = alphah
      dmu(lh) = dmuh

      xnu(lh) = (dnu(lh) - 2.)/3.
      xmu(lh) = dmuh/3.


      IF ( imurain == 3 ) THEN ! rain is gamma of volume
      rz =  ((4. + alphah)*(5. + alphah)*(6. + alphah)*(1. + xnu(lr)))/ & 
     &  ((1 + alphah)*(2 + alphah)*(3 + alphah)*(2. + xnu(lr)))

!      IF ( ipconc .lt. 5 ) alphahl = alphah
      
      rzhl =  ((4. + alphahl)*(5. + alphahl)*(6. + alphahl)*(1. + xnu(lr)))/ & 
     &  ((1. + alphahl)*(2. + alphahl)*(3. + alphahl)*(2. + xnu(lr)))

      rzs =  1. ! assume rain and snow are both gamma volume

      ELSE ! rain is gamma of diameter
      
      rz =  ((4. + alphah)*(5. + alphah)*(6. + alphah)*(1. + alphar)*(2. + alphar)*(3. + alphar))/ & 
     &  ((1 + alphah)*(2 + alphah)*(3 + alphah)*(4. + alphar)*(5. + alphar)*(6. + alphar))
      
      rzhl =  ((4. + alphahl)*(5. + alphahl)*(6. + alphahl)*(1. + alphar)*(2. + alphar)*(3. + alphar))/ & 
     &  ((1 + alphahl)*(2 + alphahl)*(3 + alphahl)*(4. + alphar)*(5. + alphar)*(6. + alphar))

      
      rzs =   & 
     &  ((1. + alphar)*(2. + alphar)*(3. + alphar)*(2. + xnu(ls)))/  &
     &  ((4. + alphar)*(5. + alphar)*(6. + alphar)*(1. + xnu(ls)))
       

      ENDIF

      IF ( ipconc <= 5 ) THEN 
        imltshddmr = Min(1, imltshddmr)
        ibinhmlr = 0
        ibinhlmlr = 0
      ENDIF

      IF ( ipconc > 5 .and. (ibinhmlr == 0 .and. ibinhlmlr == 0 ) ) THEN 
        imltshddmr = Min(1, imltshddmr)
      ENDIF

!      write(0,*) 'rz,rzhl = ', rz,rzhl

      IF ( ipconc .lt. 4 ) THEN

      dnu(ls) = alphas
      dmu(ls) = 1.

      xnu(ls) = (dnu(ls) - 2.)/3.
      xmu(ls) = 1./3.


      ENDIF

      IF ( lhl .gt. 1 ) THEN

      dnu(lhl) = alphahl
      dmu(lhl) = dmuhl

      xnu(lhl) = (dnu(lhl) - 2.)/3.
      xmu(lhl) = dmuhl/3.

      ENDIF

      cno(lc)  = 1.0e+08
      IF ( li .gt. 1 ) cno(li)  = 1.0e+08
      cno(lr)  = cnor
      IF ( ls .gt. 1 ) cno(ls)  = cnos ! 8.0e+06
      IF ( lh .gt. 1 ) cno(lh)  = cnoh ! 4.0e+05
      IF ( lhl .gt. 1 ) cno(lhl)  = cnohl ! 4.0e+05
!
!  density maximums and minimums
!
      xdnmx(:) = 900.0

      xdnmx(lr) = 1000.0
      xdnmx(lc) = 1000.0
      xdnmx(li) =  917.0
      xdnmx(ls) =  300.0
      xdnmx(lh) =  900.0
      IF ( lhl .gt. 1 ) xdnmx(lhl) = 900.0
!
      xdnmn(:) = 900.0

      xdnmn(lr) = 1000.0
      xdnmn(lc) = 1000.0
      xdnmn(li) =  100.0
      xdnmn(ls) =  100.0
      xdnmn(lh) =  hdnmn
      IF ( lhl .gt. 1 ) xdnmn(lhl) = hldnmn

      xdn0(:) = 900.0

      xdn0(lc) = 1000.0
      xdn0(li) = 900.0
      xdn0(lr) = 1000.0
      xdn0(ls) = rho_qs ! 100.0
      xdn0(lh) = rho_qh ! (0.5)*(xdnmn(lh)+xdnmx(lh))
      IF ( lhl .gt. 1 ) xdn0(lhl) = rho_qhl ! 800.0

!
!  Set terminal velocities...
!    also set drag coefficients
!
      cdx(lr) = 0.60
      cdx(lh) = 0.8 ! 1.0 ! 0.45
      cdx(ls) = 2.00
      IF ( lhl .gt. 1 ) cdx(lhl) = 0.45

      ido(lc) = idocw
      ido(lr) = idorw
      ido(li) = idoci
      ido(ls) = idosw
      ido(lh)  = idohw
      IF ( lhl .gt. 1 ) ido(lhl) = idohl

      IF ( irfall .lt. 0 ) irfall = infall
      IF ( lzr > 0 ) irfall = 0

      qccn = ccn/rho00
!      xvcmx = (4./3.)*pi*xcradmx**3

! set max rain diameter
      IF ( xvdmx .gt. 0.0 ) THEN
        xvrmx = 0.523599*(xvdmx)**3
      ELSE
        xvrmx = xvrmx0
      ENDIF

         IF ( dhmn <= 0.0 ) THEN
           xvhmn = xvhmn0
!           xvhmn = Min(xvhmn0, 0.523599*(dfrz)**3 )
         ELSE
           xvhmn = 0.523599*(dhmn)**3
!           xvhmn = 0.523599*(Min(dhmn,dfrz))**3
         ENDIF

         IF ( dhmx <= 0.0 ) THEN
           xvhmx = xvhmx0
         ELSE
           xvhmx = 0.523599*(dhmx)**3
         ENDIF
         
         IF ( qhdpvdn < 0. ) qhdpvdn = xdnmn(lh)
         IF ( qhacidn < 0. ) qhacidn = xdnmn(lh)

! load max/min diameters
      xvmn(lc) = xvcmn
      xvmn(li) = xvimn
      xvmn(lr) = xvrmn
      xvmn(ls) = xvsmn
      xvmn(lh) = xvhmn

      xvmx(lc) = xvcmx
      xvmx(li) = xvimx
      xvmx(lr) = xvrmx
      xvmx(ls) = xvsmx
      xvmx(lh) = xvhmx

      IF ( lhl .gt. 1 ) THEN
      xvmn(lhl) = xvhlmn
      xvmx(lhl) = xvhlmx
      ENDIF

!
!  cloud water constants in mks units
!
!      cwmasn = 4.25e-15  ! radius of 1.0e-6
!      cwmasn = 5.23e-13   ! minimum mass, defined by radius of 5.0e-6
!      cwmasn5 =  5.23e-13
!      cwradn = 5.0e-6     ! minimum radius
!      cwmasx = 5.25e-10   ! maximum mass, defined by radius of 50.0e-6
!      mwfac = 6.0**(1./3.)
      IF ( ipconc .ge. 2 ) THEN
!        cwmasn = xvmn(lc)*1000.  ! minimum mass, defined by minimum droplet volume
!        cwradn = 1.0e-6          ! minimum radius
!        cwmasx = xvmx(lc)*1000.  ! maximum mass, defined by maximum droplet volume
        
      ENDIF
!        rwmasn = xvmn(lr)*1000.  ! minimum mass, defined by minimum rain volume
!        rwmasx = xvmx(lr)*1000.  ! maximum mass, defined by maximum rain volume

      IF ( lhl < 1 ) ifrzg = 1

      ventr = 1.
      IF ( imurain == 3 ) THEN
!       IF ( izwisventr == 1 ) THEN
        ventr = Gamma_sp(rnu + 4./3.)/((rnu + 1.)**(1./3.)*Gamma_sp(rnu + 1.)) ! Ziegler 1985
!       ELSE
        ventrn =  Gamma_sp(rnu + 1.5 + br/6.)/(Gamma_sp(rnu + 1.)*(rnu + 1.)**((1.+br)/6. + 1./3.) ) ! adapted from Wisner et al. 1972; for second term in rwvent
!        ventr = Gamma_sp(rnu + 4./3.)/((rnu + 1.)**(1./3.)*Gamma_sp(rnu + 1.)) ! Ziegler 1985, still use for first term in rwvent
!        ventr  = Gamma_sp(rnu + 4./3.)/Gamma_sp(rnu + 1.) 
!       ENDIF
      ELSE ! imurain == 1
!       IF ( iferwisventr == 1 ) THEN
        ventr = Gamma_sp(2. + alphar)  ! Ferrier 1994
!       ELSEIF ( iferwisventr == 2 ) THEN
        ventrn =  Gamma_sp(alphar + 2.5 + br/2.)/Gamma_sp(alphar + 1.) ! adapted from Wisner et al. 1972
!       ENDIF
      ENDIF
      ventc   = Gamma_sp(cnu + 4./3.)/(cnu + 1.)**(1./3.)/Gamma_sp(cnu + 1.)
      c1sw = Gamma_sp(snu + 4./3.)*(snu + 1.0)**(-1./3.)/gamma_sp(snu + 1.0)

  ! set threshold mixing ratios

      qxmin(:) = 1.0e-12

      qxmin(lc) = 1.e-9
      qxmin(lr) = 1.e-7
      IF ( li > 1 ) qxmin(li) = 1.e-12
      IF ( ls > 1 ) qxmin(ls) = 1.e-7
      IF ( lh > 1 ) qxmin(lh) = 1.e-7
      IF ( lhl .gt. 1 ) qxmin(lhl) = 1.e-7

      IF ( lc .gt. 1 .and. lnc .gt. 1 ) qxmin(lc) = 1.0e-13
      IF ( lr .gt. 1 .and. lnr .gt. 1 ) qxmin(lr) = 1.0e-12

      IF ( li .gt. 1 .and. lni .gt. 1 ) qxmin(li ) = 1.0e-13
      IF ( ls .gt. 1 .and. lns .gt. 1 ) qxmin(ls ) = 1.0e-13
      IF ( lh .gt. 1 .and. lnh .gt. 1 ) qxmin(lh ) = 1.0e-12
      IF ( lhl.gt. 1 .and. lnhl.gt. 1 ) qxmin(lhl) = 1.0e-12

      qxmin_init(:) = 1.0e-8 ! threshold for considering single-moment initial condition mixing ratios
  ! constants for droplet nucleation

      cckm = cck-1.
      ccnefac =  (1.63/(cck * beta(3./2., cck/2.)))**(cck/(cck + 2.0))
      cnexp   = (3./2.)*cck/(cck+2.0)
! ccne is all the factors with w in eq. A7 in Mansell et al. 2010 (JAS).  The constant changes
! if k (cck) is changed!
      ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck))
      ccne0 = ccnefac*1.e6*(1.e-6)**(2./(2.+cck))
!      write(0,*) 'cwccn, cck, ccne = ',cwccn,cck,ccne,ccnefac,cnexp
      IF ( cwccn .lt. 0.0 ) THEN
      cwccn = Abs(cwccn)
      ccwmx = 50.e9 ! cwccn
      ELSE
      ccwmx = 50.e9 ! cwccn ! *1.4
      ENDIF

!
!
!  Set collection coefficients (Seifert and Beheng 05)
!
      bb(:) = 1.0/3.0
      bb(li) = 0.3429
      DO il = lc,lhab
        da0(il) = delbk(bb(il), xnu(il), xmu(il), 0)
        da1(il) = delbk(bb(il), xnu(il), xmu(il), 1)

!        write(0,*) 'il, da0, da1, xnu, xmu = ', il, da0(il), da1(il), xnu(il), xmu(il)
      ENDDO

      dab0(:,:) = 0.0
      dab1(:,:) = 0.0

      DO il = lc,lhab
        DO j = lc,lhab
          IF ( il .ne. j ) THEN

            dab0(il,j) = delabk(bb(il), bb(j), xnu(il), xnu(j), xmu(il), xmu(j), 0)
            dab1(il,j) = delabk(bb(il), bb(j), xnu(il), xnu(j), xmu(il), xmu(j), 1)

!           write(0,*) 'il, j, dab0, dab1 = ',il, j, dab0(il,j), dab1(il,j)
          ENDIF
        ENDDO
      ENDDO

        gf4br = gamma_sp(4.0+br)
        gf4ds = gamma_sp(4.0+ds)
        gf4p5 = gamma_sp(4.0+0.5)
        gfcinu1 = gamma_sp(cinu + 1.0)
        gfcinu1p47 = gamma_sp(cinu + 1.47167)
        gfcinu2p47 = gamma_sp(cinu + 2.47167)
        gfcinu1p22 = gamma_sp(cinu + 1.22117)
        gfcinu2p22 = gamma_sp(cinu + 2.22117)
        gfcinu1p18 = gamma_sp(cinu + 1.18333)
        gfcinu2p18 = gamma_sp(cinu + 2.18333)
        
        gsnow1 = gamma_sp(snu + 1.0)
        gsnow53 = gamma_sp(snu + 5./3.)
        gsnow73 = gamma_sp(snu + 7./3.)

        IF ( lh  .gt. 1 ) cwchtmp0 = 6.0/pi*gamma_sp( (xnu(lh) + 1.)/xmu(lh) )/gamma_sp( (xnu(lh) + 2.)/xmu(lh) )
        IF ( lhl .gt. 1 ) cwchltmp0 = 6.0/pi*gamma_sp( (xnu(lhl) + 1)/xmu(lhl) )/gamma_sp( (xnu(lhl) + 2)/xmu(lhl) )


      iexy(:,:)=0; ! sets to zero the ones Imight have forgotten

!     snow
      iexy(ls,li) = ieswi
      iexy(ls,lc) = ieswc ; iexy(ls,lr) = ieswr ;

!     graupel
      iexy(lh,ls)  = iehwsw ; iexy(lh,li) = iehwi ;
      iexy(lh,lc) = iehwc ; iexy(lh,lr)  = iehwr ;

!     hail
      IF (lhl .gt. 1 ) THEN
      iexy(lhl,ls)  = iehlsw ; iexy(lhl,li) = iehli ;
      iexy(lhl,lc) = iehlc ; iexy(lhl,lr)  = iehlr ;
      ENDIF
      
!      IF ( icefallfac /= 1.0 ) write(0,*) 'icefallfac = ',icefallfac
!      IF ( snowfallfac /= 1.0 ) write(0,*) 'snowfallfac = ',snowfallfac


  RETURN
END SUBROUTINE nssl_2mom_init

! #####################################################################
! #####################################################################

SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw, chl,  &
                              cn, vhw, vhl, cna, cni, f_cn, f_cna, f_cina,               &
                              zrw, zhw, zhl,                                            &
                              qsw, qhw, qhlw,                                           &
                              tt, th, pii, p, w, dn, dz, dtp, itimestep,                &
                              RAINNC,RAINNCV,                                           &
                              dx, dy,                                                   &
                              axtra,                                                    &
                              SNOWNC, SNOWNCV, GRPLNC, GRPLNCV,                         &
                              SR,HAILNC, HAILNCV,                                       &
                              tkediss,                                                  &
                              re_cloud, re_ice, re_snow,                                &
                              has_reqc, has_reqi, has_reqs,                             &
                              rainncw2, rainnci2,                                       &
                              dbz, vzf,compdbz,                                         &
                              rscghis_2d,rscghis_2dp,rscghis_2dn,                       &
                              scr,scw,sci,scs,sch,schl,sctot,                           &
                              elec_physics,                                             &
                              induc,elec,scion,sciona,                                  &
                              noninduc,noninducp,noninducn,                             &
                              pcc2, pre2, depsubr,      &
                              mnucf2, melr2, ctr2,     &
                              rim1_2, rim2_2,rim3_2, &
                              nctr2, nnuccd2, nnucf2, &
                              effc2,effr2,effi2,       &
                              effs2, effg2,                       &
                              fc2, fr2,fi2,fs2,fg2, &
                              fnc2, fnr2,fni2,fns2,fng2, &
!                              qcond,qdep,qfrz,qrauto,qhcnvi,qhcollw,qscollw,            &
!                              ncauto, niinit,nifrz,                                     &
!                              re_liquid, re_graupel, re_hail, re_icesnow,               &
!                              vtcloud, vtrain, vtsnow, vtgraupel, vthail,               &
                              ipelectmp,                                                &
                              diagflag,ke_diag,                                         &
                              nssl_progn,                                              & ! wrf-chem 
! 20130903 acd_mb_washout start
                              wetscav_on, rainprod, evapprod,                           & ! wrf-chem 
! 20130903 acd_mb_washout end
                              cu_used, qrcuten, qscuten, qicuten, qccuten,              & ! hm added
                              ids,ide, jds,jde, kds,kde,                                &  ! domain dims
                              ims,ime, jms,jme, kms,kme,                                &  ! memory dims
                              its,ite, jts,jte, kts,kte)                                   ! tile dims



      implicit none


 !Subroutine arguments:

      integer, intent(in)::                                                             &
                            ids,ide, jds,jde, kds,kde,                                   &
                            ims,ime, jms,jme, kms,kme,                                   &
                            its,ite, jts,jte, kts,kte
      real, dimension(ims:ime, kms:kme, jms:jme), intent(inout)::                        &
                            qv,qc,qr,qs,qh
      ! tt is air temperature -- used by CCPP instead of th (theta)
      real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout)::                       &
                              th, tt,                                                   &
                              zrw, zhw, zhl,                                            &
                              qsw, qhw, qhlw,                                           &
                            qi,qhl,ccw,crw,cci,csw,chw,chl,vhw,vhl
      real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: dbz, vzf, cn, cna, cni
      real, dimension(ims:ime, jms:jme), optional, intent(inout):: compdbz
      real, dimension(ims:ime, jms:jme), optional, intent(inout):: rscghis_2d,  & ! 2D accumulation arrays for vertically-integrated charging rate
                                                                   rscghis_2dp, & ! 2D accumulation arrays for vertically-integrated charging rate (positive only)
                                                                   rscghis_2dn    ! 2D accumulation arrays for vertically-integrated charging rate (negative only)
!      real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout)::rscghis_3d
      integer, optional, intent(in) :: elec_physics
      real, dimension(ims:ime, kms:kme, jms:jme),  optional, intent(inout)::                   &
                            scr,scw,sci,scs,sch,schl,sciona,sctot  ! space charge
      real, dimension(ims:ime, kms:kme, jms:jme),  optional, intent(inout)::                   &
                            induc,noninduc,noninducp,noninducn  ! charging rates: inductive, noninductive (all, positive, negative to graupel)
      real, dimension(ims:ime, kms:kme, jms:jme),  optional, intent(in) :: elec ! elecsave = Ez     
      real, dimension(ims:ime, kms:kme, jms:jme,2),optional, intent(inout) :: scion  
      real, dimension(ims:ime, kms:kme, jms:jme), intent(in)::  p,w,dz,dn

      real, dimension(ims:ime, kms:kme, jms:jme), intent(in)::  pii
      real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout)::   &
                              pcc2, pre2, depsubr,      &
                              mnucf2, melr2, ctr2,     &
                              rim1_2, rim2_2,rim3_2, &
                              nctr2, nnuccd2, nnucf2, &
                              effc2,effr2,effi2,       &
                              effs2, effg2,                       &
                              fc2, fr2,fi2,fs2,fg2, &
                              fnc2, fnr2,fni2,fns2,fng2
!                              qcond,qdep,qfrz,qrauto,qhcnvi,qhcollw,qscollw,            &
!                              ncauto, niinit,nifrz,                                     &
!                              re_liquid, re_graupel, re_hail, re_icesnow,               &
!                              vtcloud, vtrain, vtsnow, vtgraupel, vthail               

       real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout) :: axtra

! WRF variables
      real, dimension(ims:ime, jms:jme), intent(inout)::                                 &
                            RAINNC,RAINNCV    ! accumulated precip (NC) and rate (NCV)
      real, dimension(ims:ime, jms:jme), optional, intent(inout)::                                 &
                            SNOWNC,SNOWNCV,GRPLNC,GRPLNCV,SR        ! accumulated precip (NC) and rate (NCV)
      real, dimension(ims:ime, jms:jme), optional, intent(inout)::                                 &
                            HAILNC,HAILNCV ! accumulated precip (NC) and rate (NCV)
      REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(INOUT)::  re_cloud, re_ice, re_snow
      REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(IN):: tkediss
      INTEGER, INTENT(IN), optional :: has_reqc, has_reqi, has_reqs
      real, dimension(ims:ime, jms:jme), intent(out), optional ::                                 &
                            rainncw2, rainnci2       ! liquid rain, ice, accumulation rates
      real, optional, intent(in) :: dx,dy
      real, intent(in)::    dtp
      integer, intent(in):: itimestep !, ccntype
      logical, optional, intent(in) :: diagflag, f_cna, f_cn, f_cina
      integer, optional, intent(in) :: ipelectmp, ke_diag

  LOGICAL, INTENT(IN), OPTIONAL ::    nssl_progn   ! flags for wrf-chem 
  
!   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional,INTENT(INOUT):: qndrop
  LOGICAL :: flag_qndrop  ! wrf-chem
  LOGICAL :: flag_qnifa , flag_qnwfa
  logical :: flag
  real :: cinchange, t7max,testmax,wmax

! 20130903 acd_ck_washout start
! rainprod - total tendency of conversion of cloud water/ice and graupel to rain (kg kg-1 s-1)
! evapprod - tendency of evaporation of rain (kg kg-1 s-1)
! 20130903 acd_ck_washout end
   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional,INTENT(INOUT)::  rainprod, evapprod

! qrcuten, rain tendency from parameterized cumulus convection
! qscuten, snow tendency from parameterized cumulus convection
! qicuten, cloud ice tendency from parameterized cumulus convection
! mu : air mass in column
   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(IN):: qrcuten, qscuten, qicuten, qccuten
   INTEGER, optional, intent(in) :: cu_used
   LOGICAL, optional, intent(in) :: wetscav_on

!
! local variables
!
     real, dimension(its:ite, 1, kts:kte) :: elec2 ! ez = elecsave slab
!     real, dimension(its:ite, 1, kts:kte,2) :: scion2 ! 1=- , 2=+
     real, dimension(its:ite, kts:kte) :: rainprod2d, evapprod2d,tke2d
     real, dimension(its:ite, 1, kts:kte, na) :: an, ancuten
     real, dimension(its:ite, 1, kts:kte, nxtra) :: axtra2d
     real, dimension(its:ite, 1, kts:kte) :: t0,t1,t2,t3,t4,t5,t6,t7,t8,t9
     real, dimension(its:ite, 1, kts:kte) :: dn1,t00,t77,ssat,pn,wn,dz2d,dz2dinv,dbz2d,vzf2d
     real, dimension(its:ite, 1, na) :: xfall
     integer, parameter :: nor = 0, ng = 0
     integer :: nx,ny,nz
     integer ix,jy,kz,i,j,k,il,n
     integer :: infdo
     real :: ssival, ssifac, t8s, t9s, qvapor
     integer :: ltemq
     double precision :: dp1
     integer :: jye, lnb
     integer :: imx,kmx
     real    :: dbzmx,refl
     integer :: vzflag0 = 0
     logical :: makediag
      real, parameter :: cnin20 = 1.0e3
      real, parameter :: cnin10 = 5.0e1
      real, parameter :: cnin1a = 4.5
      real, parameter :: cnin2a = 12.96
      real, parameter :: cnin2b = 0.639

      double precision :: cwmass1,cwmass2
      double precision :: rwmass1,rwmass2
      double precision :: icemass1,icemass2
      double precision :: swmass1,swmass2
      double precision :: grmass1,grmass2
      double precision :: hlmass1,hlmass2
      double precision :: wvol5,wvol10
      real :: tmp,dv,dv1
      real :: rdt
      
      double precision :: dt1,dt2
      double precision :: timesed,timesed1,timesed2,timesed3, timegs, timenucond, timedbz,zmaxsed
      double precision :: timevtcalc,timesetvt
      
      logical :: f_cnatmp, f_cinatmp
      logical :: has_wetscav

      integer :: kediagloc
      integer :: iunit

      real :: ycent, y, emissrate, emissrate0, emissrate1, z, fac, factot
      real :: fach(kts:kte)

#ifdef MPI

#if defined(MPI) 
      integer, parameter :: ntot = 50
      double precision  mpitotindp(ntot), mpitotoutdp(ntot)
      INTEGER :: mpi_error_code = 1
#endif
#endif


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


      rdt = 1.0/dtp
      
!      write(0,*) 'N2M: entering routine'

     flag_qndrop = .false.
     flag_qnifa = .false.
     flag_qnwfa = .false.
     
     IF ( PRESENT ( nssl_progn ) ) flag_qndrop = nssl_progn

     
     
     
     ! ---

     IF ( present( f_cna ) ) THEN
       f_cnatmp = f_cna
     ELSE 
       f_cnatmp = .false.
     ENDIF

     IF ( present( f_cina ) ) THEN
       f_cinatmp = f_cina
     ELSE 
       f_cinatmp = .false.
     ENDIF
       
     IF ( present( vzf ) ) vzflag0 = 1
     
     IF ( present( ipelectmp ) ) THEN
       ipelec = ipelectmp
     ELSE
       ipelec = 0
     ENDIF
!       IF ( present( dbz ) ) THEN
!       DO jy = jts,jte
!         DO kz = kts,kte
!           DO ix = its,ite
!             dbz(ix,kz,jy) = 0.0
!           ENDDO
!         ENDDO
!       ENDDO
!       ENDIF

     
     makediag = .true.
     IF ( present( diagflag ) ) THEN
      makediag = diagflag .or. itimestep == 1
     ENDIF

!     write(0,*) 'N2M: makediag = ',makediag
     
     
     nx = ite-its+1
     ny = 1         ! set up as 2D slabs
     nz = kte-kts+1
     
     IF ( .not. present( cn ) ) THEN
       renucfrac = 1.0
     ENDIF
     
! set up CCN array and some other static local values
     IF ( itimestep == 1 .and. .not. invertccn .and.  present( cn ) ) THEN
     ! this is not needed for WRF 3.8 and later because it is done in physics_init, 
     ! but kept for backwards compatibility with earlier versions
      IF ( lccna > 1 .and. .not. ( present( cna ) .and. f_cnatmp ) ) THEN
      ! using cn array for cna and use background qccn for local cn array
        DO jy = jts,jte
         DO kz = kts,kte
          DO ix = its,ite
            cn(ix,kz,jy) = 0.0
          ENDDO
         ENDDO
        ENDDO

      ELSEIF ( cn((ite+its)/2,(kte+kts)/2,(jte+jts)/2) < 10.0 ) THEN ! initialize ccn if not already done
        DO jy = jts,jte
         DO kz = kts,kte
          DO ix = its,ite
            cn(ix,kz,jy) = qccn
          ENDDO
         ENDDO
        ENDDO
      ENDIF
     ENDIF

     IF ( itimestep == 1 .and. invertccn .and.  present( cn ) ) THEN
     ! this is not needed for WRF 3.8 and later because it is done in physics_init, 
     ! but kept for backwards compatibility with earlier versions
        DO jy = jts,jte
         DO kz = kts,kte
          DO ix = its,ite
            cn(ix,kz,jy) = 0.0
          ENDDO
         ENDDO
        ENDDO
      ENDIF
     
      IF ( invertccn .and.  present( cn ) ) THEN ! hack for WRF to convert activated ccn to unactivated, then do not have to 
                                              ! worry about initial and boundary conditions - they are zero
        DO jy = jts,jte
         DO kz = kts,kte
           DO ix = its,ite
             cn(ix,kz,jy) = Max( 0.0, qccn - cn(ix,kz,jy) )
           ENDDO
         ENDDO
       ENDDO
       ENDIF

!     ENDIF ! itimestep == 1


! sedimentation settings

      infdo = 2
      
      IF ( infall .ne. 1 .or. iscfall .ge. 2 ) THEN
         infdo = 1
      ELSE
         infdo = 0
      ENDIF

      IF ( infall .ge. 3 .or. ipconc .ge. 6 ) THEN
         infdo = 2
      ENDIF
     

      IF ( present( HAILNCV ) .and. lhl < 1 ) THEN ! for WRF 3.1 compatibility
        HAILNCV(its:ite,jts:jte) = 0.
      ENDIF

      tke2d(:,:) = 0.0 ! initialize if not used

     lnb = Max(lh,lhl)+1 ! lnc
!     IF ( lccn > 1 ) lnb = lccn

       jye = jte

     IF ( present( compdbz ) .and. makediag ) THEN
     DO jy = jts,jye
       DO ix = its,ite
        compdbz(ix,jy) = -3.0
       ENDDO
     ENDDO
     ENDIF

      zmaxsed = 0.0d0
      timevtcalc = 0.0d0
      timesetvt = 0.0d0
      timesed = 0.0d0
      timesed1 = 0.0d0
      timesed2 = 0.0d0
      timesed3 = 0.0d0
      timegs = 0.0d0
      timenucond = 0.0d0



!     write(0,*) 'N2M: jy loop 1, lhl,na = ',lhl,na,present(qhl)

          ancuten(its:ite,1,kts:kte,:) = 0.0

     DO jy = jts,jye
     
     xfall(:,:,:) = 0.0

!     write(0,*) 'N2M: load an, jy,lccn = ',jy,lccn,qccn

     IF ( present( pcc2 ) .and. makediag ) THEN
         axtra2d(its:ite,1,kts:kte,:) = 0.0
     ENDIF

   ! copy from 3D array to 2D slab
   
       DO kz = kts,kte
        DO ix = its,ite

          an(ix,1,kz,lt) = th(ix,kz,jy)

        
          an(ix,1,kz,lv)   = qv(ix,kz,jy)
          an(ix,1,kz,lc)   = qc(ix,kz,jy)
          an(ix,1,kz,lr)   = qr(ix,kz,jy)
          IF ( present( qi ) ) THEN
            an(ix,1,kz,li)   = qi(ix,kz,jy)
          ELSE
            an(ix,1,kz,li) = 0.0
          ENDIF
          an(ix,1,kz,ls)   = qs(ix,kz,jy)
          an(ix,1,kz,lh)   = qh(ix,kz,jy)
          IF ( lhl > 1 ) an(ix,1,kz,lhl)  = qhl(ix,kz,jy)
          IF ( lccn > 1 ) THEN
           IF ( is_aerosol_aware .and. flag_qnwfa ) THEN
            ! 
           ELSEIF ( present( cn ) ) THEN
             IF ( lccna > 1 .and. .not. ( present( cna ) .and. f_cnatmp ) ) THEN
               an(ix,1,kz,lccna) = cn(ix,kz,jy)
               an(ix,1,kz,lccn) = qccn ! cn(ix,kz,jy)
             ELSE
               an(ix,1,kz,lccn) = cn(ix,kz,jy)
             ENDIF
           ELSE
            IF ( lccna == 0 .and. ( .not. f_cnatmp ) ) THEN
              an(ix,1,kz,lccn) = qccn - ccw(ix,kz,jy)
            ELSE
              an(ix,1,kz,lccn) = qccn 
            ENDIF
           
           ENDIF
          ENDIF

          IF ( lccna > 1 ) THEN
            IF ( present( cna ) .and. f_cnatmp ) THEN
              an(ix,1,kz,lccna) = cna(ix,kz,jy)
            ENDIF
          ENDIF

          IF ( lcina > 1 ) THEN
            IF ( present( cni ) .and. f_cinatmp ) THEN
              an(ix,1,kz,lcina) = cni(ix,kz,jy)
            ENDIF
          ENDIF
          
          IF ( ipconc >= 5 ) THEN
             an(ix,1,kz,lnc)  = ccw(ix,kz,jy)
          IF ( constccw > 0.0 ) THEN
            an(ix,1,kz,lnc)  = constccw
          ENDIF
          an(ix,1,kz,lnr)  = crw(ix,kz,jy)
          IF ( present( cci ) ) THEN
            an(ix,1,kz,lni)  = cci(ix,kz,jy)
          ELSE
            an(ix,1,kz,lni) = 0.0
          ENDIF
          an(ix,1,kz,lns)  = csw(ix,kz,jy)
          an(ix,1,kz,lnh)  = chw(ix,kz,jy)
          IF ( lhl > 1 ) an(ix,1,kz,lnhl) = chl(ix,kz,jy)
          ENDIF
          IF ( lvh > 0 ) an(ix,1,kz,lvh)  = vhw(ix,kz,jy)
          IF ( lvhl > 0 .and. present( vhl ) ) an(ix,1,kz,lvhl)  = vhl(ix,kz,jy)

          



          
          t0(ix,1,kz) = th(ix,kz,jy)*pii(ix,kz,jy) ! temperature (Kelvin)
          t1(ix,1,kz) = 0.0
          t2(ix,1,kz) = 0.0
          t3(ix,1,kz) = 0.0
          t4(ix,1,kz) = 0.0
          t5(ix,1,kz) = 0.0
          t6(ix,1,kz) = 0.0
          t7(ix,1,kz) = 0.0
          t8(ix,1,kz) = 0.0
          t9(ix,1,kz) = 0.0
          t00(ix,1,kz) = 380.0/p(ix,kz,jy)
          t77(ix,1,kz) = pii(ix,kz,jy)
          dbz2d(ix,1,kz) = 0.0
          vzf2d(ix,1,kz) = 0.0

          dn1(ix,1,kz) = dn(ix,kz,jy)
          pn(ix,1,kz) = p(ix,kz,jy)
          wn(ix,1,kz) = w(ix,kz,jy)
!          wmax = Max(wmax,wn(ix,1,kz))
          dz2d(ix,1,kz) = dz(ix,kz,jy)
          dz2dinv(ix,1,kz) = 1./dz(ix,kz,jy)
          
         ltemq = Int( (t0(ix,1,kz)-163.15)/fqsat+1.5 )
         ltemq = Min( nqsat, Max(1,ltemq) )
!
! saturation mixing ratio
!
      t8s = t00(ix,1,kz)*tabqvs(ltemq)  !saturation mixing ratio wrt water
      t9s = t00(ix,1,kz)*tabqis(ltemq)  !saturation mixing ratio wrt ice

!
!  calculate rate of nucleation
!
      ssival = Min(t8s,max(an(ix,1,kz,lv),0.0))/t9s  ! qv/qvi

      if ( ssival .gt. 1.0 ) then
!
      IF ( icenucopt == 1 ) THEN

      if ( t0(ix,1,kz).le.268.15 ) then

       dp1 = dn1(ix,1,kz)/rho00*cnin20*exp( Min( 57.0 ,(cnin2a*(ssival-1.0)-cnin2b) ) )
       t7(ix,1,kz) = Min(dp1, 1.0d30)
      end if

!
!   Default value of imeyers5 turns off nucleation by Meyer at higher temperatures
!  This is really from Ferrier (1994), eq. 4.31 - 4.34
      IF ( imeyers5 ) THEN
      if ( t0(ix,1,kz).lt.tfr .and. t0(ix,1,kz).gt.268.15 ) then
      qvapor = max(an(ix,1,kz,lv),0.0)
      ssifac = 0.0
      if ( (qvapor-t9s) .gt. 1.0e-5 ) then
      if ( (t8s-t9s) .gt. 1.0e-5 ) then
      ssifac = (qvapor-t9s) /(t8s-t9s)
      ssifac = ssifac**cnin1a
      end if
      end if
      t7(ix,1,kz) = dn1(ix,1,kz)/rho00*cnin10*ssifac*exp(-(t0(ix,1,kz)-tfr)*bta1)
      end if
      ENDIF
      
!       t7max = Max(t7max,  t7(ix,1,kz) )

      ELSEIF ( icenucopt == 2 ) THEN ! Thompson/Cooper; Note Thompson 2004 has constants of
                                     ! 0.005 and 0.304 because the line function was estimated from Cooper plot
                                     ! Here, the fit line values from Cooper 1986 are converted. Very little difference 
                                     ! in practice
      
        t7(ix,1,kz) = 1000.*0.00446684*exp(0.3108*(273.16 - Max(233.0, t0(ix,1,kz) ) ) ) ! factor of 1000 to convert L**-1 to m**-3

!        write(0,*) 'Cooper t7,ssival = ',ix,kz,t7(ix,1,kz),ssival
      
      ELSEIF ( icenucopt == 3 ) THEN ! Phillips (Meyers/DeMott)

      if ( t0(ix,1,kz).le.268.15 .and.  t0(ix,1,kz) > 243.15 ) then ! Meyers with factor of Psi=0.06
        
       dp1 = 0.06*cnin20*exp( Min( 57.0 ,(cnin2a*(ssival-1.0)-cnin2b) ) )
       t7(ix,1,kz) = Min(dp1, 1.0d30)
      elseif ( t0(ix,1,kz) <= 243.15 ) then ! Phillips estimate of DeMott et al (2003) data
       dp1 = 1000.*( exp( Min( 57.0 ,cnin2a*(ssival-1.1) ) ) )**0.3
       t7(ix,1,kz) = Min(dp1, 1.0d30)
      
      end if

      ELSEIF ( icenucopt == 4 ) THEN ! DeMott 2010

        IF ( t0(ix,jy,kz) < 268.16 .and.  t0(ix,jy,kz) > 223.15 .and. ssival > 1.001 ) THEN ! 
      
        ! a = 0.0000594, b = 3.33, c = 0.0264, d = 0.0033,
        ! nint = a*(-Tc)**b * naer**(c*(-Tc) + d)
        ! nint has units of per (standard) liter, so mult by 1.e3 and scale by dn/rho00
        ! naer needs units of cm**-3, so mult by 1.e-6
        
        !  dp1 = 1.e3*0.0000594*(273.16 - t0(ix,jy,kz))**3.33 * (1.e-6*cin*dn(ix,jy,kz))**(0.0264*(273.16 - t0(ix,jy,kz)) + 0.0033)
          dp1 = 1.e3*dn(ix,jy,kz)/rho00*0.0000594*(273.16 - t0(ix,jy,kz))**3.33 * (1.e-6*naer)**(0.0264*(273.16 - t0(ix,jy,kz)) + 0.0033)
          t7(ix,jy,kz) = Min(dp1, 1.0d30)
      
        ELSE
          t7(ix,jy,kz) = 0.0
        ENDIF
      
      ENDIF ! icenucopt


!
      end if ! ( ssival .gt. 1.0 )
!

        ENDDO ! ix
       ENDDO ! kz

         has_wetscav = .false.
         IF ( wrfchem_flag > 0 ) THEN
           IF ( PRESENT( wetscav_on ) ) THEN
             has_wetscav = wetscav_on
             IF ( has_wetscav ) THEN
               IF ( PRESENT( rainprod ) ) rainprod2d(its:ite,kts:kte) = 0
               IF ( PRESENT( evapprod ) ) evapprod2d(its:ite,kts:kte) = 0
             ENDIF
           ENDIF
         ENDIF
         

   ! transform from number mixing ratios to number conc.
     
     DO il = lnb,na
       IF ( denscale(il) == 1 ) THEN
         DO kz = kts,kte
          DO ix = its,ite
           an(ix,1,kz,il) = an(ix,1,kz,il)*dn(ix,kz,jy)
          ENDDO
         ENDDO
       ENDIF
     ENDDO ! il
        
! sedimentation
      xfall(:,:,:) = 0.0
       
      IF ( .true. ) THEN


! #ifndef CM1
! for real cases when hydrometeor mixing ratios have been initialized without concentrations
       IF ( itimestep == 1 .and. ipconc > 0 ) THEN
         call calcnfromq(nx,ny,nz,an,na,nor,nor,dn1)
       ENDIF
! #endif

      IF ( present(cu_used) .and.         &
           ( present( qrcuten ) .or. present( qscuten ) .or.  &
             present( qicuten ) .or. present( qccuten ) ) ) THEN

       IF ( cu_used == 1 ) THEN
       DO kz = kts,kte
        DO ix = its,ite

         IF ( present( qrcuten ) ) ancuten(ix,1,kz,lr) = dtp*qrcuten(ix,kz,jy)
         IF ( present( qscuten ) ) ancuten(ix,1,kz,ls) = dtp*qscuten(ix,kz,jy)
         IF ( present( qicuten ) ) ancuten(ix,1,kz,li) = dtp*qicuten(ix,kz,jy)
         IF ( present( qccuten ) ) ancuten(ix,1,kz,lc) = dtp*qccuten(ix,kz,jy)
         
        ENDDO
       ENDDO
       
         call calcnfromcuten(nx,ny,nz,ancuten,an,na,nor,nor,dn1)

       
       ENDIF
       
      ENDIF


      call sediment1d(dtp,nx,ny,nz,an,na,nor,nor,xfall,dn1,dz2d,dz2dinv, &
     &                    t0,t7,infdo,jy,its,jts &
     &   ,timesed1,timesed2,timesed3,zmaxsed,timesetvt)


! copy xfall to appropriate places...

!     write(0,*) 'N2M: end sediment, jy = ',jy

       DO ix = its,ite
         IF ( lhl > 1 ) THEN
         RAINNCV(ix,jy) = dtp*dn1(ix,1,1)*(xfall(ix,1,lr) + xfall(ix,1,ls)*1000./xdn0(lr) + &
              &            xfall(ix,1,lh)*1000./xdn0(lr) + xfall(ix,1,lhl)*1000./xdn0(lr) )
         ELSE
         RAINNCV(ix,jy) = dtp*dn1(ix,1,1)*(xfall(ix,1,lr) + xfall(ix,1,ls)*1000./xdn0(lr) + &
              &            xfall(ix,1,lh)*1000./xdn0(lr) )
         ENDIF
         IF ( present ( rainncw2 ) ) THEN ! rain only
           rainncw2(ix,jy) =  rainncw2(ix,jy) +  dtp*dn1(ix,1,1)*xfall(ix,1,lr)
         ENDIF
         IF ( present ( rainnci2 ) ) THEN ! ice only
           IF ( lhl > 1 ) THEN
             rainnci2(ix,jy) =rainnci2(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,ls)*1000./xdn0(lr) + &
     &            xfall(ix,1,lh)*1000./xdn0(lr) + xfall(ix,1,lhl)*1000./xdn0(lr) )
           ELSE
             rainnci2(ix,jy) = rainnci2(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,ls)*1000./xdn0(lr) + &
     &            xfall(ix,1,lh)*1000./xdn0(lr) )
           ENDIF
         ENDIF
         IF ( present( SNOWNCV ) ) SNOWNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,ls)*1000./xdn0(lr)
         IF ( present( GRPLNCV ) ) GRPLNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lh)*1000./xdn0(lr)
         RAINNC(ix,jy)  = RAINNC(ix,jy) + RAINNCV(ix,jy)

         IF ( present (SNOWNC) .and. present (SNOWNCV) ) SNOWNC(ix,jy)  = SNOWNC(ix,jy) + SNOWNCV(ix,jy)
         IF ( lhl > 1 ) THEN
!#ifdef CM1
!           IF ( .true. ) THEN
!#else
           IF ( present( HAILNC ) ) THEN
!#endif
             HAILNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr)
             HAILNC(ix,jy)  = HAILNC(ix,jy) + HAILNCV(ix,jy)
           ELSEIF ( present( GRPLNCV ) ) THEN
             GRPLNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr)
           ENDIF
         ENDIF
         IF ( present( GRPLNCV ) ) GRPLNC(ix,jy)  = GRPLNC(ix,jy) + GRPLNCV(ix,jy)
        IF ( present( SR ) .and. present (SNOWNCV) .and. present(GRPLNCV) ) THEN
         IF ( present( HAILNC ) ) THEN
           SR(ix,jy)      = (SNOWNCV(ix,jy)+HAILNCV(ix,jy)+GRPLNCV(ix,jy))/(RAINNCV(ix,jy)+1.e-12)
         ELSE
           SR(ix,jy)      = (SNOWNCV(ix,jy)+GRPLNCV(ix,jy))/(RAINNCV(ix,jy)+1.e-12)
         ENDIF
        ENDIF
       ENDDO
       
      ENDIF ! .false.
 
      IF ( isedonly /= 1 ) THEN
   ! call nssl_2mom_gs: main gather-scatter routine to calculate microphysics

!     write(0,*) 'N2M: gs, jy = ',jy
!      IF ( isedonly /= 2 ) THEN


      call nssl_2mom_gs   &
     &  (nx,ny,nz,na,jy   &
     &  ,nor,nor          &
     &  ,dtp,dz2d       &
     &  ,t0,t1,t2,t3,t4,t5,t6,t7,t8,t9     &
     &  ,an,dn1,t77                        &
     &  ,pn,wn,0                           &
     &  ,t00,t77,                          &
     &   ventr,ventc,c1sw,1,ido,           &
     &   xdnmx,xdnmn,                      &
!     &   ln,ipc,lvol,lz,lliq,              &
     &   cdx,                              &
     &   xdn0,dbz2d,tke2d,                 &
     &   timevtcalc,axtra2d, makediag        &
     &   ,has_wetscav, rainprod2d, evapprod2d  &
     &   ,elec2,its,ids,ide,jds,jde          &
     & )





   ENDIF ! isedonly /= 1
   
 ! droplet nucleation/condensation/evaporation
   IF ( .true. ) THEN
   CALL NUCOND    &
     &  (nx,ny,nz,na,jy & 
     &  ,nor,nor,dtp,nx  &
     &  ,dz2d & 
     &  ,t0,t9 & 
     &  ,an,dn1,t77 & 
     &  ,pn,wn & 
     &  ,axtra2d, makediag  &
     &  ,ssat,t00,t77,flag_qndrop)


   ENDIF


     IF ( present( pcc2 ) .and. makediag ) THEN
         DO kz = kts,kte
          DO ix = its,ite
! example of using the 'axtra2d' array to get rates out of the microphysics routine for output.
! Search for 'axtra' to find example code below
!            pcc2(ix,kz,jy)    = axtra2d(ix,1,kz,1)

          ENDDO
         ENDDO
     ENDIF


! compute diagnostic S-band reflectivity if needed
     IF ( present( dbz ) .and. makediag ) THEN
   ! calc dbz
      
      IF ( .true. ) THEN
      IF ( present(ke_diag) ) THEN
        kediagloc = ke_diag
      ELSE
        kediagloc = nz
      ENDIF
      call radardd02(nx,ny,nz,nor,na,an,t0,         &
     &    dbz2d,dn1,nz,cnoh,rho_qh,ipconc,kediagloc, 0)
      ENDIF ! .false.

     
       DO kz = kts,kediagloc ! kte
        DO ix = its,ite
         dbz(ix,kz,jy) = dbz2d(ix,1,kz)
         IF ( present( vzf ) ) THEN
           vzf(ix,kz,jy) = vzf2d(ix,1,kz)
           IF ( dbz2d(ix,1,kz) <= 0.0 ) THEN
             vzf(ix,kz,jy) = 0.0
           ELSEIF ( dbz2d(ix,1,kz) <= 15.0 ) THEN
             refl = 10**(0.1*dbz2d(ix,1,kz))
             vzf(ix,kz,jy) = Min( vzf2d(ix,1,kz), 2.6 * Max(0.0,refl)**0.107 * (1.2/dn1(ix,1,kz))**0.4 )
           ENDIF
         ENDIF
          IF ( present( compdbz ) ) THEN
            compdbz(ix,jy) = Max( compdbz(ix,jy), dbz2d(ix,1,kz) )
          ENDIF
        ENDDO
       ENDDO

       ENDIF



! Following Greg Thompson, calculation for effective radii. Used by RRTMG LW/SW schemes if enabled in module_physics_init.F
      IF ( present( has_reqc ).and. present( has_reqi ) .and. present( has_reqs ) .and.  &
           present( re_cloud ).and. present( re_ice ) .and. present( re_snow ) ) THEN
       IF ( has_reqc.ne.0 .or. has_reqi.ne.0 .or. has_reqs.ne.0) THEN
         DO kz = kts,kte
          DO ix = its,ite
             re_cloud(ix,kz,jy)  = 2.51E-6
             re_ice(ix,kz,jy)    = 10.01E-6
             re_snow(ix,kz,jy)   = 25.E-6
             t1(ix,1,kz) = 2.51E-6
             t2(ix,1,kz) = 10.01E-6
             t3(ix,1,kz) = 25.E-6
          ENDDO
         ENDDO

          call calc_eff_radius   &
     &         (nx,ny,nz,na,jy & 
     &          ,nor,nor & 
     &          ,t1,t2,t3  & 
     &          ,an,dn1 )

        DO kz = kts,kte
          DO ix = its,ite
             re_cloud(ix,kz,jy) = MAX(2.51E-6, MIN(t1(ix,1,kz), 50.E-6))
             re_ice(ix,kz,jy)   = MAX(10.01E-6, MIN(t2(ix,1,kz), 125.E-6))
             re_snow(ix,kz,jy)  = MAX(25.E-6, MIN(t3(ix,1,kz), 999.E-6))
             ! check for case where snow needs to be treated as cloud ice (for rrtmg radiation)
             IF ( .not. present(qi) ) re_ice(ix,kz,jy)  = MAX(10.E-6, MIN(t3(ix,1,kz), 125.E-6))
          ENDDO
         ENDDO
       
         ENDIF
        ENDIF



   
! transform concentrations back to mixing ratios
     DO il = lnb,na
      IF ( denscale(il) == 1 ) THEN
       DO kz = kts,kte
        DO ix = its,ite
         an(ix,1,kz,il) = an(ix,1,kz,il)/dn(ix,kz,jy)
        ENDDO
       ENDDO
      ENDIF
     ENDDO ! il
   
   ! copy 2D slabs back to 3D

   
       DO kz = kts,kte
        DO ix = its,ite
        
         th(ix,kz,jy)  = an(ix,1,kz,lt)

         qv(ix,kz,jy)  = an(ix,1,kz,lv)
         qc(ix,kz,jy)  = an(ix,1,kz,lc)
         qr(ix,kz,jy)  = an(ix,1,kz,lr)
         IF ( present(qi) ) qi(ix,kz,jy)  = an(ix,1,kz,li)
         qs(ix,kz,jy)  = an(ix,1,kz,ls)
         qh(ix,kz,jy)  = an(ix,1,kz,lh)
         IF ( lhl > 1 ) qhl(ix,kz,jy) = an(ix,1,kz,lhl)
         
         IF ( lccn > 1 .and. is_aerosol_aware .and. flag_qnwfa ) THEN
           ! not used here
         ELSEIF ( present( cn ) .and. lccn > 1 .and. .not. flag_qndrop) THEN
            IF ( lccna > 1 .and. .not. present( cna ) ) THEN
              cn(ix,kz,jy) = Max(0.0, an(ix,1,kz,lccna) )
            ELSE
              cn(ix,kz,jy) = an(ix,1,kz,lccn)
            ENDIF
         ENDIF
         IF ( lccna > 1 ) THEN
           IF ( present( cna ) .and. f_cnatmp ) THEN
              cna(ix,kz,jy) = Max(0.0, an(ix,1,kz,lccna) )
           ENDIF
         ENDIF

         IF ( lcina > 1 ) THEN
           IF ( present( cni ) .and. f_cinatmp ) THEN
              cni(ix,kz,jy) = Max(0.0, an(ix,1,kz,lcina) )
           ENDIF
         ENDIF

         IF ( ipconc >= 5 ) THEN

          ccw(ix,kz,jy) = an(ix,1,kz,lnc)
          crw(ix,kz,jy) = an(ix,1,kz,lnr)
          IF ( present( cci ) ) cci(ix,kz,jy) = an(ix,1,kz,lni)
          csw(ix,kz,jy) = an(ix,1,kz,lns)
          chw(ix,kz,jy) = an(ix,1,kz,lnh)
          IF ( lhl > 1 ) chl(ix,kz,jy) = an(ix,1,kz,lnhl)
         ENDIF




         IF ( lvh > 0 )  vhw(ix,kz,jy) = an(ix,1,kz,lvh)
         IF ( lvhl > 0 .and. present( vhl ) ) vhl(ix,kz,jy) = an(ix,1,kz,lvhl)

#if ( WRF_CHEM == 1 )
         IF ( has_wetscav ) THEN
           IF ( PRESENT( rainprod ) ) rainprod(ix,kz,jy) = rainprod2d(ix,kz)
           IF ( PRESENT( evapprod ) ) evapprod(ix,kz,jy) = evapprod2d(ix,kz)
         ENDIF
#endif

        ENDDO
       ENDDO
  
     ENDDO ! jy
     
      IF (  invertccn .and. present( cn ) ) THEN ! hack to convert unactivated ccn  back to activated
        DO jy = jts,jte
         DO kz = kts,kte
           DO ix = its,ite
             cn(ix,kz,jy) = Max( 0.0, qccn - cn(ix,kz,jy) )
           ENDDO
         ENDDO
       ENDDO
       ENDIF





  RETURN
END SUBROUTINE nssl_2mom_driver

! #####################################################################
! #####################################################################

      REAL FUNCTION GAMMA_SP(xx)

      implicit none
      real xx
      integer j

! Double precision ser,stp,tmp,x,y,cof(6)

      real*8 ser,stp,tmp,x,y,cof(6)
      SAVE cof,stp
      DATA cof,stp/76.18009172947146d+0,  &
     &            -86.50532032941677d0,   &
     &             24.01409824083091d0,   &
     &             -1.231739572450155d0,  &
     &              0.1208650973866179d-2,&
     &             -0.5395239384953d-5,   &
     &              2.5066282746310005d0/

      IF ( xx <= 0.0 ) THEN
        write(0,*) 'Argument to gamma must be > 0!! xx = ',xx
        STOP
      ENDIF
      
      x = xx
      y = x
      tmp = x + 5.5d0
      tmp = (x + 0.5d0)*Log(tmp) - tmp
      ser = 1.000000000190015d0
      DO j=1,6
        y = y + 1.0d0
        ser = ser + cof(j)/y
      END DO
      gamma_sp = Exp(tmp + log(stp*ser/x))

      RETURN
      END FUNCTION GAMMA_SP

! #####################################################################

      DOUBLE PRECISION FUNCTION GAMMA_DPR(x)
      ! dp gamma with real input
        implicit none
        real :: x
        double precision :: xx
        
        xx = x
        
        gamma_dpr = gamma_dp(xx)
        
        return
        end FUNCTION GAMMA_DPR
        



! #####################################################################

        real function GAMXINF(A1,X1)

!       ===================================================
!       Purpose: Compute the incomplete gamma function
!                from x to infinity
!       Input :  a   --- Parameter ( a  170 )
!                x   --- Argument 
!       Output:  GIM --- gamma(a,x) t=x,Infinity
!       Routine called: GAMMA for computing gamma(x)
!       ===================================================

!        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        implicit none
        real :: a1,x1
        double precision :: xam,dlog,s,r,ga,t0,a,x
        integer :: k
        double precision :: gin, gim
        
        a = a1
        x = x1
        IF ( x1 <= 0.0 ) THEN
           gamxinf = GAMMA_SP(A1)
           return
        ENDIF
        XAM=-X+A*DLOG(X)
        IF (XAM.GT.700.0.OR.A.GT.170.0) THEN
           WRITE(*,*)'a and/or x too large'
           STOP
        ENDIF
        IF (X.EQ.0.0) THEN
           GIN=0.0
           GIM = GAMMA_SP(A1)
        ELSE IF (X.LE.1.0+A) THEN
           S=1.0D0/A
           R=S
           DO 10 K=1,60
              R=R*X/(A+K)
              S=S+R
              IF (DABS(R/S).LT.1.0D-15) GO TO 15
10         CONTINUE
15         GIN=DEXP(XAM)*S
           ga = GAMMA_SP(A1)
           GIM=GA-GIN
        ELSE IF (X.GT.1.0+A) THEN
           T0=0.0D0
           DO 20 K=60,1,-1
              T0=(K-A)/(1.0D0+K/(X+T0))
20         CONTINUE
           GIM=DEXP(XAM)/(X+T0)
!           GA = GAMMA_SP(A1)
!           GIN=GA-GIM
        ENDIF
        
        gamxinf = GIM
        return
        END function GAMXINF

! #####################################################################

        double precision function GAMXINFDP(A1,X1)

!       ===================================================
!       Purpose: Compute the incomplete gamma function
!                from x to infinity
!       Input :  a   --- Parameter ( a < 170 )
!                x   --- Argument 
!       Output:  GIM --- Gamma(a,x) t=x,Infinity
!       Routine called: GAMMA for computing gamma_dp(x)
!       ===================================================

!        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        implicit none
        real :: a1,x1
! dont declare gamma_dp because it is within the module
!        double precision :: gamma_dp
        double precision :: xam,dlog,s,r,ga,t0,a,x
        integer :: k
        double precision :: gin, gim
        
        a = a1
        x = x1
        IF ( x1 <= 0.0 ) THEN
           gamxinfdp = GAMMA_DP(A)
           return
        ENDIF
        XAM=-X+A*DLOG(X)
        IF (XAM.GT.700.0.OR.A.GT.170.0) THEN
           WRITE(*,*)'a and/or x too large'
           STOP
        ENDIF
        IF (X.EQ.0.0) THEN
           GIN=0.0
           GIM = GAMMA_dp(A)
        ELSE IF (X.LE.1.0+A) THEN
           S=1.0D0/A
           R=S
           DO 10 K=1,60
              R=R*X/(A+K)
              S=S+R
              IF (DABS(R/S).LT.1.0D-15) GO TO 15
10         CONTINUE
15         GIN=DEXP(XAM)*S
           ga = GAMMA_DP(A)
           GIM=GA-GIN
        ELSE IF (X.GT.1.0+A) THEN
           T0=0.0D0
           DO 20 K=60,1,-1
              T0=(K-A)/(1.0D0+K/(X+T0))
20         CONTINUE
           GIM=DEXP(XAM)/(X+T0)
!           GA = GAMMA_dp(A)
!           GIN=GA-GIM
        ENDIF
        
        gamxinfdp = GIM
        return
        END function GAMXINFDP


! #####################################################################

! #ifdef Z3MOM
      real function gaminterp(ratio, alp, luindex, ilh)
      
      implicit none

      real, intent(in) :: ratio, alp
      integer, intent(in) :: ilh  ! 1 = graupel, 2 = hail
      integer, intent(in) :: luindex ! which argument: 
                         ! gamxinflu(i,j,1,1) = x/y
                          ! gamxinflu(i,j,2,1) = gamxinf( 2.0+alp, ratio )/y
                          ! gamxinflu(i,j,3,1) = gamxinf( 2.5+alp+0.5*bxh, ratio )/y
                          ! gamxinflu(i,j,5,1) = gamxinf( 5.0+alp, ratio )/y
                          ! gamxinflu(i,j,6,1) = gamxinf( 5.5+alp+0.5*bxh, ratio )/y

      
      real :: delx, dely, tmp1, tmp2, temp3
      integer :: i,j,ip1,jp1 !,ilh
      
!      ilh = Abs(ilh0)


           i = Min(nqiacrratio,Int(ratio*dqiacrratioinv))
           j = Int(Max(0.0,Min(maxalphalu,alp))*dqiacralphainv)
           delx = Min(maxratiolu,ratio) - float(i)*dqiacrratio
           dely = alp - float(j)*dqiacralpha
           ip1 = Min( i+1, nqiacrratio )
           jp1 = Min( j+1, nqiacralpha )

           ! interpolate along x, i.e., ratio; 
           tmp1 = gamxinflu(i,j,luindex,ilh) + delx*dqiacrratioinv*         &
     &                 (gamxinflu(ip1,j,luindex,ilh) - gamxinflu(i,j,luindex,ilh))
           tmp2 = gamxinflu(i,jp1,luindex,ilh) + delx*dqiacrratioinv*       &
     &                 (gamxinflu(ip1,jp1,luindex,ilh) - gamxinflu(i,jp1,luindex,ilh))
           
           ! interpolate along alpha; 
           
           gaminterp = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))
           
           ! debug
!           IF ( ilh0 < 0 ) THEN
!             write(0,*) 'gaminterp: ',i,j,ilh,ratio,delx,dely,gamxinflu(i,j,luindex,ilh),tmp1,tmp2
!           ENDIF
           
        END FUNCTION gaminterp
! #endif /* Z3MOM */
! #####################################################################

!**************************** GAML02 *********************** 
!  This calculates Gamma(0.2,x)/Gamma[0.2], where is a ratio
!   It is used for qiacr with the gamma of volume to calculate what 
!   fraction of drops exceed a certain size (this version is for 40 micron drops)
! **********************************************************
      real FUNCTION GAML02(x) 
      implicit none
      integer ig, i, ii, n, np
      real x
      integer ng
      parameter(ng=12)
      real gamxg(ng), xg(ng)
      DATA xg/0.01,0.02,0.025,0.04,0.075,0.1,0.25,0.5,0.75,1.,2.,10./ 
      DATA gamxg/  &
     &  7.391019203578037e-8,0.02212726874591478,0.06959352407989682, &
     &  0.2355654024970809,0.46135930387500346,0.545435791452399,     &
     &  0.7371571313308203,                                           &
     &  0.8265676632204345,0.8640182781845841,0.8855756211304151,     &
     &  0.9245079225301251,                                           &
     &  0.9712578342732681/
      IF ( x .ge. xg(ng) ) THEN
        gaml02 = xg(ng)
        RETURN
      ENDIF
      IF ( x .lt. xg(1) ) THEN
        gaml02 = 0.0
        RETURN
      ENDIF
      DO ii = 1,ng-1
        i = ng - ii
        n = i
        np = n + 1
        IF ( x .ge. xg(i) ) THEN
!         GOTO 2 
          gaml02 = gamxg(N)+((X-XG(N))/(XG(NP)-XG(N)))* &
     &            ( gamxg(NP) - gamxg(N) ) 
          RETURN
        ENDIF
      ENDDO
      RETURN
      END FUNCTION GAML02

!**************************** GAML02d300 *********************** 
!  This calculates Gamma(0.2,x)/Gamma[0.2], where is a ratio
!   It is used for qiacr with the gamma of volume to calculate what 
!   fraction of drops exceed a certain size (this version is for 300 micron drops) (see zieglerstuff.nb)
! **********************************************************
      real FUNCTION GAML02d300(x) 
      implicit none
      integer ig, i, ii, n, np
      real x
      integer ng
      parameter(ng=9)
      real gamxg(ng), xg(ng)
      DATA xg/0.04,0.075,0.1,0.25,0.5,0.75,1.,2.,10./ 
      DATA gamxg/                           &
     &  0.0,                                  &
     &  7.391019203578011e-8,0.0002260640810600053,  &
     &  0.16567071824457152,                         &
     &  0.4231369044918005,0.5454357914523988,       &
     &  0.6170290936864555,                           &
     &  0.7471346054110058,0.9037156157718299 /
      IF ( x .ge. xg(ng) ) THEN
        GAML02d300 = xg(ng)
        RETURN
      ENDIF
      IF ( x .lt. xg(1) ) THEN
        GAML02d300 = 0.0
        RETURN
      ENDIF
      DO ii = 1,ng-1
        i = ng - ii
        n = i
        np = n + 1
        IF ( x .ge. xg(i) ) THEN
!         GOTO 2 
          GAML02d300 = gamxg(N)+((X-XG(N))/(XG(NP)-XG(N)))*  &
     &            ( gamxg(NP) - gamxg(N) ) 
          RETURN
        ENDIF
      ENDDO
      RETURN
      END FUNCTION GAML02d300
!c

! #####################################################################
! #####################################################################

!**************************** GAML02 *********************** 
!  This calculates Gamma(0.2,x)/Gamma[0.2], where is a ratio
!   It is used for qiacr with the gamma of volume to calculate what 
!   fraction of drops exceed a certain size (this version is for 500 micron drops) (see zieglerstuff.nb)
! **********************************************************
      real FUNCTION GAML02d500(x) 
      implicit none
      integer ig, i, ii, n, np
      real x
      integer ng
      parameter(ng=9)
      real gamxg(ng), xg(ng)
      DATA xg/0.04,0.075,0.1,0.25,0.5,0.75,1.,2.,10./ 
      DATA gamxg/  &
     &  0.0,0.0,   &
     &  2.2346039e-13, 0.0221272687459,  &
     &  0.23556540,  0.38710348,         &
     &  0.48136183,0.6565833,            &
     &  0.86918315 /
      IF ( x .ge. xg(ng) ) THEN
        GAML02d500 = xg(ng)
        RETURN
      ENDIF
      IF ( x .lt. xg(1) ) THEN
        GAML02d500 = 0.0
        RETURN
      ENDIF
      DO ii = 1,ng-1
        i = ng - ii
        n = i
        np = n + 1
        IF ( x .ge. xg(i) ) THEN
!         GOTO 2 
          GAML02d500 = gamxg(N)+((X-XG(N))/(XG(NP)-XG(N)))*  &
     &            ( gamxg(NP) - gamxg(N) ) 
          RETURN
        ENDIF
      ENDDO
      RETURN
      END FUNCTION GAML02d500
!c

! #####################################################################

! #####################################################################


        real function BETA(P,Q)
!
!       ==========================================
!       Purpose: Compute the beta function B(p,q)
!       Input :  p  --- Parameter  ( p > 0 )
!                q  --- Parameter  ( q > 0 )
!       Output:  BT --- B(p,q)
!       Routine called: GAMMA for computing gamma(x)
!       ==========================================
!
!        IMPLICIT real (A-H,O-Z)
        implicit none
        double precision p1,gp,q1,gq, ppq,gpq
        real p,q
        
        p1 = p
        q1 = q
        CALL GAMMADP(P1,GP)
        CALL GAMMADP(Q1,GQ)
        PPQ=P1+Q1
        CALL GAMMADP(PPQ,GPQ)
        beta=GP*GQ/GPQ
        RETURN
        END function BETA

! #####################################################################
! #####################################################################

      DOUBLE PRECISION FUNCTION GAMMA_DP(xx)

      implicit none
      double precision xx
      integer j

! Double precision ser,stp,tmp,x,y,cof(6)

      real*8 ser,stp,tmp,x,y,cof(6)
      SAVE cof,stp
      DATA cof,stp/76.18009172947146d+0,  &
     &            -86.50532032941677d0,   &
     &             24.01409824083091d0,   &
     &             -1.231739572450155d0,  &
     &              0.1208650973866179d-2,&
     &             -0.5395239384953d-5,   &
     &              2.5066282746310005d0/

      x = xx
      y = x
      tmp = x + 5.5d0
      tmp = (x + 0.5d0)*Log(tmp) - tmp
      ser = 1.000000000190015d0
      DO j=1,6
        y = y + 1.0d0
        ser = ser + cof(j)/y
      END DO
      gamma_dp = Exp(tmp + log(stp*ser/x))

      RETURN
      END function gamma_dp
! #####################################################################

        SUBROUTINE GAMMADP(X,GA)
!
!       ==================================================
!       Purpose: Compute gamma function Gamma(x)
!       Input :  x  --- Argument of Gamma(x)
!                       ( x is not equal to 0,-1,-2,...)
!       Output:  GA --- gamma(x)
!       ==================================================
!
!        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        implicit none
        
        double precision, parameter :: PI=3.141592653589793D0
        double precision :: x,ga,z,r,gr
        integer :: k,m1,m
        
        double precision :: G(26)
        
        IF (X.EQ.INT(X)) THEN
           IF (X.GT.0.0D0) THEN
              GA=1.0D0
              M1=X-1
              DO K=2,M1
                GA=GA*K
              ENDDO
           ELSE
              GA=1.0D+300
           ENDIF
        ELSE
           IF (DABS(X).GT.1.0D0) THEN
              Z=DABS(X)
              M=INT(Z)
              R=1.0D0
              DO K=1,M
                 R=R*(Z-K)
              ENDDO
              Z=Z-M
           ELSE
              Z=X
           ENDIF
           DATA G/1.0D0,0.5772156649015329D0,                  &
     &          -0.6558780715202538D0, -0.420026350340952D-1,  &
     &          0.1665386113822915D0,-.421977345555443D-1,     &
     &          -.96219715278770D-2, .72189432466630D-2,       &
     &          -.11651675918591D-2, -.2152416741149D-3,       &
     &          .1280502823882D-3, -.201348547807D-4,          &
     &          -.12504934821D-5, .11330272320D-5,             &
     &          -.2056338417D-6, .61160950D-8,                 &
     &          .50020075D-8, -.11812746D-8,                   &
     &          .1043427D-9, .77823D-11,                       &
     &          -.36968D-11, .51D-12,                          &
     &          -.206D-13, -.54D-14, .14D-14, .1D-15/
           GR=G(26)
           DO K=25,1,-1
             GR=GR*Z+G(K)
           ENDDO
           GA=1.0D0/(GR*Z)
           IF (DABS(X).GT.1.0D0) THEN
              GA=GA*R
              IF (X.LT.0.0D0) GA=-PI/(X*GA*DSIN(PI*X))
           ENDIF
        ENDIF
        RETURN
        END SUBROUTINE GAMMADP


! #####################################################################
! #####################################################################
!
!
! #####################################################################
      Function delbk(bb,nu,mu,k)
!   
!  Purpose: Caluculates collection coefficients following Siefert (2006)
!
!  delbk is equation (90) (b collecting b -- self-collection)
!  mass-diameter relationship: D = a*x**(b), where x = particle mass
!  general distribution: n(x) = A*x**(nu)*Exp(-lam*x**(mu))
!  where
!      A = mu*N/(Gamma((nu+1)/mu)) *lam**((nu+1)/mu)
!
!      lam = ( Gamma((nu+1)/mu)/Gamma((nu+2)/mu) * xbar )**(-mu)
!
!     where  xbar = L/N  (mass content)/(number concentration) = q*rhoa/N
!

      implicit none
      real delbk
      real nu, mu, bb
      integer k
      
      real tmp, del
      real x1, x2, x3, x4
      integer i

        tmp = ((1.0 + nu)/mu)
        i = Int(dgami*(tmp))
        del = tmp - dgam*i
        x1 = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami

        tmp = ((2.0 + nu)/mu)
        i = Int(dgami*(tmp))
        del = tmp - dgam*i
        x2 = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami

        tmp = ((1.0 + 2.0*bb + k + nu)/mu)
        i = Int(dgami*(tmp))
        del = tmp - dgam*i
        x3 = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
      
!      delbk =  &
!     &  ((Gamma_sp((1.0 + nu)/mu)/Gamma_sp((2.0 + nu)/mu))**(2.0*bb + k)* &
!     &    Gamma_sp((1.0 + 2.0*bb + k + nu)/mu))/Gamma_sp((1.0 + nu)/mu)

      delbk =  &
     &  ((x1/x2)**(2.0*bb + k)* &
     &    x3)/x1
      
      RETURN
      END  Function delbk
      
! #####################################################################
!
!
! #####################################################################
! Equation (91) in Seifert and Beheng (2006) ("a" collecting "b")
      Function delabk(ba,bb,nua,nub,mua,mub,k)
      
      implicit none
      real delabk
      real nua, mua, ba
      integer k
      real nub, mub, bb
      
      integer i
      real tmp,del
      
      real g1pnua, g2pnua, g1pbapnua, g1pbbpk, g1pnub, g2pnub
      
        tmp = (1. + nua)/mua
        i = Int(dgami*(tmp))
        del = tmp - dgam*i
        IF ( i+1 > ngm0 ) THEN
          write(0,*) 'delabk: i+1 > ngm0!!!!',i,ngm0,nua,mua,tmp
          STOP
        ENDIF
        g1pnua = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
!        write(91,*) 'delabk: g1pnua,gamma = ',g1pnua,Gamma_sp((1. + nua)/mua)

        tmp = ((2. + nua)/mua)
        i = Int(dgami*(tmp))
        del = tmp - dgam*i
        g2pnua = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami

        tmp = ((1. + ba + nua)/mua)
        i = Int(dgami*(tmp))
        del = tmp - dgam*i
        g1pbapnua = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami

        tmp = ((1. + nub)/mub)
        i = Int(dgami*(tmp))
        del = tmp - dgam*i
        g1pnub = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami

        tmp = ((2 + nub)/mub)
        i = Int(dgami*(tmp))
        del = tmp - dgam*i
        g2pnub = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami

        tmp = ((1. + bb + k + nub)/mub)
        i = Int(dgami*(tmp))
        del = tmp - dgam*i
        g1pbbpk = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami

      delabk =  &
     &  (2.*(g1pnua/g2pnua)**ba*     &
     &    g1pbapnua*                                               &
     &    (g1pnub/g2pnub)**(bb + k)*                                &
     &    g1pbbpk)/                                                &
     &  (g1pnua*g1pnub)              
      
      RETURN
      END Function delabk
      

! #####################################################################
!
! #####################################################################
!--------------------------------------------------------------------------
      subroutine cld_cpu(string)

      implicit none
      character( LEN = * ) string
      
      return
      
      end subroutine cld_cpu

!
!--------------------------------------------------------------------------
!
!--------------------------------------------------------------------------
!
      subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
     &                    t0,t7,infdo,jslab,its,jts,  &
     &   timesed1,timesed2,timesed3,zmaxsed,timesetvt) ! used for timing
!
! Sedimentation driver -- column by column
!
!  Written by ERM 10/2011
!
!
!
      implicit none

      integer nx,ny,nz,nor,norz,ngt,jgs,na,ia
      integer id ! =1 use density, =0 no density
      integer :: its,jts ! SW point of local tile
      
      integer ng1
      parameter(ng1 = 1)

      real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na)
      real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
      real dz3d(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
      real dz3dinv(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
      real t0(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
      real t7(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)

!      real gz(-nor+ng1:nz+nor),z1d(-nor+ng1:nz+nor,4)
      real dtp
      real xfall(nx,ny,na)  ! array for stuff landing on the ground
      real xfall0(nx,ny)    ! dummy array
      integer infdo
      integer jslab ! which line of xfall to use
            
      integer ix,jy,kz,ndfall,n,k,il,in
      real tmp, vtmax, dtptmp, dtfrac
      real, parameter :: dz = 200.

      real :: xvt(nz+1,nx,3,lc:lhab) ! (nx,nz,2,lc:lhab) ! 1=mass-weighted, 2=number-weighted
      real :: tmpn(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz)
      real :: tmpn2(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz)
      real :: z(-nor+ng1:nx+nor,-norz+ng1:nz+norz,lr:lhab)
      real :: db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1)
      
      real :: rhovtzx(nz,nx)
      
      double precision :: timesed1,timesed2,timesed3, zmaxsed,timesetvt,dummy
      double precision :: dt1,dt2,dt3,dt4

      integer,parameter :: ngs = 128 
      integer :: ngscnt,mgs,ipconc0
      
      real ::  qx(ngs,lv:lhab) 
      real ::  qxw(ngs,ls:lhab) 
      real ::  cx(ngs,lc:lhab) 
      real ::  xv(ngs,lc:lhab) 
      real ::  vtxbar(ngs,lc:lhab,3) 
      real ::  xmas(ngs,lc:lhab) 
      real ::  xdn(ngs,lc:lhab) 
      real ::  xdia(ngs,lc:lhab,3) 
      real ::  vx(ngs,li:lhab) 
      real ::  alpha(ngs,lc:lhab) 
      real ::  zx(ngs,lr:lhab) 
      logical :: hasmass(nx,lc+1:lhab)

      integer igs(ngs),kgs(ngs)
      
      real rho0(ngs),temcg(ngs)

      real temg(ngs)
      
      real rhovt(ngs)
      
      real cwnc(ngs),cinc(ngs)
      real fadvisc(ngs),cwdia(ngs),cipmas(ngs)
      
      real cimasn,cimasx,cnina(ngs),cimas(ngs)
      
      real cnostmp(ngs)
      

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

      integer :: ixb, jyb, kzb
      integer :: ixe, jye, kze
      integer :: plo, phi

      logical :: debug_mpi = .TRUE.

! ###################################################################




      kzb = 1
      kze = nz

      ixb = 1
      ixe = nx


      jy = 1
      jgs = jy


!
!  zero the precip flux arrays (2d)
!

      xvt(:,:,:,:) = 0.0

      if ( ndebug .gt. 0 ) write(0,*) 'dbg = 3a'


      DO kz = kzb,kze
      DO ix = ixb,ixe
       db1(ix,kz) = dn(ix,jy,kz)
       db1inv(ix,kz) = 1./dn(ix,jy,kz)
       rhovtzx(kz,ix) = Sqrt(rho00*Min(1.0/0.05, db1inv(ix,kz))) ! prevent excessive rhovt
      ENDDO
      ENDDO

      DO kz = kzb,kze
      DO ix = ixb,ixe
       dtz1(kz,ix,0) = dz3dinv(ix,jy,kz)
       dtz1(kz,ix,1) = dz3dinv(ix,jy,kz)*db1inv(ix,kz) 
       dz2dinv(kz,ix) = dz3dinv(ix,jy,kz)
      ENDDO
      ENDDO

      IF ( lzh .gt. 1 ) THEN
      DO kz = kzb,kze
      DO ix = ixb,ixe
        an(ix,jy,kz,lzh) = Max( 0., an(ix,jy,kz,lzh) )
      ENDDO
      ENDDO
      ENDIF

      
      DO il = lc+1,lhab
       DO ix = ixb,ixe
!        hasmass(ix,il) = Any( an(ix,jy,:,il) > qxmin(il) )
       ENDDO
      ENDDO




      if (ndebug .gt. 0 ) write(0,*) 'dbg = 3a2'

! loop over columns
      DO ix = ixb,ixe
      
      dummy = 0.d0

      
      call ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ix, & 
     &  xvt, rhovtzx, & 
     &  an,dn,ipconc,t0,t7,cwmasn,cwmasx, & 
     &  cwradn, & 
     &  qxmin,xdnmx,xdnmn,cdx,cno,xdn0,xvmn,xvmx, & 
     &  ngs,qx,qxw,cx,xv,vtxbar,xmas,xdn,xdia,vx,alpha,zx,igs,kgs, &
     &  rho0,temcg,temg,rhovt,cwnc,cinc,fadvisc,cwdia,cipmas,cnina,cimas, &
     &  cnostmp,              &
     &  infdo,0               &
     & )


! loop over each species and do sedimentation for all moments
     DO il = lc,lhab
       IF ( ido(il) == 0 ) CYCLE

!       IF ( .not. hasmass(ix,il) ) CYCLE

!      plo = nz
!      phi = 0


      vtmax = 0.0
      
      do kz = kzb,kze

      ! apply limit vtmaxsed (08/20/2015)
      xvt(kz,ix,1,il) = Min( vtmaxsed,  xvt(kz,ix,1,il) )
      xvt(kz,ix,2,il) = Min( vtmaxsed,  xvt(kz,ix,2,il) )
      xvt(kz,ix,3,il) = Min( vtmaxsed,  xvt(kz,ix,3,il) )
      
      vtmax = Max(vtmax,xvt(kz,ix,1,il)*dz2dinv(kz,ix))
      vtmax = Max(vtmax,xvt(kz,ix,2,il)*dz2dinv(kz,ix))
      vtmax = Max(vtmax,xvt(kz,ix,3,il)*dz2dinv(kz,ix))

!      IF ( dtp*xvt(kz,ix,1,il)*dz2dinv(kz,ix) >= 0.7 .or. &
!     &     dtp*xvt(kz,ix,2,il)*dz2dinv(kz,ix) >= 0.7 .or. &
!     &     dtp*xvt(kz,ix,3,il)*dz2dinv(kz,ix) >= 0.7 ) THEN
!          
!          zmaxsed = Max(zmaxsed, float(kz) )
!!          plo = Min(plo,kz)
!!          phi = Max(phi,kz)
!           
!      ENDIF
      
      ENDDO
      
      IF ( vtmax == 0.0 ) CYCLE


      
      IF ( dtp*vtmax .lt. 0.7 ) THEN ! check whether multiple steps are needed.
        ndfall = 1
      ELSE
       IF ( dtp > 20.0 ) THEN ! more stringent subdivision for large time steps
         ndfall = Max(2, Int(dtp*vtmax/0.7) + 1)
       ELSE ! more relaxed for small time steps, but might still be a problem for very thin vertical layers near the ground
         ndfall = 1+Int(dtp*vtmax + 0.301)
       ENDIF
      ENDIF
      
      IF ( ndfall .gt. 1 ) THEN
        dtptmp = dtp/Real(ndfall)
!        write(0,*) 'subdivide fallout on its,jts,ix,plo,phi = ',its,jts,ix,plo,phi
!        write(0,*) 'for il,jsblab,c,ndfall = ',il,jslab,dtp*vtmax,ndfall
      ELSE
        dtptmp = dtp
      ENDIF
      
      dtfrac = dtptmp/dtp


      DO n = 1,ndfall

      IF ( do_accurate_sedimentation .and. n .ge. 2 .and. ( n == n*(n/interval_sedi_vt) ) ) THEN
!
!  zero the precip flux arrays (2d)
!
      
!      xvt(:,:,:,il) = 0.0
      dummy = 0.d0
      call ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ix, & 
     &  xvt, rhovtzx, & 
     &  an,dn,ipconc,t0,t7,cwmasn,cwmasx, & 
     &  cwradn, & 
     &  qxmin,xdnmx,xdnmn,cdx,cno,xdn0,xvmn,xvmx, & 
     &  ngs,qx,qxw,cx,xv,vtxbar,xmas,xdn,xdia,vx,alpha,zx,igs,kgs, &
     &  rho0,temcg,temg,rhovt,cwnc,cinc,fadvisc,cwdia,cipmas,cnina,cimas, &
     &  cnostmp,             &
     &  infdo,il)


      DO kz = kzb,kze
      ! apply limit vtmaxsed (08/20/2015)
        xvt(kz,ix,1,il) = Min( vtmaxsed,  xvt(kz,ix,1,il) )
        xvt(kz,ix,2,il) = Min( vtmaxsed,  xvt(kz,ix,2,il) )
        xvt(kz,ix,3,il) = Min( vtmaxsed,  xvt(kz,ix,3,il) )
      ENDDO




      ENDIF ! (n .ge. 2)


        IF ( il >= lr .and. ( infall .eq. 3 .or. infall .eq. 4 ) .and. ln(il) > 0 ) THEN
           IF ( (il .eq. lr .and. irfall .eq. infall .and. lzr < 1) .or. (il .ge. lh .and. lz(il) .lt. 1 ) ) THEN
            call calczgr1d(nx,ny,nz,nor,na,an,ixe,kze, & 
     &         z,db1,jgs,ipconc, dnu(il), il, ln(il), qxmin(il), xvmn(il), xvmx(il), lvol(il), xdn0(il), ix )
           ENDIF
        ENDIF

      if (ndebug .gt. 0 ) write(0,*) 'dbg = 1b'

! mixing ratio

      call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,1,il), & 
     &             an,db1,il,1,xfall,dtz1,ix)


      if (ndebug .gt. 0 ) write(0,*) 'dbg = 3c'

! volume

      IF ( ldovol .and. il >= li ) THEN
        IF ( lvol(il) .gt. 1 ) THEN
         call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,1,il), & 
     &              an,db1,lvol(il),0,xfall,dtz1,ix)
        ENDIF
      ENDIF


      if (ndebug .gt. 0 ) write(0,*) 'dbg = 3d'

      
      IF ( ipconc .gt. 0 ) THEN !{
        IF ( ipconc .ge. ipc(il) ) THEN

      IF ( ( infall .ge. 2 .or. (infall .eq. 0 .and. il .lt. lh) ) .and. lz(il) .lt. 1) THEN !{
!
! load number conc. into tmpn to do fallout by mass-weighted mean fall speed
!  to put a lower bound on number conc.
!

        IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. ( il .eq. lh .or. il .eq. lhl .or.  & 
     &      ( il .eq. lr .and. irfall .eq. infall) ) ) THEN

          DO kz = kzb,kze
!            DO ix = ixb,ixe
              tmpn2(ix,jy,kz) = z(ix,kz,il)
!            ENDDO
          ENDDO
          DO kz = kzb,kze
!            DO ix = ixb,ixe
              tmpn(ix,jy,kz) = an(ix,jy,kz,ln(il))
!            ENDDO
          ENDDO
        
        ELSE
          
          DO kz = kzb,kze
!            DO ix = ixb,ixe
              tmpn(ix,jy,kz) = an(ix,jy,kz,ln(il))
!            ENDDO
          ENDDO

        ENDIF

      ENDIF !}


      if (ndebug .gt. 0 ) write(0,*) 'dbg = 3f'

       in = 2
       IF ( infall .eq. 1 ) in = 1

         call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,in,il), & 
     &        an,db1,ln(il),0,xfall,dtz1,ix)


         IF ( lz(il) .lt. 1 ) THEN ! if not 3-moment, run one of the correction schemes
         IF ( (infall .ge. 2 .or. infall .eq. 3) .and. .not. (infall .eq. 0 .and. il .ge. lh) & 
     &       .and. ( il .eq. lr .or. (il .ge. li .and. il .le. lhab) )) THEN
!     :        .or. il .eq. lhl )) THEN
           
           xfall0(:,jgs) = 0.0

           IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and.  & 
     &        ( il .ge. lh .or. (il .eq. lr .and. irfall .eq. infall) ) ) THEN
             call fallout1d(nx,ny,nz,nor,1,dtptmp,dtfrac,jgs,xvt(1,1,3,il), & 
     &         tmpn2,db1,1,0,xfall0,dtz1,ix)
             call fallout1d(nx,ny,nz,nor,1,dtptmp,dtfrac,jgs,xvt(1,1,1,il), & 
     &         tmpn,db1,1,0,xfall0,dtz1,ix)
           ELSE
             call fallout1d(nx,ny,nz,nor,1,dtptmp,dtfrac,jgs,xvt(1,1,1,il), & 
     &         tmpn,db1,1,0,xfall0,dtz1,ix)
           ENDIF

           IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. ( (il .eq. lr .and. irfall .eq. infall) & 
     &            .or. il .ge. lh ) ) THEN
! "Method I" - dbz correction

             call calcnfromz1d(nx,ny,nz,nor,na,an,tmpn2,ixe,kze, & 
     &       z,db1,jgs,ipconc, dnu(il), il, ln(il), qxmin(il), xvmn(il), xvmx(il),tmpn,  & 
     &       lvol(il), rho_qh, infall, ix)

           ELSEIF ( infall .eq. 5 .and. il .ge. lh .or. ( il == lr .and. irfall == 5 ) ) THEN

             DO kz = kzb,kze
!              DO ix = ixb,ixe
               an(ix,jgs,kz,ln(il)) = Max( an(ix,jgs,kz,ln(il)), 0.5* ( an(ix,jgs,kz,ln(il)) + tmpn(ix,jy,kz) ))
              
!              ENDDO
             ENDDO           

           ELSEIF ( .not. (il .eq. lr .and. irfall .eq. 0) ) THEN
! "Method II" M-wgt N-fallout correction

             DO kz = kzb,kze
!              DO ix = ixb,ixe

               an(ix,jgs,kz,ln(il)) = Max( an(ix,jgs,kz,ln(il)), tmpn(ix,jy,kz) )
              
!              ENDDO
             ENDDO
           ENDIF 
           ENDIF ! lz(il) .lt. 1
           

         ENDIF
        ENDIF


      ENDIF !}


      ENDDO ! n=1,ndfall
      ENDDO ! il
      
      ENDDO ! ix



      
      RETURN
      END SUBROUTINE SEDIMENT1D


! #####################################################################

!
! #####################################################################


!
!--------------------------------------------------------------------------
!
!--------------------------------------------------------------------------
!
      subroutine fallout1d(nx,ny,nz,nor,na,dtp,dtfrac,jgs,vt,   &
     &  a,db1,ia,id,xfall,dtz1,ixcol)
!
! First-order, upwind fallout scheme
!
!  Written by ERM 6/10/2011
!
!
!
      implicit none

      integer nx,ny,nz,nor,ngt,jgs,na,ia
      integer id ! =1 use density, =0 no density
      integer ng1
      parameter(ng1 = 1)
      integer :: ixcol

!      real dz3dinv(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor)
!      real a(nx,ny,nz,na)
      real a(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,na) ! quantity to be 'advected'
      real vt(nz+1,nx)  ! terminal speed for a
      real dtp,dtfrac
      real cmax
      real xfall(nx,ny,na)  ! array for stuff landing on the ground
      real db1(nx,nz+1),dtz1(nz+1,nx,0:1)

! Local
           
      integer ix,jy,kz,n,k
      integer iv1,iv2
      real tmp
      integer imn,imx,kmn,kmx
      real qtmp1(nz+1)

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

      integer :: ixb, jyb, kzb
      integer :: ixe, jye, kze

      logical :: debug_mpi = .TRUE.

! ###################################################################

      jy = 1

      iv1 = 0
      iv2 = 0

      imn = nx
      imx = 1
      kmn = nz
      kmx = 1

      cmax = 0.0

      kzb = 1
      kze = nz

      ixb = ixcol
      ixe = ixcol
      ix  = ixcol

      qtmp1(nz+1) = 0.0
      
      DO kz = kzb,kze
!        DO ix = ixb,ixe
!         cmax = Max(cmax, vt(ix,kz)*dz3dinv(ix,jy,kz)) 
         
         IF ( id == 1 ) THEN
         qtmp1(kz) = a(ix,jgs,kz,ia)*vt(kz,ix)*db1(ix,kz)
         ELSE
         qtmp1(kz) = a(ix,jgs,kz,ia)*vt(kz,ix)
         ENDIF
         
         IF ( a(ix,jgs,kz,ia) .ne. 0.0 ) THEN
!           imn = Min(ix,imn)
!           imx = Max(ix,imx)
           kmn = Min(kz,kmn)
           kmx = Max(kz,kmx)
         ENDIF
!        ENDDO
      ENDDO
      
      kmn = Max(1,kmn-1)
      
! first check if fallout is worth doing
!      IF ( cmax .eq. 0.0 .or. imn .gt. imx ) THEN
!        RETURN
!      ENDIF
      
      IF ( kmn == 1 ) THEN
      
      kz = 1
!      do ix = imn,imx ! 1,nx-1
         xfall(ix,jy,ia) = xfall(ix,jy,ia) + a(ix,jgs,kz,ia)*vt(kz,ix)*dtfrac
!      enddo
      
      ENDIF

      do kz = 1,nz
!      do ix = 1,nx
        a(ix,jgs,kz,ia) =  a(ix,jgs,kz,ia) + dtp*dtz1(kz,ix,id)*(qtmp1(kz+1) - qtmp1(kz) )
!      enddo
      enddo

      
      RETURN
      END SUBROUTINE FALLOUT1D

! ##############################################################################
! ##############################################################################

      subroutine calczgr1d(nx,ny,nz,nor,na,a,ixe,kze,              &
     &    z,db,jgs,ipconc, alpha, l,ln, qmin, xvmn,xvmx, lvol, rho_qx, ixcol)


      implicit none

      integer nx,ny,nz,nor,na,ngt,jgs
      integer :: ixcol
      integer, parameter :: norz = 3
      real a(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor,na)
      real z(-nor+1:nx+nor,-nor+1:nz+nor,lr:lhab)   ! reflectivity
      real db(nx,nz+1)  ! air density
!      real gt(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor,ngt)

      integer ixe,kze
      real    alpha
      real    qmin
      real    xvmn,xvmx
      integer ipconc
      integer l   ! index for q
      integer ln  ! index for N
      integer lvol ! index for volume
      real    rho_qx


      integer ix,jy,kz
      real vr,qr,nrx,rd,xv,g1,zx,chw,xdn
      
      
      jy = jgs
      ix = ixcol
      
      IF ( l .eq. lh .or. l .eq. lhl .or. ( l .eq. lr .and. imurain == 1 )  ) THEN
      
      
      DO kz = 1,kze
          
          
          
          IF (  a(ix,jy,kz,l) .gt. qmin .and. a(ix,jy,kz,ln) .gt. 1.e-15 ) THEN
            
            IF ( lvol .gt. 1 ) THEN
                IF ( a(ix,jy,kz,lvol) .gt. 0.0 ) THEN
                  xdn = db(ix,kz)*a(ix,jy,kz,l)/a(ix,jy,kz,lvol)
                  xdn = Min( 900., Max( hdnmn, xdn ) )
                ELSE
                  xdn = rho_qx
                ENDIF
            ELSE
                xdn = rho_qx
            ENDIF

            IF ( l == lr ) xdn = 1000.

            qr = a(ix,jy,kz,l)
            xv = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln))
            chw = a(ix,jy,kz,ln)

             IF ( xv .lt. xvmn .or. xv .gt. xvmx ) THEN
              xv = Min( xvmx, Max( xvmn,xv ) )
              chw = db(ix,kz)*a(ix,jy,kz,l)/(xv*xdn)
             ENDIF

             g1 = (6.0 + alpha)*(5.0 + alpha)*(4.0 + alpha)/  &
     &            ((3.0 + alpha)*(2.0 + alpha)*(1.0 + alpha))
             zx = g1*db(ix,kz)**2*(a(ix,jy,kz,l))*a(ix,jy,kz,l)/chw
!             z(ix,kz,l)  = 1.e18*zx*(6./(pi*1000.))**2
             z(ix,kz,l)  = zx*(6./(pi*1000.))**2


!          IF ( ny.eq.2 .and. kz .ge. 25 .and. kz .le. 29 .and. z(ix,kz,l) .gt. 0. ) THEN
!             write(*,*) 'calczgr: z,dbz,xdn = ',ix,kz,z(ix,kz,l),10*log10(z(ix,kz,l)),xdn
!          ENDIF
          
          ELSE
           
            z(ix,kz,l) = 0.0
           
          ENDIF
          
      ENDDO
      
      ELSEIF ( l .eq. lr .and. imurain == 3) THEN

      xdn = 1000.
      
      DO kz = 1,kze
          IF (  a(ix,jy,kz,l) .gt. qmin .and. a(ix,jy,kz,ln) .gt. 1.e-15 ) THEN

            vr = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln))
!            z(ix,kz,l) = 3.6e18*(rnu+2.0)*a(ix,jy,kz,ln)*vr**2/(rnu+1.0)
            z(ix,kz,l) = 3.6*(rnu+2.0)*a(ix,jy,kz,ln)*vr**2/(rnu+1.0)
!            qr = a(ix,jy,kz,lr)
!            nrx = a(ix,jy,kz,lnr)
          
          ELSE
           
            z(ix,kz,l) = 0.0
           
          ENDIF
      
          
      ENDDO
      
      ENDIF
      
      RETURN
      
      END subroutine calczgr1d

! ##############################################################################
! ##############################################################################
!
!  Subroutine to correct number concentration to prevent reflectivity growth by 
!  sedimentation in 2-moment ZXX scheme.
!  Calculation is in a slab (constant jgs)
!

      subroutine calcnfromz1d(nx,ny,nz,nor,na,a,t0,ixe,kze,    &
     &    z0,db,jgs,ipconc, alpha, l,ln, qmin, xvmn,xvmx,t1, &
     &    lvol, rho_qx, infall, ixcol)

      
      implicit none

      integer nx,ny,nz,nor,na,ngt,jgs,ixcol

      real a(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor,na)  ! sedimented N and q
      real t0(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor)    ! sedimented reflectivity
      real t1(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor)    ! sedimented N (by Vm)
!      real gt(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor,ngt)
      real z0(-nor+1:nx+nor,-nor+1:nz+nor,lr:lhab)   ! initial reflectivity

      real db(nx,nz+1)  ! air density
      
      integer ixe,kze
      real    alpha
      real    qmin
      real    xvmn,xvmx
      integer ipconc
      integer l   ! index for q
      integer ln  ! index for N
      integer lvol ! index for volume
      real    rho_qx
      integer infall
      
      
      integer ix,jy,kz
      double precision vr,qr,nrx,rd,g1,zx,chw,z,znew,zt,zxt
      real xv,xdn
      integer :: ndbz, nmwgt, nnwgt, nwlessthanz
      
      ndbz = 0
      nmwgt = 0
      nnwgt = 0
      nwlessthanz = 0
      

      
      jy = jgs
      ix = ixcol
      
      IF ( l .eq. lh .or. l .eq. lhl .or. ( l == lr .and. imurain == 1 ) ) THEN
      
             g1 = (6.0 + alpha)*(5.0 + alpha)*(4.0 + alpha)/  &
     &            ((3.0 + alpha)*(2.0 + alpha)*(1.0 + alpha))
      
      DO kz = 1,kze

         
          IF (   t0(ix,jy,kz) .gt. 0. ) THEN ! {
            
            IF ( lvol .gt. 1 ) THEN
               IF ( a(ix,jy,kz,lvol) .gt. 0.0 ) THEN
                 xdn = db(ix,kz)*a(ix,jy,kz,l)/a(ix,jy,kz,lvol)
                 xdn = Min( 900., Max( hdnmn, xdn ) )
               ELSE 
                 xdn = rho_qx
               ENDIF
            ELSE
               xdn = rho_qx
            ENDIF
            
            IF ( l == lr ) xdn = 1000.
          
            qr = a(ix,jy,kz,l)
            xv = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln))
            chw = a(ix,jy,kz,ln)

             IF ( xv .lt. xvmn .or. xv .gt. xvmx ) THEN
              xv = Min( xvmx, Max( xvmn,xv ) )
              chw = db(ix,kz)*a(ix,jy,kz,l)/(xv*xdn)
             ENDIF

             zx = g1*db(ix,kz)**2*( a(ix,jy,kz,l))*a(ix,jy,kz,l)/chw
             z  = zx*(6./(pi*1000.))**2

            
           IF ( (z .gt. t0(ix,jy,kz) .and. z .gt. 0.0 .and.  &
     &           t0(ix,jy,kz) .gt. z0(ix,kz,l) )) THEN !{
           
            zx = t0(ix,jy,kz)/((6./(pi*1000.))**2)
            
            nrx =  g1*db(ix,kz)**2*( a(ix,jy,kz,l))*a(ix,jy,kz,l)/zx
            IF ( infall .eq. 3 ) THEN
              IF ( nrx .gt. a(ix,jy,kz,ln) ) THEN
                ndbz = ndbz + 1
                IF ( t1(ix,jy,kz) .lt. ndbz ) nwlessthanz = nwlessthanz + 1
              ELSE
                nnwgt = nnwgt + 1
              ENDIF
              a(ix,jy,kz,ln) = Max( real(nrx), a(ix,jy,kz,ln) )
            ELSE
             IF (  nrx .gt. a(ix,jy,kz,ln) .and. t1(ix,jy,kz) .gt. a(ix,jy,kz,ln) ) THEN
              IF ( nrx .lt. t1(ix,jy,kz)  ) THEN
                ndbz = ndbz + 1
              ELSE
                nmwgt = nmwgt + 1
                IF ( t1(ix,jy,kz) .lt. ndbz ) nwlessthanz = nwlessthanz + 1
              ENDIF
             ELSE
              nnwgt = nnwgt + 1
             ENDIF
              
              a(ix,jy,kz,ln) = Max(Min( real(nrx), t1(ix,jy,kz) ), a(ix,jy,kz,ln) )
            ENDIF

           ELSE ! } {
             IF ( t1(ix,jy,kz) .gt. 0 .and. a(ix,jy,kz,ln) .gt. 0 ) THEN
              IF ( t1(ix,jy,kz) .gt. a(ix,jy,kz,ln) ) THEN
                nmwgt = nmwgt + 1
              ELSE
                nnwgt = nnwgt + 1
              ENDIF
            ENDIF
            a(ix,jy,kz,ln) = Max(t1(ix,jy,kz), a(ix,jy,kz,ln) )
            nrx = a(ix,jy,kz,ln)



           ENDIF ! }

           ! }
          ELSE ! {
            IF ( t1(ix,jy,kz) .gt. 0 .and. a(ix,jy,kz,ln) .gt. 0 ) THEN
              IF ( t1(ix,jy,kz) .gt. a(ix,jy,kz,ln) ) THEN
                nmwgt = nmwgt + 1
              ELSE
                nnwgt = nnwgt + 1
              ENDIF
            ENDIF
          ENDIF! }
          
      ENDDO
      
      
      ELSEIF ( l .eq. lr .and. imurain == 3) THEN

      xdn = 1000.
      
      DO kz = 1,kze
          IF (  t0(ix,jy,kz) .gt. 0. ) THEN

            vr = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln))
            z = 3.6*(rnu+2.0)*a(ix,jy,kz,ln)*vr**2/(rnu+1.0)
          
             IF ( z .gt. t0(ix,jy,kz) .and. z .gt. 0.0 .and.  &
     &          t0(ix,jy,kz) .gt. 0.0                         &
     &          .and. t0(ix,jy,kz) .gt. z0(ix,kz,l) ) THEN

            vr = db(ix,kz)*a(ix,jy,kz,l)/(xdn)
             chw =  a(ix,jy,kz,ln)
            nrx =   3.6*(rnu+2.0)*vr**2/((rnu+1.0)*t0(ix,jy,kz))
             IF ( infall .eq. 3 ) THEN
              a(ix,jy,kz,ln) = Max( real(nrx), a(ix,jy,kz,ln) )
            ELSEIF ( infall .eq. 4 ) THEN
              a(ix,jy,kz,ln) = Max( Min( real(nrx), t1(ix,jy,kz)), a(ix,jy,kz,ln) )
            ENDIF

           ELSE

            a(ix,jy,kz,ln) = Max(t1(ix,jy,kz), a(ix,jy,kz,ln) )

           ENDIF

          ELSE

            a(ix,jy,kz,ln) = Max(t1(ix,jy,kz), a(ix,jy,kz,ln) )

          ENDIF


      ENDDO

      ENDIF

      RETURN

      END subroutine calcnfromz1d


! ##############################################################################
! ##############################################################################
!
!  Subroutine to calculate number concentrations from initial state that has only mixing ratio.
!  N will be in #/kg, NOT #/m^3, since sedimentation is done next.
!

!
! 10.27.2015: Added hail calculation
!
      subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn)

      
      implicit none

      integer nx,ny,nz,nor,norz,na,ngt,jgs,ixcol

      real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na)  ! scalars (q, N, Z)

      real dn(nx,nz+1)  ! air density
      
      integer ixe,kze
      real    alpha
      real    qmin
      real    xvmn,xvmx
      integer ipconc
      integer lvol ! index for volume
      integer infall
      
      
      integer ix,jy,kz
      double precision vr,q,nrx,nrx2,rd,g1h,g1hl,g1r,g1s,zx,chw,z,znew,zt,zxt,n1,laminv1
      double precision :: zr, zs, zh, dninv
      real, parameter :: xn0s = 3.0e6, xn0r = 8.0e6, xn0h = 2.0e5, xn0hl = 4.0e4
      real, parameter :: xdnr = 1000., xdns = 100. ,xdnh = 700.0, xdnhl = 900.0
      real, parameter :: zhlfac = 1./(pi*xdnhl*xn0hl)
      real, parameter :: zhfac = 1./(pi*xdnh*xn0h)
      real, parameter :: zrfac = 1./(pi*xdnr*xn0r)
      real, parameter :: zsfac = 1./(pi*xdns*xn0s)
      real, parameter :: g0 = (6.0)*(5.0)*(4.0)/((3.0)*(2.0)*(1.0))
      real, parameter :: xims=900.*0.523599*(2.*50.e-6)**3    ! mks   (100 micron diam solid sphere approx)
      real, parameter :: xgms=xdnh*0.523599*(300.e-6)**3    ! mks   (300 micron diam  sphere approx)
      real, parameter :: cwmas09 = 1000.*0.523599*(2.*9.e-6)**3 ! mass of 9-micron radius droplet

      real xv,xdn
      integer :: ndbz, nmwgt, nnwgt, nwlessthanz

! ------------------------------------------------------------------
      
      
      jy = 1
      
      
         g1h = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/  &
     &        ((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah))

         g1hl = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/  &
     &        ((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl))
     
         IF ( imurain == 3 ) THEN
         g1r = (rnu+2.0)/(rnu+1.0)
         ELSE ! imurain == 1
         g1r = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/  &
     &        ((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar))
         ENDIF

         g1s = (snu+2.0)/(snu+1.0)
      
      DO kz = 1,nz
       DO ix = 1,nx ! ixcol

         dninv = 1./dn(ix,kz)
         
   !  Cloud droplets
         
         IF ( lnc > 1 ) THEN
           IF ( an(ix,jy,kz,lnc) <= cxmin .and. an(ix,jy,kz,lc) > qxmin_init(lc) ) THEN
             
             an(ix,jy,kz,lnc) = Min(qccn, an(ix,jy,kz,lc)/cwmas09 )*dn(ix,kz)
             
             IF ( lccn > 1 .and. lccna < 1 ) THEN
                an(ix,jy,kz,lccn) = an(ix,jy,kz,lccn) - an(ix,jy,kz,lnc)
             ENDIF
             IF ( lccna > 1 ) THEN
                an(ix,jy,kz,lccna) = an(ix,jy,kz,lccna) + an(ix,jy,kz,lnc)
             ENDIF

           ELSEIF ( an(ix,jy,kz,lc) <= qxmin(lc) .or.  &
                    ( an(ix,jy,kz,lnc) <= cxmin .and. an(ix,jy,kz,lc) <= qxmin_init(lc)) ) THEN
             
             an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lc)
             an(ix,jy,kz,lnc) = 0.0
             an(ix,jy,kz,lc) = 0.0
           
           ENDIF
         ENDIF

   !  Cloud ice
         
         IF ( lni > 1 ) THEN
           IF ( an(ix,jy,kz,lni) <= cxmin .and. an(ix,jy,kz,li) > qxmin_init(li) ) THEN
             an(ix,jy,kz,lni) = dn(ix,kz)*an(ix,jy,kz,li)/xims
           
           ELSEIF ( an(ix,jy,kz,li) <= qxmin(li) .or. &
                    ( an(ix,jy,kz,lni) <= cxmin .and. an(ix,jy,kz,li) <= qxmin_init(li)) ) THEN
             an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,li)
             an(ix,jy,kz,lni) = 0.0
             an(ix,jy,kz,li) = 0.0
           ENDIF
         ENDIF

   !  rain
         
         IF ( lnr > 1 ) THEN
           IF ( an(ix,jy,kz,lnr) <= 0.1*cxmin .and. an(ix,jy,kz,lr) > qxmin_init(lr) ) THEN

             q = an(ix,jy,kz,lr)
             
             laminv1 = (dn(ix,kz) * q * zrfac)**(0.25)  ! inverse of slope
             
             n1 = laminv1*xn0r  ! number concentration for inv. exponential single moment input
             
             nrx =  n1*g1r/g0   ! number concentration for different shape parameter

             an(ix,jy,kz,lnr) = nrx ! *dninv ! convert to number mixing ratio
             
           ELSEIF ( an(ix,jy,kz,lr) <= qxmin(lr) .or. &
                    ( an(ix,jy,kz,lnr) <= cxmin .and. an(ix,jy,kz,lr) <= qxmin_init(lr)) ) THEN
             an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lr)
             an(ix,jy,kz,lnr) = 0.0
             an(ix,jy,kz,lr) = 0.0
           ENDIF
         ENDIF

  ! snow
         IF ( lns > 1 ) THEN
           IF ( an(ix,jy,kz,lns) <= 0.1*cxmin .and. an(ix,jy,kz,ls) > qxmin_init(ls) ) THEN

             q = an(ix,jy,kz,ls)
             
             laminv1 = (dn(ix,kz) * q * zsfac)**(0.25)  ! inverse of slope
             
             n1 = laminv1*xn0s  ! number concentration for inv. exponential single moment input
             
             nrx =  n1*g1s/g0   ! number concentration for different shape parameter

             an(ix,jy,kz,lns) = nrx ! *dninv ! convert to number mixing ratio

           ELSEIF ( an(ix,jy,kz,ls) <= qxmin(ls) .or. &
                    ( an(ix,jy,kz,lns) <= cxmin .and. an(ix,jy,kz,ls) <= qxmin_init(ls)) ) THEN
             an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,ls)
             an(ix,jy,kz,lns) = 0.0
             an(ix,jy,kz,ls) = 0.0
             
           ENDIF
         ENDIF
         
    ! graupel

         IF ( lnh > 1 ) THEN
           IF ( an(ix,jy,kz,lnh) <= 0.1*cxmin .and. an(ix,jy,kz,lh) > qxmin_init(lh) ) THEN
             IF ( lvh > 1 ) THEN
               IF ( an(ix,jy,kz,lvh) <= 0.0 ) THEN
                 an(ix,jy,kz,lvh) = an(ix,jy,kz,lh)/xdnh
               ENDIF
             ENDIF

             q = an(ix,jy,kz,lh)
             
             laminv1 = (dn(ix,kz) * q * zhfac)**(0.25)  ! inverse of slope
             
             n1 = laminv1*xn0h  ! number concentration for inv. exponential single moment input
             
             nrx =  n1*g1h/g0   ! number concentration for different shape parameter

             nrx2 = dn(ix,kz) * q / xgms
             
             nrx = Min( nrx, nrx2 )

             IF ( nrx > cxmin ) THEN
               an(ix,jy,kz,lnh) = nrx ! *dninv ! convert to number mixing ratio
             ELSE
               an(ix,jy,kz,lh) = 0.0
               an(ix,jy,kz,lnh) = 0.0
               an(ix,jy,kz,lvh) = 0.0
             ENDIF

           ELSEIF ( an(ix,jy,kz,lh) <= qxmin(lh) .or. &
                    ( an(ix,jy,kz,lnh) <= cxmin .and. an(ix,jy,kz,lh) <= qxmin_init(lh)) ) THEN
           
              an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lh)
              an(ix,jy,kz,lh) = 0.0
           
           ENDIF
         ENDIF

    ! hail

         IF ( lnhl > 1 .and. lhl > 1 ) THEN
           IF ( an(ix,jy,kz,lnhl) <= 0.1*cxmin .and. an(ix,jy,kz,lhl) > qxmin_init(lhl) ) THEN
             IF ( lvhl > 1 ) THEN
               IF ( an(ix,jy,kz,lvhl) <= 0.0 ) THEN
                 an(ix,jy,kz,lvhl) = an(ix,jy,kz,lhl)/xdnhl
               ENDIF
             ENDIF

             q = an(ix,jy,kz,lhl)
             
             laminv1 = (dn(ix,kz) * q * zhlfac)**(0.25)  ! inverse of slope
             
             n1 = laminv1*xn0hl  ! number concentration for inv. exponential single moment input
             
             nrx =  n1*g1hl/g0   ! number concentration for different shape parameter

             an(ix,jy,kz,lnhl) = nrx ! *dninv ! convert to number mixing ratio


           ELSEIF ( an(ix,jy,kz,lhl) <= qxmin(lhl) .or.  &
                   ( an(ix,jy,kz,lnhl) <= cxmin .and. an(ix,jy,kz,lhl) <= qxmin_init(lhl)) ) THEN
           
              an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lhl)
              an(ix,jy,kz,lhl) = 0.0
           
           ENDIF
         ENDIF
 
      ENDDO ! ix
      ENDDO ! kz
      
      RETURN
      
      END subroutine calcnfromq

! ##############################################################################
! ##############################################################################
!
!  Subroutine to calculate number concentrations from convection parameterization rates that have only mixing ratio.
!  N will be in #/kg, NOT #/m^3, since sedimentation is done next.
!

!
! 10.27.2015: Added hail calculation
!
      subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn)

      
      implicit none

      integer nx,ny,nz,nor,norz,na,ngt,jgs,ixcol

      real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na)  ! scalars (q, N, Z) from CUTEN arrays
      real anold(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na)  ! scalars (q, N, Z)

      real dn(nx,nz+1)  ! air density
      
      integer ixe,kze
      real    alpha
      real    qmin
      real    xvmn,xvmx
      integer ipconc
      integer lvol ! index for volume
      integer infall
      
      
      integer ix,jy,kz
      double precision vr,q,nrx,rd,g1h,g1hl,g1r,g1s,zx,chw,z,znew,zt,zxt,n1,laminv1
      double precision :: zr, zs, zh, dninv
      real, parameter :: xn0s = 3.0e6, xn0r = 8.0e6, xn0h = 4.0e4, xn0hl = 4.0e4
      real, parameter :: xdnr = 1000., xdns = 100. ,xdnh = 700.0, xdnhl = 900.0
      real, parameter :: zhlfac = 1./(pi*xdnhl*xn0hl)
      real, parameter :: zhfac = 1./(pi*xdnh*xn0h)
      real, parameter :: zrfac = 1./(pi*xdnr*xn0r)
      real, parameter :: zsfac = 1./(pi*xdns*xn0s)
      real, parameter :: g0 = (6.0)*(5.0)*(4.0)/((3.0)*(2.0)*(1.0))
      real, parameter :: xims=900.*0.523599*(2.*50.e-6)**3    ! mks   (100 micron diam solid sphere approx)
      real, parameter :: xcms=1000.*0.523599*(2.*7.5e-6)**3    ! mks   (100 micron diam solid sphere approx)

      real :: xmass,xv,xdn
      integer :: ndbz, nmwgt, nnwgt, nwlessthanz

! ------------------------------------------------------------------
      
      
      jy = 1
      
      
         g1h = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/  &
     &        ((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah))

         g1hl = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/  &
     &        ((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl))
     
         IF ( imurain == 3 ) THEN
         g1r = (rnu+2.0)/(rnu+1.0)
         ELSE ! imurain == 1
         g1r = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/  &
     &        ((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar))
         ENDIF

         g1s = (snu+2.0)/(snu+1.0)
      
      DO kz = 1,nz
       DO ix = 1,nx ! ixcol

         dninv = 1./dn(ix,kz)
         
   !  Cloud droplets
         
         IF ( lnc > 1 ) THEN
!           IF ( an(ix,jy,kz,lnc) <= 0.1*cxmin .and. an(ix,jy,kz,lc) > qxmin(lc) ) THEN
           IF ( an(ix,jy,kz,lnc) > qxmin(lc) ) THEN
             anold(ix,jy,kz,lnc) = anold(ix,jy,kz,lnc) + an(ix,jy,kz,lc)/xcms
           ENDIF
         ENDIF

   !  Cloud ice
         
         IF ( lni > 1 ) THEN
           IF ( an(ix,jy,kz,lni) > qxmin(li) ) THEN
             anold(ix,jy,kz,lni) = anold(ix,jy,kz,lni) + an(ix,jy,kz,li)/xims
           ENDIF
         ENDIF

   !  rain
         
         IF ( lnr > 1 ) THEN
           IF ( an(ix,jy,kz,lr) > qxmin(lr) ) THEN ! adding rain mass from CU scheme

            IF ( .true. .or. (anold(ix,jy,kz,lr) - an(ix,jy,kz,lr)) < qxmin(lr) .or. anold(ix,jy,kz,lnr) < cxmin ) THEN 

             q = an(ix,jy,kz,lr)
             
             laminv1 = (dn(ix,kz) * q * zrfac)**(0.25)  ! inverse of slope
             
             n1 = laminv1*xn0r  ! number concentration for inv. exponential single moment input
             
             nrx =  n1*g1r/g0   ! number concentration for different shape parameter

             anold(ix,jy,kz,lnr) = anold(ix,jy,kz,lnr) + nrx ! *dninv ! convert to number mixing ratio

            ELSE
             ! assume mean particle mass of pre-existing snow
                xmass = anold(ix,jy,kz,lr)/anold(ix,jy,kz,lnr)
                anold(ix,jy,kz,lnr) = anold(ix,jy,kz,lnr) + an(ix,jy,kz,lr)/xmass
            ENDIF
             
           ENDIF
         ENDIF

  ! snow
         IF ( lns > 1 ) THEN
           IF ( an(ix,jy,kz,ls) > qxmin(ls) ) THEN ! adding snow mass from CU scheme

             IF ( .true. .or. (anold(ix,jy,kz,ls) - an(ix,jy,kz,ls)) < qxmin(ls) .or. anold(ix,jy,kz,lns) < cxmin ) THEN 
             
             ! assume that there was no snow before this
             
             q = an(ix,jy,kz,ls)
             
             laminv1 = (dn(ix,kz) * q * zsfac)**(0.25)  ! inverse of slope
             
             n1 = laminv1*xn0s  ! number concentration for inv. exponential single moment input
             
             nrx =  n1*g1s/g0   ! number concentration for different shape parameter

             anold(ix,jy,kz,lns) = anold(ix,jy,kz,lns) + nrx ! *dninv ! convert to number mixing ratio
             
             ELSE
             ! assume mean particle mass of pre-existing snow
                xmass = anold(ix,jy,kz,ls)/anold(ix,jy,kz,lns)
                anold(ix,jy,kz,lns) = anold(ix,jy,kz,lns) + an(ix,jy,kz,ls)/xmass
             ENDIF
             
           ENDIF
         ENDIF
         
    ! graupel

!         IF ( lnh > 1 ) THEN
!           IF ( an(ix,jy,kz,lnh) <= 0.1*cxmin .and. an(ix,jy,kz,lh) > qxmin(lh) ) THEN
!             IF ( lvh > 1 ) THEN
!               IF ( an(ix,jy,kz,lvh) <= 0.0 ) THEN
!                 an(ix,jy,kz,lvh) = an(ix,jy,kz,lh)/xdnh
!               ENDIF
!             ENDIF
!
!             q = an(ix,jy,kz,lh)
!             
!             laminv1 = (dn(ix,kz) * q * zhfac)**(0.25)  ! inverse of slope
!             
!             n1 = laminv1*xn0h  ! number concentration for inv. exponential single moment input
!             
!             nrx =  n1*g1h/g0   ! number concentration for different shape parameter
!
!             an(ix,jy,kz,lnh) = nrx ! *dninv ! convert to number mixing ratio
!
!           ENDIF
!         ENDIF
!
!    ! hail
!
!         IF ( lnhl > 1 .and. lhl > 1 ) THEN
!           IF ( an(ix,jy,kz,lnhl) <= 0.1*cxmin .and. an(ix,jy,kz,lhl) > qxmin(lhl) ) THEN
!             IF ( lvhl > 1 ) THEN
!               IF ( an(ix,jy,kz,lvhl) <= 0.0 ) THEN
!                 an(ix,jy,kz,lvhl) = an(ix,jy,kz,lhl)/xdnhl
!               ENDIF
!             ENDIF
!
!             q = an(ix,jy,kz,lhl)
!             
!             laminv1 = (dn(ix,kz) * q * zhlfac)**(0.25)  ! inverse of slope
!             
!             n1 = laminv1*xn0hl  ! number concentration for inv. exponential single moment input
!             
!             nrx =  n1*g1hl/g0   ! number concentration for different shape parameter
!
!             an(ix,jy,kz,lnhl) = nrx ! *dninv ! convert to number mixing ratio
!
!           ENDIF
!         ENDIF
 
      ENDDO ! ix
      ENDDO ! kz
      
      RETURN
      
      END subroutine calcnfromcuten

! #####################################################################
! #####################################################################

   SUBROUTINE calc_eff_radius    &
     &  (nx,ny,nz,na,jyslab & 
     &  ,nor,norz & 
     &  ,t1,t2,t3  & 
     &  ,an,dn )

   implicit none

      integer, parameter :: ng1 = 1
      integer :: nx,ny,nz,na
      integer :: ng
      integer :: nor,norz, jyslab ! ,nht,ngt,igsr
      real    :: dtp  ! time step


!
! external temporary arrays
!

      real t1(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
      real t2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
      real t3(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
      

      real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na)
      real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)

      


      
    ! local
    
      real pb(-norz+ng1:nz+norz)
      real pinit(-norz+ng1:nz+norz)

! 
!  declarations microphysics and for gather/scatter
!
      integer nxmpb,nzmpb,nxz
      integer mgs,ngs,numgs,inumgs
      parameter (ngs=1)
      integer ngscnt,igs(ngs),kgs(ngs)
      real rho0(ngs)

      integer ix,kz,i,n, kp1
      integer :: jy, jgs
      integer ixb,ixe,jyb,jye,kzb,kze
    
      integer itile,jtile,ktile
      integer ixend,jyend,kzend,kzbeg
      integer nxend,nyend,nzend,nzbeg

      real :: qx(ngs,lv:lhab)
      real :: cx(ngs,lc:lhab)
      real :: xv(ngs,lc:lhab)
      real :: xmas(ngs,lc:lhab)
      real :: xdn(ngs,lc:lhab)
      real :: xdia(ngs,lc:lhab,3)
      real :: alpha(ngs,lc:lhab)
      
      real :: gamc1,gamc2,gami1,gami2,gams1,gams2, factor_c, factor_i, factor_s
      real :: lam_c, lam_i, lam_s
      integer :: il


! -------------------------------------------------------------------------------
      itile = nx
      jtile = ny
      ktile = nz
      ixend = nx
      jyend = ny
      kzend = nz
      nxend = nx + 1
      nyend = ny + 1
      nzend = nz
      kzbeg = 1
      nzbeg = 1

       jy = 1
       pb(:) = 0.0
       pinit(:) = 0.0

     gamc1 = Gamma_sp(2. + cnu)
     gamc2 = 1. ! Gamma[1 + alphac]
     gami1 = Gamma_sp(2. + cinu)
     gami2 = 1. ! Gamma[1 + alphac]
     gams1 = Gamma_sp(2. + snu)
     gams2 = Gamma_sp(1. + snu)

     factor_c = (1. + cnu)*Gamma_sp(1. + cnu)/Gamma_sp(5./3. + cnu)
     factor_i = (1. + cinu)*Gamma_sp(1. + cinu)/Gamma_sp(5./3. + cinu)
     factor_s = (1. + snu)*Gamma_sp(1. + snu)/Gamma_sp(5./3. + snu)

!
!     jy = 1 ! working on a 2d slab
!!  VERY IMPORTANT:  SET jgs = jy

      jgs = jy

      mgs = 1
      DO kz = 1,nz
       DO ix = 1,nx ! ixcol

         rho0(mgs) = dn(ix,jy,kz)
         DO il = lc,ls
          qx(mgs,il) = max(an(ix,jy,kz,il), 0.0) 
          cx(mgs,il) = max(an(ix,jy,kz,ln(il)), 0.0) 
         ENDDO
         
         IF ( qx(mgs,lc) > qxmin(lc) ) THEN
! Lambda for cloud droplets 
         lam_c = ((cx(mgs,lc)*(Pi/6.)*xdn0(lc)*Gamc1)/(qx(mgs,lc)*rho0(mgs)*Gamc2))**(1./3.)
          t1(ix,jy,kz) = 0.5*factor_c/lam_c
         ENDIF

         IF ( qx(mgs,li) > qxmin(li) ) THEN
! Lambda for cloud ice 
         lam_i = ((cx(mgs,li)*(Pi/6.)*xdn0(li)*Gami1)/(qx(mgs,li)*rho0(mgs)*Gami2))**(1./3.)
          t2(ix,jy,kz) = 0.5*factor_i/lam_i
         ENDIF

         IF ( qx(mgs,ls) > qxmin(ls) ) THEN
! Lambda for snow
         lam_s = ((cx(mgs,ls)*(Pi/6.)*xdn0(ls)*Gams1)/(qx(mgs,ls)*rho0(mgs)*Gams2))**(1./3.)
          t3(ix,jy,kz) = 0.5*factor_s/lam_s
         ENDIF

      
       ENDDO ! ix
      ENDDO ! kz

   RETURN
   END SUBROUTINE calc_eff_radius


! #####################################################################
! #####################################################################

      SUBROUTINE QVEXCESS(ngs,mgs,qwvp0,qv0,qcw1,pres,thetap0,theta0, &
     &    qvex,pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ss1,pk,ngscnt)
      
!#####################################################################
!  Purpose: find the amount of vapor that can be condensed to liquid
!#####################################################################

      implicit none

      integer ngs,mgs,ngscnt
      
      real theta2temp
      
      real qvex
      
      integer nqsat
      real fqsat, cbw
      
      real ss1  ! 'target' supersaturation
!
!  input arrays
!
      real qv0(ngs), qcw1(ngscnt), pres(ngs), qwvp0(mgs)
      real thetap0(ngs), theta0(ngs)
      real fcqv1(ngs), felvcp(ngs), pi0(ngs)
      real pk(ngs)
      
      real tabqvs(nqsat)
!
! Local stuff
!
      
      integer itertd
      integer ltemq
      real gamss
      real theta(ngs), qvap(ngs), pqs(ngs), qcw(ngs), qwv(ngs)
      real qcwtmp(ngs), qss(ngs), qvs(ngs), qwvp(ngs)
      real dqcw(ngs), dqwv(ngs), dqvcnd(ngs)
      real temg(ngs), temcg(ngs), thetap(ngs)
      
      real tfr
      parameter ( tfr = 273.15 )
            
!      real poo,cap
!      parameter ( cap = rd/cp, poo = 1.0e+05 )
!
!
!  Modified Straka adjustment (nearly identical to Tao et al. 1989 MWR)
!
!
!
!  set up temperature and vapor arrays
!
      pqs(mgs) = (380.0)/(pres(mgs))
      thetap(mgs) = thetap0(mgs)
      theta(mgs) = thetap(mgs) + theta0(mgs)
      qwvp(mgs) = qwvp0(mgs)
      qvap(mgs) = max( (qwvp0(mgs) + qv0(mgs)), 0.0 )
      temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap
!      temg(mgs) = theta2temp( theta(mgs), pres(mgs) )
!
!
!
!  reset temporaries for cloud particles and vapor
!
      
      qwv(mgs) = max( 0.0, qvap(mgs) )
      qcw(mgs) = max( 0.0, qcw1(mgs) )
!
!
      qcwtmp(mgs) = qcw(mgs)
      temcg(mgs) = temg(mgs) - tfr
      ltemq = (temg(mgs)-163.15)/fqsat+1.5
      ltemq = Min( nqsat, Max(1,ltemq) )

      qvs(mgs) = pqs(mgs)*tabqvs(ltemq)
      qss(mgs) = (0.01*ss1 + 1.0)*qvs(mgs)
!
!  iterate  adjustment
!
      do itertd = 1,2
!
!
!  calculate super-saturation
!
      dqcw(mgs) = 0.0
      dqwv(mgs) = ( qwv(mgs) - qss(mgs) )
!
!  evaporation and sublimation adjustment
!
      if( dqwv(mgs) .lt. 0. ) then           !  subsaturated
        if( qcw(mgs) .gt. -dqwv(mgs) ) then  ! check if qc can make up all of the deficit
          dqcw(mgs) = dqwv(mgs)
          dqwv(mgs) = 0.
        else                                 !  otherwise make all qc available for evap
          dqcw(mgs) = -qcw(mgs)
          dqwv(mgs) = dqwv(mgs) + qcw(mgs)
        end if
!
        qwvp(mgs) = qwvp(mgs) - ( dqcw(mgs)  )  ! add to perturbation vapor
!
        qcw(mgs) = qcw(mgs) + dqcw(mgs)

        thetap(mgs) = thetap(mgs) +  &
     &                1./pi0(mgs)*  &
     &                (felvcp(mgs)*dqcw(mgs) )

      end if  ! dqwv(mgs) .lt. 0. (end of evap/sublim)
!
! condensation/deposition
!
      IF ( dqwv(mgs) .ge. 0. ) THEN
!
      dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv1(mgs)*qss(mgs)/  &
     &  ((temg(mgs)-cbw)**2))
!
!
      dqcw(mgs) = dqvcnd(mgs)
!
      thetap(mgs) = thetap(mgs) +  &
     &   (felvcp(mgs)*dqcw(mgs) )    &
     & / (pi0(mgs))
      qwvp(mgs) = qwvp(mgs) - ( dqvcnd(mgs) )
      qcw(mgs) = qcw(mgs) + dqcw(mgs)
!
      END IF !  dqwv(mgs) .ge. 0.

      theta(mgs) = thetap(mgs) + theta0(mgs)
      temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap
!      temg(mgs) = theta2temp( theta(mgs), pres(mgs) )
      qvap(mgs) = Max((qwvp(mgs) + qv0(mgs)), 0.0)
      temcg(mgs) = temg(mgs) - tfr
!      tqvcon = temg(mgs)-cbw
      ltemq = (temg(mgs)-163.15)/fqsat+1.5
      ltemq = Min( nqsat, Max(1,ltemq) )
      qvs(mgs) = pqs(mgs)*tabqvs(ltemq)
      qcw(mgs) = max( 0.0, qcw(mgs) )
      qwv(mgs) = max( 0.0, qvap(mgs))
      qss(mgs) = (0.01*ss1 + 1.0)*qvs(mgs)
      end do
!
!  end the saturation adjustment iteration loop
!
!
      qvex = Max(0.0, qcw(mgs) - qcw1(mgs) )

      RETURN
      END SUBROUTINE QVEXCESS

! #####################################################################
! #####################################################################





!
! ##############################################################################
!
      SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
     &                 xmas,vtxbar,xdn,xvmn0,xvmx0,xv,cdx,cdxgs,            &
     &                 ipconc1,ndebug1,ngs,nz,kgs,fadvisc,   &
     &                 cwmasn,cwmasx,cwradn,cnina,cimna,cimxa,      &
     &                 itype1a,itype2a,temcg,infdo,alpha,ildo,axx,bxx)
!     &                 itype1a,itype2a,temcg,infdo,alpha,ildo,axh,bxh,axhl,bxhl)


      implicit none
      
      integer ngscnt,ngs0,ngs,nz
!      integer infall    ! whether to calculate number-weighted fall speeds
      
      real xv(ngs,lc:lhab)
      real qx(ngs,lv:lhab)
      real qxw(ngs,ls:lhab)
      real cx(ngs,lc:lhab)
      real vtxbar(ngs,lc:lhab,3)
      real xmas(ngs,lc:lhab)
      real xdn(ngs,lc:lhab)
      real cdxgs(ngs,lc:lhab)
      real xdia(ngs,lc:lhab,3)
      real xvmn0(lc:lhab), xvmx0(lc:lhab)
      real qxmin(lc:lhab)
      real cdx(lc:lhab)
      real alpha(ngs,lc:lhab)
      
      real rho0(ngs),rhovt(ngs),temcg(ngs)
      real cno(lc:lhab)
      real cnostmp(ngs)
      
      real cwc1, cimna, cimxa
      real cnina(ngs)
      integer kgs(ngs)
      real fadvisc(ngs)
      real fsw
      
      integer ipconc1
      integer ndebug1
      
      integer, intent (in) :: itype1a,itype2a,infdo
      integer, intent (in) :: ildo ! which species to do, or all if ildo=0

      real :: axx(ngs,lh:lhab),bxx(ngs,lh:lhab)
!!      real :: axh(ngs),bxh(ngs)
!      real :: axhl(ngs),bxhl(ngs)
      
! Local vars

      
      
      real swmasmx, dtmp
      real cd
      real cwc0 ! ,cwc1
      real :: cwch(ngscnt), cwchl(ngscnt)
      real :: cwchtmp,cwchltmp,xnutmp
      real pii
      real cimasx,cimasn
      real cwmasn,cwmasx,cwradn
      real cwrad
      real vr,rnux
      real alp
      
      real ccimx

      integer mgs
      
      real arx,frx,vtrain,fw
      real fwlo,fwhi,rfwdiff
      real ar,br,cs,ds
!      real gf4p5, gf4ds, gf4br, ifirst, gf1ds
!      real gfcinu1, gfcinu1p47, gfcinu2p47
      real gr
      real rwrad,rwdia
      real mwfac
      integer il

!      save gf4p5, gf4ds, gf4br, ifirst, gf1ds
!      save gfcinu1, gfcinu1p47, gfcinu2p47
!      data ifirst /0/
      
      real bta1,cnit
      parameter ( bta1 = 0.6, cnit = 1.0e-02 )
      real x,y,tmp,del
      real aax,bbx,delrho
      integer :: indxr
      real mwt, nwt, zwt
      real, parameter :: rho00 = 1.225
      integer i
      real xvbarmax

      integer l1, l2


!
! set values
!
!      cwmasn = 5.23e-13  ! radius of 5.0e-6
!      cwradn = 5.0e-6
!      cwmasx = 5.25e-10  ! radius of 50.0e-6

      fwlo = 0.2                ! water fraction to start weighting toward rain fall speed
      fwhi = 0.4                ! water fraction at which rain fall speed only is used
      rfwdiff = 1./(fwhi - fwlo)
      
!      pi = 4.0*atan(1.0)
      pii = piinv ! 1.0/pi

      arx = 10.
      frx = 516.575 ! raind fit parameters for arx*(1 - Exp(-fx*d)), where d is rain diameter in meters.

      ar = 841.99666  
      br = 0.8
      gr = 9.8
!  new values for  cs and ds
      cs = 12.42
      ds = 0.42

      IF ( ildo == 0 ) THEN
        l1 = lc
        l2 = lhab
      ELSE
        l1 = ildo
        l2 = ildo
      ENDIF

!      IF ( ifirst .eq. 0 ) THEN
!        ifirst = 1
!        gf4br = gamma(4.0+br)
!        gf4ds = gamma(4.0+ds)
!!        gf1ds = gamma(1.0+ds)
!        gf4p5 = gamma(4.0+0.5)
!        gfcinu1 = gamma(cinu + 1.0)
!        gfcinu1p47 = gamma(cinu + 1.47167)
!        gfcinu2p47 = gamma(cinu + 2.47167)
        
        IF ( lh  .gt. 1 ) THEN
          IF ( dmuh == 1.0 ) THEN
            cwchtmp = ((3. + dnu(lh))*(2. + dnu(lh))*(1.0 + dnu(lh)))**(-1./3.)
          ELSE
            cwchtmp = 6.0*pii*gamma_sp( (xnu(lh) + 1.)/xmu(lh) )/gamma_sp( (xnu(lh) + 2.)/xmu(lh) )
          ENDIF
        ENDIF
        IF ( lhl .gt. 1 ) THEN
          IF ( dmuhl == 1.0 ) THEN
            cwchltmp = ((3. + dnu(lhl))*(2. + dnu(lhl))*(1.0 + dnu(lhl)))**(-1./3.)
          ELSE
            cwchltmp = 6.0*pii*gamma_sp( (xnu(lhl) + 1)/xmu(lhl) )/gamma_sp( (xnu(lhl) + 2)/xmu(lhl) )
          ENDIF
        ENDIF

        IF ( ipconc .le. 5 ) THEN
          IF ( lh  .gt. 1 ) cwch(:) =  cwchtmp 
          IF ( lhl .gt. 1 ) cwchl(:) = cwchltmp
        ELSE
          DO mgs = 1,ngscnt
          
          IF ( lh  .gt. 1 .and. ( ildo == 0 .or. ildo == lh ) ) THEN
           IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN
            IF ( dmuh == 1.0 ) THEN
              cwch(mgs) = ((3. + alpha(mgs,lh))*(2. + alpha(mgs,lh))*(1.0 + alpha(mgs,lh)))**(-1./3.)
             ELSE
             xnutmp = (alpha(mgs,lh) - 2.0)/3.0
             cwch(mgs) =  6.0*pii*gamma_sp( (xnutmp + 1.)/xmu(lh) )/gamma_sp( (xnutmp + 2.)/xmu(lh) )
            ENDIF
           ELSE
             cwch(mgs) = cwchtmp
           ENDIF
          ENDIF
          IF ( lhl .gt. 1 .and. ( ildo == 0 .or. ildo == lhl ) ) THEN
           IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN
            IF ( dmuhl == 1.0 ) THEN
              cwchl(mgs) = ((3. + alpha(mgs,lhl))*(2. + alpha(mgs,lhl))*(1.0 + alpha(mgs,lhl)))**(-1./3.)
             ELSE
             xnutmp = (alpha(mgs,lhl) - 2.0)/3.0
             cwchl(mgs) = 6.0*pii*gamma_sp( (xnutmp + 1)/xmu(lhl) )/gamma_sp( (xnutmp + 2)/xmu(lhl) )
            ENDIF
           ELSE
             cwchl(mgs) = cwchltmp
           ENDIF
          ENDIF
          
          ENDDO
        
        ENDIF
       

      cimasn = Min( cimas0, 6.88e-13)
      cimasx = 1.0e-8
      ccimx = 5000.0e3   ! max of 5000 per liter

      cwc1 = 6.0/(pi*1000.)
      cwc0 = pii ! 6.0*pii
      mwfac = 6.0**(1./3.)

      
      if (ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set scale diameter'
!


!
!  cloud water variables
! ################################################################
!
!  DROPLETS
!
!
      if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set cloud water variables'
      
      IF ( ildo == 0 .or. ildo == lc ) THEN
      
      do mgs = 1,ngscnt
      xv(mgs,lc) = 0.0
      
      IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN !{
      
      IF ( ipconc .ge. 2 ) THEN
        IF ( cx(mgs,lc) .gt. cxmin) THEN !{
        xmas(mgs,lc) =  &
     &    min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx )
        xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc)
        ELSE
         cx(mgs,lc) = Max( cxmin, rho0(mgs)*qx(mgs,lc)/cwmasx )
         xmas(mgs,lc) = Min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx )
         xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc)
        
        ENDIF
      ELSE
       IF ( ipconc .lt. 2 ) THEN
         cx(mgs,lc) = rho0(mgs)*ccn/rho00 ! scales to local density, relative to standard air density
       ENDIF
       IF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 0.01 ) THEN !{
        xmas(mgs,lc) =  &
     &     min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),xdn(mgs,lc)*xvmn(lc)), &
     &      xdn(mgs,lc)*xvmx(lc) )
        
        xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc)
        cx(mgs,lc) = qx(mgs,lc)*rho0(mgs)/xmas(mgs,lc)
        
       ELSEIF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .le. 1.0e-9 ) THEN
        cx(mgs,lc) = Max( cxmin, rho0(mgs)*qx(mgs,lc)/cwmasx )
        xmas(mgs,lc) =  &
     &    min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx )
        xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc)

       ELSEIF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .le. 0.01 ) THEN
        xmas(mgs,lc) = xdn(mgs,lc)*4.*pi/3.*(5.0e-6)**3
        cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc)
        xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc)
        
       ELSE
        xmas(mgs,lc) = cwmasn
        xv(mgs,lc) = xmas(mgs,lc)/1000.
! do not define ccw here! it can feed back to ccn!!!    cx(mgs,lc) = 0.0 ! cwnc(mgs)
       ENDIF !}
      ENDIF !}
!      IF ( ipconc .lt. 2 ) THEN
!        xmas(mgs,lc) = &
!     &    min( max(qx(mgs,lc)*rho0(mgs)/cwnc(mgs),cwmasn),cwmasx )
!        cx(mgs,lc) = Max(1.0,qx(mgs,lc)*rho0(mgs)/xmas(mgs,lc))
!      ELSE
!        cwnc(mgs) = an(igs(mgs),jgs,kgs(mgs),lnc)
!        cx(mgs,lc) = cwnc(mgs)
!      ENDIF
      xdia(mgs,lc,1) = (xmas(mgs,lc)*cwc1)**(1./3.)
      xdia(mgs,lc,2) = xdia(mgs,lc,1)**2
      xdia(mgs,lc,3) = xdia(mgs,lc,1)
      cwrad = 0.5*xdia(mgs,lc,1)
      IF ( fadvisc(mgs) > 0.0 ) THEN
      vtxbar(mgs,lc,1) =  &
     &   (2.0*gr*xdn(mgs,lc) *(cwrad**2)) &
     &  /(9.0*fadvisc(mgs))
      ELSE
       vtxbar(mgs,lc,1) = 0.0
      ENDIF

      
      ELSE
       xmas(mgs,lc) = cwmasn
       xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc)
       IF ( qx(mgs,lc) <= 0.0 ) cx(mgs,lc) = 0.0
       IF ( ipconc .le. 1 ) cx(mgs,lc) = 0.01
       xdia(mgs,lc,1) = 2.*cwradn
       xdia(mgs,lc,2) = 4.*cwradn**2
       xdia(mgs,lc,3) = xdia(mgs,lc,1)
       vtxbar(mgs,lc,1) = 0.0
       
      ENDIF !} qcw .gt. qxmin(lc)
      
      end do
      
      ENDIF



!
! cloud ice variables
! columns
!
! ################################################################
!
!  CLOUD ICE
!
      if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set cip'
      
      IF ( li .gt. 1 .and. ( ildo == 0 .or. ildo == li ) ) THEN
      do mgs = 1,ngscnt
       xdn(mgs,li)  = 900.0
      IF ( ipconc .eq. 0 ) THEN
!       cx(mgs,li) = min(cnit*exp(-temcg(mgs)*bta1),1.e+09)
        cx(mgs,li) = cnina(mgs)
       IF ( cimna .gt. 1.0 ) THEN
         cx(mgs,li) = Max(cimna,cx(mgs,li))
       ENDIF
       IF ( cimxa .gt. 1.0 ) THEN
         cx(mgs,li) = Min(cimxa,cx(mgs,li))
       ENDIF
! erm 3/28/2002
       IF ( itype1a .ge. 1 .or. itype2a .ge. 1 ) THEN
        cx(mgs,li) = Max(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasx)
        cx(mgs,li) = Min(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasn)
       ENDIF
!
       cx(mgs,li) = max(1.0e-20,cx(mgs,li))
!       cx(mgs,li) = Min(ccimx, cx(mgs,li))

      
      ELSEIF ( ipconc .ge. 1 ) THEN
        IF ( qx(mgs,li) .gt. qxmin(li) ) THEN
         cx(mgs,li) = Max(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasx)
         cx(mgs,li) = Min(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasn)
!         cx(mgs,li) = Max(1.0,cx(mgs,li))
        ENDIF
      ENDIF
      
      IF ( qx(mgs,li) .gt. qxmin(li) ) THEN
      xmas(mgs,li) = &
     &     max( qx(mgs,li)*rho0(mgs)/cx(mgs,li), cimasn )
!     &  min( max(qx(mgs,li)*rho0(mgs)/cx(mgs,li),cimasn),cimasx )
      
!      if ( temcg(mgs) .gt. 0.0 ) then
!      xdia(mgs,li,1) = 0.0
!      else
      if ( xmas(mgs,li) .gt. 0.0 ) THEN ! cimasn ) then
!c      xdia(mgs,li,1) = 0.4892*(xmas(mgs,li)**(0.4554))
!       xdia(mgs,li,1) = 0.1871*(xmas(mgs,li)**(0.3429))

!       xdia(mgs,li,1) = (132.694*5.40662/xmas(mgs,li))**(-1./2.9163)  ! for inverse exponential distribution
       IF ( ixtaltype == 1 ) THEN ! column
       xdia(mgs,li,1) = 0.1871*(xmas(mgs,li)**(0.3429))
       xdia(mgs,li,3) = 0.1871*(xmas(mgs,li)**(0.3429))
       ELSEIF  ( ixtaltype == 2 ) THEN ! disk
        xdia(mgs,li,1) = 0.277823*xmas(mgs,li)**0.359971
        xdia(mgs,li,3) = 0.277823*xmas(mgs,li)**0.359971
       ENDIF
      end if
!      end if
!      xdia(mgs,li,1) = max(xdia(mgs,li,1), 5.e-6)
!      xdia(mgs,li,1) = min(xdia(mgs,li,1), 1000.e-6)

       IF ( ipconc .ge. 0 ) THEN
!      vtxbar(mgs,li,1) = rhovt(mgs)*49420.*40.0005/5.40662*xdia(mgs,li,1)**(1.415) ! mass-weighted
!      vtxbar(mgs,li,1) = (4.942e4)*(xdia(mgs,li,1)**(1.4150))
        xv(mgs,li) = xmas(mgs,li)/xdn(mgs,li)
        IF ( icefallopt == 1 ) THEN ! default ice fall
          IF ( ixtaltype == 1 ) THEN ! column
          tmp = (67056.6300748612*rhovt(mgs))/  &
     &     (((1.0 + cinu)/xv(mgs,li))**0.4716666666666667*gfcinu1)
          vtxbar(mgs,li,2) = tmp*gfcinu1p47
          vtxbar(mgs,li,1) = tmp*gfcinu2p47/(1. + cinu)
          vtxbar(mgs,li,3) = vtxbar(mgs,li,1) 
        ELSEIF  ( ixtaltype == 2 ) THEN ! disk -- but just use Ferrier (1994) snow fall speeds for now
            vtxbar(mgs,li,1) = 11.9495*rhovt(mgs)*(xv(mgs,li))**(0.14)
            vtxbar(mgs,li,2) = 7.02909*rhovt(mgs)*(xv(mgs,li))**(0.14)
           vtxbar(mgs,li,3) = vtxbar(mgs,li,1) 
        
          ENDIF
          
       ELSEIF ( icefallopt == 2 ) THEN !   ! Ferrier ice fall speed
          tmp = (82.3166*rhovt(mgs))/  &
     &     (((1.0 + cinu)/xv(mgs,li))**0.22117*gfcinu1)
          vtxbar(mgs,li,2) = tmp*gfcinu1p22
          vtxbar(mgs,li,1) = tmp*gfcinu2p22/(1. + cinu)
          vtxbar(mgs,li,3) = vtxbar(mgs,li,1) 

       ELSEIF ( icefallopt == 3 ) THEN !   ! Adjusted Ferrier (smaller exponent of 0.55 instead of 0.6635)
       
          tmp = (47.6273*rhovt(mgs))/  &
     &     (((1.0 + cinu)/xv(mgs,li))**0.18333*gfcinu1)
          vtxbar(mgs,li,2) = tmp*gfcinu1p18
          vtxbar(mgs,li,1) = tmp*gfcinu2p18/(1. + cinu)
          vtxbar(mgs,li,3) = vtxbar(mgs,li,1) 
       
       ENDIF
!      vtxbar(mgs,li,1) = vtxbar(mgs,li,2)*(1.+cinu)/(1. + cinu)
!      xdn(mgs,li)   = min(max(769.8*xdia(mgs,li,1)**(-0.0140),300.0),900.0)
!      xdn(mgs,li) = 900.0
        xdia(mgs,li,2) = xdia(mgs,li,1)**2
!      vtxbar(mgs,li,1) = vtxbar(mgs,li,1)*rhovt(mgs)
       ELSE
         xdia(mgs,li,1) = max(xdia(mgs,li,1), 10.e-6)
         xdia(mgs,li,1) = min(xdia(mgs,li,1), 1000.e-6)
         vtxbar(mgs,li,1) = (4.942e4)*(xdia(mgs,li,1)**(1.4150))
!      xdn(mgs,li)   = min(max(769.8*xdia(mgs,li,1)**(-0.0140),300.0),900.0)
         xdn(mgs,li) = 900.0
         xdia(mgs,li,2) = xdia(mgs,li,1)**2
         vtxbar(mgs,li,1) = vtxbar(mgs,li,1)*rhovt(mgs)
         xv(mgs,li) = xmas(mgs,li)/xdn(mgs,li)
       ENDIF ! ipconc gt 3
      ELSE
       xmas(mgs,li) = 1.e-13
       IF ( qx(mgs,li) <= 0.0 ) cx(mgs,li) = 0.0
       xdn(mgs,li)  = 900.0
       xdia(mgs,li,1) = 1.e-7
       xdia(mgs,li,2) = (1.e-14)
       xdia(mgs,li,3) = 1.e-7
       vtxbar(mgs,li,1) = 0.0
!       cicap(mgs) = 0.0
!       ciat(mgs) = 0.0
      ENDIF
      
      IF ( icefallfac /= 1.0 ) THEN
        vtxbar(mgs,li,1) = icefallfac*vtxbar(mgs,li,1)
        vtxbar(mgs,li,2) = icefallfac*vtxbar(mgs,li,2)
        vtxbar(mgs,li,3) = icefallfac*vtxbar(mgs,li,3)
      ENDIF

      
      
      end do
      
      ENDIF ! li .gt. 1


! ################################################################
!
!  RAIN
!
      
!
      IF ( ildo == 0 .or. ildo == lr ) THEN
      do mgs = 1,ngscnt
      if ( qx(mgs,lr) .gt. qxmin(lr) ) then
      
!      IF ( qx(mgs,lr) .gt. 10.0e-3 ) &
!     &  write(0,*)  'RAIN1: ',igs(mgs),kgs(mgs),qx(mgs,lr)
      
      if ( ipconc .ge. 3 ) then
        xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr)))
        xvbarmax = xvmx(lr)
        IF ( imaxdiaopt == 1 ) THEN
          xvbarmax = xvmx(lr)
        ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter
         IF ( imurain == 1 ) THEN
           xvbarmax = xvmx(lr)/((3. + alpha(mgs,lr))**3/((3. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(1. + alpha(mgs,lr))))
         ELSEIF ( imurain == 3 ) THEN
           
         ENDIF
        ELSEIF ( imaxdiaopt == 3 ) THEN ! test against mass-weighted diameter
         IF ( imurain == 1 ) THEN
           xvbarmax = xvmx(lr)/((4. + alpha(mgs,lr))**3/((3. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(1. + alpha(mgs,lr))))
         ELSEIF ( imurain == 3 ) THEN
           
         ENDIF
        ENDIF
       
        IF ( xv(mgs,lr) .gt. xvbarmax ) THEN
          xv(mgs,lr) = xvbarmax
          cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvbarmax*xdn(mgs,lr))
        ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN
          xv(mgs,lr) = xvmn(lr)
          cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr))
        ENDIF


        xmas(mgs,lr) = xv(mgs,lr)*xdn(mgs,lr)
        xdia(mgs,lr,3) = (xmas(mgs,lr)*cwc1)**(1./3.) ! xdia(mgs,lr,1)
        IF ( imurain == 3 ) THEN
!          xdia(mgs,lr,1) = (6.*pii*xv(mgs,lr)/(alpha(mgs,lr)+1.))**(1./3.)
          xdia(mgs,lr,1) = xdia(mgs,lr,3) ! formulae for Ziegler (1985) use mean volume diameter, not lambda**(-1)
        ELSE ! imurain == 1, Characteristic diameter (1/lambda)
          xdia(mgs,lr,1) = (6.*pii*xv(mgs,lr)/((alpha(mgs,lr)+3.)*(alpha(mgs,lr)+2.)*(alpha(mgs,lr)+1.)))**(1./3.)
        ENDIF
!        rwrad(mgs) = 0.5*xdia(mgs,lr,1)

! Inverse exponential version:
!        xdia(mgs,lr,1) =
!     &  (qx(mgs,lr)*rho0(mgs)
!     & /(pi*xdn(mgs,lr)*cx(mgs,lr)))**(0.333333)
      ELSE
        xdia(mgs,lr,1) = &
     &  (qx(mgs,lr)*rho0(mgs)/(pi*xdn(mgs,lr)*cno(lr)))**(0.25) 
        xmas(mgs,lr) = xdn(mgs,lr)*(pi/6.)*xdia(mgs,lr,1)**3
        xdia(mgs,lr,3) = (xmas(mgs,lr)*cwc1)**(1./3.)
        cx(mgs,lr) = cno(lr)*xdia(mgs,lr,1)
        xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr))
      end if
      else
        xdia(mgs,lr,1) = 1.e-9
        xdia(mgs,lr,3) = 1.e-9
        xmas(mgs,lr) = xdn(mgs,lr)*(pi/6.)*xdia(mgs,lr,1)**3
!        rwrad(mgs) = 0.5*xdia(mgs,lr,1)
      end if
      xdia(mgs,lr,2) = xdia(mgs,lr,1)**2
!      xmas(mgs,lr) = xdn(mgs,lr)*(pi/6.)*xdia(mgs,lr,1)**3
      end do
      
      ENDIF
! ################################################################
!
!  SNOW
!

      IF ( ls .gt. 1 .and. ( ildo == 0 .or. ildo == ls ) ) THEN
      
      do mgs = 1,ngscnt 
      if ( qx(mgs,ls) .gt. qxmin(ls) ) then
      if ( ipconc .ge. 4 ) then ! 

        xmas(mgs,ls) =  rho0(mgs)*qx(mgs,ls)/(Max(1.0e-9,cx(mgs,ls)))
        swmasmx = 13.7e-6
!       IF ( xmas(mgs,ls) > swmasmx ) THEN
!          xmas(mgs,ls) = swmasmx
!          cx(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xmas(mgs,ls))
!        ENDIF

        IF ( isnowdens == 2 ) THEN ! Set values according to Cox relationship
        
          xdn(mgs,ls) = 0.0346159*Sqrt(cx(mgs,ls)/(qx(mgs,ls)*rho0(mgs)) )
          xdn(mgs,ls) = Max( 100.0, xdn(mgs,ls) )  ! limit snow to 100. to keep other equations in line
          
          IF ( xdn(mgs,ls) <= 900. ) THEN
             dtmp = Sqrt( xmas(mgs,ls)/0.069 ) ! diameter (meters) of mean mass particle using Cox 1998 relation (m = p d^2)
             xv(mgs,ls) = 28.8887*xmas(mgs,ls)**(3./2.)
          ELSE ! at small sizes, assume ice spheres
             xdn(mgs,ls) = 900.
             xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*Max(1.0e-9,cx(mgs,ls)))
             dtmp = (xv(mgs,ls)*cwc0*6.0)**(1./3.)
          ENDIF
          
        ELSE ! leave xdn(ls) at default value
             xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*Max(1.0e-9,cx(mgs,ls)))
             dtmp = (xv(mgs,ls)*cwc0*6.0)**(1./3.)
        ENDIF

        xdia(mgs,ls,1) = dtmp ! (xv(mgs,ls)*cwc0*6.0)**(1./3.)

        IF ( xv(mgs,ls) .lt. xvmn(ls) .and. isnowdens == 1) THEN
          xv(mgs,ls) = Max( xvmn(ls),xv(mgs,ls) )
          xmas(mgs,ls) = xv(mgs,ls)*xdn(mgs,ls)
          cx(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xmas(mgs,ls))
          xdia(mgs,ls,1) = (xv(mgs,ls)*cwc0*6.0)**(1./3.)
        ENDIF

        IF ( xv(mgs,ls) .gt. xvmx(ls)*Max(1.,100./Min(100.,xdn(mgs,ls))) ) THEN
          xv(mgs,ls) = Min( xvmx(ls), Max( xvmn(ls),xv(mgs,ls) ) )
          xmas(mgs,ls) = 0.106214*xv(mgs,ls)**(2./3.)
          cx(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xmas(mgs,ls))
          xdn(mgs,ls) = 0.0346159*Sqrt(cx(mgs,ls)/(qx(mgs,ls)*rho0(mgs)) )
          xdia(mgs,ls,1) = Sqrt( xmas(mgs,ls)/0.069 ) 
        ENDIF

        xdia(mgs,ls,3) = xdia(mgs,ls,1)

      ELSE
        xdia(mgs,ls,1) =  &
     &    (qx(mgs,ls)*rho0(mgs)/(pi*xdn(mgs,ls)*cnostmp(mgs)))**(0.25) 
        cx(mgs,ls) = cnostmp(mgs)*xdia(mgs,ls,1)
        xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*cx(mgs,ls))
        xdia(mgs,ls,3) = (xv(mgs,ls)*cwc0*6.0)**(1./3.)
      end if
      else
      xdia(mgs,ls,1) = 1.e-9
      xdia(mgs,ls,3) = 1.e-9
      cx(mgs,ls) = 0.0
      
       IF ( isnowdens == 2 ) THEN ! Set values according to Cox relationship
         xdn(mgs,ls) = 90.
       ENDIF

      end if
      xdia(mgs,ls,2) = xdia(mgs,ls,1)**2
!      swdia3(mgs) = xdia(mgs,ls,2)*xdia(mgs,ls,1)
!      xmas(mgs,ls) = xdn(mgs,ls)*(pi/6.)*swdia3(mgs)
      end do
      
      ENDIF ! ls .gt 1
!
!
! ################################################################
!
!  GRAUPEL
!

      IF ( lh .gt. 1 .and. ( ildo == 0 .or. ildo == lh ) ) THEN
      
      do mgs = 1,ngscnt 
      if ( qx(mgs,lh) .gt. qxmin(lh) ) then
      if ( ipconc .ge. 5 ) then

        xv(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*Max(1.0e-9,cx(mgs,lh)))
        xmas(mgs,lh) = xv(mgs,lh)*xdn(mgs,lh)

        IF ( xv(mgs,lh) .lt. xvmn(lh) .or. xv(mgs,lh) .gt. xvmx(lh) ) THEN
          xv(mgs,lh) = Min( xvmx(lh), Max( xvmn(lh),xv(mgs,lh) ) )
          xmas(mgs,lh) = xv(mgs,lh)*xdn(mgs,lh)
          cx(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xmas(mgs,lh))
        ENDIF

         xdia(mgs,lh,3) = (xv(mgs,lh)*6.*pii)**(1./3.) ! mwfac*xdia(mgs,lh,1) ! (xv(mgs,lh)*cwc0*6.0)**(1./3.)
         IF ( dmuh == 1.0 ) THEN
           xdia(mgs,lh,1) = cwch(mgs)*xdia(mgs,lh,3)
         ELSE
           xdia(mgs,lh,1) = (xv(mgs,lh)*cwch(mgs))**(1./3.)
         ENDIF

      ELSE
      xdia(mgs,lh,1) =  &
     &  (qx(mgs,lh)*rho0(mgs)/(pi*xdn(mgs,lh)*cno(lh)))**(0.25) 
      cx(mgs,lh) = cno(lh)*xdia(mgs,lh,1)
      xv(mgs,lh) = Max(xvmn(lh), rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) )
      xdia(mgs,lh,3) = (xv(mgs,lh)*6./pi)**(1./3.) 
      end if
      else
      xdia(mgs,lh,1) = 1.e-9
      xdia(mgs,lh,3) = 1.e-9
      end if
      xdia(mgs,lh,2) = xdia(mgs,lh,1)**2
!      hwdia3(mgs) = xdia(mgs,lh,2)*xdia(mgs,lh,1)
!      xmas(mgs,lh) = xdn(mgs,lh)*(pi/6.)*hwdia3(mgs)
      end do
      
      ENDIF

!
! ################################################################
!
!  HAIL
!

      IF ( lhl .gt. 1 .and. ( ildo == 0 .or. ildo == lhl ) ) THEN
      
      do mgs = 1,ngscnt 
      if ( qx(mgs,lhl) .gt. qxmin(lhl) ) then
      if ( ipconc .ge. 5 ) then

        xv(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*Max(1.0e-9,cx(mgs,lhl)))
        xmas(mgs,lhl) = xv(mgs,lhl)*xdn(mgs,lhl)
!        write(0,*) 'setvt: xv = ',xv(mgs,lhl),xdn(mgs,lhl),cx(mgs,lhl),xmas(mgs,lhl),qx(mgs,lhl)

        IF ( xv(mgs,lhl) .lt. xvmn(lhl) .or. xv(mgs,lhl) .gt. xvmx(lhl) ) THEN
          xv(mgs,lhl) = Min( xvmx(lhl), Max( xvmn(lhl),xv(mgs,lhl) ) )
          xmas(mgs,lhl) = xv(mgs,lhl)*xdn(mgs,lhl)
          cx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/(xmas(mgs,lhl))
        ENDIF

        xdia(mgs,lhl,3) = (xv(mgs,lhl)*6./pi)**(1./3.) ! mwfac*xdia(mgs,lh,1) ! (xv(mgs,lh)*cwc0*6.0)**(1./3.)
         IF ( dmuhl == 1.0 ) THEN
           xdia(mgs,lhl,1) = cwchl(mgs)*xdia(mgs,lhl,3)
         ELSE
           xdia(mgs,lhl,1) = (xv(mgs,lhl)*cwchl(mgs))**(1./3.)
         ENDIF
        
!        write(0,*) 'setvt: xv = ',xv(mgs,lhl),xdn(mgs,lhl),cx(mgs,lhl),xdia(mgs,lhl,3)
      ELSE
      xdia(mgs,lhl,1) = &
     &  (qx(mgs,lhl)*rho0(mgs)/(pi*xdn(mgs,lhl)*cno(lhl)))**(0.25) 
      cx(mgs,lhl) = cno(lhl)*xdia(mgs,lhl,1)
      xv(mgs,lhl) = Max(xvmn(lhl), rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*cx(mgs,lhl)) )
      xdia(mgs,lhl,3) = (xv(mgs,lhl)*6./pi)**(1./3.) 
      end if
      else
      xdia(mgs,lhl,1) = 1.e-9
      xdia(mgs,lhl,3) = 1.e-9
      end if
      xdia(mgs,lhl,2) = xdia(mgs,lhl,1)**2
!      hwdia3(mgs) = xdia(mgs,lh,2)*xdia(mgs,lh,1)
!      xmas(mgs,lh) = xdn(mgs,lh)*(pi/6.)*hwdia3(mgs)
      end do
      
      ENDIF
!      
!
!
!  Set terminal velocities...
!    also set drag coefficients (moved to start of subroutine)
!
!      cdx(lr) = 0.60
!      cdx(lh) = 0.45
!      cdx(lhl) = 0.45
!      cdx(lf) = 0.45
!      cdx(lgh) = 0.60
!      cdx(lgm) = 0.80
!      cdx(lgl) = 0.80
!      cdx(lir) = 2.00
!
      if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set terminal velocities'
!
!
! ################################################################
!
!  RAIN
!
      IF ( ildo == 0 .or. ildo == lr ) THEN
      do mgs = 1,ngscnt
      if ( qx(mgs,lr) .gt. qxmin(lr) ) then
      IF ( ipconc .lt. 3 ) THEN
        vtxbar(mgs,lr,1) = rainfallfac*(ar*gf4br/6.0)*(xdia(mgs,lr,1)**br)*rhovt(mgs)
!        write(91,*) 'vtxbar: ',vtxbar(mgs,lr,1),mgs,gf4br,xdia(mgs,lr,1),rhovt(mgs)
      ELSE
        
        IF ( imurain == 1 ) THEN ! DSD of Diameter
        
        ! using functional form of  arx*(1 - Exp(-frx*diameter) ), with arx =       arx = 10.
        !  and frx = 516.575 ! raind fit parameters for arx*(1 - Exp(-fx*d)), where d is rain diameter in meters.
        ! Similar form as in Atlas et al. (1973), who had 9.65 - 10.3*Exp[-600 * d]

        
          alp = alpha(mgs,lr)
          
          vtxbar(mgs,lr,1) = rhovt(mgs)*arx*(1.0 - (1.0 + frx*xdia(mgs,lr,1))**(-alp - 4.0) ) ! mass weighted
          
          IF ( infdo .ge. 1 .and. rssflg == 1 ) THEN
            vtxbar(mgs,lr,2) = rhovt(mgs)*arx*(1.0 - (1.0 + frx*xdia(mgs,lr,1))**(-alp - 1.0) ) ! number weighted
          ELSE
            vtxbar(mgs,lr,2) = vtxbar(mgs,lr,1)
          ENDIF
          
          IF ( infdo .ge. 2 .and. rssflg == 1 ) THEN
            vtxbar(mgs,lr,3) = rhovt(mgs)*arx*(1.0 - (1.0 + frx*xdia(mgs,lr,1))**(-alp - 7.0) ) ! z-weighted
          ELSE
            vtxbar(mgs,lr,3) = vtxbar(mgs,lr,1)
          ENDIF
          
!          write(91,*) 'setvt: alp,vn,vm,vz = ',alp,vtxbar(mgs,lr,2), vtxbar(mgs,lr,1), vtxbar(mgs,lr,3),alpha(mgs,lr)

        ELSEIF ( imurain == 3 ) THEN ! DSD of Volume
        
        IF ( lzr < 1 ) THEN ! not 3-moment rain
        rwdia = Min( xdia(mgs,lr,1), 8.0e-3 )
        
         vtxbar(mgs,lr,1) = rhovt(mgs)*6.0*pii*( 0.04771 + 3788.0*rwdia -  &
     &        1.105e6*rwdia**2 + 1.412e8*rwdia**3 - 6.527e9*rwdia**4)
        
        IF ( infdo .ge. 1 ) THEN
          IF (  rssflg >= 1 ) THEN
         vtxbar(mgs,lr,2) = (0.09112 + 2714.0*rwdia - 4.872e5*rwdia**2 +  &
     &            4.495e7*rwdia**3 - 1.626e9*rwdia**4)*rhovt(mgs)
          ELSE
            vtxbar(mgs,lr,2) = vtxbar(mgs,lr,1)
          ENDIF
        ENDIF
        
        IF ( infdo .ge. 2 ) THEN ! Z-weighted fall speed
        vtxbar(mgs,lr,3)  = rhovt(mgs)*(  &
     &       0.0911229 +                  &
     &  9246.494*(rwdia) -               &
     &  3.2839926e6*(rwdia**2) +          &
     &  4.944093e8*(rwdia**3) -          &
     &  2.631718e10*(rwdia**4) )
        ENDIF
        
        ELSE ! 3-moment rain, gamma-volume

        vr = xv(mgs,lr)
        rnux = alpha(mgs,lr)
        
        IF ( infdo .ge. 1 .and. rssflg == 1) THEN ! number-weighted; DTD: added size-sorting flag
        vtxbar(mgs,lr,2) = rhovt(mgs)*                             &
     &     (((1. + rnux)/vr)**(-1.333333)*                         &
     &    (0.0911229*((1. + rnux)/vr)**1.333333*Gamma_sp(1. + rnux) + &
     &      (5430.3131*(1. + rnux)*Gamma_sp(4./3. + rnux))/           &
     &       vr - 1.0732802e6*((1. + rnux)/vr)**0.6666667*         &
     &       Gamma_sp(1.666667 + rnux) +                              &
     &      8.584110982429507e7*((1. + rnux)/vr)**(1./3.)*         &
     &       Gamma_sp(2. + rnux) -                                    &
     &      2.3303765697228556e9*Gamma_sp(7./3. + rnux)))/            &
     &  Gamma_sp(1. + rnux)
        ENDIF

!  mass-weighted
       vtxbar(mgs,lr,1)  = rhovt(mgs)*                                                 &
     &   (0.0911229*(1 + rnux)**1.3333333333333333*Gamma_sp(2. + rnux) +                  &
     &    5430.313059683277*(1 + rnux)*vr**0.3333333333333333*                         &
     &     Gamma_sp(2.333333333333333 + rnux) -                                           &
     &    1.0732802065650471e6*(1 + rnux)**0.6666666666666666*vr**0.6666666666666666*  &
     &     Gamma_sp(2.6666666666666667 + rnux) +                                          &
     &    8.584110982429507e7*(1 + rnux)**0.3333333333333333*vr*Gamma_sp(3 + rnux) -      &
     &    2.3303765697228556e9*vr**1.3333333333333333*                                 &
     &     Gamma_sp(3.333333333333333 + rnux))/                                           &
     &  ((1 + rnux)**2.333333333333333*Gamma_sp(1 + rnux)) 
     
        IF(infdo .ge. 1 .and. rssflg == 0) THEN ! No size-sorting, set N-weighted fall speed to mass-weighted
          vtxbar(mgs,lr,2) = vtxbar(mgs,lr,1)
        ENDIF     
      
        IF ( infdo .ge. 2 .and. rssflg == 1) THEN ! Z-weighted fall speed
        vtxbar(mgs,lr,3)  =   rhovt(mgs)*                                          &
     &  ((1. + rnux)*(0.0911229*(1 + rnux)**1.3333333333333333*Gamma_sp(3. + rnux) +  &
     &      5430.313059683277*(1 + rnux)*vr**0.3333333333333333*                   &
     &       Gamma_sp(3.3333333333333335 + rnux) -                                    &
     &      1.0732802065650471e6*(1 + rnux)**0.6666666666666666*                   &
     &       vr**0.6666666666666666*Gamma_sp(3.6666666666666665 + rnux) +             &
     &      8.5841109824295e7*(1 + rnux)**0.3333333333333333*vr*Gamma_sp(4. + rnux) - &
     &      2.3303765697228556e9*vr**1.3333333333333333*                           &
     &       Gamma_sp(4.333333333333333 + rnux)))/                                    &
     &  ((1 + rnux)**3.3333333333333335*(2 + rnux)*Gamma_sp(1 + rnux))
        
!         write(0,*) 'setvt: mgs,lzr,infdo = ',mgs,lzr,infdo
!         write(0,*) 'vt1,2,3 = ',vtxbar(mgs,lr,1),vtxbar(mgs,lr,2),vtxbar(mgs,lr,3)
        
        ELSEIF (infdo .ge. 2) THEN ! No size-sorting, set Z-weighted fall speed to mass-weighted
          vtxbar(mgs,lr,3) = vtxbar(mgs,lr,1)
        ENDIF
        
        
        ENDIF
       ENDIF ! imurain

!        IF ( rwrad*mwfac .gt. 6.0e-4  ) THEN
!          vtxbar(mgs,lr,1) = 20.1*Sqrt(100.*rwrad*mwfac)*rhovt(mgs)
!        ELSE
!          vtxbar(mgs,lr,1) = 80.0e2*rwrad*rhovt(mgs)*mwfac
!        ENDIF
!        IF ( rwrad .gt. 6.0e-4  ) THEN
!          vtxbar(mgs,lr,2) = 20.1*Sqrt(100.*rwrad)*rhovt(mgs)
!        ELSE
!          vtxbar(mgs,lr,2) = 80.0e2*rwrad*rhovt(mgs)
!        ENDIF
      ENDIF ! ipconc
      else  ! qr < qrmin
      vtxbar(mgs,lr,1) = 0.0
      vtxbar(mgs,lr,2) = 0.0
      end if
      end do
      if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set rain vt'
      
      ENDIF
!
! ################################################################
!
!  SNOW !Zrnic et al. (1993)
!
      IF ( ls .gt. 1 .and. ( ildo == 0 .or. ildo == ls ) ) THEN
      do mgs = 1,ngscnt
      if ( qx(mgs,ls) .gt. qxmin(ls) ) then
        IF ( ipconc .ge. 4 ) THEN
         if ( mixedphase .and. qsvtmod ) then
         else
          IF ( isnowfall == 1 ) THEN
           ! original (Zrnic et al. 1993)
           vtxbar(mgs,ls,1) = 5.72462*rhovt(mgs)*(xv(mgs,ls))**(1./12.)
          ELSEIF ( isnowfall == 2 ) THEN
          ! Ferrier:
            IF ( isnowdens == 1 ) THEN
              vtxbar(mgs,ls,1) = 11.9495*rhovt(mgs)*(xv(mgs,ls))**(0.14)
            ELSE
              vtxbar(mgs,ls,1) = 11.9495*rhovt(mgs)*(xv(mgs,ls)*xdn(mgs,ls)/100.)**(0.14) 
            ENDIF
          ELSEIF ( isnowfall == 3 ) THEN
          ! Cox, mass distrib:
            vtxbar(mgs,ls,1) = 50.092*rhovt(mgs)*(xmas(mgs,ls))**(0.2635)
          ENDIF
          
          IF(Abs(sssflg) >= 1) THEN
            IF ( isnowfall == 1 ) THEN
              vtxbar(mgs,ls,2) = 4.04091*rhovt(mgs)*(xv(mgs,ls))**(1./12.)
            ELSEIF ( isnowfall == 2 ) THEN
            ! Ferrier:
              IF ( isnowdens == 1 ) THEN
                vtxbar(mgs,ls,2) = 7.02909*rhovt(mgs)*(xv(mgs,ls))**(0.14)  ! bug fix 11/15/2015: was rewriting to mass fall speed vtxbar(mgs,ls,1)
              ELSE
                vtxbar(mgs,ls,2) = 7.02909*rhovt(mgs)*(xv(mgs,ls)*xdn(mgs,ls)/100.)**(0.14)  ! bug fix 11/15/2015: was rewriting to mass fall speed vtxbar(mgs,ls,1)
              ENDIF
            ELSEIF ( isnowfall == 3 ) THEN
            ! Cox, mass distrib:
              vtxbar(mgs,ls,2) = 21.6147*rhovt(mgs)*(xmas(mgs,ls))**(0.2635)
            ENDIF
          ELSE
            vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1)
          ENDIF
           IF ( infdo  >= 2 ) THEN
            IF ( isnowfall == 1 ) THEN
             vtxbar(mgs,ls,3) = 6.12217*rhovt(mgs)*(xv(mgs,ls))**(1./12.) ! Zrnic et al 93
            ELSEIF ( isnowfall == 2 ) THEN
             vtxbar(mgs,ls,3) = 13.3436*rhovt(mgs)*(xv(mgs,ls))**(0.14)   ! Ferrier 94
            ELSEIF ( isnowfall == 3 ) THEN
            ! Cox, mass distrib:
              vtxbar(mgs,ls,3) = 61.0914*rhovt(mgs)*(xmas(mgs,ls))**(0.2635)
            ENDIF
           ENDIF
         
         IF ( sssflg < 0 .and. temcg(mgs) > Abs(sssflg) ) THEN ! above a given temperature, effectively turn off size sorting
            vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1)
            vtxbar(mgs,ls,3) = vtxbar(mgs,ls,1)
         ENDIF
         
         endif
        ELSE ! single-moment:
         vtxbar(mgs,ls,1) = (cs*gf4ds/6.0)*(xdia(mgs,ls,1)**ds)*rhovt(mgs)
         vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1)
        ENDIF
      else
      vtxbar(mgs,ls,1) = 0.0
      end if

      IF ( snowfallfac /= 1.0 ) THEN
        vtxbar(mgs,ls,1) = snowfallfac*vtxbar(mgs,ls,1)
        vtxbar(mgs,ls,2) = snowfallfac*vtxbar(mgs,ls,2)
        vtxbar(mgs,ls,3) = snowfallfac*vtxbar(mgs,ls,3)
      ENDIF


      end do
      if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set snow vt'
      
      ENDIF ! ls .gt. 1
!
!
! ################################################################
!
!  GRAUPEL !Wisner et al. (1972)
!
      IF ( lh .gt. 1 .and. ( ildo == 0 .or. ildo == lh ) ) THEN
      
      do mgs = 1,ngscnt
      vtxbar(mgs,lh,1) = 0.0
      if ( qx(mgs,lh) .gt. qxmin(lh) ) then
         cd = cdx(lh)
        IF ( icdx .eq. 1 ) THEN
         cd = cdx(lh)
       ELSEIF ( icdx .eq. 2 ) THEN
!         cd = Max(0.6, Min(1.0, 0.6 + 0.4*(xdnmx(lh) - xdn(mgs,lh))/(xdnmx(lh)-xdnmn(lh)) ) )
!         cd = Max(0.6, Min(1.0, 0.6 + 0.4*(900.0 - xdn(mgs,lh))/(900. - 300.) ) )
         cd = Max(0.45, Min(1.0, 0.45 + 0.35*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 500.) ) )
!         cd = Max(0.55, Min(1.0, 0.55 + 0.25*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 500.) ) )
       ELSEIF ( icdx .eq. 3 ) THEN
!         cd = Max(0.45, Min(1.0, 0.45 + 0.55*(800.0 - Max( 300., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 300.) ) )
         cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) )
       ELSEIF ( icdx .eq. 4 ) THEN
         cd = Max(cdhmin, Min(cdhmax, cdhmin + (cdhmax-cdhmin)* &
     &        (cdhdnmax - Max( cdhdnmin, Min( cdhdnmax, xdn(mgs,lh) ) ) )/(cdhdnmax - cdhdnmin) ) )
       ELSEIF ( icdx .eq. 5 ) THEN
         cd = cdx(lh)*(xdn(mgs,lh)/rho_qh)**(2./3.)
       ELSEIF ( icdx .eq. 6 ) THEN ! Milbrandt and Morrison (2013)
         indxr = Int( (xdn(mgs,lh)-50.)/100. ) + 1
         indxr = Min( ngdnmm, Max(1,indxr) )
         
         
         delrho = Max( 0.0, 0.01*(xdn(mgs,lh) - mmgraupvt(indxr,1)) )
         IF ( indxr < ngdnmm ) THEN
          
          axx(mgs,lh) = mmgraupvt(indxr,2) + delrho*(mmgraupvt(indxr+1,2) - mmgraupvt(indxr,2) )
          bxx(mgs,lh) = mmgraupvt(indxr,3) + delrho*(mmgraupvt(indxr+1,3) - mmgraupvt(indxr,3) )

          
         ELSE
          axx(mgs,lh) = mmgraupvt(indxr,2)
          bxx(mgs,lh) = mmgraupvt(indxr,3)
         ENDIF
         
         aax = axx(mgs,lh)
         bbx = bxx(mgs,lh)

         cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) )
         
       ELSEIF ( icdx <= 0 ) THEN ! 
         aax = ax(lh)
         bbx = bx(lh)
          cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) )
       ELSE
         cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) )
       ENDIF
       
       cdxgs(mgs,lh) = cd
      IF ( alpha(mgs,lh) .eq. 0.0 .and. icdx > 0 .and. icdx /= 6 ) THEN
!      axx(mgs,lh) =  (gf4p5/6.0)*  &
!     &  Sqrt( (xdn(mgs,lh)*4.0*gr) /  &
!     &    (3.0*cd*rho0(mgs)) )
      axx(mgs,lh) = Sqrt(4.0*xdn(mgs,lh)*gr/(3.0*cd*rho00))
      bxx(mgs,lh) = 0.5
      vtxbar(mgs,lh,1) = (gf4p5/6.0)* rhovt(mgs)*axx(mgs,lh) * Sqrt(xdia(mgs,lh,1)) 
!      vtxbar(mgs,lh,1) = (gf4p5/6.0)*  &
!     &  Sqrt( (xdn(mgs,lh)*xdia(mgs,lh,1)*4.0*gr) /  &
!     &    (3.0*cd*rho0(mgs)) )
      ELSE
        IF ( icdx /= 6 ) bbx = bx(lh)
        tmp = 4. + alpha(mgs,lh) + bbx
        i = Int(dgami*(tmp))
        del = tmp - dgam*i
        x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami

        tmp = 4. + alpha(mgs,lh)
        i = Int(dgami*(tmp))
        del = tmp - dgam*i
        y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
        
!        aax = Max( 1.0, Min(2.0, (xdn(mgs,lh)/400.) ) )
!        vtxbar(mgs,lh,1) =  rhovt(mgs)*aax*ax(lh)*(xdia(mgs,lh,1)**bx(lh)*x)/y
        
        IF ( icdx > 0 .and. icdx /= 6) THEN
          aax = Sqrt(4.0*xdn(mgs,lh)*gr/(3.0*cd*rho00))
          vtxbar(mgs,lh,1) =  rhovt(mgs)*aax* Sqrt(xdia(mgs,lh,1)) * x/y
          axx(mgs,lh) = aax
          bxx(mgs,lh) = bbx
        ELSEIF (icdx == 6 ) THEN
          vtxbar(mgs,lh,1) =  rhovt(mgs)*aax* xdia(mgs,lh,1)**bbx * x/y
        ELSE ! icdx < 0
          axx(mgs,lh) = ax(lh)
          bxx(mgs,lh) = bx(lh)
          vtxbar(mgs,lh,1) =  rhovt(mgs)*ax(lh)*(xdia(mgs,lh,1)**bx(lh)*x)/y          
        ENDIF

!     &    Gamma_sp(4.0 + dnu(lh) + 0.6))/Gamma_sp(4. + dnu(lh))
      ENDIF

      IF ( lwsm6 .and. ipconc == 0 ) THEN
!         vtxbar(mgs,lh,1) = (330.*gf4ds/6.0)*(xdia(mgs,ls,1)**ds)*rhovt(mgs)
         vtxbar(mgs,lh,1) = (330.*gf4br/6.0)*(xdia(mgs,lh,1)**br)*rhovt(mgs)
      ENDIF
      
      end if
      end do
      if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt'
      
      ENDIF ! lh .gt. 1
!
!
! ################################################################
!
!  HAIL
!
      IF ( lhl .gt. 1 .and. ( ildo == 0 .or. ildo == lhl ) ) THEN
      
      do mgs = 1,ngscnt
      vtxbar(mgs,lhl,1) = 0.0
      if ( qx(mgs,lhl) .gt. qxmin(lhl) ) then

       IF ( icdxhl .eq. 1 ) THEN
         cd = cdx(lhl)
       ELSEIF ( icdxhl .eq. 3 ) THEN
!         cd = Max(0.45, Min(1.0, 0.45 + 0.55*(800.0 - Max( 300., Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 300.) ) )
         cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hldnmn, Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 170.0) ) )
       ELSEIF ( icdxhl .eq. 4 ) THEN
         cd = Max(cdhlmin, Min(cdhlmax, cdhlmin + (cdhlmax-cdhlmin)*  &
     &       (cdhldnmax - Max( cdhldnmin, Min( cdhldnmax, xdn(mgs,lhl) ) ) )/(cdhldnmax - cdhldnmin) ) )
       ELSEIF ( icdxhl .eq. 5 ) THEN
         cd = cdx(lh)*(xdn(mgs,lhl)/rho_qh)**(2./3.)
       ELSEIF ( icdxhl .eq. 6 ) THEN ! Milbrandt and Morrison (2013)
         indxr = Int( (xdn(mgs,lhl)-50.)/100. ) + 1
         indxr = Min( ngdnmm, Max(1,indxr) )
         
         
         delrho = Max( 0.0, 0.01*(xdn(mgs,lhl) - mmgraupvt(indxr,1)) )
         IF ( indxr < ngdnmm ) THEN
          
          axx(mgs,lhl) = mmgraupvt(indxr,2) + delrho*(mmgraupvt(indxr+1,2) - mmgraupvt(indxr,2) )
          bxx(mgs,lhl) = mmgraupvt(indxr,3) + delrho*(mmgraupvt(indxr+1,3) - mmgraupvt(indxr,3) )

          
         ELSE
          axx(mgs,lhl) = mmgraupvt(indxr,2)
          bxx(mgs,lhl) = mmgraupvt(indxr,3)
         ENDIF
         
         aax = axx(mgs,lhl)
         bbx = bxx(mgs,lhl)

         cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hldnmn, Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 170.0) ) )
         
       ELSE
!         cd = Max(0.6, Min(1.0, 0.6 + 0.4*(900.0 - xdn(mgs,lhl))/(900. - 300.) ) )
!        cd = Max(0.5, Min(0.8, 0.5 + 0.3*(xdnmx(lhl) - xdn(mgs,lhl))/(xdnmx(lhl)-xdnmn(lhl)) ) )
!         cd = Max(0.45, Min(0.6, 0.45 + 0.15*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 500.) ) )
         cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hldnmn, Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 170.0) ) )
       ENDIF

       cdxgs(mgs,lhl) = cd

      IF ( alpha(mgs,lhl) .eq. 0.0 .and. icdxhl > 0 .and. icdxhl /= 6) THEN
!      axx(mgs,lhl) =  (gf4p5/6.0)*  &
!     &  Sqrt( (xdn(mgs,lhl)*4.0*gr) /  &
!     &    (3.0*cd*rho0(mgs)) )
      axx(mgs,lhl) = Sqrt(4.0*xdn(mgs,lhl)*gr/(3.0*cd*rho00))
      bxx(mgs,lhl) = 0.5
      vtxbar(mgs,lhl,1) = (gf4p5/6.0)* rhovt(mgs)*axx(mgs,lhl) * Sqrt(xdia(mgs,lhl,1)) 
      ELSE
        IF ( icdxhl /= 6 ) bbx = bx(lhl)
        tmp = 4. + alpha(mgs,lhl) + bbx
        i = Int(dgami*(tmp))
        del = tmp - dgam*i
        x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami

        tmp = 4. + alpha(mgs,lhl)
        i = Int(dgami*(tmp))
        del = tmp - dgam*i
        y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami

        IF ( icdxhl > 0 .and. icdxhl /= 6) THEN
          aax = Sqrt(4.0*xdn(mgs,lhl)*gr/(3.0*cd*rho00))
          vtxbar(mgs,lhl,1) =  rhovt(mgs)*aax* Sqrt(xdia(mgs,lhl,1)) * x/y
          axx(mgs,lhl) = aax
          bxx(mgs,lhl) = bbx
        ELSEIF ( icdxhl == 6 ) THEN
          vtxbar(mgs,lhl,1) =  rhovt(mgs)*aax* (xdia(mgs,lhl,1))**bbx * x/y
        ELSE
          axx(mgs,lhl) = ax(lhl)
          bxx(mgs,lhl) = bx(lhl)
         vtxbar(mgs,lhl,1) =  rhovt(mgs)*(ax(lhl)*xdia(mgs,lhl,1)**bx(lhl)*x)/y
        ENDIF
        
!     &    Gamma_sp(4.0 + dnu(lh) + 0.6))/Gamma_sp(4. + dnu(lh))
      ENDIF


      end if
      end do
      if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt'
      
      ENDIF ! lhl .gt. 1


      IF ( infdo .ge. 1 ) THEN

!      DO il = lc,lhab
!      IF ( il .ne. lr ) THEN
        DO mgs = 1,ngscnt
          vtxbar(mgs,lc,2) = vtxbar(mgs,lc,1)
        IF ( li .gt. 1 ) THEN
!          vtxbar(mgs,li,2) = rhovt(mgs)*49420.*1.25447*xdia(mgs,li,1)**(1.415) ! n-wgt (Ferrier 94)
!          vtxbar(mgs,li,2) = vtxbar(mgs,li,1)

! test print stuff...
!          IF ( xdia(mgs,li,1) .gt. 200.e-6 ) THEN
!            tmp = (xv(mgs,li)*cwc0)**(1./3.)
!            x = rhovt(mgs)*49420.*40.0005/5.40662*tmp**(1.415)
!            y = rhovt(mgs)*49420.*1.25447*tmp**(1.415)
!            write(6,*) 'Ice fall: ',vtxbar(mgs,li,1),x,y,tmp,xdia(mgs,li,1)
!          ENDIF
        ENDIF
!          vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1)
        ENDDO

        IF ( lg .gt. lr ) THEN

        DO il = lg,lhab
         IF ( ildo == 0 .or. ildo == il ) THEN

            DO mgs = 1,ngscnt
             IF ( qx(mgs,il) .gt. qxmin(il) ) THEN
              IF ( (il .eq. lh .and. hssflg == 1) .or. ( lhl .gt. 1 .and. il .eq. lhl .and. hlssflg == 1) ) THEN ! DTD: added flag for size-sorting
              
              ! DTD: allow for setting of number-weighted and z-weighted fall speeds to the mass-weighted value,
              ! effectively turning off size-sorting

              IF ( il .eq. lh ) THEN ! {
             
               IF ( icdx .eq. 1 ) THEN
                 cd = cdx(lh)
               ELSEIF ( icdx .eq. 2 ) THEN
!                 cd = Max(0.6, Min(1.0, 0.6 + 0.4*(xdnmx(lh) - xdn(mgs,lh))/(xdnmx(lh)-xdnmn(lh)) ) )
!                 cd = Max(0.6, Min(1.0, 0.6 + 0.4*(900.0 - xdn(mgs,lh))/(900. - 300.) ) )
                 cd = Max(0.45, Min(1.0, 0.45 + 0.35*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 500.) ) )
!                 cd = Max(0.55, Min(1.0, 0.55 + 0.25*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 500.) ) )
               ELSEIF ( icdx .eq. 3 ) THEN
!                 cd = Max(0.45, Min(1.0, 0.45 + 0.55*(800.0 - Max( 170.0, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) )
                 cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) )
               ELSEIF ( icdx .eq. 4 ) THEN
                 cd = Max(cdhmin, Min(cdhmax, cdhmin + (cdhmax-cdhmin)* &
     &            (cdhdnmax - Max( cdhdnmin, Min( cdhdnmax, xdn(mgs,lh) ) ) )/(cdhdnmax - cdhdnmin) ) )
               ELSEIF ( icdx .eq. 5 ) THEN
                 cd = cdx(lh)*(xdn(mgs,lh)/rho_qh)**(2./3.)
               ELSEIF ( icdx .eq. 6 ) THEN ! Milbrandt and Morrison (2013)
                  aax = axx(mgs,lh)
                  bbx = bxx(mgs,lh)
               ELSEIF ( icdx <= 0 ) THEN ! 
                  aax = ax(lh)
                  bbx = bx(lh)
               ENDIF
               
              ELSEIF ( lhl .gt. 1 .and. il .eq. lhl ) THEN
             
               IF ( icdxhl .eq. 1 ) THEN
                 cd = cdx(lhl)
               ELSEIF ( icdxhl .eq. 3 ) THEN
!               cd = Max(0.45, Min(1.0, 0.45 + 0.55*(800.0 - Max( 300., Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 300.) ) )
                cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hldnmn, Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 170.0) ) )
               ELSEIF ( icdxhl .eq. 4 ) THEN
                cd = Max(cdhlmin, Min(cdhlmax, cdhlmin + (cdhlmax-cdhlmin)*  &
     &               (cdhldnmax - Max( cdhldnmin, Min( cdhldnmax, xdn(mgs,lhl) ) ) )/(cdhldnmax - cdhldnmin) ) )
               ELSEIF ( icdxhl == 5 ) THEN
!                cd = Max(0.6, Min(1.0, 0.6 + 0.4*(900.0 - xdn(mgs,lhl))/(900. - 300.) ) )
!                cd = Max(0.5, Min(0.8, 0.5 + 0.3*(xdnmx(lhl) - xdn(mgs,lhl))/(xdnmx(lhl)-xdnmn(lhl)) ) )
                 cd = Max(0.45, Min(0.6, 0.45 + 0.15*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 500.) ) )
               ELSEIF ( icdxhl .eq. 6 ) THEN ! Milbrandt and Morrison (2013)
                  aax = axx(mgs,lhl)
                  bbx = bxx(mgs,lhl)
               ENDIF
               
              ENDIF ! }

               IF ( alpha(mgs,il) .eq. 0. .and. infdo .lt. 2 .and.   &
               ( ( il==lh .and. icdx > 0 .and. icdx /= 6) .or. ( il==lhl .and. icdxhl > 0 .and. icdxhl /= 6 ) ) ) THEN ! {
                 vtxbar(mgs,il,2) =   &
     &              Sqrt( (xdn(mgs,il)*xdia(mgs,il,1)*pi*gr) / &
     &                (3.0*cd*Max(0.05,rho0(mgs))) )

               ELSE
               IF ( il == lh  .and. icdx   /= 6 ) bbx = bx(il)
               IF ( il == lhl .and. icdxhl /= 6 ) bbx = bx(il)
               tmp = 1. + alpha(mgs,il) + bbx
               i = Int(dgami*(tmp))
               del = tmp - dgam*i
               x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
  
               tmp = 1. + alpha(mgs,il)
               i = Int(dgami*(tmp))
               del = tmp - dgam*i
               y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami

                 IF ( il .eq. lh  .or. il .eq. lhl) THEN ! {
                   IF ( ( il==lh .and. icdx > 0 ) ) THEN
                     IF ( icdx /= 6 ) THEN
                      aax = Sqrt(4.0*xdn(mgs,il)*gr/(3.0*cd*rho00))
                      vtxbar(mgs,il,2) =  rhovt(mgs)*aax* xdia(mgs,il,1)**bx(il) * x/y
                     ELSE !  (icdx == 6 ) THEN
                       vtxbar(mgs,il,2) =  rhovt(mgs)*aax* xdia(mgs,il,1)**bbx * x/y
                     ENDIF

                   ELSEIF ( ( il==lhl .and. icdxhl > 0 ) ) THEN
                     IF ( icdxhl /= 6 ) THEN
                       aax = Sqrt(4.0*xdn(mgs,il)*gr/(3.0*cd*rho00))
                       vtxbar(mgs,il,2) =  rhovt(mgs)*aax* xdia(mgs,il,1)**bx(il) * x/y
                     ELSE ! ( icdxhl == 6 )
                       vtxbar(mgs,il,2) =  rhovt(mgs)*aax* xdia(mgs,il,1)**bbx * x/y
                     ENDIF
                   ELSE ! get here if il==lh and icdx < 0 -- or -- il==lhl and icdxhl < 0
                     aax = ax(il)
                     vtxbar(mgs,il,2) =  rhovt(mgs)*ax(il)*(xdia(mgs,il,1)**bx(il)*x)/y
                   ENDIF

!                  vtxbar(mgs,il,2) =  &
!     &               rhovt(mgs)*(xdn(mgs,il)/400.)*(75.715*xdia(mgs,il,1)**0.6* &
!     &               x)/y
!                  vtxbar(mgs,il,2) =  &
!     &               rhovt(mgs)*(xdn(mgs,il)/400.)*(ax(il)*xdia(mgs,il,1)**bx(il)* &
!     &               x)/y
                  IF ( infdo .ge. 2 ) THEN ! Z-weighted

               tmp = 7. + alpha(mgs,il) + bbx
               i = Int(dgami*(tmp))
               del = tmp - dgam*i
               x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
  
               tmp = 7. + alpha(mgs,il)
               i = Int(dgami*(tmp))
               del = tmp - dgam*i
               y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami

                   vtxbar(mgs,il,3) = rhovt(mgs)*                 &
     &                (aax*(xdia(mgs,il,1) )**bbx *  &
     &                 x)/y
!     &                 Gamma(7.0 + alpha(mgs,il) + bbx))/Gamma(7. + alpha(mgs,il))
          IF ( .not. (vtxbar(mgs,il,1) > -1. .and. vtxbar(mgs,il,1) < 200. ) .or. &
               .not. (vtxbar(mgs,il,3) > -1. .and. vtxbar(mgs,il,3) < 200. ) ) THEN
           write(0,*) 'Setvtz: problem with vtxbar1/3: ',il,vtxbar(mgs,il,1),vtxbar(mgs,il,3),aax,bbx,x,y
           write(0,*) 'q, number, diam1,3(mm) = ', qx(mgs,il),cx(mgs,il),1000.*xdia(mgs,il,1),1000.*xdia(mgs,il,3)
           ! call commasmpi_abort()
          ENDIF
!     &                (aax*(1.0/xdia(mgs,il,1) )**(- bx(il))*  &
!     &                 Gamma_sp(7.0 + alpha(mgs,il) + bx(il)))/Gamma_sp(7. + alpha(mgs,il))
                  ENDIF

      if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt3'

                 ELSE ! hail
                  vtxbar(mgs,il,2) =  &
     &               rhovt(mgs)*(ax(il)*xdia(mgs,il,1)**bx(il)* &
     &               x)/y

                 IF ( infdo .ge. 2 ) THEN ! Z-weighted
                  vtxbar(mgs,il,3) = rhovt(mgs)*                 &
     &              (aax*(1.0/xdia(mgs,il,1) )**(- bbx)*  &
     &               Gamma_sp(7.0 + alpha(mgs,il) + bbx))/Gamma_sp(7. + alpha(mgs,il))
!     &              (ax(il)*(1.0/xdia(mgs,il,1) )**(- bx(il))*  &
!     &               Gamma_sp(7.0 + alpha(mgs,il) + bx(il)))/Gamma_sp(7. + alpha(mgs,il))
                  ENDIF

      if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt4'

                 ENDIF ! }
!     &             Gamma_sp(1.0 + dnu(il) + 0.6)/Gamma_sp(1. + dnu(il))
               ENDIF ! }

!              IF ( infdo .ge. 2 ) THEN ! Z-weighted
!               vtxbar(mgs,il,3) = rhovt(mgs)*                 &
!     &            (ax(il)*(1.0/xdia(mgs,il,1) )**(- bx(il))*  &
!     &             Gamma_sp(7.0 + alpha(mgs,il) + bx(il)))/Gamma_sp(7. + alpha(mgs,il))
!              ENDIF

!               IF ( lhl .gt. 1 .and. il .eq. lhl ) THEN
!                write(0,*) 'setvt: ',qx(mgs,il),xdia(mgs,il,1),xdia(mgs,il,3),dnu(il),ax(il),bx(il)
!               ENDIF
             ELSEIF ( (il .eq. lh .and. hssflg == 0) .or. ( lhl .gt. 1 .and. il .eq. lhl .and. hlssflg == 0) ) THEN ! no size-sorting for graupel or hail
              vtxbar(mgs,il,2) = vtxbar(mgs,il,1)
              vtxbar(mgs,il,3) = vtxbar(mgs,il,1)
             ELSE ! not lh or lhl
              vtxbar(mgs,il,2) = &
     &            Sqrt( (xdn(mgs,il)*xdia(mgs,il,1)*pi*gr) /  &
     &              (3.0*cdx(il)*Max(0.05,rho0(mgs))) )
              vtxbar(mgs,il,3) = vtxbar(mgs,il,1)

      if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt5'


              ENDIF
             ELSE ! qx < qxmin
              vtxbar(mgs,il,2) = 0.0

      if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt6'

             ENDIF
           ENDDO ! mgs

      if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt7'

        ENDIF
        ENDDO ! il

      if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt8'

        ENDIF ! lg .gt. 1 
        
!      ENDIF
!      ENDDO

      if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt9'

!       DO mgs = 1,ngscnt
!        IF ( qx(mgs,lr) > qxmin(lr) ) THEN
!         write(0,*) 'setvt2: mgs,lzr,infdo = ',mgs,lzr,infdo
!         write(0,*) 'vt1,2,3 = ',vtxbar(mgs,lr,1),vtxbar(mgs,lr,2),vtxbar(mgs,lr,3)
!        ENDIF
!       ENDDO

      ENDIF ! infdo .ge. 1 

        IF (  lh > 0 .and. graupelfallfac /= 1.0 ) THEN
          DO mgs = 1,ngscnt
            vtxbar(mgs,lh,1) = graupelfallfac*vtxbar(mgs,lh,1)
            vtxbar(mgs,lh,2) = graupelfallfac*vtxbar(mgs,lh,2)
            vtxbar(mgs,lh,3) = graupelfallfac*vtxbar(mgs,lh,3)
            axx(mgs,lh) = graupelfallfac*axx(mgs,lh)
          ENDDO
        ENDIF

        IF ( lhl > 0 .and. hailfallfac /= 1.0 ) THEN
          DO mgs = 1,ngscnt
            vtxbar(mgs,lhl,1) = hailfallfac*vtxbar(mgs,lhl,1)
            vtxbar(mgs,lhl,2) = hailfallfac*vtxbar(mgs,lhl,2)
            vtxbar(mgs,lhl,3) = hailfallfac*vtxbar(mgs,lhl,3)
            axx(mgs,lhl) = hailfallfac*axx(mgs,lhl)
          ENDDO
        ENDIF
      
      if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: END OF ROUTINE'

!############ SETVTZ ############################

      RETURN
      END SUBROUTINE setvtz
!--------------------------------------------------------------------------

!
! ##############################################################################

!
!  subroutine to calculate fall speeds of hydrometeors
!

      subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, &
     &  xvt, rhovtzx,                                           &
     &  an,dn,ipconc0,t0,t7,cwmasn,cwmasx,       &
     &  cwradn,                                   &
     &  qxmin,xdnmx,xdnmn,cdx,cno,xdn0,xvmn,xvmx,  &
     &  ngs,qx,qxw,cx,xv,vtxbar,xmas,xdn,xdia,vx,alpha,zx,igs,kgs, &
     &  rho0,temcg,temg,rhovt,cwnc,cinc,fadvisc,cwdia,cipmas,cnina,cimas, &
     &  cnostmp,                     &
     &  infdo,ildo,timesetvt)

! 12.16.2005: .F version use in transitional SWM model
!
! 10.10.2003: Added cimn and cimx to setting for cci and cip.
!
! TO DO LIST:
!
! need to set up values for:
!     :  cipdia,cidia,cwdia,cwmas,vtwbar,
!     :  rho0,temcg,cip,cci
!
! and need to put fallspeed values in cwvt etc.
!
      
      implicit none
      integer ng1
      parameter(ng1 = 1)
      
      integer, intent(in) :: ixcol ! which column to return
      integer, intent(in) :: ildo
      
      integer nx,ny,nz,nor,norz,ngt,jgs,na
      real an(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,na)
      real dn(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor)
      real t0(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor)
      real t7(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor)
      real dtp,dtz1
      
      real :: rhovtzx(nz,nx)
      
      integer ndebugzf
      parameter (ndebugzf = 0)

      integer ix,jy,kz,i,j,k,il
      integer infdo
!
!
      real xvt(nz+1,nx,3,lc:lhab) ! 1=mass-weighted, 2=number-weighted

      real qxmin(lc:lhab)
      real xdn0(lc:lhab)
      real xvmn(lc:lhab), xvmx(lc:lhab)
      double precision,optional :: timesetvt

      integer :: ngs
      integer :: ngscnt,mgs,ipconc0
!      parameter ( ngs=200 )
      
      real ::  qx(ngs,lv:lhab) 
      real ::  qxw(ngs,ls:lhab) 
      real ::  cx(ngs,lc:lhab) 
      real ::  xv(ngs,lc:lhab) 
      real ::  vtxbar(ngs,lc:lhab,3) 
      real ::  xmas(ngs,lc:lhab) 
      real ::  xdn(ngs,lc:lhab) 
      real ::  cdxgs(ngs,lc:lhab) 
      real ::  xdia(ngs,lc:lhab,3) 
      real ::  vx(ngs,li:lhab) 
      real ::  alpha(ngs,lc:lhab) 
      real ::  zx(ngs,lr:lhab) 

      real xdnmx(lc:lhab), xdnmn(lc:lhab)
      real :: axx(ngs,lh:lhab), bxx(ngs,lh:lhab)
!      real axh(ngs),bxh(ngs),axhl(ngs),bxhl(ngs)

!
!   drag coefficients
!
      real cdx(lc:lhab)
!
! Fixed intercept values for single moment scheme
!
      real cno(lc:lhab)
      
      real cwccn0,cwmasn,cwmasx,cwradn
!      real cwc0

      integer nxmpb,nzmpb,nxz,numgs,inumgs
      integer kstag
      parameter (kstag=1)

      integer igs(ngs),kgs(ngs)
      
      real rho0(ngs),temcg(ngs)

      real temg(ngs)
      
      real rhovt(ngs)
      
      real cwnc(ngs),cinc(ngs)
      real fadvisc(ngs),cwdia(ngs),cipmas(ngs)
      
!      real cimasn,cimasx,
      real :: cnina(ngs),cimas(ngs)
      
      real :: cnostmp(ngs)

!      real pii
!
!
!  general constants for microphysics
!

! 
! Miscellaneous
!
      
      logical flag
      logical ldoliq
      
    
      real chw, qr, z, rd, alp, z1, g1, vr, nrx, tmp
      
      real vtmax
      real xvbarmax
      
      integer l1, l2
      
      double precision :: dpt1, dpt2


!-----------------------------------------------------------------------------
! MPI LOCAL VARIABLES 

      integer :: ixb, jyb, kzb
      integer :: ixe, jye, kze

      logical :: debug_mpi = .false.


      if (ndebugzf .gt. 0 ) write(0,*) "ZIEGFALL: ENTERED SUBROUTINE"

! #####################################################################
! BEGIN EXECUTABLE
! #####################################################################
!

!  constants
!

      ldoliq = .false.
      IF ( ls .gt. 1 ) THEN
      DO il = ls,lhab
        ldoliq = ldoliq .or. ( lliq(il) .gt. 1 )
      ENDDO
      ENDIF
      
!      poo = 1.0e+05
!      cp608 = 0.608
!      cp = 1004.0
!      cv = 717.0
!      dnz00 = 1.225
!      rho00 = 1.225
!      cs = 4.83607122
!      ds = 0.25
!  new values for  cs and ds
!      cs = 12.42
!      ds = 0.42
!      pi = 4.0*atan(1.0)
!      pii = piinv ! 1./pi
!      pid4 = pi/4.0 
!      qccrit = 2.0e-03
!      qscrit = 6.0e-04
!      cwc0 = pii
      
!
!
!  general constants for microphysics
!
      
!
!  ci constants in mks units
!
!      cimasn = 6.88e-13 
!      cimasx = 1.0e-8
!
!  Set terminal velocities...
!    also set drag coefficients
!
      jy = jgs
      nxmpb = ixcol
      nzmpb = 1
      nxz = 1*nz
!      ngs = nz
      numgs = 1

      IF ( ildo == 0 ) THEN
        l1 = lc
        l2 = lhab
      ELSE
        l1 = ildo
        l2 = ildo
      ENDIF


      do inumgs = 1,numgs
       ngscnt = 0


       do kz = nzmpb,nz
        do ix = ixcol,ixcol
        flag = .false.

        
        DO il = l1,l2
          flag =  flag .or. ( an(ix,jy,kz,il)  .gt. qxmin(il) ) 
        ENDDO

        if ( flag ) then
! load temp quantities

        ngscnt = ngscnt + 1
        igs(ngscnt) = ix
        kgs(ngscnt) = kz
        if ( ngscnt .eq. ngs ) goto 1100
        end if
        end do !!ix
        nxmpb = 1
       end do !! kz

!      if ( jy .eq. (ny-jstag) ) iend = 1

 1100 continue

      if ( ngscnt .eq. 0 ) go to 9998
!
!  set temporaries for microphysics variables
!


!
!  Reconstruct various quantities 
!
      do mgs = 1,ngscnt

       rho0(mgs) = dn(igs(mgs),jy,kgs(mgs))
       rhovt(mgs) = rhovtzx(kgs(mgs),ixcol) !  Sqrt(rho00/rho0(mgs))
       temg(mgs) = t0(igs(mgs),jy,kgs(mgs))
       temcg(mgs) = temg(mgs) - tfr

        
!
      end do
!
! only need fadvisc for 
      IF ( lc .gt. 1 .and. (ildo == 0 .or. ildo == lc ) ) then
        do mgs = 1,ngscnt
         fadvisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))* &
     &   (temg(mgs)/296.0)**(1.5)
        end do
      ENDIF

      IF ( ipconc .eq. 0 ) THEN
      do mgs = 1,ngscnt
      cnina(mgs) = t7(igs(mgs),jgs,kgs(mgs))
      end do
      ENDIF


      IF ( ildo > 0 ) THEN
        vtxbar(:,ildo,:) = 0.0
      ELSE
        vtxbar(:,:,:) = 0.0
      ENDIF
      
!      do mgs = 1,ngscnt
!        qx(mgs,lv) = max(an(igs(mgs),jy,kgs(mgs),lv), 0.0) 
!      ENDDO
      DO il = l1,l2
      do mgs = 1,ngscnt
        qx(mgs,il) = max(an(igs(mgs),jy,kgs(mgs),il), 0.0) 
      ENDDO
      end do
      
      cnostmp(:) = cno(ls)
      IF ( ipconc < 1 .and. lwsm6 .and. (ildo == 0 .or. ildo == ls )) THEN
        DO mgs = 1,ngscnt
          tmp = Min( 0.0, temcg(mgs) )
          cnostmp(mgs) = Min( 2.e8, 2.e6*exp(0.12*tmp) )
        ENDDO
      ENDIF


!
!  set concentrations
!
      cx(:,:) = 0.0
      
      if ( ipconc .ge. 1 .and. li .gt. 1 .and. (ildo == 0 .or. ildo == li ) ) then
       do mgs = 1,ngscnt
        cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0)
       end do
      end if
      if ( ipconc .ge. 2 .and. lc .gt. 1 .and. (ildo == 0 .or. ildo == lc ) ) then
       do mgs = 1,ngscnt
        cx(mgs,lc) = Max(an(igs(mgs),jy,kgs(mgs),lnc), 0.0)
!        cx(mgs,lc) = Min( ccwmx, cx(mgs,lc) )
       end do
      end if
      if ( ipconc .ge. 3 .and. lr .gt. 1 .and. (ildo == 0 .or. ildo == lr ) ) then
       do mgs = 1,ngscnt
        cx(mgs,lr) = Max(an(igs(mgs),jy,kgs(mgs),lnr), 0.0)
!        IF ( qx(mgs,lr) .le. qxmin(lr) ) THEN
!        ELSE
!          cx(mgs,lr) = Max( 0.0, cx(mgs,lr) )
!        ENDIF
       end do
      end if
      if ( ipconc .ge. 4  .and. ls .gt. 1 .and. (ildo == 0 .or. ildo == ls ) ) then
       do mgs = 1,ngscnt
        cx(mgs,ls) = Max(an(igs(mgs),jy,kgs(mgs),lns), 0.0)
!        IF ( qx(mgs,ls) .le. qxmin(ls) ) THEN
!        ELSE
!          cx(mgs,ls) = Max( 0.0, cx(mgs,ls) )
!        ENDIF
       end do
      end if

      if ( ipconc .ge. 5  .and. lh .gt. 1 .and. (ildo == 0 .or. ildo == lh ) ) then
       do mgs = 1,ngscnt

        cx(mgs,lh) = Max(an(igs(mgs),jy,kgs(mgs),lnh), 0.0)
!        IF ( qx(mgs,lh) .le. qxmin(lh) ) THEN
!        ELSE
!          cx(mgs,lh) = Max( 0.0, cx(mgs,lh) )
!        ENDIF

       end do
      ENDIF

      if ( ipconc .ge. 5  .and. lhl .gt. 1 .and. (ildo == 0 .or. ildo == lhl ) ) then
       do mgs = 1,ngscnt

        cx(mgs,lhl) = Max(an(igs(mgs),jy,kgs(mgs),lnhl), 0.0)
!        IF ( qx(mgs,lhl) .le. qxmin(lhl) ) THEN
!          cx(mgs,lhl) = 0.0
!        ELSEIF ( cx(mgs,lhl) .eq. 0.0 .and. qx(mgs,lhl) .lt. 3.0*qxmin(lhl) ) THEN
!          qx(mgs,lhl) = 0.0
!        ELSE
!          cx(mgs,lhl) = Max( 0.0, cx(mgs,lhl) )
!        ENDIF

       end do
      end if
       
      do mgs = 1,ngscnt
        xdn(mgs,lc) = xdn0(lc)
        xdn(mgs,lr) = xdn0(lr)
!        IF ( ls .gt. 1 .and. lvs .eq. 0 ) xdn(mgs,ls) = xdn0(ls)
!        IF ( lh .gt. 1 .and. lvh .eq. 0 ) xdn(mgs,lh) = xdn0(lh)
        IF ( li .gt. 1 )  xdn(mgs,li) = xdn0(li)
        IF ( ls .gt. 1 )  xdn(mgs,ls) = xdn0(ls)
        IF ( lh .gt. 1 )  xdn(mgs,lh) = xdn0(lh)
        IF ( lhl .gt. 1 ) xdn(mgs,lhl) = xdn0(lhl)
      end do

!
! Set mean particle volume
!
      IF ( ldovol .and. (ildo == 0 .or. ildo >= li ) ) THEN
      
      vx(:,:) = 0.0
      
       DO il = l1,l2
        
        IF ( lvol(il) .ge. 1 ) THEN
        
          DO mgs = 1,ngscnt
            vx(mgs,il) = Max(an(igs(mgs),jy,kgs(mgs),lvol(il)), 0.0)
            IF ( vx(mgs,il) .gt. rho0(mgs)*qxmin(il)*1.e-3 .and. qx(mgs,il) .gt. qxmin(il) ) THEN
              xdn(mgs,il) = Min( xdnmx(il), Max( xdnmn(il), rho0(mgs)*qx(mgs,il)/vx(mgs,il) ) )
            ENDIF
          ENDDO
          
        ENDIF
      
       ENDDO
      
      ENDIF

      DO il = lg,lhab
      DO mgs = 1,ngscnt
        alpha(mgs,il) = dnu(il)
      ENDDO
      ENDDO
      
      IF ( imurain == 1 ) THEN
        alpha(:,lr) = alphar
      ELSEIF ( imurain == 3 ) THEN
        alpha(:,lr) = xnu(lr)
      ENDIF
       






!
!  Set density
!
      if (ndebugzf .gt. 0 ) write(0,*)  'ZIEGFALL: call setvtz'
!
      
      call setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp,   &
     &                 xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx,cdxgs,        &
     &                 ipconc,ndebugzf,ngs,nz,kgs,fadvisc, &
     &                 cwmasn,cwmasx,cwradn,cnina,cimn,cimx,    &
     &                 itype1,itype2,temcg,infdo,alpha,ildo,axx,bxx)
!     &                 itype1,itype2,temcg,infdo,alpha,ildo,axh,bxh,axhl,bxhl)



!
! put fall speeds into the x-z arrays
!
      DO il = l1,l2
      do mgs = 1,ngscnt
       
       vtmax = 150.0

       
       IF ( vtxbar(mgs,il,2) .gt. vtxbar(mgs,il,1)  .or. &
     &      ( vtxbar(mgs,il,1) .gt. vtxbar(mgs,il,3) .and. vtxbar(mgs,il,3) > 0.0) ) THEN
          
          
          
          vtxbar(mgs,il,1) = Max( vtxbar(mgs,il,1), vtxbar(mgs,il,2) )
          vtxbar(mgs,il,3) = Max( vtxbar(mgs,il,3), vtxbar(mgs,il,1) )
          
       ENDIF

       
       IF ( vtxbar(mgs,il,1) .gt. vtmax .or. vtxbar(mgs,il,2) .gt. vtmax .or. &
     &      vtxbar(mgs,il,3) .gt. vtmax ) THEN
       
        vtxbar(mgs,il,1) = Min(vtmax,vtxbar(mgs,il,1) )
        vtxbar(mgs,il,2) = Min(vtmax,vtxbar(mgs,il,2) )
        vtxbar(mgs,il,3) = Min(vtmax,vtxbar(mgs,il,3) )
        
!        call commasmpi_abort()
       ENDIF


       xvt(kgs(mgs),igs(mgs),1,il) = vtxbar(mgs,il,1)
       xvt(kgs(mgs),igs(mgs),2,il) = vtxbar(mgs,il,2)
       IF ( infdo .ge. 2 ) THEN
       xvt(kgs(mgs),igs(mgs),3,il) = vtxbar(mgs,il,3)
       ELSE
       xvt(kgs(mgs),igs(mgs),3,il) = 0.0
       ENDIF

!       xvt(kgs(mgs),igs(mgs),2,il) = xvt(kgs(mgs),igs(mgs),1,il)

      enddo
      ENDDO


      if (ndebugzf .gt. 0 ) write(0,*)  'ZIEGFALL: COPIED FALL SPEEDS'



 9998 continue

      if (ndebugzf .gt. 0 ) write(0,*)  'ZIEGFALL: DONE WITH LOOP'

      if ( kz .gt. nz-1 ) then
        go to 1200
      else
        nzmpb = kz 
      end if

      if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: SET NZMPB'

      end do !! inumgs

      if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: SET NXMPB'

 1200 continue


!       ENDDO ! ix
!      ENDDO ! kz


      if (ndebugzf .gt. 0 ) write(0,*) "ZIEGFALL: EXITING SUBROUTINE"


      RETURN
      END subroutine ziegfall1d

! #####################################################################
! #####################################################################


! #####################################################################
! #####################################################################

! ##############################################################################
      subroutine radardd02(nx,ny,nz,nor,na,an,temk,         &
     &    dbz,db,nzdbz,cnoh0t,hwdn1t,ipconc,ke_diag, iunit)
!
! 11.13.2005: Changed values of indices for reordering of lip
!
! 07.13.2005: Fixed an error where cnoh was being used for graupel and frozen drops
!
! 01.24.2005: add ice crystal reflectivity using parameterization of
!             Heymsfield (JAS, 1977).  Could also try Ferrier for this, too.
!
!  09.28.2002 Test alterations for dry ice following Ferrier (1994)
!      for equivalent melted diameter reflectivity.
!      Converted to Fortran by ERM.
!      
!Date: Tue, 21 Nov 2000 10:13:36 -0600 (CST)
!From: Matthew Gilmore <gilmore@hesston.met.tamu.edu>
!
!PRO RF_SPEC ; Computes Radar Reflectivity
!COMMON MAINB, data, x1d, y1d, z1d, iconst, rconst, labels, nx, ny, nz, dshft
!
!;MODIFICATION HISTORY
!; 5/99  -Svelta Veleva introduces variable dielf (const_ki_x) as a (weak)
!;   function of density.  This leads to slight modification of dielf such
!;   that the snow reflectivity is slightly increased - not a big effect.
!;   This is believed to be more accurate than assuming the dielectric
!;   constant for snow is the same as for hail in previous versions.
!
!;On 6/13/99 I added the VIL computation (k=0 in vil array)
!;On 6/15/99 I removed the number concentration dependencies as a function
!;           of temperature (only use for ferrier!)
!;On 6/15/99 I added the Composite reflectivity (k=1 in VIL array)
!;On 6/15/99 I added the Severe Hail Index computation (k=2 in vil array)
!;
!; 6/99 - Veleva and Seo argue that since graupel is more similar to
!;   snow (in number conc and size density) than it is to hail, we
!;   should not weight wetted graupel with the .95 exponent correction
!;   factor as in the case of hail.  An if-statement checks the size
!;   density for wet hail/graupel and treats them appropriately.
!;
!; 6/22/99 - Added function to compute height of max rf and 40 dbz echo top
!;           Also added vilqr which is the model vertical integrated liquid only
!;           using qr.  Will need to check...does not seem consistent with vilZ
!;


      implicit none
      
      character(LEN=15), parameter :: microp = 'ZVD'
      integer nx,ny,nz,nor,na,ngt
      integer nzdbz    !  how many levels actually to process
      
      integer ng1,n10
      integer iunit
      integer, parameter :: printyn = 0

      parameter( ng1 = 1 )
      
      real cnoh0t,hwdn1t
      integer ke_diag
      integer ipconc
      real vr


      integer imapz,mzdist
      
      integer vzflag
      integer, parameter :: norz = 3
      real an(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,na)
      real db(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor)  ! air density
!      real gt(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,ngt)
      real temk(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor)  ! air temperature (kelvin)
      real dbz(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor)   ! reflectivity
      real gz(-nor+1:nz+nor) ! ,z1d(-nor+1:nz+nor,4)
      
!      real g,rgas,eta,inveta
      real cr1, cr2 ,  hwdnsq,swdnsq
      real rwdnsq, dhmin, qrmin, qsmin, qhmin, qhlmin, tfr, tfrh, zrc
      real reflectmin,  kw_sq
      real const_ki_sn, const_ki_h, ki_sq_sn
      real ki_sq_h, dielf_sn, dielf_h
      real pi
      logical ltest

!  Other data arrays
       real gtmp     (nx,nz)
       real dtmp     (nx,nz)
       real tmp

       real*8 dtmps, dtmpr, dtmph, dtmphl, g1, zx, ze, x

       integer i,j,k,ix,jy,kz,ihcnt

        real*8 xcnoh, xcnos, dadh, dads, zhdryc, zsdryc, zhwetc,zswetc
        real*8 dadr
        real dbzmax,dbzmin
        parameter ( dbzmin = 0 )

      real cnow,cnoi,cnoip,cnoir,cnor,cnos
      real cnogl,cnogm,cnogh,cnof,cnoh,cnohl

      real swdn, rwdn ,hwdn,gldn,gmdn,ghdn,fwdn,hldn
      real swdn0

      real rwdnmx,cwdnmx,cidnmx,xidnmx,swdnmx,gldnmx,gmdnmx
      real ghdnmx,fwdnmx,hwdnmx,hldnmx
      real rwdnmn,cwdnmn,cidnmn,xidnmn,swdnmn,gldnmn,gmdnmn
      real ghdnmn,fwdnmn,hwdnmn,hldnmn
 
      real gldnsq,gmdnsq,ghdnsq,fwdnsq,hldnsq

      real dadgl,dadgm,dadgh,dadhl,dadf
      real zgldryc,zglwetc,zgmdryc, zgmwetc,zghdryc,zghwetc
      real zhldryc,zhlwetc,zfdryc,zfwetc

      real dielf_gl,dielf_gm,dielf_gh,dielf_hl,dielf_fw
      
      integer imx,jmx,kmx
      
      real swdia,gldia,gmdia,ghdia,fwdia,hwdia,hldia
      
      real csw,cgl,cgm,cgh,cfw,chw,chl
      real xvs,xvgl,xvgm,xvgh,xvf,xvh,xvhl
      
      real cwc0
      integer izieg
      integer ice10
      real rhos
      parameter ( rhos = 0.1 )
      
      real qxw,qxw1    ! temp value for liquid water on ice mixing ratio
      real :: dnsnow
      real qh

      real, parameter :: cwmasn = 5.23e-13   ! minimum mass, defined by radius of 5.0e-6
      real, parameter :: cwmasx = 5.25e-10   ! maximum mass, defined by radius of 50.0e-6
      real, parameter :: cwradn = 5.0e-6     ! minimum radius

      real cwnccn(nz)
      
      real :: vzsnow, vzrain, vzgraupel, vzhail
      real :: ksq
      real :: dtp


! #########################################################################      

      vzflag = 0
      
      izieg = 0
      ice10 = 0
!      g=9.806                 ! g: gravity constant
!      rgas=287.04             ! rgas: gas constant for dry air
!      rcp=rgas/cp             ! rcp: gamma constant
!      eta=0.622
!      inveta = 1./eta
!      rcpinv = 1./rcp
!      cpr=cp/rgas
!      cvr=cv/rgas
      pi = 4.0*ATan(1.)
      cwc0 = piinv ! 1./pi ! 6.0/pi
      
      cnoh = cnoh0t
      hwdn = hwdn1t

      rwdn = 1000.0
      swdn = 100.0

      qrmin = 1.0e-05
      qsmin = 1.0e-06
      qhmin = 1.0e-05

!
!  default slope intercepts
!
      cnow  = 1.0e+08
      cnoi  = 1.0e+08
      cnoip = 1.0e+08 
      cnoir = 1.0e+08 
      cnor  = 8.0e+06 
      cnos  = 8.0e+06 
      cnogl = 4.0e+05 
      cnogm = 4.0e+05 
      cnogh = 4.0e+05 
      cnof  = 4.0e+05
      cnohl = 1.0e+03


      imx = 1
      jmx = 1
      kmx = 1
      i = 1


       IF ( microp(1:4) .eq. 'ZIEG' ) THEN !  na .ge. 14 .and. ipconc .ge. 3 ) THEN 

!        write(0,*)  'Set reflectivity for ZIEG'
         izieg = 1

         hwdn = hwdn1t ! 500.


         cnor  = cno(lr)
         cnos  = cno(ls)
         cnoh  = cno(lh)
         qrmin = qxmin(lr)
         qsmin = qxmin(ls)
         qhmin = qxmin(lh)
         IF ( lhl .gt. 1 ) THEN
            cnohl  = cno(lhl)
            qhlmin = qxmin(lhl)
         ENDIF

       ELSEIF ( microp(1:3) .eq. 'ZVD' ) THEN !  na .ge. 14 .and. ipconc .ge. 3 ) THEN 

         izieg = 1
         
         swdn0 = swdn

         cnor  = cno(lr)
         cnos  = cno(ls)
         cnoh  = cno(lh)
         
         qrmin = qxmin(lr)
         qsmin = qxmin(ls)
         qhmin = qxmin(lh)
         IF ( lhl .gt. 1 ) THEN
            cnohl  = cno(lhl)
            qhlmin = qxmin(lhl)
         ENDIF
!         write(*,*) 'radardbz: ',db(1,1,1),temk(1,1,1),an(1,1,1,lr),an(1,1,1,ls),an(1,1,1,lh)


        ENDIF


!      cdx(lr) = 0.60
!      
!      IF ( lh > 1 ) THEN
!      cdx(lh) = 0.8 ! 1.0 ! 0.45
!      cdx(ls) = 2.00
!      ENDIF
!
!      IF ( lhl .gt. 1 ) cdx(lhl) = 0.45
!
!      xvmn(lc) = xvcmn
!      xvmn(lr) = xvrmn
!
!      xvmx(lc) = xvcmx
!      xvmx(lr) = xvrmx
!
!      IF ( lh > 1 ) THEN
!      xvmn(ls) = xvsmn
!      xvmn(lh) = xvhmn
!      xvmx(ls) = xvsmx
!      xvmx(lh) = xvhmx
!      ENDIF
!
!      IF ( lhl .gt. 1 ) THEN
!      xvmn(lhl) = xvhlmn
!      xvmx(lhl) = xvhlmx
!      ENDIF
!
!      xdnmx(lr) = 1000.0
!      xdnmx(lc) = 1000.0
!      IF ( lh > 1 ) THEN
!      xdnmx(li) =  917.0
!      xdnmx(ls) =  300.0
!      xdnmx(lh) =  900.0
!      ENDIF
!      IF ( lhl .gt. 1 ) xdnmx(lhl) = 900.0
!!
!      xdnmn(:) = 900.0
!      
!      xdnmn(lr) = 1000.0
!      xdnmn(lc) = 1000.0
!      IF ( lh > 1 ) THEN
!      xdnmn(li) =  100.0
!      xdnmn(ls) =  100.0
!      xdnmn(lh) =  hdnmn
!      ENDIF
!      IF ( lhl .gt. 1 ) xdnmn(lhl) = 500.0
!
!      xdn0(:) = 900.0
!      
!      xdn0(lc) = 1000.0
!      xdn0(lr) = 1000.0
!      IF ( lh > 1 ) THEN
!      xdn0(li) = 900.0
!      xdn0(ls) = 100.0 ! 100.0
!      xdn0(lh) = hwdn1t ! (0.5)*(xdnmn(lh)+xdnmx(lh))
!      ENDIF
!      IF ( lhl .gt. 1 ) xdn0(lhl) = 800.0

!
!  slope intercepts
!
!      cnow  = 1.0e+08
!      cnoi  = 1.0e+08
!      cnoip = 1.0e+08 
!      cnoir = 1.0e+08 
!      cnor  = 8.0e+06 
!      cnos  = 8.0e+06 
!      cnogl = 4.0e+05 
!      cnogm = 4.0e+05 
!      cnogh = 4.0e+05 
!      cnof  = 4.0e+05
!c      cnoh  = 4.0e+04
!      cnohl = 1.0e+03
!
!
!  density maximums and minimums
!
      rwdnmx = 1000.0
      cwdnmx = 1000.0
      cidnmx =  917.0
      xidnmx =  917.0
      swdnmx =  200.0
      gldnmx =  400.0
      gmdnmx =  600.0
      ghdnmx =  800.0
      fwdnmx =  900.0
      hwdnmx =  900.0
      hldnmx =  900.0
!
      rwdnmn = 1000.0
      cwdnmn = 1000.0
      xidnmn =  001.0
      cidnmn =  001.0
      swdnmn =  001.0
      gldnmn =  200.0
      gmdnmn =  400.0
      ghdnmn =  600.0
      fwdnmn =  700.0
      hwdnmn =  700.0
      hldnmn =  900.0

      
      gldn = (0.5)*(gldnmn+gldnmx)  ! 300.
      gmdn = (0.5)*(gmdnmn+gmdnmx)  ! 500.
      ghdn = (0.5)*(ghdnmn+ghdnmx)  ! 700.
      fwdn = (0.5)*(fwdnmn+fwdnmx)  ! 800.
      hldn = (0.5)*(hldnmn+hldnmx)  ! 900.


      cr1  = 7.2e+20
      cr2  = 7.295e+19
      hwdnsq = hwdn**2
      swdnsq = swdn**2
      rwdnsq = rwdn**2

      gldnsq = gldn**2
      gmdnsq = gmdn**2
      ghdnsq = ghdn**2
      fwdnsq = fwdn**2
      hldnsq = hldn**2
      
      dhmin = 0.005
      tfr   = 273.16
      tfrh  = tfr - 8.0
      zrc   = cr1*cnor
      reflectmin = 0.0
      kw_sq = 0.93
      dbzmax = dbzmin
      
      ihcnt=0

            
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!  Dielectric Factor  - Formulas implemented by Svetla Veleva
!                       following Battan, "Radar Meteorology" - p. 40
!  The result of these calculations is that the dielf numerator (ki_sq) without
!  the density ratio is  .2116 for hail if using 917 density and .25 for
!  snow if using 220 density.
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      const_ki_sn = 0.5 - (0.5-0.46)/(917.-220.)*(swdn-220.)
      const_ki_h  = 0.5 - (0.5-0.46)/(917.-220.)*(hwdn-220.)
      ki_sq_sn = (swdnsq/rwdnsq) * const_ki_sn**2
      ki_sq_h  = (hwdnsq/rwdnsq) * const_ki_h**2
      dielf_sn = ki_sq_sn / kw_sq
      dielf_h  = ki_sq_h  / kw_sq
            
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!  Use the next line if you want to hardwire dielf for dry hail for both dry
!  snow and dry hail.
!  This would be equivalent to what Straka had originally. (i.e, .21/.93)
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      dielf_sn = (swdnsq/rwdnsq)*.21/ kw_sq
      dielf_h  = (hwdnsq/rwdnsq)*.21/ kw_sq

      dielf_gl  = (gldnsq/rwdnsq)*.21/ kw_sq
      dielf_gm  = (gmdnsq/rwdnsq)*.21/ kw_sq
      dielf_gh  = (ghdnsq/rwdnsq)*.21/ kw_sq
      dielf_hl  = (hldnsq/rwdnsq)*.21/ kw_sq
      dielf_fw  = (fwdnsq/rwdnsq)*.21/ kw_sq

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!  Notes on dielectric factors  - from Eun-Kyoung Seo
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! constants for both snow and hail would be (x=s,h).....
!       xwdnsq/rwdnsq *0.21/kw_sq   ! Straka/Smith - the original
!       xwdnsq/rwdnsq *0.224        ! Ferrier - for particle sizes in equiv. drop diam
!       xwdnsq/rwdnsq *0.176/kw_sq  ! =0.189 in Smith - for particle sizes in equiv 
!                       ice spheres
!       xwdnsq/rwdnsq *0.208/kw_sq  ! Smith 1984 - for particle sizes in equiv melted drop diameter
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~


! VIL algorithm constants
!      Ztop = 10.**(56./10)           !56 dbz is the max rf used by WATADS in cell vil


! Hail detection algorithm constants
!      ZL = 40.
!      ZU = 50.
!      Ho = 3400.  !WATADS Defaults
!      Hm20 = 6200.      !WATADS Defaults

!      DO kz = 1,Min(nzdbz,nz-1)

      DO jy=1,1

        DO kz = 1,ke_diag ! nz
         
          DO ix=1,nx
            dbz(ix,jy,kz) = 0.0
                      
          vzsnow = 0.0
          vzrain = 0.0
          vzgraupel = 0.0
          vzhail = 0.0
          
          dtmph = 0.0
          dtmps = 0.0
          dtmphl = 0.0
          dtmpr = 0.0
           dadr = (db(ix,jy,kz)/(pi*rwdn*cnor))**(0.25)
!-----------------------------------------------------------------------
! Compute Rain Radar Reflectivity
!-----------------------------------------------------------------------
           
           dtmp(ix,kz) = 0.0
           gtmp(ix,kz) = 0.0
           IF ( an(ix,jy,kz,lr) .ge. qrmin ) THEN
             IF ( ipconc .le. 2 ) THEN
               gtmp(ix,kz) = dadr*an(ix,jy,kz,lr)**(0.25)
               dtmp(ix,kz) = zrc*gtmp(ix,kz)**7
             ELSEIF ( an(ix,jy,kz,lnr) .gt. 1.e-3 ) THEN
               IF ( imurain == 3 ) THEN
                 vr = db(ix,jy,kz)*an(ix,jy,kz,lr)/(1000.*an(ix,jy,kz,lnr))
                 dtmp(ix,kz) = 3.6e18*(rnu+2.)*an(ix,jy,kz,lnr)*vr**2/(rnu+1.)
               ELSE ! imurain == 1
                g1 = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar))
                zx = g1*(db(ix,jy,kz)*an(ix,jy,kz,lr))**2/an(ix,jy,kz,lnr)
                ze =1.e18*zx*(6./(pi*1000.))**2 ! note: using 1000. here for water density
                dtmp(ix,kz) = ze
               ENDIF
             ENDIF
             dtmpr = dtmp(ix,kz)
           ENDIF
           
!-----------------------------------------------------------------------
! Compute snow and graupel reflectivity
!
! Lou modified to look at parcel temperature rather than base state
!-----------------------------------------------------------------------

          IF( lhab .gt. lr ) THEN

!    qs2d   = reform(data[*,*,k,10],[nx*ny])
!    qh2d   = reform(data[*,*,k,11],[nx*ny])

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! Only use the following lines if running Straka GEMS microphysics
!  (Sam 1-d version modified by L Wicker does not use this)
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!    ;xcnoh    = cnoh*exp(-0.025*(temp-tfr))
!    ;xcnos    = cnos*exp(-0.038*(temp-tfr))
!    ;good = where(temp GT tfr, n_elements)
!    ;IF n_elements NE 0 THEN xcnoh(good) = cnoh*exp(-0.075*(temp(good)-tfr))
!    ;IF n_elements NE 0 THEN xcnos(good) = cnos*exp(-0.088*(temp(good)-tfr))

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! Only use the following lines if running Ferrier micro with No=No(T)
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!    ;  NOSE = -.15
!    ;  NOGE =  .0
!    ;  xcnoh = cnoh*(1.>exp(NOGE*(temp-tfr)) )
!    ;  xcnos = cnos*(1.>exp(NOSE*(temp-tfr)) )

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! Use the following lines if Nos and Noh are constant
!  (As in Svetla version of Ferrier, GCE Tao, and SAM 1-d)
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
        xcnoh    = cnoh
        xcnos    = cnos

!
! Temporary fix for predicted number concentration -- need a 
! more appropriate reflectivity equation!
!
!        IF ( an(ix,jy,kz,lns) .lt. 0.1 ) THEN
!         swdia = (xvrmn*cwc0)**(1./3.)
!         xcnos = an(ix,jy,kz,ls)*db(ix,jy,kz)/(xvrmn*swdn*swdia)
!        ELSE
!      ! changed back to diameter of mean volume!!!
!         swdia =
!     >  (an(ix,jy,kz,ls)*db(ix,jy,kz)
!     > /(pi*swdn*an(ix,jy,kz,lns)))**(1./3.)
!
!        xcnos = an(ix,jy,kz,lns)/swdia
!        ENDIF

        IF ( ls .gt. 1 ) THEN ! {
        
        IF ( lvs .gt. 1 ) THEN
          IF ( an(ix,jy,kz,lvs) .gt. 0.0 ) THEN
            swdn = db(ix,jy,kz)*an(ix,jy,kz,ls)/an(ix,jy,kz,lvs)
            swdn = Min( 300., Max( 100., swdn ) )
          ELSE 
            swdn = swdn0
          ENDIF
        
        ENDIF 
        
        IF ( ipconc .ge. 5 ) THEN ! {

        xvs = db(ix,jy,kz)*an(ix,jy,kz,ls)/  &
     &      (swdn*Max(1.0e-3,an(ix,jy,kz,lns)))
        IF ( xvs .lt. xvsmn .or. xvs .gt. xvsmx ) THEN
          xvs = Min( xvsmx, Max( xvsmn,xvs ) )
          csw = db(ix,jy,kz)*an(ix,jy,kz,ls)/(xvs*swdn)
        ENDIF

         swdia = (xvs*cwc0)**(1./3.)
         xcnos = an(ix,jy,kz,ls)*db(ix,jy,kz)/(xvs*swdn*swdia)
         
         ENDIF ! }
         ENDIF  ! }

!        IF ( an(ix,jy,kz,lnh) .lt. 0.1 ) THEN
!         hwdia = (xvrmn*cwc0)**(1./3.)
!         xcnoh = an(ix,jy,kz,lh)*db(ix,jy,kz)/(xvrmn*hwdn*hwdia)
!        ELSE
!      ! changed back to diameter of mean volume!!!
!         hwdia =
!     >  (an(ix,jy,kz,lh)*db(ix,jy,kz)
!     > /(pi*hwdn*an(ix,jy,kz,lnh)))**(1./3.)
!        
!         xcnoh = an(ix,jy,kz,lnh)/hwdia
!        ENDIF

        IF ( lh .gt. 1 ) THEN ! {

        IF ( lvh .gt. 1 ) THEN
          IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN
            hwdn = db(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh)
            hwdn = Min( 900., Max( hdnmn, hwdn ) )
          ELSE 
            hwdn = 500. ! hwdn1t
          ENDIF
        ELSE
          hwdn = hwdn1t
        ENDIF 
        
        IF ( ipconc .ge. 5 ) THEN ! {

        xvh = db(ix,jy,kz)*an(ix,jy,kz,lh)/       &
     &      (hwdn*Max(1.0e-3,an(ix,jy,kz,lnh)))
        IF ( xvh .lt. xvhmn .or. xvh .gt. xvhmx ) THEN
          xvh = Min( xvhmx, Max( xvhmn,xvh ) )
          chw = db(ix,jy,kz)*an(ix,jy,kz,lh)/(xvh*hwdn)
        ENDIF

         hwdia = (xvh*cwc0)**(1./3.)
         xcnoh = an(ix,jy,kz,lh)*db(ix,jy,kz)/(xvh*hwdn*hwdia)
         
        ENDIF ! } ipconc .ge. 5
 
        ENDIF ! }

        dadh = 0.0
        dadhl = 0.0
        dads = 0.0
        IF ( xcnoh .gt. 0.0 ) THEN 
          dadh = ( db(ix,jy,kz) /(pi*hwdn*xcnoh) )**(.25)
          zhdryc = 0.224*cr2*(db(ix,jy,kz)/rwdn)**2/xcnoh ! dielf_h*cr1*xcnoh          ! SV - equiv formula as before but
                                        ! ratio of densities included in
                                        ! dielf_h rather than here following
                                        ! Battan.
        ELSE
          dadh = 0.0
          zhdryc = 0.0
        ENDIF
        
        IF ( xcnos .gt. 0.0 ) THEN
          dads = ( db(ix,jy,kz) /(pi*swdn*xcnos) )**(.25)
          zsdryc = 0.224*cr2*(db(ix,jy,kz)/rwdn)**2/xcnos ! dielf_sn*cr1*xcnos         ! SV - similar change as above
        ELSE
          dads = 0.0
          zsdryc = 0.0
        ENDIF
        zhwetc = zhdryc ! cr1*xcnoh      !Hail/graupel version with .95 power bug removed
        zswetc = zsdryc ! cr1*xcnos
!           
! snow contribution
!
          IF ( ls .gt. 1 ) THEN
          
          gtmp(ix,kz) = 0.0 
          qxw = 0.0 
          qxw1 = 0.0
          dtmps = 0.0
           IF ( an(ix,jy,kz,ls) .ge. qsmin ) THEN !{
            IF ( ipconc .ge. 4 ) THEN  ! (Ferrier 94) !{

             if (lsw .gt. 1) THEN 
               qxw = an(ix,jy,kz,lsw)
               qxw1 = 0.0
             ELSEIF ( ( iusewetsnow == 1 .or. iusewetsnow == 3) .and. temk(ix,jy,kz) .gt. tfr+1. & 
     &                  .and. an(ix,jy,kz,ls) > an(ix,jy,kz,lr) .and. an(ix,jy,kz,lr) > qsmin) THEN
               qxw = Min(0.5*an(ix,jy,kz,ls), an(ix,jy,kz,lr))
               qxw1 = qxw
             ENDIF

             vr = xvs ! db(ix,jy,kz)*an(ix,jy,kz,lr)/(1000.*an(ix,jy,kz,lnr))
!             gtmp(ix,kz) = 3.6e18*(0.243*rhos**2/0.93)*(snu+2.)*an(ix,jy,kz,lns)*vr**2/(snu+1.)
             
             ksq = 0.189 ! Smith (1984, JAMC) for equiv. ice sphere
             IF ( an(ix,jy,kz,lns) .gt. 1.e-7 ) THEN
     !          IF ( .true. ) THEN
               IF ( qxw > qsmin .or. iusewetsnow >= 2 ) THEN ! old version
!                gtmp(ix,kz) = 3.6e18*(snu+2.)*( 0.224*an(ix,jy,kz,ls) + 0.776*qxw)*an(ix,jy,kz,ls)/ &
!     &              (an(ix,jy,kz,lns)*(snu+1.)*rwdn**2)*db(ix,jy,kz)**2
                gtmp(ix,kz) = 3.6e18*(snu+2.)*( 0.224*(an(ix,jy,kz,ls)+qxw1) + 0.776*qxw)*(an(ix,jy,kz,ls)+qxw1)/ &
     &              (an(ix,jy,kz,lns)*(snu+1.)*rwdn**2)*db(ix,jy,kz)**2

               ELSE ! new form using a mass relationship m = p d^2 (instead of d^3 -- Cox 1988 QJRMS) so that density depends on size
                    ! p = 0.106214 for m = p v^(2/3)
                 dnsnow = 0.346159*sqrt(an(ix,jy,kz,lns)/(an(ix,jy,kz,ls)*db(ix,jy,kz)) )
                 IF ( .true. .or. dnsnow < 900. ) THEN
                  gtmp(ix,kz) = 1.e18*323.3226* 0.106214**2*(ksq*an(ix,jy,kz,ls) + &
     &             (1.-ksq)*qxw)*an(ix,jy,kz,ls)*db(ix,jy,kz)**2*gsnow73/         &
     &                   (an(ix,jy,kz,lns)*(917.)**2* gsnow1*(1.0+snu)**(4./3.))
                 ELSE ! otherwise small enough to assume ice spheres?
                  gtmp(ix,kz) = (36./pi**2) * 1.e18*(snu+2.)*( 0.224*(an(ix,jy,kz,ls)+qxw1) + 0.776*qxw)*(an(ix,jy,kz,ls)+qxw1)/ &
     &              (an(ix,jy,kz,lns)*(snu+1.)*rwdn**2)*db(ix,jy,kz)**2
                 ENDIF

               ENDIF
             
             ENDIF
             
!             tmp = Min(1.0,1.e3*(an(ix,jy,kz,ls))*db(ix,jy,kz))
!             gtmp(ix,kz) = Max( 1.0*gtmp(ix,kz), 750.0*(tmp)**1.98)
             dtmps = gtmp(ix,kz)
             dtmp(ix,kz) = dtmp(ix,kz) + gtmp(ix,kz)
            ELSE ! }{ single-moment snow:
             gtmp(ix,kz) = dads*an(ix,jy,kz,ls)**(0.25)
             
             IF ( gtmp(ix,kz) .gt. 0.0 ) THEN !{
             dtmps = zsdryc*an(ix,jy,kz,ls)**2/gtmp(ix,kz)
             IF ( temk(ix,jy,kz) .lt. tfr ) THEN
               dtmp(ix,kz) = dtmp(ix,kz) +          &
     &                   zsdryc*an(ix,jy,kz,ls)**2/gtmp(ix,kz)
             ELSE
               dtmp(ix,kz) = dtmp(ix,kz) +          &
     &                  zswetc*an(ix,jy,kz,ls)**2/gtmp(ix,kz)
             ENDIF
             ENDIF !}
            ENDIF !}
           
           ENDIF !}
           
           ENDIF


!
! ice crystal contribution (Heymsfield, 1977, JAS)
!
         IF ( li .gt. 1 .and. idbzci .ne. 0 ) THEN
          
           IF ( idbzci == 1 .and. lni > 0 ) THEN
          ! assume spherical ice with density of 900 for dbz calc
            IF ( an(ix,jy,kz,li) > qxmin(li) .and. an(ix,jy,kz,lni) > 1.0 ) THEN
                 vr = db(ix,jy,kz)*an(ix,jy,kz,li)/(900.*an(ix,jy,kz,lni))
                 dtmp(ix,kz) = dtmp(ix,kz) +  &
     &                 0.224*3.6e18*(cinu+2.)*an(ix,jy,kz,lni)*vr**2/(cinu+1.)*(900./1000.)**2
            ENDIF

          ELSEIF ( idbzci == 2 ) THEN
!
! ice crystal contribution (Heymsfield, 1977, JAS)
!
         gtmp(ix,kz) = 0.0 
           IF ( an(ix,jy,kz,li) .ge. 0.1e-3 ) THEN
             gtmp(ix,kz) = Min(1.0,1.e3*(an(ix,jy,kz,li))*db(ix,jy,kz))
             dtmp(ix,kz) = dtmp(ix,kz) + 750.0*(gtmp(ix,kz))**1.98
           ENDIF
           
          ENDIF
        
        ENDIF
          
!           
! graupel/hail contribution
!
         IF ( lh .gt. 1 ) THEN ! {
           gtmp(ix,kz) = 0.0 
           dtmph = 0.0
           qxw = 0.0

          IF ( izieg .ge. 1 .and. ipconc .ge. 5 ) THEN

           ltest = .false.
           
           IF ( ltest .or. (an(ix,jy,kz,lh) .ge. qhmin .and. an(ix,jy,kz,lnh) .ge. cxmin )) THEN
            
            IF ( lvh .gt. 1 ) THEN
             
             IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN
               hwdn = db(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh)
               hwdn = Min( 900., Max( 100., hwdn ) )
              ELSE 
               hwdn = 500. ! hwdn1t
              ENDIF

             ENDIF

             chw = an(ix,jy,kz,lnh)
            IF ( chw .gt. 0.0 ) THEN                                         ! (Ferrier 94)
             xvh = db(ix,jy,kz)*an(ix,jy,kz,lh)/(hwdn*Max(1.0e-3,chw))
             IF ( xvh .lt. xvhmn .or. xvh .gt. xvhmx ) THEN
              xvh = Min( xvhmx, Max( xvhmn,xvh ) )
              chw = db(ix,jy,kz)*an(ix,jy,kz,lh)/(xvh*hwdn)
             ENDIF
             
             qh = an(ix,jy,kz,lh)
             
             IF ( lhw .gt. 1 ) THEN
               IF ( iusewetgraupel .eq. 1 ) THEN
                  qxw = an(ix,jy,kz,lhw)
               ELSEIF ( iusewetgraupel .eq. 2 ) THEN
                  IF ( hwdn .lt. 300. ) THEN
                    qxw = an(ix,jy,kz,lhw)
                  ENDIF
               ENDIF
             ELSEIF ( iusewetgraupel .eq. 3 ) THEN
                  IF ( hwdn .lt. 300. .and. temk(ix,jy,kz) > tfr .and. an(ix,jy,kz,lr) > qhmin ) THEN
                    qxw = Min( an(ix,jy,kz,lh), an(ix,jy,kz,lr))
                    qh = qh + qxw
                  ENDIF
             ELSEIF ( iusewetgraupel == 4 .and. temk(ix,jy,kz) .gt. tfr+0.25 .and. an(ix,jy,kz,lh) > an(ix,jy,kz,lr) &
     &              .and. an(ix,jy,kz,lr) > qhmin) THEN
               qxw = Min(0.5*an(ix,jy,kz,lh), an(ix,jy,kz,lr))
               qh = qh + qxw

             ENDIF
             
             IF ( lzh .gt. 1 ) THEN
             ELSE
             g1 = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah))
!             zx = g1*(db(ix,jy,kz)*an(ix,jy,kz,lh))**2/chw
!             ze = 0.224*1.e18*zx*(6./(pi*1000.))**2
             zx = g1*db(ix,jy,kz)**2*( 0.224*qh + 0.776*qxw)*qh/chw
             ze =1.e18*zx*(6./(pi*1000.))**2
             dtmp(ix,kz) = dtmp(ix,kz) + ze
             dtmph = ze
             ENDIF
             
            ENDIF
             
        !     IF ( an(ix,jy,kz,lh) .gt. 1.0e-3 ) write(0,*)  'Graupel Z : ',dtmph,ze
           ENDIF
          
          ELSE
          
          dtmph = 0.0
          
           IF ( an(ix,jy,kz,lh) .ge. qhmin ) THEN
             gtmp(ix,kz) = dadh*an(ix,jy,kz,lh)**(0.25)
             IF ( gtmp(ix,kz) .gt. 0.0 ) THEN
             dtmph =  zhdryc*an(ix,jy,kz,lh)**2/gtmp(ix,kz)
             IF ( temk(ix,jy,kz) .lt. tfr ) THEN
               dtmp(ix,kz) = dtmp(ix,kz) +                   &
     &                  zhdryc*an(ix,jy,kz,lh)**2/gtmp(ix,kz)
             ELSE
!               IF ( hwdn .gt. 700.0 ) THEN
                 dtmp(ix,kz) = dtmp(ix,kz) +                   &
     &                  zhdryc*an(ix,jy,kz,lh)**2/gtmp(ix,kz)
! 
!     &                               (zhwetc*gtmp(ix,kz)**7)**0.95
!               ELSE
!                 dtmp(ix,kz) = dtmp(ix,kz) + zhwetc*gtmp(ix,kz)**7
!               ENDIF
             ENDIF
             ENDIF
           ENDIF
          
         
          
          ENDIF
 

          ENDIF ! }
          
          ENDIF ! na .gt. 5

        
        IF ( izieg .ge. 1 .and. lhl .gt. 1 ) THEN

        hldn = 900.0
        gtmp(ix,kz) = 0.0
        dtmphl = 0.0
        qxw = 0.0
        

        IF ( lvhl .gt. 1 ) THEN
          IF ( an(ix,jy,kz,lvhl) .gt. 0.0 ) THEN
            hldn = db(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl)
            hldn = Min( 900., Max( 300., hldn ) )
          ELSE 
            hldn = 900. 
          ENDIF
        ELSE
          hldn = rho_qhl
        ENDIF 


        IF ( ipconc .ge. 5 ) THEN

           ltest = .false.

          IF ( ltest .or. ( an(ix,jy,kz,lhl) .ge. qhlmin .and. an(ix,jy,kz,lnhl) .gt. 0.) ) THEN !{
            chl = an(ix,jy,kz,lnhl)
            IF ( chl .gt. 0.0 ) THEN !{
             xvhl = db(ix,jy,kz)*an(ix,jy,kz,lhl)/         &
     &        (hldn*Max(1.0e-9,an(ix,jy,kz,lnhl)))
            IF ( xvhl .lt. xvhlmn .or. xvhl .gt. xvhlmx ) THEN ! {
              xvhl = Min( xvhlmx, Max( xvhlmn,xvhl ) )
              chl = db(ix,jy,kz)*an(ix,jy,kz,lhl)/(xvhl*hldn)
              ! do not update state in dbz calc. ! an(ix,jy,kz,lnhl) = chl
            ENDIF ! }

             IF ( lhlw .gt. 1 ) THEN
               IF ( iusewethail .eq. 1 ) THEN
                  qxw = an(ix,jy,kz,lhlw)
               ELSEIF ( iusewethail .eq. 2 ) THEN
                  IF ( hldn .lt. 300. ) THEN
                    qxw = an(ix,jy,kz,lhlw)
                  ENDIF
               ENDIF
             ENDIF
            
             IF ( lzhl .gt. 1 ) THEN !{
             ELSE !}

             g1 = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl))
             zx = g1*db(ix,jy,kz)**2*( 0.224*an(ix,jy,kz,lhl) + 0.776*qxw)*an(ix,jy,kz,lhl)/chl
!             zx = g1*(db(ix,jy,kz)*an(ix,jy,kz,lhl))**2/chl
             ze = 1.e18*zx*(6./(pi*1000.))**2 ! 3/28/2016 removed extra factor of 0.224
             dtmp(ix,kz) = dtmp(ix,kz) + ze
             dtmphl = ze
             
             ENDIF !}
            ENDIF!}
        !     IF ( an(ix,jy,kz,lh) .gt. 1.0e-3 ) write(0,*)  'Graupel Z : ',dtmph,ze
           ENDIF

          
          ELSE
          
          
           IF ( an(ix,jy,kz,lhl) .ge. qhlmin ) THEN ! {
            dadhl = ( db(ix,jy,kz) /(pi*hldn*cnohl) )**(.25)
             gtmp(ix,kz) = dadhl*an(ix,jy,kz,lhl)**(0.25)
             IF ( gtmp(ix,kz) .gt. 0.0 ) THEN ! {

              zhldryc = 0.224*cr2*( db(ix,jy,kz)/rwdn)**2/cnohl 

             dtmphl =  zhldryc*an(ix,jy,kz,lhl)**2/gtmp(ix,kz)

             IF ( temk(ix,jy,kz) .lt. tfr ) THEN
               dtmp(ix,kz) = dtmp(ix,kz) +                   &
     &                  zhldryc*an(ix,jy,kz,lhl)**2/gtmp(ix,kz)
             ELSE
!               IF ( hwdn .gt. 700.0 ) THEN
                 dtmp(ix,kz) = dtmp(ix,kz) +                   &
     &                  zhldryc*an(ix,jy,kz,lhl)**2/gtmp(ix,kz)
! 
!     :                               (zhwetc*gtmp(ix,kz)**7)**0.95
!               ELSE
!                 dtmp(ix,kz) = dtmp(ix,kz) + zhwetc*gtmp(ix,kz)**7
!               ENDIF
             ENDIF
             ENDIF ! }
           
           ENDIF ! }
          
         ENDIF ! ipconc .ge. 5


        ENDIF ! izieg .ge. 1 .and. lhl .gt. 1 

          
           
          IF ( dtmp(ix,kz) .gt. 0.0 ) THEN
            dbz(ix,jy,kz) = Max(dbzmin, 10.0*Log10(dtmp(ix,kz)) )
            
            IF ( dbz(ix,jy,kz) .gt. dbzmax ) THEN
              dbzmax = Max(dbzmax,dbz(ix,jy,kz))
              imx = ix
              jmx = jy
              kmx = kz
            ENDIF
          ELSE 
             dbz(ix,jy,kz) = dbzmin
             IF ( lh > 1 .and. lhl > 1) THEN
               IF ( an(ix,jy,kz,lh) > 1.0e-3 ) THEN
                 write(0,*) 'radardbz: qr,qh,qhl = ',an(ix,jy,kz,lr), an(ix,jy,kz,lh),an(ix,jy,kz,lhl)
                 write(0,*) 'radardbz: dtmps,dtmph,dadh,dadhl,dtmphl = ',dtmps,dtmph,dadh,dadhl,dtmphl
                 
                 IF ( lzh>1 .and. lzhl>1 ) write(0,*) 'radardbz: zh, zhl = ',an(ix,jy,kz,lzh),an(ix,jy,kz,lzhl)
               ENDIF
             ENDIF
          ENDIF

!         IF ( an(ix,jy,kz,lh) .gt. 1.e-4 .and. 
!     &        dbz(ix,jy,kz) .le. 0.0 ) THEN
!          write(0,*) 'dbz = ',dbz(ix,jy,kz)
!          write(0,*) 'Hail intercept: ',xcnoh,ix,kz
!          write(0,*) 'Hail,snow q: ',an(ix,jy,kz,lh),an(ix,jy,kz,ls)
!          write(0,*) 'Hail,snow c: ',an(ix,jy,kz,lnh),an(ix,jy,kz,lns)
!          write(0,*) 'dtmps,dtmph = ',dtmps,dtmph
!         ENDIF
        IF ( .not. dtmp(ix,kz) .lt. 1.e30 .or. dbz(ix,jy,kz) > 190.0 ) THEN
!        IF ( ix == 31 .and. kz == 20 .and. jy == 23 ) THEN
!          write(0,*) 'my_rank = ',my_rank
          write(0,*) 'ix,jy,kz = ',ix,jy,kz
          write(0,*) 'dbz = ',dbz(ix,jy,kz)
          write(0,*) 'db, zhdryc = ',db(ix,jy,kz),zhdryc
          write(0,*) 'Hail intercept: ',xcnoh,ix,kz
          write(0,*) 'Hail,snow q: ',an(ix,jy,kz,lh),an(ix,jy,kz,ls)
          write(0,*) 'graupel density hwdn = ',hwdn
          write(0,*) 'rain q: ',an(ix,jy,kz,lr)
          write(0,*) 'ice q: ',an(ix,jy,kz,li)
          IF ( lhl .gt. 1 ) write(0,*) 'Hail (lhl): ',an(ix,jy,kz,lhl)
          IF (ipconc .ge. 3 ) write(0,*) 'rain c: ',an(ix,jy,kz,lnr)
          IF ( lzr > 1 ) write(0,*) 'rain Z: ',an(ix,jy,kz,lzr)
          IF ( ipconc .ge. 5 ) THEN
          write(0,*) 'Hail,snow c: ',an(ix,jy,kz,lnh),an(ix,jy,kz,lns)
          IF ( lhl .gt. 1 ) write(0,*) 'Hail (lnhl): ',an(ix,jy,kz,lnhl)
          IF ( lzhl .gt. 1 ) THEN 
            write(0,*) 'Hail (lzhl): ',an(ix,jy,kz,lzhl)
            write(0,*) 'chl,xvhl,dhl = ',chl,xvhl,(xvhl*6./3.14159)**(1./3.)
            write(0,*) 'xvhlmn,xvhlmx = ',xvhlmn,xvhlmx
          ENDIF
          ENDIF
          write(0,*) 'chw,xvh = ', chw,xvh
          write(0,*) 'dtmps,dtmph,dadh,dadhl,dtmphl = ',dtmps,dtmph,dadh,dadhl,dtmphl
          write(0,*) 'dtmpr = ',dtmpr
          write(0,*) 'gtmp = ',gtmp(ix,kz),dtmp(ix,kz)
          IF ( .not. (dbz(ix,jy,kz) .gt. -100 .and. dbz(ix,jy,kz) .lt. 200 ) ) THEN
            write(0,*) 'dbz out of bounds! STOP!'
!            STOP
          ENDIF
         ENDIF

           
          ENDDO ! ix
         ENDDO ! kz
      ENDDO ! jy
            
      
      
      
!      write(0,*)  'na,lr = ',na,lr
      IF ( printyn .eq. 1 ) THEN
!      IF ( dbzmax .gt. dbzmin ) THEN
        write(iunit,*) 'maxdbz,ijk = ',dbzmax,imx,jmx,kmx
        write(iunit,*) 'qrw = ',an(imx,jmx,kmx,lr)
        
        IF ( lh .gt. 1 ) THEN
          write(iunit,*) 'qi  = ',an(imx,jmx,kmx,li)
          write(iunit,*) 'qsw = ',an(imx,jmx,kmx,ls)
          write(iunit,*) 'qhw = ',an(imx,jmx,kmx,lh)
          IF ( lhl .gt. 1 ) write(iunit,*) 'qhl = ',an(imx,jmx,kmx,lhl)
        ENDIF

      
      ENDIF
      
      
      RETURN
      END subroutine radardd02
      

! ##############################################################################
! ##############################################################################


! #####################################################################
! #####################################################################
!
! Subroutine for explicit cloud condensation and droplet nucleation
!
   SUBROUTINE NUCOND    &
     &  (nx,ny,nz,na,jyslab & 
     &  ,nor,norz,dtp,nxi & 
     &  ,dz3d & 
     &  ,t0,t9 & 
     &  ,an,dn,p2 & 
     &  ,pn,w & 
     &  ,axtra,io_flag &
     &  ,ssfilt,t00,t77,flag_qndrop  &
     & )


   implicit none

!      real :: cwmasn = 1000.*0.523599*(2.*2.e-6)**3 
      integer :: nx,ny,nz,na,nxi
      integer :: nor,norz, jyslab ! ,nht,ngt,igsr
      real    :: dtp  ! time step
      logical :: flag_qndrop

      integer, parameter :: ng1 = 1


!
! external temporary arrays
!
      real t00(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
      real t77(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)

      real t0(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
!      real t1(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
!      real t2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
!      real t3(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
!      real t4(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
!      real t5(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
!      real t6(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
!      real t7(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
!      real t8(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
      real t9(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
      

      real p2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)  ! perturbation Pi
      real pn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
      real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na)
      real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)

      real w(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
!      real qv(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)

      real ssfilt(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
      

      real pb(-norz+ng1:nz+norz)
      real pinit(-norz+ng1:nz+norz)

      real dz3d(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)

      
    ! local


      real axtra(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,nxtra)
      logical :: io_flag
      
      real :: dv

! 
!  declarations microphysics and for gather/scatter
!
      real, parameter :: cwmas30 = 1000.*0.523599*(2.*30.e-6)**3 ! mass of 30-micron radius droplet, for sat. adj.
      real, parameter :: cwmas20 = 1000.*0.523599*(2.*20.e-6)**3 ! mass of 20-micron radius droplet, for sat. adj.
      integer nxmpb,nzmpb,nxz
      integer mgs,ngs,numgs,inumgs
      parameter (ngs=500)
      integer ngscnt,igs(ngs),kgs(ngs)
      integer kgsp(ngs),kgsm(ngs)
      integer nsvcnt
      
      integer ix,kz,i,n, kp1, km1
      integer :: jy, jgs
      integer ixb,ixe,jyb,jye,kzb,kze
    
      integer itile,jtile,ktile
      integer ixend,jyend,kzend,kzbeg
      integer nxend,nyend,nzend,nzbeg

!
! Variables for Ziegler warm rain microphysics
!      


      real ccnc(ngs), ccna(ngs), cnuc(ngs), cwnccn(ngs)
      real ccncuf(ngs)
      real sscb  ! 'cloud base' SS threshold
      parameter ( sscb = 2.0 )
      integer idecss  ! flag to turn on (=1) decay of ssmax when no cloud or ice crystals
      parameter ( idecss = 1 )
      integer iba ! flag to do condensation/nucleation in 1st or 2nd loop
                  ! =0 to use ad to calculate SS
                  ! =1 to use an at end of main jy loop to calculate SS
      parameter (iba = 1)
      integer ifilt   ! =1 to filter ssat, =0 to set ssfilt=ssat
      parameter ( ifilt = 0 ) 
      real temp1,temp2 ! ,ssold
      real :: ssmax(ngs) = 0.0       ! maximum SS experienced by a parcel
      real ssmx
      real dnnet,dqnet
!      real cnu,rnu,snu,cinu
!      parameter ( cnu = 0.0, rnu = -0.8, snu = -0.8, cinu = 0.0 )
      real ventrx(ngs)
      real ventrxn(ngs)
      real volb, t2s
      real, parameter :: aa1 = 9.44e15, aa2 = 5.78e3  ! a1 in Ziegler

      real ec0, ex1, ft, rhoinv(ngs)
      
      real chw, g1, rd1

      real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp2 ! , sstdy, super
      real tmpmx, fw, qctmp
      real x,y,del,r,alpr
      double precision :: vent1,vent2
      real g1palp
      real bs
      real v1, v2
      real d1r, d1i, d1s, e1i
      integer nc ! condensation step
      real dtcon,dtcon1,dtcon2 ! condensation time step (dtcon*nc = dtp)
      real delta
      integer ltemq1,ltemq1m ! ,ltemq1m2
      real dqv,qv1,ss1,ss2,qvs1,dqvs,dtemp,dt1   ! temporaries for condensation

      real ssi1, ssi2, dqvi, dqvis, dqvii,qis1
      real dqvr, dqc, dqr, dqi, dqs
      real qv1m,qvs1m,ss1m,ssi1m,qis1m
      real cwmastmp 
      real  dcloud,dcloud2 ! ,as, bs
      real dcrit
      real cn(ngs), cnuf(ngs)
      real :: ccwmax

      integer ltemq
      
      integer il

      real  es(ngs) ! ss(ngs),
!      real  eis(ngs)
      real ssf(ngs),ssfkp1(ngs),ssfkm1(ngs),ssat0(ngs)
      real, parameter :: ssfcut = 4.0
      real ssfjp1(ngs),ssfjm1(ngs)
      real ssfip1(ngs),ssfim1(ngs)

      real supcb, supmx
      parameter (supcb=0.5,supmx=238.0)
      real r2dxm, r2dym, r2dzm
      real dssdz, dssdy, dssdx
!      real tqvcon
      real epsi,d
      parameter (epsi = 0.622, d = 0.266)
      real r1,qevap ! ,slv
      
      real vr,nrx,qr,z1,z2,rdi,alp,xnutmp,xnuc
      real ctmp, ccwtmp
      real f5, qvs0  ! Kessler condensation factor
      real    :: t0p1, t0p3
      real qvex
      
!      real, dimension(ngs) :: temp, tempc, elv, elf, els, pqs, theta, temg, temcg
      real dqvcnd(ngs),dqwv(ngs),dqcw(ngs),dqci(ngs)
      real temp(ngs),tempc(ngs)
      real temg(ngs),temcg(ngs),theta(ngs),qvap(ngs) ! ,tembzg(ngs)
      real temgx(ngs),temcgx(ngs)
      real qvs(ngs),qis(ngs),qss(ngs),pqs(ngs)
      real felv(ngs),felf(ngs),fels(ngs)
      real felvcp(ngs),felvpi(ngs)
      real gamw(ngs),gams(ngs)   !   qciavl(ngs),
      real tsqr(ngs),ssi(ngs),ssw(ngs)
      real cc3(ngs),cqv1(ngs),cqv2(ngs)
      real qcwtmp(ngs),qtmp

      real fvent(ngs) !,fraci(ngs),fracl(ngs)
      real fwvdf(ngs),ftka(ngs),fthdf(ngs)
      real fadvisc(ngs),fakvisc(ngs)
      real fci(ngs),fcw(ngs)
      real fschm(ngs),fpndl(ngs)

      real pres(ngs),pipert(ngs)
      real pk(ngs)
      real rho0(ngs),pi0(ngs)
      real rhovt(ngs)
      real thetap(ngs),theta0(ngs),qwvp(ngs),qv0(ngs)
      real thsave(ngs)
      real qss0(ngs)
      real fcqv1(ngs)
      real wvel(ngs),wvelkm1(ngs)

      real wvdf(ngs),tka(ngs)
      real advisc(ngs)

      real rwvent(ngs)
      

      real :: qx(ngs,lv:lhab)
      real :: cx(ngs,lc:lhab)
      real :: xv(ngs,lc:lhab)
      real :: xmas(ngs,lc:lhab)
      real :: xdn(ngs,lc:lhab)
      real :: xdia(ngs,lc:lhab,3)
      real :: alpha(ngs,lc:lhab)
      real :: zx(ngs,lr:lhab)


      logical zerocx(lc:lqmx)
      
      logical :: lprint

      integer, parameter :: iunit = 0
      
      real :: frac, hwdn, tmpg
      
      real :: cvm,cpm,rmm

      real, parameter :: rovcp = rd/cp
      real, parameter ::      cpv = 1885.0       ! specific heat of water vapor at constant pressure
      
      integer :: kstag
      
      integer :: count
      

! -------------------------------------------------------------------------------
      itile = nxi
      jtile = ny
      ktile = nz
      ixend = nxi
      jyend = ny
      kzend = nz
      nxend = nxi + 1
      nyend = ny + 1
      nzend = nz
      kzbeg = 1
      nzbeg = 1

      f5 = 237.3 * 17.27 * 2.5e6 / cp ! combined constants for rain condensation (Soong and Ogura 73)

       jy = 1
       kstag = 0
       pb(:) = 0.0
       pinit(:) = 0.0
      
      IF ( ipconc <= 1 .or. isedonly == 2 ) GOTO 2200

!
!  Ziegler nucleation 
!

!      ssfilt(:,:,:) = 0.0
      ssmx = 0
      count = 0

      do kz = 1,nz-kstag
        do ix = 1,nxi

         temp1 = an(ix,jy,kz,lt)*t77(ix,jy,kz)
          t0(ix,jy,kz) = temp1
          ltemq = Int( (temp1-163.15)/fqsat+1.5 )
         ltemq = Min( nqsat, Max(1,ltemq) )

          c1 = t00(ix,jy,kz)*tabqvs(ltemq)

          IF ( c1 > 0. ) THEN
            ssfilt(ix,jy,kz) = 100.*(an(ix,jy,kz,lv)/c1 - 1.0)  ! from "new" values
          ENDIF

        ENDDO
      ENDDO


!
!     jy = 1 ! working on a 2d slab
!!  VERY IMPORTANT:  SET jgs = jy

      jgs = jy

!
!..Gather microphysics
!
      if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: Gather stage'

      nxmpb = 1
      nzmpb = 1
      nxz = nxi*nz
      numgs = nxz/ngs + 1


      do 2000 inumgs = 1,numgs

      ngscnt = 0


      kzb = nzmpb
      kze = nz-kstag
 !     if (kzbeg .le. nzmpb .and. kzend .gt. nzmpb) kzb = nzmpb

      ixb = nxmpb
      ixe = itile

      do kz = kzb,kze
      do ix = nxmpb,nxi

      pqs(1) = 380.0/(pn(ix,jy,kz) + pb(kz))
      theta(1) = an(ix,jy,kz,lt)
      temg(1) = t0(ix,jy,kz)

      temcg(1) = temg(1) - tfr
      ltemq = (temg(1)-163.15)/fqsat+1.5
      ltemq = Min( nqsat, Max(1,ltemq) )
      qvs(1) = pqs(1)*tabqvs(ltemq)
      qis(1) = pqs(1)*tabqis(ltemq)

      qss(1) = qvs(1)


      if ( temg(1) .lt. tfr ) then
      end if
!
      if ( (temg(1) .gt. tfrh .or. an(ix,jy,kz,lv)/qvs(1) > maxsupersat ) .and.  &
     &   ( an(ix,jy,kz,lv)  .gt. qss(1) .or. &
     &     an(ix,jy,kz,lc)  .gt. qxmin(lc)   .or.  &
     &     ( an(ix,jy,kz,lr)  .gt. qxmin(lr) .and. rcond == 2 )  &
     &     )) then
      ngscnt = ngscnt + 1
      igs(ngscnt) = ix
      kgs(ngscnt) = kz
      if ( ngscnt .eq. ngs ) goto 2100
      end if

      end do  !ix

      nxmpb = 1
      end do  !kz
!      if ( jy .eq. (ny-jstag) ) iend = 1
 2100 continue

      if ( ngscnt .eq. 0 ) go to 29998

      if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: dbg = 8'
      
!      write(0,*) 'NUCOND: dbg = 8, ngscnt,ssmx = ',ngscnt,ssmx

      
      qx(:,:) = 0.0
      cx(:,:) = 0.0

      xv(:,:) = 0.0
      xmas(:,:) = 0.0

      IF ( imurain == 1 ) THEN
        alpha(:,lr) = alphar
      ELSEIF ( imurain == 3 ) THEN
        alpha(:,lr) = xnu(lr)
      ENDIF

!
!  define temporaries for state variables to be used in calculations
!
      DO mgs = 1,ngscnt
      qx(mgs,lv) = an(igs(mgs),jy,kgs(mgs),lv)
       DO il = lc,lhab
        qx(mgs,il) = max(an(igs(mgs),jy,kgs(mgs),il), 0.0)
       ENDDO

       qcwtmp(mgs) = qx(mgs,lc)


      theta0(mgs) = an(igs(mgs),jy,kgs(mgs),lt) !
      thetap(mgs) = 0.0
      theta(mgs) = an(igs(mgs),jy,kgs(mgs),lt)
      qv0(mgs) =  qx(mgs,lv)
      qwvp(mgs) = qx(mgs,lv) - qv0(mgs)

       pres(mgs) = pn(igs(mgs),jy,kgs(mgs)) + pb(kgs(mgs))
       pipert(mgs) = p2(igs(mgs),jy,kgs(mgs))
       rho0(mgs) = dn(igs(mgs),jy,kgs(mgs))
       rhoinv(mgs) = 1.0/rho0(mgs)
       rhovt(mgs) = Sqrt(rho00/rho0(mgs))
       pi0(mgs) = p2(igs(mgs),jy,kgs(mgs)) + pinit(kgs(mgs))
       temg(mgs) = t0(igs(mgs),jy,kgs(mgs))
!       pk(mgs) = t77(igs(mgs),jy,kgs(mgs)) ! ( pres(mgs) / poo ) ** cap
       pk(mgs)   = p2(igs(mgs),jy,kgs(mgs)) + pinit(kgs(mgs)) ! t77(igs(mgs),jy,kgs(mgs))
       temcg(mgs) = temg(mgs) - tfr
       qss0(mgs) = (380.0)/(pres(mgs))
       pqs(mgs) = (380.0)/(pres(mgs))
       ltemq = (temg(mgs)-163.15)/fqsat+1.5
       ltemq = Min( nqsat, Max(1,ltemq) )
       qvs(mgs) = pqs(mgs)*tabqvs(ltemq)
       qis(mgs) = pqs(mgs)*tabqis(ltemq)
!
        qvap(mgs) = max( (qwvp(mgs) + qv0(mgs)), 0.0 )
        es(mgs) = 6.1078e2*tabqvs(ltemq)
        qss(mgs) = qvs(mgs)


        temgx(mgs) = min(temg(mgs),313.15)
        temgx(mgs) = max(temgx(mgs),233.15)
        felv(mgs) = 2500837.367 * (273.15/temgx(mgs))**((0.167)+(3.67e-4)*temgx(mgs))
!
        IF ( eqtset <= 1 ) THEN
          felvcp(mgs) = felv(mgs)*cpi
        ELSE ! equation set 2 in cm1
          tmp = qx(mgs,li)+qx(mgs,ls)+qx(mgs,lh)
          IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl)
          cvm = cv+cvv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr))   &
                                  +cpigb*(tmp)
          cpm = cp+cpv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr))   &
                                  +cpigb*(tmp)
          rmm=rd+rw*qx(mgs,lv)
          
          IF ( eqtset == 2 ) THEN

           felvcp(mgs) = (felv(mgs)-rw*temg(mgs))/cvm

          ELSE
            felvcp(mgs) = (felv(mgs)*cv/(cp) - rw*temg(mgs)*(1.0-rovcp*cpm/rmm))/cvm
            felvpi(mgs) = pi0(mgs)*rovcp*(felv(mgs)/(temg(mgs)) - rw*cpm/rmm)/cvm
          ENDIF

        ENDIF

        temcgx(mgs) = min(temg(mgs),273.15)
        temcgx(mgs) = max(temcgx(mgs),223.15)
        temcgx(mgs) = temcgx(mgs)-273.15
        felf(mgs) = 333690.6098 + (2030.61425)*temcgx(mgs) - (10.46708312)*temcgx(mgs)**2
!
        fels(mgs) = felv(mgs) + felf(mgs)
        fcqv1(mgs) = 4098.0258*felv(mgs)*cpi

      wvdf(mgs) = (2.11e-05)*((temg(mgs)/tfr)**1.94)* &
     &  (101325.0/(pb(kgs(mgs)) + pn(igs(mgs),jgs,kgs(mgs))))                            ! diffusivity of water vapor, Hall and Pruppacher (76)
      advisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))* &
     &  (temg(mgs)/296.0)**(1.5)                         ! dynamic viscosity (SMT; see Beard & Pruppacher 71)
      tka(mgs) = tka0*advisc(mgs)/advisc1                 ! thermal conductivity


      ENDDO



!
! load concentrations
!
      if ( ipconc .ge. 1 ) then
       do mgs = 1,ngscnt
        cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0)
       end do
      end if
      if ( ipconc .ge. 2 ) then
       do mgs = 1,ngscnt
        cx(mgs,lc) = Max(an(igs(mgs),jy,kgs(mgs),lnc), 0.0)
        cwnccn(mgs) = cwccn*rho0(mgs)/rho00 ! background ccn count
        cn(mgs) = 0.0
        IF ( lss > 1 ) THEN 
          ssmax(mgs) = an(igs(mgs),jy,kgs(mgs),lss)
        ELSE
          ssmax(mgs) = 0.0
        ENDIF
        IF ( lccn .gt. 1 ) THEN
          ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn)
        ELSE
          ccnc(mgs) = cwnccn(mgs)
        ENDIF
        IF ( lccnuf .gt. 1 ) THEN
          ccncuf(mgs) = an(igs(mgs),jy,kgs(mgs),lccnuf)
        ELSE
          ccncuf(mgs) = 0.0
        ENDIF
        cnuf(mgs) = 0.0
        IF ( lccna > 1 ) THEN
          ccna(mgs) = an(igs(mgs),jy,kgs(mgs),lccna) ! predicted count of activated ccn
        ELSE
          IF ( lccn > 1 ) THEN
            ccna(mgs) = cwnccn(mgs) - ccnc(mgs) ! diagnose activated ccn as background value - remaining unactivated ccn
          ELSE
            ccna(mgs) = cx(mgs,lc) ! approximation of number of activated ccn
          ENDIF
        ENDIF
       end do
      end if
      if ( ipconc .ge. 3 ) then
       do mgs = 1,ngscnt
        cx(mgs,lr) = Max(an(igs(mgs),jy,kgs(mgs),lnr), 0.0)
       end do
      end if

!        cnuc(1:ngscnt) = cwccn*rho0(mgs)/rho00*(1. - renucfrac) + ccnc(1:ngscnt)*renucfrac
       DO mgs = 1,ngscnt
       ! default value of renucfrac is 0.0
        IF ( irenuc /= 6 ) THEN
        cnuc(mgs) = Max(ccnc(mgs),cwnccn(mgs))*(1. - renucfrac) + ccnc(mgs)*renucfrac
        ELSE
        cnuc(mgs) = Max(ccnc(mgs),cwnccn(mgs))*(1. - renucfrac) + Max(0.0,ccnc(mgs) - ccna(mgs))*renucfrac
        ENDIF
        IF ( renucfrac >= 0.999 ) THEN
          IF ( temg(mgs) < 265. ) THEN
            IF ( qx(mgs,lc) > 10.*qxmin(lc) .and. w(igs(mgs),jgs,kgs(mgs)) > 2.0 ) THEN
             cnuc(mgs) = 0.0 !  Min(cnuc(mgs), 0.5*cx(mgs,lc) ) ! Hack to reduce nucleation at low temp in updraft when ccn are not predicted
            ELSE
             cnuc(mgs) = 0.1*cnuc(mgs)
            ENDIF
          ENDIF
        ENDIF
       ENDDO

!  Set density
!
      if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: Set density'

      do mgs = 1,ngscnt
        xdn(mgs,lc) = xdn0(lc)
        xdn(mgs,lr) = xdn0(lr)
      end do

      ventrx(:) = ventr
      ventrxn(:) = ventrn
      


!       write(0,*) 'NUCOND: Set ssf variables, ssmxinit =',ssmxinit
      ssmx = 0.0
      DO mgs = 1,ngscnt
      
      kp1 = Min(nz, kgs(mgs)+1 )
      wvel(mgs) = (0.5)*(w(igs(mgs),jgs,kp1) & 
     &                  +w(igs(mgs),jgs,kgs(mgs)))
      wvelkm1(mgs) = (0.5)*(w(igs(mgs),jgs,kgs(mgs)) & 
     &                  +w(igs(mgs),jgs,Max(1,kgs(mgs)-1)))

      ssat0(mgs)  = ssfilt(igs(mgs),jgs,kgs(mgs))
      ssf(mgs)    = ssfilt(igs(mgs),jgs,kgs(mgs))
!      ssmx = Max( ssmx, ssf(mgs) )

      
      ssfkp1(mgs) = ssfilt(igs(mgs),jgs,Min(nz-1,kgs(mgs)+1))
      ssfkm1(mgs) = ssfilt(igs(mgs),jgs,Max(1,kgs(mgs)-1))


      ENDDO



!
!  cloud water variables
!

      if ( ndebug .gt. 0 )write(0,*) 'ICEZVD_DR: Set cloud water variables'

      do mgs = 1,ngscnt
      xv(mgs,lc) = 0.0
      IF ( ipconc .ge. 2 .and. cx(mgs,lc) .gt. 1.0e6 ) THEN
        xmas(mgs,lc) = &
     &    min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx )
        xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc)
      ELSE
       IF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. cxmin ) THEN
        xmas(mgs,lc) = &
     &     min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),xdn(mgs,lc)*xvmn(lc)), &
     &      xdn(mgs,lc)*xvmx(lc) )

        cx(mgs,lc) = qx(mgs,lc)*rho0(mgs)/xmas(mgs,lc)

       ELSEIF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .le. cxmin ) THEN
!        xmas(mgs,lc) = xdn(mgs,lc)*4.*pi/3.*(5.0e-6)**3
!        cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc)
        cx(mgs,lc) = Max( cxmin, rho0(mgs)*qx(mgs,lc)/cwmasx )
        xmas(mgs,lc) =  &
     &    min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx )
        xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc)

       ELSE
        xmas(mgs,lc) = cwmasn
       ENDIF
      ENDIF
      xdia(mgs,lc,1) = (xmas(mgs,lc)*cwc1)**c1f3


      end do
!
! rain
!
      do mgs = 1,ngscnt
      if ( qx(mgs,lr) .gt. qxmin(lr) ) then

      if ( ipconc .ge. 3 ) then
        xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-9,cx(mgs,lr)))
!      parameter( xvmn(lr)=2.8866e-13, xvmx(lr)=4.1887e-9 )  ! mks
        IF ( xv(mgs,lr) .gt. xvmx(lr) ) THEN
          xv(mgs,lr) = xvmx(lr)
          cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmx(lr)*xdn(mgs,lr))
        ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN
          xv(mgs,lr) = xvmn(lr)
          cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr))
        ENDIF

        xmas(mgs,lr) = xv(mgs,lr)*xdn(mgs,lr)
        xdia(mgs,lr,3) = (xmas(mgs,lr)*cwc1)**(1./3.) ! xdia(mgs,lr,1)
        IF ( imurain == 3 ) THEN
!          xdia(mgs,lr,1) = (6.*pii*xv(mgs,lr)/(alpha(mgs,lr)+1.))**(1./3.)
          xdia(mgs,lr,1) = xdia(mgs,lr,3) ! formulae for Ziegler (1985) use mean volume diameter, not lambda**(-1)
        ELSE ! imurain == 1, Characteristic diameter (1/lambda)
          xdia(mgs,lr,1) = (6.*piinv*xv(mgs,lr)/((alpha(mgs,lr)+3.)*(alpha(mgs,lr)+2.)*(alpha(mgs,lr)+1.)))**(1./3.)
        ENDIF
!        rwrad(mgs) = 0.5*xdia(mgs,lr,1)

! Inverse exponential version:
!        xdia(mgs,lr,1) =
!     >  (qx(mgs,lr)*rho0(mgs)
!     > /(pi*xdn(mgs,lr)*cx(mgs,lr)))**(0.333333)
      ELSE
        xdia(mgs,lr,1) = &
     &  (qx(mgs,lr)*rho0(mgs)/(pi*xdn(mgs,lr)*cno(lr)))**(0.25)
      end if
      else
        xdia(mgs,lr,1) = 1.e-9
!        rwrad(mgs) = 0.5*xdia(mgs,lr,1)
      end if

      end do


!
!  Ventilation coefficients

      do mgs = 1,ngscnt


      fadvisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))* & 
     &  (temg(mgs)/296.0)**(1.5)

      fakvisc(mgs) = fadvisc(mgs)*rhoinv(mgs)

      fwvdf(mgs) = (2.11e-05)*((temg(mgs)/tfr)**1.94)* & 
     &  (101325.0/(pres(mgs)))
      
      fschm(mgs) = (fakvisc(mgs)/fwvdf(mgs))

      fvent(mgs) = (fschm(mgs)**(1./3.)) * (fakvisc(mgs)**(-0.5))

      end do
!
!
!  Ziegler nucleation 
!
!
! cloud evaporation, condensation, and nucleation
!  sqsat -> qss(mgs)

      DO mgs=1,ngscnt
        dcloud = 0.0
        IF ( temg(mgs) .le. tfrh .and. qx(mgs,lv)/qvs(mgs) < maxsupersat ) THEN
         CYCLE
        ENDIF

      IF( ssat0(mgs) .GT. 0. .OR. ssf(mgs) .GT. 0. ) GO TO 620
!6/4      IF( qvap(mgs) .EQ. qss(mgs) ) GO TO 631
!
!.... EVAPORATION. QV IS LESS THAN qss(mgs).
!.... EVAPORATE CLOUD FIRST
!
      IF ( qx(mgs,lc) .LE. 0. ) GO TO 631
!.... CLOUD EVAPORATION.
! convert input 'cp' to cgs
      R1=1./(1. + caw*(273.15 - cbw)*qss(mgs)*felv(mgs)/ &
     &            (cp*(temg(mgs) - cbw)**2))
      QEVAP= Min( qx(mgs,lc), R1*(qss(mgs)-qvap(mgs)) )


      IF ( qx(mgs,lc) .LT. QEVAP ) THEN ! GO TO 63
        qwvp(mgs) = qwvp(mgs) + qx(mgs,lc)
        thetap(mgs) = thetap(mgs) - felv(mgs)*qx(mgs,lc)/(cp*pi0(mgs))
        IF ( io_flag .and. nxtra > 1 ) THEN
           axtra(igs(mgs),jy,kgs(mgs),1) = -qx(mgs,lc)/dtp
        ENDIF
        qx(mgs,lc) = 0.
        IF ( restoreccn ) THEN
          IF ( irenuc <= 2 ) THEN
             IF ( .not. invertccn ) THEN
              ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) )
             ELSE
              ccnc(mgs) = ccnc(mgs) + cx(mgs,lc)
             ENDIF
          ENDIF
          IF ( lccna > 1 ) THEN
            ccna(mgs) = ccna(mgs) - cx(mgs,lc)
          ENDIF
        ENDIF
        cx(mgs,lc) = 0.
      ELSE
        qctmp = qx(mgs,lc)
        qwvp(mgs) = qwvp(mgs) + QEVAP
        qx(mgs,lc) = qx(mgs,lc) - QEVAP
        IF ( qx(mgs,lc) .le. 0. ) THEN
          IF ( restoreccn ) THEN
            IF ( irenuc <= 2 ) THEN
!              ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) )
!              ccnc(mgs) = ccnc(mgs) + cx(mgs,lc)
              IF ( .not. invertccn ) THEN
               ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) )
              ELSE
               ccnc(mgs) = ccnc(mgs) + cx(mgs,lc)
              ENDIF
            ENDIF
            IF ( lccna > 1 ) THEN
              ccna(mgs) = ccna(mgs) - cx(mgs,lc)
            ENDIF
          ENDIF
          cx(mgs,lc) = 0.
        ELSE
          tmp = 0.9*QEVAP*cx(mgs,lc)/qctmp ! let droplets get smaller but also remove some. A factor of 1.0 would maintain same size
          IF ( restoreccn ) THEN
            IF ( irenuc <= 2 ) THEN
 !             ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + tmp ) )
!              ccnc(mgs) = ccnc(mgs) + tmp
              IF ( .not. invertccn ) THEN
               ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + tmp ) )
              ELSE
               ccnc(mgs) = ccnc(mgs) + tmp
              ENDIF
            ENDIF
            IF ( lccna > 1 ) THEN
              ccna(mgs) = ccna(mgs) - tmp
            ENDIF
          ENDIF
          cx(mgs,lc) = cx(mgs,lc) - tmp
        ENDIF
        thetap(mgs) = thetap(mgs) - felv(mgs)*QEVAP/(CP*pi0(mgs))
        IF ( io_flag .and. nxtra > 1 ) THEN
           axtra(igs(mgs),jy,kgs(mgs),1) = -QEVAP/dtp
        ENDIF

      ENDIF

      GO TO 631


  620 CONTINUE

!.... CLOUD CONDENSATION

        IF ( qx(mgs,lc) .GT. qxmin(lc) .and. cx(mgs,lc) .ge. 1. ) THEN



!       ac1 =  xdn(mgs,lc)*elv(kgs(mgs))**2*epsi/
!     :        (tka(kgs(mgs))*rw*temg(mgs)**2)
! took out xdn factor because it cancels later...
       ac1 =  felv(mgs)**2/(tka(mgs)*rw*temg(mgs)**2)


!       bc = xdn(mgs,lc)*rw*temg(mgs)/
!     :       (epsi*wvdf(kgs(mgs))*es(mgs))
! took out xdn factor because it cancels later...
       bc =   rw*temg(mgs)/(wvdf(mgs)*es(mgs))

!       bs = rho0(mgs)*((rd*temg(mgs)/(epsi*es(mgs)))+
!     :             (epsi*elv(kgs(mgs))**2/(pres(mgs)*temg(mgs)*cp)))

!       taus = Min(dtp, xdn(mgs,lc)*rho0(mgs)*(ac1+bc)/
!     :        (4*pi*0.89298*BS*0.5*xdia(mgs,lc,1)*cx(mgs,lc)*xdn(mgs,lc)))

!
      IF ( ssf(mgs) .gt. 0.0 .or. ssat0(mgs) .gt. 0.0 ) THEN
       IF ( ny .le. 2 ) THEN
!        write(0,*)  'undershoot: ',ssf(mgs),
!     :   ( (qx(mgs,lv) - dcloud)/c1 - 1.0)*100.
       ENDIF



       IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN

         IF ( xdia(mgs,lc,1) .le. 0.0 ) THEN
          xmas(mgs,lc) = cwmasn
          xdia(mgs,lc,1) = (xmas(mgs,lc)*cwc1)**c1f3
         ENDIF
        d1 = (1./(ac1 + bc))*4.0*pi*ventc &
     &        *0.5*xdia(mgs,lc,1)*cx(mgs,lc)*rhoinv(mgs)

       ELSE
         d1 = 0.0
       ENDIF

       IF ( rcond .eq. 2 .and. qx(mgs,lr) .gt. qxmin(lr) .and. cx(mgs,lr) > 1.e-9 ) THEN
          IF ( imurain == 3 ) THEN
           IF ( izwisventr == 1 ) THEN
            rwvent(mgs) = ventrx(mgs)*(1.6 + 124.9*(1.e-3*rho0(mgs)*qx(mgs,lr))**.2046)
           ELSE ! izwisventr = 2
!  Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br
          rwvent(mgs) =   &
     &  (0.78*ventrx(mgs) + 0.308*ventrxn(mgs)*fvent(mgs)   &
     &   *Sqrt((ar*rhovt(mgs)))   &
     &    *(xdia(mgs,lr,1)**((1.0+br)/2.0)) )
           ENDIF

          ELSE ! imurain == 1

           IF ( iferwisventr == 1 ) THEN
             alpr = Min(alpharmax,alpha(mgs,lr) )
!             alpr = alpha(mgs,lr)
             x =  1. + alpr

              tmp = 1 + alpr
              i = Int(dgami*(tmp))
              del = tmp - dgam*i
              g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami

              tmp = 2.5 + alpr + 0.5*bx(lr)
              i = Int(dgami*(tmp))
              del = tmp - dgam*i
              y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp ! ratio of gamma functions

!         vent1 = dble(xdia(mgs,lr,1))**(-2. - alpr) ! Actually OK
!         vent2 = dble(1./xdia(mgs,lr,1) + 0.5*fx(lr))**dble(2.5+alpr+0.5*bx(lr))  ! Actually OK
         vent1 = dble(xdia(mgs,lr,1))**(0.5 + 0.5*bx(lr)) ! 2016.2.26 Changed for consistency with derivation (recast formula)
         vent2 = dble(1. + 0.5*fx(lr)*xdia(mgs,lr,1))**dble(2.5+alpr+0.5*bx(lr))
        
        
        rwvent(mgs) =    &
     &    0.78*x +    &
     &    0.308*fvent(mgs)*y*   &
     &            Sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2)

           ELSEIF ( iferwisventr == 2 ) THEN
          
!  Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br
            x =  1. + alpha(mgs,lr)

            rwvent(mgs) =   &
     &        (0.78*x + 0.308*ventrxn(mgs)*fvent(mgs)   &
     &         *Sqrt((ar*rhovt(mgs)))   &
     &         *(xdia(mgs,lr,1)**((1.0+br)/2.0)) )

          
          ENDIF ! iferwisventr
          
       ENDIF ! imurain

       d1r = (1./(ac1 + bc))*4.0*pi*rwvent(mgs) & 
     &        *0.5*xdia(mgs,lr,1)*cx(mgs,lr)*rhoinv(mgs)
       ELSE
       d1r = 0.0
       ENDIF
       
       
       e1  = felvcp(mgs)/(pi0(mgs))
       f1 = pk(mgs) ! (pres(mgs)/poo)**cap

!
!  fifth trial to see what happens:
!
       ltemq = (temg(mgs)-163.15)/fqsat+1.5
       ltemq = Min( nqsat, Max(1,ltemq) )
       ltemq1 = ltemq
       temp1 = temg(mgs)
       p380 = 380.0/pres(mgs)

!       taus = Max( 0.05*dtp, Min(taus, 0.25*dtp ) )
!       nc = NInt(dtp/Min(1.0,0.5*taus))
!       dtcon = dtp/float(nc)
       ss1 = qx(mgs,lv)/qvs(mgs)
       ss2 = ss1
       temp2 = temp1
       qv1 = qx(mgs,lv)
       qvs1 = qvs(mgs)
       qis1 = qis(mgs)
       dt1 = 0.0


!          dtcon = Max(dtcon,0.2)
!          nc = Nint(dtp/dtcon)

       ltemq1 = ltemq
! want to start out with a small time step to handle the steep slope
! and fast changes, then can switch to a larger step (dtcon2) for the
! rest of the big time step.
! base the initial time step (dtcon1) on the slope (delta)
       IF ( Abs(ss1 - 1.0) .gt. 1.e-5 ) THEN
         delta = 0.5*(qv1-qvs1)/(d1*(ss1 - 1.0))
       ELSE
         delta = 0.1*dtp
       ENDIF
! delta is the extrapolated time to get halfway from qv1 to qvs1
! want at least 5 time steps to the halfway point, so multiply by 0.2
! for the initial time step
       dtcon1 = Min(0.05,0.2*delta)
       nc = Max(5,2*NInt( (dtp-4.0*dtcon1)/delta))
       dtcon2 = (dtp-4.0*dtcon1)/nc

       n = 1
       dt1 = 0.0
       nc = 0
       dqc = 0.0
       dqr = 0.0
       dqi = 0.0
       dqs = 0.0
       dqvii = 0.0
       dqvis = 0.0

       RK2c: DO WHILE ( dt1 .lt. dtp )
          nc = 0
          IF ( n .le. 4 ) THEN
            dtcon = dtcon1
          ELSE
            dtcon = dtcon2
          ENDIF
 609       dqv  = -(ss1 - 1.)*d1*dtcon
           dqvr = -(ss1 - 1.)*d1r*dtcon
            dtemp = -0.5*e1*f1*(dqv + dqvr)
!          write(0,*) 'RK2c dqv1 = ',dqv
! calculate midpoint values:
     !      ltemq1m = ltemq1 + Nint(dtemp*fqsat + 0.5)

         ! 7.6.2016: Test full calc of ltemq
           ltemq1m = (temp1+dtemp-163.15)*fqsati+1.5
           ltemq1m = Min( nqsat, Max(1,ltemq1m) )

           IF ( ltemq1m .lt. 1 .or. ltemq1m .gt. nqsat ) THEN
             write(0,*) 'STOP in nucond line 1192 '
             write(0,*) ' ltemq1m,icond = ',ltemq1m,icond
             write(0,*) ' dtemp,e1,f1,dqv,dqvr = ', dtemp,e1,f1,dqv,dqvr
             write(0,*) ' d1,d1r,dtcon,ss1 = ',d1,d1r,dtcon,ss1
             write(0,*) ' dqc, dqr = ',dqc,dqr
             write(0,*) ' qv,qc,qr = ',qx(mgs,lv)*1000.,qx(mgs,lc)*1000.,qx(mgs,lr)*1000.
             write(0,*) ' i, j, k = ',igs(mgs),jy,kgs(mgs)
             write(0,*) ' dtcon1,dtcon2,delta = ',dtcon1,dtcon2,delta
             write(0,*) ' nc,dtp = ',nc,dtp
             write(0,*) ' rwvent,xdia,crw,ccw = ', rwvent(mgs),xdia(mgs,lr,1),cx(mgs,lr),cx(mgs,lc)
             write(0,*) ' fvent,alphar = ',fvent(mgs),alpha(mgs,lr)
             write(0,*) ' xvr,xmasr,xdnr,cwc1 = ',xv(mgs,lr),xmas(mgs,lr),xdn(mgs,lr),cwc1
           ENDIF
            dqvs = dtemp*p380*dtabqvs(ltemq1m)
            qv1m = qv1 + dqv + dqvr
!          qv1mr = qv1r + dqvr

            qvs1m = qvs1 + dqvs
            ss1m = qv1m/qvs1m

    ! check for undersaturation when no ice is present, if so, then reduce time step
          IF ( ss1m .lt. 1.  .and. (dqvii + dqvis) .eq. 0.0 ) THEN
            dtcon = (0.5*dtcon)
            IF ( dtcon .ge. dtcon1 ) THEN
             GOTO 609
            ELSE
             EXIT
            ENDIF
          ENDIF
! calculate full step:
          dqv  = -(ss1m - 1.)*d1*dtcon
          dqvr = -(ss1m - 1.)*d1r*dtcon


!          write(0,*) 'RK2a dqv1m = ',dqv
          dtemp = -e1*f1*(dqv + dqvr)
          
         ! ltemq1 = ltemq1 + Nint(dtemp*fqsat + 0.5)

         ! 7.6.2016: Test full calc of ltemq
           ltemq1 = (temp1+dtemp-163.15)*fqsati+1.5
           ltemq1 = Min( nqsat, Max(1,ltemq1) )

           IF ( ltemq1 .lt. 1 .or. ltemq1 .gt. nqsat ) THEN
             write(0,*) 'STOP in nucond line 1230 '
             write(0,*) ' ltemq1m,icond = ',ltemq1m,icond
             write(0,*) ' dtemp,e1,dqv,dqvr = ', dtemp,e1,dqv,dqvr
           ENDIF
          dqvs = dtemp*p380*dtabqvs(ltemq1)

          qv1 = qv1 + dqv + dqvr

          dqc = dqc - dqv
          dqr = dqr - dqvr

          qvs1 = qvs1 + dqvs
          ss1 = qv1/qvs1
          temp1 = temp1 + dtemp
          IF ( temp2 .eq. temp1 .or. ss2 .eq. ss1 .or.  &
     &           ss1 .eq. 1.00 .or.  &
     &      ( n .gt. 10 .and. ss1 .lt. 1.0005 ) ) THEN
!           write(0,*) 'RK2c break'
           EXIT
          ELSE
           ss2 = ss1
           temp2 = temp1
           dt1 = dt1 + dtcon
           n = n + 1
          ENDIF
       ENDDO RK2c


        dcloud = dqc ! qx(mgs,lv) - qv1
        thetap(mgs) = thetap(mgs) + e1*(DCLOUD + dqr)


        IF ( eqtset > 2 ) THEN
           pipert(mgs) = pipert(mgs) + felvpi(mgs)*(DCLOUD + dqr)
        ENDIF
        IF ( io_flag .and. nxtra > 1 ) THEN
           axtra(igs(mgs),jy,kgs(mgs),1) = DCLOUD/dtp
           axtra(igs(mgs),jy,kgs(mgs),2) = axtra(igs(mgs),jy,kgs(mgs),2) + dqr/dtp
        ENDIF
        qwvp(mgs) = qwvp(mgs) - (DCLOUD + dqr)
        qx(mgs,lc) = qx(mgs,lc) + DCLOUD
        qx(mgs,lr) = qx(mgs,lr) + dqr
!        t9(igs(mgs),jy,kgs(mgs)) = t9(igs(mgs),jy,kgs(mgs)) + (DCLOUD + dqr)/dtp*felv(mgs)/(cp*pi0(mgs)) !* &
!!     &                 dx*dy*dz3d(igs(mgs),jy,kgs(mgs))


        theta(mgs) = thetap(mgs) + theta0(mgs)
        temg(mgs) = theta(mgs)*f1
        ltemq = (temg(mgs)-163.15)/fqsat+1.5
        ltemq = Min( nqsat, Max(1,ltemq) )
        qvs(mgs) = pqs(mgs)*tabqvs(ltemq)
!        es(mgs) = 6.1078e2*tabqvs(ltemq)

!

      ENDIF  ! dcloud .gt. 0.


      ELSE  ! qc .le. qxmin(lc)

!        IF ( ssf(mgs) .gt. 0.0 .and. .not. flag_qndrop ) THEN ! flag_qndrop turns off primary nucleation when using wrf-chem with progn=1
        IF ( ssf(mgs) .gt. 0.0 ) THEN ! .and.  ssmax(mgs) .lt. sscb ) THEN ! except that wrf-chem does not seem to initialize qc for activated aerosols, so keep this, after all

          IF ( iqcinit == 1 ) THEN

         qvs0   = 380.*exp(17.27*(temg(mgs)-273.)/(temg(mgs)- 36.))/pk(mgs)

         dcloud = Max(0.0, (qx(mgs,lv)-qvs0) / (1.+qvs0*f5/(temg(mgs)-36.)**2) )

          ELSEIF ( iqcinit == 3 ) THEN
              R1=1./(1. + caw*(273.15 - cbw)*qss(mgs)*felvcp(mgs)/ & 
     &             ((temg(mgs) - cbw)**2))
            DCLOUD=R1*(qvap(mgs) - qvs(mgs))  ! KW model adjustment; 
                              ! this will put mass into qc if qv > sqsat exists
          
          ELSEIF ( iqcinit == 2 ) THEN
!              R1=1./(1. + caw*(273.15 - cbw)*qss(mgs)*felv(mgs)/
!     :             (cp*(temg(mgs) - cbw)**2))
!            DCLOUD=R1*(qvap(mgs) - qvs(mgs))  ! KW model adjustment; 
                              ! this will put mass into qc if qv > sqsat exists
         ssmx = ssmxinit

!          IF ( ssf(mgs) > ssmx  .and. ssmax(mgs) < 3.0 ) THEN
!          IF ( ssf(mgs) > ssmx  .and. ccnc(mgs) > 1.0 ) THEN
!          IF ( ssf(mgs) > ssmx  .and. ssf(mgs) < 5.0 .and. ccnc(mgs) > 0.1*cwnccn(mgs) ) THEN ! this one works
!          IF ( ssf(mgs) > ssmx  .and. ssf(mgs) < 20.0 ) THEN ! test -- fails
!          IF ( ssf(mgs) > ssmx  .and. ssf(mgs) < 20.0 .and. ccnc(mgs) > 0.1*cwnccn(mgs)) THEN ! test -- is OK
          IF ( ssf(mgs) > ssmx  .and. ssf(mgs) < 20.0 .and. ccnc(mgs) > 0.05*cwnccn(mgs)) THEN ! test
!          IF ( ssf(mgs) > ssmx ) THEN ! original condition
           CALL QVEXCESS(ngs,mgs,qwvp,qv0,qx(1,lc),pres,thetap,theta0,dcloud, & 
     &      pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ssmx,pk,ngscnt)
          ELSE
            dcloud = 0.0
          ENDIF
         ENDIF
        ELSE
            dcloud = 0.0
        ENDIF

        thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs))
        qwvp(mgs) = qwvp(mgs) - DCLOUD
        qx(mgs,lc) = qx(mgs,lc) + DCLOUD
        IF ( io_flag .and. nxtra > 1 ) THEN
           axtra(igs(mgs),jy,kgs(mgs),1) = DCLOUD/dtp
        ENDIF
        theta(mgs) = thetap(mgs) + theta0(mgs)
        temg(mgs) = theta(mgs)*pk(mgs) !( pres(mgs) / poo ) ** cap
!        temg(mgs) = theta2temp( theta(mgs), pres(mgs) )
        ltemq = (temg(mgs)-163.15)/fqsat+1.5
        ltemq = Min( nqsat, Max(1,ltemq) )
        qvs(mgs) = pqs(mgs)*tabqvs(ltemq)
!        es(mgs) = 6.1078e2*tabqvs(ltemq)

!.... S. TWOMEY (1959)
! Note: get here if there is no previous cloud water and w > 0.
      cn(mgs) = 0.0
      
      IF ( ncdebug .ge. 1 ) THEN
        write(iunit,*) 'at 613: ',qx(mgs,lc),cx(mgs,lc),wvel(mgs),ssmax(mgs),kgs(mgs)
      ENDIF
      
      IF (  .not. flag_qndrop ) THEN ! { do not calculate number of droplets if using wrf-chem

      
!      IF ( ssmax(mgs) .lt. sscb .and. qx(mgs,lc) .gt. qxmin(lc)) THEN
      IF ( dcloud .gt. qxmin(lc) .and. wvel(mgs) > 0.0) THEN
!       CN(mgs) =   CCNE*wvel(mgs)**cnexp ! *Min(1.0,1./dtp) ! 0.3465
       CN(mgs) =   CCNE0*cnuc(mgs)**(2./(2.+cck))*wvel(mgs)**cnexp ! *Min(1.0,1./dtp) ! 0.3465
        IF ( ny .le. 2 .and. cn(mgs) .gt. 0.0    &
     &                    .and. ncdebug .ge. 1 ) THEN 
          write(iunit,*) 'CN: ',cn(mgs)*1.e-6, cx(mgs,lc)*1.e-6, qx(mgs,lc)*1.e3,   &
     &       wvel(mgs), dcloud*1.e3
          IF ( cn(mgs) .gt. 1.0 ) write(iunit,*) 'cwrad = ',   &
     &       1.e6*(rho0(mgs)*qx(mgs,lc)/cn(mgs)*cwc1)**c1f3,   &
     &   igs(mgs),kgs(mgs),temcg(mgs),    &
     &   1.e3*an(igs(mgs),jgs,kgs(mgs)-1,lc)
        ENDIF
        IF ( iccwflg .eq. 1 ) THEN
          cn(mgs) = Min(cwccn*rho0(mgs)/rho00, Max(cn(mgs),   &
     &       rho0(mgs)*qx(mgs,lc)/(xdn(mgs,lc)*(4.*pi/3.)*(4.e-6)**3)))
        ENDIF
      ELSE
       cn(mgs) = 0.0
       dcloud = 0.0
!          cn(mgs) = Min(cwccn,    &
!     &       rho0(mgs)*dcloud/(xdn(mgs,lc)*(4.*pi/3.)*(4.e-6)**3) )
      ENDIF

      IF ( cn(mgs) .gt. 0.0 ) THEN
       IF ( cn(mgs) .gt. ccnc(mgs) ) THEN
         cn(mgs) = ccnc(mgs)
!         ccnc(mgs) = 0.0
       ENDIF
!      cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
      IF ( irenuc <= 2 ) ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
      ccna(mgs) = ccna(mgs) + cn(mgs)
      ENDIF

!       write(91,*) 'nuc1: cn, ix, kz = ',cn(mgs),igs(mgs),kgs(mgs),wvel(mgs),cnexp,ccnc(mgs)

      IF( CN(mgs) .GT. cx(mgs,lc) ) cx(mgs,lc) = CN(mgs)
      IF( cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .le. qxmin(lc) ) THEN
        cx(mgs,lc) = 0.
      ELSE
        cx(mgs,lc) = Min(cx(mgs,lc),rho0(mgs)*Max(0.0,qx(mgs,lc))/cwmasn)
      ENDIF
      
      ENDIF ! }.not. flag_qndrop

        GOTO 613
        
        END IF ! qc .gt. 0.

!        ES=EES(PIB(K)*PT)
!        SQSAT=EPSI*ES/(PB(K)*1000.-ES)

!.... CLOUD NUCLEATION
!      T=PIB(K)*PT
!      ES=1.E3*PB(K)*QV/EPSI

      IF ( wvel(mgs) .le. 0. ) GO TO 616
      IF ( cx(mgs,lc) .le. 0. )  GO TO 613                             !TWOMEY (1959) Nucleation
      IF ( kzbeg-1+kgs(mgs) .GT. 1 .and. qx(mgs,lc) .le. qxmin(lc)) GO TO 613  !TWOMEY (1959) Nucleation
      IF ( kzbeg-1+kgs(mgs) .eq. 1 .and. wvel(mgs) .gt. 0. ) GO TO 613         !TWOMEY (1959) Nucleation
!.... ATTEMPT ZIEGLER CLOUD NUCLEATION IN CLOUD INTERIOR UNLESS...
  616 IF ( ssf(mgs) .LE. SUPCB .AND. wvel(mgs) .GT. 0. ) GO TO 631 !... weakly saturated updraft
      IF ( kzbeg-1+kgs(mgs) .GT. 1 .AND. kzbeg-1+kgs(mgs) .LT. nzend-1 .AND.  &
     &    (ssfkp1(mgs) .GE. SUPMX .OR. &
     &     ssf(mgs)    .GE. SUPMX .OR. &
     &     ssfkm1(mgs) .GE. SUPMX)) GO TO 631                      !... too much vapour
      IF (ssf(mgs) .LT. 1.E-10 .OR. ssf(mgs) .GE. SUPMX) GO TO 631 !... at the extremes for ss

!
! get here if ( qc > 0 and ss > supcb) or (w < 0)
!

      if (ndebug .gt. 0) write(0,*) "ICEZVD_DR: Entered Ziegler Cloud Nucleation" !mpidebug

      DSSDZ=0.
      r2dzm=0.50/dz3d(igs(mgs),jy,kgs(mgs))
      IF ( irenuc >= 0 .and. .not. flag_qndrop) THEN ! turn off nucleation when flag_qndrop (using WRF-CHEM for activation)

      IF ( irenuc < 2 ) THEN !{

        IF ( kzend == nzend ) THEN
          t0p3 = t0(igs(mgs),jgs,Min(kze,kgs(mgs)+3))
          t0p1 = t0(igs(mgs),jgs,Min(kze,kgs(mgs)+1))
        ELSE
          t0p3 = t0(igs(mgs),jgs,kgs(mgs)+3)
          t0p1 = t0(igs(mgs),jgs,kgs(mgs)+1)
        ENDIF

      IF ( ( ssf(mgs) .gt. ssmax(mgs) .or.  irenuc .eq. 1 ) &
     &   .and.  ( ( lccn .lt. 1 .and.  &
     &            cx(mgs,lc) .lt. cwccn*(Min(1.0,rho0(mgs)))) .or. &
     &    ( lccn .gt. 1 .and. ccnc(mgs) .gt. 0. )   ) &
     &    ) THEN
      IF( kzbeg-1+kgs(mgs) .GT. 1 .AND. kzbeg-1+kgs(mgs) .LT. nzend-1 &
     &  .and. ssf(mgs) .gt. 0.0 &
     &  .and. ssfkp1(mgs) .LT. SUPMX .and. ssfkp1(mgs) .ge. 0.0  &
     &  .AND. ssfkm1(mgs) .LT. SUPMX .AND. ssfkm1(mgs) .ge. 0.0  &
     &  .AND. ssfkp1(mgs) .gt. ssfkm1(mgs)  &
     &  .and. t0p3 .gt. 233.2) THEN
          DSSDZ = (ssfkp1(mgs) - ssfkm1(mgs))*R2DZM
!
! otherwise check for cloud base condition with updraft:
!
        ELSEIF( kzbeg-1+kgs(mgs) .GT. 1 .AND. kzbeg-1+kgs(mgs) .LT. nzend-1 &
!        IF( kgs(mgs) .GT. 1 .AND. kgs(mgs) .LT. NZ-1 & !)
     &  .and. ssf(mgs) .gt. 0.0  .and. wvel(mgs) .gt. 0.0 &
     &  .and. ssfkp1(mgs) .gt. 0.0   &
     &  .AND. ssfkm1(mgs) .le. 0.0 .and. wvelkm1(mgs) .gt. 0.0 &
     &  .AND. ssf(mgs) .gt. ssfkm1(mgs)  &
     &  .and. t0p1 .gt. 233.2) THEN
         DSSDZ = 2.*(ssf(mgs) - ssfkm1(mgs))*R2DZM  ! 1-sided difference
        ENDIF

       ENDIF
!
!CLZ  IF(wijk.LE.0.) CN=CCN*ssfilt(ix,jy,kz)**CCK
! note: CCN -> cwccn, DELT -> dtp
      c1 = Max(0.0, rho0(mgs)*(qx(mgs,lv) - qss(mgs))/ &
     &        (xdn(mgs,lc)*(4.*pi/3.)*(4.e-6)**3))
      IF ( lccn .lt. 1 ) THEN
       CN(mgs) = cwccn*rho0(mgs)/rho00*CCK*ssf(mgs)**CCKM*dtp*   &
     & Max(0.0,    &
     &         (wvel(mgs)*DSSDZ) )      ! probably the vertical gradient dominates
      ELSE
      CN(mgs) =  &
     &    Min(ccnc(mgs), cnuc(mgs)*CCK*ssf(mgs)**CCKM*dtp*   &
     & Max(0.0,    &
     &         ( wvel(mgs)*DSSDZ) )  )
!      IF ( cn(mgs) .gt. 0 ) ccnc(mgs) = ccnc(mgs) - cn(mgs)
      ENDIF

      IF ( cn(mgs) .gt. 0.0 ) THEN
       IF ( ccnc(mgs) .lt. 5.e7 .and. cn(mgs) .ge. 5.e7 ) THEN
          cn(mgs) = 5.e7
          ccnc(mgs) = 0.0
       ELSEIF ( cn(mgs) .gt. ccnc(mgs) ) THEN
         cn(mgs) = ccnc(mgs)
         ccnc(mgs) = 0.0
       ENDIF
      cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
      ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
      ENDIF

      ELSEIF ( irenuc == 2 ) THEN !} { 
      ! simple Twomey scheme
!      if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR:  Cloud reNucleation, wvel = ',wvel(mgs)
       CN(mgs) =   CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp ! *Min(1.0,1./dtp) ! 0.3465
!      ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck))
!!!       CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from
               ! Philips, Donner et al. 2007, but results in too much limitation of
               ! nucleation
       CN(mgs) = Min(cn(mgs), ccnc(mgs))
       cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass
       
        IF ( .false. .and. ny <= 2 ) THEN
          write(0,*) 'i,k, cwmasn = ',igs(mgs),kgs(mgs),cwmasn
          write(0,*) 'wvel, cnuc, cn = ',wvel(mgs),cnuc(mgs),cn(mgs)
          write(0,*) 'ccne0,cnexp,cck = ',ccne0,cnexp,cck
          write(0,*) 'part1, part2 = ',CCNE0*cnuc(mgs)**(2./(2.+cck)), Max(0.0,wvel(mgs))**cnexp
          write(0,*) 'ccnc, dqc, dqc/cwmasn = ',ccnc(mgs), dqc, 0.5*dqc/cwmasn
        ENDIF
       
       IF ( icnuclimit > 0 ) THEN 
         tmp = ccnc(mgs) + cx(mgs,lc)
         IF ( tmp < 330.34e6 ) THEN
           ccwmax = 1.1173e6 * (1.e-6*tmp)**0.9504
         ELSE
           ccwmax = 21.57e6 * (1.e-6*tmp)**0.44
         ENDIF
         
!         IF ( cn(mgs) > 0. ) THEN
!          write(0,*) 'cn,tmp,ccwmax,cx,c-cx = ',cn(mgs),tmp,ccwmax,cx(mgs,lc),ccwmax - cx(mgs,lc) 
!         ENDIF
         
        cn(mgs) = Max( 0.0, Min( cn(mgs), ccwmax - cx(mgs,lc) ) )
       
       ENDIF
       
       cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
       
       ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))

      ELSEIF ( irenuc == 5 ) THEN !} { 

      ! modification of Phillips Donner Garner 2007
!      if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR:  Cloud reNucleation, wvel = ',wvel(mgs)
!      CN(mgs) =  Min( 0.91*cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465
       CN(mgs) =  Min( cnuc(mgs),  CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )

         
        IF ( ccna(mgs) >= cnuc(mgs) ) THEN ! apply limit after all "base" CCN have been depleted
        temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz)
          ltemq = Int( (temp1-163.15)/fqsat+1.5 )
         ltemq = Min( nqsat, Max(1,ltemq) )

          c1= pqs(mgs)*tabqvs(ltemq)
          IF ( c1 > 0. ) THEN
            ssf(mgs) = Max(0.0, 100.*((qv0(mgs) + qwvp(mgs))/c1 - 1.0) )  ! from "new" values
          ELSE
            ssf(mgs) = 0.0
          ENDIF
          

       CN(mgs) =   Max( cn(mgs), cnuc(mgs)*Min(ssf2kmax, ssf(mgs)**cck) ) ! this allows cn(mgs) > cnuc(mgs)

   !    cn(mgs) = Min( cn(mgs), cnuc(mgs) )

!       IF ( ccna(mgs) >= cnuc(mgs) ) THEN ! apply limit after all "base" CCN have been depleted
       CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from
       
       ELSE
         CN(mgs) =  Min( cn(mgs), cnuc(mgs) - ccna(mgs) ) ! no more than remaining "base" CCN
       ENDIF
               ! Philips, Donner et al. 2007, but results in too much limitation of
               ! nucleation
!       CN(mgs) = Min(cn(mgs), ccnc(mgs))
!       cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass
       dcrit = 2.0*2.0e-6
       dcloud = 1000.*dcrit**3*Pi/6.
 !      cn(mgs) = Min(cn(mgs), 0.5*dqc/dcloud) ! limit the nucleation mass to half of the condensation mass
       ! check new droplet size:
         ! tmp is number of droplets at diameter dcrit
         tmp = Max(0.0,  rho0(mgs)*qx(mgs,lc)/dcloud - cx(mgs,lc)) ! (cx(mgs,lc) + cn(mgs))
         cn(mgs) = Min(tmp, cn(mgs) )

      
       IF ( cn(mgs) > 0.0 ) THEN
       cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
       
       dcrit = 2.5e-7
       
       dcloud = 1000.*dcrit**3*Pi/6.*cn(mgs)
        qx(mgs,lc) = qx(mgs,lc) + DCLOUD
        thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs))
        qwvp(mgs) = qwvp(mgs) - DCLOUD
        ENDIF
       ! 6/13/2016: Phillips et al. appears not to decrement CCN, but only increments CCNa.
       ! This would allow an initially non-homogeneous (vertically, e.g.) initial value of CCN/rho_air
       ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
      ELSEIF ( irenuc == 7 ) THEN !} { 

      ! simple Twomey scheme but limit activation to try to do most activation near cloud base, but keep some CCN available for renuclation
!      if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR:  Cloud reNucleation, wvel = ',wvel(mgs)
       cn(mgs) = 0.0
!       IF ( ccna(mgs) < 0.7*cnuc(mgs) .and. ccnc(mgs) > 0.69*cnuc(mgs) - ccna(mgs)) THEN ! here, assume we are near cloud base and use Twomey formulation
       IF ( ccna(mgs) < 0.9*cnuc(mgs) ) THEN ! { here, assume we are near cloud base and use Twomey formulation
         CN(mgs) =  Min( 0.91*cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465
!         IF ( cn(mgs) + ccna(mgs) > 0.71*cnuc ) THEN
         ! prevent this branch from activating more than 70% of CCN
           CN(mgs) = Min( CN(mgs), Max(0.0, (0.9*cnuc(mgs) - ccna(mgs) )) )
!           CN(mgs) = Min( CN(mgs), Max(0.0, 0.71*ccnc(mgs) - ccna(mgs) ) )
         !  write(0,*) '1: k,cn = ',kgs(mgs),cn(mgs),ssf(mgs)
!!           IF ( ccncuf(mgs) > 0.0 .and. cn(mgs) < 1.e-3 .and. ssmax(mgs) > 1.0 ) THEN
!           IF ( ccncuf(mgs) > 0.0 .and. ssf(mgs) > ssmxuf .and. ssmax(mgs) > ssmxuf ) THEN
!            CNuf(mgs) =  Min( ccncuf(mgs), CCNE0*ccncuf(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465
          !  IF ( cnuf(mgs) >= 0.0 ) write(0,*) '1: cnuf, k = ',cnuf(mgs),ccncuf(mgs),kgs(mgs)
!           ENDIF

           
       ELSE ! }{
        ! if a large fraction of CCN have been activated, then assume we are in the cloud interior and use local SSw as in Phillips et al. 2007.

         temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz)
!          t0(ix,jy,kz) = temp1
          ltemq = Int( (temp1-163.15)/fqsat+1.5 )
         ltemq = Min( nqsat, Max(1,ltemq) )

        !  c1 = t00(igs(mgs),jy,kgs(mgs))*tabqvs(ltemq)
          c1= pqs(mgs)*tabqvs(ltemq)

          ssf(mgs) = 0.0
          IF ( c1 > 0. ) THEN
            ssf(mgs) = 100.*(qx(mgs,lv)/c1 - 1.0)  ! from "new" values
          ENDIF

!          IF ( ssf(mgs) <= 1.0 .or. cnuc(mgs) > ccna(mgs) ) THEN
          IF ( ssf(mgs) <= 1.0 ) THEN
          CN(mgs) =   cnuc(mgs)*Min(1.0, Max(0.0,ssf(mgs))**cck ) ! 
          ELSE
          CN(mgs) =   cnuc(mgs)*Min(2.0, Max(0.0,0.03*(ssf(mgs)-1.0)+1.)**cck ) !           
!          write(0,*) 'iren7: ssf,ssmx = ',ssf(mgs),ssmax(mgs),cn(mgs),ccna(mgs),cnuc(mgs)
!          write(0,*) 'c1,qv = ',c1,qx(mgs,lv),temp1,ltemq
          ENDIF

         !  write(0,*) 'k,cn = ',kgs(mgs),cn(mgs),ssf(mgs)
         !  write(0,*) 'ccn-ccna = ',cnuc(mgs) - ccna(mgs),ccnc(mgs) - ccna(mgs)
!           IF ( ccncuf(mgs) > 0.0 .and. cn(mgs) < 1.e-3 .and. ssmax(mgs) > 1.0 ) THEN
           IF ( ccncuf(mgs) > 0.0 .and. ssf(mgs) > ssmxuf .and. ssmax(mgs) > ssmxuf ) THEN
            CNuf(mgs) =  Min( ccncuf(mgs), CCNE0*ccncuf(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465
          !  IF ( cnuf(mgs) >= 0.0 ) write(0,*) 'cnuf, k = ',cnuf(mgs),ccncuf(mgs),kgs(mgs)
           ENDIF
          

!        CN(mgs) = Min( Min(0.1,ssf(mgs)-1.)*cnuc(mgs), Max( 0.0, CN(mgs) - ccna(mgs) ) ) ! this was from
!        CN(mgs) = Min( Min(0.5*cx(mgs,lc), Min(0.1,ssf(mgs)/100.)*cnuc(mgs)), Max( 0.0, CN(mgs) - ccna(mgs) ) ) ! this was from
        
        CN(mgs) = Min(0.01*cnuc(mgs), Max( 0.0, CN(mgs) - ccna(mgs) ) ) ! this was from

       ENDIF ! }
!      ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck))
!!!       CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from
               ! Philips, Donner et al. 2007, but results in too much limitation of
               ! nucleation
!       CN(mgs) = Min(cn(mgs), ccnc(mgs))
!       cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass
       

        IF ( icnuclimit > 0 ) THEN
! max droplet conc. based on Chandrakar et al. (2016) and Konwar et al. (2012)
           tmp = ccnc(mgs) - ccna(mgs) + cx(mgs,lc)
           IF ( tmp < 330.34e6 ) THEN
             ccwmax = 1.1173e6 * (1.e-6*tmp)**0.9504
           ELSE
             ccwmax = 21.57e6 * (1.e-6*tmp)**0.44
           ENDIF
          
           cn(mgs) = Max( 0.0, Min( cn(mgs), ccwmax - cx(mgs,lc) ) )
           
        ENDIF

       IF ( cn(mgs) + cnuf(mgs) > 0.0 ) THEN

       dcrit = 2.0*2.0e-6
       dcloud = 1000.*dcrit**3*Pi/6.
 !      cn(mgs) = Min(cn(mgs), 0.5*dqc/dcloud) ! limit the nucleation mass to half of the condensation mass
       ! check new droplet size:
         ! tmp is number of droplets at diameter dcrit
         tmp = Max(0.0,  rho0(mgs)*qx(mgs,lc)/dcloud - cx(mgs,lc)) ! (cx(mgs,lc) + cn(mgs))
         cn(mgs) = Min(tmp, cn(mgs) )

        cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + cnuf(mgs)
 
 
       ! create some small droplets at minimum size (CP 2000), although it adds very little liquid
       
       
       dcrit = 2.0*2.5e-7
       dcloud = 1000.*dcrit**3*Pi/6.*(cn(mgs) + cnuf(mgs) )
        qx(mgs,lc) = qx(mgs,lc) + DCLOUD
        thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs))
        qwvp(mgs) = qwvp(mgs) - DCLOUD
  !      ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
         ccncuf(mgs) = Max(0.0, ccncuf(mgs) - cnuf(mgs))
        ENDIF

      ELSEIF ( irenuc == 8 ) THEN !} { 
      ! simple Twomey scheme
!      if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR:  Cloud reNucleation, wvel = ',wvel(mgs)
       
       cn(mgs) = 0.0
       
       IF ( ccnc(mgs) > 0. ) THEN
       CN(mgs) =   CCNE0*ccnc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp ! *Min(1.0,1./dtp) ! 0.3465
!      ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck))
!!!       CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from
               ! Philips, Donner et al. 2007, but results in too much limitation of
               ! nucleation
       CN(mgs) = Min(cn(mgs), ccnc(mgs))
       
       ELSEIF ( cx(mgs,lc) < 0.01e9 ) THEN

        ! if a large fraction of CCN have been activated, then assume we are in the cloud interior and use local SSw as in Phillips et al. 2007.

         temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz)
!          t0(ix,jy,kz) = temp1
          ltemq = Int( (temp1-163.15)/fqsat+1.5 )
         ltemq = Min( nqsat, Max(1,ltemq) )

        !  c1 = t00(igs(mgs),jy,kgs(mgs))*tabqvs(ltemq)
          c1= pqs(mgs)*tabqvs(ltemq)

          ssf(mgs) = 0.0
          IF ( c1 > 0. ) THEN
            ssf(mgs) = 100.*(qx(mgs,lv)/c1 - 1.0)  ! from "new" values
          ENDIF

!          IF ( ssf(mgs) <= 1.0 .or. cnuc(mgs) > ccna(mgs) ) THEN
          IF ( ssf(mgs) <= 1.0 ) THEN
          CN(mgs) = 0.0
          ELSE
!           CN(mgs) = 0.01e9*rho0(mgs)/rho00*Min(2.0, Max(0.0,0.03*(ssf(mgs)-1.0)+1.)**cck ) - cx(mgs,lc) !           
           CN(mgs) = 0.01e9*Min(2.0, Max(0.0,0.03*(ssf(mgs)-1.0)+1.)**cck ) - cx(mgs,lc) !           
          ENDIF
       
       ENDIF

       IF ( cn(mgs) > 0.0 ) THEN
       cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
       
       ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
       
       ! create some small droplets at minimum size (CP 2000), although it adds very little liquid
       
       dcrit = 2.0*2.5e-7
       
       dcloud = 1000.*dcrit**3*Pi/6.*cn(mgs)
        qx(mgs,lc) = qx(mgs,lc) + DCLOUD
        thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs))
        qwvp(mgs) = qwvp(mgs) - DCLOUD
  !      ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
        ENDIF
       


      ENDIF ! }

      ccna(mgs) = ccna(mgs) + cn(mgs)



      ENDIF ! irenuc >= 0 .and. .not. flag_qndrop

      IF( cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .LE. qxmin(lc)) cx(mgs,lc)=0.
      GO TO 631
!.... NUCLEATION ON CLOUD INFLOW BOUNDARY POINT

  613 CONTINUE

  631  CONTINUE

!
! Check for supersaturation greater than ssmx and adjust down
!
       ssmx = maxsupersat
       qv1 = qv0(mgs) + qwvp(mgs)
       qvs1 = qvs(mgs)
       
!       IF ( flag_qndrop .and. do_satadj_for_wrfchem ) ssmx = 1.04 ! set lower threshold for progn=1 when using WRF-CHEM

       IF ( qv1 .gt. (ssmx*qvs1) ) THEN
! use line below to disable saturation adjustment when flag_qndrop is true
!       IF ( qv1 .gt. (ssmx*qvs1) .and. .not. flag_qndrop ) THEN
        
         ss1 = qv1/qvs1

        ssmx = 100.*(ssmx - 1.0)
        
        qvex = 0.0

        CALL QVEXCESS(ngs,mgs,qwvp,qv0,qx(1,lc),pres,thetap,theta0,qvex,   &
     &    pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ssmx,pk,ngscnt)



        IF ( qvex .gt. 0.0 ) THEN
        thetap(mgs) = thetap(mgs) + felvcp(mgs)*qvex/(pi0(mgs))
        IF ( io_flag .and. nxtra > 1 ) THEN
           axtra(igs(mgs),jy,kgs(mgs),1) = axtra(igs(mgs),jy,kgs(mgs),1) + qvex/dtp
        ENDIF
        qwvp(mgs) = qwvp(mgs) - qvex
        qx(mgs,lc) = qx(mgs,lc) + qvex
        IF ( .not. flag_qndrop) THEN
          IF ( imaxsupopt == 1 ) THEN
            cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, xmas(mgs,lc) )  )
          ELSEIF ( imaxsupopt == 2 ) THEN
            cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, Max(cwmas30,xmas(mgs,lc)) )  )
          ELSEIF ( imaxsupopt == 3 ) THEN
            cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, Max(cwmasx,xmas(mgs,lc)) )  )
!            cn(mgs) = 1.5*cxmin
          ELSEIF ( imaxsupopt == 4 ) THEN
            cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, Max(cwmas20,xmas(mgs,lc)) )  )
          ENDIF
        ccnc(mgs) = Max( 0.0, ccnc(mgs) - cn(mgs) )
        cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
        ENDIF
        
!        write(iunit,*) 'theta = ',theta0(mgs) + thetap(mgs)

!        temg(mgs) = theta(mgs)*( pres(mgs) / poo ) ** cap

        ENDIF

       
       ENDIF

!
! Calculate droplet volume and check if it is within bounds.
!  Adjust if necessary
!  
!      if (ndebug .gt. 0) write(0,*) "ICEZVD_DR: check droplet volume" 


!      cx(mgs,lc) = Min( cwnccn(mgs), cx(mgs,lc) )
      IF( cx(mgs,lc) > cxmin .AND. qx(mgs,lc) .GT. qxmin(lc)) THEN
!        SVC(mgs) = rho0(mgs)*qx(mgs,lc)/(cx(mgs,lc)*xdn(mgs,lc))
        xmas(mgs,lc) = rho0(mgs)*qx(mgs,lc)/(cx(mgs,lc))
        
       IF (  xmas(mgs,lc) < cwmasn .or.  xmas(mgs,lc) > cwmasx ) THEN
        tmp = cx(mgs,lc)
        xmas(mgs,lc) = Min( xmas(mgs,lc), cwmasx )
        xmas(mgs,lc) = Max( xmas(mgs,lc), cwmasn )
        cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc)
!        IF ( cx(mgs,lc) > tmp*1.1 ) THEN
!          write(0,*) 'nucond: kgs, ccw1,2 = ',kgs(mgs),tmp,cx(mgs,lc)
!        ENDIF
       ENDIF
      ENDIF


!      IF( cx(mgs,lc) .GT. 10.e6 .AND. qx(mgs,lc) .GT. qxmin(lc) ) GO TO 681
!        ccwtmp = cx(mgs,lc)
!        cwmastmp = xmas(mgs,lc)
!       xmas(mgs,lc) = Max(xmas(mgs,lc), cwmasn)
!       IF (qx(mgs,lc) .GT. qxmin(lc) .AND. cx(mgs,lc) .le. 0.) THEN
!          cx(mgs,lc) = Min(0.5*cwccn,rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc))
!          xmas(mgs,lc) = rho0(mgs)*qx(mgs,lc)/cx(mgs,lc)
!       ENDIF
!      IF (cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .GT. qxmin(lc))    &
!     &        xmas(mgs,lc) = rho0(mgs)*qx(mgs,lc)/cx(mgs,lc)
!      IF (qx(mgs,lc) .GT. qxmin(lc) .AND. xmas(mgs,lc) .LT. cwmasn)    &
!     &          xmas(mgs,lc) = cwmasn
!      IF (qx(mgs,lc) .GT. qxmin(lc) .AND. xmas(mgs,lc) .GT. cwmasx)    &
!     &    xmas(mgs,lc) = cwmasx
!      IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN
!        cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/Max(cwmasn,xmas(mgs,lc))
!      ENDIF
!        
!
! 681  CONTINUE

        
      IF ( ipconc .ge. 3 .and. rcond == 2 ) THEN

        
        IF (cx(mgs,lr) .GT. 0. .AND. qx(mgs,lr) .GT. qxmin(lr))    &
     &       xv(mgs,lr)=rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr))
        IF (xv(mgs,lr) .GT. xvmx(lr)) xv(mgs,lr) = xvmx(lr)
        IF (xv(mgs,lr) .LT. xvmn(lr)) xv(mgs,lr) = xvmn(lr)

      ENDIF



      ENDDO ! mgs


! ################################################################
      DO mgs=1,ngscnt
      IF ( lss > 1 .and. ssf(mgs) .gt. ssmax(mgs)    &
     &  .and. ( idecss .eq. 0 .or. qx(mgs,lc) .gt. qxmin(lc)) ) THEN
        ssmax(mgs) = ssf(mgs)
      ENDIF
      ENDDO
!

      do mgs = 1,ngscnt
      an(igs(mgs),jy,kgs(mgs),lt) = theta0(mgs) + thetap(mgs)
      an(igs(mgs),jy,kgs(mgs),lv) =  qv0(mgs) + qwvp(mgs)
!      tmp3d(igs(mgs),jy,kgs(mgs)) = tmp3d(igs(mgs),jy,kgs(mgs)) + t9(igs(mgs),jy,kgs(mgs)) !  pi0(mgs) ! wvdf(mgs) ! ssf(mgs) ! cn(mgs)
!
      IF ( eqtset > 2 ) THEN
        p2(igs(mgs),jy,kgs(mgs)) = pipert(mgs)
      ENDIF

       if ( ido(lc) .eq. 1 )  then
        an(igs(mgs),jy,kgs(mgs),lc) = qx(mgs,lc) +    &
     &    min( an(igs(mgs),jy,kgs(mgs),lc), 0.0 )
!        qx(mgs,lc) = an(igs(mgs),jy,kgs(mgs),lc)
       end if
!

       if ( ido(lr) .eq. 1 .and. rcond == 2 )  then
        an(igs(mgs),jy,kgs(mgs),lr) = qx(mgs,lr) +    &
     &    min( an(igs(mgs),jy,kgs(mgs),lr), 0.0 )
!        qx(mgs,lr) = an(igs(mgs),jy,kgs(mgs),lr)
       end if



       IF (  ipconc .ge. 2 ) THEN
        an(igs(mgs),jy,kgs(mgs),lnc) = Max(cx(mgs,lc) , 0.0)
        IF ( lss > 1 ) an(igs(mgs),jy,kgs(mgs),lss) = Max( 0.0, ssmax(mgs) )
        IF ( lccn .gt. 1 ) THEN
          an(igs(mgs),jy,kgs(mgs),lccn) = Max(0.0,  ccnc(mgs) )
        ENDIF
        IF ( lccnuf .gt. 1 ) THEN
          an(igs(mgs),jy,kgs(mgs),lccnuf) = Max(0.0,  ccncuf(mgs) )
        ENDIF
        IF ( lccna .gt. 1 ) THEN
          an(igs(mgs),jy,kgs(mgs),lccna) = Max(0.0, ccna(mgs) )
        ENDIF
       ENDIF
       IF (  ipconc .ge. 3 .and. rcond == 2 ) THEN
        an(igs(mgs),jy,kgs(mgs),lnr) = Max(cx(mgs,lr) , 0.0)
       ENDIF
      end do


29998 continue


      if ( kz .gt. nz-1 .and. ix .ge. nxi) then
        if ( ix .ge. nxi ) then
         go to 2200 ! exit gather scatter
        else
         nzmpb = kz
        endif
      else
        nzmpb = kz
      end if

      if ( ix .ge. nxi ) then
        nxmpb = 1
        nzmpb = kz+1
      else
       nxmpb = ix+1
      end if

 2000 continue ! inumgs
 2200 continue
!
!  end of gather scatter (for this jy slice)


!#ifdef COMMAS
!    GOTO 9999
!#endif

! Redistribute inappreciable cloud particles and charge
!
! Redistribution everywhere in the domain...
!
    IF ( .true. ) THEN
      
      frac = 1.0 ! 0.25 ! 1.0 ! 0.2
!
!  alternate test version for ipconc .ge. 3
!  just vaporize stuff to prevent noise in the number concentrations


      do kz = 1,nz
!      do jy = 1,1
      do ix = 1,nxi
      
      t0(ix,jy,kz) = an(ix,jy,kz,lt)*t77(ix,jy,kz)
      
      zerocx(:) = .false.
      DO il = lc,lhab
       IF ( iresetmoments == 1 .or. iresetmoments == il ) THEN
        IF ( ln(il) > 1 ) zerocx(il) = ( an(ix,jy,kz,ln(il)) < cxmin )
        IF ( lz(il) > 1 ) zerocx(il) = ( zerocx(il) .or. an(ix,jy,kz,lz(il)) < zxmin )
       ELSE
        IF ( il == lc ) THEN
          IF ( ln(il) > 1 ) zerocx(il) = ( an(ix,jy,kz,ln(il)) <= 0 ) .and. .not. flag_qndrop ! do not reset if progn=1 (WRF-CHEM)
        ELSE
         IF ( ln(il) > 1 ) zerocx(il) = ( an(ix,jy,kz,ln(il)) <= 0 )
        ENDIF
       ENDIF
      ENDDO

      IF ( lhl .gt. 1 ) THEN
      
      
      if ( an(ix,jy,kz,lhl) .lt. frac*qxmin(lhl) .or. zerocx(lhl) ) then

!        IF ( an(ix,jy,kz,lhl) .gt. 0 ) THEN
          an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lhl)
          an(ix,jy,kz,lhl) = 0.0
!        ENDIF

        IF ( ipconc .ge. 5 ) THEN ! .and. an(ix,jy,kz,lnh) .gt. 0.0 ) THEN
          an(ix,jy,kz,lnhl) = 0.0
        ENDIF

        IF ( lvhl .gt. 1 ) THEN
           an(ix,jy,kz,lvhl) = 0.0
        ENDIF

        IF ( lhlw .gt. 1 ) THEN
           an(ix,jy,kz,lhlw) = 0.0
        ENDIF
      
        IF ( lzhl .gt. 1 ) THEN
           an(ix,jy,kz,lzhl) = 0.0
        ENDIF

      ELSE
       IF ( lvol(lhl) .gt. 1 ) THEN  ! check density
        IF ( an(ix,jy,kz,lvhl) .gt. 0.0 ) THEN
         tmp = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl)
        ELSE ! in case volume is zero but mass is above threshold (should not happen, of course)
          tmp = rho_qhl
          an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp
        ENDIF

        IF (  tmp .lt. xdnmn(lhl) ) THEN
          tmp = Max( xdnmn(lhl), tmp )
          an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp
        ENDIF

        IF ( tmp .gt. xdnmx(lhl) .and. lhlw .le. 0 ) THEN ! no liquid allowed on hail
          tmp = Min( xdnmx(lhl), tmp )
          an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp
        ELSEIF ( tmp .gt. xdnmx(lhl) .and. lhlw .gt. 1 ) THEN  ! allow for liquid on hail
          fw = an(ix,jy,kz,lhlw)/an(ix,jy,kz,lhl)
!          tmpmx = xdnmx(lhl) + fw*(xdnmx(lr) - xdnmx(lhl)) ! maximum possible average density
                                                           ! it is not exactly linear, but approx. is close enough for this
!          tmpmx = 1./( (1. - fw)/900. + fw/1000. ) is exact max, where 900 is xdnmx

          tmpmx = xdnmx(lhl)/( 1. - fw*(1. - xdnmx(lhl)/xdnmx(lr) )) 

          IF ( tmp .gt. tmpmx  ) THEN
            an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmpmx
          ENDIF

!          IF ( tmp .gt. xdnmx(lhl) .and. an(ix,jy,kz,lhlw) .lt. qxmin(lhl) ) THEN
!            tmp = Min( xdnmx(lhl), tmp )
!            an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp
!          ELSEIF ( tmp .gt. xdnmx(lr) ) THEN
!            tmp =  xdnmx(lr)
!            an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp
!          ENDIF
        ENDIF

        IF ( lhlw .gt. 1 ) THEN ! check if basically pure water
          IF ( an(ix,jy,kz,lhlw) .gt. 0.98*an(ix,jy,kz,lhl) ) THEN
           tmp = xdnmx(lr)
           an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp
          ENDIF
        ENDIF
        
       ENDIF
       
       
!  CHECK INTERCEPT
       IF ( ipconc == 5 .and.  an(ix,jy,kz,lhl) .gt. qxmin(lhl) .and.  alphahl .le. 0.1 .and. lnhl .gt. 1 .and. lzhl == 0 ) THEN
       
         IF ( lvhl .gt. 1 ) THEN
           hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl)
         ELSE
           hwdn = xdn0(lhl)
         ENDIF
           tmp = (hwdn*an(ix,jy,kz,lnhl))/(dn(ix,jy,kz)*an(ix,jy,kz,lhl))
           tmpg = an(ix,jy,kz,lnhl)*(tmp*(3.14159))**(1./3.)
           IF ( tmpg .lt. cnohlmn ) THEN
             tmp = ( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lhl))*(3.14159))**(1./3.)
              an(ix,jy,kz,lnhl) = (cnohlmn/tmp)**(3./4.)
           ENDIF
       
       ENDIF
!      ELSE  ! check mean size here?

      end if

      ENDIF !lhl




      if ( an(ix,jy,kz,lh) .lt. frac*qxmin(lh) .or. zerocx(lh) ) then

!        IF ( an(ix,jy,kz,lh) .gt. 0 ) THEN
          an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lh)
          an(ix,jy,kz,lh) = 0.0
!        ENDIF

        IF ( ipconc .ge. 5 ) THEN ! .and. an(ix,jy,kz,lnh) .gt. 0.0 ) THEN
          an(ix,jy,kz,lnh) = 0.0
        ENDIF

        IF ( lvh .gt. 1 ) THEN
           an(ix,jy,kz,lvh) = 0.0
        ENDIF
      
        IF ( lhw .gt. 1 ) THEN
           an(ix,jy,kz,lhw) = 0.0
        ENDIF
      
        IF ( lzh .gt. 1 ) THEN
           an(ix,jy,kz,lzh) = 0.0
        ENDIF

      ELSE
       IF ( lvol(lh) .gt. 1 ) THEN  ! check density
        IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN
         tmp = dn(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh)
        ELSE
         tmp = rho_qh
          an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp
        ENDIF

        IF (  tmp .lt. xdnmn(lh) ) THEN
          tmp = Max( xdnmn(lh), tmp )
          an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp
        ENDIF

        IF ( tmp .gt. xdnmx(lh) .and. lhw .le. 0 ) THEN ! no liquid allowed on graupel
          tmp = Min( xdnmx(lh), tmp )
          an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp
        ELSEIF ( tmp .gt. xdnmx(lh) .and. lhw .gt. 1 ) THEN  ! allow for liquid on graupel
          fw = an(ix,jy,kz,lhw)/an(ix,jy,kz,lh)
!          tmpmx = xdnmx(lh) + fw*(xdnmx(lr) - xdnmx(lh)) ! maximum possible average density
                                                           ! it is not exactly linear, but approx. is close enough for this
!          tmpmx = 1./( (1. - fw)/900. + fw/1000. ) is exact max, where 900 is xdnmx
          tmpmx = xdnmx(lh)/( 1. - fw*(1. - xdnmx(lh)/xdnmx(lr) )) 

          IF ( tmp .gt. tmpmx  ) THEN
            an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmpmx
          ENDIF

!          IF ( tmp .gt. xdnmx(lh) .and. an(ix,jy,kz,lhw) .lt. qxmin(lh) ) THEN
!            tmp = Min( xdnmx(lh), tmp )
!            an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp
!          ELSEIF ( tmp .gt. xdnmx(lr) ) THEN
!            tmp =  xdnmx(lr)
!            an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp
!          ENDIF

        ENDIF

        IF ( lhw .gt. 1 ) THEN ! check if basically pure water
          IF ( an(ix,jy,kz,lhw) .gt. 0.98*an(ix,jy,kz,lh) ) THEN
           tmp = xdnmx(lr)
           an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp
          ENDIF
        ENDIF
        
       ENDIF

!  CHECK INTERCEPT
       IF ( ipconc == 5 .and.  an(ix,jy,kz,lh) .gt. qxmin(lh) .and.  alphah .le. 0.1 .and. lnh .gt. 1 .and. lzh == 0 ) THEN
       
         IF ( lvh .gt. 1 ) THEN
           IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN
             hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh)
           ELSE
             hwdn = xdn0(lh)
           ENDIF
           hwdn = Max( xdnmn(lh), hwdn )
         ELSE
           hwdn = xdn0(lh)
         ENDIF
           tmp = (hwdn*an(ix,jy,kz,lnh))/(dn(ix,jy,kz)*an(ix,jy,kz,lh))
           tmpg = an(ix,jy,kz,lnh)*(tmp*(3.14159))**(1./3.)
           IF ( tmpg .lt. cnohmn ) THEN
!           tmpg = an(ix,jy,kz,lnh)*( (hwdn*an(ix,jy,kz,lnh))/(dn(ix,jy,kz)*an(ix,jy,kz,lh))*(3.14159))**(1./3.)
!           tmpg = an(ix,jy,kz,lnh)**(4./3.)*( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lh))*(3.14159))**(1./3.)
             tmp = ( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lh))*(3.14159))**(1./3.)
              an(ix,jy,kz,lnh) = (cnohmn/tmp)**(3./4.)
           ENDIF
       
       ENDIF
        
      end if


      if ( an(ix,jy,kz,ls) .lt.  frac*qxmin(ls)  .or. zerocx(ls)  & ! .or.  an(ix,jy,kz,lns) .lt. 0.1 ! .and.
     &         ) then
      IF ( t0(ix,jy,kz) .lt. 273.15 ) THEN
!        IF ( an(ix,jy,kz,ls) .gt. 0 ) THEN
          an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,ls)
          an(ix,jy,kz,ls) = 0.0
!        ENDIF
      
        IF ( ipconc .ge. 4 ) THEN ! .and. an(ix,jy,kz,lns) .gt. 0.0  ) THEN ! 
!          an(ix,jy,kz,lni) = an(ix,jy,kz,lni) + an(ix,jy,kz,lns)
          an(ix,jy,kz,lns) = 0.0
        ENDIF
        
        IF ( lvs .gt. 1 ) THEN
           an(ix,jy,kz,lvs) = 0.0
        ENDIF

        IF ( lsw .gt. 1 ) THEN
           an(ix,jy,kz,lsw) = 0.0
        ENDIF

      ELSE
!        IF ( an(ix,jy,kz,ls) .gt. 0 ) THEN
          an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,ls)
          an(ix,jy,kz,ls) = 0.0
!        ENDIF

        IF ( lvs .gt. 1 ) THEN
           an(ix,jy,kz,lvs) = 0.0
        ENDIF

        IF ( lsw .gt. 1 ) THEN
           an(ix,jy,kz,lsw) = 0.0
        ENDIF

        IF ( ipconc .ge. 4 ) THEN ! .and. an(ix,jy,kz,lns) .gt. 0.0  ) THEN ! 
!          an(ix,jy,kz,lnr) = an(ix,jy,kz,lnr) + an(ix,jy,kz,lns)
          an(ix,jy,kz,lns) = 0.0
        ENDIF

      ENDIF
      

      ELSEIF ( lvol(ls) .gt. 1 ) THEN  ! check density
        IF ( an(ix,jy,kz,lvs) .gt. 0.0 ) THEN
          tmp = dn(ix,jy,kz)*an(ix,jy,kz,ls)/an(ix,jy,kz,lvs)
          IF ( tmp .gt. xdnmx(ls) .or. tmp .lt. xdnmn(ls) ) THEN
            tmp = Min( xdnmx(ls), Max( xdnmn(ls), tmp ) )
            an(ix,jy,kz,lvs) = dn(ix,jy,kz)*an(ix,jy,kz,ls)/tmp
          ENDIF
        ELSE
          tmp = rho_qs
          an(ix,jy,kz,lvs) = dn(ix,jy,kz)*an(ix,jy,kz,ls)/tmp
        ENDIF


      end if


      if ( an(ix,jy,kz,lr) .lt. frac*qxmin(lr)  .or. zerocx(lr)  &
     &  ) then
        an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lr)
        an(ix,jy,kz,lr) = 0.0
        IF ( ipconc .ge. 3 ) THEN
!          an(ix,jy,kz,lnc) = an(ix,jy,kz,lnc) + an(ix,jy,kz,lnr)
          an(ix,jy,kz,lnr) = 0.0
        ENDIF
        
      end if

!
!  for qci
!
      IF ( an(ix,jy,kz,li) .le. frac*qxmin(li) .or. zerocx(li)   & ! .or.  an(ix,jy,kz,lni) .lt. 0.1
     &    ) THEN
      an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,li)
      an(ix,jy,kz,li)= 0.0
       IF ( ipconc .ge. 1 ) THEN
         an(ix,jy,kz,lni) = 0.0
       ENDIF
      ENDIF

!
!  for qis
!
      IF ( lis > 1 ) THEN ! {
      IF ( an(ix,jy,kz,lis) .le. frac*qxmin(lis) .or. zerocx(lis)   & ! .or.  an(ix,jy,kz,lni) .lt. 0.1
     &    ) THEN ! { {
      an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lis)
      an(ix,jy,kz,lis)= 0.0
       IF ( ipconc .ge. 1 ) THEN
         an(ix,jy,kz,lnis) = 0.0
       ENDIF
      
      ELSEIF ( icespheres >= 2 ) THEN ! } {
       km1 = Max(1, kz-1)
       IF ( 0.5*( w(ix,jy,kz) + w(ix,jy,kz+1)) < -1.0 .or.    &
     &      (icespheres == 3 .and. ( t0(ix,jy,kz) < 232.15 .or. an(ix,jy,kz,lc) < qxmin(lc) ) ) .or. &
     &      (icespheres == 5 .and. ( t0(ix,jy,kz) < 232.15 .or. &
     &         ( an(ix,jy,kz,lc) < qxmin(lc) .and. an(ix,jy,km1,lc) < qxmin(lc)  )) ) .or. &
     &      (icespheres == 4 .and. ( t0(ix,jy,kz) < 235.15 )) ) THEN ! transfer to regular ice crystals in downdraft or at low temp
         an(ix,jy,kz,li) = an(ix,jy,kz,li) + an(ix,jy,kz,lis)
         an(ix,jy,kz,lni) = an(ix,jy,kz,lni) + an(ix,jy,kz,lnis)
         an(ix,jy,kz,lis)= 0.0
         an(ix,jy,kz,lnis)= 0.0
         
       ENDIF
       
      ENDIF ! } }
      ENDIF ! }

!
!  for qcw
!

      IF ( an(ix,jy,kz,lc) .le. frac*qxmin(lc) .or. zerocx(lc)   &
     &       ) THEN
      an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lc)
      an(ix,jy,kz,lc)= 0.0
       IF ( ipconc .ge. 2 ) THEN
        IF ( lccn .gt. 1 ) THEN
         an(ix,jy,kz,lccn) =     &
     &       an(ix,jy,kz,lccn) + Max(0.0,an(ix,jy,kz,lnc))
        ENDIF
         an(ix,jy,kz,lnc) = 0.0
         
         IF ( lccna > 0  ) THEN ! apply exponential decay to activated CCN to restore to environmental value
           tmp = an(ix,jy,kz,li) + an(ix,jy,kz,ls)  
           
           IF ( an(ix,jy,kz,lccna) > 1. .and. tmp < qxmin(li) ) an(ix,jy,kz,lccna) = an(ix,jy,kz,lccna)*Exp(-dtp/ccntimeconst)

         ELSEIF ( lccn > 1 .and. restoreccn ) THEN
           ! in this case, we are treating the ccn field as ccna
           tmp = an(ix,jy,kz,li) + an(ix,jy,kz,ls)  
!           IF ( ny == 2 .and. ix == nx/2 ) THEN
!             write(0,*) 'restore: k, qccn,exp = ',kz,qccn,dn(ix,jy,kz)*qccn,Exp(-dtp/ccntimeconst)
!             write(0,*) 'ccn1,ccn2 = ',an(ix,jy,kz,lccn),dn(ix,jy,kz)*qccn - Max(0.0 , dn(ix,jy,kz)*qccn - an(ix,jy,kz,lccn))*Exp(-dtp/ccntimeconst)
!           ENDIF
           IF ( an(ix,jy,kz,lccn) > 1. .and. tmp < qxmin(li) .and. ( an(ix,jy,kz,lccn) < dn(ix,jy,kz)*qccn .or. .not. invertccn ) ) THEN 
        !      an(ix,jy,kz,lccn) =  &
        !            an(ix,jy,kz,lccn) +  Max(0.0 , dn(ix,jy,kz)*qccn - an(ix,jy,kz,lccn))*(1.0 - Exp(-dtp/ccntimeconst))
        ! Equivalent form after expanding last term:
               an(ix,jy,kz,lccn) =  &
                    dn(ix,jy,kz)*qccn - Max(0.0 , dn(ix,jy,kz)*qccn - an(ix,jy,kz,lccn))*Exp(-dtp/ccntimeconst)
           ENDIF
         
         ENDIF

       ENDIF

      ENDIF

      end do
!      end do
      end do
      
      ENDIF ! true/false
      
      IF ( ndebug .ge. 1 ) write(6,*) 'END OF ICEZVD_DR'
!
!
   
   
   9999 RETURN
   
   END SUBROUTINE NUCOND


! #####################################################################
! #####################################################################




!c--------------------------------------------------------------------------
!
!
!--------------------------------------------------------------------------
!

      subroutine nssl_2mom_gs   &
     &  (nx,ny,nz,na,jyslab  &
     &  ,nor,norz          &
     &  ,dtp,gz       &
     &  ,t0,t1,t2,t3,t4,t5,t6,t7,t8,t9      &
     &  ,an,dn,p2                  &
     &  ,pn,w,iunit                   &
     &  ,t00,t77,                             &
     &   ventr,ventc,c1sw,jgs,ido,    &
     &   xdnmx,xdnmn,               &
!     &   ln,ipc,lvol,lz,lliq,   &
     &   cdx,                              &
     &   xdn0,tmp3d,tkediss  &
     & ,timevtcalc,axtra,io_flag  &
     & , has_wetscav,rainprod2d, evapprod2d &
     & ,elec,its,ids,ide,jds,jde &
     & )


!
!--------------------------------------------------------------------------
!                                
!     Ziegler 1985 parameterized microphysics (also Zrnic et al. 1993)
!     1)  cloud water
!     2)  rain
!     3)  column ice 
!     6)  snow
!     11) graupel/hail
!
!--------------------------------------------------------------------------
!
! Notes:
!
!  4/27/2009: allows for liquid water to be advected on snow and graupel particles using flag "mixedphase"
!
!  3/14/2007: (APS) added qproc temp to make microphysic process timeseries
!
!  10/17/2006: added flag (iehw) to select how to calculate ehw
!
!  10/5/2006: switched chacr to integrated version rather than assuming that average rain
!             drop mass does not change.  This acts to reduce rain size somewhat via graupel
!             collection.
!             Use Mason data for ehw, with scaling toward ehw=1 as air density decreases.
!
!  10/3/2006: Turned off Meyers nucleation for T > -5 (can turn on with imeyers5 flag)
!             Turned off contact nucleation in updrafts
!
!  7/24/2006:  Turned on Meyers nucleation for -5 < T < 0
!
!  5/12/2006:  Converted qsacw/csacw and qsaci/csaci to Z93
!
!  5/12/2006:  Put a threshold on Bigg rain freezing.  If the frozen drops
!              have an average volume less than xvhmn, then the drops are put
!              into snow instead of graupel/hail.
!
!              Fixed bug when vapor deposition was limited.
!
!  5/13/2006:  Note that qhacr has a large effect, but Z85 did not include it.
!              Turned off qsacr (set to zero).
!
!  9/14/2007: erm: recalculate vx(lh) after setting xdn(lh) in case xdn was out of allowed range.
!             added parameter rimc3 for minimum rime density.  Default value set at 170. kg/m**3
!             instead of previous use of 100.  (Farley, 1987)
!
!--------------------------------------------------------------------------
!
!  general declarations
!
!--------------------------------------------------------------------------
!
!
!


      implicit none
!
!      integer icond 
!      parameter ( icond = 2 )

      integer, parameter :: ng1 = 1

      integer nx,ny,nz,na,nba,nv
      integer nor,norz,istag,jstag,kstag ! ,nht,ngt,igsr
      integer iwrite
      real dtp,dx,dy,dz

      logical, intent(in) :: io_flag

      integer itile,jtile,ktile
      integer ixbeg,jybeg
      integer ixend,jyend,kzend,kzbeg
      integer nxend,nyend,nzend,nzbeg
      integer :: my_rank = 0
      integer, parameter :: myprock = 1, nprock = 1
      logical, intent(in) :: has_wetscav
      real rainprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz)
      real evapprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz)

      real tkediss(-nor+1:nx+nor,-norz+ng1:nz+norz)
      real axtra(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,nxtra)

      real :: galpharaut
      real :: xvbarmax
      
      integer jyslab,its,ids,ide,jds,jde ! domain boundaries
      integer, intent(in) :: iunit !,iunit0
      real qvex
      integer iraincv, icgxconv
      parameter ( iraincv = 1, icgxconv = 1)
      real ffrz
      real :: ffrzh = 1.0

      real qcitmp,cirdiatmp ! ,qiptmp,qirtmp
      real ccwtmp,ccitmp ! ,ciptmp,cirtmp
      real cpqc,cpci ! ,cpip,cpir
      real cpqc0,cpci0 ! ,cpip0,cpir0
      real scfac ! ,cpip1
      
      double precision dp1
      
      double precision frac, frach, xvfrz, xvbiggsnow
      
      double precision :: timevtcalc
      double precision :: dpt1,dpt2
            
      logical, parameter :: gammacheck = .false.
      integer :: luindex
      double precision :: tmpgam
      logical, parameter :: usegamxinfcnu = .false.
      logical, parameter :: usegamxinf = .false.
      logical, parameter :: usegamxinf2 = .false.
      logical, parameter :: usegamxinf3 = .false.
!      real rar  ! rime accretion rate as calculated from qxacw


! a few vars for time-split fallout      
      real vtmax
      integer n,ndfall
      
      double precision chgneg,chgpos,sctot
      
      real temgtmp

      real pb(-norz+ng1:nz+norz)
      real pinit(-norz+ng1:nz+norz)

      real gz(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) ! dz
      
      real qimax,xni0,roqi0


      real dv

      real dtptmp
      integer itest,nidx,id1,jd1,kd1
      parameter (itest=1)
      parameter (nidx=10)
      parameter (id1=1,jd1=1,kd1=1)
      integer ierr
      integer iend

      integer ix,kz, il, ic, ir, icp1, irp1, ip1,jp1,kp1
      integer :: jy
      integer i,j,k,i1
      integer kzb,kze
      real slope1, slope2
      real x1, x2, x3
      real eps,eps2
      parameter (eps=1.e-20,eps2=1.e-5)
!
!  Other elec. vars
!
      real  temele
      real  trev
      
      logical ldovol, ishail, ltest, wtest
      logical , parameter :: alp0flag = .false.
!
!
!  wind indicies
!
      integer mu,mv,mw
      parameter (mu=1,mv=2,mw=3)
!
!  conversion parameters
!
      integer mqcw,mqxw,mtem,mrho,mtim
      parameter (mqcw=21,mqxw=21,mtem=21,mrho=5,mtim=6)

      real xftim,xftimi,yftim, xftem,yftem, xfqcw,yfqcw, xfqxw,yfqxw
      parameter (xftim=0.05,xftimi = 1./xftim,yftim=1.)
      parameter (xftem=0.5,yftem=1.)
      parameter (xfqcw=2000.,yfqcw=1.)
      parameter (xfqxw=2000.,yfqxw=1.)
      real dtfac
      parameter ( dtfac = 1.0 )
      integer ido(lc:lqmx)

!      integer iexy(lc:lqmx,lc:lqmx)
!      integer ieswi, ieswir, ieswip, ieswc, ieswr
!      integer ieglsw, iegli, ieglir, ieglip, ieglc, ieglr
!      integer iegmsw, iegmi, iegmir, iegmip, iegmc, iegmr
!      integer ieghsw, ieghi, ieghir, ieghip, ieghc, ieghr
!      integer iefwsw, iefwi, iefwir, iefwip, iefwc, iefwr
!      integer iehwsw, iehwi, iehwir, iehwip, iehwc, iehwr
!      integer iehlsw, iehli, iehlir, iehlip, iehlc, iehlr
!      real delqnsa, delqxsa, delqnsb, delqxsb, delqnia, delqxia
!      real delqnra, delqxra

       real delqnxa(lc:lqmx)
       real delqxxa(lc:lqmx)
!
! external temporary arrays
!
      real t00(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz)
      real t77(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz)

      real t0(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz)
      real t1(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz)
      real t2(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz)
      real t3(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz)
      real t4(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz)
      real t5(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz)
      real t6(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz)
      real t7(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz)
      real t8(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz)
      real t9(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz)

      real p2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz)  ! perturbation Pi
      real pn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz)
      real an(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,na)
      real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz)
      real w(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz)

      real tmp3d(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz)

! 
!  declarations microphyscs and for gather/scatter
!
      integer nxmpb,nzmpb,nxz
      integer jgs,mgs,ngs,numgs
      parameter (ngs=500) !500)
      integer, parameter :: ngsz = 500
      integer ntt
      parameter (ntt=300)

      real dvmgs(ngs)
      
      integer ngscnt,igs(ngs),kgs(ngs)
      integer kgsp(ngs),kgsm(ngs),kgsm2(ngs)
      integer ncuse
      parameter (ncuse=0)
      integer il0(ngs),il5(ngs),il2(ngs),il3(ngs)
!      integer il1m(ngs),il2m(ngs),il3m(ngs),il4m(ngs),il5m(ngs)
!
      real tdtol,temsav,tfrcbw,tfrcbi
      real, parameter :: thnuc = 235.15
!
!  Ice Multiplication Arrays.
!
      real  fimt1(ngs),fimta(ngs),fimt2(ngs) !,qmul1(ngs),qmul2(ngs)
      real xcwmas
!
!
! Variables for Ziegler warm rain microphysics
!      


      real ccnc(ngs),ccin(ngs),cina(ngs),ccna(ngs)
      real cwnccn(ngs)
      real sscb  ! 'cloud base' SS threshold
      parameter ( sscb = 2.0 )
      integer idecss  ! flag to turn on (=1) decay of ssmax when no cloud or ice crystals
      parameter ( idecss = 1 )
      integer iba ! flag to do condensation/nucleation in 1st or 2nd loop
                  ! =0 to use ad to calculate SS
                  ! =1 to use an at end of main jy loop to calculate SS
      parameter (iba = 1)
      integer ifilt   ! =1 to filter ssat, =0 to set ssfilt=ssat
      parameter ( ifilt = 0 ) 
      real temp1,temp2 ! ,ssold
      real :: mwat, mice, dice, mwshed, fwmax, fw, mwcrit, massfactor, tmpdiam
      real, parameter :: shedalp = 3.  ! set 3 for maximum mass diameter (same as area-weighted diameter), 4 for mass-weighted diameter
      real ssmax(ngs)       ! maximum SS experienced by a parcel
      real ssmx
      real dnnet,dqnet
!      real cnu,rnu,snu,cinu
!      parameter ( cnu = 0.0, rnu = -0.8, snu = -0.8, cinu = 0.0 )
      real bfnu, bfnu0, bfnu1
      parameter ( bfnu0 = (rnu + 2.0)/(rnu + 1.0)  )
      real ventr, ventc
      real volb
      double precision t2s, xdp
      double precision xl2p(ngs),rb(ngs)
      real, parameter :: aa1 = 9.44e15, aa2 = 5.78e3  ! a1 in Ziegler
! snow parameters:
      real, parameter :: cexs = 0.1, cecs = 0.5 
      real, parameter :: rvt = 0.104  ! ratio of collection kernels (Zrnic et al, 1993)
      real, parameter :: kfrag = 1.0e-6 ! rate coefficent for collisional splintering (Schuur & Rutledge 00b)
      real, parameter :: mfrag = 1.0e-10 ! assumed ice fragment mass for collisional splintering (Schuur & Rutledge 00b)
      double precision cautn(ngs), rh(ngs), nh(ngs)
      real ex1, ft, rhoinv(ngs)
      double precision ec0(ngs)
      
      real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp1,tmp2,tmp3,tmp4,tmp5,temp3 ! , sstdy, super
      real dw,dwr
      double precision :: tmpz, tmpzmlt
      real ratio, delx, dely
      real dbigg,volt
      real chgtmp,fac,mixedphasefac
      real x,y,y2,del,r,rtmp,alpr
      double precision :: vent1,vent2
      double precision :: g1palp,g4palp
      double precision :: g1palpinf,g4palpinf
      real fqt !charge separation as fn of temperature from Dong and Hallett 1992
      real bs
      real v1, v2
      real d1r, d1i, d1s, e1i
      real c1sw   ! integration factor for snow melting with snu = -0.8
      real, parameter :: vr1mm = 5.23599e-10 ! volume of 1mm diameter sphere (m**3)
      real, parameter :: vr3mm = 5.23599e-10*(3.0/1.)**3   ! volume of a 3 mm diameter sphere (m**3) (Rasmussen et al. 1984b, JAS)
      real, parameter :: vr4p5mm = 5.23599e-10*(4.5/1.)**3 ! volume of 4.5mm diameter sphere (m**3) (Rasmussen et al. 1984b, JAS)
      real vmlt,vshd, vshdgs(ngs,lh:lhab), maxmassfac(lc:lhab)
      real rhosm
      parameter ( rhosm = 500. )
      integer nc ! condensation step
      real dtcon,dtcon1,dtcon2 ! condensation time step (dtcon*nc = dtp)
      real delta
      integer ltemq1,ltemq1m ! ,ltemq1m2
      real dqv,qv1,ss1,ss2,qvs1,dqvs,dtemp,dt1   ! temporaries for condensation
      real ssi1, ssi2, dqvi, dqvis, dqvii,qis1
      real dqvr, dqc, dqr, dqi, dqs
      real qv1m,qvs1m,ss1m,ssi1m,qis1m
      real cwmastmp
      real  dcloud,dcloud2 ! ,as, bs
      real cn(ngs)
      double precision xvc, xvr
      real mwfac
!      real  es(ngs) ! ss(ngs),
!      real  eis(ngs)

      real rwmasn,rwmasx

      real vgra,vfrz
      parameter ( vgra = 0.523599*(1.0e-3)**3 )
     
!      real, parameter :: epsi = 0.622
!      real, parameter :: d = 0.266
      real :: d, dold, denom,denominv,vth
      double precision :: h1, h2, h3, h4,denomdp, denominvdp
      real r1,qevap ! ,slv
      
      real vr,nrx,chw,g1,qr,z,z1,rdi,alp,xnutmp,xnuc,g1r,rd1,rdia,rmas
      real :: snowmeltmass = 0
      
!      real, parameter :: rhofrz = 900.   ! density of graupel from newly-frozen rain
      real, parameter :: rimedens = 500. ! default rime density

!      real svc(ngs)  !  droplet volume
!
!  contact freezing nucleation
!
      real raero,kaero !assumd aerosol radius, thermal conductivity
      parameter ( raero = 3.e-7, kaero = 5.39e-3 )
      real kb   ! Boltzman constant  J K-1
      parameter (kb = 1.3807e-23)
      
      real knud(ngs),knuda(ngs) !knudsen number and correction factor
      real gtp(ngs)  !G(T,p) = 1/(a' + b')  Cotton 72b
      real dfar(ngs) !aerosol diffusivity
      real fn1(ngs),fn2(ngs),fnft(ngs)
      
      real ccia(ngs)
      real ctfzbd(ngs),ctfzth(ngs),ctfzdi(ngs)
!
!  misc
!
      real ni,nis,nr,d0
      real dqvcnd(ngs),dqwv(ngs),dqcw(ngs),dqci(ngs),dqcitmp(ngs),dqwvtmp(ngs)
      real tempc(ngs)
      real temg(ngs),temcg(ngs),theta(ngs),qvap(ngs) 
      real temgkm1(ngs), temgkm2(ngs)
      real temgx(ngs),temcgx(ngs)
      real qvs(ngs),qis(ngs),qss(ngs),pqs(ngs)
      real elv(ngs),elf(ngs),els(ngs)
      real tsqr(ngs),ssi(ngs),ssw(ngs)
      real qcwtmp(ngs),qtmp,qtot(ngs) 
      real qcond(ngs)
      real ctmp, sctmp
      real cimasn,cimasx,ccimx
      real pid4
      real cs,ds,gf7,gf6,gf5,gf4,gf3,gf2,gf1
      real gcnup1,gcnup2
      real gf73rds, gf83rds
      real gamice73fac, gamsnow73fac
      real gf43rds, gf53rds
      real aradcw,bradcw,cradcw,dradcw,cwrad,rwrad,rwradmn
      parameter ( rwradmn = 50.e-6 )
      real dh0
      real dg0(ngs),df0(ngs)
      
      real clionpmx,clionnmx
      parameter (clionpmx=1.e9,clionnmx=1.e9) ! Takahashi 84
!
!  other arrays

      real fwet1(ngs),fwet2(ngs)   
      real fmlt1(ngs),fmlt2(ngs)  
      real fvds(ngs),fvce(ngs),fiinit(ngs) 
      real fvent(ngs),fraci(ngs),fracl(ngs)
!
      real fai(ngs),fav(ngs),fbi(ngs),fbv(ngs)
      real felv(ngs),fels(ngs),felf(ngs)
      real felvcp(ngs),felscp(ngs),felfcp(ngs)
      real felvpi(ngs),felspi(ngs),felfpi(ngs)
      real felvs(ngs),felss(ngs)      !   ,felfs(ngs)
      real fwvdf(ngs),ftka(ngs),fthdf(ngs)
      real fadvisc(ngs),fakvisc(ngs)
      real fci(ngs),fcw(ngs) ! heat capacities of ice and liquid
      real fschm(ngs),fpndl(ngs)
      real fgamw(ngs),fgams(ngs)
      real fcqv1(ngs),fcqv2(ngs),fcc3(ngs) 
      
      real cvm,cpm,rmm

      real, parameter :: rovcp = rd/cp
      real, parameter ::      cpv = 1885.0       ! specific heat of water vapor at constant pressure
!
      real fcci(ngs), fcip(ngs)
!
      real :: sfm1(ngs),sfm2(ngs)
      real :: gfm1(ngs),gfm2(ngs)
      real :: hfm1(ngs),hfm2(ngs)

      logical :: wetsfc(ngs),wetsfchl(ngs),wetsfcf(ngs)
      logical :: wetgrowth(ngs), wetgrowthhl(ngs), wetgrowthf(ngs)

      real qitmp(ngs),qistmp(ngs)
       
      real rzxh(ngs), rzxhl(ngs), rzxhlh(ngs), rzxhlf(ngs)
      real rzxs(ngs), rzxf(ngs)
!      real axh(ngs),bxh(ngs),axhl(ngs),bxhl(ngs)
      real cdh(ngs),cdhl(ngs)
      real :: axx(ngs,lh:lhab),bxx(ngs,lh:lhab)
      real vt2ave(ngs)

      real :: qcwresv(ngs), ccwresv(ngs) ! "reserved" droplet mass and number that are too small for accretion
      
      real ::  lfsave(ngs,6)
      real ::  qx(ngs,lv:lhab)
      real ::  qxw(ngs,ls:lhab)
      real ::  qxwlg(ngs,lh:lhab)
      real ::  chxf(ngs,lh:lhab)
      real ::  cx(ngs,lc:lhab)
      real ::  cxmxd(ngs,lc:lhab)
      real ::  qxmxd(ngs,lv:lhab)
      real ::  scx(ngs,lc:lhab)
      real ::  xv(ngs,lc:lhab)
      real ::  vtxbar(ngs,lc:lhab,3)
      real ::  xmas(ngs,lc:lhab)
      real ::  xdn(ngs,lc:lhab)
      real ::  cdxgs(ngs,lc:lhab)
      real ::  xdia(ngs,lc:lhab,3)
      real ::  vtwtdia(ngs,lr:lhab) ! sweep-out volume weighted diameter
      real ::  rarx(ngs,ls:lhab)
      real ::  vx(ngs,li:lhab)
      real ::  rimdn(ngs,li:lhab)
      real ::  raindn(ngs,li:lhab)
      real ::  alpha(ngs,lc:lhab)
      real ::  dab0lh(ngs,lc:lhab,lc:lhab)
      real ::  dab1lh(ngs,lc:lhab,lc:lhab)

      real :: qsimxdep(ngs) ! max sublimation of qi+qs+qis
      real :: qsimxsub(ngs) ! max depositionof qi+qs+qis
      logical,parameter :: DoSublimationFix = .true.
      real :: qrtmp(ngs),qvtmp(ngs),qctmp(ngs)
      real :: felvcptmp,felscptmp,qsstmp
      real :: thetatmp, thetaptmp, temcgtmp,qvaptmp
      real :: qvstmp, qisstmp, qvptmp, qitmp1, qctmp1
      
      real :: galphrout
      
      real ventrx(ngs)
      real ventrxn(ngs)
      real g1shr, alphashr
      real g1mlr, alphamlr
      real massfacshr, massfacmlr
      
      real :: qhgt8mm ! ice mass greater than 8mm
      real :: qhwgt8mm ! ice + max water mass greater than 8mm
      real :: qhgt10mm ! mass greater than 10mm
      real :: qhgt20mm ! mass greater than 20mm
      real :: fwmhtmp
      real, parameter :: fwmhtmptem = -15. ! temperature at which fwmhtmp fully switches to liquid water only being on large particles
      real, parameter :: d1t = (6.0 * 0.268e-3/(917.* pi))**(1./3.) ! d1t is the diameter of the ice sphere with the mass (0.268e-3 kg) of an 8mm spherical drop
      real, parameter :: srasheym = 0.1389 ! slope fraction from Rasmussen and Heymsfield 
!
      real swvent(ngs),hwvent(ngs),rwvent(ngs),hlvent(ngs),hwventy(ngs),hlventy(ngs),rwventz(ngs)
      integer, parameter :: ndiam = 10
      integer :: numdiam
      real hwvent0(ndiam+4),hlvent0 ! 0 to d1
      real hwvent1,hlvent1 ! d1 to infinity
      real hwvent2,hlvent2 ! d2 to infinity
      real gama0,gamb0
      real gama1,gamb1
      real gama2,gamb2
!      real, parameter :: mltdiam1 = 9.0e-3, mltdiam1p5 = 16.0e-3, mltdiam2 = 19.0e-3, mltdiam3 = 200.0e-3, mltdiam05 = 4.5e-3
      real :: mltdiam(ndiam+4)
      real mltmass0inv,mltmass1inv,mltmass2inv, mltmass1cgs, mltmass2cgs,mltmass3inv, mltmass3cgs
      real qhmlr0, qhmlr05, qhmlr1, qhmlr2,qhmlr3, qhmlr12, qhmlr23
      real qhlmlr0, qhlmlr05, qhlmlr1, qhlmlr2,qhlmlr3, qhlmlr12, qhlmlr23
      real qxd1, cxd1, zxd1 ! mass and number up to mltdiam1
      real qxd05, cxd05 ! mass and number up to mltdiam1/2
      
      real :: qxd(ndiam+4), cxd(ndiam+4), qhml(ndiam+4), qhml0(ndiam+4)
      real :: dqxd(ndiam+4), dcxd(ndiam+4), dqhml(ndiam+4)
      
      
      real civent(ngs)
      real isvent(ngs)
!
      real xmascw(ngs)
      real xdnmx(lc:lhab), xdnmn(lc:lhab)
      real dnmx
      real :: xdiamxmas(ngs,lc:lhab)
!
      real cilen(ngs) ! ,ciplen(ngs)
!
!
      real rwcap(ngs),swcap(ngs)
      real hwcap(ngs)
      real hlcap(ngs)
      real cicap(ngs)
      real iscap(ngs)

      real qvimxd(ngs)
      real qimxd(ngs),qismxd(ngs),qcmxd(ngs),qrmxd(ngs),qsmxd(ngs),qhmxd(ngs),qhlmxd(ngs)
      real cimxd(ngs),ccmxd(ngs),crmxd(ngs),csmxd(ngs),chmxd(ngs)
      real cionpmxd(ngs),cionnmxd(ngs)
      real clionpmxd(ngs),clionnmxd(ngs)


      real elec(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) ! Ez (elecsave)

!
!
      ! Hallett-Mossop arrays
      real chmul1(ngs),chlmul1(ngs),csmul1(ngs),csmul(ngs)
      real qhmul1(ngs),qhlmul1(ngs),qsmul1(ngs),qsmul(ngs)
      
      ! splinters from drop freezing
      real csplinter(ngs),qsplinter(ngs)
      real csplinter2(ngs),qsplinter2(ngs)
!
!
!  concentration arrays...
!
      real :: chlcnh(ngs), vhlcnh(ngs), vhlcnhl(ngs)
      real :: chlcnhhl(ngs) ! number of new hail particles (may be different from number of lost graupel)
      real cracif(ngs), ciacrf(ngs)
      real cracr(ngs)

!
      real ciint(ngs), crfrz(ngs), crfrzf(ngs), crfrzs(ngs)
      real cicint(ngs)
      real cipint(ngs)
      real ciacw(ngs), cwacii(ngs) 
      real ciacr(ngs), craci(ngs)
      real csacw(ngs)
      real csacr(ngs)
      real csaci(ngs),   csacs(ngs)
      real cracw(ngs) 
      real chacw(ngs), chacr(ngs)
      real :: chlacw(ngs) 
      real chaci(ngs), chacs(ngs)
!
      real :: chlacr(ngs)
      real :: chlaci(ngs), chlacs(ngs)
      real crcnw(ngs) 
      real cidpv(ngs),cisbv(ngs)
      real cisdpv(ngs),cissbv(ngs)
      real cimlr(ngs),cismlr(ngs)

      real chlsbv(ngs), chldpv(ngs)
      real chlmlr(ngs), chlmlrr(ngs)
!      real chlmlrsave(ngs),chlsave(ngs),qhlsave(ngs)
      real chlshr(ngs), chlshrr(ngs)


      real chdpv(ngs),chsbv(ngs)
      real chmlr(ngs),chcev(ngs)
      real chmlrr(ngs)
      real chshr(ngs), chshrr(ngs)

      real csdpv(ngs),cssbv(ngs)
      real csmlr(ngs),csmlrr(ngs),cscev(ngs)
      real csshr(ngs), csshrr(ngs)

      real crcev(ngs)
      real crshr(ngs)
      real cwshw(ngs), qwshw(ngs)
!
!
! arrays for w-ac-x ;  x-ac-w
!
!
!
      real qrcnw(ngs), qwcnr(ngs)
      real zrcnw(ngs),zracr(ngs),zracw(ngs),zrcev(ngs)


      real qracw(ngs) ! qwacr(ngs),
      real qiacw(ngs) !, qwaci(ngs)

      real qsacw(ngs) ! ,qwacs(ngs),
      real qhacw(ngs) ! qwach(ngs),
      real :: qhlacw(ngs) ! 
      real vhacw(ngs), vsacw(ngs), vhlacw(ngs), vhlacr(ngs)

      real qfmul1(ngs),cfmul1(ngs)
!
      real qsacws(ngs)

!
!  arrays for x-ac-r and r-ac-x; 
!
      real qsacr(ngs),qracs(ngs)
      real qhacr(ngs),qhacrmlr(ngs) ! ,qrach(ngs)
      real vhacr(ngs), zhacr(ngs), zhacrf(ngs), zrach(ngs), zrachl(ngs)
      real qiacr(ngs),qraci(ngs)
      
      real ziacr(ngs)

      real qracif(ngs),qiacrf(ngs),qiacrs(ngs),ciacrs(ngs)

      real :: qhlacr(ngs),qhlacrmlr(ngs)
      real qsacrs(ngs) !,qracss(ngs)
!
!  ice - ice interactions
!
      real qsaci(ngs)
      real qsacis(ngs)
      real qhaci(ngs)
      real qhacs(ngs)

      real :: qhacis(ngs) 
      real :: chacis(ngs) 
      real :: chacis0(ngs)

      real :: csaci0(ngs) ! collision rate only
      real :: chaci0(ngs) ! collision rate only
      real :: chacs0(ngs) ! collision rate only
      real :: chlaci0(ngs)
      real :: chlacis(ngs)
      real :: chlacis0(ngs)
      real :: chlacs0(ngs) 

      real :: qsaci0(ngs) ! collision rate only
      real :: qsacis0(ngs) ! collision rate only
      real :: qhaci0(ngs) ! collision rate only
      real :: qhacis0(ngs) ! collision rate only
      real :: qhacs0(ngs) ! collision rate only
      real :: qhlaci0(ngs)  
      real :: qhlacis0(ngs)
      real :: qhlacs0(ngs) 

      real :: qhlaci(ngs)  
      real :: qhlacis(ngs)
      real :: qhlacs(ngs)
!
!  conversions
!
      real qrfrz(ngs) ! , qirirhr(ngs)
      real zrfrz(ngs), zrfrzf(ngs), zrfrzs(ngs)
      real ziacrf(ngs), zhcnsh(ngs), zhcnih(ngs)
      real zhacw(ngs), zhacs(ngs), zhaci(ngs)
      real zhmlr(ngs), zhdsv(ngs), zhsbv(ngs), zhlcnh(ngs), zhshr(ngs)
      real zfacw(ngs), zfacs(ngs), zfaci(ngs)
      real zfmlr(ngs), zfdsv(ngs), zfsbv(ngs), zhlcnf(ngs), zfshr(ngs), zfshrr(ngs)
      real zhmlrtmp,zhmlr0inf,zhlmlr0inf
      real zhmlrr(ngs),zhlmlrr(ngs),zhshrr(ngs),zhlshrr(ngs),zfmlrr(ngs)
      real zsmlr(ngs), zsmlrr(ngs), zsshr(ngs)
      real zhcns(ngs), zhcni(ngs)
      real zhwdn(ngs), zfwdn(ngs) ! change in Z due to density changes
      real zhldn(ngs) ! change in Z due to density changes

      real zhlacw(ngs), zhlacs(ngs), zhlacr(ngs)
      real zhlmlr(ngs), zhldsv(ngs), zhlsbv(ngs), zhlshr(ngs)

      
      real vrfrzf(ngs), viacrf(ngs)
      real qrfrzs(ngs), qrfrzf(ngs)
      real qwfrz(ngs), qwctfz(ngs)
      real cwfrz(ngs), cwctfz(ngs)
      real qwfrzis(ngs), qwctfzis(ngs) ! droplet freezing to ice spheres
      real cwfrzis(ngs), cwctfzis(ngs)
      real qwfrzc(ngs), qwctfzc(ngs) ! droplet freezing to columns
      real cwfrzc(ngs), cwctfzc(ngs)
      real qwfrzp(ngs), qwctfzp(ngs) ! droplet freezing to plates
      real cwfrzp(ngs), cwctfzp(ngs)
      real xcolmn(ngs), xplate(ngs)
      real ciihr(ngs), qiihr(ngs)
      real cicichr(ngs), qicichr(ngs)
      real cipiphr(ngs), qipiphr(ngs)
      real qscni(ngs), cscni(ngs), cscnis(ngs)
      real qscnvi(ngs), cscnvi(ngs), cscnvis(ngs)
      real qhcns(ngs), chcns(ngs), chcnsh(ngs), vhcns(ngs)
      real qscnh(ngs), cscnh(ngs), vscnh(ngs)
      real qhcni(ngs), chcni(ngs), chcnih(ngs), vhcni(ngs)
      real qiint(ngs),qipipnt(ngs),qicicnt(ngs)
      real cninm(ngs),cnina(ngs),cninp(ngs),wvel(ngs),wvelkm1(ngs)
      real tke(ngs)
      real uvel(ngs),vvel(ngs)
!
      real qidpv(ngs),qisbv(ngs) ! qicnv(ngs),qievv(ngs),
      real qimlr(ngs),qidsv(ngs),qisdsv(ngs),qidsvp(ngs) ! ,qicev(ngs)
      real qismlr(ngs)

!
!
      real :: qhldpv(ngs), qhlsbv(ngs) ! qhlcnv(ngs),qhlevv(ngs),
      real :: qhlmlr(ngs), qhldsv(ngs), qhlmlrsave(ngs)
      real :: qhlwet(ngs), qhldry(ngs), qhlshr(ngs) 
!
      real :: qrfz(ngs),qsfz(ngs),qhfz(ngs),qhlfz(ngs)
!
      real qhdpv(ngs),qhsbv(ngs) ! qhcnv(ngs),qhevv(ngs),
      real qhmlr(ngs),qhdsv(ngs),qhcev(ngs),qhcndv(ngs),qhevv(ngs)
      real qhlcev(ngs), chlcev(ngs)
      real qhwet(ngs),qhdry(ngs),qhshr(ngs)
      real qhshrp(ngs)
      real qhshh(ngs) !accreted water that remains on graupel
      real qhmlh(ngs) !melt water that remains on graupel
      real qhfzh(ngs) !water that freezes on mixed-phase graupel
      real qhlfzhl(ngs) !water that freezes on mixed-phase hail
      
      real qhmlrlg(ngs),qhlmlrlg(ngs) ! melting from the larger diameters
      real qhfzhlg(ngs) !water that freezes on mixed-phase graupel (large sizes)
      real qhlfzhllg(ngs) !water that freezes on mixed-phase hail (large sizes)
      real qhlcevlg(ngs), chlcevlg(ngs)
      real qhcevlg(ngs), chcevlg(ngs)

      real vhfzh(ngs), vffzf(ngs) ! change in volume from water that freezes on mixed-phase graupel, frozen drops
      real vhlfzhl(ngs) !  change in volume from water that freezes on mixed-phase hail

      real vhshdr(ngs) !accreted water that leaves on graupel (mixedphase)
      real vhlshdr(ngs) !accreted water that leaves on hail (mixedphase)
      real vhmlr(ngs) !melt water that leaves graupel (single phase)
      real vhlmlr(ngs) !melt water that leaves hail (single phase)
      real vhsoak(ngs) !  aquired water that seeps into graupel.
      real vhlsoak(ngs) !  aquired water that seeps into hail.
      
!
      real qsdpv(ngs),qssbv(ngs) ! qscnv(ngs),qsevv(ngs),
      real qsmlr(ngs),qsdsv(ngs),qscev(ngs),qscndv(ngs),qsevv(ngs)
      real qswet(ngs),qsdry(ngs),qsshr(ngs)
      real qsshrp(ngs)
      real qsfzs(ngs)
!
!
      real qipdpv(ngs),qipsbv(ngs)
      real qipmlr(ngs),qipdsv(ngs)
!
      real qirdpv(ngs),qirsbv(ngs)
      real qirmlr(ngs),qirdsv(ngs),qirmlw(ngs)
!
      real qgldpv(ngs),qglsbv(ngs)
      real qglmlr(ngs),qgldsv(ngs)
      real qglwet(ngs),qgldry(ngs),qglshr(ngs)
      real qglshrp(ngs)
!
      real qgmdpv(ngs),qgmsbv(ngs)
      real qgmmlr(ngs),qgmdsv(ngs)
      real qgmwet(ngs),qgmdry(ngs),qgmshr(ngs)
      real qgmshrp(ngs)
      real qghdpv(ngs),qghsbv(ngs)
      real qghmlr(ngs),qghdsv(ngs) 
      real qghwet(ngs),qghdry(ngs),qghshr(ngs)
      real qghshrp(ngs)
!
      real qrztot(ngs),qrzmax(ngs),qrzfac(ngs)
      real qrcev(ngs)
      real qrshr(ngs)
      real fsw(ngs),fhw(ngs),fhlw(ngs),ffw(ngs) !liquid water fractions
      real fswmax(ngs),fhwmax(ngs),fhlwmax(ngs) !liquid water fractions
      real qhcnf(ngs) 
      real :: qhlcnh(ngs)
      real qhcngh(ngs),qhcngm(ngs),qhcngl(ngs)
      
      real :: qhcnhl(ngs), chcnhl(ngs), zhcnhl(ngs), vhcnhl(ngs) ! conversion of low-density hail back to graupel

      real eiw(ngs),eii(ngs),eiri(ngs),eipir(ngs),eisw(ngs)
      real erw(ngs),esw(ngs),eglw(ngs),eghw(ngs),efw(ngs)
      real ehxw(ngs),ehlw(ngs),egmw(ngs),ehw(ngs)
      real err(ngs),esr(ngs),eglr(ngs),eghr(ngs),efr(ngs)
      real ehxr(ngs),ehlr(ngs),egmr(ngs) 
      real eri(ngs),esi(ngs),egli(ngs),eghi(ngs),efi(ngs),efis(ngs)
      real ehxi(ngs),ehli(ngs),egmi(ngs),ehi(ngs),ehis(ngs),ehlis(ngs)
      real ers(ngs),ess(ngs),egls(ngs),eghs(ngs),efs(ngs),ehs(ngs)
      real ehscnv(ngs)
      real ehxs(ngs),ehls(ngs),egms(ngs),egmip(ngs) 

      real ehsclsn(ngs),ehiclsn(ngs),ehisclsn(ngs)
      real efsclsn(ngs),eficlsn(ngs),efisclsn(ngs)
      real ehlsclsn(ngs),ehliclsn(ngs),ehlisclsn(ngs)
      real esiclsn(ngs)

      real :: ehs_collsn = 0.5, ehi_collsn = 1.0
      real :: efs_collsn = 0.5, efi_collsn = 1.0
      real :: ehls_collsn = 1.0, ehli_collsn = 1.0
      real :: esi_collsn = 1.0
      
      real ew(8,6)
      real cwr(8,2)  ! radius and inverse of interval
      data cwr / 2.0, 3.0, 4.0, 6.0,  8.0,  10.0, 15.0,  20.0 , & ! radius
     &           1.0, 1.0, 0.5, 0.5,  0.5,   0.2,  0.2,  1.  /   ! inverse of interval
      integer icwr(ngs), igwr(ngs), irwr(ngs), ihlr(ngs), ifwr(ngs)
      real grad(6,2) ! graupel radius and inverse of interval
      data grad / 100., 200., 300., 400., 600., 1000.,   &
     &            1.e-2,1.e-2,1.e-2,5.e-3,2.5e-3, 1.    /
!droplet radius: 2     3     4     6     8    10    15    20
      data ew /0.03, 0.07, 0.17, 0.41, 0.58, 0.69, 0.82, 0.88,  & ! 100
!     :         0.07, 0.13, 0.27, 0.48, 0.65, 0.73, 0.84, 0.91,  ! 150
     &         0.10, 0.20, 0.34, 0.58, 0.70, 0.78, 0.88, 0.92,  & ! 200
     &         0.15, 0.31, 0.44, 0.65, 0.75, 0.83, 0.96, 0.91,  & ! 300
     &         0.17, 0.37, 0.50, 0.70, 0.81, 0.87, 0.93, 0.96,  & ! 400
     &         0.17, 0.40, 0.54, 0.71, 0.83, 0.88, 0.94, 0.98,  & ! 600
     &         0.15, 0.37, 0.52, 0.74, 0.82, 0.88, 0.94, 0.98 / ! 1000
!     :         0.11, 0.34, 0.49, 0.71, 0.83, 0.88, 0.94, 0.95 / ! 1400


      real da0lr(ngs),da1lr(ngs)
      real da0lc(ngs),da1lc(ngs)
      real da0lh(ngs)
      real da0lhl(ngs)
      real da0lf(ngs)
      real :: da0lx(ngs,lr:lhab)
      
      real va0 (lc:lqmx)          ! collection coefficients from Seifert 2005
      real vab0(lc:lqmx,lc:lqmx)  ! collection coefficients from Seifert 2005
      real vab1(lc:lqmx,lc:lqmx)  ! collection coefficients from Seifert 2005
      real va1 (lc:lqmx)          ! collection coefficients from Seifert 2005
      real ehip(ngs),ehlip(ngs),ehlir(ngs)
      real erir(ngs),esir(ngs),eglir(ngs),egmir(ngs),eghir(ngs)
      real efir(ngs),ehir(ngs),eirw(ngs),eirir(ngs),ehr(ngs)
      real erip(ngs),esip(ngs),eglip(ngs),eghip(ngs)
      real efip(ngs),eipi(ngs),eipw(ngs),eipip(ngs)
!
!  arrays for production terms
!
      real ptotal(ngs) ! , pqtot(ngs)
!
      real pqcwi(ngs),pqcii(ngs),pqrwi(ngs),pqisi(ngs)
      real pqswi(ngs),pqhwi(ngs),pqwvi(ngs)
      real pqgli(ngs),pqghi(ngs),pqfwi(ngs)
      real pqgmi(ngs),pqhli(ngs) ! ,pqhxi(ngs)
      real pqiri(ngs),pqipi(ngs) ! pqwai(ngs),
      real pqlwsi(ngs),pqlwhi(ngs),pqlwhli(ngs)
      
      real pqlwlghi(ngs),pqlwlghli(ngs)
      real pqlwlghd(ngs),pqlwlghld(ngs)
      
      

      real pvhwi(ngs), pvhwd(ngs)
      real pvfwi(ngs), pvfwd(ngs)
      real pvhli(ngs), pvhld(ngs)
      real pvswi(ngs), pvswd(ngs)
!
      real pqcwd(ngs),pqcid(ngs),pqrwd(ngs),pqisd(ngs), pqcwdacc(ngs)
      real pqswd(ngs),pqhwd(ngs),pqwvd(ngs)
      real pqgld(ngs),pqghd(ngs),pqfwd(ngs)
      real pqgmd(ngs),pqhld(ngs) ! ,pqhxd(ngs)
      real pqird(ngs),pqipd(ngs) ! pqwad(ngs),
      real pqlwsd(ngs),pqlwhd(ngs),pqlwhld(ngs)
!
!      real pqxii(ngs,nhab),pqxid(ngs,nhab)
!
      real  pctot(ngs)
      real  pcipi(ngs), pcipd(ngs)
      real  pciri(ngs), pcird(ngs)
      real  pccwi(ngs), pccwd(ngs), pccwdacc(ngs)
      real  pccii(ngs), pccid(ngs)
      real  pcisi(ngs), pcisd(ngs)
      real  pccin(ngs)
      real  pcrwi(ngs), pcrwd(ngs)
      real  pcswi(ngs), pcswd(ngs)
      real  pchwi(ngs), pchwd(ngs)
      real  pchli(ngs), pchld(ngs)
      real  pcfwi(ngs), pcfwd(ngs)
      real  pcgli(ngs), pcgld(ngs)
      real  pcgmi(ngs), pcgmd(ngs)
      real  pcghi(ngs), pcghd(ngs)

      real  pzrwi(ngs), pzrwd(ngs)
      real  pzhwi(ngs), pzhwd(ngs)
      real  pzfwi(ngs), pzfwd(ngs)
      real  pzhli(ngs), pzhld(ngs)
      real  pzswi(ngs), pzswd(ngs)

!
!  other arrays
!
      real dqisdt(ngs) !,advisc(ngs) !dqwsdt(ngs), ,schm(ngs),pndl(ngs)

      real qss0(ngs)

      real qsacip(ngs)
      real pres(ngs),pipert(ngs)
      real pk(ngs)
      real rho0(ngs),pi0(ngs)
      real rhovt(ngs),sqrtrhovt
      real thetap(ngs),theta0(ngs),qwvp(ngs),qv0(ngs)
      real thsave(ngs)
      real ptwfzi(ngs),ptimlw(ngs)
      real psub(ngs),pvap(ngs),pfrz(ngs),ptem(ngs),pmlt(ngs),pevap(ngs),pdep(ngs),ptem2(ngs)
      
      real cnostmp(ngs)   ! for diagnosed snow intercept
!
!  iholef = 1 to do hole filling technique version 1
!  which uses all hydrometerors to do hole filling of all hydrometeors
!  iholef = 2 to do hole filling technique version 2
!  which uses an individual hydrometeror species to do hole
!  filling of a species of a hydrometeor
!
!  iholen = interval that hole filling is done
!
      integer  iholef
      integer  iholen
      parameter (iholef = 1)
      parameter (iholen = 1)
      real  cqtotn,cqtotn1
      real  cctotn
      real  citotn
      real  crtotn
      real  cstotn
      real  cvtotn
      real  cftotn
      real  cgltotn
      real  cghtotn
      real  chtotn
      real  cqtotp,cqtotp1
      real  cctotp
      real  citotp
      real  ciptotp
      real  crtotp
      real  cstotp
      real  cvtotp
      real  cftotp
      real  chltotp
      real  cgltotp
      real  cgmtotp
      real  cghtotp
      real  chtotp
      real  cqfac
      real  ccfac
      real  cifac
      real  cipfac
      real  crfac
      real  csfac
      real  cvfac
      real  cffac
      real  cglfac
      real  cghfac
      real  chfac
      
      real ssifac, qvapor
!
!   Miscellaneous variables
!
      real, parameter :: cwmas30 = 1000.*0.523599*(2.*30.e-6)**3 ! mass of 30-micron radius droplet, for sat. adj.
      real, parameter :: cwmas20 = 1000.*0.523599*(2.*20.e-6)**3 ! mass of 20-micron radius droplet, for sat. adj.
      integer ireadqf,lrho,lqsw,lqgl,lqgm ,lqgh 
      integer lqrw
      real vt
      real arg  ! gamma is a function
      real erbnd1, fdgt1, costhe1
      real qeps
      real dyi2,dzi2,cp608,bta1,cnit,dragh,dnz00,pii
      real qccrit,gf4br,gf4ds,gf4p5, gf3ds, gf1ds,gr
      real gf1palp(ngs) ! for storing Gamma[1.0 + alphar]

      
      real xdn0(lc:lhab)
      real xdn_new,drhodt
      
      integer l ,ltemq,inumgs, idelq

      real brz,arz,temq

      real ssival,tqvcon
      real cdx(lc:lhab)
      real cnox
      real cval,aval,eval,fval,gval ,qsign,ftelwc,qconkq,elecfac,altelecfac
      real qconm,qconn,cfce15,gf8,gf4i,gf3p5,gf1a,gf1p5,qdiff,argrcnw
      real c4,bradp,bl2,bt2,dthr,hrifac, hdia0,hdia1,civenta,civentb
      real civentc,civentd,civente,civentf,civentg,cireyn,xcivent
      real cipventa,cipventb,cipventc,cipventd,cipreyn,cirventa
      real cirventb
      integer igmrwa,igmrwb,igmswa, igmswb,igmfwa,igmfwb,igmhwa,igmhwb
      real rwventa ,rwventb,swventa,swventb,fwventa,fwventb,fwventc
      real hwventa,hwventb
      real    hwventc, hlventa, hlventb,  hlventc
      real  glventa, glventb, glventc
      real   gmventa, gmventb,  gmventc, ghventa, ghventb, ghventc
      real  dzfacp,  dzfacm,  cmassin,  cwdiar 
      real  rimmas, rhobar
      real   argtim, argqcw, argqxw, argtem
      real   frcswsw, frcswgl, frcswgm, frcswgh, frcswfw, frcswsw1
      real   frcglgl, frcglgm, frcglgh,  frcglfw, frcglgl1
      real   frcgmgl, frcgmgm, frcgmgh,  frcgmfw, frcgmgm1
      real   frcghgl, frcghgm, frcghgh,  frcghfw,  frcghgh1
      real   frcfwgl, frcfwgm, frcfwgh, frcfwfw,  frcfwfw1
      real   frcswrsw, frcswrgl,  frcswrgm,  frcswrgh, frcswrfw
      real   frcswrsw1
      real   frcrswsw, frcrswgl, frcrswgm, frcrswgh, frcrswfw
      real  frcrswsw1
      real  frcglrgl, frcglrgm, frcglrgh,  frcglrfw, frcglrgl1
      real  frcrglgl
      real  frcrglgm,  frcrglgh, frcrglfw, frcrglgl1
      real  frcgmrgl, frcgmrgm, frcgmrgh, frcgmrfw,  frcgmrgm1
      real  frcrgmgl, frcrgmgm,  frcrgmgh, frcrgmfw, frcrgmgm1
      real  sum,  qweps,  gf2a, gf4a, dqldt, dqidt, dqdt
      real frcghrgl, frcghrgm, frcghrgh, frcghrfw, frcghrgh1, frcrghgl
      real frcrghgm, frcrghgh,  frcrghfw, frcrghgh1
      real    a1,a2,a3,a4,a5,a6
      real   gamss
      real cdw, cdi, denom1, denom2, delqci1, delqip1
      real cirtotn,  ciptotn, cgmtotn, chltotn,  cirtotp
      real  cgmfac, chlfac,  cirfac
      integer igmhla, igmhlb, igmgla, igmglb, igmgma,  igmgmb
      integer igmgha, igmghb
      integer idqis, item, itim0 
      integer  iqgl, iqgm, iqgh, iqrw, iqsw 
      integer  itertd, ia
      
      integer :: infdo
      
      real tau, ewtmp
      
      integer cntnic_noliq
      real     q_noliqmn, q_noliqmx
      real     scsacimn, scsacimx
      
      real :: dtpinv
      
!   arrays for temporary bin space

      real :: xden,xmlt,cmlt,cmlttot,fventm,fventh,am,ah,felfinv,dmwdt

      real :: qhmlrtmp,qhmlrtmp2, chmlrtmp, chmlrtmpd1inf, chlmlrtmp, zhlmlrtmp, zhlmlrrtmp, qvs0,tmpcmlt

      real :: term1,term2,term3,term4
      real :: qaacw ! combined qsacw-qhacw for WSM6 variation



!
! ####################################################################
!
!  Start routine
!
! ####################################################################



!

       pb(:) = 0.0
       pinit(:) = 0.0
      itile = nx
      jtile = ny
      ktile = nz
      ixend = nx
      jyend = ny
      kzend = nz
      nxend = nx + 1
      nyend = ny + 1
      nzend = nz
      kzbeg = 1
      nzbeg = 1

      istag = 0
      jstag = 0
      kstag = 1



!
!  slope intercepts
!

      IF ( ngs .lt. nz ) THEN
!       write(0,*) 'Error in ICEZVD: Must have ngs .ge. nz!'
!       STOP
      ENDIF

      cntnic_noliq = 0
      q_noliqmn = 0.0
      q_noliqmx = 0.0
      scsacimn = 0.0
      scsacimx = 0.0

      ldovol = .false.

      DO il = lc,lhab
        ldovol = ldovol .or. ( lvol(il) .gt. 1 )
      ENDDO


      ffrzh = 1
!      DO il = lc,lhab
!        write(iunit,*) 'delqnxa(',il,') = ',delqnxa(il)
!      ENDDO
      
!
!  density maximums and minimums
!

!
!  Set terminal velocities...
!    also set drag coefficients
!

      dtpinv = 1.d0/dtp

!

!
!  electricity constants
!
!  mixing ratio epsilon
!
      qeps  = 1.0e-20

!  rebound efficiency (erbnd)
!
!
!
!  constants
!

      cp608 = 0.608
      aradcw = -0.27544
      bradcw = 0.26249e+06
      cradcw = -1.8896e+10
      dradcw = 4.4626e+14
      bta1 = 0.6
      cnit = 1.0e-02
      dragh = 0.60
      dnz00 = 1.225
!      cs = 4.83607122
!      ds = 0.25
!  new values for  cs and ds
      cs = 12.42
      ds = 0.42
      pii = piinv ! 1./pi
      pid4 = pi/4.0 
!      qscrit = 6.0e-04
      gf1 = 1.0 ! gamma(1.0)
      gf1p5 = 0.8862269255  ! gamma(1.5)
      gf2 = 1.0 ! gamma(2.0)
      gf3 = 2.0 ! gamma(3.0)
      gf3p5 = 3.32335097 ! gamma(3.5)
      gf4 = 6.00 ! gamma(4.0)
      gf5 = 24.0 ! gamma(5.0)
      gf6 = 120.0 ! gamma(6.0)
      gf7 = 720.0 ! gamma(7.0)
      gf4br = 17.837861981813607 ! gamma(4.0+br)
      gf4ds = 10.41688578110938 ! gamma(4.0+ds)
      gf4p5 = 11.63172839656745 ! gamma(4.0+0.5)
      gf3ds = 3.0458730354120997 ! gamma(3.0+ds)
      gf1ds = 0.8863557896089221 ! gamma(1.0+ds)
      gr = 9.8
      gf43rds = 0.8929795116 ! gamma(4./3.)
      gf53rds = 0.9027452930 ! gamma(5./3.)
      gf73rds = 1.190639349 ! gamma(7./3.)
      gf83rds = 1.504575488 ! gamma(8./3.)
      
      gamice73fac =  (Gamma_sp(7./3. + cinu))**3/ (Gamma_sp(1. + cinu)**3 * (1. + cinu)**4)
      gamsnow73fac =  (Gamma_sp(7./3. + snu))**3/ (Gamma_sp(1. + snu)**3 * (1. + snu)**4)
      
!      gcnup1 = Gamma_sp(cnu + 1.)
!      gcnup2 = Gamma_sp(cnu + 2.)
!
!  constants
!
!
!  general constants for microphysics
!
      brz = 100.0
      arz = 0.66
      
      bfnu1 = (4. + alphar)*(5. + alphar)*(6. + alphar)/ &
     &       ((1. + alphar)*(2. + alphar)*(3. + alphar))

       galpharaut = (6.+alpharaut)*(5.+alpharaut)*(4.+alpharaut)/ &
     &             ((3.+alpharaut)*(2.+alpharaut)*(1.+alpharaut))
      
      vfrz = 0.523599*(dfrz)**3 
      vmlt = Min(xvmx(lr), 0.523599*(dmlt)**3 )
      vshd = Min(xvmx(lr), 0.523599*(dshd)**3 )

      snowmeltmass = pi/6.0 * 1000. * snowmeltdia**3  ! maximum rain particle mass from melting snow (if snowmeltdia > 0)

      tdtol = 1.0e-05
      tfrcbw = tfr - cbw
      tfrcbi = tfr - cbi
!
!
! #ifdef COMMAS
!      print*,'ventr,ventc = ',ventr,ventc

!
!  Set up look up tables for supersaturation w.r.t. liq and ice
!
!VD$L SKIP
!      do l = 1,nqsat
!      temq = 163.15 + (l-1)*fqsat
!      tabqvs(l) = exp(caw*(temq-273.15)/(temq-cbw))
!      tabqis(l) = exp(cai*(temq-273.15)/(temq-cbi))
!      end do

      mltmass0inv = 1.0/( 1000.0* xvmx(lr) ) ! for drops melting from ice with diameter > 1.9cm
      mltmass1inv = 1.0/( 1000.0*(4.0*pi/3.0)*((0.01*0.5*takshedsize1)**3) ) ! for drops melting from ice with diameter > 1.9cm; 0.01 converts cm to m, 0.5 conv. diam to radius
      mltmass2inv = 1.0/( 1000.0*(4.0*pi/3.0)*((0.01*0.5*takshedsize2)**3) ) ! for drops melting from ice with 0.9cm < d < 1.9cm (or 1.6cm to 1.9cm)
      mltmass3inv = 1.0/( 1000.0*(4.0*pi/3.0)*((0.01*0.5*takshedsize3)**3) ) ! for drops melting from ice with 0.9cm < d < 1.6cm
      mltmass1cgs =  1.0*(4.0*pi/3.0)*((0.5*takshedsize1)**3) 
      mltmass2cgs =  1.0*(4.0*pi/3.0)*((0.5*takshedsize2)**3) 
      mltmass3cgs =  1.0*(4.0*pi/3.0)*((0.5*takshedsize3)**3) 
      
!      real, parameter :: mltdiam1 = 9.0e-3, mltdiam2 = 19.0e-3, mltdiam05 = 4.5e-3

      IF ( ibinnum == 1 ) THEN
        numdiam = 1 ! must have numdiam < ndiam because numdiam+1 holds values for the interval of mltdiam(numdiam) to mltdiam(ndiam+1)
        mltdiam(1) = 4.5e-3
      ELSEIF ( ibinnum == 2 ) THEN
        numdiam = 2 ! must have numdiam < ndiam because numdiam+1 holds values for the interval of mltdiam(numdiam) to mltdiam(ndiam+1)
        mltdiam(1) = mltdiam1/6. ! 1.5e-3
        mltdiam(2) = mltdiam1/2. ! 4.5e-3
      ELSEIF ( ibinnum > 2 ) THEN
        numdiam = Min(ibinnum, ndiam)
        DO k = 1,numdiam
          mltdiam(k) = (k - 0.5)*mltdiam1/float(numdiam)
        ENDDO
      
      ELSE
        numdiam = 5 ! must have numdiam < ndiam because numdiam+1 holds values for the interval of mltdiam(numdiam) to mltdiam(ndiam+1)
        mltdiam(1) = 0.5e-3
        mltdiam(2) = 1.0e-3
        mltdiam(3) = 2.0e-3
        mltdiam(4) = 4.0e-3
        mltdiam(5) = 6.0e-3
      ENDIF


      IF ( numshedregimes == 2 ) THEN
        mltdiam(ndiam+1) = mltdiam1 !  9.0e-3
        mltdiam(ndiam+2) = mltdiam3 ! 19.0e-3
        mltdiam(ndiam+3) = mltdiam4 !100.0e-3
      ELSEIF ( numshedregimes == 3 ) THEN
        mltdiam(ndiam+1) = mltdiam1 !  9.0e-3
        mltdiam(ndiam+2) = mltdiam2 ! 16.0e-3
        mltdiam(ndiam+3) = mltdiam3 ! 19.0e-3
        mltdiam(ndiam+4) = mltdiam4 !200.0e-3
      ENDIF

      kzb = 1
      kze = ktile
!      if (kzend .eq. nzend) kze = kzend-kzbeg+1-kstag

!
!  cw constants in mks units
!
!      cwmasn = 4.25e-15  ! radius of 1.0e-6
      mwfac = 6.0**(1./3.)
      IF ( ipconc .ge. 2 ) THEN
!        cwmasn = xvmn(lc)*1000.
!        cwradn = 1.0e-6
!        cwmasx = xvmx(lc)*1000.
      ENDIF
        rwmasn = xvmn(lr)*1000.
        rwmasx = xvmx(lr)*1000.

      IF ( biggsnowdiam > 0.0 ) THEN
        xvbiggsnow = (pi/6.0)*biggsnowdiam**3
      ELSE
        xvbiggsnow = xvmn(lh)
      ENDIF

!
!  ci constants in mks units
!
      cimasn = Min(cimas0, cimas1) ! 12 microns for  0.1871*(xmas(mgs,li)**(0.3429))
      cimasx = 1.0e-8   ! 338 microns
      ccimx = 5000.0e3   ! max of 5000 per liter

!
!  constants for paramerization
!
!
!  set save counter (number of saves):  nsvcnt
!
!      nsvcnt = 0
      iend = 0


!      timetd1 = etime(tarray)
!      timetd1 = tarray(1)

!
!***********************************************************
!  start jy loop
!***********************************************************
!

!      do 9999 jy = 1,ny-jstag
!
!  VERY IMPORTANT:  SET jy = jgs
!
      jy = jgs
     
     
!      t1(:,:,:) = 0
!      t2(:,:,:) = 0
!      t3(:,:,:) = 0
!      t4(:,:,:) = 0
!      t5(:,:,:) = 0
!      t6(:,:,:) = 0
!      t8(:,:,:) = 0
      
      IF ( ipconc < 2 ) THEN ! Make a copy of cloud droplet mixing ratio to use for homogeneous freezing
        DO kz = 1,kze
         DO ix = 1,itile
           t9(ix,jy,kz) = an(ix,jy,kz,lc)
         ENDDO
        ENDDO
      ENDIF
      
!
!..Gather microphysics  
!
      if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: ENTER GATHER STAGE'


      
      nxmpb = 1
      nzmpb = 1
      nxz = itile*nz
      numgs = nxz/ngs + 1
!      write(0,*) 'ICEZVD_GS: ENTER GATHER STAGE: nx,nz,nxz,numgs,ngs = ',nx,nz,nxz,numgs,ngs

      do 1000 inumgs = 1,numgs
      ngscnt = 0
      
      do kz = nzmpb,kze
      do ix = nxmpb,itile

      pqs(1) = t00(ix,jy,kz)
!      pqs(kz) = t00(ix,jy,kz)

      theta(1) = an(ix,jy,kz,lt)
      temg(1) = t0(ix,jy,kz)
      temcg(1) = temg(1) - tfr
      tqvcon = temg(1)-cbw
      ltemq = (temg(1)-163.15)/fqsat+1.5
      ltemq = Min( nqsat, Max(1,ltemq) )
      qvs(1) = pqs(1)*tabqvs(ltemq)
      qis(1) = pqs(1)*tabqis(ltemq)

      qss(1) = qvs(1)

!      IF ( jy .eq. 1 .and. ix .eq. 24 ) THEN
!       write(91,*) 'kz,qv,th: ',kz,an(ix,jy,kz,lv),an(ix,jy,kz,lt),pqs(kz),tabqvs(ltemq),qvs(kz)
!      ENDIF

      if ( temg(1) .lt. tfr ) then
!      if( qcw(kz) .le. qxmin(lc) .and. qci(kz) .gt. qxmin(li))
!     >  qss(kz) = qis(kz)
!      if( qcw(kz) .gt. qxmin(lc) .and. qci(kz) .gt. qxmin(li))
!     >   qss(kz) = (qcw(kz)*qvs(kz) + qci(kz)*qis(kz)) /
!     >   (qcw(kz) + qci(kz))
      qss(1) = qis(1)
      else
!       IF ( an(ix,jy,kz,lv)  .gt. qss(kz) ) THEN
!       write(iunit,*) 'qss exceeded at ',ix,jy,kz,qss(kz),an(ix,jy,kz,lv),temg(kz)
!       write(iunit,*) 'other temg = ',theta(kz)*(pinit(kz)+p2(ix,jy,kz))
!       ENDIF
      end if
!
      ishail = .false.
      IF ( lhl > 1 ) THEN
        IF ( an(ix,jy,kz,lhl)  .gt. qxmin(lhl) ) ishail = .true.
      ENDIF


      
      if ( an(ix,jy,kz,lv)  .gt. qss(1) .or.   &
     &     an(ix,jy,kz,lc)  .gt. qxmin(lc)   .or.    &
     &     an(ix,jy,kz,li)  .gt. qxmin(li)   .or.   &
     &     an(ix,jy,kz,lr)  .gt. qxmin(lr)   .or.   &
     &     an(ix,jy,kz,ls)  .gt. qxmin(ls)   .or.   &
     &     an(ix,jy,kz,lh)  .gt. qxmin(lh)   .or.  ishail ) then
      ngscnt = ngscnt + 1
      igs(ngscnt) = ix
      kgs(ngscnt) = kz
      if ( ngscnt .eq. ngs ) goto 1100
      end if
      enddo !ix
      nxmpb = 1
      enddo !kz
 1100 continue

      if ( ngscnt .eq. 0 ) go to 9998

      if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: dbg = 5, ngscnt = ',ngscnt
      
!      write(0,*) 'allocating qc'

      
      xv(:,:) = 0.0
      xmas(:,:) = 0.0
      vtxbar(:,:,:) = 0.0
      xdia(:,:,:) = 0.0
      raindn(:,:) = 900.
      cx(:,:) = 0.0
      IF ( lnhf > 1 .or. lnhlf > 1 ) chxf(:,:) = 0.0
      alpha(:,:) = 0.0
      DO il = li,lhab
        DO mgs = 1,ngscnt
          rimdn(mgs,il)  = rimedens ! xdn0(il)
        ENDDO
      ENDDO
!
!  define temporaries for state variables to be used in calculations
!
      if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: dbg = def temps'
      do mgs = 1,ngscnt
      kgsm(mgs) = max(kgs(mgs)-1,1)
      kgsp(mgs) = min(kgs(mgs)+1,nz-1)
      kgsm2(mgs) = Max(kgs(mgs)-2,1)
      theta0(mgs) = an(igs(mgs),jy,kgs(mgs),lt)
      thetap(mgs) = an(igs(mgs),jy,kgs(mgs),lt) - theta0(mgs)
      theta(mgs) = an(igs(mgs),jy,kgs(mgs),lt)
      qv0(mgs) = an(igs(mgs),jy,kgs(mgs),lv)
      qwvp(mgs) = an(igs(mgs),jy,kgs(mgs),lv)  - qv0(mgs) ! qv0(mgs) is full qv, so qwvp starts as zero!

      pres(mgs) = pn(igs(mgs),jy,kgs(mgs)) + pb(kgs(mgs))
      pipert(mgs) = p2(igs(mgs),jy,kgs(mgs))
      rho0(mgs) = dn(igs(mgs),jy,kgs(mgs))
      rhoinv(mgs) = 1.0/rho0(mgs)
      rhovt(mgs) = Sqrt(rho00/Max(0.05,rho0(mgs))) ! prevent excessive rhovt
      pi0(mgs) = p2(igs(mgs),jy,kgs(mgs)) + pinit(kgs(mgs))
      temg(mgs) = t0(igs(mgs),jy,kgs(mgs))
      temgkm1(mgs) = t0(igs(mgs),jy,kgsm(mgs))
      temgkm2(mgs) = t0(igs(mgs),jy,kgsm2(mgs))
      pk(mgs)   = p2(igs(mgs),jy,kgs(mgs)) + pinit(kgs(mgs)) ! t77(igs(mgs),jy,kgs(mgs))
      temcg(mgs) = temg(mgs) - tfr
      qss0(mgs) = (380.0)/(pres(mgs))
      pqs(mgs) = (380.0)/(pres(mgs))
      ltemq = (temg(mgs)-163.15)/fqsat+1.5
      ltemq = Min( nqsat, Max(1,ltemq) )
      qvs(mgs) = pqs(mgs)*tabqvs(ltemq)
      qis(mgs) = pqs(mgs)*tabqis(ltemq)
      qss(mgs) = qvs(mgs)
!      es(mgs)  = 6.1078e2*tabqvs(ltemq)
!      eis(mgs) = 6.1078e2*tabqis(ltemq)
      cnostmp(mgs) = cno(ls)
!

      il5(mgs) = 0
      if ( temg(mgs) .lt. tfr ) then
      il5(mgs) = 1
      end if
      enddo !mgs
      
      IF ( ipconc < 1 .and. lwsm6 ) THEN
        DO mgs = 1,ngscnt
          tmp = Min( 0.0, temcg(mgs) )
          cnostmp(mgs) = Min( 2.e8, 2.e6*exp(0.12*tmp) )
        ENDDO
      ENDIF


!
! zero arrays that are used but not otherwise set (tm)
!
      do mgs = 1,ngscnt
         qhshr(mgs) = 0.0 
       end do
!
!  set temporaries for microphysics variables
!
      DO il = lv,lhab
      do mgs = 1,ngscnt
        qx(mgs,il) = max(an(igs(mgs),jy,kgs(mgs),il), 0.0) 
      ENDDO
      end do

      qxw(:,:) = 0.0
      qxwlg(:,:) = 0.0



        scx(:,:) = 0.0
!
!  set shape parameters
!
      IF ( imurain == 1 ) THEN
        alpha(:,lr) = alphar
      ELSEIF ( imurain == 3 ) THEN
        alpha(:,lr) = xnu(lr)
      ENDIF
      
      alpha(:,li) = xnu(li)
      alpha(:,lc) = xnu(lc)

      IF ( imusnow == 1 ) THEN
        alpha(:,ls) = alphas
      ELSEIF ( imusnow == 3 ) THEN
        alpha(:,ls) = xnu(ls)
      ENDIF
      
      DO il = lr,lhab
      do mgs = 1,ngscnt
        IF ( il .ge. lg ) alpha(mgs,il) = dnu(il)


        DO ic = lc,lhab
        dab0lh(mgs,il,ic) =  dab0(il,ic) ! dab0(ic,il)
        dab1lh(mgs,il,ic) =  dab1(il,ic) ! dab1(ic,il)
        ENDDO
      ENDDO
      end do
      
      
!      DO mgs = 1,ngscnt
        DO il = lr,lhab
          da0lx(:,il) = da0(il)
        ENDDO
        da0lh(:) = da0(lh)
        da0lr(:) = da0(lr)
        da1lr(:) = da1(lr)
        da0lc(:) = da0(lc)
        da1lc(:) = da1(lc)


        IF ( lzh < 1 .or. lzhl < 1 ) THEN
          rzxhlh(:) = rzhl/rz
        ELSEIF ( lzh > 1 .and. lzhl > 1 ) THEN
          rzxhlh(:) = 1.
        ENDIF
        IF ( lzr > 1 ) THEN
          rzxh(:) = 1.
          rzxhl(:) = 1.
        ELSE
          rzxh(:) = rz
          rzxhl(:) = rzhl
        ENDIF
        
        IF ( imurain == 1 .and. imusnow == 3 .and. lzr < 1 ) THEN
          rzxs(:) = rzs
        ELSEIF ( imurain == imusnow .or. lzr > 1 ) THEN
          rzxs(:) = 1.
        ENDIF
 !     ENDDO
      
      IF ( lhl .gt. 1 ) THEN
      DO mgs = 1,ngscnt
        da0lhl(mgs) = da0(lhl)
      ENDDO
      ENDIF
      
      ventrx(:) = ventr
      ventrxn(:) = ventrn
      gf1palp(:) = gamma_sp(1.0 + alphar)

!
!  set concentrations
!
!      ssmax = 0.0
      
      
      if ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*)  'ICEZVD_GS: dbg = 5b'
      
      if ( ipconc .ge. 1 ) then
       do mgs = 1,ngscnt
        cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0)
          IF ( qx(mgs,li) .le. qxmin(li) ) THEN
            cx(mgs,li) = 0.0
          ENDIF

        IF ( lcina .gt. 1 ) THEN
         cina(mgs) = an(igs(mgs),jy,kgs(mgs),lcina)
        ELSE
         cina(mgs) = cx(mgs,li)
        ENDIF
        IF ( lcin > 1 ) THEN
         ccin(mgs) = an(igs(mgs),jy,kgs(mgs),lcin)
        ENDIF
       end do
      end if
      if ( ipconc .ge. 2 ) then
       do mgs = 1,ngscnt
        cx(mgs,lc) = Max(an(igs(mgs),jy,kgs(mgs),lnc), 0.0)
!        cx(mgs,lc) = Min( ccwmx, cx(mgs,lc) )
        IF ( qx(mgs,lc) .le. qxmin(lc) ) THEN
          cx(mgs,lc) = 0.0
        ENDIF
        IF ( lss > 1 ) THEN
        ssmax(mgs) = an(igs(mgs),jy,kgs(mgs),lss)
        ENDIF
        IF ( lccn .gt. 1 ) THEN
         ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn)
        ELSE
         ccnc(mgs) = 0.0
        ENDIF
        IF ( lccna .gt. 1 ) THEN
         ccna(mgs) = an(igs(mgs),jy,kgs(mgs),lccna)
        ELSE
         ccna(mgs) = cx(mgs,lc)
        ENDIF
       end do
!       ELSE
!       cx(mgs,lc) = Abs(ccn)
      end if
      if ( ipconc .ge. 3 ) then
       do mgs = 1,ngscnt
        cx(mgs,lr) = Max(an(igs(mgs),jy,kgs(mgs),lnr), 0.0)
        IF ( qx(mgs,lr) .le. qxmin(lr) ) THEN
!          cx(mgs,lr) = 0.0
        ELSEIF ( cx(mgs,lr) .eq. 0.0 .and. qx(mgs,lr) .lt. 3.0*qxmin(lr) ) THEN
          qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lr)
          qx(mgs,lr) = 0.0
        ELSE
          cx(mgs,lr) = Max( 1.e-9, cx(mgs,lr) )
        ENDIF
       end do
      end if
      if ( ipconc .ge. 4 ) then
       do mgs = 1,ngscnt
        cx(mgs,ls) = Max(an(igs(mgs),jy,kgs(mgs),lns), 0.0)
        IF ( qx(mgs,ls) .le. qxmin(ls) ) THEN
!          cx(mgs,ls) = 0.0
        ELSEIF ( cx(mgs,ls) .eq. 0.0 .and. qx(mgs,ls) .lt. 3.0*qxmin(ls) ) THEN
          qx(mgs,lv) = qx(mgs,lv) + qx(mgs,ls)
          qx(mgs,ls) = 0.0
        ELSE
          cx(mgs,ls) = Max( 1.e-9, cx(mgs,ls) )

         IF ( ilimit .ge. ipc(ls) ) THEN
            tmp = (xdn0(ls)*cx(mgs,ls))/(rho0(mgs)*qx(mgs,ls))
            tmp2 = (tmp*(3.14159))**(1./3.)
            cnox = cx(mgs,ls)*(tmp2)
         IF ( cnox .gt. 3.0*cno(ls) ) THEN
           cx(mgs,ls) = 3.0*cno(ls)/tmp2
         ENDIF
         ENDIF
        ENDIF
       end do
      end if
      if ( ipconc .ge. 5 ) then
       do mgs = 1,ngscnt

        cx(mgs,lh) = Max(an(igs(mgs),jy,kgs(mgs),lnh), 0.0)
        IF ( qx(mgs,lh) .le. qxmin(lh) ) THEN
!          cx(mgs,lh) = 0.0
        ELSEIF ( cx(mgs,lh) .eq. 0.0 .and. qx(mgs,lh) .lt. 3.0*qxmin(lh) ) THEN
          qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lh) 
          qx(mgs,lh) = 0.0
        ELSE
          cx(mgs,lh) = Max( 1.e-9, cx(mgs,lh) )
         IF ( ilimit .ge. ipc(lh) ) THEN
            tmp = (xdn0(lh)*cx(mgs,lh))/(rho0(mgs)*qx(mgs,lh))
            tmp2 = (tmp*(3.14159))**(1./3.)
            cnox = cx(mgs,lh)*(tmp2)
         IF ( cnox .gt. 3.0*cno(lh) ) THEN
           cx(mgs,lh) = 3.0*cno(lh)/tmp2
         ENDIF
         ENDIF
        ENDIF


       end do


      end if

      if ( lhl .gt. 1 .and. ipconc .ge. 5 ) then
       do mgs = 1,ngscnt

        cx(mgs,lhl) = Max(an(igs(mgs),jy,kgs(mgs),lnhl), 0.0)
        IF ( qx(mgs,lhl) .le. qxmin(lhl) ) THEN
          cx(mgs,lhl) = 0.0
        ELSEIF ( cx(mgs,lhl) .eq. 0.0 .and. qx(mgs,lhl) .lt. 3.0*qxmin(lhl) ) THEN
          qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lhl) 
          qx(mgs,lhl) = 0.0
        ELSE
          cx(mgs,lhl) = Max( 1.e-9, cx(mgs,lhl) )
         IF ( ilimit .ge. ipc(lhl) ) THEN
            tmp = (xdn0(lhl)*cx(mgs,lhl))/(rho0(mgs)*qx(mgs,lhl))
            tmp2 = (tmp*(3.14159))**(1./3.)
            cnox = cx(mgs,lhl)*(tmp2)
         IF ( cnox .gt. 3.0*cno(lhl) ) THEN
           cx(mgs,lhl) = 3.0*cno(lhl)/tmp2
         ENDIF
         ENDIF
        ENDIF


       end do
      end if

!
! Set mean particle volume
!
      IF ( ldovol ) THEN
      
      vx(:,:) = 0.0
      
       DO il = li,lhab
        
        IF ( lvol(il) .ge. 1 ) THEN
        
          DO mgs = 1,ngscnt
            vx(mgs,il) = Max(an(igs(mgs),jy,kgs(mgs),lvol(il)), 0.0)
          ENDDO

        ENDIF

       ENDDO

      ENDIF


!
! Set liquid water fraction
!
      fhw(:) = 0.0
      fsw(:) = 0.0
      fhlw(:) = 0.0




!
!  set factors
!
      do mgs = 1,ngscnt
!
      ssi(mgs) = qx(mgs,lv)/qis(mgs)
      ssw(mgs) = qx(mgs,lv)/qvs(mgs)
!
      tsqr(mgs) = temg(mgs)**2
!
      temgx(mgs) = min(temg(mgs),313.15)
      temgx(mgs) = max(temgx(mgs),233.15)
      felv(mgs) = 2500837.367 * (273.15/temgx(mgs))**((0.167)+(3.67e-4)*temgx(mgs))
!
      temcgx(mgs) = min(temg(mgs),273.15)
      temcgx(mgs) = max(temcgx(mgs),223.15)
      temcgx(mgs) = temcgx(mgs)-273.15

! felf = latent heat of fusion, fels = LH of sublimation, felv = LH of vaporization
      felf(mgs) = 333690.6098 + (2030.61425)*temcgx(mgs) - (10.46708312)*temcgx(mgs)**2
!
      fels(mgs) = felv(mgs) + felf(mgs)
!
      felvs(mgs) = felv(mgs)*felv(mgs)
      felss(mgs) = fels(mgs)*fels(mgs)
      
        IF ( eqtset <= 1 ) THEN
          felvcp(mgs) = felv(mgs)*cpi
          felscp(mgs) = fels(mgs)*cpi
          felfcp(mgs) = felf(mgs)*cpi
        ELSE
          
          ! equations from appendix in Bryan and Morrison (2012, MWR)
          ! note that rw is Rv in the paper, and rd is R.
          
          tmp = qx(mgs,li)+qx(mgs,ls)+qx(mgs,lh)
          IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl)
          cvm = cv+cvv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr))   &
                                  +cpigb*(tmp)

          IF ( eqtset == 2 ) THEN ! compact form from treating dT/dt = theta*d(pi)/dt + pi*d(theta)dt and then applied to theta assuming constant pi
          felvcp(mgs) = (felv(mgs)-rw*temg(mgs))/cvm
          felscp(mgs) = (fels(mgs)-rw*temg(mgs))/cvm
          felfcp(mgs) = felf(mgs)/cvm
          
          ELSE
           ! equivalent version that applies separate updates of latent heating to theta and pi, when both are returned.

          cpm = cp+cpv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr))   &
                                  +cpigb*(tmp)
          rmm=rd+rw*qx(mgs,lv)
          
          felvcp(mgs) = (felv(mgs)*cv/(cp) - rw*temg(mgs)*(1.0-rovcp*cpm/rmm))/cvm
          felscp(mgs) = (fels(mgs)*cv/(cp) - rw*temg(mgs)*(1.0-rovcp*cpm/rmm))/cvm
          felfcp(mgs) = felf(mgs)*cv/(cp*cvm)

          felvpi(mgs) = pi0(mgs)*rovcp*(felv(mgs)/(temg(mgs)) - rw*cpm/rmm)/cvm
          felspi(mgs) = pi0(mgs)*rovcp*(fels(mgs)/(temg(mgs)) - rw*cpm/rmm)/cvm 
          felfpi(mgs) = pi0(mgs)*rovcp*(felf(mgs)/(cvm*temg(mgs)))
          
          ENDIF

        ENDIF
!
      fgamw(mgs) = felvcp(mgs)/pi0(mgs)
      fgams(mgs) = felscp(mgs)/pi0(mgs)
!
      fcqv1(mgs) = 4098.0258*pi0(mgs)*fgamw(mgs)
      fcqv2(mgs) = 5807.6953*pi0(mgs)*fgams(mgs)
      fcc3(mgs) = felfcp(mgs)/pi0(mgs)
!
!  fwvdf = water vapor diffusivity
      fwvdf(mgs) = (2.11e-05)*((temg(mgs)/tfr)**1.94)*(101325.0/(pres(mgs)))
!
! fadvisc = 'd' for dynamic viscosity
! fakvisc = 'k' for kinematic viscosity
      fadvisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))*(temg(mgs)/296.0)**(1.5) ! dynamic visc.
!
      fakvisc(mgs) = fadvisc(mgs)*rhoinv(mgs) ! divide by rho_air to get kinematic visc. (note the 'k' vs. 'd')
!
      temcgx(mgs) = min(temg(mgs),273.15)
      temcgx(mgs) = max(temcgx(mgs),233.15)
      temcgx(mgs) = temcgx(mgs)-273.15
      fci(mgs) = (2.118636 + 0.007371*(temcgx(mgs)))*(1.0e+03)
!
      if ( temg(mgs) .lt. 273.15 ) then
      temcgx(mgs) = min(temg(mgs),273.15)
      temcgx(mgs) = max(temcgx(mgs),233.15)
      temcgx(mgs) = temcgx(mgs)-273.15
      fcw(mgs) = 4203.1548  + (1.30572e-2)*((temcgx(mgs)-35.)**2)   &
     &                 + (1.60056e-5)*((temcgx(mgs)-35.)**4)
      end if
      if ( temg(mgs) .ge. 273.15 ) then
      temcgx(mgs) = min(temg(mgs),308.15)
      temcgx(mgs) = max(temcgx(mgs),273.15)
      temcgx(mgs) = temcgx(mgs)-273.15
      fcw(mgs) = 4243.1688  + (3.47104e-1)*(temcgx(mgs)**2)
      end if
!
      ftka(mgs) = tka0*fadvisc(mgs)/advisc1  ! thermal conductivity: proportional to dynamic viscosity
      fthdf(mgs) = ftka(mgs)*cpi*rhoinv(mgs)
!
      fschm(mgs) = (fakvisc(mgs)/fwvdf(mgs))  ! Schmidt number
      fpndl(mgs) = (fakvisc(mgs)/fthdf(mgs))  ! Prandl number (only used for bin melting)
!
      fai(mgs) = (fels(mgs)**2)/(ftka(mgs)*rw*temg(mgs)**2)
      fbi(mgs) = (1.0/(rho0(mgs)*fwvdf(mgs)*qis(mgs)))
      fav(mgs) = (felv(mgs)**2)/(ftka(mgs)*rw*temg(mgs)**2)
      fbv(mgs) = (1.0/(rho0(mgs)*fwvdf(mgs)*qvs(mgs)))

      kp1 = Min(nz, kgs(mgs)+1 )
      wvel(mgs) = (0.5)*(w(igs(mgs),jgs,kp1)   &
     &                  +w(igs(mgs),jgs,kgs(mgs)))

!
      end do
!
!
!   ice habit fractions
!
!
!
!  Set density
!
      if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: Set density'
!

      do mgs = 1,ngscnt
        xdn(mgs,li) = xdn0(li)
        xdn(mgs,lc) = xdn0(lc)
        xdn(mgs,lr) = xdn0(lr)
        xdn(mgs,ls) = xdn0(ls)
        xdn(mgs,lh) = xdn0(lh)
        IF ( lvol(ls) .gt. 1 ) THEN
         IF ( vx(mgs,ls) .gt. 0.0 .and. qx(mgs,ls) .gt. qxmin(ls) ) THEN
           xdn(mgs,ls) = Min( xdnmx(ls), Max( xdnmn(ls), rho0(mgs)*qx(mgs,ls)/vx(mgs,ls) ) )
         ENDIF
        ENDIF

        IF ( lvol(lh) .gt. 1 ) THEN
         IF ( vx(mgs,lh) .gt. 0.0 .and. qx(mgs,lh) .gt. qxmin(lh) ) THEN
           IF ( mixedphase ) THEN
           ELSE
             dnmx = xdnmx(lh)
           ENDIF
           xdn(mgs,lh) = Min( dnmx, Max( xdnmn(lh), rho0(mgs)*qx(mgs,lh)/vx(mgs,lh) ) )
           vx(mgs,lh) = rho0(mgs)*qx(mgs,lh)/xdn(mgs,lh)
         
         ELSEIF ( vx(mgs,lh) == 0.0 .and. qx(mgs,lh) .gt. qxmin(lh) ) THEN ! if volume is zero, need to initialize the default value

           vx(mgs,lh) = rho0(mgs)*qx(mgs,lh)/xdn(mgs,lh)
         
         ENDIF
        ENDIF


        IF ( lhl .gt. 1 ) THEN

          xdn(mgs,lhl) = xdn0(lhl)

          IF ( lvol(lhl) .gt. 1 ) THEN
           IF ( vx(mgs,lhl) .gt. 0.0 .and. qx(mgs,lhl) .gt. qxmin(lhl) ) THEN

           IF ( mixedphase .and. lhlw > 1 ) THEN
           ELSE
             dnmx = xdnmx(lhl)
           ENDIF

             xdn(mgs,lhl) = Min( dnmx, Max( xdnmn(lhl), rho0(mgs)*qx(mgs,lhl)/vx(mgs,lhl) ) )
             vx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/xdn(mgs,lhl)
         
           ELSEIF ( vx(mgs,lhl) == 0.0 .and. qx(mgs,lhl) .gt. qxmin(lhl) ) THEN ! if volume is zero, need to initialize the default value

             vx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/xdn(mgs,lhl)
         
           ENDIF
          ENDIF

        ENDIF


      end do


       IF ( imurain == 3 ) THEN
         IF ( lzr > 1 ) THEN
           alphashr = 0.0
           alphamlr = -2.0/3.0
         ELSE
           alphashr = xnu(lr)
           alphamlr = xnu(lr)
         ENDIF
!         massfacshr = ( (2. + 3.*(1. +alphashr) )/( 3.*(1. + alphashr) ) )**(1./3.) ! this is the diameter factor
!         massfacmlr = ( (2. + 3.*(1. +alphamlr) )/( 3.*(1. + alphamlr) ) )**(1./3.)
         massfacshr = ( (2. + 3.*(1. +alphashr) )**3/( 3.*(1. + alphashr) ) )  ! this is the mass or volume factor
         massfacmlr = ( (2. + 3.*(1. +alphamlr) )**3/( 3.*(1. + alphamlr) ) )
       ELSEIF ( imurain == 1 ) THEN
         IF ( lzr > 1 ) THEN
           alphashr = 4.0
           alphamlr = 4.0
         ELSE
           alphashr = alphar
           alphamlr = alphar
         ENDIF
!         massfacshr = (3.0 + alphashr)*((3.+alphashr)*(2.+alphashr)*(1. + alphashr) )**(-1./3.) ! this is the diameter factor
!         massfacmlr = (3.0 + alphamlr)*((3.+alphamlr)*(2.+alphamlr)*(1. + alphamlr) )**(-1./3.)
         massfacshr = (3.0 + alphashr)**3/((3.+alphashr)*(2.+alphashr)*(1. + alphashr) ) ! this is the mass or volume factor
         massfacmlr = (3.0 + alphamlr)**3/((3.+alphamlr)*(2.+alphamlr)*(1. + alphamlr) )
       ENDIF
       

!
!  set some values for ice nucleation
!
      do mgs = 1,ngscnt
      kp1 = Min(nz, kgs(mgs)+1 )
!      wvel(mgs) = (0.5)*(w(igs(mgs),jgs,kp1)   &
!     &                  +w(igs(mgs),jgs,kgs(mgs)))

      
        wvelkm1(mgs) = (0.5)*(w(igs(mgs),jgs,kgs(mgs))   &
     &                    +w(igs(mgs),jgs,kgsm(mgs)))
      cninm(mgs) = t7(igs(mgs),jgs,kgsm(mgs))
      cnina(mgs) = t7(igs(mgs),jgs,kgs(mgs))
      cninp(mgs) = t7(igs(mgs),jgs,kgsp(mgs))
      end do

!
!  Set a couple of cloud variables...
!

!      SUBROUTINE setvt(ngscnt,qx,qxmin,cx,rho0,rhovt,xdia,cno,
!     :                 xmas,xdn,xvmn,xvmx,xv,cdx,
!     :                 ipconc,ndebug)
!      SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno, &
!     &                 xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx,            &
!     &                 ipconc1,ndebug1,ngs,nz,kgs,cwnccn,fadvisc,   &
!     &                 cwmasn,cwmasx,cwradn,cnina,cimna,cimxa,      &
!     &                 itype1a,itype2a,temcg,infdo,alpha)


      infdo = 0
      IF ( rimdenvwgt > 0 ) infdo = 1

      call setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp,   &
     &                 xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx,cdxgs,   &
     &                 ipconc,ndebug,ngs,nz,kgs,fadvisc,   &
     &                 cwmasn,cwmasx,cwradn,cnina,cimn,cimx,   &
     &                 itype1,itype2,temcg,infdo,alpha,0,axx,bxx) ! ,cdh,cdhl)
!     &                 itype1,itype2,temcg,infdo,alpha,0,axh,bxh,axhl,bxhl) ! ,cdh,cdhl)


       IF ( lwsm6 .and. ipconc == 0 ) THEN
         tmp = Max(qxmin(lh), qxmin(ls))
         DO mgs = 1,ngscnt
           sum = qx(mgs,lh) + qx(mgs,ls)
           IF ( sum > tmp ) THEN
             vt2ave(mgs) = (qx(mgs,lh)*vtxbar(mgs,lh,1) + qx(mgs,ls)*vtxbar(mgs,ls,1))/sum
           ELSE
             vt2ave(mgs) = 0.0
           ENDIF
         ENDDO
       ENDIF


!
!  Set number concentrations (need xdia from setvt)
!
      if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: Set concentration'
      IF ( ipconc .lt. 1 ) THEN
         cina(1:ngscnt) = cx(1:ngscnt,li)
      ENDIF
      if ( ipconc .lt. 5 ) then
      do mgs = 1,ngscnt


      IF ( ipconc .lt. 3 ) THEN
!      cx(mgs,lr) = 0.0
      if ( qx(mgs,lr) .gt. qxmin(lh) )  then
!      cx(mgs,lr) = cno(lr)*xdia(mgs,lr,1)
!      xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr))
      end if
      ENDIF

      IF ( ipconc .lt. 4 ) THEN
!      tmp = cx(mgs,ls)
!      cx(mgs,ls) = 0.0
      if ( qx(mgs,ls) .gt. qxmin(ls) )  then
!      cx(mgs,ls) = cno(ls)*xdia(mgs,ls,1)
!      xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*cx(mgs,ls))
      end if
      ENDIF ! ( ipconc .lt. 4 )

      IF ( ipconc .lt. 5 ) THEN


!      cx(mgs,lh) = 0.0
      if ( qx(mgs,lh) .gt. qxmin(lh) )  then
!      cx(mgs,lh) = cno(lh)*xdia(mgs,lh,1)
!      xv(mgs,lh) = Max(xvmn(lh), rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) )
!      xdia(mgs,lh,3) = (xv(mgs,lh)*6./pi)**(1./3.) 
      end if

      ENDIF ! ( ipconc .lt. 5 )

      end do
      end if
      
      IF ( ipconc .ge. 2 ) THEN
      DO mgs = 1,ngscnt
        
        rb(mgs) = 0.5*xdia(mgs,lc,1)*(1./(1.+alpha(mgs,lc)))**(1./6.)
        xl2p(mgs) = Max(0.0d0, 2.7e-2*xdn(mgs,lc)*cx(mgs,lc)*xv(mgs,lc)*   &
     &           ((0.5e20*rb(mgs)**3*xdia(mgs,lc,1))-0.4) )
        IF ( rb(mgs) .gt. 3.51e-6 ) THEN
!          rh(mgs) = Max( 0.5d0*xdia(mgs,lc,1), 6.3d-4/(1.d6*(rb(mgs) - 3.5d-6)) )
          rh(mgs) = Max( 41.d-6, 6.3d-4/(1.d6*(rb(mgs) - 3.5d-6)) )
        ELSE
          rh(mgs) = 41.d-6
        ENDIF
        IF ( xl2p(mgs) .gt. 0.0 ) THEN
          nh(mgs) = 4.2d9*xl2p(mgs)
        ELSE
          nh(mgs) = 1.e30
        ENDIF
      ENDDO
      ENDIF
      
!
!
!              
!
!  maximum depletion tendency by any one source
!
!
      if( ndebug .ge. 0 ) THEN
!mpi!        write(0,*) 'Set depletion max/min1'
      endif
      do mgs = 1,ngscnt
      qvimxd(mgs) = 0.70*(qx(mgs,lv)-qis(mgs))*dtpinv ! depletion by all vap. dep to ice.
      
      IF ( qx(mgs,lc) < qxmin(lc) ) qvimxd(mgs) = 0.99*(qx(mgs,lv)-qis(mgs))*dtpinv ! this makes virtually no difference whatsoever, but what the heck
      
      qvimxd(mgs) = max(qvimxd(mgs), 0.0)

      frac = 0.1d0
      qimxd(mgs)  = frac*qx(mgs,li)*dtpinv
      qcmxd(mgs)  = frac*qx(mgs,lc)*dtpinv
      qrmxd(mgs)  = frac*qx(mgs,lr)*dtpinv
      qsmxd(mgs)  = frac*qx(mgs,ls)*dtpinv
      qhmxd(mgs)  = frac*qx(mgs,lh)*dtpinv
      IF ( lhl > 1 ) qhlmxd(mgs)  = frac*qx(mgs,lhl)*dtpinv
      end do
!
      if( ndebug .ge. 0 ) THEN
!mpi!        write(0,*) 'Set depletion max/min2'
      endif

      do mgs = 1,ngscnt
!
      if ( qx(mgs,lc) .le. qxmin(lc) ) then
      ccmxd(mgs)  = 0.20*cx(mgs,lc)*dtpinv
      else
      IF ( ipconc .ge. 2 ) THEN
        ccmxd(mgs)  = frac*cx(mgs,lc)*dtpinv
      ELSE
        ccmxd(mgs)  = frac*qx(mgs,lc)/(xmas(mgs,lc)*rho0(mgs)*dtp)
      ENDIF
      end if
!
      if ( qx(mgs,li) .le. qxmin(li) ) then
      cimxd(mgs)  = frac*cx(mgs,li)*dtpinv
      else
      IF ( ipconc .ge. 1 ) THEN
        cimxd(mgs)  = frac*cx(mgs,li)*dtpinv
      ELSE
        cimxd(mgs)  = frac*qx(mgs,li)/(xmas(mgs,li)*rho0(mgs)*dtp)
      ENDIF
      end if
!
!
      crmxd(mgs)  = 0.10*cx(mgs,lr)*dtpinv
      csmxd(mgs)  = frac*cx(mgs,ls)*dtpinv
      chmxd(mgs)  = frac*cx(mgs,lh)*dtpinv

      ccmxd(mgs)  = frac*cx(mgs,lc)*dtpinv
      cimxd(mgs)  = frac*cx(mgs,li)*dtpinv
      crmxd(mgs)  = frac*cx(mgs,lr)*dtpinv
      csmxd(mgs)  = frac*cx(mgs,ls)*dtpinv
      chmxd(mgs)  = frac*cx(mgs,lh)*dtpinv

      qxmxd(mgs,lv) = Max(0.0, 0.1*(qx(mgs,lv) - qvs(mgs))*dtpinv)

      DO il = lc,lhab
       qxmxd(mgs,il) = frac*qx(mgs,il)*dtpinv
       cxmxd(mgs,il) = frac*cx(mgs,il)*dtpinv
      ENDDO

      end do








    ! default factors between mean volume and maximum mass volume
      maxmassfac(lc) = ( (2. + 3.*(1. + xnu(lc)) )**3/( 3.*(1. + xnu(lc)) ) )
      maxmassfac(li) = ( (2. + 3.*(1. + xnu(li)) )**3/( 3.*(1. + xnu(li)) ) )

      IF ( imurain == 3 ) THEN
        maxmassfac(lr) = ( (2. + 3.*(1. + xnu(lr)) )**3/( 3.*(1. + xnu(lr)) ) )
      ELSE
        maxmassfac(lr) =  (3.0 + alphar)**3/    &
     &                  ((3.+alphar)*(2.+alphar)*(1. + alphar) )
      ENDIF

      IF ( imusnow == 3 ) THEN
        maxmassfac(ls) = ( (2. + 3.*(1. + alphas) )**3/( 3.*(1. + alphas) ) )
      ELSE
        maxmassfac(ls) =  (3.0 + alphas)**3/    &
     &                  ((3.+alphas)*(2.+alphas)*(1. + alphas) )
      ENDIF
      
        maxmassfac(lh) =  (3.0 + alphah)**3/    &
     &                  ((3.+alphah)*(2.+alphah)*(1. + alphah) )

       IF ( lhl > 1 ) THEN
        maxmassfac(lhl) =  (3.0 + alphahl)**3/    &
     &                  ((3.+alphahl)*(2.+alphahl)*(1. + alphahl) )
       ENDIF
      


       DO mgs = 1,ngscnt
          DO il = lh,lhab ! graupel and hail only (and frozen drops)
            
            vshdgs(mgs,il) = vshd ! base value
            
            IF ( qx(mgs,il) > qxmin(il) ) THEN
              
              ! tmpdiam is weighted diameter of d^(shedalp-1), so for shedalp=3, this is the area-weighted diameter or maximum mass diameter.
              tmpdiam = (shedalp+alpha(mgs,il))*xdia(mgs,il,1)*( xdn(mgs,il)/917. )**(1./3.) ! erm added density factor for equiv. solid ice sphere 10.12.2015
              
              IF ( tmpdiam > sheddiam0 ) THEN
                vshdgs(mgs,il) = 0.523599*(1.5e-3)**3/massfacshr ! 1.5mm drops from very large ice
              ELSEIF ( tmpdiam > sheddiam ) THEN ! intermediate size
                vshdgs(mgs,il) = 0.523599*(3.0e-3)**3/massfacshr ! 3.0mm drops from medium-large ice
              ELSE
!                vshdgs(mgs,il) = Min( xvmx(lr), xv(mgs,il)*xdn(mgs,il)*0.001 ) ! size of drop from melted mean ice particle
                vshdgs(mgs,il) = Min( xvmx(lr), 6./pi*xdn(mgs,il)*0.001*tmpdiam**3 )/massfacshr ! size of drop from melted mean ice particle; 0.001 is 1/rhow
              ENDIF
            ENDIF
          ENDDO
       ENDDO

!
!
!  microphysics source terms (1/s) for mixing ratios 
!
!
!
!  Collection efficiencies:
!
      if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: Set collection efficiencies'
!
      do mgs = 1,ngscnt
!
!
!
      qcwresv(mgs) = 0.0
      ccwresv(mgs) = 0.0
      
      erw(mgs) = 0.0
      esw(mgs) = 0.0
      ehw(mgs) = 0.0
      efw(mgs) = 0.0
      ehlw(mgs) = 0.0
!      ehxw(mgs) = 0.0
!
      err(mgs) = 0.0
      esr(mgs) = 0.0
      il2(mgs) = 0
      il3(mgs) = 0
      ehr(mgs) = 0.0
      ehlr(mgs) = 0.0
!      ehxr(mgs) = 0.0
!
      eri(mgs) = 0.0
      esi(mgs) = 0.0
      ehi(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehi*ehiclsn
      ehis(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehi*ehiclsn
      ehli(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehli*ehliclsn
      ehlis(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehli*ehliclsn
!      ehxi(mgs) = 0.0
!
      ers(mgs) = 0.0
      ess(mgs) = 0.0
      ehs(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehs*ehsclsn
      ehls(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehls*ehlsclsn
      ehscnv(mgs) = 0.0
!      ehxs(mgs) = 0.0
!
      eiw(mgs) = 0.0
      eii(mgs) = 0.0

      ehsclsn(mgs) = 0.0
      ehiclsn(mgs) = 0.0
      ehlsclsn(mgs) = 0.0
      ehliclsn(mgs) = 0.0
      esiclsn(mgs) = 0.0


! reserve droplets
         IF ( exwmindiam > 0 .and. qx(mgs,lc) > qxmin(lc) ) THEN
           tmp = cx(mgs,lc)*Exp(- (exwmindiam/xdia(mgs,lc,1))**3 )
           ccwresv(mgs) =  Min( cx(mgs,lc), Max( 2.e6,  cx(mgs,lc) -  tmp ) )
           
           tmp = cx(mgs,lc) - ccwresv(mgs)

           volt = pi/6.*(exwmindiam)**3
           qcwresv(mgs) = qx(mgs,lc) - tmp*xdn0(lc)*rhoinv(mgs)*(volt + xv(mgs,lc))
           
           
           IF ( .false. .and. qx(mgs,lc) > 0.1e-3 ) THEN
           
             write(0,*) 'cx,qx,crsv,qrsv = ',cx(mgs,lc),qx(mgs,lc),ccwresv(mgs),qcwresv(mgs)
           
           ENDIF

         ENDIF


      icwr(mgs) = 1
      IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN
       cwrad = 0.5*xdia(mgs,lc,1)
      DO il = 1,8
         IF ( cwrad .ge. 1.e-6*cwr(il,1) ) icwr(mgs) = il
      ENDDO
      ENDIF


      irwr(mgs) = 1
      IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN
         rwrad = 0.5*xdia(mgs,lr,3)  ! changed to mean volume diameter (10/6/06)
      DO il = 1,6
         IF ( rwrad .ge. 1.e-6*grad(il,1) ) irwr(mgs) = il
      ENDDO
      ENDIF


      igwr(mgs) = 1
!      IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN
!         rwrad = 0.5*xdia(mgs,lr,1)
! setting erw = 1 always, so now use igwr for graupel
      IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN
         rwrad = 0.5*xdia(mgs,lh,3)  ! changed to mean volume diameter (10/6/06)
      DO il = 1,6
         IF ( rwrad .ge. 1.e-6*grad(il,1) ) igwr(mgs) = il
      ENDDO
      ENDIF


      IF ( lhl .gt. 1 ) THEN ! hail is turned on
      ihlr(mgs) = 1
      IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN
         rwrad = 0.5*xdia(mgs,lhl,3)  ! changed to mean volume diameter (10/6/06)
      DO il = 1,6
         IF ( rwrad .ge. 1.e-6*grad(il,1) ) ihlr(mgs) = il
      ENDDO
      ENDIF
      ENDIF

!
!
!  Ice-Ice: Collection (cxc) efficiencies
!
!
      if ( qx(mgs,li) .gt. qxmin(li) ) then
!      IF ( ipconc .ge. 14 ) THEN
!       eii(mgs)=0.1*exp(0.1*temcg(mgs))
!       if ( temg(mgs) .lt. 243.15 .and. qx(mgs,lc) .gt. 1.e-6 ) then
!        eii(mgs)=0.1
!       end if
!      
!      ELSE
        eii(mgs) = exp(0.025*Min(temcg(mgs),0.0))  ! alpha1 from LFO83 (21)
!      ENDIF
      if ( temg(mgs) .gt. 273.15 ) eii(mgs) = 1.0
      end if
!
!
!
!  Ice-cloud water: Collection (cxc) efficiencies
!
!
      eiw(mgs) = 0.0
      if ( qx(mgs,li).gt.qxmin(li) .and. qx(mgs,lc).gt.qxmin(lc) ) then
      
      
      if (xdia(mgs,lc,1).gt.15.0e-06 .and. xdia(mgs,li,1).gt.30.0e-06) then
! erm 5/10/2007 test following change:
!      if (xdia(mgs,lc,1).gt.12.0e-06 .and. xdia(mgs,li,1).gt.50.0e-06) then
      eiw(mgs) = 0.5
      end if
      if ( temg(mgs) .ge. 273.15 ) eiw(mgs) = 0.0
      end if

!
!
!
!  Rain: Collection (cxc) efficiencies
!
!
      if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,lc).gt.qxmin(lc) ) then

       IF ( lnr .gt. 1 ) THEN
       erw(mgs) = 1.0

       ELSE

!      cwrad = 0.5*xdia(mgs,lc,1)
!      erw(mgs) =
!     >  min((aradcw + cwrad*(bradcw + cwrad*
!     <  (cradcw + cwrad*(dradcw)))), 1.0)
!       IF ( xdia(mgs,lc,1) .lt. 2.4e-06 .or. xdia(mgs,lr,1) .le. 50.0e-6 ) THEN
!          erw(mgs)=0.0
!       ENDIF
!       erw(mgs) = ew(icwr(mgs),igwr(mgs))
! interpolate along droplet radius
       ic = icwr(mgs)
       icp1 = Min( 8, ic+1 )
       ir = irwr(mgs)
       irp1 = Min( 6, ir+1 )
       cwrad = 0.5*xdia(mgs,lc,3)
       rwrad = 0.5*xdia(mgs,lr,3)
       
       slope1 = (ew(icp1, ir  ) - ew(ic,ir  ))*cwr(ic,2)
       slope2 = (ew(icp1, irp1) - ew(ic,irp1))*cwr(ic,2)

!       write(iunit,*) 'slop1: ',slope1,slope2,ew(ic,ir),cwr(ic,2)

       x1 = ew(ic,  ir) + slope1*Max(0.0, (cwrad - cwr(ic,1)) )
       x2 = ew(icp1,ir) + slope2*Max(0.0, (cwrad - cwr(ic,1)) )

       slope1 = (x2 - x1)*grad(ir,2)

       erw(mgs) = Max(0.0, x1 + slope1*Max(0.0, (rwrad - grad(ir,1)) ))

!       write(iunit,*) 'erw: ',erw(mgs),1.e6*cwrad,1.e6*rwrad,ic,ir,x1,x2
!       write(iunit,*)

       erw(mgs) = Max(0.0, erw(mgs) )
       IF ( rwrad .lt. 50.e-6 ) THEN
         erw(mgs) = 0.0
       ELSEIF (  rwrad .lt. 100.e-6 ) THEN  ! linear change from zero at 50 to erw at 100 microns
         erw(mgs) = erw(mgs)*(rwrad - 50.e-6)/50.e-6
       ENDIF

       ENDIF
      end if
      IF ( cx(mgs,lc) .le. 0.0 ) erw(mgs) = 0.0
!
      if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,lr).gt.qxmin(lr) ) then
      err(mgs)=1.0
      end if
!
      if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,ls).gt.qxmin(ls) ) then
      ers(mgs)=1.0
      end if
!
      if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,li).gt.qxmin(li) ) then
!        IF ( vtxbar(mgs,lr,1) .gt. vtxbar(mgs,li,1) .and.
!     :       xdia(mgs,lr,3) .gt. 200.e-6 .and. xdia(mgs,li,3) .gt. 100.e-6 ) THEN
         eri(mgs) = eri0
!      cwrad = 0.5*xdia(mgs,li,3)
!      eri(mgs) =
!     >  1.0*min((aradcw + cwrad*(bradcw + cwrad*
!     <  (cradcw + cwrad*(dradcw)))), 1.0)
!         ENDIF
!       if ( xdia(mgs,li,1) .lt. 10.e-6 ) eri(mgs)=0.0
       if ( xdia(mgs,li,3) .lt. eri_cimin ) eri(mgs)=0.0
      end if
!
!
!  Snow aggregates: Collection (cxc) efficiencies
!
! Modified by ERM with a linear function for small droplets and large
! snow agg. based numerical data from Wang and Ji (1992) in P&K 1997 (Fig. 14-13), which
! allows collection of very small droplets, albeit at low efficiency.  But slow
! fall speeds of snow make up for the efficiency.
!
      esw(mgs) = 0.0
      if ( qx(mgs,ls).gt.qxmin(ls) .and. qx(mgs,lc).gt.qxmin(lc) ) then
        esw(mgs) = 0.5
        if ( xdia(mgs,lc,1) .gt. 15.e-6 .and. xdia(mgs,ls,1) .gt. 100.e-6) then
          esw(mgs) = 0.5
        ELSEIF ( xdia(mgs,ls,1) .ge. 500.e-6 ) THEN
          esw(mgs) = Min(0.5, 0.05 + (0.8-0.05)/(40.e-6)*xdia(mgs,lc,1) )
        ENDIF
      end if
!
      if ( qx(mgs,ls).gt.qxmin(ls) .and. qx(mgs,lr).gt.qxmin(lr)  &
     &     .and. temg(mgs) .lt. tfr - 1.   &
     &                               ) then
      esr(mgs)=Exp(-(40.e-6)**3/xv(mgs,lr))*Exp(-40.e-6/xdia(mgs,ls,1))
      IF ( qx(mgs,ls) < 1.e-4 .and. qx(mgs,lr) < 1.e-4 ) il2(mgs) = 1
      end if
      
      IF ( ipconc < 3 .and. temg(mgs) < tfr .and. qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,lr) < 1.e-4 ) THEN
        il3(mgs) = 1
      ENDIF
!
!      if ( qx(mgs,ls).gt.qxmin(ls) ) then
      if ( temcg(mgs) < 0.0 ) then
            
      IF ( ipconc .lt. 4 .or. temcg(mgs) < esstem1 ) THEN
        ess(mgs) = 0.0
!        ess(mgs)=0.1*exp(0.1*min(temcg(mgs),0.0))
!        ess(mgs)=min(0.1,ess(mgs))
      
      ELSE
      
        fac = Abs(ess0)
        IF ( .true. .and. ess0 < 0.0 ) THEN
!         IF ( wvel(mgs) > 2.0 .or. wvel(mgs) < -0.5 .or. ssi(mgs) < 1.0 ) THEN
         IF ( wvel(mgs) > 2.0 ) THEN
          ! assume convective cell or downdraft
           fac = 0.0
         ELSEIF ( wvel(mgs) > 1.0 ) THEN ! transition to stratiform range of values
           fac = Max(0.0, 2.0 - wvel(mgs))*fac
         ENDIF
        ENDIF
        
        IF ( temcg(mgs) > esstem1 .and. temcg(mgs) < esstem2 ) THEN  ! only nonzero for T > -25
          ess(mgs) = fac*Exp(ess1*(esstem2) )*(temcg(mgs) - esstem1)/(esstem2 - esstem1) ! linear ramp up from zero at esstem1 to value at esstem2
        ELSEIF ( temcg(mgs) >= esstem2 ) THEN
          ess(mgs) = fac*Exp(ess1*Min( temcg(mgs), 0.0 ) )
        ENDIF
        
      ENDIF
      end if
!
      if ( qx(mgs,ls).gt.qxmin(ls) .and. qx(mgs,li).gt.qxmin(li) ) then
       esiclsn(mgs) = esi_collsn
!      IF ( ipconc .lt. 4 ) THEN
      IF ( ipconc < 1 .and. lwsm6 ) THEN
        esi(mgs) = exp(0.7*min(temcg(mgs),0.0))
      ELSE
        esi(mgs) = esi0*exp(0.1*min(temcg(mgs),0.0))
        esi(mgs) = Min(0.1,esi(mgs))
      ENDIF
      IF ( ipconc .le. 3 ) THEN
       esi(mgs) =  exp(0.025*min(temcg(mgs),0.0)) ! LFO
!       esi(mgs) =  Min(0.5, exp(0.025*min(temcg(mgs),0.0)) ) ! LFO
!       esi(mgs)=0.5*exp(0.1*min(temcg(mgs),0.0))  ! 10ice
      ENDIF
!      ELSE ! zrnic/ziegler 1993
!      esi(mgs)= 0.1 ! 0.5*exp(0.1*min(temcg(mgs),0.0))
!      ENDIF
      if ( temg(mgs) .gt. 273.15 ) esi(mgs) = 0.0
      end if
!
!
!
!
!  Graupel: Collection (cxc) efficiencies
!
!
       xmascw(mgs) = xmas(mgs,lc)
      if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lc).gt.qxmin(lc) ) then !{
       ehw(mgs) = 1.0
       IF ( iehw .eq. 0 ) THEN
       ehw(mgs) = ehw0  ! default value is 1.0
       ELSEIF ( iehw .eq. 1 .or. iehw .eq. 10 ) THEN
      cwrad = 0.5*xdia(mgs,lc,1)
      ehw(mgs) = Min( ehw0,    &
     &  ewfac*min((aradcw + cwrad*(bradcw + cwrad*   &
     &  (cradcw + cwrad*(dradcw)))), 1.0) )
      
       ELSEIF ( iehw .eq. 2 .or. iehw .eq. 10 ) THEN
       ic = icwr(mgs)
       icp1 = Min( 8, ic+1 )
       ir = igwr(mgs)
       irp1 = Min( 6, ir+1 )
       cwrad = 0.5*xdia(mgs,lc,1)
       rwrad = 0.5*xdia(mgs,lh,3)  ! changed to mean volume diameter
       
       slope1 = (ew(icp1, ir  ) - ew(ic,ir  ))*cwr(ic,2)
       slope2 = (ew(icp1, irp1) - ew(ic,irp1))*cwr(ic,2)
 
!        write(iunit,*) 'slop1: ',slope1,slope2,ew(ic,ir),cwr(ic,2)

       x1 = ew(ic,  ir) + slope1*Max(0.0, (cwrad - cwr(ic,1)) )
       x2 = ew(icp1,ir) + slope2*Max(0.0, (cwrad - cwr(ic,1)) )
       
       slope1 = (x2 - x1)*grad(ir,2)
       
       tmp = Max( 0.0, Min( 1.0, x1 + slope1*Max(0.0, (rwrad - grad(ir,1)) ) ) )
       ehw(mgs) = Min( ehw(mgs), tmp )

!       write(iunit,*) 'ehw: ',ehw(mgs),1.e6*cwrad,1.e6*rwrad,ic,ir,x1,x2
!       write(iunit,*)

!       ehw(mgs) = Max( 0.2, ehw(mgs) )
!  assume that ehw = 1 for zero air resistance (rho0 = 0.0) and extrapolate toward that
!      ehw(mgs) = ehw(mgs) + (ehw(mgs) - 1.0)*(rho0(mgs) - rho00)/rho00
!      ehw(mgs) = ehw(mgs) + (1.0 - ehw(mgs))*((Max(0.0,rho00 - rho0(mgs)))/rho00)**2

       ELSEIF ( iehw .eq. 3 .or. iehw .eq. 10 ) THEN ! use fraction of droplets greater than dmincw diameter
         tmp = Exp(- (dmincw/xdia(mgs,lc,1))**3)
         xmascw(mgs) = xmas(mgs,lc) + xdn0(lc)*(pi*dmincw**3/6.0) ! this is the average mass of the droplets with d > dmincw
         ehw(mgs) = Min( ehw(mgs), tmp )
       ELSEIF ( iehw .eq. 4 .or. iehw .eq. 10 ) THEN ! Cober and List 1993, eq. 19-20
         tmp =  &
     &   2.0*xdn(mgs,lc)*vtxbar(mgs,lh,1)*(0.5*xdia(mgs,lc,1))**2 &
     &  /(9.0*fadvisc(mgs)*0.5*xdia(mgs,lh,3))
         tmp = Max( 1.5, Min(10.0, tmp) )
         ehw(mgs) = Min( ehw(mgs), 0.55*Log10(2.51*tmp) )
       ENDIF
      if ( xdia(mgs,lc,1) .lt. 2.4e-06 ) ehw(mgs)=0.0

       ehw(mgs) = Min( ehw0, ehw(mgs) )
       
       IF ( ibfc == -1 .and. temcg(mgs) < -41.0 ) THEN
        ehw(mgs) = 0.0
       ENDIF 

      end if !}
!
      if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lr).gt.qxmin(lr)    &
!     &     .and. temg(mgs) .lt. tfr    &
     &                               ) then
!      ehr(mgs) = Exp(-(40.e-6)**3/xv(mgs,lr))*Exp(-40.e-6/xdia(mgs,lh,1))
!      ehr(mgs) = 1.0
       ehr(mgs) = Exp(-(40.e-6)/xdia(mgs,lr,3))*Exp(-40.e-6/xdia(mgs,lh,3))
       ehr(mgs) = Min( ehr0, ehr(mgs) )
      end if
!
      IF ( qx(mgs,ls).gt.qxmin(ls) ) THEN
        IF ( ipconc .ge. 4 ) THEN
        ehscnv(mgs) = ehs0*exp(ehs1*min(temcg(mgs),0.0)) ! for 2-moment, used as default for ehs and ehls. Otherwise not used for snow->graupel conversion
        ELSE
        ehscnv(mgs) = exp(0.09*min(temcg(mgs),0.0))
        ENDIF
        if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lc) > qxmin(lc)  ) then
          ehsclsn(mgs) = ehs_collsn
          IF ( xdia(mgs,ls,3) < 40.e-6 ) THEN
            ehsclsn(mgs) = 0.0
          ELSEIF ( xdia(mgs,ls,3) < 150.e-6 ) THEN
            ehsclsn(mgs) =  ehs_collsn*(xdia(mgs,ls,3) - 40.e-6)/(150.e-6 - 40.e-6)
          ELSE
            ehsclsn(mgs) = ehs_collsn
          ENDIF
!          ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0., xdn(mgs,lh) - xdnmn(lh)*1.2)/xdnmn(lh)  ) ! shut off qhacs as graupel goes to lowest density
          ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300.  ) ! shut off qhacs as graupel goes to low density
          ehs(mgs) = Min(ehs(mgs),ehsmax)
          IF ( qx(mgs,lc) < qxmin(lc) ) ehs(mgs) = 0.0
        end if
      ENDIF
!
      if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,li).gt.qxmin(li) ) then
      ehiclsn(mgs) = ehi_collsn
      ehi(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0))
      ehi(mgs) = Min( ehimax, Max( ehi(mgs), ehimin ) )
      if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehi(mgs) = 0.0
      end if

      IF ( lis > 1 ) THEN
      if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lis).gt.qxmin(lis) ) then
      ehisclsn(mgs) = ehi_collsn
      ehis(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0))
      ehis(mgs) = Min( ehimax, Max( ehis(mgs), ehimin ) )
      if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehis(mgs) = 0.0
      end if
      ENDIF

 
!
!
!  Hail: Collection (cxc) efficiencies
!
!
      IF ( lhl .gt. 1 ) THEN

      if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,lc).gt.qxmin(lc) ) then
       IF ( iehw == 3 ) iehlw = 3
       IF ( iehw == 4 ) iehlw = 4
       ehlw(mgs) = ehlw0
       IF ( iehlw .eq. 0 ) THEN
       ehlw(mgs) = ehlw0  ! default value is 1.0
       ELSEIF ( iehlw .eq. 1 .or. iehlw .eq. 10 ) THEN
      cwrad = 0.5*xdia(mgs,lc,1)
      ehlw(mgs) = Min( ehlw0,    &
     &  ewfac*min((aradcw + cwrad*(bradcw + cwrad*   &
     &  (cradcw + cwrad*(dradcw)))), 1.0) )
      
       ELSEIF ( iehlw .eq. 2 .or. iehlw .eq. 10 ) THEN
       ic = icwr(mgs)
       icp1 = Min( 8, ic+1 )
       ir = ihlr(mgs)
       irp1 = Min( 6, ir+1 )
       cwrad = 0.5*xdia(mgs,lc,1)
       rwrad = 0.5*xdia(mgs,lhl,3)  ! changed to mean volume diameter
       
       slope1 = (ew(icp1, ir  ) - ew(ic,ir  ))*cwr(ic,2)
       slope2 = (ew(icp1, irp1) - ew(ic,irp1))*cwr(ic,2)
       
       x1 = ew(ic,  ir) + slope1*(cwrad - cwr(ic,1))
       x2 = ew(icp1,ir) + slope2*(cwrad - cwr(ic,1))
       
       slope1 = (x2 - x1)*grad(ir,2)
       
       tmp = Max( 0.0, Min( 1.0, x1 + slope1*(rwrad - grad(ir,1)) ) )
         ehlw(mgs) = Min( ehlw(mgs), tmp )
       ehlw(mgs) = Min( ehlw0, ehlw(mgs) )
!       ehw(mgs) = Max( 0.2, ehw(mgs) )
!  assume that ehw = 1 for zero air resistance (rho0 = 0.0) and extrapolate toward that
!      ehw(mgs) = ehw(mgs) + (ehw(mgs) - 1.0)*(rho0(mgs) - rho00)/rho00
!      ehlw(mgs) = ehlw(mgs) + (1.0 - ehlw(mgs))*((Max(0.0,rho00 - rho0(mgs)))/rho00)**2

       ELSEIF ( iehlw .eq. 3 .or. iehlw .eq. 10 ) THEN ! use fraction of droplets greater than 15 micron diameter
         tmp = Exp(- (dmincw/xdia(mgs,lc,1))**3)
         ehlw(mgs) = Min( ehlw(mgs), tmp )
       ELSEIF ( iehlw .eq. 4 .or. iehlw .eq. 10 ) THEN ! Cober and List 1993
         tmp =  &
     &   2.0*xdn(mgs,lc)*vtxbar(mgs,lhl,1)*(0.5*xdia(mgs,lc,1))**2 &
     &  /(9.0*fadvisc(mgs)*0.5*xdia(mgs,lhl,3))
         tmp = Max( 1.5, Min(10.0, tmp) )
         ehlw(mgs) = Min( ehlw(mgs), 0.55*Log10(2.51*tmp) )
       ENDIF
      if ( xdia(mgs,lc,1) .lt. 2.4e-06 ) ehlw(mgs)=0.0
       ehlw(mgs) = Min( ehlw0, ehlw(mgs) )

       IF ( ibfc == -1 .and. temcg(mgs) < -41.0 ) THEN 
        ehlw(mgs) = 0.0
       ENDIF 

      end if
!
      if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,lr).gt.qxmin(lr)    &
!     &     .and. temg(mgs) .lt. tfr    &
     &                               ) then
        ehlr(mgs) = 1.0
       ehlr(mgs) = Min( ehlr0, ehlr(mgs) )
      end if
!
      IF ( qx(mgs,ls).gt.qxmin(ls) ) THEN
        if ( qx(mgs,lhl).gt.qxmin(lhl)  ) then
          ehlsclsn(mgs) = ehls_collsn
          ehls(mgs) = ehscnv(mgs)
          ehls(mgs) = Min(ehls(mgs),ehsmax)
        end if
      ENDIF
!
      if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,li).gt.qxmin(li) ) then
      ehliclsn(mgs) = ehli_collsn
      ehli(mgs)=eii0hl*exp(eii1hl*min(temcg(mgs),0.0))
      ehli(mgs) = Min( ehimax, Max( ehli(mgs), ehimin ) )
      if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehli(mgs) = 0.0
      end if

      IF ( lis > 1 ) THEN
      if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,lis).gt.qxmin(lis) ) then
      ehlisclsn(mgs) = ehli_collsn
      ehlis(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0))
      ehlis(mgs) = Min( ehimax, Max( ehlis(mgs), ehimin ) )
      if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehlis(mgs) = 0.0
      end if
      ENDIF


      ENDIF ! lhl .gt. 1

      ENDDO  ! mgs loop for collection efficiencies

!
!
!
!  Set flags for plates vs. columns
!
!
      do mgs = 1,ngscnt
!
      xplate(mgs) = 0.0
      xcolmn(mgs) = 1.0
!
!      if ( temcg(mgs) .lt. 0. .and. temcg(mgs) .ge. -4. ) then
!      xplate(mgs) = 1.0
!      xcolmn(mgs) = 0.0
!      end if
!c
!      if ( temcg(mgs) .lt. -4. .and. temcg(mgs) .ge. -9. ) then
!      xplate(mgs) = 0.0
!      xcolmn(mgs) = 1.0
!      end if
!c
!      if ( temcg(mgs) .lt. -9. .and. temcg(mgs) .ge. -22.5 ) then
!      xplate(mgs) = 1.0
!      xcolmn(mgs) = 0.0
!      end if
!c
!      if ( temcg(mgs) .lt. -22.5 .and. temcg(mgs) .ge. -90. ) then
!      xplate(mgs) = 0.0
!      xcolmn(mgs) = 1.0
!      end if
!
      end do
      
      
!
!
!
!  Collection growth equations....
!
!
      if (ndebug .gt. 0 ) write(0,*) 'Collection: rain collects xxxxx'
!
      do mgs = 1,ngscnt
      qracw(mgs) =  0.0
      IF ( qx(mgs,lr) .gt. qxmin(lr) .and. erw(mgs) .gt. 0.0 ) THEN
      IF ( ipconc .lt. 3 ) THEN
       IF ( erw(mgs) .gt. 0.0 .and. qx(mgs,lr) .gt. 1.e-7 ) THEN
       vt = (ar*(xdia(mgs,lc,1)**br))*rhovt(mgs)
       qracw(mgs) =    &
     &   (0.25)*pi*erw(mgs)*(qx(mgs,lc)-qcwresv(mgs))*cx(mgs,lr) &
!     >  *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,lc,1))   &
     &  *Max(0.0, vtxbar(mgs,lr,1)-vt)   &
     &  *(  gf3*xdia(mgs,lr,2)    &
     &    + 2.0*gf2*xdia(mgs,lr,1)*xdia(mgs,lc,1)    &
     &    + gf1*xdia(mgs,lc,2) )
!       qracw(mgs) = 0.0
!      write(iunit,*) 'qracw,cx =',qracw(mgs),1.e6*xdia(mgs,lr,1),erw(mgs)
!      write(iunit,*) 'qracw,cx =',qracw(mgs),cx(mgs,lc),kgs(mgs),cx(mgs,lr),1.e6*xdia(mgs,lr,1),vtxbar(mgs,lr,1),vt
!      write(iunit,*) 'vtr: ',vtxbar(mgs,lr,1), ar*gf4br/6.0*xdia(mgs,lr,1)**br, rhovt(mgs),
!     :         ar*gf4br/6.0*xdia(mgs,lr,1)**br * rhovt(mgs)
       ENDIF
      ELSE

      IF ( dmrauto <= 0 .or.  rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN 
       rwrad = 0.5*xdia(mgs,lr,3)
        IF ( rwrad .gt. rh(mgs) ) THEN ! .or. cx(mgs,lr) .gt. nh(mgs) ) THEN
         IF ( rwrad .gt. rwradmn ) THEN
!      DM1CCC=A2*XNC*XNR*XVC*(((CNU+2.)/(CNU+1.))*XVC+XVR)       ! (A12)
!     NOTE: Result is independent of imurain, assumes mucloud = 3
           qracw(mgs) = erw(mgs)*aa2*cx(mgs,lr)*cx(mgs,lc)*xmas(mgs,lc)*   &
     &        ((alpha(mgs,lc) + 2.)*xv(mgs,lc)/(alpha(mgs,lc) + 1.) + xv(mgs,lr))/rho0(mgs) !*rhoinv(mgs)
         ELSE

          IF ( imurain == 3 ) THEN

!      DM1CCC=A1*XNC*XNR*(((CNU+3.)*(CNU+2.)/(CNU+1.)**2)*XVC**3+ ! (A14)
!     1 ((RNU+2.)/(RNU+1.))*XVC*XVR**2)

!           qracw(mgs) = aa1*cx(mgs,lr)*cx(mgs,lc)*xdn(mgs,lc)*   &
!     &        ((cnu + 3.)*(cnu + 2.)*xv(mgs,lc)**3/(cnu + 1.)**2 +    &
!     &         (alpha(mgs,lr) + 2.)*xv(mgs,lc)*xv(mgs,lr)**2/(alpha(mgs,lr) + 1.))/rho0(mgs) !*rhoinv(mgs)
! save multiplies by converting cx*xdn*xv/rho0 to qx
           qracw(mgs) = aa1*cx(mgs,lr)*(qx(mgs,lc)-qcwresv(mgs))*   &
     &        ((alpha(mgs,lc) + 3.)*(alpha(mgs,lc) + 2.)*xv(mgs,lc)**2/(alpha(mgs,lc) + 1.)**2 +    &
     &         (alpha(mgs,lr) + 2.)*xv(mgs,lr)**2/(alpha(mgs,lr) + 1.)) 
           
           ELSE ! imurain == 1

           qracw(mgs) = aa1*cx(mgs,lr)*(qx(mgs,lc)-qcwresv(mgs))*   &
     &        ((alpha(mgs,lc) + 3.)*(alpha(mgs,lc) + 2.)*xv(mgs,lc)**2/(alpha(mgs,lc) + 1.)**2 +    &
     &         (alpha(mgs,lr) + 6.)*(alpha(mgs,lr) + 5.)*(alpha(mgs,lr) + 4.)*xv(mgs,lr)**2/ &
     &          ((alpha(mgs,lr) + 3.)*(alpha(mgs,lr) + 2.)*(alpha(mgs,lr) + 1.))) 
           
           ENDIF
           
         ENDIF
        ENDIF
        ENDIF
       ENDIF
!       qracw(mgs) = Min(qracw(mgs), qx(mgs,lc))
       qracw(mgs) = Min(qracw(mgs), qcmxd(mgs))
       ENDIF
      end do
!
      do mgs = 1,ngscnt
      qraci(mgs) = 0.0
      craci(mgs) = 0.0
      IF ( eri(mgs) .gt. 0.0 .and. iacr .ge. 1 .and. xdia(mgs,lr,3) .gt. 2.*rwradmn ) THEN
        IF ( ipconc .ge. 3 ) THEN

           tmp = eri(mgs)*aa2*cx(mgs,lr)*cx(mgs,li)*   &
     &        ((cinu + 2.)*xv(mgs,li)/(cinu + 1.) + xv(mgs,lr))

        qraci(mgs) = Min( qxmxd(mgs,li), tmp*xmas(mgs,li)*rhoinv(mgs) )
        craci(mgs) = Min( cxmxd(mgs,li), tmp )

!       vt = Sqrt((vtxbar(mgs,lr,1)-vtxbar(mgs,li,1))**2 +
!     :            0.04*vtxbar(mgs,lr,1)*vtxbar(mgs,li,1) )
!
!          qraci(mgs) = 0.25*pi*eri(mgs)*cx(mgs,lr)*qx(mgs,li)*vt*
!     :         (  da0(lr)*xdia(mgs,lr,3)**2 +
!     :            dab1(lr,li)*xdia(mgs,lr,3)*xdia(mgs,li,3) +
!     :            da1(li)*xdia(mgs,li,3)**2 )
!
!
!       vt = Sqrt((vtxbar(mgs,lr,1)-vtxbar(mgs,li,1))**2 +
!     :            0.04*vtxbar(mgs,lr,1)*vtxbar(mgs,li,1) )
!
!          craci(mgs) = 0.25*pi*eri(mgs)*cx(mgs,lr)*cx(mgs,li)*vt*
!     :         (  da0(lr)*xdia(mgs,lr,3)**2 +
!     :            dab0(lr,li)*xdia(mgs,lr,3)*xdia(mgs,li,3) +
!     :            da0(li)*xdia(mgs,li,3)**2 )
!
!          qraci(mgs) = Min( qraci(mgs), qxmxd(mgs,li) )
!          craci(mgs) = Min( craci(mgs), cxmxd(mgs,li) )

        ELSE
          qraci(mgs) =    &
     &     min(   &
     &     (0.25)*pi*eri(mgs)*qx(mgs,li)*cx(mgs,lr)   &
     &    *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,li,1))   &
     &    *(  gf3*xdia(mgs,lr,2)    &
     &      + 2.0*gf2*xdia(mgs,lr,1)*xdia(mgs,li,1)    &
     &      + gf1*xdia(mgs,li,2) )     &
     &    , qimxd(mgs))
        ENDIF
      if ( temg(mgs) .gt. 268.15 ) then
      qraci(mgs) = 0.0
      end if
      ENDIF
      end do
!
      do mgs = 1,ngscnt
      qracs(mgs) =  0.0
      IF ( ers(mgs) .gt. 0.0 .and. ipconc < 3 ) THEN
       IF ( lwsm6 .and. ipconc == 0 ) THEN
         vt = vt2ave(mgs)
       ELSE
         vt = vtxbar(mgs,ls,1)
       ENDIF
      qracs(mgs) =      &
     &   min(     &
     &   ((0.25)*pi/gf4)*ers(mgs)*qx(mgs,ls)*cx(mgs,lr)     &
     &  *abs(vtxbar(mgs,lr,1)-vt)     &
     &  *(  gf6*gf1*xdia(mgs,ls,2)     &
     &    + 2.0*gf5*gf2*xdia(mgs,ls,1)*xdia(mgs,lr,1)      &
     &    + gf4*gf3*xdia(mgs,lr,2) )      &
     &  , qsmxd(mgs))
      ENDIF
      end do

!
!
      if (ndebug .gt. 0 ) write(0,*) 'Collection: snow collects xxxxx'
!
      do mgs = 1,ngscnt
      qsacw(mgs) =  0.0
      csacw(mgs) =  0.0
      vsacw(mgs) =  0.0
      IF ( esw(mgs) .gt. 0.0 ) THEN

       IF ( ipconc .ge. 4 ) THEN
!      QSACC=CECS*RVT*A2*XNC*XNS*XVC*ROS*
!     *    (((CNU+2.)/(CNU+1.))*XVC+XVS)/RO

!        tmp = esw(mgs)*rvt*aa2*cx(mgs,ls)*cx(mgs,lc)*
!     :        ((cnu + 2.)*xv(mgs,lc)/(cnu + 1.) + xv(mgs,ls))
        tmp = 1.0*rvt*aa2*cx(mgs,ls)*cx(mgs,lc)*   &
     &        ((alpha(mgs,lc) + 2.)*xv(mgs,lc)/(alpha(mgs,lc) + 1.) + xv(mgs,ls))

        qsacw(mgs) = Min( qxmxd(mgs,lc), tmp*xmas(mgs,lc)*rhoinv(mgs) )
        csacw(mgs) = Min( cxmxd(mgs,lc), tmp )

          IF ( lvol(ls) .gt. 1 ) THEN
             IF ( temg(mgs) .lt. 273.15) THEN
             rimdn(mgs,ls) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1))   &
     &                *((0.60)*vtxbar(mgs,ls,1))   &
     &                /(temg(mgs)-273.15))**(rimc2)
             rimdn(mgs,ls) = Min( Max( rimc3, rimdn(mgs,ls) ), rimc4 )
             ELSE
             rimdn(mgs,ls) = 1000.
             ENDIF

           vsacw(mgs) = rho0(mgs)*qsacw(mgs)/rimdn(mgs,ls)

          ENDIF


!        qsacw(mgs) = cecs*aa2*cx(mgs,ls)*cx(mgs,lc)*xmas(mgs,lc)*
!     :        ((alpha(mgs,lc) + 2.)*xv(mgs,lc)/(alpha(mgs,lc) + 1.) + xv(mgs,ls))*rhoinv(mgs)
       ELSE
!      qsacw(mgs) =
!     >   min(
!     >   ((0.25)*pi)*esw(mgs)*qx(mgs,lc)*cx(mgs,ls)
!     >  *abs(vtxbar(mgs,ls,1)-vtxbar(mgs,lc,1))
!     >  *(  gf3*xdia(mgs,ls,2)
!     >    + 2.0*gf2*xdia(mgs,ls,1)*xdia(mgs,lc,1)
!     >    + gf1*xdia(mgs,lc,2) )
!     <  , qcmxd(mgs))

            vt = abs(vtxbar(mgs,ls,1)-vtxbar(mgs,lc,1))

          qsacw(mgs) = 0.25*pi*esw(mgs)*cx(mgs,ls)*qx(mgs,lc)*vt*   &
     &         (  da0(ls)*xdia(mgs,ls,3)**2 +     &
     &            dab1(ls,lc)*xdia(mgs,ls,3)*xdia(mgs,lc,3) +    &
     &            da1lc(mgs)*xdia(mgs,lc,3)**2 )
        qsacw(mgs) = Min( qsacw(mgs), qxmxd(mgs,ls) )
        csacw(mgs) = rho0(mgs)*qsacw(mgs)/xmas(mgs,lc)
       ENDIF
      ENDIF
      end do
!
!
      do mgs = 1,ngscnt
      qsaci(mgs) = 0.0
      csaci(mgs) = 0.0
      csaci0(mgs) = 0.0
      IF ( ipconc .ge. 4 ) THEN
      IF ( esi(mgs) .gt. 0.0 .or. ( ipelec > 0 .and. esiclsn(mgs) > 0.0 )) THEN
!      QSCOI=CEXS*RVT*A2*XNCI*XNS*XVCI*ROS*
!     *  (((CINU+2.)/(CINU+1.))*VCIP+XVS)/RO

        tmp = esiclsn(mgs)*rvt*aa2*cx(mgs,ls)*cx(mgs,li)*   &
     &        ((cinu + 2.)*xv(mgs,li)/(cinu + 1.) + xv(mgs,ls))

        qsaci(mgs) = Min( qxmxd(mgs,li), esi(mgs)*tmp*xmas(mgs,li)*rhoinv(mgs) )
        csaci0(mgs) = tmp
        csaci(mgs) = Min(cxmxd(mgs,li), esi(mgs)*tmp )

!      qsaci(mgs) =
!     >   min(
!     >   ((0.25)*pi)*esi(mgs)*qx(mgs,li)*cx(mgs,ls)
!     >  *abs(vtxbar(mgs,ls,1)-vtxbar(mgs,li,1))
!     >  *(  gf3*xdia(mgs,ls,2)
!     >    + 2.0*gf2*xdia(mgs,ls,1)*xdia(mgs,li,1)
!     >    + gf1*xdia(mgs,li,2) )
!     <  , qimxd(mgs))
      ENDIF
      ELSE ! 
      IF ( esi(mgs) .gt. 0.0 ) THEN
         qsaci(mgs) =    &
     &   min(   &
     &   ((0.25)*pi)*esi(mgs)*qx(mgs,li)*cx(mgs,ls)   &
     &  *abs(vtxbar(mgs,ls,1)-vtxbar(mgs,li,1))   &
     &  *(  gf3*xdia(mgs,ls,2)    &
     &    + 2.0*gf2*xdia(mgs,ls,1)*xdia(mgs,li,1)    &
     &    + gf1*xdia(mgs,li,2) )     &
     &  , qimxd(mgs))
      ENDIF
      ENDIF
      end do
!
!
!
      do mgs = 1,ngscnt
      qsacr(mgs) = 0.0
      qsacrs(mgs) = 0.0
      csacr(mgs) = 0.0
      IF ( esr(mgs) .gt. 0.0 ) THEN
      IF ( ipconc .ge. 3 ) THEN
!       vt = Sqrt((vtxbar(mgs,ls,1)-vtxbar(mgs,lr,1))**2 + 
!     :            0.04*vtxbar(mgs,ls,1)*vtxbar(mgs,lr,1) )
!       qsacr(mgs) = esr(mgs)*cx(mgs,ls)*vt*
!     :     qx(mgs,lr)*0.25*pi*
!     :      (3.02787*xdia(mgs,lr,2) + 
!     :       3.30669*xdia(mgs,ls,1)*xdia(mgs,lr,1) + 
!     :       2.*xdia(mgs,ls,2))
!        qsacr(mgs) = Min( qsacr(mgs), qrmxd(mgs) )
!        csacr(mgs) = qsacr(mgs)*cx(mgs,lr)/qx(mgs,lr)
!        csacr(mgs) = min(csacr(mgs),crmxd(mgs))
      ELSE
       IF ( lwsm6 .and. ipconc == 0 ) THEN
         vt = vt2ave(mgs)
       ELSE
         vt = vtxbar(mgs,ls,1)
       ENDIF
       
       qsacr(mgs) =   &
     &   min(   &
     &   ((0.25)*pi/gf4)*esr(mgs)*qx(mgs,lr)*cx(mgs,ls)   &
     &  *abs(vtxbar(mgs,lr,1)-vt)   &
     &  *(  gf6*gf1*xdia(mgs,lr,2)   &
     &    + 2.0*gf5*gf2*xdia(mgs,lr,1)*xdia(mgs,ls,1)    &
     &    + gf4*gf3*xdia(mgs,ls,2) )    &
     &  , qrmxd(mgs))
      ENDIF
      ENDIF
      end do
!
!
!

      if (ndebug .gt. 0 ) write(0,*) 'Collection: graupel collects xxxxx'
!
      do mgs = 1,ngscnt
      qhacw(mgs) = 0.0
      rarx(mgs,lh) = 0.0
      vhacw(mgs) = 0.0
      vhsoak(mgs) = 0.0
      zhacw(mgs) = 0.0
      
      IF ( .false. ) THEN
        vtmax = (gz(igs(mgs),jgs,kgs(mgs))*dtpinv)
        vtxbar(mgs,lh,1) = Min( vtmax, vtxbar(mgs,lh,1))
        vtxbar(mgs,lh,2) = Min( vtmax, vtxbar(mgs,lh,2))
        vtxbar(mgs,lh,3) = Min( vtmax, vtxbar(mgs,lh,3))
      ENDIF
      IF ( ehw(mgs) .gt. 0.0 ) THEN

        IF ( ipconc .ge. 2 ) THEN

        IF ( .false. ) THEN  
        qhacw(mgs) = (ehw(mgs)*(qx(mgs,lc)-qcwresv(mgs))*cx(mgs,lh)*pi*   &
     &    abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1))*   &
     &    (2.0*xdia(mgs,lh,1)*(xdia(mgs,lh,1) +    &
     &         xdia(mgs,lc,1)*gf73rds) +    &
     &      xdia(mgs,lc,2)*gf83rds))/4.     
     
         ELSE  ! using Seifert coefficients
            vt = abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1)) 

          qhacw(mgs) = 0.25*pi*ehw(mgs)*cx(mgs,lh)*(qx(mgs,lc)-qcwresv(mgs))*vt*   &
     &         (  da0lh(mgs)*xdia(mgs,lh,3)**2 +     &
     &            dab1lh(mgs,lh,lc)*xdia(mgs,lh,3)*xdia(mgs,lc,3) +    &
     &            da1lc(mgs)*xdia(mgs,lc,3)**2 ) 
         
         ENDIF
          qhacw(mgs) = Min( qhacw(mgs), 0.5*qx(mgs,lc)*dtpinv )
        
         IF ( lzh .gt. 1 ) THEN
          tmp = qx(mgs,lh)/cx(mgs,lh)
          
!!          g1 = (6.0 + alpha(mgs,lh))*(5.0 + alpha(mgs,lh))*(4.0 + alpha(mgs,lh))/
!!     :         ((3.0 + alpha(mgs,lh))*(2.0 + alpha(mgs,lh))*(1.0 + alpha(mgs,lh)))
!          alp = Max( 1.0, alpha(mgs,lh)+1. )
!          g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/
!     :         ((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
!          zhacw(mgs) =  g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) )
         ENDIF
        
        ELSE
         qhacw(mgs) =    &
     &   min(   &
     &   ((0.25)*pi)*ehw(mgs)*(qx(mgs,lc)-qcwresv(mgs))*cx(mgs,lh)   &
     &  *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1))   &
     &  *(  gf3*xdia(mgs,lh,2)    &
     &    + 2.0*gf2*xdia(mgs,lh,1)*xdia(mgs,lc,1)    &
     &    + gf1*xdia(mgs,lc,2) )     &
     &    , 0.5*(qx(mgs,lc)-qcwresv(mgs))*dtpinv)
!     <  , qxmxd(mgs,lc))
!     <  , qcmxd(mgs))
       
       
         IF ( lwsm6 .and. qsacw(mgs) > 0.0 .and.  qhacw(mgs) > 0.0) THEN
           qaacw = ( qx(mgs,ls)*qsacw(mgs) + qx(mgs,lh)*qhacw(mgs) )/(qx(mgs,ls) + qx(mgs,lh))
!           qaacw = Min( qaacw, 0.5*(qsacw(mgs) + qhacw(mgs) ) )
           qsacw(mgs) = qaacw
           qhacw(mgs) = qaacw
         ENDIF
         
       ENDIF

          IF ( lvol(lh) .gt. 1 .or. lhl .gt. 1 ) THEN ! calculate rime density for graupel volume and/or for graupel conversion to hail
             
             IF ( temg(mgs) .lt. 273.15) THEN
               IF ( irimdenopt == 1 ) THEN ! Heymsfield and Pflaum (1985)
               vt = ( (1.0-rimdenvwgt)*vtxbar(mgs,lh,1) + rimdenvwgt*vtxbar(mgs,lh,2) )
               
             rimdn(mgs,lh) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1))   &
     &                *((0.60)*vt )   &
     &                /(temg(mgs)-273.15))**(rimc2)
!             rimdn(mgs,lh) = Min( Max( hdnmn, rimc3, rimdn(mgs,lh) ), rimc4 )
             rimdn(mgs,lh) = Min( Max( rimc3, rimdn(mgs,lh) ), rimc4 )

!               IF ( igs(mgs) == 30 ) THEN
!                 write(0,*) 'k,vt: ',kgs(mgs),vt, vtxbar(mgs,lh,1),vtxbar(mgs,lh,2), rhovt(mgs)*axx(mgs,lh)*( (alpha(mgs,lh)+3.)*xdia(mgs,lh,1) )**bxx(mgs,lh)
!                 write(0,*) 'diam: char, mean, maxmass = ',xdia(mgs,lh,1),xdia(mgs,lh,3),(alpha(mgs,lh)+3.)*xdia(mgs,lh,1)
!                 write(0,*) 'ax,bx,cd,xdn = ',axx(mgs,lh),bxx(mgs,lh),cdxgs(mgs,lh),xdn(mgs,lh)
!                 write(0,*) 'vt_char,vt_mean = ',rhovt(mgs)*axx(mgs,lh)*( xdia(mgs,lh,1) )**bxx(mgs,lh),rhovt(mgs)*axx(mgs,lh)*( xdia(mgs,lh,3) )**bxx(mgs,lh)
!                 write(0,*) 'rimdn,alpha = ',rimdn(mgs,lh),alpha(mgs,lh)
!               ENDIF

               ELSEIF ( irimdenopt == 2 ) THEN ! Cober and List (1993)

                tmp = (-((0.5)*(1.e+06)*xdia(mgs,lc,1))   &
     &                *( (1.0-rimdenvwgt)*vtxbar(mgs,lh,1) + rimdenvwgt*vtxbar(mgs,lh,2) )   &
     &                /(temg(mgs)-273.15))
                tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) ) ! have to limit range of "R" because quadratic function starts to decrease (unphysically) at higher values
                
                rimdn(mgs,lh) = 1000.*(0.051 + 0.114*tmp - 0.0055*tmp**2)

               ELSEIF ( irimdenopt == 3 ) THEN ! Macklin

                tmp = (-((0.5)*(1.e+06)*xdia(mgs,lc,1))   &
     &                *( (1.0-rimdenvwgt)*vtxbar(mgs,lh,1) + rimdenvwgt*vtxbar(mgs,lh,2) )   &
     &                /(temg(mgs)-273.15))
              !  tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) )
                
                rimdn(mgs,lh) =  Min(900., Max( 170., 110.*tmp**0.76 ) )
               
               ENDIF
             ELSE
             rimdn(mgs,lh) = 1000.
             ENDIF
             
             IF ( lvol(lh) > 1 ) vhacw(mgs) = rho0(mgs)*qhacw(mgs)/rimdn(mgs,lh)

          ENDIF
      
        IF ( qx(mgs,lh) .gt. qxmin(lh) .and. ipelec .ge. 1 ) THEN
         rarx(mgs,lh) =     &
     &    qhacw(mgs)*1.0e3*rho0(mgs)/((pi/2.0)*xdia(mgs,lh,2)*cx(mgs,lh))
        ENDIF
      
      ENDIF  
      end do   
!
!
      do mgs = 1,ngscnt
      qhaci(mgs) = 0.0
      qhaci0(mgs) = 0.0
      IF ( ehi(mgs) .gt. 0.0 ) THEN
       IF (  ipconc .ge. 5 ) THEN

       vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,li,1))**2 +    &
     &            0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,li,1) )

          qhaci0(mgs) = 0.25*pi*ehiclsn(mgs)*cx(mgs,lh)*qx(mgs,li)*vt*   &
     &         (  da0lh(mgs)*xdia(mgs,lh,3)**2 +     &
     &            dab1lh(mgs,lh,li)*xdia(mgs,lh,3)*xdia(mgs,li,3) +    &
     &            da1(li)*xdia(mgs,li,3)**2 ) 
          qhaci(mgs) = Min( ehi(mgs)*qhaci0(mgs), qimxd(mgs) )
       ELSE
        qhaci(mgs) =    &
     &  min(   &
     &  ((0.25)*pi)*ehi(mgs)*ehiclsn(mgs)*qx(mgs,li)*cx(mgs,lh)   &
     &  *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,li,1))   &
     &  *(  gf3*xdia(mgs,lh,2)    &
     &    + 2.0*gf2*xdia(mgs,lh,1)*xdia(mgs,li,1)    &
     &    + gf1*xdia(mgs,li,2) )     &
     &  , qimxd(mgs))
       ENDIF
      ENDIF
      end do   


      IF ( lis > 1 .and. ipconc >= 5 ) THEN
      do mgs = 1,ngscnt
      qhacis(mgs) = 0.0
      qhacis0(mgs) = 0.0
      IF ( ehis(mgs) .gt. 0.0 ) THEN

       vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,lis,1))**2 +    &
     &            0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,lis,1) )

          qhacis0(mgs) = 0.25*pi*ehisclsn(mgs)*cx(mgs,lh)*qx(mgs,lis)*vt*   &
     &         (  da0lh(mgs)*xdia(mgs,lh,3)**2 +     &
     &            dab1lh(mgs,lh,lis)*xdia(mgs,lh,3)*xdia(mgs,lis,3) +    &
     &            da1(li)*xdia(mgs,lis,3)**2 ) 
          qhacis(mgs) = Min( ehis(mgs)*qhacis0(mgs), qxmxd(mgs,lis) )
      ENDIF
      end do
      ENDIF

!
!
      do mgs = 1,ngscnt
      qhacs(mgs) = 0.0
      qhacs0(mgs) = 0.0
      IF ( ehs(mgs) .gt. 0.0 ) THEN
       IF ( ipconc .ge. 5 ) THEN

       vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1))**2 +    &
     &            0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,ls,1) )

          qhacs0(mgs) = 0.25*pi*ehsclsn(mgs)*cx(mgs,lh)*qx(mgs,ls)*vt*   &
     &         (  da0lh(mgs)*xdia(mgs,lh,3)**2 +     &
     &            dab1lh(mgs,lh,ls)*xdia(mgs,lh,3)*xdia(mgs,ls,3) +    &
     &            da1(ls)*xdia(mgs,ls,3)**2 ) 
      
          qhacs(mgs) = Min( ehs(mgs)*qhacs0(mgs), qsmxd(mgs) )

       ELSE
         qhacs(mgs) =   &
     &   min(   &
     &   ((0.25)*pi/gf4)*ehs(mgs)*ehsclsn(mgs)*qx(mgs,ls)*cx(mgs,lh)   &
     &  *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1))   &
     &  *(  gf6*gf1*xdia(mgs,ls,2)   &
     &    + 2.0*gf5*gf2*xdia(mgs,ls,1)*xdia(mgs,lh,1)   &
     &    + gf4*gf3*xdia(mgs,lh,2) )   &
     &  , qsmxd(mgs))
        ENDIF
      ENDIF
      end do   
!
      do mgs = 1,ngscnt
      qhacr(mgs) = 0.0
      qhacrmlr(mgs) = 0.0
      vhacr(mgs) = 0.0
      chacr(mgs) = 0.0
      zhacr(mgs) = 0.0
      IF ( temg(mgs) .gt. tfr ) raindn(mgs,lh) = 1000.0

      IF ( ehr(mgs) .gt. 0.0 ) THEN
      IF ( ipconc .ge. 3 ) THEN
       vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,lr,1))**2 +    &
     &            0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,lr,1) )
!       qhacr(mgs) = ehr(mgs)*cx(mgs,lh)*vt*
!     :     qx(mgs,lr)*0.25*pi*
!     :      (3.02787*xdia(mgs,lr,2) + 
!     :       3.30669*xdia(mgs,lh,1)*xdia(mgs,lr,1) + 
!     :       2.*xdia(mgs,lh,2))
     
       qhacr(mgs) = 0.25*pi*ehr(mgs)*cx(mgs,lh)*qx(mgs,lr)*vt*   &
     &         (  da0lh(mgs)*xdia(mgs,lh,3)**2 +     &
     &            dab1lh(mgs,lh,lr)*xdia(mgs,lh,3)*xdia(mgs,lr,3) +    &
     &            da1lr(mgs)*xdia(mgs,lr,3)**2 )
!     &            da1(lr)*xdia(mgs,lr,3)**2 )
!       IF ( qhacr(mgs) .gt. 0. .or. tmp .gt. 0.0 ) write(0,*) 'qhacr= ',qhacr(mgs),tmp
!!        qhacr(mgs) = Min( qhacr(mgs), qrmxd(mgs) )
!!        chacr(mgs) = qhacr(mgs)*cx(mgs,lr)/qx(mgs,lr)
!!        chacr(mgs) = min(chacr(mgs),crmxd(mgs))

        qhacr(mgs) = Min( qhacr(mgs), qxmxd(mgs,lr) )

            qhacrmlr(mgs) = qhacr(mgs)
        
        IF ( temg(mgs) > tfr .and. iehr0c == 0 ) THEN
          qhacr(mgs) = 0.0

          IF ( iqhacrmlr == 0 ) THEN
              qhacrmlr(mgs) = -qhacw(mgs)
          ENDIF

        ELSE
!        chacr(mgs) = Min( qhacr(mgs)*rho0(mgs)/xmas(mgs,lr), cxmxd(mgs,lr) )

!       chacr(mgs) = ehr(mgs)*cx(mgs,lh)*vt*
!     :     cx(mgs,lr)*0.25*pi*
!     :      (0.69874*xdia(mgs,lr,2) +
!     :       1.24001*xdia(mgs,lh,1)*xdia(mgs,lr,1) +
!     :       2.*xdia(mgs,lh,2))

        chacr(mgs) = 0.25*pi*ehr(mgs)*cx(mgs,lh)*cx(mgs,lr)*vt*      &
     &         (  da0lh(mgs)*xdia(mgs,lh,3)**2 +                     &
     &            dab0lh(mgs,lh,lr)*xdia(mgs,lh,3)*xdia(mgs,lr,3) +  &
     &            da0lr(mgs)*xdia(mgs,lr,3)**2 )

!       IF ( qhacr(mgs) .gt. 0. .or. tmp .gt. 0.0 ) write(0,*) 'chacr= ',chacr(mgs),tmp

!        chacr(mgs) = qhacr(mgs)*cx(mgs,lr)/qx(mgs,lr)
        chacr(mgs) = min(chacr(mgs),crmxd(mgs))

      IF ( lzh .gt. 1 ) THEN
          tmp = qx(mgs,lh)/cx(mgs,lh)

!          g1 = (6.0 + alpha(mgs,lh))*(5.0 + alpha(mgs,lh))*(4.0 + alpha(mgs,lh))/
!     :         ((3.0 + alpha(mgs,lh))*(2.0 + alpha(mgs,lh))*(1.0 + alpha(mgs,lh)))
!          alp = Max( 1.0, alpha(mgs,lh)+1. )
!          g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/
!     :         ((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
!        zhacr(mgs) =  g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) - tmp**2 * chacr(mgs) )
!        zhacr(mgs) =  g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qhacr(mgs) )
      ENDIF
      ENDIF ! temg > tfr
      
      ELSE
       IF ( lwsm6 .and. ipconc == 0 ) THEN
         vt = vt2ave(mgs)
       ELSE
         vt = vtxbar(mgs,lh,1)
       ENDIF

      qhacr(mgs) =   &
     &   min(   &
     &   ((0.25)*pi/gf4)*ehr(mgs)*qx(mgs,lr)*cx(mgs,lh)   &
     &  *abs(vt-vtxbar(mgs,lr,1))   &
     &  *(  gf6*gf1*xdia(mgs,lr,2)   &
     &    + 2.0*gf5*gf2*xdia(mgs,lr,1)*xdia(mgs,lh,1)   &
     &    + gf4*gf3*xdia(mgs,lh,2) )   &
     &  , qrmxd(mgs))
      
        IF ( temg(mgs) > tfr ) THEN
          IF ( iqhacrmlr >= 1 ) qhacrmlr(mgs) = qhacr(mgs)
          qhacr(mgs) = 0.0
        ENDIF
      
      ENDIF
          IF ( lvol(lh) .gt. 1 .or. lhl .gt. 1 ) THEN ! calculate rime density for graupel volume and/or for graupel conversion to hail
             
             IF ( temg(mgs) .lt. 273.15) THEN
             raindn(mgs,lh) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lr,3))   &
     &                *((0.60)*vt)   &
     &                /(temg(mgs)-273.15))**(rimc2)

             raindn(mgs,lh) = Min( Max( rimc3, rimdn(mgs,lh) ), rimc4 )
             ELSE
             raindn(mgs,lh) = 1000.
             ENDIF
             
             IF ( lvol(lh) > 1 )  vhacr(mgs) = rho0(mgs)*qhacr(mgs)/raindn(mgs,lh)
        ENDIF
      ENDIF
      end do

!
!
      if (ndebug .gt. 0 ) write(0,*) 'Collection: hail collects xxxxx'
!

      do mgs = 1,ngscnt
      qhlacw(mgs) = 0.0
      vhlacw(mgs) = 0.0
      vhlsoak(mgs) = 0.0
      IF ( lhl > 1 .and. .true.) THEN
        vtmax = (gz(igs(mgs),jgs,kgs(mgs))*dtpinv)
        vtxbar(mgs,lhl,1) = Min( vtmax, vtxbar(mgs,lhl,1))
        vtxbar(mgs,lhl,2) = Min( vtmax, vtxbar(mgs,lhl,2))
        vtxbar(mgs,lhl,3) = Min( vtmax, vtxbar(mgs,lhl,3))
      ENDIF

      IF ( lhl > 0 ) THEN
      rarx(mgs,lhl) = 0.0
      ENDIF

      IF ( lhl .gt. 1 .and. ehlw(mgs) .gt. 0.0 ) THEN


!        IF ( ipconc .ge. 2 ) THEN

            vt = abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,lc,1))

          qhlacw(mgs) = 0.25*pi*ehlw(mgs)*cx(mgs,lhl)*(qx(mgs,lc)-qcwresv(mgs))*vt*   &
     &         (  da0lhl(mgs)*xdia(mgs,lhl,3)**2 +     &
     &            dab1lh(mgs,lhl,lc)*xdia(mgs,lhl,3)*xdia(mgs,lc,3) +    &
     &            da1lc(mgs)*xdia(mgs,lc,3)**2 )


          qhlacw(mgs) = Min( qhlacw(mgs), 0.5*qx(mgs,lc)*dtpinv )

          IF ( lvol(lhl) .gt. 1 ) THEN

             IF ( temg(mgs) .lt. 273.15) THEN
               IF ( irimdenopt == 1 ) THEN ! Rasmussen and Heymsfeld (1985)
             rimdn(mgs,lhl) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1))   &
     &                *((0.60)*( (1.0-rimdenvwgt)*vtxbar(mgs,lhl,1) + rimdenvwgt*vtxbar(mgs,lhl,2) ))   &
     &                /(temg(mgs)-273.15))**(rimc2)
             rimdn(mgs,lhl) = Min( Max( hldnmn, rimc3, rimdn(mgs,lhl) ), rimc4 )
               
               ELSEIF ( irimdenopt == 2 ) THEN ! Cober and List (1993)
                tmp = -0.5*(1.e+06)*xdia(mgs,lc,1)   &
     &                *( (1.0-rimdenvwgt)*vtxbar(mgs,lhl,1) + rimdenvwgt*vtxbar(mgs,lhl,2) )   &
     &                /(temg(mgs)-273.15)
                tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) )
                
                rimdn(mgs,lhl) = 1000.*(0.051 + 0.114*tmp - 0.005*tmp**2)
               
               ELSEIF ( irimdenopt == 3 ) THEN ! Macklin
                tmp = -0.5*(1.e+06)*xdia(mgs,lc,1)   &
     &                *( (1.0-rimdenvwgt)*vtxbar(mgs,lhl,1) + rimdenvwgt*vtxbar(mgs,lhl,2) )  &
     &                /(temg(mgs)-273.15)
              !  tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) )
                
                rimdn(mgs,lhl) = Min(900., Max( 170., 110.*tmp**0.76 ) )
               
               ENDIF
             ELSE
             rimdn(mgs,lhl) = 1000.
             ENDIF

             vhlacw(mgs) = rho0(mgs)*qhlacw(mgs)/rimdn(mgs,lhl)

          ENDIF


        IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. ipelec .ge. 1 ) THEN
         rarx(mgs,lhl) =     &
     &    qhlacw(mgs)*1.0e3*rho0(mgs)/((pi/2.0)*xdia(mgs,lhl,2)*cx(mgs,lhl))
        ENDIF

      ENDIF
      end do

      qhlaci(:) = 0.0
      qhlaci0(:) = 0.0
      IF ( lhl .gt. 1  ) THEN
      do mgs = 1,ngscnt
      IF ( ehli(mgs) .gt. 0.0 ) THEN
       IF (  ipconc .ge. 5 ) THEN

       vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,li,1))**2 +    &
     &            0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,li,1) )

          qhlaci0(mgs) = 0.25*pi*ehliclsn(mgs)*cx(mgs,lhl)*qx(mgs,li)*vt*   &
     &         (  da0lhl(mgs)*xdia(mgs,lhl,3)**2 +     &
     &            dab1lh(mgs,lhl,li)*xdia(mgs,lhl,3)*xdia(mgs,li,3) +    &
     &            da1(li)*xdia(mgs,li,3)**2 )
        ! qhlaci(mgs) = Min( qhlaci(mgs), qimxd(mgs) )
          qhlaci(mgs) = Min( ehli(mgs)*qhlaci0(mgs), qimxd(mgs) )
       ENDIF
      ENDIF
      end do
      ENDIF
!
      qhlacs(:) = 0.0
      qhlacs0(:) = 0.0
      IF ( lhl .gt. 1 ) THEN
      do mgs = 1,ngscnt
      IF ( ehls(mgs) .gt. 0.0) THEN
       IF ( ipconc .ge. 5 ) THEN

       vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,ls,1))**2 +    &
     &            0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,ls,1) )

          qhlacs0(mgs) = 0.25*pi*ehlsclsn(mgs)*cx(mgs,lhl)*qx(mgs,ls)*vt*   &
     &         (  da0lhl(mgs)*xdia(mgs,lhl,3)**2 +     &
     &            dab1lh(mgs,lhl,ls)*xdia(mgs,lhl,3)*xdia(mgs,ls,3) +    &
     &            da1(ls)*xdia(mgs,ls,3)**2 )

          qhlacs(mgs) = Min( ehls(mgs)*qhlacs0(mgs), qsmxd(mgs) )
        ENDIF
      ENDIF
      end do
      ENDIF


      do mgs = 1,ngscnt
      qhlacr(mgs) = 0.0
      qhlacrmlr(mgs) = 0.0
      chlacr(mgs) = 0.0
      vhlacr(mgs) = 0.0
      IF ( lhl .gt. 1 .and. temg(mgs) .gt. tfr ) raindn(mgs,lhl) = 1000.0

      IF ( lhl .gt. 1 .and. ehlr(mgs) .gt. 0.0 ) THEN
      IF ( ipconc .ge. 3 ) THEN
       vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,lr,1))**2 +    &
     &            0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,lr,1) )

       qhlacr(mgs) = 0.25*pi*ehlr(mgs)*cx(mgs,lhl)*qx(mgs,lr)*vt*   &
     &         (  da0lhl(mgs)*xdia(mgs,lhl,3)**2 +     &
     &            dab1lh(mgs,lhl,lr)*xdia(mgs,lhl,3)*xdia(mgs,lr,3) +    &
     &            da1lr(mgs)*xdia(mgs,lr,3)**2 )
!     &            da1(lr)*xdia(mgs,lr,3)**2 )
!       IF ( qhacr(mgs) .gt. 0. .or. tmp .gt. 0.0 ) write(0,*) 'qhacr= ',qhacr(mgs),tmp
!!        qhacr(mgs) = Min( qhacr(mgs), qrmxd(mgs) )
!!        chacr(mgs) = qhacr(mgs)*cx(mgs,lr)/qx(mgs,lr)
!!        chacr(mgs) = min(chacr(mgs),crmxd(mgs))

        qhlacr(mgs) = Min( qhlacr(mgs), qxmxd(mgs,lr) )

     
        IF ( iqhlacrmlr >= 1 ) qhlacrmlr(mgs) = qhlacr(mgs)
        
        IF ( temg(mgs) > tfr .and. iehlr0c == 0) THEN
          qhlacr(mgs) = 0.0
          IF ( iqhlacrmlr == 0 ) THEN
              qhlacrmlr(mgs) = -qhlacw(mgs)
          ENDIF
        ELSE
        chlacr(mgs) = 0.25*pi*ehlr(mgs)*cx(mgs,lhl)*cx(mgs,lr)*vt*   &
     &         (  da0lhl(mgs)*xdia(mgs,lhl,3)**2 +     &
     &            dab0lh(mgs,lhl,lr)*xdia(mgs,lhl,3)*xdia(mgs,lr,3) +    &
     &            da0lr(mgs)*xdia(mgs,lr,3)**2 )

        chlacr(mgs) = min(chlacr(mgs),crmxd(mgs))

        IF ( lvol(lhl) .gt. 1 ) THEN
         vhlacr(mgs) = rho0(mgs)*qhlacr(mgs)/raindn(mgs,lhl)
        ENDIF
        ENDIF
      ENDIF
      ENDIF
      end do



!
!
!
!
!      if (ndebug .gt. 0 ) write(0,*) 'Collection: Cloud collects xxxxx'

      if (ndebug .gt. 0 ) write(0,*) 'Collection: cloud ice collects xxxx2'
!
      do mgs = 1,ngscnt
      qiacw(mgs) = 0.0
      IF ( eiw(mgs) .gt. 0.0 ) THEN

       vt = Sqrt((vtxbar(mgs,li,1)-vtxbar(mgs,lc,1))**2 +    &
     &            0.04*vtxbar(mgs,li,1)*vtxbar(mgs,lc,1) )

          qiacw(mgs) = 0.25*pi*eiw(mgs)*cx(mgs,li)*qx(mgs,lc)*vt*   &
     &         (  da0(li)*xdia(mgs,li,3)**2 +     &
     &            dab1(li,lc)*xdia(mgs,li,3)*xdia(mgs,lc,3) +    &
     &            da1lc(mgs)*xdia(mgs,lc,3)**2 )

       qiacw(mgs) = Min( qiacw(mgs), qxmxd(mgs,lc) )
      ENDIF
      end do


!
!
      if (ndebug .gt. 0 ) write(0,*) 'Collection: cloud ice collects xxxx8'
!
      do mgs = 1,ngscnt
      qiacr(mgs) = 0.0
      qiacrf(mgs) = 0.0
      qiacrs(mgs) = 0.0
      ciacrs(mgs) = 0.0
      ciacr(mgs) = 0.0
      ciacrf(mgs) = 0.0
      viacrf(mgs) = 0.0
      csplinter(mgs) = 0.0
      qsplinter(mgs) = 0.0
      csplinter2(mgs) = 0.0
      qsplinter2(mgs) = 0.0
      IF ( iacr .ge. 1 .and. eri(mgs) .gt. 0.0    &
     &     .and. temg(mgs) .le. 270.15 ) THEN
      IF ( ipconc .ge. 3 ) THEN
       ni = 0.0
         IF ( xdia(mgs,li,1) .ge. 10.e-6 ) THEN
          ni = ni + cx(mgs,li)*Exp(- (40.e-6/xdia(mgs,li,1))**3 )
         ENDIF
       IF ( imurain == 1 ) THEN ! gamma of diameter
           IF ( iacrsize /= 4 ) THEN
           IF ( iacrsize .eq. 1 ) THEN
             ratio = 500.e-6/xdia(mgs,lr,1)
           ELSEIF ( iacrsize .eq. 2 ) THEN
             ratio = 300.e-6/xdia(mgs,lr,1)
           ELSEIF ( iacrsize .eq. 3 ) THEN
             ratio = 40.e-6/xdia(mgs,lr,1)
           ELSEIF ( iacrsize .eq. 5 ) THEN
             ratio = 150.e-6/xdia(mgs,lr,1)
           ENDIF
           i = Min(nqiacrratio,Int(ratio*dqiacrratioinv))
           j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))*dqiacralphainv)
!           j = Int(Max(minalphalu,Min(maxalphalu,alpha(mgs,lr)))*dqiacralphainv)
           delx = ratio - float(i)*dqiacrratio
           dely = alpha(mgs,lr) - float(j)*dqiacralpha
           ip1 = Min( i+1, nqiacrratio )
           jp1 = Min( j+1, nqiacralpha )

           ! interpolate along x, i.e., ratio
           tmp1 = ciacrratio(i,j) + delx*dqiacrratioinv*(ciacrratio(ip1,j) - ciacrratio(i,j))
           tmp2 = ciacrratio(i,jp1) + delx*dqiacrratioinv*(ciacrratio(ip1,jp1) - ciacrratio(i,jp1))
           
           ! interpolate along alpha
           
           nr = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*cx(mgs,lr)
           
           ! interpolate along x, i.e., ratio; 
           tmp1 = qiacrratio(i,j) + delx*dqiacrratioinv*(qiacrratio(ip1,j) - qiacrratio(i,j))
           tmp2 = qiacrratio(i,jp1) + delx*dqiacrratioinv*(qiacrratio(ip1,jp1) - qiacrratio(i,jp1))
           
           ! interpolate along alpha; 
           
           qr = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*qx(mgs,lr)
           
           ELSE ! iacrsize == 4 : use all
             nr = cx(mgs,lr)
             qr = qx(mgs,lr)
           ENDIF

          vt = Sqrt((vtxbar(mgs,lr,1)-vtxbar(mgs,li,1))**2 +     &
     &            0.04*vtxbar(mgs,lr,1)*vtxbar(mgs,li,1) )

          qiacr(mgs) = 0.25*pi*eri(mgs)*ni*qr*vt*   &
     &         (  da0(li)*xdia(mgs,li,3)**2 +     &
     &            dab1lh(mgs,li,lr)*xdia(mgs,lh,3)*xdia(mgs,li,3) +    &
     &            da1(lr)*xdia(mgs,lr,3)**2 ) 
          
          qiacr(mgs) = Min( qrmxd(mgs), qiacr(mgs) )
          

          ciacr(mgs) = 0.25*pi*eri(mgs)*ni*nr*vt*   &
     &         (  da0(li)*xdia(mgs,li,3)**2 +     &
     &            dab0lh(mgs,li,lr)*xdia(mgs,lr,3)*xdia(mgs,li,3) +    &
     &            da0(lr)*xdia(mgs,lr,3)**2 ) 

          ciacr(mgs) = Min( crmxd(mgs), ciacr(mgs) )
          
!          write(iunit,*) 'qiacr: ',cx(mgs,lr),nr,qx(mgs,lr),qr,qiacr(mgs),ciacr(mgs)
!          write(iunit,*) 'xdia r li = ',xdia(mgs,lr,3),xdia(mgs,li,3),xdia(mgs,lr,1),xdia(mgs,li,1)
!          write(iunit,*) 'i,j,ratio = ',i,j,ciacrratio(i,j),qiacrratio(i,j)
!          write(iunit,*) 'ni,ci = ',ni,cx(mgs,li),qx(mgs,li)

       ELSEIF ( imurain == 3 ) THEN ! gamma of volume
!   Set nr to the number of drops greater than 40 microns.
         arg = 1000.*xdia(mgs,lr,3)
!         nr = cx(mgs,lr)*gaml02( arg )
!        IF ( iacr .eq. 1 ) THEN
         IF ( ipconc .ge. 3 ) THEN
           IF ( iacrsize .eq. 1 ) THEN
            nr = cx(mgs,lr)*gaml02d500( arg )  ! number greater than 500 microns in diameter
           ELSEIF ( iacrsize .eq. 2 .or. iacrsize .eq. 5 ) THEN
            nr = cx(mgs,lr)*gaml02d300( arg )  ! number greater than 300 microns in diameter
           ELSEIF ( iacrsize .eq. 3 ) THEN
            nr = cx(mgs,lr)*gaml02( arg ) ! number greater than 40 microns in diameter
           ELSEIF ( iacrsize .eq. 4 ) THEN
            nr = cx(mgs,lr) ! all raindrops
           ENDIF
         ELSE
         nr = cx(mgs,lr)*gaml02( arg )
         ENDIF
!        ELSEIF ( iacr .eq. 2 ) THEN
!         nr = cx(mgs,lr)*gaml02d300( arg )  ! number greater than 300 microns in diameter
!        ENDIF
       IF ( ni .gt. 0.0 .and. nr .gt. 0.0 ) THEN
       d0 = xdia(mgs,lr,3)
       qiacr(mgs) = xdn(mgs,lr)*rhoinv(mgs)*   &
     &     (0.217239*(0.522295*(d0**5) +    &
     &      49711.81*(d0**6) -    &
     &      1.673016e7*(d0**7)+    &
     &      2.404471e9*(d0**8) -    &
     &      1.22872e11*(d0**9))*ni*nr)
      qiacr(mgs) = Min( qrmxd(mgs), qiacr(mgs) )
      ciacr(mgs) =   &
     &   (0.217239*(0.2301947*(d0**2) +    &
     &      15823.76*(d0**3) -    &
     &      4.167685e6*(d0**4) +    &
     &      4.920215e8*(d0**5) -    &
     &      2.133344e10*(d0**6))*ni*nr)
      ciacr(mgs) = Min( crmxd(mgs), ciacr(mgs) )
!      ciacr(mgs) = qiacr(mgs)*cx(mgs,lr)/qx(mgs,lr)
      ENDIF
      ENDIF
       IF ( iacr .eq. 1 .or. iacr .eq. 3 ) THEN
         ciacrf(mgs) = Min(ciacr(mgs), qiacr(mgs)/(1.0*vr1mm*1000.0)*rho0(mgs) ) ! *rzxh(mgs)
       ELSEIF ( iacr .eq. 2 ) THEN
         ciacrf(mgs) = ciacr(mgs) ! *rzxh(mgs)
       ELSEIF ( iacr .eq. 4 ) THEN
         ciacrf(mgs) = Min(ciacr(mgs), qiacr(mgs)/(1.0*vfrz*1000.0)*rho0(mgs) ) ! *rzxh(mgs)
       ELSEIF ( iacr .eq. 5 ) THEN
         ciacrf(mgs) = ciacr(mgs)*rzxh(mgs)
       ENDIF 
!      crfrzf(mgs) = Min(crfrz(mgs), qrfrz(mgs)/(bfnu*27.0*vr1mm*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs)
       ENDIF
      
      
      ELSE ! single-moment rain
      qiacr(mgs) =    &
     &  min(        &
     &   ((0.25/gf4)*pi)*eri(mgs)*cx(mgs,li)*qx(mgs,lr)   &
     &  *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,li,1))   &
     &  *(  gf6*gf1*xdia(mgs,lr,2)    &
     &    + 2.0*gf5*gf2*xdia(mgs,lr,1)*xdia(mgs,li,1)    &
     &    + gf4*gf3*xdia(mgs,li,2) )     &
     &  , qrmxd(mgs))
      ENDIF
!      if ( temg(mgs) .gt. 268.15 ) then
!      qiacr(mgs) = 0.0
!      ciacr(mgs) = 0.0
!      end if

      IF ( ipconc .ge. 1 ) THEN
        IF ( nsplinter .ge. 1000 ) THEN
        ! Lawson et al. 2015 JAS
         ! ave. diam of freezing drops in microns
           IF ( qiacr(mgs)*dtp > qxmin(lh) .and. ciacr(mgs) > 1.e-3 ) THEN
             tmpdiam = 1.e6*( 6.*qiacr(mgs)/(1000.*pi*ciacr(mgs) ) )**(1./3.) ! avg. diameter of newly frozen drops in microns
             csplinter(mgs) = lawson_splinter_fac*tmpdiam**4*ciacr(mgs)
           ENDIF
        ELSEIF ( nsplinter .ge. 0 ) THEN
          csplinter(mgs) = nsplinter*ciacr(mgs)
        ELSE
          csplinter(mgs) = -nsplinter*ciacrf(mgs)
        ENDIF
        qsplinter(mgs) = Min(0.1*qiacr(mgs), csplinter(mgs)*splintermass/rho0(mgs) ) ! makes splinters smaller if too much mass is taken from graupel
      ENDIF
      
      frach = 1.0
           IF ( ibiggsnow == 2 .or. ibiggsnow == 3 ) THEN
           IF ( ciacr(mgs) > qxmin(lh) ) THEN
           xvfrz = rho0(mgs)*qiacr(mgs)/(ciacr(mgs)*900.) ! mean volume of frozen drops; 900. for frozen drop density
           frach = 0.5 *(1. +  Tanh(0.2e12 *( xvfrz - 1.15*xvbiggsnow)))

             qiacrs(mgs) = (1.-frach)*qiacr(mgs)
             ciacrs(mgs) = (1.-frach)*ciacr(mgs) ! *rzxh(mgs)
           
           ENDIF
           ENDIF

      qiacrf(mgs) = frach*qiacr(mgs)
      ciacrf(mgs) = frach*ciacrf(mgs)

      IF ( lvol(lh) > 1 ) THEN
         viacrf(mgs) = rho0(mgs)*qiacrf(mgs)/rhofrz
      ENDIF
      
      end do
!
!
!
!

! snow aggregation here
      if ( ipconc .ge. 4 ) then !
      do mgs = 1,ngscnt
      csacs(mgs) = 0.0
      IF ( qx(mgs,ls) > qxmin(ls) .and. ess(mgs) .gt. 0.0 ) THEN ! .and. xv(mgs,ls) < 0.25*xvmx(ls)*Max(1.,100./Min(100.,xdn(mgs,ls)))  ) THEN

        IF ( iessec0flag == 0 ) THEN
          ec0(mgs) = 1.0
        ELSE
          tmp = xv(mgs,ls)/(xvmx(ls)*Max(1.,100./Min(100.,xdn(mgs,ls)))) ! fraction of max snow mass
          IF ( tmp .lt. essfrac1 ) THEN
            ec0(mgs) = 1.0
          ELSEIF ( tmp .gt. essfrac2 ) THEN
            ec0(mgs) = 0.0
          ELSE
            ec0(mgs) = (essfrac2 - tmp)/(essfrac2 - essfrac1)
          ENDIF
        ENDIF

      csacs(mgs) = ec0(mgs)*rvt*aa2*ess(mgs)*cx(mgs,ls)**2*Min( xv(mgs,ls), 4.*pii/3.*essrmax**3 ) ! *Min(1.,xdn(mgs,ls)/100. ) ! Min func tries to recalibrate for low diagnosed density 
!      csacs(mgs) = rvt*aa2*ess(mgs)*cx(mgs,ls)**2*Min( xv(mgs,ls), 4.*pii/3.*0.02**3 ) ! *Min(1.,xdn(mgs,ls)/100. ) ! Min func tries to recalibrate for low diagnosed density 
      csacs(mgs) = Min(csacs(mgs),csmxd(mgs))
      ENDIF
      end do
      end if
!
!
      if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 11'
      if ( ipconc .ge. 2 .or. ipelec .ge. 9 ) then
      do mgs = 1,ngscnt
      ciacw(mgs) = 0.0
      IF ( eiw(mgs) .gt. 0.0 ) THEN
        ciacw(mgs) = qiacw(mgs)*rho0(mgs)/xmas(mgs,lc)
        ciacw(mgs) = min(ciacw(mgs),ccmxd(mgs))
      ENDIF
      end do

      end if

      if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 18'
      if ( ipconc .ge. 2 .or. ipelec .ge. 1 ) then
      do mgs = 1,ngscnt
       cracw(mgs) = 0.0
       cracr(mgs) = 0.0
       ec0(mgs) = 1.e9
      IF ( qx(mgs,lc) .gt. qxmin(lc) .and. qx(mgs,lr) .gt. qxmin(lr)    &
     &      .and. qracw(mgs) .gt. 0.0 ) THEN

       IF ( ipconc .lt. 3 ) THEN
        IF ( erw(mgs) .gt. 0.0 ) THEN
        cracw(mgs) =   &
     &   ((0.25)*pi)*erw(mgs)*(cx(mgs,lc) - ccwresv(mgs))*cx(mgs,lr)   &
     &  *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,lc,1))   &
     &  *(  gf1*xdia(mgs,lc,2)   &
     &    + 2.0*gf2*xdia(mgs,lc,1)*xdia(mgs,lr,1)   &
     &    + gf3*xdia(mgs,lr,2) )
        ENDIF
       ELSE ! IF ( ipconc .ge. 3 .and. 
        IF ( dmrauto <= 0 .or.  rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN  !{
        IF ( 0.5*xdia(mgs,lr,3) .gt. rh(mgs) ) THEN ! { .or. cx(mgs,lr) .gt. nh(mgs) 
!        IF ( qx(mgs,lc) .gt. qxmin(lc) .and. qx(mgs,lr) .gt. qxmin(lr) ) THEN
          IF ( 0.5*xdia(mgs,lr,3) .gt. rwradmn ) THEN ! r > 50.e-6 
!          DM0CCC=A2*XNC*XNR*(XVC+XVR)                               ! (A11)
!         NOTE: murain drops out, so same result for imurain = 1 and 3
            cracw(mgs) = aa2*cx(mgs,lr)*(cx(mgs,lc) - ccwresv(mgs))*(xv(mgs,lc) + xv(mgs,lr))
          ELSE
            IF ( imurain == 3 ) THEN
!          DM0CCC=A1*XNC*XNR*(((CNU+2.)/(CNU+1.))*XVC**2+((RNU+2.)/(RNU+1.))*XVR**2) ! (A13)
            cracw(mgs) = aa1*cx(mgs,lr)*(cx(mgs,lc) - ccwresv(mgs))*   &
     &          ((alpha(mgs,lc) + 2.)*xv(mgs,lc)**2/(alpha(mgs,lc) + 1.) +    &
     &          (alpha(mgs,lr) + 2.)*xv(mgs,lr)**2/(alpha(mgs,lr) + 1.))
            ELSE ! imurain == 1 USE CP00 for rain DSD in diameter
            cracw(mgs) = aa1*cx(mgs,lr)*(cx(mgs,lc) - ccwresv(mgs))*   &
     &          ((alpha(mgs,lc) + 2.)*xv(mgs,lc)**2/(alpha(mgs,lc) + 1.) +    &
     &          (alpha(mgs,lr) + 6.)*(alpha(mgs,lr) + 5.)*(alpha(mgs,lr) + 4.)*xv(mgs,lr)**2/  &
     &             ((alpha(mgs,lr) + 3.)*(alpha(mgs,lr) + 2.)*(alpha(mgs,lr) + 1.)) )
            ENDIF ! imurain
          ENDIF
        ENDIF ! } rh
        ENDIF ! } dmrauto
       ENDIF ! ipconc
      ENDIF ! qc > qcmin & qr > qrmin
        
! Rain self collection (cracr) and break-up (factor of ec0)
!
!       
        ec0(mgs) = 2.e9
        IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN
        rwrad = 0.5*xdia(mgs,lr,3)
        IF ( xdia(mgs,lr,3) .gt. 2.0e-3 .or. icracr <= 0 ) THEN
          ec0(mgs) = 0.0
          cracr(mgs) = 0.0
        ELSE
         IF ( dmrauto <= 0 .or.  rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN 
          IF ( xdia(mgs,lr,3) .lt. 6.1e-4 ) THEN
            ec0(mgs) = 1.0
          ELSE
            ec0(mgs) = Exp(-50.0*(50.0*(xdia(mgs,lr,3) - 6.0e-4)))
          ENDIF
          

          IF ( rwrad .ge. 50.e-6 ) THEN
              cracr(mgs) = ec0(mgs)*aa2*cx(mgs,lr)**2*xv(mgs,lr)
          ELSE
            IF ( imurain == 3 ) THEN
             cracr(mgs) = ec0(mgs)*aa1*(cx(mgs,lr)*xv(mgs,lr))**2*   &
     &                   (alpha(mgs,lr) + 2.)/(alpha(mgs,lr) + 1.)
            ELSE ! imurain == 1
             cracr(mgs) = ec0(mgs)*aa1*(cx(mgs,lr)*xv(mgs,lr))**2*   &
     &                   (alpha(mgs,lr) + 6.)*(alpha(mgs,lr) + 5.)*(alpha(mgs,lr) + 4.)/ &
     &                  ((alpha(mgs,lr) + 3.)*(alpha(mgs,lr) + 2.)*(alpha(mgs,lr) + 1.))
              
            ENDIF
          ENDIF
!          cracr(mgs) = Min(cracr(mgs),crmxd(mgs))
         ENDIF
        ENDIF
        ENDIF

!      cracw(mgs) = min(cracw(mgs),cxmxd(mgs,lc)) 
      end do
      end if

!
!
!
!  Graupel
!
      if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22ii'
      chacw(:) = 0.0
      if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then
      do mgs = 1,ngscnt

      IF ( ipconc .ge. 5 ) THEN
       IF ( qhacw(mgs) .gt. 0.0 .and. xmas(mgs,lc) .gt. 0.0 ) THEN

!  This is the explict version of chacw, which turns out to be very close to the
!  approximation that the droplet size does not change, to within a few percent.
!  This may _not_ be the case for cnu other than zero!
!          chacw(mgs) = (ehw(mgs)*cx(mgs,lc)*cx(mgs,lh)*(pi/4.)*
!     :    abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1))*
!     :    (2.0*xdia(mgs,lh,1)*(xdia(mgs,lh,1) +
!     :         xdia(mgs,lc,1)*gf43rds) +
!     :      xdia(mgs,lc,2)*gf53rds))

!          chacw(mgs) = Min( chacw(mgs), 0.6*cx(mgs,lc)*dtpinv )

!        chacw(mgs) = qhacw(mgs)*rho0(mgs)/xmas(mgs,lc)
        chacw(mgs) = qhacw(mgs)*rho0(mgs)/xmascw(mgs)
!        chacw(mgs) = min(chacw(mgs),cxmxd(mgs,lc))
        chacw(mgs) = Min( chacw(mgs), 0.5*(cx(mgs,lc) - ccwresv(mgs))*dtpinv )
       ELSE
        qhacw(mgs) = 0.0
       ENDIF
      ELSE
      ! single-moment
      chacw(mgs) =   &
     &   ((0.25)*pi)*ehw(mgs)*cx(mgs,lc)*cx(mgs,lh)   &
     &  *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1))   &
     &  *(  gf1*xdia(mgs,lc,2)   &
     &    + 2.0*gf2*xdia(mgs,lc,1)*xdia(mgs,lh,1)   &
     &    + gf3*xdia(mgs,lh,2) )
      chacw(mgs) = min(chacw(mgs),0.5*cx(mgs,lc)*dtpinv)
!      chacw(mgs) = min(chacw(mgs),cxmxd(mgs,lc))
!      chacw(mgs) = min(chacw(mgs),ccmxd(mgs))
      ENDIF
      end do
      end if
!
      if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22kk'
      chaci(:) = 0.0
      if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then
      do mgs = 1,ngscnt
      IF ( ehi(mgs) .gt. 0.0 .or. ( ehiclsn(mgs) > 0.0 .and. ipelec > 0 )) THEN
       IF ( ipconc .ge. 5 ) THEN

       vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,li,1))**2 +    &
     &            0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,li,1) )

          chaci0(mgs) = 0.25*pi*ehiclsn(mgs)*cx(mgs,lh)*cx(mgs,li)*vt*   &
     &         (  da0lh(mgs)*xdia(mgs,lh,3)**2 +     &
     &            dab0lh(mgs,lh,li)*xdia(mgs,lh,3)*xdia(mgs,li,3) +    &
     &            da0(li)*xdia(mgs,li,3)**2 )

       ELSE
        chaci0(mgs) =   &
     &   ((0.25)*pi)*ehiclsn(mgs)*cx(mgs,li)*cx(mgs,lh)   &
     &  *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,li,1))   &
     &  *(  gf1*xdia(mgs,li,2)   &
     &    + 2.0*gf2*xdia(mgs,li,1)*xdia(mgs,lh,1)   &
     &    + gf3*xdia(mgs,lh,2) )
        ENDIF

        chaci(mgs) = min(ehi(mgs)*chaci0(mgs),cimxd(mgs))
       ENDIF
      end do
      end if


      chacis(:) = 0.0
      if ( lis > 1 .and. ipconc .ge. 5 .or. ipelec .ge. 1 ) then
      do mgs = 1,ngscnt
      IF ( ehis(mgs) .gt. 0.0 .or. ( ehisclsn(mgs) > 0.0 .and. ipelec > 0 )) THEN

       vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,lis,1))**2 +    &
     &            0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,lis,1) )

          chacis0(mgs) = 0.25*pi*ehisclsn(mgs)*cx(mgs,lh)*cx(mgs,lis)*vt*   &
     &         (  da0lh(mgs)*xdia(mgs,lh,3)**2 +     &
     &            dab0lh(mgs,lh,lis)*xdia(mgs,lh,3)*xdia(mgs,lis,3) +    &
     &            da0(lis)*xdia(mgs,lis,3)**2 )


        chacis(mgs) = min(ehis(mgs)*chacis0(mgs),cxmxd(mgs,lis))
       ENDIF
      end do
      end if
!
!
      if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22nn'
      chacs(:) = 0.0
      if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then
      do mgs = 1,ngscnt
      IF ( ehs(mgs) .gt. 0 ) THEN
       IF ( ipconc .ge. 5 .or. ( ehsclsn(mgs) > 0.0 .and. ipelec > 0 ) ) THEN

       vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1))**2 +    &
     &            0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,ls,1) )

          chacs0(mgs) = 0.25*pi*ehsclsn(mgs)*cx(mgs,lh)*cx(mgs,ls)*vt*   &
     &         (  da0lh(mgs)*xdia(mgs,lh,3)**2 +     &
     &            dab0lh(mgs,lh,ls)*xdia(mgs,lh,3)*xdia(mgs,ls,3) +    &
     &            da0(ls)*xdia(mgs,ls,3)**2 )

       ELSE
      chacs0(mgs) =   &
     &   ((0.25)*pi)*ehsclsn(mgs)*cx(mgs,ls)*cx(mgs,lh)   &
     &  *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1))   &
     &  *(  gf3*gf1*xdia(mgs,ls,2)   &
     &    + 2.0*gf2*gf2*xdia(mgs,ls,1)*xdia(mgs,lh,1)   &
     &    + gf1*gf3*xdia(mgs,lh,2) )
      ENDIF
      chacs(mgs) = min(ehs(mgs)*chacs0(mgs),csmxd(mgs))
      ENDIF
      end do
      end if


!
!
!  Hail
!
      if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22ii'
      chlacw(:) = 0.0
      if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then
      do mgs = 1,ngscnt

      IF ( lhl .gt. 1 .and. ipconc .ge. 5 ) THEN
       IF ( qhlacw(mgs) .gt. 0.0 .and. xmas(mgs,lc) .gt. 0.0 ) THEN

!  This is the explict version of chacw, which turns out to be very close to the
!  approximation that the droplet size does not change, to within a few percent.
!  This may _not_ be the case for cnu other than zero!
!          chlacw(mgs) = (ehlw(mgs)*cx(mgs,lc)*cx(mgs,lhl)*(pi/4.)*
!     :    abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,lc,1))*
!     :    (2.0*xdia(mgs,lhl,1)*(xdia(mgs,lhl,1) +
!     :         xdia(mgs,lc,1)*gf43rds) +
!     :      xdia(mgs,lc,2)*gf53rds))

!          chlacw(mgs) = Min( chlacw(mgs), 0.6*cx(mgs,lc)*dtpinv )

!        chlacw(mgs) = qhlacw(mgs)*rho0(mgs)/xmas(mgs,lc)
        chlacw(mgs) = qhlacw(mgs)*rho0(mgs)/xmascw(mgs)
!        chlacw(mgs) = min(chlacw(mgs),cxmxd(mgs,lc))
        chlacw(mgs) = Min( chlacw(mgs), 0.5*cx(mgs,lc)*dtpinv )
       ELSE
        qhlacw(mgs) = 0.0
       ENDIF
!      ELSE
!      chlacw(mgs) =
!     >   ((0.25)*pi)*ehlw(mgs)*cx(mgs,lc)*cx(mgs,lhl)
!     >  *abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,lc,1))
!     >  *(  gf1*xdia(mgs,lc,2)
!     >    + 2.0*gf2*xdia(mgs,lc,1)*xdia(mgs,lhl,1)
!     >    + gf3*xdia(mgs,lhl,2) )
!      chlacw(mgs) = min(chlacw(mgs),0.5*cx(mgs,lc)*dtpinv)
!      chlacw(mgs) = min(chlacw(mgs),cxmxd(mgs,lc))
!      chlacw(mgs) = min(chlacw(mgs),ccmxd(mgs))
      ENDIF
      end do
      end if
!
      if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22kk'
      chlaci(:) = 0.0
      chlaci0(:) = 0.0
      if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then
      do mgs = 1,ngscnt
      IF ( lhl .gt. 1 .and. ( ehli(mgs) .gt. 0.0 .or. (ipelec > 0 .and. ehliclsn(mgs) > 0.0) )  ) THEN
       IF ( ipconc .ge. 5 ) THEN

       vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,li,1))**2 +    &
     &            0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,li,1) )

          chlaci0(mgs) = 0.25*pi*ehliclsn(mgs)*cx(mgs,lhl)*cx(mgs,li)*vt*   &
     &         (  da0lhl(mgs)*xdia(mgs,lhl,3)**2 +     &
     &            dab0(lhl,li)*xdia(mgs,lhl,3)*xdia(mgs,li,3) +    &
     &            da0(li)*xdia(mgs,li,3)**2 )

!       ELSE
!        chlaci(mgs) =
!     >   ((0.25)*pi)*ehli(mgs)*cx(mgs,li)*cx(mgs,lhl)
!     >  *abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,li,1))
!     >  *(  gf1*xdia(mgs,li,2)
!     >    + 2.0*gf2*xdia(mgs,li,1)*xdia(mgs,lhl,1)
!     >    + gf3*xdia(mgs,lhl,2) )
        ENDIF

        chlaci(mgs) = min(ehli(mgs)*chlaci0(mgs),cimxd(mgs))
       ENDIF
      end do
      end if


      IF ( lis > 1 .and. ipconc .ge. 5) THEN
      
      if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22kk'
      chlacis(:) = 0.0
      chlacis0(:) = 0.0
       do mgs = 1,ngscnt
      IF ( lhl .gt. 1 .and. ( ehlis(mgs) .gt. 0.0 .or. (ipelec > 0 .and. ehlisclsn(mgs) > 0.0) )  ) THEN

       vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,lis,1))**2 +    &
     &            0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,lis,1) )

          chlacis0(mgs) = 0.25*pi*ehlisclsn(mgs)*cx(mgs,lhl)*cx(mgs,lis)*vt*   &
     &         (  da0lhl(mgs)*xdia(mgs,lhl,3)**2 +     &
     &            dab0(lhl,lis)*xdia(mgs,lhl,3)*xdia(mgs,lis,3) +    &
     &            da0(lis)*xdia(mgs,lis,3)**2 )


        chlacis(mgs) = min(ehlis(mgs)*chlacis0(mgs),cxmxd(mgs,lis))
       ENDIF
      end do
      ENDIF

!
!
      if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22jj'
      chlacs(:) = 0.0
      chlacs0(:) = 0.0
      if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then
      do mgs = 1,ngscnt
      IF ( lhl .gt. 1 .and. ( ehls(mgs) .gt. 0.0 .or. (ipelec > 0 .and. ehlsclsn(mgs) > 0.0) ) ) THEN
       IF ( ipconc .ge. 5 ) THEN

       vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,ls,1))**2 +    &
     &            0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,ls,1) )

          chlacs0(mgs) = 0.25*pi*ehlsclsn(mgs)*cx(mgs,lhl)*cx(mgs,ls)*vt*   &
     &         (  da0lhl(mgs)*xdia(mgs,lhl,3)**2 +     &
     &            dab0(lhl,ls)*xdia(mgs,lhl,3)*xdia(mgs,ls,3) +    &
     &            da0(ls)*xdia(mgs,ls,3)**2 )

!       ELSE
!      chlacs(mgs) =
!     >   ((0.25)*pi)*ehls(mgs)*cx(mgs,ls)*cx(mgs,lhl)
!     >  *abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,ls,1))
!     >  *(  gf3*gf1*xdia(mgs,ls,2)
!     >    + 2.0*gf2*gf2*xdia(mgs,ls,1)*xdia(mgs,lhl,1)
!     >    + gf1*gf3*xdia(mgs,lhl,2) )
      ENDIF
      chlacs(mgs) = min(ehls(mgs)*chlacs0(mgs),csmxd(mgs))
      ENDIF
      end do
      end if

!
! Ziegler (1985) autoconversion
!
!
      IF ( ipconc .ge. 2 .and. ircnw /= -1) THEN ! DTD: added flag for autoconversion.  If -1, turns off autoconversion
      if (ndebug .gt. 0 ) write(0,*) 'conc 26a'
      
      DO mgs = 1,ngscnt
        zrcnw(mgs) = 0.0
        qrcnw(mgs) = 0.0
        crcnw(mgs) = 0.0
        cautn(mgs) = 0.0
      ENDDO
      
      IF ( dmrauto >= -1 ) THEN !{
      DO mgs = 1,ngscnt
!      qracw(mgs) = 0.0
!      cracw(mgs) = 0.0
       IF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 1000. .and. temg(mgs) .gt. tfrh+4.) THEN
       !( .and. w(igs(mgs),jgs,kgs(mgs)) > 5.0) THEN ! DTD: added w threshold for testing                                                                                                            
         volb = xv(mgs,lc)*(1./(1.+alpha(mgs,lc)))**(1./2.)
         cautn(mgs) = Min(ccmxd(mgs),   &
     &      ((alpha(mgs,lc)+2.)/(alpha(mgs,lc)+1.))*aa1*cx(mgs,lc)**2*xv(mgs,lc)**2)
         cautn(mgs) = Max( 0.0d0, cautn(mgs) )
         IF ( rb(mgs) .le. 7.51d-6 ) THEN
           t2s = 1.d30
!           cautn(mgs) = 0.0
         ELSE
!         XL2P=2.7E-2*XNC*XVC*((1.E12*RB**3*RC)-0.4)
         
!        T2S=3.72E-3/(((1.E4*RB)-7.5)*XNC*XVC) 
!           t2s = 3.72E-3/(((1.e6*rb)-7.5)*cx(mgs,lc)*xv(mgs,lc))
!           t2s = 3.72/(((1.e6*rb(mgs))-7.5)*rho0(mgs)*qx(mgs,lc))
           t2s = 3.72/(1.e6*(rb(mgs)-7.500d-6)*rho0(mgs)*qx(mgs,lc))

           qrcnw(mgs) = Max( 0.0d0, xl2p(mgs)/(t2s*rho0(mgs)) )
           crcnw(mgs) = Max( 0.0d0, Min(3.5e9*xl2p(mgs)/t2s,0.5*cautn(mgs)) )
           
           IF ( dmrauto == 0 ) THEN
             IF ( qx(mgs,lr)*rho0(mgs) > 1.2*xl2p(mgs) .and. cx(mgs,lr) > cxmin ) THEN ! Cohard and Pinty (2000a) switch over from (18) to (19)
               crcnw(mgs) = cx(mgs,lr)/qx(mgs,lr)*qrcnw(mgs)
             ELSEIF ( ( dmropt == 1 .or. dmropt == 3 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN
               tmp = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr)
               crcnw(mgs) = Min(tmp,crcnw(mgs) )
             ELSEIF ( ( dmropt == 4 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN
               tmp = crcnw(mgs)
               tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr)
               ! try mass-weighted average of old and new Dmr using converted qc mass
               crcnw(mgs) = (tmp*qrcnw(mgs)+tmp2*qx(mgs,lr))/(qrcnw(mgs)+qx(mgs,lr))
             ELSEIF ( ( dmropt == 5 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN
               tmp = crcnw(mgs)
               tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr)
               ! try mass-weighted average of old and new Dmr using full qc mass
               crcnw(mgs) = (tmp*qx(mgs,lc)+tmp2*qx(mgs,lr))/(qx(mgs,lc)+qx(mgs,lr))
             ELSEIF ( ( dmropt == 6 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN
               tmp = crcnw(mgs)
               tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr)
               ! try mass*diameter-weighted average of old and new Dmr (using full qc mass)
               crcnw(mgs) = (tmp*xdia(mgs,lc,3)*qx(mgs,lc)+tmp2*xdia(mgs,lr,3)*qx(mgs,lr))/(xdia(mgs,lc,3)*qx(mgs,lc)+xdia(mgs,lr,3)*qx(mgs,lr))
             ELSEIF ( ( dmropt == 7 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN
               tmp = crcnw(mgs)
               tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr)
               ! try diameter-weighted average of old and new Dmr
               crcnw(mgs) = (tmp*xdia(mgs,lc,3)+tmp2*xdia(mgs,lr,3))/(xdia(mgs,lc,3)+xdia(mgs,lr,3))
             ELSEIF ( ( dmropt == 8 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN
               tmp = crcnw(mgs)
               tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr)
               ! try sqrt(diameter)-weighted average of old and new Dmr
               crcnw(mgs) = (tmp*sqrt(xdia(mgs,lc,3))+tmp2*sqrt(xdia(mgs,lr,3)))/(sqrt(xdia(mgs,lc,3))+sqrt(xdia(mgs,lr,3)))
             ENDIF
           ELSEIF ( dmrauto == 1  .and. cx(mgs,lr) > cxmin) THEN
             IF ( qx(mgs,lr) > qxmin(lr) ) THEN
               tmp = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr)
               crcnw(mgs) = Min(tmp,crcnw(mgs) )
             ENDIF
           ELSEIF ( dmrauto == 2  .and. cx(mgs,lr) > cxmin) THEN
               tmp = crcnw(mgs)
               tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr)
               ! try mass-weighted average of old and new Dmr
               crcnw(mgs) = (tmp*qrcnw(mgs)+tmp2*qx(mgs,lr))/(qrcnw(mgs)+qx(mgs,lr))
           ELSEIF ( dmrauto == 3  .and. cx(mgs,lr) > cxmin) THEN ! adapted from MY/CP code
              tmp = Max( 2.d0*rh(mgs), dble( xdia(mgs,lr,3) ) )
              crcnw(mgs) = rho0(mgs)*qrcnw(mgs)/(pi/6.*1000.*tmp**3)
           ENDIF
           
           IF ( crcnw(mgs) < 1.e-30 ) qrcnw(mgs) = 0.0

!           IF (  crcnw(mgs) .gt. cautn(mgs) .and. crcnw(mgs) .gt. 1.0 )
!     :          THEN
!             write(0,*)  'crcnw,cautn ',crcnw(mgs)/cautn(mgs),
!     :          crcnw(mgs),cautn(mgs),igs(mgs),kgs(mgs),t2s,qx(mgs,lr)
!             write(0,*)  '            ',qx(mgs,lc),cx(mgs,lc),0.5e6*xdia(mgs,lc,1)
!             write(0,*)  '            ',rho0(mgs)*qrcnw(mgs)/crcnw(mgs),
!     :         1.e6*(( 3/(4.*pi))*rho0(mgs)*qrcnw(mgs)/
!     :       (crcnw(mgs)*xdn(mgs,lr)))**(1./3.),rh(mgs)*1.e6,rwrad(mgs)
!           ELSEIF ( crcnw(mgs) .gt. 1.0 .and. cautn(mgs) .gt. 0.) THEN
!             write(0,*)  'crcnw,cautn ',crcnw(mgs)/cautn(mgs),
!     :          crcnw(mgs),cautn(mgs),igs(mgs),kgs(mgs),t2s
!             write(0,*)  '            ',rho0(mgs)*qrcnw(mgs)/crcnw(mgs),
!     :  1.e6*(( 3*pi/4.)*rho0(mgs)*qrcnw(mgs)/
!     :   (crcnw(mgs)*xdn(mgs,lr)))**(1./3.)
!           ENDIF
!           crcnw(mgs) = Min(cautn(mgs),3.5e9*xl2p(mgs)/t2s)

!           IF ( qrcnw(mgs) .gt. 0.3e-2 ) THEN
!            write(0,*)  'QRCNW'
!            write(0,*)  qrcnw(mgs),crcnw(mgs),cautn(mgs)
!            write(0,*)  xl2p,t2s,rho0(mgs),xv(mgs,lc),cx(mgs,lc),qx(mgs,lc)
!            write(0,*)  rb,0.5*xdia(mgs,lc,1),mgs,igs(mgs),kgs(mgs)
!           ENDIF
!           qrcnw(mgs) = Min(qrcnw(mgs),qcmxd(mgs))
         ENDIF


       ENDIF
      ENDDO
      
      ENDIF !} dmrauto >= 0



      ELSE

!
!  Berry 1968 auto conversion for rain (Orville & Kopp 1977)
!
!
      if ( ircnw .eq. 4 ) then
      do mgs = 1,ngscnt
!      sconvmix(lcw,mgs) = 0.0
      qrcnw(mgs) =  0.0
      qdiff = max((qx(mgs,lc)-qminrncw),0.0)
      if ( qdiff .gt. 0.0 .and. xdia(mgs,lc,1) .gt. 20.0e-6 ) then
      argrcnw =   &
     &  ((1.2e-4)+(1.596e-12)*(cx(mgs,lc)*1.0e-6)   &
     &  /(cwdisp*qdiff*1.0e-3*rho0(mgs)))
      qrcnw(mgs) = (rho0(mgs)*1e-3)*(qdiff**2)/argrcnw
!      sconvmix(lcw,mgs) = max(sconvmix(lcw,mgs),0.0)
      qrcnw(mgs) = (max(qrcnw(mgs),0.0))
      end if
      end do

      ENDIF
!
!
!
!  Berry 1968 auto conversion for rain (Ferrier 1994)
!
!
      if ( ircnw .eq. 5 ) then
      do mgs = 1,ngscnt
      qrcnw(mgs) = 0.0
      qrcnw(mgs) =  0.0
      qccrit = (pi/6.)*(cx(mgs,lc)*cwdiap**3)*xdn(mgs,lc)/rho0(mgs)
      qdiff = max((qx(mgs,lc)-qccrit),0.)
      if ( qdiff .gt. 0.0 .and. cx(mgs,lc) .gt. 1.0 ) then
      argrcnw = &
!     >  ((1.2e-4)+(1.596e-12)*cx(mgs,lc)/(cwdisp*rho0(mgs)*qdiff))   &
     &  ((1.2e-4)+(1.596e-12)*cx(mgs,lc)*1.0e-3/(cwdisp*rho0(mgs)*qdiff))
      qrcnw(mgs) = &
!     >  timflg(mgs)*rho0(mgs)*(qdiff**2)/argrcnw   &
     &  1.0e-3*rho0(mgs)*(qdiff**2)/argrcnw
      qrcnw(mgs) = Min(qxmxd(mgs,lc), (max(qrcnw(mgs),0.0)) )

!      write(iunit,*) 'qrcnw,cx =',qrcnw(mgs),cx(mgs,lc),mgs,1.e3*qx(mgs,lc),cno(lr)
      end if
      end do
      end if

!
!
!  kessler auto conversion for rain.
!
      if ( ircnw .eq. 2 ) then
      do mgs = 1,ngscnt
      qrcnw(mgs) = 0.0
      qrcnw(mgs) = (0.001)*max((qx(mgs,lc)-qminrncw),0.0)
      end do
      end if
!
!  c4 = pi/6
!  c1 = 0.12-0.32 for colorado storms...typically 0.3-0.4
!  berry reinhart type conversion (proctor 1988)
!
      if ( ircnw .eq. 1 ) then
      do mgs = 1,ngscnt
      qrcnw(mgs) = 0.0
      c1 = 0.2
      c4 = pi/(6.0)
      bradp =    &
     & (1.e+06) * ((c1/(0.38))**(1./3.)) * (xdia(mgs,lc,1)*(0.5))
      bl2 =   &
     & (0.027) * ((100.0)*(bradp**3)*(xdia(mgs,lc,1)*(0.5)) - (0.4))
      bt2 = (bradp -7.5) / (3.72)
      qrcnw(mgs) = 0.0
      if ( bl2 .gt. 0.0 .and. bt2 .gt. 0.0 ) then
      qrcnw(mgs) = bl2 * bt2 * rho0(mgs)   &
     &  * qx(mgs,lc) * qx(mgs,lc)
      end if
      end do
      end if



      ENDIF  !  ( ipconc .ge. 2 )

!
!
!
!  Bigg Freezing of Rain
!
      if (ndebug .gt. 0 ) write(0,*) 'conc 27a'
      qrfrz(:) = 0.0
      qrfrzs(:) = 0.0
      qrfrzf(:) = 0.0
      vrfrzf(:) = 0.0
      crfrz(:) = 0.0
      crfrzs(:) = 0.0
      crfrzf(:) = 0.0
      zrfrz(:)  = 0.0
      zrfrzs(:)  = 0.0
      zrfrzf(:)  = 0.0
      qwcnr(:) = 0.0
      
      IF ( .not. ( ipconc == 0 .and. lwsm6 ) ) THEN
      
      do mgs = 1,ngscnt 
      if ( qx(mgs,lr) .gt. qxmin(lr) .and. temcg(mgs) .lt. -5. .and. ibiggopt > 0 ) then
!      brz = 100.0
!      arz = 0.66
       IF ( ipconc .lt. 3 ) THEN
       qrfrz(mgs) =    &
     &  min(   &
     &  (20.0)*(pi**2)*brz*(xdn(mgs,lr)/rho0(mgs))   &
     &   *cx(mgs,lr)*(xdia(mgs,lr,1)**6)   &
     &   *(exp(max(-arz*temcg(mgs), 0.0))-1.0)   &
     &  , qrmxd(mgs))
        qrfrzf(mgs) = qrfrz(mgs)

!       ELSEIF ( ipconc .ge. 3 .and. xv(mgs,lr) .gt. 1.1*xvmn(lr) ) THEN
       ELSEIF ( ipconc .ge. 3 ) THEN
!         tmp = brz*cx(mgs,lr)*(Exp(Max( -arz*temcg(mgs), 0.0 )) - 1.0)
!         crfrz(mgs) = xv(mgs,lr)*tmp

         frach = 1.0d0
         
!         IF ( ibiggopt == 2 .and. imurain == 1 .and. lzr < 1 ) THEN ! lzr check because results are weird for 3-moment
         IF ( ibiggopt == 2 .and. imurain == 1 ) THEN !
         ! integrate from Bigg diameter (for given supercooling Ts) to infinity
           
           volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 !  Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 (Proc. Phys. Soc. London) 
                                               ! for mean temperature for freezing: -ln (V) = a*Ts - b, where a = 6.9/6.8, or approx a = 1.0, and b = 16.2
                                               ! volt is given in cm**3, so convert to m**3
           dbigg = (6./pi* volt )**(1./3.) 
           
           ! perhaps should also test that W > V_t_dbigg, i.e., that drops the size of dbigg are being lifted and cooled. 
           IF ( dbigg < 8.e-3 ) THEN !{ only bother if freezing diameter is reasonable
           
             ratio = Min(maxratiolu, dbigg/xdia(mgs,lr,1) )
           
           i = Min(nqiacrratio,Int(ratio*dqiacrratioinv))
           IF ( alp0flag ) THEN
           j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))*dqiacralphainv)
           ELSE
           j = Int(Max(minalphalu,Min(maxalphalu,alpha(mgs,lr)))*dqiacralphainv)
           ENDIF
           delx = ratio - float(i)*dqiacrratio
           dely = alpha(mgs,lr) - float(j)*dqiacralpha
           ip1 = Min( i+1, nqiacrratio )
           jp1 = Min( j+1, nqiacralpha )

           ! interpolate along x, i.e., ratio; 
           tmp1 = ciacrratio(i,j) + delx*dqiacrratioinv*(ciacrratio(ip1,j) - ciacrratio(i,j))
           tmp2 = ciacrratio(i,jp1) + delx*dqiacrratioinv*(ciacrratio(ip1,jp1) - ciacrratio(i,jp1))
           
           ! interpolate along alpha; 
           
           crfrz(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*cx(mgs,lr)*dtpinv
           crfrzf(mgs) = crfrz(mgs)
           ! interpolate along x, i.e., ratio; 
           tmp1 = qiacrratio(i,j) + delx*dqiacrratioinv*(qiacrratio(ip1,j) - qiacrratio(i,j))
           tmp2 = qiacrratio(i,jp1) + delx*dqiacrratioinv*(qiacrratio(ip1,jp1) - qiacrratio(i,jp1))
           
           ! interpolate along alpha; 
           
           qrfrz(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*qx(mgs,lr)*dtpinv
           qrfrzf(mgs) = qrfrz(mgs)

           IF ( qrfrz(mgs)*dtp < qxmin(lh) .or. crfrz(mgs)*dtp < cxmin ) THEN
           
             crfrz(mgs) = 0.0
             qrfrz(mgs) = 0.0
             qrfrzf(mgs) = 0.0
            
           ELSE !{

            
           
            IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < 2.*xvmn(lr) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN
!            IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < xvbiggsnow .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN
             ! rain drops are so small that they cannot be pushed smaller, so put into snow (or cloud ice, depending on ifrzs)
              crfrzf(mgs) = 0.0
              qrfrzf(mgs) = 0.0
              crfrzs(mgs) = crfrz(mgs)
              qrfrzs(mgs) = qrfrz(mgs)

           ELSEIF ( dbigg < Max( biggsnowdiam, Max(dfrz,dhmn)) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN ! { convert some to snow or ice crystals
            ! temporarily store qrfrz and crfrz in snow terms and caclulate new crfrzf, qrfrzf, and zrfrzf. Leave crfrz etc. alone!
            
            crfrzs(mgs) = crfrz(mgs)
            qrfrzs(mgs) = qrfrz(mgs)
            
            IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < 1.2*xvmn(lr) ) THEN
             ! rain drops are so small that they cannot be pushed smaller, so put into snow (or cloud ice, depending on ifrzs)
            crfrzf(mgs) = 0.0
            qrfrzf(mgs) = 0.0

            ELSE !{
            
           ! recalculate using dhmn for ratio
           ratio = Min( maxratiolu, Max(dfrz,dhmn)/xdia(mgs,lr,1) )
           
           i = Min(nqiacrratio,Int(ratio*dqiacrratioinv))
!           j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))*dqiacralphainv)
!           j = Int(Max(alphamin,Min(alphamax,alpha(mgs,lr)))*dqiacralphainv)
           IF ( alp0flag ) THEN
           j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))*dqiacralphainv)
           ELSE
           j = Int(Max(minalphalu,Min(maxalphalu,alpha(mgs,lr)))*dqiacralphainv)
           ENDIF
           delx = ratio - float(i)*dqiacrratio
           dely = alpha(mgs,lr) - float(j)*dqiacralpha
           ip1 = Min( i+1, nqiacrratio )
           jp1 = Min( j+1, nqiacralpha )

           ! interpolate along x, i.e., ratio; 
           tmp1 = ciacrratio(i,j) + delx*dqiacrratioinv*(ciacrratio(ip1,j) - ciacrratio(i,j))
           tmp2 = ciacrratio(i,jp1) + delx*dqiacrratioinv*(ciacrratio(ip1,jp1) - ciacrratio(i,jp1))


           ! interpolate along alpha; 
           
           crfrzf(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*cx(mgs,lr)*dtpinv
           
           ! interpolate along x, i.e., ratio; 
           tmp1 = qiacrratio(i,j) + delx*dqiacrratioinv*(qiacrratio(ip1,j) - qiacrratio(i,j))
           tmp2 = qiacrratio(i,jp1) + delx*dqiacrratioinv*(qiacrratio(ip1,jp1) - qiacrratio(i,jp1))
           
           ! interpolate along alpha; 
           
           qrfrzf(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*qx(mgs,lr)*dtpinv

           ! now subtract off the difference
            crfrzs(mgs) = crfrzs(mgs) - crfrzf(mgs)
            qrfrzs(mgs) = qrfrzs(mgs) - qrfrzf(mgs)

            ENDIF ! }
           ELSE
            crfrzs(mgs) = 0.0
            qrfrzs(mgs) = 0.0
           ENDIF ! }
           
           ENDIF !}
           
           IF ( (qrfrz(mgs))*dtp > qx(mgs,lr) ) THEN
             fac = ( qrfrz(mgs) )*dtp/qx(mgs,lr)
             qrfrz(mgs) = fac*qrfrz(mgs)
             qrfrzs(mgs) = fac*qrfrzs(mgs)
             qrfrzf(mgs) = fac*qrfrzf(mgs)
             crfrz(mgs) = fac*crfrz(mgs)
             crfrzs(mgs) = fac*crfrzs(mgs)
             crfrzf(mgs) = fac*crfrzf(mgs)
           ENDIF
           
            ENDIF !}

!           IF ( (crfrzs(mgs) + crfrz(mgs))*dtp > cx(mgs,lr) ) THEN
!             fac = ( crfrzs(mgs) + crfrz(mgs) )*dtp/cx(mgs,lr)
!             crfrz(mgs) = fac*crfrz(mgs)
!             crfrzs(mgs) = fac*crfrzs(mgs)
!           ENDIF
           
!           qrfrzf(mgs) = qrfrz(mgs)
!           crfrzf(mgs) = crfrz(mgs)
           
   !        qrfrz(mgs) = qrfrzf(mgs) + qrfrzs(mgs)
   !        crfrz(mgs) = crfrzf(mgs) + crfrzs(mgs)

           
         ELSEIF ( ibiggopt == 1 ) THEN
         ! Z85, eq. A34
         tmp = xv(mgs,lr)*brz*cx(mgs,lr)*(Exp(Max( -arz*temcg(mgs), 0.0 )) - 1.0)
         IF ( .false. .and. tmp .gt. cxmxd(mgs,lr) ) THEN ! {
!           write(iunit,*) 'Bigg Freezing problem!',mgs,igs(mgs),kgs(mgs)
!           write(iunit,*)  'tmp, cx(lr), xv = ',tmp, cx(mgs,lr), xv(mgs,lr), (Exp(Max( -arz*temcg(mgs), 0.0 )) - 1.0)
!           write(iunit,*)  'qr,temcg = ',qx(mgs,lr)*1000.,temcg(mgs)
           crfrz(mgs) = cxmxd(mgs,lr) ! cx(mgs,lr)*dtpinv
           qrfrz(mgs) = qxmxd(mgs,lr) ! qx(mgs,lr)*dtpinv
!           STOP
         ELSE ! } {
         crfrz(mgs) = tmp
 !        crfrzfmx = cx(mgs,lr)*Exp(-4./3.*pi*(40.e-6)**3/xv(mgs,lr))
 !        IF ( crfrz(mgs) .gt. crfrzmx ) THEN
 !          crfrz(mgs) = crfrzmx
 !          qrfrz(mgs) = bfnu*xmas(mgs,lr)*rhoinv(mgs)*crfrzmx
 !          qwcnr(mgs) = cx(mgs,lr) - crfrzmx
 !        ELSE
         IF ( lzr < 1 ) THEN
           IF ( imurain == 3 ) THEN
             bfnu = bfnu0
           ELSE !imurain == 1
             bfnu = bfnu1
           ENDIF
         ELSE
 !         bfnu = 1.0 ! (alpha(mgs,lr)+2.0)/(alpha(mgs,lr)+1.)
           IF ( imurain == 3 ) THEN
             bfnu = (alpha(mgs,lr)+2.0)/(alpha(mgs,lr)+1.)
           ELSE !imurain == 1
!             bfnu = bfnu1
            bfnu = (4. + alpha(mgs,lr))*(5. + alpha(mgs,lr))*(6. + alpha(mgs,lr))/  &
     &            ((1. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(3. + alpha(mgs,lr)))
!            bfnu = 1.
           ENDIF
         ENDIF 
         qrfrz(mgs) = bfnu*xmas(mgs,lr)*rhoinv(mgs)*crfrz(mgs)

         qrfrz(mgs) = Min( qrfrz(mgs), 1.*qx(mgs,lr)*dtpinv ) ! qxmxd(mgs,lr) 
         crfrz(mgs) = Min( crfrz(mgs), 1.*cx(mgs,lr)*dtpinv ) !cxmxd(mgs,lr) 
         qrfrz(mgs) = Min( qrfrz(mgs), qx(mgs,lr) )
         qrfrzf(mgs) = qrfrz(mgs)
         ENDIF !}

         
         
         
         IF ( crfrz(mgs) .gt. qxmin(lh) ) THEN !{ Yes, it compares cx and qxmin, but this is just to be sure that 
                                                  ! crfrz is greater than zero in the division
!          IF ( xdia(mgs,lr,1) .lt. 200.e-6 ) THEN
!           IF ( xv(mgs,lr) .lt. xvmn(lh) ) THEN
           
           IF ( (ibiggsnow == 1 .or. ibiggsnow == 3 ) .and. ibiggopt /= 2 ) THEN
           xvfrz = rho0(mgs)*qrfrz(mgs)/(crfrz(mgs)*900.) ! mean volume of frozen drops; 900. for frozen drop density
           frach = 0.5 *(1. +  Tanh(0.2e12 *( xvfrz - 1.15*xvmn(lh))))

             qrfrzs(mgs) = (1.-frach)*qrfrz(mgs)
             crfrzs(mgs) = (1.-frach)*crfrz(mgs) ! *rzxh(mgs)
!             qrfrzf(mgs) = frach*qrfrz(mgs)
           
           ENDIF
           
           IF ( ipconc .ge. 14 .and. 1.e-3*rho0(mgs)*qrfrz(mgs)/crfrz(mgs) .lt. xvmn(lh) ) THEN
             qrfrzs(mgs) = qrfrz(mgs)
             crfrzs(mgs) = crfrz(mgs) ! *rzxh(mgs)
           ELSE
!           crfrz(mgs) = Min( crfrz(mgs), 0.1*cx(mgs,lr)*dtpinv ) ! cxmxd(mgs,lr) 
!           qrfrz(mgs) = Min( qrfrz(mgs), 0.1*qx(mgs,lr)*dtpinv ) ! qxmxd(mgs,lr) 
             qrfrzf(mgs) = frach*qrfrz(mgs)
!             crfrzf(mgs) = Min( qrfrz(mgs)*rho0(mgs)/(xdn(mgs,lh)*vgra), crfrz(mgs) )
            IF ( ibfr .le. 1 ) THEN
             crfrzf(mgs) = frach*Min(crfrz(mgs), qrfrz(mgs)/(bfnu*1.0*vr1mm*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs)
            ELSEIF ( ibfr .eq. 5 ) THEN
             crfrzf(mgs) = frach*Min(crfrz(mgs), qrfrz(mgs)/(bfnu*vfrz*1000.0)*rho0(mgs) )*rzxh(mgs)  !*crfrz(mgs)
            ELSEIF ( ibfr .eq. 2 ) THEN
             crfrzf(mgs) = frach*Min(crfrz(mgs), qrfrz(mgs)/(bfnu*vfrz*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs)
            ELSEIF ( ibfr .eq. 6 ) THEN
             crfrzf(mgs) = frach*Max(crfrz(mgs), qrfrz(mgs)/(bfnu*9.*xv(mgs,lr)*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs)
            ELSE
             crfrzf(mgs) = frach*crfrz(mgs)
            ENDIF 
!             crfrzf(mgs) = Min(crfrz(mgs), qrfrz(mgs)/(bfnu*xvmn(lh)*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs)
!            IF ( lz(lr) > 1 .and. lz(lh) > 1 ) THEN
!              crfrzf(mgs) = crfrz(mgs)
!            ENDIF
            
           ENDIF
!         crfrz(mgs) = Min( cxmxd(mgs,lr), rho0(mgs)*qrfrz(mgs)/xmas(mgs,lr) )
         ELSE
          crfrz(mgs) = 0.0
          qrfrz(mgs) = 0.0
         ENDIF !}

         ENDIF ! ibiggopt

          IF ( lvol(lh) .gt. 1 ) THEN
           vrfrzf(mgs) = rho0(mgs)*qrfrzf(mgs)/rhofrz
          ENDIF

        
        IF ( nsplinter .ne. 0 ) THEN
          IF ( nsplinter .ge. 1000 ) THEN
           ! Lawson et al. 2015 JAS
           ! ave. diam of freezing drops in microns
            tmp = 0
            IF ( qrfrz(mgs)*dtp > qxmin(lh) .and. crfrz(mgs) > 1.e-3 ) THEN
              tmpdiam = 1.e6*( 6.*qrfrz(mgs)/(1000.*pi*crfrz(mgs) ))**(1./3.)  ! avg. diameter of newly frozen drops in microns
              tmp = lawson_splinter_fac*tmpdiam**4*crfrz(mgs)
            ENDIF
          ELSEIF ( nsplinter .gt. 0 ) THEN
            tmp = nsplinter*crfrz(mgs)
          ELSE
            tmp = -nsplinter*crfrzf(mgs)
          ENDIF
          csplinter2(mgs) = tmp
          qsplinter2(mgs) = Min(0.1*qrfrz(mgs), tmp*splintermass/rho0(mgs) ) ! makes splinters smaller if too much mass is taken from graupel

!          csplinter(mgs) = csplinter(mgs) + tmp
!          qsplinter(mgs) = qsplinter(mgs) + Min(0.1*qrfrz(mgs), tmp*splintermass/rho0(mgs) ) ! makes splinters smaller if too much mass is taken from graupel
        ENDIF
!         IF ( temcg(mgs) .lt. -31.0 ) THEN
!           qrfrz(mgs) = qx(mgs,lr)*dtpinv + qrcnw(mgs)
!           qrfrzf(mgs) = qrfrz(mgs)
!           crfrz(mgs) = cx(mgs,lr)*dtpinv + crcnw(mgs)
!           crfrzf(mgs) = Min(crfrz(mgs), qrfrz(mgs)/(bfnu*1.0*vr1mm*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs)
!         ENDIF
!         qrfrz(mgs) = 6.0*xdn(mgs,lr)*xv(mgs,lr)**2*tmp*rhoinv(mgs)
!         qrfrz(mgs) = Min( qrfrz(mgs), ffrz*qrmxd(mgs) )
!         crfrz(mgs) = Min( crmxd(mgs), ffrz*crfrz(mgs))
!         crfrz(mgs) = Min(crmxd(mgs),qrfrz(mgs)*rho0(mgs)/xmas(mgs,lr))
       ENDIF
!      if ( temg(mgs) .gt. 268.15 ) then
      else
!      end if
      end if
      end do
      
      ENDIF
!
!  Homogeneous freezing of cloud drops to ice crystals
!  following Bigg (1953) and Ferrier (1994).
!
      if (ndebug .gt. 0 ) write(0,*) 'conc 25b'
      do mgs = 1,ngscnt
      qwfrz(mgs) = 0.0
      cwfrz(mgs) = 0.0
      qwfrzc(mgs) = 0.0
      cwfrzc(mgs) = 0.0
      qwfrzp(mgs) = 0.0
      cwfrzp(mgs) = 0.0
      IF ( ibfc .ge. 1 .and. ibfc /= 3 .and. temg(mgs) < 268.15 ) THEN
!      if ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 1.  .and.   &
!     &     .not. (ipconc .ge. 2 .and. xdia(mgs,lc,1) .lt. 10.e-6) ) then
      if ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. cxmin ) THEN
      IF ( ipconc < 2 ) THEN
      qwfrz(mgs) = ((2.0)*(brz)/(xdn(mgs,lc)*cx(mgs,lc)))   &
     &  *(exp(max(-arz*temcg(mgs), 0.0))-1.0)   &
     &  *rho0(mgs)*(qx(mgs,lc)**2)
      qwfrz(mgs) = max(qwfrz(mgs), 0.0)
      qwfrz(mgs) = min(qwfrz(mgs),qcmxd(mgs))
         cwfrz(mgs) = qwfrz(mgs)*rho0(mgs)/xmas(mgs,li)
       ELSEIF ( ipconc .ge. 2 ) THEN
         IF ( xdia(mgs,lc,3) > 0.e-6 ) THEN
          volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 !  Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 
                                               ! for mean temperature for freezing: -ln (V) = a*Ts - b
                                               ! volt is given in cm**3, so factor of 1.e-6 to convert to m**3
!           dbigg = (6./pi* volt )**(1./3.) 

         IF (  alpha(mgs,lc) == 0.0 ) THEN
         cwfrz(mgs) = cx(mgs,lc)*Exp(-volt/xv(mgs,lc))*dtpinv ! number of droplets with volume greater than volt
!turn off limit so that all can freeze at low temp
!!!       cwfrz(mgs) = Min(cwfrz(mgs),ccmxd(mgs))

         qwfrz(mgs) = cwfrz(mgs)*xdn0(lc)*rhoinv(mgs)*(volt + xv(mgs,lc))
          ELSE
            ratio = (1. + alpha(mgs,lc))*volt/xv(mgs,lc)
            
            IF ( .false. .and. usegamxinfcnu ) THEN
              i = Nint(dgami*(1. + alpha(mgs,lc)))
              gcnup1 = gmoi(i)
              i = Nint(dgami*(2. + alpha(mgs,lc)))
              gcnup2 = gmoi(i)

              cwfrz(mgs) = cx(mgs,lc)*Gamxinf(1.+alpha(mgs,lc), ratio)/(dtp*gcnup1) ! gamxinflu(i,j,1,1)

              qwfrz(mgs) = cx(mgs,lc)*xdn0(lc)*xv(mgs,lc)*rhoinv(mgs)*Gamxinf(2.+alpha(mgs,lc), ratio)/(dtp*gcnup2) !  gamxinflu(i,j,12,1)
            
            ELSE
            
              ratio = Min( maxratiolu, ratio )
!              write(0,*) 'cwfrz: temp,ratio = ',temcg(mgs),ratio
!              write(0,*) 'cwfrz: xv,volt,qx = ',xv(mgs,lc),volt,qx(mgs,lc)
!              write(0,*) 'cwfrz: i,j,k = ',igs(mgs),jgs,kgs(mgs)
              tmp = gaminterp(ratio,alpha(mgs,lc),1,1)
!              write(0,*) 'cwfrz: tmp1 = ',tmp
              cwfrz(mgs) = cx(mgs,lc)*tmp*dtpinv ! Gamxinf(1.+alpha(mgs,lc), ratio)/(dtp*gcnup1) ! gamxinflu(i,j,1,1)

              tmp = gaminterp(ratio,alpha(mgs,lc),12,1)
!              write(0,*) 'cwfrz: tmp2 = ',tmp
              qwfrz(mgs) = cx(mgs,lc)*xdn0(lc)*xv(mgs,lc)*rhoinv(mgs)*dtpinv*tmp ! Gamxinf(2.+alpha(mgs,lc), ratio)/(dtp*gcnup2) !  gamxinflu(i,j,12,1)
            
            ENDIF
          
          ENDIF

         ENDIF
       ENDIF
      if ( temg(mgs) .gt. 268.15 ) then
      qwfrz(mgs) = 0.0
      cwfrz(mgs) = 0.0
      end if
      end if
      ENDIF
!
        if ( xplate(mgs) .eq. 1 ) then
          qwfrzp(mgs) = qwfrz(mgs)
          cwfrzp(mgs) = cwfrz(mgs)
        end if
!  
        if ( xcolmn(mgs) .eq. 1 ) then
          qwfrzc(mgs) = qwfrz(mgs)
          cwfrzc(mgs) = cwfrz(mgs)
        end if
      
!
!     qwfrzp(mgs) = 0.0
!     qwfrzc(mgs) = qwfrz(mgs)
!
      end do
!
!
!  Contact freezing nucleation:  factor is to convert from L-1
!  T < -2C:  via Meyers et al. JAM July, 1992 (31, 708-721)
!
      if (ndebug .gt. 0 ) write(0,*) 'conc 25a'
      do mgs = 1,ngscnt

       ccia(mgs) = 0.0

       cwctfz(mgs) = 0.0
       qwctfz(mgs) = 0.0
       ctfzbd(mgs) = 0.0
       ctfzth(mgs) = 0.0
       ctfzdi(mgs) = 0.0

       cwctfzc(mgs) = 0.0
       qwctfzc(mgs) = 0.0
       cwctfzp(mgs) = 0.0
       qwctfzp(mgs) = 0.0
       IF ( icfn .ge. 1 ) THEN

       IF ( temg(mgs) .lt. 271.15  .and. qx(mgs,lc) .gt. qxmin(lc)) THEN

!       find available # of ice nuclei & limit value to max depletion of cloud water

        IF ( icfn .ge. 2 ) THEN
         ccia(mgs) = exp( 4.11 - (0.262)*temcg(mgs) )  ! in m-3, see Walko et al. 1995; 1000*exp(-2.8 -b*t) = exp(6.91)*exp(-2.8 - b*t) = exp(4.11 -b*t)
         !ccia(mgs) = Min(cwctfz(mgs), ccmxd(mgs) )

!       now find how many of these collect cloud water to form IN
!       Cotton et al 1986

         knud(mgs) = 2.28e-5 * temg(mgs) / ( pres(mgs)*raero ) !Walko et al. 1995
         knuda(mgs) = 1.257 + 0.4*exp(-1.1/knud(mgs))          !Pruppacher & Klett 1997 eqn 11-16
         gtp(mgs) = 1. / ( fai(mgs) + fbi(mgs) )               !Byers 65 / Cotton 72b
         dfar(mgs) = kb*temg(mgs)*(1.+knuda(mgs)*knud(mgs))/(6.*pi*fadvisc(mgs)*raero) !P&K 1997 eqn 11-15
         fn1(mgs) = 2.*pi*xdia(mgs,lc,1)*cx(mgs,lc)*ccia(mgs)
         fn2(mgs) = -gtp(mgs)*(ssw(mgs)-1.)*felv(mgs)/pres(mgs)
         fnft(mgs) = 0.4*(1.+1.45*knud(mgs)+0.4*knud(mgs)*exp(-1./knud(mgs)))*(ftka(mgs)+2.5*knud(mgs)*kaero)      &
     &              / ( (1.+3.*knud(mgs))*(2*ftka(mgs)+5.*knud(mgs)*kaero+kaero) )


!      Brownian diffusion
         ctfzbd(mgs) = fn1(mgs)*dfar(mgs)

!      Thermophoretic contact nucleation
         ctfzth(mgs) = fn1(mgs)*fn2(mgs)*fnft(mgs)/rho0(mgs)

!      Diffusiophoretic contact nucleation
         ctfzdi(mgs) = fn1(mgs)*fn2(mgs)*rw*temg(mgs)/(felv(mgs)*rho0(mgs))

         cwctfz(mgs) = max( ctfzbd(mgs) + ctfzth(mgs) + ctfzdi(mgs) , 0.)

!      Sum of the contact nucleation processes
!         IF ( cx(mgs,lc) .gt. 1.e6) write(0,*) 'ctfzbd,etc = ',cwctfz(mgs),ctfzbd(mgs),ctfzth(mgs),ctfzdi(mgs)
!         IF ( wvel(mgs) .lt. -0.05 ) write(6,*) 'ctfzbd,etc = ',ctfzbd(mgs),ctfzth(mgs),ctfzdi(mgs),cx(mgs,lc)*1e-6,wvel(mgs)
!         IF ( ssw(mgs) .lt. 1.0 .and. cx(mgs,lc) .gt. 1.e6 .and. cwctfz(mgs) .gt. 1. ) THEN
!          write(6,*) 'ctfzbd,etc = ',ctfzbd(mgs),ctfzth(mgs),ctfzdi(mgs),cx(mgs,lc)*1e-6,wvel(mgs),fn1(mgs),fn2(mgs)
!          write(6,*) 'more = ',nstep,ssw(mgs),dfar(mgs),gtp(mgs),felv(mgs),pres(mgs)
!         ENDIF

        ELSEIF ( icfn .eq. 1 ) THEN
         IF ( wvel(mgs) .lt. -0.05 ) THEN ! older kludgy version
           cwctfz(mgs) = cfnfac*exp( (-2.80) - (0.262)*temcg(mgs) )
           cwctfz(mgs) = Min((1.0e3)*cwctfz(mgs), ccmxd(mgs) )  !convert to m-3
         ENDIF
        ENDIF   ! icfn

        IF ( ipconc .ge. 2 ) THEN
         cwctfz(mgs) = Min( cwctfz(mgs)*dtpinv, ccmxd(mgs) )
         qwctfz(mgs) = xmas(mgs,lc)*cwctfz(mgs)/rho0(mgs)
        ELSE
         qwctfz(mgs) = (cimasn)*cwctfz(mgs)/(dtp*rho0(mgs))
         qwctfz(mgs) = max(qwctfz(mgs), 0.0)
         qwctfz(mgs) = min(qwctfz(mgs),qcmxd(mgs))
        ENDIF

!
        if ( xplate(mgs) .eq. 1 ) then
         qwctfzp(mgs) = qwctfz(mgs)
         cwctfzp(mgs) = cwctfz(mgs)
        end if
!
        if ( xcolmn(mgs) .eq. 1 ) then
         qwctfzc(mgs) = qwctfz(mgs)
         cwctfzc(mgs) = cwctfz(mgs)
        end if
        
!        IF ( cwctfz(mgs)*dtp > 0.5 .and. dtp*qwctfz(mgs) > qxmin(li) ) THEN
!          write(91,*) 'cwctfz: ',cwctfz(mgs),qwctfz(mgs) ! ,cwctfzc(mgs),qwctfzc(mgs)
!        ENDIF
       
!
!     qwctfzc(mgs) = qwctfz(mgs)
!     qwctfzp(mgs) = 0.0
!
       end if

       ENDIF ! icfn

      end do
!
!
!
! Hobbs-Rangno ice enhancement (Ferrier, 1994)
!
      if (ndebug .gt. 0 ) write(0,*) 'conc 23a'
      dthr = 300.0
      hrifac = (1.e-3)*((0.044)*(0.01**3))
      do mgs = 1,ngscnt
      ciihr(mgs) = 0.0
      qiihr(mgs) = 0.0
      cicichr(mgs) = 0.0
      qicichr(mgs) = 0.0
      cipiphr(mgs) = 0.0
      qipiphr(mgs) = 0.0
      IF ( ihrn .ge. 1 ) THEN
      if ( qx(mgs,lc) .gt. qxmin(lc) ) then
      if ( temg(mgs) .lt. 273.15 ) then
!      write(iunit,'(3(1x,i3),3(1x,1pe12.5))')
!     : igs(mgs),jgs,kgs(mgs),cx(mgs,lc),rho0(mgs),qx(mgs,lc)
!      write(iunit,'(1pe15.6)')
!     :  log(cx(mgs,lc)*(1.e-6)/(3.0)),
!     :  ((1.e-3)*rho0(mgs)*qx(mgs,lc)),
!     :  (cx(mgs,lc)*(1.e-6)),
!     : ((1.e-3)*rho0(mgs)*qx(mgs,lc))/(cx(mgs,lc)*(1.e-6)),
!     : (alog(cx(mgs,lc)*(1.e-6)/(3.0)) *
!     >  ((1.e-3)*rho0(mgs)*qx(mgs,lc))/(cx(mgs,lc)*(1.e-6)))

      IF ( Log(cx(mgs,lc)*(1.e-6)/(3.0)) .gt. 0.0 ) THEN
      ciihr(mgs) = ((1.69e17)/dthr)   &
     & *(log(cx(mgs,lc)*(1.e-6)/(3.0)) *   &
     &  ((1.e-3)*rho0(mgs)*qx(mgs,lc))/(cx(mgs,lc)*(1.e-6)))**(7./3.)
      ciihr(mgs) = ciihr(mgs)*(1.0e6)
      qiihr(mgs) = hrifac*ciihr(mgs)/rho0(mgs)
      qiihr(mgs) = max(qiihr(mgs), 0.0)
      qiihr(mgs) = min(qiihr(mgs),qcmxd(mgs))
      ENDIF
!
      if ( xplate(mgs) .eq. 1 ) then
      qipiphr(mgs) = qiihr(mgs)
      cipiphr(mgs) = ciihr(mgs)
      end if
!
      if ( xcolmn(mgs) .eq. 1 ) then
      qicichr(mgs) = qiihr(mgs)
      cicichr(mgs) = ciihr(mgs)
      end if
!
!     qipiphr(mgs) = 0.0
!     qicichr(mgs) = qiihr(mgs)
!
      end if
      end if
      ENDIF ! ihrn
      end do
!
!
!
!  simple frozen rain to hail conversion.  All of the
!  frozen rain larger than 5.0e-3 m in diameter are converted
!  to hail.  This is done by considering the equation for
!  frozen rain mixing ratio:
!
!
!  qfw = [ cno(lf) * pi * fwdn / (6 rhoair) ]
!
!         /inf
!      *  |     fwdia*3 exp(-dia/fwdia) d(dia)
!         /Do
!
!  The amount to be reclassified as hail is the integral above from
!  Do to inf where Do is 5.0e-3 m.
!
!
!  qfauh = [ cno(lf) * pi * fwdn / (6 rhoair) ]
!
!


      hdia0 = 300.0e-6
      do mgs = 1,ngscnt
      qscnvi(mgs) = 0.0
      cscnvi(mgs) = 0.0
      cscnvis(mgs) = 0.0
!      IF ( .false. ) THEN
!      IF ( temg(mgs) .lt. tfr .and. ssi(mgs) .gt. 1.01 .and. qx(mgs,li) .gt. qxmin(li) ) THEN
      IF ( temg(mgs) .lt. tfr .and. qx(mgs,li) .gt. qxmin(li) ) THEN
        IF ( ipconc .ge. 4 .and. .false. ) THEN
         if ( cx(mgs,li) .gt. 10. .and. xdia(mgs,li,1) .gt. 50.e-6 ) then !{
         cirdiatmp =   &
     &  (qx(mgs,li)*rho0(mgs)   &
     & /(pi*xdn(mgs,li)*cx(mgs,li)))**(1./3.)
          IF ( cirdiatmp .gt. 100.e-6 ) THEN !{
          qscnvi(mgs) =   &
     &  ((pi*xdn(mgs,li)*cx(mgs,li)) / (6.0*rho0(mgs)*dtp))   &
     & *exp(-hdia0/cirdiatmp)   &
     & *( (hdia0**3) + 3.0*(hdia0**2)*cirdiatmp   &
     &  + 6.0*(hdia0)*(cirdiatmp**2) + 6.0*(cirdiatmp**3) )
      qscnvi(mgs) =   &
     &  min(qscnvi(mgs),qimxd(mgs))
          IF ( ipconc .ge. 4 ) THEN
            cscnvi(mgs) = Min( cimxd(mgs), cx(mgs,li)*Exp(-hdia0/cirdiatmp))
          ENDIF
         ENDIF  ! }
        end if ! }

       ELSEIF ( ipconc .lt. 4 ) THEN

        qscnvi(mgs) = 0.001*eii(mgs)*max((qx(mgs,li)-1.e-3),0.0)
        qscnvi(mgs) = min(qscnvi(mgs),qxmxd(mgs,li))
        cscnvi(mgs) = qscnvi(mgs)*rho0(mgs)/xmas(mgs,li)
        cscnvis(mgs) = 0.5*cscnvi(mgs)

       ENDIF
      ENDIF
!      ENDIF
      end do



!
!  Ventilation coeficients
!
      do mgs = 1,ngscnt
      fvent(mgs) = (fschm(mgs)**(1./3.)) * (fakvisc(mgs)**(-0.5))
      end do
!
!
      if ( ndebug .gt. 0 ) write(0,*) 'civent'
!
      civenta = 1.258e4
      civentb = 2.331
      civentc = 5.662e4
      civentd = 2.373
      civente = 0.8241
      civentf = -0.042
      civentg = 1.70

      do mgs = 1,ngscnt
      IF ( icond .eq. 1 .or. temg(mgs) .le. tfrh    &
     &      .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN
      IF ( qx(mgs,li) .gt. qxmin(li) ) THEN
      cireyn =   &
     &  (civenta*xdia(mgs,li,1)**civentb   &
     &  +civentc*xdia(mgs,li,1)**civentd)   &
     &  /   &
     &  (civente*xdia(mgs,li,1)**civentf+civentg)
      xcivent = (fschm(mgs)**(1./3.))*((cireyn/fakvisc(mgs))**0.5)
      if ( xcivent .lt. 1.0 ) then
      civent(mgs) = 1.0 + 0.14*xcivent**2
      end if
      if ( xcivent .ge. 1.0 ) then
      civent(mgs) = 0.86 + 0.28*xcivent
      end if
      ELSE
       civent(mgs) = 0.0
      ENDIF


      ENDIF ! icond .eq. 1
      end do

!
!
      igmrwa = 100.0*2.0
      igmrwb = 100.*((5.0+br)/2.0)
      rwventa = (0.78)*gmoi(igmrwa)  ! 0.78
      rwventb = (0.308)*gmoi(igmrwb) ! 0.562825
      do mgs = 1,ngscnt
      IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN
        IF ( ipconc .ge. 3 ) THEN
          IF ( imurain == 3 ) THEN
           IF ( izwisventr == 1 ) THEN
            rwvent(mgs) = ventrx(mgs)*(1.6 + 124.9*(1.e-3*rho0(mgs)*qx(mgs,lr))**.2046)
           ELSE ! izwisventr = 2
!  Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br
          rwvent(mgs) =   &
     &  (0.78*ventrx(mgs) + 0.308*ventrxn(mgs)*fvent(mgs)   &
     &   *Sqrt((ar*rhovt(mgs)))   &
     &    *(xdia(mgs,lr,1)**((1.0+br)/2.0)) )
           ENDIF

          ELSE ! imurain == 1
       ! linear interpolation of complete gamma function
!        tmp = 2. + alpha(mgs,lr)
!        i = Int(dgami*(tmp))
!        del = tmp - dgam*i
!        x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami

        IF ( iferwisventr == 1 ) THEN

  ! Ferrier fall speed in the ventillation term [uses fx(lr) ]
  
        alpr = Min(alpharmax,alpha(mgs,lr) )

        x =  1. + alpha(mgs,lr)

        IF ( lzr > 1 ) THEN ! 3 moment
! 
        ELSE
         y = ventrxn(mgs)
        ENDIF

!         vent1 = dble(xdia(mgs,lr,1))**(-2. - alpr) ! Actually OK
!         vent2 = dble(1./xdia(mgs,lr,1) + 0.5*fx(lr))**dble(2.5+alpr+0.5*bx(lr))  ! Actually OK
         vent1 = dble(xdia(mgs,lr,1))**(0.5 + 0.5*bx(lr)) ! 2016.2.26 Changed for consistency with derivation (recast formula -- should be equivalent)
         vent2 = dble(1. + 0.5*fx(lr)*xdia(mgs,lr,1))**dble(2.5+alpr+0.5*bx(lr))
        
        
        rwvent(mgs) =    &
     &    0.78*x +    &
     &    0.308*fvent(mgs)*y*   &
     &            Sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2)
       

        ELSEIF ( iferwisventr == 2 ) THEN
          
!  Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br
         x =  1. + alpha(mgs,lr)

           rwvent(mgs) =   &
     &  (0.78*x + 0.308*ventrxn(mgs)*fvent(mgs)   &
     &   *Sqrt((ar*rhovt(mgs)))   &
     &    *(xdia(mgs,lr,1)**((1.0+br)/2.0)) )


          
          ENDIF ! iferwisventr
          
          ENDIF ! imurain
        ELSE
         rwvent(mgs) =   &
     &  (rwventa + rwventb*fvent(mgs)   &
     &   *Sqrt((ar*rhovt(mgs)))   &
     &    *(xdia(mgs,lr,1)**((1.0+br)/2.0)) )
        ENDIF
      ELSE
       rwvent(mgs) = 0.0
      ENDIF
      end do
!
      igmswa = 100.0*2.0
      igmswb = 100.*((5.0+ds)/2.0)
      swventa = (0.78)*gmoi(igmswa)
      swventb = (0.308)*gmoi(igmswb)
      do mgs = 1,ngscnt
      IF ( qx(mgs,ls) .gt. qxmin(ls) ) THEN
      IF ( ipconc .ge. 4 ) THEN
      swvent(mgs) = 0.65 + 0.44*fvent(mgs)*Sqrt(vtxbar(mgs,ls,1)*xdia(mgs,ls,1))
      ELSE
! 10-ice version:
       swvent(mgs) =   &
     &  (swventa + swventb*fvent(mgs)   &
     &   *Sqrt((cs*rhovt(mgs)))   &
     &   *(xdia(mgs,ls,1)**((1.0+ds)/2.0)) )
      ENDIF
      ELSE
      swvent(mgs) = 0.0
      ENDIF
      end do
!
!

      igmhwa = 100.0*2.0
      igmhwb = 100.0*2.75
      hwventa = (0.78)*gmoi(igmhwa)
      hwventb = (0.308)*gmoi(igmhwb)
!      hwventc = (4.0*gr/(3.0*cdx(lh)))**(0.25)
      do mgs = 1,ngscnt
      IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN
       hwventc = (4.0*gr/(3.0*cdxgs(mgs,lh)))**(0.25)
       IF ( .false. .or. alpha(mgs,lh) .eq. 0.0 ) THEN
        hwvent(mgs) =   &
     &  ( hwventa + hwventb*hwventc*fvent(mgs)   &
     &    *((xdn(mgs,lh)/rho0(mgs))**(0.25))   &
     &    *(xdia(mgs,lh,1)**(0.75)))
       ELSE ! Ferrier 1994, eq. B.36
       ! linear interpolation of complete gamma function
!        tmp = 2. + alpha(mgs,lh)
!        i = Int(dgami*(tmp))
!        del = tmp - dgam*i
!        x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
        
! note that hwvent includes a division by Gamma(1+alpha), so Gamma(2+alpha)/Gamma(1+alpha) = 1 + alpha
! and g1palp = Gamma(1+alpha) divides into y
        x =  1. + alpha(mgs,lh)

        tmp = 1 + alpha(mgs,lh)
        i = Int(dgami*(tmp))
        del = tmp - dgam*i
        g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami

        tmp = 2.5 + alpha(mgs,lh) + 0.5*bxx(mgs,lh)
        i = Int(dgami*(tmp))
        del = tmp - dgam*i
        y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp
        
        
        hwventy(mgs) = 0.308*fvent(mgs)*(xdia(mgs,lh,1)**(0.5 + 0.5*bxx(mgs,lh)))*Sqrt(axx(mgs,lh)*rhovt(mgs)) 
        hwvent(mgs) =    &
     &  ( 0.78*x +  y*hwventy(mgs) ) !   &
!     &    0.308*fvent(mgs)*y*(xdia(mgs,lh,1)**(0.5 + 0.5*bxx(mgs,lh)))*   &
!     &            Sqrt(axx(mgs,lh)*rhovt(mgs)) )
       
       ENDIF
      ELSE
      hwvent(mgs) = 0.0
      hwventy(mgs) = 0.0
      ENDIF
      end do
      

      hlvent(:) = 0.0
      hlventy(:) = 0.0

      IF ( lhl .gt. 1 ) THEN
      igmhwa = 100.0*2.0
      igmhwb = 100.0*2.75
      hwventa = (0.78)*gmoi(igmhwa)
      hwventb = (0.308)*gmoi(igmhwb)
!      hwventc = (4.0*gr/(3.0*cdx(lhl)))**(0.25)
      do mgs = 1,ngscnt
      IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN
      hwventc = (4.0*gr/(3.0*cdxgs(mgs,lhl)))**(0.25)

       IF ( .false. .or. alpha(mgs,lhl) .eq. 0.0 ) THEN
        hlvent(mgs) =   &
     &  ( hwventa + hwventb*hwventc*fvent(mgs)   &
     &    *((xdn(mgs,lhl)/rho0(mgs))**(0.25))   &
     &    *(xdia(mgs,lhl,1)**(0.75)))
       ELSE ! Ferrier 1994, eq. B.36
       ! linear interpolation of complete gamma function
!        tmp = 2. + alpha(mgs,lhl)
!        i = Int(dgami*(tmp))
!        del = tmp - dgam*i
!        x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami

! note that hlvent includes a division by Gamma(1+alpha), so x = Gamma(2+alpha)/Gamma(1+alpha) = 1 + alpha
! and g1palp = Gamma(1+alpha) divides into y

        x =  1. + alpha(mgs,lhl)

        tmp = 1 + alpha(mgs,lhl)
        i = Int(dgami*(tmp))
        del = tmp - dgam*i
        g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami

        tmp = 2.5 + alpha(mgs,lhl) + 0.5*bxx(mgs,lhl)
        i = Int(dgami*(tmp))
        del = tmp - dgam*i
        y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp ! ratio of gamma functions

        hlventy(mgs) = 0.308*fvent(mgs)*(xdia(mgs,lhl,1)**(0.5 + 0.5*bxx(mgs,lhl)))*Sqrt(axx(mgs,lhl)*rhovt(mgs)) 
        
        hlvent(mgs) =  0.78*x + y*hlventy(mgs)  !   &
!     &    0.308*fvent(mgs)*y*(xdia(mgs,lhl,1)**(0.5 + 0.5*bxx(mgs,lhl)))*   &
!     &            Sqrt(axx(mgs,lhl)*rhovt(mgs)))
!     :            Sqrt(xdn(mgs,lhl)*ax(lhl)*rhovt(mgs)/rg0))/tmp

        ENDIF
       ENDIF
      end do
      ENDIF

!
!
!
!  Wet growth constants
!
      do mgs = 1,ngscnt
      fwet1(mgs) =   &
     & (2.0*pi)*   &
     & ( felv(mgs)*fwvdf(mgs)*rho0(mgs)*(qss0(mgs)-qx(mgs,lv))   &
     &  -ftka(mgs)*temcg(mgs) )   &
     & / ( rho0(mgs)*(felf(mgs)+fcw(mgs)*temcg(mgs)) )
      fwet2(mgs) =   &
     &  (1.0)-fci(mgs)*temcg(mgs)   &
     & / ( felf(mgs)+fcw(mgs)*temcg(mgs) )
      end do
!
!  Melting constants
!
      do mgs = 1,ngscnt
      fmlt1(mgs) = (2.0*pi)*   &
     &  ( felv(mgs)*fwvdf(mgs)*(qss0(mgs)-qx(mgs,lv))   &
     &   -ftka(mgs)*temcg(mgs)/rho0(mgs) )    &
     &  / (felf(mgs))
      fmlt2(mgs) = -fcw(mgs)*temcg(mgs)/felf(mgs)
      end do
!
!  Vapor Deposition constants
!
      do mgs = 1,ngscnt
      fvds(mgs) =    &
     &  (4.0*pi/rho0(mgs))*(ssi(mgs)-1.0)*   &
     &  (1.0/(fai(mgs)+fbi(mgs)))
      end do
      do mgs = 1,ngscnt
      fvce(mgs) =    &
     &  (4.0*pi/rho0(mgs))*(ssw(mgs)-1.0)*   &
     &  (1.0/(fav(mgs)+fbv(mgs)))
      end do

!
!  deposition, sublimation, and melting of snow, graupel and hail
!
      qsmlr(:) = 0.0
      qimlr(:) = 0.0 ! this is not used. qi melts to qc way down in the code.
      qhmlr(:) = 0.0
      qhlmlr(:) = 0.0
      IF ( lhwlg > 1 ) THEN
        qhmlrlg(:) = 0.0
        qhlmlrlg(:) = 0.0
      ENDIF
      qhfzh(:) = 0.0
      qhlfzhl(:) = 0.0
      qhfzhlg(:) = 0.0
      qhlfzhllg(:) = 0.0
      vhfzh(:) = 0.0
      vffzf(:) = 0.0
      vhlfzhl(:) = 0.0
      qsfzs(:) = 0.0
      zsmlr(:) = 0.0
      zhmlr(:) = 0.0
      zhmlrr(:) = 0.0
      zhshr(:) = 0.0
      zhlmlr(:) = 0.0
      zhlshr(:) = 0.0

      zhshrr(:) = 0.0
      zhlmlrr(:) = 0.0
      zhlshrr(:) = 0.0

      csmlr(:) = 0.0
      csmlrr(:) = 0.0
      chmlr(:) = 0.0
      chmlrr(:) = 0.0
      chlmlr(:) = 0.0
!      chlmlrsave(:) = 0.0
!      qhlmlrsave(:) = 0.0
!      chlsave(:) = 0.0
!      qhlsave(:) = 0.0
      chlmlrr(:) = 0.0


      if ( .not. mixedphase ) then !{
      do mgs = 1,ngscnt
!
      IF ( temg(mgs) .gt. tfr ) THEN
      
      IF (  qx(mgs,ls) .gt. qxmin(ls) ) THEN
      qsmlr(mgs) =   &
     &   min(   &
     &  (c1sw*fmlt1(mgs)*cx(mgs,ls)*swvent(mgs)*xdia(mgs,ls,1) ) & ! /rhosm    &
     &   , 0.0 )
      ENDIF

      
!       IF ( qx(mgs,ls) .gt. 0.1e-4 ) write(0,*) 'qsmlr: ',qsmlr(mgs),qx(mgs,ls),cx(mgs,ls),fmlt1(mgs),
!     :        temcg(mgs),swvent(mgs),xdia(mgs,ls,1),qss0(mgs)-qx(mgs,lv)
!      ELSE
!       qsmlr(mgs) = 0.0
!      ENDIF
! 10ice version:
!     >   min(
!     >  (fmlt1(mgs)*cx(mgs,ls)*swvent(mgs)*xdia(mgs,ls,1) +
!     >   fmlt2(mgs)*(qsacr(mgs)+qsacw(mgs)) )
!     <   , 0.0 )

      IF (  qx(mgs,lh) .gt. qxmin(lh) ) THEN

      IF ( ibinhmlr == 0 .or. lzh < 1 ) THEN
       qhmlr(mgs) =   &
     &   meltfac*min(   &
     &  fmlt1(mgs)*cx(mgs,lh)*hwvent(mgs)*xdia(mgs,lh,1)   &
     &  + fmlt2(mgs)*(qhacrmlr(mgs)+qhacw(mgs))    &
     &   , 0.0 )
       ELSEIF ( ibinhmlr == 1 ) THEN ! use incomplete gamma functions to approximate the bin results

         write(0,*) 'ibinhmlr = 1 not available for 2-moment'
         STOP
         
       ELSEIF ( ibinhmlr == 2 .or. ibinhmlr == 3 ) THEN

       ENDIF
       
       
       IF ( ivhmltsoak > 0 .and. qhmlr(mgs) < 0.0 .and. lvol(lh) > 1 .and. xdn(mgs,lh) .lt. xdnmx(lh) ) THEN
         ! act as if 100% of the meltwater were soaked into the graupel
           v1 = (1. - xdn(mgs,lh)/xdnmx(lh))*(vx(mgs,lh) + rho0(mgs)*qhmlr(mgs)/xdn(mgs,lh) )/(dtp) ! volume available for filling
           v2 = -1.0*rho0(mgs)*qhmlr(mgs)/xdnmx(lh)  ! volume of melted ice if it were refrozen in the matrix
           
           vhsoak(mgs) = Min(v1,v2)
           
       ENDIF

      ENDIF !  qx(mgs,lh) .gt. qxmin(lh)

      
      IF ( lhl .gt. 1  .and. lhlw < 1 ) THEN

       IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN
         IF ( ibinhlmlr == 0  .or. lzhl < 1) THEN
       qhlmlr(mgs) =   &
     &   meltfac*min(   &
     &  fmlt1(mgs)*cx(mgs,lhl)*hlvent(mgs)*xdia(mgs,lhl,1)   &
     &  + fmlt2(mgs)*(qhlacrmlr(mgs)+qhlacw(mgs))    &
     &   , 0.0 )

       ELSEIF ( ibinhlmlr == 1 ) THEN ! use incomplete gamma functions to approximate the bin results

! #ifdef Z3MOM
! #if (defined Z3MOM) && defined( COMMAS ) || defined( COMMASTMP )

       ELSEIF ( ibinhlmlr == -1 ) THEN ! OLD VERSION use incomplete gamma functions to approximate the bin results

        ENDIF ! ibinhlmlr


       IF ( ivhmltsoak > 0 .and.  qhlmlr(mgs) < 0.0 .and. lvol(lhl) > 1 .and. xdn(mgs,lhl) .lt. xdnmx(lhl) ) THEN
         ! act as if 50% of the meltwater were soaked into the graupel
           v1 = (1. - xdn(mgs,lhl)/xdnmx(lhl))*(vx(mgs,lhl) + rho0(mgs)*qhlmlr(mgs)/xdn(mgs,lhl) )/(dtp) ! volume available for filling
           v2 = -1.0*rho0(mgs)*qhlmlr(mgs)/xdnmx(lhl)  ! volume of melted ice if it were refrozen in the matrix
           
           vhlsoak(mgs) = Min(v1,v2)
           
       ENDIF
        
        ENDIF
       ENDIF

      ENDIF
      
!
!      qimlr(mgs)  = max( qimlr(mgs), -qimxd(mgs) ) 
!      qsmlr(mgs)  = max( qsmlr(mgs),  -qsmxd(mgs) ) 
! erm 5/10/2007 changed to next line:
      if ( .not. mixedphase ) qsmlr(mgs)  = max( qsmlr(mgs),  Min( -qsmxd(mgs), -0.7*qx(mgs,ls)*dtpinv ) ) 
      IF ( .not. mixedphase ) THEN
        qhmlr(mgs)  = max( qhmlr(mgs),  Min( -qhmxd(mgs), -0.95*qx(mgs,lh)*dtpinv ) ) 
        chmlr(mgs)  = max( chmlr(mgs),  Min( -chmxd(mgs), -0.95*cx(mgs,lh)*dtpinv ) ) 
      ENDIF
!      qhmlr(mgs)  = max( max( qhmlr(mgs),  -qhmxd(mgs) ) , -0.5*qx(mgs,lh)*dtpinv ) !limits to 1/2 qh or max depletion
      qhmlh(mgs)  = 0.


      ! Rasmussen and Heymsfield say melt water remains on graupel up to 9 mm before shedding


      IF ( lhl .gt. 1 .and. lhlw < 1 ) THEN
        qhlmlr(mgs)  = max( qhlmlr(mgs),  Min( -qxmxd(mgs,lhl), -0.95*qx(mgs,lhl)*dtpinv ) )
        chlmlr(mgs)  = max( chlmlr(mgs),  Min( -cxmxd(mgs,lhl), -0.95*cx(mgs,lhl)*dtpinv ) )
      ENDIF

!
      end do

      endif  ! } not mixedphase
!
      if ( ipconc .ge. 1 ) then
      do mgs = 1,ngscnt
      cimlr(mgs)  = (cx(mgs,li)/(qx(mgs,li)+1.e-20))*qimlr(mgs)
      IF ( .not. mixedphase ) THEN !{
        IF ( xdia(mgs,ls,1) .gt. 1.e-6 .and. -qsmlr(mgs) .ge. 0.5*qxmin(ls) .and. ipconc .ge. 4 ) THEN 
!         csmlr(mgs)  = rho0(mgs)*qsmlr(mgs)/(xv(mgs,ls)*rhosm)
         csmlr(mgs)  = (cx(mgs,ls)/(qx(mgs,ls)))*qsmlr(mgs)
        ELSEIF ( qx(mgs,ls) > qxmin(ls) ) THEN
         csmlr(mgs)  = (cx(mgs,ls)/(qx(mgs,ls)))*qsmlr(mgs)
        ENDIF
        
        csmlrr(mgs) = csmlr(mgs)/rzxs(mgs)
         IF ( -csmlrr(mgs)*dtp > cxmin .and. -qsmlr(mgs)*dtp > qxmin(lr) .and. snowmeltdia > 0.0 ) THEN
           rmas = rho0(mgs)*qsmlr(mgs)/csmlrr(mgs)
           IF ( rmas > snowmeltmass ) THEN
             csmlrr(mgs) = rho0(mgs)*qsmlr(mgs)/snowmeltmass
           ENDIF
         ENDIF
           


!        IF ( xdia(mgs,lh,1) .gt. 1.e-6 .and. Abs(qhmlr(mgs)) .ge. qxmin(lh) ) THEN
!          chmlr(mgs) = rho0(mgs)*qhmlr(mgs)/(pi*xdn(mgs,lh)*xdia(mgs,lh,1)**3)  ! out of hail
!          chmlr(mgs) = Max( chmlr(mgs), -chmxd(mgs) )
!        ELSE
         IF ( ibinhmlr == 0 .or. lzh < 1 ) THEN
           chmlr(mgs)  = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhmlr(mgs)
           IF ( imltshddmr == 3 .and. qhmlr(mgs) < -qxmin(lh) ) THEN
            !  tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1)
            !  
            !  IF ( tmpdiam > sheddiam ) THEN ! let size get smaller until it reaches sheddiam
            !   chmlr(mgs) = 0.0
            !  ENDIF
            
            ! test to remove the part of the melting associated with large ice particles so they get smaller

            tmp = 1. + alpha(mgs,lh)
            i = Int(dgami*(tmp))
            del = tmp - dgam*i
            g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami

            ratio = Min( maxratiolu,  mltdiam1/xdia(mgs,lh,1) )

            x =  gamxinfdp(2. + alpha(mgs,lh), ratio)/g1palp
            y =  gamxinfdp(2.5 + alpha(mgs,lh) + 0.5*bxx(mgs,lh), ratio)/g1palp

            hwvent1 =  0.78*x + y*hwventy(mgs) 

            qhlmlr1 = min( fmlt1(mgs)*cx(mgs,lh)*hwvent1*xdia(mgs,lh,1), 0.0 )

            chmlr(mgs)  = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*(qhmlr(mgs) - qhlmlr1)
           
           
           ENDIF
!           IF ( igs(mgs) == 40 ) THEN
!             write(0,*) 'is this running? chmlr = ',kgs(mgs), chmlr(mgs)
!           ENDIF
         ENDIF
!        ENDIF



     IF ( chmlr(mgs) < 0.0 .and. (ibinhmlr < 1 .or. lzh < 1) ) THEN ! { already done if ibinhmlr > 0
      
      IF ( ibinhmlr == 0 .or. lzh < 1 ) THEN
      IF ( ihmlt .eq. 1 ) THEN
        chmlrr(mgs)  = Min( chmlr(mgs), rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*vmlt) ) ! into rain 
      ELSEIF ( ihmlt .eq. 2 ) THEN
        IF ( xv(mgs,lh) .gt. 0.0 .and. chmlr(mgs) .lt. 0.0 ) THEN
!        chmlrr(mgs) = Min( chmlr(mgs), rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lh)*xv(mgs,lh)) ) ! into rain 
! guess what, this is the same as chmlr: rho0*qhmlr/xmas(lh) --> cx/qx = rho0/xmas
          IF(imltshddmr == 1) THEN
            ! DTD: If Dmg < sheddiam, then assume complete melting into
            ! maximal raindrop.  Between sheddiam and sheddiam0 mm, linearly ramp down to a 3 mm shed drop
            tmp = -rho0(mgs)*qhmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lh)*xv(mgs,lh))) ! Min of Maximum raindrop size/mean hail size
            tmp2 = -rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*vr3mm) ! conc. change for a 3 mm mean drop diameter
            
            chmlrr(mgs) = tmp*(sheddiam0-xdia(mgs,lh,3))/(sheddiam0-sheddiam)+tmp2*(xdia(mgs,lh,3)-sheddiam)/(sheddiam0-sheddiam)  ! old version
            chmlrr(mgs) = -Max(tmp,Min(tmp2,chmlrr(mgs)))
          ELSEIF ( imltshddmr == 2 .or. imltshddmr == 3 ) THEN
            ! 8/26/2015 ERM updated to use shedalp and tmpdiam
            ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1)
            chmlrr(mgs) =  rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lh))  ! into rain 
          ELSE ! Old method
            chmlrr(mgs) =  rho0(mgs)*qhmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lh)*xv(mgs,lh)))  ! into rain 
         ENDIF
        ELSE
        chmlrr(mgs) = chmlr(mgs)
        ENDIF
      ELSEIF ( ihmlt .eq. 0 ) THEN
        chmlrr(mgs) = chmlr(mgs)
      ENDIF

      ELSE ! ibinhmlr < 0? Already have an outer IF test for ibinhmlr < 1
        chmlrr(mgs)  = Min( chmlrr(mgs), rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*xvmx(lr)) ) ! into rain 
      ENDIF
      
      ENDIF ! } ( chmlr(mgs) < 0.0 .and. ibinhmlr < 1)

      IF ( lhl .gt. 1 .and. lhlw < 1 .and. .not. mixedphase .and. qhlmlr(mgs) < 0.0 ) THEN ! {
      
      IF ( ibinhlmlr == 0 .or. lzhl < 1 ) THEN
!      IF ( xdia(mgs,lhl,1) .gt. 1.e-6 .and. Abs(qhlmlr(mgs)) .ge. qxmin(lhl) ) THEN
!      chlmlr(mgs) = rho0(mgs)*qhlmlr(mgs)/(pi*xdn(mgs,lhl)*xdia(mgs,lhl,1)**3)  ! out of hail
!      chlmlr(mgs) = Max( chlmlr(mgs), -cxmxd(mgs,lhl) )
!      ELSE
      chlmlr(mgs)  = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlmlr(mgs)
           IF ( imltshddmr == 3 .and. qhlmlr(mgs) < -qxmin(lhl) ) THEN
!           IF ( .false. .and. imltshddmr == 3  ) THEN
!              tmpdiam = (shedalp+alpha(mgs,lhl))*xdia(mgs,lhl,1)
!              
!              IF ( tmpdiam > sheddiam ) THEN ! let size get smaller until it reaches sheddiam
!                chlmlr(mgs) = 0.0
!              ENDIF
 
            ! test to remove the part of the melting associated with large ice particles so they get smaller
!
            tmp = 1. + alpha(mgs,lhl)
            i = Int(dgami*(tmp))
            del = tmp - dgam*i
            g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami

            ratio = Min( maxratiolu,  mltdiam1/xdia(mgs,lhl,1) )

            x =  gamxinfdp(2. + alpha(mgs,lhl), ratio)/g1palp
            y =  gamxinfdp(2.5 + alpha(mgs,lhl) + 0.5*bxx(mgs,lhl), ratio)/g1palp

            hwvent1 =  0.78*x + y*hlventy(mgs) 

            qhlmlr1 = min( fmlt1(mgs)*cx(mgs,lhl)*hwvent1*xdia(mgs,lhl,1), 0.0 )

            chlmlr(mgs)  = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*Min(0.0, qhlmlr(mgs) - qhlmlr1)

            ENDIF
!      ENDIF
      ENDIF
      
      IF ( ibinhlmlr == 0 .or. lzhl < 1 ) THEN !{
      IF ( ihmlt .eq. 1 ) THEN
        chlmlrr(mgs)  = Min( chlmlr(mgs), rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*vmlt) ) ! into rain 
      ELSEIF ( ihmlt .eq. 2 ) THEN
        IF ( xv(mgs,lhl) .gt. 0.0 .and. chlmlr(mgs) .lt. 0.0 ) THEN
!        chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl)))  ! into rain 
!        chlmlrr(mgs) = Min( chlmlr(mgs), rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lhl)*xv(mgs,lhl)) ) ! into rain 
          IF(imltshddmr == 1 ) THEN
            tmp = -rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! Min of Maximum raindrop size/mean hail size
            tmp2 = -rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*vr3mm) ! conc. change for a 3 mm mean drop diameter
            chlmlrr(mgs) = tmp*(20.e-3-xdia(mgs,lhl,3))/(20.e-3-sheddiam)+tmp2*(xdia(mgs,lhl,3)-sheddiam)/(20.e-3-sheddiam)
            chlmlrr(mgs) = -Max(tmp,Min(tmp2,chlmlrr(mgs)))
          ELSEIF ( imltshddmr == 2 .or. imltshddmr == 3 ) THEN
            ! 8/26/2015 ERM updated to use shedalp and tmpdiam
            ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1)
            chlmlrr(mgs) =  rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lhl))  ! into rain 
          ELSE ! old method
            chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl)))  ! into rain 
          ENDIF
        ELSE
        chlmlrr(mgs) = chlmlr(mgs)
        ENDIF
      ELSEIF ( ihmlt .eq. 0 ) THEN
        chlmlrr(mgs) = chlmlr(mgs)
      ENDIF

      ELSE ! } { ibinhlmlr > 0
        chlmlrr(mgs)  = Min( chlmlrr(mgs), rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*xvmx(lr)) ) ! into rain 
      ENDIF !}
      
        
      ENDIF ! }

      ENDIF ! }.not. mixedphase 

! 10ice versions:
!      chmlr(mgs)  = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhmlr(mgs)
!      chmlrr(mgs) = chmlr(mgs)
      end do
      end if

!
!  deposition/sublimation of ice
!
      DO mgs = 1,ngscnt

      rwcap(mgs) = (0.5)*xdia(mgs,lr,1)
      swcap(mgs) = (0.5)*xdia(mgs,ls,1)
      hwcap(mgs) = (0.5)*xdia(mgs,lh,1)
      IF ( lhl .gt. 1 ) hlcap(mgs) = (0.5)*xdia(mgs,lhl,1)

      if ( qx(mgs,li).gt.qxmin(li) .and. xdia(mgs,li,1) .gt. 0.0 ) then
!
! from Cotton, 1972 (Part II)
!
        cilen(mgs)   = 0.4764*(xdia(mgs,li,1))**(0.958)
        cval = xdia(mgs,li,1)
        aval = cilen(mgs)
        eval = Sqrt(1.0-(aval**2)/(cval**2))
        fval = min(0.99,eval)
        gval = alog( abs( (1.+fval)/(1.-fval) ) )
        cicap(mgs) = cval*fval / gval
      ELSE
       cicap(mgs) = 0.0
      end if
      ENDDO
!
!
      qhldsv(:) = 0.0

      do mgs = 1,ngscnt
      IF ( icond .eq. 1 .or. temg(mgs) .le. tfrh    &
     &      .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN
        qidsv(mgs) =   &
     &    fvds(mgs)*cx(mgs,li)*civent(mgs)*cicap(mgs)*depfac
        qsdsv(mgs) =   &
     &    fvds(mgs)*cx(mgs,ls)*swvent(mgs)*swcap(mgs)*depfac
!        IF ( ny .eq. 2 .and. igs(mgs) .eq. 302 .and. temg(mgs) .le. tfrh+10 .and. qx(mgs,lv) .gt. qis(mgs)
!     :       .and. qx(mgs,li) .gt. qxmin(li) ) THEN
!         write(0,*) 'qidsv = ',nstep,kgs(mgs),qidsv(mgs),temg(mgs)-tfrh,100.*(qx(mgs,lv)/qis(mgs) - 1.),1.e6*xdia(mgs,li,1),
!     :            fvds(mgs),civent(mgs),cicap(mgs)
!        ENDIF
      ELSE
        qidsv(mgs) = 0.0
        qsdsv(mgs) = 0.0
      ENDIF
        qhdsv(mgs) =   &
     &    fvds(mgs)*cx(mgs,lh)*hwvent(mgs)*hwcap(mgs)*depfac

        IF ( lhl .gt. 1 ) qhldsv(mgs) = fvds(mgs)*cx(mgs,lhl)*hlvent(mgs)*hlcap(mgs)*depfac
!
!
      end do
!


! #include "nssl.qlimit.F"

!
!  Use a test saturation adjustment to set limits on ice deposition/sublimation
!  and rain evaporation
!
!
      IF ( DoSublimationFix ) THEN
      
      do mgs = 1,ngscnt

        qitmp(mgs) = qx(mgs,li) + qx(mgs,ls) + qx(mgs,lh)
        IF ( lis > 1 ) qitmp(mgs) = qitmp(mgs) + qx(mgs,lis)
        IF ( lhl > 1 ) qitmp(mgs) = qitmp(mgs) + qx(mgs,lhl)
        qrtmp(mgs) = qx(mgs,lr)
        qctmp(mgs) = qx(mgs,lc)
        qsimxdep(mgs) = 0.0
        qsimxsub(mgs) = 0.0
        dqcitmp(mgs) = 0.0
        

!      IF ( ( qitmp(mgs) > qxmin(li) .or. qrtmp(mgs) > qxmin(lr) ) ) THEN
      IF ( qitmp(mgs) > qxmin(li)  ) THEN
      
        qitmp1    = qitmp(mgs)
        qctmp1    = qctmp(mgs)
        felvcptmp = felvcp(mgs)
        felscptmp = felscp(mgs)
        qvtmp(mgs) = qx(mgs,lv)
        qss(mgs) = qvs(mgs)
        qsstmp = qvs(mgs)
        qvstmp = qvs(mgs)
        qisstmp = qis(mgs)
        thetatmp  = theta(mgs)
        thetaptmp = thetap(mgs)
        temgtmp   = temg(mgs)
        temcgtmp  = temcg(mgs)
        qvaptmp   = qx(mgs,lv) ! qwvp(mgs) + qv0(mgs)
        qvptmp    = 0.0 ! qwvp(mgs)  ! qv pertubation

        qsstmp = qisstmp

      
       dqwvtmp(mgs) = ( qvtmp(mgs) - qsstmp )

      do itertd = 1,2
      
!
!  calculate super-saturation
!
      IF ( itertd == 1 ) THEN
      
      ELSE
        dqcitmp(mgs) = dqci(mgs)
   !     dqwvtmp(mgs) = dqwv(mgs)
      ENDIF

      dqcw(mgs) = 0.0
      dqci(mgs) = 0.0
      dqwv(mgs) = ( qvtmp(mgs) - qsstmp )
!
!  evaporation and sublimation adjustment
!
      if( dqwv(mgs) .lt. 0. ) then           ! { subsaturated
        if( qitmp(mgs) .gt. -dqwv(mgs) ) then  ! check if qi can make up all the deficit
          dqci(mgs) = dqwv(mgs)
          dqwv(mgs) = 0.
        else                                  ! otherwise make all ice available for sublimation
          dqci(mgs) = -qitmp(mgs)
          dqwv(mgs) = dqwv(mgs) + qitmp(mgs)
        end if
!
       qvptmp = qvptmp - ( dqcw(mgs) + dqci(mgs) )  ! add to perturbation vapor

       IF ( itertd == 2 .and. eqtset > 1 ) THEN
       ! if eqtset == 2, then need to update the latent heats for change in hydrometeor content
          tmp = qitmp(mgs) !+ qx(mgs,lh)
!          IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl)
          cvm = cv+cvv*qvtmp(mgs)+cpl*(qx(mgs,lc)+qrtmp(mgs))   &
                                  +cpigb*(tmp)

          felvcptmp = (felv(mgs)-rw*temg(mgs))/cvm
          felscptmp = (fels(mgs)-rw*temg(mgs))/cvm
       ENDIF


!      qitmp(mgs) = qx(mgs,li)
      qctmp(mgs) = qctmp(mgs) + dqcw(mgs) ! dqcw is zero
      qitmp(mgs) = qitmp(mgs) + dqci(mgs)
      thetaptmp = thetaptmp +   &
     &  1./pi0(mgs)*   &
     &  (felvcp(mgs)*dqcw(mgs) +felscp(mgs)*dqci(mgs))


      end if  ! } dqwv(mgs) .lt. 0. (end of evap/sublim)
!
! condensation/deposition
!
      IF ( dqwv(mgs) .ge. 0. ) THEN ! {
      
!      write(iunit,*) 'satadj: mgs,iter = ',mgs,itertd,dqwv(mgs),qss(mgs),qx(mgs,lv),qx(mgs,lc)
!
!        qitmp(mgs) = qx(mgs,li)
        fracl(mgs) = 0.0
        fraci(mgs) = 1.0
        if ( temg(mgs) .lt. tfr .and. temg(mgs) .gt. thnuc ) then
!          fracl(mgs) = max(min(1.,(temg(mgs)-233.15)/(20.)),0.0)
!          fraci(mgs) = 1.0-fracl(mgs)
        end if
        if ( temg(mgs) .le. thnuc ) then
           fraci(mgs) = 1.0
           fracl(mgs) = 0.0
         end if
!        fraci(mgs) = 1.0-fracl(mgs)

       gamss = (felvcp(mgs)*fracl(mgs) + felscp(mgs)*fraci(mgs))   &
     &      / (pi0(mgs))

          dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv2(mgs)*qsstmp/   &
     &  ((temg(mgs)-cbi)**2))

      if ( temg(mgs) .ge. tfr ) then
      dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv1(mgs)*qsstmp/   &
     &  ((temg(mgs)-cbw)**2))
      end if

      delqci1=qx(mgs,li)


      dqcw(mgs) = dqvcnd(mgs)*fracl(mgs) ! is zero
      dqci(mgs) = dqvcnd(mgs)*fraci(mgs)

      thetaptmp = thetaptmp +   &
     &   (felvcp(mgs)*dqcw(mgs) + felscp(mgs)*dqci(mgs))   &
     & / (pi0(mgs))

      qvptmp = qvptmp - ( dqvcnd(mgs) )
      qctmp(mgs) = qctmp(mgs) + dqcw(mgs)
      qitmp(mgs) = qitmp(mgs) + dqci(mgs)

       IF ( itertd == 2 .and. eqtset > 1 ) THEN
       ! if eqtset == 2, then need to update the latent heats for change in hydrometeor content
          tmp = qitmp(mgs) ! + qx(mgs,lh)
!          IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl)
          cvm = cv+cvv*qvtmp(mgs)+cpl*(qctmp(mgs) +qrtmp(mgs))   &
                                  +cpigb*(tmp)

          felvcptmp = (felv(mgs)-rw*temg(mgs))/cvm
          felscptmp = (fels(mgs)-rw*temg(mgs))/cvm
       ENDIF

      IF ( eqtset > 2 ) THEN
        pipert(mgs) = pipert(mgs) + (0   &
     &  +felspi(mgs)*dqci(mgs)    &
     &  +felvpi(mgs)*dqcw(mgs))*dtp
      ENDIF

!
!
      END IF ! } dqwv(mgs) .ge. 0.


!
      IF ( itertd == 1 ) THEN
      ! update temporary saturation values

      thetatmp = thetaptmp + theta0(mgs)
      temgtmp = thetatmp*pk(mgs) ! ( pres(mgs) / poo ) ** cap
      qvaptmp = Max((qvptmp + qv0(mgs)), 0.0)
      temcgtmp = temgtmp - tfr
      tqvcon = temgtmp-cbw
      ltemq = (temgtmp-163.15)/fqsat+1.5
      ltemq = Min( nqsat, Max(1,ltemq) )
      qvstmp = pqs(mgs)*tabqvs(ltemq)
      qisstmp = pqs(mgs)*tabqis(ltemq)
      qctmp(mgs) = max( 0.0, qctmp(mgs) )
      qitmp(mgs) = max( 0.0, qitmp(mgs) )
      qvtmp(mgs) = max( 0.0, qvaptmp )
      
!      qsstmp = qvstmp
      qsstmp = qisstmp
      
      ELSE
       ! set max depletion
        qctmp(mgs) = max( 0.0, qctmp(mgs) )
        qitmp(mgs) = max( 0.0, qitmp(mgs) )
       
        IF ( qitmp(mgs) < qitmp1 ) THEN
          qsimxsub(mgs) = (qitmp1 - qitmp(mgs))*dtpinv
        ELSEIF ( qitmp(mgs) > qitmp1 ) THEN
          qsimxdep(mgs) = (qitmp(mgs) - qitmp1)*dtpinv
        ENDIF
       
      
      ENDIF
!      pceds(mgs) = (thetap(mgs) - thsave(mgs))*dtpinv
!      write(iunit,*) 'satadj2: mgs,iter = ',mgs,itertd,dqwv(mgs),qss(mgs),qxtmp,qctmp(mgs)
!
!  end the saturation adjustment iteration loop
!
      end do ! itertd
      
      ENDIF
      
      end do ! mgs
      
      ELSE
      
       DO mgs = 1,ngscnt
         qsimxdep(mgs) = qvimxd(mgs)
         qsimxsub(mgs) = 1.e20
       ENDDO
      
      ENDIF

! end of qlimit

      do mgs = 1,ngscnt
      qisbv(mgs) = 0.0
      qssbv(mgs) = 0.0
      qidpv(mgs) = 0.0
      qsdpv(mgs) = 0.0
      IF ( icond .eq. 1 .or. temg(mgs) .le. tfrh    &
     &      .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN
!        qisbv(mgs) = max( min(qidsv(mgs), 0.0), -qimxd(mgs) )
!        qssbv(mgs) = max( min(qsdsv(mgs), 0.0), -qsmxd(mgs) )
! erm 5/10/2007:
        qisbv(mgs) = max( min(qidsv(mgs), 0.0),  Min( -qimxd(mgs), -0.5*qx(mgs,li)*dtpinv ) )
        qssbv(mgs) = max( min(qsdsv(mgs), 0.0),  Min( -qsmxd(mgs), -0.5*qx(mgs,ls)*dtpinv ) )
        qidpv(mgs) = Max(qidsv(mgs), 0.0)
        qsdpv(mgs) = Max(qsdsv(mgs), 0.0)


      ELSE
        qisbv(mgs) = 0.0
        qssbv(mgs) = 0.0
        qidpv(mgs) = 0.0
        qsdpv(mgs) = 0.0
      ENDIF

      qhsbv(mgs) = max( min(qhdsv(mgs), 0.0), -qhmxd(mgs) )

      qhdpv(mgs) = Max(qhdsv(mgs), 0.0)


      qhlsbv(mgs) = 0.0
      qhldpv(mgs) = 0.0
      IF ( lhl .gt. 1 ) THEN
        qhlsbv(mgs) = max( min(qhldsv(mgs), 0.0), -qxmxd(mgs,lhl) )
        qhldpv(mgs) = Max(qhldsv(mgs), 0.0)
      ENDIF
      
      temp1 = qidpv(mgs) + qsdpv(mgs) + qhdpv(mgs) + qhldpv(mgs)

!      IF ( temp1 .gt. qvimxd(mgs) ) THEN

!      frac = qvimxd(mgs)/temp1

      IF ( temp1 .gt. qsimxdep(mgs) ) THEN
      frac = qsimxdep(mgs)/temp1

      qidpv(mgs) = frac*qidpv(mgs)
      qsdpv(mgs) = frac*qsdpv(mgs)
      qhdpv(mgs) = frac*qhdpv(mgs)
      qhldpv(mgs) = frac*qhldpv(mgs)

!        IF ( ny .eq. 2 .and. igs(mgs) .eq. 302 .and. temg(mgs) .le. tfrh+10 .and. qx(mgs,lv) .gt. qis(mgs)
!     :       .and. qx(mgs,li) .gt. qxmin(li) ) THEN
!         write(0,*) 'qidpv,frac = ',kgs(mgs),qidpv(mgs),frac
!        ENDIF

      ENDIF

      temp1 = qisbv(mgs) + qssbv(mgs) + qhsbv(mgs) + qhlsbv(mgs)


      IF ( temp1 <  -qsimxsub(mgs) ) THEN
      frac = -qsimxsub(mgs)/temp1

      qisbv(mgs) = frac*qisbv(mgs)
      qssbv(mgs) = frac*qssbv(mgs)
      qhsbv(mgs) = frac*qhsbv(mgs)
      qhlsbv(mgs) = frac*qhlsbv(mgs)

!        IF ( ny .eq. 2 .and. igs(mgs) .eq. 302 .and. temg(mgs) .le. tfrh+10 .and. qx(mgs,lv) .gt. qis(mgs)
!     :       .and. qx(mgs,li) .gt. qxmin(li) ) THEN
!         write(0,*) 'qidpv,frac = ',kgs(mgs),qidpv(mgs),frac
!        ENDIF

      ENDIF


      end do
!
!
      if ( ipconc .ge. 1 ) then
      do mgs = 1,ngscnt
      cssbv(mgs)  = (cx(mgs,ls)/(qx(mgs,ls)+1.e-20))*qssbv(mgs)
      cisbv(mgs)  = (cx(mgs,li)/(qx(mgs,li)+1.e-20))*qisbv(mgs)
      chsbv(mgs)  = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhsbv(mgs)
      IF ( lhl .gt. 1 ) chlsbv(mgs)  = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlsbv(mgs)
      csdpv(mgs)  = 0.0 ! (cx(mgs,ls)/(qx(mgs,ls)+1.e-20))*qsdpv(mgs)
      cidpv(mgs) =  0.0 ! (cx(mgs,li)/(qx(mgs,li)+1.e-20))*qidpv(mgs)
      cisdpv(mgs) = 0.0
      chdpv(mgs)  = 0.0 ! (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhdpv(mgs)
      chldpv(mgs) = 0.0
      end do
      end if

!
!  Aggregation or size conversion of small crystals to snow
!
      if (ndebug .gt. 0 ) write(0,*) 'conc 29a'
      do mgs = 1,ngscnt
      qscni(mgs) =  0.0
      cscni(mgs) = 0.0
      cscnis(mgs) = 0.0
      if ( ipconc .ge. 4 .and. iscni .ge. 1 .and. qx(mgs,li) .gt. qxmin(li) ) then
        IF ( iscni .eq. 1 ) THEN
         qscni(mgs) =    &
     &      pi*rho0(mgs)*((0.25)/(6.0))   &
     &      *eii(mgs)*(qx(mgs,li)**2)*(xdia(mgs,li,2))   &
     &      *vtxbar(mgs,li,1)/xmas(mgs,li)
         cscni(mgs) = Min(cimxd(mgs),qscni(mgs)*rho0(mgs)/xmas(mgs,li))
         cscnis(mgs) = 0.5*cscni(mgs)
        ELSEIF ( iscni .eq. 2 .or. iscni .eq. 4 .or. iscni .eq. 5 ) THEN  ! Zeigler 1985/Zrnic 1993, sort of
          IF ( iscni .ne. 5 .and. qidpv(mgs) .gt. 0.0 .and.  xdia(mgs,li,3) .ge. 100.e-6 ) THEN
          ! convert larger crystals to snow
!            IF ( xdia(mgs,ls,3) .gt. xdia(mgs,li,3) ) THEN
!              qscni(mgs) = Max(0.1,xdia(mgs,li,3)/xdia(mgs,ls,3))*qidpv(mgs)
! erm 9/5/08 changed max to min
              qscni(mgs) = Min(0.5, xdia(mgs,li,3)/200.e-6)*qidpv(mgs)
!            ELSE
!              qscni(mgs) = 0.1*qidpv(mgs)
!            ENDIF
            cscni(mgs) = fscni*qscni(mgs)*rho0(mgs)/Max(rho_qs*xvmn(ls),xmas(mgs,li))
!            cscni(mgs) = fscni*Min(cimxd(mgs),qscni(mgs)*rho0(mgs)/Max(xdn(mgs,ls)*xvmn(ls),xmas(mgs,li)))
!            cscni(mgs) = Min(cimxd(mgs),qscni(mgs)*rho0(mgs)/xmas(mgs,li) )
!            IF ( xdia(mgs,ls,3) .le. 200.e-6 ) THEN
              cscnis(mgs) = cscni(mgs)
!            ELSE
!              cscnis(mgs) = 0.0
!            ENDIF
          ENDIF

           IF ( iscni .ne. 4 ) THEN
           ! crystal aggregation to become snow
! erm 9/5/08 commented second line and added xv to 1st line (zrnic et al 1993)
             tmp = ess(mgs)*rvt*aa2*cx(mgs,li)*cx(mgs,li)*xv(mgs,li)
!     :         ((cinu + 2.)*xv(mgs,li)/(cinu + 1.) + xv(mgs,li))

!           csacs(mgs) = rvt*aa2*ess(mgs)*cx(mgs,ls)**2*xv(mgs,ls)

             qscni(mgs) = qscni(mgs) + Min( qxmxd(mgs,li), 2.0*tmp*xmas(mgs,li)*rhoinv(mgs) )
             cscni(mgs) = cscni(mgs) + Min( cxmxd(mgs,li), 2.0*tmp )
             cscnis(mgs) = cscnis(mgs) + Min( cxmxd(mgs,li), tmp )
           ENDIF
        ELSEIF ( iscni .eq. 3 ) THEN ! LFO
           qscni(mgs) = 0.001*eii(mgs)*max((qx(mgs,li)-1.e-3),0.0)
           qscni(mgs) = min(qscni(mgs),qxmxd(mgs,li))
           cscni(mgs) = qscni(mgs)*rho0(mgs)/xmas(mgs,li)
           cscnis(mgs) = 0.5*cscni(mgs)
!           write(iunit,*) 'qscni, qi = ',qscni(mgs),qx(mgs,li),igs(mgs),kgs(mgs)
        ENDIF

      ELSEIF ( ipconc < 4 ) THEN ! LFO
           IF ( lwsm6 ) THEN
             qimax = rhoinv(mgs)*roqimax
             qscni(mgs) = Min(0.90*qx(mgs,li), Max( 0.0, (qx(mgs,li) - qimax)*dtpinv ) )
           ELSE
             qscni(mgs) = 0.001*eii(mgs)*max((qx(mgs,li)-1.e-3),0.0)
             qscni(mgs) = min(qscni(mgs),qxmxd(mgs,li))
           ENDIF
      else ! 10-ice version
      if ( iscni > 0 .and. qx(mgs,li) .gt. qxmin(li) ) then
          qscni(mgs) =    &
     &    pi*rho0(mgs)*((0.25)/(6.0))   &
     &    *eii(mgs)*(qx(mgs,li)**2)*(xdia(mgs,li,2))   &
     &    *vtxbar(mgs,li,1)/xmas(mgs,li)
         cscni(mgs) = Min(cimxd(mgs),qscni(mgs)*rho0(mgs)/xmas(mgs,li))
        end if

      end if
      end do

!
!
!  compute dry growth rate of snow, graupel, and hail
!
      do mgs = 1,ngscnt
!
      qsdry(mgs)  = qsacr(mgs)    + qsacw(mgs)   &
     &            + qsaci(mgs)
!
      qhdry(mgs)  = qhaci(mgs)    + qhacs(mgs)   &
     &            + qhacr(mgs)   &
     &            + qhacw(mgs)
!

      qhldry(mgs) = 0.0
      IF ( lhl .gt. 1 ) THEN
      qhldry(mgs)  = qhlaci(mgs)    + qhlacs(mgs)   &
     &               + qhlacr(mgs)   &
     &               + qhlacw(mgs)
      ENDIF
      end do
!
!  set wet growth and shedding
!
      do mgs = 1,ngscnt
      
      IF ( temg(mgs) < tfr ) THEN
!
!      qswet(mgs) =
!     >  ( xdia(mgs,ls,1)*swvent(mgs)*cx(mgs,ls)*fwet1(mgs)
!     >  + fwet2(mgs)*(qsaci(mgs)+qsacir(mgs)
!     >               +qsacip(mgs)) )
!      qswet(mgs) = max( 0.0, qswet(mgs))
!
!      IF ( dnu(lh) .ne. 0. ) THEN
!        qhwet(mgs) = qhdry(mgs)
!      ELSE
        qhwet(mgs) =   &
     &    ( xdia(mgs,lh,1)*hwvent(mgs)*cx(mgs,lh)*fwet1(mgs)   &
     &   + fwet2(mgs)*(qhaci(mgs) + qhacs(mgs)) )
       qhwet(mgs) = max( 0.0, qhwet(mgs))
!      ENDIF


       qhlwet(mgs) = 0.0
       IF ( lhl .gt. 1 ) THEN
       qhlwet(mgs) =   &
     &    ( xdia(mgs,lhl,1)*hlvent(mgs)*cx(mgs,lhl)*fwet1(mgs)   &
     &   + fwet2(mgs)*(qhlaci(mgs) + qhlacs(mgs)) )
       qhlwet(mgs) = max( 0.0, qhlwet(mgs))
       ENDIF
       
       ELSE
       
        qhwet(mgs) = qhdry(mgs)
        qhlwet(mgs) = qhldry(mgs)
        
       ENDIF
!
!      qhlwet(mgs) = qhldry(mgs)

      end do
!
! shedding rate
!
      qsshr(:)  =  0.0
      qhshr(:)  =  0.0
      qhlshr(:) =  0.0
      qhshh(:)  =  0.0
      csshr(:)  =  0.0
      csshrr(:) = 0.0
      chshr(:)  =  0.0
      chlshr(:)  =  0.0
      chshrr(:)  =  0.0
      chlshrr(:)  =  0.0
      vhshdr(:)  = 0.0
      vhlshdr(:)  = 0.0
      wetsfc(:)  = .false.
      wetgrowth(:)  = .false.
      wetsfchl(:)  = .false.
      wetgrowthhl(:)  = .false.

      do mgs = 1,ngscnt
!
!
!
      qhshr(mgs)  = Min( 0.0, qhwet(mgs) - qhdry(mgs) )  ! water that freezes should never be more than what sheds
      


      qhlshr(mgs)  =  Min( 0.0, qhlwet(mgs) - qhldry(mgs) )

!
! limit wet growth to only higher density particles
!
      qsshr(mgs)  =  0.0
!
!
!  no shedding for temperatures < 243.15 
!
      if ( temg(mgs) .lt. 243.15 ) then
       qsshr(mgs)  =  0.0
       qhshr(mgs)  =  0.0
       qhlshr(mgs) =  0.0
       vhshdr(mgs)  = 0.0
       vhlshdr(mgs)  = 0.0
       wetsfc(mgs) = .false.
       wetgrowth(mgs) = .false.
       wetsfchl(mgs) = .false.
       wetgrowthhl(mgs) = .false.
      end if
!
!  shed all at temperatures > 273.15
!
      if ( temg(mgs) .gt. tfr ) then

       IF ( .false. ) THEN ! old and incorrect -- Thanks to Shaofeng Hua for noticing this error (9/17/2017)
       qsshr(mgs)  = -qsdry(mgs)
       qhshr(mgs)  = -qhdry(mgs)
       qhlshr(mgs) = -qhldry(mgs)
       ELSE ! new and correct
       
       qsshr(mgs)   = - qsacr(mgs) - qsacw(mgs) ! -qsdry(mgs)
       qhlshr(mgs)  = - qhlacw(mgs) - qhlacr(mgs) ! -qhldry(mgs)
       qhshr(mgs)  = - qhacw(mgs) - qhacr(mgs) ! -qhdry(mgs)

       ENDIF

       vhshdr(mgs)  = -vhacw(mgs) - vhacr(mgs)
       vhlshdr(mgs)  = -vhlacw(mgs) - vhlacr(mgs)
       qhwet(mgs)  = 0.0
       qhlwet(mgs) = 0.0
      end if
!
!      if (qhshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr  ) THEN
        wetsfc(mgs) =  (qhshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) .or. ( qhmlr(mgs) < -qxmin(lh) .and.  temg(mgs) > tfr )
        wetgrowth(mgs) = (qhshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr )
!      ENDIF
      if (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) THEN
        wetsfchl(mgs) = (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) .or. ( qhlmlr(mgs) < -qxmin(lhl) .and.  temg(mgs) > tfr )
        wetgrowthhl(mgs) = (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr )
      ENDIF

      end do
!
      if ( ipconc .ge. 1 ) then
      do mgs = 1,ngscnt
      csshr(mgs)  = 0.0 ! (cx(mgs,ls)/(qx(mgs,ls)+1.e-20))*Min(0.0,qsshr(mgs))
       
       chshr(mgs) = 0.0 ! no change to graupel number concentration for wet-growth shedding
       
      !   tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1)
        ! Base the drop size on the shedding regime
            ! 8/26/2015 ERM updated to use shedalp and tmpdiam
            ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1)
            chshrr(mgs) =  rho0(mgs)*qhshr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lh))  ! into rain 
      
      
      
      chlshr(mgs) = 0.0
      chlshrr(mgs) = 0.0
      IF ( lhl .gt. 1 ) THEN 
!         chlshr(mgs)  = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlshr(mgs)


       chlshr(mgs) = 0.0 ! no change to hail number concentration for wet-growth shedding
       
      !   tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1)
        ! Base the drop size on the shedding regime
            ! 8/26/2015 ERM updated to use shedalp and tmpdiam
            ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1)
            chlshrr(mgs) =  rho0(mgs)*qhlshr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lhl))  ! into rain 

      ENDIF ! ( lhl > 1 )

      
      end do
      end if



!
!  final decisions
!
      do mgs = 1,ngscnt
!
!  Snow
!
      if ( qsshr(mgs) .lt. 0.0 ) then
      qsdpv(mgs) = 0.0
      qssbv(mgs) = 0.0
      else
      qsshr(mgs) = 0.0
      end if
!
!     if ( qsdry(mgs) .lt. qswet(mgs) ) then
!     qswet(mgs) = 0.0
!     else
!     qsdry(mgs) = 0.0
!     end if
!

!  graupel
!
!
      if ( wetgrowth(mgs) .or. (mixedphase .and. fhw(mgs) .gt. 0.05 .and. temg(mgs) .gt. 243.15) ) then
      

! soaking (when not advected liquid water film with graupel)

        IF ( lvol(lh) .gt. 1 .and. .not. mixedphase) THEN
        ! rescale volumes to maximum density
         rimdn(mgs,lh) = xdnmx(lh)
         raindn(mgs,lh) = xdnmx(lh)
         vhacw(mgs) = qhacw(mgs)*rho0(mgs)/rimdn(mgs,lh)
         vhacr(mgs) = qhacr(mgs)*rho0(mgs)/raindn(mgs,lh)
!        IF ( lvol(lh) .gt. 1 .and. wetgrowth(mgs) ) THEN
         IF ( xdn(mgs,lh) .lt. xdnmx(lh) ) THEN
         ! soak some liquid into the graupel
!           v1 = xdnmx(lh)*vx(mgs,lh)/(xdn(mgs,lh)*dtp) ! volume available for filling
           v1 = (1. - xdn(mgs,lh)/xdnmx(lh))*vx(mgs,lh)/(dtp) ! volume available for filling
!            tmp = (vx(mgs,lh)/rho0(mgs))*(xdnmx(lh) - xdn(mgs,lh)) ! max mixing ratio of liquid water that can be added
           v2 = rho0(mgs)*qhwet(mgs)/xdnmx(lh)  ! volume of frozen accretion
           
           vhsoak(mgs) = Min(v1,v2)
           
         ENDIF

         vhshdr(mgs) = Min(0.0, rho0(mgs)*qhwet(mgs)/xdnmx(lh) - vhacw(mgs) - vhacr(mgs) )
         
        ELSEIF ( lvol(lh) .gt. 1  .and. mixedphase ) THEN
!         vhacw(mgs) = rho0(mgs)*qhacw(mgs)/xdn0(lr)
!         vhacr(mgs) = rho0(mgs)*qhacr(mgs)/xdn0(lr)
        ENDIF
        

      qhdpv(mgs) = 0.0
!      qhsbv(mgs) = 0.0
      chdpv(mgs) = 0.0
!      chsbv(mgs) = 0.0

! collection efficiency modification

      IF ( ehi(mgs) .gt. 0.0 ) THEN
        qhaci(mgs) = Min(qimxd(mgs),qhaci0(mgs))  ! effectively sets collection eff to 1
        chaci(mgs) = Min(cimxd(mgs),chaci0(mgs))  ! effectively sets collection eff to 1
      ENDIF
      IF ( ehs(mgs) .gt. 0.0 ) THEN
!        qhacs(mgs) = Min(qsmxd(mgs),qhacs(mgs)/ehs(mgs))  ! effectively sets collection eff to 1
        qhacs(mgs) = Min(qsmxd(mgs),qhacs0(mgs)) !/ehs(mgs)                   ! divide out the collection efficiency
        chacs(mgs) = Min(csmxd(mgs),chacs0(mgs)) !/ehs(mgs)                   ! divide out the collection efficiency
        ehs(mgs) = ehsmax ! 1.0 ! min(ehsfrac*ehs(mgs),ehsmax)            ! modify it
        qhacs(mgs) = Min(qsmxd(mgs),qhacs(mgs))   ! plug it back in
      ENDIF

! be sure to catch particles with wet surfaces but not in wet growth to turn off Hallett-Mossop
      wetsfc(mgs) = .true.

      else
!        qhshr(mgs) = 0.0
      end if
!
!
!  hail
!
!      if ( lhl .gt. 1 .and. qhlshr(mgs) .lt. 0.0 ) then
      if ( lhl > 1 .and. ( wetgrowthhl(mgs) .or. (mixedphase .and. fhlw(mgs) .gt. 0.05 .and. temg(mgs) .gt. 243.15) ) ) then
!      if ( wetgrowthhl(mgs) ) then
       

      qhldpv(mgs) = 0.0
!      qhlsbv(mgs) = 0.0
      chldpv(mgs) = 0.0
!      chlsbv(mgs) = 0.0




        IF ( lvol(lhl) .gt. 1  .and. .not. mixedphase ) THEN
!        IF ( lvol(lhl) .gt. 1 .and. wetgrowthhl(mgs) ) THEN

         rimdn(mgs,lhl) = xdnmx(lhl) 
         raindn(mgs,lhl) = xdnmx(lhl) 
         vhlacw(mgs) = qhlacw(mgs)*rho0(mgs)/rimdn(mgs,lhl)
         vhlacr(mgs) = qhlacr(mgs)*rho0(mgs)/raindn(mgs,lhl)

         IF ( xdn(mgs,lhl) .lt. xdnmx(lhl) ) THEN
         ! soak some liquid into the hail
!           v1 = xdnmx(lhl)*vx(mgs,lhl)/(xdn(mgs,lhl)*dtp) ! volume available for filling
           v1 = (1. - xdn(mgs,lhl)/xdnmx(lhl))*vx(mgs,lhl)/(dtp) ! volume available for filling
!            tmp = (vx(mgs,lhl)/rho0(mgs))*(xdnmx(lhl) - xdn(mgs,lhl)) ! max mixing ratio of liquid water that can be added
           v2 = rho0(mgs)*qhlwet(mgs)/xdnmx(lhl)  ! volume of frozen accretion
           IF ( v1 > v2 ) THEN ! all the frozen stuff fits in
             vhlsoak(mgs) = v2
           ELSE  ! fill up the available space
             vhlsoak(mgs) = v1
           ENDIF
!           vhlacw(mgs) = 0.0
!           vhlacr(mgs) = Max( 0.0, v2 - v1 )
         ELSE
           vhlsoak(mgs) = 0.0
!           vhlacw(mgs) = 0.0
!           vhlacr(mgs) = rho0(mgs)*qhlwet(mgs)/raindn(mgs,lhl)
         
         ENDIF

         vhlshdr(mgs) = Min(0.0, rho0(mgs)*qhlwet(mgs)/xdnmx(lhl) - vhlacw(mgs) - vhlacr(mgs) )


        ELSEIF ( lvol(lhl) .gt. 1  .and. mixedphase ) THEN
!         vhlacw(mgs) = rho0(mgs)*qhlacw(mgs)/xdn0(lr)
!         vhlacr(mgs) = rho0(mgs)*qhlacr(mgs)/xdn0(lr)
        ENDIF

      IF ( ehli(mgs) .gt. 0.0 ) THEN
        qhlaci(mgs) = Min(qimxd(mgs),qhlaci0(mgs))  ! effectively sets collection eff to 1
        chlaci(mgs) = Min(cimxd(mgs),chlaci0(mgs))  ! effectively sets collection eff to 1
      ENDIF

!      IF ( ehls(mgs) .gt. 0.0 ) THEN
!        qhlacs(mgs) = Min(qsmxd(mgs),qhlacs(mgs)/ehls(mgs))
!      ENDIF
      IF ( ehls(mgs) .gt. 0.0 ) THEN
        qhlacs(mgs) = Min(qsmxd(mgs),qhlacs0(mgs)) !/ehls(mgs)                   ! divide out the collection efficiency
        chlacs(mgs) = Min(csmxd(mgs),chlacs0(mgs)) !/ehls(mgs)                   ! divide out the collection efficiency
        ehls(mgs) = ehsmax ! 1.0 ! min(ehsfrac*ehs(mgs),ehsmax)            ! modify it
!        qhlacs(mgs) = Min(qsmxd(mgs),qhlacs(mgs))   ! plug it back in
      ENDIF

      
!      qhlwet(mgs) = 1.0

! be sure to catch particles with wet surfaces but not in wet growth to turn off Hallett-Mossop
      wetsfchl(mgs) = .true.


      else
!      qhlshr(mgs) = 0.0
!      qhlwet(mgs) = 0.0
      end if

      end do
!
! Ice -> graupel conversion
!
      DO mgs = 1,ngscnt
      
      qhcni(mgs) = 0.0
      chcni(mgs) = 0.0
      chcnih(mgs) = 0.0
      vhcni(mgs) = 0.0
      
      IF ( iglcnvi .ge. 1 ) THEN
      IF ( temg(mgs) .lt. 273.0 .and. qiacw(mgs) - qidpv(mgs) .gt. 0.0 ) THEN
      
        
        tmp = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1))   &
     &                *((0.60)*vtxbar(mgs,li,1))   &
     &                /(temg(mgs)-273.15))**(rimc2)
        tmp = Min( Max( rimc3, tmp ), 900.0 )
        
        !  Assume that half the volume of the embryo is rime with density 'tmp'
        !  m = rhoi*(V/2) + rhorime*(V/2) = (rhoi + rhorime)*V/2
        !  V = 2*m/(rhoi + rhorime)
        
!        write(0,*)  'rime dens = ',tmp
        
        IF ( tmp .ge. 200.0 .or. iglcnvi >= 2 ) THEN
          r = Max( 0.5*(xdn(mgs,li) + tmp), xdnmn(lh) )
!          r = Max( r, 400. )
          qhcni(mgs) = (qiacw(mgs) - qidpv(mgs)) ! *float(iglcnvi)
          chcni(mgs) = cx(mgs,li)*qhcni(mgs)/qx(mgs,li)
!          chcnih(mgs) = rho0(mgs)*qhcni(mgs)/(1.6e-10)
          chcnih(mgs) = Min(chcni(mgs), rho0(mgs)*qhcni(mgs)/(r*xvmn(lh)) )
!          vhcni(mgs) = rho0(mgs)*2.0*qhcni(mgs)/(xdn(mgs,li) + tmp)
          vhcni(mgs) = rho0(mgs)*qhcni(mgs)/r
        ENDIF
      
      ELSEIF ( iglcnvi == 3 ) THEN

       IF ( temg(mgs) .lt. 273.0 .and. qiacw(mgs)*dtp > 2.*qxmin(lh) .and. gamice73fac*xmas(mgs,li) > xdnmn(lh)*xvmn(lh) ) THEN
      
        
        tmp = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1))   &
     &                *((0.60)*vtxbar(mgs,li,1))   &
     &                /(temg(mgs)-273.15))**(rimc2)
        tmp = Min( Max( rimc3, tmp ), 900.0 )
        
        !  Assume that half the volume of the embryo is rime with density 'tmp'
        !  m = rhoi*(V/2) + rhorime*(V/2) = (rhoi + rhorime)*V/2
        !  V = 2*m/(rhoi + rhorime)
        
!        write(0,*)  'rime dens = ',tmp
        ! convert to particles with the mass of the mass-weighted diameter
      !  massofmwr = gamice73fac*xmas(mgs,li)
        
        IF ( tmp .ge. xdnmn(lh)  ) THEN
          r = Max( 0.5*(xdn(mgs,li) + tmp), xdnmn(lh) )
!          r = Max( r, 400. )
          qhcni(mgs) = 0.5*qiacw(mgs)
          chcni(mgs) = qhcni(mgs)/(gamice73fac*xmas(mgs,li))
          chcnih(mgs) = Min(chcni(mgs), rho0(mgs)*qhcni(mgs)/(r*xvmn(lh)) )
!          vhcni(mgs) = rho0(mgs)*2.0*qhcni(mgs)/(xdn(mgs,li) + tmp)
          vhcni(mgs) = rho0(mgs)*qhcni(mgs)/r
        ENDIF
      
      ENDIF

      
      ENDIF
      ENDIF
      
      
      ENDDO
      
      
      qhlcnh(:) = 0.0
      chlcnh(:) = 0.0
      chlcnhhl(:) = 0.0
      vhlcnh(:) = 0.0
      vhlcnhl(:) = 0.0
      zhlcnh(:) = 0.0

      qhcnhl(:) = 0.0
      chcnhl(:) = 0.0
      vhcnhl(:) = 0.0
      zhcnhl(:) = 0.0


      IF ( lhl .gt. 1  ) THEN
      
      IF ( ihlcnh == 1 .or. ihlcnh == 3 ) THEN

!
!  Graupel (h) conversion to hail (hl) based on Milbrandt and Yau 2005b
!
      DO mgs = 1,ngscnt

!        IF ( lhl .gt. 1 .and. ipconc .ge. 5 .and. qx(mgs,lh) .gt. 1.0e-3 .and.
!     :        xdn(mgs,lh) .gt. 750. .and. qhshr(mgs) .lt. 0.0 .and.
!     :        xdia(mgs,lh,3) .gt. 1.e-3 ) THEN
        IF ( hlcnhdia > 0 ) THEN
          ltest = xdia(mgs,lh,3) .gt. hlcnhdia  ! test on mean volume diameter
        ELSE 
!          ltest =  xdia(mgs,lh,1)*(3. + alpha(mgs,lh)) > Abs( hlcnhdia ) ! test on maximum mass diameter
          ltest =  xdia(mgs,lh,1)*(4. + alpha(mgs,lh)) > Abs( hlcnhdia ) ! test on mass-weighted diameter
        ENDIF

         dg0(mgs) = -1.

        wtest = (dg0(mgs) > 0.0 .and. dg0(mgs) < dg0thresh )
        
        IF ( ihlcnh == 1 ) THEN ! .or. iusedw == 0  THEN
        
        IF ( ( wetgrowth(mgs) .and. (xdn(mgs,lh) .gt. hldnmn .or. lvh < 1 ) .and.  & ! correct this when hail gets turned on
     &        rimdn(mgs,lh) .gt. 800. .and.   &
     &        ltest .and. qx(mgs,lh) .gt. hlcnhqmin ) .or. wtest ) THEN ! {
!     :        xdia(mgs,lh,3) .gt. 2.e-3 .and. qx(mgs,lh) .gt. 1.0e-3  THEN ! 0823.2008 erm test
!        IF ( xdia(mgs,lh,3) .gt. 1.e-3 ) THEN
        IF ( qhacw(mgs) .gt. 0.0 .and. qhacw(mgs) .gt. qhaci(mgs) .and. temg(mgs) .le. tfr-2.0 ) THEN ! {
        ! dh0 is the diameter dividing wet growth from dry growth (Ziegler 1985), modified by MY05
!          dh0 = 0.01*(exp(temcg(mgs)/(1.1e4*(qx(mgs,lc)+qx(mgs,lr)) - 
!     :           1.3e3*qx(mgs,li) + 1.0e-3 ) ) - 1.0)
          IF ( wtest ) THEN
            dh0 = dg0(mgs)
          ELSE
            x = (1.1e4*(rho0(mgs)*qx(mgs,lc)) - 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0e-3 )
            IF ( x > 1.e-20 ) THEN
            arg = Min(70.0, (-temcg(mgs)/x )) ! prevent overflow of the exp function in 32 bit
            dh0 = 0.01*(exp(arg) - 1.0)
            ELSE
             dh0 = 1.e30
            ENDIF
          ENDIF ! wtest
!          dh0 = Max( dh0, 5.e-3 )
          
!         IF ( dh0 .gt. 0.0 ) write(0,*) 'dh0 = ',dh0
!         IF ( dh0 .gt. 1.0e-4 ) THEN
         IF ( xdia(mgs,lh,3)/dh0 .gt. 0.1 ) THEN !{
!         IF ( xdia(mgs,lh,3) .lt. 20.*dh0 .and. dh0 .lt. 2.0*xdia(mgs,lh,3) ) THEN 
           tmp = qhacw(mgs) + qhacr(mgs) + qhaci(mgs) + qhacs(mgs)
!           qtmp = Min( 1.0, xdia(mgs,lh,3)/(2.0*dh0) )*(tmp)
           qtmp = Min( 100.0, xdia(mgs,lh,3)/(2.0*dh0) )*(tmp)
!           IF ( .false. .and. qx(mgs,lhl) + qtmp*dtp .lt. 0.5e-3 ) THEN
!             hdia1 = Max(dh0, xdia(mgs,lh,3) )
!            qtmp = qtmp + Min(qxmxd(mgs,lh), Max( 0.0,   &
!     &      ((pi*xdn(mgs,lh)*cx(mgs,lh)) / (6.0*rho0(mgs)*dtp))   &
!     &      *exp(-hdia1/xdia(mgs,lh,1))   &
!     &      *( (hdia1**3) + 3.0*(hdia1**2)*xdia(mgs,lh,1)   &
!     &      + 6.0*(hdia1)*(xdia(mgs,lh,1)**2) + 6.0*(xdia(mgs,lh,1)**3) ) ) )

!           ENDIF

!           qhlcnh(mgs) = Min( 0.5*(qx(mgs,lh))+tmp, xdia(mgs,lh,3)/(2.0*dh0)*(tmp) )
!           qhlcnh(mgs) = Min(  qxmxd(mgs,lh), xdia(mgs,lh,3)/(2.0*dh0)*(tmp) )
           qhlcnh(mgs) = Min(  qxmxd(mgs,lh), qtmp )
           
           IF ( ipconc .ge. 5 ) THEN !{
!           dh0 = Max( xdia(mgs,lh,3), Min( dh0, 5.e-3 ) ) ! do not create hail greater than 5mm diam. unless the graupel is larger
           IF ( .not. wtest ) dh0 = Min( dh0, 10.e-3 ) ! do not create hail greater than 10mm diam., which is the max graupel size
           IF ( qx(mgs,lhl) > 0.1e-3 ) dh0 = Max( dh0, xdia(mgs,lhl,3) ) ! when enough hail is established, do not dilute the size
           chlcnhhl(mgs) = Min( cxmxd(mgs,lh), rho0(mgs)*qhlcnh(mgs)/(pi*xdn(mgs,lh)*dh0**3/6.0) )

           r = rho0(mgs)*qhlcnh(mgs)/(xdn(mgs,lh)*xv(mgs,lh))  ! number of graupel particles at mean volume diameter
!           chlcnh(mgs) = Min( Max( 1./8.*r , chlcnh(mgs)), r )
!           chlcnh(mgs) = Min( chlcnh(mgs), r )
           chlcnh(mgs) = Max( chlcnhhl(mgs), r )
           ENDIF !}
           
           vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh)
           vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh))

          ENDIF !}

        ENDIF ! }
        ENDIF ! }
        
        ELSEIF ( ihlcnh == 3 ) THEN !{
         

        ENDIF !}
      
      ENDDO
      
      ELSEIF ( ihlcnh == 2 ) THEN ! 10-ice type conversion 

      ELSEIF ( ihlcnh == 0 ) THEN

      do mgs = 1,ngscnt
!      qhlcnh(mgs) = 0.0
!      chlcnh(mgs) = 0.0
      if ( wetgrowth(mgs) .and. temg(mgs) .lt. tfr-5. .and. qx(mgs,lh) > qxmin(lh) ) then
      if ( qhacw(mgs).gt.1.e-6 .and. xdn(mgs,lh) > 700. ) then
      qhlcnh(mgs) =                                                   &
        ((pi*xdn(mgs,lh)*cx(mgs,lh)) / (6.0*rho0(mgs)*dtp))           &
       *exp(-hldia1/xdia(mgs,lh,1))                                    &
       *( (hldia1**3) + 3.0*(hldia1**2)*xdia(mgs,lh,1)                  &
        + 6.0*(hldia1)*(xdia(mgs,lh,1)**2) + 6.0*(xdia(mgs,lh,1)**3) )
      qhlcnh(mgs) =   min(qhlcnh(mgs),qhmxd(mgs))
      IF ( ipconc .ge. 5 ) THEN
        chlcnh(mgs) = Min( cxmxd(mgs,lh), cx(mgs,lh)*Exp(-hldia1/xdia(mgs,lh,1)))
        chlcnhhl(mgs) = chlcnh(mgs)
!        chlcnh(mgs) = Min( cxmxd(mgs,lh), rho0(mgs)*qhlcnh(mgs)/(2.0*xmas(mgs,lh) ))
      ENDIF
           vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh)
           vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh))
      end if
      end if
      end do
      
!      ENDIF ! true
      
      ENDIF ! ihlcnh options
      
     ! convert low-density hail to graupel
      IF ( icvhl2h >= 1 ) THEN
      DO mgs = 1,ngscnt
        IF (  qx(mgs,lhl) > qxmin(lhl) .and. xdn(mgs,lhl) < 0.5*(xdnmn(lhl) + xdnmx(lhl)) ) THEN
          tmp = Min(0.95, 1. - 0.5*(1. + tanh(0.125*(xdn(mgs,lhl) - 1.01*xdnmn(lhl) )) ))
          qhcnhl(mgs) = tmp*qx(mgs,lhl)*dtpinv
          chcnhl(mgs) = cx(mgs,lhl)*qhcnhl(mgs)/qx(mgs,lhl)
          vhcnhl(mgs) = vx(mgs,lhl)*qhcnhl(mgs)/qx(mgs,lhl)
          
        ENDIF
      ENDDO
      
      ENDIF
      
      ENDIF ! lhl > 1

  
  

!
! Ziegler snow conversion to graupel
!
      DO mgs = 1,ngscnt

      qhcns(mgs) = 0.0
      chcns(mgs) = 0.0
      chcnsh(mgs) = 0.0
      vhcns(mgs) = 0.0

      qscnh(mgs) = 0.0
      cscnh(mgs) = 0.0
      vscnh(mgs) = 0.0

      IF ( ipconc .ge. 5 ) THEN

        ! test attempt at converting graupel to snow when not riming but growing by deposition
        IF ( temg(mgs) < tfr .and. qx(mgs,lh) .gt. qxmin(lh) .and. qhdpv(mgs) > qxmin(lh)*dtpinv  &
     &       .and. qhacw(mgs) < qxmin(lh)*dtpinv ) THEN
          IF ( xdn(mgs,lh) < 290. ) THEN
!          qscnh(mgs) = 2.*qhdpv(mgs)
!          cscnh(mgs) = cx(mgs,lh)*qscnh(mgs)/qx(mgs,lh)
!          vscnh(mgs) = rho0(mgs)*qscnh(mgs)/xdn(mgs,lh)
          ENDIF
        ENDIF


        IF ( qx(mgs,ls) .gt. qxmin(ls) .and. qsacw(mgs) .gt. 0.0 ) THEN

!      DATA VGRA/1.413E-2/  ! this is the volume (cm**3) of a 3mm diam. sphere
!    vgra = 1.4137e-8 m**3

!      DNNET=DNCNV-DNAGG
!      DQNET=QXCON+QSACC+SDEP
!
!      DNSCNV=EXP(-(ROS*XNS*VGRA/(RO*QI)))*((1.-(XNS*VGRA*ROS/
!     / (RO*QI)))*DNNET + (XNS**2*VGRA*ROS/(RO*QI**2))*DQNET)
!      IF(DNSCNV.LT.0.) DNSCNV=0.
!
!      QIHC=(ROS*VGRA/RO)*DNSCNV
!
!      QH=QH+DT*QIHC
!      QI=QI-DT*QIHC
!      XNH=XNH+DT*DNSCNV
!      XNS=XNS-DT*DNSCNV

        IF ( iglcnvs .eq. 1 ) THEN  ! Zrnic, Ziegler et al (1993)

        dnnet = cscnvis(mgs) + cscnis(mgs) - csacs(mgs)
        dqnet = qscnvi(mgs) + qscni(mgs) + qsacw(mgs) + qsdpv(mgs) + qssbv(mgs)

        a3 = 1./(rho0(mgs)*qx(mgs,ls))
        a1 = Exp( - xdn(mgs,ls)*cx(mgs,ls)*vgra*a3 ) !! EXP(-(ROS*XNS*VGRA/(RO*QI)))
! (1.-(XNS*VGRA*ROS/(RO*QI)))*DNNET
        a2 =  (1.-(cx(mgs,ls)*vgra*xdn(mgs,ls)*a3))*dnnet
! (XNS**2*VGRA*ROS/(RO*QI**2))*DQNET
        a4 = cx(mgs,ls)**2*vgra*xdn(mgs,ls)*a3/qx(mgs,ls)*dqnet

        chcns(mgs) = Max( 0.0, a1*(a2 + a4) )
        chcns(mgs) = Min( chcns(mgs), cxmxd(mgs,ls) )
        chcnsh(mgs) = chcns(mgs)

        qhcns(mgs) = Min( xdn(mgs,ls)*vgra*rhoinv(mgs)*chcns(mgs), qxmxd(mgs,ls) )
        vhcns(mgs) = rho0(mgs)*qhcns(mgs)/Max(xdn(mgs,ls),xdnmn(lh))
!        vhcns(mgs) = rho0(mgs)*qhcns(mgs)/Max(xdn(mgs,ls),400.)

        ELSEIF ( iglcnvs .ge. 2  ) THEN  ! treat like ice crystals, i.e., check for rime density (ERM)

          IF ( temg(mgs) .lt. 273.0 .and. ( qsacw(mgs) - qsdpv(mgs) .gt. 0.0 .or. &
              ( iglcnvs >= 3 .and. qsacw(mgs)*dtp > 2.*qxmin(lh) .and. gamsnow73fac*xmas(mgs,ls) > xdnmn(lh)*xvmn(lh)  ) ) ) THEN !{


        tmp = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1))   &
     &                *((0.60)*vtxbar(mgs,ls,1))   &
     &                /(temg(mgs)-273.15))**(rimc2)
!        tmp = Min( Max( rimc3, tmp ), 900.0 )
        tmp = Min( tmp , 900.0 )

        !  Assume that half the volume of the embryo is rime with density 'tmp'
        !  m = rhoi*(V/2) + rhorime*(V/2) = (rhoi + rhorime)*V/2
        !  V = 2*m/(rhoi + rhorime)

!        write(0,*)  'rime dens = ',tmp

        IF ( iglcnvs == 2 ) THEN !{
        IF ( tmp .ge. 200.0  ) THEN
          r = Max( 0.5*(xdn(mgs,ls) + tmp), xdnmn(lh) )
!          r = Max( r, 400. )
          qhcns(mgs) = (qsacw(mgs) - qsdpv(mgs))
          chcns(mgs) = cx(mgs,ls)*qhcns(mgs)/qx(mgs,ls)
!          chcnih(mgs) = rho0(mgs)*qhcni(mgs)/(1.6e-10)
          chcnsh(mgs) = Min(chcns(mgs), rho0(mgs)*qhcns(mgs)/(r*xvmn(lh)) )
!          vhcni(mgs) = rho0(mgs)*2.0*qhcni(mgs)/(xdn(mgs,li) + tmp)
          vhcns(mgs) = rho0(mgs)*qhcns(mgs)/r
        ENDIF
        
        ELSEIF ( iglcnvs == 3 ) THEN
 
         ! convert to particles with the mass of the mass-weighted diameter
      !  massofmwr = gamice73fac*xmas(mgs,li)
        
        IF ( tmp > xdnmn(lh) ) THEN
          r = Max( 0.5*(xdn(mgs,ls) + tmp), xdnmn(lh) )
!          r = Max( r, 400. )
          qhcns(mgs) = 0.5*qsacw(mgs)
          chcns(mgs) = qhcns(mgs)/(gamsnow73fac*xmas(mgs,ls))
          chcns(mgs) = Min( chcns(mgs), cx(mgs,ls)*qhcns(mgs)/qx(mgs,ls))
          chcnsh(mgs) = Min(chcns(mgs), rho0(mgs)*qhcns(mgs)/(r*xvmn(lh)) )
          vhcns(mgs) = rho0(mgs)*qhcns(mgs)/r
        ENDIF

        ENDIF !}

      ENDIF !}

        ENDIF


        ENDIF

       ELSE ! single moment lfo

        qhcns(mgs) = 0.001*ehscnv(mgs)*max((qx(mgs,ls)-6.e-4),0.0)
        qhcns(mgs) = min(qhcns(mgs),qxmxd(mgs,ls))
        IF ( lvol(lh) .ge. 1 ) vhcns(mgs) = rho0(mgs)*qhcns(mgs)/Max(xdn(mgs,ls),400.)

       ENDIF
      ENDDO
!
!
!  heat budget for rain---not all rain that collects ice can freeze
!
!
!
      if ( irwfrz .gt. 0 .and. .not. mixedphase) then
!
      do mgs = 1,ngscnt
!
!  compute total rain that freeze when it interacts with cloud ice
!
      qrztot(mgs) = qrfrz(mgs) + qiacr(mgs) + qsacr(mgs)
!
!  compute the maximum amount of rain that can freeze
!  Used to limit freezing to 4*qrmxd, but now allow all rain to freeze if possible
!
      qrzmax(mgs) =   &
     &  ( xdia(mgs,lr,1)*rwvent(mgs)*cx(mgs,lr)*fwet1(mgs) )
      qrzmax(mgs) = max(qrzmax(mgs), 0.0)
      qrzmax(mgs) = min(qrztot(mgs), qrzmax(mgs))
      qrzmax(mgs) = min(qx(mgs,lr)*dtpinv, qrzmax(mgs))

      IF ( temcg(mgs) < -30. ) THEN ! allow all to freeze if T < -30 because fwet becomes invalid (negative)
        qrzmax(mgs) = qx(mgs,lr)*dtpinv
      ENDIF
!      qrzmax(mgs) = min(4.*qrmxd(mgs), qrzmax(mgs))
!
!  compute the correction factor
!
!      IF ( qrztot(mgs) .gt. qxmin(lr) ) THEN
      IF ( qrztot(mgs) .gt. qrzmax(mgs) .and. qrztot(mgs) .gt. qxmin(lr) ) THEN
        qrzfac(mgs) = qrzmax(mgs)/(qrztot(mgs))
      ELSE
        qrzfac(mgs) = 1.0
      ENDIF
      qrzfac(mgs) = min(1.0, qrzfac(mgs))
!
      end do
!
!
! now correct the above sources
!
!
      do mgs = 1,ngscnt
      if ( temg(mgs) .le. 273.15 .and. qrzfac(mgs) .lt. 1.0 ) then
      qrfrz(mgs)   = qrzfac(mgs)*qrfrz(mgs)
      qrfrzs(mgs)  = qrzfac(mgs)*qrfrzs(mgs)
      qrfrzf(mgs)  = qrzfac(mgs)*qrfrzf(mgs)
      qiacr(mgs)   = qrzfac(mgs)*qiacr(mgs)
      qsacr(mgs)   = qrzfac(mgs)*qsacr(mgs)
      qiacrf(mgs)  = qrzfac(mgs)*qiacrf(mgs)
      qiacrs(mgs)  = qrzfac(mgs)*qiacrs(mgs)
      crfrz(mgs)   = qrzfac(mgs)*crfrz(mgs)
      crfrzf(mgs)  = qrzfac(mgs)*crfrzf(mgs)
      crfrzs(mgs)  = qrzfac(mgs)*crfrzs(mgs)
      ciacr(mgs)   = qrzfac(mgs)*ciacr(mgs)
      ciacrf(mgs)  = qrzfac(mgs)*ciacrf(mgs)
      ciacrs(mgs)  = qrzfac(mgs)*ciacrs(mgs)

      
       vrfrzf(mgs)  = qrzfac(mgs)*vrfrzf(mgs)
       viacrf(mgs)  = qrzfac(mgs)*viacrf(mgs)
      end if
      end do
!
!
!
      end if
!
!
!
!  evaporation of rain
!
!
!
      qrcev(:) = 0.0
      crcev(:) = 0.0


      do mgs = 1,ngscnt
!
      IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN

      qrcev(mgs) =   &
     &  fvce(mgs)*cx(mgs,lr)*rwvent(mgs)*rwcap(mgs)*evapfac
! this line to allow condensation on rain:
      IF ( rcond .eq. 1 ) THEN
        qrcev(mgs) = min(qrcev(mgs), qxmxd(mgs,lv))
! this line to have evaporation only:
      ELSE
        qrcev(mgs) = min(qrcev(mgs), 0.0)
      ENDIF

      qrcev(mgs) = max(qrcev(mgs), -qrmxd(mgs))
!      if ( temg(mgs) .lt. 273.15 ) qrcev(mgs) = 0.0
      IF ( qrcev(mgs) .lt. 0. .and. lnr > 1 ) THEN
!        qrcev(mgs) =   -qrmxd(mgs)
!        crcev(mgs) = (rho0(mgs)/(xmas(mgs,lr)+1.e-20))*qrcev(mgs)
      crcev(mgs) = (cx(mgs,lr)/(qx(mgs,lr)))*qrcev(mgs)
      ELSE
         crcev(mgs) = 0.0
      ENDIF
!      if ( temg(mgs) .lt. 273.15 ) crcev(mgs) = 0.0
!
      ENDIF

      end do
!
! evaporation/condensation of wet graupel and snow
!
      qscev(:) = 0.0
      cscev(:) = 0.0
      qhcev(:) = 0.0
      chcev(:) = 0.0
      qhlcev(:) = 0.0
      chlcev(:) = 0.0
      IF ( lhwlg > 1 ) THEN
      qhcevlg(:) = 0.0
      chcevlg(:) = 0.0
      ENDIF
      IF ( lhlwlg > 1 ) THEN
      qhlcevlg(:) = 0.0
      chlcevlg(:) = 0.0
      ENDIF

!
!
!
!  ICE MULTIPLICATION: Two modes (rimpa, and rimpb)
!  (following Cotton et al. 1986)
!
 
      chmul1(:) =  0.0
      chlmul1(:) =  0.0
      csmul1(:) = 0.0
!
      qhmul1(:) =  0.0
      qhlmul1(:) =  0.0
      qsmul1(:) =  0.0
      do mgs = 1,ngscnt
 
       ltest =  qx(mgs,lh) .gt. qxmin(lh)
       IF ( lhl > 1 )  ltest =  ltest .or. qx(mgs,lhl) .gt. qxmin(lhl)
       
      IF ( (itype1 .ge. 1 .or. itype2 .ge. 1 )   &
     &              .and. qx(mgs,lc) .gt. qxmin(lc)) THEN
      if ( temg(mgs) .ge. 265.15 .and. temg(mgs) .le. 271.15 ) then
       IF ( ipconc .ge. 2 ) THEN
        IF ( xv(mgs,lc) .gt. 0.0     &
     &     .and.  ltest &
!     .and. itype2 .ge. 2    &
     &       ) THEN
!
!  Ziegler et al. 1986 Hallett-Mossop process.  VSTAR = 7.23e-15 (vol of 12micron radius)
!
         IF ( alpha(mgs,lc) == 0.0 ) THEN
           ex1 = (1./250.)*Exp(-7.23e-15/xv(mgs,lc))
         ELSE
           
           ratio = (1. + alpha(mgs,lc))*(7.23e-15)/xv(mgs,lc)

           IF ( usegamxinfcnu ) THEN
            i = Nint(dgami*(1. + alpha(mgs,lc)))
            gcnup1 = gmoi(i)
            ex1 = (1./250.)*Gamxinf(1.+alpha(mgs,lc), ratio)/(gcnup1)
           ELSE
             ratio = Min( maxratiolu, ratio )
             tmp = gaminterp(ratio,alpha(mgs,lc),1,1)
             ex1 = (1./250.)*tmp
           ENDIF
         ENDIF
       IF ( itype2 .le. 2 ) THEN
         ft = Max(0.0,Min(1.0,-0.11*temcg(mgs)**2 - 1.1*temcg(mgs)-1.7))
       ELSE
        IF ( temg(mgs) .ge. 265.15 .and. temg(mgs) .le. 267.15 ) THEN
          ft = 0.5
        ELSEIF (temg(mgs) .ge. 267.15 .and. temg(mgs) .le. 269.15 ) THEN
          ft = 1.0
        ELSEIF (temg(mgs) .ge. 269.15 .and. temg(mgs) .le. 271.15 ) THEN
          ft = 0.5
        ELSE 
          ft = 0.0
        ENDIF
       ENDIF
!        rhoinv = 1./rho0(mgs)
!        DNSTAR = ex1*cglacw(mgs)
        
       IF ( ft > 0.0 ) THEN
        
        IF ( itype2 > 0 ) THEN
         IF ( qx(mgs,lh) .gt. qxmin(lh) .and. (.not. wetsfc(mgs))  ) THEN
          chmul1(mgs) = ft*ex1*chacw(mgs)
!          chmul1(mgs) = Min( ft*ex1*chacw(mgs), ft*(30.*1.e+06)*rho0(mgs)*qhacw(mgs) ) ! 1.e+6 converts kg to mg; Saunders & Hosseini (2001) average of about 30 crystals per mg
          qhmul1(mgs) = cimas0*chmul1(mgs)*rhoinv(mgs)
         ENDIF
         IF ( lhl .gt. 1 ) THEN
           IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. (.not. wetsfchl(mgs))  ) THEN
            chlmul1(mgs) = (ft*ex1*chlacw(mgs))
            qhlmul1(mgs) = cimas0*chlmul1(mgs)*rhoinv(mgs)
           ENDIF
         ENDIF
        ENDIF ! itype2

        IF ( itype1 > 0 ) THEN
         IF ( qx(mgs,lh) .gt. qxmin(lh) .and. (.not. wetsfc(mgs))  ) THEN
          tmp = ft*(3.5e+08)*rho0(mgs)*qhacw(mgs)
          chmul1(mgs) = chmul1(mgs) + tmp
          qhmul1(mgs) = qhmul1(mgs) + cimas0*tmp*rhoinv(mgs)
         ENDIF
         IF ( lhl .gt. 1 ) THEN
           IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. (.not. wetsfchl(mgs)) ) THEN
            tmp = ft*(3.5e+08)*rho0(mgs)*qhlacw(mgs)
            chlmul1(mgs) = chlmul1(mgs) + tmp
            qhlmul1(mgs) = qhlmul1(mgs) + cimas0*tmp*rhoinv(mgs)
           ENDIF
         ENDIF
        ENDIF ! itype1

        
        ENDIF ! ft

        ENDIF ! xv(mgs,lc) .gt. 0.0 .and.

       ELSE ! ipconc .lt. 2
!
!  define the temperature function
!
      fimt1(mgs) = 0.0
!
! Cotton et al. (1986) version
!
      if ( temg(mgs) .ge. 268.15 .and. temg(mgs) .le. 270.15 ) then
        fimt1(mgs) = 1.0 -(temg(mgs)-268.15)/2.0
      elseif (temg(mgs) .le. 268.15 .and. temg(mgs) .ge. 265.15 ) then
        fimt1(mgs) = 1.0 +(temg(mgs)-268.15)/3.0
      ELSE 
        fimt1(mgs) = 0.0
      end if
!
! Ferrier (1994) version
!
      if ( temg(mgs) .ge. 265.15 .and. temg(mgs) .le. 267.15 ) then
        fimt1(mgs) = 0.5
      elseif (temg(mgs) .ge. 267.15 .and. temg(mgs) .le. 269.15 ) then
        fimt1(mgs) = 1.0
      elseif (temg(mgs) .ge. 269.15 .and. temg(mgs) .le. 271.15 ) then
        fimt1(mgs) = 0.5
      ELSE 
        fimt1(mgs) = 0.0
      end if
!
!
!   type I:  350 splinters are formed for every 1e-3 grams of cloud
!            water accreted by graupel/hail (note converted to MKS units)
!            3.5e+8 has units of 1/kg
!
      IF ( itype1 .ge. 1 ) THEN
       fimta(mgs) = (3.5e+08)*rho0(mgs)
      ELSE
       fimta(mgs) = 0.0
      ENDIF

!
!
!   type II:  1 splinter formed for every 250 cloud droplets larger than
!             24 micons in diameter (12 microns in radius) accreted by
!             graupel/hail
!
!
      fimt2(mgs) = 0.0
      xcwmas = xmas(mgs,lc) * 1000.
!
      IF ( itype2 .ge. 1 ) THEN
      if ( xcwmas.lt.1.26e-9 ) then
        fimt2(mgs) = 0.0
      end if
      if ( xcwmas .le. 3.55e-9 .and. xcwmas .ge. 1.26e-9 ) then
        fimt2(mgs) = (2.27)*alog(xcwmas) + 13.39
      end if
      if ( xcwmas .gt. 3.55e-9 ) then
        fimt2(mgs) = 1.0
      end if

      fimt2(mgs) = min(fimt2(mgs),1.0)
      fimt2(mgs) = max(fimt2(mgs),0.0)
      
      ENDIF
!
!     qhmul2 = 0.0
!     qsmul2 = 0.0
!
!     qhmul2 =
!    >  (4.0e-03)*fimt1(mgs)*fimt2(mgs)*qhacw(mgs)
!     qsmul2 =
!    >  (4.0e-03)*fimt1(mgs)*fimt2(mgs)*qsacw(mgs)
!
!      cimas0 = (1.0e-12)
!      cimas0 = 2.5e-10
      IF ( .not. wetsfc(mgs) ) THEN
      chmul1(mgs) =  fimt1(mgs)*(fimta(mgs) +   &
     &                           (4.0e-03)*fimt2(mgs))*qhacw(mgs)
      ENDIF
!
      qhmul1(mgs) =  chmul1(mgs)*(cimas0/rho0(mgs))

         IF ( lhl .gt. 1 ) THEN
           IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. (.not. wetsfchl(mgs)) ) THEN
            tmp = fimt1(mgs)*(fimta(mgs) +   &
     &                           (4.0e-03)*fimt2(mgs))*qhlacw(mgs)
            chlmul1(mgs) =  tmp
            qhlmul1(mgs) = cimas0*tmp*rhoinv(mgs)
           ENDIF
         ENDIF

!      qsmul1(mgs) =  csmul1(mgs)*(cimas0/rho0(mgs))
!
      ENDIF ! ( ipconc .ge. 2 )
      
      end if ! (in temperature range)
      
      ENDIF ! ( itype1 .eq. 1 .or. itype2 .eq. 1)
!
      end do
!
!
!
!     end if
!
!     end do
!
!
! ICE MULTIPLICATION FROM SNOW
!   Lo and Passarelli 82 / Willis and Heymsfield 89 / Schuur and Rutledge 00b
!   using kfrag as fragmentation rate (s-1) / 500 microns as char mean diam for max snow mix ratio
!
      csmul(:) = 0.0
      qsmul(:) = 0.0
      
      IF ( isnwfrac /= 0 ) THEN
      do mgs = 1,ngscnt
       IF (temg(mgs) .gt. 265.0) THEN !{
        if (xdia(mgs,ls,1) .gt. 100.e-6 .and. xdia(mgs,ls,1) .lt. 2.0e-3) then  ! equiv diameter 100microns to 2mm

        tmp = rhoinv(mgs)*pi*xdn(mgs,ls)*cx(mgs,ls)*(500.e-6)**3
        qsmul(mgs) = Max( kfrag*( qx(mgs,ls) - tmp ) , 0.0 )

        qsmul(mgs) = Min( qxmxd(mgs,li), qsmul(mgs) )
        csmul(mgs) = Min( cxmxd(mgs,li), rho0(mgs)*qsmul(mgs)/mfrag )

        endif
       ENDIF !}
      enddo
      ENDIF

!
!  frozen rain-rain interaction....
!
!
!
!
!  rain-ice interaction
!
!
      do mgs = 1,ngscnt
      qracif(mgs) = qraci(mgs)
      cracif(mgs) = craci(mgs)
!      ciacrf(mgs) = ciacr(mgs)
      end do
!
! 
!  vapor to pristine ice crystals   UP
!
!
!
!  compute the nucleation rate
!
!     do mgs = 1,ngscnt
!     idqis = 0
!     if ( ssi(mgs) .gt. 1.0 ) idqis = 1
!     fiinit(mgs) = (felv(mgs)**2)/(cp*rw)
!     dqisdt(mgs) = (qx(mgs,lv)-qis(mgs))/
!    >  (1.0 + fiinit(mgs)*qis(mgs)/tsqr(mgs))
!     qidsvp(mgs) = dqisdt(mgs)
!     cnnt = min(cnit*exp(-temcg(mgs)*bta1),1.0e+09)
!     qiint(mgs) = 
!    >  il5(mgs)*idqis*(1.0*dtpinv)
!    <  *min((6.88e-13)*cnnt/rho0(mgs), 0.25*dqisdt(mgs)) 
!     end do
!
!  Meyers et al. (1992; JAS) and Ferrier (1994) primary ice nucleation
!
      cmassin = cimasn  ! 6.88e-13
      do mgs = 1,ngscnt
      qiint(mgs) = 0.0
      ciint(mgs) = 0.0
      qicicnt(mgs) = 0.0
      cicint(mgs) = 0.0
      qipipnt(mgs) = 0.0
      cipint(mgs) = 0.0
      ccitmp = 0.0
      IF ( icenucopt == 1 .or. icenucopt == -10 .or. icenucopt == -11 ) THEN
      if ( ( temg(mgs) .lt. 268.15 .or.  &
!     : ( imeyers5 .and. temg(mgs) .lt.  273.0) ) .and.    &
     & ( imeyers5 .and. temg(mgs) .lt.  272.0 .and. temgkm2(mgs) .lt. tfr) ) .and.    &
     &    ciintmx .gt. (cx(mgs,li)+ccitmp)  &
!     :    .and. cninm(mgs) .gt. 0.   &
     &     ) then
      fiinit(mgs) = (felv(mgs)**2)/(cp*rw)
      dqisdt(mgs) = (qx(mgs,lv)-qis(mgs))/   &
     &  (1.0 + fiinit(mgs)*qis(mgs)/tsqr(mgs))
!      qidsvp(mgs) = dqisdt(mgs)
      idqis = 0
      if ( ssi(mgs) .gt. 1.0 ) THEN
      idqis = 1 
      dzfacp = max( float(kgsp(mgs)-kgs(mgs)), 0.0 )
      dzfacm = max( float(kgs(mgs)-kgsm(mgs)), 0.0 )
      qiint(mgs) =   &
     &  idqis*il5(mgs)   &
     &  *(cmassin/rho0(mgs))   &
     &  *max(0.0,wvel(mgs))   &
     &  *max((cninp(mgs)-cninm(mgs)),0.0)/gz(igs(mgs),jgs,kgs(mgs))   &
     &  /((dzfacp+dzfacm))

      qiint(mgs) = min(qiint(mgs), max(0.25*dqisdt(mgs),0.0)) 
      ciint(mgs) = qiint(mgs)*rho0(mgs)/cmassin
      
!
! limit new crystals so it does not increase the current concentration
!  above ciintmx 20,000 per liter (2.e7 per m**3)
!
!      ciintmx = 1.e9
!      ciintmx = 1.e9
      IF ( icenucopt /= -10 ) THEN
      
        IF ( lcin > 1 ) THEN
          ciint(mgs) = Min(ciint(mgs), ccin(mgs)*dtpinv) ! because ciint is a *rate*
          ccin(mgs) = ccin(mgs) - ciint(mgs)*dtp
          qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs)
        ELSEIF ( lcina > 1 ) THEN
          ciint(mgs) = Max(0.0, Min( ciint(mgs), Min( cnina(mgs), ciintmx ) - cina(mgs) ))
          qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs)
      
        ELSEIF ( icenucopt == 1 .and. ciint(mgs) .gt. Max(0.0, ciintmx - cx(mgs,li) - ccitmp )*dtpinv  ) THEN
          ciint(mgs) = Max(0.0, ciintmx - (cx(mgs,li)) )*dtpinv 
          qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs)

        ELSEIF ( icenucopt == -11 .and. dtp*ciint(mgs) .gt. ( cnina(mgs) - (cx(mgs,li) - ccitmp))) THEN
          ciint(mgs) = Max(0.0,  cnina(mgs) - (cx(mgs,li)+ccitmp)*dtpinv )
          qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs)

        ENDIF
      ENDIF
      
      end if
      endif

      ELSEIF ( icenucopt == 2 .or. icenucopt == -1 .or. icenucopt == -2 ) THEN
      
        IF ( ( temg(mgs) .lt. 268.15 .and. ssw(mgs) > 1.0 ) .or. ssi(mgs) > 1.25 ) THEN
          IF ( lcin > 1 ) THEN
           ciint(mgs) = Min(cnina(mgs), ccin(mgs))
           ciint(mgs) = Min( ciint(mgs), Max(0.0, ciintmx - (cx(mgs,li) - ccitmp) ) ) ! do not initiate ice beyond concentration of ciintmx
           ccin(mgs) = ccin(mgs) - ciint(mgs)
           ciint(mgs) = ciint(mgs)*dtpinv ! convert total initiation to a rate
          ELSE
           ciint(mgs) = Max( 0.0, cnina(mgs) - cina(mgs) )*dtpinv
          ENDIF
          qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs)

          fiinit(mgs) = (felv(mgs)**2)/(cp*rw)
          dqisdt(mgs) = (qx(mgs,lv)-qis(mgs))/(1.0 + fiinit(mgs)*qis(mgs)/tsqr(mgs))
          qiint(mgs) = min(qiint(mgs), max(0.25*dqisdt(mgs),0.0))
          ciint(mgs) = qiint(mgs)*rho0(mgs)/cmassin
        ENDIF
      
      
      
      ELSEIF ( icenucopt == 3 .or. icenucopt == 4 .or. icenucopt == 10 ) THEN
        IF (  temg(mgs) .lt. 268.15 ) THEN
          IF ( lcin > 1 ) THEN
           ciint(mgs) = Min(cnina(mgs), ccin(mgs))
           ciint(mgs) = Min( ciint(mgs), Max(0.0, ciintmx - (cx(mgs,li) + ccitmp) ) ) ! do not initiate ice beyond concentration of ciintmx
           ccin(mgs) = ccin(mgs) - ciint(mgs)
           ciint(mgs) = ciint(mgs)*dtpinv ! convert total initiation to a rate
          ELSE
           ciint(mgs) = Max( 0.0, cnina(mgs) - cina(mgs) )*dtpinv
          ENDIF
          qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs)
        ENDIF

      ENDIF
!
      if ( xplate(mgs) .eq. 1 ) then
      qipipnt(mgs) = qiint(mgs)
      cipint(mgs) = ciint(mgs)
      end if
!
      if ( xcolmn(mgs) .eq. 1 ) then
      qicicnt(mgs) = qiint(mgs)
      cicint(mgs) = ciint(mgs)
      end if
!
!     qipipnt(mgs) = 0.0
!     qicicnt(mgs) = qiint(mgs)
!
      end do
!
! 

!
!  vapor to cloud droplets   UP
!
      if (ndebug .gt. 0 ) write(0,*) 'dbg = 8'
!
!
      if (ndebug .gt. 0 ) write(0,*) 'Collection: set 3-component'
!
!  time for riming....
!
!     rimtim = 240.0
!     dtrim = rimtim
!     xacrtim  = 120.0
!     tranfr = 0.50
!     tranfw = 0.50
!
!  coefficients for riming
!
!     rimc1 = 300.00
!     rimc2 = 0.44
!
! 
!  zero some arrays
!
!
      do mgs = 1,ngscnt
      qrshr(mgs) = 0.0
      qwshw(mgs) = 0.0
      cwshw(mgs) = 0.0
      qsshrp(mgs) = 0.0
      qhshrp(mgs) = 0.0
      end do
!
!
!  first sum all of the shed rain
!
!
      do mgs = 1,ngscnt
      qrshr(mgs) = qsshr(mgs) + qhshr(mgs) + qhlshr(mgs)
      crshr(mgs) = chshrr(mgs)/rzxh(mgs) + chlshrr(mgs)/rzxhl(mgs)
      
      
      IF ( ipconc .ge. 3 ) THEN
!       crshr(mgs) = Max(crshr(mgs), rho0(mgs)*qrshr(mgs)/(xdn(mgs,lr)*vr1mm) )
      ENDIF
      end do 
!
!
!

!
!
!
!
      IF ( ipconc .ge. 1 ) THEN
!
!
!  concentration production terms
!
!  YYY
!
!
!       DO mgs = 1,ngscnt
       pccwi(:) = 0.0
       pccwd(:) = 0.0
       pccwdacc(:) = 0.0
       pccii(:) = 0.0
       pccin(:) = 0.0
       pccid(:) = 0.0
       pcisi(:) = 0.0
       pcisd(:) = 0.0
       pcrwi(:) = 0.0
       pcrwd(:) = 0.0
       pcswi(:) = 0.0
       pcswd(:) = 0.0
       pchwi(:) = 0.0
       pchwd(:) = 0.0
       pchli(:) = 0.0
       pchld(:) = 0.0
!       ENDDO
!
!  Cloud ice
!
!      IF ( ipconc .ge. 1 ) THEN

      IF ( warmonly < 0.5 ) THEN
      IF ( ffrzs < 1.0 ) THEN
      do mgs = 1,ngscnt
      pccii(mgs) =   &
     &   il5(mgs)*cicint(mgs)  &
     &  +il5(mgs)*((1.0-cwfrz2snowfrac)*cwfrzc(mgs)+cwctfzc(mgs)   &
     &  +cicichr(mgs))   &
     &  +chmul1(mgs)   &
     &  +chlmul1(mgs)    &
     &  + csplinter(mgs) + csplinter2(mgs)   &
     &  +csmul(mgs)
     
       pccii(mgs) = pccii(mgs)*(1.0 - ffrzs)
       
!     >  + nsplinter*(crfrzf(mgs) + crfrz(mgs))
      pccid(mgs) =   &
     &   il5(mgs)*(-cscni(mgs) - cscnvi(mgs) & ! - cwaci(mgs)   &
     &  -craci(mgs)    &
     &  -csaci(mgs)   &
     &  -chaci(mgs) - chlaci(mgs)   &
     &  -chcni(mgs))   &
     &  +il5(mgs)*cisbv(mgs)   &
     &  -(1.-il5(mgs))*cimlr(mgs)

      pccin(mgs) = ciint(mgs)
      

      end do
      ENDIF ! ffrzs
      ELSEIF ( warmonly < 0.8 ) THEN
      do mgs = 1,ngscnt
      
!      qiint(mgs) = 0.0
!      cicint(mgs) = 0.0
!      qicicnt(mgs) = 0.0
      
      pccii(mgs) =   &
     &   il5(mgs)*cicint(mgs)   &
     &  +il5(mgs)*((1.0-cwfrz2snowfrac)*cwfrzc(mgs)+cwctfzc(mgs)   &
     &  +cicichr(mgs))   &
     &  +chmul1(mgs)   &
     &  +chlmul1(mgs)    &
     &  + csplinter(mgs) + csplinter2(mgs)   &
     &  +csmul(mgs)
     
       pccii(mgs) = pccii(mgs)*(1. - ffrzs)
      pccid(mgs) =   &
!     &   il5(mgs)*(-cscni(mgs) - cscnvi(mgs) & ! - cwaci(mgs)   &
!     &  -craci(mgs)    &
!     &  -csaci(mgs)   &
!     &  -chaci(mgs) - chlaci(mgs)   &
!     &  -chcni(mgs))   &
     &  +il5(mgs)*cisbv(mgs)   &
     &  -(1.-il5(mgs))*cimlr(mgs)

      pccin(mgs) = ciint(mgs)

      end do
      ENDIF ! warmonly

      
!      ENDIF ! ( ipconc .ge. 1 )
!
!  Cloud water
!
      IF ( ipconc .ge. 2 ) THEN
      
      do mgs = 1,ngscnt
      pccwi(mgs) =  (0.0) - cwshw(mgs) ! + (1-il5(mgs))*(-cirmlw(mgs))
      
      IF ( warmonly < 0.5 ) THEN
      pccwd(mgs) =    &
     &  - cautn(mgs) +   &
     &  il5(mgs)*(-ciacw(mgs)-cwfrz(mgs)-cwctfzp(mgs)   &
     &  -cwctfzc(mgs)   &
     &   )   &
     &  -cracw(mgs) -csacw(mgs)  -chacw(mgs) - chlacw(mgs)


      ELSEIF ( warmonly < 0.8 ) THEN
      pccwd(mgs) =    &
     &  - cautn(mgs) +   &
     &  il5(mgs)*(  &
     & -ciacw(mgs)-cwfrz(mgs)-cwctfzp(mgs)   &
     &  -cwctfzc(mgs)   &
     &   )   &
     &  -cracw(mgs) -chacw(mgs) -chlacw(mgs) 
      ELSE
      
!       tmp3d(igs(mgs),jy,kgs(mgs)) = crcnw(mgs)

!       cracw(mgs) = 0.0 ! turn off accretion
!       qracw(mgs) = 0.0
!       crcev(mgs) = 0.0 ! turn off evap
!       qrcev(mgs) = 0.0 ! turn off evap
!       cracr(mgs) = 0.0 ! turn off self collection
       
       
!       cautn(mgs) = 0.0 
!       crcnw(mgs) = 0.0
!       qrcnw(mgs) = 0.0

      pccwd(mgs) =    &
     &  - cautn(mgs) -cracw(mgs)
      ENDIF


      IF ( .false. .and. exwmindiam > 0.0 .and. ccwresv(mgs) > 0.0 ) THEN
      pccwdacc(mgs) =    &
     &  il5(mgs)*(-ciacw(mgs)  &
     &   )   &
     &  -cracw(mgs) -csacw(mgs)  -chacw(mgs) - chlacw(mgs)

      IF ( -pccwdacc(mgs)*dtp .gt. cx(mgs,lc) - ccwresv(mgs) ) THEN

       frac = -(cx(mgs,lc) - ccwresv(mgs) )/(pccwdacc(mgs)*dtp)
       pccwdacc(mgs) = -(cx(mgs,lc) - ccwresv(mgs) )*dtpinv

        ciacw(mgs)   = frac*ciacw(mgs)
        cracw(mgs)   = frac*cracw(mgs)
        csacw(mgs)   = frac*csacw(mgs)
        chacw(mgs)   = frac*chacw(mgs)
        cautn(mgs)   = frac*cautn(mgs)
       
        IF ( lhl .gt. 1 ) chlacw(mgs)   = frac*chlacw(mgs)

! resum
      pccwd(mgs) =    &
     &  - cautn(mgs) +   &
     &  il5(mgs)*(-ciacw(mgs)-cwfrzp(mgs)-cwctfzp(mgs)   &
     &  -cwfrzc(mgs)-cwctfzc(mgs)   &
     &  -il5(mgs)*(ciihr(mgs))   &
     &   )   &
     &  -cracw(mgs) -csacw(mgs)  -chacw(mgs) - chlacw(mgs)

      ENDIF

      ENDIF


      IF ( -pccwd(mgs)*dtp .gt. cx(mgs,lc) ) THEN
!       write(0,*) 'OUCH! pccwd(mgs)*dtp .gt. ccw(mgs) ',pccwd(mgs),cx(mgs,lc)
!       write(0,*) 'qc = ',qx(mgs,lc)
!       write(0,*) -ciacw(mgs)-cwfrzp(mgs)-cwctfzp(mgs)-cwfrzc(mgs)-cwctfzc(mgs)
!       write(0,*)  -cracw(mgs) -csacw(mgs)  -chacw(mgs)
!       write(0,*) - cautn(mgs)

       frac = -cx(mgs,lc)/(pccwd(mgs)*dtp)
       pccwd(mgs) = -cx(mgs,lc)*dtpinv

        ciacw(mgs)   = frac*ciacw(mgs)
        cwfrz(mgs)  = frac*cwfrz(mgs)
        cwfrzp(mgs)  = frac*cwfrzp(mgs)
        cwctfzp(mgs) = frac*cwctfzp(mgs)
        cwfrzc(mgs)  = frac*cwfrzc(mgs)
        cwctfzc(mgs) = frac*cwctfzc(mgs)
        cwctfz(mgs) = frac*cwctfz(mgs)
        cracw(mgs)   = frac*cracw(mgs)
        csacw(mgs)   = frac*csacw(mgs)
        chacw(mgs)   = frac*chacw(mgs)
        cautn(mgs)   = frac*cautn(mgs)
       
        pccii(mgs) = pccii(mgs) - (1.-frac)*il5(mgs)*(cwfrzc(mgs)+cwctfzc(mgs))*(1. - ffrzs)
        IF ( lhl .gt. 1 ) chlacw(mgs)   = frac*chlacw(mgs)

!       STOP
      ENDIF

      end do

      ENDIF ! ipconc

!
!  Rain
!
      IF ( ipconc .ge. 3 ) THEN

      do mgs = 1,ngscnt

      IF ( warmonly < 0.5 ) THEN
      pcrwi(mgs) = &
!     >   cracw(mgs) +    &
     &   crcnw(mgs)   &
     &  +(1-il5(mgs))*(   &
     &    -chmlrr(mgs)/rzxh(mgs)   &
     &    -chlmlrr(mgs)/rzxhl(mgs)   &
!     &    -csmlr(mgs)/rzxs(mgs)     &
     &   -csmlrr(mgs)     &
     &   - cimlr(mgs) )   &
     &  -crshr(mgs)             !null at this point when wet snow/graupel included
      pcrwd(mgs) =   &
     &   il5(mgs)*(-ciacr(mgs) - crfrz(mgs) ) & ! - cipacr(mgs))
!     >  -csacr(mgs)   &
     &  - chacr(mgs) - chlacr(mgs)   &
     &  +crcev(mgs)   &
     &  - cracr(mgs)
!     >  -il5(mgs)*ciracr(mgs)


      ELSEIF ( warmonly < 0.8 ) THEN
       pcrwi(mgs) = &
     &   crcnw(mgs)   &
     &  +(1-il5(mgs))*(   &
     &    -chmlrr(mgs)/rzxh(mgs)    &
     &    -chlmlrr(mgs)/rzxhl(mgs)   &
!     &    -csmlr(mgs)     &
     &   -csmlrr(mgs)     &
     &   - cimlr(mgs) )   &
     &  -crshr(mgs)             !null at this point when wet snow/graupel included
      pcrwd(mgs) =   &
     &   il5(mgs)*( - crfrz(mgs) ) & ! - cipacr(mgs))
     &  - chacr(mgs)    &
     &  - chlacr(mgs)    &
     &  +crcev(mgs)   &
     &  - cracr(mgs)
      ELSE
      pcrwi(mgs) =   &
     &   crcnw(mgs)
      pcrwd(mgs) =   &
     &  +crcev(mgs)   &
     &  - cracr(mgs)

!        tmp3d(igs(mgs),jy,kgs(mgs)) = vtxbar(mgs,lr,1) ! crcnw(mgs) ! (pcrwi(mgs) + pcrwd(mgs))
!        pcrwi(mgs) = 0.0
!        pcrwd(mgs) = 0.0
!        qrcnw(mgs) = 0.0

      ENDIF


      frac = 0.0
      IF ( -pcrwd(mgs)*dtp .gt. cx(mgs,lr) ) THEN
!       write(0,*) 'OUCH! pcrwd(mgs)*dtp .gt. crw(mgs) ',pcrwd(mgs)*dtp,cx(mgs,lr),mgs,igs(mgs),kgs(mgs)
!       write(0,*) -ciacr(mgs)
!       write(0,*) -crfrz(mgs)
!       write(0,*) -chacr(mgs)
!       write(0,*)  crcev(mgs)
!       write(0,*)  -cracr(mgs)

       frac =  -cx(mgs,lr)/(pcrwd(mgs)*dtp)
       pcrwd(mgs) = -cx(mgs,lr)*dtpinv

        ciacr(mgs) = frac*ciacr(mgs)
        ciacrf(mgs) = frac*ciacrf(mgs)
        ciacrs(mgs) = frac*ciacrs(mgs)
        crfrz(mgs) = frac*crfrz(mgs)
        crfrzf(mgs) = frac*crfrzf(mgs)
        crfrzs(mgs) = frac*crfrzs(mgs)
        chacr(mgs) = frac*chacr(mgs)
        chlacr(mgs) = frac*chlacr(mgs)
        crcev(mgs) = frac*crcev(mgs)
        cracr(mgs) = frac*cracr(mgs)

!       STOP
      ENDIF

      end do

      ENDIF


      IF ( warmonly < 0.5 ) THEN

!
!  Snow
!
      IF ( ipconc .ge. 4 ) THEN !

      do mgs = 1,ngscnt
      pcswi(mgs) =   &
     &   il5(mgs)*(cscnis(mgs) + cscnvis(mgs) )    &
     &  + cwfrz2snowfrac*cwfrz(mgs)/cwfrz2snowratio  &
     &  + cscnh(mgs)
      
      IF (  ffrzs > 0.0 ) THEN
       pcswi(mgs) =  pcswi(mgs) + ffrzs* (  &
     &   il5(mgs)*cicint(mgs)   &
     &  +il5(mgs)*(cwfrzc(mgs)+cwctfzc(mgs)   &
     &  +cicichr(mgs))  &
     &  +chmul1(mgs)   &
     &  +chlmul1(mgs)    &
     &  + csplinter(mgs) + csplinter2(mgs)   &
     &  +csmul(mgs) )
      ENDIF

      
      IF ( ess0 < 0.0 ) THEN
         csacs(mgs) = Max(0.0, csacs(mgs) - (ifrzs)*(crfrzs(mgs) + ciacrs(mgs)))
      ENDIF
      
      pcswd(mgs) = &
!     :  cracs(mgs)     &
     &  -chacs(mgs) - chlacs(mgs)   &
     &  -chcns(mgs)   &
     &  +(1-il5(mgs))*csmlr(mgs) + csshr(mgs) & ! + csshrp(mgs)
!     >  +il5(mgs)*(cssbv(mgs))   &
     &   + cssbv(mgs)   &
     &  - csacs(mgs)

      frac = 0.0
      IF ( imixedphase == 0 ) THEN
        IF ( cx(mgs,ls) + dtp*(pcswi(mgs) + pcswd(mgs)) < 0.0 ) THEN
         frac = (-cx(mgs,ls) + pcswi(mgs)*dtp)/(pcswd(mgs)*dtp)
         
           pcswd(mgs) = frac*pcswd(mgs)
           
           chacs(mgs)  = frac*chacs(mgs) 
           chlacs(mgs) = frac*chlacs(mgs)
           chcns(mgs)  = frac*chcns(mgs) 
           csmlr(mgs)  = frac*csmlr(mgs) 
           csshr(mgs)  = frac*csshr(mgs) 
           cssbv(mgs)  = frac*cssbv(mgs) 
           csacs(mgs)  = frac*csacs(mgs)
      
        ENDIF
      ENDIF


      
      pccii(mgs) =  pccii(mgs) &
     &  + (1. - ifrzs)*crfrzs(mgs) &
     &  + (1. - ifrzs)*ciacrs(mgs)

      pcswi(mgs) =  pcswi(mgs) &
     &  + (ifrzs)*crfrzs(mgs) &
     &  + (ifrzs)*ciacrs(mgs)

      end do

      ENDIF

!
!  Graupel
!
      IF ( ipconc .ge. 5 ) THEN !
      do mgs = 1,ngscnt
      pchwi(mgs) =   &
     &  +(ffrzh*ifrzg*crfrzf(mgs)   &
     & +il5(mgs)*ffrzh*ifiacrg*(ciacrf(mgs) ))    &
     & + f2h*chcnsh(mgs) + f2h*chcnih(mgs) + chcnhl(mgs)

      pchwd(mgs) =   &
     &  (1-il5(mgs))*chmlr(mgs) &
!     >  + il5(mgs)*chsbv(mgs)   &
     &  + chsbv(mgs)   &
     &  - il5(mgs)*chlcnh(mgs) &
     &  - cscnh(mgs)
      end do


!

!
!  Hail
!
      IF ( lhl .gt. 1 .and. lnhl > 1 ) THEN !
      do mgs = 1,ngscnt
      pchli(mgs) = (ffrzh*(1.0-ifrzg)*crfrzf(mgs) +il5(mgs)*ffrzh*(1.0-ifiacrg)*(ciacrf(mgs) ))  &
     & + chlcnhhl(mgs) *rzxhlh(mgs)

      pchld(mgs) =   &
     &  (1-il5(mgs))*chlmlr(mgs)   &
!     >  + il5(mgs)*chlsbv(mgs)   &
     &  + chlsbv(mgs) - chcnhl(mgs)
      
      IF ( imixedphase == 0 ) THEN
      frac = 0.0
      IF ( cx(mgs,lhl) + dtp*(pchli(mgs) + pchld(mgs)) < 0.0 ) THEN
        ! rescale depletion

         frac = (-cx(mgs,lhl) + pchli(mgs)*dtp)/(pchld(mgs)*dtp)
         
         chlmlr(mgs) = frac*chlmlr(mgs)
         chlsbv(mgs) = frac*chlsbv(mgs)
         chcnhl(mgs) = frac*chcnhl(mgs)
           
         pchld(mgs) = frac*pchld(mgs)
           
      ENDIF
      ENDIF

      end do
      
      ENDIF
!

      ENDIF ! (ipconc .ge. 5 )

      ELSEIF ( warmonly < 0.8 ) THEN

!
!  Graupel
!
      IF ( ipconc .ge. 5 ) THEN !
      do mgs = 1,ngscnt
      pchwi(mgs) =   &
     &  +ifrzg*(crfrzf(mgs) ) ! +il5(mgs)*(ciacrf(mgs) ))

      pchwd(mgs) =   &
     &  (1-il5(mgs))*chmlr(mgs) &
     &  - il5(mgs)*chlcnh(mgs)
      end do
!
!  Hail
!
      IF ( lhl .gt. 1 ) THEN !
      do mgs = 1,ngscnt
      pchli(mgs) = (1.0-ifrzg)*(crfrzf(mgs)) & ! +il5(mgs)*(ciacrf(mgs) ))  &
     & + chlcnhhl(mgs) *rzxhl(mgs)/rzxh(mgs)

      pchld(mgs) =   &
     &  (1-il5(mgs))*chlmlr(mgs) !  &
!     >  + il5(mgs)*chlsbv(mgs)   &
!     &  + chlsbv(mgs)

!      IF ( pchli(mgs) .ne. 0. .or. pchld(mgs) .ne. 0 ) THEN
!       write(0,*) 'dr: pchli,pchld = ', pchli(mgs),pchld(mgs), igs(mgs),kgs(mgs)
!      ENDIF
      end do

      ENDIF

      ENDIF ! ipconc >= 5

      ENDIF ! warmonly

!

!
!  Balance and checks for continuity.....within machine precision...
!
      do mgs = 1,ngscnt
      pctot(mgs)   = pccwi(mgs) +pccwd(mgs) +   &
     &               pccii(mgs) +pccid(mgs) +   &
     &               pcrwi(mgs) +pcrwd(mgs) +   &
     &               pcswi(mgs) +pcswd(mgs) +   &
     &               pchwi(mgs) +pchwd(mgs) +   &
     &               pchli(mgs) +pchld(mgs)
      end do
!
!
      ENDIF ! ( ipconc .ge. 1 )
!
!
!
!
!
!  GOGO
!  production terms for mass
!
!
       pqwvi(:) = 0.0
       pqwvd(:) = 0.0
       pqcwi(:) = 0.0
       pqcwd(:) = 0.0
       pqcwdacc(:) = 0.0
       pqcii(:) = 0.0
       pqcid(:) = 0.0
       pqrwi(:) = 0.0
       pqrwd(:) = 0.0
       pqswi(:) = 0.0
       pqswd(:) = 0.0
       pqhwi(:) = 0.0
       pqhwd(:) = 0.0
       pqhli(:) = 0.0
       pqhld(:) = 0.0
       pqlwsi(:) = 0.0
       pqlwsd(:) = 0.0
       pqlwhi(:) = 0.0
       pqlwhd(:) = 0.0
       pqlwlghi(:) = 0.0
       pqlwlghd(:) = 0.0
       pqlwlghli(:) = 0.0
       pqlwlghld(:) = 0.0
       pqlwhli(:) = 0.0
       pqlwhld(:) = 0.0


!
!  Vapor
!
      IF ( warmonly < 0.5 ) THEN
      do mgs = 1,ngscnt
      
! NOTE: ANY CHANGES HERE ALSO NEED TO GO INTO THE RESUM FARTHER DOWN!
      pqwvi(mgs) =    &
     &  -Min(0.0, qrcev(mgs))   &
     &  -Min(0.0, qhcev(mgs))   &
     &  -Min(0.0, qhlcev(mgs))   &
     &  -Min(0.0, qscev(mgs))   &
!     >  +il5(mgs)*(-qhsbv(mgs) - qhlsbv(mgs) )   &
     &  -qhsbv(mgs) - qhlsbv(mgs)   &
     &  -qssbv(mgs)    &
     &  -il5(mgs)*qisbv(mgs)
      
      pqwvd(mgs) =     &
     &  -Max(0.0, qrcev(mgs))   &
     &  -Max(0.0, qhcev(mgs))   &
     &  -Max(0.0, qhlcev(mgs))   &
     &  -Max(0.0, qscev(mgs))   &
     &  +il5(mgs)*(-qiint(mgs)   &
     &  -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs))   &
     &  -il5(mgs)*qidpv(mgs)  
      
      end do

      ELSEIF ( warmonly < 0.8 ) THEN
      do mgs = 1,ngscnt
      pqwvi(mgs) =    &
     &  -Min(0.0, qrcev(mgs)) &
     &  -il5(mgs)*qisbv(mgs)
      pqwvd(mgs) =     &
     &  +il5(mgs)*(-qiint(mgs)   &
!     &  -qhdpv(mgs) ) & !- qhldpv(mgs))   &
     &  -qhdpv(mgs) - qhldpv(mgs))   &
!     &  -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs))   &
     &  -Max(0.0, qrcev(mgs))     &
     &  -il5(mgs)*qidpv(mgs)  
      end do

      ELSE
      do mgs = 1,ngscnt
      pqwvi(mgs) =    &
     &  -Min(0.0, qrcev(mgs))
      pqwvd(mgs) =     &
     &  -Max(0.0, qrcev(mgs))
      end do

      ENDIF ! warmonly
!
!  Cloud water
!
      do mgs = 1,ngscnt

      pqcwi(mgs) =  (0.0) + qwcnr(mgs) - qwshw(mgs)

      IF ( warmonly < 0.5 ) THEN
      pqcwd(mgs) =    &
     &  il5(mgs)*(-qiacw(mgs)-qwfrz(mgs)-qwctfz(mgs))   &
     &  -il5(mgs)*(qiihr(mgs))   &
     &  -qracw(mgs) -qsacw(mgs) -qrcnw(mgs) -qhacw(mgs) - qhlacw(mgs)  !&
!     &  -il5(mgs)*(qwfrzp(mgs))
      ELSEIF ( warmonly < 0.8 ) THEN
      pqcwd(mgs) =    &
     &  il5(mgs)*(-qiacw(mgs)-qwfrz(mgs)-qwctfz(mgs))   &
     &  -il5(mgs)*(qiihr(mgs))   &
     &  -qracw(mgs) -qrcnw(mgs) -qhacw(mgs) -qhlacw(mgs)
      ELSE
      pqcwd(mgs) =    &
     &  -qracw(mgs) - qrcnw(mgs)
      ENDIF


      IF ( pqcwd(mgs) .lt. 0.0 .and. -pqcwd(mgs)*dtp .gt. qx(mgs,lc) ) THEN

       frac = -Max(0.0,qx(mgs,lc))/(pqcwd(mgs)*dtp)
       pqcwd(mgs) = -qx(mgs,lc)*dtpinv

        qiacw(mgs)   = frac*qiacw(mgs)
!        qwfrzp(mgs)  = frac*qwfrzp(mgs)
!        qwctfzp(mgs) = frac*qwctfzp(mgs)
        qwfrzc(mgs)  = frac*qwfrzc(mgs)
        qwfrz(mgs)  = frac*qwfrz(mgs)
        qwctfzc(mgs) = frac*qwctfzc(mgs)
        qwctfz(mgs) = frac*qwctfz(mgs)
        qracw(mgs)   = frac*qracw(mgs)
        qsacw(mgs)   = frac*qsacw(mgs)
        qhacw(mgs)   = frac*qhacw(mgs)
        vhacw(mgs)   = frac*vhacw(mgs)
        qrcnw(mgs)   = frac*qrcnw(mgs)
        qwfrzp(mgs)  = frac*qwfrzp(mgs)
        IF ( lhl .gt. 1 ) THEN
          qhlacw(mgs)   = frac*qhlacw(mgs)
          vhlacw(mgs)   = frac*vhlacw(mgs)
        ENDIF
!        IF ( lzh .gt. 1 ) zhacw(mgs) = frac*zhacw(mgs)

!       STOP
      ENDIF
      

      end do
!
!  Cloud ice
!
      IF ( warmonly < 0.5 ) THEN

      do mgs = 1,ngscnt
      IF ( ffrzs < 1.0 ) THEN
      pqcii(mgs) =     &
     &   il5(mgs)*qicicnt(mgs)    &
     &  +il5(mgs)*((1.0-cwfrz2snowfrac)*qwfrzc(mgs)+qwctfzc(mgs))   &
     &  +il5(mgs)*(qicichr(mgs))  &
     &  +qsmul(mgs)               &
     &  +qhmul1(mgs) + qhlmul1(mgs)   &
     & + qsplinter(mgs) + qsplinter2(mgs)
!     > + cimas0*nsplinter*(crfrzf(mgs) + crfrz(mgs))/rho0(mgs)
      ENDIF
       
       pqcii(mgs) = pqcii(mgs)*(1.0 - ffrzs) &
     &  +il5(mgs)*qidpv(mgs)    &
     &  +il5(mgs)*qiacw(mgs)
       
      pqcid(mgs) =     &
     &   il5(mgs)*(-qscni(mgs) - qscnvi(mgs)    & ! -qwaci(mgs)    &
     &  -qraci(mgs)    &
     &  -qsaci(mgs) )   &
     &  -qhaci(mgs)   &
     &  -qhlaci(mgs)    &
     &  +il5(mgs)*qisbv(mgs)    &
     &  +(1.-il5(mgs))*qimlr(mgs)   &
     &  - qhcni(mgs)
      end do

      
      ELSEIF ( warmonly < 0.8 ) THEN

      do mgs = 1,ngscnt
      pqcii(mgs) =     &
     &   il5(mgs)*qicicnt(mgs)*(1. - ffrzs)    &
     &  +il5(mgs)*((1.0-cwfrz2snowfrac)*qwfrzc(mgs)+qwctfzc(mgs))*(1. - ffrzs)   &
     &  +il5(mgs)*(qicichr(mgs))*(1. - ffrzs)   &
!     &  +il5(mgs)*(qicichr(mgs))   &
!     &  +qsmul(mgs)               &
     &  +qhmul1(mgs) + qhlmul1(mgs)   &
     & + qsplinter(mgs) + qsplinter2(mgs) &
     &  +il5(mgs)*qidpv(mgs)    &
     &  +il5(mgs)*qiacw(mgs)  ! & ! (qiacwi(mgs)+qwacii(mgs))   &
!     &  +il5(mgs)*(qwfrzc(mgs)+qwctfzc(mgs))   &
!     &  +il5(mgs)*(qicichr(mgs))   &
!     &  +qsmul(mgs)               &
!     &  +qhmul1(mgs) + qhlmul1(mgs)   &
!     & + qsplinter(mgs) + qsplinter2(mgs)

      pqcid(mgs) =     &
!     &   il5(mgs)*(-qscni(mgs) - qscnvi(mgs)    & ! -qwaci(mgs)    &
!     &  -qraci(mgs)    &
!     &  -qsaci(mgs) )   &
!     &  -qhaci(mgs)   &
!     &  -qhlaci(mgs)    &
     &  +il5(mgs)*qisbv(mgs)    &
     &  +(1.-il5(mgs))*qimlr(mgs)  ! &
!     &  - qhcni(mgs)
      end do

      ENDIF
!
!  Rain
!

      do mgs = 1,ngscnt
      IF ( warmonly < 0.5 ) THEN
      pqrwi(mgs) =     &
     &   qracw(mgs) + qrcnw(mgs) + Max(0.0, qrcev(mgs))   &
     &  +(1-il5(mgs))*(   &
     &    -qhmlr(mgs)                 &            !null at this point when wet snow/graupel included
     &    -qsmlr(mgs)  - qhlmlr(mgs)     &
     &    -qimlr(mgs))   &
!     &    -qsshr(mgs)       &                      !null at this point when wet snow/graupel included
!     &    -qhshr(mgs)       &                      !null at this point when wet snow/graupel included
!     &    -qhlshr(mgs)      &
     & - qrshr(mgs)

      pqrwd(mgs) =     &
     &  il5(mgs)*(-qiacr(mgs)-qrfrz(mgs))    &
     &  - qsacr(mgs) - qhacr(mgs) - qhlacr(mgs) - qwcnr(mgs)   &
     &  + Min(0.0,qrcev(mgs))
      ELSEIF ( warmonly < 0.8 ) THEN
      pqrwi(mgs) =     &
     &   qracw(mgs) + qrcnw(mgs) + Max(0.0, qrcev(mgs))   &
     &  +(1-il5(mgs))*(   &
     &    -qhlmlr(mgs)                 &            !null at this point when wet snow/graupel included
     &    -qhmlr(mgs)  )               &            !null at this point when wet snow/graupel included
     &    -qhshr(mgs)                 &           !null at this point when wet snow/graupel included
     &    -qhlshr(mgs)                            !null at this point when wet snow/graupel included
      pqrwd(mgs) =     &
     &  il5(mgs)*(-qrfrz(mgs))    &
     &   - qhacr(mgs)    &
     &   - qhlacr(mgs)    &
     &  + Min(0.0,qrcev(mgs))
      ELSE
      pqrwi(mgs) =     &
     &   qracw(mgs) + qrcnw(mgs) + Max(0.0, qrcev(mgs))
      pqrwd(mgs) =  Min(0.0,qrcev(mgs))
      ENDIF ! warmonly


 !      IF ( pqrwd(mgs) .lt. 0.0 .and. -(pqrwd(mgs) + pqrwi(mgs))*dtp .gt. qx(mgs,lr)  ) THEN
      IF ( pqrwd(mgs) .lt. 0.0 .and. -(pqrwd(mgs) + pqrwi(mgs))*dtp .gt. qx(mgs,lr)  ) THEN

       frac = (-qx(mgs,lr) + pqrwi(mgs)*dtp)/(pqrwd(mgs)*dtp)
!       pqrwd(mgs) = -qx(mgs,lr)*dtpinv  + pqrwi(mgs)

       pqwvi(mgs) = pqwvi(mgs)    &
     &  + Min(0.0, qrcev(mgs))   &
     &  - frac*Min(0.0, qrcev(mgs))
       pqwvd(mgs) =  pqwvd(mgs)   &
     &  + Max(0.0, qrcev(mgs))   &
     &  - frac*Max(0.0, qrcev(mgs))

       qiacr(mgs)  = frac*qiacr(mgs)
       qiacrf(mgs) = frac*qiacrf(mgs)
       qiacrs(mgs) = frac*qiacrs(mgs)
       viacrf(mgs) = frac*viacrf(mgs)
       qrfrz(mgs)  = frac*qrfrz(mgs) 
       qrfrzs(mgs) = frac*qrfrzs(mgs) 
       qrfrzf(mgs) = frac*qrfrzf(mgs)
       vrfrzf(mgs) = frac*vrfrzf(mgs)
       qsacr(mgs)  = frac*qsacr(mgs)
       qhacr(mgs)  = frac*qhacr(mgs)
       vhacr(mgs)  = frac*vhacr(mgs)
       qrcev(mgs)  = frac*qrcev(mgs)
       qhlacr(mgs) = frac*qhlacr(mgs)
       vhlacr(mgs) = frac*vhlacr(mgs)
!       qhcev(mgs)  = frac*qhcev(mgs)


      IF ( warmonly < 0.5 ) THEN
       pqrwd(mgs) =     &
     &  il5(mgs)*(-qiacr(mgs)-qrfrz(mgs) - qsacr(mgs))    &
     &  - qhacr(mgs) - qhlacr(mgs) - qwcnr(mgs)   &
     &  + Min(0.0,qrcev(mgs))
      ELSEIF ( warmonly < 0.8 ) THEN
      pqrwd(mgs) =     &
     &  il5(mgs)*(-qrfrz(mgs))    &
     &   - qhacr(mgs)    &
     &   - qhlacr(mgs)    &
     &  + Min(0.0,qrcev(mgs))
      ELSE
       pqrwd(mgs) =  Min(0.0,qrcev(mgs))
      ENDIF ! warmonly

!
! Resum for vapor since qrcev has changed
!
      IF ( qrcev(mgs) .ne. 0.0 ) THEN
       pqwvi(mgs) =    &
     &  -Min(0.0, qrcev(mgs))   &
     &  -Min(0.0, qhcev(mgs))   &
     &  -Min(0.0, qhlcev(mgs))   &
     &  -Min(0.0, qscev(mgs))   &
!     >  +il5(mgs)*(-qhsbv(mgs)  - qhlsbv(mgs) )   &
     &  -qhsbv(mgs)  - qhlsbv(mgs)   &
     &  -qssbv(mgs)    &
     &  -il5(mgs)*qisbv(mgs) 
     
       pqwvd(mgs) =     &
     &  -Max(0.0, qrcev(mgs))   &
     &  -Max(0.0, qhcev(mgs))   &
     &  -Max(0.0, qhlcev(mgs))   &
     &  -Max(0.0, qscev(mgs))   &
     &  +il5(mgs)*(-qiint(mgs)   &
     &  -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs))   &
     &  -il5(mgs)*qidpv(mgs)  

       ENDIF


!       STOP
      ENDIF
      end do

      IF ( warmonly < 0.5 ) THEN

!
!  Snow
!
      do mgs = 1,ngscnt
      pqswi(mgs) =     &
     &   il5(mgs)*(qscni(mgs)+qsaci(mgs)+qsdpv(mgs)   &
     &   + qscnvi(mgs)                        &
     &   + ifrzs*(qiacrs(mgs) + qrfrzs(mgs))  &
     &   + il5(mgs)*(( qwfrzc(mgs) + qwctfzc(mgs) + qicichr(mgs) )*ffrzs   &
     &   +  (1.0 - ffrzs)*cwfrz2snowfrac*qwfrz(mgs) ) &
     &   + il2(mgs)*qsacr(mgs))   &
     &   + il5(mgs)*qicicnt(mgs)*ffrzs        &
     &   + il3(mgs)*(qiacrf(mgs)+qracif(mgs)) & ! only applies for ipconc <= 3
     &   + Max(0.0, qscev(mgs))   &
     &   + qsacw(mgs) + qscnh(mgs) &
     &  + ffrzs*(qsmul(mgs)               &
     &  +qhmul1(mgs) + qhlmul1(mgs)   &
     & + qsplinter(mgs) + qsplinter2(mgs))
      pqswd(mgs) =    &
!     >  -qfacs(mgs) ! -qwacs(mgs)   &
     &  -qracs(mgs)*(1-il2(mgs)) -qhacs(mgs) - qhlacs(mgs)   &
     &  -qhcns(mgs)   &
     &  +(1-il5(mgs))*qsmlr(mgs) + qsshr(mgs)    &    !null at this point when wet snow included
!     >  +il5(mgs)*(qssbv(mgs))   &
     &  + (qssbv(mgs))   &
     &  + Min(0.0, qscev(mgs))  &
     &  -qsmul(mgs)
      
      
      IF ( imixedphase == 0 .and. pqswd(mgs) .lt. 0.0  ) THEN
        IF ( qx(mgs,ls) + dtp*(pqswi(mgs) + pqswd(mgs)) < 0.0 ) THEN
         frac = (-qx(mgs,ls) + pqswi(mgs)*dtp)/(pqswd(mgs)*dtp)
         
           pqswd(mgs) = frac*pqswd(mgs)
           
           qracs(mgs)  = frac*qracs(mgs) ! only used for single moment at this time
           qhacs(mgs)  = frac*qhacs(mgs) 
           qhlacs(mgs) = frac*qhlacs(mgs)
           qhcns(mgs)  = frac*qhcns(mgs) 
           qsmlr(mgs)  = frac*qsmlr(mgs) 
           qsshr(mgs)  = frac*qsshr(mgs) 
           qssbv(mgs)  = frac*qssbv(mgs) 
           qsmul(mgs)  = frac*qsmul(mgs) 
           IF ( qscev(mgs) < 0.0 ) qscev(mgs) = frac*qscev(mgs)

        ENDIF
      ENDIF
      
      pqcii(mgs) =  pqcii(mgs) &
     &  + (1. - ifrzs)*qrfrzs(mgs) &
     &  + (1. - ifrzs)*qiacrs(mgs)
      
      end do 
      
!
!  Graupel
!
      do mgs = 1,ngscnt
      pqhwi(mgs) =    &
     &  +il5(mgs)*(ffrzh*ifrzg*qrfrzf(mgs)  + (1-il3(mgs))*ffrzh*ifiacrg*(qiacrf(mgs)+qracif(mgs)))   &
     &  + (1-il2(mgs))*(qracs(mgs) + qsacr(mgs))  & ! only used for ipconc < 3
     &  +il5(mgs)*(qhdpv(mgs))   &
     &  +Max(0.0, qhcev(mgs))   &
     &  +qhacr(mgs)+qhacw(mgs)   &
     &  +qhacs(mgs)+qhaci(mgs)   &
     &  + f2h*qhcns(mgs) + f2h*qhcni(mgs) + qhcnhl(mgs)
      pqhwd(mgs) =     &
     &   qhshr(mgs)                &    !null at this point when wet graupel included
     &  +(1-il5(mgs))*qhmlr(mgs)   &    !null at this point when wet graupel included
!     >  +il5(mgs)*qhsbv(mgs)   &
     &  + qhsbv(mgs)   &
     &  + Min(0.0, qhcev(mgs))   &
     &  -qhmul1(mgs) - qhlcnh(mgs) - qscnh(mgs)  &
     &  - ffrzh*(qsplinter(mgs) + qsplinter2(mgs))
!     > - cimas0*nsplinter*(crfrzf(mgs) + crfrz(mgs))/rho0(mgs)

      end do


!
!  Hail
!
      IF ( lhl .gt. 1 ) THEN

      do mgs = 1,ngscnt
      pqhli(mgs) =    &
     &  +il5(mgs)*(qhldpv(mgs) + ((1.0-ifrzg)*qrfrzf(mgs) + (1.0-ifiacrg)*(qiacrf(mgs)+ qracif(mgs))))   &
     &  +Max(0.0, qhlcev(mgs))   &
     &  +qhlacr(mgs)+qhlacw(mgs)   &
     &  +qhlacs(mgs)+qhlaci(mgs)   &
     &  + qhlcnh(mgs)
      pqhld(mgs) =     &
     &   qhlshr(mgs)    &
     &  +(1-il5(mgs))*qhlmlr(mgs)    &
!     >  +il5(mgs)*qhlsbv(mgs)   &
     &  + qhlsbv(mgs)   &
     &  + Min(0.0, qhlcev(mgs))   &
     &  -qhlmul1(mgs) - qhcnhl(mgs)

      IF ( imixedphase == 0 ) THEN
      frac = 0.0
      IF ( qx(mgs,lhl) + dtp*(pqhli(mgs) + pqhld(mgs)) < 0.0 ) THEN
        ! rescale depletion

         frac = (-qx(mgs,lhl) + pqhli(mgs)*dtp)/(pqhld(mgs)*dtp)
         
         qhlmlr(mgs) = frac*qhlmlr(mgs)
         qhlsbv(mgs) = frac*qhlsbv(mgs)
         qhcnhl(mgs) = frac*qhcnhl(mgs)
         qhlmul1(mgs) = frac*qhlmul1(mgs)
         IF ( qhlcev(mgs) < 0.0 ) qhlcev(mgs) = frac*qhlcev(mgs)
           
         pqhld(mgs) = frac*pqhld(mgs)
           
      ENDIF
      ENDIF


      end do
      
      ENDIF ! lhl

      ELSEIF ( warmonly < 0.8 ) THEN
!
!  Graupel
!
      do mgs = 1,ngscnt
      pqhwi(mgs) =    &
     &  +il5(mgs)*ifrzg*(qrfrzf(mgs) )   &
     &  +il5(mgs)*(qhdpv(mgs))   &
     &  +qhacr(mgs)+qhacw(mgs)   
      pqhwd(mgs) =     &
     &   qhshr(mgs)                &    !null at this point when wet graupel included
     &  - qhlcnh(mgs)   &
     &  - qhmul1(mgs)   &
     &  - qsplinter(mgs) - qsplinter2(mgs) &
     &  +(1-il5(mgs))*qhmlr(mgs)        !null at this point when wet graupel included
       end do

!
!  Hail
!
      IF ( lhl .gt. 1 ) THEN

      do mgs = 1,ngscnt
      pqhli(mgs) =    &
     &  +il5(mgs)*(qhldpv(mgs) ) & ! + (1.0-ifrzg)*(qiacrf(mgs)+qrfrzf(mgs)  + qracif(mgs)))   &
     &  +il5(mgs)*(1.0-ifrzg)*(qrfrzf(mgs) )  &
     &  +qhlacr(mgs)+qhlacw(mgs)   &
!     &  +qhlacs(mgs)+qhlaci(mgs)   &
     &  + qhlcnh(mgs)
      pqhld(mgs) =     &
     &   qhlshr(mgs)    &
     &  +(1-il5(mgs))*qhlmlr(mgs)    &
!     >  +il5(mgs)*qhlsbv(mgs)   &
     &  + qhlsbv(mgs)   &
     &  -qhlmul1(mgs) - qhcnhl(mgs)

      end do

      ENDIF ! lhl

      ENDIF ! warmonly

!
!  Liquid water on snow and graupel
!

      vhmlr(:) = 0.0
      vhlmlr(:) = 0.0
      vhfzh(:) = 0.0
      vhlfzhl(:) = 0.0

      IF ( mixedphase ) THEN
      ELSE ! set arrays for non-mixedphase graupel
      
!        vhshdr(:) = 0.0
        vhmlr(:) = qhmlr(:) ! not actually volume, but treated as q in rate equation
!        vhsoak(:) = 0.0

!        vhlshdr(:) = 0.0
        vhlmlr(:) = qhlmlr(:) ! not actually volume, but treated as q in rate equation
!        vhlmlr(:) = rho0(:)*qhlmlr(:)/xdn(:,lhl) 
!        vhlsoak(:) = 0.0

      ENDIF  ! mixedphase



!
!  Snow volume
!
      IF ( lvol(ls) .gt. 1 ) THEN
      do mgs = 1,ngscnt
!      pvswi(mgs) = rho0(mgs)*( pqswi(mgs) )/xdn0(ls)

      pvswi(mgs) = rho0(mgs)*(    &
!aps     >   il5*qsfzs(mgs)/xdn(mgs,ls)   &
!aps     >  -il5*qsfzs(mgs)/xdn(mgs,lr)   &
     &  +il5(mgs)*(qscni(mgs)+qsaci(mgs)+qsdpv(mgs)   &
     &   + qscnvi(mgs) + (1. - ifrzs)*qiacrs(mgs) &
     &   + (1. - ifrzs)*qrfrzs(mgs)  &
     &  )/xdn0(ls)   &
     &    + (qsacr(mgs))/rimdn(mgs,ls) ) + vsacw(mgs)
!     >   + (qsacw(mgs) + qsacr(mgs))/rimdn(mgs,ls) )
      pvswd(mgs) = rho0(mgs)*( pqswd(mgs) )/xdn0(ls)  &
!     >  -qhacs(mgs)
!     >  -qhcns(mgs)
!     >  +(1-il5(mgs))*qsmlr(mgs) + qsshr(mgs)
!     >  +il5(mgs)*(qssbv(mgs))
     &   -rho0(mgs)*qsmul(mgs)/xdn0(ls)
!aps     >   +rho0(mgs)*(1-il5(mgs))*(
!aps     >             qsmlr(mgs)/xdn(mgs,ls)
!aps     >    +(qscev-qsmlr(mgs))/xdn(mgs,lr) )
      end do

!aps      IF (mixedphase) THEN
!aps        pvswd(mgs) = pvswd(mgs)
!aps     >   + rho0(mgs)*qsshr(mgs)/xdn(mgs,lr)
!aps      ENDIF

      ENDIF
!
!  Graupel volume
!
      IF ( lvol(lh) .gt. 1 ) THEN
      DO mgs = 1,ngscnt
!      pvhwi(mgs) = rho0(mgs)*( (pqhwi(mgs) )/xdn0(lh) )

!      pvhwi(mgs) = rho0(mgs)*( (pqhwi(mgs) - il5(mgs)*qrfrzf(mgs) )/xdn0(lh) !
!     :  +  il5(mgs)*qrfrzf(mgs)/rhofrz )

      pvhwi(mgs) = rho0(mgs)*(   &
     &  +il5(mgs)*( ifiacrg*ffrzh*qracif(mgs))/rhofrz   &
!erm     >  + il5(mgs)*qhfzh(mgs)/rhofrz !aps: or use xdnmx(lh)?   &
     &  + (  il5(mgs)*qhdpv(mgs)/qhdpvdn   &
     &     + (qhacs(mgs) + qhaci(mgs))/qhacidn ) )   &
     &  +   rho0(mgs)*Max(0.0, qhcev(mgs))/1000.   & ! only used in mixed phase: evaporation/condensation of liquid water coating
!     >     + qhacs(mgs) + qhaci(mgs) )/xdn0(ls) )   &
     &  + f2h*vhcns(mgs)   &
     &  + vhacr(mgs) + vhacw(mgs)  + vhfzh(mgs)   & ! qhacw(mgs)/rimdn(mgs,lh)
!     >  + vhfrh(mgs)   &
     &  + f2h*vhcni(mgs) + (ifiacrg*viacrf(mgs) + ifrzg*vrfrzf(mgs))*ffrzh
!     >  +qhacr(mgs)/raindn(mgs,lh) + qhacw(mgs)/rimdn(mgs,lh)
      
!      pvhwd(mgs) = rho0(mgs)*(pqhwd(mgs) )/xdn0(lh)

      pvhwd(mgs) = rho0(mgs)*(   &
!     >   qhshr(mgs)/xdn0(lr)   &
!     >  - il5(mgs)*qhfzh(mgs)/xdn(mgs,lr)   &
     &  +( (1-il5(mgs))*vhmlr(mgs)    &
!     >     +il5(mgs)*qhsbv(mgs)   &
     &     + qhsbv(mgs)   &
     &     + Min(0.0, qhcev(mgs))   &
     &     -qhmul1(mgs) )/xdn(mgs,lh) )   &
     &  - vhlcnh(mgs) + vhshdr(mgs) - vhsoak(mgs) - vscnh(mgs)

!      IF (mixedphase) THEN
!       pvhwd(mgs) = pvhwd(mgs) 
!     >  + rho0(mgs)*qhshr(mgs)/xdn(mgs,lh) !xdn(mgs,lr)
!      ENDIF

      IF ( .false. .and. ny .eq. 2 .and. kgs(mgs) .eq. 9 .and. igs(mgs) .eq. 19 ) THEN

      write(iunit,*)
      write(iunit,*)   'Graupel at ',igs(mgs),kgs(mgs)
!
      write(iunit,*)   il5(mgs)*qrfrzf(mgs), qrfrzf(mgs) - qrfrz(mgs)
      write(iunit,*)   il5(mgs)*qiacrf(mgs)
      write(iunit,*)   il5(mgs)*qracif(mgs)
      write(iunit,*)   'qhcns',qhcns(mgs)
      write(iunit,*)   'qhcni',qhcni(mgs)
      write(iunit,*)   il5(mgs)*(qhdpv(mgs))
      write(iunit,*)   'qhacr ',qhacr(mgs)
      write(iunit,*)   'qhacw', qhacw(mgs)
      write(iunit,*)   'qhacs', qhacs(mgs)
      write(iunit,*)   'qhaci', qhaci(mgs)
      write(iunit,*)   'pqhwi = ',pqhwi(mgs)
      write(iunit,*)
      write(iunit,*) 'qhcev',qhcev(mgs)
      write(iunit,*)
      write(iunit,*)   'qhshr',qhshr(mgs)
      write(iunit,*)  'qhmlr', (1-il5(mgs))*qhmlr(mgs)
      write(iunit,*)   'qhsbv', qhsbv(mgs)
      write(iunit,*)   'qhlcnh',-qhlcnh(mgs)
      write(iunit,*)   'qhmul1',-qhmul1(mgs)
      write(iunit,*)   'pqhwd = ', pqhwd(mgs)
      write(iunit,*)
      write(iunit,*)  'Volume'
      write(iunit,*)
      write(iunit,*)  'pvhwi',pvhwi(mgs)
      write(iunit,*)   'vhcns', vhcns(mgs)
      write(iunit,*)  'vhacr,vhacw',vhacr(mgs), vhacw(mgs) ! qhacw(mgs)/rimdn(mgs,lh)
      write(iunit,*)  'vhcni',vhcni(mgs)
      write(iunit,*)
      write(iunit,*)  'pvhwd',pvhwd(mgs)
      write(iunit,*)  'vhlcnh,vhshdr,vhsoak ', vhlcnh(mgs),  vhshdr(mgs), vhsoak(mgs)
      write(iunit,*)  'vhmlr', vhmlr(mgs)
      write(iunit,*)
!      write(iunit,*)
!      write(iunit,*)
!      write(iunit,*)
      write(iunit,*)  'Concentration'
      write(iunit,*)   pchwi(mgs),pchwd(mgs)
      write(iunit,*)  crfrzf(mgs)
      write(iunit,*)  chcns(mgs)
      write(iunit,*)  ciacrf(mgs)


      ENDIF


      ENDDO

      ENDIF
!
!
!

!
!  Hail volume
!
      IF ( lhl .gt. 1 ) THEN
      IF ( lvol(lhl) .gt. 1 ) THEN
      DO mgs = 1,ngscnt

      pvhli(mgs) = rho0(mgs)*(   &
     &  + (  il5(mgs)*(((1.0-ifiacrg)*ffrzh*qracif(mgs))/rhofrz  + qhldpv(mgs) )   &
!     &  +    Max(0.0, qhlcev(mgs))   &
!     &     + qhlacs(mgs) + qhlaci(mgs) )/xdnmn(lhl) )   & ! xdn0(ls) )   &
!     &     + qhlacs(mgs) + qhlaci(mgs) )/xdnmn(lh) )   &  ! yes, this is 'lh' on purpose
     &     + qhlacs(mgs) + qhlaci(mgs) )/500. )   &  ! changed to 500 instead of min graupel density to keep hail density from dropping too much
     &  +   rho0(mgs)*Max(0.0, qhlcev(mgs))/1000.   &
     &  + vhlcnhl(mgs) + ((1.0-ifiacrg)*ffrzh*viacrf(mgs) + (1.0-ifrzg)*ffrzh*vrfrzf(mgs))  & 
     &  + vhlacr(mgs) + vhlacw(mgs) + vhlfzhl(mgs) ! qhlacw(mgs)/rimdn(mgs,lhl)
      
      pvhld(mgs) = rho0(mgs)*(   &
     &  +(  qhlsbv(mgs)   &
     &     + Min(0.0, qhlcev(mgs))   &
     &     -qhlmul1(mgs) )/xdn(mgs,lhl) ) &
!     &   + vhlmlr(mgs)                    &
     &   + rho0(mgs)*(1-il5(mgs))*vhlmlr(mgs)/xdn(mgs,lhl)  &
     &   + vhlshdr(mgs) - vhlsoak(mgs)


      ENDDO
      
      ENDIF
      ENDIF


      if ( ndebug .ge. 1 ) then
      do mgs = 1,ngscnt
!
      ptotal(mgs) = 0.
      ptotal(mgs) = ptotal(mgs)     &
     &  + pqwvi(mgs) + pqwvd(mgs)   &
     &  + pqcwi(mgs) + pqcwd(mgs)   &
     &  + pqcii(mgs) + pqcid(mgs)   &
     &  + pqrwi(mgs) + pqrwd(mgs)   &
     &  + pqswi(mgs) + pqswd(mgs)   &
     &  + pqhwi(mgs) + pqhwd(mgs)   &
     &  + pqhli(mgs) + pqhld(mgs)
!

      
      
      ENDDO
      
      do mgs = 1,ngscnt

      if ( ( (ndebug .ge. 0  ) .and. abs(ptotal(mgs)) .gt. eqtot )   &
!      if ( (  abs(ptotal(mgs)) .gt. eqtot )
!     :    .or. pqswi(mgs)*dtp .gt. 1.e-3
!     :    .or. pqhwi(mgs)*dtp .gt. 1.e-3
!     :     .or. dtp*(pqrwi(mgs)+pqrwd(mgs)) .gt. 10.0e-3
!     :     .or. dtp*(pccii(mgs)+pccid(mgs)) .gt. 1.e7
!     :     .or. dtp*(pcipi(mgs)+pcipd(mgs)) .gt. 1.e7    &
     &  .or.  .not. (ptotal(mgs) .lt. 1.0 .and.  ptotal(mgs) .gt. -1.0)   & ! this line is basically checking for NaNs
     &              ) then
      write(iunit,*) 'YIKES! ','ptotal1',mgs,igs(mgs),jgs,   &
     &       kgs(mgs),ptotal(mgs)

      write(iunit,*) 't7: ', t7(igs(mgs),jgs,kgs(mgs))
      write(iunit,*)  'cci,ccw,crw,rdia: ',cx(mgs,li),cx(mgs,lc),cx(mgs,lr),0.5*xdia(mgs,lr,1)
      write(iunit,*)  'qc,qi,qr : ',qx(mgs,lc),qx(mgs,li),qx(mgs,lr)
      write(iunit,*)  'rmas, qrcalc : ',xmas(mgs,lr),xmas(mgs,lr)*cx(mgs,lr)/rho0(mgs)
      write(iunit,*)  'vti,vtc,eiw,vtr: ',vtxbar(mgs,li,1),vtxbar(mgs,lc,1),eiw(mgs),vtxbar(mgs,lr,1)
      write(iunit,*)  'cidia,cwdia,qcmxd: ', xdia(mgs,li,1),xdia(mgs,lc,1),qcmxd(mgs)
      write(iunit,*)  'snow: ',qx(mgs,ls),cx(mgs,ls),swvent(mgs),vtxbar(mgs,ls,1),xdia(mgs,ls,1)
      write(iunit,*)  'graupel: ',qx(mgs,lh),cx(mgs,lh),hwvent(mgs),vtxbar(mgs,lh,1),xdia(mgs,lh,1)
      IF ( lhl .gt. 1 ) write(iunit,*)  'hail: ',qx(mgs,lhl),cx(mgs,lhl),hlvent(mgs),vtxbar(mgs,lhl,1),xdia(mgs,lhl,1)


      write(iunit,*)  'li: ',xdia(mgs,li,1),xdia(mgs,li,2),xmas(mgs,li),qx(mgs,li),   &
     &         vtxbar(mgs,li,1)


      write(iunit,*)  'rain cx,xv : ',cx(mgs,lr),xv(mgs,lr)
      write(iunit,*)  'temcg = ', temcg(mgs)

      write(iunit,*) 'v ', pqwvi(mgs) ,pqwvd(mgs)
      write(iunit,*) 'c ', pqcwi(mgs) ,pqcwd(mgs)
      write(iunit,*) 'ci', pqcii(mgs) ,pqcid(mgs)
      write(iunit,*) 'r ', pqrwi(mgs) ,pqrwd(mgs)
      write(iunit,*) 's ', pqswi(mgs) ,pqswd(mgs)
      write(iunit,*) 'h ', pqhwi(mgs) ,pqhwd(mgs)
      write(iunit,*) 'hl', pqhli(mgs) ,pqhld(mgs)
       tmp =  pqwvi(mgs) + pqwvd(mgs)   &
     &  + pqcwi(mgs) + pqcwd(mgs)   &
     &  + pqcii(mgs) + pqcid(mgs)   &
     &  + pqrwi(mgs) + pqrwd(mgs)   &
     &  + pqswi(mgs) + pqswd(mgs)   &
     &  + pqhwi(mgs) + pqhwd(mgs)   &
     &  + pqhli(mgs) + pqhld(mgs)

      write(iunit,*) 'total = ',tmp
      write(iunit,*) 'END OF OUTPUT OF SOURCE AND SINK'

!
!  print production terms
!
      write(iunit,*)
      write(iunit,*)   'Vapor'
!
      write(iunit,*)   -Min(0.0,qrcev(mgs))
      write(iunit,*)   -il5(mgs)*qhsbv(mgs)
      write(iunit,*)   -il5(mgs)*qhlsbv(mgs)
      write(iunit,*)   -il5(mgs)*qssbv(mgs)
      write(iunit,*)   -il5(mgs)*qisbv(mgs)
      write(iunit,*)    'pqwvi= ', pqwvi(mgs)
      write(iunit,*)   -Max(0.0,qrcev(mgs))
      write(iunit,*)   -Max(0.0,qhcev(mgs))
      write(iunit,*)   -Max(0.0,qhlcev(mgs))
      write(iunit,*)   -Max(0.0,qscev(mgs))
      write(iunit,*)   -il5(mgs)*qiint(mgs)
      write(iunit,*)   -il5(mgs)*qhdpv(mgs)
      write(iunit,*)   -il5(mgs)*qhldpv(mgs)
      write(iunit,*)   -il5(mgs)*qsdpv(mgs)
      write(iunit,*)   -il5(mgs)*qidpv(mgs)
      write(iunit,*)    'pqwvd = ', pqwvd(mgs)
!
      write(iunit,*)
      write(iunit,*)   'Cloud ice'
!
      write(iunit,*)   il5(mgs)*qicicnt(mgs)
      write(iunit,*)   il5(mgs)*qidpv(mgs)
      write(iunit,*)   il5(mgs)*qiacw(mgs)
      write(iunit,*)   il5(mgs)*qwfrzc(mgs)
      write(iunit,*)   il5(mgs)*qwctfzc(mgs)
      write(iunit,*)   il5(mgs)*qicichr(mgs)
      write(iunit,*)   qhmul1(mgs)
      write(iunit,*)   qhlmul1(mgs)
      write(iunit,*)   'pqcii = ', pqcii(mgs)
      write(iunit,*)   -il5(mgs)*qscni(mgs)
      write(iunit,*)   -il5(mgs)*qscnvi(mgs)
      write(iunit,*)   -il5(mgs)*qraci(mgs)
      write(iunit,*)   -il5(mgs)*qsaci(mgs)
      write(iunit,*)   -il5(mgs)*qhaci(mgs)
      write(iunit,*)   -il5(mgs)*qhlaci(mgs)
      write(iunit,*)   il5(mgs)*qisbv(mgs)
      write(iunit,*)   (1.-il5(mgs))*qimlr(mgs)
      write(iunit,*)   -il5(mgs)*qhcni(mgs)
      write(iunit,*)   'pqcid = ', pqcid(mgs)
      write(iunit,*)   ' Conc:'
      write(iunit,*)   pccii(mgs),pccid(mgs)
      write(iunit,*)   il5(mgs),cicint(mgs)
      write(iunit,*)   cwfrzc(mgs),cwctfzc(mgs)
      write(iunit,*)   cicichr(mgs)
      write(iunit,*)   chmul1(mgs)
      write(iunit,*)   chlmul1(mgs)
      write(iunit,*)   csmul(mgs)
!
!
!
!
      write(iunit,*)
      write(iunit,*)   'Cloud water'
!
      write(iunit,*)   'pqcwi =', pqcwi(mgs)
      write(iunit,*)   -il5(mgs)*qiacw(mgs)
      write(iunit,*)   -il5(mgs)*qwfrzc(mgs)
      write(iunit,*)   -il5(mgs)*qwctfzc(mgs)
!      write(iunit,*)   -il5(mgs)*qwfrzp(mgs)
!      write(iunit,*)   -il5(mgs)*qwctfzp(mgs)
      write(iunit,*)   -il5(mgs)*qiihr(mgs)
      write(iunit,*)   -il5(mgs)*qicichr(mgs)
      write(iunit,*)   -il5(mgs)*qipiphr(mgs)
      write(iunit,*)   -qracw(mgs)
      write(iunit,*)   -qsacw(mgs)
      write(iunit,*)   -qrcnw(mgs)
      write(iunit,*)   -qhacw(mgs)
      write(iunit,*)   -qhlacw(mgs)
      write(iunit,*)   'pqcwd = ', pqcwd(mgs)


      write(iunit,*)
      write(iunit,*)  'Concentration:'
      write(iunit,*)   -cautn(mgs)
      write(iunit,*)   -cracw(mgs)
      write(iunit,*)   -csacw(mgs)
      write(iunit,*)   -chacw(mgs)
      write(iunit,*)  -ciacw(mgs)
      write(iunit,*)  -cwfrzp(mgs)
      write(iunit,*)  -cwctfzp(mgs)
      write(iunit,*)  -cwfrzc(mgs)
      write(iunit,*)  -cwctfzc(mgs)
      write(iunit,*)   pccwd(mgs)
!
      write(iunit,*)
      write(iunit,*)      'Rain '
!
      write(iunit,*)      qracw(mgs)
      write(iunit,*)      qrcnw(mgs)
      write(iunit,*)      Max(0.0, qrcev(mgs))
      write(iunit,*)       -(1-il5(mgs))*qhmlr(mgs)
      write(iunit,*)       -(1-il5(mgs))*qhlmlr(mgs)
      write(iunit,*)       -(1-il5(mgs))*qsmlr(mgs)
      write(iunit,*)       -(1-il5(mgs))*qimlr(mgs)
      write(iunit,*)       -qrshr(mgs)
      write(iunit,*)       'pqrwi = ', pqrwi(mgs)    
      write(iunit,*)        -qsshr(mgs)     
      write(iunit,*)        -qhshr(mgs)     
      write(iunit,*)        -qhlshr(mgs)
      write(iunit,*)        -il5(mgs)*qiacr(mgs),qiacr(mgs), qiacrf(mgs)
      write(iunit,*)        -il5(mgs)*qrfrz(mgs)
      write(iunit,*)        -qsacr(mgs)
      write(iunit,*)        -qhacr(mgs)
      write(iunit,*)        -qhlacr(mgs)
      write(iunit,*)        qrcev(mgs)
      write(iunit,*)       'pqrwd = ', pqrwd(mgs) 
      write(iunit,*)        'qrzfac = ', qrzfac(mgs)
!
      
      write(iunit,*)
      write(iunit,*)  'Rain concentration'
      write(iunit,*)  pcrwi(mgs) 
      write(iunit,*)    crcnw(mgs)
      write(iunit,*)    1-il5(mgs)
      write(iunit,*)   -chmlr(mgs),-csmlr(mgs)
      write(iunit,*)     -crshr(mgs)
      write(iunit,*)  pcrwd(mgs) 
      write(iunit,*)    il5(mgs)
      write(iunit,*)   -ciacr(mgs),-crfrz(mgs) 
      write(iunit,*)   -csacr(mgs),-chacr(mgs)
      write(iunit,*)   +crcev(mgs)
      write(iunit,*)   cracr(mgs)
!      write(iunit,*)   -il5(mgs)*ciracr(mgs)


      write(iunit,*)
      write(iunit,*)   'Snow'
!
      write(iunit,*)        il5(mgs)*qscni(mgs), qscnvi(mgs)
      write(iunit,*)        il5(mgs)*qsaci(mgs)
      write(iunit,*)        il5(mgs)*qrfrzs(mgs)
      write(iunit,*)        il5(mgs)*qiacrs(mgs),il3(mgs)*(qiacrf(mgs)+qracif(mgs)),il3(mgs),qiacrf(mgs),qracif(mgs)
      write(iunit,*)        il5(mgs)*qsdpv(mgs), qscev(mgs)
      write(iunit,*)        qsacw(mgs)
      write(iunit,*)        qsacr(mgs), qscnh(mgs)
       write(iunit,*)        'pqswi = ',pqswi(mgs)
      write(iunit,*)        -qhcns(mgs)
      write(iunit,*)        -qracs(mgs)
      write(iunit,*)        -qhacs(mgs)
      write(iunit,*)        -qhlacs(mgs)
      write(iunit,*)       (1-il5(mgs))*qsmlr(mgs)
      write(iunit,*)       qsshr(mgs)
!      write(iunit,*)       qsshrp(mgs)
      write(iunit,*)       il5(mgs)*(qssbv(mgs))
      write(iunit,*)       'pqswd = ', pqswd(mgs)
      write(iunit,*)   -qracs(mgs)*(1-il2(mgs)) , qhacs(mgs) , qhlacs(mgs)   
      write(iunit,*)   -qhcns(mgs)   
      write(iunit,*)   +(1-il5(mgs))*qsmlr(mgs) , qsshr(mgs)     
      write(iunit,*)   (qssbv(mgs))   
      write(iunit,*)   Min(0.0, qscev(mgs))  
      write(iunit,*)   -qsmul(mgs)
!
!
      write(iunit,*)
      write(iunit,*)   'Graupel'
!
      write(iunit,*)   il5(mgs)*qrfrzf(mgs), qrfrzf(mgs) - qrfrz(mgs)
      write(iunit,*)   il5(mgs)*qiacrf(mgs)
      write(iunit,*)   il5(mgs)*qracif(mgs)
      write(iunit,*)   qhcns(mgs)
      write(iunit,*)   qhcni(mgs)
      write(iunit,*)   il5(mgs)*(qhdpv(mgs))
      write(iunit,*)   qhacr(mgs)
      write(iunit,*)   qhacw(mgs)
      write(iunit,*)   qhacs(mgs)
      write(iunit,*)   qhaci(mgs)
      write(iunit,*)   'pqhwi = ',pqhwi(mgs)
      write(iunit,*)
      write(iunit,*)   qhshr(mgs)
      write(iunit,*)   (1-il5(mgs))*qhmlr(mgs)
      write(iunit,*)   il5(mgs),qhsbv(mgs)
      write(iunit,*)   -qhlcnh(mgs)
      write(iunit,*)   -qhmul1(mgs)
      write(iunit,*)   'pqhwd = ', pqhwd(mgs)
      write(iunit,*)  'Concentration'
      write(iunit,*)   pchwi(mgs),pchwd(mgs)
      write(iunit,*)  crfrzf(mgs)
      write(iunit,*)  chcns(mgs)
      write(iunit,*)  ciacrf(mgs)

!
      write(iunit,*)
      write(iunit,*)   'Hail'
!
      write(iunit,*)   qhlcnh(mgs)
      write(iunit,*)   il5(mgs)*(qhldpv(mgs))
      write(iunit,*)   qhlacr(mgs)
      write(iunit,*)   qhlacw(mgs)
      write(iunit,*)   qhlacs(mgs)
      write(iunit,*)   qhlaci(mgs)
      write(iunit,*)   pqhli(mgs)
      write(iunit,*)
      write(iunit,*)   qhlshr(mgs)
      write(iunit,*)   (1-il5(mgs))*qhlmlr(mgs)
      write(iunit,*)   il5(mgs)*qhlsbv(mgs)
      write(iunit,*)   pqhld(mgs)
      write(iunit,*)  'Concentration'
      write(iunit,*)   pchli(mgs),pchld(mgs)
      write(iunit,*)  chlcnh(mgs)
!
!  Balance and checks for continuity.....within machine precision...
!
!
      write(iunit,*) 'END OF OUTPUT OF SOURCE AND SINK'
      write(iunit,*) 'PTOTAL',ptotal(mgs)
!
      end if ! ptotal out of bounds or NaN
!
      end do
!

      end if ! ( nstep/12*12 .eq. nstep )

!
!  latent heating from phase changes (except qcw, qci cond, and evap)
!
      do mgs = 1,ngscnt
      IF ( warmonly < 0.5 ) THEN
      pfrz(mgs) =    &
     &  (1-il5(mgs))*   &
     &  (qhmlr(mgs)+qsmlr(mgs)+qhlmlr(mgs))   & !+qhmlh(mgs))   &
     &  +il5(mgs)*(qhfzh(mgs)+qsfzs(mgs)+qhlfzhl(mgs))   &
     &  +il5(mgs)*(1-imixedphase)*(   &
     &   qsacw(mgs)+qhacw(mgs) + qhlacw(mgs)   &
     &  +qsacr(mgs)+qhacr(mgs) + qhlacr(mgs)   &
     &  +qsshr(mgs)   &
     &  +qhshr(mgs)   &
     &  +qhlshr(mgs) +qrfrz(mgs)+qiacr(mgs)  &
     &  )  &
     &  +il5(mgs)*(qwfrz(mgs)    &
     &  +qwctfz(mgs)+qiihr(mgs)   &
     &  +qiacw(mgs))
      pmlt(mgs) =    &
     &  (1-il5(mgs))*   &
     &  (qhmlr(mgs)+qsmlr(mgs)+qhlmlr(mgs))    !+qhmlh(mgs))   
      ! NOTE: psub is sum of sublimation and deposition
      psub(mgs) =    &
     &   il5(mgs)*(   &
     &  + qsdpv(mgs) + qhdpv(mgs)   &
     &  + qhldpv(mgs)    &
     &  + qidpv(mgs) + qisbv(mgs) )   &
     &   + qssbv(mgs)  + qhsbv(mgs) + qhlsbv(mgs)   &
     &  +il5(mgs)*(qiint(mgs))
      pvap(mgs) =    &
     &   qrcev(mgs) + qhcev(mgs) + qscev(mgs) + qhlcev(mgs)
      pevap(mgs) =    &
     &   Min(0.0,qrcev(mgs)) + Min(0.0,qhcev(mgs)) + Min(0.0,qscev(mgs)) + Min(0.0,qhlcev(mgs))
      ! NOTE: pdep is the deposition part only
      pdep(mgs) =    &
     &   il5(mgs)*(   &
     &  + qsdpv(mgs) + qhdpv(mgs)   &
     &  + qhldpv(mgs)    &
     &  + qidpv(mgs)  )   & 
     &  +il5(mgs)*(qiint(mgs))
      ELSEIF ( warmonly < 0.8 ) THEN
      pfrz(mgs) =    &
     &  (1-il5(mgs))*   &
     &  (qhmlr(mgs)+qhlmlr(mgs))   & !+qhmlh(mgs))   &
     &  +il5(mgs)*(qhfzh(mgs)+qhlfzhl(mgs))   &
     &  +il5(mgs)*(   &
     &  +qhshr(mgs)   &
     &  +qhlshr(mgs)   &
     &  +qrfrz(mgs)+qwfrz(mgs)   &
     &  +qwctfz(mgs)+qiihr(mgs)   &
     &  +qiacw(mgs)                &
     & +qhacw(mgs) + qhlacw(mgs)   &
     & +qhacr(mgs) + qhlacr(mgs)  ) 
      psub(mgs) =  0.0 +  &
     &   il5(mgs)*(   &
     &  + qhdpv(mgs)   &
     &  + qhldpv(mgs)    &
     &  + qidpv(mgs) + qisbv(mgs) )   &
     &  +il5(mgs)*(qiint(mgs))
      pvap(mgs) =    &
     &   qrcev(mgs) + qhcev(mgs) + qhlcev(mgs) ! + qscev(mgs) 
      ELSE
      pfrz(mgs) = 0.0
      psub(mgs) = 0.0
      pvap(mgs) = qrcev(mgs)
      ENDIF ! warmonly
      ptem(mgs) =    &
     &  (1./pi0(mgs))*   &
     &  (felfcp(mgs)*pfrz(mgs)   &
     &  +felscp(mgs)*psub(mgs)    &
     &  +felvcp(mgs)*pvap(mgs))
      thetap(mgs) = thetap(mgs) + dtp*ptem(mgs)
      ptem2(mgs) = ptem(mgs)
      IF ( eqtset > 2 ) THEN
        pipert(mgs) = pipert(mgs) + (felfpi(mgs)*pfrz(mgs)   &
     &  +felspi(mgs)*psub(mgs)    &
     &  +felvpi(mgs)*pvap(mgs))*dtp
      ENDIF
      end do




!
!  sum the sources and sinks for qwvp, qcw, qci, qrw, qsw
!
!
      do mgs = 1,ngscnt
      qwvp(mgs) = qwvp(mgs) +        &
     &   dtp*(pqwvi(mgs)+pqwvd(mgs))
      qx(mgs,lc) = qx(mgs,lc) +   &
     &   dtp*(pqcwi(mgs)+pqcwd(mgs))
      qx(mgs,lr) = qx(mgs,lr) +   &
     &   dtp*(pqrwi(mgs)+pqrwd(mgs))
      qx(mgs,li) = qx(mgs,li) +   &
     &   dtp*(pqcii(mgs)+pqcid(mgs))
      qx(mgs,ls) = qx(mgs,ls) +   &
     &   dtp*(pqswi(mgs)+pqswd(mgs))
      qx(mgs,lh) = qx(mgs,lh) +    &
     &   dtp*(pqhwi(mgs)+pqhwd(mgs))
      IF ( lhl .gt. 1 ) THEN
      qx(mgs,lhl) = qx(mgs,lhl) +    &
     &   dtp*(pqhli(mgs)+pqhld(mgs))
      ENDIF


      end do

! sum sources for particle volume

      IF ( ldovol ) THEN

      do mgs = 1,ngscnt

      IF ( lvol(ls) .gt. 1 ) THEN
      vx(mgs,ls) = vx(mgs,ls) +    &
     &   dtp*(pvswi(mgs)+pvswd(mgs))
      ENDIF

      IF ( lvol(lh) .gt. 1 ) THEN
      vx(mgs,lh) = vx(mgs,lh) +    &
     &   dtp*(pvhwi(mgs)+pvhwd(mgs))
!     >   rho0(mgs)*dtp*(pqhwi(mgs)+pqhwd(mgs))/xdn0(lh)
      ENDIF

      IF ( lhl .gt. 1 ) THEN
      IF ( lvol(lhl) .gt. 1 ) THEN
      vx(mgs,lhl) = vx(mgs,lhl) +    &
     &   dtp*(pvhli(mgs)+pvhld(mgs))
!     >   rho0(mgs)*dtp*(pqhwi(mgs)+pqhwd(mgs))/xdn0(lh)
      ENDIF
      ENDIF

      ENDDO

      ENDIF  ! ldovol

!
!
!
! concentrations
!
      if ( ipconc .ge. 1  ) then
      do mgs = 1,ngscnt
      cx(mgs,li) = cx(mgs,li) +   &
     &   dtp*(pccii(mgs)+pccid(mgs)) 
      cina(mgs) = cina(mgs) + pccin(mgs)*dtp
      IF ( ipconc .ge. 2 ) THEN
      cx(mgs,lc) = cx(mgs,lc) +   &
     &   dtp*(pccwi(mgs)+pccwd(mgs))
      ENDIF
      IF ( ipconc .ge. 3 ) THEN
      cx(mgs,lr) = cx(mgs,lr) +   &
     &   dtp*(pcrwi(mgs)+pcrwd(mgs))
      ENDIF
      IF ( ipconc .ge. 4 ) THEN
      cx(mgs,ls) = cx(mgs,ls) +   &
     &   dtp*(pcswi(mgs)+pcswd(mgs))
      ENDIF
      IF ( ipconc .ge. 5 ) THEN
      cx(mgs,lh) = cx(mgs,lh) +    &
     &   dtp*(pchwi(mgs)+pchwd(mgs))
       IF ( lhl .gt. 1 ) THEN
        cx(mgs,lhl) = cx(mgs,lhl) +    &
     &     dtp*(pchli(mgs)+pchld(mgs))


        
        
       ENDIF
      ENDIF
      end do
      end if


      IF ( has_wetscav ) THEN
        DO mgs = 1,ngscnt
         evapprod2d(igs(mgs),kgs(mgs)) = -(qrcev(mgs) + qssbv(mgs)  + qhsbv(mgs) + qhlsbv(mgs)) 
         rainprod2d(igs(mgs),kgs(mgs)) = qrcnw(mgs) + qracw(mgs) + qsacw(mgs) + qhacw(mgs) + qhlacw(mgs) + &
                                         qraci(mgs) + qsaci(mgs) + qhaci(mgs) + qhlaci(mgs) + qscni(mgs)
        ENDDO
      ENDIF
!
!
!
! start saturation adjustment
!
      if (ndebug .gt. 0 ) write(0,*) 'conc 30a'
!      include 'sam.jms.satadj.sgi'
!
!
!
!  Modified Straka adjustment (nearly identical to Tao et al. 1989 MWR)
!
!
!
!  set up temperature and vapor arrays
!
      do mgs = 1,ngscnt
      pqs(mgs) = (380.0)/(pres(mgs))
      theta(mgs) = thetap(mgs) + theta0(mgs)
      qvap(mgs) = max( (qwvp(mgs) + qv0(mgs)), 0.0 )
      temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap
      end do
!
!  melting of cloud ice
!
      do mgs = 1,ngscnt
      qcwtmp(mgs) = qx(mgs,lc)
      ptimlw(mgs) = 0.0
      end do
!
      do mgs = 1,ngscnt
      qitmp(mgs) = qx(mgs,li)
      if( temg(mgs) .gt. tfr .and.   &
     &    qitmp(mgs) .gt. 0.0 ) then
      qx(mgs,lc) = qx(mgs,lc) + qitmp(mgs)
!      pfrz(mgs) = pfrz(mgs) - qitmp(mgs)*dtpinv
      ptem(mgs) =  ptem(mgs) +   &
     &  (1./pi0(mgs))*   &
     &  felfcp(mgs)*(- qitmp(mgs)*dtpinv)  
      IF ( eqtset > 2 ) THEN
        pipert(mgs) = pipert(mgs) - (felfpi(mgs)*qitmp(mgs))
      ENDIF
      pmlt(mgs) = pmlt(mgs) - qitmp(mgs)*dtpinv
      scx(mgs,lc) = scx(mgs,lc) + scx(mgs,li)
      thetap(mgs) = thetap(mgs) -   &
     &  fcc3(mgs)*qitmp(mgs)
      ptimlw(mgs) = -fcc3(mgs)*qitmp(mgs)*dtpinv
      cx(mgs,lc) = cx(mgs,lc) + cx(mgs,li)
      qx(mgs,li) = 0.0
      cx(mgs,li) = 0.0
      scx(mgs,li) = 0.0
      vx(mgs,li) = 0.0
      qitmp(mgs) = 0.0
      end if
      end do

!
!


!      do mgs = 1,ngscnt
!      qimlw(mgs) = (qcwtmp(mgs)-qx(mgs,lc))*dtpinv
!      end do
!
!  homogeneous freezing of cloud water
!
      IF ( warmonly < 0.8 ) THEN

      do mgs = 1,ngscnt
      qcwtmp(mgs) = qx(mgs,lc)
      ptwfzi(mgs) = 0.0
      end do
!
      do mgs = 1,ngscnt

!      if( temg(mgs) .lt. tfrh ) THEN
!       write(0,*) 'GS: mgs,temp,qc,qi = ',mgs,temg(mgs),temcg(mgs),qx(mgs,lc),qx(mgs,li)
!      ENDIF

      ctmp = 0.0
      frac = 0.0
      qtmp = 0.0
      
!      if( ( temg(mgs) .lt. thnuc + 2. .or. (ibfc == 2 .and. temg(mgs) < thnuc + 10. ) ) .and.    &
!     &  qx(mgs,lc) .gt. qxmin(lc) .and. (ipconc < 2 .or. ibfc == 0 .or. ibfc == 2 )) then
! commented for test (12/01/2015):
!      if( temg(mgs) .lt. thnuc + 0. .and.    &
!     &  qx(mgs,lc) .gt. 0.0 .and. (ipconc < 2 .or. ibfc == 0 )) then
      if( ( ( temg(mgs) .lt. thnuc + 0.) .or. (temg(mgs) .lt. thnuc + 2. .and. ibfc >= 3) ) .and.    &
     &  qx(mgs,lc) .gt. 0.0 .and. (ipconc < 2 .or. ibfc == 0 .or. ibfc == 2)) then

      IF ( ibfc >= 3 ) THEN
        frac = Max( 0.25, Min( 1., ((thnuc + 2.) - temg(mgs) )/4.0 ) )
      ELSEIF ( ibfc /= 2 .or. ipconc < 2 ) THEN
        frac = Max( 0.25, Min( 1., ((thnuc + 1.) - temg(mgs) )/4.0 ) )
      ELSE
          volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 !  Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 
                                               ! for mean temperature for freezing: -ln (V) = a*Ts - b
                                               ! volt is given in cm**3, so factor of 1.e-6 to convert to m**3
         
         cwfrz(mgs) = cx(mgs,lc)*Exp(-volt/xv(mgs,lc)) ! number of droplets with volume greater than volt

         qtmp = cwfrz(mgs)*xdn0(lc)*rhoinv(mgs)*(volt + xv(mgs,lc))
         frac = qtmp/qx(mgs,lc) ! reset number frozen to same fraction as mass. This makes 
                                                       ! sure that cwfrz and qwfrz are consistent and prevents 
                                                       ! spurious creation of ice crystals.
      
      ENDIF
      qtmp = frac*qx(mgs,lc)

      IF ( ibfc == 4 .and. lis >= 1 ) THEN
        qx(mgs,lis) = qx(mgs,lis) + qtmp
      ELSE
        qx(mgs,li) = qx(mgs,li) + qtmp ! qx(mgs,lc)
      ENDIF
      pfrz(mgs) = pfrz(mgs) + qtmp*dtpinv
      ptem(mgs) =  ptem(mgs) +   &
     &  (1./pi0(mgs))*   &
     &  felfcp(mgs)*(qtmp*dtpinv)  

      IF ( eqtset > 2 ) THEN
        pipert(mgs) = pipert(mgs) + felfpi(mgs)*qtmp
      ENDIF

!      IF ( lvol(li) .gt. 1 ) vx(mgs,li) = vx(mgs,li) + rho0(mgs)*qx(mgs,lc)/xdn0(li)
      IF ( lvol(li) .gt. 1 ) vx(mgs,li) = vx(mgs,li) + rho0(mgs)*qtmp/xdn0(li)

      IF ( ipconc .ge. 2 ) THEN
        ctmp = frac*cx(mgs,lc)
!        cx(mgs,li) = cx(mgs,li) + cx(mgs,lc)
        IF ( ibfc == 4 .and. lis >= 1 ) THEN
          cx(mgs,lis) = cx(mgs,lis) + ctmp
        ELSE
          cx(mgs,li) = cx(mgs,li) + ctmp
        ENDIF
      ELSE ! (ipconc .lt. 2 )
        ctmp = 0.0
        IF ( t9(igs(mgs),jgs,kgs(mgs)-1) .gt. qx(mgs,lc) ) THEN
           qtmp = frac*t9(igs(mgs),jgs,kgs(mgs)-1)  

!           cx(mgs,lc) = cx(mgs,lc)*qx(mgs,lc)*rho0(mgs)/qtmp
           ctmp = cx(mgs,lc)*qx(mgs,lc)*rho0(mgs)/qtmp
        ELSE
           cx(mgs,lc) = Max(0.0,wvel(mgs))*dtp*cwccn   &
     &      /gz(igs(mgs),jgs,kgs(mgs))
          cx(mgs,lc) = cwccn
        ENDIF

       IF ( ipconc .ge. 1 ) cx(mgs,li) = Min(ccimx, cx(mgs,li) + cx(mgs,lc))
      ENDIF

      sctmp = frac*scx(mgs,lc)
!      scx(mgs,li) = scx(mgs,li) + scx(mgs,lc)
      scx(mgs,li) = scx(mgs,li) + sctmp
!      thetap(mgs) = thetap(mgs) + fcc3(mgs)*qx(mgs,lc)
!      ptwfzi(mgs) = fcc3(mgs)*qx(mgs,lc)*dtpinv
!      qx(mgs,lc) = 0.0
!      cx(mgs,lc) = 0.0
!      scx(mgs,lc) = 0.0
      thetap(mgs) = thetap(mgs) + fcc3(mgs)*qtmp
      ptwfzi(mgs) = fcc3(mgs)*qtmp*dtpinv
      qx(mgs,lc) = qx(mgs,lc) - qtmp
      cx(mgs,lc) = cx(mgs,lc) - ctmp
      scx(mgs,lc) = scx(mgs,lc) - sctmp
      end if
      end do

      ENDIF ! warmonly
!
!      do mgs = 1,ngscnt
!      qwfzi(mgs) = (qcwtmp(mgs)-qx(mgs,lc))*dtpinv   ! Not used?? (ERM)
!      end do
!
!  reset temporaries for cloud particles and vapor
!
      qcond(:) = 0.0
      
      IF ( ipconc .le. 1 .and.  lwsm6 ) THEN ! Explicit cloud condensation/evaporation (Rutledge and Hobbs 1983)
       DO mgs = 1,ngscnt

        qcwtmp(mgs) = qx(mgs,lc)
        theta(mgs) = thetap(mgs) + theta0(mgs)
        temgtmp = temg(mgs)
!        temg(mgs) = theta(mgs)*(p2(igs(mgs),jgs,kgs(mgs)) ) ! *pk(mgs) ! ( pres(mgs) / poo ) ** cap
!        temsav = temg(mgs)
!        thsave(mgs) = thetap(mgs)
        temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap
        temcg(mgs) = temg(mgs) - tfr
        ltemq = (temg(mgs)-163.15)/fqsat+1.5
        ltemq = Min( nqsat, Max(1,ltemq) )

        qvs(mgs) = pqs(mgs)*tabqvs(ltemq)

        IF ( ( qvap(mgs) > qvs(mgs) .or. qx(mgs,lc) > qxmin(lc) ) .and. temg(mgs) > tfrh ) THEN
          tmp = (qvap(mgs) - qvs(mgs))/(1. + qvs(mgs)*felv(mgs)**2/(cp*rw*temg(mgs)**2) )
          qcond(mgs) = Min( Max( 0.0, tmp ), (qvap(mgs)-qvs(mgs)) )
          IF ( qx(mgs,lc) > qxmin(lc) .and. tmp < 0.0 ) THEN ! evaporation
            qcond(mgs) = Max( tmp, -qx(mgs,lc) )
          ENDIF
          qwvp(mgs) = qwvp(mgs) - qcond(mgs)
          qvap(mgs) = qvap(mgs) - qcond(mgs)
          qx(mgs,lc) = Max( 0.0, qx(mgs,lc) + qcond(mgs) )
          thetap(mgs) = thetap(mgs) + felvcp(mgs)*qcond(mgs)/(pi0(mgs))
          
        ENDIF
        
        ENDDO
      
      ENDIF
      
      
      IF ( ipconc .le. 1 .and. .not. lwsm6 ) THEN
!      IF ( ipconc .le. 1  ) THEN
      
      do mgs = 1,ngscnt
      qx(mgs,lv) = max( 0.0, qvap(mgs) )
      qx(mgs,lc) = max( 0.0, qx(mgs,lc) )
      qx(mgs,li) = max( 0.0, qx(mgs,li) )
      qitmp(mgs) = qx(mgs,li)
      end do
!
!
      do mgs = 1,ngscnt
      qcwtmp(mgs) = qx(mgs,lc)
      qitmp(mgs) = qx(mgs,li)
      theta(mgs) = thetap(mgs) + theta0(mgs)
      temgtmp = temg(mgs)
      temg(mgs) = theta(mgs)*(pinit(kgs(mgs)) + p2(igs(mgs),jgs,kgs(mgs)) ) ! *pk(mgs) ! ( pres(mgs) / poo ) ** cap
      temsav = temg(mgs)
      thsave(mgs) = thetap(mgs)
      temcg(mgs) = temg(mgs) - tfr
      tqvcon = temg(mgs)-cbw
      ltemq = (temg(mgs)-163.15)/fqsat+1.5
      ltemq = Min( nqsat, Max(1,ltemq) )
!      IF ( ltemq .lt. 1 .or. ltemq .gt. nqsat ) THEN
! C$PAR CRITICAL SECTION
!        write(iunit,*) 'out of range ltemq!',temgtmp,temg(mgs),
!     :      thetap(mgs),theta0(mgs),pres(mgs),theta(mgs),
!     :      ltemq,igs(mgs),jy,kgs(mgs)
!        write(iunit,*) an(igs(mgs),jy,kgs(mgs),lt),
!     :   ab(igs(mgs),jy,kgs(mgs),lt),
!     :   t0(igs(mgs),jy,kgs(mgs))
!        write(iunit,*) fcc3(mgs),qx(mgs,lc),qitmp(mgs),dtp,ptem(mgs)
!        STOP
! C$PAR END CRITICAL SECTION
!      END IF
      qvs(mgs) = pqs(mgs)*tabqvs(ltemq)
      qis(mgs) = pqs(mgs)*tabqis(ltemq)
!      qss(kz) = qvs(kz)
!      if ( temg(kz) .lt. tfr ) then
!      if( qcw(kz) .le. qxmin(lc) .and. qci(kz) .gt. qxmin(li))
!     >  qss(kz) = qis(kz)
!      if( qcw(kz) .gt. qxmin(lc) .and. qci(kz) .gt. qxmin(li))
!     >   qss(kz) = (qcw(kz)*qvs(kz) + qci(kz)*qis(kz)) /
!     >   (qcw(kz) + qci(kz))
!      qss(kz) = qis(kz)
!      end if
! dont get enough condensation with qcw .le./.gt. qxmin(lc)
!      if ( temg(mgs) .lt. tfr ) then
!      if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) )
!     >  qss(mgs) = qvs(mgs)
!      if( qx(mgs,lc) .eq. 0.0 .and. qitmp(mgs) .gt. qxmin(li))
!     >  qss(mgs) = qis(mgs)
!      if( qx(mgs,lc) .gt. 0.0 .and. qitmp(mgs) .gt. qxmin(li))
!     >   qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) /
!     >   (qx(mgs,lc) + qitmp(mgs))
!      else
!      qss(mgs) = qvs(mgs)
!      end if
      qss(mgs) = qvs(mgs)
      if ( temg(mgs) .lt. tfr ) then
      if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) )   &
     &  qss(mgs) = qvs(mgs)
      if( qx(mgs,lc) .le. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li))   &
     &  qss(mgs) = qis(mgs)
      if( qx(mgs,lc) .gt. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li))   &
     &   qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) /   &
     &   (qx(mgs,lc) + qitmp(mgs))
      end if
      end do
!
!  iterate  adjustment
!
      do itertd = 1,2
!
      do mgs = 1,ngscnt
!
!  calculate super-saturation
!
      qitmp(mgs) = qx(mgs,li)
      fcci(mgs) = 0.0
      fcip(mgs) = 0.0
      dqcw(mgs) = 0.0
      dqci(mgs) = 0.0
      dqwv(mgs) = ( qx(mgs,lv) - qss(mgs) )
!
!  evaporation and sublimation adjustment
!
      if( dqwv(mgs) .lt. 0. ) then           !  subsaturated
        if( qx(mgs,lc) .gt. -dqwv(mgs) ) then  ! check if qc can make up all of the deficit
          dqcw(mgs) = dqwv(mgs)
          dqwv(mgs) = 0.
        else                                 !  otherwise make all qc available for evap
          dqcw(mgs) = -qx(mgs,lc)
          dqwv(mgs) = dqwv(mgs) + qx(mgs,lc)
        end if
!
        if( qitmp(mgs) .gt. -dqwv(mgs) ) then  ! check if qi can make up all the deficit
          dqci(mgs) = dqwv(mgs)
          dqwv(mgs) = 0.
        else                                  ! otherwise make all ice available for sublimation
          dqci(mgs) = -qitmp(mgs)
          dqwv(mgs) = dqwv(mgs) + qitmp(mgs)
        end if
!
       qwvp(mgs) = qwvp(mgs) - ( dqcw(mgs) + dqci(mgs) )  ! add to perturbation vapor
!
! This next line removed 3/19/2003 thanks to Adam Houston,
!  who found the bug in the 3-ICE code
!      qwvp(mgs) = max(qwvp(mgs), 0.0)
      qitmp(mgs) = qx(mgs,li)
      IF ( qitmp(mgs) .ge. qxmin(li) ) THEN
        fcci(mgs) = qx(mgs,li)/(qitmp(mgs))
      ELSE
        fcci(mgs) = 1.0
      ENDIF
      qx(mgs,lc) = qx(mgs,lc) + dqcw(mgs)
      qx(mgs,li) = qx(mgs,li) + dqci(mgs) * fcci(mgs)
      thetap(mgs) = thetap(mgs) +   &
     &  1./pi0(mgs)*   &
     &  (felvcp(mgs)*dqcw(mgs) +felscp(mgs)*dqci(mgs))

      IF ( eqtset > 2 ) THEN
        pipert(mgs) = pipert(mgs)   &
     &  +(felspi(mgs)*dqci(mgs)    &
     &  +felvpi(mgs)*dqcw(mgs))*dtp
      ENDIF

      end if  ! dqwv(mgs) .lt. 0. (end of evap/sublim)
!
! condensation/deposition
!
      IF ( dqwv(mgs) .ge. 0. ) THEN
      
!      write(iunit,*) 'satadj: mgs,iter = ',mgs,itertd,dqwv(mgs),qss(mgs),qx(mgs,lv),qx(mgs,lc)
!
        qitmp(mgs) = qx(mgs,li)
        fracl(mgs) = 1.0
        fraci(mgs) = 0.0
        if ( temg(mgs) .lt. tfr .and. temg(mgs) .gt. thnuc ) then
          fracl(mgs) = max(min(1.,(temg(mgs)-233.15)/(20.)),0.0)
          fraci(mgs) = 1.0-fracl(mgs)
        end if
        if ( temg(mgs) .le. thnuc ) then
           fraci(mgs) = 1.0
           fracl(mgs) = 0.0
         end if
        fraci(mgs) = 1.0-fracl(mgs)
!
       gamss = (felvcp(mgs)*fracl(mgs) + felscp(mgs)*fraci(mgs))   &
     &      / (pi0(mgs))
!
      IF ( temg(mgs) .lt. tfr ) then
        IF (qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) then
         dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv1(mgs)*qss(mgs)/   &
     &  ((temg(mgs)-cbw)**2))
        END IF
        IF ( qx(mgs,lc) .eq. 0.0 .and. qitmp(mgs) .gt. qxmin(li) ) then
          dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv2(mgs)*qss(mgs)/   &
     &  ((temg(mgs)-cbi)**2))
        END IF
        IF ( qx(mgs,lc) .gt. 0.0 .and. qitmp(mgs) .gt. qxmin(li) ) then
         cdw = caw*pi0(mgs)*tfrcbw/((temg(mgs)-cbw)**2)
         cdi = cai*pi0(mgs)*tfrcbi/((temg(mgs)-cbi)**2)
         denom1 = qx(mgs,lc) + qitmp(mgs)
         denom2 = 1.0 + gamss*   &
     &    (qx(mgs,lc)*qvs(mgs)*cdw + qitmp(mgs)*qis(mgs)*cdi) / denom1
         dqvcnd(mgs) =  dqwv(mgs) / denom2
        END IF 

      ENDIF  !  temg(mgs) .lt. tfr
!
      if ( temg(mgs) .ge. tfr ) then
      dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv1(mgs)*qss(mgs)/   &
     &  ((temg(mgs)-cbw)**2))
      end if
!
      delqci1=qx(mgs,li)
!
      IF ( qitmp(mgs) .gt. qxmin(li) ) THEN
        fcci(mgs) = qx(mgs,li)/(qitmp(mgs))
      ELSE
        fcci(mgs) = 1.0
      ENDIF
!
      dqcw(mgs) = dqvcnd(mgs)*fracl(mgs)
      dqci(mgs) = dqvcnd(mgs)*fraci(mgs)
!
      thetap(mgs) = thetap(mgs) +   &
     &   (felvcp(mgs)*dqcw(mgs) + felscp(mgs)*dqci(mgs))   &
     & / (pi0(mgs))

      IF ( eqtset > 2 ) THEN
        pipert(mgs) = pipert(mgs) + (0   &
     &  +felspi(mgs)*dqci(mgs)    &
     &  +felvpi(mgs)*dqcw(mgs))*dtp
      ENDIF

      qwvp(mgs) = qwvp(mgs) - ( dqvcnd(mgs) )
      qx(mgs,lc) = qx(mgs,lc) + dqcw(mgs)
!      IF ( qitmp(mgs) .gt. qxmin(li) ) THEN
        qx(mgs,li) = qx(mgs,li) + dqci(mgs)*fcci(mgs)
        qitmp(mgs) = qx(mgs,li)
!      ENDIF
!
!      delqci(mgs) =  dqci(mgs)*fcci(mgs)
!
      END IF !  dqwv(mgs) .ge. 0.
      end do
!
      do mgs = 1,ngscnt
      qitmp(mgs) = qx(mgs,li)
      theta(mgs) = thetap(mgs) + theta0(mgs)
      temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap
      qvap(mgs) = Max((qwvp(mgs) + qv0(mgs)), 0.0)
      temcg(mgs) = temg(mgs) - tfr
      tqvcon = temg(mgs)-cbw
      ltemq = (temg(mgs)-163.15)/fqsat+1.5
      ltemq = Min( nqsat, Max(1,ltemq) )
      qvs(mgs) = pqs(mgs)*tabqvs(ltemq)
      qis(mgs) = pqs(mgs)*tabqis(ltemq)
      qx(mgs,lc) = max( 0.0, qx(mgs,lc) )
      qitmp(mgs) = max( 0.0, qitmp(mgs) )
      qx(mgs,lv) = max( 0.0, qvap(mgs))
!      if ( temg(mgs) .lt. tfr ) then
!      if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) )
!     >  qss(mgs) = qvs(mgs)
!c      if( qx(mgs,lc) .le. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li))
!      if( qx(mgs,lc) .eq. 0.0 .and. qitmp(mgs) .gt. qxmin(li))
!     >  qss(mgs) = qis(mgs)
!c      if( qx(mgs,lc) .gt. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li))
!      if( qx(mgs,lc) .gt. 0.0 .and. qitmp(mgs) .gt. qxmin(li))
!     >  qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) /
!     > (qx(mgs,lc) + qitmp(mgs))
!      else
!      qss(mgs) = qvs(mgs)
!      end if
      qss(mgs) = qvs(mgs)
      if ( temg(mgs) .lt. tfr ) then
      if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) )   &
     &  qss(mgs) = qvs(mgs)
      if( qx(mgs,lc) .le. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li))   &
     &  qss(mgs) = qis(mgs)
      if( qx(mgs,lc) .gt. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li))   &
     &   qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) /   &
     &   (qx(mgs,lc) + qitmp(mgs))
      end if
!      pceds(mgs) = (thetap(mgs) - thsave(mgs))*dtpinv
!      write(iunit,*) 'satadj2: mgs,iter = ',mgs,itertd,dqwv(mgs),qss(mgs),qx(mgs,lv),qx(mgs,lc)
      end do
!
!  end the saturation adjustment iteration loop
!
      end do

     ENDIF ! ( ipconc .le. 1 )

!
!  spread the growth owing to vapor diffusion onto the
!  ice crystal categories using the
!
!  END OF SATURATION ADJUSTMENT
!

      if (ndebug .gt. 0 ) write(0,*) 'conc 30b'
!
!
!  end of saturation adjustment

!
!
! !DIR$ IVDEP
      do mgs = 1,ngscnt
      t0(igs(mgs),jy,kgs(mgs)) =  temg(mgs)
      end do
!
! Load the save arrays
!


! Sample code for using the axtra array to load microphysical rates or quantities for output
!
! Note that indices 1 and 2 are used in the nucond subroutine for condensation/evap of droplets (1) and
!    condensation of rain (2)
!
!      IF ( io_flag .and. nxtra > 1 ) THEN
!        DO mgs = 1,ngscnt
!          axtra(igs(mgs),jy,kgs(mgs),3)  = pfrz(mgs) !
!          axtra(igs(mgs),jy,kgs(mgs),4)  = qrcev(mgs) ! pre2
!          axtra(igs(mgs),jy,kgs(mgs),5)  = psub(mgs) ! depsubr
!          axtra(igs(mgs),jy,kgs(mgs),6)  = qrfrz(mgs) ! rain freezing (Bigg)
!          axtra(igs(mgs),jy,kgs(mgs),7)  = pmlt(mgs) ! melr2
!        ENDDO
!      ENDIF




      if (ndebug .gt. 0 ) write(0,*) 'gs 11'

      do mgs = 1,ngscnt
!
      an(igs(mgs),jy,kgs(mgs),lt) =    &
     &  theta0(mgs) + thetap(mgs) 
      an(igs(mgs),jy,kgs(mgs),lv) = qwvp(mgs) + qv0(mgs) !

      IF ( eqtset > 2 ) THEN
        p2(igs(mgs),jy,kgs(mgs)) = pipert(mgs)
      ENDIF
!
      
      DO il = lc,lhab
        IF ( ido(il) .eq. 1 ) THEN
        IF ( lf > 1 .and. il == lf ) THEN 
           lfsave(mgs,1) = an(igs(mgs),jy,kgs(mgs),il)
           lfsave(mgs,2) = qx(mgs,il)
        ENDIF
         an(igs(mgs),jy,kgs(mgs),il) = qx(mgs,il) +   &
     &     min( an(igs(mgs),jy,kgs(mgs),il), 0.0 )
         qx(mgs,il) = an(igs(mgs),jy,kgs(mgs),il)
        ENDIF
      ENDDO

      IF ( lcina > 1 ) THEN
        an(igs(mgs),jy,kgs(mgs),lcina) = cina(mgs)
      ENDIF


!
      end do
!

      if ( ipconc .ge. 1 ) then
      DO il = lc,lhab !{

!        write(0,*) 'limiter loop: il,ipc,lz: ',il,ipc(il),lz(il),ipconc

       IF ( ipconc .ge. ipc(il) .and. ido(il) > 0 ) THEN ! {

         IF (  ipconc .ge. 4 .and. ipc(il) .ge. 1 ) THEN ! {

!            write(0,*) 'MY limiter: il,ipc,lz: ',il,ipc(il),lz(il),lr,lzr
!            STOP

          IF ( lz(il) <= 1 .or. ioldlimiter == 1 ) THEN ! { { is a two-moment category so dont worry about reflectivity
          

           DO mgs = 1,ngscnt
            IF ( qx(mgs,il) .le. 0.0 ) THEN
              cx(mgs,il) = 0.0
            ELSE !{
              IF ( cx(mgs,il) .gt. cxmin ) THEN !{
!              xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(1.0e-9,cx(mgs,il)))
!              xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(cxmin,cx(mgs,il)))
                xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*cx(mgs,il))
              
!              IF ( lhl .gt. 1 .and. il .eq. lhl ) THEN
!               write(0,*) 'dr: xv,cx,qx,xdn,ln = ',xv(mgs,il),cx(mgs,il),qx(mgs,il),xdn(mgs,il),ln(il)
!              ENDIF

               ! 8/26/2015 erm: apply imaxdiaopt for 2-moment also
               IF ( imaxdiaopt == 1 .or. il == lc .or. il == li .or. (il == lr .and. imurain == 3) .or. &
     &              (il == ls .and. imusnow == 3 ) ) THEN
                 xvbarmax = xvmx(il)
               ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter
                 xvbarmax = xvmx(il) /((3. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il))))
               ELSEIF ( imaxdiaopt == 3 ) THEN ! test against mass-weighted diameter
                 xvbarmax = xvmx(il) /((4. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il))))
               ELSE
                 xvbarmax = xvmx(il)
               ENDIF

               tmp = 1.0
               IF ( il == ls ) THEN
                 xvbarmax = xvbarmax*Max(1.,100./Min(100.,xdn(mgs,ls)))
               ENDIF
               
               IF ( xv(mgs,il) .lt. xvmn(il) .or. xv(mgs,il) .gt. xvbarmax ) THEN
                xv(mgs,il) = Min( xvbarmax, xv(mgs,il) )
                xv(mgs,il) = Max( xvmn(il), xv(mgs,il) )
                cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xv(mgs,il)*xdn(mgs,il))
               ENDIF
              
             ENDIF !}

!              IF ( lhl .gt. 1 .and. il .eq. lhl ) THEN
!               write(0,*) 'dr: xv,cx,= ',xv(mgs,il),cx(mgs,il)
!              ENDIF

            ENDIF !}
           ENDDO ! mgs
          
          
          ENDIF ! }}
          ENDIF ! }

          DO mgs = 1,ngscnt
            IF ( il == lhl ) THEN
            
            IF ( lnhlf > 1 ) THEN ! number of hail from frozen drops
!              an(igs(mgs),jy,kgs(mgs),lnhlf) = Min( cx(mgs,lhl), Max( chxf(mgs,lhl), 0.0) )
              an(igs(mgs),jy,kgs(mgs),lnhlf) = Max( chxf(mgs,lhl), 0.0)
            ENDIF
            ENDIF
            an(igs(mgs),jy,kgs(mgs),ln(il)) = Max(cx(mgs,il), 0.0)
          ENDDO
        ENDIF ! }
      ENDDO ! il }

      IF ( lcin > 1 ) THEN
      do mgs = 1,ngscnt
        an(igs(mgs),jy,kgs(mgs),lcin) = Max(0.0, ccin(mgs))
      end do
      ENDIF

      IF ( ipconc .ge. 2 ) THEN
      do mgs = 1,ngscnt
        IF ( lss > 1 ) THEN
          an(igs(mgs),jy,kgs(mgs),lss) = Max(0.0, ssmax(mgs) )
        ENDIF

        IF ( lccn > 1 ) THEN
          an(igs(mgs),jy,kgs(mgs),lccn) = Max(0.0, ccnc(mgs) )
        ENDIF
      end do
      ENDIF
      
      ELSEIF ( ipconc .eq. 0 .and. lni .gt. 1 ) THEN
      
          DO mgs = 1,ngscnt
            an(igs(mgs),jy,kgs(mgs),lni) = Max(cx(mgs,li), 0.0)
          ENDDO


      end if

      IF ( ldovol ) THEN

       DO il = li,lhab

        IF ( lvol(il) .ge. 1 ) THEN

          DO mgs = 1,ngscnt

           an(igs(mgs),jy,kgs(mgs),lvol(il)) = Max( 0.0, vx(mgs,il) )
          ENDDO
          
        ENDIF
      
       ENDDO
      
      ENDIF
!
!
!
!
!
      if (ndebug .gt. 0 ) write(0,*) 'gs 12'



      if (ndebug .gt. 0 ) write(0,*) 'gs 13'

 9998 continue

      if ( kz .gt. nz-1 .and. ix .ge. itile) then
        if ( ix .ge. itile ) then
         go to 1200 ! exit gather scatter
        else
         nzmpb = kz
        endif
      else
        nzmpb = kz
      end if

      if ( ix .ge. itile ) then
        nxmpb = 1
        nzmpb = kz+1
      else
       nxmpb = ix+1
      end if

 1000 continue
 1200 continue
!
!  end of gather scatter (for this jy slice)
!
!

      return
      end subroutine nssl_2mom_gs
!
!--------------------------------------------------------------------------
!



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


END MODULE module_mp_nssl_2mom