SCALE-RM
scale_atmos_phy_mp_sn14.F90
Go to the documentation of this file.
1 !-------------------------------------------------------------------------------
52 !-------------------------------------------------------------------------------
53 
54 #ifdef PROFILE_FAPP
55 #define PROFILE_START(name) call fapp_start(name, 1, 1)
56 #define PROFILE_STOP(name) call fapp_stop (name, 1, 1)
57 #elif defined(PROFILE_FINEPA)
58 #define PROFILE_START(name) call start_collection(name)
59 #define PROFILE_STOP(name) call stop_collection (name)
60 #else
61 #define PROFILE_START(name)
62 #define PROFILE_STOP(name)
63 #endif
64 
65 #include "macro_thermodyn.h"
66 module scale_atmos_phy_mp_sn14
67  !-----------------------------------------------------------------------------
68  !
69  !++ used modules
70  !
71  use scale_precision
72  use scale_stdio
73  use scale_prof
74  use scale_grid_index
75 
76  use scale_const, only: &
77  grav => const_grav, &
78  pi => const_pi, &
79  undef8 => const_undef8, &
80  rdry => const_rdry, &
81  cpdry => const_cpdry, &
82  cvdry => const_cvdry, &
83  p00 => const_pre00, &
84  t00 => const_tem00, &
85  rvap => const_rvap, &
86  cpvap => const_cpvap, &
87  cvvap => const_cvvap, &
88  cl => const_cl, &
89  ci => const_ci, &
90  lhv => const_lhv00, &
91  lhf => const_lhf00, &
92  lhv0 => const_lhv0, &
93  lhf0 => const_lhf0, &
94  lhs0 => const_lhs0, &
95  lhv00 => const_lhv00, &
96  lhf00 => const_lhf00, &
97  psat0 => const_psat0, &
98  emelt => const_emelt, &
99  dwatr => const_dwatr
100 
101  use scale_atmos_hydrometeor, only: &
102  n_hyd, &
103  i_qv, &
104  i_qc, &
105  i_qr, &
106  i_qi, &
107  i_qs, &
108  i_qg, &
109  i_nc, &
110  i_nr, &
111  i_ni, &
112  i_ns, &
113  i_ng, &
114  i_hc, &
115  i_hr, &
116  i_hi, &
117  i_hs, &
118  i_hg
119  !-----------------------------------------------------------------------------
120  implicit none
121  private
122  !-----------------------------------------------------------------------------
123  !
124  !++ Public procedure
125  !
126  public :: atmos_phy_mp_sn14_config
127  public :: atmos_phy_mp_sn14_setup
128  public :: atmos_phy_mp_sn14
129  public :: atmos_phy_mp_sn14_cloudfraction
130  public :: atmos_phy_mp_sn14_effectiveradius
131  public :: atmos_phy_mp_sn14_mixingratio
132 
133  !-----------------------------------------------------------------------------
134  !
135  !++ Public parameters & variables
136  !
137  integer, public, parameter :: qa_mp = 11
138 
139  character(len=H_SHORT), public, target :: atmos_phy_mp_sn14_name(qa_mp)
140  character(len=H_MID) , public, target :: atmos_phy_mp_sn14_desc(qa_mp)
141  character(len=H_SHORT), public, target :: atmos_phy_mp_sn14_unit(qa_mp)
142 
143  real(RP), public, target :: atmos_phy_mp_sn14_dens(n_hyd) ! hydrometeor density [kg/m3]=[g/L]
144 
145  data atmos_phy_mp_sn14_name / &
146  'QV', &
147  'QC', &
148  'QR', &
149  'QI', &
150  'QS', &
151  'QG', &
152  'NC', &
153  'NR', &
154  'NI', &
155  'NS', &
156  'NG' /
157 
158  data atmos_phy_mp_sn14_desc / &
159  'Ratio of Water Vapor mass to total mass (Specific humidity)', &
160  'Ratio of Cloud Water mass to total mass', &
161  'Ratio of Rain Water mass to total mass', &
162  'Ratio of Cloud Ice mass to total mass', &
163  'Ratio of Snow mass to total mass', &
164  'Ratio of Graupel mass to total mass', &
165  'Cloud Water Number Density', &
166  'Rain Water Number Density', &
167  'Cloud Ice Number Density', &
168  'Snow Number Density', &
169  'Graupel Number Density' /
170 
171  data atmos_phy_mp_sn14_unit / &
172  'kg/kg', &
173  'kg/kg', &
174  'kg/kg', &
175  'kg/kg', &
176  'kg/kg', &
177  'kg/kg', &
178  'num/kg', &
179  'num/kg', &
180  'num/kg', &
181  'num/kg', &
182  'num/kg' /
183 
184  !-----------------------------------------------------------------------------
185  !
186  !++ Private procedure
187  !
188  private :: mp_sn14_init
189  private :: mp_sn14
190  private :: mp_terminal_velocity
191 
192  !-----------------------------------------------------------------------------
193  !
194  !++ Private parameters
195  !
196 
197  integer, private, parameter :: hydro_max = 5
198 
199  integer, private, parameter :: i_mp_qc = 1
200  integer, private, parameter :: i_mp_qr = 2
201  integer, private, parameter :: i_mp_qi = 3
202  integer, private, parameter :: i_mp_qs = 4
203  integer, private, parameter :: i_mp_qg = 5
204  integer, private, parameter :: i_mp_nc = 6
205  integer, private, parameter :: i_mp_nr = 7
206  integer, private, parameter :: i_mp_ni = 8
207  integer, private, parameter :: i_mp_ns = 9
208  integer, private, parameter :: i_mp_ng = 10
209 
210  integer, private :: qs_mp
211  integer, private :: qe_mp
212 
213  ! production rate
214  ! nucleation
215  integer, parameter :: i_lcccn = 1
216  integer, parameter :: i_ncccn = 2
217  integer, parameter :: i_liccn = 3
218  integer, parameter :: i_niccn = 4
219  ! freezing
220  integer, parameter :: i_lchom = 5
221  integer, parameter :: i_nchom = 6
222  integer, parameter :: i_lchet = 7
223  integer, parameter :: i_nchet = 8
224  integer, parameter :: i_lrhet = 9
225  integer, parameter :: i_nrhet = 10
226  ! melting
227  integer, parameter :: i_limlt = 11
228  integer, parameter :: i_nimlt = 12
229  integer, parameter :: i_lsmlt = 13
230  integer, parameter :: i_nsmlt = 14
231  integer, parameter :: i_lgmlt = 15
232  integer, parameter :: i_ngmlt = 16
233  ! vapor deposition
234  integer, parameter :: i_lrdep = 17
235  integer, parameter :: i_nrdep = 18
236  integer, parameter :: i_lidep = 19
237  integer, parameter :: i_nidep = 20
238  integer, parameter :: i_lsdep = 21
239  integer, parameter :: i_nsdep = 22
240  integer, parameter :: i_lgdep = 23
241  integer, parameter :: i_ngdep = 24
242  integer, parameter :: i_lcdep = 25
243 ! integer, parameter :: I_NCdep = 26
244  ! warm collection process
245  ! auto-conversion
246  integer, parameter :: i_lcaut = 26
247  integer, parameter :: i_ncaut = 27
248  integer, parameter :: i_nraut = 28
249  ! accretion
250  integer, parameter :: i_lcacc = 29
251  integer, parameter :: i_ncacc = 30
252  ! self-colletion, break-up
253  integer, parameter :: i_nrslc = 31
254  integer, parameter :: i_nrbrk = 32
255 
256  ! partial conversion(ice, snow => graupel)
257  integer, parameter :: i_licon = 33
258  integer, parameter :: i_nicon = 34
259  integer, parameter :: i_lscon = 35
260  integer, parameter :: i_nscon = 36
261  ! enhanced melting due to
262  integer, parameter :: i_liacm = 37 ! ice-cloud
263  integer, parameter :: i_niacm = 38
264  integer, parameter :: i_liarm = 39 ! ice-rain
265  integer, parameter :: i_niarm = 40
266  integer, parameter :: i_lsacm = 41 ! snow-cloud
267  integer, parameter :: i_nsacm = 42
268  integer, parameter :: i_lsarm = 43 ! snow-rain
269  integer, parameter :: i_nsarm = 44
270  integer, parameter :: i_lgacm = 45 ! graupel-cloud
271  integer, parameter :: i_ngacm = 46
272  integer, parameter :: i_lgarm = 47 ! graupel-rain
273  integer, parameter :: i_ngarm = 48
274  ! ice multiplication by splintering
275  integer, parameter :: i_lgspl = 49
276  integer, parameter :: i_lsspl = 50
277  integer, parameter :: i_nispl = 51
278 
279  integer, parameter :: pq_max = 51
280 
281  ! production rate of mixed-phase collection process
282  ! PXXacYY2ZZ means XX collect YY produce ZZ
283  integer, parameter :: i_liaclc2li = 1 ! cloud-ice
284  integer, parameter :: i_niacnc2ni = 2
285  integer, parameter :: i_lsaclc2ls = 3 ! cloud-snow(cloud change)
286  integer, parameter :: i_nsacnc2ns = 4
287  integer, parameter :: i_lgaclc2lg = 5 ! cloud-graupel
288  integer, parameter :: i_ngacnc2ng = 6
289  integer, parameter :: i_lracli2lg_i = 7 ! rain-ice(ice change)
290  integer, parameter :: i_nracni2ng_i = 8
291  integer, parameter :: i_lracli2lg_r = 9 ! rain-ice(rain change)
292  integer, parameter :: i_nracni2ng_r = 10
293  integer, parameter :: i_lracls2lg_s = 11 ! rain-snow(snow change)
294  integer, parameter :: i_nracns2ng_s = 12
295  integer, parameter :: i_lracls2lg_r = 13 ! rain-snow(rain change)
296  integer, parameter :: i_nracns2ng_r = 14
297  integer, parameter :: i_lraclg2lg = 15 ! rain-graupel(rain change)
298  integer, parameter :: i_nracng2ng = 16
299  integer, parameter :: i_liacli2ls = 17 ! ice-ice
300  integer, parameter :: i_niacni2ns = 18
301  integer, parameter :: i_liacls2ls = 19 ! ice-snow(ice change)
302  integer, parameter :: i_niacns2ns = 20
303  integer, parameter :: i_nsacns2ns = 21 ! snow-snow
304  integer, parameter :: i_ngacng2ng = 22 ! graupel-graupel
305  integer, parameter :: i_lgacls2lg = 23 ! snow-graupel
306  integer, parameter :: i_ngacns2ng = 24
307 
308  integer, parameter :: pac_max = 24
309 
310 
311 
312  character(len=H_SHORT), save :: wlabel(hydro_max)
313 
314  ! empirical value from Meyers etal.(1991), 1[/liter] = 1.d3[/m3]
315  real(RP), private, parameter :: nqmin(hydro_max) = (/ 1.e+4_rp, 1.0_rp, 1.0_rp, 1.e-4_rp, 1.e-4_rp /) ! [1/m3]
316  ! refer to Seifert(2002) (Dr. Thesis, Table.5.1)
317  ! max mass, for D_min=79um, 2mm, 5mm, 1cm, 1cm
318  real(RP), private, parameter :: xqmax(hydro_max) = (/ 2.6e-10_rp, 5.0e-6_rp, 1.377e-6_rp, 7.519e-6_rp, 4.90e-5_rp /)! [kg]
319  ! SB06, Table 1.
320  ! min mass, for D_min=2um, 79um, 10um, 20um, 100um
321  real(RP), private, parameter :: xqmin(hydro_max) = (/ 4.20e-15_rp, 2.60e-10_rp, 3.382e-13_rp, 1.847e-12_rp, 1.230e-10_rp /)! [kg]
322 
323 
324 
325  ! for all processes
326  ! SB06, Table 1.
327  real(RP), private, parameter :: xc_min = 4.20e-15_rp ! [kg] : min mass, D_min=2um
328  real(RP), private, parameter :: xr_min = 2.60e-10_rp ! [kg] : min mass, D_min=79um
329  real(RP), private, parameter :: xi_min = 3.382e-13_rp ! [kg] : min mass, D_min=10um
330  real(RP), private, parameter :: xs_min = 1.847e-12_rp ! [kg] : min mass, D_min=20um
331  real(RP), private, parameter :: xg_min = 1.230e-10_rp ! [kg] : min mass, D_min=100um
332  ! refer to Seifert(2002) (Dr. Thesis, Table.5.1)
333  real(RP), private, parameter :: xc_max = 2.6e-10_rp ! [kg] : max, D_max=79um
334  real(RP), private, parameter :: xr_max = 5.00e-6_rp ! [kg] : max, D_max=2mm
335  real(RP), private, parameter :: xi_max = 1.377e-6_rp ! [kg] : max, D_max=5mm
336  real(RP), private, parameter :: xs_max = 7.519e-6_rp ! [kg] : max, D_max=1cm
337  real(RP), private, parameter :: xg_max = 4.900e-5_rp ! [kg] : max, D_max=1cm
338  ! filter similar to Ikawa et al.(1991) sec.3.5
339  real(RP), private, parameter :: xmin_filter= xc_min
340  ! filter of effective radius(1 micron)
341  real(RP), private, parameter :: rmin_re= 1.e-6_rp
342  !
343  ! SB06(95),(96)
344  real(RP), private, parameter :: n0r_min= 2.5e+5_rp ! [m-4]: min intercept parameter of rain
345  real(RP), private, parameter :: n0r_max= 2.0e+7_rp ! [m-4]: max
346  real(RP), private, parameter :: lambdar_min= 1.e+3_rp ! [m-1]: min slope parameter of rain
347  real(RP), private, parameter :: lambdar_max= 1.e+4_rp ! [m-1]: max
348  ! empirical value from Meyers etal.(1991), 1[/liter] = 1.d3[/m3]
349  real(RP), private, parameter :: nc_min = 1.e+4_rp ! [m-3] empirical T.Mitsui
350  real(RP), private, parameter :: nr_min = 1.0_rp ! [m-3] 1/1000 [/liter]
351  real(RP), private, parameter :: ni_min = 1.0_rp ! [m-3]
352  real(RP), private, parameter :: ns_min = 1.e-4_rp ! [m-3]
353  real(RP), private, parameter :: ng_min = 1.e-4_rp ! [m-3]
354  ! empirical filter
355  real(RP), private, parameter :: lc_min = xc_min*nc_min
356  real(RP), private, parameter :: lr_min = xr_min*nr_min
357  real(RP), private, parameter :: li_min = xi_min*ni_min
358  real(RP), private, parameter :: ls_min = xs_min*ns_min
359  real(RP), private, parameter :: lg_min = xg_min*ng_min
360  !
361  real(RP), private, parameter :: x_sep = 2.6e-10_rp ! boundary mass between cloud and rain
362  !
363  real(RP), private, parameter :: tem_min=100.0_rp
364  real(RP), private, parameter :: rho_min=1.e-5_rp ! 3.e-3 is lower limit recognized in many experiments.
365  real(RP), private, parameter :: rhoi = 916.70_rp
366  !
367  integer, private, save :: ntmax_phase_change = 1
368  integer, private, save :: ntmax_collection = 1
369  integer, private, save :: mp_ntmax_sedimentation= 1 ! 10/08/03 [Add] T.Mitsui
370  !
371  !--- standard density
372  real(RP), private, parameter :: rho_0 = 1.280_rp
373  !--- max number of Nc( activatable aerosol number concentration )
374  real(RP), allocatable, private, save :: nc_uplim_d(:,:,:)
375  !
376  !--- thermal conductivity of air
377  real(RP), private, parameter :: ka0 = 2.428e-2_rp
378 
379  real(RP), private, parameter :: dka_dt = 7.47e-5_rp
380 
381  !====== Ka = Ka0 + temc*dKa_dT
382  !
383  !--- Dynamic viscosity
384  real(RP), private, parameter :: mua0 = 1.718e-5_rp
385 
386  real(RP), private, parameter :: dmua_dt = 5.28e-8_rp
387 
388  !====== mua = mua0 + temc*dmua_dT
389  !
390  real(RP), private, save :: xc_ccn = 1.e-12_rp ! [kg]
391  real(RP), private, save :: xi_ccn = 1.e-12_rp ! [kg] ! [move] 11/08/30 T.Mitsui
392  !
393  ! capacity of diffusional growth
394  ! ( dependent of their geometries )
395  real(RP), private, save :: cap(hydro_max)
396  !
397  ! constants for Diameter-Mass relation
398  ! D = a * x^b
399  real(RP), private, save :: a_m(hydro_max)
400  real(RP), private, save :: b_m(hydro_max)
401  ! constants for Terminal velocity-Mass relation
402  ! vt = alpha * x^beta * f
403  real(RP), private, save :: alpha_v(hydro_max,2)
404  real(RP), private, save :: beta_v(hydro_max,2)
405  real(RP), private, save :: alpha_vn(hydro_max,2) !
406  real(RP), private, save :: beta_vn(hydro_max,2) !
407  real(RP), private, save :: gamma_v(hydro_max)
408  ! Aerodynamical factor for correction of terminal velocity.(Heymsfield and Iaquinta, 2000)
409  ! vt(tem,pre) = vt0 * (pre/pre0)**a_pre0 * (tem/tem0)**a_tem0
410  real(RP), private, parameter :: pre0_vt = 300.e+2_rp ! 300hPa
411  real(RP), private, parameter :: tem0_vt = 233.0_rp ! -40degC
412  real(RP), private, parameter :: a_pre0_vt = -0.1780_rp
413  real(RP), private, parameter :: a_tem0_vt = -0.3940_rp
414  ! Parameters to determine Droplet Size Distribution
415  ! as a General Gamma Distribution
416  ! f(x) = A x^nu exp(-lambda x^mu )
417  ! for Marshall Palmer Distribution ( popular for rain )
418  ! mu=1/3, nu=-2/3
419  ! for Gamma Distribution ( popular for cloud )
420  ! mu=1
421  real(RP), private, save :: nu(hydro_max)
422  real(RP), private, save :: mu(hydro_max)
423  ! Mitchell(1996), JAS, vol.53, No.12, pp.1710-1723
424  ! area = a_area*D^b_area
425  ! area = ax_area*x^bx_area
426  ! Auer and Veal(1970), JAS, vol.27, pp.919-pp.926
427  ! height = a_h*x^b_h( based on h=a_ar*D^b_ar, ar:aspect ratio)
428  real(RP), private, save :: a_area(hydro_max) !
429  real(RP), private, save :: b_area(hydro_max) !
430  real(RP), private, save :: ax_area(hydro_max) !
431  real(RP), private, save :: bx_area(hydro_max) !
432  ! parameters for radius of equivalent area
433  ! r_ea = a_rea*x**b_rea
434  real(RP), private, save :: a_rea(hydro_max) !
435  real(RP), private, save :: b_rea(hydro_max) !
436  real(RP), private, save :: a_rea2(hydro_max) !
437  real(RP), private, save :: b_rea2(hydro_max) !
438  real(RP), private, save :: a_rea3(hydro_max) !
439  real(RP), private, save :: b_rea3(hydro_max) !
440  !
441  real(RP), private, save :: a_d2vt(hydro_max) !
442  real(RP), private, save :: b_d2vt(hydro_max) !
443  ! coefficient of x^2 moment of DSD
444  ! Z = integral x*x*f(x) dx
445  ! = coef_m2*N*(L/N)^2
446  real(RP), private, save :: coef_m2(hydro_max)
447  ! radar reflectivity coefficient defined by diameter
448  real(RP), private, save :: coef_d6(hydro_max) !
449  ! volume coefficient defined by diameter
450  real(RP), private, save :: coef_d3(hydro_max) !
451  ! coefficient of weighted mean diameter
452  real(RP), private, save :: coef_d(hydro_max)
453  ! coefficient of weighted mean d*d*v
454  real(RP), private, save :: coef_d2v(hydro_max) !
455  ! coefficient of moment of d*d*v
456  real(RP), private, save :: coef_md2v(hydro_max) !
457  !
458  ! for effective radius(spherical particle)
459  real(RP), private, save :: coef_r2(hydro_max)
460  real(RP), private, save :: coef_r3(hydro_max)
461  real(RP), private, save :: coef_re(hydro_max)
462  ! for effective radius(hexagonal plate)
463  real(RP), private, save :: coef_rea2(hydro_max) !
464  real(RP), private, save :: coef_rea3(hydro_max) !
465  logical, private, save :: opt_m96_ice=.true. !
466  logical, private, save :: opt_m96_column_ice=.false. !
467  !
468  ! coefficeint of weighted mean terminal velocity
469  ! vt0 is number weighted and
470  ! vt1 is mass weighted.
471  real(RP), private, save :: coef_vt0(hydro_max,2)
472  real(RP), private, save :: coef_vt1(hydro_max,2)
473  real(RP), private, save :: coef_deplc
474  real(RP), private, save :: coef_dave_n(hydro_max) !
475  real(RP), private, save :: coef_dave_l(hydro_max) !
476  ! diameter of terminal velocity branch
477  !
478  real(RP), private, save :: d0_ni=261.76e-6_rp !
479  real(RP), private, save :: d0_li=398.54e-6_rp
480  real(RP), private, parameter :: d0_ns=270.03e-6_rp !
481  real(RP), private, parameter :: d0_ls=397.47e-6_rp !
482  real(RP), private, parameter :: d0_ng=269.08e-6_rp !
483  real(RP), private, parameter :: d0_lg=376.36e-6_rp !
484  !
485  real(RP), private, parameter :: coef_vtr_ar1=9.65_rp ! coef. for large branch
486  ! original parameter of Rogers etal.(1993)
487  real(RP), private, parameter :: coef_vtr_br1=10.43_rp ! ...
488  real(RP), private, parameter :: coef_vtr_cr1=600.0_rp ! ...
489  real(RP), private, parameter :: coef_vtr_ar2=4.e+3_rp ! coef. for small branch
490  real(RP), private, parameter :: coef_vtr_br2=12.e+3_rp ! ...
491  real(RP), private, parameter :: d_vtr_branch=0.745e-3_rp ! 0.745 mm (diameter dividing 2-branches)
492  ! equilibrium diameter of rain break-up
493  real(RP), private, parameter :: dr_eq = 1.10e-3_rp ! eqilibrium diameter, Seifert 2008(36)
494  ! coefficient of General Gamma.
495  ! f(x) = A x^nu exp(-lambda x^mu )
496  ! lambda = coef_lambda * (L/N)^{-mu}
497  ! A = coef_A*N*lambda^slope_A
498  real(RP), private, save :: coef_a(hydro_max)
499  real(RP), private, save :: coef_lambda(hydro_max)
500 ! real(RP), private, save :: slope_A(HYDRO_MAX)
501  ! coefficeint of weighted ventilation effect.
502  ! large, and small branch is by PK97(13-60),(13-61),(13-88),(13-89)
503  real(RP), private, save :: ah_vent (hydro_max,2) !
504  real(RP), private, save :: bh_vent (hydro_max,2) !
505  real(RP), private, save :: ah_vent0 (hydro_max,2) !
506  real(RP), private, save :: bh_vent0 (hydro_max,2) !
507  real(RP), private, save :: ah_vent1 (hydro_max,2) !
508  real(RP), private, save :: bh_vent1 (hydro_max,2) !
509  ! coefficient of collision growth
510  real(RP), private, save :: delta_b0 (hydro_max)
511  real(RP), private, save :: delta_b1 (hydro_max)
512  real(RP), private, save :: delta_ab0(hydro_max,hydro_max)
513  real(RP), private, save :: delta_ab1(hydro_max,hydro_max)
514  !
515  real(RP), private, save :: theta_b0 (hydro_max)
516  real(RP), private, save :: theta_b1 (hydro_max)
517  real(RP), private, save :: theta_ab0(hydro_max,hydro_max)
518  real(RP), private, save :: theta_ab1(hydro_max,hydro_max)
519  !
520  logical, private, save :: opt_debug=.false.
521  !
522  logical, private, save :: opt_debug_tem=.false.
523  logical, private, save :: opt_debug_inc=.true.
524  logical, private, save :: opt_debug_act=.true.
525  logical, private, save :: opt_debug_ree=.true.
526  logical, private, save :: opt_debug_bcs=.true.
527 
528  integer, private, save :: mp_nstep_sedimentation
529  real(RP), private, save :: mp_rnstep_sedimentation
530  real(DP), private, save :: mp_dtsec_sedimentation
531 
532  !
533  ! metrics of vertical coordinate
534  ! not used in SCALE-RM
535  !
536  real(RP), private, allocatable, save :: gsgam2_d (:,:,:)
537  real(RP), private, allocatable, save :: gsgam2h_d(:,:,:)
538  real(RP), private, allocatable, save :: gam2_d (:,:,:)
539  real(RP), private, allocatable, save :: gam2h_d (:,:,:)
540  real(RP), private, allocatable, save :: rgsgam2_d(:,:,:)
541  real(RP), private, allocatable, save :: rgs_d (:,:,:)
542  real(RP), private, allocatable, save :: rgsh_d (:,:,:)
543 
544  logical, private, save :: mp_doautoconversion = .true.
545  logical, private, save :: mp_doprecipitation = .true.
546  logical, private, save :: mp_couple_aerosol = .false. ! apply CCN effect?
547  real(RP), private, save :: mp_ssw_lim = 1.e+1_rp
548 
549 
550  !-----------------------------------------------------------------------------
551 contains
552  !-----------------------------------------------------------------------------
554  subroutine atmos_phy_mp_sn14_config( &
555  MP_TYPE, &
556  QA, QS )
557  use scale_process, only: &
558  prc_mpistop
559  use scale_atmos_hydrometeor, only: &
560  atmos_hydrometeor_regist
561  use scale_tracer, only: &
562  tracer_regist
563  implicit none
564 
565  character(len=*), intent(in) :: mp_type
566  integer, intent(out) :: qa
567  integer, intent(out) :: qs
568 
569  integer :: qs2
570  !---------------------------------------------------------------------------
571 
572  if( io_l ) write(io_fid_log,*)
573  if( io_l ) write(io_fid_log,*) '++++++ Module[Cloud Microphysics Tracer] / Categ[ATMOS PHYSICS] / Origin[SCALElib]'
574  if( io_l ) write(io_fid_log,*) '*** Tracers for Seiki and Nakajima (2014) 2-moment bulk 6 category'
575 
576  if ( mp_type /= 'SN14' ) then
577  write(*,*) 'xxx ATMOS_PHY_MP_TYPE is not SN14. Check!'
578  call prc_mpistop
579  end if
580 
581  call atmos_hydrometeor_regist( qs_mp, & ! [OUT]
582  1, 2, 3, & ! [IN]
583  atmos_phy_mp_sn14_name(1:6), & ! [IN]
584  atmos_phy_mp_sn14_desc(1:6), & ! [IN]
585  atmos_phy_mp_sn14_unit(1:6) ) ! [IN]
586 
587  call tracer_regist( qs2, & ! [OUT]
588  5, & ! [IN]
589  atmos_phy_mp_sn14_name(7:11), & ! [IN]
590  atmos_phy_mp_sn14_desc(7:11), & ! [IN]
591  atmos_phy_mp_sn14_unit(7:11) ) ! [IN]
592 
593  qa = qa_mp
594  qs = qs_mp
595  qe_mp = qs_mp + qa_mp - 1
596 
597  i_qv = qs
598  i_qc = qs + i_mp_qc
599  i_qr = qs + i_mp_qr
600  i_qi = qs + i_mp_qi
601  i_qs = qs + i_mp_qs
602  i_qg = qs + i_mp_qg
603  i_nc = qs + i_mp_nc
604  i_nr = qs + i_mp_nr
605  i_ni = qs + i_mp_ni
606  i_ns = qs + i_mp_ns
607  i_ng = qs + i_mp_ng
608 
609  return
610  end subroutine atmos_phy_mp_sn14_config
611 
612  !-----------------------------------------------------------------------------
614  subroutine atmos_phy_mp_sn14_setup
615  use scale_process, only: &
616  prc_mpistop
617  use scale_grid, only: &
618  cdz => grid_cdz
619  use scale_const, only: &
620  const_undef, &
621  const_dwatr, &
622  const_dice
623  use scale_time, only: &
624  time_dtsec_atmos_phy_mp
625  implicit none
626 
627  namelist / param_atmos_phy_mp / &
628  mp_doautoconversion, &
629  mp_doprecipitation, &
630  mp_ssw_lim, &
631  mp_couple_aerosol, &
632  mp_ntmax_sedimentation
633 
634  real(RP), parameter :: max_term_vel = 10.0_rp !-- terminal velocity for calculate dt of sedimentation
635  integer :: nstep_max
636  integer :: ierr
637  !---------------------------------------------------------------------------
638 
639  if( io_l ) write(io_fid_log,*)
640  if( io_l ) write(io_fid_log,*) '++++++ Module[Cloud Microphysics] / Categ[ATMOS PHYSICS] / Origin[SCALElib]'
641  if( io_l ) write(io_fid_log,*) '*** Seiki and Nakajima (2014) 2-moment bulk 6 category'
642 
643  !--- read namelist
644  rewind(io_fid_conf)
645  read(io_fid_conf,nml=param_atmos_phy_mp,iostat=ierr)
646  if( ierr < 0 ) then !--- missing
647  if( io_l ) write(io_fid_log,*) '*** Not found namelist. Default used.'
648  elseif( ierr > 0 ) then !--- fatal error
649  write(*,*) 'xxx Not appropriate names in namelist PARAM_ATMOS_PHY_MP. Check!'
650  call prc_mpistop
651  endif
652  if( io_nml ) write(io_fid_nml,nml=param_atmos_phy_mp)
653 
654  atmos_phy_mp_sn14_dens(:) = const_undef
655  atmos_phy_mp_sn14_dens(i_hc) = const_dwatr
656  atmos_phy_mp_sn14_dens(i_hr) = const_dwatr
657  atmos_phy_mp_sn14_dens(i_hi) = const_dice
658  atmos_phy_mp_sn14_dens(i_hs) = const_dice
659  atmos_phy_mp_sn14_dens(i_hg) = const_dice
660 
661  wlabel(1) = "CLOUD"
662  wlabel(2) = "RAIN"
663  wlabel(3) = "ICE"
664  wlabel(4) = "SNOW"
665  wlabel(5) = "GRAUPEL"
666 
667  call mp_sn14_init
668 
669  allocate(nc_uplim_d(1,ia,ja))
670  nc_uplim_d(:,:,:) = 150.e6_rp
671 
672  nstep_max = int( ( time_dtsec_atmos_phy_mp * max_term_vel ) / minval( cdz ) )
673  mp_ntmax_sedimentation = max( mp_ntmax_sedimentation, nstep_max )
674 
675  mp_nstep_sedimentation = mp_ntmax_sedimentation
676  mp_rnstep_sedimentation = 1.0_rp / real(mp_ntmax_sedimentation,kind=rp)
677  mp_dtsec_sedimentation = time_dtsec_atmos_phy_mp * mp_rnstep_sedimentation
678 
679  if( io_l ) write(io_fid_log,*)
680  if( io_l ) write(io_fid_log,*) '*** Timestep of sedimentation is divided into : ', mp_ntmax_sedimentation, ' step(s)'
681  if( io_l ) write(io_fid_log,*) '*** DT of sedimentation [s] : ', mp_dtsec_sedimentation
682 
683  !--- For kij
684  allocate( gsgam2_d(ka,ia,ja) )
685  allocate( gsgam2h_d(ka,ia,ja) )
686  allocate( gam2_d(ka,ia,ja) )
687  allocate( gam2h_d(ka,ia,ja) )
688  allocate( rgsgam2_d(ka,ia,ja) )
689  allocate( rgs_d(ka,ia,ja) )
690  allocate( rgsh_d(ka,ia,ja) )
691  gsgam2_d(:,:,:) = 1.0_rp
692  gsgam2h_d(:,:,:) = 1.0_rp
693  gam2_d(:,:,:) = 1.0_rp
694  gam2h_d(:,:,:) = 1.0_rp
695  rgsgam2_d(:,:,:) = 1.0_rp
696  rgs_d(:,:,:) = 1.0_rp
697  rgsh_d(:,:,:) = 1.0_rp
698 
699  return
700  end subroutine atmos_phy_mp_sn14_setup
701 
702  !-----------------------------------------------------------------------------
704  !-----------------------------------------------------------------------------
705  subroutine atmos_phy_mp_sn14( &
706  DENS, &
707  MOMZ, &
708  MOMX, &
709  MOMY, &
710  RHOT, &
711  QTRC, &
712  CCN, &
713  EVAPORATE, &
714  SFLX_rain, &
715  SFLX_snow )
716  use scale_grid_index
717  use scale_tracer, only: &
718  qa
719  implicit none
720 
721  real(RP), intent(inout) :: dens (ka,ia,ja)
722  real(RP), intent(inout) :: momz (ka,ia,ja)
723  real(RP), intent(inout) :: momx (ka,ia,ja)
724  real(RP), intent(inout) :: momy (ka,ia,ja)
725  real(RP), intent(inout) :: rhot (ka,ia,ja)
726  real(RP), intent(inout) :: qtrc (ka,ia,ja,qa)
727  real(RP), intent(in) :: ccn (ka,ia,ja)
728  real(RP), intent(out) :: evaporate(ka,ia,ja) !--- number of evaporated cloud [/m3]
729  real(RP), intent(out) :: sflx_rain(ia,ja)
730  real(RP), intent(out) :: sflx_snow(ia,ja)
731  !---------------------------------------------------------------------------
732 
733  if( io_l ) write(io_fid_log,*) '*** Atmos physics step: Cloud microphysics(SN14)'
734 
735 #ifdef PROFILE_FIPP
736  call fipp_start()
737 #endif
738 
739  call mp_negativefilter( dens, qtrc )
740 
741  call mp_sn14( dens, & ! [INOUT]
742  momz, & ! [INOUT]
743  momx, & ! [INOUT]
744  momy, & ! [INOUT]
745  rhot, & ! [INOUT]
746  qtrc, & ! [INOUT]
747  ccn, & ! [IN]
748  evaporate, & ! [OUT]
749  sflx_rain, & ! [OUT]
750  sflx_snow ) ! [OUT]
751 
752  call mp_negativefilter( dens, qtrc )
753 
754 #ifdef PROFILE_FIPP
755  call fipp_stop()
756 #endif
757 
758  return
759  end subroutine atmos_phy_mp_sn14
760 
761  !-----------------------------------------------------------------------------
762  subroutine mp_sn14_init
763  use scale_process, only: &
764  prc_mpistop
765  use scale_specfunc, only: &
766  gammafunc => sf_gamma
767  implicit none
768 
769  real(RP) :: w1(hydro_max)
770  real(RP) :: w2(hydro_max)
771  real(RP) :: w3(hydro_max)
772  real(RP) :: w4(hydro_max)
773  real(RP) :: w5(hydro_max)
774  real(RP) :: w6(hydro_max)
775  real(RP) :: w7(hydro_max)
776  real(RP) :: w8(hydro_max)
777 
778  ! work for calculation of capacity, Mitchell and Arnott (1994) , eq.(9)
779  real(RP) :: ar_ice_fix = 0.7_rp
780  real(RP) :: wcap1, wcap2
781  ! work for ventilation coefficient
782  logical :: flag_vent0(hydro_max), flag_vent1(hydro_max)
783  integer :: ierr
784  integer :: iw, ia, ib
785  integer :: n
786  !
787  namelist /nm_mp_sn14_init/ &
788  opt_debug, &
789  opt_debug_tem, &
790  opt_debug_inc, &
791  opt_debug_act, &
792  opt_debug_ree, &
793  opt_debug_bcs, &
794  ntmax_phase_change, &
795  ntmax_collection
796  !
797  namelist /nm_mp_sn14_particles/ &
798  a_m, b_m, alpha_v, beta_v, gamma_v, &
799  alpha_vn, beta_vn, &
800  a_area, b_area, cap, &
801  nu, mu, &
802  opt_m96_column_ice, &
803  opt_m96_ice, &
804  ar_ice_fix
805  real(RP), parameter :: eps_gamma=1.e-30_rp
806 
807  a_m(:) = undef8
808  b_m(:) = undef8
809  alpha_v(:,:) = undef8
810  beta_v(:,:) = undef8
811  alpha_vn(:,:) = undef8
812  beta_vn(:,:) = undef8
813  gamma_v(:) = undef8
814  a_d2vt(:) = undef8
815  b_d2vt(:) = undef8
816  a_area(:) = undef8
817  b_area(:) = undef8
818  ax_area(:) = undef8
819  bx_area(:) = undef8
820  a_rea(:) = undef8
821  b_rea(:) = undef8
822  a_rea2(:) = undef8
823  b_rea2(:) = undef8
824  a_rea3(:) = undef8
825  b_rea3(:) = undef8
826  nu(:) = undef8
827  mu(:) = undef8
828  cap(:) = undef8
829  coef_m2(:) = undef8
830  coef_dave_n(:) = undef8
831  coef_dave_l(:) = undef8
832  coef_d(:) = undef8
833  coef_d3(:) = undef8
834  coef_d6(:) = undef8
835  coef_d2v(:) = undef8
836  coef_md2v(:) = undef8
837  coef_r2(:) = undef8
838  coef_r3(:) = undef8
839  coef_re(:) = undef8
840  coef_rea2(:) = undef8
841  coef_rea3(:) = undef8
842  coef_a(:) = undef8
843 ! slope_A(:) = UNDEF8
844  coef_lambda(:) = undef8
845  coef_vt0(:,:) = undef8
846  coef_vt1(:,:) = undef8
847  delta_b0(:) = undef8
848  delta_b1(:) = undef8
849  delta_ab0(:,:) = undef8
850  delta_ab1(:,:) = undef8
851  theta_b0(:) = undef8
852  theta_b1(:) = undef8
853  theta_ab0(:,:) = undef8
854  theta_ab1(:,:) = undef8
855  !
856  ah_vent(:,:) = undef8
857  ah_vent0(:,:) = undef8
858  ah_vent1(:,:) = undef8
859  bh_vent(:,:) = undef8
860  bh_vent0(:,:) = undef8
861  bh_vent1(:,:) = undef8
862 
863  !--- read namelist
864  rewind(io_fid_conf)
865  read(io_fid_conf,nml=nm_mp_sn14_init,iostat=ierr)
866 
867  if( ierr < 0 ) then !--- missing
868  if( io_l ) write(io_fid_log,*) '*** Not found namelist. Default used.'
869  elseif( ierr > 0 ) then !--- fatal error
870  write(*,*) 'xxx Not appropriate names in namelist nm_mp_sn14_init. Check!'
871  call prc_mpistop
872  endif
873  if( io_nml ) write(io_fid_nml,nml=nm_mp_sn14_init)
874 
875  !
876  ! default setting
877  !
878  ! Area parameters with mks unit originated by Mitchell(1996)
879  a_area(i_mp_qc) = pi/4.0_rp ! sphere
880  a_area(i_mp_qr) = pi/4.0_rp ! sphere
881  a_area(i_mp_qi) = 0.65_rp*1.e-4_rp*100.0_rp**(2.00_rp) ! Mitchell(1996), Hexagonal Plate
882  a_area(i_mp_qs) = 0.2285_rp*1.e-4_rp*100.0_rp**(1.88_rp) ! Mitchell(1996), Aggregates
883  a_area(i_mp_qg) = 0.50_rp*1.e-4_rp*100.0_rp**(2.0_rp) ! Mitchell(1996), Lump Graupel
884  b_area(i_mp_qc) = 2.0_rp
885  b_area(i_mp_qr) = 2.0_rp
886  b_area(i_mp_qi) = 2.0_rp
887  b_area(i_mp_qs) = 1.88_rp
888  b_area(i_mp_qg) = 2.0_rp
889  !
890  ! Seifert and Beheng(2006), Table. 1 or List of symbols
891  !----------------------------------------------------------
892  ! Diameter-Mass relationship
893  ! D = a * x^b
894  a_m(i_mp_qc) = 0.124_rp
895  a_m(i_mp_qr) = 0.124_rp
896  a_m(i_mp_qi) = 0.217_rp
897  a_m(i_mp_qs) = 8.156_rp
898  a_m(i_mp_qg) = 0.190_rp
899  b_m(i_mp_qc) = 1.0_rp/3.0_rp
900  b_m(i_mp_qr) = 1.0_rp/3.0_rp
901  b_m(i_mp_qi) = 0.302_rp
902  b_m(i_mp_qs) = 0.526_rp
903  b_m(i_mp_qg) = 0.323_rp
904  !----------------------------------------------------------
905  ! Terminal velocity-Mass relationship
906  ! vt = alpha * x^beta * (rho0/rho)^gamma
907  alpha_v(i_mp_qc,:)= 3.75e+5_rp
908  alpha_v(i_mp_qr,:)= 159.0_rp ! not for sedimantation
909  alpha_v(i_mp_qi,:)= 317.0_rp
910  alpha_v(i_mp_qs,:)= 27.70_rp
911  alpha_v(i_mp_qg,:)= 40.0_rp
912  beta_v(i_mp_qc,:) = 2.0_rp/3.0_rp
913  beta_v(i_mp_qr,:) = 0.266_rp ! not for sedimantation
914  beta_v(i_mp_qi,:) = 0.363_rp
915  beta_v(i_mp_qs,:) = 0.216_rp
916  beta_v(i_mp_qg,:) = 0.230_rp
917  gamma_v(i_mp_qc) = 1.0_rp
918  ! This is high Reynolds number limit(Beard 1980)
919  gamma_v(i_mp_qr) = 1.0_rp/2.0_rp
920  gamma_v(i_mp_qi) = 1.0_rp/2.0_rp
921  gamma_v(i_mp_qs) = 1.0_rp/2.0_rp
922  gamma_v(i_mp_qg) = 1.0_rp/2.0_rp
923  !----------------------------------------------------------
924  ! DSD parameters
925  ! f(x) = A x^nu exp( -lambda x^mu )
926  ! Gamma Disribution : mu=1 , nu:arbitrary
927  ! Marshall-Palmer Distribution: mu=1/3, nu:-2/3
928  ! In the case of MP, f(D) dD = f(x)dx
929  ! f(x) = c * f(D)/D^2 (c:coefficient)
930  nu(i_mp_qc) = 1.0_rp ! arbitrary for Gamma
931  nu(i_mp_qr) = -1.0_rp/3.0_rp ! nu(diameter)=1, equilibrium condition.
932  nu(i_mp_qi) = 1.0_rp !
933  nu(i_mp_qs) = 1.0_rp !
934  nu(i_mp_qg) = 1.0_rp !
935  !
936  mu(i_mp_qc) = 1.0_rp ! Gamma
937  mu(i_mp_qr) = 1.0_rp/3.0_rp ! Marshall Palmer
938  mu(i_mp_qi) = 1.0_rp/3.0_rp !
939  mu(i_mp_qs) = 1.0_rp/3.0_rp !
940  mu(i_mp_qg) = 1.0_rp/3.0_rp !
941  !----------------------------------------------------------
942  ! Geomeries for diffusion growth
943  ! Pruppacher and Klett(1997), (13-77)-(13-80) and
944  ! originally derived by McDonald(1963b)
945  ! sphere: cap=2
946  ! plate : cap=pi
947  ! needle with aspect ratio a/b
948  ! : cap=log(2*a/b)
949  cap(i_mp_qc) = 2.0_rp ! sphere
950  cap(i_mp_qr) = 2.0_rp ! sphere
951  cap(i_mp_qi) = pi ! hexagonal plate
952  cap(i_mp_qs) = 2.0_rp ! mix aggregates
953  cap(i_mp_qg) = 2.0_rp ! lump
954  !
955  alpha_vn(:,:) = alpha_v(:,:)
956  beta_vn(:,:) = beta_v(:,:)
957  !------------------------------------------------------------------------
958  !
959  ! additional setting
960  !
961 
962  !--- read namelist
963  rewind(io_fid_conf)
964  read(io_fid_conf,nml=nm_mp_sn14_particles,iostat=ierr)
965 
966  if( ierr < 0 ) then !--- missing
967  if( io_l ) write(io_fid_log,*) '*** Not found namelist. Default used.'
968  elseif( ierr > 0 ) then !--- fatal error
969  write(*,*) 'xxx Not appropriate names in namelist nm_mp_sn14_particles. Check!'
970  call prc_mpistop
971  endif
972  if( io_nml ) write(io_fid_nml,nml=nm_mp_sn14_particles)
973 
974  ! [Add] 10/08/03 T.Mitsui
975  ! particles shapes are
976  if( opt_m96_ice ) then
977  ! ice is randomly oriented Hexagonal plate (Auer and Veal 1970, Takano and Liou 1995, Mitchell 1996)
978  ! snow is assemblages of planar polycrystals(Mitchell 1996)
979  ! graupel is Lump graupel(R4b) is assumed(Mitchell 1996)
980  a_area(i_mp_qi) = 0.120284936_rp
981  a_area(i_mp_qs) = 0.131488_rp
982  a_area(i_mp_qg) = 0.5_rp
983  b_area(i_mp_qi) = 1.850000_rp
984  b_area(i_mp_qs) = 1.880000_rp
985  b_area(i_mp_qg) = 2.0_rp
986  a_m(i_mp_qi) = 1.23655360084766_rp
987  a_m(i_mp_qs) = a_m(i_mp_qi)
988  a_m(i_mp_qg) = 0.346111225718402_rp
989  b_m(i_mp_qi) = 0.408329930583912_rp
990  b_m(i_mp_qs) = b_m(i_mp_qi)
991  b_m(i_mp_qg) = 0.357142857142857_rp
992  !
993  if( opt_m96_column_ice )then
994  d0_ni=240.49e-6_rp ! this is column
995  d0_li=330.09e-6_rp ! this is column
996  a_area(i_mp_qi)= (0.684_rp*1.e-4_rp)*10.0_rp**(2.0_rp*2.00_rp)
997  b_area(i_mp_qi)= 2.0_rp
998  a_m(i_mp_qi) = 0.19834046116844_rp
999  b_m(i_mp_qi) = 0.343642611683849_rp
1000  ! [Add] 11/08/30 T.Mitsui
1001  ! approximated by the capacity for prolate spheroid with constant aspect ratio
1002  wcap1 = sqrt(1.0_rp-ar_ice_fix**2)
1003  wcap2 = log( (1.0_rp+wcap1)/ar_ice_fix )
1004  cap(i_mp_qi) = 2.0_rp*wcap2/wcap1
1005  !
1006  end if
1007  !
1008  ! These value are derived by least-square fitting in the range
1009  ! qi [100um:1000um] in diameter
1010  ! qs [100um:1000um] in diameter
1011  ! qg [200um:2000um] in diameter
1012  ! small branch , large branch
1013  alpha_v(i_mp_qi,:) =(/ 5798.60107421875_rp, 167.347076416016_rp/)
1014  alpha_vn(i_mp_qi,:) =(/ 12408.177734375_rp, 421.799865722656_rp/)
1015  if( opt_m96_column_ice )then
1016  alpha_v(i_mp_qi,:) = (/2901.0_rp, 32.20_rp/)
1017  alpha_vn(i_mp_qi,:) = (/9675.2_rp, 64.16_rp/)
1018  end if
1019  alpha_v(i_mp_qs,:) =(/ 15173.3916015625_rp, 305.678619384766_rp/)
1020  alpha_vn(i_mp_qs,:) =(/ 29257.1601562500_rp, 817.985717773438_rp/)
1021  alpha_v(i_mp_qg,:) =(/ 15481.6904296875_rp, 311.642242431641_rp/)
1022  alpha_vn(i_mp_qg,:) =(/ 27574.6562500000_rp, 697.536132812500_rp/)
1023  !
1024  beta_v(i_mp_qi,:) =(/ 0.504873454570770_rp, 0.324817866086960_rp/)
1025  beta_vn(i_mp_qi,:) =(/ 0.548495233058929_rp, 0.385287821292877_rp/)
1026  if( opt_m96_column_ice )then
1027  beta_v(i_mp_qi,:) =(/ 0.465552181005478_rp, 0.223826110363007_rp/)
1028  beta_vn(i_mp_qi,:) =(/ 0.530453503131866_rp, 0.273761242628098_rp/)
1029  end if
1030  beta_v(i_mp_qs,:) =(/ 0.528109610080719_rp, 0.329863965511322_rp/)
1031  beta_vn(i_mp_qs,:) =(/ 0.567154467105865_rp, 0.393876969814301_rp/)
1032  beta_v(i_mp_qg,:) =(/ 0.534656763076782_rp, 0.330253750085831_rp/)
1033  beta_vn(i_mp_qg,:) =(/ 0.570551633834839_rp, 0.387124240398407_rp/)
1034  end if
1035  !
1036  ! area-diameter relation => area-mass relation
1037  ax_area(:) = a_area(:)*a_m(:)**b_area(:)
1038  bx_area(:) = b_area(:)*b_m(:)
1039  !
1040  ! radius of equivalent area - m ass relation
1041  ! pi*rea**2 = ax_area*x**bx_area
1042  a_rea(:) = sqrt(ax_area(:)/pi)
1043  b_rea(:) = bx_area(:)/2.0_rp
1044  a_rea2(:) = a_rea(:)**2
1045  b_rea2(:) = b_rea(:)*2.0_rp
1046  a_rea3(:) = a_rea(:)**3
1047  b_rea3(:) = b_rea(:)*3.0_rp
1048  !
1049  a_d2vt(:)=alpha_v(:,2)*(1.0_rp/alpha_v(:,2))**(beta_v(:,2)/b_m(:))
1050  b_d2vt(:)=(beta_v(:,2)/b_m(:))
1051  !
1052  ! Calculation of Moment Coefficient
1053  !
1054  w1(:) = 0.0_rp
1055  w2(:) = 0.0_rp
1056  w3(:) = 0.0_rp
1057  w4(:) = 0.0_rp
1058  w5(:) = 0.0_rp
1059  w6(:) = 0.0_rp
1060  w7(:) = 0.0_rp
1061  w8(:) = 0.0_rp
1062  !-------------------------------------------------------
1063  ! moment coefficient
1064  ! SB06 (82)
1065  ! M^n /= coef_mn * N * (L/N)**n
1066  ! M^2 = Z = coef_m2 * N *(L/N)**2
1067  ! a*M^b = a*integral x^b f(x) dx = ave D
1068  do iw=1, hydro_max
1069  n = 2
1070  w1(iw) = gammafunc( (n+nu(iw)+1.0_rp)/mu(iw) )
1071  w2(iw) = gammafunc( (nu(iw)+1.0_rp)/mu(iw) )
1072  w3(iw) = gammafunc( (nu(iw)+2.0_rp)/mu(iw) )
1073  coef_m2(iw) = w1(iw)/w2(iw)*( w2(iw)/w3(iw) )**n
1074  !
1075  w4(iw) = gammafunc( (b_m(iw)+nu(iw)+1.0_rp)/mu(iw) )
1076  coef_d(iw) = a_m(iw) * w4(iw)/w2(iw)*( w2(iw)/w3(iw) )**b_m(iw)
1077  w5(iw) = gammafunc( (2.0_rp*b_m(iw)+beta_v(iw,2)+nu(iw)+1.0_rp)/mu(iw) )
1078  w6(iw) = gammafunc( (3.0_rp*b_m(iw)+beta_v(iw,2)+nu(iw)+1.0_rp)/mu(iw) )
1079  coef_d2v(iw) = a_m(iw) * w6(iw)/w5(iw)* ( w2(iw)/w3(iw) )**b_m(iw)
1080  coef_md2v(iw)= w5(iw)/w2(iw)* ( w2(iw)/w3(iw) )**(2.0_rp*b_m(iw)+beta_v(iw,2))
1081  ! 09/04/14 [Add] T.Mitsui, volume and radar reflectivity
1082  w7(iw) = gammafunc( (3.0_rp*b_m(iw)+nu(iw)+1.0_rp)/mu(iw) )
1083  coef_d3(iw) = a_m(iw)**3 * w7(iw)/w2(iw)*( w2(iw)/w3(iw) )**(3.0_rp*b_m(iw))
1084  w8(iw) = gammafunc( (6.0_rp*b_m(iw)+nu(iw)+1.0_rp)/mu(iw) )
1085  coef_d6(iw) = a_m(iw)**6 * w8(iw)/w2(iw)*( w2(iw)/w3(iw) )**(6.0_rp*b_m(iw))
1086  end do
1087  !
1088  coef_deplc = coef_d(i_mp_qc)/a_m(i_mp_qc)
1089  !-------------------------------------------------------
1090  ! coefficient of 2nd and 3rd moments for effective radius
1091  ! for spherical particle
1092  do iw=1, hydro_max
1093  ! integ r^2 f(x)dx
1094  w1(iw) = gammafunc( (2.0_rp*b_m(iw)+nu(iw)+1.0_rp)/mu(iw) )
1095  w2(iw) = gammafunc( (nu(iw)+1.0_rp)/mu(iw) )
1096  w3(iw) = gammafunc( (nu(iw)+2.0_rp)/mu(iw) )
1097  ! integ r^3 f(x)dx
1098  w4(iw) = gammafunc( (3.0_rp*b_m(iw)+nu(iw)+1.0_rp)/mu(iw) )
1099  !
1100  coef_r2(iw)=w1(iw)/w2(iw)*( w2(iw)/w3(iw) )**(2.0_rp*b_m(iw))
1101  coef_r3(iw)=w4(iw)/w2(iw)*( w2(iw)/w3(iw) )**(3.0_rp*b_m(iw))
1102  coef_re(iw)=coef_r3(iw)/coef_r2(iw)
1103  !
1104  end do
1105  !-------------------------------------------------------
1106  ! coefficient for effective radius of equivalent area and
1107  ! coefficient for volume of equivalent area
1108  do iw=1, hydro_max
1109  w1(iw) = gammafunc( (nu(iw)+1.0_rp)/mu(iw) )
1110  w2(iw) = gammafunc( (nu(iw)+2.0_rp)/mu(iw) )
1111  w3(iw) = gammafunc( (b_rea2(iw)+nu(iw)+1.0_rp)/mu(iw) )
1112  w4(iw) = gammafunc( (b_rea3(iw)+nu(iw)+1.0_rp)/mu(iw) )
1113  !
1114  coef_rea2(iw) = w3(iw)/w1(iw)*( w1(iw)/w2(iw) )**b_rea2(iw)
1115  coef_rea3(iw) = w4(iw)/w1(iw)*( w1(iw)/w2(iw) )**b_rea3(iw)
1116  end do
1117  !-------------------------------------------------------
1118  ! coefficient of gamma-distribution
1119  ! SB06(80)
1120  do iw=1, hydro_max
1121  w1(iw) = gammafunc( (nu(iw) + 1.0_rp)/mu(iw) )
1122  w2(iw) = gammafunc( (nu(iw) + 2.0_rp)/mu(iw) )
1123  coef_a(iw) = mu(iw)/w1(iw)
1124 ! slope_A(iw) = w1(iw)
1125  coef_lambda(iw) = (w1(iw)/w2(iw))**(-mu(iw))
1126  end do
1127  !-------------------------------------------------------
1128  ! coefficient for terminal velocity in sedimentation
1129  ! SB06(78)
1130  do ia=1,2
1131  do iw=1, hydro_max
1132  n = 0
1133  w1(iw) = gammafunc( (beta_vn(iw,ia) + nu(iw) + 1.0_rp + n)/mu(iw) )
1134  w2(iw) = gammafunc( ( nu(iw) + 1.0_rp + n)/mu(iw) )
1135  w3(iw) = gammafunc( (nu(iw) + 1.0_rp)/mu(iw) )
1136  w4(iw) = gammafunc( (nu(iw) + 2.0_rp)/mu(iw) )
1137  ! coefficient of terminal velocity for number
1138  coef_vt0(iw,ia)=alpha_vn(iw,ia)*w1(iw)/w2(iw)*(w3(iw)/w4(iw))**beta_vn(iw,ia)
1139  n = 1
1140  w1(iw) = gammafunc( (beta_v(iw,ia) + nu(iw) + 1.0_rp + n)/mu(iw) )
1141  w2(iw) = gammafunc( ( nu(iw) + 1.0_rp + n)/mu(iw) )
1142  ! coefficient of terminal velocity for mass
1143  coef_vt1(iw,ia)=alpha_v(iw,ia)*w1(iw)/w2(iw)*(w3(iw)/w4(iw))**beta_v(iw,ia)
1144  end do
1145  end do
1146  ! coefficient for weighted diameter used in calculation of terminal velocity
1147  do iw=1, hydro_max
1148  w1(iw) = gammafunc( ( b_m(iw) + nu(iw) + 1.0_rp)/mu(iw) )
1149  w2(iw) = gammafunc( (1.0_rp + b_m(iw) + nu(iw) + 1.0_rp)/mu(iw) )
1150  w3(iw) = gammafunc( (nu(iw) + 1.0_rp)/mu(iw) )
1151  w4(iw) = gammafunc( (nu(iw) + 2.0_rp)/mu(iw) )
1152  coef_dave_n(iw) = (w1(iw)/w3(iw))*(w3(iw)/w4(iw))** b_m(iw)
1153  coef_dave_l(iw) = (w2(iw)/w3(iw))*(w3(iw)/w4(iw))**(1.0_rp+b_m(iw))
1154  end do
1155  !-------------------------------------------------------
1156  !
1157  ah_vent(i_mp_qc,1:2) = (/1.0000_rp,1.0000_rp/) ! no effect
1158  ah_vent(i_mp_qr,1:2) = (/1.0000_rp,0.780_rp/)
1159  ah_vent(i_mp_qi,1:2) = (/1.0000_rp,0.860_rp/)
1160  ah_vent(i_mp_qs,1:2) = (/1.0000_rp,0.780_rp/)
1161  ah_vent(i_mp_qg,1:2) = (/1.0000_rp,0.780_rp/)
1162  bh_vent(i_mp_qc,1:2) = (/0.0000_rp,0.0000_rp/)
1163  bh_vent(i_mp_qr,1:2) = (/0.108_rp,0.308_rp/)
1164  bh_vent(i_mp_qi,1:2) = (/0.140_rp,0.280_rp/)
1165  bh_vent(i_mp_qs,1:2) = (/0.108_rp,0.308_rp/)
1166  bh_vent(i_mp_qg,1:2) = (/0.108_rp,0.308_rp/)
1167  !
1168  do iw=1, hydro_max
1169  n = 0
1170  if( (nu(iw) + b_m(iw) + n) > eps_gamma )then
1171  w1(iw) = gammafunc( (nu(iw) + b_m(iw) + n)/mu(iw) )
1172  w2(iw) = gammafunc( (nu(iw) + 1.0_rp)/mu(iw) )
1173  w3(iw) = gammafunc( (nu(iw) + 2.0_rp)/mu(iw) )
1174  ah_vent0(iw,1)= ah_vent(iw,1)*(w1(iw)/w2(iw))*(w2(iw)/w3(iw))**(b_m(iw)+n-1.0_rp)
1175  ah_vent0(iw,2)= ah_vent(iw,2)*(w1(iw)/w2(iw))*(w2(iw)/w3(iw))**(b_m(iw)+n-1.0_rp)
1176  flag_vent0(iw)=.true.
1177  else
1178  ah_vent0(iw,1)= 1.0_rp
1179  ah_vent0(iw,2)= 1.0_rp
1180  flag_vent0(iw)=.false.
1181  end if
1182  n = 1
1183  if( (nu(iw) + b_m(iw) + n) > eps_gamma )then
1184  w1(iw) = gammafunc( (nu(iw) + b_m(iw) + n)/mu(iw) )
1185  w2(iw) = gammafunc( (nu(iw) + 1.0_rp)/mu(iw) )
1186  w3(iw) = gammafunc( (nu(iw) + 2.0_rp)/mu(iw) )
1187  ah_vent1(iw,1)= ah_vent(iw,1)*(w1(iw)/w2(iw))*(w2(iw)/w3(iw))**(b_m(iw)+n-1.0_rp)
1188  ah_vent1(iw,2)= ah_vent(iw,2)*(w1(iw)/w2(iw))*(w2(iw)/w3(iw))**(b_m(iw)+n-1.0_rp)
1189  flag_vent1(iw)=.true.
1190  else
1191  ah_vent1(iw,1)= 1.0_rp
1192  ah_vent1(iw,2)= 1.0_rp
1193  flag_vent1(iw)=.true.
1194  end if
1195  end do
1196  do iw=1, hydro_max
1197  n = 0
1198  if( (nu(iw) + 1.5_rp*b_m(iw) + 0.5_rp*beta_v(iw,1) + n) < eps_gamma )then
1199  flag_vent0(iw)=.false.
1200  end if
1201  if(flag_vent0(iw))then
1202  w1(iw) = gammafunc( (nu(iw) + 1.5_rp*b_m(iw) + 0.5_rp*beta_v(iw,1) + n)/mu(iw) )
1203  w2(iw) = gammafunc( (nu(iw) + 1.0_rp)/mu(iw) )
1204  w3(iw) = gammafunc( (nu(iw) + 2.0_rp)/mu(iw) )
1205  ! [Add] 11/08/30 T.Mitsui
1206  w4(iw) = gammafunc( (nu(iw) + 2.0_rp*b_m(iw) + beta_v(iw,1) + n)/mu(iw) )
1207  bh_vent0(iw,1)=bh_vent(iw,1)*(w4(iw)/w2(iw))*(w2(iw)/w3(iw))**(2.00_rp*b_m(iw)+beta_v(iw,1)+n-1.0_rp)
1208  w5(iw) = gammafunc( (nu(iw) + 1.5_rp*b_m(iw) + 0.5_rp*beta_v(iw,2) + n)/mu(iw) )
1209  bh_vent0(iw,2)=bh_vent(iw,2)*(w5(iw)/w2(iw))*(w2(iw)/w3(iw))**(1.5_rp*b_m(iw)+0.5_rp*beta_v(iw,2)+n-1.0_rp)
1210  else
1211  bh_vent0(iw,1) = 0.0_rp
1212  bh_vent0(iw,2) = 0.0_rp
1213  end if
1214  !
1215  n = 1
1216  if( (nu(iw) + 1.5_rp*b_m(iw) + 0.5_rp*beta_v(iw,1) + n) < eps_gamma )then
1217  flag_vent1(iw)=.false.
1218  end if
1219  if(flag_vent1(iw))then
1220  w1(iw) = gammafunc( (nu(iw) + 1.5_rp*b_m(iw) + 0.5_rp*beta_v(iw,1) + n)/mu(iw) )
1221  w2(iw) = gammafunc( (nu(iw) + 1.0_rp)/mu(iw) )
1222  w3(iw) = gammafunc( (nu(iw) + 2.0_rp)/mu(iw) )
1223  ! [Add] 11/08/30 T.Mitsui
1224  w4(iw) = gammafunc( (nu(iw) + 2.0_rp*b_m(iw) + beta_v(iw,1) + n)/mu(iw) )
1225  bh_vent1(iw,1)=bh_vent(iw,1)*(w4(iw)/w2(iw))*(w2(iw)/w3(iw))**(2.00_rp*b_m(iw)+beta_v(iw,1)+n-1.0_rp)
1226  !
1227  w5(iw) = gammafunc( (nu(iw) + 1.5_rp*b_m(iw) + 0.5_rp*beta_v(iw,2) + n)/mu(iw) )
1228  bh_vent1(iw,2)=bh_vent(iw,2)*(w5(iw)/w2(iw))*(w2(iw)/w3(iw))**(1.5_rp*b_m(iw)+0.5_rp*beta_v(iw,2)+n-1.0_rp)
1229  else
1230  bh_vent1(iw,1) = 0.0_rp
1231  bh_vent1(iw,2) = 0.0_rp
1232  end if
1233  end do
1234  !-------------------------------------------------------
1235  ! coefficient for collision process
1236  ! stochastic coefficient for collision cross section
1237  ! sb06 (90) -- self collection
1238  do iw=1, hydro_max
1239  n = 0
1240  w1(iw) = gammafunc( (2.0_rp*b_rea(iw) + nu(iw) + 1.0_rp + n)/mu(iw) )
1241  w2(iw) = gammafunc( (nu(iw) + 1.0_rp)/mu(iw) )
1242  w3(iw) = gammafunc( (nu(iw) + 2.0_rp)/mu(iw) )
1243  delta_b0(iw) = w1(iw)/w2(iw) &
1244  *( w2(iw)/w3(iw) )**(2.0_rp*b_rea(iw) + n)
1245  n = 1
1246  w1(iw) = gammafunc( (2.0_rp*b_rea(iw) + nu(iw) + 1.0_rp + n)/mu(iw) )
1247  delta_b1(iw) = w1(iw)/w2(iw) &
1248  *( w2(iw)/w3(iw) )**(2.0_rp*b_rea(iw) + n)
1249  end do
1250  ! stochastic coefficient for collision cross section
1251  ! sb06(91) -- riming( collide with others )
1252  do iw=1, hydro_max
1253  n = 0
1254  w1(iw) = gammafunc( (b_rea(iw) + nu(iw) + 1.0_rp + n)/mu(iw) )
1255  w2(iw) = gammafunc( (nu(iw) + 1.0_rp)/mu(iw) )
1256  w3(iw) = gammafunc( (nu(iw) + 2.0_rp)/mu(iw) )
1257  w4(iw) = gammafunc( (b_rea(iw) + nu(iw) + 1.0_rp )/mu(iw) )
1258  n = 1
1259  w5(iw) = gammafunc( (b_rea(iw) + nu(iw) + 1.0_rp + n)/mu(iw) )
1260  end do
1261  ! ia > ib ( larger particles "a" catch smaller particles "b" )
1262  do ia=1, hydro_max
1263  do ib=1, hydro_max
1264  n=0 !
1265  ! NOTE, collected particle has a moment of n.
1266  ! collecting particle has only number(n=0).
1267  delta_ab0(ia,ib) = 2.0_rp*(w1(ib)/w2(ib))*(w4(ia)/w2(ia)) &
1268  * ( w2(ib)/w3(ib) )**(b_rea(ib)+n) &
1269  * ( w2(ia)/w3(ia) )**(b_rea(ia) )
1270  n=1 !
1271  delta_ab1(ia,ib) = 2.0_rp*(w5(ib)/w2(ib))*(w4(ia)/w2(ia)) &
1272  * ( w2(ib)/w3(ib) )**(b_rea(ib)+n) &
1273  * ( w2(ia)/w3(ia) )**(b_rea(ia) )
1274  end do
1275  end do
1276  ! stochastic coefficient for terminal velocity
1277  ! sb06(92) -- self collection
1278  ! assuming equivalent area circle.
1279  do iw=1, hydro_max
1280  n = 0
1281  w1(iw) = gammafunc( (2.0_rp*beta_v(iw,2) + 2.0_rp*b_rea(iw) + nu(iw) + 1.0_rp + n)/mu(iw) )
1282  w2(iw) = gammafunc( ( 2.0_rp*b_rea(iw) + nu(iw) + 1.0_rp + n)/mu(iw) )
1283  w3(iw) = gammafunc( (nu(iw) + 1.0_rp)/mu(iw) )
1284  w4(iw) = gammafunc( (nu(iw) + 2.0_rp)/mu(iw) )
1285  theta_b0(iw) = w1(iw)/w2(iw) * ( w3(iw)/w4(iw) )**(2.0_rp*beta_v(iw,2))
1286  n = 1
1287  w1(iw) = gammafunc( (2.0_rp*beta_v(iw,2) + 2.0_rp*b_rea(iw) + nu(iw) + 1.0_rp + n)/mu(iw) )
1288  w2(iw) = gammafunc( ( 2.0_rp*b_rea(iw) + nu(iw) + 1.0_rp + n)/mu(iw) )
1289  theta_b1(iw) = w1(iw)/w2(iw) * ( w3(iw)/w4(iw) )**(2.0_rp*beta_v(iw,2))
1290  end do
1291  !
1292  ! stochastic coefficient for terminal velocity
1293  ! sb06(93) -- riming( collide with others )
1294  do iw=1, hydro_max
1295  n = 0
1296  w1(iw) = gammafunc( (beta_v(iw,2) + 2.0_rp*b_rea(iw) + nu(iw) + 1.0_rp + n)/mu(iw) )
1297  w2(iw) = gammafunc( ( 2.0_rp*b_rea(iw) + nu(iw) + 1.0_rp + n)/mu(iw) )
1298  w3(iw) = gammafunc( (beta_v(iw,2) + 2.0_rp*b_rea(iw) + nu(iw) + 1.0_rp )/mu(iw) )
1299  w4(iw) = gammafunc( ( 2.0_rp*b_rea(iw) + nu(iw) + 1.0_rp )/mu(iw) )
1300  !
1301  w5(iw) = gammafunc( (nu(iw) + 1.0_rp)/mu(iw) )
1302  w6(iw) = gammafunc( (nu(iw) + 2.0_rp)/mu(iw) )
1303  n = 1
1304  w7(iw) = gammafunc( (beta_v(iw,2) + b_rea(iw) + nu(iw) + 1.0_rp + n)/mu(iw) )
1305  w8(iw) = gammafunc( ( b_rea(iw) + nu(iw) + 1.0_rp + n)/mu(iw) )
1306  end do
1307  ! ia > ib ( larger particles "a" catch smaller particles "b" )
1308  do ia=1, hydro_max
1309  do ib=1, hydro_max
1310  theta_ab0(ia,ib) = 2.0_rp * (w1(ib)/w2(ib))*(w3(ia)/w4(ia)) &
1311  * (w5(ia)/w6(ia))**beta_v(ia,2) &
1312  * (w5(ib)/w6(ib))**beta_v(ib,2)
1313  theta_ab1(ia,ib) = 2.0_rp * (w7(ib)/w8(ib))*(w3(ia)/w4(ia)) &
1314  * (w5(ia)/w6(ia))**beta_v(ia,2) &
1315  * (w5(ib)/w6(ib))**beta_v(ib,2)
1316  end do
1317  end do
1318 
1319  if( io_l ) write(io_fid_log,'(100a16)') "LABEL ",wlabel(:)
1320  if( io_l ) write(io_fid_log,'(a,100ES16.6)') "capacity ",cap(:) ! [Add] 11/08/30 T.Mitsui
1321  if( io_l ) write(io_fid_log,'(a,100ES16.6)') "coef_m2 ",coef_m2(:)
1322  if( io_l ) write(io_fid_log,'(a,100ES16.6)') "coef_d ",coef_d(:)
1323  !
1324  if( io_l ) write(io_fid_log,'(a,100ES16.6)') "coef_d3 ",coef_d3(:)
1325  if( io_l ) write(io_fid_log,'(a,100ES16.6)') "coef_d6 ",coef_d6(:)
1326  if( io_l ) write(io_fid_log,'(a,100ES16.6)') "coef_d2v ",coef_d2v(:)
1327  if( io_l ) write(io_fid_log,'(a,100ES16.6)') "coef_md2v ",coef_md2v(:)
1328  if( io_l ) write(io_fid_log,'(a,100ES16.6)') "a_d2vt ",a_d2vt(:)
1329  if( io_l ) write(io_fid_log,'(a,100ES16.6)') "b_d2vt ",b_d2vt(:)
1330  !
1331  if( io_l ) write(io_fid_log,'(a,100ES16.6)') "coef_r2 ",coef_r2(:)
1332  if( io_l ) write(io_fid_log,'(a,100ES16.6)') "coef_r3 ",coef_r3(:)
1333  if( io_l ) write(io_fid_log,'(a,100ES16.6)') "coef_re ",coef_re(:)
1334  !
1335  if( io_l ) write(io_fid_log,'(a,100ES16.6)') "a_area ",a_area(:)
1336  if( io_l ) write(io_fid_log,'(a,100ES16.6)') "b_area ",b_area(:)
1337  if( io_l ) write(io_fid_log,'(a,100ES16.6)') "ax_area ",ax_area(:)
1338  if( io_l ) write(io_fid_log,'(a,100ES16.6)') "bx_area ",bx_area(:)
1339  if( io_l ) write(io_fid_log,'(a,100ES16.6)') "a_rea ",a_rea(:)
1340  if( io_l ) write(io_fid_log,'(a,100ES16.6)') "b_rea ",b_rea(:)
1341  if( io_l ) write(io_fid_log,'(a,100ES16.6)') "a_rea3 ",a_rea3(:)
1342  if( io_l ) write(io_fid_log,'(a,100ES16.6)') "b_rea3 ",b_rea3(:)
1343  !
1344  if( io_l ) write(io_fid_log,'(a,100ES16.6)') "coef_rea2 ",coef_rea2(:)
1345  if( io_l ) write(io_fid_log,'(a,100ES16.6)') "coef_rea3 ",coef_rea3(:)
1346  if( io_l ) write(io_fid_log,'(a,100ES16.6)') "coef_vt0 ",coef_vt0(:,1)
1347  if( io_l ) write(io_fid_log,'(a,100ES16.6)') "coef_vt1 ",coef_vt1(:,1)
1348  if( io_l ) write(io_fid_log,'(a,100ES16.6)') "coef_A ",coef_a(:)
1349  if( io_l ) write(io_fid_log,'(a,100ES16.6)') "coef_lambda ",coef_lambda(:)
1350 
1351  if( io_l ) write(io_fid_log,'(a,100ES16.6)') "ah_vent0 sml",ah_vent0(:,1)
1352  if( io_l ) write(io_fid_log,'(a,100ES16.6)') "ah_vent0 lrg",ah_vent0(:,2)
1353  if( io_l ) write(io_fid_log,'(a,100ES16.6)') "ah_vent1 sml",ah_vent1(:,1)
1354  if( io_l ) write(io_fid_log,'(a,100ES16.6)') "ah_vent1 lrg",ah_vent1(:,2)
1355  if( io_l ) write(io_fid_log,'(a,100ES16.6)') "bh_vent0 sml",bh_vent0(:,1)
1356  if( io_l ) write(io_fid_log,'(a,100ES16.6)') "bh_vent0 lrg",bh_vent0(:,2)
1357  if( io_l ) write(io_fid_log,'(a,100ES16.6)') "bh_vent1 sml",bh_vent1(:,1)
1358  if( io_l ) write(io_fid_log,'(a,100ES16.6)') "bh_vent1 lrg",bh_vent1(:,2)
1359 
1360  if( io_l ) write(io_fid_log,'(a,100ES16.6)') "delta_b0 ",delta_b0(:)
1361  if( io_l ) write(io_fid_log,'(a,100ES16.6)') "delta_b1 ",delta_b1(:)
1362  if( io_l ) write(io_fid_log,'(a,100ES16.6)') "theta_b0 ",theta_b0(:)
1363  if( io_l ) write(io_fid_log,'(a,100ES16.6)') "theta_b1 ",theta_b1(:)
1364 
1365  do ia=1, hydro_max
1366  if( io_l ) write(io_fid_log,'(a,a10,a,100ES16.6)') "delta0(a,b)=(",trim(wlabel(ia)),",b)=",(delta_ab0(ia,ib),ib=1,hydro_max)
1367  enddo
1368  do ia=1, hydro_max
1369  if( io_l ) write(io_fid_log,'(a,a10,a,100ES16.6)') "delta1(a,b)=(",trim(wlabel(ia)),",b)=",(delta_ab1(ia,ib),ib=1,hydro_max)
1370  enddo
1371  do ia=1, hydro_max
1372  if( io_l ) write(io_fid_log,'(a,a10,a,100ES16.6)') "theta0(a,b)=(",trim(wlabel(ia)),",b)=",(theta_ab0(ia,ib),ib=1,hydro_max)
1373  enddo
1374  do ia=1, hydro_max
1375  if( io_l ) write(io_fid_log,'(a,a10,a,100ES16.6)') "theta1(a,b)=(",trim(wlabel(ia)),",b)=",(theta_ab1(ia,ib),ib=1,hydro_max)
1376  enddo
1377 
1378  return
1379  end subroutine mp_sn14_init
1380  !-----------------------------------------------------------------------------
1381  subroutine mp_sn14 ( &
1382  DENS, &
1383  MOMZ, &
1384  MOMX, &
1385  MOMY, &
1386  RHOT, &
1387  QTRC, &
1388  CCN, &
1389  EVAPORATE, &
1390  SFLX_rain, &
1391  SFLX_snow )
1392  use scale_time, only: &
1393  dt_dp => time_dtsec_atmos_phy_mp
1394  use scale_grid, only: &
1395  z => grid_cz, &
1396  dz => grid_cdz
1397  use scale_tracer, only: &
1398  qa, &
1399  tracer_r, &
1400  tracer_cv, &
1401  tracer_mass
1402  use scale_atmos_saturation, only: &
1403  moist_psat_liq => atmos_saturation_psat_liq, &
1404  moist_psat_ice => atmos_saturation_psat_ice
1405  use scale_atmos_phy_mp_common, only: &
1406  mp_precipitation => atmos_phy_mp_precipitation
1407  use scale_history, only: &
1408  hist_in
1409  implicit none
1410 
1411  real(RP), intent(inout) :: dens (ka,ia,ja)
1412  real(RP), intent(inout) :: momz (ka,ia,ja)
1413  real(RP), intent(inout) :: momx (ka,ia,ja)
1414  real(RP), intent(inout) :: momy (ka,ia,ja)
1415  real(RP), intent(inout) :: rhot (ka,ia,ja)
1416  real(RP), intent(inout) :: qtrc (ka,ia,ja,qa)
1417  real(RP), intent(in) :: ccn (ka,ia,ja)
1418  real(RP), intent(out) :: evaporate(ka,ia,ja) ! number of evaporated cloud [/m3/s]
1419  real(RP), intent(out) :: sflx_rain(ia,ja)
1420  real(RP), intent(out) :: sflx_snow(ia,ja)
1421 
1422  !
1423  ! primary variables
1424  !
1425  real(RP) :: rhoq(i_qv:i_ng,ka,ia,ja)
1426  real(RP) :: pott (ka,ia,ja)
1427  !
1428  ! diagnostic variables
1429  !
1430  real(RP) :: qdry(ka,ia,ja)
1431  real(RP) :: temp(ka,ia,ja)
1432  real(RP) :: pres(ka,ia,ja)
1433  real(RP) :: rhoe(ka,ia,ja)
1434  real(RP) :: velz(ka,ia,ja)
1435  !
1436  real(RP) :: rhoq2(i_qv:i_ng,ka,ia,ja)
1437  !
1438  real(RP) :: xq(hydro_max,ka,ia,ja)
1439  !
1440  real(RP) :: dq_xa(hydro_max,ka,ia,ja)
1441  real(RP) :: vt_xa(hydro_max,2,ka,ia,ja) ! terminal velocity
1442 
1443  real(RP) :: wtemp(ka,ia,ja) ! filtered temperature
1444  real(RP) :: esw(ka,ia,ja) ! saturated vapor pressure(water)
1445  real(RP) :: esi(ka,ia,ja) ! saturated vapor pressure(ice)
1446  !
1447  real(RP) :: rho_fac
1448  real(RP) :: rho_fac_q(hydro_max,ka,ia,ja) ! factor for tracers, 1:cloud, 2:rain, 3:ice, 4: snow, 5:graupel
1449  real(RP) :: cva(ka,ia,ja) !
1450  real(RP) :: cpa(ka,ia,ja) ! [Add] 09/08/18 T.Mitsui
1451  !
1452  real(RP) :: drhogqv ! d (rho*qv*gsgam2)
1453  real(RP) :: drhogqc, drhognc ! qc, nc
1454  real(RP) :: drhogqr, drhognr ! qr, nr
1455  real(RP) :: drhogqi, drhogni ! qi, ni
1456  real(RP) :: drhogqs, drhogns ! qs, ns
1457  real(RP) :: drhogqg, drhogng ! qg, ng
1458 
1459  ! production rate
1460  real(RP) :: pq(pq_max,ka,ia,ja)
1461 
1462  real(RP) :: wrm_dqc, wrm_dnc
1463  real(RP) :: wrm_dqr, wrm_dnr
1464 
1465  ! production rate of mixed-phase collection process
1466  real(RP) :: pac(pac_max,ka,ia,ja)
1467 
1468  real(RP) :: gc_dqc, gc_dnc
1469  real(RP) :: sc_dqc, sc_dnc
1470  real(RP) :: ic_dqc, ic_dnc
1471  real(RP) :: rg_dqg, rg_dng
1472  real(RP) :: rg_dqr, rg_dnr
1473  real(RP) :: rs_dqr, rs_dnr, rs_dqs, rs_dns
1474  real(RP) :: ri_dqr, ri_dnr
1475  real(RP) :: ri_dqi, ri_dni
1476  real(RP) :: ii_dqi, ii_dni
1477  real(RP) :: is_dqi, is_dni, ss_dns
1478  real(RP) :: gs_dqs, gs_dns, gg_dng
1479  ! mixed-phase collection process total plus(clp_), total minus(clm_)
1480  real(RP) :: clp_dqc, clp_dnc, clm_dqc, clm_dnc
1481  real(RP) :: clp_dqr, clp_dnr, clm_dqr, clm_dnr
1482  real(RP) :: clp_dqi, clp_dni, clm_dqi, clm_dni
1483  real(RP) :: clp_dqs, clp_dns, clm_dqs, clm_dns
1484  real(RP) :: clp_dqg, clp_dng, clm_dqg, clm_dng
1485  real(RP) :: fac1, fac3, fac4, fac6, fac7, fac9, fac10
1486  ! production rate of partial conversion(ice, snow => graupel)
1487  real(RP) :: pco_dqi, pco_dni
1488  real(RP) :: pco_dqs, pco_dns
1489  real(RP) :: pco_dqg, pco_dng
1490  ! production rate of enhanced melting due to
1491  real(RP) :: eml_dqc, eml_dnc
1492  real(RP) :: eml_dqr, eml_dnr
1493  real(RP) :: eml_dqi, eml_dni
1494  real(RP) :: eml_dqs, eml_dns
1495  real(RP) :: eml_dqg, eml_dng
1496  ! production rate of ice multiplication by splintering
1497  real(RP) :: spl_dqi, spl_dni
1498  real(RP) :: spl_dqg, spl_dqs
1499 
1500  real(RP) :: rrho(ka,ia,ja)
1501 
1502  !-----------------------------------------------
1503  ! work for explicit supersaturation modeling
1504  !-----------------------------------------------
1505  real(RP) :: dtdt_equiv_d(ka,ia,ja) !
1506  !--------------------------------------------------
1507  !
1508  ! variables for output
1509  !
1510  !--------------------------------------------------
1511  ! work for column production term
1512  real(RP) :: sl_plcdep(ia,ja)
1513  real(RP) :: sl_plrdep(ia,ja), sl_pnrdep(ia,ja) !
1514  !--------------------------------------------------
1515  real(RP) :: qke_d(ka,ia,ja)
1516 
1517  real(RP), parameter :: eps = 1.e-19_rp
1518  real(RP), parameter :: eps_qv = 1.e-19_rp
1519  real(RP), parameter :: eps_rhoge = 1.e-19_rp
1520  real(RP), parameter :: eps_rhog = 1.e-19_rp
1521  integer :: ntdiv
1522 
1523  real(RP) :: rmoist
1524 
1525  real(RP) :: vterm (ka,ia,ja,qa_mp-1) ! terminal velocity of each tracer [m/s]
1526  real(RP) :: pflux (ka,ia,ja,qa_mp-1) ! precipitation flux of each tracer [kg/m2/s]
1527  real(RP) :: flx_hydro(ka,ia,ja,qa_mp-1)
1528  integer :: step
1529 
1530  real(RP) :: sw
1531  real(RP) :: dt
1532 
1533  integer :: k, i, j, iq
1534  !---------------------------------------------------------------------------
1535 
1536  !============================================================================
1537  !
1538  !-- Each process is integrated sequentially.
1539  ! 1. Nucleation and filter
1540  ! 2. Phase change
1541  ! 3. Collection
1542  ! 4. Saturation adjustment( only for qc, nc )
1543  ! 5. Sedimentation
1544  ! 6. filter( keep non-negative value for radiation scheme )
1545  ! 0. calculation of optical moments
1546  !
1547  !============================================================================
1548 
1549  dt = real(dt_dp,kind=rp)
1550 
1551  !----------------------------------------------------------------------------
1552  !
1553  ! 1.Nucleation of cloud water and cloud ice
1554  !
1555  !----------------------------------------------------------------------------
1556  call prof_rapstart('MP_Preprocess', 3)
1557 
1558  do j = js, je
1559  do i = is, ie
1560  do k = ks, ke
1561  do iq = i_qv, i_ng
1562  rhoq(iq,k,i,j) = dens(k,i,j) * qtrc(k,i,j,iq)
1563  enddo
1564  rhoq2(i_qv,k,i,j) = dens(k,i,j)*qtrc(k,i,j,i_qv)
1565  rhoq2(i_ni,k,i,j) = max( 0.0_rp, dens(k,i,j)*qtrc(k,i,j,i_ni) )
1566  rhoq2(i_nc,k,i,j) = max( 0.0_rp, dens(k,i,j)*qtrc(k,i,j,i_nc) )
1567  enddo
1568  enddo
1569  enddo
1570 
1571  do j = js, je
1572  do i = is, ie
1573  velz(ks-1,i,j) = 0.0_rp
1574  do k = ks, ke-1
1575  velz(k,i,j) = momz(k,i,j) / ( dens(k,i,j) + dens(k+1,i,j) ) * 2.0_rp
1576  enddo
1577  velz(ke,i,j) = 0.0_rp
1578  end do
1579  end do
1580 
1581  do j = js, je
1582  do i = is, ie
1583  do k = ks, ke
1584  rrho(k,i,j) = 1.0_rp / dens(k,i,j)
1585  pott(k,i,j) = rhot(k,i,j) * rrho(k,i,j)
1586  calc_qdry( qdry(k,i,j), qtrc, tracer_mass, k, i, j, iq )
1587  calc_cv( cva(k,i,j), qdry(k,i,j), qtrc, k, i, j, iq, cvdry, tracer_cv )
1588  calc_r( rmoist, qdry(k,i,j), qtrc, k, i, j, iq, rdry, tracer_r )
1589  cpa(k,i,j) = cva(k,i,j) + rmoist
1590  calc_pre( pres(k,i,j), dens(k,i,j), pott(k,i,j), rmoist, cpa(k,i,j), p00 )
1591  temp(k,i,j) = pres(k,i,j) / ( dens(k,i,j) * rmoist )
1592  rhoe(k,i,j) = dens(k,i,j) * temp(k,i,j) * cva(k,i,j)
1593  wtemp(k,i,j) = max(temp(k,i,j), tem_min)
1594  enddo
1595  enddo
1596  enddo
1597 
1598  if( opt_debug_tem ) call debug_tem_kij( 1, temp(:,:,:), dens(:,:,:), pres(:,:,:), qtrc(:,:,:,i_qv) )
1599 
1600  do j = js, je
1601  do i = is, ie
1602  do k = ks, ke
1603  rho_fac = rho_0 / max(dens(k,i,j),rho_min)
1604  rho_fac_q(i_mp_qc,k,i,j) = rho_fac**gamma_v(i_mp_qc)
1605  rho_fac_q(i_mp_qr,k,i,j) = rho_fac**gamma_v(i_mp_qr)
1606  rho_fac_q(i_mp_qi,k,i,j) = (pres(k,i,j)/pre0_vt)**a_pre0_vt * (temp(k,i,j)/tem0_vt)**a_tem0_vt
1607  rho_fac_q(i_mp_qs,k,i,j) = rho_fac_q(i_mp_qi,k,i,j)
1608  rho_fac_q(i_mp_qg,k,i,j) = rho_fac_q(i_mp_qi,k,i,j)
1609  enddo
1610  enddo
1611  enddo
1612 
1613 !OCL XFILL
1614  do j = js, je
1615  do i = is, ie
1616  sl_plcdep(i,j) = 0.0_rp
1617  sl_plrdep(i,j) = 0.0_rp
1618  sl_pnrdep(i,j) = 0.0_rp
1619  end do
1620  end do
1621 
1622 !OCL XFILL
1623  do j = js, je
1624  do i = is, ie
1625  do k = ks, ke
1626  qke_d(k,i,j) = 0.0_rp ! 2*TKE
1627  enddo
1628  enddo
1629  enddo
1630 
1631 !OCL XFILL
1632  do j = js, je
1633  do i = is, ie
1634  do k = ks, ke
1635  dtdt_equiv_d(k,i,j) = 0.0_rp
1636  enddo
1637  enddo
1638  enddo
1639 
1640  call prof_rapend ('MP_Preprocess', 3)
1641 
1642  call prof_rapstart('MP_Nucleation', 3)
1643 
1644  call nucleation_kij( &
1645  z, velz, & ! in
1646  dens, wtemp, pres, & ! in
1647  rhoq2, & ! (in)
1648  pq, & ! out
1649  cpa, & ! in
1650  dtdt_equiv_d, & ! in
1651  qke_d, & ! in
1652  ccn, & ! in
1653  dt ) ! in
1654 
1655  do j = js, je
1656  do i = is, ie
1657  do k = ks, ke
1658  ! nucleation
1659  drhogqc = dt * pq(i_lcccn,k,i,j)
1660  drhognc = dt * pq(i_ncccn,k,i,j)
1661  drhogqi = dt * pq(i_liccn,k,i,j)
1662  drhogni = dt * pq(i_niccn,k,i,j)
1663  drhogqv = max( -rhoq(i_qv,k,i,j), -drhogqc-drhogqi )
1664  fac1 = drhogqv / min( -drhogqc-drhogqi, -eps ) ! limiting coefficient
1665 
1666  rhoq(i_qv,k,i,j) = rhoq(i_qv,k,i,j) + drhogqv
1667  rhoq(i_qc,k,i,j) = max(0.0_rp, rhoq(i_qc,k,i,j) + drhogqc*fac1)
1668  rhoq(i_qi,k,i,j) = max(0.0_rp, rhoq(i_qi,k,i,j) + drhogqi*fac1)
1669  rhoq(i_nc,k,i,j) = max(0.0_rp, rhoq(i_nc,k,i,j) + drhognc)
1670  rhoq(i_ni,k,i,j) = max(0.0_rp, rhoq(i_ni,k,i,j) + drhogni)
1671 
1672  ! cloud number concentration filter
1673  rhoq(i_nc,k,i,j) = min( rhoq(i_nc,k,i,j), nc_uplim_d(1,i,j) )
1674 
1675  rhoe(k,i,j) = rhoe(k,i,j) - lhv * drhogqv + lhf * drhogqi*fac1
1676 
1677  qtrc(k,i,j,i_qv) = rhoq(i_qv,k,i,j) * rrho(k,i,j)
1678  qtrc(k,i,j,i_qc) = rhoq(i_qc,k,i,j) * rrho(k,i,j)
1679  qtrc(k,i,j,i_qi) = rhoq(i_qi,k,i,j) * rrho(k,i,j)
1680  qtrc(k,i,j,i_nc) = rhoq(i_nc,k,i,j) * rrho(k,i,j)
1681  qtrc(k,i,j,i_ni) = rhoq(i_ni,k,i,j) * rrho(k,i,j)
1682 
1683  calc_qdry( qdry(k,i,j), qtrc, tracer_mass, k, i, j, iq )
1684  calc_cv( cva(k,i,j), qdry(k,i,j), qtrc, k, i, j, iq, cvdry, tracer_cv )
1685  calc_r( rmoist, qdry(k,i,j), qtrc, k, i, j, iq, rdry, tracer_r )
1686  temp(k,i,j) = rhoe(k,i,j) / ( dens(k,i,j) * cva(k,i,j) )
1687  pres(k,i,j) = dens(k,i,j) * rmoist * temp(k,i,j)
1688  wtemp(k,i,j) = max( temp(k,i,j), tem_min )
1689  enddo
1690  enddo
1691  enddo
1692 
1693 ! if( opt_debug ) call debugreport_nucleation
1694  if( opt_debug_tem ) call debug_tem_kij( 2, temp(:,:,:), dens(:,:,:), pres(:,:,:), qtrc(:,:,:,i_qv) )
1695 
1696 
1697  call prof_rapend ('MP_Nucleation', 3)
1698  !----------------------------------------------------------------------------
1699  !
1700  ! 2.Phase change: Freezing, Melting, Vapor deposition
1701  !
1702  !----------------------------------------------------------------------------
1703  call prof_rapstart('MP_Phase_change', 3)
1704 
1705  do j = js, je
1706  do i = is, ie
1707  do k = ks, ke
1708  rhoq2(i_qr,k,i,j) = rhoq(i_qr,k,i,j)
1709  rhoq2(i_nr,k,i,j) = rhoq(i_nr,k,i,j)
1710  xq(i_mp_qr,k,i,j) = max(xr_min, min(xr_max, rhoq2(i_qr,k,i,j)/(rhoq2(i_nr,k,i,j)+nr_min) ))
1711 
1712  dq_xa(i_mp_qr,k,i,j) = a_m(i_mp_qr)*xq(i_mp_qr,k,i,j)**b_m(i_mp_qr)
1713  vt_xa(i_mp_qr,1,k,i,j) = alpha_v(i_mp_qr,1)*(xq(i_mp_qr,k,i,j)**beta_v(i_mp_qr,1))*rho_fac_q(i_mp_qr,k,i,j)
1714  vt_xa(i_mp_qr,2,k,i,j) = vt_xa(i_mp_qr,1,k,i,j)
1715 
1716  !! Following values shoud be already filtered to be non-zero before sbroutine was called.
1717  ! Mass concentration [kg/m3]
1718  rhoq2(i_qv,k,i,j) = rhoq(i_qv,k,i,j)
1719  rhoq2(i_qc,k,i,j) = rhoq(i_qc,k,i,j)
1720  rhoq2(i_qi,k,i,j) = rhoq(i_qi,k,i,j)
1721  rhoq2(i_qs,k,i,j) = rhoq(i_qs,k,i,j)
1722  rhoq2(i_qg,k,i,j) = rhoq(i_qg,k,i,j)
1723  ! Number concentration[/m3] (should be filtered to avoid zero division.)
1724  rhoq2(i_nc,k,i,j) = rhoq(i_nc,k,i,j)
1725  rhoq2(i_ni,k,i,j) = rhoq(i_ni,k,i,j)
1726  rhoq2(i_ns,k,i,j) = rhoq(i_ns,k,i,j)
1727  rhoq2(i_ng,k,i,j) = rhoq(i_ng,k,i,j)
1728 
1729  ! Mass of mean particle [kg]
1730  ! SB06(94)
1731  !
1732  xq(i_mp_qc,k,i,j) = min(xc_max, max(xc_min, rhoq2(i_qc,k,i,j)/(rhoq2(i_nc,k,i,j)+nc_min) ))
1733  xq(i_mp_qi,k,i,j) = min(xi_max, max(xi_min, rhoq2(i_qi,k,i,j)/(rhoq2(i_ni,k,i,j)+ni_min) ))
1734  xq(i_mp_qs,k,i,j) = min(xs_max, max(xs_min, rhoq2(i_qs,k,i,j)/(rhoq2(i_ns,k,i,j)+ns_min) ))
1735  xq(i_mp_qg,k,i,j) = min(xg_max, max(xg_min, rhoq2(i_qg,k,i,j)/(rhoq2(i_ng,k,i,j)+ng_min) ))
1736  ! diamter of average mass
1737  ! SB06(32)
1738  dq_xa(i_mp_qc,k,i,j) = a_m(i_mp_qc)*xq(i_mp_qc,k,i,j)**b_m(i_mp_qc)
1739  dq_xa(i_mp_qi,k,i,j) = a_m(i_mp_qi)*xq(i_mp_qi,k,i,j)**b_m(i_mp_qi)
1740  dq_xa(i_mp_qs,k,i,j) = a_m(i_mp_qs)*xq(i_mp_qs,k,i,j)**b_m(i_mp_qs)
1741  dq_xa(i_mp_qg,k,i,j) = a_m(i_mp_qg)*xq(i_mp_qg,k,i,j)**b_m(i_mp_qg)
1742 
1743  ! terminal velocity of average mass
1744  vt_xa(i_mp_qc,1,k,i,j) = alpha_v(i_mp_qc,1)*(xq(i_mp_qc,k,i,j)**beta_v(i_mp_qc,1))*rho_fac_q(i_mp_qc,k,i,j)
1745  vt_xa(i_mp_qi,1,k,i,j) = alpha_v(i_mp_qi,1)*(xq(i_mp_qi,k,i,j)**beta_v(i_mp_qi,1))*rho_fac_q(i_mp_qi,k,i,j)
1746  vt_xa(i_mp_qs,1,k,i,j) = alpha_v(i_mp_qs,1)*(xq(i_mp_qs,k,i,j)**beta_v(i_mp_qs,1))*rho_fac_q(i_mp_qs,k,i,j)
1747  vt_xa(i_mp_qg,1,k,i,j) = alpha_v(i_mp_qg,1)*(xq(i_mp_qg,k,i,j)**beta_v(i_mp_qg,1))*rho_fac_q(i_mp_qg,k,i,j)
1748  vt_xa(i_mp_qc,2,k,i,j) = alpha_v(i_mp_qc,2)*(xq(i_mp_qc,k,i,j)**beta_v(i_mp_qc,2))*rho_fac_q(i_mp_qc,k,i,j)
1749  vt_xa(i_mp_qi,2,k,i,j) = alpha_v(i_mp_qi,2)*(xq(i_mp_qi,k,i,j)**beta_v(i_mp_qi,2))*rho_fac_q(i_mp_qi,k,i,j)
1750  vt_xa(i_mp_qs,2,k,i,j) = alpha_v(i_mp_qs,2)*(xq(i_mp_qs,k,i,j)**beta_v(i_mp_qs,2))*rho_fac_q(i_mp_qs,k,i,j)
1751  vt_xa(i_mp_qg,2,k,i,j) = alpha_v(i_mp_qg,2)*(xq(i_mp_qg,k,i,j)**beta_v(i_mp_qg,2))*rho_fac_q(i_mp_qg,k,i,j)
1752 
1753  end do
1754  end do
1755  end do
1756 
1757  call moist_psat_liq( esw, wtemp )
1758  call moist_psat_ice( esi, wtemp )
1759 
1760  call freezing_water_kij( &
1761  dt, & ! in
1762  pq, & ! inout
1763  rhoq2, xq, temp ) ! in
1764 
1765  call dep_vapor_melt_ice_kij( &
1766  pq, & ! inout
1767  dens, wtemp, pres, qdry, & ! in
1768  rhoq2, & ! in
1769  esw, esi, & ! in
1770  xq, & ! in
1771  vt_xa, & ! in
1772  dq_xa ) ! in
1773 
1774  !
1775  ! update subroutine
1776  !
1777  call update_by_phase_change_kij( &
1778  ntdiv, ntmax_phase_change, & ! in
1779  dt, & ! in
1780  gsgam2_d, & ! in
1781  z, & ! in
1782  dz, & ! in
1783  velz, & ! in
1784  dtdt_equiv_d, & ! in
1785  dens, & ! in
1786  rhoe, & ! inout
1787  rhoq, qtrc, & ! inout
1788  temp, pres, & ! inout
1789  cva, & ! out
1790  esw, esi, rhoq2, & ! in
1791  pq, & ! inout
1792  evaporate, & ! out
1793  sl_plcdep, & ! inout
1794  sl_plrdep, sl_pnrdep ) ! inout
1795 
1796 ! if( opt_debug ) call debugreport_phasechange
1797  if( opt_debug_tem ) call debug_tem_kij( 3, temp(:,:,:), dens(:,:,:), pres(:,:,:), qtrc(:,:,:,i_qv) )
1798 
1799  call prof_rapend ('MP_Phase_change', 3)
1800 
1801  !---------------------------------------------------------------------------
1802  !
1803  ! 3.Collection process
1804  !
1805  !---------------------------------------------------------------------------
1806  call prof_rapstart('MP_Collection', 3)
1807 
1808  ! parameter setting
1809  do j = js, je
1810  do i = is, ie
1811  do k = ks, ke
1812  ! Mass concentration [kg/m3]
1813  rhoq2(i_qv,k,i,j) = rhoq(i_qv,k,i,j)
1814  rhoq2(i_qc,k,i,j) = rhoq(i_qc,k,i,j)
1815  rhoq2(i_qr,k,i,j) = rhoq(i_qr,k,i,j)
1816  rhoq2(i_qi,k,i,j) = rhoq(i_qi,k,i,j)
1817  rhoq2(i_qs,k,i,j) = rhoq(i_qs,k,i,j)
1818  rhoq2(i_qg,k,i,j) = rhoq(i_qg,k,i,j)
1819  ! Number concentration[/m3]
1820  rhoq2(i_nc,k,i,j) = rhoq(i_nc,k,i,j)
1821  rhoq2(i_nr,k,i,j) = rhoq(i_nr,k,i,j)
1822  rhoq2(i_ni,k,i,j) = rhoq(i_ni,k,i,j)
1823  rhoq2(i_ns,k,i,j) = rhoq(i_ns,k,i,j)
1824  rhoq2(i_ng,k,i,j) = rhoq(i_ng,k,i,j)
1825 
1826  ! Mass of mean particle [kg]
1827  xq(i_mp_qc,k,i,j) = min(xc_max, max(xc_min, rhoq2(i_qc,k,i,j)/(rhoq2(i_nc,k,i,j)+nc_min) ) )
1828  xq(i_mp_qr,k,i,j) = min(xr_max, max(xr_min, rhoq2(i_qr,k,i,j)/(rhoq2(i_nr,k,i,j)+nr_min) ) )
1829  xq(i_mp_qi,k,i,j) = min(xi_max, max(xi_min, rhoq2(i_qi,k,i,j)/(rhoq2(i_ni,k,i,j)+ni_min) ) )
1830  xq(i_mp_qs,k,i,j) = min(xs_max, max(xs_min, rhoq2(i_qs,k,i,j)/(rhoq2(i_ns,k,i,j)+ns_min) ) )
1831  xq(i_mp_qg,k,i,j) = min(xg_max, max(xg_min, rhoq2(i_qg,k,i,j)/(rhoq2(i_ng,k,i,j)+ng_min) ) )
1832 
1833  ! effective cross section is assume as area equivalent circle
1834  dq_xa(i_mp_qc,k,i,j) = 2.0_rp*a_rea(i_mp_qc)*xq(i_mp_qc,k,i,j)**b_rea(i_mp_qc)
1835  dq_xa(i_mp_qr,k,i,j) = 2.0_rp*a_rea(i_mp_qr)*xq(i_mp_qr,k,i,j)**b_rea(i_mp_qr)
1836  dq_xa(i_mp_qi,k,i,j) = 2.0_rp*a_rea(i_mp_qi)*xq(i_mp_qi,k,i,j)**b_rea(i_mp_qi)
1837  dq_xa(i_mp_qs,k,i,j) = 2.0_rp*a_rea(i_mp_qs)*xq(i_mp_qs,k,i,j)**b_rea(i_mp_qs)
1838  dq_xa(i_mp_qg,k,i,j) = 2.0_rp*a_rea(i_mp_qg)*xq(i_mp_qg,k,i,j)**b_rea(i_mp_qg)
1839 
1840  ! terminal velocity of average mass
1841  ! SB06(33)
1842  vt_xa(i_mp_qc,2,k,i,j) = alpha_v(i_mp_qc,2)*(xq(i_mp_qc,k,i,j)**beta_v(i_mp_qc,2))*rho_fac_q(i_mp_qc,k,i,j)
1843  vt_xa(i_mp_qr,2,k,i,j) = alpha_v(i_mp_qr,2)*(xq(i_mp_qr,k,i,j)**beta_v(i_mp_qr,2))*rho_fac_q(i_mp_qr,k,i,j)
1844  vt_xa(i_mp_qi,2,k,i,j) = alpha_v(i_mp_qi,2)*(xq(i_mp_qi,k,i,j)**beta_v(i_mp_qi,2))*rho_fac_q(i_mp_qi,k,i,j)
1845  vt_xa(i_mp_qs,2,k,i,j) = alpha_v(i_mp_qs,2)*(xq(i_mp_qs,k,i,j)**beta_v(i_mp_qs,2))*rho_fac_q(i_mp_qs,k,i,j)
1846  vt_xa(i_mp_qg,2,k,i,j) = alpha_v(i_mp_qg,2)*(xq(i_mp_qg,k,i,j)**beta_v(i_mp_qg,2))*rho_fac_q(i_mp_qg,k,i,j)
1847  enddo
1848  enddo
1849  enddo
1850 
1851  ! Auto-conversion, Accretion, Self-collection, Break-up
1852  ! [Mod] T.Seiki
1853  if ( mp_doautoconversion ) then
1854  call aut_acc_slc_brk_kij( &
1855  pq, & ! inout
1856  rhoq2, xq, dq_xa, &
1857  dens )
1858  else
1859 !OCL XFILL
1860  do j = js, je
1861  do i = is, ie
1862  do k = ks, ke
1863  pq(i_lcaut,k,i,j) = 0.0_rp
1864  pq(i_ncaut,k,i,j) = 0.0_rp
1865  pq(i_nraut,k,i,j) = 0.0_rp
1866  pq(i_lcacc,k,i,j) = 0.0_rp
1867  pq(i_ncacc,k,i,j) = 0.0_rp
1868  pq(i_nrslc,k,i,j) = 0.0_rp
1869  pq(i_nrbrk,k,i,j) = 0.0_rp
1870  end do
1871  end do
1872  end do
1873  endif
1874 
1875  call mixed_phase_collection_kij( &
1876  ! collection process
1877  pac, pq, & ! inout
1878  temp, rhoq2, & ! in
1879  xq, dq_xa, vt_xa ) ! in
1880 ! DENS(:,:,:), ) ! in
1881 
1882  call ice_multiplication_kij( &
1883  pq, & ! inout
1884  pac, & ! in
1885  temp, rhoq2, xq ) ! in
1886 
1887  !
1888  ! update
1889  ! rhogq = l*gsgam
1890  !
1891  profile_start("sn14_update_rhoq")
1892  do j = js, je
1893  do i = is, ie
1894  do k = ks, ke
1895 
1896  ! warm collection process
1897  wrm_dqc = max( dt*( pq(i_lcaut,k,i,j)+pq(i_lcacc,k,i,j) ), -rhoq2(i_qc,k,i,j) )
1898  wrm_dnc = max( dt*( pq(i_ncaut,k,i,j)+pq(i_ncacc,k,i,j) ), -rhoq2(i_nc,k,i,j) )
1899  wrm_dnr = max( dt*( pq(i_nraut,k,i,j)+pq(i_nrslc,k,i,j)+pq(i_nrbrk,k,i,j) ), -rhoq2(i_nr,k,i,j) )
1900  wrm_dqr = -wrm_dqc
1901  ! mixed phase collection
1902  ! Pxxacyy2zz xx and yy decrease and zz increase .
1903  !
1904  ! At first fixer is applied to decreasing particles.
1905  ! order of fixer: graupel-cloud, snow-cloud, ice-cloud, graupel-rain, snow-rain, ice-rain,
1906  ! snow-ice, ice-ice, graupel-snow, snow-snow
1907  ! cloud mass decrease
1908  gc_dqc = max( dt*pac(i_lgaclc2lg,k,i,j) , min(0.0_rp, -rhoq2(i_qc,k,i,j)-wrm_dqc )) ! => dqg
1909  sc_dqc = max( dt*pac(i_lsaclc2ls,k,i,j) , min(0.0_rp, -rhoq2(i_qc,k,i,j)-wrm_dqc-gc_dqc )) ! => dqs
1910  ic_dqc = max( dt*pac(i_liaclc2li,k,i,j) , min(0.0_rp, -rhoq2(i_qc,k,i,j)-wrm_dqc-gc_dqc-sc_dqc )) ! => dqi
1911  ! cloud num. decrease
1912  gc_dnc = max( dt*pac(i_ngacnc2ng,k,i,j) , min(0.0_rp, -rhoq2(i_nc,k,i,j)-wrm_dnc )) ! => dnc:minus
1913  sc_dnc = max( dt*pac(i_nsacnc2ns,k,i,j) , min(0.0_rp, -rhoq2(i_nc,k,i,j)-wrm_dnc-gc_dnc )) ! => dnc:minus
1914  ic_dnc = max( dt*pac(i_niacnc2ni,k,i,j) , min(0.0_rp, -rhoq2(i_nc,k,i,j)-wrm_dnc-gc_dnc-sc_dnc )) ! => dnc:minus
1915 
1916  ! rain mass decrease ( tem < 273.15K)
1917  sw = sign(0.5_rp, t00-temp(k,i,j)) + 0.5_rp ! if( temp(k,i,j) <= T00 )then sw=1, else sw=0
1918  rg_dqr = max( dt*pac(i_lraclg2lg, k,i,j), min(0.0_rp, -rhoq2(i_qr,k,i,j)-wrm_dqr )) * sw
1919  rg_dqg = max( dt*pac(i_lraclg2lg, k,i,j), min(0.0_rp, -rhoq2(i_qg,k,i,j) )) * ( 1.0_rp - sw )
1920  rs_dqr = max( dt*pac(i_lracls2lg_r,k,i,j), min(0.0_rp, -rhoq2(i_qr,k,i,j)-wrm_dqr-rg_dqr )) * sw
1921  ri_dqr = max( dt*pac(i_lracli2lg_r,k,i,j), min(0.0_rp, -rhoq2(i_qr,k,i,j)-wrm_dqr-rg_dqr-rs_dqr )) * sw
1922  ! rain num. decrease
1923  rg_dnr = max( dt*pac(i_nracng2ng, k,i,j), min(0.0_rp, -rhoq2(i_nr,k,i,j)-wrm_dnr )) * sw
1924  rg_dng = max( dt*pac(i_nracng2ng, k,i,j), min(0.0_rp, -rhoq2(i_ng,k,i,j) )) * ( 1.0_rp - sw )
1925  rs_dnr = max( dt*pac(i_nracns2ng_r,k,i,j), min(0.0_rp, -rhoq2(i_nr,k,i,j)-wrm_dnr-rg_dnr )) * sw
1926  ri_dnr = max( dt*pac(i_nracni2ng_r,k,i,j), min(0.0_rp, -rhoq2(i_nr,k,i,j)-wrm_dnr-rg_dnr-rs_dnr )) * sw
1927 
1928  ! ice mass decrease
1929  fac1 = (ri_dqr-eps)/ (dt*pac(i_lracli2lg_r,k,i,j)-eps) ! suppress factor by filter of rain
1930  ri_dqi = max( dt*pac(i_lracli2lg_i,k,i,j)*fac1, min(0.0_rp, -rhoq2(i_qi,k,i,j)+ic_dqc )) ! => dqg
1931  ii_dqi = max( dt*pac(i_liacli2ls,k,i,j) , min(0.0_rp, -rhoq2(i_qi,k,i,j)+ic_dqc-ri_dqi )) ! => dqs
1932  is_dqi = max( dt*pac(i_liacls2ls,k,i,j) , min(0.0_rp, -rhoq2(i_qi,k,i,j)+ic_dqc-ri_dqi-ii_dqi )) ! => dqs
1933  ! ice num. decrease
1934  fac4 = (ri_dnr-eps)/ (dt*pac(i_nracni2ng_r,k,i,j)-eps) ! suppress factor by filter of rain
1935  ri_dni = max( dt*pac(i_nracni2ng_i,k,i,j)*fac4, min(0.0_rp, -rhoq2(i_ni,k,i,j) )) ! => dni:minus
1936  ii_dni = max( dt*pac(i_niacni2ns,k,i,j) , min(0.0_rp, -rhoq2(i_ni,k,i,j)-ri_dni )) ! => dni:minus,dns:plus(*0.5)
1937  is_dni = max( dt*pac(i_niacns2ns,k,i,j) , min(0.0_rp, -rhoq2(i_ni,k,i,j)-ri_dni-ii_dni )) ! => dni:minus,dns:plus
1938  ! snow mass decrease
1939  fac3 = (rs_dqr-eps)/(dt*pac(i_lracls2lg_r,k,i,j)-eps) ! suppress factor by filter of rain
1940  rs_dqs = max( dt*pac(i_lracls2lg_s,k,i,j)*fac3, min(0.0_rp, -rhoq2(i_qs,k,i,j)+sc_dqc+ii_dqi+is_dqi )) ! => dqg
1941  gs_dqs = max( dt*pac(i_lgacls2lg,k,i,j) , min(0.0_rp, -rhoq2(i_qs,k,i,j)+sc_dqc+ii_dqi+is_dqi-rs_dqs )) ! => dqg
1942  ! snow num. decrease
1943  fac6 = (rs_dnr-eps)/(dt*pac(i_nracns2ng_r,k,i,j)-eps) ! suppress factor by filter of rain
1944 ! fac7 = (is_dni-eps)/(dt*Pac(I_NIacNS2NS, k,i,j)-eps) ! suppress factor by filter of ice
1945  rs_dns = max( dt*pac(i_nracns2ng_s,k,i,j)*fac6, min(0.0_rp, -rhoq2(i_ns,k,i,j)+0.50_rp*ii_dni+is_dni )) ! => dns:minus
1946  gs_dns = max( dt*pac(i_ngacns2ng,k,i,j) , min(0.0_rp, -rhoq2(i_ns,k,i,j)+0.50_rp*ii_dni+is_dni-rs_dns )) ! => dns:minus
1947  ss_dns = max( dt*pac(i_nsacns2ns,k,i,j) , min(0.0_rp, -rhoq2(i_ns,k,i,j)+0.50_rp*ii_dni+is_dni-rs_dns-gs_dns ))
1948  !
1949  gg_dng = max( dt*pac(i_ngacng2ng,k,i,j) , min(0.0_rp, -rhoq2(i_ng,k,i,j) ))
1950  !
1951  ! total plus in mixed phase collection(clp_)
1952  ! mass
1953  ! if( temp(k,i,j) <= T00 )then sw=1, else sw=0
1954  clp_dqc = 0.0_rp
1955  clp_dqr = (-rg_dqg-rs_dqs-ri_dqi) * (1.0_rp-sw)
1956  clp_dqi = -ic_dqc
1957  clp_dqs = -sc_dqc-ii_dqi-is_dqi
1958  clp_dqg = -gc_dqc -gs_dqs + (-rg_dqr-rs_dqr-rs_dqs-ri_dqr-ri_dqi) * sw
1959  ! num.( number only increase when a+b=>c, dnc=-dna)
1960  clp_dnc = 0.0_rp
1961  clp_dnr = 0.0_rp
1962  clp_dni = 0.0_rp
1963  clp_dns = -ii_dni*0.5_rp
1964  clp_dng = (-rs_dnr-ri_dnr) * sw
1965  ! total minus in mixed phase collection(clm_)
1966  ! mass
1967  clm_dqc = gc_dqc+sc_dqc+ic_dqc
1968  clm_dqr = (rg_dqr+rs_dqr+ri_dqr) * sw
1969  clm_dqi = ri_dqi+ii_dqi+is_dqi
1970  clm_dqs = rs_dqs+gs_dqs
1971  clm_dqg = rg_dqg * (1.0_rp-sw)
1972  ! num.
1973  clm_dnc = gc_dnc+sc_dnc+ic_dnc
1974  clm_dnr = (rg_dnr+rs_dnr+ri_dnr) * sw
1975  clm_dni = ri_dni+ii_dni+is_dni
1976  clm_dns = rs_dns+ss_dns+gs_dns
1977  clm_dng = gg_dng + rg_dng * (1.0_rp-sw)
1978 
1979  ! partial conversion
1980  ! 08/05/08 [Mod] T.Mitsui
1981  pco_dqi = max( dt*pq(i_licon,k,i,j), -clp_dqi )
1982  pco_dqs = max( dt*pq(i_lscon,k,i,j), -clp_dqs )
1983  pco_dqg = -pco_dqi-pco_dqs
1984  ! 08/05/08 [Mod] T.Mitsui
1985  pco_dni = max( dt*pq(i_nicon,k,i,j), -clp_dni )
1986  pco_dns = max( dt*pq(i_nscon,k,i,j), -clp_dns )
1987  pco_dng = -pco_dni-pco_dns
1988  ! enhanced melting ( always negative value )
1989  ! ice-cloud melting produces cloud, others produce rain
1990  eml_dqi = max( dt*pq(i_liacm,k,i,j), min(0.0_rp, -rhoq2(i_qi,k,i,j)-(clp_dqi+clm_dqi)-pco_dqi ))
1991  eml_dqs = max( dt*pq(i_lsacm,k,i,j), min(0.0_rp, -rhoq2(i_qs,k,i,j)-(clp_dqs+clm_dqs)-pco_dqs ))
1992  eml_dqg = max( dt*(pq(i_lgacm,k,i,j)+pq(i_lgarm,k,i,j)+pq(i_lsarm,k,i,j)+pq(i_liarm,k,i,j)), &
1993  min(0.0_rp, -rhoq2(i_qg,k,i,j)-(clp_dqg+clm_dqg)-pco_dqg ))
1994  eml_dqc = -eml_dqi
1995  eml_dqr = -eml_dqs-eml_dqg
1996  !
1997  eml_dni = max( dt*pq(i_niacm,k,i,j), min(0.0_rp, -rhoq2(i_ni,k,i,j)-(clp_dni+clm_dni)-pco_dni ))
1998  eml_dns = max( dt*pq(i_nsacm,k,i,j), min(0.0_rp, -rhoq2(i_ns,k,i,j)-(clp_dns+clm_dns)-pco_dns ))
1999  eml_dng = max( dt*(pq(i_ngacm,k,i,j)+pq(i_ngarm,k,i,j)+pq(i_nsarm,k,i,j)+pq(i_niarm,k,i,j)), &
2000  min(0.0_rp, -rhoq2(i_ng,k,i,j)-(clp_dng+clm_dng)-pco_dng ))
2001  eml_dnc = -eml_dni
2002  eml_dnr = -eml_dns-eml_dng
2003  !
2004  ! ice multiplication
2005  spl_dqg = max( dt*pq(i_lgspl,k,i,j), min(0.0_rp, -rhoq2(i_qg,k,i,j)-(clp_dqg+clm_dqg)-pco_dqg-eml_dqg ))
2006  spl_dqs = max( dt*pq(i_lsspl,k,i,j), min(0.0_rp, -rhoq2(i_qs,k,i,j)-(clp_dqs+clm_dqs)-pco_dqs-eml_dqs ))
2007  spl_dqi = -spl_dqg-spl_dqs
2008  fac9 = (spl_dqg-eps)/(dt*pq(i_lgspl,k,i,j)-eps)
2009  fac10 = (spl_dqs-eps)/(dt*pq(i_lsspl,k,i,j)-eps)
2010  spl_dni = dt*pq(i_nispl,k,i,j)*fac9*fac10
2011  !
2012  ! total cloud change
2013  drhogqc = (wrm_dqc + clp_dqc + clm_dqc + eml_dqc )
2014  drhognc = (wrm_dnc + clp_dnc + clm_dnc + eml_dnc )
2015  ! total rain change
2016  drhogqr = (wrm_dqr + clp_dqr + clm_dqr + eml_dqr )
2017  drhognr = (wrm_dnr + clp_dnr + clm_dnr + eml_dnr )
2018  ! total ice change
2019  drhogqi = ( clp_dqi + clm_dqi + pco_dqi + eml_dqi + spl_dqi)
2020  drhogni = ( clp_dni + clm_dni + pco_dni + eml_dni + spl_dni)
2021  ! total snow change
2022  drhogqs = ( clp_dqs + clm_dqs + pco_dqs + eml_dqs + spl_dqs)
2023  drhogns = ( clp_dns + clm_dns + pco_dns + eml_dns )
2024  ! total graupel change
2025  drhogqg = ( clp_dqg + clm_dqg + pco_dqg + eml_dqg + spl_dqg)
2026  drhogng = ( clp_dng + clm_dng + pco_dng + eml_dng )
2027  !
2028  !--- update
2029  !
2030  rhoq(i_qc,k,i,j) = max(0.0_rp, rhoq(i_qc,k,i,j) + drhogqc )
2031  rhoq(i_nc,k,i,j) = max(0.0_rp, rhoq(i_nc,k,i,j) + drhognc )
2032  rhoq(i_qr,k,i,j) = max(0.0_rp, rhoq(i_qr,k,i,j) + drhogqr )
2033  rhoq(i_nr,k,i,j) = max(0.0_rp, rhoq(i_nr,k,i,j) + drhognr )
2034  rhoq(i_qi,k,i,j) = max(0.0_rp, rhoq(i_qi,k,i,j) + drhogqi )
2035  rhoq(i_ni,k,i,j) = max(0.0_rp, rhoq(i_ni,k,i,j) + drhogni )
2036  rhoq(i_qs,k,i,j) = max(0.0_rp, rhoq(i_qs,k,i,j) + drhogqs )
2037  rhoq(i_ns,k,i,j) = max(0.0_rp, rhoq(i_ns,k,i,j) + drhogns )
2038  rhoq(i_qg,k,i,j) = max(0.0_rp, rhoq(i_qg,k,i,j) + drhogqg )
2039  rhoq(i_ng,k,i,j) = max(0.0_rp, rhoq(i_ng,k,i,j) + drhogng )
2040  !
2041  ! update
2042  ! rhogq = l*gsgam
2043  rhoe(k,i,j) = rhoe(k,i,j) + lhf * ( drhogqi + drhogqs + drhogqg )
2044  enddo
2045  enddo
2046  enddo
2047  profile_stop("sn14_update_rhoq")
2048 
2049  call prof_rapend ('MP_Collection', 3)
2050 
2051  call prof_rapstart('MP_Postprocess', 3)
2052 
2053  !--- update mixing ratio
2054  do j = js, je
2055  do i = is, ie
2056  do k = ks, ke
2057  do iq = i_qv, i_ng
2058  qtrc(k,i,j,iq) = rhoq(iq,k,i,j) * rrho(k,i,j)
2059  enddo
2060 
2061  calc_qdry( qdry(k,i,j), qtrc, tracer_mass, k, i, j, iq )
2062  calc_cv( cva(k,i,j), qdry(k,i,j), qtrc, k, i, j, iq, cvdry, tracer_cv )
2063  calc_r( rmoist, qdry(k,i,j), qtrc, k, i, j, iq, rdry, tracer_r )
2064  cpa(k,i,j) = cva(k,i,j) + rmoist
2065  temp(k,i,j) = rhoe(k,i,j) / ( dens(k,i,j) * cva(k,i,j) )
2066  pres(k,i,j) = dens(k,i,j) * rmoist * temp(k,i,j)
2067  rhot(k,i,j) = temp(k,i,j) * ( p00 / pres(k,i,j) )**(rmoist/cpa(k,i,j)) &
2068  * dens(k,i,j)
2069  enddo
2070  enddo
2071  enddo
2072 
2073 ! if( opt_debug ) call debugreport_collection
2074  if( opt_debug_tem ) call debug_tem_kij( 4, temp(:,:,:), dens(:,:,:), pres(:,:,:), qtrc(:,:,:,i_qv) )
2075 
2076  call prof_rapend ('MP_Postprocess', 3)
2077 
2078  !----------------------------------------------------------------------------
2079  !
2080  ! 4.Saturation adjustment
2081  !
2082  !----------------------------------------------------------------------------
2083  call prof_rapstart('MP_Saturation_adjustment', 3)
2084  ! nothing to do
2085  call prof_rapend ('MP_Saturation_adjustment', 3)
2086  !----------------------------------------------------------------------------
2087  !
2088  ! 5. Sedimentation ( terminal velocity must be negative )
2089  !
2090  !----------------------------------------------------------------------------
2091  call prof_rapstart('MP_Sedimentation', 3)
2092 
2093  vterm(:,:,:,:) = 0.0_rp
2094  flx_hydro(:,:,:,:) = 0.0_rp
2095 
2096  if ( mp_doprecipitation ) then
2097 
2098  do step = 1, mp_nstep_sedimentation
2099 
2100  call mp_terminal_velocity( vterm(:,:,:,:), & ! [OUT]
2101  rhoq(:,:,:,:), & ! [IN]
2102  dens(:,:,:), & ! [IN]
2103  temp(:,:,:), & ! [IN]
2104  pres(:,:,:) ) ! [IN]
2105 
2106  call mp_precipitation( qa_mp, & ! [IN]
2107  qs_mp, & ! [IN]
2108  pflux(:,:,:,:), & ! [OUT]
2109  vterm(:,:,:,:), & ! [INOUT]
2110  dens(:,:,:), & ! [INOUT]
2111  momz(:,:,:), & ! [INOUT]
2112  momx(:,:,:), & ! [INOUT]
2113  momy(:,:,:), & ! [INOUT]
2114  rhoe(:,:,:), & ! [INOUT]
2115  qtrc(:,:,:,:), & ! [INOUT]
2116  temp(:,:,:), & ! [IN]
2117  tracer_cv(:), & ! [IN]
2118  mp_dtsec_sedimentation ) ! [IN]
2119 
2120  do j = js, je
2121  do i = is, ie
2122  do k = ks-1, ke-1
2123  flx_hydro(k,i,j,i_mp_qc) = flx_hydro(k,i,j,i_mp_qc) + pflux(k,i,j,i_mp_qc) * mp_rnstep_sedimentation
2124  flx_hydro(k,i,j,i_mp_qr) = flx_hydro(k,i,j,i_mp_qr) + pflux(k,i,j,i_mp_qr) * mp_rnstep_sedimentation
2125  flx_hydro(k,i,j,i_mp_qi) = flx_hydro(k,i,j,i_mp_qi) + pflux(k,i,j,i_mp_qi) * mp_rnstep_sedimentation
2126  flx_hydro(k,i,j,i_mp_qs) = flx_hydro(k,i,j,i_mp_qs) + pflux(k,i,j,i_mp_qs) * mp_rnstep_sedimentation
2127  flx_hydro(k,i,j,i_mp_qg) = flx_hydro(k,i,j,i_mp_qg) + pflux(k,i,j,i_mp_qg) * mp_rnstep_sedimentation
2128  flx_hydro(k,i,j,i_mp_nc) = flx_hydro(k,i,j,i_mp_nc) + pflux(k,i,j,i_mp_nc) * mp_rnstep_sedimentation
2129  flx_hydro(k,i,j,i_mp_nr) = flx_hydro(k,i,j,i_mp_nr) + pflux(k,i,j,i_mp_nr) * mp_rnstep_sedimentation
2130  flx_hydro(k,i,j,i_mp_ni) = flx_hydro(k,i,j,i_mp_ni) + pflux(k,i,j,i_mp_ni) * mp_rnstep_sedimentation
2131  flx_hydro(k,i,j,i_mp_ns) = flx_hydro(k,i,j,i_mp_ns) + pflux(k,i,j,i_mp_ns) * mp_rnstep_sedimentation
2132  flx_hydro(k,i,j,i_mp_ng) = flx_hydro(k,i,j,i_mp_ng) + pflux(k,i,j,i_mp_ng) * mp_rnstep_sedimentation
2133  enddo
2134  enddo
2135  enddo
2136 
2137  enddo
2138 
2139  endif
2140 
2141  call hist_in( flx_hydro(:,:,:,i_mp_qc), 'pflux_QC', 'precipitation flux of QC', 'kg/m2/s', nohalo=.true. )
2142  call hist_in( flx_hydro(:,:,:,i_mp_qr), 'pflux_QR', 'precipitation flux of QR', 'kg/m2/s', nohalo=.true. )
2143  call hist_in( flx_hydro(:,:,:,i_mp_qi), 'pflux_QI', 'precipitation flux of QI', 'kg/m2/s', nohalo=.true. )
2144  call hist_in( flx_hydro(:,:,:,i_mp_qs), 'pflux_QS', 'precipitation flux of QS', 'kg/m2/s', nohalo=.true. )
2145  call hist_in( flx_hydro(:,:,:,i_mp_qg), 'pflux_QG', 'precipitation flux of QG', 'kg/m2/s', nohalo=.true. )
2146  call hist_in( flx_hydro(:,:,:,i_mp_nc), 'pflux_QC', 'precipitation flux of NC', 'kg/m2/s', nohalo=.true. )
2147  call hist_in( flx_hydro(:,:,:,i_mp_nr), 'pflux_QR', 'precipitation flux of NR', 'kg/m2/s', nohalo=.true. )
2148  call hist_in( flx_hydro(:,:,:,i_mp_ni), 'pflux_QI', 'precipitation flux of NI', 'kg/m2/s', nohalo=.true. )
2149  call hist_in( flx_hydro(:,:,:,i_mp_ns), 'pflux_QS', 'precipitation flux of NS', 'kg/m2/s', nohalo=.true. )
2150  call hist_in( flx_hydro(:,:,:,i_mp_ng), 'pflux_QG', 'precipitation flux of NG', 'kg/m2/s', nohalo=.true. )
2151 
2152  do j = js, je
2153  do i = is, ie
2154  sflx_rain(i,j) = - ( flx_hydro(ks-1,i,j,i_mp_qc) &
2155  + flx_hydro(ks-1,i,j,i_mp_qr) )
2156  sflx_snow(i,j) = - ( flx_hydro(ks-1,i,j,i_mp_qi) &
2157  + flx_hydro(ks-1,i,j,i_mp_qs) &
2158  + flx_hydro(ks-1,i,j,i_mp_qg) )
2159  enddo
2160  enddo
2161 
2162  call prof_rapend ('MP_Sedimentation', 3)
2163 
2164  return
2165  end subroutine mp_sn14
2166 
2167  !-----------------------------------------------------------------------------
2168  subroutine debug_tem_kij( &
2169  point, &
2170  tem, &
2171  rho, &
2172  pre, &
2173  qv )
2174  use scale_process, only: &
2175  prc_myrank
2176  implicit none
2177 
2178  integer, intent(in) :: point
2179  real(RP), intent(in) :: tem(KA,IA,JA)
2180  real(RP), intent(in) :: rho(KA,IA,JA)
2181  real(RP), intent(in) :: pre(KA,IA,JA)
2182  real(RP), intent(in) :: qv (KA,IA,JA)
2183 
2184  integer :: k ,i, j
2185  !---------------------------------------------------------------------------
2186 
2187  do j = js, je
2188  do i = is, ie
2189  do k = ks, ke
2190  if ( tem(k,i,j) < tem_min &
2191  .OR. rho(k,i,j) < rho_min &
2192  .OR. pre(k,i,j) < 1.0_rp ) then
2193 
2194  if( io_l ) write(io_fid_log,'(A,I3,A,4(F16.5),3(I6))') &
2195  "*** point: ", point, " low tem,rho,pre:", tem(k,i,j), rho(k,i,j), pre(k,i,j), qv(k,i,j), k, i, j, prc_myrank
2196  endif
2197  enddo
2198  enddo
2199  enddo
2200 
2201  return
2202  end subroutine debug_tem_kij
2203 
2204  subroutine nucleation_kij( &
2205  z, velz, &
2206  rho, tem, pre, &
2207  rhoq, &
2208  PQ, &
2209  cpa, & ! in
2210  dTdt_rad, & ! in
2211  qke, & ! in
2212  CCN, & ! in
2213  dt ) ! in
2214  use scale_process, only: &
2215  prc_mpistop
2216  use scale_tracer, only: &
2217  qa
2218  use scale_atmos_saturation, only: &
2219  moist_psat_liq => atmos_saturation_psat_liq, &
2220  moist_psat_ice => atmos_saturation_psat_ice, &
2221  moist_pres2qsat_liq => atmos_saturation_pres2qsat_liq, &
2222  moist_pres2qsat_ice => atmos_saturation_pres2qsat_ice, &
2223  moist_dqsi_dtem_rho => atmos_saturation_dqsi_dtem_rho
2224  implicit none
2225 
2226  real(RP), intent(in) :: z(KA) !
2227  real(RP), intent(in) :: velz(KA,IA,JA) ! w of half point
2228  real(RP), intent(in) :: rho(KA,IA,JA) ! [Add] 09/08/18 T.Mitsui
2229  real(RP), intent(in) :: tem(KA,IA,JA) ! [Add] 09/08/18 T.Mitsui
2230  real(RP), intent(in) :: pre(KA,IA,JA) ! [Add] 09/08/18 T.Mitsui
2231  !
2232  real(RP), intent(in) :: rhoq(I_QV:I_NG,KA,IA,JA) !
2233  real(RP), intent(out) :: PQ(PQ_MAX,KA,IA,JA)
2234  !
2235  real(RP), intent(in) :: cpa(KA,IA,JA) ! in 09/08/18 [Add] T.Mitsui
2236  real(RP), intent(in) :: dTdt_rad(KA,IA,JA) ! 09/08/18 T.Mitsui
2237  real(RP), intent(in) :: qke(KA,IA,JA) ! 09/08/18 T.Mitsui
2238  real(RP), intent(in) :: dt
2239  real(RP), intent(in) :: CCN(KA,IA,JA)
2240  !
2241  ! namelist variables
2242  !
2243  ! total aerosol number concentration [/m3]
2244  real(RP), parameter :: c_ccn_ocean= 1.00e+8_rp
2245  real(RP), parameter :: c_ccn_land = 1.26e+9_rp
2246  real(RP), save :: c_ccn = 1.00e+8_rp
2247  ! aerosol activation factor
2248  real(RP), parameter :: kappa_ocean= 0.462_rp
2249  real(RP), parameter :: kappa_land = 0.308_rp
2250  real(RP), save :: kappa = 0.462_rp
2251  real(RP), save :: c_in = 1.0_rp
2252  ! SB06 (36)
2253  real(RP), save :: nm_M92 = 1.e+3_rp
2254  real(RP), save :: am_M92 = -0.639_rp
2255  real(RP), save :: bm_M92 = 12.96_rp
2256  !
2257  real(RP), save :: in_max = 1000.e+3_rp ! max num. of Ice-Nuclei [num/m3]
2258  real(RP), save :: ssi_max= 0.60_rp
2259  real(RP), save :: ssw_max= 1.1_rp ! [%]
2260  !
2261  logical, save :: flag_first = .true.
2262  real(RP), save :: qke_min = 0.03_rp ! sigma=0.1[m/s], 09/08/18 T.Mitsui
2263  real(RP), save :: tem_ccn_low=233.150_rp ! = -40 degC ! [Add] 10/08/03 T.Mitsui
2264  real(RP), save :: tem_in_low =173.150_rp ! = -100 degC ! [Add] 10/08/03 T.Mitsui
2265  logical, save :: nucl_twomey = .false.
2266  logical, save :: inucl_w = .false.
2267  !
2268  namelist /nm_mp_sn14_nucleation/ &
2269  in_max, & !
2270  c_ccn, kappa, & ! cloud nucleation
2271  nm_m92, am_m92, bm_m92, & ! ice nucleation
2272  xc_ccn, xi_ccn, &
2273  tem_ccn_low, & ! [Add] 10/08/03 T.Mitsui
2274  tem_in_low, & ! [Add] 10/08/03 T.Mitsui
2275  ssw_max, ssi_max, &
2276  nucl_twomey, inucl_w ! [Add] 13/01/30 Y.Sato
2277  !
2278 ! real(RP) :: c_ccn_map(1,IA,JA) ! c_ccn horizontal distribution
2279 ! real(RP) :: kappa_map(1,IA,JA) ! kappa horizontal distribution
2280 ! real(RP) :: c_in_map(1,IA,JA) ! c_in horizontal distribution ! [Add] 11/08/30 T.Mitsui
2281  real(RP) :: esw(KA,IA,JA) ! saturation vapor pressure, water
2282  real(RP) :: esi(KA,IA,JA) ! ice
2283  real(RP) :: ssw(KA,IA,JA) ! super saturation (water)
2284  real(RP) :: ssi(KA,IA,JA) ! super saturation (ice)
2285 ! real(RP) :: w_dsswdz(KA,IA,JA) ! w*(d_ssw/ d_z) super saturation(water) flux
2286  real(RP) :: w_dssidz(KA,IA,JA) ! w*(d_ssi/ d_z), 09/04/14 T.Mitsui
2287 ! real(RP) :: ssw_below(KA,IA,JA)! ssw(k-1)
2288  real(RP) :: ssi_below(KA,IA,JA)! ssi(k-1), 09/04/14 T.Mitsui
2289  real(RP) :: z_below(KA,IA,JA) ! z(k-1)
2290  real(RP) :: dz ! z(k)-z(k-1)
2291  real(RP) :: pv ! vapor pressure
2292  ! work variables for Twomey Equation.
2293  real(RP) :: qsw(KA,IA,JA)
2294  real(RP) :: qsi(KA,IA,JA)
2295  real(RP) :: dqsidtem_rho(KA,IA,JA)
2296  real(RP) :: dssidt_rad(KA,IA,JA)
2297 ! real(RP) :: dni_ratio(KA,IA,JA)
2298  real(RP) :: wssi, wdssi
2299  !
2300 ! real(RP) :: xi_nuc(1,IA,JA) ! xi use the value @ cloud base
2301 ! real(RP) :: alpha_nuc(1,IA,JA) ! alpha_nuc
2302 ! real(RP) :: eta_nuc(1,IA,JA) ! xi use the value @ cloud base
2303  !
2304  real(RP) :: sigma_w(KA,IA,JA)
2305  real(RP) :: weff(KA,IA,JA)
2306  real(RP) :: weff_max(KA,IA,JA)
2307  !
2308  real(RP) :: coef_ccn(IA,JA)
2309  real(RP) :: slope_ccn(IA,JA)
2310  real(RP) :: nc_new(KA,IA,JA)
2311  real(RP) :: nc_new_below(KA,IA,JA)
2312  real(RP) :: dnc_new
2313  real(RP) :: nc_new_max ! Lohmann (2002),
2314  real(RP) :: a_max
2315  real(RP) :: b_max
2316  logical :: flag_nucleation(KA,IA,JA)
2317  !
2318  real(RP) :: r_gravity
2319  real(RP), parameter :: r_sqrt3=0.577350269_rp ! = sqrt(1.d0/3.d0)
2320  real(RP), parameter :: eps=1.e-30_rp
2321  !====> ! 09/08/18
2322  !
2323  real(RP) :: dlcdt_max, dli_max ! defined by supersaturation
2324  real(RP) :: dncdt_max, dni_max ! defined by supersaturation
2325  real(RP) :: rdt
2326  !
2327  integer :: i, j, k
2328  !
2329  if( flag_first )then
2330  rewind(io_fid_conf)
2331  read(io_fid_conf, nml=nm_mp_sn14_nucleation, end=100)
2332 100 if( io_nml ) write(io_fid_nml,nml=nm_mp_sn14_nucleation)
2333  flag_first=.false.
2334 
2335  if ( mp_couple_aerosol .AND. nucl_twomey ) then
2336  write(*,*) "xxx [mp_sn14/nucleation] nucl_twomey should be false when MP_couple_aerosol is true, stop"
2337  call prc_mpistop
2338  endif
2339  endif
2340  !
2341 ! c_ccn_map(1,:,:) = c_ccn
2342 ! kappa_map(1,:,:) = kappa
2343 ! c_in_map(1,:,:) = c_in
2344  !
2345 ! nc_uplim_d(1,:,:) = c_ccn_map(1,:,:)*1.5_RP
2346  do j = js, je
2347  do i = is, ie
2348  nc_uplim_d(1,i,j) = c_ccn*1.5_rp
2349  end do
2350  end do
2351  !
2352  rdt = 1.0_rp/dt
2353  r_gravity = 1.0_rp/grav
2354  !
2355  call moist_psat_liq ( esw, tem )
2356  call moist_psat_ice ( esi, tem )
2357  call moist_pres2qsat_liq( qsw, tem, pre )
2358  call moist_pres2qsat_ice( qsi, tem, pre )
2359  call moist_dqsi_dtem_rho( dqsidtem_rho, tem, rho )
2360  !
2361  ! Lohmann (2002),JAS, eq.(1) but changing unit [cm-3] => [m-3]
2362  a_max = 1.e+6_rp*0.1_rp*(1.e-6_rp)**1.27_rp
2363  b_max = 1.27_rp
2364  !
2365  ssi_max = 1.0_rp
2366 
2367  do j = js, je
2368  do i = is, ie
2369  do k = ks, ke
2370  pv = rhoq(i_qv,k,i,j)*rvap*tem(k,i,j)
2371  ssw(k,i,j) = min( mp_ssw_lim, ( pv/esw(k,i,j)-1.0_rp ) )*100.0_rp
2372  ssi(k,i,j) = (pv/esi(k,i,j) - 1.00_rp)
2373 ! ssw_below(k+1,i,j) = ssw(k,i,j)
2374  ssi_below(k+1,i,j) = ssi(k,i,j)
2375  z_below(k+1,i,j) = z(k)
2376  end do
2377 ! ssw_below(KS,i,j) = ssw(KS,i,j)
2378  ssi_below(ks,i,j) = ssi(ks,i,j)
2379  z_below(ks,i,j) = z(ks-1)
2380 
2381  ! dS/dz is evaluated by first order upstream difference
2382  !*** Solution for Twomey Equation ***
2383 ! coef_ccn(i,j) = 1.E+6_RP*0.88_RP*(c_ccn_map(1,i,j)*1.E-6_RP)**(2.0_RP/(kappa_map(1,i,j) + 2.0_RP)) * &
2384  coef_ccn(i,j) = 1.e+6_rp*0.88_rp*(c_ccn*1.e-6_rp)**(2.0_rp/(kappa + 2.0_rp)) &
2385 ! * (70.0_RP)**(kappa_map(1,i,j)/(kappa_map(1,i,j) + 2.0_RP))
2386  * (70.0_rp)**(kappa/(kappa + 2.0_rp))
2387 ! slope_ccn(i,j) = 1.5_RP*kappa_map(1,i,j)/(kappa_map(1,i,j) + 2.0_RP)
2388  slope_ccn(i,j) = 1.5_rp*kappa/(kappa + 2.0_rp)
2389  !
2390  do k=ks, ke
2391  sigma_w(k,i,j) = r_sqrt3*sqrt(max(qke(k,i,j),qke_min))
2392  end do
2393  sigma_w(ks-1,i,j) = sigma_w(ks,i,j)
2394  sigma_w(ke+1,i,j) = sigma_w(ke,i,j)
2395  ! effective vertical velocity
2396  do k=ks, ke
2397  weff(k,i,j) = 0.5_rp*(velz(k-1,i,j) + velz(k,i,j)) - cpa(k,i,j)*r_gravity*dtdt_rad(k,i,j)
2398  end do
2399 
2400  end do
2401  end do
2402  !
2403  if( mp_couple_aerosol ) then
2404 
2405  do j = js, je
2406  do i = is, ie
2407  do k = ks, ke
2408  if( ssw(k,i,j) > 1.e-10_rp .AND. pre(k,i,j) > 300.e+2_rp ) then
2409  nc_new(k,i,j) = max( ccn(k,i,j), c_ccn )
2410  else
2411  nc_new(k,i,j) = 0.0_rp
2412  endif
2413  enddo
2414  enddo
2415  enddo
2416 
2417  else
2418 
2419  if( nucl_twomey ) then
2420  ! diagnose cloud condensation nuclei
2421 
2422  do j = js, je
2423  do i = is, ie
2424  do k = ks, ke
2425  ! effective vertical velocity (maximum vertical velocity in turbulent flow)
2426  weff_max(k,i,j) = weff(k,i,j) + sigma_w(k,i,j)
2427  ! large scale upward motion region and saturated
2428  if( (weff(k,i,j) > 1.e-8_rp) .AND. (ssw(k,i,j) > 1.e-10_rp) .AND. pre(k,i,j) > 300.e+2_rp )then
2429  ! Lohmann (2002), eq.(1)
2430  nc_new_max = coef_ccn(i,j)*weff_max(k,i,j)**slope_ccn(i,j)
2431  nc_new(k,i,j) = a_max*nc_new_max**b_max
2432  else
2433  nc_new(k,i,j) = 0.0_rp
2434  end if
2435  end do
2436  end do
2437  end do
2438  else
2439  ! calculate cloud condensation nuclei
2440  do j = js, je
2441  do i = is, ie
2442  do k = ks, ke
2443  if( ssw(k,i,j) > 1.e-10_rp .AND. pre(k,i,j) > 300.e+2_rp ) then
2444  nc_new(k,i,j) = c_ccn*ssw(k,i,j)**kappa
2445  else
2446  nc_new(k,i,j) = 0.0_rp
2447  endif
2448  enddo
2449  enddo
2450  enddo
2451  endif
2452 
2453  endif
2454 
2455  do j = js, je
2456  do i = is, ie
2457  do k = ks, ke
2458  ! nc_new is bound by upper limit
2459  if( nc_new(k,i,j) > nc_uplim_d(1,i,j) )then ! no more CCN
2460  flag_nucleation(k,i,j) = .false.
2461  nc_new_below(k+1,i,j) = 1.e+30_rp
2462  else if( nc_new(k,i,j) > eps )then ! nucleation can occur
2463  flag_nucleation(k,i,j) = .true.
2464  nc_new_below(k+1,i,j) = nc_new(k,i,j)
2465  else ! nucleation cannot occur(unsaturated or negative w)
2466  flag_nucleation(k,i,j) = .false.
2467  nc_new_below(k+1,i,j) = 0.0_rp
2468  end if
2469  end do
2470  nc_new_below(ks,i,j) = 0.0_rp
2471 ! do k=KS, KE
2472  ! search maximum value of nc_new
2473 ! if( ( nc_new(k,i,j) < nc_new_below(k,i,j) ) .OR. &
2474 ! ( nc_new_below(k,i,j) > c_ccn_map(1,i,j)*0.05_RP ) )then ! 5% of c_ccn
2475 ! ( nc_new_below(k,i,j) > c_ccn*0.05_RP ) )then ! 5% of c_ccn
2476 ! flag_nucleation(k,i,j) = .false.
2477 ! end if
2478 ! end do
2479 
2480  end do
2481  end do
2482 
2483  if( mp_couple_aerosol ) then
2484 
2485  do j = js, je
2486  do i = is, ie
2487  do k = ks, ke
2488  ! nucleation occurs at only cloud base.
2489  ! if CCN is more than below parcel, nucleation newly occurs
2490  ! effective vertical velocity
2491  if ( flag_nucleation(k,i,j) .AND. & ! large scale upward motion region and saturated
2492  tem(k,i,j) > tem_ccn_low ) then
2493  dlcdt_max = (rhoq(i_qv,k,i,j) - esw(k,i,j)/(rvap*tem(k,i,j)))*rdt
2494  dncdt_max = dlcdt_max/xc_min
2495 ! dnc_new = nc_new(k,i,j)-rhoq(I_NC,k,i,j)
2496  dnc_new = nc_new(k,i,j)
2497  pq(i_ncccn,k,i,j) = min( dncdt_max, dnc_new*rdt )
2498  pq(i_lcccn,k,i,j) = min( dlcdt_max, xc_min*pq(i_ncccn,k,i,j) )
2499  else
2500  pq(i_ncccn,k,i,j) = 0.0_rp
2501  pq(i_lcccn,k,i,j) = 0.0_rp
2502  end if
2503  end do
2504  end do
2505  end do
2506 
2507  else
2508 
2509  if( nucl_twomey ) then
2510  do j = js, je
2511  do i = is, ie
2512  do k = ks, ke
2513  ! nucleation occurs at only cloud base.
2514  ! if CCN is more than below parcel, nucleation newly occurs
2515  ! effective vertical velocity
2516  if ( flag_nucleation(k,i,j) .AND. & ! large scale upward motion region and saturated
2517  tem(k,i,j) > tem_ccn_low .AND. &
2518  nc_new(k,i,j) > rhoq(i_nc,k,i,j) ) then
2519  dlcdt_max = (rhoq(i_qv,k,i,j) - esw(k,i,j)/(rvap*tem(k,i,j)))*rdt
2520  dncdt_max = dlcdt_max/xc_min
2521  dnc_new = nc_new(k,i,j)-rhoq(i_nc,k,i,j)
2522  pq(i_ncccn,k,i,j) = min( dncdt_max, dnc_new*rdt )
2523  pq(i_lcccn,k,i,j) = min( dlcdt_max, xc_min*pq(i_ncccn,k,i,j) )
2524  else
2525  pq(i_ncccn,k,i,j) = 0.0_rp
2526  pq(i_lcccn,k,i,j) = 0.0_rp
2527  end if
2528  end do
2529  end do
2530  end do
2531  else
2532  do j = js, je
2533  do i = is, ie
2534  do k = ks, ke
2535  ! effective vertical velocity
2536  if( tem(k,i,j) > tem_ccn_low .AND. &
2537  nc_new(k,i,j) > rhoq(i_nc,k,i,j) ) then
2538  dlcdt_max = (rhoq(i_qv,k,i,j) - esw(k,i,j)/(rvap*tem(k,i,j)))*rdt
2539  dncdt_max = dlcdt_max/xc_min
2540  dnc_new = nc_new(k,i,j)-rhoq(i_nc,k,i,j)
2541  pq(i_ncccn,k,i,j) = min( dncdt_max, dnc_new*rdt )
2542  pq(i_lcccn,k,i,j) = min( dlcdt_max, xc_min*pq(i_ncccn,k,i,j) )
2543  else
2544  pq(i_ncccn,k,i,j) = 0.0_rp
2545  pq(i_lcccn,k,i,j) = 0.0_rp
2546  end if
2547  end do
2548  end do
2549  end do
2550  endif
2551  endif
2552 
2553  !
2554  ! ice nucleation
2555  !
2556  ! +++ NOTE ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2557  ! Based on Phillips etal.(2006).
2558  ! However this approach doesn't diagnose Ni itself but diagnose tendency.
2559  ! Original approach adjust Ni instantaneously .
2560  ! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2561  do j = js, je
2562  do i = is, ie
2563  do k = ks, ke
2564  dz = z(k) - z_below(k,i,j)
2565  w_dssidz(k,i,j) = velz(k,i,j)*(ssi(k,i,j) - ssi_below(k,i,j))/dz ! 09/04/14 [Add] T.Mitsui
2566  dssidt_rad(k,i,j) = -rhoq(i_qv,k,i,j)/(rho(k,i,j)*qsi(k,i,j)*qsi(k,i,j))*dqsidtem_rho(k,i,j)*dtdt_rad(k,i,j)
2567  dli_max = (rhoq(i_qv,k,i,j) - esi(k,i,j)/(rvap*tem(k,i,j)))*rdt
2568  dni_max = min( dli_max/xi_ccn, (in_max-rhoq(i_ni,k,i,j))*rdt )
2569  wdssi = min( w_dssidz(k,i,j)+dssidt_rad(k,i,j), 0.01_rp)
2570  wssi = min( ssi(k,i,j), ssi_max)
2571  ! SB06(34),(35)
2572  if( ( wdssi > eps ) .AND. & !
2573  (tem(k,i,j) < 273.15_rp ) .AND. & !
2574  (rhoq(i_ni,k,i,j) < in_max ) .AND. &
2575  (wssi >= eps ) )then !
2576 ! PNIccn(k,i,j) = min(dni_max, c_in_map(1,i,j)*bm_M92*nm_M92*0.3_RP*exp(0.3_RP*bm_M92*(wssi-0.1_RP))*wdssi)
2577  if( inucl_w ) then
2578  pq(i_niccn,k,i,j) = min(dni_max, c_in*bm_m92*nm_m92*0.3_rp*exp(0.3_rp*bm_m92*(wssi-0.1_rp))*wdssi)
2579  else
2580  pq(i_niccn,k,i,j) = min(dni_max, max(c_in*nm_m92*exp(0.3_rp*bm_m92*(wssi-0.1_rp) )-rhoq(i_ni,k,i,j),0.0_rp )*rdt )
2581  endif
2582  pq(i_liccn,k,i,j) = min(dli_max, pq(i_niccn,k,i,j)*xi_ccn )
2583  ! only for output
2584 ! dni_ratio(k,i,j) = dssidt_rad(k,i,j)/( w_dssidz(k,i,j)+dssidt_rad(k,i,j) )
2585  else
2586  pq(i_niccn,k,i,j) = 0.0_rp
2587  pq(i_liccn,k,i,j) = 0.0_rp
2588  end if
2589  end do
2590  end do
2591  end do
2592 
2593  return
2594  end subroutine nucleation_kij
2595  !----------------------------
2596  subroutine ice_multiplication_kij( &
2597  PQ, & ! out
2598  Pac, & ! in
2599  tem, rhoq, xq ) ! in
2600 
2601  ! ice multiplication by splintering
2602  ! we consider Hallet-Mossop process
2603  use scale_specfunc, only: &
2604  gammafunc => sf_gamma
2605  use scale_tracer, only: &
2606  qa
2607  implicit none
2608  real(RP), intent(inout):: PQ(PQ_MAX,KA,IA,JA)
2609  !
2610  real(RP), intent(in) :: Pac(Pac_MAX,KA,IA,JA)
2611  real(RP), intent(in) :: tem(KA,IA,JA)
2612  real(RP), intent(in) :: rhoq(I_QV:I_NG,KA,IA,JA)
2613  real(RP), intent(in) :: xq(HYDRO_MAX,KA,IA,JA)
2614  !
2615  logical, save :: flag_first = .true.
2616  ! production of (350.d3 ice particles)/(cloud riming [g]) => 350*d6 [/kg]
2617  real(RP), parameter :: pice = 350.0e+6_rp
2618  ! production of (1 ice particle)/(250 cloud particles riming)
2619  real(RP), parameter :: pnc = 250.0_rp
2620  real(RP), parameter :: rc_cr= 12.e-6_rp ! critical size[micron]
2621  ! temperature factor
2622  real(RP) :: fp
2623  ! work for incomplete gamma function
2624  real(RP), save :: xc_cr ! mass[kg] of cloud with r=critical size[micron]
2625  real(RP), save :: alpha ! slope parameter of gamma function
2626  real(RP), save :: gm, lgm ! gamma(alpha), log(gamma(alpha))
2627  real(RP) :: igm ! in complete gamma(x,alpha)
2628  real(RP) :: x
2629  ! coefficient of expansion using in calculation of igm
2630  real(RP) :: a0,a1,a2,a3,a4,a5
2631  real(RP) :: a6,a7,a8,a9,a10
2632  real(RP) :: an1,an2,b0,b1,b2,c0,c1,c2
2633  real(RP) :: d0,d1,d2,e1,e2,h0,h1,h2
2634  real(RP), parameter :: eps=1.0e-30_rp
2635  ! number of cloud droplets larger than 12 micron(radius).
2636  real(RP) :: n12
2637  !
2638  real(RP) :: wn, wni, wns, wng
2639  integer :: i, j, k
2640  !
2641  if( flag_first )then
2642  flag_first = .false.
2643  ! work for Incomplete Gamma function
2644  xc_cr = (2.0_rp*rc_cr/a_m(i_mp_qc))**(1.0_rp/b_m(i_mp_qc))
2645  alpha = (nu(i_mp_qc)+1.0_rp)/mu(i_mp_qc)
2646  gm = gammafunc(alpha)
2647  lgm = log(gm)
2648  end if
2649  !
2650  do j = js, je
2651  do i = is, ie
2652  do k = ks, ke
2653  ! Here we assume particle temperature is same as environment temperature.
2654  ! If you want to treat in a better manner,
2655  ! you can diagnose with eq.(64) in CT(86)
2656  if (tem(k,i,j) > 270.16_rp)then
2657  fp = 0.0_rp
2658  else if(tem(k,i,j) >= 268.16_rp)then
2659  fp = (270.16_rp-tem(k,i,j))*0.5_rp
2660  else if(tem(k,i,j) >= 265.16_rp)then
2661  fp = (tem(k,i,j)-265.16_rp)*0.333333333_rp
2662  else
2663  fp = 0.0_rp
2664  end if
2665  ! Approximation of Incomplete Gamma function
2666  ! Here we calculate with algorithm by Numerical Recipes.
2667  ! This approach is based on eq.(78) in Cotton etal.(1986),
2668  ! but more accurate and expanded for Generalized Gamma Distribution.
2669  x = coef_lambda(i_mp_qc)*(xc_cr/xq(i_mp_qc,k,i,j))**mu(i_mp_qc)
2670  !
2671  if(x<1.e-2_rp*alpha)then ! negligible
2672  igm = 0.0_rp
2673  else if(x<alpha+1.0_rp)then ! series expansion
2674  ! 10th-truncation is enough for cloud droplet.
2675  a0 = 1.0_rp/alpha ! n=0
2676  a1 = a0*x/(alpha+1.0_rp) ! n=1
2677  a2 = a1*x/(alpha+2.0_rp) ! n=2
2678  a3 = a2*x/(alpha+3.0_rp) ! n=3
2679  a4 = a3*x/(alpha+4.0_rp) ! n=4
2680  a5 = a4*x/(alpha+5.0_rp) ! n=5
2681  a6 = a5*x/(alpha+6.0_rp) ! n=6
2682  a7 = a6*x/(alpha+7.0_rp) ! n=7
2683  a8 = a7*x/(alpha+8.0_rp) ! n=8
2684  a9 = a8*x/(alpha+9.0_rp) ! n=9
2685  a10 = a9*x/(alpha+10.0_rp) ! n=10
2686  igm = (a0+a1+a2+a3+a4+a5+a6+a7+a8+a9+a10)*exp( -x + alpha*log(x) - lgm )
2687  else if(x<alpha*1.d2) then ! continued fraction expansion
2688  ! 2nd-truncation is enough for cloud droplet.
2689  ! setup
2690  b0 = x+1.0_rp-alpha
2691  c0 = 1.0_rp/eps
2692  d0 = 1.0_rp/b0
2693  h0 = d0
2694  ! n=1
2695  an1 = -(1.0_rp-alpha)
2696  b1 = b0 + 2.0_rp
2697  d1 = 1.0_rp/(an1*d0+b1)
2698  c1 = b1+an1/c0
2699  e1 = d1*c1
2700  h1 = h0*e1
2701  ! n=2
2702  an2 = -2.0_rp*(2.0_rp-alpha)
2703  b2 = b1 + 2.0_rp
2704  d2 = 1.0_rp/(an2*d1+b2)
2705  c2 = b2+an2/c1
2706  e2 = d2*c2
2707  h2 = h1*e2
2708  !
2709  igm = 1.0_rp - exp( -x + alpha*log(x) - lgm )*h2
2710  else ! negligible
2711  igm = 1.0_rp
2712  end if
2713  ! n12 is number of cloud droplets larger than 12 micron.
2714  n12 = rhoq(i_nc,k,i,j)*(1.0_rp-igm)
2715  ! eq.(82) CT(86)
2716  wn = (pice + n12/((rhoq(i_qc,k,i,j)+xc_min)*pnc) )*fp ! filtered by xc_min
2717  wni = wn*(-pac(i_liaclc2li,k,i,j) ) ! riming production rate is all negative
2718  wns = wn*(-pac(i_lsaclc2ls,k,i,j) )
2719  wng = wn*(-pac(i_lgaclc2lg,k,i,j) )
2720  pq(i_nispl,k,i,j) = wni+wns+wng
2721  !
2722  pq(i_lsspl,k,i,j) = - wns*xq(i_mp_qi,k,i,j) ! snow => ice
2723  pq(i_lgspl,k,i,j) = - wng*xq(i_mp_qi,k,i,j) ! graupel => ice
2724  !
2725  end do
2726  end do
2727  end do
2728  !
2729  return
2730  end subroutine ice_multiplication_kij
2731  !----------------------------
2732  subroutine mixed_phase_collection_kij( &
2733  ! collection process
2734  Pac, PQ, & ! out
2735  wtem, rhoq, & ! in
2736  xq, dq_xave, vt_xave ) ! in
2737 ! rho ) ! [Add] 11/08/30
2738  use scale_tracer, only: &
2739  qa
2740  use scale_atmos_saturation, only: &
2741  moist_psat_ice => atmos_saturation_psat_ice
2742  implicit none
2743 
2744  !--- mixed-phase collection process
2745  ! And all we set all production term as a negative sign to avoid confusion.
2746  !
2747  real(RP), intent(out):: Pac(Pac_MAX,KA,IA,JA)
2748  !--- partial conversion
2749  real(RP), intent(inout):: PQ(PQ_MAX,KA,IA,JA)
2750  !
2751  real(RP), intent(in) :: wtem(KA,IA,JA)
2752  !--- mass/number concentration[kg/m3]
2753  real(RP), intent(in) :: rhoq(I_QV:I_NG,KA,IA,JA)
2754  ! necessary ?
2755  real(RP), intent(in) :: xq(HYDRO_MAX,KA,IA,JA)
2756  !--- diameter of averaged mass( D(ave x) )
2757  real(RP), intent(in) :: dq_xave(HYDRO_MAX,KA,IA,JA)
2758  !--- terminal velocity of averaged mass( vt(ave x) )
2759  real(RP), intent(in) :: vt_xave(HYDRO_MAX,2,KA,IA,JA)
2760  ! [Add] 11/08/30 T.Mitsui, for autoconversion of ice
2761 ! real(RP), intent(in) :: rho(KA,IA,JA)
2762  !
2763  ! namelist variables
2764  !=== for collection
2765  !--- threshold of diameters to collide with others
2766  real(RP), save :: dc0 = 15.0e-6_rp ! lower threshold of cloud
2767  real(RP), save :: dc1 = 40.0e-6_rp ! upper threshold of cloud
2768  real(RP), save :: di0 = 150.0e-6_rp ! lower threshold of cloud
2769  real(RP), save :: ds0 = 150.0e-6_rp ! lower threshold of cloud
2770  real(RP), save :: dg0 = 150.0e-6_rp ! lower threshold of cloud
2771  !--- standard deviation of terminal velocity[m/s]
2772  real(RP), save :: sigma_c=0.00_rp ! cloud
2773  real(RP), save :: sigma_r=0.00_rp ! rain
2774  real(RP), save :: sigma_i=0.2_rp ! ice
2775  real(RP), save :: sigma_s=0.2_rp ! snow
2776  real(RP), save :: sigma_g=0.00_rp ! graupel
2777  !--- max collection efficiency for cloud
2778  real(RP), save :: E_im = 0.80_rp ! ice max
2779  real(RP), save :: E_sm = 0.80_rp ! snow max
2780  real(RP), save :: E_gm = 1.00_rp ! graupel max
2781  !--- collection efficiency between 2 species
2782  real(RP), save :: E_ir=1.0_rp ! ice x rain
2783  real(RP), save :: E_sr=1.0_rp ! snow x rain
2784  real(RP), save :: E_gr=1.0_rp ! graupel x rain
2785  real(RP), save :: E_ii=1.0_rp ! ice x ice
2786  real(RP), save :: E_si=1.0_rp ! snow x ice
2787  real(RP), save :: E_gi=1.0_rp ! graupel x ice
2788  real(RP), save :: E_ss=1.0_rp ! snow x snow
2789  real(RP), save :: E_gs=1.0_rp ! graupel x snow
2790  real(RP), save :: E_gg=1.0_rp ! graupel x graupel
2791  !=== for partial conversion
2792  !--- flag: 1=> partial conversion to graupel, 0=> no conversion
2793  integer, save :: i_iconv2g=1 ! ice => graupel
2794  integer, save :: i_sconv2g=1 ! snow => graupel
2795  !--- bulk density of graupel
2796  real(RP), save :: rho_g = 900.0_rp ! [kg/m3]
2797  !--- space filling coefficient [%]
2798  real(RP), save :: cfill_i = 0.68_rp ! ice
2799  real(RP), save :: cfill_s = 0.01_rp ! snow
2800  !--- critical diameter for ice conversion
2801  real(RP), save :: di_cri = 500.e-6_rp ! [m]
2802  ! [Add] 10/08/03 T.Mitsui
2803  logical, save :: opt_stick_KS96=.false.
2804  logical, save :: opt_stick_CO86=.false.
2805  real(RP), parameter :: a_dec = 0.883_rp
2806  real(RP), parameter :: b_dec = 0.093_rp
2807  real(RP), parameter :: c_dec = 0.00348_rp
2808  real(RP), parameter :: d_dec = 4.5185e-5_rp
2809  !
2810  logical, save :: flag_first = .true.
2811  namelist /nm_mp_sn14_collection/ &
2812  dc0, dc1, di0, ds0, dg0, &
2813  sigma_c, sigma_r, sigma_i, sigma_s, sigma_g, &
2814  opt_stick_ks96, &
2815  opt_stick_co86, &
2816  e_im, e_sm, e_gm, &
2817  e_ir, e_sr, e_gr, e_ii, e_si, e_gi, e_ss, e_gs, e_gg, &
2818  i_iconv2g, i_sconv2g, rho_g, cfill_i, cfill_s, di_cri
2819  !
2820  real(RP) :: tem(KA,IA,JA)
2821  !
2822  !--- collection efficency of each specie
2823  real(RP) :: E_c, E_r, E_i, E_s, E_g !
2824  real(RP) :: E_ic, E_sc, E_gc !
2825  !--- sticking efficiency
2826  real(RP) :: E_stick(KA,IA,JA)
2827  ! [Add] 10/08/03 T.Mitsui
2828  real(RP) :: temc, temc2, temc3
2829  real(RP) :: E_dec
2830  real(RP) :: esi_rat
2831  real(RP) :: esi(KA,IA,JA)
2832  !
2833  real(RP) :: temc_p, temc_m ! celcius tem.
2834  ! [Add] 11/08/30 T.Mitsui, estimation of autoconversion time
2835 ! real(RP) :: ci_aut(KA,IA,JA)
2836 ! real(RP) :: taui_aut(KA,IA,JA)
2837 ! real(RP) :: tau_sce(KA,IA,JA)
2838  !--- DSD averaged diameter for each species
2839  real(RP) :: ave_dc ! cloud
2840 ! real(RP) :: ave_dr ! rain
2841  real(RP) :: ave_di ! ice
2842  real(RP) :: ave_ds ! snow
2843  real(RP) :: ave_dg ! graupel
2844  !--- coefficient of collection equations(L:mass, N:number)
2845  real(RP) :: coef_acc_LCI, coef_acc_NCI ! cloud - cloud ice
2846  real(RP) :: coef_acc_LCS, coef_acc_NCS ! cloud - snow
2847  !
2848  real(RP) :: coef_acc_LCG, coef_acc_NCG ! cloud - graupel
2849  real(RP) :: coef_acc_LRI_I, coef_acc_NRI_I ! rain - cloud ice
2850  real(RP) :: coef_acc_LRI_R, coef_acc_NRI_R ! rain - cloud ice
2851  real(RP) :: coef_acc_LRS_S, coef_acc_NRS_S ! rain - snow
2852  real(RP) :: coef_acc_LRS_R, coef_acc_NRS_R ! rain - snow
2853  real(RP) :: coef_acc_LRG, coef_acc_NRG ! rain - graupel
2854  real(RP) :: coef_acc_LII, coef_acc_NII ! cloud ice - cloud ice
2855  real(RP) :: coef_acc_LIS, coef_acc_NIS ! cloud ice - snow
2856  real(RP) :: coef_acc_NSS ! snow - snow
2857  real(RP) :: coef_acc_NGG ! grauepl - graupel
2858  real(RP) :: coef_acc_LSG, coef_acc_NSG ! snow - graupel
2859  !--- (diameter) x (diameter)
2860  real(RP) :: dcdc, dcdi, dcds, dcdg
2861  real(RP) :: drdr, drdi, drds, drdg
2862  real(RP) :: didi, dids, didg
2863  real(RP) :: dsds, dsdg
2864  real(RP) :: dgdg
2865  !--- (terminal velocity) x (terminal velocity)
2866  real(RP) :: vcvc, vcvi, vcvs, vcvg
2867  real(RP) :: vrvr, vrvi, vrvs, vrvg
2868  real(RP) :: vivi, vivs, vivg
2869  real(RP) :: vsvs, vsvg
2870  real(RP) :: vgvg
2871  !
2872  real(RP) :: wx_cri, wx_crs
2873  real(RP) :: coef_emelt
2874  real(RP) :: w1
2875 
2876  real(RP) :: sw
2877  !
2878  integer :: i, j, k
2879  !
2880  if( flag_first )then
2881  rewind( io_fid_conf )
2882  read( io_fid_conf, nml=nm_mp_sn14_collection, end=100 )
2883 100 if( io_nml ) write(io_fid_nml,nml=nm_mp_sn14_collection)
2884  flag_first = .false.
2885  end if
2886  !
2887  ! [Add] 10/08/03 T.Mitsui
2888  do j = js, je
2889  do i = is, ie
2890  do k = ks, ke
2891  tem(k,i,j) = max( wtem(k,i,j), tem_min ) ! 11/08/30 T.Mitsui
2892  end do
2893  end do
2894  end do
2895 
2896  call moist_psat_ice( esi, tem )
2897 
2898  if( opt_stick_ks96 )then
2899  do j = js, je
2900  do i = is, ie
2901  do k = ks, ke
2902  ! Khain and Sednev (1996), eq.(3.15)
2903  temc = tem(k,i,j) - t00
2904  temc2 = temc*temc
2905  temc3 = temc2*temc
2906  e_dec = max(0.0_rp, a_dec + b_dec*temc + c_dec*temc2 + d_dec*temc3 )
2907  esi_rat = rhoq(i_qv,k,i,j)*rvap*tem(k,i,j)/esi(k,i,j)
2908  e_stick(k,i,j) = min(1.0_rp, e_dec*esi_rat)
2909  end do
2910  end do
2911  end do
2912  else if( opt_stick_co86 )then
2913  do j = js, je
2914  do i = is, ie
2915  do k = ks, ke
2916  ! [Add] 11/08/30 T.Mitsui, Cotton et al. (1986)
2917  temc = min(tem(k,i,j) - t00,0.0_rp)
2918  w1 = 0.035_rp*temc-0.7_rp
2919  e_stick(k,i,j) = 10._rp**w1
2920  end do
2921  end do
2922  end do
2923  else
2924  do j = js, je
2925  do i = is, ie
2926  do k = ks, ke
2927  ! Lin et al. (1983)
2928  temc_m = min(tem(k,i,j) - t00,0.0_rp) ! T < 273.15
2929  e_stick(k,i,j) = exp(0.09_rp*temc_m)
2930  end do
2931  end do
2932  end do
2933  end if
2934  !
2935  profile_start("sn14_collection")
2936 !OCL NOSIMD
2937  do j = js, je
2938  do i = is, ie
2939  do k = ks, ke
2940  !
2941 ! temc_m = min(tem(k,i,j) - T00,0.0_RP) ! T < 273.15
2942  temc_p = max(tem(k,i,j) - t00,0.0_rp) ! T > 273.15
2943  ! averaged diameter using SB06(82)
2944  ave_dc = coef_d(i_mp_qc)*xq(i_mp_qc,k,i,j)**b_m(i_mp_qc)
2945  ave_di = coef_d(i_mp_qi)*xq(i_mp_qi,k,i,j)**b_m(i_mp_qi)
2946  ave_ds = coef_d(i_mp_qs)*xq(i_mp_qs,k,i,j)**b_m(i_mp_qs)
2947  ave_dg = coef_d(i_mp_qg)*xq(i_mp_qg,k,i,j)**b_m(i_mp_qg)
2948  !------------------------------------------------------------------------
2949  ! coellection efficiency are given as follows
2950  e_c = max(0.0_rp, min(1.0_rp, (ave_dc-dc0)/(dc1-dc0) ))
2951  sw = 0.5_rp - sign(0.5_rp, di0-ave_di) ! if(ave_di>di0)then sw=1
2952  e_i = e_im * sw
2953  sw = 0.5_rp - sign(0.5_rp, ds0-ave_ds) ! if(ave_ds>ds0)then sw=1
2954  e_s = e_sm * sw
2955  sw = 0.5_rp - sign(0.5_rp, dg0-ave_dg) ! if(ave_dg>dg0)then sw=1
2956  e_g = e_gm * sw
2957  e_ic = e_i*e_c
2958  e_sc = e_s*e_c
2959  e_gc = e_g*e_c
2960  !------------------------------------------------------------------------
2961  ! Collection: a collects b ( assuming particle size a>b )
2962  dcdc = dq_xave(i_mp_qc,k,i,j) * dq_xave(i_mp_qc,k,i,j)
2963  drdr = dq_xave(i_mp_qr,k,i,j) * dq_xave(i_mp_qr,k,i,j)
2964  didi = dq_xave(i_mp_qi,k,i,j) * dq_xave(i_mp_qi,k,i,j)
2965  dsds = dq_xave(i_mp_qs,k,i,j) * dq_xave(i_mp_qs,k,i,j)
2966  dgdg = dq_xave(i_mp_qg,k,i,j) * dq_xave(i_mp_qg,k,i,j)
2967  dcdi = dq_xave(i_mp_qc,k,i,j) * dq_xave(i_mp_qi,k,i,j)
2968  dcds = dq_xave(i_mp_qc,k,i,j) * dq_xave(i_mp_qs,k,i,j)
2969  dcdg = dq_xave(i_mp_qc,k,i,j) * dq_xave(i_mp_qg,k,i,j)
2970  drdi = dq_xave(i_mp_qr,k,i,j) * dq_xave(i_mp_qi,k,i,j)
2971  drds = dq_xave(i_mp_qr,k,i,j) * dq_xave(i_mp_qs,k,i,j)
2972  drdg = dq_xave(i_mp_qr,k,i,j) * dq_xave(i_mp_qg,k,i,j)
2973  dids = dq_xave(i_mp_qi,k,i,j) * dq_xave(i_mp_qs,k,i,j)
2974 ! didg = dq_xave(I_mp_QI,k,i,j) * dq_xave(I_mp_QG,k,i,j)
2975  dsdg = dq_xave(i_mp_qs,k,i,j) * dq_xave(i_mp_qg,k,i,j)
2976  !
2977  vcvc = vt_xave(i_mp_qc,2,k,i,j)* vt_xave(i_mp_qc,2,k,i,j)
2978  vrvr = vt_xave(i_mp_qr,2,k,i,j)* vt_xave(i_mp_qr,2,k,i,j)
2979  vivi = vt_xave(i_mp_qi,2,k,i,j)* vt_xave(i_mp_qi,2,k,i,j)
2980  vsvs = vt_xave(i_mp_qs,2,k,i,j)* vt_xave(i_mp_qs,2,k,i,j)
2981  vgvg = vt_xave(i_mp_qg,2,k,i,j)* vt_xave(i_mp_qg,2,k,i,j)
2982  vcvi = vt_xave(i_mp_qc,2,k,i,j)* vt_xave(i_mp_qi,2,k,i,j)
2983  vcvs = vt_xave(i_mp_qc,2,k,i,j)* vt_xave(i_mp_qs,2,k,i,j)
2984  vcvg = vt_xave(i_mp_qc,2,k,i,j)* vt_xave(i_mp_qg,2,k,i,j)
2985  vrvi = vt_xave(i_mp_qr,2,k,i,j)* vt_xave(i_mp_qi,2,k,i,j)
2986  vrvs = vt_xave(i_mp_qr,2,k,i,j)* vt_xave(i_mp_qs,2,k,i,j)
2987  vrvg = vt_xave(i_mp_qr,2,k,i,j)* vt_xave(i_mp_qg,2,k,i,j)
2988  vivs = vt_xave(i_mp_qi,2,k,i,j)* vt_xave(i_mp_qs,2,k,i,j)
2989 ! vivg = vt_xave(I_mp_QI,2,k,i,j)* vt_xave(I_mp_QG,2,k,i,j)
2990  vsvg = vt_xave(i_mp_qs,2,k,i,j)* vt_xave(i_mp_qg,2,k,i,j)
2991  !------------------------------------------------------------------------
2992  !
2993  !+++ pattern 1: a + b => a (a>b)
2994  ! (i-c, s-c, g-c, s-i, g-r, s-g)
2995  !------------------------------------------------------------------------
2996  ! cloud-ice => ice
2997  ! reduction term of cloud
2998  coef_acc_lci = &
2999  ( delta_b1(i_mp_qc)*dcdc + delta_ab1(i_mp_qi,i_mp_qc)*dcdi + delta_b0(i_mp_qi)*didi ) &
3000  * ( theta_b1(i_mp_qc)*vcvc - theta_ab1(i_mp_qi,i_mp_qc)*vcvi + theta_b0(i_mp_qi)*vivi &
3001  + sigma_i + sigma_c )**0.5_rp
3002  coef_acc_nci = &
3003  ( delta_b0(i_mp_qc)*dcdc + delta_ab0(i_mp_qi,i_mp_qc)*dcdi + delta_b0(i_mp_qi)*didi ) &
3004  * ( theta_b0(i_mp_qc)*vcvc - theta_ab0(i_mp_qi,i_mp_qc)*vcvi + theta_b0(i_mp_qi)*vivi &
3005  + sigma_i + sigma_c )**0.5_rp
3006  pac(i_liaclc2li,k,i,j)= -0.25_rp*pi*e_ic*rhoq(i_ni,k,i,j)*rhoq(i_qc,k,i,j)*coef_acc_lci
3007  pac(i_niacnc2ni,k,i,j)= -0.25_rp*pi*e_ic*rhoq(i_ni,k,i,j)*rhoq(i_nc,k,i,j)*coef_acc_nci
3008  ! cloud-snow => snow
3009  ! reduction term of cloud
3010  coef_acc_lcs = &
3011  ( delta_b1(i_mp_qc)*dcdc + delta_ab1(i_mp_qs,i_mp_qc)*dcds + delta_b0(i_mp_qs)*dsds ) &
3012  * ( theta_b1(i_mp_qc)*vcvc - theta_ab1(i_mp_qs,i_mp_qc)*vcvs + theta_b0(i_mp_qs)*vsvs &
3013  + sigma_s + sigma_c )**0.5_rp
3014  coef_acc_ncs = &
3015  ( delta_b0(i_mp_qc)*dcdc + delta_ab0(i_mp_qs,i_mp_qc)*dcds + delta_b0(i_mp_qs)*dsds ) &
3016  * ( theta_b0(i_mp_qc)*vcvc - theta_ab0(i_mp_qs,i_mp_qc)*vcvs + theta_b0(i_mp_qs)*vsvs &
3017  + sigma_s + sigma_c )**0.5_rp
3018  pac(i_lsaclc2ls,k,i,j)= -0.25_rp*pi*e_sc*rhoq(i_ns,k,i,j)*rhoq(i_qc,k,i,j)*coef_acc_lcs
3019  pac(i_nsacnc2ns,k,i,j)= -0.25_rp*pi*e_sc*rhoq(i_ns,k,i,j)*rhoq(i_nc,k,i,j)*coef_acc_ncs
3020  ! cloud-graupel => graupel
3021  ! reduction term of cloud
3022  coef_acc_lcg = &
3023  ( delta_b1(i_mp_qc)*dcdc + delta_ab1(i_mp_qg,i_mp_qc)*dcdg + delta_b0(i_mp_qg)*dgdg ) &
3024  * ( theta_b1(i_mp_qc)*vcvc - theta_ab1(i_mp_qg,i_mp_qc)*vcvg + theta_b0(i_mp_qg)*vgvg &
3025  + sigma_g + sigma_c )**0.5_rp
3026  coef_acc_ncg = &
3027  ( delta_b0(i_mp_qc)*dcdc + delta_ab0(i_mp_qg,i_mp_qc)*dcdg + delta_b0(i_mp_qg)*dgdg ) &
3028  * ( theta_b0(i_mp_qc)*vcvc - theta_ab0(i_mp_qg,i_mp_qc)*vcvg + theta_b0(i_mp_qg)*vgvg &
3029  + sigma_g + sigma_c )**0.5_rp
3030  pac(i_lgaclc2lg,k,i,j)= -0.25_rp*pi*e_gc*rhoq(i_ng,k,i,j)*rhoq(i_qc,k,i,j)*coef_acc_lcg
3031  pac(i_ngacnc2ng,k,i,j)= -0.25_rp*pi*e_gc*rhoq(i_ng,k,i,j)*rhoq(i_nc,k,i,j)*coef_acc_ncg
3032  ! snow-graupel => graupel
3033  coef_acc_lsg = &
3034  ( delta_b1(i_mp_qs)*dsds + delta_ab1(i_mp_qg,i_mp_qs)*dsdg + delta_b0(i_mp_qg)*dgdg ) &
3035  * ( theta_b1(i_mp_qs)*vsvs - theta_ab1(i_mp_qg,i_mp_qs)*vsvg + theta_b0(i_mp_qg)*vgvg &
3036  + sigma_g + sigma_s )**0.5_rp
3037  coef_acc_nsg = &
3038  ( delta_b0(i_mp_qs)*dsds + delta_ab0(i_mp_qg,i_mp_qs)*dsdg + delta_b0(i_mp_qg)*dgdg ) &
3039  ! [fix] T.Mitsui 08/05/08
3040  * ( theta_b0(i_mp_qs)*vsvs - theta_ab0(i_mp_qg,i_mp_qs)*vsvg + theta_b0(i_mp_qg)*vgvg &
3041  + sigma_g + sigma_s )**0.5_rp
3042  pac(i_lgacls2lg,k,i,j)= -0.25_rp*pi*e_stick(k,i,j)*e_gs*rhoq(i_ng,k,i,j)*rhoq(i_qs,k,i,j)*coef_acc_lsg
3043  pac(i_ngacns2ng,k,i,j)= -0.25_rp*pi*e_stick(k,i,j)*e_gs*rhoq(i_ng,k,i,j)*rhoq(i_ns,k,i,j)*coef_acc_nsg
3044  !------------------------------------------------------------------------
3045  ! ice-snow => snow
3046  ! reduction term of ice
3047  coef_acc_lis = &
3048  ( delta_b1(i_mp_qi)*didi + delta_ab1(i_mp_qs,i_mp_qi)*dids + delta_b0(i_mp_qs)*dsds ) &
3049  * ( theta_b1(i_mp_qi)*vivi - theta_ab1(i_mp_qs,i_mp_qi)*vivs + theta_b0(i_mp_qs)*vsvs &
3050  + sigma_i + sigma_s )**0.5_rp
3051  coef_acc_nis = &
3052  ( delta_b0(i_mp_qi)*didi + delta_ab0(i_mp_qs,i_mp_qi)*dids + delta_b0(i_mp_qs)*dsds ) &
3053  * ( theta_b0(i_mp_qi)*vivi - theta_ab0(i_mp_qs,i_mp_qi)*vivs + theta_b0(i_mp_qs)*vsvs &
3054  + sigma_i + sigma_s )**0.5_rp
3055  pac(i_liacls2ls,k,i,j)= -0.25_rp*pi*e_stick(k,i,j)*e_si*rhoq(i_ns,k,i,j)*rhoq(i_qi,k,i,j)*coef_acc_lis
3056  pac(i_niacns2ns,k,i,j)= -0.25_rp*pi*e_stick(k,i,j)*e_si*rhoq(i_ns,k,i,j)*rhoq(i_ni,k,i,j)*coef_acc_nis
3057  !
3058  sw = sign(0.5_rp, t00-tem(k,i,j)) + 0.5_rp
3059  ! if ( tem(k,i,j) <= T00 )then
3060  ! rain-graupel => graupel
3061  ! reduction term of rain
3062  ! sw = 1
3063  ! else
3064  ! rain-graupel => rain
3065  ! reduction term of graupel
3066  ! sw = 0
3067  coef_acc_lrg = &
3068  ( ( delta_b1(i_mp_qr)*drdr + delta_ab1(i_mp_qg,i_mp_qr)*drdg + delta_b0(i_mp_qg)*dgdg ) * sw &
3069  + ( delta_b1(i_mp_qg)*dgdg + delta_ab1(i_mp_qr,i_mp_qg)*drdg + delta_b0(i_mp_qr)*drdr ) * (1.0_rp-sw) ) &
3070  * sqrt( ( theta_b1(i_mp_qr)*vrvr - theta_ab1(i_mp_qg,i_mp_qr)*vrvg + theta_b0(i_mp_qg)*vgvg ) * sw &
3071  + ( theta_b1(i_mp_qg)*vgvg - theta_ab1(i_mp_qr,i_mp_qg)*vrvg + theta_b0(i_mp_qr)*vrvr ) * (1.0_rp-sw) &
3072  + sigma_r + sigma_g )
3073  pac(i_lraclg2lg,k,i,j) = -0.25_rp*pi*e_gr*coef_acc_lrg &
3074  * ( rhoq(i_ng,k,i,j)*rhoq(i_qr,k,i,j) * sw &
3075  + rhoq(i_nr,k,i,j)*rhoq(i_qg,k,i,j) * (1.0_rp-sw) )
3076  coef_acc_nrg = &
3077  ( delta_b0(i_mp_qr)*drdr + delta_ab0(i_mp_qg,i_mp_qr)*drdg + delta_b0(i_mp_qg)*dgdg ) &
3078  * ( theta_b0(i_mp_qr)*vrvr - theta_ab0(i_mp_qg,i_mp_qr)*vrvg + theta_b0(i_mp_qg)*vgvg &
3079  + sigma_r + sigma_g )**0.5_rp
3080  pac(i_nracng2ng,k,i,j) = -0.25_rp*pi*e_gr*rhoq(i_ng,k,i,j)*rhoq(i_nr,k,i,j)*coef_acc_nrg
3081  !
3082  !------------------------------------------------------------------------
3083  !
3084  !+++ pattern 2: a + b => c (a>b)
3085  ! (r-i,r-s)
3086  !------------------------------------------------------------------------
3087  ! rain-ice => graupel
3088  ! reduction term of ice
3089  coef_acc_lri_i = &
3090  ( delta_b1(i_mp_qi)*didi + delta_ab1(i_mp_qr,i_mp_qi)*drdi + delta_b0(i_mp_qr)*drdr ) &
3091  * ( theta_b1(i_mp_qi)*vivi - theta_ab1(i_mp_qr,i_mp_qi)*vrvi + theta_b0(i_mp_qr)*vrvr &
3092  + sigma_r + sigma_i )**0.5_rp
3093  coef_acc_nri_i = &
3094  ( delta_b0(i_mp_qi)*didi + delta_ab0(i_mp_qr,i_mp_qi)*drdi + delta_b0(i_mp_qr)*drdr ) &
3095  * ( theta_b0(i_mp_qi)*vivi - theta_ab0(i_mp_qr,i_mp_qi)*vrvi + theta_b0(i_mp_qr)*vrvr &
3096  + sigma_r + sigma_i )**0.5_rp
3097  pac(i_lracli2lg_i,k,i,j)= -0.25_rp*pi*e_ir*rhoq(i_nr,k,i,j)*rhoq(i_qi,k,i,j)*coef_acc_lri_i
3098  pac(i_nracni2ng_i,k,i,j)= -0.25_rp*pi*e_ir*rhoq(i_nr,k,i,j)*rhoq(i_ni,k,i,j)*coef_acc_nri_i
3099  ! reduction term of rain
3100  coef_acc_lri_r = &
3101  ( delta_b1(i_mp_qr)*drdr + delta_ab1(i_mp_qi,i_mp_qr)*drdi + delta_b0(i_mp_qi)*didi ) &
3102  * ( theta_b1(i_mp_qr)*vrvr - theta_ab1(i_mp_qi,i_mp_qr)*vrvi + theta_b0(i_mp_qi)*vivi &
3103  + sigma_r + sigma_i )**0.5_rp
3104  coef_acc_nri_r = &
3105  ( delta_b0(i_mp_qr)*drdr + delta_ab0(i_mp_qi,i_mp_qr)*drdi + delta_b0(i_mp_qi)*didi ) &
3106  * ( theta_b0(i_mp_qr)*vrvr - theta_ab0(i_mp_qi,i_mp_qr)*vrvi + theta_b0(i_mp_qi)*vivi &
3107  + sigma_r + sigma_i )**0.5_rp
3108  pac(i_lracli2lg_r,k,i,j)= -0.25_rp*pi*e_ir*rhoq(i_ni,k,i,j)*rhoq(i_qr,k,i,j)*coef_acc_lri_r
3109  pac(i_nracni2ng_r,k,i,j)= -0.25_rp*pi*e_ir*rhoq(i_ni,k,i,j)*rhoq(i_nr,k,i,j)*coef_acc_nri_r
3110  ! rain-snow => graupel
3111  ! reduction term of snow
3112  coef_acc_lrs_s = &
3113  ( delta_b1(i_mp_qs)*dsds + delta_ab1(i_mp_qr,i_mp_qs)*drds + delta_b0(i_mp_qr)*drdr ) &
3114  * ( theta_b1(i_mp_qs)*vsvs - theta_ab1(i_mp_qr,i_mp_qs)*vrvs + theta_b0(i_mp_qr)*vrvr &
3115  + sigma_r + sigma_s )**0.5_rp
3116  coef_acc_nrs_s = &
3117  ( delta_b0(i_mp_qs)*dsds + delta_ab0(i_mp_qr,i_mp_qs)*drds + delta_b0(i_mp_qr)*drdr ) &
3118  * ( theta_b0(i_mp_qs)*vsvs - theta_ab0(i_mp_qr,i_mp_qs)*vrvs + theta_b0(i_mp_qr)*vrvr &
3119  + sigma_r + sigma_s )**0.5_rp
3120  pac(i_lracls2lg_s,k,i,j)= -0.25_rp*pi*e_sr*rhoq(i_nr,k,i,j)*rhoq(i_qs,k,i,j)*coef_acc_lrs_s
3121  pac(i_nracns2ng_s,k,i,j)= -0.25_rp*pi*e_sr*rhoq(i_nr,k,i,j)*rhoq(i_ns,k,i,j)*coef_acc_nrs_s
3122  ! reduction term of rain
3123  coef_acc_lrs_r = &
3124  ( delta_b1(i_mp_qr)*drdr + delta_ab1(i_mp_qs,i_mp_qr)*drds + delta_b0(i_mp_qs)*dsds ) &
3125  * ( theta_b1(i_mp_qr)*vrvr - theta_ab1(i_mp_qs,i_mp_qr)*vrvs + theta_b0(i_mp_qs)*vsvs &
3126  + sigma_r + sigma_s )**0.5_rp
3127  coef_acc_nrs_r = &
3128  ( delta_b0(i_mp_qr)*drdr + delta_ab0(i_mp_qs,i_mp_qr)*drds + delta_b0(i_mp_qs)*dsds ) &
3129  * ( theta_b0(i_mp_qr)*vrvr - theta_ab0(i_mp_qs,i_mp_qr)*vrvs + theta_b0(i_mp_qs)*vsvs &
3130  + sigma_r + sigma_s )**0.5_rp
3131  pac(i_lracls2lg_r,k,i,j)= -0.25_rp*pi*e_sr*rhoq(i_ns,k,i,j)*rhoq(i_qr,k,i,j)*coef_acc_lrs_r
3132  pac(i_nracns2ng_r,k,i,j)= -0.25_rp*pi*e_sr*rhoq(i_ns,k,i,j)*rhoq(i_nr,k,i,j)*coef_acc_nrs_r
3133  !------------------------------------------------------------------------
3134  !
3135  !+++ pattern 3: a + a => b (i-i)
3136  !
3137  !------------------------------------------------------------------------
3138  ! ice-ice ( reduction is double, but includes double-count)
3139  coef_acc_lii = &
3140  ( delta_b0(i_mp_qi)*didi + delta_ab1(i_mp_qi,i_mp_qi)*didi + delta_b1(i_mp_qi)*didi ) &
3141  * ( theta_b0(i_mp_qi)*vivi - theta_ab1(i_mp_qi,i_mp_qi)*vivi + theta_b1(i_mp_qi)*vivi &
3142  + sigma_i + sigma_i )**0.5_rp
3143  coef_acc_nii = &
3144  ( delta_b0(i_mp_qi)*didi + delta_ab0(i_mp_qi,i_mp_qi)*didi + delta_b0(i_mp_qi)*didi ) &
3145  * ( theta_b0(i_mp_qi)*vivi - theta_ab0(i_mp_qi,i_mp_qi)*vivi + theta_b0(i_mp_qi)*vivi &
3146  + sigma_i + sigma_i )**0.5_rp
3147  pac(i_liacli2ls,k,i,j)= -0.25_rp*pi*e_stick(k,i,j)*e_ii*rhoq(i_ni,k,i,j)*rhoq(i_qi,k,i,j)*coef_acc_lii
3148  pac(i_niacni2ns,k,i,j)= -0.25_rp*pi*e_stick(k,i,j)*e_ii*rhoq(i_ni,k,i,j)*rhoq(i_ni,k,i,j)*coef_acc_nii
3149  !
3150 ! ci_aut(k,i,j) = 0.25_RP*pi*E_ii*rhoq(I_NI,k,i,j)*coef_acc_LII
3151 ! taui_aut(k,i,j) = 1._RP/max(E_stick(k,i,j)*ci_aut(k,i,j),1.E-10_RP)
3152 ! tau_sce(k,i,j) = rhoq(I_QI,k,i,j)/max(rhoq(I_QI,k,i,j)+rhoq(I_QS,k,i,j),1.E-10_RP)
3153  !------------------------------------------------------------------------
3154  !
3155  !+++ pattern 4: a + a => a (s-s)
3156  !
3157  !------------------------------------------------------------------------
3158  ! snow-snow => snow
3159  coef_acc_nss = &
3160  ( delta_b0(i_mp_qs)*dsds + delta_ab0(i_mp_qs,i_mp_qs)*dsds + delta_b0(i_mp_qs)*dsds ) &
3161  * ( theta_b0(i_mp_qs)*vsvs - theta_ab0(i_mp_qs,i_mp_qs)*vsvs + theta_b0(i_mp_qs)*vsvs &
3162  + sigma_s + sigma_s )**0.5_rp
3163  pac(i_nsacns2ns,k,i,j)= -0.125_rp*pi*e_stick(k,i,j)*e_ss*rhoq(i_ns,k,i,j)*rhoq(i_ns,k,i,j)*coef_acc_nss
3164  !
3165  ! graupel-grauple => graupel
3166  coef_acc_ngg = &
3167  ( delta_b0(i_mp_qg)*dgdg + delta_ab0(i_mp_qg,i_mp_qg)*dgdg + delta_b0(i_mp_qg)*dgdg ) &
3168  * ( theta_b0(i_mp_qg)*vgvg - theta_ab0(i_mp_qg,i_mp_qg)*vgvg + theta_b0(i_mp_qg)*vgvg &
3169  + sigma_g + sigma_g )**0.5_rp
3170  pac(i_ngacng2ng,k,i,j)= -0.125_rp*pi*e_stick(k,i,j)*e_gg*rhoq(i_ng,k,i,j)*rhoq(i_ng,k,i,j)*coef_acc_ngg
3171  !
3172  !------------------------------------------------------------------------
3173  !--- Partial conversion
3174  ! SB06(70),(71)
3175  ! i_iconv2g: option whether partial conversions work or not
3176  ! ice-cloud => graupel
3177  sw = 0.5_rp - sign(0.5_rp,di_cri-ave_di) ! if( ave_di > di_cri )then sw=1
3178  wx_cri = cfill_i*dwatr/rho_g*( pi/6.0_rp*rho_g*ave_di*ave_di*ave_di/xq(i_mp_qi,k,i,j) - 1.0_rp ) * sw
3179  pq(i_licon,k,i,j) = i_iconv2g * pac(i_liaclc2li,k,i,j)/max(1.0_rp, wx_cri) * sw
3180  pq(i_nicon,k,i,j) = i_iconv2g * pq(i_licon,k,i,j)/xq(i_mp_qi,k,i,j) * sw
3181 
3182  ! snow-cloud => graupel
3183  wx_crs = cfill_s*dwatr/rho_g*( pi/6.0_rp*rho_g*ave_ds*ave_ds*ave_ds/xq(i_mp_qs,k,i,j) - 1.0_rp )
3184  pq(i_lscon,k,i,j) = i_sconv2g * (pac(i_lsaclc2ls,k,i,j))/max(1.0_rp, wx_crs)
3185  pq(i_nscon,k,i,j) = i_sconv2g * pq(i_lscon,k,i,j)/xq(i_mp_qs,k,i,j)
3186  !------------------------------------------------------------------------
3187  !--- enhanced melting( due to collection-freezing of water droplets )
3188  ! originally from Rutledge and Hobbs(1984). eq.(A.21)
3189  ! if T > 273.15 then temc_p=T-273.15, else temc_p=0
3190  ! 08/05/08 [fix] T.Mitsui LHF00 => LHF0
3191  ! melting occurs around T=273K, so LHF0 is suitable both SIMPLE and EXACT,
3192  ! otherwise LHF can have sign both negative(EXACT) and positive(SIMPLE).
3193 !!$ coef_emelt = -CL/LHF00*temc_p
3194  coef_emelt = cl/lhf0*temc_p
3195  ! cloud-graupel
3196  pq(i_lgacm,k,i,j) = coef_emelt*pac(i_lgaclc2lg,k,i,j)
3197  pq(i_ngacm,k,i,j) = pq(i_lgacm,k,i,j)/xq(i_mp_qg,k,i,j)
3198  ! rain-graupel
3199  pq(i_lgarm,k,i,j) = coef_emelt*pac(i_lraclg2lg,k,i,j)
3200  pq(i_ngarm,k,i,j) = pq(i_lgarm,k,i,j)/xq(i_mp_qg,k,i,j)
3201  ! cloud-snow
3202  pq(i_lsacm,k,i,j) = coef_emelt*(pac(i_lsaclc2ls,k,i,j))
3203  pq(i_nsacm,k,i,j) = pq(i_lsacm,k,i,j)/xq(i_mp_qs,k,i,j)
3204  ! rain-snow
3205  pq(i_lsarm,k,i,j) = coef_emelt*(pac(i_lracls2lg_r,k,i,j)+pac(i_lracls2lg_s,k,i,j))
3206  pq(i_nsarm,k,i,j) = pq(i_lsarm,k,i,j)/xq(i_mp_qg,k,i,j) ! collect? might be I_mp_QS
3207  ! cloud-ice
3208  pq(i_liacm,k,i,j) = coef_emelt*pac(i_liaclc2li,k,i,j)
3209  pq(i_niacm,k,i,j) = pq(i_liacm,k,i,j)/xq(i_mp_qi,k,i,j)
3210  ! rain-ice
3211  pq(i_liarm,k,i,j) = coef_emelt*(pac(i_lracli2lg_r,k,i,j)+pac(i_lracli2lg_i,k,i,j))
3212  pq(i_niarm,k,i,j) = pq(i_liarm,k,i,j)/xq(i_mp_qg,k,i,j) ! collect? might be I_mp_QI
3213  end do
3214  end do
3215  end do
3216  profile_stop("sn14_collection")
3217 
3218  !
3219  return
3220  end subroutine mixed_phase_collection_kij
3221  !----------------------------
3222  ! Auto-conversion, Accretion, Self-collection, Break-up
3223  subroutine aut_acc_slc_brk_kij( &
3224  PQ, &
3225  rhoq, xq, dq_xave, &
3226  rho )
3227  use scale_tracer, only: &
3228  qa
3229  implicit none
3230 
3231  real(RP), intent(inout) :: PQ(PQ_MAX,KA,IA,JA)
3232  !
3233  real(RP), intent(in) :: rhoq(I_QV:I_NG,KA,IA,JA)
3234  real(RP), intent(in) :: xq(HYDRO_MAX,KA,IA,JA)
3235  real(RP), intent(in) :: dq_xave(HYDRO_MAX,KA,IA,JA)
3236  real(RP), intent(in) :: rho(KA,IA,JA)
3237  !
3238  ! parameter for autoconversion
3239  real(RP), parameter :: kcc = 4.44e+9_rp ! collision efficiency [m3/kg2/sec]
3240  real(RP), parameter :: tau_min = 1.e-20_rp ! empirical filter by T.Mitsui
3241  real(RP), parameter :: rx_sep = 1.0_rp/x_sep ! 1/x_sep, 10/08/03 [Add] T.Mitsui
3242  !
3243  ! parameter for accretion
3244  real(RP), parameter :: kcr = 5.8_rp ! collision efficiency [m3/kg2/sec]
3245  real(RP), parameter :: thr_acc = 5.e-5_rp ! threshold for universal function original
3246  !
3247  ! parameter for self collection and collison break-up
3248  real(RP), parameter :: krr = 4.33_rp ! k_rr, S08 (35)
3249  real(RP), parameter :: kaprr = 60.7_rp ! kappa_rr, SB06(11)
3250  real(RP), parameter :: kbr = 1000._rp ! k_br, SB06(14)
3251  real(RP), parameter :: kapbr = 2.3e+3_rp ! kappa_br, SB06(15)
3252  real(RP), parameter :: dr_min = 0.35e-3_rp ! minimum diameter, SB06(13)-(15)
3253  !
3254  ! work variables
3255  real(RP) :: coef_nuc0 ! coefficient of number for Auto-conversion
3256  real(RP) :: coef_nuc1 ! mass
3257  real(RP) :: coef_aut0 ! number
3258  real(RP) :: coef_aut1 ! mass
3259  real(RP) :: lwc ! lc+lr
3260  real(RP) :: tau ! conversion ratio: qr/(qc+qr) ranges [0:1]
3261  real(RP) :: rho_fac ! factor of air density
3262  real(RP) :: psi_aut ! Universal function of Auto-conversion
3263  real(RP) :: psi_acc ! Universal function of Accretion
3264  real(RP) :: psi_brk ! Universal function of Breakup
3265  real(RP) :: ddr ! diameter difference from equilibrium
3266  !
3267  integer :: i, j, k
3268  !
3269  coef_nuc0 = (nu(i_mp_qc)+2.0_rp)/(nu(i_mp_qc)+1.0_rp)
3270  coef_nuc1 = (nu(i_mp_qc)+2.0_rp)*(nu(i_mp_qc)+4.0_rp)/(nu(i_mp_qc)+1.0_rp)/(nu(i_mp_qc)+1.0_rp)
3271  coef_aut0 = -kcc*coef_nuc0
3272  coef_aut1 = -kcc/x_sep/20._rp*coef_nuc1
3273  !
3274  do j = js, je
3275  do i = is, ie
3276  do k = ks, ke
3277  lwc = rhoq(i_qr,k,i,j)+rhoq(i_qc,k,i,j)
3278  if( lwc > xc_min )then
3279  tau = max(tau_min, rhoq(i_qr,k,i,j)/lwc)
3280  else
3281  tau = tau_min
3282  end if
3283  rho_fac = sqrt(rho_0/max(rho(k,i,j),rho_min))
3284  !
3285  ! Auto-conversion ( cloud-cloud => rain )
3286  psi_aut = 400._rp*(tau**0.7_rp)*(1.0_rp - (tau**0.7_rp))**3 ! (6) SB06
3287  pq(i_ncaut,k,i,j) = coef_aut0*rhoq(i_qc,k,i,j)*rhoq(i_qc,k,i,j)*rho_fac*rho_fac ! (9) SB06 sc+aut
3288  ! lc = lwc*(1-tau), lr = lwc*tau
3289  pq(i_lcaut,k,i,j) = coef_aut1*lwc*lwc*xq(i_mp_qc,k,i,j)*xq(i_mp_qc,k,i,j) & ! (4) SB06
3290  *((1.0_rp-tau)*(1.0_rp-tau) + psi_aut)*rho_fac*rho_fac !
3291  pq(i_nraut,k,i,j) = -rx_sep*pq(i_lcaut,k,i,j) ! (A7) SB01
3292  !
3293  ! Accretion ( cloud-rain => rain )
3294  psi_acc =(tau/(tau+thr_acc))**4 ! (8) SB06
3295  pq(i_lcacc,k,i,j) = -kcr*rhoq(i_qc,k,i,j)*rhoq(i_qr,k,i,j)*rho_fac*psi_acc ! (7) SB06
3296  pq(i_ncacc,k,i,j) = -kcr*rhoq(i_nc,k,i,j)*rhoq(i_qr,k,i,j)*rho_fac*psi_acc ! (A6) SB01
3297  !
3298  ! Self-collection ( rain-rain => rain )
3299  pq(i_nrslc,k,i,j) = -krr*rhoq(i_nr,k,i,j)*rhoq(i_qr,k,i,j)*rho_fac ! (A.8) SB01
3300  !
3301  ! Collisional breakup of rain
3302  ddr = min(1.e-3_rp, dq_xave(i_mp_qr,k,i,j) - dr_eq )
3303  if (dq_xave(i_mp_qr,k,i,j) < dr_min )then ! negligible
3304  psi_brk = -1.0_rp
3305  pq(i_nrbrk,k,i,j) = 0.0_rp
3306  else if (dq_xave(i_mp_qr,k,i,j) <= dr_eq )then
3307  psi_brk = kbr*ddr + 1.0_rp ! (14) SB06 (+1 is necessary)
3308  pq(i_nrbrk,k,i,j) = - (psi_brk + 1.0_rp)*pq(i_nrslc,k,i,j) ! (13) SB06
3309  else
3310  psi_brk = 2.0_rp*exp(kapbr*ddr) - 1.0_rp ! (15) SB06
3311  pq(i_nrbrk,k,i,j) = - (psi_brk + 1.0_rp)*pq(i_nrslc,k,i,j) ! (13) SB06
3312  end if
3313  !
3314  end do
3315  end do
3316  end do
3317  !
3318  return
3319  end subroutine aut_acc_slc_brk_kij
3320  ! Vapor Deposition, Ice Melting
3321  subroutine dep_vapor_melt_ice_kij( &
3322  PQ, & ! out
3323  rho, tem, pre, qd, & ! in
3324  rhoq, & ! in
3325  esw, esi, & ! in
3326  xq, vt_xave, dq_xave ) ! in
3327  use scale_const, only: &
3328  eps => const_eps
3329  use scale_tracer, only: &
3330  qa
3331  implicit none
3332 
3333  ! Diffusion growth or Evaporation, Sublimation
3334  real(RP), intent(inout) :: PQ(PQ_MAX,KA,IA,JA) ! mass change for cloud, [Add] 09/08/18 T.Mitsui
3335 
3336  real(RP), intent(in) :: rho(KA,IA,JA) ! air density
3337  real(RP), intent(in) :: tem(KA,IA,JA) ! air temperature
3338  real(RP), intent(in) :: pre(KA,IA,JA) ! air pressure
3339  real(RP), intent(in) :: qd(KA,IA,JA) ! mixing ratio of dry air
3340  real(RP), intent(in) :: esw(KA,IA,JA) ! saturation vapor pressure(liquid water)
3341  real(RP), intent(in) :: esi(KA,IA,JA) ! saturation vapor pressure(solid water)
3342  real(RP), intent(in) :: rhoq(I_QV:I_NG,KA,IA,JA)
3343  real(RP), intent(in) :: xq(HYDRO_MAX,KA,IA,JA) ! mean mass
3344  ! Notice following values differ from mean terminal velocity or diameter.
3345  ! mean(vt(x)) /= vt(mean(x)) and mean(D(x)) /= D(mean(x))
3346  ! Following ones are vt(mean(x)) and D(mean(x)).
3347  real(RP), intent(in) :: vt_xave(HYDRO_MAX,2,KA,IA,JA) ! terminal velocity of mean cloud 09/08/18 [Add], T.Mitsui
3348  !
3349  real(RP), intent(in) :: dq_xave(HYDRO_MAX,KA,IA,JA) ! diameter
3350  !
3351  real(RP) :: rho_lim ! limited density 09/08/18 T.Mitsui
3352  real(RP) :: temc_lim ! limited temperature[celsius] 09/08/18 T.Mitsui
3353  real(RP) :: pre_lim ! limited density 09/08/18 T.Mitsui
3354  real(RP) :: temc ! temperature[celsius]
3355 ! real(RP) :: pv ! vapor pressure
3356  real(RP) :: qv ! mixing ratio of water vapor [Add] 09/08/18
3357 ! real(RP) :: ssw ! super saturation ratio(liquid water)
3358 ! real(RP) :: ssi ! super saturation ratio(ice water)
3359  real(RP) :: nua, r_nua ! kinematic viscosity of air
3360  real(RP) :: mua ! viscosity of air
3361  real(RP) :: Kalfa ! thermal conductance
3362  real(RP) :: Dw ! diffusivity of water vapor
3363  real(RP) :: Dt ! diffusivity of heat
3364  real(RP) :: Gw, Gi ! diffusion factor by balance between heat and vapor
3365  real(RP) :: Gwr, Gii, Gis, Gig ! for rain, ice, snow and graupel.
3366  real(RP) :: Gm ! melting factor by balance between heat and vapor
3367  real(RP) :: Nsc_r3 !
3368  ! [Mod] 11/08/30 T.Mitsui, considering large and small branches
3369 ! real(RP) :: Nrecs_r2 ! 09/08/18 [Add] T.Mitsui
3370  real(RP) :: Nrers_r2, Nreis_r2 !
3371  real(RP) :: Nress_r2, Nregs_r2 !
3372 ! real(RP) :: Nrecl_r2 ! 09/08/18 [Add] T.Mitsui
3373  real(RP) :: Nrerl_r2, Nreil_r2 !
3374  real(RP) :: Nresl_r2, Nregl_r2 !
3375  real(RP) :: NscNrer_s, NscNrer_l
3376  real(RP) :: NscNrei_s, NscNrei_l
3377  real(RP) :: NscNres_s, NscNres_l
3378  real(RP) :: NscNreg_s, NscNreg_l
3379  real(RP) :: ventLR_s, ventLR_l
3380  real(RP) :: ventNI_s, ventNI_l, ventLI_s, ventLI_l
3381  real(RP) :: ventNS_s, ventNS_l, ventLS_s, ventLS_l
3382  real(RP) :: ventNG_s, ventNG_l, ventLG_s, ventLG_l
3383  !
3384  real(RP) :: wtr, wti, wts, wtg
3385  real(RP), parameter :: r_14=1.0_rp/1.4_rp
3386  real(RP), parameter :: r_15=1.0_rp/1.5_rp
3387  !
3388  real(RP) :: ventLR
3389  real(RP) :: ventNI, ventLI
3390  real(RP) :: ventNS, ventLS
3391  real(RP) :: ventNG, ventLG
3392  !
3393  real(RP), parameter :: Re_max=1.e+3_rp
3394  real(RP), parameter :: Re_min=1.e-4_rp
3395 
3396  real(RP) :: sw
3397  !
3398  integer :: i, j, k
3399  !
3400  ! Notice,T.Mitsui
3401  ! Vapor deposition and melting would not be solved iteratively to reach equilibrium.
3402  ! Because following phenomena are not adjustment but transition.
3403  ! Just time-scales differ among them.
3404  ! If we would treat more appropreately, there would be time-splitting method to solve each ones.
3405 
3406  profile_start("sn14_dep_vapor")
3407  do j = js, je
3408  do i = is, ie
3409  do k = ks, ke
3410  temc = tem(k,i,j) - t00 ! degC
3411  temc_lim= max(temc, -40._rp ) ! [Add] 09/08/18 T.Mitsui, Pruppacher and Klett(1997),(13-3)
3412  rho_lim = max(rho(k,i,j),rho_min) ! [Add] 09/08/18 T.Mitsui
3413  qv = rhoq(i_qv,k,i,j)/rho_lim
3414  pre_lim = rho_lim*(qd(k,i,j)*rdry + qv*rvap)*(temc_lim+t00) ![Add] 09/08/18 T.Mitsui
3415  !--------------------------------------------------------------------
3416  ! Diffusion growth part is described in detail
3417  ! by Pruppacher and Klett (1997) Sec. 13.2(liquid) and 13.3(solid)
3418  !
3419  ! G:factor of thermal diffusion(1st.term) and vapor diffusion(2nd. term)
3420  ! SB06(23),(38), Lin et al(31),(52) or others
3421  ! Dw is introduced by Pruppacher and Klett(1997),(13-3)
3422  dw = 0.211e-4_rp* (((temc_lim+t00)/t00)**1.94_rp) *(p00/pre_lim)
3423  kalfa = ka0 + temc_lim*dka_dt
3424  mua = mua0 + temc_lim*dmua_dt
3425  nua = mua/rho_lim
3426  r_nua = 1.0_rp/nua
3427  gw = (lhv0/kalfa/tem(k,i,j))*(lhv0/rvap/tem(k,i,j)-1.0_rp)+(rvap*tem(k,i,j)/dw/esw(k,i,j))
3428  gi = (lhs0/kalfa/tem(k,i,j))*(lhs0/rvap/tem(k,i,j)-1.0_rp)+(rvap*tem(k,i,j)/dw/esi(k,i,j))
3429  ! capacities account for their surface geometries
3430  gwr = 4.0_rp*pi/cap(i_mp_qr)/gw
3431  gii = 4.0_rp*pi/cap(i_mp_qi)/gi
3432  gis = 4.0_rp*pi/cap(i_mp_qs)/gi
3433  gig = 4.0_rp*pi/cap(i_mp_qg)/gi
3434  ! vent: ventilation effect( asymmetry vapor field around particles due to aerodynamic )
3435  ! SB06 (30),(31) and each coefficient is by (88),(89)
3436  nsc_r3 = (nua/dw)**(0.33333333_rp) ! (Schmidt number )^(1/3)
3437  !
3438 ! Nrecs_r2 = sqrt(max(Re_min,min(Re_max,vt_xave(I_mp_QC,1,k,i,j)*dq_xave(I_mp_QC,k,i,j)*r_nua))) ! (Reynolds number)^(1/2) cloud
3439  nrers_r2 = sqrt(max(re_min,min(re_max,vt_xave(i_mp_qr,1,k,i,j)*dq_xave(i_mp_qr,k,i,j)*r_nua))) ! (Reynolds number)^(1/2) rain
3440  nreis_r2 = sqrt(max(re_min,min(re_max,vt_xave(i_mp_qi,1,k,i,j)*dq_xave(i_mp_qi,k,i,j)*r_nua))) ! (Reynolds number)^(1/2) cloud ice
3441  nress_r2 = sqrt(max(re_min,min(re_max,vt_xave(i_mp_qs,1,k,i,j)*dq_xave(i_mp_qs,k,i,j)*r_nua))) ! (Reynolds number)^(1/2) snow
3442  nregs_r2 = sqrt(max(re_min,min(re_max,vt_xave(i_mp_qg,1,k,i,j)*dq_xave(i_mp_qg,k,i,j)*r_nua))) ! (Reynolds number)^(1/2) graupel
3443  !
3444 ! Nrecl_r2 = sqrt(max(Re_min,min(Re_max,vt_xave(I_mp_QC,2,k,i,j)*dq_xave(I_mp_QC,k,i,j)*r_nua))) ! (Reynolds number)^(1/2) cloud
3445  nrerl_r2 = sqrt(max(re_min,min(re_max,vt_xave(i_mp_qr,2,k,i,j)*dq_xave(i_mp_qr,k,i,j)*r_nua))) ! (Reynolds number)^(1/2) rain
3446  nreil_r2 = sqrt(max(re_min,min(re_max,vt_xave(i_mp_qi,2,k,i,j)*dq_xave(i_mp_qi,k,i,j)*r_nua))) ! (Reynolds number)^(1/2) cloud ice
3447  nresl_r2 = sqrt(max(re_min,min(re_max,vt_xave(i_mp_qs,2,k,i,j)*dq_xave(i_mp_qs,k,i,j)*r_nua))) ! (Reynolds number)^(1/2) snow
3448  nregl_r2 = sqrt(max(re_min,min(re_max,vt_xave(i_mp_qg,2,k,i,j)*dq_xave(i_mp_qg,k,i,j)*r_nua))) ! (Reynolds number)^(1/2) graupel
3449  nscnrer_s=nsc_r3*nrers_r2 ! small rain
3450  nscnrer_l=nsc_r3*nrerl_r2 ! large rain
3451  !
3452  nscnrei_s=nsc_r3*nreis_r2 ! small ice
3453  nscnrei_l=nsc_r3*nreil_r2 ! large ice
3454  !
3455  nscnres_s=nsc_r3*nress_r2 ! small snow
3456  nscnres_l=nsc_r3*nresl_r2 ! large snow
3457  !
3458  nscnreg_s=nsc_r3*nregs_r2 ! small snow
3459  nscnreg_l=nsc_r3*nregl_r2 ! large snow
3460  !
3461  ventlr_s = ah_vent1(i_mp_qr,1) + bh_vent1(i_mp_qr,1)*nscnrer_s
3462  ventlr_l = ah_vent1(i_mp_qr,2) + bh_vent1(i_mp_qr,2)*nscnrer_l
3463  !
3464  ventni_s = ah_vent0(i_mp_qi,1) + bh_vent0(i_mp_qi,1)*nscnrei_s
3465  ventni_l = ah_vent0(i_mp_qi,2) + bh_vent0(i_mp_qi,2)*nscnrei_l
3466  ventli_s = ah_vent1(i_mp_qi,1) + bh_vent1(i_mp_qi,1)*nscnrei_s
3467  ventli_l = ah_vent1(i_mp_qi,2) + bh_vent1(i_mp_qi,2)*nscnrei_l
3468  !
3469  ventns_s = ah_vent0(i_mp_qs,1) + bh_vent0(i_mp_qs,1)*nscnres_s
3470  ventns_l = ah_vent0(i_mp_qs,2) + bh_vent0(i_mp_qs,2)*nscnres_l
3471  ventls_s = ah_vent1(i_mp_qs,1) + bh_vent1(i_mp_qs,1)*nscnres_s
3472  ventls_l = ah_vent1(i_mp_qs,2) + bh_vent1(i_mp_qs,2)*nscnres_l
3473  !
3474  ventng_s = ah_vent0(i_mp_qg,1) + bh_vent0(i_mp_qg,1)*nscnreg_s
3475  ventng_l = ah_vent0(i_mp_qg,2) + bh_vent0(i_mp_qg,2)*nscnreg_l
3476  ventlg_s = ah_vent1(i_mp_qg,1) + bh_vent1(i_mp_qg,1)*nscnreg_s
3477  ventlg_l = ah_vent1(i_mp_qg,2) + bh_vent1(i_mp_qg,2)*nscnreg_l
3478  !
3479  ! branch is 1.4 for rain, snow, graupel; is 1.0 for ice (PK97, 13-60,-61,-88,-89).
3480  !
3481  wtr = ( min(max( nscnrer_s*r_14, 0.5_rp), 2.0_rp) -0.5_rp )*r_15 ! weighting between 1.4*0.5 and 1.4*2
3482  wti = ( min(max( nscnrei_s , 0.5_rp), 2.0_rp) -0.5_rp )*r_15 ! weighting between 1.0*0.5 and 1.0*2
3483  wts = ( min(max( nscnres_s*r_14, 0.5_rp), 2.0_rp) -0.5_rp )*r_15 ! weighting between 1.4*0.5 and 1.4*2
3484  wtg = ( min(max( nscnreg_s*r_14, 0.5_rp), 2.0_rp) -0.5_rp )*r_15 ! weighting between 1.4*0.5 and 1.4*2
3485  ! interpolation between two branches
3486  ventni = (1.0_rp-wti)*ventni_s + wti*ventni_l
3487  ventns = (1.0_rp-wts)*ventns_s + wts*ventns_l
3488  ventng = (1.0_rp-wtg)*ventng_s + wtg*ventng_l
3489  !
3490  ventlr = (1.0_rp-wtr)*ventlr_s + wtr*ventlr_l
3491  ventli = (1.0_rp-wti)*ventli_s + wti*ventli_l
3492  ventls = (1.0_rp-wts)*ventls_s + wts*ventls_l
3493  ventlg = (1.0_rp-wtg)*ventlg_s + wtg*ventlg_l
3494  !
3495  ! SB06(29)
3496  ! [Mod] 08/05/08 T.Mitsui, recover PNXdep, and rain is only evaporation.
3497  ! Ni, Ns, Ng should decrease in nature so we add this term.
3498  ! And vapor deposition never occur unless number exist.
3499  ! [Add comment] 09/08/18
3500  ! recover condensation/evaporation of rain,
3501  ! and ventilation effects are not taken into account for cloud.
3502  !
3503 !!$***************************************************************************
3504 !!$ NOTICE:
3505 !!$ 09/08/18 [Mod] Hereafter PLxdep means inverse of timescale.
3506 !!$***************************************************************************
3507 !!$ PQ(I_LCdep,k,i,j) = Gwr*ssw*rhoq(I_NC,k,i,j)*dq_xave(I_mp_QC,k,i,j)*coef_deplc
3508 !!$ PQ(I_LRdep,k,i,j) = Gwr*ssw*rhoq(I_NR,k,i,j)*dq_xave(I_mp_QR,k,i,j)*ventLR
3509 !!$ PQ(I_LIdep,k,i,j) = Gii*ssi*rhoq(I_NI,k,i,j)*dq_xave(I_mp_QI,k,i,j)*ventLI
3510 !!$ PQ(I_LSdep,k,i,j) = Gis*ssi*rhoq(I_NS,k,i,j)*dq_xave(I_mp_QS,k,i,j)*ventLS
3511 !!$ PQ(I_LGdep,k,i,j) = Gig*ssi*rhoq(I_NG,k,i,j)*dq_xave(I_mp_QG,k,i,j)*ventLG
3512  pq(i_lcdep,k,i,j) = gwr*rhoq(i_nc,k,i,j)*dq_xave(i_mp_qc,k,i,j)*coef_deplc
3513  pq(i_lrdep,k,i,j) = gwr*rhoq(i_nr,k,i,j)*dq_xave(i_mp_qr,k,i,j)*ventlr
3514  pq(i_lidep,k,i,j) = gii*rhoq(i_ni,k,i,j)*dq_xave(i_mp_qi,k,i,j)*ventli
3515  pq(i_lsdep,k,i,j) = gis*rhoq(i_ns,k,i,j)*dq_xave(i_mp_qs,k,i,j)*ventls
3516  pq(i_lgdep,k,i,j) = gig*rhoq(i_ng,k,i,j)*dq_xave(i_mp_qg,k,i,j)*ventlg
3517  pq(i_nrdep,k,i,j) = pq(i_lrdep,k,i,j)/xq(i_mp_qr,k,i,j)
3518  pq(i_nidep,k,i,j) = 0.0_rp
3519  pq(i_nsdep,k,i,j) = pq(i_lsdep,k,i,j)/xq(i_mp_qs,k,i,j)
3520  pq(i_ngdep,k,i,j) = pq(i_lgdep,k,i,j)/xq(i_mp_qg,k,i,j)
3521  !
3522  !------------------------------------------------------------------------
3523  ! Melting part is described by Pruppacher and Klett (1997) Sec.16.3.1
3524  ! Here we omit "Shedding" of snow-flakes and ice-particles.
3525  ! "Shedding" may be applicative if you refer
3526  ! eq.(38) in Cotton etal.(1986) Jour. Clim. Appl. Meteor. p.1658-1680.
3527  ! SB06(73)
3528  dt = kalfa/(cpvap*rho_0)
3529  ! Gm: factor caused by balance between
3530  ! "water evaporation cooling(1st.)" and "fusion heating(2nd.)"
3531  ! SB06(76)
3532  ! [fix] 08/05/08 T.Mitsui LHF00 => EMELT and esw => PSAT0
3533  ! LHS0 is more suitable than LHS because melting occurs around 273.15 K.
3534  gm = 2.0_rp*pi/emelt&
3535  * ( (kalfa*dt/dw)*(temc) + (dw*lhs0/rvap)*(esi(k,i,j)/tem(k,i,j)-psat0/t00) )
3536  ! SB06(76)
3537  ! Notice! melting only occurs where T > 273.15 K else doesn't.
3538  ! [fix] 08/05/08 T.Mitsui, Gm could be both positive and negative value.
3539  ! See Pruppacher and Klett(1997) eq.(16-79) or Rasmussen and Pruppacher(1982)
3540  sw = ( sign(0.5_rp,temc) + 0.5_rp ) * ( sign(0.5_rp,gm-eps) + 0.5_rp ) ! sw = 1 if( (temc>=0.0_RP) .AND. (Gm>0.0_RP) ), otherwise sw = 0
3541  ! if Gm==0 then rh and tem is critical value for melting process.
3542  ! 08/05/16 [Mod] T.Mitsui, change term of PLimlt. N_i => L_i/ (limited x_i)
3543  ! because melting never occur when N_i=0.
3544  pq(i_limlt,k,i,j) = - gm * rhoq(i_qi,k,i,j)*dq_xave(i_mp_qi,k,i,j)*ventli/xq(i_mp_qi,k,i,j) * sw
3545  ! [Mod] 08/08/23 T.Mitsui for Seifert(2008)
3546  pq(i_nimlt,k,i,j) = - gm * rhoq(i_ni,k,i,j)*dq_xave(i_mp_qi,k,i,j)*ventni/xq(i_mp_qi,k,i,j) * sw ! 09/08/18 [Mod] recover, T.Mitsui
3547  pq(i_lsmlt,k,i,j) = - gm * rhoq(i_qs,k,i,j)*dq_xave(i_mp_qs,k,i,j)*ventls/xq(i_mp_qs,k,i,j) * sw
3548  ! [Mod] 08/08/23 T.Mitsui for Seifert(2008)
3549  pq(i_nsmlt,k,i,j) = - gm * rhoq(i_ns,k,i,j)*dq_xave(i_mp_qs,k,i,j)*ventns/xq(i_mp_qs,k,i,j) * sw ! 09/08/18 [Mod] recover, T.Mitsui
3550  pq(i_lgmlt,k,i,j) = - gm * rhoq(i_qg,k,i,j)*dq_xave(i_mp_qg,k,i,j)*ventlg/xq(i_mp_qg,k,i,j) * sw
3551  ! [Mod] 08/08/23 T.Mitsui for Seifert(2008)
3552  pq(i_ngmlt,k,i,j) = - gm * rhoq(i_ng,k,i,j)*dq_xave(i_mp_qg,k,i,j)*ventng/xq(i_mp_qg,k,i,j) * sw ! 09/08/18 [Mod] recover, T.Mitsui
3553 
3554  end do
3555  end do
3556  end do
3557  profile_stop("sn14_dep_vapor")
3558  !
3559  return
3560  end subroutine dep_vapor_melt_ice_kij
3561  !-----------------------------------------------------------------------------
3562  subroutine freezing_water_kij( &
3563  dt, &
3564  PQ, &
3565  rhoq, xq, tem )
3566  use scale_tracer, only: &
3567  qa
3568  implicit none
3569  !
3570  ! In this subroutine,
3571  ! We assumed surface temperature of droplets are same as environment.
3572 
3573  real(RP), intent(in) :: dt
3574  real(RP), intent(inout):: PQ(PQ_MAX,KA,IA,JA)
3575  !
3576  real(RP), intent(in) :: tem(KA,IA,JA)
3577  !
3578  real(RP), intent(in) :: rhoq(I_QV:I_NG,KA,IA,JA)
3579  real(RP), intent(in) :: xq(HYDRO_MAX,KA,IA,JA)
3580  !
3581  real(RP), parameter :: temc_min = -65.0_rp
3582  real(RP), parameter :: a_het = 0.2_rp ! SB06 (44)
3583  real(RP), parameter :: b_het = 0.65_rp ! SB06 (44)
3584  !
3585  real(RP) :: coef_m2_c
3586  real(RP) :: coef_m2_r
3587  ! temperature [celsius]
3588  real(RP) :: temc, temc2, temc3, temc4
3589  ! temperature function of homegenous/heterogenous freezing
3590  real(RP) :: Jhom, Jhet
3591  real(RP) :: rdt
3592  real(RP) :: tmp
3593  !
3594  integer :: i,j,k
3595  !
3596  rdt = 1.0_rp/dt
3597  !
3598  coef_m2_c = coef_m2(i_mp_qc)
3599  coef_m2_r = coef_m2(i_mp_qr)
3600  !
3601  profile_start("sn14_freezing")
3602  do j = js, je
3603  do i = is, ie
3604  do k = ks, ke
3605  temc = max( tem(k,i,j) - t00, temc_min )
3606  ! These cause from aerosol-droplet interaction.
3607  ! Bigg(1953) formula, Khain etal.(2000) eq.(4.5), Pruppacher and Klett(1997) eq.(9-48)
3608  jhet = a_het*exp( -b_het*temc - 1.0_rp )
3609  ! These cause in nature.
3610  ! Cotton and Field 2002, QJRMS. (12)
3611  if( temc < -65.0_rp )then
3612  jhom = 10.0_rp**(24.37236_rp)*1.e+3_rp
3613  jhet = a_het*exp( 65.0_rp*b_het - 1.0_rp ) ! 09/04/14 [Add], fixer T.Mitsui
3614  else if( temc < -30.0_rp ) then
3615  temc2 = temc*temc
3616  temc3 = temc*temc2
3617  temc4 = temc2*temc2
3618  jhom = 10.0_rp**(&
3619  - 243.40_rp - 14.75_rp*temc - 0.307_rp*temc2 &
3620  - 0.00287_rp*temc3 - 0.0000102_rp*temc4 ) *1.e+3_rp
3621  else if( temc < 0.0_rp) then
3622  jhom = 10._rp**(-7.63_rp-2.996_rp*(temc+30.0_rp))*1.e+3_rp
3623  else
3624  jhom = 0.0_rp
3625  jhet = 0.0_rp
3626  end if
3627  ! Note, xc should be limited in range[xc_min:xc_max].
3628  ! and PNChom need to be calculated by NC
3629  ! because reduction rate of Nc need to be bound by NC.
3630  ! For the same reason PLChom also bound by LC and xc.
3631  ! Basically L and N should be independent
3632  ! but average particle mass x should be in suitable range.
3633  ! Homogenous Freezing
3634  pq(i_lchom,k,i,j) = 0.0_rp
3635  pq(i_nchom,k,i,j) = 0.0_rp
3636  ! Heterogenous Freezing
3637 #if defined(PGI) || defined(SX)
3638  tmp = min( xq(i_mp_qc,k,i,j)*(jhet+jhom)*dt, 1.e+3_rp) ! apply exp limiter
3639  pq(i_lchet,k,i,j) = -rdt*rhoq(i_qc,k,i,j)*( 1.0_rp - exp( -coef_m2_c*tmp ) )
3640  pq(i_nchet,k,i,j) = -rdt*rhoq(i_nc,k,i,j)*( 1.0_rp - exp( - tmp ) )
3641 
3642  tmp = min( xq(i_mp_qr,k,i,j)*(jhet+jhom)*dt, 1.e+3_rp) ! apply exp limiter
3643  pq(i_lrhet,k,i,j) = -rdt*rhoq(i_qr,k,i,j)*( 1.0_rp - exp( -coef_m2_r*tmp ) )
3644  pq(i_nrhet,k,i,j) = -rdt*rhoq(i_nr,k,i,j)*( 1.0_rp - exp( - tmp ) )
3645 #else
3646  pq(i_lchet,k,i,j) = -rdt*rhoq(i_qc,k,i,j)*( 1.0_rp - exp( -coef_m2_c*xq(i_mp_qc,k,i,j)*(jhet+jhom)*dt ) )
3647  pq(i_nchet,k,i,j) = -rdt*rhoq(i_nc,k,i,j)*( 1.0_rp - exp( - xq(i_mp_qc,k,i,j)*(jhet+jhom)*dt ) )
3648  pq(i_lrhet,k,i,j) = -rdt*rhoq(i_qr,k,i,j)*( 1.0_rp - exp( -coef_m2_r*xq(i_mp_qr,k,i,j)*(jhet+jhom)*dt ) )
3649  pq(i_nrhet,k,i,j) = -rdt*rhoq(i_nr,k,i,j)*( 1.0_rp - exp( - xq(i_mp_qr,k,i,j)*(jhet+jhom)*dt ) )
3650 #endif
3651  end do
3652  end do
3653  end do
3654  profile_stop("sn14_freezing")
3655  !
3656  return
3657  end subroutine freezing_water_kij
3658  !-----------------------------------------------------------------------------
3659  subroutine mp_terminal_velocity( &
3660  velw, &
3661  rhoq, &
3662  DENS, &
3663  temp, &
3664  pres )
3665  use scale_const, only: &
3666  const_undef
3667  use scale_tracer, only: &
3668  qa
3669  implicit none
3670 
3671  real(RP), intent(out) :: velw(KA,IA,JA,QA_MP-1) ! terminal velocity of cloud mass
3672  real(RP), intent(in) :: rhoq(I_QV:I_NG,KA,IA,JA) ! rho * q
3673  real(RP), intent(in) :: DENS(KA,IA,JA) ! rho
3674  real(RP), intent(in) :: temp(KA,IA,JA) ! temperature
3675  real(RP), intent(in) :: pres(KA,IA,JA) ! pressure
3676 
3677  real(RP) :: xq ! average mass of 1 particle( mass/number )
3678 
3679  real(RP) :: rhofac ! density factor for terminal velocity( air friction )
3680  real(RP) :: rhofac_q(HYDRO_MAX)
3681 
3682  real(RP) :: rlambdar ! work for diagnosis of Rain DSD ( Seifert, 2008 )
3683  real(RP) :: mud_r
3684  real(RP) :: dq, dql ! weigthed diameter. Improved Rogers etal. (1993) formula by T.Mitsui
3685 
3686 
3687  real(RP) :: weight ! weighting coefficient for 2-branches is determined by ratio between 0.745mm and weighted diameter. SB06 Table.1
3688  real(RP) :: velq_s ! terminal velocity for small branch of Rogers formula
3689  real(RP) :: velq_l ! terminal velocity for large branch of Rogers formula
3690 
3691  real(RP) :: tmp
3692  integer :: k, i, j, iq
3693  !---------------------------------------------------------------------------
3694 
3695  profile_start("sn14_terminal_vel")
3696 
3697  mud_r = 3.0_rp * nu(i_mp_qr) + 2.0_rp
3698 
3699 
3700  do j = js, je
3701  do i = is, ie
3702  do k = ks, ke
3703  rhofac = rho_0 / max( dens(k,i,j), rho_min )
3704 
3705  ! QC
3706  rhofac_q(i_mp_qc) = rhofac ** gamma_v(i_mp_qc)
3707  xq = max( xqmin(i_mp_qc), min( xqmax(i_mp_qc), rhoq(i_qc,k,i,j) / ( rhoq(i_nc,k,i,j) + nqmin(i_mp_qc) ) ) )
3708 
3709  velw(k,i,j,i_mp_qc) = -rhofac_q(i_mp_qc) * coef_vt1(i_mp_qc,1) * xq**beta_v(i_mp_qc,1)
3710  ! NC
3711  velw(k,i,j,i_mp_nc) = -rhofac_q(i_mp_qc) * coef_vt0(i_mp_qc,1) * xq**beta_vn(i_mp_qc,1)
3712 
3713  ! QR
3714  rhofac_q(i_mp_qr) = rhofac ** gamma_v(i_mp_qr)
3715  xq = max( xqmin(i_mp_qr), min( xqmax(i_mp_qr), rhoq(i_qr,k,i,j) / ( rhoq(i_nr,k,i,j) + nqmin(i_mp_qr) ) ) )
3716 
3717  rlambdar = a_m(i_mp_qr) * xq**b_m(i_mp_qr) &
3718  * ( (mud_r+3.0_rp) * (mud_r+2.0_rp) * (mud_r+1.0_rp) )**(-0.333333333_rp)
3719  dq = ( 4.0_rp + mud_r ) * rlambdar ! D^(3)+mu weighted mean diameter
3720  dql = dq
3721  weight = min( 1.0_rp, max( 0.0_rp, 0.5_rp * ( 1.0_rp + tanh( pi * log( dq/d_vtr_branch ) ) ) ) )
3722 
3723  velq_s = coef_vtr_ar2 * dq &
3724  * ( 1.0_rp - ( 1.0_rp + coef_vtr_br2*rlambdar )**(-5.0_rp-mud_r) )
3725  velq_l = coef_vtr_ar1 - coef_vtr_br1 &
3726  * ( 1.0_rp + coef_vtr_cr1*rlambdar )**(-4.0_rp-mud_r)
3727  velw(k,i,j,i_mp_qr) = -rhofac_q(i_mp_qr) &
3728  * ( velq_l * ( weight ) &
3729  + velq_s * ( 1.0_rp - weight ) )
3730  ! NR
3731  dq = ( 1.0_rp + mud_r ) * rlambdar
3732  weight = min( 1.0_rp, max( 0.0_rp, 0.5_rp * ( 1.0_rp + tanh( pi * log( dq/d_vtr_branch ) ) ) ) )
3733 
3734  velq_s = coef_vtr_ar2 * dql &
3735  * ( 1.0_rp - ( 1.0_rp + coef_vtr_br2*rlambdar )**(-2.0_rp-mud_r) )
3736  velq_l = coef_vtr_ar1 - coef_vtr_br1 &
3737  * ( 1.0_rp + coef_vtr_cr1*rlambdar )**(-1.0_rp-mud_r)
3738  velw(k,i,j,i_mp_nr) = -rhofac_q(i_mp_qr) &
3739  * ( velq_l * ( weight ) &
3740  + velq_s * ( 1.0_rp - weight ) )
3741 
3742  ! QI
3743  rhofac_q(i_mp_qi) = ( pres(k,i,j)/pre0_vt )**a_pre0_vt * ( temp(k,i,j)/tem0_vt )**a_tem0_vt
3744  xq = max( xqmin(i_mp_qi), min( xqmax(i_mp_qi), rhoq(i_qi,k,i,j) / ( rhoq(i_ni,k,i,j) + nqmin(i_mp_qi) ) ) )
3745 
3746  tmp = a_m(i_mp_qi) * xq**b_m(i_mp_qi)
3747  dq = coef_dave_l(i_mp_qi) * tmp
3748  weight = min( 1.0_rp, max( 0.0_rp, 0.5_rp * ( 1.0_rp + log( dq/d0_li ) ) ) )
3749 
3750  velq_s = coef_vt1(i_mp_qi,1) * xq**beta_v(i_mp_qi,1)
3751  velq_l = coef_vt1(i_mp_qi,2) * xq**beta_v(i_mp_qi,2)
3752  velw(k,i,j,i_mp_qi) = -rhofac_q(i_mp_qi) &
3753  * ( velq_l * ( weight ) &
3754  + velq_s * ( 1.0_rp - weight ) )
3755  ! NI
3756  dq = coef_dave_n(i_mp_qi) * tmp
3757  weight = min( 1.0_rp, max( 0.0_rp, 0.5_rp * ( 1.0_rp + log( dq/d0_ni ) ) ) )
3758 
3759  velq_s = coef_vt0(i_mp_qi,1) * xq**beta_vn(i_mp_qi,1)
3760  velq_l = coef_vt0(i_mp_qi,2) * xq**beta_vn(i_mp_qi,2)
3761  velw(k,i,j,i_mp_ni) = -rhofac_q(i_mp_qi) &
3762  * ( velq_l * ( weight ) &
3763  + velq_s * ( 1.0_rp - weight ) )
3764 
3765  ! QS
3766  rhofac_q(i_mp_qs) = rhofac_q(i_mp_qi)
3767  xq = max( xqmin(i_mp_qs), min( xqmax(i_mp_qs), rhoq(i_qs,k,i,j) / ( rhoq(i_ns,k,i,j) + nqmin(i_mp_qs) ) ) )
3768 
3769  tmp = a_m(i_mp_qs) * xq**b_m(i_mp_qs)
3770  dq = coef_dave_l(i_mp_qs) * tmp
3771  weight = min( 1.0_rp, max( 0.0_rp, 0.5_rp * ( 1.0_rp + log( dq/d0_ls ) ) ) )
3772 
3773  velq_s = coef_vt1(i_mp_qs,1) * xq**beta_v(i_mp_qs,1)
3774  velq_l = coef_vt1(i_mp_qs,2) * xq**beta_v(i_mp_qs,2)
3775  velw(k,i,j,i_mp_qs) = -rhofac_q(i_mp_qs) &
3776  * ( velq_l * ( weight ) &
3777  + velq_s * ( 1.0_rp - weight ) )
3778  ! NS
3779  dq = coef_dave_n(i_mp_qs) * tmp
3780  weight = min( 1.0_rp, max( 0.0_rp, 0.5_rp * ( 1.0_rp + log( dq/d0_ns ) ) ) )
3781 
3782  velq_s = coef_vt0(i_mp_qs,1) * xq**beta_vn(i_mp_qs,1)
3783  velq_l = coef_vt0(i_mp_qs,2) * xq**beta_vn(i_mp_qs,2)
3784  velw(k,i,j,i_mp_ns) = -rhofac_q(i_mp_qs) &
3785  * ( velq_l * ( weight ) &
3786  + velq_s * ( 1.0_rp - weight ) )
3787 
3788  ! QG
3789  rhofac_q(i_mp_qg) = rhofac_q(i_mp_qi)
3790  xq = max( xqmin(i_mp_qg), min( xqmax(i_mp_qg), rhoq(i_qg,k,i,j) / ( rhoq(i_ng,k,i,j) + nqmin(i_mp_qg) ) ) )
3791 
3792  tmp = a_m(i_mp_qg) * xq**b_m(i_mp_qg)
3793  dq = coef_dave_l(i_mp_qg) * tmp
3794  weight = min( 1.0_rp, max( 0.0_rp, 0.5_rp * ( 1.0_rp + log( dq/d0_lg ) ) ) )
3795 
3796  velq_s = coef_vt1(i_mp_qg,1) * xq**beta_v(i_mp_qg,1)
3797  velq_l = coef_vt1(i_mp_qg,2) * xq**beta_v(i_mp_qg,2)
3798  velw(k,i,j,i_mp_qg) = -rhofac_q(i_mp_qg) &
3799  * ( velq_l * ( weight ) &
3800  + velq_s * ( 1.0_rp - weight ) )
3801  ! NG
3802  dq = coef_dave_n(i_mp_qg) * tmp
3803  weight = min( 1.0_rp, max( 0.0_rp, 0.5_rp * ( 1.0_rp + log( dq/d0_ng ) ) ) )
3804 
3805  velq_s = coef_vt0(i_mp_qg,1) * xq**beta_vn(i_mp_qg,1)
3806  velq_l = coef_vt0(i_mp_qg,2) * xq**beta_vn(i_mp_qg,2)
3807  velw(k,i,j,i_mp_ng) = -rhofac_q(i_mp_qg) &
3808  * ( velq_l * ( weight ) &
3809  + velq_s * ( 1.0_rp - weight ) )
3810  enddo
3811  enddo
3812  enddo
3813 
3814  do iq = 1, qa_mp-1
3815  do j = js, je
3816  do i = is, ie
3817  velw(1:ks-2,i,j,iq) = const_undef
3818  velw(ks-1,i,j,iq) = velw(ks,i,j,iq)
3819  velw(ke+1:ka,i,j,iq) = const_undef
3820  enddo
3821  enddo
3822  enddo
3823 
3824  profile_stop("sn14_terminal_vel")
3825 
3826  return
3827  end subroutine mp_terminal_velocity
3828  !----------------------------------------------------------------
3829  subroutine update_by_phase_change_kij( &
3830  ntdiv, ntmax, & ! in [Add] 10/08/03
3831  dt, & ! in
3832  gsgam2, & ! in
3833  z, & ! in
3834  dz, & ! in
3835  velz, & ! in
3836  dTdt_rad, & ! in
3837  rho, & ! in
3838  rhoe, & ! inout
3839  rhoq, q, & ! inout
3840  tem, pre, & ! inout
3841  cva, & ! out
3842  esw, esi, rhoq2, & ! in
3843  PQ, & ! in
3844  qc_evaporate, & ! in
3845  sl_PLCdep, &
3846  sl_PLRdep, sl_PNRdep )
3847  use scale_tracer, only: &
3848  qa, &
3849  tracer_r, &
3850  tracer_cv, &
3851  tracer_cp, &
3852  tracer_mass
3853  use scale_atmos_saturation, only: &
3854  moist_pres2qsat_liq => atmos_saturation_pres2qsat_liq, &
3855  moist_pres2qsat_ice => atmos_saturation_pres2qsat_ice, &
3856  moist_dqsw_dtem_rho => atmos_saturation_dqsw_dtem_rho, &
3857  moist_dqsi_dtem_rho => atmos_saturation_dqsi_dtem_rho, &
3858  moist_dqsw_dtem_dpre => atmos_saturation_dqsw_dtem_dpre, &
3859  moist_dqsi_dtem_dpre => atmos_saturation_dqsi_dtem_dpre
3860  implicit none
3861 
3862  integer, intent(in) :: ntdiv ! [Add] 10/08/03
3863  integer, intent(in) :: ntmax ! [Add] 10/08/03
3864  !
3865  real(RP), intent(in) :: dt ! time step[s]
3866  real(RP), intent(in) :: gsgam2(KA,IA,JA) ! metric
3867  real(RP), intent(in) :: z(KA) ! altitude [m]
3868  real(RP), intent(in) :: dz(KA) ! altitude [m]
3869  real(RP), intent(in) :: velz(KA,IA,JA) ! vertical velocity @ half point[m/s]
3870  real(RP), intent(in) :: dTdt_rad(KA,IA,JA) ! temperture tendency by radiation[K/s]
3871  real(RP), intent(in) :: rho(KA,IA,JA) ! density[kg/m3]
3872  real(RP), intent(inout) :: rhoe(KA,IA,JA) ! internal energy[J/m3]
3873  real(RP), intent(inout) :: rhoq(I_QV:I_NG,KA,IA,JA) ! tracers[kg/m3]
3874  real(RP), intent(inout) :: q(KA,IA,JA,QA) ! tracers mixing ratio[kg/kg]
3875  real(RP), intent(inout) :: tem(KA,IA,JA) ! temperature[K]
3876  real(RP), intent(inout) :: pre(KA,IA,JA) ! pressure[Pa]
3877  real(RP), intent(out) :: cva(KA,IA,JA) ! specific heat at constant volume
3878  real(RP), intent(in) :: esw(KA,IA,JA) ! saturated vapor pressure for liquid
3879  real(RP), intent(in) :: esi(KA,IA,JA) ! for ice
3880  real(RP), intent(in) :: rhoq2(I_QV:I_NG,KA,IA,JA)
3881  !+++ tendency[kg/m3/s]
3882  real(RP), intent(inout) :: PQ(PQ_MAX,KA,IA,JA)
3883  real(RP), intent(out) :: qc_evaporate(KA,IA,JA)
3884  !+++ Column integrated tendency[kg/m2/s]
3885  real(RP), intent(inout) :: sl_PLCdep(IA,JA)
3886  real(RP), intent(inout) :: sl_PLRdep(IA,JA), sl_PNRdep(IA,JA)
3887  !
3888  real(RP) :: Rmoist
3889  !
3890  real(RP) :: xi ! mean mass of ice particles
3891  real(RP) :: rrho ! 1/rho
3892  real(RP) :: wtem(KA,IA,JA) ! temperature[K]
3893  real(RP) :: qdry ! mixing ratio of dry air
3894  !
3895  real(RP) :: r_cva ! specific heat at constant volume
3896  real(RP) :: cpa ! specific heat at constant pressure
3897  real(RP) :: r_cpa ! specific heat at constant pressure
3898  real(RP) :: qsw(KA,IA,JA) ! saturated mixing ratio for liquid
3899  real(RP) :: qsi(KA,IA,JA) ! saturated mixing ratio for solid
3900  real(RP) :: dqswdtem_rho(KA,IA,JA) ! (dqsw/dtem)_rho
3901  real(RP) :: dqsidtem_rho(KA,IA,JA) ! (dqsi/dtem)_rho
3902  real(RP) :: dqswdtem_pre(KA,IA,JA) ! (dqsw/dtem)_pre
3903  real(RP) :: dqsidtem_pre(KA,IA,JA) ! (dqsi/dtem)_pre
3904  real(RP) :: dqswdpre_tem(KA,IA,JA) ! (dqsw/dpre)_tem
3905  real(RP) :: dqsidpre_tem(KA,IA,JA) ! (dqsi/dpre)_tem
3906  !
3907  real(RP) :: w ! vetical velocity[m/s]
3908  real(RP) :: Acnd ! Pdynliq + Bergeron-Findeisen
3909  real(RP) :: Adep ! Pdyndep + Bergeron-Findeisen
3910  real(RP) :: aliqliq, asolliq
3911  real(RP) :: aliqsol, asolsol
3912  real(RP) :: Pdynliq ! production term of ssw by vertical motion
3913  real(RP) :: Pdynsol ! production term of ssi by vertical motion
3914  real(RP) :: Pradliq ! production term of ssw by radiation
3915  real(RP) :: Pradsol ! production term of ssi by radiation
3916  real(RP) :: taucnd, r_taucnd ! time scale of ssw change by MP
3917  real(RP) :: taudep, r_taudep ! time scale of ssi change by MP
3918  real(RP) :: taucnd_c(KA,IA,JA), r_taucnd_c ! by cloud
3919  real(RP) :: taucnd_r(KA,IA,JA), r_taucnd_r ! by rain
3920  real(RP) :: taudep_i(KA,IA,JA), r_taudep_i ! by ice
3921  real(RP) :: taudep_s(KA,IA,JA), r_taudep_s ! by snow
3922  real(RP) :: taudep_g(KA,IA,JA), r_taudep_g ! by graupel
3923  ! alternative tendency through changing ssw and ssi
3924  real(RP) :: PNCdep ! [Add] 11/08/30 T.Mitsui
3925  real(RP) :: PLR2NR, PLI2NI, PLS2NS, PLG2NG
3926  real(RP) :: coef_a_cnd, coef_b_cnd
3927  real(RP) :: coef_a_dep, coef_b_dep
3928  !
3929  real(RP) :: frz_dqc
3930  real(RP) :: frz_dnc
3931  real(RP) :: frz_dqr
3932  real(RP) :: frz_dnr
3933  real(RP) :: mlt_dqi
3934  real(RP) :: mlt_dni
3935  real(RP) :: mlt_dqs
3936  real(RP) :: mlt_dns
3937  real(RP) :: mlt_dqg
3938  real(RP) :: mlt_dng
3939  real(RP) :: dep_dqi
3940  real(RP) :: dep_dni
3941  real(RP) :: dep_dqs
3942  real(RP) :: dep_dns
3943  real(RP) :: dep_dqg
3944  real(RP) :: dep_dng
3945  real(RP) :: dep_dqr
3946  real(RP) :: dep_dnr
3947  real(RP) :: dep_dqc
3948  real(RP) :: dep_dnc ! 11/08/30 [Add] T.Mitsui, dep_dnc
3949  real(RP) :: r_xc_ccn, r_xi_ccn ! 11/08/30 [Add] T.Mitsui
3950  !
3951  real(RP) :: drhoqv
3952  real(RP) :: drhoqc, drhoqr, drhoqi, drhoqs, drhoqg
3953  real(RP) :: drhonc, drhonr, drhoni, drhons, drhong
3954  !
3955  real(RP) :: fac1, fac2, fac3, fac4, fac5, fac6
3956  real(RP) :: r_rvaptem ! 1/(Rvap*tem)
3957  real(RP) :: pv ! vapor pressure
3958  real(RP) :: lvsw, lvsi ! saturated vapor density
3959  real(RP) :: dlvsw, dlvsi !
3960  ! [Add] 11/08/30 T.Mitsui
3961  real(RP) :: dcnd, ddep ! total cndensation/deposition
3962  real(RP) :: uplim_cnd ! upper limit of condensation
3963  real(RP) :: lowlim_cnd ! lower limit of evaporation
3964  ! [Add] 11/08/30 T.Mitsui
3965  real(RP) :: uplim_dep ! upper limit of condensation
3966  real(RP) :: lowlim_dep ! lower limit of evaporation
3967  real(RP) :: ssw, ssi ! supersaturation ratio
3968  real(RP) :: r_esw, r_esi ! 1/esw, 1/esi
3969  real(RP) :: r_lvsw, r_lvsi ! 1/(lvsw*ssw), 1/(lvsi*ssi)
3970  real(RP) :: r_dt ! 1/dt
3971  real(RP) :: ssw_o, ssi_o
3972 ! real(RP) :: dt_dyn
3973 ! real(RP) :: dt_mp
3974  !
3975 ! real(RP) :: tem_lh(KA,IA,JA)
3976 ! real(RP) :: dtemdt_lh(KA,IA,JA)
3977  real(RP), save :: fac_cndc = 1.0_rp
3978  logical, save :: opt_fix_taucnd_c=.false.
3979  logical, save :: flag_first =.true.
3980  !
3981  namelist /nm_mp_sn14_condensation/ &
3982  opt_fix_taucnd_c, fac_cndc
3983 
3984  real(RP) :: fac_cndc_wrk
3985  !
3986  real(RP), parameter :: tau100day = 1.e+7_rp
3987  real(RP), parameter :: r_tau100day = 1.e-7_rp
3988  real(RP), parameter :: eps=1.e-30_rp
3989  !
3990  integer :: i,j,k,iqw
3991  real(RP) :: sw
3992  !
3993 
3994  ! [Add] 11/08/30 T.Mitsui
3995  if( flag_first )then
3996  flag_first = .false.
3997  rewind(io_fid_conf)
3998  read (io_fid_conf,nml=nm_mp_sn14_condensation, end=100)
3999 100 if( io_nml ) write(io_fid_nml,nml=nm_mp_sn14_condensation)
4000  end if
4001  !
4002 ! dt_dyn = dt*ntmax
4003 ! dt_mp = dt*(ntdiv-1)
4004  !
4005  r_dt = 1.0_rp/dt
4006  !
4007  r_xc_ccn=1.0_rp/xc_ccn
4008 ! r_xi_ccn=1.0_RP/xi_ccn
4009  !
4010  if( opt_fix_taucnd_c )then
4011  fac_cndc_wrk = fac_cndc**(1.0_rp-b_m(i_mp_qc))
4012  do j = js, je
4013  do i = is, ie
4014  do k = ks, ke
4015  pq(i_lcdep,k,i,j) = pq(i_lcdep,k,i,j)*fac_cndc_wrk
4016  end do
4017  end do
4018  end do
4019  if( io_l ) write(io_fid_log,*) "taucnd:fac_cndc_wrk=",fac_cndc_wrk
4020  end if
4021 
4022 !OCL XFILL
4023  do j = js, je
4024  do i = is, ie
4025  do k = ks, ke
4026  ! Temperature lower limit is only used for saturation condition.
4027  ! On the other hand original "tem" is used for calculation of latent heat or energy equation.
4028  wtem(k,i,j) = max( tem(k,i,j), tem_min )
4029  end do
4030  end do
4031  end do
4032 
4033  call moist_pres2qsat_liq ( qsw, wtem, pre )
4034  call moist_pres2qsat_ice ( qsi, wtem, pre )
4035  call moist_dqsw_dtem_rho ( dqswdtem_rho, wtem, rho )
4036  call moist_dqsi_dtem_rho ( dqsidtem_rho, wtem, rho )
4037  call moist_dqsw_dtem_dpre( dqswdtem_pre, dqswdpre_tem, wtem, pre )
4038  call moist_dqsi_dtem_dpre( dqsidtem_pre, dqsidpre_tem, wtem, pre )
4039 
4040  profile_start("sn14_update")
4041  do j = js, je
4042  do i = is, ie
4043  do k = ks, ke
4044  if( z(k) <= 25000.0_rp )then
4045  w = 0.5_rp*(velz(k-1,i,j) + velz(k,i,j))
4046  else
4047  w = 0.0_rp
4048  end if
4049  if( pre(k,i,j) < esw(k,i,j)+1.e-10_rp )then
4050  qsw(k,i,j) = 1.0_rp
4051  dqswdtem_rho(k,i,j) = 0.0_rp
4052  dqswdtem_pre(k,i,j) = 0.0_rp
4053  dqswdpre_tem(k,i,j) = 0.0_rp
4054  end if
4055  if( pre(k,i,j) < esi(k,i,j)+1.e-10_rp )then
4056  qsi(k,i,j) = 1.0_rp
4057  dqsidtem_rho(k,i,j) = 0.0_rp
4058  dqsidtem_pre(k,i,j) = 0.0_rp
4059  dqsidpre_tem(k,i,j) = 0.0_rp
4060  end if
4061 
4062  r_rvaptem = 1.0_rp/(rvap*wtem(k,i,j))
4063  lvsw = esw(k,i,j)*r_rvaptem ! rho=p/(Rv*T)
4064  lvsi = esi(k,i,j)*r_rvaptem !
4065  pv = rhoq2(i_qv,k,i,j)*rvap*tem(k,i,j)
4066  r_esw = 1.0_rp/esw(k,i,j)
4067  r_esi = 1.0_rp/esi(k,i,j)
4068  ssw = min( mp_ssw_lim, ( pv*r_esw-1.0_rp ) )
4069  ssi = pv*r_esi - 1.0_rp
4070  r_lvsw = 1.0_rp/lvsw
4071  r_lvsi = 1.0_rp/lvsi
4072  r_taucnd_c = pq(i_lcdep,k,i,j)*r_lvsw
4073  r_taucnd_r = pq(i_lrdep,k,i,j)*r_lvsw
4074  r_taudep_i = pq(i_lidep,k,i,j)*r_lvsi
4075  r_taudep_s = pq(i_lsdep,k,i,j)*r_lvsi
4076  r_taudep_g = pq(i_lgdep,k,i,j)*r_lvsi
4077 ! taucnd_c(k,i,j) = 1.0_RP/(r_taucnd_c+r_tau100day)
4078 ! taucnd_r(k,i,j) = 1.0_RP/(r_taucnd_r+r_tau100day)
4079 ! taudep_i(k,i,j) = 1.0_RP/(r_taudep_i+r_tau100day)
4080 ! taudep_s(k,i,j) = 1.0_RP/(r_taudep_s+r_tau100day)
4081 ! taudep_g(k,i,j) = 1.0_RP/(r_taudep_g+r_tau100day)
4082 
4083  calc_qdry( qdry, q, tracer_mass, k, i, j, iqw )
4084  calc_cv( cva(k,i,j), qdry, q, k, i, j, iqw, cvdry, tracer_cv )
4085  calc_cp( cpa, qdry, q, k, i, j, iqw, cpdry, tracer_cp )
4086  calc_r( rmoist, qdry, q, k, i, j, iqw, rdry, tracer_r )
4087  r_cva = 1.0_rp / cva(k,i,j)
4088  r_cpa = 1.0_rp / cpa
4089 
4090  ! Coefficient of latent heat release for ssw change by PLCdep and PLRdep
4091  aliqliq = 1.0_rp &
4092  + r_cva*( lhv00 + (cvvap-cl)*tem(k,i,j) )*dqswdtem_rho(k,i,j)
4093  ! Coefficient of latent heat release for ssw change by PLIdep, PLSdep and PLGdep
4094  asolliq = 1.0_rp &
4095  + r_cva*( lhv00 + lhf00 + (cvvap-ci)*tem(k,i,j) )*dqswdtem_rho(k,i,j)
4096  ! Coefficient of latent heat release for ssi change by PLCdep and PLRdep
4097  aliqsol = 1.0_rp &
4098  + r_cva*( lhv00 + (cvvap-cl)*tem(k,i,j) )*dqsidtem_rho(k,i,j)
4099  ! Coefficient of latent heat release for ssi change by PLIdep, PLSdep and PLGdep
4100  asolsol = 1.0_rp &
4101  + r_cva*( lhv00 + lhf00 + (cvvap-ci)*tem(k,i,j) )*dqsidtem_rho(k,i,j)
4102  pdynliq = w * grav * ( r_cpa*dqswdtem_pre(k,i,j) + rho(k,i,j)*dqswdpre_tem(k,i,j) )
4103  pdynsol = w * grav * ( r_cpa*dqsidtem_pre(k,i,j) + rho(k,i,j)*dqsidpre_tem(k,i,j) )
4104  pradliq = -dtdt_rad(k,i,j) * dqswdtem_rho(k,i,j)
4105  pradsol = -dtdt_rad(k,i,j) * dqsidtem_rho(k,i,j)
4106 
4107  ssw_o = ssw
4108  ssi_o = ssi
4109 ! ssw_o = ssw - Pdynliq*(dt_dyn-dt_mp)/qsw(k,i,j) + Pradliq*r_qsw*dt_mp
4110 ! ssi_o = ssi - Pdynsol*(dt_dyn-dt_mp)/qsi(k,i,j) + Pradsol*r_qsi*dt_mp
4111 
4112  acnd = pdynliq + pradliq &
4113  - ( r_taudep_i+r_taudep_s+r_taudep_g ) * ( qsw(k,i,j) - qsi(k,i,j) )
4114  adep = pdynsol + pradsol &
4115  + ( r_taucnd_c+r_taucnd_r ) * ( qsw(k,i,j) - qsi(k,i,j) )
4116  r_taucnd = &
4117  + aliqliq*( r_taucnd_c+r_taucnd_r ) &
4118  + asolliq*( r_taudep_i+r_taudep_s+r_taudep_g )
4119  r_taudep = &
4120  + aliqsol*( r_taucnd_c+r_taucnd_r )&
4121  + asolsol*( r_taudep_i+r_taudep_s+r_taudep_g )
4122 
4123  uplim_cnd = max( rho(k,i,j)*ssw_o*qsw(k,i,j)*r_dt, 0.0_rp )
4124  lowlim_cnd = min( rho(k,i,j)*ssw_o*qsw(k,i,j)*r_dt, 0.0_rp )
4125  if( r_taucnd < r_tau100day )then
4126 ! taucnd = tau100day
4127  pq(i_lcdep,k,i,j) = max(lowlim_cnd, min(uplim_cnd, pq(i_lcdep,k,i,j)*ssw_o ))
4128  pq(i_lrdep,k,i,j) = max(lowlim_cnd, min(uplim_cnd, pq(i_lrdep,k,i,j)*ssw_o ))
4129  pq(i_nrdep,k,i,j) = min(0.0_rp, pq(i_nrdep,k,i,j)*ssw_o )
4130 ! PLR2NR = 0.0_RP
4131  else
4132  taucnd = 1.0_rp/r_taucnd
4133  ! Production term for liquid water content
4134  coef_a_cnd = rho(k,i,j)*acnd*taucnd
4135  coef_b_cnd = rho(k,i,j)*taucnd*r_dt*(ssw_o*qsw(k,i,j)-acnd*taucnd) * ( exp(-dt*r_taucnd) - 1.0_rp )
4136  pq(i_lcdep,k,i,j) = coef_a_cnd*r_taucnd_c - coef_b_cnd*r_taucnd_c
4137  plr2nr = pq(i_nrdep,k,i,j)/(pq(i_lrdep,k,i,j)+1.e-30_rp)
4138  pq(i_lrdep,k,i,j) = coef_a_cnd*r_taucnd_r - coef_b_cnd*r_taucnd_r
4139  pq(i_nrdep,k,i,j) = min(0.0_rp, pq(i_lrdep,k,i,j)*plr2nr )
4140  end if
4141 
4142  uplim_dep = max( rho(k,i,j)*ssi_o*qsi(k,i,j)*r_dt, 0.0_rp )
4143  lowlim_dep = min( rho(k,i,j)*ssi_o*qsi(k,i,j)*r_dt, 0.0_rp )
4144  if( r_taudep < r_tau100day )then
4145 ! taudep = tau100day
4146  pq(i_lidep,k,i,j) = max(lowlim_dep, min(uplim_dep, pq(i_lidep,k,i,j)*ssi_o ))
4147  pq(i_lsdep,k,i,j) = max(lowlim_dep, min(uplim_dep, pq(i_lsdep,k,i,j)*ssi_o ))
4148  pq(i_lgdep,k,i,j) = max(lowlim_dep, min(uplim_dep, pq(i_lgdep,k,i,j)*ssi_o ))
4149  pq(i_nidep,k,i,j) = min(0.0_rp, pq(i_nidep,k,i,j)*ssi_o )
4150  pq(i_nsdep,k,i,j) = min(0.0_rp, pq(i_nsdep,k,i,j)*ssi_o )
4151  pq(i_ngdep,k,i,j) = min(0.0_rp, pq(i_ngdep,k,i,j)*ssi_o )
4152  else
4153  taudep = 1.0_rp/r_taudep
4154  ! Production term for ice water content
4155  coef_a_dep = rho(k,i,j)*adep*taudep
4156  coef_b_dep = rho(k,i,j)*taudep*r_dt*(ssi_o*qsi(k,i,j)-adep*taudep) * ( exp(-dt*r_taudep) - 1.0_rp )
4157  pli2ni = pq(i_nidep,k,i,j)/max(pq(i_lidep,k,i,j),1.e-30_rp)
4158  pls2ns = pq(i_nsdep,k,i,j)/max(pq(i_lsdep,k,i,j),1.e-30_rp)
4159  plg2ng = pq(i_ngdep,k,i,j)/max(pq(i_lgdep,k,i,j),1.e-30_rp)
4160  pq(i_lidep,k,i,j) = coef_a_dep*r_taudep_i - coef_b_dep*r_taudep_i
4161  pq(i_lsdep,k,i,j) = coef_a_dep*r_taudep_s - coef_b_dep*r_taudep_s
4162  pq(i_lgdep,k,i,j) = coef_a_dep*r_taudep_g - coef_b_dep*r_taudep_g
4163  pq(i_nidep,k,i,j) = min(0.0_rp, pq(i_lidep,k,i,j)*pli2ni )
4164  pq(i_nsdep,k,i,j) = min(0.0_rp, pq(i_lsdep,k,i,j)*pls2ns )
4165  pq(i_ngdep,k,i,j) = min(0.0_rp, pq(i_lgdep,k,i,j)*plg2ng )
4166  end if
4167 
4168  sw = 0.5_rp - sign(0.5_rp, pq(i_lcdep,k,i,j)+eps) != 1 for PLCdep<=-eps
4169  pncdep = min(0.0_rp, ((rhoq2(i_qc,k,i,j)+pq(i_lcdep,k,i,j)*dt)*r_xc_ccn - rhoq2(i_nc,k,i,j))*r_dt ) * sw
4170 ! if( PQ(I_LCdep,k,i,j) < -eps )then
4171 ! PNCdep = min(0.0_RP, ((rhoq2(I_QC,k,i,j)+PQ(I_LCdep,k,i,j)*dt)*r_xc_ccn - rhoq2(I_NC,k,i,j))*r_dt )
4172 ! else
4173 ! PNCdep = 0.0_RP
4174 ! end if
4175 ! if( PQ(I_LIdep,k,i,j) < -eps )then
4176 ! PQ(I_NIdep,k,i,j) = min(0.0_RP, ((li(k,i,j)+PQ(I_LIdep,k,i,j)*dt)*r_xi_ccn - rhoq2(I_NI,k,i,j))*r_dt )
4177 ! else
4178 ! PQ(I_NIdep,k,i,j) = 0.0_RP
4179 ! end if
4180 
4181  !--- evaporation/condensation
4182  r_rvaptem = 1.0_rp/(rvap*wtem(k,i,j))
4183  lvsw = esw(k,i,j)*r_rvaptem
4184  dlvsw = rhoq2(i_qv,k,i,j)-lvsw
4185  dcnd = dt*(pq(i_lcdep,k,i,j)+pq(i_lrdep,k,i,j))
4186 
4187  sw = ( sign(0.5_rp,dcnd) + sign(0.5_rp,dlvsw) ) &
4188  * ( 0.5_rp + sign(0.5_rp,abs(dcnd)-eps) ) ! to avoid zero division
4189  ! sw= 1: always supersaturated
4190  ! sw=-1: always unsaturated
4191  ! sw= 0: partially unsaturated during timestep
4192  fac1 = min(dlvsw*sw,dcnd*sw)*sw / (abs(sw)-1.0_rp+dcnd) & ! sw=1,-1
4193  + 1.0_rp - abs(sw) ! sw=0
4194  dep_dqc = max( dt*pq(i_lcdep,k,i,j)*fac1, &
4195  -rhoq2(i_qc,k,i,j) - 1e30_rp*(sw+1.0_rp) )*abs(sw) != -lc for sw=-1, -inf for sw=1
4196  dep_dqr = max( dt*pq(i_lrdep,k,i,j)*fac1, &
4197  -rhoq2(i_qr,k,i,j) - 1e30_rp*(sw+1.0_rp) )*abs(sw) != -lr for sw=-1, -inf for sw=1
4198 ! if ( (dcnd > eps) .AND. (dlvsw > eps) )then
4199 ! ! always supersaturated
4200 ! fac1 = min(dlvsw,dcnd)/dcnd
4201 ! dep_dqc = dt*PQ(I_LCdep,k,i,j)*fac1
4202 ! dep_dqr = dt*PQ(I_LRdep,k,i,j)*fac1
4203 ! else if( (dcnd < -eps) .AND. (dlvsw < -eps) )then
4204 ! ! always unsaturated
4205 ! fac1 = max( dlvsw,dcnd )/dcnd
4206 ! dep_dqc = max( dt*PQ(I_LCdep,k,i,j)*fac1, -rhoq2(I_QC,k,i,j) )
4207 ! dep_dqr = max( dt*PQ(I_LRdep,k,i,j)*fac1, -rhoq2(I_QR,k,i,j) )
4208 ! else
4209 ! ! partially unsaturated during timestep
4210 ! fac1 = 1.0_RP
4211 ! dep_dqc = 0.0_RP
4212 ! dep_dqr = 0.0_RP
4213 ! end if
4214 
4215  ! evaporation always lose number(always negative).
4216  dep_dnc = max( dt*pncdep*fac1, -rhoq2(i_nc,k,i,j) ) ! ss>0 dep=0, ss<0 dep<0 ! [Add] 11/08/30 T.Mitsui
4217  dep_dnr = max( dt*pq(i_nrdep,k,i,j)*fac1, -rhoq2(i_nr,k,i,j) ) ! ss>0 dep=0, ss<0 dep<0
4218 
4219  qc_evaporate(k,i,j) = - dep_dnc ! [Add] Y.Sato 15/09/08
4220 
4221  !--- deposition/sublimation
4222  lvsi = esi(k,i,j)*r_rvaptem
4223  ddep = dt*(pq(i_lidep,k,i,j)+pq(i_lsdep,k,i,j)+pq(i_lgdep,k,i,j))
4224  dlvsi = rhoq2(i_qv,k,i,j)-lvsi ! limiter for esi>1.d0
4225 
4226  sw = ( sign(0.5_rp,ddep) + sign(0.5_rp,dlvsi) ) &
4227  * ( 0.5_rp + sign(0.5_rp,abs(ddep)-eps) ) ! to avoid zero division
4228  ! sw= 1: always supersaturated
4229  ! sw=-1: always unsaturated
4230  ! sw= 0: partially unsaturated during timestep
4231  fac2 = min(dlvsi*sw,ddep*sw)*sw / (abs(sw)-1.0_rp+ddep) & ! sw=1,-1
4232  + 1.0_rp - abs(sw) ! sw=0
4233  dep_dqi = max( dt*pq(i_lidep,k,i,j) &
4234  * ( 1.0_rp-abs(sw) + fac2*abs(sw) ), & != fac2 for sw=-1,1, 1 for sw=0
4235  -rhoq2(i_qi,k,i,j) - 1e30_rp*(sw+1.0_rp) ) != -li for sw=-1, -inf for sw=0,1
4236  dep_dqs = max( dt*pq(i_lsdep,k,i,j) &
4237  * ( 1.0_rp-abs(sw) + fac2*abs(sw) ), & != fac2 for sw=-1,1, 1 for sw=0
4238  -rhoq2(i_qs,k,i,j) - 1e30_rp*(sw+1.0_rp) ) != -ls for sw=-1, -inf for sw=0,1
4239  dep_dqg = max( dt*pq(i_lgdep,k,i,j) &
4240  * ( 1.0_rp-abs(sw) + fac2*abs(sw) ), & != fac2 for sw=-1,1, 1 for sw=0
4241  -rhoq2(i_qg,k,i,j) - 1e30_rp*(sw+1.0_rp) ) != -lg for sw=-1, -inf for sw=0,1
4242 ! if ( (ddep > eps) .AND. (dlvsi > eps) )then
4243 ! ! always supersaturated
4244 ! fac2 = min(dlvsi,ddep)/ddep
4245 ! dep_dqi = dt*PQ(I_LIdep,k,i,j)*fac2
4246 ! dep_dqs = dt*PQ(I_LSdep,k,i,j)*fac2
4247 ! dep_dqg = dt*PQ(I_LGdep,k,i,j)*fac2
4248 ! else if ( (ddep < -eps) .AND. (dlvsi < -eps) )then
4249 ! ! always unsaturated
4250 ! fac2 = max(dlvsi,ddep)/ddep
4251 ! dep_dqi = max(dt*PQ(I_LIdep,k,i,j)*fac2, -rhoq2(I_QI,k,i,j) )
4252 ! dep_dqs = max(dt*PQ(I_LSdep,k,i,j)*fac2, -rhoq2(I_QS,k,i,j) )
4253 ! dep_dqg = max(dt*PQ(I_LGdep,k,i,j)*fac2, -rhoq2(I_QG,k,i,j) )
4254 ! else
4255 ! ! partially unsaturated during timestep
4256 ! fac2 = 1.0_RP
4257 ! dep_dqi = dt*PQ(I_LIdep,k,i,j)
4258 ! dep_dqs = dt*PQ(I_LSdep,k,i,j)
4259 ! dep_dqg = dt*PQ(I_LGdep,k,i,j)
4260 ! end if
4261 
4262  ! evaporation always lose number(always negative).
4263  dep_dni = max( dt*pq(i_nidep,k,i,j)*fac2, -rhoq2(i_ni,k,i,j) ) ! ss>0 dep=0, ss<0 dep<0
4264  dep_dns = max( dt*pq(i_nsdep,k,i,j)*fac2, -rhoq2(i_ns,k,i,j) ) ! ss>0 dep=0, ss<0 dep<0
4265  dep_dng = max( dt*pq(i_ngdep,k,i,j)*fac2, -rhoq2(i_ng,k,i,j) ) ! ss>0 dep=0, ss<0 dep<0
4266 
4267  !--- freezing of cloud drop
4268  frz_dqc = max( dt*(pq(i_lchom,k,i,j)+pq(i_lchet,k,i,j)), -rhoq2(i_qc,k,i,j)-dep_dqc ) ! negative value
4269  frz_dnc = max( dt*(pq(i_nchom,k,i,j)+pq(i_nchet,k,i,j)), -rhoq2(i_nc,k,i,j)-dep_dnc ) ! negative value
4270  fac3 = ( frz_dqc-eps )/( dt*(pq(i_lchom,k,i,j)+pq(i_lchet,k,i,j))-eps )
4271  fac4 = ( frz_dnc-eps )/( dt*(pq(i_nchom,k,i,j)+pq(i_nchet,k,i,j))-eps )
4272  pq(i_lchom,k,i,j) = fac3*pq(i_lchom,k,i,j)
4273  pq(i_lchet,k,i,j) = fac3*pq(i_lchet,k,i,j)
4274  pq(i_nchom,k,i,j) = fac4*pq(i_nchom,k,i,j)
4275  pq(i_nchet,k,i,j) = fac4*pq(i_nchet,k,i,j)
4276 
4277  !--- melting
4278  ! ice change
4279  mlt_dqi = max( dt*pq(i_limlt,k,i,j), -rhoq2(i_qi,k,i,j)-dep_dqi ) ! negative value
4280  mlt_dni = max( dt*pq(i_nimlt,k,i,j), -rhoq2(i_ni,k,i,j)-dep_dni ) ! negative value
4281  ! snow change
4282  mlt_dqs = max( dt*pq(i_lsmlt,k,i,j), -rhoq2(i_qs,k,i,j)-dep_dqs ) ! negative value
4283  mlt_dns = max( dt*pq(i_nsmlt,k,i,j), -rhoq2(i_ns,k,i,j)-dep_dns ) ! negative value
4284  ! graupel change
4285  mlt_dqg = max( dt*pq(i_lgmlt,k,i,j), -rhoq2(i_qg,k,i,j)-dep_dqg ) ! negative value
4286  mlt_dng = max( dt*pq(i_ngmlt,k,i,j), -rhoq2(i_ng,k,i,j)-dep_dng ) ! negative value
4287 
4288  !--- freezing of larger droplets
4289  frz_dqr = max( dt*(pq(i_lrhet,k,i,j)), min(0.0_rp, -rhoq2(i_qr,k,i,j)-dep_dqr) ) ! negative value
4290  frz_dnr = max( dt*(pq(i_nrhet,k,i,j)), min(0.0_rp, -rhoq2(i_nr,k,i,j)-dep_dnr) ) ! negative value
4291 
4292  fac5 = ( frz_dqr-eps )/( dt*pq(i_lrhet,k,i,j)-eps )
4293  pq(i_lrhet,k,i,j) = fac5*pq(i_lrhet,k,i,j)
4294  fac6 = ( frz_dnr-eps )/( dt*pq(i_nrhet,k,i,j)-eps )
4295  pq(i_nrhet,k,i,j) = fac6*pq(i_nrhet,k,i,j)
4296 
4297  ! water vapor change
4298  drhoqv = -(dep_dqc+dep_dqi+dep_dqs+dep_dqg+dep_dqr)
4299 
4300  rhoq(i_qv,k,i,j) = max(0.0_rp, rhoq(i_qv,k,i,j) + drhoqv )
4301 
4302  rhoe(k,i,j) = rhoe(k,i,j) - lhv * drhoqv
4303 
4304  xi = min(xi_max, max(xi_min, rhoq2(i_qi,k,i,j)/(rhoq2(i_ni,k,i,j)+ni_min) ))
4305  sw = 0.5_rp + sign(0.5_rp,xi-x_sep) ! if (xi>=x_sep) then sw=1 else sw=0
4306  ! sw=1: large ice crystals turn into rain by melting
4307 
4308  ! total cloud change
4309  drhoqc = ( frz_dqc - mlt_dqi*(1.0_rp-sw) + dep_dqc )
4310  drhonc = ( frz_dnc - mlt_dni*(1.0_rp-sw) + dep_dnc )
4311  ! total rain change
4312  drhoqr = ( frz_dqr - mlt_dqg - mlt_dqs - mlt_dqi*sw + dep_dqr )
4313  drhonr = ( frz_dnr - mlt_dng - mlt_dns - mlt_dni*sw + dep_dnr )
4314 
4315  rhoq(i_qc,k,i,j) = max(0.0_rp, rhoq(i_qc,k,i,j) + drhoqc )
4316  rhoq(i_nc,k,i,j) = max(0.0_rp, rhoq(i_nc,k,i,j) + drhonc )
4317  rhoq(i_qr,k,i,j) = max(0.0_rp, rhoq(i_qr,k,i,j) + drhoqr )
4318  rhoq(i_nr,k,i,j) = max(0.0_rp, rhoq(i_nr,k,i,j) + drhonr )
4319 
4320  ! total ice change
4321  drhoqi = (-frz_dqc + mlt_dqi + dep_dqi )
4322  drhoni = (-frz_dnc + mlt_dni + dep_dni )
4323 
4324  rhoq(i_qi,k,i,j) = max(0.0_rp, rhoq(i_qi,k,i,j) + drhoqi )
4325  rhoq(i_ni,k,i,j) = max(0.0_rp, rhoq(i_ni,k,i,j) + drhoni )
4326 
4327  rhoe(k,i,j) = rhoe(k,i,j) + lhf * drhoqi
4328 
4329  ! total snow change
4330  drhoqs = ( mlt_dqs + dep_dqs )
4331  drhons = ( mlt_dns + dep_dns )
4332 
4333  rhoq(i_qs,k,i,j) = max(0.0_rp, rhoq(i_qs,k,i,j) + drhoqs )
4334  rhoq(i_ns,k,i,j) = max(0.0_rp, rhoq(i_ns,k,i,j) + drhons )
4335 
4336  rhoe(k,i,j) = rhoe(k,i,j) + lhf * drhoqs
4337 
4338  ! total graupel change
4339  drhoqg = (-frz_dqr + mlt_dqg + dep_dqg )
4340  drhong = (-frz_dnr + mlt_dng + dep_dng )
4341 
4342  rhoq(i_qg,k,i,j) = max(0.0_rp, rhoq(i_qg,k,i,j) + drhoqg )
4343  rhoq(i_ng,k,i,j) = max(0.0_rp, rhoq(i_ng,k,i,j) + drhong )
4344 
4345  rhoe(k,i,j) = rhoe(k,i,j) + lhf * drhoqg
4346 
4347  !--- update mixing ratio
4348  rrho = 1.0_rp/rho(k,i,j)
4349 
4350  q(k,i,j,i_qv) = rhoq(i_qv,k,i,j) * rrho
4351  q(k,i,j,i_qc) = rhoq(i_qc,k,i,j) * rrho
4352  q(k,i,j,i_qr) = rhoq(i_qr,k,i,j) * rrho
4353  q(k,i,j,i_qi) = rhoq(i_qi,k,i,j) * rrho
4354  q(k,i,j,i_qs) = rhoq(i_qs,k,i,j) * rrho
4355  q(k,i,j,i_qg) = rhoq(i_qg,k,i,j) * rrho
4356  q(k,i,j,i_nc) = rhoq(i_nc,k,i,j) * rrho
4357  q(k,i,j,i_nr) = rhoq(i_nr,k,i,j) * rrho
4358  q(k,i,j,i_ni) = rhoq(i_ni,k,i,j) * rrho
4359  q(k,i,j,i_ns) = rhoq(i_ns,k,i,j) * rrho
4360  q(k,i,j,i_ng) = rhoq(i_ng,k,i,j) * rrho
4361 
4362  calc_qdry( qdry, q, tracer_mass, k, i, j, iqw )
4363  calc_cv( cva(k,i,j), qdry, q, k, i, j, iqw, cvdry, tracer_cv )
4364  calc_r( rmoist, qdry, q, k, i, j, iqw, rdry, tracer_r )
4365  tem(k,i,j) = rhoe(k,i,j) / ( rho(k,i,j) * cva(k,i,j) )
4366  pre(k,i,j) = rho(k,i,j) * rmoist * tem(k,i,j)
4367 
4368  sl_plcdep(i,j) = sl_plcdep(i,j) + dep_dqc*dz(k)*gsgam2(k,i,j)
4369  sl_plrdep(i,j) = sl_plrdep(i,j) + dep_dqr*dz(k)*gsgam2(k,i,j)
4370  sl_pnrdep(i,j) = sl_pnrdep(i,j) + dep_dnr*dz(k)*gsgam2(k,i,j)
4371  end do
4372  end do
4373  end do
4374  profile_stop("sn14_update")
4375 
4376  return
4377  end subroutine update_by_phase_change_kij
4378  !-------------------------------------------------------------------------------
4379  subroutine mp_negativefilter( &
4380  DENS, &
4381  QTRC )
4382  use scale_tracer, only: &
4383  qa
4384  implicit none
4385  real(RP), intent(inout) :: DENS(KA,IA,JA)
4386  real(RP), intent(inout) :: QTRC(KA,IA,JA,QA)
4387 
4388  real(RP) :: diffq(KA,IA,JA)
4389  real(RP) :: r_xmin
4390 
4391  integer :: k, i, j, iq
4392  !---------------------------------------------------------------------------
4393 
4394  call prof_rapstart('MP_filter', 3)
4395 
4396  r_xmin = 1.0_rp / xmin_filter
4397 
4398  ! total hydrometeor (before correction)
4399  do j = js, je
4400  do i = is, ie
4401 
4402  do k = ks, ke
4403  diffq(k,i,j) = qtrc(k,i,j,i_qv) &
4404  + qtrc(k,i,j,i_qc) &
4405  + qtrc(k,i,j,i_qr) &
4406  + qtrc(k,i,j,i_qi) &
4407  + qtrc(k,i,j,i_qs) &
4408  + qtrc(k,i,j,i_qg)
4409  enddo
4410 
4411  ! remove negative value of hydrometeor (mass, number)
4412  do iq = i_qc, i_ng
4413  do k = ks, ke
4414  qtrc(k,i,j,iq) = max(0.0_rp, qtrc(k,i,j,iq))
4415  enddo
4416  enddo
4417 
4418  ! apply correction of hydrometeor to total density
4419  ! [note] mass conservation is broken here to fill rounding error.
4420  do k = ks, ke
4421  dens(k,i,j) = dens(k,i,j) &
4422  * ( 1.0_rp &
4423  + qtrc(k,i,j,i_qv) &
4424  + qtrc(k,i,j,i_qc) &
4425  + qtrc(k,i,j,i_qr) &
4426  + qtrc(k,i,j,i_qi) &
4427  + qtrc(k,i,j,i_qs) &
4428  + qtrc(k,i,j,i_qg) &
4429  - diffq(k,i,j) ) ! after-before
4430  enddo
4431 
4432  ! avoid unrealistical value of number concentration
4433  ! due to numerical diffusion in advection
4434 
4435  do k = ks, ke
4436  if ( qtrc(k,i,j,i_nc) > qtrc(k,i,j,i_qc)*r_xmin ) then
4437  qtrc(k,i,j,i_nc) = qtrc(k,i,j,i_qc)*r_xmin
4438  endif
4439  enddo
4440  do k = ks, ke
4441  if ( qtrc(k,i,j,i_nr) > qtrc(k,i,j,i_qr)*r_xmin ) then
4442  qtrc(k,i,j,i_nr) = qtrc(k,i,j,i_qr)*r_xmin
4443  endif
4444  enddo
4445  do k = ks, ke
4446  if ( qtrc(k,i,j,i_ni) > qtrc(k,i,j,i_qi)*r_xmin ) then
4447  qtrc(k,i,j,i_ni) = qtrc(k,i,j,i_qi)*r_xmin
4448  endif
4449  enddo
4450  do k = ks, ke
4451  if ( qtrc(k,i,j,i_ns) > qtrc(k,i,j,i_qs)*r_xmin ) then
4452  qtrc(k,i,j,i_ns) = qtrc(k,i,j,i_qs)*r_xmin
4453  endif
4454  enddo
4455  do k = ks, ke
4456  if ( qtrc(k,i,j,i_ng) > qtrc(k,i,j,i_qg)*r_xmin ) then
4457  qtrc(k,i,j,i_ng) = qtrc(k,i,j,i_qg)*r_xmin
4458  endif
4459  enddo
4460 
4461  enddo
4462  enddo
4463 
4464  call prof_rapend('MP_filter', 3)
4465 
4466  return
4467  end subroutine mp_negativefilter
4468  !-------------------------------------------------------------------------------
4469 
4470  !-----------------------------------------------------------------------------
4472  subroutine atmos_phy_mp_sn14_cloudfraction( &
4473  cldfrac, &
4474  QTRC, &
4475  mask_criterion )
4476  use scale_grid_index
4477  use scale_tracer, only: &
4478  qa
4479  implicit none
4480 
4481  real(RP), intent(out) :: cldfrac(ka,ia,ja)
4482  real(RP), intent(in) :: qtrc (ka,ia,ja,qa)
4483  real(RP), intent(in) :: mask_criterion
4484 
4485  real(RP) :: qhydro
4486  integer :: k, i, j, iq
4487  !---------------------------------------------------------------------------
4488 
4489  do j = js, je
4490  do i = is, ie
4491  do k = ks, ke
4492  qhydro = 0.0_rp
4493  do iq = i_qc, i_qg
4494  qhydro = qhydro + qtrc(k,i,j,iq)
4495  enddo
4496  cldfrac(k,i,j) = 0.5_rp + sign(0.5_rp,qhydro-mask_criterion)
4497  enddo
4498  enddo
4499  enddo
4500 
4501  return
4502  end subroutine atmos_phy_mp_sn14_cloudfraction
4503 
4504  !-----------------------------------------------------------------------------
4506  subroutine atmos_phy_mp_sn14_effectiveradius( &
4507  Re, &
4508  QTRC0, &
4509  DENS0, &
4510  TEMP0 )
4511  use scale_grid_index
4512  use scale_tracer, only: &
4513  qa
4514  use scale_atmos_hydrometeor, only: &
4515  n_hyd
4516  implicit none
4517 
4518  real(RP), intent(out) :: re (ka,ia,ja,n_hyd) ! effective radius [cm]
4519  real(RP), intent(in) :: qtrc0(ka,ia,ja,qa) ! tracer mass concentration [kg/kg]
4520  real(RP), intent(in) :: dens0(ka,ia,ja) ! density [kg/m3]
4521  real(RP), intent(in) :: temp0(ka,ia,ja) ! temperature [K]
4522 
4523  ! mass concentration[kg/m3] and mean particle mass[kg]
4524  real(RP) :: xc(ka,ia,ja)
4525  real(RP) :: xr(ka,ia,ja)
4526  real(RP) :: xi(ka,ia,ja)
4527  real(RP) :: xs(ka,ia,ja)
4528  real(RP) :: xg(ka,ia,ja)
4529  ! diameter of average mass[kg/m3]
4530  real(RP) :: dc_ave(ka,ia,ja)
4531  real(RP) :: dr_ave(ka,ia,ja)
4532  ! radius of average mass
4533  real(RP) :: rc, rr
4534  ! 2nd. and 3rd. order moment of DSD
4535  real(RP) :: ri2m(ka,ia,ja), ri3m(ka,ia,ja)
4536  real(RP) :: rs2m(ka,ia,ja), rs3m(ka,ia,ja)
4537  real(RP) :: rg2m(ka,ia,ja), rg3m(ka,ia,ja)
4538 
4539  real(RP) :: coef_fuetal1998
4540  ! r2m_min is minimum value(moment of 1 particle with 1 micron)
4541  real(RP), parameter :: r2m_min=1.e-12_rp
4542  real(RP), parameter :: um2cm = 100.0_rp
4543 
4544  real(RP) :: limitsw, zerosw
4545  integer :: k, i, j
4546  !---------------------------------------------------------------------------
4547 
4548  ! mean particle mass[kg]
4549  do j = js, je
4550  do i = is, ie
4551  do k = ks, ke
4552  xc(k,i,j) = min( xc_max, max( xc_min, dens0(k,i,j)*qtrc0(k,i,j,i_qc)/(qtrc0(k,i,j,i_nc)+nc_min) ) )
4553  xr(k,i,j) = min( xr_max, max( xr_min, dens0(k,i,j)*qtrc0(k,i,j,i_qr)/(qtrc0(k,i,j,i_nr)+nr_min) ) )
4554  xi(k,i,j) = min( xi_max, max( xi_min, dens0(k,i,j)*qtrc0(k,i,j,i_qi)/(qtrc0(k,i,j,i_ni)+ni_min) ) )
4555  xs(k,i,j) = min( xs_max, max( xs_min, dens0(k,i,j)*qtrc0(k,i,j,i_qs)/(qtrc0(k,i,j,i_ns)+ns_min) ) )
4556  xg(k,i,j) = min( xg_max, max( xg_min, dens0(k,i,j)*qtrc0(k,i,j,i_qg)/(qtrc0(k,i,j,i_ng)+ng_min) ) )
4557  enddo
4558  enddo
4559  enddo
4560 
4561  ! diameter of average mass : SB06 eq.(32)
4562  do j = js, je
4563  do i = is, ie
4564  do k = ks, ke
4565  dc_ave(k,i,j) = a_m(i_mp_qc) * xc(k,i,j)**b_m(i_mp_qc)
4566  dr_ave(k,i,j) = a_m(i_mp_qr) * xr(k,i,j)**b_m(i_mp_qr)
4567  enddo
4568  enddo
4569  enddo
4570 
4571  ! cloud effective radius
4572  do j = js, je
4573  do i = is, ie
4574  do k = ks, ke
4575  rc = 0.5_rp * dc_ave(k,i,j)
4576  limitsw = 0.5_rp + sign(0.5_rp, rc-rmin_re )
4577  re(k,i,j,i_hc) = coef_re(i_mp_qc) * rc * limitsw * um2cm
4578  enddo
4579  enddo
4580  enddo
4581 
4582  ! rain effective radius
4583  do j = js, je
4584  do i = is, ie
4585  do k = ks, ke
4586  rr = 0.5_rp * dr_ave(k,i,j)
4587  limitsw = 0.5_rp + sign(0.5_rp, rr-rmin_re )
4588  re(k,i,j,i_hr) = coef_re(i_mp_qr) * rr * limitsw * um2cm
4589  enddo
4590  enddo
4591  enddo
4592 
4593  do j = js, je
4594  do i = is, ie
4595  do k = ks, ke
4596  ri2m(k,i,j) = pi * coef_rea2(i_mp_qi) * qtrc0(k,i,j,i_ni) * a_rea2(i_mp_qi) * xi(k,i,j)**b_rea2(i_mp_qi)
4597  rs2m(k,i,j) = pi * coef_rea2(i_mp_qs) * qtrc0(k,i,j,i_ns) * a_rea2(i_mp_qs) * xs(k,i,j)**b_rea2(i_mp_qs)
4598  rg2m(k,i,j) = pi * coef_rea2(i_mp_qg) * qtrc0(k,i,j,i_ng) * a_rea2(i_mp_qg) * xg(k,i,j)**b_rea2(i_mp_qg)
4599  enddo
4600  enddo
4601  enddo
4602 
4603  ! Fu(1996), eq.(3.11) or Fu et al.(1998), eq.(2.5)
4604  coef_fuetal1998 = 3.0_rp / (4.0_rp*rhoi)
4605  do j = js, je
4606  do i = is, ie
4607  do k = ks, ke
4608  ri3m(k,i,j) = coef_fuetal1998 * qtrc0(k,i,j,i_ni) * xi(k,i,j)
4609  rs3m(k,i,j) = coef_fuetal1998 * qtrc0(k,i,j,i_ns) * xs(k,i,j)
4610  rg3m(k,i,j) = coef_fuetal1998 * qtrc0(k,i,j,i_ng) * xg(k,i,j)
4611  enddo
4612  enddo
4613  enddo
4614 
4615  ! ice effective radius
4616  do j = js, je
4617  do i = is, ie
4618  do k = ks, ke
4619  zerosw = 0.5_rp - sign(0.5_rp, ri2m(k,i,j) - r2m_min )
4620  re(k,i,j,i_hi) = ri3m(k,i,j) / ( ri2m(k,i,j) + zerosw ) * ( 1.0_rp - zerosw ) * um2cm
4621  enddo
4622  enddo
4623  enddo
4624 
4625  ! snow effective radius
4626  do j = js, je
4627  do i = is, ie
4628  do k = ks, ke
4629  zerosw = 0.5_rp - sign(0.5_rp, rs2m(k,i,j) - r2m_min )
4630  re(k,i,j,i_hs) = rs3m(k,i,j) / ( rs2m(k,i,j) + zerosw ) * ( 1.0_rp - zerosw ) * um2cm
4631  enddo
4632  enddo
4633  enddo
4634 
4635  ! graupel effective radius
4636  do j = js, je
4637  do i = is, ie
4638  do k = ks, ke
4639  zerosw = 0.5_rp - sign(0.5_rp, rg2m(k,i,j) - r2m_min )
4640  re(k,i,j,i_hg) = rg3m(k,i,j) / ( rg2m(k,i,j) + zerosw ) * ( 1.0_rp - zerosw ) * um2cm
4641  enddo
4642  enddo
4643  enddo
4644 
4645  re(:,:,:,i_hg+1:) = 0.0_rp
4646 
4647  return
4648  end subroutine atmos_phy_mp_sn14_effectiveradius
4649  !-----------------------------------------------------------------------------
4651  subroutine atmos_phy_mp_sn14_mixingratio( &
4652  Qe, &
4653  QTRC0 )
4654  use scale_grid_index
4655  use scale_tracer, only: &
4656  qa
4657  use scale_atmos_hydrometeor, only: &
4658  n_hyd
4659  implicit none
4660 
4661  real(RP), intent(out) :: qe (ka,ia,ja,n_hyd) ! mixing ratio of each cateory [kg/kg]
4662  real(RP), intent(in) :: qtrc0(ka,ia,ja,qa) ! tracer mass concentration [kg/kg]
4663 
4664  integer :: ihydro, iqa
4665  !---------------------------------------------------------------------------
4666 
4667 
4668  qe(:,:,:,i_hc) = qtrc0(:,:,:,i_qc)
4669  qe(:,:,:,i_hr) = qtrc0(:,:,:,i_qr)
4670  qe(:,:,:,i_hi) = qtrc0(:,:,:,i_qi)
4671  qe(:,:,:,i_hs) = qtrc0(:,:,:,i_qs)
4672  qe(:,:,:,i_hg) = qtrc0(:,:,:,i_qg)
4673  qe(:,:,:,i_hg+1:) = 0.0_rp
4674 
4675  return
4676  end subroutine atmos_phy_mp_sn14_mixingratio
4677 
4678 end module scale_atmos_phy_mp_sn14
scale_atmos_phy_mp_sn14::atmos_phy_mp_sn14_desc
character(len=h_mid), dimension(qa_mp), target, public atmos_phy_mp_sn14_desc
Definition: scale_atmos_phy_mp_sn14.F90:140
scale_grid_index::is
integer, public is
start point of inner domain: x, local
Definition: scale_grid_index.F90:60
scale_atmos_phy_mp_sn14::nucleation_kij
subroutine nucleation_kij(z, velz, rho, tem, pre, rhoq, PQ, cpa, dTdt_rad, qke, CCN, dt)
Definition: scale_atmos_phy_mp_sn14.F90:2214
scale_atmos_hydrometeor::i_qr
integer, public i_qr
Definition: scale_atmos_sub_hydrometeor.F90:80
scale_atmos_phy_mp_sn14::atmos_phy_mp_sn14_effectiveradius
subroutine, public atmos_phy_mp_sn14_effectiveradius(Re, QTRC0, DENS0, TEMP0)
Calculate Effective Radius.
Definition: scale_atmos_phy_mp_sn14.F90:4511
scale_const::const_cvdry
real(rp), public const_cvdry
specific heat (dry air,constant volume) [J/kg/K]
Definition: scale_const.F90:59
scale_const::const_psat0
real(rp), parameter, public const_psat0
saturate pressure of water vapor at 0C [Pa]
Definition: scale_const.F90:83
scale_grid_index::je
integer, public je
end point of inner domain: y, local
Definition: scale_grid_index.F90:63
scale_atmos_hydrometeor::i_qg
integer, public i_qg
Definition: scale_atmos_sub_hydrometeor.F90:83
scale_const::const_cpdry
real(rp), public const_cpdry
specific heat (dry air,constant pressure) [J/kg/K]
Definition: scale_const.F90:58
scale_atmos_saturation
module ATMOSPHERE / Saturation adjustment
Definition: scale_atmos_sub_saturation.F90:16
scale_process::prc_mpistop
subroutine, public prc_mpistop
Abort MPI.
Definition: scale_process.F90:267
scale_atmos_phy_mp_sn14
module ATMOSPHERE / Physics Cloud Microphysics
Definition: scale_atmos_phy_mp_sn14.F90:66
scale_atmos_hydrometeor::i_qs
integer, public i_qs
Definition: scale_atmos_sub_hydrometeor.F90:82
scale_atmos_phy_mp_sn14::atmos_phy_mp_sn14_setup
subroutine, public atmos_phy_mp_sn14_setup
Setup Cloud Microphysics.
Definition: scale_atmos_phy_mp_sn14.F90:615
scale_const::const_ci
real(rp), parameter, public const_ci
specific heat (ice) [J/kg/K]
Definition: scale_const.F90:69
scale_const::const_dwatr
real(rp), parameter, public const_dwatr
density of water [kg/m3]
Definition: scale_const.F90:84
scale_atmos_hydrometeor::i_qc
integer, public i_qc
Definition: scale_atmos_sub_hydrometeor.F90:79
scale_tracer::tracer_r
real(rp), dimension(qa_max), public tracer_r
Definition: scale_tracer.F90:41
scale_time::time_dtsec_atmos_phy_mp
real(dp), public time_dtsec_atmos_phy_mp
time interval of physics(microphysics) [sec]
Definition: scale_time.F90:41
scale_stdio::io_l
logical, public io_l
output log or not? (this process)
Definition: scale_stdio.F90:61
scale_atmos_hydrometeor::i_hs
integer, parameter, public i_hs
snow
Definition: scale_atmos_sub_hydrometeor.F90:75
scale_specfunc::sf_gamma
real(rp) function, public sf_gamma(x)
Gamma function.
Definition: scale_specfunc.F90:48
scale_grid::grid_cz
real(rp), dimension(:), allocatable, public grid_cz
center coordinate [m]: z, local=global
Definition: scale_grid_cartesian.F90:56
scale_const::const_cl
real(rp), parameter, public const_cl
specific heat (liquid water) [J/kg/K]
Definition: scale_const.F90:68
scale_atmos_phy_mp_sn14::freezing_water_kij
subroutine freezing_water_kij(dt, PQ, rhoq, xq, tem)
Definition: scale_atmos_phy_mp_sn14.F90:3566
scale_atmos_hydrometeor::i_hr
integer, parameter, public i_hr
liquid water rain
Definition: scale_atmos_sub_hydrometeor.F90:73
scale_atmos_hydrometeor::i_ns
integer, public i_ns
Definition: scale_atmos_sub_hydrometeor.F90:89
scale_atmos_hydrometeor::i_ni
integer, public i_ni
Definition: scale_atmos_sub_hydrometeor.F90:88
scale_atmos_hydrometeor::i_hi
integer, parameter, public i_hi
ice water cloud
Definition: scale_atmos_sub_hydrometeor.F90:74
scale_stdio
module STDIO
Definition: scale_stdio.F90:12
scale_grid_index::ke
integer, public ke
end point of inner domain: z, local
Definition: scale_grid_index.F90:59
scale_atmos_phy_mp_sn14::ice_multiplication_kij
subroutine ice_multiplication_kij(PQ, Pac, tem, rhoq, xq)
Definition: scale_atmos_phy_mp_sn14.F90:2600
scale_const::const_tem00
real(rp), parameter, public const_tem00
temperature reference (0C) [K]
Definition: scale_const.F90:92
scale_tracer::qa
integer, public qa
Definition: scale_tracer.F90:35
scale_atmos_phy_mp_sn14::dep_vapor_melt_ice_kij
subroutine dep_vapor_melt_ice_kij(PQ, rho, tem, pre, qd, rhoq, esw, esi, xq, vt_xave, dq_xave)
Definition: scale_atmos_phy_mp_sn14.F90:3327
scale_const::const_cvvap
real(rp), public const_cvvap
specific heat (water vapor, constant volume) [J/kg/K]
Definition: scale_const.F90:67
scale_atmos_hydrometeor::i_nc
integer, public i_nc
Definition: scale_atmos_sub_hydrometeor.F90:86
scale_atmos_phy_mp_sn14::atmos_phy_mp_sn14_dens
real(rp), dimension(n_hyd), target, public atmos_phy_mp_sn14_dens
Definition: scale_atmos_phy_mp_sn14.F90:143
scale_const::const_lhf0
real(rp), public const_lhf0
latent heat of fusion at 0C [J/kg]
Definition: scale_const.F90:81
scale_const::const_dice
real(rp), parameter, public const_dice
density of ice [kg/m3]
Definition: scale_const.F90:85
scale_tracer::tracer_cv
real(rp), dimension(qa_max), public tracer_cv
Definition: scale_tracer.F90:40
scale_atmos_saturation::atmos_saturation_dqsw_dtem_rho
subroutine, public atmos_saturation_dqsw_dtem_rho(dqsdtem, temp, dens)
Definition: scale_atmos_sub_saturation.F90:1178
scale_atmos_saturation::atmos_saturation_dqsw_dtem_dpre
subroutine, public atmos_saturation_dqsw_dtem_dpre(dqsdtem, dqsdpre, temp, pres)
Definition: scale_atmos_sub_saturation.F90:1261
scale_grid::dz
real(rp), public dz
length in the main region [m]: z
Definition: scale_grid_cartesian.F90:41
scale_const::const_rdry
real(rp), public const_rdry
specific gas constant (dry air) [J/kg/K]
Definition: scale_const.F90:57
scale_const::const_undef
real(rp), public const_undef
Definition: scale_const.F90:43
scale_atmos_phy_mp_sn14::mixed_phase_collection_kij
subroutine mixed_phase_collection_kij(Pac, PQ, wtem, rhoq, xq, dq_xave, vt_xave)
Definition: scale_atmos_phy_mp_sn14.F90:2737
scale_const::const_lhs0
real(rp), parameter, public const_lhs0
latent heat of sublimation at 0C [J/kg]
Definition: scale_const.F90:79
scale_atmos_phy_mp_sn14::atmos_phy_mp_sn14_cloudfraction
subroutine, public atmos_phy_mp_sn14_cloudfraction(cldfrac, QTRC, mask_criterion)
Calculate Cloud Fraction.
Definition: scale_atmos_phy_mp_sn14.F90:4476
scale_atmos_phy_mp_common
module ATMOSPHERE / Physics Cloud Microphysics - Common
Definition: scale_atmos_phy_mp_common.F90:16
scale_grid_index
module grid index
Definition: scale_grid_index.F90:14
scale_atmos_saturation::atmos_saturation_dqsi_dtem_rho
subroutine, public atmos_saturation_dqsi_dtem_rho(dqsdtem, temp, dens)
Definition: scale_atmos_sub_saturation.F90:1219
scale_tracer::tracer_cp
real(rp), dimension(qa_max), public tracer_cp
Definition: scale_tracer.F90:39
scale_stdio::io_nml
logical, public io_nml
output log or not? (for namelist, this process)
Definition: scale_stdio.F90:62
scale_atmos_phy_mp_sn14::debug_tem_kij
subroutine debug_tem_kij(point, tem, rho, pre, qv)
Definition: scale_atmos_phy_mp_sn14.F90:2174
scale_tracer
module TRACER
Definition: scale_tracer.F90:15
scale_grid_index::ia
integer, public ia
of whole cells: x, local, with HALO
Definition: scale_grid_index.F90:55
scale_atmos_phy_mp_sn14::atmos_phy_mp_sn14_name
character(len=h_short), dimension(qa_mp), target, public atmos_phy_mp_sn14_name
Definition: scale_atmos_phy_mp_sn14.F90:139
scale_atmos_hydrometeor
module Hydrometeor
Definition: scale_atmos_sub_hydrometeor.F90:14
scale_grid_index::ka
integer, public ka
of whole cells: z, local, with HALO
Definition: scale_grid_index.F90:54
scale_const::const_lhv0
real(rp), parameter, public const_lhv0
latent heat of vaporizaion at 0C [J/kg]
Definition: scale_const.F90:77
scale_const::const_pre00
real(rp), public const_pre00
pressure reference [Pa]
Definition: scale_const.F90:90
scale_atmos_phy_mp_sn14::qa_mp
integer, parameter, public qa_mp
Definition: scale_atmos_phy_mp_sn14.F90:137
scale_const::const_lhf00
real(rp), public const_lhf00
latent heat of fusion at 0K [J/kg]
Definition: scale_const.F90:82
scale_const::const_grav
real(rp), public const_grav
standard acceleration of gravity [m/s2]
Definition: scale_const.F90:48
scale_grid_index::js
integer, public js
start point of inner domain: y, local
Definition: scale_grid_index.F90:62
scale_time
module TIME
Definition: scale_time.F90:15
scale_process
module PROCESS
Definition: scale_process.F90:14
scale_atmos_phy_mp_sn14::update_by_phase_change_kij
subroutine update_by_phase_change_kij(ntdiv, ntmax, dt, gsgam2, z, dz, velz, dTdt_rad, rho, rhoe, rhoq, q, tem, pre, cva, esw, esi, rhoq2, PQ, qc_evaporate, sl_PLCdep, sl_PLRdep, sl_PNRdep)
Definition: scale_atmos_phy_mp_sn14.F90:3847
scale_const::const_lhv00
real(rp), public const_lhv00
latent heat of vaporizaion at 0K [J/kg]
Definition: scale_const.F90:78
scale_specfunc
module SPECFUNC
Definition: scale_specfunc.F90:13
scale_const::const_rvap
real(rp), parameter, public const_rvap
specific gas constant (water vapor) [J/kg/K]
Definition: scale_const.F90:65
scale_atmos_saturation::atmos_saturation_dqsi_dtem_dpre
subroutine, public atmos_saturation_dqsi_dtem_dpre(dqsdtem, dqsdpre, temp, pres)
Definition: scale_atmos_sub_saturation.F90:1310
scale_const
module CONSTANT
Definition: scale_const.F90:14
scale_atmos_hydrometeor::i_hc
integer, parameter, public i_hc
liquid water cloud
Definition: scale_atmos_sub_hydrometeor.F90:72
scale_grid_index::ks
integer, public ks
start point of inner domain: z, local
Definition: scale_grid_index.F90:58
scale_const::const_emelt
real(rp), parameter, public const_emelt
Definition: scale_const.F90:74
scale_process::prc_myrank
integer, public prc_myrank
process num in local communicator
Definition: scale_process.F90:79
scale_atmos_phy_mp_sn14::atmos_phy_mp_sn14_config
subroutine, public atmos_phy_mp_sn14_config(MP_TYPE, QA, QS)
Configure.
Definition: scale_atmos_phy_mp_sn14.F90:557
scale_grid
module GRID (cartesian)
Definition: scale_grid_cartesian.F90:17
scale_atmos_hydrometeor::i_nr
integer, public i_nr
Definition: scale_atmos_sub_hydrometeor.F90:87
scale_prof::prof_rapstart
subroutine, public prof_rapstart(rapname_base, level)
Start raptime.
Definition: scale_prof.F90:156
scale_const::const_undef8
real(dp), parameter, public const_undef8
undefined value (REAL8)
Definition: scale_const.F90:42
scale_atmos_phy_mp_sn14::atmos_phy_mp_sn14_mixingratio
subroutine, public atmos_phy_mp_sn14_mixingratio(Qe, QTRC0)
Calculate mixing ratio of each category.
Definition: scale_atmos_phy_mp_sn14.F90:4654
scale_atmos_phy_mp_sn14::atmos_phy_mp_sn14
subroutine, public atmos_phy_mp_sn14(DENS, MOMZ, MOMX, MOMY, RHOT, QTRC, CCN, EVAPORATE, SFLX_rain, SFLX_snow)
Cloud Microphysics.
Definition: scale_atmos_phy_mp_sn14.F90:716
scale_atmos_phy_mp_sn14::aut_acc_slc_brk_kij
subroutine aut_acc_slc_brk_kij(PQ, rhoq, xq, dq_xave, rho)
Definition: scale_atmos_phy_mp_sn14.F90:3227
scale_atmos_hydrometeor::i_qi
integer, public i_qi
Definition: scale_atmos_sub_hydrometeor.F90:81
scale_prof
module profiler
Definition: scale_prof.F90:10
scale_grid_index::ie
integer, public ie
end point of inner domain: x, local
Definition: scale_grid_index.F90:61
scale_atmos_phy_mp_sn14::atmos_phy_mp_sn14_unit
character(len=h_short), dimension(qa_mp), target, public atmos_phy_mp_sn14_unit
Definition: scale_atmos_phy_mp_sn14.F90:141
scale_const::const_eps
real(rp), public const_eps
small number
Definition: scale_const.F90:36
scale_atmos_hydrometeor::i_qv
integer, public i_qv
Definition: scale_atmos_sub_hydrometeor.F90:68
scale_precision
module PRECISION
Definition: scale_precision.F90:13
scale_grid::grid_cdz
real(rp), dimension(:), allocatable, public grid_cdz
z-length of control volume [m]
Definition: scale_grid_cartesian.F90:59
scale_atmos_hydrometeor::atmos_hydrometeor_regist
subroutine, public atmos_hydrometeor_regist(Q0, NV, NL, NI, NAME, DESC, UNIT, ADVC)
Regist tracer.
Definition: scale_atmos_sub_hydrometeor.F90:196
scale_history
module HISTORY
Definition: scale_history.F90:16
scale_const::const_pi
real(rp), public const_pi
pi
Definition: scale_const.F90:34
scale_atmos_phy_mp_common::atmos_phy_mp_precipitation
subroutine, public atmos_phy_mp_precipitation(QA_MP, QS_MP, qflx, vterm, DENS, MOMZ, MOMX, MOMY, RHOE, QTRC, temp, CVq, dt, vt_fixed)
precipitation transport
Definition: scale_atmos_phy_mp_common.F90:763
scale_stdio::io_fid_conf
integer, public io_fid_conf
Config file ID.
Definition: scale_stdio.F90:55
scale_tracer::tracer_regist
subroutine, public tracer_regist(QS, NQ, NAME, DESC, UNIT, CV, CP, R, ADVC, MASS)
Regist tracer.
Definition: scale_tracer.F90:64
scale_stdio::io_fid_log
integer, public io_fid_log
Log file ID.
Definition: scale_stdio.F90:56
scale_atmos_hydrometeor::n_hyd
integer, parameter, public n_hyd
Definition: scale_atmos_sub_hydrometeor.F90:70
scale_const::const_cpvap
real(rp), parameter, public const_cpvap
specific heat (water vapor, constant pressure) [J/kg/K]
Definition: scale_const.F90:66
scale_atmos_hydrometeor::i_ng
integer, public i_ng
Definition: scale_atmos_sub_hydrometeor.F90:90
scale_prof::prof_rapend
subroutine, public prof_rapend(rapname_base, level)
Save raptime.
Definition: scale_prof.F90:204
scale_precision::rp
integer, parameter, public rp
Definition: scale_precision.F90:43
scale_atmos_hydrometeor::i_hg
integer, parameter, public i_hg
graupel
Definition: scale_atmos_sub_hydrometeor.F90:76
scale_stdio::io_fid_nml
integer, public io_fid_nml
Log file ID (only for output namelist)
Definition: scale_stdio.F90:57
scale_tracer::tracer_mass
real(rp), dimension(qa_max), public tracer_mass
Definition: scale_tracer.F90:42
scale_atmos_phy_mp_sn14::mp_negativefilter
subroutine mp_negativefilter(DENS, QTRC)
Definition: scale_atmos_phy_mp_sn14.F90:4382
scale_grid_index::ja
integer, public ja
of whole cells: y, local, with HALO
Definition: scale_grid_index.F90:56
Generated by   doxygen 1.8.14