CCPP SciDoc v7.0.x  v7.0.0
Common Community Physics Package Developed at DTC
 
Loading...
Searching...
No Matches
module_mp_thompson.F90
1
3
5
59
60module module_mp_thompson
61
62 use machine, only: 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
1048 implicit none
1049
1050!..Subroutine arguments
1051 integer, intent(in):: ids,ide, jds,jde, kds,kde, &
1052 ims,ime, jms,jme, kms,kme, &
1053 its,ite, jts,jte, kts,kte
1054 real(wp), dimension(ims:ime, kms:kme, jms:jme), intent(inout):: &
1055 qv, qc, qr, qi, qs, qg, ni, nr
1056 real(wp), dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: &
1057 tt, th
1058 real(wp), dimension(ims:ime, kms:kme, jms:jme), optional, intent(in):: &
1059 pii
1060 real(wp), dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: &
1061 nc, nwfa, nifa
1062 real(wp), dimension(ims:ime, jms:jme), optional, intent(in):: nwfa2d, nifa2d
1063 integer, dimension(ims:ime, jms:jme), intent(in):: lsm
1064 real(wp), dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: &
1065 re_cloud, re_ice, re_snow
1066 real(wp), dimension(ims:ime, kms:kme, jms:jme), intent(inout):: pfils, pflls
1067 integer, intent(in) :: rand_perturb_on, kme_stoch, n_var_spp
1068 real(wp), dimension(:,:), intent(in), optional :: rand_pert
1069 real(wp), dimension(:), intent(in), optional :: spp_prt_list, spp_stddev_cutoff
1070 character(len=10), dimension(:), intent(in), optional :: spp_var_list
1071 integer, intent(in):: has_reqc, has_reqi, has_reqs
1072#if ( WRF_CHEM == 1 )
1073 real(wp), dimension(ims:ime, kms:kme, jms:jme), intent(inout):: &
1074 rainprod, evapprod
1075#endif
1076 real(wp), dimension(ims:ime, kms:kme, jms:jme), intent(in):: &
1077 p, w, dz
1078 real(wp), dimension(ims:ime, jms:jme), intent(inout):: &
1079 RAINNC, RAINNCV, SR
1080 real(wp), dimension(ims:ime, jms:jme), optional, intent(inout):: &
1081 SNOWNC, SNOWNCV, &
1082 ICENC, ICENCV, &
1083 GRAUPELNC, GRAUPELNCV
1084 real(wp), dimension(ims:ime, kms:kme, jms:jme), intent(inout):: &
1085 refl_10cm
1086 real(wp), dimension(ims:ime, jms:jme), intent(inout):: &
1087 max_hail_diam_sfc
1088 real(wp), dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: &
1089 vt_dbz_wt
1090 logical, intent(in) :: first_time_step
1091 real(wp), intent(in):: dt_in, dt_inner
1092 logical, intent(in) :: sedi_semi
1093 integer, intent(in) :: decfl
1094 ! To support subcycling: current step and maximum number of steps
1095 integer, intent (in) :: istep, nsteps
1096 logical, intent (in) :: fullradar_diag
1097 ! Extended diagnostics, array pointers only associated if ext_diag flag is .true.
1098 logical, intent (in) :: ext_diag
1099 logical, optional, intent(in):: aero_ind_fdb
1100 real(wp), dimension(:,:,:), optional, intent(inout):: &
1101 !vts1, txri, txrc, &
1102 prw_vcdc, &
1103 prw_vcde, tpri_inu, tpri_ide_d, &
1104 tpri_ide_s, tprs_ide, &
1105 tprs_sde_d, tprs_sde_s, tprg_gde_d, &
1106 tprg_gde_s, tpri_iha, tpri_wfz, &
1107 tpri_rfz, tprg_rfz, tprs_scw, tprg_scw, &
1108 tprg_rcs, tprs_rcs, &
1109 tprr_rci, tprg_rcg, &
1110 tprw_vcd_c, tprw_vcd_e, tprr_sml, &
1111 tprr_gml, tprr_rcg, &
1112 tprr_rcs, tprv_rev, tten3, qvten3, &
1113 qrten3, qsten3, qgten3, qiten3, niten3, &
1114 nrten3, ncten3, qcten3
1115
1116 !..Local variables
1117 real(wp), dimension(kts:kte):: &
1118 qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
1119 nr1d, nc1d, nwfa1d, nifa1d, &
1120 t1d, p1d, w1d, dz1d, rho, dBZ, pfil1, pfll1
1121 !..Extended diagnostics, single column arrays
1122 real(wp), dimension(:), allocatable:: &
1123 !vtsk1, txri1, txrc1, &
1124 prw_vcdc1, &
1125 prw_vcde1, tpri_inu1, tpri_ide1_d, &
1126 tpri_ide1_s, tprs_ide1, &
1127 tprs_sde1_d, tprs_sde1_s, tprg_gde1_d, &
1128 tprg_gde1_s, tpri_iha1, tpri_wfz1, &
1129 tpri_rfz1, tprg_rfz1, tprs_scw1, tprg_scw1,&
1130 tprg_rcs1, tprs_rcs1, &
1131 tprr_rci1, tprg_rcg1, &
1132 tprw_vcd1_c, tprw_vcd1_e, tprr_sml1, &
1133 tprr_gml1, tprr_rcg1, &
1134 tprr_rcs1, tprv_rev1, tten1, qvten1, &
1135 qrten1, qsten1, qgten1, qiten1, niten1, &
1136 nrten1, ncten1, qcten1
1137
1138 real(wp), dimension(kts:kte):: re_qc1d, re_qi1d, re_qs1d
1139#if ( WRF_CHEM == 1 )
1140 real(wp), dimension(kts:kte):: &
1141 rainprod1d, evapprod1d
1142#endif
1143 real(wp), dimension(its:ite, jts:jte):: pcp_ra, pcp_sn, pcp_gr, pcp_ic
1144 real(wp) :: dt, pptrain, pptsnow, pptgraul, pptice
1145 real(wp) :: qc_max, qr_max, qs_max, qi_max, qg_max, ni_max, nr_max
1146 integer:: lsml
1147 real(wp) :: rand1, rand2, rand3, rand_pert_max
1148 integer:: i, j, k, m
1149 integer:: imax_qc,imax_qr,imax_qi,imax_qs,imax_qg,imax_ni,imax_nr
1150 integer:: jmax_qc,jmax_qr,jmax_qi,jmax_qs,jmax_qg,jmax_ni,jmax_nr
1151 integer:: kmax_qc,kmax_qr,kmax_qi,kmax_qs,kmax_qg,kmax_ni,kmax_nr
1152 integer:: i_start, j_start, i_end, j_end
1153 logical, optional, intent(in) :: diagflag
1154 integer, optional, intent(in) :: do_radar_ref
1155 logical :: melti = .false.
1156 integer :: ndt, it
1157
1158 ! CCPP error handling
1159 character(len=*), optional, intent( out) :: errmsg
1160 integer, optional, intent( out) :: errflg
1161
1162 ! CCPP
1163 if (present(errmsg)) errmsg = ''
1164 if (present(errflg)) errflg = 0
1165
1166 ! No need to test for every subcycling step
1167 test_only_once: if (first_time_step .and. istep==1) then
1168 ! Activate this code when removing the guard above
1169
1170 if ( (present(tt) .and. (present(th) .or. present(pii))) .or. &
1171 (.not.present(tt) .and. .not.(present(th) .and. present(pii))) ) then
1172 if (present(errmsg) .and. present(errflg)) then
1173 write(errmsg, '(a)') 'Logic error in mp_gt_driver: provide either tt or th+pii'
1174 errflg = 1
1175 return
1176 else
1177 write(*,'(a)') 'Logic error in mp_gt_driver: provide either tt or th+pii'
1178 stop
1179 end if
1180 end if
1181
1182 if (is_aerosol_aware .and. (.not.present(nc) .or. &
1183 .not.present(nwfa) .or. &
1184 .not.present(nifa) .or. &
1185 .not.present(nwfa2d) .or. &
1186 .not.present(nifa2d) )) then
1187 if (present(errmsg) .and. present(errflg)) then
1188 write(errmsg, '(*(a))') 'Logic error in mp_gt_driver: provide nc, nwfa, nifa, nwfa2d', &
1189 ' and nifa2d for aerosol-aware version of Thompson microphysics'
1190 errflg = 1
1191 return
1192 else
1193 write(*, '(*(a))') 'Logic error in mp_gt_driver: provide nc, nwfa, nifa, nwfa2d', &
1194 ' and nifa2d for aerosol-aware version of Thompson microphysics'
1195 stop
1196 end if
1197 else if (merra2_aerosol_aware .and. (.not.present(nc) .or. &
1198 .not.present(nwfa) .or. &
1199 .not.present(nifa) )) then
1200 if (present(errmsg) .and. present(errflg)) then
1201 write(errmsg, '(*(a))') 'Logic error in mp_gt_driver: provide nc, nwfa, and nifa', &
1202 ' for merra2 aerosol-aware version of Thompson microphysics'
1203 errflg = 1
1204 return
1205 else
1206 write(*, '(*(a))') 'Logic error in mp_gt_driver: provide nc, nwfa, and nifa', &
1207 ' for merra2 aerosol-aware version of Thompson microphysics'
1208 stop
1209 end if
1210 else if (.not.is_aerosol_aware .and. .not.merra2_aerosol_aware .and. &
1211 (present(nwfa) .or. present(nifa) .or. present(nwfa2d) .or. present(nifa2d))) then
1212 write(*,*) 'WARNING, nc/nwfa/nifa/nwfa2d/nifa2d present but is_aerosol_aware/merra2_aerosol_aware are FALSE'
1213 end if
1214 end if test_only_once
1215
1216 ! These must be alwyas allocated
1217 !allocate (vtsk1(kts:kte))
1218 !allocate (txri1(kts:kte))
1219 !allocate (txrc1(kts:kte))
1220 allocate_extended_diagnostics: if (ext_diag) then
1221 allocate (prw_vcdc1(kts:kte))
1222 allocate (prw_vcde1(kts:kte))
1223 allocate (tpri_inu1(kts:kte))
1224 allocate (tpri_ide1_d(kts:kte))
1225 allocate (tpri_ide1_s(kts:kte))
1226 allocate (tprs_ide1(kts:kte))
1227 allocate (tprs_sde1_d(kts:kte))
1228 allocate (tprs_sde1_s(kts:kte))
1229 allocate (tprg_gde1_d(kts:kte))
1230 allocate (tprg_gde1_s(kts:kte))
1231 allocate (tpri_iha1(kts:kte))
1232 allocate (tpri_wfz1(kts:kte))
1233 allocate (tpri_rfz1(kts:kte))
1234 allocate (tprg_rfz1(kts:kte))
1235 allocate (tprs_scw1(kts:kte))
1236 allocate (tprg_scw1(kts:kte))
1237 allocate (tprg_rcs1(kts:kte))
1238 allocate (tprs_rcs1(kts:kte))
1239 allocate (tprr_rci1(kts:kte))
1240 allocate (tprg_rcg1(kts:kte))
1241 allocate (tprw_vcd1_c(kts:kte))
1242 allocate (tprw_vcd1_e(kts:kte))
1243 allocate (tprr_sml1(kts:kte))
1244 allocate (tprr_gml1(kts:kte))
1245 allocate (tprr_rcg1(kts:kte))
1246 allocate (tprr_rcs1(kts:kte))
1247 allocate (tprv_rev1(kts:kte))
1248 allocate (tten1(kts:kte))
1249 allocate (qvten1(kts:kte))
1250 allocate (qrten1(kts:kte))
1251 allocate (qsten1(kts:kte))
1252 allocate (qgten1(kts:kte))
1253 allocate (qiten1(kts:kte))
1254 allocate (niten1(kts:kte))
1255 allocate (nrten1(kts:kte))
1256 allocate (ncten1(kts:kte))
1257 allocate (qcten1(kts:kte))
1258 end if allocate_extended_diagnostics
1259
1260!+---+
1261 i_start = its
1262 j_start = jts
1263 i_end = ite
1264 j_end = jte
1265
1266!..For idealized testing by developer.
1267! if ( (ide-ids+1).gt.4 .and. (jde-jds+1).lt.4 .and. &
1268! ids.eq.its.and.ide.eq.ite.and.jds.eq.jts.and.jde.eq.jte) then
1269! i_start = its + 2
1270! i_end = ite
1271! j_start = jts
1272! j_end = jte
1273! endif
1274
1275! dt = dt_in
1276 rainnc(:,:) = 0.0
1277 snownc(:,:) = 0.0
1278 icenc(:,:) = 0.0
1279 graupelnc(:,:) = 0.0
1280 pcp_ra(:,:) = 0.0
1281 pcp_sn(:,:) = 0.0
1282 pcp_gr(:,:) = 0.0
1283 pcp_ic(:,:) = 0.0
1284 pfils(:,:,:) = 0.0
1285 pflls(:,:,:) = 0.0
1286 rand_pert_max = 0.0
1287 ndt = max(nint(dt_in/dt_inner),1)
1288 dt = dt_in/ndt
1289 if(dt_in .le. dt_inner) dt= dt_in
1290
1291 !Get the Thompson MP SPP magnitude and standard deviation cutoff,
1292 !then compute rand_pert_max
1293
1294 if (rand_perturb_on .ne. 0) then
1295 do k =1,n_var_spp
1296 select case (spp_var_list(k))
1297 case('mp')
1298 rand_pert_max = spp_prt_list(k)*spp_stddev_cutoff(k)
1299 end select
1300 enddo
1301 endif
1302
1303 do it = 1, ndt
1304
1305 qc_max = 0.
1306 qr_max = 0.
1307 qs_max = 0.
1308 qi_max = 0.
1309 qg_max = 0
1310 ni_max = 0.
1311 nr_max = 0.
1312 imax_qc = 0
1313 imax_qr = 0
1314 imax_qi = 0
1315 imax_qs = 0
1316 imax_qg = 0
1317 imax_ni = 0
1318 imax_nr = 0
1319 jmax_qc = 0
1320 jmax_qr = 0
1321 jmax_qi = 0
1322 jmax_qs = 0
1323 jmax_qg = 0
1324 jmax_ni = 0
1325 jmax_nr = 0
1326 kmax_qc = 0
1327 kmax_qr = 0
1328 kmax_qi = 0
1329 kmax_qs = 0
1330 kmax_qg = 0
1331 kmax_ni = 0
1332 kmax_nr = 0
1333
1334 j_loop: do j = j_start, j_end
1335 i_loop: do i = i_start, i_end
1336
1337!+---+-----------------------------------------------------------------+
1338!..Introduce stochastic parameter perturbations by creating as many scalar rand1, rand2, ...
1339!.. variables as needed to perturb different pieces of microphysics. gthompsn 21Mar2018
1340! Setting spp_mp_opt to 1 gives graupel Y-intercept pertubations (2^0)
1341! 2 gives cloud water distribution gamma shape parameter perturbations (2^1)
1342! 4 gives CCN & IN activation perturbations (2^2)
1343! 3 gives both 1+2
1344! 5 gives both 1+4
1345! 6 gives both 2+4
1346! 7 gives all 1+2+4
1347! For now (22Mar2018), standard deviation should be up to 0.75 and cut-off at 3.0
1348! stddev in order to constrain the various perturbations from being too extreme.
1349!+---+-----------------------------------------------------------------+
1350 rand1 = 0.0
1351 rand2 = 0.0
1352 rand3 = 0.0
1353 if (rand_perturb_on .ne. 0) then
1354 if (mod(rand_perturb_on,2) .ne. 0) rand1 = rand_pert(i,1)
1355 m = rshift(abs(rand_perturb_on),1)
1356 if (mod(m,2) .ne. 0) rand2 = rand_pert(i,1)*2.
1357 m = rshift(abs(rand_perturb_on),2)
1358 if (mod(m,2) .ne. 0) rand3 = 0.25*(rand_pert(i,1)+rand_pert_max)
1359 m = rshift(abs(rand_perturb_on),3)
1360 endif
1361 !+---+-----------------------------------------------------------------+
1362
1363 pptrain = 0.
1364 pptsnow = 0.
1365 pptgraul = 0.
1366 pptice = 0.
1367 rainncv(i,j) = 0.
1368 IF ( PRESENT (snowncv) ) THEN
1369 snowncv(i,j) = 0.
1370 ENDIF
1371 IF ( PRESENT (icencv) ) THEN
1372 icencv(i,j) = 0.
1373 ENDIF
1374 IF ( PRESENT (graupelncv) ) THEN
1375 graupelncv(i,j) = 0.
1376 ENDIF
1377 sr(i,j) = 0.
1378
1379 do k = kts, kte
1380 if (present(tt)) then
1381 t1d(k) = tt(i,k,j)
1382 else
1383 t1d(k) = th(i,k,j)*pii(i,k,j)
1384 end if
1385 p1d(k) = p(i,k,j)
1386 w1d(k) = w(i,k,j)
1387 dz1d(k) = dz(i,k,j)
1388 qv1d(k) = qv(i,k,j)
1389 qc1d(k) = qc(i,k,j)
1390 qi1d(k) = qi(i,k,j)
1391 qr1d(k) = qr(i,k,j)
1392 qs1d(k) = qs(i,k,j)
1393 qg1d(k) = qg(i,k,j)
1394 ni1d(k) = ni(i,k,j)
1395 nr1d(k) = nr(i,k,j)
1396 rho(k) = roverrv*p1d(k) / (r*t1d(k)*(qv1d(k)+roverrv))
1397
1398 ! These arrays are always allocated and must be initialized
1399 !vtsk1(k) = 0.
1400 !txrc1(k) = 0.
1401 !txri1(k) = 0.
1402 initialize_extended_diagnostics: if (ext_diag) then
1403 prw_vcdc1(k) = 0.
1404 prw_vcde1(k) = 0.
1405 tpri_inu1(k) = 0.
1406 tpri_ide1_d(k) = 0.
1407 tpri_ide1_s(k) = 0.
1408 tprs_ide1(k) = 0.
1409 tprs_sde1_d(k) = 0.
1410 tprs_sde1_s(k) = 0.
1411 tprg_gde1_d(k) = 0.
1412 tprg_gde1_s(k) = 0.
1413 tpri_iha1(k) = 0.
1414 tpri_wfz1(k) = 0.
1415 tpri_rfz1(k) = 0.
1416 tprg_rfz1(k) = 0.
1417 tprs_scw1(k) = 0.
1418 tprg_scw1(k) = 0.
1419 tprg_rcs1(k) = 0.
1420 tprs_rcs1(k) = 0.
1421 tprr_rci1(k) = 0.
1422 tprg_rcg1(k) = 0.
1423 tprw_vcd1_c(k) = 0.
1424 tprw_vcd1_e(k) = 0.
1425 tprr_sml1(k) = 0.
1426 tprr_gml1(k) = 0.
1427 tprr_rcg1(k) = 0.
1428 tprr_rcs1(k) = 0.
1429 tprv_rev1(k) = 0.
1430 tten1(k) = 0.
1431 qvten1(k) = 0.
1432 qrten1(k) = 0.
1433 qsten1(k) = 0.
1434 qgten1(k) = 0.
1435 qiten1(k) = 0.
1436 niten1(k) = 0.
1437 nrten1(k) = 0.
1438 ncten1(k) = 0.
1439 qcten1(k) = 0.
1440 endif initialize_extended_diagnostics
1441 enddo
1442
1443 lsml = lsm(i,j)
1444 if (is_aerosol_aware .or. merra2_aerosol_aware) then
1445 do k = kts, kte
1446 nc1d(k) = nc(i,k,j)
1447 nwfa1d(k) = nwfa(i,k,j)
1448 nifa1d(k) = nifa(i,k,j)
1449 enddo
1450 else
1451 do k = kts, kte
1452 if(lsml == 1) then
1453 nc1d(k) = nt_c_l/rho(k)
1454 else
1455 nc1d(k) = nt_c_o/rho(k)
1456 endif
1457 nwfa1d(k) = 11.1e6
1458 nifa1d(k) = nain1*0.01
1459 enddo
1460 endif
1461
1463 call mp_thompson(qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
1464 nr1d, nc1d, nwfa1d, nifa1d, t1d, p1d, w1d, dz1d, &
1465 lsml, pptrain, pptsnow, pptgraul, pptice, &
1466#if ( WRF_CHEM == 1 )
1467 rainprod1d, evapprod1d, &
1468#endif
1469 rand1, rand2, rand3, &
1470 kts, kte, dt, i, j, ext_diag, &
1471 sedi_semi, decfl, &
1472 !vtsk1, txri1, txrc1, &
1473 prw_vcdc1, prw_vcde1, &
1474 tpri_inu1, tpri_ide1_d, tpri_ide1_s, tprs_ide1, &
1475 tprs_sde1_d, tprs_sde1_s, &
1476 tprg_gde1_d, tprg_gde1_s, tpri_iha1, tpri_wfz1, &
1477 tpri_rfz1, tprg_rfz1, tprs_scw1, tprg_scw1, &
1478 tprg_rcs1, tprs_rcs1, tprr_rci1, &
1479 tprg_rcg1, tprw_vcd1_c, &
1480 tprw_vcd1_e, tprr_sml1, tprr_gml1, tprr_rcg1, &
1481 tprr_rcs1, tprv_rev1, &
1482 tten1, qvten1, qrten1, qsten1, &
1483 qgten1, qiten1, niten1, nrten1, ncten1, qcten1, &
1484 pfil1, pfll1)
1485
1486 pcp_ra(i,j) = pcp_ra(i,j) + pptrain
1487 pcp_sn(i,j) = pcp_sn(i,j) + pptsnow
1488 pcp_gr(i,j) = pcp_gr(i,j) + pptgraul
1489 pcp_ic(i,j) = pcp_ic(i,j) + pptice
1490 rainncv(i,j) = pptrain + pptsnow + pptgraul + pptice
1491 rainnc(i,j) = rainnc(i,j) + pptrain + pptsnow + pptgraul + pptice
1492 IF ( PRESENT(snowncv) .AND. PRESENT(snownc) ) THEN
1493 ! Add ice to snow if separate ice not present
1494 IF ( .NOT.PRESENT(icencv) .OR. .NOT.PRESENT(icenc) ) THEN
1495 snowncv(i,j) = pptsnow + pptice
1496 snownc(i,j) = snownc(i,j) + pptsnow + pptice
1497 ELSE
1498 snowncv(i,j) = pptsnow
1499 snownc(i,j) = snownc(i,j) + pptsnow
1500 ENDIF
1501 ENDIF
1502 ! Use separate ice if present (as in FV3)
1503 IF ( PRESENT(icencv) .AND. PRESENT(icenc) ) THEN
1504 icencv(i,j) = pptice
1505 icenc(i,j) = icenc(i,j) + pptice
1506 ENDIF
1507 IF ( PRESENT(graupelncv) .AND. PRESENT(graupelnc) ) THEN
1508 graupelncv(i,j) = pptgraul
1509 graupelnc(i,j) = graupelnc(i,j) + pptgraul
1510 ENDIF
1511 sr(i,j) = (pptsnow + pptgraul + pptice) / (rainncv(i,j)+r1)
1512
1513!..Reset lowest model level to initial state aerosols (fake sfc source).
1514!.. Changed 13 May 2013 to fake emissions in which nwfa2d is aerosol
1515!.. number tendency (number per kg per second).
1516 if (is_aerosol_aware) then
1517 if ( PRESENT (aero_ind_fdb) ) then
1518 if ( .not. aero_ind_fdb) then
1519 nwfa1d(kts) = nwfa1d(kts) + nwfa2d(i,j)*dt
1520 nifa1d(kts) = nifa1d(kts) + nifa2d(i,j)*dt
1521 endif
1522 else
1523 nwfa1d(kts) = nwfa1d(kts) + nwfa2d(i,j)*dt
1524 nifa1d(kts) = nifa1d(kts) + nifa2d(i,j)*dt
1525 end if
1526
1527 do k = kts, kte
1528 nc(i,k,j) = nc1d(k)
1529 nwfa(i,k,j) = nwfa1d(k)
1530 nifa(i,k,j) = nifa1d(k)
1531 enddo
1532 endif
1533
1534 if (merra2_aerosol_aware) then
1535 do k = kts, kte
1536 nc(i,k,j) = nc1d(k)
1537 nwfa(i,k,j) = nwfa1d(k)
1538 nifa(i,k,j) = nifa1d(k)
1539 enddo
1540 endif
1541
1542 do k = kts, kte
1543 qv(i,k,j) = qv1d(k)
1544 qc(i,k,j) = qc1d(k)
1545 qi(i,k,j) = qi1d(k)
1546 qr(i,k,j) = qr1d(k)
1547 qs(i,k,j) = qs1d(k)
1548 qg(i,k,j) = qg1d(k)
1549 ni(i,k,j) = ni1d(k)
1550 nr(i,k,j) = nr1d(k)
1551 pfils(i,k,j) = pfils(i,k,j) + pfil1(k)
1552 pflls(i,k,j) = pflls(i,k,j) + pfll1(k)
1553 if (present(tt)) then
1554 tt(i,k,j) = t1d(k)
1555 else
1556 th(i,k,j) = t1d(k)/pii(i,k,j)
1557 endif
1558#if ( WRF_CHEM == 1 )
1559 rainprod(i,k,j) = rainprod1d(k)
1560 evapprod(i,k,j) = evapprod1d(k)
1561#endif
1562 if (qc1d(k) .gt. qc_max) then
1563 imax_qc = i
1564 jmax_qc = j
1565 kmax_qc = k
1566 qc_max = qc1d(k)
1567 elseif (qc1d(k) .lt. 0.0) then
1568 write(*,'(a,e16.7,a,3i8)') 'WARNING, negative qc ', qc1d(k), &
1569 ' at i,j,k=', i,j,k
1570 endif
1571 if (qr1d(k) .gt. qr_max) then
1572 imax_qr = i
1573 jmax_qr = j
1574 kmax_qr = k
1575 qr_max = qr1d(k)
1576 elseif (qr1d(k) .lt. 0.0) then
1577 write(*,'(a,e16.7,a,3i8)') 'WARNING, negative qr ', qr1d(k), &
1578 ' at i,j,k=', i,j,k
1579 endif
1580 if (nr1d(k) .gt. nr_max) then
1581 imax_nr = i
1582 jmax_nr = j
1583 kmax_nr = k
1584 nr_max = nr1d(k)
1585 elseif (nr1d(k) .lt. 0.0) then
1586 write(*,'(a,e16.7,a,3i8)') 'WARNING, negative nr ', nr1d(k), &
1587 ' at i,j,k=', i,j,k
1588 endif
1589 if (qs1d(k) .gt. qs_max) then
1590 imax_qs = i
1591 jmax_qs = j
1592 kmax_qs = k
1593 qs_max = qs1d(k)
1594 elseif (qs1d(k) .lt. 0.0) then
1595 write(*,'(a,e16.7,a,3i8)') 'WARNING, negative qs ', qs1d(k), &
1596 ' at i,j,k=', i,j,k
1597 endif
1598 if (qi1d(k) .gt. qi_max) then
1599 imax_qi = i
1600 jmax_qi = j
1601 kmax_qi = k
1602 qi_max = qi1d(k)
1603 elseif (qi1d(k) .lt. 0.0) then
1604 write(*,'(a,e16.7,a,3i8)') 'WARNING, negative qi ', qi1d(k), &
1605 ' at i,j,k=', i,j,k
1606 endif
1607 if (qg1d(k) .gt. qg_max) then
1608 imax_qg = i
1609 jmax_qg = j
1610 kmax_qg = k
1611 qg_max = qg1d(k)
1612 elseif (qg1d(k) .lt. 0.0) then
1613 write(*,'(a,e16.7,a,3i8)') 'WARNING, negative qg ', qg1d(k), &
1614 ' at i,j,k=', i,j,k
1615 endif
1616 if (ni1d(k) .gt. ni_max) then
1617 imax_ni = i
1618 jmax_ni = j
1619 kmax_ni = k
1620 ni_max = ni1d(k)
1621 elseif (ni1d(k) .lt. 0.0) then
1622 write(*,'(a,e16.7,a,3i8)') 'WARNING, negative ni ', ni1d(k), &
1623 ' at i,j,k=', i,j,k
1624 endif
1625 if (qv1d(k) .lt. 0.0) then
1626 write(*,'(a,e16.7,a,3i8)') 'WARNING, negative qv ', qv1d(k), &
1627 ' at i,j,k=', i,j,k
1628 if (k.lt.kte-2 .and. k.gt.kts+1) then
1629 write(*,*) ' below and above are: ', qv(i,k-1,j), qv(i,k+1,j)
1630 qv(i,k,j) = max(1.e-7, 0.5*(qv(i,k-1,j) + qv(i,k+1,j)))
1631 else
1632 qv(i,k,j) = 1.e-7
1633 endif
1634 endif
1635 enddo
1636
1637 assign_extended_diagnostics: if (ext_diag) then
1638 do k=kts,kte
1639 !vts1(i,k,j) = vtsk1(k)
1640 !txri(i,k,j) = txri(i,k,j) + txri1(k)
1641 !txrc(i,k,j) = txrc(i,k,j) + txrc1(k)
1642 prw_vcdc(i,k,j) = prw_vcdc(i,k,j) + prw_vcdc1(k)
1643 prw_vcde(i,k,j) = prw_vcde(i,k,j) + prw_vcde1(k)
1644 tpri_inu(i,k,j) = tpri_inu(i,k,j) + tpri_inu1(k)
1645 tpri_ide_d(i,k,j) = tpri_ide_d(i,k,j) + tpri_ide1_d(k)
1646 tpri_ide_s(i,k,j) = tpri_ide_s(i,k,j) + tpri_ide1_s(k)
1647 tprs_ide(i,k,j) = tprs_ide(i,k,j) + tprs_ide1(k)
1648 tprs_sde_s(i,k,j) = tprs_sde_s(i,k,j) + tprs_sde1_s(k)
1649 tprs_sde_d(i,k,j) = tprs_sde_d(i,k,j) + tprs_sde1_d(k)
1650 tprg_gde_d(i,k,j) = tprg_gde_d(i,k,j) + tprg_gde1_d(k)
1651 tprg_gde_s(i,k,j) = tprg_gde_s(i,k,j) + tprg_gde1_s(k)
1652 tpri_iha(i,k,j) = tpri_iha(i,k,j) + tpri_iha1(k)
1653 tpri_wfz(i,k,j) = tpri_wfz(i,k,j) + tpri_wfz1(k)
1654 tpri_rfz(i,k,j) = tpri_rfz(i,k,j) + tpri_rfz1(k)
1655 tprg_rfz(i,k,j) = tprg_rfz(i,k,j) + tprg_rfz1(k)
1656 tprs_scw(i,k,j) = tprs_scw(i,k,j) + tprs_scw1(k)
1657 tprg_scw(i,k,j) = tprg_scw(i,k,j) + tprg_scw1(k)
1658 tprg_rcs(i,k,j) = tprg_rcs(i,k,j) + tprg_rcs1(k)
1659 tprs_rcs(i,k,j) = tprs_rcs(i,k,j) + tprs_rcs1(k)
1660 tprr_rci(i,k,j) = tprr_rci(i,k,j) + tprr_rci1(k)
1661 tprg_rcg(i,k,j) = tprg_rcg(i,k,j) + tprg_rcg1(k)
1662 tprw_vcd_c(i,k,j) = tprw_vcd_c(i,k,j) + tprw_vcd1_c(k)
1663 tprw_vcd_e(i,k,j) = tprw_vcd_e(i,k,j) + tprw_vcd1_e(k)
1664 tprr_sml(i,k,j) = tprr_sml(i,k,j) + tprr_sml1(k)
1665 tprr_gml(i,k,j) = tprr_gml(i,k,j) + tprr_gml1(k)
1666 tprr_rcg(i,k,j) = tprr_rcg(i,k,j) + tprr_rcg1(k)
1667 tprr_rcs(i,k,j) = tprr_rcs(i,k,j) + tprr_rcs1(k)
1668 tprv_rev(i,k,j) = tprv_rev(i,k,j) + tprv_rev1(k)
1669 tten3(i,k,j) = tten3(i,k,j) + tten1(k)
1670 qvten3(i,k,j) = qvten3(i,k,j) + qvten1(k)
1671 qrten3(i,k,j) = qrten3(i,k,j) + qrten1(k)
1672 qsten3(i,k,j) = qsten3(i,k,j) + qsten1(k)
1673 qgten3(i,k,j) = qgten3(i,k,j) + qgten1(k)
1674 qiten3(i,k,j) = qiten3(i,k,j) + qiten1(k)
1675 niten3(i,k,j) = niten3(i,k,j) + niten1(k)
1676 nrten3(i,k,j) = nrten3(i,k,j) + nrten1(k)
1677 ncten3(i,k,j) = ncten3(i,k,j) + ncten1(k)
1678 qcten3(i,k,j) = qcten3(i,k,j) + qcten1(k)
1679 enddo
1680 endif assign_extended_diagnostics
1681
1682 if (ndt>1 .and. it==ndt) then
1683 sr(i,j) = (pcp_sn(i,j) + pcp_gr(i,j) + pcp_ic(i,j)) / (rainnc(i,j)+r1)
1684 rainncv(i,j) = rainnc(i,j)
1685 IF ( PRESENT (snowncv) ) THEN
1686 snowncv(i,j) = snownc(i,j)
1687 ENDIF
1688 IF ( PRESENT (icencv) ) THEN
1689 icencv(i,j) = icenc(i,j)
1690 ENDIF
1691 IF ( PRESENT (graupelncv) ) THEN
1692 graupelncv(i,j) = graupelnc(i,j)
1693 ENDIF
1694 endif
1695
1696 ! Diagnostic calculations only for last step
1697 ! if Thompson MP is called multiple times
1698 last_step_only: IF ((ndt>1 .and. it==ndt) .or. &
1699 (nsteps>1 .and. istep==nsteps) .or. &
1700 (nsteps==1 .and. ndt==1)) THEN
1701
1702 max_hail_diam_sfc(i,j) = hail_mass_99th_percentile(kts, kte, qg1d, t1d, p1d, qv1d)
1703
1705
1706 diagflag_present: IF ( PRESENT (diagflag) ) THEN
1707 if (diagflag .and. do_radar_ref == 1) then
1708 !
1709 ! Only set melti to true at the output times
1710 if (fullradar_diag) then
1711 melti=.true.
1712 else
1713 melti=.false.
1714 endif
1715 !
1716 if (present(vt_dbz_wt)) then
1717 call calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, &
1718 t1d, p1d, dbz, rand1, kts, kte, i, j, &
1719 melti, vt_dbz_wt(i,:,j), &
1720 first_time_step)
1721 else
1722 call calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, &
1723 t1d, p1d, dbz, rand1, kts, kte, i, j, &
1724 melti)
1725 endif
1726 do k = kts, kte
1727 refl_10cm(i,k,j) = max(-35., dbz(k))
1728 enddo
1729 endif
1730 ENDIF diagflag_present
1731
1732 IF (has_reqc.ne.0 .and. has_reqi.ne.0 .and. has_reqs.ne.0) THEN
1733 do k = kts, kte
1734 re_qc1d(k) = re_qc_min
1735 re_qi1d(k) = re_qi_min
1736 re_qs1d(k) = re_qs_min
1737 enddo
1739 call calc_effectrad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, &
1740 re_qc1d, re_qi1d, re_qs1d, lsml, kts, kte)
1741 do k = kts, kte
1742 re_cloud(i,k,j) = max(re_qc_min, min(re_qc1d(k), re_qc_max))
1743 re_ice(i,k,j) = max(re_qi_min, min(re_qi1d(k), re_qi_max))
1744 re_snow(i,k,j) = max(re_qs_min, min(re_qs1d(k), re_qs_max))
1745 enddo
1746 ENDIF
1747 ENDIF last_step_only
1748 enddo i_loop
1749 enddo j_loop
1750
1751! DEBUG - GT
1752! write(*,'(a,7(a,e13.6,1x,a,i3,a,i3,a,i3,a,1x))') 'MP-GT:', &
1753! 'qc: ', qc_max, '(', imax_qc, ',', jmax_qc, ',', kmax_qc, ')', &
1754! 'qr: ', qr_max, '(', imax_qr, ',', jmax_qr, ',', kmax_qr, ')', &
1755! 'qi: ', qi_max, '(', imax_qi, ',', jmax_qi, ',', kmax_qi, ')', &
1756! 'qs: ', qs_max, '(', imax_qs, ',', jmax_qs, ',', kmax_qs, ')', &
1757! 'qg: ', qg_max, '(', imax_qg, ',', jmax_qg, ',', kmax_qg, ')', &
1758! 'ni: ', ni_max, '(', imax_ni, ',', jmax_ni, ',', kmax_ni, ')', &
1759! 'nr: ', nr_max, '(', imax_nr, ',', jmax_nr, ',', kmax_nr, ')'
1760! END DEBUG - GT
1761 enddo ! end of nt loop
1762
1763 do j = j_start, j_end
1764 do k = kts, kte
1765 do i = i_start, i_end
1766 pfils(i,k,j) = pfils(i,k,j)/dt_in
1767 pflls(i,k,j) = pflls(i,k,j)/dt_in
1768 enddo
1769 enddo
1770 enddo
1771
1772 ! These are always allocated
1773 !deallocate (vtsk1)
1774 !deallocate (txri1)
1775 !deallocate (txrc1)
1776 deallocate_extended_diagnostics: if (ext_diag) then
1777 deallocate (prw_vcdc1)
1778 deallocate (prw_vcde1)
1779 deallocate (tpri_inu1)
1780 deallocate (tpri_ide1_d)
1781 deallocate (tpri_ide1_s)
1782 deallocate (tprs_ide1)
1783 deallocate (tprs_sde1_d)
1784 deallocate (tprs_sde1_s)
1785 deallocate (tprg_gde1_d)
1786 deallocate (tprg_gde1_s)
1787 deallocate (tpri_iha1)
1788 deallocate (tpri_wfz1)
1789 deallocate (tpri_rfz1)
1790 deallocate (tprg_rfz1)
1791 deallocate (tprs_scw1)
1792 deallocate (tprg_scw1)
1793 deallocate (tprg_rcs1)
1794 deallocate (tprs_rcs1)
1795 deallocate (tprr_rci1)
1796 deallocate (tprg_rcg1)
1797 deallocate (tprw_vcd1_c)
1798 deallocate (tprw_vcd1_e)
1799 deallocate (tprr_sml1)
1800 deallocate (tprr_gml1)
1801 deallocate (tprr_rcg1)
1802 deallocate (tprr_rcs1)
1803 deallocate (tprv_rev1)
1804 deallocate (tten1)
1805 deallocate (qvten1)
1806 deallocate (qrten1)
1807 deallocate (qsten1)
1808 deallocate (qgten1)
1809 deallocate (qiten1)
1810 deallocate (niten1)
1811 deallocate (nrten1)
1812 deallocate (ncten1)
1813 deallocate (qcten1)
1814 end if deallocate_extended_diagnostics
1815
1816 end subroutine mp_gt_driver
1818
1820 subroutine thompson_finalize()
1821
1822 implicit none
1823
1824 if (ALLOCATED(tcg_racg)) DEALLOCATE(tcg_racg)
1825 if (ALLOCATED(tmr_racg)) DEALLOCATE(tmr_racg)
1826 if (ALLOCATED(tcr_gacr)) DEALLOCATE(tcr_gacr)
1827 if (ALLOCATED(tmg_gacr)) DEALLOCATE(tmg_gacr)
1828 if (ALLOCATED(tnr_racg)) DEALLOCATE(tnr_racg)
1829 if (ALLOCATED(tnr_gacr)) DEALLOCATE(tnr_gacr)
1830
1831 if (ALLOCATED(tcs_racs1)) DEALLOCATE(tcs_racs1)
1832 if (ALLOCATED(tmr_racs1)) DEALLOCATE(tmr_racs1)
1833 if (ALLOCATED(tcs_racs2)) DEALLOCATE(tcs_racs2)
1834 if (ALLOCATED(tmr_racs2)) DEALLOCATE(tmr_racs2)
1835 if (ALLOCATED(tcr_sacr1)) DEALLOCATE(tcr_sacr1)
1836 if (ALLOCATED(tms_sacr1)) DEALLOCATE(tms_sacr1)
1837 if (ALLOCATED(tcr_sacr2)) DEALLOCATE(tcr_sacr2)
1838 if (ALLOCATED(tms_sacr2)) DEALLOCATE(tms_sacr2)
1839 if (ALLOCATED(tnr_racs1)) DEALLOCATE(tnr_racs1)
1840 if (ALLOCATED(tnr_racs2)) DEALLOCATE(tnr_racs2)
1841 if (ALLOCATED(tnr_sacr1)) DEALLOCATE(tnr_sacr1)
1842 if (ALLOCATED(tnr_sacr2)) DEALLOCATE(tnr_sacr2)
1843
1844 if (ALLOCATED(tpi_qcfz)) DEALLOCATE(tpi_qcfz)
1845 if (ALLOCATED(tni_qcfz)) DEALLOCATE(tni_qcfz)
1846
1847 if (ALLOCATED(tpi_qrfz)) DEALLOCATE(tpi_qrfz)
1848 if (ALLOCATED(tpg_qrfz)) DEALLOCATE(tpg_qrfz)
1849 if (ALLOCATED(tni_qrfz)) DEALLOCATE(tni_qrfz)
1850 if (ALLOCATED(tnr_qrfz)) DEALLOCATE(tnr_qrfz)
1851
1852 if (ALLOCATED(tps_iaus)) DEALLOCATE(tps_iaus)
1853 if (ALLOCATED(tni_iaus)) DEALLOCATE(tni_iaus)
1854 if (ALLOCATED(tpi_ide)) DEALLOCATE(tpi_ide)
1855
1856 if (ALLOCATED(t_efrw)) DEALLOCATE(t_efrw)
1857 if (ALLOCATED(t_efsw)) DEALLOCATE(t_efsw)
1858
1859 if (ALLOCATED(tnr_rev)) DEALLOCATE(tnr_rev)
1860 if (ALLOCATED(tpc_wev)) DEALLOCATE(tpc_wev)
1861 if (ALLOCATED(tnc_wev)) DEALLOCATE(tnc_wev)
1862
1863 if (ALLOCATED(tnccn_act)) DEALLOCATE(tnccn_act)
1864
1865 end subroutine thompson_finalize
1866
1867!+---+-----------------------------------------------------------------+
1868!ctrlL
1869!+---+-----------------------------------------------------------------+
1870!+---+-----------------------------------------------------------------+
1871
1880 subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
1881 nr1d, nc1d, nwfa1d, nifa1d, t1d, p1d, w1d, dzq, &
1882 lsml, pptrain, pptsnow, pptgraul, pptice, &
1883#if ( WRF_CHEM == 1 )
1884 rainprod, evapprod, &
1885#endif
1886 rand1, rand2, rand3, &
1887 kts, kte, dt, ii, jj, &
1888 ! Extended diagnostics, most arrays only
1889 ! allocated if ext_diag flag is .true.
1890 ext_diag, &
1891 sedi_semi, decfl, &
1892 !vtsk1, txri1, txrc1, &
1893 prw_vcdc1, prw_vcde1, &
1894 tpri_inu1, tpri_ide1_d, tpri_ide1_s, tprs_ide1, &
1895 tprs_sde1_d, tprs_sde1_s, &
1896 tprg_gde1_d, tprg_gde1_s, tpri_iha1, tpri_wfz1, &
1897 tpri_rfz1, tprg_rfz1, tprs_scw1, tprg_scw1, &
1898 tprg_rcs1, tprs_rcs1, tprr_rci1, &
1899 tprg_rcg1, tprw_vcd1_c, &
1900 tprw_vcd1_e, tprr_sml1, tprr_gml1, tprr_rcg1, &
1901 tprr_rcs1, tprv_rev1, &
1902 tten1, qvten1, qrten1, qsten1, &
1903 qgten1, qiten1, niten1, nrten1, ncten1, qcten1, &
1904 pfil1, pfll1)
1905
1906 use mpi_f08
1907
1908 implicit none
1909
1910!..Sub arguments
1911 integer, intent(in):: kts, kte, ii, jj
1912 real(wp), dimension(kts:kte), intent(inout) :: &
1913 qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
1914 nr1d, nc1d, nwfa1d, nifa1d, t1d
1915 real(wp), dimension(kts:kte), intent(out) :: pfil1, pfll1
1916 real(wp), dimension(kts:kte), intent(in) :: p1d, w1d, dzq
1917 real(wp), intent(inout) :: pptrain, pptsnow, pptgraul, pptice
1918 real(wp), intent(in) :: dt
1919 integer, intent(in) :: lsml
1920 real(wp), intent(in) :: rand1, rand2, rand3
1921 ! Extended diagnostics, most arrays only allocated if ext_diag is true
1922 logical, intent(in) :: ext_diag
1923 logical, intent(in) :: sedi_semi
1924 integer, intent(in) :: decfl
1925 real(wp), dimension(:), intent(out), optional :: &
1926 !vtsk1, txri1, txrc1, &
1927 prw_vcdc1, &
1928 prw_vcde1, tpri_inu1, tpri_ide1_d, &
1929 tpri_ide1_s, tprs_ide1, &
1930 tprs_sde1_d, tprs_sde1_s, tprg_gde1_d, &
1931 tprg_gde1_s, tpri_iha1, tpri_wfz1, &
1932 tpri_rfz1, tprg_rfz1, tprs_scw1, tprg_scw1,&
1933 tprg_rcs1, tprs_rcs1, &
1934 tprr_rci1, tprg_rcg1, &
1935 tprw_vcd1_c, tprw_vcd1_e, tprr_sml1, &
1936 tprr_gml1, tprr_rcg1, &
1937 tprr_rcs1, tprv_rev1, tten1, qvten1, &
1938 qrten1, qsten1, qgten1, qiten1, niten1, &
1939 nrten1, ncten1, qcten1
1940
1941#if ( WRF_CHEM == 1 )
1942 real(wp), dimension(kts:kte), intent(inout) :: &
1943 rainprod, evapprod
1944#endif
1945
1946!..Local variables
1947 real(wp), dimension(kts:kte) :: tten, qvten, qcten, qiten, &
1948 qrten, qsten, qgten, niten, nrten, ncten, nwfaten, nifaten
1949
1950 real(dp), dimension(kts:kte) :: prw_vcd
1951
1952 real(dp), dimension(kts:kte) :: pnc_wcd, pnc_wau, pnc_rcw, &
1953 pnc_scw, pnc_gcw
1954
1955 real(dp), dimension(kts:kte) :: pna_rca, pna_sca, pna_gca, &
1956 pnd_rcd, pnd_scd, pnd_gcd
1957
1958 real(dp), dimension(kts:kte) :: prr_wau, prr_rcw, prr_rcs, &
1959 prr_rcg, prr_sml, prr_gml, &
1960 prr_rci, prv_rev, &
1961 pnr_wau, pnr_rcs, pnr_rcg, &
1962 pnr_rci, pnr_sml, pnr_gml, &
1963 pnr_rev, pnr_rcr, pnr_rfz
1964
1965 real(dp), dimension(kts:kte) :: pri_inu, pni_inu, pri_ihm, &
1966 pni_ihm, pri_wfz, pni_wfz, &
1967 pri_rfz, pni_rfz, pri_ide, &
1968 pni_ide, pri_rci, pni_rci, &
1969 pni_sci, pni_iau, pri_iha, pni_iha
1970
1971 real(dp), dimension(kts:kte) :: prs_iau, prs_sci, prs_rcs, &
1972 prs_scw, prs_sde, prs_ihm, &
1973 prs_ide
1974
1975 real(dp), dimension(kts:kte) :: prg_scw, prg_rfz, prg_gde, &
1976 prg_gcw, prg_rci, prg_rcs, &
1977 prg_rcg, prg_ihm
1978
1979 real(dp), parameter:: zeroD0 = 0.0
1980 real(wp) :: dtcfl, rainsfc, graulsfc
1981 integer :: niter
1982
1983 real(wp), dimension(kts:kte) :: temp, pres, qv, pfll, pfil, pdummy
1984 real(wp), dimension(kts:kte) :: rc, ri, rr, rs, rg, ni, nr, nc, nwfa, nifa
1985 real(wp), dimension(kts:kte) :: rr_tmp, nr_tmp, rg_tmp
1986 real(wp), dimension(kts:kte) :: rho, rhof, rhof2
1987 real(wp), dimension(kts:kte) :: qvs, qvsi, delQvs
1988 real(wp), dimension(kts:kte) :: satw, sati, ssatw, ssati
1989 real(wp), dimension(kts:kte) :: diffu, visco, vsc2, &
1990 tcond, lvap, ocp, lvt2
1991
1992 real(dp), dimension(kts:kte) :: ilamr, ilamg, N0_r, N0_g
1993 real(wp), dimension(kts:kte) :: mvd_r, mvd_c
1994 real(wp), dimension(kts:kte) :: smob, smo2, smo1, smo0, &
1995 smoc, smod, smoe, smof
1996
1997 real(wp), dimension(kts:kte) :: sed_r, sed_s, sed_g, sed_i, sed_n,sed_c
1998
1999 real(wp) :: rgvm, delta_tp, orho, lfus2, orhodt
2000 real(wp), dimension(5):: onstep
2001 real(dp) :: N0_exp, N0_min, lam_exp, lamc, lamr, lamg
2002 real(dp) :: lami, ilami, ilamc
2003 real(wp) :: xDc, Dc_b, Dc_g, xDi, xDr, xDs, xDg, Ds_m, Dg_m
2004 real(dp) :: Dr_star, Dc_star
2005 real(wp) :: zeta1, zeta, taud, tau
2006 real(wp) :: stoke_r, stoke_s, stoke_g, stoke_i
2007 real(wp) :: vti, vtr, vts, vtg, vtc
2008 real(wp), dimension(kts:kte+1):: vtik, vtnik, vtrk, vtnrk, vtsk, vtgk, &
2009 vtck, vtnck
2010 real(wp), dimension(kts:kte):: vts_boost
2011 real(wp) :: Mrat, ils1, ils2, t1_vts, t2_vts, t3_vts, t4_vts, C_snow
2012 real(wp) :: a_, b_, loga_, A1, A2, tf
2013 real(wp) :: tempc, tc0, r_mvd1, r_mvd2, xkrat
2014 real(wp) :: xnc, xri, xni, xmi, oxmi, xrc, xrr, xnr
2015 real(wp) :: xsat, rate_max, sump, ratio
2016 real(wp) :: clap, fcd, dfcd
2017 real(wp) :: otemp, rvs, rvs_p, rvs_pp, gamsc, alphsc, t1_evap, t1_subl
2018 real(wp) :: r_frac, g_frac
2019 real(wp) :: Ef_rw, Ef_sw, Ef_gw, Ef_rr
2020 real(wp) :: Ef_ra, Ef_sa, Ef_ga
2021 real(wp) :: dtsave, odts, odt, odzq, hgt_agl, SR
2022 real(wp) :: xslw1, ygra1, zans1, eva_factor
2023 integer :: i, k, k2, n, nn, nstep, k_0, kbot, IT, iexfrq
2024 integer, dimension(5) :: ksed1
2025 integer :: nir, nis, nig, nii, nic, niin
2026 integer :: idx_tc, idx_t, idx_s, idx_g1, idx_g, idx_r1, idx_r, &
2027 idx_i1, idx_i, idx_c, idx, idx_d, idx_n, idx_in
2028
2029 logical :: no_micro
2030 logical, dimension(kts:kte) :: L_qc, L_qi, L_qr, L_qs, L_qg
2031 logical :: debug_flag
2032 integer :: nu_c
2033
2034!+---+
2035
2036 debug_flag = .false.
2037! if (ii.eq.901 .and. jj.eq.379) debug_flag = .true.
2038 if(debug_flag) then
2039 write(*, *) 'DEBUG INFO, mp_thompson at (i,j) ', ii, ', ', jj
2040 endif
2041
2042 no_micro = .true.
2043 dtsave = dt
2044 odt = 1./dt
2045 odts = 1./dtsave
2046 iexfrq = 1
2047
2048!+---+-----------------------------------------------------------------+
2061!+---+-----------------------------------------------------------------+
2062
2063 do k = kts, kte
2064 tten(k) = 0.
2065 qvten(k) = 0.
2066 qcten(k) = 0.
2067 qiten(k) = 0.
2068 qrten(k) = 0.
2069 qsten(k) = 0.
2070 qgten(k) = 0.
2071 niten(k) = 0.
2072 nrten(k) = 0.
2073 ncten(k) = 0.
2074 nwfaten(k) = 0.
2075 nifaten(k) = 0.
2076
2077 prw_vcd(k) = 0.
2078
2079 pnc_wcd(k) = 0.
2080 pnc_wau(k) = 0.
2081 pnc_rcw(k) = 0.
2082 pnc_scw(k) = 0.
2083 pnc_gcw(k) = 0.
2084
2085 prv_rev(k) = 0.
2086 prr_wau(k) = 0.
2087 prr_rcw(k) = 0.
2088 prr_rcs(k) = 0.
2089 prr_rcg(k) = 0.
2090 prr_sml(k) = 0.
2091 prr_gml(k) = 0.
2092 prr_rci(k) = 0.
2093 pnr_wau(k) = 0.
2094 pnr_rcs(k) = 0.
2095 pnr_rcg(k) = 0.
2096 pnr_rci(k) = 0.
2097 pnr_sml(k) = 0.
2098 pnr_gml(k) = 0.
2099 pnr_rev(k) = 0.
2100 pnr_rcr(k) = 0.
2101 pnr_rfz(k) = 0.
2102
2103 pri_inu(k) = 0.
2104 pni_inu(k) = 0.
2105 pri_ihm(k) = 0.
2106 pni_ihm(k) = 0.
2107 pri_wfz(k) = 0.
2108 pni_wfz(k) = 0.
2109 pri_rfz(k) = 0.
2110 pni_rfz(k) = 0.
2111 pri_ide(k) = 0.
2112 pni_ide(k) = 0.
2113 pri_rci(k) = 0.
2114 pni_rci(k) = 0.
2115 pni_sci(k) = 0.
2116 pni_iau(k) = 0.
2117 pri_iha(k) = 0.
2118 pni_iha(k) = 0.
2119
2120 prs_iau(k) = 0.
2121 prs_sci(k) = 0.
2122 prs_rcs(k) = 0.
2123 prs_scw(k) = 0.
2124 prs_sde(k) = 0.
2125 prs_ihm(k) = 0.
2126 prs_ide(k) = 0.
2127
2128 prg_scw(k) = 0.
2129 prg_rfz(k) = 0.
2130 prg_gde(k) = 0.
2131 prg_gcw(k) = 0.
2132 prg_rci(k) = 0.
2133 prg_rcs(k) = 0.
2134 prg_rcg(k) = 0.
2135 prg_ihm(k) = 0.
2136
2137 pna_rca(k) = 0.
2138 pna_sca(k) = 0.
2139 pna_gca(k) = 0.
2140
2141 pnd_rcd(k) = 0.
2142 pnd_scd(k) = 0.
2143 pnd_gcd(k) = 0.
2144
2145 pfil1(k) = 0.
2146 pfll1(k) = 0.
2147 pfil(k) = 0.
2148 pfll(k) = 0.
2149 pdummy(k) = 0.
2150 enddo
2151#if ( WRF_CHEM == 1 )
2152 do k = kts, kte
2153 rainprod(k) = 0.
2154 evapprod(k) = 0.
2155 enddo
2156#endif
2157
2158!Diagnostics
2159 if (ext_diag) then
2160 do k = kts, kte
2161 !vtsk1(k) = 0.
2162 !txrc1(k) = 0.
2163 !txri1(k) = 0.
2164 prw_vcdc1(k) = 0.
2165 prw_vcde1(k) = 0.
2166 tpri_inu1(k) = 0.
2167 tpri_ide1_d(k) = 0.
2168 tpri_ide1_s(k) = 0.
2169 tprs_ide1(k) = 0.
2170 tprs_sde1_d(k) = 0.
2171 tprs_sde1_s(k) = 0.
2172 tprg_gde1_d(k) = 0.
2173 tprg_gde1_s(k) = 0.
2174 tpri_iha1(k) = 0.
2175 tpri_wfz1(k) = 0.
2176 tpri_rfz1(k) = 0.
2177 tprg_rfz1(k) = 0.
2178 tprg_scw1(k) = 0.
2179 tprs_scw1(k) = 0.
2180 tprg_rcs1(k) = 0.
2181 tprs_rcs1(k) = 0.
2182 tprr_rci1(k) = 0.
2183 tprg_rcg1(k) = 0.
2184 tprw_vcd1_c(k) = 0.
2185 tprw_vcd1_e(k) = 0.
2186 tprr_sml1(k) = 0.
2187 tprr_gml1(k) = 0.
2188 tprr_rcg1(k) = 0.
2189 tprr_rcs1(k) = 0.
2190 tprv_rev1(k) = 0.
2191 tten1(k) = 0.
2192 qvten1(k) = 0.
2193 qrten1(k) = 0.
2194 qsten1(k) = 0.
2195 qgten1(k) = 0.
2196 qiten1(k) = 0.
2197 niten1(k) = 0.
2198 nrten1(k) = 0.
2199 ncten1(k) = 0.
2200 qcten1(k) = 0.
2201 enddo
2202 endif
2203
2204!..Bug fix (2016Jun15), prevent use of uninitialized value(s) of snow moments.
2205 do k = kts, kte
2206 smo0(k) = 0.
2207 smo1(k) = 0.
2208 smo2(k) = 0.
2209 smob(k) = 0.
2210 smoc(k) = 0.
2211 smod(k) = 0.
2212 smoe(k) = 0.
2213 smof(k) = 0.
2214 enddo
2215
2216!+---+-----------------------------------------------------------------+
2218!+---+-----------------------------------------------------------------+
2219 do k = kts, kte
2220 temp(k) = t1d(k)
2221 qv(k) = max(1.e-10, qv1d(k))
2222 pres(k) = p1d(k)
2223 rho(k) = roverrv*pres(k) / (r*temp(k)*(qv(k)+roverrv))
2224 nwfa(k) = max(11.1e6*rho(k), min(9999.e6*rho(k), nwfa1d(k)*rho(k)))
2225 nifa(k) = max(nain1*0.01*rho(k), min(9999.e6*rho(k), nifa1d(k)*rho(k)))
2226 mvd_r(k) = d0r
2227 mvd_c(k) = d0c
2228
2229 if (qc1d(k) .gt. r1) then
2230 no_micro = .false.
2231 rc(k) = qc1d(k)*rho(k)
2232 nc(k) = max(2., min(nc1d(k)*rho(k), nt_c_max))
2233 l_qc(k) = .true.
2234 if (nc(k).gt.10000.e6) then
2235 nu_c = 2
2236 elseif (nc(k).lt.100.) then
2237 nu_c = 15
2238 else
2239 nu_c = nint(1000.e6/nc(k)) + 2
2240 nu_c = max(2, min(nu_c+nint(rand2), 15))
2241 endif
2242 lamc = (nc(k)*am_r*ccg(2,nu_c)*ocg1(nu_c)/rc(k))**obmr
2243 xdc = (bm_r + nu_c + 1.) / lamc
2244 if (xdc.lt. d0c) then
2245 lamc = cce(2,nu_c)/d0c
2246 elseif (xdc.gt. d0r*2.) then
2247 lamc = cce(2,nu_c)/(d0r*2.)
2248 endif
2249 nc(k) = min(real(nt_c_max, kind=dp), ccg(1,nu_c)*ocg2(nu_c)*rc(k) &
2250 / am_r*lamc**bm_r)
2251 if (.NOT. (is_aerosol_aware .or. merra2_aerosol_aware)) then
2252 if (lsml == 1) then
2253 nc(k) = nt_c_l
2254 else
2255 nc(k) = nt_c_o
2256 endif
2257 endif
2258 else
2259 qc1d(k) = 0.0
2260 nc1d(k) = 0.0
2261 rc(k) = r1
2262 nc(k) = 2.
2263 l_qc(k) = .false.
2264 endif
2265
2266 if (qi1d(k) .gt. r1) then
2267 no_micro = .false.
2268 ri(k) = qi1d(k)*rho(k)
2269 ni(k) = max(r2, ni1d(k)*rho(k))
2270 if (ni(k).le. r2) then
2271 lami = cie(2)/5.e-6
2272 ni(k) = min(nt_i_max, cig(1)*oig2*ri(k)/am_i*lami**bm_i)
2273 endif
2274 l_qi(k) = .true.
2275 lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi
2276 ilami = 1./lami
2277 xdi = (bm_i + mu_i + 1.) * ilami
2278 if (xdi.lt. 5.e-6) 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 elseif (xdi.gt. 300.e-6) then
2282 lami = cie(2)/300.e-6
2283 ni(k) = cig(1)*oig2*ri(k)/am_i*lami**bm_i
2284 endif
2285 else
2286 qi1d(k) = 0.0
2287 ni1d(k) = 0.0
2288 ri(k) = r1
2289 ni(k) = r2
2290 l_qi(k) = .false.
2291 endif
2292
2293 if (qr1d(k) .gt. r1) then
2294 no_micro = .false.
2295 rr(k) = qr1d(k)*rho(k)
2296 nr(k) = max(r2, nr1d(k)*rho(k))
2297 if (nr(k).le. r2) then
2298 mvd_r(k) = 1.0e-3
2299 lamr = (3.0 + mu_r + 0.672) / mvd_r(k)
2300 nr(k) = crg(2)*org3*rr(k)*lamr**bm_r / am_r
2301 endif
2302 l_qr(k) = .true.
2303 lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr
2304 mvd_r(k) = (3.0 + mu_r + 0.672) / lamr
2305 if (mvd_r(k) .gt. 2.5e-3) then
2306 mvd_r(k) = 2.5e-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 elseif (mvd_r(k) .lt. d0r*0.75) then
2310 mvd_r(k) = d0r*0.75
2311 lamr = (3.0 + mu_r + 0.672) / mvd_r(k)
2312 nr(k) = crg(2)*org3*rr(k)*lamr**bm_r / am_r
2313 endif
2314 else
2315 qr1d(k) = 0.0
2316 nr1d(k) = 0.0
2317 rr(k) = r1
2318 nr(k) = r2
2319 l_qr(k) = .false.
2320 endif
2321 if (qs1d(k) .gt. r1) then
2322 no_micro = .false.
2323 rs(k) = qs1d(k)*rho(k)
2324 l_qs(k) = .true.
2325 else
2326 qs1d(k) = 0.0
2327 rs(k) = r1
2328 l_qs(k) = .false.
2329 endif
2330 if (qg1d(k) .gt. r1) then
2331 no_micro = .false.
2332 rg(k) = qg1d(k)*rho(k)
2333 l_qg(k) = .true.
2334 else
2335 qg1d(k) = 0.0
2336 rg(k) = r1
2337 l_qg(k) = .false.
2338 endif
2339 enddo
2340
2341!+---+-----------------------------------------------------------------+
2342! if (debug_flag) then
2343! do k = kts, kte
2344! write(*, '(a,i3,f8.2,1x,f7.2,1x, 11(1x,e13.6))') &
2345! & '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)
2346! enddo
2347! endif
2348!+---+-----------------------------------------------------------------+
2349
2350!+---+-----------------------------------------------------------------+
2355!+---+-----------------------------------------------------------------+
2356 do k = kts, kte
2357 tempc = temp(k) - 273.15
2358 rhof(k) = sqrt(rho_not/rho(k))
2359 rhof2(k) = sqrt(rhof(k))
2360 qvs(k) = rslf(pres(k), temp(k))
2361 delqvs(k) = max(0.0, rslf(pres(k), 273.15)-qv(k))
2362 if (tempc .le. 0.0) then
2363 qvsi(k) = rsif(pres(k), temp(k))
2364 else
2365 qvsi(k) = qvs(k)
2366 endif
2367 satw(k) = qv(k)/qvs(k)
2368 sati(k) = qv(k)/qvsi(k)
2369 ssatw(k) = satw(k) - 1.
2370 ssati(k) = sati(k) - 1.
2371 if (abs(ssatw(k)).lt. eps) ssatw(k) = 0.0
2372 if (abs(ssati(k)).lt. eps) ssati(k) = 0.0
2373 if (no_micro .and. ssati(k).gt. 0.0) no_micro = .false.
2374 diffu(k) = 2.11e-5*(temp(k)/273.15)**1.94 * (101325./pres(k))
2375 if (tempc .ge. 0.0) then
2376 visco(k) = (1.718+0.0049*tempc)*1.0e-5
2377 else
2378 visco(k) = (1.718+0.0049*tempc-1.2e-5*tempc*tempc)*1.0e-5
2379 endif
2380 ocp(k) = 1./(cp*(1.+0.887*qv(k)))
2381 vsc2(k) = sqrt(rho(k)/visco(k))
2382 lvap(k) = lvap0 + (2106.0 - 4218.0)*tempc
2383 tcond(k) = (5.69 + 0.0168*tempc)*1.0e-5 * 418.936
2384 enddo
2385
2386!+---+-----------------------------------------------------------------+
2389!+---+-----------------------------------------------------------------+
2390
2391 if (no_micro) return
2392
2393!+---+-----------------------------------------------------------------+
2395!+---+-----------------------------------------------------------------+
2396 if (.not. iiwarm) then
2397 do k = kts, kte
2398 if (.not. l_qs(k)) cycle
2399 tc0 = min(-0.1, temp(k)-273.15)
2400 smob(k) = rs(k)*oams
2401
2404 if (bm_s.gt.(2.0-1.e-3) .and. bm_s.lt.(2.0+1.e-3)) then
2405 smo2(k) = smob(k)
2406 else
2407 loga_ = sa(1) + sa(2)*tc0 + sa(3)*bm_s &
2408 + sa(4)*tc0*bm_s + sa(5)*tc0*tc0 &
2409 + sa(6)*bm_s*bm_s + sa(7)*tc0*tc0*bm_s &
2410 + sa(8)*tc0*bm_s*bm_s + sa(9)*tc0*tc0*tc0 &
2411 + sa(10)*bm_s*bm_s*bm_s
2412 a_ = 10.0**loga_
2413 b_ = sb(1) + sb(2)*tc0 + sb(3)*bm_s &
2414 + sb(4)*tc0*bm_s + sb(5)*tc0*tc0 &
2415 + sb(6)*bm_s*bm_s + sb(7)*tc0*tc0*bm_s &
2416 + sb(8)*tc0*bm_s*bm_s + sb(9)*tc0*tc0*tc0 &
2417 + sb(10)*bm_s*bm_s*bm_s
2418 smo2(k) = (smob(k)/a_)**(1./b_)
2419 endif
2420
2422 loga_ = sa(1) + sa(2)*tc0 + sa(5)*tc0*tc0 + sa(9)*tc0*tc0*tc0
2423 a_ = 10.0**loga_
2424 b_ = sb(1) + sb(2)*tc0 + sb(5)*tc0*tc0 + sb(9)*tc0*tc0*tc0
2425 smo0(k) = a_ * smo2(k)**b_
2426
2428 loga_ = sa(1) + sa(2)*tc0 + sa(3) &
2429 + sa(4)*tc0 + sa(5)*tc0*tc0 &
2430 + sa(6) + sa(7)*tc0*tc0 &
2431 + sa(8)*tc0 + sa(9)*tc0*tc0*tc0 &
2432 + sa(10)
2433 a_ = 10.0**loga_
2434 b_ = sb(1)+ sb(2)*tc0 + sb(3) + sb(4)*tc0 &
2435 + sb(5)*tc0*tc0 + sb(6) &
2436 + sb(7)*tc0*tc0 + sb(8)*tc0 &
2437 + sb(9)*tc0*tc0*tc0 + sb(10)
2438 smo1(k) = a_ * smo2(k)**b_
2439
2441 loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(1) &
2442 + sa(4)*tc0*cse(1) + sa(5)*tc0*tc0 &
2443 + sa(6)*cse(1)*cse(1) + sa(7)*tc0*tc0*cse(1) &
2444 + sa(8)*tc0*cse(1)*cse(1) + sa(9)*tc0*tc0*tc0 &
2445 + sa(10)*cse(1)*cse(1)*cse(1)
2446 a_ = 10.0**loga_
2447 b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(1) + sb(4)*tc0*cse(1) &
2448 + sb(5)*tc0*tc0 + sb(6)*cse(1)*cse(1) &
2449 + sb(7)*tc0*tc0*cse(1) + sb(8)*tc0*cse(1)*cse(1) &
2450 + sb(9)*tc0*tc0*tc0 + sb(10)*cse(1)*cse(1)*cse(1)
2451 smoc(k) = a_ * smo2(k)**b_
2452
2454 loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(13) &
2455 + sa(4)*tc0*cse(13) + sa(5)*tc0*tc0 &
2456 + sa(6)*cse(13)*cse(13) + sa(7)*tc0*tc0*cse(13) &
2457 + sa(8)*tc0*cse(13)*cse(13) + sa(9)*tc0*tc0*tc0 &
2458 + sa(10)*cse(13)*cse(13)*cse(13)
2459 a_ = 10.0**loga_
2460 b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(13) + sb(4)*tc0*cse(13) &
2461 + sb(5)*tc0*tc0 + sb(6)*cse(13)*cse(13) &
2462 + sb(7)*tc0*tc0*cse(13) + sb(8)*tc0*cse(13)*cse(13) &
2463 + sb(9)*tc0*tc0*tc0 + sb(10)*cse(13)*cse(13)*cse(13)
2464 smoe(k) = a_ * smo2(k)**b_
2465
2467 loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(16) &
2468 + sa(4)*tc0*cse(16) + sa(5)*tc0*tc0 &
2469 + sa(6)*cse(16)*cse(16) + sa(7)*tc0*tc0*cse(16) &
2470 + sa(8)*tc0*cse(16)*cse(16) + sa(9)*tc0*tc0*tc0 &
2471 + sa(10)*cse(16)*cse(16)*cse(16)
2472 a_ = 10.0**loga_
2473 b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(16) + sb(4)*tc0*cse(16) &
2474 + sb(5)*tc0*tc0 + sb(6)*cse(16)*cse(16) &
2475 + sb(7)*tc0*tc0*cse(16) + sb(8)*tc0*cse(16)*cse(16) &
2476 + sb(9)*tc0*tc0*tc0 + sb(10)*cse(16)*cse(16)*cse(16)
2477 smof(k) = a_ * smo2(k)**b_
2478 enddo
2479
2480!+---+-----------------------------------------------------------------+
2482!+---+-----------------------------------------------------------------+
2483 call graupel_psd_parameters(kts, kte, rand1, rg, ilamg, n0_g)
2484 endif
2485
2486!+---+-----------------------------------------------------------------+
2488!+---+-----------------------------------------------------------------+
2489 do k = kte, kts, -1
2490 lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr
2491 ilamr(k) = 1./lamr
2492 mvd_r(k) = (3.0 + mu_r + 0.672) / lamr
2493 n0_r(k) = nr(k)*org2*lamr**cre(2)
2494 enddo
2495
2496!+---+-----------------------------------------------------------------+
2498!+---+-----------------------------------------------------------------+
2499
2500 do k = kts, kte
2501
2504 if (l_qr(k) .and. mvd_r(k).gt. d0r) then
2505 ef_rr = max(-0.1, 1.0 - exp(2300.0*(mvd_r(k)-1950.0e-6)))
2506 pnr_rcr(k) = ef_rr * 2.0*nr(k)*rr(k)
2507 endif
2508
2509 if (l_qc(k)) then
2510 if (nc(k).gt.10000.e6) then
2511 nu_c = 2
2512 elseif (nc(k).lt.100.) then
2513 nu_c = 15
2514 else
2515 nu_c = nint(1000.e6/nc(k)) + 2
2516 nu_c = max(2, min(nu_c+nint(rand2), 15))
2517 endif
2518 xdc = max(d0c*1.e6, ((rc(k)/(am_r*nc(k)))**obmr) * 1.e6)
2519 lamc = (nc(k)*am_r* ccg(2,nu_c) * ocg1(nu_c) / rc(k))**obmr
2520 mvd_c(k) = (3.0+nu_c+0.672) / lamc
2521 mvd_c(k) = max(d0c, min(mvd_c(k), d0r))
2522 endif
2523
2526 if (rc(k).gt. 0.01e-3) then
2527 dc_g = ((ccg(3,nu_c)*ocg2(nu_c))**obmr / lamc) * 1.e6
2528 dc_b = (xdc*xdc*xdc*dc_g*dc_g*dc_g - xdc*xdc*xdc*xdc*xdc*xdc) &
2529 **(1./6.)
2530 zeta1 = 0.5*((6.25e-6*xdc*dc_b*dc_b*dc_b - 0.4) &
2531 + abs(6.25e-6*xdc*dc_b*dc_b*dc_b - 0.4))
2532 zeta = 0.027*rc(k)*zeta1
2533 taud = 0.5*((0.5*dc_b - 7.5) + abs(0.5*dc_b - 7.5)) + r1
2534 tau = 3.72/(rc(k)*taud)
2535 prr_wau(k) = zeta/tau
2536 prr_wau(k) = min(real(rc(k)*odts, kind=dp), prr_wau(k))
2537 pnr_wau(k) = prr_wau(k) / (am_r*nu_c*10.*d0r*d0r*d0r) ! RAIN2M
2538 pnc_wau(k) = min(real(nc(k)*odts, kind=dp), prr_wau(k) &
2539 / (am_r*mvd_c(k)*mvd_c(k)*mvd_c(k))) ! Qc2M
2540 endif
2541
2543 if (l_qr(k) .and. mvd_r(k).gt. d0r .and. mvd_c(k).gt. d0c) then
2544 lamr = 1./ilamr(k)
2545 idx = 1 + int(nbr*log(real(mvd_r(k)/dr(1), kind=dp)) / log(dr(nbr)/dr(1)))
2546 idx = min(idx, nbr)
2547 ef_rw = t_efrw(idx, int(mvd_c(k)*1.e6))
2548 prr_rcw(k) = rhof(k)*t1_qr_qc*ef_rw*rc(k)*n0_r(k) &
2549 *((lamr+fv_r)**(-cre(9)))
2550 prr_rcw(k) = min(real(rc(k)*odts, kind=dp), prr_rcw(k))
2551 pnc_rcw(k) = rhof(k)*t1_qr_qc*ef_rw*nc(k)*n0_r(k) &
2552 *((lamr+fv_r)**(-cre(9))) ! Qc2M
2553 pnc_rcw(k) = min(real(nc(k)*odts, kind=dp), pnc_rcw(k))
2554 endif
2555
2557 if (l_qr(k) .and. mvd_r(k).gt. d0r) then
2558 ef_ra = eff_aero(mvd_r(k),0.04e-6,visco(k),rho(k),temp(k),'r')
2559 lamr = 1./ilamr(k)
2560 pna_rca(k) = rhof(k)*t1_qr_qc*ef_ra*nwfa(k)*n0_r(k) &
2561 *((lamr+fv_r)**(-cre(9)))
2562 pna_rca(k) = min(real(nwfa(k)*odts, kind=dp), pna_rca(k))
2563
2564 ef_ra = eff_aero(mvd_r(k),0.8e-6,visco(k),rho(k),temp(k),'r')
2565 pnd_rcd(k) = rhof(k)*t1_qr_qc*ef_ra*nifa(k)*n0_r(k) &
2566 *((lamr+fv_r)**(-cre(9)))
2567 pnd_rcd(k) = min(real(nifa(k)*odts, kind=dp), pnd_rcd(k))
2568 endif
2569
2570 enddo
2571
2572!+---+-----------------------------------------------------------------+
2574!+---+-----------------------------------------------------------------+
2575 if (.not. iiwarm) then
2576 do k = kts, kte
2577 vts_boost(k) = 1.0
2578 xds = 0.0
2579 if (l_qs(k)) xds = smoc(k) / smob(k)
2580
2582 tempc = temp(k) - 273.15
2583 idx_tc = max(1, min(nint(-tempc), 45) )
2584 idx_t = int( (tempc-2.5)/5. ) - 1
2585 idx_t = max(1, -idx_t)
2586 idx_t = min(idx_t, ntb_t)
2587 it = max(1, min(nint(-tempc), 31) )
2588
2590 if (rc(k).gt. r_c(1)) then
2591 nic = nint(log10(rc(k)))
2592 do_loop_rc: do nn = nic-1, nic+1
2593 n = nn
2594 if ( (rc(k)/10.**nn).ge.1.0 .and. (rc(k)/10.**nn).lt.10.0 ) exit do_loop_rc
2595 enddo do_loop_rc
2596 idx_c = int(rc(k)/10.**n) + 10*(n-nic2) - (n-nic2)
2597 idx_c = max(1, min(idx_c, ntb_c))
2598 else
2599 idx_c = 1
2600 endif
2601
2603 idx_n = nint(1.0 + real(nbc, kind=wp) * log(real(nc(k)/t_nc(1), kind=dp)) / nic1)
2604 idx_n = max(1, min(idx_n, nbc))
2605
2607 if (ri(k).gt. r_i(1)) then
2608 nii = nint(log10(ri(k)))
2609 do_loop_ri: do nn = nii-1, nii+1
2610 n = nn
2611 if ( (ri(k)/10.**nn).ge.1.0 .and. (ri(k)/10.**nn).lt.10.0 ) exit do_loop_ri
2612 enddo do_loop_ri
2613 idx_i = int(ri(k)/10.**n) + 10*(n-nii2) - (n-nii2)
2614 idx_i = max(1, min(idx_i, ntb_i))
2615 else
2616 idx_i = 1
2617 endif
2618
2619 if (ni(k).gt. nt_i(1)) then
2620 nii = nint(log10(ni(k)))
2621 do_loop_ni: do nn = nii-1, nii+1
2622 n = nn
2623 if ( (ni(k)/10.**nn).ge.1.0 .and. (ni(k)/10.**nn).lt.10.0 ) exit do_loop_ni
2624 enddo do_loop_ni
2625 idx_i1 = int(ni(k)/10.**n) + 10*(n-nii3) - (n-nii3)
2626 idx_i1 = max(1, min(idx_i1, ntb_i1))
2627 else
2628 idx_i1 = 1
2629 endif
2630
2632 if (rr(k).gt. r_r(1)) then
2633 nir = nint(log10(rr(k)))
2634 do_loop_rr: do nn = nir-1, nir+1
2635 n = nn
2636 if ( (rr(k)/10.**nn).ge.1.0 .and. (rr(k)/10.**nn).lt.10.0 ) exit do_loop_rr
2637 enddo do_loop_rr
2638 idx_r = int(rr(k)/10.**n) + 10*(n-nir2) - (n-nir2)
2639 idx_r = max(1, min(idx_r, ntb_r))
2640
2641 lamr = 1./ilamr(k)
2642 lam_exp = lamr * (crg(3)*org2*org1)**bm_r
2643 n0_exp = org1*rr(k)/am_r * lam_exp**cre(1)
2644 nir = nint(log10(n0_exp))
2645 do_loop_nr: do nn = nir-1, nir+1
2646 n = nn
2647 if ( (n0_exp/10.**nn).ge.1.0 .and. (n0_exp/10.**nn).lt.10.0 ) exit do_loop_nr
2648 enddo do_loop_nr
2649 idx_r1 = int(n0_exp/10.**n) + 10*(n-nir3) - (n-nir3)
2650 idx_r1 = max(1, min(idx_r1, ntb_r1))
2651 else
2652 idx_r = 1
2653 idx_r1 = ntb_r1
2654 endif
2655
2657 if (rs(k).gt. r_s(1)) then
2658 nis = nint(log10(rs(k)))
2659 do_loop_rs: do nn = nis-1, nis+1
2660 n = nn
2661 if ( (rs(k)/10.**nn).ge.1.0 .and. (rs(k)/10.**nn).lt.10.0 ) exit do_loop_rs
2662 enddo do_loop_rs
2663 idx_s = int(rs(k)/10.**n) + 10*(n-nis2) - (n-nis2)
2664 idx_s = max(1, min(idx_s, ntb_s))
2665 else
2666 idx_s = 1
2667 endif
2668
2670 if (rg(k).gt. r_g(1)) then
2671 nig = nint(log10(rg(k)))
2672 do_loop_rg: do nn = nig-1, nig+1
2673 n = nn
2674 if ( (rg(k)/10.**nn).ge.1.0 .and. (rg(k)/10.**nn).lt.10.0 ) exit do_loop_rg
2675 enddo do_loop_rg
2676 idx_g = int(rg(k)/10.**n) + 10*(n-nig2) - (n-nig2)
2677 idx_g = max(1, min(idx_g, ntb_g))
2678
2679 lamg = 1./ilamg(k)
2680 lam_exp = lamg * (cgg(3)*ogg2*ogg1)**bm_g
2681 n0_exp = ogg1*rg(k)/am_g * lam_exp**cge(1)
2682 nig = nint(log10(real(n0_exp, kind=dp)))
2683 do_loop_ng: do nn = nig-1, nig+1
2684 n = nn
2685 if ( (n0_exp/10.**nn).ge.1.0 .and. (n0_exp/10.**nn).lt.10.0 ) exit do_loop_ng
2686 enddo do_loop_ng
2687 idx_g1 = int(n0_exp/10.**n) + 10*(n-nig3) - (n-nig3)
2688 idx_g1 = max(1, min(idx_g1, ntb_g1))
2689 else
2690 idx_g = 1
2691 idx_g1 = ntb_g1
2692 endif
2693
2695 otemp = 1./temp(k)
2696 rvs = rho(k)*qvsi(k)
2697 rvs_p = rvs*otemp*(lsub*otemp*orv - 1.)
2698 rvs_pp = rvs * ( otemp*(lsub*otemp*orv - 1.) &
2699 *otemp*(lsub*otemp*orv - 1.) &
2700 + (-2.*lsub*otemp*otemp*otemp*orv) &
2701 + otemp*otemp)
2702 gamsc = lsub*diffu(k)/tcond(k) * rvs_p
2703 alphsc = 0.5*(gamsc/(1.+gamsc))*(gamsc/(1.+gamsc)) &
2704 * rvs_pp/rvs_p * rvs/rvs_p
2705 alphsc = max(1.e-9, alphsc)
2706 xsat = ssati(k)
2707 if (abs(xsat).lt. 1.e-9) xsat=0.
2708 t1_subl = 4.*pi*( 1.0 - alphsc*xsat &
2709 + 2.*alphsc*alphsc*xsat*xsat &
2710 - 5.*alphsc*alphsc*alphsc*xsat*xsat*xsat ) &
2711 / (1.+gamsc)
2712
2714 if (l_qc(k) .and. mvd_c(k).gt. d0c) then
2715 if (xds .gt. d0s) then
2716 idx = 1 + int(nbs*log(real(xds/ds(1), kind=dp)) / log(ds(nbs)/ds(1)))
2717 idx = min(idx, nbs)
2718 ef_sw = t_efsw(idx, int(mvd_c(k)*1.e6))
2719 prs_scw(k) = rhof(k)*t1_qs_qc*ef_sw*rc(k)*smoe(k)
2720 prs_scw(k) = min(real(rc(k)*odts, kind=dp), prs_scw(k))
2721 pnc_scw(k) = rhof(k)*t1_qs_qc*ef_sw*nc(k)*smoe(k) ! Qc2M
2722 pnc_scw(k) = min(real(nc(k)*odts, kind=dp), pnc_scw(k))
2723 endif
2724
2726 if (rg(k).ge. r_g(1) .and. mvd_c(k).gt. d0c) then
2727 xdg = (bm_g + mu_g + 1.) * ilamg(k)
2728 vtg = rhof(k)*av_g*cgg(6)*ogg3 * ilamg(k)**bv_g
2729 stoke_g = mvd_c(k)*mvd_c(k)*vtg*rho_w/(9.*visco(k)*xdg)
2730 if (xdg.gt. d0g) then
2731 if (stoke_g.ge.0.4 .and. stoke_g.le.10.) then
2732 ef_gw = 0.55*log10(2.51*stoke_g)
2733 elseif (stoke_g.lt.0.4) then
2734 ef_gw = 0.0
2735 elseif (stoke_g.gt.10) then
2736 ef_gw = 0.77
2737 endif
2738 prg_gcw(k) = rhof(k)*t1_qg_qc*ef_gw*rc(k)*n0_g(k) &
2739 *ilamg(k)**cge(9)
2740 pnc_gcw(k) = rhof(k)*t1_qg_qc*ef_gw*nc(k)*n0_g(k) &
2741 *ilamg(k)**cge(9) ! Qc2M
2742 pnc_gcw(k) = min(real(nc(k)*odts, kind=dp), pnc_gcw(k))
2743 endif
2744 endif
2745 endif
2746
2748 if (rs(k) .gt. r_s(1)) then
2749 ef_sa = eff_aero(xds,0.04e-6,visco(k),rho(k),temp(k),'s')
2750 pna_sca(k) = rhof(k)*t1_qs_qc*ef_sa*nwfa(k)*smoe(k)
2751 pna_sca(k) = min(real(nwfa(k)*odts, kind=dp), pna_sca(k))
2752
2753 ef_sa = eff_aero(xds,0.8e-6,visco(k),rho(k),temp(k),'s')
2754 pnd_scd(k) = rhof(k)*t1_qs_qc*ef_sa*nifa(k)*smoe(k)
2755 pnd_scd(k) = min(real(nifa(k)*odts, kind=dp), pnd_scd(k))
2756 endif
2757 if (rg(k) .gt. r_g(1)) then
2758 xdg = (bm_g + mu_g + 1.) * ilamg(k)
2759 ef_ga = eff_aero(xdg,0.04e-6,visco(k),rho(k),temp(k),'g')
2760 pna_gca(k) = rhof(k)*t1_qg_qc*ef_ga*nwfa(k)*n0_g(k) &
2761 *ilamg(k)**cge(9)
2762 pna_gca(k) = min(real(nwfa(k)*odts, kind=dp), pna_gca(k))
2763
2764 ef_ga = eff_aero(xdg,0.8e-6,visco(k),rho(k),temp(k),'g')
2765 pnd_gcd(k) = rhof(k)*t1_qg_qc*ef_ga*nifa(k)*n0_g(k) &
2766 *ilamg(k)**cge(9)
2767 pnd_gcd(k) = min(real(nifa(k)*odts, kind=dp), pnd_gcd(k))
2768 endif
2769
2773 if (rr(k).ge. r_r(1)) then
2774 if (rs(k).ge. r_s(1)) then
2775 if (temp(k).lt.t_0) then
2776 prr_rcs(k) = -(tmr_racs2(idx_s,idx_t,idx_r1,idx_r) &
2777 + tcr_sacr2(idx_s,idx_t,idx_r1,idx_r) &
2778 + tmr_racs1(idx_s,idx_t,idx_r1,idx_r) &
2779 + tcr_sacr1(idx_s,idx_t,idx_r1,idx_r))
2780 prs_rcs(k) = tmr_racs2(idx_s,idx_t,idx_r1,idx_r) &
2781 + tcr_sacr2(idx_s,idx_t,idx_r1,idx_r) &
2782 - tcs_racs1(idx_s,idx_t,idx_r1,idx_r) &
2783 - tms_sacr1(idx_s,idx_t,idx_r1,idx_r)
2784 prg_rcs(k) = tmr_racs1(idx_s,idx_t,idx_r1,idx_r) &
2785 + tcr_sacr1(idx_s,idx_t,idx_r1,idx_r) &
2786 + tcs_racs1(idx_s,idx_t,idx_r1,idx_r) &
2787 + tms_sacr1(idx_s,idx_t,idx_r1,idx_r)
2788 prr_rcs(k) = max(real(-rr(k)*odts, kind=dp), prr_rcs(k))
2789 prs_rcs(k) = max(real(-rs(k)*odts, kind=dp), prs_rcs(k))
2790 prg_rcs(k) = min(real((rr(k)+rs(k))*odts, kind=dp), prg_rcs(k))
2791 pnr_rcs(k) = tnr_racs1(idx_s,idx_t,idx_r1,idx_r) & ! RAIN2M
2792 + tnr_racs2(idx_s,idx_t,idx_r1,idx_r) &
2793 + tnr_sacr1(idx_s,idx_t,idx_r1,idx_r) &
2794 + tnr_sacr2(idx_s,idx_t,idx_r1,idx_r)
2795 pnr_rcs(k) = min(real(nr(k)*odts, kind=dp), pnr_rcs(k))
2796 else
2797 prs_rcs(k) = -tcs_racs1(idx_s,idx_t,idx_r1,idx_r) &
2798 - tms_sacr1(idx_s,idx_t,idx_r1,idx_r) &
2799 + tmr_racs2(idx_s,idx_t,idx_r1,idx_r) &
2800 + tcr_sacr2(idx_s,idx_t,idx_r1,idx_r)
2801 prs_rcs(k) = max(real(-rs(k)*odts, kind=dp), prs_rcs(k))
2802 prr_rcs(k) = -prs_rcs(k)
2803 endif
2804 endif
2805
2809 if (rg(k).ge. r_g(1)) then
2810 if (temp(k).lt.t_0) then
2811 prg_rcg(k) = tmr_racg(idx_g1,idx_g,idx_r1,idx_r) &
2812 + tcr_gacr(idx_g1,idx_g,idx_r1,idx_r)
2813 prg_rcg(k) = min(real(rr(k)*odts, kind=dp), prg_rcg(k))
2814 prr_rcg(k) = -prg_rcg(k)
2815 pnr_rcg(k) = tnr_racg(idx_g1,idx_g,idx_r1,idx_r) & ! RAIN2M
2816 + tnr_gacr(idx_g1,idx_g,idx_r1,idx_r)
2817 pnr_rcg(k) = min(real(nr(k)*odts, kind=dp), pnr_rcg(k))
2818 else
2819 prr_rcg(k) = tcg_racg(idx_g1,idx_g,idx_r1,idx_r)
2820 prr_rcg(k) = min(real(rg(k)*odts, kind=dp), prr_rcg(k))
2821 prg_rcg(k) = -prr_rcg(k)
2823 pnr_rcg(k) = -1.5*tnr_gacr(idx_g1,idx_g,idx_r1,idx_r) ! RAIN2M
2824 endif
2825 endif
2826 endif
2827
2828 if (temp(k).lt.t_0) then
2829 rate_max = (qv(k)-qvsi(k))*rho(k)*odts*0.999
2830
2832 if (l_qs(k)) then
2833 c_snow = c_sqrd + (tempc+1.5)*(c_cube-c_sqrd)/(-30.+1.5)
2834 c_snow = max(c_sqrd, min(c_snow, c_cube))
2835 prs_sde(k) = c_snow*t1_subl*diffu(k)*ssati(k)*rvs &
2836 * (t1_qs_sd*smo1(k) &
2837 + t2_qs_sd*rhof2(k)*vsc2(k)*smof(k))
2838 if (prs_sde(k).lt. 0.) then
2839 prs_sde(k) = max(real(-rs(k)*odts, kind=dp), prs_sde(k), real(rate_max, kind=dp))
2840 else
2841 prs_sde(k) = min(prs_sde(k), real(rate_max, kind=dp))
2842 endif
2843 endif
2844
2845 if (l_qg(k) .and. ssati(k).lt. -eps) then
2846 prg_gde(k) = c_cube*t1_subl*diffu(k)*ssati(k)*rvs &
2847 * n0_g(k) * (t1_qg_sd*ilamg(k)**cge(10) &
2848 + t2_qg_sd*vsc2(k)*rhof2(k)*ilamg(k)**cge(11))
2849 if (prg_gde(k).lt. 0.) then
2850 prg_gde(k) = max(real(-rg(k)*odts, kind=dp), prg_gde(k), real(rate_max, kind=dp))
2851 else
2852 prg_gde(k) = min(prg_gde(k), real(rate_max, kind=dp))
2853 endif
2854 endif
2855
2860 if (prs_scw(k).gt.5.0*prs_sde(k) .and. &
2861 prs_sde(k).gt.eps) then
2862 r_frac = min(30.0_dp, prs_scw(k)/prs_sde(k))
2863 g_frac = min(0.75, 0.15 + (r_frac-5.)*.028)
2864 vts_boost(k) = min(1.5, 1.1 + (r_frac-5.)*.016)
2865 prg_scw(k) = g_frac*prs_scw(k)
2866 prs_scw(k) = (1. - g_frac)*prs_scw(k)
2867 endif
2868 endif
2869
2870!+---+-----------------------------------------------------------------+
2872!+---+-----------------------------------------------------------------+
2873
2874 if (temp(k).lt.t_0) then
2875
2876 rate_max = (qv(k)-qvsi(k))*rho(k)*odts*0.999
2877
2878!+---+---------------- BEGIN NEW ICE NUCLEATION -----------------------+
2890!+---+-----------------------------------------------------------------+
2891
2892 if (dustyice .AND. (is_aerosol_aware .or. merra2_aerosol_aware)) then
2893 xni = icedemott(tempc,qvs(k),qvs(k),qvsi(k),rho(k),nifa(k))
2894 else
2895 xni = 1.0 *1000. ! Default is 1.0 per Liter
2896 endif
2897
2899 if (xni.gt. nt_in(1)) then
2900 niin = nint(log10(xni))
2901 do_loop_xni: do nn = niin-1, niin+1
2902 n = nn
2903 if ( (xni/10.**nn).ge.1.0 .and. (xni/10.**nn).lt.10.0 ) exit do_loop_xni
2904 enddo do_loop_xni
2905 idx_in = int(xni/10.**n) + 10*(n-niin2) - (n-niin2)
2906 idx_in = max(1, min(idx_in, ntb_in))
2907 else
2908 idx_in = 1
2909 endif
2910
2912 if (rr(k).gt. r_r(1)) then
2913 prg_rfz(k) = tpg_qrfz(idx_r,idx_r1,idx_tc,idx_in)*odts
2914 pri_rfz(k) = tpi_qrfz(idx_r,idx_r1,idx_tc,idx_in)*odts
2915 pni_rfz(k) = tni_qrfz(idx_r,idx_r1,idx_tc,idx_in)*odts
2916 pnr_rfz(k) = tnr_qrfz(idx_r,idx_r1,idx_tc,idx_in)*odts ! RAIN2M
2917 pnr_rfz(k) = min(real(nr(k)*odts, kind=dp), pnr_rfz(k))
2918 elseif (rr(k).gt. r1 .and. temp(k).lt.hgfr) then
2919 pri_rfz(k) = rr(k)*odts
2920 pni_rfz(k) = pnr_rfz(k)
2921 endif
2922
2923 if (rc(k).gt. r_c(1)) then
2924 pri_wfz(k) = tpi_qcfz(idx_c,idx_n,idx_tc,idx_in)*odts
2925 pri_wfz(k) = min(real(rc(k)*odts, kind=dp), pri_wfz(k))
2926 pni_wfz(k) = tni_qcfz(idx_c,idx_n,idx_tc,idx_in)*odts
2927 pni_wfz(k) = min(real(nc(k)*odts, kind=dp), pri_wfz(k)/(2.0_dp*xm0i), &
2928 pni_wfz(k))
2929 elseif (rc(k).gt. r1 .and. temp(k).lt.hgfr) then
2930 pri_wfz(k) = rc(k)*odts
2931 pni_wfz(k) = nc(k)*odts
2932 endif
2933
2936 if ( (ssati(k).ge. ssati_min) .or. (ssatw(k).gt. eps &
2937 .and. temp(k).lt.253.15) ) then
2938 if (dustyice .AND. (is_aerosol_aware .or. merra2_aerosol_aware)) then
2939 xnc = icedemott(tempc,qv(k),qvs(k),qvsi(k),rho(k),nifa(k))
2940 xnc = xnc*(1.0 + 50.*rand3)
2941 else
2942 xnc = min(xnc_max, tno*exp(ato*(t_0-temp(k))))
2943 endif
2944 xni = ni(k) + (pni_rfz(k)+pni_wfz(k))*dtsave
2945 pni_inu(k) = 0.5*(xnc-xni + abs(xnc-xni))*odts
2946 pri_inu(k) = min(real(rate_max, kind=dp), xm0i*pni_inu(k))
2947 pni_inu(k) = pri_inu(k)/xm0i
2948 endif
2949
2951 xni = smo0(k)+ni(k) + (pni_rfz(k)+pni_wfz(k)+pni_inu(k))*dtsave
2952 if ((is_aerosol_aware .or. merra2_aerosol_aware) .AND. homogice .AND. (xni.le.nt_i_max) &
2953 .AND.(temp(k).lt.238).AND.(ssati(k).ge.0.4) ) then
2954 xnc = icekoop(temp(k),qv(k),qvs(k),nwfa(k), dtsave)
2955 pni_iha(k) = xnc*odts
2956 pri_iha(k) = min(real(rate_max, kind=dp), xm0i*0.1*pni_iha(k))
2957 pni_iha(k) = pri_iha(k)/(xm0i*0.1)
2958 endif
2959!+---+------------------ END NEW ICE NUCLEATION -----------------------+
2960
2961
2963 if (l_qi(k)) then
2964 lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi
2965 ilami = 1./lami
2966 xdi = max(real(d0i, kind=dp), (bm_i + mu_i + 1.) * ilami)
2967 xmi = am_i*xdi**bm_i
2968 oxmi = 1./xmi
2969 pri_ide(k) = c_cube*t1_subl*diffu(k)*ssati(k)*rvs &
2970 *oig1*cig(5)*ni(k)*ilami
2971
2972 if (pri_ide(k) .lt. 0.0) then
2973 pri_ide(k) = max(real(-ri(k)*odts, kind=dp), pri_ide(k), real(rate_max, kind=dp))
2974 pni_ide(k) = pri_ide(k)*oxmi
2975 pni_ide(k) = max(real(-ni(k)*odts, kind=dp), pni_ide(k))
2976 else
2977 pri_ide(k) = min(pri_ide(k), real(rate_max, kind=dp))
2978 prs_ide(k) = (1.0_dp-tpi_ide(idx_i,idx_i1))*pri_ide(k)
2979 pri_ide(k) = tpi_ide(idx_i,idx_i1)*pri_ide(k)
2980 endif
2981
2984 if ( (idx_i.eq. ntb_i) .or. (xdi.gt. 5.0*d0s) ) then
2985 prs_iau(k) = ri(k)*.99*odts
2986 pni_iau(k) = ni(k)*.95*odts
2987 elseif (xdi.lt. 0.1*d0s) then
2988 prs_iau(k) = 0.
2989 pni_iau(k) = 0.
2990 else
2991 prs_iau(k) = tps_iaus(idx_i,idx_i1)*odts
2992 prs_iau(k) = min(real(ri(k)*.99*odts, kind=dp), prs_iau(k))
2993 pni_iau(k) = tni_iaus(idx_i,idx_i1)*odts
2994 pni_iau(k) = min(real(ni(k)*.95*odts, kind=dp), pni_iau(k))
2995 endif
2996 endif
2997
2999 if (l_qi(k)) then
3000 lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi
3001 ilami = 1./lami
3002 xdi = max(real(d0i, kind=dp), (bm_i + mu_i + 1.) * ilami)
3003 xmi = am_i*xdi**bm_i
3004 oxmi = 1./xmi
3005 if (rs(k).ge. r_s(1)) then
3006 prs_sci(k) = t1_qs_qi*rhof(k)*ef_si*ri(k)*smoe(k)
3007 pni_sci(k) = prs_sci(k) * oxmi
3008 endif
3009
3011 if (rr(k).ge. r_r(1) .and. mvd_r(k).gt. 4.*xdi) then
3012 lamr = 1./ilamr(k)
3013 pri_rci(k) = rhof(k)*t1_qr_qi*ef_ri*ri(k)*n0_r(k) &
3014 *((lamr+fv_r)**(-cre(9)))
3015 pnr_rci(k) = rhof(k)*t1_qr_qi*ef_ri*ni(k)*n0_r(k) & ! RAIN2M
3016 *((lamr+fv_r)**(-cre(9)))
3017 pni_rci(k) = pri_rci(k) * oxmi
3018 prr_rci(k) = rhof(k)*t2_qr_qi*ef_ri*ni(k)*n0_r(k) &
3019 *((lamr+fv_r)**(-cre(8)))
3020 prr_rci(k) = min(real(rr(k)*odts, kind=dp), prr_rci(k))
3021 prg_rci(k) = pri_rci(k) + prr_rci(k)
3022 endif
3023 endif
3024
3026 if (prg_gcw(k).gt. eps .and. tempc.gt.-8.0) then
3027 tf = 0.
3028 if (tempc.ge.-5.0 .and. tempc.lt.-3.0) then
3029 tf = 0.5*(-3.0 - tempc)
3030 elseif (tempc.gt.-8.0 .and. tempc.lt.-5.0) then
3031 tf = 0.33333333*(8.0 + tempc)
3032 endif
3033 pni_ihm(k) = 3.5e8*tf*prg_gcw(k)
3034 pri_ihm(k) = xm0i*pni_ihm(k)
3035 prs_ihm(k) = prs_scw(k)/(prs_scw(k)+prg_gcw(k)) &
3036 * pri_ihm(k)
3037 prg_ihm(k) = prg_gcw(k)/(prs_scw(k)+prg_gcw(k)) &
3038 * pri_ihm(k)
3039 endif
3040
3041 else
3042
3045 if (l_qs(k)) then
3046 prr_sml(k) = (tempc*tcond(k)-lvap0*diffu(k)*delqvs(k)) &
3047 * (t1_qs_me*smo1(k) + t2_qs_me*rhof2(k)*vsc2(k)*smof(k))
3048 if (prr_sml(k) .gt. 0.) then
3049 prr_sml(k) = prr_sml(k) + 4218.*olfus*tempc &
3050 * (prr_rcs(k)+prs_scw(k))
3051 prr_sml(k) = min(real(rs(k)*odts, kind=dp), prr_sml(k))
3052 pnr_sml(k) = smo0(k)/rs(k)*prr_sml(k) * 10.0**(-0.25*tempc) ! RAIN2M
3053 pnr_sml(k) = min(real(smo0(k)*odts, kind=dp), pnr_sml(k))
3054 elseif (ssati(k).lt. 0.) then
3055 prr_sml(k) = 0.0
3056 prs_sde(k) = c_cube*t1_subl*diffu(k)*ssati(k)*rvs &
3057 * (t1_qs_sd*smo1(k) &
3058 + t2_qs_sd*rhof2(k)*vsc2(k)*smof(k))
3059 prs_sde(k) = max(real(-rs(k)*odts, kind=dp), prs_sde(k))
3060 endif
3061 endif
3062
3063 if (l_qg(k)) then
3064 prr_gml(k) = (tempc*tcond(k)-lvap0*diffu(k)*delqvs(k)) &
3065 * n0_g(k)*(t1_qg_me*ilamg(k)**cge(10) &
3066 + t2_qg_me*rhof2(k)*vsc2(k)*ilamg(k)**cge(11))
3067 if (prr_gml(k) .gt. 0.) then
3068 prr_gml(k) = min(real(rg(k)*odts, kind=dp), prr_gml(k))
3069 pnr_gml(k) = n0_g(k)*cgg(2)*ilamg(k)**cge(2) / rg(k) & ! RAIN2M
3070 * prr_gml(k) * 10.0**(-0.5*tempc)
3071 elseif (ssati(k).lt. 0.) then
3072 prr_gml(k) = 0.0
3073 prg_gde(k) = c_cube*t1_subl*diffu(k)*ssati(k)*rvs &
3074 * n0_g(k) * (t1_qg_sd*ilamg(k)**cge(10) &
3075 + t2_qg_sd*vsc2(k)*rhof2(k)*ilamg(k)**cge(11))
3076 prg_gde(k) = max(real(-rg(k)*odts, kind=dp), prg_gde(k))
3077 endif
3078 endif
3079
3084 if (dt .gt. 120.) then
3085 prr_rcw(k)=prr_rcw(k)+prs_scw(k)+prg_gcw(k)
3086 prs_scw(k)=0.
3087 prg_gcw(k)=0.
3088 endif
3089 endif
3090
3091 enddo
3092 endif
3093
3094!+---+-----------------------------------------------------------------+
3096!+---+-----------------------------------------------------------------+
3097 do k = kts, kte
3098
3103 sump = pri_inu(k) + pri_ide(k) + prs_ide(k) &
3104 + prs_sde(k) + prg_gde(k) + pri_iha(k)
3105 rate_max = (qv(k)-qvsi(k))*rho(k)*odts*0.999
3106 if ( (sump.gt. eps .and. sump.gt. rate_max) .or. &
3107 (sump.lt. -eps .and. sump.lt. rate_max) ) then
3108 ratio = rate_max/sump
3109 pri_inu(k) = pri_inu(k) * ratio
3110 pri_ide(k) = pri_ide(k) * ratio
3111 pni_ide(k) = pni_ide(k) * ratio
3112 prs_ide(k) = prs_ide(k) * ratio
3113 prs_sde(k) = prs_sde(k) * ratio
3114 prg_gde(k) = prg_gde(k) * ratio
3115 pri_iha(k) = pri_iha(k) * ratio
3116 endif
3117
3119 sump = -prr_wau(k) - pri_wfz(k) - prr_rcw(k) &
3120 - prs_scw(k) - prg_scw(k) - prg_gcw(k)
3121 rate_max = -rc(k)*odts
3122 if (sump.lt. rate_max .and. l_qc(k)) then
3123 ratio = rate_max/sump
3124 prr_wau(k) = prr_wau(k) * ratio
3125 pri_wfz(k) = pri_wfz(k) * ratio
3126 prr_rcw(k) = prr_rcw(k) * ratio
3127 prs_scw(k) = prs_scw(k) * ratio
3128 prg_scw(k) = prg_scw(k) * ratio
3129 prg_gcw(k) = prg_gcw(k) * ratio
3130 endif
3131
3133 sump = pri_ide(k) - prs_iau(k) - prs_sci(k) &
3134 - pri_rci(k)
3135 rate_max = -ri(k)*odts
3136 if (sump.lt. rate_max .and. l_qi(k)) then
3137 ratio = rate_max/sump
3138 pri_ide(k) = pri_ide(k) * ratio
3139 prs_iau(k) = prs_iau(k) * ratio
3140 prs_sci(k) = prs_sci(k) * ratio
3141 pri_rci(k) = pri_rci(k) * ratio
3142 endif
3143
3145 sump = -prg_rfz(k) - pri_rfz(k) - prr_rci(k) &
3146 + prr_rcs(k) + prr_rcg(k)
3147 rate_max = -rr(k)*odts
3148 if (sump.lt. rate_max .and. l_qr(k)) then
3149 ratio = rate_max/sump
3150 prg_rfz(k) = prg_rfz(k) * ratio
3151 pri_rfz(k) = pri_rfz(k) * ratio
3152 prr_rci(k) = prr_rci(k) * ratio
3153 prr_rcs(k) = prr_rcs(k) * ratio
3154 prr_rcg(k) = prr_rcg(k) * ratio
3155 endif
3156
3158 sump = prs_sde(k) - prs_ihm(k) - prr_sml(k) &
3159 + prs_rcs(k)
3160 rate_max = -rs(k)*odts
3161 if (sump.lt. rate_max .and. l_qs(k)) then
3162 ratio = rate_max/sump
3163 prs_sde(k) = prs_sde(k) * ratio
3164 prs_ihm(k) = prs_ihm(k) * ratio
3165 prr_sml(k) = prr_sml(k) * ratio
3166 prs_rcs(k) = prs_rcs(k) * ratio
3167 endif
3168
3170 sump = prg_gde(k) - prg_ihm(k) - prr_gml(k) &
3171 + prg_rcg(k)
3172 rate_max = -rg(k)*odts
3173 if (sump.lt. rate_max .and. l_qg(k)) then
3174 ratio = rate_max/sump
3175 prg_gde(k) = prg_gde(k) * ratio
3176 prg_ihm(k) = prg_ihm(k) * ratio
3177 prr_gml(k) = prr_gml(k) * ratio
3178 prg_rcg(k) = prg_rcg(k) * ratio
3179 endif
3180
3183 pri_ihm(k) = prs_ihm(k) + prg_ihm(k)
3184 ratio = min( abs(prr_rcg(k)), abs(prg_rcg(k)) )
3185 prr_rcg(k) = ratio * sign(1.0, sngl(prr_rcg(k)))
3186 prg_rcg(k) = -prr_rcg(k)
3187 if (temp(k).gt.t_0) then
3188 ratio = min( abs(prr_rcs(k)), abs(prs_rcs(k)) )
3189 prr_rcs(k) = ratio * sign(1.0, sngl(prr_rcs(k)))
3190 prs_rcs(k) = -prr_rcs(k)
3191 endif
3192
3193 enddo
3194
3195!+---+-----------------------------------------------------------------+
3198!+---+-----------------------------------------------------------------+
3199 do k = kts, kte
3200 orho = 1./rho(k)
3201 lfus2 = lsub - lvap(k)
3202
3204 if (is_aerosol_aware) then
3205 nwfaten(k) = nwfaten(k) - (pna_rca(k) + pna_sca(k) &
3206 + pna_gca(k) + pni_iha(k)) * orho
3207 nifaten(k) = nifaten(k) - (pnd_rcd(k) + pnd_scd(k) &
3208 + pnd_gcd(k)) * orho
3209 if (dustyice) then
3210 nifaten(k) = nifaten(k) - pni_inu(k)*orho
3211 else
3212 nifaten(k) = 0.
3213 endif
3214 endif
3215
3217 qvten(k) = qvten(k) + (-pri_inu(k) - pri_iha(k) - pri_ide(k) &
3218 - prs_ide(k) - prs_sde(k) - prg_gde(k)) &
3219 * orho
3220
3222 qcten(k) = qcten(k) + (-prr_wau(k) - pri_wfz(k) &
3223 - prr_rcw(k) - prs_scw(k) - prg_scw(k) &
3224 - prg_gcw(k)) &
3225 * orho
3226
3228 ncten(k) = ncten(k) + (-pnc_wau(k) - pnc_rcw(k) &
3229 - pni_wfz(k) - pnc_scw(k) - pnc_gcw(k)) &
3230 * orho
3231
3234 xrc=max(r1, (qc1d(k) + qcten(k)*dtsave)*rho(k))
3235 xnc=max(2., (nc1d(k) + ncten(k)*dtsave)*rho(k))
3236 if (xrc .gt. r1) then
3237 if (xnc.gt.10000.e6) then
3238 nu_c = 2
3239 elseif (xnc.lt.100.) then
3240 nu_c = 15
3241 else
3242 nu_c = nint(1000.e6/xnc) + 2
3243 nu_c = max(2, min(nu_c+nint(rand2), 15))
3244 endif
3245 lamc = (xnc*am_r*ccg(2,nu_c)*ocg1(nu_c)/rc(k))**obmr
3246 xdc = (bm_r + nu_c + 1.) / lamc
3247 if (xdc.lt. d0c) then
3248 lamc = cce(2,nu_c)/d0c
3249 xnc = ccg(1,nu_c)*ocg2(nu_c)*xrc/am_r*lamc**bm_r
3250 ncten(k) = (xnc-nc1d(k)*rho(k))*odts*orho
3251 elseif (xdc.gt. d0r*2.) then
3252 lamc = cce(2,nu_c)/(d0r*2.)
3253 xnc = ccg(1,nu_c)*ocg2(nu_c)*xrc/am_r*lamc**bm_r
3254 ncten(k) = (xnc-nc1d(k)*rho(k))*odts*orho
3255 endif
3256 else
3257 ncten(k) = -nc1d(k)*odts
3258 endif
3259 xnc=max(0.,(nc1d(k) + ncten(k)*dtsave)*rho(k))
3260 if (xnc.gt.nt_c_max) &
3261 ncten(k) = (nt_c_max-nc1d(k)*rho(k))*odts*orho
3262
3264 qiten(k) = qiten(k) + (pri_inu(k) + pri_iha(k) + pri_ihm(k) &
3265 + pri_wfz(k) + pri_rfz(k) + pri_ide(k) &
3266 - prs_iau(k) - prs_sci(k) - pri_rci(k)) &
3267 * orho
3268
3270 niten(k) = niten(k) + (pni_inu(k) + pni_iha(k) + pni_ihm(k) &
3271 + pni_wfz(k) + pni_rfz(k) + pni_ide(k) &
3272 - pni_iau(k) - pni_sci(k) - pni_rci(k)) &
3273 * orho
3274
3277 xri=max(r1,(qi1d(k) + qiten(k)*dtsave)*rho(k))
3278 xni=max(r2,(ni1d(k) + niten(k)*dtsave)*rho(k))
3279 if (xri.gt. r1) then
3280 lami = (am_i*cig(2)*oig1*xni/xri)**obmi
3281 ilami = 1./lami
3282 xdi = (bm_i + mu_i + 1.) * ilami
3283 if (xdi.lt. 5.e-6) then
3284 lami = cie(2)/5.e-6
3285 xni = min(nt_i_max, cig(1)*oig2*xri/am_i*lami**bm_i)
3286 niten(k) = (xni-ni1d(k)*rho(k))*odts*orho
3287 elseif (xdi.gt. 300.e-6) then
3288 lami = cie(2)/300.e-6
3289 xni = cig(1)*oig2*xri/am_i*lami**bm_i
3290 niten(k) = (xni-ni1d(k)*rho(k))*odts*orho
3291 endif
3292 else
3293 niten(k) = -ni1d(k)*odts
3294 endif
3295 xni=max(0.,(ni1d(k) + niten(k)*dtsave)*rho(k))
3296 if (xni.gt.nt_i_max) &
3297 niten(k) = (nt_i_max-ni1d(k)*rho(k))*odts*orho
3298
3300 qrten(k) = qrten(k) + (prr_wau(k) + prr_rcw(k) &
3301 + prr_sml(k) + prr_gml(k) + prr_rcs(k) &
3302 + prr_rcg(k) - prg_rfz(k) &
3303 - pri_rfz(k) - prr_rci(k)) &
3304 * orho
3305
3307 nrten(k) = nrten(k) + (pnr_wau(k) + pnr_sml(k) + pnr_gml(k) &
3308 - (pnr_rfz(k) + pnr_rcr(k) + pnr_rcg(k) &
3309 + pnr_rcs(k) + pnr_rci(k) + pni_rfz(k)) ) &
3310 * orho
3311
3314 xrr=max(r1,(qr1d(k) + qrten(k)*dtsave)*rho(k))
3315 xnr=max(r2,(nr1d(k) + nrten(k)*dtsave)*rho(k))
3316 if (xrr.gt. r1) then
3317 lamr = (am_r*crg(3)*org2*xnr/xrr)**obmr
3318 mvd_r(k) = (3.0 + mu_r + 0.672) / lamr
3319 if (mvd_r(k) .gt. 2.5e-3) then
3320 mvd_r(k) = 2.5e-3
3321 lamr = (3.0 + mu_r + 0.672) / mvd_r(k)
3322 xnr = crg(2)*org3*xrr*lamr**bm_r / am_r
3323 nrten(k) = (xnr-nr1d(k)*rho(k))*odts*orho
3324 elseif (mvd_r(k) .lt. d0r*0.75) then
3325 mvd_r(k) = d0r*0.75
3326 lamr = (3.0 + mu_r + 0.672) / mvd_r(k)
3327 xnr = crg(2)*org3*xrr*lamr**bm_r / am_r
3328 nrten(k) = (xnr-nr1d(k)*rho(k))*odts*orho
3329 endif
3330 else
3331 qrten(k) = -qr1d(k)*odts
3332 nrten(k) = -nr1d(k)*odts
3333 endif
3334
3336 qsten(k) = qsten(k) + (prs_iau(k) + prs_sde(k) &
3337 + prs_sci(k) + prs_scw(k) + prs_rcs(k) &
3338 + prs_ide(k) - prs_ihm(k) - prr_sml(k)) &
3339 * orho
3340
3342 qgten(k) = qgten(k) + (prg_scw(k) + prg_rfz(k) &
3343 + prg_gde(k) + prg_rcg(k) + prg_gcw(k) &
3344 + prg_rci(k) + prg_rcs(k) - prg_ihm(k) &
3345 - prr_gml(k)) &
3346 * orho
3347
3349 if (temp(k).lt.t_0) then
3350 tten(k) = tten(k) &
3351 + ( lsub*ocp(k)*(pri_inu(k) + pri_ide(k) &
3352 + prs_ide(k) + prs_sde(k) &
3353 + prg_gde(k) + pri_iha(k)) &
3354 + lfus2*ocp(k)*(pri_wfz(k) + pri_rfz(k) &
3355 + prg_rfz(k) + prs_scw(k) &
3356 + prg_scw(k) + prg_gcw(k) &
3357 + prg_rcs(k) + prs_rcs(k) &
3358 + prr_rci(k) + prg_rcg(k)) &
3359 )*orho * (1-ifdry)
3360 else
3361 tten(k) = tten(k) &
3362 + ( lfus*ocp(k)*(-prr_sml(k) - prr_gml(k) &
3363 - prr_rcg(k) - prr_rcs(k)) &
3364 + lsub*ocp(k)*(prs_sde(k) + prg_gde(k)) &
3365 )*orho * (1-ifdry)
3366 endif
3367
3368 enddo
3369
3370!+---+-----------------------------------------------------------------+
3372!+---+-----------------------------------------------------------------+
3373 do k = kts, kte
3374 temp(k) = t1d(k) + dt*tten(k)
3375 otemp = 1./temp(k)
3376 tempc = temp(k) - 273.15
3377 qv(k) = max(1.e-10, qv1d(k) + dt*qvten(k))
3378 rho(k) = roverrv*pres(k) / (r*temp(k)*(qv(k)+roverrv))
3379 rhof(k) = sqrt(rho_not/rho(k))
3380 rhof2(k) = sqrt(rhof(k))
3381 qvs(k) = rslf(pres(k), temp(k))
3382 ssatw(k) = qv(k)/qvs(k) - 1.
3383 if (abs(ssatw(k)).lt. eps) ssatw(k) = 0.0
3384 diffu(k) = 2.11e-5*(temp(k)/273.15)**1.94 * (101325./pres(k))
3385 if (tempc .ge. 0.0) then
3386 visco(k) = (1.718+0.0049*tempc)*1.0e-5
3387 else
3388 visco(k) = (1.718+0.0049*tempc-1.2e-5*tempc*tempc)*1.0e-5
3389 endif
3390 vsc2(k) = sqrt(rho(k)/visco(k))
3391 lvap(k) = lvap0 + (2106.0 - 4218.0)*tempc
3392 tcond(k) = (5.69 + 0.0168*tempc)*1.0e-5 * 418.936
3393 ocp(k) = 1./(cp*(1.+0.887*qv(k)))
3394 lvt2(k)=lvap(k)*lvap(k)*ocp(k)*orv*otemp*otemp
3395 if (is_aerosol_aware) &
3396 nwfa(k) = max(11.1e6*rho(k), (nwfa1d(k) + nwfaten(k)*dt)*rho(k))
3397 enddo
3398
3399 do k = kts, kte
3400 if ((qc1d(k) + qcten(k)*dt) .gt. r1) then
3401 rc(k) = (qc1d(k) + qcten(k)*dt)*rho(k)
3402 nc(k) = max(2., min((nc1d(k)+ncten(k)*dt)*rho(k), nt_c_max))
3403 if (.NOT. (is_aerosol_aware .or. merra2_aerosol_aware)) then
3404 if(lsml == 1) then
3405 nc(k) = nt_c_l
3406 else
3407 nc(k) = nt_c_o
3408 endif
3409 endif
3410 l_qc(k) = .true.
3411 else
3412 rc(k) = r1
3413 nc(k) = 2.
3414 l_qc(k) = .false.
3415 endif
3416
3417 if ((qi1d(k) + qiten(k)*dt) .gt. r1) then
3418 ri(k) = (qi1d(k) + qiten(k)*dt)*rho(k)
3419 ni(k) = max(r2, (ni1d(k) + niten(k)*dt)*rho(k))
3420 l_qi(k) = .true.
3421 else
3422 ri(k) = r1
3423 ni(k) = r2
3424 l_qi(k) = .false.
3425 endif
3426
3427 if ((qr1d(k) + qrten(k)*dt) .gt. r1) then
3428 rr(k) = (qr1d(k) + qrten(k)*dt)*rho(k)
3429 nr(k) = max(r2, (nr1d(k) + nrten(k)*dt)*rho(k))
3430 l_qr(k) = .true.
3431 lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr
3432 mvd_r(k) = (3.0 + mu_r + 0.672) / lamr
3433 if (mvd_r(k) .gt. 2.5e-3) then
3434 mvd_r(k) = 2.5e-3
3435 lamr = (3.0 + mu_r + 0.672) / mvd_r(k)
3436 nr(k) = crg(2)*org3*rr(k)*lamr**bm_r / am_r
3437 elseif (mvd_r(k) .lt. d0r*0.75) then
3438 mvd_r(k) = d0r*0.75
3439 lamr = (3.0 + mu_r + 0.672) / mvd_r(k)
3440 nr(k) = crg(2)*org3*rr(k)*lamr**bm_r / am_r
3441 endif
3442 else
3443 rr(k) = r1
3444 nr(k) = r2
3445 l_qr(k) = .false.
3446 endif
3447
3448 if ((qs1d(k) + qsten(k)*dt) .gt. r1) then
3449 rs(k) = (qs1d(k) + qsten(k)*dt)*rho(k)
3450 l_qs(k) = .true.
3451 else
3452 rs(k) = r1
3453 l_qs(k) = .false.
3454 endif
3455
3456 if ((qg1d(k) + qgten(k)*dt) .gt. r1) then
3457 rg(k) = (qg1d(k) + qgten(k)*dt)*rho(k)
3458 l_qg(k) = .true.
3459 else
3460 rg(k) = r1
3461 l_qg(k) = .false.
3462 endif
3463 enddo
3464
3465!+---+-----------------------------------------------------------------+
3468!+---+-----------------------------------------------------------------+
3469 if (.not. iiwarm) then
3470 do k = kts, kte
3471 smo2(k) = 0.
3472 smob(k) = 0.
3473 smoc(k) = 0.
3474 smod(k) = 0.
3475 enddo
3476 do k = kts, kte
3477 if (.not. l_qs(k)) cycle
3478 tc0 = min(-0.1, temp(k)-273.15)
3479 smob(k) = rs(k)*oams
3480
3483 if (bm_s.gt.(2.0-1.e-3) .and. bm_s.lt.(2.0+1.e-3)) then
3484 smo2(k) = smob(k)
3485 else
3486 loga_ = sa(1) + sa(2)*tc0 + sa(3)*bm_s &
3487 + sa(4)*tc0*bm_s + sa(5)*tc0*tc0 &
3488 + sa(6)*bm_s*bm_s + sa(7)*tc0*tc0*bm_s &
3489 + sa(8)*tc0*bm_s*bm_s + sa(9)*tc0*tc0*tc0 &
3490 + sa(10)*bm_s*bm_s*bm_s
3491 a_ = 10.0**loga_
3492 b_ = sb(1) + sb(2)*tc0 + sb(3)*bm_s &
3493 + sb(4)*tc0*bm_s + sb(5)*tc0*tc0 &
3494 + sb(6)*bm_s*bm_s + sb(7)*tc0*tc0*bm_s &
3495 + sb(8)*tc0*bm_s*bm_s + sb(9)*tc0*tc0*tc0 &
3496 + sb(10)*bm_s*bm_s*bm_s
3497 smo2(k) = (smob(k)/a_)**(1./b_)
3498 endif
3499
3501 loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(1) &
3502 + sa(4)*tc0*cse(1) + sa(5)*tc0*tc0 &
3503 + sa(6)*cse(1)*cse(1) + sa(7)*tc0*tc0*cse(1) &
3504 + sa(8)*tc0*cse(1)*cse(1) + sa(9)*tc0*tc0*tc0 &
3505 + sa(10)*cse(1)*cse(1)*cse(1)
3506 a_ = 10.0**loga_
3507 b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(1) + sb(4)*tc0*cse(1) &
3508 + sb(5)*tc0*tc0 + sb(6)*cse(1)*cse(1) &
3509 + sb(7)*tc0*tc0*cse(1) + sb(8)*tc0*cse(1)*cse(1) &
3510 + sb(9)*tc0*tc0*tc0 + sb(10)*cse(1)*cse(1)*cse(1)
3511 smoc(k) = a_ * smo2(k)**b_
3512
3514 loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(14) &
3515 + sa(4)*tc0*cse(14) + sa(5)*tc0*tc0 &
3516 + sa(6)*cse(14)*cse(14) + sa(7)*tc0*tc0*cse(14) &
3517 + sa(8)*tc0*cse(14)*cse(14) + sa(9)*tc0*tc0*tc0 &
3518 + sa(10)*cse(14)*cse(14)*cse(14)
3519 a_ = 10.0**loga_
3520 b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(14) + sb(4)*tc0*cse(14) &
3521 + sb(5)*tc0*tc0 + sb(6)*cse(14)*cse(14) &
3522 + sb(7)*tc0*tc0*cse(14) + sb(8)*tc0*cse(14)*cse(14) &
3523 + sb(9)*tc0*tc0*tc0 + sb(10)*cse(14)*cse(14)*cse(14)
3524 smod(k) = a_ * smo2(k)**b_
3525 enddo
3526
3527!+---+-----------------------------------------------------------------+
3529!+---+-----------------------------------------------------------------+
3530 call graupel_psd_parameters(kts, kte, rand1, rg, ilamg, n0_g)
3531 endif
3532
3533!+---+-----------------------------------------------------------------+
3535!+---+-----------------------------------------------------------------+
3536 do k = kte, kts, -1
3537 lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr
3538 ilamr(k) = 1./lamr
3539 mvd_r(k) = (3.0 + mu_r + 0.672) / lamr
3540 n0_r(k) = nr(k)*org2*lamr**cre(2)
3541 enddo
3542
3543!+---+-----------------------------------------------------------------+
3550!+---+-----------------------------------------------------------------+
3551 do k = kts, kte
3552 orho = 1./rho(k)
3553 if ( (ssatw(k).gt. eps) .or. (ssatw(k).lt. -eps .and. &
3554 l_qc(k)) ) then
3555 clap = (qv(k)-qvs(k))/(1. + lvt2(k)*qvs(k))
3556 do n = 1, 3
3557 fcd = qvs(k)* exp(lvt2(k)*clap) - qv(k) + clap
3558 dfcd = qvs(k)*lvt2(k)* exp(lvt2(k)*clap) + 1.
3559 clap = clap - fcd/dfcd
3560 enddo
3561 xrc = rc(k) + clap*rho(k)
3562 xnc = 0.
3563 if (xrc.gt. r1) then
3564 prw_vcd(k) = clap*odt
3565 !+---+-----------------------------------------------------------------+ ! DROPLET NUCLEATION
3566 if (clap .gt. eps) then
3567 if (is_aerosol_aware .or. merra2_aerosol_aware) then
3568 xnc = max(2., activ_ncloud(temp(k), w1d(k)+rand3, nwfa(k), lsml))
3569 else
3570 if(lsml == 1) then
3571 xnc = nt_c_l
3572 else
3573 xnc = nt_c_o
3574 endif
3575 endif
3576 pnc_wcd(k) = 0.5*(xnc-nc(k) + abs(xnc-nc(k)))*odts*orho
3577
3578 !+---+-----------------------------------------------------------------+ ! EVAPORATION
3579 elseif (clap .lt. -eps .AND. ssatw(k).lt.-1.e-6 .AND. &
3580 is_aerosol_aware) then
3581 tempc = temp(k) - 273.15
3582 otemp = 1./temp(k)
3583 rvs = rho(k)*qvs(k)
3584 rvs_p = rvs*otemp*(lvap(k)*otemp*orv - 1.)
3585 rvs_pp = rvs * ( otemp*(lvap(k)*otemp*orv - 1.) &
3586 *otemp*(lvap(k)*otemp*orv - 1.) &
3587 + (-2.*lvap(k)*otemp*otemp*otemp*orv) &
3588 + otemp*otemp)
3589 gamsc = lvap(k)*diffu(k)/tcond(k) * rvs_p
3590 alphsc = 0.5*(gamsc/(1.+gamsc))*(gamsc/(1.+gamsc)) &
3591 * rvs_pp/rvs_p * rvs/rvs_p
3592 alphsc = max(1.e-9, alphsc)
3593 xsat = ssatw(k)
3594 if (abs(xsat).lt. 1.e-9) xsat=0.
3595 t1_evap = 2.*pi*( 1.0 - alphsc*xsat &
3596 + 2.*alphsc*alphsc*xsat*xsat &
3597 - 5.*alphsc*alphsc*alphsc*xsat*xsat*xsat ) &
3598 / (1.+gamsc)
3599
3600 dc_star = sqrt(-2.0_dp*dt * t1_evap/(2.*pi) &
3601 * 4.*diffu(k)*ssatw(k)*rvs/rho_w)
3602 idx_d = max(1, min(int(1.e6*dc_star), nbc))
3603
3604 idx_n = nint(1.0 + real(nbc, kind=wp) * log(real(nc(k)/t_nc(1), kind=dp)) / nic1)
3605 idx_n = max(1, min(idx_n, nbc))
3606
3608 if (rc(k).gt. r_c(1)) then
3609 nic = nint(log10(rc(k)))
3610 do_loop_rc_cond: do nn = nic-1, nic+1
3611 n = nn
3612 if ( (rc(k)/10.**nn).ge.1.0 .and. (rc(k)/10.**nn).lt.10.0 ) exit do_loop_rc_cond
3613 enddo do_loop_rc_cond
3614 idx_c = int(rc(k)/10.**n) + 10*(n-nic2) - (n-nic2)
3615 idx_c = max(1, min(idx_c, ntb_c))
3616 else
3617 idx_c = 1
3618 endif
3619
3620 !prw_vcd(k) = max(real(-rc(k)*orho*odt, kind=dp), &
3621 ! -tpc_wev(idx_d, idx_c, idx_n)*orho*odt)
3622 prw_vcd(k) = max(real(-rc(k)*0.99*orho*odt, kind=dp), prw_vcd(k))
3623 pnc_wcd(k) = max(real(-nc(k)*0.99*orho*odt, kind=dp), &
3624 -tnc_wev(idx_d, idx_c, idx_n)*orho*odt)
3625
3626 endif
3627 else
3628 prw_vcd(k) = -rc(k)*orho*odt
3629 pnc_wcd(k) = -nc(k)*orho*odt
3630 endif
3631
3632!+---+-----------------------------------------------------------------+
3633
3634 qvten(k) = qvten(k) - prw_vcd(k)
3635 qcten(k) = qcten(k) + prw_vcd(k)
3636 ncten(k) = ncten(k) + pnc_wcd(k)
3637 if (is_aerosol_aware) &
3638 nwfaten(k) = nwfaten(k) - pnc_wcd(k)
3639 tten(k) = tten(k) + lvap(k)*ocp(k)*prw_vcd(k)*(1-ifdry)
3640 rc(k) = max(r1, (qc1d(k) + dt*qcten(k))*rho(k))
3641 if (rc(k).eq.r1) l_qc(k) = .false.
3642 nc(k) = max(2., min((nc1d(k)+ncten(k)*dt)*rho(k), nt_c_max))
3643 if (.NOT. (is_aerosol_aware .or. merra2_aerosol_aware)) then
3644 if(lsml == 1) then
3645 nc(k) = nt_c_l
3646 else
3647 nc(k) = nt_c_o
3648 endif
3649 endif
3650 qv(k) = max(1.e-10, qv1d(k) + dt*qvten(k))
3651 temp(k) = t1d(k) + dt*tten(k)
3652 rho(k) = roverrv*pres(k) / (r*temp(k)*(qv(k)+roverrv))
3653 qvs(k) = rslf(pres(k), temp(k))
3654 ssatw(k) = qv(k)/qvs(k) - 1.
3655 endif
3656 enddo
3657
3658!+---+-----------------------------------------------------------------+
3661!+---+-----------------------------------------------------------------+
3662 do k = kts, kte
3663 if ( (ssatw(k).lt. -eps) .and. l_qr(k) &
3664 .and. (.not.(prw_vcd(k).gt. 0.)) ) then
3665 tempc = temp(k) - 273.15
3666 otemp = 1./temp(k)
3667 orho = 1./rho(k)
3668 rhof(k) = sqrt(rho_not*orho)
3669 rhof2(k) = sqrt(rhof(k))
3670 diffu(k) = 2.11e-5*(temp(k)/273.15)**1.94 * (101325./pres(k))
3671 if (tempc .ge. 0.0) then
3672 visco(k) = (1.718+0.0049*tempc)*1.0e-5
3673 else
3674 visco(k) = (1.718+0.0049*tempc-1.2e-5*tempc*tempc)*1.0e-5
3675 endif
3676 vsc2(k) = sqrt(rho(k)/visco(k))
3677 lvap(k) = lvap0 + (2106.0 - 4218.0)*tempc
3678 tcond(k) = (5.69 + 0.0168*tempc)*1.0e-5 * 418.936
3679 ocp(k) = 1./(cp*(1.+0.887*qv(k)))
3680
3681 rvs = rho(k)*qvs(k)
3682 rvs_p = rvs*otemp*(lvap(k)*otemp*orv - 1.)
3683 rvs_pp = rvs * ( otemp*(lvap(k)*otemp*orv - 1.) &
3684 *otemp*(lvap(k)*otemp*orv - 1.) &
3685 + (-2.*lvap(k)*otemp*otemp*otemp*orv) &
3686 + otemp*otemp)
3687 gamsc = lvap(k)*diffu(k)/tcond(k) * rvs_p
3688 alphsc = 0.5*(gamsc/(1.+gamsc))*(gamsc/(1.+gamsc)) &
3689 * rvs_pp/rvs_p * rvs/rvs_p
3690 alphsc = max(1.e-9, alphsc)
3691 xsat = min(-1.e-9, ssatw(k))
3692 t1_evap = 2.*pi*( 1.0 - alphsc*xsat &
3693 + 2.*alphsc*alphsc*xsat*xsat &
3694 - 5.*alphsc*alphsc*alphsc*xsat*xsat*xsat ) &
3695 / (1.+gamsc)
3696
3697 lamr = 1./ilamr(k)
3699 if (qv(k)/qvs(k) .lt. 0.95 .AND. rr(k)*orho.le.1.e-8) then
3700 prv_rev(k) = rr(k)*orho*odts
3701 else
3702 prv_rev(k) = t1_evap*diffu(k)*(-ssatw(k))*n0_r(k)*rvs &
3703 * (t1_qr_ev*ilamr(k)**cre(10) &
3704 + t2_qr_ev*vsc2(k)*rhof2(k)*((lamr+0.5*fv_r)**(-cre(11))))
3705 rate_max = min((rr(k)*orho*odts), (qvs(k)-qv(k))*odts)
3706 prv_rev(k) = min(real(rate_max, kind=dp), prv_rev(k)*orho)
3707
3708!..TEST: G. Thompson 10 May 2013
3715 if (prr_gml(k).gt.0.0) then
3716 eva_factor = min(1.0, 0.01+(0.99-0.01)*(tempc/20.0))
3717 prv_rev(k) = prv_rev(k)*eva_factor
3718 endif
3719 endif
3720
3721 pnr_rev(k) = min(real(nr(k)*0.99*orho*odts, kind=dp), & ! RAIN2M
3722 prv_rev(k) * nr(k)/rr(k))
3723
3724 qrten(k) = qrten(k) - prv_rev(k)
3725 qvten(k) = qvten(k) + prv_rev(k)
3726 nrten(k) = nrten(k) - pnr_rev(k)
3727 if (is_aerosol_aware) &
3728 nwfaten(k) = nwfaten(k) + pnr_rev(k)
3729 tten(k) = tten(k) - lvap(k)*ocp(k)*prv_rev(k)*(1-ifdry)
3730
3731 rr(k) = max(r1, (qr1d(k) + dt*qrten(k))*rho(k))
3732 qv(k) = max(1.e-10, qv1d(k) + dt*qvten(k))
3733 nr(k) = max(r2, (nr1d(k) + dt*nrten(k))*rho(k))
3734 temp(k) = t1d(k) + dt*tten(k)
3735 rho(k) = roverrv*pres(k) / (r*temp(k)*(qv(k)+roverrv))
3736 endif
3737 enddo
3738#if ( WRF_CHEM == 1 )
3739 do k = kts, kte
3740 evapprod(k) = prv_rev(k) - (min(zerod0,prs_sde(k)) + &
3741 min(zerod0,prg_gde(k)))
3742 rainprod(k) = prr_wau(k) + prr_rcw(k) + prs_scw(k) + &
3743 prg_scw(k) + prs_iau(k) + &
3744 prg_gcw(k) + prs_sci(k) + &
3745 pri_rci(k)
3746 enddo
3747#endif
3748
3749!+---+-----------------------------------------------------------------+
3756!+---+-----------------------------------------------------------------+
3757 nstep = 0
3758 onstep(:) = 1.0
3759 ksed1(:) = 1
3760 do k = kte+1, kts, -1
3761 vtrk(k) = 0.
3762 vtnrk(k) = 0.
3763 vtik(k) = 0.
3764 vtnik(k) = 0.
3765 vtsk(k) = 0.
3766 vtgk(k) = 0.
3767 vtck(k) = 0.
3768 vtnck(k) = 0.
3769 enddo
3770
3771 if (any(l_qr .eqv. .true.)) then
3772 do k = kte, kts, -1
3773 vtr = 0.
3774 rhof(k) = sqrt(rho_not/rho(k))
3775
3776 if (rr(k).gt. r1) then
3777 lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr
3778 vtr = rhof(k)*av_r*crg(6)*org3 * lamr**cre(3) &
3779 *((lamr+fv_r)**(-cre(6)))
3780 vtrk(k) = vtr
3781! First below is technically correct:
3782! vtr = rhof(k)*av_r*crg(5)*org2 * lamr**cre(2) &
3783! *((lamr+fv_r)**(-cre(5)))
3784! Test: make number fall faster (but still slower than mass)
3785! Goal: less prominent size sorting
3786 vtr = rhof(k)*av_r*crg(7)/crg(12) * lamr**cre(12) &
3787 *((lamr+fv_r)**(-cre(7)))
3788 vtnrk(k) = vtr
3789 else
3790 vtrk(k) = vtrk(k+1)
3791 vtnrk(k) = vtnrk(k+1)
3792 endif
3793
3794 if (max(vtrk(k),vtnrk(k)) .gt. 1.e-3) then
3795 ksed1(1) = max(ksed1(1), k)
3796 delta_tp = dzq(k)/(max(vtrk(k),vtnrk(k)))
3797 nstep = max(nstep, int(dt/delta_tp + 1.))
3798 endif
3799 enddo
3800 if (ksed1(1) .eq. kte) ksed1(1) = kte-1
3801 if (nstep .gt. 0) onstep(1) = 1./real(nstep, kind=wp)
3802 endif
3803
3804!+---+-----------------------------------------------------------------+
3805
3806 if (any(l_qc .eqv. .true.)) then
3807 hgt_agl = 0.
3808 do_loop_hgt_agl : do k = kts, kte-1
3809 if (rc(k) .gt. r2) ksed1(5) = k
3810 hgt_agl = hgt_agl + dzq(k)
3811 if (hgt_agl .gt. 500.0) exit do_loop_hgt_agl
3812 enddo do_loop_hgt_agl
3813
3814 do k = ksed1(5), kts, -1
3815 vtc = 0.
3816 if (rc(k) .gt. r1 .and. w1d(k) .lt. 1.e-1) then
3817 if (nc(k).gt.10000.e6) then
3818 nu_c = 2
3819 elseif (nc(k).lt.100.) then
3820 nu_c = 15
3821 else
3822 nu_c = nint(1000.e6/nc(k)) + 2
3823 nu_c = max(2, min(nu_c+nint(rand2), 15))
3824 endif
3825 lamc = (nc(k)*am_r*ccg(2,nu_c)*ocg1(nu_c)/rc(k))**obmr
3826 ilamc = 1./lamc
3827 vtc = rhof(k)*av_c*ccg(5,nu_c)*ocg2(nu_c) * ilamc**bv_c
3828 vtck(k) = vtc
3829 vtc = rhof(k)*av_c*ccg(4,nu_c)*ocg1(nu_c) * ilamc**bv_c
3830 vtnck(k) = vtc
3831 endif
3832 enddo
3833 endif
3834
3835!+---+-----------------------------------------------------------------+
3836
3837 if (.not. iiwarm) then
3838
3839 if (any(l_qi .eqv. .true.)) then
3840 nstep = 0
3841 do k = kte, kts, -1
3842 vti = 0.
3843
3844 if (ri(k).gt. r1) then
3845 lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi
3846 ilami = 1./lami
3847 vti = rhof(k)*av_i*cig(3)*oig2 * ilami**bv_i
3848 vtik(k) = vti
3849 ! First below is technically correct:
3850 ! vti = rhof(k)*av_i*cig(4)*oig1 * ilami**bv_i
3851 ! Goal: less prominent size sorting
3852 vti = rhof(k)*av_i*cig(6)/cig(7) * ilami**bv_i
3853 vtnik(k) = vti
3854 else
3855 vtik(k) = vtik(k+1)
3856 vtnik(k) = vtnik(k+1)
3857 endif
3858
3859 if (vtik(k) .gt. 1.e-3) then
3860 ksed1(2) = max(ksed1(2), k)
3861 delta_tp = dzq(k)/vtik(k)
3862 nstep = max(nstep, int(dt/delta_tp + 1.))
3863 endif
3864 enddo
3865 if (ksed1(2) .eq. kte) ksed1(2) = kte-1
3866 if (nstep .gt. 0) onstep(2) = 1./real(nstep, kind=wp)
3867 endif
3868
3869!+---+-----------------------------------------------------------------+
3870
3871 if (any(l_qs .eqv. .true.)) then
3872 nstep = 0
3873 do k = kte, kts, -1
3874 vts = 0.
3875 !vtsk1(k)=0.
3876
3877 if (rs(k).gt. r1) then
3878 xds = smoc(k) / smob(k)
3879 mrat = 1./xds
3880 ils1 = 1./(mrat*lam0 + fv_s)
3881 ils2 = 1./(mrat*lam1 + fv_s)
3882 t1_vts = kap0*csg(4)*ils1**cse(4)
3883 t2_vts = kap1*mrat**mu_s*csg(10)*ils2**cse(10)
3884 ils1 = 1./(mrat*lam0)
3885 ils2 = 1./(mrat*lam1)
3886 t3_vts = kap0*csg(1)*ils1**cse(1)
3887 t4_vts = kap1*mrat**mu_s*csg(7)*ils2**cse(7)
3888 vts = rhof(k)*av_s * (t1_vts+t2_vts)/(t3_vts+t4_vts)
3889 if (prr_sml(k) .gt. 0.0) then
3890 ! vtsk(k) = max(vts*vts_boost(k), &
3891 ! & vts*((vtrk(k)-vts*vts_boost(k))/(temp(k)-T_0)))
3892 sr = rs(k)/(rs(k)+rr(k))
3893 vtsk(k) = vts*sr + (1.-sr)*vtrk(k)
3894 !vtsk1(k)=vtsk(k)
3895 else
3896 vtsk(k) = vts*vts_boost(k)
3897 !vtsk1(k)=vtsk(k)
3898 endif
3899 else
3900 vtsk(k) = vtsk(k+1)
3901 !vtsk1(k)=0
3902 endif
3903
3904 if (vtsk(k) .gt. 1.e-3) then
3905 ksed1(3) = max(ksed1(3), k)
3906 delta_tp = dzq(k)/vtsk(k)
3907 nstep = max(nstep, int(dt/delta_tp + 1.))
3908 endif
3909 enddo
3910 if (ksed1(3) .eq. kte) ksed1(3) = kte-1
3911 if (nstep .gt. 0) onstep(3) = 1./real(nstep, kind=wp)
3912 endif
3913
3914!+---+-----------------------------------------------------------------+
3915
3916 if (any(l_qg .eqv. .true.)) then
3917 nstep = 0
3918 do k = kte, kts, -1
3919 vtg = 0.
3920
3921 if (rg(k).gt. r1) then
3922 vtg = rhof(k)*av_g*cgg(6)*ogg3 * ilamg(k)**bv_g
3923 if (temp(k).gt. t_0) then
3924 vtgk(k) = max(vtg, vtrk(k))
3925 else
3926 vtgk(k) = vtg
3927 endif
3928 else
3929 vtgk(k) = vtgk(k+1)
3930 endif
3931
3932 if (vtgk(k) .gt. 1.e-3) then
3933 ksed1(4) = max(ksed1(4), k)
3934 delta_tp = dzq(k)/vtgk(k)
3935 nstep = max(nstep, int(dt/delta_tp + 1.))
3936 endif
3937 enddo
3938 if (ksed1(4) .eq. kte) ksed1(4) = kte-1
3939 if (nstep .gt. 0) onstep(4) = 1./real(nstep, kind=wp)
3940 endif
3941 endif
3942
3943!+---+-----------------------------------------------------------------+
3947!+---+-----------------------------------------------------------------+
3948
3949 if (any(l_qr .eqv. .true.)) then
3950 nstep = nint(1./onstep(1))
3951
3952 if(.not. sedi_semi) then
3953 do n = 1, nstep
3954 do k = kte, kts, -1
3955 sed_r(k) = vtrk(k)*rr(k)
3956 sed_n(k) = vtnrk(k)*nr(k)
3957 enddo
3958 k = kte
3959 odzq = 1./dzq(k)
3960 orho = 1./rho(k)
3961 qrten(k) = qrten(k) - sed_r(k)*odzq*onstep(1)*orho
3962 nrten(k) = nrten(k) - sed_n(k)*odzq*onstep(1)*orho
3963 rr(k) = max(r1, rr(k) - sed_r(k)*odzq*dt*onstep(1))
3964 nr(k) = max(r2, nr(k) - sed_n(k)*odzq*dt*onstep(1))
3965 pfll1(k) = pfll1(k) + sed_r(k)*dt*onstep(1)
3966 do k = ksed1(1), kts, -1
3967 odzq = 1./dzq(k)
3968 orho = 1./rho(k)
3969 qrten(k) = qrten(k) + (sed_r(k+1)-sed_r(k)) &
3970 *odzq*onstep(1)*orho
3971 nrten(k) = nrten(k) + (sed_n(k+1)-sed_n(k)) &
3972 *odzq*onstep(1)*orho
3973 rr(k) = max(r1, rr(k) + (sed_r(k+1)-sed_r(k)) &
3974 *odzq*dt*onstep(1))
3975 nr(k) = max(r2, nr(k) + (sed_n(k+1)-sed_n(k)) &
3976 *odzq*dt*onstep(1))
3977 pfll1(k) = pfll1(k) + sed_r(k)*dt*onstep(1)
3978 enddo
3979
3980 if (rr(kts).gt.r1*rr_min) then
3981 pptrain = pptrain + sed_r(kts)*dt*onstep(1)
3982 endif
3983 enddo
3984 else !if(.not. sedi_semi)
3985 niter = 1
3986 dtcfl = dt
3987 niter = int(nstep/max(decfl,1)) + 1
3988 dtcfl = dt/niter
3989 do n = 1, niter
3990 rr_tmp(:) = rr(:)
3991 nr_tmp(:) = nr(:)
3992 call semi_lagrange_sedim(kte,dzq,vtrk,rr,rainsfc,pfll,dtcfl,r1)
3993 call semi_lagrange_sedim(kte,dzq,vtnrk,nr,vtr,pdummy,dtcfl,r2)
3994 do k = kts, kte
3995 orhodt = 1./(rho(k)*dt)
3996 qrten(k) = qrten(k) + (rr(k) - rr_tmp(k)) * orhodt
3997 nrten(k) = nrten(k) + (nr(k) - nr_tmp(k)) * orhodt
3998 pfll1(k) = pfll1(k) + pfll(k)
3999 enddo
4000 pptrain = pptrain + rainsfc
4001
4002 do k = kte+1, kts, -1
4003 vtrk(k) = 0.
4004 vtnrk(k) = 0.
4005 enddo
4006 do k = kte, kts, -1
4007 vtr = 0.
4008 if (rr(k).gt. r1) then
4009 lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr
4010 vtr = rhof(k)*av_r*crg(6)*org3 * lamr**cre(3) &
4011 *((lamr+fv_r)**(-cre(6)))
4012 vtrk(k) = vtr
4013 ! First below is technically correct:
4014 ! vtr = rhof(k)*av_r*crg(5)*org2 * lamr**cre(2) &
4015 ! *((lamr+fv_r)**(-cre(5)))
4016 ! Test: make number fall faster (but still slower than mass)
4017 ! Goal: less prominent size sorting
4018 vtr = rhof(k)*av_r*crg(7)/crg(12) * lamr**cre(12) &
4019 *((lamr+fv_r)**(-cre(7)))
4020 vtnrk(k) = vtr
4021 endif
4022 enddo
4023 enddo
4024 endif! if(.not. sedi_semi)
4025 endif
4026
4027!+---+-----------------------------------------------------------------+
4028
4029 if (any(l_qc .eqv. .true.)) then
4030 do k = kte, kts, -1
4031 sed_c(k) = vtck(k)*rc(k)
4032 sed_n(k) = vtnck(k)*nc(k)
4033 enddo
4034 do k = ksed1(5), kts, -1
4035 odzq = 1./dzq(k)
4036 orho = 1./rho(k)
4037 qcten(k) = qcten(k) + (sed_c(k+1)-sed_c(k)) *odzq*orho
4038 ncten(k) = ncten(k) + (sed_n(k+1)-sed_n(k)) *odzq*orho
4039 rc(k) = max(r1, rc(k) + (sed_c(k+1)-sed_c(k)) *odzq*dt)
4040 nc(k) = max(10., nc(k) + (sed_n(k+1)-sed_n(k)) *odzq*dt)
4041 enddo
4042 endif
4043
4044!+---+-----------------------------------------------------------------+
4045
4046 if (any(l_qi .eqv. .true.)) then
4047 nstep = nint(1./onstep(2))
4048 do n = 1, nstep
4049 do k = kte, kts, -1
4050 sed_i(k) = vtik(k)*ri(k)
4051 sed_n(k) = vtnik(k)*ni(k)
4052 enddo
4053 k = kte
4054 odzq = 1./dzq(k)
4055 orho = 1./rho(k)
4056 qiten(k) = qiten(k) - sed_i(k)*odzq*onstep(2)*orho
4057 niten(k) = niten(k) - sed_n(k)*odzq*onstep(2)*orho
4058 ri(k) = max(r1, ri(k) - sed_i(k)*odzq*dt*onstep(2))
4059 ni(k) = max(r2, ni(k) - sed_n(k)*odzq*dt*onstep(2))
4060 pfil1(k) = pfil1(k) + sed_i(k)*dt*onstep(2)
4061 do k = ksed1(2), kts, -1
4062 odzq = 1./dzq(k)
4063 orho = 1./rho(k)
4064 qiten(k) = qiten(k) + (sed_i(k+1)-sed_i(k)) &
4065 *odzq*onstep(2)*orho
4066 niten(k) = niten(k) + (sed_n(k+1)-sed_n(k)) &
4067 *odzq*onstep(2)*orho
4068 ri(k) = max(r1, ri(k) + (sed_i(k+1)-sed_i(k)) &
4069 *odzq*dt*onstep(2))
4070 ni(k) = max(r2, ni(k) + (sed_n(k+1)-sed_n(k)) &
4071 *odzq*dt*onstep(2))
4072 pfil1(k) = pfil1(k) + sed_i(k)*dt*onstep(2)
4073 enddo
4074
4075 if (ri(kts).gt.r1*rr_min) then
4076 pptice = pptice + sed_i(kts)*dt*onstep(2)
4077 endif
4078 enddo
4079 endif
4080
4081!+---+-----------------------------------------------------------------+
4082
4083 if (any(l_qs .eqv. .true.)) then
4084 nstep = nint(1./onstep(3))
4085 do n = 1, nstep
4086 do k = kte, kts, -1
4087 sed_s(k) = vtsk(k)*rs(k)
4088 enddo
4089 k = kte
4090 odzq = 1./dzq(k)
4091 orho = 1./rho(k)
4092 qsten(k) = qsten(k) - sed_s(k)*odzq*onstep(3)*orho
4093 rs(k) = max(r1, rs(k) - sed_s(k)*odzq*dt*onstep(3))
4094 pfil1(k) = pfil1(k) + sed_s(k)*dt*onstep(3)
4095 do k = ksed1(3), kts, -1
4096 odzq = 1./dzq(k)
4097 orho = 1./rho(k)
4098 qsten(k) = qsten(k) + (sed_s(k+1)-sed_s(k)) &
4099 *odzq*onstep(3)*orho
4100 rs(k) = max(r1, rs(k) + (sed_s(k+1)-sed_s(k)) &
4101 *odzq*dt*onstep(3))
4102 pfil1(k) = pfil1(k) + sed_s(k)*dt*onstep(3)
4103 enddo
4104
4105 if (rs(kts).gt.r1*rr_min) then
4106 pptsnow = pptsnow + sed_s(kts)*dt*onstep(3)
4107 endif
4108 enddo
4109 endif
4110
4111!+---+-----------------------------------------------------------------+
4112
4113 if (any(l_qg .eqv. .true.)) then
4114 nstep = nint(1./onstep(4))
4115 if(.not. sedi_semi) then
4116 do n = 1, nstep
4117 do k = kte, kts, -1
4118 sed_g(k) = vtgk(k)*rg(k)
4119 enddo
4120 k = kte
4121 odzq = 1./dzq(k)
4122 orho = 1./rho(k)
4123 qgten(k) = qgten(k) - sed_g(k)*odzq*onstep(4)*orho
4124 rg(k) = max(r1, rg(k) - sed_g(k)*odzq*dt*onstep(4))
4125 pfil1(k) = pfil1(k) + sed_g(k)*dt*onstep(4)
4126 do k = ksed1(4), kts, -1
4127 odzq = 1./dzq(k)
4128 orho = 1./rho(k)
4129 qgten(k) = qgten(k) + (sed_g(k+1)-sed_g(k)) &
4130 *odzq*onstep(4)*orho
4131 rg(k) = max(r1, rg(k) + (sed_g(k+1)-sed_g(k)) &
4132 *odzq*dt*onstep(4))
4133 pfil1(k) = pfil1(k) + sed_g(k)*dt*onstep(4)
4134 enddo
4135
4136 if (rg(kts).gt.r1*rr_min) then
4137 pptgraul = pptgraul + sed_g(kts)*dt*onstep(4)
4138 endif
4139 enddo
4140 else ! if(.not. sedi_semi) then
4141 niter = 1
4142 dtcfl = dt
4143 niter = int(nstep/max(decfl,1)) + 1
4144 dtcfl = dt/niter
4145
4146 do n = 1, niter
4147 rg_tmp(:) = rg(:)
4148 call semi_lagrange_sedim(kte,dzq,vtgk,rg,graulsfc,pfil,dtcfl,r1)
4149 do k = kts, kte
4150 orhodt = 1./(rho(k)*dt)
4151 qgten(k) = qgten(k) + (rg(k) - rg_tmp(k))*orhodt
4152 pfil1(k) = pfil1(k) + pfil(k)
4153 enddo
4154 pptgraul = pptgraul + graulsfc
4155 do k = kte+1, kts, -1
4156 vtgk(k) = 0.
4157 enddo
4158 do k = kte, kts, -1
4159 vtg = 0.
4160 if (rg(k).gt. r1) then
4161 ygra1 = log10(max(1.e-9_wp, rg(k)))
4162 zans1 = 3.4 + 2./7.*(ygra1+8.) + rand1
4163 n0_exp = 10.**(zans1)
4164 n0_exp = max(real(gonv_min, kind=dp), min(n0_exp, real(gonv_max, kind=dp)))
4165 lam_exp = (n0_exp*am_g*cgg(1)/rg(k))**oge1
4166 lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg
4167
4168 vtg = rhof(k)*av_g*cgg(6)*ogg3 * (1./lamg)**bv_g
4169 if (temp(k).gt. t_0) then
4170 vtgk(k) = max(vtg, vtrk(k))
4171 else
4172 vtgk(k) = vtg
4173 endif
4174 endif
4175 enddo
4176 enddo
4177 endif ! if(.not. sedi_semi) then
4178 endif
4179
4180!+---+-----------------------------------------------------------------+
4183!+---+-----------------------------------------------------------------+
4184 if (.not. iiwarm) then
4185 do k = kts, kte
4186 xri = max(0.0, qi1d(k) + qiten(k)*dt)
4187 if ( (temp(k).gt. t_0) .and. (xri.gt. 0.0) ) then
4188 qcten(k) = qcten(k) + xri*odt
4189 ncten(k) = ncten(k) + ni1d(k)*odt
4190 qiten(k) = qiten(k) - xri*odt
4191 niten(k) = -ni1d(k)*odt
4192 tten(k) = tten(k) - lfus*ocp(k)*xri*odt*(1-ifdry)
4193 !diag
4194 !txri1(k) = lfus*ocp(k)*xri*odt*(1-IFDRY)
4195 endif
4196
4197 xrc = max(0.0, qc1d(k) + qcten(k)*dt)
4198 if ( (temp(k).lt. hgfr) .and. (xrc.gt. 0.0) ) then
4199 lfus2 = lsub - lvap(k)
4200 xnc = nc1d(k) + ncten(k)*dt
4201 qiten(k) = qiten(k) + xrc*odt
4202 niten(k) = niten(k) + xnc*odt
4203 qcten(k) = qcten(k) - xrc*odt
4204 ncten(k) = ncten(k) - xnc*odt
4205 tten(k) = tten(k) + lfus2*ocp(k)*xrc*odt*(1-ifdry)
4206 !diag
4207 !txrc1(k) = lfus2*ocp(k)*xrc*odt*(1-IFDRY)*DT
4208 endif
4209 enddo
4210 endif
4211
4212!+---+-----------------------------------------------------------------+
4214!+---+-----------------------------------------------------------------+
4215 do k = kts, kte
4216 t1d(k) = t1d(k) + tten(k)*dt
4217 qv1d(k) = max(1.e-10, qv1d(k) + qvten(k)*dt)
4218 qc1d(k) = qc1d(k) + qcten(k)*dt
4219 nc1d(k) = max(2./rho(k), min(nc1d(k) + ncten(k)*dt, nt_c_max))
4220 if (is_aerosol_aware) then
4221 nwfa1d(k) = max(11.1e6, min(9999.e6, &
4222 (nwfa1d(k)+nwfaten(k)*dt)))
4223 nifa1d(k) = max(nain1*0.01, min(9999.e6, &
4224 (nifa1d(k)+nifaten(k)*dt)))
4225 end if
4226 if (qc1d(k) .le. r1) then
4227 qc1d(k) = 0.0
4228 nc1d(k) = 0.0
4229 else
4230 if (nc1d(k)*rho(k).gt.10000.e6) then
4231 nu_c = 2
4232 elseif (nc1d(k)*rho(k).lt.100.) then
4233 nu_c = 15
4234 else
4235 nu_c = nint(1000.e6/(nc1d(k)*rho(k))) + 2
4236 nu_c = max(2, min(nu_c+nint(rand2), 15))
4237 endif
4238 lamc = (am_r*ccg(2,nu_c)*ocg1(nu_c)*nc1d(k)/qc1d(k))**obmr
4239 xdc = (bm_r + nu_c + 1.) / lamc
4240 if (xdc.lt. d0c) then
4241 lamc = cce(2,nu_c)/d0c
4242 elseif (xdc.gt. d0r*2.) then
4243 lamc = cce(2,nu_c)/(d0r*2.)
4244 endif
4245 nc1d(k) = min(ccg(1,nu_c)*ocg2(nu_c)*qc1d(k)/am_r*lamc**bm_r,&
4246 real(Nt_c_max, kind=dp)/rho(k))
4247 endif
4248
4249 qi1d(k) = qi1d(k) + qiten(k)*dt
4250 ni1d(k) = max(r2/rho(k), ni1d(k) + niten(k)*dt)
4251 if (qi1d(k) .le. r1) then
4252 qi1d(k) = 0.0
4253 ni1d(k) = 0.0
4254 else
4255 lami = (am_i*cig(2)*oig1*ni1d(k)/qi1d(k))**obmi
4256 ilami = 1./lami
4257 xdi = (bm_i + mu_i + 1.) * ilami
4258 if (xdi.lt. 5.e-6) then
4259 lami = cie(2)/5.e-6
4260 elseif (xdi.gt. 300.e-6) then
4261 lami = cie(2)/300.e-6
4262 endif
4263 ni1d(k) = min(cig(1)*oig2*qi1d(k)/am_i*lami**bm_i, &
4264 nt_i_max/rho(k))
4265 endif
4266 qr1d(k) = qr1d(k) + qrten(k)*dt
4267 nr1d(k) = max(r2/rho(k), nr1d(k) + nrten(k)*dt)
4268 if (qr1d(k) .le. r1) then
4269 qr1d(k) = 0.0
4270 nr1d(k) = 0.0
4271 else
4272 lamr = (am_r*crg(3)*org2*nr1d(k)/qr1d(k))**obmr
4273 mvd_r(k) = (3.0 + mu_r + 0.672) / lamr
4274 if (mvd_r(k) .gt. 2.5e-3) then
4275 mvd_r(k) = 2.5e-3
4276 elseif (mvd_r(k) .lt. d0r*0.75) then
4277 mvd_r(k) = d0r*0.75
4278 endif
4279 lamr = (3.0 + mu_r + 0.672) / mvd_r(k)
4280 nr1d(k) = crg(2)*org3*qr1d(k)*lamr**bm_r / am_r
4281 endif
4282 qs1d(k) = qs1d(k) + qsten(k)*dt
4283 if (qs1d(k) .le. r1) qs1d(k) = 0.0
4284 qg1d(k) = qg1d(k) + qgten(k)*dt
4285 if (qg1d(k) .le. r1) qg1d(k) = 0.0
4286 enddo
4287
4288! Diagnostics
4289 calculate_extended_diagnostics: if (ext_diag) then
4290 do k = kts, kte
4291 if(prw_vcd(k).gt.0)then
4292 prw_vcdc1(k) = prw_vcd(k)*dt
4293 elseif(prw_vcd(k).lt.0)then
4294 prw_vcde1(k) = -1*prw_vcd(k)*dt
4295 endif
4296!heating/cooling diagnostics
4297 tpri_inu1(k) = pri_inu(k)*lsub*ocp(k)*orho * (1-ifdry)*dt
4298
4299 if(pri_ide(k).gt.0)then
4300 tpri_ide1_d(k) = pri_ide(k)*lsub*ocp(k)*orho * (1-ifdry)*dt
4301 else
4302 tpri_ide1_s(k) = -pri_ide(k)*lsub*ocp(k)*orho * (1-ifdry)*dt
4303 endif
4304
4305 if(temp(k).lt.t_0)then
4306 tprs_ide1(k) = prs_ide(k)*lsub*ocp(k)*orho * (1-ifdry)*dt
4307 endif
4308
4309 if(prs_sde(k).gt.0)then
4310 tprs_sde1_d(k) = prs_sde(k)*lsub*ocp(k)*orho * (1-ifdry)*dt
4311 else
4312 tprs_sde1_s(k) = -prs_sde(k)*lsub*ocp(k)*orho * (1-ifdry)*dt
4313 endif
4314
4315 if(prg_gde(k).gt.0)then
4316 tprg_gde1_d(k) = prg_gde(k)*lsub*ocp(k)*orho * (1-ifdry)*dt
4317 else
4318 tprg_gde1_s(k) = -prg_gde(k)*lsub*ocp(k)*orho * (1-ifdry)*dt
4319 endif
4320
4321 tpri_iha1(k) = pri_iha(k)*lsub*ocp(k)*orho * (1-ifdry)*dt
4322 tpri_wfz1(k) = pri_wfz(k)*lfus2*ocp(k)*orho * (1-ifdry)*dt
4323 tpri_rfz1(k) = pri_rfz(k)*lfus2*ocp(k)*orho * (1-ifdry)*dt
4324 tprg_rfz1(k) = prg_rfz(k)*lfus2*ocp(k)*orho * (1-ifdry)*dt
4325 tprs_scw1(k) = prs_scw(k)*lfus2*ocp(k)*orho * (1-ifdry)*dt
4326 tprg_scw1(k) = prg_scw(k)*lfus2*ocp(k)*orho * (1-ifdry)*dt
4327 tprg_rcs1(k) = prg_rcs(k)*lfus2*ocp(k)*orho * (1-ifdry)*dt
4328
4329 if(temp(k).lt.t_0)then
4330 tprs_rcs1(k) = prs_rcs(k)*lfus2*ocp(k)*orho * (1-ifdry)*dt
4331 endif
4332
4333 tprr_rci1(k) = prr_rci(k)*lfus2*ocp(k)*orho * (1-ifdry)*dt
4334
4335 if(temp(k).lt.t_0)then
4336 tprg_rcg1(k) = prg_rcg(k)*lfus2*ocp(k)*orho * (1-ifdry)*dt
4337 endif
4338
4339 if(prw_vcd(k).gt.0)then
4340 tprw_vcd1_c(k) = lvap(k)*ocp(k)*prw_vcd(k)*(1-ifdry)*dt
4341 else
4342 tprw_vcd1_e(k) = -lvap(k)*ocp(k)*prw_vcd(k)*(1-ifdry)*dt
4343 endif
4344
4345! cooling terms
4346 tprr_sml1(k) = prr_sml(k)*lfus*ocp(k)*orho * (1-ifdry)*dt
4347 tprr_gml1(k) = prr_gml(k)*lfus*ocp(k)*orho * (1-ifdry)*dt
4348
4349 if(temp(k).ge.t_0)then
4350 tprr_rcg1(k) = -prr_rcg(k)*lfus*ocp(k)*orho * (1-ifdry)*dt
4351 endif
4352
4353 if(temp(k).ge.t_0)then
4354 tprr_rcs1(k) = -prr_rcs(k)*lfus*ocp(k)*orho * (1-ifdry)*dt
4355 endif
4356
4357 tprv_rev1(k) = lvap(k)*ocp(k)*prv_rev(k)*(1-ifdry)*dt
4358 tten1(k) = tten(k)*dt
4359 qvten1(k) = qvten(k)*dt
4360 qiten1(k) = qiten(k)*dt
4361 qrten1(k) = qrten(k)*dt
4362 qsten1(k) = qsten(k)*dt
4363 qgten1(k) = qgten(k)*dt
4364 niten1(k) = niten(k)*dt
4365 nrten1(k) = nrten(k)*dt
4366 ncten1(k) = ncten(k)*dt
4367 qcten1(k) = qcten(k)*dt
4368 enddo
4369 endif calculate_extended_diagnostics
4370
4371 end subroutine mp_thompson
4373
4374!+---+-----------------------------------------------------------------+
4375!ctrlL
4376!+---+-----------------------------------------------------------------+
4377!..Creation of the lookup tables and support functions found below here.
4378!+---+-----------------------------------------------------------------+
4381 subroutine qr_acr_qg
4382
4383 implicit none
4384
4385!..Local variables
4386 integer:: i, j, k, m, n, n2
4387 integer:: km, km_s, km_e
4388 real(dp), dimension(nbg):: vg, N_g
4389 real(dp), dimension(nbr):: vr, N_r
4390 real(dp) :: N0_r, N0_g, lam_exp, lamg, lamr
4391 real(dp) :: massg, massr, dvg, dvr, t1, t2, z1, z2, y1, y2
4392 logical force_read_thompson, write_thompson_tables
4393 logical lexist,lopen
4394 integer good,ierr
4395
4396 force_read_thompson = .false.
4397 write_thompson_tables = .false.
4398!+---+
4399
4400
4401 good = 0
4402 INQUIRE(file=qr_acr_qg_file, exist=lexist)
4403 call mpi_barrier(mpi_communicator,ierr)
4404 IF ( lexist ) THEN
4405 OPEN(63,file=qr_acr_qg_file,form="unformatted",err=1234)
4406!sms$serial begin
4407 READ(63,err=1234) tcg_racg
4408 READ(63,err=1234) tmr_racg
4409 READ(63,err=1234) tcr_gacr
4410 READ(63,err=1234) tmg_gacr
4411 READ(63,err=1234) tnr_racg
4412 READ(63,err=1234) tnr_gacr
4413!sms$serial end
4414 good = 1
4415 1234 CONTINUE
4416 IF ( good .NE. 1 ) THEN
4417 INQUIRE(63,opened=lopen)
4418 IF (lopen) THEN
4419 IF( force_read_thompson ) THEN
4420 write(0,*) "Error reading "//qr_acr_qg_file//" Aborting because force_read_thompson is .true."
4421 return
4422 ENDIF
4423 CLOSE(63)
4424 ELSE
4425 IF( force_read_thompson ) THEN
4426 write(0,*) "Error opening "//qr_acr_qg_file//" Aborting because force_read_thompson is .true."
4427 return
4428 ENDIF
4429 ENDIF
4430 ELSE
4431 INQUIRE(63,opened=lopen)
4432 IF (lopen) THEN
4433 CLOSE(63)
4434 ENDIF
4435 ENDIF
4436 ELSE
4437 IF( force_read_thompson ) THEN
4438 write(0,*) "Non-existent "//qr_acr_qg_file//" Aborting because force_read_thompson is .true."
4439 return
4440 ENDIF
4441 ENDIF
4442
4443 IF (.NOT. good .EQ. 1 ) THEN
4444 if (thompson_table_writer) then
4445 write_thompson_tables = .true.
4446 write(0,*) "ThompMP: computing qr_acr_qg"
4447 endif
4448 do n2 = 1, nbr
4449! vr(n2) = av_r*Dr(n2)**bv_r * exp(real(-fv_r*Dr(n2), kind=dp))
4450 vr(n2) = -0.1021 + 4.932e3*dr(n2) - 0.9551e6*dr(n2)*dr(n2) &
4451 + 0.07934e9*dr(n2)*dr(n2)*dr(n2) &
4452 - 0.002362e12*dr(n2)*dr(n2)*dr(n2)*dr(n2)
4453 enddo
4454 do n = 1, nbg
4455 vg(n) = av_g*dg(n)**bv_g
4456 enddo
4457
4458!..Note values returned from wrf_dm_decomp1d are zero-based, add 1 for
4459!.. fortran indices. J. Michalakes, 2009Oct30.
4460
4461#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
4462 CALL wrf_dm_decomp1d ( ntb_r*ntb_r1, km_s, km_e )
4463#else
4464 km_s = 0
4465 km_e = ntb_r*ntb_r1 - 1
4466#endif
4467
4468 do km = km_s, km_e
4469 m = km / ntb_r1 + 1
4470 k = mod( km , ntb_r1 ) + 1
4471
4472 lam_exp = (n0r_exp(k)*am_r*crg(1)/r_r(m))**ore1
4473 lamr = lam_exp * (crg(3)*org2*org1)**obmr
4474 n0_r = n0r_exp(k)/(crg(2)*lam_exp) * lamr**cre(2)
4475 do n2 = 1, nbr
4476 n_r(n2) = n0_r*dr(n2)**mu_r *exp(-lamr*dr(n2))*dtr(n2)
4477 enddo
4478
4479 do j = 1, ntb_g
4480 do i = 1, ntb_g1
4481 lam_exp = (n0g_exp(i)*am_g*cgg(1)/r_g(j))**oge1
4482 lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg
4483 n0_g = n0g_exp(i)/(cgg(2)*lam_exp) * lamg**cge(2)
4484 do n = 1, nbg
4485 n_g(n) = n0_g*dg(n)**mu_g * exp(-lamg*dg(n))*dtg(n)
4486 enddo
4487
4488 t1 = 0.0_dp
4489 t2 = 0.0_dp
4490 z1 = 0.0_dp
4491 z2 = 0.0_dp
4492 y1 = 0.0_dp
4493 y2 = 0.0_dp
4494 do n2 = 1, nbr
4495 massr = am_r * dr(n2)**bm_r
4496 do n = 1, nbg
4497 massg = am_g * dg(n)**bm_g
4498
4499 dvg = 0.5d0*((vr(n2) - vg(n)) + abs(real(vr(n2)-vg(n), kind=dp)))
4500 dvr = 0.5d0*((vg(n) - vr(n2)) + abs(real(vg(n)-vr(n2), kind=dp)))
4501
4502 t1 = t1+ pi*.25*ef_rg*(dg(n)+dr(n2))*(dg(n)+dr(n2)) &
4503 *dvg*massg * n_g(n)* n_r(n2)
4504 z1 = z1+ pi*.25*ef_rg*(dg(n)+dr(n2))*(dg(n)+dr(n2)) &
4505 *dvg*massr * n_g(n)* n_r(n2)
4506 y1 = y1+ pi*.25*ef_rg*(dg(n)+dr(n2))*(dg(n)+dr(n2)) &
4507 *dvg * n_g(n)* n_r(n2)
4508
4509 t2 = t2+ pi*.25*ef_rg*(dg(n)+dr(n2))*(dg(n)+dr(n2)) &
4510 *dvr*massr * n_g(n)* n_r(n2)
4511 y2 = y2+ pi*.25*ef_rg*(dg(n)+dr(n2))*(dg(n)+dr(n2)) &
4512 *dvr * n_g(n)* n_r(n2)
4513 z2 = z2+ pi*.25*ef_rg*(dg(n)+dr(n2))*(dg(n)+dr(n2)) &
4514 *dvr*massg * n_g(n)* n_r(n2)
4515 enddo
4516 97 continue
4517 enddo
4518 tcg_racg(i,j,k,m) = t1
4519 tmr_racg(i,j,k,m) = min(z1, r_r(m)*1.0_dp)
4520 tcr_gacr(i,j,k,m) = t2
4521 tmg_gacr(i,j,k,m) = min(z2, r_g(j)*1.0_dp)
4522 tnr_racg(i,j,k,m) = y1
4523 tnr_gacr(i,j,k,m) = y2
4524 enddo
4525 enddo
4526 enddo
4527
4528 IF ( write_thompson_tables ) THEN
4529 write(0,*) "Writing "//qr_acr_qg_file//" in Thompson MP init"
4530 OPEN(63,file=qr_acr_qg_file,form="unformatted",err=9234)
4531 WRITE(63,err=9234) tcg_racg
4532 WRITE(63,err=9234) tmr_racg
4533 WRITE(63,err=9234) tcr_gacr
4534 WRITE(63,err=9234) tmg_gacr
4535 WRITE(63,err=9234) tnr_racg
4536 WRITE(63,err=9234) tnr_gacr
4537 CLOSE(63)
4538 RETURN ! ----- RETURN
4539 9234 CONTINUE
4540 write(0,*) "Error writing "//qr_acr_qg_file
4541 return
4542 ENDIF
4543 ENDIF
4544
4545 end subroutine qr_acr_qg
4546!+---+-----------------------------------------------------------------+
4547!ctrlL
4548!+---+-----------------------------------------------------------------+
4551 subroutine qr_acr_qs
4552
4553 implicit none
4554
4555!..Local variables
4556 integer:: i, j, k, m, n, n2
4557 integer:: km, km_s, km_e
4558 real(dp), dimension(nbr):: vr, D1, N_r
4559 real(dp), dimension(nbs):: vs, N_s
4560 real(dp) :: loga_, a_, b_, second, M0, M2, M3, Mrat, oM3
4561 real(dp) :: N0_r, lam_exp, lamr, slam1, slam2
4562 real(dp) :: dvs, dvr, masss, massr
4563 real(dp) :: t1, t2, t3, t4, z1, z2, z3, z4
4564 real(dp) :: y1, y2, y3, y4
4565 logical force_read_thompson, write_thompson_tables
4566 logical lexist,lopen
4567 integer good,ierr
4568
4569!+---+
4570
4571 force_read_thompson = .false.
4572 write_thompson_tables = .false.
4573
4574 good = 0
4575 INQUIRE(file=qr_acr_qs_file, exist=lexist)
4576 call mpi_barrier(mpi_communicator,ierr)
4577 IF ( lexist ) THEN
4578 !write(0,*) "ThompMP: read "//qr_acr_qs_file//" instead of computing"
4579 OPEN(63,file=qr_acr_qs_file,form="unformatted",err=1234)
4580!sms$serial begin
4581 READ(63,err=1234)tcs_racs1
4582 READ(63,err=1234)tmr_racs1
4583 READ(63,err=1234)tcs_racs2
4584 READ(63,err=1234)tmr_racs2
4585 READ(63,err=1234)tcr_sacr1
4586 READ(63,err=1234)tms_sacr1
4587 READ(63,err=1234)tcr_sacr2
4588 READ(63,err=1234)tms_sacr2
4589 READ(63,err=1234)tnr_racs1
4590 READ(63,err=1234)tnr_racs2
4591 READ(63,err=1234)tnr_sacr1
4592 READ(63,err=1234)tnr_sacr2
4593!sms$serial end
4594 good = 1
4595 1234 CONTINUE
4596 IF ( good .NE. 1 ) THEN
4597 INQUIRE(63,opened=lopen)
4598 IF (lopen) THEN
4599 IF( force_read_thompson ) THEN
4600 write(0,*) "Error reading "//qr_acr_qs_file//" Aborting because force_read_thompson is .true."
4601 return
4602 ENDIF
4603 CLOSE(63)
4604 ELSE
4605 IF( force_read_thompson ) THEN
4606 write(0,*) "Error opening "//qr_acr_qs_file//" Aborting because force_read_thompson is .true."
4607 return
4608 ENDIF
4609 ENDIF
4610 ELSE
4611 INQUIRE(63,opened=lopen)
4612 IF (lopen) THEN
4613 CLOSE(63)
4614 ENDIF
4615 ENDIF
4616 ELSE
4617 IF( force_read_thompson ) THEN
4618 write(0,*) "Non-existent "//qr_acr_qs_file//" Aborting because force_read_thompson is .true."
4619 return
4620 ENDIF
4621 ENDIF
4622
4623 IF (.NOT. good .EQ. 1 ) THEN
4624 if (thompson_table_writer) then
4625 write_thompson_tables = .true.
4626 write(0,*) "ThompMP: computing qr_acr_qs"
4627 endif
4628 do n2 = 1, nbr
4629! vr(n2) = av_r*Dr(n2)**bv_r * exp(real(-fv_r*Dr(n2), kind=dp))
4630 vr(n2) = -0.1021 + 4.932e3*dr(n2) - 0.9551e6*dr(n2)*dr(n2) &
4631 + 0.07934e9*dr(n2)*dr(n2)*dr(n2) &
4632 - 0.002362e12*dr(n2)*dr(n2)*dr(n2)*dr(n2)
4633 d1(n2) = (vr(n2)/av_s)**(1./bv_s)
4634 enddo
4635 do n = 1, nbs
4636 vs(n) = 1.5*av_s*ds(n)**bv_s * exp(real(-fv_s*ds(n), kind=dp))
4637 enddo
4638
4639!..Note values returned from wrf_dm_decomp1d are zero-based, add 1 for
4640!.. fortran indices. J. Michalakes, 2009Oct30.
4641
4642#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
4643 CALL wrf_dm_decomp1d ( ntb_r*ntb_r1, km_s, km_e )
4644#else
4645 km_s = 0
4646 km_e = ntb_r*ntb_r1 - 1
4647#endif
4648
4649 do km = km_s, km_e
4650 m = km / ntb_r1 + 1
4651 k = mod( km , ntb_r1 ) + 1
4652
4653 lam_exp = (n0r_exp(k)*am_r*crg(1)/r_r(m))**ore1
4654 lamr = lam_exp * (crg(3)*org2*org1)**obmr
4655 n0_r = n0r_exp(k)/(crg(2)*lam_exp) * lamr**cre(2)
4656 do n2 = 1, nbr
4657 n_r(n2) = n0_r*dr(n2)**mu_r * exp(-lamr*dr(n2))*dtr(n2)
4658 enddo
4659
4660 do j = 1, ntb_t
4661 do i = 1, ntb_s
4662
4663!..From the bm_s moment, compute plus one moment. If we are not
4664!.. using bm_s=2, then we must transform to the pure 2nd moment
4665!.. (variable called "second") and then to the bm_s+1 moment.
4666
4667 m2 = r_s(i)*oams*1.0_dp
4668 if (bm_s.gt.2.0-1.e-3 .and. bm_s.lt.2.0+1.e-3) then
4669 loga_ = sa(1) + sa(2)*tc(j) + sa(3)*bm_s &
4670 + sa(4)*tc(j)*bm_s + sa(5)*tc(j)*tc(j) &
4671 + sa(6)*bm_s*bm_s + sa(7)*tc(j)*tc(j)*bm_s &
4672 + sa(8)*tc(j)*bm_s*bm_s + sa(9)*tc(j)*tc(j)*tc(j) &
4673 + sa(10)*bm_s*bm_s*bm_s
4674 a_ = 10.0**loga_
4675 b_ = sb(1) + sb(2)*tc(j) + sb(3)*bm_s &
4676 + sb(4)*tc(j)*bm_s + sb(5)*tc(j)*tc(j) &
4677 + sb(6)*bm_s*bm_s + sb(7)*tc(j)*tc(j)*bm_s &
4678 + sb(8)*tc(j)*bm_s*bm_s + sb(9)*tc(j)*tc(j)*tc(j) &
4679 + sb(10)*bm_s*bm_s*bm_s
4680 second = (m2/a_)**(1./b_)
4681 else
4682 second = m2
4683 endif
4684
4685 loga_ = sa(1) + sa(2)*tc(j) + sa(3)*cse(1) &
4686 + sa(4)*tc(j)*cse(1) + sa(5)*tc(j)*tc(j) &
4687 + sa(6)*cse(1)*cse(1) + sa(7)*tc(j)*tc(j)*cse(1) &
4688 + sa(8)*tc(j)*cse(1)*cse(1) + sa(9)*tc(j)*tc(j)*tc(j) &
4689 + sa(10)*cse(1)*cse(1)*cse(1)
4690 a_ = 10.0**loga_
4691 b_ = sb(1)+sb(2)*tc(j)+sb(3)*cse(1) + sb(4)*tc(j)*cse(1) &
4692 + sb(5)*tc(j)*tc(j) + sb(6)*cse(1)*cse(1) &
4693 + sb(7)*tc(j)*tc(j)*cse(1) + sb(8)*tc(j)*cse(1)*cse(1) &
4694 + sb(9)*tc(j)*tc(j)*tc(j)+sb(10)*cse(1)*cse(1)*cse(1)
4695 m3 = a_ * second**b_
4696
4697 om3 = 1./m3
4698 mrat = m2*(m2*om3)*(m2*om3)*(m2*om3)
4699 m0 = (m2*om3)**mu_s
4700 slam1 = m2 * om3 * lam0
4701 slam2 = m2 * om3 * lam1
4702
4703 do n = 1, nbs
4704 n_s(n) = mrat*(kap0*exp(-slam1*ds(n)) &
4705 + kap1*m0*ds(n)**mu_s * exp(-slam2*ds(n)))*dts(n)
4706 enddo
4707
4708 t1 = 0.0_dp
4709 t2 = 0.0_dp
4710 t3 = 0.0_dp
4711 t4 = 0.0_dp
4712 z1 = 0.0_dp
4713 z2 = 0.0_dp
4714 z3 = 0.0_dp
4715 z4 = 0.0_dp
4716 y1 = 0.0_dp
4717 y2 = 0.0_dp
4718 y3 = 0.0_dp
4719 y4 = 0.0_dp
4720 do n2 = 1, nbr
4721 massr = am_r * dr(n2)**bm_r
4722 do n = 1, nbs
4723 masss = am_s * ds(n)**bm_s
4724
4725 dvs = 0.5d0*((vr(n2) - vs(n)) + dabs(vr(n2)-vs(n)))
4726 dvr = 0.5d0*((vs(n) - vr(n2)) + dabs(vs(n)-vr(n2)))
4727
4728 if (massr .gt. 1.5*masss) then
4729 t1 = t1+ pi*.25*ef_rs*(ds(n)+dr(n2))*(ds(n)+dr(n2)) &
4730 *dvs*masss * n_s(n)* n_r(n2)
4731 z1 = z1+ pi*.25*ef_rs*(ds(n)+dr(n2))*(ds(n)+dr(n2)) &
4732 *dvs*massr * n_s(n)* n_r(n2)
4733 y1 = y1+ pi*.25*ef_rs*(ds(n)+dr(n2))*(ds(n)+dr(n2)) &
4734 *dvs * n_s(n)* n_r(n2)
4735 else
4736 t3 = t3+ pi*.25*ef_rs*(ds(n)+dr(n2))*(ds(n)+dr(n2)) &
4737 *dvs*masss * n_s(n)* n_r(n2)
4738 z3 = z3+ pi*.25*ef_rs*(ds(n)+dr(n2))*(ds(n)+dr(n2)) &
4739 *dvs*massr * n_s(n)* n_r(n2)
4740 y3 = y3+ pi*.25*ef_rs*(ds(n)+dr(n2))*(ds(n)+dr(n2)) &
4741 *dvs * n_s(n)* n_r(n2)
4742 endif
4743
4744 if (massr .gt. 1.5*masss) then
4745 t2 = t2+ pi*.25*ef_rs*(ds(n)+dr(n2))*(ds(n)+dr(n2)) &
4746 *dvr*massr * n_s(n)* n_r(n2)
4747 y2 = y2+ pi*.25*ef_rs*(ds(n)+dr(n2))*(ds(n)+dr(n2)) &
4748 *dvr * n_s(n)* n_r(n2)
4749 z2 = z2+ pi*.25*ef_rs*(ds(n)+dr(n2))*(ds(n)+dr(n2)) &
4750 *dvr*masss * n_s(n)* n_r(n2)
4751 else
4752 t4 = t4+ pi*.25*ef_rs*(ds(n)+dr(n2))*(ds(n)+dr(n2)) &
4753 *dvr*massr * n_s(n)* n_r(n2)
4754 y4 = y4+ pi*.25*ef_rs*(ds(n)+dr(n2))*(ds(n)+dr(n2)) &
4755 *dvr * n_s(n)* n_r(n2)
4756 z4 = z4+ pi*.25*ef_rs*(ds(n)+dr(n2))*(ds(n)+dr(n2)) &
4757 *dvr*masss * n_s(n)* n_r(n2)
4758 endif
4759
4760 enddo
4761 enddo
4762 tcs_racs1(i,j,k,m) = t1
4763 tmr_racs1(i,j,k,m) = min(z1, r_r(m)*1.0_dp)
4764 tcs_racs2(i,j,k,m) = t3
4765 tmr_racs2(i,j,k,m) = z3
4766 tcr_sacr1(i,j,k,m) = t2
4767 tms_sacr1(i,j,k,m) = z2
4768 tcr_sacr2(i,j,k,m) = t4
4769 tms_sacr2(i,j,k,m) = z4
4770 tnr_racs1(i,j,k,m) = y1
4771 tnr_racs2(i,j,k,m) = y3
4772 tnr_sacr1(i,j,k,m) = y2
4773 tnr_sacr2(i,j,k,m) = y4
4774 enddo
4775 enddo
4776 enddo
4777
4778 IF ( write_thompson_tables ) THEN
4779 write(0,*) "Writing "//qr_acr_qs_file//" in Thompson MP init"
4780 OPEN(63,file=qr_acr_qs_file,form="unformatted",err=9234)
4781 WRITE(63,err=9234)tcs_racs1
4782 WRITE(63,err=9234)tmr_racs1
4783 WRITE(63,err=9234)tcs_racs2
4784 WRITE(63,err=9234)tmr_racs2
4785 WRITE(63,err=9234)tcr_sacr1
4786 WRITE(63,err=9234)tms_sacr1
4787 WRITE(63,err=9234)tcr_sacr2
4788 WRITE(63,err=9234)tms_sacr2
4789 WRITE(63,err=9234)tnr_racs1
4790 WRITE(63,err=9234)tnr_racs2
4791 WRITE(63,err=9234)tnr_sacr1
4792 WRITE(63,err=9234)tnr_sacr2
4793 CLOSE(63)
4794 RETURN ! ----- RETURN
4795 9234 CONTINUE
4796 write(0,*) "Error writing "//qr_acr_qs_file
4797 ENDIF
4798 ENDIF
4799
4800 end subroutine qr_acr_qs
4801!+---+-----------------------------------------------------------------+
4802!ctrlL
4803!+---+-----------------------------------------------------------------+
4808 subroutine freezeh2o(threads)
4809
4810 implicit none
4811
4812!..Interface variables
4813 integer, intent(in):: threads
4814
4815!..Local variables
4816 integer:: i, j, k, m, n, n2
4817 real(dp) :: N_r, N_c
4818 real(dp), dimension(nbr):: massr
4819 real(dp), dimension(nbc):: massc
4820 real(dp) :: sum1, sum2, sumn1, sumn2, &
4821 prob, vol, Texp, orho_w, &
4822 lam_exp, lamr, N0_r, lamc, N0_c, y
4823 integer :: nu_c
4824 real(wp) :: T_adjust
4825 logical force_read_thompson, write_thompson_tables
4826 logical lexist,lopen
4827 integer good,ierr
4828
4829!+---+
4830 force_read_thompson = .false.
4831 write_thompson_tables = .false.
4832
4833 good = 0
4834 INQUIRE(file=freeze_h2o_file,exist=lexist)
4835 call mpi_barrier(mpi_communicator,ierr)
4836 IF ( lexist ) THEN
4837 !write(0,*) "ThompMP: read "//freeze_h2o_file//" instead of computing"
4838 OPEN(63,file=freeze_h2o_file,form="unformatted",err=1234)
4839!sms$serial begin
4840 READ(63,err=1234)tpi_qrfz
4841 READ(63,err=1234)tni_qrfz
4842 READ(63,err=1234)tpg_qrfz
4843 READ(63,err=1234)tnr_qrfz
4844 READ(63,err=1234)tpi_qcfz
4845 READ(63,err=1234)tni_qcfz
4846!sms$serial end
4847 good = 1
4848 1234 CONTINUE
4849 IF ( good .NE. 1 ) THEN
4850 INQUIRE(63,opened=lopen)
4851 IF (lopen) THEN
4852 IF( force_read_thompson ) THEN
4853 write(0,*) "Error reading "//freeze_h2o_file//" Aborting because force_read_thompson is .true."
4854 return
4855 ENDIF
4856 CLOSE(63)
4857 ELSE
4858 IF( force_read_thompson ) THEN
4859 write(0,*) "Error opening "//freeze_h2o_file//" Aborting because force_read_thompson is .true."
4860 return
4861 ENDIF
4862 ENDIF
4863 ELSE
4864 INQUIRE(63,opened=lopen)
4865 IF (lopen) THEN
4866 CLOSE(63)
4867 ENDIF
4868 ENDIF
4869 ELSE
4870 IF( force_read_thompson ) THEN
4871 write(0,*) "Non-existent "//freeze_h2o_file//" Aborting because force_read_thompson is .true."
4872 return
4873 ENDIF
4874 ENDIF
4875
4876 IF (.NOT. good .EQ. 1 ) THEN
4877 if (thompson_table_writer) then
4878 write_thompson_tables = .true.
4879 write(0,*) "ThompMP: computing freezeH2O"
4880 endif
4881
4882 orho_w = 1./rho_w
4883
4884 do n2 = 1, nbr
4885 massr(n2) = am_r*dr(n2)**bm_r
4886 enddo
4887 do n = 1, nbc
4888 massc(n) = am_r*dc(n)**bm_r
4889 enddo
4890
4891!..Freeze water (smallest drops become cloud ice, otherwise graupel).
4892 do m = 1, ntb_in
4893 t_adjust = max(-3.0, min(3.0 - log10(nt_in(m)), 3.0))
4894 do k = 1, 45
4895! print*, ' Freezing water for temp = ', -k
4896 texp = exp( real(k, kind=dp) - t_adjust*1.0_dp ) - 1.0_dp
4897!$OMP PARALLEL DO SCHEDULE(dynamic) num_threads(threads) &
4898!$OMP PRIVATE(j,i,lam_exp,lamr,N0_r,sum1,sum2,sumn1,sumn2,n2,N_r,vol,prob)
4899 do j = 1, ntb_r1
4900 do i = 1, ntb_r
4901 lam_exp = (n0r_exp(j)*am_r*crg(1)/r_r(i))**ore1
4902 lamr = lam_exp * (crg(3)*org2*org1)**obmr
4903 n0_r = n0r_exp(j)/(crg(2)*lam_exp) * lamr**cre(2)
4904 sum1 = 0.0_dp
4905 sum2 = 0.0_dp
4906 sumn1 = 0.0_dp
4907 sumn2 = 0.0_dp
4908 do n2 = nbr, 1, -1
4909 n_r = n0_r*dr(n2)**mu_r*exp(-lamr*dr(n2))*dtr(n2)
4910 vol = massr(n2)*orho_w
4911 prob = max(0.0_dp, 1.0_dp - exp(-120.0_dp*vol*5.2e-4_dp * texp))
4912 if (massr(n2) .lt. xm0g) then
4913 sumn1 = sumn1 + prob*n_r
4914 sum1 = sum1 + prob*n_r*massr(n2)
4915 else
4916 sumn2 = sumn2 + prob*n_r
4917 sum2 = sum2 + prob*n_r*massr(n2)
4918 endif
4919 if ((sum1+sum2).ge.r_r(i)) EXIT
4920 enddo
4921 tpi_qrfz(i,j,k,m) = sum1
4922 tni_qrfz(i,j,k,m) = sumn1
4923 tpg_qrfz(i,j,k,m) = sum2
4924 tnr_qrfz(i,j,k,m) = sumn2
4925 enddo
4926 enddo
4927!$OMP END PARALLEL DO
4928
4929!$OMP PARALLEL DO SCHEDULE(dynamic) num_threads(threads) &
4930!$OMP PRIVATE(j,i,nu_c,lamc,N0_c,sum1,sumn2,vol,prob,N_c)
4931 do j = 1, nbc
4932 nu_c = min(15, nint(1000.e6/t_nc(j)) + 2)
4933 do i = 1, ntb_c
4934 lamc = (t_nc(j)*am_r* ccg(2,nu_c) * ocg1(nu_c) / r_c(i))**obmr
4935 n0_c = t_nc(j)*ocg1(nu_c) * lamc**cce(1,nu_c)
4936 sum1 = 0.0_dp
4937 sumn2 = 0.0_dp
4938 do n = nbc, 1, -1
4939 vol = massc(n)*orho_w
4940 prob = max(0.0_dp, 1.0_dp - exp(-120.0_dp*vol*5.2e-4_dp * texp))
4941 n_c = n0_c*dc(n)**nu_c*exp(-lamc*dc(n))*dtc(n)
4942 sumn2 = min(t_nc(j), sumn2 + prob*n_c)
4943 sum1 = sum1 + prob*n_c*massc(n)
4944 if (sum1 .ge. r_c(i)) EXIT
4945 enddo
4946 tpi_qcfz(i,j,k,m) = sum1
4947 tni_qcfz(i,j,k,m) = sumn2
4948 enddo
4949 enddo
4950!$OMP END PARALLEL DO
4951 enddo
4952 enddo
4953
4954 IF ( write_thompson_tables ) THEN
4955 write(0,*) "Writing "//freeze_h2o_file//" in Thompson MP init"
4956 OPEN(63,file=freeze_h2o_file,form="unformatted",err=9234)
4957 WRITE(63,err=9234)tpi_qrfz
4958 WRITE(63,err=9234)tni_qrfz
4959 WRITE(63,err=9234)tpg_qrfz
4960 WRITE(63,err=9234)tnr_qrfz
4961 WRITE(63,err=9234)tpi_qcfz
4962 WRITE(63,err=9234)tni_qcfz
4963 CLOSE(63)
4964 RETURN ! ----- RETURN
4965 9234 CONTINUE
4966 write(0,*) "Error writing "//freeze_h2o_file
4967 return
4968 ENDIF
4969 ENDIF
4970
4971 end subroutine freezeh2o
4972
4973!+---+-----------------------------------------------------------------+
4974!ctrlL
4975!+---+-----------------------------------------------------------------+
4985 subroutine qi_aut_qs
4986
4987 implicit none
4988
4989!..Local variables
4990 integer:: i, j, n2
4991 real(dp), dimension(nbi):: N_i
4992 real(dp) :: N0_i, lami, Di_mean, t1, t2
4993 real(wp) :: xlimit_intg
4994
4995!+---+
4996
4997 do j = 1, ntb_i1
4998 do i = 1, ntb_i
4999 lami = (am_i*cig(2)*oig1*nt_i(j)/r_i(i))**obmi
5000 di_mean = (bm_i + mu_i + 1.) / lami
5001 n0_i = nt_i(j)*oig1 * lami**cie(1)
5002 t1 = 0.0_dp
5003 t2 = 0.0_dp
5004 if (sngl(di_mean) .gt. 5.*d0s) then
5005 t1 = r_i(i)
5006 t2 = nt_i(j)
5007 tpi_ide(i,j) = 0.0_dp
5008 elseif (sngl(di_mean) .lt. d0i) then
5009 t1 = 0.0_dp
5010 t2 = 0.0_dp
5011 tpi_ide(i,j) = 1.0_dp
5012 else
5013 xlimit_intg = lami*d0s
5014 tpi_ide(i,j) = gammp(mu_i+2.0, xlimit_intg) * 1.0_dp
5015 do n2 = 1, nbi
5016 n_i(n2) = n0_i*di(n2)**mu_i * exp(-lami*di(n2))*dti(n2)
5017 if (di(n2).ge.d0s) then
5018 t1 = t1 + n_i(n2) * am_i*di(n2)**bm_i
5019 t2 = t2 + n_i(n2)
5020 endif
5021 enddo
5022 endif
5023 tps_iaus(i,j) = t1
5024 tni_iaus(i,j) = t2
5025 enddo
5026 enddo
5027
5028 end subroutine qi_aut_qs
5029!ctrlL
5030!+---+-----------------------------------------------------------------+
5035 subroutine table_efrw
5036
5037 implicit none
5038
5039!..Local variables
5040 real(dp) :: vtr, stokes, reynolds, Ef_rw
5041 real(dp) :: p, yc0, F, G, H, z, K0, X
5042 integer:: i, j
5043
5044 do j = 1, nbc
5045 do i = 1, nbr
5046 ef_rw = 0.0
5047 p = dc(j)/dr(i)
5048 if (dr(i).lt.50.e-6 .or. dc(j).lt.3.e-6) then
5049 t_efrw(i,j) = 0.0
5050 elseif (p.gt.0.25) then
5051 x = dc(j)*1.e6_dp
5052 if (dr(i) .lt. 75.e-6) then
5053 ef_rw = 0.026794*x - 0.20604
5054 elseif (dr(i) .lt. 125.e-6) then
5055 ef_rw = -0.00066842*x*x + 0.061542*x - 0.37089
5056 elseif (dr(i) .lt. 175.e-6) then
5057 ef_rw = 4.091e-06*x*x*x*x - 0.00030908*x*x*x &
5058 + 0.0066237*x*x - 0.0013687*x - 0.073022
5059 elseif (dr(i) .lt. 250.e-6) then
5060 ef_rw = 9.6719e-5*x*x*x - 0.0068901*x*x + 0.17305*x &
5061 - 0.65988
5062 elseif (dr(i) .lt. 350.e-6) then
5063 ef_rw = 9.0488e-5*x*x*x - 0.006585*x*x + 0.16606*x &
5064 - 0.56125
5065 else
5066 ef_rw = 0.00010721*x*x*x - 0.0072962*x*x + 0.1704*x &
5067 - 0.46929
5068 endif
5069 else
5070 vtr = -0.1021 + 4.932e3*dr(i) - 0.9551e6*dr(i)*dr(i) &
5071 + 0.07934e9*dr(i)*dr(i)*dr(i) &
5072 - 0.002362e12*dr(i)*dr(i)*dr(i)*dr(i)
5073 stokes = dc(j)*dc(j)*vtr*rho_w/(9.*1.718e-5*dr(i))
5074 reynolds = 9.*stokes/(p*p*rho_w)
5075
5076 f = log(real(reynolds, kind=dp))
5077 g = -0.1007_dp - 0.358_dp*f + 0.0261_dp*f*f
5078 k0 = exp(g)
5079 z = log(stokes/(k0+1.e-15_dp))
5080 h = 0.1465d0 + 1.302d0*z - 0.607d0*z*z + 0.293d0*z*z*z
5081 yc0 = 2.0_dp/pi * atan(h)
5082 ef_rw = (yc0+p)*(yc0+p) / ((1.+p)*(1.+p))
5083
5084 endif
5085
5086 t_efrw(i,j) = max(0.0, min(sngl(ef_rw), 0.95))
5087
5088 enddo
5089 enddo
5090
5091 end subroutine table_efrw
5092!ctrlL
5093!+---+-----------------------------------------------------------------+
5098 subroutine table_efsw
5099
5100 implicit none
5101
5102!..Local variables
5103 real(dp) :: Ds_m, vts, vtc, stokes, reynolds, Ef_sw
5104 real(dp) :: p, yc0, F, G, H, z, K0
5105 integer:: i, j
5106
5107 do j = 1, nbc
5108 vtc = 1.19e4_dp * (1.0e4_dp*dc(j)*dc(j)*0.25_dp)
5109 do i = 1, nbs
5110 vts = av_s*ds(i)**bv_s * exp(real(-fv_s*ds(i), kind=dp)) - vtc
5111 ds_m = (am_s*ds(i)**bm_s / am_r)**obmr
5112 p = dc(j)/ds_m
5113 if (p.gt.0.25 .or. ds(i).lt.d0s .or. dc(j).lt.6.e-6 &
5114 .or. vts.lt.1.e-3) then
5115 t_efsw(i,j) = 0.0
5116 else
5117 stokes = dc(j)*dc(j)*vts*rho_w/(9.*1.718e-5*ds_m)
5118 reynolds = 9.*stokes/(p*p*rho_w)
5119
5120 f = log(real(reynolds, kind=dp))
5121 g = -0.1007_dp - 0.358_dp*f + 0.0261_dp*f*f
5122 k0 = exp(g)
5123 z = log(stokes/(k0+1.e-15_dp))
5124 h = 0.1465d0 + 1.302d0*z - 0.607d0*z*z + 0.293d0*z*z*z
5125 yc0 = 2.0_dp/pi * atan(h)
5126 ef_sw = (yc0+p)*(yc0+p) / ((1.+p)*(1.+p))
5127
5128 t_efsw(i,j) = max(0.0, min(sngl(ef_sw), 0.95))
5129 endif
5130
5131 enddo
5132 enddo
5133
5134 end subroutine table_efsw
5135!ctrlL
5136!+---+-----------------------------------------------------------------+
5141 real function eff_aero(d, da, visc,rhoa,temp,species)
5142
5143 implicit none
5144 real:: d, da, visc, rhoa, temp
5145 character(LEN=1):: species
5146 real:: aval, cc, diff, re, sc, st, st2, vt, eff
5147 real(wp), parameter:: boltzman = 1.3806503e-23
5148 real(wp), parameter:: meanpath = 0.0256e-6
5149
5150 vt = 1.
5151 if (species .eq. 'r') then
5152 vt = -0.1021 + 4.932e3*d - 0.9551e6*d*d &
5153 + 0.07934e9*d*d*d - 0.002362e12*d*d*d*d
5154 elseif (species .eq. 's') then
5155 vt = av_s*d**bv_s
5156 elseif (species .eq. 'g') then
5157 vt = av_g*d**bv_g
5158 endif
5159
5160 cc = 1. + 2.*meanpath/da *(1.257+0.4*exp(-0.55*da/meanpath))
5161 diff = boltzman*temp*cc/(3.*pi*visc*da)
5162
5163 re = 0.5*rhoa*d*vt/visc
5164 sc = visc/(rhoa*diff)
5165
5166 st = da*da*vt*1000./(9.*visc*d)
5167 aval = 1.+log(1.+re)
5168 st2 = (1.2 + 1./12.*aval)/(1.+aval)
5169
5170 eff = 4./(re*sc) * (1. + 0.4*sqrt(re)*sc**0.3333 &
5171 + 0.16*sqrt(re)*sqrt(sc)) &
5172 + 4.*da/d * (0.02 + da/d*(1.+2.*sqrt(re)))
5173
5174 if (st.gt.st2) eff = eff + ( (st-st2)/(st-st2+0.666667))**1.5
5175 eff_aero = max(1.e-5, min(eff, 1.0))
5176
5177 end function eff_aero
5178
5179!ctrlL
5180!+---+-----------------------------------------------------------------+
5186 subroutine table_dropevap
5187
5188 implicit none
5189
5190!..Local variables
5191 integer:: i, j, k, n
5192 real(dp), dimension(nbc):: N_c, massc
5193 real(dp) :: summ, summ2, lamc, N0_c
5194 integer:: nu_c
5195! real(dp) :: Nt_r, N0, lam_exp, lam
5196! real(wp) :: xlimit_intg
5197
5198 do n = 1, nbc
5199 massc(n) = am_r*dc(n)**bm_r
5200 enddo
5201
5202 do k = 1, nbc
5203 nu_c = min(15, nint(1000.e6/t_nc(k)) + 2)
5204 do j = 1, ntb_c
5205 lamc = (t_nc(k)*am_r* ccg(2,nu_c)*ocg1(nu_c) / r_c(j))**obmr
5206 n0_c = t_nc(k)*ocg1(nu_c) * lamc**cce(1,nu_c)
5207 do i = 1, nbc
5208!-GT tnc_wev(i,j,k) = GAMMP(nu_c+1., SNGL(Dc(i)*lamc))*t_Nc(k)
5209 n_c(i) = n0_c* dc(i)**nu_c*exp(-lamc*dc(i))*dtc(i)
5210! if(j.eq.18 .and. k.eq.50) print*, ' N_c = ', N_c(i)
5211 summ = 0.
5212 summ2 = 0.
5213 do n = 1, i
5214 summ = summ + massc(n)*n_c(n)
5215 summ2 = summ2 + n_c(n)
5216 enddo
5217! if(j.eq.18 .and. k.eq.50) print*, ' DEBUG-TABLE: ', r_c(j), t_Nc(k), summ2, summ
5218 tpc_wev(i,j,k) = summ
5219 tnc_wev(i,j,k) = summ2
5220 enddo
5221 enddo
5222 enddo
5223
5224!
5225!..To do the same thing for rain.
5226!
5227! do k = 1, ntb_r
5228! do j = 1, ntb_r1
5229! lam_exp = (N0r_exp(j)*am_r*crg(1)/r_r(k))**ore1
5230! lam = lam_exp * (crg(3)*org2*org1)**obmr
5231! N0 = N0r_exp(j)/(crg(2)*lam_exp) * lam**cre(2)
5232! Nt_r = N0 * crg(2) / lam**cre(2)
5233! do i = 1, nbr
5234! xlimit_intg = lam*Dr(i)
5235! tnr_rev(i,j,k) = GAMMP(mu_r+1.0, xlimit_intg) * Nt_r
5236! enddo
5237! enddo
5238! enddo
5239
5240! TO APPLY TABLE ABOVE
5241!..Rain lookup table indexes.
5242! Dr_star = sqrt(-2.0_dp*DT * t1_evap/(2.*PI) &
5243! * 0.78*4.*diffu(k)*xsat*rvs/rho_w)
5244! idx_d = nint(1.0 + real(nbr, kind=wp) * log(real(Dr_star/D0r, kind=dp)) &
5245! / log(real(Dr(nbr)/D0r, kind=dp)))
5246! idx_d = max(1, min(idx_d, nbr))
5247!
5248! nir = nint(log10(real(rr(k), kind=wp)))
5249! do nn = nir-1, nir+1
5250! n = nn
5251! if ( (rr(k)/10.**nn).ge.1.0 .and. &
5252! (rr(k)/10.**nn).lt.10.0) goto 154
5253! enddo
5254!154 continue
5255! idx_r = int(rr(k)/10.**n) + 10*(n-nir2) - (n-nir2)
5256! idx_r = max(1, min(idx_r, ntb_r))
5257!
5258! lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr
5259! lam_exp = lamr * (crg(3)*org2*org1)**bm_r
5260! N0_exp = org1*rr(k)/am_r * lam_exp**cre(1)
5261! nir = nint(log10(real(N0_exp, kind=dp))
5262! do nn = nir-1, nir+1
5263! n = nn
5264! if ( (N0_exp/10.**nn).ge.1.0 .and. &
5265! (N0_exp/10.**nn).lt.10.0) goto 155
5266! enddo
5267!155 continue
5268! idx_r1 = int(N0_exp/10.**n) + 10*(n-nir3) - (n-nir3)
5269! idx_r1 = max(1, min(idx_r1, ntb_r1))
5270!
5271! pnr_rev(k) = min(nr(k)*odts, SNGL(tnr_rev(idx_d,idx_r1,idx_r) & ! RAIN2M
5272! * odts))
5273
5274 end subroutine table_dropevap
5275!
5276!ctrlL
5277!+---+-----------------------------------------------------------------+
5284 subroutine table_ccnact(errmess,errflag)
5285
5286 implicit none
5287
5288!..Error handling variables
5289 character(len=*), intent(inout) :: errmess
5290 integer, intent(inout) :: errflag
5291
5292!..Local variables
5293 integer:: iunit_mp_th1, i
5294 logical:: opened
5295
5296 iunit_mp_th1 = -1
5297 do_loop_ccn : do i = 20, 99
5298 INQUIRE (i, opened=opened)
5299 if (.not. opened) then
5300 iunit_mp_th1 = i
5301 exit do_loop_ccn
5302 endif
5303 enddo do_loop_ccn
5304
5305 if (iunit_mp_th1 < 0) then
5306 write(0,*) 'module_mp_thompson: table_ccnAct: '// &
5307 'Can not find unused fortran unit to read in lookup table.'
5308 return
5309 endif
5310
5311 !WRITE(*, '(A,I2)') 'module_mp_thompson: opening CCN_ACTIVATE.BIN on unit ',iunit_mp_th1
5312 OPEN(iunit_mp_th1, file='CCN_ACTIVATE.BIN', &
5313 form='UNFORMATTED', status='OLD', convert='BIG_ENDIAN', err=9009)
5314
5315!sms$serial begin
5316 READ(iunit_mp_th1, err=9010) tnccn_act
5317!sms$serial end
5318
5319 return
5320 9009 CONTINUE
5321 WRITE(errmess , '(A,I2)') 'module_mp_thompson: error opening CCN_ACTIVATE.BIN on unit ',iunit_mp_th1
5322 errflag = 1
5323 return
5324 9010 CONTINUE
5325 WRITE(errmess , '(A,I2)') 'module_mp_thompson: error reading CCN_ACTIVATE.BIN on unit ',iunit_mp_th1
5326 errflag = 1
5327 return
5328
5329 end subroutine table_ccnact
5330
5337! TO_DO ITEM: For radiation cooling producing fog, in which case the
5338!.. updraft velocity could easily be negative, we could use the temp
5339!.. and its tendency to diagnose a pretend postive updraft velocity.
5340 real function activ_ncloud(tt, ww, nccn, lsm_in)
5341
5342 implicit none
5343 real(wp), intent(in):: tt, ww, nccn
5344 integer, intent(in):: lsm_in
5345 real(wp):: n_local, w_local
5346 integer:: i, j, k, l, m, n
5347 real(wp):: a, b, c, d, t, u, x1, x2, y1, y2, nx, wy, fraction
5348 real(wp):: lower_lim_nuc_frac
5349
5350! ta_Na = (/10.0, 31.6, 100.0, 316.0, 1000.0, 3160.0, 10000.0/) ntb_arc
5351! ta_Ww = (/0.01, 0.0316, 0.1, 0.316, 1.0, 3.16, 10.0, 31.6, 100.0/) ntb_arw
5352! ta_Tk = (/243.15, 253.15, 263.15, 273.15, 283.15, 293.15, 303.15/) ntb_art
5353! ta_Ra = (/0.01, 0.02, 0.04, 0.08, 0.16/) ntb_arr
5354! ta_Ka = (/0.2, 0.4, 0.6, 0.8/) ntb_ark
5355
5356 n_local = nccn * 1.e-6
5357 w_local = ww
5358
5359 if (n_local .ge. ta_na(ntb_arc)) then
5360 n_local = ta_na(ntb_arc) - 1.0
5361 elseif (n_local .le. ta_na(1)) then
5362 n_local = ta_na(1) + 1.0
5363 endif
5364 do n = 2, ntb_arc
5365 if (n_local.ge.ta_na(n-1) .and. n_local.lt.ta_na(n)) goto 8003
5366 enddo
5367 8003 continue
5368 i = n
5369 x1 = log(ta_na(i-1))
5370 x2 = log(ta_na(i))
5371
5372 if (w_local .ge. ta_ww(ntb_arw)) then
5373 w_local = ta_ww(ntb_arw) - 1.0
5374 elseif (w_local .le. ta_ww(1)) then
5375 w_local = ta_ww(1) + 0.001
5376 endif
5377 do n = 2, ntb_arw
5378 if (w_local.ge.ta_ww(n-1) .and. w_local.lt.ta_ww(n)) goto 8005
5379 enddo
5380 8005 continue
5381 j = n
5382 y1 = log(ta_ww(j-1))
5383 y2 = log(ta_ww(j))
5384
5385 k = max(1, min( nint( (tt - ta_tk(1))*0.1) + 1, ntb_art))
5386
5387!..The next two values are indexes of mean aerosol radius and
5388!.. hygroscopicity. Currently these are constant but a future version
5389!.. should implement other variables to allow more freedom such as
5390!.. at least simple separation of tiny size sulfates from larger
5391!.. sea salts.
5392 l = 3
5393 m = 2
5394
5395 if (lsm_in .eq. 1) then ! land
5396 lower_lim_nuc_frac = 0.
5397 else if (lsm_in .eq. 0) then ! water
5398 lower_lim_nuc_frac = 0.15
5399 else
5400 lower_lim_nuc_frac = 0.15 ! catch-all for anything else
5401 endif
5402
5403 a = tnccn_act(i-1,j-1,k,l,m)
5404 b = tnccn_act(i,j-1,k,l,m)
5405 c = tnccn_act(i,j,k,l,m)
5406 d = tnccn_act(i-1,j,k,l,m)
5407 nx = log(n_local)
5408 wy = log(w_local)
5409
5410 t = (nx-x1)/(x2-x1)
5411 u = (wy-y1)/(y2-y1)
5412
5413! t = (n_local-ta(Na(i-1))/(ta_Na(i)-ta_Na(i-1))
5414! u = (w_local-ta_Ww(j-1))/(ta_Ww(j)-ta_Ww(j-1))
5415
5416 fraction = (1.0-t)*(1.0-u)*a + t*(1.0-u)*b + t*u*c + (1.0-t)*u*d
5417 fraction = max(fraction, lower_lim_nuc_frac)
5418
5419! if (NCCN*fraction .gt. 0.75*Nt_c_max) then
5420! write(*,*) ' DEBUG-GT ', n_local, w_local, Tt, i, j, k
5421! endif
5422
5423 activ_ncloud = nccn*fraction
5424
5425 end function activ_ncloud
5426
5427!+---+-----------------------------------------------------------------+
5428!+---+-----------------------------------------------------------------+
5432 SUBROUTINE gcf(GAMMCF,A,X,GLN)
5433! RETURNS THE INCOMPLETE GAMMA FUNCTION Q(A,X) EVALUATED BY ITS
5434! CONTINUED FRACTION REPRESENTATION AS GAMMCF. ALSO RETURNS
5435! --- LN(GAMMA(A)) AS GLN. THE CONTINUED FRACTION IS EVALUATED BY
5436! --- A MODIFIED LENTZ METHOD.
5437! --- USES GAMMLN
5438 IMPLICIT NONE
5439 integer, parameter:: ITMAX=100
5440 real(wp), parameter:: gEPS=3.e-7
5441 real(wp), parameter:: FPMIN=1.e-30
5442 real(wp), intent(in):: A, X
5443 real(wp):: GAMMCF,GLN
5444 integer:: I
5445 real(wp):: AN,B,C,D,DEL,H
5446 gln=gammln(a)
5447 b=x+1.-a
5448 c=1./fpmin
5449 d=1./b
5450 h=d
5451 DO 11 i=1,itmax
5452 an=-i*(i-a)
5453 b=b+2.
5454 d=an*d+b
5455 IF(abs(d).LT.fpmin)d=fpmin
5456 c=b+an/c
5457 IF(abs(c).LT.fpmin)c=fpmin
5458 d=1./d
5459 del=d*c
5460 h=h*del
5461 IF(abs(del-1.).LT.geps)GOTO 1
5462 11 CONTINUE
5463 print *, 'A TOO LARGE, ITMAX TOO SMALL IN GCF'
5464 1 gammcf=exp(-x+a*log(x)-gln)*h
5465 END SUBROUTINE gcf
5466! (C) Copr. 1986-92 Numerical Recipes Software 2.02
5467
5471 SUBROUTINE gser(GAMSER,A,X,GLN)
5472! --- RETURNS THE INCOMPLETE GAMMA FUNCTION P(A,X) EVALUATED BY ITS
5473! --- ITS SERIES REPRESENTATION AS GAMSER. ALSO RETURNS LN(GAMMA(A))
5474! --- AS GLN.
5475! --- USES GAMMLN
5476 IMPLICIT NONE
5477 integer, parameter:: ITMAX=100
5478 real(wp), parameter:: gEPS=3.e-7
5479 real(wp), intent(in):: A, X
5480 real(wp):: GAMSER,GLN
5481 integer:: N
5482 real(wp):: AP,DEL,SUM
5483 gln=gammln(a)
5484 IF(x.LE.0.)THEN
5485 IF(x.LT.0.) print *, 'X < 0 IN GSER'
5486 gamser=0.
5487 RETURN
5488 ENDIF
5489 ap=a
5490 sum=1./a
5491 del=sum
5492 DO 11 n=1,itmax
5493 ap=ap+1.
5494 del=del*x/ap
5495 sum=sum+del
5496 IF(abs(del).LT.abs(sum)*geps)GOTO 1
5497 11 CONTINUE
5498 print *,'A TOO LARGE, ITMAX TOO SMALL IN GSER'
5499 1 gamser=sum*exp(-x+a*log(x)-gln)
5500 END SUBROUTINE gser
5501! (C) Copr. 1986-92 Numerical Recipes Software 2.02
5502
5505 REAL function gammln(xx)
5506! --- RETURNS THE VALUE LN(GAMMA(XX)) FOR XX > 0.
5507 IMPLICIT NONE
5508 real(wp), intent(in):: xx
5509 real(dp), parameter:: stp = 2.5066282746310005d0
5510 real(dp), dimension(6), parameter:: &
5511 cof = (/76.18009172947146d0, -86.50532032941677d0, &
5512 24.01409824083091d0, -1.231739572450155d0, &
5513 .1208650973866179d-2, -.5395239384953d-5/)
5514 real(dp) :: ser,tmp,x,y
5515 integer:: j
5516
5517 x=xx
5518 y=x
5519 tmp=x+5.5d0
5520 tmp=(x+0.5d0)*log(tmp)-tmp
5521 ser=1.000000000190015d0
5522 DO 11 j=1,6
5523 y=y+1.0_dp
5524 ser=ser+cof(j)/y
552511 CONTINUE
5526 gammln=tmp+log(stp*ser/x)
5527 END FUNCTION gammln
5528! (C) Copr. 1986-92 Numerical Recipes Software 2.02
5529
5531 REAL function gammp(a,x)
5532! --- COMPUTES THE INCOMPLETE GAMMA FUNCTION P(A,X)
5533! --- SEE ABRAMOWITZ AND STEGUN 6.5.1
5534! --- USES GCF,GSER
5535 IMPLICIT NONE
5536 real(wp), intent(in):: a,x
5537 real(wp):: gammcf,gamser,gln
5538 gammp = 0.
5539 IF((x.LT.0.) .OR. (a.LE.0.)) THEN
5540 print *, 'BAD ARGUMENTS IN GAMMP'
5541 RETURN
5542 ELSEIF(x.LT.a+1.)THEN
5543 CALL gser(gamser,a,x,gln)
5544 gammp=gamser
5545 ELSE
5546 CALL gcf(gammcf,a,x,gln)
5547 gammp=1.-gammcf
5548 ENDIF
5549 END FUNCTION gammp
5550! (C) Copr. 1986-92 Numerical Recipes Software 2.02
5551!+---+-----------------------------------------------------------------+
5553 REAL function wgamma(y)
5554
5555 IMPLICIT NONE
5556 real(wp), intent(in):: y
5557
5558 wgamma = exp(gammln(y))
5559
5560 END FUNCTION wgamma
5561!+---+-----------------------------------------------------------------+
5565 REAL function rslf(p,t)
5566
5567 IMPLICIT NONE
5568 real(wp), intent(in):: p, t
5569 real(wp):: esl,x
5570 real(wp), parameter:: c0= .611583699e03
5571 real(wp), parameter:: c1= .444606896e02
5572 real(wp), parameter:: c2= .143177157e01
5573 real(wp), parameter:: c3= .264224321e-1
5574 real(wp), parameter:: c4= .299291081e-3
5575 real(wp), parameter:: c5= .203154182e-5
5576 real(wp), parameter:: c6= .702620698e-8
5577 real(wp), parameter:: c7= .379534310e-11
5578 real(wp), parameter:: c8=-.321582393e-13
5579
5580 x=max(-80.,t-273.16)
5581
5582! ESL=612.2*EXP(17.67*X/(T-29.65))
5583 esl=c0+x*(c1+x*(c2+x*(c3+x*(c4+x*(c5+x*(c6+x*(c7+x*c8)))))))
5584 esl=min(esl, p*0.15) ! Even with P=1050mb and T=55C, the sat. vap. pres only contributes to ~15% of total pres.
5585 rslf=roverrv*esl / max(1.e-4,(p-esl))
5586
5587! ALTERNATIVE
5588! ; Source: Murphy and Koop, Review of the vapour pressure of ice and
5589! supercooled water for atmospheric applications, Q. J. R.
5590! Meteorol. Soc (2005), 131, pp. 1539-1565.
5591! ESL = EXP(54.842763 - 6763.22 / T - 4.210 * ALOG(T) + 0.000367 * T
5592! + TANH(0.0415 * (T - 218.8)) * (53.878 - 1331.22
5593! / T - 9.44523 * ALOG(T) + 0.014025 * T))
5594
5595 END FUNCTION rslf
5596!+---+-----------------------------------------------------------------+
5600 REAL function rsif(p,t)
5601
5602 IMPLICIT NONE
5603 real(wp), intent(in):: p, t
5604 real(wp):: esi,x
5605 real(wp), parameter:: c0= .609868993e03
5606 real(wp), parameter:: c1= .499320233e02
5607 real(wp), parameter:: c2= .184672631e01
5608 real(wp), parameter:: c3= .402737184e-1
5609 real(wp), parameter:: c4= .565392987e-3
5610 real(wp), parameter:: c5= .521693933e-5
5611 real(wp), parameter:: c6= .307839583e-7
5612 real(wp), parameter:: c7= .105785160e-9
5613 real(wp), parameter:: c8= .161444444e-12
5614
5615 x=max(-80.,t-273.16)
5616 esi=c0+x*(c1+x*(c2+x*(c3+x*(c4+x*(c5+x*(c6+x*(c7+x*c8)))))))
5617 esi=min(esi, p*0.15)
5618 rsif=roverrv*esi / max(1.e-4,(p-esi))
5619
5620! ALTERNATIVE
5621! ; Source: Murphy and Koop, Review of the vapour pressure of ice and
5622! supercooled water for atmospheric applications, Q. J. R.
5623! Meteorol. Soc (2005), 131, pp. 1539-1565.
5624! ESI = EXP(9.550426 - 5723.265/T + 3.53068*ALOG(T) - 0.00728332*T)
5625
5626 END FUNCTION rsif
5627
5628!+---+-----------------------------------------------------------------+
5630 real function icedemott(tempc, qv, qvs, qvsi, rho, nifa)
5631 implicit none
5632
5633 real(wp), intent(in):: tempc, qv, qvs, qvsi, rho, nifa
5634
5635!..Local vars
5636 real(wp):: satw, sati, siw, p_x, si0x, dtt, dsi, dsw, dab, fc, hx
5637 real(wp):: ntilde, n_in, nmax, nhat, mux, xni, nifa_cc
5638 real(wp), parameter:: p_c1 = 1000.
5639 real(wp), parameter:: p_rho_c = 0.76
5640 real(wp), parameter:: p_alpha = 1.0
5641 real(wp), parameter:: p_gam = 2.
5642 real(wp), parameter:: delt = 5.
5643 real(wp), parameter:: t0x = -40.
5644 real(wp), parameter:: sw0x = 0.97
5645 real(wp), parameter:: delsi = 0.1
5646 real(wp), parameter:: hdm = 0.15
5647 real(wp), parameter:: p_psi = 0.058707*p_gam/p_rho_c
5648 real(wp), parameter:: aap = 1.
5649 real(wp), parameter:: bbp = 0.
5650 real(wp), parameter:: y1p = -35.
5651 real(wp), parameter:: y2p = -25.
5652 real(wp), parameter:: rho_not0 = 101325./(287.05*273.15)
5653
5654!+---+
5655
5656 xni = 0.0
5657! satw = qv/qvs
5658! sati = qv/qvsi
5659! siw = qvs/qvsi
5660! p_x = -1.0261+(3.1656e-3*tempc)+(5.3938e-4*(tempc*tempc)) &
5661! + (8.2584e-6*(tempc*tempc*tempc))
5662! si0x = 1.+(10.**p_x)
5663! if (sati.ge.si0x .and. satw.lt.0.985) then
5664! dtt = delta_p (tempc, T0x, T0x+delT, 1., hdm)
5665! dsi = delta_p (sati, Si0x, Si0x+delSi, 0., 1.)
5666! dsw = delta_p (satw, Sw0x, 1., 0., 1.)
5667! fc = dtt*dsi*0.5
5668! hx = min(fc+((1.-fc)*dsw), 1.)
5669! ntilde = p_c1*p_gam*((exp(12.96*(sati-1.1)))**0.3) / p_rho_c
5670! if (tempc .le. y1p) then
5671! n_in = ntilde
5672! elseif (tempc .ge. y2p) then
5673! n_in = p_psi*p_c1*exp(12.96*(sati-1.)-0.639)
5674! else
5675! if (tempc .le. -30.) then
5676! nmax = p_c1*p_gam*(exp(12.96*(siw-1.1)))**0.3/p_rho_c
5677! else
5678! nmax = p_psi*p_c1*exp(12.96*(siw-1.)-0.639)
5679! endif
5680! ntilde = min(ntilde, nmax)
5681! nhat = min(p_psi*p_c1*exp(12.96*(sati-1.)-0.639), nmax)
5682! dab = delta_p (tempc, y1p, y2p, aap, bbp)
5683! n_in = min(nhat*(ntilde/nhat)**dab, nmax)
5684! endif
5685! mux = hx*p_alpha*n_in*rho
5686! xni = mux*((6700.*nifa)-200.)/((6700.*5.E5)-200.)
5687! elseif (satw.ge.0.985 .and. tempc.gt.HGFR-273.15) then
5688 nifa_cc = max(0.5, nifa*rho_not0*1.e-6/rho)
5689! xni = 3.*nifa_cc**(1.25)*exp((0.46*(-tempc))-11.6) ! [DeMott, 2015]
5690 xni = (5.94e-5*(-tempc)**3.33) & ! [DeMott, 2010]
5691 * (nifa_cc**((-0.0264*(tempc))+0.0033))
5692 xni = xni*rho/rho_not0 * 1000.
5693! endif
5694
5695 icedemott = max(0., xni)
5696
5697 end FUNCTION icedemott
5698
5699!+---+-----------------------------------------------------------------+
5704 real function icekoop(temp, qv, qvs, naero, dt)
5705 implicit none
5706
5707 real(wp), intent(in):: temp, qv, qvs, naero, dt
5708 real(wp):: mu_diff, a_w_i, delta_aw, log_j_rate, j_rate, prob_h, satw
5709 real(wp):: xni
5710
5711 xni = 0.0
5712 satw = qv/qvs
5713 mu_diff = 210368.0 + (131.438*temp) - (3.32373e6/temp) &
5714 & - (41729.1*alog(temp))
5715 a_w_i = exp(mu_diff/(r_uni*temp))
5716 delta_aw = satw - a_w_i
5717 log_j_rate = -906.7 + (8502.0*delta_aw) &
5718 & - (26924.0*delta_aw*delta_aw) &
5719 & + (29180.0*delta_aw*delta_aw*delta_aw)
5720 log_j_rate = min(20.0, log_j_rate)
5721 j_rate = 10.**log_j_rate ! cm-3 s-1
5722 prob_h = min(1.-exp(-j_rate*ar_volume*dt), 1.)
5723 if (prob_h .gt. 0.) then
5724 xni = min(prob_h*naero, 1000.e3)
5725 endif
5726
5727 icekoop = max(0.0, xni)
5728
5729 end FUNCTION icekoop
5730
5731!+---+-----------------------------------------------------------------+
5734 REAL function delta_p (yy, y1, y2, aa, bb)
5735 IMPLICIT NONE
5736
5737 real(wp), intent(in):: yy, y1, y2, aa, bb
5738 real(wp):: dab, a, b, a0, a1, a2, a3
5739
5740 a = 6.*(aa-bb)/((y2-y1)*(y2-y1)*(y2-y1))
5741 b = aa+(a*y1*y1*y1/6.)-(a*y1*y1*y2*0.5)
5742 a0 = b
5743 a1 = a*y1*y2
5744 a2 = -a*(y1+y2)*0.5
5745 a3 = a/3.
5746
5747 if (yy.le.y1) then
5748 dab = aa
5749 else if (yy.ge.y2) then
5750 dab = bb
5751 else
5752 dab = a0+(a1*yy)+(a2*yy*yy)+(a3*yy*yy*yy)
5753 endif
5754
5755 if (dab.lt.aa) then
5756 dab = aa
5757 endif
5758 if (dab.gt.bb) then
5759 dab = bb
5760 endif
5761 delta_p = dab
5762
5763 END FUNCTION delta_p
5764
5765!+---+-----------------------------------------------------------------+
5766!ctrlL
5767
5768!+---+-----------------------------------------------------------------+
5776
5777 subroutine calc_effectrad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, &
5778 & re_qc1d, re_qi1d, re_qs1d, lsml, kts, kte)
5779
5780 IMPLICIT NONE
5781
5782!..Sub arguments
5783 integer, intent(in):: kts, kte
5784 real(wp), dimension(kts:kte), intent(in):: &
5785 & t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d
5786 real(wp), dimension(kts:kte), intent(out):: re_qc1d, re_qi1d, re_qs1d
5787!..Local variables
5788 integer:: k
5789 real(wp), dimension(kts:kte):: rho, rc, nc, ri, ni, rs
5790 real(wp):: smo2, smob, smoc
5791 real(wp):: tc0, loga_, a_, b_
5792 real(dp) :: lamc, lami
5793 logical:: has_qc, has_qi, has_qs
5794 integer:: inu_c
5795 integer:: lsml
5796 real(wp), dimension(15), parameter:: g_ratio = (/24,60,120,210,336, &
5797 & 504,720,990,1320,1716,2184,2730,3360,4080,4896/)
5798
5799 has_qc = .false.
5800 has_qi = .false.
5801 has_qs = .false.
5802
5803 re_qc1d(:) = 0.0_dp
5804 re_qi1d(:) = 0.0_dp
5805 re_qs1d(:) = 0.0_dp
5806
5807 do k = kts, kte
5808 rho(k) = roverrv*p1d(k) / (r*t1d(k)*(qv1d(k)+roverrv))
5809 rc(k) = max(r1, qc1d(k)*rho(k))
5810 nc(k) = max(2., min(nc1d(k)*rho(k), nt_c_max))
5811 if (.NOT. (is_aerosol_aware .or. merra2_aerosol_aware)) then
5812 if( lsml == 1) then
5813 nc(k) = nt_c_l
5814 else
5815 nc(k) = nt_c_o
5816 endif
5817 endif
5818 if (rc(k).gt.r1 .and. nc(k).gt.r2) has_qc = .true.
5819 ri(k) = max(r1, qi1d(k)*rho(k))
5820 ni(k) = max(r2, ni1d(k)*rho(k))
5821 if (ri(k).gt.r1 .and. ni(k).gt.r2) has_qi = .true.
5822 rs(k) = max(r1, qs1d(k)*rho(k))
5823 if (rs(k).gt.r1) has_qs = .true.
5824 enddo
5825
5826 if (has_qc) then
5827 do k = kts, kte
5828 if (rc(k).le.r1 .or. nc(k).le.r2) cycle
5829 if (nc(k).lt.100) then
5830 inu_c = 15
5831 elseif (nc(k).gt.1.e10) then
5832 inu_c = 2
5833 else
5834 inu_c = min(15, nint(1000.e6/nc(k)) + 2)
5835 endif
5836 lamc = (nc(k)*am_r*g_ratio(inu_c)/rc(k))**obmr
5837 re_qc1d(k) = sngl(0.5d0 * real(3.+inu_c, kind=dp)/lamc)
5838 enddo
5839 endif
5840
5841 if (has_qi) then
5842 do k = kts, kte
5843 if (ri(k).le.r1 .or. ni(k).le.r2) cycle
5844 lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi
5845 re_qi1d(k) = sngl(0.5d0 * real(3.+mu_i, kind=dp)/lami)
5846 enddo
5847 endif
5848
5849 if (has_qs) then
5850 do k = kts, kte
5851 if (rs(k).le.r1) cycle
5852 tc0 = min(-0.1, t1d(k)-273.15)
5853 smob = rs(k)*oams
5854
5855!..All other moments based on reference, 2nd moment. If bm_s.ne.2,
5856!.. then we must compute actual 2nd moment and use as reference.
5857 if (bm_s.gt.(2.0-1.e-3) .and. bm_s.lt.(2.0+1.e-3)) then
5858 smo2 = smob
5859 else
5860 loga_ = sa(1) + sa(2)*tc0 + sa(3)*bm_s &
5861 & + sa(4)*tc0*bm_s + sa(5)*tc0*tc0 &
5862 & + sa(6)*bm_s*bm_s + sa(7)*tc0*tc0*bm_s &
5863 & + sa(8)*tc0*bm_s*bm_s + sa(9)*tc0*tc0*tc0 &
5864 & + sa(10)*bm_s*bm_s*bm_s
5865 a_ = 10.0**loga_
5866 b_ = sb(1) + sb(2)*tc0 + sb(3)*bm_s &
5867 & + sb(4)*tc0*bm_s + sb(5)*tc0*tc0 &
5868 & + sb(6)*bm_s*bm_s + sb(7)*tc0*tc0*bm_s &
5869 & + sb(8)*tc0*bm_s*bm_s + sb(9)*tc0*tc0*tc0 &
5870 & + sb(10)*bm_s*bm_s*bm_s
5871 smo2 = (smob/a_)**(1./b_)
5872 endif
5873!..Calculate bm_s+1 (th) moment. Useful for diameter calcs.
5874 loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(1) &
5875 & + sa(4)*tc0*cse(1) + sa(5)*tc0*tc0 &
5876 & + sa(6)*cse(1)*cse(1) + sa(7)*tc0*tc0*cse(1) &
5877 & + sa(8)*tc0*cse(1)*cse(1) + sa(9)*tc0*tc0*tc0 &
5878 & + sa(10)*cse(1)*cse(1)*cse(1)
5879 a_ = 10.0**loga_
5880 b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(1) + sb(4)*tc0*cse(1) &
5881 & + sb(5)*tc0*tc0 + sb(6)*cse(1)*cse(1) &
5882 & + sb(7)*tc0*tc0*cse(1) + sb(8)*tc0*cse(1)*cse(1) &
5883 & + sb(9)*tc0*tc0*tc0 + sb(10)*cse(1)*cse(1)*cse(1)
5884 smoc = a_ * smo2**b_
5885 re_qs1d(k) = 0.5*(smoc/smob)
5886 enddo
5887 endif
5888
5889 end subroutine calc_effectrad
5890
5891!+---+-----------------------------------------------------------------+
5899
5900 subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, &
5901 t1d, p1d, dBZ, rand1, kts, kte, ii, jj, melti, &
5902 vt_dBZ, first_time_step)
5903
5904 IMPLICIT NONE
5905
5906!..Sub arguments
5907 integer, intent(in):: kts, kte, ii, jj
5908 real(wp), intent(in):: rand1
5909 real(wp), dimension(kts:kte), intent(in):: &
5910 qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, t1d, p1d
5911 real(wp), dimension(kts:kte), intent(inout):: dBZ
5912 real(wp), dimension(kts:kte), optional, intent(inout):: vt_dBZ
5913 logical, optional, intent(in) :: first_time_step
5914
5915!..Local variables
5916 logical :: do_vt_dBZ
5917 logical :: allow_wet_graupel
5918 logical :: allow_wet_snow
5919 real(wp), dimension(kts:kte):: temp, pres, qv, rho, rhof
5920 real(wp), dimension(kts:kte):: rc, rr, nr, rs, rg
5921
5922 real(dp), dimension(kts:kte):: ilamr, ilamg, N0_r, N0_g
5923 real(wp), dimension(kts:kte):: mvd_r
5924 real(wp), dimension(kts:kte):: smob, smo2, smoc, smoz
5925 real(wp):: oM3, M0, Mrat, slam1, slam2, xDs
5926 real(wp):: ils1, ils2, t1_vts, t2_vts, t3_vts, t4_vts
5927 real(wp):: vtr_dbz_wt, vts_dbz_wt, vtg_dbz_wt
5928
5929 real(wp), dimension(kts:kte):: ze_rain, ze_snow, ze_graupel
5930
5931 real(dp) :: N0_exp, N0_min, lam_exp, lamr, lamg
5932 real(wp):: a_, b_, loga_, tc0, SR
5933 real(dp) :: fmelt_s, fmelt_g
5934
5935 integer:: i, k, k_0, kbot, n
5936 logical, intent(in):: melti
5937 logical, dimension(kts:kte):: L_qr, L_qs, L_qg
5938
5939 real(dp) :: cback, x, eta, f_d
5940 real(wp):: xslw1, ygra1, zans1
5941
5942!+---+
5943 if (present(vt_dbz) .and. present(first_time_step)) then
5944 do_vt_dbz = .true.
5945 if (first_time_step) then
5946! no bright banding, to be consistent with hydrometeor retrieval in GSI
5947 allow_wet_snow = .false.
5948 else
5949 allow_wet_snow = .true.
5950 endif
5951 allow_wet_graupel = .false.
5952 else
5953 do_vt_dbz = .false.
5954 allow_wet_snow = .true.
5955 allow_wet_graupel = .false.
5956 endif
5957
5958 do k = kts, kte
5959 dbz(k) = -35.0
5960 enddo
5961
5962!+---+-----------------------------------------------------------------+
5963!..Put column of data into local arrays.
5964!+---+-----------------------------------------------------------------+
5965 do k = kts, kte
5966 temp(k) = t1d(k)
5967 qv(k) = max(1.e-10, qv1d(k))
5968 pres(k) = p1d(k)
5969 rho(k) = roverrv*pres(k) / (r*temp(k)*(qv(k)+roverrv))
5970 rhof(k) = sqrt(rho_not/rho(k))
5971 rc(k) = max(r1, qc1d(k)*rho(k))
5972 if (qr1d(k) .gt. r1) then
5973 rr(k) = qr1d(k)*rho(k)
5974 nr(k) = max(r2, nr1d(k)*rho(k))
5975 lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr
5976 ilamr(k) = 1./lamr
5977 n0_r(k) = nr(k)*org2*lamr**cre(2)
5978 mvd_r(k) = (3.0 + mu_r + 0.672) * ilamr(k)
5979 l_qr(k) = .true.
5980 else
5981 rr(k) = r1
5982 nr(k) = r1
5983 mvd_r(k) = 50.e-6
5984 l_qr(k) = .false.
5985 endif
5986 if (qs1d(k) .gt. r2) then
5987 rs(k) = qs1d(k)*rho(k)
5988 l_qs(k) = .true.
5989 else
5990 rs(k) = r1
5991 l_qs(k) = .false.
5992 endif
5993 if (qg1d(k) .gt. r2) then
5994 rg(k) = qg1d(k)*rho(k)
5995 l_qg(k) = .true.
5996 else
5997 rg(k) = r1
5998 l_qg(k) = .false.
5999 endif
6000 enddo
6001
6002!+---+-----------------------------------------------------------------+
6003!..Calculate y-intercept, slope, and useful moments for snow.
6004!+---+-----------------------------------------------------------------+
6005 do k = kts, kte
6006 smo2(k) = 0.
6007 smob(k) = 0.
6008 smoc(k) = 0.
6009 smoz(k) = 0.
6010 enddo
6011 if (any(l_qs .eqv. .true.)) then
6012 do k = kts, kte
6013 if (.not. l_qs(k)) cycle
6014 tc0 = min(-0.1, temp(k)-273.15)
6015 smob(k) = rs(k)*oams
6016
6017!..All other moments based on reference, 2nd moment. If bm_s.ne.2,
6018!.. then we must compute actual 2nd moment and use as reference.
6019 if (bm_s.gt.(2.0-1.e-3) .and. bm_s.lt.(2.0+1.e-3)) then
6020 smo2(k) = smob(k)
6021 else
6022 loga_ = sa(1) + sa(2)*tc0 + sa(3)*bm_s &
6023 & + sa(4)*tc0*bm_s + sa(5)*tc0*tc0 &
6024 & + sa(6)*bm_s*bm_s + sa(7)*tc0*tc0*bm_s &
6025 & + sa(8)*tc0*bm_s*bm_s + sa(9)*tc0*tc0*tc0 &
6026 & + sa(10)*bm_s*bm_s*bm_s
6027 a_ = 10.0**loga_
6028 b_ = sb(1) + sb(2)*tc0 + sb(3)*bm_s &
6029 & + sb(4)*tc0*bm_s + sb(5)*tc0*tc0 &
6030 & + sb(6)*bm_s*bm_s + sb(7)*tc0*tc0*bm_s &
6031 & + sb(8)*tc0*bm_s*bm_s + sb(9)*tc0*tc0*tc0 &
6032 & + sb(10)*bm_s*bm_s*bm_s
6033 smo2(k) = (smob(k)/a_)**(1./b_)
6034 endif
6035
6036!..Calculate bm_s+1 (th) moment. Useful for diameter calcs.
6037 loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(1) &
6038 & + sa(4)*tc0*cse(1) + sa(5)*tc0*tc0 &
6039 & + sa(6)*cse(1)*cse(1) + sa(7)*tc0*tc0*cse(1) &
6040 & + sa(8)*tc0*cse(1)*cse(1) + sa(9)*tc0*tc0*tc0 &
6041 & + sa(10)*cse(1)*cse(1)*cse(1)
6042 a_ = 10.0**loga_
6043 b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(1) + sb(4)*tc0*cse(1) &
6044 & + sb(5)*tc0*tc0 + sb(6)*cse(1)*cse(1) &
6045 & + sb(7)*tc0*tc0*cse(1) + sb(8)*tc0*cse(1)*cse(1) &
6046 & + sb(9)*tc0*tc0*tc0 + sb(10)*cse(1)*cse(1)*cse(1)
6047 smoc(k) = a_ * smo2(k)**b_
6048
6049!..Calculate bm_s*2 (th) moment. Useful for reflectivity.
6050 loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(3) &
6051 & + sa(4)*tc0*cse(3) + sa(5)*tc0*tc0 &
6052 & + sa(6)*cse(3)*cse(3) + sa(7)*tc0*tc0*cse(3) &
6053 & + sa(8)*tc0*cse(3)*cse(3) + sa(9)*tc0*tc0*tc0 &
6054 & + sa(10)*cse(3)*cse(3)*cse(3)
6055 a_ = 10.0**loga_
6056 b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(3) + sb(4)*tc0*cse(3) &
6057 & + sb(5)*tc0*tc0 + sb(6)*cse(3)*cse(3) &
6058 & + sb(7)*tc0*tc0*cse(3) + sb(8)*tc0*cse(3)*cse(3) &
6059 & + sb(9)*tc0*tc0*tc0 + sb(10)*cse(3)*cse(3)*cse(3)
6060 smoz(k) = a_ * smo2(k)**b_
6061 enddo
6062 endif
6063
6064!+---+-----------------------------------------------------------------+
6065!..Calculate y-intercept, slope values for graupel.
6066!+---+-----------------------------------------------------------------+
6067
6068 if (any(l_qg .eqv. .true.)) then
6069 call graupel_psd_parameters(kts, kte, rand1, rg, ilamg, n0_g)
6070 endif
6071
6072!+---+-----------------------------------------------------------------+
6073!..Locate K-level of start of melting (k_0 is level above).
6074!+---+-----------------------------------------------------------------+
6075 k_0 = kts
6076 if ( melti ) then
6077 k_loop:do k = kte-1, kts, -1
6078 if ((temp(k).gt.273.15) .and. l_qr(k) &
6079 & .and. (l_qs(k+1).or.l_qg(k+1)) ) then
6080 k_0 = max(k+1, k_0)
6081 EXIT k_loop
6082 endif
6083 enddo k_loop
6084 endif
6085!+---+-----------------------------------------------------------------+
6086!..Assume Rayleigh approximation at 10 cm wavelength. Rain (all temps)
6087!.. and non-water-coated snow and graupel when below freezing are
6088!.. simple. Integrations of m(D)*m(D)*N(D)*dD.
6089!+---+-----------------------------------------------------------------+
6090
6091 do k = kts, kte
6092 ze_rain(k) = 1.e-22
6093 ze_snow(k) = 1.e-22
6094 ze_graupel(k) = 1.e-22
6095 if (l_qr(k)) ze_rain(k) = n0_r(k)*crg(4)*ilamr(k)**cre(4)
6096 if (l_qs(k)) ze_snow(k) = (0.176/0.93) * (6.0/pi)*(6.0/pi) &
6097 & * (am_s/900.0)*(am_s/900.0)*smoz(k)
6098 if (l_qg(k)) ze_graupel(k) = (0.176/0.93) * (6.0/pi)*(6.0/pi) &
6099 & * (am_g/900.0)*(am_g/900.0) &
6100 & * n0_g(k)*cgg(4)*ilamg(k)**cge(4)
6101 enddo
6102
6103!+---+-----------------------------------------------------------------+
6104!..Special case of melting ice (snow/graupel) particles. Assume the
6105!.. ice is surrounded by the liquid water. Fraction of meltwater is
6106!.. extremely simple based on amount found above the melting level.
6107!.. Uses code from Uli Blahak (rayleigh_soak_wetgraupel and supporting
6108!.. routines).
6109!+---+-----------------------------------------------------------------+
6110
6111 if (.not. iiwarm .and. melti .and. k_0.ge.2) then
6112 do k = k_0-1, kts, -1
6113
6114!..Reflectivity contributed by melting snow
6115 if (allow_wet_snow .and. l_qs(k) .and. l_qs(k_0) ) then
6116 sr = max(0.01, min(1.0 - rs(k)/(rs(k) + rr(k)), 0.99))
6117 fmelt_s = real(sr*sr, kind=dp)
6118 eta = 0.0_dp
6119 om3 = 1./smoc(k)
6120 m0 = (smob(k)*om3)
6121 mrat = smob(k)*m0*m0*m0
6122 slam1 = m0 * lam0
6123 slam2 = m0 * lam1
6124 do n = 1, nrbins
6125 x = am_s * xxds(n)**bm_s
6126 call rayleigh_soak_wetgraupel (x, real(ocms, kind=dp), real(obms, kind=dp), &
6127 & fmelt_s, melt_outside_s, m_w_0, m_i_0, lamda_radar, &
6128 & cback, mixingrulestring_s, matrixstring_s, &
6129 & inclusionstring_s, hoststring_s, &
6130 & hostmatrixstring_s, hostinclusionstring_s)
6131 f_d = mrat*(kap0*exp(real(-slam1*xxds(n), kind=dp)) &
6132 & + kap1*(m0*xxds(n))**mu_s * exp(real(-slam2*xxds(n), kind=dp)))
6133 eta = eta + f_d * cback * simpson(n) * xdts(n)
6134 enddo
6135 ze_snow(k) = sngl(lamda4 / (pi5 * k_w) * eta)
6136 endif
6137
6138!..Reflectivity contributed by melting graupel
6139 if (allow_wet_graupel .and. l_qg(k) .and. l_qg(k_0) ) then
6140 sr = max(0.01, min(1.0 - rg(k)/(rg(k) + rr(k)), 0.99))
6141 fmelt_g = real(sr*sr, kind=dp)
6142 eta = 0.0_dp
6143 lamg = 1./ilamg(k)
6144 do n = 1, nrbins
6145 x = am_g * xxdg(n)**bm_g
6146 call rayleigh_soak_wetgraupel (x, real(ocmg, kind=dp), real(obmg, kind=dp), &
6147 & fmelt_g, melt_outside_g, m_w_0, m_i_0, lamda_radar, &
6148 & cback, mixingrulestring_g, matrixstring_g, &
6149 & inclusionstring_g, hoststring_g, &
6150 & hostmatrixstring_g, hostinclusionstring_g)
6151 f_d = n0_g(k)*xxdg(n)**mu_g * exp(real(-lamg*xxdg(n), kind=dp))
6152 eta = eta + f_d * cback * simpson(n) * xdtg(n)
6153 enddo
6154 ze_graupel(k) = sngl(lamda4 / (pi5 * k_w) * eta)
6155 endif
6156
6157 enddo
6158 endif
6159
6160 do k = kte, kts, -1
6161 dbz(k) = 10.*log10((ze_rain(k)+ze_snow(k)+ze_graupel(k))*1.e18_dp)
6162 enddo
6163
6164!..Reflectivity-weighted terminal velocity (snow, rain, graupel, mix).
6165 if (do_vt_dbz) then
6166 do k = kte, kts, -1
6167 vt_dbz(k) = 1.e-3
6168 if (rs(k).gt.r2) then
6169 mrat = smob(k) / smoc(k)
6170 ils1 = 1./(mrat*lam0 + fv_s)
6171 ils2 = 1./(mrat*lam1 + fv_s)
6172 t1_vts = kap0*csg(5)*ils1**cse(5)
6173 t2_vts = kap1*mrat**mu_s*csg(11)*ils2**cse(11)
6174 ils1 = 1./(mrat*lam0)
6175 ils2 = 1./(mrat*lam1)
6176 t3_vts = kap0*csg(6)*ils1**cse(6)
6177 t4_vts = kap1*mrat**mu_s*csg(12)*ils2**cse(12)
6178 vts_dbz_wt = rhof(k)*av_s * (t1_vts+t2_vts)/(t3_vts+t4_vts)
6179 if (temp(k).ge.273.15 .and. temp(k).lt.275.15) then
6180 vts_dbz_wt = vts_dbz_wt*1.5
6181 elseif (temp(k).ge.275.15) then
6182 vts_dbz_wt = vts_dbz_wt*2.0
6183 endif
6184 else
6185 vts_dbz_wt = 1.e-3
6186 endif
6187
6188 if (rr(k).gt.r1) then
6189 lamr = 1./ilamr(k)
6190 vtr_dbz_wt = rhof(k)*av_r*crg(13)*(lamr+fv_r)**(-cre(13)) &
6191 / (crg(4)*lamr**(-cre(4)))
6192 else
6193 vtr_dbz_wt = 1.e-3
6194 endif
6195
6196 if (rg(k).gt.r2) then
6197 lamg = 1./ilamg(k)
6198 vtg_dbz_wt = rhof(k)*av_g*cgg(5)*lamg**(-cge(5)) &
6199 / (cgg(4)*lamg**(-cge(4)))
6200 else
6201 vtg_dbz_wt = 1.e-3
6202 endif
6203
6204 vt_dbz(k) = (vts_dbz_wt*ze_snow(k) + vtr_dbz_wt*ze_rain(k) &
6205 + vtg_dbz_wt*ze_graupel(k)) &
6206 / (ze_rain(k)+ze_snow(k)+ze_graupel(k))
6207 enddo
6208 endif
6209
6210 end subroutine calc_refl10cm
6211!
6212!-------------------------------------------------------------------
6218 SUBROUTINE semi_lagrange_sedim(km,dzl,wwl,rql,precip,pfsan,dt,R1)
6219!-------------------------------------------------------------------
6220!
6221! dzl depth of model layer in meter
6222! wwl terminal velocity at model layer m/s
6223! rql dry air density*mixing ratio
6224! precip precipitation at surface
6225! dt time step
6226!
6227! author: hann-ming henry juang <henry.juang@noaa.gov>
6228! implemented by song-you hong
6229! reference: Juang, H.-M., and S.-Y. Hong, 2010: Forward semi-Lagrangian advection
6230! with mass conservation and positive definiteness for falling
6231! hydrometeors. *Mon. Wea. Rev.*, *138*, 1778-1791
6232!
6233 implicit none
6234
6235 integer, intent(in) :: km
6236 real(wp), intent(in) :: dt, R1
6237 real(wp), intent(in) :: dzl(km),wwl(km)
6238 real(wp), intent(out) :: precip
6239 real(wp), intent(inout) :: rql(km)
6240 real(wp), intent(out) :: pfsan(km)
6241 integer :: k,m,kk,kb,kt
6242 real(wp) :: tl,tl2,qql,dql,qqd
6243 real(wp) :: th,th2,qqh,dqh
6244 real(wp) :: zsum,qsum,dim,dip,con1,fa1,fa2
6245 real(wp) :: allold, decfl
6246 real(wp) :: dz(km), ww(km), qq(km)
6247 real(wp) :: wi(km+1), zi(km+1), za(km+2)
6248 real(wp) :: qn(km)
6249 real(wp) :: dza(km+1), qa(km+1), qmi(km+1), qpi(km+1)
6250 real(wp) :: net_flx(km)
6251!
6252 precip = 0.0
6253 qa(:) = 0.0
6254 qq(:) = 0.0
6255 dz(:) = dzl(:)
6256 ww(:) = wwl(:)
6257 do k = 1,km
6258 if(rql(k).gt.r1) then
6259 qq(k) = rql(k)
6260 else
6261 ww(k) = 0.0
6262 endif
6263 pfsan(k) = 0.0
6264 net_flx(k) = 0.0
6265 enddo
6266! skip for no precipitation for all layers
6267 allold = 0.0
6268 do k=1,km
6269 allold = allold + qq(k)
6270 enddo
6271 if(allold.le.0.0) then
6272 return
6273 endif
6274!
6275! compute interface values
6276 zi(1)=0.0
6277 do k=1,km
6278 zi(k+1) = zi(k)+dz(k)
6279 enddo
6280! n=1
6281! plm is 2nd order, we can use 2nd order wi or 3rd order wi
6282! 2nd order interpolation to get wi
6283 wi(1) = ww(1)
6284 wi(km+1) = ww(km)
6285 do k=2,km
6286 wi(k) = (ww(k)*dz(k-1)+ww(k-1)*dz(k))/(dz(k-1)+dz(k))
6287 enddo
6288! 3rd order interpolation to get wi
6289 fa1 = 9./16.
6290 fa2 = 1./16.
6291 wi(1) = ww(1)
6292 wi(2) = 0.5*(ww(2)+ww(1))
6293 do k=3,km-1
6294 wi(k) = fa1*(ww(k)+ww(k-1))-fa2*(ww(k+1)+ww(k-2))
6295 enddo
6296 wi(km) = 0.5*(ww(km)+ww(km-1))
6297 wi(km+1) = ww(km)
6298
6299! terminate of top of raingroup
6300 do k=2,km
6301 if( ww(k).eq.0.0 ) wi(k)=ww(k-1)
6302 enddo
6303
6304! diffusivity of wi
6305 con1 = 0.05
6306 do k=km,1,-1
6307 decfl = (wi(k+1)-wi(k))*dt/dz(k)
6308 if( decfl .gt. con1 ) then
6309 wi(k) = wi(k+1) - con1*dz(k)/dt
6310 endif
6311 enddo
6312! compute arrival point
6313 do k=1,km+1
6314 za(k) = zi(k) - wi(k)*dt
6315 enddo
6316 za(km+2) = zi(km+1)
6317
6318 do k=1,km+1
6319 dza(k) = za(k+1)-za(k)
6320 enddo
6321
6322! computer deformation at arrival point
6323 do k=1,km
6324 qa(k) = qq(k)*dz(k)/dza(k)
6325 enddo
6326 qa(km+1) = 0.0
6327
6328! estimate values at arrival cell interface with monotone
6329 do k=2,km
6330 dip=(qa(k+1)-qa(k))/(dza(k+1)+dza(k))
6331 dim=(qa(k)-qa(k-1))/(dza(k-1)+dza(k))
6332 if( dip*dim.le.0.0 ) then
6333 qmi(k)=qa(k)
6334 qpi(k)=qa(k)
6335 else
6336 qpi(k)=qa(k)+0.5*(dip+dim)*dza(k)
6337 qmi(k)=2.0*qa(k)-qpi(k)
6338 if( qpi(k).lt.0.0 .or. qmi(k).lt.0.0 ) then
6339 qpi(k) = qa(k)
6340 qmi(k) = qa(k)
6341 endif
6342 endif
6343 enddo
6344 qpi(1)=qa(1)
6345 qmi(1)=qa(1)
6346 qmi(km+1)=qa(km+1)
6347 qpi(km+1)=qa(km+1)
6348
6349! interpolation to regular point
6350 qn = 0.0
6351 kb=1
6352 kt=1
6353 intp : do k=1,km
6354 kb=max(kb-1,1)
6355 kt=max(kt-1,1)
6356! find kb and kt
6357 if( zi(k).ge.za(km+1) ) then
6358 exit intp
6359 else
6360 find_kb : do kk=kb,km
6361 if( zi(k).le.za(kk+1) ) then
6362 kb = kk
6363 exit find_kb
6364 else
6365 cycle find_kb
6366 endif
6367 enddo find_kb
6368 find_kt : do kk=kt,km+2
6369 if( zi(k+1).le.za(kk) ) then
6370 kt = kk
6371 exit find_kt
6372 else
6373 cycle find_kt
6374 endif
6375 enddo find_kt
6376 kt = kt - 1
6377! compute q with piecewise constant method
6378 if( kt.eq.kb ) then
6379 tl=(zi(k)-za(kb))/dza(kb)
6380 th=(zi(k+1)-za(kb))/dza(kb)
6381 tl2=tl*tl
6382 th2=th*th
6383 qqd=0.5*(qpi(kb)-qmi(kb))
6384 qqh=qqd*th2+qmi(kb)*th
6385 qql=qqd*tl2+qmi(kb)*tl
6386 qn(k) = (qqh-qql)/(th-tl)
6387 else if( kt.gt.kb ) then
6388 tl=(zi(k)-za(kb))/dza(kb)
6389 tl2=tl*tl
6390 qqd=0.5*(qpi(kb)-qmi(kb))
6391 qql=qqd*tl2+qmi(kb)*tl
6392 dql = qa(kb)-qql
6393 zsum = (1.-tl)*dza(kb)
6394 qsum = dql*dza(kb)
6395 if( kt-kb.gt.1 ) then
6396 do m=kb+1,kt-1
6397 zsum = zsum + dza(m)
6398 qsum = qsum + qa(m) * dza(m)
6399 enddo
6400 endif
6401 th=(zi(k+1)-za(kt))/dza(kt)
6402 th2=th*th
6403 qqd=0.5*(qpi(kt)-qmi(kt))
6404 dqh=qqd*th2+qmi(kt)*th
6405 zsum = zsum + th*dza(kt)
6406 qsum = qsum + dqh*dza(kt)
6407 qn(k) = qsum/zsum
6408 endif
6409 cycle intp
6410 endif
6411
6412 enddo intp
6413
6414! rain out
6415 sum_precip: do k=1,km
6416 if( za(k).lt.0.0 .and. za(k+1).le.0.0 ) then
6417 precip = precip + qa(k)*dza(k)
6418 net_flx(k) = qa(k)*dza(k)
6419 cycle sum_precip
6420 else if ( za(k).lt.0.0 .and. za(k+1).gt.0.0 ) then
6421 th = (0.0-za(k))/dza(k)
6422 th2 = th*th
6423 qqd = 0.5*(qpi(k)-qmi(k))
6424 qqh = qqd*th2+qmi(k)*th
6425 precip = precip + qqh*dza(k)
6426 net_flx(k) = qqh*dza(k)
6427 exit sum_precip
6428 endif
6429 exit sum_precip
6430 enddo sum_precip
6431
6432! calculating precipitation fluxes
6433 do k=km,1,-1
6434 if(k == km) then
6435 pfsan(k) = net_flx(k)
6436 else
6437 pfsan(k) = pfsan(k+1) + net_flx(k)
6438 end if
6439 enddo
6440!
6441! replace the new values
6442 rql(:) = max(qn(:),r1)
6443
6444 END SUBROUTINE semi_lagrange_sedim
6445
6458 subroutine graupel_psd_parameters(kts, kte, rand1, rg, ilamg, N0_g)
6459
6460 implicit none
6461
6462 integer, intent(in) :: kts, kte
6463 real(wp), intent(in) :: rand1
6464 real(wp), intent(in) :: rg(:)
6465 real(dp), intent(out) :: ilamg(:), N0_g(:)
6466
6467 integer :: k
6468 real(wp) :: ygra1, zans1
6469 real(dp) :: N0_exp, lam_exp, lamg
6470
6471 do k = kte, kts, -1
6472 ygra1 = alog10(max(1.e-9, rg(k)))
6473 zans1 = 3.4 + 2./7.*(ygra1+8.) + rand1
6474 n0_exp = 10.**(zans1)
6475 n0_exp = max(real(gonv_min, kind=dp), min(n0_exp, real(gonv_max, kind=dp)))
6476 lam_exp = (n0_exp*am_g*cgg(1)/rg(k))**oge1
6477 lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg
6478 ilamg(k) = 1./lamg
6479 n0_g(k) = n0_exp/(cgg(2)*lam_exp) * lamg**cge(2)
6480 enddo
6481
6482 end subroutine graupel_psd_parameters
6483
6497 function hail_mass_99th_percentile(kts, kte, qg, temperature, pressure, qv) result(max_hail_diam)
6498
6499 implicit none
6500
6501 integer, intent(in) :: kts, kte
6502 real(wp), intent(in) :: qg(:), temperature(:), pressure(:), qv(:)
6503 real(wp) :: max_hail_diam
6504
6505 integer :: k
6506 real(wp) :: rho(kts:kte), rg(kts:kte), max_hail_column(kts:kte)
6507 real(dp) :: ilamg(kts:kte), n0_g(kts:kte)
6508 real(wp), parameter :: random_number = 0.
6509
6510 max_hail_column = 0.
6511 rg = 0.
6512 do k = kts, kte
6513 rho(k) = roverrv*pressure(k) / (r*temperature(k)*(max(1.e-10, qv(k))+roverrv))
6514 if (qg(k) .gt. r1) then
6515 rg(k) = qg(k)*rho(k)
6516 else
6517 rg(k) = r1
6518 endif
6519 enddo
6520
6521 call graupel_psd_parameters(kts, kte, random_number, rg, ilamg, n0_g)
6522
6523 where(rg .gt. 1.e-9) max_hail_column = 10.05 * ilamg
6524 max_hail_diam = max_hail_column(kts)
6525
6526 end function hail_mass_99th_percentile
6527
6528!+---+-----------------------------------------------------------------+
6529!+---+-----------------------------------------------------------------+
6530end module module_mp_thompson
6531!+---+-----------------------------------------------------------------+
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:5735
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:5472
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:4809
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:4986
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:5433
module_mp_thompson::gammp
real function gammp(a, x)
Definition module_mp_thompson.F90:5532
module_mp_thompson::icedemott
real function icedemott(tempc, qv, qvs, qvsi, rho, nifa)
Definition module_mp_thompson.F90:5631
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:5142
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:5601
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:5285
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:5903
module_mp_thompson::wgamma
real function wgamma(y)
Definition module_mp_thompson.F90:5554
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:5341
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:5566
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:5779
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:5036
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:5099
module_mp_thompson::qr_acr_qs
subroutine qr_acr_qs
Rain collecting snow (and inverse). Explicit CE integration.
Definition module_mp_thompson.F90:4552
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:5187
module_mp_thompson::qr_acr_qg
subroutine qr_acr_qg
Rain collecting graupel (and inverse). Explicit CE integration.
Definition module_mp_thompson.F90:4382
module_mp_thompson::gammln
real function gammln(xx)
Returns the value ln(gamma(xx)) for xx > 0.
Definition module_mp_thompson.F90:5506
module_mp_thompson::thompson_finalize
subroutine thompson_finalize()
Definition module_mp_thompson.F90:1821
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:5705
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:6459
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:6498
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