| nssl_ehw0 | mp_nssl | NSSL graupel-droplet collection efficiency | 0.9
diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90
index 409bf4019..ad90ec81f 100644
--- a/physics/module_mp_nssl_2mom.F90
+++ b/physics/module_mp_nssl_2mom.F90
@@ -1,7 +1,14 @@
!> \file module_mp_nssl_2mom.F90
+
+
+
+
+
+
+
!---------------------------------------------------------------------
-! code snapshot: "Feb 24 2022" at "14:27:57"
+! code snapshot: "Sep 22 2023" at "22:01:53"
!---------------------------------------------------------------------
!---------------------------------------------------------------------
! IMPORTANT: Best results are attained using the 5th-order WENO (Weighted Essentially Non-Oscillatory) advection option (4) for scalars:
@@ -19,37 +26,32 @@
! WENO references: Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223; Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118;
!
!>\ingroup mod_mp_nssl2m
-!! This module provides a 2-moment bulk microphysics scheme described by
-!! Mansell, Zeigler, and Bruning (2010, JAS)
-!!
-!! This module provides a 2-moment bulk microphysics scheme based on a combination of
-!! Straka and Mansell (2005, JAM) and Zeigler (1985, JAS) and modified/upgraded in
-!! in Mansell, Zeigler, and Bruning (2010, JAS). Two-moment adaptive sedimentation
+!! This module provides a 1/2/3-moment bulk microphysics scheme based on a combination of
+!! Straka and Mansell (2005, JAM) and 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.
+!! Average graupel and hail particle densities are predicted, which affects fall speed as well.
!!
!! Maintainer: Ted Mansell, National Severe Storms Laboratory
!!
!! Microphysics References:
!!
-!! Mansell, E. R., C. L. Ziegler, and E. C. Bruning, 2010: Simulated electrification of a small
+!! 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,
+!! 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.
+!! 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.
+!! 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:
@@ -63,18 +65,25 @@
! 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
+! 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
+! 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.
!
!
!---------------------------------------------------------------------
+! Apr. 2023
+! - Update to 3-moment for rain, graupel, and hail
+! - Change default graupel/hail fall speeds to icdx/icdxhl=6 (Milbrandt & Morrison 2013)
+! and also set default ehw0=0.9 and ehlw0=0.9 to compensate for lower fall speeds.
+! - Change default hail conversion to ihlcnh=-1, and then =1 for 2-mom or =3 for 3-mom,
+! using wet growth diameter to convert large graupel
+!---------------------------------------------------------------------
! Sept. 2021:
! Fixes:
-! Restored previous formulation of snow reflectivity, as it was realized that the last change incorrectly assumed a fixed
+! 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)
@@ -221,7 +230,7 @@ MODULE module_mp_nssl_2mom
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 :: rho_qhl= 800., 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)
@@ -234,8 +243,9 @@ MODULE module_mp_nssl_2mom
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"
+ real , private :: ccn = 0.6e+09 ! set in namelist!! Central plains CCN value
+ real , private :: ccnuf = 0 ! set in namelist!! Central plains CCN value
+ real , public :: qccn, qccnuf ! ccn "mixing ratio"
real , private :: old_qccn = -1.0
integer, private :: iauttim = 1 ! 10-ice rain delay flag
real , private :: auttim = 300. ! 10-ice rain delay time
@@ -245,12 +255,17 @@ MODULE module_mp_nssl_2mom
! 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
+ logical, private :: invertccn = .false. ! =true for base state of ccn=0, =false for ccn initialized in the base state
#endif
logical :: switchccn = .false.
real :: old_cccn = -1.0
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)
+ real, private :: restoreccnfrac = 1.0 ! fraction of evaporated droplets that restore CCN
+ real :: ufccntimeconst = 6.*3600. ! time constant for UFCCN decay (Blossey et al. 2018)
+ real :: ufbackground = 0.1e9 ! background ccnuf value (Blossey et al.)
+ logical :: decayufccn = .false.
+ integer :: i_uf_or_ccn = 0 ! 0 = ship adds UF; 1 = treat UF as regular ccn (add to qccn)
! sedimentation flags
! itfall -> 0 = 1st order fallout (other options removed)
@@ -259,6 +274,7 @@ MODULE module_mp_nssl_2mom
integer, private :: itfall = 0
integer, private :: iscfall = 1
integer, private :: irfall = -1
+ integer, private :: isfall = 2 ! default limit with method II (more restrictive)
logical, private :: do_accurate_sedimentation = .true. ! 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.
@@ -269,14 +285,20 @@ MODULE module_mp_nssl_2mom
! 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.
+ integer :: imydiagalpha = 0 ! apply MY diagnostic shape parameter for fall speeds (1=for fall speed only; 2=also for microphysics rates)
real, private :: rainfallfac = 1.0 ! factor to adjust rain fall speed (single moment only)
real, private :: icefallfac = 1.5 ! factor to adjust ice fall speed
real, private :: snowfallfac = 1.25 ! 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.
+ integer, private :: icdx = 6 ! (graupel) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc.
+ ! 6= Milbrandt and Morrison (2013) density-based fall speed
+ integer, private :: icdxhl = 6 ! (hail) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc.
+ ! 6= Milbrandt and Morrison (2013) density-based fall speed
+ real :: axh = 75.7149, bxh = 0.5
+ real :: axf = 75.7149, bxf = 0.5
+ real :: axhl = 206.984, bxhl = 0.6384
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)
@@ -310,7 +332,7 @@ MODULE module_mp_nssl_2mom
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)
+ integer, private :: irimdenopt = 1 ! = 1 for default Heymsfield and Pflaum (1985); = 2 for experimental Cober and List (1993); = 3 Macklin
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
@@ -325,7 +347,7 @@ MODULE module_mp_nssl_2mom
! (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
+ integer, private :: irenuc = 2 ! =1 to always allow renucleation of droplets within the cloud (do no use, obsolete)
! =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
@@ -347,6 +369,7 @@ MODULE module_mp_nssl_2mom
! 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 :: in_freeze_rain_first = 0 ! =1 use IN to freezed rain drops (if none, then freeze droplets)
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
@@ -357,7 +380,9 @@ MODULE module_mp_nssl_2mom
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 :: icrcev = 1 ! 1 = old crcev; 2 = crcev scaled by vtrain ratio (num/mass); 3 = set to zero
integer, private :: icracr = 1 ! Flag to turn rain self-collection on/off (=0 to turn off)
+ integer, private :: icracrthresh = 1 ! For rain self-coll. thresh. use: 1 = mean diam of 2mm; 2 = rain median volume diam of 1.9mm
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)
@@ -413,11 +438,15 @@ MODULE module_mp_nssl_2mom
! 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 :: ewi_dcmin = 15.0e-06 ! minimum droplet diameter for nonzero ewi
+ real, private :: ewi_dimin = 30.0e-06 ! minimum ice crystal diameter for nonzero ewi
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
+ integer :: iessopt = 1 ! 1 = Original (no factor); 2 = factor based on wvel; 3 = factor based on SSI
+ ! 4 = as 3 but sets min factor of 0.1 and goes to full value at 0.5% SSI
real , private :: ess0 = 0.5, 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 = -15. ! lower temperature where snow aggregation turns on
@@ -452,11 +481,13 @@ MODULE module_mp_nssl_2mom
! 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.)
+ integer, private :: iqis0 = 2 ! = 1 for normal qis; = 2 to set qis to use T = 0C when T > 0C
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 :: ivshdgs = 1 ! 0 = use 1mm for all shedding (non-mixedphase); 1 = use vshdgs with sheddiam
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
@@ -480,6 +511,7 @@ MODULE module_mp_nssl_2mom
real, private :: qhdpvdn = -1.
real, private :: qhacidn = -1.
+ integer, private :: iraintypes = 0
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
@@ -511,17 +543,23 @@ MODULE module_mp_nssl_2mom
real, parameter :: alpharmax = 8. ! limited for rwvent calculation
- integer, private :: ihlcnh = 1 ! which graupel -> hail conversion to use
+ 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
+ ! 3 = Conversion using wet growth diameter
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.
+ real , private :: hldia1 = 10.0e-3 ! threshold diameter for graupel -> hail conversion for ihlcnh = 2 option.
+ integer, private :: incwet = 0 ! flag to do wet growth only on D > D_wet
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 :: dwmin = 5.0e-3 ! Minimum diameter with iusedw (can stay at 0 or be set to something larger)
+ real , private :: dwetmin = 5.0e-3 ! Minimum diameter with iusedw (can stay at 0 or be set to something larger)
+ real , private :: dwmax = 15.e-3 ! for ihlcnh, always convert this size and larger whether or not there is wet growth
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 :: ifddenfac = 0 ! = 1 to use density threshold to count FD as GR when converting to HL
+ real :: fddenthresh = 500. ! if ifddenfac > 0, then hail from FD with lower density are considered to come from graupel
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.
@@ -538,6 +576,8 @@ MODULE module_mp_nssl_2mom
! = 1 use mean diameter for breakup
! = 2 use maximum mass diameter for breakup
! = 3 use mass-weighted diameter for breakup
+ integer :: iraintailbreak = 0 ! 1 = on
+ real :: draintail = 8.e-3 ! starting size for rain breakup
integer, private :: dmrauto = 0
! = -1 no limiter on crcnw
! = 0 limit crcnw when qr > 1.2*L (Cohard-Pinty 2002)
@@ -545,7 +585,7 @@ MODULE module_mp_nssl_2mom
! = 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 :: dmhlopt = 0 ! options for graupel -> hail conversion
integer :: irescalerainopt = 3 ! 0 = default option
! 1 = qx(mgs,lc) > qxmin(lc)
! 2 = qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < 3.0
@@ -562,7 +602,7 @@ MODULE module_mp_nssl_2mom
integer :: ivhmltsoak = 1 ! 0=off, 1=on : flag to simulate soaking (graupel/hail) during melting
! when liquid fraction is not predicted
- logical :: iwetsoak = .true. ! soak and freeze during wet growth or not
+ logical, private :: iwetsoak = .true. ! soak and freeze during wet growth or not
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)
@@ -595,9 +635,12 @@ MODULE module_mp_nssl_2mom
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
+ integer, private :: iqhacwshr = 1 ! turn on/off qhacw for T > 0
+ integer, private :: iqhlacwshr = 1 ! turn on/off qhlacw for T > 0
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 :: alphasmlr0 = 14.0 ! shape parameter for drops formed from melting/shedding 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)
@@ -739,6 +782,7 @@ MODULE module_mp_nssl_2mom
real da1 (lc:lqmx) ! collection coefficients from Seifert 2005
real bb (lc:lqmx)
+
! put ipelec here for now....
integer :: ipelec = 0
integer :: isaund = 0
@@ -764,8 +808,8 @@ MODULE module_mp_nssl_2mom
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
+ integer, parameter :: nqiacralpha = 300 !480 ! 240 ! 120 ! 15
+ integer, parameter :: nqiacrratio = 400 ! 500 !50 ! 25
! real, parameter :: maxratiolu = 25.
real, parameter :: maxratiolu = 100. ! 25.
real, parameter :: maxalphalu = 15.
@@ -782,6 +826,10 @@ MODULE module_mp_nssl_2mom
! real :: ziacrratio(0:nqiacrratio,0:nqiacralpha)
! double precision :: gamxinflu(0:nqiacrratio,0:nqiacralpha,12,2) ! last index for graupel (1) or hail (2)
+! for 3-moment collection coefficients
+ real, save :: dab0lu(ialpstart:nqiacralpha,ialpstart:nqiacralpha,lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005
+ real, save :: dab1lu(ialpstart:nqiacralpha,ialpstart:nqiacralpha,lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005
+
integer, parameter :: ngdnmm = 9
real :: mmgraupvt(ngdnmm,3) ! Milbrandt and Morrison (2013) fall speed coefficients for graupel/hail
@@ -860,7 +908,7 @@ MODULE module_mp_nssl_2mom
! 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 :: xvcmx=0.523599*(2.*xcradmx)**3 ! mks max volume = 60 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
@@ -903,18 +951,20 @@ MODULE module_mp_nssl_2mom
real, parameter :: cawbolton = 17.67
real, parameter :: tfrh = 233.15
+! --------------------------
+ ! For CCPP, the following variables should be set by the host model, but initial values are set just in case
real :: tfr = 273.15
-
real :: cp = 1004.0, rd = 287.04
real :: rw = 461.5 ! gas const. for water vapor
- REAL, PRIVATE :: cpl = 4190.0
- REAL, PRIVATE :: cpigb = 2106.0
- real :: cpi
- real :: cap
- real :: tfrcbw
- real :: tfrcbi
- real :: rovcp
-
+ real :: cpl = 4190.0
+ real :: cpigb = 2106.0
+ real :: cpi = 1.0/1004.0
+ real :: cap = 287.04/1004.0
+ real :: tfrcbw = 273.15 - cbw
+ real :: tfrcbi = 273.15 - cbi
+ real :: rovcp = 287.04/1004.0
+ real :: rdorv = 0.622
+! --------------------------
real, parameter :: poo = 1.0e+05
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
@@ -922,8 +972,8 @@ MODULE module_mp_nssl_2mom
! 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 :: cv = 717.0 ! specific heat at constant volume - air
+ REAL, PRIVATE, parameter :: cvv = 1408.5
! GHB
real, parameter :: bfnu0 = (rnu + 2.0)/(rnu + 1.0)
@@ -952,10 +1002,12 @@ MODULE module_mp_nssl_2mom
logical, parameter :: do_satadj_for_wrfchem = .true.
+ integer, parameter :: ac_opt = 0 ! option flag for alternate aerosol (for NUWRF only)
+ logical, private :: nuaccoinp = .false.
! 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
+! Some may be useful for ensemble physics diversity. Feel free to contact Ted Mansell if you have questions
! in that regard.
NAMELIST /nssl_mp_params/ &
ndebug, ncdebug,&
@@ -965,7 +1017,7 @@ MODULE module_mp_nssl_2mom
idbzci, &
vtmaxsed, &
itfall,iscfall, &
- infall, &
+ infall,irfall,isfall, &
rssflg, &
sssflg, &
hssflg, &
@@ -976,13 +1028,15 @@ MODULE module_mp_nssl_2mom
icnuclimit, &
irenuc, &
restoreccn, ccntimeconst, cck, &
+ decayufccn, ufccntimeconst, &
switchccn, old_cccn, &
ciintmx, &
itype1, itype2, &
- icenucopt, &
+ icenucopt, in_freeze_rain_first, &
naer, &
icfn, &
ibfc, iacr, icracr, &
+ icracrthresh, &
cwfrz2snowfrac, cwfrz2snowratio, &
ibfr, &
ibiggopt, &
@@ -998,7 +1052,7 @@ MODULE module_mp_nssl_2mom
eri_cimin, &
eii0hl, eii1hl, &
ehs0, ehs1, &
- ess0, ess1, &
+ ess0, ess1, iessopt, &
esstem1,esstem2, &
ircnw, qminrncw,& ! single-moment only
iglcnvi, &
@@ -1024,6 +1078,7 @@ MODULE module_mp_nssl_2mom
hailfallfac, &
icefallopt, &
icdx,icdxhl, &
+ axh,bxh,axf,bxf,axhl,bxhl, &
cdhmin, cdhmax, &
cdhdnmin, cdhdnmax, &
cdhlmin, cdhlmax, &
@@ -1058,7 +1113,7 @@ MODULE module_mp_nssl_2mom
rescale_low_alphah, &
rescale_low_alphahl, &
rescale_high_alpha, &
- ihlcnh, hldia1,iusedw, dwehwmin, dwmin, dwtempmin, &
+ ihlcnh, hldia1,iusedw, dwehwmin, dwmin, dwmax, dwtempmin, dg0thresh, &
icvhl2h, hldnmn,hdnmn, &
hlcnhdia, hlcnhqmin, &
isedonly, &
@@ -1133,12 +1188,12 @@ SUBROUTINE nssl_2mom_init_const( &
real, intent(in) :: con_g, con_rd, con_cp, con_rv, &
con_t0c, con_cliq, con_csol, con_eps
- cp608 = con_eps ! 0.608 ! constant used in conversion of T to Tv
gr = con_g
tfr = con_t0c
cp = con_cp
rd = con_rd
rw = con_rv
+ rdorv = con_eps
cpl = con_cliq ! 4190.0
cpigb = con_csol ! 2106.0
cpi = 1./cp
@@ -1151,6 +1206,8 @@ SUBROUTINE nssl_2mom_init_const( &
RETURN
END SUBROUTINE nssl_2mom_init_const
+
+
! #####################################################################
! #####################################################################
!>\ingroup mod_nsslmp
@@ -1165,7 +1222,14 @@ SUBROUTINE nssl_2mom_init( &
& nssl_icdxhl, &
& nssl_icefallfac, &
& nssl_snowfallfac, &
+ & nssl_cccn, &
+ & nssl_ufccn, &
+ & nssl_alphah, &
+ & nssl_alphahl, &
+ & nssl_alphar, &
+ & nssl_density_on, nssl_hail_on, nssl_ccn_on, nssl_icecrystals_on, ccn_is_ccna, &
& errmsg, errflg, &
+ & infileunit, &
& myrank, mpiroot &
)
@@ -1177,24 +1241,38 @@ SUBROUTINE nssl_2mom_init( &
& nssl_ehw0, &
& nssl_ehlw0, &
& nssl_icefallfac, &
- & nssl_snowfallfac
+ & nssl_snowfallfac, &
+ & nssl_cccn, &
+ & nssl_alphah, &
+ & nssl_alphahl, &
+ & nssl_alphar
integer, intent(in), optional :: &
& nssl_icdx, &
- & nssl_icdxhl, myrank, mpiroot
+ & nssl_icdxhl, myrank, mpiroot, &
+ & nssl_ufccn
+ logical, intent(in), optional :: nssl_density_on, nssl_hail_on, nssl_ccn_on, nssl_icecrystals_on
+ integer, intent(inout), optional :: ccn_is_ccna
+
+ integer, intent(in),optional :: infileunit
! CCPP error handling
character(len=*), intent( out) :: errmsg
integer, intent( out) :: errflg
- integer, intent(in) :: ims,ime, jms,jme, kms,kme
- real, intent(in), dimension(20) :: nssl_params
+ integer, intent(in), optional :: ims,ime, jms,jme, kms,kme
+
+ real, intent(in), dimension(20), optional :: nssl_params
- integer, intent(in) :: ipctmp,mixphase,ihvol
+ integer, intent(in) :: ipctmp,mixphase
+ integer, optional, intent(in) :: ihvol
logical, optional, intent(in) :: idoniconlytmp
+ integer :: igvol_local = 1
logical :: wrote_namelist = .false.
logical :: wrf_dm_on_monitor
+ integer :: hail_on = -1, density_on = -1, icecrystals_on = 1
+ integer :: ccn_on = -1
double precision :: arg
real :: temq
@@ -1202,22 +1280,59 @@ SUBROUTINE nssl_2mom_init( &
integer :: i,il,j,l
integer :: ltmp
integer :: isub
- real :: bxh,bxhl
+ real :: bxh1,bxhl1
real :: alp,ratio
double precision :: x,y,y2,y7
logical :: turn_on_ccna, turn_on_cina
+ integer :: iufccn = 0
integer :: istat
+
+ real :: alpjj, alpii, xnuii, xnujj
+ integer :: ii, jj
errmsg = ''
errflg = 0
turn_on_ccna = .false.
turn_on_cina = .false.
+
+! IF ( present( igvol ) ) THEN
+! igvol_local = igvol
+! ENDIF
+
+ IF ( present( nssl_hail_on ) ) THEN
+ IF ( nssl_hail_on ) THEN
+ hail_on = 1
+ ELSE
+ hail_on = 0
+ ENDIF
+ ENDIF
+
+ IF ( present( nssl_density_on ) ) THEN
+ IF ( nssl_density_on ) THEN
+ density_on = 1
+ ELSE
+ density_on = 0
+ ENDIF
+ ENDIF
+
+ IF ( present( nssl_icecrystals_on ) ) THEN
+ IF ( nssl_icecrystals_on ) THEN
+ icecrystals_on = 1
+ ELSE
+ icecrystals_on = 0
+ ! renucfrac = 1.0 ! why was this set to 1?
+ ffrzs = 1.0
+ ENDIF
+ ENDIF
+
+
!
! set some global values from namelist input
!
+ IF ( present( nssl_params ) ) THEN
ccn = Abs( nssl_params(1) )
alphah = nssl_params(2)
alphahl = nssl_params(3)
@@ -1228,26 +1343,60 @@ SUBROUTINE nssl_2mom_init( &
rho_qh = nssl_params(8)
rho_qhl = nssl_params(9)
rho_qs = nssl_params(10)
- alphar = nssl_params(15)
-
+ 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
+ ccnuf = Abs( nssl_params(14) )
+ IF ( present(nssl_ufccn) ) iufccn = nssl_ufccn
+
+ ENDIF
+ alphar = nssl_params(15)
! 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_ehw0) ) THEN
+ IF ( nssl_ehw0 > 0.0 ) ehw0 = nssl_ehw0
+ ENDIF
+ IF ( present(nssl_ehlw0) ) THEN
+ IF ( nssl_ehlw0 > 0.0 ) ehlw0 = nssl_ehlw0
+ ENDIF
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 ( present(nssl_cccn) ) THEN
+ IF (nssl_cccn > 1 ) ccn = nssl_cccn
+ ENDIF
+ IF ( present(nssl_alphah) ) THEN
+ IF ( nssl_alphah > -1. ) alphah = nssl_alphah
+ ENDIF
+ IF ( present(nssl_alphahl) ) THEN
+ IF ( nssl_alphahl > -1. ) alphahl = nssl_alphahl
+ ENDIF
+ IF ( present(nssl_alphar) ) THEN
+ IF ( nssl_alphar > -1.0 ) alphar = nssl_alphar
+ ENDIF
- IF ( Nint(nssl_params(13)) == 1 ) THEN
- ! hack to switch CCN field to CCNA (activated ccn)
-! invertccn = .true.
- turn_on_ccna = .true.
- irenuc = 7
+ ipconc = ipctmp
+
+ IF ( ipconc < 5 ) THEN
+ ihlcnh = 0
+ ENDIF
+
+ IF ( ihlcnh <= 0 ) THEN
+ IF ( ipconc == 5 ) THEN
+ ihlcnh = 3
+ ELSEIF ( ipconc >= 6 ) THEN
+ ihlcnh = 3
ENDIF
+ ENDIF
@@ -1275,8 +1424,43 @@ SUBROUTINE nssl_2mom_init( &
+ IF ( iufccn > 0 ) THEN ! make sure to use option that uses UF ccn
+ irenuc = 7
+ IF ( ccnuf <= 0.0 ) decayufccn = .true. ! assume surface emission and need decay
+ IF ( i_uf_or_ccn > 0 ) THEN
+ ufbackground = 0.0
+ ccntimeconst = ufccntimeconst
+ ENDIF
+ ENDIF
+
+ IF ( present( nssl_ccn_on ) ) THEN
+ IF ( nssl_ccn_on ) THEN
+ ccn_on = 1
+ ELSE
+ ccn_on = 0
+ irenuc = 2
+ ENDIF
+ ENDIF
+
IF ( irenuc >= 5 ) THEN
turn_on_ccna = .true.
+ IF ( present( nssl_ccn_on ) ) THEN
+ IF ( .not. nssl_ccn_on ) THEN
+ errmsg = 'NSSL_MP Error: Must have nssl_ccn_on=1 for irenuc >= 5!'
+ errflg = 1
+ return
+ ENDIF
+ ENDIF
+ ENDIF
+
+ IF ( present( ccn_is_ccna ) .and. ccn_on == 1 ) THEN
+ IF ( ccn_is_ccna > 0 ) THEN
+ turn_on_ccna = .true.
+ ELSE
+ IF ( irenuc >= 5 ) THEN
+ ccn_is_ccna = 1
+ ENDIF
+ ENDIF
ENDIF
cwccn = ccn
@@ -1290,25 +1474,42 @@ SUBROUTINE nssl_2mom_init( &
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
+ IF ( hail_on == -1 ) THEN ! hail_on is not set
+ hail_on = 1
+ IF ( ihvol <= -1 .or. ihvol == 2 ) THEN
+ IF ( ihvol == -1 .or. ihvol == -2 ) THEN
+ lhab = lhab - 1 ! turns off hail
+ lhl = 0
+ hail_on = 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 .or. icecrystals_on == 0 ) THEN ! ice crystals are turned off
+ ! a value of 2? means to turn off ice crystals but turn on hail
+ ! renucfrac = 1.0 ! why?
+ ffrzs = 1.0
+ ! idoci = 0 ! try this later
+ ENDIF
+ ENDIF
+
+ ELSE ! hail_on is set
+ IF ( hail_on == 0 ) THEN
+ lhab = lhab - 1 ! turns off hail
+ lhl = 0
+ ELSE
+ ! assume default that hail is on
ENDIF
ENDIF
+
+ IF ( density_on == -1 ) THEN ! density flag not set, so default is to predict it
+ density_on = 1
+ ENDIF
+
IF ( iresetmoments == 0 ) iresetmoments = 1 ! lhl
-! write(0,*) 'wrf_init: lhab,lhl = ',lhab,lhl
+! write(0,*) 'wrf_init: lhab,lhl,hail_on,density_on = ',lhab,lhl,hail_on,density_on
! IF ( ipelec > 0 ) idonic = .true.
@@ -1335,29 +1536,42 @@ SUBROUTINE nssl_2mom_init( &
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
+! ELSEIF ( icdx == 1 ) THEN
+! bx(lh) = bxh
+! ax(lh) = axh
+ ELSEIF ( icdx > 1 ) THEN
bx(lh) = 0.5
ax(lh) = 75.7149
- ELSE
- bx(lh) = 0.37 ! 0.6 ! Ferrier 1994
+ ELSEIF ( icdx == 0 ) THEN
+ bx(lh) = 0.37 ! 0.6 ! Ferrier 1994 graupel
ax(lh) = 19.3
+ ELSE ! icdx < 0
+! ax(lh) = 206.984 ! Ferrier 1994 hail/frozen drops
+! bx(lh) = 0.6384
+ bx(lh) = bxh
+ ax(lh) = axh
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
+ ax(lhl) = 206.984 ! Ferrier 1994
+ bx(lhl) = 0.6384
ELSEIF (icdxhl > 0 ) THEN
- bx(lhl) = 0.5
- ax(lhl) = 75.7149
+ bx(lhl) = 0.5
+ ax(lhl) = 75.7149
ELSE
- ax(lhl) = 206.984 ! Ferrier 1994
- bx(lhl) = 0.6384
+ bx(lhl) = bxhl
+ ax(lhl) = axhl
ENDIF
ENDIF
@@ -1373,8 +1587,8 @@ SUBROUTINE nssl_2mom_init( &
! 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))
+ bxh1 = bx(lh)
+ bxhl1 = bx(Max(lh,lhl))
! DO j = 0,nqiacralpha
DO j = ialpstart,nqiacralpha
@@ -1390,9 +1604,9 @@ SUBROUTINE nssl_2mom_init( &
! 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,3,1) = gamxinfdp( 2.5+alp+0.5*bxh1, 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,6,1) = (gamma_dpr(5.5+alp+0.5*bxh1) - gamxinfdp( 5.5+alp+0.5*bxh1, ratio ))/y
gamxinflu(i,j,9,1) = gamxinfdp( 1.0+alp, ratio )/y
gamxinflu(i,j,10,1)= gamxinfdp( 4.0+alp, ratio )/y
@@ -1401,9 +1615,9 @@ SUBROUTINE nssl_2mom_init( &
! 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,3,2) = gamxinfdp( 2.5+alp+0.5*bxhl1, 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,6,2) = (gamma_dpr(5.5+alp+0.5*bxhl1) - gamxinfdp( 5.5+alp+0.5*bxhl1, ratio ))/y
gamxinflu(i,j,9,2) = gamxinflu(i,j,9,1)
gamxinflu(i,j,10,2)= gamxinflu(i,j,10,1)
@@ -1411,16 +1625,16 @@ SUBROUTINE nssl_2mom_init( &
! 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
+ gamxinflu(i,j,8,1) = (gamma_dpr(alp - 0.5 + 0.5*bxh1) - gamxinfdp( alp - 0.5 + 0.5*bxh1, ratio ))/y
+! gamxinflu(i,j,8,2) = gamxinfdp( alp - 0.5 + 0.5*bxhl1, ratio )/y
+ gamxinflu(i,j,8,2) = (gamma_dpr(alp - 0.5 + 0.5*bxhl1) - gamxinfdp( alp - 0.5 + 0.5*bxhl1, 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
+! gamxinflu(i,j,8,1) = gamxinfdp( 1.1 - 0.5 + 0.5*bxh1, ratio )/y
+! gamxinflu(i,j,8,2) = gamxinfdp( 1.1 - 0.5 + 0.5*bxhl1, ratio )/y
+ gamxinflu(i,j,8,1) = (gamma_dpr(1.1 - 0.5 + 0.5*bxh1) - gamxinfdp( 1.1 - 0.5 + 0.5*bxh1, ratio ) )/y
+ gamxinflu(i,j,8,2) = (gamma_dpr(1.1 - 0.5 + 0.5*bxhl1) - gamxinfdp( 1.1 - 0.5 + 0.5*bxhl1, ratio ) )/y
ENDIF
gamxinflu(i,j,7,2) = gamxinflu(i,j,7,1)
@@ -1454,9 +1668,8 @@ SUBROUTINE nssl_2mom_init( &
qiacrratio(0,:) = 1.0
- isub = Min( 0, Max(-1,ihvol) ) ! is -1 or 0
-
lccn = 0
+ lccnuf = 0
lccna = 0
lnc = 0
lnr = 0
@@ -1478,34 +1691,41 @@ SUBROUTINE nssl_2mom_init( &
! lccn = 9
- ipconc = ipctmp
IF ( ipconc == 0 ) THEN
- IF ( ihvol >= 0 ) THEN
+ IF ( hail_on == 1 ) THEN ! turn on graupel density for 1-moment scheme
lvh = 9
ltmp = 9
denscale(lvh) = 1
- ELSE ! no hail
+ ELSE ! no hail, 'LFO' scheme
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 = lhab
+ IF ( iufccn > 0 ) THEN
+ ltmp = ltmp+1
+ lccnuf = ltmp
+ denscale(lccnuf) = 1
+ ENDIF
+ lccn= ltmp+1 ! 9
+ lnc = ltmp+2 ! 10
+ lnr = ltmp+3 ! 11
+ lni = ltmp+4 !12
+ lns = ltmp+5 !13
+ lnh = ltmp+6 !14
ltmp = lnh
- IF ( ihvol >= 0 ) THEN
+ IF ( hail_on == 1 ) THEN
ltmp = ltmp + 1
lnhl = ltmp ! lhab+7 ! 15
ENDIF
+ IF ( density_on >= 1 ) THEN
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
+ ENDIF
+ denscale(lccn:ltmp) = 1
+ IF ( density_on == 1 .and. hail_on == 1 ) THEN
ltmp = ltmp + 1
lvhl = ltmp
! ltmp = lvhl
@@ -1523,25 +1743,31 @@ SUBROUTINE nssl_2mom_init( &
! ltmp = lhlw
ENDIF
ELSEIF ( ipconc >= 6 ) THEN
- errmsg = 'NSSL microphysics has not been compiled for 3-moment. Sorry.'
- errflg = 1
- return
- 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 = lhab
+ IF ( iufccn > 0 ) THEN
+ ltmp = ltmp+1
+ lccnuf = ltmp
+ denscale(lccnuf) = 1
+ ENDIF
+
+ lccn= ltmp+1 ! 9
+ lnc = ltmp+2 ! 10
+ lnr = ltmp+3 ! 11
+ lni = ltmp+4 !12
+ lns = ltmp+5 !13
+ lnh = ltmp+6 !14
ltmp = lnh
IF ( lhl > 0 ) THEN
ltmp = ltmp + 1
lnhl = ltmp ! lhab+7 ! 15
ENDIF
+ IF ( density_on == 1 ) THEN
ltmp = ltmp + 1
lvh = ltmp ! lhab+8 + isub ! 16 + isub ! isub adjusts to 15 if hail is off
+ ENDIF
! ltmp = lvh
- denscale(lccn:lvh) = 1
- IF ( ihvol >= 1 ) THEN
+ denscale(lccn:ltmp) = 1
+ IF ( density_on == 1 .and. hail_on == 1 ) THEN
ltmp = ltmp + 1
lvhl = ltmp
! ltmp = lvhl
@@ -1561,19 +1787,14 @@ SUBROUTINE nssl_2mom_init( &
lzh = ltmp
ltmp = ltmp + 1
lzr = ltmp
- ltmp = ltmp + 1
IF ( lhl > 1 ) THEN
ltmp = ltmp + 1
lzhl = ltmp
ENDIF
+ ! write(0,*) 'ipcon,lzr = ',ipconc,lzr,lzh,lzhl
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
@@ -1593,7 +1814,8 @@ SUBROUTINE nssl_2mom_init( &
-
+ ! write(0,*) 'wrf_init: lh,lhl,lzh,lzhl = ',lh,lhl,lzh,lzhl
+ ! write(0,*) 'wrf_init: ipconc = ',ipconc
! write(0,*) 'wrf_init: irenuc, turn_on_ccna = ',irenuc, turn_on_ccna
IF ( turn_on_ccna ) THEN
ltmp = ltmp + 1
@@ -1825,9 +2047,11 @@ SUBROUTINE nssl_2mom_init( &
IF ( lhl .gt. 1 ) ido(lhl) = idohl
IF ( irfall .lt. 0 ) irfall = infall
+ IF ( isfall .lt. 0 ) isfall = infall
IF ( lzr > 0 ) irfall = 0
qccn = ccn/rho00
+ qccnuf = ccnuf/rho00
IF ( old_cccn > 0.0 ) THEN
old_qccn = old_cccn/rho00
ELSE
@@ -1981,6 +2205,33 @@ SUBROUTINE nssl_2mom_init( &
ENDDO
ENDDO
+ dab0lu(:,:,:,:) = 0.0
+ dab1lu(:,:,:,:) = 0.0
+
+ IF ( ipconc >= 6 ) THEN
+ DO il = lc,lhab ! collector
+ DO j = lc,lhab ! collected
+ IF ( il .ne. j ) THEN
+
+ DO jj = ialpstart,nqiacralpha
+ alpjj = float(jj)*dqiacralpha
+ xnujj = (alpjj - 2.)/3.
+ DO ii = ialpstart,nqiacralpha
+ alpii = float(ii)*dqiacralpha
+ xnuii = (alpii - 2.)/3.
+
+ dab0lu(ii,jj,il,j) = delabk(bb(il), bb(j), xnuii, xnujj, xmu(il), xmu(j), 0)
+ dab1lu(ii,jj,il,j) = delabk(bb(il), bb(j), xnuii, xnujj, xmu(il), xmu(j), 1)
+
+ ENDDO
+ ENDDO
+! write(0,*) 'il, j, dab0, dab1 = ',il, j, dab0(il,j), dab1(il,j)
+ ENDIF
+ ENDDO
+ ENDDO
+
+ ENDIF
+
gf4br = gamma_sp(4.0+br)
gf4ds = gamma_sp(4.0+ds)
gf4p5 = gamma_sp(4.0+0.5)
@@ -2029,18 +2280,25 @@ END SUBROUTINE nssl_2mom_init
!>\ingroup mod_nsslmp
!! Driver subroutine that copies state data to local 2D arrays for microphysics calls
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, &
+ cn, vhw, vhl, cna, cni, f_cn, f_cna, f_cina, &
+ f_qc, f_qr, f_qi, f_qs, f_qh, f_qhl, &
+ cnuf, f_cnuf, &
+ zrw, zhw, zhl, f_zrw, f_zhw, f_zhl, f_vhw, f_vhl, &
qsw, qhw, qhlw, &
tt, th, pii, p, w, dn, dz, dtp, itimestep, &
+ is_theta_or_temp, &
+ ntmul, ntcnt, lastloop, &
RAINNC,RAINNCV, &
dx, dy, &
axtra, &
SNOWNC, SNOWNCV, GRPLNC, GRPLNCV, &
SR,HAILNC, HAILNCV, &
+ hail_maxk1, hail_max2d, nwp_diagnostics, &
tkediss, &
re_cloud, re_ice, re_snow, re_rain, &
+ re_graup, re_hail, &
has_reqc, has_reqi, has_reqs, has_reqr, &
+ has_reqg, has_reqh, &
rainncw2, rainnci2, &
dbz, vzf,compdbz, &
rscghis_2d,rscghis_2dp,rscghis_2dn, &
@@ -2074,6 +2332,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
+
+
implicit none
@@ -2091,7 +2351,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
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
+ integer, optional, intent(in) :: is_theta_or_temp
+ logical, optional, intent(in) :: f_zrw, f_zhw, f_zhl, f_vhw, f_vhl ! not used yet
+ real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: dbz, vzf, cn, cna, cni, cnuf
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)
@@ -2102,8 +2364,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
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) :: elecz ! elecsave = Ez
- real, dimension(ims:ime, kms:kme, jms:jme,2),optional, intent(inout) :: scion
+ real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(in) :: elecz ! 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
@@ -2124,22 +2386,30 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout) :: axtra
! WRF variables
- real, dimension(ims:ime, jms:jme), intent(inout):: &
+ real, dimension(ims:ime, jms:jme) :: &
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, jms:jme), optional, intent(inout) :: hail_maxk1, hail_max2d
+ integer, optional, intent(in) :: nwp_diagnostics
+! for cm1, set nproctot=44 (or as needed) to get domain total rates
integer, parameter :: nproc = 1
- REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(INOUT):: re_cloud, re_ice, re_snow, re_rain
+ double precision :: proctot(nproc),proctotmpi(nproc)
+ REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(INOUT):: re_cloud, re_ice, re_snow, &
+ re_rain, re_graup, re_hail
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(IN):: tkediss
- INTEGER, INTENT(IN), optional :: has_reqc, has_reqi, has_reqs, has_reqr
+ INTEGER, INTENT(IN), optional :: has_reqc, has_reqi, has_reqs, has_reqr, has_reqg, has_reqh
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, intent(in), optional :: ntmul, ntcnt
+ logical, optional, intent(in) :: lastloop
+ logical, optional, intent(in) :: diagflag, f_cna, f_cn, f_cina, f_cnuf
+ logical, optional, intent(in) :: f_qc, f_qr, f_qi, f_qs, f_qh, f_qhl
integer, optional, intent(in) :: ipelectmp, ke_diag
! CCPP error handling
@@ -2151,7 +2421,12 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
! REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional,INTENT(INOUT):: qndrop
LOGICAL :: flag_qndrop ! wrf-chem
LOGICAL :: flag_qnifa , flag_qnwfa
+ logical :: flag_cnuf = .false.
+ logical :: flag_ccn = .false.
+ logical :: flag_qi = .true.
+ logical :: has_reqg_local = .false., has_reqh_local = .false.
logical :: flag
+ logical :: nwp_diagflag = .false.
real :: cinchange, t7max,testmax,wmax
! 20130903 acd_ck_washout start
@@ -2176,12 +2451,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
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, 3) :: alpha2d
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
+ real, dimension(its:ite, 1) :: hailmax1d,hailmaxk1
real, dimension(kts:kte, nproc) :: thproclocal
integer, parameter :: nor = 0, ng = 0
- integer :: nx,ny,nz
+ integer :: nx,ny,nz,ngs
integer ix,jy,kz,i,j,k,il,n
integer :: infdo
real :: ssival, ssifac, t8s, t9s, qvapor
@@ -2223,15 +2500,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
real :: fach(kts:kte)
logical, parameter :: debugdriver = .false.
-
-#ifdef MPI
-
-#if defined(MPI)
- integer, parameter :: ntot = 50
- double precision mpitotindp(ntot), mpitotoutdp(ntot)
- INTEGER :: mpi_error_code = 1
-#endif
-#endif
+
+ integer :: loopcnt, loopmax, outerloopcnt
+ logical :: lastlooptmp
! -------------------------------------------------------------------
@@ -2246,13 +2517,52 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
flag_qndrop = .false.
flag_qnifa = .false.
flag_qnwfa = .false.
+ flag_cnuf = .false.
+ flag_ccn = .false.
+ nwp_diagflag = .false.
IF ( PRESENT ( nssl_progn ) ) flag_qndrop = nssl_progn
+ IF ( present ( f_cnuf ) ) flag_cnuf = f_cnuf
+ IF ( present ( nwp_diagnostics ) ) nwp_diagflag = ( nwp_diagnostics > 0 )
+ IF ( present ( f_cn ) .and. present( cn ) ) THEN
+ flag_ccn = f_cn
+ ELSEIF ( present( cn ) ) THEN
+ flag_ccn = .true.
+ ENDIF
+
+ IF ( present( f_qi ) ) THEN
+ flag_qi = f_qi
+ ELSE
+ IF ( ffrzs < 1.0 ) THEN
+ flag_qi = .true.
+ ELSE
+ flag_qi = .false.
+ ENDIF
+ ENDIF
+ IF ( .not. flag_qi .and. ffrzs < 1.0 ) ffrzs = 1.0
+
+ IF ( PRESENT ( has_reqg ) ) has_reqg_local = has_reqg > 0
+ IF ( PRESENT ( has_reqh ) ) has_reqh_local = has_reqh > 0
- ! ---
+ loopmax = 1
+ outerloopcnt = 1
+ lastlooptmp = .true.
+ IF ( present( ntmul ) .and. present( ntcnt ) .and. present( lastloop ) ) THEN
+ loopmax = ntmul
+ outerloopcnt = ntcnt
+ lastlooptmp = lastloop
+ ENDIF
+
+
+ has_wetscav = .false.
+ IF ( wrfchem_flag > 0 ) THEN
+ IF ( PRESENT( wetscav_on ) ) THEN
+ has_wetscav = wetscav_on
+ ENDIF
+ ENDIF
IF ( present( f_cna ) ) THEN
f_cnatmp = f_cna
@@ -2303,8 +2613,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
nx = ite-its+1
ny = 1 ! set up as 2D slabs
nz = kte-kts+1
+ ngs = 64
- IF ( .not. present( cn ) ) THEN
+ IF ( .not. flag_ccn ) THEN
renucfrac = 1.0
ENDIF
@@ -2365,32 +2676,35 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
ancuten(its:ite,1,kts:kte,:) = 0.0
thproclocal(:,:) = 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
+ IF ( nwp_diagflag ) THEN
+ alpha2d(its:ite,1,kts:kte,1) = alphar
+ alpha2d(its:ite,1,kts:kte,2) = alphah
+ alpha2d(its:ite,1,kts:kte,3) = alphahl
+ ENDIF
+
+
! copy from 3D array to 2D slab
DO kz = kts,kte
DO ix = its,ite
-
IF ( present( tt ) ) THEN
an(ix,1,kz,lt) = tt(ix,kz,jy)/pii(ix,kz,jy)
ELSE
an(ix,1,kz,lt) = th(ix,kz,jy)
ENDIF
-
-
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
+ IF ( flag_qi ) THEN
an(ix,1,kz,li) = qi(ix,kz,jy)
ELSE
an(ix,1,kz,li) = 0.0
@@ -2401,13 +2715,16 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
IF ( lccn > 1 ) THEN
IF ( is_aerosol_aware .and. flag_qnwfa ) THEN
!
- ELSEIF ( present( cn ) ) THEN
+ ELSEIF ( flag_ccn ) 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
+ IF ( i_uf_or_ccn > 0 .and. lccnuf > 1 ) THEN ! UF ccn are extra regular ccn
+ an(ix,1,kz,lccn) = an(ix,1,kz,lccn) + cnuf(ix,kz,jy)
+ ENDIF
ELSE
IF ( lccna == 0 .and. ( .not. f_cnatmp ) ) THEN
an(ix,1,kz,lccn) = qccn - ccw(ix,kz,jy)
@@ -2418,6 +2735,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
ENDIF
ENDIF
+ IF ( lccnuf > 0 .and. flag_cnuf ) THEN
+ IF ( i_uf_or_ccn == 0 ) THEN ! UF are UF
+ an(ix,1,kz,lccnuf) = Max(0.0, cnuf(ix,kz,jy) )
+ ELSE ! UF were added to lccn
+ an(ix,1,kz,lccnuf) = 0.0
+ ENDIF
+ ENDIF
+
IF ( lccna > 1 ) THEN
IF ( present( cna ) .and. f_cnatmp ) THEN
an(ix,1,kz,lccna) = cna(ix,kz,jy)
@@ -2448,9 +2773,19 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
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)
+ IF ( ipconc >= 6 ) THEN
+ IF ( lzr > 0 ) an(ix,1,kz,lzr) = zrw(ix,kz,jy)*zscale
+ IF ( lzh > 0 ) an(ix,1,kz,lzh) = zhw(ix,kz,jy)*zscale
+ IF ( lzhl > 0 ) an(ix,1,kz,lzhl) = zhl(ix,kz,jy)*zscale
+ ENDIF
+ ENDDO
+ ENDDO
+
+ DO kz = kts,kte
+ DO ix = its,ite
IF ( present( tt ) ) THEN
@@ -2458,6 +2793,26 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
ELSE
t0(ix,1,kz) = th(ix,kz,jy)*pii(ix,kz,jy) ! temperature (Kelvin)
ENDIF
+ 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
+ ENDDO
+ ENDDO
+
+ DO ix = its,ite
+ RAINNCV(ix,jy) = 0.0
+ IF ( present( GRPLNCV ) ) GRPLNCV(ix,jy) = 0.0
+ IF ( present( HAILNCV ) ) HAILNCV(ix,jy) = 0.0
+ IF ( present( SNOWNCV ) ) SNOWNCV(ix,jy) = 0.0
+ ENDDO
+
+ DO loopcnt = 1,loopmax
+
+ DO kz = kts,kte
+ DO ix = its,ite
+
+
t1(ix,1,kz) = 0.0
t2(ix,1,kz) = 0.0
t3(ix,1,kz) = 0.0
@@ -2467,14 +2822,11 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
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)
+! calculate dn1 in case we are substepping: rho = con_eps*prsl/(con_rd*tgrs*(qv_mp+con_eps))
+ dn1(ix,1,kz) = rdorv*pn(ix,1,kz)/(rd*t0(ix,1,kz)*(an(ix,1,kz,lv) + rdorv))
! wmax = Max(wmax,wn(ix,1,kz))
dz2d(ix,1,kz) = dz(ix,kz,jy)
dz2dinv(ix,1,kz) = 1./dz(ix,kz,jy)
@@ -2492,6 +2844,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
!
ssival = Min(t8s,max(an(ix,1,kz,lv),0.0))/t9s ! qv/qvi
+
if ( ssival .gt. 1.0 ) then
!
IF ( icenucopt == 1 ) THEN
@@ -2544,19 +2897,20 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
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 !
+ IF ( t0(ix,1,kz) < 268.16 .and. t0(ix,1,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)
+ ! dp1 = 1.e3*0.0000594*(273.16 - t0(ix,1,kz))**3.33 * (1.e-6*cin*dn(ix,1,kz))**(0.0264*(273.16 - t0(ix,1,kz)) + 0.0033)
+ tmp = 1.e-6*naer
+ dp1 = 1.e3*dn1(ix,1,kz)/rho00*0.0000594*(273.16 - t0(ix,1,kz))**3.33 * tmp**(0.0264*(273.16 - t0(ix,1,kz)) + 0.0033)
+ t7(ix,1,kz) = Min(dp1, 1.0d30)
ELSE
- t7(ix,jy,kz) = 0.0
+ ! t7(ix,1,kz) = 0.0
ENDIF
ENDIF ! icenucopt
@@ -2569,39 +2923,39 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
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
+ IF ( wrfchem_flag > 0 ) THEN
+ IF ( has_wetscav ) THEN
+ IF ( PRESENT( rainprod ) ) rainprod2d(its:ite,kts:kte) = 0
+ IF ( PRESENT( evapprod ) ) evapprod2d(its:ite,kts:kte) = 0
+ ENDIF
+ ENDIF
! transform from number mixing ratios to number conc.
+ IF ( loopcnt == 1 ) THEN
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)
+ an(ix,1,kz,il) = an(ix,1,kz,il)*dn1(ix,1,kz) ! dn(ix,kz,jy)
ENDDO
ENDDO
ENDIF
ENDDO ! il
+ ENDIF
+
! sedimentation
xfall(:,:,:) = 0.0
- IF ( .true. ) THEN
+
+! IF ( .true. ) THEN
! #ifndef CM1
! for real cases when hydrometeor mixing ratios have been initialized without concentrations
- IF ( itimestep == 1 .and. ipconc > 0 ) THEN
+ IF ( itimestep == 1 .and. ipconc > 0 .and. loopcnt == 1 ) THEN
call calcnfromq(nx,ny,nz,an,na,nor,nor,dn1)
ENDIF
! IF ( itimestep == 3 .and. ipconc > 0 ) THEN
@@ -2611,9 +2965,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
IF ( present(cu_used) .and. &
( present( qrcuten ) .or. present( qscuten ) .or. &
- present( qicuten ) .or. present( qccuten ) ) ) THEN
+ present( qicuten ) .or. present( qccuten ) ) ) THEN !{
- IF ( cu_used == 1 ) THEN
+ IF ( cu_used == 1 ) THEN !{
DO kz = kts,kte
DO ix = its,ite
@@ -2627,10 +2981,22 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
call calcnfromcuten(nx,ny,nz,ancuten,an,na,nor,nor,dn1)
+ DO kz = kts,kte
+ DO ix = its,ite
+
+
+ IF ( ipconc >= 6 ) THEN
+! IF ( lzr > 0 ) an(ix,1,kz,lzr) = an(ix,1,kz,lzr) + ancuten(ix,1,kz,lzr)
+ ENDIF
+
+ ENDDO
+ ENDDO
- ENDIF
+ ENDIF !}
- ENDIF
+ ENDIF !}
+
+
call sediment1d(dtp,nx,ny,nz,an,na,nor,nor,xfall,dn1,dz2d,dz2dinv, &
@@ -2644,10 +3010,12 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
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) + &
+ RAINNCV(ix,jy) = 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) + &
+ RAINNCV(ix,jy) = 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
@@ -2662,17 +3030,19 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
& 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( SNOWNCV ) ) SNOWNCV(ix,jy) = SNOWNCV(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,ls)*1000./xdn0(lr)
IF ( present( GRPLNCV ) ) THEN
IF ( lhl > 1 .and. .not. present( HAILNC) ) THEN ! if no separate hail accum, then add to graupel
- GRPLNCV(ix,jy) = dtp*dn1(ix,1,1)*(xfall(ix,1,lh) + xfall(ix,1,lhl)) *1000./xdn0(lr)
+ GRPLNCV(ix,jy) = GRPLNCV(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,lh) + xfall(ix,1,lhl)) *1000./xdn0(lr)
ELSE
- GRPLNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lh)*1000./xdn0(lr)
+ GRPLNCV(ix,jy) = GRPLNCV(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,lh)*1000./xdn0(lr)
ENDIF
ENDIF
- RAINNC(ix,jy) = RAINNC(ix,jy) + RAINNCV(ix,jy)
+ IF ( loopcnt == loopmax ) 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 ( present (SNOWNC) .and. present (SNOWNCV) .and. loopcnt == loopmax ) THEN
+ SNOWNC(ix,jy) = SNOWNC(ix,jy) + SNOWNCV(ix,jy)
+ ENDIF
IF ( lhl > 1 ) THEN
!#ifdef CM1
! IF ( .true. ) THEN
@@ -2680,13 +3050,15 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
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)
+ IF ( loopcnt == loopmax ) HAILNC(ix,jy) = HAILNC(ix,jy) + HAILNCV(ix,jy)
! ELSEIF ( present( GRPLNCV ) ) THEN ! if no separate hail accum, then add to graupel
! GRPLNCV(ix,jy) = 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( GRPLNCV ) .and. loopcnt == loopmax ) THEN
+ GRPLNC(ix,jy) = GRPLNC(ix,jy) + GRPLNCV(ix,jy)
+ ENDIF
+ IF ( present( SR ) .and. present (SNOWNCV) .and. present(GRPLNCV) .and. loopcnt == loopmax ) THEN
IF ( present( HAILNC ) ) THEN
SR(ix,jy) = (SNOWNCV(ix,jy)+HAILNCV(ix,jy)+GRPLNCV(ix,jy))/(RAINNCV(ix,jy)+1.e-12)
ELSE
@@ -2695,7 +3067,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
ENDIF
ENDDO
- ENDIF ! .false.
+! ENDIF ! .false.
IF ( isedonly /= 1 ) THEN
! call nssl_2mom_gs: main gather-scatter routine to calculate microphysics
@@ -2717,15 +3089,22 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
! & ln,ipc,lvol,lz,lliq, &
& cdx, &
& xdn0,dbz2d,tke2d, &
- & thproclocal,nproc,dx1,dy1, &
+ & thproclocal,nproc,dx1,dy1,ngs, &
& timevtcalc,axtra2d, makediag &
- & ,has_wetscav, rainprod2d, evapprod2d &
+ & ,has_wetscav, rainprod2d, evapprod2d, alpha2d &
& ,errmsg,errflg &
& ,elec2,its,ids,ide,jds,jde &
& )
+! recalculate dn1 after temperature changes: rho = con_eps*prsl/(con_rd*tgrs*(qv_mp+con_eps))
+ DO kz = kts,kte
+ DO ix = its,ite
+ dn1(ix,1,kz) = rdorv*pn(ix,1,kz)/(rd*t0(ix,1,kz)*(an(ix,1,kz,lv) + rdorv))
+ ENDDO
+ ENDDO
+
ENDIF ! isedonly /= 1
@@ -2737,29 +3116,38 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
& ,dz2d &
& ,t0,t9 &
& ,an,dn1,t77 &
- & ,pn,wn &
+ & ,pn,wn &
+ & ,ngs &
& ,axtra2d, makediag &
& ,ssat,t00,t77,flag_qndrop)
+! recalculate dn1 after temperature changes
+ DO kz = kts,kte
+ DO ix = its,ite
+ dn1(ix,1,kz) = rdorv*pn(ix,1,kz)/(rd*t0(ix,1,kz)*(an(ix,1,kz,lv) + rdorv))
+ ENDDO
+ ENDDO
+
ENDIF
+
+ ENDDO ! loopcnt=1,loopmax
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
+ IF ( present( dbz ) .and. makediag .and. lastlooptmp ) THEN
! calc dbz
IF ( .true. ) THEN
@@ -2797,7 +3185,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
! 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
+ present( re_cloud ).and. present( re_ice ) .and. present( re_snow ) .and. &
+ lastlooptmp) 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
@@ -2815,16 +3204,16 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
call calc_eff_radius &
& (nx,ny,nz,na,jy &
& ,nor,nor &
- & ,t1=t1,t2=t2,t3=t3,t4=t4 &
+ & ,t1=t1,t2=t2,t3=t3,t4=t4,t5=t5,t6=t6,f_t5=has_reqg_local, f_t6=has_reqh_local &
& ,an=an,dn=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), 200.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), 200.E-6))
+ IF ( .not. present(qi) ) re_ice(ix,kz,jy) = MAX(10.E-6, MIN(t3(ix,1,kz), 125.E-6))
ENDDO
ENDDO
@@ -2837,19 +3226,53 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
ENDDO
ENDIF
ENDIF
+
+ IF ( present(has_reqg) .and. present( re_graup ) ) THEN
+ IF ( has_reqg /= 0 ) THEN
+ DO kz = kts,kte
+ DO ix = its,ite
+ re_graup(ix,kz,jy) = MAX(50.E-6, MIN(t5(ix,1,kz), 10.E-3))
+ ENDDO
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF ( present(has_reqh) .and. present( re_hail ) ) THEN
+ IF ( has_reqh /= 0 ) THEN
+ DO kz = kts,kte
+ DO ix = its,ite
+ re_hail(ix,kz,jy) = MAX(50.E-6, MIN(t5(ix,1,kz), 40.E-3))
+ ENDDO
+ ENDDO
+ ENDIF
+ ENDIF
ENDIF
ENDIF
+ IF ( present( hail_maxk1 ) .and. present( hail_max2d ) .and. nwp_diagflag ) THEN
+ DO ix = its,ite
+ hailmax1d(ix,1) = hail_max2d(ix,jy)
+ hailmaxk1(ix,1) = hail_maxk1(ix,jy)
+ ENDDO
+
+ call hailmaxd(dtp,nx,ny,nz,an,na,nor,nor,alpha2d,dn1, &
+ hailmax1d,hailmaxk1,1 )
+ DO ix = its,ite
+ hail_max2d(ix,jy) = hailmax1d(ix,1)
+ hail_maxk1(ix,jy) = hailmaxk1(ix,1)
+ 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)
+ an(ix,1,kz,il) = an(ix,1,kz,il)/dn1(ix,1,kz) ! dn(ix,kz,jy)
ENDDO
ENDDO
ENDIF
@@ -2870,14 +3293,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
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)
+ IF ( flag_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
+ ELSEIF ( flag_ccn .and. lccn > 1 .and. .not. flag_qndrop) THEN
IF ( lccna > 1 .and. .not. ( present( cna ) .and. f_cnatmp ) ) THEN
cn(ix,kz,jy) = Max(0.0, an(ix,1,kz,lccna) )
ELSE
@@ -2896,6 +3319,21 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
ENDIF
ENDIF
+ IF ( lccnuf > 0 .and. flag_cnuf ) THEN
+ IF ( i_uf_or_ccn > 0 ) THEN ! UF are ccn and lccnuf is zero, so put cnuf into lccnuf to do decay
+ an(ix,1,kz,lccnuf) = Max(0.0, cnuf(ix,kz,jy) )
+ ENDIF
+ IF ( decayufccn ) THEN
+ IF ( an(ix,1,kz,lccnuf) > ufbackground ) THEN
+ an(ix,1,kz,lccnuf) = an(ix,1,kz,lccnuf) - (an(ix,1,kz,lccnuf) - &
+ ufbackground)*(1.0 - exp(-dtp/ufccntimeconst))
+ ENDIF
+ ENDIF
+ cnuf(ix,kz,jy) = an(ix,1,kz,lccnuf)
+ ENDIF
+
+
+
IF ( ipconc >= 5 ) THEN
ccw(ix,kz,jy) = an(ix,1,kz,lnc)
@@ -2906,6 +3344,11 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
IF ( lhl > 1 ) chl(ix,kz,jy) = an(ix,1,kz,lnhl)
ENDIF
+ IF ( ipconc >= 6 ) THEN
+ IF ( lzr > 0 ) zrw(ix,kz,jy) = an(ix,1,kz,lzr) *zscaleinv
+ IF ( lzh > 0 ) zhw(ix,kz,jy) = an(ix,1,kz,lzh) *zscaleinv
+ IF ( lzhl > 0 ) zhl(ix,kz,jy) = an(ix,1,kz,lzhl)*zscaleinv
+ ENDIF
@@ -2914,6 +3357,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
#if ( WRF_CHEM == 1 )
IF ( has_wetscav ) THEN
+ IF ( loopmax > 1 ) THEN
+ ! wrferror not supported
+ ENDIF
IF ( PRESENT( rainprod ) ) rainprod(ix,kz,jy) = rainprod2d(ix,kz)
IF ( PRESENT( evapprod ) ) evapprod(ix,kz,jy) = evapprod2d(ix,kz)
ENDIF
@@ -2921,8 +3367,11 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
ENDDO
ENDDO
-
+
+
ENDDO ! jy
+
+
@@ -3217,7 +3666,7 @@ END FUNCTION GAML02
! **********************************************************
!>\ingroup mod_nsslmp
!! Function calculates fraction of drops larger than 300 microns ( imurain == 3 )
- real FUNCTION GAML02d300(x)
+ real FUNCTION GAML02d300(x)
implicit none
integer ig, i, ii, n, np
real x
@@ -3558,11 +4007,245 @@ Function delabk(ba,bb,nua,nub,mua,mub,k)
RETURN
END Function delabk
-
+
+
+! #######################################################################
+! HAILMAXD - calculated maximum expected hail size
+! #######################################################################
!>\ingroup mod_nsslmp
-!! Sedimentation driver subroutine. Calls fallout column by column
- subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
+!! Hail max size subroutine.
+ subroutine hailmaxd(dtp,nx,ny,nz,an,na,nor,norz,alpha2d,dn, &
+ & hailmax1d,hailmaxk1,jslab )
+!
+! Calculate maximum hail size from the tail of of the distribution. The value
+! of thresh_conc sets the minimum concentration in the integral over (Dmax, Inf).
+! This uses the lookup tables for incomplete gamma functions and simply search for
+! the expected value (and linearly interpolate) on D.
+!
+! Written by ERM 7/2023
+!
+!
+!
+ implicit none
+
+ integer nx,ny,nz,nor,norz,ngt,jgs,na,ia
+ integer id ! =1 use density, =0 no density
+! integer :: its,ite ! x-range to calculate
+
+ 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 gz(-nor+ng1:nz+nor),z1d(-nor+ng1:nz+nor,4)
+ real dtp
+ real alpha2d(-nor+1:nx+nor,1,-norz+1:nz+norz,3) ! array for PSD shape parameters
+ real :: hailmax1d(nx,ny),hailmaxk1(nx,ny)
+ integer infdo
+ integer jslab ! which line of xfall to use
+
+ integer ix,jy,kz,ndfall,n,k,il,in
+ double precision :: tmp, ratio, del, g1palp
+ real, parameter :: dz = 200.
+
+ real :: db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1)
+
+ real :: rhovtzx(nz,nx)
+
+ real :: alp, diam, diam1, hwdn
+
+! real, parameter :: cmin = 0.001 ! threshold number per m^3 for maximum diamter (threshold from diag_nwp)
+ DOUBLE PRECISION, PARAMETER:: thresh_conc = 0.0005d0 ! number conc. of graupel/hail per cubic meter
+ real :: cwchtmp,cwchltmp, maxdia
+
+!-----------------------------------------------------------------------------
+
+ integer :: ixb, jyb, kzb
+ integer :: ixe, jye, kze
+ integer :: plo, phi
+ integer :: ialp, i, j
+
+ logical :: debug_mpi = .TRUE.
+
+! ###################################################################
+
+
+ IF ( lh > 1 ) THEN
+ cwchtmp = ((3. + dnu(lh))*(2. + dnu(lh))*(1.0 + dnu(lh)))**(-1./3.)
+ ENDIF
+ IF ( lhl > 1 ) THEN
+ cwchltmp = ((3. + dnu(lhl))*(2. + dnu(lhl))*(1.0 + dnu(lhl)))**(-1./3.)
+ ENDIF
+
+
+ kzb = 1
+ kze = nz
+
+ ixb = 1 ! aliased its
+ ixe = nx ! aliased ite
+
+
+ jy = jslab
+ jgs = jy
+
+
+! hailmax1d(:,jy) = 0.0
+! hailmaxk1(:,jy) = 0.0
+
+ if ( ndebug .gt. 0 ) write(0,*) 'dbg = 3a'
+
+
+! first graupel, even if hail is also predicted, since graupel can sometime be large on its own
+ IF ( lh > 1 .and. lnh > 1 ) THEN
+ DO kz = kzb,kze
+ DO ix = ixb,ixe
+ IF ( an(ix,jy,kz,lh) .gt. qxmin(lh) .and. an(ix,jy,kz,lnh) .gt. thresh_conc ) THEN
+ IF ( lvh .gt. 1 ) THEN
+ hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh)
+ ELSE
+ hwdn = rho_qh
+ ENDIF
+
+ tmp = 1. + alpha2d(ix,1,kz,2)
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+ tmp = dn(ix,jy,kz)*an(ix,jy,kz,lh)/(hwdn*an(ix,jy,kz,lnh))
+ diam = (6.0*tmp/pi)**(1./3.)
+ IF ( lzh > 1 ) THEN ! 3moment
+ cwchtmp = ((3. + alpha2d(ix,1,kz,2))*(2. + alpha2d(ix,1,kz,2))*(1.0 + alpha2d(ix,1,kz,2)))**(-1./3.)
+ ENDIF
+ diam1 = diam*cwchtmp ! characteristic diameter, i.e., 1/lambda
+ ! want cxd1 = thresh_conc
+ ! tmp = gaminterp(ratio,alpha(mgs,lh),1,1)
+ ! cxd1 = cx(mgs,lh)*(tmp)/g1palp
+ ! tmp = thresh_conc*g1palp/cx
+ !
+ tmp = thresh_conc*g1palp/an(ix,jy,kz,lnh)
+ alp = alpha2d(ix,1,kz,2)
+ ! gamxinflu(i,j,luindex,ilh)
+ j = Int(Max(0.0,Min(maxalphalu,alp))*dqiacralphainv)
+ ratio = 0.0
+ maxdia = 0.0
+ ! eventually could replace with bisection search, but final value of i is usually small
+ ! compared to nqiacrratio
+ DO i = 0,nqiacrratio-1
+ IF ( gamxinflu(i,j,1,1) >= tmp .and. tmp >= gamxinflu(i+1,j,1,1) ) THEN
+ ! interpolate here for FWIW
+ ratio = i*dqiacrratio
+ del = tmp - gamxinflu(i,j,1,1)
+ ratio = (float(i) + del/(gamxinflu(i+1,j,1,1) - gamxinflu(i,j,1,1)))*dqiacrratio
+ exit
+ ENDIF
+ ENDDO
+
+ IF ( ratio > 0.0 ) THEN
+ maxdia = ratio*diam1 ! units of m
+ ENDIF
+
+ IF ( kz == kzb ) THEN
+ hailmaxk1(ix,jy) = Max( maxdia, hailmaxk1(ix,jy) )
+! IF ( maxdia > 0.1 ) THEN
+! IF ( an(ix,jy,kz,lh) > 1.e-4 ) THEN
+! write(0,*) 'maxdia,tmp,alp,ratio,diam,diam1= ',maxdia,tmp,alp,ratio,diam*100.,diam1*100.
+! write(0,*) 'hwdn, cxhl, qx, g1palp = ',hwdn, an(ix,jy,kz,lnhl), an(ix,jy,kz,lhl), g1palp
+! write(0,*) 'j,gamxinflu(0,2,4) = ',j,gamxinflu(0,j,1,1),gamxinflu(2,j,1,1), &
+! gamxinflu(4,j,1,1)
+! ENDIF
+ ENDIF
+
+ hailmax1d(ix,jy) = Max(maxdia, hailmax1d(ix,jy) )
+
+ !
+
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+ ENDIF ! lh
+
+! And diam for hail if present
+ IF ( lhl > 1 .and. lnhl > 1 ) THEN
+ DO kz = kzb,kze
+ DO ix = ixb,ixe
+ IF ( an(ix,jy,kz,lhl) .gt. qxmin(lhl) .and. an(ix,jy,kz,lnhl) .gt. thresh_conc ) THEN
+ IF ( lvhl .gt. 1 ) THEN
+ hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl)
+ ELSE
+ hwdn = rho_qhl
+ ENDIF
+
+ tmp = 1. + alpha2d(ix,1,kz,3)
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+ tmp = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/(hwdn*an(ix,jy,kz,lnhl))
+ diam = (6.0*tmp/pi)**(1./3.)
+ IF ( lzhl > 1 ) THEN ! 3moment
+ cwchltmp = ((3. + alpha2d(ix,1,kz,3))*(2. + alpha2d(ix,1,kz,3))*(1.0 + alpha2d(ix,1,kz,3)))**(-1./3.)
+ ENDIF
+ diam1 = diam*cwchltmp ! characteristic diameter, i.e., 1/lambda
+ ! want cxd1 = thresh_conc
+ ! tmp = gaminterp(ratio,alpha(mgs,lh),1,1)
+ ! cxd1 = cx(mgs,lh)*(tmp)/g1palp
+ ! tmp = thresh_conc*g1palp/cx
+ !
+ tmp = thresh_conc*g1palp/an(ix,jy,kz,lnhl)
+ alp = alpha2d(ix,1,kz,3)
+ ! gamxinflu(i,j,luindex,ilh)
+ j = Int(Max(0.0,Min(maxalphalu,alp))*dqiacralphainv)
+ ratio = 0.0
+ maxdia = 0.0
+ ! eventually could replace with bisection search, but final value of i is usually small
+ ! compared to nqiacrratio
+ DO i = 0,nqiacrratio-1
+ IF ( gamxinflu(i,j,1,1) >= tmp .and. tmp >= gamxinflu(i+1,j,1,1) ) THEN
+ ! interpolate here for FWIW
+ ratio = i*dqiacrratio
+ del = tmp - gamxinflu(i,j,1,1)
+ ratio = (float(i) + del/(gamxinflu(i+1,j,1,1) - gamxinflu(i,j,1,1)))*dqiacrratio
+ exit
+ ENDIF
+ ENDDO
+
+ IF ( ratio > 0.0 ) THEN
+ maxdia = ratio*diam1 ! units of m
+ ENDIF
+
+ IF ( kz == kzb ) THEN
+ hailmaxk1(ix,jy) = Max( maxdia, hailmaxk1(ix,jy) )
+! IF ( maxdia > 0.1 ) THEN
+! IF ( an(ix,jy,kz,lhl) > 1.e-4 ) THEN
+! write(0,*) 'maxdia,tmp,alp,ratio,diam,diam1= ',maxdia,tmp,alp,ratio,diam*100.,diam1*100.
+! write(0,*) 'hwdn, cxhl, qx, g1palp = ',hwdn, an(ix,jy,kz,lnhl), an(ix,jy,kz,lhl), g1palp
+! write(0,*) 'j,gamxinflu(0,2,4) = ',j,gamxinflu(0,j,1,1),gamxinflu(2,j,1,1), &
+! gamxinflu(4,j,1,1)
+! ENDIF
+ ENDIF
+
+ hailmax1d(ix,jy) = Max(maxdia, hailmax1d(ix,jy) )
+
+ !
+
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+ ENDIF
+
+
+ END SUBROUTINE HAILMAXD
+! #######################################################################
+! #######################################################################
+!>\ingroup mod_nsslmp
+!! Sedimentation driver subroutine. Calls fallout column by column
+ 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
!
@@ -3591,7 +4274,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
! 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
+! real xfall0(nx,ny) ! dummy array
integer infdo
integer jslab ! which line of xfall to use
@@ -3599,47 +4282,81 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
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 :: 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)
+! real :: rhovtzx(nz,nx)
+
+ real, allocatable :: db1(:,:), dtz1(:,:,:),dz2dinv(:,:),db1inv(:,:) ! db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1)
+ real, allocatable :: rhovtzx(:,:)
+ real, allocatable :: xfall0(:,:), xvt(:,:,:,:),tmpn(:,:,:),tmpn2(:,:,:),z(:,:,:)
double precision :: timesed1,timesed2,timesed3, zmaxsed,timesetvt,dummy
double precision :: dt1,dt2,dt3,dt4
- integer,parameter :: ngs = 128
+ integer :: ngs ! = 512
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)
+! 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)
+
+ real, allocatable :: qx(:,:)
+ real, allocatable :: qxw(:,:)
+ real, allocatable :: cx(:,:)
+ real, allocatable :: xv(:,:)
+ real, allocatable :: vtxbar(:,:,:)
+ real, allocatable :: xmas(:,:)
+ real, allocatable :: xdn(:,:)
+ real, allocatable :: xdia(:,:,:)
+ real, allocatable :: vx(:,:)
+ real, allocatable :: alpha(:,:)
+ real, allocatable :: zx(:,:)
+ logical, allocatable :: hasmass(:,:)
+
+ integer, allocatable :: igs(:),kgs(:)
+
+ real, allocatable :: rho0(:),temcg(:)
+
+ real, allocatable :: temg(:)
+
+ real, allocatable :: rhovt(:)
+
+ real, allocatable :: cwnc(:),cinc(:)
+ real, allocatable :: fadvisc(:),cwdia(:),cipmas(:)
+
+ real, allocatable :: cnina(:),cimas(:)
+
+ real, allocatable :: cnostmp(:)
+
+ real :: cimasn,cimasx
!-----------------------------------------------------------------------------
@@ -3653,7 +4370,30 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
! ###################################################################
-
+ allocate( db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1),rhovtzx(nz,nx) )
+ allocate( xfall0(nx,ny), xvt(nz+1,nx,3,lc:lhab), tmpn(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) )
+ allocate( tmpn2(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz), z(-nor+ng1:nx+nor,-norz+ng1:nz+norz,lr:lhab))
+
+ ngs = nz+3
+
+ allocate( qx(ngs,lv:lhab), &
+ qxw(ngs,ls:lhab), &
+ cx(ngs,lc:lhab), &
+ xv(ngs,lc:lhab), &
+ vtxbar(ngs,lc:lhab,3), &
+ xmas(ngs,lc:lhab), &
+ xdn(ngs,lc:lhab), &
+ xdia(ngs,lc:lhab,3), &
+ vx(ngs,li:lhab), &
+ alpha(ngs,lc:lhab), &
+ zx(ngs,lr:lhab), &
+ hasmass(nx,lc+1:lhab), &
+ igs(ngs),kgs(ngs), &
+ rho0(ngs),temcg(ngs),temg(ngs), rhovt(ngs), &
+ cwnc(ngs),cinc(ngs), &
+ fadvisc(ngs),cwdia(ngs),cipmas(ngs), &
+ cnina(ngs),cimas(ngs), &
+ cnostmp(ngs) )
kzb = 1
kze = nz
@@ -3825,7 +4565,8 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
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
+ IF ( (il .eq. lr .and. irfall .eq. infall .and. lzr < 1) .or. &
+ (il .ge. lh .and. lz(il) .lt. 1 ) .or. (il == ls .and. isfall == infall ) ) 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
@@ -3850,6 +4591,14 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
ENDIF
ENDIF
+! reflectivity
+
+ IF ( ipconc .ge. 6 ) THEN
+ IF ( lz(il) .gt. 1 ) THEN
+ call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,3,il), &
+ & an,db1,lz(il),0,xfall,dtz1,ix)
+ ENDIF
+ ENDIF
if (ndebug .gt. 0 ) write(0,*) 'dbg = 3d'
@@ -3863,9 +4612,11 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
! 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. &
+ IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. ( (il == ls .and. isfall .eq. infall ) &
+ & .or. il .eq. lh .or. il .eq. lhl .or. il == lf .or. &
& ( il .eq. lr .and. irfall .eq. infall) ) ) THEN
+ ! set up for method I+II
DO kz = kzb,kze
! DO ix = ixb,ixe
tmpn2(ix,jy,kz) = z(ix,kz,il)
@@ -3878,7 +4629,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
ENDDO
ELSE
-
+ ! set up for method II only
DO kz = kzb,kze
! DO ix = ixb,ixe
tmpn(ix,jy,kz) = an(ix,jy,kz,ln(il))
@@ -3907,7 +4658,8 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
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
+ & ( il .ge. lh .or. (il .eq. lr .and. irfall .eq. infall) &
+ .or. (il .eq. ls .and. isfall .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), &
@@ -3918,12 +4670,12 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
ENDIF
IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. ( (il .eq. lr .and. irfall .eq. infall) &
- & .or. il .ge. lh ) ) THEN
+ & .or. il .ge. lh .or. (il == ls .and. isfall .eq. infall ) ) ) 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)
+ & lvol(il), xdn0(il), infall, ix)
ELSEIF ( infall .eq. 5 .and. il .ge. lh .or. ( il == lr .and. irfall == 5 ) ) THEN
@@ -3934,7 +4686,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
! ENDDO
ENDDO
- ELSEIF ( .not. (il .eq. lr .and. irfall .eq. 0) ) THEN
+ ELSEIF ( .not. (il .eq. lr .and. irfall .eq. 0) .and. .not. (il .eq. ls .and. isfall .eq. 0) ) THEN
! "Method II" M-wgt N-fallout correction
DO kz = kzb,kze
@@ -3961,8 +4713,29 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
ENDDO ! ix
+ deallocate( db1,dtz1,dz2dinv,db1inv,rhovtzx )
+ deallocate( xfall0, xvt, tmpn )
+ deallocate( tmpn2, z)
+
+ deallocate( qx, &
+ qxw, &
+ cx, &
+ xv, &
+ vtxbar, &
+ xmas, &
+ xdn, &
+ xdia, &
+ vx, &
+ alpha, &
+ zx, &
+ hasmass, &
+ igs,kgs, &
+ rho0,temcg,temg, rhovt, &
+ cwnc,cinc, &
+ fadvisc,cwdia,cipmas, &
+ cnina,cimas, &
+ cnostmp )
-
RETURN
END SUBROUTINE SEDIMENT1D
@@ -4120,13 +4893,14 @@ subroutine calczgr1d(nx,ny,nz,nor,na,a,ixe,kze, &
integer ix,jy,kz
- real vr,qr,nrx,rd,xv,g1,zx,chw,xdn
+ real vr,qr,nrx,rd,xv,g1,zx,chw,xdn,ynu
jy = jgs
ix = ixcol
- IF ( l .eq. lh .or. l .eq. lhl .or. ( l .eq. lr .and. imurain == 1 ) ) THEN
+ IF ( l .eq. lh .or. l .eq. lhl .or. ( l .eq. lr .and. imurain == 1 ) &
+ .or. ( l .eq. ls .and. imusnow == 1 ) ) THEN
DO kz = 1,kze
@@ -4176,16 +4950,19 @@ subroutine calczgr1d(nx,ny,nz,nor,na,a,ixe,kze, &
ENDDO
- ELSEIF ( l .eq. lr .and. imurain == 3) THEN
+ ELSEIF ( (l == ls .and. imusnow == 3) .or. ( l .eq. lr .and. imurain == 3 ) ) THEN
- xdn = 1000.
+ xdn = rho_qx ! 1000.
+ IF ( l == ls ) ynu = snu
+ IF ( l == lr ) ynu = rnu
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)
+! z(ix,kz,l) = 3.6e18*(ynu+2.0)*a(ix,jy,kz,ln)*vr**2/(ynu+1.0)
+ z(ix,kz,l) = 3.6*(ynu+2.0)*a(ix,jy,kz,ln)*vr**2/(ynu+1.0)
! qr = a(ix,jy,kz,lr)
! nrx = a(ix,jy,kz,lnr)
@@ -4598,6 +5375,15 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, &
ENDIF
ENDIF
+ IF ( lzr > 1 ) THEN ! set reflectivity moment
+ IF ( an(ix,jy,kz,lr) > qxmin_init(lr) .and. an(ix,jy,kz,lzr) < zxmin .and. &
+ an(ix,jy,kz,lnr) > cxmin ) THEN
+ q = an(ix,jy,kz,lr)
+ nrx = an(ix,jy,kz,lnr)
+ an(ix,jy,kz,lzr) = 36.*g1r*dn(ix,kz)**2*q**2/(pi**2*xdnr**2*nrx) ! *dninv
+ 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
@@ -4660,6 +5446,15 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, &
ENDIF
ENDIF
+ IF ( lzh > 1 ) THEN ! set reflectivity moment
+ IF ( an(ix,jy,kz,lh) > qxmin_init(lh) .and. an(ix,jy,kz,lzh) < zxmin .and. &
+ an(ix,jy,kz,lnh) > cxmin ) THEN
+ q = an(ix,jy,kz,lh)
+ nrx = an(ix,jy,kz,lnh)
+ an(ix,jy,kz,lzh) = 36.*g1h*dn(ix,kz)**2*q**2/(pi**2*xdnh**2*nrx) ! *dninv
+ ENDIF
+ ENDIF
+
! hail
IF ( lnhl > 1 .and. lhl > 1 ) THEN
@@ -4680,7 +5475,6 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, &
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
@@ -4689,6 +5483,15 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, &
ENDIF
ENDIF
+
+ IF ( lzhl > 1 ) THEN ! set reflectivity moment
+ IF ( an(ix,jy,kz,lhl) > qxmin_init(lhl) .and. an(ix,jy,kz,lzhl) < zxmin .and. &
+ an(ix,jy,kz,lnhl) > cxmin ) THEN
+ q = an(ix,jy,kz,lhl)
+ nrx = an(ix,jy,kz,lnhl)
+ an(ix,jy,kz,lzhl) = 36.*g1hl*dn(ix,kz)**2*q**2/(pi**2*xdnhl**2*nrx) ! *dninv
+ ENDIF
+ ENDIF
! ENDIF
@@ -4859,6 +5662,9 @@ subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn)
anold(ix,jy,kz,lnr) = anold(ix,jy,kz,lnr) + an(ix,jy,kz,lr)/xmass
ENDIF
+ IF ( lzr > 1 ) THEN ! set reflectivity moment
+ an(ix,jy,kz,lzr) = 36.*g1r*dn(ix,kz)**2*q**2/(pi**2*xdnr**2*nrx) ! *dninv
+ ENDIF
ENDIF
ENDIF
@@ -4909,6 +5715,9 @@ subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn)
!
! an(ix,jy,kz,lnh) = nrx ! *dninv ! convert to number mixing ratio
!
+! IF ( lzh > 1 ) THEN ! set reflectivity moment
+! an(ix,jy,kz,lzh) = 36.*g1h*dn(ix,kz)**2*q**2/(pi**2*xdnh**2*nrx) ! *dninv
+! ENDIF
! ENDIF
! ENDIF
!
@@ -4932,6 +5741,9 @@ subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn)
!
! an(ix,jy,kz,lnhl) = nrx ! *dninv ! convert to number mixing ratio
!
+! IF ( lzhl > 1 ) THEN ! set reflectivity moment
+! an(ix,jy,kz,lzhl) = 36.*g1hl*dn(ix,kz)**2*q**2/(pi**2*xdnhl**2*nrx) ! *dninv
+! ENDIF
! ENDIF
! ENDIF
@@ -4950,7 +5762,7 @@ END subroutine calcnfromcuten
SUBROUTINE calc_eff_radius &
& (nx,ny,nz,na,jyslab &
& ,nor,norz &
- & ,t1,t2,t3,t4 &
+ & ,t1,t2,t3,t4,t5,t6, f_t5,f_t6 &
& ,qcw,qci,qsw,qrw &
& ,ccw,cci,csw,crw &
& ,an,dn )
@@ -4972,6 +5784,9 @@ SUBROUTINE calc_eff_radius &
real,optional :: t2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
real,optional :: t3(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
real,optional :: t4(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
+ real,optional :: t5(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
+ real,optional :: t6(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
+ logical, optional :: f_t5, f_t6 ! flags to fill t5/t6 for graupel/hail
real, optional :: 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)
@@ -6490,6 +7305,9 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
ELSEIF ( icdxhl .eq. 6 ) THEN ! Milbrandt and Morrison (2013)
aax = axx(mgs,lhl)
bbx = bxx(mgs,lhl)
+ ELSEIF ( icdxhl <= 0 ) THEN !
+ aax = ax(lhl)
+ bbx = bx(lhl)
ENDIF
ENDIF ! }
@@ -6798,7 +7616,11 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, &
real vtmax
real xvbarmax
-
+
+ real, parameter :: c1r=19.0, c2r=0.6, c3r=1.8, c4r=17.0 ! rain
+ real, parameter :: c1h=5.5, c2h=0.7, c3h=4.5, c4h=8.5 ! Graupel
+ real, parameter :: c1hl=3.7, c2hl=0.3, c3hl=9.0, c4hl=6.5, c5hl=1.0, c6hl=6.5 ! Hail
+
integer l1, l2
double precision :: dpt1, dpt2
@@ -7074,68 +7896,549 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, &
ELSEIF ( imurain == 3 ) THEN
alpha(:,lr) = xnu(lr)
ENDIF
-
-
-
+ IF ( ipconc == 5 .and. imydiagalpha > 0 ) THEN
+ DO mgs = 1,ngscnt
+ IF ( qx(mgs,lr) .gt. qxmin(lr) .and. cx(mgs,lr) > cxmin ) THEN
+ xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) !
+ xdia(mgs,lr,3) = (xv(mgs,lr)*6.0*cwc1)**(1./3.)
+ alpha(mgs,lr) = Min(alphamax, c1r*tanh(c2r*(xdia(mgs,lr,3)*1000. - c3r)) + c4r)
+ ENDIF
+ IF ( qx(mgs,lh) .gt. qxmin(lh) .and. cx(mgs,lh) > cxmin ) THEN
+ xv(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) !
+ xdia(mgs,lh,3) = (xv(mgs,lh)*6.*piinv)**(1./3.) ! mwfac*xdia(mgs,lh,1) ! (xv(mgs,lh)*cwc0*6.0)**(1./3.)
+ alpha(mgs,lh) = Min(alphamax, c1h*tanh(c2h*(xdia(mgs,lh,3)*1000. - c3h)) + c4h)
+ ENDIF
+! alpha(:,lr) = 0. ! 10.
+! alpha(:,lh) = 0. ! 10.
+ IF ( lhl > 0 ) THEN
+ IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. cx(mgs,lhl) > cxmin ) THEN
+ xv(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*cx(mgs,lhl)) !
+ xdia(mgs,lhl,3) = (xv(mgs,lhl)*6.*piinv)**(1./3.)
+ IF ( xdia(mgs,lhl,3) < 0.008 ) THEN
+ alpha(mgs,lhl) = Min(alphamax, c1hl*tanh(c2hl*(xdia(mgs,lhl,3)*1000. - c3hl)) + c4hl)
+ ELSE
+ alpha(mgs,lhl) = Min(alphamax, c5hl*xdia(mgs,lhl,3)*1000. + c6hl)
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDIF
!
-! Set density
-!
- if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: call setvtz'
+! Set 6th moments
!
+ IF ( ipconc .ge. 6 .or. lzr > 1) THEN
- 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)
+ zx(:,:) = 0.0
+
+! DO il = lr,lhab
+ DO il = l1,l2
+
+ IF ( lz(il) .ge. 1 ) THEN
+
+ DO mgs = 1,ngscnt
+ zx(mgs,il) = Max(an(igs(mgs),jy,kgs(mgs),lz(il)), 0.0)
+ ENDDO
+
+
+ ENDIF
+
+ ENDDO
+
+ ENDIF
+
-!
-! put fall speeds into the x-z arrays
-!
- DO il = l1,l2
- do mgs = 1,ngscnt
- vtmax = 150.0
+! Find shape parameter rain
-
- 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) )
+
+ IF ( lz(lr) > 1 .and. (ildo == 0 .or. ildo == lr ) .and. imurain == 3 ) THEN ! { RAIN SHAPE PARAM
+ il = lr
+ DO mgs = 1,ngscnt
+
+ IF ( iresetmoments == 1 .or. iresetmoments == il ) THEN
+! IF ( .false. .and. zx(mgs,lr) <= zxmin ) THEN
+ IF ( zx(mgs,lr) <= zxmin ) THEN
+ qx(mgs,lr) = 0.0
+ cx(mgs,lr) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),lr)
+ an(igs(mgs),jgs,kgs(mgs),lr) = qx(mgs,lr)
+ an(igs(mgs),jgs,kgs(mgs),ln(lr)) = cx(mgs,lr)
+! ELSEIF ( zx(mgs,lr) <= 0.0 .and. cx(mgs,lr) > 0.0 .and. qx(mgs,il) .gt. qxmin(il)) THEN
+! write(91,*) 'ZF: overdepletion of Zr: z,c,q = ',zx(mgs,il),cx(mgs,il),qx(mgs,il)
+ ELSEIF ( cx(mgs,lr) <= cxmin ) THEN
+ zx(mgs,lr) = 0.0
+ qx(mgs,lr) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),lr)
+ an(igs(mgs),jgs,kgs(mgs),lr) = qx(mgs,lr)
+ an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr)
+ ENDIF
+ ENDIF
+
- ENDIF
+
+ IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN
-
- 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
+ xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr)))
+ IF ( xv(mgs,lr) .gt. xvmx(lr) ) THEN
+! tmp = cx(mgs,lr)
+! xv(mgs,lr) = xvmx(lr)
+! cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmx(lr)*xdn(mgs,lr))
+! an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+! IF ( tmp < cx(mgs,il) ) THEN ! breakup
+! g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+!! zx(mgs,lr) = zx(mgs,lr) + g1*(rho0(mgs)/(1000.))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) )
+!! an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr)
+! ENDIF
+ 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))
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ ENDIF
+ IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN
+! have mass and reflectivity but no concentration, so set concentration, using default alpha
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ z = zx(mgs,il)
+ qr = qx(mgs,il)
+
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*1000.*1000)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > cxmin ) THEN
+! have mass and concentration but no reflectivity, so set reflectivity, using default alpha
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+
+! xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(1000.*Max(1.0e-9,cx(mgs,lr)))
+! vr = xv(mgs,lr)
+
+! z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2)
+! zx(mgs,il) = z
+! an(igs(mgs),jy,kgs(mgs),lz(il)) = z
+
+ zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(xdn(mgs,lr)**2*chw)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN
+! How did this happen?
+ ! set values according to dBZ of -10, or Z = 0.1
+! write(91,*) 'alpha = ',alpha(mgs,il)
+ IF ( qx(mgs,il) < 1.e-8 ) THEN
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ ELSE
+! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2
+ zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ z = zx(mgs,il)
+ qr = qx(mgs,il)
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*1000.*1000)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ ENDIF
+ ENDIF
+
+ IF ( zx(mgs,lr) > 0.0 ) THEN
+ xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(1000.*Max(1.0e-9,cx(mgs,lr)))
+ vr = xv(mgs,lr)
+! z = 36.*(alpha(kz)+2.0)*a(ix,jy,kz,lnr)*vr**2/((alpha(kz)+1.0)*pi**2)
+ qr = qx(mgs,lr)
+ nrx = cx(mgs,lr)
+ z = zx(mgs,lr)
+
+! xv = (db(1,kz)*a(1,1,kz,lr))**2/(a(1,1,kz,lnr))
+! rd = z*(pi/6.*1000.)**2/xv
+
+! determine shape parameter alpha by iteration
+ IF ( z .gt. 0.0 ) THEN
+! alpha(mgs,lr) = 3.
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
+ DO i = 1,20
+! IF ( 100.*Abs(alp - alpha(mgs,lr))/Abs(alpha(mgs,lr)) .lt. 1. ) EXIT
+ IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT
+ alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) )
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
+! write(0,*) 'i,alp = ',i,alp
+ alp = Max( rnumin, Min( rnumax, alp ) )
+ ENDDO
+! write(0,*) 'kz, alp, alpha(kz) = ',kz,alp,alpha(mgs,lr),qr*1000,z*1.e18,vr,nrx
+
+
+! check for artificial breakup (rain larger than allowed max size)
+ IF ( xv(mgs,il) .gt. xvmx(il) ) THEN
+ tmp = cx(mgs,il)
+ xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) )
+ xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+ cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
+ IF ( tmp < cx(mgs,il) ) THEN ! breakup
+
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) )
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ vr = xv(mgs,lr)
+ qr = qx(mgs,lr)
+ nrx = cx(mgs,lr)
+ z = zx(mgs,lr)
+
+
+! determine shape parameter alpha by iteration
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
+ DO i = 1,20
+ IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT
+ alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) )
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
+ alp = Max( rnumin, Min( rnumax, alp ) )
+ ENDDO
- 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
+
+ ENDIF
+ ENDIF
-! xvt(kgs(mgs),igs(mgs),2,il) = xvt(kgs(mgs),igs(mgs),1,il)
+!
+! Check whether the shape parameter is at or less than the minimum, and if it is, reset the
+! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N)
+!
+! IF ( alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax ) THEN
+ IF ( .true. .and. (alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax) ) THEN
+
+ IF ( rescale_high_alpha .and. alp >= rnumax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(1./(xdn(mgs,il)))**2
+ an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il)
+
+ ELSEIF ( rescale_low_alphar .and. alp <= rnumin ) THEN
+
+ z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2)
+ zx(mgs,il) = z
+ an(igs(mgs),jy,kgs(mgs),lz(il)) = z
+
+ ENDIF
+ ENDIF
+
+ ENDIF
+ ENDIF
+
+ ELSE
+
+ zx(mgs,lr) = 0.0
+ cx(mgs,lr) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),ln(lr)) = cx(mgs,lr)
+ an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr)
+
+ ENDIF
+
+ ENDDO
+ ENDIF ! }
+
+
+ IF ( ipconc .ge. 6 ) THEN
+
+! Find shape parameters for graupel,hail
+
+ DO il = lr,lhab
+
+ IF ( lz(il) .gt. 1 .and. (ildo == 0 .or. ildo == il ) .and. ( .not. ( il == lr .and. imurain == 3 )) ) THEN
+
+ DO mgs = 1,ngscnt
+
+ IF ( iresetmoments == 1 .or. iresetmoments == il .or. iresetmoments == -1 ) THEN
+ IF ( zx(mgs,il) <= zxmin ) THEN ! .and. qx(mgs,il) > 0.05e-3 ) THEN
+ qx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ ELSEIF ( iresetmoments == -1 .and. qx(mgs,il) < qxmin(il) ) THEN
+ zx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ ELSEIF ( cx(mgs,il) <= cxmin .and. iresetmoments /= -1 ) THEN ! .and. qx(mgs,il) > 0.05e-3 ) THEN
+!! write(91,*) 'cx=0; qx,zx = ',1000.*qx(mgs,il),1.e18*zx(mgs,il)
+ zx(mgs,il) = 0.0
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+ ENDIF
+ ENDIF
+
+ IF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= cxmin ) THEN
+ zx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+ ENDIF
+
+ IF ( qx(mgs,il) .gt. qxmin(il) ) THEN
+
+ xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(1.0e-9,cx(mgs,il)))
+ xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+
+ IF ( xv(mgs,il) .lt. xvmn(il) ) THEN
+! tmp = cx(mgs,il)
+ xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) )
+ xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+ cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
+! IF ( tmp < cx(mgs,il) ) THEN ! breakup
+! g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+! & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2)
+! zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) )
+! an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+!
+! ENDIF
+ ENDIF
+
+ IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN
+! have mass and reflectivity but no concentration, so set concentration, using default alpha
+ g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+ z = zx(mgs,il)
+ qr = qx(mgs,il)
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(z*(pi*xdn(mgs,il))**2)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > cxmin ) THEN
+! have mass and concentration but no reflectivity, so set reflectivity, using default alpha
+ g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+! zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw
+ zx(mgs,il) = Min(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(chw*(pi*xdn(mgs,il))**2) )
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN
+! How did this happen?
+! write(91,*) 'ziegfall: something screwy with moments: il = ',il
+! write(91,*) 'q,n,z = ', 1.e3*qx(mgs,il),cx(mgs,il),zx(mgs,il)
+! write(91,*) 'alpha = ',alpha(mgs,il)
+
+ IF ( qx(mgs,il) < 1.e-8 ) THEN
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ ELSE
+! write(0,*) 'alpha = ',alpha(mgs,il)
+ ! set values according to dBZ of -10
+! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2
+ zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+ z = zx(mgs,il)
+ qr = qx(mgs,il)
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(z*(pi*xdn(mgs,il))**2)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ ENDIF
+ ENDIF
+ ENDIF
+
+ IF ( qx(mgs,il) .gt. qxmin(il) .and. cx(mgs,il) .gt. cxmin ) THEN
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+ z = zx(mgs,il)
+
+ IF ( zx(mgs,il) .gt. 0. ) THEN
+
+! rd = z*(pi/6.*1000.)**2*chw/(0.224*(dn(igs(mgs),jy,kgs(mgs))*qr)**2)
+ rd = z*(pi/6.*xdn(mgs,il))**2*chw/((dn(igs(mgs),jy,kgs(mgs))*qr)**2)
+
+ alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd) - 1.0
+ DO i = 1,10
+ IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT
+ alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) )
+ alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd) - 1.0
+! write(0,*) 'i,alp = ',i,alp
+ alp = Max( alphamin, Min( alphamax, alp ) )
+ ENDDO
+
+
+
+! check for artificial breakup (graupel/hail larger than allowed max size)
+
+ IF ( imaxdiaopt == 1 ) 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))))
+ ENDIF
+
+ IF ( xv(mgs,il) .gt. xvbarmax ) THEN
+ tmp = cx(mgs,il)
+ xv(mgs,il) = Min( xvbarmax, Max( xvmn(il),xv(mgs,il) ) )
+ xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+ cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
+ IF ( tmp < cx(mgs,il) ) THEN ! breakup
+ g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2)
+ zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) )
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+ z = zx(mgs,il)
+
+ rd = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2)
+ alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd) - 1.0
+ DO i = 1,10
+ IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT
+ alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) )
+ alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd) - 1.0
+ alp = Max( alphamin, Min( alphamax, alp ) )
+ ENDDO
+
+
+ ENDIF
+ ENDIF
+
+!
+! Check whether the shape parameter is at or less than the minimum, and if it is, reset the
+! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N)
+!
+ IF ( (rescale_low_alpha .or. rescale_high_alpha ) .and. &
+ & ( alpha(mgs,il) <= alphamin .or. alp == alphamin .or. alp == alphamax ) ) THEN
+
+ g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+
+ IF ( rescale_high_alpha .and. alp >= alphamax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2
+ an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il)
+
+ ELSEIF ( rescale_low_alpha .and. alp <= alphamin .and. .not. (il == lh .and. icvhl2h > 0 ) ) THEN
+
+!! z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*( 0.224*qr)*qr/chw
+ z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw
+ z = z1*(6./(pi*xdn(mgs,il)))**2
+ zx(mgs,il) = z
+ an(igs(mgs),jy,kgs(mgs),lz(il)) = z
+ ENDIF
+ ENDIF
+ ELSE
+ ENDIF
+ ENDIF
+ ENDDO ! mgs
+
+ ENDIF ! lz(il) .gt. 1
+
+ ENDDO ! il
+
+! CALL cld_cpu('Z-MOMENT-ZFAll')
+
+ ENDIF
+
+ IF ( lzhl > 1 ) THEN
+ IF ( lhl .gt. 1 ) THEN
+
+ ENDIF
+ 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
+
+
+! IF ( qx(mgs,il) > 1.e-4 .and. &
+! & .not. ( il == lr .and. 1.e3*xdia(mgs,il,3) > 5.0 ) ) THEN
+! write(0,*) 'infdo,mgs = ',infdo,lzr,mgs
+! write(0,*) 'Moment problem with vtxbar for il at i,j,k = ',il,igs(mgs),jy,kgs(mgs)
+! write(0,*) 'nx,ny,nz,ng = ',nx,ny,nz,nor
+! write(0,*) 'cwmasn,cwmasx = ',cwmasn,cwmasx
+! write(0,*) 'vt1,2,3 = ',vtxbar(mgs,il,1),vtxbar(mgs,il,2),vtxbar(mgs,il,3)
+! write(0,*) 'q,n,d = ', 1.e3*qx(mgs,il),cx(mgs,il),1.e3*xdia(mgs,il,3)
+! IF ( il .ge. lr .and. lz(il) > 1 ) write(0,*) 'z = ', zx(mgs,il)
+! IF ( il .ge. lg .or. il == lr ) THEN
+! write(0,*) 'alpha = ',alpha(mgs,il)
+! ENDIF
+! ENDIF
+
+ 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
+
+! IF ( ndebugzf >= 0 .and. 1.e3*qx(mgs,il) > 0.1 ) THEN
+! write(0,*) 'infdo = ',infdo
+! write(0,*) 'Problem with vtxbar for il at i,j,k = ',il,igs(mgs),jy,kgs(mgs)
+! write(0,*) 'nx,ny,nz,ng = ',nx,ny,nz,nor
+! write(0,*) 'cwmasn,cwmasx = ',cwmasn,cwmasx
+! write(0,*) 'vt1,2,3 = ',vtxbar(mgs,il,1),vtxbar(mgs,il,2),vtxbar(mgs,il,3)
+! write(0,*) 'q,n,d = ', 1.e3*qx(mgs,il),cx(mgs,il),1.e3*xdia(mgs,il,3)
+! IF ( il .ge. lr .and. lz(il) > 1 ) write(0,*) 'z = ', zx(mgs,il)
+! IF ( il .ge. lg ) THEN
+! write(0,*) 'alpha = ',alpha(mgs,il)
+! ENDIF
+! ENDIF
+ 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
@@ -7630,6 +8933,8 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, &
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 ( lzr .gt. 1 ) THEN
+ dtmp(ix,kz) = 1e18*an(ix,jy,kz,lzr)
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))
@@ -7822,7 +9127,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, &
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)) )
+ dnsnow = 0.0346159*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/ &
@@ -7898,6 +9203,10 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, &
IF ( izieg .ge. 1 .and. ipconc .ge. 5 ) THEN
ltest = .false.
+ IF ( lzh > 1 ) THEN
+ IF ( an(ix,jy,kz,lzh) > 0.0 .and. an(ix,jy,kz,lh) > qhmin .and. &
+ an(ix,jy,kz,lnh) >= cxmin ) ltest = .true.
+ ENDIF
IF ( ltest .or. (an(ix,jy,kz,lh) .ge. qhmin .and. an(ix,jy,kz,lnh) .ge. cxmin )) THEN
@@ -7943,6 +9252,9 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, &
ENDIF
IF ( lzh .gt. 1 ) THEN
+ x = (0.224*qh + 0.776*qxw)/an(ix,jy,kz,lh) ! weighted average of dielectric const
+ dtmph = 1.e18*x*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2
+ dtmp(ix,kz) = dtmp(ix,kz) + dtmph
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
@@ -8015,6 +9327,10 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, &
IF ( ipconc .ge. 5 ) THEN
ltest = .false.
+ IF ( lzhl > 1 ) THEN
+ IF ( an(ix,jy,kz,lzhl) > 0.0 .and. an(ix,jy,kz,lhl) > qhlmin .and. &
+ an(ix,jy,kz,lnhl) > 0.0 ) ltest = .true.
+ ENDIF
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)
@@ -8038,6 +9354,9 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, &
ENDIF
IF ( lzhl .gt. 1 ) THEN !{
+ x = (0.224*an(ix,jy,kz,lhl) + 0.776*qxw)/an(ix,jy,kz,lhl) ! weighted average of dielectric const
+ dtmphl = 1.e18*x*an(ix,jy,kz,lzhl)*(hldn/rwdn)**2
+ dtmp(ix,kz) = dtmp(ix,kz) + dtmphl
ELSE !}
g1 = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl))
@@ -8118,8 +9437,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, &
! write(0,*) 'Hail,snow c: ',an(ix,jy,kz,lnh),an(ix,jy,kz,lns)
! write(0,*) 'dtmps,dtmph = ',dtmps,dtmph
! ENDIF
-
- IF ( ndebug>1 .and. .not. dtmp(ix,kz) .lt. 1.e30 .or. dbz(ix,jy,kz) > 190.0 ) THEN
+ 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
@@ -8190,6 +9508,8 @@ END subroutine radardd02
! #####################################################################
!
! Subroutine for explicit cloud condensation and droplet nucleation
+!
+! 11/30/2022: Fixed droplet evaporation heating term for CM1 eqtset=2 (was only doing eqtset=1)
!
SUBROUTINE NUCOND &
& (nx,ny,nz,na,jyslab &
@@ -8198,6 +9518,7 @@ SUBROUTINE NUCOND &
& ,t0,t9 &
& ,an,dn,p2 &
& ,pn,w &
+ & ,ngs &
& ,axtra,io_flag &
& ,ssfilt,t00,t77,flag_qndrop &
& )
@@ -8256,6 +9577,7 @@ SUBROUTINE NUCOND &
logical :: io_flag
real :: dv
+ real :: ccnefactwo, sstmp, cn1, cnuctmp
!
! declarations microphysics and for gather/scatter
@@ -8264,7 +9586,6 @@ SUBROUTINE NUCOND &
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
@@ -8283,6 +9604,7 @@ SUBROUTINE NUCOND &
real ccnc(ngs), ccna(ngs), cnuc(ngs), cwnccn(ngs)
+ real :: ccnc_nu(ngs), ccnc_ac(ngs), ccnc_co(ngs)
real ccncuf(ngs)
real sscb ! 'cloud base' SS threshold
parameter ( sscb = 2.0 )
@@ -8295,7 +9617,7 @@ SUBROUTINE NUCOND &
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 :: ssmax(ngs) ! maximum SS experienced by a parcel
real ssmx
real dnnet,dqnet
! real cnu,rnu,snu,cinu
@@ -8419,7 +9741,6 @@ SUBROUTINE NUCOND &
integer :: count
-
! -------------------------------------------------------------------------------
itile = nxi
jtile = ny
@@ -8433,6 +9754,7 @@ SUBROUTINE NUCOND &
kzbeg = 1
nzbeg = 1
+ IF ( ac_opt > 0 ) ccnefactwo = (1.63e-3/(cck * beta(3./2., cck/2.)))**(1.0/(cck + 2.0))
f5 = 237.3 * 17.27 * 2.5e6 / cp ! combined constants for rain condensation (Soong and Ogura 73)
jy = 1
@@ -8543,6 +9865,7 @@ SUBROUTINE NUCOND &
qx(:,:) = 0.0
cx(:,:) = 0.0
+ zx(:,:) = 0.0
xv(:,:) = 0.0
xmas(:,:) = 0.0
@@ -8602,6 +9925,7 @@ SUBROUTINE NUCOND &
ELSE ! equation set 2 in cm1
tmp = qx(mgs,li)+qx(mgs,ls)+qx(mgs,lh)
IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl)
+ IF ( lf > 1 ) tmp = tmp + qx(mgs,lf)
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)) &
@@ -8656,12 +9980,16 @@ SUBROUTINE NUCOND &
ELSE
ssmax(mgs) = 0.0
ENDIF
- IF ( lccn .gt. 1 ) THEN
- ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn)
+ IF ( lccn .gt. 1 .and. ac_opt == 0 ) THEN
+ IF ( lccnuf .gt. 1 .and. i_uf_or_ccn > 0 ) THEN
+ ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) + an(igs(mgs),jy,kgs(mgs),lccnuf)
+ ELSE
+ ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn)
+ ENDIF
ELSE
ccnc(mgs) = cwnccn(mgs)
ENDIF
- IF ( lccnuf .gt. 1 ) THEN
+ IF ( lccnuf .gt. 1 .and. i_uf_or_ccn == 0 ) THEN
ccncuf(mgs) = an(igs(mgs),jy,kgs(mgs),lccnuf)
ELSE
ccncuf(mgs) = 0.0
@@ -8716,6 +10044,237 @@ SUBROUTINE NUCOND &
ventrxn(:) = ventrn
+! Find shape parameter rain
+
+ IF ( lzr > 1 .and. rcond == 2 ) THEN ! { RAIN SHAPE PARAM
+ DO mgs = 1,ngscnt
+ zx(mgs,lr) = Max(an(igs(mgs),jy,kgs(mgs),lzr), 0.0)
+ ENDDO
+
+! CALL cld_cpu('Z-MOMENT-1r2')
+ il = lr
+ DO mgs = 1,ngscnt
+
+ IF ( zx(mgs,il) <= zxmin ) THEN
+ qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il)
+ qx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ ELSEIF ( cx(mgs,il) <= 0.0 ) THEN
+ qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il)
+ zx(mgs,il) = 0.0
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+ ENDIF
+
+ IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN
+
+ xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr)))
+ 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
+
+ IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN
+! have mass and reflectivity but no concentration, so set concentration, using default alpha
+ IF ( imurain == 3 ) THEN
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ z1 = zx(mgs,il)
+ qr = qx(mgs,il)
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z1*1000.*1000)
+ ELSE
+ g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2)
+ z1 = zx(mgs,il)
+ qr = qx(mgs,il)
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z1*1000.*1000)
+
+ ENDIF
+! an(igs(mgs),jgs,kgs(mgs),ln(il)) = zx(mgs,il)
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > 0.0 ) THEN
+! have mass and concentration but no reflectivity, so set reflectivity, using default alpha
+ IF ( imurain == 3 ) THEN
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+ zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(chw*1000.*1000)
+ ELSE
+ g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2)
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+ zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(chw*1000.*1000)
+
+ ENDIF
+
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN
+! How did this happen?
+ ! set values according to dBZ of -10, or Z = 0.1
+! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2
+ zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ IF ( imurain == 3 ) THEN
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ z1 = zx(mgs,il)
+ qr = qx(mgs,il)
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z1*1000.*1000)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ ELSEIF ( imurain == 1 ) THEN
+ g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+ z1 = zx(mgs,il)
+ qr = qx(mgs,il)
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(z1*(pi*xdn(mgs,il))**2)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+
+ ENDIF
+ ENDIF
+
+ IF ( zx(mgs,lr) > 0.0 ) THEN
+ vr = rho0(mgs)*qx(mgs,lr)/(1000.*cx(mgs,lr))
+! z1 = 36.*(alpha(kz)+2.0)*a(ix,jy,kz,lnr)*vr**2/((alpha(kz)+1.0)*pi**2)
+ qr = qx(mgs,lr)
+ nrx = cx(mgs,lr)
+ z1 = zx(mgs,lr)
+
+! xv = (db(1,kz)*a(1,1,kz,lr))**2/(a(1,1,kz,lnr))
+! rd = z1*(pi/6.*1000.)**2/xv
+
+
+! determine shape parameter alpha by iteration
+ IF ( z1 .gt. 0.0 ) THEN
+
+ IF ( imurain == 3 ) THEN
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z1*pi**2) - 1.
+! write(0,*) 'kz, alp, alpha(kz) = ',kz,alp,alpha(kz),rd,z1,xv
+ DO i = 1,20
+ IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT
+ alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) )
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z1*pi**2) - 1.
+! write(0,*) 'i,alp = ',i,alp
+ alp = Max( rnumin, Min( rnumax, alp ) )
+ ENDDO
+
+ ELSE ! imurain == 1
+ g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2)
+
+ rd1 = z1*(pi/6.*xdn(mgs,il))**2*nrx/(rho0(mgs)*qr)**2
+
+ alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd1) - 1.0
+
+ DO i = 1,10
+ IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT
+ alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) )
+
+ alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd1) - 1.0
+
+ alp = Max( alphamin, Min( alphamax, alp ) )
+ ENDDO
+
+
+ ENDIF
+! ENDIF
+
+!
+! Check whether the shape parameter is at or less than the minimum, and if it is, reset the
+! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N)
+!
+ IF ( imurain == 3 ) THEN
+ IF ( .true. .and. (alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax) ) THEN
+
+ IF ( rescale_high_alpha .and. alp >= rnumax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z1*(1./(xdn(mgs,il)))**2
+ an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il)
+
+ ELSEIF ( rescale_low_alphar .and. alp <= rnumin ) THEN
+
+ z1 = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2)
+ zx(mgs,il) = z1
+ ENDIF
+ ENDIF
+
+ ELSEIF ( imurain == 1 ) THEN
+
+ g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+
+ IF ( (rescale_low_alpha .or. rescale_high_alpha ) .and. &
+ & ( alpha(mgs,il) <= alphamin .or. alp == alphamin .or. alp == alphamax ) ) THEN
+
+
+
+ IF ( rescale_high_alpha .and. alp >= alphamax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z
+ cx(mgs,il) = g1*rho0(mgs)**2*(qr)*qr/zx(mgs,lr)*(6./(pi*xdn(mgs,il)))**2
+ an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il)
+
+ ELSEIF ( rescale_low_alpha .and. alp <= alphamin ) THEN ! alpha = alphamin, so reset Z to prevent growth in C
+ z1 = g1*rho0(mgs)**2*(qr)*qr/nrx
+ z2 = z1*(6./(pi*xdn(mgs,il)))**2
+ zx(mgs,il) = z2
+ an(igs(mgs),jy,kgs(mgs),lz(il)) = z2
+ ENDIF
+ ENDIF ! imurain
+
+ ENDIF ! z > 0
+
+ tmp = alpha(mgs,lr) + 4./3.
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+ tmp = alpha(mgs,lr) + 1.
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+! ventrx(mgs) = Gamma(alpha(mgs,lr) + 4./3.)/(alpha(mgs,lr) + 1.)**(1./3.)/Gamma(alpha(mgs,lr) + 1.)
+ ventrx(mgs) = x/(y*(alpha(mgs,lr) + 1.)**(1./3.))
+
+ IF ( imurain == 3 .and. izwisventr == 2 ) THEN
+
+ tmp = alpha(mgs,lr) + 1.5 + br/6.
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+! ventrx(mgs) = Gamma(alpha(mgs,lr) + 1.5 + br/6.)/Gamma(alpha(mgs,lr) + 1.)
+ ventrxn(mgs) = x/(y*(alpha(mgs,lr) + 1.)**((1.+br)/6. + 1./3.))
+
+ ELSEIF ( imurain == 1 .and. iferwisventr == 2 ) THEN
+
+ tmp = alpha(mgs,lr) + 2.5 + br/2.
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+! ventrx(mgs) = Gamma(alpha(mgs,lr) + 1.5 + br/6.)/Gamma(alpha(mgs,lr) + 1.)
+ ventrxn(mgs) = x/y
+
+
+ ENDIF
+
+
+ ENDIF
+ ENDIF
+
+ ENDIF
+
+ ENDDO
+! CALL cld_cpu('Z-MOMENT-1r2')
+ ENDIF ! }
+
! write(0,*) 'NUCOND: Set ssf variables, ssmxinit =',ssmxinit
ssmx = 0.0
@@ -8735,6 +10294,8 @@ SUBROUTINE NUCOND &
ssfkp1(mgs) = ssfilt(igs(mgs),jgs,Min(nz-1,kgs(mgs)+1))
ssfkm1(mgs) = ssfilt(igs(mgs),jgs,Max(1,kgs(mgs)-1))
+! IF ( wvel(mgs) /= 0.0 ) write(0,*) 'mgs,wvel1,ssf = ',mgs,wvel(mgs),ssf(mgs)
+
ENDDO
@@ -8744,7 +10305,7 @@ SUBROUTINE NUCOND &
! cloud water variables
!
- if ( ndebug .gt. 0 )write(0,*) 'ICEZVD_DR: Set cloud water variables'
+ if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: Set cloud water variables'
do mgs = 1,ngscnt
xv(mgs,lc) = 0.0
@@ -8868,23 +10429,22 @@ SUBROUTINE NUCOND &
QEVAP= Min( qx(mgs,lc), R1*(qss(mgs)-qvap(mgs)) )
- IF ( qx(mgs,lc) .LT. QEVAP ) THEN ! GO TO 63
+ IF ( qx(mgs,lc) <= QEVAP ) THEN ! GO TO 63
qwvp(mgs) = qwvp(mgs) + qx(mgs,lc)
- thetap(mgs) = thetap(mgs) - felv(mgs)*qx(mgs,lc)/(cp*pi0(mgs))
+ thetap(mgs) = thetap(mgs) - felvcp(mgs)*qx(mgs,lc)/(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)
+ IF ( lccna > 1 ) THEN
+ ccna(mgs) = ccna(mgs) - restoreccnfrac*cx(mgs,lc)
+ ELSEIF ( irenuc <= 2 ) THEN
+ IF ( .not. invertccn ) THEN
+ ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + restoreccnfrac*cx(mgs,lc) ) )
+ ELSE
+ ccnc(mgs) = ccnc(mgs) + restoreccnfrac*cx(mgs,lc)
+ ENDIF
ENDIF
ENDIF
cx(mgs,lc) = 0.
@@ -8894,39 +10454,37 @@ SUBROUTINE NUCOND &
qx(mgs,lc) = qx(mgs,lc) - QEVAP
IF ( qx(mgs,lc) .le. 0. ) THEN
IF ( restoreccn ) THEN
- IF ( irenuc <= 2 ) THEN
+ IF ( lccna > 1 ) THEN
+ ccna(mgs) = ccna(mgs) - restoreccnfrac*cx(mgs,lc)
+ ELSEIF ( 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) ) )
+ ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + restoreccnfrac*cx(mgs,lc) ) )
ELSE
- ccnc(mgs) = ccnc(mgs) + cx(mgs,lc)
+ ccnc(mgs) = ccnc(mgs) + restoreccnfrac*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
+ IF ( lccna > 1 ) THEN
+ ccna(mgs) = ccna(mgs) - restoreccnfrac*tmp
+ ELSEIF ( 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 ) )
+ ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + restoreccnfrac*tmp ) )
ELSE
- ccnc(mgs) = ccnc(mgs) + tmp
+ ccnc(mgs) = ccnc(mgs) + restoreccnfrac*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))
+ thetap(mgs) = thetap(mgs) - felvcp(mgs)*QEVAP/(pi0(mgs))
IF ( io_flag .and. nxtra > 1 ) THEN
axtra(igs(mgs),jy,kgs(mgs),1) = -QEVAP/dtp
ENDIF
@@ -9208,11 +10766,24 @@ SUBROUTINE NUCOND &
!! & 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)
+ IF ( lzr > 1 .and. rcond == 2 .and. qx(mgs,lr) .gt. qxmin(lr) &
+ & .and. cx(mgs,lr) .gt. 1.e-9 ) THEN
+ tmp = qx(mgs,lr)/cx(mgs,lr)
+ IF ( imurain == 3 ) THEN
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ ELSE
+ g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2)
+
+ ENDIF
+ zx(mgs,lr) = zx(mgs,lr) + g1*(rho0(mgs)/(xdn(mgs,lr)))**2*( 2.*( tmp ) * dqr )
+ ENDIF
+
+ 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)
!
@@ -9249,7 +10820,8 @@ SUBROUTINE NUCOND &
! 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 .and. ssf(mgs) < 20.0 .and. &
+ ( ccnc(mgs) > 0.05*cwnccn(mgs) .or. ( ac_opt > 0 .and. ccnc_ac(mgs) - cx(mgs,lc) > 0.0 ) ) ) 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)
@@ -9260,7 +10832,7 @@ SUBROUTINE NUCOND &
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
@@ -9285,11 +10857,16 @@ SUBROUTINE NUCOND &
IF ( .not. flag_qndrop ) THEN ! { do not calculate number of droplets if using wrf-chem
+ IF ( ac_opt == 0 ) THEN
+ cnuctmp = cnuc(mgs)
+ ELSE
+ cnuctmp = ccnc_ac(mgs)
+ ENDIF
! 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
+ CN(mgs) = CCNE0*cnuctmp**(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, &
@@ -9311,12 +10888,16 @@ SUBROUTINE NUCOND &
ENDIF
IF ( cn(mgs) .gt. 0.0 ) THEN
- IF ( cn(mgs) .gt. ccnc(mgs) ) THEN
- cn(mgs) = ccnc(mgs)
-! ccnc(mgs) = 0.0
+ IF ( ac_opt == 0 ) THEN
+ IF ( cn(mgs) .gt. ccnc(mgs) ) THEN
+ cn(mgs) = ccnc(mgs)
+! ccnc(mgs) = 0.0
+ ENDIF
+ ELSE
+ cn(mgs) = Min( cn(mgs), ccnc_ac(mgs) )
ENDIF
! cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
- IF ( irenuc <= 2 ) ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
+ IF ( irenuc <= 2 .and. lccna < 1 ) ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
ccna(mgs) = ccna(mgs) + cn(mgs)
ENDIF
@@ -9362,7 +10943,8 @@ SUBROUTINE NUCOND &
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 >= 0 .and. ac_opt == 0 .and. .not. flag_qndrop ) THEN ! turn off nucleation when flag_qndrop (using WRF-CHEM for activation)
IF ( irenuc < 2 ) THEN !{
@@ -9439,6 +11021,7 @@ SUBROUTINE NUCOND &
! 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
+ CN(mgs) = Min( CN(mgs), Max(0.0, (cnuc(mgs) - ccna(mgs) )) )
IF ( .false. .and. ny <= 2 ) THEN
write(0,*) 'i,k, cwmasn = ',igs(mgs),kgs(mgs),cwmasn
@@ -9466,8 +11049,136 @@ SUBROUTINE NUCOND &
cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
- ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
+ IF ( lccna < 1 ) ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
+
+ ELSEIF ( irenuc == 3 ) THEN !} {
+ ! Phillips Donner Garner 2007
+! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs)
+! CN(mgs) = cwccn*Min(ssf(mgs),ssfcut)**cck
+
+! Need to calculate new ssf since condensation has happened:
+ 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)
+
+ ssf(mgs) = 0.0
+ IF ( c1 > 0. ) THEN
+ ssf(mgs) = 100.*(qx(mgs,lv)/c1 - 1.0) ! from "new" values
+ ENDIF
+ CN(mgs) = cnuc(mgs)*Min(1.0, (ssf(mgs))**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
+
+ cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
+
+ ! 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 == 4 ) THEN !} {
+ ! modification of Phillips Donner Garner 2007
+! 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
+! cn(mgs) = Min( cn(mgs), cnuc(mgs) )
+! Need to calculate new ssf since condensation has happened:
+ 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) = cnuc(mgs)*Min(ssf2kmax, ssf(mgs)**cck) ! this allows cn(mgs) > cnuc(mgs)
+
+ 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 ( cn(mgs) > 0.0 ) THEN
+ cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
+ ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
+
+ 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
+ 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 == 6 ) 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.7*cnuc(mgs) ) THEN ! here, assume we are near cloud base and use Twomey formulation
+ CN(mgs) = Min( 0.9*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.7*cnuc(mgs) - ccna(mgs) )) )
+! CN(mgs) = Min( CN(mgs), Max(0.0, 0.71*ccnc(mgs) - ccna(mgs) ) )
+
+ 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)
+ 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) = cnuc(mgs)*Min(0.99, Min(ssf(mgs),ssfcut)**cck ) !
+ CN(mgs) = cnuc(mgs)*Min(2.0, Max(0.0,ssf(mgs))**cck ) !
+! CN(mgs) = cnuc(mgs)*Min(ssf(mgs),ssfcut)**cck !
+
+
+ CN(mgs) = Min(0.01*cnuc(mgs), Max( 0.0, CN(mgs) - ccna(mgs) ) ) ! this was from
+! cn(mgs) = 0.0
+ 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 ( cn(mgs) > 0.0 ) THEN
+ cx(mgs,lc) = cx(mgs,lc) + 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
ELSEIF ( irenuc == 5 ) THEN !} {
! modification of Phillips Donner Garner 2007
@@ -9525,17 +11236,22 @@ SUBROUTINE NUCOND &
! 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 !} {
+ ELSEIF ( irenuc == 7 .or. irenuc == 17 ) 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 ( irenuc == 7 ) THEN
+ frac = 0.9
+ ELSE
+ frac = 0.98
+ ENDIF
! 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 ( ccna(mgs) < frac*cnuc(mgs) ) THEN ! { here, assume we are near cloud base and use Twomey formulation
+ CN(mgs) = Min( (frac+0.01)*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, (frac*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
@@ -9573,7 +11289,7 @@ SUBROUTINE NUCOND &
! 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
+ IF ( ccncuf(mgs) > 0.0 .and. ssf(mgs) > ssmxuf .and. ( ssmax(mgs) > ssmxuf .or. lss < 1 ) ) 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
@@ -9675,7 +11391,7 @@ SUBROUTINE NUCOND &
IF ( cn(mgs) > 0.0 ) THEN
cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
- ccnc(mgs) = Max(0.0, ccnc(mgs) - 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
@@ -9694,8 +11410,6 @@ SUBROUTINE NUCOND &
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.
@@ -9748,7 +11462,11 @@ SUBROUTINE NUCOND &
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) )
+ IF ( lccna > 1 ) THEN
+ ccna(mgs) = ccna(mgs) + cn(mgs)
+ ELSE
+ ccnc(mgs) = Max( 0.0, ccnc(mgs) - cn(mgs) )
+ ENDIF
cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
ENDIF
@@ -9853,15 +11571,21 @@ SUBROUTINE NUCOND &
! qx(mgs,lr) = an(igs(mgs),jy,kgs(mgs),lr)
end if
+ IF ( lzr > 1 .and. rcond == 2 ) THEN
+ an(igs(mgs),jy,kgs(mgs),lzr) = zx(mgs,lr) + &
+ & min( an(igs(mgs),jy,kgs(mgs),lzr), 0.0 )
+ ENDIF
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) )
+ IF ( ac_opt == 0 ) THEN
+ IF ( lccn .gt. 1 .and. lccna .lt. 1 ) THEN
+ an(igs(mgs),jy,kgs(mgs),lccn) = Max(0.0, ccnc(mgs) )
+ ENDIF
ENDIF
- IF ( lccnuf .gt. 1 ) THEN
+ IF ( lccnuf .gt. 1 .and. .not. ( lccna .gt. 1 .and. i_uf_or_ccn > 0 ) ) THEN
an(igs(mgs),jy,kgs(mgs),lccnuf) = Max(0.0, ccncuf(mgs) )
ENDIF
IF ( lccna .gt. 1 ) THEN
@@ -9938,6 +11662,42 @@ SUBROUTINE NUCOND &
IF ( lhl .gt. 1 ) THEN
+ IF ( lzhl .gt. 1 ) THEN
+
+ an(ix,jy,kz,lzhl) = Max(0.0, an(ix,jy,kz,lzhl) )
+
+ IF ( an(ix,jy,kz,lhl) .ge. frac*qxmin(lhl) .and. rescale_low_alpha ) THEN ! check 6th moment
+
+ IF ( an(ix,jy,kz,lnhl) .gt. 0.0 ) THEN
+
+ IF ( lvhl .gt. 1 ) THEN
+ IF ( an(ix,jy,kz,lvhl) .gt. 0.0 ) THEN
+ hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl)
+ ELSE
+ hwdn = xdn0(lhl)
+ ENDIF
+ hwdn = Max( xdnmn(lhl), hwdn )
+ ELSE
+ hwdn = xdn0(lhl)
+ ENDIF
+
+ chw = an(ix,jy,kz,lnhl)
+ g1 = (6.0+alphamin)*(5.0+alphamin)*(4.0+alphamin)/ &
+ & ((3.0+alphamin)*(2.0+alphamin)*(1.0+alphamin))
+ z1 = g1*dn(ix,jy,kz)**2*( an(ix,jy,kz,lhl) )*an(ix,jy,kz,lhl)/chw
+ z1 = z1*(6./(pi*hwdn))**2
+ ELSE
+ z1 = 0.0
+ ENDIF
+
+ an(ix,jy,kz,lzhl) = Min( z1, an(ix,jy,kz,lzhl) )
+
+ IF ( an(ix,jy,kz,lnhl) .lt. 1.e-5 ) THEN
+! an(ix,jy,kz,lzhl) = 0.9*an(ix,jy,kz,lzhl)
+ ENDIF
+ ENDIF
+
+ ENDIF !lzhl
if ( an(ix,jy,kz,lhl) .lt. frac*qxmin(lhl) .or. zerocx(lhl) ) then
@@ -10038,6 +11798,42 @@ SUBROUTINE NUCOND &
+ IF ( lzh .gt. 1 ) THEN
+
+ an(ix,jy,kz,lzh) = Max(0.0, an(ix,jy,kz,lzh) )
+
+ IF ( .false. .and. an(ix,jy,kz,lh) .ge. frac*qxmin(lh) .and. rescale_low_alpha ) THEN
+
+ IF ( an(ix,jy,kz,lnh) .gt. 0.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
+
+ chw = an(ix,jy,kz,lnh)
+ g1 = (6.0+alphamin)*(5.0+alphamin)*(4.0+alphamin)/ &
+ & ((3.0+alphamin)*(2.0+alphamin)*(1.0+alphamin))
+ z1 = g1*dn(ix,jy,kz)**2*( an(ix,jy,kz,lh) )*an(ix,jy,kz,lh)/chw
+ z1 = z1*(6./(pi*hwdn))**2
+ ELSE
+ z1 = 0.0
+ ENDIF
+
+ an(ix,jy,kz,lzh) = Min( z1, an(ix,jy,kz,lzh) )
+
+ IF ( an(ix,jy,kz,lnh) .lt. 1.e-5 ) THEN
+! an(ix,jy,kz,lzh) = 0.9*an(ix,jy,kz,lzh)
+ ENDIF
+ ENDIF
+
+ ENDIF
if ( an(ix,jy,kz,lh) .lt. frac*qxmin(lh) .or. zerocx(lh) ) then
@@ -10198,6 +11994,9 @@ SUBROUTINE NUCOND &
end if
+ IF ( lzr > 1 ) THEN
+ an(ix,jy,kz,lzr) = Max(0.0, an(ix,jy,kz,lzr) )
+ ENDIF
if ( an(ix,jy,kz,lr) .lt. frac*qxmin(lr) .or. zerocx(lr) &
& ) then
@@ -10208,6 +12007,10 @@ SUBROUTINE NUCOND &
an(ix,jy,kz,lnr) = 0.0
ENDIF
+ IF ( lzr > 1 ) THEN
+ an(ix,jy,kz,lzr) = 0.0
+ ENDIF
+
end if
!
@@ -10260,18 +12063,25 @@ SUBROUTINE NUCOND &
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))
+ IF ( lccn .gt. 1 .or. ac_opt == 1 ) THEN
+ IF ( irenuc < 5 .and. lccna <= 1 ) THEN
+ IF ( ac_opt == 0 ) THEN
+ an(ix,jy,kz,lccn) = an(ix,jy,kz,lccn) + Max(0.0,an(ix,jy,kz,lnc))
+ ENDIF
+ ELSEIF ( lccna > 1 ) THEN
+ an(ix,jy,kz,lccna) = Max( 0.0, an(ix,jy,kz,lccna) - Max(0.0,an(ix,jy,kz,lnc)) )
+ ENDIF
ENDIF
an(ix,jy,kz,lnc) = 0.0
+ IF ( lccn > 1 ) an(ix,jy,kz,lccn) = Max( 0.0, an(ix,jy,kz,lccn) )
- IF ( lccna > 0 ) THEN ! apply exponential decay to activated CCN to restore to environmental value
+ IF ( lccna > 0 .and. ac_opt == 0 ) THEN ! apply exponential decay to activated CCN to restore to environmental value
+ IF ( restoreccn ) THEN
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
+ ENDIF
+ ELSEIF ( lccn > 1 .and. restoreccn .and. ac_opt == 0 ) 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
@@ -10335,9 +12145,9 @@ subroutine nssl_2mom_gs &
! & ln,ipc,lvol,lz,lliq, &
& cdx, &
& xdn0,tmp3d,tkediss &
- & ,thproc,numproc,dx1,dy1 &
+ & ,thproc,numproc,dx1,dy1,ngs &
& ,timevtcalc,axtra,io_flag &
- & , has_wetscav,rainprod2d, evapprod2d &
+ & , has_wetscav,rainprod2d, evapprod2d, alpha2d &
& ,errmsg,errflg &
& ,elec,its,ids,ide,jds,jde &
& )
@@ -10425,6 +12235,12 @@ subroutine nssl_2mom_gs &
real rainprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz)
real evapprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz)
+
+ real :: alpha2d(-nor+1:nx+nor,-norz+ng1:nz+norz,3)
+
+ real, parameter :: tfrdry = 243.15
+
+ logical lrescalelow(lc:lhab)
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)
@@ -10570,7 +12386,6 @@ subroutine nssl_2mom_gs &
!
integer nxmpb,nzmpb,nxz
integer jgs,mgs,ngs,numgs
- parameter (ngs=500) !500)
integer, parameter :: ngsz = 500
integer ntt
parameter (ntt=300)
@@ -10633,7 +12448,8 @@ subroutine nssl_2mom_gs &
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 ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp1,tmp2,tmp3,tmp4,tmp5,tmp6,temp3 ! , sstdy, super
+ real :: flim
real dw,dwr
double precision :: tmpz, tmpzmlt
real ratio, delx, dely
@@ -10714,7 +12530,7 @@ subroutine nssl_2mom_gs &
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 tsqr(ngs),ssi(ngs),ssw(ngs),ssi0(ngs)
real qcwtmp(ngs),qtmp,qtot(ngs)
real qcond(ngs)
real ctmp, sctmp
@@ -10729,6 +12545,7 @@ subroutine nssl_2mom_gs &
parameter ( rwradmn = 50.e-6 )
real dh0
real dg0(ngs),df0(ngs)
+ real dhwet(ngs),dhlwet(ngs),dfwet(ngs)
real clionpmx,clionnmx
parameter (clionpmx=1.e9,clionnmx=1.e9) ! Takahashi 84
@@ -10736,7 +12553,7 @@ subroutine nssl_2mom_gs &
! other arrays
real fwet1(ngs),fwet2(ngs)
- real fmlt1(ngs),fmlt2(ngs)
+ real fmlt1(ngs),fmlt2(ngs),fmlt1e(ngs)
real fvds(ngs),fvce(ngs),fiinit(ngs)
real fvent(ngs),fraci(ngs),fracl(ngs)
!
@@ -10760,6 +12577,7 @@ subroutine nssl_2mom_gs &
!
real :: sfm1(ngs),sfm2(ngs)
real :: gfm1(ngs),gfm2(ngs)
+ real :: ffm1(ngs),ffm2(ngs)
real :: hfm1(ngs),hfm2(ngs)
logical :: wetsfc(ngs),wetsfchl(ngs),wetsfcf(ngs)
@@ -10800,6 +12618,10 @@ subroutine nssl_2mom_gs &
real :: alpha(ngs,lc:lhab)
real :: dab0lh(ngs,lc:lhab,lc:lhab)
real :: dab1lh(ngs,lc:lhab,lc:lhab)
+ real :: zx(ngs,lr:lhab)
+ real :: zxmxd(ngs,lr:lhab)
+ real :: g1x(ngs,lr:lhab)
+
real :: qsimxdep(ngs) ! max sublimation of qi+qs+qis
real :: qsimxsub(ngs) ! max depositionof qi+qs+qis
@@ -10815,6 +12637,7 @@ subroutine nssl_2mom_gs &
real ventrxn(ngs)
real g1shr, alphashr
real g1mlr, alphamlr
+ real g1smlr, alphasmlr
real massfacshr, massfacmlr
real :: qhgt8mm ! ice mass greater than 8mm
@@ -10827,6 +12650,8 @@ subroutine nssl_2mom_gs &
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)
+ real hxventtmp
+ real hlventinc(ngs),hwventinc(ngs)
integer, parameter :: ndiam = 10
integer :: numdiam
real hwvent0(ndiam+4),hlvent0 ! 0 to d1
@@ -10940,15 +12765,15 @@ subroutine nssl_2mom_gs &
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 :: qhlacw(ngs), qxacwtmp, qxacrtmp, qxacitmp, qxacstmp !
real vhacw(ngs), vsacw(ngs), vhlacw(ngs), vhlacr(ngs)
+ real qfcev(ngs)
real qfmul1(ngs),cfmul1(ngs)
!
real qsacws(ngs)
@@ -10957,7 +12782,7 @@ subroutine nssl_2mom_gs &
! arrays for x-ac-r and r-ac-x;
!
real qsacr(ngs),qracs(ngs)
- real qhacr(ngs),qhacrmlr(ngs) ! ,qrach(ngs)
+ real qhacr(ngs),qhacrmlr(ngs),qhacwmlr(ngs) ! ,qrach(ngs)
real vhacr(ngs), zhacr(ngs), zhacrf(ngs), zrach(ngs), zrachl(ngs)
real qiacr(ngs),qraci(ngs)
@@ -10965,7 +12790,7 @@ subroutine nssl_2mom_gs &
real qracif(ngs),qiacrf(ngs),qiacrs(ngs),ciacrs(ngs)
- real :: qhlacr(ngs),qhlacrmlr(ngs)
+ real :: qhlacr(ngs),qhlacrmlr(ngs), qhlacwmlr(ngs)
real qsacrs(ngs) !,qracss(ngs)
!
! ice - ice interactions
@@ -11011,7 +12836,8 @@ subroutine nssl_2mom_gs &
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 zsmlr(ngs)
+ real zsmlrr(ngs), zsshr(ngs), zsshrr(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
@@ -11052,9 +12878,10 @@ subroutine nssl_2mom_gs &
!
real :: qhldpv(ngs), qhlsbv(ngs) ! qhlcnv(ngs),qhlevv(ngs),
real :: qhlmlr(ngs), qhldsv(ngs), qhlmlrsave(ngs)
- real :: qhlwet(ngs), qhldry(ngs), qhlshr(ngs)
+ real :: qhlwet(ngs), qhldry(ngs), qhlshr(ngs), qxwettmp
!
real :: qrfz(ngs),qsfz(ngs),qhfz(ngs),qhlfz(ngs)
+ real :: qffz(ngs)
!
real qhdpv(ngs),qhsbv(ngs) ! qhcnv(ngs),qhevv(ngs),
real qhmlr(ngs),qhdsv(ngs),qhcev(ngs),qhcndv(ngs),qhevv(ngs)
@@ -11064,6 +12891,7 @@ subroutine nssl_2mom_gs &
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 qffzf(ngs) !water that freezes on mixed-phase FD
real qhlfzhl(ngs) !water that freezes on mixed-phase hail
real qhmlrlg(ngs),qhlmlrlg(ngs) ! melting from the larger diameters
@@ -11115,6 +12943,7 @@ subroutine nssl_2mom_gs &
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 ffwmax(ngs)
real qhcnf(ngs)
real :: qhlcnh(ngs)
real qhcngh(ngs),qhcngm(ngs),qhcngl(ngs)
@@ -11128,7 +12957,7 @@ subroutine nssl_2mom_gs &
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 ers(ngs),ess(ngs),egls(ngs),eghs(ngs),efs(ngs),ehs(ngs),ehsfac(ngs)
real ehscnv(ngs)
real ehxs(ngs),ehls(ngs),egms(ngs),egmip(ngs)
@@ -11187,12 +13016,13 @@ subroutine nssl_2mom_gs &
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 pqlwsi(ngs),pqlwhi(ngs),pqlwhli(ngs),pqlwfi(ngs)
real pqlwlghi(ngs),pqlwlghli(ngs)
real pqlwlghd(ngs),pqlwlghld(ngs)
+
real pvhwi(ngs), pvhwd(ngs)
real pvfwi(ngs), pvfwd(ngs)
@@ -11204,7 +13034,7 @@ subroutine nssl_2mom_gs &
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 pqlwsd(ngs),pqlwhd(ngs),pqlwhld(ngs),pqlwfd(ngs)
!
! real pqxii(ngs,nhab),pqxid(ngs,nhab)
!
@@ -11352,7 +13182,7 @@ subroutine nssl_2mom_gs &
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 total, 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
@@ -11384,9 +13214,22 @@ subroutine nssl_2mom_gs &
real :: term1,term2,term3,term4
real :: qaacw ! combined qsacw-qhacw for WSM6 variation
+ real :: cwchtmp
+
+ real, parameter :: c1r=19.0, c2r=0.6, c3r=1.8, c4r=17.0 ! rain
+ real, parameter :: c1h=5.5, c2h=0.7, c3h=4.5, c4h=8.5 ! Graupel
+ real, parameter :: c1hl=3.7, c2hl=0.3, c3hl=9.0, c4hl=6.5, c5hl=1.0, c6hl=6.5 ! Hail
+! inline functions for Newton method
+ real :: galpha, dgalpha
+ real :: a_in
+ logical, parameter :: newton = .false.
+
+ galpha(a_in) = ((4. + a_in)*(5. + a_in)*(6. + a_in))/((1. + a_in)*(2. + a_in)*(3. + a_in))
+ dgalpha(a_in) = (876. + 1260.*a_in + 621.*a_in**2 + 126.*a_in**3 + 9.*a_in**4)/ &
+ & (36. + 132.*a_in + 193.*a_in**2 + 144.*a_in**3 + 58.*a_in**4 + 12.*a_in**5 + a_in**6)
!
! ####################################################################
!
@@ -11416,6 +13259,11 @@ subroutine nssl_2mom_gs &
jstag = 0
kstag = 1
+ lrescalelow(:) = rescale_low_alpha
+ lrescalelow(lr) = rescale_low_alphar .and. rescale_low_alpha
+ lrescalelow(lh) = rescale_low_alphah .and. rescale_low_alpha
+ IF ( lf > 1 ) lrescalelow(lf) = rescale_low_alphah .and. rescale_low_alpha
+ IF ( lhl > 1 ) lrescalelow(lhl) = rescale_low_alphahl .and. rescale_low_alpha
!
@@ -11533,11 +13381,18 @@ subroutine nssl_2mom_gs &
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)
+ IF ( snowmeltdia > 0.0 ) THEN
+ snowmeltmass = pi/6.0 * 1000. * snowmeltdia**3 ! maximum rain particle mass from melting snow (if snowmeltdia > 0)
+ ENDIF
tdtol = 1.0e-05
tfrcbw = tfr - cbw
tfrcbi = tfr - cbi
+
+ IF ( mixedphase ) THEN
+ ibinhmlr = 0
+ ibinhlmlr = 0
+ ENDIF
!
!
! #ifdef COMMAS
@@ -11689,35 +13544,25 @@ subroutine nssl_2mom_gs &
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 = (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)
+ IF ( iqis0 == 1 .or. temg(1) <= tfr+0.5 ) THEN
+ qis(1) = pqs(1)*tabqis(ltemq)
+ ELSE
+ ltemq = (tfr - 163.15)/fqsat + 1.5
+ qis(1) = pqs(1)*tabqis(ltemq)
+ ENDIF
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
+ qss(1) = qis(1)
end if
!
ishail = .false.
@@ -11793,7 +13638,12 @@ subroutine nssl_2mom_gs &
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)
+ IF ( iqis0 == 1 .or. temg(mgs) <= tfr+0.5 ) THEN
+ qis(mgs) = pqs(mgs)*tabqis(ltemq)
+ ELSE
+ ltemq = (tfr - 163.15)/fqsat + 1.5
+ qis(mgs) = pqs(mgs)*tabqis(ltemq)
+ ENDIF
qss(mgs) = qvs(mgs)
! es(mgs) = 6.1078e2*tabqvs(ltemq)
! eis(mgs) = 6.1078e2*tabqis(ltemq)
@@ -11834,93 +13684,21 @@ subroutine nssl_2mom_gs &
- scx(:,:) = 0.0
+
!
-! set shape parameters
+! set concentrations
!
- 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
+! ssmax = 0.0
- 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
+ if ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) 'ICEZVD_GS: dbg = 5b'
-! 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 ( 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)
@@ -12074,6 +13852,124 @@ subroutine nssl_2mom_gs &
+!
+! 6th moments
+!
+
+ IF ( ipconc .ge. 6 ) THEN
+ zx(:,:) = 0.0
+ DO il = lr,lhab
+ IF ( lz(il) .gt. 1 ) THEN
+ DO mgs = 1,ngscnt
+ zx(mgs,il) = Max( an(igs(mgs),jy,kgs(mgs),lz(il)), 0.0 )
+ ENDDO
+ ENDIF
+ ENDDO
+
+ ENDIF
+
+ IF ( ipconc .ge. 6 ) THEN
+
+ IF ( lz(lr) .lt. 1 ) THEN
+ g1x(:,lr) = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/ &
+ & ((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar))
+
+
+ DO mgs = 1,ngscnt
+ IF ( cx(mgs,lr) .gt. 0.0 .and. qx(mgs,lr) .gt. qxmin(lr) ) THEN
+
+ vr = rho0(mgs)*qx(mgs,lr)/(1000.*cx(mgs,lr))
+ IF ( lzr < 1 ) THEN
+ IF ( imurain == 3 ) THEN
+ zx(mgs,lr) = 3.6476*(rnu+2.0)*cx(mgs,lr)*vr**2/(rnu+1.0)
+ ELSE ! imurain == 1
+ zx(mgs,lr) = 3.6476*g1x(mgs,lr)*cx(mgs,lr)*vr**2
+ ENDIF
+ ENDIF
+
+ ENDIF
+ ENDDO
+ ENDIF
+
+ ENDIF
+
+
+ scx(:,:) = 0.0
+!
+! set shape parameters
+!
+ if ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'ICEZVD_GS: dbg = set alpha'
+ 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
+
+ if ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'ICEZVD_GS: dbg = set dab'
+
+ 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
+ end do
+ ENDDO
+
+
+! 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 ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'ICEZVD_GS: dbg = set rz'
+
+ 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 factors
@@ -12112,6 +14008,7 @@ subroutine nssl_2mom_gs &
tmp = qx(mgs,li)+qx(mgs,ls)+qx(mgs,lh)
IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl)
+ IF ( lf > 1 ) tmp = tmp + qx(mgs,lf)
cvm = cv+cvv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) &
+cpigb*(tmp)
@@ -12231,62 +14128,880 @@ subroutine nssl_2mom_gs &
ENDIF
- IF ( lhl .gt. 1 ) THEN
+ IF ( lhl .gt. 1 ) THEN
+
+ xdn(mgs,lhl) = xdn0(lhl)
+ xdntmp(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)
+ xdntmp(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 ( ipconc == 5 .and. imydiagalpha == 2 ) THEN
+
+ cwchtmp = ((3. + dnu(lh))*(2. + dnu(lh))*(1.0 + dnu(lh)))**(-1./3.)
+
+ DO mgs = 1,ngscnt
+ !IF ( igs(mgs) == 19 ) write(0,*) 'k,qr,qh,cr,ch = ',kgs(mgs),qx(mgs,lr),cx(mgs,lr),qx(mgs,lh),cx(mgs,lh)
+ IF ( qx(mgs,lr) .gt. qxmin(lr) .and. cx(mgs,lr) > cxmin ) THEN
+ xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) !
+ xdia(mgs,lr,3) = (xv(mgs,lr)*6.0*cwc1)**(1./3.)
+ ! alpha(mgs,lr) = Min(alphamax, c1r*tanh(c2r*(xdia(mgs,lr,3)*1000. - c3r)) + c4r)
+ ! IF ( igs(mgs) == 19 ) write(0,*) 'imy: i,k,alpr,xdia = ',igs(mgs),kgs(mgs),alpha(mgs,lr),xdia(mgs,lr,3)*1000.
+
+ ! M&M-C 2010:
+ tmp = 4. + alphar
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+ tmp = 1. + alphar
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+ tmp = (x/y)**(1./3.)*xdia(mgs,lr,3)*cwchtmp
+
+ alpha(mgs,lr) = Min(15., 11.8*(1000.*tmp - 0.7)**2 + 2.)
+ ENDIF
+ IF ( qx(mgs,lh) .gt. qxmin(lh) .and. cx(mgs,lh) > cxmin ) THEN
+! MY 2005:
+ xv(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) !
+ xdia(mgs,lh,3) = (xv(mgs,lh)*6.*piinv)**(1./3.) ! mwfac*xdia(mgs,lh,1) ! (xv(mgs,lh)*cwc0*6.0)**(1./3.)
+! alpha(mgs,lh) = Min(alphamax, c1h*tanh(c2h*(xdia(mgs,lh,3)*1000. - c3h)) + c4h)
+
+ ! M&M-C 2010:
+ tmp = 4. + dnu(lh)
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+ tmp = 1. + dnu(lh)
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+ tmp = (x/y)**(1./3.)*xdia(mgs,lh,3)*cwchtmp
+
+ alpha(mgs,lh) = Min(15., 11.8*(1000.*tmp - 0.7)**2 + 2.)
+ ! alphan(mgs,lh) = alpha(mgs,lh)
+
+ ! IF ( igs(mgs) == 19 ) write(0,*) 'imy: i,k,alph,xdia = ',igs(mgs),kgs(mgs),alpha(mgs,lh),xdia(mgs,lh,3)*1000.
+ il = lh
+ DO ic = lc,lh-1 ! lhab
+ i = Nint( alpha(mgs,il)*dqiacralphainv )
+ IF ( ic == lc .or. ic == li .or. ic == ls .or. (ic == lr .and. imurain == 3) ) THEN
+ alp = (3.*alpha(mgs,ic) + 2.)
+ j = Nint( (3.*alpha(mgs,ic) + 2.)*dqiacralphainv )
+ ELSE ! IF ( ic == lr .and. imurain == 1 ) ! rain
+ alp = alpha(mgs,ic)
+ j = Nint( alpha(mgs,ic)*dqiacralphainv )
+ ENDIF
+
+ dab0lh(mgs,ic,il) = dab0lu(j,i,ic,il)
+ dab1lh(mgs,ic,il) = dab1lu(j,i,ic,il)
+ dab0lh(mgs,il,ic) = dab0lu(i,j,il,ic)
+ dab1lh(mgs,il,ic) = dab1lu(i,j,il,ic)
+ ENDDO
+ ENDIF
+! alpha(:,lr) = 0. ! 10.
+! alpha(:,lh) = 0. ! 10.
+ IF ( lhl > 0 ) THEN
+ IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. cx(mgs,lhl) > cxmin ) THEN
+ xv(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*cx(mgs,lhl)) !
+ xdia(mgs,lhl,3) = (xv(mgs,lhl)*6.*piinv)**(1./3.)
+ IF ( xdia(mgs,lhl,3) < 0.008 ) THEN
+ alpha(mgs,lhl) = Min(alphamax, c1hl*tanh(c2hl*(xdia(mgs,lhl,3)*1000. - c3hl)) + c4hl)
+ ELSE
+ alpha(mgs,lhl) = Min(alphamax, c5hl*xdia(mgs,lhl,3)*1000. + c6hl)
+ ENDIF
+
+ il = lhl
+ DO ic = lc,lh-1 ! lhab
+ i = Nint( alpha(mgs,il)*dqiacralphainv )
+ IF ( ic == lc .or. ic == li .or. ic == ls .or. (ic == lr .and. imurain == 3) ) THEN
+ alp = (3.*alpha(mgs,ic) + 2.)
+ j = Nint( (3.*alpha(mgs,ic) + 2.)*dqiacralphainv )
+ ELSE ! IF ( ic == lr .and. imurain == 1 ) ! rain
+ alp = alpha(mgs,ic)
+ j = Nint( alpha(mgs,ic)*dqiacralphainv )
+ ENDIF
+
+ dab0lh(mgs,ic,il) = dab0lu(j,i,ic,il)
+ dab1lh(mgs,ic,il) = dab1lu(j,i,ic,il)
+ dab0lh(mgs,il,ic) = dab0lu(i,j,il,ic)
+ dab1lh(mgs,il,ic) = dab1lu(i,j,il,ic)
+ ENDDO
+
+ ENDIF
+ ENDIF
+
+
+
+ ENDDO
+ ENDIF
+
+
+ IF ( imurain == 3 ) THEN
+ IF ( lzr > 1 ) THEN
+ alphashr = 0.0
+ alphamlr = -2.0/3.0
+ alphasmlr = -2.0/3.0
+ ELSE
+ alphashr = xnu(lr)
+ alphamlr = xnu(lr)
+ alphasmlr = 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
+ alphasmlr = alphasmlr0
+ ELSE
+ alphashr = alphar
+ alphamlr = alphar
+ alphasmlr = 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
+
+! Find shape parameter rain
+
+ g1shr = 1.0
+ g1mlr = 1.0
+ g1smlr = 1.0
+
+! CALL cld_cpu('Z-MOMENT-1')
+
+ IF ( ipconc >= 6 ) THEN
+
+ ! set base g1x in case rain is not 3-moment
+ IF ( ipconc >= 6 .and. imurain == 3 ) THEN
+ il = lr
+ DO mgs = 1,ngscnt
+! g1x(mgs,il) = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ g1x(mgs,il) = (alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0))
+ ENDDO
+ ENDIF
+
+ IF (lzr > 1 ) THEN
+ IF ( imurain == 3 ) THEN
+ g1shr = (alphashr+2.0)/((alphashr+1.0))
+ g1mlr = (alphamlr+2.0)/((alphamlr+1.0))
+ g1smlr = (alphasmlr+2.0)/((alphasmlr+1.0))
+ ELSEIF ( imurain == 1 ) THEN
+! g1shr = 36.*(6.0 + alphashr)*(5.0 + alphashr)*(4.0 + alphashr)/ &
+! & (pi**2*(3.0 + alphashr)*(2.0 + alphashr)*(1.0 + alphashr))
+ g1shr = (6.0 + alphashr)*(5.0 + alphashr)*(4.0 + alphashr)/ &
+ & ((3.0 + alphashr)*(2.0 + alphashr)*(1.0 + alphashr))
+! g1mlr = 36.*(6.0 + alphamlr)*(5.0 + alphamlr)*(4.0 + alphamlr)/ &
+! & (pi**2*(3.0 + alphamlr)*(2.0 + alphamlr)*(1.0 + alphamlr))
+ g1mlr = (6.0 + alphamlr)*(5.0 + alphamlr)*(4.0 + alphamlr)/ &
+ & ((3.0 + alphamlr)*(2.0 + alphamlr)*(1.0 + alphamlr))
+ g1smlr = (6.0 + alphasmlr)*(5.0 + alphasmlr)*(4.0 + alphasmlr)/ &
+ & ((3.0 + alphasmlr)*(2.0 + alphasmlr)*(1.0 + alphasmlr))
+ ENDIF
+ ENDIF
+
+ IF ( lzr > 1 .and. imurain == 3 ) THEN ! { RAIN SHAPE PARAM
+
+
+! CALL cld_cpu('Z-MOMENT-1r')
+ il = lr
+ DO mgs = 1,ngscnt
+
+
+ IF ( iresetmoments == 1 .or. iresetmoments == il .or. iresetmoments == -1 ) THEN ! .or. qx(mgs,il) <= qxmin(il) THEN
+ IF ( zx(mgs,il) <= zxmin ) THEN ! .and. qx(mgs,il) > 0.05e-3 THEN
+!! write(91,*) 'zx=0; qx,cx = ',1000.*qx(mgs,il),cx(mgs,il)
+ qx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ ELSEIF ( iresetmoments == -1 .and. qx(mgs,il) < qxmin(il) ) THEN
+ zx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ ELSEIF ( cx(mgs,il) <= cxmin .and. iresetmoments /= -1 ) THEN ! .and. qx(mgs,il) > 0.05e-3 THEN
+
+ qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il)
+ zx(mgs,lr) = 0.0
+ qx(mgs,lr) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),lr)
+ an(igs(mgs),jgs,kgs(mgs),lr) = qx(mgs,lr)
+ an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr)
+ ENDIF
+ ENDIF
+
+ IF ( .false. .and. zx(mgs,il) <= zxmin .and. cx(mgs,il) <= cxmin ) THEN
+ zx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+ ENDIF
+
+ IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN
+
+ xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr)))
+ 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
+
+ IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN
+! have mass and reflectivity but no concentration, so set concentration, using default alpha
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ z = zx(mgs,il)
+ qr = qx(mgs,il)
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*xdn(mgs,lr)**2)
+! an(igs(mgs),jgs,kgs(mgs),ln(il)) = zx(mgs,il)
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > 0.0 ) THEN
+! have mass and concentration but no reflectivity, so set reflectivity, using default alpha
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+ zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(xdn(mgs,lr)**2*chw)
+ an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr)
+
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN
+! How did this happen?
+ ! set values according to dBZ of -10, or Z = 0.1
+! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2
+ zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ z = zx(mgs,il)
+ qr = qx(mgs,il)
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*1000.*1000)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ ENDIF
+
+ IF ( zx(mgs,lr) > 0.0 ) THEN
+ xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(1000.*cx(mgs,lr))
+ vr = xv(mgs,lr)
+ qr = qx(mgs,lr)
+ nrx = cx(mgs,lr)
+ z = zx(mgs,lr)
+
+! xv = (db(1,kz)*a(1,1,kz,lr))**2/(a(1,1,kz,lnr))
+! rd = z*(pi/6.*1000.)**2/xv
+
+! determine shape parameter alpha by iteration
+ IF ( z .gt. 0.0 ) THEN
+! alpha(mgs,lr) = 3.
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
+ DO i = 1,20
+ IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT
+ alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) )
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
+ alp = Max( rnumin, Min( rnumax, alp ) )
+ ENDDO
+
+! check for artificial breakup (rain larger than allowed max size)
+ IF ( (xv(mgs,il) .gt. xvmx(il) .or. (ioldlimiter >= 2 .and. xv(mgs,il) .gt. xvmx(il)/8.) )) THEN
+ tmp = cx(mgs,il)
+ IF ( ioldlimiter >= 2 ) THEN ! MY-style active breakup
+ x = (6.*rho0(mgs)*qx(mgs,il)/(pi*xdn(mgs,il)*cx(mgs,il)))**(1./3.)
+ x1 = Max(0.0e-3, x - 3.0e-3)
+ x2 = Max(0.5, x/6.0e-3)
+ x3 = x2**3
+ cx(mgs,il) = cx(mgs,il)*Max((1.+2.222e3*x1**2), x3)
+ xv(mgs,il) = xv(mgs,il)/Max((1.+2.222e3*x1**2), x3)
+ ELSE ! simple cutoff
+ xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) )
+ xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+ cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
+ ENDIF
+ !xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+ !cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
+
+ IF ( tmp < cx(mgs,il) ) THEN ! breakup
+
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) )
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ vr = xv(mgs,lr)
+ qr = qx(mgs,lr)
+ nrx = cx(mgs,lr)
+ z = zx(mgs,lr)
+
+
+! determine shape parameter alpha by iteration
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
+ DO i = 1,20
+ IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT
+ alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) )
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
+ alp = Max( rnumin, Min( rnumax, alp ) )
+ ENDDO
+
+
+ ENDIF
+ ENDIF
+
+!
+! Check whether the shape parameter is at or less than the minimum, and if it is, reset the
+! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N)
+!
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ IF ( .true. .and. (alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax) ) THEN
+
+ IF ( rescale_high_alpha .and. alp >= rnumax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(1./(xdn(mgs,il)))**2
+ an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il)
+
+ ELSEIF ( rescale_low_alphar .and. alp <= rnumin ) THEN
+ z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2)
+ zx(mgs,il) = z
+ an(igs(mgs),jy,kgs(mgs),lz(il)) = zx(mgs,il)
+ ENDIF
+ ENDIF
+
+ ! set g1x to use as G factor later. If alpha is in the range ( rnumin < alpha < rnumax ), then
+ ! this will be the same as computing G from alpha. If alpha = rnumax, however, it probably means that
+ ! the moments are not matched correctly, so we compute G from the moments instead so that the dZ/dt rates
+ ! stay consistent with dN/dt and dq/dt.
+ IF ( alp >= rnumax - 0.01 ) THEN
+! g1x(mgs,il) = 6**2*zx(mgs,il)/(cx(mgs,il)*(pi*xv(mgs,lr))**2)
+! g1x(mgs,il) = xdn(mgs,il)*zx(mgs,il)*cx(mgs,il)/((rho0(mgs)*qx(mgs,lr))**2)
+ g1x(mgs,il) = (pi*xdn(mgs,il))**2*zx(mgs,il)*cx(mgs,il)/((6.*rho0(mgs)*qx(mgs,il))**2)
+ ELSE
+ g1x(mgs,il) = g1
+ ENDIF
+
+ tmp = alpha(mgs,lr) + 4./3.
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+ tmp = alpha(mgs,lr) + 1.
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+ gf1palp(mgs) = y
+
+! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 4./3.)/(alpha(mgs,lr) + 1.)**(1./3.)/Gamma_sp(alpha(mgs,lr) + 1.)
+ ventrx(mgs) = x/(y*(alpha(mgs,lr) + 1.)**(1./3.))
+
+ IF ( imurain == 3 .and. izwisventr == 2 ) THEN
+
+ tmp = alpha(mgs,lr) + 1.5 + br/6.
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 1.5 + br/6.)/Gamma_sp(alpha(mgs,lr) + 1.)
+ ventrxn(mgs) = x/(y*(alpha(mgs,lr) + 1.)**((1.+br)/6. + 1./3.))
+
+! This whole section is imurain == 3, so this branch never runs
+! ELSEIF ( imurain == 1 .and. iferwisventr == 2 ) THEN
+!
+! tmp = alpha(mgs,lr) + 2.5 + br/2.
+! i = Int(dgami*(tmp))
+! del = tmp - dgam*i
+! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+!
+!! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 1.5 + br/6.)/Gamma_sp(alpha(mgs,lr) + 1.)
+! ventrxn(mgs) = x/y
+
+
+ ENDIF
+
+ ENDIF
+ ENDIF
+
+ ENDIF
+
+ ENDDO
+! CALL cld_cpu('Z-MOMENT-1r')
+ ENDIF ! }
+
+ ENDIF ! ipconc >= 6
+
+! Find shape parameters for graupel and hail
+ IF ( ipconc .ge. 6 ) THEN
+
+ DO il = lr,lhab
+
+ ! set base values of g1x
+ IF ( (.not. ( il == lr .and. imurain == 3 )) .and. ( il == lr .or. il == lh .or. il == lhl .or. il == lf ) ) THEN
+ DO mgs = 1,ngscnt
+ g1x(mgs,il) = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+ ENDDO
+ ENDIF
+
+ IF ( lz(il) .gt. 1 .and. ( .not. ( il == lr .and. imurain == 3 )) ) THEN
+
+ DO mgs = 1,ngscnt
+
+
+ IF ( iresetmoments == 1 .or. iresetmoments == il .or. iresetmoments == -1 ) THEN ! .or. qx(mgs,il) <= qxmin(il) ) THEN
+ IF ( zx(mgs,il) <= zxmin ) THEN ! .and. qx(mgs,il) > 0.05e-3 ) THEN
+!! write(91,*) 'zx=0; qx,cx = ',1000.*qx(mgs,il),cx(mgs,il)
+ qx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ zx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+ ELSEIF ( iresetmoments == -1 .and. qx(mgs,il) < qxmin(il) ) THEN
+ zx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ ELSEIF ( cx(mgs,il) <= cxmin .and. iresetmoments /= -1 ) THEN ! .and. qx(mgs,il) > 0.05e-3 ) THEN
+ qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il)
+ zx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ ENDIF
+ ENDIF
+
+ IF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= cxmin ) THEN
+ zx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+ ENDIF
+
+ IF ( qx(mgs,il) .gt. qxmin(il) ) THEN
+
+ xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(1.0e-9,cx(mgs,il)))
+ xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+
+ IF ( xv(mgs,il) .lt. xvmn(il) ) THEN
+ xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) )
+ xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+ cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
+ ENDIF
+
+ IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN
+! have mass and reflectivity but no concentration, so set concentration, using default alpha
+ g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+ z = zx(mgs,il)
+ qr = qx(mgs,il)
+! cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(z*(pi*xdn(mgs,il))**2)
+
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > cxmin ) THEN
+! have mass and concentration but no reflectivity, so set reflectivity, using default alpha
+! g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+! & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+! zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw
+! zx(mgs,il) = Min(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(chw*(pi*xdn(mgs,il))**2) )
+ g1 = (6.0 + alphamax)*(5.0 + alphamax)*(4.0 + alphamax)/ &
+ & ((3.0 + alphamax)*(2.0 + alphamax)*(1.0 + alphamax))
+ zx(mgs,il) = Max(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(chw*(pi*xdn(mgs,il))**2) )
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN
+! How did this happen?
+ ! set values according to dBZ of -10, or Z = 0.1
+! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2
+ zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+ z = zx(mgs,il)
+ qr = qx(mgs,il)
+! cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(z*(pi*xdn(mgs,il))**2)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ ELSE
+
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+ z = zx(mgs,il)
+
+ IF ( zx(mgs,il) .gt. 0. ) THEN
+
+! rdi = z*(pi/6.*1000.)**2*chw/((rho0(mgs)*qr)**2)
+ rdi = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2)
+
+! alp = 1.e18*(6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/
+! : ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
+ alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
+! print*,'kz, alp, alpha(mgs,il) = ',kz,alp,alpha(mgs,il),rdi,z,xv
+ alp = Max( alphamin, Min( alphamax, alp ) )
+
+ IF ( newton ) THEN
+ DO i = 1,10
+ IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT
+ alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) )
+ alp = alp + ( galpha(alp) - rdi )/dgalpha(alp)
+ alp = Max( alphamin, Min( alphamax, alp ) )
+ ENDDO
+
+ ELSE
+ DO i = 1,10
+! IF ( 100.*Abs(alp - alpha(mgs,il))/(Abs(alpha(mgs,il))+1.e-5) .lt. 1. ) EXIT
+ IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT
+ alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) )
+! alp = 1.e18*(6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/
+! : ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
+ alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
+! print*,'i,alp = ',i,alp
+ alp = Max( alphamin, Min( alphamax, alp ) )
+ ENDDO
+ ENDIF
+
+
+! check for artificial breakup (graupel/hail larger than allowed max size)
+ IF ( imaxdiaopt == 1 ) 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
+
+ IF ( xv(mgs,il) .gt. xvbarmax .or. (il == lr .and. ioldlimiter >= 2 .and. xv(mgs,il) .gt. xvmx(il)/8.)) THEN
+ tmp = cx(mgs,il)
+ IF( ioldlimiter >= 2 .and. il == lr) THEN ! MY-style drop limiter for rain
+ x = (6.*rho0(mgs)*qx(mgs,il)/(pi*xdn(mgs,il)*cx(mgs,il)))**(1./3.)
+ x1 = Max(0.0e-3, x - 3.0e-3)
+ x2 = Max(0.5, x/6.0e-3)
+ x3 = x2**3
+ cx(mgs,il) = cx(mgs,il)*Max((1.+2.222e3*x1**2), x3)
+ xv(mgs,il) = xv(mgs,il)/Max((1.+2.222e3*x1**2), x3)
+ ELSE
+ xv(mgs,il) = Min( xvbarmax, Max( xvmn(il),xv(mgs,il) ) )
+ xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+ cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
+ ENDIF
+ IF ( tmp < cx(mgs,il) ) THEN ! artificial breakup has happened, so need to adjust reflectivity and find new shape parameter
+ g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2)
+ zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) )
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+ z = zx(mgs,il)
+
+ rdi = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2)
+ alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
+ DO i = 1,10
+ IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT
+ alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) )
+ alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
+ alp = Max( alphamin, Min( alphamax, alp ) )
+ ENDDO
+
+
+ ENDIF
+ ENDIF
+
+!
+! Check whether the shape parameter is at or less than the minimum, and if it is, reset the
+! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N)
+!
+ g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+
+ IF ( ( lrescalelow(il) .or. rescale_high_alpha ) .and. &
+ & ( alpha(mgs,il) <= alphamin .or. alp == alphamin .or. alp == alphamax ) ) THEN
+
+
+
+ IF ( rescale_high_alpha .and. alp >= alphamax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2
+ an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il)
+
+ ELSEIF ( lrescalelow(il) .and. alp <= alphamin .and. .not. (il == lh .and. icvhl2h > 0 ) .and. &
+ .not. ( il == lr .and. .not. rescale_low_alphar ) ) THEN ! alpha = alphamin, so reset Z to prevent growth in C
+ wtest = .false.
+ IF ( irescalerainopt == 0 ) THEN
+ wtest = .false.
+ ELSEIF ( irescalerainopt == 1 ) THEN
+ wtest = qx(mgs,lc) > qxmin(lc)
+ ELSEIF ( irescalerainopt == 2 ) THEN
+ wtest = qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < rescale_wthresh
+ ELSEIF ( irescalerainopt == 3 ) THEN
+ wtest = temcg(mgs) > rescale_tempthresh .and. qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < rescale_wthresh
+ ENDIF
+
+ IF ( il == lr .and. ( wtest ) ) THEN
+! IF ( temcg(mgs) > 0.0 .and. il == lr .and. qx(mgs,lc) > qxmin(lc) ) THEN
+ ! certain situations where rain number is adjusted instead of Z. Helps avoid rain being 'zapped' by autoconverted
+ ! drops (i.e., favor preserving Z when alpha tries to go negative)
+ chw = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2 ! g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z1
+ cx(mgs,il) = chw
+ an(igs(mgs),jy,kgs(mgs),ln(il)) = chw
+ ELSE
+
+ ! Usual resetting of reflectivity moment to force consisntency between Q, N, Z, and alpha when alpha = alphamin
+ z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw
+ z = z1*(6./(pi*xdn(mgs,il)))**2
+ zx(mgs,il) = z
+ an(igs(mgs),jy,kgs(mgs),lz(il)) = z
+ ENDIF
+ ENDIF
+ ENDIF
+
+
+ ! set g1x to use as G factor later. If alpha is in the range ( rnumin < alpha < rnumax ), then
+ ! this will be the same as computing G from alpha. If alpha = rnumax, however, it probably means that
+ ! the moments are not matched correctly, so we compute G from the moments instead so that the dZ/dt rates
+ ! stay consistent with dN/dt and dq/dt.
+! g1x(mgs,il) = zx(mgs,il)*chw*(pi*xdn(mgs,il))**2/(6.*qr*dn(igs(mgs),jy,kgs(mgs)))**2
+! g1x(mgs,il) = g1 ! zx(mgs,il)*cx(mgs,il)/(qr)**2
+ IF ( alp >= alphamax - 0.5 ) THEN
+! g1x(mgs,il) = 6**2*zx(mgs,il)/(cx(mgs,il)*(pi*xv(mgs,lr))**2)
+! g1x(mgs,il) = (xdn(mgs,il))**2*zx(mgs,il)*cx(mgs,il)/((rho0(mgs)*qx(mgs,il))**2)
+ g1x(mgs,il) = (pi*xdn(mgs,il))**2*zx(mgs,il)*cx(mgs,il)/((6.*rho0(mgs)*qx(mgs,il))**2)
+ ELSE
+ g1x(mgs,il) = g1
+ ENDIF
+
+ ENDIF
+
+! IF ( ny .eq. 2 ) THEN
+! IF ( qr .gt. 1.e-3 ) THEN
+! write(0,*) 'alphah at nstep,i,k = ',dtp*(nstep-1),igs(mgs),kgs(mgs),alpha(mgs,il),qr*1000.
+! ENDIF
+! ENDIF
+
+
+ ENDIF ! .true.
+
+ IF ( il == lr ) THEN
+
+! tmp = alpha(mgs,lr) + 4./3.
+! i = Int(dgami*(tmp))
+! del = tmp - dgam*i
+! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+!
+! tmp = alpha(mgs,lr) + 1.
+! i = Int(dgami*(tmp))
+! del = tmp - dgam*i
+! y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+!
+!! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 4./3.)/(alpha(mgs,lr) + 1.)**(1./3.)/Gamma_sp(alpha(mgs,lr) + 1.)
+! ventrx(mgs) = x/(y*(alpha(mgs,lr) + 1.)**(1./3.))
+
- xdn(mgs,lhl) = xdn0(lhl)
- xdntmp(mgs,lhl) = xdn0(lhl)
+ tmp = alpha(mgs,lr) + 1.
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
- IF ( lvol(lhl) .gt. 1 ) THEN
- IF ( vx(mgs,lhl) .gt. 0.0 .and. qx(mgs,lhl) .gt. qxmin(lhl) ) THEN
+ gf1palp(mgs) = y
- IF ( mixedphase .and. lhlw > 1 ) THEN
- ELSE
- dnmx = xdnmx(lhl)
- ENDIF
+ IF ( iferwisventr == 2 ) THEN
+ tmp = alpha(mgs,lr) + 2.5 + br/2.
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
- 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)
- xdntmp(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
+! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 1.5 + br/6.)/Gamma_sp(alpha(mgs,lr) + 1.)
- vx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/xdn(mgs,lhl)
-
+ ventrxn(mgs) = x/y
+
ENDIF
- ENDIF
-
- ENDIF
+
+ ENDIF ! il==lr
+
+
+ ELSE ! below mass threshold
+! g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/
+! & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+! z1 = g1*rho0(mgs)**2*(qr)*qr/chw
+! z = 1.e18*z1*(6./(pi*1000.))**2
+! z = z1*(6./(pi*1000.))**2
+! zx(mgs,il) = z
+! an(igs(mgs),jy,kgs(mgs),lz(il)) = z
+ ENDIF ! ( qx(mgs,il) .gt. qxmin(il) )
+
+
+
+! ENDIF
+ ENDDO ! mgs
+! CALL cld_cpu('Z-DELABK')
+
+! IF ( il == lr ) THEN
+! xnutmp = (alpha(mgs,il) - 2.)/3.
+! da0lr(mgs) = delbk(bb(il), xnutmp, xmu(il), 0)
+! ENDIF
+
+ IF ( .not. ( il == lr .and. imurain == 3 ) ) THEN
+! CALL cld_cpu('Z-DELABK')
+ DO mgs = 1,ngscnt
+ IF ( qx(mgs,il) > qxmin(il) ) THEN
+ xnutmp = (alpha(mgs,il) - 2.)/3.
+
+! IF ( .true. ) THEN
+ DO ic = lc,lh-1 ! lhab
+ IF ( il .ne. ic .and. qx(mgs,ic) .gt. qxmin(ic)) THEN
+ xnuc = xnu(ic)
+ IF ( ic == lc .and. idiagnosecnu > 0 ) xnuc = alpha(mgs,lc) ! alpha for droplets is actually nu
+ IF ( il /= lr .and. ic == lr .and. lzr > 1 ) THEN
+ IF ( imurain == 3 ) THEN
+ xnuc = alpha(mgs,lr) ! alpha is nu already
+ ELSE
+ xnuc = ( alpha(mgs,lr) - 2. )/3. ! convert alpha to nu
+ ENDIF
+ ENDIF
+ ! delabk(ba,bb,nua,nub,mua,mub,k), where a (il) is collector and b (ic) is collected
+ IF ( .false. ) THEN
+ dab0lh(mgs,ic,il) = delabk(bb(ic), bb(il), xnuc, xnutmp, xmu(ic), xmu(il), 0) !dab0(il,ic)
+ dab1lh(mgs,ic,il) = delabk(bb(ic), bb(il), xnuc, xnutmp, xmu(ic), xmu(il), 1) !dab1(il,ic)
+ dab0lh(mgs,il,ic) = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic), 0) !dab0(il,ic)
+ dab1lh(mgs,il,ic) = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic), 1) !dab1(il,ic)
+ ELSE ! use lookup table -- not interpolating yet because table resolution of 0.05 is good enough
+ i = Nint( alpha(mgs,il)*dqiacralphainv )
+ IF ( ic == lc .or. ic == li .or. ic == ls .or. (ic == lr .and. imurain == 3) ) THEN
+ alp = (3.*alpha(mgs,ic) + 2.)
+ j = Nint( (3.*alpha(mgs,ic) + 2.)*dqiacralphainv )
+ ELSE ! IF ( ic == lr .and. imurain == 1 ) ! rain
+ alp = alpha(mgs,ic)
+ j = Nint( alpha(mgs,ic)*dqiacralphainv )
+ ENDIF
+
+ dab0lh(mgs,ic,il) = dab0lu(j,i,ic,il)
+ dab1lh(mgs,ic,il) = dab1lu(j,i,ic,il)
+ dab0lh(mgs,il,ic) = dab0lu(i,j,il,ic)
+ dab1lh(mgs,il,ic) = dab1lu(i,j,il,ic)
+
+! tmp1 = dab0lu(j,i,ic,il)
+! tmp2 = dab1lu(j,i,ic,il)
+! tmp3 = dab0lu(i,j,il,ic)
+! tmp4 = dab1lu(i,j,il,ic)
+! tmp5 = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(ic), xmu(il), 0) !dab0(il,ic)
+! tmp6 = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(ic), xmu(il), 1) !dab1(il,ic)
+! tmp5 = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic), 0) !dab0(il,ic)
+! tmp6 = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic), 1) !dab1(il,ic)
+
+ IF ( .false. .and. ny <= 2 ) THEN
+ write(0,*)
+ write(0,*) 'bb: ', bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic)
+ write(0,*) 'il,ic = ',il,ic,alpha(mgs,il),i,xnuc,alp,j
+ write(0,*) 'dab0lh,tmp1 = ',dab0lh(mgs,ic,il),tmp1
+ write(0,*) 'dab1lh,tmp2 = ',dab1lh(mgs,ic,il),tmp2
+ write(0,*) 'dab0lh,tmp3 = ',dab0lh(mgs,il,ic),tmp3,tmp5
+ write(0,*) 'dab1lh,tmp4 = ',dab1lh(mgs,il,ic),tmp4,tmp6
+
+ ENDIF
+
+ ENDIF
+
+ ENDIF
+ ENDDO
- end do
+! ENDIF
+
+ da0lx(mgs,il) = delbk(bb(il), xnutmp, xmu(il), 0)
+ IF ( il .eq. lh ) THEN
+ da0lh(mgs) = delbk(bb(il), xnutmp, xmu(il), 0)
+ IF ( lzr > 1 ) THEN
+ rzxh(mgs) = 1.
+ ELSE
+ rzxh(mgs) = ((4. + alpha(mgs,il))*(5. + alpha(mgs,il))*(6. + alpha(mgs,il))*(1. + xnu(lr)))/ &
+ & ((1. + alpha(mgs,il))*(2. + alpha(mgs,il))*(3. + alpha(mgs,il))*(2. + xnu(lr)))
+ ENDIF
+
+ IF ( lzhl < 1 ) THEN
+ rzxhlh(mgs) = rzxhl(mgs)/(((4. + alpha(mgs,il))*(5. + alpha(mgs,il))*(6. + alpha(mgs,il))*(1. + xnu(lr)))/ &
+ & ((1. + alpha(mgs,il))*(2. + alpha(mgs,il))*(3. + alpha(mgs,il))*(2. + xnu(lr))))
+ ENDIF
+ ELSEIF ( il .eq. lhl ) THEN
+ da0lhl(mgs) = delbk(bb(il), xnutmp, xmu(il), 0)
+ IF ( lzr > 1 ) THEN
+ rzxhl(mgs) = 1.
+ ELSE
+ rzxhl(mgs) = ((4.0 + alpha(mgs,il))*(5. + alpha(mgs,il))*(6. + alpha(mgs,il))*(1. + xnu(lr)))/ &
+ & ((1. + alpha(mgs,il))*(2. + alpha(mgs,il))*(3. + alpha(mgs,il))*(2. + xnu(lr)))
+ ENDIF
+ ELSEIF ( il == lr ) THEN
+ xnutmp = (alpha(mgs,il) - 2.)/3.
+ da0lr(mgs) = delbk(bb(il), xnutmp, xmu(il), 0)
+ da1lr(mgs) = delbk(bb(il), xnutmp, xmu(il), 1)
+ ENDIF
+
+ ENDIF ! ( qx(mgs,il) > qxmin(il) )
+ ENDDO ! mgs
+! CALL cld_cpu('Z-DELABK')
+ ENDIF ! il /= lr
+! CALL cld_cpu('Z-DELABK')
+
+ ENDIF ! lz(il) .gt. 1
+
+ ENDDO ! il
+
+ ENDIF ! ipconc .ge. 6
- 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
-
+! CALL cld_cpu('Z-MOMENT-1')
!
! set some values for ice nucleation
@@ -12318,7 +15033,7 @@ subroutine nssl_2mom_gs &
! & itype1a,itype2a,temcg,infdo,alpha)
- infdo = 0
+ infdo = 1
IF ( rimdenvwgt > 0 ) infdo = 1
call setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
@@ -12332,9 +15047,9 @@ subroutine nssl_2mom_gs &
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
+ total = qx(mgs,lh) + qx(mgs,ls)
+ IF ( total > tmp ) THEN
+ vt2ave(mgs) = (qx(mgs,lh)*vtxbar(mgs,lh,1) + qx(mgs,ls)*vtxbar(mgs,ls,1))/total
ELSE
vt2ave(mgs) = 0.0
ENDIF
@@ -12480,6 +15195,17 @@ subroutine nssl_2mom_gs &
+ IF ( ipconc >= 6 ) THEN
+ frac = 0.4d0
+ zxmxd(:,:) = 0.0
+ DO il = lr,lhab
+ IF ( lz(il) > 0 .or. ( il == lr ) ) THEN
+ DO mgs = 1,ngscnt
+ zxmxd(mgs,il) = frac*zx(mgs,il)*dtpinv
+ ENDDO
+ ENDIF
+ ENDDO
+ ENDIF
@@ -12517,10 +15243,10 @@ subroutine nssl_2mom_gs &
vshdgs(mgs,il) = vshd ! base value
- IF ( qx(mgs,il) > qxmin(il) ) THEN
+ IF ( qx(mgs,il) > qxmin(il) .and. ivshdgs > 0 ) 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
+ 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
@@ -12577,13 +15303,13 @@ subroutine nssl_2mom_gs &
ers(mgs) = 0.0
ess(mgs) = 0.0
ehs(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehs*ehsclsn
+ ehsfac(mgs) = 1.0 ! factor based on ice saturation
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
@@ -12678,7 +15404,7 @@ subroutine nssl_2mom_gs &
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
+ if (xdia(mgs,lc,1).gt.ewi_dcmin .and. xdia(mgs,li,1).gt.ewi_dimin) 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
@@ -12802,7 +15528,7 @@ subroutine nssl_2mom_gs &
ELSE
fac = Abs(ess0)
- IF ( .true. .and. ess0 < 0.0 ) THEN
+ IF ( iessopt == 2 ) THEN ! experimental code
! 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
@@ -12810,9 +15536,25 @@ subroutine nssl_2mom_gs &
ELSEIF ( wvel(mgs) > 1.0 ) THEN ! transition to stratiform range of values
fac = Max(0.0, 2.0 - wvel(mgs))*fac
ENDIF
+ ELSEIF ( iessopt == 3 ) THEN ! factor based on ice supersat
+ IF ( ssi(mgs) <= 1.0 ) THEN
+ fac = 0.0
+ ehsfac(mgs) = 0.0
+ ELSEIF ( ssi(mgs) <= 1.02 ) THEN
+ fac = fac*(ssi(mgs) - 1.0)/0.02
+ ehsfac(mgs) = (ssi(mgs) - 1.0)/0.02
+ ENDIF
+ ELSEIF ( iessopt == 4 ) THEN ! factor based on ice supersat; very roughly based on Hosler et al. 1957 (J. Met.)
+ IF ( ssi(mgs) <= 1.0 ) THEN
+ fac = 0.1
+ ehsfac(mgs) = 0.1
+ ELSEIF ( ssi(mgs) <= 1.005 ) THEN
+ fac = Max(0.1, fac*(ssi(mgs) - 1.0)/0.005)
+ ehsfac(mgs) = Max(0.1, (ssi(mgs) - 1.0)/0.005)
+ ENDIF
ENDIF
- IF ( temcg(mgs) > esstem1 .and. temcg(mgs) < esstem2 ) THEN ! only nonzero for T > -25
+ IF ( temcg(mgs) > esstem1 .and. temcg(mgs) < esstem2 ) THEN ! only nonzero for T > esstem1
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 ) )
@@ -12923,7 +15665,11 @@ subroutine nssl_2mom_gs &
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
+
+ IF ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lc) >= qxmin(lc) ) THEN
+! ehsclsn(mgs) = ehs_collsn
+! ehs(mgs) = ehscnv(mgs)*ehsfac(mgs)*Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. )
+! ELSEIF ( 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
@@ -12933,10 +15679,9 @@ subroutine nssl_2mom_gs &
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) = ehscnv(mgs)*Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) ! shut off qhacs as graupel goes to low density; limits scavenging of snow in bright band
! 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
!
@@ -12944,7 +15689,7 @@ subroutine nssl_2mom_gs &
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
+! if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehi(mgs) = 0.0
end if
IF ( lis > 1 ) THEN
@@ -12952,7 +15697,7 @@ subroutine nssl_2mom_gs &
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
+! if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehis(mgs) = 0.0
end if
ENDIF
@@ -13089,6 +15834,7 @@ subroutine nssl_2mom_gs &
end do
+
!
!
!
@@ -13162,6 +15908,7 @@ subroutine nssl_2mom_gs &
do mgs = 1,ngscnt
qraci(mgs) = 0.0
craci(mgs) = 0.0
+ qracs(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
@@ -13207,8 +15954,9 @@ subroutine nssl_2mom_gs &
ENDIF
end do
!
+ IF ( ipconc < 3 ) THEN
do mgs = 1,ngscnt
- qracs(mgs) = 0.0
+ qracs(mgs) = 0.0
IF ( ers(mgs) .gt. 0.0 .and. ipconc < 3 ) THEN
IF ( lwsm6 .and. ipconc == 0 ) THEN
vt = vt2ave(mgs)
@@ -13225,6 +15973,7 @@ subroutine nssl_2mom_gs &
& , qsmxd(mgs))
ENDIF
end do
+ ENDIF
!
!
@@ -13371,6 +16120,7 @@ subroutine nssl_2mom_gs &
!
do mgs = 1,ngscnt
qhacw(mgs) = 0.0
+ qhacwmlr(mgs) = 0.0
rarx(mgs,lh) = 0.0
vhacw(mgs) = 0.0
vhsoak(mgs) = 0.0
@@ -13437,6 +16187,11 @@ subroutine nssl_2mom_gs &
ENDIF
+ qhacwmlr(mgs) = qhacw(mgs)
+ IF ( temg(mgs) > tfr .and. iqhacwshr == 0 ) THEN
+ qhacw(mgs) = 0.0
+ 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
@@ -13466,14 +16221,18 @@ subroutine nssl_2mom_gs &
rimdn(mgs,lh) = 1000.*(0.051 + 0.114*tmp - 0.0055*tmp**2)
- ELSEIF ( irimdenopt == 3 ) THEN ! Macklin
+ ELSEIF ( irimdenopt == 3 .or. irimdenopt == 4) THEN ! Macklin (3) or Saunders and Hosseini 2001
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 ) )
+ IF ( irimdenopt == 3 ) THEN
+ rimdn(mgs,lh) = Min(900., Max( 170., 110.*tmp**0.76 ) )
+ ELSEIF ( irimdenopt == 4 ) THEN ! Saunders and Hosseini
+ rimdn(mgs,lh) = Min(917., Max( 10., 900.0*(1.0 - 0.905**tmp ) ) )
+ ENDIF
ENDIF
ELSE
@@ -13687,6 +16446,7 @@ subroutine nssl_2mom_gs &
do mgs = 1,ngscnt
qhlacw(mgs) = 0.0
+ qhlacwmlr(mgs) = 0.0
vhlacw(mgs) = 0.0
vhlsoak(mgs) = 0.0
IF ( lhl > 1 .and. .true.) THEN
@@ -13715,10 +16475,15 @@ subroutine nssl_2mom_gs &
qhlacw(mgs) = Min( qhlacw(mgs), 0.5*qx(mgs,lc)*dtpinv )
+ qhlacwmlr(mgs) = qhlacw(mgs)
+ IF ( temg(mgs) > tfr .and. iqhlacwshr == 0 ) THEN
+ qhlacw(mgs) = 0.0
+ ENDIF
+
IF ( lvol(lhl) .gt. 1 ) THEN
IF ( temg(mgs) .lt. 273.15) THEN
- IF ( irimdenopt == 1 ) THEN ! Rasmussen and Heymsfeld (1985)
+ IF ( irimdenopt == 1 ) THEN ! Heymsfeld and Pflaum (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)
@@ -13732,13 +16497,17 @@ subroutine nssl_2mom_gs &
rimdn(mgs,lhl) = 1000.*(0.051 + 0.114*tmp - 0.005*tmp**2)
- ELSEIF ( irimdenopt == 3 ) THEN ! Macklin
+ ELSEIF ( irimdenopt == 3 .or. irimdenopt == 4) THEN ! Macklin (3) or Saunders and Hosseini 2001
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 ) )
+ IF ( irimdenopt == 3 ) THEN
+ rimdn(mgs,lhl) = Min(900., Max( 170., 110.*tmp**0.76 ) )
+ ELSEIF ( irimdenopt == 4 ) THEN ! Saunders and Hosseini
+ rimdn(mgs,lhl) = Min(917., Max( 10., 900.0*(1.0 - 0.905**tmp ) ) )
+ ENDIF
ENDIF
ELSE
@@ -14053,7 +16822,7 @@ subroutine nssl_2mom_gs &
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)
+ ciacrs(mgs) = (1.-frach)*ciacrf(mgs) ! *rzxh(mgs)
ENDIF
ENDIF
@@ -14083,7 +16852,7 @@ subroutine nssl_2mom_gs &
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
+ ELSEIF ( tmp .ge. essfrac2 ) THEN
ec0(mgs) = 0.0
ELSE
ec0(mgs) = (essfrac2 - tmp)/(essfrac2 - essfrac1)
@@ -14160,7 +16929,21 @@ subroutine nssl_2mom_gs &
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
+
+
+ ! check median volume diameter
+ IF ( icracrthresh > 1 ) THEN
+ IF ( imurain == 1 ) THEN
+ tmp = (3.67+alpha(mgs,lr))*xdia(mgs,lr,1) ! median volume diameter; units of mm (Ulbrich 1983, JCAM)
+ ELSE ! imurain == 3,
+ tmp = (1.678+alpha(mgs,lr))**(1./3.)*xdia(mgs,lr,1) ! units of mm (using method of Ulbrich 1983. See ventillation_stuff.nb)
+ ENDIF
+ ELSE
+ tmp = xdia(mgs,lr,3) - 0.1e-3
+ ENDIF
+
+! IF ( xdia(mgs,lr,3) .gt. 2.0e-3 .or. icracr <= 0 ) THEN
+ IF ( tmp .gt. 1.9e-3 .or. icracr <= 0 ) THEN
ec0(mgs) = 0.0
cracr(mgs) = 0.0
ELSE
@@ -14242,6 +17025,7 @@ subroutine nssl_2mom_gs &
!
if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22kk'
chaci(:) = 0.0
+ chaci0(:) = 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
@@ -14292,6 +17076,7 @@ subroutine nssl_2mom_gs &
!
if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22nn'
chacs(:) = 0.0
+ chacs0(:) = 0.0
if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then
do mgs = 1,ngscnt
IF ( ehs(mgs) .gt. 0 ) THEN
@@ -14451,7 +17236,7 @@ subroutine nssl_2mom_gs &
! Ziegler (1985) autoconversion
!
!
- IF ( ipconc .ge. 2 .and. ircnw /= -1) THEN ! DTD: added flag for autoconversion. If -1, turns off autoconversion
+ IF ( ipconc .ge. 2 ) THEN
if (ndebug .gt. 0 ) write(0,*) 'conc 26a'
DO mgs = 1,ngscnt
@@ -14534,6 +17319,47 @@ subroutine nssl_2mom_gs &
IF ( crcnw(mgs) < 1.e-30 ) qrcnw(mgs) = 0.0
+ IF ( ipconc >= 6 ) THEN
+ IF ( lzr > 1 .and. qrcnw(mgs) > 0.0 ) THEN
+! vr = rho0(mgs)*qrcnw(mgs)/(1000.*crcnw(mgs))
+! zrcnw(mgs) = 36.*(xnu(lr)+2.0)*crcnw(mgs)*vr**2/((xnu(lr)+1.0)*pi**2)
+ ! DTD: If rain exists at a grid point already either use the alpha-preserving Z-rate eqn. (dmrauto == 1)
+ ! or a mass-weighted average of the alpha-preserving Z-rate eqn. and the init. rate eqn. (dmrauto == 2)
+ ! or the original initiation rate equation (dmrauto == 0). Not sure if this is the correct way to go but seems to work ok.
+ IF (qx(mgs,lr) .gt. qxmin(lr) .and. ( dmrauto == 1 .or. dmrauto ==2 ) ) THEN
+ tmp3 = qx(mgs,lr)/cx(mgs,lr)
+ tmp4 = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2* &
+ & ( 2.*tmp3 * qrcnw(mgs) - tmp3**2 * crcnw(mgs) )
+ if (imurain == 3) then
+ vr = rho0(mgs)*qrcnw(mgs)/(1000.)
+ tmp3 = 36.*(xnu(lc)+2.0)*vr**2/(crcnw(mgs)*(xnu(lc)+1.0)*pi**2)
+ else
+ tmp3 = galpharaut*(6.*rho0(mgs)*qrcnw(mgs)/(pi*xdn0(lr)))**2/crcnw(mgs)
+ endif
+ IF ( dmrauto == 1 ) THEN ! Preserve alpha
+ zrcnw(mgs) = tmp4
+ ELSEIF ( dmrauto == 2 ) THEN ! Mass-weighted average
+ zrcnw(mgs) = (tmp3*qrcnw(mgs)+tmp4*qx(mgs,lr))/(qrcnw(mgs)+qx(mgs,lr))
+ ENDIF
+ else ! original formulation
+ IF ( imurain == 3 ) THEN
+ vr = rho0(mgs)*qrcnw(mgs)/(1000.) ! crcnw(mgs) not divided here but is in next line, cancels one factor in the numerator
+ zrcnw(mgs) = 36.*(xnu(lc)+2.0)*vr**2/(crcnw(mgs)*(xnu(lc)+1.0)*pi**2)
+ ELSE ! rain in gamma of diameter
+ IF ( dmropt <= 1 .or. dmropt >= 4 .or. ( qx(mgs,lr) < qxmin(lr) .and. cx(mgs,lr) < cxmin ) ) THEN
+ zrcnw(mgs) = galpharaut*(6.*rho0(mgs)*qrcnw(mgs)/(pi*xdn0(lr)))**2/crcnw(mgs)
+ ELSE
+ tmp3 = qx(mgs,lr)/cx(mgs,lr)
+ zrcnw(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2* &
+ & ( 2.*tmp3 * qrcnw(mgs) - tmp3**2 * crcnw(mgs) )
+ ENDIF
+! vr = rho0(mgs)*qrcnw(mgs)/(1000.) ! crcnw(mgs) not divided here but is in next line, cancels one factor in the numerator
+! zrcnw(mgs) = 36.*(xnu(lc)+2.0)*vr**2/(crcnw(mgs)*(xnu(lc)+1.0)*pi**2)
+ ENDIF
+ endif
+! z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2)
+ ENDIF
+ ENDIF ! ipconc >= 6
! IF ( crcnw(mgs) .gt. cautn(mgs) .and. crcnw(mgs) .gt. 1.0 )
! : THEN
! write(0,*) 'crcnw,cautn ',crcnw(mgs)/cautn(mgs),
@@ -14744,6 +17570,15 @@ subroutine nssl_2mom_gs &
ELSE !{
+ IF ( ipconc >= 6 .and. lzr > 1 ) THEN
+ ! interpolate along x, i.e., ratio;
+ tmp1 = ziacrratio(i,j) + delx*dqiacrratioinv*(ziacrratio(ip1,j) - ziacrratio(i,j))
+ tmp2 = ziacrratio(i,jp1) + delx*dqiacrratioinv*(ziacrratio(ip1,jp1) - ziacrratio(i,jp1))
+
+ ! interpolate along alpha;
+
+ zrfrz(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*zx(mgs,lr)*dtpinv
+ ENDIF
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
@@ -14753,6 +17588,10 @@ subroutine nssl_2mom_gs &
crfrzs(mgs) = crfrz(mgs)
qrfrzs(mgs) = qrfrz(mgs)
+ IF ( ipconc >= 6 .and. lzr > 1 ) THEN
+ zrfrzs(mgs) = zrfrz(mgs)
+ zrfrzf(mgs) = 0.
+ ENDIF
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!
@@ -14764,6 +17603,10 @@ subroutine nssl_2mom_gs &
crfrzf(mgs) = 0.0
qrfrzf(mgs) = 0.0
+ IF (ipconc >= 6 .and. lzr > 1 ) THEN
+ zrfrzs(mgs) = zrfrz(mgs)
+ zrfrzf(mgs) = 0.
+ ENDIF
ELSE !{
! recalculate using dhmn for ratio
@@ -14803,10 +17646,23 @@ subroutine nssl_2mom_gs &
crfrzs(mgs) = crfrzs(mgs) - crfrzf(mgs)
qrfrzs(mgs) = qrfrzs(mgs) - qrfrzf(mgs)
+ IF ( ipconc >= 6 .and. lzr > 1 ) THEN
+ zrfrzs(mgs) = zrfrz(mgs)
+ ! interpolate along x, i.e., ratio;
+ tmp1 = ziacrratio(i,j) + delx*dqiacrratioinv*(ziacrratio(ip1,j) - ziacrratio(i,j))
+ tmp2 = ziacrratio(i,jp1) + delx*dqiacrratioinv*(ziacrratio(ip1,jp1) - ziacrratio(i,jp1))
+
+ ! interpolate along alpha;
+
+ zrfrzf(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*zx(mgs,lr)*dtpinv
+ zrfrzs(mgs) = zrfrzs(mgs) - zrfrzf(mgs)
+ zrfrzf(mgs) = (1000./900.)**2*zrfrzf(mgs)
+ ENDIF
ENDIF ! }
ELSE
crfrzs(mgs) = 0.0
qrfrzs(mgs) = 0.0
+ zrfrzs(mgs) = 0.0
ENDIF ! }
ENDIF !}
@@ -14819,6 +17675,10 @@ subroutine nssl_2mom_gs &
crfrz(mgs) = fac*crfrz(mgs)
crfrzs(mgs) = fac*crfrzs(mgs)
crfrzf(mgs) = fac*crfrzf(mgs)
+ IF ( ipconc >= 6 .and. lzr > 1 ) THEN
+ zrfrz(mgs) = fac*zrfrz(mgs)
+ zrfrzf(mgs) = fac*zrfrzf(mgs)
+ ENDIF
ENDIF
ENDIF !}
@@ -15363,8 +18223,16 @@ subroutine nssl_2mom_gs &
x = 1. + alpha(mgs,lr)
- IF ( lzr > 1 ) THEN ! 3 moment
-!
+ IF ( ipconc >= 6 .and. lzr > 1 ) THEN ! 3 moment
+ tmp = 1. + alpr ! alpha(mgs,lr)
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+ tmp = 2.5 + alpha(mgs,lr) + 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
ELSE
y = ventrxn(mgs)
ENDIF
@@ -15380,6 +18248,13 @@ subroutine nssl_2mom_gs &
& 0.308*fvent(mgs)*y* &
& Sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2)
+ rwventz(mgs) = 0.0
+
+! rwventz(mgs) = &
+! & 0.78*x + &
+! & 0.308*fvent(mgs)*y* &
+! & Sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2)
+
ELSEIF ( iferwisventr == 2 ) THEN
@@ -15392,6 +18267,23 @@ subroutine nssl_2mom_gs &
& *(xdia(mgs,lr,1)**((1.0+br)/2.0)) )
+ IF ( ipconc >= 7 ) THEN
+ alpr = Min(alpharmax,alpha(mgs,lr) )
+
+ tmp = alpr + 5.5 + br/2.
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+! rwventz(mgs) = &
+! & 0.78*(4. + alpha(mgs,lr))*(3. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(1. + alpha(mgs,lr)) + &
+ rwventz(mgs) = &
+ & 0.78*(4. + alpr)*(3. + alpr)*(2. + alpr)*(1. + alpr) + &
+ & 0.308*fvent(mgs)* &
+ & Sqrt(ax(lr)*rhovt(mgs))*(y/gf1palp(mgs))*(xdia(mgs,lr,1)**((1.0+br)/2.0))
+
+ ENDIF
+
ENDIF ! iferwisventr
@@ -15434,6 +18326,9 @@ subroutine nssl_2mom_gs &
hwventa = (0.78)*gmoi(igmhwa)
hwventb = (0.308)*gmoi(igmhwb)
! hwventc = (4.0*gr/(3.0*cdx(lh)))**(0.25)
+ hwvent(:) = 0.0
+ hwventy(:) = 0.0
+
do mgs = 1,ngscnt
IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN
hwventc = (4.0*gr/(3.0*cdxgs(mgs,lh)))**(0.25)
@@ -15554,6 +18449,8 @@ subroutine nssl_2mom_gs &
& -ftka(mgs)*temcg(mgs)/rho0(mgs) ) &
& / (felf(mgs))
fmlt2(mgs) = -fcw(mgs)*temcg(mgs)/felf(mgs)
+ fmlt1e(mgs) = (2.0*pi)* &
+ & ( felv(mgs)*fwvdf(mgs)*(qss0(mgs)-qx(mgs,lv)) ) / (felf(mgs))
end do
!
! Vapor Deposition constants
@@ -15581,6 +18478,7 @@ subroutine nssl_2mom_gs &
qhlmlrlg(:) = 0.0
ENDIF
qhfzh(:) = 0.0
+ qffzf(:) = 0.0
qhlfzhl(:) = 0.0
qhfzhlg(:) = 0.0
qhlfzhllg(:) = 0.0
@@ -15588,9 +18486,10 @@ subroutine nssl_2mom_gs &
vffzf(:) = 0.0
vhlfzhl(:) = 0.0
qsfzs(:) = 0.0
- zsmlr(:) = 0.0
+! zsmlr(:) = 0.0
zhmlr(:) = 0.0
zhmlrr(:) = 0.0
+ zsmlrr(:) = 0.0
zhshr(:) = 0.0
zhlmlr(:) = 0.0
zhlshr(:) = 0.0
@@ -15642,7 +18541,7 @@ subroutine nssl_2mom_gs &
qhmlr(mgs) = &
& meltfac*min( &
& fmlt1(mgs)*cx(mgs,lh)*hwvent(mgs)*xdia(mgs,lh,1) &
- & + fmlt2(mgs)*(qhacrmlr(mgs)+qhacw(mgs)) &
+ & + fmlt2(mgs)*(qhacrmlr(mgs)+qhacwmlr(mgs)) &
& , 0.0 )
ELSEIF ( ibinhmlr == 1 ) THEN ! use incomplete gamma functions to approximate the bin results
@@ -15674,13 +18573,13 @@ subroutine nssl_2mom_gs &
qhlmlr(mgs) = &
& meltfac*min( &
& fmlt1(mgs)*cx(mgs,lhl)*hlvent(mgs)*xdia(mgs,lhl,1) &
- & + fmlt2(mgs)*(qhlacrmlr(mgs)+qhlacw(mgs)) &
+ & + fmlt2(mgs)*(qhlacrmlr(mgs)+qhlacwmlr(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 )
+! #ifdef 1
+! #if (defined 1) && defined( COMMAS ) || defined( COMMASTMP )
ELSEIF ( ibinhlmlr == -1 ) THEN ! OLD VERSION use incomplete gamma functions to approximate the bin results
@@ -15711,7 +18610,7 @@ subroutine nssl_2mom_gs &
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.
+ qhmlh(mgs) = 0. ! not used
! Rasmussen and Heymsfield say melt water remains on graupel up to 9 mm before shedding
@@ -15788,8 +18687,15 @@ subroutine nssl_2mom_gs &
! ENDIF
-
IF ( chmlr(mgs) < 0.0 .and. (ibinhmlr < 1 .or. lzh < 1) ) THEN ! { already done if ibinhmlr > 0
+ IF ( ipconc >= 6 .and. lzr .gt. 1 .and. lzh < 1 .and. qx(mgs,lh) > qxmin(lh) ) THEN ! Only compute if rain is 3-moment but graupel is not, otherwise is computed later
+ tmp = qx(mgs,lh)/cx(mgs,lh)
+ alp = alpha(mgs,lh)
+ g1 = g1x(mgs,lh) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+
+ zhmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhmlr(mgs) - tmp**2 * chmlr(mgs) )
+
+ ENDIF
IF ( ibinhmlr == 0 .or. lzh < 1 ) THEN
IF ( ihmlt .eq. 1 ) THEN
@@ -15895,6 +18801,17 @@ subroutine nssl_2mom_gs &
ENDIF !}
+ IF ( ipconc >= 8 .and. lzhl .gt. 1 .and. ibinhlmlr <= 0 ) THEN
+ IF ( cx(mgs,lhl) > 0.0 ) THEN
+
+ tmp = qx(mgs,lhl)/cx(mgs,lhl)
+ alp = alpha(mgs,lhl)
+! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+ g1 = g1x(mgs,lhl) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+
+ zhlmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( tmp * qhlmlr(mgs) )
+ ENDIF
+ ENDIF
ENDIF ! }
ENDIF ! }.not. mixedphase
@@ -15932,6 +18849,7 @@ subroutine nssl_2mom_gs &
ENDDO
!
!
+ qhdsv(:) = 0.0
qhldsv(:) = 0.0
do mgs = 1,ngscnt
@@ -15941,6 +18859,7 @@ subroutine nssl_2mom_gs &
& 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),
@@ -16177,20 +19096,41 @@ subroutine nssl_2mom_gs &
! end of qlimit
+ qhcev(:) = 0.0
+ chcev(:) = 0.0
+ qhlcev(:) = 0.0
+ chlcev(:) = 0.0
+ qfcev(:) = 0.0
+
do mgs = 1,ngscnt
qisbv(mgs) = 0.0
qssbv(mgs) = 0.0
qidpv(mgs) = 0.0
qsdpv(mgs) = 0.0
+ qhsbv(mgs) = 0.0
+ qscev(mgs) = 0.0
+ cscev(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
+ & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN ! last condition (qr qxmin(lh) ) THEN
+ IF ( temg(mgs) < tfr .or. .not. qhmlr(mgs) < 0.0 ) THEN
+ ! no liquid from melting, so evaporation is greater. Thus can calculate sublimation rate
qhsbv(mgs) = max( min(qhdsv(mgs), 0.0), -qhmxd(mgs) )
-
qhdpv(mgs) = Max(qhdsv(mgs), 0.0)
+ ENDIF
+
+ IF ( .true. .and. qhmlr(mgs) < 0.0 .and. .not. mixedphase ) THEN
+ ! Liquid is forming, so find the evaporation that was subtracted from melting (if it is not condensing)
+! qhcev(mgs) = &
+! & evapfac*min( &
+! & fmlt1e(mgs)*cx(mgs,lh)*hwvent(mgs)*xdia(mgs,lh,1), 0.0 )
+
+ qhcev(mgs) = evapfac*2.0*pi*(qx(mgs,lv)-qss0(mgs))* &
+ & cx(mgs,lh)*xdia(mgs,lh,1)*hwvent(mgs)/(qss0(mgs)*(fav(mgs)+fbv(mgs)))
+
+ qhcev(mgs) = max(qhcev(mgs), -qhmxd(mgs))
+ IF ( temg(mgs) > tfr ) qhcev(mgs) = Min(0.0, qhcev(mgs) )
+
+ ENDIF
+ ENDIF
qhlsbv(mgs) = 0.0
qhldpv(mgs) = 0.0
IF ( lhl .gt. 1 ) THEN
+ IF ( qx(mgs,lhl) > qxmin(lhl) ) THEN
+ IF ( temg(mgs) < tfr .or. .not. qhlmlr(mgs) < 0.0 ) THEN
qhlsbv(mgs) = max( min(qhldsv(mgs), 0.0), -qxmxd(mgs,lhl) )
qhldpv(mgs) = Max(qhldsv(mgs), 0.0)
+ ENDIF
+ IF ( qhlmlr(mgs) < 0.0 .and. .not. mixedphase ) THEN
+ ! Liquid is forming, so find the evaporation that was subtracted from melting (if it is not condensing)
+ qhlcev(mgs) = evapfac*2.0*pi*(qx(mgs,lv)-qss0(mgs))* &
+ & cx(mgs,lhl)*xdia(mgs,lhl,1)*hlvent(mgs)/(qss0(mgs)*(fav(mgs)+fbv(mgs)))
+
+ qhlcev(mgs) = max(qhlcev(mgs), -qhlmxd(mgs))
+ IF ( temg(mgs) > tfr ) qhlcev(mgs) = Min(0.0, qhlcev(mgs) )
+
+ ENDIF
+ ENDIF
ENDIF
temp1 = qidpv(mgs) + qsdpv(mgs) + qhdpv(mgs) + qhldpv(mgs)
@@ -16345,6 +19318,10 @@ subroutine nssl_2mom_gs &
end if
end do
+
+
+
+
!
!
! compute dry growth rate of snow, graupel, and hail
@@ -16371,7 +19348,7 @@ subroutine nssl_2mom_gs &
!
do mgs = 1,ngscnt
- IF ( temg(mgs) < tfr ) THEN
+ IF ( tfrdry < temg(mgs) .and. temg(mgs) < tfr ) THEN
!
! qswet(mgs) =
! > ( xdia(mgs,ls,1)*swvent(mgs)*cx(mgs,ls)*fwet1(mgs)
@@ -16382,31 +19359,39 @@ subroutine nssl_2mom_gs &
! IF ( dnu(lh) .ne. 0. ) THEN
! qhwet(mgs) = qhdry(mgs)
! ELSE
+ IF ( incwet == 0 ) THEN
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))
+ ELSE
+ ENDIF
+
! 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))
+ IF ( incwet == 0 ) 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))
+
+ ELSE
+ ENDIF ! incwet
ENDIF
ELSE
qhwet(mgs) = qhdry(mgs)
qhlwet(mgs) = qhldry(mgs)
-
ENDIF
!
! qhlwet(mgs) = qhldry(mgs)
end do
+
!
! shedding rate
!
@@ -16466,7 +19451,7 @@ subroutine nssl_2mom_gs &
qhshr(mgs) = -qhdry(mgs)
qhlshr(mgs) = -qhldry(mgs)
ELSE ! new and correct
-
+ ! note that the qxacr terms should be zero here, so shedding at T > 0 is all from the droplets
qsshr(mgs) = - qsacr(mgs) - qsacw(mgs) ! -qsdry(mgs)
qhlshr(mgs) = - qhlacw(mgs) - qhlacr(mgs) ! -qhldry(mgs)
qhshr(mgs) = - qhacw(mgs) - qhacr(mgs) ! -qhdry(mgs)
@@ -16802,7 +19787,93 @@ subroutine nssl_2mom_gs &
ltest = xdia(mgs,lh,1)*(4. + alpha(mgs,lh)) > Abs( hlcnhdia ) ! test on mass-weighted diameter
ENDIF
- dg0(mgs) = -1.
+ IF ( iusedw == 0 .and. ihlcnh == 1 ) THEN
+ dg0(mgs) = -1.
+ ELSE
+ IF (((qhacw(mgs) + qhacr(mgs))*dtp > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin .and. temg(mgs) .le. tfr-2.0 &
+ .and. temg(mgs) .gt. dwtempmin ) .or. ( wetgrowth(mgs) .and. qx(mgs,lh) > hlcnhqmin ) ) THEN
+! dw = 0.01*( Exp( -temcg(mgs)/( 1.1e4 * rho0(mgs)*ehw(mgs)*qx(mgs,lc) - 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 ) ) - 1.0 )
+! dwr = 0.01*( Exp( -temcg(mgs)/( 1.1e4 * rho0(mgs)*(ehw(mgs)*qx(mgs,lc)+ehr(mgs)*qx(mgs,lr)) - &
+! 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 ) ) - 1.0 )
+ x = 1.1e4 * rho0(mgs)*(ehw(mgs)*qx(mgs,lc)+ehr(mgs)*qx(mgs,lr)) - &
+ 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0
+ IF ( x > 1.e-20 ) THEN
+ arg = Min(70.0, (-temcg(mgs)/x )) ! prevent overflow of the exp function in 32 bit
+ dwr = 0.01*(exp(arg) - 1.0)
+ ELSE
+ dwr = 1.e30
+ ENDIF
+ d = dwr
+ IF ( dwr < 0.2 .and. dwr > 0.0 .and. rho0(mgs)*(qx(mgs,lc)+qx(mgs,lr)) > 1.e-4 ) THEN
+ sqrtrhovt = Sqrt( rhovt(mgs) )
+ fventh = sqrtrhovt*(fpndl(mgs)**(1./3.)) * (fakvisc(mgs))**(-0.5)
+ fventm = sqrtrhovt*(fschm(mgs)**(1./3.)) * (fakvisc(mgs))**(-0.5)
+ ltemq = (tfr-163.15)/fqsat+1.5
+ qvs0 = pqs(mgs)*tabqvs(ltemq)
+ denomdp = felf(mgs) + fcw(mgs)*temcg(mgs)
+ denominvdp = 1.d0/(felf(mgs) + fcw(mgs)*temcg(mgs))
+
+! write(91,*) 'dw,dwr,temcg = ',100.*dw,100.*dwr,temcg(mgs)
+ h1 = ( -ftka(mgs)*temcg(mgs) - felv(mgs)*fwvdf(mgs)*rho0(mgs)*(qx(mgs,lv) - qvs0) )
+ h2 = ehi(mgs)*qx(mgs,li)*rho0(mgs)*fci(mgs)*temcg(mgs)
+ h3 = Max(dwehwmin, ehw(mgs))*qx(mgs,lc)
+ h4 = ehr(mgs)* qx(mgs,lr)
+ ! iterate to find minimum diameter for wet growth. Start with value of dwr
+ DO n = 1,10
+ d = Max(d, 1.e-4)
+ dold = d
+ vth = axx(mgs,lh)*d**bxx(mgs,lh)
+ x2 = fventh*sqrtrhovt*Sqrt(d*vth)
+ IF ( x2 > 1.4 ) THEN
+ ah = 0.78 + 0.308*x2 ! heat ventillation
+ ELSE
+ ah = 1.0 + 0.108*x2**2 ! mass ventillation (Beard and Pruppacher 1971, eq. 9)
+ ENDIF
+
+ IF ( .false. ) THEN ! this option includes 'am' separate from ah, which makes only small differences. Otherwise equivalent to second option
+ x1 = fventm*sqrtrhovt*Sqrt(d*vth)
+ IF ( x1 > 1.4 ) THEN
+ am = 0.78 + 0.308*x1 ! mass ventillation (Beard and Pruppacher 1971, eq. 8)
+ ELSE
+ am = 1.0 + 0.108*x1**2 ! mass ventillation (Beard and Pruppacher 1971, eq. 9)
+ ENDIF
+
+ d = 8.*denominvdp*( am*felv(mgs)*fwvdf(mgs)*rho0(mgs)*(qvs0 - qx(mgs,lv)) - ah*ftka(mgs)*temcg(mgs) )/ &
+ (dtp* ( ( Max(0.001,vth - vtxbar(mgs,lc,1))*h3 + &
+ Max(0.001,vth - vtxbar(mgs,lr,1))*h4) *rho0(mgs) + &
+ Max(0.001,vth - vtxbar(mgs,li,1))*h2*denominvdp))
+
+ ELSE
+
+ ! Based on Farley and Orville (1986), eq. 5-9 but neglecting the Ci*(T0-Ts) term in (8) since we want Ts=T0
+ ! Simplified mass rates as dm_w/dt = pi/4*d**2*(Vh - Vc)*rhoair*qc*ehw, etc.
+ d = 8.*ah*h1/ &
+ ( ( Max(0.001,vth - vtxbar(mgs,lc,1))*h3 + &
+ Max(0.001,vth - vtxbar(mgs,lr,1))*h4) *rho0(mgs)*denomdp + &
+ Max(0.001,vth - vtxbar(mgs,li,1))*h2)
+
+ ENDIF
+ IF ( Abs(dold - d)/dold < 0.05 .or. ( n > 3 .and. d > dg0thresh ) ) EXIT
+
+ ENDDO
+ ENDIF
+
+ dg0(mgs) = Min( dwmax, Max( d, dwmin ) )
+ ELSE
+ IF ( qx(mgs,lh) > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin .and. temg(mgs) .le. tfr-2.0 ) THEN
+ dg0(mgs) = dwmax
+ ELSE
+ dg0(mgs) = dg0thresh + 0.0001
+ ENDIF
+ ENDIF
+
+ IF ( ihlcnh == 3 .and. (qhacw(mgs) + qhacr(mgs))*dtp > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin &
+ .and. temg(mgs) .le. tfr-2.0 ) THEN
+ ! set a secondary condition on to capture large graupel that is riming but not in wet growth
+ dg0(mgs) = Min( dg0(mgs), dg0thresh - 0.0001 )
+ ENDIF
+
+ ENDIF
wtest = (dg0(mgs) > 0.0 .and. dg0(mgs) < dg0thresh )
@@ -16837,18 +19908,6 @@ subroutine nssl_2mom_gs &
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 !{
@@ -16858,8 +19917,6 @@ subroutine nssl_2mom_gs &
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 !}
@@ -16874,12 +19931,119 @@ subroutine nssl_2mom_gs &
ELSEIF ( ihlcnh == 3 ) THEN !{
+ IF ( wtest .and. &
+ ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr-2. .and. qx(mgs,lh) > hlcnhqmin ) ) THEN
+ ! convert number, mass, and reflectivity for d > dw
+ IF ( ipconc == 5 ) THEN
+ ! dg0(mgs) = Min( dg0(mgs), hldia1 )
+ !dg0(mgs) = hldia1
+ ENDIF
+
+ ratio = Min( maxratiolu, dg0(mgs)/xdia(mgs,lh,1) )
+
+
+ ! mass
+ tmp2 = gaminterp(ratio,alpha(mgs,lh),4,1)
+ IF ( ipconc == 5 ) THEN
+ ! tmp2 = Min( 0.25, tmp2 )
+ ENDIF
+ qxd1 = qx(mgs,lh)*(tmp2)
+ qhlcnh(mgs) = dtpinv*qxd1
+ flim = 1.0
+ tmp3 = qxmxd(mgs,lh)
+ IF (qxd1 > tmp3 ) THEN
+! flim = tmp3/(qxd1)
+! qhlcnh(mgs) = flim*qhlcnh(mgs)
+ ENDIF
+
+
+
+ IF ( ( qxd1 > qxmin(lhl) .and. ipconc > 5 ) .or. ( qxd1 > 10.*qxmin(lhl) .and. ipconc == 5) ) THEN
+
+ ! number
+ tmp = gaminterp(ratio,alpha(mgs,lh),1,1)
+ IF ( ipconc == 5 ) THEN
+ ! tmp = Min( 0.2, tmp )
+ ENDIF
+ cxd1 = flim*cx(mgs,lh)*( tmp)
+ chlcnh(mgs) = dtpinv*cxd1
+ chlcnhhl(mgs) = chlcnh(mgs)
+
+ IF ( qx(mgs,lhl) > qxmin(lhl) .and. dmhlopt > 0 ) THEN
+ tmp = rho0(mgs)*qhlcnh(mgs)/chlcnhhl(mgs)
+ IF ( tmp < xmas(mgs,lhl) ) THEN
+ ! dh0 = ( qxd1*dh0 + qx(mgs,lhl)*xmas(mgs,lhl))/( qxd1 + qx(mgs,lhl)) ! weighted average
+ dh0 = (( qxd1*tmp**(1./3.) + qx(mgs,lhl)*xmas(mgs,lhl)**(1./3.))/( qxd1 + qx(mgs,lhl)))**3 ! weighted average
+ chlcnhhl(mgs) = Min( chlcnhhl(mgs), rho0(mgs)*qhlcnh(mgs)/dh0 )
+ ELSE
+! dh0 = Max( dh0, xmas(mgs,lhl) ) ! when enough hail is established, do not dilute the size
+ ENDIF
+ ENDIF
+
+
+ ! reflectivity
+ IF ( ipconc >= 6 .and. lzh > 1 .and. lzhl > 1 ) THEN
+ tmp3 = gaminterp(ratio,alpha(mgs,lh),11,1)
+ zxd1 = flim*zx(mgs,lh)*(tmp3)
+ zhlcnh(mgs) = dtpinv*zxd1
+ ELSE
+ zxd1 = 0
+ ENDIF
+
+ ELSE
+ qhlcnh(mgs) = 0.0
+ ENDIF
+
+ vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh)
+ vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh))
+
+ ENDIF
+
+
ENDIF !}
ENDDO
ELSEIF ( ihlcnh == 2 ) THEN ! 10-ice type conversion
+!
+! Staka and Mansell (2005) type conversion
+!
+! hldia1 is set in micro_module and namelist
+! IF ( .true. ) THEN
+
+ ! convert number, mass, and reflectivity for d > hldia1,
+ ! regardless of wet growth status, but as long as riming > 0
+ DO mgs = 1,ngscnt
+ IF ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr-2. .and. qx(mgs,lh) > qxmin(lh) ) THEN
+ ratio = Min( maxratiolu, hldia1/xdia(mgs,lh,1) )
+
+ ! number
+ tmp = gaminterp(ratio,alpha(mgs,lh),1,1)
+ cxd1 = cx(mgs,lh)*( tmp)
+ chlcnh(mgs) = dtpinv*cxd1
+ chlcnhhl(mgs) = chlcnh(mgs)
+
+ ! mass
+ tmp2 = gaminterp(ratio,alpha(mgs,lh),4,1)
+ qxd1 = qx(mgs,lh)*(tmp2)
+ qhlcnh(mgs) = dtpinv*qxd1
+
+ ! reflectivity
+ IF ( lzh > 1 .and. lzhl > 1 ) THEN
+ tmp3 = gaminterp(ratio,alpha(mgs,lh),11,1)
+ zxd1 = zx(mgs,lh)*(tmp3)
+ zhlcnh(mgs) = dtpinv*zxd1
+ ELSE
+ zxd1 = 0
+ ENDIF
+ vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh)
+ vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh))
+
+ ENDIF
+
+ ENDDO
+! ENDIF
ELSEIF ( ihlcnh == 0 ) THEN
do mgs = 1,ngscnt
@@ -17115,6 +20279,10 @@ subroutine nssl_2mom_gs &
ciacrf(mgs) = qrzfac(mgs)*ciacrf(mgs)
ciacrs(mgs) = qrzfac(mgs)*ciacrs(mgs)
+! IF ( lzh .gt. 1 ) THEN
+! zrfrzf(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,lr)+2.)/(xdn0(lr)**2*(alpha(mgs,lr)+1.)) * &
+! ( 2.*tmp * qrfrzf(mgs) - tmp**2 * crfrzf(mgs) )
+! ENDIF
vrfrzf(mgs) = qrzfac(mgs)*vrfrzf(mgs)
viacrf(mgs) = qrzfac(mgs)*viacrf(mgs)
@@ -17154,7 +20322,13 @@ subroutine nssl_2mom_gs &
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)
+ IF ( icrcev == 1 ) THEN
+ crcev(mgs) = (cx(mgs,lr)/(qx(mgs,lr)))*qrcev(mgs)
+ ELSEIF ( icrcev == 2 ) THEN
+ crcev(mgs) = (cx(mgs,lr)/(qx(mgs,lr)))*qrcev(mgs)*vtxbar(mgs,lr,2)/vtxbar(mgs,lr,1)
+ ELSE
+ crcev(mgs) = 0.0
+ ENDIF
ELSE
crcev(mgs) = 0.0
ENDIF
@@ -17166,12 +20340,6 @@ subroutine nssl_2mom_gs &
!
! 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
@@ -17181,6 +20349,7 @@ subroutine nssl_2mom_gs &
chlcevlg(:) = 0.0
ENDIF
+
!
!
!
@@ -18128,6 +21297,14 @@ subroutine nssl_2mom_gs &
pqlwlghld(:) = 0.0
pqlwhli(:) = 0.0
pqlwhld(:) = 0.0
+ IF ( ipconc > 5 ) THEN
+ pzhwi(:) = 0.0
+ pzhwd(:) = 0.0
+ pzrwi(:) = 0.0
+ pzrwd(:) = 0.0
+ pzhli(:) = 0.0
+ pzhld(:) = 0.0
+ ENDIF
!
@@ -18366,7 +21543,8 @@ subroutine nssl_2mom_gs &
qrcev(mgs) = frac*qrcev(mgs)
qhlacr(mgs) = frac*qhlacr(mgs)
vhlacr(mgs) = frac*vhlacr(mgs)
-! qhcev(mgs) = frac*qhcev(mgs)
+ qhcev(mgs) = frac*qhcev(mgs)
+ qhlcev(mgs) = frac*qhlcev(mgs)
IF ( warmonly < 0.5 ) THEN
@@ -18412,6 +21590,8 @@ subroutine nssl_2mom_gs &
! STOP
ENDIF
+
+
end do
IF ( warmonly < 0.5 ) THEN
@@ -18440,7 +21620,7 @@ subroutine nssl_2mom_gs &
& -qhcns(mgs) &
& +(1-il5(mgs))*qsmlr(mgs) + qsshr(mgs) & !null at this point when wet snow included
! > +il5(mgs)*(qssbv(mgs)) &
- & + (qssbv(mgs)) &
+ & + qssbv(mgs) &
& + Min(0.0, qscev(mgs)) &
& -qsmul(mgs)
@@ -18555,53 +21735,634 @@ subroutine nssl_2mom_gs &
& +(1-il5(mgs))*qhmlr(mgs) !null at this point when wet graupel included
end do
-!
-! Hail
-!
- IF ( lhl .gt. 1 ) THEN
+!
+! 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
+
+
+
+!
+! Graupel reflectivity
+!
+ if (ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'graupel reflectivity'
+
+ do mgs = 1,ngscnt
+
+! zhmlr(mgs) = 0.0
+! zhshr(mgs) = 0.0
+! zhmlrr(mgs) = 0.0
+! zhshrr(mgs) = 0.0
+ zhdsv(mgs) = 0.0
+! IF ( lf < 1 ) THEN
+ IF ( ffrzh > 0.0 ) THEN
+ ziacr(mgs) = 0.0
+ ziacrf(mgs) = 0.0
+ ENDIF
+! ENDIF
+ zhcns(mgs) = 0.0
+ zhcni(mgs) = 0.0
+ zhacs(mgs) = 0.0
+ zhaci(mgs) = 0.0
+
+ ENDDO
+
+ IF ( lzh .gt. 1 ) THEN !
+ do mgs = 1,ngscnt
+
+
+ IF ( qx(mgs,lh) .gt. qxmin(lh) .and. cx(mgs,lh) .gt. 0.0 ) THEN
+ tmp = qx(mgs,lh)/cx(mgs,lh)
+ alp = Max( alphamin, alpha(mgs,lh) )
+! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+ g1 = g1x(mgs,lh) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+! g1r = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+
+ zhaci(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qhaci(mgs) )
+ zhacs(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qhacs(mgs) )
+
+ IF ( .not. mixedphase .and. ibinhmlr < 1 ) THEN
+ zhmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhmlr(mgs) - tmp**2 * chmlr(mgs) )
+ ENDIF
+
+ zhshr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshr(mgs) )
+
+! IF ( lzr > 0 .and. qhshr(mgs) /= 0.0 .and. chshrr(mgs) /= 0.0 .and. ibinhmlr < 1 ) THEN
+ IF ( lzr > 0 .and. qhshr(mgs) /= 0.0 .and. chshrr(mgs) /= 0.0 ) THEN
+! IF ( temg(mgs) > tfr + 2.0 ) THEN
+! zhshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshrr(mgs) )
+! IF ( zhshrr(mgs) > 0. ) THEN
+! zhshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshr(mgs) )
+! ENDIF
+! z1 = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) ) ! should this be g1shr?
+! zhshrr(mgs) = Max( z1, zhshrr(mgs))
+! ELSE
+! zhshrr(mgs) = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) )
+
+
+ IF ( temg(mgs) >= tfr ) THEN
+ ! zhshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn0(lr)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshrr(mgs) )
+ ! IF ( zhshrr(mgs) > 0.0 ) THEN
+ ! zhshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn0(lr)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshr(mgs) )
+ ! ENDIF
+ IF ( (shedalp + alpha(mgs,lh))*xdia(mgs,lh,1) < sheddiam ) THEN ! if not shedding small drops, then use alpha of hail
+ z1 = g1*(6.0*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) )
+ ELSE
+ z1 = g1shr*(6.0*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) ) ! should this be g1shr?
+ ENDIF
+ zhshrr(mgs) = z1
+! z1 = g1mlr*(rho0(mgs)/(xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) ) ! should this be g1shr?
+! zhshrr(mgs) = Max( z1, zhshrr(mgs))
+ ELSE
+ zhshrr(mgs) = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) )
+ ENDIF
+
+ zhshrr(mgs) = Min( 0.0, zhshrr(mgs) )
+ ENDIF
+
+ IF ( zhshr(mgs) > 0.0 ) THEN
+ write(0,*) 'Problem with zhshr! zhshr,qhshr,chshr = ',zhshr(mgs),qhshr(mgs),chshr(mgs)
+ write(0,*) 'g1,tmp, qx,cx,zx = ',g1,tmp,qx(mgs,lh),cx(mgs,lh),zx(mgs,lh)
+ write(0,*) ( 2.*tmp * qhshr(mgs) - tmp**2 * chshr(mgs) ), 2.*tmp * qhshr(mgs), - tmp**2 * chshr(mgs)
+ write(0,*) 'temcg = ',temcg(mgs),'chshr recalc = ',(cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhshr(mgs)
+
+ STOP
+ ENDIF
+
+
+! zhshr(mgs) = (xdn0(lr)/(xdn(mgs,lh)))**2*( zx(mgs,lh) * qhshr(mgs) )
+
+ qtmp = qhdpv(mgs) + qhcev(mgs) + qhsbv(mgs)
+ ctmp = chdpv(mgs) + chcev(mgs) + chsbv(mgs)
+
+ zhdsv(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qtmp - tmp**2 * ctmp )
+
+ alp = Max( alphahacx, alpha(mgs,lh) )
+! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+ g1 = g1x(mgs,lh) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+
+ IF ( .true. ) THEN ! {
+ IF ( qhacr(mgs) .gt. 0.0 ) THEN
+! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacr(mgs) )
+
+! g1r = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacr(mgs) )
+ zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacr(mgs) )
+! zhacrf(mgs) = g1*zhacr
+
+
+! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lh)+dtp*qhacr(mgs))**2)/(cx(mgs,lh))
+
+ IF ( z > zx(mgs,lh) ) THEN
+! zhacr(mgs) = (z - zx(mgs,lh))*dtpinv
+ ELSE
+! zhacr(mgs) = 0.0
+ ENDIF
+ ENDIF
+
+! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) )
+! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) - tmp**2 * chacr(mgs) )
+
+! 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))
+ IF ( qhacw(mgs) .gt. 0.0 ) THEN
+! zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) )
+ zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) )
+
+! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lh)+dtp*(qhacw(mgs)-qhmul1(mgs)))**2)/(cx(mgs,lh))
+ IF ( z > zx(mgs,lh) ) THEN
+! zhacw(mgs) = (z - zx(mgs,lh))*dtpinv
+ ENDIF
+ ENDIF
+
+ ELSE ! } { ! this is not used because of the 'true' above
+
+ IF ( qhacw(mgs) .gt. 0.0 .or. qhacr(mgs) .gt. 0.0 ) THEN
+ z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lh)+dtp*(qhacr(mgs) + qhacw(mgs)-qhmul1(mgs)))**2)/(cx(mgs,lh))
+! zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) )
+ IF ( z > zx(mgs,lh) ) THEN
+ zhacw(mgs) = (z - zx(mgs,lh))*dtpinv
+ ENDIF
+ ENDIF
+
+ ENDIF ! }
+
+ IF ( qhlcnh(mgs) .gt. 0.0 .and. ihlcnh < 2 ) THEN
+ zhlcnh(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qhlcnh(mgs) - tmp**2 * chlcnh(mgs) )
+ ENDIF
+ ENDIF
+! qsplinter(mgs)
+ IF ( ffrzh*qiacrf(mgs) .gt. 0.0 .and. cx(mgs,lr) .gt. 0.0 .and. qx(mgs,lr) .gt. qxmin(lr) ) THEN
+ tmp = qx(mgs,lr)/cx(mgs,lr)
+! alp = 3.0
+! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+ IF ( imurain == 3 ) THEN
+ ! note that 3.6476 = (6/pi)**2
+ ziacr(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,lr)+2.)/(xdn0(lr)**2*(alpha(mgs,lr)+1.))* &
+ & ( 2.*tmp * qiacrf(mgs) - tmp**2 * ciacrf(mgs) )
+ ELSE ! imurain == 1
+ ziacr(mgs) = 3.6476*rho0(mgs)**2*g1x(mgs,lr)/(xdn0(lr)**2)* &
+ & ( 2.*tmp * qiacrf(mgs) - tmp**2 * ciacrf(mgs) )
+ ENDIF
+ ziacr(mgs) = Min( ziacr(mgs), zxmxd(mgs,lr) )
+! ziacrf(mgs) = (xdn(mgs,lr)/xdn(mgs,lh))**2 * ziacr(mgs)
+ ziacrf(mgs) = (xdn(mgs,lr)/xdnmx(lh))**2 * ziacr(mgs)
+! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*tmp * (qiacrf(mgs) - qsplinter(mgs)) - tmp**2 * ciacrf(mgs) )
+! ziacrf(mgs) = Min( ziacrf(mgs), z )
+ ENDIF
+
+
+
+ IF ( ffrzh*qrfrzf(mgs) .gt. 0.0 .and. cx(mgs,lr) .gt. 0.0 ) THEN
+ tmp = qx(mgs,lr)/cx(mgs,lr)
+! alp = 3.0
+! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+ IF ( imurain == 3 ) THEN
+ zrfrz(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,lr)+2.)/(xdn0(lr)**2*(alpha(mgs,lr)+1.)) * &
+ & ( 2.*tmp * qrfrzf(mgs) - tmp**2 * crfrzf(mgs) )
+ zrfrzf(mgs) = (xdn(mgs,lr)/xdn(mgs,lh))**2 * zrfrz(mgs)
+ ELSEIF ( imurain == 1 .and. ibiggopt /= 2 ) THEN
+! zrfrz(mgs) = 3.6476*rho0(mgs)**2*g1x(mgs,lr)/(xdn0(lr)**2) * &
+! & ( 2.*tmp * qrfrzf(mgs) - tmp**2 * crfrz(mgs) )
+ zrfrz(mgs) = 3.6476*rho0(mgs)**2*g1x(mgs,lr)/(xdn0(lr)**2) * &
+ & ( 2.*tmp * qrfrz(mgs) - tmp**2 * crfrz(mgs) )
+ zrfrzf(mgs) = 3.6476*rho0(mgs)**2*g1x(mgs,lr)/(rhofrz**2) * &
+ & ( 2.*tmp * qrfrzf(mgs) - tmp**2 * crfrzf(mgs) )
+ ENDIF
+ zrfrz(mgs) = Min( zrfrz(mgs), Max(0.4,qrfrz(mgs)/qx(mgs,lr))*zx(mgs,lr)*dtpinv )
+! zrfrzf(mgs) = (xdn(mgs,lr)/xdn(mgs,lh))**2 * zrfrz(mgs)
+! zrfrzf(mgs) = (xdn(mgs,lr)/xdnmx(lh))**2 * zrfrz(mgs)
+! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*tmp * (qrfrzf(mgs)-qsplinter2(mgs)) - tmp**2 * crfrzf(mgs) )
+! zrfrzf(mgs) = Min( zrfrzf(mgs), z )
+ ! change this to be alpha=0?
+ ENDIF
+
+ IF ( lhl > 1 .and. qhcnhl(mgs) .gt. 0.0 ) THEN
+ tmp = qx(mgs,lhl)/cx(mgs,lhl)
+ zhcnhl(mgs) = g1x(mgs,lhl)*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*( tmp ) * qhcnhl(mgs) - tmp**2 * chcnhl(mgs) )
+
+ ENDIF
+
+ IF ( qhcns(mgs) > 0.0 .and. chcns(mgs) > 0.0 .and. cx(mgs,ls) > cxmin .and. vhcns(mgs) > 0 ) THEN
+ tmp = qx(mgs,ls)/cx(mgs,ls)
+ r = rho0(mgs)*qhcns(mgs)/vhcns(mgs) ! density of new graupel particles
+ IF ( imusnow == 3 ) THEN
+ zhcns(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,ls)+2.)/(r**2*(alpha(mgs,ls)+1.)) * &
+ & ( 2.*tmp * qhcns(mgs) - tmp**2 * chcns(mgs) )
+ ELSE
+ write(0,*) 'Value of imusnow not valid. Must be 3 (fix me for =1). imusnow = ',imusnow
+ STOP
+ ENDIF
+ ENDIF
+
+ IF ( qhcni(mgs) > 0.0 .and. chcni(mgs) > 0.0 .and. cx(mgs,li) > cxmin .and. vhcni(mgs) > 0 ) THEN
+ tmp = qx(mgs,li)/cx(mgs,li)
+ r = rho0(mgs)*qhcni(mgs)/vhcni(mgs) ! density of new graupel particles
+ zhcni(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,li)+2.)/(r**2*(alpha(mgs,li)+1.)) * &
+ & ( 2.*tmp * qhcni(mgs) - tmp**2 * chcni(mgs) )
+ ENDIF
+
+
+ pzhwi(mgs) = &
+ & +ifrzg*ffrzh*(zrfrzf(mgs) &
+ & +il5(mgs)*ifiacrg*(ziacrf(mgs) ) ) &
+! : + zhcnsh(mgs) + zhcnih(mgs) &
+ & + zhacw(mgs) &
+ & + zhacr(mgs) &
+ & + zhcnhl(mgs) &
+ & + zhacs(mgs) &
+ & + zhaci(mgs) &
+ & + f2h*zhcni(mgs) + f2h*zhcns(mgs) &
+ & + Max( 0.0, zhdsv(mgs) )
+
+ pzhwd(mgs) = 0.0 &
+ & + (1-il5(mgs))*zhmlr(mgs) &
+ & + zhshr(mgs) &
+ & + Min( 0.0, zhdsv(mgs) ) &
+ & - il5(mgs)*zhlcnh(mgs)
+
+
+ IF ( igs(mgs) == 44 .and. kgs(mgs) == 23 .or. dtp*( pqhwi(mgs) + pqhwd(mgs) ) > qxmin(lh) ) THEN
+! write(0,*) 'i,k,time = ',igs(mgs),kgs(mgs),time_real
+! write(0,*) 'pzhwi,d = ',pzhwi(mgs),pzhwd(mgs),dtp*( pzhwi(mgs) + pzhwd(mgs) ),zx(mgs,lh)
+! write(0,*) 'pqhwi,d = ',pqhwi(mgs),pqhwd(mgs),dtp*( pqhwi(mgs) + pqhwd(mgs) ),qx(mgs,lh)
+! write(0,*) 'pchwi,d = ',pchwi(mgs),pchwd(mgs),dtp*( pchwi(mgs) + pchwd(mgs) ),cx(mgs,lh)
+ ENDIF
+
+
+! IF ( zhcnhl(mgs) < 0.0 ) THEN
+! write(0,*) 'Problem with zhcnhl! zhcnhl,qhcnhl,chcnhl = ',zhcnhl(mgs),qhcnhl(mgs),chcnhl(mgs)
+! write(0,*) 'g1,tmp = ',g1x(mgs,lhl),tmp
+! write(0,*) ( 2.*( tmp ) * qhcnhl(mgs) - tmp**2 * chcnhl(mgs) )
+!
+!! STOP
+! ENDIF
+ end do
+
+ if (ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'end graupel reflectivity'
+
+ ENDIF
+
+!
+! Hail reflectivity
+!
+
+ do mgs = 1,ngscnt
+
+ zhldsv(mgs) = 0.0
+ zhlacr(mgs) = 0.0
+ zhlacw(mgs) = 0.0
+
+ ENDDO
+
+ IF ( lzhl .gt. 1 .or. ( lzr > 1 .and. lnhl > 1 ) ) THEN ! also run for 2-moment hail for 3-moment rain sources
+
+ if (ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'hail reflectivity'
+
+ do mgs = 1,ngscnt
+
+ IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. cx(mgs,lhl) .gt. 0.0 ) THEN
+ tmp = qx(mgs,lhl)/cx(mgs,lhl)
+ alp = Max( alphamin, alpha(mgs,lhl) )
+! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+ g1 = g1x(mgs,lhl) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+
+ IF ( .not. mixedphase .and. qhlmlr(mgs) /= 0.0 .and. chlmlr(mgs) /= 0.0 .and. ibinhlmlr < 1 ) THEN
+ zhlmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlmlr(mgs) - tmp**2 * chlmlr(mgs) )
+ ENDIF
+
+ zhlshr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlshr(mgs) - tmp**2 * chlshr(mgs) )
+ IF ( lzr > 1 .and. qhlshr(mgs) /= 0.0 .and. chlshrr(mgs) /= 0.0 ) THEN
+ IF ( temg(mgs) >= tfr ) THEN
+ ! zhlshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn0(lr)))**2*( 2.*tmp * qhlshr(mgs) - tmp**2 * chlshrr(mgs) )
+ ! IF ( zhlshrr(mgs) > 0.0 ) THEN
+ ! zhlshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn0(lr)))**2*( 2.*tmp * qhlshr(mgs) - tmp**2 * chlshr(mgs) )
+ ! ENDIF
+ IF ( (shedalp + alpha(mgs,lhl))*xdia(mgs,lhl,1) < sheddiam ) THEN ! if not shedding small drops, then use alpha of hail
+ z1 = g1*(6.0*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlshr(mgs)**2/ chlshrr(mgs) )
+ ELSE
+ z1 = g1shr*(6.0*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlshr(mgs)**2/ chlshrr(mgs) ) ! should this be g1shr?
+ ENDIF
+ zhlshrr(mgs) = z1
+! z1 = g1mlr*(rho0(mgs)/(xdn(mgs,lr)))**2*( qhlshr(mgs)**2/ chlshrr(mgs) ) ! should this be g1shr?
+! zhlshrr(mgs) = Max( z1, zhlshrr(mgs))
+ ELSE
+ zhlshrr(mgs) = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlshr(mgs)**2/ chlshrr(mgs) )
+ ENDIF
+
+ zhlshrr(mgs) = Min( 0.0, zhlshrr(mgs) )
+ ENDIF
+
+ IF ( zhlshr(mgs) > 0.0 ) THEN
+ write(0,*) 'Problem with zhlshr! zhlshr,qhlshr,chlshr = ',zhlshr(mgs),qhlshr(mgs),chlshr(mgs)
+ write(0,*) 'g1,tmp, qx,cx,zx = ',g1,tmp,qx(mgs,lhl),cx(mgs,lhl),zx(mgs,lhl)
+ write(0,*) ( 2.*tmp * qhlshr(mgs) - tmp**2 * chlshr(mgs) ), 2.*tmp * qhlshr(mgs), - tmp**2 * chlshr(mgs)
+ write(0,*) 'temcg = ',temcg(mgs),'chlshr recalc = ',(cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlshr(mgs)
+
+ STOP
+ ENDIF
+! zhlshr(mgs) = Min( 0.0, zhlshr(mgs) )
+
+! zhlshr(mgs) = (xdn0(lr)/(xdn(mgs,lhl)))**2*( zx(mgs,lhl) * qhlshr(mgs) )
+
+ qtmp = qhldpv(mgs) + qhlcev(mgs)
+ ctmp = chldpv(mgs) + chlcev(mgs)
+
+ zhldsv(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*( tmp ) * qtmp - tmp**2 * ctmp )
+
+ alp = Max( alphahacx, alpha(mgs,lhl) )
+! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+ g1 = g1x(mgs,lhl) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+
+ IF ( .true. ) THEN ! {
+ IF ( qhlacr(mgs) .gt. 0.0 ) THEN
+! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lhl)+dtp*qhlacr(mgs))**2)/(cx(mgs,lhl))
+ zhlacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*( tmp ) * qhlacr(mgs) )
+! zhlacr(mgs) = Min( zxmxd(mgs,lr), zhlacr(mgs) )
+
+! IF ( z > zx(mgs,lhl) ) THEN
+! zhlacr(mgs) = (z - zx(mgs,lhl))*dtpinv
+! ELSE
+! zhlacr(mgs) = 0.0
+! ENDIF
+ ENDIF
+
+! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) )
+! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) - tmp**2 * chacr(mgs) )
+
+ IF ( qhlacw(mgs) .gt. 0.0 ) THEN
+ alp = Max( 3.0, alpha(mgs,lhl)+1. )
+ g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+
+! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lhl)+dtp*(qhlacw(mgs)-qhlmul1(mgs)))**2)/(cx(mgs,lhl))
+! zhlacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lhl)/cx(mgs,lhl)) * qhlacw(mgs) )
+ zhlacw(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlacw(mgs) )
+
+! IF ( z > zx(mgs,lhl) ) THEN
+! zhlacw(mgs) = (z - zx(mgs,lhl))*dtpinv
+! ENDIF
+ g1 = g1x(mgs,lhl) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+ ENDIF
+
+ ELSE ! } .false. {
+
+ IF ( qhlacw(mgs) .gt. 0.0 .or. qhlacr(mgs) .gt. 0.0 ) THEN
+ z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lhl)+dtp*(qhlacr(mgs) + qhlacw(mgs)-qhlmul1(mgs)))**2)/(cx(mgs,lhl))
+! zhlacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lhl)/cx(mgs,lhl)) * qhlacw(mgs) )
+ IF ( z > zx(mgs,lhl) ) THEN
+ zhlacw(mgs) = (z - zx(mgs,lhl))*dtpinv
+ ENDIF
+ ENDIF
+
+ ENDIF ! }
+
+ ENDIF
+! qsplinter(mgs)
+
+ IF ( lzhl > 1 ) THEN
+ pzhli(mgs) = ffrzh*(((1.0-ifrzg)*zrfrzf(mgs) &
+ & +il5(mgs)*(1.0-ifiacrg)*ziacrf(mgs) )) &
+ & + il5(mgs)*zhlcnh(mgs) &
+ & + zhlacw(mgs) &
+ & + zhlacr(mgs) &
+! : + zhlacs(mgs) &
+ & + Max( 0.0, zhldsv(mgs) )
+
+ pzhld(mgs) = 0.0 &
+ & + (1-il5(mgs))*zhlmlr(mgs) &
+ & + zhlshr(mgs) &
+ & - zhcnhl(mgs) &
+ & + Min( 0.0, zhldsv(mgs) )
+
+
+ IF ( .not. ( -1.0 < pzhli(mgs) .and. pzhli(mgs) < 1.e20 ) ) THEN
+ write(iunit,*) 'Problem with pzhli!'
+ write(iunit,*) 'zhlcnh,zhlacw,zhlacr,zhldsv = ',zhlcnh(mgs),zhlacw(mgs),zhlacr(mgs),zhldsv(mgs)
+ ENDIF
+
+ IF ( .not. ( -1.0e20 < pzhld(mgs) .and. pzhld(mgs) < 1. ) ) THEN
+ write(iunit,*) 'Problem with pzhld!'
+ write(iunit,*) 'zhlmlr,zhlshr,zhldsv = ',zhlmlr(mgs),zhlshr(mgs),zhldsv(mgs)
+ ENDIF
+
+ ENDIF ! lzhl > 1
+
+ end do
+
+ ENDIF
+
+!
+! rain reflectivity
+!
+ if (ndebug .gt. 0 ) write(0,*) 'WARMZIEG: dbg = 11'
+
+ IF ( lzr .gt. 1 ) THEN !
+
+ DO mgs = 1,ngscnt
+
+ zracw(mgs) = 0.0
+ zracr(mgs) = 0.0
+ zrcev(mgs) = 0.0
+ zrach(mgs) = 0.0
+ zrachl(mgs) = 0.0
+ zsshr(mgs) = 0.0
+ zsshrr(mgs) = 0.0
+! zsmlr(mgs) = 0.0
+ zsmlrr(mgs) = 0.0
+
+ IF ( qx(mgs,ls) .gt. qxmin(ls) .and. ( csmlr(mgs) /= 0.0 .or. csshr(mgs) /= 0.0 .or. &
+ csmlrr(mgs) /= 0.0 .or. csshrr(mgs) /= 0.0) ) THEN !{
+ tmp = qx(mgs,ls)/cx(mgs,ls)
+ g1 = 36.*(xnu(ls)+2.0)/((xnu(ls)+1.0)*pi**2)
+ IF ( .not. mixedphase ) THEN
+! zsmlr(mgs) = (xdn(mgs,ls)/xdn(mgs,lr))**2*g1*(rho0(mgs)/(xdn(mgs,ls)))**2* &
+! & ( 2.*tmp * qsmlr(mgs) - tmp**2 * csmlr(mgs) )
+
+ IF ( csmlrr(mgs) /= 0.0 ) THEN
+ z1 = g1smlr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qsmlr(mgs)**2/ csmlrr(mgs) )
+ zsmlrr(mgs) = z1
+ ENDIF
+ ENDIF
+
+! zsshr(mgs) = (xdn(mgs,ls)/xdn(mgs,lr))**2*g1*(rho0(mgs)/(xdn(mgs,ls)))**2* &
+! & ( 2.*tmp * qsshr(mgs) - tmp**2 * csshr(mgs) )
+
+ IF ( csshrr(mgs) /= 0.0 ) THEN
+ z1 = g1smlr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qsshr(mgs)**2/ csshrr(mgs) )
+ zsshrr(mgs) = z1
+ ENDIF
+
+ ENDIF !}
+
+ IF ( .not. mixedphase ) THEN !{
+ IF ( zhmlr(mgs) < 0.0 .and. chmlrr(mgs) /= 0.0 .and. ibinhmlr == 0 ) THEN !{
+ tmp = qx(mgs,lh)/cx(mgs,lh)
+! zhmlrr(mgs) = Min(0.0, (xdn(mgs,lh)/xdn(mgs,lr))**2 * &
+! & g1x(mgs,lh)*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhmlr(mgs) - tmp**2 * chmlrr(mgs) ) )
+
+! IF ( zhmlrr(mgs) >= 0. ) THEN
+! zhmlrr(mgs) = (xdn(mgs,lh)/xdn(mgs,lr))**2 * zhmlr(mgs)
+! ENDIF
+ IF ( (shedalp + alpha(mgs,lh))*xdia(mgs,lh,1) < sheddiam ) THEN ! if not shedding small drops, then use alpha of graupel
+ z1 = g1x(mgs,lh)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhmlr(mgs)**2/ chmlrr(mgs) )
+ ELSE ! assume drops are shed off, so use either alpha for shedding or graupel alpha, whichever gives the lower g-factor (i.e., larger alpha)
+ z1 = Min(g1x(mgs,lh),g1shr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhmlr(mgs)**2/ chmlrr(mgs) )
+ ENDIF
+ zhmlrr(mgs) = z1
+! z1 = g1mlr*(rho0(mgs)/(xdn(mgs,lr)))**2*( qhmlr(mgs)**2/ chmlrr(mgs) )
+! zhmlrr(mgs) = Max( z1, zhmlrr(mgs))
+ ENDIF !}
+
+
+! zhshrr(mgs) = (xdn(mgs,lh)/xdn(mgs,lr))**2 * zhshr(mgs)
+
+ IF ( lhl > 1 .and. qhlmlr(mgs) /= 0 .and. ibinhlmlr == 0) THEN
+ tmp = qx(mgs,lhl)/cx(mgs,lhl)
+! zhlmlrr(mgs) = Min(0.0, (xdn(mgs,lhl)/xdn(mgs,lr))**2 * &
+! & g1x(mgs,lhl)*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlmlr(mgs) - tmp**2 * chlmlrr(mgs) ) )
+
+! IF ( zhlmlrr(mgs) >= 0. ) THEN ! should be negative, if not, then use alternate calculation
+! zhlmlrr(mgs) = (xdn(mgs,lhl)/xdn(mgs,lr))**2 * zhlmlr(mgs)
+! ENDIF
+
+ IF ( (shedalp + alpha(mgs,lhl))*xdia(mgs,lhl,1) < sheddiam ) THEN ! if not shedding small drops, then use alpha of hail
+ z1 = g1x(mgs,lhl)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlmlr(mgs)**2/ chlmlrr(mgs) )
+ ELSE ! assume drops are shed off, so use either alpha for shedding or graupel alpha, whichever gives the lower g-factor (i.e., larger alpha)
+ z1 = Min(g1x(mgs,lhl),g1shr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlmlr(mgs)**2/ chlmlrr(mgs) )
+! z1 = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlmlr(mgs)**2/ chlmlrr(mgs) )
+ ENDIF
+ zhlmlrr(mgs) = z1
+
+! z1 = g1mlr*(rho0(mgs)/(xdn(mgs,lr)))**2*( qhlmlr(mgs)**2/ chlmlrr(mgs) )
+! zhlmlrr(mgs) = Max( z1, zhlmlrr(mgs))
+! zhlmlr(mgs) =
+! zhlshrr(mgs) = (xdn(mgs,lhl)/xdn(mgs,lr))**2 * zhlshr(mgs)
+ ENDIF
+
+ ENDIF ! }
+
+ IF ( qx(mgs,lr) .gt. qxmin(lr) .and. cx(mgs,lr) .gt. 0.0 ) THEN
+
+ tmp = qx(mgs,lr)/cx(mgs,lr)
+ g1 = g1x(mgs,lr) ! 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+
+
+ IF ( qracw(mgs) > 0.0 .and. cx(mgs,lr) > 0.0 ) THEN
+ zracw(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*tmp * qracw(mgs) )
+ ENDIF
+
+ IF ( cracr(mgs) > 0.0 .and. cx(mgs,lr) > 0.0 ) THEN
+ zracr(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*1000.))**2*( tmp**2 * cracr(mgs) )
+ ENDIF
+
+ qtmp = qrcev(mgs)
+ ctmp = crcev(mgs)
+
+! IF ( .false. .or. iferwisventr == 2 ) THEN
+! zrcev(mgs) = Min(0.0, (12./(pii*xdn(mgs,lr)))*xdia(mgs,lr,1)**3*fvce(mgs)*rwcap(mgs)*rwventz(mgs) )
+! ELSE
+ zrcev(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( 2.*( tmp ) * qtmp - tmp**2 * ctmp )
+
+
+ IF ( iferwisventr == 2 ) THEN
+ vent1 = Min(0.0, (12./(pii*xdn(mgs,lr)))*xdia(mgs,lr,1)**3*fvce(mgs)*rwcap(mgs)*rwventz(mgs))
+ zrcev(mgs) = Max( zrcev(mgs), vent1 )
+ ENDIF
+! IF ( ny == 2 .and. igs(mgs) == 20 ) THEN
+! write(0,*) 'k,zrcevold,new,maxdep : ',kgs(mgs),zrcev(mgs),vent1,-zxmxd(mgs,lr),alpha(mgs,lr),cx(mgs,lr)
+! ENDIF
+
- 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)
+! ENDIF
+ zrcev(mgs) = Max( zrcev(mgs), -zxmxd(mgs,lr) )
- end do
+ IF ( qhacr(mgs) > 0.0 ) THEN
+ zrach(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2* &
+ & ( 2.*( qx(mgs,lr)/cx(mgs,lr)) * qhacr(mgs) - tmp**2 * chacr(mgs) )
+ zrach(mgs) = Min( zrach(mgs), zxmxd(mgs,lr) )
+
+ ENDIF
- ENDIF ! lhl
+ IF ( lhl > 1 .and. qhlacr(mgs) > 0.0 ) THEN
+ zrachl(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2* &
+ & ( 2.*( qx(mgs,lr)/cx(mgs,lr)) * qhlacr(mgs) - tmp**2 * chlacr(mgs) )
+ zrachl(mgs) = Min( zrachl(mgs), zxmxd(mgs,lr) )
+ ENDIF
- ENDIF ! warmonly
-!
-! Liquid water on snow and graupel
-!
+
+ ENDIF
- vhmlr(:) = 0.0
- vhlmlr(:) = 0.0
- vhfzh(:) = 0.0
- vhlfzhl(:) = 0.0
+ pzrwi(mgs) = zrcnw(mgs) + zracw(mgs) + zracr(mgs) &
+ & + Max( 0.,zrcev(mgs) ) &
+ & - (1-il5(mgs))*zsmlrr(mgs) &
+ & - zsshrr(mgs) &
+ & - (1-il5(mgs))*zhmlrr(mgs) &
+ & - zhshrr(mgs) &
+ & - (1-il5(mgs))*zhlmlrr(mgs) &
+ & - zhlshrr(mgs)
- 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
+ pzrwd(mgs) = 0.0 &
+ & + Min(0.,zrcev(mgs) ) &
+ & - zrach(mgs) &
+ & - zrachl(mgs) &
+ & - zrfrz(mgs) &
+ & - il5(mgs)*(ziacr(mgs) )
- ENDIF ! mixedphase
+
+ IF ( zx(mgs,lr) + dtp*(pzrwi(mgs)+pzrwd(mgs)) <= 0.0 &
+ .and. qx(mgs,lr) > qxmin(lr) ) THEN
+ pzrwd(mgs) = -zx(mgs,lr)*dtpinv - pzrwi(mgs)
+ ENDIF
+
+ ENDDO
+
+ ENDIF
@@ -18678,6 +22439,33 @@ subroutine nssl_2mom_gs &
! > + rho0(mgs)*qhshr(mgs)/xdn(mgs,lh) !xdn(mgs,lr)
! ENDIF
+ IF ( lzh > 1 .and. qx(mgs,lh) > qxmin(lh) ) THEN
+! Calculate change in reflectivity due to density changes
+
+ xdn_new = rho0(mgs)*(qx(mgs,lh) + dtp*(pqhwi(mgs) + pqhwd(mgs) ))/ &
+ & (vx(mgs,lh) + dtp*(pvhwi(mgs) + pvhwd(mgs)) )
+
+ IF ( mixedphase ) THEN
+ IF ( qxw(mgs,lh) .gt. 0.0 ) THEN
+ dnmx = xdnmx(lr)
+ ELSE
+ dnmx = xdnmx(lh)
+ ENDIF
+ ELSE
+ dnmx = xdnmx(lh)
+ ENDIF
+
+ xdn_new = Max( Min( xdn_new, dnmx ), xdnmn(lh) )
+
+ drhodt = (xdn_new - xdn(mgs,lh))*dtpinv
+
+ zhwdn(mgs) = -2.*g1x(mgs,lh)*(rho0(mgs)*qx(mgs,lh)*6.*pii )**2/(cx(mgs,lh)*xdn(mgs,lh)**3)*drhodt
+
+ pzhwi(mgs) = pzhwi(mgs) + Max(0.0, zhwdn(mgs))
+ pzhwd(mgs) = pzhwd(mgs) + Min(0.0, zhwdn(mgs))
+
+
+ ENDIF
IF ( .false. .and. ny .eq. 2 .and. kgs(mgs) .eq. 9 .and. igs(mgs) .eq. 19 ) THEN
write(iunit,*)
@@ -18760,6 +22548,32 @@ subroutine nssl_2mom_gs &
& + rho0(mgs)*(1-il5(mgs))*vhlmlr(mgs)/xdn(mgs,lhl) &
& + vhlshdr(mgs) - vhlsoak(mgs)
+ IF ( lzhl > 1 .and. qx(mgs,lhl) > qxmin(lhl) ) THEN
+! Calculate change in reflectivity due to density changes
+
+ xdn_new = rho0(mgs)*(qx(mgs,lhl) + dtp*(pqhli(mgs) + pqhld(mgs) ))/ &
+ & (vx(mgs,lhl) + dtp*(pvhli(mgs) + pvhld(mgs)) )
+
+ IF ( mixedphase ) THEN
+ IF ( qxw(mgs,lhl) .gt. 0.0 ) THEN
+ dnmx = xdnmx(lr)
+ ELSE
+ dnmx = xdnmx(lhl)
+ ENDIF
+ ELSE
+ dnmx = xdnmx(lhl)
+ ENDIF
+ xdn_new = Max( Min( xdn_new, dnmx ), xdnmn(lhl) )
+
+ drhodt = (xdn_new - xdn(mgs,lhl))*dtpinv
+
+ zhldn(mgs) = -2.*g1x(mgs,lhl)*(rho0(mgs)*qx(mgs,lhl)*6.*pii )**2/(cx(mgs,lhl)*xdn(mgs,lhl)**3)*drhodt
+
+ pzhli(mgs) = pzhli(mgs) + Max(0.0, zhldn(mgs))
+ pzhld(mgs) = pzhld(mgs) + Min(0.0, zhldn(mgs))
+
+
+ ENDIF
ENDDO
@@ -18989,7 +22803,7 @@ subroutine nssl_2mom_gs &
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,*) qssbv(mgs)
write(iunit,*) Min(0.0, qscev(mgs))
write(iunit,*) -qsmul(mgs)
!
@@ -19061,33 +22875,37 @@ subroutine nssl_2mom_gs &
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)) &
+ & (qhmlr(mgs)+ &
+ & qsmlr(mgs)+qhlmlr(mgs)) & !+qhmlh(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) &
+ & +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))
+ & (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) &
+ & + qssbv(mgs) + qhsbv(mgs) &
+ & + qhlsbv(mgs) &
& +il5(mgs)*(qiint(mgs))
pvap(mgs) = &
- & qrcev(mgs) + qhcev(mgs) + qscev(mgs) + qhlcev(mgs)
+ & qrcev(mgs) + qhcev(mgs) + qscev(mgs) + qhlcev(mgs) + qfcev(mgs)
pevap(mgs) = &
- & Min(0.0,qrcev(mgs)) + Min(0.0,qhcev(mgs)) + Min(0.0,qscev(mgs)) + Min(0.0,qhlcev(mgs))
+ & Min(0.0,qrcev(mgs)) + Min(0.0,qhcev(mgs)) + Min(0.0,qscev(mgs)) + Min(0.0,qhlcev(mgs)) &
+ + Min(0.0,qfcev(mgs))
! NOTE: pdep is the deposition part only
pdep(mgs) = &
& il5(mgs)*( &
@@ -19115,7 +22933,7 @@ subroutine nssl_2mom_gs &
& + qidpv(mgs) + qisbv(mgs) ) &
& +il5(mgs)*(qiint(mgs))
pvap(mgs) = &
- & qrcev(mgs) + qhcev(mgs) + qhlcev(mgs) ! + qscev(mgs)
+ & qrcev(mgs) + qhcev(mgs) + qhlcev(mgs) + qfcev(mgs)
ELSE
pfrz(mgs) = 0.0
psub(mgs) = 0.0
@@ -19143,6 +22961,8 @@ subroutine nssl_2mom_gs &
!
!
do mgs = 1,ngscnt
+
+
qwvp(mgs) = qwvp(mgs) + &
& dtp*(pqwvi(mgs)+pqwvd(mgs))
qx(mgs,lc) = qx(mgs,lc) + &
@@ -19155,6 +22975,7 @@ subroutine nssl_2mom_gs &
& 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))
@@ -19224,12 +23045,32 @@ subroutine nssl_2mom_gs &
+ ENDIF
+ ENDIF
+ IF ( ipconc .ge. 6 ) THEN
+ IF ( lzr .gt. 1 ) THEN
+ zx(mgs,lr) = zx(mgs,lr) + &
+ & dtp*(pzrwi(mgs)+pzrwd(mgs))
+ ENDIF
+ IF ( lzs .gt. 1 ) THEN
+ zx(mgs,ls) = zx(mgs,ls) + &
+ & dtp*(pzswi(mgs)+pzswd(mgs))
+ ENDIF
+ IF ( lzh .gt. 1 ) THEN
+ zx(mgs,lh) = zx(mgs,lh) + &
+ & dtp*(pzhwi(mgs)+pzhwd(mgs))
+ ENDIF
+ IF ( lzhl .gt. 1 ) THEN
+ zx(mgs,lhl) = zx(mgs,lhl) + &
+ & dtp*(pzhli(mgs)+pzhld(mgs))
+! IF ( pchli(mgs) .ne. 0. .or. pchld(mgs) .ne. 0 ) THEN
+! write(0,*) 'dr: cx,pchli,pchld = ', cx(mgs,lhl),pchli(mgs),pchld(mgs), igs(mgs),kgs(mgs)
+! ENDIF
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))
@@ -19471,41 +23312,9 @@ subroutine nssl_2mom_gs &
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) ) &
@@ -19744,7 +23553,6 @@ subroutine nssl_2mom_gs &
-
if (ndebug .gt. 0 ) write(0,*) 'gs 11'
do mgs = 1,ngscnt
@@ -19775,6 +23583,29 @@ subroutine nssl_2mom_gs &
ENDIF
+
+
+
+!
+! 6th moments
+!
+
+ IF ( ipconc .ge. 6 ) THEN
+ DO il = lr,lhab
+ IF ( lz(il) .gt. 1 ) THEN
+ IF ( lf > 1 .and. il == lf ) THEN
+ lfsave(mgs,3) = an(igs(mgs),jy,kgs(mgs),lz(il))
+ lfsave(mgs,4) = zx(mgs,il)
+ ENDIF
+
+ an(igs(mgs),jy,kgs(mgs),lz(il)) = zx(mgs,il) + &
+ & min( an(igs(mgs),jy,kgs(mgs),lz(il)), 0.0 )
+ zx(mgs,il) = an(igs(mgs),jy,kgs(mgs),lz(il))
+
+ ENDIF
+ ENDDO
+
+ ENDIF
!
end do
!
@@ -19839,7 +23670,455 @@ subroutine nssl_2mom_gs &
ENDIF !}
ENDDO ! mgs
+ ELSE ! } { is three-moment, so have to adjust Z if size is too large
+ IF ( il == lr .and. imurain == 3 ) THEN ! { { RAIN
+
+! rdmx =
+! rdmn =
+
+ DO mgs = 1,ngscnt
+
+
+ IF ( iresetmoments == 1 .or. iresetmoments == il ) THEN
+ IF ( zx(mgs,lr) <= zxmin ) THEN
+ qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il)
+ qx(mgs,lr) = 0.0
+ cx(mgs,lr) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),lr)
+ an(igs(mgs),jgs,kgs(mgs),lr) = qx(mgs,lr)
+ an(igs(mgs),jgs,kgs(mgs),ln(lr)) = cx(mgs,lr)
+ ELSEIF ( cx(mgs,lr) <= cxmin ) THEN
+ qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il)
+ zx(mgs,lr) = 0.0
+ qx(mgs,lr) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),lr)
+ an(igs(mgs),jgs,kgs(mgs),lr) = qx(mgs,lr)
+ an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr)
+ ENDIF
+ ENDIF
+
+ IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN
+
+ xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr)))
+ 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
+
+ IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN
+! have mass and reflectivity but no concentration, so set concentration, using default alpha
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ z = zx(mgs,il)
+ qr = qx(mgs,il)
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*xdn(mgs,lr)**2)
+! an(igs(mgs),jgs,kgs(mgs),ln(il)) = zx(mgs,il)
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > 0.0 ) THEN
+! have mass and concentration but no reflectivity, so set reflectivity, using default alpha
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+ zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(xdn(mgs,lr)**2*chw)
+ an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr)
+
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN
+! How did this happen?
+ ! set values according to dBZ of -10, or Z = 0.1
+! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2
+ zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ z = zx(mgs,il)
+ qr = qx(mgs,il)
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*1000.*1000)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ ENDIF
+
+ IF ( zx(mgs,lr) > 0.0 ) THEN
+ xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(1000.*cx(mgs,lr))
+ vr = xv(mgs,lr)
+ qr = qx(mgs,lr)
+ nrx = cx(mgs,lr)
+ z = zx(mgs,lr)
+
+! xv = (db(1,kz)*a(1,1,kz,lr))**2/(a(1,1,kz,lnr))
+! rd = z*(pi/6.*1000.)**2/xv
+
+! determine shape parameter alpha by iteration
+ IF ( z .gt. 0.0 ) THEN
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
+ DO i = 1,20
+ IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT
+ alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) )
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
+ alp = Max( rnumin, Min( rnumax, alp ) )
+ ENDDO
+
+! check for artificial breakup (rain larger than allowed max size)
+ IF ( xv(mgs,il) .gt. xvmx(il) .or. (ioldlimiter == 2 .and. xv(mgs,il) .gt. xvmx(il)/8.) ) THEN
+ tmp = cx(mgs,il)
+! write(0,*) 'MY limiter: xv: ',xv(mgs,il), xv(mgs,il)/(xvmx(il)/8.)
+! STOP
+ IF ( ioldlimiter == 2 ) THEN ! MY-style active breakup
+ x = (6.*rho0(mgs)*qx(mgs,il)/(pi*xdn(mgs,il)*cx(mgs,il)))**(1./3.)
+ x1 = Max(0.0e-3, x - 3.0e-3)
+ x2 = Max(0.5, x/6.0e-3)
+ x3 = x2**3
+ cx(mgs,il) = cx(mgs,il)*Max((1.+2.222e3*x1**2), x3)
+ xv(mgs,il) = xv(mgs,il)/Max((1.+2.222e3*x1**2), x3)
+ ELSE ! simple cutoff
+ xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) )
+ xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+ cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
+ ENDIF
+ !xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+ !cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
+
+
+ IF ( tmp < cx(mgs,il) ) THEN ! breakup
+
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) )
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ vr = xv(mgs,lr)
+ qr = qx(mgs,lr)
+ nrx = cx(mgs,lr)
+ z = zx(mgs,lr)
+
+
+! determine shape parameter alpha by iteration
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
+ DO i = 1,20
+ IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT
+ alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) )
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
+ alp = Max( rnumin, Min( rnumax, alp ) )
+ ENDDO
+
+
+ ENDIF
+ ENDIF
+
+!
+! Check whether the shape parameter is at or less than the minimum, and if it is, reset the
+! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N)
+!
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ IF ( .true. .and. (alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax) ) THEN
+
+ IF ( rescale_high_alpha .and. alp >= rnumax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(1./(xdn(mgs,il)))**2
+ an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il)
+
+ ELSEIF ( rescale_low_alphar .and. alp <= rnumin ) THEN
+ z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2)
+ zx(mgs,il) = z
+ an(igs(mgs),jy,kgs(mgs),lz(il)) = zx(mgs,il)
+ ENDIF
+ ENDIF
+
+
+
+ ENDIF
+ ENDIF
+
+ ENDIF
+
+ ENDDO
+! CALL cld_cpu('Z-MOMENT-1r')
+
+
+ ELSEIF ( il == lh .or. il == lhl .or. il == lf .or. (il == lr .and. imurain == 1 )) THEN ! } { Rain, GRAUPEL OR HAIL
+
+
+
+ DO mgs = 1,ngscnt
+
+ IF ( lf > 1 .and. il == lf ) THEN
+ lfsave(mgs,5) = an(igs(mgs),jy,kgs(mgs),ln(il))
+ lfsave(mgs,6) = cx(mgs,il)
+ ENDIF
+
+ IF ( il == lhl .and. lnhlf > 1 ) THEN
+ IF ( cx(mgs,lhl) > cxmin ) THEN
+ frac = chxf(mgs,lhl)/cx(mgs,lhl)
+ ELSE
+ frac = 0.0
+ ENDIF
+ ENDIF
+
+ IF ( il == lh .and. lnhf > 1 ) THEN
+ IF ( cx(mgs,lh) > cxmin ) THEN
+ frach = chxf(mgs,lh)/cx(mgs,lh)
+ ELSE
+ frach = 0.0
+ ENDIF
+ ENDIF
+
+
+
+ IF ( iresetmoments == 1 .or. iresetmoments == il .or. iresetmoments == -1 ) THEN ! { .or. qx(mgs,il) <= qxmin(il)
+ IF ( zx(mgs,il) <= zxmin ) THEN ! .and. qx(mgs,il) > 0.05e-3
+!! write(91,*) 'zx=0; qx,cx = ',1000.*qx(mgs,il),cx(mgs,il)
+ qx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ ELSEIF ( iresetmoments == -1 .and. qx(mgs,il) < qxmin(il) ) THEN
+ zx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ ELSEIF ( cx(mgs,il) <= cxmin .and. iresetmoments /= -1 ) THEN ! .and. qx(mgs,il) > 0.05e-3
+ qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il)
+ zx(mgs,il) = 0.0
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+ ENDIF
+ ELSE
+ IF ( zx(mgs,il) < 0.0 ) THEN ! .and. qx(mgs,il) > 0.05e-3
+ zx(mgs,il) = 0.0
+ ENDIF
+ ENDIF !}
+
+
+ IF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= cxmin ) THEN
+ zx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+ ENDIF
+
+ IF ( qx(mgs,il) .gt. qxmin(il) ) THEN !{
+
+ xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(1.0e-9,cx(mgs,il)))
+ xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+
+ IF ( xv(mgs,il) .lt. xvmn(il) ) THEN
+ xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) )
+ xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+ cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
+ ENDIF
+
+ IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN !{
+! have mass and reflectivity but no concentration, so set concentration, using default alpha
+ g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+ z = zx(mgs,il)
+ qr = qx(mgs,il)
+! cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(z*(pi*xdn(mgs,il))**2)
+
+
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > 0.0 ) THEN
+! have mass and concentration but no reflectivity, so set reflectivity, using default alpha
+! g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+! & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+! zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw
+! zx(mgs,il) = Min(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(chw*(pi*xdn(mgs,il))**2) )
+ g1 = (6.0 + alphamax)*(5.0 + alphamax)*(4.0 + alphamax)/ &
+ & ((3.0 + alphamax)*(2.0 + alphamax)*(1.0 + alphamax))
+ zx(mgs,il) = Max(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(chw*(pi*xdn(mgs,il))**2) )
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN
+! How did this happen?
+ ! set values according to dBZ of -10, or Z = 0.1
+! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2
+
+! write(0,*) 'GS: moment problem! il,c,z,q = ',il,cx(mgs,il),zx(mgs,il),qx(mgs,il)
+
+ zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+ z = zx(mgs,il)
+ qr = qx(mgs,il)
+! cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(z*(pi*xdn(mgs,il))**2)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+
+! write(0,*) 'GS: moment problem! reset il,c,z,q = ',il,cx(mgs,il),zx(mgs,il),qx(mgs,il)
+
+ ELSE
+ ! have all valid moments, so find shape parameter
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+ z = zx(mgs,il)
+
+ IF ( zx(mgs,il) .gt. 0. ) THEN !{
+
+! rdi = z*(pi/6.*1000.)**2*chw/((rho0(mgs)*qr)**2)
+ rdi = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2)
+
+! alp = 1.e18*(6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/
+! : ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
+ alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
+! print*,'kz, alp, alpha(mgs,il) = ',kz,alp,alpha(mgs,il),rdi,z,xv
+ DO i = 1,10
+! IF ( 100.*Abs(alp - alpha(mgs,il))/(Abs(alpha(mgs,il))+1.e-5) .lt. 1. ) EXIT
+ IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT
+ alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) )
+! alp = 1.e18*(6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/
+! : ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
+ alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
+! print*,'i,alp = ',i,alp
+ alp = Max( alphamin, Min( alphamax, alp ) )
+ ENDDO
+
+
+! check for artificial breakup (graupel/hail larger than allowed max size)
+ IF ( xv(mgs,il) .gt. xvmx(il) ) THEN !{
+ tmp = cx(mgs,il)
+
+
+ xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) )
+ xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+ cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
+ IF ( tmp < cx(mgs,il) ) THEN ! breakup
+ g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2)
+ zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) )
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+ z = zx(mgs,il)
+
+ rdi = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2)
+ alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
+ DO i = 1,10
+ IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT
+ alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) )
+ alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
+ alp = Max( alphamin, Min( alphamax, alp ) )
+ ENDDO
+
+
+ ENDIF
+ ENDIF !}
+
+!
+! Check whether the shape parameter is at or less than the minimum, and if it is, reset the
+! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N)
+!
+ g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+
+ IF ( ( lrescalelow(il) .or. rescale_high_alpha ) .and. &
+ & ( alpha(mgs,il) <= alphamin .or. alp == alphamin .or. alp == alphamax ) ) THEN !{
+
+ IF ( rescale_high_alpha .and. alp >= alphamax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2
+ an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il)
+
+ ELSEIF ( lrescalelow(il) .and. alp <= alphamin .and. .not. (il == lh .and. icvhl2h > 0 ) .and. &
+ .not. ( il == lr .and. .not. rescale_low_alphar ) ) THEN ! alpha = alphamin, so reset Z to prevent growth in C
+
+ wtest = .false.
+ IF ( irescalerainopt == 0 ) THEN
+ wtest = .false.
+ ELSEIF ( irescalerainopt == 1 ) THEN
+ wtest = qx(mgs,lc) > qxmin(lc)
+ ELSEIF ( irescalerainopt == 2 ) THEN
+ wtest = qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < rescale_wthresh
+ ELSEIF ( irescalerainopt == 3 ) THEN
+ wtest = temcg(mgs) > rescale_tempthresh .and. qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < rescale_wthresh
+ ENDIF
+
+ IF ( il == lr .and. ( wtest .or. .not. rescale_low_alphar ) ) THEN
+ ! certain situations where rain number is adjusted instead of Z. Helps avoid rain being 'zapped' by autoconverted
+ ! drops (i.e., favor preserving Z when alpha tries to go negative)
+ chw = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2 ! g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z1
+ cx(mgs,il) = chw
+ an(igs(mgs),jy,kgs(mgs),ln(il)) = chw
+ ELSE
+ ! Usual resetting of reflectivity moment to force consisntency between Q, N, Z, and alpha when alpha = alphamin
+ z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw
+ z = z1*(6./(pi*xdn(mgs,il)))**2
+ zx(mgs,il) = z
+ an(igs(mgs),jy,kgs(mgs),lz(il)) = z
+ ENDIF
+
+! z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw
+! z = z1*(6./(pi*xdn(mgs,il)))**2
+! zx(mgs,il) = z
+! an(igs(mgs),jy,kgs(mgs),lz(il)) = z
+ ENDIF
+
+ ENDIF !}
+
+
+ ENDIF !}
+
+
+ ENDIF ! !}
+
+
+ ENDIF !}
+
+ IF ( lzr > 1 ) THEN
+ alpha2d(igs(mgs),kgs(mgs),1) = Max(alphamin, Min(alphamax, alpha(mgs,lr) ))
+ ENDIF
+ IF ( lzh > 1 ) THEN
+ alpha2d(igs(mgs),kgs(mgs),2) = Max(alphamin, Min(alphamax, alpha(mgs,lh) ))
+ ENDIF
+ IF ( lzhl > 1 ) THEN
+ alpha2d(igs(mgs),kgs(mgs),3) = Max(alphamin, Min(alphamax, alpha(mgs,lhl) ))
+ ENDIF
+
+ IF ( il == lhl .and. lnhlf > 1 ) THEN
+ ! update chxf in case cx has changed
+ chxf(mgs,lhl) = frac*cx(mgs,lhl)
+ ENDIF
+ IF ( il == lh .and. lnhf > 1 ) THEN
+ ! update chxf in case cx has changed
+ chxf(mgs,lh) = frach*cx(mgs,lh)
+ ENDIF
+
+
+! IF ( lf > 0 .and. il == lf .and. kgs(mgs) <= 20 .and. ( cx(mgs,lf) + dtp*( pcfwi(mgs) + pcfwd(mgs) ) > 200. .or. cx(mgs,lf) > 400. )) THEN
+! write(0,*) 'ix,jy, kz, cf = ',igs(mgs)+ixbeg,jy+jybeg,kgs(mgs), an(igs(mgs),jy,kgs(mgs),ln(lf)),lfsave(mgs,5),lfsave(mgs,6)
+! write(0,*) 'qold,qxold,zold,zxold = ',lfsave(mgs,1),lfsave(mgs,2),lfsave(mgs,3),lfsave(mgs,4)
+! write(0,*) 'cf_new,pcfwi,pcfwd = ',cx(mgs,lf),cx(mgs,lf) + dtp*( pcfwi(mgs) + pcfwd(mgs) ),pcfwi(mgs) + pcfwd(mgs)
+!
+! ENDIF
+
+ ENDDO ! mgs
+
+! CALL cld_cpu('Z-DELABK')
+
+
+! CALL cld_cpu('Z-DELABK')
+
+
+
+
+ ENDIF ! } }
+
ENDIF ! }}
ENDIF ! }
diff --git a/physics/mp_nssl.F90 b/physics/mp_nssl.F90
index 59ca877fa..e79376709 100644
--- a/physics/mp_nssl.F90
+++ b/physics/mp_nssl.F90
@@ -26,13 +26,13 @@ module mp_nssl
!! \htmlinclude mp_nssl_init.html
!!
subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, &
- mpirank, mpiroot, &
- con_g, con_rd, con_cp, con_rv, &
- con_t0c, con_cliq, con_csol, con_eps, &
- imp_physics, imp_physics_nssl, &
- nssl_cccn, nssl_alphah, nssl_alphahl, &
- nssl_alphar, nssl_ehw0, nssl_ehlw0, &
- nssl_ccn_on, nssl_hail_on, nssl_invertccn )
+ mpirank, mpiroot, &
+ con_g, con_rd, con_cp, con_rv, &
+ con_t0c, con_cliq, con_csol, con_eps, &
+ imp_physics, imp_physics_nssl, &
+ nssl_cccn, nssl_alphah, nssl_alphahl, &
+ nssl_alphar, nssl_ehw0, nssl_ehlw0, &
+ nssl_ccn_on, nssl_hail_on, nssl_invertccn, nssl_3moment )
use module_mp_nssl_2mom, only: nssl_2mom_init, nssl_2mom_init_const
@@ -53,13 +53,13 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, &
integer, intent(in) :: imp_physics
integer, intent(in) :: imp_physics_nssl
real(kind_phys), intent(in) :: nssl_cccn, nssl_alphah, nssl_alphahl
- real(kind_phys), intent(in) :: nssl_alphar, nssl_ehw0, nssl_ehlw0
- logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_invertccn
+ real(kind_phys), intent(in) :: nssl_alphar, nssl_ehw0, nssl_ehlw0
+ logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_invertccn, nssl_3moment
! Local variables: dimensions used in nssl_init
integer :: ims,ime, jms,jme, kms,kme, nx, nz, i,k
real :: nssl_params(20)
- integer :: ihailv
+ integer :: ihailv,ipc
! Initialize the CCPP error handling variables
@@ -104,9 +104,9 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, &
nssl_params(:) = 0.0
- nssl_params(1) = nssl_cccn
- nssl_params(2) = nssl_alphah
- nssl_params(3) = nssl_alphahl
+ ! nssl_params(1) = nssl_cccn ! use direct interface instead
+ ! nssl_params(2) = nssl_alphah ! use direct interface instead
+ ! nssl_params(3) = nssl_alphahl ! use direct interface instead
nssl_params(4) = 4.e5 ! nssl_cnoh -- not used for 2-moment
nssl_params(5) = 4.e4 ! nssl_cnohl-- not used for 2-moment
nssl_params(6) = 4.e5 ! nssl_cnor-- not used for 2-moment
@@ -114,10 +114,6 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, &
nssl_params(8) = 500. ! nssl_rho_qh
nssl_params(9) = 800. ! nssl_rho_qhl
nssl_params(10) = 100. ! nssl_rho_qs
- nssl_params(11) = 0 ! nssl_ipelec_tmp
- nssl_params(12) = 11 ! nssl_isaund
- nssl_params(13) = 0 ! 1= turn on cccna; 0 = turn off
- nssl_params(15) = nssl_alphar
nssl_qccn = nssl_cccn/1.225
! if (mpirank==mpiroot) then
@@ -129,10 +125,21 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, &
ELSE
ihailv = -1
ENDIF
+
+ IF ( nssl_3moment ) THEN
+ ipc = 8
+ ELSE
+ ipc = 5
+ ENDIF
! write(0,*) 'call nssl_2mom_init'
- CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0, &
- ihvol=ihailv,nssl_ehw0=nssl_ehw0,nssl_ehlw0=nssl_ehlw0,errmsg=errmsg,errflg=errflg,myrank=mpirank,mpiroot=mpiroot)
+ CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=ipc,mixphase=0, &
+ ihvol=ihailv,nssl_ehw0=nssl_ehw0,nssl_ehlw0=nssl_ehlw0,errmsg=errmsg, &
+ nssl_alphar=nssl_alphar, &
+ nssl_alphah=nssl_alphah, &
+ nssl_alphahl=nssl_alphahl, &
+ nssl_cccn=nssl_cccn, &
+ errflg=errflg,myrank=mpirank,mpiroot=mpiroot)
! For restart runs, the init is done here
if (restart) then
@@ -158,17 +165,18 @@ end subroutine mp_nssl_init
!! \htmlinclude mp_nssl_run.html
!!
subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, &
-! spechum, cccn, qc, qr, qi, qs, qh, qhl, &
- spechum, cccn, cccna, qc, qr, qi, qs, qh, qhl, &
- ccw, crw, cci, csw, chw, chl, vh, vhl, &
- tgrs, prslk, prsl, phii, omega, dtp, &
- prcp, rain, graupel, ice, snow, sr, &
+ spechum, cccn, cccna, qc, qr, qi, qs, qh, qhl, &
+ ccw, crw, cci, csw, chw, chl, vh, vhl, &
+ zrw, zhw, zhl, &
+ tgrs, prslk, prsl, phii, omega, dtp, &
+ prcp, rain, graupel, ice, snow, sr, &
refl_10cm, do_radar_ref, first_time_step, restart, &
- re_cloud, re_ice, re_snow, re_rain, &
- nleffr, nieffr, nseffr, nreffr, &
- imp_physics, convert_dry_rho, &
- imp_physics_nssl, nssl_ccn_on, &
- nssl_hail_on, nssl_invertccn, ntccn, ntccna, &
+ re_cloud, re_ice, re_snow, re_rain, &
+ nleffr, nieffr, nseffr, nreffr, &
+ imp_physics, convert_dry_rho, &
+ imp_physics_nssl, nssl_ccn_on, &
+ nssl_hail_on, nssl_invertccn, nssl_3moment, &
+ ntccn, ntccna, &
errflg, errmsg)
use module_mp_nssl_2mom, only: calcnfromq, na
@@ -197,6 +205,9 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, &
real(kind_phys), intent(inout) :: chl(:,:) !(1:ncol,1:nlev) hail number
real(kind_phys), intent(inout) :: vh (:,:) !(1:ncol,1:nlev) graupel volume
real(kind_phys), intent(inout) :: vhl(:,:) !(1:ncol,1:nlev) hail volume
+ real(kind_phys), intent(inout) :: zrw(:,:) !(1:ncol,1:nlev) rain reflectivity
+ real(kind_phys), intent(inout) :: zhw(:,:) !(1:ncol,1:nlev) graupel reflectivity
+ real(kind_phys), intent(inout) :: zhl(:,:) !(1:ncol,1:nlev) hail reflectivity
! State variables and timestep information
real(kind_phys), intent(inout) :: tgrs (:,:) !(1:ncol,1:nlev)
real(kind_phys), intent(in ) :: prsl (:,:) !(1:ncol,1:nlev)
@@ -223,7 +234,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, &
integer, intent(in) :: nleffr, nieffr, nseffr, nreffr
integer, intent(in) :: imp_physics
integer, intent(in) :: imp_physics_nssl
- logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_invertccn
+ logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_invertccn, nssl_3moment
integer, intent(in) :: ntccn, ntccna
integer, intent(out) :: errflg
@@ -256,6 +267,9 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, &
! create temporaries for hail in case it does not exist
!real(kind_phys) :: chl_mp(1:ncol,1:nlev) !< kg-1 (number mixing ratio)
real(kind_phys) :: vhl_mp(1:ncol,1:nlev) !< m3 kg-1 (volume mixing ratio)
+ real(kind_phys) :: zrw_mp(1:ncol,1:nlev) !< m6 kg-1 (reflectivity)
+ real(kind_phys) :: zhw_mp(1:ncol,1:nlev) !< m6 kg-1 (reflectivity)
+ real(kind_phys) :: zhl_mp(1:ncol,1:nlev) !< m6 kg-1 (reflectivity)
! Vertical velocity and level width
real(kind_phys) :: w(1:ncol,1:nlev) !< m s-1
real(kind_phys) :: dz(1:ncol,1:nlev) !< m
@@ -342,10 +356,17 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, &
ns_mp = csw/(1.0_kind_phys-spechum)
nh_mp = chw/(1.0_kind_phys-spechum)
vh_mp = vh/(1.0_kind_phys-spechum)
+ IF ( nssl_3moment ) THEN
+ zrw_mp = zrw/(1.0_kind_phys-spechum)
+ zhw_mp = zhw/(1.0_kind_phys-spechum)
+ ENDIF
IF ( nssl_hail_on ) THEN
qhl_mp = qhl/(1.0_kind_phys-spechum)
nhl_mp = chl/(1.0_kind_phys-spechum)
vhl_mp = vhl/(1.0_kind_phys-spechum)
+ IF ( nssl_3moment ) THEN
+ zhl_mp = zhl/(1.0_kind_phys-spechum)
+ ENDIF
ENDIF
ELSE
! qv_mp = spechum ! /(1.0_kind_phys-spechum)
@@ -361,10 +382,18 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, &
ni_mp = cci
ns_mp = csw
nh_mp = chw
+ vh_mp = vh
+ IF ( nssl_3moment ) THEN
+ zrw_mp = zrw
+ zhw_mp = zhw
+ ENDIF
IF ( nssl_hail_on ) THEN
qhl_mp = qhl ! /(1.0_kind_phys-spechum)
nhl_mp = chl
vhl_mp = vhl
+ IF ( nssl_3moment ) THEN
+ zhl_mp = zhl
+ ENDIF
ENDIF
ENDIF
@@ -572,110 +601,114 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, &
IF ( nssl_ccn_on ) THEN
-
- CALL nssl_2mom_driver( &
- ITIMESTEP=itimestep, &
- ! TH=th, &
- tt=tgrs, &
- QV=qv_mp, &
- QC=qc_mp, &
- QR=qr_mp, &
- QI=qi_mp, &
- QS=qs_mp, &
- QH=qh_mp, &
- QHL=qhl_mp, &
- CCW=nc_mp, &
- CRW=nr_mp, &
- CCI=ni_mp, &
- CSW=ns_mp, &
- CHW=nh_mp, &
- CHL=nhl_mp, &
- VHW=vh_mp, &
- VHL=vhl_mp, &
- cn=cn_mp, &
-! cna=cna_mp, f_cna=( ntccna > 0 ), & ! for future use
- cna=cna_mp, f_cna=.false. , &
- PII=prslk, &
- P=prsl, &
- W=w, &
- DZ=dz, &
- DTP=dtptmp, &
- DN=rho, &
- rainnc=xrain_mp, rainncv=xdelta_rain_mp, &
- snownc=xsnow_mp, snowncv=xdelta_snow_mp, &
-! icenc=ice_mp, icencv=delta_ice_mp, &
- GRPLNC=xgraupel_mp, GRPLNCV=xdelta_graupel_mp, sr=sr, &
- dbz = refl_10cm, &
-! nssl_progn=.false., &
- diagflag = diagflag, &
- errmsg=errmsg,errflg=errflg, &
- re_cloud=re_cloud_mp, &
- re_ice=re_ice_mp, &
- re_snow=re_snow_mp, &
- re_rain=re_rain_mp, &
- has_reqc=has_reqc, & ! ala G. Thompson
- has_reqi=has_reqi, & ! ala G. Thompson
- has_reqs=has_reqs, & ! ala G. Thompson
- has_reqr=has_reqr, &
+ CALL nssl_2mom_driver( &
+ ITIMESTEP=itimestep, &
+ ! TH=th, &
+ tt=tgrs, &
+ QV=qv_mp, &
+ QC=qc_mp, &
+ QR=qr_mp, &
+ QI=qi_mp, &
+ QS=qs_mp, &
+ QH=qh_mp, &
+ QHL=qhl_mp, &
+ CCW=nc_mp, &
+ CRW=nr_mp, &
+ CCI=ni_mp, &
+ CSW=ns_mp, &
+ CHW=nh_mp, &
+ CHL=nhl_mp, &
+ VHW=vh_mp, &
+ VHL=vhl_mp, &
+ cn=cn_mp, &
+ ZRW=zrw_mp, &
+ ZHW=zhw_mp, &
+ ZHL=zhl_mp, &
+! cna=cna_mp, f_cna=( ntccna > 0 ), & ! for future use
+ cna=cna_mp, f_cna=.false. , &
+ PII=prslk, &
+ P=prsl, &
+ W=w, &
+ DZ=dz, &
+ DTP=dtptmp, &
+ DN=rho, &
+ rainnc=xrain_mp, rainncv=xdelta_rain_mp, &
+ snownc=xsnow_mp, snowncv=xdelta_snow_mp, &
+ GRPLNC=xgraupel_mp, &
+ GRPLNCV=xdelta_graupel_mp, &
+ sr=sr, &
+ dbz = refl_10cm, &
+ diagflag = diagflag, &
+ errmsg=errmsg,errflg=errflg, &
+ re_cloud=re_cloud_mp, &
+ re_ice=re_ice_mp, &
+ re_snow=re_snow_mp, &
+ re_rain=re_rain_mp, &
+ has_reqc=has_reqc, &
+ has_reqi=has_reqi, &
+ has_reqs=has_reqs, &
+ has_reqr=has_reqr, &
IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde, &
IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme, &
ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte &
)
-
ELSE
- CALL nssl_2mom_driver( &
- ITIMESTEP=itimestep, &
- ! TH=th, &
- tt=tgrs, &
- QV=qv_mp, &
- QC=qc_mp, &
- QR=qr_mp, &
- QI=qi_mp, &
- QS=qs_mp, &
- QH=qh_mp, &
- QHL=qhl_mp, &
-! CCW=qnc_mp, &
- CCW=nc_mp, &
- CRW=nr_mp, &
- CCI=ni_mp, &
- CSW=ns_mp, &
- CHW=nh_mp, &
- CHL=nhl_mp, &
- VHW=vh_mp, &
- VHL=vhl_mp, &
- ! cn=cccn, &
- PII=prslk, &
- P=prsl, &
- W=w, &
- DZ=dz, &
- DTP=dtptmp, &
- DN=rho, &
- rainnc=xrain_mp, rainncv=xdelta_rain_mp, &
- snownc=xsnow_mp, snowncv=xdelta_snow_mp, &
-! icenc=ice_mp, icencv=delta_ice_mp, &
- GRPLNC=xgraupel_mp, GRPLNCV=xdelta_graupel_mp, sr=sr, &
- dbz = refl_10cm, &
-! nssl_progn=.false., &
- diagflag = diagflag, &
- errmsg=errmsg,errflg=errflg, &
- re_cloud=re_cloud_mp, &
- re_ice=re_ice_mp, &
- re_snow=re_snow_mp, &
- re_rain=re_rain_mp, &
- has_reqc=has_reqc, & ! ala G. Thompson
- has_reqi=has_reqi, & ! ala G. Thompson
- has_reqs=has_reqs, & ! ala G. Thompson
- has_reqr=has_reqr, &
+ CALL nssl_2mom_driver( &
+ ITIMESTEP=itimestep, &
+ ! TH=th, &
+ tt=tgrs, &
+ QV=qv_mp, &
+ QC=qc_mp, &
+ QR=qr_mp, &
+ QI=qi_mp, &
+ QS=qs_mp, &
+ QH=qh_mp, &
+ QHL=qhl_mp, &
+ CCW=nc_mp, &
+ CRW=nr_mp, &
+ CCI=ni_mp, &
+ CSW=ns_mp, &
+ CHW=nh_mp, &
+ CHL=nhl_mp, &
+ VHW=vh_mp, &
+ VHL=vhl_mp, &
+! cn=cn_mp, &
+ ZRW=zrw_mp, &
+ ZHW=zhw_mp, &
+ ZHL=zhl_mp, &
+! cna=cna_mp, f_cna=( ntccna > 0 ), & ! for future use
+! cna=cna_mp, f_cna=.false. , &
+ PII=prslk, &
+ P=prsl, &
+ W=w, &
+ DZ=dz, &
+ DTP=dtptmp, &
+ DN=rho, &
+ rainnc=xrain_mp, rainncv=xdelta_rain_mp, &
+ snownc=xsnow_mp, snowncv=xdelta_snow_mp, &
+ GRPLNC=xgraupel_mp, &
+ GRPLNCV=xdelta_graupel_mp, &
+ sr=sr, &
+ dbz = refl_10cm, &
+ diagflag = diagflag, &
+ errmsg=errmsg,errflg=errflg, &
+ re_cloud=re_cloud_mp, &
+ re_ice=re_ice_mp, &
+ re_snow=re_snow_mp, &
+ re_rain=re_rain_mp, &
+ has_reqc=has_reqc, &
+ has_reqi=has_reqi, &
+ has_reqs=has_reqs, &
+ has_reqr=has_reqr, &
IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde, &
IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme, &
ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte &
)
-
+
ENDIF
-
-
+
DO i = 1,ncol
delta_rain_mp(i) = delta_rain_mp(i) + xdelta_rain_mp(i) ! this is liquid equivalent of all precip
delta_graupel_mp(i) = delta_graupel_mp(i) + xdelta_graupel_mp(i) ! this is liquid equivalent of graupel
@@ -684,7 +717,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, &
ENDDO
ENDDO
-
+
ENDIF
@@ -750,10 +783,17 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, &
csw = ns_mp/(1.0_kind_phys+qv_mp)
chw = nh_mp/(1.0_kind_phys+qv_mp)
vh = vh_mp/(1.0_kind_phys+qv_mp)
+ IF ( nssl_3moment ) THEN
+ zrw = zrw_mp/(1.0_kind_phys+qv_mp)
+ zhw = zhw_mp/(1.0_kind_phys+qv_mp)
+ ENDIF
IF ( nssl_hail_on ) THEN
qhl = qhl_mp/(1.0_kind_phys+qv_mp)
chl = nhl_mp/(1.0_kind_phys+qv_mp)
vhl = vhl_mp/(1.0_kind_phys+qv_mp)
+ IF ( nssl_3moment ) THEN
+ zhl = zhl_mp/(1.0_kind_phys+qv_mp)
+ ENDIF
ENDIF
ELSE
! spechum = qv_mp ! /(1.0_kind_phys+qv_mp)
@@ -770,10 +810,17 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, &
csw = ns_mp
chw = nh_mp
vh = vh_mp
+ IF ( nssl_3moment ) THEN
+ zrw = zrw_mp
+ zhw = zhw_mp
+ ENDIF
IF ( nssl_hail_on ) THEN
qhl = qhl_mp ! /(1.0_kind_phys+qv_mp)
chl = nhl_mp
vhl = vhl_mp
+ IF ( nssl_3moment ) THEN
+ zhl = zhl_mp
+ ENDIF
ENDIF
ENDIF
diff --git a/physics/mp_nssl.meta b/physics/mp_nssl.meta
index 6bbf92c73..337b1ab76 100644
--- a/physics/mp_nssl.meta
+++ b/physics/mp_nssl.meta
@@ -210,6 +210,13 @@
dimensions = ()
type = logical
intent = in
+[nssl_3moment]
+ standard_name = nssl_3moment
+ long_name = 3-moment activation flag in NSSL microphysics scheme
+ units = flag
+ dimensions = ()
+ type = logical
+ intent = in
########################################################################
[ccpp-arg-table]
name = mp_nssl_run
@@ -387,6 +394,30 @@
type = real
kind = kind_phys
intent = inout
+[zrw]
+ standard_name = reflectivity_of_rain_of_new_state
+ long_name = rain reflectivity
+ units = m6 kg-1
+ dimensions = (horizontal_loop_extent,vertical_layer_dimension)
+ type = real
+ kind = kind_phys
+ intent = inout
+[zhw]
+ standard_name = reflectivity_of_graupel_of_new_state
+ long_name = graupel reflectivity
+ units = m6 kg-1
+ dimensions = (horizontal_loop_extent,vertical_layer_dimension)
+ type = real
+ kind = kind_phys
+ intent = inout
+[zhl]
+ standard_name = reflectivity_of_hail_of_new_state
+ long_name = hail reflectivity
+ units = m6 kg-1
+ dimensions = (horizontal_loop_extent,vertical_layer_dimension)
+ type = real
+ kind = kind_phys
+ intent = inout
[tgrs]
standard_name = air_temperature_of_new_state
long_name = model layer mean temperature
@@ -614,6 +645,13 @@
dimensions = ()
type = logical
intent = in
+[nssl_3moment]
+ standard_name = nssl_3moment
+ long_name = 3-moment activation flag in NSSL microphysics scheme
+ units = flag
+ dimensions = ()
+ type = logical
+ intent = in
[ntccn]
standard_name = index_of_cloud_condensation_nuclei_number_concentration_in_tracer_concentration_array
long_name = tracer index for cloud condensation nuclei number concentration
|