CCPP SciDoc v7.0.0  v7.0.0
Common Community Physics Package Developed at DTC
 
Loading...
Searching...
No Matches
module_mp_nssl_2mom.F90
1
2
3
4
5
6
7
8
9
10!---------------------------------------------------------------------
11! code snapshot: "Sep 22 2023" at "22:01:53"
12!---------------------------------------------------------------------
13!---------------------------------------------------------------------
14! IMPORTANT: Best results are attained using the 5th-order WENO (Weighted Essentially Non-Oscillatory) advection option (4) for scalars:
15! moist_adv_opt = 4,
16! scalar_adv_opt = 4, (can also use option 3, which is WENO without the positive definite filter)
17! The WENO-5 scheme provides a 5th-order (horizontal and vertical) adaptive weighting of components that
18! better preserve monotinicity in strong gradients. The standard 5th-order formulation is prone to undershoots
19! (negative values) of mass and number concentrations at cloud edges. The WENO scheme helps
20! to prevent undershoots and results in less noise at cloud and reflectivity boundaries. This is particularly
21! useful for multi-moment schemes to preserve relationships between mass and number concentration. An option is also available
22! for WENO-5 advection of momentum, but this can result in excessive damping of poorly-resolved features. For both scalar and momentum
23! the steps 1 and 2 of the Runge-Kutta time integration use standare 5th-order advection, and the WENO-5 is applied on the 3rd (final)
24! RK step. Option 3 applies the WENO-5, and option 4 adds the positive definite filter (as also used in option 1).
25!
26! WENO references: Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223; Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118;
27!
56!
57! Possible parameters to adjust:
58!
59! ccn : base cloud condensation nuclei concentration (use namelist.input value "nssl_cccn")
60! alphah, alphahl : Size distribution shape parameters for graupel (h) and hail (hl)
61! infall : changes sedimentation options to see effects (see below)
62!
63! lightning model references:
64!
65! Fierro, A. O., E.R. Mansell, C. Ziegler and D. R. MacGorman 2013: The
66! implementation of an explicit charging and discharge lightning scheme
67! within the WRF-ARW model: Benchmark simulations of a continental squall line, a
68! tropical cyclone and a winter storm. Monthly Weather Review, Volume 141, 2390-2415
69!
70! Mansell et al. 2005: Charge structure and lightning sensitivity in a simulated
71! multicell thunderstorm. J. Geophys. Res., 110, D12101, doi:10.1029/2004JD005287
72!
73! Note: Some parameters below apply to unreleased features.
74!
75!
76!---------------------------------------------------------------------
77! Apr. 2023
78! - Update to 3-moment for rain, graupel, and hail
79! - Change default graupel/hail fall speeds to icdx/icdxhl=6 (Milbrandt & Morrison 2013)
80! and also set default ehw0=0.9 and ehlw0=0.9 to compensate for lower fall speeds.
81! - Change default hail conversion to ihlcnh=-1, and then =1 for 2-mom or =3 for 3-mom,
82! using wet growth diameter to convert large graupel
83!---------------------------------------------------------------------
84! Sept. 2021:
85! Fixes:
86! Restored previous formulation of snow reflectivity, as it was realized that the last change incorrectly assumed a fixed
87! density independent of size. Generally lower snow reflectivity values as a result (no effect on microphysics)
88! Other:
89! Generic fall speed coeffecients (axx,bxx) to accomodate future frozen drops category (no effect)
90! Reordered collection coefficients (dab1lh) to be consistent (no effect)
91! Switched to full calculation of rain number loss via collection by graupel (chacr; to be consisted with collection by hail) (minor effects)
92!---------------------------------------------------------------------
93! April 2021:
94! Fixes:
95! Fall speed air density factor limited to air density of 0.05 (for very high model top) to mitigate excessive fall speeds
96! Fixed issue of spurious creation of large concentrations of very small droplets and transient large condensation (also increased minimum droplet size)
97! Fixed issue of negligible "seed" values of graupel from Bigg freezing at relatively high temperatures (thanks to S. Lasher-Trapp)
98! Minor bug fix in effective radius calculation of snow. (thanks to T. Iguchi)
99! Updates:
100! Enabled regeneration of CCN by droplet evaporation and background restore (default time constant of 3600s)
101! Updated the routine that handles single-moment variables on the first time step. This sets a higher threshold for meaningful mixing ratios and sets a more realistic droplet concentration (also activating CCN as needed).
102! Enabled radar reflectivity from cloud ice (new formulation) ( idbzci = 1 )
103! Added internal option for ice crystal nucleation by DeMott et al. (2010, PNAS) (inucopt=4)
104! Allow greater fraction of hail to melt in one time step
105! Reduced minimum number concentration from 1e-4 to 1e-8 (based on CAPS input)
106! Added internal namelist for easier access to internal variables for development/testing and easier setup for ensemble microphysics diversity
107! (namelist read is disabled by default)
108! Increased resolution of lookup table for incomplete gamma functions
109!
110!---------------------------------------------------------------------
111! Sept. 2019:
112! Bug fixes:
113! - Effective radius calculation was only done at history times. Now every time step (though should be just before radiation is called)
114! - Snow reflectivity: Previous "fix" was incorrect and yields snow dBZ that is too low. Reverted to old version which was correct
115! - Incorrectly updated a state value in the reflectivity code. (Could cause small differences if reflectivity is not calculated)
116! Updates:
117! - Added code hints to use the "axtra2d" array to communicate rates from the microphysics routine into any 3d arrays that are passed in to the driver.
118! - Graupel and hail drag coefficients are returned from fall speed subroutine to use in ventilation coeffs. for consistency (minor change)
119! - Added (compile) option flag to turn on diagnosis of cloud droplet shape parameter based on number concentration
120! - Added (compile) option flag icracr to turn off rain self-collection
121! - Added compile options 'depfac' and 'meltfac' to adjust deposition/sublimation and melting (not freezing) rates of graupel/hail by a constant factor (for experimentation). Default value is 1.0
122! - Put limit on snow volume (2 cm) in aggregation rate
123!---------------------------------------------------------------------
124! WRF 4.0 update:
125! Major:
126! Fixed excessive sublimation that could occur in very strong downdrafts (3.9.1.1 update)
127!
128! Minor:
129! icefallopt=3 : New ice crystal fall speed that has faster speeds for small ice particles. Main effect
130! is on anvil clouds to help them decay a bit faster. Old behavior can be recovered with icefallopt=1
131! Cosmetic: removed stray single quotes because some preprocessors complain about unclosed quotes even in comments
132!
133!---------------------------------------------------------------------
134! WRF 3.9.1.1 update:
135!
136! Added a check on overdepletion of ice by sublimation, which could sometimes result in water supersaturation
137! Bug fix: setting of t7 used 'dn' instead of 'dn1' (Thanks to Chunxi Zhang)
138!
139!---------------------------------------------------------------------
140! WRF 3.9 updates:
141!
142! 2-moment scheme now creates number concentration tendencies from cumulus scheme mass mixing ratio rates
143! Renamed internal gamma function routine from 'gamma' to 'gamma_sp' to avoid name conflicts
144! Restored older settings that allow snow aggregation starting at T > -25C
145! Adjusted Meyers number of activated nuclei by the local air density to compensate for using data at surface
146! Minor updates to rain-ice crystal and hail-rain collection efficiencies
147!
148!
149! Reduced minimum mean snow diameter from 100 microns to 10 microns
150!
151!---------------------------------------------------------------------
152! WRF 3.8 updates:
153! Fixed issue with reflectivity conservation for graupel melting into rain. Rain number concentrations were too low,
154! resulting in excessive reflectivity of a couple dBZ
155! Changed default value of iusewetgraupel to 1 (turns off diagnostic meltwater on graupel for reflectivity)
156! Apply a 70 m/s fall speed limit for sedimentation
157! Changed vapor ice nucleation to Meyers-Ferrier method (original scheme)
158! New method for Bigg freezing (ibiggopt=2)
159! Reduced snow aggregration efficiency and restricted aggregation to higher temperatures (assuming dendrites and mechanical aggregation)
160! Increased maximum graupel-droplet collection efficiency when hail is turned off (nssl_2momg)
161! Updates for compatibility with WRF-NMM
162! Added calculation of hail number concentration in calcnfromq (creates number concentration from mixing ratio
163! when starting from an analysis). And fixed error in graupel intercept
164! Bug fix in snow fall speeds
165! Further fix in snow reflectivity
166! Use diameter of maximum mass rather than mean diamter when checking maximum size
167! Helped performance in sedimentation with flag "do_accurate_sedimentation" to control recalculation of fall speeds when
168! more than one sub-time step is needed (often happens with large time steps and small dz near the ground):
169! = .true. : recalculates fall speed after each substep (more accurate)
170! = .false. : (default) reuses fall speeds calculated on the first substep (typical for most schemes), theoretically could cause an occasional glitch, but none seen in practice
171! Increased maximum mean droplet radius from 40 to 60 microns, which alleviates spurious number concentration increases at low CCN concentration.
172! Removed a duplicate factor from hail reflectivity that was causing a loss of about 6 dBZ (since WRF 3.5).
173!
174!---------------------------------------------------------------------
175
176
177
182 IMPLICIT NONE
183
184 public nssl_2mom_driver
185 public nssl_2mom_init
187 public calc_eff_radius
188 public calcnfromq
191 private delbk, delabk
192 private gammadp
193
194 logical, private :: cleardiag = .false.
195 PRIVATE
196
197#if ( WRF_CHEM == 1 )
198 integer, parameter :: wrfchem_flag = 1
199#else
200 integer, parameter :: wrfchem_flag = 0
201#endif
202
203 LOGICAL, PRIVATE:: is_aerosol_aware = .false.
204
205 logical, private :: turn_on_cin = .false.
206
207 integer, private :: eqtset = 1 ! Flag for use with cm1 to use alternate equation set (changes latent heating rates)
208 ! value of > 2 invokes the equivalent version of eqtset=2 that applies updates to both theta and Pi.
209 double precision, parameter, public :: zscale = 1.0d0 ! 1.000e-10
210 double precision, parameter, public :: zscaleinv = 1.0d0/zscale ! 1.000e-10
211
212
213 real, parameter :: warmonly = 0.0 ! testing parameter, set to 1.0 to reduce to warm-rain physics (ice variables stay zero)
214
215 logical, parameter :: lwsm6 = .false. ! act like wsm6 for some single moment interactions
216
217! some constants from WSM6
218 real, parameter :: dimax = 500.e-6 ! limited maximum value for the cloud-ice diamter
219 real, parameter :: roqimax = 2.08e22*dimax**8
220
221! Params for dbz:
222 integer :: iuseferrier = 1 ! =1: use dry graupel only from Ferrier 1994; = 0: Use Smith (wet graupel)
223 integer :: idbzci = 1
224 integer :: iusewetgraupel = 1 ! =1 to turn on use of QHW for graupel reflectivity (only for ZVDM -- mixedphase)
225 ! =2 turn on for graupel density less than 300. only
226 integer :: iusewethail = 0 ! =1 to turn on use of QHW for graupel reflectivity (only for ZVDM -- mixedphase)
227 integer :: iusewetsnow = 0 ! =1 to turn on diagnosed bright band; =2 'old' snow reflectivity (dry), =3 'old' snow dbz + brightband
228! microphysics
229
230 real, private :: rho_qr = 1000., cnor = 8.0e5 ! cnor is set in namelist!! rain params
231 real, private :: rho_qs = 100., cnos = 3.0e6 ! set in namelist!! snow params
232 real, private :: rho_qh = 500., cnoh = 4.0e5 ! set in namelist!! graupel params
233 real, private :: rho_qhl= 800., cnohl = 4.0e4 ! set in namelist!! hail params
234
235 real, private :: hdnmn = 170.0 ! minimum graupel density (for variable density graupel)
236 real, private :: hldnmn = 500.0 ! minimum hail density (for variable density hail)
237
238 real :: cnohmn = 1.e-2 ! minimum intercept for 2-moment graupel (alphah < 0.5)
239 real :: cnohlmn = 1.e-2 ! minimum intercept for 2-moment hail (alphahl < 0.5)
240
241! Autoconversion parameters
242
243 real , private :: qcmincwrn = 2.0e-3 ! qc threshold for autonconversion (LFO; for 10ICE use qminrncw for ircnw != 5)
244 real , private :: cwdiap = 20.0e-6 ! threshold diameter of cloud drops (Ferrier 1994 autoconversion)
245 real , private :: cwdisp = 0.15 ! assume droplet dispersion parameter (can be 0.3 for maritime)
246 real , private :: ccn = 0.6e+09 ! set in namelist!! Central plains CCN value
247 real , private :: ccnuf = 0 ! set in namelist!! Central plains CCN value
248 real , public :: qccn, qccnuf ! ccn "mixing ratio"
249 real , private :: old_qccn = -1.0
250 integer, private :: iauttim = 1 ! 10-ice rain delay flag
251 real , private :: auttim = 300. ! 10-ice rain delay time
252 real , private :: qcwmntim = 1.0e-5 ! 10-ice rain delay min qc for time accrual
253
254#if (NMM_CORE == 1)
255! NMM WRF core does not have special boundary conditions for CCN, therefore set invertccn to true
256 logical, parameter :: invertccn = .true. ! =true for base state of ccn=0, =false for ccn initialized in the base state
257#else
258 logical, private :: invertccn = .false. ! =true for base state of ccn=0, =false for ccn initialized in the base state
259#endif
260 logical :: switchccn = .false.
261 real :: old_cccn = -1.0
262 logical :: restoreccn = .true. ! whether or not to nudge CCN back to base state (qccn) (only applies if CCNA is NOT predicted)
263 real :: ccntimeconst = 3600. ! time constant for CCN restore (either for CCNA or when restoreccn = true)
264 real, private :: restoreccnfrac = 1.0 ! fraction of evaporated droplets that restore CCN
265 real :: ufccntimeconst = 6.*3600. ! time constant for UFCCN decay (Blossey et al. 2018)
266 real :: ufbackground = 0.1e9 ! background ccnuf value (Blossey et al.)
267 logical :: decayufccn = .false.
268 integer :: i_uf_or_ccn = 0 ! 0 = ship adds UF; 1 = treat UF as regular ccn (add to qccn)
269
270! sedimentation flags
271! itfall -> 0 = 1st order fallout (other options removed)
272! iscfall, infall -> fallout options for charge and number concentration, respectively
273! 1 = mass-weighted fall speed; 2 = number-weighted fallspeed.
274 integer, private :: itfall = 0
275 integer, private :: iscfall = 1
276 integer, private :: irfall = -1
277 integer, private :: isfall = 2 ! default limit with method II (more restrictive)
278 logical, private :: do_accurate_sedimentation = .true. ! if true, recalculate fall speeds on sub time steps; (more expensive)
279 ! if false, reuse fall speeds on multiple steps (can have a noticeable speedup)
280 ! Mainly is an issue for small dz near the surface.
281 integer, private :: interval_sedi_vt = 2 ! interval for recalculating Vt in sedimentation subloop (only when do_accurate_sedimentation = .true.)
282 integer, private :: infall = 4 ! 0 -> uses number-wgt for N; NO correction applied (results in excessive size sorting)
283 ! 1 -> uses mass-weighted fallspeed for N ALWAYS
284 ! 2 -> uses number-wgt for N and mass-weighted correction for N (Method II in Mansell, 2010 JAS)
285 ! 3 -> uses number-wgt for N and Z-weighted correction for N (Method I in Mansell, 2010 JAS)
286 ! 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)
287 ! 5 -> uses number-wgt for N and uses average of N-wgt and q-wgt instead of Max.
288 integer :: imydiagalpha = 0 ! apply MY diagnostic shape parameter for fall speeds (1=for fall speed only; 2=also for microphysics rates)
289 real, private :: rainfallfac = 1.0 ! factor to adjust rain fall speed (single moment only)
290 real, private :: icefallfac = 1.5 ! factor to adjust ice fall speed
291 real, private :: snowfallfac = 1.25 ! factor to adjust snow fall speed
292 real, private :: graupelfallfac = 1.0 ! factor to adjust graupel fall speed
293 real, private :: hailfallfac = 1.0 ! factor to adjust hail fall speed
294 integer, private :: icefallopt = 3 ! 1= default, 2 = Ferrier ice fall speed; 3 = adjusted Ferrier (slightly high Vt)
295 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.
296 ! 6= Milbrandt and Morrison (2013) density-based fall speed
297 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.
298 ! 6= Milbrandt and Morrison (2013) density-based fall speed
299 real :: axh = 75.7149, bxh = 0.5
300 real :: axf = 75.7149, bxf = 0.5
301 real :: axhl = 206.984, bxhl = 0.6384
302 real , private :: cdhmin = 0.45, cdhmax = 0.8 ! defaults for graupel (icdx=4)
303 real , private :: cdhdnmin = 500., cdhdnmax = 800.0 ! defaults for graupel (icdx=4)
304 real , private :: cdhlmin = 0.45, cdhlmax = 0.6 ! defaults for hail (icdx=4)
305 real , private :: cdhldnmin = 500., cdhldnmax = 800.0 ! defaults for hail (icdx=4)
306 real , private :: vtmaxsed = 70. ! Limit on fall speed (m/s, all moments) for sedimentation calculations. Not applied to fall speeds for microphysical rates
307
308 integer :: rssflg = 1 ! Rain size-sorting allowed (1, default), or disallowed (0). If 0, sets N and Z-weighted fall speeds to q-weighted value
309 integer :: sssflg = 1 ! As above but for snow
310 integer :: hssflg = 1 ! As above but for graupel
311 integer :: hlssflg = 1 ! As above but for hail
312
313! input flags
314
315 integer, private :: ndebug = -1, ncdebug = 0
316 integer, private :: ipconc = 5
317 integer, private :: inucopt = 0
318 integer, private :: ichaff = 0
319 integer, parameter :: ilimit = 0
320
321 real, private :: constccw = -1.
322
323 real, private :: cimn = 1.0e3, cimx = 1.0e6
324
325 real , private :: rhofrz = 900 ! density of freezing drops
326 real , private :: ifrzg = 1.0 ! fraction of frozen drops (Bigg freezing) going to graupel. 1=freeze all rain to graupel, 0=freeze all to hail
327 real , private :: ifiacrg = 1.0 ! fraction of frozen drops (3-component freezing qiacr) going to graupel. 1=freeze all rain to graupel, 0=freeze all to hail
328 real , private :: ifrzs = 1.0 ! fraction of small frozen drops going to snow. 1=freeze rain to snow, 0=freeze to cloud ice
329 real , private :: ffrzs = 0.0 ! fraction of other initiated cloud ice going to snow. 1=freeze rain to snow, 0=freeze to cloud ice
330 real , private :: f2h = 1.0 ! fraction of cloud ice conversion going to graupel (vs. frozen drops). For testing
331 integer, private :: irwfrz = 1 ! compute total rain that can freeze (checks heat budget)
332 integer, private :: irimtim = 0 ! future use
333! integer, private :: infdo = 1 ! 1 = calculate number-weighted fall speeds
334
335 integer, private :: irimdenopt = 1 ! = 1 for default Heymsfield and Pflaum (1985); = 2 for experimental Cober and List (1993); = 3 Macklin
336 real , private :: rimc1 = 300.0, rimc2 = 0.44 ! rime density coeff. and power (Default Heymsfield and Pflaum, 1985)
337 real , private :: rimc3 = 170.0 ! minimum rime density
338 real :: rimc4 = 900.0 ! maximum rime density
339 real , private :: rimtim = 120.0 ! cut-off rime time (10ICE)
340 real , private :: eqtot = 1.0e-9 ! threshold for mass budget reporting
341 real, private :: rimdenvwgt = 0.0 ! weight (0-1) given to number-weighted fall speed when calculating rime density
342
343 integer, private :: ireadmic = 0
344
345 integer, private :: idiagnosecnu = 0 ! =1 to diagnose cnu based on Chandrakar et al. 2016 data; =2 for Geoffroy et al. (2010, ACP)
346 integer, private :: iccwflg = 1 ! sets max size of first droplets in parcel to 4 micron radius (in two-moment liquid)
347 ! (first nucleation is done with a KW sat. adj. step)
348 integer, private :: issfilt = 0 ! flag to turn on filtering of supersaturation field
349 integer, private :: icnuclimit = 0 ! limit droplet nucleation based on Konwar et al. (2012) and Chandrakar et al. (2016)
350 integer, private :: irenuc = 2 ! =1 to always allow renucleation of droplets within the cloud (do no use, obsolete)
351 ! =2 renucleation following Twomey/Cohard&Pinty
352 ! =7 New renucleation that requires prediction of the number of activated nuclei
353 ! i.e., not only at cloud base
354 integer, private :: irenuc3d = 0 ! =1 to include horizontal gradient in renucleation of droplets within the cloud
355 real :: renucfrac = 0.0 ! = 0 : cnuc = cwccn
356 ! = 1 : cnuc = actual available CCN
357 ! otherwise cnuc = cwccn*(1. - renufrac) + ccnc(1:ngscnt)*renucfrac
358 real :: ssf2kmax = 10. ! max value for ssf**cck in irenuc=4 or 5
359 real , private :: cck = 0.6 ! exponent in Twomey expression
360 real , private :: ciintmx = 1.0e6 ! limit on ice concentration from primary nucleation
361
362 real , private :: cwccn ! , cwmasn,cwmasx
363 real , private :: ccwmx
364
365 integer, private :: idocw = 1, idorw = 1, idoci = 1, idoir = 1, idoip = 1, idosw = 1
366 integer, private :: idogl = 1, idogm = 1, idogh = 1, idofw = 1, idohw = 1, idohl = 1
367! integer, private :: ido(3:14) = / 12*1 /
368
369
370! 0,2, 5.00e-10, 1, 0, 0, 0 : itype1,itype2,cimas0,icfn,ihrn,ibfc,iacr
371 integer, private :: itype1 = 0, itype2 = 2 ! controls Hallett-Mossop process
372 integer, private :: in_freeze_rain_first = 0 ! =1 use IN to freezed rain drops (if none, then freeze droplets)
373 integer, private :: icenucopt = 1 ! =1 Meyers/Ferrier primary ice nucleation; =2 Thompson/Cooper, =3 Phillips (Meyers/Demott), =4 DeMott (2010)
374 real, private :: naer = 1.0e6 ! background large aerosol conc. for DeMott
375 integer, private :: icfn = 2 ! contact freezing: 0 = off; 1 = hack (ok for single moment); 2 = full Cotton/Meyers version
376 integer, private :: ihrn = 0 ! Hobbs-Rangno ice multiplication (Ferrier, 1994; use in 10-ice only)
377 integer, private :: ibfc = 1 ! Flag to use Bigg freezing on droplets (0 = off (uses alternate freezing), 1 = on)
378 real, private :: cwfrz2snowfrac = 0.0 ! fraction of freezing droplet mass to send to snow
379 real, private :: cwfrz2snowratio = 5. ! Assumed number of frozen droplets in a cluster
380 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
381 integer, private :: iacr = 2 ! Flag for drop contact freezing with crytals
382 ! (0=off; 1=drops > 500micron diameter; 2 = > 300micron)
383 integer, private :: icrcev = 1 ! 1 = old crcev; 2 = crcev scaled by vtrain ratio (num/mass); 3 = set to zero
384 integer, private :: icracr = 1 ! Flag to turn rain self-collection on/off (=0 to turn off)
385 integer, private :: icracrthresh = 1 ! For rain self-coll. thresh. use: 1 = mean diam of 2mm; 2 = rain median volume diam of 1.9mm
386 integer, private :: ibfr = 2 ! Flag for Bigg freezing conversion of freezing drops to graupel
387 ! (1=min graupel size is vr1mm; 2=use min size of dfrz, 5= as for 2 and apply dbz conservation)
388 integer, private :: ibiggopt = 2 ! 1 = old Bigg; 2 = experimental Bigg (only for imurain = 1, however)
389 integer :: ibiggsmallrain = 0 ! 1 = When rain is too small, freeze none to graupel and send all to snow (experimental)
390 integer, private :: iacrsize = 5 ! assumed min size of drops freezing by capture
391 ! 1: > 500 micron diam
392 ! 2: > 300 micron
393 ! 3: > 40 micron
394 ! 4: all sizes
395 ! 5: > 150 micron (only for imurain = 1)
396 real , private :: cimas0 = 6.62e-11 ! default mass of Hallett-Mossop crystals
397 ! 6.62e-11kg results in half the diam. (60 microns) of old default value of 5.0e-10
398 real , private :: cimas1 = 6.88e-13 ! default mass of new ice crystals
399 real , private :: splintermass = 6.88e-13
400 real , private :: cfnfac = 0.1 ! Hack factor that goes with icfn=1
401 integer, private :: iscni = 4 ! default option for ice crystal aggregation/conversion to snow
402 real , private :: fscni = 1.0 ! factor for calculating cscni
403 logical, private :: imeyers5 = .false. ! .false.=off, true=on for Meyers ice nucleation for temp > -5 C
404 real , private :: dmincw = 15.0e-6 ! minimum droplet diameter for collection for iehw=3
405 integer, private :: iehw = 1 ! 0 -> ehw=ehw0; 1 -> old ehw; 2 -> test ehw with Mason table data
406 integer, private :: iefw = 1 ! 0 -> ehw=ehw0; 1 -> old ehw; 2 -> test ehw with Mason table data
407 integer, private :: iehlw = 1 ! 0 -> ehlw=ehlw0; 1 -> old ehlw; 2 -> test ehlw with Mason table data
408 ! For ehw/ehlw = 1, ehw0/ehlw0 act as maximum limit on collection efficiency (defaults are 1.0)
409 integer, private :: ierw = 1 ! for single-moment rain (LFO/Z)
410 integer, private :: iehr0c = 0 ! 0 -> no collection for T > 0C; 1 -> turn on collection/shedding for T > 0C
411 integer, private :: iehlr0c = 0 ! 0 -> no collection for T > 0C; 1 -> turn on collection/shedding for T > 0C
412 real , private :: ehw0 = 0.9 ! constant or max assumed graupel-droplet collection efficiency
413 real , private :: erw0 = 1.0 ! constant assumed rain-droplet collection efficiency
414 real , private :: ehlw0 = 0.9 ! constant or max assumed hail-droplet collection efficiency
415 real , private :: efw0 = 0.5 ! constant or max assumed graupel-droplet collection efficiency
416 real :: ehr0 = 1.0 ! constant or max assumed graupel-rain collection efficiency
417 real :: efr0 = 1.0 ! constant or max assumed graupel-rain collection efficiency
418 real :: ehlr0 = 1.0 ! constant or max assumed hail-rain collection efficiency
419 real , private :: exwmindiam = 0.0 ! minimum diameter of droplets for riming. If set > 0, will exclude that fraction of mass/number from accretion (idea from Furtado and Field 2017 JAS but also Fierro and Mansell 2017)
420
421
422 real , private :: esilfo0 = 1.0 ! factor for LFO collection efficiency of snow for cloud ice.
423 real , private :: ehslfo0 = 1.0 ! factor for LFO collection efficiency of hail/graupel for snow.
424
425 integer, private :: ircnw = 5 ! single-moment warm-rain autoconversion option. 5= Ferrier 1994.
426 real , private :: qminrncw = 2.0e-3 ! qc threshold for rain autoconversion (NA for ircnw=5)
427
428 integer, private :: iqcinit = 2 ! For ZVDxx schemes, flag to choose which way to initialize droplets
429 ! 1 = Soong-Ogura adjustment
430 ! 2 = Saturation adjustment to value of ssmxinit
431 ! 3 = KW adjustment
432
433 real , private :: ssmxinit = 0.4 ! saturation percentage to adjust down to for initial cloud
434 ! formation (ZVDxx scheme only)
435
436 real , private :: ewfac = 1.0 ! hack factor applied to graupel and hail collection eff. for droplets
437 real , private :: eii0 = 0.1 ,eii1 = 0.1 ! graupel-crystal coll. eff. parameters: eii0*exp(eii1*min(temcg(mgs),0.0))
438 ! set eii1 = 0 to get a constant value of eii0
439 real , private :: eii0hl = 0.2 ,eii1hl = 0.0 ! hail-crystal coll. eff. parameters: eii0hl*exp(eii1hl*min(temcg(mgs),0.0))
440 ! set eii1hl = 0 to get a constant value of eii0hl
441 real, private :: ewi_dcmin = 15.0e-06 ! minimum droplet diameter for nonzero ewi
442 real, private :: ewi_dimin = 30.0e-06 ! minimum ice crystal diameter for nonzero ewi
443 real , private :: eri0 = 0.1 ! rain efficiency to collect ice crystals
444 real , private :: eri_cimin = 10.e-6 ! minimum ice crystal diameter for collection by rain
445 real , private :: esi0 = 0.1 ! linear factor in snow-ice collection efficiency
446 real , private :: ehs0 = 0.1, ehs1 = 0.1 ! graupel-snow coll. eff. parameters: ehs0*exp(ehs1*min(temcg(mgs),0.0))
447 ! set ehs1 = 0 to get a constant value of ehs0
448 integer :: iessopt = 1 ! 1 = Original (no factor); 2 = factor based on wvel; 3 = factor based on SSI
449 ! 4 = as 3 but sets min factor of 0.1 and goes to full value at 0.5% SSI
450 real , private :: ess0 = 0.5, ess1 = 0.05 ! snow aggregation coefficients: ess0*exp(ess1*min(temcg(mgs),0.0))
451 ! set ess1 = 0 to get a constant value of ess0
452 real , private :: esstem1 = -15. ! lower temperature where snow aggregation turns on
453 real , private :: esstem2 = -10. ! higher temperature for linear ramp of ess from zero at esstem1 to formula value at esstem2
454 real , private :: essrmax = 0.02 ! maximum snow radius (meters) for csacs
455 real , private :: essfrac1 = 0.5 ! snow mass fraction 1 for aggregation roll-off
456 real , private :: essfrac2 = 0.75 ! snow mass fraction 2 for aggregation roll-off
457 integer, private :: iessec0flag = 0 ! flag to activate aggregation roll-off
458 real , private :: ehsfrac = 1.0 ! multiplier for graupel collection efficiency in wet growth
459 real , private :: ehimin = 0.0 ! Minimum collection efficiency (graupel - ice crystal)
460 real , private :: ehimax = 1.0 ! Maximum collection efficiency (graupel - ice crystal)
461 real , private :: ehsmax = 0.5 ! Maximum collection efficiency (graupel - snow)
462 real , private :: ecollmx = 0.5 ! Maximum collision efficiency for graup/hail with ice; used only for charging rates
463 integer, private :: iglcnvi = 1 ! flag for riming conversion from cloud ice to rimed ice/graupel
464 integer, private :: iglcnvs = 2 ! flag for conversion from snow to rimed ice/graupel
465
466 real , private :: rz ! reflectivity conservation factor for graupel/rain
467 ! now calculated in icezvd_dr.F from alphah and rnu
468 ! currently only used for graupel melting to rain
469 real , private :: rzhl ! reflectivity conservation factor for hail/rain
470 ! now calculated in icezvd_dr.F from alphahl and rnu
471
472 real , private :: rzs ! reflectivity conservation factor for snow(imusnow=3) with rain (imurain=1)
473
474 real , private :: alphahacx = 0.0 ! assumed minimum shape parameter for zhacw and zhacr
475
476 real , private :: fconv = 1.0 ! factor to boost max graupel depletion by riming conversions in 10ICE
477
478 real , private :: rg0 = 400.0 ! reference graupel density for graupel fall speed
479
480 integer, private :: rcond = 2 ! (Z only) rcond = 2 includes rain condensation in loop with droplet condensation
481 ! 0 = no condensation on rain; 1 = bulk condensation on rain
482 integer, parameter, private :: icond = 1 ! (Z only) icond = 1 calculates ice deposition (crystals and snow) BEFORE droplet condensation
483 ! icond = 2 does not work (intended to calc. dep in loop with droplet cond.)
484 integer, private :: iqis0 = 2 ! = 1 for normal qis; = 2 to set qis to use T = 0C when T > 0C
485
486 real , private :: dfrz = 0.15e-3 ! 0.25e-3 ! minimum diameter of frozen drops from Bigg freezing (used for vfrz) for iacr > 1
487 ! and for ciacrf for iacr=4
488 real , private :: dmlt = 3.0e-3 ! maximum diameter for rain melting from graupel and hail
489 real , private :: dshd = 1.0e-3 ! nominal diameter for rain drops shed from graupel/hail
490 integer, private :: ivshdgs = 1 ! 0 = use 1mm for all shedding (non-mixedphase); 1 = use vshdgs with sheddiam
491 integer, private :: ished2cld = 0 ! 1: Send shed liquid (from wet growth) to cloud droplets
492
493 integer, private :: ihmlt = 2 ! 1=old melting with vmlt; 2=new melting using mean volume diam of graupel/hail
494 integer, private :: imltshddmr = 2 ! 0 (default)=mean diameter of drops produced during melting+shedding as before (using mean diameter of graupel/hail
495 ! and max mean diameter of rain)
496 ! 1=new method where mean diameter of rain during melting is adjusted linearly downward
497 ! toward 3 mm for large (> sheddiam) graupel and hail, to take into account shedding of
498 ! smaller drops. sheddiam0 controls the size of graupel/hail above which the assumed
499 ! mean diameter of rain is set to 3 mm
500 ! Only valid for ihmlt = 2 for ZVD(H) but also applies to ZVD(H)M
501 ! 2 = method that sets the resulting rain size ( vshdgs ) according to the mass-weighted diameter of the ice
502
503 real :: mltdiam1 = 9.0e-3, mltdiam2 = 16.0e-3, mltdiam3 = 19.0e-3, mltdiam4 = 200.0e-3, mltdiam05 = 4.5e-3
504
505 integer, private :: nsplinter = 0 ! number of ice splinters per freezing drop, if negative, then per resulting graupel particle
506 real, private :: lawson_splinter_fac = 2.5e-11 ! constant in Lawson et al. (2015, JAS) for ice particle production from freezing drops
507 integer, private :: isnwfrac = 0 ! 0= no snow fragmentation; 1 = turn on snow fragmentation (Schuur, 2000)
508
509! integer, private :: denscale = 1 ! 1=scale num. conc. and charge by air density for advection, 0=turn off for comparison
510
511 real, private :: qhdpvdn = -1.
512 real, private :: qhacidn = -1.
513
514 integer, private :: iraintypes = 0
515 logical, private :: mixedphase = .false. ! .false.=off, true=on to include mixed phase graupel
516 integer, private :: imixedphase = 0
517 logical, private :: qsdenmod = .false. ! true = modify snow density by linear interpolation of snow and rain density
518 logical, private :: qhdenmod = .false. ! true = modify graupel density by linear interpolation of graupel and rain density
519 logical, private :: qsvtmod = .false. ! true = modify snow fall speed by linear interpolation of snow and rain vt
520 real , private :: sheddiam = 8.0e-03 ! minimum diameter of graupel before shedding occurs
521 real :: sheddiamlg = 10.0e-03 ! diameter of hail to use fwmlarge
522 real :: sheddiam0 = 20.0e-03 ! diameter of hail at which all water is shed
523
524 integer :: ifwmhopt = 2 ! option for calculating maximum liquid fraction when fwmh and/or fwmhl is set to -1
525 ! 1 = maximum based on size of maximum mass diameter
526 ! 2 = integrate over spectrum for maximum liquid (experimental)
527
528 integer :: ihxw2rain = 0 ! = 0 no transfer
529 ! = 1 transfer completely melted (99.5%) graupel/hail to rain when fwmh/fwmhl is set to -1.
530
531 real , private :: fwms = 0.5 ! maximum liquid water fraction on snow
532 real , private :: fwmh = 0.5 ! maximum liquid water fraction on graupel
533 real , private :: fwmhl = 0.5 ! maximum liquid water fraction on hail
534 real :: fwmlarge = 0.2 ! maximum liquid water fraction on hail larger than sheddiam
535 integer :: ifwmfall = 0 ! whether to interpolate toward rain fall speed for graupel and hail
536 ! when diam < sheddiam and liquid fraction is predicted (0=no, 1=yes)
537
538 logical :: rescale_high_alpha = .false. ! whether to rescale number. conc. when alpha = alphamax (3-moment only)
539 logical :: rescale_low_alpha = .true. ! whether to rescale Z (graupel/hail) when alpha = alphamin (3-moment only)
540 logical :: rescale_low_alphar = .true. ! whether to rescale Z for rain when alpha = alphamin (3-moment only)
541 logical :: rescale_low_alphah = .true. ! whether to rescale Z for rain when alpha = alphamin (3-moment only)
542 logical :: rescale_low_alphahl = .true. ! whether to rescale Z for rain when alpha = alphamin (3-moment only)
543
544 real, parameter :: alpharmax = 8. ! limited for rwvent calculation
545
546 integer, private :: ihlcnh = -1 ! which graupel -> hail conversion to use
547 ! 1 = Milbrandt and Yau (2005) using Ziegler 1985 wet growth diameter
548 ! 2 = Straka and Mansell (2005) conversion using size threshold
549 ! 3 = Conversion using wet growth diameter
550 real, private :: hlcnhdia = 1.e-3 ! threshold diameter for graupel -> hail conversion for ihlcnh = 1 option.
551 real, private :: hlcnhqmin = 0.1e-3 ! minimum graupel mass content for graupel -> hail conversion (ihlcnh = 1)
552 real , private :: hldia1 = 10.0e-3 ! threshold diameter for graupel -> hail conversion for ihlcnh = 2 option.
553 integer, private :: incwet = 0 ! flag to do wet growth only on D > D_wet
554 integer, private :: iusedw = 0 ! flag to use experimental wet growth ice diameter for gr -> hl conversion (=1 turns on)
555 real , private :: dwmin = 5.0e-3 ! Minimum diameter with iusedw (can stay at 0 or be set to something larger)
556 real , private :: dwetmin = 5.0e-3 ! Minimum diameter with iusedw (can stay at 0 or be set to something larger)
557 real , private :: dwmax = 15.e-3 ! for ihlcnh, always convert this size and larger whether or not there is wet growth
558 real , private :: dwtempmin = 242. ! lowest temperature to allow wet growth conversion to hail
559 real , private :: dwehwmin = 0. ! Minimum ehw to use to find wet growth diameter (if > ehw0, then wet growth diam becomes smaller)
560 real , private :: dg0thresh = 0.15 ! graupel wet growth diameter above which we say do not bother
561 integer :: ifddenfac = 0 ! = 1 to use density threshold to count FD as GR when converting to HL
562 real :: fddenthresh = 500. ! if ifddenfac > 0, then hail from FD with lower density are considered to come from graupel
563 integer :: icvhl2h = 0 ! allow conversion of hail back to graupel when hail density gets close to minimum allowed
564
565 integer, private :: imurain = 1 ! 3 for gamma-volume, 1 for gamma-diameter DSD for rain.
566 integer, private :: imusnow = 3 ! 3 for gamma-volume, 1 for gamma-diameter DSD for snow (=1 NOT IMPLEMENTED!!).
567 integer, private :: iturbenhance = 0 ! warm-rain collision enhancement
568 ! 1 = enhance autoconversion only
569 ! 2 = add rain collection of cloud
570 ! 3 = add rain self-collection
571 integer, private :: isedonly = 0 ! 1= only do sedimentation and skip other microphysics
572 integer, private :: iferwisventr = 2 ! =1 for Ferrier rwvent, =2 for Wisner rwvent (imurain=1)
573 integer, private :: izwisventr = 2 ! =1 for old Ziegler rwvent, =2 for Wisner-style rwvent (imurain=3)
574 integer :: iresetmoments = 0 ! if >0, then set all moments to zero when one of them is zero (3-moment only)
575 integer, private :: imaxdiaopt = 3
576 ! = 1 use mean diameter for breakup
577 ! = 2 use maximum mass diameter for breakup
578 ! = 3 use mass-weighted diameter for breakup
579 integer :: iraintailbreak = 0 ! 1 = on
580 real :: draintail = 8.e-3 ! starting size for rain breakup
581 integer, private :: dmrauto = 0
582 ! = -1 no limiter on crcnw
583 ! = 0 limit crcnw when qr > 1.2*L (Cohard-Pinty 2002)
584 ! = 1 DTD version based on MY code
585 ! = 2 DTD mass-weighted version based on MY code
586 ! = 3 Milbrandt version (from Cohard and Pinty code
587 integer :: dmropt = 0 ! extra option for crcnw
588 integer :: dmhlopt = 0 ! options for graupel -> hail conversion
589 integer :: irescalerainopt = 3 ! 0 = default option
590 ! 1 = qx(mgs,lc) > qxmin(lc)
591 ! 2 = qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < 3.0
592 ! 3 = temcg(mgs) > 0.0.and. qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < 3.0
593 real :: rescale_wthresh = 3.0
594 real :: rescale_tempthresh = 0.0
595 real, parameter :: alpharaut = 0.0 ! MY2005 for autoconversion
596 real :: cxmin = 1.e-8 ! threshold cutoff for number concentration
597 real :: zxmin = 1.e-28 ! threshold cutoff for reflectivity moment
598
599 integer :: ithompsoncnoh = 0 ! For single moment graupel only
600 ! 0 = fixed intercept
601 ! 1 = intercept based on graupel mass
602
603 integer :: ivhmltsoak = 1 ! 0=off, 1=on : flag to simulate soaking (graupel/hail) during melting
604 ! when liquid fraction is not predicted
605 logical, private :: iwetsoak = .true. ! soak and freeze during wet growth or not
606 integer, private :: ioldlimiter = 0 ! test switch for new(=0) or old(=1) size limiter at the end of GS for 3-moment categories
607 integer, private :: isnowfall = 2 ! Option for choosing between snow fall speed parameters
608 ! 1 = original Zrnic et al. (Mansell et al. 2010)
609 ! 2 = Ferrier 1994 (results in slower fall speeds)
610
611 integer, private :: isnowdens = 1 ! Option for choosing between snow density options
612 ! 1 = constant of 100 kg m^-3
613 ! 2 = Option based on Cox
614
615 integer, private :: ibiggsnow = 3 ! 1 = switch conversion over to snow for small frozen drops from Bigg freezing
616 ! 2 = switch conversion over to snow for small frozen drops from rain-ice interaction
617 ! 3 = switch conversion over to snow for small frozen drops from both
618 real :: biggsnowdiam = -1.0 ! If >0, use for ibiggsnow threshold
619
620 integer, private :: ixtaltype = 1 ! =1 column, =2 disk (similar to Takahashi)
621
622 real, private :: takshedsize1 = 0.15 ! diameter (cm) of drop shed from ice with D > 1.9 cm
623 real, private :: takshedsize2 = 0.3 ! diameter (cm) of drop shed from ice with D < 1.9 cm and D > 0.8 cm
624 real, private :: takshedsize3 = 0.45 ! diameter (cm) of drop shed from ice with D < 1.6 cm and D > 0.8 cm
625 integer, private :: numshedregimes = 3
626
627 real, private :: evapfac = 1.0 ! Multiplier on rain evaporation rate
628 real, private :: depfac = 1.0 ! Multiplier on graupel/hail deposition/sublimation rate
629 real,private,parameter :: meltfac = 1.0 ! Multiplier on graupel/hail melting rate
630
631 integer, private :: ibinhmlr = 0 ! =1 use incomplete gammas to determine melting from larger and smaller sizes of graupel, and appropriate shed drop sizes
632 ! =2 to test melting by temporary bins
633 integer, private :: ibinhlmlr = 0 ! =1 use incomplete gammas to determine melting from larger and smaller sizes of hail, and appropriate shed drop sizes
634 ! =2 to test melting by temporary bins
635 integer, private :: ibinnum = 2 ! number of bins for melting of smaller ice (for ibinhmlr = 1)
636 integer, private :: iqhacrmlr = 1 ! turn on/off qhacrmlr
637 integer, private :: iqhlacrmlr = 1 ! turn on/off qhlacrmlr
638 integer, private :: iqhacwshr = 1 ! turn on/off qhacw for T > 0
639 integer, private :: iqhlacwshr = 1 ! turn on/off qhlacw for T > 0
640 real, private :: binmlrmxdia = 40.e-3 ! threshold diameter (graupel/hail) to switch bin-bulk melting to use standard chmlr
641 real, private :: binmlrzrrfac = 1.0 ! factor for reflectivity change ice that sheds while melting
642 real, private :: snowmeltdia = 0 ! If nonzero, sets the size of rain drops from melting snow.
643 real, private :: alphasmlr0 = 14.0 ! shape parameter for drops formed from melting/shedding snow
644 real, private :: delta_alphamlr = 0.5 ! offset from alphamax at which melting does not further collapse the shape parameter
645
646 integer :: iqvsopt = 0 ! =0 use old default for tabqvs; =1 use Bolton formulation (Rogers and Yau)
647
648 integer :: imaxsupopt = 4 ! how to treat saturation adjustment in two-moment droplets
649 ! 1 = add droplets with same mean mass as current droplets
650 ! 2 = add droplets with minimum radius of 30 microns
651 ! 3 = only add 1.5*cxmin to number concentration (allow max size to apply)
652 ! 4 = add droplets with minimum radius of 20 microns
653 real :: maxsupersat = 1.9 ! maximum supersaturation ratio, above which a saturation adustment is done
654 real :: maxlowtempss = 1.08 ! Sat. ratio threshold for allowing droplet nucleation at T < tfrh
655 real :: ssmxuf = 4.0 ! supersaturation at which to start using "ultrafine" CCN (if ccnuf > 0.)
656
657
658 integer, parameter :: icespheres = 0 ! turn ice spheres (frozen droplets) on (1) or off (0). NOT COMPLETE IN WRF/ARPS/CM1 CODE!
659 integer, parameter :: lqmx = 30
660 integer, parameter :: lt = 1
661 integer, parameter :: lv = 2
662 integer, parameter :: lc = 3
663 integer, parameter :: lr = 4
664 integer, parameter :: li = 5
665 integer, private :: lis = 0
666 integer, private :: ls = 6
667 integer, private :: lh = 7
668 integer, private :: lf = 0
669 integer, private :: lhl = 0
670
671 integer, private :: lccn = 9 ! 0 or 9, other indices adjusted accordingly
672 integer, private :: lccnuf = 0
673 integer, private :: lccna = 0
674 integer, private :: lcina = 0
675 integer, private :: lcin = 0
676 integer, private :: lnc = 9
677 integer, private :: lnr = 10
678 integer, private :: lni = 11
679 integer, private :: lnis = 0
680 integer, private :: lns = 12
681 integer, private :: lnh = 13
682 integer, private :: lnf = 0
683 integer, private :: lnhl = 0
684 integer, private :: lnhf = 0
685 integer, private :: lnhlf = 0
686 integer, private :: lss = 0
687 integer :: lvh = 15
688
689 integer, private :: lhab = 8
690 integer, private :: lg = 7
691
692! Particle volume
693
694 integer :: lvi = 0
695 integer :: lvs = 0
696 integer :: lvgl = 0
697 integer :: lvgm = 0
698 integer :: lvgh = 0
699 integer :: lvf = 0
700! integer :: lvh = 16
701 integer :: lvhl = 0
702
703! liquid water fraction (not predicted here but tested for)
704 integer :: lhw = 0
705 integer :: lfw = 0
706 integer :: lsw = 0
707 integer :: lhlw = 0
708 integer :: lhwlg = 0
709 integer :: lhlwlg = 0
710
711! reflectivity (6th moment) ! not predicted here but may be tested against
712
713 integer :: lzr = 0
714 integer :: lzi = 0
715 integer :: lzs = 0
716 integer :: lzgl = 0
717 integer :: lzgm = 0
718 integer :: lzgh = 0
719 integer :: lzf = 0
720 integer :: lzh = 0
721 integer :: lzhl = 0
722
723! Space charge
724
725 integer :: lscw = 0
726 integer :: lscr = 0
727 integer :: lsci = 0
728 integer :: lscis = 0
729 integer :: lscs = 0
730 integer :: lsch = 0
731 integer :: lscf = 0
732 integer :: lschl = 0
733 integer :: lscwi = 0
734 integer :: lscpi = 0
735 integer :: lscni = 0
736 integer :: lscpli = 0
737 integer :: lscnli = 0
738 integer :: lschab = 0
739
740 integer :: lscb = 0
741 integer :: lsce = 0
742 integer :: lsceq = 0
743
744! integer, parameter :: lscmx = 100
745
746 integer :: lne = 0 ! last varible for transforming
747
748 real :: cnoh0 = 4.0e+5
749 real :: hwdn1 = 700.0
750
751 real :: alphai = 0.0 ! shape parameter for ZIEG ice crystals ! not currently used
752 real :: alphas = 0.0 ! shape parameter for ZIEG snow ! used only for single moment
753 real :: alphar = 0.0 ! shape parameter for rain (imurain=1 only)
754 real, private :: alphah = 0.0 ! set in namelist!! shape parameter for ZIEG graupel
755 real, private :: alphahl = 1.0 ! set in namelist!! shape parameter for ZIEG hail
756
757 real :: dmuh = 1.0 ! power in exponential part (graupel)
758 real :: dmuhl = 1.0 ! power in exponential part (hail)
759
760 real, private :: alphamax = 15.
761 real, private :: alphamin = 0.
762 real, parameter :: rnumin = -0.8
763 real, parameter :: rnumax = 15.0
764
765
766 real :: cnu = 0.0 ! default value of droplet shape parameter. Can be diagnosed by setting idiagnosecnu=1
767 real, parameter :: rnu = -0.8, snu = -0.8, cinu = 0.0
768! parameter ( cnu = 0.0, rnu = -0.8, snu = -0.8, cinu = 0.0 )
769
770 real xnu(lc:lqmx) ! 1st shape parameter (mass)
771 real xmu(lc:lqmx) ! 2nd shape parameter (mass)
772 real dnu(lc:lqmx) ! 1st shape parameter (diameter)
773 real dmu(lc:lqmx) ! 2nd shape parameter (diameter)
774
775 real ax(lc:lqmx)
776 real bx(lc:lqmx)
777 real fx(lc:lqmx)
778
779 real da0 (lc:lqmx) ! collection coefficients from Seifert 2005
780 real dab0(lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005
781 real dab1(lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005
782 real da1 (lc:lqmx) ! collection coefficients from Seifert 2005
783 real bb (lc:lqmx)
784
785
786! put ipelec here for now....
787 integer :: ipelec = 0
788 integer :: isaund = 0
789 logical :: idoniconly = .false.
790 integer, private :: elec_on_time = -1 ! time (seconds) to turn on charge separation.
791 integer, private :: elec_ramp_time = 0 ! time (interval) for linear ramp after elec_on_time
792 ! (i.e., linear factor on chg sep to smoothly turn on elec)
793 ! full charging rate is achieved at time = elec_on_time + elec_ramp_time
794 integer :: jchgs = 3 ! number of points near boundary where charging is turned off (to keep lightning from getting wonky)
795 integer :: jchgn = 2
796 integer :: ichge = 3
797 integer :: ichgw = 2
798 real :: charging_border = 4000. ! width of no-charging zone from boundary
799 real, private :: delqnw = -1.0e-10!-1.0e-12 !
800 real, private :: delqxw = 1.0e-10! 1.0e-12 !
801 real :: tindmn = 233, tindmx = 298.0 ! min and max temperatures where inductive charging is allowed
802
803!
804! gamma function lookup table
805!
806 integer ngm0,ngm1,ngm2
807 parameter(ngm0=3001,ngm1=500,ngm2=500)
808 double precision, parameter :: dgam = 0.01, dgami = 100.
809 double precision gmoi(0:ngm0) ! ,gmod(0:ngm1,0:ngm2),gmdi(0:ngm1,0:ngm2)
810
811 integer, parameter :: nqiacralpha = 300 !480 ! 240 ! 120 ! 15
812 integer, parameter :: nqiacrratio = 400 ! 500 !50 ! 25
813! real, parameter :: maxratiolu = 25.
814 real, parameter :: maxratiolu = 100. ! 25.
815 real, parameter :: maxalphalu = 15.
816 real, parameter :: minalphalu = -0.95
817 real, parameter :: dqiacralpha = maxalphalu/float(nqiacralpha), dqiacrratio = maxratiolu/float(nqiacrratio)
818 real, parameter :: dqiacrratioinv = 1./dqiacrratio, dqiacralphainv = 1./dqiacralpha
819 integer, parameter :: ialpstart = minalphalu*dqiacralphainv
820 real :: ciacrratio(0:nqiacrratio,ialpstart:nqiacralpha)
821 real :: qiacrratio(0:nqiacrratio,ialpstart:nqiacralpha)
822 real :: ziacrratio(0:nqiacrratio,ialpstart:nqiacralpha)
823 double precision :: gamxinflu(0:nqiacrratio,ialpstart:nqiacralpha,12,2) ! last index for graupel (1) or hail (2)
824! real :: ciacrratio(0:nqiacrratio,0:nqiacralpha)
825! real :: qiacrratio(0:nqiacrratio,0:nqiacralpha)
826! real :: ziacrratio(0:nqiacrratio,0:nqiacralpha)
827! double precision :: gamxinflu(0:nqiacrratio,0:nqiacralpha,12,2) ! last index for graupel (1) or hail (2)
828
829! for 3-moment collection coefficients
830 real, save :: dab0lu(ialpstart:nqiacralpha,ialpstart:nqiacralpha,lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005
831 real, save :: dab1lu(ialpstart:nqiacralpha,ialpstart:nqiacralpha,lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005
832
833 integer, parameter :: ngdnmm = 9
834 real :: mmgraupvt(ngdnmm,3) ! Milbrandt and Morrison (2013) fall speed coefficients for graupel/hail
835
836 DATA mmgraupvt(:,1) / 50., 150., 250., 350., 450., 550., 650., 750., 850./
837 DATA mmgraupvt(:,2) / 62.923, 94.122, 114.74, 131.21, 145.26, 157.71, 168.98, 179.36, 189.02 /
838 DATA mmgraupvt(:,3) / 0.67819, 0.63789, 0.62197, 0.61240, 0.60572, 0.60066, 0.59663, 0.59330, 0.59048 /
839
840 integer lsc(lc:lqmx)
841 integer ln(lc:lqmx)
842 integer ipc(lc:lqmx)
843 integer lvol(lc:lqmx)
844 integer lz(lc:lqmx)
845 integer lliq(li:lqmx)
846 integer denscale(lc:lqmx) ! flag for density scaling (mixing ratio conversion)
847
848 integer ido(lc:lqmx)
849 logical ldovol
850
851 real xdn0(lc:lqmx)
852 real xdnmx(lc:lqmx), xdnmn(lc:lqmx)
853 real cdx(lc:lqmx)
854 real cno(lc:lqmx)
855 real xvmn(lc:lqmx), xvmx(lc:lqmx)
856 real qxmin(lc:lqmx)
857 real qxmin_init(lc:lqmx)
858
859 integer nqsat
860 parameter(nqsat=1000001) ! (nqsat=20001)
861 real fqsat,fqsati
862 parameter(fqsat=0.002,fqsati=1./fqsat)
863 real tabqvs(nqsat),tabqis(nqsat),dtabqvs(nqsat),dtabqis(nqsat)
864
865!
866! constants
867!
868 real, parameter :: ar = 841.99666 ! rain terminal velocity power law coefficient (LFO)
869 real, parameter :: br = 0.8 ! rain terminal velocity power law coefficient (LFO)
870 real, parameter :: aradcw = -0.27544 !
871 real, parameter :: bradcw = 0.26249e+06 !
872 real, parameter :: cradcw = -1.8896e+10 !
873 real, parameter :: dradcw = 4.4626e+14 !
874 real, parameter :: bta1 = 0.6 ! beta-1 constant used for ice nucleation by deposition (Ferrier 94, among others)
875 real, parameter :: cnit = 1.0e-02 ! No for ice nucleation by deposition (Cotton et al. 86)
876 real, parameter :: dragh = 0.60 ! coefficient used to adjust fall speed for hail versus graupel (Pruppacher and Klett 78)
877 real, parameter :: dnz00 = 1.225 ! reference/MSL air density
878 real, parameter :: rho00 = 1.225 ! reference/MSL air density
879! cs = 4.83607122 ! snow terminal velocity power law coefficient (LFO)
880! ds = 0.25 ! snow terminal velocity power law coefficient (LFO)
881! new values for cs and ds
882 real, parameter :: cs = 12.42 ! snow terminal velocity power law coefficient
883 real, parameter :: ds = 0.42 ! snow terminal velocity power law coefficient
884 real :: cp608 = 0.608 ! constant used in conversion of T to Tv
885 real :: gr = 9.8
886
887 real, parameter :: pi = 3.141592653589793
888 real, parameter :: piinv = 1./pi
889 real, parameter :: pid4 = pi/4.0
890
891!
892! max and min mean volumes
893!
894 real xvrmn, xvrmx0 ! min, max rain volumes
895 real xvsmn, xvsmx ! min, max snow volumes
896 real xvfmn, xvfmx ! min, max frozen drop volumes
897 real xvgmn, xvgmx ! min, max graupel volumes
898 real xvhmn, xvhmn0, xvhmx, xvhmx0 ! min, max hail volumes
899 real xvhlmn, xvhlmx ! min, max lg hail volumes
900
901 real, parameter :: dhlmn = 0.3e-3, dhlmx = 40.e-3
902 real, parameter :: dhmn0 = 0.3e-3
903 real, private :: dhmn = dhmn0, dhmx = -1.
904
905 real, parameter :: cwradn = 2.0e-6, xcradmn = cwradn ! minimum radius
906 real, parameter :: cwradx = 60.e-6, xcradmx = cwradx ! maximum radius
907 real, parameter :: cwc1 = 6.0/(pi*1000.)
908
909! parameter( xvcmn=4.188e-18 ) ! mks min volume = 3 micron radius
910 real, parameter :: xvcmn=0.523599*(2.*cwradn)**3 ! mks min volume = 2.5 micron radius
911 real, parameter :: xvcmx=0.523599*(2.*xcradmx)**3 ! mks max volume = 60 micron radius
912 real, parameter :: cwmasn = 1000.*xvcmn ! minimum mass, defined by radius of 5.0e-6
913 real, parameter :: cwmasx = 1000.*xvcmx ! maximum mass, defined by radius of 50.0e-6
914 real, parameter :: cwmasn5 = 1000.*0.523599*(2.*5.0e-6)**3 ! 5.23e-13
915
916 real, parameter :: xvimn=0.523599*(2.*5.e-6)**3 ! mks min volume = 5 micron radius
917 real, parameter :: xvimx=0.523599*(2.*1.e-3)**3 ! mks max volume = 1 mm radius (solid sphere approx)
918
919 real, private :: xvdmx = -1.0 ! 3.0e-3
920 real :: xvrmx
921 parameter( xvrmn=0.523599*(80.e-6)**3, xvrmx0=0.523599*(6.e-3)**3 ) !( was 4.1887e-9 ) ! mks
922 parameter( xvsmn=0.523599*(0.01e-3)**3, xvsmx=0.523599*(10.e-3)**3 ) !( was 4.1887e-9 ) ! mks
923 parameter( xvfmn=0.523599*(0.1e-3)**3, xvfmx=0.523599*(10.e-3)**3 ) ! mks xvfmx = (pi/6)*(10mm)**3
924 parameter( xvgmn=0.523599*(0.1e-3)**3, xvgmx=0.523599*(10.e-3)**3 ) ! mks xvfmx = (pi/6)*(10mm)**3
925 parameter( xvhmn0=0.523599*(0.3e-3)**3, xvhmx0=0.523599*(20.e-3)**3 ) ! mks xvfmx = (pi/6)*(20mm)**3
926 parameter( xvhlmn=0.523599*(dhlmn)**3, xvhlmx=0.523599*(dhlmx)**3 ) ! mks xvfmx = (pi/6)*(40mm)**3
927
928!
929! electrical permitivity of air C / (N m**2) - check the units
930!
931 real eperao
932 parameter(eperao = 8.8592e-12 )
933
934 real ec,eci ! fundamental unit of charge
935 parameter(ec = 1.602e-19)
936 parameter(eci = 1.0/ec)
937
938 real :: scwppmx = 20.0e-12
939 real :: scippmx = 20.0e-12
940!
941! constants
942!
943 real, parameter :: c1f3 = 1.0/3.0
944
945 real, parameter :: cai = 21.87455
946 real, parameter :: caw = 17.2693882
947 real, parameter :: cbi = 7.66
948 real, parameter :: cbw = 35.86
949
950 real, parameter :: cbwbolton = 29.65 ! constants for Bolton formulation
951 real, parameter :: cawbolton = 17.67
952
953 real, parameter :: tfrh = 233.15
954! --------------------------
955 ! For CCPP, the following variables should be set by the host model, but initial values are set just in case
956 real :: tfr = 273.15
957 real :: cp = 1004.0, rd = 287.04
958 real :: rw = 461.5 ! gas const. for water vapor
959 real :: cpl = 4190.0
960 real :: cpigb = 2106.0
961 real :: cpi = 1.0/1004.0
962 real :: cap = 287.04/1004.0
963 real :: tfrcbw = 273.15 - cbw
964 real :: tfrcbi = 273.15 - cbi
965 real :: rovcp = 287.04/1004.0
966 real :: rdorv = 0.622
967! --------------------------
968 real, parameter :: poo = 1.0e+05
969 real, parameter :: advisc0 = 1.832e-05 ! reference dynamic viscosity (SMT; see Beard & Pruppacher 71)
970 real, parameter :: advisc1 = 1.718e-05 ! dynamic viscosity constant used in thermal conductivity calc
971 real, parameter :: tka0 = 2.43e-02 ! reference thermal conductivity
972
973 ! GHB: Needed for eqtset=2 in cm1
974! REAL, PRIVATE :: cv = cp - rd
975 real, private, parameter :: cv = 717.0 ! specific heat at constant volume - air
976 REAL, PRIVATE, parameter :: cvv = 1408.5
977 ! GHB
978
979 real, parameter :: bfnu0 = (rnu + 2.0)/(rnu + 1.0)
980 real :: ventr, ventrn, ventc, c1sw
981
982
983 real :: cckm,ccne,ccnefac,cnexp,ccne0
984
985 integer, public :: na = 9
986 integer :: nxtra = 1
987 real gf4p5, gf4ds, gf4br
988 real gsnow1, gsnow53, gsnow73
989 real gfcinu1, gfcinu1p47, gfcinu2p47
990 real gfcinu1p22,gfcinu2p22
991 real gfcinu1p18,gfcinu2p18
992
993 real :: cwchtmp0 = 1.0
994 real :: cwchltmp0 = 1.0
995
996 real :: esctot = 1.0e-13
997
998 integer iexy(lc:lqmx,lc:lqmx)
999 integer :: ieswi = 1, ieswc = 1, ieswr = 0
1000 integer :: iehlsw = 1, iehli = 1, iehlc = 1, iehlr = 0
1001 integer :: iehwsw = 1, iehwi = 1, iehwc = 1, iehwr = 0
1002
1003 logical, parameter :: do_satadj_for_wrfchem = .true.
1004
1005 integer, parameter :: ac_opt = 0 ! option flag for alternate aerosol (for NUWRF only)
1006 logical, private :: nuaccoinp = .false.
1007
1008! Note to users: Many of these options are for development and not guaranteed to perform well.
1009! Some may not be functional depending on the version of the code.
1010! Some may be useful for ensemble physics diversity. Feel free to contact Ted Mansell if you have questions
1011! in that regard.
1012 namelist /nssl_mp_params/ &
1013 ndebug, ncdebug,&
1014 iusewetgraupel, &
1015 iusewethail, &
1016 iusewetsnow, &
1017 idbzci, &
1018 vtmaxsed, &
1019 itfall,iscfall, &
1020 infall,irfall,isfall, &
1021 rssflg, &
1022 sssflg, &
1023 hssflg, &
1024 hlssflg, &
1025 irimdenopt,rimdenvwgt, &
1026 rimc1, rimc2, rimc3, rimc4, &
1027 idiagnosecnu, &
1028 icnuclimit, &
1029 irenuc, &
1030 restoreccn, ccntimeconst, cck, &
1031 decayufccn, ufccntimeconst, &
1032 switchccn, old_cccn, &
1033 ciintmx, &
1034 itype1, itype2, &
1035 icenucopt, in_freeze_rain_first, &
1036 naer, &
1037 icfn, &
1038 ibfc, iacr, icracr, &
1039 icracrthresh, &
1040 cwfrz2snowfrac, cwfrz2snowratio, &
1041 ibfr, &
1042 ibiggopt, &
1043 ibiggsmallrain, &
1044 ifrzg,ifiacrg, &
1045 ifrzs,ffrzs, &
1046 iacrsize, &
1047 cimas0, cimas1, cfnfac, &
1048 splintermass, &
1049 ewfac, &
1050 eii0, eii1, &
1051 eri0, esi0, &
1052 eri_cimin, &
1053 eii0hl, eii1hl, &
1054 ehs0, ehs1, &
1055 ess0, ess1, iessopt, &
1056 esstem1,esstem2, &
1057 ircnw, qminrncw,& ! single-moment only
1058 iglcnvi, &
1059 iglcnvs, &
1060 alphahacx, &
1061 fconv, &
1062 eqtot, &
1063 imeyers5, &
1064 iehw, &
1065 ierw, &
1066 iehr0c,iehlr0c, &
1067 alphai, &
1068 alphar, &
1069 alphas, & ! note that alphah and alphahl come through physics namelist
1070 cnu, &
1071 iscni,fscni, &
1072 dfrz, &
1073 dmlt, &
1074 rainfallfac, &
1075 icefallfac, &
1076 snowfallfac, &
1077 graupelfallfac, &
1078 hailfallfac, &
1079 icefallopt, &
1080 icdx,icdxhl, &
1081 axh,bxh,axf,bxf,axhl,bxhl, &
1082 cdhmin, cdhmax, &
1083 cdhdnmin, cdhdnmax, &
1084 cdhlmin, cdhlmax, &
1085 cdhldnmin, cdhldnmax, &
1086 ihmlt, &
1087 ehimin, &
1088 ehimax, &
1089 ehsmax, &
1090 ecollmx, &
1091 ehw0, ehlw0, &
1092 ehr0, ehlr0, &
1093 erw0, &
1094 exwmindiam, &
1095 nsplinter, &
1096 lawson_splinter_fac, &
1097 iqcinit, &
1098 ssmxinit, &
1099 xvdmx, &
1100 dhmn, dhmx, &
1101 fwms,fwmh,fwmhl, &
1102 ifwmhopt, &
1103 ihxw2rain, &
1104 fwmlarge, &
1105 ifwmfall, &
1106 iturbenhance, &
1107 qsdenmod,qhdenmod, &
1108 qsvtmod, &
1109 alphamin,alphamax, &
1110 isnwfrac, &
1111 rescale_low_alpha, &
1112 rescale_low_alphar, &
1113 rescale_low_alphah, &
1114 rescale_low_alphahl, &
1115 rescale_high_alpha, &
1116 ihlcnh, hldia1,iusedw, dwehwmin, dwmin, dwmax, dwtempmin, dg0thresh, &
1117 icvhl2h, hldnmn,hdnmn, &
1118 hlcnhdia, hlcnhqmin, &
1119 isedonly, &
1120 iresetmoments, &
1121 cxmin, zxmin, &
1122 imurain, &
1123 iferwisventr, &
1124 izwisventr, &
1125 qhdpvdn, &
1126 qhacidn, &
1127 sheddiam,sheddiamlg, &
1128 sheddiam0, &
1129 mltdiam1,mltdiam2,mltdiam3,mltdiam4,mltdiam05, &
1130 imaxdiaopt, &
1131 ithompsoncnoh, &
1132 cnohmn, &
1133 ivhmltsoak, &
1134 ioldlimiter, &
1135 isnowfall, &
1136 isnowdens, &
1137 ibiggsnow, &
1138 ixtaltype, &
1139 evapfac, &
1140 depfac, &
1141 dmrauto,irescalerainopt, dmropt,dmhlopt, &
1142 rescale_tempthresh, rescale_wthresh, &
1143 ibinhmlr,ibinhlmlr,imltshddmr, binmlrmxdia, binmlrzrrfac,ibinnum, &
1144 iqhacrmlr, iqhlacrmlr, &
1145 snowmeltdia, &
1146 delta_alphamlr, &
1147 iqvsopt, &
1148 maxsupersat, &
1149 do_accurate_sedimentation, interval_sedi_vt
1150! #####################################################################
1151! #####################################################################
1152
1153 CONTAINS
1154
1155! #####################################################################
1156! #####################################################################
1157
1158
1161 REAL function fqvs(t)
1162 implicit none
1163 real :: t
1164 fqvs = exp(caw*(t-273.15)/(t-cbw))
1165 END FUNCTION fqvs
1166
1169 REAL function fqis(t)
1170 implicit none
1171 real :: t
1172 fqis = exp(cai*(t-273.15)/(t-cbi))
1173 END FUNCTION fqis
1174
1175
1176
1177
1178! #####################################################################
1179! #####################################################################
1180
1181
1185 con_g, con_rd, con_cp, con_rv, con_t0c, con_cliq, con_csol, con_eps )
1186
1187 implicit none
1188 real, intent(in) :: con_g, con_rd, con_cp, con_rv, &
1189 con_t0c, con_cliq, con_csol, con_eps
1190
1191 gr = con_g
1192 tfr = con_t0c
1193 cp = con_cp
1194 rd = con_rd
1195 rw = con_rv
1196 rdorv = con_eps
1197 cpl = con_cliq ! 4190.0
1198 cpigb = con_csol ! 2106.0
1199 cpi = 1./cp
1200 cap = rd/cp
1201 tfrcbw = tfr - cbw
1202 tfrcbi = tfr - cbi
1203 rovcp = rd/cp
1204
1205
1206
1207 RETURN
1208 END SUBROUTINE nssl_2mom_init_const
1209
1210
1211! #####################################################################
1212! #####################################################################
1215 SUBROUTINE nssl_2mom_init( &
1216 & ims,ime, jms,jme, kms,kme, nssl_params, ipctmp, mixphase,ihvol,idoniconlytmp, &
1217 & nssl_graupelfallfac, &
1218 & nssl_hailfallfac, &
1219 & nssl_ehw0, &
1220 & nssl_ehlw0, &
1221 & nssl_icdx, &
1222 & nssl_icdxhl, &
1223 & nssl_icefallfac, &
1224 & nssl_snowfallfac, &
1225 & nssl_cccn, &
1226 & nssl_ufccn, &
1227 & nssl_alphah, &
1228 & nssl_alphahl, &
1229 & nssl_alphar, &
1230 & nssl_density_on, nssl_hail_on, nssl_ccn_on, nssl_icecrystals_on, ccn_is_ccna, &
1231 & errmsg, errflg, &
1232 & infileunit, &
1233 & myrank, mpiroot &
1234 )
1235
1236 implicit none
1237
1238 real, intent(in), optional :: &
1239 & nssl_graupelfallfac, &
1240 & nssl_hailfallfac, &
1241 & nssl_ehw0, &
1242 & nssl_ehlw0, &
1243 & nssl_icefallfac, &
1244 & nssl_snowfallfac, &
1245 & nssl_cccn, &
1246 & nssl_alphah, &
1247 & nssl_alphahl, &
1248 & nssl_alphar
1249 integer, intent(in), optional :: &
1250 & nssl_icdx, &
1251 & nssl_icdxhl, myrank, mpiroot, &
1252 & nssl_ufccn
1253 logical, intent(in), optional :: nssl_density_on, nssl_hail_on, nssl_ccn_on, nssl_icecrystals_on
1254 integer, intent(inout), optional :: ccn_is_ccna
1255
1256 integer, intent(in),optional :: infileunit
1257
1258 ! CCPP error handling
1259 character(len=*), intent( out) :: errmsg
1260 integer, intent( out) :: errflg
1261 integer, intent(in), optional :: ims,ime, jms,jme, kms,kme
1262
1263 real, intent(in), dimension(20), optional :: nssl_params
1264
1265
1266
1267 integer, intent(in) :: ipctmp,mixphase
1268 integer, optional, intent(in) :: ihvol
1269 logical, optional, intent(in) :: idoniconlytmp
1270
1271 integer :: igvol_local = 1
1272 logical :: wrote_namelist = .false.
1273 logical :: wrf_dm_on_monitor
1274 integer :: hail_on = -1, density_on = -1, icecrystals_on = 1
1275 integer :: ccn_on = -1
1276
1277 double precision :: arg
1278 real :: temq
1279 integer :: igam
1280 integer :: i,il,j,l
1281 integer :: ltmp
1282 integer :: isub
1283 real :: bxh1,bxhl1
1284
1285 real :: alp,ratio
1286 double precision :: x,y,y2,y7
1287 logical :: turn_on_ccna, turn_on_cina
1288 integer :: iufccn = 0
1289 integer :: istat
1290
1291 real :: alpjj, alpii, xnuii, xnujj
1292 integer :: ii, jj
1293
1294
1295 errmsg = ''
1296 errflg = 0
1297 turn_on_ccna = .false.
1298 turn_on_cina = .false.
1299
1300! IF ( present( igvol ) ) THEN
1301! igvol_local = igvol
1302! ENDIF
1303
1304 IF ( present( nssl_hail_on ) ) THEN
1305 IF ( nssl_hail_on ) THEN
1306 hail_on = 1
1307 ELSE
1308 hail_on = 0
1309 ENDIF
1310 ENDIF
1311
1312 IF ( present( nssl_density_on ) ) THEN
1313 IF ( nssl_density_on ) THEN
1314 density_on = 1
1315 ELSE
1316 density_on = 0
1317 ENDIF
1318 ENDIF
1319
1320 IF ( present( nssl_icecrystals_on ) ) THEN
1321 IF ( nssl_icecrystals_on ) THEN
1322 icecrystals_on = 1
1323 ELSE
1324 icecrystals_on = 0
1325 ! renucfrac = 1.0 ! why was this set to 1?
1326 ffrzs = 1.0
1327 ENDIF
1328 ENDIF
1329
1330
1331!
1332! set some global values from namelist input
1333!
1334
1335 IF ( present( nssl_params ) ) THEN
1336 ccn = abs( nssl_params(1) )
1337 alphah = nssl_params(2)
1338 alphahl = nssl_params(3)
1339 cnoh = nssl_params(4)
1340 cnohl = nssl_params(5)
1341 cnor = nssl_params(6)
1342 cnos = nssl_params(7)
1343 rho_qh = nssl_params(8)
1344 rho_qhl = nssl_params(9)
1345 rho_qs = nssl_params(10)
1346 IF ( nint(nssl_params(13)) == 1 ) THEN
1347 ! hack to switch CCN field to CCNA (activated ccn)
1348! invertccn = .true.
1349 turn_on_ccna = .true.
1350 irenuc = 7
1351 ENDIF
1352 ccnuf = abs( nssl_params(14) )
1353 IF ( present(nssl_ufccn) ) iufccn = nssl_ufccn
1354
1355 ENDIF
1356 alphar = nssl_params(15)
1357! ipelec = Nint(nssl_params(11))
1358! isaund = Nint(nssl_params(12))
1359
1360
1361 IF ( present(nssl_graupelfallfac) ) graupelfallfac = nssl_graupelfallfac
1362 IF ( present(nssl_hailfallfac) ) hailfallfac = nssl_hailfallfac
1363 IF ( present(nssl_ehw0) ) THEN
1364 IF ( nssl_ehw0 > 0.0 ) ehw0 = nssl_ehw0
1365 ENDIF
1366 IF ( present(nssl_ehlw0) ) THEN
1367 IF ( nssl_ehlw0 > 0.0 ) ehlw0 = nssl_ehlw0
1368 ENDIF
1369 IF ( present(nssl_icdx) ) icdx = nssl_icdx
1370 IF ( present(nssl_icdxhl) ) icdxhl = nssl_icdxhl
1371 IF ( present(nssl_icefallfac) ) icefallfac = nssl_icefallfac
1372 IF ( present(nssl_snowfallfac) ) snowfallfac = nssl_snowfallfac
1373 IF ( present(nssl_cccn) ) THEN
1374 IF (nssl_cccn > 1 ) ccn = nssl_cccn
1375 ENDIF
1376 IF ( present(nssl_alphah) ) THEN
1377 IF ( nssl_alphah > -1. ) alphah = nssl_alphah
1378 ENDIF
1379 IF ( present(nssl_alphahl) ) THEN
1380 IF ( nssl_alphahl > -1. ) alphahl = nssl_alphahl
1381 ENDIF
1382 IF ( present(nssl_alphar) ) THEN
1383 IF ( nssl_alphar > -1.0 ) alphar = nssl_alphar
1384 ENDIF
1385
1386
1387 ipconc = ipctmp
1388
1389 IF ( ipconc < 5 ) THEN
1390 ihlcnh = 0
1391 ENDIF
1392
1393 IF ( ihlcnh <= 0 ) THEN
1394 IF ( ipconc == 5 ) THEN
1395 ihlcnh = 3
1396 ELSEIF ( ipconc >= 6 ) THEN
1397 ihlcnh = 3
1398 ENDIF
1399 ENDIF
1400
1401
1402
1403
1404
1405 IF ( .false. ) THEN ! set to true to enable internal namelist read
1406 open(15,file='input.nml',status='old',form='formatted',action='read')
1407 rewind(15)
1408 read(15,nml=nssl_mp_params,iostat=istat)
1409 close(15)
1410 IF ( present ( myrank ) .and. present ( mpiroot ) ) THEN
1411 IF ( myrank == mpiroot ) THEN
1412 IF ( istat /= 0 ) THEN
1413 write(0,*) 'NSSL_2MOM_INIT: PROBLEM WITH NSSL_MP_PARAMS namelist: not found or bad token'
1414 ENDIF
1415
1416! write(0,*) 'iusewetsnow = ',iusewetsnow
1417
1418 open(15,file='nssl_mp_params.out',status='unknown',form='formatted')
1419 write(15,nml=nssl_mp_params)
1420 close(15)
1421 ENDIF
1422 ENDIF
1423 ENDIF
1424
1425
1426
1427 IF ( iufccn > 0 ) THEN ! make sure to use option that uses UF ccn
1428 irenuc = 7
1429 IF ( ccnuf <= 0.0 ) decayufccn = .true. ! assume surface emission and need decay
1430 IF ( i_uf_or_ccn > 0 ) THEN
1431 ufbackground = 0.0
1432 ccntimeconst = ufccntimeconst
1433 ENDIF
1434 ENDIF
1435
1436 IF ( present( nssl_ccn_on ) ) THEN
1437 IF ( nssl_ccn_on ) THEN
1438 ccn_on = 1
1439 ELSE
1440 ccn_on = 0
1441 irenuc = 2
1442 ENDIF
1443 ENDIF
1444
1445 IF ( irenuc >= 5 ) THEN
1446 turn_on_ccna = .true.
1447 IF ( present( nssl_ccn_on ) ) THEN
1448 IF ( .not. nssl_ccn_on ) THEN
1449 errmsg = 'NSSL_MP Error: Must have nssl_ccn_on=1 for irenuc >= 5!'
1450 errflg = 1
1451 return
1452 ENDIF
1453 ENDIF
1454 ENDIF
1455
1456 IF ( present( ccn_is_ccna ) .and. ccn_on == 1 ) THEN
1457 IF ( ccn_is_ccna > 0 ) THEN
1458 turn_on_ccna = .true.
1459 ELSE
1460 IF ( irenuc >= 5 ) THEN
1461 ccn_is_ccna = 1
1462 ENDIF
1463 ENDIF
1464 ENDIF
1465
1466 cwccn = ccn
1467
1468 lhab = 8
1469 lhl = 8
1470 IF ( icespheres >= 1 ) THEN
1471 lhab = lhab + 1
1472 lis = li + 1
1473 ls = ls + 1
1474 lh = lh + 1
1475 lhl = lhl + 1
1476 ENDIF
1477 IF ( hail_on == -1 ) THEN ! hail_on is not set
1478 hail_on = 1
1479 IF ( ihvol <= -1 .or. ihvol == 2 ) THEN
1480 IF ( ihvol == -1 .or. ihvol == -2 ) THEN
1481 lhab = lhab - 1 ! turns off hail
1482 lhl = 0
1483 hail_on = 0
1484 ! past me thought it would be a good idea to change graupel factors when hail is off....
1485 ! ehw0 = 0.75
1486 ! iehw = 2
1487 ! dfrz = Max( dfrz, 0.5e-3 )
1488 ENDIF
1489 IF ( ihvol == -2 .or. ihvol == 2 .or. icecrystals_on == 0 ) THEN ! ice crystals are turned off
1490 ! a value of 2? means to turn off ice crystals but turn on hail
1491 ! renucfrac = 1.0 ! why?
1492 ffrzs = 1.0
1493 ! idoci = 0 ! try this later
1494 ENDIF
1495 ENDIF
1496
1497 ELSE ! hail_on is set
1498 IF ( hail_on == 0 ) THEN
1499 lhab = lhab - 1 ! turns off hail
1500 lhl = 0
1501 ELSE
1502 ! assume default that hail is on
1503 ENDIF
1504 ENDIF
1505
1506 IF ( density_on == -1 ) THEN ! density flag not set, so default is to predict it
1507 density_on = 1
1508 ENDIF
1509
1510
1511 IF ( iresetmoments == 0 ) iresetmoments = 1 ! lhl
1512! write(0,*) 'wrf_init: lhab,lhl,hail_on,density_on = ',lhab,lhl,hail_on,density_on
1513
1514! IF ( ipelec > 0 ) idonic = .true.
1515
1516!
1517! Build lookup table for saturation mixing ratio (Soong and Ogura 73)
1518!
1519
1520 do l = 1,nqsat
1521 temq = 163.15 + (l-1)*fqsat
1522 IF ( iqvsopt == 0 ) THEN
1523 tabqvs(l) = exp(caw*(temq-273.15)/(temq-cbw))
1524 dtabqvs(l) = ((-caw*(-273.15 + temq))/(temq - cbw)**2 + &
1525 & caw/(temq - cbw))*tabqvs(l)
1526 ELSE
1527 tabqvs(l) = exp(caw*(temq-273.15)/(temq-cbw))
1528 dtabqvs(l) = ((-cawbolton*(-273.15 + temq))/(temq - cbwbolton)**2 + &
1529 & cawbolton/(temq - cbwbolton))*tabqvs(l)
1530 ENDIF
1531 tabqis(l) = exp(cai*(temq-273.15)/(temq-cbi))
1532 dtabqis(l) = ((-cai*(-273.15 + temq))/(temq - cbi)**2 + &
1533 & cai/(temq - cbi))*tabqis(l)
1534 end do
1535
1536 bx(lr) = 0.85
1537 ax(lr) = 1647.81
1538 fx(lr) = 135.477
1539
1540
1541 IF ( icdx == 6 ) THEN
1542 bx(lh) = 0.6 ! Milbrandt and Morrison (2013) for density of 550.
1543 ax(lh) = 157.71
1544! ELSEIF ( icdx == 1 ) THEN
1545! bx(lh) = bxh
1546! ax(lh) = axh
1547 ELSEIF ( icdx > 1 ) THEN
1548 bx(lh) = 0.5
1549 ax(lh) = 75.7149
1550 ELSEIF ( icdx == 0 ) THEN
1551 bx(lh) = 0.37 ! 0.6 ! Ferrier 1994 graupel
1552 ax(lh) = 19.3
1553 ELSE ! icdx < 0
1554! ax(lh) = 206.984 ! Ferrier 1994 hail/frozen drops
1555! bx(lh) = 0.6384
1556 bx(lh) = bxh
1557 ax(lh) = axh
1558 ENDIF
1559
1560! bx(lh) = 0.6
1561
1562 IF ( lhl .gt. 1 ) THEN
1563 IF ( icdxhl == 6 ) THEN
1564 bx(lhl) = 0.593 ! Milbrandt and Morrison (2013) for density of 750.
1565 ax(lhl) = 179.36
1566 ELSEIF (icdxhl == 0 ) THEN
1567 ax(lhl) = 206.984 ! Ferrier 1994
1568 bx(lhl) = 0.6384
1569 ELSEIF (icdxhl > 0 ) THEN
1570 bx(lhl) = 0.5
1571 ax(lhl) = 75.7149
1572 ELSE
1573 bx(lhl) = bxhl
1574 ax(lhl) = axhl
1575 ENDIF
1576 ENDIF
1577
1578! fill in the complete gamma function lookup table
1579 gmoi(0) = 1.d32
1580 do igam = 1,ngm0
1581 arg = dgam*igam
1582 gmoi(igam) = gamma_dp(arg)
1583 end do
1584
1585 ! build lookup table to compute the number and mass fractions of rain drops
1586 ! (imurain=1) greater than a given diameter. Used for qiacr and ciacr
1587 ! Uses incomplete gamma functions
1588 ! The terms with bxh or bxhl will be off if the actual bxh or bxhl is different from the base value (icdx=6 option)
1589
1590 bxh1 = bx(lh)
1591 bxhl1 = bx(max(lh,lhl))
1592
1593! DO j = 0,nqiacralpha
1594 DO j = ialpstart,nqiacralpha
1595 alp = float(j)*dqiacralpha
1596 y = gamma_dpr(1.+alp)
1597 y2 = gamma_dpr(2.+alp)
1598 DO i = 0,nqiacrratio
1599 ratio = float(i)*dqiacrratio
1600 x = gamxinfdp( 1.+alp, ratio )
1601! write(0,*) 'i, x/y = ',i, x/y
1602 ciacrratio(i,j) = x/y
1603
1604 ! graupel (.,.,.,1)
1605 gamxinflu(i,j,1,1) = x/y
1606 gamxinflu(i,j,2,1) = gamxinfdp( 2.0+alp, ratio )/y
1607 gamxinflu(i,j,3,1) = gamxinfdp( 2.5+alp+0.5*bxh1, ratio )/y
1608 gamxinflu(i,j,5,1) = (gamma_dpr(5.0+alp) - gamxinfdp( 5.0+alp, ratio ))/y
1609 gamxinflu(i,j,6,1) = (gamma_dpr(5.5+alp+0.5*bxh1) - gamxinfdp( 5.5+alp+0.5*bxh1, ratio ))/y
1610 gamxinflu(i,j,9,1) = gamxinfdp( 1.0+alp, ratio )/y
1611 gamxinflu(i,j,10,1)= gamxinfdp( 4.0+alp, ratio )/y
1612
1613 gamxinflu(i,j,12,1) = gamxinfdp( 2.0+alp, ratio )/y2
1614
1615 ! hail (.,.,.,2)
1616 gamxinflu(i,j,1,2) = gamxinflu(i,j,1,1)
1617 gamxinflu(i,j,2,2) = gamxinflu(i,j,2,1)
1618 gamxinflu(i,j,3,2) = gamxinfdp( 2.5+alp+0.5*bxhl1, ratio )/y
1619 gamxinflu(i,j,5,2) = gamxinflu(i,j,5,1)
1620 gamxinflu(i,j,6,2) = (gamma_dpr(5.5+alp+0.5*bxhl1) - gamxinfdp( 5.5+alp+0.5*bxhl1, ratio ))/y
1621 gamxinflu(i,j,9,2) = gamxinflu(i,j,9,1)
1622 gamxinflu(i,j,10,2)= gamxinflu(i,j,10,1)
1623
1624 IF ( alp > 1.1 ) THEN
1625! gamxinflu(i,j,7,1) = gamxinfdp( alp - 1., ratio )/y
1626 gamxinflu(i,j,7,1) = (gamma_dpr(alp - 1.) - gamxinfdp( alp - 1., ratio ))/y
1627! gamxinflu(i,j,8,1) = gamxinfdp( alp - 0.5 + 0.5*bxh, ratio )/y
1628 gamxinflu(i,j,8,1) = (gamma_dpr(alp - 0.5 + 0.5*bxh1) - gamxinfdp( alp - 0.5 + 0.5*bxh1, ratio ))/y
1629! gamxinflu(i,j,8,2) = gamxinfdp( alp - 0.5 + 0.5*bxhl1, ratio )/y
1630 gamxinflu(i,j,8,2) = (gamma_dpr(alp - 0.5 + 0.5*bxhl1) - gamxinfdp( alp - 0.5 + 0.5*bxhl1, ratio ))/y
1631 ELSE
1632! gamxinflu(i,j,7,1) = gamxinfdp( .1, ratio )/y
1633 gamxinflu(i,j,7,1) = (gamma_dpr(0.1) - gamxinfdp( 0.1, ratio ) )/y
1634! gamxinflu(i,j,8,1) = gamxinfdp( 1.1 - 0.5 + 0.5*bxh1, ratio )/y
1635! gamxinflu(i,j,8,2) = gamxinfdp( 1.1 - 0.5 + 0.5*bxhl1, ratio )/y
1636 gamxinflu(i,j,8,1) = (gamma_dpr(1.1 - 0.5 + 0.5*bxh1) - gamxinfdp( 1.1 - 0.5 + 0.5*bxh1, ratio ) )/y
1637 gamxinflu(i,j,8,2) = (gamma_dpr(1.1 - 0.5 + 0.5*bxhl1) - gamxinfdp( 1.1 - 0.5 + 0.5*bxhl1, ratio ) )/y
1638 ENDIF
1639
1640 gamxinflu(i,j,7,2) = gamxinflu(i,j,7,1)
1641
1642 ENDDO
1643 ENDDO
1644 ciacrratio(0,:) = 1.0
1645
1646 DO j = ialpstart,nqiacralpha
1647 alp = float(j)*dqiacralpha
1648 y = gamma_sp(4.+alp)
1649 y7 = gamma_sp(7.+alp)
1650 DO i = 0,nqiacrratio
1651 ratio = float(i)*dqiacrratio
1652
1653 ! mass fraction
1654 x = gamxinfdp( 4.+alp, ratio )
1655! write(0,*) 'i, x/y = ',i, x/y
1656 qiacrratio(i,j) = x/y
1657 gamxinflu(i,j,4,1) = x/y
1658 gamxinflu(i,j,4,2) = x/y
1659
1660 ! reflectivity fraction
1661 x = gamxinfdp( 7.+alp, ratio )
1662 ziacrratio(i,j) = x/y7
1663 gamxinflu(i,j,11,1) = x/y7
1664 gamxinflu(i,j,11,2) = x/y7
1665
1666 ENDDO
1667 ENDDO
1668 qiacrratio(0,:) = 1.0
1669
1670
1671 lccn = 0
1672 lccnuf = 0
1673 lccna = 0
1674 lnc = 0
1675 lnr = 0
1676 lni = 0
1677 lnis = 0
1678 lns = 0
1679 lnh = 0
1680 lnhl = 0
1681 lvh = 0
1682 lvhl = 0
1683 lzr = 0
1684 lzh = 0
1685 lzhl = 0
1686 lsw = 0
1687 lhw = 0
1688 lhlw = 0
1689
1690 denscale(:) = 0
1691
1692! lccn = 9
1693
1694
1695 IF ( ipconc == 0 ) THEN
1696 IF ( hail_on == 1 ) THEN ! turn on graupel density for 1-moment scheme
1697 lvh = 9
1698 ltmp = 9
1699 denscale(lvh) = 1
1700 ELSE ! no hail, 'LFO' scheme
1701 ltmp = lhab
1702 lhl = 0
1703 ENDIF
1704 ELSEIF ( ipconc == 5 ) THEN
1705 ltmp = lhab
1706 IF ( iufccn > 0 ) THEN
1707 ltmp = ltmp+1
1708 lccnuf = ltmp
1709 denscale(lccnuf) = 1
1710 ENDIF
1711 lccn= ltmp+1 ! 9
1712 lnc = ltmp+2 ! 10
1713 lnr = ltmp+3 ! 11
1714 lni = ltmp+4 !12
1715 lns = ltmp+5 !13
1716 lnh = ltmp+6 !14
1717 ltmp = lnh
1718 IF ( hail_on == 1 ) THEN
1719 ltmp = ltmp + 1
1720 lnhl = ltmp ! lhab+7 ! 15
1721 ENDIF
1722 IF ( density_on >= 1 ) THEN
1723 ltmp = ltmp + 1
1724 lvh = ltmp ! lhab+8 + isub ! 16 + isub ! isub adjusts to 15 if hail is off
1725! ltmp = lvh
1726 ENDIF
1727 denscale(lccn:ltmp) = 1
1728 IF ( density_on == 1 .and. hail_on == 1 ) THEN
1729 ltmp = ltmp + 1
1730 lvhl = ltmp
1731! ltmp = lvhl
1732 denscale(lvhl) = 1
1733 ENDIF
1734 IF ( mixedphase ) THEN
1735 ltmp = ltmp + 1
1736 lsw = ltmp
1737 ltmp = ltmp + 1
1738 lhw = ltmp
1739 IF ( lhl > 1 ) THEN
1740 ltmp = ltmp + 1
1741 lhlw = ltmp
1742 ENDIF
1743! ltmp = lhlw
1744 ENDIF
1745 ELSEIF ( ipconc >= 6 ) THEN
1746 ltmp = lhab
1747 IF ( iufccn > 0 ) THEN
1748 ltmp = ltmp+1
1749 lccnuf = ltmp
1750 denscale(lccnuf) = 1
1751 ENDIF
1752
1753 lccn= ltmp+1 ! 9
1754 lnc = ltmp+2 ! 10
1755 lnr = ltmp+3 ! 11
1756 lni = ltmp+4 !12
1757 lns = ltmp+5 !13
1758 lnh = ltmp+6 !14
1759 ltmp = lnh
1760 IF ( lhl > 0 ) THEN
1761 ltmp = ltmp + 1
1762 lnhl = ltmp ! lhab+7 ! 15
1763 ENDIF
1764 IF ( density_on == 1 ) THEN
1765 ltmp = ltmp + 1
1766 lvh = ltmp ! lhab+8 + isub ! 16 + isub ! isub adjusts to 15 if hail is off
1767 ENDIF
1768! ltmp = lvh
1769 denscale(lccn:ltmp) = 1
1770 IF ( density_on == 1 .and. hail_on == 1 ) THEN
1771 ltmp = ltmp + 1
1772 lvhl = ltmp
1773! ltmp = lvhl
1774 denscale(lvhl) = 1
1775 ENDIF
1776
1777 IF ( ipconc == 6 ) THEN
1778 ltmp = ltmp + 1
1779 lzh = ltmp
1780 ELSEIF ( ipconc == 7 ) THEN
1781 ltmp = ltmp + 1
1782 lzh = ltmp
1783 ltmp = ltmp + 1
1784 lzr = ltmp
1785 ELSEIF ( ipconc == 8 ) THEN
1786 ltmp = ltmp + 1
1787 lzh = ltmp
1788 ltmp = ltmp + 1
1789 lzr = ltmp
1790 IF ( lhl > 1 ) THEN
1791 ltmp = ltmp + 1
1792 lzhl = ltmp
1793 ENDIF
1794 ! write(0,*) 'ipcon,lzr = ',ipconc,lzr,lzh,lzhl
1795 ENDIF
1796! ltmp = lvh
1797 ! denscale(lccn:lvh) = 1
1798 IF ( mixedphase ) THEN
1799 ltmp = ltmp + 1
1800 lsw = ltmp
1801 ltmp = ltmp + 1
1802 lhw = ltmp
1803 IF ( lhl > 1 ) THEN
1804 ltmp = ltmp + 1
1805 lhlw = ltmp
1806 ENDIF
1807! ltmp = lhlw
1808 ENDIF
1809 ELSE
1810 errmsg = 'nssl_2mom_init: Invalid value of ipctmp'
1811 errflg = 1
1812 RETURN
1813 ENDIF
1814
1815
1816
1817 ! write(0,*) 'wrf_init: lh,lhl,lzh,lzhl = ',lh,lhl,lzh,lzhl
1818 ! write(0,*) 'wrf_init: ipconc = ',ipconc
1819 ! write(0,*) 'wrf_init: irenuc, turn_on_ccna = ',irenuc, turn_on_ccna
1820 IF ( turn_on_ccna ) THEN
1821 ltmp = ltmp + 1
1822 lccna = ltmp
1823 denscale(ltmp) = 1
1824 ENDIF
1825
1826 IF ( turn_on_cina ) THEN
1827 ltmp = ltmp + 1
1828 lcina = ltmp
1829 denscale(ltmp) = 1
1830 ENDIF
1831
1832 IF ( turn_on_cin .or. is_aerosol_aware ) THEN
1833 ltmp = ltmp + 1
1834 lcin = ltmp
1835 denscale(ltmp) = 1
1836!debug write(0,*) 'Setting lcin to ',lcin
1837 ENDIF
1838 na = ltmp
1839
1840 ln(lc) = lnc
1841 ln(lr) = lnr
1842 ln(li) = lni
1843 ln(ls) = lns
1844 ln(lh) = lnh
1845 IF ( lhl .gt. 1 ) ln(lhl) = lnhl
1846
1847 ipc(lc) = 2
1848 ipc(lr) = 3
1849 ipc(li) = 1
1850 ipc(ls) = 4
1851 ipc(lh) = 5
1852 IF ( lhl .gt. 1 ) ipc(lhl) = 5
1853
1854 ldovol = .false.
1855 lvol(:) = 0
1856 lvol(li) = lvi
1857 lvol(ls) = lvs
1858 lvol(lh) = lvh
1859 IF ( lhl .gt. 1 .and. lvhl .gt. 1 ) lvol(lhl) = lvhl
1860
1861 lne = max(lnh,lnhl)
1862 lne = max(lne,lvh)
1863 lne = max(lne,lvhl)
1864 lne = max(lne,na)
1865
1866 lsc(:) = 0
1867 lsc(lc) = lscw
1868 lsc(lr) = lscr
1869 lsc(li) = lsci
1870 lsc(ls) = lscs
1871 lsc(lh) = lsch
1872 IF ( lhl .gt. 1 ) lsc(lhl) = lschl
1873
1874
1875 DO il = lc,lhab
1876 ldovol = ldovol .or. ( lvol(il) .gt. 1 )
1877 ENDDO
1878
1879! write(0,*) 'nssl_2mom_init: ldovol = ',ldovol
1880
1881 lz(:) = 0
1882 lz(lr) = lzr
1883 lz(li) = lzi
1884 lz(ls) = lzs
1885 lz(lh) = lzh
1886 IF ( lhl .gt. 1 .and. lzhl > 1 ) lz(lhl) = lzhl
1887
1888 lliq(:) = 0
1889 lliq(ls) = lsw
1890 lliq(lh) = lhw
1891 IF ( lhl .gt. 1 ) lliq(lhl) = lhlw
1892 IF ( mixedphase ) THEN
1893! write(0,*) 'lsw,lhw,lhlw = ',lsw,lhw,lhlw
1894 ENDIF
1895
1896
1897
1898 xnu(lc) = cnu
1899 xmu(lc) = 1.
1900
1901 IF ( imurain == 3 ) THEN
1902 xnu(lr) = rnu
1903 xmu(lr) = 1.
1904 ELSEIF ( imurain == 1 ) THEN
1905 xnu(lr) = (alphar - 2.0)/3.0
1906 xmu(lr) = 1./3.
1907 ENDIF
1908
1909 xnu(li) = cinu
1910 xmu(li) = 1.
1911
1912 IF ( lis >= 1 ) THEN
1913 xnu(lis) = 0.0
1914 xmu(lis) = 1.
1915 ENDIF
1916
1917 dnu(lc) = 3.*xnu(lc) + 2. ! alphac
1918 dmu(lc) = 3.*xmu(lc)
1919
1920 dnu(lr) = 3.*xnu(lr) + 2. ! alphar
1921 dmu(lr) = 3.*xmu(lr)
1922
1923 xnu(ls) = snu
1924 xmu(ls) = 1.
1925
1926 dnu(ls) = 3.*xnu(ls) + 2. ! -0.4 ! alphas
1927 dmu(ls) = 3.*xmu(ls)
1928
1929
1930 dnu(lh) = alphah
1931 dmu(lh) = dmuh
1932
1933 xnu(lh) = (dnu(lh) - 2.)/3.
1934 xmu(lh) = dmuh/3.
1935
1936
1937 IF ( imurain == 3 ) THEN ! rain is gamma of volume
1938 rz = ((4. + alphah)*(5. + alphah)*(6. + alphah)*(1. + xnu(lr)))/ &
1939 & ((1 + alphah)*(2 + alphah)*(3 + alphah)*(2. + xnu(lr)))
1940
1941! IF ( ipconc .lt. 5 ) alphahl = alphah
1942
1943 rzhl = ((4. + alphahl)*(5. + alphahl)*(6. + alphahl)*(1. + xnu(lr)))/ &
1944 & ((1. + alphahl)*(2. + alphahl)*(3. + alphahl)*(2. + xnu(lr)))
1945
1946 rzs = 1. ! assume rain and snow are both gamma volume
1947
1948 ELSE ! rain is gamma of diameter
1949
1950 rz = ((4. + alphah)*(5. + alphah)*(6. + alphah)*(1. + alphar)*(2. + alphar)*(3. + alphar))/ &
1951 & ((1 + alphah)*(2 + alphah)*(3 + alphah)*(4. + alphar)*(5. + alphar)*(6. + alphar))
1952
1953 rzhl = ((4. + alphahl)*(5. + alphahl)*(6. + alphahl)*(1. + alphar)*(2. + alphar)*(3. + alphar))/ &
1954 & ((1 + alphahl)*(2 + alphahl)*(3 + alphahl)*(4. + alphar)*(5. + alphar)*(6. + alphar))
1955
1956
1957 rzs = &
1958 & ((1. + alphar)*(2. + alphar)*(3. + alphar)*(2. + xnu(ls)))/ &
1959 & ((4. + alphar)*(5. + alphar)*(6. + alphar)*(1. + xnu(ls)))
1960
1961
1962 ENDIF
1963
1964 IF ( ipconc <= 5 ) THEN
1965 imltshddmr = min(1, imltshddmr)
1966 ibinhmlr = 0
1967 ibinhlmlr = 0
1968 ENDIF
1969
1970 IF ( ipconc > 5 .and. (ibinhmlr == 0 .and. ibinhlmlr == 0 ) ) THEN
1971 imltshddmr = min(1, imltshddmr)
1972 ENDIF
1973
1974! write(0,*) 'rz,rzhl = ', rz,rzhl
1975
1976 IF ( ipconc .lt. 4 ) THEN
1977
1978 dnu(ls) = alphas
1979 dmu(ls) = 1.
1980
1981 xnu(ls) = (dnu(ls) - 2.)/3.
1982 xmu(ls) = 1./3.
1983
1984
1985 ENDIF
1986
1987 IF ( lhl .gt. 1 ) THEN
1988
1989 dnu(lhl) = alphahl
1990 dmu(lhl) = dmuhl
1991
1992 xnu(lhl) = (dnu(lhl) - 2.)/3.
1993 xmu(lhl) = dmuhl/3.
1994
1995 ENDIF
1996
1997 cno(lc) = 1.0e+08
1998 IF ( li .gt. 1 ) cno(li) = 1.0e+08
1999 cno(lr) = cnor
2000 IF ( ls .gt. 1 ) cno(ls) = cnos ! 8.0e+06
2001 IF ( lh .gt. 1 ) cno(lh) = cnoh ! 4.0e+05
2002 IF ( lhl .gt. 1 ) cno(lhl) = cnohl ! 4.0e+05
2003!
2004! density maximums and minimums
2005!
2006 xdnmx(:) = 900.0
2007
2008 xdnmx(lr) = 1000.0
2009 xdnmx(lc) = 1000.0
2010 xdnmx(li) = 917.0
2011 xdnmx(ls) = 300.0
2012 xdnmx(lh) = 900.0
2013 IF ( lhl .gt. 1 ) xdnmx(lhl) = 900.0
2014!
2015 xdnmn(:) = 900.0
2016
2017 xdnmn(lr) = 1000.0
2018 xdnmn(lc) = 1000.0
2019 xdnmn(li) = 100.0
2020 xdnmn(ls) = 100.0
2021 xdnmn(lh) = hdnmn
2022 IF ( lhl .gt. 1 ) xdnmn(lhl) = hldnmn
2023
2024 xdn0(:) = 900.0
2025
2026 xdn0(lc) = 1000.0
2027 xdn0(li) = 900.0
2028 xdn0(lr) = 1000.0
2029 xdn0(ls) = rho_qs ! 100.0
2030 xdn0(lh) = rho_qh ! (0.5)*(xdnmn(lh)+xdnmx(lh))
2031 IF ( lhl .gt. 1 ) xdn0(lhl) = rho_qhl ! 800.0
2032
2033!
2034! Set terminal velocities...
2035! also set drag coefficients
2036!
2037 cdx(lr) = 0.60
2038 cdx(lh) = 0.8 ! 1.0 ! 0.45
2039 cdx(ls) = 2.00
2040 IF ( lhl .gt. 1 ) cdx(lhl) = 0.45
2041
2042 ido(lc) = idocw
2043 ido(lr) = idorw
2044 ido(li) = idoci
2045 ido(ls) = idosw
2046 ido(lh) = idohw
2047 IF ( lhl .gt. 1 ) ido(lhl) = idohl
2048
2049 IF ( irfall .lt. 0 ) irfall = infall
2050 IF ( isfall .lt. 0 ) isfall = infall
2051 IF ( lzr > 0 ) irfall = 0
2052
2053 qccn = ccn/rho00
2054 qccnuf = ccnuf/rho00
2055 IF ( old_cccn > 0.0 ) THEN
2056 old_qccn = old_cccn/rho00
2057 ELSE
2058 old_qccn = qccn
2059 ENDIF
2060! xvcmx = (4./3.)*pi*xcradmx**3
2061
2062! set max rain diameter
2063 IF ( xvdmx .gt. 0.0 ) THEN
2064 xvrmx = 0.523599*(xvdmx)**3
2065 ELSE
2066 xvrmx = xvrmx0
2067 ENDIF
2068
2069 IF ( dhmn <= 0.0 ) THEN
2070 xvhmn = xvhmn0
2071! xvhmn = Min(xvhmn0, 0.523599*(dfrz)**3 )
2072 ELSE
2073 xvhmn = 0.523599*(dhmn)**3
2074! xvhmn = 0.523599*(Min(dhmn,dfrz))**3
2075 ENDIF
2076
2077 IF ( dhmx <= 0.0 ) THEN
2078 xvhmx = xvhmx0
2079 ELSE
2080 xvhmx = 0.523599*(dhmx)**3
2081 ENDIF
2082
2083 IF ( qhdpvdn < 0. ) qhdpvdn = xdnmn(lh)
2084 IF ( qhacidn < 0. ) qhacidn = xdnmn(lh)
2085
2086! load max/min diameters
2087 xvmn(lc) = xvcmn
2088 xvmn(li) = xvimn
2089 xvmn(lr) = xvrmn
2090 xvmn(ls) = xvsmn
2091 xvmn(lh) = xvhmn
2092
2093 xvmx(lc) = xvcmx
2094 xvmx(li) = xvimx
2095 xvmx(lr) = xvrmx
2096 xvmx(ls) = xvsmx
2097 xvmx(lh) = xvhmx
2098
2099 IF ( lhl .gt. 1 ) THEN
2100 xvmn(lhl) = xvhlmn
2101 xvmx(lhl) = xvhlmx
2102 ENDIF
2103
2104!
2105! cloud water constants in mks units
2106!
2107! cwmasn = 4.25e-15 ! radius of 1.0e-6
2108! cwmasn = 5.23e-13 ! minimum mass, defined by radius of 5.0e-6
2109! cwmasn5 = 5.23e-13
2110! cwradn = 5.0e-6 ! minimum radius
2111! cwmasx = 5.25e-10 ! maximum mass, defined by radius of 50.0e-6
2112! mwfac = 6.0**(1./3.)
2113 IF ( ipconc .ge. 2 ) THEN
2114! cwmasn = xvmn(lc)*1000. ! minimum mass, defined by minimum droplet volume
2115! cwradn = 1.0e-6 ! minimum radius
2116! cwmasx = xvmx(lc)*1000. ! maximum mass, defined by maximum droplet volume
2117
2118 ENDIF
2119! rwmasn = xvmn(lr)*1000. ! minimum mass, defined by minimum rain volume
2120! rwmasx = xvmx(lr)*1000. ! maximum mass, defined by maximum rain volume
2121
2122 IF ( lhl < 1 ) ifrzg = 1
2123
2124 ventr = 1.
2125 IF ( imurain == 3 ) THEN
2126! IF ( izwisventr == 1 ) THEN
2127 ventr = gamma_sp(rnu + 4./3.)/((rnu + 1.)**(1./3.)*gamma_sp(rnu + 1.)) ! Ziegler 1985
2128! ELSE
2129 ventrn = gamma_sp(rnu + 1.5 + br/6.)/(gamma_sp(rnu + 1.)*(rnu + 1.)**((1.+br)/6. + 1./3.) ) ! adapted from Wisner et al. 1972; for second term in rwvent
2130! ventr = Gamma_sp(rnu + 4./3.)/((rnu + 1.)**(1./3.)*Gamma_sp(rnu + 1.)) ! Ziegler 1985, still use for first term in rwvent
2131! ventr = Gamma_sp(rnu + 4./3.)/Gamma_sp(rnu + 1.)
2132! ENDIF
2133 ELSE ! imurain == 1
2134! IF ( iferwisventr == 1 ) THEN
2135 ventr = gamma_sp(2. + alphar) ! Ferrier 1994
2136! ELSEIF ( iferwisventr == 2 ) THEN
2137 ventrn = gamma_sp(alphar + 2.5 + br/2.)/gamma_sp(alphar + 1.) ! adapted from Wisner et al. 1972
2138! ENDIF
2139 ENDIF
2140 ventc = gamma_sp(cnu + 4./3.)/(cnu + 1.)**(1./3.)/gamma_sp(cnu + 1.)
2141 c1sw = gamma_sp(snu + 4./3.)*(snu + 1.0)**(-1./3.)/gamma_sp(snu + 1.0)
2142
2143 ! set threshold mixing ratios
2144
2145 qxmin(:) = 1.0e-12
2146
2147 qxmin(lc) = 1.e-9
2148 qxmin(lr) = 1.e-7
2149 IF ( li > 1 ) qxmin(li) = 1.e-12
2150 IF ( ls > 1 ) qxmin(ls) = 1.e-7
2151 IF ( lh > 1 ) qxmin(lh) = 1.e-7
2152 IF ( lhl .gt. 1 ) qxmin(lhl) = 1.e-7
2153
2154 IF ( lc .gt. 1 .and. lnc .gt. 1 ) qxmin(lc) = 1.0e-13
2155 IF ( lr .gt. 1 .and. lnr .gt. 1 ) qxmin(lr) = 1.0e-12
2156
2157 IF ( li .gt. 1 .and. lni .gt. 1 ) qxmin(li ) = 1.0e-13
2158 IF ( ls .gt. 1 .and. lns .gt. 1 ) qxmin(ls ) = 1.0e-13
2159 IF ( lh .gt. 1 .and. lnh .gt. 1 ) qxmin(lh ) = 1.0e-12
2160 IF ( lhl.gt. 1 .and. lnhl.gt. 1 ) qxmin(lhl) = 1.0e-12
2161
2162 qxmin_init(:) = 1.0e-8 ! threshold for considering single-moment initial condition mixing ratios
2163 ! constants for droplet nucleation
2164
2165 cckm = cck-1.
2166 ccnefac = (1.63/(cck * beta(3./2., cck/2.)))**(cck/(cck + 2.0))
2167 cnexp = (3./2.)*cck/(cck+2.0)
2168! ccne is all the factors with w in eq. A7 in Mansell et al. 2010 (JAS). The constant changes
2169! if k (cck) is changed!
2170 ccne = ccnefac*1.e6*(1.e-6*abs(cwccn))**(2./(2.+cck))
2171 ccne0 = ccnefac*1.e6*(1.e-6)**(2./(2.+cck))
2172! write(0,*) 'cwccn, cck, ccne = ',cwccn,cck,ccne,ccnefac,cnexp
2173 IF ( cwccn .lt. 0.0 ) THEN
2174 cwccn = abs(cwccn)
2175 ccwmx = 50.e9 ! cwccn
2176 ELSE
2177 ccwmx = 50.e9 ! cwccn ! *1.4
2178 ENDIF
2179
2180!
2181!
2182! Set collection coefficients (Seifert and Beheng 05)
2183!
2184 bb(:) = 1.0/3.0
2185 bb(li) = 0.3429
2186 DO il = lc,lhab
2187 da0(il) = delbk(bb(il), xnu(il), xmu(il), 0)
2188 da1(il) = delbk(bb(il), xnu(il), xmu(il), 1)
2189
2190! write(0,*) 'il, da0, da1, xnu, xmu = ', il, da0(il), da1(il), xnu(il), xmu(il)
2191 ENDDO
2192
2193 dab0(:,:) = 0.0
2194 dab1(:,:) = 0.0
2195
2196 DO il = lc,lhab
2197 DO j = lc,lhab
2198 IF ( il .ne. j ) THEN
2199
2200 dab0(il,j) = delabk(bb(il), bb(j), xnu(il), xnu(j), xmu(il), xmu(j), 0)
2201 dab1(il,j) = delabk(bb(il), bb(j), xnu(il), xnu(j), xmu(il), xmu(j), 1)
2202
2203! write(0,*) 'il, j, dab0, dab1 = ',il, j, dab0(il,j), dab1(il,j)
2204 ENDIF
2205 ENDDO
2206 ENDDO
2207
2208 dab0lu(:,:,:,:) = 0.0
2209 dab1lu(:,:,:,:) = 0.0
2210
2211 IF ( ipconc >= 6 ) THEN
2212 DO il = lc,lhab ! collector
2213 DO j = lc,lhab ! collected
2214 IF ( il .ne. j ) THEN
2215
2216 DO jj = ialpstart,nqiacralpha
2217 alpjj = float(jj)*dqiacralpha
2218 xnujj = (alpjj - 2.)/3.
2219 DO ii = ialpstart,nqiacralpha
2220 alpii = float(ii)*dqiacralpha
2221 xnuii = (alpii - 2.)/3.
2222
2223 dab0lu(ii,jj,il,j) = delabk(bb(il), bb(j), xnuii, xnujj, xmu(il), xmu(j), 0)
2224 dab1lu(ii,jj,il,j) = delabk(bb(il), bb(j), xnuii, xnujj, xmu(il), xmu(j), 1)
2225
2226 ENDDO
2227 ENDDO
2228! write(0,*) 'il, j, dab0, dab1 = ',il, j, dab0(il,j), dab1(il,j)
2229 ENDIF
2230 ENDDO
2231 ENDDO
2232
2233 ENDIF
2234
2235 gf4br = gamma_sp(4.0+br)
2236 gf4ds = gamma_sp(4.0+ds)
2237 gf4p5 = gamma_sp(4.0+0.5)
2238 gfcinu1 = gamma_sp(cinu + 1.0)
2239 gfcinu1p47 = gamma_sp(cinu + 1.47167)
2240 gfcinu2p47 = gamma_sp(cinu + 2.47167)
2241 gfcinu1p22 = gamma_sp(cinu + 1.22117)
2242 gfcinu2p22 = gamma_sp(cinu + 2.22117)
2243 gfcinu1p18 = gamma_sp(cinu + 1.18333)
2244 gfcinu2p18 = gamma_sp(cinu + 2.18333)
2245
2246 gsnow1 = gamma_sp(snu + 1.0)
2247 gsnow53 = gamma_sp(snu + 5./3.)
2248 gsnow73 = gamma_sp(snu + 7./3.)
2249
2250 IF ( lh .gt. 1 ) cwchtmp0 = 6.0/pi*gamma_sp( (xnu(lh) + 1.)/xmu(lh) )/gamma_sp( (xnu(lh) + 2.)/xmu(lh) )
2251 IF ( lhl .gt. 1 ) cwchltmp0 = 6.0/pi*gamma_sp( (xnu(lhl) + 1)/xmu(lhl) )/gamma_sp( (xnu(lhl) + 2)/xmu(lhl) )
2252
2253
2254 iexy(:,:)=0; ! sets to zero the ones Imight have forgotten
2255
2256! snow
2257 iexy(ls,li) = ieswi
2258 iexy(ls,lc) = ieswc ; iexy(ls,lr) = ieswr ;
2259
2260! graupel
2261 iexy(lh,ls) = iehwsw ; iexy(lh,li) = iehwi ;
2262 iexy(lh,lc) = iehwc ; iexy(lh,lr) = iehwr ;
2263
2264! hail
2265 IF (lhl .gt. 1 ) THEN
2266 iexy(lhl,ls) = iehlsw ; iexy(lhl,li) = iehli ;
2267 iexy(lhl,lc) = iehlc ; iexy(lhl,lr) = iehlr ;
2268 ENDIF
2269
2270! IF ( icefallfac /= 1.0 ) write(0,*) 'icefallfac = ',icefallfac
2271! IF ( snowfallfac /= 1.0 ) write(0,*) 'snowfallfac = ',snowfallfac
2272
2273
2274 RETURN
2275END SUBROUTINE nssl_2mom_init
2276
2277! #####################################################################
2278! #####################################################################
2279
2282SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw, chl, &
2283 cn, vhw, vhl, cna, cni, f_cn, f_cna, f_cina, &
2284 f_qc, f_qr, f_qi, f_qs, f_qh, f_qhl, &
2285 cnuf, f_cnuf, &
2286 zrw, zhw, zhl, f_zrw, f_zhw, f_zhl, f_vhw, f_vhl, &
2287 qsw, qhw, qhlw, &
2288 tt, th, pii, p, w, dn, dz, dtp, itimestep, &
2289 is_theta_or_temp, &
2290 ntmul, ntcnt, lastloop, &
2291 RAINNC,RAINNCV, &
2292 dx, dy, &
2293 axtra, &
2294 SNOWNC, SNOWNCV, GRPLNC, GRPLNCV, &
2295 SR,HAILNC, HAILNCV, &
2296 hail_maxk1, hail_max2d, nwp_diagnostics, &
2297 tkediss, &
2298 re_cloud, re_ice, re_snow, re_rain, &
2299 re_graup, re_hail, &
2300 has_reqc, has_reqi, has_reqs, has_reqr, &
2301 has_reqg, has_reqh, &
2302 rainncw2, rainnci2, &
2303 dbz, vzf,compdbz, &
2304 rscghis_2d,rscghis_2dp,rscghis_2dn, &
2305 scr,scw,sci,scs,sch,schl,sctot, &
2306 elec_physics, &
2307 induc,elecz,scion,sciona, &
2308 noninduc,noninducp,noninducn, &
2309 pcc2, pre2, depsubr, &
2310 mnucf2, melr2, ctr2, &
2311 rim1_2, rim2_2,rim3_2, &
2312 nctr2, nnuccd2, nnucf2, &
2313 effc2,effr2,effi2, &
2314 effs2, effg2, &
2315 fc2, fr2,fi2,fs2,fg2, &
2316 fnc2, fnr2,fni2,fns2,fng2, &
2317! qcond,qdep,qfrz,qrauto,qhcnvi,qhcollw,qscollw, &
2318! ncauto, niinit,nifrz, &
2319! re_liquid, re_graupel, re_hail, re_icesnow, &
2320! vtcloud, vtrain, vtsnow, vtgraupel, vthail, &
2321 ipelectmp, &
2322 diagflag,ke_diag, &
2323 errmsg, errflg, &
2324 nssl_progn, & ! wrf-chem
2325! 20130903 acd_mb_washout start
2326 wetscav_on, rainprod, evapprod, & ! wrf-chem
2327! 20130903 acd_mb_washout end
2328 cu_used, qrcuten, qscuten, qicuten, qccuten, & ! hm added
2329 ids,ide, jds,jde, kds,kde, & ! domain dims
2330 ims,ime, jms,jme, kms,kme, & ! memory dims
2331 its,ite, jts,jte, kts,kte) ! tile dims
2332
2333
2334
2335
2336
2337 implicit none
2338
2339
2340 !Subroutine arguments:
2341
2342 integer, intent(in):: &
2343 ids,ide, jds,jde, kds,kde, &
2344 ims,ime, jms,jme, kms,kme, &
2345 its,ite, jts,jte, kts,kte
2346 real, dimension(ims:ime, kms:kme, jms:jme), intent(inout):: &
2347 qv,qc,qr,qs,qh
2348 ! tt is air temperature -- used by CCPP instead of th (theta)
2349 real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: &
2350 th, tt, &
2351 zrw, zhw, zhl, &
2352 qsw, qhw, qhlw, &
2353 qi,qhl,ccw,crw,cci,csw,chw,chl,vhw,vhl
2354 integer, optional, intent(in) :: is_theta_or_temp
2355 logical, optional, intent(in) :: f_zrw, f_zhw, f_zhl, f_vhw, f_vhl ! not used yet
2356 real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: dbz, vzf, cn, cna, cni, cnuf
2357 real, dimension(ims:ime, jms:jme), optional, intent(inout):: compdbz
2358 real, dimension(ims:ime, jms:jme), optional, intent(inout):: rscghis_2d, & ! 2D accumulation arrays for vertically-integrated charging rate
2359 rscghis_2dp, & ! 2D accumulation arrays for vertically-integrated charging rate (positive only)
2360 rscghis_2dn ! 2D accumulation arrays for vertically-integrated charging rate (negative only)
2361! real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout)::rscghis_3d
2362 integer, optional, intent(in) :: elec_physics
2363 real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: &
2364 scr,scw,sci,scs,sch,schl,sciona,sctot ! space charge
2365 real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: &
2366 induc,noninduc,noninducp,noninducn ! charging rates: inductive, noninductive (all, positive, negative to graupel)
2367 real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(in) :: elecz ! elecsave = Ez
2368 real, dimension(ims:ime, kms:kme, jms:jme,2),optional, intent(inout) :: scion
2369 real, dimension(ims:ime, kms:kme, jms:jme), intent(in):: p,w,dz,dn
2370
2371 real, dimension(ims:ime, kms:kme, jms:jme), intent(in):: pii
2372 real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: &
2373 pcc2, pre2, depsubr, &
2374 mnucf2, melr2, ctr2, &
2375 rim1_2, rim2_2,rim3_2, &
2376 nctr2, nnuccd2, nnucf2, &
2377 effc2,effr2,effi2, &
2378 effs2, effg2, &
2379 fc2, fr2,fi2,fs2,fg2, &
2380 fnc2, fnr2,fni2,fns2,fng2
2381! qcond,qdep,qfrz,qrauto,qhcnvi,qhcollw,qscollw, &
2382! ncauto, niinit,nifrz, &
2383! re_liquid, re_graupel, re_hail, re_icesnow, &
2384! vtcloud, vtrain, vtsnow, vtgraupel, vthail
2385
2386 real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout) :: axtra
2387
2388! WRF variables
2389 real, dimension(ims:ime, jms:jme) :: &
2390 rainnc,rainncv ! accumulated precip (NC) and rate (NCV)
2391 real, dimension(ims:ime, jms:jme), optional, intent(inout):: &
2392 snownc,snowncv,grplnc,grplncv,sr ! accumulated precip (NC) and rate (NCV)
2393 real, dimension(ims:ime, jms:jme), optional, intent(inout):: &
2394 hailnc,hailncv ! accumulated precip (NC) and rate (NCV)
2395 real, dimension(ims:ime, jms:jme), optional, intent(inout) :: hail_maxk1, hail_max2d
2396 integer, optional, intent(in) :: nwp_diagnostics
2397! for cm1, set nproctot=44 (or as needed) to get domain total rates
2398 integer, parameter :: nproc = 1
2399 double precision :: proctot(nproc),proctotmpi(nproc)
2400 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(INOUT):: re_cloud, re_ice, re_snow, &
2401 re_rain, re_graup, re_hail
2402 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(IN):: tkediss
2403 INTEGER, INTENT(IN), optional :: has_reqc, has_reqi, has_reqs, has_reqr, has_reqg, has_reqh
2404 real, dimension(ims:ime, jms:jme), intent(out), optional :: &
2405 rainncw2, rainnci2 ! liquid rain, ice, accumulation rates
2406 real, optional, intent(in) :: dx,dy
2407 real, intent(in):: dtp
2408 integer, intent(in):: itimestep !, ccntype
2409 integer, intent(in), optional :: ntmul, ntcnt
2410 logical, optional, intent(in) :: lastloop
2411 logical, optional, intent(in) :: diagflag, f_cna, f_cn, f_cina, f_cnuf
2412 logical, optional, intent(in) :: f_qc, f_qr, f_qi, f_qs, f_qh, f_qhl
2413 integer, optional, intent(in) :: ipelectmp, ke_diag
2414
2415 ! CCPP error handling
2416 character(len=*), intent( out) :: errmsg
2417 integer, intent( out) :: errflg
2418
2419 LOGICAL, INTENT(IN), OPTIONAL :: nssl_progn ! flags for wrf-chem
2420
2421! REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional,INTENT(INOUT):: qndrop
2422 LOGICAL :: flag_qndrop ! wrf-chem
2423 LOGICAL :: flag_qnifa , flag_qnwfa
2424 logical :: flag_cnuf = .false.
2425 logical :: flag_ccn = .false.
2426 logical :: flag_qi = .true.
2427 logical :: has_reqg_local = .false., has_reqh_local = .false.
2428 logical :: flag
2429 logical :: nwp_diagflag = .false.
2430 real :: cinchange, t7max,testmax,wmax
2431
2432! 20130903 acd_ck_washout start
2433! rainprod - total tendency of conversion of cloud water/ice and graupel to rain (kg kg-1 s-1)
2434! evapprod - tendency of evaporation of rain (kg kg-1 s-1)
2435! 20130903 acd_ck_washout end
2436 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional,INTENT(INOUT):: rainprod, evapprod
2437
2438! qrcuten, rain tendency from parameterized cumulus convection
2439! qscuten, snow tendency from parameterized cumulus convection
2440! qicuten, cloud ice tendency from parameterized cumulus convection
2441! mu : air mass in column
2442 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(IN):: qrcuten, qscuten, qicuten, qccuten
2443 INTEGER, optional, intent(in) :: cu_used
2444 LOGICAL, optional, intent(in) :: wetscav_on
2445
2446!
2447! local variables
2448!
2449 real, dimension(its:ite, 1, kts:kte) :: elec2 ! ez = elecsave slab
2450! real, dimension(its:ite, 1, kts:kte,2) :: scion2 ! 1=- , 2=+
2451 real, dimension(its:ite, kts:kte) :: rainprod2d, evapprod2d,tke2d
2452 real, dimension(its:ite, 1, kts:kte, na) :: an, ancuten
2453 real, dimension(its:ite, 1, kts:kte, nxtra) :: axtra2d
2454 real, dimension(its:ite, 1, kts:kte, 3) :: alpha2d
2455 real, dimension(its:ite, 1, kts:kte) :: t0,t1,t2,t3,t4,t5,t6,t7,t8,t9
2456 real, dimension(its:ite, 1, kts:kte) :: dn1,t00,t77,ssat,pn,wn,dz2d,dz2dinv,dbz2d,vzf2d
2457 real, dimension(its:ite, 1, na) :: xfall
2458 real, dimension(its:ite, 1) :: hailmax1d,hailmaxk1
2459 real, dimension(kts:kte, nproc) :: thproclocal
2460 integer, parameter :: nor = 0, ng = 0
2461 integer :: nx,ny,nz,ngs
2462 integer ix,jy,kz,i,j,k,il,n
2463 integer :: infdo
2464 real :: ssival, ssifac, t8s, t9s, qvapor
2465 integer :: ltemq
2466 double precision :: dp1
2467 integer :: jye, lnb
2468 integer :: imx,kmx
2469 real :: dbzmx,refl
2470 integer :: vzflag0 = 0
2471 logical :: makediag
2472 real :: dx1,dy1
2473 real, parameter :: cnin20 = 1.0e3
2474 real, parameter :: cnin10 = 5.0e1
2475 real, parameter :: cnin1a = 4.5
2476 real, parameter :: cnin2a = 12.96
2477 real, parameter :: cnin2b = 0.639
2478
2479 double precision :: cwmass1,cwmass2
2480 double precision :: rwmass1,rwmass2
2481 double precision :: icemass1,icemass2
2482 double precision :: swmass1,swmass2
2483 double precision :: grmass1,grmass2
2484 double precision :: hlmass1,hlmass2
2485 double precision :: wvol5,wvol10
2486 real :: tmp,dv,dv1,tmpchg
2487 real :: rdt
2488
2489 double precision :: dt1,dt2
2490 double precision :: timesed,timesed1,timesed2,timesed3, timegs, timenucond, timedbz,zmaxsed
2491 double precision :: timevtcalc,timesetvt
2492
2493 logical :: f_cnatmp, f_cinatmp
2494 logical :: has_wetscav
2495
2496 integer :: kediagloc
2497 integer :: iunit
2498
2499 real :: ycent, y, emissrate, emissrate0, emissrate1, z, fac, factot
2500 real :: fach(kts:kte)
2501
2502 logical, parameter :: debugdriver = .false.
2503
2504 integer :: loopcnt, loopmax, outerloopcnt
2505 logical :: lastlooptmp
2506
2507
2508! -------------------------------------------------------------------
2509
2510 errmsg = ''
2511 errflg = 0
2512
2513 rdt = 1.0/dtp
2514
2515 IF ( debugdriver ) write(0,*) 'N2M: entering routine'
2516
2517 flag_qndrop = .false.
2518 flag_qnifa = .false.
2519 flag_qnwfa = .false.
2520 flag_cnuf = .false.
2521 flag_ccn = .false.
2522 nwp_diagflag = .false.
2523
2524 IF ( PRESENT ( nssl_progn ) ) flag_qndrop = nssl_progn
2525 IF ( present ( f_cnuf ) ) flag_cnuf = f_cnuf
2526 IF ( present ( nwp_diagnostics ) ) nwp_diagflag = ( nwp_diagnostics > 0 )
2527
2528 IF ( present ( f_cn ) .and. present( cn ) ) THEN
2529 flag_ccn = f_cn
2530 ELSEIF ( present( cn ) ) THEN
2531 flag_ccn = .true.
2532 ENDIF
2533
2534 IF ( present( f_qi ) ) THEN
2535 flag_qi = f_qi
2536 ELSE
2537 IF ( ffrzs < 1.0 ) THEN
2538 flag_qi = .true.
2539 ELSE
2540 flag_qi = .false.
2541 ENDIF
2542 ENDIF
2543
2544 IF ( .not. flag_qi .and. ffrzs < 1.0 ) ffrzs = 1.0
2545
2546
2547 IF ( PRESENT ( has_reqg ) ) has_reqg_local = has_reqg > 0
2548 IF ( PRESENT ( has_reqh ) ) has_reqh_local = has_reqh > 0
2549
2550 loopmax = 1
2551 outerloopcnt = 1
2552 lastlooptmp = .true.
2553 IF ( present( ntmul ) .and. present( ntcnt ) .and. present( lastloop ) ) THEN
2554 loopmax = ntmul
2555 outerloopcnt = ntcnt
2556 lastlooptmp = lastloop
2557 ENDIF
2558
2559
2560 has_wetscav = .false.
2561 IF ( wrfchem_flag > 0 ) THEN
2562 IF ( PRESENT( wetscav_on ) ) THEN
2563 has_wetscav = wetscav_on
2564 ENDIF
2565 ENDIF
2566
2567 IF ( present( f_cna ) ) THEN
2568 f_cnatmp = f_cna
2569 ELSE
2570 f_cnatmp = .false.
2571 ENDIF
2572
2573 IF ( present( f_cina ) ) THEN
2574 f_cinatmp = f_cina
2575 ELSE
2576 f_cinatmp = .false.
2577 ENDIF
2578
2579 IF ( present( vzf ) ) vzflag0 = 1
2580
2581 IF ( present( ipelectmp ) ) THEN
2582 ipelec = ipelectmp
2583 ELSE
2584 ipelec = 0
2585 ENDIF
2586! IF ( present( dbz ) ) THEN
2587! DO jy = jts,jte
2588! DO kz = kts,kte
2589! DO ix = its,ite
2590! dbz(ix,kz,jy) = 0.0
2591! ENDDO
2592! ENDDO
2593! ENDDO
2594! ENDIF
2595
2596 IF ( present( dx ) .and. present( dy ) ) THEN
2597 dx1 = dx
2598 dy1 = dy
2599 ELSE
2600 dx1 = 1.0
2601 dy1 = 1.0
2602 ENDIF
2603
2604
2605 makediag = .true.
2606 IF ( present( diagflag ) ) THEN
2607 makediag = diagflag .or. itimestep == 1
2608 ENDIF
2609
2610 IF ( debugdriver ) write(0,*) 'N2M: makediag = ',makediag
2611
2612
2613 nx = ite-its+1
2614 ny = 1 ! set up as 2D slabs
2615 nz = kte-kts+1
2616 ngs = 64
2617
2618 IF ( .not. flag_ccn ) THEN
2619 renucfrac = 1.0
2620 ENDIF
2621
2622
2623
2624
2625! ENDIF ! itimestep == 1
2626
2627
2628! sedimentation settings
2629
2630 infdo = 2
2631
2632 IF ( infall .ne. 1 .or. iscfall .ge. 2 ) THEN
2633 infdo = 1
2634 ELSE
2635 infdo = 0
2636 ENDIF
2637
2638 IF ( infall .ge. 3 .or. ipconc .ge. 6 ) THEN
2639 infdo = 2
2640 ENDIF
2641
2642
2643 IF ( present( hailncv ) .and. lhl < 1 ) THEN ! for WRF 3.1 compatibility
2644 hailncv(its:ite,jts:jte) = 0.
2645 ENDIF
2646
2647 tke2d(:,:) = 0.0 ! initialize if not used
2648
2649 lnb = max(lh,lhl)+1 ! lnc
2650! IF ( lccn > 1 ) lnb = lccn
2651
2652 jye = jte
2653
2654 IF ( present( compdbz ) .and. makediag ) THEN
2655 DO jy = jts,jye
2656 DO ix = its,ite
2657 compdbz(ix,jy) = -3.0
2658 ENDDO
2659 ENDDO
2660 ENDIF
2661
2662 zmaxsed = 0.0d0
2663 timevtcalc = 0.0d0
2664 timesetvt = 0.0d0
2665 timesed = 0.0d0
2666 timesed1 = 0.0d0
2667 timesed2 = 0.0d0
2668 timesed3 = 0.0d0
2669 timegs = 0.0d0
2670 timenucond = 0.0d0
2671
2672
2673
2674 IF ( debugdriver ) write(0,*) 'N2M: jy loop 1, lhl,na = ',lhl,na,present(qhl)
2675
2676 ancuten(its:ite,1,kts:kte,:) = 0.0
2677 thproclocal(:,:) = 0.0
2678
2679
2680 DO jy = jts,jye
2681
2682! write(0,*) 'N2M: load an, jy,lccn = ',jy,lccn,qccn
2683
2684 IF ( present( pcc2 ) .and. makediag ) THEN
2685 axtra2d(its:ite,1,kts:kte,:) = 0.0
2686 ENDIF
2687
2688 IF ( nwp_diagflag ) THEN
2689 alpha2d(its:ite,1,kts:kte,1) = alphar
2690 alpha2d(its:ite,1,kts:kte,2) = alphah
2691 alpha2d(its:ite,1,kts:kte,3) = alphahl
2692 ENDIF
2693
2694
2695 ! copy from 3D array to 2D slab
2696
2697 DO kz = kts,kte
2698 DO ix = its,ite
2699 IF ( present( tt ) ) THEN
2700 an(ix,1,kz,lt) = tt(ix,kz,jy)/pii(ix,kz,jy)
2701 ELSE
2702 an(ix,1,kz,lt) = th(ix,kz,jy)
2703 ENDIF
2704 an(ix,1,kz,lv) = qv(ix,kz,jy)
2705 an(ix,1,kz,lc) = qc(ix,kz,jy)
2706 an(ix,1,kz,lr) = qr(ix,kz,jy)
2707 IF ( flag_qi ) THEN
2708 an(ix,1,kz,li) = qi(ix,kz,jy)
2709 ELSE
2710 an(ix,1,kz,li) = 0.0
2711 ENDIF
2712 an(ix,1,kz,ls) = qs(ix,kz,jy)
2713 an(ix,1,kz,lh) = qh(ix,kz,jy)
2714 IF ( lhl > 1 ) an(ix,1,kz,lhl) = qhl(ix,kz,jy)
2715 IF ( lccn > 1 ) THEN
2716 IF ( is_aerosol_aware .and. flag_qnwfa ) THEN
2717 !
2718 ELSEIF ( flag_ccn ) THEN
2719 IF ( lccna > 1 .and. .not. ( present( cna ) .and. f_cnatmp ) ) THEN
2720 an(ix,1,kz,lccna) = cn(ix,kz,jy)
2721 an(ix,1,kz,lccn) = qccn ! cn(ix,kz,jy)
2722 ELSE
2723 an(ix,1,kz,lccn) = cn(ix,kz,jy)
2724 ENDIF
2725 IF ( i_uf_or_ccn > 0 .and. lccnuf > 1 ) THEN ! UF ccn are extra regular ccn
2726 an(ix,1,kz,lccn) = an(ix,1,kz,lccn) + cnuf(ix,kz,jy)
2727 ENDIF
2728 ELSE
2729 IF ( lccna == 0 .and. ( .not. f_cnatmp ) ) THEN
2730 an(ix,1,kz,lccn) = qccn - ccw(ix,kz,jy)
2731 ELSE
2732 an(ix,1,kz,lccn) = qccn
2733 ENDIF
2734
2735 ENDIF
2736 ENDIF
2737
2738 IF ( lccnuf > 0 .and. flag_cnuf ) THEN
2739 IF ( i_uf_or_ccn == 0 ) THEN ! UF are UF
2740 an(ix,1,kz,lccnuf) = max(0.0, cnuf(ix,kz,jy) )
2741 ELSE ! UF were added to lccn
2742 an(ix,1,kz,lccnuf) = 0.0
2743 ENDIF
2744 ENDIF
2745
2746 IF ( lccna > 1 ) THEN
2747 IF ( present( cna ) .and. f_cnatmp ) THEN
2748 an(ix,1,kz,lccna) = cna(ix,kz,jy)
2749 ENDIF
2750 ENDIF
2751
2752 IF ( lcina > 1 ) THEN
2753 IF ( present( cni ) .and. f_cinatmp ) THEN
2754 an(ix,1,kz,lcina) = cni(ix,kz,jy)
2755 ENDIF
2756 ENDIF
2757
2758 IF ( ipconc >= 5 ) THEN
2759 an(ix,1,kz,lnc) = ccw(ix,kz,jy)
2760 IF ( constccw > 0.0 ) THEN
2761 an(ix,1,kz,lnc) = constccw
2762 ENDIF
2763 an(ix,1,kz,lnr) = crw(ix,kz,jy)
2764 IF ( present( cci ) ) THEN
2765 an(ix,1,kz,lni) = cci(ix,kz,jy)
2766 ELSE
2767 an(ix,1,kz,lni) = 0.0
2768 ENDIF
2769 an(ix,1,kz,lns) = csw(ix,kz,jy)
2770 an(ix,1,kz,lnh) = chw(ix,kz,jy)
2771 IF ( lhl > 1 ) an(ix,1,kz,lnhl) = chl(ix,kz,jy)
2772 ENDIF
2773 IF ( lvh > 0 ) an(ix,1,kz,lvh) = vhw(ix,kz,jy)
2774 IF ( lvhl > 0 .and. present( vhl ) ) an(ix,1,kz,lvhl) = vhl(ix,kz,jy)
2775
2776 IF ( ipconc >= 6 ) THEN
2777 IF ( lzr > 0 ) an(ix,1,kz,lzr) = zrw(ix,kz,jy)*zscale
2778 IF ( lzh > 0 ) an(ix,1,kz,lzh) = zhw(ix,kz,jy)*zscale
2779 IF ( lzhl > 0 ) an(ix,1,kz,lzhl) = zhl(ix,kz,jy)*zscale
2780 ENDIF
2781
2782
2783
2784 ENDDO
2785 ENDDO
2786
2787 DO kz = kts,kte
2788 DO ix = its,ite
2789
2790
2791 IF ( present( tt ) ) THEN
2792 t0(ix,1,kz) = tt(ix,kz,jy) ! temperature (Kelvin)
2793 ELSE
2794 t0(ix,1,kz) = th(ix,kz,jy)*pii(ix,kz,jy) ! temperature (Kelvin)
2795 ENDIF
2796 t00(ix,1,kz) = 380.0/p(ix,kz,jy)
2797 t77(ix,1,kz) = pii(ix,kz,jy)
2798 dbz2d(ix,1,kz) = 0.0
2799 vzf2d(ix,1,kz) = 0.0
2800 ENDDO
2801 ENDDO
2802
2803 DO ix = its,ite
2804 rainncv(ix,jy) = 0.0
2805 IF ( present( grplncv ) ) grplncv(ix,jy) = 0.0
2806 IF ( present( hailncv ) ) hailncv(ix,jy) = 0.0
2807 IF ( present( snowncv ) ) snowncv(ix,jy) = 0.0
2808 ENDDO
2809
2810 DO loopcnt = 1,loopmax
2811
2812 DO kz = kts,kte
2813 DO ix = its,ite
2814
2815
2816 t1(ix,1,kz) = 0.0
2817 t2(ix,1,kz) = 0.0
2818 t3(ix,1,kz) = 0.0
2819 t4(ix,1,kz) = 0.0
2820 t5(ix,1,kz) = 0.0
2821 t6(ix,1,kz) = 0.0
2822 t7(ix,1,kz) = 0.0
2823 t8(ix,1,kz) = 0.0
2824 t9(ix,1,kz) = 0.0
2825
2826 pn(ix,1,kz) = p(ix,kz,jy)
2827 wn(ix,1,kz) = w(ix,kz,jy)
2828! calculate dn1 in case we are substepping: rho = con_eps*prsl/(con_rd*tgrs*(qv_mp+con_eps))
2829 dn1(ix,1,kz) = rdorv*pn(ix,1,kz)/(rd*t0(ix,1,kz)*(an(ix,1,kz,lv) + rdorv))
2830! wmax = Max(wmax,wn(ix,1,kz))
2831 dz2d(ix,1,kz) = dz(ix,kz,jy)
2832 dz2dinv(ix,1,kz) = 1./dz(ix,kz,jy)
2833
2834 ltemq = int( (t0(ix,1,kz)-163.15)/fqsat+1.5 )
2835 ltemq = min( nqsat, max(1,ltemq) )
2836!
2837! saturation mixing ratio
2838!
2839 t8s = t00(ix,1,kz)*tabqvs(ltemq) !saturation mixing ratio wrt water
2840 t9s = t00(ix,1,kz)*tabqis(ltemq) !saturation mixing ratio wrt ice
2841
2842!
2843! calculate rate of nucleation
2844!
2845 ssival = min(t8s,max(an(ix,1,kz,lv),0.0))/t9s ! qv/qvi
2846
2847
2848 if ( ssival .gt. 1.0 ) then
2849!
2850 IF ( icenucopt == 1 ) THEN
2851
2852 if ( t0(ix,1,kz).le.268.15 ) then
2853
2854 dp1 = dn1(ix,1,kz)/rho00*cnin20*exp( min( 57.0 ,(cnin2a*(ssival-1.0)-cnin2b) ) )
2855 t7(ix,1,kz) = min(dp1, 1.0d30)
2856 end if
2857
2858!
2859! Default value of imeyers5 turns off nucleation by Meyer at higher temperatures
2860! This is really from Ferrier (1994), eq. 4.31 - 4.34
2861 IF ( imeyers5 ) THEN
2862 if ( t0(ix,1,kz).lt.tfr .and. t0(ix,1,kz).gt.268.15 ) then
2863 qvapor = max(an(ix,1,kz,lv),0.0)
2864 ssifac = 0.0
2865 if ( (qvapor-t9s) .gt. 1.0e-5 ) then
2866 if ( (t8s-t9s) .gt. 1.0e-5 ) then
2867 ssifac = (qvapor-t9s) /(t8s-t9s)
2868 ssifac = ssifac**cnin1a
2869 end if
2870 end if
2871 t7(ix,1,kz) = dn1(ix,1,kz)/rho00*cnin10*ssifac*exp(-(t0(ix,1,kz)-tfr)*bta1)
2872 end if
2873 ENDIF
2874
2875! t7max = Max(t7max, t7(ix,1,kz) )
2876
2877 ELSEIF ( icenucopt == 2 ) THEN ! Thompson/Cooper; Note Thompson 2004 has constants of
2878 ! 0.005 and 0.304 because the line function was estimated from Cooper plot
2879 ! Here, the fit line values from Cooper 1986 are converted. Very little difference
2880 ! in practice
2881
2882 t7(ix,1,kz) = 1000.*0.00446684*exp(0.3108*(273.16 - max(233.0, t0(ix,1,kz) ) ) ) ! factor of 1000 to convert L**-1 to m**-3
2883
2884! write(0,*) 'Cooper t7,ssival = ',ix,kz,t7(ix,1,kz),ssival
2885
2886 ELSEIF ( icenucopt == 3 ) THEN ! Phillips (Meyers/DeMott)
2887
2888 if ( t0(ix,1,kz).le.268.15 .and. t0(ix,1,kz) > 243.15 ) then ! Meyers with factor of Psi=0.06
2889
2890 dp1 = 0.06*cnin20*exp( min( 57.0 ,(cnin2a*(ssival-1.0)-cnin2b) ) )
2891 t7(ix,1,kz) = min(dp1, 1.0d30)
2892 elseif ( t0(ix,1,kz) <= 243.15 ) then ! Phillips estimate of DeMott et al (2003) data
2893 dp1 = 1000.*( exp( min( 57.0 ,cnin2a*(ssival-1.1) ) ) )**0.3
2894 t7(ix,1,kz) = min(dp1, 1.0d30)
2895
2896 end if
2897
2898 ELSEIF ( icenucopt == 4 ) THEN ! DeMott 2010
2899
2900 IF ( t0(ix,1,kz) < 268.16 .and. t0(ix,1,kz) > 223.15 .and. ssival > 1.001 ) THEN !
2901
2902 ! a = 0.0000594, b = 3.33, c = 0.0264, d = 0.0033,
2903 ! nint = a*(-Tc)**b * naer**(c*(-Tc) + d)
2904 ! nint has units of per (standard) liter, so mult by 1.e3 and scale by dn/rho00
2905 ! naer needs units of cm**-3, so mult by 1.e-6
2906
2907 ! 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)
2908 tmp = 1.e-6*naer
2909 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)
2910 t7(ix,1,kz) = min(dp1, 1.0d30)
2911
2912 ELSE
2913 ! t7(ix,1,kz) = 0.0
2914 ENDIF
2915
2916 ENDIF ! icenucopt
2917
2918
2919!
2920 end if ! ( ssival .gt. 1.0 )
2921!
2922
2923 ENDDO ! ix
2924 ENDDO ! kz
2925
2926 IF ( wrfchem_flag > 0 ) THEN
2927 IF ( has_wetscav ) THEN
2928 IF ( PRESENT( rainprod ) ) rainprod2d(its:ite,kts:kte) = 0
2929 IF ( PRESENT( evapprod ) ) evapprod2d(its:ite,kts:kte) = 0
2930 ENDIF
2931 ENDIF
2932
2933
2934 ! transform from number mixing ratios to number conc.
2935
2936 IF ( loopcnt == 1 ) THEN
2937 DO il = lnb,na
2938 IF ( denscale(il) == 1 ) THEN
2939 DO kz = kts,kte
2940 DO ix = its,ite
2941 an(ix,1,kz,il) = an(ix,1,kz,il)*dn1(ix,1,kz) ! dn(ix,kz,jy)
2942 ENDDO
2943 ENDDO
2944 ENDIF
2945 ENDDO ! il
2946 ENDIF
2947
2948
2949! sedimentation
2950 xfall(:,:,:) = 0.0
2951
2952
2953! IF ( .true. ) THEN
2954
2955
2956! #ifndef CM1
2957! for real cases when hydrometeor mixing ratios have been initialized without concentrations
2958 IF ( itimestep == 1 .and. ipconc > 0 .and. loopcnt == 1 ) THEN
2959 call calcnfromq(nx,ny,nz,an,na,nor,nor,dn1)
2960 ENDIF
2961! IF ( itimestep == 3 .and. ipconc > 0 ) THEN
2962! call calcnfromq(nx,ny,nz,an,na,nor,nor,dn1)
2963! ENDIF
2964! #endif
2965
2966 IF ( present(cu_used) .and. &
2967 ( present( qrcuten ) .or. present( qscuten ) .or. &
2968 present( qicuten ) .or. present( qccuten ) ) ) THEN !{
2969
2970 IF ( cu_used == 1 ) THEN !{
2971 DO kz = kts,kte
2972 DO ix = its,ite
2973
2974 IF ( present( qrcuten ) ) ancuten(ix,1,kz,lr) = dtp*qrcuten(ix,kz,jy)
2975 IF ( present( qscuten ) ) ancuten(ix,1,kz,ls) = dtp*qscuten(ix,kz,jy)
2976 IF ( present( qicuten ) ) ancuten(ix,1,kz,li) = dtp*qicuten(ix,kz,jy)
2977 IF ( present( qccuten ) ) ancuten(ix,1,kz,lc) = dtp*qccuten(ix,kz,jy)
2978
2979 ENDDO
2980 ENDDO
2981
2982 call calcnfromcuten(nx,ny,nz,ancuten,an,na,nor,nor,dn1)
2983
2984 DO kz = kts,kte
2985 DO ix = its,ite
2986
2987
2988 IF ( ipconc >= 6 ) THEN
2989! IF ( lzr > 0 ) an(ix,1,kz,lzr) = an(ix,1,kz,lzr) + ancuten(ix,1,kz,lzr)
2990 ENDIF
2991
2992 ENDDO
2993 ENDDO
2994
2995 ENDIF !}
2996
2997 ENDIF !}
2998
2999
3000
3001
3002 call sediment1d(dtp,nx,ny,nz,an,na,nor,nor,xfall,dn1,dz2d,dz2dinv, &
3003 & t0,t7,infdo,jy,its,jts &
3004 & ,timesed1,timesed2,timesed3,zmaxsed,timesetvt)
3005
3006
3007! copy xfall to appropriate places...
3008
3009 IF ( debugdriver ) write(0,*) 'N2M: end sediment, jy = ',jy
3010
3011 DO ix = its,ite
3012 IF ( lhl > 1 ) THEN
3013 rainncv(ix,jy) = rainncv(ix,jy) + &
3014 dtp*dn1(ix,1,1)*(xfall(ix,1,lr) + xfall(ix,1,ls)*1000./xdn0(lr) + &
3015 & xfall(ix,1,lh)*1000./xdn0(lr) + xfall(ix,1,lhl)*1000./xdn0(lr) )
3016 ELSE
3017 rainncv(ix,jy) = rainncv(ix,jy) + &
3018 dtp*dn1(ix,1,1)*(xfall(ix,1,lr) + xfall(ix,1,ls)*1000./xdn0(lr) + &
3019 & xfall(ix,1,lh)*1000./xdn0(lr) )
3020 ENDIF
3021 IF ( present ( rainncw2 ) ) THEN ! rain only
3022 rainncw2(ix,jy) = rainncw2(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,lr)
3023 ENDIF
3024 IF ( present ( rainnci2 ) ) THEN ! ice only
3025 IF ( lhl > 1 ) THEN
3026 rainnci2(ix,jy) =rainnci2(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,ls)*1000./xdn0(lr) + &
3027 & xfall(ix,1,lh)*1000./xdn0(lr) + xfall(ix,1,lhl)*1000./xdn0(lr) )
3028 ELSE
3029 rainnci2(ix,jy) = rainnci2(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,ls)*1000./xdn0(lr) + &
3030 & xfall(ix,1,lh)*1000./xdn0(lr) )
3031 ENDIF
3032 ENDIF
3033 IF ( present( snowncv ) ) snowncv(ix,jy) = snowncv(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,ls)*1000./xdn0(lr)
3034 IF ( present( grplncv ) ) THEN
3035 IF ( lhl > 1 .and. .not. present( hailnc) ) THEN ! if no separate hail accum, then add to graupel
3036 grplncv(ix,jy) = grplncv(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,lh) + xfall(ix,1,lhl)) *1000./xdn0(lr)
3037 ELSE
3038 grplncv(ix,jy) = grplncv(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,lh)*1000./xdn0(lr)
3039 ENDIF
3040 ENDIF
3041 IF ( loopcnt == loopmax ) rainnc(ix,jy) = rainnc(ix,jy) + rainncv(ix,jy)
3042
3043 IF ( present (snownc) .and. present (snowncv) .and. loopcnt == loopmax ) THEN
3044 snownc(ix,jy) = snownc(ix,jy) + snowncv(ix,jy)
3045 ENDIF
3046 IF ( lhl > 1 ) THEN
3047!#ifdef CM1
3048! IF ( .true. ) THEN
3049!#else
3050 IF ( present( hailnc ) ) THEN
3051!#endif
3052 hailncv(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr)
3053 IF ( loopcnt == loopmax ) hailnc(ix,jy) = hailnc(ix,jy) + hailncv(ix,jy)
3054! ELSEIF ( present( GRPLNCV ) ) THEN ! if no separate hail accum, then add to graupel
3055! GRPLNCV(ix,jy) = GRPLNCV(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr)
3056 ENDIF
3057 ENDIF
3058 IF ( present( grplncv ) .and. loopcnt == loopmax ) THEN
3059 grplnc(ix,jy) = grplnc(ix,jy) + grplncv(ix,jy)
3060 ENDIF
3061 IF ( present( sr ) .and. present (snowncv) .and. present(grplncv) .and. loopcnt == loopmax ) THEN
3062 IF ( present( hailnc ) ) THEN
3063 sr(ix,jy) = (snowncv(ix,jy)+hailncv(ix,jy)+grplncv(ix,jy))/(rainncv(ix,jy)+1.e-12)
3064 ELSE
3065 sr(ix,jy) = (snowncv(ix,jy)+grplncv(ix,jy))/(rainncv(ix,jy)+1.e-12)
3066 ENDIF
3067 ENDIF
3068 ENDDO
3069
3070! ENDIF ! .false.
3071
3072 IF ( isedonly /= 1 ) THEN
3073 ! call nssl_2mom_gs: main gather-scatter routine to calculate microphysics
3074
3075 IF ( debugdriver ) write(0,*) 'N2M: gs, jy = ',jy
3076! IF ( isedonly /= 2 ) THEN
3077
3078
3079 call nssl_2mom_gs &
3080 & (nx,ny,nz,na,jy &
3081 & ,nor,nor &
3082 & ,dtp,dz2d &
3083 & ,t0,t1,t2,t3,t4,t5,t6,t7,t8,t9 &
3084 & ,an,dn1,t77 &
3085 & ,pn,wn,0 &
3086 & ,t00,t77, &
3087 & ventr,ventc,c1sw,1,ido, &
3088 & xdnmx,xdnmn, &
3089! & ln,ipc,lvol,lz,lliq, &
3090 & cdx, &
3091 & xdn0,dbz2d,tke2d, &
3092 & thproclocal,nproc,dx1,dy1,ngs, &
3093 & timevtcalc,axtra2d, makediag &
3094 & ,has_wetscav, rainprod2d, evapprod2d, alpha2d &
3095 & ,errmsg,errflg &
3096 & ,elec2,its,ids,ide,jds,jde &
3097 & )
3098
3099
3100
3101! recalculate dn1 after temperature changes: rho = con_eps*prsl/(con_rd*tgrs*(qv_mp+con_eps))
3102 DO kz = kts,kte
3103 DO ix = its,ite
3104 dn1(ix,1,kz) = rdorv*pn(ix,1,kz)/(rd*t0(ix,1,kz)*(an(ix,1,kz,lv) + rdorv))
3105 ENDDO
3106 ENDDO
3107
3108
3109 ENDIF ! isedonly /= 1
3110
3111 ! droplet nucleation/condensation/evaporation
3112 IF ( .true. ) THEN
3113 CALL nucond &
3114 & (nx,ny,nz,na,jy &
3115 & ,nor,nor,dtp,nx &
3116 & ,dz2d &
3117 & ,t0,t9 &
3118 & ,an,dn1,t77 &
3119 & ,pn,wn &
3120 & ,ngs &
3121 & ,axtra2d, makediag &
3122 & ,ssat,t00,t77,flag_qndrop)
3123
3124! recalculate dn1 after temperature changes
3125 DO kz = kts,kte
3126 DO ix = its,ite
3127 dn1(ix,1,kz) = rdorv*pn(ix,1,kz)/(rd*t0(ix,1,kz)*(an(ix,1,kz,lv) + rdorv))
3128 ENDDO
3129 ENDDO
3130
3131
3132 ENDIF
3133
3134
3135
3136
3137 ENDDO ! loopcnt=1,loopmax
3138 IF ( present( pcc2 ) .and. makediag ) THEN
3139 DO kz = kts,kte
3140 DO ix = its,ite
3141! example of using the 'axtra2d' array to get rates out of the microphysics routine for output.
3142! Search for 'axtra' to find example code below
3143! pcc2(ix,kz,jy) = axtra2d(ix,1,kz,1)
3144 ENDDO
3145 ENDDO
3146 ENDIF
3147
3148
3149! compute diagnostic S-band reflectivity if needed
3150 IF ( present( dbz ) .and. makediag .and. lastlooptmp ) THEN
3151 ! calc dbz
3152
3153 IF ( .true. ) THEN
3154 IF ( present(ke_diag) ) THEN
3155 kediagloc = ke_diag
3156 ELSE
3157 kediagloc = nz
3158 ENDIF
3159 call radardd02(nx,ny,nz,nor,na,an,t0, &
3160 & dbz2d,dn1,nz,cnoh,rho_qh,ipconc,kediagloc, 0)
3161 ENDIF ! .false.
3162
3163
3164 DO kz = kts,kediagloc ! kte
3165 DO ix = its,ite
3166 dbz(ix,kz,jy) = dbz2d(ix,1,kz)
3167 IF ( present( vzf ) ) THEN
3168 vzf(ix,kz,jy) = vzf2d(ix,1,kz)
3169 IF ( dbz2d(ix,1,kz) <= 0.0 ) THEN
3170 vzf(ix,kz,jy) = 0.0
3171 ELSEIF ( dbz2d(ix,1,kz) <= 15.0 ) THEN
3172 refl = 10**(0.1*dbz2d(ix,1,kz))
3173 vzf(ix,kz,jy) = min( vzf2d(ix,1,kz), 2.6 * max(0.0,refl)**0.107 * (1.2/dn1(ix,1,kz))**0.4 )
3174 ENDIF
3175 ENDIF
3176 IF ( present( compdbz ) ) THEN
3177 compdbz(ix,jy) = max( compdbz(ix,jy), dbz2d(ix,1,kz) )
3178 ENDIF
3179 ENDDO
3180 ENDDO
3181
3182 ENDIF
3183
3184
3185
3186! Following Greg Thompson, calculation for effective radii. Used by RRTMG LW/SW schemes if enabled in module_physics_init.F
3187 IF ( present( has_reqc ).and. present( has_reqi ) .and. present( has_reqs ) .and. &
3188 present( re_cloud ).and. present( re_ice ) .and. present( re_snow ) .and. &
3189 lastlooptmp) THEN
3190 IF ( has_reqc.ne.0 .or. has_reqi.ne.0 .or. has_reqs.ne.0) THEN
3191 DO kz = kts,kte
3192 DO ix = its,ite
3193 re_cloud(ix,kz,jy) = 2.51e-6
3194 re_ice(ix,kz,jy) = 10.01e-6
3195 re_snow(ix,kz,jy) = 25.e-6
3196 t1(ix,1,kz) = 2.51e-6
3197 t2(ix,1,kz) = 10.01e-6
3198 t3(ix,1,kz) = 25.e-6
3199 t4(ix,1,kz) = 50.e-6
3200 ENDDO
3201 ENDDO
3202
3203
3204 call calc_eff_radius &
3205 & (nx,ny,nz,na,jy &
3206 & ,nor,nor &
3207 & ,t1=t1,t2=t2,t3=t3,t4=t4,t5=t5,t6=t6,f_t5=has_reqg_local, f_t6=has_reqh_local &
3208 & ,an=an,dn=dn1 )
3209
3210 DO kz = kts,kte
3211 DO ix = its,ite
3212 re_cloud(ix,kz,jy) = max(2.51e-6, min(t1(ix,1,kz), 50.e-6))
3213 re_ice(ix,kz,jy) = max(10.01e-6, min(t2(ix,1,kz), 125.e-6))
3214 re_snow(ix,kz,jy) = max(25.e-6, min(t3(ix,1,kz), 999.e-6))
3215 ! check for case where snow needs to be treated as cloud ice (for rrtmg radiation)
3216 IF ( .not. present(qi) ) re_ice(ix,kz,jy) = max(10.e-6, min(t3(ix,1,kz), 125.e-6))
3217 ENDDO
3218 ENDDO
3219
3220 IF ( present(has_reqr) .and. present( re_rain ) ) THEN
3221 IF ( has_reqr /= 0 ) THEN
3222 DO kz = kts,kte
3223 DO ix = its,ite
3224 re_rain(ix,kz,jy) = max(50.e-6, min(t4(ix,1,kz), 2999.e-6))
3225 ENDDO
3226 ENDDO
3227 ENDIF
3228 ENDIF
3229
3230 IF ( present(has_reqg) .and. present( re_graup ) ) THEN
3231 IF ( has_reqg /= 0 ) THEN
3232 DO kz = kts,kte
3233 DO ix = its,ite
3234 re_graup(ix,kz,jy) = max(50.e-6, min(t5(ix,1,kz), 10.e-3))
3235 ENDDO
3236 ENDDO
3237 ENDIF
3238 ENDIF
3239
3240 IF ( present(has_reqh) .and. present( re_hail ) ) THEN
3241 IF ( has_reqh /= 0 ) THEN
3242 DO kz = kts,kte
3243 DO ix = its,ite
3244 re_hail(ix,kz,jy) = max(50.e-6, min(t5(ix,1,kz), 40.e-3))
3245 ENDDO
3246 ENDDO
3247 ENDIF
3248 ENDIF
3249
3250 ENDIF
3251 ENDIF
3252
3253
3254 IF ( present( hail_maxk1 ) .and. present( hail_max2d ) .and. nwp_diagflag ) THEN
3255 DO ix = its,ite
3256 hailmax1d(ix,1) = hail_max2d(ix,jy)
3257 hailmaxk1(ix,1) = hail_maxk1(ix,jy)
3258 ENDDO
3259
3260 call hailmaxd(dtp,nx,ny,nz,an,na,nor,nor,alpha2d,dn1, &
3261 hailmax1d,hailmaxk1,1 )
3262
3263 DO ix = its,ite
3264 hail_max2d(ix,jy) = hailmax1d(ix,1)
3265 hail_maxk1(ix,jy) = hailmaxk1(ix,1)
3266 ENDDO
3267! ENDIF
3268 ENDIF
3269
3270! transform concentrations back to mixing ratios
3271 DO il = lnb,na
3272 IF ( denscale(il) == 1 ) THEN
3273 DO kz = kts,kte
3274 DO ix = its,ite
3275 an(ix,1,kz,il) = an(ix,1,kz,il)/dn1(ix,1,kz) ! dn(ix,kz,jy)
3276 ENDDO
3277 ENDDO
3278 ENDIF
3279 ENDDO ! il
3280
3281 ! copy 2D slabs back to 3D
3282
3283
3284 DO kz = kts,kte
3285 DO ix = its,ite
3286
3287 IF ( present( tt ) ) THEN
3288 tt(ix,kz,jy) = t0(ix,1,kz)
3289 ELSE
3290 th(ix,kz,jy) = an(ix,1,kz,lt)
3291 ENDIF
3292
3293 qv(ix,kz,jy) = an(ix,1,kz,lv)
3294 qc(ix,kz,jy) = an(ix,1,kz,lc)
3295 qr(ix,kz,jy) = an(ix,1,kz,lr)
3296 IF ( flag_qi ) qi(ix,kz,jy) = an(ix,1,kz,li)
3297 qs(ix,kz,jy) = an(ix,1,kz,ls)
3298 qh(ix,kz,jy) = an(ix,1,kz,lh)
3299 IF ( lhl > 1 ) qhl(ix,kz,jy) = an(ix,1,kz,lhl)
3300
3301 IF ( lccn > 1 .and. is_aerosol_aware .and. flag_qnwfa ) THEN
3302 ! not used here
3303 ELSEIF ( flag_ccn .and. lccn > 1 .and. .not. flag_qndrop) THEN
3304 IF ( lccna > 1 .and. .not. ( present( cna ) .and. f_cnatmp ) ) THEN
3305 cn(ix,kz,jy) = max(0.0, an(ix,1,kz,lccna) )
3306 ELSE
3307 cn(ix,kz,jy) = an(ix,1,kz,lccn)
3308 ENDIF
3309 ENDIF
3310 IF ( lccna > 1 ) THEN
3311 IF ( present( cna ) .and. f_cnatmp ) THEN
3312 cna(ix,kz,jy) = max(0.0, an(ix,1,kz,lccna) )
3313 ENDIF
3314 ENDIF
3315
3316 IF ( lcina > 1 ) THEN
3317 IF ( present( cni ) .and. f_cinatmp ) THEN
3318 cni(ix,kz,jy) = max(0.0, an(ix,1,kz,lcina) )
3319 ENDIF
3320 ENDIF
3321
3322 IF ( lccnuf > 0 .and. flag_cnuf ) THEN
3323 IF ( i_uf_or_ccn > 0 ) THEN ! UF are ccn and lccnuf is zero, so put cnuf into lccnuf to do decay
3324 an(ix,1,kz,lccnuf) = max(0.0, cnuf(ix,kz,jy) )
3325 ENDIF
3326 IF ( decayufccn ) THEN
3327 IF ( an(ix,1,kz,lccnuf) > ufbackground ) THEN
3328 an(ix,1,kz,lccnuf) = an(ix,1,kz,lccnuf) - (an(ix,1,kz,lccnuf) - &
3329 ufbackground)*(1.0 - exp(-dtp/ufccntimeconst))
3330 ENDIF
3331 ENDIF
3332 cnuf(ix,kz,jy) = an(ix,1,kz,lccnuf)
3333 ENDIF
3334
3335
3336
3337 IF ( ipconc >= 5 ) THEN
3338
3339 ccw(ix,kz,jy) = an(ix,1,kz,lnc)
3340 crw(ix,kz,jy) = an(ix,1,kz,lnr)
3341 IF ( present( cci ) ) cci(ix,kz,jy) = an(ix,1,kz,lni)
3342 csw(ix,kz,jy) = an(ix,1,kz,lns)
3343 chw(ix,kz,jy) = an(ix,1,kz,lnh)
3344 IF ( lhl > 1 ) chl(ix,kz,jy) = an(ix,1,kz,lnhl)
3345 ENDIF
3346
3347 IF ( ipconc >= 6 ) THEN
3348 IF ( lzr > 0 ) zrw(ix,kz,jy) = an(ix,1,kz,lzr) *zscaleinv
3349 IF ( lzh > 0 ) zhw(ix,kz,jy) = an(ix,1,kz,lzh) *zscaleinv
3350 IF ( lzhl > 0 ) zhl(ix,kz,jy) = an(ix,1,kz,lzhl)*zscaleinv
3351 ENDIF
3352
3353
3354
3355 IF ( lvh > 0 ) vhw(ix,kz,jy) = an(ix,1,kz,lvh)
3356 IF ( lvhl > 0 .and. present( vhl ) ) vhl(ix,kz,jy) = an(ix,1,kz,lvhl)
3357
3358#if ( WRF_CHEM == 1 )
3359 IF ( has_wetscav ) THEN
3360 IF ( loopmax > 1 ) THEN
3361 ! wrferror not supported
3362 ENDIF
3363 IF ( PRESENT( rainprod ) ) rainprod(ix,kz,jy) = rainprod2d(ix,kz)
3364 IF ( PRESENT( evapprod ) ) evapprod(ix,kz,jy) = evapprod2d(ix,kz)
3365 ENDIF
3366#endif
3367
3368 ENDDO
3369 ENDDO
3370
3371
3372 ENDDO ! jy
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382 RETURN
3383END SUBROUTINE nssl_2mom_driver
3384
3385! #####################################################################
3386! #####################################################################
3387
3390 REAL function gamma_sp(xx)
3391
3392 implicit none
3393 real xx
3394 integer j
3395
3396! Double precision ser,stp,tmp,x,y,cof(6)
3397
3398 real*8 ser,stp,tmp,x,y,cof(6)
3399 SAVE cof,stp
3400 DATA cof,stp/76.18009172947146d+0, &
3401 & -86.50532032941677d0, &
3402 & 24.01409824083091d0, &
3403 & -1.231739572450155d0, &
3404 & 0.1208650973866179d-2,&
3405 & -0.5395239384953d-5, &
3406 & 2.5066282746310005d0/
3407
3408 IF ( xx <= 0.0 ) THEN
3409 write(0,*) 'Argument to gamma must be > 0!! xx = ',xx
3410 ENDIF
3411
3412 x = xx
3413 y = x
3414 tmp = x + 5.5d0
3415 tmp = (x + 0.5d0)*log(tmp) - tmp
3416 ser = 1.000000000190015d0
3417 DO j=1,6
3418 y = y + 1.0d0
3419 ser = ser + cof(j)/y
3420 END DO
3421 gamma_sp = exp(tmp + log(stp*ser/x))
3422
3423 RETURN
3424 END FUNCTION gamma_sp
3425
3426! #####################################################################
3427
3430 DOUBLE PRECISION FUNCTION gamma_dpr(x)
3431 ! dp gamma with real input
3432 implicit none
3433 real :: x
3434 double precision :: xx
3435
3436 xx = x
3437
3438 gamma_dpr = gamma_dp(xx)
3439
3440 return
3441 end FUNCTION gamma_dpr
3442
3443
3444
3445
3446! #####################################################################
3447
3450 real function gamxinf(a1,x1)
3451
3452! ===================================================
3453! Purpose: Compute the incomplete gamma function
3454! from x to infinity
3455! Input : a --- Parameter ( a 170 )
3456! x --- Argument
3457! Output: GIM --- gamma(a,x) t=x,Infinity
3458! Routine called: GAMMA for computing gamma(x)
3459! ===================================================
3460
3461! IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3462 implicit none
3463 real :: a1,x1
3464 double precision :: xam,dlog,s,r,ga,t0,a,x
3465 integer :: k
3466 double precision :: gin, gim
3467
3468 a = a1
3469 x = x1
3470 IF ( x1 <= 0.0 ) THEN
3471 gamxinf = gamma_sp(a1)
3472 return
3473 ENDIF
3474 xam=-x+a*dlog(x)
3475 IF (xam.GT.700.0.OR.a.GT.170.0) THEN
3476 WRITE(*,*)'a and/or x too large'
3477 ENDIF
3478 IF (x.EQ.0.0) THEN
3479 gin=0.0
3480 gim = gamma_sp(a1)
3481 ELSE IF (x.LE.1.0+a) THEN
3482 s=1.0d0/a
3483 r=s
3484 DO 10 k=1,60
3485 r=r*x/(a+k)
3486 s=s+r
3487 IF (dabs(r/s).LT.1.0d-15) GO TO 15
348810 CONTINUE
348915 gin=dexp(xam)*s
3490 ga = gamma_sp(a1)
3491 gim=ga-gin
3492 ELSE IF (x.GT.1.0+a) THEN
3493 t0=0.0d0
3494 DO 20 k=60,1,-1
3495 t0=(k-a)/(1.0d0+k/(x+t0))
349620 CONTINUE
3497 gim=dexp(xam)/(x+t0)
3498! GA = GAMMA_SP(A1)
3499! GIN=GA-GIM
3500 ENDIF
3501
3502 gamxinf = gim
3503 return
3504 END function gamxinf
3505
3506! #####################################################################
3507
3510 double precision function gamxinfdp(A1,X1)
3511
3512! ===================================================
3513! Purpose: Compute the incomplete gamma function
3514! from x to infinity
3515! Input : a --- Parameter ( a < 170 )
3516! x --- Argument
3517! Output: GIM --- Gamma(a,x) t=x,Infinity
3518! Routine called: GAMMA for computing gamma_dp(x)
3519! ===================================================
3520
3521! IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3522 implicit none
3523 real :: a1,x1
3524! dont declare gamma_dp because it is within the module
3525! double precision :: gamma_dp
3526 double precision :: xam,dlog,s,r,ga,t0,a,x
3527 integer :: k
3528 double precision :: gin, gim
3529
3530 a = a1
3531 x = x1
3532 IF ( x1 <= 0.0 ) THEN
3533 gamxinfdp = gamma_dp(a)
3534 return
3535 ENDIF
3536 xam=-x+a*dlog(x)
3537 IF (xam.GT.700.0.OR.a.GT.170.0) THEN
3538 WRITE(*,*)'a and/or x too large'
3539 ENDIF
3540 IF (x.EQ.0.0) THEN
3541 gin=0.0
3542 gim = gamma_dp(a)
3543 ELSE IF (x.LE.1.0+a) THEN
3544 s=1.0d0/a
3545 r=s
3546 DO 10 k=1,60
3547 r=r*x/(a+k)
3548 s=s+r
3549 IF (dabs(r/s).LT.1.0d-15) GO TO 15
355010 CONTINUE
355115 gin=dexp(xam)*s
3552 ga = gamma_dp(a)
3553 gim=ga-gin
3554 ELSE IF (x.GT.1.0+a) THEN
3555 t0=0.0d0
3556 DO 20 k=60,1,-1
3557 t0=(k-a)/(1.0d0+k/(x+t0))
355820 CONTINUE
3559 gim=dexp(xam)/(x+t0)
3560! GA = GAMMA_dp(A)
3561! GIN=GA-GIM
3562 ENDIF
3563
3564 gamxinfdp = gim
3565 return
3566 END function gamxinfdp
3567
3568
3569! #####################################################################
3570
3573 real function gaminterp(ratio, alp, luindex, ilh)
3574
3575 implicit none
3576
3577 real, intent(in) :: ratio, alp
3578 integer, intent(in) :: ilh ! 1 = graupel, 2 = hail
3579 integer, intent(in) :: luindex ! which argument:
3580 ! gamxinflu(i,j,1,1) = x/y
3581 ! gamxinflu(i,j,2,1) = gamxinf( 2.0+alp, ratio )/y
3582 ! gamxinflu(i,j,3,1) = gamxinf( 2.5+alp+0.5*bxh, ratio )/y
3583 ! gamxinflu(i,j,5,1) = gamxinf( 5.0+alp, ratio )/y
3584 ! gamxinflu(i,j,6,1) = gamxinf( 5.5+alp+0.5*bxh, ratio )/y
3585
3586
3587 real :: delx, dely, tmp1, tmp2, temp3
3588 integer :: i,j,ip1,jp1 !,ilh
3589
3590! ilh = Abs(ilh0)
3591
3592
3593 i = min(nqiacrratio,int(ratio*dqiacrratioinv))
3594 j = int(max(0.0,min(maxalphalu,alp))*dqiacralphainv)
3595 delx = min(maxratiolu,ratio) - float(i)*dqiacrratio
3596 dely = alp - float(j)*dqiacralpha
3597 ip1 = min( i+1, nqiacrratio )
3598 jp1 = min( j+1, nqiacralpha )
3599
3600 ! interpolate along x, i.e., ratio;
3601 tmp1 = gamxinflu(i,j,luindex,ilh) + delx*dqiacrratioinv* &
3602 & (gamxinflu(ip1,j,luindex,ilh) - gamxinflu(i,j,luindex,ilh))
3603 tmp2 = gamxinflu(i,jp1,luindex,ilh) + delx*dqiacrratioinv* &
3604 & (gamxinflu(ip1,jp1,luindex,ilh) - gamxinflu(i,jp1,luindex,ilh))
3605
3606 ! interpolate along alpha;
3607
3608 gaminterp = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))
3609
3610 ! debug
3611! IF ( ilh0 < 0 ) THEN
3612! write(0,*) 'gaminterp: ',i,j,ilh,ratio,delx,dely,gamxinflu(i,j,luindex,ilh),tmp1,tmp2
3613! ENDIF
3614
3615 END FUNCTION gaminterp
3616! #####################################################################
3617
3618!**************************** GAML02 ***********************
3619! This calculates Gamma(0.2,x)/Gamma[0.2], where is a ratio
3620! It is used for qiacr with the gamma of volume to calculate what
3621! fraction of drops exceed a certain size (this version is for 40 micron drops)
3622! **********************************************************
3625 real function gaml02(x)
3626 implicit none
3627 integer ig, i, ii, n, np
3628 real x
3629 integer ng
3630 parameter(ng=12)
3631 real gamxg(ng), xg(ng)
3632 DATA xg/0.01,0.02,0.025,0.04,0.075,0.1,0.25,0.5,0.75,1.,2.,10./
3633 DATA gamxg/ &
3634 & 7.391019203578037e-8,0.02212726874591478,0.06959352407989682, &
3635 & 0.2355654024970809,0.46135930387500346,0.545435791452399, &
3636 & 0.7371571313308203, &
3637 & 0.8265676632204345,0.8640182781845841,0.8855756211304151, &
3638 & 0.9245079225301251, &
3639 & 0.9712578342732681/
3640 IF ( x .ge. xg(ng) ) THEN
3641 gaml02 = xg(ng)
3642 RETURN
3643 ENDIF
3644 IF ( x .lt. xg(1) ) THEN
3645 gaml02 = 0.0
3646 RETURN
3647 ENDIF
3648 DO ii = 1,ng-1
3649 i = ng - ii
3650 n = i
3651 np = n + 1
3652 IF ( x .ge. xg(i) ) THEN
3653! GOTO 2
3654 gaml02 = gamxg(n)+((x-xg(n))/(xg(np)-xg(n)))* &
3655 & ( gamxg(np) - gamxg(n) )
3656 RETURN
3657 ENDIF
3658 ENDDO
3659 RETURN
3660 END FUNCTION gaml02
3661
3662!**************************** GAML02d300 ***********************
3663! This calculates Gamma(0.2,x)/Gamma[0.2], where is a ratio
3664! It is used for qiacr with the gamma of volume to calculate what
3665! fraction of drops exceed a certain size (this version is for 300 micron drops) (see zieglerstuff.nb)
3666! **********************************************************
3669 real function gaml02d300(x)
3670 implicit none
3671 integer ig, i, ii, n, np
3672 real x
3673 integer ng
3674 parameter(ng=9)
3675 real gamxg(ng), xg(ng)
3676 DATA xg/0.04,0.075,0.1,0.25,0.5,0.75,1.,2.,10./
3677 DATA gamxg/ &
3678 & 0.0, &
3679 & 7.391019203578011e-8,0.0002260640810600053, &
3680 & 0.16567071824457152, &
3681 & 0.4231369044918005,0.5454357914523988, &
3682 & 0.6170290936864555, &
3683 & 0.7471346054110058,0.9037156157718299 /
3684 IF ( x .ge. xg(ng) ) THEN
3685 gaml02d300 = xg(ng)
3686 RETURN
3687 ENDIF
3688 IF ( x .lt. xg(1) ) THEN
3689 gaml02d300 = 0.0
3690 RETURN
3691 ENDIF
3692 DO ii = 1,ng-1
3693 i = ng - ii
3694 n = i
3695 np = n + 1
3696 IF ( x .ge. xg(i) ) THEN
3697! GOTO 2
3698 gaml02d300 = gamxg(n)+((x-xg(n))/(xg(np)-xg(n)))* &
3699 & ( gamxg(np) - gamxg(n) )
3700 RETURN
3701 ENDIF
3702 ENDDO
3703 RETURN
3704 END FUNCTION gaml02d300
3705!c
3706
3707! #####################################################################
3708! #####################################################################
3709
3710!**************************** GAML02 ***********************
3711! This calculates Gamma(0.2,x)/Gamma[0.2], where is a ratio
3712! It is used for qiacr with the gamma of volume to calculate what
3713! fraction of drops exceed a certain size (this version is for 500 micron drops) (see zieglerstuff.nb)
3714! **********************************************************
3717 real function gaml02d500(x)
3718 implicit none
3719 integer ig, i, ii, n, np
3720 real x
3721 integer ng
3722 parameter(ng=9)
3723 real gamxg(ng), xg(ng)
3724 DATA xg/0.04,0.075,0.1,0.25,0.5,0.75,1.,2.,10./
3725 DATA gamxg/ &
3726 & 0.0,0.0, &
3727 & 2.2346039e-13, 0.0221272687459, &
3728 & 0.23556540, 0.38710348, &
3729 & 0.48136183,0.6565833, &
3730 & 0.86918315 /
3731 IF ( x .ge. xg(ng) ) THEN
3732 gaml02d500 = xg(ng)
3733 RETURN
3734 ENDIF
3735 IF ( x .lt. xg(1) ) THEN
3736 gaml02d500 = 0.0
3737 RETURN
3738 ENDIF
3739 DO ii = 1,ng-1
3740 i = ng - ii
3741 n = i
3742 np = n + 1
3743 IF ( x .ge. xg(i) ) THEN
3744! GOTO 2
3745 gaml02d500 = gamxg(n)+((x-xg(n))/(xg(np)-xg(n)))* &
3746 & ( gamxg(np) - gamxg(n) )
3747 RETURN
3748 ENDIF
3749 ENDDO
3750 RETURN
3751 END FUNCTION gaml02d500
3752!c
3753
3754! #####################################################################
3755
3756! #####################################################################
3757
3758
3759 real function beta(p,q)
3760!
3761! ==========================================
3762! Purpose: Compute the beta function B(p,q)
3763! Input : p --- Parameter ( p > 0 )
3764! q --- Parameter ( q > 0 )
3765! Output: BT --- B(p,q)
3766! Routine called: GAMMA for computing gamma(x)
3767! ==========================================
3768!
3769! IMPLICIT real (A-H,O-Z)
3770 implicit none
3771 double precision p1,gp,q1,gq, ppq,gpq
3772 real p,q
3773
3774 p1 = p
3775 q1 = q
3776 CALL gammadp(p1,gp)
3777 CALL gammadp(q1,gq)
3778 ppq=p1+q1
3779 CALL gammadp(ppq,gpq)
3780 beta=gp*gq/gpq
3781 RETURN
3782 END function beta
3783
3784! #####################################################################
3785! #####################################################################
3786
3789 DOUBLE PRECISION FUNCTION gamma_dp(xx)
3790
3791 implicit none
3792 double precision xx
3793 integer j
3794
3795! Double precision ser,stp,tmp,x,y,cof(6)
3796
3797 real*8 ser,stp,tmp,x,y,cof(6)
3798 SAVE cof,stp
3799 DATA cof,stp/76.18009172947146d+0, &
3800 & -86.50532032941677d0, &
3801 & 24.01409824083091d0, &
3802 & -1.231739572450155d0, &
3803 & 0.1208650973866179d-2,&
3804 & -0.5395239384953d-5, &
3805 & 2.5066282746310005d0/
3806
3807 x = xx
3808 y = x
3809 tmp = x + 5.5d0
3810 tmp = (x + 0.5d0)*log(tmp) - tmp
3811 ser = 1.000000000190015d0
3812 DO j=1,6
3813 y = y + 1.0d0
3814 ser = ser + cof(j)/y
3815 END DO
3816 gamma_dp = exp(tmp + log(stp*ser/x))
3817
3818 RETURN
3819 END function gamma_dp
3820! #####################################################################
3821
3824 SUBROUTINE gammadp(X,GA)
3825!
3826! ==================================================
3827! Purpose: Compute gamma function Gamma(x)
3828! Input : x --- Argument of Gamma(x)
3829! ( x is not equal to 0,-1,-2,...)
3830! Output: GA --- gamma(x)
3831! ==================================================
3832!
3833! IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3834 implicit none
3835
3836 double precision, parameter :: pi=3.141592653589793d0
3837 double precision :: x,ga,z,r,gr
3838 integer :: k,m1,m
3839
3840 double precision :: g(26)
3841
3842 IF (x.EQ.int(x)) THEN
3843 IF (x.GT.0.0d0) THEN
3844 ga=1.0d0
3845 m1=x-1
3846 DO k=2,m1
3847 ga=ga*k
3848 ENDDO
3849 ELSE
3850 ga=1.0d+300
3851 ENDIF
3852 ELSE
3853 IF (dabs(x).GT.1.0d0) THEN
3854 z=dabs(x)
3855 m=int(z)
3856 r=1.0d0
3857 DO k=1,m
3858 r=r*(z-k)
3859 ENDDO
3860 z=z-m
3861 ELSE
3862 z=x
3863 ENDIF
3864 DATA g/1.0d0,0.5772156649015329d0, &
3865 & -0.6558780715202538d0, -0.420026350340952d-1, &
3866 & 0.1665386113822915d0,-.421977345555443d-1, &
3867 & -.96219715278770d-2, .72189432466630d-2, &
3868 & -.11651675918591d-2, -.2152416741149d-3, &
3869 & .1280502823882d-3, -.201348547807d-4, &
3870 & -.12504934821d-5, .11330272320d-5, &
3871 & -.2056338417d-6, .61160950d-8, &
3872 & .50020075d-8, -.11812746d-8, &
3873 & .1043427d-9, .77823d-11, &
3874 & -.36968d-11, .51d-12, &
3875 & -.206d-13, -.54d-14, .14d-14, .1d-15/
3876 gr=g(26)
3877 DO k=25,1,-1
3878 gr=gr*z+g(k)
3879 ENDDO
3880 ga=1.0d0/(gr*z)
3881 IF (dabs(x).GT.1.0d0) THEN
3882 ga=ga*r
3883 IF (x.LT.0.0d0) ga=-pi/(x*ga*dsin(pi*x))
3884 ENDIF
3885 ENDIF
3886 RETURN
3887 END SUBROUTINE gammadp
3888
3889
3890! #####################################################################
3891! #####################################################################
3892!
3893!
3894! #####################################################################
3897 Function delbk(bb,nu,mu,k)
3898!
3899! Purpose: Caluculates collection coefficients following Siefert (2006)
3900!
3901! delbk is equation (90) (b collecting b -- self-collection)
3902! mass-diameter relationship: D = a*x**(b), where x = particle mass
3903! general distribution: n(x) = A*x**(nu)*Exp(-lam*x**(mu))
3904! where
3905! A = mu*N/(Gamma((nu+1)/mu)) *lam**((nu+1)/mu)
3906!
3907! lam = ( Gamma((nu+1)/mu)/Gamma((nu+2)/mu) * xbar )**(-mu)
3908!
3909! where xbar = L/N (mass content)/(number concentration) = q*rhoa/N
3910!
3911
3912 implicit none
3913 real delbk
3914 real nu, mu, bb
3915 integer k
3916
3917 real tmp, del
3918 real x1, x2, x3, x4
3919 integer i
3920
3921 tmp = ((1.0 + nu)/mu)
3922 i = int(dgami*(tmp))
3923 del = tmp - dgam*i
3924 x1 = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
3925
3926 tmp = ((2.0 + nu)/mu)
3927 i = int(dgami*(tmp))
3928 del = tmp - dgam*i
3929 x2 = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
3930
3931 tmp = ((1.0 + 2.0*bb + k + nu)/mu)
3932 i = int(dgami*(tmp))
3933 del = tmp - dgam*i
3934 x3 = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
3935
3936! delbk = &
3937! & ((Gamma_sp((1.0 + nu)/mu)/Gamma_sp((2.0 + nu)/mu))**(2.0*bb + k)* &
3938! & Gamma_sp((1.0 + 2.0*bb + k + nu)/mu))/Gamma_sp((1.0 + nu)/mu)
3939
3940 delbk = &
3941 & ((x1/x2)**(2.0*bb + k)* &
3942 & x3)/x1
3943
3944 RETURN
3945 END Function delbk
3946
3947! #####################################################################
3948!
3949!
3950! #####################################################################
3951! Equation (91) in Seifert and Beheng (2006) ("a" collecting "b")
3954 Function delabk(ba,bb,nua,nub,mua,mub,k)
3955
3956 implicit none
3957 real delabk
3958 real nua, mua, ba
3959 integer k
3960 real nub, mub, bb
3961
3962 integer i
3963 real tmp,del
3964
3965 real g1pnua, g2pnua, g1pbapnua, g1pbbpk, g1pnub, g2pnub
3966
3967 tmp = (1. + nua)/mua
3968 i = int(dgami*(tmp))
3969 del = tmp - dgam*i
3970 IF ( i+1 > ngm0 ) THEN
3971 write(0,*) 'delabk: i+1 > ngm0!!!!',i,ngm0,nua,mua,tmp
3972 ENDIF
3973 g1pnua = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
3974! write(91,*) 'delabk: g1pnua,gamma = ',g1pnua,Gamma_sp((1. + nua)/mua)
3975
3976 tmp = ((2. + nua)/mua)
3977 i = int(dgami*(tmp))
3978 del = tmp - dgam*i
3979 g2pnua = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
3980
3981 tmp = ((1. + ba + nua)/mua)
3982 i = int(dgami*(tmp))
3983 del = tmp - dgam*i
3984 g1pbapnua = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
3985
3986 tmp = ((1. + nub)/mub)
3987 i = int(dgami*(tmp))
3988 del = tmp - dgam*i
3989 g1pnub = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
3990
3991 tmp = ((2 + nub)/mub)
3992 i = int(dgami*(tmp))
3993 del = tmp - dgam*i
3994 g2pnub = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
3995
3996 tmp = ((1. + bb + k + nub)/mub)
3997 i = int(dgami*(tmp))
3998 del = tmp - dgam*i
3999 g1pbbpk = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
4000
4001 delabk = &
4002 & (2.*(g1pnua/g2pnua)**ba* &
4003 & g1pbapnua* &
4004 & (g1pnub/g2pnub)**(bb + k)* &
4005 & g1pbbpk)/ &
4006 & (g1pnua*g1pnub)
4007
4008 RETURN
4009 END Function delabk
4010
4011
4012
4013! #######################################################################
4014! HAILMAXD - calculated maximum expected hail size
4015! #######################################################################
4018 subroutine hailmaxd(dtp,nx,ny,nz,an,na,nor,norz,alpha2d,dn, &
4019 & hailmax1d,hailmaxk1,jslab )
4020!
4021! Calculate maximum hail size from the tail of of the distribution. The value
4022! of thresh_conc sets the minimum concentration in the integral over (Dmax, Inf).
4023! This uses the lookup tables for incomplete gamma functions and simply search for
4024! the expected value (and linearly interpolate) on D.
4025!
4026! Written by ERM 7/2023
4027!
4028!
4029!
4030 implicit none
4031
4032 integer nx,ny,nz,nor,norz,ngt,jgs,na,ia
4033 integer id ! =1 use density, =0 no density
4034! integer :: its,ite ! x-range to calculate
4035
4036 integer ng1
4037 parameter(ng1 = 1)
4038
4039 real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na)
4040 real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
4041
4042! real gz(-nor+ng1:nz+nor),z1d(-nor+ng1:nz+nor,4)
4043 real dtp
4044 real alpha2d(-nor+1:nx+nor,1,-norz+1:nz+norz,3) ! array for PSD shape parameters
4045 real :: hailmax1d(nx,ny),hailmaxk1(nx,ny)
4046 integer infdo
4047 integer jslab ! which line of xfall to use
4048
4049 integer ix,jy,kz,ndfall,n,k,il,in
4050 double precision :: tmp, ratio, del, g1palp
4051 real, parameter :: dz = 200.
4052
4053 real :: db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1)
4054
4055 real :: rhovtzx(nz,nx)
4056
4057 real :: alp, diam, diam1, hwdn
4058
4059! real, parameter :: cmin = 0.001 ! threshold number per m^3 for maximum diamter (threshold from diag_nwp)
4060 DOUBLE PRECISION, PARAMETER:: thresh_conc = 0.0005d0 ! number conc. of graupel/hail per cubic meter
4061 real :: cwchtmp,cwchltmp, maxdia
4062
4063!-----------------------------------------------------------------------------
4064
4065 integer :: ixb, jyb, kzb
4066 integer :: ixe, jye, kze
4067 integer :: plo, phi
4068 integer :: ialp, i, j
4069
4070 logical :: debug_mpi = .true.
4071
4072! ###################################################################
4073
4074
4075 IF ( lh > 1 ) THEN
4076 cwchtmp = ((3. + dnu(lh))*(2. + dnu(lh))*(1.0 + dnu(lh)))**(-1./3.)
4077 ENDIF
4078 IF ( lhl > 1 ) THEN
4079 cwchltmp = ((3. + dnu(lhl))*(2. + dnu(lhl))*(1.0 + dnu(lhl)))**(-1./3.)
4080 ENDIF
4081
4082
4083 kzb = 1
4084 kze = nz
4085
4086 ixb = 1 ! aliased its
4087 ixe = nx ! aliased ite
4088
4089
4090 jy = jslab
4091 jgs = jy
4092
4093
4094! hailmax1d(:,jy) = 0.0
4095! hailmaxk1(:,jy) = 0.0
4096
4097 if ( ndebug .gt. 0 ) write(0,*) 'dbg = 3a'
4098
4099
4100! first graupel, even if hail is also predicted, since graupel can sometime be large on its own
4101 IF ( lh > 1 .and. lnh > 1 ) THEN
4102 DO kz = kzb,kze
4103 DO ix = ixb,ixe
4104 IF ( an(ix,jy,kz,lh) .gt. qxmin(lh) .and. an(ix,jy,kz,lnh) .gt. thresh_conc ) THEN
4105 IF ( lvh .gt. 1 ) THEN
4106 hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh)
4107 ELSE
4108 hwdn = rho_qh
4109 ENDIF
4110
4111 tmp = 1. + alpha2d(ix,1,kz,2)
4112 i = int(dgami*(tmp))
4113 del = tmp - dgam*i
4114 g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
4115
4116 tmp = dn(ix,jy,kz)*an(ix,jy,kz,lh)/(hwdn*an(ix,jy,kz,lnh))
4117 diam = (6.0*tmp/pi)**(1./3.)
4118 IF ( lzh > 1 ) THEN ! 3moment
4119 cwchtmp = ((3. + alpha2d(ix,1,kz,2))*(2. + alpha2d(ix,1,kz,2))*(1.0 + alpha2d(ix,1,kz,2)))**(-1./3.)
4120 ENDIF
4121 diam1 = diam*cwchtmp ! characteristic diameter, i.e., 1/lambda
4122 ! want cxd1 = thresh_conc
4123 ! tmp = gaminterp(ratio,alpha(mgs,lh),1,1)
4124 ! cxd1 = cx(mgs,lh)*(tmp)/g1palp
4125 ! tmp = thresh_conc*g1palp/cx
4126 !
4127 tmp = thresh_conc*g1palp/an(ix,jy,kz,lnh)
4128 alp = alpha2d(ix,1,kz,2)
4129 ! gamxinflu(i,j,luindex,ilh)
4130 j = int(max(0.0,min(maxalphalu,alp))*dqiacralphainv)
4131 ratio = 0.0
4132 maxdia = 0.0
4133 ! eventually could replace with bisection search, but final value of i is usually small
4134 ! compared to nqiacrratio
4135 DO i = 0,nqiacrratio-1
4136 IF ( gamxinflu(i,j,1,1) >= tmp .and. tmp >= gamxinflu(i+1,j,1,1) ) THEN
4137 ! interpolate here for FWIW
4138 ratio = i*dqiacrratio
4139 del = tmp - gamxinflu(i,j,1,1)
4140 ratio = (float(i) + del/(gamxinflu(i+1,j,1,1) - gamxinflu(i,j,1,1)))*dqiacrratio
4141 exit
4142 ENDIF
4143 ENDDO
4144
4145 IF ( ratio > 0.0 ) THEN
4146 maxdia = ratio*diam1 ! units of m
4147 ENDIF
4148
4149 IF ( kz == kzb ) THEN
4150 hailmaxk1(ix,jy) = max( maxdia, hailmaxk1(ix,jy) )
4151! IF ( maxdia > 0.1 ) THEN
4152! IF ( an(ix,jy,kz,lh) > 1.e-4 ) THEN
4153! write(0,*) 'maxdia,tmp,alp,ratio,diam,diam1= ',maxdia,tmp,alp,ratio,diam*100.,diam1*100.
4154! write(0,*) 'hwdn, cxhl, qx, g1palp = ',hwdn, an(ix,jy,kz,lnhl), an(ix,jy,kz,lhl), g1palp
4155! write(0,*) 'j,gamxinflu(0,2,4) = ',j,gamxinflu(0,j,1,1),gamxinflu(2,j,1,1), &
4156! gamxinflu(4,j,1,1)
4157! ENDIF
4158 ENDIF
4159
4160 hailmax1d(ix,jy) = max(maxdia, hailmax1d(ix,jy) )
4161
4162 !
4163
4164 ENDIF
4165
4166 ENDDO
4167 ENDDO
4168
4169 ENDIF ! lh
4170
4171! And diam for hail if present
4172 IF ( lhl > 1 .and. lnhl > 1 ) THEN
4173 DO kz = kzb,kze
4174 DO ix = ixb,ixe
4175 IF ( an(ix,jy,kz,lhl) .gt. qxmin(lhl) .and. an(ix,jy,kz,lnhl) .gt. thresh_conc ) THEN
4176 IF ( lvhl .gt. 1 ) THEN
4177 hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl)
4178 ELSE
4179 hwdn = rho_qhl
4180 ENDIF
4181
4182 tmp = 1. + alpha2d(ix,1,kz,3)
4183 i = int(dgami*(tmp))
4184 del = tmp - dgam*i
4185 g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
4186
4187 tmp = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/(hwdn*an(ix,jy,kz,lnhl))
4188 diam = (6.0*tmp/pi)**(1./3.)
4189 IF ( lzhl > 1 ) THEN ! 3moment
4190 cwchltmp = ((3. + alpha2d(ix,1,kz,3))*(2. + alpha2d(ix,1,kz,3))*(1.0 + alpha2d(ix,1,kz,3)))**(-1./3.)
4191 ENDIF
4192 diam1 = diam*cwchltmp ! characteristic diameter, i.e., 1/lambda
4193 ! want cxd1 = thresh_conc
4194 ! tmp = gaminterp(ratio,alpha(mgs,lh),1,1)
4195 ! cxd1 = cx(mgs,lh)*(tmp)/g1palp
4196 ! tmp = thresh_conc*g1palp/cx
4197 !
4198 tmp = thresh_conc*g1palp/an(ix,jy,kz,lnhl)
4199 alp = alpha2d(ix,1,kz,3)
4200 ! gamxinflu(i,j,luindex,ilh)
4201 j = int(max(0.0,min(maxalphalu,alp))*dqiacralphainv)
4202 ratio = 0.0
4203 maxdia = 0.0
4204 ! eventually could replace with bisection search, but final value of i is usually small
4205 ! compared to nqiacrratio
4206 DO i = 0,nqiacrratio-1
4207 IF ( gamxinflu(i,j,1,1) >= tmp .and. tmp >= gamxinflu(i+1,j,1,1) ) THEN
4208 ! interpolate here for FWIW
4209 ratio = i*dqiacrratio
4210 del = tmp - gamxinflu(i,j,1,1)
4211 ratio = (float(i) + del/(gamxinflu(i+1,j,1,1) - gamxinflu(i,j,1,1)))*dqiacrratio
4212 exit
4213 ENDIF
4214 ENDDO
4215
4216 IF ( ratio > 0.0 ) THEN
4217 maxdia = ratio*diam1 ! units of m
4218 ENDIF
4219
4220 IF ( kz == kzb ) THEN
4221 hailmaxk1(ix,jy) = max( maxdia, hailmaxk1(ix,jy) )
4222! IF ( maxdia > 0.1 ) THEN
4223! IF ( an(ix,jy,kz,lhl) > 1.e-4 ) THEN
4224! write(0,*) 'maxdia,tmp,alp,ratio,diam,diam1= ',maxdia,tmp,alp,ratio,diam*100.,diam1*100.
4225! write(0,*) 'hwdn, cxhl, qx, g1palp = ',hwdn, an(ix,jy,kz,lnhl), an(ix,jy,kz,lhl), g1palp
4226! write(0,*) 'j,gamxinflu(0,2,4) = ',j,gamxinflu(0,j,1,1),gamxinflu(2,j,1,1), &
4227! gamxinflu(4,j,1,1)
4228! ENDIF
4229 ENDIF
4230
4231 hailmax1d(ix,jy) = max(maxdia, hailmax1d(ix,jy) )
4232
4233 !
4234
4235 ENDIF
4236
4237 ENDDO
4238 ENDDO
4239
4240 ENDIF
4241
4242
4243 END SUBROUTINE hailmaxd
4244! #######################################################################
4245! #######################################################################
4248 subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
4249 & t0,t7,infdo,jslab,its,jts, &
4250 & timesed1,timesed2,timesed3,zmaxsed,timesetvt) ! used for timing
4251!
4252! Sedimentation driver -- column by column
4253!
4254! Written by ERM 10/2011
4255!
4256!
4257!
4258 implicit none
4259
4260 integer nx,ny,nz,nor,norz,ngt,jgs,na,ia
4261 integer id ! =1 use density, =0 no density
4262 integer :: its,jts ! SW point of local tile
4263
4264 integer ng1
4265 parameter(ng1 = 1)
4266
4267 real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na)
4268 real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
4269 real dz3d(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
4270 real dz3dinv(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
4271 real t0(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
4272 real t7(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
4273
4274! real gz(-nor+ng1:nz+nor),z1d(-nor+ng1:nz+nor,4)
4275 real dtp
4276 real xfall(nx,ny,na) ! array for stuff landing on the ground
4277! real xfall0(nx,ny) ! dummy array
4278 integer infdo
4279 integer jslab ! which line of xfall to use
4280
4281 integer ix,jy,kz,ndfall,n,k,il,in
4282 real tmp, vtmax, dtptmp, dtfrac
4283 real, parameter :: dz = 200.
4284
4285! real :: xvt(nz+1,nx,3,lc:lhab) ! (nx,nz,2,lc:lhab) ! 1=mass-weighted, 2=number-weighted
4286! real :: tmpn(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz)
4287! real :: tmpn2(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz)
4288! real :: z(-nor+ng1:nx+nor,-norz+ng1:nz+norz,lr:lhab)
4289! real :: db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1)
4290
4291! real :: rhovtzx(nz,nx)
4292
4293 real, allocatable :: db1(:,:), dtz1(:,:,:),dz2dinv(:,:),db1inv(:,:) ! db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1)
4294 real, allocatable :: rhovtzx(:,:)
4295 real, allocatable :: xfall0(:,:), xvt(:,:,:,:),tmpn(:,:,:),tmpn2(:,:,:),z(:,:,:)
4296
4297 double precision :: timesed1,timesed2,timesed3, zmaxsed,timesetvt,dummy
4298 double precision :: dt1,dt2,dt3,dt4
4299
4300 integer :: ngs ! = 512
4301 integer :: ngscnt,mgs,ipconc0
4302
4303! real :: qx(ngs,lv:lhab)
4304! real :: qxw(ngs,ls:lhab)
4305! real :: cx(ngs,lc:lhab)
4306! real :: xv(ngs,lc:lhab)
4307! real :: vtxbar(ngs,lc:lhab,3)
4308! real :: xmas(ngs,lc:lhab)
4309! real :: xdn(ngs,lc:lhab)
4310! real :: xdia(ngs,lc:lhab,3)
4311! real :: vx(ngs,li:lhab)
4312! real :: alpha(ngs,lc:lhab)
4313! real :: zx(ngs,lr:lhab)
4314! logical :: hasmass(nx,lc+1:lhab)
4315!
4316! integer igs(ngs),kgs(ngs)
4317!
4318! real rho0(ngs),temcg(ngs)
4319!
4320! real temg(ngs)
4321!
4322! real rhovt(ngs)
4323!
4324! real cwnc(ngs),cinc(ngs)
4325! real fadvisc(ngs),cwdia(ngs),cipmas(ngs)
4326!
4327! real cimasn,cimasx,cnina(ngs),cimas(ngs)
4328!
4329! real cnostmp(ngs)
4330
4331 real, allocatable :: qx(:,:)
4332 real, allocatable :: qxw(:,:)
4333 real, allocatable :: cx(:,:)
4334 real, allocatable :: xv(:,:)
4335 real, allocatable :: vtxbar(:,:,:)
4336 real, allocatable :: xmas(:,:)
4337 real, allocatable :: xdn(:,:)
4338 real, allocatable :: xdia(:,:,:)
4339 real, allocatable :: vx(:,:)
4340 real, allocatable :: alpha(:,:)
4341 real, allocatable :: zx(:,:)
4342 logical, allocatable :: hasmass(:,:)
4343
4344 integer, allocatable :: igs(:),kgs(:)
4345
4346 real, allocatable :: rho0(:),temcg(:)
4347
4348 real, allocatable :: temg(:)
4349
4350 real, allocatable :: rhovt(:)
4351
4352 real, allocatable :: cwnc(:),cinc(:)
4353 real, allocatable :: fadvisc(:),cwdia(:),cipmas(:)
4354
4355 real, allocatable :: cnina(:),cimas(:)
4356
4357 real, allocatable :: cnostmp(:)
4358
4359 real :: cimasn,cimasx
4360
4361
4362!-----------------------------------------------------------------------------
4363
4364 integer :: ixb, jyb, kzb
4365 integer :: ixe, jye, kze
4366 integer :: plo, phi
4367
4368 logical :: debug_mpi = .true.
4369
4370! ###################################################################
4371
4372
4373 allocate( db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1),rhovtzx(nz,nx) )
4374 allocate( xfall0(nx,ny), xvt(nz+1,nx,3,lc:lhab), tmpn(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) )
4375 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))
4376
4377 ngs = nz+3
4378
4379 allocate( qx(ngs,lv:lhab), &
4380 qxw(ngs,ls:lhab), &
4381 cx(ngs,lc:lhab), &
4382 xv(ngs,lc:lhab), &
4383 vtxbar(ngs,lc:lhab,3), &
4384 xmas(ngs,lc:lhab), &
4385 xdn(ngs,lc:lhab), &
4386 xdia(ngs,lc:lhab,3), &
4387 vx(ngs,li:lhab), &
4388 alpha(ngs,lc:lhab), &
4389 zx(ngs,lr:lhab), &
4390 hasmass(nx,lc+1:lhab), &
4391 igs(ngs),kgs(ngs), &
4392 rho0(ngs),temcg(ngs),temg(ngs), rhovt(ngs), &
4393 cwnc(ngs),cinc(ngs), &
4394 fadvisc(ngs),cwdia(ngs),cipmas(ngs), &
4395 cnina(ngs),cimas(ngs), &
4396 cnostmp(ngs) )
4397
4398 kzb = 1
4399 kze = nz
4400
4401 ixb = 1
4402 ixe = nx
4403
4404
4405 jy = 1
4406 jgs = jy
4407
4408
4409!
4410! zero the precip flux arrays (2d)
4411!
4412
4413 xvt(:,:,:,:) = 0.0
4414
4415 if ( ndebug .gt. 0 ) write(0,*) 'dbg = 3a'
4416
4417
4418 DO kz = kzb,kze
4419 DO ix = ixb,ixe
4420 db1(ix,kz) = dn(ix,jy,kz)
4421 db1inv(ix,kz) = 1./dn(ix,jy,kz)
4422 rhovtzx(kz,ix) = sqrt(rho00*min(1.0/0.05, db1inv(ix,kz))) ! prevent excessive rhovt
4423 ENDDO
4424 ENDDO
4425
4426 DO kz = kzb,kze
4427 DO ix = ixb,ixe
4428 dtz1(kz,ix,0) = dz3dinv(ix,jy,kz)
4429 dtz1(kz,ix,1) = dz3dinv(ix,jy,kz)*db1inv(ix,kz)
4430 dz2dinv(kz,ix) = dz3dinv(ix,jy,kz)
4431 ENDDO
4432 ENDDO
4433
4434 IF ( lzh .gt. 1 ) THEN
4435 DO kz = kzb,kze
4436 DO ix = ixb,ixe
4437 an(ix,jy,kz,lzh) = max( 0., an(ix,jy,kz,lzh) )
4438 ENDDO
4439 ENDDO
4440 ENDIF
4441
4442
4443 DO il = lc+1,lhab
4444 DO ix = ixb,ixe
4445! hasmass(ix,il) = Any( an(ix,jy,:,il) > qxmin(il) )
4446 ENDDO
4447 ENDDO
4448
4449
4450
4451
4452 if (ndebug .gt. 0 ) write(0,*) 'dbg = 3a2'
4453
4454! loop over columns
4455 DO ix = ixb,ixe
4456
4457 dummy = 0.d0
4458
4459
4460 call ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ix, &
4461 & xvt, rhovtzx, &
4462 & an,dn,ipconc,t0,t7,cwmasn,cwmasx, &
4463 & cwradn, &
4464 & qxmin,xdnmx,xdnmn,cdx,cno,xdn0,xvmn,xvmx, &
4465 & ngs,qx,qxw,cx,xv,vtxbar,xmas,xdn,xdia,vx,alpha,zx,igs,kgs, &
4466 & rho0,temcg,temg,rhovt,cwnc,cinc,fadvisc,cwdia,cipmas,cnina,cimas, &
4467 & cnostmp, &
4468 & infdo,0 &
4469 & )
4470
4471
4472! loop over each species and do sedimentation for all moments
4473 DO il = lc,lhab
4474 IF ( ido(il) == 0 ) cycle
4475
4476! IF ( .not. hasmass(ix,il) ) CYCLE
4477
4478! plo = nz
4479! phi = 0
4480
4481
4482 vtmax = 0.0
4483
4484 do kz = kzb,kze
4485
4486 ! apply limit vtmaxsed (08/20/2015)
4487 xvt(kz,ix,1,il) = min( vtmaxsed, xvt(kz,ix,1,il) )
4488 xvt(kz,ix,2,il) = min( vtmaxsed, xvt(kz,ix,2,il) )
4489 xvt(kz,ix,3,il) = min( vtmaxsed, xvt(kz,ix,3,il) )
4490
4491 vtmax = max(vtmax,xvt(kz,ix,1,il)*dz2dinv(kz,ix))
4492 vtmax = max(vtmax,xvt(kz,ix,2,il)*dz2dinv(kz,ix))
4493 vtmax = max(vtmax,xvt(kz,ix,3,il)*dz2dinv(kz,ix))
4494
4495! IF ( dtp*xvt(kz,ix,1,il)*dz2dinv(kz,ix) >= 0.7 .or. &
4496! & dtp*xvt(kz,ix,2,il)*dz2dinv(kz,ix) >= 0.7 .or. &
4497! & dtp*xvt(kz,ix,3,il)*dz2dinv(kz,ix) >= 0.7 ) THEN
4498!
4499! zmaxsed = Max(zmaxsed, float(kz) )
4500!! plo = Min(plo,kz)
4501!! phi = Max(phi,kz)
4502!
4503! ENDIF
4504
4505 ENDDO
4506
4507 IF ( vtmax == 0.0 ) cycle
4508
4509
4510
4511 IF ( dtp*vtmax .lt. 0.7 ) THEN ! check whether multiple steps are needed.
4512 ndfall = 1
4513 ELSE
4514 IF ( dtp > 20.0 ) THEN ! more stringent subdivision for large time steps
4515 ndfall = max(2, int(dtp*vtmax/0.7) + 1)
4516 ELSE ! more relaxed for small time steps, but might still be a problem for very thin vertical layers near the ground
4517 ndfall = 1+int(dtp*vtmax + 0.301)
4518 ENDIF
4519 ENDIF
4520
4521 IF ( ndfall .gt. 1 ) THEN
4522 dtptmp = dtp/real(ndfall)
4523! write(0,*) 'subdivide fallout on its,jts,ix,plo,phi = ',its,jts,ix,plo,phi
4524! write(0,*) 'for il,jsblab,c,ndfall = ',il,jslab,dtp*vtmax,ndfall
4525 ELSE
4526 dtptmp = dtp
4527 ENDIF
4528
4529 dtfrac = dtptmp/dtp
4530
4531
4532 DO n = 1,ndfall
4533
4534 IF ( do_accurate_sedimentation .and. n .ge. 2 .and. ( n == interval_sedi_vt*(n/interval_sedi_vt) ) ) THEN
4535!
4536! zero the precip flux arrays (2d)
4537!
4538
4539 dummy = 0.d0
4540
4541 xvt(kzb:kze,ix,1:3,il) = 0.0 ! reset to zero because routine will only compute points with q > qmin
4542
4543 call ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ix, &
4544 & xvt, rhovtzx, &
4545 & an,dn,ipconc,t0,t7,cwmasn,cwmasx, &
4546 & cwradn, &
4547 & qxmin,xdnmx,xdnmn,cdx,cno,xdn0,xvmn,xvmx, &
4548 & ngs,qx,qxw,cx,xv,vtxbar,xmas,xdn,xdia,vx,alpha,zx,igs,kgs, &
4549 & rho0,temcg,temg,rhovt,cwnc,cinc,fadvisc,cwdia,cipmas,cnina,cimas, &
4550 & cnostmp, &
4551 & infdo,il)
4552
4553
4554 DO kz = kzb,kze
4555 ! apply limit vtmaxsed (08/20/2015)
4556 xvt(kz,ix,1,il) = min( vtmaxsed, xvt(kz,ix,1,il) )
4557 xvt(kz,ix,2,il) = min( vtmaxsed, xvt(kz,ix,2,il) )
4558 xvt(kz,ix,3,il) = min( vtmaxsed, xvt(kz,ix,3,il) )
4559 ENDDO
4560
4561
4562
4563
4564 ENDIF ! (n .ge. 2)
4565
4566
4567 IF ( il >= lr .and. ( infall .eq. 3 .or. infall .eq. 4 ) .and. ln(il) > 0 ) THEN
4568 IF ( (il .eq. lr .and. irfall .eq. infall .and. lzr < 1) .or. &
4569 (il .ge. lh .and. lz(il) .lt. 1 ) .or. (il == ls .and. isfall == infall ) ) THEN
4570 call calczgr1d(nx,ny,nz,nor,na,an,ixe,kze, &
4571 & z,db1,jgs,ipconc, dnu(il), il, ln(il), qxmin(il), xvmn(il), xvmx(il), lvol(il), xdn0(il), ix )
4572 ENDIF
4573 ENDIF
4574
4575 if (ndebug .gt. 0 ) write(0,*) 'dbg = 1b'
4576
4577! mixing ratio
4578
4579 call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,1,il), &
4580 & an,db1,il,1,xfall,dtz1,ix)
4581
4582
4583 if (ndebug .gt. 0 ) write(0,*) 'dbg = 3c'
4584
4585! volume
4586
4587 IF ( ldovol .and. il >= li ) THEN
4588 IF ( lvol(il) .gt. 1 ) THEN
4589 call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,1,il), &
4590 & an,db1,lvol(il),0,xfall,dtz1,ix)
4591 ENDIF
4592 ENDIF
4593
4594! reflectivity
4595
4596 IF ( ipconc .ge. 6 ) THEN
4597 IF ( lz(il) .gt. 1 ) THEN
4598 call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,3,il), &
4599 & an,db1,lz(il),0,xfall,dtz1,ix)
4600 ENDIF
4601 ENDIF
4602
4603 if (ndebug .gt. 0 ) write(0,*) 'dbg = 3d'
4604
4605
4606 IF ( ipconc .gt. 0 ) THEN !{
4607 IF ( ipconc .ge. ipc(il) ) THEN
4608
4609 IF ( ( infall .ge. 2 .or. (infall .eq. 0 .and. il .lt. lh) ) .and. lz(il) .lt. 1) THEN !{
4610!
4611! load number conc. into tmpn to do fallout by mass-weighted mean fall speed
4612! to put a lower bound on number conc.
4613!
4614
4615 IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. ( (il == ls .and. isfall .eq. infall ) &
4616 & .or. il .eq. lh .or. il .eq. lhl .or. il == lf .or. &
4617 & ( il .eq. lr .and. irfall .eq. infall) ) ) THEN
4618
4619 ! set up for method I+II
4620 DO kz = kzb,kze
4621! DO ix = ixb,ixe
4622 tmpn2(ix,jy,kz) = z(ix,kz,il)
4623! ENDDO
4624 ENDDO
4625 DO kz = kzb,kze
4626! DO ix = ixb,ixe
4627 tmpn(ix,jy,kz) = an(ix,jy,kz,ln(il))
4628! ENDDO
4629 ENDDO
4630
4631 ELSE
4632 ! set up for method II only
4633 DO kz = kzb,kze
4634! DO ix = ixb,ixe
4635 tmpn(ix,jy,kz) = an(ix,jy,kz,ln(il))
4636! ENDDO
4637 ENDDO
4638
4639 ENDIF
4640
4641 ENDIF !}
4642
4643
4644 if (ndebug .gt. 0 ) write(0,*) 'dbg = 3f'
4645
4646 in = 2
4647 IF ( infall .eq. 1 ) in = 1
4648
4649 call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,in,il), &
4650 & an,db1,ln(il),0,xfall,dtz1,ix)
4651
4652
4653 IF ( lz(il) .lt. 1 ) THEN ! if not 3-moment, run one of the correction schemes
4654 IF ( (infall .ge. 2 .or. infall .eq. 3) .and. .not. (infall .eq. 0 .and. il .ge. lh) &
4655 & .and. ( il .eq. lr .or. (il .ge. li .and. il .le. lhab) )) THEN
4656! : .or. il .eq. lhl )) THEN
4657
4658 xfall0(:,jgs) = 0.0
4659
4660 IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. &
4661 & ( il .ge. lh .or. (il .eq. lr .and. irfall .eq. infall) &
4662 .or. (il .eq. ls .and. isfall .eq. infall) ) ) THEN
4663 call fallout1d(nx,ny,nz,nor,1,dtptmp,dtfrac,jgs,xvt(1,1,3,il), &
4664 & tmpn2,db1,1,0,xfall0,dtz1,ix)
4665 call fallout1d(nx,ny,nz,nor,1,dtptmp,dtfrac,jgs,xvt(1,1,1,il), &
4666 & tmpn,db1,1,0,xfall0,dtz1,ix)
4667 ELSE
4668 call fallout1d(nx,ny,nz,nor,1,dtptmp,dtfrac,jgs,xvt(1,1,1,il), &
4669 & tmpn,db1,1,0,xfall0,dtz1,ix)
4670 ENDIF
4671
4672 IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. ( (il .eq. lr .and. irfall .eq. infall) &
4673 & .or. il .ge. lh .or. (il == ls .and. isfall .eq. infall ) ) ) THEN
4674! "Method I" - dbz correction
4675
4676 call calcnfromz1d(nx,ny,nz,nor,na,an,tmpn2,ixe,kze, &
4677 & z,db1,jgs,ipconc, dnu(il), il, ln(il), qxmin(il), xvmn(il), xvmx(il),tmpn, &
4678 & lvol(il), xdn0(il), infall, ix)
4679
4680 ELSEIF ( infall .eq. 5 .and. il .ge. lh .or. ( il == lr .and. irfall == 5 ) ) THEN
4681
4682 DO kz = kzb,kze
4683! DO ix = ixb,ixe
4684 an(ix,jgs,kz,ln(il)) = max( an(ix,jgs,kz,ln(il)), 0.5* ( an(ix,jgs,kz,ln(il)) + tmpn(ix,jy,kz) ))
4685
4686! ENDDO
4687 ENDDO
4688
4689 ELSEIF ( .not. (il .eq. lr .and. irfall .eq. 0) .and. .not. (il .eq. ls .and. isfall .eq. 0) ) THEN
4690! "Method II" M-wgt N-fallout correction
4691
4692 DO kz = kzb,kze
4693! DO ix = ixb,ixe
4694
4695 an(ix,jgs,kz,ln(il)) = max( an(ix,jgs,kz,ln(il)), tmpn(ix,jy,kz) )
4696
4697! ENDDO
4698 ENDDO
4699 ENDIF
4700 ENDIF ! lz(il) .lt. 1
4701
4702
4703 ENDIF
4704 ENDIF
4705
4706
4707 ENDIF !}
4708
4709
4710 ENDDO ! n=1,ndfall
4711 ENDDO ! il
4712
4713 ENDDO ! ix
4714
4715
4716 deallocate( db1,dtz1,dz2dinv,db1inv,rhovtzx )
4717 deallocate( xfall0, xvt, tmpn )
4718 deallocate( tmpn2, z)
4719
4720 deallocate( qx, &
4721 qxw, &
4722 cx, &
4723 xv, &
4724 vtxbar, &
4725 xmas, &
4726 xdn, &
4727 xdia, &
4728 vx, &
4729 alpha, &
4730 zx, &
4731 hasmass, &
4732 igs,kgs, &
4733 rho0,temcg,temg, rhovt, &
4734 cwnc,cinc, &
4735 fadvisc,cwdia,cipmas, &
4736 cnina,cimas, &
4737 cnostmp )
4738
4739 RETURN
4740 END SUBROUTINE sediment1d
4741
4742
4743! #####################################################################
4744
4745!
4746! #####################################################################
4747
4748
4749!
4750!--------------------------------------------------------------------------
4751!
4752!--------------------------------------------------------------------------
4753!
4756 subroutine fallout1d(nx,ny,nz,nor,na,dtp,dtfrac,jgs,vt, &
4757 & a,db1,ia,id,xfall,dtz1,ixcol)
4758!
4759! First-order, upwind fallout scheme
4760!
4761! Written by ERM 6/10/2011
4762!
4763!
4764!
4765 implicit none
4766
4767 integer nx,ny,nz,nor,ngt,jgs,na,ia
4768 integer id ! =1 use density, =0 no density
4769 integer ng1
4770 parameter(ng1 = 1)
4771 integer :: ixcol
4772
4773! real dz3dinv(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor)
4774! real a(nx,ny,nz,na)
4775 real a(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,na) ! quantity to be 'advected'
4776 real vt(nz+1,nx) ! terminal speed for a
4777 real dtp,dtfrac
4778 real cmax
4779 real xfall(nx,ny,na) ! array for stuff landing on the ground
4780 real db1(nx,nz+1),dtz1(nz+1,nx,0:1)
4781
4782! Local
4783
4784 integer ix,jy,kz,n,k
4785 integer iv1,iv2
4786 real tmp
4787 integer imn,imx,kmn,kmx
4788 real qtmp1(nz+1)
4789
4790!-----------------------------------------------------------------------------
4791
4792 integer :: ixb, jyb, kzb
4793 integer :: ixe, jye, kze
4794
4795 logical :: debug_mpi = .true.
4796
4797! ###################################################################
4798
4799 jy = 1
4800
4801 iv1 = 0
4802 iv2 = 0
4803
4804 imn = nx
4805 imx = 1
4806 kmn = nz
4807 kmx = 1
4808
4809 cmax = 0.0
4810
4811 kzb = 1
4812 kze = nz
4813
4814 ixb = ixcol
4815 ixe = ixcol
4816 ix = ixcol
4817
4818 qtmp1(nz+1) = 0.0
4819
4820 DO kz = kzb,kze
4821! DO ix = ixb,ixe
4822! cmax = Max(cmax, vt(ix,kz)*dz3dinv(ix,jy,kz))
4823
4824 IF ( id == 1 ) THEN
4825 qtmp1(kz) = a(ix,jgs,kz,ia)*vt(kz,ix)*db1(ix,kz)
4826 ELSE
4827 qtmp1(kz) = a(ix,jgs,kz,ia)*vt(kz,ix)
4828 ENDIF
4829
4830 IF ( a(ix,jgs,kz,ia) .ne. 0.0 ) THEN
4831! imn = Min(ix,imn)
4832! imx = Max(ix,imx)
4833 kmn = min(kz,kmn)
4834 kmx = max(kz,kmx)
4835 ENDIF
4836! ENDDO
4837 ENDDO
4838
4839 kmn = max(1,kmn-1)
4840
4841! first check if fallout is worth doing
4842! IF ( cmax .eq. 0.0 .or. imn .gt. imx ) THEN
4843! RETURN
4844! ENDIF
4845
4846 IF ( kmn == 1 ) THEN
4847
4848 kz = 1
4849! do ix = imn,imx ! 1,nx-1
4850 xfall(ix,jy,ia) = xfall(ix,jy,ia) + a(ix,jgs,kz,ia)*vt(kz,ix)*dtfrac
4851! enddo
4852
4853 ENDIF
4854
4855 do kz = 1,nz
4856! do ix = 1,nx
4857 a(ix,jgs,kz,ia) = a(ix,jgs,kz,ia) + dtp*dtz1(kz,ix,id)*(qtmp1(kz+1) - qtmp1(kz) )
4858! enddo
4859 enddo
4860
4861
4862 RETURN
4863 END SUBROUTINE fallout1d
4864
4865! ##############################################################################
4866! ##############################################################################
4867
4870 subroutine calczgr1d(nx,ny,nz,nor,na,a,ixe,kze, &
4871 & z,db,jgs,ipconc, alpha, l,ln, qmin, xvmn,xvmx, lvol, rho_qx, ixcol)
4872
4873
4874 implicit none
4875
4876 integer nx,ny,nz,nor,na,ngt,jgs
4877 integer :: ixcol
4878 integer, parameter :: norz = 3
4879 real a(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor,na)
4880 real z(-nor+1:nx+nor,-nor+1:nz+nor,lr:lhab) ! reflectivity
4881 real db(nx,nz+1) ! air density
4882! real gt(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor,ngt)
4883
4884 integer ixe,kze
4885 real alpha
4886 real qmin
4887 real xvmn,xvmx
4888 integer ipconc
4889 integer l ! index for q
4890 integer ln ! index for N
4891 integer lvol ! index for volume
4892 real rho_qx
4893
4894
4895 integer ix,jy,kz
4896 real vr,qr,nrx,rd,xv,g1,zx,chw,xdn,ynu
4897
4898
4899 jy = jgs
4900 ix = ixcol
4901
4902 IF ( l .eq. lh .or. l .eq. lhl .or. ( l .eq. lr .and. imurain == 1 ) &
4903 .or. ( l .eq. ls .and. imusnow == 1 ) ) THEN
4904
4905
4906 DO kz = 1,kze
4907
4908
4909
4910 IF ( a(ix,jy,kz,l) .gt. qmin .and. a(ix,jy,kz,ln) .gt. 1.e-15 ) THEN
4911
4912 IF ( lvol .gt. 1 ) THEN
4913 IF ( a(ix,jy,kz,lvol) .gt. 0.0 ) THEN
4914 xdn = db(ix,kz)*a(ix,jy,kz,l)/a(ix,jy,kz,lvol)
4915 xdn = min( 900., max( hdnmn, xdn ) )
4916 ELSE
4917 xdn = rho_qx
4918 ENDIF
4919 ELSE
4920 xdn = rho_qx
4921 ENDIF
4922
4923 IF ( l == lr ) xdn = 1000.
4924
4925 qr = a(ix,jy,kz,l)
4926 xv = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln))
4927 chw = a(ix,jy,kz,ln)
4928
4929 IF ( xv .lt. xvmn .or. xv .gt. xvmx ) THEN
4930 xv = min( xvmx, max( xvmn,xv ) )
4931 chw = db(ix,kz)*a(ix,jy,kz,l)/(xv*xdn)
4932 ENDIF
4933
4934 g1 = (6.0 + alpha)*(5.0 + alpha)*(4.0 + alpha)/ &
4935 & ((3.0 + alpha)*(2.0 + alpha)*(1.0 + alpha))
4936 zx = g1*db(ix,kz)**2*(a(ix,jy,kz,l))*a(ix,jy,kz,l)/chw
4937! z(ix,kz,l) = 1.e18*zx*(6./(pi*1000.))**2
4938 z(ix,kz,l) = zx*(6./(pi*1000.))**2
4939
4940
4941! IF ( ny.eq.2 .and. kz .ge. 25 .and. kz .le. 29 .and. z(ix,kz,l) .gt. 0. ) THEN
4942! write(*,*) 'calczgr: z,dbz,xdn = ',ix,kz,z(ix,kz,l),10*log10(z(ix,kz,l)),xdn
4943! ENDIF
4944
4945 ELSE
4946
4947 z(ix,kz,l) = 0.0
4948
4949 ENDIF
4950
4951 ENDDO
4952
4953 ELSEIF ( (l == ls .and. imusnow == 3) .or. ( l .eq. lr .and. imurain == 3 ) ) THEN
4954
4955 xdn = rho_qx ! 1000.
4956 IF ( l == ls ) ynu = snu
4957 IF ( l == lr ) ynu = rnu
4958
4959 DO kz = 1,kze
4960
4961 IF ( a(ix,jy,kz,l) .gt. qmin .and. a(ix,jy,kz,ln) .gt. 1.e-15 ) THEN
4962
4963 vr = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln))
4964! z(ix,kz,l) = 3.6e18*(ynu+2.0)*a(ix,jy,kz,ln)*vr**2/(ynu+1.0)
4965 z(ix,kz,l) = 3.6*(ynu+2.0)*a(ix,jy,kz,ln)*vr**2/(ynu+1.0)
4966! qr = a(ix,jy,kz,lr)
4967! nrx = a(ix,jy,kz,lnr)
4968
4969 ELSE
4970
4971 z(ix,kz,l) = 0.0
4972
4973 ENDIF
4974
4975
4976 ENDDO
4977
4978 ENDIF
4979
4980 RETURN
4981
4982 END subroutine calczgr1d
4983
4984! ##############################################################################
4985! ##############################################################################
4986!
4987! Subroutine to correct number concentration to prevent reflectivity growth by
4988! sedimentation in 2-moment ZXX scheme.
4989! Calculation is in a slab (constant jgs)
4990!
4991
4994 subroutine calcnfromz1d(nx,ny,nz,nor,na,a,t0,ixe,kze, &
4995 & z0,db,jgs,ipconc, alpha, l,ln, qmin, xvmn,xvmx,t1, &
4996 & lvol, rho_qx, infall, ixcol)
4997
4998
4999 implicit none
5000
5001 integer nx,ny,nz,nor,na,ngt,jgs,ixcol
5002
5003 real a(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor,na) ! sedimented N and q
5004 real t0(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor) ! sedimented reflectivity
5005 real t1(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor) ! sedimented N (by Vm)
5006! real gt(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor,ngt)
5007 real z0(-nor+1:nx+nor,-nor+1:nz+nor,lr:lhab) ! initial reflectivity
5008
5009 real db(nx,nz+1) ! air density
5010
5011 integer ixe,kze
5012 real alpha
5013 real qmin
5014 real xvmn,xvmx
5015 integer ipconc
5016 integer l ! index for q
5017 integer ln ! index for N
5018 integer lvol ! index for volume
5019 real rho_qx
5020 integer infall
5021
5022
5023 integer ix,jy,kz
5024 double precision vr,qr,nrx,rd,g1,zx,chw,z,znew,zt,zxt
5025 real xv,xdn
5026 integer :: ndbz, nmwgt, nnwgt, nwlessthanz
5027
5028 ndbz = 0
5029 nmwgt = 0
5030 nnwgt = 0
5031 nwlessthanz = 0
5032
5033
5034
5035 jy = jgs
5036 ix = ixcol
5037
5038 IF ( l .eq. lh .or. l .eq. lhl .or. ( l == lr .and. imurain == 1 ) ) THEN
5039
5040 g1 = (6.0 + alpha)*(5.0 + alpha)*(4.0 + alpha)/ &
5041 & ((3.0 + alpha)*(2.0 + alpha)*(1.0 + alpha))
5042
5043 DO kz = 1,kze
5044
5045
5046 IF ( t0(ix,jy,kz) .gt. 0. ) THEN ! {
5047
5048 IF ( lvol .gt. 1 ) THEN
5049 IF ( a(ix,jy,kz,lvol) .gt. 0.0 ) THEN
5050 xdn = db(ix,kz)*a(ix,jy,kz,l)/a(ix,jy,kz,lvol)
5051 xdn = min( 900., max( hdnmn, xdn ) )
5052 ELSE
5053 xdn = rho_qx
5054 ENDIF
5055 ELSE
5056 xdn = rho_qx
5057 ENDIF
5058
5059 IF ( l == lr ) xdn = 1000.
5060
5061 qr = a(ix,jy,kz,l)
5062 xv = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln))
5063 chw = a(ix,jy,kz,ln)
5064
5065 IF ( xv .lt. xvmn .or. xv .gt. xvmx ) THEN
5066 xv = min( xvmx, max( xvmn,xv ) )
5067 chw = db(ix,kz)*a(ix,jy,kz,l)/(xv*xdn)
5068 ENDIF
5069
5070 zx = g1*db(ix,kz)**2*( a(ix,jy,kz,l))*a(ix,jy,kz,l)/chw
5071 z = zx*(6./(pi*1000.))**2
5072
5073
5074 IF ( (z .gt. t0(ix,jy,kz) .and. z .gt. 0.0 .and. &
5075 & t0(ix,jy,kz) .gt. z0(ix,kz,l) )) THEN !{
5076
5077 zx = t0(ix,jy,kz)/((6./(pi*1000.))**2)
5078
5079 nrx = g1*db(ix,kz)**2*( a(ix,jy,kz,l))*a(ix,jy,kz,l)/zx
5080 IF ( infall .eq. 3 ) THEN
5081 IF ( nrx .gt. a(ix,jy,kz,ln) ) THEN
5082 ndbz = ndbz + 1
5083 IF ( t1(ix,jy,kz) .lt. ndbz ) nwlessthanz = nwlessthanz + 1
5084 ELSE
5085 nnwgt = nnwgt + 1
5086 ENDIF
5087 a(ix,jy,kz,ln) = max( real(nrx), a(ix,jy,kz,ln) )
5088 ELSE
5089 IF ( nrx .gt. a(ix,jy,kz,ln) .and. t1(ix,jy,kz) .gt. a(ix,jy,kz,ln) ) THEN
5090 IF ( nrx .lt. t1(ix,jy,kz) ) THEN
5091 ndbz = ndbz + 1
5092 ELSE
5093 nmwgt = nmwgt + 1
5094 IF ( t1(ix,jy,kz) .lt. ndbz ) nwlessthanz = nwlessthanz + 1
5095 ENDIF
5096 ELSE
5097 nnwgt = nnwgt + 1
5098 ENDIF
5099
5100 a(ix,jy,kz,ln) = max(min( real(nrx), t1(ix,jy,kz) ), a(ix,jy,kz,ln) )
5101 ENDIF
5102
5103 ELSE ! } {
5104 IF ( t1(ix,jy,kz) .gt. 0 .and. a(ix,jy,kz,ln) .gt. 0 ) THEN
5105 IF ( t1(ix,jy,kz) .gt. a(ix,jy,kz,ln) ) THEN
5106 nmwgt = nmwgt + 1
5107 ELSE
5108 nnwgt = nnwgt + 1
5109 ENDIF
5110 ENDIF
5111 a(ix,jy,kz,ln) = max(t1(ix,jy,kz), a(ix,jy,kz,ln) )
5112 nrx = a(ix,jy,kz,ln)
5113
5114
5115
5116 ENDIF ! }
5117
5118 ! }
5119 ELSE ! {
5120 IF ( t1(ix,jy,kz) .gt. 0 .and. a(ix,jy,kz,ln) .gt. 0 ) THEN
5121 IF ( t1(ix,jy,kz) .gt. a(ix,jy,kz,ln) ) THEN
5122 nmwgt = nmwgt + 1
5123 ELSE
5124 nnwgt = nnwgt + 1
5125 ENDIF
5126 ENDIF
5127 endif! }
5128
5129 ENDDO
5130
5131
5132 ELSEIF ( l .eq. lr .and. imurain == 3) THEN
5133
5134 xdn = 1000.
5135
5136 DO kz = 1,kze
5137 IF ( t0(ix,jy,kz) .gt. 0. ) THEN
5138
5139 vr = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln))
5140 z = 3.6*(rnu+2.0)*a(ix,jy,kz,ln)*vr**2/(rnu+1.0)
5141
5142 IF ( z .gt. t0(ix,jy,kz) .and. z .gt. 0.0 .and. &
5143 & t0(ix,jy,kz) .gt. 0.0 &
5144 & .and. t0(ix,jy,kz) .gt. z0(ix,kz,l) ) THEN
5145
5146 vr = db(ix,kz)*a(ix,jy,kz,l)/(xdn)
5147 chw = a(ix,jy,kz,ln)
5148 nrx = 3.6*(rnu+2.0)*vr**2/((rnu+1.0)*t0(ix,jy,kz))
5149 IF ( infall .eq. 3 ) THEN
5150 a(ix,jy,kz,ln) = max( real(nrx), a(ix,jy,kz,ln) )
5151 ELSEIF ( infall .eq. 4 ) THEN
5152 a(ix,jy,kz,ln) = max( min( real(nrx), t1(ix,jy,kz)), a(ix,jy,kz,ln) )
5153 ENDIF
5154
5155 ELSE
5156
5157 a(ix,jy,kz,ln) = max(t1(ix,jy,kz), a(ix,jy,kz,ln) )
5158
5159 ENDIF
5160
5161 ELSE
5162
5163 a(ix,jy,kz,ln) = max(t1(ix,jy,kz), a(ix,jy,kz,ln) )
5164
5165 ENDIF
5166
5167
5168 ENDDO
5169
5170 ENDIF
5171
5172 RETURN
5173
5174 END subroutine calcnfromz1d
5175
5176
5177! ##############################################################################
5178! ##############################################################################
5179!
5180! Subroutine to calculate number concentrations from initial state that has only mixing ratio.
5181! Output N will be in #/m^3 in 'an' array, since sedimentation is done next.
5182! Output ccw,cci etc. will be in #/kg
5183
5184!
5185! 10.27.2015: Added hail calculation
5186!
5189 subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, &
5190 & qcw,qci,qsw,qrw,qhw,qhl, &
5191 & ccw,cci,csw,crw,chw,chl, &
5192 & cccn,cccna, vhw,vhl,qv,spechum, invertccn_flag, cwmasin )
5193
5194
5195
5196 implicit none
5197
5198 integer nx,ny,nz,nor,norz,na,ngt,jgs,ixcol
5199
5200 real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) ! scalars (q, N, Z)
5201
5202 real dn(nx,nz+1) ! air density
5203
5204 real, optional, dimension(nx,nz), intent(inout) :: qcw,qci,qsw,qrw,qhw,qhl, &
5205 ccw,cci,csw,crw,chw,chl, &
5206 cccn,cccna,vhw,vhl,qv, spechum
5207 logical, optional, intent(in) :: invertccn_flag
5208 real, optional :: cwmasin
5209
5210 integer ixe,kze
5211 real alpha
5212 real qmin
5213 real xvmn,xvmx
5214 integer ipconc
5215 integer lvol ! index for volume
5216 integer infall
5217
5218
5219 integer ix,jy,kz
5220 double precision vr,q,nrx,nrx2,rd,g1h,g1hl,g1r,g1s,zx,z,znew,zt,zxt,n1,laminv1
5221 double precision :: zr, zs, zh, dninv
5222 real, parameter :: xn0s = 3.0e6, xn0r = 8.0e6, xn0h = 2.0e5, xn0hl = 4.0e4
5223 real, parameter :: xdnr = 1000., xdns = 100. ,xdnh = 700.0, xdnhl = 900.0
5224 real, parameter :: zhlfac = 1./(pi*xdnhl*xn0hl)
5225 real, parameter :: zhfac = 1./(pi*xdnh*xn0h)
5226 real, parameter :: zrfac = 1./(pi*xdnr*xn0r)
5227 real, parameter :: zsfac = 1./(pi*xdns*xn0s)
5228 real, parameter :: g0 = (6.0)*(5.0)*(4.0)/((3.0)*(2.0)*(1.0))
5229 real, parameter :: xims=900.*0.523599*(2.*50.e-6)**3 ! mks (100 micron diam solid sphere approx)
5230 real, parameter :: xgms=xdnh*0.523599*(300.e-6)**3 ! mks (300 micron diam sphere approx)
5231 real, parameter :: cwmas09 = 1000.*0.523599*(2.*9.e-6)**3 ! mass of 9-micron radius droplet
5232
5233 real xv,xdn,cwmasinv
5234 integer :: ndbz, nmwgt, nnwgt, nwlessthanz
5235 double precision :: mixconv, mixconvqv, qsmax,qsmax2,qsmax3,qsmax4
5236 logical :: invertccn_local
5237
5238! ------------------------------------------------------------------
5239
5240 IF ( present( invertccn_flag ) ) THEN
5241 invertccn_local = invertccn_flag
5242 ELSE
5243 invertccn_local = .false.
5244 ENDIF
5245
5246 IF ( present( cwmasin ) ) THEN
5247 cwmasinv = 1.0/cwmasin
5248 ELSE
5249 cwmasinv = 1.0/cwmas09
5250 ENDIF
5251
5252 jy = 1
5253
5254
5255 g1h = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/ &
5256 & ((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah))
5257
5258 g1hl = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/ &
5259 & ((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl))
5260
5261 IF ( imurain == 3 ) THEN
5262 g1r = (rnu+2.0)/(rnu+1.0)
5263 ELSE ! imurain == 1
5264 g1r = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/ &
5265 & ((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar))
5266 ENDIF
5267
5268 g1s = (snu+2.0)/(snu+1.0)
5269 qsmax = 0
5270 qsmax2 = 0
5271 qsmax3 = 0
5272 qsmax4 = 0
5273! IF ( .not. present( qcw ) ) THEN
5274 DO kz = 1,nz
5275 DO ix = 1,nx ! ixcol
5276
5277! qv_mp = spechum/(1.0_kind_phys-spechum)
5278! IF ( convertdry ) THEN
5279! qc_mp = qc/(1.0_kind_phys-spechum)
5280 mixconv = 1
5281 IF ( present( spechum ) ) THEN ! convert to "dry" mixing ratios
5282 an(ix,jy,kz,lv) = spechum(ix,kz)/(1.0d0 - spechum(ix,kz))
5283 mixconv = 1.0d0/(1.0d0 - spechum(ix,kz))
5284 ELSE
5285 mixconv = 1.0d0
5286 ENDIF
5287 IF ( present( qv ) ) an(ix,jy,kz,lv) = qv(ix,kz) ! assume qv is "dry" mixing ratio if passed in
5288 IF ( present( qcw ) ) an(ix,jy,kz,lc) = qcw(ix,kz)*mixconv
5289 IF ( present( qrw ) ) an(ix,jy,kz,lr) = qrw(ix,kz)*mixconv
5290 IF ( present( qci ) ) an(ix,jy,kz,li) = qci(ix,kz)*mixconv
5291 IF ( present( qsw ) ) THEN
5292 an(ix,jy,kz,ls) = qsw(ix,kz)*mixconv
5293! qsmax = Max( qsmax, qsw(ix,kz) )
5294! qsmax2 = Max( qsmax2, an(ix,jy,kz,ls) )
5295 ENDIF
5296 IF ( present( qhw ) ) an(ix,jy,kz,lh) = qhw(ix,kz)*mixconv
5297 IF ( lhl > 1 .and. present( qhl ) ) an(ix,jy,kz,lhl) = qhl(ix,kz)*mixconv
5298 IF ( present( ccw ) ) an(ix,jy,kz,lnc) = ccw(ix,kz)*mixconv*dn(ix,kz)
5299 IF ( present( crw ) ) an(ix,jy,kz,lnr) = crw(ix,kz)*mixconv*dn(ix,kz)
5300 IF ( present( cci ) ) an(ix,jy,kz,lni) = cci(ix,kz)*mixconv*dn(ix,kz)
5301 IF ( present( csw ) ) an(ix,jy,kz,lns) = csw(ix,kz)*mixconv*dn(ix,kz)
5302 IF ( present( chw ) ) an(ix,jy,kz,lnh) = chw(ix,kz)*mixconv*dn(ix,kz)
5303 IF ( lhl > 1 .and. present( chl ) ) an(ix,jy,kz,lnhl) = chl(ix,kz)*mixconv*dn(ix,kz)
5304 IF ( lvh > 1 .and. present( vhw ) ) an(ix,jy,kz,lvh) = vhw(ix,kz)*mixconv
5305 IF ( lvhl > 1 .and. present( vhl ) ) an(ix,jy,kz,lvhl) = vhl(ix,kz)*mixconv
5306 IF ( lccn > 1 .and. present( cccn ) ) an(ix,jy,kz,lccn) = cccn(ix,kz)*mixconv*dn(ix,kz)
5307 IF ( lccna > 1 .and. present( cccna ) ) an(ix,jy,kz,lccna) = cccna(ix,kz)*mixconv
5308
5309 dninv = 1./dn(ix,kz)
5310
5311! IF ( .not. present( qcw ) ) THEN
5312 ! Cloud droplets
5313
5314 IF ( lnc > 1 ) THEN
5315 IF ( an(ix,jy,kz,lnc) <= cxmin .and. an(ix,jy,kz,lc) > qxmin_init(lc) ) THEN
5316
5317 an(ix,jy,kz,lnc) = min(qccn, an(ix,jy,kz,lc)*cwmasinv )*dn(ix,kz)
5318
5319 IF ( invertccn_local ) THEN
5320 an(ix,jy,kz,lccn) = an(ix,jy,kz,lccn) + an(ix,jy,kz,lnc)
5321 ELSE
5322
5323 IF ( lccn > 1 .and. lccna < 1 ) THEN
5324 an(ix,jy,kz,lccn) = an(ix,jy,kz,lccn) - an(ix,jy,kz,lnc)
5325 ENDIF
5326 IF ( lccna > 1 ) THEN
5327 an(ix,jy,kz,lccna) = an(ix,jy,kz,lccna) + an(ix,jy,kz,lnc)
5328 ENDIF
5329 ENDIF
5330
5331 ELSEIF ( an(ix,jy,kz,lc) <= qxmin(lc) .or. &
5332 ( an(ix,jy,kz,lnc) <= cxmin .and. an(ix,jy,kz,lc) <= qxmin_init(lc)) ) THEN
5333
5334 an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lc)
5335 an(ix,jy,kz,lnc) = 0.0
5336 an(ix,jy,kz,lc) = 0.0
5337
5338 ENDIF
5339 ENDIF
5340
5341 ! Cloud ice
5342
5343 IF ( lni > 1 ) THEN
5344 IF ( an(ix,jy,kz,lni) <= cxmin .and. an(ix,jy,kz,li) > qxmin_init(li) ) THEN
5345 an(ix,jy,kz,lni) = dn(ix,kz)*an(ix,jy,kz,li)/xims
5346
5347 ELSEIF ( an(ix,jy,kz,li) <= qxmin(li) .or. &
5348 ( an(ix,jy,kz,lni) <= cxmin .and. an(ix,jy,kz,li) <= qxmin_init(li)) ) THEN
5349 an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,li)
5350 an(ix,jy,kz,lni) = 0.0
5351 an(ix,jy,kz,li) = 0.0
5352 ENDIF
5353 ENDIF
5354
5355 ! rain
5356
5357 IF ( lnr > 1 ) THEN
5358 IF ( an(ix,jy,kz,lnr) <= 0.1*cxmin .and. an(ix,jy,kz,lr) > qxmin_init(lr) ) THEN
5359
5360 q = an(ix,jy,kz,lr)
5361
5362 laminv1 = (dn(ix,kz) * q * zrfac)**(0.25) ! inverse of slope
5363
5364 n1 = laminv1*xn0r ! number concentration for inv. exponential single moment input
5365
5366 nrx = n1*g1r/g0 ! number concentration for different shape parameter
5367
5368 an(ix,jy,kz,lnr) = nrx ! *dninv ! convert to number mixing ratio
5369
5370 ELSEIF ( an(ix,jy,kz,lr) <= qxmin(lr) .or. &
5371 ( an(ix,jy,kz,lnr) <= cxmin .and. an(ix,jy,kz,lr) <= qxmin_init(lr)) ) THEN
5372 an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lr)
5373 an(ix,jy,kz,lnr) = 0.0
5374 an(ix,jy,kz,lr) = 0.0
5375 ENDIF
5376 ENDIF
5377
5378 IF ( lzr > 1 ) THEN ! set reflectivity moment
5379 IF ( an(ix,jy,kz,lr) > qxmin_init(lr) .and. an(ix,jy,kz,lzr) < zxmin .and. &
5380 an(ix,jy,kz,lnr) > cxmin ) THEN
5381 q = an(ix,jy,kz,lr)
5382 nrx = an(ix,jy,kz,lnr)
5383 an(ix,jy,kz,lzr) = 36.*g1r*dn(ix,kz)**2*q**2/(pi**2*xdnr**2*nrx) ! *dninv
5384 ENDIF
5385 ENDIF
5386
5387 ! snow
5388 IF ( lns > 1 ) THEN
5389 IF ( an(ix,jy,kz,lns) <= 0.1*cxmin .and. an(ix,jy,kz,ls) > qxmin_init(ls) ) THEN
5390
5391 q = an(ix,jy,kz,ls)
5392
5393 laminv1 = (dn(ix,kz) * q * zsfac)**(0.25) ! inverse of slope
5394
5395 n1 = laminv1*xn0s ! number concentration for inv. exponential single moment input
5396
5397 nrx = n1*g1s/g0 ! number concentration for different shape parameter
5398
5399 an(ix,jy,kz,lns) = nrx ! *dninv ! convert to number mixing ratio
5400
5401 ELSEIF ( an(ix,jy,kz,ls) <= qxmin(ls) .or. &
5402 ( an(ix,jy,kz,lns) <= cxmin .and. an(ix,jy,kz,ls) <= qxmin_init(ls)) ) THEN
5403 an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,ls)
5404 an(ix,jy,kz,lns) = 0.0
5405 an(ix,jy,kz,ls) = 0.0
5406
5407 ENDIF
5408 ENDIF
5409
5410 ! graupel
5411
5412 IF ( lnh > 1 ) THEN
5413 IF ( an(ix,jy,kz,lnh) <= 0.1*cxmin .and. an(ix,jy,kz,lh) > qxmin_init(lh) ) THEN
5414 IF ( lvh > 1 ) THEN
5415 IF ( an(ix,jy,kz,lvh) <= 0.0 ) THEN
5416 an(ix,jy,kz,lvh) = an(ix,jy,kz,lh)/xdnh
5417 ENDIF
5418 ENDIF
5419
5420 q = an(ix,jy,kz,lh)
5421
5422 laminv1 = (dn(ix,kz) * q * zhfac)**(0.25) ! inverse of slope
5423
5424 n1 = laminv1*xn0h ! number concentration for inv. exponential single moment input
5425
5426 nrx = n1*g1h/g0 ! number concentration for different shape parameter
5427
5428 nrx2 = dn(ix,kz) * q / xgms
5429
5430 nrx = min( nrx, nrx2 )
5431
5432 IF ( nrx > cxmin ) THEN
5433 an(ix,jy,kz,lnh) = nrx ! *dninv ! convert to number mixing ratio
5434 ELSE
5435 an(ix,jy,kz,lh) = 0.0
5436 an(ix,jy,kz,lnh) = 0.0
5437 an(ix,jy,kz,lvh) = 0.0
5438 ENDIF
5439
5440 ELSEIF ( an(ix,jy,kz,lh) <= qxmin(lh) .or. &
5441 ( an(ix,jy,kz,lnh) <= cxmin .and. an(ix,jy,kz,lh) <= qxmin_init(lh)) ) THEN
5442
5443 an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lh)
5444 an(ix,jy,kz,lh) = 0.0
5445
5446 ENDIF
5447 ENDIF
5448
5449 IF ( lzh > 1 ) THEN ! set reflectivity moment
5450 IF ( an(ix,jy,kz,lh) > qxmin_init(lh) .and. an(ix,jy,kz,lzh) < zxmin .and. &
5451 an(ix,jy,kz,lnh) > cxmin ) THEN
5452 q = an(ix,jy,kz,lh)
5453 nrx = an(ix,jy,kz,lnh)
5454 an(ix,jy,kz,lzh) = 36.*g1h*dn(ix,kz)**2*q**2/(pi**2*xdnh**2*nrx) ! *dninv
5455 ENDIF
5456 ENDIF
5457
5458 ! hail
5459
5460 IF ( lnhl > 1 .and. lhl > 1 ) THEN
5461 IF ( an(ix,jy,kz,lnhl) <= 0.1*cxmin .and. an(ix,jy,kz,lhl) > qxmin_init(lhl) ) THEN
5462 IF ( lvhl > 1 ) THEN
5463 IF ( an(ix,jy,kz,lvhl) <= 0.0 ) THEN
5464 an(ix,jy,kz,lvhl) = an(ix,jy,kz,lhl)/xdnhl
5465 ENDIF
5466 ENDIF
5467
5468 q = an(ix,jy,kz,lhl)
5469
5470 laminv1 = (dn(ix,kz) * q * zhlfac)**(0.25) ! inverse of slope
5471
5472 n1 = laminv1*xn0hl ! number concentration for inv. exponential single moment input
5473
5474 nrx = n1*g1hl/g0 ! number concentration for different shape parameter
5475
5476 an(ix,jy,kz,lnhl) = nrx ! *dninv ! convert to number mixing ratio
5477
5478 ELSEIF ( an(ix,jy,kz,lhl) <= qxmin(lhl) .or. &
5479 ( an(ix,jy,kz,lnhl) <= cxmin .and. an(ix,jy,kz,lhl) <= qxmin_init(lhl)) ) THEN
5480
5481 an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lhl)
5482 an(ix,jy,kz,lhl) = 0.0
5483
5484 ENDIF
5485 ENDIF
5486
5487 IF ( lzhl > 1 ) THEN ! set reflectivity moment
5488 IF ( an(ix,jy,kz,lhl) > qxmin_init(lhl) .and. an(ix,jy,kz,lzhl) < zxmin .and. &
5489 an(ix,jy,kz,lnhl) > cxmin ) THEN
5490 q = an(ix,jy,kz,lhl)
5491 nrx = an(ix,jy,kz,lnhl)
5492 an(ix,jy,kz,lzhl) = 36.*g1hl*dn(ix,kz)**2*q**2/(pi**2*xdnhl**2*nrx) ! *dninv
5493 ENDIF
5494 ENDIF
5495
5496
5497! ENDIF
5498
5499! spechum = qv_mp/(1.0_kind_phys+qv_mp)
5500! IF ( convertdry ) THEN
5501! qc = qc_mp/(1.0_kind_phys+qv_mp)
5502 mixconvqv = 1
5503 IF ( present( spechum ) ) THEN ! convert back to "dry+vapor" mixing ratios
5504 !an(ix,jy,kz,lv) = spechum(ix,kz)/(1.0d0 - spechum(ix,kz))
5505 mixconvqv = 1.0d0/(1.0d0 + an(ix,jy,kz,lv))
5506 spechum(ix,kz) = an(ix,jy,kz,lv)*mixconvqv
5507 ELSE
5508 mixconvqv = 1.0d0
5509 ENDIF
5510
5511 IF ( present( qv ) ) qv(ix,kz) = an(ix,jy,kz,lv)
5512 IF ( present( qcw ) ) qcw(ix,kz) = an(ix,jy,kz,lc)*mixconvqv
5513 IF ( present( qrw ) ) qrw(ix,kz) = an(ix,jy,kz,lr)*mixconvqv
5514 IF ( present( qci ) ) qci(ix,kz) = an(ix,jy,kz,li)*mixconvqv
5515 IF ( present( qsw ) ) THEN
5516 qsw(ix,kz) = an(ix,jy,kz,ls)*mixconvqv
5517! qsmax3 = Max( qsmax3, qsw(ix,kz) )
5518! qsmax4 = Max( qsmax4, an(ix,jy,kz,ls) )
5519 ENDIF
5520 IF ( present( qhw ) ) qhw(ix,kz) = an(ix,jy,kz,lh)*mixconvqv
5521 IF ( lhl > 1 .and. present( qhl ) ) qhl(ix,kz) = an(ix,jy,kz,lhl)*mixconvqv
5522 IF ( present( ccw ) ) ccw(ix,kz) = an(ix,jy,kz,lnc)*mixconvqv*dninv
5523 IF ( present( crw ) ) crw(ix,kz) = an(ix,jy,kz,lnr)*mixconvqv*dninv
5524 IF ( present( cci ) ) cci(ix,kz) = an(ix,jy,kz,lni)*mixconvqv*dninv
5525 IF ( present( csw ) ) csw(ix,kz) = an(ix,jy,kz,lns)*mixconvqv*dninv
5526 IF ( present( chw ) ) chw(ix,kz) = an(ix,jy,kz,lnh)*mixconvqv*dninv
5527 IF ( lhl > 1 .and. present( chl ) ) chl(ix,kz) = an(ix,jy,kz,lnhl)*mixconvqv*dninv
5528 IF ( lvh > 1 .and. present( vhw ) ) vhw(ix,kz) = an(ix,jy,kz,lvh)*mixconvqv
5529 IF ( lvhl > 1 .and. present( vhl ) ) vhl(ix,kz) = an(ix,jy,kz,lvhl)*mixconvqv
5530 IF ( lccn > 1 .and. present( cccn ) ) cccn(ix,kz) = an(ix,jy,kz,lccn)*mixconvqv*dninv
5531 IF ( lccna > 1 .and. present( cccna ) ) cccna(ix,kz) = an(ix,jy,kz,lccna)*mixconvqv
5532
5533
5534 ENDDO ! ix
5535 ENDDO ! kz
5536! ELSE
5537! write(0,*) 'calcnfromq: lv = ',lv,lc,lr,li,ls,lh,lvh,lhl,lccn,lccna
5538! write(0,*) 'calcnfromq: nx,ny,nz,na = ',nx,ny,nz,na
5539!
5540! ENDIF
5541
5542! IF ( present( qsw ) ) THEN
5543! write(0,*) 'calcnfromq: qsmax = ',qsmax,qsmax2,qsmax3,qsmax4
5544! ENDIF
5545
5546 RETURN
5547
5548 END subroutine calcnfromq
5549
5550! ##############################################################################
5551! ##############################################################################
5552!
5553! Subroutine to calculate number concentrations from convection parameterization rates that have only mixing ratio.
5554! N will be in #/kg, NOT #/m^3, since sedimentation is done next.
5555!
5556
5557!
5558! 10.27.2015: Added hail calculation
5559!
5562 subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn)
5563
5564
5565 implicit none
5566
5567 integer nx,ny,nz,nor,norz,na,ngt,jgs,ixcol
5568
5569 real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) ! scalars (q, N, Z) from CUTEN arrays
5570 real anold(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) ! scalars (q, N, Z)
5571
5572 real dn(nx,nz+1) ! air density
5573
5574 integer ixe,kze
5575 real alpha
5576 real qmin
5577 real xvmn,xvmx
5578 integer ipconc
5579 integer lvol ! index for volume
5580 integer infall
5581
5582
5583 integer ix,jy,kz
5584 double precision vr,q,nrx,rd,g1h,g1hl,g1r,g1s,zx,chw,z,znew,zt,zxt,n1,laminv1
5585 double precision :: zr, zs, zh, dninv
5586 real, parameter :: xn0s = 3.0e6, xn0r = 8.0e6, xn0h = 4.0e4, xn0hl = 4.0e4
5587 real, parameter :: xdnr = 1000., xdns = 100. ,xdnh = 700.0, xdnhl = 900.0
5588 real, parameter :: zhlfac = 1./(pi*xdnhl*xn0hl)
5589 real, parameter :: zhfac = 1./(pi*xdnh*xn0h)
5590 real, parameter :: zrfac = 1./(pi*xdnr*xn0r)
5591 real, parameter :: zsfac = 1./(pi*xdns*xn0s)
5592 real, parameter :: g0 = (6.0)*(5.0)*(4.0)/((3.0)*(2.0)*(1.0))
5593 real, parameter :: xims=900.*0.523599*(2.*50.e-6)**3 ! mks (100 micron diam solid sphere approx)
5594 real, parameter :: xcms=1000.*0.523599*(2.*7.5e-6)**3 ! mks (100 micron diam solid sphere approx)
5595
5596 real :: xmass,xv,xdn
5597 integer :: ndbz, nmwgt, nnwgt, nwlessthanz
5598
5599! ------------------------------------------------------------------
5600
5601
5602 jy = 1
5603
5604
5605 g1h = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/ &
5606 & ((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah))
5607
5608 g1hl = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/ &
5609 & ((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl))
5610
5611 IF ( imurain == 3 ) THEN
5612 g1r = (rnu+2.0)/(rnu+1.0)
5613 ELSE ! imurain == 1
5614 g1r = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/ &
5615 & ((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar))
5616 ENDIF
5617
5618 g1s = (snu+2.0)/(snu+1.0)
5619
5620 DO kz = 1,nz
5621 DO ix = 1,nx ! ixcol
5622
5623 dninv = 1./dn(ix,kz)
5624
5625 ! Cloud droplets
5626
5627 IF ( lnc > 1 ) THEN
5628! IF ( an(ix,jy,kz,lnc) <= 0.1*cxmin .and. an(ix,jy,kz,lc) > qxmin(lc) ) THEN
5629 IF ( an(ix,jy,kz,lnc) > qxmin(lc) ) THEN
5630 anold(ix,jy,kz,lnc) = anold(ix,jy,kz,lnc) + an(ix,jy,kz,lc)/xcms
5631 ENDIF
5632 ENDIF
5633
5634 ! Cloud ice
5635
5636 IF ( lni > 1 ) THEN
5637 IF ( an(ix,jy,kz,lni) > qxmin(li) ) THEN
5638 anold(ix,jy,kz,lni) = anold(ix,jy,kz,lni) + an(ix,jy,kz,li)/xims
5639 ENDIF
5640 ENDIF
5641
5642 ! rain
5643
5644 IF ( lnr > 1 ) THEN
5645 IF ( an(ix,jy,kz,lr) > qxmin(lr) ) THEN ! adding rain mass from CU scheme
5646
5647 IF ( .true. .or. (anold(ix,jy,kz,lr) - an(ix,jy,kz,lr)) < qxmin(lr) .or. anold(ix,jy,kz,lnr) < cxmin ) THEN
5648
5649 q = an(ix,jy,kz,lr)
5650
5651 laminv1 = (dn(ix,kz) * q * zrfac)**(0.25) ! inverse of slope
5652
5653 n1 = laminv1*xn0r ! number concentration for inv. exponential single moment input
5654
5655 nrx = n1*g1r/g0 ! number concentration for different shape parameter
5656
5657 anold(ix,jy,kz,lnr) = anold(ix,jy,kz,lnr) + nrx ! *dninv ! convert to number mixing ratio
5658
5659 ELSE
5660 ! assume mean particle mass of pre-existing snow
5661 xmass = anold(ix,jy,kz,lr)/anold(ix,jy,kz,lnr)
5662 anold(ix,jy,kz,lnr) = anold(ix,jy,kz,lnr) + an(ix,jy,kz,lr)/xmass
5663 ENDIF
5664
5665 IF ( lzr > 1 ) THEN ! set reflectivity moment
5666 an(ix,jy,kz,lzr) = 36.*g1r*dn(ix,kz)**2*q**2/(pi**2*xdnr**2*nrx) ! *dninv
5667 ENDIF
5668 ENDIF
5669 ENDIF
5670
5671 ! snow
5672 IF ( lns > 1 ) THEN
5673 IF ( an(ix,jy,kz,ls) > qxmin(ls) ) THEN ! adding snow mass from CU scheme
5674
5675 IF ( .true. .or. (anold(ix,jy,kz,ls) - an(ix,jy,kz,ls)) < qxmin(ls) .or. anold(ix,jy,kz,lns) < cxmin ) THEN
5676
5677 ! assume that there was no snow before this
5678
5679 q = an(ix,jy,kz,ls)
5680
5681 laminv1 = (dn(ix,kz) * q * zsfac)**(0.25) ! inverse of slope
5682
5683 n1 = laminv1*xn0s ! number concentration for inv. exponential single moment input
5684
5685 nrx = n1*g1s/g0 ! number concentration for different shape parameter
5686
5687 anold(ix,jy,kz,lns) = anold(ix,jy,kz,lns) + nrx ! *dninv ! convert to number mixing ratio
5688
5689 ELSE
5690 ! assume mean particle mass of pre-existing snow
5691 xmass = anold(ix,jy,kz,ls)/anold(ix,jy,kz,lns)
5692 anold(ix,jy,kz,lns) = anold(ix,jy,kz,lns) + an(ix,jy,kz,ls)/xmass
5693 ENDIF
5694
5695 ENDIF
5696 ENDIF
5697
5698 ! graupel
5699
5700! IF ( lnh > 1 ) THEN
5701! IF ( an(ix,jy,kz,lnh) <= 0.1*cxmin .and. an(ix,jy,kz,lh) > qxmin(lh) ) THEN
5702! IF ( lvh > 1 ) THEN
5703! IF ( an(ix,jy,kz,lvh) <= 0.0 ) THEN
5704! an(ix,jy,kz,lvh) = an(ix,jy,kz,lh)/xdnh
5705! ENDIF
5706! ENDIF
5707!
5708! q = an(ix,jy,kz,lh)
5709!
5710! laminv1 = (dn(ix,kz) * q * zhfac)**(0.25) ! inverse of slope
5711!
5712! n1 = laminv1*xn0h ! number concentration for inv. exponential single moment input
5713!
5714! nrx = n1*g1h/g0 ! number concentration for different shape parameter
5715!
5716! an(ix,jy,kz,lnh) = nrx ! *dninv ! convert to number mixing ratio
5717!
5718! IF ( lzh > 1 ) THEN ! set reflectivity moment
5719! an(ix,jy,kz,lzh) = 36.*g1h*dn(ix,kz)**2*q**2/(pi**2*xdnh**2*nrx) ! *dninv
5720! ENDIF
5721! ENDIF
5722! ENDIF
5723!
5724! ! hail
5725!
5726! IF ( lnhl > 1 .and. lhl > 1 ) THEN
5727! IF ( an(ix,jy,kz,lnhl) <= 0.1*cxmin .and. an(ix,jy,kz,lhl) > qxmin(lhl) ) THEN
5728! IF ( lvhl > 1 ) THEN
5729! IF ( an(ix,jy,kz,lvhl) <= 0.0 ) THEN
5730! an(ix,jy,kz,lvhl) = an(ix,jy,kz,lhl)/xdnhl
5731! ENDIF
5732! ENDIF
5733!
5734! q = an(ix,jy,kz,lhl)
5735!
5736! laminv1 = (dn(ix,kz) * q * zhlfac)**(0.25) ! inverse of slope
5737!
5738! n1 = laminv1*xn0hl ! number concentration for inv. exponential single moment input
5739!
5740! nrx = n1*g1hl/g0 ! number concentration for different shape parameter
5741!
5742! an(ix,jy,kz,lnhl) = nrx ! *dninv ! convert to number mixing ratio
5743!
5744! IF ( lzhl > 1 ) THEN ! set reflectivity moment
5745! an(ix,jy,kz,lzhl) = 36.*g1hl*dn(ix,kz)**2*q**2/(pi**2*xdnhl**2*nrx) ! *dninv
5746! ENDIF
5747! ENDIF
5748! ENDIF
5749
5750 ENDDO ! ix
5751 ENDDO ! kz
5752
5753 RETURN
5754
5755 END subroutine calcnfromcuten
5756
5757! #####################################################################
5758! #####################################################################
5759
5762 SUBROUTINE calc_eff_radius &
5763 & (nx,ny,nz,na,jyslab &
5764 & ,nor,norz &
5765 & ,t1,t2,t3,t4,t5,t6, f_t5,f_t6 &
5766 & ,qcw,qci,qsw,qrw &
5767 & ,ccw,cci,csw,crw &
5768 & ,an,dn )
5769
5770 implicit none
5771
5772 integer, parameter :: ng1 = 1
5773 integer :: nx,ny,nz,na
5774 integer :: ng
5775 integer :: nor,norz, jyslab ! ,nht,ngt,igsr
5776 real :: dtp ! time step
5777
5778
5779!
5780! external temporary arrays
5781!
5782
5783 real,optional :: t1(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
5784 real,optional :: t2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
5785 real,optional :: t3(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
5786 real,optional :: t4(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
5787 real,optional :: t5(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
5788 real,optional :: t6(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
5789 logical, optional :: f_t5, f_t6 ! flags to fill t5/t6 for graupel/hail
5790
5791 real, optional :: an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na)
5792 real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
5793 real, optional, dimension(nx,nz) :: qcw,qci,qsw,qrw,ccw,cci,csw,crw
5794
5795
5796
5797
5798
5799 ! local
5800
5801 real pb(-norz+ng1:nz+norz)
5802 real pinit(-norz+ng1:nz+norz)
5803
5804!
5805! declarations microphysics and for gather/scatter
5806!
5807 integer nxmpb,nzmpb,nxz
5808 integer mgs,ngs,numgs,inumgs
5809 parameter(ngs=1)
5810 integer ngscnt,igs(ngs),kgs(ngs)
5811 real rho0(ngs)
5812
5813 integer ix,kz,i,n, kp1
5814 integer :: jy, jgs
5815 integer ixb,ixe,jyb,jye,kzb,kze
5816
5817 integer itile,jtile,ktile
5818 integer ixend,jyend,kzend,kzbeg
5819 integer nxend,nyend,nzend,nzbeg
5820
5821 real :: qx(ngs,lv:lhab)
5822 real :: cx(ngs,lc:lhab)
5823 real :: xv(ngs,lc:lhab)
5824 real :: xmas(ngs,lc:lhab)
5825 real :: xdn(ngs,lc:lhab)
5826 real :: xdia(ngs,lc:lhab,3)
5827 real :: alpha(ngs,lc:lhab)
5828
5829 real :: gamc1,gamc2,gami1,gami2,gams1,gams2,gamr1,gamr2
5830 real :: factor_c, factor_i, factor_s, factor_r
5831 real :: lam_c, lam_i, lam_s, lam_r
5832 integer :: il
5833
5834
5835! -------------------------------------------------------------------------------
5836 itile = nx
5837 jtile = ny
5838 ktile = nz
5839 ixend = nx
5840 jyend = ny
5841 kzend = nz
5842 nxend = nx + 1
5843 nyend = ny + 1
5844 nzend = nz
5845 kzbeg = 1
5846 nzbeg = 1
5847
5848 jy = 1
5849 pb(:) = 0.0
5850 pinit(:) = 0.0
5851
5852 gamc1 = gamma_sp(2. + cnu)
5853 gamc2 = 1. ! Gamma[1 + alphac]
5854 gami1 = gamma_sp(2. + cinu)
5855 gami2 = 1. ! Gamma[1 + alphac]
5856 gams1 = gamma_sp(2. + snu)
5857 gams2 = gamma_sp(1. + snu)
5858 gamr1 = gamma_sp(2. + rnu)
5859 gamr2 = gamma_sp(1. + rnu)
5860
5861 factor_c = (1. + cnu)*gamma_sp(1. + cnu)/gamma_sp(5./3. + cnu)
5862 factor_i = (1. + cinu)*gamma_sp(1. + cinu)/gamma_sp(5./3. + cinu)
5863 factor_s = (1. + snu)*gamma_sp(1. + snu)/gamma_sp(5./3. + snu)
5864
5865 IF ( present(t4) ) THEN
5866 IF ( imurain == 3 ) THEN
5867 factor_r = (1. + rnu)*gamma_sp(1. + rnu)/gamma_sp(5./3. + rnu)
5868 ELSE
5869 factor_r = ((pi*(alphar+3.)*(alphar+1.)*(alphar+1.))/6.)**(1./3.)
5870 ENDIF
5871 ENDIF
5872
5873!
5874! jy = 1 ! working on a 2d slab
5875!! VERY IMPORTANT: SET jgs = jy
5876
5877 jgs = jy
5878
5879 mgs = 1
5880 DO kz = 1,nz
5881 DO ix = 1,nx ! ixcol
5882
5883 rho0(mgs) = dn(ix,jy,kz)
5884 IF ( present( an ) ) THEN
5885 DO il = lc,ls
5886 qx(mgs,il) = max(an(ix,jy,kz,il), 0.0)
5887 cx(mgs,il) = max(an(ix,jy,kz,ln(il)), 0.0)
5888 ENDDO
5889 ELSE
5890 qx(mgs,:) = 0.0
5891 cx(mgs,:) = 0.0
5892 IF ( present(qcw) ) qx(mgs,lc) = qcw(ix,kz)
5893 IF ( present(qci) ) qx(mgs,li) = qci(ix,kz)
5894 IF ( present(qsw) ) qx(mgs,ls) = qsw(ix,kz)
5895 IF ( present(qrw) ) qx(mgs,lr) = qrw(ix,kz)
5896 IF ( present(ccw) ) cx(mgs,lc) = ccw(ix,kz)*rho0(mgs)
5897 IF ( present(cci) ) cx(mgs,li) = cci(ix,kz)*rho0(mgs)
5898 IF ( present(csw) ) cx(mgs,ls) = csw(ix,kz)*rho0(mgs)
5899 IF ( present(crw) ) cx(mgs,lr) = crw(ix,kz)*rho0(mgs)
5900
5901 ENDIF
5902
5903 IF ( present( t1 ) .and. qx(mgs,lc) > qxmin(lc) .and. cx(mgs,lc) > cxmin ) THEN
5904! Lambda for cloud droplets
5905 lam_c = ((cx(mgs,lc)*(pi/6.)*xdn0(lc)*gamc1)/(qx(mgs,lc)*rho0(mgs)*gamc2))**(1./3.)
5906 t1(ix,jy,kz) = 0.5*factor_c/lam_c
5907 ENDIF
5908
5909 IF ( present( t2 ) .and. qx(mgs,li) > qxmin(li) .and. cx(mgs,li) > cxmin ) THEN
5910! Lambda for cloud ice
5911 lam_i = ((cx(mgs,li)*(pi/6.)*xdn0(li)*gami1)/(qx(mgs,li)*rho0(mgs)*gami2))**(1./3.)
5912 t2(ix,jy,kz) = 0.5*factor_i/lam_i
5913 ENDIF
5914
5915 IF ( present( t3 ) .and. qx(mgs,ls) > qxmin(ls) .and. cx(mgs,ls) > cxmin ) THEN
5916! Lambda for snow
5917 lam_s = ((cx(mgs,ls)*(pi/6.)*xdn0(ls)*gams1)/(qx(mgs,ls)*rho0(mgs)*gams2))**(1./3.)
5918 t3(ix,jy,kz) = 0.5*factor_s/lam_s
5919 ENDIF
5920
5921 IF ( present( t4 ) .and. present(qrw) .and. present(crw) ) THEN
5922 IF ( qx(mgs,lr) > max(1.e-8,qxmin(lr)) .and. cx(mgs,lr) > cxmin ) THEN
5923 IF ( imurain == 1 ) THEN ! gamma-diameter
5924! Lambda for rain
5925 lam_r = factor_r *((xdn0(lr)*cx(mgs,lr))/(qx(mgs,lr)*rho0(mgs)))**(1./3.)
5926 t4(ix,jy,kz) = 0.5*(alphar+3.)/lam_r
5927 ELSE ! gamma-volume
5928! Lambda for rain
5929 lam_r = ((cx(mgs,lr)*(pi/6.)*xdn0(lr)*gamr1)/(qx(mgs,lr)*rho0(mgs)*gamr2))**(1./3.)
5930 t4(ix,jy,kz) = 0.5*factor_r/lam_r
5931 ENDIF
5932 ENDIF
5933 ENDIF
5934
5935
5936 ENDDO ! ix
5937 ENDDO ! kz
5938
5939 RETURN
5940 END SUBROUTINE calc_eff_radius
5941
5942
5943! #####################################################################
5944! #####################################################################
5945
5948 SUBROUTINE qvexcess(ngs,mgs,qwvp0,qv0,qcw1,pres,thetap0,theta0, &
5949 & qvex,pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ss1,pk,ngscnt)
5950
5951!#####################################################################
5952! Purpose: find the amount of vapor that can be condensed to liquid
5953!#####################################################################
5954
5955 implicit none
5956
5957 integer ngs,mgs,ngscnt
5958
5959 real theta2temp
5960
5961 real qvex
5962
5963 integer nqsat
5964 real fqsat, cbw
5965
5966 real ss1 ! 'target' supersaturation
5967!
5968! input arrays
5969!
5970 real qv0(ngs), qcw1(ngscnt), pres(ngs), qwvp0(mgs)
5971 real thetap0(ngs), theta0(ngs)
5972 real fcqv1(ngs), felvcp(ngs), pi0(ngs)
5973 real pk(ngs)
5974
5975 real tabqvs(nqsat)
5976!
5977! Local stuff
5978!
5979
5980 integer itertd
5981 integer ltemq
5982 real gamss
5983 real theta(ngs), qvap(ngs), pqs(ngs), qcw(ngs), qwv(ngs)
5984 real qcwtmp(ngs), qss(ngs), qvs(ngs), qwvp(ngs)
5985 real dqcw(ngs), dqwv(ngs), dqvcnd(ngs)
5986 real temg(ngs), temcg(ngs), thetap(ngs)
5987
5988 real tfr
5989 parameter( tfr = 273.15 )
5990
5991! real poo,cap
5992! parameter ( cap = rd/cp, poo = 1.0e+05 )
5993!
5994!
5995! Modified Straka adjustment (nearly identical to Tao et al. 1989 MWR)
5996!
5997!
5998!
5999! set up temperature and vapor arrays
6000!
6001 pqs(mgs) = (380.0)/(pres(mgs))
6002 thetap(mgs) = thetap0(mgs)
6003 theta(mgs) = thetap(mgs) + theta0(mgs)
6004 qwvp(mgs) = qwvp0(mgs)
6005 qvap(mgs) = max( (qwvp0(mgs) + qv0(mgs)), 0.0 )
6006 temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap
6007! temg(mgs) = theta2temp( theta(mgs), pres(mgs) )
6008!
6009!
6010!
6011! reset temporaries for cloud particles and vapor
6012!
6013
6014 qwv(mgs) = max( 0.0, qvap(mgs) )
6015 qcw(mgs) = max( 0.0, qcw1(mgs) )
6016!
6017!
6018 qcwtmp(mgs) = qcw(mgs)
6019 temcg(mgs) = temg(mgs) - tfr
6020 ltemq = (temg(mgs)-163.15)/fqsat+1.5
6021 ltemq = min( nqsat, max(1,ltemq) )
6022
6023 qvs(mgs) = pqs(mgs)*tabqvs(ltemq)
6024 qss(mgs) = (0.01*ss1 + 1.0)*qvs(mgs)
6025!
6026! iterate adjustment
6027!
6028 do itertd = 1,2
6029!
6030!
6031! calculate super-saturation
6032!
6033 dqcw(mgs) = 0.0
6034 dqwv(mgs) = ( qwv(mgs) - qss(mgs) )
6035!
6036! evaporation and sublimation adjustment
6037!
6038 if( dqwv(mgs) .lt. 0. ) then ! subsaturated
6039 if( qcw(mgs) .gt. -dqwv(mgs) ) then ! check if qc can make up all of the deficit
6040 dqcw(mgs) = dqwv(mgs)
6041 dqwv(mgs) = 0.
6042 else ! otherwise make all qc available for evap
6043 dqcw(mgs) = -qcw(mgs)
6044 dqwv(mgs) = dqwv(mgs) + qcw(mgs)
6045 end if
6046!
6047 qwvp(mgs) = qwvp(mgs) - ( dqcw(mgs) ) ! add to perturbation vapor
6048!
6049 qcw(mgs) = qcw(mgs) + dqcw(mgs)
6050
6051 thetap(mgs) = thetap(mgs) + &
6052 & 1./pi0(mgs)* &
6053 & (felvcp(mgs)*dqcw(mgs) )
6054
6055 end if ! dqwv(mgs) .lt. 0. (end of evap/sublim)
6056!
6057! condensation/deposition
6058!
6059 IF ( dqwv(mgs) .ge. 0. ) THEN
6060!
6061 dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv1(mgs)*qss(mgs)/ &
6062 & ((temg(mgs)-cbw)**2))
6063!
6064!
6065 dqcw(mgs) = dqvcnd(mgs)
6066!
6067 thetap(mgs) = thetap(mgs) + &
6068 & (felvcp(mgs)*dqcw(mgs) ) &
6069 & / (pi0(mgs))
6070 qwvp(mgs) = qwvp(mgs) - ( dqvcnd(mgs) )
6071 qcw(mgs) = qcw(mgs) + dqcw(mgs)
6072!
6073 END IF ! dqwv(mgs) .ge. 0.
6074
6075 theta(mgs) = thetap(mgs) + theta0(mgs)
6076 temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap
6077! temg(mgs) = theta2temp( theta(mgs), pres(mgs) )
6078 qvap(mgs) = max((qwvp(mgs) + qv0(mgs)), 0.0)
6079 temcg(mgs) = temg(mgs) - tfr
6080! tqvcon = temg(mgs)-cbw
6081 ltemq = (temg(mgs)-163.15)/fqsat+1.5
6082 ltemq = min( nqsat, max(1,ltemq) )
6083 qvs(mgs) = pqs(mgs)*tabqvs(ltemq)
6084 qcw(mgs) = max( 0.0, qcw(mgs) )
6085 qwv(mgs) = max( 0.0, qvap(mgs))
6086 qss(mgs) = (0.01*ss1 + 1.0)*qvs(mgs)
6087 end do
6088!
6089! end the saturation adjustment iteration loop
6090!
6091!
6092 qvex = max(0.0, qcw(mgs) - qcw1(mgs) )
6093
6094 RETURN
6095 END SUBROUTINE qvexcess
6096
6097! #####################################################################
6098! #####################################################################
6099
6100
6101
6102
6103
6104!
6105! ##############################################################################
6106!
6109 SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
6110 & xmas,vtxbar,xdn,xvmn0,xvmx0,xv,cdx,cdxgs, &
6111 & ipconc1,ndebug1,ngs,nz,kgs,fadvisc, &
6112 & cwmasn,cwmasx,cwradn,cnina,cimna,cimxa, &
6113 & itype1a,itype2a,temcg,infdo,alpha,ildo,axx,bxx)
6114! & itype1a,itype2a,temcg,infdo,alpha,ildo,axh,bxh,axhl,bxhl)
6115
6116
6117 implicit none
6118
6119 integer ngscnt,ngs0,ngs,nz
6120! integer infall ! whether to calculate number-weighted fall speeds
6121
6122 real xv(ngs,lc:lhab)
6123 real qx(ngs,lv:lhab)
6124 real qxw(ngs,ls:lhab)
6125 real cx(ngs,lc:lhab)
6126 real vtxbar(ngs,lc:lhab,3)
6127 real xmas(ngs,lc:lhab)
6128 real xdn(ngs,lc:lhab)
6129 real cdxgs(ngs,lc:lhab)
6130 real xdia(ngs,lc:lhab,3)
6131 real xvmn0(lc:lhab), xvmx0(lc:lhab)
6132 real qxmin(lc:lhab)
6133 real cdx(lc:lhab)
6134 real alpha(ngs,lc:lhab)
6135
6136 real rho0(ngs),rhovt(ngs),temcg(ngs)
6137 real cno(lc:lhab)
6138 real cnostmp(ngs)
6139
6140 real cwc1, cimna, cimxa
6141 real cnina(ngs)
6142 integer kgs(ngs)
6143 real fadvisc(ngs)
6144 real fsw
6145
6146 integer ipconc1
6147 integer ndebug1
6148
6149 integer, intent (in) :: itype1a,itype2a,infdo
6150 integer, intent (in) :: ildo ! which species to do, or all if ildo=0
6151
6152 real :: axx(ngs,lh:lhab),bxx(ngs,lh:lhab)
6153!! real :: axh(ngs),bxh(ngs)
6154! real :: axhl(ngs),bxhl(ngs)
6155
6156! Local vars
6157
6158
6159
6160 real swmasmx, dtmp
6161 real cd
6162 real cwc0 ! ,cwc1
6163 real :: cwch(ngscnt), cwchl(ngscnt)
6164 real :: cwchtmp,cwchltmp,xnutmp
6165 real pii
6166 real cimasx,cimasn
6167 real cwmasn,cwmasx,cwradn
6168 real cwrad
6169 real vr,rnux
6170 real alp
6171
6172 real ccimx
6173
6174 integer mgs
6175
6176 real arx,frx,vtrain,fw
6177 real fwlo,fwhi,rfwdiff
6178 real ar,br,cs,ds
6179! real gf4p5, gf4ds, gf4br, ifirst, gf1ds
6180! real gfcinu1, gfcinu1p47, gfcinu2p47
6181 real gr
6182 real rwrad,rwdia
6183 real mwfac
6184 integer il
6185
6186! save gf4p5, gf4ds, gf4br, ifirst, gf1ds
6187! save gfcinu1, gfcinu1p47, gfcinu2p47
6188! data ifirst /0/
6189
6190 real bta1,cnit
6191 parameter( bta1 = 0.6, cnit = 1.0e-02 )
6192 real x,y,tmp,del
6193 real aax,bbx,delrho
6194 integer :: indxr
6195 real mwt, nwt, zwt
6196 real, parameter :: rho00 = 1.225
6197 integer i
6198 real xvbarmax
6199
6200 integer l1, l2
6201
6202
6203!
6204! set values
6205!
6206! cwmasn = 5.23e-13 ! radius of 5.0e-6
6207! cwradn = 5.0e-6
6208! cwmasx = 5.25e-10 ! radius of 50.0e-6
6209
6210 fwlo = 0.2 ! water fraction to start weighting toward rain fall speed
6211 fwhi = 0.4 ! water fraction at which rain fall speed only is used
6212 rfwdiff = 1./(fwhi - fwlo)
6213
6214! pi = 4.0*atan(1.0)
6215 pii = piinv ! 1.0/pi
6216
6217 arx = 10.
6218 frx = 516.575 ! raind fit parameters for arx*(1 - Exp(-fx*d)), where d is rain diameter in meters.
6219
6220 ar = 841.99666
6221 br = 0.8
6222 gr = 9.8
6223! new values for cs and ds
6224 cs = 12.42
6225 ds = 0.42
6226
6227 IF ( ildo == 0 ) THEN
6228 l1 = lc
6229 l2 = lhab
6230 ELSE
6231 l1 = ildo
6232 l2 = ildo
6233 ENDIF
6234
6235! IF ( ifirst .eq. 0 ) THEN
6236! ifirst = 1
6237! gf4br = gamma(4.0+br)
6238! gf4ds = gamma(4.0+ds)
6239!! gf1ds = gamma(1.0+ds)
6240! gf4p5 = gamma(4.0+0.5)
6241! gfcinu1 = gamma(cinu + 1.0)
6242! gfcinu1p47 = gamma(cinu + 1.47167)
6243! gfcinu2p47 = gamma(cinu + 2.47167)
6244
6245 IF ( lh .gt. 1 ) THEN
6246 IF ( dmuh == 1.0 ) THEN
6247 cwchtmp = ((3. + dnu(lh))*(2. + dnu(lh))*(1.0 + dnu(lh)))**(-1./3.)
6248 ELSE
6249 cwchtmp = 6.0*pii*gamma_sp( (xnu(lh) + 1.)/xmu(lh) )/gamma_sp( (xnu(lh) + 2.)/xmu(lh) )
6250 ENDIF
6251 ENDIF
6252 IF ( lhl .gt. 1 ) THEN
6253 IF ( dmuhl == 1.0 ) THEN
6254 cwchltmp = ((3. + dnu(lhl))*(2. + dnu(lhl))*(1.0 + dnu(lhl)))**(-1./3.)
6255 ELSE
6256 cwchltmp = 6.0*pii*gamma_sp( (xnu(lhl) + 1)/xmu(lhl) )/gamma_sp( (xnu(lhl) + 2)/xmu(lhl) )
6257 ENDIF
6258 ENDIF
6259
6260 IF ( ipconc .le. 5 ) THEN
6261 IF ( lh .gt. 1 ) cwch(:) = cwchtmp
6262 IF ( lhl .gt. 1 ) cwchl(:) = cwchltmp
6263 ELSE
6264 DO mgs = 1,ngscnt
6265
6266 IF ( lh .gt. 1 .and. ( ildo == 0 .or. ildo == lh ) ) THEN
6267 IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN
6268 IF ( dmuh == 1.0 ) THEN
6269 cwch(mgs) = ((3. + alpha(mgs,lh))*(2. + alpha(mgs,lh))*(1.0 + alpha(mgs,lh)))**(-1./3.)
6270 ELSE
6271 xnutmp = (alpha(mgs,lh) - 2.0)/3.0
6272 cwch(mgs) = 6.0*pii*gamma_sp( (xnutmp + 1.)/xmu(lh) )/gamma_sp( (xnutmp + 2.)/xmu(lh) )
6273 ENDIF
6274 ELSE
6275 cwch(mgs) = cwchtmp
6276 ENDIF
6277 ENDIF
6278 IF ( lhl .gt. 1 .and. ( ildo == 0 .or. ildo == lhl ) ) THEN
6279 IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN
6280 IF ( dmuhl == 1.0 ) THEN
6281 cwchl(mgs) = ((3. + alpha(mgs,lhl))*(2. + alpha(mgs,lhl))*(1.0 + alpha(mgs,lhl)))**(-1./3.)
6282 ELSE
6283 xnutmp = (alpha(mgs,lhl) - 2.0)/3.0
6284 cwchl(mgs) = 6.0*pii*gamma_sp( (xnutmp + 1)/xmu(lhl) )/gamma_sp( (xnutmp + 2)/xmu(lhl) )
6285 ENDIF
6286 ELSE
6287 cwchl(mgs) = cwchltmp
6288 ENDIF
6289 ENDIF
6290
6291 ENDDO
6292
6293 ENDIF
6294
6295
6296 cimasn = min( cimas0, 6.88e-13)
6297 cimasx = 1.0e-8
6298 ccimx = 5000.0e3 ! max of 5000 per liter
6299
6300 cwc1 = 6.0/(pi*1000.)
6301 cwc0 = pii ! 6.0*pii
6302 mwfac = 6.0**(1./3.)
6303
6304
6305 if (ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set scale diameter'
6306!
6307
6308
6309!
6310! cloud water variables
6311! ################################################################
6312!
6313! DROPLETS
6314!
6315!
6316 if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set cloud water variables'
6317
6318 IF ( ildo == 0 .or. ildo == lc ) THEN
6319
6320 do mgs = 1,ngscnt
6321 xv(mgs,lc) = 0.0
6322
6323 IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN !{
6324
6325 IF ( ipconc .ge. 2 ) THEN
6326 IF ( cx(mgs,lc) .gt. cxmin) THEN !{
6327 xmas(mgs,lc) = &
6328 & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx )
6329 xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc)
6330 ELSE
6331 cx(mgs,lc) = max( cxmin, rho0(mgs)*qx(mgs,lc)/cwmasx )
6332 xmas(mgs,lc) = min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx )
6333 xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc)
6334
6335 ENDIF
6336 ELSE
6337 IF ( ipconc .lt. 2 ) THEN
6338 cx(mgs,lc) = rho0(mgs)*ccn/rho00 ! scales to local density, relative to standard air density
6339 ENDIF
6340 IF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 0.01 ) THEN !{
6341 xmas(mgs,lc) = &
6342 & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),xdn(mgs,lc)*xvmn(lc)), &
6343 & xdn(mgs,lc)*xvmx(lc) )
6344
6345 xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc)
6346 cx(mgs,lc) = qx(mgs,lc)*rho0(mgs)/xmas(mgs,lc)
6347
6348 ELSEIF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .le. 1.0e-9 ) THEN
6349 cx(mgs,lc) = max( cxmin, rho0(mgs)*qx(mgs,lc)/cwmasx )
6350 xmas(mgs,lc) = &
6351 & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx )
6352 xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc)
6353
6354 ELSEIF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .le. 0.01 ) THEN
6355 xmas(mgs,lc) = xdn(mgs,lc)*4.*pi/3.*(5.0e-6)**3
6356 cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc)
6357 xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc)
6358
6359 ELSE
6360 xmas(mgs,lc) = cwmasn
6361 xv(mgs,lc) = xmas(mgs,lc)/1000.
6362! do not define ccw here! it can feed back to ccn!!! cx(mgs,lc) = 0.0 ! cwnc(mgs)
6363 ENDIF !}
6364 ENDIF !}
6365! IF ( ipconc .lt. 2 ) THEN
6366! xmas(mgs,lc) = &
6367! & min( max(qx(mgs,lc)*rho0(mgs)/cwnc(mgs),cwmasn),cwmasx )
6368! cx(mgs,lc) = Max(1.0,qx(mgs,lc)*rho0(mgs)/xmas(mgs,lc))
6369! ELSE
6370! cwnc(mgs) = an(igs(mgs),jgs,kgs(mgs),lnc)
6371! cx(mgs,lc) = cwnc(mgs)
6372! ENDIF
6373 xdia(mgs,lc,1) = (xmas(mgs,lc)*cwc1)**(1./3.)
6374 xdia(mgs,lc,2) = xdia(mgs,lc,1)**2
6375 xdia(mgs,lc,3) = xdia(mgs,lc,1)
6376 cwrad = 0.5*xdia(mgs,lc,1)
6377 IF ( fadvisc(mgs) > 0.0 ) THEN
6378 vtxbar(mgs,lc,1) = &
6379 & (2.0*gr*xdn(mgs,lc) *(cwrad**2)) &
6380 & /(9.0*fadvisc(mgs))
6381 ELSE
6382 vtxbar(mgs,lc,1) = 0.0
6383 ENDIF
6384
6385
6386 ELSE
6387 xmas(mgs,lc) = cwmasn
6388 xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc)
6389 IF ( qx(mgs,lc) <= 0.0 ) cx(mgs,lc) = 0.0
6390 IF ( ipconc .le. 1 ) cx(mgs,lc) = 0.01
6391 xdia(mgs,lc,1) = 2.*cwradn
6392 xdia(mgs,lc,2) = 4.*cwradn**2
6393 xdia(mgs,lc,3) = xdia(mgs,lc,1)
6394 vtxbar(mgs,lc,1) = 0.0
6395
6396 ENDIF !} qcw .gt. qxmin(lc)
6397
6398 end do
6399
6400 ENDIF
6401
6402
6403
6404!
6405! cloud ice variables
6406! columns
6407!
6408! ################################################################
6409!
6410! CLOUD ICE
6411!
6412 if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set cip'
6413
6414 IF ( li .gt. 1 .and. ( ildo == 0 .or. ildo == li ) ) THEN
6415 do mgs = 1,ngscnt
6416 xdn(mgs,li) = 900.0
6417 IF ( ipconc .eq. 0 ) THEN
6418! cx(mgs,li) = min(cnit*exp(-temcg(mgs)*bta1),1.e+09)
6419 cx(mgs,li) = cnina(mgs)
6420 IF ( cimna .gt. 1.0 ) THEN
6421 cx(mgs,li) = max(cimna,cx(mgs,li))
6422 ENDIF
6423 IF ( cimxa .gt. 1.0 ) THEN
6424 cx(mgs,li) = min(cimxa,cx(mgs,li))
6425 ENDIF
6426! erm 3/28/2002
6427 IF ( itype1a .ge. 1 .or. itype2a .ge. 1 ) THEN
6428 cx(mgs,li) = max(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasx)
6429 cx(mgs,li) = min(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasn)
6430 ENDIF
6431!
6432 cx(mgs,li) = max(1.0e-20,cx(mgs,li))
6433! cx(mgs,li) = Min(ccimx, cx(mgs,li))
6434
6435
6436 ELSEIF ( ipconc .ge. 1 ) THEN
6437 IF ( qx(mgs,li) .gt. qxmin(li) ) THEN
6438 cx(mgs,li) = max(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasx)
6439 cx(mgs,li) = min(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasn)
6440! cx(mgs,li) = Max(1.0,cx(mgs,li))
6441 ENDIF
6442 ENDIF
6443
6444 IF ( qx(mgs,li) .gt. qxmin(li) ) THEN
6445 xmas(mgs,li) = &
6446 & max( qx(mgs,li)*rho0(mgs)/cx(mgs,li), cimasn )
6447! & min( max(qx(mgs,li)*rho0(mgs)/cx(mgs,li),cimasn),cimasx )
6448
6449! if ( temcg(mgs) .gt. 0.0 ) then
6450! xdia(mgs,li,1) = 0.0
6451! else
6452 if ( xmas(mgs,li) .gt. 0.0 ) THEN ! cimasn ) then
6453!c xdia(mgs,li,1) = 0.4892*(xmas(mgs,li)**(0.4554))
6454! xdia(mgs,li,1) = 0.1871*(xmas(mgs,li)**(0.3429))
6455
6456! xdia(mgs,li,1) = (132.694*5.40662/xmas(mgs,li))**(-1./2.9163) ! for inverse exponential distribution
6457 IF ( ixtaltype == 1 ) THEN ! column
6458 xdia(mgs,li,1) = 0.1871*(xmas(mgs,li)**(0.3429))
6459 xdia(mgs,li,3) = 0.1871*(xmas(mgs,li)**(0.3429))
6460 ELSEIF ( ixtaltype == 2 ) THEN ! disk
6461 xdia(mgs,li,1) = 0.277823*xmas(mgs,li)**0.359971
6462 xdia(mgs,li,3) = 0.277823*xmas(mgs,li)**0.359971
6463 ENDIF
6464 end if
6465! end if
6466! xdia(mgs,li,1) = max(xdia(mgs,li,1), 5.e-6)
6467! xdia(mgs,li,1) = min(xdia(mgs,li,1), 1000.e-6)
6468
6469 IF ( ipconc .ge. 0 ) THEN
6470! vtxbar(mgs,li,1) = rhovt(mgs)*49420.*40.0005/5.40662*xdia(mgs,li,1)**(1.415) ! mass-weighted
6471! vtxbar(mgs,li,1) = (4.942e4)*(xdia(mgs,li,1)**(1.4150))
6472 xv(mgs,li) = xmas(mgs,li)/xdn(mgs,li)
6473 IF ( icefallopt == 1 ) THEN ! default ice fall
6474 IF ( ixtaltype == 1 ) THEN ! column
6475 tmp = (67056.6300748612*rhovt(mgs))/ &
6476 & (((1.0 + cinu)/xv(mgs,li))**0.4716666666666667*gfcinu1)
6477 vtxbar(mgs,li,2) = tmp*gfcinu1p47
6478 vtxbar(mgs,li,1) = tmp*gfcinu2p47/(1. + cinu)
6479 vtxbar(mgs,li,3) = vtxbar(mgs,li,1)
6480 ELSEIF ( ixtaltype == 2 ) THEN ! disk -- but just use Ferrier (1994) snow fall speeds for now
6481 vtxbar(mgs,li,1) = 11.9495*rhovt(mgs)*(xv(mgs,li))**(0.14)
6482 vtxbar(mgs,li,2) = 7.02909*rhovt(mgs)*(xv(mgs,li))**(0.14)
6483 vtxbar(mgs,li,3) = vtxbar(mgs,li,1)
6484
6485 ENDIF
6486
6487 ELSEIF ( icefallopt == 2 ) THEN ! ! Ferrier ice fall speed
6488 tmp = (82.3166*rhovt(mgs))/ &
6489 & (((1.0 + cinu)/xv(mgs,li))**0.22117*gfcinu1)
6490 vtxbar(mgs,li,2) = tmp*gfcinu1p22
6491 vtxbar(mgs,li,1) = tmp*gfcinu2p22/(1. + cinu)
6492 vtxbar(mgs,li,3) = vtxbar(mgs,li,1)
6493
6494 ELSEIF ( icefallopt == 3 ) THEN ! ! Adjusted Ferrier (smaller exponent of 0.55 instead of 0.6635)
6495
6496 tmp = (47.6273*rhovt(mgs))/ &
6497 & (((1.0 + cinu)/xv(mgs,li))**0.18333*gfcinu1)
6498 vtxbar(mgs,li,2) = tmp*gfcinu1p18
6499 vtxbar(mgs,li,1) = tmp*gfcinu2p18/(1. + cinu)
6500 vtxbar(mgs,li,3) = vtxbar(mgs,li,1)
6501
6502 ENDIF
6503! vtxbar(mgs,li,1) = vtxbar(mgs,li,2)*(1.+cinu)/(1. + cinu)
6504! xdn(mgs,li) = min(max(769.8*xdia(mgs,li,1)**(-0.0140),300.0),900.0)
6505! xdn(mgs,li) = 900.0
6506 xdia(mgs,li,2) = xdia(mgs,li,1)**2
6507! vtxbar(mgs,li,1) = vtxbar(mgs,li,1)*rhovt(mgs)
6508 ELSE
6509 xdia(mgs,li,1) = max(xdia(mgs,li,1), 10.e-6)
6510 xdia(mgs,li,1) = min(xdia(mgs,li,1), 1000.e-6)
6511 vtxbar(mgs,li,1) = (4.942e4)*(xdia(mgs,li,1)**(1.4150))
6512! xdn(mgs,li) = min(max(769.8*xdia(mgs,li,1)**(-0.0140),300.0),900.0)
6513 xdn(mgs,li) = 900.0
6514 xdia(mgs,li,2) = xdia(mgs,li,1)**2
6515 vtxbar(mgs,li,1) = vtxbar(mgs,li,1)*rhovt(mgs)
6516 xv(mgs,li) = xmas(mgs,li)/xdn(mgs,li)
6517 ENDIF ! ipconc gt 3
6518 ELSE
6519 xmas(mgs,li) = 1.e-13
6520 IF ( qx(mgs,li) <= 0.0 ) cx(mgs,li) = 0.0
6521 xdn(mgs,li) = 900.0
6522 xdia(mgs,li,1) = 1.e-7
6523 xdia(mgs,li,2) = (1.e-14)
6524 xdia(mgs,li,3) = 1.e-7
6525 vtxbar(mgs,li,1) = 0.0
6526! cicap(mgs) = 0.0
6527! ciat(mgs) = 0.0
6528 ENDIF
6529
6530 IF ( icefallfac /= 1.0 ) THEN
6531 vtxbar(mgs,li,1) = icefallfac*vtxbar(mgs,li,1)
6532 vtxbar(mgs,li,2) = icefallfac*vtxbar(mgs,li,2)
6533 vtxbar(mgs,li,3) = icefallfac*vtxbar(mgs,li,3)
6534 ENDIF
6535
6536
6537
6538 end do
6539
6540 ENDIF ! li .gt. 1
6541
6542
6543! ################################################################
6544!
6545! RAIN
6546!
6547
6548!
6549 IF ( ildo == 0 .or. ildo == lr ) THEN
6550 do mgs = 1,ngscnt
6551 if ( qx(mgs,lr) .gt. qxmin(lr) ) then
6552
6553! IF ( qx(mgs,lr) .gt. 10.0e-3 ) &
6554! & write(0,*) 'RAIN1: ',igs(mgs),kgs(mgs),qx(mgs,lr)
6555
6556 if ( ipconc .ge. 3 ) then
6557 xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*max(1.0e-11,cx(mgs,lr)))
6558 xvbarmax = xvmx(lr)
6559 IF ( imaxdiaopt == 1 ) THEN
6560 xvbarmax = xvmx(lr)
6561 ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter
6562 IF ( imurain == 1 ) THEN
6563 xvbarmax = xvmx(lr)/((3. + alpha(mgs,lr))**3/((3. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(1. + alpha(mgs,lr))))
6564 ELSEIF ( imurain == 3 ) THEN
6565
6566 ENDIF
6567 ELSEIF ( imaxdiaopt == 3 ) THEN ! test against mass-weighted diameter
6568 IF ( imurain == 1 ) THEN
6569 xvbarmax = xvmx(lr)/((4. + alpha(mgs,lr))**3/((3. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(1. + alpha(mgs,lr))))
6570 ELSEIF ( imurain == 3 ) THEN
6571
6572 ENDIF
6573 ENDIF
6574
6575 IF ( xv(mgs,lr) .gt. xvbarmax ) THEN
6576 xv(mgs,lr) = xvbarmax
6577 cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvbarmax*xdn(mgs,lr))
6578 ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN
6579 xv(mgs,lr) = xvmn(lr)
6580 cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr))
6581 ENDIF
6582
6583
6584 xmas(mgs,lr) = xv(mgs,lr)*xdn(mgs,lr)
6585 xdia(mgs,lr,3) = (xmas(mgs,lr)*cwc1)**(1./3.) ! xdia(mgs,lr,1)
6586 IF ( imurain == 3 ) THEN
6587! xdia(mgs,lr,1) = (6.*pii*xv(mgs,lr)/(alpha(mgs,lr)+1.))**(1./3.)
6588 xdia(mgs,lr,1) = xdia(mgs,lr,3) ! formulae for Ziegler (1985) use mean volume diameter, not lambda**(-1)
6589 ELSE ! imurain == 1, Characteristic diameter (1/lambda)
6590 xdia(mgs,lr,1) = (6.*pii*xv(mgs,lr)/((alpha(mgs,lr)+3.)*(alpha(mgs,lr)+2.)*(alpha(mgs,lr)+1.)))**(1./3.)
6591 ENDIF
6592! rwrad(mgs) = 0.5*xdia(mgs,lr,1)
6593
6594! Inverse exponential version:
6595! xdia(mgs,lr,1) =
6596! & (qx(mgs,lr)*rho0(mgs)
6597! & /(pi*xdn(mgs,lr)*cx(mgs,lr)))**(0.333333)
6598 ELSE
6599 xdia(mgs,lr,1) = &
6600 & (qx(mgs,lr)*rho0(mgs)/(pi*xdn(mgs,lr)*cno(lr)))**(0.25)
6601 xmas(mgs,lr) = xdn(mgs,lr)*(pi/6.)*xdia(mgs,lr,1)**3
6602 xdia(mgs,lr,3) = (xmas(mgs,lr)*cwc1)**(1./3.)
6603 cx(mgs,lr) = cno(lr)*xdia(mgs,lr,1)
6604 xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr))
6605 end if
6606 else
6607 xdia(mgs,lr,1) = 1.e-9
6608 xdia(mgs,lr,3) = 1.e-9
6609 xmas(mgs,lr) = xdn(mgs,lr)*(pi/6.)*xdia(mgs,lr,1)**3
6610! rwrad(mgs) = 0.5*xdia(mgs,lr,1)
6611 end if
6612 xdia(mgs,lr,2) = xdia(mgs,lr,1)**2
6613! xmas(mgs,lr) = xdn(mgs,lr)*(pi/6.)*xdia(mgs,lr,1)**3
6614 end do
6615
6616 ENDIF
6617! ################################################################
6618!
6619! SNOW
6620!
6621
6622 IF ( ls .gt. 1 .and. ( ildo == 0 .or. ildo == ls ) ) THEN
6623
6624 do mgs = 1,ngscnt
6625 if ( qx(mgs,ls) .gt. qxmin(ls) ) then
6626 if ( ipconc .ge. 4 ) then !
6627
6628 xmas(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(max(1.0e-9,cx(mgs,ls)))
6629 swmasmx = 13.7e-6
6630! IF ( xmas(mgs,ls) > swmasmx ) THEN
6631! xmas(mgs,ls) = swmasmx
6632! cx(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xmas(mgs,ls))
6633! ENDIF
6634
6635 IF ( isnowdens == 2 ) THEN ! Set values according to Cox relationship
6636
6637 xdn(mgs,ls) = 0.0346159*sqrt(cx(mgs,ls)/(qx(mgs,ls)*rho0(mgs)) )
6638 xdn(mgs,ls) = max( 100.0, xdn(mgs,ls) ) ! limit snow to 100. to keep other equations in line
6639
6640 IF ( xdn(mgs,ls) <= 900. ) THEN
6641 dtmp = sqrt( xmas(mgs,ls)/0.069 ) ! diameter (meters) of mean mass particle using Cox 1998 relation (m = p d^2)
6642 xv(mgs,ls) = 28.8887*xmas(mgs,ls)**(3./2.)
6643 ELSE ! at small sizes, assume ice spheres
6644 xdn(mgs,ls) = 900.
6645 xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*max(1.0e-9,cx(mgs,ls)))
6646 dtmp = (xv(mgs,ls)*cwc0*6.0)**(1./3.)
6647 ENDIF
6648
6649 ELSE ! leave xdn(ls) at default value
6650 xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*max(1.0e-9,cx(mgs,ls)))
6651 dtmp = (xv(mgs,ls)*cwc0*6.0)**(1./3.)
6652 ENDIF
6653
6654 xdia(mgs,ls,1) = dtmp ! (xv(mgs,ls)*cwc0*6.0)**(1./3.)
6655
6656 IF ( xv(mgs,ls) .lt. xvmn(ls) .and. isnowdens == 1) THEN
6657 xv(mgs,ls) = max( xvmn(ls),xv(mgs,ls) )
6658 xmas(mgs,ls) = xv(mgs,ls)*xdn(mgs,ls)
6659 cx(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xmas(mgs,ls))
6660 xdia(mgs,ls,1) = (xv(mgs,ls)*cwc0*6.0)**(1./3.)
6661 ENDIF
6662
6663 IF ( xv(mgs,ls) .gt. xvmx(ls)*max(1.,100./min(100.,xdn(mgs,ls))) ) THEN
6664 xv(mgs,ls) = min( xvmx(ls), max( xvmn(ls),xv(mgs,ls) ) )
6665 xmas(mgs,ls) = 0.106214*xv(mgs,ls)**(2./3.)
6666 cx(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xmas(mgs,ls))
6667 xdn(mgs,ls) = 0.0346159*sqrt(cx(mgs,ls)/(qx(mgs,ls)*rho0(mgs)) )
6668 xdia(mgs,ls,1) = sqrt( xmas(mgs,ls)/0.069 )
6669 ENDIF
6670
6671 xdia(mgs,ls,3) = xdia(mgs,ls,1)
6672
6673 ELSE
6674 xdia(mgs,ls,1) = &
6675 & (qx(mgs,ls)*rho0(mgs)/(pi*xdn(mgs,ls)*cnostmp(mgs)))**(0.25)
6676 cx(mgs,ls) = cnostmp(mgs)*xdia(mgs,ls,1)
6677 xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*cx(mgs,ls))
6678 xdia(mgs,ls,3) = (xv(mgs,ls)*cwc0*6.0)**(1./3.)
6679 end if
6680 else
6681 xdia(mgs,ls,1) = 1.e-9
6682 xdia(mgs,ls,3) = 1.e-9
6683 cx(mgs,ls) = 0.0
6684
6685 IF ( isnowdens == 2 ) THEN ! Set values according to Cox relationship
6686 xdn(mgs,ls) = 90.
6687 ENDIF
6688
6689 end if
6690 xdia(mgs,ls,2) = xdia(mgs,ls,1)**2
6691! swdia3(mgs) = xdia(mgs,ls,2)*xdia(mgs,ls,1)
6692! xmas(mgs,ls) = xdn(mgs,ls)*(pi/6.)*swdia3(mgs)
6693 end do
6694
6695 ENDIF ! ls .gt 1
6696!
6697!
6698! ################################################################
6699!
6700! GRAUPEL
6701!
6702
6703 IF ( lh .gt. 1 .and. ( ildo == 0 .or. ildo == lh ) ) THEN
6704
6705 do mgs = 1,ngscnt
6706 if ( qx(mgs,lh) .gt. qxmin(lh) ) then
6707 if ( ipconc .ge. 5 ) then
6708
6709 xv(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*max(1.0e-9,cx(mgs,lh)))
6710 xmas(mgs,lh) = xv(mgs,lh)*xdn(mgs,lh)
6711
6712 IF ( xv(mgs,lh) .lt. xvmn(lh) .or. xv(mgs,lh) .gt. xvmx(lh) ) THEN
6713 xv(mgs,lh) = min( xvmx(lh), max( xvmn(lh),xv(mgs,lh) ) )
6714 xmas(mgs,lh) = xv(mgs,lh)*xdn(mgs,lh)
6715 cx(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xmas(mgs,lh))
6716 ENDIF
6717
6718 xdia(mgs,lh,3) = (xv(mgs,lh)*6.*pii)**(1./3.) ! mwfac*xdia(mgs,lh,1) ! (xv(mgs,lh)*cwc0*6.0)**(1./3.)
6719 IF ( dmuh == 1.0 ) THEN
6720 xdia(mgs,lh,1) = cwch(mgs)*xdia(mgs,lh,3)
6721 ELSE
6722 xdia(mgs,lh,1) = (xv(mgs,lh)*cwch(mgs))**(1./3.)
6723 ENDIF
6724
6725 ELSE
6726 xdia(mgs,lh,1) = &
6727 & (qx(mgs,lh)*rho0(mgs)/(pi*xdn(mgs,lh)*cno(lh)))**(0.25)
6728 cx(mgs,lh) = cno(lh)*xdia(mgs,lh,1)
6729 xv(mgs,lh) = max(xvmn(lh), rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) )
6730 xdia(mgs,lh,3) = (xv(mgs,lh)*6./pi)**(1./3.)
6731 end if
6732 else
6733 xdia(mgs,lh,1) = 1.e-9
6734 xdia(mgs,lh,3) = 1.e-9
6735 end if
6736 xdia(mgs,lh,2) = xdia(mgs,lh,1)**2
6737! hwdia3(mgs) = xdia(mgs,lh,2)*xdia(mgs,lh,1)
6738! xmas(mgs,lh) = xdn(mgs,lh)*(pi/6.)*hwdia3(mgs)
6739 end do
6740
6741 ENDIF
6742
6743!
6744! ################################################################
6745!
6746! HAIL
6747!
6748
6749 IF ( lhl .gt. 1 .and. ( ildo == 0 .or. ildo == lhl ) ) THEN
6750
6751 do mgs = 1,ngscnt
6752 if ( qx(mgs,lhl) .gt. qxmin(lhl) ) then
6753 if ( ipconc .ge. 5 ) then
6754
6755 xv(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*max(1.0e-9,cx(mgs,lhl)))
6756 xmas(mgs,lhl) = xv(mgs,lhl)*xdn(mgs,lhl)
6757! write(0,*) 'setvt: xv = ',xv(mgs,lhl),xdn(mgs,lhl),cx(mgs,lhl),xmas(mgs,lhl),qx(mgs,lhl)
6758
6759 IF ( xv(mgs,lhl) .lt. xvmn(lhl) .or. xv(mgs,lhl) .gt. xvmx(lhl) ) THEN
6760 xv(mgs,lhl) = min( xvmx(lhl), max( xvmn(lhl),xv(mgs,lhl) ) )
6761 xmas(mgs,lhl) = xv(mgs,lhl)*xdn(mgs,lhl)
6762 cx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/(xmas(mgs,lhl))
6763 ENDIF
6764
6765 xdia(mgs,lhl,3) = (xv(mgs,lhl)*6./pi)**(1./3.) ! mwfac*xdia(mgs,lh,1) ! (xv(mgs,lh)*cwc0*6.0)**(1./3.)
6766 IF ( dmuhl == 1.0 ) THEN
6767 xdia(mgs,lhl,1) = cwchl(mgs)*xdia(mgs,lhl,3)
6768 ELSE
6769 xdia(mgs,lhl,1) = (xv(mgs,lhl)*cwchl(mgs))**(1./3.)
6770 ENDIF
6771
6772! write(0,*) 'setvt: xv = ',xv(mgs,lhl),xdn(mgs,lhl),cx(mgs,lhl),xdia(mgs,lhl,3)
6773 ELSE
6774 xdia(mgs,lhl,1) = &
6775 & (qx(mgs,lhl)*rho0(mgs)/(pi*xdn(mgs,lhl)*cno(lhl)))**(0.25)
6776 cx(mgs,lhl) = cno(lhl)*xdia(mgs,lhl,1)
6777 xv(mgs,lhl) = max(xvmn(lhl), rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*cx(mgs,lhl)) )
6778 xdia(mgs,lhl,3) = (xv(mgs,lhl)*6./pi)**(1./3.)
6779 end if
6780 else
6781 xdia(mgs,lhl,1) = 1.e-9
6782 xdia(mgs,lhl,3) = 1.e-9
6783 end if
6784 xdia(mgs,lhl,2) = xdia(mgs,lhl,1)**2
6785! hwdia3(mgs) = xdia(mgs,lh,2)*xdia(mgs,lh,1)
6786! xmas(mgs,lh) = xdn(mgs,lh)*(pi/6.)*hwdia3(mgs)
6787 end do
6788
6789 ENDIF
6790!
6791!
6792!
6793! Set terminal velocities...
6794! also set drag coefficients (moved to start of subroutine)
6795!
6796! cdx(lr) = 0.60
6797! cdx(lh) = 0.45
6798! cdx(lhl) = 0.45
6799! cdx(lf) = 0.45
6800! cdx(lgh) = 0.60
6801! cdx(lgm) = 0.80
6802! cdx(lgl) = 0.80
6803! cdx(lir) = 2.00
6804!
6805 if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set terminal velocities'
6806!
6807!
6808! ################################################################
6809!
6810! RAIN
6811!
6812 IF ( ildo == 0 .or. ildo == lr ) THEN
6813 do mgs = 1,ngscnt
6814 if ( qx(mgs,lr) .gt. qxmin(lr) ) then
6815 IF ( ipconc .lt. 3 ) THEN
6816 vtxbar(mgs,lr,1) = rainfallfac*(ar*gf4br/6.0)*(xdia(mgs,lr,1)**br)*rhovt(mgs)
6817! write(91,*) 'vtxbar: ',vtxbar(mgs,lr,1),mgs,gf4br,xdia(mgs,lr,1),rhovt(mgs)
6818 ELSE
6819
6820 IF ( imurain == 1 ) THEN ! DSD of Diameter
6821
6822 ! using functional form of arx*(1 - Exp(-frx*diameter) ), with arx = arx = 10.
6823 ! and frx = 516.575 ! raind fit parameters for arx*(1 - Exp(-fx*d)), where d is rain diameter in meters.
6824 ! Similar form as in Atlas et al. (1973), who had 9.65 - 10.3*Exp[-600 * d]
6825
6826
6827 alp = alpha(mgs,lr)
6828
6829 vtxbar(mgs,lr,1) = rhovt(mgs)*arx*(1.0 - (1.0 + frx*xdia(mgs,lr,1))**(-alp - 4.0) ) ! mass weighted
6830
6831 IF ( infdo .ge. 1 .and. rssflg == 1 ) THEN
6832 vtxbar(mgs,lr,2) = rhovt(mgs)*arx*(1.0 - (1.0 + frx*xdia(mgs,lr,1))**(-alp - 1.0) ) ! number weighted
6833 ELSE
6834 vtxbar(mgs,lr,2) = vtxbar(mgs,lr,1)
6835 ENDIF
6836
6837 IF ( infdo .ge. 2 .and. rssflg == 1 ) THEN
6838 vtxbar(mgs,lr,3) = rhovt(mgs)*arx*(1.0 - (1.0 + frx*xdia(mgs,lr,1))**(-alp - 7.0) ) ! z-weighted
6839 ELSE
6840 vtxbar(mgs,lr,3) = vtxbar(mgs,lr,1)
6841 ENDIF
6842
6843! write(91,*) 'setvt: alp,vn,vm,vz = ',alp,vtxbar(mgs,lr,2), vtxbar(mgs,lr,1), vtxbar(mgs,lr,3),alpha(mgs,lr)
6844
6845 ELSEIF ( imurain == 3 ) THEN ! DSD of Volume
6846
6847 IF ( lzr < 1 ) THEN ! not 3-moment rain
6848 rwdia = min( xdia(mgs,lr,1), 8.0e-3 )
6849
6850 vtxbar(mgs,lr,1) = rhovt(mgs)*6.0*pii*( 0.04771 + 3788.0*rwdia - &
6851 & 1.105e6*rwdia**2 + 1.412e8*rwdia**3 - 6.527e9*rwdia**4)
6852
6853 IF ( infdo .ge. 1 ) THEN
6854 IF ( rssflg >= 1 ) THEN
6855 vtxbar(mgs,lr,2) = (0.09112 + 2714.0*rwdia - 4.872e5*rwdia**2 + &
6856 & 4.495e7*rwdia**3 - 1.626e9*rwdia**4)*rhovt(mgs)
6857 ELSE
6858 vtxbar(mgs,lr,2) = vtxbar(mgs,lr,1)
6859 ENDIF
6860 ENDIF
6861
6862 IF ( infdo .ge. 2 ) THEN ! Z-weighted fall speed
6863 vtxbar(mgs,lr,3) = rhovt(mgs)*( &
6864 & 0.0911229 + &
6865 & 9246.494*(rwdia) - &
6866 & 3.2839926e6*(rwdia**2) + &
6867 & 4.944093e8*(rwdia**3) - &
6868 & 2.631718e10*(rwdia**4) )
6869 ENDIF
6870
6871 ELSE ! 3-moment rain, gamma-volume
6872
6873 vr = xv(mgs,lr)
6874 rnux = alpha(mgs,lr)
6875
6876 IF ( infdo .ge. 1 .and. rssflg == 1) THEN ! number-weighted; DTD: added size-sorting flag
6877 vtxbar(mgs,lr,2) = rhovt(mgs)* &
6878 & (((1. + rnux)/vr)**(-1.333333)* &
6879 & (0.0911229*((1. + rnux)/vr)**1.333333*gamma_sp(1. + rnux) + &
6880 & (5430.3131*(1. + rnux)*gamma_sp(4./3. + rnux))/ &
6881 & vr - 1.0732802e6*((1. + rnux)/vr)**0.6666667* &
6882 & gamma_sp(1.666667 + rnux) + &
6883 & 8.584110982429507e7*((1. + rnux)/vr)**(1./3.)* &
6884 & gamma_sp(2. + rnux) - &
6885 & 2.3303765697228556e9*gamma_sp(7./3. + rnux)))/ &
6886 & gamma_sp(1. + rnux)
6887 ENDIF
6888
6889! mass-weighted
6890 vtxbar(mgs,lr,1) = rhovt(mgs)* &
6891 & (0.0911229*(1 + rnux)**1.3333333333333333*gamma_sp(2. + rnux) + &
6892 & 5430.313059683277*(1 + rnux)*vr**0.3333333333333333* &
6893 & gamma_sp(2.333333333333333 + rnux) - &
6894 & 1.0732802065650471e6*(1 + rnux)**0.6666666666666666*vr**0.6666666666666666* &
6895 & gamma_sp(2.6666666666666667 + rnux) + &
6896 & 8.584110982429507e7*(1 + rnux)**0.3333333333333333*vr*gamma_sp(3 + rnux) - &
6897 & 2.3303765697228556e9*vr**1.3333333333333333* &
6898 & gamma_sp(3.333333333333333 + rnux))/ &
6899 & ((1 + rnux)**2.333333333333333*gamma_sp(1 + rnux))
6900
6901 IF(infdo .ge. 1 .and. rssflg == 0) THEN ! No size-sorting, set N-weighted fall speed to mass-weighted
6902 vtxbar(mgs,lr,2) = vtxbar(mgs,lr,1)
6903 ENDIF
6904
6905 IF ( infdo .ge. 2 .and. rssflg == 1) THEN ! Z-weighted fall speed
6906 vtxbar(mgs,lr,3) = rhovt(mgs)* &
6907 & ((1. + rnux)*(0.0911229*(1 + rnux)**1.3333333333333333*gamma_sp(3. + rnux) + &
6908 & 5430.313059683277*(1 + rnux)*vr**0.3333333333333333* &
6909 & gamma_sp(3.3333333333333335 + rnux) - &
6910 & 1.0732802065650471e6*(1 + rnux)**0.6666666666666666* &
6911 & vr**0.6666666666666666*gamma_sp(3.6666666666666665 + rnux) + &
6912 & 8.5841109824295e7*(1 + rnux)**0.3333333333333333*vr*gamma_sp(4. + rnux) - &
6913 & 2.3303765697228556e9*vr**1.3333333333333333* &
6914 & gamma_sp(4.333333333333333 + rnux)))/ &
6915 & ((1 + rnux)**3.3333333333333335*(2 + rnux)*gamma_sp(1 + rnux))
6916
6917! write(0,*) 'setvt: mgs,lzr,infdo = ',mgs,lzr,infdo
6918! write(0,*) 'vt1,2,3 = ',vtxbar(mgs,lr,1),vtxbar(mgs,lr,2),vtxbar(mgs,lr,3)
6919
6920 ELSEIF (infdo .ge. 2) THEN ! No size-sorting, set Z-weighted fall speed to mass-weighted
6921 vtxbar(mgs,lr,3) = vtxbar(mgs,lr,1)
6922 ENDIF
6923
6924
6925 ENDIF
6926 ENDIF ! imurain
6927
6928! IF ( rwrad*mwfac .gt. 6.0e-4 ) THEN
6929! vtxbar(mgs,lr,1) = 20.1*Sqrt(100.*rwrad*mwfac)*rhovt(mgs)
6930! ELSE
6931! vtxbar(mgs,lr,1) = 80.0e2*rwrad*rhovt(mgs)*mwfac
6932! ENDIF
6933! IF ( rwrad .gt. 6.0e-4 ) THEN
6934! vtxbar(mgs,lr,2) = 20.1*Sqrt(100.*rwrad)*rhovt(mgs)
6935! ELSE
6936! vtxbar(mgs,lr,2) = 80.0e2*rwrad*rhovt(mgs)
6937! ENDIF
6938 ENDIF ! ipconc
6939 else ! qr < qrmin
6940 vtxbar(mgs,lr,1) = 0.0
6941 vtxbar(mgs,lr,2) = 0.0
6942 end if
6943 end do
6944 if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set rain vt'
6945
6946 ENDIF
6947!
6948! ################################################################
6949!
6950! SNOW !Zrnic et al. (1993)
6951!
6952 IF ( ls .gt. 1 .and. ( ildo == 0 .or. ildo == ls ) ) THEN
6953 do mgs = 1,ngscnt
6954 if ( qx(mgs,ls) .gt. qxmin(ls) ) then
6955 IF ( ipconc .ge. 4 ) THEN
6956 if ( mixedphase .and. qsvtmod ) then
6957 else
6958 IF ( isnowfall == 1 ) THEN
6959 ! original (Zrnic et al. 1993)
6960 vtxbar(mgs,ls,1) = 5.72462*rhovt(mgs)*(xv(mgs,ls))**(1./12.)
6961 ELSEIF ( isnowfall == 2 ) THEN
6962 ! Ferrier:
6963 IF ( isnowdens == 1 ) THEN
6964 vtxbar(mgs,ls,1) = 11.9495*rhovt(mgs)*(xv(mgs,ls))**(0.14)
6965 ELSE
6966 vtxbar(mgs,ls,1) = 11.9495*rhovt(mgs)*(xv(mgs,ls)*xdn(mgs,ls)/100.)**(0.14)
6967 ENDIF
6968 ELSEIF ( isnowfall == 3 ) THEN
6969 ! Cox, mass distrib:
6970 vtxbar(mgs,ls,1) = 50.092*rhovt(mgs)*(xmas(mgs,ls))**(0.2635)
6971 ENDIF
6972
6973 IF(abs(sssflg) >= 1) THEN
6974 IF ( isnowfall == 1 ) THEN
6975 vtxbar(mgs,ls,2) = 4.04091*rhovt(mgs)*(xv(mgs,ls))**(1./12.)
6976 ELSEIF ( isnowfall == 2 ) THEN
6977 ! Ferrier:
6978 IF ( isnowdens == 1 ) THEN
6979 vtxbar(mgs,ls,2) = 7.02909*rhovt(mgs)*(xv(mgs,ls))**(0.14) ! bug fix 11/15/2015: was rewriting to mass fall speed vtxbar(mgs,ls,1)
6980 ELSE
6981 vtxbar(mgs,ls,2) = 7.02909*rhovt(mgs)*(xv(mgs,ls)*xdn(mgs,ls)/100.)**(0.14) ! bug fix 11/15/2015: was rewriting to mass fall speed vtxbar(mgs,ls,1)
6982 ENDIF
6983 ELSEIF ( isnowfall == 3 ) THEN
6984 ! Cox, mass distrib:
6985 vtxbar(mgs,ls,2) = 21.6147*rhovt(mgs)*(xmas(mgs,ls))**(0.2635)
6986 ENDIF
6987 ELSE
6988 vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1)
6989 ENDIF
6990 IF ( infdo >= 2 ) THEN
6991 IF ( isnowfall == 1 ) THEN
6992 vtxbar(mgs,ls,3) = 6.12217*rhovt(mgs)*(xv(mgs,ls))**(1./12.) ! Zrnic et al 93
6993 ELSEIF ( isnowfall == 2 ) THEN
6994 vtxbar(mgs,ls,3) = 13.3436*rhovt(mgs)*(xv(mgs,ls))**(0.14) ! Ferrier 94
6995 ELSEIF ( isnowfall == 3 ) THEN
6996 ! Cox, mass distrib:
6997 vtxbar(mgs,ls,3) = 61.0914*rhovt(mgs)*(xmas(mgs,ls))**(0.2635)
6998 ENDIF
6999 ENDIF
7000
7001 IF ( sssflg < 0 .and. temcg(mgs) > abs(sssflg) ) THEN ! above a given temperature, effectively turn off size sorting
7002 vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1)
7003 vtxbar(mgs,ls,3) = vtxbar(mgs,ls,1)
7004 ENDIF
7005
7006 endif
7007 ELSE ! single-moment:
7008 vtxbar(mgs,ls,1) = (cs*gf4ds/6.0)*(xdia(mgs,ls,1)**ds)*rhovt(mgs)
7009 vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1)
7010 ENDIF
7011 else
7012 vtxbar(mgs,ls,1) = 0.0
7013 end if
7014
7015 IF ( snowfallfac /= 1.0 ) THEN
7016 vtxbar(mgs,ls,1) = snowfallfac*vtxbar(mgs,ls,1)
7017 vtxbar(mgs,ls,2) = snowfallfac*vtxbar(mgs,ls,2)
7018 vtxbar(mgs,ls,3) = snowfallfac*vtxbar(mgs,ls,3)
7019 ENDIF
7020
7021
7022 end do
7023 if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set snow vt'
7024
7025 ENDIF ! ls .gt. 1
7026!
7027!
7028! ################################################################
7029!
7030! GRAUPEL !Wisner et al. (1972)
7031!
7032 IF ( lh .gt. 1 .and. ( ildo == 0 .or. ildo == lh ) ) THEN
7033
7034 do mgs = 1,ngscnt
7035 vtxbar(mgs,lh,1) = 0.0
7036 if ( qx(mgs,lh) .gt. qxmin(lh) ) then
7037 cd = cdx(lh)
7038 IF ( icdx .eq. 1 ) THEN
7039 cd = cdx(lh)
7040 ELSEIF ( icdx .eq. 2 ) THEN
7041! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(xdnmx(lh) - xdn(mgs,lh))/(xdnmx(lh)-xdnmn(lh)) ) )
7042! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(900.0 - xdn(mgs,lh))/(900. - 300.) ) )
7043 cd = max(0.45, min(1.0, 0.45 + 0.35*(800.0 - max( 500., min( 800.0, xdn(mgs,lh) ) ) )/(800. - 500.) ) )
7044! cd = Max(0.55, Min(1.0, 0.55 + 0.25*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 500.) ) )
7045 ELSEIF ( icdx .eq. 3 ) THEN
7046! cd = Max(0.45, Min(1.0, 0.45 + 0.55*(800.0 - Max( 300., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 300.) ) )
7047 cd = max(0.45, min(1.2, 0.45 + 0.55*(800.0 - max( hdnmn, min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) )
7048 ELSEIF ( icdx .eq. 4 ) THEN
7049 cd = max(cdhmin, min(cdhmax, cdhmin + (cdhmax-cdhmin)* &
7050 & (cdhdnmax - max( cdhdnmin, min( cdhdnmax, xdn(mgs,lh) ) ) )/(cdhdnmax - cdhdnmin) ) )
7051 ELSEIF ( icdx .eq. 5 ) THEN
7052 cd = cdx(lh)*(xdn(mgs,lh)/rho_qh)**(2./3.)
7053 ELSEIF ( icdx .eq. 6 ) THEN ! Milbrandt and Morrison (2013)
7054 indxr = int( (xdn(mgs,lh)-50.)/100. ) + 1
7055 indxr = min( ngdnmm, max(1,indxr) )
7056
7057
7058 delrho = max( 0.0, 0.01*(xdn(mgs,lh) - mmgraupvt(indxr,1)) )
7059 IF ( indxr < ngdnmm ) THEN
7060
7061 axx(mgs,lh) = mmgraupvt(indxr,2) + delrho*(mmgraupvt(indxr+1,2) - mmgraupvt(indxr,2) )
7062 bxx(mgs,lh) = mmgraupvt(indxr,3) + delrho*(mmgraupvt(indxr+1,3) - mmgraupvt(indxr,3) )
7063
7064
7065 ELSE
7066 axx(mgs,lh) = mmgraupvt(indxr,2)
7067 bxx(mgs,lh) = mmgraupvt(indxr,3)
7068 ENDIF
7069
7070 aax = axx(mgs,lh)
7071 bbx = bxx(mgs,lh)
7072
7073 cd = max(0.45, min(1.2, 0.45 + 0.55*(800.0 - max( hdnmn, min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) )
7074
7075 ELSEIF ( icdx <= 0 ) THEN !
7076 aax = ax(lh)
7077 bbx = bx(lh)
7078 cd = max(0.45, min(1.2, 0.45 + 0.55*(800.0 - max( hdnmn, min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) )
7079 ELSE
7080 cd = max(0.45, min(1.2, 0.45 + 0.55*(800.0 - max( hdnmn, min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) )
7081 ENDIF
7082
7083 cdxgs(mgs,lh) = cd
7084 IF ( alpha(mgs,lh) .eq. 0.0 .and. icdx > 0 .and. icdx /= 6 ) THEN
7085! axx(mgs,lh) = (gf4p5/6.0)* &
7086! & Sqrt( (xdn(mgs,lh)*4.0*gr) / &
7087! & (3.0*cd*rho0(mgs)) )
7088 axx(mgs,lh) = sqrt(4.0*xdn(mgs,lh)*gr/(3.0*cd*rho00))
7089 bxx(mgs,lh) = 0.5
7090 vtxbar(mgs,lh,1) = (gf4p5/6.0)* rhovt(mgs)*axx(mgs,lh) * sqrt(xdia(mgs,lh,1))
7091! vtxbar(mgs,lh,1) = (gf4p5/6.0)* &
7092! & Sqrt( (xdn(mgs,lh)*xdia(mgs,lh,1)*4.0*gr) / &
7093! & (3.0*cd*rho0(mgs)) )
7094 ELSE
7095 IF ( icdx /= 6 ) bbx = bx(lh)
7096 tmp = 4. + alpha(mgs,lh) + bbx
7097 i = int(dgami*(tmp))
7098 del = tmp - dgam*i
7099 x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
7100
7101 tmp = 4. + alpha(mgs,lh)
7102 i = int(dgami*(tmp))
7103 del = tmp - dgam*i
7104 y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
7105
7106! aax = Max( 1.0, Min(2.0, (xdn(mgs,lh)/400.) ) )
7107! vtxbar(mgs,lh,1) = rhovt(mgs)*aax*ax(lh)*(xdia(mgs,lh,1)**bx(lh)*x)/y
7108
7109 IF ( icdx > 0 .and. icdx /= 6) THEN
7110 aax = sqrt(4.0*xdn(mgs,lh)*gr/(3.0*cd*rho00))
7111 vtxbar(mgs,lh,1) = rhovt(mgs)*aax* sqrt(xdia(mgs,lh,1)) * x/y
7112 axx(mgs,lh) = aax
7113 bxx(mgs,lh) = bbx
7114 ELSEIF (icdx == 6 ) THEN
7115 vtxbar(mgs,lh,1) = rhovt(mgs)*aax* xdia(mgs,lh,1)**bbx * x/y
7116 ELSE ! icdx < 0
7117 axx(mgs,lh) = ax(lh)
7118 bxx(mgs,lh) = bx(lh)
7119 vtxbar(mgs,lh,1) = rhovt(mgs)*ax(lh)*(xdia(mgs,lh,1)**bx(lh)*x)/y
7120 ENDIF
7121
7122! & Gamma_sp(4.0 + dnu(lh) + 0.6))/Gamma_sp(4. + dnu(lh))
7123 ENDIF
7124
7125 IF ( lwsm6 .and. ipconc == 0 ) THEN
7126! vtxbar(mgs,lh,1) = (330.*gf4ds/6.0)*(xdia(mgs,ls,1)**ds)*rhovt(mgs)
7127 vtxbar(mgs,lh,1) = (330.*gf4br/6.0)*(xdia(mgs,lh,1)**br)*rhovt(mgs)
7128 ENDIF
7129
7130 end if
7131 end do
7132 if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt'
7133
7134 ENDIF ! lh .gt. 1
7135!
7136!
7137! ################################################################
7138!
7139! HAIL
7140!
7141 IF ( lhl .gt. 1 .and. ( ildo == 0 .or. ildo == lhl ) ) THEN
7142
7143 do mgs = 1,ngscnt
7144 vtxbar(mgs,lhl,1) = 0.0
7145 if ( qx(mgs,lhl) .gt. qxmin(lhl) ) then
7146
7147 IF ( icdxhl .eq. 1 ) THEN
7148 cd = cdx(lhl)
7149 ELSEIF ( icdxhl .eq. 3 ) THEN
7150! cd = Max(0.45, Min(1.0, 0.45 + 0.55*(800.0 - Max( 300., Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 300.) ) )
7151 cd = max(0.45, min(1.2, 0.45 + 0.55*(800.0 - max( hldnmn, min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 170.0) ) )
7152 ELSEIF ( icdxhl .eq. 4 ) THEN
7153 cd = max(cdhlmin, min(cdhlmax, cdhlmin + (cdhlmax-cdhlmin)* &
7154 & (cdhldnmax - max( cdhldnmin, min( cdhldnmax, xdn(mgs,lhl) ) ) )/(cdhldnmax - cdhldnmin) ) )
7155 ELSEIF ( icdxhl .eq. 5 ) THEN
7156 cd = cdx(lh)*(xdn(mgs,lhl)/rho_qh)**(2./3.)
7157 ELSEIF ( icdxhl .eq. 6 ) THEN ! Milbrandt and Morrison (2013)
7158 indxr = int( (xdn(mgs,lhl)-50.)/100. ) + 1
7159 indxr = min( ngdnmm, max(1,indxr) )
7160
7161
7162 delrho = max( 0.0, 0.01*(xdn(mgs,lhl) - mmgraupvt(indxr,1)) )
7163 IF ( indxr < ngdnmm ) THEN
7164
7165 axx(mgs,lhl) = mmgraupvt(indxr,2) + delrho*(mmgraupvt(indxr+1,2) - mmgraupvt(indxr,2) )
7166 bxx(mgs,lhl) = mmgraupvt(indxr,3) + delrho*(mmgraupvt(indxr+1,3) - mmgraupvt(indxr,3) )
7167
7168
7169 ELSE
7170 axx(mgs,lhl) = mmgraupvt(indxr,2)
7171 bxx(mgs,lhl) = mmgraupvt(indxr,3)
7172 ENDIF
7173
7174 aax = axx(mgs,lhl)
7175 bbx = bxx(mgs,lhl)
7176
7177 cd = max(0.45, min(1.2, 0.45 + 0.55*(800.0 - max( hldnmn, min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 170.0) ) )
7178
7179 ELSE
7180! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(900.0 - xdn(mgs,lhl))/(900. - 300.) ) )
7181! cd = Max(0.5, Min(0.8, 0.5 + 0.3*(xdnmx(lhl) - xdn(mgs,lhl))/(xdnmx(lhl)-xdnmn(lhl)) ) )
7182! cd = Max(0.45, Min(0.6, 0.45 + 0.15*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 500.) ) )
7183 cd = max(0.45, min(1.2, 0.45 + 0.55*(800.0 - max( hldnmn, min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 170.0) ) )
7184 ENDIF
7185
7186 cdxgs(mgs,lhl) = cd
7187
7188 IF ( alpha(mgs,lhl) .eq. 0.0 .and. icdxhl > 0 .and. icdxhl /= 6) THEN
7189! axx(mgs,lhl) = (gf4p5/6.0)* &
7190! & Sqrt( (xdn(mgs,lhl)*4.0*gr) / &
7191! & (3.0*cd*rho0(mgs)) )
7192 axx(mgs,lhl) = sqrt(4.0*xdn(mgs,lhl)*gr/(3.0*cd*rho00))
7193 bxx(mgs,lhl) = 0.5
7194 vtxbar(mgs,lhl,1) = (gf4p5/6.0)* rhovt(mgs)*axx(mgs,lhl) * sqrt(xdia(mgs,lhl,1))
7195 ELSE
7196 IF ( icdxhl /= 6 ) bbx = bx(lhl)
7197 tmp = 4. + alpha(mgs,lhl) + bbx
7198 i = int(dgami*(tmp))
7199 del = tmp - dgam*i
7200 x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
7201
7202 tmp = 4. + alpha(mgs,lhl)
7203 i = int(dgami*(tmp))
7204 del = tmp - dgam*i
7205 y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
7206
7207 IF ( icdxhl > 0 .and. icdxhl /= 6) THEN
7208 aax = sqrt(4.0*xdn(mgs,lhl)*gr/(3.0*cd*rho00))
7209 vtxbar(mgs,lhl,1) = rhovt(mgs)*aax* sqrt(xdia(mgs,lhl,1)) * x/y
7210 axx(mgs,lhl) = aax
7211 bxx(mgs,lhl) = bbx
7212 ELSEIF ( icdxhl == 6 ) THEN
7213 vtxbar(mgs,lhl,1) = rhovt(mgs)*aax* (xdia(mgs,lhl,1))**bbx * x/y
7214 ELSE
7215 axx(mgs,lhl) = ax(lhl)
7216 bxx(mgs,lhl) = bx(lhl)
7217 vtxbar(mgs,lhl,1) = rhovt(mgs)*(ax(lhl)*xdia(mgs,lhl,1)**bx(lhl)*x)/y
7218 ENDIF
7219
7220! & Gamma_sp(4.0 + dnu(lh) + 0.6))/Gamma_sp(4. + dnu(lh))
7221 ENDIF
7222
7223
7224 end if
7225 end do
7226 if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt'
7227
7228 ENDIF ! lhl .gt. 1
7229
7230
7231 IF ( infdo .ge. 1 ) THEN
7232
7233! DO il = lc,lhab
7234! IF ( il .ne. lr ) THEN
7235 DO mgs = 1,ngscnt
7236 IF ( ildo == 0 .or. ildo == lc ) THEN
7237 vtxbar(mgs,lc,2) = vtxbar(mgs,lc,1)
7238 ENDIF
7239 IF ( li .gt. 1 ) THEN
7240! vtxbar(mgs,li,2) = rhovt(mgs)*49420.*1.25447*xdia(mgs,li,1)**(1.415) ! n-wgt (Ferrier 94)
7241! vtxbar(mgs,li,2) = vtxbar(mgs,li,1)
7242
7243! test print stuff...
7244! IF ( xdia(mgs,li,1) .gt. 200.e-6 ) THEN
7245! tmp = (xv(mgs,li)*cwc0)**(1./3.)
7246! x = rhovt(mgs)*49420.*40.0005/5.40662*tmp**(1.415)
7247! y = rhovt(mgs)*49420.*1.25447*tmp**(1.415)
7248! write(6,*) 'Ice fall: ',vtxbar(mgs,li,1),x,y,tmp,xdia(mgs,li,1)
7249! ENDIF
7250 ENDIF
7251! vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1)
7252 ENDDO
7253
7254 IF ( lg .gt. lr ) THEN
7255
7256 DO il = lg,lhab
7257 IF ( ildo == 0 .or. ildo == il ) THEN
7258
7259 DO mgs = 1,ngscnt
7260 IF ( qx(mgs,il) .gt. qxmin(il) ) THEN
7261 IF ( (il .eq. lh .and. hssflg == 1) .or. ( lhl .gt. 1 .and. il .eq. lhl .and. hlssflg == 1) ) THEN ! DTD: added flag for size-sorting
7262
7263 ! DTD: allow for setting of number-weighted and z-weighted fall speeds to the mass-weighted value,
7264 ! effectively turning off size-sorting
7265
7266 IF ( il .eq. lh ) THEN ! {
7267
7268 IF ( icdx .eq. 1 ) THEN
7269 cd = cdx(lh)
7270 ELSEIF ( icdx .eq. 2 ) THEN
7271! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(xdnmx(lh) - xdn(mgs,lh))/(xdnmx(lh)-xdnmn(lh)) ) )
7272! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(900.0 - xdn(mgs,lh))/(900. - 300.) ) )
7273 cd = max(0.45, min(1.0, 0.45 + 0.35*(800.0 - max( 500., min( 800.0, xdn(mgs,lh) ) ) )/(800. - 500.) ) )
7274! cd = Max(0.55, Min(1.0, 0.55 + 0.25*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 500.) ) )
7275 ELSEIF ( icdx .eq. 3 ) THEN
7276! cd = Max(0.45, Min(1.0, 0.45 + 0.55*(800.0 - Max( 170.0, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) )
7277 cd = max(0.45, min(1.2, 0.45 + 0.55*(800.0 - max( hdnmn, min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) )
7278 ELSEIF ( icdx .eq. 4 ) THEN
7279 cd = max(cdhmin, min(cdhmax, cdhmin + (cdhmax-cdhmin)* &
7280 & (cdhdnmax - max( cdhdnmin, min( cdhdnmax, xdn(mgs,lh) ) ) )/(cdhdnmax - cdhdnmin) ) )
7281 ELSEIF ( icdx .eq. 5 ) THEN
7282 cd = cdx(lh)*(xdn(mgs,lh)/rho_qh)**(2./3.)
7283 ELSEIF ( icdx .eq. 6 ) THEN ! Milbrandt and Morrison (2013)
7284 aax = axx(mgs,lh)
7285 bbx = bxx(mgs,lh)
7286 ELSEIF ( icdx <= 0 ) THEN !
7287 aax = ax(lh)
7288 bbx = bx(lh)
7289 ENDIF
7290
7291 ELSEIF ( lhl .gt. 1 .and. il .eq. lhl ) THEN
7292
7293 IF ( icdxhl .eq. 1 ) THEN
7294 cd = cdx(lhl)
7295 ELSEIF ( icdxhl .eq. 3 ) THEN
7296! cd = Max(0.45, Min(1.0, 0.45 + 0.55*(800.0 - Max( 300., Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 300.) ) )
7297 cd = max(0.45, min(1.2, 0.45 + 0.55*(800.0 - max( hldnmn, min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 170.0) ) )
7298 ELSEIF ( icdxhl .eq. 4 ) THEN
7299 cd = max(cdhlmin, min(cdhlmax, cdhlmin + (cdhlmax-cdhlmin)* &
7300 & (cdhldnmax - max( cdhldnmin, min( cdhldnmax, xdn(mgs,lhl) ) ) )/(cdhldnmax - cdhldnmin) ) )
7301 ELSEIF ( icdxhl == 5 ) THEN
7302! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(900.0 - xdn(mgs,lhl))/(900. - 300.) ) )
7303! cd = Max(0.5, Min(0.8, 0.5 + 0.3*(xdnmx(lhl) - xdn(mgs,lhl))/(xdnmx(lhl)-xdnmn(lhl)) ) )
7304 cd = max(0.45, min(0.6, 0.45 + 0.15*(800.0 - max( 500., min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 500.) ) )
7305 ELSEIF ( icdxhl .eq. 6 ) THEN ! Milbrandt and Morrison (2013)
7306 aax = axx(mgs,lhl)
7307 bbx = bxx(mgs,lhl)
7308 ELSEIF ( icdxhl <= 0 ) THEN !
7309 aax = ax(lhl)
7310 bbx = bx(lhl)
7311 ENDIF
7312
7313 ENDIF ! }
7314
7315 IF ( alpha(mgs,il) .eq. 0. .and. infdo .lt. 2 .and. &
7316 ( ( il==lh .and. icdx > 0 .and. icdx /= 6) .or. ( il==lhl .and. icdxhl > 0 .and. icdxhl /= 6 ) ) ) THEN ! {
7317 vtxbar(mgs,il,2) = &
7318 & sqrt( (xdn(mgs,il)*xdia(mgs,il,1)*pi*gr) / &
7319 & (3.0*cd*max(0.05,rho0(mgs))) )
7320
7321 ELSE
7322 IF ( il == lh .and. icdx /= 6 ) bbx = bx(il)
7323 IF ( il == lhl .and. icdxhl /= 6 ) bbx = bx(il)
7324 tmp = 1. + alpha(mgs,il) + bbx
7325 i = int(dgami*(tmp))
7326 del = tmp - dgam*i
7327 x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
7328
7329 tmp = 1. + alpha(mgs,il)
7330 i = int(dgami*(tmp))
7331 del = tmp - dgam*i
7332 y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
7333
7334 IF ( il .eq. lh .or. il .eq. lhl) THEN ! {
7335 IF ( ( il==lh .and. icdx > 0 ) ) THEN
7336 IF ( icdx /= 6 ) THEN
7337 aax = sqrt(4.0*xdn(mgs,il)*gr/(3.0*cd*rho00))
7338 vtxbar(mgs,il,2) = rhovt(mgs)*aax* xdia(mgs,il,1)**bx(il) * x/y
7339 ELSE ! (icdx == 6 ) THEN
7340 vtxbar(mgs,il,2) = rhovt(mgs)*aax* xdia(mgs,il,1)**bbx * x/y
7341 ENDIF
7342
7343 ELSEIF ( ( il==lhl .and. icdxhl > 0 ) ) THEN
7344 IF ( icdxhl /= 6 ) THEN
7345 aax = sqrt(4.0*xdn(mgs,il)*gr/(3.0*cd*rho00))
7346 vtxbar(mgs,il,2) = rhovt(mgs)*aax* xdia(mgs,il,1)**bx(il) * x/y
7347 ELSE ! ( icdxhl == 6 )
7348 vtxbar(mgs,il,2) = rhovt(mgs)*aax* xdia(mgs,il,1)**bbx * x/y
7349 ENDIF
7350 ELSE ! get here if il==lh and icdx < 0 -- or -- il==lhl and icdxhl < 0
7351 aax = ax(il)
7352 vtxbar(mgs,il,2) = rhovt(mgs)*ax(il)*(xdia(mgs,il,1)**bx(il)*x)/y
7353 ENDIF
7354! vtxbar(mgs,il,2) = &
7355! & rhovt(mgs)*(xdn(mgs,il)/400.)*(75.715*xdia(mgs,il,1)**0.6* &
7356! & x)/y
7357! vtxbar(mgs,il,2) = &
7358! & rhovt(mgs)*(xdn(mgs,il)/400.)*(ax(il)*xdia(mgs,il,1)**bx(il)* &
7359! & x)/y
7360 IF ( infdo .ge. 2 ) THEN ! Z-weighted
7361
7362 tmp = 7. + alpha(mgs,il) + bbx
7363 i = int(dgami*(tmp))
7364 del = tmp - dgam*i
7365 x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
7366
7367 tmp = 7. + alpha(mgs,il)
7368 i = int(dgami*(tmp))
7369 del = tmp - dgam*i
7370 y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
7371
7372 vtxbar(mgs,il,3) = rhovt(mgs)* &
7373 & (aax*(xdia(mgs,il,1) )**bbx * &
7374 & x)/y
7375! & Gamma(7.0 + alpha(mgs,il) + bbx)/Gamma(7. + alpha(mgs,il))
7376 IF ( .not. (vtxbar(mgs,il,1) > -1. .and. vtxbar(mgs,il,1) < 200. ) .or. &
7377 .not. (vtxbar(mgs,il,3) > -1. .and. vtxbar(mgs,il,3) < 200. ) ) THEN
7378 write(0,*) 'Setvtz: problem with vtxbar1/3: ',il,vtxbar(mgs,il,1),vtxbar(mgs,il,3),aax,bbx,x,y
7379 write(0,*) 'q, number, diam1,3(mm) = ', qx(mgs,il),cx(mgs,il),1000.*xdia(mgs,il,1),1000.*xdia(mgs,il,3)
7380 ! call commasmpi_abort()
7381 ENDIF
7382! & (aax*(1.0/xdia(mgs,il,1) )**(- bx(il))* &
7383! & Gamma_sp(7.0 + alpha(mgs,il) + bx(il)))/Gamma_sp(7. + alpha(mgs,il))
7384 ENDIF
7385
7386 if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt3'
7387
7388 ELSE ! hail
7389 vtxbar(mgs,il,2) = &
7390 & rhovt(mgs)*(ax(il)*xdia(mgs,il,1)**bx(il)* &
7391 & x)/y
7392
7393 IF ( infdo .ge. 2 ) THEN ! Z-weighted
7394 vtxbar(mgs,il,3) = rhovt(mgs)* &
7395 & (aax*(1.0/xdia(mgs,il,1) )**(- bbx)* &
7396 & gamma_sp(7.0 + alpha(mgs,il) + bbx))/gamma_sp(7. + alpha(mgs,il))
7397! & (ax(il)*(1.0/xdia(mgs,il,1) )**(- bx(il))* &
7398! & Gamma_sp(7.0 + alpha(mgs,il) + bx(il)))/Gamma_sp(7. + alpha(mgs,il))
7399 ENDIF
7400
7401 if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt4'
7402
7403 ENDIF ! }
7404! & Gamma_sp(1.0 + dnu(il) + 0.6)/Gamma_sp(1. + dnu(il))
7405 ENDIF ! }
7406
7407! IF ( infdo .ge. 2 ) THEN ! Z-weighted
7408! vtxbar(mgs,il,3) = rhovt(mgs)* &
7409! & (ax(il)*(1.0/xdia(mgs,il,1) )**(- bx(il))* &
7410! & Gamma_sp(7.0 + alpha(mgs,il) + bx(il)))/Gamma_sp(7. + alpha(mgs,il))
7411! ENDIF
7412
7413! IF ( lhl .gt. 1 .and. il .eq. lhl ) THEN
7414! write(0,*) 'setvt: ',qx(mgs,il),xdia(mgs,il,1),xdia(mgs,il,3),dnu(il),ax(il),bx(il)
7415! ENDIF
7416 ELSEIF ( (il .eq. lh .and. hssflg == 0) .or. ( lhl .gt. 1 .and. il .eq. lhl .and. hlssflg == 0) ) THEN ! no size-sorting for graupel or hail
7417 vtxbar(mgs,il,2) = vtxbar(mgs,il,1)
7418 vtxbar(mgs,il,3) = vtxbar(mgs,il,1)
7419 ELSE ! not lh or lhl
7420 vtxbar(mgs,il,2) = &
7421 & sqrt( (xdn(mgs,il)*xdia(mgs,il,1)*pi*gr) / &
7422 & (3.0*cdx(il)*max(0.05,rho0(mgs))) )
7423 vtxbar(mgs,il,3) = vtxbar(mgs,il,1)
7424
7425 if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt5'
7426
7427
7428 ENDIF
7429 ELSE ! qx < qxmin
7430 vtxbar(mgs,il,2) = 0.0
7431
7432 if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt6'
7433
7434 ENDIF
7435 ENDDO ! mgs
7436
7437 if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt7'
7438
7439 ENDIF
7440 ENDDO ! il
7441
7442 if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt8'
7443
7444 ENDIF ! lg .gt. 1
7445
7446! ENDIF
7447! ENDDO
7448
7449 if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt9'
7450
7451! DO mgs = 1,ngscnt
7452! IF ( qx(mgs,lr) > qxmin(lr) ) THEN
7453! write(0,*) 'setvt2: mgs,lzr,infdo = ',mgs,lzr,infdo
7454! write(0,*) 'vt1,2,3 = ',vtxbar(mgs,lr,1),vtxbar(mgs,lr,2),vtxbar(mgs,lr,3)
7455! ENDIF
7456! ENDDO
7457
7458 ENDIF ! infdo .ge. 1
7459
7460 IF ( lh > 0 .and. graupelfallfac /= 1.0 ) THEN
7461 DO mgs = 1,ngscnt
7462 vtxbar(mgs,lh,1) = graupelfallfac*vtxbar(mgs,lh,1)
7463 vtxbar(mgs,lh,2) = graupelfallfac*vtxbar(mgs,lh,2)
7464 vtxbar(mgs,lh,3) = graupelfallfac*vtxbar(mgs,lh,3)
7465 axx(mgs,lh) = graupelfallfac*axx(mgs,lh)
7466 ENDDO
7467 ENDIF
7468
7469 IF ( lhl > 0 .and. hailfallfac /= 1.0 ) THEN
7470 DO mgs = 1,ngscnt
7471 vtxbar(mgs,lhl,1) = hailfallfac*vtxbar(mgs,lhl,1)
7472 vtxbar(mgs,lhl,2) = hailfallfac*vtxbar(mgs,lhl,2)
7473 vtxbar(mgs,lhl,3) = hailfallfac*vtxbar(mgs,lhl,3)
7474 axx(mgs,lhl) = hailfallfac*axx(mgs,lhl)
7475 ENDDO
7476 ENDIF
7477
7478 if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: END OF ROUTINE'
7479
7480!############ SETVTZ ############################
7481
7482 RETURN
7483 END SUBROUTINE setvtz
7484!--------------------------------------------------------------------------
7485
7486!
7487! ##############################################################################
7488
7489!
7490! subroutine to calculate fall speeds of hydrometeors
7491!
7492
7495 subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, &
7496 & xvt, rhovtzx, &
7497 & an,dn,ipconc0,t0,t7,cwmasn,cwmasx, &
7498 & cwradn, &
7499 & qxmin,xdnmx,xdnmn,cdx,cno,xdn0,xvmn,xvmx, &
7500 & ngs,qx,qxw,cx,xv,vtxbar,xmas,xdn,xdia,vx,alpha,zx,igs,kgs, &
7501 & rho0,temcg,temg,rhovt,cwnc,cinc,fadvisc,cwdia,cipmas,cnina,cimas, &
7502 & cnostmp, &
7503 & infdo,ildo,timesetvt)
7504
7505! 12.16.2005: .F version use in transitional SWM model
7506!
7507! 10.10.2003: Added cimn and cimx to setting for cci and cip.
7508!
7509! TO DO LIST:
7510!
7511! need to set up values for:
7512! : cipdia,cidia,cwdia,cwmas,vtwbar,
7513! : rho0,temcg,cip,cci
7514!
7515! and need to put fallspeed values in cwvt etc.
7516!
7517
7518 implicit none
7519 integer ng1
7520 parameter(ng1 = 1)
7521
7522 integer, intent(in) :: ixcol ! which column to return
7523 integer, intent(in) :: ildo
7524
7525 integer nx,ny,nz,nor,norz,ngt,jgs,na
7526 real an(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,na)
7527 real dn(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor)
7528 real t0(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor)
7529 real t7(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor)
7530 real dtp,dtz1
7531
7532 real :: rhovtzx(nz,nx)
7533
7534 integer ndebugzf
7535 parameter(ndebugzf = 0)
7536
7537 integer ix,jy,kz,i,j,k,il
7538 integer infdo
7539!
7540!
7541 real xvt(nz+1,nx,3,lc:lhab) ! 1=mass-weighted, 2=number-weighted
7542
7543 real qxmin(lc:lhab)
7544 real xdn0(lc:lhab)
7545 real xvmn(lc:lhab), xvmx(lc:lhab)
7546 double precision,optional :: timesetvt
7547
7548 integer :: ngs
7549 integer :: ngscnt,mgs,ipconc0
7550! parameter ( ngs=200 )
7551
7552 real :: qx(ngs,lv:lhab)
7553 real :: qxw(ngs,ls:lhab)
7554 real :: cx(ngs,lc:lhab)
7555 real :: xv(ngs,lc:lhab)
7556 real :: vtxbar(ngs,lc:lhab,3)
7557 real :: xmas(ngs,lc:lhab)
7558 real :: xdn(ngs,lc:lhab)
7559 real :: cdxgs(ngs,lc:lhab)
7560 real :: xdia(ngs,lc:lhab,3)
7561 real :: vx(ngs,li:lhab)
7562 real :: alpha(ngs,lc:lhab)
7563 real :: zx(ngs,lr:lhab)
7564
7565 real xdnmx(lc:lhab), xdnmn(lc:lhab)
7566 real :: axx(ngs,lh:lhab), bxx(ngs,lh:lhab)
7567! real axh(ngs),bxh(ngs),axhl(ngs),bxhl(ngs)
7568
7569!
7570! drag coefficients
7571!
7572 real cdx(lc:lhab)
7573!
7574! Fixed intercept values for single moment scheme
7575!
7576 real cno(lc:lhab)
7577
7578 real cwccn0,cwmasn,cwmasx,cwradn
7579! real cwc0
7580
7581 integer nxmpb,nzmpb,nxz,numgs,inumgs
7582 integer kstag
7583 parameter(kstag=1)
7584
7585 integer igs(ngs),kgs(ngs)
7586
7587 real rho0(ngs),temcg(ngs)
7588
7589 real temg(ngs)
7590
7591 real rhovt(ngs)
7592
7593 real cwnc(ngs),cinc(ngs)
7594 real fadvisc(ngs),cwdia(ngs),cipmas(ngs)
7595
7596! real cimasn,cimasx,
7597 real :: cnina(ngs),cimas(ngs)
7598
7599 real :: cnostmp(ngs)
7600
7601! real pii
7602!
7603!
7604! general constants for microphysics
7605!
7606
7607!
7608! Miscellaneous
7609!
7610
7611 logical flag
7612 logical ldoliq
7613
7614
7615 real chw, qr, z, rd, alp, z1, g1, vr, nrx, tmp
7616
7617 real vtmax
7618 real xvbarmax
7619
7620 real, parameter :: c1r=19.0, c2r=0.6, c3r=1.8, c4r=17.0 ! rain
7621 real, parameter :: c1h=5.5, c2h=0.7, c3h=4.5, c4h=8.5 ! Graupel
7622 real, parameter :: c1hl=3.7, c2hl=0.3, c3hl=9.0, c4hl=6.5, c5hl=1.0, c6hl=6.5 ! Hail
7623
7624 integer l1, l2
7625
7626 double precision :: dpt1, dpt2
7627
7628
7629!-----------------------------------------------------------------------------
7630! MPI LOCAL VARIABLES
7631
7632 integer :: ixb, jyb, kzb
7633 integer :: ixe, jye, kze
7634
7635 logical :: debug_mpi = .false.
7636
7637
7638 if (ndebugzf .gt. 0 ) write(0,*) "ZIEGFALL: ENTERED SUBROUTINE"
7639
7640! #####################################################################
7641! BEGIN EXECUTABLE
7642! #####################################################################
7643!
7644
7645! constants
7646!
7647
7648 ldoliq = .false.
7649 IF ( ls .gt. 1 ) THEN
7650 DO il = ls,lhab
7651 ldoliq = ldoliq .or. ( lliq(il) .gt. 1 )
7652 ENDDO
7653 ENDIF
7654
7655! poo = 1.0e+05
7656! cp608 = 0.608
7657! cp = 1004.0
7658! cv = 717.0
7659! dnz00 = 1.225
7660! rho00 = 1.225
7661! cs = 4.83607122
7662! ds = 0.25
7663! new values for cs and ds
7664! cs = 12.42
7665! ds = 0.42
7666! pi = 4.0*atan(1.0)
7667! pii = piinv ! 1./pi
7668! pid4 = pi/4.0
7669! qccrit = 2.0e-03
7670! qscrit = 6.0e-04
7671! cwc0 = pii
7672
7673!
7674!
7675! general constants for microphysics
7676!
7677
7678!
7679! ci constants in mks units
7680!
7681! cimasn = 6.88e-13
7682! cimasx = 1.0e-8
7683!
7684! Set terminal velocities...
7685! also set drag coefficients
7686!
7687 jy = jgs
7688 nxmpb = ixcol
7689 nzmpb = 1
7690 nxz = 1*nz
7691! ngs = nz
7692 numgs = 1
7693
7694 IF ( ildo == 0 ) THEN
7695 l1 = lc
7696 l2 = lhab
7697 ELSE
7698 l1 = ildo
7699 l2 = ildo
7700 ENDIF
7701
7702
7703 do inumgs = 1,numgs
7704 ngscnt = 0
7705
7706
7707 do kz = nzmpb,nz
7708 do ix = ixcol,ixcol
7709 flag = .false.
7710
7711
7712 DO il = l1,l2
7713 flag = flag .or. ( an(ix,jy,kz,il) .gt. qxmin(il) )
7714 ENDDO
7715
7716 if ( flag ) then
7717! load temp quantities
7718
7719 ngscnt = ngscnt + 1
7720 igs(ngscnt) = ix
7721 kgs(ngscnt) = kz
7722 if ( ngscnt .eq. ngs ) goto 1100
7723 end if
7724 end do !!ix
7725 nxmpb = 1
7726 end do !! kz
7727
7728! if ( jy .eq. (ny-jstag) ) iend = 1
7729
7730 1100 continue
7731
7732 if ( ngscnt .eq. 0 ) go to 9998
7733!
7734! set temporaries for microphysics variables
7735!
7736
7737
7738!
7739! Reconstruct various quantities
7740!
7741 do mgs = 1,ngscnt
7742
7743 rho0(mgs) = dn(igs(mgs),jy,kgs(mgs))
7744 rhovt(mgs) = rhovtzx(kgs(mgs),ixcol) ! Sqrt(rho00/rho0(mgs))
7745 temg(mgs) = t0(igs(mgs),jy,kgs(mgs))
7746 temcg(mgs) = temg(mgs) - tfr
7747
7748
7749!
7750 end do
7751!
7752! only need fadvisc for
7753 IF ( lc .gt. 1 .and. (ildo == 0 .or. ildo == lc ) ) then
7754 do mgs = 1,ngscnt
7755 fadvisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))* &
7756 & (temg(mgs)/296.0)**(1.5)
7757 end do
7758 ENDIF
7759
7760 IF ( ipconc .eq. 0 ) THEN
7761 do mgs = 1,ngscnt
7762 cnina(mgs) = t7(igs(mgs),jgs,kgs(mgs))
7763 end do
7764 ENDIF
7765
7766
7767 IF ( ildo > 0 ) THEN
7768 vtxbar(:,ildo,:) = 0.0
7769 ELSE
7770 vtxbar(:,:,:) = 0.0
7771 ENDIF
7772
7773! do mgs = 1,ngscnt
7774! qx(mgs,lv) = max(an(igs(mgs),jy,kgs(mgs),lv), 0.0)
7775! ENDDO
7776 DO il = l1,l2
7777 do mgs = 1,ngscnt
7778 qx(mgs,il) = max(an(igs(mgs),jy,kgs(mgs),il), 0.0)
7779 ENDDO
7780 end do
7781
7782 cnostmp(:) = cno(ls)
7783 IF ( ipconc < 1 .and. lwsm6 .and. (ildo == 0 .or. ildo == ls )) THEN
7784 DO mgs = 1,ngscnt
7785 tmp = min( 0.0, temcg(mgs) )
7786 cnostmp(mgs) = min( 2.e8, 2.e6*exp(0.12*tmp) )
7787 ENDDO
7788 ENDIF
7789
7790
7791!
7792! set concentrations
7793!
7794 cx(:,:) = 0.0
7795
7796 if ( ipconc .ge. 1 .and. li .gt. 1 .and. (ildo == 0 .or. ildo == li ) ) then
7797 do mgs = 1,ngscnt
7798 cx(mgs,li) = max(an(igs(mgs),jy,kgs(mgs),lni), 0.0)
7799 end do
7800 end if
7801 if ( ipconc .ge. 2 .and. lc .gt. 1 .and. (ildo == 0 .or. ildo == lc ) ) then
7802 do mgs = 1,ngscnt
7803 cx(mgs,lc) = max(an(igs(mgs),jy,kgs(mgs),lnc), 0.0)
7804! cx(mgs,lc) = Min( ccwmx, cx(mgs,lc) )
7805 end do
7806 end if
7807 if ( ipconc .ge. 3 .and. lr .gt. 1 .and. (ildo == 0 .or. ildo == lr ) ) then
7808 do mgs = 1,ngscnt
7809 cx(mgs,lr) = max(an(igs(mgs),jy,kgs(mgs),lnr), 0.0)
7810! IF ( qx(mgs,lr) .le. qxmin(lr) ) THEN
7811! ELSE
7812! cx(mgs,lr) = Max( 0.0, cx(mgs,lr) )
7813! ENDIF
7814 end do
7815 end if
7816 if ( ipconc .ge. 4 .and. ls .gt. 1 .and. (ildo == 0 .or. ildo == ls ) ) then
7817 do mgs = 1,ngscnt
7818 cx(mgs,ls) = max(an(igs(mgs),jy,kgs(mgs),lns), 0.0)
7819! IF ( qx(mgs,ls) .le. qxmin(ls) ) THEN
7820! ELSE
7821! cx(mgs,ls) = Max( 0.0, cx(mgs,ls) )
7822! ENDIF
7823 end do
7824 end if
7825
7826 if ( ipconc .ge. 5 .and. lh .gt. 1 .and. (ildo == 0 .or. ildo == lh ) ) then
7827 do mgs = 1,ngscnt
7828
7829 cx(mgs,lh) = max(an(igs(mgs),jy,kgs(mgs),lnh), 0.0)
7830! IF ( qx(mgs,lh) .le. qxmin(lh) ) THEN
7831! ELSE
7832! cx(mgs,lh) = Max( 0.0, cx(mgs,lh) )
7833! ENDIF
7834
7835 end do
7836 ENDIF
7837
7838 if ( ipconc .ge. 5 .and. lhl .gt. 1 .and. (ildo == 0 .or. ildo == lhl ) ) then
7839 do mgs = 1,ngscnt
7840
7841 cx(mgs,lhl) = max(an(igs(mgs),jy,kgs(mgs),lnhl), 0.0)
7842! IF ( qx(mgs,lhl) .le. qxmin(lhl) ) THEN
7843! cx(mgs,lhl) = 0.0
7844! ELSEIF ( cx(mgs,lhl) .eq. 0.0 .and. qx(mgs,lhl) .lt. 3.0*qxmin(lhl) ) THEN
7845! qx(mgs,lhl) = 0.0
7846! ELSE
7847! cx(mgs,lhl) = Max( 0.0, cx(mgs,lhl) )
7848! ENDIF
7849
7850 end do
7851 end if
7852
7853 do mgs = 1,ngscnt
7854 xdn(mgs,lc) = xdn0(lc)
7855 xdn(mgs,lr) = xdn0(lr)
7856! IF ( ls .gt. 1 .and. lvs .eq. 0 ) xdn(mgs,ls) = xdn0(ls)
7857! IF ( lh .gt. 1 .and. lvh .eq. 0 ) xdn(mgs,lh) = xdn0(lh)
7858 IF ( li .gt. 1 ) xdn(mgs,li) = xdn0(li)
7859 IF ( ls .gt. 1 ) xdn(mgs,ls) = xdn0(ls)
7860 IF ( lh .gt. 1 ) xdn(mgs,lh) = xdn0(lh)
7861 IF ( lhl .gt. 1 ) xdn(mgs,lhl) = xdn0(lhl)
7862 end do
7863
7864!
7865! Set mean particle volume
7866!
7867 IF ( ldovol .and. (ildo == 0 .or. ildo >= li ) ) THEN
7868
7869 vx(:,:) = 0.0
7870
7871 DO il = l1,l2
7872
7873 IF ( lvol(il) .ge. 1 ) THEN
7874
7875 DO mgs = 1,ngscnt
7876 vx(mgs,il) = max(an(igs(mgs),jy,kgs(mgs),lvol(il)), 0.0)
7877 IF ( vx(mgs,il) .gt. rho0(mgs)*qxmin(il)*1.e-3 .and. qx(mgs,il) .gt. qxmin(il) ) THEN
7878 xdn(mgs,il) = min( xdnmx(il), max( xdnmn(il), rho0(mgs)*qx(mgs,il)/vx(mgs,il) ) )
7879 ENDIF
7880 ENDDO
7881
7882 ENDIF
7883
7884 ENDDO
7885
7886 ENDIF
7887
7888 DO il = lg,lhab
7889 DO mgs = 1,ngscnt
7890 alpha(mgs,il) = dnu(il)
7891 ENDDO
7892 ENDDO
7893
7894 IF ( imurain == 1 ) THEN
7895 alpha(:,lr) = alphar
7896 ELSEIF ( imurain == 3 ) THEN
7897 alpha(:,lr) = xnu(lr)
7898 ENDIF
7899
7900
7901 IF ( ipconc == 5 .and. imydiagalpha > 0 ) THEN
7902 DO mgs = 1,ngscnt
7903 IF ( qx(mgs,lr) .gt. qxmin(lr) .and. cx(mgs,lr) > cxmin ) THEN
7904 xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) !
7905 xdia(mgs,lr,3) = (xv(mgs,lr)*6.0*cwc1)**(1./3.)
7906 alpha(mgs,lr) = min(alphamax, c1r*tanh(c2r*(xdia(mgs,lr,3)*1000. - c3r)) + c4r)
7907 ENDIF
7908 IF ( qx(mgs,lh) .gt. qxmin(lh) .and. cx(mgs,lh) > cxmin ) THEN
7909 xv(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) !
7910 xdia(mgs,lh,3) = (xv(mgs,lh)*6.*piinv)**(1./3.) ! mwfac*xdia(mgs,lh,1) ! (xv(mgs,lh)*cwc0*6.0)**(1./3.)
7911 alpha(mgs,lh) = min(alphamax, c1h*tanh(c2h*(xdia(mgs,lh,3)*1000. - c3h)) + c4h)
7912 ENDIF
7913! alpha(:,lr) = 0. ! 10.
7914! alpha(:,lh) = 0. ! 10.
7915 IF ( lhl > 0 ) THEN
7916 IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. cx(mgs,lhl) > cxmin ) THEN
7917 xv(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*cx(mgs,lhl)) !
7918 xdia(mgs,lhl,3) = (xv(mgs,lhl)*6.*piinv)**(1./3.)
7919 IF ( xdia(mgs,lhl,3) < 0.008 ) THEN
7920 alpha(mgs,lhl) = min(alphamax, c1hl*tanh(c2hl*(xdia(mgs,lhl,3)*1000. - c3hl)) + c4hl)
7921 ELSE
7922 alpha(mgs,lhl) = min(alphamax, c5hl*xdia(mgs,lhl,3)*1000. + c6hl)
7923 ENDIF
7924 ENDIF
7925 ENDIF
7926 ENDDO
7927 ENDIF
7928
7929
7930!
7931! Set 6th moments
7932!
7933 IF ( ipconc .ge. 6 .or. lzr > 1) THEN
7934
7935 zx(:,:) = 0.0
7936
7937! DO il = lr,lhab
7938 DO il = l1,l2
7939
7940 IF ( lz(il) .ge. 1 ) THEN
7941
7942 DO mgs = 1,ngscnt
7943 zx(mgs,il) = max(an(igs(mgs),jy,kgs(mgs),lz(il)), 0.0)
7944 ENDDO
7945
7946
7947 ENDIF
7948
7949 ENDDO
7950
7951 ENDIF
7952
7953
7954
7955
7956
7957! Find shape parameter rain
7958
7959
7960 IF ( lz(lr) > 1 .and. (ildo == 0 .or. ildo == lr ) .and. imurain == 3 ) THEN ! { RAIN SHAPE PARAM
7961 il = lr
7962 DO mgs = 1,ngscnt
7963
7964 IF ( iresetmoments == 1 .or. iresetmoments == il ) THEN
7965! IF ( .false. .and. zx(mgs,lr) <= zxmin ) THEN
7966 IF ( zx(mgs,lr) <= zxmin ) THEN
7967 qx(mgs,lr) = 0.0
7968 cx(mgs,lr) = 0.0
7969 an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),lr)
7970 an(igs(mgs),jgs,kgs(mgs),lr) = qx(mgs,lr)
7971 an(igs(mgs),jgs,kgs(mgs),ln(lr)) = cx(mgs,lr)
7972! ELSEIF ( zx(mgs,lr) <= 0.0 .and. cx(mgs,lr) > 0.0 .and. qx(mgs,il) .gt. qxmin(il)) THEN
7973! write(91,*) 'ZF: overdepletion of Zr: z,c,q = ',zx(mgs,il),cx(mgs,il),qx(mgs,il)
7974 ELSEIF ( cx(mgs,lr) <= cxmin ) THEN
7975 zx(mgs,lr) = 0.0
7976 qx(mgs,lr) = 0.0
7977 an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),lr)
7978 an(igs(mgs),jgs,kgs(mgs),lr) = qx(mgs,lr)
7979 an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr)
7980 ENDIF
7981 ENDIF
7982
7983
7984
7985 IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN
7986
7987 xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*max(1.0e-11,cx(mgs,lr)))
7988 IF ( xv(mgs,lr) .gt. xvmx(lr) ) THEN
7989! tmp = cx(mgs,lr)
7990! xv(mgs,lr) = xvmx(lr)
7991! cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmx(lr)*xdn(mgs,lr))
7992! an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
7993! IF ( tmp < cx(mgs,il) ) THEN ! breakup
7994! g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
7995!! zx(mgs,lr) = zx(mgs,lr) + g1*(rho0(mgs)/(1000.))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) )
7996!! an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr)
7997! ENDIF
7998 ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN
7999 xv(mgs,lr) = xvmn(lr)
8000 cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr))
8001 an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
8002 ENDIF
8003
8004 IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN
8005! have mass and reflectivity but no concentration, so set concentration, using default alpha
8006 g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
8007 z = zx(mgs,il)
8008 qr = qx(mgs,il)
8009
8010 cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*1000.*1000)
8011 an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
8012
8013 ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > cxmin ) THEN
8014! have mass and concentration but no reflectivity, so set reflectivity, using default alpha
8015 g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
8016 chw = cx(mgs,il)
8017 qr = qx(mgs,il)
8018
8019! xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(1000.*Max(1.0e-9,cx(mgs,lr)))
8020! vr = xv(mgs,lr)
8021
8022! z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2)
8023! zx(mgs,il) = z
8024! an(igs(mgs),jy,kgs(mgs),lz(il)) = z
8025
8026 zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(xdn(mgs,lr)**2*chw)
8027 an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
8028
8029 ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN
8030! How did this happen?
8031 ! set values according to dBZ of -10, or Z = 0.1
8032! write(91,*) 'alpha = ',alpha(mgs,il)
8033 IF ( qx(mgs,il) < 1.e-8 ) THEN
8034 qx(mgs,il) = 0.0
8035 an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
8036 an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
8037 ELSE
8038! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2
8039 zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2
8040 an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
8041
8042 g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
8043 z = zx(mgs,il)
8044 qr = qx(mgs,il)
8045 cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*1000.*1000)
8046 an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
8047 ENDIF
8048 ENDIF
8049
8050 IF ( zx(mgs,lr) > 0.0 ) THEN
8051 xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(1000.*max(1.0e-9,cx(mgs,lr)))
8052 vr = xv(mgs,lr)
8053! z = 36.*(alpha(kz)+2.0)*a(ix,jy,kz,lnr)*vr**2/((alpha(kz)+1.0)*pi**2)
8054 qr = qx(mgs,lr)
8055 nrx = cx(mgs,lr)
8056 z = zx(mgs,lr)
8057
8058! xv = (db(1,kz)*a(1,1,kz,lr))**2/(a(1,1,kz,lnr))
8059! rd = z*(pi/6.*1000.)**2/xv
8060
8061! determine shape parameter alpha by iteration
8062 IF ( z .gt. 0.0 ) THEN
8063! alpha(mgs,lr) = 3.
8064 alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
8065 DO i = 1,20
8066! IF ( 100.*Abs(alp - alpha(mgs,lr))/Abs(alpha(mgs,lr)) .lt. 1. ) EXIT
8067 IF ( abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT
8068 alpha(mgs,lr) = max( rnumin, min( rnumax, alp ) )
8069 alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
8070! write(0,*) 'i,alp = ',i,alp
8071 alp = max( rnumin, min( rnumax, alp ) )
8072 ENDDO
8073! write(0,*) 'kz, alp, alpha(kz) = ',kz,alp,alpha(mgs,lr),qr*1000,z*1.e18,vr,nrx
8074
8075
8076! check for artificial breakup (rain larger than allowed max size)
8077 IF ( xv(mgs,il) .gt. xvmx(il) ) THEN
8078 tmp = cx(mgs,il)
8079 xv(mgs,il) = min( xvmx(il), max( xvmn(il),xv(mgs,il) ) )
8080 xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
8081 cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
8082 IF ( tmp < cx(mgs,il) ) THEN ! breakup
8083
8084 g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
8085 zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) )
8086 an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
8087
8088 vr = xv(mgs,lr)
8089 qr = qx(mgs,lr)
8090 nrx = cx(mgs,lr)
8091 z = zx(mgs,lr)
8092
8093
8094! determine shape parameter alpha by iteration
8095 alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
8096 DO i = 1,20
8097 IF ( abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT
8098 alpha(mgs,lr) = max( rnumin, min( rnumax, alp ) )
8099 alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
8100 alp = max( rnumin, min( rnumax, alp ) )
8101 ENDDO
8102
8103
8104 ENDIF
8105 ENDIF
8106
8107!
8108! Check whether the shape parameter is at or less than the minimum, and if it is, reset the
8109! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N)
8110!
8111! IF ( alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax ) THEN
8112 IF ( .true. .and. (alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax) ) THEN
8113
8114 IF ( rescale_high_alpha .and. alp >= rnumax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z
8115 g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
8116 cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(1./(xdn(mgs,il)))**2
8117 an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il)
8118
8119 ELSEIF ( rescale_low_alphar .and. alp <= rnumin ) THEN
8120
8121 z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2)
8122 zx(mgs,il) = z
8123 an(igs(mgs),jy,kgs(mgs),lz(il)) = z
8124
8125 ENDIF
8126 ENDIF
8127
8128 ENDIF
8129 ENDIF
8130
8131 ELSE
8132
8133 zx(mgs,lr) = 0.0
8134 cx(mgs,lr) = 0.0
8135 an(igs(mgs),jgs,kgs(mgs),ln(lr)) = cx(mgs,lr)
8136 an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr)
8137
8138 ENDIF
8139
8140 ENDDO
8141 ENDIF ! }
8142
8143
8144 IF ( ipconc .ge. 6 ) THEN
8145
8146! Find shape parameters for graupel,hail
8147
8148 DO il = lr,lhab
8149
8150 IF ( lz(il) .gt. 1 .and. (ildo == 0 .or. ildo == il ) .and. ( .not. ( il == lr .and. imurain == 3 )) ) THEN
8151
8152 DO mgs = 1,ngscnt
8153
8154 IF ( iresetmoments == 1 .or. iresetmoments == il .or. iresetmoments == -1 ) THEN
8155 IF ( zx(mgs,il) <= zxmin ) THEN ! .and. qx(mgs,il) > 0.05e-3 ) THEN
8156 qx(mgs,il) = 0.0
8157 cx(mgs,il) = 0.0
8158 an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
8159 an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
8160 an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
8161 ELSEIF ( iresetmoments == -1 .and. qx(mgs,il) < qxmin(il) ) THEN
8162 zx(mgs,il) = 0.0
8163 cx(mgs,il) = 0.0
8164 an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
8165
8166 qx(mgs,il) = 0.0
8167 an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
8168 an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
8169 an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
8170
8171 ELSEIF ( cx(mgs,il) <= cxmin .and. iresetmoments /= -1 ) THEN ! .and. qx(mgs,il) > 0.05e-3 ) THEN
8172!! write(91,*) 'cx=0; qx,zx = ',1000.*qx(mgs,il),1.e18*zx(mgs,il)
8173 zx(mgs,il) = 0.0
8174 qx(mgs,il) = 0.0
8175 an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
8176 an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
8177 an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
8178 ENDIF
8179 ENDIF
8180
8181 IF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= cxmin ) THEN
8182 zx(mgs,il) = 0.0
8183 cx(mgs,il) = 0.0
8184 an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
8185 qx(mgs,il) = 0.0
8186 an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
8187 an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
8188 an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
8189 ENDIF
8190
8191 IF ( qx(mgs,il) .gt. qxmin(il) ) THEN
8192
8193 xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*max(1.0e-9,cx(mgs,il)))
8194 xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
8195
8196 IF ( xv(mgs,il) .lt. xvmn(il) ) THEN
8197! tmp = cx(mgs,il)
8198 xv(mgs,il) = min( xvmx(il), max( xvmn(il),xv(mgs,il) ) )
8199 xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
8200 cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
8201! IF ( tmp < cx(mgs,il) ) THEN ! breakup
8202! g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
8203! & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2)
8204! zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) )
8205! an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
8206!
8207! ENDIF
8208 ENDIF
8209
8210 IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN
8211! have mass and reflectivity but no concentration, so set concentration, using default alpha
8212 g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
8213 & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
8214 z = zx(mgs,il)
8215 qr = qx(mgs,il)
8216 cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(z*(pi*xdn(mgs,il))**2)
8217 an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
8218
8219 ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > cxmin ) THEN
8220! have mass and concentration but no reflectivity, so set reflectivity, using default alpha
8221 g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
8222 & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
8223 chw = cx(mgs,il)
8224 qr = qx(mgs,il)
8225! zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw
8226 zx(mgs,il) = min(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(chw*(pi*xdn(mgs,il))**2) )
8227 an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
8228 ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN
8229! How did this happen?
8230! write(91,*) 'ziegfall: something screwy with moments: il = ',il
8231! write(91,*) 'q,n,z = ', 1.e3*qx(mgs,il),cx(mgs,il),zx(mgs,il)
8232! write(91,*) 'alpha = ',alpha(mgs,il)
8233
8234 IF ( qx(mgs,il) < 1.e-8 ) THEN
8235 qx(mgs,il) = 0.0
8236 an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
8237 an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
8238 ELSE
8239! write(0,*) 'alpha = ',alpha(mgs,il)
8240 ! set values according to dBZ of -10
8241! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2
8242 zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2
8243 an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
8244
8245 g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
8246 & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
8247 z = zx(mgs,il)
8248 qr = qx(mgs,il)
8249 cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(z*(pi*xdn(mgs,il))**2)
8250 an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
8251 ENDIF
8252 ENDIF
8253 ENDIF
8254
8255 IF ( qx(mgs,il) .gt. qxmin(il) .and. cx(mgs,il) .gt. cxmin ) THEN
8256 chw = cx(mgs,il)
8257 qr = qx(mgs,il)
8258 z = zx(mgs,il)
8259
8260 IF ( zx(mgs,il) .gt. 0. ) THEN
8261
8262! rd = z*(pi/6.*1000.)**2*chw/(0.224*(dn(igs(mgs),jy,kgs(mgs))*qr)**2)
8263 rd = z*(pi/6.*xdn(mgs,il))**2*chw/((dn(igs(mgs),jy,kgs(mgs))*qr)**2)
8264
8265 alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
8266 & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd) - 1.0
8267 DO i = 1,10
8268 IF ( abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT
8269 alpha(mgs,il) = max( alphamin, min( alphamax, alp ) )
8270 alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
8271 & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd) - 1.0
8272! write(0,*) 'i,alp = ',i,alp
8273 alp = max( alphamin, min( alphamax, alp ) )
8274 ENDDO
8275
8276
8277
8278! check for artificial breakup (graupel/hail larger than allowed max size)
8279
8280 IF ( imaxdiaopt == 1 ) THEN
8281 xvbarmax = xvmx(il)
8282 ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter
8283 xvbarmax = xvmx(il) /((3. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il))))
8284 ELSEIF ( imaxdiaopt == 3 ) THEN ! test against mass-weighted diameter
8285 xvbarmax = xvmx(il) /((4. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il))))
8286 ENDIF
8287
8288 IF ( xv(mgs,il) .gt. xvbarmax ) THEN
8289 tmp = cx(mgs,il)
8290 xv(mgs,il) = min( xvbarmax, max( xvmn(il),xv(mgs,il) ) )
8291 xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
8292 cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
8293 IF ( tmp < cx(mgs,il) ) THEN ! breakup
8294 g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
8295 & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2)
8296 zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) )
8297 an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
8298
8299 chw = cx(mgs,il)
8300 qr = qx(mgs,il)
8301 z = zx(mgs,il)
8302
8303 rd = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2)
8304 alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
8305 & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd) - 1.0
8306 DO i = 1,10
8307 IF ( abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT
8308 alpha(mgs,il) = max( alphamin, min( alphamax, alp ) )
8309 alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
8310 & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd) - 1.0
8311 alp = max( alphamin, min( alphamax, alp ) )
8312 ENDDO
8313
8314
8315 ENDIF
8316 ENDIF
8317
8318!
8319! Check whether the shape parameter is at or less than the minimum, and if it is, reset the
8320! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N)
8321!
8322 IF ( (rescale_low_alpha .or. rescale_high_alpha ) .and. &
8323 & ( alpha(mgs,il) <= alphamin .or. alp == alphamin .or. alp == alphamax ) ) THEN
8324
8325 g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
8326 & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
8327
8328 IF ( rescale_high_alpha .and. alp >= alphamax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z
8329 cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2
8330 an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il)
8331
8332 ELSEIF ( rescale_low_alpha .and. alp <= alphamin .and. .not. (il == lh .and. icvhl2h > 0 ) ) THEN
8333
8334!! z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*( 0.224*qr)*qr/chw
8335 z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw
8336 z = z1*(6./(pi*xdn(mgs,il)))**2
8337 zx(mgs,il) = z
8338 an(igs(mgs),jy,kgs(mgs),lz(il)) = z
8339 ENDIF
8340 ENDIF
8341 ELSE
8342 ENDIF
8343 ENDIF
8344 ENDDO ! mgs
8345
8346 ENDIF ! lz(il) .gt. 1
8347
8348 ENDDO ! il
8349
8350! CALL cld_cpu('Z-MOMENT-ZFAll')
8351
8352 ENDIF
8353
8354 IF ( lzhl > 1 ) THEN
8355 IF ( lhl .gt. 1 ) THEN
8356
8357 ENDIF
8358 ENDIF
8359
8360
8361
8362!
8363! Set density
8364!
8365 if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: call setvtz'
8366!
8367
8368 call setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
8369 & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx,cdxgs, &
8370 & ipconc,ndebugzf,ngs,nz,kgs,fadvisc, &
8371 & cwmasn,cwmasx,cwradn,cnina,cimn,cimx, &
8372 & itype1,itype2,temcg,infdo,alpha,ildo,axx,bxx)
8373! & itype1,itype2,temcg,infdo,alpha,ildo,axh,bxh,axhl,bxhl)
8374
8375
8376
8377!
8378! put fall speeds into the x-z arrays
8379!
8380 DO il = l1,l2
8381 do mgs = 1,ngscnt
8382
8383 vtmax = 150.0
8384
8385
8386 IF ( vtxbar(mgs,il,2) .gt. vtxbar(mgs,il,1) .or. &
8387 & ( vtxbar(mgs,il,1) .gt. vtxbar(mgs,il,3) .and. vtxbar(mgs,il,3) > 0.0) ) THEN
8388
8389
8390! IF ( qx(mgs,il) > 1.e-4 .and. &
8391! & .not. ( il == lr .and. 1.e3*xdia(mgs,il,3) > 5.0 ) ) THEN
8392! write(0,*) 'infdo,mgs = ',infdo,lzr,mgs
8393! write(0,*) 'Moment problem with vtxbar for il at i,j,k = ',il,igs(mgs),jy,kgs(mgs)
8394! write(0,*) 'nx,ny,nz,ng = ',nx,ny,nz,nor
8395! write(0,*) 'cwmasn,cwmasx = ',cwmasn,cwmasx
8396! write(0,*) 'vt1,2,3 = ',vtxbar(mgs,il,1),vtxbar(mgs,il,2),vtxbar(mgs,il,3)
8397! write(0,*) 'q,n,d = ', 1.e3*qx(mgs,il),cx(mgs,il),1.e3*xdia(mgs,il,3)
8398! IF ( il .ge. lr .and. lz(il) > 1 ) write(0,*) 'z = ', zx(mgs,il)
8399! IF ( il .ge. lg .or. il == lr ) THEN
8400! write(0,*) 'alpha = ',alpha(mgs,il)
8401! ENDIF
8402! ENDIF
8403
8404 vtxbar(mgs,il,1) = max( vtxbar(mgs,il,1), vtxbar(mgs,il,2) )
8405 vtxbar(mgs,il,3) = max( vtxbar(mgs,il,3), vtxbar(mgs,il,1) )
8406
8407 ENDIF
8408
8409
8410 IF ( vtxbar(mgs,il,1) .gt. vtmax .or. vtxbar(mgs,il,2) .gt. vtmax .or. &
8411 & vtxbar(mgs,il,3) .gt. vtmax ) THEN
8412
8413! IF ( ndebugzf >= 0 .and. 1.e3*qx(mgs,il) > 0.1 ) THEN
8414! write(0,*) 'infdo = ',infdo
8415! write(0,*) 'Problem with vtxbar for il at i,j,k = ',il,igs(mgs),jy,kgs(mgs)
8416! write(0,*) 'nx,ny,nz,ng = ',nx,ny,nz,nor
8417! write(0,*) 'cwmasn,cwmasx = ',cwmasn,cwmasx
8418! write(0,*) 'vt1,2,3 = ',vtxbar(mgs,il,1),vtxbar(mgs,il,2),vtxbar(mgs,il,3)
8419! write(0,*) 'q,n,d = ', 1.e3*qx(mgs,il),cx(mgs,il),1.e3*xdia(mgs,il,3)
8420! IF ( il .ge. lr .and. lz(il) > 1 ) write(0,*) 'z = ', zx(mgs,il)
8421! IF ( il .ge. lg ) THEN
8422! write(0,*) 'alpha = ',alpha(mgs,il)
8423! ENDIF
8424! ENDIF
8425 vtxbar(mgs,il,1) = min(vtmax,vtxbar(mgs,il,1) )
8426 vtxbar(mgs,il,2) = min(vtmax,vtxbar(mgs,il,2) )
8427 vtxbar(mgs,il,3) = min(vtmax,vtxbar(mgs,il,3) )
8428
8429! call commasmpi_abort()
8430 ENDIF
8431
8432
8433 xvt(kgs(mgs),igs(mgs),1,il) = vtxbar(mgs,il,1)
8434 xvt(kgs(mgs),igs(mgs),2,il) = vtxbar(mgs,il,2)
8435 IF ( infdo .ge. 2 ) THEN
8436 xvt(kgs(mgs),igs(mgs),3,il) = vtxbar(mgs,il,3)
8437 ELSE
8438 xvt(kgs(mgs),igs(mgs),3,il) = 0.0
8439 ENDIF
8440
8441! xvt(kgs(mgs),igs(mgs),2,il) = xvt(kgs(mgs),igs(mgs),1,il)
8442
8443 enddo
8444 ENDDO
8445
8446
8447 if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: COPIED FALL SPEEDS'
8448
8449
8450
8451 9998 continue
8452
8453 if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: DONE WITH LOOP'
8454
8455 if ( kz .gt. nz-1 ) then
8456 go to 1200
8457 else
8458 nzmpb = kz
8459 end if
8460
8461 if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: SET NZMPB'
8462
8463 end do !! inumgs
8464
8465 if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: SET NXMPB'
8466
8467 1200 continue
8468
8469
8470! ENDDO ! ix
8471! ENDDO ! kz
8472
8473
8474 if (ndebugzf .gt. 0 ) write(0,*) "ZIEGFALL: EXITING SUBROUTINE"
8475
8476
8477 RETURN
8478 END subroutine ziegfall1d
8479
8480! #####################################################################
8481! #####################################################################
8482
8483
8484! #####################################################################
8485! #####################################################################
8486
8487! ##############################################################################
8490 subroutine radardd02(nx,ny,nz,nor,na,an,temk, &
8491 & dbz,db,nzdbz,cnoh0t,hwdn1t,ipconc,ke_diag, iunit)
8492!
8493! 11.13.2005: Changed values of indices for reordering of lip
8494!
8495! 07.13.2005: Fixed an error where cnoh was being used for graupel and frozen drops
8496!
8497! 01.24.2005: add ice crystal reflectivity using parameterization of
8498! Heymsfield (JAS, 1977). Could also try Ferrier for this, too.
8499!
8500! 09.28.2002 Test alterations for dry ice following Ferrier (1994)
8501! for equivalent melted diameter reflectivity.
8502! Converted to Fortran by ERM.
8503!
8504!Date: Tue, 21 Nov 2000 10:13:36 -0600 (CST)
8505!From: Matthew Gilmore <gilmore@hesston.met.tamu.edu>
8506!
8507!PRO RF_SPEC ; Computes Radar Reflectivity
8508!COMMON MAINB, data, x1d, y1d, z1d, iconst, rconst, labels, nx, ny, nz, dshft
8509!
8510!;MODIFICATION HISTORY
8511!; 5/99 -Svelta Veleva introduces variable dielf (const_ki_x) as a (weak)
8512!; function of density. This leads to slight modification of dielf such
8513!; that the snow reflectivity is slightly increased - not a big effect.
8514!; This is believed to be more accurate than assuming the dielectric
8515!; constant for snow is the same as for hail in previous versions.
8516!
8517!;On 6/13/99 I added the VIL computation (k=0 in vil array)
8518!;On 6/15/99 I removed the number concentration dependencies as a function
8519!; of temperature (only use for ferrier!)
8520!;On 6/15/99 I added the Composite reflectivity (k=1 in VIL array)
8521!;On 6/15/99 I added the Severe Hail Index computation (k=2 in vil array)
8522!;
8523!; 6/99 - Veleva and Seo argue that since graupel is more similar to
8524!; snow (in number conc and size density) than it is to hail, we
8525!; should not weight wetted graupel with the .95 exponent correction
8526!; factor as in the case of hail. An if-statement checks the size
8527!; density for wet hail/graupel and treats them appropriately.
8528!;
8529!; 6/22/99 - Added function to compute height of max rf and 40 dbz echo top
8530!; Also added vilqr which is the model vertical integrated liquid only
8531!; using qr. Will need to check...does not seem consistent with vilZ
8532!;
8533
8534
8535 implicit none
8536
8537 character(LEN=15), parameter :: microp = 'ZVD'
8538 integer nx,ny,nz,nor,na,ngt
8539 integer nzdbz ! how many levels actually to process
8540
8541 integer ng1,n10
8542 integer iunit
8543 integer, parameter :: printyn = 0
8544
8545 parameter( ng1 = 1 )
8546
8547 real cnoh0t,hwdn1t
8548 integer ke_diag
8549 integer ipconc
8550 real vr
8551
8552
8553 integer imapz,mzdist
8554
8555 integer vzflag
8556 integer, parameter :: norz = 3
8557 real an(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,na)
8558 real db(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) ! air density
8559! real gt(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,ngt)
8560 real temk(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) ! air temperature (kelvin)
8561 real dbz(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) ! reflectivity
8562 real gz(-nor+1:nz+nor) ! ,z1d(-nor+1:nz+nor,4)
8563
8564! real g,rgas,eta,inveta
8565 real cr1, cr2 , hwdnsq,swdnsq
8566 real rwdnsq, dhmin, qrmin, qsmin, qhmin, qhlmin, tfr, tfrh, zrc
8567 real reflectmin, kw_sq
8568 real const_ki_sn, const_ki_h, ki_sq_sn
8569 real ki_sq_h, dielf_sn, dielf_h
8570 real pi
8571 logical ltest
8572
8573! Other data arrays
8574 real gtmp (nx,nz)
8575 real dtmp (nx,nz)
8576 real tmp
8577
8578 real*8 dtmps, dtmpr, dtmph, dtmphl, g1, zx, ze, x
8579
8580 integer i,j,k,ix,jy,kz,ihcnt
8581
8582 real*8 xcnoh, xcnos, dadh, dads, zhdryc, zsdryc, zhwetc,zswetc
8583 real*8 dadr
8584 real dbzmax,dbzmin
8585 parameter( dbzmin = 0 )
8586
8587 real cnow,cnoi,cnoip,cnoir,cnor,cnos
8588 real cnogl,cnogm,cnogh,cnof,cnoh,cnohl
8589
8590 real swdn, rwdn ,hwdn,gldn,gmdn,ghdn,fwdn,hldn
8591 real swdn0
8592
8593 real rwdnmx,cwdnmx,cidnmx,xidnmx,swdnmx,gldnmx,gmdnmx
8594 real ghdnmx,fwdnmx,hwdnmx,hldnmx
8595 real rwdnmn,cwdnmn,cidnmn,xidnmn,swdnmn,gldnmn,gmdnmn
8596 real ghdnmn,fwdnmn,hwdnmn,hldnmn
8597
8598 real gldnsq,gmdnsq,ghdnsq,fwdnsq,hldnsq
8599
8600 real dadgl,dadgm,dadgh,dadhl,dadf
8601 real zgldryc,zglwetc,zgmdryc, zgmwetc,zghdryc,zghwetc
8602 real zhldryc,zhlwetc,zfdryc,zfwetc
8603
8604 real dielf_gl,dielf_gm,dielf_gh,dielf_hl,dielf_fw
8605
8606 integer imx,jmx,kmx
8607
8608 real swdia,gldia,gmdia,ghdia,fwdia,hwdia,hldia
8609
8610 real csw,cgl,cgm,cgh,cfw,chw,chl
8611 real xvs,xvgl,xvgm,xvgh,xvf,xvh,xvhl
8612
8613 real cwc0
8614 integer izieg
8615 integer ice10
8616 real rhos
8617 parameter( rhos = 0.1 )
8618
8619 real qxw,qxw1 ! temp value for liquid water on ice mixing ratio
8620 real :: dnsnow
8621 real qh
8622
8623 real, parameter :: cwmasn = 5.23e-13 ! minimum mass, defined by radius of 5.0e-6
8624 real, parameter :: cwmasx = 5.25e-10 ! maximum mass, defined by radius of 50.0e-6
8625 real, parameter :: cwradn = 5.0e-6 ! minimum radius
8626
8627 real cwnccn(nz)
8628
8629 real :: vzsnow, vzrain, vzgraupel, vzhail
8630 real :: ksq
8631 real :: dtp
8632
8633
8634! #########################################################################
8635
8636 vzflag = 0
8637
8638 izieg = 0
8639 ice10 = 0
8640! g=9.806 ! g: gravity constant
8641! rgas=287.04 ! rgas: gas constant for dry air
8642! rcp=rgas/cp ! rcp: gamma constant
8643! eta=0.622
8644! inveta = 1./eta
8645! rcpinv = 1./rcp
8646! cpr=cp/rgas
8647! cvr=cv/rgas
8648 pi = 4.0*atan(1.)
8649 cwc0 = piinv ! 1./pi ! 6.0/pi
8650
8651 cnoh = cnoh0t
8652 hwdn = hwdn1t
8653
8654 rwdn = 1000.0
8655 swdn = 100.0
8656
8657 qrmin = 1.0e-05
8658 qsmin = 1.0e-06
8659 qhmin = 1.0e-05
8660
8661!
8662! default slope intercepts
8663!
8664 cnow = 1.0e+08
8665 cnoi = 1.0e+08
8666 cnoip = 1.0e+08
8667 cnoir = 1.0e+08
8668 cnor = 8.0e+06
8669 cnos = 8.0e+06
8670 cnogl = 4.0e+05
8671 cnogm = 4.0e+05
8672 cnogh = 4.0e+05
8673 cnof = 4.0e+05
8674 cnohl = 1.0e+03
8675
8676
8677 imx = 1
8678 jmx = 1
8679 kmx = 1
8680 i = 1
8681
8682
8683 IF ( microp(1:4) .eq. 'ZIEG' ) THEN ! na .ge. 14 .and. ipconc .ge. 3 ) THEN
8684
8685! write(0,*) 'Set reflectivity for ZIEG'
8686 izieg = 1
8687
8688 hwdn = hwdn1t ! 500.
8689
8690
8691 cnor = cno(lr)
8692 cnos = cno(ls)
8693 cnoh = cno(lh)
8694 qrmin = qxmin(lr)
8695 qsmin = qxmin(ls)
8696 qhmin = qxmin(lh)
8697 IF ( lhl .gt. 1 ) THEN
8698 cnohl = cno(lhl)
8699 qhlmin = qxmin(lhl)
8700 ENDIF
8701
8702 ELSEIF ( microp(1:3) .eq. 'ZVD' ) THEN ! na .ge. 14 .and. ipconc .ge. 3 ) THEN
8703
8704 izieg = 1
8705
8706 swdn0 = swdn
8707
8708 cnor = cno(lr)
8709 cnos = cno(ls)
8710 cnoh = cno(lh)
8711
8712 qrmin = qxmin(lr)
8713 qsmin = qxmin(ls)
8714 qhmin = qxmin(lh)
8715 IF ( lhl .gt. 1 ) THEN
8716 cnohl = cno(lhl)
8717 qhlmin = qxmin(lhl)
8718 ENDIF
8719! write(*,*) 'radardbz: ',db(1,1,1),temk(1,1,1),an(1,1,1,lr),an(1,1,1,ls),an(1,1,1,lh)
8720
8721
8722 ENDIF
8723
8724
8725! cdx(lr) = 0.60
8726!
8727! IF ( lh > 1 ) THEN
8728! cdx(lh) = 0.8 ! 1.0 ! 0.45
8729! cdx(ls) = 2.00
8730! ENDIF
8731!
8732! IF ( lhl .gt. 1 ) cdx(lhl) = 0.45
8733!
8734! xvmn(lc) = xvcmn
8735! xvmn(lr) = xvrmn
8736!
8737! xvmx(lc) = xvcmx
8738! xvmx(lr) = xvrmx
8739!
8740! IF ( lh > 1 ) THEN
8741! xvmn(ls) = xvsmn
8742! xvmn(lh) = xvhmn
8743! xvmx(ls) = xvsmx
8744! xvmx(lh) = xvhmx
8745! ENDIF
8746!
8747! IF ( lhl .gt. 1 ) THEN
8748! xvmn(lhl) = xvhlmn
8749! xvmx(lhl) = xvhlmx
8750! ENDIF
8751!
8752! xdnmx(lr) = 1000.0
8753! xdnmx(lc) = 1000.0
8754! IF ( lh > 1 ) THEN
8755! xdnmx(li) = 917.0
8756! xdnmx(ls) = 300.0
8757! xdnmx(lh) = 900.0
8758! ENDIF
8759! IF ( lhl .gt. 1 ) xdnmx(lhl) = 900.0
8760!!
8761! xdnmn(:) = 900.0
8762!
8763! xdnmn(lr) = 1000.0
8764! xdnmn(lc) = 1000.0
8765! IF ( lh > 1 ) THEN
8766! xdnmn(li) = 100.0
8767! xdnmn(ls) = 100.0
8768! xdnmn(lh) = hdnmn
8769! ENDIF
8770! IF ( lhl .gt. 1 ) xdnmn(lhl) = 500.0
8771!
8772! xdn0(:) = 900.0
8773!
8774! xdn0(lc) = 1000.0
8775! xdn0(lr) = 1000.0
8776! IF ( lh > 1 ) THEN
8777! xdn0(li) = 900.0
8778! xdn0(ls) = 100.0 ! 100.0
8779! xdn0(lh) = hwdn1t ! (0.5)*(xdnmn(lh)+xdnmx(lh))
8780! ENDIF
8781! IF ( lhl .gt. 1 ) xdn0(lhl) = 800.0
8782
8783!
8784! slope intercepts
8785!
8786! cnow = 1.0e+08
8787! cnoi = 1.0e+08
8788! cnoip = 1.0e+08
8789! cnoir = 1.0e+08
8790! cnor = 8.0e+06
8791! cnos = 8.0e+06
8792! cnogl = 4.0e+05
8793! cnogm = 4.0e+05
8794! cnogh = 4.0e+05
8795! cnof = 4.0e+05
8796!c cnoh = 4.0e+04
8797! cnohl = 1.0e+03
8798!
8799!
8800! density maximums and minimums
8801!
8802 rwdnmx = 1000.0
8803 cwdnmx = 1000.0
8804 cidnmx = 917.0
8805 xidnmx = 917.0
8806 swdnmx = 200.0
8807 gldnmx = 400.0
8808 gmdnmx = 600.0
8809 ghdnmx = 800.0
8810 fwdnmx = 900.0
8811 hwdnmx = 900.0
8812 hldnmx = 900.0
8813!
8814 rwdnmn = 1000.0
8815 cwdnmn = 1000.0
8816 xidnmn = 001.0
8817 cidnmn = 001.0
8818 swdnmn = 001.0
8819 gldnmn = 200.0
8820 gmdnmn = 400.0
8821 ghdnmn = 600.0
8822 fwdnmn = 700.0
8823 hwdnmn = 700.0
8824 hldnmn = 900.0
8825
8826
8827 gldn = (0.5)*(gldnmn+gldnmx) ! 300.
8828 gmdn = (0.5)*(gmdnmn+gmdnmx) ! 500.
8829 ghdn = (0.5)*(ghdnmn+ghdnmx) ! 700.
8830 fwdn = (0.5)*(fwdnmn+fwdnmx) ! 800.
8831 hldn = (0.5)*(hldnmn+hldnmx) ! 900.
8832
8833
8834 cr1 = 7.2e+20
8835 cr2 = 7.295e+19
8836 hwdnsq = hwdn**2
8837 swdnsq = swdn**2
8838 rwdnsq = rwdn**2
8839
8840 gldnsq = gldn**2
8841 gmdnsq = gmdn**2
8842 ghdnsq = ghdn**2
8843 fwdnsq = fwdn**2
8844 hldnsq = hldn**2
8845
8846 dhmin = 0.005
8847 tfr = 273.16
8848 tfrh = tfr - 8.0
8849 zrc = cr1*cnor
8850 reflectmin = 0.0
8851 kw_sq = 0.93
8852 dbzmax = dbzmin
8853
8854 ihcnt=0
8855
8856
8857!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
8858! Dielectric Factor - Formulas implemented by Svetla Veleva
8859! following Battan, "Radar Meteorology" - p. 40
8860! The result of these calculations is that the dielf numerator (ki_sq) without
8861! the density ratio is .2116 for hail if using 917 density and .25 for
8862! snow if using 220 density.
8863!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
8864 const_ki_sn = 0.5 - (0.5-0.46)/(917.-220.)*(swdn-220.)
8865 const_ki_h = 0.5 - (0.5-0.46)/(917.-220.)*(hwdn-220.)
8866 ki_sq_sn = (swdnsq/rwdnsq) * const_ki_sn**2
8867 ki_sq_h = (hwdnsq/rwdnsq) * const_ki_h**2
8868 dielf_sn = ki_sq_sn / kw_sq
8869 dielf_h = ki_sq_h / kw_sq
8870
8871!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
8872! Use the next line if you want to hardwire dielf for dry hail for both dry
8873! snow and dry hail.
8874! This would be equivalent to what Straka had originally. (i.e, .21/.93)
8875!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
8876 dielf_sn = (swdnsq/rwdnsq)*.21/ kw_sq
8877 dielf_h = (hwdnsq/rwdnsq)*.21/ kw_sq
8878
8879 dielf_gl = (gldnsq/rwdnsq)*.21/ kw_sq
8880 dielf_gm = (gmdnsq/rwdnsq)*.21/ kw_sq
8881 dielf_gh = (ghdnsq/rwdnsq)*.21/ kw_sq
8882 dielf_hl = (hldnsq/rwdnsq)*.21/ kw_sq
8883 dielf_fw = (fwdnsq/rwdnsq)*.21/ kw_sq
8884
8885!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
8886! Notes on dielectric factors - from Eun-Kyoung Seo
8887!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
8888! constants for both snow and hail would be (x=s,h).....
8889! xwdnsq/rwdnsq *0.21/kw_sq ! Straka/Smith - the original
8890! xwdnsq/rwdnsq *0.224 ! Ferrier - for particle sizes in equiv. drop diam
8891! xwdnsq/rwdnsq *0.176/kw_sq ! =0.189 in Smith - for particle sizes in equiv
8892! ice spheres
8893! xwdnsq/rwdnsq *0.208/kw_sq ! Smith 1984 - for particle sizes in equiv melted drop diameter
8894!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
8895
8896
8897! VIL algorithm constants
8898! Ztop = 10.**(56./10) !56 dbz is the max rf used by WATADS in cell vil
8899
8900
8901! Hail detection algorithm constants
8902! ZL = 40.
8903! ZU = 50.
8904! Ho = 3400. !WATADS Defaults
8905! Hm20 = 6200. !WATADS Defaults
8906
8907! DO kz = 1,Min(nzdbz,nz-1)
8908
8909 DO jy=1,1
8910
8911 DO kz = 1,ke_diag ! nz
8912
8913 DO ix=1,nx
8914 dbz(ix,jy,kz) = 0.0
8915
8916 vzsnow = 0.0
8917 vzrain = 0.0
8918 vzgraupel = 0.0
8919 vzhail = 0.0
8920
8921 dtmph = 0.0
8922 dtmps = 0.0
8923 dtmphl = 0.0
8924 dtmpr = 0.0
8925 dadr = (db(ix,jy,kz)/(pi*rwdn*cnor))**(0.25)
8926!-----------------------------------------------------------------------
8927! Compute Rain Radar Reflectivity
8928!-----------------------------------------------------------------------
8929
8930 dtmp(ix,kz) = 0.0
8931 gtmp(ix,kz) = 0.0
8932 IF ( an(ix,jy,kz,lr) .ge. qrmin ) THEN
8933 IF ( ipconc .le. 2 ) THEN
8934 gtmp(ix,kz) = dadr*an(ix,jy,kz,lr)**(0.25)
8935 dtmp(ix,kz) = zrc*gtmp(ix,kz)**7
8936 ELSEIF ( lzr .gt. 1 ) THEN
8937 dtmp(ix,kz) = 1e18*an(ix,jy,kz,lzr)
8938 ELSEIF ( an(ix,jy,kz,lnr) .gt. 1.e-3 ) THEN
8939 IF ( imurain == 3 ) THEN
8940 vr = db(ix,jy,kz)*an(ix,jy,kz,lr)/(1000.*an(ix,jy,kz,lnr))
8941 dtmp(ix,kz) = 3.6e18*(rnu+2.)*an(ix,jy,kz,lnr)*vr**2/(rnu+1.)
8942 ELSE ! imurain == 1
8943 g1 = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar))
8944 zx = g1*(db(ix,jy,kz)*an(ix,jy,kz,lr))**2/an(ix,jy,kz,lnr)
8945 ze =1.e18*zx*(6./(pi*1000.))**2 ! note: using 1000. here for water density
8946 dtmp(ix,kz) = ze
8947 ENDIF
8948 ENDIF
8949 dtmpr = dtmp(ix,kz)
8950 ENDIF
8951
8952!-----------------------------------------------------------------------
8953! Compute snow and graupel reflectivity
8954!
8955! Lou modified to look at parcel temperature rather than base state
8956!-----------------------------------------------------------------------
8957
8958 IF( lhab .gt. lr ) THEN
8959
8960! qs2d = reform(data[*,*,k,10],[nx*ny])
8961! qh2d = reform(data[*,*,k,11],[nx*ny])
8962
8963!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
8964! Only use the following lines if running Straka GEMS microphysics
8965! (Sam 1-d version modified by L Wicker does not use this)
8966!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
8967! ;xcnoh = cnoh*exp(-0.025*(temp-tfr))
8968! ;xcnos = cnos*exp(-0.038*(temp-tfr))
8969! ;good = where(temp GT tfr, n_elements)
8970! ;IF n_elements NE 0 THEN xcnoh(good) = cnoh*exp(-0.075*(temp(good)-tfr))
8971! ;IF n_elements NE 0 THEN xcnos(good) = cnos*exp(-0.088*(temp(good)-tfr))
8972
8973!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
8974! Only use the following lines if running Ferrier micro with No=No(T)
8975!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
8976! ; NOSE = -.15
8977! ; NOGE = .0
8978! ; xcnoh = cnoh*(1.>exp(NOGE*(temp-tfr)) )
8979! ; xcnos = cnos*(1.>exp(NOSE*(temp-tfr)) )
8980
8981!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
8982! Use the following lines if Nos and Noh are constant
8983! (As in Svetla version of Ferrier, GCE Tao, and SAM 1-d)
8984!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
8985 xcnoh = cnoh
8986 xcnos = cnos
8987
8988!
8989! Temporary fix for predicted number concentration -- need a
8990! more appropriate reflectivity equation!
8991!
8992! IF ( an(ix,jy,kz,lns) .lt. 0.1 ) THEN
8993! swdia = (xvrmn*cwc0)**(1./3.)
8994! xcnos = an(ix,jy,kz,ls)*db(ix,jy,kz)/(xvrmn*swdn*swdia)
8995! ELSE
8996! ! changed back to diameter of mean volume!!!
8997! swdia =
8998! > (an(ix,jy,kz,ls)*db(ix,jy,kz)
8999! > /(pi*swdn*an(ix,jy,kz,lns)))**(1./3.)
9000!
9001! xcnos = an(ix,jy,kz,lns)/swdia
9002! ENDIF
9003
9004 IF ( ls .gt. 1 ) THEN ! {
9005
9006 IF ( lvs .gt. 1 ) THEN
9007 IF ( an(ix,jy,kz,lvs) .gt. 0.0 ) THEN
9008 swdn = db(ix,jy,kz)*an(ix,jy,kz,ls)/an(ix,jy,kz,lvs)
9009 swdn = min( 300., max( 100., swdn ) )
9010 ELSE
9011 swdn = swdn0
9012 ENDIF
9013
9014 ENDIF
9015
9016 IF ( ipconc .ge. 5 ) THEN ! {
9017
9018 xvs = db(ix,jy,kz)*an(ix,jy,kz,ls)/ &
9019 & (swdn*max(1.0e-3,an(ix,jy,kz,lns)))
9020 IF ( xvs .lt. xvsmn .or. xvs .gt. xvsmx ) THEN
9021 xvs = min( xvsmx, max( xvsmn,xvs ) )
9022 csw = db(ix,jy,kz)*an(ix,jy,kz,ls)/(xvs*swdn)
9023 ENDIF
9024
9025 swdia = (xvs*cwc0)**(1./3.)
9026 xcnos = an(ix,jy,kz,ls)*db(ix,jy,kz)/(xvs*swdn*swdia)
9027
9028 ENDIF ! }
9029 ENDIF ! }
9030
9031! IF ( an(ix,jy,kz,lnh) .lt. 0.1 ) THEN
9032! hwdia = (xvrmn*cwc0)**(1./3.)
9033! xcnoh = an(ix,jy,kz,lh)*db(ix,jy,kz)/(xvrmn*hwdn*hwdia)
9034! ELSE
9035! ! changed back to diameter of mean volume!!!
9036! hwdia =
9037! > (an(ix,jy,kz,lh)*db(ix,jy,kz)
9038! > /(pi*hwdn*an(ix,jy,kz,lnh)))**(1./3.)
9039!
9040! xcnoh = an(ix,jy,kz,lnh)/hwdia
9041! ENDIF
9042
9043 IF ( lh .gt. 1 ) THEN ! {
9044
9045 IF ( lvh .gt. 1 ) THEN
9046 IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN
9047 hwdn = db(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh)
9048 hwdn = min( 900., max( hdnmn, hwdn ) )
9049 ELSE
9050 hwdn = 500. ! hwdn1t
9051 ENDIF
9052 ELSE
9053 hwdn = hwdn1t
9054 ENDIF
9055
9056 IF ( ipconc .ge. 5 ) THEN ! {
9057
9058 xvh = db(ix,jy,kz)*an(ix,jy,kz,lh)/ &
9059 & (hwdn*max(1.0e-3,an(ix,jy,kz,lnh)))
9060 IF ( xvh .lt. xvhmn .or. xvh .gt. xvhmx ) THEN
9061 xvh = min( xvhmx, max( xvhmn,xvh ) )
9062 chw = db(ix,jy,kz)*an(ix,jy,kz,lh)/(xvh*hwdn)
9063 ENDIF
9064
9065 hwdia = (xvh*cwc0)**(1./3.)
9066 xcnoh = an(ix,jy,kz,lh)*db(ix,jy,kz)/(xvh*hwdn*hwdia)
9067
9068 ENDIF ! } ipconc .ge. 5
9069
9070 ENDIF ! }
9071
9072 dadh = 0.0
9073 dadhl = 0.0
9074 dads = 0.0
9075 IF ( xcnoh .gt. 0.0 ) THEN
9076 dadh = ( db(ix,jy,kz) /(pi*hwdn*xcnoh) )**(.25)
9077 zhdryc = 0.224*cr2*(db(ix,jy,kz)/rwdn)**2/xcnoh ! dielf_h*cr1*xcnoh ! SV - equiv formula as before but
9078 ! ratio of densities included in
9079 ! dielf_h rather than here following
9080 ! Battan.
9081 ELSE
9082 dadh = 0.0
9083 zhdryc = 0.0
9084 ENDIF
9085
9086 IF ( xcnos .gt. 0.0 ) THEN
9087 dads = ( db(ix,jy,kz) /(pi*swdn*xcnos) )**(.25)
9088 zsdryc = 0.224*cr2*(db(ix,jy,kz)/rwdn)**2/xcnos ! dielf_sn*cr1*xcnos ! SV - similar change as above
9089 ELSE
9090 dads = 0.0
9091 zsdryc = 0.0
9092 ENDIF
9093 zhwetc = zhdryc ! cr1*xcnoh !Hail/graupel version with .95 power bug removed
9094 zswetc = zsdryc ! cr1*xcnos
9095!
9096! snow contribution
9097!
9098 IF ( ls .gt. 1 ) THEN
9099
9100 gtmp(ix,kz) = 0.0
9101 qxw = 0.0
9102 qxw1 = 0.0
9103 dtmps = 0.0
9104 IF ( an(ix,jy,kz,ls) .ge. qsmin ) THEN !{
9105 IF ( ipconc .ge. 4 ) THEN ! (Ferrier 94) !{
9106
9107 if (lsw .gt. 1) THEN
9108 qxw = an(ix,jy,kz,lsw)
9109 qxw1 = 0.0
9110 ELSEIF ( ( iusewetsnow == 1 .or. iusewetsnow == 3) .and. temk(ix,jy,kz) .gt. tfr+1. &
9111 & .and. an(ix,jy,kz,ls) > an(ix,jy,kz,lr) .and. an(ix,jy,kz,lr) > qsmin) THEN
9112 qxw = min(0.5*an(ix,jy,kz,ls), an(ix,jy,kz,lr))
9113 qxw1 = qxw
9114 ENDIF
9115
9116 vr = xvs ! db(ix,jy,kz)*an(ix,jy,kz,lr)/(1000.*an(ix,jy,kz,lnr))
9117! gtmp(ix,kz) = 3.6e18*(0.243*rhos**2/0.93)*(snu+2.)*an(ix,jy,kz,lns)*vr**2/(snu+1.)
9118
9119 ksq = 0.189 ! Smith (1984, JAMC) for equiv. ice sphere
9120 IF ( an(ix,jy,kz,lns) .gt. 1.e-7 ) THEN
9121 ! IF ( .true. ) THEN
9122 IF ( qxw > qsmin .or. iusewetsnow >= 2 ) THEN ! old version
9123! gtmp(ix,kz) = 3.6e18*(snu+2.)*( 0.224*an(ix,jy,kz,ls) + 0.776*qxw)*an(ix,jy,kz,ls)/ &
9124! & (an(ix,jy,kz,lns)*(snu+1.)*rwdn**2)*db(ix,jy,kz)**2
9125 gtmp(ix,kz) = 3.6e18*(snu+2.)*( 0.224*(an(ix,jy,kz,ls)+qxw1) + 0.776*qxw)*(an(ix,jy,kz,ls)+qxw1)/ &
9126 & (an(ix,jy,kz,lns)*(snu+1.)*rwdn**2)*db(ix,jy,kz)**2
9127
9128 ELSE ! new form using a mass relationship m = p d^2 (instead of d^3 -- Cox 1988 QJRMS) so that density depends on size
9129 ! p = 0.106214 for m = p v^(2/3)
9130 dnsnow = 0.0346159*sqrt(an(ix,jy,kz,lns)/(an(ix,jy,kz,ls)*db(ix,jy,kz)) )
9131 IF ( .true. .or. dnsnow < 900. ) THEN
9132 gtmp(ix,kz) = 1.e18*323.3226* 0.106214**2*(ksq*an(ix,jy,kz,ls) + &
9133 & (1.-ksq)*qxw)*an(ix,jy,kz,ls)*db(ix,jy,kz)**2*gsnow73/ &
9134 & (an(ix,jy,kz,lns)*(917.)**2* gsnow1*(1.0+snu)**(4./3.))
9135 ELSE ! otherwise small enough to assume ice spheres?
9136 gtmp(ix,kz) = (36./pi**2) * 1.e18*(snu+2.)*( 0.224*(an(ix,jy,kz,ls)+qxw1) + 0.776*qxw)*(an(ix,jy,kz,ls)+qxw1)/ &
9137 & (an(ix,jy,kz,lns)*(snu+1.)*rwdn**2)*db(ix,jy,kz)**2
9138 ENDIF
9139
9140 ENDIF
9141
9142 ENDIF
9143
9144! tmp = Min(1.0,1.e3*(an(ix,jy,kz,ls))*db(ix,jy,kz))
9145! gtmp(ix,kz) = Max( 1.0*gtmp(ix,kz), 750.0*(tmp)**1.98)
9146 dtmps = gtmp(ix,kz)
9147 dtmp(ix,kz) = dtmp(ix,kz) + gtmp(ix,kz)
9148 ELSE ! }{ single-moment snow:
9149 gtmp(ix,kz) = dads*an(ix,jy,kz,ls)**(0.25)
9150
9151 IF ( gtmp(ix,kz) .gt. 0.0 ) THEN !{
9152 dtmps = zsdryc*an(ix,jy,kz,ls)**2/gtmp(ix,kz)
9153 IF ( temk(ix,jy,kz) .lt. tfr ) THEN
9154 dtmp(ix,kz) = dtmp(ix,kz) + &
9155 & zsdryc*an(ix,jy,kz,ls)**2/gtmp(ix,kz)
9156 ELSE
9157 dtmp(ix,kz) = dtmp(ix,kz) + &
9158 & zswetc*an(ix,jy,kz,ls)**2/gtmp(ix,kz)
9159 ENDIF
9160 ENDIF !}
9161 ENDIF !}
9162
9163 ENDIF !}
9164
9165 ENDIF
9166
9167
9168!
9169! ice crystal contribution (Heymsfield, 1977, JAS)
9170!
9171 IF ( li .gt. 1 .and. idbzci .ne. 0 ) THEN
9172
9173 IF ( idbzci == 1 .and. lni > 0 ) THEN
9174 ! assume spherical ice with density of 900 for dbz calc
9175 IF ( an(ix,jy,kz,li) > qxmin(li) .and. an(ix,jy,kz,lni) > 1.0 ) THEN
9176 vr = db(ix,jy,kz)*an(ix,jy,kz,li)/(900.*an(ix,jy,kz,lni))
9177 dtmp(ix,kz) = dtmp(ix,kz) + &
9178 & 0.224*3.6e18*(cinu+2.)*an(ix,jy,kz,lni)*vr**2/(cinu+1.)*(900./1000.)**2
9179 ENDIF
9180
9181 ELSEIF ( idbzci == 2 ) THEN
9182!
9183! ice crystal contribution (Heymsfield, 1977, JAS)
9184!
9185 gtmp(ix,kz) = 0.0
9186 IF ( an(ix,jy,kz,li) .ge. 0.1e-3 ) THEN
9187 gtmp(ix,kz) = min(1.0,1.e3*(an(ix,jy,kz,li))*db(ix,jy,kz))
9188 dtmp(ix,kz) = dtmp(ix,kz) + 750.0*(gtmp(ix,kz))**1.98
9189 ENDIF
9190
9191 ENDIF
9192
9193 ENDIF
9194
9195!
9196! graupel/hail contribution
9197!
9198 IF ( lh .gt. 1 ) THEN ! {
9199 gtmp(ix,kz) = 0.0
9200 dtmph = 0.0
9201 qxw = 0.0
9202
9203 IF ( izieg .ge. 1 .and. ipconc .ge. 5 ) THEN
9204
9205 ltest = .false.
9206 IF ( lzh > 1 ) THEN
9207 IF ( an(ix,jy,kz,lzh) > 0.0 .and. an(ix,jy,kz,lh) > qhmin .and. &
9208 an(ix,jy,kz,lnh) >= cxmin ) ltest = .true.
9209 ENDIF
9210
9211 IF ( ltest .or. (an(ix,jy,kz,lh) .ge. qhmin .and. an(ix,jy,kz,lnh) .ge. cxmin )) THEN
9212
9213 IF ( lvh .gt. 1 ) THEN
9214
9215 IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN
9216 hwdn = db(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh)
9217 hwdn = min( 900., max( 100., hwdn ) )
9218 ELSE
9219 hwdn = 500. ! hwdn1t
9220 ENDIF
9221
9222 ENDIF
9223
9224 chw = an(ix,jy,kz,lnh)
9225 IF ( chw .gt. 0.0 ) THEN ! (Ferrier 94)
9226 xvh = db(ix,jy,kz)*an(ix,jy,kz,lh)/(hwdn*max(1.0e-3,chw))
9227 IF ( xvh .lt. xvhmn .or. xvh .gt. xvhmx ) THEN
9228 xvh = min( xvhmx, max( xvhmn,xvh ) )
9229 chw = db(ix,jy,kz)*an(ix,jy,kz,lh)/(xvh*hwdn)
9230 ENDIF
9231
9232 qh = an(ix,jy,kz,lh)
9233
9234 IF ( lhw .gt. 1 ) THEN
9235 IF ( iusewetgraupel .eq. 1 ) THEN
9236 qxw = an(ix,jy,kz,lhw)
9237 ELSEIF ( iusewetgraupel .eq. 2 ) THEN
9238 IF ( hwdn .lt. 300. ) THEN
9239 qxw = an(ix,jy,kz,lhw)
9240 ENDIF
9241 ENDIF
9242 ELSEIF ( iusewetgraupel .eq. 3 ) THEN
9243 IF ( hwdn .lt. 300. .and. temk(ix,jy,kz) > tfr .and. an(ix,jy,kz,lr) > qhmin ) THEN
9244 qxw = min( an(ix,jy,kz,lh), an(ix,jy,kz,lr))
9245 qh = qh + qxw
9246 ENDIF
9247 ELSEIF ( iusewetgraupel == 4 .and. temk(ix,jy,kz) .gt. tfr+0.25 .and. an(ix,jy,kz,lh) > an(ix,jy,kz,lr) &
9248 & .and. an(ix,jy,kz,lr) > qhmin) THEN
9249 qxw = min(0.5*an(ix,jy,kz,lh), an(ix,jy,kz,lr))
9250 qh = qh + qxw
9251
9252 ENDIF
9253
9254 IF ( lzh .gt. 1 ) THEN
9255 x = (0.224*qh + 0.776*qxw)/an(ix,jy,kz,lh) ! weighted average of dielectric const
9256 dtmph = 1.e18*x*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2
9257 dtmp(ix,kz) = dtmp(ix,kz) + dtmph
9258 ELSE
9259 g1 = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah))
9260! zx = g1*(db(ix,jy,kz)*an(ix,jy,kz,lh))**2/chw
9261! ze = 0.224*1.e18*zx*(6./(pi*1000.))**2
9262 zx = g1*db(ix,jy,kz)**2*( 0.224*qh + 0.776*qxw)*qh/chw
9263 ze =1.e18*zx*(6./(pi*1000.))**2
9264 dtmp(ix,kz) = dtmp(ix,kz) + ze
9265 dtmph = ze
9266 ENDIF
9267
9268 ENDIF
9269
9270 ! IF ( an(ix,jy,kz,lh) .gt. 1.0e-3 ) write(0,*) 'Graupel Z : ',dtmph,ze
9271 ENDIF
9272
9273 ELSE
9274
9275 dtmph = 0.0
9276
9277 IF ( an(ix,jy,kz,lh) .ge. qhmin ) THEN
9278 gtmp(ix,kz) = dadh*an(ix,jy,kz,lh)**(0.25)
9279 IF ( gtmp(ix,kz) .gt. 0.0 ) THEN
9280 dtmph = zhdryc*an(ix,jy,kz,lh)**2/gtmp(ix,kz)
9281 IF ( temk(ix,jy,kz) .lt. tfr ) THEN
9282 dtmp(ix,kz) = dtmp(ix,kz) + &
9283 & zhdryc*an(ix,jy,kz,lh)**2/gtmp(ix,kz)
9284 ELSE
9285! IF ( hwdn .gt. 700.0 ) THEN
9286 dtmp(ix,kz) = dtmp(ix,kz) + &
9287 & zhdryc*an(ix,jy,kz,lh)**2/gtmp(ix,kz)
9288!
9289! & (zhwetc*gtmp(ix,kz)**7)**0.95
9290! ELSE
9291! dtmp(ix,kz) = dtmp(ix,kz) + zhwetc*gtmp(ix,kz)**7
9292! ENDIF
9293 ENDIF
9294 ENDIF
9295 ENDIF
9296
9297
9298
9299 ENDIF
9300
9301
9302 ENDIF ! }
9303
9304 ENDIF ! na .gt. 5
9305
9306
9307 IF ( izieg .ge. 1 .and. lhl .gt. 1 ) THEN
9308
9309 hldn = 900.0
9310 gtmp(ix,kz) = 0.0
9311 dtmphl = 0.0
9312 qxw = 0.0
9313
9314
9315 IF ( lvhl .gt. 1 ) THEN
9316 IF ( an(ix,jy,kz,lvhl) .gt. 0.0 ) THEN
9317 hldn = db(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl)
9318 hldn = min( 900., max( 300., hldn ) )
9319 ELSE
9320 hldn = 900.
9321 ENDIF
9322 ELSE
9323 hldn = rho_qhl
9324 ENDIF
9325
9326
9327 IF ( ipconc .ge. 5 ) THEN
9328
9329 ltest = .false.
9330 IF ( lzhl > 1 ) THEN
9331 IF ( an(ix,jy,kz,lzhl) > 0.0 .and. an(ix,jy,kz,lhl) > qhlmin .and. &
9332 an(ix,jy,kz,lnhl) > 0.0 ) ltest = .true.
9333 ENDIF
9334
9335 IF ( ltest .or. ( an(ix,jy,kz,lhl) .ge. qhlmin .and. an(ix,jy,kz,lnhl) .gt. 0.) ) THEN !{
9336 chl = an(ix,jy,kz,lnhl)
9337 IF ( chl .gt. 0.0 ) THEN !{
9338 xvhl = db(ix,jy,kz)*an(ix,jy,kz,lhl)/ &
9339 & (hldn*max(1.0e-9,an(ix,jy,kz,lnhl)))
9340 IF ( xvhl .lt. xvhlmn .or. xvhl .gt. xvhlmx ) THEN ! {
9341 xvhl = min( xvhlmx, max( xvhlmn,xvhl ) )
9342 chl = db(ix,jy,kz)*an(ix,jy,kz,lhl)/(xvhl*hldn)
9343 ! do not update state in dbz calc. ! an(ix,jy,kz,lnhl) = chl
9344 ENDIF ! }
9345
9346 IF ( lhlw .gt. 1 ) THEN
9347 IF ( iusewethail .eq. 1 ) THEN
9348 qxw = an(ix,jy,kz,lhlw)
9349 ELSEIF ( iusewethail .eq. 2 ) THEN
9350 IF ( hldn .lt. 300. ) THEN
9351 qxw = an(ix,jy,kz,lhlw)
9352 ENDIF
9353 ENDIF
9354 ENDIF
9355
9356 IF ( lzhl .gt. 1 ) THEN !{
9357 x = (0.224*an(ix,jy,kz,lhl) + 0.776*qxw)/an(ix,jy,kz,lhl) ! weighted average of dielectric const
9358 dtmphl = 1.e18*x*an(ix,jy,kz,lzhl)*(hldn/rwdn)**2
9359 dtmp(ix,kz) = dtmp(ix,kz) + dtmphl
9360 ELSE !}
9361
9362 g1 = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl))
9363 zx = g1*db(ix,jy,kz)**2*( 0.224*an(ix,jy,kz,lhl) + 0.776*qxw)*an(ix,jy,kz,lhl)/chl
9364! zx = g1*(db(ix,jy,kz)*an(ix,jy,kz,lhl))**2/chl
9365 ze = 1.e18*zx*(6./(pi*1000.))**2 ! 3/28/2016 removed extra factor of 0.224
9366 dtmp(ix,kz) = dtmp(ix,kz) + ze
9367 dtmphl = ze
9368
9369 ENDIF !}
9370 endif!}
9371 ! IF ( an(ix,jy,kz,lh) .gt. 1.0e-3 ) write(0,*) 'Graupel Z : ',dtmph,ze
9372 ENDIF
9373
9374
9375 ELSE
9376
9377
9378 IF ( an(ix,jy,kz,lhl) .ge. qhlmin ) THEN ! {
9379 dadhl = ( db(ix,jy,kz) /(pi*hldn*cnohl) )**(.25)
9380 gtmp(ix,kz) = dadhl*an(ix,jy,kz,lhl)**(0.25)
9381 IF ( gtmp(ix,kz) .gt. 0.0 ) THEN ! {
9382
9383 zhldryc = 0.224*cr2*( db(ix,jy,kz)/rwdn)**2/cnohl
9384
9385 dtmphl = zhldryc*an(ix,jy,kz,lhl)**2/gtmp(ix,kz)
9386
9387 IF ( temk(ix,jy,kz) .lt. tfr ) THEN
9388 dtmp(ix,kz) = dtmp(ix,kz) + &
9389 & zhldryc*an(ix,jy,kz,lhl)**2/gtmp(ix,kz)
9390 ELSE
9391! IF ( hwdn .gt. 700.0 ) THEN
9392 dtmp(ix,kz) = dtmp(ix,kz) + &
9393 & zhldryc*an(ix,jy,kz,lhl)**2/gtmp(ix,kz)
9394!
9395! : (zhwetc*gtmp(ix,kz)**7)**0.95
9396! ELSE
9397! dtmp(ix,kz) = dtmp(ix,kz) + zhwetc*gtmp(ix,kz)**7
9398! ENDIF
9399 ENDIF
9400 ENDIF ! }
9401
9402 ENDIF ! }
9403
9404 ENDIF ! ipconc .ge. 5
9405
9406
9407 ENDIF ! izieg .ge. 1 .and. lhl .gt. 1
9408
9409
9410
9411 IF ( dtmp(ix,kz) .gt. 0.0 ) THEN
9412 dbz(ix,jy,kz) = max(dbzmin, 10.0*log10(dtmp(ix,kz)) )
9413
9414 IF ( dbz(ix,jy,kz) .gt. dbzmax ) THEN
9415 dbzmax = max(dbzmax,dbz(ix,jy,kz))
9416 imx = ix
9417 jmx = jy
9418 kmx = kz
9419 ENDIF
9420 ELSE
9421 dbz(ix,jy,kz) = dbzmin
9422 IF ( lh > 1 .and. lhl > 1) THEN
9423 IF ( an(ix,jy,kz,lh) > 1.0e-3 ) THEN
9424 write(0,*) 'radardbz: qr,qh,qhl = ',an(ix,jy,kz,lr), an(ix,jy,kz,lh),an(ix,jy,kz,lhl)
9425 write(0,*) 'radardbz: dtmps,dtmph,dadh,dadhl,dtmphl = ',dtmps,dtmph,dadh,dadhl,dtmphl
9426
9427 IF ( lzh>1 .and. lzhl>1 ) write(0,*) 'radardbz: zh, zhl = ',an(ix,jy,kz,lzh),an(ix,jy,kz,lzhl)
9428 ENDIF
9429 ENDIF
9430 ENDIF
9431
9432! IF ( an(ix,jy,kz,lh) .gt. 1.e-4 .and.
9433! & dbz(ix,jy,kz) .le. 0.0 ) THEN
9434! write(0,*) 'dbz = ',dbz(ix,jy,kz)
9435! write(0,*) 'Hail intercept: ',xcnoh,ix,kz
9436! write(0,*) 'Hail,snow q: ',an(ix,jy,kz,lh),an(ix,jy,kz,ls)
9437! write(0,*) 'Hail,snow c: ',an(ix,jy,kz,lnh),an(ix,jy,kz,lns)
9438! write(0,*) 'dtmps,dtmph = ',dtmps,dtmph
9439! ENDIF
9440 IF ( .not. dtmp(ix,kz) .lt. 1.e30 .or. dbz(ix,jy,kz) > 190.0 ) THEN
9441! IF ( ix == 31 .and. kz == 20 .and. jy == 23 ) THEN
9442! write(0,*) 'my_rank = ',my_rank
9443 write(0,*) 'ix,jy,kz = ',ix,jy,kz
9444 write(0,*) 'dbz = ',dbz(ix,jy,kz)
9445 write(0,*) 'db, zhdryc = ',db(ix,jy,kz),zhdryc
9446 write(0,*) 'Hail intercept: ',xcnoh,ix,kz
9447 write(0,*) 'Hail,snow q: ',an(ix,jy,kz,lh),an(ix,jy,kz,ls)
9448 write(0,*) 'graupel density hwdn = ',hwdn
9449 write(0,*) 'rain q: ',an(ix,jy,kz,lr)
9450 write(0,*) 'ice q: ',an(ix,jy,kz,li)
9451 IF ( lhl .gt. 1 ) write(0,*) 'Hail (lhl): ',an(ix,jy,kz,lhl)
9452 IF (ipconc .ge. 3 ) write(0,*) 'rain c: ',an(ix,jy,kz,lnr)
9453 IF ( lzr > 1 ) write(0,*) 'rain Z: ',an(ix,jy,kz,lzr)
9454 IF ( ipconc .ge. 5 ) THEN
9455 write(0,*) 'Hail,snow c: ',an(ix,jy,kz,lnh),an(ix,jy,kz,lns)
9456 IF ( lhl .gt. 1 ) write(0,*) 'Hail (lnhl): ',an(ix,jy,kz,lnhl)
9457 IF ( lzhl .gt. 1 ) THEN
9458 write(0,*) 'Hail (lzhl): ',an(ix,jy,kz,lzhl)
9459 write(0,*) 'chl,xvhl,dhl = ',chl,xvhl,(xvhl*6./3.14159)**(1./3.)
9460 write(0,*) 'xvhlmn,xvhlmx = ',xvhlmn,xvhlmx
9461 ENDIF
9462 ENDIF
9463 write(0,*) 'chw,xvh = ', chw,xvh
9464 write(0,*) 'dtmps,dtmph,dadh,dadhl,dtmphl = ',dtmps,dtmph,dadh,dadhl,dtmphl
9465 write(0,*) 'dtmpr = ',dtmpr
9466 write(0,*) 'gtmp = ',gtmp(ix,kz),dtmp(ix,kz)
9467 IF ( .not. (dbz(ix,jy,kz) .gt. -100 .and. dbz(ix,jy,kz) .lt. 200 ) ) THEN
9468 write(0,*) 'dbz out of bounds!'
9469 ENDIF
9470 ENDIF
9471
9472
9473 ENDDO ! ix
9474 ENDDO ! kz
9475 ENDDO ! jy
9476
9477
9478
9479
9480! write(0,*) 'na,lr = ',na,lr
9481 IF ( printyn .eq. 1 ) THEN
9482! IF ( dbzmax .gt. dbzmin ) THEN
9483 write(iunit,*) 'maxdbz,ijk = ',dbzmax,imx,jmx,kmx
9484 write(iunit,*) 'qrw = ',an(imx,jmx,kmx,lr)
9485
9486 IF ( lh .gt. 1 ) THEN
9487 write(iunit,*) 'qi = ',an(imx,jmx,kmx,li)
9488 write(iunit,*) 'qsw = ',an(imx,jmx,kmx,ls)
9489 write(iunit,*) 'qhw = ',an(imx,jmx,kmx,lh)
9490 IF ( lhl .gt. 1 ) write(iunit,*) 'qhl = ',an(imx,jmx,kmx,lhl)
9491 ENDIF
9492
9493
9494 ENDIF
9495
9496
9497 RETURN
9498 END subroutine radardd02
9499
9500
9501! ##############################################################################
9502! ##############################################################################
9503
9504
9507! #####################################################################
9508! #####################################################################
9509!
9510! Subroutine for explicit cloud condensation and droplet nucleation
9511!
9512! 11/30/2022: Fixed droplet evaporation heating term for CM1 eqtset=2 (was only doing eqtset=1)
9513!
9514 SUBROUTINE nucond &
9515 & (nx,ny,nz,na,jyslab &
9516 & ,nor,norz,dtp,nxi &
9517 & ,dz3d &
9518 & ,t0,t9 &
9519 & ,an,dn,p2 &
9520 & ,pn,w &
9521 & ,ngs &
9522 & ,axtra,io_flag &
9523 & ,ssfilt,t00,t77,flag_qndrop &
9524 & )
9525
9526
9527 implicit none
9528
9529! real :: cwmasn = 1000.*0.523599*(2.*2.e-6)**3
9530 integer :: nx,ny,nz,na,nxi
9531 integer :: nor,norz, jyslab ! ,nht,ngt,igsr
9532 real :: dtp ! time step
9533 logical :: flag_qndrop
9534
9535 integer, parameter :: ng1 = 1
9536
9537
9538!
9539! external temporary arrays
9540!
9541 real t00(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
9542 real t77(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
9543
9544 real t0(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
9545! real t1(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
9546! real t2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
9547! real t3(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
9548! real t4(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
9549! real t5(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
9550! real t6(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
9551! real t7(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
9552! real t8(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
9553 real t9(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
9554
9555
9556 real p2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) ! perturbation Pi
9557 real pn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
9558 real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na)
9559 real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
9560
9561 real w(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
9562! real qv(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
9563
9564 real ssfilt(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
9565
9566
9567 real pb(-norz+ng1:nz+norz)
9568 real pinit(-norz+ng1:nz+norz)
9569
9570 real dz3d(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
9571
9572
9573 ! local
9574
9575
9576 real axtra(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,nxtra)
9577 logical :: io_flag
9578
9579 real :: dv
9580 real :: ccnefactwo, sstmp, cn1, cnuctmp
9581
9582!
9583! declarations microphysics and for gather/scatter
9584!
9585 real, parameter :: cwmas30 = 1000.*0.523599*(2.*30.e-6)**3 ! mass of 30-micron radius droplet, for sat. adj.
9586 real, parameter :: cwmas20 = 1000.*0.523599*(2.*20.e-6)**3 ! mass of 20-micron radius droplet, for sat. adj.
9587 integer nxmpb,nzmpb,nxz
9588 integer mgs,ngs,numgs,inumgs
9589 integer ngscnt,igs(ngs),kgs(ngs)
9590 integer kgsp(ngs),kgsm(ngs)
9591 integer nsvcnt
9592
9593 integer ix,kz,i,n, kp1, km1
9594 integer :: jy, jgs
9595 integer ixb,ixe,jyb,jye,kzb,kze
9596
9597 integer itile,jtile,ktile
9598 integer ixend,jyend,kzend,kzbeg
9599 integer nxend,nyend,nzend,nzbeg
9600
9601!
9602! Variables for Ziegler warm rain microphysics
9603!
9604
9605
9606 real ccnc(ngs), ccna(ngs), cnuc(ngs), cwnccn(ngs)
9607 real :: ccnc_nu(ngs), ccnc_ac(ngs), ccnc_co(ngs)
9608 real ccncuf(ngs)
9609 real sscb ! 'cloud base' SS threshold
9610 parameter( sscb = 2.0 )
9611 integer idecss ! flag to turn on (=1) decay of ssmax when no cloud or ice crystals
9612 parameter( idecss = 1 )
9613 integer iba ! flag to do condensation/nucleation in 1st or 2nd loop
9614 ! =0 to use ad to calculate SS
9615 ! =1 to use an at end of main jy loop to calculate SS
9616 parameter(iba = 1)
9617 integer ifilt ! =1 to filter ssat, =0 to set ssfilt=ssat
9618 parameter( ifilt = 0 )
9619 real temp1,temp2 ! ,ssold
9620 real :: ssmax(ngs) ! maximum SS experienced by a parcel
9621 real ssmx
9622 real dnnet,dqnet
9623! real cnu,rnu,snu,cinu
9624! parameter ( cnu = 0.0, rnu = -0.8, snu = -0.8, cinu = 0.0 )
9625 real ventrx(ngs)
9626 real ventrxn(ngs)
9627 real volb, t2s
9628 real, parameter :: aa1 = 9.44e15, aa2 = 5.78e3 ! a1 in Ziegler
9629
9630 real ec0, ex1, ft, rhoinv(ngs)
9631
9632 real chw, g1, rd1
9633
9634 real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp2 ! , sstdy, super
9635 real tmpmx, fw, qctmp
9636 real x,y,del,r,alpr
9637 double precision :: vent1,vent2
9638 real g1palp
9639 real bs
9640 real v1, v2
9641 real d1r, d1i, d1s, e1i
9642 integer nc ! condensation step
9643 real dtcon,dtcon1,dtcon2 ! condensation time step (dtcon*nc = dtp)
9644 real delta
9645 integer ltemq1,ltemq1m ! ,ltemq1m2
9646 real dqv,qv1,ss1,ss2,qvs1,dqvs,dtemp,dt1 ! temporaries for condensation
9647
9648 real ssi1, ssi2, dqvi, dqvis, dqvii,qis1
9649 real dqvr, dqc, dqr, dqi, dqs
9650 real qv1m,qvs1m,ss1m,ssi1m,qis1m
9651 real cwmastmp
9652 real dcloud,dcloud2 ! ,as, bs
9653 real dcrit
9654 real cn(ngs), cnuf(ngs)
9655 real :: ccwmax
9656
9657 integer ltemq
9658
9659 integer il
9660
9661 real es(ngs) ! ss(ngs),
9662! real eis(ngs)
9663 real ssf(ngs),ssfkp1(ngs),ssfkm1(ngs),ssat0(ngs)
9664 real, parameter :: ssfcut = 4.0
9665 real ssfjp1(ngs),ssfjm1(ngs)
9666 real ssfip1(ngs),ssfim1(ngs)
9667
9668 real supcb, supmx
9669 parameter(supcb=0.5,supmx=238.0)
9670 real r2dxm, r2dym, r2dzm
9671 real dssdz, dssdy, dssdx
9672! real tqvcon
9673 real epsi,d
9674 parameter(epsi = 0.622, d = 0.266)
9675 real r1,qevap ! ,slv
9676
9677 real vr,nrx,qr,z1,z2,rdi,alp,xnutmp,xnuc
9678 real ctmp, ccwtmp
9679 real f5, qvs0 ! Kessler condensation factor
9680 real :: t0p1, t0p3
9681 real qvex
9682
9683! real, dimension(ngs) :: temp, tempc, elv, elf, els, pqs, theta, temg, temcg
9684 real dqvcnd(ngs),dqwv(ngs),dqcw(ngs),dqci(ngs)
9685 real temp(ngs),tempc(ngs)
9686 real temg(ngs),temcg(ngs),theta(ngs),qvap(ngs) ! ,tembzg(ngs)
9687 real temgx(ngs),temcgx(ngs)
9688 real qvs(ngs),qis(ngs),qss(ngs),pqs(ngs)
9689 real felv(ngs),felf(ngs),fels(ngs)
9690 real felvcp(ngs),felvpi(ngs)
9691 real gamw(ngs),gams(ngs) ! qciavl(ngs),
9692 real tsqr(ngs),ssi(ngs),ssw(ngs)
9693 real cc3(ngs),cqv1(ngs),cqv2(ngs)
9694 real qcwtmp(ngs),qtmp
9695
9696 real fvent(ngs) !,fraci(ngs),fracl(ngs)
9697 real fwvdf(ngs),ftka(ngs),fthdf(ngs)
9698 real fadvisc(ngs),fakvisc(ngs)
9699 real fci(ngs),fcw(ngs)
9700 real fschm(ngs),fpndl(ngs)
9701
9702 real pres(ngs),pipert(ngs)
9703 real pk(ngs)
9704 real rho0(ngs),pi0(ngs)
9705 real rhovt(ngs)
9706 real thetap(ngs),theta0(ngs),qwvp(ngs),qv0(ngs)
9707 real thsave(ngs)
9708 real qss0(ngs)
9709 real fcqv1(ngs)
9710 real wvel(ngs),wvelkm1(ngs)
9711
9712 real wvdf(ngs),tka(ngs)
9713 real advisc(ngs)
9714
9715 real rwvent(ngs)
9716
9717
9718 real :: qx(ngs,lv:lhab)
9719 real :: cx(ngs,lc:lhab)
9720 real :: xv(ngs,lc:lhab)
9721 real :: xmas(ngs,lc:lhab)
9722 real :: xdn(ngs,lc:lhab)
9723 real :: xdia(ngs,lc:lhab,3)
9724 real :: alpha(ngs,lc:lhab)
9725 real :: zx(ngs,lr:lhab)
9726
9727
9728 logical zerocx(lc:lqmx)
9729
9730 logical :: lprint
9731
9732 integer, parameter :: iunit = 0
9733
9734 real :: frac, hwdn, tmpg
9735
9736 real :: cvm,cpm,rmm
9737
9738 real, parameter :: cpv = 1885.0 ! specific heat of water vapor at constant pressure
9739
9740 integer :: kstag
9741
9742 integer :: count
9743
9744! -------------------------------------------------------------------------------
9745 itile = nxi
9746 jtile = ny
9747 ktile = nz
9748 ixend = nxi
9749 jyend = ny
9750 kzend = nz
9751 nxend = nxi + 1
9752 nyend = ny + 1
9753 nzend = nz
9754 kzbeg = 1
9755 nzbeg = 1
9756
9757 IF ( ac_opt > 0 ) ccnefactwo = (1.63e-3/(cck * beta(3./2., cck/2.)))**(1.0/(cck + 2.0))
9758 f5 = 237.3 * 17.27 * 2.5e6 / cp ! combined constants for rain condensation (Soong and Ogura 73)
9759
9760 jy = 1
9761 kstag = 0
9762 pb(:) = 0.0
9763 pinit(:) = 0.0
9764
9765 IF ( ipconc <= 1 .or. isedonly == 2 ) GOTO 2200
9766
9767!
9768! Ziegler nucleation
9769!
9770
9771! ssfilt(:,:,:) = 0.0
9772 ssmx = 0
9773 count = 0
9774
9775 do kz = 1,nz-kstag
9776 do ix = 1,nxi
9777
9778 temp1 = an(ix,jy,kz,lt)*t77(ix,jy,kz)
9779 t0(ix,jy,kz) = temp1
9780 ltemq = int( (temp1-163.15)/fqsat+1.5 )
9781 ltemq = min( nqsat, max(1,ltemq) )
9782
9783 c1 = t00(ix,jy,kz)*tabqvs(ltemq)
9784
9785 IF ( c1 > 0. ) THEN
9786 ssfilt(ix,jy,kz) = 100.*(an(ix,jy,kz,lv)/c1 - 1.0) ! from "new" values
9787 ENDIF
9788
9789 ENDDO
9790 ENDDO
9791
9792
9793!
9794! jy = 1 ! working on a 2d slab
9795!! VERY IMPORTANT: SET jgs = jy
9796
9797 jgs = jy
9798
9799!
9800!..Gather microphysics
9801!
9802 if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: Gather stage'
9803
9804 nxmpb = 1
9805 nzmpb = 1
9806 nxz = nxi*nz
9807 numgs = nxz/ngs + 1
9808
9809
9810 do 2000 inumgs = 1,numgs
9811
9812 ngscnt = 0
9813
9814
9815 kzb = nzmpb
9816 kze = nz-kstag
9817 ! if (kzbeg .le. nzmpb .and. kzend .gt. nzmpb) kzb = nzmpb
9818
9819 ixb = nxmpb
9820 ixe = itile
9821
9822 do kz = kzb,kze
9823 do ix = nxmpb,nxi
9824
9825 pqs(1) = 380.0/(pn(ix,jy,kz) + pb(kz))
9826 theta(1) = an(ix,jy,kz,lt)
9827 temg(1) = t0(ix,jy,kz)
9828
9829 temcg(1) = temg(1) - tfr
9830 ltemq = (temg(1)-163.15)/fqsat+1.5
9831 ltemq = min( nqsat, max(1,ltemq) )
9832 qvs(1) = pqs(1)*tabqvs(ltemq)
9833 qis(1) = pqs(1)*tabqis(ltemq)
9834
9835 qss(1) = qvs(1)
9836
9837
9838 if ( temg(1) .lt. tfr ) then
9839 end if
9840!
9841 if ( (temg(1) .gt. tfrh .or. an(ix,jy,kz,lv)/qvs(1) > maxlowtempss ) .and. &
9842 & ( an(ix,jy,kz,lv) .gt. qss(1) .or. &
9843 & an(ix,jy,kz,lc) .gt. qxmin(lc) .or. &
9844 & ( an(ix,jy,kz,lr) .gt. qxmin(lr) .and. rcond == 2 ) &
9845 & )) then
9846 ngscnt = ngscnt + 1
9847 igs(ngscnt) = ix
9848 kgs(ngscnt) = kz
9849 if ( ngscnt .eq. ngs ) goto 2100
9850 end if
9851
9852 end do !ix
9853
9854 nxmpb = 1
9855 end do !kz
9856! if ( jy .eq. (ny-jstag) ) iend = 1
9857 2100 continue
9858
9859 if ( ngscnt .eq. 0 ) go to 29998
9860
9861 if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: dbg = 8'
9862
9863! write(0,*) 'NUCOND: dbg = 8, ngscnt,ssmx = ',ngscnt,ssmx
9864
9865
9866 qx(:,:) = 0.0
9867 cx(:,:) = 0.0
9868 zx(:,:) = 0.0
9869
9870 xv(:,:) = 0.0
9871 xmas(:,:) = 0.0
9872
9873 IF ( imurain == 1 ) THEN
9874 alpha(:,lr) = alphar
9875 ELSEIF ( imurain == 3 ) THEN
9876 alpha(:,lr) = xnu(lr)
9877 ENDIF
9878
9879!
9880! define temporaries for state variables to be used in calculations
9881!
9882 DO mgs = 1,ngscnt
9883 qx(mgs,lv) = an(igs(mgs),jy,kgs(mgs),lv)
9884 DO il = lc,lhab
9885 qx(mgs,il) = max(an(igs(mgs),jy,kgs(mgs),il), 0.0)
9886 ENDDO
9887
9888 qcwtmp(mgs) = qx(mgs,lc)
9889
9890
9891 theta0(mgs) = an(igs(mgs),jy,kgs(mgs),lt) !
9892 thetap(mgs) = 0.0
9893 theta(mgs) = an(igs(mgs),jy,kgs(mgs),lt)
9894 qv0(mgs) = qx(mgs,lv)
9895 qwvp(mgs) = qx(mgs,lv) - qv0(mgs)
9896
9897 pres(mgs) = pn(igs(mgs),jy,kgs(mgs)) + pb(kgs(mgs))
9898 pipert(mgs) = p2(igs(mgs),jy,kgs(mgs))
9899 rho0(mgs) = dn(igs(mgs),jy,kgs(mgs))
9900 rhoinv(mgs) = 1.0/rho0(mgs)
9901 rhovt(mgs) = sqrt(rho00/rho0(mgs))
9902 pi0(mgs) = p2(igs(mgs),jy,kgs(mgs)) + pinit(kgs(mgs))
9903 temg(mgs) = t0(igs(mgs),jy,kgs(mgs))
9904! pk(mgs) = t77(igs(mgs),jy,kgs(mgs)) ! ( pres(mgs) / poo ) ** cap
9905 pk(mgs) = p2(igs(mgs),jy,kgs(mgs)) + pinit(kgs(mgs)) ! t77(igs(mgs),jy,kgs(mgs))
9906 temcg(mgs) = temg(mgs) - tfr
9907 qss0(mgs) = (380.0)/(pres(mgs))
9908 pqs(mgs) = (380.0)/(pres(mgs))
9909 ltemq = (temg(mgs)-163.15)/fqsat+1.5
9910 ltemq = min( nqsat, max(1,ltemq) )
9911 qvs(mgs) = pqs(mgs)*tabqvs(ltemq)
9912 qis(mgs) = pqs(mgs)*tabqis(ltemq)
9913!
9914 qvap(mgs) = max( (qwvp(mgs) + qv0(mgs)), 0.0 )
9915 es(mgs) = 6.1078e2*tabqvs(ltemq)
9916 qss(mgs) = qvs(mgs)
9917
9918
9919 temgx(mgs) = min(temg(mgs),313.15)
9920 temgx(mgs) = max(temgx(mgs),233.15)
9921 felv(mgs) = 2500837.367 * (273.15/temgx(mgs))**((0.167)+(3.67e-4)*temgx(mgs))
9922!
9923 IF ( eqtset <= 1 ) THEN
9924 felvcp(mgs) = felv(mgs)*cpi
9925 ELSE ! equation set 2 in cm1
9926 tmp = qx(mgs,li)+qx(mgs,ls)+qx(mgs,lh)
9927 IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl)
9928 IF ( lf > 1 ) tmp = tmp + qx(mgs,lf)
9929 cvm = cv+cvv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) &
9930 +cpigb*(tmp)
9931 cpm = cp+cpv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) &
9932 +cpigb*(tmp)
9933 rmm=rd+rw*qx(mgs,lv)
9934
9935 IF ( eqtset == 2 ) THEN
9936
9937 felvcp(mgs) = (felv(mgs)-rw*temg(mgs))/cvm
9938
9939 ELSE
9940 felvcp(mgs) = (felv(mgs)*cv/(cp) - rw*temg(mgs)*(1.0-rovcp*cpm/rmm))/cvm
9941 felvpi(mgs) = pi0(mgs)*rovcp*(felv(mgs)/(temg(mgs)) - rw*cpm/rmm)/cvm
9942 ENDIF
9943
9944 ENDIF
9945
9946 temcgx(mgs) = min(temg(mgs),273.15)
9947 temcgx(mgs) = max(temcgx(mgs),223.15)
9948 temcgx(mgs) = temcgx(mgs)-273.15
9949 felf(mgs) = 333690.6098 + (2030.61425)*temcgx(mgs) - (10.46708312)*temcgx(mgs)**2
9950!
9951 fels(mgs) = felv(mgs) + felf(mgs)
9952 fcqv1(mgs) = 4098.0258*felv(mgs)*cpi
9953
9954 wvdf(mgs) = (2.11e-05)*((temg(mgs)/tfr)**1.94)* &
9955 & (101325.0/(pb(kgs(mgs)) + pn(igs(mgs),jgs,kgs(mgs)))) ! diffusivity of water vapor, Hall and Pruppacher (76)
9956 advisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))* &
9957 & (temg(mgs)/296.0)**(1.5) ! dynamic viscosity (SMT; see Beard & Pruppacher 71)
9958 tka(mgs) = tka0*advisc(mgs)/advisc1 ! thermal conductivity
9959
9960
9961 ENDDO
9962
9963
9964
9965!
9966! load concentrations
9967!
9968 if ( ipconc .ge. 1 ) then
9969 do mgs = 1,ngscnt
9970 cx(mgs,li) = max(an(igs(mgs),jy,kgs(mgs),lni), 0.0)
9971 end do
9972 end if
9973 if ( ipconc .ge. 2 ) then
9974 do mgs = 1,ngscnt
9975 cx(mgs,lc) = max(an(igs(mgs),jy,kgs(mgs),lnc), 0.0)
9976 cwnccn(mgs) = cwccn*rho0(mgs)/rho00 ! background ccn count
9977 cn(mgs) = 0.0
9978 IF ( lss > 1 ) THEN
9979 ssmax(mgs) = an(igs(mgs),jy,kgs(mgs),lss)
9980 ELSE
9981 ssmax(mgs) = 0.0
9982 ENDIF
9983 IF ( lccn .gt. 1 .and. ac_opt == 0 ) THEN
9984 IF ( lccnuf .gt. 1 .and. i_uf_or_ccn > 0 ) THEN
9985 ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) + an(igs(mgs),jy,kgs(mgs),lccnuf)
9986 ELSE
9987 ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn)
9988 ENDIF
9989 ELSE
9990 ccnc(mgs) = cwnccn(mgs)
9991 ENDIF
9992 IF ( lccnuf .gt. 1 .and. i_uf_or_ccn == 0 ) THEN
9993 ccncuf(mgs) = an(igs(mgs),jy,kgs(mgs),lccnuf)
9994 ELSE
9995 ccncuf(mgs) = 0.0
9996 ENDIF
9997 cnuf(mgs) = 0.0
9998 IF ( lccna > 1 ) THEN
9999 ccna(mgs) = an(igs(mgs),jy,kgs(mgs),lccna) ! predicted count of activated ccn
10000 ELSE
10001 IF ( lccn > 1 ) THEN
10002 ccna(mgs) = cwnccn(mgs) - ccnc(mgs) ! diagnose activated ccn as background value - remaining unactivated ccn
10003 ELSE
10004 ccna(mgs) = cx(mgs,lc) ! approximation of number of activated ccn
10005 ENDIF
10006 ENDIF
10007 end do
10008 end if
10009 if ( ipconc .ge. 3 ) then
10010 do mgs = 1,ngscnt
10011 cx(mgs,lr) = max(an(igs(mgs),jy,kgs(mgs),lnr), 0.0)
10012 end do
10013 end if
10014
10015! cnuc(1:ngscnt) = cwccn*rho0(mgs)/rho00*(1. - renucfrac) + ccnc(1:ngscnt)*renucfrac
10016 DO mgs = 1,ngscnt
10017 ! default value of renucfrac is 0.0
10018 IF ( irenuc /= 6 ) THEN
10019 cnuc(mgs) = max(ccnc(mgs),cwnccn(mgs))*(1. - renucfrac) + ccnc(mgs)*renucfrac
10020 ELSE
10021 cnuc(mgs) = max(ccnc(mgs),cwnccn(mgs))*(1. - renucfrac) + max(0.0,ccnc(mgs) - ccna(mgs))*renucfrac
10022 ENDIF
10023 IF ( renucfrac >= 0.999 ) THEN
10024 IF ( temg(mgs) < 265. ) THEN
10025 IF ( qx(mgs,lc) > 10.*qxmin(lc) .and. w(igs(mgs),jgs,kgs(mgs)) > 2.0 ) THEN
10026 cnuc(mgs) = 0.0 ! Min(cnuc(mgs), 0.5*cx(mgs,lc) ) ! Hack to reduce nucleation at low temp in updraft when ccn are not predicted
10027 ELSE
10028 cnuc(mgs) = 0.1*cnuc(mgs)
10029 ENDIF
10030 ENDIF
10031 ENDIF
10032 ENDDO
10033
10034! Set density
10035!
10036 if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: Set density'
10037
10038 do mgs = 1,ngscnt
10039 xdn(mgs,lc) = xdn0(lc)
10040 xdn(mgs,lr) = xdn0(lr)
10041 end do
10042
10043 ventrx(:) = ventr
10044 ventrxn(:) = ventrn
10045
10046
10047! Find shape parameter rain
10048
10049 IF ( lzr > 1 .and. rcond == 2 ) THEN ! { RAIN SHAPE PARAM
10050 DO mgs = 1,ngscnt
10051 zx(mgs,lr) = max(an(igs(mgs),jy,kgs(mgs),lzr), 0.0)
10052 ENDDO
10053
10054! CALL cld_cpu('Z-MOMENT-1r2')
10055 il = lr
10056 DO mgs = 1,ngscnt
10057
10058 IF ( zx(mgs,il) <= zxmin ) THEN
10059 qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il)
10060 qx(mgs,il) = 0.0
10061 cx(mgs,il) = 0.0
10062 an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
10063 an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
10064 an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
10065 ELSEIF ( cx(mgs,il) <= 0.0 ) THEN
10066 qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il)
10067 zx(mgs,il) = 0.0
10068 qx(mgs,il) = 0.0
10069 an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
10070 an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
10071 an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
10072 ENDIF
10073
10074 IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN
10075
10076 xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*max(1.0e-11,cx(mgs,lr)))
10077 IF ( xv(mgs,lr) .gt. xvmx(lr) ) THEN
10078 xv(mgs,lr) = xvmx(lr)
10079 cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmx(lr)*xdn(mgs,lr))
10080 ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN
10081 xv(mgs,lr) = xvmn(lr)
10082 cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr))
10083 ENDIF
10084
10085 IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN
10086! have mass and reflectivity but no concentration, so set concentration, using default alpha
10087 IF ( imurain == 3 ) THEN
10088 g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
10089 z1 = zx(mgs,il)
10090 qr = qx(mgs,il)
10091 cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z1*1000.*1000)
10092 ELSE
10093 g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
10094 & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2)
10095 z1 = zx(mgs,il)
10096 qr = qx(mgs,il)
10097 cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z1*1000.*1000)
10098
10099 ENDIF
10100! an(igs(mgs),jgs,kgs(mgs),ln(il)) = zx(mgs,il)
10101 ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > 0.0 ) THEN
10102! have mass and concentration but no reflectivity, so set reflectivity, using default alpha
10103 IF ( imurain == 3 ) THEN
10104 g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
10105 chw = cx(mgs,il)
10106 qr = qx(mgs,il)
10107 zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(chw*1000.*1000)
10108 ELSE
10109 g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
10110 & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2)
10111 chw = cx(mgs,il)
10112 qr = qx(mgs,il)
10113 zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(chw*1000.*1000)
10114
10115 ENDIF
10116
10117 ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN
10118! How did this happen?
10119 ! set values according to dBZ of -10, or Z = 0.1
10120! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2
10121 zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2
10122 an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
10123
10124 IF ( imurain == 3 ) THEN
10125 g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
10126 z1 = zx(mgs,il)
10127 qr = qx(mgs,il)
10128 cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z1*1000.*1000)
10129 an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
10130 ELSEIF ( imurain == 1 ) THEN
10131 g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
10132 & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
10133 z1 = zx(mgs,il)
10134 qr = qx(mgs,il)
10135 cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(z1*(pi*xdn(mgs,il))**2)
10136 an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
10137
10138 ENDIF
10139 ENDIF
10140
10141 IF ( zx(mgs,lr) > 0.0 ) THEN
10142 vr = rho0(mgs)*qx(mgs,lr)/(1000.*cx(mgs,lr))
10143! z1 = 36.*(alpha(kz)+2.0)*a(ix,jy,kz,lnr)*vr**2/((alpha(kz)+1.0)*pi**2)
10144 qr = qx(mgs,lr)
10145 nrx = cx(mgs,lr)
10146 z1 = zx(mgs,lr)
10147
10148! xv = (db(1,kz)*a(1,1,kz,lr))**2/(a(1,1,kz,lnr))
10149! rd = z1*(pi/6.*1000.)**2/xv
10150
10151
10152! determine shape parameter alpha by iteration
10153 IF ( z1 .gt. 0.0 ) THEN
10154
10155 IF ( imurain == 3 ) THEN
10156 alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z1*pi**2) - 1.
10157! write(0,*) 'kz, alp, alpha(kz) = ',kz,alp,alpha(kz),rd,z1,xv
10158 DO i = 1,20
10159 IF ( abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT
10160 alpha(mgs,lr) = max( rnumin, min( rnumax, alp ) )
10161 alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z1*pi**2) - 1.
10162! write(0,*) 'i,alp = ',i,alp
10163 alp = max( rnumin, min( rnumax, alp ) )
10164 ENDDO
10165
10166 ELSE ! imurain == 1
10167 g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
10168 & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2)
10169
10170 rd1 = z1*(pi/6.*xdn(mgs,il))**2*nrx/(rho0(mgs)*qr)**2
10171
10172 alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
10173 & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd1) - 1.0
10174
10175 DO i = 1,10
10176 IF ( abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT
10177 alpha(mgs,il) = max( alphamin, min( alphamax, alp ) )
10178
10179 alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
10180 & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd1) - 1.0
10181
10182 alp = max( alphamin, min( alphamax, alp ) )
10183 ENDDO
10184
10185
10186 ENDIF
10187! ENDIF
10188
10189!
10190! Check whether the shape parameter is at or less than the minimum, and if it is, reset the
10191! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N)
10192!
10193 IF ( imurain == 3 ) THEN
10194 IF ( .true. .and. (alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax) ) THEN
10195
10196 IF ( rescale_high_alpha .and. alp >= rnumax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z
10197 g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
10198 cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z1*(1./(xdn(mgs,il)))**2
10199 an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il)
10200
10201 ELSEIF ( rescale_low_alphar .and. alp <= rnumin ) THEN
10202
10203 z1 = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2)
10204 zx(mgs,il) = z1
10205 ENDIF
10206 ENDIF
10207
10208 ELSEIF ( imurain == 1 ) THEN
10209
10210 g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
10211 & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
10212
10213 IF ( (rescale_low_alpha .or. rescale_high_alpha ) .and. &
10214 & ( alpha(mgs,il) <= alphamin .or. alp == alphamin .or. alp == alphamax ) ) THEN
10215
10216
10217
10218 IF ( rescale_high_alpha .and. alp >= alphamax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z
10219 cx(mgs,il) = g1*rho0(mgs)**2*(qr)*qr/zx(mgs,lr)*(6./(pi*xdn(mgs,il)))**2
10220 an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il)
10221
10222 ELSEIF ( rescale_low_alpha .and. alp <= alphamin ) THEN ! alpha = alphamin, so reset Z to prevent growth in C
10223 z1 = g1*rho0(mgs)**2*(qr)*qr/nrx
10224 z2 = z1*(6./(pi*xdn(mgs,il)))**2
10225 zx(mgs,il) = z2
10226 an(igs(mgs),jy,kgs(mgs),lz(il)) = z2
10227 ENDIF
10228 ENDIF ! imurain
10229
10230 ENDIF ! z > 0
10231
10232 tmp = alpha(mgs,lr) + 4./3.
10233 i = int(dgami*(tmp))
10234 del = tmp - dgam*i
10235 x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
10236
10237 tmp = alpha(mgs,lr) + 1.
10238 i = int(dgami*(tmp))
10239 del = tmp - dgam*i
10240 y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
10241
10242! ventrx(mgs) = Gamma(alpha(mgs,lr) + 4./3.)/(alpha(mgs,lr) + 1.)**(1./3.)/Gamma(alpha(mgs,lr) + 1.)
10243 ventrx(mgs) = x/(y*(alpha(mgs,lr) + 1.)**(1./3.))
10244
10245 IF ( imurain == 3 .and. izwisventr == 2 ) THEN
10246
10247 tmp = alpha(mgs,lr) + 1.5 + br/6.
10248 i = int(dgami*(tmp))
10249 del = tmp - dgam*i
10250 x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
10251
10252! ventrx(mgs) = Gamma(alpha(mgs,lr) + 1.5 + br/6.)/Gamma(alpha(mgs,lr) + 1.)
10253 ventrxn(mgs) = x/(y*(alpha(mgs,lr) + 1.)**((1.+br)/6. + 1./3.))
10254
10255 ELSEIF ( imurain == 1 .and. iferwisventr == 2 ) THEN
10256
10257 tmp = alpha(mgs,lr) + 2.5 + br/2.
10258 i = int(dgami*(tmp))
10259 del = tmp - dgam*i
10260 x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
10261
10262! ventrx(mgs) = Gamma(alpha(mgs,lr) + 1.5 + br/6.)/Gamma(alpha(mgs,lr) + 1.)
10263 ventrxn(mgs) = x/y
10264
10265
10266 ENDIF
10267
10268
10269 ENDIF
10270 ENDIF
10271
10272 ENDIF
10273
10274 ENDDO
10275! CALL cld_cpu('Z-MOMENT-1r2')
10276 ENDIF ! }
10277
10278
10279! write(0,*) 'NUCOND: Set ssf variables, ssmxinit =',ssmxinit
10280 ssmx = 0.0
10281 DO mgs = 1,ngscnt
10282
10283 kp1 = min(nz, kgs(mgs)+1 )
10284 wvel(mgs) = (0.5)*(w(igs(mgs),jgs,kp1) &
10285 & +w(igs(mgs),jgs,kgs(mgs)))
10286 wvelkm1(mgs) = (0.5)*(w(igs(mgs),jgs,kgs(mgs)) &
10287 & +w(igs(mgs),jgs,max(1,kgs(mgs)-1)))
10288
10289 ssat0(mgs) = ssfilt(igs(mgs),jgs,kgs(mgs))
10290 ssf(mgs) = ssfilt(igs(mgs),jgs,kgs(mgs))
10291! ssmx = Max( ssmx, ssf(mgs) )
10292
10293
10294 ssfkp1(mgs) = ssfilt(igs(mgs),jgs,min(nz-1,kgs(mgs)+1))
10295 ssfkm1(mgs) = ssfilt(igs(mgs),jgs,max(1,kgs(mgs)-1))
10296
10297! IF ( wvel(mgs) /= 0.0 ) write(0,*) 'mgs,wvel1,ssf = ',mgs,wvel(mgs),ssf(mgs)
10298
10299
10300 ENDDO
10301
10302
10303
10304!
10305! cloud water variables
10306!
10307
10308 if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: Set cloud water variables'
10309
10310 do mgs = 1,ngscnt
10311 xv(mgs,lc) = 0.0
10312 IF ( ipconc .ge. 2 .and. cx(mgs,lc) .gt. 1.0e6 ) THEN
10313 xmas(mgs,lc) = &
10314 & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx )
10315 xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc)
10316 ELSE
10317 IF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. cxmin ) THEN
10318 xmas(mgs,lc) = &
10319 & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),xdn(mgs,lc)*xvmn(lc)), &
10320 & xdn(mgs,lc)*xvmx(lc) )
10321
10322 cx(mgs,lc) = qx(mgs,lc)*rho0(mgs)/xmas(mgs,lc)
10323
10324 ELSEIF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .le. cxmin ) THEN
10325! xmas(mgs,lc) = xdn(mgs,lc)*4.*pi/3.*(5.0e-6)**3
10326! cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc)
10327 cx(mgs,lc) = max( cxmin, rho0(mgs)*qx(mgs,lc)/cwmasx )
10328 xmas(mgs,lc) = &
10329 & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx )
10330 xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc)
10331
10332 ELSE
10333 xmas(mgs,lc) = cwmasn
10334 ENDIF
10335 ENDIF
10336 xdia(mgs,lc,1) = (xmas(mgs,lc)*cwc1)**c1f3
10337
10338
10339 end do
10340!
10341! rain
10342!
10343 do mgs = 1,ngscnt
10344 if ( qx(mgs,lr) .gt. qxmin(lr) ) then
10345
10346 if ( ipconc .ge. 3 ) then
10347 xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*max(1.0e-9,cx(mgs,lr)))
10348! parameter( xvmn(lr)=2.8866e-13, xvmx(lr)=4.1887e-9 ) ! mks
10349 IF ( xv(mgs,lr) .gt. xvmx(lr) ) THEN
10350 xv(mgs,lr) = xvmx(lr)
10351 cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmx(lr)*xdn(mgs,lr))
10352 ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN
10353 xv(mgs,lr) = xvmn(lr)
10354 cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr))
10355 ENDIF
10356
10357 xmas(mgs,lr) = xv(mgs,lr)*xdn(mgs,lr)
10358 xdia(mgs,lr,3) = (xmas(mgs,lr)*cwc1)**(1./3.) ! xdia(mgs,lr,1)
10359 IF ( imurain == 3 ) THEN
10360! xdia(mgs,lr,1) = (6.*pii*xv(mgs,lr)/(alpha(mgs,lr)+1.))**(1./3.)
10361 xdia(mgs,lr,1) = xdia(mgs,lr,3) ! formulae for Ziegler (1985) use mean volume diameter, not lambda**(-1)
10362 ELSE ! imurain == 1, Characteristic diameter (1/lambda)
10363 xdia(mgs,lr,1) = (6.*piinv*xv(mgs,lr)/((alpha(mgs,lr)+3.)*(alpha(mgs,lr)+2.)*(alpha(mgs,lr)+1.)))**(1./3.)
10364 ENDIF
10365! rwrad(mgs) = 0.5*xdia(mgs,lr,1)
10366
10367! Inverse exponential version:
10368! xdia(mgs,lr,1) =
10369! > (qx(mgs,lr)*rho0(mgs)
10370! > /(pi*xdn(mgs,lr)*cx(mgs,lr)))**(0.333333)
10371 ELSE
10372 xdia(mgs,lr,1) = &
10373 & (qx(mgs,lr)*rho0(mgs)/(pi*xdn(mgs,lr)*cno(lr)))**(0.25)
10374 end if
10375 else
10376 xdia(mgs,lr,1) = 1.e-9
10377! rwrad(mgs) = 0.5*xdia(mgs,lr,1)
10378 end if
10379
10380 end do
10381
10382
10383!
10384! Ventilation coefficients
10385
10386 do mgs = 1,ngscnt
10387
10388
10389 fadvisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))* &
10390 & (temg(mgs)/296.0)**(1.5)
10391
10392 fakvisc(mgs) = fadvisc(mgs)*rhoinv(mgs)
10393
10394 fwvdf(mgs) = (2.11e-05)*((temg(mgs)/tfr)**1.94)* &
10395 & (101325.0/(pres(mgs)))
10396
10397 fschm(mgs) = (fakvisc(mgs)/fwvdf(mgs))
10398
10399 fvent(mgs) = (fschm(mgs)**(1./3.)) * (fakvisc(mgs)**(-0.5))
10400
10401 end do
10402!
10403!
10404! Ziegler nucleation
10405!
10406!
10407! cloud evaporation, condensation, and nucleation
10408! sqsat -> qss(mgs)
10409
10410 DO mgs=1,ngscnt
10411 dcloud = 0.0
10412 ! Skip points at low temperature if SS stays less than 1.08,
10413 ! otherwise allow nucleation at low temp (will freeze at next time step)
10414 IF ( temg(mgs) .le. tfrh .and. qx(mgs,lv)/qvs(mgs) < maxlowtempss ) THEN
10415 cycle
10416 ENDIF
10417
10418 IF( ssat0(mgs) .GT. 0. .OR. ssf(mgs) .GT. 0. ) GO TO 620
10419!6/4 IF( qvap(mgs) .EQ. qss(mgs) ) GO TO 631
10420!
10421!.... EVAPORATION. QV IS LESS THAN qss(mgs).
10422!.... EVAPORATE CLOUD FIRST
10423!
10424 IF ( qx(mgs,lc) .LE. 0. ) GO TO 631
10425!.... CLOUD EVAPORATION.
10426! convert input 'cp' to cgs
10427 r1=1./(1. + caw*(273.15 - cbw)*qss(mgs)*felv(mgs)/ &
10428 & (cp*(temg(mgs) - cbw)**2))
10429 qevap= min( qx(mgs,lc), r1*(qss(mgs)-qvap(mgs)) )
10430
10431
10432 IF ( qx(mgs,lc) <= qevap ) THEN ! GO TO 63
10433 qwvp(mgs) = qwvp(mgs) + qx(mgs,lc)
10434 thetap(mgs) = thetap(mgs) - felvcp(mgs)*qx(mgs,lc)/(pi0(mgs))
10435 IF ( io_flag .and. nxtra > 1 ) THEN
10436 axtra(igs(mgs),jy,kgs(mgs),1) = -qx(mgs,lc)/dtp
10437 ENDIF
10438 qx(mgs,lc) = 0.
10439 IF ( restoreccn ) THEN
10440 IF ( lccna > 1 ) THEN
10441 ccna(mgs) = ccna(mgs) - restoreccnfrac*cx(mgs,lc)
10442 ELSEIF ( irenuc <= 2 ) THEN
10443 IF ( .not. invertccn ) THEN
10444 ccnc(mgs) = max( ccnc(mgs), min( qccn*rho0(mgs), ccnc(mgs) + restoreccnfrac*cx(mgs,lc) ) )
10445 ELSE
10446 ccnc(mgs) = ccnc(mgs) + restoreccnfrac*cx(mgs,lc)
10447 ENDIF
10448 ENDIF
10449 ENDIF
10450 cx(mgs,lc) = 0.
10451 ELSE
10452 qctmp = qx(mgs,lc)
10453 qwvp(mgs) = qwvp(mgs) + qevap
10454 qx(mgs,lc) = qx(mgs,lc) - qevap
10455 IF ( qx(mgs,lc) .le. 0. ) THEN
10456 IF ( restoreccn ) THEN
10457 IF ( lccna > 1 ) THEN
10458 ccna(mgs) = ccna(mgs) - restoreccnfrac*cx(mgs,lc)
10459 ELSEIF ( irenuc <= 2 ) THEN
10460! ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) )
10461! ccnc(mgs) = ccnc(mgs) + cx(mgs,lc)
10462 IF ( .not. invertccn ) THEN
10463 ccnc(mgs) = max( ccnc(mgs), min( qccn*rho0(mgs), ccnc(mgs) + restoreccnfrac*cx(mgs,lc) ) )
10464 ELSE
10465 ccnc(mgs) = ccnc(mgs) + restoreccnfrac*cx(mgs,lc)
10466 ENDIF
10467 ENDIF
10468 ENDIF
10469 cx(mgs,lc) = 0.
10470 ELSE
10471 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
10472 IF ( restoreccn ) THEN
10473 IF ( lccna > 1 ) THEN
10474 ccna(mgs) = ccna(mgs) - restoreccnfrac*tmp
10475 ELSEIF ( irenuc <= 2 ) THEN
10476 ! ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + tmp ) )
10477! ccnc(mgs) = ccnc(mgs) + tmp
10478 IF ( .not. invertccn ) THEN
10479 ccnc(mgs) = max( ccnc(mgs), min( qccn*rho0(mgs), ccnc(mgs) + restoreccnfrac*tmp ) )
10480 ELSE
10481 ccnc(mgs) = ccnc(mgs) + restoreccnfrac*tmp
10482 ENDIF
10483 ENDIF
10484 ENDIF
10485 cx(mgs,lc) = cx(mgs,lc) - tmp
10486 ENDIF
10487 thetap(mgs) = thetap(mgs) - felvcp(mgs)*qevap/(pi0(mgs))
10488 IF ( io_flag .and. nxtra > 1 ) THEN
10489 axtra(igs(mgs),jy,kgs(mgs),1) = -qevap/dtp
10490 ENDIF
10491
10492 ENDIF
10493
10494 GO TO 631
10495
10496
10497 620 CONTINUE
10498
10499!.... CLOUD CONDENSATION
10500
10501 IF ( qx(mgs,lc) .GT. qxmin(lc) .and. cx(mgs,lc) .ge. 1. ) THEN
10502
10503
10504
10505! ac1 = xdn(mgs,lc)*elv(kgs(mgs))**2*epsi/
10506! : (tka(kgs(mgs))*rw*temg(mgs)**2)
10507! took out xdn factor because it cancels later...
10508 ac1 = felv(mgs)**2/(tka(mgs)*rw*temg(mgs)**2)
10509
10510
10511! bc = xdn(mgs,lc)*rw*temg(mgs)/
10512! : (epsi*wvdf(kgs(mgs))*es(mgs))
10513! took out xdn factor because it cancels later...
10514 bc = rw*temg(mgs)/(wvdf(mgs)*es(mgs))
10515
10516! bs = rho0(mgs)*((rd*temg(mgs)/(epsi*es(mgs)))+
10517! : (epsi*elv(kgs(mgs))**2/(pres(mgs)*temg(mgs)*cp)))
10518
10519! taus = Min(dtp, xdn(mgs,lc)*rho0(mgs)*(ac1+bc)/
10520! : (4*pi*0.89298*BS*0.5*xdia(mgs,lc,1)*cx(mgs,lc)*xdn(mgs,lc)))
10521
10522!
10523 IF ( ssf(mgs) .gt. 0.0 .or. ssat0(mgs) .gt. 0.0 ) THEN
10524 IF ( ny .le. 2 ) THEN
10525! write(0,*) 'undershoot: ',ssf(mgs),
10526! : ( (qx(mgs,lv) - dcloud)/c1 - 1.0)*100.
10527 ENDIF
10528
10529
10530
10531 IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN
10532
10533 IF ( xdia(mgs,lc,1) .le. 0.0 ) THEN
10534 xmas(mgs,lc) = cwmasn
10535 xdia(mgs,lc,1) = (xmas(mgs,lc)*cwc1)**c1f3
10536 ENDIF
10537 d1 = (1./(ac1 + bc))*4.0*pi*ventc &
10538 & *0.5*xdia(mgs,lc,1)*cx(mgs,lc)*rhoinv(mgs)
10539
10540 ELSE
10541 d1 = 0.0
10542 ENDIF
10543
10544 IF ( rcond .eq. 2 .and. qx(mgs,lr) .gt. qxmin(lr) .and. cx(mgs,lr) > 1.e-9 ) THEN
10545 IF ( imurain == 3 ) THEN
10546 IF ( izwisventr == 1 ) THEN
10547 rwvent(mgs) = ventrx(mgs)*(1.6 + 124.9*(1.e-3*rho0(mgs)*qx(mgs,lr))**.2046)
10548 ELSE ! izwisventr = 2
10549! Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br
10550 rwvent(mgs) = &
10551 & (0.78*ventrx(mgs) + 0.308*ventrxn(mgs)*fvent(mgs) &
10552 & *sqrt((ar*rhovt(mgs))) &
10553 & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) )
10554 ENDIF
10555
10556 ELSE ! imurain == 1
10557
10558 IF ( iferwisventr == 1 ) THEN
10559 alpr = min(alpharmax,alpha(mgs,lr) )
10560! alpr = alpha(mgs,lr)
10561 x = 1. + alpr
10562
10563 tmp = 1 + alpr
10564 i = int(dgami*(tmp))
10565 del = tmp - dgam*i
10566 g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
10567
10568 tmp = 2.5 + alpr + 0.5*bx(lr)
10569 i = int(dgami*(tmp))
10570 del = tmp - dgam*i
10571 y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp ! ratio of gamma functions
10572
10573! vent1 = dble(xdia(mgs,lr,1))**(-2. - alpr) ! Actually OK
10574! vent2 = dble(1./xdia(mgs,lr,1) + 0.5*fx(lr))**dble(2.5+alpr+0.5*bx(lr)) ! Actually OK
10575 vent1 = dble(xdia(mgs,lr,1))**(0.5 + 0.5*bx(lr)) ! 2016.2.26 Changed for consistency with derivation (recast formula)
10576 vent2 = dble(1. + 0.5*fx(lr)*xdia(mgs,lr,1))**dble(2.5+alpr+0.5*bx(lr))
10577
10578
10579 rwvent(mgs) = &
10580 & 0.78*x + &
10581 & 0.308*fvent(mgs)*y* &
10582 & sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2)
10583
10584 ELSEIF ( iferwisventr == 2 ) THEN
10585
10586! Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br
10587 x = 1. + alpha(mgs,lr)
10588
10589 rwvent(mgs) = &
10590 & (0.78*x + 0.308*ventrxn(mgs)*fvent(mgs) &
10591 & *sqrt((ar*rhovt(mgs))) &
10592 & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) )
10593
10594
10595 ENDIF ! iferwisventr
10596
10597 ENDIF ! imurain
10598
10599 d1r = (1./(ac1 + bc))*4.0*pi*rwvent(mgs) &
10600 & *0.5*xdia(mgs,lr,1)*cx(mgs,lr)*rhoinv(mgs)
10601 ELSE
10602 d1r = 0.0
10603 ENDIF
10604
10605
10606 e1 = felvcp(mgs)/(pi0(mgs))
10607 f1 = pk(mgs) ! (pres(mgs)/poo)**cap
10608
10609!
10610! fifth trial to see what happens:
10611!
10612 ltemq = (temg(mgs)-163.15)/fqsat+1.5
10613 ltemq = min( nqsat, max(1,ltemq) )
10614 ltemq1 = ltemq
10615 temp1 = temg(mgs)
10616 p380 = 380.0/pres(mgs)
10617
10618! taus = Max( 0.05*dtp, Min(taus, 0.25*dtp ) )
10619! nc = NInt(dtp/Min(1.0,0.5*taus))
10620! dtcon = dtp/float(nc)
10621 ss1 = qx(mgs,lv)/qvs(mgs)
10622 ss2 = ss1
10623 temp2 = temp1
10624 qv1 = qx(mgs,lv)
10625 qvs1 = qvs(mgs)
10626 qis1 = qis(mgs)
10627 dt1 = 0.0
10628
10629
10630! dtcon = Max(dtcon,0.2)
10631! nc = Nint(dtp/dtcon)
10632
10633 ltemq1 = ltemq
10634! want to start out with a small time step to handle the steep slope
10635! and fast changes, then can switch to a larger step (dtcon2) for the
10636! rest of the big time step.
10637! base the initial time step (dtcon1) on the slope (delta)
10638 IF ( abs(ss1 - 1.0) .gt. 1.e-5 ) THEN
10639 delta = 0.5*(qv1-qvs1)/(d1*(ss1 - 1.0))
10640 ELSE
10641 delta = 0.1*dtp
10642 ENDIF
10643! delta is the extrapolated time to get halfway from qv1 to qvs1
10644! want at least 5 time steps to the halfway point, so multiply by 0.2
10645! for the initial time step
10646 dtcon1 = min(0.05,0.2*delta)
10647 nc = max(5,2*nint( (dtp-4.0*dtcon1)/delta))
10648 dtcon2 = (dtp-4.0*dtcon1)/nc
10649
10650 n = 1
10651 dt1 = 0.0
10652 nc = 0
10653 dqc = 0.0
10654 dqr = 0.0
10655 dqi = 0.0
10656 dqs = 0.0
10657 dqvii = 0.0
10658 dqvis = 0.0
10659
10660 rk2c: DO WHILE ( dt1 .lt. dtp )
10661 nc = 0
10662 IF ( n .le. 4 ) THEN
10663 dtcon = dtcon1
10664 ELSE
10665 dtcon = dtcon2
10666 ENDIF
10667 609 dqv = -(ss1 - 1.)*d1*dtcon
10668 dqvr = -(ss1 - 1.)*d1r*dtcon
10669 dtemp = -0.5*e1*f1*(dqv + dqvr)
10670! write(0,*) 'RK2c dqv1 = ',dqv
10671! calculate midpoint values:
10672 ! ltemq1m = ltemq1 + Nint(dtemp*fqsat + 0.5)
10673
10674 ! 7.6.2016: Test full calc of ltemq
10675 ltemq1m = (temp1+dtemp-163.15)*fqsati+1.5
10676 ltemq1m = min( nqsat, max(1,ltemq1m) )
10677
10678 IF ( ltemq1m .lt. 1 .or. ltemq1m .gt. nqsat ) THEN
10679 write(0,*) 'STOP in nucond line 1192 '
10680 write(0,*) ' ltemq1m,icond = ',ltemq1m,icond
10681 write(0,*) ' dtemp,e1,f1,dqv,dqvr = ', dtemp,e1,f1,dqv,dqvr
10682 write(0,*) ' d1,d1r,dtcon,ss1 = ',d1,d1r,dtcon,ss1
10683 write(0,*) ' dqc, dqr = ',dqc,dqr
10684 write(0,*) ' qv,qc,qr = ',qx(mgs,lv)*1000.,qx(mgs,lc)*1000.,qx(mgs,lr)*1000.
10685 write(0,*) ' i, j, k = ',igs(mgs),jy,kgs(mgs)
10686 write(0,*) ' dtcon1,dtcon2,delta = ',dtcon1,dtcon2,delta
10687 write(0,*) ' nc,dtp = ',nc,dtp
10688 write(0,*) ' rwvent,xdia,crw,ccw = ', rwvent(mgs),xdia(mgs,lr,1),cx(mgs,lr),cx(mgs,lc)
10689 write(0,*) ' fvent,alphar = ',fvent(mgs),alpha(mgs,lr)
10690 write(0,*) ' xvr,xmasr,xdnr,cwc1 = ',xv(mgs,lr),xmas(mgs,lr),xdn(mgs,lr),cwc1
10691 ENDIF
10692 dqvs = dtemp*p380*dtabqvs(ltemq1m)
10693 qv1m = qv1 + dqv + dqvr
10694! qv1mr = qv1r + dqvr
10695
10696 qvs1m = qvs1 + dqvs
10697 ss1m = qv1m/qvs1m
10698
10699 ! check for undersaturation when no ice is present, if so, then reduce time step
10700 IF ( ss1m .lt. 1. .and. (dqvii + dqvis) .eq. 0.0 ) THEN
10701 dtcon = (0.5*dtcon)
10702 IF ( dtcon .ge. dtcon1 ) THEN
10703 GOTO 609
10704 ELSE
10705 EXIT
10706 ENDIF
10707 ENDIF
10708! calculate full step:
10709 dqv = -(ss1m - 1.)*d1*dtcon
10710 dqvr = -(ss1m - 1.)*d1r*dtcon
10711
10712
10713! write(0,*) 'RK2a dqv1m = ',dqv
10714 dtemp = -e1*f1*(dqv + dqvr)
10715
10716 ! ltemq1 = ltemq1 + Nint(dtemp*fqsat + 0.5)
10717
10718 ! 7.6.2016: Test full calc of ltemq
10719 ltemq1 = (temp1+dtemp-163.15)*fqsati+1.5
10720 ltemq1 = min( nqsat, max(1,ltemq1) )
10721
10722 IF ( ltemq1 .lt. 1 .or. ltemq1 .gt. nqsat ) THEN
10723 write(0,*) 'STOP in nucond line 1230 '
10724 write(0,*) ' ltemq1m,icond = ',ltemq1m,icond
10725 write(0,*) ' dtemp,e1,dqv,dqvr = ', dtemp,e1,dqv,dqvr
10726 ENDIF
10727 dqvs = dtemp*p380*dtabqvs(ltemq1)
10728
10729 qv1 = qv1 + dqv + dqvr
10730
10731 dqc = dqc - dqv
10732 dqr = dqr - dqvr
10733
10734 qvs1 = qvs1 + dqvs
10735 ss1 = qv1/qvs1
10736 temp1 = temp1 + dtemp
10737 IF ( temp2 .eq. temp1 .or. ss2 .eq. ss1 .or. &
10738 & ss1 .eq. 1.00 .or. &
10739 & ( n .gt. 10 .and. ss1 .lt. 1.0005 ) ) THEN
10740! write(0,*) 'RK2c break'
10741 EXIT
10742 ELSE
10743 ss2 = ss1
10744 temp2 = temp1
10745 dt1 = dt1 + dtcon
10746 n = n + 1
10747 ENDIF
10748 ENDDO rk2c
10749
10750
10751 dcloud = dqc ! qx(mgs,lv) - qv1
10752 thetap(mgs) = thetap(mgs) + e1*(dcloud + dqr)
10753
10754
10755 IF ( eqtset > 2 ) THEN
10756 pipert(mgs) = pipert(mgs) + felvpi(mgs)*(dcloud + dqr)
10757 ENDIF
10758 IF ( io_flag .and. nxtra > 1 ) THEN
10759 axtra(igs(mgs),jy,kgs(mgs),1) = dcloud/dtp
10760 axtra(igs(mgs),jy,kgs(mgs),2) = axtra(igs(mgs),jy,kgs(mgs),2) + dqr/dtp
10761 ENDIF
10762 qwvp(mgs) = qwvp(mgs) - (dcloud + dqr)
10763 qx(mgs,lc) = qx(mgs,lc) + dcloud
10764 qx(mgs,lr) = qx(mgs,lr) + dqr
10765! t9(igs(mgs),jy,kgs(mgs)) = t9(igs(mgs),jy,kgs(mgs)) + (DCLOUD + dqr)/dtp*felv(mgs)/(cp*pi0(mgs)) !* &
10766!! & dx*dy*dz3d(igs(mgs),jy,kgs(mgs))
10767
10768
10769 IF ( lzr > 1 .and. rcond == 2 .and. qx(mgs,lr) .gt. qxmin(lr) &
10770 & .and. cx(mgs,lr) .gt. 1.e-9 ) THEN
10771 tmp = qx(mgs,lr)/cx(mgs,lr)
10772 IF ( imurain == 3 ) THEN
10773 g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
10774 ELSE
10775 g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
10776 & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2)
10777
10778 ENDIF
10779 zx(mgs,lr) = zx(mgs,lr) + g1*(rho0(mgs)/(xdn(mgs,lr)))**2*( 2.*( tmp ) * dqr )
10780 ENDIF
10781
10782 theta(mgs) = thetap(mgs) + theta0(mgs)
10783 temg(mgs) = theta(mgs)*f1
10784 ltemq = (temg(mgs)-163.15)/fqsat+1.5
10785 ltemq = min( nqsat, max(1,ltemq) )
10786 qvs(mgs) = pqs(mgs)*tabqvs(ltemq)
10787! es(mgs) = 6.1078e2*tabqvs(ltemq)
10788
10789!
10790
10791 ENDIF ! dcloud .gt. 0.
10792
10793
10794 ELSE ! qc .le. qxmin(lc)
10795
10796! IF ( ssf(mgs) .gt. 0.0 .and. .not. flag_qndrop ) THEN ! flag_qndrop turns off primary nucleation when using wrf-chem with progn=1
10797 IF ( ssf(mgs) .gt. 0.0 ) THEN ! .and. ssmax(mgs) .lt. sscb ) THEN ! except that wrf-chem does not seem to initialize qc for activated aerosols, so keep this, after all
10798
10799 IF ( iqcinit == 1 ) THEN
10800
10801 qvs0 = 380.*exp(17.27*(temg(mgs)-273.)/(temg(mgs)- 36.))/pk(mgs)
10802
10803 dcloud = max(0.0, (qx(mgs,lv)-qvs0) / (1.+qvs0*f5/(temg(mgs)-36.)**2) )
10804
10805 ELSEIF ( iqcinit == 3 ) THEN
10806 r1=1./(1. + caw*(273.15 - cbw)*qss(mgs)*felvcp(mgs)/ &
10807 & ((temg(mgs) - cbw)**2))
10808 dcloud=r1*(qvap(mgs) - qvs(mgs)) ! KW model adjustment;
10809 ! this will put mass into qc if qv > sqsat exists
10810
10811 ELSEIF ( iqcinit == 2 ) THEN
10812! R1=1./(1. + caw*(273.15 - cbw)*qss(mgs)*felv(mgs)/
10813! : (cp*(temg(mgs) - cbw)**2))
10814! DCLOUD=R1*(qvap(mgs) - qvs(mgs)) ! KW model adjustment;
10815 ! this will put mass into qc if qv > sqsat exists
10816 ssmx = ssmxinit
10817
10818! IF ( ssf(mgs) > ssmx .and. ssmax(mgs) < 3.0 ) THEN
10819! IF ( ssf(mgs) > ssmx .and. ccnc(mgs) > 1.0 ) THEN
10820! IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 5.0 .and. ccnc(mgs) > 0.1*cwnccn(mgs) ) THEN ! this one works
10821! IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 ) THEN ! test -- fails
10822! IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 .and. ccnc(mgs) > 0.1*cwnccn(mgs)) THEN ! test -- is OK
10823 IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 .and. &
10824 ( ccnc(mgs) > 0.05*cwnccn(mgs) .or. ( ac_opt > 0 .and. ccnc_ac(mgs) - cx(mgs,lc) > 0.0 ) ) ) THEN ! test
10825! IF ( ssf(mgs) > ssmx ) THEN ! original condition
10826 CALL qvexcess(ngs,mgs,qwvp,qv0,qx(1,lc),pres,thetap,theta0,dcloud, &
10827 & pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ssmx,pk,ngscnt)
10828 ELSE
10829 dcloud = 0.0
10830 ENDIF
10831 ENDIF
10832 ELSE
10833 dcloud = 0.0
10834 ENDIF
10835
10836 thetap(mgs) = thetap(mgs) + felvcp(mgs)*dcloud/(pi0(mgs))
10837 qwvp(mgs) = qwvp(mgs) - dcloud
10838 qx(mgs,lc) = qx(mgs,lc) + dcloud
10839 IF ( io_flag .and. nxtra > 1 ) THEN
10840 axtra(igs(mgs),jy,kgs(mgs),1) = dcloud/dtp
10841 ENDIF
10842 theta(mgs) = thetap(mgs) + theta0(mgs)
10843 temg(mgs) = theta(mgs)*pk(mgs) !( pres(mgs) / poo ) ** cap
10844! temg(mgs) = theta2temp( theta(mgs), pres(mgs) )
10845 ltemq = (temg(mgs)-163.15)/fqsat+1.5
10846 ltemq = min( nqsat, max(1,ltemq) )
10847 qvs(mgs) = pqs(mgs)*tabqvs(ltemq)
10848! es(mgs) = 6.1078e2*tabqvs(ltemq)
10849
10850!.... S. TWOMEY (1959)
10851! Note: get here if there is no previous cloud water and w > 0.
10852 cn(mgs) = 0.0
10853
10854 IF ( ncdebug .ge. 1 ) THEN
10855 write(iunit,*) 'at 613: ',qx(mgs,lc),cx(mgs,lc),wvel(mgs),ssmax(mgs),kgs(mgs)
10856 ENDIF
10857
10858 IF ( .not. flag_qndrop ) THEN ! { do not calculate number of droplets if using wrf-chem
10859
10860 IF ( ac_opt == 0 ) THEN
10861 cnuctmp = cnuc(mgs)
10862 ELSE
10863 cnuctmp = ccnc_ac(mgs)
10864 ENDIF
10865
10866! IF ( ssmax(mgs) .lt. sscb .and. qx(mgs,lc) .gt. qxmin(lc)) THEN
10867 IF ( dcloud .gt. qxmin(lc) .and. wvel(mgs) > 0.0) THEN
10868! CN(mgs) = CCNE*wvel(mgs)**cnexp ! *Min(1.0,1./dtp) ! 0.3465
10869 cn(mgs) = ccne0*cnuctmp**(2./(2.+cck))*wvel(mgs)**cnexp ! *Min(1.0,1./dtp) ! 0.3465
10870 IF ( ny .le. 2 .and. cn(mgs) .gt. 0.0 &
10871 & .and. ncdebug .ge. 1 ) THEN
10872 write(iunit,*) 'CN: ',cn(mgs)*1.e-6, cx(mgs,lc)*1.e-6, qx(mgs,lc)*1.e3, &
10873 & wvel(mgs), dcloud*1.e3
10874 IF ( cn(mgs) .gt. 1.0 ) write(iunit,*) 'cwrad = ', &
10875 & 1.e6*(rho0(mgs)*qx(mgs,lc)/cn(mgs)*cwc1)**c1f3, &
10876 & igs(mgs),kgs(mgs),temcg(mgs), &
10877 & 1.e3*an(igs(mgs),jgs,kgs(mgs)-1,lc)
10878 ENDIF
10879 IF ( iccwflg .eq. 1 ) THEN
10880 cn(mgs) = min(cwccn*rho0(mgs)/rho00, max(cn(mgs), &
10881 & rho0(mgs)*qx(mgs,lc)/(xdn(mgs,lc)*(4.*pi/3.)*(4.e-6)**3)))
10882 ENDIF
10883 ELSE
10884 cn(mgs) = 0.0
10885 dcloud = 0.0
10886! cn(mgs) = Min(cwccn, &
10887! & rho0(mgs)*dcloud/(xdn(mgs,lc)*(4.*pi/3.)*(4.e-6)**3) )
10888 ENDIF
10889
10890 IF ( cn(mgs) .gt. 0.0 ) THEN
10891 IF ( ac_opt == 0 ) THEN
10892 IF ( cn(mgs) .gt. ccnc(mgs) ) THEN
10893 cn(mgs) = ccnc(mgs)
10894! ccnc(mgs) = 0.0
10895 ENDIF
10896 ELSE
10897 cn(mgs) = min( cn(mgs), ccnc_ac(mgs) )
10898 ENDIF
10899! cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
10900 IF ( irenuc <= 2 .and. lccna < 1 ) ccnc(mgs) = max(0.0, ccnc(mgs) - cn(mgs))
10901 ccna(mgs) = ccna(mgs) + cn(mgs)
10902 ENDIF
10903
10904! write(91,*) 'nuc1: cn, ix, kz = ',cn(mgs),igs(mgs),kgs(mgs),wvel(mgs),cnexp,ccnc(mgs)
10905
10906 IF( cn(mgs) .GT. cx(mgs,lc) ) cx(mgs,lc) = cn(mgs)
10907 IF( cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .le. qxmin(lc) ) THEN
10908 cx(mgs,lc) = 0.
10909 ELSE
10910 cx(mgs,lc) = min(cx(mgs,lc),rho0(mgs)*max(0.0,qx(mgs,lc))/cwmasn)
10911 ENDIF
10912
10913 ENDIF ! }.not. flag_qndrop
10914
10915 GOTO 613
10916
10917 END IF ! qc .gt. 0.
10918
10919! ES=EES(PIB(K)*PT)
10920! SQSAT=EPSI*ES/(PB(K)*1000.-ES)
10921
10922!.... CLOUD NUCLEATION
10923! T=PIB(K)*PT
10924! ES=1.E3*PB(K)*QV/EPSI
10925
10926 IF ( wvel(mgs) .le. 0. ) GO TO 616
10927 IF ( cx(mgs,lc) .le. 0. ) GO TO 613 !TWOMEY (1959) Nucleation
10928 IF ( kzbeg-1+kgs(mgs) .GT. 1 .and. qx(mgs,lc) .le. qxmin(lc)) GO TO 613 !TWOMEY (1959) Nucleation
10929 IF ( kzbeg-1+kgs(mgs) .eq. 1 .and. wvel(mgs) .gt. 0. ) GO TO 613 !TWOMEY (1959) Nucleation
10930!.... ATTEMPT ZIEGLER CLOUD NUCLEATION IN CLOUD INTERIOR UNLESS...
10931 616 IF ( ssf(mgs) .LE. supcb .AND. wvel(mgs) .GT. 0. ) GO TO 631 !... weakly saturated updraft
10932 IF ( kzbeg-1+kgs(mgs) .GT. 1 .AND. kzbeg-1+kgs(mgs) .LT. nzend-1 .AND. &
10933 & (ssfkp1(mgs) .GE. supmx .OR. &
10934 & ssf(mgs) .GE. supmx .OR. &
10935 & ssfkm1(mgs) .GE. supmx)) GO TO 631 !... too much vapour
10936 IF (ssf(mgs) .LT. 1.e-10 .OR. ssf(mgs) .GE. supmx) GO TO 631 !... at the extremes for ss
10937
10938!
10939! get here if ( qc > 0 and ss > supcb) or (w < 0)
10940!
10941
10942 if (ndebug .gt. 0) write(0,*) "ICEZVD_DR: Entered Ziegler Cloud Nucleation" !mpidebug
10943
10944 dssdz=0.
10945 r2dzm=0.50/dz3d(igs(mgs),jy,kgs(mgs))
10946
10947 IF ( irenuc >= 0 .and. ac_opt == 0 .and. .not. flag_qndrop ) THEN ! turn off nucleation when flag_qndrop (using WRF-CHEM for activation)
10948
10949 IF ( irenuc < 2 ) THEN !{
10950
10951 IF ( kzend == nzend ) THEN
10952 t0p3 = t0(igs(mgs),jgs,min(kze,kgs(mgs)+3))
10953 t0p1 = t0(igs(mgs),jgs,min(kze,kgs(mgs)+1))
10954 ELSE
10955 t0p3 = t0(igs(mgs),jgs,kgs(mgs)+3)
10956 t0p1 = t0(igs(mgs),jgs,kgs(mgs)+1)
10957 ENDIF
10958
10959 IF ( ( ssf(mgs) .gt. ssmax(mgs) .or. irenuc .eq. 1 ) &
10960 & .and. ( ( lccn .lt. 1 .and. &
10961 & cx(mgs,lc) .lt. cwccn*(min(1.0,rho0(mgs)))) .or. &
10962 & ( lccn .gt. 1 .and. ccnc(mgs) .gt. 0. ) ) &
10963 & ) THEN
10964 IF( kzbeg-1+kgs(mgs) .GT. 1 .AND. kzbeg-1+kgs(mgs) .LT. nzend-1 &
10965 & .and. ssf(mgs) .gt. 0.0 &
10966 & .and. ssfkp1(mgs) .LT. supmx .and. ssfkp1(mgs) .ge. 0.0 &
10967 & .AND. ssfkm1(mgs) .LT. supmx .AND. ssfkm1(mgs) .ge. 0.0 &
10968 & .AND. ssfkp1(mgs) .gt. ssfkm1(mgs) &
10969 & .and. t0p3 .gt. 233.2) THEN
10970 dssdz = (ssfkp1(mgs) - ssfkm1(mgs))*r2dzm
10971!
10972! otherwise check for cloud base condition with updraft:
10973!
10974 ELSEIF( kzbeg-1+kgs(mgs) .GT. 1 .AND. kzbeg-1+kgs(mgs) .LT. nzend-1 &
10975! IF( kgs(mgs) .GT. 1 .AND. kgs(mgs) .LT. NZ-1 & !)
10976 & .and. ssf(mgs) .gt. 0.0 .and. wvel(mgs) .gt. 0.0 &
10977 & .and. ssfkp1(mgs) .gt. 0.0 &
10978 & .AND. ssfkm1(mgs) .le. 0.0 .and. wvelkm1(mgs) .gt. 0.0 &
10979 & .AND. ssf(mgs) .gt. ssfkm1(mgs) &
10980 & .and. t0p1 .gt. 233.2) THEN
10981 dssdz = 2.*(ssf(mgs) - ssfkm1(mgs))*r2dzm ! 1-sided difference
10982 ENDIF
10983
10984 ENDIF
10985!
10986!CLZ IF(wijk.LE.0.) CN=CCN*ssfilt(ix,jy,kz)**CCK
10987! note: CCN -> cwccn, DELT -> dtp
10988 c1 = max(0.0, rho0(mgs)*(qx(mgs,lv) - qss(mgs))/ &
10989 & (xdn(mgs,lc)*(4.*pi/3.)*(4.e-6)**3))
10990 IF ( lccn .lt. 1 ) THEN
10991 cn(mgs) = cwccn*rho0(mgs)/rho00*cck*ssf(mgs)**cckm*dtp* &
10992 & max(0.0, &
10993 & (wvel(mgs)*dssdz) ) ! probably the vertical gradient dominates
10994 ELSE
10995 cn(mgs) = &
10996 & min(ccnc(mgs), cnuc(mgs)*cck*ssf(mgs)**cckm*dtp* &
10997 & max(0.0, &
10998 & ( wvel(mgs)*dssdz) ) )
10999! IF ( cn(mgs) .gt. 0 ) ccnc(mgs) = ccnc(mgs) - cn(mgs)
11000 ENDIF
11001
11002 IF ( cn(mgs) .gt. 0.0 ) THEN
11003 IF ( ccnc(mgs) .lt. 5.e7 .and. cn(mgs) .ge. 5.e7 ) THEN
11004 cn(mgs) = 5.e7
11005 ccnc(mgs) = 0.0
11006 ELSEIF ( cn(mgs) .gt. ccnc(mgs) ) THEN
11007 cn(mgs) = ccnc(mgs)
11008 ccnc(mgs) = 0.0
11009 ENDIF
11010 cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
11011 ccnc(mgs) = max(0.0, ccnc(mgs) - cn(mgs))
11012 ENDIF
11013
11014 ELSEIF ( irenuc == 2 ) THEN !} {
11015 ! simple Twomey scheme
11016! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs)
11017 cn(mgs) = ccne0*cnuc(mgs)**(2./(2.+cck))*max(0.0,wvel(mgs))**cnexp ! *Min(1.0,1./dtp) ! 0.3465
11018! ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck))
11019!!! CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from
11020 ! Philips, Donner et al. 2007, but results in too much limitation of
11021 ! nucleation
11022 cn(mgs) = min(cn(mgs), ccnc(mgs))
11023 cn(mgs) = min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass
11024 cn(mgs) = min( cn(mgs), max(0.0, (cnuc(mgs) - ccna(mgs) )) )
11025
11026 IF ( .false. .and. ny <= 2 ) THEN
11027 write(0,*) 'i,k, cwmasn = ',igs(mgs),kgs(mgs),cwmasn
11028 write(0,*) 'wvel, cnuc, cn = ',wvel(mgs),cnuc(mgs),cn(mgs)
11029 write(0,*) 'ccne0,cnexp,cck = ',ccne0,cnexp,cck
11030 write(0,*) 'part1, part2 = ',ccne0*cnuc(mgs)**(2./(2.+cck)), max(0.0,wvel(mgs))**cnexp
11031 write(0,*) 'ccnc, dqc, dqc/cwmasn = ',ccnc(mgs), dqc, 0.5*dqc/cwmasn
11032 ENDIF
11033
11034 IF ( icnuclimit > 0 ) THEN
11035 tmp = ccnc(mgs) + cx(mgs,lc)
11036 IF ( tmp < 330.34e6 ) THEN
11037 ccwmax = 1.1173e6 * (1.e-6*tmp)**0.9504
11038 ELSE
11039 ccwmax = 21.57e6 * (1.e-6*tmp)**0.44
11040 ENDIF
11041
11042! IF ( cn(mgs) > 0. ) THEN
11043! write(0,*) 'cn,tmp,ccwmax,cx,c-cx = ',cn(mgs),tmp,ccwmax,cx(mgs,lc),ccwmax - cx(mgs,lc)
11044! ENDIF
11045
11046 cn(mgs) = max( 0.0, min( cn(mgs), ccwmax - cx(mgs,lc) ) )
11047
11048 ENDIF
11049
11050 cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
11051
11052 IF ( lccna < 1 ) ccnc(mgs) = max(0.0, ccnc(mgs) - cn(mgs))
11053
11054 ELSEIF ( irenuc == 3 ) THEN !} {
11055 ! Phillips Donner Garner 2007
11056! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs)
11057! CN(mgs) = cwccn*Min(ssf(mgs),ssfcut)**cck
11058
11059! Need to calculate new ssf since condensation has happened:
11060 temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz)
11061 ltemq = int( (temp1-163.15)/fqsat+1.5 )
11062 ltemq = min( nqsat, max(1,ltemq) )
11063
11064 c1= pqs(mgs)*tabqvs(ltemq)
11065
11066 ssf(mgs) = 0.0
11067 IF ( c1 > 0. ) THEN
11068 ssf(mgs) = 100.*(qx(mgs,lv)/c1 - 1.0) ! from "new" values
11069 ENDIF
11070 cn(mgs) = cnuc(mgs)*min(1.0, (ssf(mgs))**cck ) !
11071
11072 cn(mgs) = max( 0.0, cn(mgs) - ccna(mgs) ) ! this was from
11073 ! Philips, Donner et al. 2007, but results in too much limitation of
11074 ! nucleation
11075 cn(mgs) = min(cn(mgs), ccnc(mgs))
11076 cn(mgs) = min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass
11077
11078 cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
11079
11080 ! 6/13/2016: Phillips et al. appears not to decrement CCN, but only increments CCNa.
11081 ! This would allow an initially non-homogeneous (vertically, e.g.) initial value of CCN/rho_air
11082 ccnc(mgs) = max(0.0, ccnc(mgs) - cn(mgs))
11083
11084 ELSEIF ( irenuc == 4 ) THEN !} {
11085 ! modification of Phillips Donner Garner 2007
11086! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs)
11087! CN(mgs) = CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp
11088! cn(mgs) = Min( cn(mgs), cnuc(mgs) )
11089! Need to calculate new ssf since condensation has happened:
11090 temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz)
11091 ltemq = int( (temp1-163.15)/fqsat+1.5 )
11092 ltemq = min( nqsat, max(1,ltemq) )
11093
11094 c1= pqs(mgs)*tabqvs(ltemq)
11095 IF ( c1 > 0. ) THEN
11096 ssf(mgs) = max(0.0, 100.*((qv0(mgs) + qwvp(mgs))/c1 - 1.0) ) ! from "new" values
11097 ELSE
11098 ssf(mgs) = 0.0
11099 ENDIF
11100 cn(mgs) = cnuc(mgs)*min(ssf2kmax, ssf(mgs)**cck) ! this allows cn(mgs) > cnuc(mgs)
11101
11102 cn(mgs) = max( 0.0, cn(mgs) - ccna(mgs) ) ! this was from
11103 ! Philips, Donner et al. 2007, but results in too much limitation of
11104 ! nucleation
11105! CN(mgs) = Min(cn(mgs), ccnc(mgs))
11106 cn(mgs) = min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass
11107
11108 IF ( cn(mgs) > 0.0 ) THEN
11109 cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
11110 ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
11111
11112 dcrit = 2.0*2.5e-7
11113
11114 dcloud = 1000.*dcrit**3*pi/6.*cn(mgs)
11115 qx(mgs,lc) = qx(mgs,lc) + dcloud
11116 thetap(mgs) = thetap(mgs) + felvcp(mgs)*dcloud/(pi0(mgs))
11117 qwvp(mgs) = qwvp(mgs) - dcloud
11118 ENDIF
11119 ! 6/13/2016: Phillips et al. appears not to decrement CCN, but only increments CCNa.
11120 ! This would allow an initially non-homogeneous (vertically, e.g.) initial value of CCN/rho_air
11121! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
11122
11123
11124
11125 ELSEIF ( irenuc == 6 ) THEN !} {
11126
11127 ! simple Twomey scheme but limit activation to try to do most activation near cloud base, but keep some CCN available for renuclation
11128! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs)
11129 cn(mgs) = 0.0
11130! 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
11131 IF ( ccna(mgs) < 0.7*cnuc(mgs) ) THEN ! here, assume we are near cloud base and use Twomey formulation
11132 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
11133! IF ( cn(mgs) + ccna(mgs) > 0.71*cnuc ) THEN
11134 ! prevent this branch from activating more than 70% of CCN
11135 cn(mgs) = min( cn(mgs), max(0.0, (0.7*cnuc(mgs) - ccna(mgs) )) )
11136! CN(mgs) = Min( CN(mgs), Max(0.0, 0.71*ccnc(mgs) - ccna(mgs) ) )
11137
11138 ELSE
11139 ! 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.
11140
11141 temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz)
11142! t0(ix,jy,kz) = temp1
11143 ltemq = int( (temp1-163.15)/fqsat+1.5 )
11144 ltemq = min( nqsat, max(1,ltemq) )
11145
11146! c1 = t00(igs(mgs),jy,kgs(mgs))*tabqvs(ltemq)
11147 c1= pqs(mgs)*tabqvs(ltemq)
11148 IF ( c1 > 0. ) THEN
11149 ssf(mgs) = max(0.0, 100.*((qv0(mgs) + qwvp(mgs))/c1 - 1.0) ) ! from "new" values
11150 ELSE
11151 ssf(mgs) = 0.0
11152 ENDIF
11153
11154! CN(mgs) = cnuc(mgs)*Min(0.99, Min(ssf(mgs),ssfcut)**cck ) !
11155 cn(mgs) = cnuc(mgs)*min(2.0, max(0.0,ssf(mgs))**cck ) !
11156! CN(mgs) = cnuc(mgs)*Min(ssf(mgs),ssfcut)**cck !
11157
11158
11159 cn(mgs) = min(0.01*cnuc(mgs), max( 0.0, cn(mgs) - ccna(mgs) ) ) ! this was from
11160! cn(mgs) = 0.0
11161 ENDIF
11162! ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck))
11163!!! CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from
11164 ! Philips, Donner et al. 2007, but results in too much limitation of
11165 ! nucleation
11166! CN(mgs) = Min(cn(mgs), ccnc(mgs))
11167! cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass
11168
11169 IF ( cn(mgs) > 0.0 ) THEN
11170 cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
11171
11172 ! create some small droplets at minimum size (CP 2000), although it adds very little liquid
11173
11174 dcrit = 2.0*2.5e-7
11175
11176 dcloud = 1000.*dcrit**3*pi/6.*cn(mgs)
11177 qx(mgs,lc) = qx(mgs,lc) + dcloud
11178 thetap(mgs) = thetap(mgs) + felvcp(mgs)*dcloud/(pi0(mgs))
11179 qwvp(mgs) = qwvp(mgs) - dcloud
11180 ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
11181 ENDIF
11182 ELSEIF ( irenuc == 5 ) THEN !} {
11183
11184 ! modification of Phillips Donner Garner 2007
11185! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs)
11186! 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
11187 cn(mgs) = min( cnuc(mgs), ccne0*cnuc(mgs)**(2./(2.+cck))*max(0.0,wvel(mgs))**cnexp )
11188
11189
11190 IF ( ccna(mgs) >= cnuc(mgs) ) THEN ! apply limit after all "base" CCN have been depleted
11191 temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz)
11192 ltemq = int( (temp1-163.15)/fqsat+1.5 )
11193 ltemq = min( nqsat, max(1,ltemq) )
11194
11195 c1= pqs(mgs)*tabqvs(ltemq)
11196 IF ( c1 > 0. ) THEN
11197 ssf(mgs) = max(0.0, 100.*((qv0(mgs) + qwvp(mgs))/c1 - 1.0) ) ! from "new" values
11198 ELSE
11199 ssf(mgs) = 0.0
11200 ENDIF
11201
11202
11203 cn(mgs) = max( cn(mgs), cnuc(mgs)*min(ssf2kmax, ssf(mgs)**cck) ) ! this allows cn(mgs) > cnuc(mgs)
11204
11205 ! cn(mgs) = Min( cn(mgs), cnuc(mgs) )
11206
11207! IF ( ccna(mgs) >= cnuc(mgs) ) THEN ! apply limit after all "base" CCN have been depleted
11208 cn(mgs) = max( 0.0, cn(mgs) - ccna(mgs) ) ! this was from
11209
11210 ELSE
11211 cn(mgs) = min( cn(mgs), cnuc(mgs) - ccna(mgs) ) ! no more than remaining "base" CCN
11212 ENDIF
11213 ! Philips, Donner et al. 2007, but results in too much limitation of
11214 ! nucleation
11215! CN(mgs) = Min(cn(mgs), ccnc(mgs))
11216! cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass
11217 dcrit = 2.0*2.0e-6
11218 dcloud = 1000.*dcrit**3*pi/6.
11219 ! cn(mgs) = Min(cn(mgs), 0.5*dqc/dcloud) ! limit the nucleation mass to half of the condensation mass
11220 ! check new droplet size:
11221 ! tmp is number of droplets at diameter dcrit
11222 tmp = max(0.0, rho0(mgs)*qx(mgs,lc)/dcloud - cx(mgs,lc)) ! (cx(mgs,lc) + cn(mgs))
11223 cn(mgs) = min(tmp, cn(mgs) )
11224
11225
11226 IF ( cn(mgs) > 0.0 ) THEN
11227 cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
11228
11229 dcrit = 2.5e-7
11230
11231 dcloud = 1000.*dcrit**3*pi/6.*cn(mgs)
11232 qx(mgs,lc) = qx(mgs,lc) + dcloud
11233 thetap(mgs) = thetap(mgs) + felvcp(mgs)*dcloud/(pi0(mgs))
11234 qwvp(mgs) = qwvp(mgs) - dcloud
11235 ENDIF
11236 ! 6/13/2016: Phillips et al. appears not to decrement CCN, but only increments CCNa.
11237 ! This would allow an initially non-homogeneous (vertically, e.g.) initial value of CCN/rho_air
11238 ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
11239 ELSEIF ( irenuc == 7 .or. irenuc == 17 ) THEN !} {
11240
11241 ! simple Twomey scheme but limit activation to try to do most activation near cloud base, but keep some CCN available for renuclation
11242! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs)
11243 cn(mgs) = 0.0
11244 IF ( irenuc == 7 ) THEN
11245 frac = 0.9
11246 ELSE
11247 frac = 0.98
11248 ENDIF
11249! 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
11250 IF ( ccna(mgs) < frac*cnuc(mgs) ) THEN ! { here, assume we are near cloud base and use Twomey formulation
11251 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
11252! IF ( cn(mgs) + ccna(mgs) > 0.71*cnuc ) THEN
11253 ! prevent this branch from activating more than 70% of CCN
11254 cn(mgs) = min( cn(mgs), max(0.0, (frac*cnuc(mgs) - ccna(mgs) )) )
11255! CN(mgs) = Min( CN(mgs), Max(0.0, 0.71*ccnc(mgs) - ccna(mgs) ) )
11256 ! write(0,*) '1: k,cn = ',kgs(mgs),cn(mgs),ssf(mgs)
11257!! IF ( ccncuf(mgs) > 0.0 .and. cn(mgs) < 1.e-3 .and. ssmax(mgs) > 1.0 ) THEN
11258! IF ( ccncuf(mgs) > 0.0 .and. ssf(mgs) > ssmxuf .and. ssmax(mgs) > ssmxuf ) THEN
11259! CNuf(mgs) = Min( ccncuf(mgs), CCNE0*ccncuf(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465
11260 ! IF ( cnuf(mgs) >= 0.0 ) write(0,*) '1: cnuf, k = ',cnuf(mgs),ccncuf(mgs),kgs(mgs)
11261! ENDIF
11262
11263
11264 ELSE ! }{
11265 ! 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.
11266
11267 temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz)
11268! t0(ix,jy,kz) = temp1
11269 ltemq = int( (temp1-163.15)/fqsat+1.5 )
11270 ltemq = min( nqsat, max(1,ltemq) )
11271
11272 ! c1 = t00(igs(mgs),jy,kgs(mgs))*tabqvs(ltemq)
11273 c1= pqs(mgs)*tabqvs(ltemq)
11274
11275 ssf(mgs) = 0.0
11276 IF ( c1 > 0. ) THEN
11277 ssf(mgs) = 100.*(qx(mgs,lv)/c1 - 1.0) ! from "new" values
11278 ENDIF
11279
11280! IF ( ssf(mgs) <= 1.0 .or. cnuc(mgs) > ccna(mgs) ) THEN
11281 IF ( ssf(mgs) <= 1.0 ) THEN
11282 cn(mgs) = cnuc(mgs)*min(1.0, max(0.0,ssf(mgs))**cck ) !
11283 ELSE
11284 cn(mgs) = cnuc(mgs)*min(2.0, max(0.0,0.03*(ssf(mgs)-1.0)+1.)**cck ) !
11285! write(0,*) 'iren7: ssf,ssmx = ',ssf(mgs),ssmax(mgs),cn(mgs),ccna(mgs),cnuc(mgs)
11286! write(0,*) 'c1,qv = ',c1,qx(mgs,lv),temp1,ltemq
11287 ENDIF
11288
11289 ! write(0,*) 'k,cn = ',kgs(mgs),cn(mgs),ssf(mgs)
11290 ! write(0,*) 'ccn-ccna = ',cnuc(mgs) - ccna(mgs),ccnc(mgs) - ccna(mgs)
11291! IF ( ccncuf(mgs) > 0.0 .and. cn(mgs) < 1.e-3 .and. ssmax(mgs) > 1.0 ) THEN
11292 IF ( ccncuf(mgs) > 0.0 .and. ssf(mgs) > ssmxuf .and. ( ssmax(mgs) > ssmxuf .or. lss < 1 ) ) THEN
11293 cnuf(mgs) = min( ccncuf(mgs), ccne0*ccncuf(mgs)**(2./(2.+cck))*max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465
11294 ! IF ( cnuf(mgs) >= 0.0 ) write(0,*) 'cnuf, k = ',cnuf(mgs),ccncuf(mgs),kgs(mgs)
11295 ENDIF
11296
11297
11298! CN(mgs) = Min( Min(0.1,ssf(mgs)-1.)*cnuc(mgs), Max( 0.0, CN(mgs) - ccna(mgs) ) ) ! this was from
11299! CN(mgs) = Min( Min(0.5*cx(mgs,lc), Min(0.1,ssf(mgs)/100.)*cnuc(mgs)), Max( 0.0, CN(mgs) - ccna(mgs) ) ) ! this was from
11300
11301 cn(mgs) = min(0.01*cnuc(mgs), max( 0.0, cn(mgs) - ccna(mgs) ) ) ! this was from
11302
11303 ENDIF ! }
11304! ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck))
11305!!! CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from
11306 ! Philips, Donner et al. 2007, but results in too much limitation of
11307 ! nucleation
11308! CN(mgs) = Min(cn(mgs), ccnc(mgs))
11309! cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass
11310
11311
11312 IF ( icnuclimit > 0 ) THEN
11313! max droplet conc. based on Chandrakar et al. (2016) and Konwar et al. (2012)
11314 tmp = ccnc(mgs) - ccna(mgs) + cx(mgs,lc)
11315 IF ( tmp < 330.34e6 ) THEN
11316 ccwmax = 1.1173e6 * (1.e-6*tmp)**0.9504
11317 ELSE
11318 ccwmax = 21.57e6 * (1.e-6*tmp)**0.44
11319 ENDIF
11320
11321 cn(mgs) = max( 0.0, min( cn(mgs), ccwmax - cx(mgs,lc) ) )
11322
11323 ENDIF
11324
11325 IF ( cn(mgs) + cnuf(mgs) > 0.0 ) THEN
11326
11327 dcrit = 2.0*2.0e-6
11328 dcloud = 1000.*dcrit**3*pi/6.
11329 ! cn(mgs) = Min(cn(mgs), 0.5*dqc/dcloud) ! limit the nucleation mass to half of the condensation mass
11330 ! check new droplet size:
11331 ! tmp is number of droplets at diameter dcrit
11332 tmp = max(0.0, rho0(mgs)*qx(mgs,lc)/dcloud - cx(mgs,lc)) ! (cx(mgs,lc) + cn(mgs))
11333 cn(mgs) = min(tmp, cn(mgs) )
11334
11335 cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + cnuf(mgs)
11336
11337
11338 ! create some small droplets at minimum size (CP 2000), although it adds very little liquid
11339
11340
11341 dcrit = 2.0*2.5e-7
11342 dcloud = 1000.*dcrit**3*pi/6.*(cn(mgs) + cnuf(mgs) )
11343 qx(mgs,lc) = qx(mgs,lc) + dcloud
11344 thetap(mgs) = thetap(mgs) + felvcp(mgs)*dcloud/(pi0(mgs))
11345 qwvp(mgs) = qwvp(mgs) - dcloud
11346 ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
11347 ccncuf(mgs) = max(0.0, ccncuf(mgs) - cnuf(mgs))
11348 ENDIF
11349
11350 ELSEIF ( irenuc == 8 ) THEN !} {
11351 ! simple Twomey scheme
11352! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs)
11353
11354 cn(mgs) = 0.0
11355
11356 IF ( ccnc(mgs) > 0. ) THEN
11357 cn(mgs) = ccne0*ccnc(mgs)**(2./(2.+cck))*max(0.0,wvel(mgs))**cnexp ! *Min(1.0,1./dtp) ! 0.3465
11358! ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck))
11359!!! CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from
11360 ! Philips, Donner et al. 2007, but results in too much limitation of
11361 ! nucleation
11362 cn(mgs) = min(cn(mgs), ccnc(mgs))
11363
11364 ELSEIF ( cx(mgs,lc) < 0.01e9 ) THEN
11365
11366 ! 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.
11367
11368 temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz)
11369! t0(ix,jy,kz) = temp1
11370 ltemq = int( (temp1-163.15)/fqsat+1.5 )
11371 ltemq = min( nqsat, max(1,ltemq) )
11372
11373 ! c1 = t00(igs(mgs),jy,kgs(mgs))*tabqvs(ltemq)
11374 c1= pqs(mgs)*tabqvs(ltemq)
11375
11376 ssf(mgs) = 0.0
11377 IF ( c1 > 0. ) THEN
11378 ssf(mgs) = 100.*(qx(mgs,lv)/c1 - 1.0) ! from "new" values
11379 ENDIF
11380
11381! IF ( ssf(mgs) <= 1.0 .or. cnuc(mgs) > ccna(mgs) ) THEN
11382 IF ( ssf(mgs) <= 1.0 ) THEN
11383 cn(mgs) = 0.0
11384 ELSE
11385! CN(mgs) = 0.01e9*rho0(mgs)/rho00*Min(2.0, Max(0.0,0.03*(ssf(mgs)-1.0)+1.)**cck ) - cx(mgs,lc) !
11386 cn(mgs) = 0.01e9*min(2.0, max(0.0,0.03*(ssf(mgs)-1.0)+1.)**cck ) - cx(mgs,lc) !
11387 ENDIF
11388
11389 ENDIF
11390
11391 IF ( cn(mgs) > 0.0 ) THEN
11392 cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
11393
11394 ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
11395
11396 ! create some small droplets at minimum size (CP 2000), although it adds very little liquid
11397
11398 dcrit = 2.0*2.5e-7
11399
11400 dcloud = 1000.*dcrit**3*pi/6.*cn(mgs)
11401 qx(mgs,lc) = qx(mgs,lc) + dcloud
11402 thetap(mgs) = thetap(mgs) + felvcp(mgs)*dcloud/(pi0(mgs))
11403 qwvp(mgs) = qwvp(mgs) - dcloud
11404 ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
11405 ENDIF
11406
11407
11408
11409 ENDIF ! }
11410
11411 ccna(mgs) = ccna(mgs) + cn(mgs)
11412
11413 ENDIF ! irenuc >= 0 .and. .not. flag_qndrop
11414
11415 IF( cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .LE. qxmin(lc)) cx(mgs,lc)=0.
11416 GO TO 631
11417!.... NUCLEATION ON CLOUD INFLOW BOUNDARY POINT
11418
11419 613 CONTINUE
11420
11421 631 CONTINUE
11422
11423!
11424! Check for supersaturation greater than ssmx and adjust down
11425!
11426 ssmx = maxsupersat
11427 qv1 = qv0(mgs) + qwvp(mgs)
11428 qvs1 = qvs(mgs)
11429
11430! IF ( flag_qndrop .and. do_satadj_for_wrfchem ) ssmx = 1.04 ! set lower threshold for progn=1 when using WRF-CHEM
11431
11432 IF ( qv1 .gt. (ssmx*qvs1) ) THEN
11433! use line below to disable saturation adjustment when flag_qndrop is true
11434! IF ( qv1 .gt. (ssmx*qvs1) .and. .not. flag_qndrop ) THEN
11435
11436 ss1 = qv1/qvs1
11437
11438 ssmx = 100.*(ssmx - 1.0)
11439
11440 qvex = 0.0
11441
11442 CALL qvexcess(ngs,mgs,qwvp,qv0,qx(1,lc),pres,thetap,theta0,qvex, &
11443 & pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ssmx,pk,ngscnt)
11444
11445
11446
11447 IF ( qvex .gt. 0.0 ) THEN
11448 thetap(mgs) = thetap(mgs) + felvcp(mgs)*qvex/(pi0(mgs))
11449 IF ( io_flag .and. nxtra > 1 ) THEN
11450 axtra(igs(mgs),jy,kgs(mgs),1) = axtra(igs(mgs),jy,kgs(mgs),1) + qvex/dtp
11451 ENDIF
11452 qwvp(mgs) = qwvp(mgs) - qvex
11453 qx(mgs,lc) = qx(mgs,lc) + qvex
11454 IF ( .not. flag_qndrop) THEN
11455 IF ( imaxsupopt == 1 ) THEN
11456 cn(mgs) = min( max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/max( cwmasn5, xmas(mgs,lc) ) )
11457 ELSEIF ( imaxsupopt == 2 ) THEN
11458 cn(mgs) = min( max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/max( cwmasn5, max(cwmas30,xmas(mgs,lc)) ) )
11459 ELSEIF ( imaxsupopt == 3 ) THEN
11460 cn(mgs) = min( max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/max( cwmasn5, max(cwmasx,xmas(mgs,lc)) ) )
11461! cn(mgs) = 1.5*cxmin
11462 ELSEIF ( imaxsupopt == 4 ) THEN
11463 cn(mgs) = min( max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/max( cwmasn5, max(cwmas20,xmas(mgs,lc)) ) )
11464 ENDIF
11465 IF ( lccna > 1 ) THEN
11466 ccna(mgs) = ccna(mgs) + cn(mgs)
11467 ELSE
11468 ccnc(mgs) = max( 0.0, ccnc(mgs) - cn(mgs) )
11469 ENDIF
11470 cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
11471 ENDIF
11472
11473! write(iunit,*) 'theta = ',theta0(mgs) + thetap(mgs)
11474
11475! temg(mgs) = theta(mgs)*( pres(mgs) / poo ) ** cap
11476
11477 ENDIF
11478
11479
11480 ENDIF
11481
11482!
11483! Calculate droplet volume and check if it is within bounds.
11484! Adjust if necessary
11485!
11486! if (ndebug .gt. 0) write(0,*) "ICEZVD_DR: check droplet volume"
11487
11488
11489! cx(mgs,lc) = Min( cwnccn(mgs), cx(mgs,lc) )
11490 IF( cx(mgs,lc) > cxmin .AND. qx(mgs,lc) .GT. qxmin(lc)) THEN
11491! SVC(mgs) = rho0(mgs)*qx(mgs,lc)/(cx(mgs,lc)*xdn(mgs,lc))
11492 xmas(mgs,lc) = rho0(mgs)*qx(mgs,lc)/(cx(mgs,lc))
11493
11494 IF ( xmas(mgs,lc) < cwmasn .or. xmas(mgs,lc) > cwmasx ) THEN
11495 tmp = cx(mgs,lc)
11496 xmas(mgs,lc) = min( xmas(mgs,lc), cwmasx )
11497 xmas(mgs,lc) = max( xmas(mgs,lc), cwmasn )
11498 cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc)
11499! IF ( cx(mgs,lc) > tmp*1.1 ) THEN
11500! write(0,*) 'nucond: kgs, ccw1,2 = ',kgs(mgs),tmp,cx(mgs,lc)
11501! ENDIF
11502 ENDIF
11503 ENDIF
11504
11505
11506! IF( cx(mgs,lc) .GT. 10.e6 .AND. qx(mgs,lc) .GT. qxmin(lc) ) GO TO 681
11507! ccwtmp = cx(mgs,lc)
11508! cwmastmp = xmas(mgs,lc)
11509! xmas(mgs,lc) = Max(xmas(mgs,lc), cwmasn)
11510! IF (qx(mgs,lc) .GT. qxmin(lc) .AND. cx(mgs,lc) .le. 0.) THEN
11511! cx(mgs,lc) = Min(0.5*cwccn,rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc))
11512! xmas(mgs,lc) = rho0(mgs)*qx(mgs,lc)/cx(mgs,lc)
11513! ENDIF
11514! IF (cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .GT. qxmin(lc)) &
11515! & xmas(mgs,lc) = rho0(mgs)*qx(mgs,lc)/cx(mgs,lc)
11516! IF (qx(mgs,lc) .GT. qxmin(lc) .AND. xmas(mgs,lc) .LT. cwmasn) &
11517! & xmas(mgs,lc) = cwmasn
11518! IF (qx(mgs,lc) .GT. qxmin(lc) .AND. xmas(mgs,lc) .GT. cwmasx) &
11519! & xmas(mgs,lc) = cwmasx
11520! IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN
11521! cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/Max(cwmasn,xmas(mgs,lc))
11522! ENDIF
11523!
11524!
11525! 681 CONTINUE
11526
11527
11528 IF ( ipconc .ge. 3 .and. rcond == 2 ) THEN
11529
11530
11531 IF (cx(mgs,lr) .GT. 0. .AND. qx(mgs,lr) .GT. qxmin(lr)) &
11532 & xv(mgs,lr)=rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr))
11533 IF (xv(mgs,lr) .GT. xvmx(lr)) xv(mgs,lr) = xvmx(lr)
11534 IF (xv(mgs,lr) .LT. xvmn(lr)) xv(mgs,lr) = xvmn(lr)
11535
11536 ENDIF
11537
11538
11539
11540 ENDDO ! mgs
11541
11542
11543! ################################################################
11544 DO mgs=1,ngscnt
11545 IF ( lss > 1 .and. ssf(mgs) .gt. ssmax(mgs) &
11546 & .and. ( idecss .eq. 0 .or. qx(mgs,lc) .gt. qxmin(lc)) ) THEN
11547 ssmax(mgs) = ssf(mgs)
11548 ENDIF
11549 ENDDO
11550!
11551
11552 do mgs = 1,ngscnt
11553 an(igs(mgs),jy,kgs(mgs),lt) = theta0(mgs) + thetap(mgs)
11554 an(igs(mgs),jy,kgs(mgs),lv) = qv0(mgs) + qwvp(mgs)
11555! tmp3d(igs(mgs),jy,kgs(mgs)) = tmp3d(igs(mgs),jy,kgs(mgs)) + t9(igs(mgs),jy,kgs(mgs)) ! pi0(mgs) ! wvdf(mgs) ! ssf(mgs) ! cn(mgs)
11556!
11557 IF ( eqtset > 2 ) THEN
11558 p2(igs(mgs),jy,kgs(mgs)) = pipert(mgs)
11559 ENDIF
11560
11561 if ( ido(lc) .eq. 1 ) then
11562 an(igs(mgs),jy,kgs(mgs),lc) = qx(mgs,lc) + &
11563 & min( an(igs(mgs),jy,kgs(mgs),lc), 0.0 )
11564! qx(mgs,lc) = an(igs(mgs),jy,kgs(mgs),lc)
11565 end if
11566!
11567
11568 if ( ido(lr) .eq. 1 .and. rcond == 2 ) then
11569 an(igs(mgs),jy,kgs(mgs),lr) = qx(mgs,lr) + &
11570 & min( an(igs(mgs),jy,kgs(mgs),lr), 0.0 )
11571! qx(mgs,lr) = an(igs(mgs),jy,kgs(mgs),lr)
11572 end if
11573
11574 IF ( lzr > 1 .and. rcond == 2 ) THEN
11575 an(igs(mgs),jy,kgs(mgs),lzr) = zx(mgs,lr) + &
11576 & min( an(igs(mgs),jy,kgs(mgs),lzr), 0.0 )
11577 ENDIF
11578
11579
11580 IF ( ipconc .ge. 2 ) THEN
11581 an(igs(mgs),jy,kgs(mgs),lnc) = max(cx(mgs,lc) , 0.0)
11582 IF ( lss > 1 ) an(igs(mgs),jy,kgs(mgs),lss) = max( 0.0, ssmax(mgs) )
11583 IF ( ac_opt == 0 ) THEN
11584 IF ( lccn .gt. 1 .and. lccna .lt. 1 ) THEN
11585 an(igs(mgs),jy,kgs(mgs),lccn) = max(0.0, ccnc(mgs) )
11586 ENDIF
11587 ENDIF
11588 IF ( lccnuf .gt. 1 .and. .not. ( lccna .gt. 1 .and. i_uf_or_ccn > 0 ) ) THEN
11589 an(igs(mgs),jy,kgs(mgs),lccnuf) = max(0.0, ccncuf(mgs) )
11590 ENDIF
11591 IF ( lccna .gt. 1 ) THEN
11592 an(igs(mgs),jy,kgs(mgs),lccna) = max(0.0, ccna(mgs) )
11593 ENDIF
11594 ENDIF
11595 IF ( ipconc .ge. 3 .and. rcond == 2 ) THEN
11596 an(igs(mgs),jy,kgs(mgs),lnr) = max(cx(mgs,lr) , 0.0)
11597 ENDIF
11598 end do
11599
11600
1160129998 continue
11602
11603
11604 if ( kz .gt. nz-1 .and. ix .ge. nxi) then
11605 if ( ix .ge. nxi ) then
11606 go to 2200 ! exit gather scatter
11607 else
11608 nzmpb = kz
11609 endif
11610 else
11611 nzmpb = kz
11612 end if
11613
11614 if ( ix .ge. nxi ) then
11615 nxmpb = 1
11616 nzmpb = kz+1
11617 else
11618 nxmpb = ix+1
11619 end if
11620
11621 2000 continue ! inumgs
11622 2200 continue
11623!
11624! end of gather scatter (for this jy slice)
11625
11626
11627!#ifdef COMMAS
11628! GOTO 9999
11629!#endif
11630
11631! Redistribute inappreciable cloud particles and charge
11632!
11633! Redistribution everywhere in the domain...
11634!
11635 IF ( .true. ) THEN
11636
11637 frac = 1.0 ! 0.25 ! 1.0 ! 0.2
11638!
11639! alternate test version for ipconc .ge. 3
11640! just vaporize stuff to prevent noise in the number concentrations
11641
11642
11643 do kz = 1,nz
11644! do jy = 1,1
11645 do ix = 1,nxi
11646
11647 t0(ix,jy,kz) = an(ix,jy,kz,lt)*t77(ix,jy,kz)
11648
11649 zerocx(:) = .false.
11650 DO il = lc,lhab
11651 IF ( iresetmoments == 1 .or. iresetmoments == il ) THEN
11652 IF ( ln(il) > 1 ) zerocx(il) = ( an(ix,jy,kz,ln(il)) < cxmin )
11653 IF ( lz(il) > 1 ) zerocx(il) = ( zerocx(il) .or. an(ix,jy,kz,lz(il)) < zxmin )
11654 ELSE
11655 IF ( il == lc ) THEN
11656 IF ( ln(il) > 1 ) zerocx(il) = ( an(ix,jy,kz,ln(il)) <= 0 ) .and. .not. flag_qndrop ! do not reset if progn=1 (WRF-CHEM)
11657 ELSE
11658 IF ( ln(il) > 1 ) zerocx(il) = ( an(ix,jy,kz,ln(il)) <= 0 )
11659 ENDIF
11660 ENDIF
11661 ENDDO
11662
11663 IF ( lhl .gt. 1 ) THEN
11664
11665 IF ( lzhl .gt. 1 ) THEN
11666
11667 an(ix,jy,kz,lzhl) = max(0.0, an(ix,jy,kz,lzhl) )
11668
11669 IF ( an(ix,jy,kz,lhl) .ge. frac*qxmin(lhl) .and. rescale_low_alpha ) THEN ! check 6th moment
11670
11671 IF ( an(ix,jy,kz,lnhl) .gt. 0.0 ) THEN
11672
11673 IF ( lvhl .gt. 1 ) THEN
11674 IF ( an(ix,jy,kz,lvhl) .gt. 0.0 ) THEN
11675 hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl)
11676 ELSE
11677 hwdn = xdn0(lhl)
11678 ENDIF
11679 hwdn = max( xdnmn(lhl), hwdn )
11680 ELSE
11681 hwdn = xdn0(lhl)
11682 ENDIF
11683
11684 chw = an(ix,jy,kz,lnhl)
11685 g1 = (6.0+alphamin)*(5.0+alphamin)*(4.0+alphamin)/ &
11686 & ((3.0+alphamin)*(2.0+alphamin)*(1.0+alphamin))
11687 z1 = g1*dn(ix,jy,kz)**2*( an(ix,jy,kz,lhl) )*an(ix,jy,kz,lhl)/chw
11688 z1 = z1*(6./(pi*hwdn))**2
11689 ELSE
11690 z1 = 0.0
11691 ENDIF
11692
11693 an(ix,jy,kz,lzhl) = min( z1, an(ix,jy,kz,lzhl) )
11694
11695 IF ( an(ix,jy,kz,lnhl) .lt. 1.e-5 ) THEN
11696! an(ix,jy,kz,lzhl) = 0.9*an(ix,jy,kz,lzhl)
11697 ENDIF
11698 ENDIF
11699
11700 ENDIF !lzhl
11701
11702 if ( an(ix,jy,kz,lhl) .lt. frac*qxmin(lhl) .or. zerocx(lhl) ) then
11703
11704! IF ( an(ix,jy,kz,lhl) .gt. 0 ) THEN
11705 an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lhl)
11706 an(ix,jy,kz,lhl) = 0.0
11707! ENDIF
11708
11709 IF ( ipconc .ge. 5 ) THEN ! .and. an(ix,jy,kz,lnh) .gt. 0.0 ) THEN
11710 an(ix,jy,kz,lnhl) = 0.0
11711 ENDIF
11712
11713 IF ( lvhl .gt. 1 ) THEN
11714 an(ix,jy,kz,lvhl) = 0.0
11715 ENDIF
11716
11717 IF ( lhlw .gt. 1 ) THEN
11718 an(ix,jy,kz,lhlw) = 0.0
11719 ENDIF
11720
11721 IF ( lnhlf .gt. 1 ) THEN
11722 an(ix,jy,kz,lnhlf) = 0.0
11723 ENDIF
11724
11725 IF ( lzhl .gt. 1 ) THEN
11726 an(ix,jy,kz,lzhl) = 0.0
11727 ENDIF
11728
11729 ELSE
11730 IF ( lvol(lhl) .gt. 1 ) THEN ! check density
11731 IF ( an(ix,jy,kz,lvhl) .gt. 0.0 ) THEN
11732 tmp = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl)
11733 ELSE ! in case volume is zero but mass is above threshold (should not happen, of course)
11734 tmp = rho_qhl
11735 an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp
11736 ENDIF
11737
11738 IF ( tmp .lt. xdnmn(lhl) ) THEN
11739 tmp = max( xdnmn(lhl), tmp )
11740 an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp
11741 ENDIF
11742
11743 IF ( tmp .gt. xdnmx(lhl) .and. lhlw .le. 0 ) THEN ! no liquid allowed on hail
11744 tmp = min( xdnmx(lhl), tmp )
11745 an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp
11746 ELSEIF ( tmp .gt. xdnmx(lhl) .and. lhlw .gt. 1 ) THEN ! allow for liquid on hail
11747 fw = an(ix,jy,kz,lhlw)/an(ix,jy,kz,lhl)
11748! tmpmx = xdnmx(lhl) + fw*(xdnmx(lr) - xdnmx(lhl)) ! maximum possible average density
11749 ! it is not exactly linear, but approx. is close enough for this
11750! tmpmx = 1./( (1. - fw)/900. + fw/1000. ) is exact max, where 900 is xdnmx
11751
11752 tmpmx = xdnmx(lhl)/( 1. - fw*(1. - xdnmx(lhl)/xdnmx(lr) ))
11753
11754 IF ( tmp .gt. tmpmx ) THEN
11755 an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmpmx
11756 ENDIF
11757
11758! IF ( tmp .gt. xdnmx(lhl) .and. an(ix,jy,kz,lhlw) .lt. qxmin(lhl) ) THEN
11759! tmp = Min( xdnmx(lhl), tmp )
11760! an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp
11761! ELSEIF ( tmp .gt. xdnmx(lr) ) THEN
11762! tmp = xdnmx(lr)
11763! an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp
11764! ENDIF
11765 ENDIF
11766
11767 IF ( lhlw .gt. 1 ) THEN ! check if basically pure water
11768 IF ( an(ix,jy,kz,lhlw) .gt. 0.98*an(ix,jy,kz,lhl) ) THEN
11769 tmp = xdnmx(lr)
11770 an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp
11771 ENDIF
11772 ENDIF
11773
11774 ENDIF
11775
11776
11777! CHECK INTERCEPT
11778 IF ( ipconc == 5 .and. an(ix,jy,kz,lhl) .gt. qxmin(lhl) .and. alphahl .le. 0.1 .and. lnhl .gt. 1 .and. lzhl == 0 ) THEN
11779
11780 IF ( lvhl .gt. 1 ) THEN
11781 hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl)
11782 ELSE
11783 hwdn = xdn0(lhl)
11784 ENDIF
11785 tmp = (hwdn*an(ix,jy,kz,lnhl))/(dn(ix,jy,kz)*an(ix,jy,kz,lhl))
11786 tmpg = an(ix,jy,kz,lnhl)*(tmp*(3.14159))**(1./3.)
11787 IF ( tmpg .lt. cnohlmn ) THEN
11788 tmp = ( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lhl))*(3.14159))**(1./3.)
11789 an(ix,jy,kz,lnhl) = (cnohlmn/tmp)**(3./4.)
11790 ENDIF
11791
11792 ENDIF
11793! ELSE ! check mean size here?
11794
11795 end if
11796
11797 ENDIF !lhl
11798
11799
11800
11801 IF ( lzh .gt. 1 ) THEN
11802
11803 an(ix,jy,kz,lzh) = max(0.0, an(ix,jy,kz,lzh) )
11804
11805 IF ( .false. .and. an(ix,jy,kz,lh) .ge. frac*qxmin(lh) .and. rescale_low_alpha ) THEN
11806
11807 IF ( an(ix,jy,kz,lnh) .gt. 0.0 ) THEN
11808
11809 IF ( lvh .gt. 1 ) THEN
11810 IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN
11811 hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh)
11812 ELSE
11813 hwdn = xdn0(lh)
11814 ENDIF
11815 hwdn = max( xdnmn(lh), hwdn )
11816 ELSE
11817 hwdn = xdn0(lh)
11818 ENDIF
11819
11820 chw = an(ix,jy,kz,lnh)
11821 g1 = (6.0+alphamin)*(5.0+alphamin)*(4.0+alphamin)/ &
11822 & ((3.0+alphamin)*(2.0+alphamin)*(1.0+alphamin))
11823 z1 = g1*dn(ix,jy,kz)**2*( an(ix,jy,kz,lh) )*an(ix,jy,kz,lh)/chw
11824 z1 = z1*(6./(pi*hwdn))**2
11825 ELSE
11826 z1 = 0.0
11827 ENDIF
11828
11829 an(ix,jy,kz,lzh) = min( z1, an(ix,jy,kz,lzh) )
11830
11831 IF ( an(ix,jy,kz,lnh) .lt. 1.e-5 ) THEN
11832! an(ix,jy,kz,lzh) = 0.9*an(ix,jy,kz,lzh)
11833 ENDIF
11834 ENDIF
11835
11836 ENDIF
11837
11838 if ( an(ix,jy,kz,lh) .lt. frac*qxmin(lh) .or. zerocx(lh) ) then
11839
11840! IF ( an(ix,jy,kz,lh) .gt. 0 ) THEN
11841 an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lh)
11842 an(ix,jy,kz,lh) = 0.0
11843! ENDIF
11844
11845 IF ( ipconc .ge. 5 ) THEN ! .and. an(ix,jy,kz,lnh) .gt. 0.0 ) THEN
11846 an(ix,jy,kz,lnh) = 0.0
11847 ENDIF
11848
11849 IF ( lvh .gt. 1 ) THEN
11850 an(ix,jy,kz,lvh) = 0.0
11851 ENDIF
11852
11853 IF ( lhw .gt. 1 ) THEN
11854 an(ix,jy,kz,lhw) = 0.0
11855 ENDIF
11856
11857 IF ( lnhf .gt. 1 ) THEN
11858 an(ix,jy,kz,lnhf) = 0.0
11859 ENDIF
11860
11861 IF ( lzh .gt. 1 ) THEN
11862 an(ix,jy,kz,lzh) = 0.0
11863 ENDIF
11864
11865 ELSE
11866 IF ( lvol(lh) .gt. 1 ) THEN ! check density
11867 IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN
11868 tmp = dn(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh)
11869 ELSE
11870 tmp = rho_qh
11871 an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp
11872 ENDIF
11873
11874 IF ( tmp .lt. xdnmn(lh) ) THEN
11875 tmp = max( xdnmn(lh), tmp )
11876 an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp
11877 ENDIF
11878
11879 IF ( tmp .gt. xdnmx(lh) .and. lhw .le. 0 ) THEN ! no liquid allowed on graupel
11880 tmp = min( xdnmx(lh), tmp )
11881 an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp
11882 ELSEIF ( tmp .gt. xdnmx(lh) .and. lhw .gt. 1 ) THEN ! allow for liquid on graupel
11883 fw = an(ix,jy,kz,lhw)/an(ix,jy,kz,lh)
11884! tmpmx = xdnmx(lh) + fw*(xdnmx(lr) - xdnmx(lh)) ! maximum possible average density
11885 ! it is not exactly linear, but approx. is close enough for this
11886! tmpmx = 1./( (1. - fw)/900. + fw/1000. ) is exact max, where 900 is xdnmx
11887 tmpmx = xdnmx(lh)/( 1. - fw*(1. - xdnmx(lh)/xdnmx(lr) ))
11888
11889 IF ( tmp .gt. tmpmx ) THEN
11890 an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmpmx
11891 ENDIF
11892
11893! IF ( tmp .gt. xdnmx(lh) .and. an(ix,jy,kz,lhw) .lt. qxmin(lh) ) THEN
11894! tmp = Min( xdnmx(lh), tmp )
11895! an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp
11896! ELSEIF ( tmp .gt. xdnmx(lr) ) THEN
11897! tmp = xdnmx(lr)
11898! an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp
11899! ENDIF
11900
11901 ENDIF
11902
11903 IF ( lhw .gt. 1 ) THEN ! check if basically pure water
11904 IF ( an(ix,jy,kz,lhw) .gt. 0.98*an(ix,jy,kz,lh) ) THEN
11905 tmp = xdnmx(lr)
11906 an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp
11907 ENDIF
11908 ENDIF
11909
11910 ENDIF
11911
11912! CHECK INTERCEPT
11913 IF ( ipconc == 5 .and. an(ix,jy,kz,lh) .gt. qxmin(lh) .and. alphah .le. 0.1 .and. lnh .gt. 1 .and. lzh == 0 ) THEN
11914
11915 IF ( lvh .gt. 1 ) THEN
11916 IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN
11917 hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh)
11918 ELSE
11919 hwdn = xdn0(lh)
11920 ENDIF
11921 hwdn = max( xdnmn(lh), hwdn )
11922 ELSE
11923 hwdn = xdn0(lh)
11924 ENDIF
11925 tmp = (hwdn*an(ix,jy,kz,lnh))/(dn(ix,jy,kz)*an(ix,jy,kz,lh))
11926 tmpg = an(ix,jy,kz,lnh)*(tmp*(3.14159))**(1./3.)
11927 IF ( tmpg .lt. cnohmn ) THEN
11928! tmpg = an(ix,jy,kz,lnh)*( (hwdn*an(ix,jy,kz,lnh))/(dn(ix,jy,kz)*an(ix,jy,kz,lh))*(3.14159))**(1./3.)
11929! tmpg = an(ix,jy,kz,lnh)**(4./3.)*( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lh))*(3.14159))**(1./3.)
11930 tmp = ( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lh))*(3.14159))**(1./3.)
11931 an(ix,jy,kz,lnh) = (cnohmn/tmp)**(3./4.)
11932 ENDIF
11933
11934 ENDIF
11935
11936 end if
11937
11938
11939 if ( an(ix,jy,kz,ls) .lt. frac*qxmin(ls) .or. zerocx(ls) & ! .or. an(ix,jy,kz,lns) .lt. 0.1 ! .and.
11940 & ) then
11941 IF ( t0(ix,jy,kz) .lt. 273.15 ) THEN
11942! IF ( an(ix,jy,kz,ls) .gt. 0 ) THEN
11943 an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,ls)
11944 an(ix,jy,kz,ls) = 0.0
11945! ENDIF
11946
11947 IF ( ipconc .ge. 4 ) THEN ! .and. an(ix,jy,kz,lns) .gt. 0.0 ) THEN !
11948! an(ix,jy,kz,lni) = an(ix,jy,kz,lni) + an(ix,jy,kz,lns)
11949 an(ix,jy,kz,lns) = 0.0
11950 ENDIF
11951
11952 IF ( lvs .gt. 1 ) THEN
11953 an(ix,jy,kz,lvs) = 0.0
11954 ENDIF
11955
11956 IF ( lsw .gt. 1 ) THEN
11957 an(ix,jy,kz,lsw) = 0.0
11958 ENDIF
11959
11960 ELSE
11961! IF ( an(ix,jy,kz,ls) .gt. 0 ) THEN
11962 an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,ls)
11963 an(ix,jy,kz,ls) = 0.0
11964! ENDIF
11965
11966 IF ( lvs .gt. 1 ) THEN
11967 an(ix,jy,kz,lvs) = 0.0
11968 ENDIF
11969
11970 IF ( lsw .gt. 1 ) THEN
11971 an(ix,jy,kz,lsw) = 0.0
11972 ENDIF
11973
11974 IF ( ipconc .ge. 4 ) THEN ! .and. an(ix,jy,kz,lns) .gt. 0.0 ) THEN !
11975! an(ix,jy,kz,lnr) = an(ix,jy,kz,lnr) + an(ix,jy,kz,lns)
11976 an(ix,jy,kz,lns) = 0.0
11977 ENDIF
11978
11979 ENDIF
11980
11981
11982 ELSEIF ( lvol(ls) .gt. 1 ) THEN ! check density
11983 IF ( an(ix,jy,kz,lvs) .gt. 0.0 ) THEN
11984 tmp = dn(ix,jy,kz)*an(ix,jy,kz,ls)/an(ix,jy,kz,lvs)
11985 IF ( tmp .gt. xdnmx(ls) .or. tmp .lt. xdnmn(ls) ) THEN
11986 tmp = min( xdnmx(ls), max( xdnmn(ls), tmp ) )
11987 an(ix,jy,kz,lvs) = dn(ix,jy,kz)*an(ix,jy,kz,ls)/tmp
11988 ENDIF
11989 ELSE
11990 tmp = rho_qs
11991 an(ix,jy,kz,lvs) = dn(ix,jy,kz)*an(ix,jy,kz,ls)/tmp
11992 ENDIF
11993
11994
11995 end if
11996
11997 IF ( lzr > 1 ) THEN
11998 an(ix,jy,kz,lzr) = max(0.0, an(ix,jy,kz,lzr) )
11999 ENDIF
12000
12001 if ( an(ix,jy,kz,lr) .lt. frac*qxmin(lr) .or. zerocx(lr) &
12002 & ) then
12003 an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lr)
12004 an(ix,jy,kz,lr) = 0.0
12005 IF ( ipconc .ge. 3 ) THEN
12006! an(ix,jy,kz,lnc) = an(ix,jy,kz,lnc) + an(ix,jy,kz,lnr)
12007 an(ix,jy,kz,lnr) = 0.0
12008 ENDIF
12009
12010 IF ( lzr > 1 ) THEN
12011 an(ix,jy,kz,lzr) = 0.0
12012 ENDIF
12013
12014 end if
12015
12016!
12017! for qci
12018!
12019 IF ( an(ix,jy,kz,li) .le. frac*qxmin(li) .or. zerocx(li) & ! .or. an(ix,jy,kz,lni) .lt. 0.1
12020 & ) THEN
12021 an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,li)
12022 an(ix,jy,kz,li)= 0.0
12023 IF ( ipconc .ge. 1 ) THEN
12024 an(ix,jy,kz,lni) = 0.0
12025 ENDIF
12026 ENDIF
12027
12028!
12029! for qis
12030!
12031 IF ( lis > 1 ) THEN ! {
12032 IF ( an(ix,jy,kz,lis) .le. frac*qxmin(lis) .or. zerocx(lis) & ! .or. an(ix,jy,kz,lni) .lt. 0.1
12033 & ) THEN ! { {
12034 an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lis)
12035 an(ix,jy,kz,lis)= 0.0
12036 IF ( ipconc .ge. 1 ) THEN
12037 an(ix,jy,kz,lnis) = 0.0
12038 ENDIF
12039
12040 ELSEIF ( icespheres >= 2 ) THEN ! } {
12041 km1 = max(1, kz-1)
12042 IF ( 0.5*( w(ix,jy,kz) + w(ix,jy,kz+1)) < -1.0 .or. &
12043 & (icespheres == 3 .and. ( t0(ix,jy,kz) < 232.15 .or. an(ix,jy,kz,lc) < qxmin(lc) ) ) .or. &
12044 & (icespheres == 5 .and. ( t0(ix,jy,kz) < 232.15 .or. &
12045 & ( an(ix,jy,kz,lc) < qxmin(lc) .and. an(ix,jy,km1,lc) < qxmin(lc) )) ) .or. &
12046 & (icespheres == 4 .and. ( t0(ix,jy,kz) < 235.15 )) ) THEN ! transfer to regular ice crystals in downdraft or at low temp
12047 an(ix,jy,kz,li) = an(ix,jy,kz,li) + an(ix,jy,kz,lis)
12048 an(ix,jy,kz,lni) = an(ix,jy,kz,lni) + an(ix,jy,kz,lnis)
12049 an(ix,jy,kz,lis)= 0.0
12050 an(ix,jy,kz,lnis)= 0.0
12051
12052 ENDIF
12053
12054 ENDIF ! } }
12055 ENDIF ! }
12056
12057!
12058! for qcw
12059!
12060
12061 IF ( an(ix,jy,kz,lc) .le. frac*qxmin(lc) .or. zerocx(lc) &
12062 & ) THEN
12063 an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lc)
12064 an(ix,jy,kz,lc)= 0.0
12065 IF ( ipconc .ge. 2 ) THEN
12066 IF ( lccn .gt. 1 .or. ac_opt == 1 ) THEN
12067 IF ( irenuc < 5 .and. lccna <= 1 ) THEN
12068 IF ( ac_opt == 0 ) THEN
12069 an(ix,jy,kz,lccn) = an(ix,jy,kz,lccn) + max(0.0,an(ix,jy,kz,lnc))
12070 ENDIF
12071 ELSEIF ( lccna > 1 ) THEN
12072 an(ix,jy,kz,lccna) = max( 0.0, an(ix,jy,kz,lccna) - max(0.0,an(ix,jy,kz,lnc)) )
12073 ENDIF
12074 ENDIF
12075 an(ix,jy,kz,lnc) = 0.0
12076 IF ( lccn > 1 ) an(ix,jy,kz,lccn) = max( 0.0, an(ix,jy,kz,lccn) )
12077
12078 IF ( lccna > 0 .and. ac_opt == 0 ) THEN ! apply exponential decay to activated CCN to restore to environmental value
12079 IF ( restoreccn ) THEN
12080 tmp = an(ix,jy,kz,li) + an(ix,jy,kz,ls)
12081
12082 IF ( an(ix,jy,kz,lccna) > 1. .and. tmp < qxmin(li) ) an(ix,jy,kz,lccna) = an(ix,jy,kz,lccna)*exp(-dtp/ccntimeconst)
12083 ENDIF
12084 ELSEIF ( lccn > 1 .and. restoreccn .and. ac_opt == 0 ) THEN
12085 ! in this case, we are treating the ccn field as ccna
12086 tmp = an(ix,jy,kz,li) + an(ix,jy,kz,ls)
12087! IF ( ny == 2 .and. ix == nx/2 ) THEN
12088! write(0,*) 'restore: k, qccn,exp = ',kz,qccn,dn(ix,jy,kz)*qccn,Exp(-dtp/ccntimeconst)
12089! write(0,*) 'ccn1,ccn2 = ',an(ix,jy,kz,lccn),dn(ix,jy,kz)*qccn - Max(0.0 , dn(ix,jy,kz)*qccn - an(ix,jy,kz,lccn))*Exp(-dtp/ccntimeconst)
12090! ENDIF
12091 IF ( an(ix,jy,kz,lccn) > 1. .and. tmp < qxmin(li) .and. ( an(ix,jy,kz,lccn) < dn(ix,jy,kz)*qccn .or. .not. invertccn ) ) THEN
12092 ! an(ix,jy,kz,lccn) = &
12093 ! an(ix,jy,kz,lccn) + Max(0.0 , dn(ix,jy,kz)*qccn - an(ix,jy,kz,lccn))*(1.0 - Exp(-dtp/ccntimeconst))
12094 ! Equivalent form after expanding last term:
12095 an(ix,jy,kz,lccn) = &
12096 dn(ix,jy,kz)*qccn - max(0.0 , dn(ix,jy,kz)*qccn - an(ix,jy,kz,lccn))*exp(-dtp/ccntimeconst)
12097 ENDIF
12098
12099 ENDIF
12100
12101 ENDIF
12102
12103 ENDIF
12104
12105 end do
12106! end do
12107 end do
12108
12109 ENDIF ! true/false
12110
12111 IF ( ndebug .ge. 1 ) write(6,*) 'END OF ICEZVD_DR'
12112!
12113!
12114
12115
12116 9999 RETURN
12117
12118 END SUBROUTINE nucond
12119
12120
12121! #####################################################################
12122! #####################################################################
12125
12126
12127
12128
12129!c--------------------------------------------------------------------------
12130!
12131!
12132!--------------------------------------------------------------------------
12133!
12134
12135 subroutine nssl_2mom_gs &
12136 & (nx,ny,nz,na,jyslab &
12137 & ,nor,norz &
12138 & ,dtp,gz &
12139 & ,t0,t1,t2,t3,t4,t5,t6,t7,t8,t9 &
12140 & ,an,dn,p2 &
12141 & ,pn,w,iunit &
12142 & ,t00,t77, &
12143 & ventr,ventc,c1sw,jgs,ido, &
12144 & xdnmx,xdnmn, &
12145! & ln,ipc,lvol,lz,lliq, &
12146 & cdx, &
12147 & xdn0,tmp3d,tkediss &
12148 & ,thproc,numproc,dx1,dy1,ngs &
12149 & ,timevtcalc,axtra,io_flag &
12150 & , has_wetscav,rainprod2d, evapprod2d, alpha2d &
12151 & ,errmsg,errflg &
12152 & ,elec,its,ids,ide,jds,jde &
12153 & )
12154
12155
12156!
12157!--------------------------------------------------------------------------
12158!
12159! Ziegler 1985 parameterized microphysics (also Zrnic et al. 1993)
12160! 1) cloud water
12161! 2) rain
12162! 3) column ice
12163! 6) snow
12164! 11) graupel/hail
12165!
12166!--------------------------------------------------------------------------
12167!
12168! Notes:
12169!
12170! 4/27/2009: allows for liquid water to be advected on snow and graupel particles using flag "mixedphase"
12171!
12172! 3/14/2007: (APS) added qproc temp to make microphysic process timeseries
12173!
12174! 10/17/2006: added flag (iehw) to select how to calculate ehw
12175!
12176! 10/5/2006: switched chacr to integrated version rather than assuming that average rain
12177! drop mass does not change. This acts to reduce rain size somewhat via graupel
12178! collection.
12179! Use Mason data for ehw, with scaling toward ehw=1 as air density decreases.
12180!
12181! 10/3/2006: Turned off Meyers nucleation for T > -5 (can turn on with imeyers5 flag)
12182! Turned off contact nucleation in updrafts
12183!
12184! 7/24/2006: Turned on Meyers nucleation for -5 < T < 0
12185!
12186! 5/12/2006: Converted qsacw/csacw and qsaci/csaci to Z93
12187!
12188! 5/12/2006: Put a threshold on Bigg rain freezing. If the frozen drops
12189! have an average volume less than xvhmn, then the drops are put
12190! into snow instead of graupel/hail.
12191!
12192! Fixed bug when vapor deposition was limited.
12193!
12194! 5/13/2006: Note that qhacr has a large effect, but Z85 did not include it.
12195! Turned off qsacr (set to zero).
12196!
12197! 9/14/2007: erm: recalculate vx(lh) after setting xdn(lh) in case xdn was out of allowed range.
12198! added parameter rimc3 for minimum rime density. Default value set at 170. kg/m**3
12199! instead of previous use of 100. (Farley, 1987)
12200!
12201!--------------------------------------------------------------------------
12202!
12203! general declarations
12204!
12205!--------------------------------------------------------------------------
12206!
12207!
12208!
12209
12210
12211 implicit none
12212!
12213! integer icond
12214! parameter ( icond = 2 )
12215
12216 integer, parameter :: ng1 = 1
12217
12218 integer nx,ny,nz,na,nba,nv
12219 integer nor,norz,istag,jstag,kstag ! ,nht,ngt,igsr
12220 integer iwrite
12221 real dtp,dx,dy,dz
12222
12223 logical, intent(in) :: io_flag
12224
12225 integer itile,jtile,ktile
12226 integer ixbeg,jybeg
12227 integer ixend,jyend,kzend,kzbeg
12228 integer nxend,nyend,nzend,nzbeg
12229 integer :: my_rank = 0
12230 integer, parameter :: myprock = 1, nprock = 1
12231 logical, intent(in) :: has_wetscav
12232 integer, intent(in) :: numproc
12233 real, intent(inout) :: thproc(nz,numproc)
12234 real, intent(in) :: dx1,dy1
12235 real rainprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz)
12236 real evapprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz)
12237
12238
12239 real :: alpha2d(-nor+1:nx+nor,-norz+ng1:nz+norz,3)
12240
12241 real, parameter :: tfrdry = 243.15
12242
12243 logical lrescalelow(lc:lhab)
12244 real tkediss(-nor+1:nx+nor,-norz+ng1:nz+norz)
12245 real axtra(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,nxtra)
12246
12247 real :: galpharaut
12248 real :: xvbarmax
12249
12250 integer jyslab,its,ids,ide,jds,jde ! domain boundaries
12251 integer, intent(in) :: iunit !,iunit0
12252 real qvex
12253 integer iraincv, icgxconv
12254 parameter( iraincv = 1, icgxconv = 1)
12255 real ffrz
12256 real :: ffrzh = 1.0
12257
12258 real qcitmp,cirdiatmp ! ,qiptmp,qirtmp
12259 real ccwtmp,ccitmp ! ,ciptmp,cirtmp
12260 real cpqc,cpci ! ,cpip,cpir
12261 real cpqc0,cpci0 ! ,cpip0,cpir0
12262 real scfac ! ,cpip1
12263
12264 double precision dp1
12265
12266 double precision frac, frach, xvfrz, xvbiggsnow
12267
12268 double precision :: timevtcalc
12269 double precision :: dpt1,dpt2
12270
12271 logical, parameter :: gammacheck = .false.
12272 integer :: luindex
12273 double precision :: tmpgam
12274 logical, parameter :: usegamxinfcnu = .false.
12275 logical, parameter :: usegamxinf = .false.
12276 logical, parameter :: usegamxinf2 = .false.
12277 logical, parameter :: usegamxinf3 = .false.
12278! real rar ! rime accretion rate as calculated from qxacw
12279
12280 ! CCPP error handling
12281 character(len=*), intent( out) :: errmsg
12282 integer, intent( out) :: errflg
12283! a few vars for time-split fallout
12284 real vtmax
12285 integer n,ndfall
12286
12287 double precision chgneg,chgpos,sctot
12288
12289 real temgtmp
12290
12291 real pb(-norz+ng1:nz+norz)
12292 real pinit(-norz+ng1:nz+norz)
12293
12294 real gz(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) ! dz
12295
12296 real qimax,xni0,roqi0
12297
12298
12299 real dv
12300
12301 real dtptmp
12302 integer itest,nidx,id1,jd1,kd1
12303 parameter(itest=1)
12304 parameter(nidx=10)
12305 parameter(id1=1,jd1=1,kd1=1)
12306 integer ierr
12307 integer iend
12308
12309 integer ix,kz, il, ic, ir, icp1, irp1, ip1,jp1,kp1
12310 integer :: jy
12311 integer i,j,k,i1
12312 integer kzb,kze
12313 real slope1, slope2
12314 real x1, x2, x3
12315 real eps,eps2
12316 parameter(eps=1.e-20,eps2=1.e-5)
12317!
12318! Other elec. vars
12319!
12320 real temele
12321 real trev
12322
12323 logical ldovol, ishail, ltest, wtest
12324 logical , parameter :: alp0flag = .false.
12325!
12326!
12327! wind indicies
12328!
12329 integer mu,mv,mw
12330 parameter(mu=1,mv=2,mw=3)
12331!
12332! conversion parameters
12333!
12334 integer mqcw,mqxw,mtem,mrho,mtim
12335 parameter(mqcw=21,mqxw=21,mtem=21,mrho=5,mtim=6)
12336
12337 real xftim,xftimi,yftim, xftem,yftem, xfqcw,yfqcw, xfqxw,yfqxw
12338 parameter(xftim=0.05,xftimi = 1./xftim,yftim=1.)
12339 parameter(xftem=0.5,yftem=1.)
12340 parameter(xfqcw=2000.,yfqcw=1.)
12341 parameter(xfqxw=2000.,yfqxw=1.)
12342 real dtfac
12343 parameter( dtfac = 1.0 )
12344 integer ido(lc:lqmx)
12345
12346! integer iexy(lc:lqmx,lc:lqmx)
12347! integer ieswi, ieswir, ieswip, ieswc, ieswr
12348! integer ieglsw, iegli, ieglir, ieglip, ieglc, ieglr
12349! integer iegmsw, iegmi, iegmir, iegmip, iegmc, iegmr
12350! integer ieghsw, ieghi, ieghir, ieghip, ieghc, ieghr
12351! integer iefwsw, iefwi, iefwir, iefwip, iefwc, iefwr
12352! integer iehwsw, iehwi, iehwir, iehwip, iehwc, iehwr
12353! integer iehlsw, iehli, iehlir, iehlip, iehlc, iehlr
12354! real delqnsa, delqxsa, delqnsb, delqxsb, delqnia, delqxia
12355! real delqnra, delqxra
12356
12357 real delqnxa(lc:lqmx)
12358 real delqxxa(lc:lqmx)
12359!
12360! external temporary arrays
12361!
12362 real t00(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz)
12363 real t77(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz)
12364
12365 real t0(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz)
12366 real t1(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz)
12367 real t2(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz)
12368 real t3(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz)
12369 real t4(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz)
12370 real t5(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz)
12371 real t6(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz)
12372 real t7(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz)
12373 real t8(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz)
12374 real t9(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz)
12375
12376 real p2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz) ! perturbation Pi
12377 real pn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz)
12378 real an(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,na)
12379 real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz)
12380 real w(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz)
12381
12382 real tmp3d(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz)
12383
12384!
12385! declarations microphyscs and for gather/scatter
12386!
12387 integer nxmpb,nzmpb,nxz
12388 integer jgs,mgs,ngs,numgs
12389 integer, parameter :: ngsz = 500
12390 integer ntt
12391 parameter(ntt=300)
12392
12393 real dvmgs(ngs)
12394
12395 integer ngscnt,igs(ngs),kgs(ngs)
12396 integer kgsp(ngs),kgsm(ngs),kgsm2(ngs)
12397 integer ncuse
12398 parameter(ncuse=0)
12399 integer il0(ngs),il5(ngs),il2(ngs),il3(ngs)
12400! integer il1m(ngs),il2m(ngs),il3m(ngs),il4m(ngs),il5m(ngs)
12401!
12402 real tdtol,temsav,tfrcbw,tfrcbi
12403 real, parameter :: thnuc = 235.15
12404!
12405! Ice Multiplication Arrays.
12406!
12407 real fimt1(ngs),fimta(ngs),fimt2(ngs) !,qmul1(ngs),qmul2(ngs)
12408 real xcwmas
12409!
12410!
12411! Variables for Ziegler warm rain microphysics
12412!
12413
12414
12415 real ccnc(ngs),ccin(ngs),cina(ngs),ccna(ngs)
12416 real cwnccn(ngs)
12417 real sscb ! 'cloud base' SS threshold
12418 parameter( sscb = 2.0 )
12419 integer idecss ! flag to turn on (=1) decay of ssmax when no cloud or ice crystals
12420 parameter( idecss = 1 )
12421 integer iba ! flag to do condensation/nucleation in 1st or 2nd loop
12422 ! =0 to use ad to calculate SS
12423 ! =1 to use an at end of main jy loop to calculate SS
12424 parameter(iba = 1)
12425 integer ifilt ! =1 to filter ssat, =0 to set ssfilt=ssat
12426 parameter( ifilt = 0 )
12427 real temp1,temp2 ! ,ssold
12428 real :: mwat, mice, dice, mwshed, fwmax, fw, mwcrit, massfactor, tmpdiam
12429 real, parameter :: shedalp = 3. ! set 3 for maximum mass diameter (same as area-weighted diameter), 4 for mass-weighted diameter
12430 real ssmax(ngs) ! maximum SS experienced by a parcel
12431 real ssmx
12432 real dnnet,dqnet
12433! real cnu,rnu,snu,cinu
12434! parameter ( cnu = 0.0, rnu = -0.8, snu = -0.8, cinu = 0.0 )
12435 real bfnu, bfnu0, bfnu1
12436 parameter( bfnu0 = (rnu + 2.0)/(rnu + 1.0) )
12437 real ventr, ventc
12438 real volb
12439 double precision t2s, xdp
12440 double precision xl2p(ngs),rb(ngs)
12441 real, parameter :: aa1 = 9.44e15, aa2 = 5.78e3 ! a1 in Ziegler
12442! snow parameters:
12443 real, parameter :: cexs = 0.1, cecs = 0.5
12444 real, parameter :: rvt = 0.104 ! ratio of collection kernels (Zrnic et al, 1993)
12445 real, parameter :: kfrag = 1.0e-6 ! rate coefficent for collisional splintering (Schuur & Rutledge 00b)
12446 real, parameter :: mfrag = 1.0e-10 ! assumed ice fragment mass for collisional splintering (Schuur & Rutledge 00b)
12447 double precision cautn(ngs), rh(ngs), nh(ngs)
12448 real ex1, ft, rhoinv(ngs)
12449 double precision ec0(ngs)
12450
12451 real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp1,tmp2,tmp3,tmp4,tmp5,tmp6,temp3 ! , sstdy, super
12452 real :: flim
12453 real dw,dwr
12454 double precision :: tmpz, tmpzmlt
12455 real ratio, delx, dely
12456 real dbigg,volt
12457 real chgtmp,fac,mixedphasefac
12458 real x,y,y2,del,r,rtmp,alpr
12459 double precision :: vent1,vent2
12460 double precision :: g1palp,g4palp
12461 double precision :: g1palpinf,g4palpinf
12462 real fqt !charge separation as fn of temperature from Dong and Hallett 1992
12463 real bs
12464 real v1, v2
12465 real d1r, d1i, d1s, e1i
12466 real c1sw ! integration factor for snow melting with snu = -0.8
12467 real, parameter :: vr1mm = 5.23599e-10 ! volume of 1mm diameter sphere (m**3)
12468 real, parameter :: vr3mm = 5.23599e-10*(3.0/1.)**3 ! volume of a 3 mm diameter sphere (m**3) (Rasmussen et al. 1984b, JAS)
12469 real, parameter :: vr4p5mm = 5.23599e-10*(4.5/1.)**3 ! volume of 4.5mm diameter sphere (m**3) (Rasmussen et al. 1984b, JAS)
12470 real vmlt,vshd, vshdgs(ngs,lh:lhab), maxmassfac(lc:lhab)
12471 real rhosm
12472 parameter( rhosm = 500. )
12473 integer nc ! condensation step
12474 real dtcon,dtcon1,dtcon2 ! condensation time step (dtcon*nc = dtp)
12475 real delta
12476 integer ltemq1,ltemq1m ! ,ltemq1m2
12477 real dqv,qv1,ss1,ss2,qvs1,dqvs,dtemp,dt1 ! temporaries for condensation
12478 real ssi1, ssi2, dqvi, dqvis, dqvii,qis1
12479 real dqvr, dqc, dqr, dqi, dqs
12480 real qv1m,qvs1m,ss1m,ssi1m,qis1m
12481 real cwmastmp
12482 real dcloud,dcloud2 ! ,as, bs
12483 real cn(ngs)
12484 double precision xvc, xvr
12485 real mwfac
12486! real es(ngs) ! ss(ngs),
12487! real eis(ngs)
12488
12489 real rwmasn,rwmasx
12490
12491 real vgra,vfrz
12492 parameter( vgra = 0.523599*(1.0e-3)**3 )
12493
12494! real, parameter :: epsi = 0.622
12495! real, parameter :: d = 0.266
12496 real :: d, dold, denom,denominv,vth
12497 double precision :: h1, h2, h3, h4,denomdp, denominvdp
12498 real r1,qevap ! ,slv
12499
12500 real vr,nrx,chw,g1,qr,z,z1,rdi,alp,xnutmp,xnuc,g1r,rd1,rdia,rmas
12501 real :: snowmeltmass = 0
12502
12503! real, parameter :: rhofrz = 900. ! density of graupel from newly-frozen rain
12504 real, parameter :: rimedens = 500. ! default rime density
12505
12506! real svc(ngs) ! droplet volume
12507!
12508! contact freezing nucleation
12509!
12510 real raero,kaero !assumd aerosol radius, thermal conductivity
12511 parameter( raero = 3.e-7, kaero = 5.39e-3 )
12512 real kb ! Boltzman constant J K-1
12513 parameter(kb = 1.3807e-23)
12514
12515 real knud(ngs),knuda(ngs) !knudsen number and correction factor
12516 real gtp(ngs) !G(T,p) = 1/(a' + b') Cotton 72b
12517 real dfar(ngs) !aerosol diffusivity
12518 real fn1(ngs),fn2(ngs),fnft(ngs)
12519
12520 real ccia(ngs)
12521 real ctfzbd(ngs),ctfzth(ngs),ctfzdi(ngs)
12522!
12523! misc
12524!
12525 real ni,nis,nr,d0
12526 real dqvcnd(ngs),dqwv(ngs),dqcw(ngs),dqci(ngs),dqcitmp(ngs),dqwvtmp(ngs)
12527 real tempc(ngs)
12528 real temg(ngs),temcg(ngs),theta(ngs),qvap(ngs)
12529 real temgkm1(ngs), temgkm2(ngs)
12530 real temgx(ngs),temcgx(ngs)
12531 real qvs(ngs),qis(ngs),qss(ngs),pqs(ngs)
12532 real elv(ngs),elf(ngs),els(ngs)
12533 real tsqr(ngs),ssi(ngs),ssw(ngs),ssi0(ngs)
12534 real qcwtmp(ngs),qtmp,qtot(ngs)
12535 real qcond(ngs)
12536 real ctmp, sctmp
12537 real cimasn,cimasx,ccimx
12538 real pid4
12539 real cs,ds,gf7,gf6,gf5,gf4,gf3,gf2,gf1
12540 real gcnup1,gcnup2
12541 real gf73rds, gf83rds
12542 real gamice73fac, gamsnow73fac
12543 real gf43rds, gf53rds
12544 real aradcw,bradcw,cradcw,dradcw,cwrad,rwrad,rwradmn
12545 parameter( rwradmn = 50.e-6 )
12546 real dh0
12547 real dg0(ngs),df0(ngs)
12548 real dhwet(ngs),dhlwet(ngs),dfwet(ngs)
12549
12550 real clionpmx,clionnmx
12551 parameter(clionpmx=1.e9,clionnmx=1.e9) ! Takahashi 84
12552!
12553! other arrays
12554
12555 real fwet1(ngs),fwet2(ngs)
12556 real fmlt1(ngs),fmlt2(ngs),fmlt1e(ngs)
12557 real fvds(ngs),fvce(ngs),fiinit(ngs)
12558 real fvent(ngs),fraci(ngs),fracl(ngs)
12559!
12560 real fai(ngs),fav(ngs),fbi(ngs),fbv(ngs)
12561 real felv(ngs),fels(ngs),felf(ngs)
12562 real felvcp(ngs),felscp(ngs),felfcp(ngs)
12563 real felvpi(ngs),felspi(ngs),felfpi(ngs)
12564 real felvs(ngs),felss(ngs) ! ,felfs(ngs)
12565 real fwvdf(ngs),ftka(ngs),fthdf(ngs)
12566 real fadvisc(ngs),fakvisc(ngs)
12567 real fci(ngs),fcw(ngs) ! heat capacities of ice and liquid
12568 real fschm(ngs),fpndl(ngs)
12569 real fgamw(ngs),fgams(ngs)
12570 real fcqv1(ngs),fcqv2(ngs),fcc3(ngs)
12571
12572 real cvm,cpm,rmm
12573
12574 real, parameter :: cpv = 1885.0 ! specific heat of water vapor at constant pressure
12575!
12576 real fcci(ngs), fcip(ngs)
12577!
12578 real :: sfm1(ngs),sfm2(ngs)
12579 real :: gfm1(ngs),gfm2(ngs)
12580 real :: ffm1(ngs),ffm2(ngs)
12581 real :: hfm1(ngs),hfm2(ngs)
12582
12583 logical :: wetsfc(ngs),wetsfchl(ngs),wetsfcf(ngs)
12584 logical :: wetgrowth(ngs), wetgrowthhl(ngs), wetgrowthf(ngs)
12585
12586 real qitmp(ngs),qistmp(ngs)
12587
12588 real rzxh(ngs), rzxhl(ngs), rzxhlh(ngs), rzxhlf(ngs)
12589 real rzxs(ngs), rzxf(ngs)
12590! real axh(ngs),bxh(ngs),axhl(ngs),bxhl(ngs)
12591 real cdh(ngs),cdhl(ngs)
12592 real :: axx(ngs,lh:lhab),bxx(ngs,lh:lhab)
12593 real vt2ave(ngs)
12594
12595 real :: qcwresv(ngs), ccwresv(ngs) ! "reserved" droplet mass and number that are too small for accretion
12596
12597 real :: lfsave(ngs,6)
12598 real :: qx(ngs,lv:lhab)
12599 real :: qxw(ngs,ls:lhab)
12600 real :: qxwlg(ngs,lh:lhab)
12601 real :: chxf(ngs,lh:lhab)
12602 real :: cx(ngs,lc:lhab)
12603 real :: cxmxd(ngs,lc:lhab)
12604 real :: qxmxd(ngs,lv:lhab)
12605 real :: scx(ngs,lc:lhab)
12606 real :: xv(ngs,lc:lhab)
12607 real :: vtxbar(ngs,lc:lhab,3)
12608 real :: xmas(ngs,lc:lhab)
12609 real :: xdn(ngs,lc:lhab)
12610 real :: xdntmp(ngs,lc:lhab)
12611 real :: cdxgs(ngs,lc:lhab)
12612 real :: xdia(ngs,lc:lhab,3)
12613 real :: vtwtdia(ngs,lr:lhab) ! sweep-out volume weighted diameter
12614 real :: rarx(ngs,ls:lhab)
12615 real :: vx(ngs,li:lhab)
12616 real :: rimdn(ngs,li:lhab)
12617 real :: raindn(ngs,li:lhab)
12618 real :: alpha(ngs,lc:lhab)
12619 real :: dab0lh(ngs,lc:lhab,lc:lhab)
12620 real :: dab1lh(ngs,lc:lhab,lc:lhab)
12621 real :: zx(ngs,lr:lhab)
12622 real :: zxmxd(ngs,lr:lhab)
12623 real :: g1x(ngs,lr:lhab)
12624
12625
12626 real :: qsimxdep(ngs) ! max sublimation of qi+qs+qis
12627 real :: qsimxsub(ngs) ! max depositionof qi+qs+qis
12628 logical,parameter :: DoSublimationFix = .true.
12629 real :: qrtmp(ngs),qvtmp(ngs),qctmp(ngs)
12630 real :: felvcptmp,felscptmp,qsstmp
12631 real :: thetatmp, thetaptmp, temcgtmp,qvaptmp
12632 real :: qvstmp, qisstmp, qvptmp, qitmp1, qctmp1
12633
12634 real :: galphrout
12635
12636 real ventrx(ngs)
12637 real ventrxn(ngs)
12638 real g1shr, alphashr
12639 real g1mlr, alphamlr
12640 real g1smlr, alphasmlr
12641 real massfacshr, massfacmlr
12642
12643 real :: qhgt8mm ! ice mass greater than 8mm
12644 real :: qhwgt8mm ! ice + max water mass greater than 8mm
12645 real :: qhgt10mm ! mass greater than 10mm
12646 real :: qhgt20mm ! mass greater than 20mm
12647 real :: fwmhtmp
12648 real, parameter :: fwmhtmptem = -15. ! temperature at which fwmhtmp fully switches to liquid water only being on large particles
12649 real, parameter :: d1t = (6.0 * 0.268e-3/(917.* pi))**(1./3.) ! d1t is the diameter of the ice sphere with the mass (0.268e-3 kg) of an 8mm spherical drop
12650 real, parameter :: srasheym = 0.1389 ! slope fraction from Rasmussen and Heymsfield
12651!
12652 real swvent(ngs),hwvent(ngs),rwvent(ngs),hlvent(ngs),hwventy(ngs),hlventy(ngs),rwventz(ngs)
12653 real hxventtmp
12654 real hlventinc(ngs),hwventinc(ngs)
12655 integer, parameter :: ndiam = 10
12656 integer :: numdiam
12657 real hwvent0(ndiam+4),hlvent0 ! 0 to d1
12658 real hwvent1,hlvent1 ! d1 to infinity
12659 real hwvent2,hlvent2 ! d2 to infinity
12660 real gama0,gamb0
12661 real gama1,gamb1
12662 real gama2,gamb2
12663! real, parameter :: mltdiam1 = 9.0e-3, mltdiam1p5 = 16.0e-3, mltdiam2 = 19.0e-3, mltdiam3 = 200.0e-3, mltdiam05 = 4.5e-3
12664 real :: mltdiam(ndiam+4)
12665 real mltmass0inv,mltmass1inv,mltmass2inv, mltmass1cgs, mltmass2cgs,mltmass3inv, mltmass3cgs
12666 real qhmlr0, qhmlr05, qhmlr1, qhmlr2,qhmlr3, qhmlr12, qhmlr23
12667 real qhlmlr0, qhlmlr05, qhlmlr1, qhlmlr2,qhlmlr3, qhlmlr12, qhlmlr23
12668 real qxd1, cxd1, zxd1 ! mass and number up to mltdiam1
12669 real qxd05, cxd05 ! mass and number up to mltdiam1/2
12670
12671 real :: qxd(ndiam+4), cxd(ndiam+4), qhml(ndiam+4), qhml0(ndiam+4)
12672 real :: dqxd(ndiam+4), dcxd(ndiam+4), dqhml(ndiam+4)
12673
12674
12675 real civent(ngs)
12676 real isvent(ngs)
12677!
12678 real xmascw(ngs)
12679 real xdnmx(lc:lhab), xdnmn(lc:lhab)
12680 real dnmx
12681 real :: xdiamxmas(ngs,lc:lhab)
12682!
12683 real cilen(ngs) ! ,ciplen(ngs)
12684!
12685!
12686 real rwcap(ngs),swcap(ngs)
12687 real hwcap(ngs)
12688 real hlcap(ngs)
12689 real cicap(ngs)
12690 real iscap(ngs)
12691
12692 real qvimxd(ngs)
12693 real qimxd(ngs),qismxd(ngs),qcmxd(ngs),qrmxd(ngs),qsmxd(ngs),qhmxd(ngs),qhlmxd(ngs)
12694 real cimxd(ngs),ccmxd(ngs),crmxd(ngs),csmxd(ngs),chmxd(ngs)
12695 real cionpmxd(ngs),cionnmxd(ngs)
12696 real clionpmxd(ngs),clionnmxd(ngs)
12697
12698
12699 real elec(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) ! Ez (elecsave)
12700
12701!
12702!
12703 ! Hallett-Mossop arrays
12704 real chmul1(ngs),chlmul1(ngs),csmul1(ngs),csmul(ngs)
12705 real qhmul1(ngs),qhlmul1(ngs),qsmul1(ngs),qsmul(ngs)
12706
12707 ! splinters from drop freezing
12708 real csplinter(ngs),qsplinter(ngs)
12709 real csplinter2(ngs),qsplinter2(ngs)
12710!
12711!
12712! concentration arrays...
12713!
12714 real :: chlcnh(ngs), vhlcnh(ngs), vhlcnhl(ngs)
12715 real :: chlcnhhl(ngs) ! number of new hail particles (may be different from number of lost graupel)
12716 real cracif(ngs), ciacrf(ngs)
12717 real cracr(ngs)
12718
12719!
12720 real ciint(ngs), crfrz(ngs), crfrzf(ngs), crfrzs(ngs)
12721 real cicint(ngs)
12722 real cipint(ngs)
12723 real ciacw(ngs), cwacii(ngs)
12724 real ciacr(ngs), craci(ngs)
12725 real csacw(ngs)
12726 real csacr(ngs)
12727 real csaci(ngs), csacs(ngs)
12728 real cracw(ngs)
12729 real chacw(ngs), chacr(ngs)
12730 real :: chlacw(ngs)
12731 real chaci(ngs), chacs(ngs)
12732!
12733 real :: chlacr(ngs)
12734 real :: chlaci(ngs), chlacs(ngs)
12735 real crcnw(ngs)
12736 real cidpv(ngs),cisbv(ngs)
12737 real cisdpv(ngs),cissbv(ngs)
12738 real cimlr(ngs),cismlr(ngs)
12739
12740 real chlsbv(ngs), chldpv(ngs)
12741 real chlmlr(ngs), chlmlrr(ngs)
12742 real chlfmlr(ngs)
12743! real chlmlrsave(ngs),chlsave(ngs),qhlsave(ngs)
12744 real chlshr(ngs), chlshrr(ngs)
12745
12746
12747 real chdpv(ngs),chsbv(ngs)
12748 real chmlr(ngs),chcev(ngs)
12749 real chmlrr(ngs)
12750 real chshr(ngs), chshrr(ngs)
12751
12752 real csdpv(ngs),cssbv(ngs)
12753 real csmlr(ngs),csmlrr(ngs),cscev(ngs)
12754 real csshr(ngs), csshrr(ngs)
12755
12756 real crcev(ngs)
12757 real crshr(ngs)
12758 real cwshw(ngs), qwshw(ngs)
12759!
12760!
12761! arrays for w-ac-x ; x-ac-w
12762!
12763!
12764!
12765 real qrcnw(ngs), qwcnr(ngs)
12766 real zrcnw(ngs),zracr(ngs),zracw(ngs),zrcev(ngs)
12767
12768 real qracw(ngs) ! qwacr(ngs),
12769 real qiacw(ngs) !, qwaci(ngs)
12770
12771 real qsacw(ngs) ! ,qwacs(ngs),
12772 real qhacw(ngs) ! qwach(ngs),
12773 real :: qhlacw(ngs), qxacwtmp, qxacrtmp, qxacitmp, qxacstmp !
12774 real vhacw(ngs), vsacw(ngs), vhlacw(ngs), vhlacr(ngs)
12775
12776 real qfcev(ngs)
12777 real qfmul1(ngs),cfmul1(ngs)
12778!
12779 real qsacws(ngs)
12780
12781!
12782! arrays for x-ac-r and r-ac-x;
12783!
12784 real qsacr(ngs),qracs(ngs)
12785 real qhacr(ngs),qhacrmlr(ngs),qhacwmlr(ngs) ! ,qrach(ngs)
12786 real vhacr(ngs), zhacr(ngs), zhacrf(ngs), zrach(ngs), zrachl(ngs)
12787 real qiacr(ngs),qraci(ngs)
12788
12789 real ziacr(ngs)
12790
12791 real qracif(ngs),qiacrf(ngs),qiacrs(ngs),ciacrs(ngs)
12792
12793 real :: qhlacr(ngs),qhlacrmlr(ngs), qhlacwmlr(ngs)
12794 real qsacrs(ngs) !,qracss(ngs)
12795!
12796! ice - ice interactions
12797!
12798 real qsaci(ngs)
12799 real qsacis(ngs)
12800 real qhaci(ngs)
12801 real qhacs(ngs)
12802
12803 real :: qhacis(ngs)
12804 real :: chacis(ngs)
12805 real :: chacis0(ngs)
12806
12807 real :: csaci0(ngs) ! collision rate only
12808 real :: chaci0(ngs) ! collision rate only
12809 real :: chacs0(ngs) ! collision rate only
12810 real :: chlaci0(ngs)
12811 real :: chlacis(ngs)
12812 real :: chlacis0(ngs)
12813 real :: chlacs0(ngs)
12814
12815 real :: qsaci0(ngs) ! collision rate only
12816 real :: qsacis0(ngs) ! collision rate only
12817 real :: qhaci0(ngs) ! collision rate only
12818 real :: qhacis0(ngs) ! collision rate only
12819 real :: qhacs0(ngs) ! collision rate only
12820 real :: qhlaci0(ngs)
12821 real :: qhlacis0(ngs)
12822 real :: qhlacs0(ngs)
12823
12824 real :: qhlaci(ngs)
12825 real :: qhlacis(ngs)
12826 real :: qhlacs(ngs)
12827!
12828! conversions
12829!
12830 real qrfrz(ngs) ! , qirirhr(ngs)
12831 real zrfrz(ngs), zrfrzf(ngs), zrfrzs(ngs)
12832 real ziacrf(ngs), zhcnsh(ngs), zhcnih(ngs)
12833 real zhacw(ngs), zhacs(ngs), zhaci(ngs)
12834 real zhmlr(ngs), zhdsv(ngs), zhsbv(ngs), zhlcnh(ngs), zhshr(ngs)
12835 real zfacw(ngs), zfacs(ngs), zfaci(ngs)
12836 real zfmlr(ngs), zfdsv(ngs), zfsbv(ngs), zhlcnf(ngs), zfshr(ngs), zfshrr(ngs)
12837 real zhmlrtmp,zhmlr0inf,zhlmlr0inf
12838 real zhmlrr(ngs),zhlmlrr(ngs),zhshrr(ngs),zhlshrr(ngs),zfmlrr(ngs)
12839! real zsmlr(ngs)
12840 real zsmlrr(ngs), zsshr(ngs), zsshrr(ngs)
12841 real zhcns(ngs), zhcni(ngs)
12842 real zhwdn(ngs), zfwdn(ngs) ! change in Z due to density changes
12843 real zhldn(ngs) ! change in Z due to density changes
12844
12845 real zhlacw(ngs), zhlacs(ngs), zhlacr(ngs)
12846 real zhlmlr(ngs), zhldsv(ngs), zhlsbv(ngs), zhlshr(ngs)
12847
12848
12849 real vrfrzf(ngs), viacrf(ngs)
12850 real qrfrzs(ngs), qrfrzf(ngs)
12851 real qwfrz(ngs), qwctfz(ngs)
12852 real cwfrz(ngs), cwctfz(ngs)
12853 real qwfrzis(ngs), qwctfzis(ngs) ! droplet freezing to ice spheres
12854 real cwfrzis(ngs), cwctfzis(ngs)
12855 real qwfrzc(ngs), qwctfzc(ngs) ! droplet freezing to columns
12856 real cwfrzc(ngs), cwctfzc(ngs)
12857 real qwfrzp(ngs), qwctfzp(ngs) ! droplet freezing to plates
12858 real cwfrzp(ngs), cwctfzp(ngs)
12859 real xcolmn(ngs), xplate(ngs)
12860 real ciihr(ngs), qiihr(ngs)
12861 real cicichr(ngs), qicichr(ngs)
12862 real cipiphr(ngs), qipiphr(ngs)
12863 real qscni(ngs), cscni(ngs), cscnis(ngs)
12864 real qscnvi(ngs), cscnvi(ngs), cscnvis(ngs)
12865 real qhcns(ngs), chcns(ngs), chcnsh(ngs), vhcns(ngs)
12866 real qscnh(ngs), cscnh(ngs), vscnh(ngs)
12867 real qhcni(ngs), chcni(ngs), chcnih(ngs), vhcni(ngs)
12868 real qiint(ngs),qipipnt(ngs),qicicnt(ngs)
12869 real cninm(ngs),cnina(ngs),cninp(ngs),wvel(ngs),wvelkm1(ngs)
12870 real tke(ngs)
12871 real uvel(ngs),vvel(ngs)
12872!
12873 real qidpv(ngs),qisbv(ngs) ! qicnv(ngs),qievv(ngs),
12874 real qimlr(ngs),qidsv(ngs),qisdsv(ngs),qidsvp(ngs) ! ,qicev(ngs)
12875 real qismlr(ngs)
12876
12877!
12878!
12879 real :: qhldpv(ngs), qhlsbv(ngs) ! qhlcnv(ngs),qhlevv(ngs),
12880 real :: qhlmlr(ngs), qhldsv(ngs), qhlmlrsave(ngs)
12881 real :: qhlwet(ngs), qhldry(ngs), qhlshr(ngs), qxwettmp
12882!
12883 real :: qrfz(ngs),qsfz(ngs),qhfz(ngs),qhlfz(ngs)
12884 real :: qffz(ngs)
12885!
12886 real qhdpv(ngs),qhsbv(ngs) ! qhcnv(ngs),qhevv(ngs),
12887 real qhmlr(ngs),qhdsv(ngs),qhcev(ngs),qhcndv(ngs),qhevv(ngs)
12888 real qhlcev(ngs), chlcev(ngs)
12889 real qhwet(ngs),qhdry(ngs),qhshr(ngs)
12890 real qhshrp(ngs)
12891 real qhshh(ngs) !accreted water that remains on graupel
12892 real qhmlh(ngs) !melt water that remains on graupel
12893 real qhfzh(ngs) !water that freezes on mixed-phase graupel
12894 real qffzf(ngs) !water that freezes on mixed-phase FD
12895 real qhlfzhl(ngs) !water that freezes on mixed-phase hail
12896
12897 real qhmlrlg(ngs),qhlmlrlg(ngs) ! melting from the larger diameters
12898 real qhfzhlg(ngs) !water that freezes on mixed-phase graupel (large sizes)
12899 real qhlfzhllg(ngs) !water that freezes on mixed-phase hail (large sizes)
12900 real qhlcevlg(ngs), chlcevlg(ngs)
12901 real qhcevlg(ngs), chcevlg(ngs)
12902
12903 real vhfzh(ngs), vffzf(ngs) ! change in volume from water that freezes on mixed-phase graupel, frozen drops
12904 real vhlfzhl(ngs) ! change in volume from water that freezes on mixed-phase hail
12905
12906 real vhshdr(ngs) !accreted water that leaves on graupel (mixedphase)
12907 real vhlshdr(ngs) !accreted water that leaves on hail (mixedphase)
12908 real vhmlr(ngs) !melt water that leaves graupel (single phase)
12909 real vhlmlr(ngs) !melt water that leaves hail (single phase)
12910 real vhsoak(ngs) ! aquired water that seeps into graupel.
12911 real vhlsoak(ngs) ! aquired water that seeps into hail.
12912
12913!
12914 real qsdpv(ngs),qssbv(ngs) ! qscnv(ngs),qsevv(ngs),
12915 real qsmlr(ngs),qsdsv(ngs),qscev(ngs),qscndv(ngs),qsevv(ngs)
12916 real qswet(ngs),qsdry(ngs),qsshr(ngs)
12917 real qsshrp(ngs)
12918 real qsfzs(ngs)
12919!
12920!
12921 real qipdpv(ngs),qipsbv(ngs)
12922 real qipmlr(ngs),qipdsv(ngs)
12923!
12924 real qirdpv(ngs),qirsbv(ngs)
12925 real qirmlr(ngs),qirdsv(ngs),qirmlw(ngs)
12926!
12927 real qgldpv(ngs),qglsbv(ngs)
12928 real qglmlr(ngs),qgldsv(ngs)
12929 real qglwet(ngs),qgldry(ngs),qglshr(ngs)
12930 real qglshrp(ngs)
12931!
12932 real qgmdpv(ngs),qgmsbv(ngs)
12933 real qgmmlr(ngs),qgmdsv(ngs)
12934 real qgmwet(ngs),qgmdry(ngs),qgmshr(ngs)
12935 real qgmshrp(ngs)
12936 real qghdpv(ngs),qghsbv(ngs)
12937 real qghmlr(ngs),qghdsv(ngs)
12938 real qghwet(ngs),qghdry(ngs),qghshr(ngs)
12939 real qghshrp(ngs)
12940!
12941 real qrztot(ngs),qrzmax(ngs),qrzfac(ngs)
12942 real qrcev(ngs)
12943 real qrshr(ngs)
12944 real fsw(ngs),fhw(ngs),fhlw(ngs),ffw(ngs) !liquid water fractions
12945 real fswmax(ngs),fhwmax(ngs),fhlwmax(ngs) !liquid water fractions
12946 real ffwmax(ngs)
12947 real qhcnf(ngs)
12948 real :: qhlcnh(ngs)
12949 real qhcngh(ngs),qhcngm(ngs),qhcngl(ngs)
12950
12951 real :: qhcnhl(ngs), chcnhl(ngs), zhcnhl(ngs), vhcnhl(ngs) ! conversion of low-density hail back to graupel
12952
12953 real eiw(ngs),eii(ngs),eiri(ngs),eipir(ngs),eisw(ngs)
12954 real erw(ngs),esw(ngs),eglw(ngs),eghw(ngs),efw(ngs)
12955 real ehxw(ngs),ehlw(ngs),egmw(ngs),ehw(ngs)
12956 real err(ngs),esr(ngs),eglr(ngs),eghr(ngs),efr(ngs)
12957 real ehxr(ngs),ehlr(ngs),egmr(ngs)
12958 real eri(ngs),esi(ngs),egli(ngs),eghi(ngs),efi(ngs),efis(ngs)
12959 real ehxi(ngs),ehli(ngs),egmi(ngs),ehi(ngs),ehis(ngs),ehlis(ngs)
12960 real ers(ngs),ess(ngs),egls(ngs),eghs(ngs),efs(ngs),ehs(ngs),ehsfac(ngs)
12961 real ehscnv(ngs)
12962 real ehxs(ngs),ehls(ngs),egms(ngs),egmip(ngs)
12963
12964 real ehsclsn(ngs),ehiclsn(ngs),ehisclsn(ngs)
12965 real efsclsn(ngs),eficlsn(ngs),efisclsn(ngs)
12966 real ehlsclsn(ngs),ehliclsn(ngs),ehlisclsn(ngs)
12967 real esiclsn(ngs)
12968
12969 real :: ehs_collsn = 0.5, ehi_collsn = 1.0
12970 real :: efs_collsn = 0.5, efi_collsn = 1.0
12971 real :: ehls_collsn = 1.0, ehli_collsn = 1.0
12972 real :: esi_collsn = 1.0
12973
12974 real ew(8,6)
12975 real cwr(8,2) ! radius and inverse of interval
12976 data cwr / 2.0, 3.0, 4.0, 6.0, 8.0, 10.0, 15.0, 20.0 , & ! radius
12977 & 1.0, 1.0, 0.5, 0.5, 0.5, 0.2, 0.2, 1. / ! inverse of interval
12978 integer icwr(ngs), igwr(ngs), irwr(ngs), ihlr(ngs), ifwr(ngs)
12979 real grad(6,2) ! graupel radius and inverse of interval
12980 data grad / 100., 200., 300., 400., 600., 1000., &
12981 & 1.e-2,1.e-2,1.e-2,5.e-3,2.5e-3, 1. /
12982!droplet radius: 2 3 4 6 8 10 15 20
12983 data ew /0.03, 0.07, 0.17, 0.41, 0.58, 0.69, 0.82, 0.88, & ! 100
12984! : 0.07, 0.13, 0.27, 0.48, 0.65, 0.73, 0.84, 0.91, ! 150
12985 & 0.10, 0.20, 0.34, 0.58, 0.70, 0.78, 0.88, 0.92, & ! 200
12986 & 0.15, 0.31, 0.44, 0.65, 0.75, 0.83, 0.96, 0.91, & ! 300
12987 & 0.17, 0.37, 0.50, 0.70, 0.81, 0.87, 0.93, 0.96, & ! 400
12988 & 0.17, 0.40, 0.54, 0.71, 0.83, 0.88, 0.94, 0.98, & ! 600
12989 & 0.15, 0.37, 0.52, 0.74, 0.82, 0.88, 0.94, 0.98 / ! 1000
12990! : 0.11, 0.34, 0.49, 0.71, 0.83, 0.88, 0.94, 0.95 / ! 1400
12991
12992
12993 real da0lr(ngs),da1lr(ngs)
12994 real da0lc(ngs),da1lc(ngs)
12995 real da0lh(ngs)
12996 real da0lhl(ngs)
12997 real da0lf(ngs)
12998 real :: da0lx(ngs,lr:lhab)
12999
13000 real va0 (lc:lqmx) ! collection coefficients from Seifert 2005
13001 real vab0(lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005
13002 real vab1(lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005
13003 real va1 (lc:lqmx) ! collection coefficients from Seifert 2005
13004 real ehip(ngs),ehlip(ngs),ehlir(ngs)
13005 real erir(ngs),esir(ngs),eglir(ngs),egmir(ngs),eghir(ngs)
13006 real efir(ngs),ehir(ngs),eirw(ngs),eirir(ngs),ehr(ngs)
13007 real erip(ngs),esip(ngs),eglip(ngs),eghip(ngs)
13008 real efip(ngs),eipi(ngs),eipw(ngs),eipip(ngs)
13009!
13010! arrays for production terms
13011!
13012 real ptotal(ngs) ! , pqtot(ngs)
13013!
13014 real pqcwi(ngs),pqcii(ngs),pqrwi(ngs),pqisi(ngs)
13015 real pqswi(ngs),pqhwi(ngs),pqwvi(ngs)
13016 real pqgli(ngs),pqghi(ngs),pqfwi(ngs)
13017 real pqgmi(ngs),pqhli(ngs) ! ,pqhxi(ngs)
13018 real pqiri(ngs),pqipi(ngs) ! pqwai(ngs),
13019 real pqlwsi(ngs),pqlwhi(ngs),pqlwhli(ngs),pqlwfi(ngs)
13020
13021 real pqlwlghi(ngs),pqlwlghli(ngs)
13022 real pqlwlghd(ngs),pqlwlghld(ngs)
13023
13024
13025
13026
13027 real pvhwi(ngs), pvhwd(ngs)
13028 real pvfwi(ngs), pvfwd(ngs)
13029 real pvhli(ngs), pvhld(ngs)
13030 real pvswi(ngs), pvswd(ngs)
13031!
13032 real pqcwd(ngs),pqcid(ngs),pqrwd(ngs),pqisd(ngs), pqcwdacc(ngs)
13033 real pqswd(ngs),pqhwd(ngs),pqwvd(ngs)
13034 real pqgld(ngs),pqghd(ngs),pqfwd(ngs)
13035 real pqgmd(ngs),pqhld(ngs) ! ,pqhxd(ngs)
13036 real pqird(ngs),pqipd(ngs) ! pqwad(ngs),
13037 real pqlwsd(ngs),pqlwhd(ngs),pqlwhld(ngs),pqlwfd(ngs)
13038!
13039! real pqxii(ngs,nhab),pqxid(ngs,nhab)
13040!
13041 real pctot(ngs)
13042 real pcipi(ngs), pcipd(ngs)
13043 real pciri(ngs), pcird(ngs)
13044 real pccwi(ngs), pccwd(ngs), pccwdacc(ngs)
13045 real pccii(ngs), pccid(ngs)
13046 real pcisi(ngs), pcisd(ngs)
13047 real pccin(ngs)
13048 real pcrwi(ngs), pcrwd(ngs)
13049 real pcswi(ngs), pcswd(ngs)
13050 real pchwi(ngs), pchwd(ngs)
13051 real pchli(ngs), pchld(ngs)
13052 real pcfwi(ngs), pcfwd(ngs)
13053 real pcgli(ngs), pcgld(ngs)
13054 real pcgmi(ngs), pcgmd(ngs)
13055 real pcghi(ngs), pcghd(ngs)
13056
13057 real pzrwi(ngs), pzrwd(ngs)
13058 real pzhwi(ngs), pzhwd(ngs)
13059 real pzfwi(ngs), pzfwd(ngs)
13060 real pzhli(ngs), pzhld(ngs)
13061 real pzswi(ngs), pzswd(ngs)
13062
13063!
13064! other arrays
13065!
13066 real dqisdt(ngs) !,advisc(ngs) !dqwsdt(ngs), ,schm(ngs),pndl(ngs)
13067
13068 real qss0(ngs)
13069
13070 real qsacip(ngs)
13071 real pres(ngs),pipert(ngs)
13072 real pk(ngs)
13073 real rho0(ngs),pi0(ngs)
13074 real rhovt(ngs),sqrtrhovt
13075 real thetap(ngs),theta0(ngs),qwvp(ngs),qv0(ngs)
13076 real thsave(ngs)
13077 real ptwfzi(ngs),ptimlw(ngs)
13078 real psub(ngs),pvap(ngs),pfrz(ngs),ptem(ngs),pmlt(ngs),pevap(ngs),pdep(ngs),ptem2(ngs)
13079
13080 real cnostmp(ngs) ! for diagnosed snow intercept
13081!
13082! iholef = 1 to do hole filling technique version 1
13083! which uses all hydrometerors to do hole filling of all hydrometeors
13084! iholef = 2 to do hole filling technique version 2
13085! which uses an individual hydrometeror species to do hole
13086! filling of a species of a hydrometeor
13087!
13088! iholen = interval that hole filling is done
13089!
13090 integer iholef
13091 integer iholen
13092 parameter(iholef = 1)
13093 parameter(iholen = 1)
13094 real cqtotn,cqtotn1
13095 real cctotn
13096 real citotn
13097 real crtotn
13098 real cstotn
13099 real cvtotn
13100 real cftotn
13101 real cgltotn
13102 real cghtotn
13103 real chtotn
13104 real cqtotp,cqtotp1
13105 real cctotp
13106 real citotp
13107 real ciptotp
13108 real crtotp
13109 real cstotp
13110 real cvtotp
13111 real cftotp
13112 real chltotp
13113 real cgltotp
13114 real cgmtotp
13115 real cghtotp
13116 real chtotp
13117 real cqfac
13118 real ccfac
13119 real cifac
13120 real cipfac
13121 real crfac
13122 real csfac
13123 real cvfac
13124 real cffac
13125 real cglfac
13126 real cghfac
13127 real chfac
13128
13129 real ssifac, qvapor
13130!
13131! Miscellaneous variables
13132!
13133 real, parameter :: cwmas30 = 1000.*0.523599*(2.*30.e-6)**3 ! mass of 30-micron radius droplet, for sat. adj.
13134 real, parameter :: cwmas20 = 1000.*0.523599*(2.*20.e-6)**3 ! mass of 20-micron radius droplet, for sat. adj.
13135 integer ireadqf,lrho,lqsw,lqgl,lqgm ,lqgh
13136 integer lqrw
13137 real vt
13138 real arg ! gamma is a function
13139 real erbnd1, fdgt1, costhe1
13140 real qeps
13141 real dyi2,dzi2,bta1,cnit,dragh,dnz00,pii ! ,cp608
13142 real qccrit,gf4br,gf4ds,gf4p5, gf3ds, gf1ds
13143 real gf1palp(ngs) ! for storing Gamma[1.0 + alphar]
13144
13145
13146 real xdn0(lc:lhab)
13147 real xdn_new,drhodt
13148
13149 integer l ,ltemq,inumgs, idelq
13150
13151 real brz,arz,temq
13152
13153 real ssival,tqvcon
13154 real cdx(lc:lhab)
13155 real cnox
13156 real cval,aval,eval,fval,gval ,qsign,ftelwc,qconkq,elecfac,altelecfac
13157 real qconm,qconn,cfce15,gf8,gf4i,gf3p5,gf1a,gf1p5,qdiff,argrcnw
13158 real c4,bradp,bl2,bt2,dthr,hrifac, hdia0,hdia1,civenta,civentb
13159 real civentc,civentd,civente,civentf,civentg,cireyn,xcivent
13160 real cipventa,cipventb,cipventc,cipventd,cipreyn,cirventa
13161 real cirventb
13162 integer igmrwa,igmrwb,igmswa, igmswb,igmfwa,igmfwb,igmhwa,igmhwb
13163 real rwventa ,rwventb,swventa,swventb,fwventa,fwventb,fwventc
13164 real hwventa,hwventb
13165 real hwventc, hlventa, hlventb, hlventc
13166 real glventa, glventb, glventc
13167 real gmventa, gmventb, gmventc, ghventa, ghventb, ghventc
13168 real dzfacp, dzfacm, cmassin, cwdiar
13169 real rimmas, rhobar
13170 real argtim, argqcw, argqxw, argtem
13171 real frcswsw, frcswgl, frcswgm, frcswgh, frcswfw, frcswsw1
13172 real frcglgl, frcglgm, frcglgh, frcglfw, frcglgl1
13173 real frcgmgl, frcgmgm, frcgmgh, frcgmfw, frcgmgm1
13174 real frcghgl, frcghgm, frcghgh, frcghfw, frcghgh1
13175 real frcfwgl, frcfwgm, frcfwgh, frcfwfw, frcfwfw1
13176 real frcswrsw, frcswrgl, frcswrgm, frcswrgh, frcswrfw
13177 real frcswrsw1
13178 real frcrswsw, frcrswgl, frcrswgm, frcrswgh, frcrswfw
13179 real frcrswsw1
13180 real frcglrgl, frcglrgm, frcglrgh, frcglrfw, frcglrgl1
13181 real frcrglgl
13182 real frcrglgm, frcrglgh, frcrglfw, frcrglgl1
13183 real frcgmrgl, frcgmrgm, frcgmrgh, frcgmrfw, frcgmrgm1
13184 real frcrgmgl, frcrgmgm, frcrgmgh, frcrgmfw, frcrgmgm1
13185 real total, qweps, gf2a, gf4a, dqldt, dqidt, dqdt
13186 real frcghrgl, frcghrgm, frcghrgh, frcghrfw, frcghrgh1, frcrghgl
13187 real frcrghgm, frcrghgh, frcrghfw, frcrghgh1
13188 real a1,a2,a3,a4,a5,a6
13189 real gamss
13190 real cdw, cdi, denom1, denom2, delqci1, delqip1
13191 real cirtotn, ciptotn, cgmtotn, chltotn, cirtotp
13192 real cgmfac, chlfac, cirfac
13193 integer igmhla, igmhlb, igmgla, igmglb, igmgma, igmgmb
13194 integer igmgha, igmghb
13195 integer idqis, item, itim0
13196 integer iqgl, iqgm, iqgh, iqrw, iqsw
13197 integer itertd, ia
13198
13199 integer :: infdo
13200
13201 real tau, ewtmp
13202
13203 integer cntnic_noliq
13204 real q_noliqmn, q_noliqmx
13205 real scsacimn, scsacimx
13206
13207 real :: dtpinv
13208
13209! arrays for temporary bin space
13210
13211 real :: xden,xmlt,cmlt,cmlttot,fventm,fventh,am,ah,felfinv,dmwdt
13212
13213 real :: qhmlrtmp,qhmlrtmp2, chmlrtmp, chmlrtmpd1inf, chlmlrtmp, zhlmlrtmp, zhlmlrrtmp, qvs0,tmpcmlt
13214
13215 real :: term1,term2,term3,term4
13216 real :: qaacw ! combined qsacw-qhacw for WSM6 variation
13217 real :: cwchtmp
13218
13219 real, parameter :: c1r=19.0, c2r=0.6, c3r=1.8, c4r=17.0 ! rain
13220 real, parameter :: c1h=5.5, c2h=0.7, c3h=4.5, c4h=8.5 ! Graupel
13221 real, parameter :: c1hl=3.7, c2hl=0.3, c3hl=9.0, c4hl=6.5, c5hl=1.0, c6hl=6.5 ! Hail
13222
13223
13224! inline functions for Newton method
13225 real :: galpha, dgalpha
13226 real :: a_in
13227 logical, parameter :: newton = .false.
13228
13229
13230 galpha(a_in) = ((4. + a_in)*(5. + a_in)*(6. + a_in))/((1. + a_in)*(2. + a_in)*(3. + a_in))
13231 dgalpha(a_in) = (876. + 1260.*a_in + 621.*a_in**2 + 126.*a_in**3 + 9.*a_in**4)/ &
13232 & (36. + 132.*a_in + 193.*a_in**2 + 144.*a_in**3 + 58.*a_in**4 + 12.*a_in**5 + a_in**6)
13233!
13234! ####################################################################
13235!
13236! Start routine
13237!
13238! ####################################################################
13239
13240
13241
13242!
13243
13244 pb(:) = 0.0
13245 pinit(:) = 0.0
13246 itile = nx
13247 jtile = ny
13248 ktile = nz
13249 ixend = nx
13250 jyend = ny
13251 kzend = nz
13252 nxend = nx + 1
13253 nyend = ny + 1
13254 nzend = nz
13255 kzbeg = 1
13256 nzbeg = 1
13257
13258 istag = 0
13259 jstag = 0
13260 kstag = 1
13261
13262 lrescalelow(:) = rescale_low_alpha
13263 lrescalelow(lr) = rescale_low_alphar .and. rescale_low_alpha
13264 lrescalelow(lh) = rescale_low_alphah .and. rescale_low_alpha
13265 IF ( lf > 1 ) lrescalelow(lf) = rescale_low_alphah .and. rescale_low_alpha
13266 IF ( lhl > 1 ) lrescalelow(lhl) = rescale_low_alphahl .and. rescale_low_alpha
13267
13268
13269!
13270! slope intercepts
13271!
13272
13273 IF ( ngs .lt. nz ) THEN
13274! write(0,*) 'Error in ICEZVD: Must have ngs .ge. nz!'
13275! STOP
13276 ENDIF
13277
13278 cntnic_noliq = 0
13279 q_noliqmn = 0.0
13280 q_noliqmx = 0.0
13281 scsacimn = 0.0
13282 scsacimx = 0.0
13283
13284 ldovol = .false.
13285
13286 DO il = lc,lhab
13287 ldovol = ldovol .or. ( lvol(il) .gt. 1 )
13288 ENDDO
13289
13290
13291 ffrzh = 1
13292! DO il = lc,lhab
13293! write(iunit,*) 'delqnxa(',il,') = ',delqnxa(il)
13294! ENDDO
13295
13296!
13297! density maximums and minimums
13298!
13299
13300!
13301! Set terminal velocities...
13302! also set drag coefficients
13303!
13304
13305 dtpinv = 1.d0/dtp
13306
13307!
13308
13309!
13310! electricity constants
13311!
13312! mixing ratio epsilon
13313!
13314 qeps = 1.0e-20
13315
13316! rebound efficiency (erbnd)
13317!
13318!
13319!
13320! constants
13321!
13322
13323! cp608 = 0.608
13324 aradcw = -0.27544
13325 bradcw = 0.26249e+06
13326 cradcw = -1.8896e+10
13327 dradcw = 4.4626e+14
13328 bta1 = 0.6
13329 cnit = 1.0e-02
13330 dragh = 0.60
13331 dnz00 = 1.225
13332! cs = 4.83607122
13333! ds = 0.25
13334! new values for cs and ds
13335 cs = 12.42
13336 ds = 0.42
13337 pii = piinv ! 1./pi
13338 pid4 = pi/4.0
13339! qscrit = 6.0e-04
13340 gf1 = 1.0 ! gamma(1.0)
13341 gf1p5 = 0.8862269255 ! gamma(1.5)
13342 gf2 = 1.0 ! gamma(2.0)
13343 gf3 = 2.0 ! gamma(3.0)
13344 gf3p5 = 3.32335097 ! gamma(3.5)
13345 gf4 = 6.00 ! gamma(4.0)
13346 gf5 = 24.0 ! gamma(5.0)
13347 gf6 = 120.0 ! gamma(6.0)
13348 gf7 = 720.0 ! gamma(7.0)
13349 gf4br = 17.837861981813607 ! gamma(4.0+br)
13350 gf4ds = 10.41688578110938 ! gamma(4.0+ds)
13351 gf4p5 = 11.63172839656745 ! gamma(4.0+0.5)
13352 gf3ds = 3.0458730354120997 ! gamma(3.0+ds)
13353 gf1ds = 0.8863557896089221 ! gamma(1.0+ds)
13354
13355 gf43rds = 0.8929795116 ! gamma(4./3.)
13356 gf53rds = 0.9027452930 ! gamma(5./3.)
13357 gf73rds = 1.190639349 ! gamma(7./3.)
13358 gf83rds = 1.504575488 ! gamma(8./3.)
13359
13360 gamice73fac = (gamma_sp(7./3. + cinu))**3/ (gamma_sp(1. + cinu)**3 * (1. + cinu)**4)
13361 gamsnow73fac = (gamma_sp(7./3. + snu))**3/ (gamma_sp(1. + snu)**3 * (1. + snu)**4)
13362
13363! gcnup1 = Gamma_sp(cnu + 1.)
13364! gcnup2 = Gamma_sp(cnu + 2.)
13365!
13366! constants
13367!
13368!
13369! general constants for microphysics
13370!
13371 brz = 100.0
13372 arz = 0.66
13373
13374 bfnu1 = (4. + alphar)*(5. + alphar)*(6. + alphar)/ &
13375 & ((1. + alphar)*(2. + alphar)*(3. + alphar))
13376
13377 galpharaut = (6.+alpharaut)*(5.+alpharaut)*(4.+alpharaut)/ &
13378 & ((3.+alpharaut)*(2.+alpharaut)*(1.+alpharaut))
13379
13380 vfrz = 0.523599*(dfrz)**3
13381 vmlt = min(xvmx(lr), 0.523599*(dmlt)**3 )
13382 vshd = min(xvmx(lr), 0.523599*(dshd)**3 )
13383
13384 IF ( snowmeltdia > 0.0 ) THEN
13385 snowmeltmass = pi/6.0 * 1000. * snowmeltdia**3 ! maximum rain particle mass from melting snow (if snowmeltdia > 0)
13386 ENDIF
13387
13388 tdtol = 1.0e-05
13389 tfrcbw = tfr - cbw
13390 tfrcbi = tfr - cbi
13391
13392 IF ( mixedphase ) THEN
13393 ibinhmlr = 0
13394 ibinhlmlr = 0
13395 ENDIF
13396!
13397!
13398! #ifdef COMMAS
13399! print*,'ventr,ventc = ',ventr,ventc
13400
13401!
13402! Set up look up tables for supersaturation w.r.t. liq and ice
13403!
13404!VD$L SKIP
13405! do l = 1,nqsat
13406! temq = 163.15 + (l-1)*fqsat
13407! tabqvs(l) = exp(caw*(temq-273.15)/(temq-cbw))
13408! tabqis(l) = exp(cai*(temq-273.15)/(temq-cbi))
13409! end do
13410
13411 mltmass0inv = 1.0/( 1000.0* xvmx(lr) ) ! for drops melting from ice with diameter > 1.9cm
13412 mltmass1inv = 1.0/( 1000.0*(4.0*pi/3.0)*((0.01*0.5*takshedsize1)**3) ) ! for drops melting from ice with diameter > 1.9cm; 0.01 converts cm to m, 0.5 conv. diam to radius
13413 mltmass2inv = 1.0/( 1000.0*(4.0*pi/3.0)*((0.01*0.5*takshedsize2)**3) ) ! for drops melting from ice with 0.9cm < d < 1.9cm (or 1.6cm to 1.9cm)
13414 mltmass3inv = 1.0/( 1000.0*(4.0*pi/3.0)*((0.01*0.5*takshedsize3)**3) ) ! for drops melting from ice with 0.9cm < d < 1.6cm
13415 mltmass1cgs = 1.0*(4.0*pi/3.0)*((0.5*takshedsize1)**3)
13416 mltmass2cgs = 1.0*(4.0*pi/3.0)*((0.5*takshedsize2)**3)
13417 mltmass3cgs = 1.0*(4.0*pi/3.0)*((0.5*takshedsize3)**3)
13418
13419! real, parameter :: mltdiam1 = 9.0e-3, mltdiam2 = 19.0e-3, mltdiam05 = 4.5e-3
13420
13421 IF ( ibinnum == 1 ) THEN
13422 numdiam = 1 ! must have numdiam < ndiam because numdiam+1 holds values for the interval of mltdiam(numdiam) to mltdiam(ndiam+1)
13423 mltdiam(1) = 4.5e-3
13424 ELSEIF ( ibinnum == 2 ) THEN
13425 numdiam = 2 ! must have numdiam < ndiam because numdiam+1 holds values for the interval of mltdiam(numdiam) to mltdiam(ndiam+1)
13426 mltdiam(1) = mltdiam1/6. ! 1.5e-3
13427 mltdiam(2) = mltdiam1/2. ! 4.5e-3
13428 ELSEIF ( ibinnum > 2 ) THEN
13429 numdiam = min(ibinnum, ndiam)
13430 DO k = 1,numdiam
13431 mltdiam(k) = (k - 0.5)*mltdiam1/float(numdiam)
13432 ENDDO
13433
13434 ELSE
13435 numdiam = 5 ! must have numdiam < ndiam because numdiam+1 holds values for the interval of mltdiam(numdiam) to mltdiam(ndiam+1)
13436 mltdiam(1) = 0.5e-3
13437 mltdiam(2) = 1.0e-3
13438 mltdiam(3) = 2.0e-3
13439 mltdiam(4) = 4.0e-3
13440 mltdiam(5) = 6.0e-3
13441 ENDIF
13442
13443
13444 IF ( numshedregimes == 2 ) THEN
13445 mltdiam(ndiam+1) = mltdiam1 ! 9.0e-3
13446 mltdiam(ndiam+2) = mltdiam3 ! 19.0e-3
13447 mltdiam(ndiam+3) = mltdiam4 !100.0e-3
13448 ELSEIF ( numshedregimes == 3 ) THEN
13449 mltdiam(ndiam+1) = mltdiam1 ! 9.0e-3
13450 mltdiam(ndiam+2) = mltdiam2 ! 16.0e-3
13451 mltdiam(ndiam+3) = mltdiam3 ! 19.0e-3
13452 mltdiam(ndiam+4) = mltdiam4 !200.0e-3
13453 ENDIF
13454
13455 kzb = 1
13456 kze = ktile
13457! if (kzend .eq. nzend) kze = kzend-kzbeg+1-kstag
13458
13459!
13460! cw constants in mks units
13461!
13462! cwmasn = 4.25e-15 ! radius of 1.0e-6
13463 mwfac = 6.0**(1./3.)
13464 IF ( ipconc .ge. 2 ) THEN
13465! cwmasn = xvmn(lc)*1000.
13466! cwradn = 1.0e-6
13467! cwmasx = xvmx(lc)*1000.
13468 ENDIF
13469 rwmasn = xvmn(lr)*1000.
13470 rwmasx = xvmx(lr)*1000.
13471
13472 IF ( biggsnowdiam > 0.0 ) THEN
13473 xvbiggsnow = (pi/6.0)*biggsnowdiam**3
13474 ELSE
13475 xvbiggsnow = xvmn(lh)
13476 ENDIF
13477
13478!
13479! ci constants in mks units
13480!
13481 cimasn = min(cimas0, cimas1) ! 12 microns for 0.1871*(xmas(mgs,li)**(0.3429))
13482 cimasx = 1.0e-8 ! 338 microns
13483 ccimx = 5000.0e3 ! max of 5000 per liter
13484
13485!
13486! constants for paramerization
13487!
13488!
13489! set save counter (number of saves): nsvcnt
13490!
13491! nsvcnt = 0
13492 iend = 0
13493
13494
13495! timetd1 = etime(tarray)
13496! timetd1 = tarray(1)
13497
13498!
13499!***********************************************************
13500! start jy loop
13501!***********************************************************
13502!
13503
13504! do 9999 jy = 1,ny-jstag
13505!
13506! VERY IMPORTANT: SET jy = jgs
13507!
13508 jy = jgs
13509
13510
13511! t1(:,:,:) = 0
13512! t2(:,:,:) = 0
13513! t3(:,:,:) = 0
13514! t4(:,:,:) = 0
13515! t5(:,:,:) = 0
13516! t6(:,:,:) = 0
13517! t8(:,:,:) = 0
13518
13519 IF ( ipconc < 2 ) THEN ! Make a copy of cloud droplet mixing ratio to use for homogeneous freezing
13520 DO kz = 1,kze
13521 DO ix = 1,itile
13522 t9(ix,jy,kz) = an(ix,jy,kz,lc)
13523 ENDDO
13524 ENDDO
13525 ENDIF
13526
13527!
13528!..Gather microphysics
13529!
13530 if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: ENTER GATHER STAGE'
13531
13532
13533
13534 nxmpb = 1
13535 nzmpb = 1
13536 nxz = itile*nz
13537 numgs = nxz/ngs + 1
13538! write(0,*) 'ICEZVD_GS: ENTER GATHER STAGE: nx,nz,nxz,numgs,ngs = ',nx,nz,nxz,numgs,ngs
13539
13540 do 1000 inumgs = 1,numgs
13541 ngscnt = 0
13542
13543 do kz = nzmpb,kze
13544 do ix = nxmpb,itile
13545
13546 pqs(1) = t00(ix,jy,kz)
13547
13548 theta(1) = an(ix,jy,kz,lt)
13549 temg(1) = t0(ix,jy,kz)
13550 temcg(1) = temg(1) - tfr
13551 tqvcon = temg(1)-cbw
13552 ltemq = (temg(1)-163.15)/fqsat + 1.5
13553 ltemq = min( nqsat, max(1,ltemq) )
13554 qvs(1) = pqs(1)*tabqvs(ltemq)
13555 IF ( iqis0 == 1 .or. temg(1) <= tfr+0.5 ) THEN
13556 qis(1) = pqs(1)*tabqis(ltemq)
13557 ELSE
13558 ltemq = (tfr - 163.15)/fqsat + 1.5
13559 qis(1) = pqs(1)*tabqis(ltemq)
13560 ENDIF
13561
13562 qss(1) = qvs(1)
13563
13564 if ( temg(1) .lt. tfr ) then
13565 qss(1) = qis(1)
13566 end if
13567!
13568 ishail = .false.
13569 IF ( lhl > 1 ) THEN
13570 IF ( an(ix,jy,kz,lhl) .gt. qxmin(lhl) ) ishail = .true.
13571 ENDIF
13572
13573
13574
13575 if ( an(ix,jy,kz,lv) .gt. qss(1) .or. &
13576 & an(ix,jy,kz,lc) .gt. qxmin(lc) .or. &
13577 & an(ix,jy,kz,li) .gt. qxmin(li) .or. &
13578 & an(ix,jy,kz,lr) .gt. qxmin(lr) .or. &
13579 & an(ix,jy,kz,ls) .gt. qxmin(ls) .or. &
13580 & an(ix,jy,kz,lh) .gt. qxmin(lh) .or. ishail ) then
13581 ngscnt = ngscnt + 1
13582 igs(ngscnt) = ix
13583 kgs(ngscnt) = kz
13584 if ( ngscnt .eq. ngs ) goto 1100
13585 end if
13586 enddo !ix
13587 nxmpb = 1
13588 enddo !kz
13589 1100 continue
13590
13591 if ( ngscnt .eq. 0 ) go to 9998
13592
13593 if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: dbg = 5, ngscnt = ',ngscnt
13594
13595! write(0,*) 'allocating qc'
13596
13597
13598 xv(:,:) = 0.0
13599 xmas(:,:) = 0.0
13600 vtxbar(:,:,:) = 0.0
13601 xdia(:,:,:) = 0.0
13602 raindn(:,:) = 900.
13603 cx(:,:) = 0.0
13604 IF ( lnhf > 1 .or. lnhlf > 1 ) chxf(:,:) = 0.0
13605 alpha(:,:) = 0.0
13606 DO il = li,lhab
13607 DO mgs = 1,ngscnt
13608 rimdn(mgs,il) = rimedens ! xdn0(il)
13609 ENDDO
13610 ENDDO
13611!
13612! define temporaries for state variables to be used in calculations
13613!
13614 if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: dbg = def temps'
13615 do mgs = 1,ngscnt
13616 kgsm(mgs) = max(kgs(mgs)-1,1)
13617 kgsp(mgs) = min(kgs(mgs)+1,nz-1)
13618 kgsm2(mgs) = max(kgs(mgs)-2,1)
13619 theta0(mgs) = an(igs(mgs),jy,kgs(mgs),lt)
13620 thetap(mgs) = an(igs(mgs),jy,kgs(mgs),lt) - theta0(mgs)
13621 theta(mgs) = an(igs(mgs),jy,kgs(mgs),lt)
13622 qv0(mgs) = an(igs(mgs),jy,kgs(mgs),lv)
13623 qwvp(mgs) = an(igs(mgs),jy,kgs(mgs),lv) - qv0(mgs) ! qv0(mgs) is full qv, so qwvp starts as zero!
13624
13625 pres(mgs) = pn(igs(mgs),jy,kgs(mgs)) + pb(kgs(mgs))
13626 pipert(mgs) = p2(igs(mgs),jy,kgs(mgs))
13627 rho0(mgs) = dn(igs(mgs),jy,kgs(mgs))
13628 rhoinv(mgs) = 1.0/rho0(mgs)
13629 rhovt(mgs) = sqrt(rho00/max(0.05,rho0(mgs))) ! prevent excessive rhovt
13630 pi0(mgs) = p2(igs(mgs),jy,kgs(mgs)) + pinit(kgs(mgs))
13631 temg(mgs) = t0(igs(mgs),jy,kgs(mgs))
13632 temgkm1(mgs) = t0(igs(mgs),jy,kgsm(mgs))
13633 temgkm2(mgs) = t0(igs(mgs),jy,kgsm2(mgs))
13634 pk(mgs) = p2(igs(mgs),jy,kgs(mgs)) + pinit(kgs(mgs)) ! t77(igs(mgs),jy,kgs(mgs))
13635 temcg(mgs) = temg(mgs) - tfr
13636 qss0(mgs) = (380.0)/(pres(mgs))
13637 pqs(mgs) = (380.0)/(pres(mgs))
13638 ltemq = (temg(mgs)-163.15)/fqsat+1.5
13639 ltemq = min( nqsat, max(1,ltemq) )
13640 qvs(mgs) = pqs(mgs)*tabqvs(ltemq)
13641 IF ( iqis0 == 1 .or. temg(mgs) <= tfr+0.5 ) THEN
13642 qis(mgs) = pqs(mgs)*tabqis(ltemq)
13643 ELSE
13644 ltemq = (tfr - 163.15)/fqsat + 1.5
13645 qis(mgs) = pqs(mgs)*tabqis(ltemq)
13646 ENDIF
13647 qss(mgs) = qvs(mgs)
13648! es(mgs) = 6.1078e2*tabqvs(ltemq)
13649! eis(mgs) = 6.1078e2*tabqis(ltemq)
13650 cnostmp(mgs) = cno(ls)
13651!
13652
13653 il5(mgs) = 0
13654 if ( temg(mgs) .lt. tfr ) then
13655 il5(mgs) = 1
13656 end if
13657 enddo !mgs
13658
13659 IF ( ipconc < 1 .and. lwsm6 ) THEN
13660 DO mgs = 1,ngscnt
13661 tmp = min( 0.0, temcg(mgs) )
13662 cnostmp(mgs) = min( 2.e8, 2.e6*exp(0.12*tmp) )
13663 ENDDO
13664 ENDIF
13665
13666
13667!
13668! zero arrays that are used but not otherwise set (tm)
13669!
13670 do mgs = 1,ngscnt
13671 qhshr(mgs) = 0.0
13672 end do
13673!
13674! set temporaries for microphysics variables
13675!
13676 DO il = lv,lhab
13677 do mgs = 1,ngscnt
13678 qx(mgs,il) = max(an(igs(mgs),jy,kgs(mgs),il), 0.0)
13679 ENDDO
13680 end do
13681
13682 qxw(:,:) = 0.0
13683 qxwlg(:,:) = 0.0
13684
13685
13686
13687
13688!
13689! set concentrations
13690!
13691! ssmax = 0.0
13692
13693
13694 if ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) 'ICEZVD_GS: dbg = 5b'
13695
13696 if ( ipconc .ge. 1 ) then
13697 do mgs = 1,ngscnt
13698 cx(mgs,li) = max(an(igs(mgs),jy,kgs(mgs),lni), 0.0)
13699 IF ( qx(mgs,li) .le. qxmin(li) ) THEN
13700 cx(mgs,li) = 0.0
13701 ENDIF
13702
13703 IF ( lcina .gt. 1 ) THEN
13704 cina(mgs) = an(igs(mgs),jy,kgs(mgs),lcina)
13705 ELSE
13706 cina(mgs) = cx(mgs,li)
13707 ENDIF
13708 IF ( lcin > 1 ) THEN
13709 ccin(mgs) = an(igs(mgs),jy,kgs(mgs),lcin)
13710 ENDIF
13711 end do
13712 end if
13713 if ( ipconc .ge. 2 ) then
13714 do mgs = 1,ngscnt
13715 cx(mgs,lc) = max(an(igs(mgs),jy,kgs(mgs),lnc), 0.0)
13716! cx(mgs,lc) = Min( ccwmx, cx(mgs,lc) )
13717 IF ( qx(mgs,lc) .le. qxmin(lc) ) THEN
13718 cx(mgs,lc) = 0.0
13719 ENDIF
13720 IF ( lss > 1 ) THEN
13721 ssmax(mgs) = an(igs(mgs),jy,kgs(mgs),lss)
13722 ENDIF
13723 IF ( lccn .gt. 1 ) THEN
13724 ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn)
13725 ELSE
13726 ccnc(mgs) = 0.0
13727 ENDIF
13728 IF ( lccna .gt. 1 ) THEN
13729 ccna(mgs) = an(igs(mgs),jy,kgs(mgs),lccna)
13730 ELSE
13731 ccna(mgs) = cx(mgs,lc)
13732 ENDIF
13733 end do
13734! ELSE
13735! cx(mgs,lc) = Abs(ccn)
13736 end if
13737 if ( ipconc .ge. 3 ) then
13738 do mgs = 1,ngscnt
13739 cx(mgs,lr) = max(an(igs(mgs),jy,kgs(mgs),lnr), 0.0)
13740 IF ( qx(mgs,lr) .le. qxmin(lr) ) THEN
13741! cx(mgs,lr) = 0.0
13742 ELSEIF ( cx(mgs,lr) .eq. 0.0 .and. qx(mgs,lr) .lt. 3.0*qxmin(lr) ) THEN
13743 qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lr)
13744 qx(mgs,lr) = 0.0
13745 ELSE
13746 cx(mgs,lr) = max( 1.e-9, cx(mgs,lr) )
13747 ENDIF
13748 end do
13749 end if
13750 if ( ipconc .ge. 4 ) then
13751 do mgs = 1,ngscnt
13752 cx(mgs,ls) = max(an(igs(mgs),jy,kgs(mgs),lns), 0.0)
13753 IF ( qx(mgs,ls) .le. qxmin(ls) ) THEN
13754! cx(mgs,ls) = 0.0
13755 ELSEIF ( cx(mgs,ls) .eq. 0.0 .and. qx(mgs,ls) .lt. 3.0*qxmin(ls) ) THEN
13756 qx(mgs,lv) = qx(mgs,lv) + qx(mgs,ls)
13757 qx(mgs,ls) = 0.0
13758 ELSE
13759 cx(mgs,ls) = max( 1.e-9, cx(mgs,ls) )
13760
13761 IF ( ilimit .ge. ipc(ls) ) THEN
13762 tmp = (xdn0(ls)*cx(mgs,ls))/(rho0(mgs)*qx(mgs,ls))
13763 tmp2 = (tmp*(3.14159))**(1./3.)
13764 cnox = cx(mgs,ls)*(tmp2)
13765 IF ( cnox .gt. 3.0*cno(ls) ) THEN
13766 cx(mgs,ls) = 3.0*cno(ls)/tmp2
13767 ENDIF
13768 ENDIF
13769 ENDIF
13770 end do
13771 end if
13772 if ( ipconc .ge. 5 ) then
13773 do mgs = 1,ngscnt
13774
13775 cx(mgs,lh) = max(an(igs(mgs),jy,kgs(mgs),lnh), 0.0)
13776 IF ( qx(mgs,lh) .le. qxmin(lh) ) THEN
13777! cx(mgs,lh) = 0.0
13778 ELSEIF ( cx(mgs,lh) .eq. 0.0 .and. qx(mgs,lh) .lt. 3.0*qxmin(lh) ) THEN
13779 qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lh)
13780 qx(mgs,lh) = 0.0
13781 ELSE
13782 cx(mgs,lh) = max( 1.e-9, cx(mgs,lh) )
13783 IF ( ilimit .ge. ipc(lh) ) THEN
13784 tmp = (xdn0(lh)*cx(mgs,lh))/(rho0(mgs)*qx(mgs,lh))
13785 tmp2 = (tmp*(3.14159))**(1./3.)
13786 cnox = cx(mgs,lh)*(tmp2)
13787 IF ( cnox .gt. 3.0*cno(lh) ) THEN
13788 cx(mgs,lh) = 3.0*cno(lh)/tmp2
13789 ENDIF
13790 ENDIF
13791 ENDIF
13792
13793
13794 end do
13795
13796
13797 end if
13798
13799 if ( lhl .gt. 1 .and. ipconc .ge. 5 ) then
13800 do mgs = 1,ngscnt
13801
13802 cx(mgs,lhl) = max(an(igs(mgs),jy,kgs(mgs),lnhl), 0.0)
13803 IF ( qx(mgs,lhl) .le. qxmin(lhl) ) THEN
13804 cx(mgs,lhl) = 0.0
13805 ELSEIF ( cx(mgs,lhl) .eq. 0.0 .and. qx(mgs,lhl) .lt. 3.0*qxmin(lhl) ) THEN
13806 qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lhl)
13807 qx(mgs,lhl) = 0.0
13808 ELSE
13809 cx(mgs,lhl) = max( 1.e-9, cx(mgs,lhl) )
13810 IF ( ilimit .ge. ipc(lhl) ) THEN
13811 tmp = (xdn0(lhl)*cx(mgs,lhl))/(rho0(mgs)*qx(mgs,lhl))
13812 tmp2 = (tmp*(3.14159))**(1./3.)
13813 cnox = cx(mgs,lhl)*(tmp2)
13814 IF ( cnox .gt. 3.0*cno(lhl) ) THEN
13815 cx(mgs,lhl) = 3.0*cno(lhl)/tmp2
13816 ENDIF
13817 ENDIF
13818 ENDIF
13819
13820
13821 end do
13822 end if
13823
13824!
13825! Set mean particle volume
13826!
13827 IF ( ldovol ) THEN
13828
13829 vx(:,:) = 0.0
13830
13831 DO il = li,lhab
13832
13833 IF ( lvol(il) .ge. 1 ) THEN
13834
13835 DO mgs = 1,ngscnt
13836 vx(mgs,il) = max(an(igs(mgs),jy,kgs(mgs),lvol(il)), 0.0)
13837 ENDDO
13838
13839 ENDIF
13840
13841 ENDDO
13842
13843 ENDIF
13844
13845
13846!
13847! Set liquid water fraction
13848!
13849 fhw(:) = 0.0
13850 fsw(:) = 0.0
13851 fhlw(:) = 0.0
13852
13853
13854
13855!
13856! 6th moments
13857!
13858
13859 IF ( ipconc .ge. 6 ) THEN
13860 zx(:,:) = 0.0
13861 DO il = lr,lhab
13862 IF ( lz(il) .gt. 1 ) THEN
13863 DO mgs = 1,ngscnt
13864 zx(mgs,il) = max( an(igs(mgs),jy,kgs(mgs),lz(il)), 0.0 )
13865 ENDDO
13866 ENDIF
13867 ENDDO
13868
13869 ENDIF
13870
13871 IF ( ipconc .ge. 6 ) THEN
13872
13873 IF ( lz(lr) .lt. 1 ) THEN
13874 g1x(:,lr) = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/ &
13875 & ((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar))
13876
13877
13878 DO mgs = 1,ngscnt
13879 IF ( cx(mgs,lr) .gt. 0.0 .and. qx(mgs,lr) .gt. qxmin(lr) ) THEN
13880
13881 vr = rho0(mgs)*qx(mgs,lr)/(1000.*cx(mgs,lr))
13882 IF ( lzr < 1 ) THEN
13883 IF ( imurain == 3 ) THEN
13884 zx(mgs,lr) = 3.6476*(rnu+2.0)*cx(mgs,lr)*vr**2/(rnu+1.0)
13885 ELSE ! imurain == 1
13886 zx(mgs,lr) = 3.6476*g1x(mgs,lr)*cx(mgs,lr)*vr**2
13887 ENDIF
13888 ENDIF
13889
13890 ENDIF
13891 ENDDO
13892 ENDIF
13893
13894 ENDIF
13895
13896
13897 scx(:,:) = 0.0
13898!
13899! set shape parameters
13900!
13901 if ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'ICEZVD_GS: dbg = set alpha'
13902 IF ( imurain == 1 ) THEN
13903 alpha(:,lr) = alphar
13904 ELSEIF ( imurain == 3 ) THEN
13905 alpha(:,lr) = xnu(lr)
13906 ENDIF
13907
13908 alpha(:,li) = xnu(li)
13909 alpha(:,lc) = xnu(lc)
13910
13911 IF ( imusnow == 1 ) THEN
13912 alpha(:,ls) = alphas
13913 ELSEIF ( imusnow == 3 ) THEN
13914 alpha(:,ls) = xnu(ls)
13915 ENDIF
13916
13917 if ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'ICEZVD_GS: dbg = set dab'
13918
13919 DO il = lr,lhab
13920 do mgs = 1,ngscnt
13921 IF ( il .ge. lg ) alpha(mgs,il) = dnu(il)
13922
13923
13924 DO ic = lc,lhab
13925 dab0lh(mgs,il,ic) = dab0(il,ic) ! dab0(ic,il)
13926 dab1lh(mgs,il,ic) = dab1(il,ic) ! dab1(ic,il)
13927 ENDDO
13928 end do
13929 ENDDO
13930
13931
13932! DO mgs = 1,ngscnt
13933 DO il = lr,lhab
13934 da0lx(:,il) = da0(il)
13935 ENDDO
13936 da0lh(:) = da0(lh)
13937 da0lr(:) = da0(lr)
13938 da1lr(:) = da1(lr)
13939 da0lc(:) = da0(lc)
13940 da1lc(:) = da1(lc)
13941
13942 if ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'ICEZVD_GS: dbg = set rz'
13943
13944 IF ( lzh < 1 .or. lzhl < 1 ) THEN
13945 rzxhlh(:) = rzhl/rz
13946 ELSEIF ( lzh > 1 .and. lzhl > 1 ) THEN
13947 rzxhlh(:) = 1.
13948 ENDIF
13949 IF ( lzr > 1 ) THEN
13950 rzxh(:) = 1.
13951 rzxhl(:) = 1.
13952 ELSE
13953 rzxh(:) = rz
13954 rzxhl(:) = rzhl
13955 ENDIF
13956
13957 IF ( imurain == 1 .and. imusnow == 3 .and. lzr < 1 ) THEN
13958 rzxs(:) = rzs
13959 ELSEIF ( imurain == imusnow .or. lzr > 1 ) THEN
13960 rzxs(:) = 1.
13961 ENDIF
13962 ! ENDDO
13963
13964 IF ( lhl .gt. 1 ) THEN
13965 DO mgs = 1,ngscnt
13966 da0lhl(mgs) = da0(lhl)
13967 ENDDO
13968 ENDIF
13969
13970 ventrx(:) = ventr
13971 ventrxn(:) = ventrn
13972 gf1palp(:) = gamma_sp(1.0 + alphar)
13973
13974!
13975! set factors
13976!
13977 do mgs = 1,ngscnt
13978!
13979 ssi(mgs) = qx(mgs,lv)/qis(mgs)
13980 ssw(mgs) = qx(mgs,lv)/qvs(mgs)
13981!
13982 tsqr(mgs) = temg(mgs)**2
13983!
13984 temgx(mgs) = min(temg(mgs),313.15)
13985 temgx(mgs) = max(temgx(mgs),233.15)
13986 felv(mgs) = 2500837.367 * (273.15/temgx(mgs))**((0.167)+(3.67e-4)*temgx(mgs))
13987!
13988 temcgx(mgs) = min(temg(mgs),273.15)
13989 temcgx(mgs) = max(temcgx(mgs),223.15)
13990 temcgx(mgs) = temcgx(mgs)-273.15
13991
13992! felf = latent heat of fusion, fels = LH of sublimation, felv = LH of vaporization
13993 felf(mgs) = 333690.6098 + (2030.61425)*temcgx(mgs) - (10.46708312)*temcgx(mgs)**2
13994!
13995 fels(mgs) = felv(mgs) + felf(mgs)
13996!
13997 felvs(mgs) = felv(mgs)*felv(mgs)
13998 felss(mgs) = fels(mgs)*fels(mgs)
13999
14000 IF ( eqtset <= 1 ) THEN
14001 felvcp(mgs) = felv(mgs)*cpi
14002 felscp(mgs) = fels(mgs)*cpi
14003 felfcp(mgs) = felf(mgs)*cpi
14004 ELSE
14005
14006 ! equations from appendix in Bryan and Morrison (2012, MWR)
14007 ! note that rw is Rv in the paper, and rd is R.
14008
14009 tmp = qx(mgs,li)+qx(mgs,ls)+qx(mgs,lh)
14010 IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl)
14011 IF ( lf > 1 ) tmp = tmp + qx(mgs,lf)
14012 cvm = cv+cvv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) &
14013 +cpigb*(tmp)
14014
14015 IF ( eqtset == 2 ) THEN ! compact form from treating dT/dt = theta*d(pi)/dt + pi*d(theta)dt and then applied to theta assuming constant pi
14016 felvcp(mgs) = (felv(mgs)-rw*temg(mgs))/cvm
14017 felscp(mgs) = (fels(mgs)-rw*temg(mgs))/cvm
14018 felfcp(mgs) = felf(mgs)/cvm
14019
14020 ELSE
14021 ! equivalent version that applies separate updates of latent heating to theta and pi, when both are returned.
14022
14023 cpm = cp+cpv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) &
14024 +cpigb*(tmp)
14025 rmm=rd+rw*qx(mgs,lv)
14026
14027 felvcp(mgs) = (felv(mgs)*cv/(cp) - rw*temg(mgs)*(1.0-rovcp*cpm/rmm))/cvm
14028 felscp(mgs) = (fels(mgs)*cv/(cp) - rw*temg(mgs)*(1.0-rovcp*cpm/rmm))/cvm
14029 felfcp(mgs) = felf(mgs)*cv/(cp*cvm)
14030
14031 felvpi(mgs) = pi0(mgs)*rovcp*(felv(mgs)/(temg(mgs)) - rw*cpm/rmm)/cvm
14032 felspi(mgs) = pi0(mgs)*rovcp*(fels(mgs)/(temg(mgs)) - rw*cpm/rmm)/cvm
14033 felfpi(mgs) = pi0(mgs)*rovcp*(felf(mgs)/(cvm*temg(mgs)))
14034
14035 ENDIF
14036
14037 ENDIF
14038!
14039 fgamw(mgs) = felvcp(mgs)/pi0(mgs)
14040 fgams(mgs) = felscp(mgs)/pi0(mgs)
14041!
14042 fcqv1(mgs) = 4098.0258*pi0(mgs)*fgamw(mgs)
14043 fcqv2(mgs) = 5807.6953*pi0(mgs)*fgams(mgs)
14044 fcc3(mgs) = felfcp(mgs)/pi0(mgs)
14045!
14046! fwvdf = water vapor diffusivity
14047 fwvdf(mgs) = (2.11e-05)*((temg(mgs)/tfr)**1.94)*(101325.0/(pres(mgs)))
14048!
14049! fadvisc = 'd' for dynamic viscosity
14050! fakvisc = 'k' for kinematic viscosity
14051 fadvisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))*(temg(mgs)/296.0)**(1.5) ! dynamic visc.
14052!
14053 fakvisc(mgs) = fadvisc(mgs)*rhoinv(mgs) ! divide by rho_air to get kinematic visc. (note the 'k' vs. 'd')
14054!
14055 temcgx(mgs) = min(temg(mgs),273.15)
14056 temcgx(mgs) = max(temcgx(mgs),233.15)
14057 temcgx(mgs) = temcgx(mgs)-273.15
14058 fci(mgs) = (2.118636 + 0.007371*(temcgx(mgs)))*(1.0e+03)
14059!
14060 if ( temg(mgs) .lt. 273.15 ) then
14061 temcgx(mgs) = min(temg(mgs),273.15)
14062 temcgx(mgs) = max(temcgx(mgs),233.15)
14063 temcgx(mgs) = temcgx(mgs)-273.15
14064 fcw(mgs) = 4203.1548 + (1.30572e-2)*((temcgx(mgs)-35.)**2) &
14065 & + (1.60056e-5)*((temcgx(mgs)-35.)**4)
14066 end if
14067 if ( temg(mgs) .ge. 273.15 ) then
14068 temcgx(mgs) = min(temg(mgs),308.15)
14069 temcgx(mgs) = max(temcgx(mgs),273.15)
14070 temcgx(mgs) = temcgx(mgs)-273.15
14071 fcw(mgs) = 4243.1688 + (3.47104e-1)*(temcgx(mgs)**2)
14072 end if
14073!
14074 ftka(mgs) = tka0*fadvisc(mgs)/advisc1 ! thermal conductivity: proportional to dynamic viscosity
14075 fthdf(mgs) = ftka(mgs)*cpi*rhoinv(mgs)
14076!
14077 fschm(mgs) = (fakvisc(mgs)/fwvdf(mgs)) ! Schmidt number
14078 fpndl(mgs) = (fakvisc(mgs)/fthdf(mgs)) ! Prandl number (only used for bin melting)
14079!
14080 fai(mgs) = (fels(mgs)**2)/(ftka(mgs)*rw*temg(mgs)**2)
14081 fbi(mgs) = (1.0/(rho0(mgs)*fwvdf(mgs)*qis(mgs)))
14082 fav(mgs) = (felv(mgs)**2)/(ftka(mgs)*rw*temg(mgs)**2)
14083 fbv(mgs) = (1.0/(rho0(mgs)*fwvdf(mgs)*qvs(mgs)))
14084
14085 kp1 = min(nz, kgs(mgs)+1 )
14086 wvel(mgs) = (0.5)*(w(igs(mgs),jgs,kp1) &
14087 & +w(igs(mgs),jgs,kgs(mgs)))
14088
14089!
14090 end do
14091!
14092!
14093! ice habit fractions
14094!
14095!
14096!
14097! Set density
14098!
14099 if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: Set density'
14100!
14101
14102 do mgs = 1,ngscnt
14103 xdn(mgs,li) = xdn0(li)
14104 xdn(mgs,lc) = xdn0(lc)
14105 xdn(mgs,lr) = xdn0(lr)
14106 xdn(mgs,ls) = xdn0(ls)
14107 xdn(mgs,lh) = xdn0(lh)
14108 IF ( lvol(ls) .gt. 1 ) THEN
14109 IF ( vx(mgs,ls) .gt. 0.0 .and. qx(mgs,ls) .gt. qxmin(ls) ) THEN
14110 xdn(mgs,ls) = min( xdnmx(ls), max( xdnmn(ls), rho0(mgs)*qx(mgs,ls)/vx(mgs,ls) ) )
14111 ENDIF
14112 ENDIF
14113
14114 IF ( lvol(lh) .gt. 1 ) THEN
14115 IF ( vx(mgs,lh) .gt. 0.0 .and. qx(mgs,lh) .gt. qxmin(lh) ) THEN
14116 IF ( mixedphase ) THEN
14117 ELSE
14118 dnmx = xdnmx(lh)
14119 ENDIF
14120 xdn(mgs,lh) = min( dnmx, max( xdnmn(lh), rho0(mgs)*qx(mgs,lh)/vx(mgs,lh) ) )
14121 vx(mgs,lh) = rho0(mgs)*qx(mgs,lh)/xdn(mgs,lh)
14122
14123 ELSEIF ( vx(mgs,lh) == 0.0 .and. qx(mgs,lh) .gt. qxmin(lh) ) THEN ! if volume is zero, need to initialize the default value
14124
14125 vx(mgs,lh) = rho0(mgs)*qx(mgs,lh)/xdn(mgs,lh)
14126
14127 ENDIF
14128 ENDIF
14129
14130
14131 IF ( lhl .gt. 1 ) THEN
14132
14133 xdn(mgs,lhl) = xdn0(lhl)
14134 xdntmp(mgs,lhl) = xdn0(lhl)
14135
14136 IF ( lvol(lhl) .gt. 1 ) THEN
14137 IF ( vx(mgs,lhl) .gt. 0.0 .and. qx(mgs,lhl) .gt. qxmin(lhl) ) THEN
14138
14139 IF ( mixedphase .and. lhlw > 1 ) THEN
14140 ELSE
14141 dnmx = xdnmx(lhl)
14142 ENDIF
14143
14144 xdn(mgs,lhl) = min( dnmx, max( xdnmn(lhl), rho0(mgs)*qx(mgs,lhl)/vx(mgs,lhl) ) )
14145 vx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/xdn(mgs,lhl)
14146 xdntmp(mgs,lhl) = xdn(mgs,lhl)
14147
14148 ELSEIF ( vx(mgs,lhl) == 0.0 .and. qx(mgs,lhl) .gt. qxmin(lhl) ) THEN ! if volume is zero, need to initialize the default value
14149
14150 vx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/xdn(mgs,lhl)
14151
14152 ENDIF
14153 ENDIF
14154
14155 ENDIF
14156
14157
14158 end do
14159
14160 IF ( ipconc == 5 .and. imydiagalpha == 2 ) THEN
14161
14162 cwchtmp = ((3. + dnu(lh))*(2. + dnu(lh))*(1.0 + dnu(lh)))**(-1./3.)
14163
14164 DO mgs = 1,ngscnt
14165 !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)
14166 IF ( qx(mgs,lr) .gt. qxmin(lr) .and. cx(mgs,lr) > cxmin ) THEN
14167 xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) !
14168 xdia(mgs,lr,3) = (xv(mgs,lr)*6.0*cwc1)**(1./3.)
14169 ! alpha(mgs,lr) = Min(alphamax, c1r*tanh(c2r*(xdia(mgs,lr,3)*1000. - c3r)) + c4r)
14170 ! IF ( igs(mgs) == 19 ) write(0,*) 'imy: i,k,alpr,xdia = ',igs(mgs),kgs(mgs),alpha(mgs,lr),xdia(mgs,lr,3)*1000.
14171
14172 ! M&M-C 2010:
14173 tmp = 4. + alphar
14174 i = int(dgami*(tmp))
14175 del = tmp - dgam*i
14176 x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
14177
14178 tmp = 1. + alphar
14179 i = int(dgami*(tmp))
14180 del = tmp - dgam*i
14181 y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
14182
14183 tmp = (x/y)**(1./3.)*xdia(mgs,lr,3)*cwchtmp
14184
14185 alpha(mgs,lr) = min(15., 11.8*(1000.*tmp - 0.7)**2 + 2.)
14186 ENDIF
14187 IF ( qx(mgs,lh) .gt. qxmin(lh) .and. cx(mgs,lh) > cxmin ) THEN
14188! MY 2005:
14189 xv(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) !
14190 xdia(mgs,lh,3) = (xv(mgs,lh)*6.*piinv)**(1./3.) ! mwfac*xdia(mgs,lh,1) ! (xv(mgs,lh)*cwc0*6.0)**(1./3.)
14191! alpha(mgs,lh) = Min(alphamax, c1h*tanh(c2h*(xdia(mgs,lh,3)*1000. - c3h)) + c4h)
14192
14193 ! M&M-C 2010:
14194 tmp = 4. + dnu(lh)
14195 i = int(dgami*(tmp))
14196 del = tmp - dgam*i
14197 x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
14198
14199 tmp = 1. + dnu(lh)
14200 i = int(dgami*(tmp))
14201 del = tmp - dgam*i
14202 y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
14203
14204 tmp = (x/y)**(1./3.)*xdia(mgs,lh,3)*cwchtmp
14205
14206 alpha(mgs,lh) = min(15., 11.8*(1000.*tmp - 0.7)**2 + 2.)
14207 ! alphan(mgs,lh) = alpha(mgs,lh)
14208
14209 ! IF ( igs(mgs) == 19 ) write(0,*) 'imy: i,k,alph,xdia = ',igs(mgs),kgs(mgs),alpha(mgs,lh),xdia(mgs,lh,3)*1000.
14210 il = lh
14211 DO ic = lc,lh-1 ! lhab
14212 i = nint( alpha(mgs,il)*dqiacralphainv )
14213 IF ( ic == lc .or. ic == li .or. ic == ls .or. (ic == lr .and. imurain == 3) ) THEN
14214 alp = (3.*alpha(mgs,ic) + 2.)
14215 j = nint( (3.*alpha(mgs,ic) + 2.)*dqiacralphainv )
14216 ELSE ! IF ( ic == lr .and. imurain == 1 ) ! rain
14217 alp = alpha(mgs,ic)
14218 j = nint( alpha(mgs,ic)*dqiacralphainv )
14219 ENDIF
14220
14221 dab0lh(mgs,ic,il) = dab0lu(j,i,ic,il)
14222 dab1lh(mgs,ic,il) = dab1lu(j,i,ic,il)
14223 dab0lh(mgs,il,ic) = dab0lu(i,j,il,ic)
14224 dab1lh(mgs,il,ic) = dab1lu(i,j,il,ic)
14225 ENDDO
14226 ENDIF
14227! alpha(:,lr) = 0. ! 10.
14228! alpha(:,lh) = 0. ! 10.
14229 IF ( lhl > 0 ) THEN
14230 IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. cx(mgs,lhl) > cxmin ) THEN
14231 xv(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*cx(mgs,lhl)) !
14232 xdia(mgs,lhl,3) = (xv(mgs,lhl)*6.*piinv)**(1./3.)
14233 IF ( xdia(mgs,lhl,3) < 0.008 ) THEN
14234 alpha(mgs,lhl) = min(alphamax, c1hl*tanh(c2hl*(xdia(mgs,lhl,3)*1000. - c3hl)) + c4hl)
14235 ELSE
14236 alpha(mgs,lhl) = min(alphamax, c5hl*xdia(mgs,lhl,3)*1000. + c6hl)
14237 ENDIF
14238
14239 il = lhl
14240 DO ic = lc,lh-1 ! lhab
14241 i = nint( alpha(mgs,il)*dqiacralphainv )
14242 IF ( ic == lc .or. ic == li .or. ic == ls .or. (ic == lr .and. imurain == 3) ) THEN
14243 alp = (3.*alpha(mgs,ic) + 2.)
14244 j = nint( (3.*alpha(mgs,ic) + 2.)*dqiacralphainv )
14245 ELSE ! IF ( ic == lr .and. imurain == 1 ) ! rain
14246 alp = alpha(mgs,ic)
14247 j = nint( alpha(mgs,ic)*dqiacralphainv )
14248 ENDIF
14249
14250 dab0lh(mgs,ic,il) = dab0lu(j,i,ic,il)
14251 dab1lh(mgs,ic,il) = dab1lu(j,i,ic,il)
14252 dab0lh(mgs,il,ic) = dab0lu(i,j,il,ic)
14253 dab1lh(mgs,il,ic) = dab1lu(i,j,il,ic)
14254 ENDDO
14255
14256 ENDIF
14257 ENDIF
14258
14259
14260
14261 ENDDO
14262 ENDIF
14263
14264
14265 IF ( imurain == 3 ) THEN
14266 IF ( lzr > 1 ) THEN
14267 alphashr = 0.0
14268 alphamlr = -2.0/3.0
14269 alphasmlr = -2.0/3.0
14270 ELSE
14271 alphashr = xnu(lr)
14272 alphamlr = xnu(lr)
14273 alphasmlr = xnu(lr)
14274 ENDIF
14275! massfacshr = ( (2. + 3.*(1. +alphashr) )/( 3.*(1. + alphashr) ) )**(1./3.) ! this is the diameter factor
14276! massfacmlr = ( (2. + 3.*(1. +alphamlr) )/( 3.*(1. + alphamlr) ) )**(1./3.)
14277 massfacshr = ( (2. + 3.*(1. +alphashr) )**3/( 3.*(1. + alphashr) ) ) ! this is the mass or volume factor
14278 massfacmlr = ( (2. + 3.*(1. +alphamlr) )**3/( 3.*(1. + alphamlr) ) )
14279 ELSEIF ( imurain == 1 ) THEN
14280 IF ( lzr > 1 ) THEN
14281 alphashr = 4.0
14282 alphamlr = 4.0
14283 alphasmlr = alphasmlr0
14284 ELSE
14285 alphashr = alphar
14286 alphamlr = alphar
14287 alphasmlr = alphar
14288 ENDIF
14289! massfacshr = (3.0 + alphashr)*((3.+alphashr)*(2.+alphashr)*(1. + alphashr) )**(-1./3.) ! this is the diameter factor
14290! massfacmlr = (3.0 + alphamlr)*((3.+alphamlr)*(2.+alphamlr)*(1. + alphamlr) )**(-1./3.)
14291 massfacshr = (3.0 + alphashr)**3/((3.+alphashr)*(2.+alphashr)*(1. + alphashr) ) ! this is the mass or volume factor
14292 massfacmlr = (3.0 + alphamlr)**3/((3.+alphamlr)*(2.+alphamlr)*(1. + alphamlr) )
14293 ENDIF
14294
14295! Find shape parameter rain
14296
14297 g1shr = 1.0
14298 g1mlr = 1.0
14299 g1smlr = 1.0
14300
14301! CALL cld_cpu('Z-MOMENT-1')
14302
14303 IF ( ipconc >= 6 ) THEN
14304
14305 ! set base g1x in case rain is not 3-moment
14306 IF ( ipconc >= 6 .and. imurain == 3 ) THEN
14307 il = lr
14308 DO mgs = 1,ngscnt
14309! g1x(mgs,il) = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
14310 g1x(mgs,il) = (alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0))
14311 ENDDO
14312 ENDIF
14313
14314 IF (lzr > 1 ) THEN
14315 IF ( imurain == 3 ) THEN
14316 g1shr = (alphashr+2.0)/((alphashr+1.0))
14317 g1mlr = (alphamlr+2.0)/((alphamlr+1.0))
14318 g1smlr = (alphasmlr+2.0)/((alphasmlr+1.0))
14319 ELSEIF ( imurain == 1 ) THEN
14320! g1shr = 36.*(6.0 + alphashr)*(5.0 + alphashr)*(4.0 + alphashr)/ &
14321! & (pi**2*(3.0 + alphashr)*(2.0 + alphashr)*(1.0 + alphashr))
14322 g1shr = (6.0 + alphashr)*(5.0 + alphashr)*(4.0 + alphashr)/ &
14323 & ((3.0 + alphashr)*(2.0 + alphashr)*(1.0 + alphashr))
14324! g1mlr = 36.*(6.0 + alphamlr)*(5.0 + alphamlr)*(4.0 + alphamlr)/ &
14325! & (pi**2*(3.0 + alphamlr)*(2.0 + alphamlr)*(1.0 + alphamlr))
14326 g1mlr = (6.0 + alphamlr)*(5.0 + alphamlr)*(4.0 + alphamlr)/ &
14327 & ((3.0 + alphamlr)*(2.0 + alphamlr)*(1.0 + alphamlr))
14328 g1smlr = (6.0 + alphasmlr)*(5.0 + alphasmlr)*(4.0 + alphasmlr)/ &
14329 & ((3.0 + alphasmlr)*(2.0 + alphasmlr)*(1.0 + alphasmlr))
14330 ENDIF
14331 ENDIF
14332
14333 IF ( lzr > 1 .and. imurain == 3 ) THEN ! { RAIN SHAPE PARAM
14334
14335
14336! CALL cld_cpu('Z-MOMENT-1r')
14337 il = lr
14338 DO mgs = 1,ngscnt
14339
14340
14341 IF ( iresetmoments == 1 .or. iresetmoments == il .or. iresetmoments == -1 ) THEN ! .or. qx(mgs,il) <= qxmin(il) THEN
14342 IF ( zx(mgs,il) <= zxmin ) THEN ! .and. qx(mgs,il) > 0.05e-3 THEN
14343!! write(91,*) 'zx=0; qx,cx = ',1000.*qx(mgs,il),cx(mgs,il)
14344 qx(mgs,il) = 0.0
14345 cx(mgs,il) = 0.0
14346 an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
14347 an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
14348 an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
14349 ELSEIF ( iresetmoments == -1 .and. qx(mgs,il) < qxmin(il) ) THEN
14350 zx(mgs,il) = 0.0
14351 cx(mgs,il) = 0.0
14352 an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
14353
14354 qx(mgs,il) = 0.0
14355 an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
14356 an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
14357 an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
14358
14359 ELSEIF ( cx(mgs,il) <= cxmin .and. iresetmoments /= -1 ) THEN ! .and. qx(mgs,il) > 0.05e-3 THEN
14360
14361 qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il)
14362 zx(mgs,lr) = 0.0
14363 qx(mgs,lr) = 0.0
14364 an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),lr)
14365 an(igs(mgs),jgs,kgs(mgs),lr) = qx(mgs,lr)
14366 an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr)
14367 ENDIF
14368 ENDIF
14369
14370 IF ( .false. .and. zx(mgs,il) <= zxmin .and. cx(mgs,il) <= cxmin ) THEN
14371 zx(mgs,il) = 0.0
14372 cx(mgs,il) = 0.0
14373 an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
14374
14375 qx(mgs,il) = 0.0
14376 an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
14377 an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
14378 an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
14379 ENDIF
14380
14381 IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN
14382
14383 xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*max(1.0e-11,cx(mgs,lr)))
14384 IF ( xv(mgs,lr) .gt. xvmx(lr) ) THEN
14385! xv(mgs,lr) = xvmx(lr)
14386! cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmx(lr)*xdn(mgs,lr))
14387 ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN
14388 xv(mgs,lr) = xvmn(lr)
14389 cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr))
14390 ENDIF
14391
14392 IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN
14393! have mass and reflectivity but no concentration, so set concentration, using default alpha
14394 g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
14395 z = zx(mgs,il)
14396 qr = qx(mgs,il)
14397 cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*xdn(mgs,lr)**2)
14398! an(igs(mgs),jgs,kgs(mgs),ln(il)) = zx(mgs,il)
14399 ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > 0.0 ) THEN
14400! have mass and concentration but no reflectivity, so set reflectivity, using default alpha
14401 g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
14402 chw = cx(mgs,il)
14403 qr = qx(mgs,il)
14404 zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(xdn(mgs,lr)**2*chw)
14405 an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr)
14406
14407 ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN
14408! How did this happen?
14409 ! set values according to dBZ of -10, or Z = 0.1
14410! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2
14411 zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2
14412 an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
14413
14414 g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
14415 z = zx(mgs,il)
14416 qr = qx(mgs,il)
14417 cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*1000.*1000)
14418 an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
14419 ENDIF
14420
14421 IF ( zx(mgs,lr) > 0.0 ) THEN
14422 xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(1000.*cx(mgs,lr))
14423 vr = xv(mgs,lr)
14424 qr = qx(mgs,lr)
14425 nrx = cx(mgs,lr)
14426 z = zx(mgs,lr)
14427
14428! xv = (db(1,kz)*a(1,1,kz,lr))**2/(a(1,1,kz,lnr))
14429! rd = z*(pi/6.*1000.)**2/xv
14430
14431! determine shape parameter alpha by iteration
14432 IF ( z .gt. 0.0 ) THEN
14433! alpha(mgs,lr) = 3.
14434 alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
14435 DO i = 1,20
14436 IF ( abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT
14437 alpha(mgs,lr) = max( rnumin, min( rnumax, alp ) )
14438 alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
14439 alp = max( rnumin, min( rnumax, alp ) )
14440 ENDDO
14441
14442! check for artificial breakup (rain larger than allowed max size)
14443 IF ( (xv(mgs,il) .gt. xvmx(il) .or. (ioldlimiter >= 2 .and. xv(mgs,il) .gt. xvmx(il)/8.) )) THEN
14444 tmp = cx(mgs,il)
14445 IF ( ioldlimiter >= 2 ) THEN ! MY-style active breakup
14446 x = (6.*rho0(mgs)*qx(mgs,il)/(pi*xdn(mgs,il)*cx(mgs,il)))**(1./3.)
14447 x1 = max(0.0e-3, x - 3.0e-3)
14448 x2 = max(0.5, x/6.0e-3)
14449 x3 = x2**3
14450 cx(mgs,il) = cx(mgs,il)*max((1.+2.222e3*x1**2), x3)
14451 xv(mgs,il) = xv(mgs,il)/max((1.+2.222e3*x1**2), x3)
14452 ELSE ! simple cutoff
14453 xv(mgs,il) = min( xvmx(il), max( xvmn(il),xv(mgs,il) ) )
14454 xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
14455 cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
14456 ENDIF
14457 !xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
14458 !cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
14459
14460 IF ( tmp < cx(mgs,il) ) THEN ! breakup
14461
14462 g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
14463 zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) )
14464 an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
14465
14466 vr = xv(mgs,lr)
14467 qr = qx(mgs,lr)
14468 nrx = cx(mgs,lr)
14469 z = zx(mgs,lr)
14470
14471
14472! determine shape parameter alpha by iteration
14473 alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
14474 DO i = 1,20
14475 IF ( abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT
14476 alpha(mgs,lr) = max( rnumin, min( rnumax, alp ) )
14477 alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
14478 alp = max( rnumin, min( rnumax, alp ) )
14479 ENDDO
14480
14481
14482 ENDIF
14483 ENDIF
14484
14485!
14486! Check whether the shape parameter is at or less than the minimum, and if it is, reset the
14487! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N)
14488!
14489 g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
14490 IF ( .true. .and. (alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax) ) THEN
14491
14492 IF ( rescale_high_alpha .and. alp >= rnumax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z
14493 cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(1./(xdn(mgs,il)))**2
14494 an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il)
14495
14496 ELSEIF ( rescale_low_alphar .and. alp <= rnumin ) THEN
14497 z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2)
14498 zx(mgs,il) = z
14499 an(igs(mgs),jy,kgs(mgs),lz(il)) = zx(mgs,il)
14500 ENDIF
14501 ENDIF
14502
14503 ! set g1x to use as G factor later. If alpha is in the range ( rnumin < alpha < rnumax ), then
14504 ! this will be the same as computing G from alpha. If alpha = rnumax, however, it probably means that
14505 ! the moments are not matched correctly, so we compute G from the moments instead so that the dZ/dt rates
14506 ! stay consistent with dN/dt and dq/dt.
14507 IF ( alp >= rnumax - 0.01 ) THEN
14508! g1x(mgs,il) = 6**2*zx(mgs,il)/(cx(mgs,il)*(pi*xv(mgs,lr))**2)
14509! g1x(mgs,il) = xdn(mgs,il)*zx(mgs,il)*cx(mgs,il)/((rho0(mgs)*qx(mgs,lr))**2)
14510 g1x(mgs,il) = (pi*xdn(mgs,il))**2*zx(mgs,il)*cx(mgs,il)/((6.*rho0(mgs)*qx(mgs,il))**2)
14511 ELSE
14512 g1x(mgs,il) = g1
14513 ENDIF
14514
14515 tmp = alpha(mgs,lr) + 4./3.
14516 i = int(dgami*(tmp))
14517 del = tmp - dgam*i
14518 x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
14519
14520 tmp = alpha(mgs,lr) + 1.
14521 i = int(dgami*(tmp))
14522 del = tmp - dgam*i
14523 y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
14524
14525 gf1palp(mgs) = y
14526
14527! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 4./3.)/(alpha(mgs,lr) + 1.)**(1./3.)/Gamma_sp(alpha(mgs,lr) + 1.)
14528 ventrx(mgs) = x/(y*(alpha(mgs,lr) + 1.)**(1./3.))
14529
14530 IF ( imurain == 3 .and. izwisventr == 2 ) THEN
14531
14532 tmp = alpha(mgs,lr) + 1.5 + br/6.
14533 i = int(dgami*(tmp))
14534 del = tmp - dgam*i
14535 x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
14536
14537! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 1.5 + br/6.)/Gamma_sp(alpha(mgs,lr) + 1.)
14538 ventrxn(mgs) = x/(y*(alpha(mgs,lr) + 1.)**((1.+br)/6. + 1./3.))
14539
14540! This whole section is imurain == 3, so this branch never runs
14541! ELSEIF ( imurain == 1 .and. iferwisventr == 2 ) THEN
14542!
14543! tmp = alpha(mgs,lr) + 2.5 + br/2.
14544! i = Int(dgami*(tmp))
14545! del = tmp - dgam*i
14546! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
14547!
14548!! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 1.5 + br/6.)/Gamma_sp(alpha(mgs,lr) + 1.)
14549! ventrxn(mgs) = x/y
14550
14551
14552 ENDIF
14553
14554 ENDIF
14555 ENDIF
14556
14557 ENDIF
14558
14559 ENDDO
14560! CALL cld_cpu('Z-MOMENT-1r')
14561 ENDIF ! }
14562
14563 ENDIF ! ipconc >= 6
14564
14565! Find shape parameters for graupel and hail
14566 IF ( ipconc .ge. 6 ) THEN
14567
14568 DO il = lr,lhab
14569
14570 ! set base values of g1x
14571 IF ( (.not. ( il == lr .and. imurain == 3 )) .and. ( il == lr .or. il == lh .or. il == lhl .or. il == lf ) ) THEN
14572 DO mgs = 1,ngscnt
14573 g1x(mgs,il) = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
14574 & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
14575 ENDDO
14576 ENDIF
14577
14578 IF ( lz(il) .gt. 1 .and. ( .not. ( il == lr .and. imurain == 3 )) ) THEN
14579
14580 DO mgs = 1,ngscnt
14581
14582
14583 IF ( iresetmoments == 1 .or. iresetmoments == il .or. iresetmoments == -1 ) THEN ! .or. qx(mgs,il) <= qxmin(il) ) THEN
14584 IF ( zx(mgs,il) <= zxmin ) THEN ! .and. qx(mgs,il) > 0.05e-3 ) THEN
14585!! write(91,*) 'zx=0; qx,cx = ',1000.*qx(mgs,il),cx(mgs,il)
14586 qx(mgs,il) = 0.0
14587 cx(mgs,il) = 0.0
14588 zx(mgs,il) = 0.0
14589 an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
14590 an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
14591 an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
14592 an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
14593 ELSEIF ( iresetmoments == -1 .and. qx(mgs,il) < qxmin(il) ) THEN
14594 zx(mgs,il) = 0.0
14595 cx(mgs,il) = 0.0
14596 an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
14597
14598 qx(mgs,il) = 0.0
14599 an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
14600 an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
14601 an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
14602
14603 ELSEIF ( cx(mgs,il) <= cxmin .and. iresetmoments /= -1 ) THEN ! .and. qx(mgs,il) > 0.05e-3 ) THEN
14604 qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il)
14605 zx(mgs,il) = 0.0
14606 cx(mgs,il) = 0.0
14607 qx(mgs,il) = 0.0
14608 an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
14609 an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
14610 an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
14611 an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
14612 ENDIF
14613 ENDIF
14614
14615 IF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= cxmin ) THEN
14616 zx(mgs,il) = 0.0
14617 cx(mgs,il) = 0.0
14618 an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
14619
14620 qx(mgs,il) = 0.0
14621 an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
14622 an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
14623 an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
14624 ENDIF
14625
14626 IF ( qx(mgs,il) .gt. qxmin(il) ) THEN
14627
14628 xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*max(1.0e-9,cx(mgs,il)))
14629 xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
14630
14631 IF ( xv(mgs,il) .lt. xvmn(il) ) THEN
14632 xv(mgs,il) = min( xvmx(il), max( xvmn(il),xv(mgs,il) ) )
14633 xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
14634 cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
14635 ENDIF
14636
14637 IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN
14638! have mass and reflectivity but no concentration, so set concentration, using default alpha
14639 g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
14640 & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
14641 z = zx(mgs,il)
14642 qr = qx(mgs,il)
14643! cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z
14644 cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(z*(pi*xdn(mgs,il))**2)
14645
14646 ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > cxmin ) THEN
14647! have mass and concentration but no reflectivity, so set reflectivity, using default alpha
14648! g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
14649! & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
14650 chw = cx(mgs,il)
14651 qr = qx(mgs,il)
14652! zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw
14653! zx(mgs,il) = Min(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(chw*(pi*xdn(mgs,il))**2) )
14654 g1 = (6.0 + alphamax)*(5.0 + alphamax)*(4.0 + alphamax)/ &
14655 & ((3.0 + alphamax)*(2.0 + alphamax)*(1.0 + alphamax))
14656 zx(mgs,il) = max(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(chw*(pi*xdn(mgs,il))**2) )
14657 an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
14658
14659 ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN
14660! How did this happen?
14661 ! set values according to dBZ of -10, or Z = 0.1
14662! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2
14663 zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2
14664 an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
14665
14666 g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
14667 & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
14668 z = zx(mgs,il)
14669 qr = qx(mgs,il)
14670! cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z
14671 cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(z*(pi*xdn(mgs,il))**2)
14672 an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
14673 ELSE
14674
14675 chw = cx(mgs,il)
14676 qr = qx(mgs,il)
14677 z = zx(mgs,il)
14678
14679 IF ( zx(mgs,il) .gt. 0. ) THEN
14680
14681! rdi = z*(pi/6.*1000.)**2*chw/((rho0(mgs)*qr)**2)
14682 rdi = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2)
14683
14684! alp = 1.e18*(6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/
14685! : ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
14686 alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
14687 & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
14688! print*,'kz, alp, alpha(mgs,il) = ',kz,alp,alpha(mgs,il),rdi,z,xv
14689 alp = max( alphamin, min( alphamax, alp ) )
14690
14691 IF ( newton ) THEN
14692 DO i = 1,10
14693 IF ( abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT
14694 alpha(mgs,il) = max( alphamin, min( alphamax, alp ) )
14695 alp = alp + ( galpha(alp) - rdi )/dgalpha(alp)
14696 alp = max( alphamin, min( alphamax, alp ) )
14697 ENDDO
14698
14699 ELSE
14700 DO i = 1,10
14701! IF ( 100.*Abs(alp - alpha(mgs,il))/(Abs(alpha(mgs,il))+1.e-5) .lt. 1. ) EXIT
14702 IF ( abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT
14703 alpha(mgs,il) = max( alphamin, min( alphamax, alp ) )
14704! alp = 1.e18*(6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/
14705! : ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
14706 alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
14707 & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
14708! print*,'i,alp = ',i,alp
14709 alp = max( alphamin, min( alphamax, alp ) )
14710 ENDDO
14711 ENDIF
14712
14713
14714! check for artificial breakup (graupel/hail larger than allowed max size)
14715 IF ( imaxdiaopt == 1 ) THEN
14716 xvbarmax = xvmx(il)
14717 ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter
14718 xvbarmax = xvmx(il) /((3. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il))))
14719 ELSEIF ( imaxdiaopt == 3 ) THEN ! test against mass-weighted diameter
14720 xvbarmax = xvmx(il) /((4. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il))))
14721 ELSE
14722 xvbarmax = xvmx(il)
14723 ENDIF
14724
14725 IF ( xv(mgs,il) .gt. xvbarmax .or. (il == lr .and. ioldlimiter >= 2 .and. xv(mgs,il) .gt. xvmx(il)/8.)) THEN
14726 tmp = cx(mgs,il)
14727 IF( ioldlimiter >= 2 .and. il == lr) THEN ! MY-style drop limiter for rain
14728 x = (6.*rho0(mgs)*qx(mgs,il)/(pi*xdn(mgs,il)*cx(mgs,il)))**(1./3.)
14729 x1 = max(0.0e-3, x - 3.0e-3)
14730 x2 = max(0.5, x/6.0e-3)
14731 x3 = x2**3
14732 cx(mgs,il) = cx(mgs,il)*max((1.+2.222e3*x1**2), x3)
14733 xv(mgs,il) = xv(mgs,il)/max((1.+2.222e3*x1**2), x3)
14734 ELSE
14735 xv(mgs,il) = min( xvbarmax, max( xvmn(il),xv(mgs,il) ) )
14736 xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
14737 cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
14738 ENDIF
14739 IF ( tmp < cx(mgs,il) ) THEN ! artificial breakup has happened, so need to adjust reflectivity and find new shape parameter
14740 g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
14741 & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2)
14742 zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) )
14743 an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
14744
14745 chw = cx(mgs,il)
14746 qr = qx(mgs,il)
14747 z = zx(mgs,il)
14748
14749 rdi = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2)
14750 alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
14751 & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
14752 DO i = 1,10
14753 IF ( abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT
14754 alpha(mgs,il) = max( alphamin, min( alphamax, alp ) )
14755 alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
14756 & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
14757 alp = max( alphamin, min( alphamax, alp ) )
14758 ENDDO
14759
14760
14761 ENDIF
14762 ENDIF
14763
14764!
14765! Check whether the shape parameter is at or less than the minimum, and if it is, reset the
14766! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N)
14767!
14768 g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
14769 & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
14770
14771 IF ( ( lrescalelow(il) .or. rescale_high_alpha ) .and. &
14772 & ( alpha(mgs,il) <= alphamin .or. alp == alphamin .or. alp == alphamax ) ) THEN
14773
14774
14775
14776 IF ( rescale_high_alpha .and. alp >= alphamax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z
14777 cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2
14778 an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il)
14779
14780 ELSEIF ( lrescalelow(il) .and. alp <= alphamin .and. .not. (il == lh .and. icvhl2h > 0 ) .and. &
14781 .not. ( il == lr .and. .not. rescale_low_alphar ) ) THEN ! alpha = alphamin, so reset Z to prevent growth in C
14782 wtest = .false.
14783 IF ( irescalerainopt == 0 ) THEN
14784 wtest = .false.
14785 ELSEIF ( irescalerainopt == 1 ) THEN
14786 wtest = qx(mgs,lc) > qxmin(lc)
14787 ELSEIF ( irescalerainopt == 2 ) THEN
14788 wtest = qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < rescale_wthresh
14789 ELSEIF ( irescalerainopt == 3 ) THEN
14790 wtest = temcg(mgs) > rescale_tempthresh .and. qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < rescale_wthresh
14791 ENDIF
14792
14793 IF ( il == lr .and. ( wtest ) ) THEN
14794! IF ( temcg(mgs) > 0.0 .and. il == lr .and. qx(mgs,lc) > qxmin(lc) ) THEN
14795 ! certain situations where rain number is adjusted instead of Z. Helps avoid rain being 'zapped' by autoconverted
14796 ! drops (i.e., favor preserving Z when alpha tries to go negative)
14797 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
14798 cx(mgs,il) = chw
14799 an(igs(mgs),jy,kgs(mgs),ln(il)) = chw
14800 ELSE
14801
14802 ! Usual resetting of reflectivity moment to force consisntency between Q, N, Z, and alpha when alpha = alphamin
14803 z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw
14804 z = z1*(6./(pi*xdn(mgs,il)))**2
14805 zx(mgs,il) = z
14806 an(igs(mgs),jy,kgs(mgs),lz(il)) = z
14807 ENDIF
14808 ENDIF
14809 ENDIF
14810
14811
14812 ! set g1x to use as G factor later. If alpha is in the range ( rnumin < alpha < rnumax ), then
14813 ! this will be the same as computing G from alpha. If alpha = rnumax, however, it probably means that
14814 ! the moments are not matched correctly, so we compute G from the moments instead so that the dZ/dt rates
14815 ! stay consistent with dN/dt and dq/dt.
14816! g1x(mgs,il) = zx(mgs,il)*chw*(pi*xdn(mgs,il))**2/(6.*qr*dn(igs(mgs),jy,kgs(mgs)))**2
14817! g1x(mgs,il) = g1 ! zx(mgs,il)*cx(mgs,il)/(qr)**2
14818 IF ( alp >= alphamax - 0.5 ) THEN
14819! g1x(mgs,il) = 6**2*zx(mgs,il)/(cx(mgs,il)*(pi*xv(mgs,lr))**2)
14820! g1x(mgs,il) = (xdn(mgs,il))**2*zx(mgs,il)*cx(mgs,il)/((rho0(mgs)*qx(mgs,il))**2)
14821 g1x(mgs,il) = (pi*xdn(mgs,il))**2*zx(mgs,il)*cx(mgs,il)/((6.*rho0(mgs)*qx(mgs,il))**2)
14822 ELSE
14823 g1x(mgs,il) = g1
14824 ENDIF
14825
14826 ENDIF
14827
14828! IF ( ny .eq. 2 ) THEN
14829! IF ( qr .gt. 1.e-3 ) THEN
14830! write(0,*) 'alphah at nstep,i,k = ',dtp*(nstep-1),igs(mgs),kgs(mgs),alpha(mgs,il),qr*1000.
14831! ENDIF
14832! ENDIF
14833
14834
14835 ENDIF ! .true.
14836
14837 IF ( il == lr ) THEN
14838
14839! tmp = alpha(mgs,lr) + 4./3.
14840! i = Int(dgami*(tmp))
14841! del = tmp - dgam*i
14842! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
14843!
14844! tmp = alpha(mgs,lr) + 1.
14845! i = Int(dgami*(tmp))
14846! del = tmp - dgam*i
14847! y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
14848!
14849!! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 4./3.)/(alpha(mgs,lr) + 1.)**(1./3.)/Gamma_sp(alpha(mgs,lr) + 1.)
14850! ventrx(mgs) = x/(y*(alpha(mgs,lr) + 1.)**(1./3.))
14851
14852
14853 tmp = alpha(mgs,lr) + 1.
14854 i = int(dgami*(tmp))
14855 del = tmp - dgam*i
14856 y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
14857
14858 gf1palp(mgs) = y
14859
14860 IF ( iferwisventr == 2 ) THEN
14861 tmp = alpha(mgs,lr) + 2.5 + br/2.
14862 i = int(dgami*(tmp))
14863 del = tmp - dgam*i
14864 x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
14865
14866! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 1.5 + br/6.)/Gamma_sp(alpha(mgs,lr) + 1.)
14867
14868 ventrxn(mgs) = x/y
14869
14870 ENDIF
14871
14872 ENDIF ! il==lr
14873
14874
14875 ELSE ! below mass threshold
14876! g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/
14877! & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
14878! z1 = g1*rho0(mgs)**2*(qr)*qr/chw
14879! z = 1.e18*z1*(6./(pi*1000.))**2
14880! z = z1*(6./(pi*1000.))**2
14881! zx(mgs,il) = z
14882! an(igs(mgs),jy,kgs(mgs),lz(il)) = z
14883 ENDIF ! ( qx(mgs,il) .gt. qxmin(il) )
14884
14885
14886
14887! ENDIF
14888 ENDDO ! mgs
14889
14890! CALL cld_cpu('Z-DELABK')
14891
14892! IF ( il == lr ) THEN
14893! xnutmp = (alpha(mgs,il) - 2.)/3.
14894! da0lr(mgs) = delbk(bb(il), xnutmp, xmu(il), 0)
14895! ENDIF
14896
14897 IF ( .not. ( il == lr .and. imurain == 3 ) ) THEN
14898! CALL cld_cpu('Z-DELABK')
14899 DO mgs = 1,ngscnt
14900 IF ( qx(mgs,il) > qxmin(il) ) THEN
14901 xnutmp = (alpha(mgs,il) - 2.)/3.
14902
14903! IF ( .true. ) THEN
14904 DO ic = lc,lh-1 ! lhab
14905 IF ( il .ne. ic .and. qx(mgs,ic) .gt. qxmin(ic)) THEN
14906 xnuc = xnu(ic)
14907 IF ( ic == lc .and. idiagnosecnu > 0 ) xnuc = alpha(mgs,lc) ! alpha for droplets is actually nu
14908 IF ( il /= lr .and. ic == lr .and. lzr > 1 ) THEN
14909 IF ( imurain == 3 ) THEN
14910 xnuc = alpha(mgs,lr) ! alpha is nu already
14911 ELSE
14912 xnuc = ( alpha(mgs,lr) - 2. )/3. ! convert alpha to nu
14913 ENDIF
14914 ENDIF
14915 ! delabk(ba,bb,nua,nub,mua,mub,k), where a (il) is collector and b (ic) is collected
14916 IF ( .false. ) THEN
14917 dab0lh(mgs,ic,il) = delabk(bb(ic), bb(il), xnuc, xnutmp, xmu(ic), xmu(il), 0) !dab0(il,ic)
14918 dab1lh(mgs,ic,il) = delabk(bb(ic), bb(il), xnuc, xnutmp, xmu(ic), xmu(il), 1) !dab1(il,ic)
14919 dab0lh(mgs,il,ic) = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic), 0) !dab0(il,ic)
14920 dab1lh(mgs,il,ic) = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic), 1) !dab1(il,ic)
14921 ELSE ! use lookup table -- not interpolating yet because table resolution of 0.05 is good enough
14922 i = nint( alpha(mgs,il)*dqiacralphainv )
14923 IF ( ic == lc .or. ic == li .or. ic == ls .or. (ic == lr .and. imurain == 3) ) THEN
14924 alp = (3.*alpha(mgs,ic) + 2.)
14925 j = nint( (3.*alpha(mgs,ic) + 2.)*dqiacralphainv )
14926 ELSE ! IF ( ic == lr .and. imurain == 1 ) ! rain
14927 alp = alpha(mgs,ic)
14928 j = nint( alpha(mgs,ic)*dqiacralphainv )
14929 ENDIF
14930
14931 dab0lh(mgs,ic,il) = dab0lu(j,i,ic,il)
14932 dab1lh(mgs,ic,il) = dab1lu(j,i,ic,il)
14933 dab0lh(mgs,il,ic) = dab0lu(i,j,il,ic)
14934 dab1lh(mgs,il,ic) = dab1lu(i,j,il,ic)
14935
14936! tmp1 = dab0lu(j,i,ic,il)
14937! tmp2 = dab1lu(j,i,ic,il)
14938! tmp3 = dab0lu(i,j,il,ic)
14939! tmp4 = dab1lu(i,j,il,ic)
14940! tmp5 = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(ic), xmu(il), 0) !dab0(il,ic)
14941! tmp6 = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(ic), xmu(il), 1) !dab1(il,ic)
14942! tmp5 = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic), 0) !dab0(il,ic)
14943! tmp6 = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic), 1) !dab1(il,ic)
14944
14945 IF ( .false. .and. ny <= 2 ) THEN
14946 write(0,*)
14947 write(0,*) 'bb: ', bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic)
14948 write(0,*) 'il,ic = ',il,ic,alpha(mgs,il),i,xnuc,alp,j
14949 write(0,*) 'dab0lh,tmp1 = ',dab0lh(mgs,ic,il),tmp1
14950 write(0,*) 'dab1lh,tmp2 = ',dab1lh(mgs,ic,il),tmp2
14951 write(0,*) 'dab0lh,tmp3 = ',dab0lh(mgs,il,ic),tmp3,tmp5
14952 write(0,*) 'dab1lh,tmp4 = ',dab1lh(mgs,il,ic),tmp4,tmp6
14953
14954 ENDIF
14955
14956 ENDIF
14957
14958 ENDIF
14959 ENDDO
14960
14961! ENDIF
14962
14963 da0lx(mgs,il) = delbk(bb(il), xnutmp, xmu(il), 0)
14964 IF ( il .eq. lh ) THEN
14965 da0lh(mgs) = delbk(bb(il), xnutmp, xmu(il), 0)
14966 IF ( lzr > 1 ) THEN
14967 rzxh(mgs) = 1.
14968 ELSE
14969 rzxh(mgs) = ((4. + alpha(mgs,il))*(5. + alpha(mgs,il))*(6. + alpha(mgs,il))*(1. + xnu(lr)))/ &
14970 & ((1. + alpha(mgs,il))*(2. + alpha(mgs,il))*(3. + alpha(mgs,il))*(2. + xnu(lr)))
14971 ENDIF
14972
14973 IF ( lzhl < 1 ) THEN
14974 rzxhlh(mgs) = rzxhl(mgs)/(((4. + alpha(mgs,il))*(5. + alpha(mgs,il))*(6. + alpha(mgs,il))*(1. + xnu(lr)))/ &
14975 & ((1. + alpha(mgs,il))*(2. + alpha(mgs,il))*(3. + alpha(mgs,il))*(2. + xnu(lr))))
14976 ENDIF
14977 ELSEIF ( il .eq. lhl ) THEN
14978 da0lhl(mgs) = delbk(bb(il), xnutmp, xmu(il), 0)
14979 IF ( lzr > 1 ) THEN
14980 rzxhl(mgs) = 1.
14981 ELSE
14982 rzxhl(mgs) = ((4.0 + alpha(mgs,il))*(5. + alpha(mgs,il))*(6. + alpha(mgs,il))*(1. + xnu(lr)))/ &
14983 & ((1. + alpha(mgs,il))*(2. + alpha(mgs,il))*(3. + alpha(mgs,il))*(2. + xnu(lr)))
14984 ENDIF
14985 ELSEIF ( il == lr ) THEN
14986 xnutmp = (alpha(mgs,il) - 2.)/3.
14987 da0lr(mgs) = delbk(bb(il), xnutmp, xmu(il), 0)
14988 da1lr(mgs) = delbk(bb(il), xnutmp, xmu(il), 1)
14989 ENDIF
14990
14991 ENDIF ! ( qx(mgs,il) > qxmin(il) )
14992 ENDDO ! mgs
14993! CALL cld_cpu('Z-DELABK')
14994 ENDIF ! il /= lr
14995
14996! CALL cld_cpu('Z-DELABK')
14997
14998 ENDIF ! lz(il) .gt. 1
14999
15000 ENDDO ! il
15001
15002 ENDIF ! ipconc .ge. 6
15003
15004! CALL cld_cpu('Z-MOMENT-1')
15005
15006!
15007! set some values for ice nucleation
15008!
15009 do mgs = 1,ngscnt
15010 kp1 = min(nz, kgs(mgs)+1 )
15011! wvel(mgs) = (0.5)*(w(igs(mgs),jgs,kp1) &
15012! & +w(igs(mgs),jgs,kgs(mgs)))
15013
15014
15015 wvelkm1(mgs) = (0.5)*(w(igs(mgs),jgs,kgs(mgs)) &
15016 & +w(igs(mgs),jgs,kgsm(mgs)))
15017 cninm(mgs) = t7(igs(mgs),jgs,kgsm(mgs))
15018 cnina(mgs) = t7(igs(mgs),jgs,kgs(mgs))
15019 cninp(mgs) = t7(igs(mgs),jgs,kgsp(mgs))
15020 end do
15021
15022!
15023! Set a couple of cloud variables...
15024!
15025
15026! SUBROUTINE setvt(ngscnt,qx,qxmin,cx,rho0,rhovt,xdia,cno,
15027! : xmas,xdn,xvmn,xvmx,xv,cdx,
15028! : ipconc,ndebug)
15029! SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno, &
15030! & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx, &
15031! & ipconc1,ndebug1,ngs,nz,kgs,cwnccn,fadvisc, &
15032! & cwmasn,cwmasx,cwradn,cnina,cimna,cimxa, &
15033! & itype1a,itype2a,temcg,infdo,alpha)
15034
15035
15036 infdo = 1
15037 IF ( rimdenvwgt > 0 ) infdo = 1
15038
15039 call setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
15040 & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx,cdxgs, &
15041 & ipconc,ndebug,ngs,nz,kgs,fadvisc, &
15042 & cwmasn,cwmasx,cwradn,cnina,cimn,cimx, &
15043 & itype1,itype2,temcg,infdo,alpha,0,axx,bxx) ! ,cdh,cdhl)
15044! & itype1,itype2,temcg,infdo,alpha,0,axh,bxh,axhl,bxhl) ! ,cdh,cdhl)
15045
15046
15047 IF ( lwsm6 .and. ipconc == 0 ) THEN
15048 tmp = max(qxmin(lh), qxmin(ls))
15049 DO mgs = 1,ngscnt
15050 total = qx(mgs,lh) + qx(mgs,ls)
15051 IF ( total > tmp ) THEN
15052 vt2ave(mgs) = (qx(mgs,lh)*vtxbar(mgs,lh,1) + qx(mgs,ls)*vtxbar(mgs,ls,1))/total
15053 ELSE
15054 vt2ave(mgs) = 0.0
15055 ENDIF
15056 ENDDO
15057 ENDIF
15058
15059
15060!
15061! Set number concentrations (need xdia from setvt)
15062!
15063 if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: Set concentration'
15064 IF ( ipconc .lt. 1 ) THEN
15065 cina(1:ngscnt) = cx(1:ngscnt,li)
15066 ENDIF
15067 if ( ipconc .lt. 5 ) then
15068 do mgs = 1,ngscnt
15069
15070
15071 IF ( ipconc .lt. 3 ) THEN
15072! cx(mgs,lr) = 0.0
15073 if ( qx(mgs,lr) .gt. qxmin(lh) ) then
15074! cx(mgs,lr) = cno(lr)*xdia(mgs,lr,1)
15075! xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr))
15076 end if
15077 ENDIF
15078
15079 IF ( ipconc .lt. 4 ) THEN
15080! tmp = cx(mgs,ls)
15081! cx(mgs,ls) = 0.0
15082 if ( qx(mgs,ls) .gt. qxmin(ls) ) then
15083! cx(mgs,ls) = cno(ls)*xdia(mgs,ls,1)
15084! xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*cx(mgs,ls))
15085 end if
15086 ENDIF ! ( ipconc .lt. 4 )
15087
15088 IF ( ipconc .lt. 5 ) THEN
15089
15090
15091! cx(mgs,lh) = 0.0
15092 if ( qx(mgs,lh) .gt. qxmin(lh) ) then
15093! cx(mgs,lh) = cno(lh)*xdia(mgs,lh,1)
15094! xv(mgs,lh) = Max(xvmn(lh), rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) )
15095! xdia(mgs,lh,3) = (xv(mgs,lh)*6./pi)**(1./3.)
15096 end if
15097
15098 ENDIF ! ( ipconc .lt. 5 )
15099
15100 end do
15101 end if
15102
15103 IF ( ipconc .ge. 2 ) THEN
15104 DO mgs = 1,ngscnt
15105
15106 rb(mgs) = 0.5*xdia(mgs,lc,1)*(1./(1.+alpha(mgs,lc)))**(1./6.)
15107 xl2p(mgs) = max(0.0d0, 2.7e-2*xdn(mgs,lc)*cx(mgs,lc)*xv(mgs,lc)* &
15108 & ((0.5e20*rb(mgs)**3*xdia(mgs,lc,1))-0.4) )
15109 IF ( rb(mgs) .gt. 3.51e-6 ) THEN
15110! rh(mgs) = Max( 0.5d0*xdia(mgs,lc,1), 6.3d-4/(1.d6*(rb(mgs) - 3.5d-6)) )
15111 rh(mgs) = max( 41.d-6, 6.3d-4/(1.d6*(rb(mgs) - 3.5d-6)) )
15112 ELSE
15113 rh(mgs) = 41.d-6
15114 ENDIF
15115 IF ( xl2p(mgs) .gt. 0.0 ) THEN
15116 nh(mgs) = 4.2d9*xl2p(mgs)
15117 ELSE
15118 nh(mgs) = 1.e30
15119 ENDIF
15120 ENDDO
15121 ENDIF
15122
15123!
15124!
15125!
15126!
15127! maximum depletion tendency by any one source
15128!
15129!
15130 if( ndebug .ge. 0 ) THEN
15131!mpi! write(0,*) 'Set depletion max/min1'
15132 endif
15133 do mgs = 1,ngscnt
15134 qvimxd(mgs) = 0.70*(qx(mgs,lv)-qis(mgs))*dtpinv ! depletion by all vap. dep to ice.
15135
15136 IF ( qx(mgs,lc) < qxmin(lc) ) qvimxd(mgs) = 0.99*(qx(mgs,lv)-qis(mgs))*dtpinv ! this makes virtually no difference whatsoever, but what the heck
15137
15138 qvimxd(mgs) = max(qvimxd(mgs), 0.0)
15139
15140 frac = 0.1d0
15141 qimxd(mgs) = frac*qx(mgs,li)*dtpinv
15142 qcmxd(mgs) = frac*qx(mgs,lc)*dtpinv
15143 qrmxd(mgs) = frac*qx(mgs,lr)*dtpinv
15144 qsmxd(mgs) = frac*qx(mgs,ls)*dtpinv
15145 qhmxd(mgs) = frac*qx(mgs,lh)*dtpinv
15146 IF ( lhl > 1 ) qhlmxd(mgs) = frac*qx(mgs,lhl)*dtpinv
15147 end do
15148!
15149 if( ndebug .ge. 0 ) THEN
15150!mpi! write(0,*) 'Set depletion max/min2'
15151 endif
15152
15153 do mgs = 1,ngscnt
15154!
15155 if ( qx(mgs,lc) .le. qxmin(lc) ) then
15156 ccmxd(mgs) = 0.20*cx(mgs,lc)*dtpinv
15157 else
15158 IF ( ipconc .ge. 2 ) THEN
15159 ccmxd(mgs) = frac*cx(mgs,lc)*dtpinv
15160 ELSE
15161 ccmxd(mgs) = frac*qx(mgs,lc)/(xmas(mgs,lc)*rho0(mgs)*dtp)
15162 ENDIF
15163 end if
15164!
15165 if ( qx(mgs,li) .le. qxmin(li) ) then
15166 cimxd(mgs) = frac*cx(mgs,li)*dtpinv
15167 else
15168 IF ( ipconc .ge. 1 ) THEN
15169 cimxd(mgs) = frac*cx(mgs,li)*dtpinv
15170 ELSE
15171 cimxd(mgs) = frac*qx(mgs,li)/(xmas(mgs,li)*rho0(mgs)*dtp)
15172 ENDIF
15173 end if
15174!
15175!
15176 crmxd(mgs) = 0.10*cx(mgs,lr)*dtpinv
15177 csmxd(mgs) = frac*cx(mgs,ls)*dtpinv
15178 chmxd(mgs) = frac*cx(mgs,lh)*dtpinv
15179
15180 ccmxd(mgs) = frac*cx(mgs,lc)*dtpinv
15181 cimxd(mgs) = frac*cx(mgs,li)*dtpinv
15182 crmxd(mgs) = frac*cx(mgs,lr)*dtpinv
15183 csmxd(mgs) = frac*cx(mgs,ls)*dtpinv
15184 chmxd(mgs) = frac*cx(mgs,lh)*dtpinv
15185
15186 qxmxd(mgs,lv) = max(0.0, 0.1*(qx(mgs,lv) - qvs(mgs))*dtpinv)
15187
15188 DO il = lc,lhab
15189 qxmxd(mgs,il) = frac*qx(mgs,il)*dtpinv
15190 cxmxd(mgs,il) = frac*cx(mgs,il)*dtpinv
15191 ENDDO
15192
15193 end do
15194
15195
15196
15197
15198 IF ( ipconc >= 6 ) THEN
15199 frac = 0.4d0
15200 zxmxd(:,:) = 0.0
15201 DO il = lr,lhab
15202 IF ( lz(il) > 0 .or. ( il == lr ) ) THEN
15203 DO mgs = 1,ngscnt
15204 zxmxd(mgs,il) = frac*zx(mgs,il)*dtpinv
15205 ENDDO
15206 ENDIF
15207 ENDDO
15208 ENDIF
15209
15210
15211
15212
15213 ! default factors between mean volume and maximum mass volume
15214 maxmassfac(lc) = ( (2. + 3.*(1. + xnu(lc)) )**3/( 3.*(1. + xnu(lc)) ) )
15215 maxmassfac(li) = ( (2. + 3.*(1. + xnu(li)) )**3/( 3.*(1. + xnu(li)) ) )
15216
15217 IF ( imurain == 3 ) THEN
15218 maxmassfac(lr) = ( (2. + 3.*(1. + xnu(lr)) )**3/( 3.*(1. + xnu(lr)) ) )
15219 ELSE
15220 maxmassfac(lr) = (3.0 + alphar)**3/ &
15221 & ((3.+alphar)*(2.+alphar)*(1. + alphar) )
15222 ENDIF
15223
15224 IF ( imusnow == 3 ) THEN
15225 maxmassfac(ls) = ( (2. + 3.*(1. + alphas) )**3/( 3.*(1. + alphas) ) )
15226 ELSE
15227 maxmassfac(ls) = (3.0 + alphas)**3/ &
15228 & ((3.+alphas)*(2.+alphas)*(1. + alphas) )
15229 ENDIF
15230
15231 maxmassfac(lh) = (3.0 + alphah)**3/ &
15232 & ((3.+alphah)*(2.+alphah)*(1. + alphah) )
15233
15234 IF ( lhl > 1 ) THEN
15235 maxmassfac(lhl) = (3.0 + alphahl)**3/ &
15236 & ((3.+alphahl)*(2.+alphahl)*(1. + alphahl) )
15237 ENDIF
15238
15239
15240
15241 DO mgs = 1,ngscnt
15242 DO il = lh,lhab ! graupel and hail only (and frozen drops)
15243
15244 vshdgs(mgs,il) = vshd ! base value
15245
15246 IF ( qx(mgs,il) > qxmin(il) .and. ivshdgs > 0 ) THEN
15247
15248 ! tmpdiam is weighted diameter of d^(shedalp-1), so for shedalp=3, this is the area-weighted diameter or maximum mass diameter.
15249 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
15250
15251 IF ( tmpdiam > sheddiam0 ) THEN
15252 vshdgs(mgs,il) = 0.523599*(1.5e-3)**3/massfacshr ! 1.5mm drops from very large ice
15253 ELSEIF ( tmpdiam > sheddiam ) THEN ! intermediate size
15254 vshdgs(mgs,il) = 0.523599*(3.0e-3)**3/massfacshr ! 3.0mm drops from medium-large ice
15255 ELSE
15256! vshdgs(mgs,il) = Min( xvmx(lr), xv(mgs,il)*xdn(mgs,il)*0.001 ) ! size of drop from melted mean ice particle
15257 vshdgs(mgs,il) = min( xvmx(lr), 6./pi*xdn(mgs,il)*0.001*tmpdiam**3 )/massfacshr ! size of drop from melted mean ice particle; 0.001 is 1/rhow
15258 ENDIF
15259 ENDIF
15260 ENDDO
15261 ENDDO
15262
15263!
15264!
15265! microphysics source terms (1/s) for mixing ratios
15266!
15267!
15268!
15269! Collection efficiencies:
15270!
15271 if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: Set collection efficiencies'
15272!
15273 do mgs = 1,ngscnt
15274!
15275!
15276!
15277 qcwresv(mgs) = 0.0
15278 ccwresv(mgs) = 0.0
15279
15280 erw(mgs) = 0.0
15281 esw(mgs) = 0.0
15282 ehw(mgs) = 0.0
15283 efw(mgs) = 0.0
15284 ehlw(mgs) = 0.0
15285! ehxw(mgs) = 0.0
15286!
15287 err(mgs) = 0.0
15288 esr(mgs) = 0.0
15289 il2(mgs) = 0
15290 il3(mgs) = 0
15291 ehr(mgs) = 0.0
15292 ehlr(mgs) = 0.0
15293! ehxr(mgs) = 0.0
15294!
15295 eri(mgs) = 0.0
15296 esi(mgs) = 0.0
15297 ehi(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehi*ehiclsn
15298 ehis(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehi*ehiclsn
15299 ehli(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehli*ehliclsn
15300 ehlis(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehli*ehliclsn
15301! ehxi(mgs) = 0.0
15302!
15303 ers(mgs) = 0.0
15304 ess(mgs) = 0.0
15305 ehs(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehs*ehsclsn
15306 ehsfac(mgs) = 1.0 ! factor based on ice saturation
15307 ehls(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehls*ehlsclsn
15308 ehscnv(mgs) = 0.0
15309! ehxs(mgs) = 0.0
15310!
15311 eiw(mgs) = 0.0
15312 eii(mgs) = 0.0
15313 ehsclsn(mgs) = 0.0
15314 ehiclsn(mgs) = 0.0
15315 ehlsclsn(mgs) = 0.0
15316 ehliclsn(mgs) = 0.0
15317 esiclsn(mgs) = 0.0
15318
15319
15320! reserve droplets
15321 IF ( exwmindiam > 0 .and. qx(mgs,lc) > qxmin(lc) ) THEN
15322 tmp = cx(mgs,lc)*exp(- (exwmindiam/xdia(mgs,lc,1))**3 )
15323 ccwresv(mgs) = min( cx(mgs,lc), max( 2.e6, cx(mgs,lc) - tmp ) )
15324
15325 tmp = cx(mgs,lc) - ccwresv(mgs)
15326
15327 volt = pi/6.*(exwmindiam)**3
15328 qcwresv(mgs) = qx(mgs,lc) - tmp*xdn0(lc)*rhoinv(mgs)*(volt + xv(mgs,lc))
15329
15330
15331 IF ( .false. .and. qx(mgs,lc) > 0.1e-3 ) THEN
15332
15333 write(0,*) 'cx,qx,crsv,qrsv = ',cx(mgs,lc),qx(mgs,lc),ccwresv(mgs),qcwresv(mgs)
15334
15335 ENDIF
15336
15337 ENDIF
15338
15339
15340 icwr(mgs) = 1
15341 IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN
15342 cwrad = 0.5*xdia(mgs,lc,1)
15343 DO il = 1,8
15344 IF ( cwrad .ge. 1.e-6*cwr(il,1) ) icwr(mgs) = il
15345 ENDDO
15346 ENDIF
15347
15348
15349 irwr(mgs) = 1
15350 IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN
15351 rwrad = 0.5*xdia(mgs,lr,3) ! changed to mean volume diameter (10/6/06)
15352 DO il = 1,6
15353 IF ( rwrad .ge. 1.e-6*grad(il,1) ) irwr(mgs) = il
15354 ENDDO
15355 ENDIF
15356
15357
15358 igwr(mgs) = 1
15359! IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN
15360! rwrad = 0.5*xdia(mgs,lr,1)
15361! setting erw = 1 always, so now use igwr for graupel
15362 IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN
15363 rwrad = 0.5*xdia(mgs,lh,3) ! changed to mean volume diameter (10/6/06)
15364 DO il = 1,6
15365 IF ( rwrad .ge. 1.e-6*grad(il,1) ) igwr(mgs) = il
15366 ENDDO
15367 ENDIF
15368
15369
15370 IF ( lhl .gt. 1 ) THEN ! hail is turned on
15371 ihlr(mgs) = 1
15372 IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN
15373 rwrad = 0.5*xdia(mgs,lhl,3) ! changed to mean volume diameter (10/6/06)
15374 DO il = 1,6
15375 IF ( rwrad .ge. 1.e-6*grad(il,1) ) ihlr(mgs) = il
15376 ENDDO
15377 ENDIF
15378 ENDIF
15379
15380!
15381!
15382! Ice-Ice: Collection (cxc) efficiencies
15383!
15384!
15385 if ( qx(mgs,li) .gt. qxmin(li) ) then
15386! IF ( ipconc .ge. 14 ) THEN
15387! eii(mgs)=0.1*exp(0.1*temcg(mgs))
15388! if ( temg(mgs) .lt. 243.15 .and. qx(mgs,lc) .gt. 1.e-6 ) then
15389! eii(mgs)=0.1
15390! end if
15391!
15392! ELSE
15393 eii(mgs) = exp(0.025*min(temcg(mgs),0.0)) ! alpha1 from LFO83 (21)
15394! ENDIF
15395 if ( temg(mgs) .gt. 273.15 ) eii(mgs) = 1.0
15396 end if
15397!
15398!
15399!
15400! Ice-cloud water: Collection (cxc) efficiencies
15401!
15402!
15403 eiw(mgs) = 0.0
15404 if ( qx(mgs,li).gt.qxmin(li) .and. qx(mgs,lc).gt.qxmin(lc) ) then
15405
15406
15407 if (xdia(mgs,lc,1).gt.ewi_dcmin .and. xdia(mgs,li,1).gt.ewi_dimin) then
15408! erm 5/10/2007 test following change:
15409! if (xdia(mgs,lc,1).gt.12.0e-06 .and. xdia(mgs,li,1).gt.50.0e-06) then
15410 eiw(mgs) = 0.5
15411 end if
15412 if ( temg(mgs) .ge. 273.15 ) eiw(mgs) = 0.0
15413 end if
15414
15415!
15416!
15417!
15418! Rain: Collection (cxc) efficiencies
15419!
15420!
15421 if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,lc).gt.qxmin(lc) ) then
15422
15423 IF ( lnr .gt. 1 ) THEN
15424 erw(mgs) = 1.0
15425
15426 ELSE
15427
15428! cwrad = 0.5*xdia(mgs,lc,1)
15429! erw(mgs) =
15430! > min((aradcw + cwrad*(bradcw + cwrad*
15431! < (cradcw + cwrad*(dradcw)))), 1.0)
15432! IF ( xdia(mgs,lc,1) .lt. 2.4e-06 .or. xdia(mgs,lr,1) .le. 50.0e-6 ) THEN
15433! erw(mgs)=0.0
15434! ENDIF
15435! erw(mgs) = ew(icwr(mgs),igwr(mgs))
15436! interpolate along droplet radius
15437 ic = icwr(mgs)
15438 icp1 = min( 8, ic+1 )
15439 ir = irwr(mgs)
15440 irp1 = min( 6, ir+1 )
15441 cwrad = 0.5*xdia(mgs,lc,3)
15442 rwrad = 0.5*xdia(mgs,lr,3)
15443
15444 slope1 = (ew(icp1, ir ) - ew(ic,ir ))*cwr(ic,2)
15445 slope2 = (ew(icp1, irp1) - ew(ic,irp1))*cwr(ic,2)
15446
15447! write(iunit,*) 'slop1: ',slope1,slope2,ew(ic,ir),cwr(ic,2)
15448
15449 x1 = ew(ic, ir) + slope1*max(0.0, (cwrad - cwr(ic,1)) )
15450 x2 = ew(icp1,ir) + slope2*max(0.0, (cwrad - cwr(ic,1)) )
15451
15452 slope1 = (x2 - x1)*grad(ir,2)
15453
15454 erw(mgs) = max(0.0, x1 + slope1*max(0.0, (rwrad - grad(ir,1)) ))
15455
15456! write(iunit,*) 'erw: ',erw(mgs),1.e6*cwrad,1.e6*rwrad,ic,ir,x1,x2
15457! write(iunit,*)
15458
15459 erw(mgs) = max(0.0, erw(mgs) )
15460 IF ( rwrad .lt. 50.e-6 ) THEN
15461 erw(mgs) = 0.0
15462 ELSEIF ( rwrad .lt. 100.e-6 ) THEN ! linear change from zero at 50 to erw at 100 microns
15463 erw(mgs) = erw(mgs)*(rwrad - 50.e-6)/50.e-6
15464 ENDIF
15465
15466 ENDIF
15467 end if
15468 IF ( cx(mgs,lc) .le. 0.0 ) erw(mgs) = 0.0
15469!
15470 if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,lr).gt.qxmin(lr) ) then
15471 err(mgs)=1.0
15472 end if
15473!
15474 if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,ls).gt.qxmin(ls) ) then
15475 ers(mgs)=1.0
15476 end if
15477!
15478 if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,li).gt.qxmin(li) ) then
15479! IF ( vtxbar(mgs,lr,1) .gt. vtxbar(mgs,li,1) .and.
15480! : xdia(mgs,lr,3) .gt. 200.e-6 .and. xdia(mgs,li,3) .gt. 100.e-6 ) THEN
15481 eri(mgs) = eri0
15482! cwrad = 0.5*xdia(mgs,li,3)
15483! eri(mgs) =
15484! > 1.0*min((aradcw + cwrad*(bradcw + cwrad*
15485! < (cradcw + cwrad*(dradcw)))), 1.0)
15486! ENDIF
15487! if ( xdia(mgs,li,1) .lt. 10.e-6 ) eri(mgs)=0.0
15488 if ( xdia(mgs,li,3) .lt. eri_cimin ) eri(mgs)=0.0
15489 end if
15490!
15491!
15492! Snow aggregates: Collection (cxc) efficiencies
15493!
15494! Modified by ERM with a linear function for small droplets and large
15495! snow agg. based numerical data from Wang and Ji (1992) in P&K 1997 (Fig. 14-13), which
15496! allows collection of very small droplets, albeit at low efficiency. But slow
15497! fall speeds of snow make up for the efficiency.
15498!
15499 esw(mgs) = 0.0
15500 if ( qx(mgs,ls).gt.qxmin(ls) .and. qx(mgs,lc).gt.qxmin(lc) ) then
15501 esw(mgs) = 0.5
15502 if ( xdia(mgs,lc,1) .gt. 15.e-6 .and. xdia(mgs,ls,1) .gt. 100.e-6) then
15503 esw(mgs) = 0.5
15504 ELSEIF ( xdia(mgs,ls,1) .ge. 500.e-6 ) THEN
15505 esw(mgs) = min(0.5, 0.05 + (0.8-0.05)/(40.e-6)*xdia(mgs,lc,1) )
15506 ENDIF
15507 end if
15508!
15509 if ( qx(mgs,ls).gt.qxmin(ls) .and. qx(mgs,lr).gt.qxmin(lr) &
15510 & .and. temg(mgs) .lt. tfr - 1. &
15511 & ) then
15512 esr(mgs)=exp(-(40.e-6)**3/xv(mgs,lr))*exp(-40.e-6/xdia(mgs,ls,1))
15513 IF ( qx(mgs,ls) < 1.e-4 .and. qx(mgs,lr) < 1.e-4 ) il2(mgs) = 1
15514 end if
15515
15516 IF ( ipconc < 3 .and. temg(mgs) < tfr .and. qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,lr) < 1.e-4 ) THEN
15517 il3(mgs) = 1
15518 ENDIF
15519!
15520! if ( qx(mgs,ls).gt.qxmin(ls) ) then
15521 if ( temcg(mgs) < 0.0 ) then
15522
15523 IF ( ipconc .lt. 4 .or. temcg(mgs) < esstem1 ) THEN
15524 ess(mgs) = 0.0
15525! ess(mgs)=0.1*exp(0.1*min(temcg(mgs),0.0))
15526! ess(mgs)=min(0.1,ess(mgs))
15527
15528 ELSE
15529
15530 fac = abs(ess0)
15531 IF ( iessopt == 2 ) THEN ! experimental code
15532! IF ( wvel(mgs) > 2.0 .or. wvel(mgs) < -0.5 .or. ssi(mgs) < 1.0 ) THEN
15533 IF ( wvel(mgs) > 2.0 ) THEN
15534 ! assume convective cell or downdraft
15535 fac = 0.0
15536 ELSEIF ( wvel(mgs) > 1.0 ) THEN ! transition to stratiform range of values
15537 fac = max(0.0, 2.0 - wvel(mgs))*fac
15538 ENDIF
15539 ELSEIF ( iessopt == 3 ) THEN ! factor based on ice supersat
15540 IF ( ssi(mgs) <= 1.0 ) THEN
15541 fac = 0.0
15542 ehsfac(mgs) = 0.0
15543 ELSEIF ( ssi(mgs) <= 1.02 ) THEN
15544 fac = fac*(ssi(mgs) - 1.0)/0.02
15545 ehsfac(mgs) = (ssi(mgs) - 1.0)/0.02
15546 ENDIF
15547 ELSEIF ( iessopt == 4 ) THEN ! factor based on ice supersat; very roughly based on Hosler et al. 1957 (J. Met.)
15548 IF ( ssi(mgs) <= 1.0 ) THEN
15549 fac = 0.1
15550 ehsfac(mgs) = 0.1
15551 ELSEIF ( ssi(mgs) <= 1.005 ) THEN
15552 fac = max(0.1, fac*(ssi(mgs) - 1.0)/0.005)
15553 ehsfac(mgs) = max(0.1, (ssi(mgs) - 1.0)/0.005)
15554 ENDIF
15555 ENDIF
15556
15557 IF ( temcg(mgs) > esstem1 .and. temcg(mgs) < esstem2 ) THEN ! only nonzero for T > esstem1
15558 ess(mgs) = fac*exp(ess1*(esstem2) )*(temcg(mgs) - esstem1)/(esstem2 - esstem1) ! linear ramp up from zero at esstem1 to value at esstem2
15559 ELSEIF ( temcg(mgs) >= esstem2 ) THEN
15560 ess(mgs) = fac*exp(ess1*min( temcg(mgs), 0.0 ) )
15561 ENDIF
15562
15563 ENDIF
15564 end if
15565!
15566 if ( qx(mgs,ls).gt.qxmin(ls) .and. qx(mgs,li).gt.qxmin(li) ) then
15567 esiclsn(mgs) = esi_collsn
15568! IF ( ipconc .lt. 4 ) THEN
15569 IF ( ipconc < 1 .and. lwsm6 ) THEN
15570 esi(mgs) = exp(0.7*min(temcg(mgs),0.0))
15571 ELSE
15572 esi(mgs) = esi0*exp(0.1*min(temcg(mgs),0.0))
15573 esi(mgs) = min(0.1,esi(mgs))
15574 ENDIF
15575 IF ( ipconc .le. 3 ) THEN
15576 esi(mgs) = exp(0.025*min(temcg(mgs),0.0)) ! LFO
15577! esi(mgs) = Min(0.5, exp(0.025*min(temcg(mgs),0.0)) ) ! LFO
15578! esi(mgs)=0.5*exp(0.1*min(temcg(mgs),0.0)) ! 10ice
15579 ENDIF
15580! ELSE ! zrnic/ziegler 1993
15581! esi(mgs)= 0.1 ! 0.5*exp(0.1*min(temcg(mgs),0.0))
15582! ENDIF
15583 if ( temg(mgs) .gt. 273.15 ) esi(mgs) = 0.0
15584 end if
15585!
15586!
15587!
15588!
15589! Graupel: Collection (cxc) efficiencies
15590!
15591!
15592 xmascw(mgs) = xmas(mgs,lc)
15593 if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lc).gt.qxmin(lc) ) then !{
15594 ehw(mgs) = 1.0
15595 IF ( iehw .eq. 0 ) THEN
15596 ehw(mgs) = ehw0 ! default value is 1.0
15597 ELSEIF ( iehw .eq. 1 .or. iehw .eq. 10 ) THEN
15598 cwrad = 0.5*xdia(mgs,lc,1)
15599 ehw(mgs) = min( ehw0, &
15600 & ewfac*min((aradcw + cwrad*(bradcw + cwrad* &
15601 & (cradcw + cwrad*(dradcw)))), 1.0) )
15602
15603 ELSEIF ( iehw .eq. 2 .or. iehw .eq. 10 ) THEN
15604 ic = icwr(mgs)
15605 icp1 = min( 8, ic+1 )
15606 ir = igwr(mgs)
15607 irp1 = min( 6, ir+1 )
15608 cwrad = 0.5*xdia(mgs,lc,1)
15609 rwrad = 0.5*xdia(mgs,lh,3) ! changed to mean volume diameter
15610
15611 slope1 = (ew(icp1, ir ) - ew(ic,ir ))*cwr(ic,2)
15612 slope2 = (ew(icp1, irp1) - ew(ic,irp1))*cwr(ic,2)
15613
15614! write(iunit,*) 'slop1: ',slope1,slope2,ew(ic,ir),cwr(ic,2)
15615
15616 x1 = ew(ic, ir) + slope1*max(0.0, (cwrad - cwr(ic,1)) )
15617 x2 = ew(icp1,ir) + slope2*max(0.0, (cwrad - cwr(ic,1)) )
15618
15619 slope1 = (x2 - x1)*grad(ir,2)
15620
15621 tmp = max( 0.0, min( 1.0, x1 + slope1*max(0.0, (rwrad - grad(ir,1)) ) ) )
15622 ehw(mgs) = min( ehw(mgs), tmp )
15623
15624! write(iunit,*) 'ehw: ',ehw(mgs),1.e6*cwrad,1.e6*rwrad,ic,ir,x1,x2
15625! write(iunit,*)
15626
15627! ehw(mgs) = Max( 0.2, ehw(mgs) )
15628! assume that ehw = 1 for zero air resistance (rho0 = 0.0) and extrapolate toward that
15629! ehw(mgs) = ehw(mgs) + (ehw(mgs) - 1.0)*(rho0(mgs) - rho00)/rho00
15630! ehw(mgs) = ehw(mgs) + (1.0 - ehw(mgs))*((Max(0.0,rho00 - rho0(mgs)))/rho00)**2
15631
15632 ELSEIF ( iehw .eq. 3 .or. iehw .eq. 10 ) THEN ! use fraction of droplets greater than dmincw diameter
15633 tmp = exp(- (dmincw/xdia(mgs,lc,1))**3)
15634 xmascw(mgs) = xmas(mgs,lc) + xdn0(lc)*(pi*dmincw**3/6.0) ! this is the average mass of the droplets with d > dmincw
15635 ehw(mgs) = min( ehw(mgs), tmp )
15636 ELSEIF ( iehw .eq. 4 .or. iehw .eq. 10 ) THEN ! Cober and List 1993, eq. 19-20
15637 tmp = &
15638 & 2.0*xdn(mgs,lc)*vtxbar(mgs,lh,1)*(0.5*xdia(mgs,lc,1))**2 &
15639 & /(9.0*fadvisc(mgs)*0.5*xdia(mgs,lh,3))
15640 tmp = max( 1.5, min(10.0, tmp) )
15641 ehw(mgs) = min( ehw(mgs), 0.55*log10(2.51*tmp) )
15642 ENDIF
15643 if ( xdia(mgs,lc,1) .lt. 2.4e-06 ) ehw(mgs)=0.0
15644
15645 ehw(mgs) = min( ehw0, ehw(mgs) )
15646
15647 IF ( ibfc == -1 .and. temcg(mgs) < -41.0 ) THEN
15648 ehw(mgs) = 0.0
15649 ENDIF
15650
15651 end if !}
15652!
15653 if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lr).gt.qxmin(lr) &
15654! & .and. temg(mgs) .lt. tfr &
15655 & ) then
15656! ehr(mgs) = Exp(-(40.e-6)**3/xv(mgs,lr))*Exp(-40.e-6/xdia(mgs,lh,1))
15657! ehr(mgs) = 1.0
15658 ehr(mgs) = exp(-(40.e-6)/xdia(mgs,lr,3))*exp(-40.e-6/xdia(mgs,lh,3))
15659 ehr(mgs) = min( ehr0, ehr(mgs) )
15660 end if
15661!
15662 IF ( qx(mgs,ls).gt.qxmin(ls) ) THEN
15663 IF ( ipconc .ge. 4 ) THEN
15664 ehscnv(mgs) = ehs0*exp(ehs1*min(temcg(mgs),0.0)) ! for 2-moment, used as default for ehs and ehls. Otherwise not used for snow->graupel conversion
15665 ELSE
15666 ehscnv(mgs) = exp(0.09*min(temcg(mgs),0.0))
15667 ENDIF
15668
15669 IF ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lc) >= qxmin(lc) ) THEN
15670! ehsclsn(mgs) = ehs_collsn
15671! ehs(mgs) = ehscnv(mgs)*ehsfac(mgs)*Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. )
15672! ELSEIF ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lc) >= qxmin(lc) ) then
15673 ehsclsn(mgs) = ehs_collsn
15674 IF ( xdia(mgs,ls,3) < 40.e-6 ) THEN
15675 ehsclsn(mgs) = 0.0
15676 ELSEIF ( xdia(mgs,ls,3) < 150.e-6 ) THEN
15677 ehsclsn(mgs) = ehs_collsn*(xdia(mgs,ls,3) - 40.e-6)/(150.e-6 - 40.e-6)
15678 ELSE
15679 ehsclsn(mgs) = ehs_collsn
15680 ENDIF
15681! 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
15682 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
15683! ehs(mgs) = ehscnv(mgs) ! *Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) ! shut off qhacs as graupel goes to low density
15684 ehs(mgs) = min(ehs(mgs),ehsmax)
15685 end if
15686 ENDIF
15687!
15688 if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,li).gt.qxmin(li) ) then
15689 ehiclsn(mgs) = ehi_collsn
15690 ehi(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0))
15691 ehi(mgs) = min( ehimax, max( ehi(mgs), ehimin ) )
15692! if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehi(mgs) = 0.0
15693 end if
15694
15695 IF ( lis > 1 ) THEN
15696 if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lis).gt.qxmin(lis) ) then
15697 ehisclsn(mgs) = ehi_collsn
15698 ehis(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0))
15699 ehis(mgs) = min( ehimax, max( ehis(mgs), ehimin ) )
15700! if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehis(mgs) = 0.0
15701 end if
15702 ENDIF
15703
15704
15705!
15706!
15707! Hail: Collection (cxc) efficiencies
15708!
15709!
15710 IF ( lhl .gt. 1 ) THEN
15711
15712 if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,lc).gt.qxmin(lc) ) then
15713 IF ( iehw == 3 ) iehlw = 3
15714 IF ( iehw == 4 ) iehlw = 4
15715 ehlw(mgs) = ehlw0
15716 IF ( iehlw .eq. 0 ) THEN
15717 ehlw(mgs) = ehlw0 ! default value is 1.0
15718 ELSEIF ( iehlw .eq. 1 .or. iehlw .eq. 10 ) THEN
15719 cwrad = 0.5*xdia(mgs,lc,1)
15720 ehlw(mgs) = min( ehlw0, &
15721 & ewfac*min((aradcw + cwrad*(bradcw + cwrad* &
15722 & (cradcw + cwrad*(dradcw)))), 1.0) )
15723
15724 ELSEIF ( iehlw .eq. 2 .or. iehlw .eq. 10 ) THEN
15725 ic = icwr(mgs)
15726 icp1 = min( 8, ic+1 )
15727 ir = ihlr(mgs)
15728 irp1 = min( 6, ir+1 )
15729 cwrad = 0.5*xdia(mgs,lc,1)
15730 rwrad = 0.5*xdia(mgs,lhl,3) ! changed to mean volume diameter
15731
15732 slope1 = (ew(icp1, ir ) - ew(ic,ir ))*cwr(ic,2)
15733 slope2 = (ew(icp1, irp1) - ew(ic,irp1))*cwr(ic,2)
15734
15735 x1 = ew(ic, ir) + slope1*(cwrad - cwr(ic,1))
15736 x2 = ew(icp1,ir) + slope2*(cwrad - cwr(ic,1))
15737
15738 slope1 = (x2 - x1)*grad(ir,2)
15739
15740 tmp = max( 0.0, min( 1.0, x1 + slope1*(rwrad - grad(ir,1)) ) )
15741 ehlw(mgs) = min( ehlw(mgs), tmp )
15742 ehlw(mgs) = min( ehlw0, ehlw(mgs) )
15743! ehw(mgs) = Max( 0.2, ehw(mgs) )
15744! assume that ehw = 1 for zero air resistance (rho0 = 0.0) and extrapolate toward that
15745! ehw(mgs) = ehw(mgs) + (ehw(mgs) - 1.0)*(rho0(mgs) - rho00)/rho00
15746! ehlw(mgs) = ehlw(mgs) + (1.0 - ehlw(mgs))*((Max(0.0,rho00 - rho0(mgs)))/rho00)**2
15747
15748 ELSEIF ( iehlw .eq. 3 .or. iehlw .eq. 10 ) THEN ! use fraction of droplets greater than 15 micron diameter
15749 tmp = exp(- (dmincw/xdia(mgs,lc,1))**3)
15750 ehlw(mgs) = min( ehlw(mgs), tmp )
15751 ELSEIF ( iehlw .eq. 4 .or. iehlw .eq. 10 ) THEN ! Cober and List 1993
15752 tmp = &
15753 & 2.0*xdn(mgs,lc)*vtxbar(mgs,lhl,1)*(0.5*xdia(mgs,lc,1))**2 &
15754 & /(9.0*fadvisc(mgs)*0.5*xdia(mgs,lhl,3))
15755 tmp = max( 1.5, min(10.0, tmp) )
15756 ehlw(mgs) = min( ehlw(mgs), 0.55*log10(2.51*tmp) )
15757 ENDIF
15758 if ( xdia(mgs,lc,1) .lt. 2.4e-06 ) ehlw(mgs)=0.0
15759 ehlw(mgs) = min( ehlw0, ehlw(mgs) )
15760
15761 IF ( ibfc == -1 .and. temcg(mgs) < -41.0 ) THEN
15762 ehlw(mgs) = 0.0
15763 ENDIF
15764
15765 end if
15766!
15767 if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,lr).gt.qxmin(lr) &
15768! & .and. temg(mgs) .lt. tfr &
15769 & ) then
15770 ehlr(mgs) = 1.0
15771 ehlr(mgs) = min( ehlr0, ehlr(mgs) )
15772 end if
15773!
15774 IF ( qx(mgs,ls).gt.qxmin(ls) ) THEN
15775 if ( qx(mgs,lhl).gt.qxmin(lhl) ) then
15776 ehlsclsn(mgs) = ehls_collsn
15777 ehls(mgs) = ehscnv(mgs)
15778 ehls(mgs) = min(ehls(mgs),ehsmax)
15779 end if
15780 ENDIF
15781!
15782 if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,li).gt.qxmin(li) ) then
15783 ehliclsn(mgs) = ehli_collsn
15784 ehli(mgs)=eii0hl*exp(eii1hl*min(temcg(mgs),0.0))
15785 ehli(mgs) = min( ehimax, max( ehli(mgs), ehimin ) )
15786 if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehli(mgs) = 0.0
15787 end if
15788
15789 IF ( lis > 1 ) THEN
15790 if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,lis).gt.qxmin(lis) ) then
15791 ehlisclsn(mgs) = ehli_collsn
15792 ehlis(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0))
15793 ehlis(mgs) = min( ehimax, max( ehlis(mgs), ehimin ) )
15794 if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehlis(mgs) = 0.0
15795 end if
15796 ENDIF
15797
15798
15799 ENDIF ! lhl .gt. 1
15800
15801 ENDDO ! mgs loop for collection efficiencies
15802
15803!
15804!
15805!
15806! Set flags for plates vs. columns
15807!
15808!
15809 do mgs = 1,ngscnt
15810!
15811 xplate(mgs) = 0.0
15812 xcolmn(mgs) = 1.0
15813!
15814! if ( temcg(mgs) .lt. 0. .and. temcg(mgs) .ge. -4. ) then
15815! xplate(mgs) = 1.0
15816! xcolmn(mgs) = 0.0
15817! end if
15818!c
15819! if ( temcg(mgs) .lt. -4. .and. temcg(mgs) .ge. -9. ) then
15820! xplate(mgs) = 0.0
15821! xcolmn(mgs) = 1.0
15822! end if
15823!c
15824! if ( temcg(mgs) .lt. -9. .and. temcg(mgs) .ge. -22.5 ) then
15825! xplate(mgs) = 1.0
15826! xcolmn(mgs) = 0.0
15827! end if
15828!c
15829! if ( temcg(mgs) .lt. -22.5 .and. temcg(mgs) .ge. -90. ) then
15830! xplate(mgs) = 0.0
15831! xcolmn(mgs) = 1.0
15832! end if
15833!
15834 end do
15835
15836
15837
15838!
15839!
15840!
15841! Collection growth equations....
15842!
15843!
15844 if (ndebug .gt. 0 ) write(0,*) 'Collection: rain collects xxxxx'
15845!
15846 do mgs = 1,ngscnt
15847 qracw(mgs) = 0.0
15848 IF ( qx(mgs,lr) .gt. qxmin(lr) .and. erw(mgs) .gt. 0.0 ) THEN
15849 IF ( ipconc .lt. 3 ) THEN
15850 IF ( erw(mgs) .gt. 0.0 .and. qx(mgs,lr) .gt. 1.e-7 ) THEN
15851 vt = (ar*(xdia(mgs,lc,1)**br))*rhovt(mgs)
15852 qracw(mgs) = &
15853 & (0.25)*pi*erw(mgs)*(qx(mgs,lc)-qcwresv(mgs))*cx(mgs,lr) &
15854! > *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,lc,1)) &
15855 & *max(0.0, vtxbar(mgs,lr,1)-vt) &
15856 & *( gf3*xdia(mgs,lr,2) &
15857 & + 2.0*gf2*xdia(mgs,lr,1)*xdia(mgs,lc,1) &
15858 & + gf1*xdia(mgs,lc,2) )
15859! qracw(mgs) = 0.0
15860! write(iunit,*) 'qracw,cx =',qracw(mgs),1.e6*xdia(mgs,lr,1),erw(mgs)
15861! write(iunit,*) 'qracw,cx =',qracw(mgs),cx(mgs,lc),kgs(mgs),cx(mgs,lr),1.e6*xdia(mgs,lr,1),vtxbar(mgs,lr,1),vt
15862! write(iunit,*) 'vtr: ',vtxbar(mgs,lr,1), ar*gf4br/6.0*xdia(mgs,lr,1)**br, rhovt(mgs),
15863! : ar*gf4br/6.0*xdia(mgs,lr,1)**br * rhovt(mgs)
15864 ENDIF
15865 ELSE
15866
15867 IF ( dmrauto <= 0 .or. rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN
15868 rwrad = 0.5*xdia(mgs,lr,3)
15869 IF ( rwrad .gt. rh(mgs) ) THEN ! .or. cx(mgs,lr) .gt. nh(mgs) ) THEN
15870 IF ( rwrad .gt. rwradmn ) THEN
15871! DM1CCC=A2*XNC*XNR*XVC*(((CNU+2.)/(CNU+1.))*XVC+XVR) ! (A12)
15872! NOTE: Result is independent of imurain, assumes mucloud = 3
15873 qracw(mgs) = erw(mgs)*aa2*cx(mgs,lr)*cx(mgs,lc)*xmas(mgs,lc)* &
15874 & ((alpha(mgs,lc) + 2.)*xv(mgs,lc)/(alpha(mgs,lc) + 1.) + xv(mgs,lr))/rho0(mgs) !*rhoinv(mgs)
15875 ELSE
15876
15877 IF ( imurain == 3 ) THEN
15878
15879! DM1CCC=A1*XNC*XNR*(((CNU+3.)*(CNU+2.)/(CNU+1.)**2)*XVC**3+ ! (A14)
15880! 1 ((RNU+2.)/(RNU+1.))*XVC*XVR**2)
15881
15882! qracw(mgs) = aa1*cx(mgs,lr)*cx(mgs,lc)*xdn(mgs,lc)* &
15883! & ((cnu + 3.)*(cnu + 2.)*xv(mgs,lc)**3/(cnu + 1.)**2 + &
15884! & (alpha(mgs,lr) + 2.)*xv(mgs,lc)*xv(mgs,lr)**2/(alpha(mgs,lr) + 1.))/rho0(mgs) !*rhoinv(mgs)
15885! save multiplies by converting cx*xdn*xv/rho0 to qx
15886 qracw(mgs) = aa1*cx(mgs,lr)*(qx(mgs,lc)-qcwresv(mgs))* &
15887 & ((alpha(mgs,lc) + 3.)*(alpha(mgs,lc) + 2.)*xv(mgs,lc)**2/(alpha(mgs,lc) + 1.)**2 + &
15888 & (alpha(mgs,lr) + 2.)*xv(mgs,lr)**2/(alpha(mgs,lr) + 1.))
15889
15890 ELSE ! imurain == 1
15891
15892 qracw(mgs) = aa1*cx(mgs,lr)*(qx(mgs,lc)-qcwresv(mgs))* &
15893 & ((alpha(mgs,lc) + 3.)*(alpha(mgs,lc) + 2.)*xv(mgs,lc)**2/(alpha(mgs,lc) + 1.)**2 + &
15894 & (alpha(mgs,lr) + 6.)*(alpha(mgs,lr) + 5.)*(alpha(mgs,lr) + 4.)*xv(mgs,lr)**2/ &
15895 & ((alpha(mgs,lr) + 3.)*(alpha(mgs,lr) + 2.)*(alpha(mgs,lr) + 1.)))
15896
15897 ENDIF
15898
15899 ENDIF
15900 ENDIF
15901 ENDIF
15902 ENDIF
15903! qracw(mgs) = Min(qracw(mgs), qx(mgs,lc))
15904 qracw(mgs) = min(qracw(mgs), qcmxd(mgs))
15905 ENDIF
15906 end do
15907!
15908 do mgs = 1,ngscnt
15909 qraci(mgs) = 0.0
15910 craci(mgs) = 0.0
15911 qracs(mgs) = 0.0
15912 IF ( eri(mgs) .gt. 0.0 .and. iacr .ge. 1 .and. xdia(mgs,lr,3) .gt. 2.*rwradmn ) THEN
15913 IF ( ipconc .ge. 3 ) THEN
15914
15915 tmp = eri(mgs)*aa2*cx(mgs,lr)*cx(mgs,li)* &
15916 & ((cinu + 2.)*xv(mgs,li)/(cinu + 1.) + xv(mgs,lr))
15917
15918 qraci(mgs) = min( qxmxd(mgs,li), tmp*xmas(mgs,li)*rhoinv(mgs) )
15919 craci(mgs) = min( cxmxd(mgs,li), tmp )
15920
15921! vt = Sqrt((vtxbar(mgs,lr,1)-vtxbar(mgs,li,1))**2 +
15922! : 0.04*vtxbar(mgs,lr,1)*vtxbar(mgs,li,1) )
15923!
15924! qraci(mgs) = 0.25*pi*eri(mgs)*cx(mgs,lr)*qx(mgs,li)*vt*
15925! : ( da0(lr)*xdia(mgs,lr,3)**2 +
15926! : dab1(lr,li)*xdia(mgs,lr,3)*xdia(mgs,li,3) +
15927! : da1(li)*xdia(mgs,li,3)**2 )
15928!
15929!
15930! vt = Sqrt((vtxbar(mgs,lr,1)-vtxbar(mgs,li,1))**2 +
15931! : 0.04*vtxbar(mgs,lr,1)*vtxbar(mgs,li,1) )
15932!
15933! craci(mgs) = 0.25*pi*eri(mgs)*cx(mgs,lr)*cx(mgs,li)*vt*
15934! : ( da0(lr)*xdia(mgs,lr,3)**2 +
15935! : dab0(lr,li)*xdia(mgs,lr,3)*xdia(mgs,li,3) +
15936! : da0(li)*xdia(mgs,li,3)**2 )
15937!
15938! qraci(mgs) = Min( qraci(mgs), qxmxd(mgs,li) )
15939! craci(mgs) = Min( craci(mgs), cxmxd(mgs,li) )
15940
15941 ELSE
15942 qraci(mgs) = &
15943 & min( &
15944 & (0.25)*pi*eri(mgs)*qx(mgs,li)*cx(mgs,lr) &
15945 & *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,li,1)) &
15946 & *( gf3*xdia(mgs,lr,2) &
15947 & + 2.0*gf2*xdia(mgs,lr,1)*xdia(mgs,li,1) &
15948 & + gf1*xdia(mgs,li,2) ) &
15949 & , qimxd(mgs))
15950 ENDIF
15951 if ( temg(mgs) .gt. 268.15 ) then
15952 qraci(mgs) = 0.0
15953 end if
15954 ENDIF
15955 end do
15956!
15957 IF ( ipconc < 3 ) THEN
15958 do mgs = 1,ngscnt
15959 qracs(mgs) = 0.0
15960 IF ( ers(mgs) .gt. 0.0 .and. ipconc < 3 ) THEN
15961 IF ( lwsm6 .and. ipconc == 0 ) THEN
15962 vt = vt2ave(mgs)
15963 ELSE
15964 vt = vtxbar(mgs,ls,1)
15965 ENDIF
15966 qracs(mgs) = &
15967 & min( &
15968 & ((0.25)*pi/gf4)*ers(mgs)*qx(mgs,ls)*cx(mgs,lr) &
15969 & *abs(vtxbar(mgs,lr,1)-vt) &
15970 & *( gf6*gf1*xdia(mgs,ls,2) &
15971 & + 2.0*gf5*gf2*xdia(mgs,ls,1)*xdia(mgs,lr,1) &
15972 & + gf4*gf3*xdia(mgs,lr,2) ) &
15973 & , qsmxd(mgs))
15974 ENDIF
15975 end do
15976 ENDIF
15977
15978!
15979!
15980 if (ndebug .gt. 0 ) write(0,*) 'Collection: snow collects xxxxx'
15981!
15982 do mgs = 1,ngscnt
15983 qsacw(mgs) = 0.0
15984 csacw(mgs) = 0.0
15985 vsacw(mgs) = 0.0
15986 IF ( esw(mgs) .gt. 0.0 ) THEN
15987
15988 IF ( ipconc .ge. 4 ) THEN
15989! QSACC=CECS*RVT*A2*XNC*XNS*XVC*ROS*
15990! * (((CNU+2.)/(CNU+1.))*XVC+XVS)/RO
15991
15992! tmp = esw(mgs)*rvt*aa2*cx(mgs,ls)*cx(mgs,lc)*
15993! : ((cnu + 2.)*xv(mgs,lc)/(cnu + 1.) + xv(mgs,ls))
15994 tmp = 1.0*rvt*aa2*cx(mgs,ls)*cx(mgs,lc)* &
15995 & ((alpha(mgs,lc) + 2.)*xv(mgs,lc)/(alpha(mgs,lc) + 1.) + xv(mgs,ls))
15996
15997 qsacw(mgs) = min( qxmxd(mgs,lc), tmp*xmas(mgs,lc)*rhoinv(mgs) )
15998 csacw(mgs) = min( cxmxd(mgs,lc), tmp )
15999
16000 IF ( lvol(ls) .gt. 1 ) THEN
16001 IF ( temg(mgs) .lt. 273.15) THEN
16002 rimdn(mgs,ls) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) &
16003 & *((0.60)*vtxbar(mgs,ls,1)) &
16004 & /(temg(mgs)-273.15))**(rimc2)
16005 rimdn(mgs,ls) = min( max( rimc3, rimdn(mgs,ls) ), rimc4 )
16006 ELSE
16007 rimdn(mgs,ls) = 1000.
16008 ENDIF
16009
16010 vsacw(mgs) = rho0(mgs)*qsacw(mgs)/rimdn(mgs,ls)
16011
16012 ENDIF
16013
16014
16015! qsacw(mgs) = cecs*aa2*cx(mgs,ls)*cx(mgs,lc)*xmas(mgs,lc)*
16016! : ((alpha(mgs,lc) + 2.)*xv(mgs,lc)/(alpha(mgs,lc) + 1.) + xv(mgs,ls))*rhoinv(mgs)
16017 ELSE
16018! qsacw(mgs) =
16019! > min(
16020! > ((0.25)*pi)*esw(mgs)*qx(mgs,lc)*cx(mgs,ls)
16021! > *abs(vtxbar(mgs,ls,1)-vtxbar(mgs,lc,1))
16022! > *( gf3*xdia(mgs,ls,2)
16023! > + 2.0*gf2*xdia(mgs,ls,1)*xdia(mgs,lc,1)
16024! > + gf1*xdia(mgs,lc,2) )
16025! < , qcmxd(mgs))
16026
16027 vt = abs(vtxbar(mgs,ls,1)-vtxbar(mgs,lc,1))
16028
16029 qsacw(mgs) = 0.25*pi*esw(mgs)*cx(mgs,ls)*qx(mgs,lc)*vt* &
16030 & ( da0(ls)*xdia(mgs,ls,3)**2 + &
16031 & dab1(ls,lc)*xdia(mgs,ls,3)*xdia(mgs,lc,3) + &
16032 & da1lc(mgs)*xdia(mgs,lc,3)**2 )
16033 qsacw(mgs) = min( qsacw(mgs), qxmxd(mgs,ls) )
16034 csacw(mgs) = rho0(mgs)*qsacw(mgs)/xmas(mgs,lc)
16035 ENDIF
16036 ENDIF
16037 end do
16038!
16039!
16040 do mgs = 1,ngscnt
16041 qsaci(mgs) = 0.0
16042 csaci(mgs) = 0.0
16043 csaci0(mgs) = 0.0
16044 IF ( ipconc .ge. 4 ) THEN
16045 IF ( esi(mgs) .gt. 0.0 .or. ( ipelec > 0 .and. esiclsn(mgs) > 0.0 )) THEN
16046! QSCOI=CEXS*RVT*A2*XNCI*XNS*XVCI*ROS*
16047! * (((CINU+2.)/(CINU+1.))*VCIP+XVS)/RO
16048
16049 tmp = esiclsn(mgs)*rvt*aa2*cx(mgs,ls)*cx(mgs,li)* &
16050 & ((cinu + 2.)*xv(mgs,li)/(cinu + 1.) + xv(mgs,ls))
16051
16052 qsaci(mgs) = min( qxmxd(mgs,li), esi(mgs)*tmp*xmas(mgs,li)*rhoinv(mgs) )
16053 csaci0(mgs) = tmp
16054 csaci(mgs) = min(cxmxd(mgs,li), esi(mgs)*tmp )
16055
16056! qsaci(mgs) =
16057! > min(
16058! > ((0.25)*pi)*esi(mgs)*qx(mgs,li)*cx(mgs,ls)
16059! > *abs(vtxbar(mgs,ls,1)-vtxbar(mgs,li,1))
16060! > *( gf3*xdia(mgs,ls,2)
16061! > + 2.0*gf2*xdia(mgs,ls,1)*xdia(mgs,li,1)
16062! > + gf1*xdia(mgs,li,2) )
16063! < , qimxd(mgs))
16064 ENDIF
16065 ELSE !
16066 IF ( esi(mgs) .gt. 0.0 ) THEN
16067 qsaci(mgs) = &
16068 & min( &
16069 & ((0.25)*pi)*esi(mgs)*qx(mgs,li)*cx(mgs,ls) &
16070 & *abs(vtxbar(mgs,ls,1)-vtxbar(mgs,li,1)) &
16071 & *( gf3*xdia(mgs,ls,2) &
16072 & + 2.0*gf2*xdia(mgs,ls,1)*xdia(mgs,li,1) &
16073 & + gf1*xdia(mgs,li,2) ) &
16074 & , qimxd(mgs))
16075 ENDIF
16076 ENDIF
16077 end do
16078!
16079!
16080!
16081 do mgs = 1,ngscnt
16082 qsacr(mgs) = 0.0
16083 qsacrs(mgs) = 0.0
16084 csacr(mgs) = 0.0
16085 IF ( esr(mgs) .gt. 0.0 ) THEN
16086 IF ( ipconc .ge. 3 ) THEN
16087! vt = Sqrt((vtxbar(mgs,ls,1)-vtxbar(mgs,lr,1))**2 +
16088! : 0.04*vtxbar(mgs,ls,1)*vtxbar(mgs,lr,1) )
16089! qsacr(mgs) = esr(mgs)*cx(mgs,ls)*vt*
16090! : qx(mgs,lr)*0.25*pi*
16091! : (3.02787*xdia(mgs,lr,2) +
16092! : 3.30669*xdia(mgs,ls,1)*xdia(mgs,lr,1) +
16093! : 2.*xdia(mgs,ls,2))
16094! qsacr(mgs) = Min( qsacr(mgs), qrmxd(mgs) )
16095! csacr(mgs) = qsacr(mgs)*cx(mgs,lr)/qx(mgs,lr)
16096! csacr(mgs) = min(csacr(mgs),crmxd(mgs))
16097 ELSE
16098 IF ( lwsm6 .and. ipconc == 0 ) THEN
16099 vt = vt2ave(mgs)
16100 ELSE
16101 vt = vtxbar(mgs,ls,1)
16102 ENDIF
16103
16104 qsacr(mgs) = &
16105 & min( &
16106 & ((0.25)*pi/gf4)*esr(mgs)*qx(mgs,lr)*cx(mgs,ls) &
16107 & *abs(vtxbar(mgs,lr,1)-vt) &
16108 & *( gf6*gf1*xdia(mgs,lr,2) &
16109 & + 2.0*gf5*gf2*xdia(mgs,lr,1)*xdia(mgs,ls,1) &
16110 & + gf4*gf3*xdia(mgs,ls,2) ) &
16111 & , qrmxd(mgs))
16112 ENDIF
16113 ENDIF
16114 end do
16115!
16116!
16117!
16118
16119 if (ndebug .gt. 0 ) write(0,*) 'Collection: graupel collects xxxxx'
16120!
16121 do mgs = 1,ngscnt
16122 qhacw(mgs) = 0.0
16123 qhacwmlr(mgs) = 0.0
16124 rarx(mgs,lh) = 0.0
16125 vhacw(mgs) = 0.0
16126 vhsoak(mgs) = 0.0
16127 zhacw(mgs) = 0.0
16128
16129 IF ( .false. ) THEN
16130 vtmax = (gz(igs(mgs),jgs,kgs(mgs))*dtpinv)
16131 vtxbar(mgs,lh,1) = min( vtmax, vtxbar(mgs,lh,1))
16132 vtxbar(mgs,lh,2) = min( vtmax, vtxbar(mgs,lh,2))
16133 vtxbar(mgs,lh,3) = min( vtmax, vtxbar(mgs,lh,3))
16134 ENDIF
16135 IF ( ehw(mgs) .gt. 0.0 ) THEN
16136
16137 IF ( ipconc .ge. 2 ) THEN
16138
16139 IF ( .false. ) THEN
16140 qhacw(mgs) = (ehw(mgs)*(qx(mgs,lc)-qcwresv(mgs))*cx(mgs,lh)*pi* &
16141 & abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1))* &
16142 & (2.0*xdia(mgs,lh,1)*(xdia(mgs,lh,1) + &
16143 & xdia(mgs,lc,1)*gf73rds) + &
16144 & xdia(mgs,lc,2)*gf83rds))/4.
16145
16146 ELSE ! using Seifert coefficients
16147 vt = abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1))
16148
16149 qhacw(mgs) = 0.25*pi*ehw(mgs)*cx(mgs,lh)*(qx(mgs,lc)-qcwresv(mgs))*vt* &
16150 & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + &
16151 & dab1lh(mgs,lh,lc)*xdia(mgs,lh,3)*xdia(mgs,lc,3) + &
16152 & da1lc(mgs)*xdia(mgs,lc,3)**2 )
16153
16154 ENDIF
16155 qhacw(mgs) = min( qhacw(mgs), 0.5*qx(mgs,lc)*dtpinv )
16156
16157 IF ( lzh .gt. 1 ) THEN
16158 tmp = qx(mgs,lh)/cx(mgs,lh)
16159
16160!! g1 = (6.0 + alpha(mgs,lh))*(5.0 + alpha(mgs,lh))*(4.0 + alpha(mgs,lh))/
16161!! : ((3.0 + alpha(mgs,lh))*(2.0 + alpha(mgs,lh))*(1.0 + alpha(mgs,lh)))
16162! alp = Max( 1.0, alpha(mgs,lh)+1. )
16163! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/
16164! : ((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
16165! zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) )
16166 ENDIF
16167
16168 ELSE
16169 qhacw(mgs) = &
16170 & min( &
16171 & ((0.25)*pi)*ehw(mgs)*(qx(mgs,lc)-qcwresv(mgs))*cx(mgs,lh) &
16172 & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1)) &
16173 & *( gf3*xdia(mgs,lh,2) &
16174 & + 2.0*gf2*xdia(mgs,lh,1)*xdia(mgs,lc,1) &
16175 & + gf1*xdia(mgs,lc,2) ) &
16176 & , 0.5*(qx(mgs,lc)-qcwresv(mgs))*dtpinv)
16177! < , qxmxd(mgs,lc))
16178! < , qcmxd(mgs))
16179
16180
16181 IF ( lwsm6 .and. qsacw(mgs) > 0.0 .and. qhacw(mgs) > 0.0) THEN
16182 qaacw = ( qx(mgs,ls)*qsacw(mgs) + qx(mgs,lh)*qhacw(mgs) )/(qx(mgs,ls) + qx(mgs,lh))
16183! qaacw = Min( qaacw, 0.5*(qsacw(mgs) + qhacw(mgs) ) )
16184 qsacw(mgs) = qaacw
16185 qhacw(mgs) = qaacw
16186 ENDIF
16187
16188 ENDIF
16189
16190 qhacwmlr(mgs) = qhacw(mgs)
16191 IF ( temg(mgs) > tfr .and. iqhacwshr == 0 ) THEN
16192 qhacw(mgs) = 0.0
16193 ENDIF
16194
16195 IF ( lvol(lh) .gt. 1 .or. lhl .gt. 1 ) THEN ! calculate rime density for graupel volume and/or for graupel conversion to hail
16196
16197 IF ( temg(mgs) .lt. 273.15) THEN
16198 IF ( irimdenopt == 1 ) THEN ! Heymsfield and Pflaum (1985)
16199 vt = ( (1.0-rimdenvwgt)*vtxbar(mgs,lh,1) + rimdenvwgt*vtxbar(mgs,lh,2) )
16200
16201 rimdn(mgs,lh) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) &
16202 & *((0.60)*vt ) &
16203 & /(temg(mgs)-273.15))**(rimc2)
16204! rimdn(mgs,lh) = Min( Max( hdnmn, rimc3, rimdn(mgs,lh) ), rimc4 )
16205 rimdn(mgs,lh) = min( max( rimc3, rimdn(mgs,lh) ), rimc4 )
16206
16207! IF ( igs(mgs) == 30 ) THEN
16208! write(0,*) 'k,vt: ',kgs(mgs),vt, vtxbar(mgs,lh,1),vtxbar(mgs,lh,2), rhovt(mgs)*axx(mgs,lh)*( (alpha(mgs,lh)+3.)*xdia(mgs,lh,1) )**bxx(mgs,lh)
16209! write(0,*) 'diam: char, mean, maxmass = ',xdia(mgs,lh,1),xdia(mgs,lh,3),(alpha(mgs,lh)+3.)*xdia(mgs,lh,1)
16210! write(0,*) 'ax,bx,cd,xdn = ',axx(mgs,lh),bxx(mgs,lh),cdxgs(mgs,lh),xdn(mgs,lh)
16211! write(0,*) 'vt_char,vt_mean = ',rhovt(mgs)*axx(mgs,lh)*( xdia(mgs,lh,1) )**bxx(mgs,lh),rhovt(mgs)*axx(mgs,lh)*( xdia(mgs,lh,3) )**bxx(mgs,lh)
16212! write(0,*) 'rimdn,alpha = ',rimdn(mgs,lh),alpha(mgs,lh)
16213! ENDIF
16214
16215 ELSEIF ( irimdenopt == 2 ) THEN ! Cober and List (1993)
16216
16217 tmp = (-((0.5)*(1.e+06)*xdia(mgs,lc,1)) &
16218 & *( (1.0-rimdenvwgt)*vtxbar(mgs,lh,1) + rimdenvwgt*vtxbar(mgs,lh,2) ) &
16219 & /(temg(mgs)-273.15))
16220 tmp = min( 5.5/0.6, max( 0.3/0.6, tmp ) ) ! have to limit range of "R" because quadratic function starts to decrease (unphysically) at higher values
16221
16222 rimdn(mgs,lh) = 1000.*(0.051 + 0.114*tmp - 0.0055*tmp**2)
16223
16224 ELSEIF ( irimdenopt == 3 .or. irimdenopt == 4) THEN ! Macklin (3) or Saunders and Hosseini 2001
16225
16226 tmp = (-((0.5)*(1.e+06)*xdia(mgs,lc,1)) &
16227 & *( (1.0-rimdenvwgt)*vtxbar(mgs,lh,1) + rimdenvwgt*vtxbar(mgs,lh,2) ) &
16228 & /(temg(mgs)-273.15))
16229 ! tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) )
16230
16231 IF ( irimdenopt == 3 ) THEN
16232 rimdn(mgs,lh) = min(900., max( 170., 110.*tmp**0.76 ) )
16233 ELSEIF ( irimdenopt == 4 ) THEN ! Saunders and Hosseini
16234 rimdn(mgs,lh) = min(917., max( 10., 900.0*(1.0 - 0.905**tmp ) ) )
16235 ENDIF
16236
16237 ENDIF
16238 ELSE
16239 rimdn(mgs,lh) = 1000.
16240 ENDIF
16241
16242 IF ( lvol(lh) > 1 ) vhacw(mgs) = rho0(mgs)*qhacw(mgs)/rimdn(mgs,lh)
16243
16244 ENDIF
16245
16246 IF ( qx(mgs,lh) .gt. qxmin(lh) .and. ipelec .ge. 1 ) THEN
16247 rarx(mgs,lh) = &
16248 & qhacw(mgs)*1.0e3*rho0(mgs)/((pi/2.0)*xdia(mgs,lh,2)*cx(mgs,lh))
16249 ENDIF
16250
16251 ENDIF
16252 end do
16253!
16254!
16255 do mgs = 1,ngscnt
16256 qhaci(mgs) = 0.0
16257 qhaci0(mgs) = 0.0
16258 IF ( ehi(mgs) .gt. 0.0 ) THEN
16259 IF ( ipconc .ge. 5 ) THEN
16260
16261 vt = sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,li,1))**2 + &
16262 & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,li,1) )
16263
16264 qhaci0(mgs) = 0.25*pi*ehiclsn(mgs)*cx(mgs,lh)*qx(mgs,li)*vt* &
16265 & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + &
16266 & dab1lh(mgs,lh,li)*xdia(mgs,lh,3)*xdia(mgs,li,3) + &
16267 & da1(li)*xdia(mgs,li,3)**2 )
16268 qhaci(mgs) = min( ehi(mgs)*qhaci0(mgs), qimxd(mgs) )
16269 ELSE
16270 qhaci(mgs) = &
16271 & min( &
16272 & ((0.25)*pi)*ehi(mgs)*ehiclsn(mgs)*qx(mgs,li)*cx(mgs,lh) &
16273 & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,li,1)) &
16274 & *( gf3*xdia(mgs,lh,2) &
16275 & + 2.0*gf2*xdia(mgs,lh,1)*xdia(mgs,li,1) &
16276 & + gf1*xdia(mgs,li,2) ) &
16277 & , qimxd(mgs))
16278 ENDIF
16279 ENDIF
16280 end do
16281
16282
16283 IF ( lis > 1 .and. ipconc >= 5 ) THEN
16284 do mgs = 1,ngscnt
16285 qhacis(mgs) = 0.0
16286 qhacis0(mgs) = 0.0
16287 IF ( ehis(mgs) .gt. 0.0 ) THEN
16288
16289 vt = sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,lis,1))**2 + &
16290 & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,lis,1) )
16291
16292 qhacis0(mgs) = 0.25*pi*ehisclsn(mgs)*cx(mgs,lh)*qx(mgs,lis)*vt* &
16293 & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + &
16294 & dab1lh(mgs,lh,lis)*xdia(mgs,lh,3)*xdia(mgs,lis,3) + &
16295 & da1(li)*xdia(mgs,lis,3)**2 )
16296 qhacis(mgs) = min( ehis(mgs)*qhacis0(mgs), qxmxd(mgs,lis) )
16297 ENDIF
16298 end do
16299 ENDIF
16300
16301!
16302!
16303 do mgs = 1,ngscnt
16304 qhacs(mgs) = 0.0
16305 qhacs0(mgs) = 0.0
16306 IF ( ehs(mgs) .gt. 0.0 ) THEN
16307 IF ( ipconc .ge. 5 ) THEN
16308
16309 vt = sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1))**2 + &
16310 & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,ls,1) )
16311
16312 qhacs0(mgs) = 0.25*pi*ehsclsn(mgs)*cx(mgs,lh)*qx(mgs,ls)*vt* &
16313 & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + &
16314 & dab1lh(mgs,lh,ls)*xdia(mgs,lh,3)*xdia(mgs,ls,3) + &
16315 & da1(ls)*xdia(mgs,ls,3)**2 )
16316
16317 qhacs(mgs) = min( ehs(mgs)*qhacs0(mgs), qsmxd(mgs) )
16318
16319 ELSE
16320 qhacs(mgs) = &
16321 & min( &
16322 & ((0.25)*pi/gf4)*ehs(mgs)*ehsclsn(mgs)*qx(mgs,ls)*cx(mgs,lh) &
16323 & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1)) &
16324 & *( gf6*gf1*xdia(mgs,ls,2) &
16325 & + 2.0*gf5*gf2*xdia(mgs,ls,1)*xdia(mgs,lh,1) &
16326 & + gf4*gf3*xdia(mgs,lh,2) ) &
16327 & , qsmxd(mgs))
16328 ENDIF
16329 ENDIF
16330 end do
16331!
16332 do mgs = 1,ngscnt
16333 qhacr(mgs) = 0.0
16334 qhacrmlr(mgs) = 0.0
16335 vhacr(mgs) = 0.0
16336 chacr(mgs) = 0.0
16337 zhacr(mgs) = 0.0
16338 IF ( temg(mgs) .gt. tfr ) raindn(mgs,lh) = 1000.0
16339
16340 IF ( ehr(mgs) .gt. 0.0 ) THEN
16341 IF ( ipconc .ge. 3 ) THEN
16342 vt = sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,lr,1))**2 + &
16343 & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,lr,1) )
16344! qhacr(mgs) = ehr(mgs)*cx(mgs,lh)*vt*
16345! : qx(mgs,lr)*0.25*pi*
16346! : (3.02787*xdia(mgs,lr,2) +
16347! : 3.30669*xdia(mgs,lh,1)*xdia(mgs,lr,1) +
16348! : 2.*xdia(mgs,lh,2))
16349
16350 qhacr(mgs) = 0.25*pi*ehr(mgs)*cx(mgs,lh)*qx(mgs,lr)*vt* &
16351 & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + &
16352 & dab1lh(mgs,lh,lr)*xdia(mgs,lh,3)*xdia(mgs,lr,3) + &
16353 & da1lr(mgs)*xdia(mgs,lr,3)**2 )
16354! & da1(lr)*xdia(mgs,lr,3)**2 )
16355! IF ( qhacr(mgs) .gt. 0. .or. tmp .gt. 0.0 ) write(0,*) 'qhacr= ',qhacr(mgs),tmp
16356!! qhacr(mgs) = Min( qhacr(mgs), qrmxd(mgs) )
16357!! chacr(mgs) = qhacr(mgs)*cx(mgs,lr)/qx(mgs,lr)
16358!! chacr(mgs) = min(chacr(mgs),crmxd(mgs))
16359
16360 qhacr(mgs) = min( qhacr(mgs), qxmxd(mgs,lr) )
16361
16362 qhacrmlr(mgs) = qhacr(mgs)
16363
16364 IF ( temg(mgs) > tfr .and. iehr0c == 0 ) THEN
16365 qhacr(mgs) = 0.0
16366
16367 IF ( iqhacrmlr == 0 ) THEN
16368 qhacrmlr(mgs) = -qhacw(mgs)
16369 ENDIF
16370
16371 ELSE
16372! chacr(mgs) = Min( qhacr(mgs)*rho0(mgs)/xmas(mgs,lr), cxmxd(mgs,lr) )
16373
16374! chacr(mgs) = ehr(mgs)*cx(mgs,lh)*vt*
16375! : cx(mgs,lr)*0.25*pi*
16376! : (0.69874*xdia(mgs,lr,2) +
16377! : 1.24001*xdia(mgs,lh,1)*xdia(mgs,lr,1) +
16378! : 2.*xdia(mgs,lh,2))
16379
16380 chacr(mgs) = 0.25*pi*ehr(mgs)*cx(mgs,lh)*cx(mgs,lr)*vt* &
16381 & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + &
16382 & dab0lh(mgs,lh,lr)*xdia(mgs,lh,3)*xdia(mgs,lr,3) + &
16383 & da0lr(mgs)*xdia(mgs,lr,3)**2 )
16384
16385! IF ( qhacr(mgs) .gt. 0. .or. tmp .gt. 0.0 ) write(0,*) 'chacr= ',chacr(mgs),tmp
16386
16387! chacr(mgs) = qhacr(mgs)*cx(mgs,lr)/qx(mgs,lr)
16388 chacr(mgs) = min(chacr(mgs),crmxd(mgs))
16389
16390 IF ( lzh .gt. 1 ) THEN
16391 tmp = qx(mgs,lh)/cx(mgs,lh)
16392
16393! g1 = (6.0 + alpha(mgs,lh))*(5.0 + alpha(mgs,lh))*(4.0 + alpha(mgs,lh))/
16394! : ((3.0 + alpha(mgs,lh))*(2.0 + alpha(mgs,lh))*(1.0 + alpha(mgs,lh)))
16395! alp = Max( 1.0, alpha(mgs,lh)+1. )
16396! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/
16397! : ((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
16398! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) - tmp**2 * chacr(mgs) )
16399! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qhacr(mgs) )
16400 ENDIF
16401 ENDIF ! temg > tfr
16402
16403 ELSE
16404 IF ( lwsm6 .and. ipconc == 0 ) THEN
16405 vt = vt2ave(mgs)
16406 ELSE
16407 vt = vtxbar(mgs,lh,1)
16408 ENDIF
16409
16410 qhacr(mgs) = &
16411 & min( &
16412 & ((0.25)*pi/gf4)*ehr(mgs)*qx(mgs,lr)*cx(mgs,lh) &
16413 & *abs(vt-vtxbar(mgs,lr,1)) &
16414 & *( gf6*gf1*xdia(mgs,lr,2) &
16415 & + 2.0*gf5*gf2*xdia(mgs,lr,1)*xdia(mgs,lh,1) &
16416 & + gf4*gf3*xdia(mgs,lh,2) ) &
16417 & , qrmxd(mgs))
16418
16419 IF ( temg(mgs) > tfr ) THEN
16420 IF ( iqhacrmlr >= 1 ) qhacrmlr(mgs) = qhacr(mgs)
16421 qhacr(mgs) = 0.0
16422 ENDIF
16423
16424 ENDIF
16425 IF ( lvol(lh) .gt. 1 .or. lhl .gt. 1 ) THEN ! calculate rime density for graupel volume and/or for graupel conversion to hail
16426
16427 IF ( temg(mgs) .lt. 273.15) THEN
16428 raindn(mgs,lh) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lr,3)) &
16429 & *((0.60)*vt) &
16430 & /(temg(mgs)-273.15))**(rimc2)
16431
16432 raindn(mgs,lh) = min( max( rimc3, rimdn(mgs,lh) ), rimc4 )
16433 ELSE
16434 raindn(mgs,lh) = 1000.
16435 ENDIF
16436
16437 IF ( lvol(lh) > 1 ) vhacr(mgs) = rho0(mgs)*qhacr(mgs)/raindn(mgs,lh)
16438 ENDIF
16439 ENDIF
16440 end do
16441
16442!
16443!
16444 if (ndebug .gt. 0 ) write(0,*) 'Collection: hail collects xxxxx'
16445!
16446
16447 do mgs = 1,ngscnt
16448 qhlacw(mgs) = 0.0
16449 qhlacwmlr(mgs) = 0.0
16450 vhlacw(mgs) = 0.0
16451 vhlsoak(mgs) = 0.0
16452 IF ( lhl > 1 .and. .true.) THEN
16453 vtmax = (gz(igs(mgs),jgs,kgs(mgs))*dtpinv)
16454 vtxbar(mgs,lhl,1) = min( vtmax, vtxbar(mgs,lhl,1))
16455 vtxbar(mgs,lhl,2) = min( vtmax, vtxbar(mgs,lhl,2))
16456 vtxbar(mgs,lhl,3) = min( vtmax, vtxbar(mgs,lhl,3))
16457 ENDIF
16458
16459 IF ( lhl > 0 ) THEN
16460 rarx(mgs,lhl) = 0.0
16461 ENDIF
16462
16463 IF ( lhl .gt. 1 .and. ehlw(mgs) .gt. 0.0 ) THEN
16464
16465
16466! IF ( ipconc .ge. 2 ) THEN
16467
16468 vt = abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,lc,1))
16469
16470 qhlacw(mgs) = 0.25*pi*ehlw(mgs)*cx(mgs,lhl)*(qx(mgs,lc)-qcwresv(mgs))*vt* &
16471 & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + &
16472 & dab1lh(mgs,lhl,lc)*xdia(mgs,lhl,3)*xdia(mgs,lc,3) + &
16473 & da1lc(mgs)*xdia(mgs,lc,3)**2 )
16474
16475
16476 qhlacw(mgs) = min( qhlacw(mgs), 0.5*qx(mgs,lc)*dtpinv )
16477
16478 qhlacwmlr(mgs) = qhlacw(mgs)
16479 IF ( temg(mgs) > tfr .and. iqhlacwshr == 0 ) THEN
16480 qhlacw(mgs) = 0.0
16481 ENDIF
16482
16483 IF ( lvol(lhl) .gt. 1 ) THEN
16484
16485 IF ( temg(mgs) .lt. 273.15) THEN
16486 IF ( irimdenopt == 1 ) THEN ! Heymsfeld and Pflaum (1985)
16487 rimdn(mgs,lhl) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) &
16488 & *((0.60)*( (1.0-rimdenvwgt)*vtxbar(mgs,lhl,1) + rimdenvwgt*vtxbar(mgs,lhl,2) )) &
16489 & /(temg(mgs)-273.15))**(rimc2)
16490 rimdn(mgs,lhl) = min( max( hldnmn, rimc3, rimdn(mgs,lhl) ), rimc4 )
16491
16492 ELSEIF ( irimdenopt == 2 ) THEN ! Cober and List (1993)
16493 tmp = -0.5*(1.e+06)*xdia(mgs,lc,1) &
16494 & *( (1.0-rimdenvwgt)*vtxbar(mgs,lhl,1) + rimdenvwgt*vtxbar(mgs,lhl,2) ) &
16495 & /(temg(mgs)-273.15)
16496 tmp = min( 5.5/0.6, max( 0.3/0.6, tmp ) )
16497
16498 rimdn(mgs,lhl) = 1000.*(0.051 + 0.114*tmp - 0.005*tmp**2)
16499
16500 ELSEIF ( irimdenopt == 3 .or. irimdenopt == 4) THEN ! Macklin (3) or Saunders and Hosseini 2001
16501 tmp = -0.5*(1.e+06)*xdia(mgs,lc,1) &
16502 & *( (1.0-rimdenvwgt)*vtxbar(mgs,lhl,1) + rimdenvwgt*vtxbar(mgs,lhl,2) ) &
16503 & /(temg(mgs)-273.15)
16504 ! tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) )
16505
16506 IF ( irimdenopt == 3 ) THEN
16507 rimdn(mgs,lhl) = min(900., max( 170., 110.*tmp**0.76 ) )
16508 ELSEIF ( irimdenopt == 4 ) THEN ! Saunders and Hosseini
16509 rimdn(mgs,lhl) = min(917., max( 10., 900.0*(1.0 - 0.905**tmp ) ) )
16510 ENDIF
16511
16512 ENDIF
16513 ELSE
16514 rimdn(mgs,lhl) = 1000.
16515 ENDIF
16516
16517 vhlacw(mgs) = rho0(mgs)*qhlacw(mgs)/rimdn(mgs,lhl)
16518
16519 ENDIF
16520
16521
16522 IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. ipelec .ge. 1 ) THEN
16523 rarx(mgs,lhl) = &
16524 & qhlacw(mgs)*1.0e3*rho0(mgs)/((pi/2.0)*xdia(mgs,lhl,2)*cx(mgs,lhl))
16525 ENDIF
16526
16527 ENDIF
16528 end do
16529
16530 qhlaci(:) = 0.0
16531 qhlaci0(:) = 0.0
16532 IF ( lhl .gt. 1 ) THEN
16533 do mgs = 1,ngscnt
16534 IF ( ehli(mgs) .gt. 0.0 ) THEN
16535 IF ( ipconc .ge. 5 ) THEN
16536
16537 vt = sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,li,1))**2 + &
16538 & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,li,1) )
16539
16540 qhlaci0(mgs) = 0.25*pi*ehliclsn(mgs)*cx(mgs,lhl)*qx(mgs,li)*vt* &
16541 & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + &
16542 & dab1lh(mgs,lhl,li)*xdia(mgs,lhl,3)*xdia(mgs,li,3) + &
16543 & da1(li)*xdia(mgs,li,3)**2 )
16544 ! qhlaci(mgs) = Min( qhlaci(mgs), qimxd(mgs) )
16545 qhlaci(mgs) = min( ehli(mgs)*qhlaci0(mgs), qimxd(mgs) )
16546 ENDIF
16547 ENDIF
16548 end do
16549 ENDIF
16550!
16551 qhlacs(:) = 0.0
16552 qhlacs0(:) = 0.0
16553 IF ( lhl .gt. 1 ) THEN
16554 do mgs = 1,ngscnt
16555 IF ( ehls(mgs) .gt. 0.0) THEN
16556 IF ( ipconc .ge. 5 ) THEN
16557
16558 vt = sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,ls,1))**2 + &
16559 & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,ls,1) )
16560
16561 qhlacs0(mgs) = 0.25*pi*ehlsclsn(mgs)*cx(mgs,lhl)*qx(mgs,ls)*vt* &
16562 & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + &
16563 & dab1lh(mgs,lhl,ls)*xdia(mgs,lhl,3)*xdia(mgs,ls,3) + &
16564 & da1(ls)*xdia(mgs,ls,3)**2 )
16565
16566 qhlacs(mgs) = min( ehls(mgs)*qhlacs0(mgs), qsmxd(mgs) )
16567 ENDIF
16568 ENDIF
16569 end do
16570 ENDIF
16571
16572
16573 do mgs = 1,ngscnt
16574 qhlacr(mgs) = 0.0
16575 qhlacrmlr(mgs) = 0.0
16576 chlacr(mgs) = 0.0
16577 vhlacr(mgs) = 0.0
16578 IF ( lhl .gt. 1 .and. temg(mgs) .gt. tfr ) raindn(mgs,lhl) = 1000.0
16579
16580 IF ( lhl .gt. 1 .and. ehlr(mgs) .gt. 0.0 ) THEN
16581 IF ( ipconc .ge. 3 ) THEN
16582 vt = sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,lr,1))**2 + &
16583 & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,lr,1) )
16584
16585 qhlacr(mgs) = 0.25*pi*ehlr(mgs)*cx(mgs,lhl)*qx(mgs,lr)*vt* &
16586 & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + &
16587 & dab1lh(mgs,lhl,lr)*xdia(mgs,lhl,3)*xdia(mgs,lr,3) + &
16588 & da1lr(mgs)*xdia(mgs,lr,3)**2 )
16589! & da1(lr)*xdia(mgs,lr,3)**2 )
16590! IF ( qhacr(mgs) .gt. 0. .or. tmp .gt. 0.0 ) write(0,*) 'qhacr= ',qhacr(mgs),tmp
16591!! qhacr(mgs) = Min( qhacr(mgs), qrmxd(mgs) )
16592!! chacr(mgs) = qhacr(mgs)*cx(mgs,lr)/qx(mgs,lr)
16593!! chacr(mgs) = min(chacr(mgs),crmxd(mgs))
16594
16595 qhlacr(mgs) = min( qhlacr(mgs), qxmxd(mgs,lr) )
16596
16597
16598 IF ( iqhlacrmlr >= 1 ) qhlacrmlr(mgs) = qhlacr(mgs)
16599
16600 IF ( temg(mgs) > tfr .and. iehlr0c == 0) THEN
16601 qhlacr(mgs) = 0.0
16602 IF ( iqhlacrmlr == 0 ) THEN
16603 qhlacrmlr(mgs) = -qhlacw(mgs)
16604 ENDIF
16605 ELSE
16606 chlacr(mgs) = 0.25*pi*ehlr(mgs)*cx(mgs,lhl)*cx(mgs,lr)*vt* &
16607 & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + &
16608 & dab0lh(mgs,lhl,lr)*xdia(mgs,lhl,3)*xdia(mgs,lr,3) + &
16609 & da0lr(mgs)*xdia(mgs,lr,3)**2 )
16610
16611 chlacr(mgs) = min(chlacr(mgs),crmxd(mgs))
16612
16613 IF ( lvol(lhl) .gt. 1 ) THEN
16614 vhlacr(mgs) = rho0(mgs)*qhlacr(mgs)/raindn(mgs,lhl)
16615 ENDIF
16616 ENDIF
16617 ENDIF
16618 ENDIF
16619 end do
16620
16621
16622
16623!
16624!
16625!
16626!
16627! if (ndebug .gt. 0 ) write(0,*) 'Collection: Cloud collects xxxxx'
16628
16629 if (ndebug .gt. 0 ) write(0,*) 'Collection: cloud ice collects xxxx2'
16630!
16631 do mgs = 1,ngscnt
16632 qiacw(mgs) = 0.0
16633 IF ( eiw(mgs) .gt. 0.0 ) THEN
16634
16635 vt = sqrt((vtxbar(mgs,li,1)-vtxbar(mgs,lc,1))**2 + &
16636 & 0.04*vtxbar(mgs,li,1)*vtxbar(mgs,lc,1) )
16637
16638 qiacw(mgs) = 0.25*pi*eiw(mgs)*cx(mgs,li)*qx(mgs,lc)*vt* &
16639 & ( da0(li)*xdia(mgs,li,3)**2 + &
16640 & dab1(li,lc)*xdia(mgs,li,3)*xdia(mgs,lc,3) + &
16641 & da1lc(mgs)*xdia(mgs,lc,3)**2 )
16642
16643 qiacw(mgs) = min( qiacw(mgs), qxmxd(mgs,lc) )
16644 ENDIF
16645 end do
16646
16647
16648!
16649!
16650 if (ndebug .gt. 0 ) write(0,*) 'Collection: cloud ice collects xxxx8'
16651!
16652 do mgs = 1,ngscnt
16653 qiacr(mgs) = 0.0
16654 qiacrf(mgs) = 0.0
16655 qiacrs(mgs) = 0.0
16656 ciacrs(mgs) = 0.0
16657 ciacr(mgs) = 0.0
16658 ciacrf(mgs) = 0.0
16659 viacrf(mgs) = 0.0
16660 csplinter(mgs) = 0.0
16661 qsplinter(mgs) = 0.0
16662 csplinter2(mgs) = 0.0
16663 qsplinter2(mgs) = 0.0
16664 IF ( iacr .ge. 1 .and. eri(mgs) .gt. 0.0 &
16665 & .and. temg(mgs) .le. 270.15 ) THEN
16666 IF ( ipconc .ge. 3 ) THEN
16667 ni = 0.0
16668 IF ( xdia(mgs,li,1) .ge. 10.e-6 ) THEN
16669 ni = ni + cx(mgs,li)*exp(- (40.e-6/xdia(mgs,li,1))**3 )
16670 ENDIF
16671 IF ( imurain == 1 ) THEN ! gamma of diameter
16672 IF ( iacrsize /= 4 ) THEN
16673 IF ( iacrsize .eq. 1 ) THEN
16674 ratio = 500.e-6/xdia(mgs,lr,1)
16675 ELSEIF ( iacrsize .eq. 2 ) THEN
16676 ratio = 300.e-6/xdia(mgs,lr,1)
16677 ELSEIF ( iacrsize .eq. 3 ) THEN
16678 ratio = 40.e-6/xdia(mgs,lr,1)
16679 ELSEIF ( iacrsize .eq. 5 ) THEN
16680 ratio = 150.e-6/xdia(mgs,lr,1)
16681 ENDIF
16682 i = min(nqiacrratio,int(ratio*dqiacrratioinv))
16683 j = int(max(0.0,min(15.,alpha(mgs,lr)))*dqiacralphainv)
16684! j = Int(Max(minalphalu,Min(maxalphalu,alpha(mgs,lr)))*dqiacralphainv)
16685 delx = ratio - float(i)*dqiacrratio
16686 dely = alpha(mgs,lr) - float(j)*dqiacralpha
16687 ip1 = min( i+1, nqiacrratio )
16688 jp1 = min( j+1, nqiacralpha )
16689
16690 ! interpolate along x, i.e., ratio
16691 tmp1 = ciacrratio(i,j) + delx*dqiacrratioinv*(ciacrratio(ip1,j) - ciacrratio(i,j))
16692 tmp2 = ciacrratio(i,jp1) + delx*dqiacrratioinv*(ciacrratio(ip1,jp1) - ciacrratio(i,jp1))
16693
16694 ! interpolate along alpha
16695
16696 nr = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*cx(mgs,lr)
16697
16698 ! interpolate along x, i.e., ratio;
16699 tmp1 = qiacrratio(i,j) + delx*dqiacrratioinv*(qiacrratio(ip1,j) - qiacrratio(i,j))
16700 tmp2 = qiacrratio(i,jp1) + delx*dqiacrratioinv*(qiacrratio(ip1,jp1) - qiacrratio(i,jp1))
16701
16702 ! interpolate along alpha;
16703
16704 qr = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*qx(mgs,lr)
16705
16706 ELSE ! iacrsize == 4 : use all
16707 nr = cx(mgs,lr)
16708 qr = qx(mgs,lr)
16709 ENDIF
16710
16711 vt = sqrt((vtxbar(mgs,lr,1)-vtxbar(mgs,li,1))**2 + &
16712 & 0.04*vtxbar(mgs,lr,1)*vtxbar(mgs,li,1) )
16713
16714 qiacr(mgs) = 0.25*pi*eri(mgs)*ni*qr*vt* &
16715 & ( da0(li)*xdia(mgs,li,3)**2 + &
16716 & dab1lh(mgs,li,lr)*xdia(mgs,lh,3)*xdia(mgs,li,3) + &
16717 & da1(lr)*xdia(mgs,lr,3)**2 )
16718
16719 qiacr(mgs) = min( qrmxd(mgs), qiacr(mgs) )
16720
16721
16722 ciacr(mgs) = 0.25*pi*eri(mgs)*ni*nr*vt* &
16723 & ( da0(li)*xdia(mgs,li,3)**2 + &
16724 & dab0lh(mgs,li,lr)*xdia(mgs,lr,3)*xdia(mgs,li,3) + &
16725 & da0(lr)*xdia(mgs,lr,3)**2 )
16726
16727 ciacr(mgs) = min( crmxd(mgs), ciacr(mgs) )
16728
16729! write(iunit,*) 'qiacr: ',cx(mgs,lr),nr,qx(mgs,lr),qr,qiacr(mgs),ciacr(mgs)
16730! write(iunit,*) 'xdia r li = ',xdia(mgs,lr,3),xdia(mgs,li,3),xdia(mgs,lr,1),xdia(mgs,li,1)
16731! write(iunit,*) 'i,j,ratio = ',i,j,ciacrratio(i,j),qiacrratio(i,j)
16732! write(iunit,*) 'ni,ci = ',ni,cx(mgs,li),qx(mgs,li)
16733
16734 ELSEIF ( imurain == 3 ) THEN ! gamma of volume
16735! Set nr to the number of drops greater than 40 microns.
16736 arg = 1000.*xdia(mgs,lr,3)
16737! nr = cx(mgs,lr)*gaml02( arg )
16738! IF ( iacr .eq. 1 ) THEN
16739 IF ( ipconc .ge. 3 ) THEN
16740 IF ( iacrsize .eq. 1 ) THEN
16741 nr = cx(mgs,lr)*gaml02d500( arg ) ! number greater than 500 microns in diameter
16742 ELSEIF ( iacrsize .eq. 2 .or. iacrsize .eq. 5 ) THEN
16743 nr = cx(mgs,lr)*gaml02d300( arg ) ! number greater than 300 microns in diameter
16744 ELSEIF ( iacrsize .eq. 3 ) THEN
16745 nr = cx(mgs,lr)*gaml02( arg ) ! number greater than 40 microns in diameter
16746 ELSEIF ( iacrsize .eq. 4 ) THEN
16747 nr = cx(mgs,lr) ! all raindrops
16748 ENDIF
16749 ELSE
16750 nr = cx(mgs,lr)*gaml02( arg )
16751 ENDIF
16752! ELSEIF ( iacr .eq. 2 ) THEN
16753! nr = cx(mgs,lr)*gaml02d300( arg ) ! number greater than 300 microns in diameter
16754! ENDIF
16755 IF ( ni .gt. 0.0 .and. nr .gt. 0.0 ) THEN
16756 d0 = xdia(mgs,lr,3)
16757 qiacr(mgs) = xdn(mgs,lr)*rhoinv(mgs)* &
16758 & (0.217239*(0.522295*(d0**5) + &
16759 & 49711.81*(d0**6) - &
16760 & 1.673016e7*(d0**7)+ &
16761 & 2.404471e9*(d0**8) - &
16762 & 1.22872e11*(d0**9))*ni*nr)
16763 qiacr(mgs) = min( qrmxd(mgs), qiacr(mgs) )
16764 ciacr(mgs) = &
16765 & (0.217239*(0.2301947*(d0**2) + &
16766 & 15823.76*(d0**3) - &
16767 & 4.167685e6*(d0**4) + &
16768 & 4.920215e8*(d0**5) - &
16769 & 2.133344e10*(d0**6))*ni*nr)
16770 ciacr(mgs) = min( crmxd(mgs), ciacr(mgs) )
16771! ciacr(mgs) = qiacr(mgs)*cx(mgs,lr)/qx(mgs,lr)
16772 ENDIF
16773 ENDIF
16774 IF ( iacr .eq. 1 .or. iacr .eq. 3 ) THEN
16775 ciacrf(mgs) = min(ciacr(mgs), qiacr(mgs)/(1.0*vr1mm*1000.0)*rho0(mgs) ) ! *rzxh(mgs)
16776 ELSEIF ( iacr .eq. 2 ) THEN
16777 ciacrf(mgs) = ciacr(mgs) ! *rzxh(mgs)
16778 ELSEIF ( iacr .eq. 4 ) THEN
16779 ciacrf(mgs) = min(ciacr(mgs), qiacr(mgs)/(1.0*vfrz*1000.0)*rho0(mgs) ) ! *rzxh(mgs)
16780 ELSEIF ( iacr .eq. 5 ) THEN
16781 ciacrf(mgs) = ciacr(mgs)*rzxh(mgs)
16782 ENDIF
16783! crfrzf(mgs) = Min(crfrz(mgs), qrfrz(mgs)/(bfnu*27.0*vr1mm*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs)
16784 ENDIF
16785
16786
16787 ELSE ! single-moment rain
16788 qiacr(mgs) = &
16789 & min( &
16790 & ((0.25/gf4)*pi)*eri(mgs)*cx(mgs,li)*qx(mgs,lr) &
16791 & *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,li,1)) &
16792 & *( gf6*gf1*xdia(mgs,lr,2) &
16793 & + 2.0*gf5*gf2*xdia(mgs,lr,1)*xdia(mgs,li,1) &
16794 & + gf4*gf3*xdia(mgs,li,2) ) &
16795 & , qrmxd(mgs))
16796 ENDIF
16797! if ( temg(mgs) .gt. 268.15 ) then
16798! qiacr(mgs) = 0.0
16799! ciacr(mgs) = 0.0
16800! end if
16801
16802 IF ( ipconc .ge. 1 ) THEN
16803 IF ( nsplinter .ge. 1000 ) THEN
16804 ! Lawson et al. 2015 JAS
16805 ! ave. diam of freezing drops in microns
16806 IF ( qiacr(mgs)*dtp > qxmin(lh) .and. ciacr(mgs) > 1.e-3 ) THEN
16807 tmpdiam = 1.e6*( 6.*qiacr(mgs)/(1000.*pi*ciacr(mgs) ) )**(1./3.) ! avg. diameter of newly frozen drops in microns
16808 csplinter(mgs) = lawson_splinter_fac*tmpdiam**4*ciacr(mgs)
16809 ENDIF
16810 ELSEIF ( nsplinter .ge. 0 ) THEN
16811 csplinter(mgs) = nsplinter*ciacr(mgs)
16812 ELSE
16813 csplinter(mgs) = -nsplinter*ciacrf(mgs)
16814 ENDIF
16815 qsplinter(mgs) = min(0.1*qiacr(mgs), csplinter(mgs)*splintermass/rho0(mgs) ) ! makes splinters smaller if too much mass is taken from graupel
16816 ENDIF
16817
16818 frach = 1.0
16819 IF ( ibiggsnow == 2 .or. ibiggsnow == 3 ) THEN
16820 IF ( ciacr(mgs) > qxmin(lh) ) THEN
16821 xvfrz = rho0(mgs)*qiacr(mgs)/(ciacr(mgs)*900.) ! mean volume of frozen drops; 900. for frozen drop density
16822 frach = 0.5 *(1. + tanh(0.2e12 *( xvfrz - 1.15*xvbiggsnow)))
16823
16824 qiacrs(mgs) = (1.-frach)*qiacr(mgs)
16825 ciacrs(mgs) = (1.-frach)*ciacrf(mgs) ! *rzxh(mgs)
16826
16827 ENDIF
16828 ENDIF
16829
16830 qiacrf(mgs) = frach*qiacr(mgs)
16831 ciacrf(mgs) = frach*ciacrf(mgs)
16832
16833 IF ( lvol(lh) > 1 ) THEN
16834 viacrf(mgs) = rho0(mgs)*qiacrf(mgs)/rhofrz
16835 ENDIF
16836
16837 end do
16838!
16839!
16840!
16841!
16842
16843! snow aggregation here
16844 if ( ipconc .ge. 4 ) then !
16845 do mgs = 1,ngscnt
16846 csacs(mgs) = 0.0
16847 IF ( qx(mgs,ls) > qxmin(ls) .and. ess(mgs) .gt. 0.0 ) THEN ! .and. xv(mgs,ls) < 0.25*xvmx(ls)*Max(1.,100./Min(100.,xdn(mgs,ls))) ) THEN
16848
16849 IF ( iessec0flag == 0 ) THEN
16850 ec0(mgs) = 1.0
16851 ELSE
16852 tmp = xv(mgs,ls)/(xvmx(ls)*max(1.,100./min(100.,xdn(mgs,ls)))) ! fraction of max snow mass
16853 IF ( tmp .lt. essfrac1 ) THEN
16854 ec0(mgs) = 1.0
16855 ELSEIF ( tmp .ge. essfrac2 ) THEN
16856 ec0(mgs) = 0.0
16857 ELSE
16858 ec0(mgs) = (essfrac2 - tmp)/(essfrac2 - essfrac1)
16859 ENDIF
16860 ENDIF
16861
16862 csacs(mgs) = ec0(mgs)*rvt*aa2*ess(mgs)*cx(mgs,ls)**2*min( xv(mgs,ls), 4.*pii/3.*essrmax**3 ) ! *Min(1.,xdn(mgs,ls)/100. ) ! Min func tries to recalibrate for low diagnosed density
16863! csacs(mgs) = rvt*aa2*ess(mgs)*cx(mgs,ls)**2*Min( xv(mgs,ls), 4.*pii/3.*0.02**3 ) ! *Min(1.,xdn(mgs,ls)/100. ) ! Min func tries to recalibrate for low diagnosed density
16864 csacs(mgs) = min(csacs(mgs),csmxd(mgs))
16865 ENDIF
16866 end do
16867 end if
16868!
16869!
16870 if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 11'
16871 if ( ipconc .ge. 2 .or. ipelec .ge. 9 ) then
16872 do mgs = 1,ngscnt
16873 ciacw(mgs) = 0.0
16874 IF ( eiw(mgs) .gt. 0.0 ) THEN
16875 ciacw(mgs) = qiacw(mgs)*rho0(mgs)/xmas(mgs,lc)
16876 ciacw(mgs) = min(ciacw(mgs),ccmxd(mgs))
16877 ENDIF
16878 end do
16879
16880 end if
16881
16882 if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 18'
16883 if ( ipconc .ge. 2 .or. ipelec .ge. 1 ) then
16884 do mgs = 1,ngscnt
16885 cracw(mgs) = 0.0
16886 cracr(mgs) = 0.0
16887 ec0(mgs) = 1.e9
16888 IF ( qx(mgs,lc) .gt. qxmin(lc) .and. qx(mgs,lr) .gt. qxmin(lr) &
16889 & .and. qracw(mgs) .gt. 0.0 ) THEN
16890
16891 IF ( ipconc .lt. 3 ) THEN
16892 IF ( erw(mgs) .gt. 0.0 ) THEN
16893 cracw(mgs) = &
16894 & ((0.25)*pi)*erw(mgs)*(cx(mgs,lc) - ccwresv(mgs))*cx(mgs,lr) &
16895 & *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,lc,1)) &
16896 & *( gf1*xdia(mgs,lc,2) &
16897 & + 2.0*gf2*xdia(mgs,lc,1)*xdia(mgs,lr,1) &
16898 & + gf3*xdia(mgs,lr,2) )
16899 ENDIF
16900 ELSE ! IF ( ipconc .ge. 3 .and.
16901 IF ( dmrauto <= 0 .or. rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN !{
16902 IF ( 0.5*xdia(mgs,lr,3) .gt. rh(mgs) ) THEN ! { .or. cx(mgs,lr) .gt. nh(mgs)
16903! IF ( qx(mgs,lc) .gt. qxmin(lc) .and. qx(mgs,lr) .gt. qxmin(lr) ) THEN
16904 IF ( 0.5*xdia(mgs,lr,3) .gt. rwradmn ) THEN ! r > 50.e-6
16905! DM0CCC=A2*XNC*XNR*(XVC+XVR) ! (A11)
16906! NOTE: murain drops out, so same result for imurain = 1 and 3
16907 cracw(mgs) = aa2*cx(mgs,lr)*(cx(mgs,lc) - ccwresv(mgs))*(xv(mgs,lc) + xv(mgs,lr))
16908 ELSE
16909 IF ( imurain == 3 ) THEN
16910! DM0CCC=A1*XNC*XNR*(((CNU+2.)/(CNU+1.))*XVC**2+((RNU+2.)/(RNU+1.))*XVR**2) ! (A13)
16911 cracw(mgs) = aa1*cx(mgs,lr)*(cx(mgs,lc) - ccwresv(mgs))* &
16912 & ((alpha(mgs,lc) + 2.)*xv(mgs,lc)**2/(alpha(mgs,lc) + 1.) + &
16913 & (alpha(mgs,lr) + 2.)*xv(mgs,lr)**2/(alpha(mgs,lr) + 1.))
16914 ELSE ! imurain == 1 USE CP00 for rain DSD in diameter
16915 cracw(mgs) = aa1*cx(mgs,lr)*(cx(mgs,lc) - ccwresv(mgs))* &
16916 & ((alpha(mgs,lc) + 2.)*xv(mgs,lc)**2/(alpha(mgs,lc) + 1.) + &
16917 & (alpha(mgs,lr) + 6.)*(alpha(mgs,lr) + 5.)*(alpha(mgs,lr) + 4.)*xv(mgs,lr)**2/ &
16918 & ((alpha(mgs,lr) + 3.)*(alpha(mgs,lr) + 2.)*(alpha(mgs,lr) + 1.)) )
16919 ENDIF ! imurain
16920 ENDIF
16921 ENDIF ! } rh
16922 ENDIF ! } dmrauto
16923 ENDIF ! ipconc
16924 ENDIF ! qc > qcmin & qr > qrmin
16925
16926! Rain self collection (cracr) and break-up (factor of ec0)
16927!
16928!
16929 ec0(mgs) = 2.e9
16930 IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN
16931 rwrad = 0.5*xdia(mgs,lr,3)
16932
16933
16934 ! check median volume diameter
16935 IF ( icracrthresh > 1 ) THEN
16936 IF ( imurain == 1 ) THEN
16937 tmp = (3.67+alpha(mgs,lr))*xdia(mgs,lr,1) ! median volume diameter; units of mm (Ulbrich 1983, JCAM)
16938 ELSE ! imurain == 3,
16939 tmp = (1.678+alpha(mgs,lr))**(1./3.)*xdia(mgs,lr,1) ! units of mm (using method of Ulbrich 1983. See ventillation_stuff.nb)
16940 ENDIF
16941 ELSE
16942 tmp = xdia(mgs,lr,3) - 0.1e-3
16943 ENDIF
16944
16945! IF ( xdia(mgs,lr,3) .gt. 2.0e-3 .or. icracr <= 0 ) THEN
16946 IF ( tmp .gt. 1.9e-3 .or. icracr <= 0 ) THEN
16947 ec0(mgs) = 0.0
16948 cracr(mgs) = 0.0
16949 ELSE
16950 IF ( dmrauto <= 0 .or. rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN
16951 IF ( xdia(mgs,lr,3) .lt. 6.1e-4 ) THEN
16952 ec0(mgs) = 1.0
16953 ELSE
16954 ec0(mgs) = exp(-50.0*(50.0*(xdia(mgs,lr,3) - 6.0e-4)))
16955 ENDIF
16956
16957
16958 IF ( rwrad .ge. 50.e-6 ) THEN
16959 cracr(mgs) = ec0(mgs)*aa2*cx(mgs,lr)**2*xv(mgs,lr)
16960 ELSE
16961 IF ( imurain == 3 ) THEN
16962 cracr(mgs) = ec0(mgs)*aa1*(cx(mgs,lr)*xv(mgs,lr))**2* &
16963 & (alpha(mgs,lr) + 2.)/(alpha(mgs,lr) + 1.)
16964 ELSE ! imurain == 1
16965 cracr(mgs) = ec0(mgs)*aa1*(cx(mgs,lr)*xv(mgs,lr))**2* &
16966 & (alpha(mgs,lr) + 6.)*(alpha(mgs,lr) + 5.)*(alpha(mgs,lr) + 4.)/ &
16967 & ((alpha(mgs,lr) + 3.)*(alpha(mgs,lr) + 2.)*(alpha(mgs,lr) + 1.))
16968
16969 ENDIF
16970 ENDIF
16971! cracr(mgs) = Min(cracr(mgs),crmxd(mgs))
16972 ENDIF
16973 ENDIF
16974 ENDIF
16975
16976! cracw(mgs) = min(cracw(mgs),cxmxd(mgs,lc))
16977 end do
16978 end if
16979
16980!
16981!
16982!
16983! Graupel
16984!
16985 if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22ii'
16986 chacw(:) = 0.0
16987 if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then
16988 do mgs = 1,ngscnt
16989
16990 IF ( ipconc .ge. 5 ) THEN
16991 IF ( qhacw(mgs) .gt. 0.0 .and. xmas(mgs,lc) .gt. 0.0 ) THEN
16992
16993! This is the explict version of chacw, which turns out to be very close to the
16994! approximation that the droplet size does not change, to within a few percent.
16995! This may _not_ be the case for cnu other than zero!
16996! chacw(mgs) = (ehw(mgs)*cx(mgs,lc)*cx(mgs,lh)*(pi/4.)*
16997! : abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1))*
16998! : (2.0*xdia(mgs,lh,1)*(xdia(mgs,lh,1) +
16999! : xdia(mgs,lc,1)*gf43rds) +
17000! : xdia(mgs,lc,2)*gf53rds))
17001
17002! chacw(mgs) = Min( chacw(mgs), 0.6*cx(mgs,lc)*dtpinv )
17003
17004! chacw(mgs) = qhacw(mgs)*rho0(mgs)/xmas(mgs,lc)
17005 chacw(mgs) = qhacw(mgs)*rho0(mgs)/xmascw(mgs)
17006! chacw(mgs) = min(chacw(mgs),cxmxd(mgs,lc))
17007 chacw(mgs) = min( chacw(mgs), 0.5*(cx(mgs,lc) - ccwresv(mgs))*dtpinv )
17008 ELSE
17009 qhacw(mgs) = 0.0
17010 ENDIF
17011 ELSE
17012 ! single-moment
17013 chacw(mgs) = &
17014 & ((0.25)*pi)*ehw(mgs)*cx(mgs,lc)*cx(mgs,lh) &
17015 & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1)) &
17016 & *( gf1*xdia(mgs,lc,2) &
17017 & + 2.0*gf2*xdia(mgs,lc,1)*xdia(mgs,lh,1) &
17018 & + gf3*xdia(mgs,lh,2) )
17019 chacw(mgs) = min(chacw(mgs),0.5*cx(mgs,lc)*dtpinv)
17020! chacw(mgs) = min(chacw(mgs),cxmxd(mgs,lc))
17021! chacw(mgs) = min(chacw(mgs),ccmxd(mgs))
17022 ENDIF
17023 end do
17024 end if
17025!
17026 if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22kk'
17027 chaci(:) = 0.0
17028 chaci0(:) = 0.0
17029 if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then
17030 do mgs = 1,ngscnt
17031 IF ( ehi(mgs) .gt. 0.0 .or. ( ehiclsn(mgs) > 0.0 .and. ipelec > 0 )) THEN
17032 IF ( ipconc .ge. 5 ) THEN
17033
17034 vt = sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,li,1))**2 + &
17035 & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,li,1) )
17036
17037 chaci0(mgs) = 0.25*pi*ehiclsn(mgs)*cx(mgs,lh)*cx(mgs,li)*vt* &
17038 & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + &
17039 & dab0lh(mgs,lh,li)*xdia(mgs,lh,3)*xdia(mgs,li,3) + &
17040 & da0(li)*xdia(mgs,li,3)**2 )
17041
17042 ELSE
17043 chaci0(mgs) = &
17044 & ((0.25)*pi)*ehiclsn(mgs)*cx(mgs,li)*cx(mgs,lh) &
17045 & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,li,1)) &
17046 & *( gf1*xdia(mgs,li,2) &
17047 & + 2.0*gf2*xdia(mgs,li,1)*xdia(mgs,lh,1) &
17048 & + gf3*xdia(mgs,lh,2) )
17049 ENDIF
17050
17051 chaci(mgs) = min(ehi(mgs)*chaci0(mgs),cimxd(mgs))
17052 ENDIF
17053 end do
17054 end if
17055
17056
17057 chacis(:) = 0.0
17058 if ( lis > 1 .and. ipconc .ge. 5 .or. ipelec .ge. 1 ) then
17059 do mgs = 1,ngscnt
17060 IF ( ehis(mgs) .gt. 0.0 .or. ( ehisclsn(mgs) > 0.0 .and. ipelec > 0 )) THEN
17061
17062 vt = sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,lis,1))**2 + &
17063 & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,lis,1) )
17064
17065 chacis0(mgs) = 0.25*pi*ehisclsn(mgs)*cx(mgs,lh)*cx(mgs,lis)*vt* &
17066 & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + &
17067 & dab0lh(mgs,lh,lis)*xdia(mgs,lh,3)*xdia(mgs,lis,3) + &
17068 & da0(lis)*xdia(mgs,lis,3)**2 )
17069
17070
17071 chacis(mgs) = min(ehis(mgs)*chacis0(mgs),cxmxd(mgs,lis))
17072 ENDIF
17073 end do
17074 end if
17075!
17076!
17077 if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22nn'
17078 chacs(:) = 0.0
17079 chacs0(:) = 0.0
17080 if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then
17081 do mgs = 1,ngscnt
17082 IF ( ehs(mgs) .gt. 0 ) THEN
17083 IF ( ipconc .ge. 5 .or. ( ehsclsn(mgs) > 0.0 .and. ipelec > 0 ) ) THEN
17084
17085 vt = sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1))**2 + &
17086 & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,ls,1) )
17087
17088 chacs0(mgs) = 0.25*pi*ehsclsn(mgs)*cx(mgs,lh)*cx(mgs,ls)*vt* &
17089 & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + &
17090 & dab0lh(mgs,lh,ls)*xdia(mgs,lh,3)*xdia(mgs,ls,3) + &
17091 & da0(ls)*xdia(mgs,ls,3)**2 )
17092
17093 ELSE
17094 chacs0(mgs) = &
17095 & ((0.25)*pi)*ehsclsn(mgs)*cx(mgs,ls)*cx(mgs,lh) &
17096 & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1)) &
17097 & *( gf3*gf1*xdia(mgs,ls,2) &
17098 & + 2.0*gf2*gf2*xdia(mgs,ls,1)*xdia(mgs,lh,1) &
17099 & + gf1*gf3*xdia(mgs,lh,2) )
17100 ENDIF
17101 chacs(mgs) = min(ehs(mgs)*chacs0(mgs),csmxd(mgs))
17102 ENDIF
17103 end do
17104 end if
17105
17106
17107!
17108!
17109! Hail
17110!
17111 if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22ii'
17112 chlacw(:) = 0.0
17113 if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then
17114 do mgs = 1,ngscnt
17115
17116 IF ( lhl .gt. 1 .and. ipconc .ge. 5 ) THEN
17117 IF ( qhlacw(mgs) .gt. 0.0 .and. xmas(mgs,lc) .gt. 0.0 ) THEN
17118
17119! This is the explict version of chacw, which turns out to be very close to the
17120! approximation that the droplet size does not change, to within a few percent.
17121! This may _not_ be the case for cnu other than zero!
17122! chlacw(mgs) = (ehlw(mgs)*cx(mgs,lc)*cx(mgs,lhl)*(pi/4.)*
17123! : abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,lc,1))*
17124! : (2.0*xdia(mgs,lhl,1)*(xdia(mgs,lhl,1) +
17125! : xdia(mgs,lc,1)*gf43rds) +
17126! : xdia(mgs,lc,2)*gf53rds))
17127
17128! chlacw(mgs) = Min( chlacw(mgs), 0.6*cx(mgs,lc)*dtpinv )
17129
17130! chlacw(mgs) = qhlacw(mgs)*rho0(mgs)/xmas(mgs,lc)
17131 chlacw(mgs) = qhlacw(mgs)*rho0(mgs)/xmascw(mgs)
17132! chlacw(mgs) = min(chlacw(mgs),cxmxd(mgs,lc))
17133 chlacw(mgs) = min( chlacw(mgs), 0.5*cx(mgs,lc)*dtpinv )
17134 ELSE
17135 qhlacw(mgs) = 0.0
17136 ENDIF
17137! ELSE
17138! chlacw(mgs) =
17139! > ((0.25)*pi)*ehlw(mgs)*cx(mgs,lc)*cx(mgs,lhl)
17140! > *abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,lc,1))
17141! > *( gf1*xdia(mgs,lc,2)
17142! > + 2.0*gf2*xdia(mgs,lc,1)*xdia(mgs,lhl,1)
17143! > + gf3*xdia(mgs,lhl,2) )
17144! chlacw(mgs) = min(chlacw(mgs),0.5*cx(mgs,lc)*dtpinv)
17145! chlacw(mgs) = min(chlacw(mgs),cxmxd(mgs,lc))
17146! chlacw(mgs) = min(chlacw(mgs),ccmxd(mgs))
17147 ENDIF
17148 end do
17149 end if
17150!
17151 if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22kk'
17152 chlaci(:) = 0.0
17153 chlaci0(:) = 0.0
17154 if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then
17155 do mgs = 1,ngscnt
17156 IF ( lhl .gt. 1 .and. ( ehli(mgs) .gt. 0.0 .or. (ipelec > 0 .and. ehliclsn(mgs) > 0.0) ) ) THEN
17157 IF ( ipconc .ge. 5 ) THEN
17158
17159 vt = sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,li,1))**2 + &
17160 & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,li,1) )
17161
17162 chlaci0(mgs) = 0.25*pi*ehliclsn(mgs)*cx(mgs,lhl)*cx(mgs,li)*vt* &
17163 & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + &
17164 & dab0(lhl,li)*xdia(mgs,lhl,3)*xdia(mgs,li,3) + &
17165 & da0(li)*xdia(mgs,li,3)**2 )
17166
17167! ELSE
17168! chlaci(mgs) =
17169! > ((0.25)*pi)*ehli(mgs)*cx(mgs,li)*cx(mgs,lhl)
17170! > *abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,li,1))
17171! > *( gf1*xdia(mgs,li,2)
17172! > + 2.0*gf2*xdia(mgs,li,1)*xdia(mgs,lhl,1)
17173! > + gf3*xdia(mgs,lhl,2) )
17174 ENDIF
17175
17176 chlaci(mgs) = min(ehli(mgs)*chlaci0(mgs),cimxd(mgs))
17177 ENDIF
17178 end do
17179 end if
17180
17181
17182 IF ( lis > 1 .and. ipconc .ge. 5) THEN
17183
17184 if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22kk'
17185 chlacis(:) = 0.0
17186 chlacis0(:) = 0.0
17187 do mgs = 1,ngscnt
17188 IF ( lhl .gt. 1 .and. ( ehlis(mgs) .gt. 0.0 .or. (ipelec > 0 .and. ehlisclsn(mgs) > 0.0) ) ) THEN
17189
17190 vt = sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,lis,1))**2 + &
17191 & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,lis,1) )
17192
17193 chlacis0(mgs) = 0.25*pi*ehlisclsn(mgs)*cx(mgs,lhl)*cx(mgs,lis)*vt* &
17194 & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + &
17195 & dab0(lhl,lis)*xdia(mgs,lhl,3)*xdia(mgs,lis,3) + &
17196 & da0(lis)*xdia(mgs,lis,3)**2 )
17197
17198
17199 chlacis(mgs) = min(ehlis(mgs)*chlacis0(mgs),cxmxd(mgs,lis))
17200 ENDIF
17201 end do
17202 ENDIF
17203
17204!
17205!
17206 if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22jj'
17207 chlacs(:) = 0.0
17208 chlacs0(:) = 0.0
17209 if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then
17210 do mgs = 1,ngscnt
17211 IF ( lhl .gt. 1 .and. ( ehls(mgs) .gt. 0.0 .or. (ipelec > 0 .and. ehlsclsn(mgs) > 0.0) ) ) THEN
17212 IF ( ipconc .ge. 5 ) THEN
17213
17214 vt = sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,ls,1))**2 + &
17215 & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,ls,1) )
17216
17217 chlacs0(mgs) = 0.25*pi*ehlsclsn(mgs)*cx(mgs,lhl)*cx(mgs,ls)*vt* &
17218 & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + &
17219 & dab0(lhl,ls)*xdia(mgs,lhl,3)*xdia(mgs,ls,3) + &
17220 & da0(ls)*xdia(mgs,ls,3)**2 )
17221
17222! ELSE
17223! chlacs(mgs) =
17224! > ((0.25)*pi)*ehls(mgs)*cx(mgs,ls)*cx(mgs,lhl)
17225! > *abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,ls,1))
17226! > *( gf3*gf1*xdia(mgs,ls,2)
17227! > + 2.0*gf2*gf2*xdia(mgs,ls,1)*xdia(mgs,lhl,1)
17228! > + gf1*gf3*xdia(mgs,lhl,2) )
17229 ENDIF
17230 chlacs(mgs) = min(ehls(mgs)*chlacs0(mgs),csmxd(mgs))
17231 ENDIF
17232 end do
17233 end if
17234
17235!
17236! Ziegler (1985) autoconversion
17237!
17238!
17239 IF ( ipconc .ge. 2 ) THEN
17240 if (ndebug .gt. 0 ) write(0,*) 'conc 26a'
17241
17242 DO mgs = 1,ngscnt
17243 zrcnw(mgs) = 0.0
17244 qrcnw(mgs) = 0.0
17245 crcnw(mgs) = 0.0
17246 cautn(mgs) = 0.0
17247 ENDDO
17248
17249 IF ( dmrauto >= -1 ) THEN !{
17250 DO mgs = 1,ngscnt
17251! qracw(mgs) = 0.0
17252! cracw(mgs) = 0.0
17253 IF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 1000. .and. temg(mgs) .gt. tfrh+4.) THEN
17254 !( .and. w(igs(mgs),jgs,kgs(mgs)) > 5.0) THEN ! DTD: added w threshold for testing
17255 volb = xv(mgs,lc)*(1./(1.+alpha(mgs,lc)))**(1./2.)
17256 cautn(mgs) = min(ccmxd(mgs), &
17257 & ((alpha(mgs,lc)+2.)/(alpha(mgs,lc)+1.))*aa1*cx(mgs,lc)**2*xv(mgs,lc)**2)
17258 cautn(mgs) = max( 0.0d0, cautn(mgs) )
17259 IF ( rb(mgs) .le. 7.51d-6 .or. dmrauto == -1) THEN
17260 t2s = 1.d30
17261! cautn(mgs) = 0.0
17262 ELSE
17263! XL2P=2.7E-2*XNC*XVC*((1.E12*RB**3*RC)-0.4)
17264
17265! T2S=3.72E-3/(((1.E4*RB)-7.5)*XNC*XVC)
17266! t2s = 3.72E-3/(((1.e6*rb)-7.5)*cx(mgs,lc)*xv(mgs,lc))
17267! t2s = 3.72/(((1.e6*rb(mgs))-7.5)*rho0(mgs)*qx(mgs,lc))
17268 t2s = 3.72/(1.e6*(rb(mgs)-7.500d-6)*rho0(mgs)*qx(mgs,lc))
17269
17270 qrcnw(mgs) = max( 0.0d0, xl2p(mgs)/(t2s*rho0(mgs)) )
17271 crcnw(mgs) = max( 0.0d0, min(3.5e9*xl2p(mgs)/t2s,0.5*cautn(mgs)) )
17272
17273 IF ( dmrauto == 0 ) THEN
17274 IF ( qx(mgs,lr)*rho0(mgs) > 1.2*xl2p(mgs) .and. cx(mgs,lr) > cxmin ) THEN ! Cohard and Pinty (2000a) switch over from (18) to (19)
17275 crcnw(mgs) = cx(mgs,lr)/qx(mgs,lr)*qrcnw(mgs)
17276 ELSEIF ( ( dmropt == 1 .or. dmropt == 3 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN
17277 tmp = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr)
17278 crcnw(mgs) = min(tmp,crcnw(mgs) )
17279 ELSEIF ( ( dmropt == 4 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN
17280 tmp = crcnw(mgs)
17281 tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr)
17282 ! try mass-weighted average of old and new Dmr using converted qc mass
17283 crcnw(mgs) = (tmp*qrcnw(mgs)+tmp2*qx(mgs,lr))/(qrcnw(mgs)+qx(mgs,lr))
17284 ELSEIF ( ( dmropt == 5 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN
17285 tmp = crcnw(mgs)
17286 tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr)
17287 ! try mass-weighted average of old and new Dmr using full qc mass
17288 crcnw(mgs) = (tmp*qx(mgs,lc)+tmp2*qx(mgs,lr))/(qx(mgs,lc)+qx(mgs,lr))
17289 ELSEIF ( ( dmropt == 6 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN
17290 tmp = crcnw(mgs)
17291 tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr)
17292 ! try mass*diameter-weighted average of old and new Dmr (using full qc mass)
17293 crcnw(mgs) = (tmp*xdia(mgs,lc,3)*qx(mgs,lc)+tmp2*xdia(mgs,lr,3)*qx(mgs,lr))/(xdia(mgs,lc,3)*qx(mgs,lc)+xdia(mgs,lr,3)*qx(mgs,lr))
17294 ELSEIF ( ( dmropt == 7 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN
17295 tmp = crcnw(mgs)
17296 tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr)
17297 ! try diameter-weighted average of old and new Dmr
17298 crcnw(mgs) = (tmp*xdia(mgs,lc,3)+tmp2*xdia(mgs,lr,3))/(xdia(mgs,lc,3)+xdia(mgs,lr,3))
17299 ELSEIF ( ( dmropt == 8 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN
17300 tmp = crcnw(mgs)
17301 tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr)
17302 ! try sqrt(diameter)-weighted average of old and new Dmr
17303 crcnw(mgs) = (tmp*sqrt(xdia(mgs,lc,3))+tmp2*sqrt(xdia(mgs,lr,3)))/(sqrt(xdia(mgs,lc,3))+sqrt(xdia(mgs,lr,3)))
17304 ENDIF
17305 ELSEIF ( dmrauto == 1 .and. cx(mgs,lr) > cxmin) THEN
17306 IF ( qx(mgs,lr) > qxmin(lr) ) THEN
17307 tmp = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr)
17308 crcnw(mgs) = min(tmp,crcnw(mgs) )
17309 ENDIF
17310 ELSEIF ( dmrauto == 2 .and. cx(mgs,lr) > cxmin) THEN
17311 tmp = crcnw(mgs)
17312 tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr)
17313 ! try mass-weighted average of old and new Dmr
17314 crcnw(mgs) = (tmp*qrcnw(mgs)+tmp2*qx(mgs,lr))/(qrcnw(mgs)+qx(mgs,lr))
17315 ELSEIF ( dmrauto == 3 .and. cx(mgs,lr) > cxmin) THEN ! adapted from MY/CP code
17316 tmp = max( 2.d0*rh(mgs), dble( xdia(mgs,lr,3) ) )
17317 crcnw(mgs) = rho0(mgs)*qrcnw(mgs)/(pi/6.*1000.*tmp**3)
17318 ENDIF
17319
17320 IF ( crcnw(mgs) < 1.e-30 ) qrcnw(mgs) = 0.0
17321
17322 IF ( ipconc >= 6 ) THEN
17323 IF ( lzr > 1 .and. qrcnw(mgs) > 0.0 ) THEN
17324! vr = rho0(mgs)*qrcnw(mgs)/(1000.*crcnw(mgs))
17325! zrcnw(mgs) = 36.*(xnu(lr)+2.0)*crcnw(mgs)*vr**2/((xnu(lr)+1.0)*pi**2)
17326 ! DTD: If rain exists at a grid point already either use the alpha-preserving Z-rate eqn. (dmrauto == 1)
17327 ! or a mass-weighted average of the alpha-preserving Z-rate eqn. and the init. rate eqn. (dmrauto == 2)
17328 ! or the original initiation rate equation (dmrauto == 0). Not sure if this is the correct way to go but seems to work ok.
17329 IF (qx(mgs,lr) .gt. qxmin(lr) .and. ( dmrauto == 1 .or. dmrauto ==2 ) ) THEN
17330 tmp3 = qx(mgs,lr)/cx(mgs,lr)
17331 tmp4 = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2* &
17332 & ( 2.*tmp3 * qrcnw(mgs) - tmp3**2 * crcnw(mgs) )
17333 if (imurain == 3) then
17334 vr = rho0(mgs)*qrcnw(mgs)/(1000.)
17335 tmp3 = 36.*(xnu(lc)+2.0)*vr**2/(crcnw(mgs)*(xnu(lc)+1.0)*pi**2)
17336 else
17337 tmp3 = galpharaut*(6.*rho0(mgs)*qrcnw(mgs)/(pi*xdn0(lr)))**2/crcnw(mgs)
17338 endif
17339 IF ( dmrauto == 1 ) THEN ! Preserve alpha
17340 zrcnw(mgs) = tmp4
17341 ELSEIF ( dmrauto == 2 ) THEN ! Mass-weighted average
17342 zrcnw(mgs) = (tmp3*qrcnw(mgs)+tmp4*qx(mgs,lr))/(qrcnw(mgs)+qx(mgs,lr))
17343 ENDIF
17344 else ! original formulation
17345 IF ( imurain == 3 ) THEN
17346 vr = rho0(mgs)*qrcnw(mgs)/(1000.) ! crcnw(mgs) not divided here but is in next line, cancels one factor in the numerator
17347 zrcnw(mgs) = 36.*(xnu(lc)+2.0)*vr**2/(crcnw(mgs)*(xnu(lc)+1.0)*pi**2)
17348 ELSE ! rain in gamma of diameter
17349 IF ( dmropt <= 1 .or. dmropt >= 4 .or. ( qx(mgs,lr) < qxmin(lr) .and. cx(mgs,lr) < cxmin ) ) THEN
17350 zrcnw(mgs) = galpharaut*(6.*rho0(mgs)*qrcnw(mgs)/(pi*xdn0(lr)))**2/crcnw(mgs)
17351 ELSE
17352 tmp3 = qx(mgs,lr)/cx(mgs,lr)
17353 zrcnw(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2* &
17354 & ( 2.*tmp3 * qrcnw(mgs) - tmp3**2 * crcnw(mgs) )
17355 ENDIF
17356! vr = rho0(mgs)*qrcnw(mgs)/(1000.) ! crcnw(mgs) not divided here but is in next line, cancels one factor in the numerator
17357! zrcnw(mgs) = 36.*(xnu(lc)+2.0)*vr**2/(crcnw(mgs)*(xnu(lc)+1.0)*pi**2)
17358 ENDIF
17359 endif
17360! z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2)
17361 ENDIF
17362 ENDIF ! ipconc >= 6
17363! IF ( crcnw(mgs) .gt. cautn(mgs) .and. crcnw(mgs) .gt. 1.0 )
17364! : THEN
17365! write(0,*) 'crcnw,cautn ',crcnw(mgs)/cautn(mgs),
17366! : crcnw(mgs),cautn(mgs),igs(mgs),kgs(mgs),t2s,qx(mgs,lr)
17367! write(0,*) ' ',qx(mgs,lc),cx(mgs,lc),0.5e6*xdia(mgs,lc,1)
17368! write(0,*) ' ',rho0(mgs)*qrcnw(mgs)/crcnw(mgs),
17369! : 1.e6*(( 3/(4.*pi))*rho0(mgs)*qrcnw(mgs)/
17370! : (crcnw(mgs)*xdn(mgs,lr)))**(1./3.),rh(mgs)*1.e6,rwrad(mgs)
17371! ELSEIF ( crcnw(mgs) .gt. 1.0 .and. cautn(mgs) .gt. 0.) THEN
17372! write(0,*) 'crcnw,cautn ',crcnw(mgs)/cautn(mgs),
17373! : crcnw(mgs),cautn(mgs),igs(mgs),kgs(mgs),t2s
17374! write(0,*) ' ',rho0(mgs)*qrcnw(mgs)/crcnw(mgs),
17375! : 1.e6*(( 3*pi/4.)*rho0(mgs)*qrcnw(mgs)/
17376! : (crcnw(mgs)*xdn(mgs,lr)))**(1./3.)
17377! ENDIF
17378! crcnw(mgs) = Min(cautn(mgs),3.5e9*xl2p(mgs)/t2s)
17379
17380! IF ( qrcnw(mgs) .gt. 0.3e-2 ) THEN
17381! write(0,*) 'QRCNW'
17382! write(0,*) qrcnw(mgs),crcnw(mgs),cautn(mgs)
17383! write(0,*) xl2p,t2s,rho0(mgs),xv(mgs,lc),cx(mgs,lc),qx(mgs,lc)
17384! write(0,*) rb,0.5*xdia(mgs,lc,1),mgs,igs(mgs),kgs(mgs)
17385! ENDIF
17386! qrcnw(mgs) = Min(qrcnw(mgs),qcmxd(mgs))
17387 ENDIF
17388
17389
17390 ENDIF
17391 ENDDO
17392
17393 ENDIF !} dmrauto >= 0
17394
17395
17396
17397 ELSE
17398
17399!
17400! Berry 1968 auto conversion for rain (Orville & Kopp 1977)
17401!
17402!
17403 if ( ircnw .eq. 4 ) then
17404 do mgs = 1,ngscnt
17405! sconvmix(lcw,mgs) = 0.0
17406 qrcnw(mgs) = 0.0
17407 qdiff = max((qx(mgs,lc)-qminrncw),0.0)
17408 if ( qdiff .gt. 0.0 .and. xdia(mgs,lc,1) .gt. 20.0e-6 ) then
17409 argrcnw = &
17410 & ((1.2e-4)+(1.596e-12)*(cx(mgs,lc)*1.0e-6) &
17411 & /(cwdisp*qdiff*1.0e-3*rho0(mgs)))
17412 qrcnw(mgs) = (rho0(mgs)*1e-3)*(qdiff**2)/argrcnw
17413! sconvmix(lcw,mgs) = max(sconvmix(lcw,mgs),0.0)
17414 qrcnw(mgs) = (max(qrcnw(mgs),0.0))
17415 end if
17416 end do
17417
17418 ENDIF
17419!
17420!
17421!
17422! Berry 1968 auto conversion for rain (Ferrier 1994)
17423!
17424!
17425 if ( ircnw .eq. 5 ) then
17426 do mgs = 1,ngscnt
17427 qrcnw(mgs) = 0.0
17428 qrcnw(mgs) = 0.0
17429 qccrit = (pi/6.)*(cx(mgs,lc)*cwdiap**3)*xdn(mgs,lc)/rho0(mgs)
17430 qdiff = max((qx(mgs,lc)-qccrit),0.)
17431 if ( qdiff .gt. 0.0 .and. cx(mgs,lc) .gt. 1.0 ) then
17432 argrcnw = &
17433! > ((1.2e-4)+(1.596e-12)*cx(mgs,lc)/(cwdisp*rho0(mgs)*qdiff)) &
17434 & ((1.2e-4)+(1.596e-12)*cx(mgs,lc)*1.0e-3/(cwdisp*rho0(mgs)*qdiff))
17435 qrcnw(mgs) = &
17436! > timflg(mgs)*rho0(mgs)*(qdiff**2)/argrcnw &
17437 & 1.0e-3*rho0(mgs)*(qdiff**2)/argrcnw
17438 qrcnw(mgs) = min(qxmxd(mgs,lc), (max(qrcnw(mgs),0.0)) )
17439
17440! write(iunit,*) 'qrcnw,cx =',qrcnw(mgs),cx(mgs,lc),mgs,1.e3*qx(mgs,lc),cno(lr)
17441 end if
17442 end do
17443 end if
17444
17445!
17446!
17447! kessler auto conversion for rain.
17448!
17449 if ( ircnw .eq. 2 ) then
17450 do mgs = 1,ngscnt
17451 qrcnw(mgs) = 0.0
17452 qrcnw(mgs) = (0.001)*max((qx(mgs,lc)-qminrncw),0.0)
17453 end do
17454 end if
17455!
17456! c4 = pi/6
17457! c1 = 0.12-0.32 for colorado storms...typically 0.3-0.4
17458! berry reinhart type conversion (proctor 1988)
17459!
17460 if ( ircnw .eq. 1 ) then
17461 do mgs = 1,ngscnt
17462 qrcnw(mgs) = 0.0
17463 c1 = 0.2
17464 c4 = pi/(6.0)
17465 bradp = &
17466 & (1.e+06) * ((c1/(0.38))**(1./3.)) * (xdia(mgs,lc,1)*(0.5))
17467 bl2 = &
17468 & (0.027) * ((100.0)*(bradp**3)*(xdia(mgs,lc,1)*(0.5)) - (0.4))
17469 bt2 = (bradp -7.5) / (3.72)
17470 qrcnw(mgs) = 0.0
17471 if ( bl2 .gt. 0.0 .and. bt2 .gt. 0.0 ) then
17472 qrcnw(mgs) = bl2 * bt2 * rho0(mgs) &
17473 & * qx(mgs,lc) * qx(mgs,lc)
17474 end if
17475 end do
17476 end if
17477
17478
17479
17480 ENDIF ! ( ipconc .ge. 2 )
17481
17482!
17483!
17484!
17485! Bigg Freezing of Rain
17486!
17487 if (ndebug .gt. 0 ) write(0,*) 'conc 27a'
17488 qrfrz(:) = 0.0
17489 qrfrzs(:) = 0.0
17490 qrfrzf(:) = 0.0
17491 vrfrzf(:) = 0.0
17492 crfrz(:) = 0.0
17493 crfrzs(:) = 0.0
17494 crfrzf(:) = 0.0
17495 zrfrz(:) = 0.0
17496 zrfrzs(:) = 0.0
17497 zrfrzf(:) = 0.0
17498 qwcnr(:) = 0.0
17499
17500 IF ( .not. ( ipconc == 0 .and. lwsm6 ) ) THEN
17501
17502 do mgs = 1,ngscnt
17503 if ( qx(mgs,lr) .gt. qxmin(lr) .and. temcg(mgs) .lt. -5. .and. ibiggopt > 0 ) then
17504! brz = 100.0
17505! arz = 0.66
17506 IF ( ipconc .lt. 3 ) THEN
17507 qrfrz(mgs) = &
17508 & min( &
17509 & (20.0)*(pi**2)*brz*(xdn(mgs,lr)/rho0(mgs)) &
17510 & *cx(mgs,lr)*(xdia(mgs,lr,1)**6) &
17511 & *(exp(max(-arz*temcg(mgs), 0.0))-1.0) &
17512 & , qrmxd(mgs))
17513 qrfrzf(mgs) = qrfrz(mgs)
17514
17515! ELSEIF ( ipconc .ge. 3 .and. xv(mgs,lr) .gt. 1.1*xvmn(lr) ) THEN
17516 ELSEIF ( ipconc .ge. 3 ) THEN
17517! tmp = brz*cx(mgs,lr)*(Exp(Max( -arz*temcg(mgs), 0.0 )) - 1.0)
17518! crfrz(mgs) = xv(mgs,lr)*tmp
17519
17520 frach = 1.0d0
17521
17522! IF ( ibiggopt == 2 .and. imurain == 1 .and. lzr < 1 ) THEN ! lzr check because results are weird for 3-moment
17523 IF ( ibiggopt == 2 .and. imurain == 1 ) THEN !
17524 ! integrate from Bigg diameter (for given supercooling Ts) to infinity
17525
17526 volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 ! Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 (Proc. Phys. Soc. London)
17527 ! for mean temperature for freezing: -ln (V) = a*Ts - b, where a = 6.9/6.8, or approx a = 1.0, and b = 16.2
17528 ! volt is given in cm**3, so convert to m**3
17529 dbigg = (6./pi* volt )**(1./3.)
17530
17531 ! perhaps should also test that W > V_t_dbigg, i.e., that drops the size of dbigg are being lifted and cooled.
17532 IF ( dbigg < 8.e-3 ) THEN !{ only bother if freezing diameter is reasonable
17533
17534 ratio = min(maxratiolu, dbigg/xdia(mgs,lr,1) )
17535
17536 i = min(nqiacrratio,int(ratio*dqiacrratioinv))
17537 IF ( alp0flag ) THEN
17538 j = int(max(0.0,min(15.,alpha(mgs,lr)))*dqiacralphainv)
17539 ELSE
17540 j = int(max(minalphalu,min(maxalphalu,alpha(mgs,lr)))*dqiacralphainv)
17541 ENDIF
17542 delx = ratio - float(i)*dqiacrratio
17543 dely = alpha(mgs,lr) - float(j)*dqiacralpha
17544 ip1 = min( i+1, nqiacrratio )
17545 jp1 = min( j+1, nqiacralpha )
17546
17547 ! interpolate along x, i.e., ratio;
17548 tmp1 = ciacrratio(i,j) + delx*dqiacrratioinv*(ciacrratio(ip1,j) - ciacrratio(i,j))
17549 tmp2 = ciacrratio(i,jp1) + delx*dqiacrratioinv*(ciacrratio(ip1,jp1) - ciacrratio(i,jp1))
17550
17551 ! interpolate along alpha;
17552
17553 crfrz(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*cx(mgs,lr)*dtpinv
17554 crfrzf(mgs) = crfrz(mgs)
17555 ! interpolate along x, i.e., ratio;
17556 tmp1 = qiacrratio(i,j) + delx*dqiacrratioinv*(qiacrratio(ip1,j) - qiacrratio(i,j))
17557 tmp2 = qiacrratio(i,jp1) + delx*dqiacrratioinv*(qiacrratio(ip1,jp1) - qiacrratio(i,jp1))
17558
17559 ! interpolate along alpha;
17560
17561 qrfrz(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*qx(mgs,lr)*dtpinv
17562 qrfrzf(mgs) = qrfrz(mgs)
17563
17564 IF ( qrfrz(mgs)*dtp < qxmin(lh) .or. crfrz(mgs)*dtp < cxmin ) THEN
17565
17566 crfrz(mgs) = 0.0
17567 qrfrz(mgs) = 0.0
17568 qrfrzf(mgs) = 0.0
17569
17570 ELSE !{
17571
17572
17573 IF ( ipconc >= 6 .and. lzr > 1 ) THEN
17574 ! interpolate along x, i.e., ratio;
17575 tmp1 = ziacrratio(i,j) + delx*dqiacrratioinv*(ziacrratio(ip1,j) - ziacrratio(i,j))
17576 tmp2 = ziacrratio(i,jp1) + delx*dqiacrratioinv*(ziacrratio(ip1,jp1) - ziacrratio(i,jp1))
17577
17578 ! interpolate along alpha;
17579
17580 zrfrz(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*zx(mgs,lr)*dtpinv
17581 ENDIF
17582
17583 IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < 2.*xvmn(lr) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN
17584! IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < xvbiggsnow .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN
17585 ! rain drops are so small that they cannot be pushed smaller, so put into snow (or cloud ice, depending on ifrzs)
17586 crfrzf(mgs) = 0.0
17587 qrfrzf(mgs) = 0.0
17588 crfrzs(mgs) = crfrz(mgs)
17589 qrfrzs(mgs) = qrfrz(mgs)
17590
17591 IF ( ipconc >= 6 .and. lzr > 1 ) THEN
17592 zrfrzs(mgs) = zrfrz(mgs)
17593 zrfrzf(mgs) = 0.
17594 ENDIF
17595 ELSEIF ( dbigg < max( biggsnowdiam, max(dfrz,dhmn)) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN ! { convert some to snow or ice crystals
17596 ! temporarily store qrfrz and crfrz in snow terms and caclulate new crfrzf, qrfrzf, and zrfrzf. Leave crfrz etc. alone!
17597
17598 crfrzs(mgs) = crfrz(mgs)
17599 qrfrzs(mgs) = qrfrz(mgs)
17600
17601 IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < 1.2*xvmn(lr) ) THEN
17602 ! rain drops are so small that they cannot be pushed smaller, so put into snow (or cloud ice, depending on ifrzs)
17603 crfrzf(mgs) = 0.0
17604 qrfrzf(mgs) = 0.0
17605
17606 IF (ipconc >= 6 .and. lzr > 1 ) THEN
17607 zrfrzs(mgs) = zrfrz(mgs)
17608 zrfrzf(mgs) = 0.
17609 ENDIF
17610 ELSE !{
17611
17612 ! recalculate using dhmn for ratio
17613 ratio = min( maxratiolu, max(dfrz,dhmn)/xdia(mgs,lr,1) )
17614
17615 i = min(nqiacrratio,int(ratio*dqiacrratioinv))
17616! j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))*dqiacralphainv)
17617! j = Int(Max(alphamin,Min(alphamax,alpha(mgs,lr)))*dqiacralphainv)
17618 IF ( alp0flag ) THEN
17619 j = int(max(0.0,min(15.,alpha(mgs,lr)))*dqiacralphainv)
17620 ELSE
17621 j = int(max(minalphalu,min(maxalphalu,alpha(mgs,lr)))*dqiacralphainv)
17622 ENDIF
17623 delx = ratio - float(i)*dqiacrratio
17624 dely = alpha(mgs,lr) - float(j)*dqiacralpha
17625 ip1 = min( i+1, nqiacrratio )
17626 jp1 = min( j+1, nqiacralpha )
17627
17628 ! interpolate along x, i.e., ratio;
17629 tmp1 = ciacrratio(i,j) + delx*dqiacrratioinv*(ciacrratio(ip1,j) - ciacrratio(i,j))
17630 tmp2 = ciacrratio(i,jp1) + delx*dqiacrratioinv*(ciacrratio(ip1,jp1) - ciacrratio(i,jp1))
17631
17632
17633 ! interpolate along alpha;
17634
17635 crfrzf(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*cx(mgs,lr)*dtpinv
17636
17637 ! interpolate along x, i.e., ratio;
17638 tmp1 = qiacrratio(i,j) + delx*dqiacrratioinv*(qiacrratio(ip1,j) - qiacrratio(i,j))
17639 tmp2 = qiacrratio(i,jp1) + delx*dqiacrratioinv*(qiacrratio(ip1,jp1) - qiacrratio(i,jp1))
17640
17641 ! interpolate along alpha;
17642
17643 qrfrzf(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*qx(mgs,lr)*dtpinv
17644
17645 ! now subtract off the difference
17646 crfrzs(mgs) = crfrzs(mgs) - crfrzf(mgs)
17647 qrfrzs(mgs) = qrfrzs(mgs) - qrfrzf(mgs)
17648
17649 IF ( ipconc >= 6 .and. lzr > 1 ) THEN
17650 zrfrzs(mgs) = zrfrz(mgs)
17651 ! interpolate along x, i.e., ratio;
17652 tmp1 = ziacrratio(i,j) + delx*dqiacrratioinv*(ziacrratio(ip1,j) - ziacrratio(i,j))
17653 tmp2 = ziacrratio(i,jp1) + delx*dqiacrratioinv*(ziacrratio(ip1,jp1) - ziacrratio(i,jp1))
17654
17655 ! interpolate along alpha;
17656
17657 zrfrzf(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*zx(mgs,lr)*dtpinv
17658 zrfrzs(mgs) = zrfrzs(mgs) - zrfrzf(mgs)
17659 zrfrzf(mgs) = (1000./900.)**2*zrfrzf(mgs)
17660 ENDIF
17661 ENDIF ! }
17662 ELSE
17663 crfrzs(mgs) = 0.0
17664 qrfrzs(mgs) = 0.0
17665 zrfrzs(mgs) = 0.0
17666 ENDIF ! }
17667
17668 ENDIF !}
17669
17670 IF ( (qrfrz(mgs))*dtp > qx(mgs,lr) ) THEN
17671 fac = ( qrfrz(mgs) )*dtp/qx(mgs,lr)
17672 qrfrz(mgs) = fac*qrfrz(mgs)
17673 qrfrzs(mgs) = fac*qrfrzs(mgs)
17674 qrfrzf(mgs) = fac*qrfrzf(mgs)
17675 crfrz(mgs) = fac*crfrz(mgs)
17676 crfrzs(mgs) = fac*crfrzs(mgs)
17677 crfrzf(mgs) = fac*crfrzf(mgs)
17678 IF ( ipconc >= 6 .and. lzr > 1 ) THEN
17679 zrfrz(mgs) = fac*zrfrz(mgs)
17680 zrfrzf(mgs) = fac*zrfrzf(mgs)
17681 ENDIF
17682 ENDIF
17683
17684 ENDIF !}
17685
17686! IF ( (crfrzs(mgs) + crfrz(mgs))*dtp > cx(mgs,lr) ) THEN
17687! fac = ( crfrzs(mgs) + crfrz(mgs) )*dtp/cx(mgs,lr)
17688! crfrz(mgs) = fac*crfrz(mgs)
17689! crfrzs(mgs) = fac*crfrzs(mgs)
17690! ENDIF
17691
17692! qrfrzf(mgs) = qrfrz(mgs)
17693! crfrzf(mgs) = crfrz(mgs)
17694
17695 ! qrfrz(mgs) = qrfrzf(mgs) + qrfrzs(mgs)
17696 ! crfrz(mgs) = crfrzf(mgs) + crfrzs(mgs)
17697
17698
17699 ELSEIF ( ibiggopt == 1 ) THEN
17700 ! Z85, eq. A34
17701 tmp = xv(mgs,lr)*brz*cx(mgs,lr)*(exp(max( -arz*temcg(mgs), 0.0 )) - 1.0)
17702 IF ( .false. .and. tmp .gt. cxmxd(mgs,lr) ) THEN ! {
17703! write(iunit,*) 'Bigg Freezing problem!',mgs,igs(mgs),kgs(mgs)
17704! write(iunit,*) 'tmp, cx(lr), xv = ',tmp, cx(mgs,lr), xv(mgs,lr), (Exp(Max( -arz*temcg(mgs), 0.0 )) - 1.0)
17705! write(iunit,*) 'qr,temcg = ',qx(mgs,lr)*1000.,temcg(mgs)
17706 crfrz(mgs) = cxmxd(mgs,lr) ! cx(mgs,lr)*dtpinv
17707 qrfrz(mgs) = qxmxd(mgs,lr) ! qx(mgs,lr)*dtpinv
17708! STOP
17709 ELSE ! } {
17710 crfrz(mgs) = tmp
17711 ! crfrzfmx = cx(mgs,lr)*Exp(-4./3.*pi*(40.e-6)**3/xv(mgs,lr))
17712 ! IF ( crfrz(mgs) .gt. crfrzmx ) THEN
17713 ! crfrz(mgs) = crfrzmx
17714 ! qrfrz(mgs) = bfnu*xmas(mgs,lr)*rhoinv(mgs)*crfrzmx
17715 ! qwcnr(mgs) = cx(mgs,lr) - crfrzmx
17716 ! ELSE
17717 IF ( lzr < 1 ) THEN
17718 IF ( imurain == 3 ) THEN
17719 bfnu = bfnu0
17720 ELSE !imurain == 1
17721 bfnu = bfnu1
17722 ENDIF
17723 ELSE
17724 ! bfnu = 1.0 ! (alpha(mgs,lr)+2.0)/(alpha(mgs,lr)+1.)
17725 IF ( imurain == 3 ) THEN
17726 bfnu = (alpha(mgs,lr)+2.0)/(alpha(mgs,lr)+1.)
17727 ELSE !imurain == 1
17728! bfnu = bfnu1
17729 bfnu = (4. + alpha(mgs,lr))*(5. + alpha(mgs,lr))*(6. + alpha(mgs,lr))/ &
17730 & ((1. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(3. + alpha(mgs,lr)))
17731! bfnu = 1.
17732 ENDIF
17733 ENDIF
17734 qrfrz(mgs) = bfnu*xmas(mgs,lr)*rhoinv(mgs)*crfrz(mgs)
17735
17736 qrfrz(mgs) = min( qrfrz(mgs), 1.*qx(mgs,lr)*dtpinv ) ! qxmxd(mgs,lr)
17737 crfrz(mgs) = min( crfrz(mgs), 1.*cx(mgs,lr)*dtpinv ) !cxmxd(mgs,lr)
17738 qrfrz(mgs) = min( qrfrz(mgs), qx(mgs,lr) )
17739 qrfrzf(mgs) = qrfrz(mgs)
17740 ENDIF !}
17741
17742
17743
17744
17745 IF ( crfrz(mgs) .gt. qxmin(lh) ) THEN !{ Yes, it compares cx and qxmin, but this is just to be sure that
17746 ! crfrz is greater than zero in the division
17747! IF ( xdia(mgs,lr,1) .lt. 200.e-6 ) THEN
17748! IF ( xv(mgs,lr) .lt. xvmn(lh) ) THEN
17749
17750 IF ( (ibiggsnow == 1 .or. ibiggsnow == 3 ) .and. ibiggopt /= 2 ) THEN
17751 xvfrz = rho0(mgs)*qrfrz(mgs)/(crfrz(mgs)*900.) ! mean volume of frozen drops; 900. for frozen drop density
17752 frach = 0.5 *(1. + tanh(0.2e12 *( xvfrz - 1.15*xvmn(lh))))
17753
17754 qrfrzs(mgs) = (1.-frach)*qrfrz(mgs)
17755 crfrzs(mgs) = (1.-frach)*crfrz(mgs) ! *rzxh(mgs)
17756! qrfrzf(mgs) = frach*qrfrz(mgs)
17757
17758 ENDIF
17759
17760 IF ( ipconc .ge. 14 .and. 1.e-3*rho0(mgs)*qrfrz(mgs)/crfrz(mgs) .lt. xvmn(lh) ) THEN
17761 qrfrzs(mgs) = qrfrz(mgs)
17762 crfrzs(mgs) = crfrz(mgs) ! *rzxh(mgs)
17763 ELSE
17764! crfrz(mgs) = Min( crfrz(mgs), 0.1*cx(mgs,lr)*dtpinv ) ! cxmxd(mgs,lr)
17765! qrfrz(mgs) = Min( qrfrz(mgs), 0.1*qx(mgs,lr)*dtpinv ) ! qxmxd(mgs,lr)
17766 qrfrzf(mgs) = frach*qrfrz(mgs)
17767! crfrzf(mgs) = Min( qrfrz(mgs)*rho0(mgs)/(xdn(mgs,lh)*vgra), crfrz(mgs) )
17768 IF ( ibfr .le. 1 ) THEN
17769 crfrzf(mgs) = frach*min(crfrz(mgs), qrfrz(mgs)/(bfnu*1.0*vr1mm*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs)
17770 ELSEIF ( ibfr .eq. 5 ) THEN
17771 crfrzf(mgs) = frach*min(crfrz(mgs), qrfrz(mgs)/(bfnu*vfrz*1000.0)*rho0(mgs) )*rzxh(mgs) !*crfrz(mgs)
17772 ELSEIF ( ibfr .eq. 2 ) THEN
17773 crfrzf(mgs) = frach*min(crfrz(mgs), qrfrz(mgs)/(bfnu*vfrz*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs)
17774 ELSEIF ( ibfr .eq. 6 ) THEN
17775 crfrzf(mgs) = frach*max(crfrz(mgs), qrfrz(mgs)/(bfnu*9.*xv(mgs,lr)*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs)
17776 ELSE
17777 crfrzf(mgs) = frach*crfrz(mgs)
17778 ENDIF
17779! crfrzf(mgs) = Min(crfrz(mgs), qrfrz(mgs)/(bfnu*xvmn(lh)*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs)
17780! IF ( lz(lr) > 1 .and. lz(lh) > 1 ) THEN
17781! crfrzf(mgs) = crfrz(mgs)
17782! ENDIF
17783
17784 ENDIF
17785! crfrz(mgs) = Min( cxmxd(mgs,lr), rho0(mgs)*qrfrz(mgs)/xmas(mgs,lr) )
17786 ELSE
17787 crfrz(mgs) = 0.0
17788 qrfrz(mgs) = 0.0
17789 ENDIF !}
17790
17791 ENDIF ! ibiggopt
17792
17793 IF ( lvol(lh) .gt. 1 ) THEN
17794 vrfrzf(mgs) = rho0(mgs)*qrfrzf(mgs)/rhofrz
17795 ENDIF
17796
17797
17798 IF ( nsplinter .ne. 0 ) THEN
17799 IF ( nsplinter .ge. 1000 ) THEN
17800 ! Lawson et al. 2015 JAS
17801 ! ave. diam of freezing drops in microns
17802 tmp = 0
17803 IF ( qrfrz(mgs)*dtp > qxmin(lh) .and. crfrz(mgs) > 1.e-3 ) THEN
17804 tmpdiam = 1.e6*( 6.*qrfrz(mgs)/(1000.*pi*crfrz(mgs) ))**(1./3.) ! avg. diameter of newly frozen drops in microns
17805 tmp = lawson_splinter_fac*tmpdiam**4*crfrz(mgs)
17806 ENDIF
17807 ELSEIF ( nsplinter .gt. 0 ) THEN
17808 tmp = nsplinter*crfrz(mgs)
17809 ELSE
17810 tmp = -nsplinter*crfrzf(mgs)
17811 ENDIF
17812 csplinter2(mgs) = tmp
17813 qsplinter2(mgs) = min(0.1*qrfrz(mgs), tmp*splintermass/rho0(mgs) ) ! makes splinters smaller if too much mass is taken from graupel
17814
17815! csplinter(mgs) = csplinter(mgs) + tmp
17816! qsplinter(mgs) = qsplinter(mgs) + Min(0.1*qrfrz(mgs), tmp*splintermass/rho0(mgs) ) ! makes splinters smaller if too much mass is taken from graupel
17817 ENDIF
17818! IF ( temcg(mgs) .lt. -31.0 ) THEN
17819! qrfrz(mgs) = qx(mgs,lr)*dtpinv + qrcnw(mgs)
17820! qrfrzf(mgs) = qrfrz(mgs)
17821! crfrz(mgs) = cx(mgs,lr)*dtpinv + crcnw(mgs)
17822! crfrzf(mgs) = Min(crfrz(mgs), qrfrz(mgs)/(bfnu*1.0*vr1mm*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs)
17823! ENDIF
17824! qrfrz(mgs) = 6.0*xdn(mgs,lr)*xv(mgs,lr)**2*tmp*rhoinv(mgs)
17825! qrfrz(mgs) = Min( qrfrz(mgs), ffrz*qrmxd(mgs) )
17826! crfrz(mgs) = Min( crmxd(mgs), ffrz*crfrz(mgs))
17827! crfrz(mgs) = Min(crmxd(mgs),qrfrz(mgs)*rho0(mgs)/xmas(mgs,lr))
17828 ENDIF
17829! if ( temg(mgs) .gt. 268.15 ) then
17830 else
17831! end if
17832 end if
17833 end do
17834
17835 ENDIF
17836!
17837! Homogeneous freezing of cloud drops to ice crystals
17838! following Bigg (1953) and Ferrier (1994).
17839!
17840 if (ndebug .gt. 0 ) write(0,*) 'conc 25b'
17841 do mgs = 1,ngscnt
17842 qwfrz(mgs) = 0.0
17843 cwfrz(mgs) = 0.0
17844 qwfrzc(mgs) = 0.0
17845 cwfrzc(mgs) = 0.0
17846 qwfrzp(mgs) = 0.0
17847 cwfrzp(mgs) = 0.0
17848 IF ( ibfc .ge. 1 .and. ibfc /= 3 .and. temg(mgs) < 268.15 ) THEN
17849! if ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 1. .and. &
17850! & .not. (ipconc .ge. 2 .and. xdia(mgs,lc,1) .lt. 10.e-6) ) then
17851 if ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. cxmin ) THEN
17852 IF ( ipconc < 2 ) THEN
17853 qwfrz(mgs) = ((2.0)*(brz)/(xdn(mgs,lc)*cx(mgs,lc))) &
17854 & *(exp(max(-arz*temcg(mgs), 0.0))-1.0) &
17855 & *rho0(mgs)*(qx(mgs,lc)**2)
17856 qwfrz(mgs) = max(qwfrz(mgs), 0.0)
17857 qwfrz(mgs) = min(qwfrz(mgs),qcmxd(mgs))
17858 cwfrz(mgs) = qwfrz(mgs)*rho0(mgs)/xmas(mgs,li)
17859 ELSEIF ( ipconc .ge. 2 ) THEN
17860 IF ( xdia(mgs,lc,3) > 0.e-6 ) THEN
17861 volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 ! Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953
17862 ! for mean temperature for freezing: -ln (V) = a*Ts - b
17863 ! volt is given in cm**3, so factor of 1.e-6 to convert to m**3
17864! dbigg = (6./pi* volt )**(1./3.)
17865
17866 IF ( alpha(mgs,lc) == 0.0 ) THEN
17867 cwfrz(mgs) = cx(mgs,lc)*exp(-volt/xv(mgs,lc))*dtpinv ! number of droplets with volume greater than volt
17868!turn off limit so that all can freeze at low temp
17869!!! cwfrz(mgs) = Min(cwfrz(mgs),ccmxd(mgs))
17870
17871 qwfrz(mgs) = cwfrz(mgs)*xdn0(lc)*rhoinv(mgs)*(volt + xv(mgs,lc))
17872 ELSE
17873 ratio = (1. + alpha(mgs,lc))*volt/xv(mgs,lc)
17874
17875 IF ( .false. .and. usegamxinfcnu ) THEN
17876 i = nint(dgami*(1. + alpha(mgs,lc)))
17877 gcnup1 = gmoi(i)
17878 i = nint(dgami*(2. + alpha(mgs,lc)))
17879 gcnup2 = gmoi(i)
17880
17881 cwfrz(mgs) = cx(mgs,lc)*gamxinf(1.+alpha(mgs,lc), ratio)/(dtp*gcnup1) ! gamxinflu(i,j,1,1)
17882
17883 qwfrz(mgs) = cx(mgs,lc)*xdn0(lc)*xv(mgs,lc)*rhoinv(mgs)*gamxinf(2.+alpha(mgs,lc), ratio)/(dtp*gcnup2) ! gamxinflu(i,j,12,1)
17884
17885 ELSE
17886
17887 ratio = min( maxratiolu, ratio )
17888! write(0,*) 'cwfrz: temp,ratio = ',temcg(mgs),ratio
17889! write(0,*) 'cwfrz: xv,volt,qx = ',xv(mgs,lc),volt,qx(mgs,lc)
17890! write(0,*) 'cwfrz: i,j,k = ',igs(mgs),jgs,kgs(mgs)
17891 tmp = gaminterp(ratio,alpha(mgs,lc),1,1)
17892! write(0,*) 'cwfrz: tmp1 = ',tmp
17893 cwfrz(mgs) = cx(mgs,lc)*tmp*dtpinv ! Gamxinf(1.+alpha(mgs,lc), ratio)/(dtp*gcnup1) ! gamxinflu(i,j,1,1)
17894
17895 tmp = gaminterp(ratio,alpha(mgs,lc),12,1)
17896! write(0,*) 'cwfrz: tmp2 = ',tmp
17897 qwfrz(mgs) = cx(mgs,lc)*xdn0(lc)*xv(mgs,lc)*rhoinv(mgs)*dtpinv*tmp ! Gamxinf(2.+alpha(mgs,lc), ratio)/(dtp*gcnup2) ! gamxinflu(i,j,12,1)
17898
17899 ENDIF
17900
17901 ENDIF
17902
17903 ENDIF
17904 ENDIF
17905 if ( temg(mgs) .gt. 268.15 ) then
17906 qwfrz(mgs) = 0.0
17907 cwfrz(mgs) = 0.0
17908 end if
17909 end if
17910 ENDIF
17911!
17912 if ( xplate(mgs) .eq. 1 ) then
17913 qwfrzp(mgs) = qwfrz(mgs)
17914 cwfrzp(mgs) = cwfrz(mgs)
17915 end if
17916!
17917 if ( xcolmn(mgs) .eq. 1 ) then
17918 qwfrzc(mgs) = qwfrz(mgs)
17919 cwfrzc(mgs) = cwfrz(mgs)
17920 end if
17921
17922!
17923! qwfrzp(mgs) = 0.0
17924! qwfrzc(mgs) = qwfrz(mgs)
17925!
17926 end do
17927!
17928!
17929! Contact freezing nucleation: factor is to convert from L-1
17930! T < -2C: via Meyers et al. JAM July, 1992 (31, 708-721)
17931!
17932 if (ndebug .gt. 0 ) write(0,*) 'conc 25a'
17933 do mgs = 1,ngscnt
17934
17935 ccia(mgs) = 0.0
17936
17937 cwctfz(mgs) = 0.0
17938 qwctfz(mgs) = 0.0
17939 ctfzbd(mgs) = 0.0
17940 ctfzth(mgs) = 0.0
17941 ctfzdi(mgs) = 0.0
17942
17943 cwctfzc(mgs) = 0.0
17944 qwctfzc(mgs) = 0.0
17945 cwctfzp(mgs) = 0.0
17946 qwctfzp(mgs) = 0.0
17947 IF ( icfn .ge. 1 ) THEN
17948
17949 IF ( temg(mgs) .lt. 271.15 .and. qx(mgs,lc) .gt. qxmin(lc)) THEN
17950
17951! find available # of ice nuclei & limit value to max depletion of cloud water
17952
17953 IF ( icfn .ge. 2 ) THEN
17954 ccia(mgs) = exp( 4.11 - (0.262)*temcg(mgs) ) ! in m-3, see Walko et al. 1995; 1000*exp(-2.8 -b*t) = exp(6.91)*exp(-2.8 - b*t) = exp(4.11 -b*t)
17955 !ccia(mgs) = Min(cwctfz(mgs), ccmxd(mgs) )
17956
17957! now find how many of these collect cloud water to form IN
17958! Cotton et al 1986
17959
17960 knud(mgs) = 2.28e-5 * temg(mgs) / ( pres(mgs)*raero ) !Walko et al. 1995
17961 knuda(mgs) = 1.257 + 0.4*exp(-1.1/knud(mgs)) !Pruppacher & Klett 1997 eqn 11-16
17962 gtp(mgs) = 1. / ( fai(mgs) + fbi(mgs) ) !Byers 65 / Cotton 72b
17963 dfar(mgs) = kb*temg(mgs)*(1.+knuda(mgs)*knud(mgs))/(6.*pi*fadvisc(mgs)*raero) !P&K 1997 eqn 11-15
17964 fn1(mgs) = 2.*pi*xdia(mgs,lc,1)*cx(mgs,lc)*ccia(mgs)
17965 fn2(mgs) = -gtp(mgs)*(ssw(mgs)-1.)*felv(mgs)/pres(mgs)
17966 fnft(mgs) = 0.4*(1.+1.45*knud(mgs)+0.4*knud(mgs)*exp(-1./knud(mgs)))*(ftka(mgs)+2.5*knud(mgs)*kaero) &
17967 & / ( (1.+3.*knud(mgs))*(2*ftka(mgs)+5.*knud(mgs)*kaero+kaero) )
17968
17969
17970! Brownian diffusion
17971 ctfzbd(mgs) = fn1(mgs)*dfar(mgs)
17972
17973! Thermophoretic contact nucleation
17974 ctfzth(mgs) = fn1(mgs)*fn2(mgs)*fnft(mgs)/rho0(mgs)
17975
17976! Diffusiophoretic contact nucleation
17977 ctfzdi(mgs) = fn1(mgs)*fn2(mgs)*rw*temg(mgs)/(felv(mgs)*rho0(mgs))
17978
17979 cwctfz(mgs) = max( ctfzbd(mgs) + ctfzth(mgs) + ctfzdi(mgs) , 0.)
17980
17981! Sum of the contact nucleation processes
17982! IF ( cx(mgs,lc) .gt. 1.e6) write(0,*) 'ctfzbd,etc = ',cwctfz(mgs),ctfzbd(mgs),ctfzth(mgs),ctfzdi(mgs)
17983! IF ( wvel(mgs) .lt. -0.05 ) write(6,*) 'ctfzbd,etc = ',ctfzbd(mgs),ctfzth(mgs),ctfzdi(mgs),cx(mgs,lc)*1e-6,wvel(mgs)
17984! IF ( ssw(mgs) .lt. 1.0 .and. cx(mgs,lc) .gt. 1.e6 .and. cwctfz(mgs) .gt. 1. ) THEN
17985! write(6,*) 'ctfzbd,etc = ',ctfzbd(mgs),ctfzth(mgs),ctfzdi(mgs),cx(mgs,lc)*1e-6,wvel(mgs),fn1(mgs),fn2(mgs)
17986! write(6,*) 'more = ',nstep,ssw(mgs),dfar(mgs),gtp(mgs),felv(mgs),pres(mgs)
17987! ENDIF
17988
17989 ELSEIF ( icfn .eq. 1 ) THEN
17990 IF ( wvel(mgs) .lt. -0.05 ) THEN ! older kludgy version
17991 cwctfz(mgs) = cfnfac*exp( (-2.80) - (0.262)*temcg(mgs) )
17992 cwctfz(mgs) = min((1.0e3)*cwctfz(mgs), ccmxd(mgs) ) !convert to m-3
17993 ENDIF
17994 ENDIF ! icfn
17995
17996 IF ( ipconc .ge. 2 ) THEN
17997 cwctfz(mgs) = min( cwctfz(mgs)*dtpinv, ccmxd(mgs) )
17998 qwctfz(mgs) = xmas(mgs,lc)*cwctfz(mgs)/rho0(mgs)
17999 ELSE
18000 qwctfz(mgs) = (cimasn)*cwctfz(mgs)/(dtp*rho0(mgs))
18001 qwctfz(mgs) = max(qwctfz(mgs), 0.0)
18002 qwctfz(mgs) = min(qwctfz(mgs),qcmxd(mgs))
18003 ENDIF
18004
18005!
18006 if ( xplate(mgs) .eq. 1 ) then
18007 qwctfzp(mgs) = qwctfz(mgs)
18008 cwctfzp(mgs) = cwctfz(mgs)
18009 end if
18010!
18011 if ( xcolmn(mgs) .eq. 1 ) then
18012 qwctfzc(mgs) = qwctfz(mgs)
18013 cwctfzc(mgs) = cwctfz(mgs)
18014 end if
18015
18016! IF ( cwctfz(mgs)*dtp > 0.5 .and. dtp*qwctfz(mgs) > qxmin(li) ) THEN
18017! write(91,*) 'cwctfz: ',cwctfz(mgs),qwctfz(mgs) ! ,cwctfzc(mgs),qwctfzc(mgs)
18018! ENDIF
18019
18020!
18021! qwctfzc(mgs) = qwctfz(mgs)
18022! qwctfzp(mgs) = 0.0
18023!
18024 end if
18025
18026 ENDIF ! icfn
18027
18028 end do
18029!
18030!
18031!
18032! Hobbs-Rangno ice enhancement (Ferrier, 1994)
18033!
18034 if (ndebug .gt. 0 ) write(0,*) 'conc 23a'
18035 dthr = 300.0
18036 hrifac = (1.e-3)*((0.044)*(0.01**3))
18037 do mgs = 1,ngscnt
18038 ciihr(mgs) = 0.0
18039 qiihr(mgs) = 0.0
18040 cicichr(mgs) = 0.0
18041 qicichr(mgs) = 0.0
18042 cipiphr(mgs) = 0.0
18043 qipiphr(mgs) = 0.0
18044 IF ( ihrn .ge. 1 ) THEN
18045 if ( qx(mgs,lc) .gt. qxmin(lc) ) then
18046 if ( temg(mgs) .lt. 273.15 ) then
18047! write(iunit,'(3(1x,i3),3(1x,1pe12.5))')
18048! : igs(mgs),jgs,kgs(mgs),cx(mgs,lc),rho0(mgs),qx(mgs,lc)
18049! write(iunit,'(1pe15.6)')
18050! : log(cx(mgs,lc)*(1.e-6)/(3.0)),
18051! : ((1.e-3)*rho0(mgs)*qx(mgs,lc)),
18052! : (cx(mgs,lc)*(1.e-6)),
18053! : ((1.e-3)*rho0(mgs)*qx(mgs,lc))/(cx(mgs,lc)*(1.e-6)),
18054! : (alog(cx(mgs,lc)*(1.e-6)/(3.0)) *
18055! > ((1.e-3)*rho0(mgs)*qx(mgs,lc))/(cx(mgs,lc)*(1.e-6)))
18056
18057 IF ( log(cx(mgs,lc)*(1.e-6)/(3.0)) .gt. 0.0 ) THEN
18058 ciihr(mgs) = ((1.69e17)/dthr) &
18059 & *(log(cx(mgs,lc)*(1.e-6)/(3.0)) * &
18060 & ((1.e-3)*rho0(mgs)*qx(mgs,lc))/(cx(mgs,lc)*(1.e-6)))**(7./3.)
18061 ciihr(mgs) = ciihr(mgs)*(1.0e6)
18062 qiihr(mgs) = hrifac*ciihr(mgs)/rho0(mgs)
18063 qiihr(mgs) = max(qiihr(mgs), 0.0)
18064 qiihr(mgs) = min(qiihr(mgs),qcmxd(mgs))
18065 ENDIF
18066!
18067 if ( xplate(mgs) .eq. 1 ) then
18068 qipiphr(mgs) = qiihr(mgs)
18069 cipiphr(mgs) = ciihr(mgs)
18070 end if
18071!
18072 if ( xcolmn(mgs) .eq. 1 ) then
18073 qicichr(mgs) = qiihr(mgs)
18074 cicichr(mgs) = ciihr(mgs)
18075 end if
18076!
18077! qipiphr(mgs) = 0.0
18078! qicichr(mgs) = qiihr(mgs)
18079!
18080 end if
18081 end if
18082 ENDIF ! ihrn
18083 end do
18084!
18085!
18086!
18087! simple frozen rain to hail conversion. All of the
18088! frozen rain larger than 5.0e-3 m in diameter are converted
18089! to hail. This is done by considering the equation for
18090! frozen rain mixing ratio:
18091!
18092!
18093! qfw = [ cno(lf) * pi * fwdn / (6 rhoair) ]
18094!
18095! /inf
18096! * | fwdia*3 exp(-dia/fwdia) d(dia)
18097! /Do
18098!
18099! The amount to be reclassified as hail is the integral above from
18100! Do to inf where Do is 5.0e-3 m.
18101!
18102!
18103! qfauh = [ cno(lf) * pi * fwdn / (6 rhoair) ]
18104!
18105!
18106
18107
18108 hdia0 = 300.0e-6
18109 do mgs = 1,ngscnt
18110 qscnvi(mgs) = 0.0
18111 cscnvi(mgs) = 0.0
18112 cscnvis(mgs) = 0.0
18113! IF ( .false. ) THEN
18114! IF ( temg(mgs) .lt. tfr .and. ssi(mgs) .gt. 1.01 .and. qx(mgs,li) .gt. qxmin(li) ) THEN
18115 IF ( temg(mgs) .lt. tfr .and. qx(mgs,li) .gt. qxmin(li) ) THEN
18116 IF ( ipconc .ge. 4 .and. .false. ) THEN
18117 if ( cx(mgs,li) .gt. 10. .and. xdia(mgs,li,1) .gt. 50.e-6 ) then !{
18118 cirdiatmp = &
18119 & (qx(mgs,li)*rho0(mgs) &
18120 & /(pi*xdn(mgs,li)*cx(mgs,li)))**(1./3.)
18121 IF ( cirdiatmp .gt. 100.e-6 ) THEN !{
18122 qscnvi(mgs) = &
18123 & ((pi*xdn(mgs,li)*cx(mgs,li)) / (6.0*rho0(mgs)*dtp)) &
18124 & *exp(-hdia0/cirdiatmp) &
18125 & *( (hdia0**3) + 3.0*(hdia0**2)*cirdiatmp &
18126 & + 6.0*(hdia0)*(cirdiatmp**2) + 6.0*(cirdiatmp**3) )
18127 qscnvi(mgs) = &
18128 & min(qscnvi(mgs),qimxd(mgs))
18129 IF ( ipconc .ge. 4 ) THEN
18130 cscnvi(mgs) = min( cimxd(mgs), cx(mgs,li)*exp(-hdia0/cirdiatmp))
18131 ENDIF
18132 ENDIF ! }
18133 end if ! }
18134
18135 ELSEIF ( ipconc .lt. 4 ) THEN
18136
18137 qscnvi(mgs) = 0.001*eii(mgs)*max((qx(mgs,li)-1.e-3),0.0)
18138 qscnvi(mgs) = min(qscnvi(mgs),qxmxd(mgs,li))
18139 cscnvi(mgs) = qscnvi(mgs)*rho0(mgs)/xmas(mgs,li)
18140 cscnvis(mgs) = 0.5*cscnvi(mgs)
18141
18142 ENDIF
18143 ENDIF
18144! ENDIF
18145 end do
18146
18147
18148
18149!
18150! Ventilation coeficients
18151!
18152 do mgs = 1,ngscnt
18153 fvent(mgs) = (fschm(mgs)**(1./3.)) * (fakvisc(mgs)**(-0.5))
18154 end do
18155!
18156!
18157 if ( ndebug .gt. 0 ) write(0,*) 'civent'
18158!
18159 civenta = 1.258e4
18160 civentb = 2.331
18161 civentc = 5.662e4
18162 civentd = 2.373
18163 civente = 0.8241
18164 civentf = -0.042
18165 civentg = 1.70
18166
18167 do mgs = 1,ngscnt
18168 IF ( icond .eq. 1 .or. temg(mgs) .le. tfrh &
18169 & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN
18170 IF ( qx(mgs,li) .gt. qxmin(li) ) THEN
18171 cireyn = &
18172 & (civenta*xdia(mgs,li,1)**civentb &
18173 & +civentc*xdia(mgs,li,1)**civentd) &
18174 & / &
18175 & (civente*xdia(mgs,li,1)**civentf+civentg)
18176 xcivent = (fschm(mgs)**(1./3.))*((cireyn/fakvisc(mgs))**0.5)
18177 if ( xcivent .lt. 1.0 ) then
18178 civent(mgs) = 1.0 + 0.14*xcivent**2
18179 end if
18180 if ( xcivent .ge. 1.0 ) then
18181 civent(mgs) = 0.86 + 0.28*xcivent
18182 end if
18183 ELSE
18184 civent(mgs) = 0.0
18185 ENDIF
18186
18187
18188 ENDIF ! icond .eq. 1
18189 end do
18190
18191!
18192!
18193 igmrwa = 100.0*2.0
18194 igmrwb = 100.*((5.0+br)/2.0)
18195 rwventa = (0.78)*gmoi(igmrwa) ! 0.78
18196 rwventb = (0.308)*gmoi(igmrwb) ! 0.562825
18197 do mgs = 1,ngscnt
18198 IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN
18199 IF ( ipconc .ge. 3 ) THEN
18200 IF ( imurain == 3 ) THEN
18201 IF ( izwisventr == 1 ) THEN
18202 rwvent(mgs) = ventrx(mgs)*(1.6 + 124.9*(1.e-3*rho0(mgs)*qx(mgs,lr))**.2046)
18203 ELSE ! izwisventr = 2
18204! Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br
18205 rwvent(mgs) = &
18206 & (0.78*ventrx(mgs) + 0.308*ventrxn(mgs)*fvent(mgs) &
18207 & *sqrt((ar*rhovt(mgs))) &
18208 & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) )
18209 ENDIF
18210
18211 ELSE ! imurain == 1
18212 ! linear interpolation of complete gamma function
18213! tmp = 2. + alpha(mgs,lr)
18214! i = Int(dgami*(tmp))
18215! del = tmp - dgam*i
18216! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
18217
18218 IF ( iferwisventr == 1 ) THEN
18219
18220 ! Ferrier fall speed in the ventillation term [uses fx(lr) ]
18221
18222 alpr = min(alpharmax,alpha(mgs,lr) )
18223
18224 x = 1. + alpha(mgs,lr)
18225
18226 IF ( ipconc >= 6 .and. lzr > 1 ) THEN ! 3 moment
18227 tmp = 1. + alpr ! alpha(mgs,lr)
18228 i = int(dgami*(tmp))
18229 del = tmp - dgam*i
18230 g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
18231
18232 tmp = 2.5 + alpha(mgs,lr) + 0.5*bx(lr)
18233 i = int(dgami*(tmp))
18234 del = tmp - dgam*i
18235 y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp ! ratio of gamma functions
18236 ELSE
18237 y = ventrxn(mgs)
18238 ENDIF
18239
18240! vent1 = dble(xdia(mgs,lr,1))**(-2. - alpr) ! Actually OK
18241! vent2 = dble(1./xdia(mgs,lr,1) + 0.5*fx(lr))**dble(2.5+alpr+0.5*bx(lr)) ! Actually OK
18242 vent1 = dble(xdia(mgs,lr,1))**(0.5 + 0.5*bx(lr)) ! 2016.2.26 Changed for consistency with derivation (recast formula -- should be equivalent)
18243 vent2 = dble(1. + 0.5*fx(lr)*xdia(mgs,lr,1))**dble(2.5+alpr+0.5*bx(lr))
18244
18245
18246 rwvent(mgs) = &
18247 & 0.78*x + &
18248 & 0.308*fvent(mgs)*y* &
18249 & sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2)
18250
18251 rwventz(mgs) = 0.0
18252
18253! rwventz(mgs) = &
18254! & 0.78*x + &
18255! & 0.308*fvent(mgs)*y* &
18256! & Sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2)
18257
18258
18259 ELSEIF ( iferwisventr == 2 ) THEN
18260
18261! Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br
18262 x = 1. + alpha(mgs,lr)
18263
18264 rwvent(mgs) = &
18265 & (0.78*x + 0.308*ventrxn(mgs)*fvent(mgs) &
18266 & *sqrt((ar*rhovt(mgs))) &
18267 & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) )
18268
18269
18270 IF ( ipconc >= 7 ) THEN
18271 alpr = min(alpharmax,alpha(mgs,lr) )
18272
18273 tmp = alpr + 5.5 + br/2.
18274 i = int(dgami*(tmp))
18275 del = tmp - dgam*i
18276 y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
18277
18278! rwventz(mgs) = &
18279! & 0.78*(4. + alpha(mgs,lr))*(3. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(1. + alpha(mgs,lr)) + &
18280 rwventz(mgs) = &
18281 & 0.78*(4. + alpr)*(3. + alpr)*(2. + alpr)*(1. + alpr) + &
18282 & 0.308*fvent(mgs)* &
18283 & sqrt(ax(lr)*rhovt(mgs))*(y/gf1palp(mgs))*(xdia(mgs,lr,1)**((1.0+br)/2.0))
18284
18285 ENDIF
18286
18287
18288 ENDIF ! iferwisventr
18289
18290 ENDIF ! imurain
18291 ELSE
18292 rwvent(mgs) = &
18293 & (rwventa + rwventb*fvent(mgs) &
18294 & *sqrt((ar*rhovt(mgs))) &
18295 & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) )
18296 ENDIF
18297 ELSE
18298 rwvent(mgs) = 0.0
18299 ENDIF
18300 end do
18301!
18302 igmswa = 100.0*2.0
18303 igmswb = 100.*((5.0+ds)/2.0)
18304 swventa = (0.78)*gmoi(igmswa)
18305 swventb = (0.308)*gmoi(igmswb)
18306 do mgs = 1,ngscnt
18307 IF ( qx(mgs,ls) .gt. qxmin(ls) ) THEN
18308 IF ( ipconc .ge. 4 ) THEN
18309 swvent(mgs) = 0.65 + 0.44*fvent(mgs)*sqrt(vtxbar(mgs,ls,1)*xdia(mgs,ls,1))
18310 ELSE
18311! 10-ice version:
18312 swvent(mgs) = &
18313 & (swventa + swventb*fvent(mgs) &
18314 & *sqrt((cs*rhovt(mgs))) &
18315 & *(xdia(mgs,ls,1)**((1.0+ds)/2.0)) )
18316 ENDIF
18317 ELSE
18318 swvent(mgs) = 0.0
18319 ENDIF
18320 end do
18321!
18322!
18323
18324 igmhwa = 100.0*2.0
18325 igmhwb = 100.0*2.75
18326 hwventa = (0.78)*gmoi(igmhwa)
18327 hwventb = (0.308)*gmoi(igmhwb)
18328! hwventc = (4.0*gr/(3.0*cdx(lh)))**(0.25)
18329 hwvent(:) = 0.0
18330 hwventy(:) = 0.0
18331
18332 do mgs = 1,ngscnt
18333 IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN
18334 hwventc = (4.0*gr/(3.0*cdxgs(mgs,lh)))**(0.25)
18335 IF ( .false. .or. alpha(mgs,lh) .eq. 0.0 ) THEN
18336 hwvent(mgs) = &
18337 & ( hwventa + hwventb*hwventc*fvent(mgs) &
18338 & *((xdn(mgs,lh)/rho0(mgs))**(0.25)) &
18339 & *(xdia(mgs,lh,1)**(0.75)))
18340 ELSE ! Ferrier 1994, eq. B.36
18341 ! linear interpolation of complete gamma function
18342! tmp = 2. + alpha(mgs,lh)
18343! i = Int(dgami*(tmp))
18344! del = tmp - dgam*i
18345! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
18346
18347! note that hwvent includes a division by Gamma(1+alpha), so Gamma(2+alpha)/Gamma(1+alpha) = 1 + alpha
18348! and g1palp = Gamma(1+alpha) divides into y
18349 x = 1. + alpha(mgs,lh)
18350
18351 tmp = 1 + alpha(mgs,lh)
18352 i = int(dgami*(tmp))
18353 del = tmp - dgam*i
18354 g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
18355
18356 tmp = 2.5 + alpha(mgs,lh) + 0.5*bxx(mgs,lh)
18357 i = int(dgami*(tmp))
18358 del = tmp - dgam*i
18359 y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp
18360
18361
18362 hwventy(mgs) = 0.308*fvent(mgs)*(xdia(mgs,lh,1)**(0.5 + 0.5*bxx(mgs,lh)))*sqrt(axx(mgs,lh)*rhovt(mgs))
18363 hwvent(mgs) = &
18364 & ( 0.78*x + y*hwventy(mgs) ) ! &
18365! & 0.308*fvent(mgs)*y*(xdia(mgs,lh,1)**(0.5 + 0.5*bxx(mgs,lh)))* &
18366! & Sqrt(axx(mgs,lh)*rhovt(mgs)) )
18367
18368 ENDIF
18369 ELSE
18370 hwvent(mgs) = 0.0
18371 hwventy(mgs) = 0.0
18372 ENDIF
18373 end do
18374
18375
18376 hlvent(:) = 0.0
18377 hlventy(:) = 0.0
18378
18379 IF ( lhl .gt. 1 ) THEN
18380 igmhwa = 100.0*2.0
18381 igmhwb = 100.0*2.75
18382 hwventa = (0.78)*gmoi(igmhwa)
18383 hwventb = (0.308)*gmoi(igmhwb)
18384! hwventc = (4.0*gr/(3.0*cdx(lhl)))**(0.25)
18385 do mgs = 1,ngscnt
18386 IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN
18387 hwventc = (4.0*gr/(3.0*cdxgs(mgs,lhl)))**(0.25)
18388
18389 IF ( .false. .or. alpha(mgs,lhl) .eq. 0.0 ) THEN
18390 hlvent(mgs) = &
18391 & ( hwventa + hwventb*hwventc*fvent(mgs) &
18392 & *((xdn(mgs,lhl)/rho0(mgs))**(0.25)) &
18393 & *(xdia(mgs,lhl,1)**(0.75)))
18394 ELSE ! Ferrier 1994, eq. B.36
18395 ! linear interpolation of complete gamma function
18396! tmp = 2. + alpha(mgs,lhl)
18397! i = Int(dgami*(tmp))
18398! del = tmp - dgam*i
18399! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
18400
18401! note that hlvent includes a division by Gamma(1+alpha), so x = Gamma(2+alpha)/Gamma(1+alpha) = 1 + alpha
18402! and g1palp = Gamma(1+alpha) divides into y
18403
18404 x = 1. + alpha(mgs,lhl)
18405
18406 tmp = 1 + alpha(mgs,lhl)
18407 i = int(dgami*(tmp))
18408 del = tmp - dgam*i
18409 g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
18410
18411 tmp = 2.5 + alpha(mgs,lhl) + 0.5*bxx(mgs,lhl)
18412 i = int(dgami*(tmp))
18413 del = tmp - dgam*i
18414 y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp ! ratio of gamma functions
18415
18416 hlventy(mgs) = 0.308*fvent(mgs)*(xdia(mgs,lhl,1)**(0.5 + 0.5*bxx(mgs,lhl)))*sqrt(axx(mgs,lhl)*rhovt(mgs))
18417
18418 hlvent(mgs) = 0.78*x + y*hlventy(mgs) ! &
18419! & 0.308*fvent(mgs)*y*(xdia(mgs,lhl,1)**(0.5 + 0.5*bxx(mgs,lhl)))* &
18420! & Sqrt(axx(mgs,lhl)*rhovt(mgs)))
18421! : Sqrt(xdn(mgs,lhl)*ax(lhl)*rhovt(mgs)/rg0))/tmp
18422
18423 ENDIF
18424 ENDIF
18425 end do
18426 ENDIF
18427
18428!
18429!
18430!
18431! Wet growth constants
18432!
18433 do mgs = 1,ngscnt
18434 fwet1(mgs) = &
18435 & (2.0*pi)* &
18436 & ( felv(mgs)*fwvdf(mgs)*rho0(mgs)*(qss0(mgs)-qx(mgs,lv)) &
18437 & -ftka(mgs)*temcg(mgs) ) &
18438 & / ( rho0(mgs)*(felf(mgs)+fcw(mgs)*temcg(mgs)) )
18439 fwet2(mgs) = &
18440 & (1.0)-fci(mgs)*temcg(mgs) &
18441 & / ( felf(mgs)+fcw(mgs)*temcg(mgs) )
18442 end do
18443!
18444! Melting constants
18445!
18446 do mgs = 1,ngscnt
18447 fmlt1(mgs) = (2.0*pi)* &
18448 & ( felv(mgs)*fwvdf(mgs)*(qss0(mgs)-qx(mgs,lv)) &
18449 & -ftka(mgs)*temcg(mgs)/rho0(mgs) ) &
18450 & / (felf(mgs))
18451 fmlt2(mgs) = -fcw(mgs)*temcg(mgs)/felf(mgs)
18452 fmlt1e(mgs) = (2.0*pi)* &
18453 & ( felv(mgs)*fwvdf(mgs)*(qss0(mgs)-qx(mgs,lv)) ) / (felf(mgs))
18454 end do
18455!
18456! Vapor Deposition constants
18457!
18458 do mgs = 1,ngscnt
18459 fvds(mgs) = &
18460 & (4.0*pi/rho0(mgs))*(ssi(mgs)-1.0)* &
18461 & (1.0/(fai(mgs)+fbi(mgs)))
18462 end do
18463 do mgs = 1,ngscnt
18464 fvce(mgs) = &
18465 & (4.0*pi/rho0(mgs))*(ssw(mgs)-1.0)* &
18466 & (1.0/(fav(mgs)+fbv(mgs)))
18467 end do
18468
18469!
18470! deposition, sublimation, and melting of snow, graupel and hail
18471!
18472 qsmlr(:) = 0.0
18473 qimlr(:) = 0.0 ! this is not used. qi melts to qc way down in the code.
18474 qhmlr(:) = 0.0
18475 qhlmlr(:) = 0.0
18476 IF ( lhwlg > 1 ) THEN
18477 qhmlrlg(:) = 0.0
18478 qhlmlrlg(:) = 0.0
18479 ENDIF
18480 qhfzh(:) = 0.0
18481 qffzf(:) = 0.0
18482 qhlfzhl(:) = 0.0
18483 qhfzhlg(:) = 0.0
18484 qhlfzhllg(:) = 0.0
18485 vhfzh(:) = 0.0
18486 vffzf(:) = 0.0
18487 vhlfzhl(:) = 0.0
18488 qsfzs(:) = 0.0
18489! zsmlr(:) = 0.0
18490 zhmlr(:) = 0.0
18491 zhmlrr(:) = 0.0
18492 zsmlrr(:) = 0.0
18493 zhshr(:) = 0.0
18494 zhlmlr(:) = 0.0
18495 zhlshr(:) = 0.0
18496
18497 zhshrr(:) = 0.0
18498 zhlmlrr(:) = 0.0
18499 zhlshrr(:) = 0.0
18500
18501 csmlr(:) = 0.0
18502 csmlrr(:) = 0.0
18503 chmlr(:) = 0.0
18504 chmlrr(:) = 0.0
18505 chlmlr(:) = 0.0
18506 chlfmlr(:) = 0.0
18507! chlmlrsave(:) = 0.0
18508! qhlmlrsave(:) = 0.0
18509! chlsave(:) = 0.0
18510! qhlsave(:) = 0.0
18511 chlmlrr(:) = 0.0
18512
18513
18514 if ( .not. mixedphase ) then !{
18515 do mgs = 1,ngscnt
18516!
18517 IF ( temg(mgs) .gt. tfr ) THEN
18518
18519 IF ( qx(mgs,ls) .gt. qxmin(ls) ) THEN
18520 qsmlr(mgs) = &
18521 & min( &
18522 & (c1sw*fmlt1(mgs)*cx(mgs,ls)*swvent(mgs)*xdia(mgs,ls,1) ) & ! /rhosm &
18523 & , 0.0 )
18524 ENDIF
18525
18526
18527! IF ( qx(mgs,ls) .gt. 0.1e-4 ) write(0,*) 'qsmlr: ',qsmlr(mgs),qx(mgs,ls),cx(mgs,ls),fmlt1(mgs),
18528! : temcg(mgs),swvent(mgs),xdia(mgs,ls,1),qss0(mgs)-qx(mgs,lv)
18529! ELSE
18530! qsmlr(mgs) = 0.0
18531! ENDIF
18532! 10ice version:
18533! > min(
18534! > (fmlt1(mgs)*cx(mgs,ls)*swvent(mgs)*xdia(mgs,ls,1) +
18535! > fmlt2(mgs)*(qsacr(mgs)+qsacw(mgs)) )
18536! < , 0.0 )
18537
18538 IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN
18539
18540 IF ( ibinhmlr == 0 .or. lzh < 1 ) THEN
18541 qhmlr(mgs) = &
18542 & meltfac*min( &
18543 & fmlt1(mgs)*cx(mgs,lh)*hwvent(mgs)*xdia(mgs,lh,1) &
18544 & + fmlt2(mgs)*(qhacrmlr(mgs)+qhacwmlr(mgs)) &
18545 & , 0.0 )
18546 ELSEIF ( ibinhmlr == 1 ) THEN ! use incomplete gamma functions to approximate the bin results
18547
18548 errmsg = 'ibinhmlr = 1 not available for 2-moment'
18549 errflg = 1
18550 RETURN
18551
18552 ELSEIF ( ibinhmlr == 2 .or. ibinhmlr == 3 ) THEN
18553
18554 ENDIF
18555
18556
18557 IF ( ivhmltsoak > 0 .and. qhmlr(mgs) < 0.0 .and. lvol(lh) > 1 .and. xdn(mgs,lh) .lt. xdnmx(lh) ) THEN
18558 ! act as if 100% of the meltwater were soaked into the graupel
18559 v1 = (1. - xdn(mgs,lh)/xdnmx(lh))*(vx(mgs,lh) + rho0(mgs)*qhmlr(mgs)/xdn(mgs,lh) )/(dtp) ! volume available for filling
18560 v2 = -1.0*rho0(mgs)*qhmlr(mgs)/xdnmx(lh) ! volume of melted ice if it were refrozen in the matrix
18561
18562 vhsoak(mgs) = min(v1,v2)
18563
18564 ENDIF
18565
18566 ENDIF ! qx(mgs,lh) .gt. qxmin(lh)
18567
18568
18569 IF ( lhl .gt. 1 .and. lhlw < 1 ) THEN
18570
18571 IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN
18572 IF ( ibinhlmlr == 0 .or. lzhl < 1) THEN
18573 qhlmlr(mgs) = &
18574 & meltfac*min( &
18575 & fmlt1(mgs)*cx(mgs,lhl)*hlvent(mgs)*xdia(mgs,lhl,1) &
18576 & + fmlt2(mgs)*(qhlacrmlr(mgs)+qhlacwmlr(mgs)) &
18577 & , 0.0 )
18578
18579 ELSEIF ( ibinhlmlr == 1 ) THEN ! use incomplete gamma functions to approximate the bin results
18580
18581! #ifdef 1
18582! #if (defined 1) && defined( COMMAS ) || defined( COMMASTMP )
18583
18584 ELSEIF ( ibinhlmlr == -1 ) THEN ! OLD VERSION use incomplete gamma functions to approximate the bin results
18585
18586 ENDIF ! ibinhlmlr
18587
18588
18589 IF ( ivhmltsoak > 0 .and. qhlmlr(mgs) < 0.0 .and. lvol(lhl) > 1 .and. xdn(mgs,lhl) .lt. xdnmx(lhl) ) THEN
18590 ! act as if 50% of the meltwater were soaked into the graupel
18591 v1 = (1. - xdn(mgs,lhl)/xdnmx(lhl))*(vx(mgs,lhl) + rho0(mgs)*qhlmlr(mgs)/xdn(mgs,lhl) )/(dtp) ! volume available for filling
18592 v2 = -1.0*rho0(mgs)*qhlmlr(mgs)/xdnmx(lhl) ! volume of melted ice if it were refrozen in the matrix
18593
18594 vhlsoak(mgs) = min(v1,v2)
18595
18596 ENDIF
18597
18598 ENDIF
18599 ENDIF
18600
18601 ENDIF
18602
18603!
18604! qimlr(mgs) = max( qimlr(mgs), -qimxd(mgs) )
18605! qsmlr(mgs) = max( qsmlr(mgs), -qsmxd(mgs) )
18606! erm 5/10/2007 changed to next line:
18607 if ( .not. mixedphase ) qsmlr(mgs) = max( qsmlr(mgs), min( -qsmxd(mgs), -0.7*qx(mgs,ls)*dtpinv ) )
18608 IF ( .not. mixedphase ) THEN
18609 qhmlr(mgs) = max( qhmlr(mgs), min( -qhmxd(mgs), -0.95*qx(mgs,lh)*dtpinv ) )
18610 chmlr(mgs) = max( chmlr(mgs), min( -chmxd(mgs), -0.95*cx(mgs,lh)*dtpinv ) )
18611 ENDIF
18612! qhmlr(mgs) = max( max( qhmlr(mgs), -qhmxd(mgs) ) , -0.5*qx(mgs,lh)*dtpinv ) !limits to 1/2 qh or max depletion
18613 qhmlh(mgs) = 0. ! not used
18614
18615
18616 ! Rasmussen and Heymsfield say melt water remains on graupel up to 9 mm before shedding
18617
18618
18619 IF ( lhl .gt. 1 .and. lhlw < 1 ) THEN
18620 qhlmlr(mgs) = max( qhlmlr(mgs), min( -qxmxd(mgs,lhl), -0.95*qx(mgs,lhl)*dtpinv ) )
18621 chlmlr(mgs) = max( chlmlr(mgs), min( -cxmxd(mgs,lhl), -0.95*cx(mgs,lhl)*dtpinv ) )
18622 ENDIF
18623
18624!
18625 end do
18626
18627 endif ! } not mixedphase
18628!
18629 if ( ipconc .ge. 1 ) then
18630 do mgs = 1,ngscnt
18631 cimlr(mgs) = (cx(mgs,li)/(qx(mgs,li)+1.e-20))*qimlr(mgs)
18632 IF ( .not. mixedphase ) THEN !{
18633 IF ( xdia(mgs,ls,1) .gt. 1.e-6 .and. -qsmlr(mgs) .ge. 0.5*qxmin(ls) .and. ipconc .ge. 4 ) THEN
18634! csmlr(mgs) = rho0(mgs)*qsmlr(mgs)/(xv(mgs,ls)*rhosm)
18635 csmlr(mgs) = (cx(mgs,ls)/(qx(mgs,ls)))*qsmlr(mgs)
18636 ELSEIF ( qx(mgs,ls) > qxmin(ls) ) THEN
18637 csmlr(mgs) = (cx(mgs,ls)/(qx(mgs,ls)))*qsmlr(mgs)
18638 ENDIF
18639
18640 csmlrr(mgs) = csmlr(mgs)/rzxs(mgs)
18641 IF ( -csmlrr(mgs)*dtp > cxmin .and. -qsmlr(mgs)*dtp > qxmin(lr) .and. snowmeltdia > 0.0 ) THEN
18642 rmas = rho0(mgs)*qsmlr(mgs)/csmlrr(mgs)
18643 IF ( rmas > snowmeltmass ) THEN
18644 csmlrr(mgs) = rho0(mgs)*qsmlr(mgs)/snowmeltmass
18645 ENDIF
18646 ENDIF
18647
18648
18649
18650! IF ( xdia(mgs,lh,1) .gt. 1.e-6 .and. Abs(qhmlr(mgs)) .ge. qxmin(lh) ) THEN
18651! chmlr(mgs) = rho0(mgs)*qhmlr(mgs)/(pi*xdn(mgs,lh)*xdia(mgs,lh,1)**3) ! out of hail
18652! chmlr(mgs) = Max( chmlr(mgs), -chmxd(mgs) )
18653! ELSE
18654 IF ( ibinhmlr == 0 .or. lzh < 1 ) THEN
18655 chmlr(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhmlr(mgs)
18656 IF ( imltshddmr == 3 .and. qhmlr(mgs) < -qxmin(lh) ) THEN
18657 ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1)
18658 !
18659 ! IF ( tmpdiam > sheddiam ) THEN ! let size get smaller until it reaches sheddiam
18660 ! chmlr(mgs) = 0.0
18661 ! ENDIF
18662
18663 ! test to remove the part of the melting associated with large ice particles so they get smaller
18664
18665 tmp = 1. + alpha(mgs,lh)
18666 i = int(dgami*(tmp))
18667 del = tmp - dgam*i
18668 g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
18669
18670 ratio = min( maxratiolu, mltdiam1/xdia(mgs,lh,1) )
18671
18672 x = gamxinfdp(2. + alpha(mgs,lh), ratio)/g1palp
18673 y = gamxinfdp(2.5 + alpha(mgs,lh) + 0.5*bxx(mgs,lh), ratio)/g1palp
18674
18675 hwvent1 = 0.78*x + y*hwventy(mgs)
18676
18677 qhlmlr1 = min( fmlt1(mgs)*cx(mgs,lh)*hwvent1*xdia(mgs,lh,1), 0.0 )
18678
18679 chmlr(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*(qhmlr(mgs) - qhlmlr1)
18680
18681
18682 ENDIF
18683! IF ( igs(mgs) == 40 ) THEN
18684! write(0,*) 'is this running? chmlr = ',kgs(mgs), chmlr(mgs)
18685! ENDIF
18686 ENDIF
18687! ENDIF
18688
18689
18690 IF ( chmlr(mgs) < 0.0 .and. (ibinhmlr < 1 .or. lzh < 1) ) THEN ! { already done if ibinhmlr > 0
18691 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
18692 tmp = qx(mgs,lh)/cx(mgs,lh)
18693 alp = alpha(mgs,lh)
18694 g1 = g1x(mgs,lh) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
18695
18696 zhmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhmlr(mgs) - tmp**2 * chmlr(mgs) )
18697
18698 ENDIF
18699
18700 IF ( ibinhmlr == 0 .or. lzh < 1 ) THEN
18701 IF ( ihmlt .eq. 1 ) THEN
18702 chmlrr(mgs) = min( chmlr(mgs), rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*vmlt) ) ! into rain
18703 ELSEIF ( ihmlt .eq. 2 ) THEN
18704 IF ( xv(mgs,lh) .gt. 0.0 .and. chmlr(mgs) .lt. 0.0 ) THEN
18705! chmlrr(mgs) = Min( chmlr(mgs), rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lh)*xv(mgs,lh)) ) ! into rain
18706! guess what, this is the same as chmlr: rho0*qhmlr/xmas(lh) --> cx/qx = rho0/xmas
18707 IF(imltshddmr == 1) THEN
18708 ! DTD: If Dmg < sheddiam, then assume complete melting into
18709 ! maximal raindrop. Between sheddiam and sheddiam0 mm, linearly ramp down to a 3 mm shed drop
18710 tmp = -rho0(mgs)*qhmlr(mgs)/(min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lh)*xv(mgs,lh))) ! Min of Maximum raindrop size/mean hail size
18711 tmp2 = -rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*vr3mm) ! conc. change for a 3 mm mean drop diameter
18712
18713 chmlrr(mgs) = tmp*(sheddiam0-xdia(mgs,lh,3))/(sheddiam0-sheddiam)+tmp2*(xdia(mgs,lh,3)-sheddiam)/(sheddiam0-sheddiam) ! old version
18714 chmlrr(mgs) = -max(tmp,min(tmp2,chmlrr(mgs)))
18715 ELSEIF ( imltshddmr == 2 .or. imltshddmr == 3 ) THEN
18716 ! 8/26/2015 ERM updated to use shedalp and tmpdiam
18717 ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1)
18718 chmlrr(mgs) = rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lh)) ! into rain
18719 ELSE ! Old method
18720 chmlrr(mgs) = rho0(mgs)*qhmlr(mgs)/(min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lh)*xv(mgs,lh))) ! into rain
18721 ENDIF
18722 ELSE
18723 chmlrr(mgs) = chmlr(mgs)
18724 ENDIF
18725 ELSEIF ( ihmlt .eq. 0 ) THEN
18726 chmlrr(mgs) = chmlr(mgs)
18727 ENDIF
18728
18729 ELSE ! ibinhmlr < 0? Already have an outer IF test for ibinhmlr < 1
18730 chmlrr(mgs) = min( chmlrr(mgs), rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*xvmx(lr)) ) ! into rain
18731 ENDIF
18732
18733 ENDIF ! } ( chmlr(mgs) < 0.0 .and. ibinhmlr < 1)
18734
18735 IF ( lhl .gt. 1 .and. lhlw < 1 .and. .not. mixedphase .and. qhlmlr(mgs) < 0.0 ) THEN ! {
18736
18737 IF ( ibinhlmlr == 0 .or. lzhl < 1 ) THEN
18738! IF ( xdia(mgs,lhl,1) .gt. 1.e-6 .and. Abs(qhlmlr(mgs)) .ge. qxmin(lhl) ) THEN
18739! chlmlr(mgs) = rho0(mgs)*qhlmlr(mgs)/(pi*xdn(mgs,lhl)*xdia(mgs,lhl,1)**3) ! out of hail
18740! chlmlr(mgs) = Max( chlmlr(mgs), -cxmxd(mgs,lhl) )
18741! ELSE
18742 chlmlr(mgs) = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlmlr(mgs)
18743 IF ( imltshddmr == 3 .and. qhlmlr(mgs) < -qxmin(lhl) ) THEN
18744! IF ( .false. .and. imltshddmr == 3 ) THEN
18745! tmpdiam = (shedalp+alpha(mgs,lhl))*xdia(mgs,lhl,1)
18746!
18747! IF ( tmpdiam > sheddiam ) THEN ! let size get smaller until it reaches sheddiam
18748! chlmlr(mgs) = 0.0
18749! ENDIF
18750
18751 ! test to remove the part of the melting associated with large ice particles so they get smaller
18752!
18753 tmp = 1. + alpha(mgs,lhl)
18754 i = int(dgami*(tmp))
18755 del = tmp - dgam*i
18756 g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
18757
18758 ratio = min( maxratiolu, mltdiam1/xdia(mgs,lhl,1) )
18759
18760 x = gamxinfdp(2. + alpha(mgs,lhl), ratio)/g1palp
18761 y = gamxinfdp(2.5 + alpha(mgs,lhl) + 0.5*bxx(mgs,lhl), ratio)/g1palp
18762
18763 hwvent1 = 0.78*x + y*hlventy(mgs)
18764
18765 qhlmlr1 = min( fmlt1(mgs)*cx(mgs,lhl)*hwvent1*xdia(mgs,lhl,1), 0.0 )
18766
18767 chlmlr(mgs) = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*min(0.0, qhlmlr(mgs) - qhlmlr1)
18768
18769 ENDIF
18770! ENDIF
18771 ENDIF
18772
18773 IF ( ibinhlmlr == 0 .or. lzhl < 1 ) THEN !{
18774 IF ( ihmlt .eq. 1 ) THEN
18775 chlmlrr(mgs) = min( chlmlr(mgs), rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*vmlt) ) ! into rain
18776 ELSEIF ( ihmlt .eq. 2 ) THEN
18777 IF ( xv(mgs,lhl) .gt. 0.0 .and. chlmlr(mgs) .lt. 0.0 ) THEN
18778! chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! into rain
18779! chlmlrr(mgs) = Min( chlmlr(mgs), rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lhl)*xv(mgs,lhl)) ) ! into rain
18780 IF(imltshddmr == 1 ) THEN
18781 tmp = -rho0(mgs)*qhlmlr(mgs)/(min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! Min of Maximum raindrop size/mean hail size
18782 tmp2 = -rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*vr3mm) ! conc. change for a 3 mm mean drop diameter
18783 chlmlrr(mgs) = tmp*(20.e-3-xdia(mgs,lhl,3))/(20.e-3-sheddiam)+tmp2*(xdia(mgs,lhl,3)-sheddiam)/(20.e-3-sheddiam)
18784 chlmlrr(mgs) = -max(tmp,min(tmp2,chlmlrr(mgs)))
18785 ELSEIF ( imltshddmr == 2 .or. imltshddmr == 3 ) THEN
18786 ! 8/26/2015 ERM updated to use shedalp and tmpdiam
18787 ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1)
18788 chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lhl)) ! into rain
18789 ELSE ! old method
18790 chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! into rain
18791 ENDIF
18792 ELSE
18793 chlmlrr(mgs) = chlmlr(mgs)
18794 ENDIF
18795 ELSEIF ( ihmlt .eq. 0 ) THEN
18796 chlmlrr(mgs) = chlmlr(mgs)
18797 ENDIF
18798
18799 ELSE ! } { ibinhlmlr > 0
18800 chlmlrr(mgs) = min( chlmlrr(mgs), rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*xvmx(lr)) ) ! into rain
18801 ENDIF !}
18802
18803
18804 IF ( ipconc >= 8 .and. lzhl .gt. 1 .and. ibinhlmlr <= 0 ) THEN
18805 IF ( cx(mgs,lhl) > 0.0 ) THEN
18806
18807 tmp = qx(mgs,lhl)/cx(mgs,lhl)
18808 alp = alpha(mgs,lhl)
18809! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
18810 g1 = g1x(mgs,lhl) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
18811
18812 zhlmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( tmp * qhlmlr(mgs) )
18813 ENDIF
18814 ENDIF
18815 ENDIF ! }
18816
18817 ENDIF ! }.not. mixedphase
18818
18819! 10ice versions:
18820! chmlr(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhmlr(mgs)
18821! chmlrr(mgs) = chmlr(mgs)
18822 end do
18823 end if
18824
18825!
18826! deposition/sublimation of ice
18827!
18828 DO mgs = 1,ngscnt
18829
18830 rwcap(mgs) = (0.5)*xdia(mgs,lr,1)
18831 swcap(mgs) = (0.5)*xdia(mgs,ls,1)
18832 hwcap(mgs) = (0.5)*xdia(mgs,lh,1)
18833 IF ( lhl .gt. 1 ) hlcap(mgs) = (0.5)*xdia(mgs,lhl,1)
18834
18835 if ( qx(mgs,li).gt.qxmin(li) .and. xdia(mgs,li,1) .gt. 0.0 ) then
18836!
18837! from Cotton, 1972 (Part II)
18838!
18839 cilen(mgs) = 0.4764*(xdia(mgs,li,1))**(0.958)
18840 cval = xdia(mgs,li,1)
18841 aval = cilen(mgs)
18842 eval = sqrt(1.0-(aval**2)/(cval**2))
18843 fval = min(0.99,eval)
18844 gval = alog( abs( (1.+fval)/(1.-fval) ) )
18845 cicap(mgs) = cval*fval / gval
18846 ELSE
18847 cicap(mgs) = 0.0
18848 end if
18849 ENDDO
18850!
18851!
18852 qhdsv(:) = 0.0
18853 qhldsv(:) = 0.0
18854
18855 do mgs = 1,ngscnt
18856 IF ( icond .eq. 1 .or. temg(mgs) .le. tfrh &
18857 & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN
18858 qidsv(mgs) = &
18859 & fvds(mgs)*cx(mgs,li)*civent(mgs)*cicap(mgs)*depfac
18860 qsdsv(mgs) = &
18861 & fvds(mgs)*cx(mgs,ls)*swvent(mgs)*swcap(mgs)*depfac
18862
18863! IF ( ny .eq. 2 .and. igs(mgs) .eq. 302 .and. temg(mgs) .le. tfrh+10 .and. qx(mgs,lv) .gt. qis(mgs)
18864! : .and. qx(mgs,li) .gt. qxmin(li) ) THEN
18865! write(0,*) 'qidsv = ',nstep,kgs(mgs),qidsv(mgs),temg(mgs)-tfrh,100.*(qx(mgs,lv)/qis(mgs) - 1.),1.e6*xdia(mgs,li,1),
18866! : fvds(mgs),civent(mgs),cicap(mgs)
18867! ENDIF
18868 ELSE
18869 qidsv(mgs) = 0.0
18870 qsdsv(mgs) = 0.0
18871 ENDIF
18872 qhdsv(mgs) = &
18873 & fvds(mgs)*cx(mgs,lh)*hwvent(mgs)*hwcap(mgs)*depfac
18874
18875 IF ( lhl .gt. 1 ) qhldsv(mgs) = fvds(mgs)*cx(mgs,lhl)*hlvent(mgs)*hlcap(mgs)*depfac
18876!
18877!
18878 end do
18879!
18880
18881
18882! #include "nssl.qlimit.F"
18883
18884!
18885! Use a test saturation adjustment to set limits on ice deposition/sublimation
18886! and rain evaporation
18887!
18888!
18889 IF ( dosublimationfix ) THEN
18890
18891 do mgs = 1,ngscnt
18892
18893 qitmp(mgs) = qx(mgs,li) + qx(mgs,ls) + qx(mgs,lh)
18894 IF ( lis > 1 ) qitmp(mgs) = qitmp(mgs) + qx(mgs,lis)
18895 IF ( lhl > 1 ) qitmp(mgs) = qitmp(mgs) + qx(mgs,lhl)
18896 qrtmp(mgs) = qx(mgs,lr)
18897 qctmp(mgs) = qx(mgs,lc)
18898 qsimxdep(mgs) = 0.0
18899 qsimxsub(mgs) = 0.0
18900 dqcitmp(mgs) = 0.0
18901
18902
18903! IF ( ( qitmp(mgs) > qxmin(li) .or. qrtmp(mgs) > qxmin(lr) ) ) THEN
18904 IF ( qitmp(mgs) > qxmin(li) ) THEN
18905
18906 qitmp1 = qitmp(mgs)
18907 qctmp1 = qctmp(mgs)
18908 felvcptmp = felvcp(mgs)
18909 felscptmp = felscp(mgs)
18910 qvtmp(mgs) = qx(mgs,lv)
18911 qss(mgs) = qvs(mgs)
18912 qsstmp = qvs(mgs)
18913 qvstmp = qvs(mgs)
18914 qisstmp = qis(mgs)
18915 thetatmp = theta(mgs)
18916 thetaptmp = thetap(mgs)
18917 temgtmp = temg(mgs)
18918 temcgtmp = temcg(mgs)
18919 qvaptmp = qx(mgs,lv) ! qwvp(mgs) + qv0(mgs)
18920 qvptmp = 0.0 ! qwvp(mgs) ! qv pertubation
18921
18922 qsstmp = qisstmp
18923
18924
18925 dqwvtmp(mgs) = ( qvtmp(mgs) - qsstmp )
18926
18927 do itertd = 1,2
18928
18929!
18930! calculate super-saturation
18931!
18932 IF ( itertd == 1 ) THEN
18933
18934 ELSE
18935 dqcitmp(mgs) = dqci(mgs)
18936 ! dqwvtmp(mgs) = dqwv(mgs)
18937 ENDIF
18938
18939 dqcw(mgs) = 0.0
18940 dqci(mgs) = 0.0
18941 dqwv(mgs) = ( qvtmp(mgs) - qsstmp )
18942!
18943! evaporation and sublimation adjustment
18944!
18945 if( dqwv(mgs) .lt. 0. ) then ! { subsaturated
18946 if( qitmp(mgs) .gt. -dqwv(mgs) ) then ! check if qi can make up all the deficit
18947 dqci(mgs) = dqwv(mgs)
18948 dqwv(mgs) = 0.
18949 else ! otherwise make all ice available for sublimation
18950 dqci(mgs) = -qitmp(mgs)
18951 dqwv(mgs) = dqwv(mgs) + qitmp(mgs)
18952 end if
18953!
18954 qvptmp = qvptmp - ( dqcw(mgs) + dqci(mgs) ) ! add to perturbation vapor
18955
18956 IF ( itertd == 2 .and. eqtset > 1 ) THEN
18957 ! if eqtset == 2, then need to update the latent heats for change in hydrometeor content
18958 tmp = qitmp(mgs) !+ qx(mgs,lh)
18959! IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl)
18960 cvm = cv+cvv*qvtmp(mgs)+cpl*(qx(mgs,lc)+qrtmp(mgs)) &
18961 +cpigb*(tmp)
18962
18963 felvcptmp = (felv(mgs)-rw*temg(mgs))/cvm
18964 felscptmp = (fels(mgs)-rw*temg(mgs))/cvm
18965 ENDIF
18966
18967
18968! qitmp(mgs) = qx(mgs,li)
18969 qctmp(mgs) = qctmp(mgs) + dqcw(mgs) ! dqcw is zero
18970 qitmp(mgs) = qitmp(mgs) + dqci(mgs)
18971 thetaptmp = thetaptmp + &
18972 & 1./pi0(mgs)* &
18973 & (felvcp(mgs)*dqcw(mgs) +felscp(mgs)*dqci(mgs))
18974
18975
18976 end if ! } dqwv(mgs) .lt. 0. (end of evap/sublim)
18977!
18978! condensation/deposition
18979!
18980 IF ( dqwv(mgs) .ge. 0. ) THEN ! {
18981
18982! write(iunit,*) 'satadj: mgs,iter = ',mgs,itertd,dqwv(mgs),qss(mgs),qx(mgs,lv),qx(mgs,lc)
18983!
18984! qitmp(mgs) = qx(mgs,li)
18985 fracl(mgs) = 0.0
18986 fraci(mgs) = 1.0
18987 if ( temg(mgs) .lt. tfr .and. temg(mgs) .gt. thnuc ) then
18988! fracl(mgs) = max(min(1.,(temg(mgs)-233.15)/(20.)),0.0)
18989! fraci(mgs) = 1.0-fracl(mgs)
18990 end if
18991 if ( temg(mgs) .le. thnuc ) then
18992 fraci(mgs) = 1.0
18993 fracl(mgs) = 0.0
18994 end if
18995! fraci(mgs) = 1.0-fracl(mgs)
18996
18997 gamss = (felvcp(mgs)*fracl(mgs) + felscp(mgs)*fraci(mgs)) &
18998 & / (pi0(mgs))
18999
19000 dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv2(mgs)*qsstmp/ &
19001 & ((temg(mgs)-cbi)**2))
19002
19003 if ( temg(mgs) .ge. tfr ) then
19004 dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv1(mgs)*qsstmp/ &
19005 & ((temg(mgs)-cbw)**2))
19006 end if
19007
19008 delqci1=qx(mgs,li)
19009
19010
19011 dqcw(mgs) = dqvcnd(mgs)*fracl(mgs) ! is zero
19012 dqci(mgs) = dqvcnd(mgs)*fraci(mgs)
19013
19014 thetaptmp = thetaptmp + &
19015 & (felvcp(mgs)*dqcw(mgs) + felscp(mgs)*dqci(mgs)) &
19016 & / (pi0(mgs))
19017
19018 qvptmp = qvptmp - ( dqvcnd(mgs) )
19019 qctmp(mgs) = qctmp(mgs) + dqcw(mgs)
19020 qitmp(mgs) = qitmp(mgs) + dqci(mgs)
19021
19022 IF ( itertd == 2 .and. eqtset > 1 ) THEN
19023 ! if eqtset == 2, then need to update the latent heats for change in hydrometeor content
19024 tmp = qitmp(mgs) ! + qx(mgs,lh)
19025! IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl)
19026 cvm = cv+cvv*qvtmp(mgs)+cpl*(qctmp(mgs) +qrtmp(mgs)) &
19027 +cpigb*(tmp)
19028
19029 felvcptmp = (felv(mgs)-rw*temg(mgs))/cvm
19030 felscptmp = (fels(mgs)-rw*temg(mgs))/cvm
19031 ENDIF
19032
19033 IF ( eqtset > 2 ) THEN
19034 pipert(mgs) = pipert(mgs) + (0 &
19035 & +felspi(mgs)*dqci(mgs) &
19036 & +felvpi(mgs)*dqcw(mgs))*dtp
19037 ENDIF
19038
19039!
19040!
19041 END IF ! } dqwv(mgs) .ge. 0.
19042
19043
19044!
19045 IF ( itertd == 1 ) THEN
19046 ! update temporary saturation values
19047
19048 thetatmp = thetaptmp + theta0(mgs)
19049 temgtmp = thetatmp*pk(mgs) ! ( pres(mgs) / poo ) ** cap
19050 qvaptmp = max((qvptmp + qv0(mgs)), 0.0)
19051 temcgtmp = temgtmp - tfr
19052 tqvcon = temgtmp-cbw
19053 ltemq = (temgtmp-163.15)/fqsat+1.5
19054 ltemq = min( nqsat, max(1,ltemq) )
19055 qvstmp = pqs(mgs)*tabqvs(ltemq)
19056 qisstmp = pqs(mgs)*tabqis(ltemq)
19057 qctmp(mgs) = max( 0.0, qctmp(mgs) )
19058 qitmp(mgs) = max( 0.0, qitmp(mgs) )
19059 qvtmp(mgs) = max( 0.0, qvaptmp )
19060
19061! qsstmp = qvstmp
19062 qsstmp = qisstmp
19063
19064 ELSE
19065 ! set max depletion
19066 qctmp(mgs) = max( 0.0, qctmp(mgs) )
19067 qitmp(mgs) = max( 0.0, qitmp(mgs) )
19068
19069 IF ( qitmp(mgs) < qitmp1 ) THEN
19070 qsimxsub(mgs) = (qitmp1 - qitmp(mgs))*dtpinv
19071 ELSEIF ( qitmp(mgs) > qitmp1 ) THEN
19072 qsimxdep(mgs) = (qitmp(mgs) - qitmp1)*dtpinv
19073 ENDIF
19074
19075
19076 ENDIF
19077! pceds(mgs) = (thetap(mgs) - thsave(mgs))*dtpinv
19078! write(iunit,*) 'satadj2: mgs,iter = ',mgs,itertd,dqwv(mgs),qss(mgs),qxtmp,qctmp(mgs)
19079!
19080! end the saturation adjustment iteration loop
19081!
19082 end do ! itertd
19083
19084 ENDIF
19085
19086 end do ! mgs
19087
19088 ELSE
19089
19090 DO mgs = 1,ngscnt
19091 qsimxdep(mgs) = qvimxd(mgs)
19092 qsimxsub(mgs) = 1.e20
19093 ENDDO
19094
19095 ENDIF
19096
19097! end of qlimit
19098
19099 qhcev(:) = 0.0
19100 chcev(:) = 0.0
19101 qhlcev(:) = 0.0
19102 chlcev(:) = 0.0
19103 qfcev(:) = 0.0
19104
19105 do mgs = 1,ngscnt
19106 qisbv(mgs) = 0.0
19107 qssbv(mgs) = 0.0
19108 qidpv(mgs) = 0.0
19109 qsdpv(mgs) = 0.0
19110 qhsbv(mgs) = 0.0
19111 qscev(mgs) = 0.0
19112 cscev(mgs) = 0.0
19113 IF ( icond .eq. 1 .or. temg(mgs) .le. tfrh &
19114 & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN ! last condition (qr<qmin & qc<qmin) for case icond=0
19115! qisbv(mgs) = max( min(qidsv(mgs), 0.0), -qimxd(mgs) )
19116! qssbv(mgs) = max( min(qsdsv(mgs), 0.0), -qsmxd(mgs) )
19117! erm 5/10/2007:
19118 qisbv(mgs) = max( min(qidsv(mgs), 0.0), min( -qimxd(mgs), -0.5*qx(mgs,li)*dtpinv ) )
19119 IF ( temg(mgs) < tfr .or. .not. qsmlr(mgs) < 0.0 ) THEN
19120 qssbv(mgs) = max( min(qsdsv(mgs), 0.0), min( -qsmxd(mgs), -0.5*qx(mgs,ls)*dtpinv ) )
19121 ENDIF
19122 qidpv(mgs) = max(qidsv(mgs), 0.0)
19123 qsdpv(mgs) = max(qsdsv(mgs), 0.0)
19124
19125 IF ( qsmlr(mgs) < 0.0 .and. .not. mixedphase ) THEN ! switch snow sublimation to evaporation if there is melting
19126
19127 qscev(mgs) = evapfac* &
19128 & 4.0*pi*(qx(mgs,lv)-qss0(mgs))*cx(mgs,ls)*swcap(mgs)*swvent(mgs)/(qss0(mgs)*(fav(mgs)+fbv(mgs)))
19129 qscev(mgs) = max( min(0.0,qscev(mgs)), min( -qsmxd(mgs), -0.5*qx(mgs,ls)*dtpinv ) )
19130 ELSE
19131
19132 ENDIF
19133
19134
19135
19136 ELSE
19137 qisbv(mgs) = 0.0
19138 qssbv(mgs) = 0.0
19139 qidpv(mgs) = 0.0
19140 qsdpv(mgs) = 0.0
19141 ENDIF
19142
19143 qhsbv(mgs) = 0.0
19144 qhdpv(mgs) = 0.0
19145 IF ( qx(mgs,lh) > qxmin(lh) ) THEN
19146 IF ( temg(mgs) < tfr .or. .not. qhmlr(mgs) < 0.0 ) THEN
19147 ! no liquid from melting, so evaporation is greater. Thus can calculate sublimation rate
19148 qhsbv(mgs) = max( min(qhdsv(mgs), 0.0), -qhmxd(mgs) )
19149 qhdpv(mgs) = max(qhdsv(mgs), 0.0)
19150 ENDIF
19151
19152 IF ( .true. .and. qhmlr(mgs) < 0.0 .and. .not. mixedphase ) THEN
19153 ! Liquid is forming, so find the evaporation that was subtracted from melting (if it is not condensing)
19154! qhcev(mgs) = &
19155! & evapfac*min( &
19156! & fmlt1e(mgs)*cx(mgs,lh)*hwvent(mgs)*xdia(mgs,lh,1), 0.0 )
19157
19158 qhcev(mgs) = evapfac*2.0*pi*(qx(mgs,lv)-qss0(mgs))* &
19159 & cx(mgs,lh)*xdia(mgs,lh,1)*hwvent(mgs)/(qss0(mgs)*(fav(mgs)+fbv(mgs)))
19160
19161 qhcev(mgs) = max(qhcev(mgs), -qhmxd(mgs))
19162 IF ( temg(mgs) > tfr ) qhcev(mgs) = min(0.0, qhcev(mgs) )
19163
19164 ENDIF
19165 ENDIF
19166
19167
19168 qhlsbv(mgs) = 0.0
19169 qhldpv(mgs) = 0.0
19170 IF ( lhl .gt. 1 ) THEN
19171 IF ( qx(mgs,lhl) > qxmin(lhl) ) THEN
19172 IF ( temg(mgs) < tfr .or. .not. qhlmlr(mgs) < 0.0 ) THEN
19173 qhlsbv(mgs) = max( min(qhldsv(mgs), 0.0), -qxmxd(mgs,lhl) )
19174 qhldpv(mgs) = max(qhldsv(mgs), 0.0)
19175 ENDIF
19176 IF ( qhlmlr(mgs) < 0.0 .and. .not. mixedphase ) THEN
19177 ! Liquid is forming, so find the evaporation that was subtracted from melting (if it is not condensing)
19178 qhlcev(mgs) = evapfac*2.0*pi*(qx(mgs,lv)-qss0(mgs))* &
19179 & cx(mgs,lhl)*xdia(mgs,lhl,1)*hlvent(mgs)/(qss0(mgs)*(fav(mgs)+fbv(mgs)))
19180
19181 qhlcev(mgs) = max(qhlcev(mgs), -qhlmxd(mgs))
19182 IF ( temg(mgs) > tfr ) qhlcev(mgs) = min(0.0, qhlcev(mgs) )
19183
19184 ENDIF
19185 ENDIF
19186 ENDIF
19187
19188 temp1 = qidpv(mgs) + qsdpv(mgs) + qhdpv(mgs) + qhldpv(mgs)
19189
19190! IF ( temp1 .gt. qvimxd(mgs) ) THEN
19191
19192! frac = qvimxd(mgs)/temp1
19193
19194 IF ( temp1 .gt. qsimxdep(mgs) ) THEN
19195 frac = qsimxdep(mgs)/temp1
19196
19197 qidpv(mgs) = frac*qidpv(mgs)
19198 qsdpv(mgs) = frac*qsdpv(mgs)
19199 qhdpv(mgs) = frac*qhdpv(mgs)
19200 qhldpv(mgs) = frac*qhldpv(mgs)
19201
19202! IF ( ny .eq. 2 .and. igs(mgs) .eq. 302 .and. temg(mgs) .le. tfrh+10 .and. qx(mgs,lv) .gt. qis(mgs)
19203! : .and. qx(mgs,li) .gt. qxmin(li) ) THEN
19204! write(0,*) 'qidpv,frac = ',kgs(mgs),qidpv(mgs),frac
19205! ENDIF
19206
19207 ENDIF
19208
19209 temp1 = qisbv(mgs) + qssbv(mgs) + qhsbv(mgs) + qhlsbv(mgs)
19210
19211
19212 IF ( temp1 < -qsimxsub(mgs) ) THEN
19213 frac = -qsimxsub(mgs)/temp1
19214
19215 qisbv(mgs) = frac*qisbv(mgs)
19216 qssbv(mgs) = frac*qssbv(mgs)
19217 qhsbv(mgs) = frac*qhsbv(mgs)
19218 qhlsbv(mgs) = frac*qhlsbv(mgs)
19219
19220! IF ( ny .eq. 2 .and. igs(mgs) .eq. 302 .and. temg(mgs) .le. tfrh+10 .and. qx(mgs,lv) .gt. qis(mgs)
19221! : .and. qx(mgs,li) .gt. qxmin(li) ) THEN
19222! write(0,*) 'qidpv,frac = ',kgs(mgs),qidpv(mgs),frac
19223! ENDIF
19224
19225 ENDIF
19226
19227
19228 end do
19229!
19230!
19231 if ( ipconc .ge. 1 ) then
19232 do mgs = 1,ngscnt
19233 cssbv(mgs) = (cx(mgs,ls)/(qx(mgs,ls)+1.e-20))*qssbv(mgs)
19234 cisbv(mgs) = (cx(mgs,li)/(qx(mgs,li)+1.e-20))*qisbv(mgs)
19235 chsbv(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhsbv(mgs)
19236 IF ( lhl .gt. 1 ) chlsbv(mgs) = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlsbv(mgs)
19237 csdpv(mgs) = 0.0 ! (cx(mgs,ls)/(qx(mgs,ls)+1.e-20))*qsdpv(mgs)
19238 cidpv(mgs) = 0.0 ! (cx(mgs,li)/(qx(mgs,li)+1.e-20))*qidpv(mgs)
19239 cisdpv(mgs) = 0.0
19240 chdpv(mgs) = 0.0 ! (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhdpv(mgs)
19241 chldpv(mgs) = 0.0
19242 end do
19243 end if
19244
19245!
19246! Aggregation or size conversion of small crystals to snow
19247!
19248 if (ndebug .gt. 0 ) write(0,*) 'conc 29a'
19249 do mgs = 1,ngscnt
19250 qscni(mgs) = 0.0
19251 cscni(mgs) = 0.0
19252 cscnis(mgs) = 0.0
19253 if ( ipconc .ge. 4 .and. iscni .ge. 1 .and. qx(mgs,li) .gt. qxmin(li) ) then
19254 IF ( iscni .eq. 1 ) THEN
19255 qscni(mgs) = &
19256 & pi*rho0(mgs)*((0.25)/(6.0)) &
19257 & *eii(mgs)*(qx(mgs,li)**2)*(xdia(mgs,li,2)) &
19258 & *vtxbar(mgs,li,1)/xmas(mgs,li)
19259 cscni(mgs) = min(cimxd(mgs),qscni(mgs)*rho0(mgs)/xmas(mgs,li))
19260 cscnis(mgs) = 0.5*cscni(mgs)
19261 ELSEIF ( iscni .eq. 2 .or. iscni .eq. 4 .or. iscni .eq. 5 ) THEN ! Zeigler 1985/Zrnic 1993, sort of
19262 IF ( iscni .ne. 5 .and. qidpv(mgs) .gt. 0.0 .and. xdia(mgs,li,3) .ge. 100.e-6 ) THEN
19263 ! convert larger crystals to snow
19264! IF ( xdia(mgs,ls,3) .gt. xdia(mgs,li,3) ) THEN
19265! qscni(mgs) = Max(0.1,xdia(mgs,li,3)/xdia(mgs,ls,3))*qidpv(mgs)
19266! erm 9/5/08 changed max to min
19267 qscni(mgs) = min(0.5, xdia(mgs,li,3)/200.e-6)*qidpv(mgs)
19268! ELSE
19269! qscni(mgs) = 0.1*qidpv(mgs)
19270! ENDIF
19271 cscni(mgs) = fscni*qscni(mgs)*rho0(mgs)/max(rho_qs*xvmn(ls),xmas(mgs,li))
19272! cscni(mgs) = fscni*Min(cimxd(mgs),qscni(mgs)*rho0(mgs)/Max(xdn(mgs,ls)*xvmn(ls),xmas(mgs,li)))
19273! cscni(mgs) = Min(cimxd(mgs),qscni(mgs)*rho0(mgs)/xmas(mgs,li) )
19274! IF ( xdia(mgs,ls,3) .le. 200.e-6 ) THEN
19275 cscnis(mgs) = cscni(mgs)
19276! ELSE
19277! cscnis(mgs) = 0.0
19278! ENDIF
19279 ENDIF
19280
19281 IF ( iscni .ne. 4 ) THEN
19282 ! crystal aggregation to become snow
19283! erm 9/5/08 commented second line and added xv to 1st line (zrnic et al 1993)
19284 tmp = ess(mgs)*rvt*aa2*cx(mgs,li)*cx(mgs,li)*xv(mgs,li)
19285! : ((cinu + 2.)*xv(mgs,li)/(cinu + 1.) + xv(mgs,li))
19286
19287! csacs(mgs) = rvt*aa2*ess(mgs)*cx(mgs,ls)**2*xv(mgs,ls)
19288
19289 qscni(mgs) = qscni(mgs) + min( qxmxd(mgs,li), 2.0*tmp*xmas(mgs,li)*rhoinv(mgs) )
19290 cscni(mgs) = cscni(mgs) + min( cxmxd(mgs,li), 2.0*tmp )
19291 cscnis(mgs) = cscnis(mgs) + min( cxmxd(mgs,li), tmp )
19292 ENDIF
19293 ELSEIF ( iscni .eq. 3 ) THEN ! LFO
19294 qscni(mgs) = 0.001*eii(mgs)*max((qx(mgs,li)-1.e-3),0.0)
19295 qscni(mgs) = min(qscni(mgs),qxmxd(mgs,li))
19296 cscni(mgs) = qscni(mgs)*rho0(mgs)/xmas(mgs,li)
19297 cscnis(mgs) = 0.5*cscni(mgs)
19298! write(iunit,*) 'qscni, qi = ',qscni(mgs),qx(mgs,li),igs(mgs),kgs(mgs)
19299 ENDIF
19300
19301 ELSEIF ( ipconc < 4 ) THEN ! LFO
19302 IF ( lwsm6 ) THEN
19303 qimax = rhoinv(mgs)*roqimax
19304 qscni(mgs) = min(0.90*qx(mgs,li), max( 0.0, (qx(mgs,li) - qimax)*dtpinv ) )
19305 ELSE
19306 qscni(mgs) = 0.001*eii(mgs)*max((qx(mgs,li)-1.e-3),0.0)
19307 qscni(mgs) = min(qscni(mgs),qxmxd(mgs,li))
19308 ENDIF
19309 else ! 10-ice version
19310 if ( iscni > 0 .and. qx(mgs,li) .gt. qxmin(li) ) then
19311 qscni(mgs) = &
19312 & pi*rho0(mgs)*((0.25)/(6.0)) &
19313 & *eii(mgs)*(qx(mgs,li)**2)*(xdia(mgs,li,2)) &
19314 & *vtxbar(mgs,li,1)/xmas(mgs,li)
19315 cscni(mgs) = min(cimxd(mgs),qscni(mgs)*rho0(mgs)/xmas(mgs,li))
19316 end if
19317
19318 end if
19319 end do
19320
19321
19322
19323
19324
19325!
19326!
19327! compute dry growth rate of snow, graupel, and hail
19328!
19329 do mgs = 1,ngscnt
19330!
19331 qsdry(mgs) = qsacr(mgs) + qsacw(mgs) &
19332 & + qsaci(mgs)
19333!
19334 qhdry(mgs) = qhaci(mgs) + qhacs(mgs) &
19335 & + qhacr(mgs) &
19336 & + qhacw(mgs)
19337!
19338
19339 qhldry(mgs) = 0.0
19340 IF ( lhl .gt. 1 ) THEN
19341 qhldry(mgs) = qhlaci(mgs) + qhlacs(mgs) &
19342 & + qhlacr(mgs) &
19343 & + qhlacw(mgs)
19344 ENDIF
19345 end do
19346!
19347! set wet growth and shedding
19348!
19349 do mgs = 1,ngscnt
19350
19351 IF ( tfrdry < temg(mgs) .and. temg(mgs) < tfr ) THEN
19352!
19353! qswet(mgs) =
19354! > ( xdia(mgs,ls,1)*swvent(mgs)*cx(mgs,ls)*fwet1(mgs)
19355! > + fwet2(mgs)*(qsaci(mgs)+qsacir(mgs)
19356! > +qsacip(mgs)) )
19357! qswet(mgs) = max( 0.0, qswet(mgs))
19358!
19359! IF ( dnu(lh) .ne. 0. ) THEN
19360! qhwet(mgs) = qhdry(mgs)
19361! ELSE
19362 IF ( incwet == 0 ) THEN
19363 qhwet(mgs) = &
19364 & ( xdia(mgs,lh,1)*hwvent(mgs)*cx(mgs,lh)*fwet1(mgs) &
19365 & + fwet2(mgs)*(qhaci(mgs) + qhacs(mgs)) )
19366 qhwet(mgs) = max( 0.0, qhwet(mgs))
19367 ELSE
19368 ENDIF
19369
19370! ENDIF
19371
19372
19373 qhlwet(mgs) = 0.0
19374 IF ( lhl .gt. 1 ) THEN
19375 IF ( incwet == 0 ) THEN
19376 qhlwet(mgs) = &
19377 & ( xdia(mgs,lhl,1)*hlvent(mgs)*cx(mgs,lhl)*fwet1(mgs) &
19378 & + fwet2(mgs)*(qhlaci(mgs) + qhlacs(mgs)) )
19379 qhlwet(mgs) = max( 0.0, qhlwet(mgs))
19380
19381 ELSE
19382 ENDIF ! incwet
19383 ENDIF
19384
19385 ELSE
19386
19387 qhwet(mgs) = qhdry(mgs)
19388 qhlwet(mgs) = qhldry(mgs)
19389 ENDIF
19390!
19391! qhlwet(mgs) = qhldry(mgs)
19392
19393 end do
19394
19395!
19396! shedding rate
19397!
19398 qsshr(:) = 0.0
19399 qhshr(:) = 0.0
19400 qhlshr(:) = 0.0
19401 qhshh(:) = 0.0
19402 csshr(:) = 0.0
19403 csshrr(:) = 0.0
19404 chshr(:) = 0.0
19405 chlshr(:) = 0.0
19406 chshrr(:) = 0.0
19407 chlshrr(:) = 0.0
19408 vhshdr(:) = 0.0
19409 vhlshdr(:) = 0.0
19410 wetsfc(:) = .false.
19411 wetgrowth(:) = .false.
19412 wetsfchl(:) = .false.
19413 wetgrowthhl(:) = .false.
19414
19415 do mgs = 1,ngscnt
19416!
19417!
19418!
19419 qhshr(mgs) = min( 0.0, qhwet(mgs) - qhdry(mgs) ) ! water that freezes should never be more than what sheds
19420
19421
19422
19423 qhlshr(mgs) = min( 0.0, qhlwet(mgs) - qhldry(mgs) )
19424
19425!
19426! limit wet growth to only higher density particles
19427!
19428 qsshr(mgs) = 0.0
19429!
19430!
19431! no shedding for temperatures < 243.15
19432!
19433 if ( temg(mgs) .lt. 243.15 ) then
19434 qsshr(mgs) = 0.0
19435 qhshr(mgs) = 0.0
19436 qhlshr(mgs) = 0.0
19437 vhshdr(mgs) = 0.0
19438 vhlshdr(mgs) = 0.0
19439 wetsfc(mgs) = .false.
19440 wetgrowth(mgs) = .false.
19441 wetsfchl(mgs) = .false.
19442 wetgrowthhl(mgs) = .false.
19443 end if
19444!
19445! shed all at temperatures > 273.15
19446!
19447 if ( temg(mgs) .gt. tfr ) then
19448
19449 IF ( .false. ) THEN ! old and incorrect -- Thanks to Shaofeng Hua for noticing this error (9/17/2017)
19450 qsshr(mgs) = -qsdry(mgs)
19451 qhshr(mgs) = -qhdry(mgs)
19452 qhlshr(mgs) = -qhldry(mgs)
19453 ELSE ! new and correct
19454 ! note that the qxacr terms should be zero here, so shedding at T > 0 is all from the droplets
19455 qsshr(mgs) = - qsacr(mgs) - qsacw(mgs) ! -qsdry(mgs)
19456 qhlshr(mgs) = - qhlacw(mgs) - qhlacr(mgs) ! -qhldry(mgs)
19457 qhshr(mgs) = - qhacw(mgs) - qhacr(mgs) ! -qhdry(mgs)
19458
19459 ENDIF
19460
19461 vhshdr(mgs) = -vhacw(mgs) - vhacr(mgs)
19462 vhlshdr(mgs) = -vhlacw(mgs) - vhlacr(mgs)
19463 qhwet(mgs) = 0.0
19464 qhlwet(mgs) = 0.0
19465 end if
19466!
19467! if (qhshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) THEN
19468 wetsfc(mgs) = (qhshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) .or. ( qhmlr(mgs) < -qxmin(lh) .and. temg(mgs) > tfr )
19469 wetgrowth(mgs) = (qhshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr )
19470! ENDIF
19471 if (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) THEN
19472 wetsfchl(mgs) = (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) .or. ( qhlmlr(mgs) < -qxmin(lhl) .and. temg(mgs) > tfr )
19473 wetgrowthhl(mgs) = (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr )
19474 ENDIF
19475
19476 end do
19477!
19478 if ( ipconc .ge. 1 ) then
19479 do mgs = 1,ngscnt
19480 csshr(mgs) = 0.0 ! (cx(mgs,ls)/(qx(mgs,ls)+1.e-20))*Min(0.0,qsshr(mgs))
19481
19482 chshr(mgs) = 0.0 ! no change to graupel number concentration for wet-growth shedding
19483
19484 ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1)
19485 ! Base the drop size on the shedding regime
19486 ! 8/26/2015 ERM updated to use shedalp and tmpdiam
19487 ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1)
19488 chshrr(mgs) = rho0(mgs)*qhshr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lh)) ! into rain
19489
19490
19491
19492 chlshr(mgs) = 0.0
19493 chlshrr(mgs) = 0.0
19494 IF ( lhl .gt. 1 ) THEN
19495! chlshr(mgs) = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlshr(mgs)
19496
19497
19498 chlshr(mgs) = 0.0 ! no change to hail number concentration for wet-growth shedding
19499
19500 ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1)
19501 ! Base the drop size on the shedding regime
19502 ! 8/26/2015 ERM updated to use shedalp and tmpdiam
19503 ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1)
19504 chlshrr(mgs) = rho0(mgs)*qhlshr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lhl)) ! into rain
19505
19506 ENDIF ! ( lhl > 1 )
19507
19508
19509 end do
19510 end if
19511
19512
19513
19514!
19515! final decisions
19516!
19517 do mgs = 1,ngscnt
19518!
19519! Snow
19520!
19521 if ( qsshr(mgs) .lt. 0.0 ) then
19522 qsdpv(mgs) = 0.0
19523 qssbv(mgs) = 0.0
19524 else
19525 qsshr(mgs) = 0.0
19526 end if
19527!
19528! if ( qsdry(mgs) .lt. qswet(mgs) ) then
19529! qswet(mgs) = 0.0
19530! else
19531! qsdry(mgs) = 0.0
19532! end if
19533!
19534
19535! graupel
19536!
19537!
19538 if ( wetgrowth(mgs) .or. (mixedphase .and. fhw(mgs) .gt. 0.05 .and. temg(mgs) .gt. 243.15) ) then
19539
19540
19541! soaking (when not advected liquid water film with graupel)
19542
19543 IF ( lvol(lh) .gt. 1 .and. .not. mixedphase) THEN
19544 ! rescale volumes to maximum density
19545 IF ( iwetsoak ) THEN
19546
19547 rimdn(mgs,lh) = xdnmx(lh)
19548 raindn(mgs,lh) = xdnmx(lh)
19549 vhacw(mgs) = qhacw(mgs)*rho0(mgs)/rimdn(mgs,lh)
19550 vhacr(mgs) = qhacr(mgs)*rho0(mgs)/raindn(mgs,lh)
19551! IF ( lvol(lh) .gt. 1 .and. wetgrowth(mgs) ) THEN
19552 IF ( xdn(mgs,lh) .lt. xdnmx(lh) ) THEN
19553 ! soak some liquid into the graupel
19554! v1 = xdnmx(lh)*vx(mgs,lh)/(xdn(mgs,lh)*dtp) ! volume available for filling
19555 v1 = (1. - xdn(mgs,lh)/xdnmx(lh))*vx(mgs,lh)/(dtp) ! volume available for filling
19556! tmp = (vx(mgs,lh)/rho0(mgs))*(xdnmx(lh) - xdn(mgs,lh)) ! max mixing ratio of liquid water that can be added
19557 v2 = rho0(mgs)*qhwet(mgs)/xdnmx(lh) ! volume of frozen accretion
19558
19559 vhsoak(mgs) = min(v1,v2)
19560
19561
19562 ENDIF
19563
19564 ENDIF
19565
19566 vhshdr(mgs) = min(0.0, rho0(mgs)*qhwet(mgs)/xdnmx(lh) - vhacw(mgs) - vhacr(mgs) )
19567
19568 ELSEIF ( lvol(lh) .gt. 1 .and. mixedphase ) THEN
19569! vhacw(mgs) = rho0(mgs)*qhacw(mgs)/xdn0(lr)
19570! vhacr(mgs) = rho0(mgs)*qhacr(mgs)/xdn0(lr)
19571 ENDIF
19572
19573
19574 qhdpv(mgs) = 0.0
19575! qhsbv(mgs) = 0.0
19576 chdpv(mgs) = 0.0
19577! chsbv(mgs) = 0.0
19578
19579! collection efficiency modification
19580
19581 IF ( ehi(mgs) .gt. 0.0 ) THEN
19582 qhaci(mgs) = min(qimxd(mgs),qhaci0(mgs)) ! effectively sets collection eff to 1
19583 chaci(mgs) = min(cimxd(mgs),chaci0(mgs)) ! effectively sets collection eff to 1
19584 ENDIF
19585 IF ( ehs(mgs) .gt. 0.0 ) THEN
19586! qhacs(mgs) = Min(qsmxd(mgs),qhacs(mgs)/ehs(mgs)) ! effectively sets collection eff to 1
19587 qhacs(mgs) = min(qsmxd(mgs),qhacs0(mgs)) !/ehs(mgs) ! divide out the collection efficiency
19588 chacs(mgs) = min(csmxd(mgs),chacs0(mgs)) !/ehs(mgs) ! divide out the collection efficiency
19589 ehs(mgs) = ehsmax ! 1.0 ! min(ehsfrac*ehs(mgs),ehsmax) ! modify it
19590 qhacs(mgs) = min(qsmxd(mgs),qhacs(mgs)) ! plug it back in
19591 ENDIF
19592
19593! be sure to catch particles with wet surfaces but not in wet growth to turn off Hallett-Mossop
19594 wetsfc(mgs) = .true.
19595
19596 else
19597! qhshr(mgs) = 0.0
19598 end if
19599!
19600!
19601! hail
19602!
19603! if ( lhl .gt. 1 .and. qhlshr(mgs) .lt. 0.0 ) then
19604 if ( lhl > 1 .and. ( wetgrowthhl(mgs) .or. (mixedphase .and. fhlw(mgs) .gt. 0.05 .and. temg(mgs) .gt. 243.15) ) ) then
19605! if ( wetgrowthhl(mgs) ) then
19606
19607
19608 qhldpv(mgs) = 0.0
19609! qhlsbv(mgs) = 0.0
19610 chldpv(mgs) = 0.0
19611! chlsbv(mgs) = 0.0
19612
19613
19614
19615
19616 IF ( lvol(lhl) .gt. 1 .and. .not. mixedphase ) THEN
19617! IF ( lvol(lhl) .gt. 1 .and. wetgrowthhl(mgs) ) THEN
19618
19619 IF ( iwetsoak ) THEN
19620
19621 rimdn(mgs,lhl) = xdnmx(lhl)
19622 raindn(mgs,lhl) = xdnmx(lhl)
19623 vhlacw(mgs) = qhlacw(mgs)*rho0(mgs)/rimdn(mgs,lhl)
19624 vhlacr(mgs) = qhlacr(mgs)*rho0(mgs)/raindn(mgs,lhl)
19625
19626 IF ( xdn(mgs,lhl) .lt. xdnmx(lhl) ) THEN
19627 ! soak some liquid into the hail
19628! v1 = xdnmx(lhl)*vx(mgs,lhl)/(xdn(mgs,lhl)*dtp) ! volume available for filling
19629 v1 = (1. - xdn(mgs,lhl)/xdnmx(lhl))*vx(mgs,lhl)/(dtp) ! volume available for filling
19630! tmp = (vx(mgs,lhl)/rho0(mgs))*(xdnmx(lhl) - xdn(mgs,lhl)) ! max mixing ratio of liquid water that can be added
19631 v2 = rho0(mgs)*qhlwet(mgs)/xdnmx(lhl) ! volume of frozen accretion
19632 IF ( v1 > v2 ) THEN ! all the frozen stuff fits in
19633 vhlsoak(mgs) = v2
19634 ELSE ! fill up the available space
19635 vhlsoak(mgs) = v1
19636 ENDIF
19637! vhlacw(mgs) = 0.0
19638! vhlacr(mgs) = Max( 0.0, v2 - v1 )
19639 ELSE
19640 vhlsoak(mgs) = 0.0
19641! vhlacw(mgs) = 0.0
19642! vhlacr(mgs) = rho0(mgs)*qhlwet(mgs)/raindn(mgs,lhl)
19643
19644 ENDIF
19645
19646 ENDIF
19647
19648 vhlshdr(mgs) = min(0.0, rho0(mgs)*qhlwet(mgs)/xdnmx(lhl) - vhlacw(mgs) - vhlacr(mgs) )
19649
19650
19651 ELSEIF ( lvol(lhl) .gt. 1 .and. mixedphase ) THEN
19652! vhlacw(mgs) = rho0(mgs)*qhlacw(mgs)/xdn0(lr)
19653! vhlacr(mgs) = rho0(mgs)*qhlacr(mgs)/xdn0(lr)
19654 ENDIF
19655
19656 IF ( ehli(mgs) .gt. 0.0 ) THEN
19657 qhlaci(mgs) = min(qimxd(mgs),qhlaci0(mgs)) ! effectively sets collection eff to 1
19658 chlaci(mgs) = min(cimxd(mgs),chlaci0(mgs)) ! effectively sets collection eff to 1
19659 ENDIF
19660
19661! IF ( ehls(mgs) .gt. 0.0 ) THEN
19662! qhlacs(mgs) = Min(qsmxd(mgs),qhlacs(mgs)/ehls(mgs))
19663! ENDIF
19664 IF ( ehls(mgs) .gt. 0.0 ) THEN
19665 qhlacs(mgs) = min(qsmxd(mgs),qhlacs0(mgs)) !/ehls(mgs) ! divide out the collection efficiency
19666 chlacs(mgs) = min(csmxd(mgs),chlacs0(mgs)) !/ehls(mgs) ! divide out the collection efficiency
19667 ehls(mgs) = ehsmax ! 1.0 ! min(ehsfrac*ehs(mgs),ehsmax) ! modify it
19668! qhlacs(mgs) = Min(qsmxd(mgs),qhlacs(mgs)) ! plug it back in
19669 ENDIF
19670
19671
19672! qhlwet(mgs) = 1.0
19673
19674! be sure to catch particles with wet surfaces but not in wet growth to turn off Hallett-Mossop
19675 wetsfchl(mgs) = .true.
19676
19677
19678 else
19679! qhlshr(mgs) = 0.0
19680! qhlwet(mgs) = 0.0
19681 end if
19682
19683 end do
19684!
19685! Ice -> graupel conversion
19686!
19687 DO mgs = 1,ngscnt
19688
19689 qhcni(mgs) = 0.0
19690 chcni(mgs) = 0.0
19691 chcnih(mgs) = 0.0
19692 vhcni(mgs) = 0.0
19693
19694 IF ( iglcnvi .ge. 1 ) THEN
19695 IF ( temg(mgs) .lt. 273.0 .and. qiacw(mgs) - qidpv(mgs) .gt. 0.0 ) THEN
19696
19697
19698 tmp = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) &
19699 & *((0.60)*vtxbar(mgs,li,1)) &
19700 & /(temg(mgs)-273.15))**(rimc2)
19701 tmp = min( max( rimc3, tmp ), 900.0 )
19702
19703 ! Assume that half the volume of the embryo is rime with density 'tmp'
19704 ! m = rhoi*(V/2) + rhorime*(V/2) = (rhoi + rhorime)*V/2
19705 ! V = 2*m/(rhoi + rhorime)
19706
19707! write(0,*) 'rime dens = ',tmp
19708
19709 IF ( tmp .ge. 200.0 .or. iglcnvi >= 2 ) THEN
19710 r = max( 0.5*(xdn(mgs,li) + tmp), xdnmn(lh) )
19711! r = Max( r, 400. )
19712 qhcni(mgs) = (qiacw(mgs) - qidpv(mgs)) ! *float(iglcnvi)
19713 chcni(mgs) = cx(mgs,li)*qhcni(mgs)/qx(mgs,li)
19714! chcnih(mgs) = rho0(mgs)*qhcni(mgs)/(1.6e-10)
19715 chcnih(mgs) = min(chcni(mgs), rho0(mgs)*qhcni(mgs)/(r*xvmn(lh)) )
19716! vhcni(mgs) = rho0(mgs)*2.0*qhcni(mgs)/(xdn(mgs,li) + tmp)
19717 vhcni(mgs) = rho0(mgs)*qhcni(mgs)/r
19718 ENDIF
19719
19720 ELSEIF ( iglcnvi == 3 ) THEN
19721
19722 IF ( temg(mgs) .lt. 273.0 .and. qiacw(mgs)*dtp > 2.*qxmin(lh) .and. gamice73fac*xmas(mgs,li) > xdnmn(lh)*xvmn(lh) ) THEN
19723
19724
19725 tmp = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) &
19726 & *((0.60)*vtxbar(mgs,li,1)) &
19727 & /(temg(mgs)-273.15))**(rimc2)
19728 tmp = min( max( rimc3, tmp ), 900.0 )
19729
19730 ! Assume that half the volume of the embryo is rime with density 'tmp'
19731 ! m = rhoi*(V/2) + rhorime*(V/2) = (rhoi + rhorime)*V/2
19732 ! V = 2*m/(rhoi + rhorime)
19733
19734! write(0,*) 'rime dens = ',tmp
19735 ! convert to particles with the mass of the mass-weighted diameter
19736 ! massofmwr = gamice73fac*xmas(mgs,li)
19737
19738 IF ( tmp .ge. xdnmn(lh) ) THEN
19739 r = max( 0.5*(xdn(mgs,li) + tmp), xdnmn(lh) )
19740! r = Max( r, 400. )
19741 qhcni(mgs) = 0.5*qiacw(mgs)
19742 chcni(mgs) = qhcni(mgs)/(gamice73fac*xmas(mgs,li))
19743 chcnih(mgs) = min(chcni(mgs), rho0(mgs)*qhcni(mgs)/(r*xvmn(lh)) )
19744! vhcni(mgs) = rho0(mgs)*2.0*qhcni(mgs)/(xdn(mgs,li) + tmp)
19745 vhcni(mgs) = rho0(mgs)*qhcni(mgs)/r
19746 ENDIF
19747
19748 ENDIF
19749
19750
19751 ENDIF
19752 ENDIF
19753
19754
19755 ENDDO
19756
19757
19758 qhlcnh(:) = 0.0
19759 chlcnh(:) = 0.0
19760 chlcnhhl(:) = 0.0
19761 vhlcnh(:) = 0.0
19762 vhlcnhl(:) = 0.0
19763 zhlcnh(:) = 0.0
19764
19765 qhcnhl(:) = 0.0
19766 chcnhl(:) = 0.0
19767 vhcnhl(:) = 0.0
19768 zhcnhl(:) = 0.0
19769
19770
19771 IF ( lhl .gt. 1 ) THEN
19772
19773 IF ( ihlcnh == 1 .or. ihlcnh == 3 ) THEN
19774
19775!
19776! Graupel (h) conversion to hail (hl) based on Milbrandt and Yau 2005b
19777!
19778 DO mgs = 1,ngscnt
19779
19780! IF ( lhl .gt. 1 .and. ipconc .ge. 5 .and. qx(mgs,lh) .gt. 1.0e-3 .and.
19781! : xdn(mgs,lh) .gt. 750. .and. qhshr(mgs) .lt. 0.0 .and.
19782! : xdia(mgs,lh,3) .gt. 1.e-3 ) THEN
19783 IF ( hlcnhdia > 0 ) THEN
19784 ltest = xdia(mgs,lh,3) .gt. hlcnhdia ! test on mean volume diameter
19785 ELSE
19786! ltest = xdia(mgs,lh,1)*(3. + alpha(mgs,lh)) > Abs( hlcnhdia ) ! test on maximum mass diameter
19787 ltest = xdia(mgs,lh,1)*(4. + alpha(mgs,lh)) > abs( hlcnhdia ) ! test on mass-weighted diameter
19788 ENDIF
19789
19790 IF ( iusedw == 0 .and. ihlcnh == 1 ) THEN
19791 dg0(mgs) = -1.
19792 ELSE
19793 IF (((qhacw(mgs) + qhacr(mgs))*dtp > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin .and. temg(mgs) .le. tfr-2.0 &
19794 .and. temg(mgs) .gt. dwtempmin ) .or. ( wetgrowth(mgs) .and. qx(mgs,lh) > hlcnhqmin ) ) THEN
19795! 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 )
19796! dwr = 0.01*( Exp( -temcg(mgs)/( 1.1e4 * rho0(mgs)*(ehw(mgs)*qx(mgs,lc)+ehr(mgs)*qx(mgs,lr)) - &
19797! 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 ) ) - 1.0 )
19798 x = 1.1e4 * rho0(mgs)*(ehw(mgs)*qx(mgs,lc)+ehr(mgs)*qx(mgs,lr)) - &
19799 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0
19800 IF ( x > 1.e-20 ) THEN
19801 arg = min(70.0, (-temcg(mgs)/x )) ! prevent overflow of the exp function in 32 bit
19802 dwr = 0.01*(exp(arg) - 1.0)
19803 ELSE
19804 dwr = 1.e30
19805 ENDIF
19806 d = dwr
19807 IF ( dwr < 0.2 .and. dwr > 0.0 .and. rho0(mgs)*(qx(mgs,lc)+qx(mgs,lr)) > 1.e-4 ) THEN
19808 sqrtrhovt = sqrt( rhovt(mgs) )
19809 fventh = sqrtrhovt*(fpndl(mgs)**(1./3.)) * (fakvisc(mgs))**(-0.5)
19810 fventm = sqrtrhovt*(fschm(mgs)**(1./3.)) * (fakvisc(mgs))**(-0.5)
19811 ltemq = (tfr-163.15)/fqsat+1.5
19812 qvs0 = pqs(mgs)*tabqvs(ltemq)
19813 denomdp = felf(mgs) + fcw(mgs)*temcg(mgs)
19814 denominvdp = 1.d0/(felf(mgs) + fcw(mgs)*temcg(mgs))
19815
19816! write(91,*) 'dw,dwr,temcg = ',100.*dw,100.*dwr,temcg(mgs)
19817 h1 = ( -ftka(mgs)*temcg(mgs) - felv(mgs)*fwvdf(mgs)*rho0(mgs)*(qx(mgs,lv) - qvs0) )
19818 h2 = ehi(mgs)*qx(mgs,li)*rho0(mgs)*fci(mgs)*temcg(mgs)
19819 h3 = max(dwehwmin, ehw(mgs))*qx(mgs,lc)
19820 h4 = ehr(mgs)* qx(mgs,lr)
19821 ! iterate to find minimum diameter for wet growth. Start with value of dwr
19822 DO n = 1,10
19823 d = max(d, 1.e-4)
19824 dold = d
19825 vth = axx(mgs,lh)*d**bxx(mgs,lh)
19826 x2 = fventh*sqrtrhovt*sqrt(d*vth)
19827 IF ( x2 > 1.4 ) THEN
19828 ah = 0.78 + 0.308*x2 ! heat ventillation
19829 ELSE
19830 ah = 1.0 + 0.108*x2**2 ! mass ventillation (Beard and Pruppacher 1971, eq. 9)
19831 ENDIF
19832
19833 IF ( .false. ) THEN ! this option includes 'am' separate from ah, which makes only small differences. Otherwise equivalent to second option
19834 x1 = fventm*sqrtrhovt*sqrt(d*vth)
19835 IF ( x1 > 1.4 ) THEN
19836 am = 0.78 + 0.308*x1 ! mass ventillation (Beard and Pruppacher 1971, eq. 8)
19837 ELSE
19838 am = 1.0 + 0.108*x1**2 ! mass ventillation (Beard and Pruppacher 1971, eq. 9)
19839 ENDIF
19840
19841 d = 8.*denominvdp*( am*felv(mgs)*fwvdf(mgs)*rho0(mgs)*(qvs0 - qx(mgs,lv)) - ah*ftka(mgs)*temcg(mgs) )/ &
19842 (dtp* ( ( max(0.001,vth - vtxbar(mgs,lc,1))*h3 + &
19843 max(0.001,vth - vtxbar(mgs,lr,1))*h4) *rho0(mgs) + &
19844 max(0.001,vth - vtxbar(mgs,li,1))*h2*denominvdp))
19845
19846 ELSE
19847
19848 ! Based on Farley and Orville (1986), eq. 5-9 but neglecting the Ci*(T0-Ts) term in (8) since we want Ts=T0
19849 ! Simplified mass rates as dm_w/dt = pi/4*d**2*(Vh - Vc)*rhoair*qc*ehw, etc.
19850 d = 8.*ah*h1/ &
19851 ( ( max(0.001,vth - vtxbar(mgs,lc,1))*h3 + &
19852 max(0.001,vth - vtxbar(mgs,lr,1))*h4) *rho0(mgs)*denomdp + &
19853 max(0.001,vth - vtxbar(mgs,li,1))*h2)
19854
19855 ENDIF
19856 IF ( abs(dold - d)/dold < 0.05 .or. ( n > 3 .and. d > dg0thresh ) ) EXIT
19857
19858 ENDDO
19859 ENDIF
19860
19861 dg0(mgs) = min( dwmax, max( d, dwmin ) )
19862 ELSE
19863 IF ( qx(mgs,lh) > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin .and. temg(mgs) .le. tfr-2.0 ) THEN
19864 dg0(mgs) = dwmax
19865 ELSE
19866 dg0(mgs) = dg0thresh + 0.0001
19867 ENDIF
19868 ENDIF
19869
19870 IF ( ihlcnh == 3 .and. (qhacw(mgs) + qhacr(mgs))*dtp > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin &
19871 .and. temg(mgs) .le. tfr-2.0 ) THEN
19872 ! set a secondary condition on to capture large graupel that is riming but not in wet growth
19873 dg0(mgs) = min( dg0(mgs), dg0thresh - 0.0001 )
19874 ENDIF
19875
19876 ENDIF
19877
19878 wtest = (dg0(mgs) > 0.0 .and. dg0(mgs) < dg0thresh )
19879
19880 IF ( ihlcnh == 1 ) THEN ! .or. iusedw == 0 THEN
19881
19882 IF ( ( wetgrowth(mgs) .and. (xdn(mgs,lh) .gt. hldnmn .or. lvh < 1 ) .and. & ! correct this when hail gets turned on
19883 & rimdn(mgs,lh) .gt. 800. .and. &
19884 & ltest .and. qx(mgs,lh) .gt. hlcnhqmin ) .or. wtest ) THEN ! {
19885! : xdia(mgs,lh,3) .gt. 2.e-3 .and. qx(mgs,lh) .gt. 1.0e-3 THEN ! 0823.2008 erm test
19886! IF ( xdia(mgs,lh,3) .gt. 1.e-3 ) THEN
19887 IF ( qhacw(mgs) .gt. 0.0 .and. qhacw(mgs) .gt. qhaci(mgs) .and. temg(mgs) .le. tfr-2.0 ) THEN ! {
19888 ! dh0 is the diameter dividing wet growth from dry growth (Ziegler 1985), modified by MY05
19889! dh0 = 0.01*(exp(temcg(mgs)/(1.1e4*(qx(mgs,lc)+qx(mgs,lr)) -
19890! : 1.3e3*qx(mgs,li) + 1.0e-3 ) ) - 1.0)
19891 IF ( wtest ) THEN
19892 dh0 = dg0(mgs)
19893 ELSE
19894 x = (1.1e4*(rho0(mgs)*qx(mgs,lc)) - 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0e-3 )
19895 IF ( x > 1.e-20 ) THEN
19896 arg = min(70.0, (-temcg(mgs)/x )) ! prevent overflow of the exp function in 32 bit
19897 dh0 = 0.01*(exp(arg) - 1.0)
19898 ELSE
19899 dh0 = 1.e30
19900 ENDIF
19901 ENDIF ! wtest
19902! dh0 = Max( dh0, 5.e-3 )
19903
19904! IF ( dh0 .gt. 0.0 ) write(0,*) 'dh0 = ',dh0
19905! IF ( dh0 .gt. 1.0e-4 ) THEN
19906 IF ( xdia(mgs,lh,3)/dh0 .gt. 0.1 ) THEN !{
19907! IF ( xdia(mgs,lh,3) .lt. 20.*dh0 .and. dh0 .lt. 2.0*xdia(mgs,lh,3) ) THEN
19908 tmp = qhacw(mgs) + qhacr(mgs) + qhaci(mgs) + qhacs(mgs)
19909! qtmp = Min( 1.0, xdia(mgs,lh,3)/(2.0*dh0) )*(tmp)
19910 qtmp = min( 100.0, xdia(mgs,lh,3)/(2.0*dh0) )*(tmp)
19911 qhlcnh(mgs) = min( qxmxd(mgs,lh), qtmp )
19912
19913 IF ( ipconc .ge. 5 ) THEN !{
19914! dh0 = Max( xdia(mgs,lh,3), Min( dh0, 5.e-3 ) ) ! do not create hail greater than 5mm diam. unless the graupel is larger
19915 IF ( .not. wtest ) dh0 = min( dh0, 10.e-3 ) ! do not create hail greater than 10mm diam., which is the max graupel size
19916 IF ( qx(mgs,lhl) > 0.1e-3 ) dh0 = max( dh0, xdia(mgs,lhl,3) ) ! when enough hail is established, do not dilute the size
19917 chlcnhhl(mgs) = min( cxmxd(mgs,lh), rho0(mgs)*qhlcnh(mgs)/(pi*xdn(mgs,lh)*dh0**3/6.0) )
19918
19919 r = rho0(mgs)*qhlcnh(mgs)/(xdn(mgs,lh)*xv(mgs,lh)) ! number of graupel particles at mean volume diameter
19920 chlcnh(mgs) = max( chlcnhhl(mgs), r )
19921 ENDIF !}
19922
19923 vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh)
19924 vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/max(xdnmn(lhl), xdn(mgs,lh))
19925
19926 ENDIF !}
19927
19928 ENDIF ! }
19929 ENDIF ! }
19930
19931 ELSEIF ( ihlcnh == 3 ) THEN !{
19932
19933
19934 IF ( wtest .and. &
19935 ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr-2. .and. qx(mgs,lh) > hlcnhqmin ) ) THEN
19936 ! convert number, mass, and reflectivity for d > dw
19937 IF ( ipconc == 5 ) THEN
19938 ! dg0(mgs) = Min( dg0(mgs), hldia1 )
19939 !dg0(mgs) = hldia1
19940 ENDIF
19941
19942 ratio = min( maxratiolu, dg0(mgs)/xdia(mgs,lh,1) )
19943
19944
19945 ! mass
19946 tmp2 = gaminterp(ratio,alpha(mgs,lh),4,1)
19947 IF ( ipconc == 5 ) THEN
19948 ! tmp2 = Min( 0.25, tmp2 )
19949 ENDIF
19950 qxd1 = qx(mgs,lh)*(tmp2)
19951 qhlcnh(mgs) = dtpinv*qxd1
19952 flim = 1.0
19953 tmp3 = qxmxd(mgs,lh)
19954 IF (qxd1 > tmp3 ) THEN
19955! flim = tmp3/(qxd1)
19956! qhlcnh(mgs) = flim*qhlcnh(mgs)
19957 ENDIF
19958
19959
19960
19961 IF ( ( qxd1 > qxmin(lhl) .and. ipconc > 5 ) .or. ( qxd1 > 10.*qxmin(lhl) .and. ipconc == 5) ) THEN
19962
19963 ! number
19964 tmp = gaminterp(ratio,alpha(mgs,lh),1,1)
19965 IF ( ipconc == 5 ) THEN
19966 ! tmp = Min( 0.2, tmp )
19967 ENDIF
19968 cxd1 = flim*cx(mgs,lh)*( tmp)
19969 chlcnh(mgs) = dtpinv*cxd1
19970 chlcnhhl(mgs) = chlcnh(mgs)
19971
19972 IF ( qx(mgs,lhl) > qxmin(lhl) .and. dmhlopt > 0 ) THEN
19973 tmp = rho0(mgs)*qhlcnh(mgs)/chlcnhhl(mgs)
19974 IF ( tmp < xmas(mgs,lhl) ) THEN
19975 ! dh0 = ( qxd1*dh0 + qx(mgs,lhl)*xmas(mgs,lhl))/( qxd1 + qx(mgs,lhl)) ! weighted average
19976 dh0 = (( qxd1*tmp**(1./3.) + qx(mgs,lhl)*xmas(mgs,lhl)**(1./3.))/( qxd1 + qx(mgs,lhl)))**3 ! weighted average
19977 chlcnhhl(mgs) = min( chlcnhhl(mgs), rho0(mgs)*qhlcnh(mgs)/dh0 )
19978 ELSE
19979! dh0 = Max( dh0, xmas(mgs,lhl) ) ! when enough hail is established, do not dilute the size
19980 ENDIF
19981 ENDIF
19982
19983
19984 ! reflectivity
19985 IF ( ipconc >= 6 .and. lzh > 1 .and. lzhl > 1 ) THEN
19986 tmp3 = gaminterp(ratio,alpha(mgs,lh),11,1)
19987 zxd1 = flim*zx(mgs,lh)*(tmp3)
19988 zhlcnh(mgs) = dtpinv*zxd1
19989 ELSE
19990 zxd1 = 0
19991 ENDIF
19992
19993 ELSE
19994 qhlcnh(mgs) = 0.0
19995 ENDIF
19996
19997 vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh)
19998 vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/max(xdnmn(lhl), xdn(mgs,lh))
19999
20000 ENDIF
20001
20002
20003 ENDIF !}
20004
20005 ENDDO
20006
20007 ELSEIF ( ihlcnh == 2 ) THEN ! 10-ice type conversion
20008
20009!
20010! Staka and Mansell (2005) type conversion
20011!
20012! hldia1 is set in micro_module and namelist
20013! IF ( .true. ) THEN
20014
20015 ! convert number, mass, and reflectivity for d > hldia1,
20016 ! regardless of wet growth status, but as long as riming > 0
20017 DO mgs = 1,ngscnt
20018 IF ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr-2. .and. qx(mgs,lh) > qxmin(lh) ) THEN
20019 ratio = min( maxratiolu, hldia1/xdia(mgs,lh,1) )
20020
20021 ! number
20022 tmp = gaminterp(ratio,alpha(mgs,lh),1,1)
20023 cxd1 = cx(mgs,lh)*( tmp)
20024 chlcnh(mgs) = dtpinv*cxd1
20025 chlcnhhl(mgs) = chlcnh(mgs)
20026
20027 ! mass
20028 tmp2 = gaminterp(ratio,alpha(mgs,lh),4,1)
20029 qxd1 = qx(mgs,lh)*(tmp2)
20030 qhlcnh(mgs) = dtpinv*qxd1
20031
20032 ! reflectivity
20033 IF ( lzh > 1 .and. lzhl > 1 ) THEN
20034 tmp3 = gaminterp(ratio,alpha(mgs,lh),11,1)
20035 zxd1 = zx(mgs,lh)*(tmp3)
20036 zhlcnh(mgs) = dtpinv*zxd1
20037 ELSE
20038 zxd1 = 0
20039 ENDIF
20040 vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh)
20041 vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/max(xdnmn(lhl), xdn(mgs,lh))
20042
20043 ENDIF
20044
20045 ENDDO
20046! ENDIF
20047 ELSEIF ( ihlcnh == 0 ) THEN
20048
20049 do mgs = 1,ngscnt
20050! qhlcnh(mgs) = 0.0
20051! chlcnh(mgs) = 0.0
20052 if ( wetgrowth(mgs) .and. temg(mgs) .lt. tfr-5. .and. qx(mgs,lh) > qxmin(lh) ) then
20053 if ( qhacw(mgs).gt.1.e-6 .and. xdn(mgs,lh) > 700. ) then
20054 qhlcnh(mgs) = &
20055 ((pi*xdn(mgs,lh)*cx(mgs,lh)) / (6.0*rho0(mgs)*dtp)) &
20056 *exp(-hldia1/xdia(mgs,lh,1)) &
20057 *( (hldia1**3) + 3.0*(hldia1**2)*xdia(mgs,lh,1) &
20058 + 6.0*(hldia1)*(xdia(mgs,lh,1)**2) + 6.0*(xdia(mgs,lh,1)**3) )
20059 qhlcnh(mgs) = min(qhlcnh(mgs),qhmxd(mgs))
20060 IF ( ipconc .ge. 5 ) THEN
20061 chlcnh(mgs) = min( cxmxd(mgs,lh), cx(mgs,lh)*exp(-hldia1/xdia(mgs,lh,1)))
20062 chlcnhhl(mgs) = chlcnh(mgs)
20063! chlcnh(mgs) = Min( cxmxd(mgs,lh), rho0(mgs)*qhlcnh(mgs)/(2.0*xmas(mgs,lh) ))
20064 ENDIF
20065 vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh)
20066 vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/max(xdnmn(lhl), xdn(mgs,lh))
20067 end if
20068 end if
20069 end do
20070
20071! ENDIF ! true
20072
20073 ENDIF ! ihlcnh options
20074
20075 ! convert low-density hail to graupel
20076 IF ( icvhl2h >= 1 ) THEN
20077 DO mgs = 1,ngscnt
20078 IF ( qx(mgs,lhl) > qxmin(lhl) .and. xdn(mgs,lhl) < 0.5*(xdnmn(lhl) + xdnmx(lhl)) ) THEN
20079 tmp = min(0.95, 1. - 0.5*(1. + tanh(0.125*(xdn(mgs,lhl) - 1.01*xdnmn(lhl) )) ))
20080 qhcnhl(mgs) = tmp*qx(mgs,lhl)*dtpinv
20081 chcnhl(mgs) = cx(mgs,lhl)*qhcnhl(mgs)/qx(mgs,lhl)
20082 vhcnhl(mgs) = vx(mgs,lhl)*qhcnhl(mgs)/qx(mgs,lhl)
20083
20084 ENDIF
20085 ENDDO
20086
20087 ENDIF
20088
20089 ENDIF ! lhl > 1
20090
20091
20092
20093
20094!
20095! Ziegler snow conversion to graupel
20096!
20097 DO mgs = 1,ngscnt
20098
20099 qhcns(mgs) = 0.0
20100 chcns(mgs) = 0.0
20101 chcnsh(mgs) = 0.0
20102 vhcns(mgs) = 0.0
20103
20104 qscnh(mgs) = 0.0
20105 cscnh(mgs) = 0.0
20106 vscnh(mgs) = 0.0
20107
20108 IF ( ipconc .ge. 5 ) THEN
20109
20110 ! test attempt at converting graupel to snow when not riming but growing by deposition
20111 IF ( temg(mgs) < tfr .and. qx(mgs,lh) .gt. qxmin(lh) .and. qhdpv(mgs) > qxmin(lh)*dtpinv &
20112 & .and. qhacw(mgs) < qxmin(lh)*dtpinv ) THEN
20113 IF ( xdn(mgs,lh) < 290. ) THEN
20114! qscnh(mgs) = 2.*qhdpv(mgs)
20115! cscnh(mgs) = cx(mgs,lh)*qscnh(mgs)/qx(mgs,lh)
20116! vscnh(mgs) = rho0(mgs)*qscnh(mgs)/xdn(mgs,lh)
20117 ENDIF
20118 ENDIF
20119
20120
20121 IF ( qx(mgs,ls) .gt. qxmin(ls) .and. qsacw(mgs) .gt. 0.0 ) THEN
20122
20123! DATA VGRA/1.413E-2/ ! this is the volume (cm**3) of a 3mm diam. sphere
20124! vgra = 1.4137e-8 m**3
20125
20126! DNNET=DNCNV-DNAGG
20127! DQNET=QXCON+QSACC+SDEP
20128!
20129! DNSCNV=EXP(-(ROS*XNS*VGRA/(RO*QI)))*((1.-(XNS*VGRA*ROS/
20130! / (RO*QI)))*DNNET + (XNS**2*VGRA*ROS/(RO*QI**2))*DQNET)
20131! IF(DNSCNV.LT.0.) DNSCNV=0.
20132!
20133! QIHC=(ROS*VGRA/RO)*DNSCNV
20134!
20135! QH=QH+DT*QIHC
20136! QI=QI-DT*QIHC
20137! XNH=XNH+DT*DNSCNV
20138! XNS=XNS-DT*DNSCNV
20139
20140 IF ( iglcnvs .eq. 1 ) THEN ! Zrnic, Ziegler et al (1993)
20141
20142 dnnet = cscnvis(mgs) + cscnis(mgs) - csacs(mgs)
20143 dqnet = qscnvi(mgs) + qscni(mgs) + qsacw(mgs) + qsdpv(mgs) + qssbv(mgs)
20144
20145 a3 = 1./(rho0(mgs)*qx(mgs,ls))
20146 a1 = exp( - xdn(mgs,ls)*cx(mgs,ls)*vgra*a3 ) !! EXP(-(ROS*XNS*VGRA/(RO*QI)))
20147! (1.-(XNS*VGRA*ROS/(RO*QI)))*DNNET
20148 a2 = (1.-(cx(mgs,ls)*vgra*xdn(mgs,ls)*a3))*dnnet
20149! (XNS**2*VGRA*ROS/(RO*QI**2))*DQNET
20150 a4 = cx(mgs,ls)**2*vgra*xdn(mgs,ls)*a3/qx(mgs,ls)*dqnet
20151
20152 chcns(mgs) = max( 0.0, a1*(a2 + a4) )
20153 chcns(mgs) = min( chcns(mgs), cxmxd(mgs,ls) )
20154 chcnsh(mgs) = chcns(mgs)
20155
20156 qhcns(mgs) = min( xdn(mgs,ls)*vgra*rhoinv(mgs)*chcns(mgs), qxmxd(mgs,ls) )
20157 vhcns(mgs) = rho0(mgs)*qhcns(mgs)/max(xdn(mgs,ls),xdnmn(lh))
20158! vhcns(mgs) = rho0(mgs)*qhcns(mgs)/Max(xdn(mgs,ls),400.)
20159
20160 ELSEIF ( iglcnvs .ge. 2 ) THEN ! treat like ice crystals, i.e., check for rime density (ERM)
20161
20162 IF ( temg(mgs) .lt. 273.0 .and. ( qsacw(mgs) - qsdpv(mgs) .gt. 0.0 .or. &
20163 ( iglcnvs >= 3 .and. qsacw(mgs)*dtp > 2.*qxmin(lh) .and. gamsnow73fac*xmas(mgs,ls) > xdnmn(lh)*xvmn(lh) ) ) ) THEN !{
20164
20165
20166 tmp = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) &
20167 & *((0.60)*vtxbar(mgs,ls,1)) &
20168 & /(temg(mgs)-273.15))**(rimc2)
20169! tmp = Min( Max( rimc3, tmp ), 900.0 )
20170 tmp = min( tmp , 900.0 )
20171
20172 ! Assume that half the volume of the embryo is rime with density 'tmp'
20173 ! m = rhoi*(V/2) + rhorime*(V/2) = (rhoi + rhorime)*V/2
20174 ! V = 2*m/(rhoi + rhorime)
20175
20176! write(0,*) 'rime dens = ',tmp
20177
20178 IF ( iglcnvs == 2 ) THEN !{
20179 IF ( tmp .ge. 200.0 ) THEN
20180 r = max( 0.5*(xdn(mgs,ls) + tmp), xdnmn(lh) )
20181! r = Max( r, 400. )
20182 qhcns(mgs) = (qsacw(mgs) - qsdpv(mgs))
20183 chcns(mgs) = cx(mgs,ls)*qhcns(mgs)/qx(mgs,ls)
20184! chcnih(mgs) = rho0(mgs)*qhcni(mgs)/(1.6e-10)
20185 chcnsh(mgs) = min(chcns(mgs), rho0(mgs)*qhcns(mgs)/(r*xvmn(lh)) )
20186! vhcni(mgs) = rho0(mgs)*2.0*qhcni(mgs)/(xdn(mgs,li) + tmp)
20187 vhcns(mgs) = rho0(mgs)*qhcns(mgs)/r
20188 ENDIF
20189
20190 ELSEIF ( iglcnvs == 3 ) THEN
20191
20192 ! convert to particles with the mass of the mass-weighted diameter
20193 ! massofmwr = gamice73fac*xmas(mgs,li)
20194
20195 IF ( tmp > xdnmn(lh) ) THEN
20196 r = max( 0.5*(xdn(mgs,ls) + tmp), xdnmn(lh) )
20197! r = Max( r, 400. )
20198 qhcns(mgs) = 0.5*qsacw(mgs)
20199 chcns(mgs) = qhcns(mgs)/(gamsnow73fac*xmas(mgs,ls))
20200 chcns(mgs) = min( chcns(mgs), cx(mgs,ls)*qhcns(mgs)/qx(mgs,ls))
20201 chcnsh(mgs) = min(chcns(mgs), rho0(mgs)*qhcns(mgs)/(r*xvmn(lh)) )
20202 vhcns(mgs) = rho0(mgs)*qhcns(mgs)/r
20203 ENDIF
20204
20205 ENDIF !}
20206
20207 ENDIF !}
20208
20209 ENDIF
20210
20211
20212 ENDIF
20213
20214 ELSE ! single moment lfo
20215
20216 qhcns(mgs) = 0.001*ehscnv(mgs)*max((qx(mgs,ls)-6.e-4),0.0)
20217 qhcns(mgs) = min(qhcns(mgs),qxmxd(mgs,ls))
20218 IF ( lvol(lh) .ge. 1 ) vhcns(mgs) = rho0(mgs)*qhcns(mgs)/max(xdn(mgs,ls),400.)
20219
20220 ENDIF
20221 ENDDO
20222!
20223!
20224! heat budget for rain---not all rain that collects ice can freeze
20225!
20226!
20227!
20228 if ( irwfrz .gt. 0 .and. .not. mixedphase) then
20229!
20230 do mgs = 1,ngscnt
20231!
20232! compute total rain that freeze when it interacts with cloud ice
20233!
20234 qrztot(mgs) = qrfrz(mgs) + qiacr(mgs) + qsacr(mgs)
20235!
20236! compute the maximum amount of rain that can freeze
20237! Used to limit freezing to 4*qrmxd, but now allow all rain to freeze if possible
20238!
20239 qrzmax(mgs) = &
20240 & ( xdia(mgs,lr,1)*rwvent(mgs)*cx(mgs,lr)*fwet1(mgs) )
20241 qrzmax(mgs) = max(qrzmax(mgs), 0.0)
20242 qrzmax(mgs) = min(qrztot(mgs), qrzmax(mgs))
20243 qrzmax(mgs) = min(qx(mgs,lr)*dtpinv, qrzmax(mgs))
20244
20245 IF ( temcg(mgs) < -30. ) THEN ! allow all to freeze if T < -30 because fwet becomes invalid (negative)
20246 qrzmax(mgs) = qx(mgs,lr)*dtpinv
20247 ENDIF
20248! qrzmax(mgs) = min(4.*qrmxd(mgs), qrzmax(mgs))
20249!
20250! compute the correction factor
20251!
20252! IF ( qrztot(mgs) .gt. qxmin(lr) ) THEN
20253 IF ( qrztot(mgs) .gt. qrzmax(mgs) .and. qrztot(mgs) .gt. qxmin(lr) ) THEN
20254 qrzfac(mgs) = qrzmax(mgs)/(qrztot(mgs))
20255 ELSE
20256 qrzfac(mgs) = 1.0
20257 ENDIF
20258 qrzfac(mgs) = min(1.0, qrzfac(mgs))
20259!
20260 end do
20261!
20262!
20263! now correct the above sources
20264!
20265!
20266 do mgs = 1,ngscnt
20267 if ( temg(mgs) .le. 273.15 .and. qrzfac(mgs) .lt. 1.0 ) then
20268 qrfrz(mgs) = qrzfac(mgs)*qrfrz(mgs)
20269 qrfrzs(mgs) = qrzfac(mgs)*qrfrzs(mgs)
20270 qrfrzf(mgs) = qrzfac(mgs)*qrfrzf(mgs)
20271 qiacr(mgs) = qrzfac(mgs)*qiacr(mgs)
20272 qsacr(mgs) = qrzfac(mgs)*qsacr(mgs)
20273 qiacrf(mgs) = qrzfac(mgs)*qiacrf(mgs)
20274 qiacrs(mgs) = qrzfac(mgs)*qiacrs(mgs)
20275 crfrz(mgs) = qrzfac(mgs)*crfrz(mgs)
20276 crfrzf(mgs) = qrzfac(mgs)*crfrzf(mgs)
20277 crfrzs(mgs) = qrzfac(mgs)*crfrzs(mgs)
20278 ciacr(mgs) = qrzfac(mgs)*ciacr(mgs)
20279 ciacrf(mgs) = qrzfac(mgs)*ciacrf(mgs)
20280 ciacrs(mgs) = qrzfac(mgs)*ciacrs(mgs)
20281
20282! IF ( lzh .gt. 1 ) THEN
20283! zrfrzf(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,lr)+2.)/(xdn0(lr)**2*(alpha(mgs,lr)+1.)) * &
20284! ( 2.*tmp * qrfrzf(mgs) - tmp**2 * crfrzf(mgs) )
20285! ENDIF
20286
20287 vrfrzf(mgs) = qrzfac(mgs)*vrfrzf(mgs)
20288 viacrf(mgs) = qrzfac(mgs)*viacrf(mgs)
20289 end if
20290 end do
20291!
20292!
20293!
20294 end if
20295!
20296!
20297!
20298! evaporation of rain
20299!
20300!
20301!
20302 qrcev(:) = 0.0
20303 crcev(:) = 0.0
20304
20305
20306 do mgs = 1,ngscnt
20307!
20308 IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN
20309
20310 qrcev(mgs) = &
20311 & fvce(mgs)*cx(mgs,lr)*rwvent(mgs)*rwcap(mgs)*evapfac
20312! this line to allow condensation on rain:
20313 IF ( rcond .eq. 1 ) THEN
20314 qrcev(mgs) = min(qrcev(mgs), qxmxd(mgs,lv))
20315! this line to have evaporation only:
20316 ELSE
20317 qrcev(mgs) = min(qrcev(mgs), 0.0)
20318 ENDIF
20319
20320 qrcev(mgs) = max(qrcev(mgs), -qrmxd(mgs))
20321! if ( temg(mgs) .lt. 273.15 ) qrcev(mgs) = 0.0
20322 IF ( qrcev(mgs) .lt. 0. .and. lnr > 1 ) THEN
20323! qrcev(mgs) = -qrmxd(mgs)
20324! crcev(mgs) = (rho0(mgs)/(xmas(mgs,lr)+1.e-20))*qrcev(mgs)
20325 IF ( icrcev == 1 ) THEN
20326 crcev(mgs) = (cx(mgs,lr)/(qx(mgs,lr)))*qrcev(mgs)
20327 ELSEIF ( icrcev == 2 ) THEN
20328 crcev(mgs) = (cx(mgs,lr)/(qx(mgs,lr)))*qrcev(mgs)*vtxbar(mgs,lr,2)/vtxbar(mgs,lr,1)
20329 ELSE
20330 crcev(mgs) = 0.0
20331 ENDIF
20332 ELSE
20333 crcev(mgs) = 0.0
20334 ENDIF
20335! if ( temg(mgs) .lt. 273.15 ) crcev(mgs) = 0.0
20336!
20337 ENDIF
20338
20339 end do
20340!
20341! evaporation/condensation of wet graupel and snow
20342!
20343 IF ( lhwlg > 1 ) THEN
20344 qhcevlg(:) = 0.0
20345 chcevlg(:) = 0.0
20346 ENDIF
20347 IF ( lhlwlg > 1 ) THEN
20348 qhlcevlg(:) = 0.0
20349 chlcevlg(:) = 0.0
20350 ENDIF
20351
20352
20353!
20354!
20355!
20356! ICE MULTIPLICATION: Two modes (rimpa, and rimpb)
20357! (following Cotton et al. 1986)
20358!
20359
20360 chmul1(:) = 0.0
20361 chlmul1(:) = 0.0
20362 csmul1(:) = 0.0
20363!
20364 qhmul1(:) = 0.0
20365 qhlmul1(:) = 0.0
20366 qsmul1(:) = 0.0
20367 do mgs = 1,ngscnt
20368
20369 ltest = qx(mgs,lh) .gt. qxmin(lh)
20370 IF ( lhl > 1 ) ltest = ltest .or. qx(mgs,lhl) .gt. qxmin(lhl)
20371
20372 IF ( (itype1 .ge. 1 .or. itype2 .ge. 1 ) &
20373 & .and. qx(mgs,lc) .gt. qxmin(lc)) THEN
20374 if ( temg(mgs) .ge. 265.15 .and. temg(mgs) .le. 271.15 ) then
20375 IF ( ipconc .ge. 2 ) THEN
20376 IF ( xv(mgs,lc) .gt. 0.0 &
20377 & .and. ltest &
20378! .and. itype2 .ge. 2 &
20379 & ) THEN
20380!
20381! Ziegler et al. 1986 Hallett-Mossop process. VSTAR = 7.23e-15 (vol of 12micron radius)
20382!
20383 IF ( alpha(mgs,lc) == 0.0 ) THEN
20384 ex1 = (1./250.)*exp(-7.23e-15/xv(mgs,lc))
20385 ELSE
20386
20387 ratio = (1. + alpha(mgs,lc))*(7.23e-15)/xv(mgs,lc)
20388
20389 IF ( usegamxinfcnu ) THEN
20390 i = nint(dgami*(1. + alpha(mgs,lc)))
20391 gcnup1 = gmoi(i)
20392 ex1 = (1./250.)*gamxinf(1.+alpha(mgs,lc), ratio)/(gcnup1)
20393 ELSE
20394 ratio = min( maxratiolu, ratio )
20395 tmp = gaminterp(ratio,alpha(mgs,lc),1,1)
20396 ex1 = (1./250.)*tmp
20397 ENDIF
20398 ENDIF
20399 IF ( itype2 .le. 2 ) THEN
20400 ft = max(0.0,min(1.0,-0.11*temcg(mgs)**2 - 1.1*temcg(mgs)-1.7))
20401 ELSE
20402 IF ( temg(mgs) .ge. 265.15 .and. temg(mgs) .le. 267.15 ) THEN
20403 ft = 0.5
20404 ELSEIF (temg(mgs) .ge. 267.15 .and. temg(mgs) .le. 269.15 ) THEN
20405 ft = 1.0
20406 ELSEIF (temg(mgs) .ge. 269.15 .and. temg(mgs) .le. 271.15 ) THEN
20407 ft = 0.5
20408 ELSE
20409 ft = 0.0
20410 ENDIF
20411 ENDIF
20412! rhoinv = 1./rho0(mgs)
20413! DNSTAR = ex1*cglacw(mgs)
20414
20415 IF ( ft > 0.0 ) THEN
20416
20417 IF ( itype2 > 0 ) THEN
20418 IF ( qx(mgs,lh) .gt. qxmin(lh) .and. (.not. wetsfc(mgs)) ) THEN
20419 chmul1(mgs) = ft*ex1*chacw(mgs)
20420! chmul1(mgs) = Min( ft*ex1*chacw(mgs), ft*(30.*1.e+06)*rho0(mgs)*qhacw(mgs) ) ! 1.e+6 converts kg to mg; Saunders & Hosseini (2001) average of about 30 crystals per mg
20421 qhmul1(mgs) = cimas0*chmul1(mgs)*rhoinv(mgs)
20422 ENDIF
20423 IF ( lhl .gt. 1 ) THEN
20424 IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. (.not. wetsfchl(mgs)) ) THEN
20425 chlmul1(mgs) = (ft*ex1*chlacw(mgs))
20426 qhlmul1(mgs) = cimas0*chlmul1(mgs)*rhoinv(mgs)
20427 ENDIF
20428 ENDIF
20429 ENDIF ! itype2
20430
20431 IF ( itype1 > 0 ) THEN
20432 IF ( qx(mgs,lh) .gt. qxmin(lh) .and. (.not. wetsfc(mgs)) ) THEN
20433 tmp = ft*(3.5e+08)*rho0(mgs)*qhacw(mgs)
20434 chmul1(mgs) = chmul1(mgs) + tmp
20435 qhmul1(mgs) = qhmul1(mgs) + cimas0*tmp*rhoinv(mgs)
20436 ENDIF
20437 IF ( lhl .gt. 1 ) THEN
20438 IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. (.not. wetsfchl(mgs)) ) THEN
20439 tmp = ft*(3.5e+08)*rho0(mgs)*qhlacw(mgs)
20440 chlmul1(mgs) = chlmul1(mgs) + tmp
20441 qhlmul1(mgs) = qhlmul1(mgs) + cimas0*tmp*rhoinv(mgs)
20442 ENDIF
20443 ENDIF
20444 ENDIF ! itype1
20445
20446
20447 ENDIF ! ft
20448
20449 ENDIF ! xv(mgs,lc) .gt. 0.0 .and.
20450
20451 ELSE ! ipconc .lt. 2
20452!
20453! define the temperature function
20454!
20455 fimt1(mgs) = 0.0
20456!
20457! Cotton et al. (1986) version
20458!
20459 if ( temg(mgs) .ge. 268.15 .and. temg(mgs) .le. 270.15 ) then
20460 fimt1(mgs) = 1.0 -(temg(mgs)-268.15)/2.0
20461 elseif (temg(mgs) .le. 268.15 .and. temg(mgs) .ge. 265.15 ) then
20462 fimt1(mgs) = 1.0 +(temg(mgs)-268.15)/3.0
20463 ELSE
20464 fimt1(mgs) = 0.0
20465 end if
20466!
20467! Ferrier (1994) version
20468!
20469 if ( temg(mgs) .ge. 265.15 .and. temg(mgs) .le. 267.15 ) then
20470 fimt1(mgs) = 0.5
20471 elseif (temg(mgs) .ge. 267.15 .and. temg(mgs) .le. 269.15 ) then
20472 fimt1(mgs) = 1.0
20473 elseif (temg(mgs) .ge. 269.15 .and. temg(mgs) .le. 271.15 ) then
20474 fimt1(mgs) = 0.5
20475 ELSE
20476 fimt1(mgs) = 0.0
20477 end if
20478!
20479!
20480! type I: 350 splinters are formed for every 1e-3 grams of cloud
20481! water accreted by graupel/hail (note converted to MKS units)
20482! 3.5e+8 has units of 1/kg
20483!
20484 IF ( itype1 .ge. 1 ) THEN
20485 fimta(mgs) = (3.5e+08)*rho0(mgs)
20486 ELSE
20487 fimta(mgs) = 0.0
20488 ENDIF
20489
20490!
20491!
20492! type II: 1 splinter formed for every 250 cloud droplets larger than
20493! 24 micons in diameter (12 microns in radius) accreted by
20494! graupel/hail
20495!
20496!
20497 fimt2(mgs) = 0.0
20498 xcwmas = xmas(mgs,lc) * 1000.
20499!
20500 IF ( itype2 .ge. 1 ) THEN
20501 if ( xcwmas.lt.1.26e-9 ) then
20502 fimt2(mgs) = 0.0
20503 end if
20504 if ( xcwmas .le. 3.55e-9 .and. xcwmas .ge. 1.26e-9 ) then
20505 fimt2(mgs) = (2.27)*alog(xcwmas) + 13.39
20506 end if
20507 if ( xcwmas .gt. 3.55e-9 ) then
20508 fimt2(mgs) = 1.0
20509 end if
20510
20511 fimt2(mgs) = min(fimt2(mgs),1.0)
20512 fimt2(mgs) = max(fimt2(mgs),0.0)
20513
20514 ENDIF
20515!
20516! qhmul2 = 0.0
20517! qsmul2 = 0.0
20518!
20519! qhmul2 =
20520! > (4.0e-03)*fimt1(mgs)*fimt2(mgs)*qhacw(mgs)
20521! qsmul2 =
20522! > (4.0e-03)*fimt1(mgs)*fimt2(mgs)*qsacw(mgs)
20523!
20524! cimas0 = (1.0e-12)
20525! cimas0 = 2.5e-10
20526 IF ( .not. wetsfc(mgs) ) THEN
20527 chmul1(mgs) = fimt1(mgs)*(fimta(mgs) + &
20528 & (4.0e-03)*fimt2(mgs))*qhacw(mgs)
20529 ENDIF
20530!
20531 qhmul1(mgs) = chmul1(mgs)*(cimas0/rho0(mgs))
20532
20533 IF ( lhl .gt. 1 ) THEN
20534 IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. (.not. wetsfchl(mgs)) ) THEN
20535 tmp = fimt1(mgs)*(fimta(mgs) + &
20536 & (4.0e-03)*fimt2(mgs))*qhlacw(mgs)
20537 chlmul1(mgs) = tmp
20538 qhlmul1(mgs) = cimas0*tmp*rhoinv(mgs)
20539 ENDIF
20540 ENDIF
20541
20542! qsmul1(mgs) = csmul1(mgs)*(cimas0/rho0(mgs))
20543!
20544 ENDIF ! ( ipconc .ge. 2 )
20545
20546 end if ! (in temperature range)
20547
20548 ENDIF ! ( itype1 .eq. 1 .or. itype2 .eq. 1)
20549!
20550 end do
20551!
20552!
20553!
20554! end if
20555!
20556! end do
20557!
20558!
20559! ICE MULTIPLICATION FROM SNOW
20560! Lo and Passarelli 82 / Willis and Heymsfield 89 / Schuur and Rutledge 00b
20561! using kfrag as fragmentation rate (s-1) / 500 microns as char mean diam for max snow mix ratio
20562!
20563 csmul(:) = 0.0
20564 qsmul(:) = 0.0
20565
20566 IF ( isnwfrac /= 0 ) THEN
20567 do mgs = 1,ngscnt
20568 IF (temg(mgs) .gt. 265.0) THEN !{
20569 if (xdia(mgs,ls,1) .gt. 100.e-6 .and. xdia(mgs,ls,1) .lt. 2.0e-3) then ! equiv diameter 100microns to 2mm
20570
20571 tmp = rhoinv(mgs)*pi*xdn(mgs,ls)*cx(mgs,ls)*(500.e-6)**3
20572 qsmul(mgs) = max( kfrag*( qx(mgs,ls) - tmp ) , 0.0 )
20573
20574 qsmul(mgs) = min( qxmxd(mgs,li), qsmul(mgs) )
20575 csmul(mgs) = min( cxmxd(mgs,li), rho0(mgs)*qsmul(mgs)/mfrag )
20576
20577 endif
20578 ENDIF !}
20579 enddo
20580 ENDIF
20581
20582!
20583! frozen rain-rain interaction....
20584!
20585!
20586!
20587!
20588! rain-ice interaction
20589!
20590!
20591 do mgs = 1,ngscnt
20592 qracif(mgs) = qraci(mgs)
20593 cracif(mgs) = craci(mgs)
20594! ciacrf(mgs) = ciacr(mgs)
20595 end do
20596!
20597!
20598! vapor to pristine ice crystals UP
20599!
20600!
20601!
20602! compute the nucleation rate
20603!
20604! do mgs = 1,ngscnt
20605! idqis = 0
20606! if ( ssi(mgs) .gt. 1.0 ) idqis = 1
20607! fiinit(mgs) = (felv(mgs)**2)/(cp*rw)
20608! dqisdt(mgs) = (qx(mgs,lv)-qis(mgs))/
20609! > (1.0 + fiinit(mgs)*qis(mgs)/tsqr(mgs))
20610! qidsvp(mgs) = dqisdt(mgs)
20611! cnnt = min(cnit*exp(-temcg(mgs)*bta1),1.0e+09)
20612! qiint(mgs) =
20613! > il5(mgs)*idqis*(1.0*dtpinv)
20614! < *min((6.88e-13)*cnnt/rho0(mgs), 0.25*dqisdt(mgs))
20615! end do
20616!
20617! Meyers et al. (1992; JAS) and Ferrier (1994) primary ice nucleation
20618!
20619 cmassin = cimasn ! 6.88e-13
20620 do mgs = 1,ngscnt
20621 qiint(mgs) = 0.0
20622 ciint(mgs) = 0.0
20623 qicicnt(mgs) = 0.0
20624 cicint(mgs) = 0.0
20625 qipipnt(mgs) = 0.0
20626 cipint(mgs) = 0.0
20627 ccitmp = 0.0
20628 IF ( icenucopt == 1 .or. icenucopt == -10 .or. icenucopt == -11 ) THEN
20629 if ( ( temg(mgs) .lt. 268.15 .or. &
20630! : ( imeyers5 .and. temg(mgs) .lt. 273.0) ) .and. &
20631 & ( imeyers5 .and. temg(mgs) .lt. 272.0 .and. temgkm2(mgs) .lt. tfr) ) .and. &
20632 & ciintmx .gt. (cx(mgs,li)+ccitmp) &
20633! : .and. cninm(mgs) .gt. 0. &
20634 & ) then
20635 fiinit(mgs) = (felv(mgs)**2)/(cp*rw)
20636 dqisdt(mgs) = (qx(mgs,lv)-qis(mgs))/ &
20637 & (1.0 + fiinit(mgs)*qis(mgs)/tsqr(mgs))
20638! qidsvp(mgs) = dqisdt(mgs)
20639 idqis = 0
20640 if ( ssi(mgs) .gt. 1.0 ) THEN
20641 idqis = 1
20642 dzfacp = max( float(kgsp(mgs)-kgs(mgs)), 0.0 )
20643 dzfacm = max( float(kgs(mgs)-kgsm(mgs)), 0.0 )
20644 qiint(mgs) = &
20645 & idqis*il5(mgs) &
20646 & *(cmassin/rho0(mgs)) &
20647 & *max(0.0,wvel(mgs)) &
20648 & *max((cninp(mgs)-cninm(mgs)),0.0)/gz(igs(mgs),jgs,kgs(mgs)) &
20649 & /((dzfacp+dzfacm))
20650
20651 qiint(mgs) = min(qiint(mgs), max(0.25*dqisdt(mgs),0.0))
20652 ciint(mgs) = qiint(mgs)*rho0(mgs)/cmassin
20653
20654!
20655! limit new crystals so it does not increase the current concentration
20656! above ciintmx 20,000 per liter (2.e7 per m**3)
20657!
20658! ciintmx = 1.e9
20659! ciintmx = 1.e9
20660 IF ( icenucopt /= -10 ) THEN
20661
20662 IF ( lcin > 1 ) THEN
20663 ciint(mgs) = min(ciint(mgs), ccin(mgs)*dtpinv) ! because ciint is a *rate*
20664 ccin(mgs) = ccin(mgs) - ciint(mgs)*dtp
20665 qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs)
20666 ELSEIF ( lcina > 1 ) THEN
20667 ciint(mgs) = max(0.0, min( ciint(mgs), min( cnina(mgs), ciintmx ) - cina(mgs) ))
20668 qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs)
20669
20670 ELSEIF ( icenucopt == 1 .and. ciint(mgs) .gt. max(0.0, ciintmx - cx(mgs,li) - ccitmp )*dtpinv ) THEN
20671 ciint(mgs) = max(0.0, ciintmx - (cx(mgs,li)) )*dtpinv
20672 qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs)
20673
20674 ELSEIF ( icenucopt == -11 .and. dtp*ciint(mgs) .gt. ( cnina(mgs) - (cx(mgs,li) - ccitmp))) THEN
20675 ciint(mgs) = max(0.0, cnina(mgs) - (cx(mgs,li)+ccitmp)*dtpinv )
20676 qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs)
20677
20678 ENDIF
20679 ENDIF
20680
20681 end if
20682 endif
20683
20684 ELSEIF ( icenucopt == 2 .or. icenucopt == -1 .or. icenucopt == -2 ) THEN
20685
20686 IF ( ( temg(mgs) .lt. 268.15 .and. ssw(mgs) > 1.0 ) .or. ssi(mgs) > 1.25 ) THEN
20687 IF ( lcin > 1 ) THEN
20688 ciint(mgs) = min(cnina(mgs), ccin(mgs))
20689 ciint(mgs) = min( ciint(mgs), max(0.0, ciintmx - (cx(mgs,li) - ccitmp) ) ) ! do not initiate ice beyond concentration of ciintmx
20690 ccin(mgs) = ccin(mgs) - ciint(mgs)
20691 ciint(mgs) = ciint(mgs)*dtpinv ! convert total initiation to a rate
20692 ELSE
20693 ciint(mgs) = max( 0.0, cnina(mgs) - cina(mgs) )*dtpinv
20694 ENDIF
20695 qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs)
20696
20697 fiinit(mgs) = (felv(mgs)**2)/(cp*rw)
20698 dqisdt(mgs) = (qx(mgs,lv)-qis(mgs))/(1.0 + fiinit(mgs)*qis(mgs)/tsqr(mgs))
20699 qiint(mgs) = min(qiint(mgs), max(0.25*dqisdt(mgs),0.0))
20700 ciint(mgs) = qiint(mgs)*rho0(mgs)/cmassin
20701 ENDIF
20702
20703
20704
20705 ELSEIF ( icenucopt == 3 .or. icenucopt == 4 .or. icenucopt == 10 ) THEN
20706 IF ( temg(mgs) .lt. 268.15 ) THEN
20707 IF ( lcin > 1 ) THEN
20708 ciint(mgs) = min(cnina(mgs), ccin(mgs))
20709 ciint(mgs) = min( ciint(mgs), max(0.0, ciintmx - (cx(mgs,li) + ccitmp) ) ) ! do not initiate ice beyond concentration of ciintmx
20710 ccin(mgs) = ccin(mgs) - ciint(mgs)
20711 ciint(mgs) = ciint(mgs)*dtpinv ! convert total initiation to a rate
20712 ELSE
20713 ciint(mgs) = max( 0.0, cnina(mgs) - cina(mgs) )*dtpinv
20714 ENDIF
20715 qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs)
20716 ENDIF
20717
20718 ENDIF
20719!
20720 if ( xplate(mgs) .eq. 1 ) then
20721 qipipnt(mgs) = qiint(mgs)
20722 cipint(mgs) = ciint(mgs)
20723 end if
20724!
20725 if ( xcolmn(mgs) .eq. 1 ) then
20726 qicicnt(mgs) = qiint(mgs)
20727 cicint(mgs) = ciint(mgs)
20728 end if
20729!
20730! qipipnt(mgs) = 0.0
20731! qicicnt(mgs) = qiint(mgs)
20732!
20733 end do
20734!
20735!
20736
20737!
20738! vapor to cloud droplets UP
20739!
20740 if (ndebug .gt. 0 ) write(0,*) 'dbg = 8'
20741!
20742!
20743 if (ndebug .gt. 0 ) write(0,*) 'Collection: set 3-component'
20744!
20745! time for riming....
20746!
20747! rimtim = 240.0
20748! dtrim = rimtim
20749! xacrtim = 120.0
20750! tranfr = 0.50
20751! tranfw = 0.50
20752!
20753! coefficients for riming
20754!
20755! rimc1 = 300.00
20756! rimc2 = 0.44
20757!
20758!
20759! zero some arrays
20760!
20761!
20762 do mgs = 1,ngscnt
20763 qrshr(mgs) = 0.0
20764 qwshw(mgs) = 0.0
20765 cwshw(mgs) = 0.0
20766 qsshrp(mgs) = 0.0
20767 qhshrp(mgs) = 0.0
20768 end do
20769!
20770!
20771! first sum all of the shed rain
20772!
20773!
20774 do mgs = 1,ngscnt
20775 qrshr(mgs) = qsshr(mgs) + qhshr(mgs) + qhlshr(mgs)
20776 crshr(mgs) = chshrr(mgs)/rzxh(mgs) + chlshrr(mgs)/rzxhl(mgs)
20777
20778
20779 IF ( ipconc .ge. 3 ) THEN
20780! crshr(mgs) = Max(crshr(mgs), rho0(mgs)*qrshr(mgs)/(xdn(mgs,lr)*vr1mm) )
20781 ENDIF
20782 end do
20783!
20784!
20785!
20786
20787!
20788!
20789!
20790!
20791 IF ( ipconc .ge. 1 ) THEN
20792!
20793!
20794! concentration production terms
20795!
20796! YYY
20797!
20798!
20799! DO mgs = 1,ngscnt
20800 pccwi(:) = 0.0
20801 pccwd(:) = 0.0
20802 pccwdacc(:) = 0.0
20803 pccii(:) = 0.0
20804 pccin(:) = 0.0
20805 pccid(:) = 0.0
20806 pcisi(:) = 0.0
20807 pcisd(:) = 0.0
20808 pcrwi(:) = 0.0
20809 pcrwd(:) = 0.0
20810 pcswi(:) = 0.0
20811 pcswd(:) = 0.0
20812 pchwi(:) = 0.0
20813 pchwd(:) = 0.0
20814 pchli(:) = 0.0
20815 pchld(:) = 0.0
20816! ENDDO
20817!
20818! Cloud ice
20819!
20820! IF ( ipconc .ge. 1 ) THEN
20821
20822 IF ( warmonly < 0.5 ) THEN
20823 IF ( ffrzs < 1.0 ) THEN
20824 do mgs = 1,ngscnt
20825 pccii(mgs) = &
20826 & il5(mgs)*cicint(mgs) &
20827 & +il5(mgs)*((1.0-cwfrz2snowfrac)*cwfrzc(mgs)+cwctfzc(mgs) &
20828 & +cicichr(mgs)) &
20829 & +chmul1(mgs) &
20830 & +chlmul1(mgs) &
20831 & + csplinter(mgs) + csplinter2(mgs) &
20832 & +csmul(mgs)
20833
20834 pccii(mgs) = pccii(mgs)*(1.0 - ffrzs)
20835
20836! > + nsplinter*(crfrzf(mgs) + crfrz(mgs))
20837 pccid(mgs) = &
20838 & il5(mgs)*(-cscni(mgs) - cscnvi(mgs) & ! - cwaci(mgs) &
20839 & -craci(mgs) &
20840 & -csaci(mgs) &
20841 & -chaci(mgs) - chlaci(mgs) &
20842 & -chcni(mgs)) &
20843 & +il5(mgs)*cisbv(mgs) &
20844 & -(1.-il5(mgs))*cimlr(mgs)
20845
20846 pccin(mgs) = ciint(mgs)
20847
20848
20849 end do
20850 ENDIF ! ffrzs
20851 ELSEIF ( warmonly < 0.8 ) THEN
20852 do mgs = 1,ngscnt
20853
20854! qiint(mgs) = 0.0
20855! cicint(mgs) = 0.0
20856! qicicnt(mgs) = 0.0
20857
20858 pccii(mgs) = &
20859 & il5(mgs)*cicint(mgs) &
20860 & +il5(mgs)*((1.0-cwfrz2snowfrac)*cwfrzc(mgs)+cwctfzc(mgs) &
20861 & +cicichr(mgs)) &
20862 & +chmul1(mgs) &
20863 & +chlmul1(mgs) &
20864 & + csplinter(mgs) + csplinter2(mgs) &
20865 & +csmul(mgs)
20866
20867 pccii(mgs) = pccii(mgs)*(1. - ffrzs)
20868 pccid(mgs) = &
20869! & il5(mgs)*(-cscni(mgs) - cscnvi(mgs) & ! - cwaci(mgs) &
20870! & -craci(mgs) &
20871! & -csaci(mgs) &
20872! & -chaci(mgs) - chlaci(mgs) &
20873! & -chcni(mgs)) &
20874 & +il5(mgs)*cisbv(mgs) &
20875 & -(1.-il5(mgs))*cimlr(mgs)
20876
20877 pccin(mgs) = ciint(mgs)
20878
20879 end do
20880 ENDIF ! warmonly
20881
20882
20883! ENDIF ! ( ipconc .ge. 1 )
20884!
20885! Cloud water
20886!
20887 IF ( ipconc .ge. 2 ) THEN
20888
20889 do mgs = 1,ngscnt
20890 pccwi(mgs) = (0.0) - cwshw(mgs) ! + (1-il5(mgs))*(-cirmlw(mgs))
20891
20892 IF ( warmonly < 0.5 ) THEN
20893 pccwd(mgs) = &
20894 & - cautn(mgs) + &
20895 & il5(mgs)*(-ciacw(mgs)-cwfrz(mgs)-cwctfzp(mgs) &
20896 & -cwctfzc(mgs) &
20897 & ) &
20898 & -cracw(mgs) -csacw(mgs) -chacw(mgs) - chlacw(mgs)
20899
20900
20901 ELSEIF ( warmonly < 0.8 ) THEN
20902 pccwd(mgs) = &
20903 & - cautn(mgs) + &
20904 & il5(mgs)*( &
20905 & -ciacw(mgs)-cwfrz(mgs)-cwctfzp(mgs) &
20906 & -cwctfzc(mgs) &
20907 & ) &
20908 & -cracw(mgs) -chacw(mgs) -chlacw(mgs)
20909 ELSE
20910
20911! tmp3d(igs(mgs),jy,kgs(mgs)) = crcnw(mgs)
20912
20913! cracw(mgs) = 0.0 ! turn off accretion
20914! qracw(mgs) = 0.0
20915! crcev(mgs) = 0.0 ! turn off evap
20916! qrcev(mgs) = 0.0 ! turn off evap
20917! cracr(mgs) = 0.0 ! turn off self collection
20918
20919
20920! cautn(mgs) = 0.0
20921! crcnw(mgs) = 0.0
20922! qrcnw(mgs) = 0.0
20923
20924 pccwd(mgs) = &
20925 & - cautn(mgs) -cracw(mgs)
20926 ENDIF
20927
20928
20929 IF ( .false. .and. exwmindiam > 0.0 .and. ccwresv(mgs) > 0.0 ) THEN
20930 pccwdacc(mgs) = &
20931 & il5(mgs)*(-ciacw(mgs) &
20932 & ) &
20933 & -cracw(mgs) -csacw(mgs) -chacw(mgs) - chlacw(mgs)
20934
20935 IF ( -pccwdacc(mgs)*dtp .gt. cx(mgs,lc) - ccwresv(mgs) ) THEN
20936
20937 frac = -(cx(mgs,lc) - ccwresv(mgs) )/(pccwdacc(mgs)*dtp)
20938 pccwdacc(mgs) = -(cx(mgs,lc) - ccwresv(mgs) )*dtpinv
20939
20940 ciacw(mgs) = frac*ciacw(mgs)
20941 cracw(mgs) = frac*cracw(mgs)
20942 csacw(mgs) = frac*csacw(mgs)
20943 chacw(mgs) = frac*chacw(mgs)
20944 cautn(mgs) = frac*cautn(mgs)
20945
20946 IF ( lhl .gt. 1 ) chlacw(mgs) = frac*chlacw(mgs)
20947
20948! resum
20949 pccwd(mgs) = &
20950 & - cautn(mgs) + &
20951 & il5(mgs)*(-ciacw(mgs)-cwfrzp(mgs)-cwctfzp(mgs) &
20952 & -cwfrzc(mgs)-cwctfzc(mgs) &
20953 & -il5(mgs)*(ciihr(mgs)) &
20954 & ) &
20955 & -cracw(mgs) -csacw(mgs) -chacw(mgs) - chlacw(mgs)
20956
20957 ENDIF
20958
20959 ENDIF
20960
20961
20962 IF ( -pccwd(mgs)*dtp .gt. cx(mgs,lc) ) THEN
20963! write(0,*) 'OUCH! pccwd(mgs)*dtp .gt. ccw(mgs) ',pccwd(mgs),cx(mgs,lc)
20964! write(0,*) 'qc = ',qx(mgs,lc)
20965! write(0,*) -ciacw(mgs)-cwfrzp(mgs)-cwctfzp(mgs)-cwfrzc(mgs)-cwctfzc(mgs)
20966! write(0,*) -cracw(mgs) -csacw(mgs) -chacw(mgs)
20967! write(0,*) - cautn(mgs)
20968
20969 frac = -cx(mgs,lc)/(pccwd(mgs)*dtp)
20970 pccwd(mgs) = -cx(mgs,lc)*dtpinv
20971
20972 ciacw(mgs) = frac*ciacw(mgs)
20973 cwfrz(mgs) = frac*cwfrz(mgs)
20974 cwfrzp(mgs) = frac*cwfrzp(mgs)
20975 cwctfzp(mgs) = frac*cwctfzp(mgs)
20976 cwfrzc(mgs) = frac*cwfrzc(mgs)
20977 cwctfzc(mgs) = frac*cwctfzc(mgs)
20978 cwctfz(mgs) = frac*cwctfz(mgs)
20979 cracw(mgs) = frac*cracw(mgs)
20980 csacw(mgs) = frac*csacw(mgs)
20981 chacw(mgs) = frac*chacw(mgs)
20982 cautn(mgs) = frac*cautn(mgs)
20983
20984 pccii(mgs) = pccii(mgs) - (1.-frac)*il5(mgs)*(cwfrzc(mgs)+cwctfzc(mgs))*(1. - ffrzs)
20985 IF ( lhl .gt. 1 ) chlacw(mgs) = frac*chlacw(mgs)
20986
20987! STOP
20988 ENDIF
20989
20990 end do
20991
20992 ENDIF ! ipconc
20993
20994!
20995! Rain
20996!
20997 IF ( ipconc .ge. 3 ) THEN
20998
20999 do mgs = 1,ngscnt
21000
21001 IF ( warmonly < 0.5 ) THEN
21002 pcrwi(mgs) = &
21003! > cracw(mgs) + &
21004 & crcnw(mgs) &
21005 & +(1-il5(mgs))*( &
21006 & -chmlrr(mgs)/rzxh(mgs) &
21007 & -chlmlrr(mgs)/rzxhl(mgs) &
21008! & -csmlr(mgs)/rzxs(mgs) &
21009 & -csmlrr(mgs) &
21010 & - cimlr(mgs) ) &
21011 & -crshr(mgs) !null at this point when wet snow/graupel included
21012 pcrwd(mgs) = &
21013 & il5(mgs)*(-ciacr(mgs) - crfrz(mgs) ) & ! - cipacr(mgs))
21014! > -csacr(mgs) &
21015 & - chacr(mgs) - chlacr(mgs) &
21016 & +crcev(mgs) &
21017 & - cracr(mgs)
21018! > -il5(mgs)*ciracr(mgs)
21019
21020
21021 ELSEIF ( warmonly < 0.8 ) THEN
21022 pcrwi(mgs) = &
21023 & crcnw(mgs) &
21024 & +(1-il5(mgs))*( &
21025 & -chmlrr(mgs)/rzxh(mgs) &
21026 & -chlmlrr(mgs)/rzxhl(mgs) &
21027! & -csmlr(mgs) &
21028 & -csmlrr(mgs) &
21029 & - cimlr(mgs) ) &
21030 & -crshr(mgs) !null at this point when wet snow/graupel included
21031 pcrwd(mgs) = &
21032 & il5(mgs)*( - crfrz(mgs) ) & ! - cipacr(mgs))
21033 & - chacr(mgs) &
21034 & - chlacr(mgs) &
21035 & +crcev(mgs) &
21036 & - cracr(mgs)
21037 ELSE
21038 pcrwi(mgs) = &
21039 & crcnw(mgs)
21040 pcrwd(mgs) = &
21041 & +crcev(mgs) &
21042 & - cracr(mgs)
21043
21044! tmp3d(igs(mgs),jy,kgs(mgs)) = vtxbar(mgs,lr,1) ! crcnw(mgs) ! (pcrwi(mgs) + pcrwd(mgs))
21045! pcrwi(mgs) = 0.0
21046! pcrwd(mgs) = 0.0
21047! qrcnw(mgs) = 0.0
21048
21049 ENDIF
21050
21051
21052 frac = 0.0
21053 IF ( -pcrwd(mgs)*dtp .gt. cx(mgs,lr) ) THEN
21054! write(0,*) 'OUCH! pcrwd(mgs)*dtp .gt. crw(mgs) ',pcrwd(mgs)*dtp,cx(mgs,lr),mgs,igs(mgs),kgs(mgs)
21055! write(0,*) -ciacr(mgs)
21056! write(0,*) -crfrz(mgs)
21057! write(0,*) -chacr(mgs)
21058! write(0,*) crcev(mgs)
21059! write(0,*) -cracr(mgs)
21060
21061 frac = -cx(mgs,lr)/(pcrwd(mgs)*dtp)
21062 pcrwd(mgs) = -cx(mgs,lr)*dtpinv
21063
21064 ciacr(mgs) = frac*ciacr(mgs)
21065 ciacrf(mgs) = frac*ciacrf(mgs)
21066 ciacrs(mgs) = frac*ciacrs(mgs)
21067 crfrz(mgs) = frac*crfrz(mgs)
21068 crfrzf(mgs) = frac*crfrzf(mgs)
21069 crfrzs(mgs) = frac*crfrzs(mgs)
21070 chacr(mgs) = frac*chacr(mgs)
21071 chlacr(mgs) = frac*chlacr(mgs)
21072 crcev(mgs) = frac*crcev(mgs)
21073 cracr(mgs) = frac*cracr(mgs)
21074
21075! STOP
21076 ENDIF
21077
21078 end do
21079
21080 ENDIF
21081
21082
21083 IF ( warmonly < 0.5 ) THEN
21084
21085!
21086! Snow
21087!
21088 IF ( ipconc .ge. 4 ) THEN !
21089
21090 do mgs = 1,ngscnt
21091 pcswi(mgs) = &
21092 & il5(mgs)*(cscnis(mgs) + cscnvis(mgs) ) &
21093 & + cwfrz2snowfrac*cwfrz(mgs)/cwfrz2snowratio &
21094 & + cscnh(mgs)
21095
21096 IF ( ffrzs > 0.0 ) THEN
21097 pcswi(mgs) = pcswi(mgs) + ffrzs* ( &
21098 & il5(mgs)*cicint(mgs) &
21099 & +il5(mgs)*(cwfrzc(mgs)+cwctfzc(mgs) &
21100 & +cicichr(mgs)) &
21101 & +chmul1(mgs) &
21102 & +chlmul1(mgs) &
21103 & + csplinter(mgs) + csplinter2(mgs) &
21104 & +csmul(mgs) )
21105 ENDIF
21106
21107
21108 IF ( ess0 < 0.0 ) THEN
21109 csacs(mgs) = max(0.0, csacs(mgs) - (ifrzs)*(crfrzs(mgs) + ciacrs(mgs)))
21110 ENDIF
21111
21112 pcswd(mgs) = &
21113! : cracs(mgs) &
21114 & -chacs(mgs) - chlacs(mgs) &
21115 & -chcns(mgs) &
21116 & +(1-il5(mgs))*csmlr(mgs) + csshr(mgs) & ! + csshrp(mgs)
21117! > +il5(mgs)*(cssbv(mgs)) &
21118 & + cssbv(mgs) &
21119 & - csacs(mgs)
21120
21121 frac = 0.0
21122 IF ( imixedphase == 0 ) THEN
21123 IF ( cx(mgs,ls) + dtp*(pcswi(mgs) + pcswd(mgs)) < 0.0 ) THEN
21124 frac = (-cx(mgs,ls) + pcswi(mgs)*dtp)/(pcswd(mgs)*dtp)
21125
21126 pcswd(mgs) = frac*pcswd(mgs)
21127
21128 chacs(mgs) = frac*chacs(mgs)
21129 chlacs(mgs) = frac*chlacs(mgs)
21130 chcns(mgs) = frac*chcns(mgs)
21131 csmlr(mgs) = frac*csmlr(mgs)
21132 csshr(mgs) = frac*csshr(mgs)
21133 cssbv(mgs) = frac*cssbv(mgs)
21134 csacs(mgs) = frac*csacs(mgs)
21135
21136 ENDIF
21137 ENDIF
21138
21139
21140
21141 pccii(mgs) = pccii(mgs) &
21142 & + (1. - ifrzs)*crfrzs(mgs) &
21143 & + (1. - ifrzs)*ciacrs(mgs)
21144
21145 pcswi(mgs) = pcswi(mgs) &
21146 & + (ifrzs)*crfrzs(mgs) &
21147 & + (ifrzs)*ciacrs(mgs)
21148
21149 end do
21150
21151 ENDIF
21152
21153!
21154! Graupel
21155!
21156 IF ( ipconc .ge. 5 ) THEN !
21157 do mgs = 1,ngscnt
21158 pchwi(mgs) = &
21159 & +(ffrzh*ifrzg*crfrzf(mgs) &
21160 & +il5(mgs)*ffrzh*ifiacrg*(ciacrf(mgs) )) &
21161 & + f2h*chcnsh(mgs) + f2h*chcnih(mgs) + chcnhl(mgs)
21162
21163 pchwd(mgs) = &
21164 & (1-il5(mgs))*chmlr(mgs) &
21165! > + il5(mgs)*chsbv(mgs) &
21166 & + chsbv(mgs) &
21167 & - il5(mgs)*chlcnh(mgs) &
21168 & - cscnh(mgs)
21169
21170 end do
21171
21172
21173
21174!
21175
21176!
21177! Hail
21178!
21179 IF ( lhl .gt. 1 .and. lnhl > 1 ) THEN !
21180 do mgs = 1,ngscnt
21181 pchli(mgs) = (ffrzh*(1.0-ifrzg)*crfrzf(mgs) +il5(mgs)*ffrzh*(1.0-ifiacrg)*(ciacrf(mgs) )) &
21182 & + chlcnhhl(mgs) *rzxhlh(mgs)
21183
21184 pchld(mgs) = &
21185 & (1-il5(mgs))*chlmlr(mgs) &
21186! > + il5(mgs)*chlsbv(mgs) &
21187 & + chlsbv(mgs) - chcnhl(mgs)
21188
21189 IF ( imixedphase == 0 ) THEN
21190 frac = 0.0
21191 IF ( cx(mgs,lhl) + dtp*(pchli(mgs) + pchld(mgs)) < 0.0 ) THEN
21192 ! rescale depletion
21193
21194 frac = (-cx(mgs,lhl) + pchli(mgs)*dtp)/(pchld(mgs)*dtp)
21195
21196 chlmlr(mgs) = frac*chlmlr(mgs)
21197 chlsbv(mgs) = frac*chlsbv(mgs)
21198 chcnhl(mgs) = frac*chcnhl(mgs)
21199
21200 pchld(mgs) = frac*pchld(mgs)
21201
21202 ENDIF
21203 ENDIF
21204
21205 end do
21206
21207 ENDIF
21208!
21209
21210 ENDIF ! (ipconc .ge. 5 )
21211
21212 ELSEIF ( warmonly < 0.8 ) THEN
21213
21214!
21215! Graupel
21216!
21217 IF ( ipconc .ge. 5 ) THEN !
21218 do mgs = 1,ngscnt
21219 pchwi(mgs) = &
21220 & +ifrzg*(crfrzf(mgs) ) ! +il5(mgs)*(ciacrf(mgs) ))
21221
21222 pchwd(mgs) = &
21223 & (1-il5(mgs))*chmlr(mgs) &
21224 & - il5(mgs)*chlcnh(mgs)
21225 end do
21226!
21227! Hail
21228!
21229 IF ( lhl .gt. 1 ) THEN !
21230 do mgs = 1,ngscnt
21231 pchli(mgs) = (1.0-ifrzg)*(crfrzf(mgs)) & ! +il5(mgs)*(ciacrf(mgs) )) &
21232 & + chlcnhhl(mgs) *rzxhl(mgs)/rzxh(mgs)
21233
21234 pchld(mgs) = &
21235 & (1-il5(mgs))*chlmlr(mgs) ! &
21236! > + il5(mgs)*chlsbv(mgs) &
21237! & + chlsbv(mgs)
21238
21239! IF ( pchli(mgs) .ne. 0. .or. pchld(mgs) .ne. 0 ) THEN
21240! write(0,*) 'dr: pchli,pchld = ', pchli(mgs),pchld(mgs), igs(mgs),kgs(mgs)
21241! ENDIF
21242 end do
21243
21244 ENDIF
21245
21246 ENDIF ! ipconc >= 5
21247
21248 ENDIF ! warmonly
21249
21250!
21251
21252!
21253! Balance and checks for continuity.....within machine precision...
21254!
21255 do mgs = 1,ngscnt
21256 pctot(mgs) = pccwi(mgs) +pccwd(mgs) + &
21257 & pccii(mgs) +pccid(mgs) + &
21258 & pcrwi(mgs) +pcrwd(mgs) + &
21259 & pcswi(mgs) +pcswd(mgs) + &
21260 & pchwi(mgs) +pchwd(mgs) + &
21261 & pchli(mgs) +pchld(mgs)
21262 end do
21263!
21264!
21265 ENDIF ! ( ipconc .ge. 1 )
21266!
21267!
21268!
21269!
21270!
21271! GOGO
21272! production terms for mass
21273!
21274!
21275 pqwvi(:) = 0.0
21276 pqwvd(:) = 0.0
21277 pqcwi(:) = 0.0
21278 pqcwd(:) = 0.0
21279 pqcwdacc(:) = 0.0
21280 pqcii(:) = 0.0
21281 pqcid(:) = 0.0
21282 pqrwi(:) = 0.0
21283 pqrwd(:) = 0.0
21284 pqswi(:) = 0.0
21285 pqswd(:) = 0.0
21286 pqhwi(:) = 0.0
21287 pqhwd(:) = 0.0
21288 pqhli(:) = 0.0
21289 pqhld(:) = 0.0
21290 pqlwsi(:) = 0.0
21291 pqlwsd(:) = 0.0
21292 pqlwhi(:) = 0.0
21293 pqlwhd(:) = 0.0
21294 pqlwlghi(:) = 0.0
21295 pqlwlghd(:) = 0.0
21296 pqlwlghli(:) = 0.0
21297 pqlwlghld(:) = 0.0
21298 pqlwhli(:) = 0.0
21299 pqlwhld(:) = 0.0
21300 IF ( ipconc > 5 ) THEN
21301 pzhwi(:) = 0.0
21302 pzhwd(:) = 0.0
21303 pzrwi(:) = 0.0
21304 pzrwd(:) = 0.0
21305 pzhli(:) = 0.0
21306 pzhld(:) = 0.0
21307 ENDIF
21308
21309
21310!
21311! Vapor
21312!
21313 IF ( warmonly < 0.5 ) THEN
21314 do mgs = 1,ngscnt
21315
21316! NOTE: ANY CHANGES HERE ALSO NEED TO GO INTO THE RESUM FARTHER DOWN!
21317 pqwvi(mgs) = &
21318 & -min(0.0, qrcev(mgs)) &
21319 & -min(0.0, qhcev(mgs)) &
21320 & -min(0.0, qhlcev(mgs)) &
21321 & -min(0.0, qscev(mgs)) &
21322! > +il5(mgs)*(-qhsbv(mgs) - qhlsbv(mgs) ) &
21323 & -qhsbv(mgs) - qhlsbv(mgs) &
21324 & -qssbv(mgs) &
21325 & -il5(mgs)*qisbv(mgs)
21326
21327 pqwvd(mgs) = &
21328 & -max(0.0, qrcev(mgs)) &
21329 & -max(0.0, qhcev(mgs)) &
21330 & -max(0.0, qhlcev(mgs)) &
21331 & -max(0.0, qscev(mgs)) &
21332 & +il5(mgs)*(-qiint(mgs) &
21333 & -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs)) &
21334 & -il5(mgs)*qidpv(mgs)
21335
21336 end do
21337
21338 ELSEIF ( warmonly < 0.8 ) THEN
21339 do mgs = 1,ngscnt
21340 pqwvi(mgs) = &
21341 & -min(0.0, qrcev(mgs)) &
21342 & -il5(mgs)*qisbv(mgs)
21343 pqwvd(mgs) = &
21344 & +il5(mgs)*(-qiint(mgs) &
21345! & -qhdpv(mgs) ) & !- qhldpv(mgs)) &
21346 & -qhdpv(mgs) - qhldpv(mgs)) &
21347! & -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs)) &
21348 & -max(0.0, qrcev(mgs)) &
21349 & -il5(mgs)*qidpv(mgs)
21350 end do
21351
21352 ELSE
21353 do mgs = 1,ngscnt
21354 pqwvi(mgs) = &
21355 & -min(0.0, qrcev(mgs))
21356 pqwvd(mgs) = &
21357 & -max(0.0, qrcev(mgs))
21358 end do
21359
21360 ENDIF ! warmonly
21361!
21362! Cloud water
21363!
21364 do mgs = 1,ngscnt
21365
21366 pqcwi(mgs) = (0.0) + qwcnr(mgs) - qwshw(mgs)
21367
21368 IF ( warmonly < 0.5 ) THEN
21369 pqcwd(mgs) = &
21370 & il5(mgs)*(-qiacw(mgs)-qwfrz(mgs)-qwctfz(mgs)) &
21371 & -il5(mgs)*(qiihr(mgs)) &
21372 & -qracw(mgs) -qsacw(mgs) -qrcnw(mgs) -qhacw(mgs) - qhlacw(mgs) !&
21373! & -il5(mgs)*(qwfrzp(mgs))
21374 ELSEIF ( warmonly < 0.8 ) THEN
21375 pqcwd(mgs) = &
21376 & il5(mgs)*(-qiacw(mgs)-qwfrz(mgs)-qwctfz(mgs)) &
21377 & -il5(mgs)*(qiihr(mgs)) &
21378 & -qracw(mgs) -qrcnw(mgs) -qhacw(mgs) -qhlacw(mgs)
21379 ELSE
21380 pqcwd(mgs) = &
21381 & -qracw(mgs) - qrcnw(mgs)
21382 ENDIF
21383
21384
21385 IF ( pqcwd(mgs) .lt. 0.0 .and. -pqcwd(mgs)*dtp .gt. qx(mgs,lc) ) THEN
21386
21387 frac = -max(0.0,qx(mgs,lc))/(pqcwd(mgs)*dtp)
21388 pqcwd(mgs) = -qx(mgs,lc)*dtpinv
21389
21390 qiacw(mgs) = frac*qiacw(mgs)
21391! qwfrzp(mgs) = frac*qwfrzp(mgs)
21392! qwctfzp(mgs) = frac*qwctfzp(mgs)
21393 qwfrzc(mgs) = frac*qwfrzc(mgs)
21394 qwfrz(mgs) = frac*qwfrz(mgs)
21395 qwctfzc(mgs) = frac*qwctfzc(mgs)
21396 qwctfz(mgs) = frac*qwctfz(mgs)
21397 qracw(mgs) = frac*qracw(mgs)
21398 qsacw(mgs) = frac*qsacw(mgs)
21399 qhacw(mgs) = frac*qhacw(mgs)
21400 vhacw(mgs) = frac*vhacw(mgs)
21401 qrcnw(mgs) = frac*qrcnw(mgs)
21402 qwfrzp(mgs) = frac*qwfrzp(mgs)
21403 IF ( lhl .gt. 1 ) THEN
21404 qhlacw(mgs) = frac*qhlacw(mgs)
21405 vhlacw(mgs) = frac*vhlacw(mgs)
21406 ENDIF
21407! IF ( lzh .gt. 1 ) zhacw(mgs) = frac*zhacw(mgs)
21408
21409! STOP
21410 ENDIF
21411
21412
21413 end do
21414!
21415! Cloud ice
21416!
21417 IF ( warmonly < 0.5 ) THEN
21418
21419 do mgs = 1,ngscnt
21420 IF ( ffrzs < 1.0 ) THEN
21421 pqcii(mgs) = &
21422 & il5(mgs)*qicicnt(mgs) &
21423 & +il5(mgs)*((1.0-cwfrz2snowfrac)*qwfrzc(mgs)+qwctfzc(mgs)) &
21424 & +il5(mgs)*(qicichr(mgs)) &
21425 & +qsmul(mgs) &
21426 & +qhmul1(mgs) + qhlmul1(mgs) &
21427 & + qsplinter(mgs) + qsplinter2(mgs)
21428! > + cimas0*nsplinter*(crfrzf(mgs) + crfrz(mgs))/rho0(mgs)
21429 ENDIF
21430
21431 pqcii(mgs) = pqcii(mgs)*(1.0 - ffrzs) &
21432 & +il5(mgs)*qidpv(mgs) &
21433 & +il5(mgs)*qiacw(mgs)
21434
21435 pqcid(mgs) = &
21436 & il5(mgs)*(-qscni(mgs) - qscnvi(mgs) & ! -qwaci(mgs) &
21437 & -qraci(mgs) &
21438 & -qsaci(mgs) ) &
21439 & -qhaci(mgs) &
21440 & -qhlaci(mgs) &
21441 & +il5(mgs)*qisbv(mgs) &
21442 & +(1.-il5(mgs))*qimlr(mgs) &
21443 & - qhcni(mgs)
21444 end do
21445
21446
21447 ELSEIF ( warmonly < 0.8 ) THEN
21448
21449 do mgs = 1,ngscnt
21450 pqcii(mgs) = &
21451 & il5(mgs)*qicicnt(mgs)*(1. - ffrzs) &
21452 & +il5(mgs)*((1.0-cwfrz2snowfrac)*qwfrzc(mgs)+qwctfzc(mgs))*(1. - ffrzs) &
21453 & +il5(mgs)*(qicichr(mgs))*(1. - ffrzs) &
21454! & +il5(mgs)*(qicichr(mgs)) &
21455! & +qsmul(mgs) &
21456 & +qhmul1(mgs) + qhlmul1(mgs) &
21457 & + qsplinter(mgs) + qsplinter2(mgs) &
21458 & +il5(mgs)*qidpv(mgs) &
21459 & +il5(mgs)*qiacw(mgs) ! & ! (qiacwi(mgs)+qwacii(mgs)) &
21460! & +il5(mgs)*(qwfrzc(mgs)+qwctfzc(mgs)) &
21461! & +il5(mgs)*(qicichr(mgs)) &
21462! & +qsmul(mgs) &
21463! & +qhmul1(mgs) + qhlmul1(mgs) &
21464! & + qsplinter(mgs) + qsplinter2(mgs)
21465
21466 pqcid(mgs) = &
21467! & il5(mgs)*(-qscni(mgs) - qscnvi(mgs) & ! -qwaci(mgs) &
21468! & -qraci(mgs) &
21469! & -qsaci(mgs) ) &
21470! & -qhaci(mgs) &
21471! & -qhlaci(mgs) &
21472 & +il5(mgs)*qisbv(mgs) &
21473 & +(1.-il5(mgs))*qimlr(mgs) ! &
21474! & - qhcni(mgs)
21475 end do
21476
21477 ENDIF
21478!
21479! Rain
21480!
21481
21482 do mgs = 1,ngscnt
21483 IF ( warmonly < 0.5 ) THEN
21484 pqrwi(mgs) = &
21485 & qracw(mgs) + qrcnw(mgs) + max(0.0, qrcev(mgs)) &
21486 & +(1-il5(mgs))*( &
21487 & -qhmlr(mgs) & !null at this point when wet snow/graupel included
21488 & -qsmlr(mgs) - qhlmlr(mgs) &
21489 & -qimlr(mgs)) &
21490! & -qsshr(mgs) & !null at this point when wet snow/graupel included
21491! & -qhshr(mgs) & !null at this point when wet snow/graupel included
21492! & -qhlshr(mgs) &
21493 & - qrshr(mgs)
21494
21495 pqrwd(mgs) = &
21496 & il5(mgs)*(-qiacr(mgs)-qrfrz(mgs)) &
21497 & - qsacr(mgs) - qhacr(mgs) - qhlacr(mgs) - qwcnr(mgs) &
21498 & + min(0.0,qrcev(mgs))
21499 ELSEIF ( warmonly < 0.8 ) THEN
21500 pqrwi(mgs) = &
21501 & qracw(mgs) + qrcnw(mgs) + max(0.0, qrcev(mgs)) &
21502 & +(1-il5(mgs))*( &
21503 & -qhlmlr(mgs) & !null at this point when wet snow/graupel included
21504 & -qhmlr(mgs) ) & !null at this point when wet snow/graupel included
21505 & -qhshr(mgs) & !null at this point when wet snow/graupel included
21506 & -qhlshr(mgs) !null at this point when wet snow/graupel included
21507 pqrwd(mgs) = &
21508 & il5(mgs)*(-qrfrz(mgs)) &
21509 & - qhacr(mgs) &
21510 & - qhlacr(mgs) &
21511 & + min(0.0,qrcev(mgs))
21512 ELSE
21513 pqrwi(mgs) = &
21514 & qracw(mgs) + qrcnw(mgs) + max(0.0, qrcev(mgs))
21515 pqrwd(mgs) = min(0.0,qrcev(mgs))
21516 ENDIF ! warmonly
21517
21518
21519 ! IF ( pqrwd(mgs) .lt. 0.0 .and. -(pqrwd(mgs) + pqrwi(mgs))*dtp .gt. qx(mgs,lr) ) THEN
21520 IF ( pqrwd(mgs) .lt. 0.0 .and. -(pqrwd(mgs) + pqrwi(mgs))*dtp .gt. qx(mgs,lr) ) THEN
21521
21522 frac = (-qx(mgs,lr) + pqrwi(mgs)*dtp)/(pqrwd(mgs)*dtp)
21523! pqrwd(mgs) = -qx(mgs,lr)*dtpinv + pqrwi(mgs)
21524
21525 pqwvi(mgs) = pqwvi(mgs) &
21526 & + min(0.0, qrcev(mgs)) &
21527 & - frac*min(0.0, qrcev(mgs))
21528 pqwvd(mgs) = pqwvd(mgs) &
21529 & + max(0.0, qrcev(mgs)) &
21530 & - frac*max(0.0, qrcev(mgs))
21531
21532 qiacr(mgs) = frac*qiacr(mgs)
21533 qiacrf(mgs) = frac*qiacrf(mgs)
21534 qiacrs(mgs) = frac*qiacrs(mgs)
21535 viacrf(mgs) = frac*viacrf(mgs)
21536 qrfrz(mgs) = frac*qrfrz(mgs)
21537 qrfrzs(mgs) = frac*qrfrzs(mgs)
21538 qrfrzf(mgs) = frac*qrfrzf(mgs)
21539 vrfrzf(mgs) = frac*vrfrzf(mgs)
21540 qsacr(mgs) = frac*qsacr(mgs)
21541 qhacr(mgs) = frac*qhacr(mgs)
21542 vhacr(mgs) = frac*vhacr(mgs)
21543 qrcev(mgs) = frac*qrcev(mgs)
21544 qhlacr(mgs) = frac*qhlacr(mgs)
21545 vhlacr(mgs) = frac*vhlacr(mgs)
21546 qhcev(mgs) = frac*qhcev(mgs)
21547 qhlcev(mgs) = frac*qhlcev(mgs)
21548
21549
21550 IF ( warmonly < 0.5 ) THEN
21551 pqrwd(mgs) = &
21552 & il5(mgs)*(-qiacr(mgs)-qrfrz(mgs) - qsacr(mgs)) &
21553 & - qhacr(mgs) - qhlacr(mgs) - qwcnr(mgs) &
21554 & + min(0.0,qrcev(mgs))
21555 ELSEIF ( warmonly < 0.8 ) THEN
21556 pqrwd(mgs) = &
21557 & il5(mgs)*(-qrfrz(mgs)) &
21558 & - qhacr(mgs) &
21559 & - qhlacr(mgs) &
21560 & + min(0.0,qrcev(mgs))
21561 ELSE
21562 pqrwd(mgs) = min(0.0,qrcev(mgs))
21563 ENDIF ! warmonly
21564
21565!
21566! Resum for vapor since qrcev has changed
21567!
21568 IF ( qrcev(mgs) .ne. 0.0 ) THEN
21569 pqwvi(mgs) = &
21570 & -min(0.0, qrcev(mgs)) &
21571 & -min(0.0, qhcev(mgs)) &
21572 & -min(0.0, qhlcev(mgs)) &
21573 & -min(0.0, qscev(mgs)) &
21574! > +il5(mgs)*(-qhsbv(mgs) - qhlsbv(mgs) ) &
21575 & -qhsbv(mgs) - qhlsbv(mgs) &
21576 & -qssbv(mgs) &
21577 & -il5(mgs)*qisbv(mgs)
21578
21579 pqwvd(mgs) = &
21580 & -max(0.0, qrcev(mgs)) &
21581 & -max(0.0, qhcev(mgs)) &
21582 & -max(0.0, qhlcev(mgs)) &
21583 & -max(0.0, qscev(mgs)) &
21584 & +il5(mgs)*(-qiint(mgs) &
21585 & -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs)) &
21586 & -il5(mgs)*qidpv(mgs)
21587
21588 ENDIF
21589
21590
21591! STOP
21592 ENDIF
21593
21594
21595 end do
21596
21597 IF ( warmonly < 0.5 ) THEN
21598
21599!
21600! Snow
21601!
21602 do mgs = 1,ngscnt
21603 pqswi(mgs) = &
21604 & il5(mgs)*(qscni(mgs)+qsaci(mgs)+qsdpv(mgs) &
21605 & + qscnvi(mgs) &
21606 & + ifrzs*(qiacrs(mgs) + qrfrzs(mgs)) &
21607 & + il5(mgs)*(( qwfrzc(mgs) + qwctfzc(mgs) + qicichr(mgs) )*ffrzs &
21608 & + (1.0 - ffrzs)*cwfrz2snowfrac*qwfrz(mgs) ) &
21609 & + il2(mgs)*qsacr(mgs)) &
21610 & + il5(mgs)*qicicnt(mgs)*ffrzs &
21611 & + il3(mgs)*(qiacrf(mgs)+qracif(mgs)) & ! only applies for ipconc <= 3
21612 & + max(0.0, qscev(mgs)) &
21613 & + qsacw(mgs) + qscnh(mgs) &
21614 & + ffrzs*(qsmul(mgs) &
21615 & +qhmul1(mgs) + qhlmul1(mgs) &
21616 & + qsplinter(mgs) + qsplinter2(mgs))
21617 pqswd(mgs) = &
21618! > -qfacs(mgs) ! -qwacs(mgs) &
21619 & -qracs(mgs)*(1-il2(mgs)) -qhacs(mgs) - qhlacs(mgs) &
21620 & -qhcns(mgs) &
21621 & +(1-il5(mgs))*qsmlr(mgs) + qsshr(mgs) & !null at this point when wet snow included
21622! > +il5(mgs)*(qssbv(mgs)) &
21623 & + qssbv(mgs) &
21624 & + min(0.0, qscev(mgs)) &
21625 & -qsmul(mgs)
21626
21627
21628 IF ( imixedphase == 0 .and. pqswd(mgs) .lt. 0.0 ) THEN
21629 IF ( qx(mgs,ls) + dtp*(pqswi(mgs) + pqswd(mgs)) < 0.0 ) THEN
21630 frac = (-qx(mgs,ls) + pqswi(mgs)*dtp)/(pqswd(mgs)*dtp)
21631
21632 pqswd(mgs) = frac*pqswd(mgs)
21633
21634 qracs(mgs) = frac*qracs(mgs) ! only used for single moment at this time
21635 qhacs(mgs) = frac*qhacs(mgs)
21636 qhlacs(mgs) = frac*qhlacs(mgs)
21637 qhcns(mgs) = frac*qhcns(mgs)
21638 qsmlr(mgs) = frac*qsmlr(mgs)
21639 qsshr(mgs) = frac*qsshr(mgs)
21640 qssbv(mgs) = frac*qssbv(mgs)
21641 qsmul(mgs) = frac*qsmul(mgs)
21642 IF ( qscev(mgs) < 0.0 ) qscev(mgs) = frac*qscev(mgs)
21643
21644 ENDIF
21645 ENDIF
21646
21647 pqcii(mgs) = pqcii(mgs) &
21648 & + (1. - ifrzs)*qrfrzs(mgs) &
21649 & + (1. - ifrzs)*qiacrs(mgs)
21650
21651 end do
21652
21653!
21654! Graupel
21655!
21656 do mgs = 1,ngscnt
21657 pqhwi(mgs) = &
21658 & +il5(mgs)*(ffrzh*ifrzg*qrfrzf(mgs) + (1-il3(mgs))*ffrzh*ifiacrg*(qiacrf(mgs)+qracif(mgs))) &
21659 & + (1-il2(mgs))*(qracs(mgs) + qsacr(mgs)) & ! only used for ipconc < 3
21660 & +il5(mgs)*(qhdpv(mgs)) &
21661 & +max(0.0, qhcev(mgs)) &
21662 & +qhacr(mgs)+qhacw(mgs) &
21663 & +qhacs(mgs)+qhaci(mgs) &
21664 & + f2h*qhcns(mgs) + f2h*qhcni(mgs) + qhcnhl(mgs)
21665 pqhwd(mgs) = &
21666 & qhshr(mgs) & !null at this point when wet graupel included
21667 & +(1-il5(mgs))*qhmlr(mgs) & !null at this point when wet graupel included
21668! > +il5(mgs)*qhsbv(mgs) &
21669 & + qhsbv(mgs) &
21670 & + min(0.0, qhcev(mgs)) &
21671 & -qhmul1(mgs) - qhlcnh(mgs) - qscnh(mgs) &
21672 & - ffrzh*(qsplinter(mgs) + qsplinter2(mgs))
21673! > - cimas0*nsplinter*(crfrzf(mgs) + crfrz(mgs))/rho0(mgs)
21674
21675 end do
21676
21677
21678!
21679! Hail
21680!
21681 IF ( lhl .gt. 1 ) THEN
21682
21683 do mgs = 1,ngscnt
21684 pqhli(mgs) = &
21685 & +il5(mgs)*(qhldpv(mgs) + ((1.0-ifrzg)*qrfrzf(mgs) + (1.0-ifiacrg)*(qiacrf(mgs)+ qracif(mgs)))) &
21686 & +max(0.0, qhlcev(mgs)) &
21687 & +qhlacr(mgs)+qhlacw(mgs) &
21688 & +qhlacs(mgs)+qhlaci(mgs) &
21689 & + qhlcnh(mgs)
21690 pqhld(mgs) = &
21691 & qhlshr(mgs) &
21692 & +(1-il5(mgs))*qhlmlr(mgs) &
21693! > +il5(mgs)*qhlsbv(mgs) &
21694 & + qhlsbv(mgs) &
21695 & + min(0.0, qhlcev(mgs)) &
21696 & -qhlmul1(mgs) - qhcnhl(mgs)
21697
21698 IF ( imixedphase == 0 ) THEN
21699 frac = 0.0
21700 IF ( qx(mgs,lhl) + dtp*(pqhli(mgs) + pqhld(mgs)) < 0.0 ) THEN
21701 ! rescale depletion
21702
21703 frac = (-qx(mgs,lhl) + pqhli(mgs)*dtp)/(pqhld(mgs)*dtp)
21704
21705 qhlmlr(mgs) = frac*qhlmlr(mgs)
21706 qhlsbv(mgs) = frac*qhlsbv(mgs)
21707 qhcnhl(mgs) = frac*qhcnhl(mgs)
21708 qhlmul1(mgs) = frac*qhlmul1(mgs)
21709 IF ( qhlcev(mgs) < 0.0 ) qhlcev(mgs) = frac*qhlcev(mgs)
21710
21711 pqhld(mgs) = frac*pqhld(mgs)
21712
21713 ENDIF
21714 ENDIF
21715
21716
21717 end do
21718
21719 ENDIF ! lhl
21720
21721 ELSEIF ( warmonly < 0.8 ) THEN
21722!
21723! Graupel
21724!
21725 do mgs = 1,ngscnt
21726 pqhwi(mgs) = &
21727 & +il5(mgs)*ifrzg*(qrfrzf(mgs) ) &
21728 & +il5(mgs)*(qhdpv(mgs)) &
21729 & +qhacr(mgs)+qhacw(mgs)
21730 pqhwd(mgs) = &
21731 & qhshr(mgs) & !null at this point when wet graupel included
21732 & - qhlcnh(mgs) &
21733 & - qhmul1(mgs) &
21734 & - qsplinter(mgs) - qsplinter2(mgs) &
21735 & +(1-il5(mgs))*qhmlr(mgs) !null at this point when wet graupel included
21736 end do
21737
21738!
21739! Hail
21740!
21741 IF ( lhl .gt. 1 ) THEN
21742
21743 do mgs = 1,ngscnt
21744 pqhli(mgs) = &
21745 & +il5(mgs)*(qhldpv(mgs) ) & ! + (1.0-ifrzg)*(qiacrf(mgs)+qrfrzf(mgs) + qracif(mgs))) &
21746 & +il5(mgs)*(1.0-ifrzg)*(qrfrzf(mgs) ) &
21747 & +qhlacr(mgs)+qhlacw(mgs) &
21748! & +qhlacs(mgs)+qhlaci(mgs) &
21749 & + qhlcnh(mgs)
21750 pqhld(mgs) = &
21751 & qhlshr(mgs) &
21752 & +(1-il5(mgs))*qhlmlr(mgs) &
21753! > +il5(mgs)*qhlsbv(mgs) &
21754 & + qhlsbv(mgs) &
21755 & -qhlmul1(mgs) - qhcnhl(mgs)
21756
21757 end do
21758
21759 ENDIF ! lhl
21760
21761 ENDIF ! warmonly
21762
21763!
21764! Liquid water on snow and graupel
21765!
21766
21767 vhmlr(:) = 0.0
21768 vhlmlr(:) = 0.0
21769 vhfzh(:) = 0.0
21770 vhlfzhl(:) = 0.0
21771
21772 IF ( mixedphase ) THEN
21773 ELSE ! set arrays for non-mixedphase graupel
21774
21775! vhshdr(:) = 0.0
21776 vhmlr(:) = qhmlr(:) ! not actually volume, but treated as q in rate equation
21777! vhsoak(:) = 0.0
21778
21779! vhlshdr(:) = 0.0
21780 vhlmlr(:) = qhlmlr(:) ! not actually volume, but treated as q in rate equation
21781! vhlmlr(:) = rho0(:)*qhlmlr(:)/xdn(:,lhl)
21782! vhlsoak(:) = 0.0
21783
21784 ENDIF ! mixedphase
21785
21786
21787
21788!
21789! Graupel reflectivity
21790!
21791 if (ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'graupel reflectivity'
21792
21793 do mgs = 1,ngscnt
21794
21795! zhmlr(mgs) = 0.0
21796! zhshr(mgs) = 0.0
21797! zhmlrr(mgs) = 0.0
21798! zhshrr(mgs) = 0.0
21799 zhdsv(mgs) = 0.0
21800! IF ( lf < 1 ) THEN
21801 IF ( ffrzh > 0.0 ) THEN
21802 ziacr(mgs) = 0.0
21803 ziacrf(mgs) = 0.0
21804 ENDIF
21805! ENDIF
21806 zhcns(mgs) = 0.0
21807 zhcni(mgs) = 0.0
21808 zhacs(mgs) = 0.0
21809 zhaci(mgs) = 0.0
21810
21811 ENDDO
21812
21813 IF ( lzh .gt. 1 ) THEN !
21814 do mgs = 1,ngscnt
21815
21816
21817 IF ( qx(mgs,lh) .gt. qxmin(lh) .and. cx(mgs,lh) .gt. 0.0 ) THEN
21818 tmp = qx(mgs,lh)/cx(mgs,lh)
21819 alp = max( alphamin, alpha(mgs,lh) )
21820! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
21821 g1 = g1x(mgs,lh) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
21822! g1r = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
21823
21824 zhaci(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qhaci(mgs) )
21825 zhacs(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qhacs(mgs) )
21826
21827 IF ( .not. mixedphase .and. ibinhmlr < 1 ) THEN
21828 zhmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhmlr(mgs) - tmp**2 * chmlr(mgs) )
21829 ENDIF
21830
21831 zhshr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshr(mgs) )
21832
21833! IF ( lzr > 0 .and. qhshr(mgs) /= 0.0 .and. chshrr(mgs) /= 0.0 .and. ibinhmlr < 1 ) THEN
21834 IF ( lzr > 0 .and. qhshr(mgs) /= 0.0 .and. chshrr(mgs) /= 0.0 ) THEN
21835! IF ( temg(mgs) > tfr + 2.0 ) THEN
21836! zhshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshrr(mgs) )
21837! IF ( zhshrr(mgs) > 0. ) THEN
21838! zhshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshr(mgs) )
21839! ENDIF
21840! z1 = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) ) ! should this be g1shr?
21841! zhshrr(mgs) = Max( z1, zhshrr(mgs))
21842! ELSE
21843! zhshrr(mgs) = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) )
21844
21845
21846 IF ( temg(mgs) >= tfr ) THEN
21847 ! zhshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn0(lr)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshrr(mgs) )
21848 ! IF ( zhshrr(mgs) > 0.0 ) THEN
21849 ! zhshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn0(lr)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshr(mgs) )
21850 ! ENDIF
21851 IF ( (shedalp + alpha(mgs,lh))*xdia(mgs,lh,1) < sheddiam ) THEN ! if not shedding small drops, then use alpha of hail
21852 z1 = g1*(6.0*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) )
21853 ELSE
21854 z1 = g1shr*(6.0*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) ) ! should this be g1shr?
21855 ENDIF
21856 zhshrr(mgs) = z1
21857! z1 = g1mlr*(rho0(mgs)/(xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) ) ! should this be g1shr?
21858! zhshrr(mgs) = Max( z1, zhshrr(mgs))
21859 ELSE
21860 zhshrr(mgs) = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) )
21861 ENDIF
21862
21863 zhshrr(mgs) = min( 0.0, zhshrr(mgs) )
21864 ENDIF
21865
21866 IF ( zhshr(mgs) > 0.0 ) THEN
21867 write(0,*) 'Problem with zhshr! zhshr,qhshr,chshr = ',zhshr(mgs),qhshr(mgs),chshr(mgs)
21868 write(0,*) 'g1,tmp, qx,cx,zx = ',g1,tmp,qx(mgs,lh),cx(mgs,lh),zx(mgs,lh)
21869 write(0,*) ( 2.*tmp * qhshr(mgs) - tmp**2 * chshr(mgs) ), 2.*tmp * qhshr(mgs), - tmp**2 * chshr(mgs)
21870 write(0,*) 'temcg = ',temcg(mgs),'chshr recalc = ',(cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhshr(mgs)
21871
21872 stop
21873 ENDIF
21874
21875
21876! zhshr(mgs) = (xdn0(lr)/(xdn(mgs,lh)))**2*( zx(mgs,lh) * qhshr(mgs) )
21877
21878 qtmp = qhdpv(mgs) + qhcev(mgs) + qhsbv(mgs)
21879 ctmp = chdpv(mgs) + chcev(mgs) + chsbv(mgs)
21880
21881 zhdsv(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qtmp - tmp**2 * ctmp )
21882
21883 alp = max( alphahacx, alpha(mgs,lh) )
21884! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
21885 g1 = g1x(mgs,lh) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
21886
21887 IF ( .true. ) THEN ! {
21888 IF ( qhacr(mgs) .gt. 0.0 ) THEN
21889! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacr(mgs) )
21890
21891! g1r = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
21892! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacr(mgs) )
21893 zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacr(mgs) )
21894! zhacrf(mgs) = g1*zhacr
21895
21896
21897! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lh)+dtp*qhacr(mgs))**2)/(cx(mgs,lh))
21898
21899 IF ( z > zx(mgs,lh) ) THEN
21900! zhacr(mgs) = (z - zx(mgs,lh))*dtpinv
21901 ELSE
21902! zhacr(mgs) = 0.0
21903 ENDIF
21904 ENDIF
21905
21906! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) )
21907! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) - tmp**2 * chacr(mgs) )
21908
21909! alp = Max( 1.0, alpha(mgs,lh)+1. )
21910! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/
21911! : ((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
21912 IF ( qhacw(mgs) .gt. 0.0 ) THEN
21913! zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) )
21914 zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) )
21915
21916! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lh)+dtp*(qhacw(mgs)-qhmul1(mgs)))**2)/(cx(mgs,lh))
21917 IF ( z > zx(mgs,lh) ) THEN
21918! zhacw(mgs) = (z - zx(mgs,lh))*dtpinv
21919 ENDIF
21920 ENDIF
21921
21922 ELSE ! } { ! this is not used because of the 'true' above
21923
21924 IF ( qhacw(mgs) .gt. 0.0 .or. qhacr(mgs) .gt. 0.0 ) THEN
21925 z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lh)+dtp*(qhacr(mgs) + qhacw(mgs)-qhmul1(mgs)))**2)/(cx(mgs,lh))
21926! zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) )
21927 IF ( z > zx(mgs,lh) ) THEN
21928 zhacw(mgs) = (z - zx(mgs,lh))*dtpinv
21929 ENDIF
21930 ENDIF
21931
21932 ENDIF ! }
21933
21934 IF ( qhlcnh(mgs) .gt. 0.0 .and. ihlcnh < 2 ) THEN
21935 zhlcnh(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qhlcnh(mgs) - tmp**2 * chlcnh(mgs) )
21936 ENDIF
21937 ENDIF
21938! qsplinter(mgs)
21939 IF ( ffrzh*qiacrf(mgs) .gt. 0.0 .and. cx(mgs,lr) .gt. 0.0 .and. qx(mgs,lr) .gt. qxmin(lr) ) THEN
21940 tmp = qx(mgs,lr)/cx(mgs,lr)
21941! alp = 3.0
21942! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
21943 IF ( imurain == 3 ) THEN
21944 ! note that 3.6476 = (6/pi)**2
21945 ziacr(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,lr)+2.)/(xdn0(lr)**2*(alpha(mgs,lr)+1.))* &
21946 & ( 2.*tmp * qiacrf(mgs) - tmp**2 * ciacrf(mgs) )
21947 ELSE ! imurain == 1
21948 ziacr(mgs) = 3.6476*rho0(mgs)**2*g1x(mgs,lr)/(xdn0(lr)**2)* &
21949 & ( 2.*tmp * qiacrf(mgs) - tmp**2 * ciacrf(mgs) )
21950 ENDIF
21951 ziacr(mgs) = min( ziacr(mgs), zxmxd(mgs,lr) )
21952! ziacrf(mgs) = (xdn(mgs,lr)/xdn(mgs,lh))**2 * ziacr(mgs)
21953 ziacrf(mgs) = (xdn(mgs,lr)/xdnmx(lh))**2 * ziacr(mgs)
21954! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*tmp * (qiacrf(mgs) - qsplinter(mgs)) - tmp**2 * ciacrf(mgs) )
21955! ziacrf(mgs) = Min( ziacrf(mgs), z )
21956 ENDIF
21957
21958
21959
21960 IF ( ffrzh*qrfrzf(mgs) .gt. 0.0 .and. cx(mgs,lr) .gt. 0.0 ) THEN
21961 tmp = qx(mgs,lr)/cx(mgs,lr)
21962! alp = 3.0
21963! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
21964 IF ( imurain == 3 ) THEN
21965 zrfrz(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,lr)+2.)/(xdn0(lr)**2*(alpha(mgs,lr)+1.)) * &
21966 & ( 2.*tmp * qrfrzf(mgs) - tmp**2 * crfrzf(mgs) )
21967 zrfrzf(mgs) = (xdn(mgs,lr)/xdn(mgs,lh))**2 * zrfrz(mgs)
21968 ELSEIF ( imurain == 1 .and. ibiggopt /= 2 ) THEN
21969! zrfrz(mgs) = 3.6476*rho0(mgs)**2*g1x(mgs,lr)/(xdn0(lr)**2) * &
21970! & ( 2.*tmp * qrfrzf(mgs) - tmp**2 * crfrz(mgs) )
21971 zrfrz(mgs) = 3.6476*rho0(mgs)**2*g1x(mgs,lr)/(xdn0(lr)**2) * &
21972 & ( 2.*tmp * qrfrz(mgs) - tmp**2 * crfrz(mgs) )
21973 zrfrzf(mgs) = 3.6476*rho0(mgs)**2*g1x(mgs,lr)/(rhofrz**2) * &
21974 & ( 2.*tmp * qrfrzf(mgs) - tmp**2 * crfrzf(mgs) )
21975 ENDIF
21976 zrfrz(mgs) = min( zrfrz(mgs), max(0.4,qrfrz(mgs)/qx(mgs,lr))*zx(mgs,lr)*dtpinv )
21977! zrfrzf(mgs) = (xdn(mgs,lr)/xdn(mgs,lh))**2 * zrfrz(mgs)
21978! zrfrzf(mgs) = (xdn(mgs,lr)/xdnmx(lh))**2 * zrfrz(mgs)
21979! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*tmp * (qrfrzf(mgs)-qsplinter2(mgs)) - tmp**2 * crfrzf(mgs) )
21980! zrfrzf(mgs) = Min( zrfrzf(mgs), z )
21981 ! change this to be alpha=0?
21982 ENDIF
21983
21984 IF ( lhl > 1 .and. qhcnhl(mgs) .gt. 0.0 ) THEN
21985 tmp = qx(mgs,lhl)/cx(mgs,lhl)
21986 zhcnhl(mgs) = g1x(mgs,lhl)*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*( tmp ) * qhcnhl(mgs) - tmp**2 * chcnhl(mgs) )
21987
21988 ENDIF
21989
21990 IF ( qhcns(mgs) > 0.0 .and. chcns(mgs) > 0.0 .and. cx(mgs,ls) > cxmin .and. vhcns(mgs) > 0 ) THEN
21991 tmp = qx(mgs,ls)/cx(mgs,ls)
21992 r = rho0(mgs)*qhcns(mgs)/vhcns(mgs) ! density of new graupel particles
21993 IF ( imusnow == 3 ) THEN
21994 zhcns(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,ls)+2.)/(r**2*(alpha(mgs,ls)+1.)) * &
21995 & ( 2.*tmp * qhcns(mgs) - tmp**2 * chcns(mgs) )
21996 ELSE
21997 write(0,*) 'Value of imusnow not valid. Must be 3 (fix me for =1). imusnow = ',imusnow
21998 stop
21999 ENDIF
22000 ENDIF
22001
22002 IF ( qhcni(mgs) > 0.0 .and. chcni(mgs) > 0.0 .and. cx(mgs,li) > cxmin .and. vhcni(mgs) > 0 ) THEN
22003 tmp = qx(mgs,li)/cx(mgs,li)
22004 r = rho0(mgs)*qhcni(mgs)/vhcni(mgs) ! density of new graupel particles
22005 zhcni(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,li)+2.)/(r**2*(alpha(mgs,li)+1.)) * &
22006 & ( 2.*tmp * qhcni(mgs) - tmp**2 * chcni(mgs) )
22007 ENDIF
22008
22009
22010 pzhwi(mgs) = &
22011 & +ifrzg*ffrzh*(zrfrzf(mgs) &
22012 & +il5(mgs)*ifiacrg*(ziacrf(mgs) ) ) &
22013! : + zhcnsh(mgs) + zhcnih(mgs) &
22014 & + zhacw(mgs) &
22015 & + zhacr(mgs) &
22016 & + zhcnhl(mgs) &
22017 & + zhacs(mgs) &
22018 & + zhaci(mgs) &
22019 & + f2h*zhcni(mgs) + f2h*zhcns(mgs) &
22020 & + max( 0.0, zhdsv(mgs) )
22021
22022 pzhwd(mgs) = 0.0 &
22023 & + (1-il5(mgs))*zhmlr(mgs) &
22024 & + zhshr(mgs) &
22025 & + min( 0.0, zhdsv(mgs) ) &
22026 & - il5(mgs)*zhlcnh(mgs)
22027
22028
22029 IF ( igs(mgs) == 44 .and. kgs(mgs) == 23 .or. dtp*( pqhwi(mgs) + pqhwd(mgs) ) > qxmin(lh) ) THEN
22030! write(0,*) 'i,k,time = ',igs(mgs),kgs(mgs),time_real
22031! write(0,*) 'pzhwi,d = ',pzhwi(mgs),pzhwd(mgs),dtp*( pzhwi(mgs) + pzhwd(mgs) ),zx(mgs,lh)
22032! write(0,*) 'pqhwi,d = ',pqhwi(mgs),pqhwd(mgs),dtp*( pqhwi(mgs) + pqhwd(mgs) ),qx(mgs,lh)
22033! write(0,*) 'pchwi,d = ',pchwi(mgs),pchwd(mgs),dtp*( pchwi(mgs) + pchwd(mgs) ),cx(mgs,lh)
22034 ENDIF
22035
22036
22037! IF ( zhcnhl(mgs) < 0.0 ) THEN
22038! write(0,*) 'Problem with zhcnhl! zhcnhl,qhcnhl,chcnhl = ',zhcnhl(mgs),qhcnhl(mgs),chcnhl(mgs)
22039! write(0,*) 'g1,tmp = ',g1x(mgs,lhl),tmp
22040! write(0,*) ( 2.*( tmp ) * qhcnhl(mgs) - tmp**2 * chcnhl(mgs) )
22041!
22042!! STOP
22043! ENDIF
22044 end do
22045
22046 if (ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'end graupel reflectivity'
22047
22048 ENDIF
22049
22050!
22051! Hail reflectivity
22052!
22053
22054 do mgs = 1,ngscnt
22055
22056 zhldsv(mgs) = 0.0
22057 zhlacr(mgs) = 0.0
22058 zhlacw(mgs) = 0.0
22059
22060 ENDDO
22061
22062 IF ( lzhl .gt. 1 .or. ( lzr > 1 .and. lnhl > 1 ) ) THEN ! also run for 2-moment hail for 3-moment rain sources
22063
22064 if (ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'hail reflectivity'
22065
22066 do mgs = 1,ngscnt
22067
22068 IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. cx(mgs,lhl) .gt. 0.0 ) THEN
22069 tmp = qx(mgs,lhl)/cx(mgs,lhl)
22070 alp = max( alphamin, alpha(mgs,lhl) )
22071! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
22072 g1 = g1x(mgs,lhl) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
22073
22074 IF ( .not. mixedphase .and. qhlmlr(mgs) /= 0.0 .and. chlmlr(mgs) /= 0.0 .and. ibinhlmlr < 1 ) THEN
22075 zhlmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlmlr(mgs) - tmp**2 * chlmlr(mgs) )
22076 ENDIF
22077
22078 zhlshr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlshr(mgs) - tmp**2 * chlshr(mgs) )
22079 IF ( lzr > 1 .and. qhlshr(mgs) /= 0.0 .and. chlshrr(mgs) /= 0.0 ) THEN
22080 IF ( temg(mgs) >= tfr ) THEN
22081 ! zhlshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn0(lr)))**2*( 2.*tmp * qhlshr(mgs) - tmp**2 * chlshrr(mgs) )
22082 ! IF ( zhlshrr(mgs) > 0.0 ) THEN
22083 ! zhlshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn0(lr)))**2*( 2.*tmp * qhlshr(mgs) - tmp**2 * chlshr(mgs) )
22084 ! ENDIF
22085 IF ( (shedalp + alpha(mgs,lhl))*xdia(mgs,lhl,1) < sheddiam ) THEN ! if not shedding small drops, then use alpha of hail
22086 z1 = g1*(6.0*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlshr(mgs)**2/ chlshrr(mgs) )
22087 ELSE
22088 z1 = g1shr*(6.0*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlshr(mgs)**2/ chlshrr(mgs) ) ! should this be g1shr?
22089 ENDIF
22090 zhlshrr(mgs) = z1
22091! z1 = g1mlr*(rho0(mgs)/(xdn(mgs,lr)))**2*( qhlshr(mgs)**2/ chlshrr(mgs) ) ! should this be g1shr?
22092! zhlshrr(mgs) = Max( z1, zhlshrr(mgs))
22093 ELSE
22094 zhlshrr(mgs) = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlshr(mgs)**2/ chlshrr(mgs) )
22095 ENDIF
22096
22097 zhlshrr(mgs) = min( 0.0, zhlshrr(mgs) )
22098 ENDIF
22099
22100 IF ( zhlshr(mgs) > 0.0 ) THEN
22101 write(0,*) 'Problem with zhlshr! zhlshr,qhlshr,chlshr = ',zhlshr(mgs),qhlshr(mgs),chlshr(mgs)
22102 write(0,*) 'g1,tmp, qx,cx,zx = ',g1,tmp,qx(mgs,lhl),cx(mgs,lhl),zx(mgs,lhl)
22103 write(0,*) ( 2.*tmp * qhlshr(mgs) - tmp**2 * chlshr(mgs) ), 2.*tmp * qhlshr(mgs), - tmp**2 * chlshr(mgs)
22104 write(0,*) 'temcg = ',temcg(mgs),'chlshr recalc = ',(cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlshr(mgs)
22105
22106 stop
22107 ENDIF
22108! zhlshr(mgs) = Min( 0.0, zhlshr(mgs) )
22109
22110! zhlshr(mgs) = (xdn0(lr)/(xdn(mgs,lhl)))**2*( zx(mgs,lhl) * qhlshr(mgs) )
22111
22112 qtmp = qhldpv(mgs) + qhlcev(mgs)
22113 ctmp = chldpv(mgs) + chlcev(mgs)
22114
22115 zhldsv(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*( tmp ) * qtmp - tmp**2 * ctmp )
22116
22117 alp = max( alphahacx, alpha(mgs,lhl) )
22118! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
22119 g1 = g1x(mgs,lhl) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
22120
22121 IF ( .true. ) THEN ! {
22122 IF ( qhlacr(mgs) .gt. 0.0 ) THEN
22123! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lhl)+dtp*qhlacr(mgs))**2)/(cx(mgs,lhl))
22124 zhlacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*( tmp ) * qhlacr(mgs) )
22125! zhlacr(mgs) = Min( zxmxd(mgs,lr), zhlacr(mgs) )
22126
22127! IF ( z > zx(mgs,lhl) ) THEN
22128! zhlacr(mgs) = (z - zx(mgs,lhl))*dtpinv
22129! ELSE
22130! zhlacr(mgs) = 0.0
22131! ENDIF
22132 ENDIF
22133
22134! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) )
22135! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) - tmp**2 * chacr(mgs) )
22136
22137 IF ( qhlacw(mgs) .gt. 0.0 ) THEN
22138 alp = max( 3.0, alpha(mgs,lhl)+1. )
22139 g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
22140
22141! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lhl)+dtp*(qhlacw(mgs)-qhlmul1(mgs)))**2)/(cx(mgs,lhl))
22142! zhlacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lhl)/cx(mgs,lhl)) * qhlacw(mgs) )
22143 zhlacw(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlacw(mgs) )
22144
22145! IF ( z > zx(mgs,lhl) ) THEN
22146! zhlacw(mgs) = (z - zx(mgs,lhl))*dtpinv
22147! ENDIF
22148 g1 = g1x(mgs,lhl) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
22149 ENDIF
22150
22151 ELSE ! } .false. {
22152
22153 IF ( qhlacw(mgs) .gt. 0.0 .or. qhlacr(mgs) .gt. 0.0 ) THEN
22154 z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lhl)+dtp*(qhlacr(mgs) + qhlacw(mgs)-qhlmul1(mgs)))**2)/(cx(mgs,lhl))
22155! zhlacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lhl)/cx(mgs,lhl)) * qhlacw(mgs) )
22156 IF ( z > zx(mgs,lhl) ) THEN
22157 zhlacw(mgs) = (z - zx(mgs,lhl))*dtpinv
22158 ENDIF
22159 ENDIF
22160
22161 ENDIF ! }
22162
22163 ENDIF
22164! qsplinter(mgs)
22165
22166 IF ( lzhl > 1 ) THEN
22167 pzhli(mgs) = ffrzh*(((1.0-ifrzg)*zrfrzf(mgs) &
22168 & +il5(mgs)*(1.0-ifiacrg)*ziacrf(mgs) )) &
22169 & + il5(mgs)*zhlcnh(mgs) &
22170 & + zhlacw(mgs) &
22171 & + zhlacr(mgs) &
22172! : + zhlacs(mgs) &
22173 & + max( 0.0, zhldsv(mgs) )
22174
22175 pzhld(mgs) = 0.0 &
22176 & + (1-il5(mgs))*zhlmlr(mgs) &
22177 & + zhlshr(mgs) &
22178 & - zhcnhl(mgs) &
22179 & + min( 0.0, zhldsv(mgs) )
22180
22181
22182 IF ( .not. ( -1.0 < pzhli(mgs) .and. pzhli(mgs) < 1.e20 ) ) THEN
22183 write(iunit,*) 'Problem with pzhli!'
22184 write(iunit,*) 'zhlcnh,zhlacw,zhlacr,zhldsv = ',zhlcnh(mgs),zhlacw(mgs),zhlacr(mgs),zhldsv(mgs)
22185 ENDIF
22186
22187 IF ( .not. ( -1.0e20 < pzhld(mgs) .and. pzhld(mgs) < 1. ) ) THEN
22188 write(iunit,*) 'Problem with pzhld!'
22189 write(iunit,*) 'zhlmlr,zhlshr,zhldsv = ',zhlmlr(mgs),zhlshr(mgs),zhldsv(mgs)
22190 ENDIF
22191
22192 ENDIF ! lzhl > 1
22193
22194 end do
22195
22196 ENDIF
22197
22198!
22199! rain reflectivity
22200!
22201 if (ndebug .gt. 0 ) write(0,*) 'WARMZIEG: dbg = 11'
22202
22203 IF ( lzr .gt. 1 ) THEN !
22204
22205 DO mgs = 1,ngscnt
22206
22207 zracw(mgs) = 0.0
22208 zracr(mgs) = 0.0
22209 zrcev(mgs) = 0.0
22210 zrach(mgs) = 0.0
22211 zrachl(mgs) = 0.0
22212 zsshr(mgs) = 0.0
22213 zsshrr(mgs) = 0.0
22214! zsmlr(mgs) = 0.0
22215 zsmlrr(mgs) = 0.0
22216
22217 IF ( qx(mgs,ls) .gt. qxmin(ls) .and. ( csmlr(mgs) /= 0.0 .or. csshr(mgs) /= 0.0 .or. &
22218 csmlrr(mgs) /= 0.0 .or. csshrr(mgs) /= 0.0) ) THEN !{
22219 tmp = qx(mgs,ls)/cx(mgs,ls)
22220 g1 = 36.*(xnu(ls)+2.0)/((xnu(ls)+1.0)*pi**2)
22221 IF ( .not. mixedphase ) THEN
22222! zsmlr(mgs) = (xdn(mgs,ls)/xdn(mgs,lr))**2*g1*(rho0(mgs)/(xdn(mgs,ls)))**2* &
22223! & ( 2.*tmp * qsmlr(mgs) - tmp**2 * csmlr(mgs) )
22224
22225 IF ( csmlrr(mgs) /= 0.0 ) THEN
22226 z1 = g1smlr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qsmlr(mgs)**2/ csmlrr(mgs) )
22227 zsmlrr(mgs) = z1
22228 ENDIF
22229 ENDIF
22230
22231! zsshr(mgs) = (xdn(mgs,ls)/xdn(mgs,lr))**2*g1*(rho0(mgs)/(xdn(mgs,ls)))**2* &
22232! & ( 2.*tmp * qsshr(mgs) - tmp**2 * csshr(mgs) )
22233
22234 IF ( csshrr(mgs) /= 0.0 ) THEN
22235 z1 = g1smlr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qsshr(mgs)**2/ csshrr(mgs) )
22236 zsshrr(mgs) = z1
22237 ENDIF
22238
22239 ENDIF !}
22240
22241 IF ( .not. mixedphase ) THEN !{
22242 IF ( zhmlr(mgs) < 0.0 .and. chmlrr(mgs) /= 0.0 .and. ibinhmlr == 0 ) THEN !{
22243 tmp = qx(mgs,lh)/cx(mgs,lh)
22244! zhmlrr(mgs) = Min(0.0, (xdn(mgs,lh)/xdn(mgs,lr))**2 * &
22245! & g1x(mgs,lh)*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhmlr(mgs) - tmp**2 * chmlrr(mgs) ) )
22246
22247! IF ( zhmlrr(mgs) >= 0. ) THEN
22248! zhmlrr(mgs) = (xdn(mgs,lh)/xdn(mgs,lr))**2 * zhmlr(mgs)
22249! ENDIF
22250 IF ( (shedalp + alpha(mgs,lh))*xdia(mgs,lh,1) < sheddiam ) THEN ! if not shedding small drops, then use alpha of graupel
22251 z1 = g1x(mgs,lh)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhmlr(mgs)**2/ chmlrr(mgs) )
22252 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)
22253 z1 = min(g1x(mgs,lh),g1shr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhmlr(mgs)**2/ chmlrr(mgs) )
22254 ENDIF
22255 zhmlrr(mgs) = z1
22256! z1 = g1mlr*(rho0(mgs)/(xdn(mgs,lr)))**2*( qhmlr(mgs)**2/ chmlrr(mgs) )
22257! zhmlrr(mgs) = Max( z1, zhmlrr(mgs))
22258 ENDIF !}
22259
22260
22261! zhshrr(mgs) = (xdn(mgs,lh)/xdn(mgs,lr))**2 * zhshr(mgs)
22262
22263 IF ( lhl > 1 .and. qhlmlr(mgs) /= 0 .and. ibinhlmlr == 0) THEN
22264 tmp = qx(mgs,lhl)/cx(mgs,lhl)
22265! zhlmlrr(mgs) = Min(0.0, (xdn(mgs,lhl)/xdn(mgs,lr))**2 * &
22266! & g1x(mgs,lhl)*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlmlr(mgs) - tmp**2 * chlmlrr(mgs) ) )
22267
22268! IF ( zhlmlrr(mgs) >= 0. ) THEN ! should be negative, if not, then use alternate calculation
22269! zhlmlrr(mgs) = (xdn(mgs,lhl)/xdn(mgs,lr))**2 * zhlmlr(mgs)
22270! ENDIF
22271
22272 IF ( (shedalp + alpha(mgs,lhl))*xdia(mgs,lhl,1) < sheddiam ) THEN ! if not shedding small drops, then use alpha of hail
22273 z1 = g1x(mgs,lhl)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlmlr(mgs)**2/ chlmlrr(mgs) )
22274 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)
22275 z1 = min(g1x(mgs,lhl),g1shr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlmlr(mgs)**2/ chlmlrr(mgs) )
22276! z1 = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlmlr(mgs)**2/ chlmlrr(mgs) )
22277 ENDIF
22278 zhlmlrr(mgs) = z1
22279
22280! z1 = g1mlr*(rho0(mgs)/(xdn(mgs,lr)))**2*( qhlmlr(mgs)**2/ chlmlrr(mgs) )
22281! zhlmlrr(mgs) = Max( z1, zhlmlrr(mgs))
22282! zhlmlr(mgs) =
22283! zhlshrr(mgs) = (xdn(mgs,lhl)/xdn(mgs,lr))**2 * zhlshr(mgs)
22284 ENDIF
22285
22286 ENDIF ! }
22287
22288 IF ( qx(mgs,lr) .gt. qxmin(lr) .and. cx(mgs,lr) .gt. 0.0 ) THEN
22289
22290 tmp = qx(mgs,lr)/cx(mgs,lr)
22291 g1 = g1x(mgs,lr) ! 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
22292
22293
22294 IF ( qracw(mgs) > 0.0 .and. cx(mgs,lr) > 0.0 ) THEN
22295 zracw(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*tmp * qracw(mgs) )
22296 ENDIF
22297
22298 IF ( cracr(mgs) > 0.0 .and. cx(mgs,lr) > 0.0 ) THEN
22299 zracr(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*1000.))**2*( tmp**2 * cracr(mgs) )
22300 ENDIF
22301
22302 qtmp = qrcev(mgs)
22303 ctmp = crcev(mgs)
22304
22305! IF ( .false. .or. iferwisventr == 2 ) THEN
22306! zrcev(mgs) = Min(0.0, (12./(pii*xdn(mgs,lr)))*xdia(mgs,lr,1)**3*fvce(mgs)*rwcap(mgs)*rwventz(mgs) )
22307! ELSE
22308 zrcev(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( 2.*( tmp ) * qtmp - tmp**2 * ctmp )
22309
22310
22311 IF ( iferwisventr == 2 ) THEN
22312 vent1 = min(0.0, (12./(pii*xdn(mgs,lr)))*xdia(mgs,lr,1)**3*fvce(mgs)*rwcap(mgs)*rwventz(mgs))
22313 zrcev(mgs) = max( zrcev(mgs), vent1 )
22314 ENDIF
22315! IF ( ny == 2 .and. igs(mgs) == 20 ) THEN
22316! write(0,*) 'k,zrcevold,new,maxdep : ',kgs(mgs),zrcev(mgs),vent1,-zxmxd(mgs,lr),alpha(mgs,lr),cx(mgs,lr)
22317! ENDIF
22318
22319
22320! ENDIF
22321 zrcev(mgs) = max( zrcev(mgs), -zxmxd(mgs,lr) )
22322
22323 IF ( qhacr(mgs) > 0.0 ) THEN
22324 zrach(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2* &
22325 & ( 2.*( qx(mgs,lr)/cx(mgs,lr)) * qhacr(mgs) - tmp**2 * chacr(mgs) )
22326 zrach(mgs) = min( zrach(mgs), zxmxd(mgs,lr) )
22327
22328 ENDIF
22329
22330 IF ( lhl > 1 .and. qhlacr(mgs) > 0.0 ) THEN
22331 zrachl(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2* &
22332 & ( 2.*( qx(mgs,lr)/cx(mgs,lr)) * qhlacr(mgs) - tmp**2 * chlacr(mgs) )
22333 zrachl(mgs) = min( zrachl(mgs), zxmxd(mgs,lr) )
22334 ENDIF
22335
22336
22337
22338 ENDIF
22339
22340 pzrwi(mgs) = zrcnw(mgs) + zracw(mgs) + zracr(mgs) &
22341 & + max( 0.,zrcev(mgs) ) &
22342 & - (1-il5(mgs))*zsmlrr(mgs) &
22343 & - zsshrr(mgs) &
22344 & - (1-il5(mgs))*zhmlrr(mgs) &
22345 & - zhshrr(mgs) &
22346 & - (1-il5(mgs))*zhlmlrr(mgs) &
22347 & - zhlshrr(mgs)
22348
22349
22350 pzrwd(mgs) = 0.0 &
22351 & + min(0.,zrcev(mgs) ) &
22352 & - zrach(mgs) &
22353 & - zrachl(mgs) &
22354 & - zrfrz(mgs) &
22355 & - il5(mgs)*(ziacr(mgs) )
22356
22357
22358 IF ( zx(mgs,lr) + dtp*(pzrwi(mgs)+pzrwd(mgs)) <= 0.0 &
22359 .and. qx(mgs,lr) > qxmin(lr) ) THEN
22360 pzrwd(mgs) = -zx(mgs,lr)*dtpinv - pzrwi(mgs)
22361 ENDIF
22362
22363 ENDDO
22364
22365 ENDIF
22366
22367
22368
22369!
22370! Snow volume
22371!
22372 IF ( lvol(ls) .gt. 1 ) THEN
22373 do mgs = 1,ngscnt
22374! pvswi(mgs) = rho0(mgs)*( pqswi(mgs) )/xdn0(ls)
22375
22376 pvswi(mgs) = rho0(mgs)*( &
22377!aps > il5*qsfzs(mgs)/xdn(mgs,ls) &
22378!aps > -il5*qsfzs(mgs)/xdn(mgs,lr) &
22379 & +il5(mgs)*(qscni(mgs)+qsaci(mgs)+qsdpv(mgs) &
22380 & + qscnvi(mgs) + (1. - ifrzs)*qiacrs(mgs) &
22381 & + (1. - ifrzs)*qrfrzs(mgs) &
22382 & )/xdn0(ls) &
22383 & + (qsacr(mgs))/rimdn(mgs,ls) ) + vsacw(mgs)
22384! > + (qsacw(mgs) + qsacr(mgs))/rimdn(mgs,ls) )
22385 pvswd(mgs) = rho0(mgs)*( pqswd(mgs) )/xdn0(ls) &
22386! > -qhacs(mgs)
22387! > -qhcns(mgs)
22388! > +(1-il5(mgs))*qsmlr(mgs) + qsshr(mgs)
22389! > +il5(mgs)*(qssbv(mgs))
22390 & -rho0(mgs)*qsmul(mgs)/xdn0(ls)
22391!aps > +rho0(mgs)*(1-il5(mgs))*(
22392!aps > qsmlr(mgs)/xdn(mgs,ls)
22393!aps > +(qscev-qsmlr(mgs))/xdn(mgs,lr) )
22394 end do
22395
22396!aps IF (mixedphase) THEN
22397!aps pvswd(mgs) = pvswd(mgs)
22398!aps > + rho0(mgs)*qsshr(mgs)/xdn(mgs,lr)
22399!aps ENDIF
22400
22401 ENDIF
22402!
22403! Graupel volume
22404!
22405 IF ( lvol(lh) .gt. 1 ) THEN
22406 DO mgs = 1,ngscnt
22407! pvhwi(mgs) = rho0(mgs)*( (pqhwi(mgs) )/xdn0(lh) )
22408
22409! pvhwi(mgs) = rho0(mgs)*( (pqhwi(mgs) - il5(mgs)*qrfrzf(mgs) )/xdn0(lh) !
22410! : + il5(mgs)*qrfrzf(mgs)/rhofrz )
22411
22412 pvhwi(mgs) = rho0(mgs)*( &
22413 & +il5(mgs)*( ifiacrg*ffrzh*qracif(mgs))/rhofrz &
22414!erm > + il5(mgs)*qhfzh(mgs)/rhofrz !aps: or use xdnmx(lh)? &
22415 & + ( il5(mgs)*qhdpv(mgs)/qhdpvdn &
22416 & + (qhacs(mgs) + qhaci(mgs))/qhacidn ) ) &
22417 & + rho0(mgs)*max(0.0, qhcev(mgs))/1000. & ! only used in mixed phase: evaporation/condensation of liquid water coating
22418! > + qhacs(mgs) + qhaci(mgs) )/xdn0(ls) ) &
22419 & + f2h*vhcns(mgs) &
22420 & + vhacr(mgs) + vhacw(mgs) + vhfzh(mgs) & ! qhacw(mgs)/rimdn(mgs,lh)
22421! > + vhfrh(mgs) &
22422 & + f2h*vhcni(mgs) + (ifiacrg*viacrf(mgs) + ifrzg*vrfrzf(mgs))*ffrzh
22423! > +qhacr(mgs)/raindn(mgs,lh) + qhacw(mgs)/rimdn(mgs,lh)
22424
22425! pvhwd(mgs) = rho0(mgs)*(pqhwd(mgs) )/xdn0(lh)
22426
22427 pvhwd(mgs) = rho0(mgs)*( &
22428! > qhshr(mgs)/xdn0(lr) &
22429! > - il5(mgs)*qhfzh(mgs)/xdn(mgs,lr) &
22430 & +( (1-il5(mgs))*vhmlr(mgs) &
22431! > +il5(mgs)*qhsbv(mgs) &
22432 & + qhsbv(mgs) &
22433 & + min(0.0, qhcev(mgs)) &
22434 & -qhmul1(mgs) )/xdn(mgs,lh) ) &
22435 & - vhlcnh(mgs) + vhshdr(mgs) - vhsoak(mgs) - vscnh(mgs)
22436
22437! IF (mixedphase) THEN
22438! pvhwd(mgs) = pvhwd(mgs)
22439! > + rho0(mgs)*qhshr(mgs)/xdn(mgs,lh) !xdn(mgs,lr)
22440! ENDIF
22441
22442 IF ( lzh > 1 .and. qx(mgs,lh) > qxmin(lh) ) THEN
22443! Calculate change in reflectivity due to density changes
22444
22445 xdn_new = rho0(mgs)*(qx(mgs,lh) + dtp*(pqhwi(mgs) + pqhwd(mgs) ))/ &
22446 & (vx(mgs,lh) + dtp*(pvhwi(mgs) + pvhwd(mgs)) )
22447
22448 IF ( mixedphase ) THEN
22449 IF ( qxw(mgs,lh) .gt. 0.0 ) THEN
22450 dnmx = xdnmx(lr)
22451 ELSE
22452 dnmx = xdnmx(lh)
22453 ENDIF
22454 ELSE
22455 dnmx = xdnmx(lh)
22456 ENDIF
22457
22458 xdn_new = max( min( xdn_new, dnmx ), xdnmn(lh) )
22459
22460 drhodt = (xdn_new - xdn(mgs,lh))*dtpinv
22461
22462 zhwdn(mgs) = -2.*g1x(mgs,lh)*(rho0(mgs)*qx(mgs,lh)*6.*pii )**2/(cx(mgs,lh)*xdn(mgs,lh)**3)*drhodt
22463
22464 pzhwi(mgs) = pzhwi(mgs) + max(0.0, zhwdn(mgs))
22465 pzhwd(mgs) = pzhwd(mgs) + min(0.0, zhwdn(mgs))
22466
22467
22468 ENDIF
22469 IF ( .false. .and. ny .eq. 2 .and. kgs(mgs) .eq. 9 .and. igs(mgs) .eq. 19 ) THEN
22470
22471 write(iunit,*)
22472 write(iunit,*) 'Graupel at ',igs(mgs),kgs(mgs)
22473!
22474 write(iunit,*) il5(mgs)*qrfrzf(mgs), qrfrzf(mgs) - qrfrz(mgs)
22475 write(iunit,*) il5(mgs)*qiacrf(mgs)
22476 write(iunit,*) il5(mgs)*qracif(mgs)
22477 write(iunit,*) 'qhcns',qhcns(mgs)
22478 write(iunit,*) 'qhcni',qhcni(mgs)
22479 write(iunit,*) il5(mgs)*(qhdpv(mgs))
22480 write(iunit,*) 'qhacr ',qhacr(mgs)
22481 write(iunit,*) 'qhacw', qhacw(mgs)
22482 write(iunit,*) 'qhacs', qhacs(mgs)
22483 write(iunit,*) 'qhaci', qhaci(mgs)
22484 write(iunit,*) 'pqhwi = ',pqhwi(mgs)
22485 write(iunit,*)
22486 write(iunit,*) 'qhcev',qhcev(mgs)
22487 write(iunit,*)
22488 write(iunit,*) 'qhshr',qhshr(mgs)
22489 write(iunit,*) 'qhmlr', (1-il5(mgs))*qhmlr(mgs)
22490 write(iunit,*) 'qhsbv', qhsbv(mgs)
22491 write(iunit,*) 'qhlcnh',-qhlcnh(mgs)
22492 write(iunit,*) 'qhmul1',-qhmul1(mgs)
22493 write(iunit,*) 'pqhwd = ', pqhwd(mgs)
22494 write(iunit,*)
22495 write(iunit,*) 'Volume'
22496 write(iunit,*)
22497 write(iunit,*) 'pvhwi',pvhwi(mgs)
22498 write(iunit,*) 'vhcns', vhcns(mgs)
22499 write(iunit,*) 'vhacr,vhacw',vhacr(mgs), vhacw(mgs) ! qhacw(mgs)/rimdn(mgs,lh)
22500 write(iunit,*) 'vhcni',vhcni(mgs)
22501 write(iunit,*)
22502 write(iunit,*) 'pvhwd',pvhwd(mgs)
22503 write(iunit,*) 'vhlcnh,vhshdr,vhsoak ', vhlcnh(mgs), vhshdr(mgs), vhsoak(mgs)
22504 write(iunit,*) 'vhmlr', vhmlr(mgs)
22505 write(iunit,*)
22506! write(iunit,*)
22507! write(iunit,*)
22508! write(iunit,*)
22509 write(iunit,*) 'Concentration'
22510 write(iunit,*) pchwi(mgs),pchwd(mgs)
22511 write(iunit,*) crfrzf(mgs)
22512 write(iunit,*) chcns(mgs)
22513 write(iunit,*) ciacrf(mgs)
22514
22515
22516 ENDIF
22517
22518
22519 ENDDO
22520
22521 ENDIF
22522!
22523!
22524!
22525
22526!
22527! Hail volume
22528!
22529 IF ( lhl .gt. 1 ) THEN
22530 IF ( lvol(lhl) .gt. 1 ) THEN
22531 DO mgs = 1,ngscnt
22532
22533 pvhli(mgs) = rho0(mgs)*( &
22534 & + ( il5(mgs)*(((1.0-ifiacrg)*ffrzh*qracif(mgs))/rhofrz + qhldpv(mgs) ) &
22535! & + Max(0.0, qhlcev(mgs)) &
22536! & + qhlacs(mgs) + qhlaci(mgs) )/xdnmn(lhl) ) & ! xdn0(ls) ) &
22537! & + qhlacs(mgs) + qhlaci(mgs) )/xdnmn(lh) ) & ! yes, this is 'lh' on purpose
22538 & + qhlacs(mgs) + qhlaci(mgs) )/500. ) & ! changed to 500 instead of min graupel density to keep hail density from dropping too much
22539 & + rho0(mgs)*max(0.0, qhlcev(mgs))/1000. &
22540 & + vhlcnhl(mgs) + ((1.0-ifiacrg)*ffrzh*viacrf(mgs) + (1.0-ifrzg)*ffrzh*vrfrzf(mgs)) &
22541 & + vhlacr(mgs) + vhlacw(mgs) + vhlfzhl(mgs) ! qhlacw(mgs)/rimdn(mgs,lhl)
22542
22543 pvhld(mgs) = rho0(mgs)*( &
22544 & +( qhlsbv(mgs) &
22545 & + min(0.0, qhlcev(mgs)) &
22546 & -qhlmul1(mgs) )/xdn(mgs,lhl) ) &
22547! & + vhlmlr(mgs) &
22548 & + rho0(mgs)*(1-il5(mgs))*vhlmlr(mgs)/xdn(mgs,lhl) &
22549 & + vhlshdr(mgs) - vhlsoak(mgs)
22550
22551 IF ( lzhl > 1 .and. qx(mgs,lhl) > qxmin(lhl) ) THEN
22552! Calculate change in reflectivity due to density changes
22553
22554 xdn_new = rho0(mgs)*(qx(mgs,lhl) + dtp*(pqhli(mgs) + pqhld(mgs) ))/ &
22555 & (vx(mgs,lhl) + dtp*(pvhli(mgs) + pvhld(mgs)) )
22556
22557 IF ( mixedphase ) THEN
22558 IF ( qxw(mgs,lhl) .gt. 0.0 ) THEN
22559 dnmx = xdnmx(lr)
22560 ELSE
22561 dnmx = xdnmx(lhl)
22562 ENDIF
22563 ELSE
22564 dnmx = xdnmx(lhl)
22565 ENDIF
22566 xdn_new = max( min( xdn_new, dnmx ), xdnmn(lhl) )
22567
22568 drhodt = (xdn_new - xdn(mgs,lhl))*dtpinv
22569
22570 zhldn(mgs) = -2.*g1x(mgs,lhl)*(rho0(mgs)*qx(mgs,lhl)*6.*pii )**2/(cx(mgs,lhl)*xdn(mgs,lhl)**3)*drhodt
22571
22572 pzhli(mgs) = pzhli(mgs) + max(0.0, zhldn(mgs))
22573 pzhld(mgs) = pzhld(mgs) + min(0.0, zhldn(mgs))
22574
22575
22576 ENDIF
22577
22578 ENDDO
22579
22580 ENDIF
22581 ENDIF
22582
22583
22584 if ( ndebug .ge. 1 ) then
22585 do mgs = 1,ngscnt
22586!
22587 ptotal(mgs) = 0.
22588 ptotal(mgs) = ptotal(mgs) &
22589 & + pqwvi(mgs) + pqwvd(mgs) &
22590 & + pqcwi(mgs) + pqcwd(mgs) &
22591 & + pqcii(mgs) + pqcid(mgs) &
22592 & + pqrwi(mgs) + pqrwd(mgs) &
22593 & + pqswi(mgs) + pqswd(mgs) &
22594 & + pqhwi(mgs) + pqhwd(mgs) &
22595 & + pqhli(mgs) + pqhld(mgs)
22596!
22597
22598
22599
22600 ENDDO
22601
22602 do mgs = 1,ngscnt
22603
22604 if ( ( (ndebug .ge. 0 ) .and. abs(ptotal(mgs)) .gt. eqtot ) &
22605! if ( ( abs(ptotal(mgs)) .gt. eqtot )
22606! : .or. pqswi(mgs)*dtp .gt. 1.e-3
22607! : .or. pqhwi(mgs)*dtp .gt. 1.e-3
22608! : .or. dtp*(pqrwi(mgs)+pqrwd(mgs)) .gt. 10.0e-3
22609! : .or. dtp*(pccii(mgs)+pccid(mgs)) .gt. 1.e7
22610! : .or. dtp*(pcipi(mgs)+pcipd(mgs)) .gt. 1.e7 &
22611 & .or. .not. (ptotal(mgs) .lt. 1.0 .and. ptotal(mgs) .gt. -1.0) & ! this line is basically checking for NaNs
22612 & ) then
22613 write(iunit,*) 'YIKES! ','ptotal1',mgs,igs(mgs),jgs, &
22614 & kgs(mgs),ptotal(mgs)
22615
22616 write(iunit,*) 't7: ', t7(igs(mgs),jgs,kgs(mgs))
22617 write(iunit,*) 'cci,ccw,crw,rdia: ',cx(mgs,li),cx(mgs,lc),cx(mgs,lr),0.5*xdia(mgs,lr,1)
22618 write(iunit,*) 'qc,qi,qr : ',qx(mgs,lc),qx(mgs,li),qx(mgs,lr)
22619 write(iunit,*) 'rmas, qrcalc : ',xmas(mgs,lr),xmas(mgs,lr)*cx(mgs,lr)/rho0(mgs)
22620 write(iunit,*) 'vti,vtc,eiw,vtr: ',vtxbar(mgs,li,1),vtxbar(mgs,lc,1),eiw(mgs),vtxbar(mgs,lr,1)
22621 write(iunit,*) 'cidia,cwdia,qcmxd: ', xdia(mgs,li,1),xdia(mgs,lc,1),qcmxd(mgs)
22622 write(iunit,*) 'snow: ',qx(mgs,ls),cx(mgs,ls),swvent(mgs),vtxbar(mgs,ls,1),xdia(mgs,ls,1)
22623 write(iunit,*) 'graupel: ',qx(mgs,lh),cx(mgs,lh),hwvent(mgs),vtxbar(mgs,lh,1),xdia(mgs,lh,1)
22624 IF ( lhl .gt. 1 ) write(iunit,*) 'hail: ',qx(mgs,lhl),cx(mgs,lhl),hlvent(mgs),vtxbar(mgs,lhl,1),xdia(mgs,lhl,1)
22625
22626
22627 write(iunit,*) 'li: ',xdia(mgs,li,1),xdia(mgs,li,2),xmas(mgs,li),qx(mgs,li), &
22628 & vtxbar(mgs,li,1)
22629
22630
22631 write(iunit,*) 'rain cx,xv : ',cx(mgs,lr),xv(mgs,lr)
22632 write(iunit,*) 'temcg = ', temcg(mgs)
22633
22634 write(iunit,*) 'v ', pqwvi(mgs) ,pqwvd(mgs)
22635 write(iunit,*) 'c ', pqcwi(mgs) ,pqcwd(mgs)
22636 write(iunit,*) 'ci', pqcii(mgs) ,pqcid(mgs)
22637 write(iunit,*) 'r ', pqrwi(mgs) ,pqrwd(mgs)
22638 write(iunit,*) 's ', pqswi(mgs) ,pqswd(mgs)
22639 write(iunit,*) 'h ', pqhwi(mgs) ,pqhwd(mgs)
22640 write(iunit,*) 'hl', pqhli(mgs) ,pqhld(mgs)
22641 tmp = pqwvi(mgs) + pqwvd(mgs) &
22642 & + pqcwi(mgs) + pqcwd(mgs) &
22643 & + pqcii(mgs) + pqcid(mgs) &
22644 & + pqrwi(mgs) + pqrwd(mgs) &
22645 & + pqswi(mgs) + pqswd(mgs) &
22646 & + pqhwi(mgs) + pqhwd(mgs) &
22647 & + pqhli(mgs) + pqhld(mgs)
22648
22649 write(iunit,*) 'total = ',tmp
22650 write(iunit,*) 'END OF OUTPUT OF SOURCE AND SINK'
22651
22652!
22653! print production terms
22654!
22655 write(iunit,*)
22656 write(iunit,*) 'Vapor'
22657!
22658 write(iunit,*) -min(0.0,qrcev(mgs))
22659 write(iunit,*) -il5(mgs)*qhsbv(mgs)
22660 write(iunit,*) -il5(mgs)*qhlsbv(mgs)
22661 write(iunit,*) -il5(mgs)*qssbv(mgs)
22662 write(iunit,*) -il5(mgs)*qisbv(mgs)
22663 write(iunit,*) 'pqwvi= ', pqwvi(mgs)
22664 write(iunit,*) -max(0.0,qrcev(mgs))
22665 write(iunit,*) -max(0.0,qhcev(mgs))
22666 write(iunit,*) -max(0.0,qhlcev(mgs))
22667 write(iunit,*) -max(0.0,qscev(mgs))
22668 write(iunit,*) -il5(mgs)*qiint(mgs)
22669 write(iunit,*) -il5(mgs)*qhdpv(mgs)
22670 write(iunit,*) -il5(mgs)*qhldpv(mgs)
22671 write(iunit,*) -il5(mgs)*qsdpv(mgs)
22672 write(iunit,*) -il5(mgs)*qidpv(mgs)
22673 write(iunit,*) 'pqwvd = ', pqwvd(mgs)
22674!
22675 write(iunit,*)
22676 write(iunit,*) 'Cloud ice'
22677!
22678 write(iunit,*) il5(mgs)*qicicnt(mgs)
22679 write(iunit,*) il5(mgs)*qidpv(mgs)
22680 write(iunit,*) il5(mgs)*qiacw(mgs)
22681 write(iunit,*) il5(mgs)*qwfrzc(mgs)
22682 write(iunit,*) il5(mgs)*qwctfzc(mgs)
22683 write(iunit,*) il5(mgs)*qicichr(mgs)
22684 write(iunit,*) qhmul1(mgs)
22685 write(iunit,*) qhlmul1(mgs)
22686 write(iunit,*) 'pqcii = ', pqcii(mgs)
22687 write(iunit,*) -il5(mgs)*qscni(mgs)
22688 write(iunit,*) -il5(mgs)*qscnvi(mgs)
22689 write(iunit,*) -il5(mgs)*qraci(mgs)
22690 write(iunit,*) -il5(mgs)*qsaci(mgs)
22691 write(iunit,*) -il5(mgs)*qhaci(mgs)
22692 write(iunit,*) -il5(mgs)*qhlaci(mgs)
22693 write(iunit,*) il5(mgs)*qisbv(mgs)
22694 write(iunit,*) (1.-il5(mgs))*qimlr(mgs)
22695 write(iunit,*) -il5(mgs)*qhcni(mgs)
22696 write(iunit,*) 'pqcid = ', pqcid(mgs)
22697 write(iunit,*) ' Conc:'
22698 write(iunit,*) pccii(mgs),pccid(mgs)
22699 write(iunit,*) il5(mgs),cicint(mgs)
22700 write(iunit,*) cwfrzc(mgs),cwctfzc(mgs)
22701 write(iunit,*) cicichr(mgs)
22702 write(iunit,*) chmul1(mgs)
22703 write(iunit,*) chlmul1(mgs)
22704 write(iunit,*) csmul(mgs)
22705!
22706!
22707!
22708!
22709 write(iunit,*)
22710 write(iunit,*) 'Cloud water'
22711!
22712 write(iunit,*) 'pqcwi =', pqcwi(mgs)
22713 write(iunit,*) -il5(mgs)*qiacw(mgs)
22714 write(iunit,*) -il5(mgs)*qwfrzc(mgs)
22715 write(iunit,*) -il5(mgs)*qwctfzc(mgs)
22716! write(iunit,*) -il5(mgs)*qwfrzp(mgs)
22717! write(iunit,*) -il5(mgs)*qwctfzp(mgs)
22718 write(iunit,*) -il5(mgs)*qiihr(mgs)
22719 write(iunit,*) -il5(mgs)*qicichr(mgs)
22720 write(iunit,*) -il5(mgs)*qipiphr(mgs)
22721 write(iunit,*) -qracw(mgs)
22722 write(iunit,*) -qsacw(mgs)
22723 write(iunit,*) -qrcnw(mgs)
22724 write(iunit,*) -qhacw(mgs)
22725 write(iunit,*) -qhlacw(mgs)
22726 write(iunit,*) 'pqcwd = ', pqcwd(mgs)
22727
22728
22729 write(iunit,*)
22730 write(iunit,*) 'Concentration:'
22731 write(iunit,*) -cautn(mgs)
22732 write(iunit,*) -cracw(mgs)
22733 write(iunit,*) -csacw(mgs)
22734 write(iunit,*) -chacw(mgs)
22735 write(iunit,*) -ciacw(mgs)
22736 write(iunit,*) -cwfrzp(mgs)
22737 write(iunit,*) -cwctfzp(mgs)
22738 write(iunit,*) -cwfrzc(mgs)
22739 write(iunit,*) -cwctfzc(mgs)
22740 write(iunit,*) pccwd(mgs)
22741!
22742 write(iunit,*)
22743 write(iunit,*) 'Rain '
22744!
22745 write(iunit,*) qracw(mgs)
22746 write(iunit,*) qrcnw(mgs)
22747 write(iunit,*) max(0.0, qrcev(mgs))
22748 write(iunit,*) -(1-il5(mgs))*qhmlr(mgs)
22749 write(iunit,*) -(1-il5(mgs))*qhlmlr(mgs)
22750 write(iunit,*) -(1-il5(mgs))*qsmlr(mgs)
22751 write(iunit,*) -(1-il5(mgs))*qimlr(mgs)
22752 write(iunit,*) -qrshr(mgs)
22753 write(iunit,*) 'pqrwi = ', pqrwi(mgs)
22754 write(iunit,*) -qsshr(mgs)
22755 write(iunit,*) -qhshr(mgs)
22756 write(iunit,*) -qhlshr(mgs)
22757 write(iunit,*) -il5(mgs)*qiacr(mgs),qiacr(mgs), qiacrf(mgs)
22758 write(iunit,*) -il5(mgs)*qrfrz(mgs)
22759 write(iunit,*) -qsacr(mgs)
22760 write(iunit,*) -qhacr(mgs)
22761 write(iunit,*) -qhlacr(mgs)
22762 write(iunit,*) qrcev(mgs)
22763 write(iunit,*) 'pqrwd = ', pqrwd(mgs)
22764 write(iunit,*) 'qrzfac = ', qrzfac(mgs)
22765!
22766
22767 write(iunit,*)
22768 write(iunit,*) 'Rain concentration'
22769 write(iunit,*) pcrwi(mgs)
22770 write(iunit,*) crcnw(mgs)
22771 write(iunit,*) 1-il5(mgs)
22772 write(iunit,*) -chmlr(mgs),-csmlr(mgs)
22773 write(iunit,*) -crshr(mgs)
22774 write(iunit,*) pcrwd(mgs)
22775 write(iunit,*) il5(mgs)
22776 write(iunit,*) -ciacr(mgs),-crfrz(mgs)
22777 write(iunit,*) -csacr(mgs),-chacr(mgs)
22778 write(iunit,*) +crcev(mgs)
22779 write(iunit,*) cracr(mgs)
22780! write(iunit,*) -il5(mgs)*ciracr(mgs)
22781
22782
22783 write(iunit,*)
22784 write(iunit,*) 'Snow'
22785!
22786 write(iunit,*) il5(mgs)*qscni(mgs), qscnvi(mgs)
22787 write(iunit,*) il5(mgs)*qsaci(mgs)
22788 write(iunit,*) il5(mgs)*qrfrzs(mgs)
22789 write(iunit,*) il5(mgs)*qiacrs(mgs),il3(mgs)*(qiacrf(mgs)+qracif(mgs)),il3(mgs),qiacrf(mgs),qracif(mgs)
22790 write(iunit,*) il5(mgs)*qsdpv(mgs), qscev(mgs)
22791 write(iunit,*) qsacw(mgs)
22792 write(iunit,*) qsacr(mgs), qscnh(mgs)
22793 write(iunit,*) 'pqswi = ',pqswi(mgs)
22794 write(iunit,*) -qhcns(mgs)
22795 write(iunit,*) -qracs(mgs)
22796 write(iunit,*) -qhacs(mgs)
22797 write(iunit,*) -qhlacs(mgs)
22798 write(iunit,*) (1-il5(mgs))*qsmlr(mgs)
22799 write(iunit,*) qsshr(mgs)
22800! write(iunit,*) qsshrp(mgs)
22801 write(iunit,*) il5(mgs)*(qssbv(mgs))
22802 write(iunit,*) 'pqswd = ', pqswd(mgs)
22803 write(iunit,*) -qracs(mgs)*(1-il2(mgs)) , qhacs(mgs) , qhlacs(mgs)
22804 write(iunit,*) -qhcns(mgs)
22805 write(iunit,*) +(1-il5(mgs))*qsmlr(mgs) , qsshr(mgs)
22806 write(iunit,*) qssbv(mgs)
22807 write(iunit,*) min(0.0, qscev(mgs))
22808 write(iunit,*) -qsmul(mgs)
22809!
22810!
22811 write(iunit,*)
22812 write(iunit,*) 'Graupel'
22813!
22814 write(iunit,*) il5(mgs)*qrfrzf(mgs), qrfrzf(mgs) - qrfrz(mgs)
22815 write(iunit,*) il5(mgs)*qiacrf(mgs)
22816 write(iunit,*) il5(mgs)*qracif(mgs)
22817 write(iunit,*) qhcns(mgs)
22818 write(iunit,*) qhcni(mgs)
22819 write(iunit,*) il5(mgs)*(qhdpv(mgs))
22820 write(iunit,*) qhacr(mgs)
22821 write(iunit,*) qhacw(mgs)
22822 write(iunit,*) qhacs(mgs)
22823 write(iunit,*) qhaci(mgs)
22824 write(iunit,*) 'pqhwi = ',pqhwi(mgs)
22825 write(iunit,*)
22826 write(iunit,*) qhshr(mgs)
22827 write(iunit,*) (1-il5(mgs))*qhmlr(mgs)
22828 write(iunit,*) il5(mgs),qhsbv(mgs)
22829 write(iunit,*) -qhlcnh(mgs)
22830 write(iunit,*) -qhmul1(mgs)
22831 write(iunit,*) 'pqhwd = ', pqhwd(mgs)
22832 write(iunit,*) 'Concentration'
22833 write(iunit,*) pchwi(mgs),pchwd(mgs)
22834 write(iunit,*) crfrzf(mgs)
22835 write(iunit,*) chcns(mgs)
22836 write(iunit,*) ciacrf(mgs)
22837
22838!
22839 write(iunit,*)
22840 write(iunit,*) 'Hail'
22841!
22842 write(iunit,*) qhlcnh(mgs)
22843 write(iunit,*) il5(mgs)*(qhldpv(mgs))
22844 write(iunit,*) qhlacr(mgs)
22845 write(iunit,*) qhlacw(mgs)
22846 write(iunit,*) qhlacs(mgs)
22847 write(iunit,*) qhlaci(mgs)
22848 write(iunit,*) pqhli(mgs)
22849 write(iunit,*)
22850 write(iunit,*) qhlshr(mgs)
22851 write(iunit,*) (1-il5(mgs))*qhlmlr(mgs)
22852 write(iunit,*) il5(mgs)*qhlsbv(mgs)
22853 write(iunit,*) pqhld(mgs)
22854 write(iunit,*) 'Concentration'
22855 write(iunit,*) pchli(mgs),pchld(mgs)
22856 write(iunit,*) chlcnh(mgs)
22857!
22858! Balance and checks for continuity.....within machine precision...
22859!
22860!
22861 write(iunit,*) 'END OF OUTPUT OF SOURCE AND SINK'
22862 write(iunit,*) 'PTOTAL',ptotal(mgs)
22863!
22864 end if ! ptotal out of bounds or NaN
22865!
22866 end do
22867!
22868
22869 end if ! ( nstep/12*12 .eq. nstep )
22870
22871!
22872! latent heating from phase changes (except qcw, qci cond, and evap)
22873!
22874 do mgs = 1,ngscnt
22875 IF ( warmonly < 0.5 ) THEN
22876 pfrz(mgs) = &
22877 & (1-il5(mgs))* &
22878 & (qhmlr(mgs)+ &
22879 & qsmlr(mgs)+qhlmlr(mgs)) & !+qhmlh(mgs)) &
22880 & +il5(mgs)*(1-imixedphase)*( &
22881 & qsacw(mgs)+qhacw(mgs) + qhlacw(mgs) &
22882 & +qsacr(mgs)+qhacr(mgs) + qhlacr(mgs) &
22883 & +qsshr(mgs) &
22884 & +qhshr(mgs) &
22885 & +qhlshr(mgs) &
22886 & +qrfrz(mgs)+qiacr(mgs) &
22887 & ) &
22888 & +il5(mgs)*(qwfrz(mgs) &
22889 & +qwctfz(mgs)+qiihr(mgs) &
22890 & +qiacw(mgs))
22891 pmlt(mgs) = &
22892 & (1-il5(mgs))* &
22893 & (qhmlr(mgs)+qsmlr(mgs)+ &
22894 & qhlmlr(mgs)) !+qhmlh(mgs))
22895 ! NOTE: psub is sum of sublimation and deposition
22896 psub(mgs) = &
22897 & il5(mgs)*( &
22898 & + qsdpv(mgs) + qhdpv(mgs) &
22899 & + qhldpv(mgs) &
22900 & + qidpv(mgs) + qisbv(mgs) ) &
22901 & + qssbv(mgs) + qhsbv(mgs) &
22902 & + qhlsbv(mgs) &
22903 & +il5(mgs)*(qiint(mgs))
22904 pvap(mgs) = &
22905 & qrcev(mgs) + qhcev(mgs) + qscev(mgs) + qhlcev(mgs) + qfcev(mgs)
22906 pevap(mgs) = &
22907 & min(0.0,qrcev(mgs)) + min(0.0,qhcev(mgs)) + min(0.0,qscev(mgs)) + min(0.0,qhlcev(mgs)) &
22908 + min(0.0,qfcev(mgs))
22909 ! NOTE: pdep is the deposition part only
22910 pdep(mgs) = &
22911 & il5(mgs)*( &
22912 & + qsdpv(mgs) + qhdpv(mgs) &
22913 & + qhldpv(mgs) &
22914 & + qidpv(mgs) ) &
22915 & +il5(mgs)*(qiint(mgs))
22916 ELSEIF ( warmonly < 0.8 ) THEN
22917 pfrz(mgs) = &
22918 & (1-il5(mgs))* &
22919 & (qhmlr(mgs)+qhlmlr(mgs)) & !+qhmlh(mgs)) &
22920 & +il5(mgs)*(qhfzh(mgs)+qhlfzhl(mgs)) &
22921 & +il5(mgs)*( &
22922 & +qhshr(mgs) &
22923 & +qhlshr(mgs) &
22924 & +qrfrz(mgs)+qwfrz(mgs) &
22925 & +qwctfz(mgs)+qiihr(mgs) &
22926 & +qiacw(mgs) &
22927 & +qhacw(mgs) + qhlacw(mgs) &
22928 & +qhacr(mgs) + qhlacr(mgs) )
22929 psub(mgs) = 0.0 + &
22930 & il5(mgs)*( &
22931 & + qhdpv(mgs) &
22932 & + qhldpv(mgs) &
22933 & + qidpv(mgs) + qisbv(mgs) ) &
22934 & +il5(mgs)*(qiint(mgs))
22935 pvap(mgs) = &
22936 & qrcev(mgs) + qhcev(mgs) + qhlcev(mgs) + qfcev(mgs)
22937 ELSE
22938 pfrz(mgs) = 0.0
22939 psub(mgs) = 0.0
22940 pvap(mgs) = qrcev(mgs)
22941 ENDIF ! warmonly
22942 ptem(mgs) = &
22943 & (1./pi0(mgs))* &
22944 & (felfcp(mgs)*pfrz(mgs) &
22945 & +felscp(mgs)*psub(mgs) &
22946 & +felvcp(mgs)*pvap(mgs))
22947 thetap(mgs) = thetap(mgs) + dtp*ptem(mgs)
22948 ptem2(mgs) = ptem(mgs)
22949 IF ( eqtset > 2 ) THEN
22950 pipert(mgs) = pipert(mgs) + (felfpi(mgs)*pfrz(mgs) &
22951 & +felspi(mgs)*psub(mgs) &
22952 & +felvpi(mgs)*pvap(mgs))*dtp
22953 ENDIF
22954 end do
22955
22956
22957
22958
22959!
22960! sum the sources and sinks for qwvp, qcw, qci, qrw, qsw
22961!
22962!
22963 do mgs = 1,ngscnt
22964
22965
22966 qwvp(mgs) = qwvp(mgs) + &
22967 & dtp*(pqwvi(mgs)+pqwvd(mgs))
22968 qx(mgs,lc) = qx(mgs,lc) + &
22969 & dtp*(pqcwi(mgs)+pqcwd(mgs))
22970 qx(mgs,lr) = qx(mgs,lr) + &
22971 & dtp*(pqrwi(mgs)+pqrwd(mgs))
22972 qx(mgs,li) = qx(mgs,li) + &
22973 & dtp*(pqcii(mgs)+pqcid(mgs))
22974 qx(mgs,ls) = qx(mgs,ls) + &
22975 & dtp*(pqswi(mgs)+pqswd(mgs))
22976 qx(mgs,lh) = qx(mgs,lh) + &
22977 & dtp*(pqhwi(mgs)+pqhwd(mgs))
22978
22979 IF ( lhl .gt. 1 ) THEN
22980 qx(mgs,lhl) = qx(mgs,lhl) + &
22981 & dtp*(pqhli(mgs)+pqhld(mgs))
22982 ENDIF
22983
22984
22985 end do
22986
22987! sum sources for particle volume
22988
22989 IF ( ldovol ) THEN
22990
22991 do mgs = 1,ngscnt
22992
22993 IF ( lvol(ls) .gt. 1 ) THEN
22994 vx(mgs,ls) = vx(mgs,ls) + &
22995 & dtp*(pvswi(mgs)+pvswd(mgs))
22996 ENDIF
22997
22998 IF ( lvol(lh) .gt. 1 ) THEN
22999 vx(mgs,lh) = vx(mgs,lh) + &
23000 & dtp*(pvhwi(mgs)+pvhwd(mgs))
23001! > rho0(mgs)*dtp*(pqhwi(mgs)+pqhwd(mgs))/xdn0(lh)
23002 ENDIF
23003
23004 IF ( lhl .gt. 1 ) THEN
23005 IF ( lvol(lhl) .gt. 1 ) THEN
23006 vx(mgs,lhl) = vx(mgs,lhl) + &
23007 & dtp*(pvhli(mgs)+pvhld(mgs))
23008! > rho0(mgs)*dtp*(pqhwi(mgs)+pqhwd(mgs))/xdn0(lh)
23009 ENDIF
23010 ENDIF
23011
23012 ENDDO
23013
23014 ENDIF ! ldovol
23015
23016!
23017!
23018!
23019! concentrations
23020!
23021 if ( ipconc .ge. 1 ) then
23022 do mgs = 1,ngscnt
23023 cx(mgs,li) = cx(mgs,li) + &
23024 & dtp*(pccii(mgs)+pccid(mgs))
23025 cina(mgs) = cina(mgs) + pccin(mgs)*dtp
23026 IF ( ipconc .ge. 2 ) THEN
23027 cx(mgs,lc) = cx(mgs,lc) + &
23028 & dtp*(pccwi(mgs)+pccwd(mgs))
23029 ENDIF
23030 IF ( ipconc .ge. 3 ) THEN
23031 cx(mgs,lr) = cx(mgs,lr) + &
23032 & dtp*(pcrwi(mgs)+pcrwd(mgs))
23033 ENDIF
23034 IF ( ipconc .ge. 4 ) THEN
23035 cx(mgs,ls) = cx(mgs,ls) + &
23036 & dtp*(pcswi(mgs)+pcswd(mgs))
23037 ENDIF
23038 IF ( ipconc .ge. 5 ) THEN
23039 cx(mgs,lh) = cx(mgs,lh) + &
23040 & dtp*(pchwi(mgs)+pchwd(mgs))
23041 IF ( lhl .gt. 1 ) THEN
23042 cx(mgs,lhl) = cx(mgs,lhl) + &
23043 & dtp*(pchli(mgs)+pchld(mgs))
23044
23045
23046
23047
23048 ENDIF
23049 ENDIF
23050 IF ( ipconc .ge. 6 ) THEN
23051 IF ( lzr .gt. 1 ) THEN
23052 zx(mgs,lr) = zx(mgs,lr) + &
23053 & dtp*(pzrwi(mgs)+pzrwd(mgs))
23054 ENDIF
23055 IF ( lzs .gt. 1 ) THEN
23056 zx(mgs,ls) = zx(mgs,ls) + &
23057 & dtp*(pzswi(mgs)+pzswd(mgs))
23058 ENDIF
23059 IF ( lzh .gt. 1 ) THEN
23060 zx(mgs,lh) = zx(mgs,lh) + &
23061 & dtp*(pzhwi(mgs)+pzhwd(mgs))
23062 ENDIF
23063 IF ( lzhl .gt. 1 ) THEN
23064 zx(mgs,lhl) = zx(mgs,lhl) + &
23065 & dtp*(pzhli(mgs)+pzhld(mgs))
23066! IF ( pchli(mgs) .ne. 0. .or. pchld(mgs) .ne. 0 ) THEN
23067! write(0,*) 'dr: cx,pchli,pchld = ', cx(mgs,lhl),pchli(mgs),pchld(mgs), igs(mgs),kgs(mgs)
23068! ENDIF
23069 ENDIF
23070 ENDIF
23071 end do
23072 end if
23073
23074 IF ( has_wetscav ) THEN
23075 DO mgs = 1,ngscnt
23076 evapprod2d(igs(mgs),kgs(mgs)) = -(qrcev(mgs) + qssbv(mgs) + qhsbv(mgs) + qhlsbv(mgs))
23077 rainprod2d(igs(mgs),kgs(mgs)) = qrcnw(mgs) + qracw(mgs) + qsacw(mgs) + qhacw(mgs) + qhlacw(mgs) + &
23078 qraci(mgs) + qsaci(mgs) + qhaci(mgs) + qhlaci(mgs) + qscni(mgs)
23079 ENDDO
23080 ENDIF
23081!
23082!
23083!
23084! start saturation adjustment
23085!
23086 if (ndebug .gt. 0 ) write(0,*) 'conc 30a'
23087! include 'sam.jms.satadj.sgi'
23088!
23089!
23090!
23091! Modified Straka adjustment (nearly identical to Tao et al. 1989 MWR)
23092!
23093!
23094!
23095! set up temperature and vapor arrays
23096!
23097 do mgs = 1,ngscnt
23098 pqs(mgs) = (380.0)/(pres(mgs))
23099 theta(mgs) = thetap(mgs) + theta0(mgs)
23100 qvap(mgs) = max( (qwvp(mgs) + qv0(mgs)), 0.0 )
23101 temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap
23102 end do
23103!
23104! melting of cloud ice
23105!
23106 do mgs = 1,ngscnt
23107 qcwtmp(mgs) = qx(mgs,lc)
23108 ptimlw(mgs) = 0.0
23109 end do
23110!
23111 do mgs = 1,ngscnt
23112 qitmp(mgs) = qx(mgs,li)
23113 if( temg(mgs) .gt. tfr .and. &
23114 & qitmp(mgs) .gt. 0.0 ) then
23115 qx(mgs,lc) = qx(mgs,lc) + qitmp(mgs)
23116! pfrz(mgs) = pfrz(mgs) - qitmp(mgs)*dtpinv
23117 ptem(mgs) = ptem(mgs) + &
23118 & (1./pi0(mgs))* &
23119 & felfcp(mgs)*(- qitmp(mgs)*dtpinv)
23120 IF ( eqtset > 2 ) THEN
23121 pipert(mgs) = pipert(mgs) - (felfpi(mgs)*qitmp(mgs))
23122 ENDIF
23123 pmlt(mgs) = pmlt(mgs) - qitmp(mgs)*dtpinv
23124 scx(mgs,lc) = scx(mgs,lc) + scx(mgs,li)
23125 thetap(mgs) = thetap(mgs) - &
23126 & fcc3(mgs)*qitmp(mgs)
23127 ptimlw(mgs) = -fcc3(mgs)*qitmp(mgs)*dtpinv
23128 cx(mgs,lc) = cx(mgs,lc) + cx(mgs,li)
23129 qx(mgs,li) = 0.0
23130 cx(mgs,li) = 0.0
23131 scx(mgs,li) = 0.0
23132 vx(mgs,li) = 0.0
23133 qitmp(mgs) = 0.0
23134 end if
23135 end do
23136
23137!
23138!
23139
23140
23141! do mgs = 1,ngscnt
23142! qimlw(mgs) = (qcwtmp(mgs)-qx(mgs,lc))*dtpinv
23143! end do
23144!
23145! homogeneous freezing of cloud water
23146!
23147 IF ( warmonly < 0.8 ) THEN
23148
23149 do mgs = 1,ngscnt
23150 qcwtmp(mgs) = qx(mgs,lc)
23151 ptwfzi(mgs) = 0.0
23152 end do
23153!
23154 do mgs = 1,ngscnt
23155
23156! if( temg(mgs) .lt. tfrh ) THEN
23157! write(0,*) 'GS: mgs,temp,qc,qi = ',mgs,temg(mgs),temcg(mgs),qx(mgs,lc),qx(mgs,li)
23158! ENDIF
23159
23160 ctmp = 0.0
23161 frac = 0.0
23162 qtmp = 0.0
23163
23164! if( ( temg(mgs) .lt. thnuc + 2. .or. (ibfc == 2 .and. temg(mgs) < thnuc + 10. ) ) .and. &
23165! & qx(mgs,lc) .gt. qxmin(lc) .and. (ipconc < 2 .or. ibfc == 0 .or. ibfc == 2 )) then
23166! commented for test (12/01/2015):
23167! if( temg(mgs) .lt. thnuc + 0. .and. &
23168! & qx(mgs,lc) .gt. 0.0 .and. (ipconc < 2 .or. ibfc == 0 )) then
23169 if( ( ( temg(mgs) .lt. thnuc + 0.) .or. (temg(mgs) .lt. thnuc + 2. .and. ibfc >= 3) ) .and. &
23170 & qx(mgs,lc) .gt. 0.0 .and. (ipconc < 2 .or. ibfc == 0 .or. ibfc == 2)) then
23171
23172 IF ( ibfc >= 3 ) THEN
23173 frac = max( 0.25, min( 1., ((thnuc + 2.) - temg(mgs) )/4.0 ) )
23174 ELSEIF ( ibfc /= 2 .or. ipconc < 2 ) THEN
23175 frac = max( 0.25, min( 1., ((thnuc + 1.) - temg(mgs) )/4.0 ) )
23176 ELSE
23177 volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 ! Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953
23178 ! for mean temperature for freezing: -ln (V) = a*Ts - b
23179 ! volt is given in cm**3, so factor of 1.e-6 to convert to m**3
23180
23181 cwfrz(mgs) = cx(mgs,lc)*exp(-volt/xv(mgs,lc)) ! number of droplets with volume greater than volt
23182
23183 qtmp = cwfrz(mgs)*xdn0(lc)*rhoinv(mgs)*(volt + xv(mgs,lc))
23184 frac = qtmp/qx(mgs,lc) ! reset number frozen to same fraction as mass. This makes
23185 ! sure that cwfrz and qwfrz are consistent and prevents
23186 ! spurious creation of ice crystals.
23187
23188 ENDIF
23189 qtmp = frac*qx(mgs,lc)
23190
23191 IF ( ibfc == 4 .and. lis >= 1 ) THEN
23192 qx(mgs,lis) = qx(mgs,lis) + qtmp
23193 ELSE
23194 qx(mgs,li) = qx(mgs,li) + qtmp ! qx(mgs,lc)
23195 ENDIF
23196 pfrz(mgs) = pfrz(mgs) + qtmp*dtpinv
23197 ptem(mgs) = ptem(mgs) + &
23198 & (1./pi0(mgs))* &
23199 & felfcp(mgs)*(qtmp*dtpinv)
23200
23201 IF ( eqtset > 2 ) THEN
23202 pipert(mgs) = pipert(mgs) + felfpi(mgs)*qtmp
23203 ENDIF
23204
23205! IF ( lvol(li) .gt. 1 ) vx(mgs,li) = vx(mgs,li) + rho0(mgs)*qx(mgs,lc)/xdn0(li)
23206 IF ( lvol(li) .gt. 1 ) vx(mgs,li) = vx(mgs,li) + rho0(mgs)*qtmp/xdn0(li)
23207
23208 IF ( ipconc .ge. 2 ) THEN
23209 ctmp = frac*cx(mgs,lc)
23210! cx(mgs,li) = cx(mgs,li) + cx(mgs,lc)
23211 IF ( ibfc == 4 .and. lis >= 1 ) THEN
23212 cx(mgs,lis) = cx(mgs,lis) + ctmp
23213 ELSE
23214 cx(mgs,li) = cx(mgs,li) + ctmp
23215 ENDIF
23216 ELSE ! (ipconc .lt. 2 )
23217 ctmp = 0.0
23218 IF ( t9(igs(mgs),jgs,kgs(mgs)-1) .gt. qx(mgs,lc) ) THEN
23219 qtmp = frac*t9(igs(mgs),jgs,kgs(mgs)-1)
23220
23221! cx(mgs,lc) = cx(mgs,lc)*qx(mgs,lc)*rho0(mgs)/qtmp
23222 ctmp = cx(mgs,lc)*qx(mgs,lc)*rho0(mgs)/qtmp
23223 ELSE
23224 cx(mgs,lc) = max(0.0,wvel(mgs))*dtp*cwccn &
23225 & /gz(igs(mgs),jgs,kgs(mgs))
23226 cx(mgs,lc) = cwccn
23227 ENDIF
23228
23229 IF ( ipconc .ge. 1 ) cx(mgs,li) = min(ccimx, cx(mgs,li) + cx(mgs,lc))
23230 ENDIF
23231
23232 sctmp = frac*scx(mgs,lc)
23233! scx(mgs,li) = scx(mgs,li) + scx(mgs,lc)
23234 scx(mgs,li) = scx(mgs,li) + sctmp
23235! thetap(mgs) = thetap(mgs) + fcc3(mgs)*qx(mgs,lc)
23236! ptwfzi(mgs) = fcc3(mgs)*qx(mgs,lc)*dtpinv
23237! qx(mgs,lc) = 0.0
23238! cx(mgs,lc) = 0.0
23239! scx(mgs,lc) = 0.0
23240 thetap(mgs) = thetap(mgs) + fcc3(mgs)*qtmp
23241 ptwfzi(mgs) = fcc3(mgs)*qtmp*dtpinv
23242 qx(mgs,lc) = qx(mgs,lc) - qtmp
23243 cx(mgs,lc) = cx(mgs,lc) - ctmp
23244 scx(mgs,lc) = scx(mgs,lc) - sctmp
23245 end if
23246 end do
23247
23248 ENDIF ! warmonly
23249!
23250! do mgs = 1,ngscnt
23251! qwfzi(mgs) = (qcwtmp(mgs)-qx(mgs,lc))*dtpinv ! Not used?? (ERM)
23252! end do
23253!
23254! reset temporaries for cloud particles and vapor
23255!
23256 qcond(:) = 0.0
23257
23258 IF ( ipconc .le. 1 .and. lwsm6 ) THEN ! Explicit cloud condensation/evaporation (Rutledge and Hobbs 1983)
23259 DO mgs = 1,ngscnt
23260
23261 qcwtmp(mgs) = qx(mgs,lc)
23262 theta(mgs) = thetap(mgs) + theta0(mgs)
23263 temgtmp = temg(mgs)
23264! temg(mgs) = theta(mgs)*(p2(igs(mgs),jgs,kgs(mgs)) ) ! *pk(mgs) ! ( pres(mgs) / poo ) ** cap
23265! temsav = temg(mgs)
23266! thsave(mgs) = thetap(mgs)
23267 temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap
23268 temcg(mgs) = temg(mgs) - tfr
23269 ltemq = (temg(mgs)-163.15)/fqsat+1.5
23270 ltemq = min( nqsat, max(1,ltemq) )
23271
23272 qvs(mgs) = pqs(mgs)*tabqvs(ltemq)
23273
23274 IF ( ( qvap(mgs) > qvs(mgs) .or. qx(mgs,lc) > qxmin(lc) ) .and. temg(mgs) > tfrh ) THEN
23275 tmp = (qvap(mgs) - qvs(mgs))/(1. + qvs(mgs)*felv(mgs)**2/(cp*rw*temg(mgs)**2) )
23276 qcond(mgs) = min( max( 0.0, tmp ), (qvap(mgs)-qvs(mgs)) )
23277 IF ( qx(mgs,lc) > qxmin(lc) .and. tmp < 0.0 ) THEN ! evaporation
23278 qcond(mgs) = max( tmp, -qx(mgs,lc) )
23279 ENDIF
23280 qwvp(mgs) = qwvp(mgs) - qcond(mgs)
23281 qvap(mgs) = qvap(mgs) - qcond(mgs)
23282 qx(mgs,lc) = max( 0.0, qx(mgs,lc) + qcond(mgs) )
23283 thetap(mgs) = thetap(mgs) + felvcp(mgs)*qcond(mgs)/(pi0(mgs))
23284
23285 ENDIF
23286
23287 ENDDO
23288
23289 ENDIF
23290
23291
23292 IF ( ipconc .le. 1 .and. .not. lwsm6 ) THEN
23293! IF ( ipconc .le. 1 ) THEN
23294
23295 do mgs = 1,ngscnt
23296 qx(mgs,lv) = max( 0.0, qvap(mgs) )
23297 qx(mgs,lc) = max( 0.0, qx(mgs,lc) )
23298 qx(mgs,li) = max( 0.0, qx(mgs,li) )
23299 qitmp(mgs) = qx(mgs,li)
23300 end do
23301!
23302!
23303 do mgs = 1,ngscnt
23304 qcwtmp(mgs) = qx(mgs,lc)
23305 qitmp(mgs) = qx(mgs,li)
23306 theta(mgs) = thetap(mgs) + theta0(mgs)
23307 temgtmp = temg(mgs)
23308 temg(mgs) = theta(mgs)*(pinit(kgs(mgs)) + p2(igs(mgs),jgs,kgs(mgs)) ) ! *pk(mgs) ! ( pres(mgs) / poo ) ** cap
23309 temsav = temg(mgs)
23310 thsave(mgs) = thetap(mgs)
23311 temcg(mgs) = temg(mgs) - tfr
23312 tqvcon = temg(mgs)-cbw
23313 ltemq = (temg(mgs)-163.15)/fqsat+1.5
23314 ltemq = min( nqsat, max(1,ltemq) )
23315
23316 qvs(mgs) = pqs(mgs)*tabqvs(ltemq)
23317 qis(mgs) = pqs(mgs)*tabqis(ltemq)
23318 qss(mgs) = qvs(mgs)
23319 if ( temg(mgs) .lt. tfr ) then
23320 if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) &
23321 & qss(mgs) = qvs(mgs)
23322 if( qx(mgs,lc) .le. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) &
23323 & qss(mgs) = qis(mgs)
23324 if( qx(mgs,lc) .gt. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) &
23325 & qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) / &
23326 & (qx(mgs,lc) + qitmp(mgs))
23327 end if
23328 end do
23329!
23330! iterate adjustment
23331!
23332 do itertd = 1,2
23333!
23334 do mgs = 1,ngscnt
23335!
23336! calculate super-saturation
23337!
23338 qitmp(mgs) = qx(mgs,li)
23339 fcci(mgs) = 0.0
23340 fcip(mgs) = 0.0
23341 dqcw(mgs) = 0.0
23342 dqci(mgs) = 0.0
23343 dqwv(mgs) = ( qx(mgs,lv) - qss(mgs) )
23344!
23345! evaporation and sublimation adjustment
23346!
23347 if( dqwv(mgs) .lt. 0. ) then ! subsaturated
23348 if( qx(mgs,lc) .gt. -dqwv(mgs) ) then ! check if qc can make up all of the deficit
23349 dqcw(mgs) = dqwv(mgs)
23350 dqwv(mgs) = 0.
23351 else ! otherwise make all qc available for evap
23352 dqcw(mgs) = -qx(mgs,lc)
23353 dqwv(mgs) = dqwv(mgs) + qx(mgs,lc)
23354 end if
23355!
23356 if( qitmp(mgs) .gt. -dqwv(mgs) ) then ! check if qi can make up all the deficit
23357 dqci(mgs) = dqwv(mgs)
23358 dqwv(mgs) = 0.
23359 else ! otherwise make all ice available for sublimation
23360 dqci(mgs) = -qitmp(mgs)
23361 dqwv(mgs) = dqwv(mgs) + qitmp(mgs)
23362 end if
23363!
23364 qwvp(mgs) = qwvp(mgs) - ( dqcw(mgs) + dqci(mgs) ) ! add to perturbation vapor
23365!
23366! This next line removed 3/19/2003 thanks to Adam Houston,
23367! who found the bug in the 3-ICE code
23368! qwvp(mgs) = max(qwvp(mgs), 0.0)
23369 qitmp(mgs) = qx(mgs,li)
23370 IF ( qitmp(mgs) .ge. qxmin(li) ) THEN
23371 fcci(mgs) = qx(mgs,li)/(qitmp(mgs))
23372 ELSE
23373 fcci(mgs) = 1.0
23374 ENDIF
23375 qx(mgs,lc) = qx(mgs,lc) + dqcw(mgs)
23376 qx(mgs,li) = qx(mgs,li) + dqci(mgs) * fcci(mgs)
23377 thetap(mgs) = thetap(mgs) + &
23378 & 1./pi0(mgs)* &
23379 & (felvcp(mgs)*dqcw(mgs) +felscp(mgs)*dqci(mgs))
23380
23381 IF ( eqtset > 2 ) THEN
23382 pipert(mgs) = pipert(mgs) &
23383 & +(felspi(mgs)*dqci(mgs) &
23384 & +felvpi(mgs)*dqcw(mgs))*dtp
23385 ENDIF
23386
23387 end if ! dqwv(mgs) .lt. 0. (end of evap/sublim)
23388!
23389! condensation/deposition
23390!
23391 IF ( dqwv(mgs) .ge. 0. ) THEN
23392
23393! write(iunit,*) 'satadj: mgs,iter = ',mgs,itertd,dqwv(mgs),qss(mgs),qx(mgs,lv),qx(mgs,lc)
23394!
23395 qitmp(mgs) = qx(mgs,li)
23396 fracl(mgs) = 1.0
23397 fraci(mgs) = 0.0
23398 if ( temg(mgs) .lt. tfr .and. temg(mgs) .gt. thnuc ) then
23399 fracl(mgs) = max(min(1.,(temg(mgs)-233.15)/(20.)),0.0)
23400 fraci(mgs) = 1.0-fracl(mgs)
23401 end if
23402 if ( temg(mgs) .le. thnuc ) then
23403 fraci(mgs) = 1.0
23404 fracl(mgs) = 0.0
23405 end if
23406 fraci(mgs) = 1.0-fracl(mgs)
23407!
23408 gamss = (felvcp(mgs)*fracl(mgs) + felscp(mgs)*fraci(mgs)) &
23409 & / (pi0(mgs))
23410!
23411 IF ( temg(mgs) .lt. tfr ) then
23412 IF (qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) then
23413 dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv1(mgs)*qss(mgs)/ &
23414 & ((temg(mgs)-cbw)**2))
23415 END IF
23416 IF ( qx(mgs,lc) .eq. 0.0 .and. qitmp(mgs) .gt. qxmin(li) ) then
23417 dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv2(mgs)*qss(mgs)/ &
23418 & ((temg(mgs)-cbi)**2))
23419 END IF
23420 IF ( qx(mgs,lc) .gt. 0.0 .and. qitmp(mgs) .gt. qxmin(li) ) then
23421 cdw = caw*pi0(mgs)*tfrcbw/((temg(mgs)-cbw)**2)
23422 cdi = cai*pi0(mgs)*tfrcbi/((temg(mgs)-cbi)**2)
23423 denom1 = qx(mgs,lc) + qitmp(mgs)
23424 denom2 = 1.0 + gamss* &
23425 & (qx(mgs,lc)*qvs(mgs)*cdw + qitmp(mgs)*qis(mgs)*cdi) / denom1
23426 dqvcnd(mgs) = dqwv(mgs) / denom2
23427 END IF
23428
23429 ENDIF ! temg(mgs) .lt. tfr
23430!
23431 if ( temg(mgs) .ge. tfr ) then
23432 dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv1(mgs)*qss(mgs)/ &
23433 & ((temg(mgs)-cbw)**2))
23434 end if
23435!
23436 delqci1=qx(mgs,li)
23437!
23438 IF ( qitmp(mgs) .gt. qxmin(li) ) THEN
23439 fcci(mgs) = qx(mgs,li)/(qitmp(mgs))
23440 ELSE
23441 fcci(mgs) = 1.0
23442 ENDIF
23443!
23444 dqcw(mgs) = dqvcnd(mgs)*fracl(mgs)
23445 dqci(mgs) = dqvcnd(mgs)*fraci(mgs)
23446!
23447 thetap(mgs) = thetap(mgs) + &
23448 & (felvcp(mgs)*dqcw(mgs) + felscp(mgs)*dqci(mgs)) &
23449 & / (pi0(mgs))
23450
23451 IF ( eqtset > 2 ) THEN
23452 pipert(mgs) = pipert(mgs) + (0 &
23453 & +felspi(mgs)*dqci(mgs) &
23454 & +felvpi(mgs)*dqcw(mgs))*dtp
23455 ENDIF
23456
23457 qwvp(mgs) = qwvp(mgs) - ( dqvcnd(mgs) )
23458 qx(mgs,lc) = qx(mgs,lc) + dqcw(mgs)
23459! IF ( qitmp(mgs) .gt. qxmin(li) ) THEN
23460 qx(mgs,li) = qx(mgs,li) + dqci(mgs)*fcci(mgs)
23461 qitmp(mgs) = qx(mgs,li)
23462! ENDIF
23463!
23464! delqci(mgs) = dqci(mgs)*fcci(mgs)
23465!
23466 END IF ! dqwv(mgs) .ge. 0.
23467 end do
23468!
23469 do mgs = 1,ngscnt
23470 qitmp(mgs) = qx(mgs,li)
23471 theta(mgs) = thetap(mgs) + theta0(mgs)
23472 temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap
23473 qvap(mgs) = max((qwvp(mgs) + qv0(mgs)), 0.0)
23474 temcg(mgs) = temg(mgs) - tfr
23475 tqvcon = temg(mgs)-cbw
23476 ltemq = (temg(mgs)-163.15)/fqsat+1.5
23477 ltemq = min( nqsat, max(1,ltemq) )
23478 qvs(mgs) = pqs(mgs)*tabqvs(ltemq)
23479 qis(mgs) = pqs(mgs)*tabqis(ltemq)
23480 qx(mgs,lc) = max( 0.0, qx(mgs,lc) )
23481 qitmp(mgs) = max( 0.0, qitmp(mgs) )
23482 qx(mgs,lv) = max( 0.0, qvap(mgs))
23483! if ( temg(mgs) .lt. tfr ) then
23484! if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) )
23485! > qss(mgs) = qvs(mgs)
23486!c if( qx(mgs,lc) .le. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li))
23487! if( qx(mgs,lc) .eq. 0.0 .and. qitmp(mgs) .gt. qxmin(li))
23488! > qss(mgs) = qis(mgs)
23489!c if( qx(mgs,lc) .gt. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li))
23490! if( qx(mgs,lc) .gt. 0.0 .and. qitmp(mgs) .gt. qxmin(li))
23491! > qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) /
23492! > (qx(mgs,lc) + qitmp(mgs))
23493! else
23494! qss(mgs) = qvs(mgs)
23495! end if
23496 qss(mgs) = qvs(mgs)
23497 if ( temg(mgs) .lt. tfr ) then
23498 if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) &
23499 & qss(mgs) = qvs(mgs)
23500 if( qx(mgs,lc) .le. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) &
23501 & qss(mgs) = qis(mgs)
23502 if( qx(mgs,lc) .gt. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) &
23503 & qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) / &
23504 & (qx(mgs,lc) + qitmp(mgs))
23505 end if
23506! pceds(mgs) = (thetap(mgs) - thsave(mgs))*dtpinv
23507! write(iunit,*) 'satadj2: mgs,iter = ',mgs,itertd,dqwv(mgs),qss(mgs),qx(mgs,lv),qx(mgs,lc)
23508 end do
23509!
23510! end the saturation adjustment iteration loop
23511!
23512 end do
23513
23514 ENDIF ! ( ipconc .le. 1 )
23515
23516!
23517! spread the growth owing to vapor diffusion onto the
23518! ice crystal categories using the
23519!
23520! END OF SATURATION ADJUSTMENT
23521!
23522
23523 if (ndebug .gt. 0 ) write(0,*) 'conc 30b'
23524!
23525!
23526! end of saturation adjustment
23527
23528!
23529!
23530! !DIR$ IVDEP
23531 do mgs = 1,ngscnt
23532 t0(igs(mgs),jy,kgs(mgs)) = temg(mgs)
23533 end do
23534!
23535! Load the save arrays
23536!
23537
23538
23539! Sample code for using the axtra array to load microphysical rates or quantities for output
23540!
23541! Note that indices 1 and 2 are used in the nucond subroutine for condensation/evap of droplets (1) and
23542! condensation of rain (2)
23543!
23544! IF ( io_flag .and. nxtra > 1 ) THEN
23545! DO mgs = 1,ngscnt
23546! axtra(igs(mgs),jy,kgs(mgs),3) = pfrz(mgs) !
23547! axtra(igs(mgs),jy,kgs(mgs),4) = qrcev(mgs) ! pre2
23548! axtra(igs(mgs),jy,kgs(mgs),5) = psub(mgs) ! depsubr
23549! axtra(igs(mgs),jy,kgs(mgs),6) = qrfrz(mgs) ! rain freezing (Bigg)
23550! axtra(igs(mgs),jy,kgs(mgs),7) = pmlt(mgs) ! melr2
23551! ENDDO
23552! ENDIF
23553
23554
23555
23556 if (ndebug .gt. 0 ) write(0,*) 'gs 11'
23557
23558 do mgs = 1,ngscnt
23559!
23560 an(igs(mgs),jy,kgs(mgs),lt) = &
23561 & theta0(mgs) + thetap(mgs)
23562 an(igs(mgs),jy,kgs(mgs),lv) = qwvp(mgs) + qv0(mgs) !
23563
23564 IF ( eqtset > 2 ) THEN
23565 p2(igs(mgs),jy,kgs(mgs)) = pipert(mgs)
23566 ENDIF
23567!
23568
23569 DO il = lc,lhab
23570 IF ( ido(il) .eq. 1 ) THEN
23571 IF ( lf > 1 .and. il == lf ) THEN
23572 lfsave(mgs,1) = an(igs(mgs),jy,kgs(mgs),il)
23573 lfsave(mgs,2) = qx(mgs,il)
23574 ENDIF
23575 an(igs(mgs),jy,kgs(mgs),il) = qx(mgs,il) + &
23576 & min( an(igs(mgs),jy,kgs(mgs),il), 0.0 )
23577 qx(mgs,il) = an(igs(mgs),jy,kgs(mgs),il)
23578 ENDIF
23579 ENDDO
23580
23581 IF ( lcina > 1 ) THEN
23582 an(igs(mgs),jy,kgs(mgs),lcina) = cina(mgs)
23583 ENDIF
23584
23585
23586
23587
23588
23589!
23590! 6th moments
23591!
23592
23593 IF ( ipconc .ge. 6 ) THEN
23594 DO il = lr,lhab
23595 IF ( lz(il) .gt. 1 ) THEN
23596 IF ( lf > 1 .and. il == lf ) THEN
23597 lfsave(mgs,3) = an(igs(mgs),jy,kgs(mgs),lz(il))
23598 lfsave(mgs,4) = zx(mgs,il)
23599 ENDIF
23600
23601 an(igs(mgs),jy,kgs(mgs),lz(il)) = zx(mgs,il) + &
23602 & min( an(igs(mgs),jy,kgs(mgs),lz(il)), 0.0 )
23603 zx(mgs,il) = an(igs(mgs),jy,kgs(mgs),lz(il))
23604
23605 ENDIF
23606 ENDDO
23607
23608 ENDIF
23609!
23610 end do
23611!
23612
23613 if ( ipconc .ge. 1 ) then
23614 DO il = lc,lhab !{
23615
23616! write(0,*) 'limiter loop: il,ipc,lz: ',il,ipc(il),lz(il),ipconc
23617
23618 IF ( ipconc .ge. ipc(il) .and. ido(il) > 0 ) THEN ! {
23619
23620 IF ( ipconc .ge. 4 .and. ipc(il) .ge. 1 ) THEN ! {
23621
23622! write(0,*) 'MY limiter: il,ipc,lz: ',il,ipc(il),lz(il),lr,lzr
23623! STOP
23624
23625 IF ( lz(il) <= 1 .or. ioldlimiter == 1 ) THEN ! { { is a two-moment category so dont worry about reflectivity
23626
23627
23628 DO mgs = 1,ngscnt
23629 IF ( qx(mgs,il) .le. 0.0 ) THEN
23630 cx(mgs,il) = 0.0
23631 ELSE !{
23632 IF ( cx(mgs,il) .gt. cxmin ) THEN !{
23633! xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(1.0e-9,cx(mgs,il)))
23634! xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(cxmin,cx(mgs,il)))
23635 xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*cx(mgs,il))
23636
23637! IF ( lhl .gt. 1 .and. il .eq. lhl ) THEN
23638! write(0,*) 'dr: xv,cx,qx,xdn,ln = ',xv(mgs,il),cx(mgs,il),qx(mgs,il),xdn(mgs,il),ln(il)
23639! ENDIF
23640
23641 ! 8/26/2015 erm: apply imaxdiaopt for 2-moment also
23642 IF ( imaxdiaopt == 1 .or. il == lc .or. il == li .or. (il == lr .and. imurain == 3) .or. &
23643 & (il == ls .and. imusnow == 3 ) ) THEN
23644 xvbarmax = xvmx(il)
23645 ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter
23646 xvbarmax = xvmx(il) /((3. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il))))
23647 ELSEIF ( imaxdiaopt == 3 ) THEN ! test against mass-weighted diameter
23648 xvbarmax = xvmx(il) /((4. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il))))
23649 ELSE
23650 xvbarmax = xvmx(il)
23651 ENDIF
23652
23653 tmp = 1.0
23654 IF ( il == ls ) THEN
23655 xvbarmax = xvbarmax*max(1.,100./min(100.,xdn(mgs,ls)))
23656 ENDIF
23657
23658 IF ( xv(mgs,il) .lt. xvmn(il) .or. xv(mgs,il) .gt. xvbarmax ) THEN
23659 xv(mgs,il) = min( xvbarmax, xv(mgs,il) )
23660 xv(mgs,il) = max( xvmn(il), xv(mgs,il) )
23661 cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xv(mgs,il)*xdn(mgs,il))
23662 ENDIF
23663
23664 ENDIF !}
23665
23666! IF ( lhl .gt. 1 .and. il .eq. lhl ) THEN
23667! write(0,*) 'dr: xv,cx,= ',xv(mgs,il),cx(mgs,il)
23668! ENDIF
23669
23670 ENDIF !}
23671 ENDDO ! mgs
23672
23673 ELSE ! } { is three-moment, so have to adjust Z if size is too large
23674 IF ( il == lr .and. imurain == 3 ) THEN ! { { RAIN
23675
23676! rdmx =
23677! rdmn =
23678
23679 DO mgs = 1,ngscnt
23680
23681
23682 IF ( iresetmoments == 1 .or. iresetmoments == il ) THEN
23683 IF ( zx(mgs,lr) <= zxmin ) THEN
23684 qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il)
23685 qx(mgs,lr) = 0.0
23686 cx(mgs,lr) = 0.0
23687 an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),lr)
23688 an(igs(mgs),jgs,kgs(mgs),lr) = qx(mgs,lr)
23689 an(igs(mgs),jgs,kgs(mgs),ln(lr)) = cx(mgs,lr)
23690 ELSEIF ( cx(mgs,lr) <= cxmin ) THEN
23691 qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il)
23692 zx(mgs,lr) = 0.0
23693 qx(mgs,lr) = 0.0
23694 an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),lr)
23695 an(igs(mgs),jgs,kgs(mgs),lr) = qx(mgs,lr)
23696 an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr)
23697 ENDIF
23698 ENDIF
23699
23700 IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN
23701
23702 xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*max(1.0e-11,cx(mgs,lr)))
23703 IF ( xv(mgs,lr) .gt. xvmx(lr) ) THEN
23704! xv(mgs,lr) = xvmx(lr)
23705! cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmx(lr)*xdn(mgs,lr))
23706 ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN
23707 xv(mgs,lr) = xvmn(lr)
23708 cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr))
23709 ENDIF
23710
23711 IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN
23712! have mass and reflectivity but no concentration, so set concentration, using default alpha
23713 g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
23714 z = zx(mgs,il)
23715 qr = qx(mgs,il)
23716 cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*xdn(mgs,lr)**2)
23717! an(igs(mgs),jgs,kgs(mgs),ln(il)) = zx(mgs,il)
23718 ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > 0.0 ) THEN
23719! have mass and concentration but no reflectivity, so set reflectivity, using default alpha
23720 g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
23721 chw = cx(mgs,il)
23722 qr = qx(mgs,il)
23723 zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(xdn(mgs,lr)**2*chw)
23724 an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr)
23725
23726 ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN
23727! How did this happen?
23728 ! set values according to dBZ of -10, or Z = 0.1
23729! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2
23730 zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2
23731 an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
23732
23733 g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
23734 z = zx(mgs,il)
23735 qr = qx(mgs,il)
23736 cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*1000.*1000)
23737 an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
23738 ENDIF
23739
23740 IF ( zx(mgs,lr) > 0.0 ) THEN
23741 xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(1000.*cx(mgs,lr))
23742 vr = xv(mgs,lr)
23743 qr = qx(mgs,lr)
23744 nrx = cx(mgs,lr)
23745 z = zx(mgs,lr)
23746
23747! xv = (db(1,kz)*a(1,1,kz,lr))**2/(a(1,1,kz,lnr))
23748! rd = z*(pi/6.*1000.)**2/xv
23749
23750! determine shape parameter alpha by iteration
23751 IF ( z .gt. 0.0 ) THEN
23752 alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
23753 DO i = 1,20
23754 IF ( abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT
23755 alpha(mgs,lr) = max( rnumin, min( rnumax, alp ) )
23756 alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
23757 alp = max( rnumin, min( rnumax, alp ) )
23758 ENDDO
23759
23760! check for artificial breakup (rain larger than allowed max size)
23761 IF ( xv(mgs,il) .gt. xvmx(il) .or. (ioldlimiter == 2 .and. xv(mgs,il) .gt. xvmx(il)/8.) ) THEN
23762 tmp = cx(mgs,il)
23763! write(0,*) 'MY limiter: xv: ',xv(mgs,il), xv(mgs,il)/(xvmx(il)/8.)
23764! STOP
23765 IF ( ioldlimiter == 2 ) THEN ! MY-style active breakup
23766 x = (6.*rho0(mgs)*qx(mgs,il)/(pi*xdn(mgs,il)*cx(mgs,il)))**(1./3.)
23767 x1 = max(0.0e-3, x - 3.0e-3)
23768 x2 = max(0.5, x/6.0e-3)
23769 x3 = x2**3
23770 cx(mgs,il) = cx(mgs,il)*max((1.+2.222e3*x1**2), x3)
23771 xv(mgs,il) = xv(mgs,il)/max((1.+2.222e3*x1**2), x3)
23772 ELSE ! simple cutoff
23773 xv(mgs,il) = min( xvmx(il), max( xvmn(il),xv(mgs,il) ) )
23774 xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
23775 cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
23776 ENDIF
23777 !xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
23778 !cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
23779
23780
23781 IF ( tmp < cx(mgs,il) ) THEN ! breakup
23782
23783 g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
23784 zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) )
23785 an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
23786
23787 vr = xv(mgs,lr)
23788 qr = qx(mgs,lr)
23789 nrx = cx(mgs,lr)
23790 z = zx(mgs,lr)
23791
23792
23793! determine shape parameter alpha by iteration
23794 alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
23795 DO i = 1,20
23796 IF ( abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT
23797 alpha(mgs,lr) = max( rnumin, min( rnumax, alp ) )
23798 alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
23799 alp = max( rnumin, min( rnumax, alp ) )
23800 ENDDO
23801
23802
23803 ENDIF
23804 ENDIF
23805
23806!
23807! Check whether the shape parameter is at or less than the minimum, and if it is, reset the
23808! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N)
23809!
23810 g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
23811 IF ( .true. .and. (alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax) ) THEN
23812
23813 IF ( rescale_high_alpha .and. alp >= rnumax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z
23814 cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(1./(xdn(mgs,il)))**2
23815 an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il)
23816
23817 ELSEIF ( rescale_low_alphar .and. alp <= rnumin ) THEN
23818 z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2)
23819 zx(mgs,il) = z
23820 an(igs(mgs),jy,kgs(mgs),lz(il)) = zx(mgs,il)
23821 ENDIF
23822 ENDIF
23823
23824
23825
23826 ENDIF
23827 ENDIF
23828
23829 ENDIF
23830
23831 ENDDO
23832! CALL cld_cpu('Z-MOMENT-1r')
23833
23834
23835 ELSEIF ( il == lh .or. il == lhl .or. il == lf .or. (il == lr .and. imurain == 1 )) THEN ! } { Rain, GRAUPEL OR HAIL
23836
23837
23838
23839 DO mgs = 1,ngscnt
23840
23841 IF ( lf > 1 .and. il == lf ) THEN
23842 lfsave(mgs,5) = an(igs(mgs),jy,kgs(mgs),ln(il))
23843 lfsave(mgs,6) = cx(mgs,il)
23844 ENDIF
23845
23846 IF ( il == lhl .and. lnhlf > 1 ) THEN
23847 IF ( cx(mgs,lhl) > cxmin ) THEN
23848 frac = chxf(mgs,lhl)/cx(mgs,lhl)
23849 ELSE
23850 frac = 0.0
23851 ENDIF
23852 ENDIF
23853
23854 IF ( il == lh .and. lnhf > 1 ) THEN
23855 IF ( cx(mgs,lh) > cxmin ) THEN
23856 frach = chxf(mgs,lh)/cx(mgs,lh)
23857 ELSE
23858 frach = 0.0
23859 ENDIF
23860 ENDIF
23861
23862
23863
23864 IF ( iresetmoments == 1 .or. iresetmoments == il .or. iresetmoments == -1 ) THEN ! { .or. qx(mgs,il) <= qxmin(il)
23865 IF ( zx(mgs,il) <= zxmin ) THEN ! .and. qx(mgs,il) > 0.05e-3
23866!! write(91,*) 'zx=0; qx,cx = ',1000.*qx(mgs,il),cx(mgs,il)
23867 qx(mgs,il) = 0.0
23868 cx(mgs,il) = 0.0
23869 an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
23870 an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
23871 an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
23872 ELSEIF ( iresetmoments == -1 .and. qx(mgs,il) < qxmin(il) ) THEN
23873 zx(mgs,il) = 0.0
23874 cx(mgs,il) = 0.0
23875 an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
23876
23877 qx(mgs,il) = 0.0
23878 an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
23879 an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
23880 an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
23881
23882 ELSEIF ( cx(mgs,il) <= cxmin .and. iresetmoments /= -1 ) THEN ! .and. qx(mgs,il) > 0.05e-3
23883 qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il)
23884 zx(mgs,il) = 0.0
23885 qx(mgs,il) = 0.0
23886 an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
23887 an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
23888 an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
23889 ENDIF
23890 ELSE
23891 IF ( zx(mgs,il) < 0.0 ) THEN ! .and. qx(mgs,il) > 0.05e-3
23892 zx(mgs,il) = 0.0
23893 ENDIF
23894 ENDIF !}
23895
23896
23897 IF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= cxmin ) THEN
23898 zx(mgs,il) = 0.0
23899 cx(mgs,il) = 0.0
23900 an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
23901 qx(mgs,il) = 0.0
23902 an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
23903 an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
23904 an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
23905 ENDIF
23906
23907 IF ( qx(mgs,il) .gt. qxmin(il) ) THEN !{
23908
23909 xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*max(1.0e-9,cx(mgs,il)))
23910 xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
23911
23912 IF ( xv(mgs,il) .lt. xvmn(il) ) THEN
23913 xv(mgs,il) = min( xvmx(il), max( xvmn(il),xv(mgs,il) ) )
23914 xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
23915 cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
23916 ENDIF
23917
23918 IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN !{
23919! have mass and reflectivity but no concentration, so set concentration, using default alpha
23920 g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
23921 & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
23922 z = zx(mgs,il)
23923 qr = qx(mgs,il)
23924! cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z
23925 cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(z*(pi*xdn(mgs,il))**2)
23926
23927
23928 ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > 0.0 ) THEN
23929! have mass and concentration but no reflectivity, so set reflectivity, using default alpha
23930! g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
23931! & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
23932 chw = cx(mgs,il)
23933 qr = qx(mgs,il)
23934! zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw
23935! zx(mgs,il) = Min(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(chw*(pi*xdn(mgs,il))**2) )
23936 g1 = (6.0 + alphamax)*(5.0 + alphamax)*(4.0 + alphamax)/ &
23937 & ((3.0 + alphamax)*(2.0 + alphamax)*(1.0 + alphamax))
23938 zx(mgs,il) = max(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(chw*(pi*xdn(mgs,il))**2) )
23939 an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
23940
23941 ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN
23942! How did this happen?
23943 ! set values according to dBZ of -10, or Z = 0.1
23944! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2
23945
23946! write(0,*) 'GS: moment problem! il,c,z,q = ',il,cx(mgs,il),zx(mgs,il),qx(mgs,il)
23947
23948 zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2
23949 an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
23950
23951 g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
23952 & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
23953 z = zx(mgs,il)
23954 qr = qx(mgs,il)
23955! cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z
23956 cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(z*(pi*xdn(mgs,il))**2)
23957 an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
23958
23959! write(0,*) 'GS: moment problem! reset il,c,z,q = ',il,cx(mgs,il),zx(mgs,il),qx(mgs,il)
23960
23961 ELSE
23962 ! have all valid moments, so find shape parameter
23963 chw = cx(mgs,il)
23964 qr = qx(mgs,il)
23965 z = zx(mgs,il)
23966
23967 IF ( zx(mgs,il) .gt. 0. ) THEN !{
23968
23969! rdi = z*(pi/6.*1000.)**2*chw/((rho0(mgs)*qr)**2)
23970 rdi = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2)
23971
23972! alp = 1.e18*(6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/
23973! : ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
23974 alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
23975 & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
23976! print*,'kz, alp, alpha(mgs,il) = ',kz,alp,alpha(mgs,il),rdi,z,xv
23977 DO i = 1,10
23978! IF ( 100.*Abs(alp - alpha(mgs,il))/(Abs(alpha(mgs,il))+1.e-5) .lt. 1. ) EXIT
23979 IF ( abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT
23980 alpha(mgs,il) = max( alphamin, min( alphamax, alp ) )
23981! alp = 1.e18*(6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/
23982! : ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
23983 alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
23984 & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
23985! print*,'i,alp = ',i,alp
23986 alp = max( alphamin, min( alphamax, alp ) )
23987 ENDDO
23988
23989
23990! check for artificial breakup (graupel/hail larger than allowed max size)
23991 IF ( xv(mgs,il) .gt. xvmx(il) ) THEN !{
23992 tmp = cx(mgs,il)
23993
23994
23995 xv(mgs,il) = min( xvmx(il), max( xvmn(il),xv(mgs,il) ) )
23996 xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
23997 cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
23998 IF ( tmp < cx(mgs,il) ) THEN ! breakup
23999 g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
24000 & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2)
24001 zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) )
24002 an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
24003
24004 chw = cx(mgs,il)
24005 qr = qx(mgs,il)
24006 z = zx(mgs,il)
24007
24008 rdi = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2)
24009 alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
24010 & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
24011 DO i = 1,10
24012 IF ( abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT
24013 alpha(mgs,il) = max( alphamin, min( alphamax, alp ) )
24014 alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
24015 & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
24016 alp = max( alphamin, min( alphamax, alp ) )
24017 ENDDO
24018
24019
24020 ENDIF
24021 ENDIF !}
24022
24023!
24024! Check whether the shape parameter is at or less than the minimum, and if it is, reset the
24025! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N)
24026!
24027 g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
24028 & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
24029
24030 IF ( ( lrescalelow(il) .or. rescale_high_alpha ) .and. &
24031 & ( alpha(mgs,il) <= alphamin .or. alp == alphamin .or. alp == alphamax ) ) THEN !{
24032
24033 IF ( rescale_high_alpha .and. alp >= alphamax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z
24034 cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2
24035 an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il)
24036
24037 ELSEIF ( lrescalelow(il) .and. alp <= alphamin .and. .not. (il == lh .and. icvhl2h > 0 ) .and. &
24038 .not. ( il == lr .and. .not. rescale_low_alphar ) ) THEN ! alpha = alphamin, so reset Z to prevent growth in C
24039
24040 wtest = .false.
24041 IF ( irescalerainopt == 0 ) THEN
24042 wtest = .false.
24043 ELSEIF ( irescalerainopt == 1 ) THEN
24044 wtest = qx(mgs,lc) > qxmin(lc)
24045 ELSEIF ( irescalerainopt == 2 ) THEN
24046 wtest = qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < rescale_wthresh
24047 ELSEIF ( irescalerainopt == 3 ) THEN
24048 wtest = temcg(mgs) > rescale_tempthresh .and. qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < rescale_wthresh
24049 ENDIF
24050
24051 IF ( il == lr .and. ( wtest .or. .not. rescale_low_alphar ) ) THEN
24052 ! certain situations where rain number is adjusted instead of Z. Helps avoid rain being 'zapped' by autoconverted
24053 ! drops (i.e., favor preserving Z when alpha tries to go negative)
24054 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
24055 cx(mgs,il) = chw
24056 an(igs(mgs),jy,kgs(mgs),ln(il)) = chw
24057 ELSE
24058 ! Usual resetting of reflectivity moment to force consisntency between Q, N, Z, and alpha when alpha = alphamin
24059 z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw
24060 z = z1*(6./(pi*xdn(mgs,il)))**2
24061 zx(mgs,il) = z
24062 an(igs(mgs),jy,kgs(mgs),lz(il)) = z
24063 ENDIF
24064
24065! z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw
24066! z = z1*(6./(pi*xdn(mgs,il)))**2
24067! zx(mgs,il) = z
24068! an(igs(mgs),jy,kgs(mgs),lz(il)) = z
24069 ENDIF
24070
24071 ENDIF !}
24072
24073
24074 ENDIF !}
24075
24076
24077 ENDIF ! !}
24078
24079
24080
24081 ENDIF !}
24082
24083 IF ( lzr > 1 ) THEN
24084 alpha2d(igs(mgs),kgs(mgs),1) = max(alphamin, min(alphamax, alpha(mgs,lr) ))
24085 ENDIF
24086 IF ( lzh > 1 ) THEN
24087 alpha2d(igs(mgs),kgs(mgs),2) = max(alphamin, min(alphamax, alpha(mgs,lh) ))
24088 ENDIF
24089 IF ( lzhl > 1 ) THEN
24090 alpha2d(igs(mgs),kgs(mgs),3) = max(alphamin, min(alphamax, alpha(mgs,lhl) ))
24091 ENDIF
24092
24093 IF ( il == lhl .and. lnhlf > 1 ) THEN
24094 ! update chxf in case cx has changed
24095 chxf(mgs,lhl) = frac*cx(mgs,lhl)
24096 ENDIF
24097 IF ( il == lh .and. lnhf > 1 ) THEN
24098 ! update chxf in case cx has changed
24099 chxf(mgs,lh) = frach*cx(mgs,lh)
24100 ENDIF
24101
24102
24103! 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
24104! 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)
24105! write(0,*) 'qold,qxold,zold,zxold = ',lfsave(mgs,1),lfsave(mgs,2),lfsave(mgs,3),lfsave(mgs,4)
24106! write(0,*) 'cf_new,pcfwi,pcfwd = ',cx(mgs,lf),cx(mgs,lf) + dtp*( pcfwi(mgs) + pcfwd(mgs) ),pcfwi(mgs) + pcfwd(mgs)
24107!
24108! ENDIF
24109
24110 ENDDO ! mgs
24111
24112! CALL cld_cpu('Z-DELABK')
24113
24114
24115! CALL cld_cpu('Z-DELABK')
24116
24117
24118
24119
24120 ENDIF ! } }
24121
24122 ENDIF ! }}
24123 ENDIF ! }
24124
24125 DO mgs = 1,ngscnt
24126
24127 IF ( il == lh ) THEN
24128 IF ( lnhf > 1 ) THEN ! number of graupel from frozen drops
24129 an(igs(mgs),jy,kgs(mgs),lnhf) = max( chxf(mgs,lh), 0.0)
24130 ENDIF
24131 ENDIF
24132
24133 IF ( il == lhl ) THEN
24134
24135 IF ( lnhlf > 1 ) THEN ! number of hail from frozen drops
24136! an(igs(mgs),jy,kgs(mgs),lnhlf) = Min( cx(mgs,lhl), Max( chxf(mgs,lhl), 0.0) )
24137 an(igs(mgs),jy,kgs(mgs),lnhlf) = max( chxf(mgs,lhl), 0.0)
24138 ENDIF
24139 ENDIF
24140 an(igs(mgs),jy,kgs(mgs),ln(il)) = max(cx(mgs,il), 0.0)
24141 ENDDO
24142 ENDIF ! }
24143 ENDDO ! il }
24144
24145 IF ( lcin > 1 ) THEN
24146 do mgs = 1,ngscnt
24147 an(igs(mgs),jy,kgs(mgs),lcin) = max(0.0, ccin(mgs))
24148 end do
24149 ENDIF
24150
24151 IF ( ipconc .ge. 2 ) THEN
24152 do mgs = 1,ngscnt
24153 IF ( lss > 1 ) THEN
24154 an(igs(mgs),jy,kgs(mgs),lss) = max(0.0, ssmax(mgs) )
24155 ENDIF
24156
24157 IF ( lccn > 1 ) THEN
24158 an(igs(mgs),jy,kgs(mgs),lccn) = max(0.0, ccnc(mgs) )
24159 ENDIF
24160 end do
24161 ENDIF
24162
24163 ELSEIF ( ipconc .eq. 0 .and. lni .gt. 1 ) THEN
24164
24165 DO mgs = 1,ngscnt
24166 an(igs(mgs),jy,kgs(mgs),lni) = max(cx(mgs,li), 0.0)
24167 ENDDO
24168
24169
24170 end if
24171
24172 IF ( ldovol ) THEN
24173
24174 DO il = li,lhab
24175
24176 IF ( lvol(il) .ge. 1 ) THEN
24177
24178 DO mgs = 1,ngscnt
24179
24180 an(igs(mgs),jy,kgs(mgs),lvol(il)) = max( 0.0, vx(mgs,il) )
24181 ENDDO
24182
24183 ENDIF
24184
24185 ENDDO
24186
24187 ENDIF
24188!
24189!
24190!
24191!
24192!
24193 if (ndebug .gt. 0 ) write(0,*) 'gs 12'
24194
24195
24196
24197 if (ndebug .gt. 0 ) write(0,*) 'gs 13'
24198
24199 9998 continue
24200
24201 if ( kz .gt. nz-1 .and. ix .ge. itile) then
24202 if ( ix .ge. itile ) then
24203 go to 1200 ! exit gather scatter
24204 else
24205 nzmpb = kz
24206 endif
24207 else
24208 nzmpb = kz
24209 end if
24210
24211 if ( ix .ge. itile ) then
24212 nxmpb = 1
24213 nzmpb = kz+1
24214 else
24215 nxmpb = ix+1
24216 end if
24217
24218 1000 continue
24219 1200 continue
24220!
24221! end of gather scatter (for this jy slice)
24222!
24223!
24224
24225 return
24226 end subroutine nssl_2mom_gs
24227!
24228!--------------------------------------------------------------------------
24229!
24230
24231
24232
24233!
24234!--------------------------------------------------------------------------
24235!
24236
24237
24238END MODULE module_mp_nssl_2mom
subroutine radardd02(nx, ny, nz, nor, na, an, temk, dbz, db, nzdbz, cnoh0t, hwdn1t, ipconc, ke_diag, iunit)
Radar reflectivity calculation. Assumes ideal Rayleigh scattering.
subroutine calcnfromz1d(nx, ny, nz, nor, na, a, t0, ixe, kze, z0, db, jgs, ipconc, alpha, l, ln, qmin, xvmn, xvmx, t1, lvol, rho_qx, infall, ixcol)
Subroutine to correct number concentration to prevent reflectivity growth.
real function, private delbk(bb, nu, mu, k)
Function calculates collection coefficients following Siefert (2006)
subroutine calcnfromcuten(nx, ny, nz, an, anold, na, nor, norz, dn)
Subroutine to calculate number concentrations from convection parameterization rates that have only m...
subroutine, public calc_eff_radius(nx, ny, nz, na, jyslab, nor, norz, t1, t2, t3, t4, t5, t6, f_t5, f_t6, qcw, qci, qsw, qrw, ccw, cci, csw, crw, an, dn)
Subroutine to calculate effective radii for use by radiation routines.
double precision function, private gamma_dp(xx)
Douple-precision complete gamma function (double precision argument)
subroutine calczgr1d(nx, ny, nz, nor, na, a, ixe, kze, z, db, jgs, ipconc, alpha, l, ln, qmin, xvmn, xvmx, lvol, rho_qx, ixcol)
Calculates temporary reflectivity moment for adaptive size-sorting limiter.
double precision function, private gamma_dpr(x)
Douple-precision complete gamma function (single precision input)
real function, private fqis(t)
This function is for saturation vapor pressure with respect to ice.
subroutine ziegfall1d(nx, ny, nz, nor, norz, na, dtp, jgs, ixcol, xvt, rhovtzx, an, dn, ipconc0, t0, t7, cwmasn, cwmasx, cwradn, qxmin, xdnmx, xdnmn, cdx, cno, xdn0, xvmn, xvmx, ngs, qx, qxw, cx, xv, vtxbar, xmas, xdn, xdia, vx, alpha, zx, igs, kgs, rho0, temcg, temg, rhovt, cwnc, cinc, fadvisc, cwdia, cipmas, cnina, cimas, cnostmp, infdo, ildo, timesetvt)
Column-wise front end to setvtz for sedimentation.
subroutine, public 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, 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, scr, scw, sci, scs, sch, schl, sctot, elec_physics, induc, elecz, scion, sciona, noninduc, noninducp, noninducn, pcc2, pre2, depsubr, mnucf2, melr2, ctr2, rim1_2, rim2_2, rim3_2, nctr2, nnuccd2, nnucf2, effc2, effr2, effi2, effs2, effg2, fc2, fr2, fi2, fs2, fg2, fnc2, fnr2, fni2, fns2, fng2, ipelectmp, diagflag, ke_diag, errmsg, errflg, nssl_progn, wetscav_on, rainprod, evapprod, cu_used, qrcuten, qscuten, qicuten, qccuten, ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte)
Driver subroutine that copies state data to local 2D arrays for microphysics calls.
subroutine nucond(nx, ny, nz, na, jyslab, nor, norz, dtp, nxi, dz3d, t0, t9, an, dn, p2, pn, w, ngs, axtra, io_flag, ssfilt, t00, t77, flag_qndrop)
Droplet nucleation routine. Explicit condensation/evaporation. Tiny mixing ratio cleanup.
subroutine, public calcnfromq(nx, ny, nz, an, na, nor, norz, dn, qcw, qci, qsw, qrw, qhw, qhl, ccw, cci, csw, crw, chw, chl, cccn, cccna, vhw, vhl, qv, spechum, invertccn_flag, cwmasin)
Subroutine to calculate number concentrations from initial state that has only mixing ratio.
subroutine nssl_2mom_gs(nx, ny, nz, na, jyslab, nor, norz, dtp, gz, t0, t1, t2, t3, t4, t5, t6, t7, t8, t9, an, dn, p2, pn, w, iunit, t00, t77, ventr, ventc, c1sw, jgs, ido, xdnmx, xdnmn, cdx, xdn0, tmp3d, tkediss, thproc, numproc, dx1, dy1, ngs, timevtcalc, axtra, io_flag, has_wetscav, rainprod2d, evapprod2d, alpha2d, errmsg, errflg, elec, its, ids, ide, jds, jde)
Main microphysical processes routine.
real function, private gaml02d500(x)
Function calculates Gamma(0.2,x)/Gamma[0.2] for 500 micro drops ( imurain == 3 )
real function gaminterp(ratio, alp, luindex, ilh)
Function to interpolate from a table of incomplete gamma function values.
subroutine hailmaxd(dtp, nx, ny, nz, an, na, nor, norz, alpha2d, dn, hailmax1d, hailmaxk1, jslab)
Hail max size subroutine.
subroutine, private gammadp(x, ga)
Double-precision complete gamma function subroutine (used by beta function routine)
subroutine qvexcess(ngs, mgs, qwvp0, qv0, qcw1, pres, thetap0, theta0, qvex, pi0, tabqvs, nqsat, fqsat, cbw, fcqv1, felvcp, ss1, pk, ngscnt)
Subroutine that returns the maximum possible condensation.
real function, private gamma_sp(xx)
Single-precision complete gamma function.
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)
Sedimentation driver subroutine. Calls fallout column by column.
double precision function, private gamxinfdp(a1, x1)
Double-precision incomplete gamma function (single precision args)
real function, private gaml02(x)
Function calculates Gamma(0.2,x)/Gamma[0.2] for 40 micro drops ( imurain == 3 )
real function, private gaml02d300(x)
Function calculates fraction of drops larger than 300 microns ( imurain == 3 )
real function, private fqvs(t)
This function is for saturation vapor pressure with respect to liquid water.
real function, private delabk(ba, bb, nua, nub, mua, mub, k)
Function calculates collection coefficients following Siefert (2006)
subroutine, public nssl_2mom_init_const(con_g, con_rd, con_cp, con_rv, con_t0c, con_cliq, con_csol, con_eps)
NSSL MP subroutine to initialize physical constants provided by host model.
subroutine, public nssl_2mom_init(ims, ime, jms, jme, kms, kme, nssl_params, ipctmp, mixphase, ihvol, idoniconlytmp, nssl_graupelfallfac, nssl_hailfallfac, nssl_ehw0, nssl_ehlw0, nssl_icdx, nssl_icdxhl, nssl_icefallfac, nssl_snowfallfac, 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)
NSSL MP setup routine (sets local options and array indices)
subroutine fallout1d(nx, ny, nz, nor, na, dtp, dtfrac, jgs, vt, a, db1, ia, id, xfall, dtz1, ixcol)
Column sedimentation fallout subroutine.
subroutine setvtz(ngscnt, qx, qxmin, qxw, cx, rho0, rhovt, xdia, cno, cnostmp, xmas, vtxbar, xdn, xvmn0, xvmx0, xv, cdx, cdxgs, ipconc1, ndebug1, ngs, nz, kgs, fadvisc, cwmasn, cwmasx, cwradn, cnina, cimna, cimxa, itype1a, itype2a, temcg, infdo, alpha, ildo, axx, bxx)
Mean hydrometeor size and fall speed calculations.
real function, private gamxinf(a1, x1)
single-precision incomplete gamma function (single precision args)