CCPP SciDoc v7.0.0  v7.0.0
Common Community Physics Package Developed at DTC
 
Loading...
Searching...
No Matches
module_mp_thompson.F90
1
3
5
59
60MODULE module_mp_thompson
61
62 USE machine, only : kind_phys
63
64 USE module_mp_radar
65
66#ifdef MPI
67 use mpi_f08
68#endif
69
70 IMPLICIT NONE
71
72 LOGICAL, PARAMETER, PRIVATE:: iiwarm = .false.
73 LOGICAL, PRIVATE:: is_aerosol_aware = .false.
74 LOGICAL, PRIVATE:: merra2_aerosol_aware = .false.
75 LOGICAL, PARAMETER, PRIVATE:: dustyice = .true.
76 LOGICAL, PARAMETER, PRIVATE:: homogice = .true.
77
78 INTEGER, PARAMETER, PRIVATE:: ifdry = 0
79 REAL, PARAMETER, PRIVATE:: t_0 = 273.15
80 REAL, PARAMETER, PRIVATE:: pi = 3.1415926536
81
82!..Densities of rain, snow, graupel, and cloud ice.
83 REAL, PARAMETER, PRIVATE:: rho_w = 1000.0
84 REAL, PARAMETER, PRIVATE:: rho_s = 100.0
85 REAL, PARAMETER, PRIVATE:: rho_g = 500.0
86 REAL, PARAMETER, PRIVATE:: rho_i = 890.0
87
88!..Prescribed number of cloud droplets. Set according to known data or
89!.. roughly 100 per cc (100.E6 m^-3) for Maritime cases and
90!.. 300 per cc (300.E6 m^-3) for Continental. Gamma shape parameter,
91!.. mu_c, calculated based on Nt_c is important in autoconversion
92!.. scheme. In 2-moment cloud water, Nt_c represents a maximum of
93!.. droplet concentration and nu_c is also variable depending on local
94!.. droplet number concentration.
95 !REAL, PARAMETER :: Nt_c = 100.E6
96 REAL, PARAMETER :: nt_c_o = 50.e6
97 REAL, PARAMETER :: nt_c_l = 100.e6
98 REAL, PARAMETER, PRIVATE:: nt_c_max = 1999.e6
99
100!..Declaration of constants for assumed CCN/IN aerosols when none in
101!.. the input data. Look inside the init routine for modifications
102!.. due to surface land-sea points or vegetation characteristics.
103 REAL, PARAMETER :: nain0 = 1.5e6
104 REAL, PARAMETER :: nain1 = 0.5e6
105 REAL, PARAMETER :: naccn0 = 300.0e6
106 REAL, PARAMETER :: naccn1 = 50.0e6
107
108!..Generalized gamma distributions for rain, graupel and cloud ice.
109!.. N(D) = N_0 * D**mu * exp(-lamda*D); mu=0 is exponential.
110 REAL, PARAMETER, PRIVATE:: mu_r = 0.0
111 REAL, PARAMETER, PRIVATE:: mu_g = 0.0
112 REAL, PARAMETER, PRIVATE:: mu_i = 0.0
113 REAL, PRIVATE:: mu_c_o, mu_c_l
114
115!..Sum of two gamma distrib for snow (Field et al. 2005).
116!.. N(D) = M2**4/M3**3 * [Kap0*exp(-M2*Lam0*D/M3)
117!.. + Kap1*(M2/M3)**mu_s * D**mu_s * exp(-M2*Lam1*D/M3)]
118!.. M2 and M3 are the (bm_s)th and (bm_s+1)th moments respectively
119!.. calculated as function of ice water content and temperature.
120 REAL, PARAMETER, PRIVATE:: mu_s = 0.6357
121 REAL, PARAMETER, PRIVATE:: kap0 = 490.6
122 REAL, PARAMETER, PRIVATE:: kap1 = 17.46
123 REAL, PARAMETER, PRIVATE:: lam0 = 20.78
124 REAL, PARAMETER, PRIVATE:: lam1 = 3.29
125
126!..Y-intercept parameter for graupel is not constant and depends on
127!.. mixing ratio. Also, when mu_g is non-zero, these become equiv
128!.. y-intercept for an exponential distrib and proper values are
129!.. computed based on same mixing ratio and total number concentration.
130 REAL, PARAMETER, PRIVATE:: gonv_min = 1.e2
131 REAL, PARAMETER, PRIVATE:: gonv_max = 1.e6
132
133!..Mass power law relations: mass = am*D**bm
134!.. Snow from Field et al. (2005), others assume spherical form.
135 REAL, PARAMETER, PRIVATE:: am_r = pi*rho_w/6.0
136 REAL, PARAMETER, PRIVATE:: bm_r = 3.0
137 REAL, PARAMETER, PRIVATE:: am_s = 0.069
138 REAL, PARAMETER, PRIVATE:: bm_s = 2.0
139 REAL, PARAMETER, PRIVATE:: am_g = pi*rho_g/6.0
140 REAL, PARAMETER, PRIVATE:: bm_g = 3.0
141 REAL, PARAMETER, PRIVATE:: am_i = pi*rho_i/6.0
142 REAL, PARAMETER, PRIVATE:: bm_i = 3.0
143
144!..Fallspeed power laws relations: v = (av*D**bv)*exp(-fv*D)
145!.. Rain from Ferrier (1994), ice, snow, and graupel from
146!.. Thompson et al (2008). Coefficient fv is zero for graupel/ice.
147 REAL, PARAMETER, PRIVATE:: av_r = 4854.0
148 REAL, PARAMETER, PRIVATE:: bv_r = 1.0
149 REAL, PARAMETER, PRIVATE:: fv_r = 195.0
150 REAL, PARAMETER, PRIVATE:: av_s = 40.0
151 REAL, PARAMETER, PRIVATE:: bv_s = 0.55
152 REAL, PARAMETER, PRIVATE:: fv_s = 100.0
153 REAL, PARAMETER, PRIVATE:: av_g = 442.0
154 REAL, PARAMETER, PRIVATE:: bv_g = 0.89
155 REAL, PARAMETER, PRIVATE:: bv_i = 1.0
156 REAL, PARAMETER, PRIVATE:: av_c = 0.316946e8
157 REAL, PARAMETER, PRIVATE:: bv_c = 2.0
158
159!..Capacitance of sphere and plates/aggregates: D**3, D**2
160 REAL, PARAMETER, PRIVATE:: c_cube = 0.5
161 REAL, PARAMETER, PRIVATE:: c_sqrd = 0.15
162
163!..Collection efficiencies. Rain/snow/graupel collection of cloud
164!.. droplets use variables (Ef_rw, Ef_sw, Ef_gw respectively) and
165!.. get computed elsewhere because they are dependent on stokes
166!.. number.
167 REAL, PARAMETER, PRIVATE:: ef_si = 0.05
168 REAL, PARAMETER, PRIVATE:: ef_rs = 0.95
169 REAL, PARAMETER, PRIVATE:: ef_rg = 0.75
170 REAL, PARAMETER, PRIVATE:: ef_ri = 0.95
171
172!..Minimum microphys values
173!.. R1 value, 1.E-12, cannot be set lower because of numerical
174!.. problems with Paul Field's moments and should not be set larger
175!.. because of truncation problems in snow/ice growth.
176 REAL, PARAMETER, PRIVATE:: r1 = 1.e-12
177 REAL, PARAMETER, PRIVATE:: r2 = 1.e-6
178 REAL, PARAMETER :: eps = 1.e-15
179
180!..Constants in Cooper curve relation for cloud ice number.
181 REAL, PARAMETER, PRIVATE:: tno = 5.0
182 REAL, PARAMETER, PRIVATE:: ato = 0.304
183
184!..Rho_not used in fallspeed relations (rho_not/rho)**.5 adjustment.
185 REAL, PARAMETER, PRIVATE:: rho_not = 101325.0/(287.05*298.0)
186
187!..Schmidt number
188 REAL, PARAMETER, PRIVATE:: sc = 0.632
189 REAL, PRIVATE:: sc3
190
191!..Homogeneous freezing temperature
192 REAL, PARAMETER, PRIVATE:: hgfr = 235.16
193
194!..Water vapor and air gas constants at constant pressure
195 REAL, PARAMETER, PRIVATE:: rv = 461.5
196 REAL, PARAMETER, PRIVATE:: orv = 1./rv
197 REAL, PARAMETER, PRIVATE:: r = 287.04
198 REAL, PARAMETER, PRIVATE:: cp = 1004.0
199 REAL, PARAMETER, PRIVATE:: r_uni = 8.314
200
201 DOUBLE PRECISION, PARAMETER, PRIVATE:: k_b = 1.38065e-23
202 DOUBLE PRECISION, PARAMETER, PRIVATE:: m_w = 18.01528e-3
203 DOUBLE PRECISION, PARAMETER, PRIVATE:: m_a = 28.96e-3
204 DOUBLE PRECISION, PARAMETER, PRIVATE:: n_avo = 6.022e23
205 DOUBLE PRECISION, PARAMETER, PRIVATE:: ma_w = m_w / n_avo
206 REAL, PARAMETER, PRIVATE:: ar_volume = 4./3.*pi*(2.5e-6)**3
207
208!..Enthalpy of sublimation, vaporization, and fusion at 0C.
209 REAL, PARAMETER, PRIVATE:: lsub = 2.834e6
210 REAL, PARAMETER, PRIVATE:: lvap0 = 2.5e6
211 REAL, PARAMETER, PRIVATE:: lfus = lsub - lvap0
212 REAL, PARAMETER, PRIVATE:: olfus = 1./lfus
213
214!..Ice initiates with this mass (kg), corresponding diameter calc.
215!..Min diameters and mass of cloud, rain, snow, and graupel (m, kg).
216 REAL, PARAMETER, PRIVATE:: xm0i = 1.e-12
217 REAL, PARAMETER, PRIVATE:: d0c = 1.e-6
218 REAL, PARAMETER, PRIVATE:: d0r = 50.e-6
219 REAL, PARAMETER, PRIVATE:: d0s = 300.e-6
220 REAL, PARAMETER, PRIVATE:: d0g = 350.e-6
221 REAL, PRIVATE:: d0i, xm0s, xm0g
222
223!..Min and max radiative effective radius of cloud water, cloud ice, and snow;
224!.. performed by subroutine calc_effectRad. On purpose, these should stay PUBLIC.
225 REAL, PARAMETER:: re_qc_min = 2.50e-6 ! 2.5 microns
226 REAL, PARAMETER:: re_qc_max = 50.0e-6 ! 50 microns
227 REAL, PARAMETER:: re_qi_min = 2.50e-6 ! 2.5 microns
228 REAL, PARAMETER:: re_qi_max = 125.0e-6 ! 125 microns
229 REAL, PARAMETER:: re_qs_min = 5.00e-6 ! 5 microns
230 REAL, PARAMETER:: re_qs_max = 999.0e-6 ! 999 microns (1 mm)
231
232!..Lookup table dimensions
233 INTEGER, PARAMETER, PRIVATE:: nbins = 100
234 INTEGER, PARAMETER, PRIVATE:: nbc = nbins
235 INTEGER, PARAMETER, PRIVATE:: nbi = nbins
236 INTEGER, PARAMETER, PRIVATE:: nbr = nbins
237 INTEGER, PARAMETER, PRIVATE:: nbs = nbins
238 INTEGER, PARAMETER, PRIVATE:: nbg = nbins
239 INTEGER, PARAMETER, PRIVATE:: ntb_c = 37
240 INTEGER, PARAMETER, PRIVATE:: ntb_i = 64
241 INTEGER, PARAMETER, PRIVATE:: ntb_r = 37
242 INTEGER, PARAMETER, PRIVATE:: ntb_s = 28
243 INTEGER, PARAMETER, PRIVATE:: ntb_g = 28
244 INTEGER, PARAMETER, PRIVATE:: ntb_g1 = 37
245 INTEGER, PARAMETER, PRIVATE:: ntb_r1 = 37
246 INTEGER, PARAMETER, PRIVATE:: ntb_i1 = 55
247 INTEGER, PARAMETER, PRIVATE:: ntb_t = 9
248 INTEGER, PRIVATE:: nic1, nic2, nii2, nii3, nir2, nir3, nis2, nig2, nig3
249 INTEGER, PARAMETER, PRIVATE:: ntb_arc = 7
250 INTEGER, PARAMETER, PRIVATE:: ntb_arw = 9
251 INTEGER, PARAMETER, PRIVATE:: ntb_art = 7
252 INTEGER, PARAMETER, PRIVATE:: ntb_arr = 5
253 INTEGER, PARAMETER, PRIVATE:: ntb_ark = 4
254 INTEGER, PARAMETER, PRIVATE:: ntb_in = 55
255 INTEGER, PRIVATE:: niin2
256
257 DOUBLE PRECISION, DIMENSION(nbins+1):: xdx
258 DOUBLE PRECISION, DIMENSION(nbc):: dc, dtc
259 DOUBLE PRECISION, DIMENSION(nbi):: di, dti
260 DOUBLE PRECISION, DIMENSION(nbr):: dr, dtr
261 DOUBLE PRECISION, DIMENSION(nbs):: ds, dts
262 DOUBLE PRECISION, DIMENSION(nbg):: dg, dtg
263 DOUBLE PRECISION, DIMENSION(nbc):: t_nc
264
266 REAL, DIMENSION(ntb_c), PARAMETER, PRIVATE:: &
267 r_c = (/1.e-6,2.e-6,3.e-6,4.e-6,5.e-6,6.e-6,7.e-6,8.e-6,9.e-6, &
268 1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, &
269 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, &
270 1.e-3,2.e-3,3.e-3,4.e-3,5.e-3,6.e-3,7.e-3,8.e-3,9.e-3, &
271 1.e-2/)
272
274 REAL, DIMENSION(ntb_i), PARAMETER, PRIVATE:: &
275 r_i = (/1.e-10,2.e-10,3.e-10,4.e-10, &
276 5.e-10,6.e-10,7.e-10,8.e-10,9.e-10, &
277 1.e-9,2.e-9,3.e-9,4.e-9,5.e-9,6.e-9,7.e-9,8.e-9,9.e-9, &
278 1.e-8,2.e-8,3.e-8,4.e-8,5.e-8,6.e-8,7.e-8,8.e-8,9.e-8, &
279 1.e-7,2.e-7,3.e-7,4.e-7,5.e-7,6.e-7,7.e-7,8.e-7,9.e-7, &
280 1.e-6,2.e-6,3.e-6,4.e-6,5.e-6,6.e-6,7.e-6,8.e-6,9.e-6, &
281 1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, &
282 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, &
283 1.e-3/)
284
286 REAL, DIMENSION(ntb_r), PARAMETER, PRIVATE:: &
287 r_r = (/1.e-6,2.e-6,3.e-6,4.e-6,5.e-6,6.e-6,7.e-6,8.e-6,9.e-6, &
288 1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, &
289 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, &
290 1.e-3,2.e-3,3.e-3,4.e-3,5.e-3,6.e-3,7.e-3,8.e-3,9.e-3, &
291 1.e-2/)
292
294 REAL, DIMENSION(ntb_g), PARAMETER, PRIVATE:: &
295 r_g = (/1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, &
296 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, &
297 1.e-3,2.e-3,3.e-3,4.e-3,5.e-3,6.e-3,7.e-3,8.e-3,9.e-3, &
298 1.e-2/)
299
301 REAL, DIMENSION(ntb_s), PARAMETER, PRIVATE:: &
302 r_s = (/1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, &
303 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, &
304 1.e-3,2.e-3,3.e-3,4.e-3,5.e-3,6.e-3,7.e-3,8.e-3,9.e-3, &
305 1.e-2/)
306
308 REAL, DIMENSION(ntb_r1), PARAMETER, PRIVATE:: &
309 n0r_exp = (/1.e6,2.e6,3.e6,4.e6,5.e6,6.e6,7.e6,8.e6,9.e6, &
310 1.e7,2.e7,3.e7,4.e7,5.e7,6.e7,7.e7,8.e7,9.e7, &
311 1.e8,2.e8,3.e8,4.e8,5.e8,6.e8,7.e8,8.e8,9.e8, &
312 1.e9,2.e9,3.e9,4.e9,5.e9,6.e9,7.e9,8.e9,9.e9, &
313 1.e10/)
314
316 REAL, DIMENSION(ntb_g1), PARAMETER, PRIVATE:: &
317 n0g_exp = (/1.e2,2.e2,3.e2,4.e2,5.e2,6.e2,7.e2,8.e2,9.e2, &
318 1.e3,2.e3,3.e3,4.e3,5.e3,6.e3,7.e3,8.e3,9.e3, &
319 1.e4,2.e4,3.e4,4.e4,5.e4,6.e4,7.e4,8.e4,9.e4, &
320 1.e5,2.e5,3.e5,4.e5,5.e5,6.e5,7.e5,8.e5,9.e5, &
321 1.e6/)
322
324 REAL, DIMENSION(ntb_i1), PARAMETER, PRIVATE:: &
325 nt_i = (/1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0, &
326 1.e1,2.e1,3.e1,4.e1,5.e1,6.e1,7.e1,8.e1,9.e1, &
327 1.e2,2.e2,3.e2,4.e2,5.e2,6.e2,7.e2,8.e2,9.e2, &
328 1.e3,2.e3,3.e3,4.e3,5.e3,6.e3,7.e3,8.e3,9.e3, &
329 1.e4,2.e4,3.e4,4.e4,5.e4,6.e4,7.e4,8.e4,9.e4, &
330 1.e5,2.e5,3.e5,4.e5,5.e5,6.e5,7.e5,8.e5,9.e5, &
331 1.e6/)
332
333!..Aerosol table parameter: Number of available aerosols, vertical
334!.. velocity, temperature, aerosol mean radius, and hygroscopicity.
335 REAL, DIMENSION(ntb_arc), PARAMETER, PRIVATE:: &
336 ta_na = (/10.0, 31.6, 100.0, 316.0, 1000.0, 3160.0, 10000.0/)
337 REAL, DIMENSION(ntb_arw), PARAMETER, PRIVATE:: &
338 ta_ww = (/0.01, 0.0316, 0.1, 0.316, 1.0, 3.16, 10.0, 31.6, 100.0/)
339 REAL, DIMENSION(ntb_art), PARAMETER, PRIVATE:: &
340 ta_tk = (/243.15, 253.15, 263.15, 273.15, 283.15, 293.15, 303.15/)
341 REAL, DIMENSION(ntb_arr), PARAMETER, PRIVATE:: &
342 ta_ra = (/0.01, 0.02, 0.04, 0.08, 0.16/)
343 REAL, DIMENSION(ntb_ark), PARAMETER, PRIVATE:: &
344 ta_ka = (/0.2, 0.4, 0.6, 0.8/)
345
347 REAL, DIMENSION(ntb_IN), PARAMETER, PRIVATE:: &
348 nt_in = (/1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0, &
349 1.e1,2.e1,3.e1,4.e1,5.e1,6.e1,7.e1,8.e1,9.e1, &
350 1.e2,2.e2,3.e2,4.e2,5.e2,6.e2,7.e2,8.e2,9.e2, &
351 1.e3,2.e3,3.e3,4.e3,5.e3,6.e3,7.e3,8.e3,9.e3, &
352 1.e4,2.e4,3.e4,4.e4,5.e4,6.e4,7.e4,8.e4,9.e4, &
353 1.e5,2.e5,3.e5,4.e5,5.e5,6.e5,7.e5,8.e5,9.e5, &
354 1.e6/)
355
357 REAL, DIMENSION(10), PARAMETER, PRIVATE:: &
358 sa = (/ 5.065339, -0.062659, -3.032362, 0.029469, -0.000285, &
359 0.31255, 0.000204, 0.003199, 0.0, -0.015952/)
360 REAL, DIMENSION(10), PARAMETER, PRIVATE:: &
361 sb = (/ 0.476221, -0.015896, 0.165977, 0.007468, -0.000141, &
362 0.060366, 0.000079, 0.000594, 0.0, -0.003577/)
363
365 REAL, DIMENSION(ntb_t), PARAMETER, PRIVATE:: &
366 tc = (/-0.01, -5., -10., -15., -20., -25., -30., -35., -40./)
367
368!..Lookup tables for various accretion/collection terms.
369!.. ntb_x refers to the number of elements for rain, snow, graupel,
370!.. and temperature array indices. Variables beginning with t-p/c/m/n
371!.. represent lookup tables. Save compile-time memory by making
372!.. allocatable (2009Jun12, J. Michalakes).
373
374!..To permit possible creation of new lookup tables as variables expand/change,
375!.. specify a name of external file(s) including version number for pre-computed
376!.. Thompson tables.
377 character(len=*), parameter :: thomp_table_file = 'thompson_tables_precomp_v2.sl'
378 character(len=*), parameter :: qr_acr_qg_file = 'qr_acr_qgV2.dat'
379 character(len=*), parameter :: qr_acr_qs_file = 'qr_acr_qsV2.dat'
380 character(len=*), parameter :: freeze_h2o_file = 'freezeH2O.dat'
381
382 INTEGER, PARAMETER, PRIVATE:: r8size = 8
383 INTEGER, PARAMETER, PRIVATE:: r4size = 4
384 REAL (kind=r8size), ALLOCATABLE, DIMENSION(:,:,:,:):: &
385 tcg_racg, tmr_racg, tcr_gacr, tmg_gacr, &
386 tnr_racg, tnr_gacr
387 REAL (kind=r8size), ALLOCATABLE, DIMENSION(:,:,:,:):: &
388 tcs_racs1, tmr_racs1, tcs_racs2, tmr_racs2, &
389 tcr_sacr1, tms_sacr1, tcr_sacr2, tms_sacr2, &
390 tnr_racs1, tnr_racs2, tnr_sacr1, tnr_sacr2
391 REAL (kind=r8size), ALLOCATABLE, DIMENSION(:,:,:,:):: &
392 tpi_qcfz, tni_qcfz
393 REAL (kind=r8size), ALLOCATABLE, DIMENSION(:,:,:,:):: &
394 tpi_qrfz, tpg_qrfz, tni_qrfz, tnr_qrfz
395 REAL (kind=r8size), ALLOCATABLE, DIMENSION(:,:):: &
396 tps_iaus, tni_iaus, tpi_ide
397 REAL (kind=r8size), ALLOCATABLE, DIMENSION(:,:):: t_efrw
398 REAL (kind=r8size), ALLOCATABLE, DIMENSION(:,:):: t_efsw
399 REAL (kind=r8size), ALLOCATABLE, DIMENSION(:,:,:):: tnr_rev
400 REAL (kind=r8size), ALLOCATABLE, DIMENSION(:,:,:):: &
401 tpc_wev, tnc_wev
402 REAL (kind=r4size), ALLOCATABLE, DIMENSION(:,:,:,:,:):: tnccn_act
403
404!..Variables holding a bunch of exponents and gamma values (cloud water,
405!.. cloud ice, rain, snow, then graupel).
406 REAL, DIMENSION(5,15), PRIVATE:: cce, ccg
407 REAL, DIMENSION(15), PRIVATE:: ocg1, ocg2
408 REAL, DIMENSION(7), PRIVATE:: cie, cig
409 REAL, PRIVATE:: oig1, oig2, obmi
410 REAL, DIMENSION(13), PRIVATE:: cre, crg
411 REAL, PRIVATE:: ore1, org1, org2, org3, obmr
412 REAL, DIMENSION(18), PRIVATE:: cse, csg
413 REAL, PRIVATE:: oams, obms, ocms
414 REAL, DIMENSION(12), PRIVATE:: cge, cgg
415 REAL, PRIVATE:: oge1, ogg1, ogg2, ogg3, oamg, obmg, ocmg
416
417!..Declaration of precomputed constants in various rate eqns.
418 REAL:: t1_qr_qc, t1_qr_qi, t2_qr_qi, t1_qg_qc, t1_qs_qc, t1_qs_qi
419 REAL:: t1_qr_ev, t2_qr_ev
420 REAL:: t1_qs_sd, t2_qs_sd, t1_qg_sd, t2_qg_sd
421 REAL:: t1_qs_me, t2_qs_me, t1_qg_me, t2_qg_me
422
423!..MPI communicator
424 TYPE(mpi_comm):: mpi_communicator
425
426!..Write tables with master MPI task after computing them in thompson_init
427 LOGICAL:: thompson_table_writer
428
429!+---+
430!+---+-----------------------------------------------------------------+
431!..END DECLARATIONS
432!+---+-----------------------------------------------------------------+
433!+---+
434!ctrlL
435
436 CONTAINS
442 SUBROUTINE thompson_init(is_aerosol_aware_in, &
443 merra2_aerosol_aware_in, &
444 mpicomm, mpirank, mpiroot, &
445 threads, errmsg, errflg)
446
447 IMPLICIT NONE
448
449 LOGICAL, INTENT(IN) :: is_aerosol_aware_in
450 LOGICAL, INTENT(IN) :: merra2_aerosol_aware_in
451 TYPE(mpi_comm), INTENT(IN) :: mpicomm
452 INTEGER, INTENT(IN) :: mpirank, mpiroot
453 INTEGER, INTENT(IN) :: threads
454 CHARACTER(len=*), INTENT(INOUT) :: errmsg
455 INTEGER, INTENT(INOUT) :: errflg
456
457 INTEGER:: i, j, k, l, m, n
458 LOGICAL:: micro_init
459 real :: stime, etime
460 LOGICAL, PARAMETER :: precomputed_tables = .false.
461
462! Set module variable is_aerosol_aware/merra2_aerosol_aware
463 is_aerosol_aware = is_aerosol_aware_in
464 merra2_aerosol_aware = merra2_aerosol_aware_in
465 if (is_aerosol_aware .and. merra2_aerosol_aware) then
466 errmsg = 'Logic error in thompson_init: only one of the two options can be true, ' // &
467 'not both: is_aerosol_aware or merra2_aerosol_aware'
468 errflg = 1
469 return
470 end if
471 if (mpirank==mpiroot) then
472 if (is_aerosol_aware) then
473 write (*,'(a)') 'Using aerosol-aware version of Thompson microphysics'
474 else if(merra2_aerosol_aware) then
475 write (*,'(a)') 'Using merra2 aerosol-aware version of Thompson microphysics'
476 else
477 write (*,'(a)') 'Using non-aerosol-aware version of Thompson microphysics'
478 end if
479 end if
480
481 micro_init = .false.
482
484
485 if (.NOT. ALLOCATED(tcg_racg) ) then
486 ALLOCATE(tcg_racg(ntb_g1,ntb_g,ntb_r1,ntb_r))
487 micro_init = .true.
488 endif
489
490 if (.NOT. ALLOCATED(tmr_racg)) ALLOCATE(tmr_racg(ntb_g1,ntb_g,ntb_r1,ntb_r))
491 if (.NOT. ALLOCATED(tcr_gacr)) ALLOCATE(tcr_gacr(ntb_g1,ntb_g,ntb_r1,ntb_r))
492 if (.NOT. ALLOCATED(tmg_gacr)) ALLOCATE(tmg_gacr(ntb_g1,ntb_g,ntb_r1,ntb_r))
493 if (.NOT. ALLOCATED(tnr_racg)) ALLOCATE(tnr_racg(ntb_g1,ntb_g,ntb_r1,ntb_r))
494 if (.NOT. ALLOCATED(tnr_gacr)) ALLOCATE(tnr_gacr(ntb_g1,ntb_g,ntb_r1,ntb_r))
495
496 if (.NOT. ALLOCATED(tcs_racs1)) ALLOCATE(tcs_racs1(ntb_s,ntb_t,ntb_r1,ntb_r))
497 if (.NOT. ALLOCATED(tmr_racs1)) ALLOCATE(tmr_racs1(ntb_s,ntb_t,ntb_r1,ntb_r))
498 if (.NOT. ALLOCATED(tcs_racs2)) ALLOCATE(tcs_racs2(ntb_s,ntb_t,ntb_r1,ntb_r))
499 if (.NOT. ALLOCATED(tmr_racs2)) ALLOCATE(tmr_racs2(ntb_s,ntb_t,ntb_r1,ntb_r))
500 if (.NOT. ALLOCATED(tcr_sacr1)) ALLOCATE(tcr_sacr1(ntb_s,ntb_t,ntb_r1,ntb_r))
501 if (.NOT. ALLOCATED(tms_sacr1)) ALLOCATE(tms_sacr1(ntb_s,ntb_t,ntb_r1,ntb_r))
502 if (.NOT. ALLOCATED(tcr_sacr2)) ALLOCATE(tcr_sacr2(ntb_s,ntb_t,ntb_r1,ntb_r))
503 if (.NOT. ALLOCATED(tms_sacr2)) ALLOCATE(tms_sacr2(ntb_s,ntb_t,ntb_r1,ntb_r))
504 if (.NOT. ALLOCATED(tnr_racs1)) ALLOCATE(tnr_racs1(ntb_s,ntb_t,ntb_r1,ntb_r))
505 if (.NOT. ALLOCATED(tnr_racs2)) ALLOCATE(tnr_racs2(ntb_s,ntb_t,ntb_r1,ntb_r))
506 if (.NOT. ALLOCATED(tnr_sacr1)) ALLOCATE(tnr_sacr1(ntb_s,ntb_t,ntb_r1,ntb_r))
507 if (.NOT. ALLOCATED(tnr_sacr2)) ALLOCATE(tnr_sacr2(ntb_s,ntb_t,ntb_r1,ntb_r))
508
509 if (.NOT. ALLOCATED(tpi_qcfz)) ALLOCATE(tpi_qcfz(ntb_c,nbc,45,ntb_in))
510 if (.NOT. ALLOCATED(tni_qcfz)) ALLOCATE(tni_qcfz(ntb_c,nbc,45,ntb_in))
511
512 if (.NOT. ALLOCATED(tpi_qrfz)) ALLOCATE(tpi_qrfz(ntb_r,ntb_r1,45,ntb_in))
513 if (.NOT. ALLOCATED(tpg_qrfz)) ALLOCATE(tpg_qrfz(ntb_r,ntb_r1,45,ntb_in))
514 if (.NOT. ALLOCATED(tni_qrfz)) ALLOCATE(tni_qrfz(ntb_r,ntb_r1,45,ntb_in))
515 if (.NOT. ALLOCATED(tnr_qrfz)) ALLOCATE(tnr_qrfz(ntb_r,ntb_r1,45,ntb_in))
516
517 if (.NOT. ALLOCATED(tps_iaus)) ALLOCATE(tps_iaus(ntb_i,ntb_i1))
518 if (.NOT. ALLOCATED(tni_iaus)) ALLOCATE(tni_iaus(ntb_i,ntb_i1))
519 if (.NOT. ALLOCATED(tpi_ide)) ALLOCATE(tpi_ide(ntb_i,ntb_i1))
520
521 if (.NOT. ALLOCATED(t_efrw)) ALLOCATE(t_efrw(nbr,nbc))
522 if (.NOT. ALLOCATED(t_efsw)) ALLOCATE(t_efsw(nbs,nbc))
523
524 if (.NOT. ALLOCATED(tnr_rev)) ALLOCATE(tnr_rev(nbr, ntb_r1, ntb_r))
525 if (.NOT. ALLOCATED(tpc_wev)) ALLOCATE(tpc_wev(nbc,ntb_c,nbc))
526 if (.NOT. ALLOCATED(tnc_wev)) ALLOCATE(tnc_wev(nbc,ntb_c,nbc))
527
528 if (.NOT. ALLOCATED(tnccn_act)) &
529 ALLOCATE(tnccn_act(ntb_arc,ntb_arw,ntb_art,ntb_arr,ntb_ark))
530
531 if_micro_init: if (micro_init) then
532
536!.. disp=SQRT((mu+2)/(mu+1) - 1) so mu varies from 15 for Maritime
537!.. to 2 for really dirty air. This not used in 2-moment cloud water
538!.. scheme and nu_c used instead and varies from 2 to 15 (integer-only).
539 mu_c_l = min(15., (1000.e6/nt_c_l + 2.))
540 mu_c_o = min(15., (1000.e6/nt_c_o + 2.))
541
543 sc3 = sc**(1./3.)
544
546 d0i = (xm0i/am_i)**(1./bm_i)
547 xm0s = am_s * d0s**bm_s
548 xm0g = am_g * d0g**bm_g
549
552 do n = 1, 15
553 cce(1,n) = n + 1.
554 cce(2,n) = bm_r + n + 1.
555 cce(3,n) = bm_r + n + 4.
556 cce(4,n) = n + bv_c + 1.
557 cce(5,n) = bm_r + n + bv_c + 1.
558 ccg(1,n) = wgamma(cce(1,n))
559 ccg(2,n) = wgamma(cce(2,n))
560 ccg(3,n) = wgamma(cce(3,n))
561 ccg(4,n) = wgamma(cce(4,n))
562 ccg(5,n) = wgamma(cce(5,n))
563 ocg1(n) = 1./ccg(1,n)
564 ocg2(n) = 1./ccg(2,n)
565 enddo
566
567 cie(1) = mu_i + 1.
568 cie(2) = bm_i + mu_i + 1.
569 cie(3) = bm_i + mu_i + bv_i + 1.
570 cie(4) = mu_i + bv_i + 1.
571 cie(5) = mu_i + 2.
572 cie(6) = bm_i*0.5 + mu_i + bv_i + 1.
573 cie(7) = bm_i*0.5 + mu_i + 1.
574 cig(1) = wgamma(cie(1))
575 cig(2) = wgamma(cie(2))
576 cig(3) = wgamma(cie(3))
577 cig(4) = wgamma(cie(4))
578 cig(5) = wgamma(cie(5))
579 cig(6) = wgamma(cie(6))
580 cig(7) = wgamma(cie(7))
581 oig1 = 1./cig(1)
582 oig2 = 1./cig(2)
583 obmi = 1./bm_i
584
585 cre(1) = bm_r + 1.
586 cre(2) = mu_r + 1.
587 cre(3) = bm_r + mu_r + 1.
588 cre(4) = bm_r*2. + mu_r + 1.
589 cre(5) = mu_r + bv_r + 1.
590 cre(6) = bm_r + mu_r + bv_r + 1.
591 cre(7) = bm_r*0.5 + mu_r + bv_r + 1.
592 cre(8) = bm_r + mu_r + bv_r + 3.
593 cre(9) = mu_r + bv_r + 3.
594 cre(10) = mu_r + 2.
595 cre(11) = 0.5*(bv_r + 5. + 2.*mu_r)
596 cre(12) = bm_r*0.5 + mu_r + 1.
597 cre(13) = bm_r*2. + mu_r + bv_r + 1.
598 do n = 1, 13
599 crg(n) = wgamma(cre(n))
600 enddo
601 obmr = 1./bm_r
602 ore1 = 1./cre(1)
603 org1 = 1./crg(1)
604 org2 = 1./crg(2)
605 org3 = 1./crg(3)
606
607 cse(1) = bm_s + 1.
608 cse(2) = bm_s + 2.
609 cse(3) = bm_s*2.
610 cse(4) = bm_s + bv_s + 1.
611 cse(5) = bm_s*2. + bv_s + 1.
612 cse(6) = bm_s*2. + 1.
613 cse(7) = bm_s + mu_s + 1.
614 cse(8) = bm_s + mu_s + 2.
615 cse(9) = bm_s + mu_s + 3.
616 cse(10) = bm_s + mu_s + bv_s + 1.
617 cse(11) = bm_s*2. + mu_s + bv_s + 1.
618 cse(12) = bm_s*2. + mu_s + 1.
619 cse(13) = bv_s + 2.
620 cse(14) = bm_s + bv_s
621 cse(15) = mu_s + 1.
622 cse(16) = 1.0 + (1.0 + bv_s)/2.
623 cse(17) = cse(16) + mu_s + 1.
624 cse(18) = bv_s + mu_s + 3.
625 do n = 1, 18
626 csg(n) = wgamma(cse(n))
627 enddo
628 oams = 1./am_s
629 obms = 1./bm_s
630 ocms = oams**obms
631
632 cge(1) = bm_g + 1.
633 cge(2) = mu_g + 1.
634 cge(3) = bm_g + mu_g + 1.
635 cge(4) = bm_g*2. + mu_g + 1.
636 cge(5) = bm_g*2. + mu_g + bv_g + 1.
637 cge(6) = bm_g + mu_g + bv_g + 1.
638 cge(7) = bm_g + mu_g + bv_g + 2.
639 cge(8) = bm_g + mu_g + bv_g + 3.
640 cge(9) = mu_g + bv_g + 3.
641 cge(10) = mu_g + 2.
642 cge(11) = 0.5*(bv_g + 5. + 2.*mu_g)
643 cge(12) = 0.5*(bv_g + 5.) + mu_g
644 do n = 1, 12
645 cgg(n) = wgamma(cge(n))
646 enddo
647 oamg = 1./am_g
648 obmg = 1./bm_g
649 ocmg = oamg**obmg
650 oge1 = 1./cge(1)
651 ogg1 = 1./cgg(1)
652 ogg2 = 1./cgg(2)
653 ogg3 = 1./cgg(3)
654
655!+---+-----------------------------------------------------------------+
657!+---+-----------------------------------------------------------------+
658
660 t1_qr_qc = pi*.25*av_r * crg(9)
661 t1_qr_qi = pi*.25*av_r * crg(9)
662 t2_qr_qi = pi*.25*am_r*av_r * crg(8)
663
665 t1_qg_qc = pi*.25*av_g * cgg(9)
666
668 t1_qs_qc = pi*.25*av_s
669
671 t1_qs_qi = pi*.25*av_s
672
674 t1_qr_ev = 0.78 * crg(10)
675 t2_qr_ev = 0.308*sc3*sqrt(av_r) * crg(11)
676
678 t1_qs_sd = 0.86
679 t2_qs_sd = 0.28*sc3*sqrt(av_s)
680
682 t1_qs_me = pi*4.*c_sqrd*olfus * 0.86
683 t2_qs_me = pi*4.*c_sqrd*olfus * 0.28*sc3*sqrt(av_s)
684
686 t1_qg_sd = 0.86 * cgg(10)
687 t2_qg_sd = 0.28*sc3*sqrt(av_g) * cgg(11)
688
690 t1_qg_me = pi*4.*c_cube*olfus * 0.86 * cgg(10)
691 t2_qg_me = pi*4.*c_cube*olfus * 0.28*sc3*sqrt(av_g) * cgg(11)
692
694 nic2 = nint(alog10(r_c(1)))
695 nii2 = nint(alog10(r_i(1)))
696 nii3 = nint(alog10(nt_i(1)))
697 nir2 = nint(alog10(r_r(1)))
698 nir3 = nint(alog10(n0r_exp(1)))
699 nis2 = nint(alog10(r_s(1)))
700 nig2 = nint(alog10(r_g(1)))
701 nig3 = nint(alog10(n0g_exp(1)))
702 niin2 = nint(alog10(nt_in(1)))
703
705 dc(1) = d0c*1.0d0
706 dtc(1) = d0c*1.0d0
707 do n = 2, nbc
708 dc(n) = dc(n-1) + 1.0d-6
709 dtc(n) = (dc(n) - dc(n-1))
710 enddo
711
713 xdx(1) = d0i*1.0d0
714 xdx(nbi+1) = 2.0d0*d0s
715 do n = 2, nbi
716 xdx(n) = dexp(dfloat(n-1)/dfloat(nbi) &
717 *dlog(xdx(nbi+1)/xdx(1)) +dlog(xdx(1)))
718 enddo
719 do n = 1, nbi
720 di(n) = dsqrt(xdx(n)*xdx(n+1))
721 dti(n) = xdx(n+1) - xdx(n)
722 enddo
723
725 xdx(1) = d0r*1.0d0
726 xdx(nbr+1) = 0.005d0
727 do n = 2, nbr
728 xdx(n) = dexp(dfloat(n-1)/dfloat(nbr) &
729 *dlog(xdx(nbr+1)/xdx(1)) +dlog(xdx(1)))
730 enddo
731 do n = 1, nbr
732 dr(n) = dsqrt(xdx(n)*xdx(n+1))
733 dtr(n) = xdx(n+1) - xdx(n)
734 enddo
735
737 xdx(1) = d0s*1.0d0
738 xdx(nbs+1) = 0.02d0
739 do n = 2, nbs
740 xdx(n) = dexp(dfloat(n-1)/dfloat(nbs) &
741 *dlog(xdx(nbs+1)/xdx(1)) +dlog(xdx(1)))
742 enddo
743 do n = 1, nbs
744 ds(n) = dsqrt(xdx(n)*xdx(n+1))
745 dts(n) = xdx(n+1) - xdx(n)
746 enddo
747
749 xdx(1) = d0g*1.0d0
750 xdx(nbg+1) = 0.05d0
751 do n = 2, nbg
752 xdx(n) = dexp(dfloat(n-1)/dfloat(nbg) &
753 *dlog(xdx(nbg+1)/xdx(1)) +dlog(xdx(1)))
754 enddo
755 do n = 1, nbg
756 dg(n) = dsqrt(xdx(n)*xdx(n+1))
757 dtg(n) = xdx(n+1) - xdx(n)
758 enddo
759
761 xdx(1) = 1.0d0
762 xdx(nbc+1) = 3000.0d0
763 do n = 2, nbc
764 xdx(n) = dexp(dfloat(n-1)/dfloat(nbc) &
765 *dlog(xdx(nbc+1)/xdx(1)) +dlog(xdx(1)))
766 enddo
767 do n = 1, nbc
768 t_nc(n) = dsqrt(xdx(n)*xdx(n+1)) * 1.d6
769 enddo
770 nic1 = dlog(t_nc(nbc)/t_nc(1))
771
772!+---+-----------------------------------------------------------------+
774!+---+-----------------------------------------------------------------+
775
776 ! Assign mpicomm to module variable
777 mpi_communicator = mpicomm
778
779 ! Standard tables are only written by master MPI task;
780 ! (physics init cannot be called by multiple threads,
781 ! hence no need to test for a specific thread number)
782 if (mpirank==mpiroot) then
783 thompson_table_writer = .true.
784 else
785 thompson_table_writer = .false.
786 end if
787
788 precomputed_tables_1: if (.not.precomputed_tables) then
789
790 call cpu_time(stime)
791
792 do m = 1, ntb_r
793 do k = 1, ntb_r1
794 do j = 1, ntb_g
795 do i = 1, ntb_g1
796 tcg_racg(i,j,k,m) = 0.0d0
797 tmr_racg(i,j,k,m) = 0.0d0
798 tcr_gacr(i,j,k,m) = 0.0d0
799 tmg_gacr(i,j,k,m) = 0.0d0
800 tnr_racg(i,j,k,m) = 0.0d0
801 tnr_gacr(i,j,k,m) = 0.0d0
802 enddo
803 enddo
804 enddo
805 enddo
806
807 do m = 1, ntb_r
808 do k = 1, ntb_r1
809 do j = 1, ntb_t
810 do i = 1, ntb_s
811 tcs_racs1(i,j,k,m) = 0.0d0
812 tmr_racs1(i,j,k,m) = 0.0d0
813 tcs_racs2(i,j,k,m) = 0.0d0
814 tmr_racs2(i,j,k,m) = 0.0d0
815 tcr_sacr1(i,j,k,m) = 0.0d0
816 tms_sacr1(i,j,k,m) = 0.0d0
817 tcr_sacr2(i,j,k,m) = 0.0d0
818 tms_sacr2(i,j,k,m) = 0.0d0
819 tnr_racs1(i,j,k,m) = 0.0d0
820 tnr_racs2(i,j,k,m) = 0.0d0
821 tnr_sacr1(i,j,k,m) = 0.0d0
822 tnr_sacr2(i,j,k,m) = 0.0d0
823 enddo
824 enddo
825 enddo
826 enddo
827
828 do m = 1, ntb_in
829 do k = 1, 45
830 do j = 1, ntb_r1
831 do i = 1, ntb_r
832 tpi_qrfz(i,j,k,m) = 0.0d0
833 tni_qrfz(i,j,k,m) = 0.0d0
834 tpg_qrfz(i,j,k,m) = 0.0d0
835 tnr_qrfz(i,j,k,m) = 0.0d0
836 enddo
837 enddo
838 do j = 1, nbc
839 do i = 1, ntb_c
840 tpi_qcfz(i,j,k,m) = 0.0d0
841 tni_qcfz(i,j,k,m) = 0.0d0
842 enddo
843 enddo
844 enddo
845 enddo
846
847 do j = 1, ntb_i1
848 do i = 1, ntb_i
849 tps_iaus(i,j) = 0.0d0
850 tni_iaus(i,j) = 0.0d0
851 tpi_ide(i,j) = 0.0d0
852 enddo
853 enddo
854
855 do j = 1, nbc
856 do i = 1, nbr
857 t_efrw(i,j) = 0.0
858 enddo
859 do i = 1, nbs
860 t_efsw(i,j) = 0.0
861 enddo
862 enddo
863
864 do k = 1, ntb_r
865 do j = 1, ntb_r1
866 do i = 1, nbr
867 tnr_rev(i,j,k) = 0.0d0
868 enddo
869 enddo
870 enddo
871
872 do k = 1, nbc
873 do j = 1, ntb_c
874 do i = 1, nbc
875 tpc_wev(i,j,k) = 0.0d0
876 tnc_wev(i,j,k) = 0.0d0
877 enddo
878 enddo
879 enddo
880
881 do m = 1, ntb_ark
882 do l = 1, ntb_arr
883 do k = 1, ntb_art
884 do j = 1, ntb_arw
885 do i = 1, ntb_arc
886 tnccn_act(i,j,k,l,m) = 1.0
887 enddo
888 enddo
889 enddo
890 enddo
891 enddo
892
893 if (mpirank==mpiroot) write (*,*)'creating microphysics lookup tables ... '
894 if (mpirank==mpiroot) write (*,'(a, f5.2, a, f5.2, a, f5.2, a, f5.2)') &
895 ' using: mu_c_o=',mu_c_o,' mu_i=',mu_i,' mu_r=',mu_r,' mu_g=',mu_g
896
900 if (mpirank==mpiroot) write(*,*) ' calling table_ccnAct routine'
901 call table_ccnact(errmsg,errflg)
902 if (.not. errflg==0) return
903
906 if (mpirank==mpiroot) write(*,*) ' creating qc collision eff tables'
907 call table_efrw
908 call table_efsw
909
911 if (mpirank==mpiroot) write(*,*) ' creating rain evap table'
912 call table_dropevap
913
915 if (mpirank==mpiroot) write(*,*) ' creating ice converting to snow table'
916 call qi_aut_qs
917
918 call cpu_time(etime)
919 if (mpirank==mpiroot) print '("Calculating Thompson tables part 1 took ",f10.3," seconds.")', etime-stime
920
921 end if precomputed_tables_1
922
924 call cpu_time(stime)
925 xam_r = am_r
926 xbm_r = bm_r
927 xmu_r = mu_r
928 xam_s = am_s
929 xbm_s = bm_s
930 xmu_s = mu_s
931 xam_g = am_g
932 xbm_g = bm_g
933 xmu_g = mu_g
934 call radar_init
935 call cpu_time(etime)
936 if (mpirank==mpiroot) print '("Calling radar_init took ",f10.3," seconds.")', etime-stime
937
938
939 if_not_iiwarm: if (.not. iiwarm) then
940
941 precomputed_tables_2: if (.not.precomputed_tables) then
942
943 call cpu_time(stime)
944
946 if (mpirank==mpiroot) write(*,*) ' creating rain collecting graupel table'
947 call cpu_time(stime)
948 call qr_acr_qg
949 call cpu_time(etime)
950 if (mpirank==mpiroot) print '("Computing rain collecting graupel table took ",f10.3," seconds.")', etime-stime
951
953 if (mpirank==mpiroot) write (*,*) ' creating rain collecting snow table'
954 call cpu_time(stime)
955 call qr_acr_qs
956 call cpu_time(etime)
957 if (mpirank==mpiroot) print '("Computing rain collecting snow table took ",f10.3," seconds.")', etime-stime
958
960 if (mpirank==mpiroot) write(*,*) ' creating freezing of water drops table'
961 call cpu_time(stime)
962 call freezeh2o(threads)
963 call cpu_time(etime)
964 if (mpirank==mpiroot) print '("Computing freezing of water drops table took ",f10.3," seconds.")', etime-stime
965
966 call cpu_time(etime)
967 if (mpirank==mpiroot) print '("Calculating Thompson tables part 2 took ",f10.3," seconds.")', etime-stime
968
969 end if precomputed_tables_2
970
971 endif if_not_iiwarm
972
973 if (mpirank==mpiroot) write(*,*) ' ... DONE microphysical lookup tables'
974
975 endif if_micro_init
976
977 END SUBROUTINE thompson_init
979
984 SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, &
985 nwfa, nifa, nwfa2d, nifa2d, &
986 tt, th, pii, &
987 p, w, dz, dt_in, dt_inner, &
988 sedi_semi, decfl, lsm, &
989 RAINNC, RAINNCV, &
990 SNOWNC, SNOWNCV, &
991 ICENC, ICENCV, &
992 GRAUPELNC, GRAUPELNCV, SR, &
993#if ( WRF_CHEM == 1 )
994 rainprod, evapprod, &
995#endif
996 refl_10cm, diagflag, do_radar_ref, &
997 max_hail_diam_sfc, &
998 vt_dbz_wt, first_time_step, &
999 re_cloud, re_ice, re_snow, &
1000 has_reqc, has_reqi, has_reqs, &
1001 aero_ind_fdb, rand_perturb_on, &
1002 kme_stoch, &
1003 rand_pert, spp_prt_list, spp_var_list, &
1004 spp_stddev_cutoff, n_var_spp, &
1005 ids,ide, jds,jde, kds,kde, & ! domain dims
1006 ims,ime, jms,jme, kms,kme, & ! memory dims
1007 its,ite, jts,jte, kts,kte, & ! tile dims
1008 fullradar_diag, istep, nsteps, &
1009 errmsg, errflg, &
1010 ! Extended diagnostics, array pointers
1011 ! only associated if ext_diag flag is .true.
1012 ext_diag, &
1013 !vts1, txri, txrc, &
1014 prw_vcdc, &
1015 prw_vcde, tpri_inu, tpri_ide_d, &
1016 tpri_ide_s, tprs_ide, tprs_sde_d, &
1017 tprs_sde_s, tprg_gde_d, &
1018 tprg_gde_s, tpri_iha, tpri_wfz, &
1019 tpri_rfz, tprg_rfz, tprs_scw, tprg_scw, &
1020 tprg_rcs, tprs_rcs, &
1021 tprr_rci, tprg_rcg, &
1022 tprw_vcd_c, tprw_vcd_e, tprr_sml, &
1023 tprr_gml, tprr_rcg, &
1024 tprr_rcs, tprv_rev, tten3, qvten3, &
1025 qrten3, qsten3, qgten3, qiten3, niten3, &
1026 nrten3, ncten3, qcten3, &
1027 pfils, pflls)
1028
1029 implicit none
1030
1031!..Subroutine arguments
1032 INTEGER, INTENT(IN):: ids,ide, jds,jde, kds,kde, &
1033 ims,ime, jms,jme, kms,kme, &
1034 its,ite, jts,jte, kts,kte
1035 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: &
1036 qv, qc, qr, qi, qs, qg, ni, nr
1037 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT):: &
1038 tt, th
1039 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(IN):: &
1040 pii
1041 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT):: &
1042 nc, nwfa, nifa
1043 REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(IN):: nwfa2d, nifa2d
1044 INTEGER, DIMENSION(ims:ime, jms:jme), INTENT(IN):: lsm
1045 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT):: &
1046 re_cloud, re_ice, re_snow
1047 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: pfils, pflls
1048 INTEGER, INTENT(IN) :: rand_perturb_on, kme_stoch, n_var_spp
1049 REAL, DIMENSION(:,:), INTENT(IN), OPTIONAL :: rand_pert
1050 REAL, DIMENSION(:), INTENT(IN), OPTIONAL :: spp_prt_list
1051 REAL, DIMENSION(:), INTENT(IN) :: spp_stddev_cutoff
1052 CHARACTER(len=10), DIMENSION(:), INTENT(IN), OPTIONAL :: spp_var_list
1053 INTEGER, INTENT(IN):: has_reqc, has_reqi, has_reqs
1054#if ( WRF_CHEM == 1 )
1055 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: &
1056 rainprod, evapprod
1057#endif
1058 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN):: &
1059 p, w, dz
1060 REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT):: &
1061 RAINNC, RAINNCV, SR
1062 REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(INOUT):: &
1063 SNOWNC, SNOWNCV, &
1064 ICENC, ICENCV, &
1065 GRAUPELNC, GRAUPELNCV
1066 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: &
1067 refl_10cm
1068 REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT):: &
1069 max_hail_diam_sfc
1070 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT):: &
1071 vt_dbz_wt
1072 LOGICAL, INTENT(IN) :: first_time_step
1073 REAL, INTENT(IN):: dt_in, dt_inner
1074 LOGICAL, INTENT(IN) :: sedi_semi
1075 INTEGER, INTENT(IN) :: decfl
1076 ! To support subcycling: current step and maximum number of steps
1077 INTEGER, INTENT (IN) :: istep, nsteps
1078 LOGICAL, INTENT (IN) :: fullradar_diag
1079 ! Extended diagnostics, array pointers only associated if ext_diag flag is .true.
1080 LOGICAL, INTENT (IN) :: ext_diag
1081 LOGICAL, OPTIONAL, INTENT(IN):: aero_ind_fdb
1082 REAL, DIMENSION(:,:,:), INTENT(INOUT), OPTIONAL :: &
1083 !vts1, txri, txrc, &
1084 prw_vcdc, &
1085 prw_vcde, tpri_inu, tpri_ide_d, &
1086 tpri_ide_s, tprs_ide, &
1087 tprs_sde_d, tprs_sde_s, tprg_gde_d, &
1088 tprg_gde_s, tpri_iha, tpri_wfz, &
1089 tpri_rfz, tprg_rfz, tprs_scw, tprg_scw, &
1090 tprg_rcs, tprs_rcs, &
1091 tprr_rci, tprg_rcg, &
1092 tprw_vcd_c, tprw_vcd_e, tprr_sml, &
1093 tprr_gml, tprr_rcg, &
1094 tprr_rcs, tprv_rev, tten3, qvten3, &
1095 qrten3, qsten3, qgten3, qiten3, niten3, &
1096 nrten3, ncten3, qcten3
1097
1098!..Local variables
1099 REAL, DIMENSION(kts:kte):: &
1100 qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
1101 nr1d, nc1d, nwfa1d, nifa1d, &
1102 t1d, p1d, w1d, dz1d, rho, dBZ, pfil1, pfll1
1103!..Extended diagnostics, single column arrays
1104 REAL, DIMENSION(:), ALLOCATABLE:: &
1105 !vtsk1, txri1, txrc1, &
1106 prw_vcdc1, &
1107 prw_vcde1, tpri_inu1, tpri_ide1_d, &
1108 tpri_ide1_s, tprs_ide1, &
1109 tprs_sde1_d, tprs_sde1_s, tprg_gde1_d, &
1110 tprg_gde1_s, tpri_iha1, tpri_wfz1, &
1111 tpri_rfz1, tprg_rfz1, tprs_scw1, tprg_scw1,&
1112 tprg_rcs1, tprs_rcs1, &
1113 tprr_rci1, tprg_rcg1, &
1114 tprw_vcd1_c, tprw_vcd1_e, tprr_sml1, &
1115 tprr_gml1, tprr_rcg1, &
1116 tprr_rcs1, tprv_rev1, tten1, qvten1, &
1117 qrten1, qsten1, qgten1, qiten1, niten1, &
1118 nrten1, ncten1, qcten1
1119
1120 REAL, DIMENSION(kts:kte):: re_qc1d, re_qi1d, re_qs1d
1121#if ( WRF_CHEM == 1 )
1122 REAL, DIMENSION(kts:kte):: &
1123 rainprod1d, evapprod1d
1124#endif
1125 REAL, DIMENSION(its:ite, jts:jte):: pcp_ra, pcp_sn, pcp_gr, pcp_ic
1126 REAL:: dt, pptrain, pptsnow, pptgraul, pptice
1127 REAL:: qc_max, qr_max, qs_max, qi_max, qg_max, ni_max, nr_max
1128 INTEGER:: lsml
1129 REAL:: rand1, rand2, rand3, rand_pert_max
1130 INTEGER:: i, j, k, m
1131 INTEGER:: imax_qc,imax_qr,imax_qi,imax_qs,imax_qg,imax_ni,imax_nr
1132 INTEGER:: jmax_qc,jmax_qr,jmax_qi,jmax_qs,jmax_qg,jmax_ni,jmax_nr
1133 INTEGER:: kmax_qc,kmax_qr,kmax_qi,kmax_qs,kmax_qg,kmax_ni,kmax_nr
1134 INTEGER:: i_start, j_start, i_end, j_end
1135 LOGICAL, OPTIONAL, INTENT(IN) :: diagflag
1136 INTEGER, OPTIONAL, INTENT(IN) :: do_radar_ref
1137 logical :: melti = .false.
1138 INTEGER :: ndt, it
1139
1140 ! CCPP error handling
1141 character(len=*), optional, intent( out) :: errmsg
1142 integer, optional, intent( out) :: errflg
1143
1144 ! CCPP
1145 if (present(errmsg)) errmsg = ''
1146 if (present(errflg)) errflg = 0
1147
1148 ! No need to test for every subcycling step
1149 test_only_once: if (first_time_step .and. istep==1) then
1150 ! Activate this code when removing the guard above
1151
1152 if ( (present(tt) .and. (present(th) .or. present(pii))) .or. &
1153 (.not.present(tt) .and. .not.(present(th) .and. present(pii))) ) then
1154 if (present(errmsg) .and. present(errflg)) then
1155 write(errmsg, '(a)') 'Logic error in mp_gt_driver: provide either tt or th+pii'
1156 errflg = 1
1157 return
1158 else
1159 write(*,'(a)') 'Logic error in mp_gt_driver: provide either tt or th+pii'
1160 stop
1161 end if
1162 end if
1163
1164 if (is_aerosol_aware .and. (.not.present(nc) .or. &
1165 .not.present(nwfa) .or. &
1166 .not.present(nifa) .or. &
1167 .not.present(nwfa2d) .or. &
1168 .not.present(nifa2d) )) then
1169 if (present(errmsg) .and. present(errflg)) then
1170 write(errmsg, '(*(a))') 'Logic error in mp_gt_driver: provide nc, nwfa, nifa, nwfa2d', &
1171 ' and nifa2d for aerosol-aware version of Thompson microphysics'
1172 errflg = 1
1173 return
1174 else
1175 write(*, '(*(a))') 'Logic error in mp_gt_driver: provide nc, nwfa, nifa, nwfa2d', &
1176 ' and nifa2d for aerosol-aware version of Thompson microphysics'
1177 stop
1178 end if
1179 else if (merra2_aerosol_aware .and. (.not.present(nc) .or. &
1180 .not.present(nwfa) .or. &
1181 .not.present(nifa) )) then
1182 if (present(errmsg) .and. present(errflg)) then
1183 write(errmsg, '(*(a))') 'Logic error in mp_gt_driver: provide nc, nwfa, and nifa', &
1184 ' for merra2 aerosol-aware version of Thompson microphysics'
1185 errflg = 1
1186 return
1187 else
1188 write(*, '(*(a))') 'Logic error in mp_gt_driver: provide nc, nwfa, and nifa', &
1189 ' for merra2 aerosol-aware version of Thompson microphysics'
1190 stop
1191 end if
1192 else if (.not.is_aerosol_aware .and. .not.merra2_aerosol_aware .and. &
1193 (present(nwfa) .or. present(nifa) .or. present(nwfa2d) .or. present(nifa2d))) then
1194 write(*,*) 'WARNING, nc/nwfa/nifa/nwfa2d/nifa2d present but is_aerosol_aware/merra2_aerosol_aware are FALSE'
1195 end if
1196 end if test_only_once
1197
1198 ! These must be alwyas allocated
1199 !allocate (vtsk1(kts:kte))
1200 !allocate (txri1(kts:kte))
1201 !allocate (txrc1(kts:kte))
1202 allocate_extended_diagnostics: if (ext_diag) then
1203 allocate (prw_vcdc1(kts:kte))
1204 allocate (prw_vcde1(kts:kte))
1205 allocate (tpri_inu1(kts:kte))
1206 allocate (tpri_ide1_d(kts:kte))
1207 allocate (tpri_ide1_s(kts:kte))
1208 allocate (tprs_ide1(kts:kte))
1209 allocate (tprs_sde1_d(kts:kte))
1210 allocate (tprs_sde1_s(kts:kte))
1211 allocate (tprg_gde1_d(kts:kte))
1212 allocate (tprg_gde1_s(kts:kte))
1213 allocate (tpri_iha1(kts:kte))
1214 allocate (tpri_wfz1(kts:kte))
1215 allocate (tpri_rfz1(kts:kte))
1216 allocate (tprg_rfz1(kts:kte))
1217 allocate (tprs_scw1(kts:kte))
1218 allocate (tprg_scw1(kts:kte))
1219 allocate (tprg_rcs1(kts:kte))
1220 allocate (tprs_rcs1(kts:kte))
1221 allocate (tprr_rci1(kts:kte))
1222 allocate (tprg_rcg1(kts:kte))
1223 allocate (tprw_vcd1_c(kts:kte))
1224 allocate (tprw_vcd1_e(kts:kte))
1225 allocate (tprr_sml1(kts:kte))
1226 allocate (tprr_gml1(kts:kte))
1227 allocate (tprr_rcg1(kts:kte))
1228 allocate (tprr_rcs1(kts:kte))
1229 allocate (tprv_rev1(kts:kte))
1230 allocate (tten1(kts:kte))
1231 allocate (qvten1(kts:kte))
1232 allocate (qrten1(kts:kte))
1233 allocate (qsten1(kts:kte))
1234 allocate (qgten1(kts:kte))
1235 allocate (qiten1(kts:kte))
1236 allocate (niten1(kts:kte))
1237 allocate (nrten1(kts:kte))
1238 allocate (ncten1(kts:kte))
1239 allocate (qcten1(kts:kte))
1240 end if allocate_extended_diagnostics
1241
1242!+---+
1243 i_start = its
1244 j_start = jts
1245 i_end = ite
1246 j_end = jte
1247
1248!..For idealized testing by developer.
1249! if ( (ide-ids+1).gt.4 .and. (jde-jds+1).lt.4 .and. &
1250! ids.eq.its.and.ide.eq.ite.and.jds.eq.jts.and.jde.eq.jte) then
1251! i_start = its + 2
1252! i_end = ite
1253! j_start = jts
1254! j_end = jte
1255! endif
1256
1257! dt = dt_in
1258 rainnc(:,:) = 0.0
1259 snownc(:,:) = 0.0
1260 icenc(:,:) = 0.0
1261 graupelnc(:,:) = 0.0
1262 pcp_ra(:,:) = 0.0
1263 pcp_sn(:,:) = 0.0
1264 pcp_gr(:,:) = 0.0
1265 pcp_ic(:,:) = 0.0
1266 pfils(:,:,:) = 0.0
1267 pflls(:,:,:) = 0.0
1268 rand_pert_max = 0.0
1269 ndt = max(nint(dt_in/dt_inner),1)
1270 dt = dt_in/ndt
1271 if(dt_in .le. dt_inner) dt= dt_in
1272
1273 !Get the Thompson MP SPP magnitude and standard deviation cutoff,
1274 !then compute rand_pert_max
1275
1276 if (rand_perturb_on .ne. 0) then
1277 do k =1,n_var_spp
1278 select case (spp_var_list(k))
1279 case('mp')
1280 rand_pert_max = spp_prt_list(k)*spp_stddev_cutoff(k)
1281 end select
1282 enddo
1283 endif
1284
1285 do it = 1, ndt
1286
1287 qc_max = 0.
1288 qr_max = 0.
1289 qs_max = 0.
1290 qi_max = 0.
1291 qg_max = 0
1292 ni_max = 0.
1293 nr_max = 0.
1294 imax_qc = 0
1295 imax_qr = 0
1296 imax_qi = 0
1297 imax_qs = 0
1298 imax_qg = 0
1299 imax_ni = 0
1300 imax_nr = 0
1301 jmax_qc = 0
1302 jmax_qr = 0
1303 jmax_qi = 0
1304 jmax_qs = 0
1305 jmax_qg = 0
1306 jmax_ni = 0
1307 jmax_nr = 0
1308 kmax_qc = 0
1309 kmax_qr = 0
1310 kmax_qi = 0
1311 kmax_qs = 0
1312 kmax_qg = 0
1313 kmax_ni = 0
1314 kmax_nr = 0
1315
1316 j_loop: do j = j_start, j_end
1317 i_loop: do i = i_start, i_end
1318
1319!+---+-----------------------------------------------------------------+
1320!..Introduce stochastic parameter perturbations by creating as many scalar rand1, rand2, ...
1321!.. variables as needed to perturb different pieces of microphysics. gthompsn 21Mar2018
1322! Setting spp_mp_opt to 1 gives graupel Y-intercept pertubations (2^0)
1323! 2 gives cloud water distribution gamma shape parameter perturbations (2^1)
1324! 4 gives CCN & IN activation perturbations (2^2)
1325! 3 gives both 1+2
1326! 5 gives both 1+4
1327! 6 gives both 2+4
1328! 7 gives all 1+2+4
1329! For now (22Mar2018), standard deviation should be up to 0.75 and cut-off at 3.0
1330! stddev in order to constrain the various perturbations from being too extreme.
1331!+---+-----------------------------------------------------------------+
1332 rand1 = 0.0
1333 rand2 = 0.0
1334 rand3 = 0.0
1335 if (rand_perturb_on .ne. 0) then
1336 if (mod(rand_perturb_on,2) .ne. 0) rand1 = rand_pert(i,1)
1337 m = rshift(abs(rand_perturb_on),1)
1338 if (mod(m,2) .ne. 0) rand2 = rand_pert(i,1)*2.
1339 m = rshift(abs(rand_perturb_on),2)
1340 if (mod(m,2) .ne. 0) rand3 = 0.25*(rand_pert(i,1)+rand_pert_max)
1341 m = rshift(abs(rand_perturb_on),3)
1342 endif
1343!+---+-----------------------------------------------------------------+
1344
1345 pptrain = 0.
1346 pptsnow = 0.
1347 pptgraul = 0.
1348 pptice = 0.
1349 rainncv(i,j) = 0.
1350 IF ( PRESENT (snowncv) ) THEN
1351 snowncv(i,j) = 0.
1352 ENDIF
1353 IF ( PRESENT (icencv) ) THEN
1354 icencv(i,j) = 0.
1355 ENDIF
1356 IF ( PRESENT (graupelncv) ) THEN
1357 graupelncv(i,j) = 0.
1358 ENDIF
1359 sr(i,j) = 0.
1360
1361 do k = kts, kte
1362 if (present(tt)) then
1363 t1d(k) = tt(i,k,j)
1364 else
1365 t1d(k) = th(i,k,j)*pii(i,k,j)
1366 end if
1367 p1d(k) = p(i,k,j)
1368 w1d(k) = w(i,k,j)
1369 dz1d(k) = dz(i,k,j)
1370 qv1d(k) = qv(i,k,j)
1371 qc1d(k) = qc(i,k,j)
1372 qi1d(k) = qi(i,k,j)
1373 qr1d(k) = qr(i,k,j)
1374 qs1d(k) = qs(i,k,j)
1375 qg1d(k) = qg(i,k,j)
1376 ni1d(k) = ni(i,k,j)
1377 nr1d(k) = nr(i,k,j)
1378 rho(k) = 0.622*p1d(k)/(r*t1d(k)*(qv1d(k)+0.622))
1379
1380 ! These arrays are always allocated and must be initialized
1381 !vtsk1(k) = 0.
1382 !txrc1(k) = 0.
1383 !txri1(k) = 0.
1384 initialize_extended_diagnostics: if (ext_diag) then
1385 prw_vcdc1(k) = 0.
1386 prw_vcde1(k) = 0.
1387 tpri_inu1(k) = 0.
1388 tpri_ide1_d(k) = 0.
1389 tpri_ide1_s(k) = 0.
1390 tprs_ide1(k) = 0.
1391 tprs_sde1_d(k) = 0.
1392 tprs_sde1_s(k) = 0.
1393 tprg_gde1_d(k) = 0.
1394 tprg_gde1_s(k) = 0.
1395 tpri_iha1(k) = 0.
1396 tpri_wfz1(k) = 0.
1397 tpri_rfz1(k) = 0.
1398 tprg_rfz1(k) = 0.
1399 tprs_scw1(k) = 0.
1400 tprg_scw1(k) = 0.
1401 tprg_rcs1(k) = 0.
1402 tprs_rcs1(k) = 0.
1403 tprr_rci1(k) = 0.
1404 tprg_rcg1(k) = 0.
1405 tprw_vcd1_c(k) = 0.
1406 tprw_vcd1_e(k) = 0.
1407 tprr_sml1(k) = 0.
1408 tprr_gml1(k) = 0.
1409 tprr_rcg1(k) = 0.
1410 tprr_rcs1(k) = 0.
1411 tprv_rev1(k) = 0.
1412 tten1(k) = 0.
1413 qvten1(k) = 0.
1414 qrten1(k) = 0.
1415 qsten1(k) = 0.
1416 qgten1(k) = 0.
1417 qiten1(k) = 0.
1418 niten1(k) = 0.
1419 nrten1(k) = 0.
1420 ncten1(k) = 0.
1421 qcten1(k) = 0.
1422 endif initialize_extended_diagnostics
1423 enddo
1424 lsml = lsm(i,j)
1425 if (is_aerosol_aware .or. merra2_aerosol_aware) then
1426 do k = kts, kte
1427 nc1d(k) = nc(i,k,j)
1428 nwfa1d(k) = nwfa(i,k,j)
1429 nifa1d(k) = nifa(i,k,j)
1430 enddo
1431 else
1432 do k = kts, kte
1433 if(lsml == 1) then
1434 nc1d(k) = nt_c_l/rho(k)
1435 else
1436 nc1d(k) = nt_c_o/rho(k)
1437 endif
1438 nwfa1d(k) = 11.1e6
1439 nifa1d(k) = nain1*0.01
1440 enddo
1441 endif
1442
1444 call mp_thompson(qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
1445 nr1d, nc1d, nwfa1d, nifa1d, t1d, p1d, w1d, dz1d, &
1446 lsml, pptrain, pptsnow, pptgraul, pptice, &
1447#if ( WRF_CHEM == 1 )
1448 rainprod1d, evapprod1d, &
1449#endif
1450 rand1, rand2, rand3, &
1451 kts, kte, dt, i, j, ext_diag, &
1452 sedi_semi, decfl, &
1453 !vtsk1, txri1, txrc1, &
1454 prw_vcdc1, prw_vcde1, &
1455 tpri_inu1, tpri_ide1_d, tpri_ide1_s, tprs_ide1, &
1456 tprs_sde1_d, tprs_sde1_s, &
1457 tprg_gde1_d, tprg_gde1_s, tpri_iha1, tpri_wfz1, &
1458 tpri_rfz1, tprg_rfz1, tprs_scw1, tprg_scw1, &
1459 tprg_rcs1, tprs_rcs1, tprr_rci1, &
1460 tprg_rcg1, tprw_vcd1_c, &
1461 tprw_vcd1_e, tprr_sml1, tprr_gml1, tprr_rcg1, &
1462 tprr_rcs1, tprv_rev1, &
1463 tten1, qvten1, qrten1, qsten1, &
1464 qgten1, qiten1, niten1, nrten1, ncten1, qcten1, &
1465 pfil1, pfll1)
1466
1467 pcp_ra(i,j) = pcp_ra(i,j) + pptrain
1468 pcp_sn(i,j) = pcp_sn(i,j) + pptsnow
1469 pcp_gr(i,j) = pcp_gr(i,j) + pptgraul
1470 pcp_ic(i,j) = pcp_ic(i,j) + pptice
1471 rainncv(i,j) = pptrain + pptsnow + pptgraul + pptice
1472 rainnc(i,j) = rainnc(i,j) + pptrain + pptsnow + pptgraul + pptice
1473 IF ( PRESENT(snowncv) .AND. PRESENT(snownc) ) THEN
1474 ! Add ice to snow if separate ice not present
1475 IF ( .NOT.PRESENT(icencv) .OR. .NOT.PRESENT(icenc) ) THEN
1476 snowncv(i,j) = pptsnow + pptice
1477 snownc(i,j) = snownc(i,j) + pptsnow + pptice
1478 ELSE
1479 snowncv(i,j) = pptsnow
1480 snownc(i,j) = snownc(i,j) + pptsnow
1481 ENDIF
1482 ENDIF
1483 ! Use separate ice if present (as in FV3)
1484 IF ( PRESENT(icencv) .AND. PRESENT(icenc) ) THEN
1485 icencv(i,j) = pptice
1486 icenc(i,j) = icenc(i,j) + pptice
1487 ENDIF
1488 IF ( PRESENT(graupelncv) .AND. PRESENT(graupelnc) ) THEN
1489 graupelncv(i,j) = pptgraul
1490 graupelnc(i,j) = graupelnc(i,j) + pptgraul
1491 ENDIF
1492 sr(i,j) = (pptsnow + pptgraul + pptice)/(rainncv(i,j)+1.e-12)
1493
1494
1495
1496!..Reset lowest model level to initial state aerosols (fake sfc source).
1497!.. Changed 13 May 2013 to fake emissions in which nwfa2d is aerosol
1498!.. number tendency (number per kg per second).
1499 if (is_aerosol_aware) then
1500 if ( PRESENT (aero_ind_fdb) ) then
1501 if ( .not. aero_ind_fdb) then
1502 nwfa1d(kts) = nwfa1d(kts) + nwfa2d(i,j)*dt
1503 nifa1d(kts) = nifa1d(kts) + nifa2d(i,j)*dt
1504 endif
1505 else
1506 nwfa1d(kts) = nwfa1d(kts) + nwfa2d(i,j)*dt
1507 nifa1d(kts) = nifa1d(kts) + nifa2d(i,j)*dt
1508 end if
1509
1510 do k = kts, kte
1511 nc(i,k,j) = nc1d(k)
1512 nwfa(i,k,j) = nwfa1d(k)
1513 nifa(i,k,j) = nifa1d(k)
1514 enddo
1515 endif
1516
1517 if (merra2_aerosol_aware) then
1518 do k = kts, kte
1519 nc(i,k,j) = nc1d(k)
1520 nwfa(i,k,j) = nwfa1d(k)
1521 nifa(i,k,j) = nifa1d(k)
1522 enddo
1523 endif
1524
1525 do k = kts, kte
1526 qv(i,k,j) = qv1d(k)
1527 qc(i,k,j) = qc1d(k)
1528 qi(i,k,j) = qi1d(k)
1529 qr(i,k,j) = qr1d(k)
1530 qs(i,k,j) = qs1d(k)
1531 qg(i,k,j) = qg1d(k)
1532 ni(i,k,j) = ni1d(k)
1533 nr(i,k,j) = nr1d(k)
1534 pfils(i,k,j) = pfils(i,k,j) + pfil1(k)
1535 pflls(i,k,j) = pflls(i,k,j) + pfll1(k)
1536 if (present(tt)) then
1537 tt(i,k,j) = t1d(k)
1538 else
1539 th(i,k,j) = t1d(k)/pii(i,k,j)
1540 end if
1541#if ( WRF_CHEM == 1 )
1542 rainprod(i,k,j) = rainprod1d(k)
1543 evapprod(i,k,j) = evapprod1d(k)
1544#endif
1545 if (qc1d(k) .gt. qc_max) then
1546 imax_qc = i
1547 jmax_qc = j
1548 kmax_qc = k
1549 qc_max = qc1d(k)
1550 elseif (qc1d(k) .lt. 0.0) then
1551 write(*,'(a,e16.7,a,3i8)') 'WARNING, negative qc ', qc1d(k), &
1552 ' at i,j,k=', i,j,k
1553 endif
1554 if (qr1d(k) .gt. qr_max) then
1555 imax_qr = i
1556 jmax_qr = j
1557 kmax_qr = k
1558 qr_max = qr1d(k)
1559 elseif (qr1d(k) .lt. 0.0) then
1560 write(*,'(a,e16.7,a,3i8)') 'WARNING, negative qr ', qr1d(k), &
1561 ' at i,j,k=', i,j,k
1562 endif
1563 if (nr1d(k) .gt. nr_max) then
1564 imax_nr = i
1565 jmax_nr = j
1566 kmax_nr = k
1567 nr_max = nr1d(k)
1568 elseif (nr1d(k) .lt. 0.0) then
1569 write(*,'(a,e16.7,a,3i8)') 'WARNING, negative nr ', nr1d(k), &
1570 ' at i,j,k=', i,j,k
1571 endif
1572 if (qs1d(k) .gt. qs_max) then
1573 imax_qs = i
1574 jmax_qs = j
1575 kmax_qs = k
1576 qs_max = qs1d(k)
1577 elseif (qs1d(k) .lt. 0.0) then
1578 write(*,'(a,e16.7,a,3i8)') 'WARNING, negative qs ', qs1d(k), &
1579 ' at i,j,k=', i,j,k
1580 endif
1581 if (qi1d(k) .gt. qi_max) then
1582 imax_qi = i
1583 jmax_qi = j
1584 kmax_qi = k
1585 qi_max = qi1d(k)
1586 elseif (qi1d(k) .lt. 0.0) then
1587 write(*,'(a,e16.7,a,3i8)') 'WARNING, negative qi ', qi1d(k), &
1588 ' at i,j,k=', i,j,k
1589 endif
1590 if (qg1d(k) .gt. qg_max) then
1591 imax_qg = i
1592 jmax_qg = j
1593 kmax_qg = k
1594 qg_max = qg1d(k)
1595 elseif (qg1d(k) .lt. 0.0) then
1596 write(*,'(a,e16.7,a,3i8)') 'WARNING, negative qg ', qg1d(k), &
1597 ' at i,j,k=', i,j,k
1598 endif
1599 if (ni1d(k) .gt. ni_max) then
1600 imax_ni = i
1601 jmax_ni = j
1602 kmax_ni = k
1603 ni_max = ni1d(k)
1604 elseif (ni1d(k) .lt. 0.0) then
1605 write(*,'(a,e16.7,a,3i8)') 'WARNING, negative ni ', ni1d(k), &
1606 ' at i,j,k=', i,j,k
1607 endif
1608 if (qv1d(k) .lt. 0.0) then
1609 write(*,'(a,e16.7,a,3i8)') 'WARNING, negative qv ', qv1d(k), &
1610 ' at i,j,k=', i,j,k
1611 if (k.lt.kte-2 .and. k.gt.kts+1) then
1612 write(*,*) ' below and above are: ', qv(i,k-1,j), qv(i,k+1,j)
1613 qv(i,k,j) = max(1.e-7, 0.5*(qv(i,k-1,j) + qv(i,k+1,j)))
1614 else
1615 qv(i,k,j) = 1.e-7
1616 endif
1617 endif
1618 enddo
1619
1620 assign_extended_diagnostics: if (ext_diag) then
1621 do k=kts,kte
1622 !vts1(i,k,j) = vtsk1(k)
1623 !txri(i,k,j) = txri(i,k,j) + txri1(k)
1624 !txrc(i,k,j) = txrc(i,k,j) + txrc1(k)
1625 prw_vcdc(i,k,j) = prw_vcdc(i,k,j) + prw_vcdc1(k)
1626 prw_vcde(i,k,j) = prw_vcde(i,k,j) + prw_vcde1(k)
1627 tpri_inu(i,k,j) = tpri_inu(i,k,j) + tpri_inu1(k)
1628 tpri_ide_d(i,k,j) = tpri_ide_d(i,k,j) + tpri_ide1_d(k)
1629 tpri_ide_s(i,k,j) = tpri_ide_s(i,k,j) + tpri_ide1_s(k)
1630 tprs_ide(i,k,j) = tprs_ide(i,k,j) + tprs_ide1(k)
1631 tprs_sde_s(i,k,j) = tprs_sde_s(i,k,j) + tprs_sde1_s(k)
1632 tprs_sde_d(i,k,j) = tprs_sde_d(i,k,j) + tprs_sde1_d(k)
1633 tprg_gde_d(i,k,j) = tprg_gde_d(i,k,j) + tprg_gde1_d(k)
1634 tprg_gde_s(i,k,j) = tprg_gde_s(i,k,j) + tprg_gde1_s(k)
1635 tpri_iha(i,k,j) = tpri_iha(i,k,j) + tpri_iha1(k)
1636 tpri_wfz(i,k,j) = tpri_wfz(i,k,j) + tpri_wfz1(k)
1637 tpri_rfz(i,k,j) = tpri_rfz(i,k,j) + tpri_rfz1(k)
1638 tprg_rfz(i,k,j) = tprg_rfz(i,k,j) + tprg_rfz1(k)
1639 tprs_scw(i,k,j) = tprs_scw(i,k,j) + tprs_scw1(k)
1640 tprg_scw(i,k,j) = tprg_scw(i,k,j) + tprg_scw1(k)
1641 tprg_rcs(i,k,j) = tprg_rcs(i,k,j) + tprg_rcs1(k)
1642 tprs_rcs(i,k,j) = tprs_rcs(i,k,j) + tprs_rcs1(k)
1643 tprr_rci(i,k,j) = tprr_rci(i,k,j) + tprr_rci1(k)
1644 tprg_rcg(i,k,j) = tprg_rcg(i,k,j) + tprg_rcg1(k)
1645 tprw_vcd_c(i,k,j) = tprw_vcd_c(i,k,j) + tprw_vcd1_c(k)
1646 tprw_vcd_e(i,k,j) = tprw_vcd_e(i,k,j) + tprw_vcd1_e(k)
1647 tprr_sml(i,k,j) = tprr_sml(i,k,j) + tprr_sml1(k)
1648 tprr_gml(i,k,j) = tprr_gml(i,k,j) + tprr_gml1(k)
1649 tprr_rcg(i,k,j) = tprr_rcg(i,k,j) + tprr_rcg1(k)
1650 tprr_rcs(i,k,j) = tprr_rcs(i,k,j) + tprr_rcs1(k)
1651 tprv_rev(i,k,j) = tprv_rev(i,k,j) + tprv_rev1(k)
1652 tten3(i,k,j) = tten3(i,k,j) + tten1(k)
1653 qvten3(i,k,j) = qvten3(i,k,j) + qvten1(k)
1654 qrten3(i,k,j) = qrten3(i,k,j) + qrten1(k)
1655 qsten3(i,k,j) = qsten3(i,k,j) + qsten1(k)
1656 qgten3(i,k,j) = qgten3(i,k,j) + qgten1(k)
1657 qiten3(i,k,j) = qiten3(i,k,j) + qiten1(k)
1658 niten3(i,k,j) = niten3(i,k,j) + niten1(k)
1659 nrten3(i,k,j) = nrten3(i,k,j) + nrten1(k)
1660 ncten3(i,k,j) = ncten3(i,k,j) + ncten1(k)
1661 qcten3(i,k,j) = qcten3(i,k,j) + qcten1(k)
1662
1663 enddo
1664 endif assign_extended_diagnostics
1665
1666 if (ndt>1 .and. it==ndt) then
1667
1668 sr(i,j) = (pcp_sn(i,j) + pcp_gr(i,j) + pcp_ic(i,j))/(rainnc(i,j)+1.e-12)
1669 rainncv(i,j) = rainnc(i,j)
1670 IF ( PRESENT (snowncv) ) THEN
1671 snowncv(i,j) = snownc(i,j)
1672 ENDIF
1673 IF ( PRESENT (icencv) ) THEN
1674 icencv(i,j) = icenc(i,j)
1675 ENDIF
1676 IF ( PRESENT (graupelncv) ) THEN
1677 graupelncv(i,j) = graupelnc(i,j)
1678 ENDIF
1679 endif
1680
1681 ! Diagnostic calculations only for last step
1682 ! if Thompson MP is called multiple times
1683 last_step_only: IF ((ndt>1 .and. it==ndt) .or. &
1684 (nsteps>1 .and. istep==nsteps) .or. &
1685 (nsteps==1 .and. ndt==1)) THEN
1686
1687 max_hail_diam_sfc(i,j) = hail_mass_99th_percentile(kts, kte, qg1d, t1d, p1d, qv1d)
1688
1690
1691 diagflag_present: IF ( PRESENT (diagflag) ) THEN
1692 if (diagflag .and. do_radar_ref == 1) then
1693!
1694 ! Only set melti to true at the output times
1695 if (fullradar_diag) then
1696 melti=.true.
1697 else
1698 melti=.false.
1699 endif
1700!
1701 if (present(vt_dbz_wt)) then
1702 call calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, &
1703 t1d, p1d, dbz, rand1, kts, kte, i, j, &
1704 melti, vt_dbz_wt(i,:,j), &
1705 first_time_step)
1706 else
1707 call calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, &
1708 t1d, p1d, dbz, rand1, kts, kte, i, j, &
1709 melti)
1710 end if
1711 do k = kts, kte
1712 refl_10cm(i,k,j) = max(-35., dbz(k))
1713 enddo
1714 endif
1715 ENDIF diagflag_present
1716
1717 IF (has_reqc.ne.0 .and. has_reqi.ne.0 .and. has_reqs.ne.0) THEN
1718 do k = kts, kte
1719 re_qc1d(k) = re_qc_min
1720 re_qi1d(k) = re_qi_min
1721 re_qs1d(k) = re_qs_min
1722 enddo
1724 call calc_effectrad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, &
1725 re_qc1d, re_qi1d, re_qs1d, lsml, kts, kte)
1726 do k = kts, kte
1727 re_cloud(i,k,j) = max(re_qc_min, min(re_qc1d(k), re_qc_max))
1728 re_ice(i,k,j) = max(re_qi_min, min(re_qi1d(k), re_qi_max))
1729 re_snow(i,k,j) = max(re_qs_min, min(re_qs1d(k), re_qs_max))
1730 enddo
1731 ENDIF
1732 ENDIF last_step_only
1733
1734 enddo i_loop
1735 enddo j_loop
1736
1737! DEBUG - GT
1738! write(*,'(a,7(a,e13.6,1x,a,i3,a,i3,a,i3,a,1x))') 'MP-GT:', &
1739! 'qc: ', qc_max, '(', imax_qc, ',', jmax_qc, ',', kmax_qc, ')', &
1740! 'qr: ', qr_max, '(', imax_qr, ',', jmax_qr, ',', kmax_qr, ')', &
1741! 'qi: ', qi_max, '(', imax_qi, ',', jmax_qi, ',', kmax_qi, ')', &
1742! 'qs: ', qs_max, '(', imax_qs, ',', jmax_qs, ',', kmax_qs, ')', &
1743! 'qg: ', qg_max, '(', imax_qg, ',', jmax_qg, ',', kmax_qg, ')', &
1744! 'ni: ', ni_max, '(', imax_ni, ',', jmax_ni, ',', kmax_ni, ')', &
1745! 'nr: ', nr_max, '(', imax_nr, ',', jmax_nr, ',', kmax_nr, ')'
1746! END DEBUG - GT
1747 enddo ! end of nt loop
1748
1749 do j = j_start, j_end
1750 do k = kts, kte
1751 do i = i_start, i_end
1752 pfils(i,k,j) = pfils(i,k,j)/dt_in
1753 pflls(i,k,j) = pflls(i,k,j)/dt_in
1754 enddo
1755 enddo
1756 enddo
1757
1758 ! These are always allocated
1759 !deallocate (vtsk1)
1760 !deallocate (txri1)
1761 !deallocate (txrc1)
1762 deallocate_extended_diagnostics: if (ext_diag) then
1763 deallocate (prw_vcdc1)
1764 deallocate (prw_vcde1)
1765 deallocate (tpri_inu1)
1766 deallocate (tpri_ide1_d)
1767 deallocate (tpri_ide1_s)
1768 deallocate (tprs_ide1)
1769 deallocate (tprs_sde1_d)
1770 deallocate (tprs_sde1_s)
1771 deallocate (tprg_gde1_d)
1772 deallocate (tprg_gde1_s)
1773 deallocate (tpri_iha1)
1774 deallocate (tpri_wfz1)
1775 deallocate (tpri_rfz1)
1776 deallocate (tprg_rfz1)
1777 deallocate (tprs_scw1)
1778 deallocate (tprg_scw1)
1779 deallocate (tprg_rcs1)
1780 deallocate (tprs_rcs1)
1781 deallocate (tprr_rci1)
1782 deallocate (tprg_rcg1)
1783 deallocate (tprw_vcd1_c)
1784 deallocate (tprw_vcd1_e)
1785 deallocate (tprr_sml1)
1786 deallocate (tprr_gml1)
1787 deallocate (tprr_rcg1)
1788 deallocate (tprr_rcs1)
1789 deallocate (tprv_rev1)
1790 deallocate (tten1)
1791 deallocate (qvten1)
1792 deallocate (qrten1)
1793 deallocate (qsten1)
1794 deallocate (qgten1)
1795 deallocate (qiten1)
1796 deallocate (niten1)
1797 deallocate (nrten1)
1798 deallocate (ncten1)
1799 deallocate (qcten1)
1800 end if deallocate_extended_diagnostics
1801
1802 END SUBROUTINE mp_gt_driver
1804
1806 SUBROUTINE thompson_finalize()
1807
1808 IMPLICIT NONE
1809
1810 if (ALLOCATED(tcg_racg)) DEALLOCATE(tcg_racg)
1811 if (ALLOCATED(tmr_racg)) DEALLOCATE(tmr_racg)
1812 if (ALLOCATED(tcr_gacr)) DEALLOCATE(tcr_gacr)
1813 if (ALLOCATED(tmg_gacr)) DEALLOCATE(tmg_gacr)
1814 if (ALLOCATED(tnr_racg)) DEALLOCATE(tnr_racg)
1815 if (ALLOCATED(tnr_gacr)) DEALLOCATE(tnr_gacr)
1816
1817 if (ALLOCATED(tcs_racs1)) DEALLOCATE(tcs_racs1)
1818 if (ALLOCATED(tmr_racs1)) DEALLOCATE(tmr_racs1)
1819 if (ALLOCATED(tcs_racs2)) DEALLOCATE(tcs_racs2)
1820 if (ALLOCATED(tmr_racs2)) DEALLOCATE(tmr_racs2)
1821 if (ALLOCATED(tcr_sacr1)) DEALLOCATE(tcr_sacr1)
1822 if (ALLOCATED(tms_sacr1)) DEALLOCATE(tms_sacr1)
1823 if (ALLOCATED(tcr_sacr2)) DEALLOCATE(tcr_sacr2)
1824 if (ALLOCATED(tms_sacr2)) DEALLOCATE(tms_sacr2)
1825 if (ALLOCATED(tnr_racs1)) DEALLOCATE(tnr_racs1)
1826 if (ALLOCATED(tnr_racs2)) DEALLOCATE(tnr_racs2)
1827 if (ALLOCATED(tnr_sacr1)) DEALLOCATE(tnr_sacr1)
1828 if (ALLOCATED(tnr_sacr2)) DEALLOCATE(tnr_sacr2)
1829
1830 if (ALLOCATED(tpi_qcfz)) DEALLOCATE(tpi_qcfz)
1831 if (ALLOCATED(tni_qcfz)) DEALLOCATE(tni_qcfz)
1832
1833 if (ALLOCATED(tpi_qrfz)) DEALLOCATE(tpi_qrfz)
1834 if (ALLOCATED(tpg_qrfz)) DEALLOCATE(tpg_qrfz)
1835 if (ALLOCATED(tni_qrfz)) DEALLOCATE(tni_qrfz)
1836 if (ALLOCATED(tnr_qrfz)) DEALLOCATE(tnr_qrfz)
1837
1838 if (ALLOCATED(tps_iaus)) DEALLOCATE(tps_iaus)
1839 if (ALLOCATED(tni_iaus)) DEALLOCATE(tni_iaus)
1840 if (ALLOCATED(tpi_ide)) DEALLOCATE(tpi_ide)
1841
1842 if (ALLOCATED(t_efrw)) DEALLOCATE(t_efrw)
1843 if (ALLOCATED(t_efsw)) DEALLOCATE(t_efsw)
1844
1845 if (ALLOCATED(tnr_rev)) DEALLOCATE(tnr_rev)
1846 if (ALLOCATED(tpc_wev)) DEALLOCATE(tpc_wev)
1847 if (ALLOCATED(tnc_wev)) DEALLOCATE(tnc_wev)
1848
1849 if (ALLOCATED(tnccn_act)) DEALLOCATE(tnccn_act)
1850
1851 END SUBROUTINE thompson_finalize
1852
1853!+---+-----------------------------------------------------------------+
1854!ctrlL
1855!+---+-----------------------------------------------------------------+
1856!+---+-----------------------------------------------------------------+
1857
1866 subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
1867 nr1d, nc1d, nwfa1d, nifa1d, t1d, p1d, w1d, dzq, &
1868 lsml, pptrain, pptsnow, pptgraul, pptice, &
1869#if ( WRF_CHEM == 1 )
1870 rainprod, evapprod, &
1871#endif
1872 rand1, rand2, rand3, &
1873 kts, kte, dt, ii, jj, &
1874 ! Extended diagnostics, most arrays only
1875 ! allocated if ext_diag flag is .true.
1876 ext_diag, &
1877 sedi_semi, decfl, &
1878 !vtsk1, txri1, txrc1, &
1879 prw_vcdc1, prw_vcde1, &
1880 tpri_inu1, tpri_ide1_d, tpri_ide1_s, tprs_ide1, &
1881 tprs_sde1_d, tprs_sde1_s, &
1882 tprg_gde1_d, tprg_gde1_s, tpri_iha1, tpri_wfz1, &
1883 tpri_rfz1, tprg_rfz1, tprs_scw1, tprg_scw1, &
1884 tprg_rcs1, tprs_rcs1, tprr_rci1, &
1885 tprg_rcg1, tprw_vcd1_c, &
1886 tprw_vcd1_e, tprr_sml1, tprr_gml1, tprr_rcg1, &
1887 tprr_rcs1, tprv_rev1, &
1888 tten1, qvten1, qrten1, qsten1, &
1889 qgten1, qiten1, niten1, nrten1, ncten1, qcten1, &
1890 pfil1, pfll1)
1891
1892#ifdef MPI
1893 use mpi_f08
1894#endif
1895 implicit none
1896
1897!..Sub arguments
1898 INTEGER, INTENT(IN):: kts, kte, ii, jj
1899 REAL, DIMENSION(kts:kte), INTENT(INOUT):: &
1900 qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
1901 nr1d, nc1d, nwfa1d, nifa1d, t1d
1902 REAL, DIMENSION(kts:kte), INTENT(OUT):: pfil1, pfll1
1903 REAL, DIMENSION(kts:kte), INTENT(IN):: p1d, w1d, dzq
1904 REAL, INTENT(INOUT):: pptrain, pptsnow, pptgraul, pptice
1905 REAL, INTENT(IN):: dt
1906 INTEGER, INTENT(IN):: lsml
1907 REAL, INTENT(IN):: rand1, rand2, rand3
1908 ! Extended diagnostics, most arrays only allocated if ext_diag is true
1909 LOGICAL, INTENT(IN) :: ext_diag
1910 LOGICAL, INTENT(IN) :: sedi_semi
1911 INTEGER, INTENT(IN) :: decfl
1912 REAL, DIMENSION(:), INTENT(OUT), OPTIONAL :: &
1913 !vtsk1, txri1, txrc1, &
1914 prw_vcdc1, &
1915 prw_vcde1, tpri_inu1, tpri_ide1_d, &
1916 tpri_ide1_s, tprs_ide1, &
1917 tprs_sde1_d, tprs_sde1_s, tprg_gde1_d, &
1918 tprg_gde1_s, tpri_iha1, tpri_wfz1, &
1919 tpri_rfz1, tprg_rfz1, tprs_scw1, tprg_scw1,&
1920 tprg_rcs1, tprs_rcs1, &
1921 tprr_rci1, tprg_rcg1, &
1922 tprw_vcd1_c, tprw_vcd1_e, tprr_sml1, &
1923 tprr_gml1, tprr_rcg1, &
1924 tprr_rcs1, tprv_rev1, tten1, qvten1, &
1925 qrten1, qsten1, qgten1, qiten1, niten1, &
1926 nrten1, ncten1, qcten1
1927
1928#if ( WRF_CHEM == 1 )
1929 REAL, DIMENSION(kts:kte), INTENT(INOUT):: &
1930 rainprod, evapprod
1931#endif
1932
1933!..Local variables
1934 REAL, DIMENSION(kts:kte):: tten, qvten, qcten, qiten, &
1935 qrten, qsten, qgten, niten, nrten, ncten, nwfaten, nifaten
1936
1937 DOUBLE PRECISION, DIMENSION(kts:kte):: prw_vcd
1938
1939 DOUBLE PRECISION, DIMENSION(kts:kte):: pnc_wcd, pnc_wau, pnc_rcw, &
1940 pnc_scw, pnc_gcw
1941
1942 DOUBLE PRECISION, DIMENSION(kts:kte):: pna_rca, pna_sca, pna_gca, &
1943 pnd_rcd, pnd_scd, pnd_gcd
1944
1945 DOUBLE PRECISION, DIMENSION(kts:kte):: prr_wau, prr_rcw, prr_rcs, &
1946 prr_rcg, prr_sml, prr_gml, &
1947 prr_rci, prv_rev, &
1948 pnr_wau, pnr_rcs, pnr_rcg, &
1949 pnr_rci, pnr_sml, pnr_gml, &
1950 pnr_rev, pnr_rcr, pnr_rfz
1951
1952 DOUBLE PRECISION, DIMENSION(kts:kte):: pri_inu, pni_inu, pri_ihm, &
1953 pni_ihm, pri_wfz, pni_wfz, &
1954 pri_rfz, pni_rfz, pri_ide, &
1955 pni_ide, pri_rci, pni_rci, &
1956 pni_sci, pni_iau, pri_iha, pni_iha
1957
1958 DOUBLE PRECISION, DIMENSION(kts:kte):: prs_iau, prs_sci, prs_rcs, &
1959 prs_scw, prs_sde, prs_ihm, &
1960 prs_ide
1961
1962 DOUBLE PRECISION, DIMENSION(kts:kte):: prg_scw, prg_rfz, prg_gde, &
1963 prg_gcw, prg_rci, prg_rcs, &
1964 prg_rcg, prg_ihm
1965
1966 DOUBLE PRECISION, PARAMETER:: zeroD0 = 0.0d0
1967 REAL :: dtcfl,rainsfc,graulsfc
1968 INTEGER :: niter
1969
1970 REAL, DIMENSION(kts:kte):: temp, pres, qv, pfll, pfil, pdummy
1971 REAL, DIMENSION(kts:kte):: rc, ri, rr, rs, rg, ni, nr, nc, nwfa, nifa
1972 REAL, DIMENSION(kts:kte):: rr_tmp, nr_tmp, rg_tmp
1973 REAL, DIMENSION(kts:kte):: rho, rhof, rhof2
1974 REAL, DIMENSION(kts:kte):: qvs, qvsi, delQvs
1975 REAL, DIMENSION(kts:kte):: satw, sati, ssatw, ssati
1976 REAL, DIMENSION(kts:kte):: diffu, visco, vsc2, &
1977 tcond, lvap, ocp, lvt2
1978
1979 DOUBLE PRECISION, DIMENSION(kts:kte):: ilamr, ilamg, N0_r, N0_g
1980 REAL, DIMENSION(kts:kte):: mvd_r, mvd_c
1981 REAL, DIMENSION(kts:kte):: smob, smo2, smo1, smo0, &
1982 smoc, smod, smoe, smof
1983
1984 REAL, DIMENSION(kts:kte):: sed_r, sed_s, sed_g, sed_i, sed_n,sed_c
1985
1986 REAL:: rgvm, delta_tp, orho, lfus2, orhodt
1987 REAL, DIMENSION(5):: onstep
1988 DOUBLE PRECISION:: N0_exp, N0_min, lam_exp, lamc, lamr, lamg
1989 DOUBLE PRECISION:: lami, ilami, ilamc
1990 REAL:: xDc, Dc_b, Dc_g, xDi, xDr, xDs, xDg, Ds_m, Dg_m
1991 DOUBLE PRECISION:: Dr_star, Dc_star
1992 REAL:: zeta1, zeta, taud, tau
1993 REAL:: stoke_r, stoke_s, stoke_g, stoke_i
1994 REAL:: vti, vtr, vts, vtg, vtc
1995 REAL, DIMENSION(kts:kte+1):: vtik, vtnik, vtrk, vtnrk, vtsk, vtgk, &
1996 vtck, vtnck
1997 REAL, DIMENSION(kts:kte):: vts_boost
1998 REAL:: Mrat, ils1, ils2, t1_vts, t2_vts, t3_vts, t4_vts, C_snow
1999 REAL:: a_, b_, loga_, A1, A2, tf
2000 REAL:: tempc, tc0, r_mvd1, r_mvd2, xkrat
2001 REAL:: xnc, xri, xni, xmi, oxmi, xrc, xrr, xnr
2002 REAL:: xsat, rate_max, sump, ratio
2003 REAL:: clap, fcd, dfcd
2004 REAL:: otemp, rvs, rvs_p, rvs_pp, gamsc, alphsc, t1_evap, t1_subl
2005 REAL:: r_frac, g_frac
2006 REAL:: Ef_rw, Ef_sw, Ef_gw, Ef_rr
2007 REAL:: Ef_ra, Ef_sa, Ef_ga
2008 REAL:: dtsave, odts, odt, odzq, hgt_agl, SR
2009 REAL:: xslw1, ygra1, zans1, eva_factor
2010 REAL:: av_i
2011 INTEGER:: i, k, k2, n, nn, nstep, k_0, kbot, IT, iexfrq
2012 INTEGER, DIMENSION(5):: ksed1
2013 INTEGER:: nir, nis, nig, nii, nic, niin
2014 INTEGER:: idx_tc, idx_t, idx_s, idx_g1, idx_g, idx_r1, idx_r, &
2015 idx_i1, idx_i, idx_c, idx, idx_d, idx_n, idx_in
2016
2017 LOGICAL:: no_micro
2018 LOGICAL, DIMENSION(kts:kte):: L_qc, L_qi, L_qr, L_qs, L_qg
2019 LOGICAL:: debug_flag
2020 INTEGER:: nu_c
2021
2022!+---+
2023
2024 debug_flag = .false.
2025! if (ii.eq.901 .and. jj.eq.379) debug_flag = .true.
2026 if(debug_flag) then
2027 write(*, *) 'DEBUG INFO, mp_thompson at (i,j) ', ii, ', ', jj
2028 endif
2029
2030 no_micro = .true.
2031 dtsave = dt
2032 odt = 1./dt
2033 odts = 1./dtsave
2034 iexfrq = 1
2035! Transition value of coefficient matching at crossover from cloud ice to snow
2036 av_i = av_s * d0s ** (bv_s - bv_i)
2037
2038!+---+-----------------------------------------------------------------+
2051!+---+-----------------------------------------------------------------+
2052
2053 do k = kts, kte
2054 tten(k) = 0.
2055 qvten(k) = 0.
2056 qcten(k) = 0.
2057 qiten(k) = 0.
2058 qrten(k) = 0.
2059 qsten(k) = 0.
2060 qgten(k) = 0.
2061 niten(k) = 0.
2062 nrten(k) = 0.
2063 ncten(k) = 0.
2064 nwfaten(k) = 0.
2065 nifaten(k) = 0.
2066
2067 prw_vcd(k) = 0.
2068
2069 pnc_wcd(k) = 0.
2070 pnc_wau(k) = 0.
2071 pnc_rcw(k) = 0.
2072 pnc_scw(k) = 0.
2073 pnc_gcw(k) = 0.
2074
2075 prv_rev(k) = 0.
2076 prr_wau(k) = 0.
2077 prr_rcw(k) = 0.
2078 prr_rcs(k) = 0.
2079 prr_rcg(k) = 0.
2080 prr_sml(k) = 0.
2081 prr_gml(k) = 0.
2082 prr_rci(k) = 0.
2083 pnr_wau(k) = 0.
2084 pnr_rcs(k) = 0.
2085 pnr_rcg(k) = 0.
2086 pnr_rci(k) = 0.
2087 pnr_sml(k) = 0.
2088 pnr_gml(k) = 0.
2089 pnr_rev(k) = 0.
2090 pnr_rcr(k) = 0.
2091 pnr_rfz(k) = 0.
2092
2093 pri_inu(k) = 0.
2094 pni_inu(k) = 0.
2095 pri_ihm(k) = 0.
2096 pni_ihm(k) = 0.
2097 pri_wfz(k) = 0.
2098 pni_wfz(k) = 0.
2099 pri_rfz(k) = 0.
2100 pni_rfz(k) = 0.
2101 pri_ide(k) = 0.
2102 pni_ide(k) = 0.
2103 pri_rci(k) = 0.
2104 pni_rci(k) = 0.
2105 pni_sci(k) = 0.
2106 pni_iau(k) = 0.
2107 pri_iha(k) = 0.
2108 pni_iha(k) = 0.
2109
2110 prs_iau(k) = 0.
2111 prs_sci(k) = 0.
2112 prs_rcs(k) = 0.
2113 prs_scw(k) = 0.
2114 prs_sde(k) = 0.
2115 prs_ihm(k) = 0.
2116 prs_ide(k) = 0.
2117
2118 prg_scw(k) = 0.
2119 prg_rfz(k) = 0.
2120 prg_gde(k) = 0.
2121 prg_gcw(k) = 0.
2122 prg_rci(k) = 0.
2123 prg_rcs(k) = 0.
2124 prg_rcg(k) = 0.
2125 prg_ihm(k) = 0.
2126
2127 pna_rca(k) = 0.
2128 pna_sca(k) = 0.
2129 pna_gca(k) = 0.
2130
2131 pnd_rcd(k) = 0.
2132 pnd_scd(k) = 0.
2133 pnd_gcd(k) = 0.
2134
2135 pfil1(k) = 0.
2136 pfll1(k) = 0.
2137 pfil(k) = 0.
2138 pfll(k) = 0.
2139 pdummy(k) = 0.
2140 enddo
2141#if ( WRF_CHEM == 1 )
2142 do k = kts, kte
2143 rainprod(k) = 0.
2144 evapprod(k) = 0.
2145 enddo
2146#endif
2147
2148!Diagnostics
2149 if (ext_diag) then
2150 do k = kts, kte
2151 !vtsk1(k) = 0.
2152 !txrc1(k) = 0.
2153 !txri1(k) = 0.
2154 prw_vcdc1(k) = 0.
2155 prw_vcde1(k) = 0.
2156 tpri_inu1(k) = 0.
2157 tpri_ide1_d(k) = 0.
2158 tpri_ide1_s(k) = 0.
2159 tprs_ide1(k) = 0.
2160 tprs_sde1_d(k) = 0.
2161 tprs_sde1_s(k) = 0.
2162 tprg_gde1_d(k) = 0.
2163 tprg_gde1_s(k) = 0.
2164 tpri_iha1(k) = 0.
2165 tpri_wfz1(k) = 0.
2166 tpri_rfz1(k) = 0.
2167 tprg_rfz1(k) = 0.
2168 tprg_scw1(k) = 0.
2169 tprs_scw1(k) = 0.
2170 tprg_rcs1(k) = 0.
2171 tprs_rcs1(k) = 0.
2172 tprr_rci1(k) = 0.
2173 tprg_rcg1(k) = 0.
2174 tprw_vcd1_c(k) = 0.
2175 tprw_vcd1_e(k) = 0.
2176 tprr_sml1(k) = 0.
2177 tprr_gml1(k) = 0.
2178 tprr_rcg1(k) = 0.
2179 tprr_rcs1(k) = 0.
2180 tprv_rev1(k) = 0.
2181 tten1(k) = 0.
2182 qvten1(k) = 0.
2183 qrten1(k) = 0.
2184 qsten1(k) = 0.
2185 qgten1(k) = 0.
2186 qiten1(k) = 0.
2187 niten1(k) = 0.
2188 nrten1(k) = 0.
2189 ncten1(k) = 0.
2190 qcten1(k) = 0.
2191 enddo
2192 endif
2193
2194!..Bug fix (2016Jun15), prevent use of uninitialized value(s) of snow moments.
2195 do k = kts, kte
2196 smo0(k) = 0.
2197 smo1(k) = 0.
2198 smo2(k) = 0.
2199 smob(k) = 0.
2200 smoc(k) = 0.
2201 smod(k) = 0.
2202 smoe(k) = 0.
2203 smof(k) = 0.
2204 enddo
2205
2206!+---+-----------------------------------------------------------------+
2208!+---+-----------------------------------------------------------------+
2209 do k = kts, kte
2210 temp(k) = t1d(k)
2211 qv(k) = max(1.e-10, qv1d(k))
2212 pres(k) = p1d(k)
2213 rho(k) = 0.622*pres(k)/(r*temp(k)*(qv(k)+0.622))
2214 nwfa(k) = max(11.1e6*rho(k), min(9999.e6*rho(k), nwfa1d(k)*rho(k)))
2215 nifa(k) = max(nain1*0.01*rho(k), min(9999.e6*rho(k), nifa1d(k)*rho(k)))
2216 mvd_r(k) = d0r
2217 mvd_c(k) = d0c
2218
2219 if (qc1d(k) .gt. r1) then
2220 no_micro = .false.
2221 rc(k) = qc1d(k)*rho(k)
2222 nc(k) = max(2., min(nc1d(k)*rho(k), nt_c_max))
2223 l_qc(k) = .true.
2224 if (nc(k).gt.10000.e6) then
2225 nu_c = 2
2226 elseif (nc(k).lt.100.) then
2227 nu_c = 15
2228 else
2229 nu_c = nint(1000.e6/nc(k)) + 2
2230 nu_c = max(2, min(nu_c+nint(rand2), 15))
2231 endif
2232 lamc = (nc(k)*am_r*ccg(2,nu_c)*ocg1(nu_c)/rc(k))**obmr
2233 xdc = (bm_r + nu_c + 1.) / lamc
2234 if (xdc.lt. d0c) then
2235 lamc = cce(2,nu_c)/d0c
2236 elseif (xdc.gt. d0r*2.) then
2237 lamc = cce(2,nu_c)/(d0r*2.)
2238 endif
2239 nc(k) = min( dble(nt_c_max), ccg(1,nu_c)*ocg2(nu_c)*rc(k) &
2240 / am_r*lamc**bm_r)
2241 if (.NOT. (is_aerosol_aware .or. merra2_aerosol_aware)) then
2242 if (lsml == 1) then
2243 nc(k) = nt_c_l
2244 else
2245 nc(k) = nt_c_o
2246 endif
2247 endif
2248 else
2249 qc1d(k) = 0.0
2250 nc1d(k) = 0.0
2251 rc(k) = r1
2252 nc(k) = 2.
2253 l_qc(k) = .false.
2254 endif
2255
2256 if (qi1d(k) .gt. r1) then
2257 no_micro = .false.
2258 ri(k) = qi1d(k)*rho(k)
2259 ni(k) = max(r2, ni1d(k)*rho(k))
2260 if (ni(k).le. r2) then
2261 lami = cie(2)/5.e-6
2262 ni(k) = min(4999.d3, cig(1)*oig2*ri(k)/am_i*lami**bm_i)
2263 endif
2264 l_qi(k) = .true.
2265 lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi
2266 ilami = 1./lami
2267 xdi = (bm_i + mu_i + 1.) * ilami
2268 if (xdi.lt. 5.e-6) then
2269 lami = cie(2)/5.e-6
2270 ni(k) = min(4999.d3, cig(1)*oig2*ri(k)/am_i*lami**bm_i)
2271 elseif (xdi.gt. 300.e-6) then
2272 lami = cie(2)/300.e-6
2273 ni(k) = cig(1)*oig2*ri(k)/am_i*lami**bm_i
2274 endif
2275 else
2276 qi1d(k) = 0.0
2277 ni1d(k) = 0.0
2278 ri(k) = r1
2279 ni(k) = r2
2280 l_qi(k) = .false.
2281 endif
2282
2283 if (qr1d(k) .gt. r1) then
2284 no_micro = .false.
2285 rr(k) = qr1d(k)*rho(k)
2286 nr(k) = max(r2, nr1d(k)*rho(k))
2287 if (nr(k).le. r2) then
2288 mvd_r(k) = 1.0e-3
2289 lamr = (3.0 + mu_r + 0.672) / mvd_r(k)
2290 nr(k) = crg(2)*org3*rr(k)*lamr**bm_r / am_r
2291 endif
2292 l_qr(k) = .true.
2293 lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr
2294 mvd_r(k) = (3.0 + mu_r + 0.672) / lamr
2295 if (mvd_r(k) .gt. 2.5e-3) then
2296 mvd_r(k) = 2.5e-3
2297 lamr = (3.0 + mu_r + 0.672) / mvd_r(k)
2298 nr(k) = crg(2)*org3*rr(k)*lamr**bm_r / am_r
2299 elseif (mvd_r(k) .lt. d0r*0.75) then
2300 mvd_r(k) = d0r*0.75
2301 lamr = (3.0 + mu_r + 0.672) / mvd_r(k)
2302 nr(k) = crg(2)*org3*rr(k)*lamr**bm_r / am_r
2303 endif
2304 else
2305 qr1d(k) = 0.0
2306 nr1d(k) = 0.0
2307 rr(k) = r1
2308 nr(k) = r2
2309 l_qr(k) = .false.
2310 endif
2311 if (qs1d(k) .gt. r1) then
2312 no_micro = .false.
2313 rs(k) = qs1d(k)*rho(k)
2314 l_qs(k) = .true.
2315 else
2316 qs1d(k) = 0.0
2317 rs(k) = r1
2318 l_qs(k) = .false.
2319 endif
2320 if (qg1d(k) .gt. r1) then
2321 no_micro = .false.
2322 rg(k) = qg1d(k)*rho(k)
2323 l_qg(k) = .true.
2324 else
2325 qg1d(k) = 0.0
2326 rg(k) = r1
2327 l_qg(k) = .false.
2328 endif
2329 enddo
2330
2331!+---+-----------------------------------------------------------------+
2332! if (debug_flag) then
2333! do k = kts, kte
2334! write(*, '(a,i3,f8.2,1x,f7.2,1x, 11(1x,e13.6))') &
2335! & 'VERBOSE: ', k, pres(k)*0.01, temp(k)-273.15, qv(k), rc(k), rr(k), ri(k), rs(k), rg(k), nc(k), nr(k), ni(k), nwfa(k), nifa(k)
2336! enddo
2337! endif
2338!+---+-----------------------------------------------------------------+
2339
2340!+---+-----------------------------------------------------------------+
2345!+---+-----------------------------------------------------------------+
2346 do k = kts, kte
2347 tempc = temp(k) - 273.15
2348 rhof(k) = sqrt(rho_not/rho(k))
2349 rhof2(k) = sqrt(rhof(k))
2350 qvs(k) = rslf(pres(k), temp(k))
2351 delqvs(k) = max(0.0, rslf(pres(k), 273.15)-qv(k))
2352 if (tempc .le. 0.0) then
2353 qvsi(k) = rsif(pres(k), temp(k))
2354 else
2355 qvsi(k) = qvs(k)
2356 endif
2357 satw(k) = qv(k)/qvs(k)
2358 sati(k) = qv(k)/qvsi(k)
2359 ssatw(k) = satw(k) - 1.
2360 ssati(k) = sati(k) - 1.
2361 if (abs(ssatw(k)).lt. eps) ssatw(k) = 0.0
2362 if (abs(ssati(k)).lt. eps) ssati(k) = 0.0
2363 if (no_micro .and. ssati(k).gt. 0.0) no_micro = .false.
2364 diffu(k) = 2.11e-5*(temp(k)/273.15)**1.94 * (101325./pres(k))
2365 if (tempc .ge. 0.0) then
2366 visco(k) = (1.718+0.0049*tempc)*1.0e-5
2367 else
2368 visco(k) = (1.718+0.0049*tempc-1.2e-5*tempc*tempc)*1.0e-5
2369 endif
2370 ocp(k) = 1./(cp*(1.+0.887*qv(k)))
2371 vsc2(k) = sqrt(rho(k)/visco(k))
2372 lvap(k) = lvap0 + (2106.0 - 4218.0)*tempc
2373 tcond(k) = (5.69 + 0.0168*tempc)*1.0e-5 * 418.936
2374 enddo
2375
2376!+---+-----------------------------------------------------------------+
2379!+---+-----------------------------------------------------------------+
2380
2381 if (no_micro) return
2382
2383!+---+-----------------------------------------------------------------+
2385!+---+-----------------------------------------------------------------+
2386 if (.not. iiwarm) then
2387 do k = kts, kte
2388 if (.not. l_qs(k)) cycle
2389 tc0 = min(-0.1, temp(k)-273.15)
2390 smob(k) = rs(k)*oams
2391
2394 if (bm_s.gt.(2.0-1.e-3) .and. bm_s.lt.(2.0+1.e-3)) then
2395 smo2(k) = smob(k)
2396 else
2397 loga_ = sa(1) + sa(2)*tc0 + sa(3)*bm_s &
2398 + sa(4)*tc0*bm_s + sa(5)*tc0*tc0 &
2399 + sa(6)*bm_s*bm_s + sa(7)*tc0*tc0*bm_s &
2400 + sa(8)*tc0*bm_s*bm_s + sa(9)*tc0*tc0*tc0 &
2401 + sa(10)*bm_s*bm_s*bm_s
2402 a_ = 10.0**loga_
2403 b_ = sb(1) + sb(2)*tc0 + sb(3)*bm_s &
2404 + sb(4)*tc0*bm_s + sb(5)*tc0*tc0 &
2405 + sb(6)*bm_s*bm_s + sb(7)*tc0*tc0*bm_s &
2406 + sb(8)*tc0*bm_s*bm_s + sb(9)*tc0*tc0*tc0 &
2407 + sb(10)*bm_s*bm_s*bm_s
2408 smo2(k) = (smob(k)/a_)**(1./b_)
2409 endif
2410
2412 loga_ = sa(1) + sa(2)*tc0 + sa(5)*tc0*tc0 + sa(9)*tc0*tc0*tc0
2413 a_ = 10.0**loga_
2414 b_ = sb(1) + sb(2)*tc0 + sb(5)*tc0*tc0 + sb(9)*tc0*tc0*tc0
2415 smo0(k) = a_ * smo2(k)**b_
2416
2418 loga_ = sa(1) + sa(2)*tc0 + sa(3) &
2419 + sa(4)*tc0 + sa(5)*tc0*tc0 &
2420 + sa(6) + sa(7)*tc0*tc0 &
2421 + sa(8)*tc0 + sa(9)*tc0*tc0*tc0 &
2422 + sa(10)
2423 a_ = 10.0**loga_
2424 b_ = sb(1)+ sb(2)*tc0 + sb(3) + sb(4)*tc0 &
2425 + sb(5)*tc0*tc0 + sb(6) &
2426 + sb(7)*tc0*tc0 + sb(8)*tc0 &
2427 + sb(9)*tc0*tc0*tc0 + sb(10)
2428 smo1(k) = a_ * smo2(k)**b_
2429
2431 loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(1) &
2432 + sa(4)*tc0*cse(1) + sa(5)*tc0*tc0 &
2433 + sa(6)*cse(1)*cse(1) + sa(7)*tc0*tc0*cse(1) &
2434 + sa(8)*tc0*cse(1)*cse(1) + sa(9)*tc0*tc0*tc0 &
2435 + sa(10)*cse(1)*cse(1)*cse(1)
2436 a_ = 10.0**loga_
2437 b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(1) + sb(4)*tc0*cse(1) &
2438 + sb(5)*tc0*tc0 + sb(6)*cse(1)*cse(1) &
2439 + sb(7)*tc0*tc0*cse(1) + sb(8)*tc0*cse(1)*cse(1) &
2440 + sb(9)*tc0*tc0*tc0 + sb(10)*cse(1)*cse(1)*cse(1)
2441 smoc(k) = a_ * smo2(k)**b_
2442
2444 loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(13) &
2445 + sa(4)*tc0*cse(13) + sa(5)*tc0*tc0 &
2446 + sa(6)*cse(13)*cse(13) + sa(7)*tc0*tc0*cse(13) &
2447 + sa(8)*tc0*cse(13)*cse(13) + sa(9)*tc0*tc0*tc0 &
2448 + sa(10)*cse(13)*cse(13)*cse(13)
2449 a_ = 10.0**loga_
2450 b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(13) + sb(4)*tc0*cse(13) &
2451 + sb(5)*tc0*tc0 + sb(6)*cse(13)*cse(13) &
2452 + sb(7)*tc0*tc0*cse(13) + sb(8)*tc0*cse(13)*cse(13) &
2453 + sb(9)*tc0*tc0*tc0 + sb(10)*cse(13)*cse(13)*cse(13)
2454 smoe(k) = a_ * smo2(k)**b_
2455
2457 loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(16) &
2458 + sa(4)*tc0*cse(16) + sa(5)*tc0*tc0 &
2459 + sa(6)*cse(16)*cse(16) + sa(7)*tc0*tc0*cse(16) &
2460 + sa(8)*tc0*cse(16)*cse(16) + sa(9)*tc0*tc0*tc0 &
2461 + sa(10)*cse(16)*cse(16)*cse(16)
2462 a_ = 10.0**loga_
2463 b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(16) + sb(4)*tc0*cse(16) &
2464 + sb(5)*tc0*tc0 + sb(6)*cse(16)*cse(16) &
2465 + sb(7)*tc0*tc0*cse(16) + sb(8)*tc0*cse(16)*cse(16) &
2466 + sb(9)*tc0*tc0*tc0 + sb(10)*cse(16)*cse(16)*cse(16)
2467 smof(k) = a_ * smo2(k)**b_
2468
2469 enddo
2470
2471!+---+-----------------------------------------------------------------+
2473!+---+-----------------------------------------------------------------+
2474 call graupel_psd_parameters(kts, kte, rand1, rg, ilamg, n0_g)
2475 endif
2476
2477!+---+-----------------------------------------------------------------+
2479!+---+-----------------------------------------------------------------+
2480 do k = kte, kts, -1
2481 lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr
2482 ilamr(k) = 1./lamr
2483 mvd_r(k) = (3.0 + mu_r + 0.672) / lamr
2484 n0_r(k) = nr(k)*org2*lamr**cre(2)
2485 enddo
2486
2487!+---+-----------------------------------------------------------------+
2489!+---+-----------------------------------------------------------------+
2490
2491 do k = kts, kte
2492
2495 if (l_qr(k) .and. mvd_r(k).gt. d0r) then
2496 ef_rr = max(-0.1, 1.0 - exp(2300.0*(mvd_r(k)-1950.0e-6)))
2497 pnr_rcr(k) = ef_rr * 2.0*nr(k)*rr(k)
2498 endif
2499
2500 if (l_qc(k)) then
2501 if (nc(k).gt.10000.e6) then
2502 nu_c = 2
2503 elseif (nc(k).lt.100.) then
2504 nu_c = 15
2505 else
2506 nu_c = nint(1000.e6/nc(k)) + 2
2507 nu_c = max(2, min(nu_c+nint(rand2), 15))
2508 endif
2509 xdc = max(d0c*1.e6, ((rc(k)/(am_r*nc(k)))**obmr) * 1.e6)
2510 lamc = (nc(k)*am_r* ccg(2,nu_c) * ocg1(nu_c) / rc(k))**obmr
2511 mvd_c(k) = (3.0+nu_c+0.672) / lamc
2512 mvd_c(k) = max(d0c, min(mvd_c(k), d0r))
2513 endif
2514
2517 if (rc(k).gt. 0.01e-3) then
2518 dc_g = ((ccg(3,nu_c)*ocg2(nu_c))**obmr / lamc) * 1.e6
2519 dc_b = (xdc*xdc*xdc*dc_g*dc_g*dc_g - xdc*xdc*xdc*xdc*xdc*xdc) &
2520 **(1./6.)
2521 zeta1 = 0.5*((6.25e-6*xdc*dc_b*dc_b*dc_b - 0.4) &
2522 + abs(6.25e-6*xdc*dc_b*dc_b*dc_b - 0.4))
2523 zeta = 0.027*rc(k)*zeta1
2524 taud = 0.5*((0.5*dc_b - 7.5) + abs(0.5*dc_b - 7.5)) + r1
2525 tau = 3.72/(rc(k)*taud)
2526 prr_wau(k) = zeta/tau
2527 prr_wau(k) = min(dble(rc(k)*odts), prr_wau(k))
2528 pnr_wau(k) = prr_wau(k) / (am_r*nu_c*10.*d0r*d0r*d0r) ! RAIN2M
2529 pnc_wau(k) = min(dble(nc(k)*odts), prr_wau(k) &
2530 / (am_r*mvd_c(k)*mvd_c(k)*mvd_c(k))) ! Qc2M
2531 endif
2532
2534 if (l_qr(k) .and. mvd_r(k).gt. d0r .and. mvd_c(k).gt. d0c) then
2535 lamr = 1./ilamr(k)
2536 idx = 1 + int(nbr*dlog(mvd_r(k)/dr(1))/dlog(dr(nbr)/dr(1)))
2537 idx = min(idx, nbr)
2538 ef_rw = t_efrw(idx, int(mvd_c(k)*1.e6))
2539 prr_rcw(k) = rhof(k)*t1_qr_qc*ef_rw*rc(k)*n0_r(k) &
2540 *((lamr+fv_r)**(-cre(9)))
2541 prr_rcw(k) = min(dble(rc(k)*odts), prr_rcw(k))
2542 pnc_rcw(k) = rhof(k)*t1_qr_qc*ef_rw*nc(k)*n0_r(k) &
2543 *((lamr+fv_r)**(-cre(9))) ! Qc2M
2544 pnc_rcw(k) = min(dble(nc(k)*odts), pnc_rcw(k))
2545 endif
2546
2548 if (l_qr(k) .and. mvd_r(k).gt. d0r) then
2549 ef_ra = eff_aero(mvd_r(k),0.04e-6,visco(k),rho(k),temp(k),'r')
2550 lamr = 1./ilamr(k)
2551 pna_rca(k) = rhof(k)*t1_qr_qc*ef_ra*nwfa(k)*n0_r(k) &
2552 *((lamr+fv_r)**(-cre(9)))
2553 pna_rca(k) = min(dble(nwfa(k)*odts), pna_rca(k))
2554
2555 ef_ra = eff_aero(mvd_r(k),0.8e-6,visco(k),rho(k),temp(k),'r')
2556 pnd_rcd(k) = rhof(k)*t1_qr_qc*ef_ra*nifa(k)*n0_r(k) &
2557 *((lamr+fv_r)**(-cre(9)))
2558 pnd_rcd(k) = min(dble(nifa(k)*odts), pnd_rcd(k))
2559 endif
2560
2561 enddo
2562
2563!+---+-----------------------------------------------------------------+
2565!+---+-----------------------------------------------------------------+
2566 if (.not. iiwarm) then
2567 do k = kts, kte
2568 vts_boost(k) = 1.0
2569 xds = 0.0
2570 if (l_qs(k)) xds = smoc(k) / smob(k)
2571
2573 tempc = temp(k) - 273.15
2574 idx_tc = max(1, min(nint(-tempc), 45) )
2575 idx_t = int( (tempc-2.5)/5. ) - 1
2576 idx_t = max(1, -idx_t)
2577 idx_t = min(idx_t, ntb_t)
2578 it = max(1, min(nint(-tempc), 31) )
2579
2581 if (rc(k).gt. r_c(1)) then
2582 nic = nint(alog10(rc(k)))
2583 do nn = nic-1, nic+1
2584 n = nn
2585 if ( (rc(k)/10.**nn).ge.1.0 .and. &
2586 (rc(k)/10.**nn).lt.10.0) goto 141
2587 enddo
2588 141 continue
2589 idx_c = int(rc(k)/10.**n) + 10*(n-nic2) - (n-nic2)
2590 idx_c = max(1, min(idx_c, ntb_c))
2591 else
2592 idx_c = 1
2593 endif
2594
2596 idx_n = nint(1.0 + float(nbc) * dlog(nc(k)/t_nc(1)) / nic1)
2597 idx_n = max(1, min(idx_n, nbc))
2598
2600 if (ri(k).gt. r_i(1)) then
2601 nii = nint(alog10(ri(k)))
2602 do nn = nii-1, nii+1
2603 n = nn
2604 if ( (ri(k)/10.**nn).ge.1.0 .and. &
2605 (ri(k)/10.**nn).lt.10.0) goto 142
2606 enddo
2607 142 continue
2608 idx_i = int(ri(k)/10.**n) + 10*(n-nii2) - (n-nii2)
2609 idx_i = max(1, min(idx_i, ntb_i))
2610 else
2611 idx_i = 1
2612 endif
2613
2614 if (ni(k).gt. nt_i(1)) then
2615 nii = nint(alog10(ni(k)))
2616 do nn = nii-1, nii+1
2617 n = nn
2618 if ( (ni(k)/10.**nn).ge.1.0 .and. &
2619 (ni(k)/10.**nn).lt.10.0) goto 143
2620 enddo
2621 143 continue
2622 idx_i1 = int(ni(k)/10.**n) + 10*(n-nii3) - (n-nii3)
2623 idx_i1 = max(1, min(idx_i1, ntb_i1))
2624 else
2625 idx_i1 = 1
2626 endif
2627
2629 if (rr(k).gt. r_r(1)) then
2630 nir = nint(alog10(rr(k)))
2631 do nn = nir-1, nir+1
2632 n = nn
2633 if ( (rr(k)/10.**nn).ge.1.0 .and. &
2634 (rr(k)/10.**nn).lt.10.0) goto 144
2635 enddo
2636 144 continue
2637 idx_r = int(rr(k)/10.**n) + 10*(n-nir2) - (n-nir2)
2638 idx_r = max(1, min(idx_r, ntb_r))
2639
2640 lamr = 1./ilamr(k)
2641 lam_exp = lamr * (crg(3)*org2*org1)**bm_r
2642 n0_exp = org1*rr(k)/am_r * lam_exp**cre(1)
2643 nir = nint(dlog10(n0_exp))
2644 do nn = nir-1, nir+1
2645 n = nn
2646 if ( (n0_exp/10.**nn).ge.1.0 .and. &
2647 (n0_exp/10.**nn).lt.10.0) goto 145
2648 enddo
2649 145 continue
2650 idx_r1 = int(n0_exp/10.**n) + 10*(n-nir3) - (n-nir3)
2651 idx_r1 = max(1, min(idx_r1, ntb_r1))
2652 else
2653 idx_r = 1
2654 idx_r1 = ntb_r1
2655 endif
2656
2658 if (rs(k).gt. r_s(1)) then
2659 nis = nint(alog10(rs(k)))
2660 do nn = nis-1, nis+1
2661 n = nn
2662 if ( (rs(k)/10.**nn).ge.1.0 .and. &
2663 (rs(k)/10.**nn).lt.10.0) goto 146
2664 enddo
2665 146 continue
2666 idx_s = int(rs(k)/10.**n) + 10*(n-nis2) - (n-nis2)
2667 idx_s = max(1, min(idx_s, ntb_s))
2668 else
2669 idx_s = 1
2670 endif
2671
2673 if (rg(k).gt. r_g(1)) then
2674 nig = nint(alog10(rg(k)))
2675 do nn = nig-1, nig+1
2676 n = nn
2677 if ( (rg(k)/10.**nn).ge.1.0 .and. &
2678 (rg(k)/10.**nn).lt.10.0) goto 147
2679 enddo
2680 147 continue
2681 idx_g = int(rg(k)/10.**n) + 10*(n-nig2) - (n-nig2)
2682 idx_g = max(1, min(idx_g, ntb_g))
2683
2684 lamg = 1./ilamg(k)
2685 lam_exp = lamg * (cgg(3)*ogg2*ogg1)**bm_g
2686 n0_exp = ogg1*rg(k)/am_g * lam_exp**cge(1)
2687 nig = nint(dlog10(n0_exp))
2688 do nn = nig-1, nig+1
2689 n = nn
2690 if ( (n0_exp/10.**nn).ge.1.0 .and. &
2691 (n0_exp/10.**nn).lt.10.0) goto 148
2692 enddo
2693 148 continue
2694 idx_g1 = int(n0_exp/10.**n) + 10*(n-nig3) - (n-nig3)
2695 idx_g1 = max(1, min(idx_g1, ntb_g1))
2696 else
2697 idx_g = 1
2698 idx_g1 = ntb_g1
2699 endif
2700
2702 otemp = 1./temp(k)
2703 rvs = rho(k)*qvsi(k)
2704 rvs_p = rvs*otemp*(lsub*otemp*orv - 1.)
2705 rvs_pp = rvs * ( otemp*(lsub*otemp*orv - 1.) &
2706 *otemp*(lsub*otemp*orv - 1.) &
2707 + (-2.*lsub*otemp*otemp*otemp*orv) &
2708 + otemp*otemp)
2709 gamsc = lsub*diffu(k)/tcond(k) * rvs_p
2710 alphsc = 0.5*(gamsc/(1.+gamsc))*(gamsc/(1.+gamsc)) &
2711 * rvs_pp/rvs_p * rvs/rvs_p
2712 alphsc = max(1.e-9, alphsc)
2713 xsat = ssati(k)
2714 if (abs(xsat).lt. 1.e-9) xsat=0.
2715 t1_subl = 4.*pi*( 1.0 - alphsc*xsat &
2716 + 2.*alphsc*alphsc*xsat*xsat &
2717 - 5.*alphsc*alphsc*alphsc*xsat*xsat*xsat ) &
2718 / (1.+gamsc)
2719
2721 if (l_qc(k) .and. mvd_c(k).gt. d0c) then
2722 if (xds .gt. d0s) then
2723 idx = 1 + int(nbs*dlog(xds/ds(1))/dlog(ds(nbs)/ds(1)))
2724 idx = min(idx, nbs)
2725 ef_sw = t_efsw(idx, int(mvd_c(k)*1.e6))
2726 prs_scw(k) = rhof(k)*t1_qs_qc*ef_sw*rc(k)*smoe(k)
2727 prs_scw(k) = min(dble(rc(k)*odts), prs_scw(k))
2728 pnc_scw(k) = rhof(k)*t1_qs_qc*ef_sw*nc(k)*smoe(k) ! Qc2M
2729 pnc_scw(k) = min(dble(nc(k)*odts), pnc_scw(k))
2730 endif
2731
2733 if (rg(k).ge. r_g(1) .and. mvd_c(k).gt. d0c) then
2734 xdg = (bm_g + mu_g + 1.) * ilamg(k)
2735 vtg = rhof(k)*av_g*cgg(6)*ogg3 * ilamg(k)**bv_g
2736 stoke_g = mvd_c(k)*mvd_c(k)*vtg*rho_w/(9.*visco(k)*xdg)
2737 if (xdg.gt. d0g) then
2738 if (stoke_g.ge.0.4 .and. stoke_g.le.10.) then
2739 ef_gw = 0.55*alog10(2.51*stoke_g)
2740 elseif (stoke_g.lt.0.4) then
2741 ef_gw = 0.0
2742 elseif (stoke_g.gt.10) then
2743 ef_gw = 0.77
2744 endif
2745 prg_gcw(k) = rhof(k)*t1_qg_qc*ef_gw*rc(k)*n0_g(k) &
2746 *ilamg(k)**cge(9)
2747 pnc_gcw(k) = rhof(k)*t1_qg_qc*ef_gw*nc(k)*n0_g(k) &
2748 *ilamg(k)**cge(9) ! Qc2M
2749 pnc_gcw(k) = min(dble(nc(k)*odts), pnc_gcw(k))
2750 endif
2751 endif
2752 endif
2753
2755 if (rs(k) .gt. r_s(1)) then
2756 ef_sa = eff_aero(xds,0.04e-6,visco(k),rho(k),temp(k),'s')
2757 pna_sca(k) = rhof(k)*t1_qs_qc*ef_sa*nwfa(k)*smoe(k)
2758 pna_sca(k) = min(dble(nwfa(k)*odts), pna_sca(k))
2759
2760 ef_sa = eff_aero(xds,0.8e-6,visco(k),rho(k),temp(k),'s')
2761 pnd_scd(k) = rhof(k)*t1_qs_qc*ef_sa*nifa(k)*smoe(k)
2762 pnd_scd(k) = min(dble(nifa(k)*odts), pnd_scd(k))
2763 endif
2764 if (rg(k) .gt. r_g(1)) then
2765 xdg = (bm_g + mu_g + 1.) * ilamg(k)
2766 ef_ga = eff_aero(xdg,0.04e-6,visco(k),rho(k),temp(k),'g')
2767 pna_gca(k) = rhof(k)*t1_qg_qc*ef_ga*nwfa(k)*n0_g(k) &
2768 *ilamg(k)**cge(9)
2769 pna_gca(k) = min(dble(nwfa(k)*odts), pna_gca(k))
2770
2771 ef_ga = eff_aero(xdg,0.8e-6,visco(k),rho(k),temp(k),'g')
2772 pnd_gcd(k) = rhof(k)*t1_qg_qc*ef_ga*nifa(k)*n0_g(k) &
2773 *ilamg(k)**cge(9)
2774 pnd_gcd(k) = min(dble(nifa(k)*odts), pnd_gcd(k))
2775 endif
2776
2780 if (rr(k).ge. r_r(1)) then
2781 if (rs(k).ge. r_s(1)) then
2782 if (temp(k).lt.t_0) then
2783 prr_rcs(k) = -(tmr_racs2(idx_s,idx_t,idx_r1,idx_r) &
2784 + tcr_sacr2(idx_s,idx_t,idx_r1,idx_r) &
2785 + tmr_racs1(idx_s,idx_t,idx_r1,idx_r) &
2786 + tcr_sacr1(idx_s,idx_t,idx_r1,idx_r))
2787 prs_rcs(k) = tmr_racs2(idx_s,idx_t,idx_r1,idx_r) &
2788 + tcr_sacr2(idx_s,idx_t,idx_r1,idx_r) &
2789 - tcs_racs1(idx_s,idx_t,idx_r1,idx_r) &
2790 - tms_sacr1(idx_s,idx_t,idx_r1,idx_r)
2791 prg_rcs(k) = tmr_racs1(idx_s,idx_t,idx_r1,idx_r) &
2792 + tcr_sacr1(idx_s,idx_t,idx_r1,idx_r) &
2793 + tcs_racs1(idx_s,idx_t,idx_r1,idx_r) &
2794 + tms_sacr1(idx_s,idx_t,idx_r1,idx_r)
2795 prr_rcs(k) = max(dble(-rr(k)*odts), prr_rcs(k))
2796 prs_rcs(k) = max(dble(-rs(k)*odts), prs_rcs(k))
2797 prg_rcs(k) = min(dble((rr(k)+rs(k))*odts), prg_rcs(k))
2798 pnr_rcs(k) = tnr_racs1(idx_s,idx_t,idx_r1,idx_r) & ! RAIN2M
2799 + tnr_racs2(idx_s,idx_t,idx_r1,idx_r) &
2800 + tnr_sacr1(idx_s,idx_t,idx_r1,idx_r) &
2801 + tnr_sacr2(idx_s,idx_t,idx_r1,idx_r)
2802 pnr_rcs(k) = min(dble(nr(k)*odts), pnr_rcs(k))
2803 else
2804 prs_rcs(k) = -tcs_racs1(idx_s,idx_t,idx_r1,idx_r) &
2805 - tms_sacr1(idx_s,idx_t,idx_r1,idx_r) &
2806 + tmr_racs2(idx_s,idx_t,idx_r1,idx_r) &
2807 + tcr_sacr2(idx_s,idx_t,idx_r1,idx_r)
2808 prs_rcs(k) = max(dble(-rs(k)*odts), prs_rcs(k))
2809 prr_rcs(k) = -prs_rcs(k)
2810 endif
2811 endif
2812
2816 if (rg(k).ge. r_g(1)) then
2817 if (temp(k).lt.t_0) then
2818 prg_rcg(k) = tmr_racg(idx_g1,idx_g,idx_r1,idx_r) &
2819 + tcr_gacr(idx_g1,idx_g,idx_r1,idx_r)
2820 prg_rcg(k) = min(dble(rr(k)*odts), prg_rcg(k))
2821 prr_rcg(k) = -prg_rcg(k)
2822 pnr_rcg(k) = tnr_racg(idx_g1,idx_g,idx_r1,idx_r) & ! RAIN2M
2823 + tnr_gacr(idx_g1,idx_g,idx_r1,idx_r)
2824 pnr_rcg(k) = min(dble(nr(k)*odts), pnr_rcg(k))
2825 else
2826 prr_rcg(k) = tcg_racg(idx_g1,idx_g,idx_r1,idx_r)
2827 prr_rcg(k) = min(dble(rg(k)*odts), prr_rcg(k))
2828 prg_rcg(k) = -prr_rcg(k)
2830 pnr_rcg(k) = -1.5*tnr_gacr(idx_g1,idx_g,idx_r1,idx_r) ! RAIN2M
2831 endif
2832 endif
2833 endif
2834
2835 if (temp(k).lt.t_0) then
2836 rate_max = (qv(k)-qvsi(k))*rho(k)*odts*0.999
2837
2839 if (l_qs(k)) then
2840 c_snow = c_sqrd + (tempc+1.5)*(c_cube-c_sqrd)/(-30.+1.5)
2841 c_snow = max(c_sqrd, min(c_snow, c_cube))
2842 prs_sde(k) = c_snow*t1_subl*diffu(k)*ssati(k)*rvs &
2843 * (t1_qs_sd*smo1(k) &
2844 + t2_qs_sd*rhof2(k)*vsc2(k)*smof(k))
2845 if (prs_sde(k).lt. 0.) then
2846 prs_sde(k) = max(dble(-rs(k)*odts), prs_sde(k), dble(rate_max))
2847 else
2848 prs_sde(k) = min(prs_sde(k), dble(rate_max))
2849 endif
2850 endif
2851
2852 if (l_qg(k) .and. ssati(k).lt. -eps) then
2853 prg_gde(k) = c_cube*t1_subl*diffu(k)*ssati(k)*rvs &
2854 * n0_g(k) * (t1_qg_sd*ilamg(k)**cge(10) &
2855 + t2_qg_sd*vsc2(k)*rhof2(k)*ilamg(k)**cge(11))
2856 if (prg_gde(k).lt. 0.) then
2857 prg_gde(k) = max(dble(-rg(k)*odts), prg_gde(k), dble(rate_max))
2858 else
2859 prg_gde(k) = min(prg_gde(k), dble(rate_max))
2860 endif
2861 endif
2862
2867 if (prs_scw(k).gt.5.0*prs_sde(k) .and. &
2868 prs_sde(k).gt.eps) then
2869 r_frac = min(30.0d0, prs_scw(k)/prs_sde(k))
2870 g_frac = min(0.75, 0.15 + (r_frac-5.)*.028)
2871 vts_boost(k) = min(1.5, 1.1 + (r_frac-5.)*.016)
2872 prg_scw(k) = g_frac*prs_scw(k)
2873 prs_scw(k) = (1. - g_frac)*prs_scw(k)
2874 endif
2875
2876 endif
2877
2878!+---+-----------------------------------------------------------------+
2880!+---+-----------------------------------------------------------------+
2881
2882 if (temp(k).lt.t_0) then
2883
2884 rate_max = (qv(k)-qvsi(k))*rho(k)*odts*0.999
2885
2886!+---+---------------- BEGIN NEW ICE NUCLEATION -----------------------+
2898!+---+-----------------------------------------------------------------+
2899
2900 if (dustyice .AND. (is_aerosol_aware .or. merra2_aerosol_aware)) then
2901 xni = icedemott(tempc,qvs(k),qvs(k),qvsi(k),rho(k),nifa(k))
2902 else
2903 xni = 1.0 *1000. ! Default is 1.0 per Liter
2904 endif
2905
2907 if (xni.gt. nt_in(1)) then
2908 niin = nint(alog10(xni))
2909 do nn = niin-1, niin+1
2910 n = nn
2911 if ( (xni/10.**nn).ge.1.0 .and. &
2912 (xni/10.**nn).lt.10.0) goto 149
2913 enddo
2914 149 continue
2915 idx_in = int(xni/10.**n) + 10*(n-niin2) - (n-niin2)
2916 idx_in = max(1, min(idx_in, ntb_in))
2917 else
2918 idx_in = 1
2919 endif
2920
2922 if (rr(k).gt. r_r(1)) then
2923 prg_rfz(k) = tpg_qrfz(idx_r,idx_r1,idx_tc,idx_in)*odts
2924 pri_rfz(k) = tpi_qrfz(idx_r,idx_r1,idx_tc,idx_in)*odts
2925 pni_rfz(k) = tni_qrfz(idx_r,idx_r1,idx_tc,idx_in)*odts
2926 pnr_rfz(k) = tnr_qrfz(idx_r,idx_r1,idx_tc,idx_in)*odts ! RAIN2M
2927 pnr_rfz(k) = min(dble(nr(k)*odts), pnr_rfz(k))
2928 elseif (rr(k).gt. r1 .and. temp(k).lt.hgfr) then
2929 pri_rfz(k) = rr(k)*odts
2930 pni_rfz(k) = pnr_rfz(k)
2931 endif
2932
2933 if (rc(k).gt. r_c(1)) then
2934 pri_wfz(k) = tpi_qcfz(idx_c,idx_n,idx_tc,idx_in)*odts
2935 pri_wfz(k) = min(dble(rc(k)*odts), pri_wfz(k))
2936 pni_wfz(k) = tni_qcfz(idx_c,idx_n,idx_tc,idx_in)*odts
2937 pni_wfz(k) = min(dble(nc(k)*odts), pri_wfz(k)/(2.*xm0i), &
2938 pni_wfz(k))
2939 elseif (rc(k).gt. r1 .and. temp(k).lt.hgfr) then
2940 pri_wfz(k) = rc(k)*odts
2941 pni_wfz(k) = nc(k)*odts
2942 endif
2943
2946 if ( (ssati(k).ge. 0.15) .or. (ssatw(k).gt. eps &
2947 .and. temp(k).lt.253.15) ) then
2948 if (dustyice .AND. (is_aerosol_aware .or. merra2_aerosol_aware)) then
2949 xnc = icedemott(tempc,qv(k),qvs(k),qvsi(k),rho(k),nifa(k))
2950 xnc = xnc*(1.0 + 50.*rand3)
2951 else
2952 xnc = min(1000.e3, tno*exp(ato*(t_0-temp(k))))
2953 endif
2954 xni = ni(k) + (pni_rfz(k)+pni_wfz(k))*dtsave
2955 pni_inu(k) = 0.5*(xnc-xni + abs(xnc-xni))*odts
2956 pri_inu(k) = min(dble(rate_max), xm0i*pni_inu(k))
2957 pni_inu(k) = pri_inu(k)/xm0i
2958 endif
2959
2961 xni = smo0(k)+ni(k) + (pni_rfz(k)+pni_wfz(k)+pni_inu(k))*dtsave
2962 if ((is_aerosol_aware .or. merra2_aerosol_aware) .AND. homogice .AND. (xni.le.4999.e3) &
2963 & .AND.(temp(k).lt.238).AND.(ssati(k).ge.0.4) ) then
2964 xnc = icekoop(temp(k),qv(k),qvs(k),nwfa(k), dtsave)
2965 pni_iha(k) = xnc*odts
2966 pri_iha(k) = min(dble(rate_max), xm0i*0.1*pni_iha(k))
2967 pni_iha(k) = pri_iha(k)/(xm0i*0.1)
2968 endif
2969!+---+------------------ END NEW ICE NUCLEATION -----------------------+
2970
2971
2973 if (l_qi(k)) then
2974 lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi
2975 ilami = 1./lami
2976 xdi = max(dble(d0i), (bm_i + mu_i + 1.) * ilami)
2977 xmi = am_i*xdi**bm_i
2978 oxmi = 1./xmi
2979 pri_ide(k) = c_cube*t1_subl*diffu(k)*ssati(k)*rvs &
2980 *oig1*cig(5)*ni(k)*ilami
2981
2982 if (pri_ide(k) .lt. 0.0) then
2983 pri_ide(k) = max(dble(-ri(k)*odts), pri_ide(k), dble(rate_max))
2984 pni_ide(k) = pri_ide(k)*oxmi
2985 pni_ide(k) = max(dble(-ni(k)*odts), pni_ide(k))
2986 else
2987 pri_ide(k) = min(pri_ide(k), dble(rate_max))
2988 prs_ide(k) = (1.0d0-tpi_ide(idx_i,idx_i1))*pri_ide(k)
2989 pri_ide(k) = tpi_ide(idx_i,idx_i1)*pri_ide(k)
2990 endif
2991
2994 if ( (idx_i.eq. ntb_i) .or. (xdi.gt. 5.0*d0s) ) then
2995 prs_iau(k) = ri(k)*.99*odts
2996 pni_iau(k) = ni(k)*.95*odts
2997 elseif (xdi.lt. 0.1*d0s) then
2998 prs_iau(k) = 0.
2999 pni_iau(k) = 0.
3000 else
3001 prs_iau(k) = tps_iaus(idx_i,idx_i1)*odts
3002 prs_iau(k) = min(dble(ri(k)*.99*odts), prs_iau(k))
3003 pni_iau(k) = tni_iaus(idx_i,idx_i1)*odts
3004 pni_iau(k) = min(dble(ni(k)*.95*odts), pni_iau(k))
3005 endif
3006 endif
3007
3009 if (l_qi(k)) then
3010 lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi
3011 ilami = 1./lami
3012 xdi = max(dble(d0i), (bm_i + mu_i + 1.) * ilami)
3013 xmi = am_i*xdi**bm_i
3014 oxmi = 1./xmi
3015 if (rs(k).ge. r_s(1)) then
3016 prs_sci(k) = t1_qs_qi*rhof(k)*ef_si*ri(k)*smoe(k)
3017 pni_sci(k) = prs_sci(k) * oxmi
3018 endif
3019
3021 if (rr(k).ge. r_r(1) .and. mvd_r(k).gt. 4.*xdi) then
3022 lamr = 1./ilamr(k)
3023 pri_rci(k) = rhof(k)*t1_qr_qi*ef_ri*ri(k)*n0_r(k) &
3024 *((lamr+fv_r)**(-cre(9)))
3025 pnr_rci(k) = rhof(k)*t1_qr_qi*ef_ri*ni(k)*n0_r(k) & ! RAIN2M
3026 *((lamr+fv_r)**(-cre(9)))
3027 pni_rci(k) = pri_rci(k) * oxmi
3028 prr_rci(k) = rhof(k)*t2_qr_qi*ef_ri*ni(k)*n0_r(k) &
3029 *((lamr+fv_r)**(-cre(8)))
3030 prr_rci(k) = min(dble(rr(k)*odts), prr_rci(k))
3031 prg_rci(k) = pri_rci(k) + prr_rci(k)
3032 endif
3033 endif
3034
3036 if (prg_gcw(k).gt. eps .and. tempc.gt.-8.0) then
3037 tf = 0.
3038 if (tempc.ge.-5.0 .and. tempc.lt.-3.0) then
3039 tf = 0.5*(-3.0 - tempc)
3040 elseif (tempc.gt.-8.0 .and. tempc.lt.-5.0) then
3041 tf = 0.33333333*(8.0 + tempc)
3042 endif
3043 pni_ihm(k) = 3.5e8*tf*prg_gcw(k)
3044 pri_ihm(k) = xm0i*pni_ihm(k)
3045 prs_ihm(k) = prs_scw(k)/(prs_scw(k)+prg_gcw(k)) &
3046 * pri_ihm(k)
3047 prg_ihm(k) = prg_gcw(k)/(prs_scw(k)+prg_gcw(k)) &
3048 * pri_ihm(k)
3049 endif
3050
3051 else
3052
3055 if (l_qs(k)) then
3056 prr_sml(k) = (tempc*tcond(k)-lvap0*diffu(k)*delqvs(k)) &
3057 * (t1_qs_me*smo1(k) + t2_qs_me*rhof2(k)*vsc2(k)*smof(k))
3058 if (prr_sml(k) .gt. 0.) then
3059 prr_sml(k) = prr_sml(k) + 4218.*olfus*tempc &
3060 * (prr_rcs(k)+prs_scw(k))
3061 prr_sml(k) = min(dble(rs(k)*odts), prr_sml(k))
3062 pnr_sml(k) = smo0(k)/rs(k)*prr_sml(k) * 10.0**(-0.25*tempc) ! RAIN2M
3063 pnr_sml(k) = min(dble(smo0(k)*odts), pnr_sml(k))
3064 elseif (ssati(k).lt. 0.) then
3065 prr_sml(k) = 0.0
3066 prs_sde(k) = c_cube*t1_subl*diffu(k)*ssati(k)*rvs &
3067 * (t1_qs_sd*smo1(k) &
3068 + t2_qs_sd*rhof2(k)*vsc2(k)*smof(k))
3069 prs_sde(k) = max(dble(-rs(k)*odts), prs_sde(k))
3070 endif
3071 endif
3072
3073 if (l_qg(k)) then
3074 prr_gml(k) = (tempc*tcond(k)-lvap0*diffu(k)*delqvs(k)) &
3075 * n0_g(k)*(t1_qg_me*ilamg(k)**cge(10) &
3076 + t2_qg_me*rhof2(k)*vsc2(k)*ilamg(k)**cge(11))
3077 if (prr_gml(k) .gt. 0.) then
3078 prr_gml(k) = min(dble(rg(k)*odts), prr_gml(k))
3079 pnr_gml(k) = n0_g(k)*cgg(2)*ilamg(k)**cge(2) / rg(k) & ! RAIN2M
3080 * prr_gml(k) * 10.0**(-0.5*tempc)
3081 elseif (ssati(k).lt. 0.) then
3082 prr_gml(k) = 0.0
3083 prg_gde(k) = c_cube*t1_subl*diffu(k)*ssati(k)*rvs &
3084 * n0_g(k) * (t1_qg_sd*ilamg(k)**cge(10) &
3085 + t2_qg_sd*vsc2(k)*rhof2(k)*ilamg(k)**cge(11))
3086 prg_gde(k) = max(dble(-rg(k)*odts), prg_gde(k))
3087 endif
3088 endif
3089
3094 if (dt .gt. 120.) then
3095 prr_rcw(k)=prr_rcw(k)+prs_scw(k)+prg_gcw(k)
3096 prs_scw(k)=0.
3097 prg_gcw(k)=0.
3098 endif
3099
3100 endif
3101
3102 enddo
3103 endif
3104
3105!+---+-----------------------------------------------------------------+
3107!+---+-----------------------------------------------------------------+
3108 do k = kts, kte
3109
3114 sump = pri_inu(k) + pri_ide(k) + prs_ide(k) &
3115 + prs_sde(k) + prg_gde(k) + pri_iha(k)
3116 rate_max = (qv(k)-qvsi(k))*rho(k)*odts*0.999
3117 if ( (sump.gt. eps .and. sump.gt. rate_max) .or. &
3118 (sump.lt. -eps .and. sump.lt. rate_max) ) then
3119 ratio = rate_max/sump
3120 pri_inu(k) = pri_inu(k) * ratio
3121 pri_ide(k) = pri_ide(k) * ratio
3122 pni_ide(k) = pni_ide(k) * ratio
3123 prs_ide(k) = prs_ide(k) * ratio
3124 prs_sde(k) = prs_sde(k) * ratio
3125 prg_gde(k) = prg_gde(k) * ratio
3126 pri_iha(k) = pri_iha(k) * ratio
3127 endif
3128
3130 sump = -prr_wau(k) - pri_wfz(k) - prr_rcw(k) &
3131 - prs_scw(k) - prg_scw(k) - prg_gcw(k)
3132 rate_max = -rc(k)*odts
3133 if (sump.lt. rate_max .and. l_qc(k)) then
3134 ratio = rate_max/sump
3135 prr_wau(k) = prr_wau(k) * ratio
3136 pri_wfz(k) = pri_wfz(k) * ratio
3137 prr_rcw(k) = prr_rcw(k) * ratio
3138 prs_scw(k) = prs_scw(k) * ratio
3139 prg_scw(k) = prg_scw(k) * ratio
3140 prg_gcw(k) = prg_gcw(k) * ratio
3141 endif
3142
3144 sump = pri_ide(k) - prs_iau(k) - prs_sci(k) &
3145 - pri_rci(k)
3146 rate_max = -ri(k)*odts
3147 if (sump.lt. rate_max .and. l_qi(k)) then
3148 ratio = rate_max/sump
3149 pri_ide(k) = pri_ide(k) * ratio
3150 prs_iau(k) = prs_iau(k) * ratio
3151 prs_sci(k) = prs_sci(k) * ratio
3152 pri_rci(k) = pri_rci(k) * ratio
3153 endif
3154
3156 sump = -prg_rfz(k) - pri_rfz(k) - prr_rci(k) &
3157 + prr_rcs(k) + prr_rcg(k)
3158 rate_max = -rr(k)*odts
3159 if (sump.lt. rate_max .and. l_qr(k)) then
3160 ratio = rate_max/sump
3161 prg_rfz(k) = prg_rfz(k) * ratio
3162 pri_rfz(k) = pri_rfz(k) * ratio
3163 prr_rci(k) = prr_rci(k) * ratio
3164 prr_rcs(k) = prr_rcs(k) * ratio
3165 prr_rcg(k) = prr_rcg(k) * ratio
3166 endif
3167
3169 sump = prs_sde(k) - prs_ihm(k) - prr_sml(k) &
3170 + prs_rcs(k)
3171 rate_max = -rs(k)*odts
3172 if (sump.lt. rate_max .and. l_qs(k)) then
3173 ratio = rate_max/sump
3174 prs_sde(k) = prs_sde(k) * ratio
3175 prs_ihm(k) = prs_ihm(k) * ratio
3176 prr_sml(k) = prr_sml(k) * ratio
3177 prs_rcs(k) = prs_rcs(k) * ratio
3178 endif
3179
3181 sump = prg_gde(k) - prg_ihm(k) - prr_gml(k) &
3182 + prg_rcg(k)
3183 rate_max = -rg(k)*odts
3184 if (sump.lt. rate_max .and. l_qg(k)) then
3185 ratio = rate_max/sump
3186 prg_gde(k) = prg_gde(k) * ratio
3187 prg_ihm(k) = prg_ihm(k) * ratio
3188 prr_gml(k) = prr_gml(k) * ratio
3189 prg_rcg(k) = prg_rcg(k) * ratio
3190 endif
3191
3194 pri_ihm(k) = prs_ihm(k) + prg_ihm(k)
3195 ratio = min( abs(prr_rcg(k)), abs(prg_rcg(k)) )
3196 prr_rcg(k) = ratio * sign(1.0, sngl(prr_rcg(k)))
3197 prg_rcg(k) = -prr_rcg(k)
3198 if (temp(k).gt.t_0) then
3199 ratio = min( abs(prr_rcs(k)), abs(prs_rcs(k)) )
3200 prr_rcs(k) = ratio * sign(1.0, sngl(prr_rcs(k)))
3201 prs_rcs(k) = -prr_rcs(k)
3202 endif
3203
3204 enddo
3205
3206!+---+-----------------------------------------------------------------+
3209!+---+-----------------------------------------------------------------+
3210 do k = kts, kte
3211 orho = 1./rho(k)
3212 lfus2 = lsub - lvap(k)
3213
3215 if (is_aerosol_aware) then
3216 nwfaten(k) = nwfaten(k) - (pna_rca(k) + pna_sca(k) &
3217 + pna_gca(k) + pni_iha(k)) * orho
3218 nifaten(k) = nifaten(k) - (pnd_rcd(k) + pnd_scd(k) &
3219 + pnd_gcd(k)) * orho
3220 if (dustyice) then
3221 nifaten(k) = nifaten(k) - pni_inu(k)*orho
3222 else
3223 nifaten(k) = 0.
3224 endif
3225 endif
3226
3228 qvten(k) = qvten(k) + (-pri_inu(k) - pri_iha(k) - pri_ide(k) &
3229 - prs_ide(k) - prs_sde(k) - prg_gde(k)) &
3230 * orho
3231
3233 qcten(k) = qcten(k) + (-prr_wau(k) - pri_wfz(k) &
3234 - prr_rcw(k) - prs_scw(k) - prg_scw(k) &
3235 - prg_gcw(k)) &
3236 * orho
3237
3239 ncten(k) = ncten(k) + (-pnc_wau(k) - pnc_rcw(k) &
3240 - pni_wfz(k) - pnc_scw(k) - pnc_gcw(k)) &
3241 * orho
3242
3245 xrc=max(r1, (qc1d(k) + qcten(k)*dtsave)*rho(k))
3246 xnc=max(2., (nc1d(k) + ncten(k)*dtsave)*rho(k))
3247 if (xrc .gt. r1) then
3248 if (xnc.gt.10000.e6) then
3249 nu_c = 2
3250 elseif (xnc.lt.100.) then
3251 nu_c = 15
3252 else
3253 nu_c = nint(1000.e6/xnc) + 2
3254 nu_c = max(2, min(nu_c+nint(rand2), 15))
3255 endif
3256 lamc = (xnc*am_r*ccg(2,nu_c)*ocg1(nu_c)/rc(k))**obmr
3257 xdc = (bm_r + nu_c + 1.) / lamc
3258 if (xdc.lt. d0c) then
3259 lamc = cce(2,nu_c)/d0c
3260 xnc = ccg(1,nu_c)*ocg2(nu_c)*xrc/am_r*lamc**bm_r
3261 ncten(k) = (xnc-nc1d(k)*rho(k))*odts*orho
3262 elseif (xdc.gt. d0r*2.) then
3263 lamc = cce(2,nu_c)/(d0r*2.)
3264 xnc = ccg(1,nu_c)*ocg2(nu_c)*xrc/am_r*lamc**bm_r
3265 ncten(k) = (xnc-nc1d(k)*rho(k))*odts*orho
3266 endif
3267 else
3268 ncten(k) = -nc1d(k)*odts
3269 endif
3270 xnc=max(0.,(nc1d(k) + ncten(k)*dtsave)*rho(k))
3271 if (xnc.gt.nt_c_max) &
3272 ncten(k) = (nt_c_max-nc1d(k)*rho(k))*odts*orho
3273
3275 qiten(k) = qiten(k) + (pri_inu(k) + pri_iha(k) + pri_ihm(k) &
3276 + pri_wfz(k) + pri_rfz(k) + pri_ide(k) &
3277 - prs_iau(k) - prs_sci(k) - pri_rci(k)) &
3278 * orho
3279
3281 niten(k) = niten(k) + (pni_inu(k) + pni_iha(k) + pni_ihm(k) &
3282 + pni_wfz(k) + pni_rfz(k) + pni_ide(k) &
3283 - pni_iau(k) - pni_sci(k) - pni_rci(k)) &
3284 * orho
3285
3288 xri=max(r1,(qi1d(k) + qiten(k)*dtsave)*rho(k))
3289 xni=max(r2,(ni1d(k) + niten(k)*dtsave)*rho(k))
3290 if (xri.gt. r1) then
3291 lami = (am_i*cig(2)*oig1*xni/xri)**obmi
3292 ilami = 1./lami
3293 xdi = (bm_i + mu_i + 1.) * ilami
3294 if (xdi.lt. 5.e-6) then
3295 lami = cie(2)/5.e-6
3296 xni = min(4999.d3, cig(1)*oig2*xri/am_i*lami**bm_i)
3297 niten(k) = (xni-ni1d(k)*rho(k))*odts*orho
3298 elseif (xdi.gt. 300.e-6) then
3299 lami = cie(2)/300.e-6
3300 xni = cig(1)*oig2*xri/am_i*lami**bm_i
3301 niten(k) = (xni-ni1d(k)*rho(k))*odts*orho
3302 endif
3303 else
3304 niten(k) = -ni1d(k)*odts
3305 endif
3306 xni=max(0.,(ni1d(k) + niten(k)*dtsave)*rho(k))
3307 if (xni.gt.4999.e3) &
3308 niten(k) = (4999.e3-ni1d(k)*rho(k))*odts*orho
3309
3311 qrten(k) = qrten(k) + (prr_wau(k) + prr_rcw(k) &
3312 + prr_sml(k) + prr_gml(k) + prr_rcs(k) &
3313 + prr_rcg(k) - prg_rfz(k) &
3314 - pri_rfz(k) - prr_rci(k)) &
3315 * orho
3316
3318 nrten(k) = nrten(k) + (pnr_wau(k) + pnr_sml(k) + pnr_gml(k) &
3319 - (pnr_rfz(k) + pnr_rcr(k) + pnr_rcg(k) &
3320 + pnr_rcs(k) + pnr_rci(k) + pni_rfz(k)) ) &
3321 * orho
3322
3325 xrr=max(r1,(qr1d(k) + qrten(k)*dtsave)*rho(k))
3326 xnr=max(r2,(nr1d(k) + nrten(k)*dtsave)*rho(k))
3327 if (xrr.gt. r1) then
3328 lamr = (am_r*crg(3)*org2*xnr/xrr)**obmr
3329 mvd_r(k) = (3.0 + mu_r + 0.672) / lamr
3330 if (mvd_r(k) .gt. 2.5e-3) then
3331 mvd_r(k) = 2.5e-3
3332 lamr = (3.0 + mu_r + 0.672) / mvd_r(k)
3333 xnr = crg(2)*org3*xrr*lamr**bm_r / am_r
3334 nrten(k) = (xnr-nr1d(k)*rho(k))*odts*orho
3335 elseif (mvd_r(k) .lt. d0r*0.75) then
3336 mvd_r(k) = d0r*0.75
3337 lamr = (3.0 + mu_r + 0.672) / mvd_r(k)
3338 xnr = crg(2)*org3*xrr*lamr**bm_r / am_r
3339 nrten(k) = (xnr-nr1d(k)*rho(k))*odts*orho
3340 endif
3341 else
3342 qrten(k) = -qr1d(k)*odts
3343 nrten(k) = -nr1d(k)*odts
3344 endif
3345
3347 qsten(k) = qsten(k) + (prs_iau(k) + prs_sde(k) &
3348 + prs_sci(k) + prs_scw(k) + prs_rcs(k) &
3349 + prs_ide(k) - prs_ihm(k) - prr_sml(k)) &
3350 * orho
3351
3353 qgten(k) = qgten(k) + (prg_scw(k) + prg_rfz(k) &
3354 + prg_gde(k) + prg_rcg(k) + prg_gcw(k) &
3355 + prg_rci(k) + prg_rcs(k) - prg_ihm(k) &
3356 - prr_gml(k)) &
3357 * orho
3358
3360 if (temp(k).lt.t_0) then
3361 tten(k) = tten(k) &
3362 + ( lsub*ocp(k)*(pri_inu(k) + pri_ide(k) &
3363 + prs_ide(k) + prs_sde(k) &
3364 + prg_gde(k) + pri_iha(k)) &
3365 + lfus2*ocp(k)*(pri_wfz(k) + pri_rfz(k) &
3366 + prg_rfz(k) + prs_scw(k) &
3367 + prg_scw(k) + prg_gcw(k) &
3368 + prg_rcs(k) + prs_rcs(k) &
3369 + prr_rci(k) + prg_rcg(k)) &
3370 )*orho * (1-ifdry)
3371 else
3372 tten(k) = tten(k) &
3373 + ( lfus*ocp(k)*(-prr_sml(k) - prr_gml(k) &
3374 - prr_rcg(k) - prr_rcs(k)) &
3375 + lsub*ocp(k)*(prs_sde(k) + prg_gde(k)) &
3376 )*orho * (1-ifdry)
3377 endif
3378
3379 enddo
3380
3381!+---+-----------------------------------------------------------------+
3383!+---+-----------------------------------------------------------------+
3384 do k = kts, kte
3385 temp(k) = t1d(k) + dt*tten(k)
3386 otemp = 1./temp(k)
3387 tempc = temp(k) - 273.15
3388 qv(k) = max(1.e-10, qv1d(k) + dt*qvten(k))
3389 rho(k) = 0.622*pres(k)/(r*temp(k)*(qv(k)+0.622))
3390 rhof(k) = sqrt(rho_not/rho(k))
3391 rhof2(k) = sqrt(rhof(k))
3392 qvs(k) = rslf(pres(k), temp(k))
3393 ssatw(k) = qv(k)/qvs(k) - 1.
3394 if (abs(ssatw(k)).lt. eps) ssatw(k) = 0.0
3395 diffu(k) = 2.11e-5*(temp(k)/273.15)**1.94 * (101325./pres(k))
3396 if (tempc .ge. 0.0) then
3397 visco(k) = (1.718+0.0049*tempc)*1.0e-5
3398 else
3399 visco(k) = (1.718+0.0049*tempc-1.2e-5*tempc*tempc)*1.0e-5
3400 endif
3401 vsc2(k) = sqrt(rho(k)/visco(k))
3402 lvap(k) = lvap0 + (2106.0 - 4218.0)*tempc
3403 tcond(k) = (5.69 + 0.0168*tempc)*1.0e-5 * 418.936
3404 ocp(k) = 1./(cp*(1.+0.887*qv(k)))
3405 lvt2(k)=lvap(k)*lvap(k)*ocp(k)*orv*otemp*otemp
3406 if (is_aerosol_aware) &
3407 nwfa(k) = max(11.1e6*rho(k), (nwfa1d(k) + nwfaten(k)*dt)*rho(k))
3408 enddo
3409
3410 do k = kts, kte
3411 if ((qc1d(k) + qcten(k)*dt) .gt. r1) then
3412 rc(k) = (qc1d(k) + qcten(k)*dt)*rho(k)
3413 nc(k) = max(2., min((nc1d(k)+ncten(k)*dt)*rho(k), nt_c_max))
3414 if (.NOT. (is_aerosol_aware .or. merra2_aerosol_aware)) then
3415 if(lsml == 1) then
3416 nc(k) = nt_c_l
3417 else
3418 nc(k) = nt_c_o
3419 endif
3420 endif
3421 l_qc(k) = .true.
3422 else
3423 rc(k) = r1
3424 nc(k) = 2.
3425 l_qc(k) = .false.
3426 endif
3427
3428 if ((qi1d(k) + qiten(k)*dt) .gt. r1) then
3429 ri(k) = (qi1d(k) + qiten(k)*dt)*rho(k)
3430 ni(k) = max(r2, (ni1d(k) + niten(k)*dt)*rho(k))
3431 l_qi(k) = .true.
3432 else
3433 ri(k) = r1
3434 ni(k) = r2
3435 l_qi(k) = .false.
3436 endif
3437
3438 if ((qr1d(k) + qrten(k)*dt) .gt. r1) then
3439 rr(k) = (qr1d(k) + qrten(k)*dt)*rho(k)
3440 nr(k) = max(r2, (nr1d(k) + nrten(k)*dt)*rho(k))
3441 l_qr(k) = .true.
3442 lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr
3443 mvd_r(k) = (3.0 + mu_r + 0.672) / lamr
3444 if (mvd_r(k) .gt. 2.5e-3) then
3445 mvd_r(k) = 2.5e-3
3446 lamr = (3.0 + mu_r + 0.672) / mvd_r(k)
3447 nr(k) = crg(2)*org3*rr(k)*lamr**bm_r / am_r
3448 elseif (mvd_r(k) .lt. d0r*0.75) then
3449 mvd_r(k) = d0r*0.75
3450 lamr = (3.0 + mu_r + 0.672) / mvd_r(k)
3451 nr(k) = crg(2)*org3*rr(k)*lamr**bm_r / am_r
3452 endif
3453 else
3454 rr(k) = r1
3455 nr(k) = r2
3456 l_qr(k) = .false.
3457 endif
3458
3459 if ((qs1d(k) + qsten(k)*dt) .gt. r1) then
3460 rs(k) = (qs1d(k) + qsten(k)*dt)*rho(k)
3461 l_qs(k) = .true.
3462 else
3463 rs(k) = r1
3464 l_qs(k) = .false.
3465 endif
3466
3467 if ((qg1d(k) + qgten(k)*dt) .gt. r1) then
3468 rg(k) = (qg1d(k) + qgten(k)*dt)*rho(k)
3469 l_qg(k) = .true.
3470 else
3471 rg(k) = r1
3472 l_qg(k) = .false.
3473 endif
3474 enddo
3475
3476!+---+-----------------------------------------------------------------+
3479!+---+-----------------------------------------------------------------+
3480 if (.not. iiwarm) then
3481 do k = kts, kte
3482 smo2(k) = 0.
3483 smob(k) = 0.
3484 smoc(k) = 0.
3485 smod(k) = 0.
3486 enddo
3487 do k = kts, kte
3488 if (.not. l_qs(k)) cycle
3489 tc0 = min(-0.1, temp(k)-273.15)
3490 smob(k) = rs(k)*oams
3491
3494 if (bm_s.gt.(2.0-1.e-3) .and. bm_s.lt.(2.0+1.e-3)) then
3495 smo2(k) = smob(k)
3496 else
3497 loga_ = sa(1) + sa(2)*tc0 + sa(3)*bm_s &
3498 + sa(4)*tc0*bm_s + sa(5)*tc0*tc0 &
3499 + sa(6)*bm_s*bm_s + sa(7)*tc0*tc0*bm_s &
3500 + sa(8)*tc0*bm_s*bm_s + sa(9)*tc0*tc0*tc0 &
3501 + sa(10)*bm_s*bm_s*bm_s
3502 a_ = 10.0**loga_
3503 b_ = sb(1) + sb(2)*tc0 + sb(3)*bm_s &
3504 + sb(4)*tc0*bm_s + sb(5)*tc0*tc0 &
3505 + sb(6)*bm_s*bm_s + sb(7)*tc0*tc0*bm_s &
3506 + sb(8)*tc0*bm_s*bm_s + sb(9)*tc0*tc0*tc0 &
3507 + sb(10)*bm_s*bm_s*bm_s
3508 smo2(k) = (smob(k)/a_)**(1./b_)
3509 endif
3510
3512 loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(1) &
3513 + sa(4)*tc0*cse(1) + sa(5)*tc0*tc0 &
3514 + sa(6)*cse(1)*cse(1) + sa(7)*tc0*tc0*cse(1) &
3515 + sa(8)*tc0*cse(1)*cse(1) + sa(9)*tc0*tc0*tc0 &
3516 + sa(10)*cse(1)*cse(1)*cse(1)
3517 a_ = 10.0**loga_
3518 b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(1) + sb(4)*tc0*cse(1) &
3519 + sb(5)*tc0*tc0 + sb(6)*cse(1)*cse(1) &
3520 + sb(7)*tc0*tc0*cse(1) + sb(8)*tc0*cse(1)*cse(1) &
3521 + sb(9)*tc0*tc0*tc0 + sb(10)*cse(1)*cse(1)*cse(1)
3522 smoc(k) = a_ * smo2(k)**b_
3523
3525 loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(14) &
3526 + sa(4)*tc0*cse(14) + sa(5)*tc0*tc0 &
3527 + sa(6)*cse(14)*cse(14) + sa(7)*tc0*tc0*cse(14) &
3528 + sa(8)*tc0*cse(14)*cse(14) + sa(9)*tc0*tc0*tc0 &
3529 + sa(10)*cse(14)*cse(14)*cse(14)
3530 a_ = 10.0**loga_
3531 b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(14) + sb(4)*tc0*cse(14) &
3532 + sb(5)*tc0*tc0 + sb(6)*cse(14)*cse(14) &
3533 + sb(7)*tc0*tc0*cse(14) + sb(8)*tc0*cse(14)*cse(14) &
3534 + sb(9)*tc0*tc0*tc0 + sb(10)*cse(14)*cse(14)*cse(14)
3535 smod(k) = a_ * smo2(k)**b_
3536 enddo
3537
3538!+---+-----------------------------------------------------------------+
3540!+---+-----------------------------------------------------------------+
3541 call graupel_psd_parameters(kts, kte, rand1, rg, ilamg, n0_g)
3542 endif
3543
3544!+---+-----------------------------------------------------------------+
3546!+---+-----------------------------------------------------------------+
3547 do k = kte, kts, -1
3548 lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr
3549 ilamr(k) = 1./lamr
3550 mvd_r(k) = (3.0 + mu_r + 0.672) / lamr
3551 n0_r(k) = nr(k)*org2*lamr**cre(2)
3552 enddo
3553
3554!+---+-----------------------------------------------------------------+
3561!+---+-----------------------------------------------------------------+
3562 do k = kts, kte
3563 orho = 1./rho(k)
3564 if ( (ssatw(k).gt. eps) .or. (ssatw(k).lt. -eps .and. &
3565 l_qc(k)) ) then
3566 clap = (qv(k)-qvs(k))/(1. + lvt2(k)*qvs(k))
3567 do n = 1, 3
3568 fcd = qvs(k)* exp(lvt2(k)*clap) - qv(k) + clap
3569 dfcd = qvs(k)*lvt2(k)* exp(lvt2(k)*clap) + 1.
3570 clap = clap - fcd/dfcd
3571 enddo
3572 xrc = rc(k) + clap*rho(k)
3573 xnc = 0.
3574 if (xrc.gt. r1) then
3575 prw_vcd(k) = clap*odt
3576!+---+-----------------------------------------------------------------+ ! DROPLET NUCLEATION
3577 if (clap .gt. eps) then
3578 if (is_aerosol_aware .or. merra2_aerosol_aware) then
3579 xnc = max(2., activ_ncloud(temp(k), w1d(k)+rand3, nwfa(k), lsml))
3580 else
3581 if(lsml == 1) then
3582 xnc = nt_c_l
3583 else
3584 xnc = nt_c_o
3585 endif
3586 endif
3587 pnc_wcd(k) = 0.5*(xnc-nc(k) + abs(xnc-nc(k)))*odts*orho
3588
3589!+---+-----------------------------------------------------------------+ ! EVAPORATION
3590 elseif (clap .lt. -eps .AND. ssatw(k).lt.-1.e-6 .AND. &
3591 is_aerosol_aware) then
3592 tempc = temp(k) - 273.15
3593 otemp = 1./temp(k)
3594 rvs = rho(k)*qvs(k)
3595 rvs_p = rvs*otemp*(lvap(k)*otemp*orv - 1.)
3596 rvs_pp = rvs * ( otemp*(lvap(k)*otemp*orv - 1.) &
3597 *otemp*(lvap(k)*otemp*orv - 1.) &
3598 + (-2.*lvap(k)*otemp*otemp*otemp*orv) &
3599 + otemp*otemp)
3600 gamsc = lvap(k)*diffu(k)/tcond(k) * rvs_p
3601 alphsc = 0.5*(gamsc/(1.+gamsc))*(gamsc/(1.+gamsc)) &
3602 * rvs_pp/rvs_p * rvs/rvs_p
3603 alphsc = max(1.e-9, alphsc)
3604 xsat = ssatw(k)
3605 if (abs(xsat).lt. 1.e-9) xsat=0.
3606 t1_evap = 2.*pi*( 1.0 - alphsc*xsat &
3607 + 2.*alphsc*alphsc*xsat*xsat &
3608 - 5.*alphsc*alphsc*alphsc*xsat*xsat*xsat ) &
3609 / (1.+gamsc)
3610
3611 dc_star = dsqrt(-2.d0*dt * t1_evap/(2.*pi) &
3612 * 4.*diffu(k)*ssatw(k)*rvs/rho_w)
3613 idx_d = max(1, min(int(1.e6*dc_star), nbc))
3614
3615 idx_n = nint(1.0 + float(nbc) * dlog(nc(k)/t_nc(1)) / nic1)
3616 idx_n = max(1, min(idx_n, nbc))
3617
3619 if (rc(k).gt. r_c(1)) then
3620 nic = nint(alog10(rc(k)))
3621 do nn = nic-1, nic+1
3622 n = nn
3623 if ( (rc(k)/10.**nn).ge.1.0 .and. &
3624 (rc(k)/10.**nn).lt.10.0) goto 159
3625 enddo
3626 159 continue
3627 idx_c = int(rc(k)/10.**n) + 10*(n-nic2) - (n-nic2)
3628 idx_c = max(1, min(idx_c, ntb_c))
3629 else
3630 idx_c = 1
3631 endif
3632
3633 !prw_vcd(k) = MAX(DBLE(-rc(k)*orho*odt), &
3634 ! -tpc_wev(idx_d, idx_c, idx_n)*orho*odt)
3635 prw_vcd(k) = max(dble(-rc(k)*0.99*orho*odt), prw_vcd(k))
3636 pnc_wcd(k) = max(dble(-nc(k)*0.99*orho*odt), &
3637 -tnc_wev(idx_d, idx_c, idx_n)*orho*odt)
3638
3639 endif
3640 else
3641 prw_vcd(k) = -rc(k)*orho*odt
3642 pnc_wcd(k) = -nc(k)*orho*odt
3643 endif
3644
3645!+---+-----------------------------------------------------------------+
3646
3647 qvten(k) = qvten(k) - prw_vcd(k)
3648 qcten(k) = qcten(k) + prw_vcd(k)
3649 ncten(k) = ncten(k) + pnc_wcd(k)
3650 if (is_aerosol_aware) &
3651 nwfaten(k) = nwfaten(k) - pnc_wcd(k)
3652 tten(k) = tten(k) + lvap(k)*ocp(k)*prw_vcd(k)*(1-ifdry)
3653 rc(k) = max(r1, (qc1d(k) + dt*qcten(k))*rho(k))
3654 if (rc(k).eq.r1) l_qc(k) = .false.
3655 nc(k) = max(2., min((nc1d(k)+ncten(k)*dt)*rho(k), nt_c_max))
3656 if (.NOT. (is_aerosol_aware .or. merra2_aerosol_aware)) then
3657 if(lsml == 1) then
3658 nc(k) = nt_c_l
3659 else
3660 nc(k) = nt_c_o
3661 endif
3662 endif
3663 qv(k) = max(1.e-10, qv1d(k) + dt*qvten(k))
3664 temp(k) = t1d(k) + dt*tten(k)
3665 rho(k) = 0.622*pres(k)/(r*temp(k)*(qv(k)+0.622))
3666 qvs(k) = rslf(pres(k), temp(k))
3667 ssatw(k) = qv(k)/qvs(k) - 1.
3668 endif
3669 enddo
3670
3671!+---+-----------------------------------------------------------------+
3674!+---+-----------------------------------------------------------------+
3675 do k = kts, kte
3676 if ( (ssatw(k).lt. -eps) .and. l_qr(k) &
3677 .and. (.not.(prw_vcd(k).gt. 0.)) ) then
3678 tempc = temp(k) - 273.15
3679 otemp = 1./temp(k)
3680 orho = 1./rho(k)
3681 rhof(k) = sqrt(rho_not*orho)
3682 rhof2(k) = sqrt(rhof(k))
3683 diffu(k) = 2.11e-5*(temp(k)/273.15)**1.94 * (101325./pres(k))
3684 if (tempc .ge. 0.0) then
3685 visco(k) = (1.718+0.0049*tempc)*1.0e-5
3686 else
3687 visco(k) = (1.718+0.0049*tempc-1.2e-5*tempc*tempc)*1.0e-5
3688 endif
3689 vsc2(k) = sqrt(rho(k)/visco(k))
3690 lvap(k) = lvap0 + (2106.0 - 4218.0)*tempc
3691 tcond(k) = (5.69 + 0.0168*tempc)*1.0e-5 * 418.936
3692 ocp(k) = 1./(cp*(1.+0.887*qv(k)))
3693
3694 rvs = rho(k)*qvs(k)
3695 rvs_p = rvs*otemp*(lvap(k)*otemp*orv - 1.)
3696 rvs_pp = rvs * ( otemp*(lvap(k)*otemp*orv - 1.) &
3697 *otemp*(lvap(k)*otemp*orv - 1.) &
3698 + (-2.*lvap(k)*otemp*otemp*otemp*orv) &
3699 + otemp*otemp)
3700 gamsc = lvap(k)*diffu(k)/tcond(k) * rvs_p
3701 alphsc = 0.5*(gamsc/(1.+gamsc))*(gamsc/(1.+gamsc)) &
3702 * rvs_pp/rvs_p * rvs/rvs_p
3703 alphsc = max(1.e-9, alphsc)
3704 xsat = min(-1.e-9, ssatw(k))
3705 t1_evap = 2.*pi*( 1.0 - alphsc*xsat &
3706 + 2.*alphsc*alphsc*xsat*xsat &
3707 - 5.*alphsc*alphsc*alphsc*xsat*xsat*xsat ) &
3708 / (1.+gamsc)
3709
3710 lamr = 1./ilamr(k)
3712 if (qv(k)/qvs(k) .lt. 0.95 .AND. rr(k)*orho.le.1.e-8) then
3713 prv_rev(k) = rr(k)*orho*odts
3714 else
3715 prv_rev(k) = t1_evap*diffu(k)*(-ssatw(k))*n0_r(k)*rvs &
3716 * (t1_qr_ev*ilamr(k)**cre(10) &
3717 + t2_qr_ev*vsc2(k)*rhof2(k)*((lamr+0.5*fv_r)**(-cre(11))))
3718 rate_max = min((rr(k)*orho*odts), (qvs(k)-qv(k))*odts)
3719 prv_rev(k) = min(dble(rate_max), prv_rev(k)*orho)
3720
3721!..TEST: G. Thompson 10 May 2013
3728 IF (prr_gml(k).gt.0.0) THEN
3729 eva_factor = min(1.0, 0.01+(0.99-0.01)*(tempc/20.0))
3730 prv_rev(k) = prv_rev(k)*eva_factor
3731 ENDIF
3732 endif
3733
3734 pnr_rev(k) = min(dble(nr(k)*0.99*orho*odts), & ! RAIN2M
3735 prv_rev(k) * nr(k)/rr(k))
3736
3737 qrten(k) = qrten(k) - prv_rev(k)
3738 qvten(k) = qvten(k) + prv_rev(k)
3739 nrten(k) = nrten(k) - pnr_rev(k)
3740 if (is_aerosol_aware) &
3741 nwfaten(k) = nwfaten(k) + pnr_rev(k)
3742 tten(k) = tten(k) - lvap(k)*ocp(k)*prv_rev(k)*(1-ifdry)
3743
3744 rr(k) = max(r1, (qr1d(k) + dt*qrten(k))*rho(k))
3745 qv(k) = max(1.e-10, qv1d(k) + dt*qvten(k))
3746 nr(k) = max(r2, (nr1d(k) + dt*nrten(k))*rho(k))
3747 temp(k) = t1d(k) + dt*tten(k)
3748 rho(k) = 0.622*pres(k)/(r*temp(k)*(qv(k)+0.622))
3749 endif
3750 enddo
3751#if ( WRF_CHEM == 1 )
3752 do k = kts, kte
3753 evapprod(k) = prv_rev(k) - (min(zerod0,prs_sde(k)) + &
3754 min(zerod0,prg_gde(k)))
3755 rainprod(k) = prr_wau(k) + prr_rcw(k) + prs_scw(k) + &
3756 prg_scw(k) + prs_iau(k) + &
3757 prg_gcw(k) + prs_sci(k) + &
3758 pri_rci(k)
3759 enddo
3760#endif
3761
3762!+---+-----------------------------------------------------------------+
3769!+---+-----------------------------------------------------------------+
3770 nstep = 0
3771 onstep(:) = 1.0
3772 ksed1(:) = 1
3773 do k = kte+1, kts, -1
3774 vtrk(k) = 0.
3775 vtnrk(k) = 0.
3776 vtik(k) = 0.
3777 vtnik(k) = 0.
3778 vtsk(k) = 0.
3779 vtgk(k) = 0.
3780 vtck(k) = 0.
3781 vtnck(k) = 0.
3782 enddo
3783
3784 if (any(l_qr .eqv. .true.)) then
3785 do k = kte, kts, -1
3786 vtr = 0.
3787 rhof(k) = sqrt(rho_not/rho(k))
3788
3789 if (rr(k).gt. r1) then
3790 lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr
3791 vtr = rhof(k)*av_r*crg(6)*org3 * lamr**cre(3) &
3792 *((lamr+fv_r)**(-cre(6)))
3793 vtrk(k) = vtr
3794! First below is technically correct:
3795! vtr = rhof(k)*av_r*crg(5)*org2 * lamr**cre(2) &
3796! *((lamr+fv_r)**(-cre(5)))
3797! Test: make number fall faster (but still slower than mass)
3798! Goal: less prominent size sorting
3799 vtr = rhof(k)*av_r*crg(7)/crg(12) * lamr**cre(12) &
3800 *((lamr+fv_r)**(-cre(7)))
3801 vtnrk(k) = vtr
3802 else
3803 vtrk(k) = vtrk(k+1)
3804 vtnrk(k) = vtnrk(k+1)
3805 endif
3806
3807 if (max(vtrk(k),vtnrk(k)) .gt. 1.e-3) then
3808 ksed1(1) = max(ksed1(1), k)
3809 delta_tp = dzq(k)/(max(vtrk(k),vtnrk(k)))
3810 nstep = max(nstep, int(dt/delta_tp + 1.))
3811 endif
3812 enddo
3813 if (ksed1(1) .eq. kte) ksed1(1) = kte-1
3814 if (nstep .gt. 0) onstep(1) = 1./real(nstep)
3815 endif
3816
3817!+---+-----------------------------------------------------------------+
3818
3819 if (any(l_qc .eqv. .true.)) then
3820 hgt_agl = 0.
3821 do k = kts, kte-1
3822 if (rc(k) .gt. r2) ksed1(5) = k
3823 hgt_agl = hgt_agl + dzq(k)
3824 if (hgt_agl .gt. 500.0) goto 151
3825 enddo
3826 151 continue
3827
3828 do k = ksed1(5), kts, -1
3829 vtc = 0.
3830 if (rc(k) .gt. r1 .and. w1d(k) .lt. 1.e-1) then
3831 if (nc(k).gt.10000.e6) then
3832 nu_c = 2
3833 elseif (nc(k).lt.100.) then
3834 nu_c = 15
3835 else
3836 nu_c = nint(1000.e6/nc(k)) + 2
3837 nu_c = max(2, min(nu_c+nint(rand2), 15))
3838 endif
3839 lamc = (nc(k)*am_r*ccg(2,nu_c)*ocg1(nu_c)/rc(k))**obmr
3840 ilamc = 1./lamc
3841 vtc = rhof(k)*av_c*ccg(5,nu_c)*ocg2(nu_c) * ilamc**bv_c
3842 vtck(k) = vtc
3843 vtc = rhof(k)*av_c*ccg(4,nu_c)*ocg1(nu_c) * ilamc**bv_c
3844 vtnck(k) = vtc
3845 endif
3846 enddo
3847 endif
3848
3849!+---+-----------------------------------------------------------------+
3850
3851 if (.not. iiwarm) then
3852
3853 if (any(l_qi .eqv. .true.)) then
3854 nstep = 0
3855 do k = kte, kts, -1
3856 vti = 0.
3857
3858 if (ri(k).gt. r1) then
3859 lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi
3860 ilami = 1./lami
3861 vti = rhof(k)*av_i*cig(3)*oig2 * ilami**bv_i
3862 vtik(k) = vti
3863! First below is technically correct:
3864! vti = rhof(k)*av_i*cig(4)*oig1 * ilami**bv_i
3865! Goal: less prominent size sorting
3866 vti = rhof(k)*av_i*cig(6)/cig(7) * ilami**bv_i
3867 vtnik(k) = vti
3868 else
3869 vtik(k) = vtik(k+1)
3870 vtnik(k) = vtnik(k+1)
3871 endif
3872
3873 if (vtik(k) .gt. 1.e-3) then
3874 ksed1(2) = max(ksed1(2), k)
3875 delta_tp = dzq(k)/vtik(k)
3876 nstep = max(nstep, int(dt/delta_tp + 1.))
3877 endif
3878 enddo
3879 if (ksed1(2) .eq. kte) ksed1(2) = kte-1
3880 if (nstep .gt. 0) onstep(2) = 1./real(nstep)
3881 endif
3882
3883!+---+-----------------------------------------------------------------+
3884
3885 if (any(l_qs .eqv. .true.)) then
3886 nstep = 0
3887 do k = kte, kts, -1
3888 vts = 0.
3889 !vtsk1(k)=0.
3890
3891 if (rs(k).gt. r1) then
3892 xds = smoc(k) / smob(k)
3893 mrat = 1./xds
3894 ils1 = 1./(mrat*lam0 + fv_s)
3895 ils2 = 1./(mrat*lam1 + fv_s)
3896 t1_vts = kap0*csg(4)*ils1**cse(4)
3897 t2_vts = kap1*mrat**mu_s*csg(10)*ils2**cse(10)
3898 ils1 = 1./(mrat*lam0)
3899 ils2 = 1./(mrat*lam1)
3900 t3_vts = kap0*csg(1)*ils1**cse(1)
3901 t4_vts = kap1*mrat**mu_s*csg(7)*ils2**cse(7)
3902 vts = rhof(k)*av_s * (t1_vts+t2_vts)/(t3_vts+t4_vts)
3903 if (prr_sml(k) .gt. 0.0) then
3904! vtsk(k) = MAX(vts*vts_boost(k), &
3905! & vts*((vtrk(k)-vts*vts_boost(k))/(temp(k)-T_0)))
3906 sr = rs(k)/(rs(k)+rr(k))
3907 vtsk(k) = vts*sr + (1.-sr)*vtrk(k)
3908 !vtsk1(k)=vtsk(k)
3909 else
3910 vtsk(k) = vts*vts_boost(k)
3911 !vtsk1(k)=vtsk(k)
3912 endif
3913 else
3914 vtsk(k) = vtsk(k+1)
3915 !vtsk1(k)=0
3916 endif
3917
3918 if (vtsk(k) .gt. 1.e-3) then
3919 ksed1(3) = max(ksed1(3), k)
3920 delta_tp = dzq(k)/vtsk(k)
3921 nstep = max(nstep, int(dt/delta_tp + 1.))
3922 endif
3923 enddo
3924 if (ksed1(3) .eq. kte) ksed1(3) = kte-1
3925 if (nstep .gt. 0) onstep(3) = 1./real(nstep)
3926 endif
3927
3928!+---+-----------------------------------------------------------------+
3929
3930 if (any(l_qg .eqv. .true.)) then
3931 nstep = 0
3932 do k = kte, kts, -1
3933 vtg = 0.
3934
3935 if (rg(k).gt. r1) then
3936 vtg = rhof(k)*av_g*cgg(6)*ogg3 * ilamg(k)**bv_g
3937 if (temp(k).gt. t_0) then
3938 vtgk(k) = max(vtg, vtrk(k))
3939 else
3940 vtgk(k) = vtg
3941 endif
3942 else
3943 vtgk(k) = vtgk(k+1)
3944 endif
3945
3946 if (vtgk(k) .gt. 1.e-3) then
3947 ksed1(4) = max(ksed1(4), k)
3948 delta_tp = dzq(k)/vtgk(k)
3949 nstep = max(nstep, int(dt/delta_tp + 1.))
3950 endif
3951 enddo
3952 if (ksed1(4) .eq. kte) ksed1(4) = kte-1
3953 if (nstep .gt. 0) onstep(4) = 1./real(nstep)
3954 endif
3955 endif
3956
3957!+---+-----------------------------------------------------------------+
3961!+---+-----------------------------------------------------------------+
3962
3963 if (any(l_qr .eqv. .true.)) then
3964 nstep = nint(1./onstep(1))
3965
3966 if(.not. sedi_semi) then
3967 do n = 1, nstep
3968 do k = kte, kts, -1
3969 sed_r(k) = vtrk(k)*rr(k)
3970 sed_n(k) = vtnrk(k)*nr(k)
3971 enddo
3972 k = kte
3973 odzq = 1./dzq(k)
3974 orho = 1./rho(k)
3975 qrten(k) = qrten(k) - sed_r(k)*odzq*onstep(1)*orho
3976 nrten(k) = nrten(k) - sed_n(k)*odzq*onstep(1)*orho
3977 rr(k) = max(r1, rr(k) - sed_r(k)*odzq*dt*onstep(1))
3978 nr(k) = max(r2, nr(k) - sed_n(k)*odzq*dt*onstep(1))
3979 pfll1(k) = pfll1(k) + sed_r(k)*dt*onstep(1)
3980 do k = ksed1(1), kts, -1
3981 odzq = 1./dzq(k)
3982 orho = 1./rho(k)
3983 qrten(k) = qrten(k) + (sed_r(k+1)-sed_r(k)) &
3984 *odzq*onstep(1)*orho
3985 nrten(k) = nrten(k) + (sed_n(k+1)-sed_n(k)) &
3986 *odzq*onstep(1)*orho
3987 rr(k) = max(r1, rr(k) + (sed_r(k+1)-sed_r(k)) &
3988 *odzq*dt*onstep(1))
3989 nr(k) = max(r2, nr(k) + (sed_n(k+1)-sed_n(k)) &
3990 *odzq*dt*onstep(1))
3991 pfll1(k) = pfll1(k) + sed_r(k)*dt*onstep(1)
3992 enddo
3993
3994 if (rr(kts).gt.r1*1000.) &
3995 pptrain = pptrain + sed_r(kts)*dt*onstep(1)
3996 enddo
3997 else !if(.not. sedi_semi)
3998 niter = 1
3999 dtcfl = dt
4000 niter = int(nstep/max(decfl,1)) + 1
4001 dtcfl = dt/niter
4002 do n = 1, niter
4003 rr_tmp(:) = rr(:)
4004 nr_tmp(:) = nr(:)
4005 call semi_lagrange_sedim(kte,dzq,vtrk,rr,rainsfc,pfll,dtcfl,r1)
4006 call semi_lagrange_sedim(kte,dzq,vtnrk,nr,vtr,pdummy,dtcfl,r2)
4007 do k = kts, kte
4008 orhodt = 1./(rho(k)*dt)
4009 qrten(k) = qrten(k) + (rr(k) - rr_tmp(k)) * orhodt
4010 nrten(k) = nrten(k) + (nr(k) - nr_tmp(k)) * orhodt
4011 pfll1(k) = pfll1(k) + pfll(k)
4012 enddo
4013 pptrain = pptrain + rainsfc
4014
4015 do k = kte+1, kts, -1
4016 vtrk(k) = 0.
4017 vtnrk(k) = 0.
4018 enddo
4019 do k = kte, kts, -1
4020 vtr = 0.
4021 if (rr(k).gt. r1) then
4022 lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr
4023 vtr = rhof(k)*av_r*crg(6)*org3 * lamr**cre(3) &
4024 *((lamr+fv_r)**(-cre(6)))
4025 vtrk(k) = vtr
4026 ! First below is technically correct:
4027 ! vtr = rhof(k)*av_r*crg(5)*org2 * lamr**cre(2) &
4028 ! *((lamr+fv_r)**(-cre(5)))
4029 ! Test: make number fall faster (but still slower than mass)
4030 ! Goal: less prominent size sorting
4031 vtr = rhof(k)*av_r*crg(7)/crg(12) * lamr**cre(12) &
4032 *((lamr+fv_r)**(-cre(7)))
4033 vtnrk(k) = vtr
4034 endif
4035 enddo
4036 enddo
4037 endif! if(.not. sedi_semi)
4038 endif
4039
4040!+---+-----------------------------------------------------------------+
4041
4042 if (any(l_qc .eqv. .true.)) then
4043 do k = kte, kts, -1
4044 sed_c(k) = vtck(k)*rc(k)
4045 sed_n(k) = vtnck(k)*nc(k)
4046 enddo
4047 do k = ksed1(5), kts, -1
4048 odzq = 1./dzq(k)
4049 orho = 1./rho(k)
4050 qcten(k) = qcten(k) + (sed_c(k+1)-sed_c(k)) *odzq*orho
4051 ncten(k) = ncten(k) + (sed_n(k+1)-sed_n(k)) *odzq*orho
4052 rc(k) = max(r1, rc(k) + (sed_c(k+1)-sed_c(k)) *odzq*dt)
4053 nc(k) = max(10., nc(k) + (sed_n(k+1)-sed_n(k)) *odzq*dt)
4054 enddo
4055 endif
4056
4057!+---+-----------------------------------------------------------------+
4058
4059 if (any(l_qi .eqv. .true.)) then
4060 nstep = nint(1./onstep(2))
4061 do n = 1, nstep
4062 do k = kte, kts, -1
4063 sed_i(k) = vtik(k)*ri(k)
4064 sed_n(k) = vtnik(k)*ni(k)
4065 enddo
4066 k = kte
4067 odzq = 1./dzq(k)
4068 orho = 1./rho(k)
4069 qiten(k) = qiten(k) - sed_i(k)*odzq*onstep(2)*orho
4070 niten(k) = niten(k) - sed_n(k)*odzq*onstep(2)*orho
4071 ri(k) = max(r1, ri(k) - sed_i(k)*odzq*dt*onstep(2))
4072 ni(k) = max(r2, ni(k) - sed_n(k)*odzq*dt*onstep(2))
4073 pfil1(k) = pfil1(k) + sed_i(k)*dt*onstep(2)
4074 do k = ksed1(2), kts, -1
4075 odzq = 1./dzq(k)
4076 orho = 1./rho(k)
4077 qiten(k) = qiten(k) + (sed_i(k+1)-sed_i(k)) &
4078 *odzq*onstep(2)*orho
4079 niten(k) = niten(k) + (sed_n(k+1)-sed_n(k)) &
4080 *odzq*onstep(2)*orho
4081 ri(k) = max(r1, ri(k) + (sed_i(k+1)-sed_i(k)) &
4082 *odzq*dt*onstep(2))
4083 ni(k) = max(r2, ni(k) + (sed_n(k+1)-sed_n(k)) &
4084 *odzq*dt*onstep(2))
4085 pfil1(k) = pfil1(k) + sed_i(k)*dt*onstep(2)
4086 enddo
4087
4088 if (ri(kts).gt.r1*1000.) &
4089 pptice = pptice + sed_i(kts)*dt*onstep(2)
4090 enddo
4091 endif
4092
4093!+---+-----------------------------------------------------------------+
4094
4095 if (any(l_qs .eqv. .true.)) then
4096 nstep = nint(1./onstep(3))
4097 do n = 1, nstep
4098 do k = kte, kts, -1
4099 sed_s(k) = vtsk(k)*rs(k)
4100 enddo
4101 k = kte
4102 odzq = 1./dzq(k)
4103 orho = 1./rho(k)
4104 qsten(k) = qsten(k) - sed_s(k)*odzq*onstep(3)*orho
4105 rs(k) = max(r1, rs(k) - sed_s(k)*odzq*dt*onstep(3))
4106 pfil1(k) = pfil1(k) + sed_s(k)*dt*onstep(3)
4107 do k = ksed1(3), kts, -1
4108 odzq = 1./dzq(k)
4109 orho = 1./rho(k)
4110 qsten(k) = qsten(k) + (sed_s(k+1)-sed_s(k)) &
4111 *odzq*onstep(3)*orho
4112 rs(k) = max(r1, rs(k) + (sed_s(k+1)-sed_s(k)) &
4113 *odzq*dt*onstep(3))
4114 pfil1(k) = pfil1(k) + sed_s(k)*dt*onstep(3)
4115 enddo
4116
4117 if (rs(kts).gt.r1*1000.) &
4118 pptsnow = pptsnow + sed_s(kts)*dt*onstep(3)
4119 enddo
4120 endif
4121
4122!+---+-----------------------------------------------------------------+
4123
4124 if (any(l_qg .eqv. .true.)) then
4125 nstep = nint(1./onstep(4))
4126 if(.not. sedi_semi) then
4127 do n = 1, nstep
4128 do k = kte, kts, -1
4129 sed_g(k) = vtgk(k)*rg(k)
4130 enddo
4131 k = kte
4132 odzq = 1./dzq(k)
4133 orho = 1./rho(k)
4134 qgten(k) = qgten(k) - sed_g(k)*odzq*onstep(4)*orho
4135 rg(k) = max(r1, rg(k) - sed_g(k)*odzq*dt*onstep(4))
4136 pfil1(k) = pfil1(k) + sed_g(k)*dt*onstep(4)
4137 do k = ksed1(4), kts, -1
4138 odzq = 1./dzq(k)
4139 orho = 1./rho(k)
4140 qgten(k) = qgten(k) + (sed_g(k+1)-sed_g(k)) &
4141 *odzq*onstep(4)*orho
4142 rg(k) = max(r1, rg(k) + (sed_g(k+1)-sed_g(k)) &
4143 *odzq*dt*onstep(4))
4144 pfil1(k) = pfil1(k) + sed_g(k)*dt*onstep(4)
4145 enddo
4146
4147 if (rg(kts).gt.r1*1000.) &
4148 pptgraul = pptgraul + sed_g(kts)*dt*onstep(4)
4149 enddo
4150 else ! if(.not. sedi_semi) then
4151 niter = 1
4152 dtcfl = dt
4153 niter = int(nstep/max(decfl,1)) + 1
4154 dtcfl = dt/niter
4155
4156 do n = 1, niter
4157 rg_tmp(:) = rg(:)
4158 call semi_lagrange_sedim(kte,dzq,vtgk,rg,graulsfc,pfil,dtcfl,r1)
4159 do k = kts, kte
4160 orhodt = 1./(rho(k)*dt)
4161 qgten(k) = qgten(k) + (rg(k) - rg_tmp(k))*orhodt
4162 pfil1(k) = pfil1(k) + pfil(k)
4163 enddo
4164 pptgraul = pptgraul + graulsfc
4165 do k = kte+1, kts, -1
4166 vtgk(k) = 0.
4167 enddo
4168 do k = kte, kts, -1
4169 vtg = 0.
4170 if (rg(k).gt. r1) then
4171 ygra1 = alog10(max(1.e-9, rg(k)))
4172 zans1 = 3.4 + 2./7.*(ygra1+8.) + rand1
4173 n0_exp = 10.**(zans1)
4174 n0_exp = max(dble(gonv_min), min(n0_exp, dble(gonv_max)))
4175 lam_exp = (n0_exp*am_g*cgg(1)/rg(k))**oge1
4176 lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg
4177
4178 vtg = rhof(k)*av_g*cgg(6)*ogg3 * (1./lamg)**bv_g
4179 if (temp(k).gt. t_0) then
4180 vtgk(k) = max(vtg, vtrk(k))
4181 else
4182 vtgk(k) = vtg
4183 endif
4184 endif
4185 enddo
4186 enddo
4187 endif ! if(.not. sedi_semi) then
4188 endif
4189
4190!+---+-----------------------------------------------------------------+
4193!+---+-----------------------------------------------------------------+
4194 if (.not. iiwarm) then
4195 do k = kts, kte
4196 xri = max(0.0, qi1d(k) + qiten(k)*dt)
4197 if ( (temp(k).gt. t_0) .and. (xri.gt. 0.0) ) then
4198 qcten(k) = qcten(k) + xri*odt
4199 ncten(k) = ncten(k) + ni1d(k)*odt
4200 qiten(k) = qiten(k) - xri*odt
4201 niten(k) = -ni1d(k)*odt
4202 tten(k) = tten(k) - lfus*ocp(k)*xri*odt*(1-ifdry)
4203!diag
4204 !txri1(k) = lfus*ocp(k)*xri*odt*(1-IFDRY)
4205 endif
4206
4207 xrc = max(0.0, qc1d(k) + qcten(k)*dt)
4208 if ( (temp(k).lt. hgfr) .and. (xrc.gt. 0.0) ) then
4209 lfus2 = lsub - lvap(k)
4210 xnc = nc1d(k) + ncten(k)*dt
4211 qiten(k) = qiten(k) + xrc*odt
4212 niten(k) = niten(k) + xnc*odt
4213 qcten(k) = qcten(k) - xrc*odt
4214 ncten(k) = ncten(k) - xnc*odt
4215 tten(k) = tten(k) + lfus2*ocp(k)*xrc*odt*(1-ifdry)
4216!diag
4217 !txrc1(k) = lfus2*ocp(k)*xrc*odt*(1-IFDRY)*DT
4218 endif
4219 enddo
4220 endif
4221
4222!+---+-----------------------------------------------------------------+
4224!+---+-----------------------------------------------------------------+
4225 do k = kts, kte
4226 t1d(k) = t1d(k) + tten(k)*dt
4227 qv1d(k) = max(1.e-10, qv1d(k) + qvten(k)*dt)
4228 qc1d(k) = qc1d(k) + qcten(k)*dt
4229 nc1d(k) = max(2./rho(k), min(nc1d(k) + ncten(k)*dt, nt_c_max))
4230 if (is_aerosol_aware) then
4231 nwfa1d(k) = max(11.1e6, min(9999.e6, &
4232 (nwfa1d(k)+nwfaten(k)*dt)))
4233 nifa1d(k) = max(nain1*0.01, min(9999.e6, &
4234 (nifa1d(k)+nifaten(k)*dt)))
4235 end if
4236 if (qc1d(k) .le. r1) then
4237 qc1d(k) = 0.0
4238 nc1d(k) = 0.0
4239 else
4240 if (nc1d(k)*rho(k).gt.10000.e6) then
4241 nu_c = 2
4242 elseif (nc1d(k)*rho(k).lt.100.) then
4243 nu_c = 15
4244 else
4245 nu_c = nint(1000.e6/(nc1d(k)*rho(k))) + 2
4246 nu_c = max(2, min(nu_c+nint(rand2), 15))
4247 endif
4248 lamc = (am_r*ccg(2,nu_c)*ocg1(nu_c)*nc1d(k)/qc1d(k))**obmr
4249 xdc = (bm_r + nu_c + 1.) / lamc
4250 if (xdc.lt. d0c) then
4251 lamc = cce(2,nu_c)/d0c
4252 elseif (xdc.gt. d0r*2.) then
4253 lamc = cce(2,nu_c)/(d0r*2.)
4254 endif
4255 nc1d(k) = min(ccg(1,nu_c)*ocg2(nu_c)*qc1d(k)/am_r*lamc**bm_r,&
4256 dble(nt_c_max)/rho(k))
4257 endif
4258
4259 qi1d(k) = qi1d(k) + qiten(k)*dt
4260 ni1d(k) = max(r2/rho(k), ni1d(k) + niten(k)*dt)
4261 if (qi1d(k) .le. r1) then
4262 qi1d(k) = 0.0
4263 ni1d(k) = 0.0
4264 else
4265 lami = (am_i*cig(2)*oig1*ni1d(k)/qi1d(k))**obmi
4266 ilami = 1./lami
4267 xdi = (bm_i + mu_i + 1.) * ilami
4268 if (xdi.lt. 5.e-6) then
4269 lami = cie(2)/5.e-6
4270 elseif (xdi.gt. 300.e-6) then
4271 lami = cie(2)/300.e-6
4272 endif
4273 ni1d(k) = min(cig(1)*oig2*qi1d(k)/am_i*lami**bm_i, &
4274 4999.d3/rho(k))
4275 endif
4276 qr1d(k) = qr1d(k) + qrten(k)*dt
4277 nr1d(k) = max(r2/rho(k), nr1d(k) + nrten(k)*dt)
4278 if (qr1d(k) .le. r1) then
4279 qr1d(k) = 0.0
4280 nr1d(k) = 0.0
4281 else
4282 lamr = (am_r*crg(3)*org2*nr1d(k)/qr1d(k))**obmr
4283 mvd_r(k) = (3.0 + mu_r + 0.672) / lamr
4284 if (mvd_r(k) .gt. 2.5e-3) then
4285 mvd_r(k) = 2.5e-3
4286 elseif (mvd_r(k) .lt. d0r*0.75) then
4287 mvd_r(k) = d0r*0.75
4288 endif
4289 lamr = (3.0 + mu_r + 0.672) / mvd_r(k)
4290 nr1d(k) = crg(2)*org3*qr1d(k)*lamr**bm_r / am_r
4291 endif
4292 qs1d(k) = qs1d(k) + qsten(k)*dt
4293 if (qs1d(k) .le. r1) qs1d(k) = 0.0
4294 qg1d(k) = qg1d(k) + qgten(k)*dt
4295 if (qg1d(k) .le. r1) qg1d(k) = 0.0
4296 enddo
4297
4298! Diagnostics
4299 calculate_extended_diagnostics: if (ext_diag) then
4300 do k = kts, kte
4301 if(prw_vcd(k).gt.0)then
4302 prw_vcdc1(k) = prw_vcd(k)*dt
4303 elseif(prw_vcd(k).lt.0)then
4304 prw_vcde1(k) = -1*prw_vcd(k)*dt
4305 endif
4306!heating/cooling diagnostics
4307 tpri_inu1(k) = pri_inu(k)*lsub*ocp(k)*orho * (1-ifdry)*dt
4308
4309 if(pri_ide(k).gt.0)then
4310 tpri_ide1_d(k) = pri_ide(k)*lsub*ocp(k)*orho * (1-ifdry)*dt
4311 else
4312 tpri_ide1_s(k) = -pri_ide(k)*lsub*ocp(k)*orho * (1-ifdry)*dt
4313 endif
4314
4315 if(temp(k).lt.t_0)then
4316 tprs_ide1(k) = prs_ide(k)*lsub*ocp(k)*orho * (1-ifdry)*dt
4317 endif
4318
4319 if(prs_sde(k).gt.0)then
4320 tprs_sde1_d(k) = prs_sde(k)*lsub*ocp(k)*orho * (1-ifdry)*dt
4321 else
4322 tprs_sde1_s(k) = -prs_sde(k)*lsub*ocp(k)*orho * (1-ifdry)*dt
4323 endif
4324
4325 if(prg_gde(k).gt.0)then
4326 tprg_gde1_d(k) = prg_gde(k)*lsub*ocp(k)*orho * (1-ifdry)*dt
4327 else
4328 tprg_gde1_s(k) = -prg_gde(k)*lsub*ocp(k)*orho * (1-ifdry)*dt
4329 endif
4330
4331 tpri_iha1(k) = pri_iha(k)*lsub*ocp(k)*orho * (1-ifdry)*dt
4332 tpri_wfz1(k) = pri_wfz(k)*lfus2*ocp(k)*orho * (1-ifdry)*dt
4333 tpri_rfz1(k) = pri_rfz(k)*lfus2*ocp(k)*orho * (1-ifdry)*dt
4334 tprg_rfz1(k) = prg_rfz(k)*lfus2*ocp(k)*orho * (1-ifdry)*dt
4335 tprs_scw1(k) = prs_scw(k)*lfus2*ocp(k)*orho * (1-ifdry)*dt
4336 tprg_scw1(k) = prg_scw(k)*lfus2*ocp(k)*orho * (1-ifdry)*dt
4337 tprg_rcs1(k) = prg_rcs(k)*lfus2*ocp(k)*orho * (1-ifdry)*dt
4338
4339 if(temp(k).lt.t_0)then
4340 tprs_rcs1(k) = prs_rcs(k)*lfus2*ocp(k)*orho * (1-ifdry)*dt
4341 endif
4342
4343 tprr_rci1(k) = prr_rci(k)*lfus2*ocp(k)*orho * (1-ifdry)*dt
4344
4345 if(temp(k).lt.t_0)then
4346 tprg_rcg1(k) = prg_rcg(k)*lfus2*ocp(k)*orho * (1-ifdry)*dt
4347 endif
4348
4349 if(prw_vcd(k).gt.0)then
4350 tprw_vcd1_c(k) = lvap(k)*ocp(k)*prw_vcd(k)*(1-ifdry)*dt
4351 else
4352 tprw_vcd1_e(k) = -lvap(k)*ocp(k)*prw_vcd(k)*(1-ifdry)*dt
4353 endif
4354
4355! cooling terms
4356 tprr_sml1(k) = prr_sml(k)*lfus*ocp(k)*orho * (1-ifdry)*dt
4357 tprr_gml1(k) = prr_gml(k)*lfus*ocp(k)*orho * (1-ifdry)*dt
4358
4359 if(temp(k).ge.t_0)then
4360 tprr_rcg1(k) = -prr_rcg(k)*lfus*ocp(k)*orho * (1-ifdry)*dt
4361 endif
4362
4363 if(temp(k).ge.t_0)then
4364 tprr_rcs1(k) = -prr_rcs(k)*lfus*ocp(k)*orho * (1-ifdry)*dt
4365 endif
4366
4367 tprv_rev1(k) = lvap(k)*ocp(k)*prv_rev(k)*(1-ifdry)*dt
4368 tten1(k) = tten(k)*dt
4369 qvten1(k) = qvten(k)*dt
4370 qiten1(k) = qiten(k)*dt
4371 qrten1(k) = qrten(k)*dt
4372 qsten1(k) = qsten(k)*dt
4373 qgten1(k) = qgten(k)*dt
4374 niten1(k) = niten(k)*dt
4375 nrten1(k) = nrten(k)*dt
4376 ncten1(k) = ncten(k)*dt
4377 qcten1(k) = qcten(k)*dt
4378 enddo
4379 endif calculate_extended_diagnostics
4380
4381 end subroutine mp_thompson
4383
4384!+---+-----------------------------------------------------------------+
4385!ctrlL
4386!+---+-----------------------------------------------------------------+
4387!..Creation of the lookup tables and support functions found below here.
4388!+---+-----------------------------------------------------------------+
4391 subroutine qr_acr_qg
4392
4393 implicit none
4394
4395!..Local variables
4396 INTEGER:: i, j, k, m, n, n2
4397 INTEGER:: km, km_s, km_e
4398 DOUBLE PRECISION, DIMENSION(nbg):: vg, N_g
4399 DOUBLE PRECISION, DIMENSION(nbr):: vr, N_r
4400 DOUBLE PRECISION:: N0_r, N0_g, lam_exp, lamg, lamr
4401 DOUBLE PRECISION:: massg, massr, dvg, dvr, t1, t2, z1, z2, y1, y2
4402 LOGICAL force_read_thompson, write_thompson_tables
4403 LOGICAL lexist,lopen
4404 INTEGER good,ierr
4405
4406 force_read_thompson = .false.
4407 write_thompson_tables = .false.
4408!+---+
4409
4410
4411 good = 0
4412 INQUIRE(file=qr_acr_qg_file, exist=lexist)
4413#ifdef MPI
4414 call mpi_barrier(mpi_communicator,ierr)
4415#endif
4416 IF ( lexist ) THEN
4417 OPEN(63,file=qr_acr_qg_file,form="unformatted",err=1234)
4418!sms$serial begin
4419 READ(63,err=1234) tcg_racg
4420 READ(63,err=1234) tmr_racg
4421 READ(63,err=1234) tcr_gacr
4422 READ(63,err=1234) tmg_gacr
4423 READ(63,err=1234) tnr_racg
4424 READ(63,err=1234) tnr_gacr
4425!sms$serial end
4426 good = 1
4427 1234 CONTINUE
4428 IF ( good .NE. 1 ) THEN
4429 INQUIRE(63,opened=lopen)
4430 IF (lopen) THEN
4431 IF( force_read_thompson ) THEN
4432 write(0,*) "Error reading "//qr_acr_qg_file//" Aborting because force_read_thompson is .true."
4433 return
4434 ENDIF
4435 CLOSE(63)
4436 ELSE
4437 IF( force_read_thompson ) THEN
4438 write(0,*) "Error opening "//qr_acr_qg_file//" Aborting because force_read_thompson is .true."
4439 return
4440 ENDIF
4441 ENDIF
4442 ELSE
4443 INQUIRE(63,opened=lopen)
4444 IF (lopen) THEN
4445 CLOSE(63)
4446 ENDIF
4447 ENDIF
4448 ELSE
4449 IF( force_read_thompson ) THEN
4450 write(0,*) "Non-existent "//qr_acr_qg_file//" Aborting because force_read_thompson is .true."
4451 return
4452 ENDIF
4453 ENDIF
4454
4455 IF (.NOT. good .EQ. 1 ) THEN
4456 if (thompson_table_writer) then
4457 write_thompson_tables = .true.
4458 write(0,*) "ThompMP: computing qr_acr_qg"
4459 endif
4460 do n2 = 1, nbr
4461! vr(n2) = av_r*Dr(n2)**bv_r * DEXP(-fv_r*Dr(n2))
4462 vr(n2) = -0.1021 + 4.932e3*dr(n2) - 0.9551e6*dr(n2)*dr(n2) &
4463 + 0.07934e9*dr(n2)*dr(n2)*dr(n2) &
4464 - 0.002362e12*dr(n2)*dr(n2)*dr(n2)*dr(n2)
4465 enddo
4466 do n = 1, nbg
4467 vg(n) = av_g*dg(n)**bv_g
4468 enddo
4469
4470!..Note values returned from wrf_dm_decomp1d are zero-based, add 1 for
4471!.. fortran indices. J. Michalakes, 2009Oct30.
4472
4473#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
4474 CALL wrf_dm_decomp1d ( ntb_r*ntb_r1, km_s, km_e )
4475#else
4476 km_s = 0
4477 km_e = ntb_r*ntb_r1 - 1
4478#endif
4479
4480 do km = km_s, km_e
4481 m = km / ntb_r1 + 1
4482 k = mod( km , ntb_r1 ) + 1
4483
4484 lam_exp = (n0r_exp(k)*am_r*crg(1)/r_r(m))**ore1
4485 lamr = lam_exp * (crg(3)*org2*org1)**obmr
4486 n0_r = n0r_exp(k)/(crg(2)*lam_exp) * lamr**cre(2)
4487 do n2 = 1, nbr
4488 n_r(n2) = n0_r*dr(n2)**mu_r *dexp(-lamr*dr(n2))*dtr(n2)
4489 enddo
4490
4491 do j = 1, ntb_g
4492 do i = 1, ntb_g1
4493 lam_exp = (n0g_exp(i)*am_g*cgg(1)/r_g(j))**oge1
4494 lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg
4495 n0_g = n0g_exp(i)/(cgg(2)*lam_exp) * lamg**cge(2)
4496 do n = 1, nbg
4497 n_g(n) = n0_g*dg(n)**mu_g * dexp(-lamg*dg(n))*dtg(n)
4498 enddo
4499
4500 t1 = 0.0d0
4501 t2 = 0.0d0
4502 z1 = 0.0d0
4503 z2 = 0.0d0
4504 y1 = 0.0d0
4505 y2 = 0.0d0
4506 do n2 = 1, nbr
4507 massr = am_r * dr(n2)**bm_r
4508 do n = 1, nbg
4509 massg = am_g * dg(n)**bm_g
4510
4511 dvg = 0.5d0*((vr(n2) - vg(n)) + dabs(vr(n2)-vg(n)))
4512 dvr = 0.5d0*((vg(n) - vr(n2)) + dabs(vg(n)-vr(n2)))
4513
4514 t1 = t1+ pi*.25*ef_rg*(dg(n)+dr(n2))*(dg(n)+dr(n2)) &
4515 *dvg*massg * n_g(n)* n_r(n2)
4516 z1 = z1+ pi*.25*ef_rg*(dg(n)+dr(n2))*(dg(n)+dr(n2)) &
4517 *dvg*massr * n_g(n)* n_r(n2)
4518 y1 = y1+ pi*.25*ef_rg*(dg(n)+dr(n2))*(dg(n)+dr(n2)) &
4519 *dvg * n_g(n)* n_r(n2)
4520
4521 t2 = t2+ pi*.25*ef_rg*(dg(n)+dr(n2))*(dg(n)+dr(n2)) &
4522 *dvr*massr * n_g(n)* n_r(n2)
4523 y2 = y2+ pi*.25*ef_rg*(dg(n)+dr(n2))*(dg(n)+dr(n2)) &
4524 *dvr * n_g(n)* n_r(n2)
4525 z2 = z2+ pi*.25*ef_rg*(dg(n)+dr(n2))*(dg(n)+dr(n2)) &
4526 *dvr*massg * n_g(n)* n_r(n2)
4527 enddo
4528 97 continue
4529 enddo
4530 tcg_racg(i,j,k,m) = t1
4531 tmr_racg(i,j,k,m) = dmin1(z1, r_r(m)*1.0d0)
4532 tcr_gacr(i,j,k,m) = t2
4533 tmg_gacr(i,j,k,m) = dmin1(z2, r_g(j)*1.0d0)
4534 tnr_racg(i,j,k,m) = y1
4535 tnr_gacr(i,j,k,m) = y2
4536 enddo
4537 enddo
4538 enddo
4539
4540 IF ( write_thompson_tables ) THEN
4541 write(0,*) "Writing "//qr_acr_qg_file//" in Thompson MP init"
4542 OPEN(63,file=qr_acr_qg_file,form="unformatted",err=9234)
4543 WRITE(63,err=9234) tcg_racg
4544 WRITE(63,err=9234) tmr_racg
4545 WRITE(63,err=9234) tcr_gacr
4546 WRITE(63,err=9234) tmg_gacr
4547 WRITE(63,err=9234) tnr_racg
4548 WRITE(63,err=9234) tnr_gacr
4549 CLOSE(63)
4550 RETURN ! ----- RETURN
4551 9234 CONTINUE
4552 write(0,*) "Error writing "//qr_acr_qg_file
4553 return
4554 ENDIF
4555 ENDIF
4556
4557 end subroutine qr_acr_qg
4558!+---+-----------------------------------------------------------------+
4559!ctrlL
4560!+---+-----------------------------------------------------------------+
4563 subroutine qr_acr_qs
4564
4565 implicit none
4566
4567!..Local variables
4568 INTEGER:: i, j, k, m, n, n2
4569 INTEGER:: km, km_s, km_e
4570 DOUBLE PRECISION, DIMENSION(nbr):: vr, D1, N_r
4571 DOUBLE PRECISION, DIMENSION(nbs):: vs, N_s
4572 DOUBLE PRECISION:: loga_, a_, b_, second, M0, M2, M3, Mrat, oM3
4573 DOUBLE PRECISION:: N0_r, lam_exp, lamr, slam1, slam2
4574 DOUBLE PRECISION:: dvs, dvr, masss, massr
4575 DOUBLE PRECISION:: t1, t2, t3, t4, z1, z2, z3, z4
4576 DOUBLE PRECISION:: y1, y2, y3, y4
4577 LOGICAL force_read_thompson, write_thompson_tables
4578 LOGICAL lexist,lopen
4579 INTEGER good,ierr
4580
4581!+---+
4582
4583 force_read_thompson = .false.
4584 write_thompson_tables = .false.
4585
4586 good = 0
4587 INQUIRE(file=qr_acr_qs_file, exist=lexist)
4588#ifdef MPI
4589 call mpi_barrier(mpi_communicator,ierr)
4590#endif
4591 IF ( lexist ) THEN
4592 !write(0,*) "ThompMP: read "//qr_acr_qs_file//" instead of computing"
4593 OPEN(63,file=qr_acr_qs_file,form="unformatted",err=1234)
4594!sms$serial begin
4595 READ(63,err=1234)tcs_racs1
4596 READ(63,err=1234)tmr_racs1
4597 READ(63,err=1234)tcs_racs2
4598 READ(63,err=1234)tmr_racs2
4599 READ(63,err=1234)tcr_sacr1
4600 READ(63,err=1234)tms_sacr1
4601 READ(63,err=1234)tcr_sacr2
4602 READ(63,err=1234)tms_sacr2
4603 READ(63,err=1234)tnr_racs1
4604 READ(63,err=1234)tnr_racs2
4605 READ(63,err=1234)tnr_sacr1
4606 READ(63,err=1234)tnr_sacr2
4607!sms$serial end
4608 good = 1
4609 1234 CONTINUE
4610 IF ( good .NE. 1 ) THEN
4611 INQUIRE(63,opened=lopen)
4612 IF (lopen) THEN
4613 IF( force_read_thompson ) THEN
4614 write(0,*) "Error reading "//qr_acr_qs_file//" Aborting because force_read_thompson is .true."
4615 return
4616 ENDIF
4617 CLOSE(63)
4618 ELSE
4619 IF( force_read_thompson ) THEN
4620 write(0,*) "Error opening "//qr_acr_qs_file//" Aborting because force_read_thompson is .true."
4621 return
4622 ENDIF
4623 ENDIF
4624 ELSE
4625 INQUIRE(63,opened=lopen)
4626 IF (lopen) THEN
4627 CLOSE(63)
4628 ENDIF
4629 ENDIF
4630 ELSE
4631 IF( force_read_thompson ) THEN
4632 write(0,*) "Non-existent "//qr_acr_qs_file//" Aborting because force_read_thompson is .true."
4633 return
4634 ENDIF
4635 ENDIF
4636
4637 IF (.NOT. good .EQ. 1 ) THEN
4638 if (thompson_table_writer) then
4639 write_thompson_tables = .true.
4640 write(0,*) "ThompMP: computing qr_acr_qs"
4641 endif
4642 do n2 = 1, nbr
4643! vr(n2) = av_r*Dr(n2)**bv_r * DEXP(-fv_r*Dr(n2))
4644 vr(n2) = -0.1021 + 4.932e3*dr(n2) - 0.9551e6*dr(n2)*dr(n2) &
4645 + 0.07934e9*dr(n2)*dr(n2)*dr(n2) &
4646 - 0.002362e12*dr(n2)*dr(n2)*dr(n2)*dr(n2)
4647 d1(n2) = (vr(n2)/av_s)**(1./bv_s)
4648 enddo
4649 do n = 1, nbs
4650 vs(n) = 1.5*av_s*ds(n)**bv_s * dexp(-fv_s*ds(n))
4651 enddo
4652
4653!..Note values returned from wrf_dm_decomp1d are zero-based, add 1 for
4654!.. fortran indices. J. Michalakes, 2009Oct30.
4655
4656#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
4657 CALL wrf_dm_decomp1d ( ntb_r*ntb_r1, km_s, km_e )
4658#else
4659 km_s = 0
4660 km_e = ntb_r*ntb_r1 - 1
4661#endif
4662
4663 do km = km_s, km_e
4664 m = km / ntb_r1 + 1
4665 k = mod( km , ntb_r1 ) + 1
4666
4667 lam_exp = (n0r_exp(k)*am_r*crg(1)/r_r(m))**ore1
4668 lamr = lam_exp * (crg(3)*org2*org1)**obmr
4669 n0_r = n0r_exp(k)/(crg(2)*lam_exp) * lamr**cre(2)
4670 do n2 = 1, nbr
4671 n_r(n2) = n0_r*dr(n2)**mu_r * dexp(-lamr*dr(n2))*dtr(n2)
4672 enddo
4673
4674 do j = 1, ntb_t
4675 do i = 1, ntb_s
4676
4677!..From the bm_s moment, compute plus one moment. If we are not
4678!.. using bm_s=2, then we must transform to the pure 2nd moment
4679!.. (variable called "second") and then to the bm_s+1 moment.
4680
4681 m2 = r_s(i)*oams *1.0d0
4682 if (bm_s.gt.2.0-1.e-3 .and. bm_s.lt.2.0+1.e-3) then
4683 loga_ = sa(1) + sa(2)*tc(j) + sa(3)*bm_s &
4684 + sa(4)*tc(j)*bm_s + sa(5)*tc(j)*tc(j) &
4685 + sa(6)*bm_s*bm_s + sa(7)*tc(j)*tc(j)*bm_s &
4686 + sa(8)*tc(j)*bm_s*bm_s + sa(9)*tc(j)*tc(j)*tc(j) &
4687 + sa(10)*bm_s*bm_s*bm_s
4688 a_ = 10.0**loga_
4689 b_ = sb(1) + sb(2)*tc(j) + sb(3)*bm_s &
4690 + sb(4)*tc(j)*bm_s + sb(5)*tc(j)*tc(j) &
4691 + sb(6)*bm_s*bm_s + sb(7)*tc(j)*tc(j)*bm_s &
4692 + sb(8)*tc(j)*bm_s*bm_s + sb(9)*tc(j)*tc(j)*tc(j) &
4693 + sb(10)*bm_s*bm_s*bm_s
4694 second = (m2/a_)**(1./b_)
4695 else
4696 second = m2
4697 endif
4698
4699 loga_ = sa(1) + sa(2)*tc(j) + sa(3)*cse(1) &
4700 + sa(4)*tc(j)*cse(1) + sa(5)*tc(j)*tc(j) &
4701 + sa(6)*cse(1)*cse(1) + sa(7)*tc(j)*tc(j)*cse(1) &
4702 + sa(8)*tc(j)*cse(1)*cse(1) + sa(9)*tc(j)*tc(j)*tc(j) &
4703 + sa(10)*cse(1)*cse(1)*cse(1)
4704 a_ = 10.0**loga_
4705 b_ = sb(1)+sb(2)*tc(j)+sb(3)*cse(1) + sb(4)*tc(j)*cse(1) &
4706 + sb(5)*tc(j)*tc(j) + sb(6)*cse(1)*cse(1) &
4707 + sb(7)*tc(j)*tc(j)*cse(1) + sb(8)*tc(j)*cse(1)*cse(1) &
4708 + sb(9)*tc(j)*tc(j)*tc(j)+sb(10)*cse(1)*cse(1)*cse(1)
4709 m3 = a_ * second**b_
4710
4711 om3 = 1./m3
4712 mrat = m2*(m2*om3)*(m2*om3)*(m2*om3)
4713 m0 = (m2*om3)**mu_s
4714 slam1 = m2 * om3 * lam0
4715 slam2 = m2 * om3 * lam1
4716
4717 do n = 1, nbs
4718 n_s(n) = mrat*(kap0*dexp(-slam1*ds(n)) &
4719 + kap1*m0*ds(n)**mu_s * dexp(-slam2*ds(n)))*dts(n)
4720 enddo
4721
4722 t1 = 0.0d0
4723 t2 = 0.0d0
4724 t3 = 0.0d0
4725 t4 = 0.0d0
4726 z1 = 0.0d0
4727 z2 = 0.0d0
4728 z3 = 0.0d0
4729 z4 = 0.0d0
4730 y1 = 0.0d0
4731 y2 = 0.0d0
4732 y3 = 0.0d0
4733 y4 = 0.0d0
4734 do n2 = 1, nbr
4735 massr = am_r * dr(n2)**bm_r
4736 do n = 1, nbs
4737 masss = am_s * ds(n)**bm_s
4738
4739 dvs = 0.5d0*((vr(n2) - vs(n)) + dabs(vr(n2)-vs(n)))
4740 dvr = 0.5d0*((vs(n) - vr(n2)) + dabs(vs(n)-vr(n2)))
4741
4742 if (massr .gt. 1.5*masss) then
4743 t1 = t1+ pi*.25*ef_rs*(ds(n)+dr(n2))*(ds(n)+dr(n2)) &
4744 *dvs*masss * n_s(n)* n_r(n2)
4745 z1 = z1+ pi*.25*ef_rs*(ds(n)+dr(n2))*(ds(n)+dr(n2)) &
4746 *dvs*massr * n_s(n)* n_r(n2)
4747 y1 = y1+ pi*.25*ef_rs*(ds(n)+dr(n2))*(ds(n)+dr(n2)) &
4748 *dvs * n_s(n)* n_r(n2)
4749 else
4750 t3 = t3+ pi*.25*ef_rs*(ds(n)+dr(n2))*(ds(n)+dr(n2)) &
4751 *dvs*masss * n_s(n)* n_r(n2)
4752 z3 = z3+ pi*.25*ef_rs*(ds(n)+dr(n2))*(ds(n)+dr(n2)) &
4753 *dvs*massr * n_s(n)* n_r(n2)
4754 y3 = y3+ pi*.25*ef_rs*(ds(n)+dr(n2))*(ds(n)+dr(n2)) &
4755 *dvs * n_s(n)* n_r(n2)
4756 endif
4757
4758 if (massr .gt. 1.5*masss) then
4759 t2 = t2+ pi*.25*ef_rs*(ds(n)+dr(n2))*(ds(n)+dr(n2)) &
4760 *dvr*massr * n_s(n)* n_r(n2)
4761 y2 = y2+ pi*.25*ef_rs*(ds(n)+dr(n2))*(ds(n)+dr(n2)) &
4762 *dvr * n_s(n)* n_r(n2)
4763 z2 = z2+ pi*.25*ef_rs*(ds(n)+dr(n2))*(ds(n)+dr(n2)) &
4764 *dvr*masss * n_s(n)* n_r(n2)
4765 else
4766 t4 = t4+ pi*.25*ef_rs*(ds(n)+dr(n2))*(ds(n)+dr(n2)) &
4767 *dvr*massr * n_s(n)* n_r(n2)
4768 y4 = y4+ pi*.25*ef_rs*(ds(n)+dr(n2))*(ds(n)+dr(n2)) &
4769 *dvr * n_s(n)* n_r(n2)
4770 z4 = z4+ pi*.25*ef_rs*(ds(n)+dr(n2))*(ds(n)+dr(n2)) &
4771 *dvr*masss * n_s(n)* n_r(n2)
4772 endif
4773
4774 enddo
4775 enddo
4776 tcs_racs1(i,j,k,m) = t1
4777 tmr_racs1(i,j,k,m) = dmin1(z1, r_r(m)*1.0d0)
4778 tcs_racs2(i,j,k,m) = t3
4779 tmr_racs2(i,j,k,m) = z3
4780 tcr_sacr1(i,j,k,m) = t2
4781 tms_sacr1(i,j,k,m) = z2
4782 tcr_sacr2(i,j,k,m) = t4
4783 tms_sacr2(i,j,k,m) = z4
4784 tnr_racs1(i,j,k,m) = y1
4785 tnr_racs2(i,j,k,m) = y3
4786 tnr_sacr1(i,j,k,m) = y2
4787 tnr_sacr2(i,j,k,m) = y4
4788 enddo
4789 enddo
4790 enddo
4791
4792 IF ( write_thompson_tables ) THEN
4793 write(0,*) "Writing "//qr_acr_qs_file//" in Thompson MP init"
4794 OPEN(63,file=qr_acr_qs_file,form="unformatted",err=9234)
4795 WRITE(63,err=9234)tcs_racs1
4796 WRITE(63,err=9234)tmr_racs1
4797 WRITE(63,err=9234)tcs_racs2
4798 WRITE(63,err=9234)tmr_racs2
4799 WRITE(63,err=9234)tcr_sacr1
4800 WRITE(63,err=9234)tms_sacr1
4801 WRITE(63,err=9234)tcr_sacr2
4802 WRITE(63,err=9234)tms_sacr2
4803 WRITE(63,err=9234)tnr_racs1
4804 WRITE(63,err=9234)tnr_racs2
4805 WRITE(63,err=9234)tnr_sacr1
4806 WRITE(63,err=9234)tnr_sacr2
4807 CLOSE(63)
4808 RETURN ! ----- RETURN
4809 9234 CONTINUE
4810 write(0,*) "Error writing "//qr_acr_qs_file
4811 ENDIF
4812 ENDIF
4813
4814 end subroutine qr_acr_qs
4815!+---+-----------------------------------------------------------------+
4816!ctrlL
4817!+---+-----------------------------------------------------------------+
4822 subroutine freezeh2o(threads)
4823
4824 implicit none
4825
4826!..Interface variables
4827 INTEGER, INTENT(IN):: threads
4828
4829!..Local variables
4830 INTEGER:: i, j, k, m, n, n2
4831 DOUBLE PRECISION:: N_r, N_c
4832 DOUBLE PRECISION, DIMENSION(nbr):: massr
4833 DOUBLE PRECISION, DIMENSION(nbc):: massc
4834 DOUBLE PRECISION:: sum1, sum2, sumn1, sumn2, &
4835 prob, vol, Texp, orho_w, &
4836 lam_exp, lamr, N0_r, lamc, N0_c, y
4837 INTEGER:: nu_c
4838 REAL:: T_adjust
4839 LOGICAL force_read_thompson, write_thompson_tables
4840 LOGICAL lexist,lopen
4841 INTEGER good,ierr
4842
4843!+---+
4844 force_read_thompson = .false.
4845 write_thompson_tables = .false.
4846
4847 good = 0
4848 INQUIRE(file=freeze_h2o_file,exist=lexist)
4849#ifdef MPI
4850 call mpi_barrier(mpi_communicator,ierr)
4851#endif
4852 IF ( lexist ) THEN
4853 !write(0,*) "ThompMP: read "//freeze_h2o_file//" instead of computing"
4854 OPEN(63,file=freeze_h2o_file,form="unformatted",err=1234)
4855!sms$serial begin
4856 READ(63,err=1234)tpi_qrfz
4857 READ(63,err=1234)tni_qrfz
4858 READ(63,err=1234)tpg_qrfz
4859 READ(63,err=1234)tnr_qrfz
4860 READ(63,err=1234)tpi_qcfz
4861 READ(63,err=1234)tni_qcfz
4862!sms$serial end
4863 good = 1
4864 1234 CONTINUE
4865 IF ( good .NE. 1 ) THEN
4866 INQUIRE(63,opened=lopen)
4867 IF (lopen) THEN
4868 IF( force_read_thompson ) THEN
4869 write(0,*) "Error reading "//freeze_h2o_file//" Aborting because force_read_thompson is .true."
4870 return
4871 ENDIF
4872 CLOSE(63)
4873 ELSE
4874 IF( force_read_thompson ) THEN
4875 write(0,*) "Error opening "//freeze_h2o_file//" Aborting because force_read_thompson is .true."
4876 return
4877 ENDIF
4878 ENDIF
4879 ELSE
4880 INQUIRE(63,opened=lopen)
4881 IF (lopen) THEN
4882 CLOSE(63)
4883 ENDIF
4884 ENDIF
4885 ELSE
4886 IF( force_read_thompson ) THEN
4887 write(0,*) "Non-existent "//freeze_h2o_file//" Aborting because force_read_thompson is .true."
4888 return
4889 ENDIF
4890 ENDIF
4891
4892 IF (.NOT. good .EQ. 1 ) THEN
4893 if (thompson_table_writer) then
4894 write_thompson_tables = .true.
4895 write(0,*) "ThompMP: computing freezeH2O"
4896 endif
4897
4898 orho_w = 1./rho_w
4899
4900 do n2 = 1, nbr
4901 massr(n2) = am_r*dr(n2)**bm_r
4902 enddo
4903 do n = 1, nbc
4904 massc(n) = am_r*dc(n)**bm_r
4905 enddo
4906
4907!..Freeze water (smallest drops become cloud ice, otherwise graupel).
4908 do m = 1, ntb_in
4909 t_adjust = max(-3.0, min(3.0 - alog10(nt_in(m)), 3.0))
4910 do k = 1, 45
4911! print*, ' Freezing water for temp = ', -k
4912 texp = dexp( dfloat(k) - t_adjust*1.0d0 ) - 1.0d0
4913!$OMP PARALLEL DO SCHEDULE(dynamic) num_threads(threads) &
4914!$OMP PRIVATE(j,i,lam_exp,lamr,N0_r,sum1,sum2,sumn1,sumn2,n2,N_r,vol,prob)
4915 do j = 1, ntb_r1
4916 do i = 1, ntb_r
4917 lam_exp = (n0r_exp(j)*am_r*crg(1)/r_r(i))**ore1
4918 lamr = lam_exp * (crg(3)*org2*org1)**obmr
4919 n0_r = n0r_exp(j)/(crg(2)*lam_exp) * lamr**cre(2)
4920 sum1 = 0.0d0
4921 sum2 = 0.0d0
4922 sumn1 = 0.0d0
4923 sumn2 = 0.0d0
4924 do n2 = nbr, 1, -1
4925 n_r = n0_r*dr(n2)**mu_r*dexp(-lamr*dr(n2))*dtr(n2)
4926 vol = massr(n2)*orho_w
4927 prob = max(0.0d0, 1.0d0 - dexp(-120.0d0*vol*5.2d-4 * texp))
4928 if (massr(n2) .lt. xm0g) then
4929 sumn1 = sumn1 + prob*n_r
4930 sum1 = sum1 + prob*n_r*massr(n2)
4931 else
4932 sumn2 = sumn2 + prob*n_r
4933 sum2 = sum2 + prob*n_r*massr(n2)
4934 endif
4935 if ((sum1+sum2).ge.r_r(i)) EXIT
4936 enddo
4937 tpi_qrfz(i,j,k,m) = sum1
4938 tni_qrfz(i,j,k,m) = sumn1
4939 tpg_qrfz(i,j,k,m) = sum2
4940 tnr_qrfz(i,j,k,m) = sumn2
4941 enddo
4942 enddo
4943!$OMP END PARALLEL DO
4944
4945!$OMP PARALLEL DO SCHEDULE(dynamic) num_threads(threads) &
4946!$OMP PRIVATE(j,i,nu_c,lamc,N0_c,sum1,sumn2,vol,prob,N_c)
4947 do j = 1, nbc
4948 nu_c = min(15, nint(1000.e6/t_nc(j)) + 2)
4949 do i = 1, ntb_c
4950 lamc = (t_nc(j)*am_r* ccg(2,nu_c) * ocg1(nu_c) / r_c(i))**obmr
4951 n0_c = t_nc(j)*ocg1(nu_c) * lamc**cce(1,nu_c)
4952 sum1 = 0.0d0
4953 sumn2 = 0.0d0
4954 do n = nbc, 1, -1
4955 vol = massc(n)*orho_w
4956 prob = max(0.0d0, 1.0d0 - dexp(-120.0d0*vol*5.2d-4 * texp))
4957 n_c = n0_c*dc(n)**nu_c*exp(-lamc*dc(n))*dtc(n)
4958 sumn2 = min(t_nc(j), sumn2 + prob*n_c)
4959 sum1 = sum1 + prob*n_c*massc(n)
4960 if (sum1 .ge. r_c(i)) EXIT
4961 enddo
4962 tpi_qcfz(i,j,k,m) = sum1
4963 tni_qcfz(i,j,k,m) = sumn2
4964 enddo
4965 enddo
4966!$OMP END PARALLEL DO
4967 enddo
4968 enddo
4969
4970 IF ( write_thompson_tables ) THEN
4971 write(0,*) "Writing "//freeze_h2o_file//" in Thompson MP init"
4972 OPEN(63,file=freeze_h2o_file,form="unformatted",err=9234)
4973 WRITE(63,err=9234)tpi_qrfz
4974 WRITE(63,err=9234)tni_qrfz
4975 WRITE(63,err=9234)tpg_qrfz
4976 WRITE(63,err=9234)tnr_qrfz
4977 WRITE(63,err=9234)tpi_qcfz
4978 WRITE(63,err=9234)tni_qcfz
4979 CLOSE(63)
4980 RETURN ! ----- RETURN
4981 9234 CONTINUE
4982 write(0,*) "Error writing "//freeze_h2o_file
4983 return
4984 ENDIF
4985 ENDIF
4986
4987 end subroutine freezeh2o
4988
4989!+---+-----------------------------------------------------------------+
4990!ctrlL
4991!+---+-----------------------------------------------------------------+
5001 subroutine qi_aut_qs
5002
5003 implicit none
5004
5005!..Local variables
5006 INTEGER:: i, j, n2
5007 DOUBLE PRECISION, DIMENSION(nbi):: N_i
5008 DOUBLE PRECISION:: N0_i, lami, Di_mean, t1, t2
5009 REAL:: xlimit_intg
5010
5011!+---+
5012
5013 do j = 1, ntb_i1
5014 do i = 1, ntb_i
5015 lami = (am_i*cig(2)*oig1*nt_i(j)/r_i(i))**obmi
5016 di_mean = (bm_i + mu_i + 1.) / lami
5017 n0_i = nt_i(j)*oig1 * lami**cie(1)
5018 t1 = 0.0d0
5019 t2 = 0.0d0
5020 if (sngl(di_mean) .gt. 5.*d0s) then
5021 t1 = r_i(i)
5022 t2 = nt_i(j)
5023 tpi_ide(i,j) = 0.0d0
5024 elseif (sngl(di_mean) .lt. d0i) then
5025 t1 = 0.0d0
5026 t2 = 0.0d0
5027 tpi_ide(i,j) = 1.0d0
5028 else
5029 xlimit_intg = lami*d0s
5030 tpi_ide(i,j) = gammp(mu_i+2.0, xlimit_intg) * 1.0d0
5031 do n2 = 1, nbi
5032 n_i(n2) = n0_i*di(n2)**mu_i * dexp(-lami*di(n2))*dti(n2)
5033 if (di(n2).ge.d0s) then
5034 t1 = t1 + n_i(n2) * am_i*di(n2)**bm_i
5035 t2 = t2 + n_i(n2)
5036 endif
5037 enddo
5038 endif
5039 tps_iaus(i,j) = t1
5040 tni_iaus(i,j) = t2
5041 enddo
5042 enddo
5043
5044 end subroutine qi_aut_qs
5045!ctrlL
5046!+---+-----------------------------------------------------------------+
5051 subroutine table_efrw
5052
5053 implicit none
5054
5055!..Local variables
5056 DOUBLE PRECISION:: vtr, stokes, reynolds, Ef_rw
5057 DOUBLE PRECISION:: p, yc0, F, G, H, z, K0, X
5058 INTEGER:: i, j
5059
5060 do j = 1, nbc
5061 do i = 1, nbr
5062 ef_rw = 0.0
5063 p = dc(j)/dr(i)
5064 if (dr(i).lt.50.e-6 .or. dc(j).lt.3.e-6) then
5065 t_efrw(i,j) = 0.0
5066 elseif (p.gt.0.25) then
5067 x = dc(j)*1.d6
5068 if (dr(i) .lt. 75.e-6) then
5069 ef_rw = 0.026794*x - 0.20604
5070 elseif (dr(i) .lt. 125.e-6) then
5071 ef_rw = -0.00066842*x*x + 0.061542*x - 0.37089
5072 elseif (dr(i) .lt. 175.e-6) then
5073 ef_rw = 4.091e-06*x*x*x*x - 0.00030908*x*x*x &
5074 + 0.0066237*x*x - 0.0013687*x - 0.073022
5075 elseif (dr(i) .lt. 250.e-6) then
5076 ef_rw = 9.6719e-5*x*x*x - 0.0068901*x*x + 0.17305*x &
5077 - 0.65988
5078 elseif (dr(i) .lt. 350.e-6) then
5079 ef_rw = 9.0488e-5*x*x*x - 0.006585*x*x + 0.16606*x &
5080 - 0.56125
5081 else
5082 ef_rw = 0.00010721*x*x*x - 0.0072962*x*x + 0.1704*x &
5083 - 0.46929
5084 endif
5085 else
5086 vtr = -0.1021 + 4.932e3*dr(i) - 0.9551e6*dr(i)*dr(i) &
5087 + 0.07934e9*dr(i)*dr(i)*dr(i) &
5088 - 0.002362e12*dr(i)*dr(i)*dr(i)*dr(i)
5089 stokes = dc(j)*dc(j)*vtr*rho_w/(9.*1.718e-5*dr(i))
5090 reynolds = 9.*stokes/(p*p*rho_w)
5091
5092 f = dlog(reynolds)
5093 g = -0.1007d0 - 0.358d0*f + 0.0261d0*f*f
5094 k0 = dexp(g)
5095 z = dlog(stokes/(k0+1.d-15))
5096 h = 0.1465d0 + 1.302d0*z - 0.607d0*z*z + 0.293d0*z*z*z
5097 yc0 = 2.0d0/pi * atan(h)
5098 ef_rw = (yc0+p)*(yc0+p) / ((1.+p)*(1.+p))
5099
5100 endif
5101
5102 t_efrw(i,j) = max(0.0, min(sngl(ef_rw), 0.95))
5103
5104 enddo
5105 enddo
5106
5107 end subroutine table_efrw
5108!ctrlL
5109!+---+-----------------------------------------------------------------+
5114 subroutine table_efsw
5115
5116 implicit none
5117
5118!..Local variables
5119 DOUBLE PRECISION:: Ds_m, vts, vtc, stokes, reynolds, Ef_sw
5120 DOUBLE PRECISION:: p, yc0, F, G, H, z, K0
5121 INTEGER:: i, j
5122
5123 do j = 1, nbc
5124 vtc = 1.19d4 * (1.0d4*dc(j)*dc(j)*0.25d0)
5125 do i = 1, nbs
5126 vts = av_s*ds(i)**bv_s * dexp(-fv_s*ds(i)) - vtc
5127 ds_m = (am_s*ds(i)**bm_s / am_r)**obmr
5128 p = dc(j)/ds_m
5129 if (p.gt.0.25 .or. ds(i).lt.d0s .or. dc(j).lt.6.e-6 &
5130 .or. vts.lt.1.e-3) then
5131 t_efsw(i,j) = 0.0
5132 else
5133 stokes = dc(j)*dc(j)*vts*rho_w/(9.*1.718e-5*ds_m)
5134 reynolds = 9.*stokes/(p*p*rho_w)
5135
5136 f = dlog(reynolds)
5137 g = -0.1007d0 - 0.358d0*f + 0.0261d0*f*f
5138 k0 = dexp(g)
5139 z = dlog(stokes/(k0+1.d-15))
5140 h = 0.1465d0 + 1.302d0*z - 0.607d0*z*z + 0.293d0*z*z*z
5141 yc0 = 2.0d0/pi * atan(h)
5142 ef_sw = (yc0+p)*(yc0+p) / ((1.+p)*(1.+p))
5143
5144 t_efsw(i,j) = max(0.0, min(sngl(ef_sw), 0.95))
5145 endif
5146
5147 enddo
5148 enddo
5149
5150 end subroutine table_efsw
5151!ctrlL
5152!+---+-----------------------------------------------------------------+
5157 real function eff_aero(d, da, visc,rhoa,temp,species)
5158
5159 implicit none
5160 real:: d, da, visc, rhoa, temp
5161 character(LEN=1):: species
5162 real:: aval, cc, diff, re, sc, st, st2, vt, eff
5163 real, parameter:: boltzman = 1.3806503e-23
5164 real, parameter:: meanpath = 0.0256e-6
5165
5166 vt = 1.
5167 if (species .eq. 'r') then
5168 vt = -0.1021 + 4.932e3*d - 0.9551e6*d*d &
5169 + 0.07934e9*d*d*d - 0.002362e12*d*d*d*d
5170 elseif (species .eq. 's') then
5171 vt = av_s*d**bv_s
5172 elseif (species .eq. 'g') then
5173 vt = av_g*d**bv_g
5174 endif
5175
5176 cc = 1. + 2.*meanpath/da *(1.257+0.4*exp(-0.55*da/meanpath))
5177 diff = boltzman*temp*cc/(3.*pi*visc*da)
5178
5179 re = 0.5*rhoa*d*vt/visc
5180 sc = visc/(rhoa*diff)
5181
5182 st = da*da*vt*1000./(9.*visc*d)
5183 aval = 1.+log(1.+re)
5184 st2 = (1.2 + 1./12.*aval)/(1.+aval)
5185
5186 eff = 4./(re*sc) * (1. + 0.4*sqrt(re)*sc**0.3333 &
5187 + 0.16*sqrt(re)*sqrt(sc)) &
5188 + 4.*da/d * (0.02 + da/d*(1.+2.*sqrt(re)))
5189
5190 if (st.gt.st2) eff = eff + ( (st-st2)/(st-st2+0.666667))**1.5
5191 eff_aero = max(1.e-5, min(eff, 1.0))
5192
5193 end function eff_aero
5194
5195!ctrlL
5196!+---+-----------------------------------------------------------------+
5202 subroutine table_dropevap
5203
5204 implicit none
5205
5206!..Local variables
5207 INTEGER:: i, j, k, n
5208 DOUBLE PRECISION, DIMENSION(nbc):: N_c, massc
5209 DOUBLE PRECISION:: summ, summ2, lamc, N0_c
5210 INTEGER:: nu_c
5211! DOUBLE PRECISION:: Nt_r, N0, lam_exp, lam
5212! REAL:: xlimit_intg
5213
5214 do n = 1, nbc
5215 massc(n) = am_r*dc(n)**bm_r
5216 enddo
5217
5218 do k = 1, nbc
5219 nu_c = min(15, nint(1000.e6/t_nc(k)) + 2)
5220 do j = 1, ntb_c
5221 lamc = (t_nc(k)*am_r* ccg(2,nu_c)*ocg1(nu_c) / r_c(j))**obmr
5222 n0_c = t_nc(k)*ocg1(nu_c) * lamc**cce(1,nu_c)
5223 do i = 1, nbc
5224!-GT tnc_wev(i,j,k) = GAMMP(nu_c+1., SNGL(Dc(i)*lamc))*t_Nc(k)
5225 n_c(i) = n0_c* dc(i)**nu_c*exp(-lamc*dc(i))*dtc(i)
5226! if(j.eq.18 .and. k.eq.50) print*, ' N_c = ', N_c(i)
5227 summ = 0.
5228 summ2 = 0.
5229 do n = 1, i
5230 summ = summ + massc(n)*n_c(n)
5231 summ2 = summ2 + n_c(n)
5232 enddo
5233! if(j.eq.18 .and. k.eq.50) print*, ' DEBUG-TABLE: ', r_c(j), t_Nc(k), summ2, summ
5234 tpc_wev(i,j,k) = summ
5235 tnc_wev(i,j,k) = summ2
5236 enddo
5237 enddo
5238 enddo
5239
5240!
5241!..To do the same thing for rain.
5242!
5243! do k = 1, ntb_r
5244! do j = 1, ntb_r1
5245! lam_exp = (N0r_exp(j)*am_r*crg(1)/r_r(k))**ore1
5246! lam = lam_exp * (crg(3)*org2*org1)**obmr
5247! N0 = N0r_exp(j)/(crg(2)*lam_exp) * lam**cre(2)
5248! Nt_r = N0 * crg(2) / lam**cre(2)
5249! do i = 1, nbr
5250! xlimit_intg = lam*Dr(i)
5251! tnr_rev(i,j,k) = GAMMP(mu_r+1.0, xlimit_intg) * Nt_r
5252! enddo
5253! enddo
5254! enddo
5255
5256! TO APPLY TABLE ABOVE
5257!..Rain lookup table indexes.
5258! Dr_star = DSQRT(-2.D0*DT * t1_evap/(2.*PI) &
5259! * 0.78*4.*diffu(k)*xsat*rvs/rho_w)
5260! idx_d = NINT(1.0 + FLOAT(nbr) * DLOG(Dr_star/D0r) &
5261! / DLOG(Dr(nbr)/D0r))
5262! idx_d = MAX(1, MIN(idx_d, nbr))
5263!
5264! nir = NINT(ALOG10(rr(k)))
5265! do nn = nir-1, nir+1
5266! n = nn
5267! if ( (rr(k)/10.**nn).ge.1.0 .and. &
5268! (rr(k)/10.**nn).lt.10.0) goto 154
5269! enddo
5270!154 continue
5271! idx_r = INT(rr(k)/10.**n) + 10*(n-nir2) - (n-nir2)
5272! idx_r = MAX(1, MIN(idx_r, ntb_r))
5273!
5274! lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr
5275! lam_exp = lamr * (crg(3)*org2*org1)**bm_r
5276! N0_exp = org1*rr(k)/am_r * lam_exp**cre(1)
5277! nir = NINT(DLOG10(N0_exp))
5278! do nn = nir-1, nir+1
5279! n = nn
5280! if ( (N0_exp/10.**nn).ge.1.0 .and. &
5281! (N0_exp/10.**nn).lt.10.0) goto 155
5282! enddo
5283!155 continue
5284! idx_r1 = INT(N0_exp/10.**n) + 10*(n-nir3) - (n-nir3)
5285! idx_r1 = MAX(1, MIN(idx_r1, ntb_r1))
5286!
5287! pnr_rev(k) = MIN(nr(k)*odts, SNGL(tnr_rev(idx_d,idx_r1,idx_r) & ! RAIN2M
5288! * odts))
5289
5290 end subroutine table_dropevap
5291!
5292!ctrlL
5293!+---+-----------------------------------------------------------------+
5300 subroutine table_ccnact(errmess,errflag)
5301
5302 implicit none
5303
5304!..Error handling variables
5305 CHARACTER(len=*), INTENT(INOUT) :: errmess
5306 INTEGER, INTENT(INOUT) :: errflag
5307
5308!..Local variables
5309 INTEGER:: iunit_mp_th1, i
5310 LOGICAL:: opened
5311
5312 iunit_mp_th1 = -1
5313 DO i = 20,99
5314 INQUIRE ( i , opened = opened )
5315 IF ( .NOT. opened ) THEN
5316 iunit_mp_th1 = i
5317 GOTO 2010
5318 ENDIF
5319 ENDDO
5320 2010 CONTINUE
5321 IF ( iunit_mp_th1 < 0 ) THEN
5322 write(0,*) 'module_mp_thompson: table_ccnAct: '// &
5323 'Can not find unused fortran unit to read in lookup table.'
5324 return
5325 ENDIF
5326
5327 !WRITE(*, '(A,I2)') 'module_mp_thompson: opening CCN_ACTIVATE.BIN on unit ',iunit_mp_th1
5328 OPEN(iunit_mp_th1,file='CCN_ACTIVATE.BIN', &
5329 form='UNFORMATTED',status='OLD',convert='BIG_ENDIAN',err=9009)
5330
5331!sms$serial begin
5332 READ(iunit_mp_th1,err=9010) tnccn_act
5333!sms$serial end
5334
5335 RETURN
5336 9009 CONTINUE
5337 WRITE( errmess , '(A,I2)' ) 'module_mp_thompson: error opening CCN_ACTIVATE.BIN on unit ',iunit_mp_th1
5338 errflag = 1
5339 RETURN
5340 9010 CONTINUE
5341 WRITE( errmess , '(A,I2)' ) 'module_mp_thompson: error reading CCN_ACTIVATE.BIN on unit ',iunit_mp_th1
5342 errflag = 1
5343 RETURN
5344
5345 end subroutine table_ccnact
5346
5353! TO_DO ITEM: For radiation cooling producing fog, in which case the
5354!.. updraft velocity could easily be negative, we could use the temp
5355!.. and its tendency to diagnose a pretend postive updraft velocity.
5356 real function activ_ncloud(tt, ww, nccn, lsm_in)
5357
5358 implicit none
5359 REAL, INTENT(IN):: tt, ww, nccn
5360 INTEGER, INTENT(IN):: lsm_in
5361 REAL:: n_local, w_local
5362 INTEGER:: i, j, k, l, m, n
5363 REAL:: a, b, c, d, t, u, x1, x2, y1, y2, nx, wy, fraction
5364 REAL:: lower_lim_nuc_frac
5365
5366! ta_Na = (/10.0, 31.6, 100.0, 316.0, 1000.0, 3160.0, 10000.0/) ntb_arc
5367! ta_Ww = (/0.01, 0.0316, 0.1, 0.316, 1.0, 3.16, 10.0, 31.6, 100.0/) ntb_arw
5368! ta_Tk = (/243.15, 253.15, 263.15, 273.15, 283.15, 293.15, 303.15/) ntb_art
5369! ta_Ra = (/0.01, 0.02, 0.04, 0.08, 0.16/) ntb_arr
5370! ta_Ka = (/0.2, 0.4, 0.6, 0.8/) ntb_ark
5371
5372 n_local = nccn * 1.e-6
5373 w_local = ww
5374
5375 if (n_local .ge. ta_na(ntb_arc)) then
5376 n_local = ta_na(ntb_arc) - 1.0
5377 elseif (n_local .le. ta_na(1)) then
5378 n_local = ta_na(1) + 1.0
5379 endif
5380 do n = 2, ntb_arc
5381 if (n_local.ge.ta_na(n-1) .and. n_local.lt.ta_na(n)) goto 8003
5382 enddo
5383 8003 continue
5384 i = n
5385 x1 = log(ta_na(i-1))
5386 x2 = log(ta_na(i))
5387
5388 if (w_local .ge. ta_ww(ntb_arw)) then
5389 w_local = ta_ww(ntb_arw) - 1.0
5390 elseif (w_local .le. ta_ww(1)) then
5391 w_local = ta_ww(1) + 0.001
5392 endif
5393 do n = 2, ntb_arw
5394 if (w_local.ge.ta_ww(n-1) .and. w_local.lt.ta_ww(n)) goto 8005
5395 enddo
5396 8005 continue
5397 j = n
5398 y1 = log(ta_ww(j-1))
5399 y2 = log(ta_ww(j))
5400
5401 k = max(1, min( nint( (tt - ta_tk(1))*0.1) + 1, ntb_art))
5402
5403!..The next two values are indexes of mean aerosol radius and
5404!.. hygroscopicity. Currently these are constant but a future version
5405!.. should implement other variables to allow more freedom such as
5406!.. at least simple separation of tiny size sulfates from larger
5407!.. sea salts.
5408 l = 3
5409 m = 2
5410
5411 if (lsm_in .eq. 1) then ! land
5412 lower_lim_nuc_frac = 0.
5413 else if (lsm_in .eq. 0) then ! water
5414 lower_lim_nuc_frac = 0.15
5415 else
5416 lower_lim_nuc_frac = 0.15 ! catch-all for anything else
5417 endif
5418
5419 a = tnccn_act(i-1,j-1,k,l,m)
5420 b = tnccn_act(i,j-1,k,l,m)
5421 c = tnccn_act(i,j,k,l,m)
5422 d = tnccn_act(i-1,j,k,l,m)
5423 nx = log(n_local)
5424 wy = log(w_local)
5425
5426 t = (nx-x1)/(x2-x1)
5427 u = (wy-y1)/(y2-y1)
5428
5429! t = (n_local-ta(Na(i-1))/(ta_Na(i)-ta_Na(i-1))
5430! u = (w_local-ta_Ww(j-1))/(ta_Ww(j)-ta_Ww(j-1))
5431
5432 fraction = (1.0-t)*(1.0-u)*a + t*(1.0-u)*b + t*u*c + (1.0-t)*u*d
5433 fraction = max(fraction, lower_lim_nuc_frac)
5434
5435! if (NCCN*fraction .gt. 0.75*Nt_c_max) then
5436! write(*,*) ' DEBUG-GT ', n_local, w_local, Tt, i, j, k
5437! endif
5438
5439 activ_ncloud = nccn*fraction
5440
5441 end function activ_ncloud
5442
5443!+---+-----------------------------------------------------------------+
5444!+---+-----------------------------------------------------------------+
5448 SUBROUTINE gcf(GAMMCF,A,X,GLN)
5449! RETURNS THE INCOMPLETE GAMMA FUNCTION Q(A,X) EVALUATED BY ITS
5450! CONTINUED FRACTION REPRESENTATION AS GAMMCF. ALSO RETURNS
5451! --- LN(GAMMA(A)) AS GLN. THE CONTINUED FRACTION IS EVALUATED BY
5452! --- A MODIFIED LENTZ METHOD.
5453! --- USES GAMMLN
5454 IMPLICIT NONE
5455 INTEGER, PARAMETER:: ITMAX=100
5456 REAL, PARAMETER:: gEPS=3.e-7
5457 REAL, PARAMETER:: FPMIN=1.e-30
5458 REAL, INTENT(IN):: A, X
5459 REAL:: GAMMCF,GLN
5460 INTEGER:: I
5461 REAL:: AN,B,C,D,DEL,H
5462 gln=gammln(a)
5463 b=x+1.-a
5464 c=1./fpmin
5465 d=1./b
5466 h=d
5467 DO 11 i=1,itmax
5468 an=-i*(i-a)
5469 b=b+2.
5470 d=an*d+b
5471 IF(abs(d).LT.fpmin)d=fpmin
5472 c=b+an/c
5473 IF(abs(c).LT.fpmin)c=fpmin
5474 d=1./d
5475 del=d*c
5476 h=h*del
5477 IF(abs(del-1.).LT.geps)GOTO 1
5478 11 CONTINUE
5479 print *, 'A TOO LARGE, ITMAX TOO SMALL IN GCF'
5480 1 gammcf=exp(-x+a*log(x)-gln)*h
5481 END SUBROUTINE gcf
5482! (C) Copr. 1986-92 Numerical Recipes Software 2.02
5483
5487 SUBROUTINE gser(GAMSER,A,X,GLN)
5488! --- RETURNS THE INCOMPLETE GAMMA FUNCTION P(A,X) EVALUATED BY ITS
5489! --- ITS SERIES REPRESENTATION AS GAMSER. ALSO RETURNS LN(GAMMA(A))
5490! --- AS GLN.
5491! --- USES GAMMLN
5492 IMPLICIT NONE
5493 INTEGER, PARAMETER:: ITMAX=100
5494 REAL, PARAMETER:: gEPS=3.e-7
5495 REAL, INTENT(IN):: A, X
5496 REAL:: GAMSER,GLN
5497 INTEGER:: N
5498 REAL:: AP,DEL,SUM
5499 gln=gammln(a)
5500 IF(x.LE.0.)THEN
5501 IF(x.LT.0.) print *, 'X < 0 IN GSER'
5502 gamser=0.
5503 RETURN
5504 ENDIF
5505 ap=a
5506 sum=1./a
5507 del=sum
5508 DO 11 n=1,itmax
5509 ap=ap+1.
5510 del=del*x/ap
5511 sum=sum+del
5512 IF(abs(del).LT.abs(sum)*geps)GOTO 1
5513 11 CONTINUE
5514 print *,'A TOO LARGE, ITMAX TOO SMALL IN GSER'
5515 1 gamser=sum*exp(-x+a*log(x)-gln)
5516 END SUBROUTINE gser
5517! (C) Copr. 1986-92 Numerical Recipes Software 2.02
5518
5521 REAL function gammln(xx)
5522! --- RETURNS THE VALUE LN(GAMMA(XX)) FOR XX > 0.
5523 IMPLICIT NONE
5524 REAL, INTENT(IN):: xx
5525 DOUBLE PRECISION, PARAMETER:: stp = 2.5066282746310005d0
5526 DOUBLE PRECISION, DIMENSION(6), PARAMETER:: &
5527 cof = (/76.18009172947146d0, -86.50532032941677d0, &
5528 24.01409824083091d0, -1.231739572450155d0, &
5529 .1208650973866179d-2, -.5395239384953d-5/)
5530 DOUBLE PRECISION:: ser,tmp,x,y
5531 INTEGER:: j
5532
5533 x=xx
5534 y=x
5535 tmp=x+5.5d0
5536 tmp=(x+0.5d0)*log(tmp)-tmp
5537 ser=1.000000000190015d0
5538 DO 11 j=1,6
5539 y=y+1.d0
5540 ser=ser+cof(j)/y
554111 CONTINUE
5542 gammln=tmp+log(stp*ser/x)
5543 END FUNCTION gammln
5544! (C) Copr. 1986-92 Numerical Recipes Software 2.02
5545
5547 REAL function gammp(a,x)
5548! --- COMPUTES THE INCOMPLETE GAMMA FUNCTION P(A,X)
5549! --- SEE ABRAMOWITZ AND STEGUN 6.5.1
5550! --- USES GCF,GSER
5551 IMPLICIT NONE
5552 REAL, INTENT(IN):: a,x
5553 REAL:: gammcf,gamser,gln
5554 gammp = 0.
5555 IF((x.LT.0.) .OR. (a.LE.0.)) THEN
5556 print *, 'BAD ARGUMENTS IN GAMMP'
5557 RETURN
5558 ELSEIF(x.LT.a+1.)THEN
5559 CALL gser(gamser,a,x,gln)
5560 gammp=gamser
5561 ELSE
5562 CALL gcf(gammcf,a,x,gln)
5563 gammp=1.-gammcf
5564 ENDIF
5565 END FUNCTION gammp
5566! (C) Copr. 1986-92 Numerical Recipes Software 2.02
5567!+---+-----------------------------------------------------------------+
5569 REAL function wgamma(y)
5570
5571 IMPLICIT NONE
5572 REAL, INTENT(IN):: y
5573
5574 wgamma = exp(gammln(y))
5575
5576 END FUNCTION wgamma
5577!+---+-----------------------------------------------------------------+
5581 REAL function rslf(p,t)
5582
5583 IMPLICIT NONE
5584 REAL, INTENT(IN):: p, t
5585 REAL:: esl,x
5586 REAL, PARAMETER:: c0= .611583699e03
5587 REAL, PARAMETER:: c1= .444606896e02
5588 REAL, PARAMETER:: c2= .143177157e01
5589 REAL, PARAMETER:: c3= .264224321e-1
5590 REAL, PARAMETER:: c4= .299291081e-3
5591 REAL, PARAMETER:: c5= .203154182e-5
5592 REAL, PARAMETER:: c6= .702620698e-8
5593 REAL, PARAMETER:: c7= .379534310e-11
5594 REAL, PARAMETER:: c8=-.321582393e-13
5595
5596 x=max(-80.,t-273.16)
5597
5598! ESL=612.2*EXP(17.67*X/(T-29.65))
5599 esl=c0+x*(c1+x*(c2+x*(c3+x*(c4+x*(c5+x*(c6+x*(c7+x*c8)))))))
5600 esl=min(esl, p*0.15) ! Even with P=1050mb and T=55C, the sat. vap. pres only contributes to ~15% of total pres.
5601 rslf=.622*esl/max(1.e-4,(p-esl))
5602
5603! ALTERNATIVE
5604! ; Source: Murphy and Koop, Review of the vapour pressure of ice and
5605! supercooled water for atmospheric applications, Q. J. R.
5606! Meteorol. Soc (2005), 131, pp. 1539-1565.
5607! ESL = EXP(54.842763 - 6763.22 / T - 4.210 * ALOG(T) + 0.000367 * T
5608! + TANH(0.0415 * (T - 218.8)) * (53.878 - 1331.22
5609! / T - 9.44523 * ALOG(T) + 0.014025 * T))
5610
5611 END FUNCTION rslf
5612!+---+-----------------------------------------------------------------+
5616 REAL function rsif(p,t)
5617
5618 IMPLICIT NONE
5619 REAL, INTENT(IN):: p, t
5620 REAL:: esi,x
5621 REAL, PARAMETER:: c0= .609868993e03
5622 REAL, PARAMETER:: c1= .499320233e02
5623 REAL, PARAMETER:: c2= .184672631e01
5624 REAL, PARAMETER:: c3= .402737184e-1
5625 REAL, PARAMETER:: c4= .565392987e-3
5626 REAL, PARAMETER:: c5= .521693933e-5
5627 REAL, PARAMETER:: c6= .307839583e-7
5628 REAL, PARAMETER:: c7= .105785160e-9
5629 REAL, PARAMETER:: c8= .161444444e-12
5630
5631 x=max(-80.,t-273.16)
5632 esi=c0+x*(c1+x*(c2+x*(c3+x*(c4+x*(c5+x*(c6+x*(c7+x*c8)))))))
5633 esi=min(esi, p*0.15)
5634 rsif=.622*esi/max(1.e-4,(p-esi))
5635
5636! ALTERNATIVE
5637! ; Source: Murphy and Koop, Review of the vapour pressure of ice and
5638! supercooled water for atmospheric applications, Q. J. R.
5639! Meteorol. Soc (2005), 131, pp. 1539-1565.
5640! ESI = EXP(9.550426 - 5723.265/T + 3.53068*ALOG(T) - 0.00728332*T)
5641
5642 END FUNCTION rsif
5643
5644!+---+-----------------------------------------------------------------+
5646 real function icedemott(tempc, qv, qvs, qvsi, rho, nifa)
5647 implicit none
5648
5649 REAL, INTENT(IN):: tempc, qv, qvs, qvsi, rho, nifa
5650
5651!..Local vars
5652 REAL:: satw, sati, siw, p_x, si0x, dtt, dsi, dsw, dab, fc, hx
5653 REAL:: ntilde, n_in, nmax, nhat, mux, xni, nifa_cc
5654 REAL, PARAMETER:: p_c1 = 1000.
5655 REAL, PARAMETER:: p_rho_c = 0.76
5656 REAL, PARAMETER:: p_alpha = 1.0
5657 REAL, PARAMETER:: p_gam = 2.
5658 REAL, PARAMETER:: delt = 5.
5659 REAL, PARAMETER:: t0x = -40.
5660 REAL, PARAMETER:: sw0x = 0.97
5661 REAL, PARAMETER:: delsi = 0.1
5662 REAL, PARAMETER:: hdm = 0.15
5663 REAL, PARAMETER:: p_psi = 0.058707*p_gam/p_rho_c
5664 REAL, PARAMETER:: aap = 1.
5665 REAL, PARAMETER:: bbp = 0.
5666 REAL, PARAMETER:: y1p = -35.
5667 REAL, PARAMETER:: y2p = -25.
5668 REAL, PARAMETER:: rho_not0 = 101325./(287.05*273.15)
5669
5670!+---+
5671
5672 xni = 0.0
5673! satw = qv/qvs
5674! sati = qv/qvsi
5675! siw = qvs/qvsi
5676! p_x = -1.0261+(3.1656e-3*tempc)+(5.3938e-4*(tempc*tempc)) &
5677! + (8.2584e-6*(tempc*tempc*tempc))
5678! si0x = 1.+(10.**p_x)
5679! if (sati.ge.si0x .and. satw.lt.0.985) then
5680! dtt = delta_p (tempc, T0x, T0x+delT, 1., hdm)
5681! dsi = delta_p (sati, Si0x, Si0x+delSi, 0., 1.)
5682! dsw = delta_p (satw, Sw0x, 1., 0., 1.)
5683! fc = dtt*dsi*0.5
5684! hx = min(fc+((1.-fc)*dsw), 1.)
5685! ntilde = p_c1*p_gam*((exp(12.96*(sati-1.1)))**0.3) / p_rho_c
5686! if (tempc .le. y1p) then
5687! n_in = ntilde
5688! elseif (tempc .ge. y2p) then
5689! n_in = p_psi*p_c1*exp(12.96*(sati-1.)-0.639)
5690! else
5691! if (tempc .le. -30.) then
5692! nmax = p_c1*p_gam*(exp(12.96*(siw-1.1)))**0.3/p_rho_c
5693! else
5694! nmax = p_psi*p_c1*exp(12.96*(siw-1.)-0.639)
5695! endif
5696! ntilde = MIN(ntilde, nmax)
5697! nhat = MIN(p_psi*p_c1*exp(12.96*(sati-1.)-0.639), nmax)
5698! dab = delta_p (tempc, y1p, y2p, aap, bbp)
5699! n_in = MIN(nhat*(ntilde/nhat)**dab, nmax)
5700! endif
5701! mux = hx*p_alpha*n_in*rho
5702! xni = mux*((6700.*nifa)-200.)/((6700.*5.E5)-200.)
5703! elseif (satw.ge.0.985 .and. tempc.gt.HGFR-273.15) then
5704 nifa_cc = max(0.5, nifa*rho_not0*1.e-6/rho)
5705! xni = 3.*nifa_cc**(1.25)*exp((0.46*(-tempc))-11.6) ! [DeMott, 2015]
5706 xni = (5.94e-5*(-tempc)**3.33) & ! [DeMott, 2010]
5707 * (nifa_cc**((-0.0264*(tempc))+0.0033))
5708 xni = xni*rho/rho_not0 * 1000.
5709! endif
5710
5711 icedemott = max(0., xni)
5712
5713 end FUNCTION icedemott
5714
5715!+---+-----------------------------------------------------------------+
5720 real function icekoop(temp, qv, qvs, naero, dt)
5721 implicit none
5722
5723 REAL, INTENT(IN):: temp, qv, qvs, naero, dt
5724 REAL:: mu_diff, a_w_i, delta_aw, log_j_rate, j_rate, prob_h, satw
5725 REAL:: xni
5726
5727 xni = 0.0
5728 satw = qv/qvs
5729 mu_diff = 210368.0 + (131.438*temp) - (3.32373e6/temp) &
5730 & - (41729.1*alog(temp))
5731 a_w_i = exp(mu_diff/(r_uni*temp))
5732 delta_aw = satw - a_w_i
5733 log_j_rate = -906.7 + (8502.0*delta_aw) &
5734 & - (26924.0*delta_aw*delta_aw) &
5735 & + (29180.0*delta_aw*delta_aw*delta_aw)
5736 log_j_rate = min(20.0, log_j_rate)
5737 j_rate = 10.**log_j_rate ! cm-3 s-1
5738 prob_h = min(1.-exp(-j_rate*ar_volume*dt), 1.)
5739 if (prob_h .gt. 0.) then
5740 xni = min(prob_h*naero, 1000.e3)
5741 endif
5742
5743 icekoop = max(0.0, xni)
5744
5745 end FUNCTION icekoop
5746
5747!+---+-----------------------------------------------------------------+
5750 REAL function delta_p (yy, y1, y2, aa, bb)
5751 IMPLICIT NONE
5752
5753 REAL, INTENT(IN):: yy, y1, y2, aa, bb
5754 REAL:: dab, a, b, a0, a1, a2, a3
5755
5756 a = 6.*(aa-bb)/((y2-y1)*(y2-y1)*(y2-y1))
5757 b = aa+(a*y1*y1*y1/6.)-(a*y1*y1*y2*0.5)
5758 a0 = b
5759 a1 = a*y1*y2
5760 a2 = -a*(y1+y2)*0.5
5761 a3 = a/3.
5762
5763 if (yy.le.y1) then
5764 dab = aa
5765 else if (yy.ge.y2) then
5766 dab = bb
5767 else
5768 dab = a0+(a1*yy)+(a2*yy*yy)+(a3*yy*yy*yy)
5769 endif
5770
5771 if (dab.lt.aa) then
5772 dab = aa
5773 endif
5774 if (dab.gt.bb) then
5775 dab = bb
5776 endif
5777 delta_p = dab
5778
5779 END FUNCTION delta_p
5780
5781!+---+-----------------------------------------------------------------+
5782!ctrlL
5783
5784!+---+-----------------------------------------------------------------+
5792
5793 subroutine calc_effectrad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, &
5794 & re_qc1d, re_qi1d, re_qs1d, lsml, kts, kte)
5795
5796 IMPLICIT NONE
5797
5798!..Sub arguments
5799 INTEGER, INTENT(IN):: kts, kte
5800 REAL, DIMENSION(kts:kte), INTENT(IN):: &
5801 & t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d
5802 REAL, DIMENSION(kts:kte), INTENT(OUT):: re_qc1d, re_qi1d, re_qs1d
5803!..Local variables
5804 INTEGER:: k
5805 REAL, DIMENSION(kts:kte):: rho, rc, nc, ri, ni, rs
5806 REAL:: smo2, smob, smoc
5807 REAL:: tc0, loga_, a_, b_
5808 DOUBLE PRECISION:: lamc, lami
5809 LOGICAL:: has_qc, has_qi, has_qs
5810 INTEGER:: inu_c
5811 INTEGER:: lsml
5812 real, dimension(15), parameter:: g_ratio = (/24,60,120,210,336, &
5813 & 504,720,990,1320,1716,2184,2730,3360,4080,4896/)
5814
5815 has_qc = .false.
5816 has_qi = .false.
5817 has_qs = .false.
5818
5819 re_qc1d(:) = 0.0d0
5820 re_qi1d(:) = 0.0d0
5821 re_qs1d(:) = 0.0d0
5822
5823 do k = kts, kte
5824 rho(k) = 0.622*p1d(k)/(r*t1d(k)*(qv1d(k)+0.622))
5825 rc(k) = max(r1, qc1d(k)*rho(k))
5826 nc(k) = max(2., min(nc1d(k)*rho(k), nt_c_max))
5827 if (.NOT. (is_aerosol_aware .or. merra2_aerosol_aware)) then
5828 if( lsml == 1) then
5829 nc(k) = nt_c_l
5830 else
5831 nc(k) = nt_c_o
5832 endif
5833 endif
5834 if (rc(k).gt.r1 .and. nc(k).gt.r2) has_qc = .true.
5835 ri(k) = max(r1, qi1d(k)*rho(k))
5836 ni(k) = max(r2, ni1d(k)*rho(k))
5837 if (ri(k).gt.r1 .and. ni(k).gt.r2) has_qi = .true.
5838 rs(k) = max(r1, qs1d(k)*rho(k))
5839 if (rs(k).gt.r1) has_qs = .true.
5840 enddo
5841
5842 if (has_qc) then
5843 do k = kts, kte
5844 if (rc(k).le.r1 .or. nc(k).le.r2) cycle
5845 if (nc(k).lt.100) then
5846 inu_c = 15
5847 elseif (nc(k).gt.1.e10) then
5848 inu_c = 2
5849 else
5850 inu_c = min(15, nint(1000.e6/nc(k)) + 2)
5851 endif
5852 lamc = (nc(k)*am_r*g_ratio(inu_c)/rc(k))**obmr
5853 re_qc1d(k) = sngl(0.5d0 * dble(3.+inu_c)/lamc)
5854 enddo
5855 endif
5856
5857 if (has_qi) then
5858 do k = kts, kte
5859 if (ri(k).le.r1 .or. ni(k).le.r2) cycle
5860 lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi
5861 re_qi1d(k) = sngl(0.5d0 * dble(3.+mu_i)/lami)
5862 enddo
5863 endif
5864
5865 if (has_qs) then
5866 do k = kts, kte
5867 if (rs(k).le.r1) cycle
5868 tc0 = min(-0.1, t1d(k)-273.15)
5869 smob = rs(k)*oams
5870
5871!..All other moments based on reference, 2nd moment. If bm_s.ne.2,
5872!.. then we must compute actual 2nd moment and use as reference.
5873 if (bm_s.gt.(2.0-1.e-3) .and. bm_s.lt.(2.0+1.e-3)) then
5874 smo2 = smob
5875 else
5876 loga_ = sa(1) + sa(2)*tc0 + sa(3)*bm_s &
5877 & + sa(4)*tc0*bm_s + sa(5)*tc0*tc0 &
5878 & + sa(6)*bm_s*bm_s + sa(7)*tc0*tc0*bm_s &
5879 & + sa(8)*tc0*bm_s*bm_s + sa(9)*tc0*tc0*tc0 &
5880 & + sa(10)*bm_s*bm_s*bm_s
5881 a_ = 10.0**loga_
5882 b_ = sb(1) + sb(2)*tc0 + sb(3)*bm_s &
5883 & + sb(4)*tc0*bm_s + sb(5)*tc0*tc0 &
5884 & + sb(6)*bm_s*bm_s + sb(7)*tc0*tc0*bm_s &
5885 & + sb(8)*tc0*bm_s*bm_s + sb(9)*tc0*tc0*tc0 &
5886 & + sb(10)*bm_s*bm_s*bm_s
5887 smo2 = (smob/a_)**(1./b_)
5888 endif
5889!..Calculate bm_s+1 (th) moment. Useful for diameter calcs.
5890 loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(1) &
5891 & + sa(4)*tc0*cse(1) + sa(5)*tc0*tc0 &
5892 & + sa(6)*cse(1)*cse(1) + sa(7)*tc0*tc0*cse(1) &
5893 & + sa(8)*tc0*cse(1)*cse(1) + sa(9)*tc0*tc0*tc0 &
5894 & + sa(10)*cse(1)*cse(1)*cse(1)
5895 a_ = 10.0**loga_
5896 b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(1) + sb(4)*tc0*cse(1) &
5897 & + sb(5)*tc0*tc0 + sb(6)*cse(1)*cse(1) &
5898 & + sb(7)*tc0*tc0*cse(1) + sb(8)*tc0*cse(1)*cse(1) &
5899 & + sb(9)*tc0*tc0*tc0 + sb(10)*cse(1)*cse(1)*cse(1)
5900 smoc = a_ * smo2**b_
5901 re_qs1d(k) = 0.5*(smoc/smob)
5902 enddo
5903 endif
5904
5905 end subroutine calc_effectrad
5906
5907!+---+-----------------------------------------------------------------+
5915
5916 subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, &
5917 t1d, p1d, dBZ, rand1, kts, kte, ii, jj, melti, &
5918 vt_dBZ, first_time_step)
5919
5920 IMPLICIT NONE
5921
5922!..Sub arguments
5923 INTEGER, INTENT(IN):: kts, kte, ii, jj
5924 REAL, INTENT(IN):: rand1
5925 REAL, DIMENSION(kts:kte), INTENT(IN):: &
5926 qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, t1d, p1d
5927 REAL, DIMENSION(kts:kte), INTENT(INOUT):: dBZ
5928 REAL, DIMENSION(kts:kte), OPTIONAL, INTENT(INOUT):: vt_dBZ
5929 LOGICAL, OPTIONAL, INTENT(IN) :: first_time_step
5930
5931!..Local variables
5932 LOGICAL :: do_vt_dBZ
5933 LOGICAL :: allow_wet_graupel
5934 LOGICAL :: allow_wet_snow
5935 REAL, DIMENSION(kts:kte):: temp, pres, qv, rho, rhof
5936 REAL, DIMENSION(kts:kte):: rc, rr, nr, rs, rg
5937
5938 DOUBLE PRECISION, DIMENSION(kts:kte):: ilamr, ilamg, N0_r, N0_g
5939 REAL, DIMENSION(kts:kte):: mvd_r
5940 REAL, DIMENSION(kts:kte):: smob, smo2, smoc, smoz
5941 REAL:: oM3, M0, Mrat, slam1, slam2, xDs
5942 REAL:: ils1, ils2, t1_vts, t2_vts, t3_vts, t4_vts
5943 REAL:: vtr_dbz_wt, vts_dbz_wt, vtg_dbz_wt
5944
5945 REAL, DIMENSION(kts:kte):: ze_rain, ze_snow, ze_graupel
5946
5947 DOUBLE PRECISION:: N0_exp, N0_min, lam_exp, lamr, lamg
5948 REAL:: a_, b_, loga_, tc0, SR
5949 DOUBLE PRECISION:: fmelt_s, fmelt_g
5950
5951 INTEGER:: i, k, k_0, kbot, n
5952 LOGICAL, INTENT(IN):: melti
5953 LOGICAL, DIMENSION(kts:kte):: L_qr, L_qs, L_qg
5954
5955 DOUBLE PRECISION:: cback, x, eta, f_d
5956 REAL:: xslw1, ygra1, zans1
5957
5958!+---+
5959 if (present(vt_dbz) .and. present(first_time_step)) then
5960 do_vt_dbz = .true.
5961 if (first_time_step) then
5962! no bright banding, to be consistent with hydrometeor retrieval in GSI
5963 allow_wet_snow = .false.
5964 else
5965 allow_wet_snow = .true.
5966 endif
5967 allow_wet_graupel = .false.
5968 else
5969 do_vt_dbz = .false.
5970 allow_wet_snow = .true.
5971 allow_wet_graupel = .false.
5972 endif
5973
5974 do k = kts, kte
5975 dbz(k) = -35.0
5976 enddo
5977
5978!+---+-----------------------------------------------------------------+
5979!..Put column of data into local arrays.
5980!+---+-----------------------------------------------------------------+
5981 do k = kts, kte
5982 temp(k) = t1d(k)
5983 qv(k) = max(1.e-10, qv1d(k))
5984 pres(k) = p1d(k)
5985 rho(k) = 0.622*pres(k)/(r*temp(k)*(qv(k)+0.622))
5986 rhof(k) = sqrt(rho_not/rho(k))
5987 rc(k) = max(r1, qc1d(k)*rho(k))
5988 if (qr1d(k) .gt. r1) then
5989 rr(k) = qr1d(k)*rho(k)
5990 nr(k) = max(r2, nr1d(k)*rho(k))
5991 lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr
5992 ilamr(k) = 1./lamr
5993 n0_r(k) = nr(k)*org2*lamr**cre(2)
5994 mvd_r(k) = (3.0 + mu_r + 0.672) * ilamr(k)
5995 l_qr(k) = .true.
5996 else
5997 rr(k) = r1
5998 nr(k) = r1
5999 mvd_r(k) = 50.e-6
6000 l_qr(k) = .false.
6001 endif
6002 if (qs1d(k) .gt. r2) then
6003 rs(k) = qs1d(k)*rho(k)
6004 l_qs(k) = .true.
6005 else
6006 rs(k) = r1
6007 l_qs(k) = .false.
6008 endif
6009 if (qg1d(k) .gt. r2) then
6010 rg(k) = qg1d(k)*rho(k)
6011 l_qg(k) = .true.
6012 else
6013 rg(k) = r1
6014 l_qg(k) = .false.
6015 endif
6016 enddo
6017
6018!+---+-----------------------------------------------------------------+
6019!..Calculate y-intercept, slope, and useful moments for snow.
6020!+---+-----------------------------------------------------------------+
6021 do k = kts, kte
6022 smo2(k) = 0.
6023 smob(k) = 0.
6024 smoc(k) = 0.
6025 smoz(k) = 0.
6026 enddo
6027 if (any(l_qs .eqv. .true.)) then
6028 do k = kts, kte
6029 if (.not. l_qs(k)) cycle
6030 tc0 = min(-0.1, temp(k)-273.15)
6031 smob(k) = rs(k)*oams
6032
6033!..All other moments based on reference, 2nd moment. If bm_s.ne.2,
6034!.. then we must compute actual 2nd moment and use as reference.
6035 if (bm_s.gt.(2.0-1.e-3) .and. bm_s.lt.(2.0+1.e-3)) then
6036 smo2(k) = smob(k)
6037 else
6038 loga_ = sa(1) + sa(2)*tc0 + sa(3)*bm_s &
6039 & + sa(4)*tc0*bm_s + sa(5)*tc0*tc0 &
6040 & + sa(6)*bm_s*bm_s + sa(7)*tc0*tc0*bm_s &
6041 & + sa(8)*tc0*bm_s*bm_s + sa(9)*tc0*tc0*tc0 &
6042 & + sa(10)*bm_s*bm_s*bm_s
6043 a_ = 10.0**loga_
6044 b_ = sb(1) + sb(2)*tc0 + sb(3)*bm_s &
6045 & + sb(4)*tc0*bm_s + sb(5)*tc0*tc0 &
6046 & + sb(6)*bm_s*bm_s + sb(7)*tc0*tc0*bm_s &
6047 & + sb(8)*tc0*bm_s*bm_s + sb(9)*tc0*tc0*tc0 &
6048 & + sb(10)*bm_s*bm_s*bm_s
6049 smo2(k) = (smob(k)/a_)**(1./b_)
6050 endif
6051
6052!..Calculate bm_s+1 (th) moment. Useful for diameter calcs.
6053 loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(1) &
6054 & + sa(4)*tc0*cse(1) + sa(5)*tc0*tc0 &
6055 & + sa(6)*cse(1)*cse(1) + sa(7)*tc0*tc0*cse(1) &
6056 & + sa(8)*tc0*cse(1)*cse(1) + sa(9)*tc0*tc0*tc0 &
6057 & + sa(10)*cse(1)*cse(1)*cse(1)
6058 a_ = 10.0**loga_
6059 b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(1) + sb(4)*tc0*cse(1) &
6060 & + sb(5)*tc0*tc0 + sb(6)*cse(1)*cse(1) &
6061 & + sb(7)*tc0*tc0*cse(1) + sb(8)*tc0*cse(1)*cse(1) &
6062 & + sb(9)*tc0*tc0*tc0 + sb(10)*cse(1)*cse(1)*cse(1)
6063 smoc(k) = a_ * smo2(k)**b_
6064
6065!..Calculate bm_s*2 (th) moment. Useful for reflectivity.
6066 loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(3) &
6067 & + sa(4)*tc0*cse(3) + sa(5)*tc0*tc0 &
6068 & + sa(6)*cse(3)*cse(3) + sa(7)*tc0*tc0*cse(3) &
6069 & + sa(8)*tc0*cse(3)*cse(3) + sa(9)*tc0*tc0*tc0 &
6070 & + sa(10)*cse(3)*cse(3)*cse(3)
6071 a_ = 10.0**loga_
6072 b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(3) + sb(4)*tc0*cse(3) &
6073 & + sb(5)*tc0*tc0 + sb(6)*cse(3)*cse(3) &
6074 & + sb(7)*tc0*tc0*cse(3) + sb(8)*tc0*cse(3)*cse(3) &
6075 & + sb(9)*tc0*tc0*tc0 + sb(10)*cse(3)*cse(3)*cse(3)
6076 smoz(k) = a_ * smo2(k)**b_
6077 enddo
6078 endif
6079
6080!+---+-----------------------------------------------------------------+
6081!..Calculate y-intercept, slope values for graupel.
6082!+---+-----------------------------------------------------------------+
6083
6084 if (any(l_qg .eqv. .true.)) then
6085 call graupel_psd_parameters(kts, kte, rand1, rg, ilamg, n0_g)
6086 endif
6087
6088!+---+-----------------------------------------------------------------+
6089!..Locate K-level of start of melting (k_0 is level above).
6090!+---+-----------------------------------------------------------------+
6091 k_0 = kts
6092 if ( melti ) then
6093 k_loop:do k = kte-1, kts, -1
6094 if ((temp(k).gt.273.15) .and. l_qr(k) &
6095 & .and. (l_qs(k+1).or.l_qg(k+1)) ) then
6096 k_0 = max(k+1, k_0)
6097 EXIT k_loop
6098 endif
6099 enddo k_loop
6100 endif
6101!+---+-----------------------------------------------------------------+
6102!..Assume Rayleigh approximation at 10 cm wavelength. Rain (all temps)
6103!.. and non-water-coated snow and graupel when below freezing are
6104!.. simple. Integrations of m(D)*m(D)*N(D)*dD.
6105!+---+-----------------------------------------------------------------+
6106
6107 do k = kts, kte
6108 ze_rain(k) = 1.e-22
6109 ze_snow(k) = 1.e-22
6110 ze_graupel(k) = 1.e-22
6111 if (l_qr(k)) ze_rain(k) = n0_r(k)*crg(4)*ilamr(k)**cre(4)
6112 if (l_qs(k)) ze_snow(k) = (0.176/0.93) * (6.0/pi)*(6.0/pi) &
6113 & * (am_s/900.0)*(am_s/900.0)*smoz(k)
6114 if (l_qg(k)) ze_graupel(k) = (0.176/0.93) * (6.0/pi)*(6.0/pi) &
6115 & * (am_g/900.0)*(am_g/900.0) &
6116 & * n0_g(k)*cgg(4)*ilamg(k)**cge(4)
6117 enddo
6118
6119!+---+-----------------------------------------------------------------+
6120!..Special case of melting ice (snow/graupel) particles. Assume the
6121!.. ice is surrounded by the liquid water. Fraction of meltwater is
6122!.. extremely simple based on amount found above the melting level.
6123!.. Uses code from Uli Blahak (rayleigh_soak_wetgraupel and supporting
6124!.. routines).
6125!+---+-----------------------------------------------------------------+
6126
6127 if (.not. iiwarm .and. melti .and. k_0.ge.2) then
6128 do k = k_0-1, kts, -1
6129
6130!..Reflectivity contributed by melting snow
6131 if (allow_wet_snow .and. l_qs(k) .and. l_qs(k_0) ) then
6132 sr = max(0.01, min(1.0 - rs(k)/(rs(k) + rr(k)), 0.99))
6133 fmelt_s = dble(sr*sr)
6134 eta = 0.d0
6135 om3 = 1./smoc(k)
6136 m0 = (smob(k)*om3)
6137 mrat = smob(k)*m0*m0*m0
6138 slam1 = m0 * lam0
6139 slam2 = m0 * lam1
6140 do n = 1, nrbins
6141 x = am_s * xxds(n)**bm_s
6142 call rayleigh_soak_wetgraupel (x, dble(ocms), dble(obms), &
6143 & fmelt_s, melt_outside_s, m_w_0, m_i_0, lamda_radar, &
6144 & cback, mixingrulestring_s, matrixstring_s, &
6145 & inclusionstring_s, hoststring_s, &
6146 & hostmatrixstring_s, hostinclusionstring_s)
6147 f_d = mrat*(kap0*dexp(-slam1*xxds(n)) &
6148 & + kap1*(m0*xxds(n))**mu_s * dexp(-slam2*xxds(n)))
6149 eta = eta + f_d * cback * simpson(n) * xdts(n)
6150 enddo
6151 ze_snow(k) = sngl(lamda4 / (pi5 * k_w) * eta)
6152 endif
6153
6154!..Reflectivity contributed by melting graupel
6155 if (allow_wet_graupel .and. l_qg(k) .and. l_qg(k_0) ) then
6156 sr = max(0.01, min(1.0 - rg(k)/(rg(k) + rr(k)), 0.99))
6157 fmelt_g = dble(sr*sr)
6158 eta = 0.d0
6159 lamg = 1./ilamg(k)
6160 do n = 1, nrbins
6161 x = am_g * xxdg(n)**bm_g
6162 call rayleigh_soak_wetgraupel (x, dble(ocmg), dble(obmg), &
6163 & fmelt_g, melt_outside_g, m_w_0, m_i_0, lamda_radar, &
6164 & cback, mixingrulestring_g, matrixstring_g, &
6165 & inclusionstring_g, hoststring_g, &
6166 & hostmatrixstring_g, hostinclusionstring_g)
6167 f_d = n0_g(k)*xxdg(n)**mu_g * dexp(-lamg*xxdg(n))
6168 eta = eta + f_d * cback * simpson(n) * xdtg(n)
6169 enddo
6170 ze_graupel(k) = sngl(lamda4 / (pi5 * k_w) * eta)
6171 endif
6172
6173 enddo
6174 endif
6175
6176 do k = kte, kts, -1
6177 dbz(k) = 10.*log10((ze_rain(k)+ze_snow(k)+ze_graupel(k))*1.d18)
6178 enddo
6179
6180!..Reflectivity-weighted terminal velocity (snow, rain, graupel, mix).
6181 if (do_vt_dbz) then
6182 do k = kte, kts, -1
6183 vt_dbz(k) = 1.e-3
6184 if (rs(k).gt.r2) then
6185 mrat = smob(k) / smoc(k)
6186 ils1 = 1./(mrat*lam0 + fv_s)
6187 ils2 = 1./(mrat*lam1 + fv_s)
6188 t1_vts = kap0*csg(5)*ils1**cse(5)
6189 t2_vts = kap1*mrat**mu_s*csg(11)*ils2**cse(11)
6190 ils1 = 1./(mrat*lam0)
6191 ils2 = 1./(mrat*lam1)
6192 t3_vts = kap0*csg(6)*ils1**cse(6)
6193 t4_vts = kap1*mrat**mu_s*csg(12)*ils2**cse(12)
6194 vts_dbz_wt = rhof(k)*av_s * (t1_vts+t2_vts)/(t3_vts+t4_vts)
6195 if (temp(k).ge.273.15 .and. temp(k).lt.275.15) then
6196 vts_dbz_wt = vts_dbz_wt*1.5
6197 elseif (temp(k).ge.275.15) then
6198 vts_dbz_wt = vts_dbz_wt*2.0
6199 endif
6200 else
6201 vts_dbz_wt = 1.e-3
6202 endif
6203
6204 if (rr(k).gt.r1) then
6205 lamr = 1./ilamr(k)
6206 vtr_dbz_wt = rhof(k)*av_r*crg(13)*(lamr+fv_r)**(-cre(13)) &
6207 / (crg(4)*lamr**(-cre(4)))
6208 else
6209 vtr_dbz_wt = 1.e-3
6210 endif
6211
6212 if (rg(k).gt.r2) then
6213 lamg = 1./ilamg(k)
6214 vtg_dbz_wt = rhof(k)*av_g*cgg(5)*lamg**(-cge(5)) &
6215 / (cgg(4)*lamg**(-cge(4)))
6216 else
6217 vtg_dbz_wt = 1.e-3
6218 endif
6219
6220 vt_dbz(k) = (vts_dbz_wt*ze_snow(k) + vtr_dbz_wt*ze_rain(k) &
6221 + vtg_dbz_wt*ze_graupel(k)) &
6222 / (ze_rain(k)+ze_snow(k)+ze_graupel(k))
6223 enddo
6224 endif
6225
6226 end subroutine calc_refl10cm
6227!
6228!-------------------------------------------------------------------
6229 SUBROUTINE semi_lagrange_sedim(km,dzl,wwl,rql,precip,pfsan,dt,R1)
6230!-------------------------------------------------------------------
6231!
6232! This routine is a semi-Lagrangain forward advection for hydrometeors
6233! with mass conservation and positive definite advection
6234! 2nd order interpolation with monotonic piecewise parabolic method is used.
6235! This routine is under assumption of decfl < 1 for semi_Lagrangian
6236!
6237! dzl depth of model layer in meter
6238! wwl terminal velocity at model layer m/s
6239! rql dry air density*mixing ratio
6240! precip precipitation at surface
6241! dt time step
6242!
6243! author: hann-ming henry juang <henry.juang@noaa.gov>
6244! implemented by song-you hong
6245! reference: Juang, H.-M., and S.-Y. Hong, 2010: Forward semi-Lagrangian advection
6246! with mass conservation and positive definiteness for falling
6247! hydrometeors. *Mon. Wea. Rev.*, *138*, 1778-1791
6248!
6249 implicit none
6250
6251 integer, intent(in) :: km
6252 real, intent(in) :: dt, R1
6253 real, intent(in) :: dzl(km),wwl(km)
6254 real, intent(out) :: precip
6255 real, intent(inout) :: rql(km)
6256 real, intent(out) :: pfsan(km)
6257 integer k,m,kk,kb,kt
6258 real tl,tl2,qql,dql,qqd
6259 real th,th2,qqh,dqh
6260 real zsum,qsum,dim,dip,con1,fa1,fa2
6261 real allold, decfl
6262 real dz(km), ww(km), qq(km)
6263 real wi(km+1), zi(km+1), za(km+2)
6264 real qn(km)
6265 real dza(km+1), qa(km+1), qmi(km+1), qpi(km+1)
6266 real net_flx(km)
6267!
6268 precip = 0.0
6269 qa(:) = 0.0
6270 qq(:) = 0.0
6271 dz(:) = dzl(:)
6272 ww(:) = wwl(:)
6273 do k = 1,km
6274 if(rql(k).gt.r1) then
6275 qq(k) = rql(k)
6276 else
6277 ww(k) = 0.0
6278 endif
6279 pfsan(k) = 0.0
6280 net_flx(k) = 0.0
6281 enddo
6282! skip for no precipitation for all layers
6283 allold = 0.0
6284 do k=1,km
6285 allold = allold + qq(k)
6286 enddo
6287 if(allold.le.0.0) then
6288 return
6289 endif
6290!
6291! compute interface values
6292 zi(1)=0.0
6293 do k=1,km
6294 zi(k+1) = zi(k)+dz(k)
6295 enddo
6296! n=1
6297! plm is 2nd order, we can use 2nd order wi or 3rd order wi
6298! 2nd order interpolation to get wi
6299 wi(1) = ww(1)
6300 wi(km+1) = ww(km)
6301 do k=2,km
6302 wi(k) = (ww(k)*dz(k-1)+ww(k-1)*dz(k))/(dz(k-1)+dz(k))
6303 enddo
6304! 3rd order interpolation to get wi
6305 fa1 = 9./16.
6306 fa2 = 1./16.
6307 wi(1) = ww(1)
6308 wi(2) = 0.5*(ww(2)+ww(1))
6309 do k=3,km-1
6310 wi(k) = fa1*(ww(k)+ww(k-1))-fa2*(ww(k+1)+ww(k-2))
6311 enddo
6312 wi(km) = 0.5*(ww(km)+ww(km-1))
6313 wi(km+1) = ww(km)
6314
6315! terminate of top of raingroup
6316 do k=2,km
6317 if( ww(k).eq.0.0 ) wi(k)=ww(k-1)
6318 enddo
6319
6320! diffusivity of wi
6321 con1 = 0.05
6322 do k=km,1,-1
6323 decfl = (wi(k+1)-wi(k))*dt/dz(k)
6324 if( decfl .gt. con1 ) then
6325 wi(k) = wi(k+1) - con1*dz(k)/dt
6326 endif
6327 enddo
6328! compute arrival point
6329 do k=1,km+1
6330 za(k) = zi(k) - wi(k)*dt
6331 enddo
6332 za(km+2) = zi(km+1)
6333
6334 do k=1,km+1
6335 dza(k) = za(k+1)-za(k)
6336 enddo
6337
6338! computer deformation at arrival point
6339 do k=1,km
6340 qa(k) = qq(k)*dz(k)/dza(k)
6341 enddo
6342 qa(km+1) = 0.0
6343
6344! estimate values at arrival cell interface with monotone
6345 do k=2,km
6346 dip=(qa(k+1)-qa(k))/(dza(k+1)+dza(k))
6347 dim=(qa(k)-qa(k-1))/(dza(k-1)+dza(k))
6348 if( dip*dim.le.0.0 ) then
6349 qmi(k)=qa(k)
6350 qpi(k)=qa(k)
6351 else
6352 qpi(k)=qa(k)+0.5*(dip+dim)*dza(k)
6353 qmi(k)=2.0*qa(k)-qpi(k)
6354 if( qpi(k).lt.0.0 .or. qmi(k).lt.0.0 ) then
6355 qpi(k) = qa(k)
6356 qmi(k) = qa(k)
6357 endif
6358 endif
6359 enddo
6360 qpi(1)=qa(1)
6361 qmi(1)=qa(1)
6362 qmi(km+1)=qa(km+1)
6363 qpi(km+1)=qa(km+1)
6364
6365! interpolation to regular point
6366 qn = 0.0
6367 kb=1
6368 kt=1
6369 intp : do k=1,km
6370 kb=max(kb-1,1)
6371 kt=max(kt-1,1)
6372! find kb and kt
6373 if( zi(k).ge.za(km+1) ) then
6374 exit intp
6375 else
6376 find_kb : do kk=kb,km
6377 if( zi(k).le.za(kk+1) ) then
6378 kb = kk
6379 exit find_kb
6380 else
6381 cycle find_kb
6382 endif
6383 enddo find_kb
6384 find_kt : do kk=kt,km+2
6385 if( zi(k+1).le.za(kk) ) then
6386 kt = kk
6387 exit find_kt
6388 else
6389 cycle find_kt
6390 endif
6391 enddo find_kt
6392 kt = kt - 1
6393! compute q with piecewise constant method
6394 if( kt.eq.kb ) then
6395 tl=(zi(k)-za(kb))/dza(kb)
6396 th=(zi(k+1)-za(kb))/dza(kb)
6397 tl2=tl*tl
6398 th2=th*th
6399 qqd=0.5*(qpi(kb)-qmi(kb))
6400 qqh=qqd*th2+qmi(kb)*th
6401 qql=qqd*tl2+qmi(kb)*tl
6402 qn(k) = (qqh-qql)/(th-tl)
6403 else if( kt.gt.kb ) then
6404 tl=(zi(k)-za(kb))/dza(kb)
6405 tl2=tl*tl
6406 qqd=0.5*(qpi(kb)-qmi(kb))
6407 qql=qqd*tl2+qmi(kb)*tl
6408 dql = qa(kb)-qql
6409 zsum = (1.-tl)*dza(kb)
6410 qsum = dql*dza(kb)
6411 if( kt-kb.gt.1 ) then
6412 do m=kb+1,kt-1
6413 zsum = zsum + dza(m)
6414 qsum = qsum + qa(m) * dza(m)
6415 enddo
6416 endif
6417 th=(zi(k+1)-za(kt))/dza(kt)
6418 th2=th*th
6419 qqd=0.5*(qpi(kt)-qmi(kt))
6420 dqh=qqd*th2+qmi(kt)*th
6421 zsum = zsum + th*dza(kt)
6422 qsum = qsum + dqh*dza(kt)
6423 qn(k) = qsum/zsum
6424 endif
6425 cycle intp
6426 endif
6427
6428 enddo intp
6429
6430! rain out
6431 sum_precip: do k=1,km
6432 if( za(k).lt.0.0 .and. za(k+1).le.0.0 ) then
6433 precip = precip + qa(k)*dza(k)
6434 net_flx(k) = qa(k)*dza(k)
6435 cycle sum_precip
6436 else if ( za(k).lt.0.0 .and. za(k+1).gt.0.0 ) then
6437 th = (0.0-za(k))/dza(k)
6438 th2 = th*th
6439 qqd = 0.5*(qpi(k)-qmi(k))
6440 qqh = qqd*th2+qmi(k)*th
6441 precip = precip + qqh*dza(k)
6442 net_flx(k) = qqh*dza(k)
6443 exit sum_precip
6444 endif
6445 exit sum_precip
6446 enddo sum_precip
6447
6448! calculating precipitation fluxes
6449 do k=km,1,-1
6450 if(k == km) then
6451 pfsan(k) = net_flx(k)
6452 else
6453 pfsan(k) = pfsan(k+1) + net_flx(k)
6454 end if
6455 enddo
6456!
6457! replace the new values
6458 rql(:) = max(qn(:),r1)
6459
6460 END SUBROUTINE semi_lagrange_sedim
6461
6474subroutine graupel_psd_parameters(kts, kte, rand1, rg, ilamg, N0_g)
6475
6476 implicit none
6477
6478 integer, intent(in) :: kts, kte
6479 real, intent(in) :: rand1
6480 real, intent(in) :: rg(:)
6481 double precision, intent(out) :: ilamg(:), N0_g(:)
6482
6483 integer :: k
6484 real :: ygra1, zans1
6485 double precision :: N0_exp, lam_exp, lamg
6486
6487 do k = kte, kts, -1
6488 ygra1 = alog10(max(1.e-9, rg(k)))
6489 zans1 = 3.4 + 2./7.*(ygra1+8.) + rand1
6490 n0_exp = 10.**(zans1)
6491 n0_exp = max(dble(gonv_min), min(n0_exp, dble(gonv_max)))
6492 lam_exp = (n0_exp*am_g*cgg(1)/rg(k))**oge1
6493 lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg
6494 ilamg(k) = 1./lamg
6495 n0_g(k) = n0_exp/(cgg(2)*lam_exp) * lamg**cge(2)
6496 enddo
6497
6498end subroutine graupel_psd_parameters
6499
6513function hail_mass_99th_percentile(kts, kte, qg, temperature, pressure, qv) result(max_hail_diam)
6514
6515 implicit none
6516
6517 integer, intent(in) :: kts, kte
6518 real, intent(in) :: qg(:), temperature(:), pressure(:), qv(:)
6519 real :: max_hail_diam
6520
6521 integer :: k
6522 real :: rho(kts:kte), rg(kts:kte), max_hail_column(kts:kte)
6523 double precision :: ilamg(kts:kte), n0_g(kts:kte)
6524 real, parameter :: random_number = 0.
6525
6526 max_hail_column = 0.
6527 rg = 0.
6528 do k = kts, kte
6529 rho(k) = 0.622*pressure(k)/(r*temperature(k)*(max(1.e-10, qv(k))+0.622))
6530 if (qg(k) .gt. r1) then
6531 rg(k) = qg(k)*rho(k)
6532 else
6533 rg(k) = r1
6534 endif
6535 enddo
6536
6537 call graupel_psd_parameters(kts, kte, random_number, rg, ilamg, n0_g)
6538
6539 where(rg .gt. 1.e-9) max_hail_column = 10.05 * ilamg
6540 max_hail_diam = max_hail_column(kts)
6541
6542end function hail_mass_99th_percentile
6543
6544!+---+-----------------------------------------------------------------+
6545!+---+-----------------------------------------------------------------+
6546END MODULE module_mp_thompson
6547!+---+-----------------------------------------------------------------+
module_mp_thompson::delta_p
real function delta_p(yy, y1, y2, aa, bb)
Helper routine for Phillips et al (2008) ice nucleation.
Definition module_mp_thompson.F90:5751
module_mp_thompson::gser
subroutine gser(gamser, a, x, gln)
Returns the incomplete gamma function p(a,x) evaluated by its series representation as gamser.
Definition module_mp_thompson.F90:5488
module_mp_thompson::hail_mass_99th_percentile
real function hail_mass_99th_percentile(kts, kte, qg, temperature, pressure, qv)
Calculates graupel/hail maximum diameter.
Definition module_mp_thompson.F90:6514
module_mp_thompson::freezeh2o
subroutine freezeh2o(threads)
This is a literal adaptation of Bigg (1954) probability of drops of a particular volume freezing....
Definition module_mp_thompson.F90:4823
module_mp_thompson::qi_aut_qs
subroutine qi_aut_qs
Cloud ice converting to snow since portion greater than min snow size. Given cloud ice content (kg/m*...
Definition module_mp_thompson.F90:5002
module_mp_thompson::gcf
subroutine gcf(gammcf, a, x, gln)
Returns the incomplete gamma function q(a,x) evaluated by its continued fraction representation as ga...
Definition module_mp_thompson.F90:5449
module_mp_thompson::gammp
real function gammp(a, x)
Definition module_mp_thompson.F90:5548
module_mp_thompson::icedemott
real function icedemott(tempc, qv, qvs, qvsi, rho, nifa)
Definition module_mp_thompson.F90:5647
module_mp_thompson::eff_aero
real function eff_aero(d, da, visc, rhoa, temp, species)
Function to compute collision efficiency of collector species (rain, snow, graupel) of aerosols....
Definition module_mp_thompson.F90:5158
module_mp_thompson::rsif
real function rsif(p, t)
THIS FUNCTION CALCULATES THE ICE SATURATION VAPOR MIXING RATIO AS A FUNCTION OF TEMPERATURE AND PRESS...
Definition module_mp_thompson.F90:5617
module_mp_thompson::table_ccnact
subroutine table_ccnact(errmess, errflag)
Fill the table of CCN activation data created from parcel model run by Trude Eidhammer with inputs of...
Definition module_mp_thompson.F90:5301
module_mp_thompson::calc_refl10cm
subroutine calc_refl10cm(qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, t1d, p1d, dbz, rand1, kts, kte, ii, jj, melti, vt_dbz, first_time_step)
Compute radar reflectivity assuming 10 cm wavelength radar and using Rayleigh approximation....
Definition module_mp_thompson.F90:5919
module_mp_thompson::wgamma
real function wgamma(y)
Definition module_mp_thompson.F90:5570
module_mp_thompson::activ_ncloud
real function activ_ncloud(tt, ww, nccn, lsm_in)
Retrieve fraction of CCN that gets activated given the model temp, vertical velocity,...
Definition module_mp_thompson.F90:5357
module_mp_thompson::thompson_init
subroutine thompson_init(is_aerosol_aware_in, merra2_aerosol_aware_in, mpicomm, mpirank, mpiroot, threads, errmsg, errflg)
This subroutine calculates simplified cloud species equations and create lookup tables in Thomspson s...
Definition module_mp_thompson.F90:446
module_mp_thompson::mp_gt_driver
subroutine mp_gt_driver(wrf_chem)
This is a wrapper routine designed to transfer values from 3D to 1D.
Definition module_mp_thompson.F90:994
module_mp_thompson::rslf
real function rslf(p, t)
THIS FUNCTION CALCULATES THE LIQUID SATURATION VAPOR MIXING RATIO AS A FUNCTION OF TEMPERATURE AND PR...
Definition module_mp_thompson.F90:5582
module_mp_thompson::calc_effectrad
subroutine calc_effectrad(t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, re_qc1d, re_qi1d, re_qs1d, lsml, kts, kte)
Compute radiation effective radii of cloud water, ice, and snow. These are entirely consistent with m...
Definition module_mp_thompson.F90:5795
module_mp_thompson::table_efrw
subroutine table_efrw
Variable collision efficiency for rain collecting cloud water using method of Beard and Grover,...
Definition module_mp_thompson.F90:5052
module_mp_thompson::table_efsw
subroutine table_efsw
Variable collision efficiency for snow collecting cloud water using method of Wang and Ji,...
Definition module_mp_thompson.F90:5115
module_mp_thompson::qr_acr_qs
subroutine qr_acr_qs
Rain collecting snow (and inverse). Explicit CE integration.
Definition module_mp_thompson.F90:4564
module_mp_thompson::table_dropevap
subroutine table_dropevap
Integrate rain size distribution from zero to D-star to compute the number of drops smaller than D-st...
Definition module_mp_thompson.F90:5203
module_mp_thompson::qr_acr_qg
subroutine qr_acr_qg
Rain collecting graupel (and inverse). Explicit CE integration.
Definition module_mp_thompson.F90:4392
module_mp_thompson::gammln
real function gammln(xx)
Returns the value ln(gamma(xx)) for xx > 0.
Definition module_mp_thompson.F90:5522
module_mp_thompson::thompson_finalize
subroutine thompson_finalize()
Definition module_mp_thompson.F90:1807
module_mp_thompson::icekoop
real function icekoop(temp, qv, qvs, naero, dt)
Newer research since Koop et al (2001) suggests that the freezing rate should be lower than original ...
Definition module_mp_thompson.F90:5721
module_mp_thompson::graupel_psd_parameters
subroutine graupel_psd_parameters(kts, kte, rand1, rg, ilamg, n0_g)
Calculates graupel size distribution parameters.
Definition module_mp_thompson.F90:6475
module_mp_radar
This module is more library code whereas the individual microphysics schemes contains specific detail...
Definition module_mp_radar.F90:26
module_mp_thompson
This module computes the moisture tendencies of water vapor, cloud droplets, rain,...
Definition module_mp_thompson.F90:60
mp_thompson
This module contains the aerosol-aware Thompson microphysics scheme.
Definition mp_thompson.F90:8