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