SCALE-RM
scale_atmos_phy_mp_suzuki10.F90
Go to the documentation of this file.
1 !-------------------------------------------------------------------------------
21 !-------------------------------------------------------------------------------
22 #include "scalelib.h"
23 module scale_atmos_phy_mp_suzuki10
24  !-----------------------------------------------------------------------------
25  !
26  !++ Used modules
27  !
28  use scale_precision
29  use scale_io
30  use scale_prof
31 
32  !-----------------------------------------------------------------------------
33  implicit none
34  private
35  !-----------------------------------------------------------------------------
36  !
37  !++ Public procedure
38  !
39  public :: atmos_phy_mp_suzuki10_tracer_setup
40  public :: atmos_phy_mp_suzuki10_setup
41  public :: atmos_phy_mp_suzuki10_tendency
42  public :: atmos_phy_mp_suzuki10_terminal_velocity
43  public :: atmos_phy_mp_suzuki10_cloud_fraction
44  public :: atmos_phy_mp_suzuki10_effective_radius
45  public :: atmos_phy_mp_suzuki10_qtrc2qhyd
46  public :: atmos_phy_mp_suzuki10_qtrc2nhyd
47  public :: atmos_phy_mp_suzuki10_qhyd2qtrc
48  public :: atmos_phy_mp_suzuki10_crg_qtrc2qhyd
49 
50  !-----------------------------------------------------------------------------
51  !
52  !++ Public parameters & variables
53  !
54  !-----------------------------------------------------------------------------
55  integer, public :: atmos_phy_mp_suzuki10_ntracers
56  integer, public :: atmos_phy_mp_suzuki10_nwaters
57  integer, public :: atmos_phy_mp_suzuki10_nices
58  integer, public :: atmos_phy_mp_suzuki10_nccn
59  integer, public :: atmos_phy_mp_suzuki10_nbnd
60 
61 
62  character(len=H_SHORT), public, allocatable :: atmos_phy_mp_suzuki10_tracer_names(:)
63  character(len=H_MID) , public, allocatable :: atmos_phy_mp_suzuki10_tracer_descriptions(:)
64  character(len=H_SHORT), public, allocatable :: atmos_phy_mp_suzuki10_tracer_units(:)
65 
66 # include "kernels.h"
67  !-----------------------------------------------------------------------------
68  !
69  !++ Private procedure
70  !
71  private :: mp_suzuki10
72  private :: nucleat
73  private :: nucleata
74  private :: cndevpsbl
75  private :: cndevpsbla
76  private :: liqphase
77  private :: icephase
78  private :: mixphase
79  private :: ice_nucleat
80  private :: freezing
81  private :: melting
82  private :: collmain
83  private :: collmainf
84  private :: collcoag
85  private :: getrule
86  private :: faero
87  private :: random_setup
88  private :: r_collcoag
89  private :: mkpara
90  private :: rdkdat
91  private :: sdfgrid
92  private :: getcp
93  private :: fcpc
94  private :: getck
95  private :: fckrn
96  private :: getvt
97  private :: fvterm
98  private :: getbr
99  private :: fbulkrad
100  private :: paraout
101  private :: tinvss
102  private :: getknot
103  private :: fbspl
104  private :: fpb
105  private :: getmatrx
106  private :: getcoef
107  private :: fspline
108  private :: getcoef2
109  private :: fspline2
110 
111  !-----------------------------------------------------------------------------
112  !
113  !++ Private parameters
114  !
115  integer :: qa
116  integer, parameter :: i_qv = 1
117 
118  character(len=3) :: namspc (8) = (/ 'Qcl', &
119  'Qic', &
120  'Qip', &
121  'Qid', &
122  'Qis', &
123  'Qig', &
124  'Qih', &
125  'Qae' /)
126 
127  character(len=27) :: lnamspc(8) = (/ 'Mixing ratio of cloud bin', &
128  'Mixing ratio of colum bin', &
129  'Mixing ratio of plate bin', &
130  'Mixing ratio of dendrit bin', &
131  'Mixing ratio of snow bin', &
132  'Mixing ratio of graupel bin', &
133  'Mixing ratio of hail bin', &
134  'Mixing ratio of aerosol bin' /)
135 
136  integer, public :: nbin = 33 ! tentatively public
137  integer :: nspc = 7
138  integer, public :: nccn = 0 ! tentatively public
139  integer :: kphase = 0
140  integer :: iceflg = 1
141  integer :: num_hyd = 0
142 
143  integer, parameter :: i_mp_qc = 1
144  integer, parameter :: i_mp_qcl = 2
145  integer, parameter :: i_mp_qp = 3
146  integer, parameter :: i_mp_qd = 4
147  integer, parameter :: i_mp_qs = 5
148  integer, parameter :: i_mp_qg = 6
149  integer, parameter :: i_mp_qh = 7
150 
151  logical :: mp_doautoconversion = .true. ! apply collision process ?
152  logical :: mp_couple_aerosol = .false. ! apply CCN effect?
153 
154  !--- array definition
155  integer :: num_start_waters
156  integer :: num_end_waters
157  integer :: num_start_ices
158  integer :: num_end_ices
159 
160  !--- Indeces for determining species of cloud particle
161  integer, parameter :: il = 1 !--- index for liquid water
162  integer, parameter :: ic = 2 !--- index for columnar ice
163  integer, parameter :: ip = 3 !--- index for plate ice
164  integer, parameter :: id = 4 !--- index for dendrite ice
165  integer, parameter :: iss = 5 !--- index for snow
166  integer, parameter :: ig = 6 !--- index for graupel
167  integer, parameter :: ih = 7 !--- index for hail
168 
169  !--- bin information of hydrometeors
170  real(rp) :: dxmic !--- d( log(m) ) of hydrometeor bin
171  real(rp), allocatable :: xctr( : ) !--- log( m ) value of bin center [xctr = exp( 4/3*pi*DWATER*radc^3 )]
172  real(rp), allocatable :: xbnd( : ) !--- log( m ) value of bin boundary
173  real(rp), allocatable :: radc( : ) !--- radius of hydrometeor at bin center [m]
174  real(rp), allocatable :: cctr( :,: ) !--- capacitance of hydrometeor at bin center (C of equation A.17 in Suzuki 2004)
175  real(rp), allocatable :: cbnd( :,: ) !--- capacitance of hydrometeor at bin boundary (C of equation A.17 in Suzuki 2004)
176  real(rp), allocatable :: ck( :,:,:,: ) !-- collection kernel (K of equation A.20 in Suzuki 2004)
177  real(rp), allocatable :: vt( :,: ) !--- terminal velocity of hydrometeor [m/s]
178  real(rp), allocatable :: br( :,: ) !--- bulk density of hydrometeor [kg/m^3]
179  integer, allocatable :: ifrsl( :,:,: ) !--- type of species after collision
180  !--- bin information of aerosol (not supported)
181  real(rp), allocatable :: xactr( : ) !--- log( ma ) value of bin center ( ma is mass of aerosol )
182  real(rp), allocatable :: xabnd( : ) !--- log( ma ) value of bin boundary ( ma is mass of aerosol )
183  real(rp), allocatable :: rada( : ) !--- radius of aerosol at bin center [m]
184 
185  real(rp), allocatable :: expxctr( : ) !--- exp( xctr )
186  real(rp), allocatable :: expxbnd( : ) !--- exp( xbnd )
187  real(rp), allocatable :: expxactr( : ) !--- exp( xactr )
188  real(rp), allocatable :: expxabnd( : ) !--- exp( xabnd )
189  real(rp), allocatable :: rexpxctr( : ) !--- 1/exp( xctr )
190  real(rp), allocatable :: rexpxbnd( : ) !--- 1/exp( xbnd )
191  real(rp), allocatable :: rexpxactr( : ) !--- 1/exp( xactr )
192  real(rp), allocatable :: rexpxabnd( : ) !--- 1/exp( xabnd1 )
193 
194  real(rp) :: dxaer !--- d( log(ma) ) of aerosol bin
195  real(rp) :: xasta !--- exponential of mass of aerosol for smallest aerosol bin
196  real(rp) :: xaend !--- exponential of mass of aerosol for largest aerosol bin
197 
198  real(rp), allocatable, save :: vterm(:) !--- terminal velocity
199 
200  !--- constant for bin
201  real(rp), parameter :: cldmin = 1.0e-10_rp !--- threshould for cloud is regarded existing
202  real(rp), parameter :: oneovthird = 1.0_rp / 3.0_rp
203  real(rp), parameter :: thirdovforth = 3.0_rp / 4.0_rp
204  real(rp), parameter :: twoovthird = 2.0_rp / 3.0_rp
205 
206  real(rp) :: rbnd = 40.e-06_rp ! boundary radius of cloud and rian
207  integer :: nbnd ! boundary bin number corresponding to rbnd
208 
209  !--- constant for aerosol
210  real(rp) :: rhoa = 2.25e+03_rp ! density of aerosol ( NaCl )
211  real(rp) :: emaer = 58.0_rp ! molecular weight of aerosol ( salt )
212  real(rp) :: emwtr = 18.0_rp ! molecular weight of water
213  real(rp) :: rasta = 1.e-08_rp ! minimum radius of aerosol (m)
214  real(rp) :: raend = 1.e-06_rp ! maximum radius of aerosol (m)
215  real(rp) :: r0a = 1.e-07_rp ! average radius of aerosol (m)
216 
217  logical :: flg_regeneration ! flag regeneration of aerosol
218  logical :: flg_nucl ! flag nucleated cloud move into smallest bin
219  logical :: flg_icenucl ! flag ice nucleation
220  logical :: flg_sf_aero ! flag surface flux of aerosol
221  logical :: flg_rndm ! flag for sthastic integration for coll.-coag.
222 
223  real(rp), allocatable :: marate( : ) ! mass rate of each aerosol bin to total aerosol mass
224  integer, allocatable, save :: ncld( : ) ! bin number of aerosol in bin of hydrometeor
225 ! integer, save :: K10_1, K10_2 ! scaling factor for 10m value (momentum)
226 ! real(RP) :: R10M1, R10M2 ! scaling factor for 10m value (momentum)
227 ! real(RP) :: R10H1, R10H2 ! scaling factor for 10m value (heat)
228 ! real(RP) :: R10E1, R10E2 ! scaling factor for 10m value (tracer)
229 
230  character(len=11), parameter :: fname_micpara="micpara.dat" !--- file name
231 
232  integer(4) :: fid_micpara
233 
234  !--- Use for stochastic method
235  integer, allocatable :: blrg( :,: )
236  integer, allocatable :: bsml( :,: )
237  real(rp) :: wgtbin
238  integer :: mspc, mbin
239  real(rp) :: rndm(1,1,1)
240 
241  !--- use for ice_nucleation
242  real(rp) :: n0_icenucl = 1.e+3_rp ! N0 of Meyer et al. (1992)
243 
244  !--- use for model without aerosol
245  real(rp) :: c_ccn = 100.e+6_rp ! N0 of Nc = N0*s^kappa
246  real(rp) :: kappa = 0.462_rp ! kappa of Nc = N0*s^kappa
247 
248  !--- use for aerosol coupled model
249  real(rp) :: sigma = 7.5e-02_rp ! water surface tension [ N/m2 ] (sigma in eq. (A.11) of Suzuki (2004) )
250  real(rp) :: vhfct = 2.0_rp ! van't hoff factor (i in eq.(A.11) of Suzuki (2004))
251 
252  real(rp), parameter :: tcrit = 271.15_rp
253  integer, allocatable :: kindx( :,: )
254 
255  !--- for creating micpara.dat (mkpara)
256  integer, parameter :: ndat = 33, icemax = 3
257  integer, parameter :: kdeg = 4, ldeg = 4, nspc_mk = 7
258 
259  real(dp) :: dxmic_mk
260 
261  real(dp), allocatable :: radc_mk( : ), xctr_mk( : ), xbnd_mk( : )
262  real(dp), allocatable :: cctr_mk( :,: ), cbnd_mk( :,: )
263  real(dp), allocatable :: ck_mk( :,:,:,: )
264  real(dp), allocatable :: vt_mk( :,: )
265  real(dp), allocatable :: br_mk( :,: )
266 
267  real(dp) :: xmss( nspc_mk,ndat ), zcap( nspc_mk,ndat ), vtrm( nspc_mk,ndat )
268  real(dp) :: blkr( nspc_mk,ndat ), blkd( nspc_mk,ndat ), ykrn( nspc_mk,nspc_mk,ndat,ndat )
269 
270  real(dp) :: ywll( ndat,ndat ), ywli( ndat,ndat,icemax ), ywls( ndat,ndat )
271  real(dp) :: ywlg( ndat,ndat ), ywlh( ndat,ndat )
272 
273  real(dp) :: ywil( ndat,ndat,icemax ), ywii( ndat,ndat,icemax,icemax )
274  real(dp) :: ywis( ndat,ndat,icemax ), ywig( ndat,ndat,icemax )
275  real(dp) :: ywih( ndat,ndat,icemax )
276 
277  real(dp) :: ywsl( ndat,ndat ), ywsi( ndat,ndat,icemax ), ywss( ndat,ndat )
278  real(dp) :: ywsg( ndat,ndat ), ywsh( ndat,ndat )
279 
280  real(dp) :: ywgl( ndat,ndat ), ywgi( ndat,ndat,icemax ), ywgs( ndat,ndat )
281  real(dp) :: ywgg( ndat,ndat ), ywgh( ndat,ndat )
282 
283  real(dp) :: ywhl( ndat,ndat ), ywhi( ndat,ndat,icemax ), ywhs( ndat,ndat )
284  real(dp) :: ywhg( ndat,ndat ), ywhh( ndat,ndat )
285 
286  ! for qhyd2qtrc
287  real(rp) :: sigma_sdf(5), r0_sdf(5), n0_sdf(5), rho_sdf(5)
288 
289  ! for lightning
290  real(rp), allocatable :: flg_noninduct(:,:)
291  real(rp), allocatable :: ecoll(:,:,:,:), rcoll(:,:,:,:)
292  real(rp), allocatable, save :: num_end(:,:,:,:)
293  real(rp), save :: ecoal_gsi = 0.0_rp
294  !----------------------------------------------------------------------------
295 contains
296  !-----------------------------------------------------------------------------
298  subroutine atmos_phy_mp_suzuki10_tracer_setup
299  use scale_prc, only: &
300  prc_abort
301  implicit none
302 
303  namelist / param_atmos_phy_mp_suzuki10_bin / &
304  nbin, &
305  nccn, &
306  iceflg, &
307  kphase
308 
309  integer :: m, n, ierr
310  !---------------------------------------------------------------------------
311 
312  log_newline
313  log_info("ATMOS_PHY_MP_suzuki10_tracer_setup",*) 'Setup'
314  log_info("ATMOS_PHY_MP_suzuki10_tracer_setup",*) 'Tracers setup for Suzuki (2010) Spectral BIN model'
315 
316  log_newline
317  log_info("ATMOS_PHY_MP_suzuki10_tracer_setup",*) 'READ BIN NUMBER'
318 
319  rewind(io_fid_conf)
320  read(io_fid_conf,nml=param_atmos_phy_mp_suzuki10_bin,iostat=ierr)
321 
322  if( ierr < 0 ) then !--- missing
323  log_info("ATMOS_PHY_MP_suzuki10_tracer_setup",*) 'Not found namelist. Default used.'
324  elseif( ierr > 0 ) then !--- fatal error
325  log_error("ATMOS_PHY_MP_suzuki10_tracer_setup",*) 'Not appropriate names in namelist PARAM_ATMOS_PHY_MP_SUZUKI10_bin, Check!'
326  call prc_abort
327  end if
328 
329  log_nml(param_atmos_phy_mp_suzuki10_bin)
330 
331  if( iceflg == 0 ) then
332  nspc = 1
333  elseif( iceflg == 1 ) then
334  nspc = 7
335  else
336  log_error("ATMOS_PHY_MP_suzuki10_tracer_setup",*) "ICEFLG should be 0 (warm rain) or 1 (mixed rain) check!!"
337  call prc_abort
338  endif
339 
340  atmos_phy_mp_suzuki10_ntracers = 1 + nbin*nspc + nccn ! number of total tracers
341  atmos_phy_mp_suzuki10_nwaters = nbin ! number of liquid water
342  atmos_phy_mp_suzuki10_nices = nbin * ( nspc - 1 ) ! number of ice water
343  atmos_phy_mp_suzuki10_nccn = nccn ! number of ccn
344 
345  num_hyd = nbin * nspc
346 
347  num_start_waters = i_qv + 1
348  num_end_waters = i_qv + atmos_phy_mp_suzuki10_nwaters
349  num_start_ices = num_end_waters + 1
350  num_end_ices = num_end_waters + atmos_phy_mp_suzuki10_nices
351 
352  qa = atmos_phy_mp_suzuki10_ntracers
353 
354  allocate( atmos_phy_mp_suzuki10_tracer_names(qa) )
355  allocate( atmos_phy_mp_suzuki10_tracer_descriptions(qa) )
356  allocate( atmos_phy_mp_suzuki10_tracer_units(qa) )
357 
358  !---------------------------------------------------------------------------
359  !
360  !++ calculate each category and aerosol
361  !
362  !---------------------------------------------------------------------------
363 
364  do n = 1, qa
365  write(atmos_phy_mp_suzuki10_tracer_units(n),'(a)') 'kg/kg'
366  enddo
367 
368  write(atmos_phy_mp_suzuki10_tracer_names(1),'(a)') 'QV'
369  write(atmos_phy_mp_suzuki10_tracer_descriptions(1),'(a)') 'Water Vapor mixing ratio'
370 
371  do m = 1, nspc
372  do n = 1, nbin
373  write(atmos_phy_mp_suzuki10_tracer_names(1+nbin*(m-1)+n),'(a,i0)') trim(namspc(m)), n
374  write(atmos_phy_mp_suzuki10_tracer_descriptions(1+nbin*(m-1)+n),'(a,i0)') trim(lnamspc(m)), n
375  enddo
376  enddo
377 
378  do n = 1, nccn
379  write(atmos_phy_mp_suzuki10_tracer_names(1+nbin*nspc+n),'(a,i0)') trim(namspc(8)), n
380  write(atmos_phy_mp_suzuki10_tracer_descriptions(1+nbin*nspc+n),'(a,i0)') trim(lnamspc(8)), n
381  enddo
382 
383  return
384  end subroutine atmos_phy_mp_suzuki10_tracer_setup
385 
386  !-----------------------------------------------------------------------------
388  subroutine atmos_phy_mp_suzuki10_setup( &
389  KA, IA, JA, &
390  flg_lt )
391  use scale_prc, only: &
392  prc_abort, &
393  prc_masterrank, &
394  prc_ismaster
395  use scale_const, only: &
396  pi => const_pi, &
397  dwatr => const_dwatr, &
398  dice => const_dice
399  use scale_comm_cartesc, only: &
400  comm_bcast
401  use scale_atmos_hydrometeor, only: &
402  i_hc, &
403  i_hr, &
404  i_hi, &
405  i_hs, &
406  i_hg, &
407  i_hh
408  implicit none
409 
410  integer, intent(in) :: ka
411  integer, intent(in) :: ia
412  integer, intent(in) :: ja
413  logical, intent(in), optional :: flg_lt
414 
415  real(rp) :: rho_aero !--- density of aerosol
416  real(rp) :: r0_aero !--- center radius of aerosol (um)
417  real(rp) :: r_min !--- minimum radius of aerosol (um)
418  real(rp) :: r_max !--- maximum radius of aerosol (um)
419  real(rp) :: s10_emaer !--- moleculer weight of aerosol
420 
421  logical :: s10_flag_regene = .false. !--- flag of regeneration
422  logical :: s10_flag_nucleat = .false. !--- flag of regeneration
423  logical :: s10_flag_icenucleat = .false. !--- flag of ice nucleation
424  logical :: s10_flag_sfaero = .false. !--- flag of surface flux of aeorol
425  logical :: s10_flag_rndm = .false. !--- flag for sthastic integration for coll.-coag.
426  integer :: s10_rndm_mspc
427  integer :: s10_rndm_mbin
428 
429  namelist / param_atmos_phy_mp_suzuki10 / &
430  mp_doautoconversion, &
431  mp_couple_aerosol, &
432  rho_aero, &
433  r_min, &
434  r_max, &
435  r0_aero, &
436  s10_emaer, &
437  s10_flag_regene, &
438  s10_flag_nucleat, &
439  s10_flag_icenucleat, &
440  s10_flag_sfaero, &
441  s10_flag_rndm, &
442  s10_rndm_mspc, &
443  s10_rndm_mbin, &
444  c_ccn, kappa, &
445  n0_icenucl, &
446  sigma, vhfct, &
447  ecoal_gsi
448 
449  real(rp), parameter :: max_term_vel = 10.0_rp !-- terminal velocity for calculate dt of sedimentation
450 
451  logical :: flg_lt_
452  integer :: nnspc, nnbin
453  integer :: nn, mm, mmyu, nnyu
454  integer :: myu, nyu, i, j, k, n, ierr
455  !---------------------------------------------------------------------------
456 
457  log_newline
458  log_info("ATMOS_PHY_MP_suzuki10_setup",*) 'Setup'
459  log_info("ATMOS_PHY_MP_suzuki10_setup",*) 'Suzuki (2010) Spectral BIN model'
460 
461  !--- allocation
462  allocate( xctr( nbin ) )
463  allocate( xbnd( nbin+1 ) )
464  allocate( radc( nbin ) )
465  allocate( cctr( nbin,nspc_mk ) )
466  allocate( cbnd( nbin+1,nspc_mk ) )
467  allocate( ck( nspc_mk,nspc_mk,nbin,nbin ) )
468  allocate( vt( nspc_mk,nbin ) )
469  allocate( br( nspc_mk,nbin ) )
470  allocate( ifrsl( 2,nspc_mk,nspc_mk ) )
471  allocate( expxctr( nbin ) )
472  allocate( expxbnd( nbin+1 ) )
473  allocate( rexpxctr( nbin ) )
474  allocate( rexpxbnd( nbin+1 ) )
475  if ( nccn /= 0 ) then
476  allocate( xactr( nccn ) )
477  allocate( xabnd( nccn+1 ) )
478  allocate( rada( nccn ) )
479  allocate( expxactr( nccn ) )
480  allocate( expxabnd( nccn+1 ) )
481  allocate( rexpxactr( nccn ) )
482  allocate( rexpxabnd( nccn+1 ) )
483  endif
484 
485  mbin = nbin/2
486  mspc = nspc_mk*nspc_mk
487 
488  rho_aero = rhoa
489  s10_emaer = emaer
490  r_min = rasta
491  r_max = raend
492  r0_aero = r0a
493  s10_rndm_mspc = mspc
494  s10_rndm_mbin = mbin
495 
496  rewind(io_fid_conf)
497  read(io_fid_conf,nml=param_atmos_phy_mp_suzuki10,iostat=ierr)
498 
499  if ( ierr < 0 ) then !--- missing
500  log_info("ATMOS_PHY_MP_suzuki10_setup",*) 'Not found namelist. Default used.'
501  elseif( ierr > 0 ) then !--- fatal error
502  log_error("ATMOS_PHY_MP_suzuki10_setup",*) 'Not appropriate names in namelist PARAM_ATMOS_PHY_MP_SUZUKI10, Check!'
503  call prc_abort
504  endif
505  log_nml(param_atmos_phy_mp_suzuki10)
506 
507  if ( nspc /= 1 .AND. nspc /= 7 ) then
508  log_error("ATMOS_PHY_MP_suzuki10_setup",*) 'nspc should be set as 1 (warm rain) or 7 (mixed phase) check!'
509  call prc_abort
510  endif
511 
512  rhoa = rho_aero
513  emaer = s10_emaer
514  rasta = r_min
515  raend = r_max
516  r0a = r0_aero
517  flg_regeneration = s10_flag_regene
518  flg_nucl = s10_flag_nucleat
519  flg_icenucl = s10_flag_icenucleat
520  flg_sf_aero = s10_flag_sfaero
521  flg_rndm = s10_flag_rndm
522  mspc = s10_rndm_mspc
523  mbin = s10_rndm_mbin
524 
525  !--- read micpara.dat (microphysical parameter) and broad cast
526  if ( prc_ismaster ) then
527 
528  fid_micpara = io_get_available_fid()
529  !--- open parameter of cloud microphysics
530  open ( fid_micpara, file = fname_micpara, form = 'formatted', status = 'old', iostat=ierr )
531 
532  !--- micpara.dat does not exist
533  if ( ierr == 0 ) then
534 
535  read( fid_micpara,* ) nnspc, nnbin
536 
537  if ( nnbin /= nbin ) then
538  log_error("ATMOS_PHY_MP_suzuki10_setup",*) 'nbin in namelist and nbin in micpara.dat is different check!'
539  call prc_abort
540  endif
541 
542  ! grid parameter
543  log_info("ATMOS_PHY_MP_suzuki10_setup",*) 'Radius of cloud *'
544  do n = 1, nbin
545  read( fid_micpara,* ) nn, xctr( n ), radc( n )
546  log_info("ATMOS_PHY_MP_suzuki10_setup",'(A,1x,I3,1x,A,1x,ES15.7,1x,A)') &
547  "Radius of ", n, "th cloud bin (bin center)= ", radc( n ) , "[m]"
548  enddo
549  do n = 1, nbin+1
550  read( fid_micpara,* ) nn, xbnd( n )
551  enddo
552  read( fid_micpara,* ) dxmic
553  log_info("ATMOS_PHY_MP_suzuki10_setup",*) 'Width of Cloud SDF= ', dxmic
554 
555  ! capacity
556  do myu = 1, nspc_mk
557  do n = 1, nbin
558 ! read( fid_micpara,* ) mmyu, nn, cctr( myu,n )
559  read( fid_micpara,* ) mmyu, nn, cctr( n,myu )
560  enddo
561  do n = 1, nbin+1
562 ! read( fid_micpara,* ) mmyu, nn, cbnd( myu,n )
563  read( fid_micpara,* ) mmyu, nn, cbnd( n,myu )
564  enddo
565  enddo
566 
567  ! collection kernel
568  do myu = 1, nspc_mk
569  do nyu = 1, nspc_mk
570  do i = 1, nbin
571  do j = 1, nbin
572  read( fid_micpara,* ) mmyu, nnyu, mm, nn, ck( myu,nyu,i,j )
573  enddo
574  enddo
575  enddo
576  enddo
577 
578  ! terminal velocity
579  do myu = 1, nspc_mk
580  do n = 1, nbin
581  read( fid_micpara,* ) mmyu, nn, vt( myu,n )
582  enddo
583  enddo
584 
585  ! bulk density
586  do myu = 1, nspc_mk
587  do n = 1, nbin
588  read( fid_micpara,* ) mmyu, nn, br( myu,n )
589  enddo
590  enddo
591 
592  close ( fid_micpara )
593 
594  !--- micpara.dat does not exist
595  else
596 
597  log_info("ATMOS_PHY_MP_suzuki10_setup",*) 'micpara.dat is created'
598  call mkpara
599 
600  fid_micpara = io_get_available_fid()
601  !--- open parameter of cloud microphysics
602  open ( fid_micpara, file = fname_micpara, form = 'formatted', status = 'old', iostat=ierr )
603 
604  read( fid_micpara,* ) nnspc, nnbin
605 
606  if ( nnbin /= nbin ) then
607  log_error("ATMOS_PHY_MP_suzuki10_setup",*) 'nbin in inc_tracer and nbin in micpara.dat is different check!'
608  call prc_abort
609  endif
610 
611  ! grid parameter
612  log_info("ATMOS_PHY_MP_suzuki10_setup",*) 'Radius of cloud *'
613  do n = 1, nbin
614  read( fid_micpara,* ) nn, xctr( n ), radc( n )
615  log_info("ATMOS_PHY_MP_suzuki10_setup",'(A,1x,I3,1x,A,1x,ES15.7,1x,A)') &
616  "Radius of ", n, "th cloud bin (bin center)= ", radc( n ) , "[m]"
617  enddo
618  do n = 1, nbin+1
619  read( fid_micpara,* ) nn, xbnd( n )
620  enddo
621  read( fid_micpara,* ) dxmic
622  log_info("ATMOS_PHY_MP_suzuki10_setup",*) 'Width of Cloud SDF= ', dxmic
623 
624  ! capacity
625  do myu = 1, nspc_mk
626  do n = 1, nbin
627 ! read( fid_micpara,* ) mmyu, nn, cctr( myu,n )
628  read( fid_micpara,* ) mmyu, nn, cctr( n,myu )
629  enddo
630  do n = 1, nbin+1
631 ! read( fid_micpara,* ) mmyu, nn, cbnd( myu,n )
632  read( fid_micpara,* ) mmyu, nn, cbnd( n,myu )
633  enddo
634  enddo
635 
636  ! collection kernel
637  do myu = 1, nspc_mk
638  do nyu = 1, nspc_mk
639  do i = 1, nbin
640  do j = 1, nbin
641  read( fid_micpara,* ) mmyu, nnyu, mm, nn, ck( myu,nyu,i,j )
642  enddo
643  enddo
644  enddo
645  enddo
646 
647  ! terminal velocity
648  do myu = 1, nspc_mk
649  do n = 1, nbin
650  read( fid_micpara,* ) mmyu, nn, vt( myu,n )
651  enddo
652  enddo
653 
654  ! bulk density
655  do myu = 1, nspc_mk
656  do n = 1, nbin
657  read( fid_micpara,* ) mmyu, nn, br( myu,n )
658  enddo
659  enddo
660 
661  close ( fid_micpara )
662 
663  endif
664 
665  endif
666 
667  call comm_bcast( radc(:), nbin )
668  call comm_bcast( xctr(:), nbin )
669  call comm_bcast( dxmic )
670  call comm_bcast( xbnd(:), nbin+1 )
671  call comm_bcast( cctr(:,:), nbin, nspc_mk )
672  call comm_bcast( cbnd(:,:), nbin+1, nspc_mk )
673  call comm_bcast( ck(:,:,:,:), nspc_mk, nspc_mk, nbin, nbin )
674  call comm_bcast( br(:,:), nspc_mk, nbin )
675  call comm_bcast( vt(:,:), nspc_mk, nbin )
676 
677  allocate( flg_noninduct( nspc,nspc ) )
678  allocate( ecoll( nspc,nspc,nbin,nbin ) )
679  allocate( rcoll( nspc,nspc,nbin,nbin ) )
680  flg_noninduct(:,:) = 0.0_rp
681  ecoll( :,:,:,: ) = 0.0_rp
682  rcoll( :,:,:,: ) = 0.0_rp
683 
684  if ( present(flg_lt) ) then
685  flg_lt_ = flg_lt
686  else
687  flg_lt_ = .false.
688  end if
689  if( flg_lt_ ) then
690 
691  do myu = 1, nspc
692  do nyu = 1, nspc
693  if( ( myu >= ic .and. myu <= iss ) .and. ( nyu == ig .or. nyu == ih ) ) then
694  flg_noninduct( myu,nyu ) = 1.0_rp
695  endif
696  enddo
697  enddo
698 
699  do myu = 1, nspc
700  do nyu = 1, nspc
701  do i = 1, nbin
702  do j = 1, nbin
703  if( vt( myu,i ) /= vt( nyu,j ) ) then
704  ecoll( myu,nyu,i,j ) = ck( myu,nyu,i,j ) &
705  / ( pi*( radc( i )+radc( j ) )**2 * abs( vt( myu,i )-vt( nyu,j ) ) )
706  ecoll( myu,nyu,i,j ) = max( min( 1.0_rp, ecoll( myu,nyu,i,j ) ),0.0_rp )
707  else
708  ecoll( myu,nyu,i,j ) = 0.0_rp
709  endif
710 
711  if( ecoal_gsi /= 0.0_rp ) then
712  ecoll( myu,nyu,i,j ) = ecoal_gsi
713  endif
714 
715  if( ecoll( myu,nyu,i,j ) /= 0.0_rp ) then
716  rcoll( myu,nyu,i,j ) = ( 1.0_rp-ecoll( myu,nyu,i,j ) ) / ecoll( myu,nyu,i,j )
717  elseif( ecoll( myu,nyu,i,j ) == 0.0_rp ) then
718  rcoll( myu,nyu,i,j ) = 1.0_rp
719  endif
720  enddo
721  enddo
722  enddo
723  enddo
724 
725  endif
726 
727  !--- aerosol ( CCN ) (not supported)
728  if ( nccn /= 0 ) then
729 
730  allocate ( ncld( 1:nccn ) )
731  xasta = log( rhoa*4.0_rp/3.0_rp*pi * ( rasta )**3 )
732  xaend = log( rhoa*4.0_rp/3.0_rp*pi * ( raend )**3 )
733 
734  dxaer = ( xaend-xasta )/nccn
735 
736  do n = 1, nccn+1
737  xabnd( n ) = xasta + dxaer*( n-1 )
738  enddo
739  do n = 1, nccn
740  xactr( n ) = ( xabnd( n )+xabnd( n+1 ) )*0.50_rp
741  rada( n ) = ( exp( xactr( n ) )*thirdovforth/pi/rhoa )**( oneovthird )
742  log_info("ATMOS_PHY_MP_suzuki10_setup",'(A,1x,I3,1x,A,1x,ES15.7,1x,A)') &
743  "Radius of ", n, "th aerosol bin (bin center)= ", rada( n ) , "[m]"
744  enddo
745 
746  if ( flg_sf_aero ) then
747  log_error("ATMOS_PHY_MP_suzuki10_setup",*) "flg_sf_aero=true is not supported stop!! "
748  call prc_abort
749 ! if ( CZ(KS) >= 10.0_RP ) then
750 ! R10M1 = 10.0_RP / CZ(KS) * 0.50_RP ! scale with height
751 ! R10M2 = 10.0_RP / CZ(KS) * 0.50_RP ! scale with height
752 ! R10H1 = 1.0_RP * 0.50_RP
753 ! R10H2 = 1.0_RP * 0.0_RP
754 ! R10E1 = 1.0_RP * 0.50_RP
755 ! R10E2 = 1.0_RP * 0.50_RP
756 ! K10_1 = KS
757 ! K10_2 = KS
758 ! else
759 ! k = 1
760 ! do while ( CZ(k) < 10.0_RP )
761 ! k = k + 1
762 ! K10_1 = k
763 ! K10_2 = k + 1
764 ! R10M1 = ( CZ(k+1) - 10.0_RP ) / CDZ(k)
765 ! R10M2 = ( 10.0_RP - CZ(k) ) / CDZ(k)
766 ! R10H1 = ( CZ(k+1) - 10.0_RP ) / CDZ(k)
767 ! R10H2 = ( 10.0_RP - CZ(k) ) / CDZ(k)
768 ! R10E1 = ( CZ(k+1) - 10.0_RP ) / CDZ(k)
769 ! R10E2 = ( 10.0_RP - CZ(k) ) / CDZ(k)
770 ! enddo
771 ! endif
772  endif
773 
774  endif
775 
776  !--- determine nbnd
777  do n = 1, nbin
778  if( radc( n ) > rbnd ) then
779  nbnd = n
780  exit
781  endif
782  enddo
783  log_info("ATMOS_PHY_MP_suzuki10_setup",'(A,ES15.7,A)') 'Radius between cloud and rain is ', radc(nbnd), '[m]'
784  atmos_phy_mp_suzuki10_nbnd = nbnd
785 
786  !--- random number setup for stochastic method
787  if ( flg_rndm ) then
788  call random_setup( ia*ja*ka )
789  endif
790 
791  if ( mp_couple_aerosol .AND. nccn /=0 ) then
792  log_error("ATMOS_PHY_MP_suzuki10_setup",*) 'nccn should be 0 when MP_couple_aerosol = .true. !! stop'
793  call prc_abort
794  endif
795 
796  if ( nccn /= 0 ) then
797  do n = 1, nccn
798  expxactr( n ) = exp( xactr( n ) )
799  rexpxactr( n ) = 1.0_rp / exp( xactr( n ) )
800  enddo
801  do n = 1, nccn+1
802  expxabnd( n ) = exp( xabnd( n ) )
803  rexpxabnd( n ) = 1.0_rp / exp( xabnd( n ) )
804  enddo
805  endif
806 
807  allocate( vterm(qa-1) )
808  vterm(:) = 0.0_rp
809  do myu = 1, nspc
810  do n = 1, nbin
811  vterm((myu-1)*nbin+n) = -vt( myu,n )
812  enddo
813  enddo
814  do n = 1, nbin
815  expxctr( n ) = exp( xctr( n ) )
816  rexpxctr( n ) = 1.0_rp / exp( xctr( n ) )
817  enddo
818  do n = 1, nbin+1
819  expxbnd( n ) = exp( xbnd( n ) )
820  rexpxbnd( n ) = 1.0_rp / exp( xbnd( n ) )
821  enddo
822 
823  allocate( kindx(nbin,nbin) )
824  call getrule( ifrsl,kindx )
825 
826  !--- determine the parameters for interpolating SDF from qxx, Nxx of parent domain
827  sigma_sdf(1) = 0.2_rp
828  sigma_sdf(2) = 0.35_rp
829  sigma_sdf(3) = 0.35_rp
830  sigma_sdf(4) = 0.35_rp
831  sigma_sdf(5) = 0.35_rp
832  r0_sdf(1) = 5.e-6_rp
833  r0_sdf(2) = 2.61e-6_rp
834  r0_sdf(3) = 5.e-6_rp
835  r0_sdf(4) = 2.61e-6_rp
836  r0_sdf(5) = 2.61e-6_rp ! to be corrected
837  n0_sdf(1) = 8.0e+6_rp
838  n0_sdf(2) = 0.0_rp
839  n0_sdf(3) = 3.0e+6_rp
840  n0_sdf(4) = 4.0e+6_rp
841  n0_sdf(5) = 4.0e+6_rp ! to be corrected
842  rho_sdf(1) = dwatr
843  rho_sdf(2) = dice
844  rho_sdf(3) = 100.0_rp
845  rho_sdf(4) = 400.0_rp
846  rho_sdf(5) = 400.0_rp ! to be corrected
847 
848  !--- determine the parameters for interpolating SDF from qxx, Nxx of parent domain
849  sigma_sdf(1) = 0.2_rp
850  sigma_sdf(2) = 0.35_rp
851  sigma_sdf(3) = 0.35_rp
852  sigma_sdf(4) = 0.35_rp
853  sigma_sdf(5) = 0.35_rp
854  r0_sdf(1) = 5.e-6_rp
855  r0_sdf(2) = 2.61e-6_rp
856  r0_sdf(3) = 5.e-6_rp
857  r0_sdf(4) = 2.61e-6_rp
858  r0_sdf(5) = 2.61e-6_rp ! to be corrected
859  n0_sdf(1) = 8.0e+6_rp
860  n0_sdf(2) = 0.0_rp
861  n0_sdf(3) = 3.0e+6_rp
862  n0_sdf(4) = 4.0e+6_rp
863  n0_sdf(5) = 4.0e+6_rp ! to be corrected
864  rho_sdf(1) = dwatr
865  rho_sdf(2) = dice
866  rho_sdf(3) = 100.0_rp
867  rho_sdf(4) = 400.0_rp
868  rho_sdf(5) = 400.0_rp ! to be corrected
869 
870  return
871  end subroutine atmos_phy_mp_suzuki10_setup
872 
873  !-----------------------------------------------------------------------------
875  subroutine atmos_phy_mp_suzuki10_tendency( &
876  KA, KS, KE, IA, IS, IE, JA, JS, JE, &
877  KIJMAX, &
878  dt, &
879  DENS, PRES, TEMP, &
880  QTRC, QDRY, &
881  CPtot, CVtot, &
882  CCN, &
883  RHOQ_t, RHOE_t, &
884  CPtot_t, CVtot_t, &
885  EVAPORATE, &
886  flg_lt, &
887  d0_crg, v0_crg, &
888  dqcrg, &
889  beta_crg, &
890  QTRC_crg, &
891  QSPLT_in, Sarea, &
892  RHOC_t_mp )
893  use scale_const, only: &
894  tem00 => const_tem00, &
895  pi => const_pi
896  use scale_atmos_saturation, only: &
897  atmos_saturation_pres2qsat_liq, &
898  atmos_saturation_pres2qsat_ice
899  implicit none
900 
901  integer, intent(in) :: ka, ks, ke
902  integer, intent(in) :: ia, is, ie
903  integer, intent(in) :: ja, js, je
904  integer, intent(in) :: kijmax
905 
906  real(dp), intent(in) :: dt
907  real(rp), intent(in) :: dens (ka,ia,ja)
908  real(rp), intent(in) :: pres (ka,ia,ja)
909  real(rp), intent(in) :: temp (ka,ia,ja)
910  real(rp), intent(in) :: qtrc (ka,ia,ja,qa)
911  real(rp), intent(in) :: qdry (ka,ia,ja)
912  real(rp), intent(in) :: cptot(ka,ia,ja)
913  real(rp), intent(in) :: cvtot(ka,ia,ja)
914  real(rp), intent(in) :: ccn (ka,ia,ja)
915 
916  real(rp), intent(out) :: rhoq_t (ka,ia,ja,qa)
917  real(rp), intent(out) :: rhoe_t (ka,ia,ja)
918  real(rp), intent(out) :: cptot_t(ka,ia,ja)
919  real(rp), intent(out) :: cvtot_t(ka,ia,ja)
920  real(rp), intent(out) :: evaporate(ka,ia,ja) !--- number of evaporated cloud [/m3]
921 
922  ! Optional for Lightning
923  logical, intent(in), optional :: flg_lt
924  real(rp), intent(in), optional :: d0_crg, v0_crg
925  real(rp), intent(in), optional :: dqcrg(ka,ia,ja)
926  real(rp), intent(in), optional :: beta_crg(ka,ia,ja)
927  real(rp), intent(in), optional :: qtrc_crg(ka,ia,ja,num_hyd)
928  real(rp), intent(out), optional :: qsplt_in(ka,ia,ja,3)
929  real(rp), intent(out), optional :: sarea(ka,ia,ja,num_hyd)
930  real(rp), intent(out), optional :: rhoc_t_mp(ka,ia,ja,num_hyd)
931 
932  real(rp) :: qsat_l(ka,ia,ja)
933  real(rp) :: qsat_i(ka,ia,ja)
934  real(rp) :: ssliq(ka,ia,ja)
935  real(rp) :: ssice(ka,ia,ja)
936 
937  integer :: ijk_index (kijmax,3)
938  integer :: index_cld (kijmax)
939  integer :: index_cold(kijmax)
940  integer :: index_warm(kijmax)
941  integer :: ijkcount, ijkcount_cold, ijkcount_warm
942  integer :: ijk, indirect
943 
944  real(rp) :: dens_ijk(kijmax)
945  real(rp) :: pres_ijk(kijmax)
946  real(rp) :: temp_ijk(kijmax)
947  real(rp) :: qdry_ijk(kijmax)
948  real(rp) :: qvap_ijk(kijmax)
949  real(rp) :: ccn_ijk(kijmax)
950  real(rp) :: cp_ijk(kijmax)
951  real(rp) :: cv_ijk(kijmax)
952  real(rp) :: evaporate_ijk(kijmax)
953  real(rp) :: ghyd_ijk(nbin,nspc,kijmax)
954  real(rp) :: gaer_ijk(max(nccn,1),kijmax)
955  real(rp) :: cldsum
956  integer :: countbin
957  real(rp) :: rhoq_new
958 
959  !--- for lithgning
960  logical :: flg_lt_l
961  real(rp) :: gcrg_ijk(nbin,nspc,kijmax)
962  real(rp) :: crg_sep_ijk(nspc,kijmax)
963  real(rp) :: dqcrg_ijk(kijmax)
964  real(rp) :: beta_crg_ijk(kijmax)
965 
966  integer :: step
967  integer :: k, i, j, m, n, iq
968  !---------------------------------------------------------------------------
969 
970  if ( nspc == 1 ) then
971  log_progress(*) 'atmosphere / physics / microphysics / SBM (Liquid water only)'
972  elseif( nspc > 1 ) then
973  log_progress(*) 'atmosphere / physics / microphysics / SBM (Mixed phase)'
974  endif
975 
976  if ( present(flg_lt) ) then
977  flg_lt_l = flg_lt
978  crg_sep_ijk(:,:) = 0.0_rp
979  qsplt_in(:,:,:,:) = 0.0_rp
980  else
981  flg_lt_l = .false.
982  end if
983 
984  call atmos_saturation_pres2qsat_liq( ka, ks, ke, & ! [IN]
985  ia, is, ie, & ! [IN]
986  ja, js, je, & ! [IN]
987  temp(:,:,:), pres(:,:,:), qdry(:,:,:), & ! [IN]
988  qsat_l(:,:,:) ) ! [OUT]
989 
990  call atmos_saturation_pres2qsat_ice( ka, ks, ke, & ! [IN]
991  ia, is, ie, & ! [IN]
992  ja, js, je, & ! [IN]
993  temp(:,:,:), pres(:,:,:), qdry(:,:,:), & ! [IN]
994  qsat_i(:,:,:) ) ! [OUT]
995 
996  do j = js, je
997  do i = is, ie
998  do k = ks, ke
999  ssliq(k,i,j) = qtrc(k,i,j,i_qv) / qsat_l(k,i,j) - 1.0_rp
1000  ssice(k,i,j) = qtrc(k,i,j,i_qv) / qsat_i(k,i,j) - 1.0_rp
1001  enddo
1002  enddo
1003  enddo
1004 
1005  if ( nspc == 1 ) then
1006  ssice(:,:,:) = 0.0_rp
1007  endif
1008 
1009 !--- store initial SDF of aerosol
1010 !--- this option is not supported
1011 ! if ( ofirst_sdfa ) then
1012 ! allocate( marate( nccn ) )
1013 ! do j = JS, JE
1014 ! do i = IS, IE
1015 ! do k = KS, KE
1016 ! sum2 = 0.0_RP
1017 ! do n = 1, nccn
1018 ! marate( n ) = gdga(k,i,j,n)*rexpxactr( n )
1019 ! sum2 = sum2 + gdga(k,i,j,n)*rexpxactr( n )
1020 ! enddo
1021 ! enddo
1022 ! enddo
1023 ! enddo
1024 ! if ( sum2 /= 0.0_RP ) then
1025 ! marate( 1:nccn ) = marate( 1:nccn )/sum2
1026 ! ofirst_sdfa = .false.
1027 ! endif
1028 ! endif
1029 
1030  !--- Arrange array for microphysics
1031 
1032  call prof_rapstart('MP_ijkconvert', 3)
1033 
1034  ijk = 0
1035  do j = js, je
1036  do i = is, ie
1037  do k = ks, ke
1038  ijk = ijk + 1
1039  ijk_index(ijk,1) = i
1040  ijk_index(ijk,2) = j
1041  ijk_index(ijk,3) = k
1042  enddo
1043  enddo
1044  enddo
1045  gcrg_ijk(:,:,:) = 0.0_rp
1046  ijkcount = 0
1047  ijkcount_cold = 0
1048  ijkcount_warm = 0
1049 
1050  ijk = 0
1051  do j = js, je
1052  do i = is, ie
1053  do k = ks, ke
1054  ijk = ijk + 1
1055 
1056  ! calc total hydrometeors
1057  cldsum = 0.0_rp
1058  countbin = i_qv + 1
1059  do m = 1, nspc
1060  do n = 1, nbin
1061  cldsum = cldsum + qtrc(k,i,j,countbin) * dens(k,i,j) / dxmic
1062  countbin = countbin + 1
1063  enddo
1064  enddo
1065 
1066  if ( cldsum > cldmin &
1067  .OR. ssliq(k,i,j) > 0.0_rp &
1068  .OR. ssice(k,i,j) > 0.0_rp ) then
1069 
1070  ijkcount = ijkcount + 1
1071 
1072  index_cld(ijkcount) = ijk
1073 
1074  dens_ijk(ijkcount) = dens(k,i,j)
1075  pres_ijk(ijkcount) = pres(k,i,j)
1076  temp_ijk(ijkcount) = temp(k,i,j)
1077  qdry_ijk(ijkcount) = qdry(k,i,j)
1078  cp_ijk(ijkcount) = cptot(k,i,j)
1079  cv_ijk(ijkcount) = cvtot(k,i,j)
1080  ccn_ijk(ijkcount) = ccn(k,i,j)
1081  qvap_ijk(ijkcount) = qtrc(k,i,j,i_qv)
1082 
1083  countbin = i_qv + 1
1084  do m = 1, nspc
1085  do n = 1, nbin
1086  ghyd_ijk(n,m,ijkcount) = qtrc(k,i,j,countbin) * dens(k,i,j) / dxmic
1087  countbin = countbin + 1
1088  enddo
1089  enddo
1090 
1091  do n = 1, nccn
1092  gaer_ijk(n,ijkcount) = qtrc(k,i,j,countbin) * dens(k,i,j) / dxaer
1093  countbin = countbin + 1
1094  enddo
1095 
1096  if ( temp(k,i,j) < tem00 .AND. nspc > 1 ) then ! cold
1097  ijkcount_cold = ijkcount_cold + 1
1098  index_cold(ijkcount_cold) = ijkcount
1099  else ! warm
1100  ijkcount_warm = ijkcount_warm + 1
1101  index_warm(ijkcount_warm) = ijkcount
1102  endif
1103 
1104  if ( flg_lt_l ) then
1105  countbin = 1
1106  do m = 1, nspc
1107  do n = 1, nbin
1108  gcrg_ijk(n,m,ijkcount) = qtrc_crg(k,i,j,countbin) * dens(k,i,j)
1109  countbin = countbin + 1
1110  enddo
1111  enddo
1112  beta_crg_ijk(ijkcount) = beta_crg(k,i,j)
1113  dqcrg_ijk(ijkcount) = dqcrg(k,i,j)
1114  endif
1115 
1116  else
1117 
1118  ! no hudrometeors and undersaturation (no microphysical process occcurs)
1119  do iq = 1, qa
1120  rhoq_t(k,i,j,iq) = 0.0_rp
1121  end do
1122  rhoe_t(k,i,j) = 0.0_rp
1123  cptot_t(k,i,j) = 0.0_rp
1124  cvtot_t(k,i,j) = 0.0_rp
1125  evaporate(k,i,j) = 0.0_rp
1126 
1127  endif
1128 
1129  enddo
1130  enddo
1131  enddo
1132 
1133  call prof_rapend ('MP_ijkconvert', 3)
1134 
1135  ! tentative timername registration
1136  call prof_rapstart('MP_suzuki10', 3)
1137  call prof_rapend ('MP_suzuki10', 3)
1138  call prof_rapstart('_SBM_Nucleat', 3)
1139  call prof_rapend ('_SBM_Nucleat', 3)
1140 ! call PROF_rapstart('_SBM_NucleatA', 3)
1141 ! call PROF_rapend ('_SBM_NucleatA', 3)
1142  call prof_rapstart('_SBM_Liqphase', 3)
1143  call prof_rapend ('_SBM_Liqphase', 3)
1144  call prof_rapstart('_SBM_Icephase', 3)
1145  call prof_rapend ('_SBM_Icephase', 3)
1146  call prof_rapstart('_SBM_Mixphase', 3)
1147  call prof_rapend ('_SBM_Mixphase', 3)
1148  call prof_rapstart('_SBM_AdvLiq', 3)
1149  call prof_rapend ('_SBM_AdvLiq', 3)
1150  call prof_rapstart('_SBM_AdvIce', 3)
1151  call prof_rapend ('_SBM_AdvIce', 3)
1152  call prof_rapstart('_SBM_AdvMix', 3)
1153  call prof_rapend ('_SBM_AdvMix', 3)
1154 ! call PROF_rapstart('_SBM_FAero', 3)
1155 ! call PROF_rapend ('_SBM_FAero', 3)
1156  call prof_rapstart('_SBM_Freezing', 3)
1157  call prof_rapend ('_SBM_Freezing', 3)
1158  call prof_rapstart('_SBM_IceNucleat', 3)
1159  call prof_rapend ('_SBM_IceNucleat', 3)
1160  call prof_rapstart('_SBM_Melting', 3)
1161  call prof_rapend ('_SBM_Melting', 3)
1162  call prof_rapstart('_SBM_CollCoag', 3)
1163  call prof_rapend ('_SBM_CollCoag', 3)
1164 ! call PROF_rapstart('_SBM_CollCoagR', 3)
1165 ! call PROF_rapend ('_SBM_CollCoagR', 3)
1166 
1167  if ( ijkcount > 0 ) then
1168 
1169  call prof_rapstart('MP_suzuki10', 3)
1170 
1171  if ( flg_lt_l ) then
1172  ! --- with lightning
1173  call mp_suzuki10( ka, ia, ja, & ! [IN]
1174  ijkcount, & ! [IN]
1175  ijkcount_cold, & ! [IN]
1176  ijkcount_warm, & ! [IN]
1177  index_cold( 1:ijkcount), & ! [IN]
1178  index_warm( 1:ijkcount), & ! [IN]
1179  dens_ijk( 1:ijkcount), & ! [IN]
1180  pres_ijk( 1:ijkcount), & ! [IN]
1181  qdry_ijk( 1:ijkcount), & ! [IN]
1182  ccn_ijk( 1:ijkcount), & ! [IN]
1183  temp_ijk( 1:ijkcount), & ! [INOUT]
1184  qvap_ijk( 1:ijkcount), & ! [INOUT]
1185  ghyd_ijk(:,:,1:ijkcount), & ! [INOUT]
1186  gaer_ijk(:, 1:ijkcount), & ! [INOUT]
1187  cp_ijk( 1:ijkcount), & ! [INOUT]
1188  cv_ijk( 1:ijkcount), & ! [INOUT]
1189  evaporate_ijk(1:ijkcount), & ! [OUT]
1190  dt, & ! [IN]
1191  flg_lt_l, d0_crg, v0_crg, & ! [IN:Optional]
1192  dqcrg_ijk( 1:ijkcount), & ! [IN:Optional]
1193  beta_crg_ijk( 1:ijkcount), & ! [IN:Optional]
1194  gcrg_ijk(:,:,1:ijkcount), & ! [INOUT:Optional]
1195  crg_sep_ijk(:,1:ijkcount) ) ! [OUT:Optional]
1196  else
1197  call mp_suzuki10( ka, ia, ja, & ! [IN]
1198  ijkcount, & ! [IN]
1199  ijkcount_cold, & ! [IN]
1200  ijkcount_warm, & ! [IN]
1201  index_cold( 1:ijkcount), & ! [IN]
1202  index_warm( 1:ijkcount), & ! [IN]
1203  dens_ijk( 1:ijkcount), & ! [IN]
1204  pres_ijk( 1:ijkcount), & ! [IN]
1205  qdry_ijk( 1:ijkcount), & ! [IN]
1206  ccn_ijk( 1:ijkcount), & ! [IN]
1207  temp_ijk( 1:ijkcount), & ! [INOUT]
1208  qvap_ijk( 1:ijkcount), & ! [INOUT]
1209  ghyd_ijk(:,:,1:ijkcount), & ! [INOUT]
1210  gaer_ijk(:, 1:ijkcount), & ! [INOUT]
1211  cp_ijk( 1:ijkcount), & ! [INOUT]
1212  cv_ijk( 1:ijkcount), & ! [INOUT]
1213  evaporate_ijk(1:ijkcount), & ! [OUT]
1214  dt ) ! [IN]
1215  endif
1216 
1217  call prof_rapend ('MP_suzuki10', 3)
1218 
1219 ! if ( flg_sf_aero ) then
1220 ! do j = JS-2, JE+2
1221 ! do i = IS-2, IE+1
1222 ! VELX(i,j) = MOMX(K10_1,i,j) / ( DENS(K10_1,i+1,j)+DENS(K10_1,i,j) ) * R10M1 &
1223 ! + MOMX(K10_2,i,j) / ( DENS(K10_2,i+1,j)+DENS(K10_2,i,j) ) * R10M2
1224 ! enddo
1225 ! enddo
1226 !
1227 ! do j = JS-2, JE+1
1228 ! do i = IS-2, IE+2
1229 ! VELY(i,j) = MOMY(K10_1,i,j) / ( DENS(K10_1,i,j+1)+DENS(K10_1,i,j) ) * R10M1 &
1230 ! + MOMY(K10_2,i,j) / ( DENS(K10_2,i,j+1)+DENS(K10_2,i,j) ) * R10M2
1231 ! enddo
1232 ! enddo
1233 ! endif
1234 !
1235 ! !--- SURFACE FLUX by Monahan et al. (1986)
1236 ! if ( flg_sf_aero .AND. nccn /= 0 ) then
1237 ! do j = JS, JE
1238 ! do i = IS, IE
1239 ! ijk = ( j - JS ) * KMAX * IMAX &
1240 ! + ( i - IS ) * KMAX &
1241 ! + ( KS - KS ) &
1242 ! + 1
1243 ! Uabs = sqrt( ( ( VELX(i,j) + VELX(i-1,j ) ) * 0.50_RP )**2 &
1244 ! + ( ( VELY(i,j) + VELY(i ,j-1) ) * 0.50_RP )**2 )
1245 ! do n = 1, nccn
1246 ! if ( rada( n ) <= 2.0E-5_RP .AND. rada( n ) >= 3.0E-7_RP ) then
1247 ! bparam = ( 0.38_RP - log( rada( n ) ) )/0.65_RP
1248 ! SFLX_AERO(i,j,n) = 1.373_RP * Uabs**( 3.41_RP ) * rada( n )**( -3.0_RP ) &
1249 ! * ( 1.0_RP + 0.057_RP * rada( n )**( 1.05_RP ) ) &
1250 ! * 10.0_RP**( 1.19_RP * exp( -bparam*bparam ) )
1251 ! ! convert from [#/m^2/um/s] -> [kg/m^3/unit log (m)]
1252 ! SFLX_AERO(i,j,n) = SFLX_AERO(i,j,n) / DENS(KS,i,j) &
1253 ! / CDZ(KS) * rada( n ) / 3.0_RP * dt * expxactr( n )
1254 ! Gaer_ijk(n,ijk) = Gaer_ijk(n,ijk) + SFLX_AERO(i,j,n)/dxaer
1255 ! endif
1256 ! enddo
1257 ! enddo
1258 ! enddo
1259 ! endif
1260 
1261  call prof_rapstart('MP_ijkconvert', 3)
1262 
1263  !---- return original array
1264  do ijk = 1, ijkcount
1265  indirect = index_cld(ijk)
1266  i = ijk_index(indirect,1)
1267  j = ijk_index(indirect,2)
1268  k = ijk_index(indirect,3)
1269 
1270  rhoe_t(k,i,j) = ( temp_ijk(ijk) * cv_ijk(ijk) - temp(k,i,j) * cvtot(k,i,j) ) * dens(k,i,j) / dt
1271  cptot_t(k,i,j) = ( cp_ijk(ijk) - cptot(k,i,j) ) / dt
1272  cvtot_t(k,i,j) = ( cv_ijk(ijk) - cvtot(k,i,j) ) / dt
1273  evaporate(k,i,j) = evaporate_ijk(ijk) / dt ! [#/m3/s]
1274 
1275  rhoq_t(k,i,j,i_qv) = ( qvap_ijk(ijk) - qtrc(k,i,j,i_qv) ) * dens(k,i,j) / dt
1276 
1277  countbin = i_qv + 1
1278  do m = 1, nspc
1279  do n = 1, nbin
1280  rhoq_new = ghyd_ijk(n,m,ijk) * dxmic
1281  rhoq_t(k,i,j,countbin) = ( rhoq_new - qtrc(k,i,j,countbin)*dens(k,i,j) ) / dt
1282  countbin = countbin + 1
1283  enddo
1284  enddo
1285 
1286  do n = 1, nccn
1287  rhoq_new = gaer_ijk(n,ijk) * dxaer
1288  rhoq_t(k,i,j,countbin) = ( rhoq_new - qtrc(k,i,j,countbin)*dens(k,i,j) ) / dt
1289  countbin = countbin + 1
1290  enddo
1291 
1292  if( flg_lt_l ) then
1293  countbin = 1
1294  do m = 1, nspc
1295  do n = 1, nbin
1296  rhoq_new = gcrg_ijk(n,m,ijk)
1297  rhoc_t_mp(k,i,j,countbin) = ( rhoq_new - qtrc_crg(k,i,j,countbin)*dens(k,i,j) ) / dt
1298  countbin = countbin + 1
1299  enddo
1300  enddo
1301 
1302  sarea(k,i,j,:) = 0.0_rp
1303  countbin = 1
1304  do m = 1, nspc
1305  do n = 1, nbin
1306  rhoq_new = ghyd_ijk(n,m,ijk) * dxmic
1307  sarea(k,i,j,countbin) = 4.0_rp*pi*radc(n)**2*rhoq_new*rexpxctr( n )
1308  countbin = countbin + 1
1309  enddo
1310  enddo
1311 
1312  qsplt_in(k,i,j,1) = crg_sep_ijk(ig,ijk) * dens(k,i,j) / dt
1313  qsplt_in(k,i,j,2) = ( crg_sep_ijk(ic,ijk) &
1314  + crg_sep_ijk(ip,ijk) &
1315  + crg_sep_ijk(id,ijk) ) * dens(k,i,j) / dt
1316  qsplt_in(k,i,j,3) = crg_sep_ijk(iss,ijk) * dens(k,i,j) / dt
1317 
1318  endif
1319 
1320  enddo
1321 
1322 
1323 ! if ( nccn /= 0 ) then
1324 ! AMR(:,:,:) = 0.0_RP
1325 ! do j = JS, JE
1326 ! do i = IS, IE
1327 ! do k = KS, KE
1328 ! do n = 1, nccn
1329 ! AMR(k,i,j) = AMR(k,i,j) + QTRC(k,i,j,QQE-1+n)
1330 ! enddo
1331 ! enddo
1332 ! enddo
1333 ! enddo
1334 ! endif
1335 
1336  call prof_rapend ('MP_ijkconvert', 3)
1337 
1338  endif
1339 
1340  return
1341  end subroutine atmos_phy_mp_suzuki10_tendency
1342 
1343  !-----------------------------------------------------------------------------
1345 !OCL SERIAL
1346  subroutine atmos_phy_mp_suzuki10_terminal_velocity( &
1347  KA, &
1348  vterm_o )
1349  implicit none
1350 
1351  integer, intent(in) :: ka
1352 
1353  real(rp), intent(out) :: vterm_o(ka,qa-1)
1354 
1355  integer :: iq
1356  !---------------------------------------------------------------------------
1357 
1358  do iq = 1, qa-1
1359  vterm_o(:,iq) = vterm(iq)
1360  end do
1361 
1362  return
1363  end subroutine atmos_phy_mp_suzuki10_terminal_velocity
1364 
1365  !-----------------------------------------------------------------------------
1367  subroutine atmos_phy_mp_suzuki10_cloud_fraction( &
1368  KA, KS, KE, &
1369  IA, IS, IE, &
1370  JA, JS, JE, &
1371  QTRC0, &
1372  mask_criterion, &
1373  cldfrac )
1374  implicit none
1375 
1376  integer, intent(in) :: ka, ks, ke
1377  integer, intent(in) :: ia, is, ie
1378  integer, intent(in) :: ja, js, je
1379 
1380  real(rp), intent(in) :: qtrc0 (ka,ia,ja,num_hyd)
1381  real(rp), intent(in) :: mask_criterion
1382  real(rp), intent(out) :: cldfrac(ka,ia,ja)
1383 
1384  real(rp) :: qhydro
1385  integer :: k, i, j, iq, ihydro
1386  !---------------------------------------------------------------------------
1387 
1388  if( nspc > 1 ) then
1389  do j = js, je
1390  do i = is, ie
1391  do k = ks, ke
1392  qhydro = 0.0_rp
1393  do ihydro = 1, nspc
1394  do iq = nbin*(ihydro-1)+1, nbin*ihydro
1395  qhydro = qhydro + qtrc0(k,i,j,iq)
1396  enddo
1397  enddo
1398  cldfrac(k,i,j) = 0.5_rp + sign(0.5_rp,qhydro-mask_criterion)
1399  enddo
1400  enddo
1401  enddo
1402  elseif( nspc == 1 ) then
1403  do j = js, je
1404  do i = is, ie
1405  do k = ks, ke
1406  qhydro = 0.0_rp
1407  do ihydro = 1, i_mp_qc
1408  do iq = nbin*(ihydro-1)+1, nbin*ihydro
1409  qhydro = qhydro + qtrc0(k,i,j,iq)
1410  enddo
1411  enddo
1412  cldfrac(k,i,j) = 0.5_rp + sign(0.5_rp,qhydro-mask_criterion)
1413  enddo
1414  enddo
1415  enddo
1416  endif
1417 
1418  return
1419  end subroutine atmos_phy_mp_suzuki10_cloud_fraction
1420 
1421  !-----------------------------------------------------------------------------
1423  subroutine atmos_phy_mp_suzuki10_effective_radius( &
1424  KA, KS, KE, &
1425  IA, IS, IE, &
1426  JA, JS, JE, &
1427  DENS0, &
1428  TEMP0, &
1429  QTRC0, &
1430  Re )
1431  use scale_const, only: &
1432  eps => const_eps
1433  use scale_atmos_hydrometeor, only: &
1434  n_hyd, &
1435  i_qv, &
1436  i_hc, &
1437  i_hr, &
1438  i_hi, &
1439  i_hs, &
1440  i_hg, &
1441  i_hh
1442  implicit none
1443 
1444  integer, intent(in) :: ka, ks, ke
1445  integer, intent(in) :: ia, is, ie
1446  integer, intent(in) :: ja, js, je
1447 
1448  real(rp), intent(in) :: dens0(ka,ia,ja) ! density [kg/m3]
1449  real(rp), intent(in) :: temp0(ka,ia,ja) ! temperature [K]
1450  real(rp), intent(in) :: qtrc0(ka,ia,ja,num_hyd) ! tracer mass concentration [kg/kg]
1451  real(rp), intent(out) :: re (ka,ia,ja,n_hyd) ! effective radius [cm]
1452 
1453  real(rp), parameter :: um2cm = 100.0_rp
1454 
1455  real(rp) :: sum0(nspc), sum2, sum3, re_tmp(nspc)
1456  integer :: i, j, k, iq, ihydro
1457  !---------------------------------------------------------------------------
1458 
1459  do k = ks, ke
1460  do j = js, je
1461  do i = is, ie
1462  re(k,i,j,:) = 0.0_rp
1463 
1464  ! HC
1465  sum3 = 0.0_rp
1466  sum2 = 0.0_rp
1467  ihydro = i_mp_qc
1468  do iq = 1, nbnd
1469  sum3 = sum3 &
1470  + ( ( qtrc0(k,i,j,iq) * dens0(k,i,j) ) & !--- [kg/kg] -> [kg/m3]
1471  * rexpxctr( iq-nbin*(ihydro-1) ) & !--- mass -> number
1472  * radc( iq-nbin*(ihydro-1) )**3.0_rp )
1473  sum2 = sum2 &
1474  + ( ( qtrc0(k,i,j,iq) * dens0(k,i,j) ) & !--- [kg/kg] -> [kg/m3]
1475  * rexpxctr( iq-nbin*(ihydro-1) ) & !--- mass -> number
1476  * radc( iq-nbin*(ihydro-1) )**2.0_rp )
1477  enddo
1478  sum3 = max( sum3, 0.0_rp )
1479  sum2 = max( sum2, 0.0_rp )
1480  if ( sum2 /= 0.0_rp ) then
1481  re(k,i,j,i_hc) = sum3 / sum2 * um2cm
1482  else
1483  re(k,i,j,i_hc) = 0.0_rp
1484  endif
1485 
1486  ! HR
1487  sum3 = 0.0_rp
1488  sum2 = 0.0_rp
1489  ihydro = i_mp_qc
1490  do iq = nbnd+1, nbin
1491  sum3 = sum3 &
1492  + ( ( qtrc0(k,i,j,iq) * dens0(k,i,j) ) & !--- [kg/kg] -> [kg/m3]
1493  * rexpxctr( iq-nbin*(ihydro-1) ) & !--- mass -> number
1494  * radc( iq-nbin*(ihydro-1) )**3.0_rp )
1495  sum2 = sum2 &
1496  + ( ( qtrc0(k,i,j,iq) * dens0(k,i,j) ) & !--- [kg/kg] -> [kg/m3]
1497  * rexpxctr( iq-nbin*(ihydro-1) ) & !--- mass -> number
1498  * radc( iq-nbin*(ihydro-1) )**2.0_rp )
1499  enddo
1500  sum3 = max( sum3, 0.0_rp )
1501  sum2 = max( sum2, 0.0_rp )
1502  if ( sum2 /= 0.0_rp ) then
1503  re(k,i,j,i_hr) = sum3 / sum2 * um2cm
1504  else
1505  re(k,i,j,i_hr) = 0.0_rp
1506  endif
1507 
1508  enddo
1509  enddo
1510  enddo
1511 
1512  ! other hydrometeors
1513  if ( nspc > 1 ) then
1514  do k = ks, ke
1515  do j = js, je
1516  do i = is, ie
1517  do ihydro = 2, nspc
1518  sum0(ihydro) = 0.0_rp
1519  sum2 = 0.0_rp
1520  sum3 = 0.0_rp
1521  do iq = nbin*(ihydro-1)+1, nbin*ihydro
1522  sum0(ihydro) = sum0(ihydro) &
1523  + ( qtrc0(k,i,j,iq) * dens0(k,i,j) ) !--- [kg/kg] -> [kg/m3]
1524  sum3 = sum3 &
1525  + ( ( qtrc0(k,i,j,iq) * dens0(k,i,j) ) & !--- [kg/kg] -> [kg/m3]
1526  * rexpxctr( iq-nbin*(ihydro-1) ) & !--- mass -> number
1527  * radc( iq-nbin*(ihydro-1) )**3.0_rp )
1528  sum2 = sum2 &
1529  + ( ( qtrc0(k,i,j,iq) * dens0(k,i,j) ) & !--- [kg/kg] -> [kg/m3]
1530  * rexpxctr( iq-nbin*(ihydro-1) ) & !--- mass -> number
1531  * radc( iq-nbin*(ihydro-1) )**2.0_rp )
1532  enddo
1533  sum3 = max( sum3, 0.0_rp )
1534  sum2 = max( sum2, 0.0_rp )
1535  if ( sum2 == 0.0_rp ) then
1536  re_tmp(ihydro) = 0.0_rp
1537  else
1538  re_tmp(ihydro) = sum3 / sum2 * um2cm
1539  end if
1540  end do
1541 
1542  re(k,i,j,i_hi) = ( re_tmp(i_mp_qcl) * sum0(i_mp_qcl) &
1543  + re_tmp(i_mp_qp ) * sum0(i_mp_qp ) &
1544  + re_tmp(i_mp_qd ) * sum0(i_mp_qd ) ) &
1545  / ( sum0(i_mp_qcl) + sum0(i_mp_qp) + sum0(i_mp_qd) + eps )
1546  re(k,i,j,i_hs) = re_tmp(i_mp_qs)
1547  re(k,i,j,i_hg) = re_tmp(i_mp_qg)
1548  re(k,i,j,i_hh) = re_tmp(i_mp_qh)
1549 
1550  enddo
1551  enddo
1552  enddo
1553 
1554  end if
1555 
1556  return
1557  end subroutine atmos_phy_mp_suzuki10_effective_radius
1558 
1559  !-----------------------------------------------------------------------------
1561  subroutine atmos_phy_mp_suzuki10_qtrc2qhyd( &
1562  KA, KS, KE, &
1563  IA, IS, IE, &
1564  JA, JS, JE, &
1565  QTRC0, &
1566  Qe )
1567  use scale_atmos_hydrometeor, only: &
1568  n_hyd, &
1569  i_hc, &
1570  i_hr, &
1571  i_hi, &
1572  i_hs, &
1573  i_hg, &
1574  i_hh
1575  implicit none
1576 
1577  integer, intent(in) :: ka, ks, ke
1578  integer, intent(in) :: ia, is, ie
1579  integer, intent(in) :: ja, js, je
1580  real(rp), intent(in) :: qtrc0(ka,ia,ja,num_hyd) ! tracer mass concentration [kg/kg]
1581  real(rp), intent(out) :: qe (ka,ia,ja,n_hyd) ! mixing ratio of each cateory [kg/kg]
1582 
1583  integer :: ihydro, ibin, iq, icateg
1584  integer :: k, i, j
1585  !---------------------------------------------------------------------------
1586 
1587 !OCL XFILL
1588  qe(:,:,:,:) = 0.0_rp
1589 
1590  do ihydro = 1, nspc
1591  do ibin = 1, nbin
1592  iq = nbin*(ihydro-1) + ibin
1593 
1594  if ( iq > 0 .AND. iq <= nbin*(i_mp_qc ) ) then ! liquid
1595  if ( iq > 0 .AND. iq <= nbnd ) then ! cloud
1596  icateg = i_hc
1597  elseif( iq > nbnd .AND. iq <= nbin ) then ! rain
1598  icateg = i_hr
1599  endif
1600  elseif( iq > nbin*(i_mp_qcl-1) .AND. iq <= nbin*(i_mp_qcl) ) then ! ice (column)
1601  icateg = i_hi
1602  elseif( iq > nbin*(i_mp_qp -1) .AND. iq <= nbin*(i_mp_qp ) ) then ! ice (plate)
1603  icateg = i_hi
1604  elseif( iq > nbin*(i_mp_qd -1) .AND. iq <= nbin*(i_mp_qd ) ) then ! ice (dendrite)
1605  icateg = i_hi
1606  elseif( iq > nbin*(i_mp_qs -1) .AND. iq <= nbin*(i_mp_qs ) ) then ! snow
1607  icateg = i_hs
1608  elseif( iq > nbin*(i_mp_qg -1) .AND. iq <= nbin*(i_mp_qg ) ) then ! graupel
1609  icateg = i_hg
1610  elseif( iq > nbin*(i_mp_qh -1) .AND. iq <= num_hyd ) then ! hail
1611  icateg = i_hh
1612  endif
1613 
1614  do j = js, je
1615  do i = is, ie
1616  do k = ks, ke
1617  qe(k,i,j,icateg) = qe(k,i,j,icateg) + qtrc0(k,i,j,iq)
1618  enddo
1619  enddo
1620  enddo
1621  enddo
1622  enddo
1623 
1624  return
1625  end subroutine atmos_phy_mp_suzuki10_qtrc2qhyd
1626 
1628  subroutine atmos_phy_mp_suzuki10_qtrc2nhyd( &
1629  KA, KS, KE, &
1630  IA, IS, IE, &
1631  JA, JS, JE, &
1632  DENS, &
1633  QTRC0, &
1634  Ne )
1635  use scale_atmos_hydrometeor, only: &
1636  n_hyd, &
1637  i_hc, &
1638  i_hr, &
1639  i_hi, &
1640  i_hs, &
1641  i_hg, &
1642  i_hh
1643  implicit none
1644 
1645  integer, intent(in) :: ka, ks, ke
1646  integer, intent(in) :: ia, is, ie
1647  integer, intent(in) :: ja, js, je
1648  real(rp), intent(in) :: dens (ka,ia,ja) ! density [kg/m3]
1649  real(rp), intent(in) :: qtrc0(ka,ia,ja,num_hyd) ! tracer mass concentration [kg/kg]
1650  real(rp), intent(out) :: ne (ka,ia,ja,n_hyd) ! number concentration of each cateory [1/m3]
1651 
1652  integer :: ihydro, ibin, iq, icateg
1653  integer :: k, i, j
1654  !---------------------------------------------------------------------------
1655 
1656 !OCL XFILL
1657  ne(:,:,:,:) = 0.0_rp
1658 
1659  do ihydro = 1, nspc
1660  do ibin = 1, nbin
1661  iq = nbin*(ihydro-1) + ibin
1662 
1663  if ( iq > 0 .AND. iq <= nbin*(i_mp_qc ) ) then ! liquid
1664  if ( iq > 0 .AND. iq <= nbnd ) then ! cloud
1665  icateg = i_hc
1666  elseif( iq > nbnd .AND. iq <= nbin ) then ! rain
1667  icateg = i_hr
1668  endif
1669  elseif( iq > nbin*(i_mp_qcl-1) .AND. iq <= nbin*(i_mp_qcl) ) then ! ice (column)
1670  icateg = i_hi
1671  elseif( iq > nbin*(i_mp_qp -1) .AND. iq <= nbin*(i_mp_qp ) ) then ! ice (plate)
1672  icateg = i_hi
1673  elseif( iq > nbin*(i_mp_qd -1) .AND. iq <= nbin*(i_mp_qd ) ) then ! ice (dendrite)
1674  icateg = i_hi
1675  elseif( iq > nbin*(i_mp_qs -1) .AND. iq <= nbin*(i_mp_qs ) ) then ! snow
1676  icateg = i_hs
1677  elseif( iq > nbin*(i_mp_qg -1) .AND. iq <= nbin*(i_mp_qg ) ) then ! graupel
1678  icateg = i_hg
1679  elseif( iq > nbin*(i_mp_qh -1) .AND. iq <= num_hyd ) then ! hail
1680  icateg = i_hh
1681  endif
1682 
1683  do j = js, je
1684  do i = is, ie
1685  do k = ks, ke
1686  ne(k,i,j,icateg) = ne(k,i,j,icateg) + dens(k,i,j) * qtrc0(k,i,j,iq) * rexpxctr(ibin)
1687  enddo
1688  enddo
1689  enddo
1690  enddo
1691  enddo
1692 
1693  return
1694  end subroutine atmos_phy_mp_suzuki10_qtrc2nhyd
1695 
1696  !-----------------------------------------------------------------------------
1698  subroutine atmos_phy_mp_suzuki10_qhyd2qtrc( &
1699  KA, KS, KE, IA, IS, IE, JA, JS, JE, &
1700  Qe, &
1701  QTRC, &
1702  QNUM )
1703  use scale_const, only: &
1704  pi => const_pi, &
1705  eps => const_eps
1706  use scale_atmos_hydrometeor, only: &
1707  n_hyd, &
1708  i_hc, &
1709  i_hr, &
1710  i_hi, &
1711  i_hs, &
1712  i_hg, &
1713  i_hh
1714  use scale_specfunc, only: &
1715  sf_gamma
1716  implicit none
1717  integer, intent(in) :: ka, ks, ke
1718  integer, intent(in) :: ia, is, ie
1719  integer, intent(in) :: ja, js, je
1720 
1721  real(rp), intent(in) :: qe(ka,ia,ja,n_hyd) ! mass ratio of each cateory [kg/kg]
1722 
1723  real(rp), intent(out) :: qtrc(ka,ia,ja,qa-1)
1724 
1725  real(rp), intent(in), optional :: qnum(ka,ia,ja,n_hyd) ! number concentratio
1726 
1727  real(rp) :: coef0, coef1, coef2
1728  real(rp) :: dummy(nbin)
1729  real(rp) :: tmp_hyd, num_hyd_l, lambda_hyd
1730 
1731  integer :: k, i, j, iq
1732 
1733  if ( present(qnum) ) then
1734  log_warn("ATMOS_PHY_MP_suzuki10_qhyd2qtrc",*) 'At this moment, number concentratio is ignored'
1735  end if
1736 
1737  !--- define coefficients
1738  coef0 = 4.0_rp/3.0_rp*pi
1739  coef1 = 4.0_rp/3.0_rp*sqrt(pi/2.0_rp)
1740 
1741  if( nspc == 1 ) then !--- put all hydrometeors to liquid (warm bin)
1742 
1743  do j = js, je
1744  do i = is, ie
1745  do k = ks, ke
1746 
1747  tmp_hyd = 0.0_rp
1748  do iq = 1, nbin
1749  dummy(iq) = coef1 / sigma_sdf(1) * rho_sdf(1) * radc( iq )**3 &
1750  * exp( &
1751  - ( log( radc(iq) )-log( r0_sdf(1) ) )**2*0.5_rp &
1752  / sigma_sdf(1) / sigma_sdf(1) &
1753  )
1754  tmp_hyd = tmp_hyd + dummy(iq)
1755  enddo
1756 
1757  coef2 = ( qe(k,i,j,i_hc) + qe(k,i,j,i_hr) &
1758  + qe(k,i,j,i_hi) + qe(k,i,j,i_hs) + qe(k,i,j,i_hg) ) &
1759  / ( tmp_hyd + ( 0.50_rp - sign(0.50_rp,tmp_hyd-eps) ) )
1760 
1761  do iq = 1, nbin
1762  qtrc(k+2,i,j,(il-1)*nbin+iq) = coef2 * dummy(iq)
1763  enddo
1764 
1765  enddo
1766  enddo
1767  enddo
1768 
1769  elseif( nspc > 1 ) then !--- put each hydrometeor to each category (ice bin)
1770 
1771  do j = js, je
1772  do i = is, ie
1773  do k = ks, ke
1774 
1775  !--- Rain and Cloud put into liquid bin (log-normal)
1776  tmp_hyd = 0.0_rp
1777  do iq = 1, nbin
1778  dummy(iq) = coef1 / sigma_sdf(1) * rho_sdf(1) * radc( iq )**3 &
1779  * exp( &
1780  - ( log( radc(iq) )-log( r0_sdf(1) ) )**2*0.5_rp &
1781  / sigma_sdf(1) / sigma_sdf(1) &
1782  )
1783  tmp_hyd = tmp_hyd + dummy(iq)
1784  enddo
1785 
1786  coef2 = ( qe(k,i,j,i_hc) + qe(k,i,j,i_hr) ) &
1787  / ( tmp_hyd + ( 0.50_rp - sign(0.50_rp,tmp_hyd-eps) ) )
1788 
1789  do iq = 1, nbin
1790  qtrc(k,i,j,(il-1)*nbin+iq) = coef2 * dummy(iq)
1791  enddo
1792 
1793  !--- Ice put into plate bin (log-normal)
1794  tmp_hyd = 0.0_rp
1795  do iq = 1, nbin
1796  dummy(iq) = coef1 / sigma_sdf(2) * rho_sdf(2) * radc( iq )**3 &
1797  * exp( &
1798  - ( log( radc(iq) )-log( r0_sdf(2) ) )**2*0.5_rp &
1799  / sigma_sdf(2) / sigma_sdf(2) &
1800  )
1801  tmp_hyd = tmp_hyd + dummy(iq)
1802  enddo
1803 
1804  coef2 = ( qe(k,i,j,i_hi) ) &
1805  / ( tmp_hyd + ( 0.50_rp - sign(0.50_rp,tmp_hyd-eps) ) )
1806 
1807  do iq = 1, nbin
1808  qtrc(k,i,j,(ip-1)*nbin+iq) = coef2 * dummy(iq)
1809  enddo
1810 
1811  !--- Snow put into snow bin (gamma)
1812  num_hyd_l = coef0 * n0_sdf(3) * rho_sdf(3)
1813  lambda_hyd = ( pi * rho_sdf(3) / 6.0_rp *n0_sdf(3) * sf_gamma(4.0_rp) &
1814  / ( qe(k,i,j,i_hs) &
1815  + (0.50_rp-sign(0.50_rp,qe(k,i,j,i_hs)-eps)) &
1816  ) )**(0.25_rp)
1817 
1818  tmp_hyd = 0.0_rp
1819  do iq = 1, nbin
1820  dummy(iq) = num_hyd_l * radc( iq )**3 &
1821  * exp( -lambda_hyd * 0.5_rp * radc( iq ) )
1822  tmp_hyd = tmp_hyd + dummy(iq)
1823  enddo
1824 
1825  coef2 = ( qe(k,i,j,i_hs) ) &
1826  / ( tmp_hyd + ( 0.50_rp - sign(0.50_rp,tmp_hyd-eps) ) )
1827 
1828  do iq = 1, nbin
1829  qtrc(k,i,j,(iss-1)*nbin+iq) = coef2 * dummy(iq)
1830  enddo
1831 
1832  !--- Graupel put into Graupel bin (gamma)
1833  num_hyd_l = coef0 * n0_sdf(4) * rho_sdf(4)
1834  lambda_hyd = ( pi * rho_sdf(4) / 6.0_rp *n0_sdf(4) * sf_gamma(4.0_rp) &
1835  / ( qe(k,i,j,i_hg) &
1836  + (0.50_rp-sign(0.50_rp,qe(k,i,j,i_hg)-eps)) &
1837  ) )**(0.25_rp)
1838 
1839  tmp_hyd = 0.0_rp
1840  do iq = 1, nbin
1841  dummy(iq) = num_hyd_l * radc( iq )**3 &
1842  * exp( -lambda_hyd * 0.5_rp * radc( iq ) )
1843  tmp_hyd = tmp_hyd + dummy(iq)
1844  enddo
1845 
1846  coef2 = ( qe(k,i,j,i_hg) ) &
1847  / ( tmp_hyd + ( 0.50_rp - sign(0.50_rp,tmp_hyd-eps) ) )
1848 
1849  do iq = 1, nbin
1850  qtrc(k,i,j,(ig-1)*nbin+iq) = coef2 * dummy(iq)
1851  enddo
1852 
1853  !--- Hail put into Hail bin (gamma)
1854  num_hyd_l = coef0 * n0_sdf(5) * rho_sdf(5)
1855  lambda_hyd = ( pi * rho_sdf(5) / 6.0_rp *n0_sdf(5) * sf_gamma(4.0_rp) &
1856  / ( qe(k,i,j,i_hh) &
1857  + (0.50_rp-sign(0.50_rp,qe(k,i,j,i_hh)-eps)) &
1858  ) )**(0.25_rp)
1859 
1860  tmp_hyd = 0.0_rp
1861  do iq = 1, nbin
1862  dummy(iq) = num_hyd_l * radc( iq )**3 &
1863  * exp( -lambda_hyd * 0.5_rp * radc( iq ) )
1864  tmp_hyd = tmp_hyd + dummy(iq)
1865  enddo
1866 
1867  coef2 = ( qe(k,i,j,i_hh) ) &
1868  / ( tmp_hyd + ( 0.50_rp - sign(0.50_rp,tmp_hyd-eps) ) )
1869 
1870  do iq = 1, nbin
1871  qtrc(k,i,j,(ih-1)*nbin+iq) = coef2 * dummy(iq)
1872  enddo
1873 
1874  enddo
1875  enddo
1876  enddo
1877 
1878  endif
1879 
1880  do iq = num_hyd+1, qa-1
1881  do j = js, je
1882  do i = is, ie
1883  do k = ks, ke
1884  qtrc(k,i,j,iq) = 0.0_rp
1885  end do
1886  end do
1887  end do
1888  end do
1889 
1890  return
1891  end subroutine atmos_phy_mp_suzuki10_qhyd2qtrc
1892 
1893  !-----------------------------------------------------------------------------
1895  subroutine atmos_phy_mp_suzuki10_crg_qtrc2qhyd( &
1896  KA, KS, KE, &
1897  IA, IS, IE, &
1898  JA, JS, JE, &
1899  QTRC0, &
1900  Qecrg )
1901  use scale_atmos_hydrometeor, only: &
1902  n_hyd, &
1903  i_hc, &
1904  i_hr, &
1905  i_hi, &
1906  i_hs, &
1907  i_hg, &
1908  i_hh
1909  implicit none
1910 
1911  integer, intent(in) :: ka, ks, ke
1912  integer, intent(in) :: ia, is, ie
1913  integer, intent(in) :: ja, js, je
1914  real(rp), intent(in) :: qtrc0(ka,ia,ja,num_hyd) ! tracer charge density [fC/kg]
1915  real(rp), intent(out) :: qecrg(ka,ia,ja,n_hyd) ! charge density ratio of each cateory [fC/kg]
1916 
1917  integer :: ihydro, ibin, iq, icateg
1918  integer :: k, i, j
1919  !---------------------------------------------------------------------------
1920 
1921 !OCL XFILL
1922  qecrg(:,:,:,:) = 0.0_rp
1923 
1924  do ihydro = 1, nspc
1925  do ibin = 1, nbin
1926  iq = nbin*(ihydro-1) + ibin
1927 
1928  if ( iq > 0 .AND. iq <= nbin*(i_mp_qc ) ) then ! liquid
1929  if ( iq > 0 .AND. iq <= nbnd ) then ! cloud
1930  icateg = i_hc
1931  elseif( iq > nbnd .AND. iq <= nbin ) then ! rain
1932  icateg = i_hr
1933  endif
1934  elseif( iq > nbin*(i_mp_qcl-1) .AND. iq <= nbin*(i_mp_qcl) ) then ! ice (column)
1935  icateg = i_hi
1936  elseif( iq > nbin*(i_mp_qp -1) .AND. iq <= nbin*(i_mp_qp ) ) then ! ice (plate)
1937  icateg = i_hi
1938  elseif( iq > nbin*(i_mp_qd -1) .AND. iq <= nbin*(i_mp_qd ) ) then ! ice (dendrite)
1939  icateg = i_hi
1940  elseif( iq > nbin*(i_mp_qs -1) .AND. iq <= nbin*(i_mp_qs ) ) then ! snow
1941  icateg = i_hs
1942  elseif( iq > nbin*(i_mp_qg -1) .AND. iq <= nbin*(i_mp_qg ) ) then ! graupel
1943  icateg = i_hg
1944  elseif( iq > nbin*(i_mp_qh -1) .AND. iq <= num_hyd ) then ! hail
1945  icateg = i_hh
1946  endif
1947 
1948  do j = js, je
1949  do i = is, ie
1950  do k = ks, ke
1951  qecrg(k,i,j,icateg) = qecrg(k,i,j,icateg) + qtrc0(k,i,j,iq)
1952  enddo
1953  enddo
1954  enddo
1955  enddo
1956  enddo
1957 
1958  return
1959  end subroutine atmos_phy_mp_suzuki10_crg_qtrc2qhyd
1960 
1961  !-----------------------------------------------------------------------------
1962  subroutine mp_suzuki10( &
1963  KA, IA, JA, &
1964  ijkmax, &
1965  ijkmax_cold, &
1966  ijkmax_warm, &
1967  index_cold, &
1968  index_warm, &
1969  dens, &
1970  pres, &
1971  qdry, &
1972  ccn, &
1973  temp, &
1974  qvap, &
1975  ghyd, &
1976  gaer, &
1977  cp, &
1978  cv, &
1979  evaporate, &
1980  dt, &
1981  flg_lt, &
1982  d0_crg, &
1983  v0_crg, &
1984  dqcrg, &
1985  beta_crg, &
1986  gcrg, &
1987  crg_sep )
1988  use scale_const, only: &
1989  temp00 => const_tem00
1990  implicit none
1991 
1992  integer, intent(in) :: ka
1993  integer, intent(in) :: ia
1994  integer, intent(in) :: ja
1995 
1996  integer, intent(in) :: ijkmax
1997  integer, intent(in) :: ijkmax_cold
1998  integer, intent(in) :: ijkmax_warm
1999  integer , intent(in) :: index_cold(ijkmax)
2000  integer , intent(in) :: index_warm(ijkmax)
2001  real(rp), intent(in) :: dens (ijkmax) ! Density [kg/m3]
2002  real(rp), intent(in) :: pres (ijkmax) ! Pressure [Pa]
2003  real(rp), intent(in) :: qdry (ijkmax) ! dry air mass ratio [kg/kg]
2004  real(rp), intent(in) :: ccn (ijkmax) ! Number concentration of CCN [#/m3]
2005  real(rp), intent(inout) :: temp (ijkmax) ! Temperature [K]
2006  real(rp), intent(inout) :: qvap (ijkmax) ! Specific humidity [kg/kg]
2007  real(rp), intent(inout) :: ghyd (nbin,nspc,ijkmax) ! Mass size distribution function of hydrometeor
2008  real(rp), intent(inout) :: gaer (max(nccn,1),ijkmax) ! Mass size distribution function of aerosol
2009  real(rp), intent(inout) :: cp (ijkmax) ! specific heat
2010  real(rp), intent(inout) :: cv (ijkmax) ! specific heat
2011  real(rp), intent(out) :: evaporate (ijkmax) ! Number concentration of evaporated cloud [/m3/s]
2012  real(dp), intent(in) :: dt ! Time step interval
2013 
2014  ! Optional for Lightning
2015  logical, intent(in), optional :: flg_lt
2016  real(rp), intent(in), optional :: d0_crg, v0_crg
2017  real(rp), intent(in), optional :: dqcrg(ijkmax), beta_crg(ijkmax)
2018  real(rp), intent(inout), optional :: gcrg(nbin,nspc,ijkmax)
2019  real(rp), intent(out), optional :: crg_sep(nspc,ijkmax)
2020  !--- local
2021  integer :: m, n
2022  real(rp) :: gcrg_l(nbin,nspc,ijkmax), crg_sep_l(nspc,ijkmax)
2023  real(rp) :: csum(il,ijkmax)
2024  logical :: flg_lt_l
2025  real(rp) :: v0_crg_l, d0_crg_l, tcrglimit_l
2026  !---------------------------------------------------------------------------
2027 
2028  if ( present(flg_lt) ) then
2029  flg_lt_l = flg_lt
2030  else
2031  flg_lt_l = .false.
2032  end if
2033 
2034  if( flg_lt_l ) then
2035  gcrg_l(:,:,:) = gcrg(:,:,:)
2036  d0_crg_l = d0_crg
2037  v0_crg_l = v0_crg
2038  crg_sep_l(:,:) = 0.0_rp
2039  else
2040  gcrg_l(:,:,:) = 0.0_rp
2041  d0_crg_l = 100.e-6_rp
2042  v0_crg_l = 8.0_rp
2043  crg_sep_l(:,:) = 0.0_rp
2044  endif
2045 
2046  if ( nccn /= 0 ) then
2047  if ( nspc == 1 ) then
2048  !---< warm rain only with aerosol tracer >---
2049 
2050  ! nucleation from aerosol
2051  call nucleata( ijkmax, & ! [IN]
2052  dens(:), & ! [IN]
2053  pres(:), & ! [IN]
2054  qdry(:), & ! [IN]
2055  temp(:), & ! [INOUT]
2056  qvap(:), & ! [INOUT]
2057  ghyd(:,:,:), & ! [INOUT]
2058  gaer(:,:), & ! [INOUT]
2059  cp(:), & ! [INOUT]
2060  cv(:), & ! [INOUT]
2061  dt ) ! [IN]
2062 
2063  ! condensation / evaporation
2064  call cndevpsbla( ijkmax, & ! [IN]
2065  dens(:), & ! [IN]
2066  pres(:), & ! [IN]
2067  qdry(:), & ! [IN]
2068  temp(:), & ! [INOUT]
2069  qvap(:), & ! [INOUT]
2070  ghyd(:,:,:), & ! [INOUT]
2071  gaer(:,:), & ! [INOUT]
2072  cp(:), & ! [INOUT]
2073  cv(:), & ! [INOUT]
2074  evaporate(:),& ! [OUT]
2075  dt, & ! [IN]
2076  gcrg_l(:,:,:)) ! [INOUT]
2077 
2078  if ( mp_doautoconversion ) then
2079  ! collision-coagulation
2080 
2081  call collmain( ka, ia, ja, & ! [IN]
2082  ijkmax, & ! [IN]
2083  flg_lt_l, & ! [IN]
2084  d0_crg_l, & ! [IN]
2085  v0_crg_l, & ! [IN]
2086  dqcrg(:), & ! [IN]
2087  beta_crg(:), & ! [IN]
2088  temp(:), & ! [IN]
2089  ghyd(:,:,:), & ! [INOUT]
2090  gcrg_l(:,:,:), & ! [INOUT]
2091  crg_sep_l(:,:),& ! [OUT]
2092  dt ) ! [IN]
2093 
2094  if( flg_lt_l ) then
2095  crg_sep(:,:) = crg_sep_l(:,:)
2096  endif
2097 
2098  endif
2099 
2100  elseif( nspc > 1 ) then
2101  !---< mixed phase with aerosol tracer >---
2102 
2103  ! nucleation from aerosol
2104  call nucleata( ijkmax, & ! [IN]
2105  dens(:), & ! [IN]
2106  pres(:), & ! [IN]
2107  qdry(:), & ! [IN]
2108  temp(:), & ! [INOUT]
2109  qvap(:), & ! [INOUT]
2110  ghyd(:,:,:), & ! [INOUT]
2111  gaer(:,:), & ! [INOUT]
2112  cp(:), & ! [INOUT]
2113  cv(:), & ! [INOUT]
2114  dt ) ! [IN]
2115 
2116  ! freezing / melting
2117  call freezing( ijkmax, & ! [IN]
2118  ijkmax_cold, & ! [IN]
2119  index_cold(:), & ! [IN]
2120  flg_lt_l, & ! [IN]
2121  dens(:), & ! [IN]
2122  temp(:), & ! [INOUT]
2123  ghyd(:,:,:), & ! [INOUT]
2124  gcrg_l(:,:,:), & ! [INOUT]
2125  cp(:), & ! [INOUT]
2126  cv(:), & ! [INOUT]
2127  dt ) ! [IN]
2128 
2129  if( flg_icenucl ) then
2130  call ice_nucleat( ijkmax, & ! [IN]
2131  ijkmax_cold, & ! [IN]
2132  index_cold(:), & ! [IN]
2133  dens(:), & ! [IN]
2134  pres(:), & ! [IN]
2135  qdry(:), & ! [IN]
2136  temp(:), & ! [INOUT]
2137  qvap(:), & ! [INOUT]
2138  ghyd(:,:,:), & ! [INOUT]
2139  cp(:), & ! [INOUT]
2140  cv(:), & ! [INOUT]
2141  dt ) ! [IN]
2142  endif
2143 
2144  call melting( ijkmax, & ! [IN]
2145  ijkmax_warm, & ! [IN]
2146  index_warm(:), & ! [IN]
2147  flg_lt_l, & ! [IN]
2148  dens(:), & ! [IN]
2149  temp(:), & ! [INOUT]
2150  ghyd(:,:,:), & ! [INOUT]
2151  gcrg_l(:,:,:), & ! [INOUT]
2152  cp(:), & ! [INOUT]
2153  cv(:), & ! [INOUT]
2154  dt ) ! [IN]
2155 
2156  ! condensation / evaporation
2157  call cndevpsbla( ijkmax, & ! [IN]
2158  dens(:), & ! [IN]
2159  pres(:), & ! [IN]
2160  qdry(:), & ! [IN]
2161  temp(:), & ! [INOUT]
2162  qvap(:), & ! [INOUT]
2163  ghyd(:,:,:), & ! [INOUT]
2164  gaer(:,:), & ! [INOUT]
2165  cp(:), & ! [INOUT]
2166  cv(:), & ! [INOUT]
2167  evaporate(:), & ! [OUT]
2168  dt, & ! [IN]
2169  gcrg_l(:,:,:) ) ! [INOUT]
2170 
2171  if ( mp_doautoconversion ) then
2172  ! collision-coagulation
2173  call collmainf( ka, ia, ja, & ! [IN]
2174  ijkmax, & ! [IN]
2175  flg_lt_l, & ! [IN]
2176  d0_crg_l, & ! [IN]
2177  v0_crg_l, & ! [IN]
2178  dqcrg(:), & ! [IN]
2179  beta_crg(:), & ! [IN]
2180  temp(:), & ! [IN]
2181  ghyd(:,:,:), & ! [INOUT]
2182  gcrg_l(:,:,:), & ! [INOUT]
2183  crg_sep_l(:,:),& ! [OUT]
2184  dt ) ! [IN]
2185 
2186  if( flg_lt_l ) then
2187  crg_sep(:,:) = crg_sep_l(:,:)
2188  endif
2189 
2190  endif
2191 
2192  endif
2193 
2194  elseif( nccn == 0 ) then
2195 
2196  if ( nspc == 1 ) then
2197  !---< warm rain only without aerosol tracer >---
2198 
2199  ! nucleation
2200  call nucleat( ijkmax, & ! [IN]
2201  dens(:), & ! [IN]
2202  pres(:), & ! [IN]
2203  qdry(:), & ! [IN]
2204  ccn(:), & ! [IN]
2205  temp(:), & ! [INOUT]
2206  qvap(:), & ! [INOUT]
2207  ghyd(:,:,:), & ! [INOUT]
2208  cp(:), & ! [INOUT]
2209  cv(:), & ! [INOUT]
2210  dt ) ! [IN]
2211 
2212  ! condensation / evaporation
2213  call cndevpsbl( ijkmax, & ! [IN]
2214  dens(:), & ! [IN]
2215  pres(:), & ! [IN]
2216  qdry(:), & ! [IN]
2217  temp(:), & ! [INOUT]
2218  qvap(:), & ! [INOUT]
2219  ghyd(:,:,:), & ! [INOUT]
2220  cp(:), & ! [INOUT]
2221  cv(:), & ! [INOUT]
2222  evaporate(:), & ! [OUT]
2223  dt, & ! [IN]
2224  gcrg_l(:,:,:) ) ! [INOUT]
2225 
2226  if ( mp_doautoconversion ) then
2227  ! collision-coagulation
2228  call collmain( ka, ia, ja, & ! [IN]
2229  ijkmax, & ! [IN]
2230  flg_lt_l, & ! [IN]
2231  d0_crg_l, & ! [IN]
2232  v0_crg_l, & ! [IN]
2233  dqcrg(:), & ! [IN]
2234  beta_crg(:), & ! [IN]
2235  temp(:), & ! [IN]
2236  ghyd(:,:,:), & ! [INOUT]
2237  gcrg_l(:,:,:), & ! [INOUT]
2238  crg_sep_l(:,:),& ! [OUT]
2239  dt ) ! [IN]
2240 
2241  if( flg_lt_l ) then
2242  crg_sep(:,:) = crg_sep_l(:,:)
2243  endif
2244 
2245  endif
2246 
2247  elseif( nspc > 1 ) then
2248  !---< mixed phase without aerosol tracer >---
2249 
2250  ! nucleation
2251  call nucleat( ijkmax, & ! [IN]
2252  dens(:), & ! [IN]
2253  pres(:), & ! [IN]
2254  qdry(:), & ! [IN]
2255  ccn(:), & ! [IN]
2256  temp(:), & ! [INOUT]
2257  qvap(:), & ! [INOUT]
2258  ghyd(:,:,:), & ! [INOUT]
2259  cp(:), & ! [INOUT]
2260  cv(:), & ! [INOUT]
2261  dt ) ! [IN]
2262 
2263  ! freezing / melting
2264  call freezing( ijkmax, & ! [IN]
2265  ijkmax_cold, & ! [IN]
2266  index_cold(:), & ! [IN]
2267  flg_lt_l, & ! [IN]
2268  dens(:), & ! [IN]
2269  temp(:), & ! [INOUT]
2270  ghyd(:,:,:), & ! [INOUT]
2271  gcrg_l(:,:,:), & ! [INOUT]
2272  cp(:), & ! [INOUT]
2273  cv(:), & ! [INOUT]
2274  dt ) ! [IN]
2275 
2276  if( flg_icenucl ) then
2277  call ice_nucleat( ijkmax, & ! [IN]
2278  ijkmax_cold, & ! [IN]
2279  index_cold(:), & ! [IN]
2280  dens(:), & ! [IN]
2281  pres(:), & ! [IN]
2282  qdry(:), & ! [IN]
2283  temp(:), & ! [INOUT]
2284  qvap(:), & ! [INOUT]
2285  ghyd(:,:,:), & ! [INOUT]
2286  cp(:), & ! [INOUT]
2287  cv(:), & ! [INOUT]
2288  dt ) ! [IN]
2289  endif
2290 
2291  call melting( ijkmax, & ! [IN]
2292  ijkmax_warm, & ! [IN]
2293  index_warm(:), & ! [IN]
2294  flg_lt_l, & ! [IN]
2295  dens(:), & ! [IN]
2296  temp(:), & ! [INOUT]
2297  ghyd(:,:,:), & ! [INOUT]
2298  gcrg_l(:,:,:), & ! [INOUT]
2299  cp(:), & ! [INOUT]
2300  cv(:), & ! [INOUT]
2301  dt ) ! [IN]
2302 
2303  ! condensation / evaporation
2304  call cndevpsbl( ijkmax, & ! [IN]
2305  dens(:), & ! [IN]
2306  pres(:), & ! [IN]
2307  qdry(:), & ! [IN]
2308  temp(:), & ! [INOUT]
2309  qvap(:), & ! [INOUT]
2310  ghyd(:,:,:), & ! [INOUT]
2311  cp(:), & ! [INOUT]
2312  cv(:), & ! [INOUT]
2313  evaporate(:), & ! [OUT]
2314  dt, & ! [IN]
2315  gcrg_l(:,:,:) ) ! [INOUT]
2316 
2317  if ( mp_doautoconversion ) then
2318  ! collision-coagulation
2319  call collmainf( ka, ia, ja, & ! [IN]
2320  ijkmax, & ! [IN]
2321  flg_lt_l, & ! [IN]
2322  d0_crg_l, & ! [IN]
2323  v0_crg_l, & ! [IN]
2324  dqcrg(:), & ! [IN]
2325  beta_crg(:), & ! [IN]
2326  temp(:), & ! [IN]
2327  ghyd(:,:,:), & ! [INOUT]
2328  gcrg_l(:,:,:), & ! [INOUT]
2329  crg_sep_l(:,:),& ! [OUT]
2330  dt ) ! [IN]
2331 
2332  if( flg_lt_l ) then
2333  crg_sep(:,:) = crg_sep_l(:,:)
2334  endif
2335 
2336  endif
2337 
2338  endif
2339 
2340  endif
2341 
2342  if( flg_lt_l ) then
2343  gcrg(:,:,:) = gcrg_l(:,:,:)
2344  endif
2345 
2346  return
2347  end subroutine mp_suzuki10
2348 
2349  !-----------------------------------------------------------------------------
2350  subroutine nucleat( &
2351  ijkmax, &
2352  dens, &
2353  pres, &
2354  qdry, &
2355  ccn, &
2356  temp, &
2357  qvap, &
2358  gc, &
2359  cp, &
2360  cv, &
2361  dtime )
2362  use scale_atmos_hydrometeor, only: &
2363  atmos_hydrometeor_lhv, &
2364  cp_vapor, &
2365  cp_water, &
2366  cv_vapor, &
2367  cv_water
2368  use scale_atmos_saturation, only: &
2369  atmos_saturation_pres2qsat_liq
2370  implicit none
2371 
2372  integer, intent(in) :: ijkmax
2373  real(rp), intent(in) :: dens(ijkmax) ! Density [kg/m3]
2374  real(rp), intent(in) :: pres(ijkmax) ! Pressure [Pa]
2375  real(rp), intent(in) :: qdry(ijkmax) ! dry air mass ratio [kg/kg]
2376  real(rp), intent(in) :: ccn(ijkmax) ! CCN number concentration [#/m3]
2377  real(rp), intent(inout) :: temp(ijkmax) ! Temperature [K]
2378  real(rp), intent(inout) :: qvap(ijkmax) ! Specific humidity [kg/kg]
2379  real(rp), intent(inout) :: gc (nbin,nspc,ijkmax) ! Mass size distribution function of hydrometeor
2380  real(rp), intent(inout) :: cp(ijkmax) ! specific heat
2381  real(rp), intent(inout) :: cv(ijkmax) ! specific heat
2382  real(dp), intent(in) :: dtime ! Time step interval
2383 
2384  real(rp) :: ssliq(ijkmax)
2385  real(rp) :: qlevp(ijkmax) ! LH
2386  real(rp) :: dmp
2387  real(rp) :: dqv
2388  integer :: n
2389  !
2390  real(rp) :: n_c
2391  real(rp) :: sumnum(ijkmax)
2392  real(rp) :: gcn( nbin,ijkmax ) ! number of cloud particles in each bin (=gc/exp(xctr))
2393  real(rp) :: qsat(ijkmax)
2394  integer :: ijk
2395 
2396  call prof_rapstart('_SBM_Nucleat', 3)
2397 
2398  ! lhv
2399  call atmos_hydrometeor_lhv( ijkmax, 1, ijkmax, temp(:), qlevp(:) )
2400 
2401  if( mp_couple_aerosol ) then
2402 
2403 
2404  do ijk = 1, ijkmax
2405  dmp = ccn(ijk) * expxctr( 1 )
2406  dmp = min( dmp,qvap(ijk)*dens(ijk) )
2407  gc( 1,il,ijk ) = gc( 1,il,ijk ) + dmp/dxmic
2408  dqv = dmp/dens(ijk)
2409  qvap(ijk) = qvap(ijk) - dqv
2410  temp(ijk) = temp(ijk) + dqv*qlevp(ijk)/cv(ijk)
2411  cp(ijk) = cp(ijk) + ( cp_water - cp_vapor ) * dqv
2412  cv(ijk) = cv(ijk) + ( cv_water - cv_vapor ) * dqv
2413  enddo
2414 
2415  else
2416 
2417  call atmos_saturation_pres2qsat_liq( ijkmax, 1, ijkmax, &
2418  temp(:), pres(:), qdry(:), & ! [IN]
2419  qsat(:) ) ! [OUT]
2420  !--- supersaturation
2421  do ijk = 1, ijkmax
2422  ssliq(ijk) = qvap(ijk)/qsat(ijk) - 1.0_rp
2423  enddo
2424 
2425  sumnum(:) = 0.0_rp
2426  do ijk = 1, ijkmax
2427  ! if ( ssliq <= 0.0_RP ) cycle
2428  if ( ssliq(ijk) > 0.0_rp ) then
2429 
2430  !--- use for aerosol coupled model
2431  !--- mass -> number
2432  do n = 1, nbin
2433  gcn( n,ijk ) = gc( n,il,ijk )*rexpxctr( n )
2434  enddo
2435 
2436  do n = 1, nbin
2437  sumnum(ijk) = sumnum(ijk) + gcn( n,ijk )*dxmic
2438  enddo
2439  n_c = c_ccn * ( ssliq(ijk) * 1.e+2_rp )**( kappa )
2440  if ( n_c > sumnum(ijk) ) then
2441  dmp = ( n_c - sumnum(ijk) ) * expxctr( 1 )
2442  dmp = min( dmp,qvap(ijk)*dens(ijk) )
2443  gc( 1,il,ijk ) = gc( 1,il,ijk ) + dmp/dxmic
2444  dqv = dmp/dens(ijk)
2445  qvap(ijk) = qvap(ijk) - dqv
2446  qvap(ijk) = max( qvap(ijk),0.0_rp )
2447  temp(ijk) = temp(ijk) + dqv*qlevp(ijk)/cv(ijk)
2448  cp(ijk) = cp(ijk) + ( cp_water - cp_vapor ) * dqv
2449  cv(ijk) = cv(ijk) + ( cv_water - cv_vapor ) * dqv
2450  endif
2451  endif
2452 
2453  enddo
2454 
2455  endif
2456 
2457  call prof_rapend ('_SBM_Nucleat', 3)
2458 
2459  return
2460  end subroutine nucleat
2461 
2462  !-----------------------------------------------------------------------------
2463  subroutine nucleata( &
2464  ijkmax, &
2465  dens, &
2466  pres, &
2467  qdry, &
2468  temp, &
2469  qvap, &
2470  gc, &
2471  ga, &
2472  cp, &
2473  cv, &
2474  dtime )
2475  use scale_const, only: &
2476  pi => const_pi, &
2477  rvap => const_rvap, &
2478  rhow => const_dwatr
2479  use scale_atmos_hydrometeor, only: &
2480  atmos_hydrometeor_lhv, &
2481  cp_vapor, &
2482  cp_water, &
2483  cv_vapor, &
2484  cv_water
2485  use scale_atmos_saturation, only: &
2486  atmos_saturation_pres2qsat_liq, &
2487  atmos_saturation_pres2qsat_ice
2488  implicit none
2489 
2490  integer, intent(in) :: ijkmax
2491  real(rp), intent(in) :: dens(ijkmax) ! Density [kg/m3]
2492  real(rp), intent(in) :: pres(ijkmax) ! Pressure [Pa]
2493  real(rp), intent(in) :: qdry(ijkmax) ! dry air mass ratio [kg/kg]
2494  real(rp), intent(inout) :: temp(ijkmax) ! Temperature [K]
2495  real(rp), intent(inout) :: qvap(ijkmax) ! Specific humidity [kg/kg]
2496  real(rp), intent(inout) :: gc (nbin,nspc,ijkmax) ! Mass size distribution function of hydrometeor
2497  real(rp), intent(inout) :: ga (nccn ,ijkmax) ! Mass size distribution function of aerosol
2498  real(rp), intent(inout) :: cp(ijkmax) ! specific heat
2499  real(rp), intent(inout) :: cv(ijkmax) ! specific heat
2500  real(dp), intent(in) :: dtime ! Time step interval
2501 
2502  real(rp) :: gan( nccn ) ! size distribution function ( aerosol ) : number ( gan = ga/exp( xactr ) )
2503  real(rp) :: ssliq ! supersaturatioin of liq. and ice, and LH
2504  real(rp) :: acoef, bcoef ! A and B in eq. (A.11) of Suzuki (2004)
2505  real(rp) :: rcrit ! critical radius (rcrit, r_N,crit of (A.11) of Suzuki (2004))
2506  real(rp) :: xcrit ! exp of hydrometeror whose radi is corresponding to rcrit (xcrit)
2507  real(rp) :: ractr, rcld, xcld, part, dmp
2508  integer :: n, nc, ncrit
2509 ! integer, allocatable, save :: ncld( : )
2510 ! integer, save :: ncld( 1:nccn )
2511 ! logical, save :: ofirst(1:ijkmax) = .true.
2512  !
2513  real(rp) :: qlevp(ijkmax)
2514  real(rp) :: qsatl(ijkmax)
2515  real(rp) :: dqv
2516  integer :: ijk
2517 
2518  call prof_rapstart('_SBM_NucleatA', 3)
2519 
2520  ! lhv
2521  call atmos_hydrometeor_lhv( ijkmax, 1, ijkmax, temp(:), qlevp(:) )
2522 
2523  call atmos_saturation_pres2qsat_liq( ijkmax, 1, ijkmax, &
2524  temp(:), pres(:), qdry(:), & ! [IN]
2525  qsatl(:) ) ! [OUT]
2526  do ijk = 1, ijkmax
2527  !--- supersaturation
2528  ssliq = qvap(ijk)/qsatl(ijk) - 1.0_rp
2529 
2530  if ( ssliq <= 0.0_rp ) cycle
2531 
2532  !--- use for aerosol coupled model
2533  !--- mass -> number
2534  do n = 1, nccn
2535  gan( n ) = ga( n,ijk )*rexpxactr( n )
2536  enddo
2537 
2538  acoef = 2.0_rp*sigma/rvap/rhow/temp(ijk) ! A in (A.11) of Suzuki (2004)
2539  bcoef = vhfct* rhoa/rhow * emwtr/emaer ! B in (A.11) of Suzuki (2004)
2540 
2541  !--- relationship of bin number
2542  do n = 1, nccn
2543  ractr = ( expxactr( n )*thirdovforth/pi/rhoa )**( oneovthird )
2544  rcld = sqrt( 3.0_rp*bcoef*ractr*ractr*ractr / acoef )
2545  xcld = log( rhow * 4.0_rp*pi*oneovthird*rcld*rcld*rcld )
2546  if ( flg_nucl ) then
2547  ncld( n ) = 1
2548  else
2549  ncld( n ) = int( ( xcld-xctr( 1 ) )/dxmic ) + 1
2550  ncld( n ) = min( max( ncld( n ),1 ),nbin )
2551  endif
2552  enddo
2553 
2554  !--- nucleation
2555  do n = nccn, 1, -1
2556  if ( ssliq <= 0.0_rp ) exit
2557  !--- use for aerosol coupled model
2558  acoef = 2.0_rp*sigma/rvap/rhow/temp(ijk) ! A in (A.11) of Suzuki (2004)
2559  rcrit = acoef*oneovthird * ( 4.0_rp/bcoef )**( oneovthird ) / ssliq**( twoovthird ) ! r_{N,crit} in (A.11) of Suzuki (2004)
2560  xcrit = log( rhoa * 4.0_rp*pi*oneovthird * rcrit*rcrit*rcrit )
2561  ncrit = int( ( xcrit-xabnd( 1 ) )/dxaer ) + 1
2562 
2563  if ( n == ncrit ) then
2564  part = ( xabnd( ncrit+1 )-xcrit )/dxaer
2565  elseif ( n > ncrit ) then
2566  part = 1.0_rp
2567  else
2568  exit
2569  endif
2570 
2571  !--- calculate mass change
2572  nc = ncld( n )
2573  dmp = part*gan( n )*dxaer*expxctr( nc )
2574  dmp = min( dmp,qvap(ijk)*dens(ijk) )
2575  gc( nc,il,ijk ) = gc( nc,il,ijk ) + dmp/dxmic
2576  gan( n ) = gan( n ) - dmp/dxaer*rexpxctr( nc )
2577  gan( n ) = max( gan( n ), 0.0_rp )
2578  dqv = dmp/dens(ijk)
2579  qvap(ijk) = qvap(ijk) - dqv
2580  qvap(ijk) = max( qvap(ijk),0.0_rp )
2581  temp(ijk) = temp(ijk) + dqv*qlevp(ijk)/cv(ijk)
2582  cp(ijk) = cp(ijk) + ( cp_water - cp_vapor ) * dqv
2583  cv(ijk) = cv(ijk) + ( cv_water - cv_vapor ) * dqv
2584  enddo
2585 
2586  !--- number -> mass
2587  do n = 1, nccn
2588  ga( n,ijk ) = gan( n )*expxactr( n )
2589  enddo
2590 
2591  enddo
2592 
2593  call prof_rapend ('_SBM_NucleatA', 3)
2594 
2595  return
2596  end subroutine nucleata
2597 
2598  !-----------------------------------------------------------------------------
2599  subroutine cndevpsbl( &
2600  ijkmax, &
2601  dens, &
2602  pres, &
2603  qdry, &
2604  temp, &
2605  qvap, &
2606  gc, &
2607  cp, &
2608  cv, &
2609  evaporate, &
2610  dtime, &
2611  gcrg )
2612  implicit none
2613 
2614  integer, intent(in) :: ijkmax
2615  real(rp), intent(in) :: dens(ijkmax) ! Density [kg/m3]
2616  real(rp), intent(in) :: pres(ijkmax) ! Pressure [Pa]
2617  real(rp), intent(in) :: qdry(ijkmax) ! dry air mass ratio [kg/kg]
2618  real(rp), intent(inout) :: temp(ijkmax) ! Temperature [K]
2619  real(rp), intent(inout) :: qvap(ijkmax) ! Specific humidity [kg/kg]
2620  real(rp), intent(inout) :: gc (nbin,nspc,ijkmax) ! Mass size distribution function of hydrometeor
2621  real(rp), intent(inout) :: cp(ijkmax) ! specific heat
2622  real(rp), intent(inout) :: cv(ijkmax) ! specific heat
2623  real(rp), intent(out) :: evaporate(ijkmax) ! Number concentration of evaporated cloud [/m3]
2624  real(dp), intent(in) :: dtime ! Time step interval
2625  real(rp), intent(inout) :: gcrg(nbin,nspc,ijkmax) ! Mass size distribution function of hydrometeor
2626  !---------------------------------------------------------------------------
2627 
2628  call liqphase( ijkmax, & ! [IN]
2629  dens(:), & ! [IN]
2630  pres(:), & ! [IN]
2631  qdry(:), & ! [IN]
2632  temp(:), & ! [INOUT]
2633  qvap(:), & ! [INOUT]
2634  gc(:,:,:), & ! [INOUT]
2635  gcrg(:,:,:), & ! [INOUT]
2636  cp(:), & ! [INOUT]
2637  cv(:), & ! [INOUT]
2638  evaporate(:), & ! [OUT]
2639  dtime ) ! [IN]
2640 
2641  if( nspc > 1 ) then
2642  call icephase( ijkmax, & ! [IN]
2643  dens(:), & ! [IN]
2644  pres(:), & ! [IN]
2645  qdry(:), & ! [IN]
2646  temp(:), & ! [INOUT]
2647  qvap(:), & ! [INOUT]
2648  gc(:,:,:), & ! [INOUT]
2649  gcrg(:,:,:), & ! [INOUT]
2650  cp(:), & ! [INOUT]
2651  cv(:), & ! [INOUT]
2652  dtime ) ! [IN]
2653 
2654  call mixphase( ijkmax, & ! [IN]
2655  dens(:), & ! [IN]
2656  pres(:), & ! [IN]
2657  qdry(:), & ! [IN]
2658  temp(:), & ! [INOUT]
2659  qvap(:), & ! [INOUT]
2660  gc(:,:,:), & ! [INOUT]
2661  gcrg(:,:,:), & ! [INOUT]
2662  cp(:), & ! [INOUT]
2663  cv(:), & ! [INOUT]
2664  dtime ) ! [IN]
2665  endif
2666 
2667  return
2668  end subroutine cndevpsbl
2669 
2670  !-----------------------------------------------------------------------------
2671  subroutine cndevpsbla( &
2672  ijkmax, &
2673  dens, &
2674  pres, &
2675  qdry, &
2676  temp, &
2677  qvap, &
2678  gc, &
2679  ga, &
2680  cp, &
2681  cv, &
2682  evaporate, &
2683  dtime, &
2684  gcrg )
2685  implicit none
2686 
2687  integer, intent(in) :: ijkmax
2688  real(rp), intent(in) :: dens(ijkmax) ! Density [kg/m3]
2689  real(rp), intent(in) :: pres(ijkmax) ! Pressure [Pa]
2690  real(rp), intent(in) :: qdry(ijkmax) ! dry air mass ratio [kg/kg]
2691  real(rp), intent(inout) :: temp(ijkmax) ! Temperature [K]
2692  real(rp), intent(inout) :: qvap(ijkmax) ! Specific humidity [kg/kg]
2693  real(rp), intent(inout) :: gc (nbin,nspc,ijkmax) ! Mass size distribution function of hydrometeor
2694  real(rp), intent(inout) :: ga (nccn ,ijkmax) ! Mass size distribution function of aerosol
2695  real(rp), intent(inout) :: cp(ijkmax) ! specific heat
2696  real(rp), intent(inout) :: cv(ijkmax) ! specific heat
2697  real(rp), intent(out) :: evaporate(ijkmax) ! Number concentration of evaporated cloud [/m3]
2698  real(dp), intent(in) :: dtime ! Time step interval
2699  real(rp), intent(inout) :: gcrg(nbin,nspc,ijkmax) ! Mass size distribution function of hydrometeor
2700  !---------------------------------------------------------------------------
2701 
2702  call liqphase( ijkmax, & ! [IN]
2703  dens(:), & ! [IN]
2704  pres(:), & ! [IN]
2705  qdry(:), & ! [IN]
2706  temp(:), & ! [INOUT]
2707  qvap(:), & ! [INOUT]
2708  gc(:,:,:), & ! [INOUT]
2709  gcrg(:,:,:), & ! [INOUT]
2710  cp(:), & ! [INOUT]
2711  cv(:), & ! [INOUT]
2712  evaporate(:), & ! [OUT]
2713  dtime ) ! [IN]
2714 
2715  ! regeneration of aerosol
2716  if ( flg_regeneration ) then
2717  call faero( ijkmax, & ! [IN]
2718 ! regene_gcn(:), & ! [IN]
2719  evaporate(:), & ! [IN]
2720  ga(:,:) ) ! [INOUT]
2721  endif
2722 
2723  if( nspc > 1 ) then
2724  call icephase( ijkmax, & ! [IN]
2725  dens(:), & ! [IN]
2726  pres(:), & ! [IN]
2727  qdry(:), & ! [IN]
2728  temp(:), & ! [INOUT]
2729  qvap(:), & ! [INOUT]
2730  gc(:,:,:), & ! [INOUT]
2731  gcrg(:,:,:), & ! [INOUT]
2732  cp(:), & ! [INOUT]
2733  cv(:), & ! [INOUT]
2734  dtime ) ! [IN]
2735 
2736  call mixphase( ijkmax, & ! [IN]
2737  dens(:), & ! [IN]
2738  pres(:), & ! [IN]
2739  qdry(:), & ! [IN]
2740  temp(:), & ! [INOUT]
2741  qvap(:), & ! [INOUT]
2742  gc(:,:,:), & ! [INOUT]
2743  gcrg(:,:,:), & ! [INOUT]
2744  cp(:), & ! [INOUT]
2745  cv(:), & ! [INOUT]
2746  dtime ) ! [IN]
2747  endif
2748 
2749  return
2750  end subroutine cndevpsbla
2751 
2752  !-----------------------------------------------------------------------------
2753  subroutine liqphase( &
2754  ijkmax, &
2755  dens, &
2756  pres, &
2757  qdry, &
2758  temp, &
2759  qvap, &
2760  gc, &
2761  gcrg, &
2762  cp, &
2763  cv, &
2764  regene_gcn, &
2765  dtime )
2766  use scale_const, only: &
2767  pi => const_pi, &
2768  eps => const_eps, &
2769  esat0 => const_psat0, &
2770  rvap => const_rvap, &
2771  tmlt => const_tmelt, &
2772  tem00 => const_tem00
2773  use scale_atmos_hydrometeor, only: &
2774  atmos_hydrometeor_lhv, &
2775  cp_vapor, &
2776  cp_water, &
2777  cv_vapor, &
2778  cv_water
2779  use scale_atmos_saturation, only: &
2780  atmos_saturation_pres2qsat_liq
2781  implicit none
2782 
2783  integer, intent(in) :: ijkmax
2784  real(rp), intent(in) :: dens(ijkmax) ! Density [kg/m3]
2785  real(rp), intent(in) :: pres(ijkmax) ! Pressure [Pa]
2786  real(rp), intent(in) :: qdry(ijkmax) ! dry air mass ratio [kg/kg]
2787  real(rp), intent(inout) :: temp(ijkmax) ! Temperature [K]
2788  real(rp), intent(inout) :: qvap(ijkmax) ! Specific humidity [kg/kg]
2789  real(rp), intent(inout) :: gc (nbin,nspc,ijkmax) ! Mass size distribution function of hydrometeor
2790  real(rp), intent(inout) :: gcrg(nbin,nspc,ijkmax)
2791  real(rp), intent(inout) :: cp(ijkmax) ! specific heat
2792  real(rp), intent(inout) :: cv(ijkmax) ! specific heat
2793  real(rp), intent(out) :: regene_gcn(ijkmax) ! mass of regenerated aerosol
2794  real(dp), intent(in) :: dtime ! Time step interval
2795 
2796  integer :: n, myu, ncount
2797  integer :: nloop(ijkmax) ! number of fractional step for condensation
2798  real(rp) :: gclold(ijkmax)
2799  real(rp) :: gclnew(ijkmax)
2800  real(rp) :: cndmss
2801  real(rp) :: dtcnd(ijkmax) ! dt for condensation with considering CFL condition
2802  real(rp) :: gtliq(ijkmax) ! G of eq. (A.17) of Suzuki (2004)
2803  real(rp) :: qlevp(ijkmax) ! LH
2804  real(rp) :: cefliq, a, sliqtnd
2805  real(rp) :: sumliq(ijkmax), umax(ijkmax)
2806  real(rp) :: ssliq ! super saturation
2807  real(rp) :: gcn( -1:nbin+2,nspc,ijkmax ) ! size distribution function(hydrometeor): number
2808  ! real(RP) :: gcnold( nbin,ijkmax )
2809  real(rp), parameter :: cflfct = 0.50_rp ! CFL limiter
2810  ! real(RP) :: old_sum_gcn, new_sum_gcn
2811  integer :: iflg( nspc,ijkmax ) ! flag whether calculation is conduct or not
2812  real(rp) :: csum( nspc,ijkmax )
2813  real(rp) :: f1, f2, emu, cefd, cefk, festl
2814  real(rp) :: qsatl(ijkmax)
2815  real(rp), parameter :: afmyu = 1.72e-05_rp, bfmyu = 3.93e+2_rp
2816  real(rp), parameter :: cfmyu = 1.2e+02_rp, fct = 1.4e+3_rp
2817  real(rp) :: zerosw, qvtmp
2818  real(rp) :: dqv
2819  integer :: ijk, nn, mm, loopflg(ijkmax)
2820 
2821  !--- local for advection
2822  real(rp) :: uadv ( 0:nbin+2,nspc,ijkmax )
2823  real(rp) :: flq ( 1:nbin+1,nspc,ijkmax )
2824  real(rp) :: acoef( 0:2,0:nbin+1,nspc,ijkmax )
2825  real(rp) :: crn ( 0:nbin+2,nspc,ijkmax )
2826  real(rp) :: aip ( 0:nbin+1,nspc,ijkmax )
2827  real(rp) :: aim ( 0:nbin+1,nspc,ijkmax )
2828  real(rp) :: ai ( 0:nbin+1,nspc,ijkmax )
2829  real(rp) :: cmins, cplus
2830  integer :: nloopmax
2831 
2832  !--- for lithgning component (if not use lightning component, arrays shown below work dummy array)
2833  real(rp) :: gcrgn( -1:nbin+2,nspc,ijkmax )
2834  real(rp) :: flq_c( 1:nbin+1,nspc,ijkmax )
2835  real(rp) :: acoef_c( 0:2,0:nbin+1,nspc,ijkmax )
2836  real(rp) :: aip_c ( 0:nbin+1,nspc,ijkmax )
2837  real(rp) :: aim_c ( 0:nbin+1,nspc,ijkmax )
2838  real(rp) :: ai_c ( 0:nbin+1,nspc,ijkmax )
2839 
2840  call prof_rapstart('_SBM_Liqphase', 3)
2841 
2842  iflg(:,:) = 0
2843  csum(:,:) = 0.0_rp
2844  do ijk = 1, ijkmax
2845  do n = 1, nbin
2846  csum( il,ijk ) = csum( il,ijk ) + gc( n,il,ijk )*dxmic
2847  enddo
2848  if( csum( il,ijk ) > cldmin ) iflg( il,ijk ) = 1
2849 
2850  enddo
2851 
2852  ! lhv
2853  call atmos_hydrometeor_lhv( ijkmax, 1, ijkmax, temp(:), qlevp(:) )
2854 
2855  call atmos_saturation_pres2qsat_liq( ijkmax, 1, ijkmax, &
2856  temp(:), pres(:), qdry(:), & ! [IN]
2857  qsatl(:) ) ! [OUT]
2858 
2859  nloop(:) = 0
2860  gclold(:) = 0.0_rp
2861  do ijk = 1, ijkmax
2862 
2863  do n = 1, nbin
2864  gclold(ijk) = gclold(ijk) + gc( n,il,ijk ) * dxmic
2865  enddo
2866  !
2867  !------- mass -> number
2868  do n = 1, nbin
2869  gcn( n,il,ijk ) = gc( n,il,ijk ) * rexpxctr( n )
2870  gcrgn( n,il,ijk ) = gcrg( n,il,ijk )
2871  enddo
2872  gcn( -1,il,ijk ) = 0.0_rp
2873  gcn( 0,il,ijk ) = 0.0_rp
2874  gcn( nbin+1,il,ijk ) = 0.0_rp
2875  gcn( nbin+2,il,ijk ) = 0.0_rp
2876  gcrgn( -1,il,ijk ) = 0.0_rp
2877  gcrgn( 0,il,ijk ) = 0.0_rp
2878  gcrgn( nbin+1,il,ijk ) = 0.0_rp
2879  gcrgn( nbin+2,il,ijk ) = 0.0_rp
2880  !
2881  !--- super saturation
2882  ssliq = qvap(ijk)/qsatl(ijk) - 1.0_rp
2883 
2884  emu = afmyu*( bfmyu/( temp(ijk)+cfmyu ) )*( temp(ijk)/tmlt )**1.50_rp
2885  cefd = emu/dens(ijk)
2886  cefk = fct*emu
2887 
2888  festl = esat0*exp( qlevp(ijk)/rvap*( 1.0_rp/tem00 - 1.0_rp/temp(ijk) ) )
2889  f1 = rvap*temp(ijk)/festl/cefd
2890  f2 = qlevp(ijk)/cefk/temp(ijk)*( qlevp(ijk)/rvap/temp(ijk) - 1.0_rp )
2891  gtliq(ijk) = 4.0_rp*pi/( f1+f2 ) !--- G of eq. (A.17) of Suzuki (2004)
2892  !------- CFL condition
2893  umax(ijk) = cbnd( 1,il )*rexpxbnd( 1 )*gtliq(ijk)*abs( ssliq )
2894  dtcnd(ijk) = cflfct*dxmic/umax(ijk)
2895  nloop(ijk) = int( dtime/dtcnd(ijk) ) + 1
2896  dtcnd(ijk) = dtime / nloop(ijk)
2897 
2898  nloop(ijk) = nloop(ijk) * iflg( il,ijk ) !--- for determing trivial loop
2899  enddo
2900  nloopmax = maxval(nloop,1)
2901 
2902  !
2903  regene_gcn(:) = 0.0_rp
2904 !OCL LOOP_NOFISSION
2905 !OCL LOOP_NOINTERCHANGE
2906  do ncount = 1, nloopmax
2907 
2908  do ijk = 1, ijkmax
2909  loopflg(ijk) = min( 1, int(nloop(ijk)/ncount) ) ! 0 or 1
2910  enddo
2911 
2912  ! lhv
2913  call atmos_hydrometeor_lhv( ijkmax, 1, ijkmax, temp(:), qlevp(:) )
2914 
2915 !OCL LOOP_NOFUSION
2916  do ijk = 1, ijkmax
2917  do nn = 1, loopflg(ijk)
2918 
2919  emu = afmyu*( bfmyu/( temp(ijk)+cfmyu ) )*( temp(ijk)/tmlt )**1.50_rp
2920  cefd = emu/dens(ijk)
2921  cefk = fct*emu
2922  festl = esat0*exp( qlevp(ijk)/rvap*( 1.0_rp/tem00 - 1.0_rp/temp(ijk) ) )
2923  f1 = rvap*temp(ijk)/festl/cefd
2924  f2 = qlevp(ijk)/cefk/temp(ijk)*( qlevp(ijk)/rvap/temp(ijk) - 1.0_rp )
2925  gtliq(ijk) = 4.0_rp*pi/( f1+f2 ) !--- G of eq. (A.17) of Suzuki (2004)
2926 
2927  sumliq(ijk) = 0.0_rp
2928  ! old_sum_gcn = 0.0_RP
2929  do n = 1, nbin
2930  sumliq(ijk) = sumliq(ijk) + gcn( n,il,ijk )*cctr( n,il )*dxmic
2931  enddo
2932 
2933  enddo
2934  enddo
2935 
2936  !--- super saturation
2937  call atmos_saturation_pres2qsat_liq( ijkmax, 1, ijkmax, &
2938  temp(:), pres(:), qdry(:), & ! [IN]
2939  qsatl(:) ) ! [OUT]
2940 !OCL LOOP_NOFUSION
2941  do ijk = 1, ijkmax
2942  do nn = 1, loopflg(ijk)
2943 
2944  ssliq = qvap(ijk)/qsatl(ijk) - 1.0_rp
2945 
2946  !----- supersaturation tendency
2947  zerosw = 0.5_rp + sign( 0.5_rp,qvap(ijk)-eps ) !--- zerosw = 1 (qv>0), zerosw=0 (qv=0)
2948  qvtmp = qvap(ijk) * zerosw + ( qvap(ijk)+eps ) * ( 1.0_rp-zerosw )
2949  cefliq = ( ssliq+1.0_rp )*( 1.0_rp/qvtmp + qlevp(ijk)*qlevp(ijk)/cv(ijk)/rvap/temp(ijk)/temp(ijk) )
2950  a = - cefliq*sumliq(ijk)*gtliq(ijk)/dens(ijk) ! a of eq. (A.19) of Suzuki (2004)
2951  a = a + eps * ( 1.0_rp - zerosw ) !--- avoiding division by zero when qv = 0
2952 
2953  sliqtnd = zerosw * &
2954  ( ssliq * ( exp( a*dtcnd(ijk) )-1.0_rp )/( a*dtcnd(ijk) ) &
2955  * ( 0.5_rp + sign( 0.5_rp,abs(a*dtcnd(ijk)-0.1_rp) ) ) &
2956  + ssliq &
2957  * ( 0.5_rp - sign( 0.5_rp,abs(a*dtcnd(ijk)-0.1_rp) ) ) &
2958  ) &
2959  + ssliq * ( 1.0_rp - zerosw )
2960  !
2961  !----- change of SDF
2962  do mm = 1, iflg( il,ijk )
2963  !--- advection speed
2964  do n = 1, nbin+1
2965  uadv( n,il,ijk ) = cbnd( n,il )*rexpxbnd( n )*gtliq(ijk)*sliqtnd ! U of eq. (A.18) of Suzuki (2004)
2966  enddo
2967  uadv( 0 ,il,ijk ) = 0.0_rp
2968  uadv( nbin+2,il,ijk ) = 0.0_rp
2969 
2970 ! do n = 1, nbin
2971 ! gcnold( n ) = gcn( n,il,ijk )
2972 ! enddo
2973  enddo
2974 
2975  enddo
2976  enddo
2977 
2978  call prof_rapstart('_SBM_AdvLiq', 3)
2979 
2980  do ijk = 1, ijkmax
2981  do nn = 1, loopflg(ijk)
2982  do myu = 1, il
2983  do mm = 1, iflg( myu,ijk )
2984  do n = 0, nbin+2
2985  crn( n,myu,ijk ) = uadv( n,myu,ijk )*dtcnd(ijk)/dxmic
2986  enddo
2987  enddo
2988  enddo
2989  enddo
2990  enddo
2991 
2992  do ijk = 1, ijkmax
2993  do nn = 1, loopflg(ijk)
2994  do myu = 1, il
2995  do mm = 1, iflg( myu,ijk )
2996  do n = 0, nbin+1
2997  acoef(0,n,myu,ijk) = - ( gcn( n+1,myu,ijk )-26.0_rp*gcn( n,myu,ijk )+gcn( n-1,myu,ijk ) ) / 48.0_rp
2998  acoef(1,n,myu,ijk) = ( gcn( n+1,myu,ijk ) -gcn( n-1,myu,ijk ) ) / 16.0_rp
2999  acoef(2,n,myu,ijk) = ( gcn( n+1,myu,ijk )- 2.0_rp*gcn( n,myu,ijk )+gcn( n-1,myu,ijk ) ) / 48.0_rp
3000  acoef_c(0,n,myu,ijk) = - ( gcrgn( n+1,myu,ijk )-26.0_rp*gcrgn( n,myu,ijk )+gcrgn( n-1,myu,ijk ) ) / 48.0_rp
3001  acoef_c(1,n,myu,ijk) = ( gcrgn( n+1,myu,ijk ) -gcrgn( n-1,myu,ijk ) ) / 16.0_rp
3002  acoef_c(2,n,myu,ijk) = ( gcrgn( n+1,myu,ijk )- 2.0_rp*gcrgn( n,myu,ijk )+gcrgn( n-1,myu,ijk ) ) / 48.0_rp
3003  enddo
3004  enddo
3005  enddo
3006  enddo
3007  enddo
3008 
3009  do ijk = 1, ijkmax
3010  do nn = 1, loopflg(ijk)
3011  do myu = 1, il
3012  do mm = 1, iflg( myu,ijk )
3013  do n = 0, nbin+1
3014  cplus = 1.0_rp - ( crn(n+1,myu,ijk) + abs(crn(n+1,myu,ijk)) )
3015 
3016  aip(n,myu,ijk) = acoef(0,n,myu,ijk) * ( 1.0_rp-cplus**1 ) &
3017  + acoef(1,n,myu,ijk) * ( 1.0_rp-cplus**2 ) &
3018  + acoef(2,n,myu,ijk) * ( 1.0_rp-cplus**3 )
3019 
3020  aip(n,myu,ijk) = max( aip(n,myu,ijk), 0.0_rp )
3021 
3022  aip_c(n,myu,ijk) = acoef_c(0,n,myu,ijk) * ( 1.0_rp-cplus**1 ) &
3023  + acoef_c(1,n,myu,ijk) * ( 1.0_rp-cplus**2 ) &
3024  + acoef_c(2,n,myu,ijk) * ( 1.0_rp-cplus**3 )
3025 
3026  aip_c(n,myu,ijk) = max( aip_c(n,myu,ijk), 0.0_rp )
3027  enddo
3028  enddo
3029  enddo
3030  enddo
3031  enddo
3032 
3033  do ijk = 1, ijkmax
3034  do nn = 1, loopflg(ijk)
3035  do myu = 1, il
3036  do mm = 1, iflg( myu,ijk )
3037  do n = 0, nbin+1
3038  cmins = 1.0_rp - ( abs(crn(n,myu,ijk)) - crn(n,myu,ijk) )
3039 
3040  aim(n,myu,ijk) = acoef(0,n,myu,ijk) * ( 1.0_rp-cmins**1 ) &
3041  - acoef(1,n,myu,ijk) * ( 1.0_rp-cmins**2 ) &
3042  + acoef(2,n,myu,ijk) * ( 1.0_rp-cmins**3 )
3043 
3044  aim(n,myu,ijk) = max( aim(n,myu,ijk), 0.0_rp )
3045 
3046  aim_c(n,myu,ijk) = acoef_c(0,n,myu,ijk) * ( 1.0_rp-cmins**1 ) &
3047  - acoef_c(1,n,myu,ijk) * ( 1.0_rp-cmins**2 ) &
3048  + acoef_c(2,n,myu,ijk) * ( 1.0_rp-cmins**3 )
3049 
3050  aim_c(n,myu,ijk) = max( aim_c(n,myu,ijk), 0.0_rp )
3051  enddo
3052  enddo
3053  enddo
3054  enddo
3055  enddo
3056 
3057  do ijk = 1, ijkmax
3058  do nn = 1, loopflg(ijk)
3059  do myu = 1, il
3060  do mm = 1, iflg( myu,ijk )
3061  do n = 0, nbin+1
3062  ai(n,myu,ijk) = acoef(0,n,myu,ijk) * 2.0_rp &
3063  + acoef(2,n,myu,ijk) * 2.0_rp
3064 
3065  ai(n,myu,ijk) = max( ai(n,myu,ijk), aip(n,myu,ijk)+aim(n,myu,ijk)+cldmin )
3066 
3067  ai_c(n,myu,ijk) = acoef_c(0,n,myu,ijk) * 2.0_rp &
3068  + acoef_c(2,n,myu,ijk) * 2.0_rp
3069 
3070  ai_c(n,myu,ijk) = max( ai_c(n,myu,ijk), aip_c(n,myu,ijk)+aim_c(n,myu,ijk)+cldmin )
3071  enddo
3072  enddo
3073  enddo
3074  enddo
3075  enddo
3076 
3077  do ijk = 1, ijkmax
3078  do nn = 1, loopflg(ijk)
3079  do myu = 1, il
3080  do mm = 1, iflg( myu,ijk )
3081  do n = 1, nbin+1
3082  flq(n,myu,ijk) = ( aip(n-1,myu,ijk)/ai(n-1,myu,ijk)*gcn( n-1,myu,ijk ) &
3083  - aim(n ,myu,ijk)/ai(n ,myu,ijk)*gcn( n ,myu,ijk ) )*dxmic/dtcnd(ijk)
3084  flq_c(n,myu,ijk) = ( aip_c(n-1,myu,ijk)/ai_c(n-1,myu,ijk)*gcrgn( n-1,myu,ijk ) &
3085  - aim_c(n ,myu,ijk)/ai_c(n ,myu,ijk)*gcrgn( n ,myu,ijk ) )/dtcnd(ijk)
3086  enddo
3087  enddo
3088  enddo
3089  enddo
3090  enddo
3091 
3092  do ijk = 1, ijkmax
3093  do nn = 1, loopflg(ijk)
3094  do myu = 1, il
3095  do mm = 1, iflg( myu,ijk )
3096  regene_gcn(ijk) = regene_gcn(ijk)+( -flq(1,myu,ijk)*dtcnd(ijk)/dxmic ) &
3097  * min( uadv(1,myu,ijk),0.0_rp )/( uadv(1,myu,ijk) + eps )
3098  enddo
3099  enddo
3100  enddo
3101  enddo
3102 
3103  do ijk = 1, ijkmax
3104  do nn = 1, loopflg(ijk)
3105  do myu = 1, il
3106  do mm = 1, iflg( myu,ijk )
3107  do n = 1, nbin
3108  gcn( n,myu,ijk ) = gcn( n,myu,ijk ) - ( flq(n+1,myu,ijk)-flq(n,myu,ijk) )*dtcnd(ijk)/dxmic
3109  gcrgn( n,myu,ijk ) = gcrgn( n,myu,ijk ) - ( flq_c(n+1,myu,ijk)-flq_c(n,myu,ijk) )*dtcnd(ijk)
3110  enddo
3111  enddo
3112  enddo
3113  enddo
3114  enddo
3115 
3116  call prof_rapend ('_SBM_AdvLiq', 3)
3117 
3118 !OCL LOOP_NOFUSION
3119  do ijk = 1, ijkmax
3120  do nn = 1, loopflg(ijk)
3121 
3122  !----- new mass
3123  gclnew(ijk) = 0.0_rp
3124 ! new_sum_gcn = 0.0_RP
3125  do n = 1, nbin
3126  gclnew(ijk) = gclnew(ijk) + gcn( n,il,ijk )*expxctr( n )
3127 ! old_sum_gcn = old_sum_gcn + gcnold( n )*dxmic
3128 ! new_sum_gcn = new_sum_gcn + gcn( n,ijk )*dxmic
3129  enddo
3130 
3131  gclnew(ijk) = gclnew(ijk)*dxmic
3132  !
3133  !----- change of humidity and temperature
3134  cndmss = gclnew(ijk) - gclold(ijk)
3135  dqv = cndmss/dens(ijk)
3136  qvap(ijk) = qvap(ijk) - dqv
3137  temp(ijk) = temp(ijk) + dqv*qlevp(ijk)/cv(ijk)
3138  cp(ijk) = cp(ijk) + ( cp_water - cp_vapor ) * dqv
3139  cv(ijk) = cv(ijk) + ( cv_water - cv_vapor ) * dqv
3140  !
3141  gclold(ijk) = gclnew(ijk)
3142  !
3143  !----- continue/end
3144  enddo
3145  enddo
3146 
3147  enddo !nloop
3148  !
3149 !OCL NORECURRENCE(gc)
3150  do ijk = 1, ijkmax
3151  !------- number -> mass
3152  do n = 1 , nbin
3153  gc( n,il,ijk ) = gcn( n,il,ijk )*expxctr( n )
3154  gcrg( n,il,ijk ) = gcrgn( n,il,ijk )
3155  enddo
3156  enddo
3157 
3158  ! lhv
3159  call atmos_hydrometeor_lhv( ijkmax, 1, ijkmax, temp(:), qlevp(:) )
3160 
3161 !OCL NORECURRENCE(gc)
3162  do ijk = 1, ijkmax
3163  do n = 1 , nbin
3164  if ( gc( n,il,ijk ) < 0.0_rp ) then
3165  cndmss = -gc( n,il,ijk )
3166  gc( n,il,ijk ) = 0.0_rp
3167  gcrg( n,il,ijk ) = 0.0_rp
3168  dqv = cndmss/dens(ijk)
3169  qvap(ijk) = qvap(ijk) + dqv
3170  temp(ijk) = temp(ijk) - dqv*qlevp(ijk)/cv(ijk)
3171  cp(ijk) = cp(ijk) + ( cp_vapor - cp_water ) * dqv
3172  cv(ijk) = cv(ijk) + ( cv_vapor - cv_water ) * dqv
3173  endif
3174  enddo
3175  enddo
3176 
3177  call prof_rapend ('_SBM_Liqphase', 3)
3178 
3179  return
3180  end subroutine liqphase
3181 
3182  !-----------------------------------------------------------------------------
3183  subroutine icephase( &
3184  ijkmax, &
3185  dens, &
3186  pres, &
3187  qdry, &
3188  temp, &
3189  qvap, &
3190  gc, &
3191  gcrg, &
3192  cp, &
3193  cv, &
3194  dtime )
3195  use scale_const, only: &
3196  pi => const_pi, &
3197  eps => const_eps, &
3198  esat0 => const_psat0, &
3199  tem00 => const_tem00, &
3200  rvap => const_rvap, &
3201  tmlt => const_tmelt
3202  use scale_atmos_hydrometeor, only: &
3203  atmos_hydrometeor_lhs, &
3204  cp_vapor, &
3205  cp_ice, &
3206  cv_vapor, &
3207  cv_ice
3208  use scale_atmos_saturation, only: &
3209  atmos_saturation_pres2qsat_ice
3210  implicit none
3211 
3212  integer, intent(in) :: ijkmax
3213  real(rp), intent(in) :: dens(ijkmax) ! Density [kg/m3]
3214  real(rp), intent(in) :: pres(ijkmax) ! Pressure [Pa]
3215  real(rp), intent(in) :: qdry(ijkmax) ! dry air mass ratio [kg/kg]
3216  real(rp), intent(inout) :: temp(ijkmax) ! Temperature [K]
3217  real(rp), intent(inout) :: qvap(ijkmax) ! Specific humidity [kg/kg]
3218  real(rp), intent(inout) :: gc (nbin,nspc,ijkmax) ! Mass size distribution function of hydrometeor
3219  real(rp), intent(inout) :: gcrg(nbin,nspc,ijkmax)
3220  real(rp), intent(inout) :: cp(ijkmax) ! specific heat
3221  real(rp), intent(inout) :: cv(ijkmax) ! specific heat
3222  real(dp), intent(in) :: dtime ! Time step interval
3223 
3224  integer :: myu, n, ncount
3225  integer :: nloop(ijkmax) !number of fractional step for condensation
3226  real(rp) :: gciold(ijkmax), gcinew(ijkmax)
3227  real(rp) :: dtcnd(ijkmax) ! dt for condensation with considering CFL condition
3228  real(rp) :: sblmss
3229  real(rp) :: gtice(ijkmax), umax(ijkmax)
3230  real(rp) :: qlsbl(ijkmax)
3231  real(rp) :: cefice, d, uval, sicetnd
3232  real(rp) :: sumice(ijkmax)
3233  real(rp) :: ssice
3234  real(rp) :: gcn( -1:nbin+2,nspc,ijkmax ) ! size distribution function (Hydrometeor): number
3235  real(rp), parameter :: cflfct = 0.50_rp
3236  real(rp) :: dumm_regene(ijkmax)
3237  integer :: iflg( nspc,ijkmax )
3238  real(rp) :: csum( nspc,ijkmax )
3239  real(rp) :: f1, f2, emu, cefd, cefk, festi
3240  real(rp) :: qsati(ijkmax)
3241  real(rp), parameter :: afmyu = 1.72e-05_rp, bfmyu = 3.93e+2_rp
3242  real(rp), parameter :: cfmyu = 1.2e+02_rp, fct = 1.4e+3_rp
3243  integer :: ijk, mm, nn, loopflg(ijkmax)
3244  real(rp) :: zerosw, qvtmp
3245  real(rp) :: dqv
3246 
3247  !--- local for advection
3248 ! real(RP) :: qadv( -1:nbin+2 ), uadv( 0:nbin+2 )
3249  real(rp) :: uadv ( 0:nbin+2,nspc,ijkmax )
3250  real(rp) :: flq ( 1:nbin+1,nspc,ijkmax )
3251  real(rp) :: acoef( 0:2,0:nbin+1,nspc,ijkmax )
3252  real(rp) :: crn ( 0:nbin+2,nspc,ijkmax )
3253  real(rp) :: aip ( 0:nbin+1,nspc,ijkmax )
3254  real(rp) :: aim ( 0:nbin+1,nspc,ijkmax )
3255  real(rp) :: ai ( 0:nbin+1,nspc,ijkmax )
3256  real(rp) :: cmins, cplus
3257  integer :: nloopmax
3258 
3259  !--- for lithgning component (if not use lightning component, arrays shown below work dummy array)
3260  real(rp) :: gcrgn( -1:nbin+2,nspc,ijkmax )
3261  real(rp) :: flq_c( 1:nbin+1,nspc,ijkmax )
3262  real(rp) :: acoef_c( 0:2,0:nbin+1,nspc,ijkmax )
3263  real(rp) :: aip_c ( 0:nbin+1,nspc,ijkmax )
3264  real(rp) :: aim_c ( 0:nbin+1,nspc,ijkmax )
3265  real(rp) :: ai_c ( 0:nbin+1,nspc,ijkmax )
3266  !---------------------------------------------------------------------------
3267 
3268  call prof_rapstart('_SBM_Icephase', 3)
3269 
3270  iflg(:,:) = 0
3271  csum( :,: ) = 0.0_rp
3272  do ijk = 1, ijkmax
3273 
3274  do myu = 2, nspc
3275  do n = 1, nbin
3276  csum( myu,ijk ) = csum( myu,ijk ) + gc( n,myu,ijk )*dxmic
3277  enddo
3278  enddo
3279 
3280  do myu = 2, nspc
3281  if ( csum( myu,ijk ) > cldmin ) iflg( myu,ijk ) = 1
3282  enddo
3283 
3284  enddo
3285 
3286  ! lhs
3287  call atmos_hydrometeor_lhs( ijkmax, 1, ijkmax, temp(:), qlsbl(:) )
3288 
3289  call atmos_saturation_pres2qsat_ice( ijkmax, 1, ijkmax, &
3290  temp(:), pres(:), qdry(:), & ! [IN]
3291  qsati(:) ) ! [OUT]
3292 
3293  gciold(:) = 0.0_rp
3294  nloop(:) = 0
3295  do ijk = 1, ijkmax
3296 
3297  !----- old mass
3298  do myu = 2, nspc
3299  do n = 1, nbin
3300  gciold(ijk) = gciold(ijk) + gc( n,myu,ijk )*dxmic
3301  enddo
3302  enddo
3303 
3304  !----- mass -> number
3305  do myu = 2, nspc
3306  do n = 1, nbin
3307  gcn( n,myu,ijk ) = gc( n,myu,ijk ) * rexpxctr( n )
3308  gcrgn( n,myu,ijk ) = gcrg( n,myu,ijk )
3309  enddo
3310  gcn( -1,myu,ijk ) = 0.0_rp
3311  gcn( 0,myu,ijk ) = 0.0_rp
3312  gcn( nbin+1,myu,ijk ) = 0.0_rp
3313  gcn( nbin+2,myu,ijk ) = 0.0_rp
3314  gcrgn( -1,myu,ijk ) = 0.0_rp
3315  gcrgn( 0,myu,ijk ) = 0.0_rp
3316  gcrgn( nbin+1,myu,ijk ) = 0.0_rp
3317  gcrgn( nbin+2,myu,ijk ) = 0.0_rp
3318  enddo
3319 
3320  !--- supersaturation
3321  ssice = qvap(ijk)/qsati(ijk) - 1.0_rp
3322 
3323  emu = afmyu*( bfmyu/( temp(ijk)+cfmyu ) )*( temp(ijk)/tmlt )**1.50_rp
3324  cefd = emu/dens(ijk)
3325  cefk = fct*emu
3326  festi = esat0*exp( qlsbl(ijk)/rvap*( 1.0_rp/tem00 - 1.0_rp/temp(ijk) ) )
3327  f1 = rvap*temp(ijk)/festi/cefd
3328  f2 = qlsbl(ijk)/cefk/temp(ijk)*( qlsbl(ijk)/rvap/temp(ijk) - 1.0_rp )
3329  gtice(ijk) = 4.0_rp*pi/( f1+f2 )
3330  !----- CFL condition
3331  umax(ijk) = 0.0_rp
3332  do myu = 2, nspc
3333  uval = cbnd( 1,myu )*rexpxbnd( 1 )*gtice(ijk)*abs( ssice )
3334  umax(ijk) = max( umax(ijk),uval )
3335  enddo
3336 
3337  dtcnd(ijk) = cflfct*dxmic/umax(ijk)
3338  nloop(ijk) = int( dtime/dtcnd(ijk) ) + 1
3339  dtcnd(ijk) = dtime/nloop(ijk)
3340 
3341  nloop(ijk) = nloop(ijk) * maxval( iflg( 2:nspc,ijk ) ) !--- for determing trivial loop
3342 
3343  enddo
3344  nloopmax = maxval(nloop,1)
3345 
3346 !OCL LOOP_NOFISSION
3347 !OCL LOOP_NOINTERCHANGE
3348  do ncount = 1, nloopmax
3349 
3350  do ijk = 1, ijkmax
3351  loopflg(ijk) = min( 1, int(nloop(ijk)/ncount) ) ! 0 or 1
3352  enddo
3353 
3354  ! lhs
3355  call atmos_hydrometeor_lhs( ijkmax, 1, ijkmax, temp(:), qlsbl(:) )
3356 
3357 !OCL LOOP_NOFUSION
3358  do ijk = 1, ijkmax
3359  do nn = 1, loopflg(ijk)
3360  emu = afmyu*( bfmyu/( temp(ijk)+cfmyu ) )*( temp(ijk)/tmlt )**1.50_rp
3361  cefd = emu/dens(ijk)
3362  cefk = fct*emu
3363  festi = esat0*exp( qlsbl(ijk)/rvap*( 1.0_rp/tem00 - 1.0_rp/temp(ijk) ) )
3364  f1 = rvap*temp(ijk)/festi/cefd
3365  f2 = qlsbl(ijk)/cefk/temp(ijk)*( qlsbl(ijk)/rvap/temp(ijk) - 1.0_rp )
3366  gtice(ijk) = 4.0_rp*pi/( f1+f2 ) ! G of (A.17) of Suzuki (2004)
3367 
3368  sumice(ijk) = 0.0_rp
3369  do myu = 2, nspc
3370  do n = 1, nbin
3371  sumice(ijk) = sumice(ijk) + gcn( n,myu,ijk )*cctr( n,myu )*dxmic
3372  enddo
3373  enddo
3374 
3375  enddo
3376  enddo
3377 
3378 
3379  call atmos_saturation_pres2qsat_ice( ijkmax, 1, ijkmax, &
3380  temp(:), pres(:), qdry(:), & ! [IN]
3381  qsati(:) ) ! [OUT]
3382 
3383 !OCL LOOP_NOFUSION
3384  do ijk = 1, ijkmax
3385  do nn = 1, loopflg(ijk)
3386 
3387  !--- supersaturation
3388  ssice = qvap(ijk)/qsati(ijk) - 1.0_rp
3389 
3390  !----- supersaturation tendency
3391  zerosw = 0.5_rp + sign( 0.5_rp,qvap(ijk)-eps ) !--- zerosw = 1 (qv>0), zerosw=0 (qv=0)
3392  qvtmp = qvap(ijk) * zerosw + ( qvap(ijk)+eps ) * ( 1.0_rp-zerosw )
3393 
3394  cefice = ( ssice+1.0_rp )*( 1.0_rp/qvtmp + qlsbl(ijk)*qlsbl(ijk)/cv(ijk)/rvap/temp(ijk)/temp(ijk) )
3395  d = - cefice*sumice(ijk)*gtice(ijk)/dens(ijk) ! d of (A.19) of Suzuki (2004)
3396  d = d + eps * ( 1.0_rp - zerosw ) !--- avoiding division by zero when qv = 0
3397 
3398  sicetnd = zerosw * &
3399  ( ssice * ( exp( d*dtcnd(ijk) )-1.0_rp )/( d*dtcnd(ijk) ) &
3400  * ( 0.5_rp + sign( 0.5_rp,abs(d*dtcnd(ijk)-0.1_rp) ) ) &
3401  + ssice &
3402  * ( 0.5_rp - sign( 0.5_rp,abs(d*dtcnd(ijk)-0.1_rp) ) ) &
3403  ) &
3404  + ssice * ( 1.0_rp - zerosw )
3405  !
3406  !----- change of SDF
3407  do myu = 2, nspc
3408  do mm = 1, iflg( myu,ijk )
3409  !--- advection speed
3410  do n = 1, nbin+1
3411  uadv( n,myu,ijk ) = cbnd( n,myu )*rexpxbnd( n )*gtice(ijk)*sicetnd ! U of eq. (A.18) of Suzuki (2004)
3412  enddo
3413  uadv( 0, myu,ijk ) = 0.0_rp
3414  uadv( nbin+2,myu,ijk ) = 0.0_rp
3415  enddo
3416  enddo
3417 
3418  enddo
3419  enddo
3420 
3421  call prof_rapstart('_SBM_AdvIce', 3)
3422 
3423  do ijk = 1, ijkmax
3424  do nn = 1, loopflg(ijk)
3425  do myu = 2, nspc
3426  do mm = 1, iflg( myu,ijk )
3427  do n = 0, nbin+2
3428  crn( n,myu,ijk ) = uadv( n,myu,ijk )*dtcnd(ijk)/dxmic
3429  enddo
3430  enddo
3431  enddo
3432  enddo
3433  enddo
3434 
3435  do ijk = 1, ijkmax
3436  do nn = 1, loopflg(ijk)
3437  do myu = 2, nspc
3438  do mm = 1, iflg( myu,ijk )
3439  do n = 0, nbin+1
3440  acoef(0,n,myu,ijk) = - ( gcn( n+1,myu,ijk )-26.0_rp*gcn( n,myu,ijk )+gcn( n-1,myu,ijk ) ) / 48.0_rp
3441  acoef(1,n,myu,ijk) = ( gcn( n+1,myu,ijk ) -gcn( n-1,myu,ijk ) ) / 16.0_rp
3442  acoef(2,n,myu,ijk) = ( gcn( n+1,myu,ijk )- 2.0_rp*gcn( n,myu,ijk )+gcn( n-1,myu,ijk ) ) / 48.0_rp
3443  acoef_c(0,n,myu,ijk) = - ( gcrgn( n+1,myu,ijk )-26.0_rp*gcrgn( n,myu,ijk )+gcrgn( n-1,myu,ijk ) ) / 48.0_rp
3444  acoef_c(1,n,myu,ijk) = ( gcrgn( n+1,myu,ijk ) -gcrgn( n-1,myu,ijk ) ) / 16.0_rp
3445  acoef_c(2,n,myu,ijk) = ( gcrgn( n+1,myu,ijk )- 2.0_rp*gcrgn( n,myu,ijk )+gcrgn( n-1,myu,ijk ) ) / 48.0_rp
3446  enddo
3447  enddo
3448  enddo
3449  enddo
3450  enddo
3451 
3452  do ijk = 1, ijkmax
3453  do nn = 1, loopflg(ijk)
3454  do myu = 2, nspc
3455  do mm = 1, iflg( myu,ijk )
3456  do n = 0, nbin+1
3457  cplus = 1.0_rp - ( crn(n+1,myu,ijk) + abs(crn(n+1,myu,ijk)) )
3458 
3459  aip(n,myu,ijk) = acoef(0,n,myu,ijk) * ( 1.0_rp-cplus**1 ) &
3460  + acoef(1,n,myu,ijk) * ( 1.0_rp-cplus**2 ) &
3461  + acoef(2,n,myu,ijk) * ( 1.0_rp-cplus**3 )
3462 
3463  aip(n,myu,ijk) = max( aip(n,myu,ijk), 0.0_rp )
3464 
3465  aip_c(n,myu,ijk) = acoef_c(0,n,myu,ijk) * ( 1.0_rp-cplus**1 ) &
3466  + acoef_c(1,n,myu,ijk) * ( 1.0_rp-cplus**2 ) &
3467  + acoef_c(2,n,myu,ijk) * ( 1.0_rp-cplus**3 )
3468 
3469  aip_c(n,myu,ijk) = max( aip_c(n,myu,ijk), 0.0_rp )
3470  enddo
3471  enddo
3472  enddo
3473  enddo
3474  enddo
3475 
3476  do ijk = 1, ijkmax
3477  do nn = 1, loopflg(ijk)
3478  do myu = 2, nspc
3479  do mm = 1, iflg( myu,ijk )
3480  do n = 0, nbin+1
3481  cmins = 1.0_rp - ( abs(crn(n,myu,ijk)) - crn(n,myu,ijk) )
3482 
3483  aim(n,myu,ijk) = acoef(0,n,myu,ijk) * ( 1.0_rp-cmins**1 ) &
3484  - acoef(1,n,myu,ijk) * ( 1.0_rp-cmins**2 ) &
3485  + acoef(2,n,myu,ijk) * ( 1.0_rp-cmins**3 )
3486 
3487  aim(n,myu,ijk) = max( aim(n,myu,ijk), 0.0_rp )
3488 
3489  aim_c(n,myu,ijk) = acoef_c(0,n,myu,ijk) * ( 1.0_rp-cmins**1 ) &
3490  - acoef_c(1,n,myu,ijk) * ( 1.0_rp-cmins**2 ) &
3491  + acoef_c(2,n,myu,ijk) * ( 1.0_rp-cmins**3 )
3492 
3493  aim_c(n,myu,ijk) = max( aim_c(n,myu,ijk), 0.0_rp )
3494  enddo
3495  enddo
3496  enddo
3497  enddo
3498  enddo
3499 
3500  do ijk = 1, ijkmax
3501  do nn = 1, loopflg(ijk)
3502  do myu = 2, nspc
3503  do mm = 1, iflg( myu,ijk )
3504  do n = 0, nbin+1
3505  ai(n,myu,ijk) = acoef(0,n,myu,ijk) * 2.0_rp &
3506  + acoef(2,n,myu,ijk) * 2.0_rp
3507 
3508  ai(n,myu,ijk) = max( ai(n,myu,ijk), aip(n,myu,ijk)+aim(n,myu,ijk)+cldmin )
3509 
3510  ai_c(n,myu,ijk) = acoef_c(0,n,myu,ijk) * 2.0_rp &
3511  + acoef_c(2,n,myu,ijk) * 2.0_rp
3512 
3513  ai_c(n,myu,ijk) = max( ai_c(n,myu,ijk), aip_c(n,myu,ijk)+aim_c(n,myu,ijk)+cldmin )
3514  enddo
3515  enddo
3516  enddo
3517  enddo
3518  enddo
3519 
3520  do ijk = 1, ijkmax
3521  do nn = 1, loopflg(ijk)
3522  do myu = 2, nspc
3523  do mm = 1, iflg( myu,ijk )
3524  do n = 1, nbin+1
3525  flq(n,myu,ijk) = ( aip(n-1,myu,ijk)/ai(n-1,myu,ijk)*gcn( n-1,myu,ijk ) &
3526  - aim(n ,myu,ijk)/ai(n ,myu,ijk)*gcn( n ,myu,ijk ) )*dxmic/dtcnd(ijk)
3527 
3528  flq_c(n,myu,ijk) = ( aip_c(n-1,myu,ijk)/ai_c(n-1,myu,ijk)*gcrgn( n-1,myu,ijk ) &
3529  - aim_c(n ,myu,ijk)/ai_c(n ,myu,ijk)*gcrgn( n ,myu,ijk ) )/dtcnd(ijk)
3530  enddo
3531  enddo
3532  enddo
3533  enddo
3534  enddo
3535 
3536  do ijk = 1, ijkmax
3537  do nn = 1, loopflg(ijk)
3538  do myu = 2, nspc
3539  do mm = 1, iflg( myu,ijk )
3540  dumm_regene(ijk) = dumm_regene(ijk)+( -flq(1,myu,ijk)*dtcnd(ijk)/dxmic ) &
3541  * min( uadv(1,myu,ijk),0.0_rp )/( uadv(1,myu,ijk) + eps )
3542  enddo
3543  enddo
3544  enddo
3545  enddo
3546 
3547  do ijk = 1, ijkmax
3548  do nn = 1, loopflg(ijk)
3549  do myu = 2, nspc
3550  do mm = 1, iflg( myu,ijk )
3551  do n = 1, nbin
3552  gcn( n,myu,ijk ) = gcn( n,myu,ijk ) - ( flq(n+1,myu,ijk)-flq(n,myu,ijk) )*dtcnd(ijk)/dxmic
3553  gcrgn( n,myu,ijk ) = gcrgn( n,myu,ijk ) - ( flq_c(n+1,myu,ijk)-flq_c(n,myu,ijk) )*dtcnd(ijk)
3554  enddo
3555  enddo
3556  enddo
3557  enddo
3558  enddo
3559 
3560  call prof_rapend ('_SBM_AdvIce', 3)
3561 
3562 !OCL LOOP_NOFUSION
3563  do ijk = 1, ijkmax
3564  do nn = 1, loopflg(ijk)
3565 
3566  !----- new mass
3567  gcinew(ijk) = 0.0_rp
3568  do n = 1, nbin
3569  do myu = 2, nspc
3570  gcinew(ijk) = gcinew(ijk) + gcn( n,myu,ijk )*expxctr( n )*dxmic
3571  enddo
3572  enddo
3573  !
3574  !----- change of humidity and temperature
3575  sblmss = gcinew(ijk) - gciold(ijk)
3576  dqv = sblmss/dens(ijk)
3577  qvap(ijk) = qvap(ijk) - dqv
3578  temp(ijk) = temp(ijk) + dqv*qlsbl(ijk)/cv(ijk)
3579  cp(ijk) = cp(ijk) + ( cp_ice - cp_vapor ) * dqv
3580  cv(ijk) = cv(ijk) + ( cv_ice - cv_vapor ) * dqv
3581 
3582  gciold(ijk) = gcinew(ijk)
3583  !
3584  !----- continue / end
3585  enddo
3586  enddo
3587 
3588  enddo ! nloop
3589  !
3590 !OCL NORECURRENCE(gc)
3591  do ijk = 1, ijkmax
3592  !------- number -> mass
3593  do myu = 2, nspc
3594  do n = 1, nbin
3595  gc( n,myu,ijk ) = gcn( n,myu,ijk )*expxctr( n )
3596  gcrg( n,myu,ijk ) = gcrgn( n,myu,ijk )
3597  enddo
3598  enddo
3599  enddo
3600 
3601  call prof_rapend ('_SBM_Icephase', 3)
3602 
3603  return
3604  end subroutine icephase
3605 
3606  !-----------------------------------------------------------------------------
3607  subroutine mixphase( &
3608  ijkmax, &
3609  dens, &
3610  pres, &
3611  qdry, &
3612  temp, &
3613  qvap, &
3614  gc, &
3615  gcrg, &
3616  cp, &
3617  cv, &
3618  dtime )
3619  use scale_const, only: &
3620  pi => const_pi, &
3621  eps => const_eps, &
3622  esat0 => const_psat0, &
3623  tem00 => const_tem00, &
3624  rvap => const_rvap, &
3625  tmlt => const_tmelt
3626  use scale_atmos_hydrometeor, only: &
3627  atmos_hydrometeor_lhv, &
3628  atmos_hydrometeor_lhs, &
3629  cp_vapor, &
3630  cp_water, &
3631  cp_ice, &
3632  cv_vapor, &
3633  cv_water, &
3634  cv_ice
3635  use scale_atmos_saturation, only: &
3636  atmos_saturation_pres2qsat_liq, &
3637  atmos_saturation_pres2qsat_ice
3638  implicit none
3639 
3640  integer, intent(in) :: ijkmax
3641  real(rp), intent(in) :: dens(ijkmax) ! Density [kg/m3]
3642  real(rp), intent(in) :: pres(ijkmax) ! Pressure [Pa]
3643  real(rp), intent(in) :: qdry(ijkmax) ! dry air mass ratio [kg/kg]
3644  real(rp), intent(inout) :: temp(ijkmax) ! Temperature [K]
3645  real(rp), intent(inout) :: qvap(ijkmax) ! Specific humidity [kg/kg]
3646  real(rp), intent(inout) :: gc (nbin,nspc,ijkmax) ! Mass size distribution function of hydrometeor
3647  real(rp), intent(inout) :: gcrg(nbin,nspc,ijkmax)
3648  real(rp), intent(inout) :: cp(ijkmax) ! specific heat
3649  real(rp), intent(inout) :: cv(ijkmax) ! specific heat
3650  real(dp), intent(in) :: dtime ! Time step interval
3651 
3652  integer :: n, myu, mm, ncount
3653  integer :: nloop(ijkmax)
3654  real(rp) :: gclold(ijkmax), gclnew(ijkmax)
3655  real(rp) :: gciold(ijkmax), gcinew(ijkmax)
3656  real(rp) :: cndmss, sblmss
3657  real(rp) :: gtliq(ijkmax), gtice(ijkmax)
3658  real(rp) :: umax(ijkmax), uval, dtcnd(ijkmax)
3659  real(rp) :: qlevp(ijkmax), qlsbl(ijkmax)
3660  real(rp) :: cef1, cef2, cef3, cef4, a, b, c, d
3661  real(rp) :: rmdplus, rmdmins, ssplus, ssmins, tplus, tmins
3662  real(rp) :: sliqtnd, sicetnd
3663  real(rp) :: ssliq, ssice
3664  real(rp) :: sumliq(ijkmax), sumice(ijkmax)
3665  real(rp) :: gcn( -1:nbin+2,nspc,ijkmax )
3666  real(rp), parameter :: cflfct = 0.50_rp
3667  real(rp) :: dumm_regene(ijkmax)
3668  real(rp) :: csum( nspc,ijkmax )
3669  integer :: iflg( nspc,ijkmax )
3670  real(rp) :: f1, f2, emu, cefd, cefk, festl, festi
3671  real(rp) :: qsatl(ijkmax), qsati(ijkmax)
3672  real(rp), parameter :: afmyu = 1.72e-05_rp, bfmyu = 3.93e+2_rp
3673  real(rp), parameter :: cfmyu = 1.2e+02_rp, fct = 1.4e+3_rp
3674  real(rp) :: qvtmp, zerosw
3675  integer :: ijk, nn, loopflg(ijkmax)
3676 
3677  !--- local for advection
3678 ! real(RP) :: qadv( -1:nbin+2 ), uadv( 0:nbin+2 )
3679  real(rp) :: uadv ( 0:nbin+2,nspc,ijkmax )
3680  real(rp) :: flq ( 1:nbin+1,nspc,ijkmax )
3681  real(rp) :: acoef( 0:2,0:nbin+1,nspc,ijkmax )
3682  real(rp) :: crn ( 0:nbin+2,nspc,ijkmax )
3683  real(rp) :: aip ( 0:nbin+1,nspc,ijkmax )
3684  real(rp) :: aim ( 0:nbin+1,nspc,ijkmax )
3685  real(rp) :: ai ( 0:nbin+1,nspc,ijkmax )
3686  real(rp) :: cmins, cplus
3687  integer :: nloopmax
3688 
3689  !--- for lithgning component (if not use lightning component, arrays shown below work dummy array)
3690  real(rp) :: gcrgn( -1:nbin+2,nspc,ijkmax )
3691  real(rp) :: flq_c( 1:nbin+1,nspc,ijkmax )
3692  real(rp) :: acoef_c( 0:2,0:nbin+1,nspc,ijkmax )
3693  real(rp) :: aip_c ( 0:nbin+1,nspc,ijkmax )
3694  real(rp) :: aim_c ( 0:nbin+1,nspc,ijkmax )
3695  real(rp) :: ai_c ( 0:nbin+1,nspc,ijkmax )
3696 
3697  call prof_rapstart('_SBM_Mixphase', 3)
3698 
3699  dumm_regene( : ) = 0.0_rp
3700  iflg( :,: ) = 0
3701  csum( :,: ) = 0.0_rp
3702  do ijk = 1, ijkmax
3703 
3704  do myu = 1, nspc
3705  do n = 1, nbin
3706  csum( myu,ijk ) = csum( myu,ijk )+gc( n,myu,ijk )*dxmic
3707  enddo
3708  enddo
3709 
3710  do myu = 1, nspc
3711  if ( csum( myu,ijk ) > cldmin ) iflg( myu,ijk ) = 1
3712  enddo
3713 
3714  enddo
3715 
3716  ! lhv
3717  call atmos_hydrometeor_lhv( ijkmax, 1, ijkmax, temp(:), qlevp(:) )
3718  ! lhs
3719  call atmos_hydrometeor_lhs( ijkmax, 1, ijkmax, temp(:), qlsbl(:) )
3720 
3721  call atmos_saturation_pres2qsat_liq( ijkmax, 1, ijkmax, &
3722  temp(:), pres(:), qdry(:), & ! [IN]
3723  qsatl(:) ) ! [OUT]
3724  call atmos_saturation_pres2qsat_ice( ijkmax, 1, ijkmax, &
3725  temp(:), pres(:), qdry(:), & ! [IN]
3726  qsati(:) ) ! [OUT]
3727 
3728  gclold(:) = 0.0_rp
3729  gciold(:) = 0.0_rp
3730  nloop(:) = 0
3731  do ijk = 1, ijkmax
3732  !----- old mass
3733  do n = 1, nbin
3734  gclold(ijk) = gclold(ijk) + gc( n,il,ijk )*dxmic
3735  enddo
3736 
3737  do myu = 2, nspc
3738  do n = 1, nbin
3739  gciold(ijk) = gciold(ijk) + gc( n,myu,ijk )*dxmic
3740  enddo
3741  enddo
3742 
3743  !----- mass -> number
3744  do myu = 1, nspc
3745  do n = 1, nbin
3746  gcn( n,myu,ijk ) = gc( n,myu,ijk ) * rexpxctr( n )
3747  gcrgn( n,myu,ijk ) = gcrg( n,myu,ijk )
3748  enddo
3749  gcn( -1,myu,ijk ) = 0.0_rp
3750  gcn( 0,myu,ijk ) = 0.0_rp
3751  gcn( nbin+1,myu,ijk ) = 0.0_rp
3752  gcn( nbin+2,myu,ijk ) = 0.0_rp
3753  gcrgn( -1,myu,ijk ) = 0.0_rp
3754  gcrgn( 0,myu,ijk ) = 0.0_rp
3755  gcrgn( nbin+1,myu,ijk ) = 0.0_rp
3756  gcrgn( nbin+2,myu,ijk ) = 0.0_rp
3757  enddo
3758 
3759  !-- supersaturation
3760  ssliq = qvap(ijk)/qsatl(ijk) - 1.0_rp
3761  ssice = qvap(ijk)/qsati(ijk) - 1.0_rp
3762 
3763  emu = afmyu*( bfmyu/( temp(ijk)+cfmyu ) )*( temp(ijk)/tmlt )**1.50_rp
3764  cefd = emu/dens(ijk)
3765  cefk = fct*emu
3766 
3767  festl = esat0*exp( qlevp(ijk)/rvap*( 1.0_rp/tem00 - 1.0_rp/temp(ijk) ) )
3768  f1 = rvap*temp(ijk)/festl/cefd
3769  f2 = qlevp(ijk)/cefk/temp(ijk)*( qlevp(ijk)/rvap/temp(ijk) - 1.0_rp )
3770  gtliq(ijk) = 4.0_rp*pi/( f1+f2 )
3771 
3772  festi = esat0*exp( qlsbl(ijk)/rvap*( 1.0_rp/tem00 - 1.0_rp/temp(ijk) ) )
3773  f1 = rvap*temp(ijk)/festi/cefd
3774  f2 = qlsbl(ijk)/cefk/temp(ijk)*( qlsbl(ijk)/rvap/temp(ijk) - 1.0_rp )
3775  gtice(ijk) = 4.0_rp*pi/( f1+f2 )
3776 
3777  !----- CFL condition
3778  umax(ijk) = cbnd( 1,il )*rexpxbnd( 1 )*gtliq(ijk)*abs( ssliq )
3779  do myu = 2, nspc
3780  uval = cbnd( 1,myu )*rexpxbnd( 1 )*gtice(ijk)*abs( ssice )
3781  umax(ijk) = max( umax(ijk),uval )
3782  enddo
3783 
3784  dtcnd(ijk) = cflfct*dxmic/umax(ijk)
3785  nloop(ijk) = int( dtime/dtcnd(ijk) ) + 1
3786  dtcnd(ijk) = dtime/nloop(ijk)
3787 
3788  nloop(ijk) = nloop(ijk) * iflg( il,ijk ) !--- for determing trivial loop
3789  nloop(ijk) = nloop(ijk) * maxval( iflg( 2:nspc,ijk ) ) !--- for determing trivial loop
3790 ! nloop(ijk) = nloop(ijk) * maxval( iflg( 1:nspc,ijk ) ) !--- for determing trivial loop
3791  enddo
3792  nloopmax = maxval(nloop,1)
3793 
3794 
3795 !OCL LOOP_NOFISSION
3796 !OCL LOOP_NOINTERCHANGE
3797  do ncount = 1, nloopmax
3798 
3799  do ijk = 1, ijkmax
3800  loopflg(ijk) = min( 1, int(nloop(ijk)/ncount) ) ! 0 or 1
3801  enddo
3802 
3803 !OCL LOOP_NOFUSION
3804  do ijk = 1, ijkmax
3805  do nn = 1, loopflg(ijk)
3806 
3807  ! lhv
3808  call atmos_hydrometeor_lhv( ijkmax, 1, ijkmax, temp(:), qlevp(:) )
3809  ! lhs
3810  call atmos_hydrometeor_lhs( ijkmax, 1, ijkmax, temp(:), qlsbl(:) )
3811 
3812  !-- matrix for supersaturation tendency
3813  emu = afmyu*( bfmyu/( temp(ijk)+cfmyu ) )*( temp(ijk)/tmlt )**1.50_rp
3814  cefd = emu/dens(ijk)
3815  cefk = fct*emu
3816  festl = esat0*exp( qlevp(ijk)/rvap*( 1.0_rp/tem00 - 1.0_rp/temp(ijk) ) )
3817  f1 = rvap*temp(ijk)/festl/cefd
3818  f2 = qlevp(ijk)/cefk/temp(ijk)*( qlevp(ijk)/rvap/temp(ijk) - 1.0_rp )
3819  gtliq(ijk) = 4.0_rp*pi/( f1+f2 )
3820  festi = esat0*exp( qlsbl(ijk)/rvap*( 1.0_rp/tem00 - 1.0_rp/temp(ijk) ) )
3821  f1 = rvap*temp(ijk)/festi/cefd
3822  f2 = qlsbl(ijk)/cefk/temp(ijk)*( qlsbl(ijk)/rvap/temp(ijk) - 1.0_rp )
3823  gtice(ijk) = 4.0_rp*pi/( f1+f2 )
3824 
3825  sumliq(ijk) = 0.0_rp
3826  do n = 1, nbin
3827  sumliq(ijk) = sumliq(ijk) + gcn( n,il,ijk )*cctr( n,il )*dxmic
3828  enddo
3829 
3830  sumice(ijk) = 0.0_rp
3831  do myu = 2, nspc
3832  do n = 1, nbin
3833  sumice(ijk) = sumice(ijk) + gcn( n,myu,ijk )*cctr( n,myu )*dxmic
3834  enddo
3835  enddo
3836  enddo
3837  enddo
3838 
3839 
3840  call atmos_saturation_pres2qsat_liq( ijkmax, 1, ijkmax, &
3841  temp(:), pres(:), qdry(:), & ! [IN]
3842  qsatl(:) ) ! [OUT]
3843  call atmos_saturation_pres2qsat_ice( ijkmax, 1, ijkmax, &
3844  temp(:), pres(:), qdry(:), & ! [IN]
3845  qsati(:) ) ! [OUT]
3846 !OCL LOOP_NOFUSION
3847  do ijk = 1, ijkmax
3848  do nn = 1, loopflg(ijk)
3849 
3850  !-- supersaturation
3851  ssliq = qvap(ijk)/qsatl(ijk) - 1.0_rp
3852  ssice = qvap(ijk)/qsati(ijk) - 1.0_rp
3853 
3854  zerosw = 0.5_rp + sign( 0.5_rp,qvap(ijk)-eps ) !--- zerosw = 1 (qv>0), zerosw=0 (qv=0)
3855  qvtmp = qvap(ijk) * zerosw + ( qvap(ijk)+eps ) * ( 1.0_rp-zerosw )
3856  cef1 = ( ssliq+1.0_rp )*( 1.0_rp/qvtmp + qlevp(ijk)/rvap/temp(ijk)/temp(ijk)*qlevp(ijk)/cv(ijk) )
3857  cef2 = ( ssliq+1.0_rp )*( 1.0_rp/qvtmp + qlevp(ijk)/rvap/temp(ijk)/temp(ijk)*qlsbl(ijk)/cv(ijk) )
3858  cef3 = ( ssice+1.0_rp )*( 1.0_rp/qvtmp + qlsbl(ijk)/rvap/temp(ijk)/temp(ijk)*qlevp(ijk)/cv(ijk) )
3859  cef4 = ( ssice+1.0_rp )*( 1.0_rp/qvtmp + qlsbl(ijk)/rvap/temp(ijk)/temp(ijk)*qlsbl(ijk)/cv(ijk) )
3860 
3861  a = - cef1*sumliq(ijk)*gtliq(ijk)/dens(ijk) ! a of (A.19) of Suzuki (2004)
3862  b = - cef2*sumice(ijk)*gtice(ijk)/dens(ijk) ! b of (A.19) of Suzuki (2004)
3863  c = - cef3*sumliq(ijk)*gtliq(ijk)/dens(ijk) ! c of (A.19) of Suzuki (2004)
3864  d = - cef4*sumice(ijk)*gtice(ijk)/dens(ijk) ! d of (A.19) of Suzuki (2004)
3865 
3866  b = b + eps * ( 1.0_rp - zerosw ) !--- avoiding division by zero when qv = 0
3867  !--- eigenvalues
3868  rmdplus = ( ( a+d ) + sqrt( ( a-d )**2 + 4.0_rp*b*c ) ) * 0.50_rp
3869  rmdmins = ( ( a+d ) - sqrt( ( a-d )**2 + 4.0_rp*b*c ) ) * 0.50_rp
3870 
3871  rmdplus = rmdplus + eps * ( 1.0_rp - zerosw ) !--- avoiding division by zero when qv = 0
3872  rmdmins = rmdmins + eps * ( 1.0_rp - zerosw ) !--- avoiding division by zero when qv = 0
3873 
3874  !--- supersaturation tendency
3875  ssplus = ( ( rmdmins-a )*ssliq - b*ssice )/b/( rmdmins-rmdplus + eps * ( 1.0_rp - zerosw ) )
3876  ssmins = ( ( a-rmdplus )*ssliq + b*ssice )/b/( rmdmins-rmdplus + eps * ( 1.0_rp - zerosw ) )
3877 
3878  tplus = ( exp( rmdplus*dtcnd(ijk) )-1.0_rp )/( rmdplus*dtcnd(ijk) ) &
3879  * ( 0.5_rp + sign( 0.5_rp,abs(rmdplus*dtcnd(ijk)-0.1_rp) ) ) &
3880  + 1.0_rp &
3881  * ( 0.5_rp - sign( 0.5_rp,abs(rmdplus*dtcnd(ijk)-0.1_rp) ) )
3882  tmins = ( exp( rmdmins*dtcnd(ijk) )-1.0_rp )/( rmdmins*dtcnd(ijk) ) &
3883  * ( 0.5_rp + sign( 0.5_rp,abs(rmdmins*dtcnd(ijk)-0.1_rp) ) ) &
3884  + 1.0_rp &
3885  * ( 0.5_rp - sign( 0.5_rp,abs(rmdmins*dtcnd(ijk)-0.1_rp) ) )
3886 
3887  sliqtnd = ssliq * ( 1.0_rp - zerosw ) &
3888  + zerosw * &
3889  ( b*tplus*ssplus + b*tmins*ssmins ) ! sliwtnd in page 116 of Suzuki (2004)
3890  sicetnd = ssice * ( 1.0_rp - zerosw ) &
3891  + zerosw * &
3892  ( ( rmdplus-a )*tplus*ssplus & ! sicetnd in page 116 of Suzuki (2004)
3893  + ( rmdmins-a )*tmins*ssmins )
3894 
3895  !--- change of SDF
3896  do myu = 1, nspc
3897  do mm = 1, iflg( myu,ijk )
3898  !--- advection speed
3899  do n = 1, nbin+1
3900  !--- myu = 1 -> ssliq, myu > 1 -> ssice
3901  uadv( n,myu,ijk ) = cbnd( n,myu )*rexpxbnd( n )*gtliq(ijk)*sliqtnd & ! U of eq. (A.18) of Suzuki (2004)
3902  * ( 0.5_rp - sign( 0.5_rp,real(myu)-1.5_rp) ) &
3903  + cbnd( n,myu )*rexpxbnd( n )*gtice(ijk)*sicetnd & ! U of eq. (A.18) of Suzuki (2004)
3904  * ( 0.5_rp + sign( 0.5_rp,real(myu)-1.5_rp) )
3905  enddo
3906  uadv( 0, myu,ijk ) = 0.0_rp
3907  uadv( nbin+2,myu,ijk ) = 0.0_rp
3908  enddo
3909  enddo
3910  enddo
3911  enddo
3912 
3913  call prof_rapstart('_SBM_AdvMix', 3)
3914 
3915  do ijk = 1, ijkmax
3916  do nn = 1, loopflg(ijk)
3917  do myu = 1, nspc
3918  do mm = 1, iflg( myu,ijk )
3919  do n = 0, nbin+2
3920  crn( n,myu,ijk ) = uadv( n,myu,ijk )*dtcnd(ijk)/dxmic
3921  enddo
3922  enddo
3923  enddo
3924  enddo
3925  enddo
3926 
3927  do ijk = 1, ijkmax
3928  do nn = 1, loopflg(ijk)
3929  do myu = 1, nspc
3930  do mm = 1, iflg( myu,ijk )
3931  do n = 0, nbin+1
3932  acoef(0,n,myu,ijk) = - ( gcn( n+1,myu,ijk )-26.0_rp*gcn( n,myu,ijk )+gcn( n-1,myu,ijk ) ) / 48.0_rp
3933  acoef(1,n,myu,ijk) = ( gcn( n+1,myu,ijk ) -gcn( n-1,myu,ijk ) ) / 16.0_rp
3934  acoef(2,n,myu,ijk) = ( gcn( n+1,myu,ijk )- 2.0_rp*gcn( n,myu,ijk )+gcn( n-1,myu,ijk ) ) / 48.0_rp
3935 
3936  acoef_c(0,n,myu,ijk) = - ( gcrgn( n+1,myu,ijk )-26.0_rp*gcrgn( n,myu,ijk )+gcrgn( n-1,myu,ijk ) ) / 48.0_rp
3937  acoef_c(1,n,myu,ijk) = ( gcrgn( n+1,myu,ijk ) -gcrgn( n-1,myu,ijk ) ) / 16.0_rp
3938  acoef_c(2,n,myu,ijk) = ( gcrgn( n+1,myu,ijk )- 2.0_rp*gcrgn( n,myu,ijk )+gcrgn( n-1,myu,ijk ) ) / 48.0_rp
3939  enddo
3940  enddo
3941  enddo
3942  enddo
3943  enddo
3944 
3945  do ijk = 1, ijkmax
3946  do nn = 1, loopflg(ijk)
3947  do myu = 1, nspc
3948  do mm = 1, iflg( myu,ijk )
3949  do n = 0, nbin+1
3950  cplus = 1.0_rp - ( crn(n+1,myu,ijk) + abs(crn(n+1,myu,ijk)) )
3951 
3952  aip(n,myu,ijk) = acoef(0,n,myu,ijk) * ( 1.0_rp-cplus**1 ) &
3953  + acoef(1,n,myu,ijk) * ( 1.0_rp-cplus**2 ) &
3954  + acoef(2,n,myu,ijk) * ( 1.0_rp-cplus**3 )
3955 
3956  aip(n,myu,ijk) = max( aip(n,myu,ijk), 0.0_rp )
3957 
3958  aip_c(n,myu,ijk) = acoef_c(0,n,myu,ijk) * ( 1.0_rp-cplus**1 ) &
3959  + acoef_c(1,n,myu,ijk) * ( 1.0_rp-cplus**2 ) &
3960  + acoef_c(2,n,myu,ijk) * ( 1.0_rp-cplus**3 )
3961 
3962  aip_c(n,myu,ijk) = max( aip_c(n,myu,ijk), 0.0_rp )
3963  enddo
3964  enddo
3965  enddo
3966  enddo
3967  enddo
3968 
3969  do ijk = 1, ijkmax
3970  do nn = 1, loopflg(ijk)
3971  do myu = 1, nspc
3972  do mm = 1, iflg( myu,ijk )
3973  do n = 0, nbin+1
3974  cmins = 1.0_rp - ( abs(crn(n,myu,ijk)) - crn(n,myu,ijk) )
3975 
3976  aim(n,myu,ijk) = acoef(0,n,myu,ijk) * ( 1.0_rp-cmins**1 ) &
3977  - acoef(1,n,myu,ijk) * ( 1.0_rp-cmins**2 ) &
3978  + acoef(2,n,myu,ijk) * ( 1.0_rp-cmins**3 )
3979 
3980  aim(n,myu,ijk) = max( aim(n,myu,ijk), 0.0_rp )
3981 
3982  aim_c(n,myu,ijk) = acoef_c(0,n,myu,ijk) * ( 1.0_rp-cmins**1 ) &
3983  - acoef_c(1,n,myu,ijk) * ( 1.0_rp-cmins**2 ) &
3984  + acoef_c(2,n,myu,ijk) * ( 1.0_rp-cmins**3 )
3985 
3986  aim_c(n,myu,ijk) = max( aim_c(n,myu,ijk), 0.0_rp )
3987  enddo
3988  enddo
3989  enddo
3990  enddo
3991  enddo
3992 
3993  do ijk = 1, ijkmax
3994  do nn = 1, loopflg(ijk)
3995  do myu = 1, nspc
3996  do mm = 1, iflg( myu,ijk )
3997  do n = 0, nbin+1
3998  ai(n,myu,ijk) = acoef(0,n,myu,ijk) * 2.0_rp &
3999  + acoef(2,n,myu,ijk) * 2.0_rp
4000 
4001  ai(n,myu,ijk) = max( ai(n,myu,ijk), aip(n,myu,ijk)+aim(n,myu,ijk)+cldmin )
4002 
4003  ai_c(n,myu,ijk) = acoef_c(0,n,myu,ijk) * 2.0_rp &
4004  + acoef_c(2,n,myu,ijk) * 2.0_rp
4005 
4006  ai_c(n,myu,ijk) = max( ai_c(n,myu,ijk), aip_c(n,myu,ijk)+aim_c(n,myu,ijk)+cldmin )
4007  enddo
4008  enddo
4009  enddo
4010  enddo
4011  enddo
4012 
4013  do ijk = 1, ijkmax
4014  do nn = 1, loopflg(ijk)
4015  do myu = 1, nspc
4016  do mm = 1, iflg( myu,ijk )
4017  do n = 1, nbin+1
4018  flq(n,myu,ijk) = ( aip(n-1,myu,ijk)/ai(n-1,myu,ijk)*gcn( n-1,myu,ijk ) &
4019  - aim(n ,myu,ijk)/ai(n ,myu,ijk)*gcn( n ,myu,ijk ) )*dxmic/dtcnd(ijk)
4020 
4021  flq_c(n,myu,ijk) = ( aip_c(n-1,myu,ijk)/ai_c(n-1,myu,ijk)*gcrgn( n-1,myu,ijk ) &
4022  - aim_c(n ,myu,ijk)/ai_c(n ,myu,ijk)*gcrgn( n ,myu,ijk ) )/dtcnd(ijk)
4023  enddo
4024  enddo
4025  enddo
4026  enddo
4027  enddo
4028 
4029  do ijk = 1, ijkmax
4030  do nn = 1, loopflg(ijk)
4031  do myu = 1, nspc
4032  do mm = 1, iflg( myu,ijk )
4033  dumm_regene(ijk) = dumm_regene(ijk)+( -flq(1,myu,ijk)*dtcnd(ijk)/dxmic ) &
4034  * min( uadv(1,myu,ijk),0.0_rp )/( uadv(1,myu,ijk)+eps )
4035  enddo
4036  enddo
4037  enddo
4038  enddo
4039 
4040  do ijk = 1, ijkmax
4041  do nn = 1, loopflg(ijk)
4042  do myu = 1, nspc
4043  do mm = 1, iflg( myu,ijk )
4044  do n = 1, nbin
4045  gcn( n,myu,ijk ) = gcn( n,myu,ijk ) - ( flq(n+1,myu,ijk)-flq(n,myu,ijk) )*dtcnd(ijk)/dxmic
4046  gcrgn( n,myu,ijk ) = gcrgn( n,myu,ijk ) - ( flq_c(n+1,myu,ijk)-flq_c(n,myu,ijk) )*dtcnd(ijk)
4047  enddo
4048  enddo
4049  enddo
4050  enddo
4051  enddo
4052 
4053  call prof_rapend ('_SBM_AdvMix', 3)
4054 
4055 !OCL LOOP_NOFUSION
4056  do ijk = 1, ijkmax
4057  do nn = 1, loopflg(ijk)
4058  !--- new mass
4059  gclnew(ijk) = 0.0_rp
4060  do n = 1, nbin
4061  gclnew(ijk) = gclnew(ijk) + gcn( n,il,ijk )*expxctr( n )*dxmic
4062  enddo
4063 
4064  gcinew(ijk) = 0.0_rp
4065  do myu = 2, nspc
4066  do n = 1, nbin
4067  gcinew(ijk) = gcinew(ijk) + gcn( n,myu,ijk )*expxctr( n )*dxmic
4068  enddo
4069  enddo
4070 
4071  !--- change of humidity and temperature
4072  cndmss = gclnew(ijk) - gclold(ijk)
4073  sblmss = gcinew(ijk) - gciold(ijk)
4074 
4075  qvap(ijk) = qvap(ijk) - ( cndmss + sblmss ) / dens(ijk)
4076  temp(ijk) = temp(ijk) + ( cndmss*qlevp(ijk)+sblmss*qlsbl(ijk) ) / dens(ijk) / cv(ijk)
4077  cp(ijk) = cp(ijk) + ( ( cp_water - cp_vapor ) * cndmss + ( cp_ice - cp_vapor ) * sblmss ) / dens(ijk)
4078  cv(ijk) = cv(ijk) + ( ( cv_water - cv_vapor ) * cndmss + ( cv_ice - cv_vapor ) * sblmss ) / dens(ijk)
4079 
4080  gclold(ijk) = gclnew(ijk)
4081  gciold(ijk) = gcinew(ijk)
4082  enddo
4083  enddo
4084 
4085  enddo ! ncount
4086 
4087 !OCL NORECURRENCE(gc)
4088  do ijk = 1, ijkmax
4089  !----- number -> mass
4090  do myu = 1, nspc
4091  do n = 1, nbin
4092  gc( n,myu,ijk ) = gcn( n,myu,ijk )*expxctr( n )
4093  gcrg( n,myu,ijk ) = gcrgn( n,myu,ijk )
4094  enddo
4095  enddo
4096  enddo
4097 
4098  if ( .NOT. flg_regeneration ) then
4099  dumm_regene(:) = 0.0_rp
4100  endif
4101 
4102  call prof_rapend ('_SBM_Mixphase', 3)
4103 
4104  return
4105  end subroutine mixphase
4106 
4107  !-----------------------------------------------------------------------------
4108  subroutine ice_nucleat( &
4109  ijkmax, &
4110  num_cold, &
4111  index_cold, &
4112  dens, &
4113  pres, &
4114  qdry, &
4115  temp, &
4116  qvap, &
4117  gc, &
4118  cp, &
4119  cv, &
4120  dtime )
4121  use scale_const, only: &
4122  qlmlt => const_emelt
4123  use scale_atmos_saturation, only: &
4124  atmos_saturation_pres2qsat_ice
4125  use scale_atmos_hydrometeor, only: &
4126  atmos_hydrometeor_lhs, &
4127  cp_vapor, &
4128  cp_ice, &
4129  cv_vapor, &
4130  cv_ice
4131  implicit none
4132 
4133  integer, intent(in) :: ijkmax
4134  integer, intent(in) :: num_cold
4135  integer, intent(in) :: index_cold(ijkmax)
4136  real(rp), intent(in) :: dens(ijkmax) ! Density [kg/m3]
4137  real(rp), intent(in) :: pres(ijkmax) ! Pressure [Pa]
4138  real(rp), intent(in) :: qdry(ijkmax) ! dry air mass ratio [kg/kg]
4139  real(rp), intent(inout) :: temp(ijkmax) ! Temperature [K]
4140  real(rp), intent(inout) :: qvap(ijkmax) ! Specific humidity [kg/kg]
4141  real(rp), intent(inout) :: gc (nbin,nspc,ijkmax) ! Mass size distribution function of hydrometeor
4142  real(rp), intent(inout) :: cp(ijkmax) ! specific heat
4143  real(rp), intent(inout) :: cv(ijkmax) ! specific heat
4144  real(dp), intent(in) :: dtime ! Time step interval
4145 
4146  real(rp) :: ssice
4147  real(rp) :: numin, tdel, qdel
4148 ! real(RP), parameter :: n0 = 1.E+3_RP ! N_{IN0} in page 112 of Suzuki (2004)
4149  real(rp), parameter :: acoef = -0.639_rp, bcoef = 12.96_rp ! A and B in paeg 112 of Suzuki (2004)
4150  ! threshould to determine the type of freezed hydrometeor (the detail is described in page 113 of Suzuki(2004))
4151  real(rp), parameter :: tcolmu = 269.0_rp, tcolml = 265.0_rp! -4[degC], -8[degC]
4152  real(rp), parameter :: tdendu = 257.0_rp, tdendl = 255.0_rp! -14[degC], -18[degC]
4153  real(rp), parameter :: tplatu = 250.6_rp ! -22.4[degC]
4154  !
4155  real(rp) :: qsati(ijkmax), qlsbl(ijkmax)
4156  integer :: ijk, indirect
4157  real(rp) :: numice
4158  integer :: myu, n
4159  integer :: ispc
4160 
4161  call prof_rapstart('_SBM_IceNucleat', 3)
4162 
4163  call atmos_saturation_pres2qsat_ice( ijkmax, 1, ijkmax, &
4164  temp(:), pres(:), qdry(:), & ! [IN]
4165  qsati(:) ) ! [OUT]
4166  ! lhs
4167  call atmos_hydrometeor_lhs( ijkmax, 1, ijkmax, temp(:), qlsbl(:) )
4168 
4169  do indirect = 1, num_cold
4170  ijk = index_cold(indirect)
4171 
4172  !--- supersaturation
4173  ssice = qvap(ijk)/qsati(ijk) - 1.0_rp
4174 
4175  if( ssice <= 0.0_rp ) cycle
4176 
4177  numice = 0.0_rp
4178  do myu = ic, ih
4179  do n = 1, nbin
4180  numice = numice + gc( n,myu,ijk )*rexpxctr( n )*dxmic
4181  enddo
4182  enddo
4183 
4184  numin = n0_icenucl * exp( acoef + bcoef * ssice * 1.e+2_rp )
4185  if( numin > numice ) then
4186  !--- -4 [deg] > T >= -8 [deg] and T < -22.4 [deg] -> column
4187  if ( temp(ijk) <= tplatu .OR. ( temp(ijk) >= tcolml .AND. temp(ijk) < tcolmu ) ) then
4188  ispc = ic
4189  !--- -14 [deg] > T >= -18 [deg] -> dendrite
4190  elseif( temp(ijk) <= tdendu .AND. temp(ijk) >= tdendl ) then
4191  ispc = id
4192  !--- else -> plate
4193  else
4194  ispc = ip
4195  endif
4196 
4197  numin = (numin-numice) * expxctr( 1 )
4198  numin = min( numin,qvap(ijk)*dens(ijk) )
4199  gc( 1,ispc,ijk ) = gc( 1,ispc,ijk ) + numin / dxmic
4200 
4201  tdel = numin/dens(ijk)*qlsbl(ijk)/cv(ijk)
4202  temp(ijk) = temp(ijk) + tdel
4203  qdel = numin/dens(ijk)
4204  qvap(ijk) = qvap(ijk) - qdel
4205  cp(ijk) = cp(ijk) + ( cp_ice - cp_vapor ) * qdel
4206  cv(ijk) = cv(ijk) + ( cv_ice - cv_vapor ) * qdel
4207  endif
4208 
4209  enddo
4210 
4211 
4212  call prof_rapend ('_SBM_IceNucleat', 3)
4213 
4214  return
4215  end subroutine ice_nucleat
4216 
4217  !-----------------------------------------------------------------------------
4218  subroutine freezing( &
4219  ijkmax, &
4220  num_cold, &
4221  index_cold, &
4222  flg_lt, &
4223  dens, &
4224  temp, &
4225  gc, &
4226  gcrg, &
4227  cp, &
4228  cv, &
4229  dtime )
4230  use scale_const, only: &
4231  eps => const_eps, &
4232  pi => const_pi, &
4233  tmlt => const_tmelt, &
4234  rhow => const_dwatr
4235  use scale_atmos_hydrometeor, only: &
4236  atmos_hydrometeor_lhf, &
4237  cp_water, &
4238  cp_ice, &
4239  cv_water, &
4240  cv_ice
4241  implicit none
4242 
4243  integer, intent(in) :: ijkmax
4244  integer, intent(in) :: num_cold
4245  integer, intent(in) :: index_cold(ijkmax)
4246  logical, intent(in) :: flg_lt
4247  real(rp), intent(in) :: dens(ijkmax) ! Density [kg/m3]
4248  real(rp), intent(inout) :: temp(ijkmax) ! Temperature [K]
4249  real(rp), intent(inout) :: gc (nbin,nspc,ijkmax) ! Mass size distribution function of hydrometeor
4250  real(rp), intent(inout) :: gcrg(nbin,nspc,ijkmax)
4251  real(rp), intent(inout) :: cp(ijkmax) ! specific heat
4252  real(rp), intent(inout) :: cv(ijkmax) ! specific heat
4253  real(dp), intent(in) :: dtime ! Time step interval
4254 
4255  integer :: nbound, n
4256  real(rp) :: xbound, tc, rate, dmp, frz, sumfrz, tdel
4257  real(rp), parameter :: coefa = 1.0e-01_rp ! a_{fr} of eq.(3.19) of Suzuki (2004)
4258  real(rp), parameter :: coefb = 0.66_rp ! b_{fr} of eq.(3.19) of Suzuki (2004)
4259  real(rp), parameter :: rbound = 2.0e-04_rp ! 200 um
4260 ! real(RP), parameter :: tthreth = 235.0_RP ! -38 [degC] threshold for using Bigg's parameterization
4261 ! real(RP), parameter :: ncoefim = 1.0E+7_RP ! N_{im0} of eq.(3.18) of Suzuki (2004)
4262 ! real(RP), parameter :: gamm = 3.3_RP ! gamma of eq.(3.18) of Suzuki (2004)
4263  integer :: ijk, indirect
4264  real(rp) :: qlmlt(ijkmax)
4265  real(rp) :: dcrg
4266 
4267  call prof_rapstart('_SBM_Freezing', 3)
4268 
4269  call atmos_hydrometeor_lhf( ijkmax, 1, ijkmax, temp(:), qlmlt(:) )
4270 
4271  xbound = log( rhow * 4.0_rp*pi/3.0_rp * rbound**3 )
4272  nbound = int( ( xbound-xbnd( 1 ) )/dxmic ) + 1
4273 
4274  do indirect = 1, num_cold
4275  ijk = index_cold(indirect)
4276 
4277 ! if ( temp(ijk) <= tthreth ) then !--- Bigg (1975)
4278 
4279  tc = temp(ijk)-tmlt
4280  rate = coefa*exp( -coefb*tc )
4281 
4282  dcrg = 0.0_rp
4283  sumfrz = 0.0_rp
4284  do n = 1, nbound-1
4285  dmp = rate*expxctr( n )
4286  frz = gc( n,il,ijk )*( 1.0_rp-exp( -dmp*dtime ) )
4287  frz = min( frz, gc( n,il,ijk ) )
4288 
4289  if ( flg_lt ) then
4290  dcrg = frz / ( gc(n,il,ijk)+eps ) * gcrg( n,il,ijk )
4291  gcrg( n,il,ijk ) = gcrg( n,il,ijk ) - dcrg
4292  gcrg( n,ip,ijk ) = gcrg( n,ip,ijk ) + dcrg
4293  end if
4294 
4295  gc( n,il,ijk ) = gc( n,il,ijk ) - frz
4296  gc( n,ip,ijk ) = gc( n,ip,ijk ) + frz
4297 
4298  sumfrz = sumfrz + frz
4299  enddo
4300  do n = nbound, nbin
4301  dmp = rate*expxctr( n )
4302  frz = gc( n,il,ijk )*( 1.0_rp-exp( -dmp*dtime ) )
4303  frz = min( frz, gc( n,il,ijk ) )
4304 
4305  if ( flg_lt ) then
4306  dcrg = frz / ( gc(n,il,ijk)+eps ) * gcrg( n,il,ijk )
4307  gcrg( n,il,ijk ) = gcrg( n,il,ijk ) - dcrg
4308  gcrg( n,ih,ijk ) = gcrg( n,ih,ijk ) + dcrg
4309  end if
4310 
4311  gc( n,il,ijk ) = gc( n,il,ijk ) - frz
4312  gc( n,ih,ijk ) = gc( n,ih,ijk ) + frz
4313 
4314  sumfrz = sumfrz + frz
4315  enddo
4316 
4317 ! elseif( temp(ijk) > tthreth ) then !--- Vali (1975)
4318 !
4319 ! tc = temp(ijk)-tmlt
4320 ! dmp = ncoefim * ( 0.1_RP * ( -tc )**gamm )
4321 ! sumfrz = 0.0_RP
4322 ! do n = 1, nbound-1
4323 ! frz = gc( n,il,ijk )*expxctr( n )/rhow*dmp
4324 ! frz = min( frz,gc( n,il,ijk ) )
4325 ! gc( n,il,ijk ) = gc( n,il,ijk ) - frz
4326 ! gc( n,ip,ijk ) = gc( n,ip,ijk ) + frz
4327 !
4328 ! if ( flg_lt ) then
4329 ! dcrg = frz / ( gc(n,il,ijk)+EPS ) * gcrg( n,il,ijk )
4330 ! gcrg( n,il,ijk ) = gcrg( n,il,ijk ) - dcrg
4331 ! gcrg( n,ip,ijk ) = gcrg( n,ip,ijk ) + dcrg
4332 ! endif
4333 !
4334 ! sumfrz = sumfrz + frz
4335 ! enddo
4336 ! do n = nbound, nbin
4337 ! frz = gc( n,il,ijk )*dmp*expxctr( n )/rhow
4338 ! frz = min( frz,gc( n,il,ijk ) )
4339 ! gc( n,il,ijk ) = gc( n,il,ijk ) - frz
4340 ! gc( n,ih,ijk ) = gc( n,ih,ijk ) + frz
4341 !
4342 ! if ( flg_lt ) then
4343 ! dcrg = frz / ( gc(n,il,ijk)+EPS ) * gcrg( n,il,ijk )
4344 ! gcrg( n,il,ijk ) = gcrg( n,il,ijk ) - dcrg
4345 ! gcrg( n,ih,ijk ) = gcrg( n,ih,ijk ) + dcrg
4346 ! endif
4347 !
4348 ! sumfrz = sumfrz + frz
4349 ! enddo
4350 ! endif
4351  sumfrz = sumfrz*dxmic
4352 
4353  tdel = sumfrz/dens(ijk)*qlmlt(ijk)/cv(ijk)
4354  temp(ijk) = temp(ijk) + tdel
4355  cp(ijk) = cp(ijk) + ( cp_ice - cp_water ) * sumfrz/dens(ijk)
4356  cv(ijk) = cv(ijk) + ( cv_ice - cv_water ) * sumfrz/dens(ijk)
4357  enddo
4358 
4359  call prof_rapend ('_SBM_Freezing', 3)
4360 
4361  return
4362  end subroutine freezing
4363 
4364  !-----------------------------------------------------------------------------
4365  subroutine melting( &
4366  ijkmax, &
4367  num_warm, &
4368  index_warm, &
4369  flg_lt, &
4370  dens, &
4371  temp, &
4372  gc, &
4373  gcrg, &
4374  cp, &
4375  cv, &
4376  dtime )
4377  use scale_atmos_hydrometeor, only: &
4378  atmos_hydrometeor_lhf, &
4379  cp_water, &
4380  cp_ice, &
4381  cv_water, &
4382  cv_ice
4383  implicit none
4384 
4385  integer, intent(in) :: ijkmax
4386  integer, intent(in) :: num_warm
4387  integer, intent(in) :: index_warm(ijkmax)
4388  logical, intent(in) :: flg_lt
4389  real(rp), intent(in) :: dens(ijkmax) ! Density [kg/m3]
4390  real(rp), intent(inout) :: temp(ijkmax) ! Temperature [K]
4391  real(rp), intent(inout) :: gc (nbin,nspc,ijkmax) ! Mass size distribution function of hydrometeor
4392  real(rp), intent(inout) :: gcrg(nbin,nspc,ijkmax)
4393  real(rp), intent(inout) :: cp(ijkmax) ! specific heat
4394  real(rp), intent(inout) :: cv(ijkmax) ! specific heat
4395  real(dp), intent(in) :: dtime ! Time step interval
4396 
4397  integer :: n, m
4398  real(rp) :: summlt, sumice, tdel
4399  integer :: ijk, indirect
4400  real(rp) :: qlmlt(ijkmax)
4401  real(rp) :: dcrg
4402 
4403  call prof_rapstart('_SBM_Melting', 3)
4404 
4405  call atmos_hydrometeor_lhf( ijkmax, 1, ijkmax, temp(:), qlmlt(:) )
4406 
4407  do indirect = 1, num_warm
4408  ijk = index_warm(indirect)
4409 
4410  summlt = 0.0_rp
4411  do n = 1, nbin
4412  sumice = 0.0_rp
4413  do m = ic, ih
4414  sumice = sumice + gc( n,m,ijk )
4415  gc( n,m,ijk ) = 0.0_rp
4416  enddo
4417  gc( n,il,ijk ) = gc( n,il,ijk ) + sumice
4418  if ( flg_lt ) then
4419  dcrg = 0.0_rp
4420  do m = ic, ih
4421  dcrg = dcrg + gcrg( n,m,ijk )
4422  gcrg( n,m,ijk ) = 0.0_rp
4423  end do
4424  gcrg( n,il,ijk ) = gcrg( n,il,ijk ) + dcrg
4425  end if
4426  summlt = summlt + sumice !--- All freezed particle melt instantaneously
4427  enddo
4428  summlt = summlt*dxmic
4429 
4430  tdel = - summlt/dens(ijk)*qlmlt(ijk)/cv(ijk)
4431  temp(ijk) = temp(ijk) + tdel
4432  cp(ijk) = cp(ijk) + ( cp_water - cp_ice ) * summlt/dens(ijk)
4433  cv(ijk) = cv(ijk) + ( cv_water - cv_ice ) * summlt/dens(ijk)
4434  !
4435  enddo
4436 
4437  call prof_rapend ('_SBM_Melting', 3)
4438 
4439  return
4440  end subroutine melting
4441 
4442  !-----------------------------------------------------------------------------
4443  subroutine collmain( &
4444  KA, IA, JA , &
4445  ijkmax, &
4446  flg_lt, &
4447  d0_crg, &
4448  v0_crg, &
4449  dq, &
4450  beta, &
4451  temp, &
4452  ghyd, &
4453  gcrg, &
4454  crg_sep,&
4455  dt )
4456  implicit none
4457 
4458  integer, intent(in) :: ka
4459  integer, intent(in) :: ia
4460  integer, intent(in) :: ja
4461 
4462  integer, intent(in) :: ijkmax
4463  logical, intent(in) :: flg_lt
4464  real(rp), intent(in) :: v0_crg, d0_crg
4465  real(rp), intent(in) :: dq(ijkmax)
4466  real(rp), intent(in) :: beta(ijkmax)
4467  real(rp), intent(in) :: temp(ijkmax) ! Temperature [K]
4468  real(rp), intent(inout) :: ghyd(nbin,nspc,ijkmax) ! Mass size distribution function of hydrometeor
4469  real(rp), intent(inout) :: gcrg(nbin,nspc,ijkmax)
4470  real(rp), intent(out) :: crg_sep(nspc,ijkmax)
4471  real(dp), intent(in) :: dt ! Time step interval
4472  !---------------------------------------------------------------------------
4473 
4474  if ( flg_rndm ) then ! stochastic method
4475  call r_collcoag( ka, ia, ja, & ! [IN]
4476  ijkmax, & ! [IN]
4477  wgtbin, & ! [IN]
4478  temp(:), & ! [IN]
4479  ghyd(:,:,:), & ! [INOUT]
4480  dt ) ! [IN]
4481  else ! default
4482  call collcoag( ijkmax, & ! [IN]
4483  flg_lt, & ! [IN]
4484  d0_crg, & ! [IN]
4485  v0_crg, & ! [IN]
4486  dq(:), & ! [IN]
4487  beta(:), & ! [IN]
4488  temp(:), & ! [IN]
4489  ghyd(:,:,:), & ! [INOUT]
4490  gcrg(:,:,:), & ! [INOUT]
4491  crg_sep(:,:),& ! [OUT]
4492  dt ) ! [IN]
4493  endif
4494 
4495  return
4496  end subroutine collmain
4497 
4498  !-----------------------------------------------------------------------------
4499  subroutine collmainf( &
4500  KA, IA, JA, &
4501  ijkmax, &
4502  flg_lt, &
4503  d0_crg, &
4504  v0_crg, &
4505  dq, &
4506  beta, &
4507  temp, &
4508  ghyd, &
4509  gcrg, &
4510  crg_sep,&
4511  dt )
4512  implicit none
4513 
4514  integer, intent(in) :: ka
4515  integer, intent(in) :: ia
4516  integer, intent(in) :: ja
4517 
4518  integer, intent(in) :: ijkmax
4519  logical, intent(in) :: flg_lt
4520  real(rp), intent(in) :: v0_crg, d0_crg
4521  real(rp), intent(in) :: dq(ijkmax)
4522  real(rp), intent(in) :: beta(ijkmax)
4523  real(rp), intent(in) :: temp(ijkmax) ! Temperature [K]
4524  real(rp), intent(inout) :: ghyd(nbin,nspc,ijkmax) ! Mass size distribution function of hydrometeor
4525  real(rp), intent(inout) :: gcrg(nbin,nspc,ijkmax)
4526  real(rp), intent(out) :: crg_sep(nspc,ijkmax)
4527  real(dp), intent(in) :: dt ! Time step interval
4528  !---------------------------------------------------------------------------
4529 
4530  if ( flg_rndm ) then ! stochastic method
4531  call r_collcoag( ka, ia, ja, & ! [IN]
4532  ijkmax, & ! [IN]
4533  wgtbin, & ! [IN]
4534  temp(:), & ! [IN]
4535  ghyd(:,:,:), & ! [INOUT]
4536  dt ) ! [IN]
4537  else ! default
4538  call collcoag( ijkmax, & ! [IN]
4539  flg_lt, & ! [IN]
4540  d0_crg, & ! [IN]
4541  v0_crg, & ! [IN]
4542  dq(:), & ! [IN]
4543  beta(:), & ! [IN]
4544  temp(:), & ! [IN]
4545  ghyd(:,:,:), & ! [INOUT]
4546  gcrg(:,:,:), & ! [INOUT]
4547  crg_sep(:,:),& ! [OUT]
4548  dt ) ! [IN]
4549  endif
4550 
4551  return
4552  end subroutine collmainf
4553 
4554  !-----------------------------------------------------------------------------
4555  !--- reference paper
4556  ! Bott et al. (1998) J. Atmos. Sci. vol.55, pp. 2284-
4557  subroutine collcoag( &
4558  ijkmax, &
4559  flg_lt, &
4560  d0_crg, &
4561  v0_crg, &
4562  dq, &
4563  beta, &
4564  temp, &
4565  gc, &
4566  gcrg, &
4567  crg_sep,&
4568  dtime )
4569  implicit none
4570 
4571  integer, intent(in) :: ijkmax
4572  logical, intent(in) :: flg_lt
4573  real(rp), intent(in) :: d0_crg, v0_crg
4574  real(rp), intent(in) :: dq(ijkmax)
4575  real(rp), intent(in) :: beta(ijkmax)
4576  real(rp), intent(in) :: temp(ijkmax) ! Temperature [K]
4577  real(rp), intent(inout) :: gc (nbin,nspc,ijkmax) ! Mass size distribution function of hydrometeor
4578  real(rp), intent(inout) :: gcrg(nbin,nspc,ijkmax)
4579  real(rp), intent(out) :: crg_sep(nspc,ijkmax)
4580  real(dp), intent(in) :: dtime ! Time step interval
4581 
4582  integer :: i, j, k, l
4583  real(rp) :: xi, xj, xnew, dmpi, dmpj, frci, frcj
4584  real(rp) :: gprime, gprimk, wgt, crn, sum, flux
4585  integer, parameter :: ldeg = 2
4586  real(rp) :: acoef( 0:ldeg )
4587  real(rp), parameter :: dmpmin = 1.e-01_rp
4588  real(rp) :: suri, surj
4589 
4590  integer :: myu, n, irsl, ilrg, isml
4591  integer :: ibnd( ijkmax )
4592  integer :: iflg( nspc,ijkmax )
4593  integer :: iexst( nbin,nspc,ijkmax )
4594  real(rp) :: csum( nspc,ijkmax )
4595  integer :: ijk, nn, mm, pp, qq
4596 
4597  !--- for non-inducting charge separation
4598  real(rp) :: drhoi, drhoj, drhok, alpha, dgenei, dgenej
4599  integer :: ispc
4600  !---------------------------------------------------------------------------
4601 
4602  call prof_rapstart('_SBM_CollCoag', 3)
4603 
4604  iflg( :,: ) = 0
4605  iexst( :,:,: ) = 0
4606  csum( :,: ) = 0.0_rp
4607  crg_sep( :,: ) = 0.0_rp
4608  do ijk = 1, ijkmax
4609  !--- judgement of particle existence
4610  do myu = 1, nspc
4611  do n = 1, nbin
4612  csum( myu,ijk ) = csum( myu,ijk ) + gc( n,myu,ijk )*dxmic
4613  enddo
4614  enddo
4615  do myu = 1, nspc
4616  if ( csum( myu,ijk ) > cldmin ) iflg( myu,ijk ) = 1
4617  enddo
4618 
4619  if ( temp(ijk) < tcrit ) then
4620  ibnd(ijk) = 1
4621  else
4622  ibnd(ijk) = 2
4623  endif
4624 
4625  do myu = 1, nspc
4626  do n = 1, nbin
4627  if ( gc( n,myu,ijk ) > cldmin ) then
4628  iexst( n,myu,ijk ) = 1
4629  endif
4630  enddo
4631  enddo
4632 
4633  enddo
4634 
4635 !OCL PARALLEL
4636  do ijk = 1, ijkmax
4637  do isml = 1, nspc
4638  do nn = 1, iflg( isml,ijk )
4639 
4640  do ilrg = 1, nspc
4641  do mm = 1, iflg( ilrg,ijk )
4642  !--- rule of interaction
4643  irsl = ifrsl( ibnd(ijk),isml,ilrg )
4644 
4645  if ( isml /= ilrg ) then
4646  ispc = 0
4647  else if ( isml == ilrg ) then
4648  ispc = 1
4649  endif
4650 
4651  do i = 1, nbin-1 ! small
4652  do pp = 1, iexst( i,isml,ijk )
4653 
4654  do j = i+1, nbin ! large
4655  do qq = 1, iexst( j,ilrg,ijk )
4656 
4657  k = kindx( i,j )
4658  xi = expxctr( i )
4659  xj = expxctr( j )
4660  xnew = log( xi+xj )
4661 
4662  dmpi = ck( isml,ilrg,i,j )*gc( j,ilrg,ijk )/xj*dxmic*dtime ! dg_{i}/dt*dt in page 119 of Suzuki (2004)
4663  dmpj = ck( ilrg,isml,i,j )*gc( i,isml,ijk )/xi*dxmic*dtime ! dg_{j}/dt*dt in page 119 of Suzuki (2004)
4664 
4665  if ( dmpi <= dmpmin ) then
4666  frci = gc( i,isml,ijk )*dmpi ! Dg_{i} in page 119 of Suzuki (2004)
4667  else
4668  frci = gc( i,isml,ijk )*( 1.0_rp-exp( -dmpi ) ) ! Dg_{i} in page 119 of Suzuki (2004)
4669  endif
4670 
4671  if ( dmpj <= dmpmin ) then
4672  frcj = gc( j,ilrg,ijk )*dmpj ! Dg_{j} in page 119 of Suzuki (2004)
4673  else
4674  frcj = gc( j,ilrg,ijk )*( 1.0_rp-exp( -dmpj ) ) ! Dg_{j} in page 119 of Suzuki (2004)
4675  endif
4676 
4677  gprime = frci+frcj
4678 ! if ( gprime <= 0.0_RP ) cycle large
4679  if ( gprime > 0.0_rp .AND. k < nbin ) then
4680 
4681  suri = gc( i,isml,ijk )
4682  surj = gc( j,ilrg,ijk )
4683  gc( i,isml,ijk ) = gc( i,isml,ijk )-frci
4684  gc( j,ilrg,ijk ) = gc( j,ilrg,ijk )-frcj
4685  gc( i,isml,ijk ) = max( gc( i,isml,ijk )-frci, 0.0_rp )
4686  gc( j,ilrg,ijk ) = max( gc( j,ilrg,ijk )-frcj, 0.0_rp )
4687  frci = suri - gc( i,isml,ijk )
4688  frcj = surj - gc( j,ilrg,ijk )
4689  gprime = frci+frcj ! g' in page 119 of Suzuki (2004)
4690 
4691  if ( flg_lt ) then
4692  !--- charge transfer from two particles to generated large particle
4693  drhoi = frci/suri*gcrg( i,isml,ijk )
4694  drhoj = frcj/surj*gcrg( j,ilrg,ijk )
4695  drhok = drhoi + drhoj
4696 
4697  !--- charge density generated by non-inductive charging
4698  alpha = 5.0_rp * ( 2.0_rp*radc( i )/d0_crg )**2 &
4699  * abs( vt(ilrg,j)-vt(isml,i) )/v0_crg ! alpha in eq. (12) of Mansell et al. (2005)
4700  alpha = min( 10.0_rp, alpha )
4701 
4702  dgenei = frci / xi * rcoll( isml,ilrg,i,j ) * ( -dq( ijk ) ) &
4703  * alpha * beta( ijk ) * flg_noninduct( isml,ilrg ) ! eq. (8) of Mansell et al. (2005)
4704  dgenej = - dgenei
4705  gcrg( i,isml,ijk ) = gcrg( i,isml,ijk ) + ( dgenei-drhoi )
4706  gcrg( j,ilrg,ijk ) = gcrg( j,ilrg,ijk ) + ( dgenej-drhoj )
4707  crg_sep( isml,ijk ) = crg_sep( isml,ijk ) + dgenei
4708  crg_sep( ilrg,ijk ) = crg_sep( ilrg,ijk ) + dgenej
4709  end if
4710 
4711  gprimk = gc( k,irsl,ijk ) + gprime ! g'_{k} in page 119 of Suzuki (2004)
4712  wgt = gprime / gprimk ! w in page 119 of Suzuki (2004)
4713  crn = ( xnew-xctr( k ) )/( xctr( k+1 )-xctr( k ) ) ! c_{k} in page 119 of Suzuki (2004)
4714 
4715  acoef( 0 ) = -( gc( k+1,irsl,ijk )-26.0_rp*gprimk+gc( k-1,irsl,ijk ) )/24.0_rp ! a_{k,0} in page 119 of Suzuki (2004)
4716  acoef( 1 ) = ( gc( k+1,irsl,ijk )-gc( k-1,irsl,ijk ) ) *0.50_rp ! a_{k,1} in page 119 of Suzuki (2004)
4717  acoef( 2 ) = ( gc( k+1,irsl,ijk )-2.0_rp*gprimk+gc( k-1,irsl,ijk ) ) *0.50_rp ! a_{k,2} in page 119 of Suzuki (2004)
4718 
4719  sum = 0.0_rp
4720  do l = 0, ldeg
4721  sum = sum + acoef( l )/( l+1 )/2.0_rp**( l+1 ) &
4722  *( 1.0_rp-( 1.0_rp-2.0_rp*crn )**( l+1 ) )
4723  enddo
4724 
4725  flux = wgt*sum ! f_{k+1/2} in page 119 of Suzuki (2004)
4726  flux = min( max( flux,0.0_rp ),gprime )
4727 
4728  gc( k,irsl,ijk ) = gprimk - flux ! tilda{g_{k}} in page 119 of Suzuki (2004)
4729  gc( k+1,irsl,ijk ) = gc( k+1,irsl,ijk ) + flux ! tilda{g_{k+1}} in page 119 of Suzuki (2004)
4730 
4731  if ( flg_lt ) then
4732  !--- charge transfer from two particles to generated large particle
4733  if( gprime /= 0.0_rp ) then
4734  gcrg( k,irsl,ijk ) = gcrg( k,irsl,ijk ) + drhok * ( gprime-flux )/gprime
4735  gcrg( k+1,irsl,ijk ) = gcrg( k+1,irsl,ijk ) + drhok * flux/gprime
4736  endif
4737  end if
4738 
4739  endif
4740 
4741  enddo
4742  enddo !large
4743  enddo
4744  enddo !small
4745  !
4746  enddo
4747  enddo
4748 
4749  enddo
4750  enddo
4751 
4752  enddo
4753 
4754  call prof_rapend ('_SBM_CollCoag', 3)
4755 
4756  return
4757  end subroutine collcoag
4758 
4759  !-------------------------------------------------------------------
4760  subroutine getrule( ifrsl, indx ) !--- out
4761  ! subroutine for creating lookup table (Table A.2 of Suzuki 2004)
4762  integer, intent(out) :: indx( nbin,nbin )
4763  integer, intent(out) :: ifrsl( 2,nspc_mk,nspc_mk )
4764  integer :: i, j, k
4765  real(rp) :: xnew
4766  !
4767  do i = 1, nbin
4768  do j = 1, nbin
4769  xnew = log( expxctr( i )+expxctr( j ) )
4770  k = int( ( xnew-xctr( 1 ) )/dxmic ) + 1
4771  k = max( max( k,j ),i )
4772  indx( i,j ) = k
4773  enddo
4774  enddo
4775  !
4776  !
4777  !--- liquid + liquid -> liquid
4778  ifrsl( 1:2,il,il ) = il
4779  !
4780  !--- liquid + column -> ( graupel, hail ) + column
4781  ifrsl( 1:2,il,ic ) = ic
4782  ifrsl( 1,ic,il ) = ig
4783  ifrsl( 2,ic,il ) = ih
4784  !
4785  !--- liquid + plate -> ( graupel, hail ) + plate
4786  ifrsl( 1:2,il,ip ) = ip
4787  ifrsl( 1,ip,il ) = ig
4788  ifrsl( 2,ip,il ) = ih
4789  !
4790  !--- liquid + dendrite -> ( graupel, hail ) + dendrite
4791  ifrsl( 1:2,il,id ) = id
4792  ifrsl( 1,id,il ) = ig
4793  ifrsl( 2,id,il ) = ih
4794  !
4795  !--- liquid + snowflake -> ( graupel, hail ) + snowflake
4796  ifrsl( 1:2,il,iss ) = iss
4797  ifrsl( 1,iss,il ) = ig
4798  ifrsl( 2,iss,il ) = ih
4799  !
4800  !--- liquid + graupel -> ( graupel, hail )
4801  ifrsl( 1:2,il,ig ) = ig
4802  ifrsl( 1,ig,il ) = ig
4803  ifrsl( 2,ig,il ) = ih
4804  !
4805  !--- liquid + hail -> ( graupel, hail )
4806  ifrsl( 1:2,il,ih ) = ih
4807  ifrsl( 1,ih,il ) = ig
4808  ifrsl( 2,ih,il ) = ih
4809  !
4810  !
4811  !--- column + column -> snowflake
4812  ifrsl( 1:2,ic,ic ) = iss
4813  !
4814  !--- column + plate -> snowflake
4815  ifrsl( 1:2,ic,ip ) = iss
4816  ifrsl( 1:2,ip,ic ) = iss
4817  !
4818  !--- column + dendrite -> snowflake
4819  ifrsl( 1:2,ic,id ) = iss
4820  ifrsl( 1:2,id,ic ) = iss
4821  !
4822  !--- column + snowflake -> snowflake
4823  ifrsl( 1:2,ic,iss ) = iss
4824  ifrsl( 1:2,iss,ic ) = iss
4825  !
4826  !--- column + graupel -> column + graupel
4827  ifrsl( 1:2,ic,ig ) = ig
4828  ifrsl( 1:2,ig,ic ) = ic
4829  !
4830  !--- column + hail -> column + ( graupel, hail )
4831  ifrsl( 1:2,ih,ic ) = ic
4832  ifrsl( 1,ic,ih ) = ig
4833  ifrsl( 2,ic,ih ) = ih
4834  !
4835  !
4836  !--- plate + plate -> snowflake
4837  ifrsl( 1:2,ip,ip ) = iss
4838  !
4839  !--- plate + dendrite -> snowflake
4840  ifrsl( 1:2,ip,id ) = iss
4841  ifrsl( 1:2,id,ip ) = iss
4842  !
4843  !--- plate + snowflake -> snowflake
4844  ifrsl( 1:2,ip,iss ) = iss
4845  ifrsl( 1:2,iss,ip ) = iss
4846  !
4847  !--- plate + graupel -> plate + graupel
4848  ifrsl( 1:2,ip,ig ) = ig
4849  ifrsl( 1:2,ig,ip ) = ip
4850  !
4851  !--- plate + hail -> plate + ( graupel, hail )
4852  ifrsl( 1:2,ih,ip ) = ip
4853  ifrsl( 1,ip,ih ) = ig
4854  ifrsl( 2,ip,ih ) = ih
4855  !
4856  !
4857  !--- dendrite + dendrite -> snowflake
4858  ifrsl( 1:2,id,id ) = iss
4859  !
4860  !--- dendrite + snowflake -> snowflake
4861  ifrsl( 1:2,id,iss ) = iss
4862  ifrsl( 1:2,iss,id ) = iss
4863  !
4864  !--- dendrite + graupel -> dendrite + graupel
4865  ifrsl( 1:2,id,ig ) = ig
4866  ifrsl( 1:2,ig,id ) = id
4867  !
4868  !--- dendrite + hail -> dendrite + ( graupel, hail )
4869  ifrsl( 1:2,ih,id ) = id
4870  ifrsl( 1,id,ih ) = ig
4871  ifrsl( 2,id,ih ) = ih
4872  !
4873  !
4874  !--- snowflake + snowflake -> snowflake
4875  ifrsl( 1:2,iss,iss ) = iss
4876  !
4877  !--- snowflake + graupel -> snowflake + graupel
4878  ifrsl( 1:2,iss,ig ) = ig
4879  ifrsl( 1:2,ig,iss ) = iss
4880  !
4881  !--- snowflake + hail -> snowflake + ( graupel, hail )
4882  ifrsl( 1:2,ih,iss ) = iss
4883  ifrsl( 1,iss,ih ) = ig
4884  ifrsl( 2,iss,ih ) = ih
4885  !
4886  !
4887  !--- graupel + graupel -> graupel
4888  ifrsl( 1:2,ig,ig ) = ig
4889  !
4890  !--- graupel + hail -> ( graupel, hail )
4891  ifrsl( 1,ig,ih ) = ig
4892  ifrsl( 1,ih,ig ) = ig
4893  ifrsl( 2,ig,ih ) = ih
4894  ifrsl( 2,ih,ig ) = ih
4895  !
4896  !--- hail + hail -> hail
4897  ifrsl( 1:2,ih,ih ) = ih
4898 
4899  return
4900  end subroutine getrule
4901 
4902  !-----------------------------------------------------------------------------
4903  subroutine faero( &
4904  ijkmax, &
4905  f0, &
4906  ga )
4907  implicit none
4908 
4909  integer , intent(in) :: ijkmax
4910  real(rp), intent(in) :: f0(ijkmax)
4911  real(rp), intent(inout) :: ga(nccn,ijkmax)
4912 
4913 ! real(RP), parameter :: alpha = 3.0_RP
4914 
4915  integer :: ijk, n
4916  !---------------------------------------------------------------------------
4917 
4918  call prof_rapstart('_SBM_FAero', 3)
4919 
4920  do ijk = 1, ijkmax
4921  do n = 1, nccn
4922  ga(n,ijk) = ga(n,ijk) + f0(ijk) * marate(n) * expxactr(n) / dxaer ! [note] marate is never set.
4923  enddo
4924  enddo
4925 
4926  call prof_rapend ('_SBM_FAero', 3)
4927 
4928  return
4929  end subroutine faero
4930 
4931  !-----------------------------------------------------------------------------
4932  ! + Y. Sato added for stochastic method
4933  ! + Reference Sato et al. (2009) JGR, doi:10.1029/2008JD011247
4934  subroutine random_setup( mset ) !--- in
4935  use scale_random, only: &
4936  random_uniform
4937  use scale_prc, only: &
4938  prc_abort
4939 
4940  integer, intent(in) :: mset
4941 
4942  !--- local ----
4943  integer :: n
4944  real(rp) :: nbinr, tmp1
4945  real(rp) :: rans( mbin ), ranl( mbin )
4946  integer :: pq
4947  real(rp), allocatable :: ranstmp( : )
4948  real(rp), allocatable :: ranltmp( : )
4949  integer :: p, q
4950  integer :: k, temp
4951  integer, allocatable :: orderb( : )
4952  real(rp) :: abq1
4953  real(rp) :: a
4954  real(rp), allocatable :: randnum(:,:,:)
4955  !-------------------------------------------------------
4956  pq = nbin*(nbin-1)/2
4957  allocate( blrg( mset, mbin ) )
4958  allocate( bsml( mset, mbin ) )
4959  allocate( ranstmp( pq ) )
4960  allocate( ranltmp( pq ) )
4961  allocate( orderb( pq ) )
4962  allocate( randnum(1,1,pq) )
4963 
4964  a = real( nbin )*real( nbin-1 )*0.50_rp
4965  if ( a < mbin ) then
4966  log_error("ATMOS_PHY_MP_SUZUKI10_random_setup",*) "mbin should be smaller than {nbin}_C_{2}"
4967  call prc_abort
4968  endif
4969 
4970  wgtbin = a/real( mbin )
4971  nbinr = real( nbin )
4972 
4973  do p = 1, pq
4974  orderb( p ) = p
4975  enddo
4976 
4977  do p = 1, nbin-1
4978  ranstmp( (p-1)*nbin-(p*(p-1))/2+1 : p*nbin-(p*(p+1))/2 ) = p
4979  do q = 1, nbin-p
4980  ranltmp( (p-1)*nbin-(p*(p-1))/2+q ) = p+q
4981  enddo
4982  enddo
4983 
4984  do n = 1, mset
4985  call random_uniform( randnum )
4986  do p = 1, pq
4987  abq1 = randnum( 1,1,p )
4988  k = int( abq1*( pq-p-1 ) ) + p
4989  temp = orderb( p )
4990  orderb( p ) = orderb( k )
4991  orderb( k ) = temp
4992  enddo
4993 
4994  do p = 1, mbin
4995  if ( p <= pq ) then
4996  rans( p ) = ranstmp( orderb( p ) )
4997  ranl( p ) = ranltmp( orderb( p ) )
4998  else
4999  rans( p ) = ranstmp( orderb( p-pq ) )
5000  ranl( p ) = ranltmp( orderb( p-pq ) )
5001  endif
5002  if ( rans( p ) >= ranl( p ) ) then
5003  tmp1 = rans( p )
5004  rans( p ) = ranl( p )
5005  ranl( p ) = tmp1
5006  endif
5007  enddo
5008  blrg( n,1:mbin ) = int( ranl( 1:mbin ) )
5009  bsml( n,1:mbin ) = int( rans( 1:mbin ) )
5010  enddo
5011 
5012  deallocate( ranstmp )
5013  deallocate( ranltmp )
5014  deallocate( orderb )
5015  deallocate( randnum )
5016 
5017  end subroutine random_setup
5018 
5019  !-----------------------------------------------------------------------------
5020  !--- reference paper
5021  ! Bott et al. (1998) J. Atmos. Sci. vol.55, pp. 2284-
5022  ! Bott et al. (2000) J. Atmos. Sci. Vol.57, pp. 284-
5023  subroutine r_collcoag( &
5024  KA, IA, JA, &
5025  ijkmax, &
5026  swgt, &
5027  temp, &
5028  gc, &
5029  dtime )
5030  use scale_random, only: &
5031  random_uniform
5032  implicit none
5033 
5034  integer, intent(in) :: ka
5035  integer, intent(in) :: ia
5036  integer, intent(in) :: ja
5037 
5038  integer, intent(in) :: ijkmax
5039  real(rp), intent(in) :: swgt
5040  real(rp), intent(in) :: temp(ijkmax) ! Temperature [K]
5041  real(rp), intent(inout) :: gc (nbin,nspc,ijkmax) ! Mass size distribution function of hydrometeor
5042  real(dp), intent(in) :: dtime ! Time step interval
5043 
5044  integer :: i, j, k, l
5045  real(rp) :: xi, xj, xnew, dmpi, dmpj, frci, frcj
5046  real(rp) :: gprime, gprimk, wgt, crn, sum, flux
5047  integer, parameter :: ldeg = 2
5048  real(rp), parameter :: dmpmin = 1.e-01_rp, cmin = 1.e-10_rp
5049  real(rp) :: acoef( 0:ldeg )
5050  !
5051  !--- Y.sato added to use code6
5052  integer :: nums( mbin ), numl( mbin )
5053  real(rp), parameter :: gt = 1.0_rp
5054  integer :: s, det
5055  real(rp) :: nbinr, mbinr ! use to weight
5056 ! real(RP) :: beta
5057  real(rp) :: tmpi, tmpj
5058 
5059  integer :: ibnd( ijkmax )
5060  integer :: iflg( nspc,ijkmax )
5061  integer :: iexst( nbin,nspc,ijkmax )
5062  real(rp) :: csum( nspc,ijkmax )
5063  integer :: ijk, nn, mm, pp, qq, myu, n, isml, ilrg, irsl
5064  !---------------------------------------------------------------------------
5065 
5066  call prof_rapstart('_SBM_CollCoagR', 3)
5067 
5068  iflg( :,: ) = 0
5069  iexst( :,:,: ) = 0
5070  csum( :,: ) = 0.0_rp
5071  do ijk = 1, ijkmax
5072  !--- judgement of particle existence
5073  do n = 1, nbin
5074  csum( il,ijk ) = csum( il,ijk ) + gc( n,il,ijk )*dxmic
5075  csum( ic,ijk ) = csum( ic,ijk ) + gc( n,ic,ijk )*dxmic
5076  csum( ip,ijk ) = csum( ip,ijk ) + gc( n,ip,ijk )*dxmic
5077  csum( id,ijk ) = csum( id,ijk ) + gc( n,id,ijk )*dxmic
5078  csum( iss,ijk ) = csum( iss,ijk ) + gc( n,iss,ijk )*dxmic
5079  csum( ig,ijk ) = csum( ig,ijk ) + gc( n,ig,ijk )*dxmic
5080  csum( ih,ijk ) = csum( ih,ijk ) + gc( n,ih,ijk )*dxmic
5081  enddo
5082  if ( csum( il,ijk ) > cldmin ) iflg( il,ijk ) = 1
5083  if ( csum( ic,ijk ) > cldmin ) iflg( ic,ijk ) = 1
5084  if ( csum( ip,ijk ) > cldmin ) iflg( ip,ijk ) = 1
5085  if ( csum( id,ijk ) > cldmin ) iflg( id,ijk ) = 1
5086  if ( csum( iss,ijk ) > cldmin ) iflg( iss,ijk ) = 1
5087  if ( csum( ig,ijk ) > cldmin ) iflg( ig,ijk ) = 1
5088  if ( csum( ih,ijk ) > cldmin ) iflg( ih,ijk ) = 1
5089 
5090  if ( temp(ijk) < tcrit ) then
5091  ibnd(ijk) = 1
5092  else
5093  ibnd(ijk) = 2
5094  endif
5095 
5096  do myu = 1, nspc
5097  do n = 1, nbin
5098  if ( gc( n,myu,ijk ) > cldmin ) then
5099  iexst( n,myu,ijk ) = 1
5100  endif
5101  enddo
5102  enddo
5103 
5104  enddo
5105 
5106 !OCL PARALLEL
5107  do ijk = 1, ijkmax
5108  do isml = 1, nspc
5109  do nn = 1, iflg( isml,ijk )
5110 
5111  do ilrg = 1, nspc
5112  do mm = 1, iflg( ilrg,ijk )
5113  !--- rule of interaction
5114  irsl = ifrsl( ibnd(ijk),isml,ilrg )
5115 
5116  call random_uniform( rndm )
5117  det = int( rndm(1,1,1)*ia*ja*ka )
5118  nbinr = real( nbin )
5119  mbinr = real( mbin )
5120  nums( 1:mbin ) = bsml( det,1:mbin )
5121  numl( 1:mbin ) = blrg( det,1:mbin )
5122 
5123  do s = 1, mbin
5124  i = nums( s )
5125  j = numl( s )
5126 
5127  do pp = 1, iexst( i,isml,ijk )
5128  do qq = 1, iexst( j,ilrg,ijk )
5129 
5130  k = kindx( i,j )
5131  xi = expxctr( i )
5132  xj = expxctr( j )
5133  xnew = log( xi+xj )
5134 
5135  dmpi = ck( isml,ilrg,i,j )*gc( j,ilrg,ijk )/xj*dxmic*dtime
5136  dmpj = ck( ilrg,isml,i,j )*gc( i,isml,ijk )/xi*dxmic*dtime
5137 
5138  if ( dmpi <= dmpmin ) then
5139  frci = gc( i,isml,ijk )*dmpi
5140  else
5141  frci = gc( i,isml,ijk )*( 1.0_rp-exp( -dmpi ) )
5142  endif
5143 
5144  if ( dmpj <= dmpmin ) then
5145  frcj = gc( j,ilrg,ijk )*dmpj
5146  else
5147  frcj = gc( j,ilrg,ijk )*( 1.0_rp-exp( -dmpj ) )
5148  endif
5149  tmpi = gc( i,isml,ijk )
5150  tmpj = gc( j,ilrg,ijk )
5151 
5152  gc( i,isml,ijk ) = gc( i,isml,ijk )-frci*swgt
5153  gc( j,ilrg,ijk ) = gc( j,ilrg,ijk )-frcj*swgt
5154 
5155  if ( j /= k ) then
5156  gc( j,ilrg,ijk ) = max( gc( j,ilrg,ijk ), 0.0_rp )
5157  endif
5158  gc( i,isml,ijk ) = max( gc( i,isml,ijk ), 0.0_rp )
5159 
5160  frci = tmpi - gc( i,isml,ijk )
5161  frcj = tmpj - gc( j,ilrg,ijk )
5162 
5163  gprime = frci+frcj
5164 
5165  !-----------------------------------------------
5166  !--- Exponential Flux Method (Bott, 2000, JAS)
5167  !-----------------------------------------------
5168  ! if ( gprime <= 0.0_RP ) cycle !large
5169  ! if ( gprime > 0.0_RP .AND. k < nbin ) then
5170  ! gprimk = gc( (irsl-1)*nbin+k ) + gprime
5171  !
5172  ! beta = log( gc( (irsl-1)*nbin+k+1 )/gprimk+1.E-60_RP )
5173  ! crn = ( xnew-xctr( k ) )/( xctr( k+1 )-xctr( k ) )
5174  !
5175  ! flux = ( gprime/beta )*( exp( beta*0.50_RP ) -exp( beta*( 0.50_RP-crn ) ) )
5176  ! flux = min( gprimk ,gprime )
5177  !
5178  ! gc( (irsl-1)*nbin+k ) = gprimk - flux
5179  ! gc( (irsl-1)*nbin+k+1 ) = gc( (irsl-1)*nbin+k+1 ) + flux
5180  ! endif
5181 
5182  !-----------------------------------------------
5183  !--- Flux Method (Bott, 1998, JAS)
5184  !-----------------------------------------------
5185 ! if ( gprime <= 0.0_RP ) cycle !large
5186  if ( gprime > 0.0_rp .AND. k < nbin ) then
5187 
5188  gprimk = gc( k,irsl,ijk ) + gprime
5189  wgt = gprime / gprimk
5190  crn = ( xnew-xctr( k ) )/( xctr( k+1 )-xctr( k ) )
5191 
5192  acoef( 0 ) = -( gc( k+1,irsl,ijk )-26.0_rp*gprimk+gc( k-1,irsl,ijk ) )/24.0_rp
5193  acoef( 1 ) = ( gc( k+1,irsl,ijk )-gc( k-1,irsl,ijk ) ) *0.5_rp
5194  acoef( 2 ) = ( gc( k+1,irsl,ijk )-2.0_rp*gprimk+gc( k-1,irsl,ijk ) ) *0.50_rp
5195 
5196  sum = 0.0_rp
5197  do l = 0, ldeg
5198  sum = sum + acoef( l )/( l+1 )/2.0_rp**( l+1 ) &
5199  *( 1.0_rp-( 1.0_rp-2.0_rp*crn )**( l+1 ) )
5200  enddo
5201 
5202  flux = wgt*sum
5203  flux = min( max( flux,0.0_rp ),gprime )
5204 
5205  gc( k,irsl,ijk ) = gprimk - flux
5206  gc( k+1,irsl,ijk ) = gc( k+1,irsl,ijk ) + flux
5207  endif
5208 
5209  enddo
5210  enddo
5211 
5212  enddo ! bin
5213  !
5214  enddo
5215  enddo
5216 
5217  enddo
5218  enddo
5219 
5220  enddo
5221 
5222  call prof_rapend ('_SBM_CollCoagR', 3)
5223 
5224  return
5225  end subroutine r_collcoag
5226 
5227  !-----------------------------------------------------------------------------
5228  !----- mkpara is module to create micpara.dat, which is parameter file of
5229  !----- micrphyisical proprties of hydrometeors (collision kernel, radius...).
5230  !----- Imported from preprocess/mk_para2 at 2013/12/26 (Y.Sato)
5231  subroutine mkpara
5232 
5233  implicit none
5234 
5235  integer :: i, j
5236  !-----------------------------------------------------------------------------
5237 
5238  allocate( radc_mk( nbin ) )
5239  allocate( xctr_mk( nbin ) )
5240  allocate( xbnd_mk( nbin+1 ) )
5241  allocate( cctr_mk( nspc_mk,nbin ) )
5242  allocate( cbnd_mk( nspc_mk,nbin+1 ) )
5243  allocate( ck_mk( nspc_mk,nspc_mk,nbin,nbin ) )
5244  allocate( vt_mk( nspc_mk,nbin ) )
5245  allocate( br_mk( nspc_mk,nbin ) )
5246 
5247  !--- file reading
5248  call rdkdat
5249 
5250  !--- grid setting
5251  call sdfgrid
5252 
5253  !--- capacity
5254  call getcp
5255 
5256  !--- collection kernel
5257  call getck
5258 
5259  !--- terminal velocity
5260  call getvt
5261 
5262  !--- bulk radius
5263  call getbr
5264 
5265  !--- output
5266  call paraout
5267 
5268  deallocate( radc_mk )
5269  deallocate( xctr_mk )
5270  deallocate( xbnd_mk )
5271  deallocate( cctr_mk )
5272  deallocate( cbnd_mk )
5273  deallocate( ck_mk )
5274  deallocate( vt_mk )
5275  deallocate( br_mk )
5276 
5277  end subroutine mkpara
5278 
5279  !---------------------------------------------------------------------------------------
5280  subroutine rdkdat
5281 
5282  implicit none
5283  integer, parameter :: il = 1, ic = 2, ip = 3, id = 4
5284  integer, parameter :: is = 5, ig = 6, ih = 7
5285  integer, parameter :: icemax = 3
5286 
5287  integer :: k, kk, i, j
5288  real(dp) :: xl( ndat ), rlec( ndat ), vrl( ndat )
5289  real(dp) :: blkradl( ndat ), blkdnsl( ndat )
5290 
5291  real(dp) :: xi( ndat,icemax ), riec( ndat,icemax ), vri( ndat,icemax )
5292  real(dp) :: blkradi( ndat,icemax ), blkdnsi( ndat,icemax )
5293 
5294  real(dp) :: xs( ndat ), rsec( ndat ), vrs( ndat )
5295  real(dp) :: blkrads( ndat ), blkdnss( ndat )
5296 
5297  real(dp) :: xg( ndat ), rgec( ndat ), vrg( ndat )
5298  real(dp) :: blkradg( ndat ), blkdnsg( ndat )
5299 
5300  real(dp) :: xh( ndat ), rhec( ndat ), vrh( ndat )
5301  real(dp) :: blkradh( ndat ), blkdnsh( ndat )
5302 
5303  data xl(1:ndat) / &
5304  0.33510e-10_dp,0.67021e-10_dp,0.13404e-09_dp,0.26808e-09_dp,0.53617e-09_dp,0.10723e-08_dp, &
5305  0.21447e-08_dp,0.42893e-08_dp,0.85786e-08_dp,0.17157e-07_dp,0.34315e-07_dp,0.68629e-07_dp, &
5306  0.13726e-06_dp,0.27452e-06_dp,0.54903e-06_dp,0.10981e-05_dp,0.21961e-05_dp,0.43923e-05_dp, &
5307  0.87845e-05_dp,0.17569e-04_dp,0.35138e-04_dp,0.70276e-04_dp,0.14055e-03_dp,0.28110e-03_dp, &
5308  0.56221e-03_dp,0.11244e-02_dp,0.22488e-02_dp,0.44977e-02_dp,0.89954e-02_dp,0.17991e-01_dp, &
5309  0.35981e-01_dp,0.71963e-01_dp,0.14393e+00_dp /
5310  data xi(1:ndat,1) / &
5311  0.33510e-10_dp,0.67021e-10_dp,0.13404e-09_dp,0.26808e-09_dp,0.53617e-09_dp,0.10723e-08_dp, &
5312  0.21447e-08_dp,0.42893e-08_dp,0.85786e-08_dp,0.17157e-07_dp,0.34315e-07_dp,0.68629e-07_dp, &
5313  0.13726e-06_dp,0.27452e-06_dp,0.54903e-06_dp,0.10981e-05_dp,0.21961e-05_dp,0.43923e-05_dp, &
5314  0.87845e-05_dp,0.17569e-04_dp,0.35138e-04_dp,0.70276e-04_dp,0.14055e-03_dp,0.28110e-03_dp, &
5315  0.56221e-03_dp,0.11244e-02_dp,0.22488e-02_dp,0.44977e-02_dp,0.89954e-02_dp,0.17991e-01_dp, &
5316  0.35981e-01_dp,0.71963e-01_dp,0.14393e+00_dp /
5317  data xi(1:ndat,2) / &
5318  0.33510e-10_dp,0.67021e-10_dp,0.13404e-09_dp,0.26808e-09_dp,0.53617e-09_dp,0.10723e-08_dp, &
5319  0.21447e-08_dp,0.42893e-08_dp,0.85786e-08_dp,0.17157e-07_dp,0.34315e-07_dp,0.68629e-07_dp, &
5320  0.13726e-06_dp,0.27452e-06_dp,0.54903e-06_dp,0.10981e-05_dp,0.21961e-05_dp,0.43923e-05_dp, &
5321  0.87845e-05_dp,0.17569e-04_dp,0.35138e-04_dp,0.70276e-04_dp,0.14055e-03_dp,0.28110e-03_dp, &
5322  0.56221e-03_dp,0.11244e-02_dp,0.22488e-02_dp,0.44977e-02_dp,0.89954e-02_dp,0.17991e-01_dp, &
5323  0.35981e-01_dp,0.71963e-01_dp,0.14393e+00 /
5324  data xi(1:ndat,3) / &
5325  0.33510e-10_dp,0.67021e-10_dp,0.13404e-09_dp,0.26808e-09_dp,0.53617e-09_dp,0.10723e-08_dp, &
5326  0.21447e-08_dp,0.42893e-08_dp,0.85786e-08_dp,0.17157e-07_dp,0.34315e-07_dp,0.68629e-07_dp, &
5327  0.13726e-06_dp,0.27452e-06_dp,0.54903e-06_dp,0.10981e-05_dp,0.21961e-05_dp,0.43923e-05_dp, &
5328  0.87845e-05_dp,0.17569e-04_dp,0.35138e-04_dp,0.70276e-04_dp,0.14055e-03_dp,0.28110e-03_dp, &
5329  0.56221e-03_dp,0.11244e-02_dp,0.22488e-02_dp,0.44977e-02_dp,0.89954e-02_dp,0.17991e-01_dp, &
5330  0.35981e-01_dp,0.71963e-01_dp,0.14393e+00_dp /
5331  data xs(1:ndat) / &
5332  0.33510e-10_dp,0.67021e-10_dp,0.13404e-09_dp,0.26808e-09_dp,0.53617e-09_dp,0.10723e-08_dp, &
5333  0.21447e-08_dp,0.42893e-08_dp,0.85786e-08_dp,0.17157e-07_dp,0.34315e-07_dp,0.68629e-07_dp, &
5334  0.13726e-06_dp,0.27452e-06_dp,0.54903e-06_dp,0.10981e-05_dp,0.21961e-05_dp,0.43923e-05_dp, &
5335  0.87845e-05_dp,0.17569e-04_dp,0.35138e-04_dp,0.70276e-04_dp,0.14055e-03_dp,0.28110e-03_dp, &
5336  0.56221e-03_dp,0.11244e-02_dp,0.22488e-02_dp,0.44977e-02_dp,0.89954e-02_dp,0.17991e-01_dp, &
5337  0.35981e-01_dp,0.71963e-01_dp,0.14393e+00_dp /
5338  data xg(1:ndat) / &
5339  0.33510e-10_dp,0.67021e-10_dp,0.13404e-09_dp,0.26808e-09_dp,0.53617e-09_dp,0.10723e-08_dp, &
5340  0.21447e-08_dp,0.42893e-08_dp,0.85786e-08_dp,0.17157e-07_dp,0.34315e-07_dp,0.68629e-07_dp, &
5341  0.13726e-06_dp,0.27452e-06_dp,0.54903e-06_dp,0.10981e-05_dp,0.21961e-05_dp,0.43923e-05_dp, &
5342  0.87845e-05_dp,0.17569e-04_dp,0.35138e-04_dp,0.70276e-04_dp,0.14055e-03_dp,0.28110e-03_dp, &
5343  0.56221e-03_dp,0.11244e-02_dp,0.22488e-02_dp,0.44977e-02_dp,0.89954e-02_dp,0.17991e-01_dp, &
5344  0.35981e-01_dp,0.71963e-01_dp,0.14393e+00_dp /
5345  data xh(1:ndat) / &
5346  0.33510e-10_dp,0.67021e-10_dp,0.13404e-09_dp,0.26808e-09_dp,0.53617e-09_dp,0.10723e-08_dp, &
5347  0.21447e-08_dp,0.42893e-08_dp,0.85786e-08_dp,0.17157e-07_dp,0.34315e-07_dp,0.68629e-07_dp, &
5348  0.13726e-06_dp,0.27452e-06_dp,0.54903e-06_dp,0.10981e-05_dp,0.21961e-05_dp,0.43923e-05_dp, &
5349  0.87845e-05_dp,0.17569e-04_dp,0.35138e-04_dp,0.70276e-04_dp,0.14055e-03_dp,0.28110e-03_dp, &
5350  0.56221e-03_dp,0.11244e-02_dp,0.22488e-02_dp,0.44977e-02_dp,0.89954e-02_dp,0.17991e-01_dp, &
5351  0.35981e-01_dp,0.71963e-01_dp,0.14393e+00_dp /
5352  data rlec(1:ndat) / &
5353  0.20000e-03_dp,0.25198e-03_dp,0.31748e-03_dp,0.40000e-03_dp,0.50397e-03_dp,0.63496e-03_dp, &
5354  0.80000e-03_dp,0.10079e-02_dp,0.12699e-02_dp,0.16000e-02_dp,0.20159e-02_dp,0.25398e-02_dp, &
5355  0.32000e-02_dp,0.40317e-02_dp,0.50797e-02_dp,0.64000e-02_dp,0.80635e-02_dp,0.10159e-01_dp, &
5356  0.12800e-01_dp,0.16127e-01_dp,0.20319e-01_dp,0.25600e-01_dp,0.32254e-01_dp,0.40637e-01_dp, &
5357  0.51200e-01_dp,0.64508e-01_dp,0.81275e-01_dp,0.10240e+00_dp,0.12902e+00_dp,0.16255e+00_dp, &
5358  0.20480e+00_dp,0.25803e+00_dp,0.32510e+00_dp /
5359  data riec(1:ndat,1) / &
5360  0.31936e-03_dp,0.40397e-03_dp,0.51099e-03_dp,0.64638e-03_dp,0.81764e-03_dp,0.10343e-02_dp, &
5361  0.13084e-02_dp,0.16551e-02_dp,0.20937e-02_dp,0.26486e-02_dp,0.33506e-02_dp,0.42387e-02_dp, &
5362  0.64360e-02_dp,0.81426e-02_dp,0.10302e-01_dp,0.13035e-01_dp,0.16494e-01_dp,0.20872e-01_dp, &
5363  0.26412e-01_dp,0.33426e-01_dp,0.42304e-01_dp,0.53543e-01_dp,0.67770e-01_dp,0.85783e-01_dp, &
5364  0.10859e+00_dp,0.13746e+00_dp,0.17403e+00_dp,0.22032e+00_dp,0.27895e+00_dp,0.35319e+00_dp, &
5365  0.44722e+00_dp,0.56630e+00_dp,0.71712e+00_dp /
5366  data riec(1:ndat,2) / &
5367  0.13188e-03_dp,0.16615e-03_dp,0.20953e-03_dp,0.27728e-03_dp,0.36694e-03_dp,0.48559e-03_dp, &
5368  0.64261e-03_dp,0.85040e-03_dp,0.11254e-02_dp,0.14893e-02_dp,0.19709e-02_dp,0.26082e-02_dp, &
5369  0.34515e-02_dp,0.45676e-02_dp,0.60446e-02_dp,0.79991e-02_dp,0.10586e-01_dp,0.14009e-01_dp, &
5370  0.18539e-01_dp,0.24533e-01_dp,0.32466e-01_dp,0.42964e-01_dp,0.56857e-01_dp,0.75242e-01_dp, &
5371  0.99573e-01_dp,0.13177e+00_dp,0.17438e+00_dp,0.23077e+00_dp,0.30539e+00_dp,0.40414e+00_dp, &
5372  0.53482e+00_dp,0.70775e+00_dp,0.93661e+00_dp /
5373  data riec(1:ndat,3) / 0.14998e-03_dp,0.18896e-03_dp,0.23808e-03_dp, &
5374  0.29996e-03_dp,0.37793e-03_dp,0.47616e-03_dp,0.61048e-03_dp,0.81343e-03_dp,0.10839e-02_dp, &
5375  0.14442e-02_dp,0.19243e-02_dp,0.25640e-02_dp,0.34164e-02_dp,0.45522e-02_dp,0.60656e-02_dp, &
5376  0.80820e-02_dp,0.10769e-01_dp,0.14349e-01_dp,0.19119e-01_dp,0.25475e-01_dp,0.44576e-01_dp, &
5377  0.62633e-01_dp,0.88006e-01_dp,0.12366e+00_dp,0.17375e+00_dp,0.24414e+00_dp,0.34304e+00_dp, &
5378  0.48201e+00_dp,0.67728e+00_dp,0.95164e+00_dp,0.13372e+01_dp,0.18788e+01_dp,0.26400e+01_dp /
5379  data rsec(1:ndat) / &
5380  0.92832e-03_dp,0.11696e-02_dp,0.14736e-02_dp,0.18566e-02_dp,0.23392e-02_dp,0.29472e-02_dp, &
5381  0.37133e-02_dp,0.46784e-02_dp,0.58944e-02_dp,0.74265e-02_dp,0.93569e-02_dp,0.11789e-01_dp, &
5382  0.14853e-01_dp,0.18714e-01_dp,0.23578e-01_dp,0.29706e-01_dp,0.37427e-01_dp,0.47156e-01_dp, &
5383  0.59412e-01_dp,0.74855e-01_dp,0.94311e-01_dp,0.11882e+00_dp,0.14971e+00_dp,0.18862e+00_dp, &
5384  0.23765e+00_dp,0.29942e+00_dp,0.37724e+00_dp,0.47530e+00_dp,0.59884e+00_dp,0.75449e+00_dp, &
5385  0.95060e+00_dp,0.11977e+01_dp,0.15090e+01_dp /
5386  data rgec(1:ndat) / 0.27144e-03_dp,0.34200e-03_dp,0.43089e-03_dp, &
5387  0.54288e-03_dp,0.68399e-03_dp,0.86177e-03_dp,0.10858e-02_dp,0.13680e-02_dp,0.17235e-02_dp, &
5388  0.21715e-02_dp,0.27360e-02_dp,0.34471e-02_dp,0.43431e-02_dp,0.54719e-02_dp,0.68942e-02_dp, &
5389  0.86861e-02_dp,0.10944e-01_dp,0.13788e-01_dp,0.17372e-01_dp,0.21888e-01_dp,0.27577e-01_dp, &
5390  0.34745e-01_dp,0.43775e-01_dp,0.55154e-01_dp,0.69489e-01_dp,0.87551e-01_dp,0.11031e+00_dp, &
5391  0.13898e+00_dp,0.17510e+00_dp,0.22061e+00_dp,0.27796e+00_dp,0.35020e+00_dp,0.44123e+00_dp /
5392  data rhec(1:ndat) / &
5393  0.20715e-03_dp,0.26099e-03_dp,0.32883e-03_dp,0.41430e-03_dp,0.52198e-03_dp,0.65766e-03_dp, &
5394  0.82860e-03_dp,0.10440e-02_dp,0.13153e-02_dp,0.16572e-02_dp,0.20879e-02_dp,0.26306e-02_dp, &
5395  0.33144e-02_dp,0.41759e-02_dp,0.52613e-02_dp,0.66288e-02_dp,0.83517e-02_dp,0.10523e-01_dp, &
5396  0.13258e-01_dp,0.16703e-01_dp,0.21045e-01_dp,0.26515e-01_dp,0.33407e-01_dp,0.42090e-01_dp, &
5397  0.53030e-01_dp,0.66814e-01_dp,0.84180e-01_dp,0.10606e+00_dp,0.13363e+00_dp,0.16836e+00_dp, &
5398  0.21212e+00_dp,0.26725e+00_dp,0.33672e+00_dp /
5399  data vrl(1:ndat) / &
5400  0.50000e-01_dp,0.78000e-01_dp,0.12000e+00_dp,0.19000e+00_dp,0.31000e+00_dp,0.49000e+00_dp, &
5401  0.77000e+00_dp,0.12000e+01_dp,0.19000e+01_dp,0.30000e+01_dp,0.48000e+01_dp,0.74000e+01_dp, &
5402  0.11000e+02_dp,0.17000e+02_dp,0.26000e+02_dp,0.37000e+02_dp,0.52000e+02_dp,0.71000e+02_dp, &
5403  0.94000e+02_dp,0.12000e+03_dp,0.16000e+03_dp,0.21000e+03_dp,0.26000e+03_dp,0.33000e+03_dp, &
5404  0.41000e+03_dp,0.48000e+03_dp,0.57000e+03_dp,0.66000e+03_dp,0.75000e+03_dp,0.82000e+03_dp, &
5405  0.88000e+03_dp,0.90000e+03_dp,0.90000e+03_dp /
5406  data vri(1:ndat,1) / 0.30000e-01_dp,0.40000e-01_dp,0.60000e-01_dp, &
5407  0.80000e-01_dp,0.11000e+00_dp,0.15000e+00_dp,0.17000e+00_dp,0.18000e+00_dp,0.20000e+00_dp, &
5408  0.25000e+00_dp,0.40000e+00_dp,0.60000e+01_dp,0.10000e+02_dp,0.15000e+02_dp,0.20000e+02_dp, &
5409  0.25000e+02_dp,0.31000e+02_dp,0.37000e+02_dp,0.41000e+02_dp,0.46000e+02_dp,0.51000e+02_dp, &
5410  0.55000e+02_dp,0.59000e+02_dp,0.62000e+02_dp,0.64000e+02_dp,0.67000e+02_dp,0.68000e+02_dp, &
5411  0.69000e+02_dp,0.70000e+02_dp,0.71000e+02_dp,0.71500e+02_dp,0.71750e+02_dp,0.72000e+02_dp /
5412  data vri(1:ndat,2) / &
5413  0.30000e-01_dp,0.40000e-01_dp,0.50000e-01_dp,0.70000e-01_dp,0.90000e-01_dp,0.12000e+00_dp, &
5414  0.50000e+00_dp,0.80000e+00_dp,0.16000e+01_dp,0.18000e+01_dp,0.20000e+01_dp,0.30000e+01_dp, &
5415  0.40000e+01_dp,0.50000e+01_dp,0.80000e+01_dp,0.13000e+02_dp,0.19000e+02_dp,0.26000e+02_dp, &
5416  0.32000e+02_dp,0.38000e+02_dp,0.47000e+02_dp,0.55000e+02_dp,0.65000e+02_dp,0.73000e+02_dp, &
5417  0.77000e+02_dp,0.79000e+02_dp,0.80000e+02_dp,0.81000e+02_dp,0.81000e+02_dp,0.82000e+02_dp, &
5418  0.82000e+02_dp,0.82000e+02_dp,0.82000e+02_dp /
5419  data vri(1:ndat,3) / 0.35000e-01_dp,0.45000e-01_dp,0.55000e-01_dp, &
5420  0.75000e-01_dp,0.95000e-01_dp,0.13000e+00_dp,0.60000e+00_dp,0.90000e+00_dp,0.17000e+01_dp, &
5421  0.20000e+01_dp,0.25000e+01_dp,0.38000e+01_dp,0.50000e+01_dp,0.70000e+01_dp,0.90000e+01_dp, &
5422  0.11000e+02_dp,0.14000e+02_dp,0.17000e+02_dp,0.21000e+02_dp,0.25000e+02_dp,0.32000e+02_dp, &
5423  0.38000e+02_dp,0.44000e+02_dp,0.49000e+02_dp,0.53000e+02_dp,0.55000e+02_dp,0.58000e+02_dp, &
5424  0.59000e+02_dp,0.61000e+02_dp,0.62000e+02_dp,0.63000e+02_dp,0.64000e+02_dp,0.65000e+02_dp /
5425  data vrs(1:ndat) / &
5426  0.20000e-01_dp,0.31000e-01_dp,0.49000e-01_dp,0.77000e-01_dp,0.12000e+00_dp,0.19000e+00_dp, &
5427  0.30000e+00_dp,0.48000e+00_dp,0.76000e+00_dp,0.12000e+01_dp,0.19000e+01_dp,0.30000e+01_dp, &
5428  0.48000e+01_dp,0.75000e+01_dp,0.11000e+02_dp,0.16000e+02_dp,0.21000e+02_dp,0.26000e+02_dp, &
5429  0.34000e+02_dp,0.41000e+02_dp,0.49000e+02_dp,0.57000e+02_dp,0.65000e+02_dp,0.73000e+02_dp, &
5430  0.81000e+02_dp,0.87000e+02_dp,0.93000e+02_dp,0.99000e+02_dp,0.10750e+03_dp,0.11500e+03_dp, &
5431  0.12500e+03_dp,0.13500e+03_dp,0.14500e+03_dp /
5432  data vrg(1:ndat) / 0.39000e-01_dp,0.62000e-01_dp,0.97000e-01_dp, &
5433  0.15000e+00_dp,0.24000e+00_dp,0.38000e+00_dp,0.61000e+00_dp,0.96000e+00_dp,0.15000e+01_dp, &
5434  0.24000e+01_dp,0.38000e+01_dp,0.61000e+01_dp,0.96000e+01_dp,0.15000e+02_dp,0.23000e+02_dp, &
5435  0.31000e+02_dp,0.39000e+02_dp,0.49000e+02_dp,0.59000e+02_dp,0.68000e+02_dp,0.79000e+02_dp, &
5436  0.88000e+02_dp,0.10000e+03_dp,0.11000e+03_dp,0.13000e+03_dp,0.15000e+03_dp,0.17000e+03_dp, &
5437  0.20000e+03_dp,0.23000e+03_dp,0.26000e+03_dp,0.30000e+03_dp,0.35000e+03_dp,0.40000e+03_dp /
5438  data vrh(1:ndat) / &
5439  0.53000e-01_dp,0.84000e-01_dp,0.13000e+00_dp,0.21000e+00_dp,0.33000e+00_dp,0.52000e+00_dp, &
5440  0.82000e+00_dp,0.13000e+01_dp,0.21000e+01_dp,0.33000e+01_dp,0.52000e+01_dp,0.82000e+01_dp, &
5441  0.13000e+02_dp,0.20000e+02_dp,0.28000e+02_dp,0.36000e+02_dp,0.46000e+02_dp,0.56000e+02_dp, &
5442  0.67000e+02_dp,0.80000e+02_dp,0.97000e+02_dp,0.12000e+03_dp,0.14000e+03_dp,0.17000e+03_dp, &
5443  0.20000e+03_dp,0.24000e+03_dp,0.29000e+03_dp,0.35000e+03_dp,0.42000e+03_dp,0.51000e+03_dp, &
5444  0.61000e+03_dp,0.74000e+03_dp,0.89000e+03_dp /
5445  data blkradl(1:ndat) / &
5446  0.20000e-03_dp,0.25198e-03_dp,0.31748e-03_dp,0.40000e-03_dp,0.50397e-03_dp,0.63496e-03_dp, &
5447  0.80000e-03_dp,0.10079e-02_dp,0.12699e-02_dp,0.16000e-02_dp,0.20159e-02_dp,0.25398e-02_dp, &
5448  0.32000e-02_dp,0.40317e-02_dp,0.50797e-02_dp,0.64000e-02_dp,0.80635e-02_dp,0.10159e-01_dp, &
5449  0.12800e-01_dp,0.16127e-01_dp,0.20319e-01_dp,0.25600e-01_dp,0.32254e-01_dp,0.40637e-01_dp, &
5450  0.51200e-01_dp,0.64508e-01_dp,0.81275e-01_dp,0.10240e+00_dp,0.12902e+00_dp,0.16255e+00_dp, &
5451  0.20480e+00_dp,0.25803e+00_dp,0.32510e+00_dp /
5452  data blkradi(1:ndat,1) / 0.57452e-03_dp,0.72384e-03_dp,0.91199e-03_dp, &
5453  0.11490e-02_dp,0.14477e-02_dp,0.18240e-02_dp,0.22981e-02_dp,0.28954e-02_dp,0.36479e-02_dp, &
5454  0.45961e-02_dp,0.57908e-02_dp,0.72959e-02_dp,0.11572e-01_dp,0.14770e-01_dp,0.18851e-01_dp, &
5455  0.24060e-01_dp,0.30709e-01_dp,0.39194e-01_dp,0.50025e-01_dp,0.63848e-01_dp,0.81491e-01_dp, &
5456  0.10401e+00_dp,0.13275e+00_dp,0.16943e+00_dp,0.21625e+00_dp,0.27601e+00_dp,0.35228e+00_dp, &
5457  0.44962e+00_dp,0.57387e+00_dp,0.73244e+00_dp,0.93484e+00_dp,0.11932e+01_dp,0.15229e+01_dp /
5458  data blkradi(1:ndat,2) / &
5459  0.20715e-03_dp,0.26099e-03_dp,0.32912e-03_dp,0.43555e-03_dp,0.57638e-03_dp,0.76276e-03_dp, &
5460  0.10094e-02_dp,0.13358e-02_dp,0.17677e-02_dp,0.23394e-02_dp,0.30958e-02_dp,0.40969e-02_dp, &
5461  0.54216e-02_dp,0.71748e-02_dp,0.94948e-02_dp,0.12565e-01_dp,0.16628e-01_dp,0.22005e-01_dp, &
5462  0.29120e-01_dp,0.38537e-01_dp,0.50998e-01_dp,0.67488e-01_dp,0.89311e-01_dp,0.11819e+00_dp, &
5463  0.15641e+00_dp,0.20698e+00_dp,0.27391e+00_dp,0.36249e+00_dp,0.47970e+00_dp,0.63481e+00_dp, &
5464  0.84009e+00_dp,0.11117e+01_dp,0.14712e+01_dp /
5465  data blkradi(1:ndat,3) / 0.23559e-03_dp,0.29682e-03_dp,0.37397e-03_dp, &
5466  0.47118e-03_dp,0.59365e-03_dp,0.74795e-03_dp,0.95894e-03_dp,0.12777e-02_dp,0.17025e-02_dp, &
5467  0.22685e-02_dp,0.30227e-02_dp,0.40275e-02_dp,0.53665e-02_dp,0.71506e-02_dp,0.95278e-02_dp, &
5468  0.12695e-01_dp,0.16916e-01_dp,0.22539e-01_dp,0.30032e-01_dp,0.40017e-01_dp,0.70019e-01_dp, &
5469  0.98384e-01_dp,0.13824e+00_dp,0.19424e+00_dp,0.27293e+00_dp,0.38350e+00_dp,0.53885e+00_dp, &
5470  0.75714e+00_dp,0.10639e+01_dp,0.14948e+01_dp,0.21004e+01_dp,0.29513e+01_dp,0.41469e+01_dp /
5471  data blkrads(1:ndat) / &
5472  0.20715e-03_dp,0.26148e-03_dp,0.33067e-03_dp,0.41710e-03_dp,0.52691e-03_dp,0.66640e-03_dp, &
5473  0.84289e-03_dp,0.10674e-02_dp,0.13513e-02_dp,0.17129e-02_dp,0.21670e-02_dp,0.27521e-02_dp, &
5474  0.34989e-02_dp,0.44777e-02_dp,0.57347e-02_dp,0.75389e-02_dp,0.99020e-02_dp,0.13161e-01_dp, &
5475  0.17372e-01_dp,0.23337e-01_dp,0.31058e-01_dp,0.41194e-01_dp,0.55153e-01_dp,0.74854e-01_dp, &
5476  0.99806e-01_dp,0.13463e+00_dp,0.18136e+00_dp,0.24282e+00_dp,0.32955e+00_dp,0.44123e+00_dp, &
5477  0.59884e+00_dp,0.77090e+00_dp,0.99387e+00_dp /
5478  data blkradg(1:ndat) / 0.27144e-03_dp,0.34200e-03_dp,0.43089e-03_dp, &
5479  0.54288e-03_dp,0.68399e-03_dp,0.86177e-03_dp,0.10858e-02_dp,0.13680e-02_dp,0.17235e-02_dp, &
5480  0.21715e-02_dp,0.27360e-02_dp,0.34471e-02_dp,0.43431e-02_dp,0.54719e-02_dp,0.68942e-02_dp, &
5481  0.86861e-02_dp,0.10944e-01_dp,0.13788e-01_dp,0.17372e-01_dp,0.21888e-01_dp,0.27577e-01_dp, &
5482  0.34745e-01_dp,0.43775e-01_dp,0.55154e-01_dp,0.69489e-01_dp,0.87551e-01_dp,0.11031e+00_dp, &
5483  0.13898e+00_dp,0.17510e+00_dp,0.22061e+00_dp,0.27796e+00_dp,0.35020e+00_dp,0.44123e+00_dp /
5484  data blkradh(1:ndat) / &
5485  0.20715e-03_dp,0.26099e-03_dp,0.32883e-03_dp,0.41430e-03_dp,0.52198e-03_dp,0.65766e-03_dp, &
5486  0.82860e-03_dp,0.10440e-02_dp,0.13153e-02_dp,0.16572e-02_dp,0.20879e-02_dp,0.26306e-02_dp, &
5487  0.33144e-02_dp,0.41759e-02_dp,0.52613e-02_dp,0.66288e-02_dp,0.83517e-02_dp,0.10523e-01_dp, &
5488  0.13258e-01_dp,0.16703e-01_dp,0.21045e-01_dp,0.26515e-01_dp,0.33407e-01_dp,0.42090e-01_dp, &
5489  0.53030e-01_dp,0.66814e-01_dp,0.84180e-01_dp,0.10606e+00_dp,0.13363e+00_dp,0.16836e+00_dp, &
5490  0.21212e+00_dp,0.26725e+00_dp,0.33672e+00_dp /
5491  data blkdnsl(1:ndat) / &
5492  0.10000e+01_dp,0.10000e+01_dp,0.10000e+01_dp,0.10000e+01_dp,0.10000e+01_dp,0.10000e+01_dp, &
5493  0.10000e+01_dp,0.10000e+01_dp,0.10000e+01_dp,0.10000e+01_dp,0.10000e+01_dp,0.10000e+01_dp, &
5494  0.10000e+01_dp,0.10000e+01_dp,0.10000e+01_dp,0.10000e+01_dp,0.10000e+01_dp,0.10000e+01_dp, &
5495  0.10000e+01_dp,0.10000e+01_dp,0.10000e+01_dp,0.10000e+01_dp,0.10000e+01_dp,0.10000e+01_dp, &
5496  0.10000e+01_dp,0.10000e+01_dp,0.10000e+01_dp,0.10000e+01_dp,0.10000e+01_dp,0.10000e+01_dp, &
5497  0.10000e+01_dp,0.10000e+01_dp,0.10000e+01_dp /
5498  data blkdnsi(1:ndat,1) / 0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp, &
5499  0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp, &
5500  0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp,0.87368e+00_dp,0.87072e+00_dp,0.86777e+00_dp, &
5501  0.86483e+00_dp,0.86189e+00_dp,0.85897e+00_dp,0.85606e+00_dp,0.85316e+00_dp,0.85026e+00_dp, &
5502  0.84738e+00_dp,0.84451e+00_dp,0.84164e+00_dp,0.83879e+00_dp,0.83595e+00_dp,0.83311e+00_dp, &
5503  0.83029e+00_dp,0.82747e+00_dp,0.82467e+00_dp,0.82187e+00_dp,0.81908e+00_dp,0.81631e+00_dp /
5504  data blkdnsi(1:ndat,2) / &
5505  0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp, &
5506  0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp, &
5507  0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp, &
5508  0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp, &
5509  0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp, &
5510  0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp /
5511  data blkdnsi(1:ndat,3) / 0.61183e+00_dp,0.61183e+00_dp,0.61183e+00_dp, &
5512  0.61183e+00_dp,0.61183e+00_dp,0.61183e+00_dp,0.61183e+00_dp,0.61183e+00_dp,0.61183e+00_dp, &
5513  0.61183e+00_dp,0.61183e+00_dp,0.61183e+00_dp,0.61183e+00_dp,0.61183e+00_dp,0.61183e+00_dp, &
5514  0.61183e+00_dp,0.61183e+00_dp,0.61183e+00_dp,0.61183e+00_dp,0.61183e+00_dp,0.51790e+00_dp, &
5515  0.45557e+00_dp,0.40075e+00_dp,0.35252e+00_dp,0.31010e+00_dp,0.27278e+00_dp,0.23995e+00_dp, &
5516  0.21108e+00_dp,0.18567e+00_dp,0.16333e+00_dp,0.14367e+00_dp,0.12638e+00_dp,0.11118e+00_dp /
5517  data blkdnss(1:ndat) / &
5518  0.90000e+00_dp,0.89500e+00_dp,0.88500e+00_dp,0.88200e+00_dp,0.87500e+00_dp,0.86500e+00_dp, &
5519  0.85500e+00_dp,0.84200e+00_dp,0.83000e+00_dp,0.81500e+00_dp,0.80500e+00_dp,0.78600e+00_dp, &
5520  0.76500e+00_dp,0.73000e+00_dp,0.69500e+00_dp,0.61183e+00_dp,0.54000e+00_dp,0.46000e+00_dp, &
5521  0.40000e+00_dp,0.33000e+00_dp,0.28000e+00_dp,0.24000e+00_dp,0.20000e+00_dp,0.16000e+00_dp, &
5522  0.13500e+00_dp,0.11000e+00_dp,0.90000e-01_dp,0.75000e-01_dp,0.60000e-01_dp,0.50000e-01_dp, &
5523  0.40000e-01_dp,0.37500e-01_dp,0.35000e-01_dp /
5524  data blkdnsg(1:ndat) / &
5525  0.40000e+00_dp,0.40000e+00_dp,0.40000e+00_dp,0.40000e+00_dp,0.40000e+00_dp,0.40000e+00_dp, &
5526  0.40000e+00_dp,0.40000e+00_dp,0.40000e+00_dp,0.40000e+00_dp,0.40000e+00_dp,0.40000e+00_dp, &
5527  0.40000e+00_dp,0.40000e+00_dp,0.40000e+00_dp,0.40000e+00_dp,0.40000e+00_dp,0.40000e+00_dp, &
5528  0.40000e+00_dp,0.40000e+00_dp,0.40000e+00_dp,0.40000e+00_dp,0.40000e+00_dp,0.40000e+00_dp, &
5529  0.40000e+00_dp,0.40000e+00_dp,0.40000e+00_dp,0.40000e+00_dp,0.40000e+00_dp,0.40000e+00_dp, &
5530  0.40000e+00_dp,0.40000e+00_dp,0.40000e+00_dp /
5531  data blkdnsh(1:ndat) / &
5532  0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp, &
5533  0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp, &
5534  0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp, &
5535  0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp, &
5536  0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp, &
5537  0.90000e+00_dp,0.90000e+00_dp,0.90000e+00_dp /
5538 
5539  !--- mass
5540  do k = 1, ndat
5541  xmss( il,k ) = log( dble( xl( k ) )*1.e-03_dp )
5542  xmss( ic,k ) = log( dble( xi( k,1 ) )*1.e-03_dp )
5543  xmss( ip,k ) = log( dble( xi( k,2 ) )*1.e-03_dp )
5544  xmss( id,k ) = log( dble( xi( k,3 ) )*1.e-03_dp )
5545  xmss( is,k ) = log( dble( xs( k ) )*1.e-03_dp )
5546  xmss( ig,k ) = log( dble( xg( k ) )*1.e-03_dp )
5547  xmss( ih,k ) = log( dble( xh( k ) )*1.e-03_dp )
5548  end do
5549 
5550  !--- capacity
5551  do k = 1, ndat ! cm -> m
5552  zcap( il,k ) = dble(rlec( k ))*1.e-02_dp
5553  zcap( ic,k ) = dble(riec( k,1 ))*1.e-02_dp
5554  zcap( ip,k ) = dble(riec( k,2 ))*1.e-02_dp
5555  zcap( id,k ) = dble(riec( k,3 ))*1.e-02_dp
5556  zcap( is,k ) = dble(rsec( k ))*1.e-02_dp
5557  zcap( ig,k ) = dble(rgec( k ))*1.e-02_dp
5558  zcap( ih,k ) = dble(rhec( k ))*1.e-02_dp
5559  end do
5560 
5561  !--- terminal velocity
5562  do k = 1, ndat ! cm/s -> m/s
5563  vtrm( il,k ) = dble(vrl( k ))*1.e-02_dp
5564  vtrm( ic,k ) = dble(vri( k,1 ))*1.e-02_dp
5565  vtrm( ip,k ) = dble(vri( k,2 ))*1.e-02_dp
5566  vtrm( id,k ) = dble(vri( k,3 ))*1.e-02_dp
5567  vtrm( is,k ) = dble(vrs( k ))*1.e-02_dp
5568  vtrm( ig,k ) = dble(vrg( k ))*1.e-02_dp
5569  vtrm( ih,k ) = dble(vrh( k ))*1.e-02_dp
5570  end do
5571 
5572  !--- bulk radii
5573  do k = 1, ndat ! cm -> mm
5574  blkr( il,k ) = dble(blkradl( k ))*10.0_dp
5575  blkr( ic,k ) = dble(blkradi( k,1 ))*10.0_dp
5576  blkr( ip,k ) = dble(blkradi( k,2 ))*10.0_dp
5577  blkr( id,k ) = dble(blkradi( k,3 ))*10.0_dp
5578  blkr( is,k ) = dble(blkrads( k ))*10.0_dp
5579  blkr( ig,k ) = dble(blkradg( k ))*10.0_dp
5580  blkr( ih,k ) = dble(blkradh( k ))*10.0_dp
5581  end do
5582 
5583  !--- bulk density
5584  do k = 1, ndat ! g/cm^3 -> kg/m^3
5585  blkd( il,k ) = dble(blkdnsl( k ))*1000._dp
5586  blkd( ic,k ) = dble(blkdnsi( k,1 ))*1000._dp
5587  blkd( ip,k ) = dble(blkdnsi( k,2 ))*1000._dp
5588  blkd( id,k ) = dble(blkdnsi( k,3 ))*1000._dp
5589  blkd( is,k ) = dble(blkdnss( k ))*1000._dp
5590  blkd( ig,k ) = dble(blkdnsg( k ))*1000._dp
5591  blkd( ih,k ) = dble(blkdnsh( k ))*1000._dp
5592  end do
5593 
5594  !--- collection kernel
5595  ! cm**3/s -> m**3/s
5596  do i = 1, ndat
5597  do j = 1, ndat
5598  do k = 1, 7
5599  do kk = 1, 7
5600  ykrn( k,kk,i,j ) = kernels( k,kk,i,j )*1.e-06_dp
5601  enddo
5602  enddo
5603 
5604  end do
5605  end do
5606 
5607  end subroutine rdkdat
5608  !---------------------------------------------------------------------------------------
5609  subroutine sdfgrid
5610 
5611  real(dp) :: xsta, xend
5612  integer :: n
5613  real(dp):: pi_dp = 3.1415920_dp
5614  real(dp):: rhow_dp = 1.0e+03_dp
5615 
5616  xsta = log( rhow_dp * 4.0_dp*pi_dp/3.0_dp * ( 3.e-06_dp )**3.0_dp )
5617  xend = log( rhow_dp * 4.0_dp*pi_dp/3.0_dp * ( 3.e-03_dp )**3.0_dp )
5618 
5619  dxmic_mk = ( xend-xsta )/nbin
5620  dxmic = dxmic_mk
5621  do n = 1, nbin+1
5622  xbnd_mk( n ) = xsta + dxmic_mk*( n-1 )
5623  end do
5624  do n = 1, nbin
5625  xctr_mk( n ) = ( xbnd_mk( n )+xbnd_mk( n+1 ) )*0.50_dp
5626  radc_mk( n ) = ( exp( xctr_mk( n ) )*3.0_dp/4.0_dp/pi_dp/rhow_dp )**( 1.0_dp/3.0_dp )
5627  end do
5628 
5629  end subroutine sdfgrid
5630  !---------------------------------------------------------------------------------------
5631  subroutine getcp
5632 
5633  integer :: myu, n
5634 
5635  do myu = 1, nspc_mk
5636  do n = 1, nbin
5637  cctr_mk( myu,n ) = fcpc( myu,xctr_mk( n ) )
5638  end do
5639  do n = 1, nbin+1
5640  cbnd_mk( myu,n ) = fcpc( myu,xbnd_mk( n ) )
5641  end do
5642  end do
5643 
5644  end subroutine getcp
5645  !---------------------------------------------------------------------------------------
5646  function fcpc( myu,x )
5647 
5648  integer, intent(in) :: myu
5649  real(dp), intent(in) :: x
5650  real(dp) :: fcpc
5651 
5652  real(dp) :: qknt( ndat+kdeg ), elm( ndat,ndat ), coef( ndat )
5653 
5654  call getknot &
5655  ( ndat, kdeg, xmss( myu,: ), & !--- in
5656  qknt ) !--- out
5657 
5658  call getmatrx &
5659  ( ndat, kdeg, qknt, xmss( myu,: ), & !--- in
5660  elm ) !--- out
5661 
5662  call getcoef &
5663  ( ndat, kdeg, elm, zcap( myu,: ), & !--- in
5664  coef ) !--- out
5665 
5666  fcpc = fspline( ndat, kdeg, coef, qknt, xmss( myu,: ), x )
5667 
5668  end function fcpc
5669  !---------------------------------------------------------------------------------------
5670  subroutine getck
5671 
5672  integer :: myu, nyu, i, j
5673 
5674  log_info("ATMOS_PHY_MP_SUZUKI10_getck",*) 'Create micpara.dat'
5675  if( kphase == 0 ) then
5676  log_info("ATMOS_PHY_MP_SUZUKI10_getck",*) 'Hydro-dynamic kernel'
5677  else if( kphase == 1 ) then
5678  log_info("ATMOS_PHY_MP_SUZUKI10_getck",*) 'Long Kernel'
5679  else if( kphase == 2 ) then
5680  log_info("ATMOS_PHY_MP_SUZUKI10_getck",*) 'Golovin Kernel'
5681  endif
5682 
5683  do myu = 1, nspc_mk
5684  do nyu = 1, nspc_mk
5685  log_info("ATMOS_PHY_MP_SUZUKI10_getck",*) ' myu, nyu :', myu, nyu
5686  do i = 1, nbin
5687  do j = 1, nbin
5688  ck_mk( myu,nyu,i,j ) = fckrn( myu,nyu,xctr_mk( i ),xctr_mk( j ) )
5689  end do
5690  end do
5691  end do
5692  end do
5693 
5694  return
5695 
5696  end subroutine getck
5697  !---------------------------------------------------------------------------------------
5698  function fckrn( myu,nyu,x,y )
5699 
5700  integer, intent(in) :: myu, nyu
5701  real(dp), intent(in) :: x, y
5702  real(dp) :: fckrn
5703 
5704  real(dp) :: qknt( ndat+kdeg ), rknt( ndat+kdeg )
5705  real(dp) :: coef( ndat,ndat )
5706 
5707  real(dp) :: xlrg, xsml, vlrg, vsml, rlrg
5708  real(dp):: pi_dp = 3.1415920_dp
5709  real(dp):: rhow_dp = 1.0e+03_dp
5710 
5711  if( kphase == 0 ) then
5712  call getknot &
5713  ( ndat, kdeg, xmss( myu,: ), & !--- in
5714  qknt ) !--- out
5715 
5716  rknt( : ) = qknt( : )
5717 
5718  call getcoef2 &
5719  ( ndat, ndat, kdeg, kdeg, & !--- in
5720  xmss( myu,: ), xmss( nyu,: ), & !--- in
5721  qknt, rknt, & !--- in
5722  ykrn( myu,nyu,:,: ), & !--- in
5723  coef ) !--- out
5724 
5725  fckrn = fspline2 &
5726  ( ndat, ndat, kdeg, kdeg, & !--- in
5727  coef, qknt, rknt, & !--- in
5728  xmss( myu,: ), xmss( nyu,: ), & !--- in
5729  x, y ) !--- in
5730  else if( kphase == 1 ) then
5731  xlrg = max( x, y )
5732  xsml = min( x, y )
5733 
5734  vlrg = (exp( xlrg ) / rhow_dp )*1.e+06_dp
5735  vsml = (exp( xsml ) / rhow_dp )*1.e+06_dp
5736 
5737  rlrg = ( exp( xlrg )/( 4.0_dp*pi_dp*rhow_dp )*3.0_dp )**(1.0_dp/3.0_dp )*1.e+06_dp
5738 
5739  if( rlrg <=50.0_dp ) then
5740  fckrn = 9.44e+03_dp*( vlrg*vlrg + vsml*vsml )
5741  else
5742  fckrn = 5.78e-03_dp*( vlrg+vsml )
5743  end if
5744  else if( kphase == 2 ) then
5745  fckrn = 1.5_dp*( exp(x) +exp(y) )
5746  end if
5747 
5748  return
5749 
5750  end function fckrn
5751  !---------------------------------------------------------------------------------------
5752  subroutine getvt
5753 
5754  integer :: myu, n
5755 
5756  do myu = 1, nspc_mk
5757  do n = 1, nbin
5758  vt_mk( myu,n ) = max( fvterm( myu,xctr_mk( n ) ), 0.0_dp )
5759  end do
5760  end do
5761 
5762  end subroutine getvt
5763  !---------------------------------------------------------------------------------------
5764  function fvterm( myu,x )
5765 
5766  integer, intent(in) :: myu
5767  real(dp), intent(in) :: x
5768  real(dp) :: fvterm
5769 
5770  real(dp) :: qknt( ndat+kdeg ), elm( ndat,ndat ), coef( ndat )
5771 
5772  call getknot &
5773  ( ndat, kdeg, xmss( myu,: ), & !--- in
5774  qknt ) !--- out
5775 
5776  call getmatrx &
5777  ( ndat, kdeg, qknt, xmss( myu,: ), & !--- in
5778  elm ) !--- out
5779 
5780  call getcoef &
5781  ( ndat, kdeg, elm, vtrm( myu,: ), & !--- in
5782  coef ) !--- out
5783 
5784  fvterm = fspline( ndat, kdeg, coef, qknt, xmss( myu,: ), x )
5785 
5786  end function fvterm
5787  !---------------------------------------------------------------------------------------
5788  subroutine getbr
5789 
5790  integer :: myu, n
5791 
5792  do myu = 1, nspc_mk
5793  do n = 1, nbin
5794  br_mk( myu,n ) = fbulkrad( myu, xctr_mk( n ) )
5795  end do
5796  end do
5797 
5798  end subroutine getbr
5799  !---------------------------------------------------------------------------------------
5800  function fbulkrad( myu,x )
5801 
5802  integer, intent(in) :: myu
5803  real(dp), intent(in) :: x
5804  real(dp) :: fbulkrad
5805 
5806  real(dp) :: qknt( ndat+kdeg ), elm( ndat,ndat ), coef( ndat )
5807 
5808  call getknot &
5809  ( ndat, kdeg, xmss( myu,: ), & !--- in
5810  qknt ) !--- out
5811 
5812  call getmatrx &
5813  ( ndat, kdeg, qknt, xmss( myu,: ), & !--- in
5814  elm ) !--- out
5815 
5816  call getcoef &
5817  ( ndat, kdeg, elm, blkr( myu,: ), & !--- in
5818  coef ) !--- out
5819 
5820  fbulkrad = fspline( ndat, kdeg, coef, qknt, xmss( myu,: ), x )
5821 
5822  end function fbulkrad
5823  !---------------------------------------------------------------------------------------
5824  subroutine paraout
5825 
5826  integer :: myu, nyu, i, j, n
5827 
5828  open ( fid_micpara, file = fname_micpara, form = 'formatted', status='new' )
5829 
5830  write( fid_micpara,* ) nspc_mk, nbin
5831 
5832  ! grid parameter
5833  do n = 1, nbin
5834  xctr( n ) = xctr_mk( n )
5835  radc( n ) = radc_mk( n )
5836  write( fid_micpara,* ) n, xctr( n ), radc( n )
5837  end do
5838  do n = 1, nbin+1
5839  xbnd( n ) = xbnd_mk( n )
5840  write( fid_micpara,* ) n, xbnd( n )
5841  end do
5842  write( fid_micpara,* ) dxmic_mk
5843 
5844  ! capacity
5845  do myu = 1, nspc_mk
5846  do n = 1, nbin
5847  cctr( n,myu ) = cctr_mk( myu,n )
5848  write( fid_micpara,* ) myu, n, cctr( n,myu )
5849  end do
5850  do n = 1, nbin+1
5851  cbnd( n,myu ) = cbnd_mk( myu,n )
5852  write( fid_micpara,* ) myu, n, cbnd( n,myu )
5853  end do
5854  end do
5855 
5856  ! collection kernel
5857  do myu = 1, nspc_mk
5858  do nyu = 1, nspc_mk
5859  do i = 1, nbin
5860  do j = 1, nbin
5861  ck( myu,nyu,i,j ) = ck_mk( myu,nyu,i,j )
5862  write( fid_micpara,* ) myu, nyu, i, j, ck( myu,nyu,i,j )
5863  end do
5864  end do
5865  end do
5866  end do
5867 
5868  ! falling velocity
5869  do myu = 1, nspc_mk
5870  do n = 1, nbin
5871  vt( myu,n ) = vt_mk( myu,n )
5872  write( fid_micpara,* ) myu, n, vt( myu,n )
5873  end do
5874  end do
5875 
5876  ! bulk radius
5877  do myu = 1, nspc_mk
5878  do n = 1, nbin
5879  br( myu,n ) = br_mk( myu,n )
5880  write( fid_micpara,* ) myu, n, br( myu,n )
5881  end do
5882  end do
5883 
5884  close ( fid_micpara )
5885 
5886  end subroutine paraout
5887  !---------------------------------------------------------------------------------------
5888  !---- unify from other files
5889  !---------------------------------------------------------------------------------------
5890  subroutine tinvss(n,a,dt,e,nn,iw,inder)
5891 
5892  implicit none
5893 
5894  integer, intent(in) :: n, nn
5895  integer, intent(inout) :: inder
5896  real(dp), intent(inout) :: a(nn,n)
5897  real(dp), intent(inout) :: dt
5898  real(dp), intent(in) :: e
5899  integer, intent(inout) :: iw( 2*n )
5900  integer :: i, j, k, kk, ij, nnn
5901  real(dp) :: work, aa, az, eps
5902  integer :: ipiv, jpiv
5903  real(dp) :: piv
5904  !-----------------------------------------
5905 
5906  inder = 0
5907  if( n < 1 ) then
5908  goto 910
5909  elseif( n == 1 ) then
5910  goto 930
5911  elseif( n > 1 ) then
5912  goto 101
5913  endif
5914 
5915 101 continue
5916  if( n > nn ) then
5917  inder = -1
5918  write(6,690) "n= ", n, "nn= ", nn, &
5919  "n should be less than or equal to nn in TINVSS"
5920 690 format(a8,i5,5x,a4,i5,a55)
5921  return
5922  endif
5923 
5924  eps = 0.0_dp
5925  dt = 1.0_dp
5926  do k = 1, n
5927  piv = 0.0_dp
5928  do i = k, n
5929  do j = k, n
5930  if( abs(a(i,j)) <= abs(piv) ) goto 110 !
5931  ipiv = i
5932  jpiv = j
5933  piv = a(i,j)
5934 110 continue
5935  enddo
5936  enddo
5937  dt = dt * piv
5938  if( abs(piv) <= eps ) goto 920
5939  if( k == 1 ) eps = abs(piv)*e
5940  if( ipiv == k ) goto 130
5941  dt = -dt
5942  do j = 1, n
5943  work = a(ipiv,j)
5944  a(ipiv,j) = a(k,j)
5945  a(k,j) = work
5946  enddo
5947 130 continue
5948  if( jpiv == k ) goto 150
5949  dt = -dt
5950  do i = 1, n
5951  work = a(i,jpiv)
5952  a(i,jpiv) = a(i,k)
5953  a(i,k) = work
5954  enddo
5955 150 continue
5956  iw(2*k-1) = ipiv
5957  aa=1.0_dp/piv
5958  iw(2*k) = jpiv
5959  do j = 1, n
5960  a(k,j) = a(k,j)*aa
5961  enddo
5962  do i = 1, n
5963  if( i == k ) goto 220
5964  az = a(i,k)
5965  if( az == 0.0_dp ) goto 220
5966  do j = 1, n
5967  a(i,j) = a(i,j)-a(k,j)*az
5968  enddo
5969  a(i,k) = -aa*az
5970 220 continue
5971  enddo
5972  a(k,k) = aa
5973  enddo
5974  do kk = 2, n
5975  k=n+1-kk
5976  ij=iw(2*k)
5977  if( ij == k ) goto 420
5978  do j = 1, n
5979  work=a(ij,j)
5980  a(ij,j) = a(k,j)
5981  a(k,j) = work
5982  enddo
5983 420 continue
5984  ij = iw(2*k-1)
5985  if( ij == k ) goto 400
5986  do i = 1, n
5987  work=a(i,ij)
5988  a(i,ij)=a(i,k)
5989  a(i,k)=work
5990  enddo
5991 400 continue
5992  enddo
5993 
5994  return
5995 
5996 910 continue
5997  inder = -1
5998  write(*,691) "n= ", n, "should be positive in TINVSS"
5999 691 format(a8,i5,5x,a30)
6000  return
6001 
6002 
6003 920 continue
6004  dt = 0.0_dp
6005  inder = n-k+1
6006  nnn = k-1
6007  write(*,692) 'given matrix A to TINVSS is ill conditioned, or sigular withrank =', nnn, &
6008  'return with no further calculation'
6009 692 format(a,1x,i4,1x,a)
6010  return
6011 
6012 930 continue
6013  dt=a(1,1)
6014  k=1
6015  if( dt == 0.0_dp ) goto 920
6016  a(1,1) = 1.0_dp/a(1,1)
6017  return
6018 
6019  end subroutine tinvss
6020  !---------------------------------------------------------------
6021  subroutine getknot &
6022  ( ndat, kdeg, xdat, & !--- in
6023  qknt ) !--- out
6024 
6025  integer, intent(in) :: ndat ! number of data
6026  integer, intent(in) :: kdeg ! degree of Spline + 1
6027  real(dp), intent(in) :: xdat( ndat ) ! data of independent var.
6028 
6029  real(dp), intent(out) :: qknt( ndat+kdeg ) ! knots for B-Spline
6030 
6031  !--- local
6032  integer :: i
6033 
6034  do i = 1, kdeg
6035  qknt( i ) = xdat( 1 )
6036  end do
6037 
6038  do i = 1, ndat-kdeg
6039  qknt( i+kdeg ) = ( xdat( i )+xdat( i+kdeg ) )*0.50_dp
6040  end do
6041 
6042  do i = 1, kdeg
6043  qknt( ndat+i ) = xdat( ndat )
6044  end do
6045 
6046  return
6047 
6048  end subroutine getknot
6049  !---------------------------------------------------------------
6050  recursive function fbspl ( ndat, inum, kdeg, qknt, xdat, x ) &
6051  result(bspl)
6052 
6053  real(dp) :: bspl
6054 
6055  integer, intent(in) :: ndat ! number of data
6056  integer, intent(in) :: inum ! index of B-Spline
6057  integer, intent(in) :: kdeg ! degree of B-Spline + 1
6058  real(dp), intent(in) :: qknt( ndat+kdeg ) ! knot of B-Spline
6059  real(dp), intent(in) :: xdat( ndat ) ! data of independent variable
6060  real(dp), intent(in) :: x ! interpolation point
6061 
6062  !--- local
6063  real(dp) :: bsp1, bsp2
6064 
6065  if ( ( inum == 1 .AND. x == xdat( 1 ) ) .OR. &
6066  ( inum == ndat .AND. x == xdat( ndat ) ) ) then
6067  bspl = 1.
6068  return
6069  end if
6070 
6071  if ( kdeg == 1 ) then
6072  if ( x >= qknt( inum ) .AND. x < qknt( inum+1 ) ) then
6073  bspl = 1.0_dp
6074  else
6075  bspl = 0.0_dp
6076  end if
6077  else
6078  if ( qknt( inum+kdeg-1 ) /= qknt( inum ) ) then
6079  bsp1 = ( x-qknt( inum ) ) &
6080  /( qknt( inum+kdeg-1 )-qknt( inum ) ) &
6081  * fbspl( ndat, inum, kdeg-1, qknt, xdat, x )
6082  else
6083  bsp1 = 0.0_dp
6084  end if
6085  if ( qknt( inum+kdeg ) /= qknt( inum+1 ) ) then
6086  bsp2 = ( qknt( inum+kdeg )-x ) &
6087  /( qknt( inum+kdeg )-qknt( inum+1 ) ) &
6088  * fbspl( ndat, inum+1, kdeg-1, qknt, xdat, x )
6089  else
6090  bsp2 = 0.0_dp
6091  end if
6092  bspl = bsp1 + bsp2
6093  end if
6094 
6095  end function fbspl
6096  !---------------------------------------------------------------
6097  function fpb( ndat, i, kdeg, qknt, xdat, elm, x )
6098 
6099  real :: fpb
6100  integer :: ndat, i, kdeg
6101  real(dp) :: qknt( ndat+kdeg ), xdat( ndat ), elm( ndat,ndat )
6102  real(dp) :: x
6103 
6104  integer :: l
6105  real(dp) :: sum
6106 
6107  sum = 0.0_dp
6108  do l = 1, ndat
6109  sum = sum + elm( l,i )*fbspl( ndat, l, kdeg, qknt, xdat, x )
6110  end do
6111 
6112  fpb = sum
6113 
6114  end function fpb
6115  !---------------------------------------------------------------
6116  subroutine getmatrx &
6117  ( ndat, kdeg, qknt, xdat, & !--- in
6118  elm ) !--- out
6119 
6120 ! use scale_tinvss, only: TINVSS
6121 
6122  integer, intent(in) :: ndat
6123  integer, intent(in) :: kdeg
6124  real(dp), intent(in) :: qknt( ndat+kdeg )
6125  real(dp), intent(in) :: xdat( ndat )
6126 
6127  real(dp), intent(out) :: elm( ndat,ndat )
6128 
6129  !--- local
6130  real(dp) :: dt
6131  integer :: iw( 2*ndat ), i, j, inder
6132  real(dp), parameter :: eps = 0.
6133 
6134  do i = 1, ndat
6135  do j = 1, ndat
6136  elm( i,j ) = fbspl( ndat, j, kdeg, qknt, xdat, xdat( i ) )
6137  end do
6138  end do
6139 
6140  call tinvss( ndat, elm, dt, eps, ndat, iw, inder )
6141 
6142  return
6143 
6144  end subroutine getmatrx
6145  !---------------------------------------------------------------
6146  subroutine getcoef &
6147  ( ndat, kdeg, elm, ydat, & !--- in
6148  coef ) !--- out
6149 
6150  integer, intent(in) :: ndat ! number of data
6151  integer, intent(in) :: kdeg ! degree of Spline + 1
6152  real(dp), intent(in) :: elm( ndat,ndat ) ! matrix ( inverse )
6153  real(dp), intent(in) :: ydat( ndat ) ! data of dependent var.
6154 
6155  real(dp), intent(out) :: coef( ndat ) ! expansion coefficient
6156 
6157  !--- local
6158  integer :: i, j
6159  real(dp) :: sum
6160 
6161  do i = 1, ndat
6162  sum = 0.0_dp
6163  do j = 1, ndat
6164  sum = sum + elm( i,j )*ydat( j )
6165  end do
6166  coef( i ) = sum
6167  end do
6168 
6169  return
6170 
6171  end subroutine getcoef
6172  !---------------------------------------------------------------
6173  function fspline ( ndat, kdeg, coef, qknt, xdat, x )
6174 
6175  integer, intent(in) :: ndat
6176  integer, intent(in) :: kdeg
6177  real(dp), intent(in) :: coef( ndat )
6178  real(dp), intent(in) :: qknt( ndat+kdeg )
6179  real(dp), intent(in) :: xdat( ndat )
6180  real(dp), intent(in) :: x
6181 
6182  real(dp) :: fspline
6183 
6184  !--- local
6185  real(dp) :: sum
6186  integer :: i
6187 
6188  sum = 0.0_dp
6189  do i = 1, ndat
6190  sum = sum + coef( i )*fbspl( ndat, i, kdeg, qknt, xdat, x )
6191  end do
6192 
6193  fspline = sum
6194 
6195  return
6196 
6197  end function fspline
6198  !---------------------------------------------------------------
6199  subroutine getcoef2 &
6200  ( mdat, ndat, kdeg, ldeg, & !--- in
6201  xdat, ydat, qknt, rknt, zdat, & !--- in
6202  coef ) !--- out
6203 
6204 ! use scale_tinvss, only: TINVSS
6205 
6206  integer, intent(in) :: mdat ! number of data (x-direction)
6207  integer, intent(in) :: ndat ! number of data (y-direction)
6208  integer, intent(in) :: kdeg ! degree of Spline + 1 (x)
6209  integer, intent(in) :: ldeg ! degree of Spline + 1 (y)
6210  real(dp), intent(in) :: xdat( mdat ) ! data of independent var. (x)
6211  real(dp), intent(in) :: ydat( ndat ) ! data of independent var. (y)
6212  real(dp), intent(in) :: qknt( mdat+kdeg ) ! knots of B-Spline (x)
6213  real(dp), intent(in) :: rknt( ndat+ldeg ) ! knots of B-Spline (y)
6214  real(dp), intent(in) :: zdat( mdat,ndat ) ! data of dependent var.
6215 
6216  real(dp), intent(out) :: coef( mdat,ndat ) ! expansion coefficient
6217 
6218  !--- local
6219  real(dp) :: elmx( mdat,mdat ), elmy( ndat,ndat )
6220  integer :: iw1( 2*mdat ), iw2( 2*ndat )
6221  real(dp) :: beta( mdat,ndat ), sum, dt
6222  real(dp), parameter :: eps = 0.0_dp
6223  integer :: i, j, k, l, inder
6224 
6225  do i = 1, mdat
6226  do j = 1, mdat
6227  elmx( i,j ) = fbspl( mdat, j, kdeg, qknt, xdat, xdat( i ) )
6228  end do
6229  end do
6230  call tinvss( mdat, elmx, dt, eps, mdat, iw1, inder )
6231 
6232  do l = 1, ndat
6233  do i = 1, mdat
6234  sum = 0.0_dp
6235  do j = 1, mdat
6236  sum = sum + elmx( i,j )*zdat( j,l )
6237  end do
6238  beta( i,l ) = sum
6239  end do
6240  end do
6241 
6242  do i = 1, ndat
6243  do j = 1, ndat
6244  elmy( i,j ) = fbspl( ndat, j, ldeg, rknt, ydat, ydat( i ) )
6245  end do
6246  end do
6247  call tinvss( ndat, elmy, dt, eps, ndat, iw2, inder )
6248 
6249  do k = 1, mdat
6250  do i = 1, ndat
6251  sum = 0.0_dp
6252  do j = 1, ndat
6253  sum = sum + elmy( i,j )*beta( k,j )
6254  end do
6255  coef( k,i ) = sum
6256  end do
6257  end do
6258 
6259  return
6260 
6261  end subroutine getcoef2
6262  !---------------------------------------------------------------
6263  function fspline2 &
6264  ( mdat, ndat, kdeg, ldeg, & !--- in
6265  coef, qknt, rknt, xdat, ydat, & !--- in
6266  x, y ) !--- in
6267 
6268  integer, intent(in) :: mdat
6269  integer, intent(in) :: ndat
6270  integer, intent(in) :: kdeg
6271  integer, intent(in) :: ldeg
6272  real(dp), intent(in) :: coef( mdat,ndat )
6273  real(dp), intent(in) :: qknt( mdat+kdeg )
6274  real(dp), intent(in) :: rknt( ndat+ldeg )
6275  real(dp), intent(in) :: xdat( mdat ), ydat( ndat )
6276  real(dp), intent(in) :: x, y
6277 
6278  real(dp) :: fspline2
6279 
6280  !--- local
6281  real(dp) :: sum, add
6282  integer :: i, j
6283 
6284  sum = 0.0_dp
6285  do i = 1, mdat
6286  do j = 1, ndat
6287  add = coef( i,j )*fbspl( mdat, i, kdeg, qknt, xdat, x ) &
6288  *fbspl( ndat, j, ldeg, rknt, ydat, y )
6289  sum = sum + add
6290  end do
6291  end do
6292 
6293  fspline2 = sum
6294 
6295  return
6296 
6297  end function fspline2
6298 
6299 end module scale_atmos_phy_mp_suzuki10
scale_prc::prc_abort
subroutine, public prc_abort
Abort Process.
Definition: scale_prc.F90:342
scale_atmos_hydrometeor::i_hr
integer, parameter, public i_hr
liquid water rain
Definition: scale_atmos_hydrometeor.F90:82
scale_atmos_hydrometeor::cp_water
real(rp), public cp_water
CP for water [J/kg/K].
Definition: scale_atmos_hydrometeor.F90:133
scale_atmos_hydrometeor::i_hs
integer, parameter, public i_hs
snow
Definition: scale_atmos_hydrometeor.F90:84
scale_precision
module PRECISION
Definition: scale_precision.F90:14
scale_const::const_rvap
real(rp), parameter, public const_rvap
specific gas constant (water vapor) [J/kg/K]
Definition: scale_const.F90:63
scale_atmos_phy_mp_suzuki10::atmos_phy_mp_suzuki10_crg_qtrc2qhyd
subroutine, public atmos_phy_mp_suzuki10_crg_qtrc2qhyd(KA, KS, KE, IA, IS, IE, JA, JS, JE, QTRC0, Qecrg)
get charge density ratio of each category
Definition: scale_atmos_phy_mp_suzuki10.F90:1901
scale_atmos_phy_mp_suzuki10::atmos_phy_mp_suzuki10_qtrc2qhyd
subroutine, public atmos_phy_mp_suzuki10_qtrc2qhyd(KA, KS, KE, IA, IS, IE, JA, JS, JE, QTRC0, Qe)
Calculate mass ratio of each category.
Definition: scale_atmos_phy_mp_suzuki10.F90:1567
scale_atmos_phy_mp_suzuki10::atmos_phy_mp_suzuki10_tendency
subroutine, public atmos_phy_mp_suzuki10_tendency(KA, KS, KE, IA, IS, IE, JA, JS, JE, KIJMAX, dt, DENS, PRES, TEMP, QTRC, QDRY, CPtot, CVtot, CCN, RHOQ_t, RHOE_t, CPtot_t, CVtot_t, EVAPORATE, flg_lt, d0_crg, v0_crg, dqcrg, beta_crg, QTRC_crg, QSPLT_in, Sarea, RHOC_t_mp)
Cloud Microphysics.
Definition: scale_atmos_phy_mp_suzuki10.F90:893
scale_const::const_emelt
real(rp), parameter, public const_emelt
Definition: scale_const.F90:72
scale_const::const_eps
real(rp), public const_eps
small number
Definition: scale_const.F90:33
scale_prof::prof_rapstart
subroutine, public prof_rapstart(rapname_base, level, disable_barrier)
Start raptime.
Definition: scale_prof.F90:159
scale_atmos_hydrometeor
module atmosphere / hydrometeor
Definition: scale_atmos_hydrometeor.F90:12
scale_atmos_hydrometeor::i_hh
integer, parameter, public i_hh
hail
Definition: scale_atmos_hydrometeor.F90:86
scale_random
module RANDOM
Definition: scale_random.F90:11
scale_atmos_phy_mp_suzuki10::nbin
integer, public nbin
Definition: scale_atmos_phy_mp_suzuki10.F90:136
scale_io::io_get_available_fid
integer function, public io_get_available_fid()
search & get available file ID
Definition: scale_io.F90:321
scale_atmos_phy_mp_suzuki10::atmos_phy_mp_suzuki10_terminal_velocity
subroutine, public atmos_phy_mp_suzuki10_terminal_velocity(KA, vterm_o)
get terminal velocity
Definition: scale_atmos_phy_mp_suzuki10.F90:1349
scale_atmos_phy_mp_suzuki10::atmos_phy_mp_suzuki10_nbnd
integer, public atmos_phy_mp_suzuki10_nbnd
Definition: scale_atmos_phy_mp_suzuki10.F90:59
scale_prc
module PROCESS
Definition: scale_prc.F90:11
scale_const::const_pi
real(rp), public const_pi
pi
Definition: scale_const.F90:31
scale_precision::rp
integer, parameter, public rp
Definition: scale_precision.F90:41
scale_atmos_hydrometeor::cv_vapor
real(rp), public cv_vapor
CV for vapor [J/kg/K].
Definition: scale_atmos_hydrometeor.F90:130
scale_atmos_hydrometeor::i_hi
integer, parameter, public i_hi
ice water cloud
Definition: scale_atmos_hydrometeor.F90:83
scale_io
module STDIO
Definition: scale_io.F90:10
scale_prc::prc_masterrank
integer, parameter, public prc_masterrank
master process in each communicator
Definition: scale_prc.F90:66
scale_const
module CONSTANT
Definition: scale_const.F90:11
scale_atmos_phy_mp_suzuki10::atmos_phy_mp_suzuki10_nwaters
integer, public atmos_phy_mp_suzuki10_nwaters
Definition: scale_atmos_phy_mp_suzuki10.F90:56
scale_atmos_phy_mp_suzuki10::atmos_phy_mp_suzuki10_qtrc2nhyd
subroutine, public atmos_phy_mp_suzuki10_qtrc2nhyd(KA, KS, KE, IA, IS, IE, JA, JS, JE, DENS, QTRC0, Ne)
Calculate number concentration of each category.
Definition: scale_atmos_phy_mp_suzuki10.F90:1635
scale_atmos_phy_mp_suzuki10::atmos_phy_mp_suzuki10_qhyd2qtrc
subroutine, public atmos_phy_mp_suzuki10_qhyd2qtrc(KA, KS, KE, IA, IS, IE, JA, JS, JE, Qe, QTRC, QNUM)
get mass ratio of each category
Definition: scale_atmos_phy_mp_suzuki10.F90:1703
scale_atmos_phy_mp_suzuki10::atmos_phy_mp_suzuki10_tracer_units
character(len=h_short), dimension(:), allocatable, public atmos_phy_mp_suzuki10_tracer_units
Definition: scale_atmos_phy_mp_suzuki10.F90:64
scale_prof
module profiler
Definition: scale_prof.F90:11
scale_atmos_phy_mp_suzuki10::atmos_phy_mp_suzuki10_effective_radius
subroutine, public atmos_phy_mp_suzuki10_effective_radius(KA, KS, KE, IA, IS, IE, JA, JS, JE, DENS0, TEMP0, QTRC0, Re)
Calculate Effective Radius.
Definition: scale_atmos_phy_mp_suzuki10.F90:1431
scale_atmos_phy_mp_suzuki10
module Spectran Bin Microphysics
Definition: scale_atmos_phy_mp_suzuki10.F90:23
scale_atmos_phy_mp_suzuki10::atmos_phy_mp_suzuki10_cloud_fraction
subroutine, public atmos_phy_mp_suzuki10_cloud_fraction(KA, KS, KE, IA, IS, IE, JA, JS, JE, QTRC0, mask_criterion, cldfrac)
Calculate Cloud Fraction.
Definition: scale_atmos_phy_mp_suzuki10.F90:1374
scale_precision::dp
integer, parameter, public dp
Definition: scale_precision.F90:32
scale_specfunc
module SPECFUNC
Definition: scale_specfunc.F90:14
scale_const::const_psat0
real(rp), parameter, public const_psat0
saturate pressure of water vapor at 0C [Pa]
Definition: scale_const.F90:81
scale_atmos_phy_mp_suzuki10::atmos_phy_mp_suzuki10_tracer_descriptions
character(len=h_mid), dimension(:), allocatable, public atmos_phy_mp_suzuki10_tracer_descriptions
Definition: scale_atmos_phy_mp_suzuki10.F90:63
scale_atmos_hydrometeor::i_hc
integer, parameter, public i_hc
liquid water cloud
Definition: scale_atmos_hydrometeor.F90:81
scale_atmos_hydrometeor::i_qv
integer, public i_qv
Definition: scale_atmos_hydrometeor.F90:77
scale_const::const_dwatr
real(rp), parameter, public const_dwatr
density of water [kg/m3]
Definition: scale_const.F90:82
scale_const::const_tem00
real(rp), parameter, public const_tem00
temperature reference (0C) [K]
Definition: scale_const.F90:90
scale_atmos_phy_mp_suzuki10::atmos_phy_mp_suzuki10_tracer_setup
subroutine, public atmos_phy_mp_suzuki10_tracer_setup
Config.
Definition: scale_atmos_phy_mp_suzuki10.F90:299
scale_atmos_phy_mp_suzuki10::atmos_phy_mp_suzuki10_ntracers
integer, public atmos_phy_mp_suzuki10_ntracers
Definition: scale_atmos_phy_mp_suzuki10.F90:55
scale_comm_cartesc
module COMMUNICATION
Definition: scale_comm_cartesC.F90:11
scale_atmos_phy_mp_suzuki10::atmos_phy_mp_suzuki10_tracer_names
character(len=h_short), dimension(:), allocatable, public atmos_phy_mp_suzuki10_tracer_names
Definition: scale_atmos_phy_mp_suzuki10.F90:62
scale_const::const_tmelt
real(rp), parameter, public const_tmelt
Definition: scale_const.F90:73
scale_atmos_phy_mp_suzuki10::nccn
integer, public nccn
Definition: scale_atmos_phy_mp_suzuki10.F90:138
scale_prof::prof_rapend
subroutine, public prof_rapend(rapname_base, level, disable_barrier)
Save raptime.
Definition: scale_prof.F90:217
scale_const::const_dice
real(rp), parameter, public const_dice
density of ice [kg/m3]
Definition: scale_const.F90:83
scale_specfunc::sf_gamma
real(rp) function, public sf_gamma(x)
Gamma function.
Definition: scale_specfunc.F90:50
scale_atmos_phy_mp_suzuki10::atmos_phy_mp_suzuki10_setup
subroutine, public atmos_phy_mp_suzuki10_setup(KA, IA, JA, flg_lt)
Setup.
Definition: scale_atmos_phy_mp_suzuki10.F90:391
scale_atmos_saturation
module atmosphere / saturation
Definition: scale_atmos_saturation.F90:12
scale_atmos_phy_mp_suzuki10::atmos_phy_mp_suzuki10_nices
integer, public atmos_phy_mp_suzuki10_nices
Definition: scale_atmos_phy_mp_suzuki10.F90:57
scale_io::io_fid_conf
integer, public io_fid_conf
Config file ID.
Definition: scale_io.F90:56
scale_atmos_hydrometeor::n_hyd
integer, parameter, public n_hyd
Definition: scale_atmos_hydrometeor.F90:79
scale_atmos_hydrometeor::cp_vapor
real(rp), public cp_vapor
CP for vapor [J/kg/K].
Definition: scale_atmos_hydrometeor.F90:131
scale_atmos_phy_mp_suzuki10::atmos_phy_mp_suzuki10_nccn
integer, public atmos_phy_mp_suzuki10_nccn
Definition: scale_atmos_phy_mp_suzuki10.F90:58
scale_atmos_hydrometeor::cv_water
real(rp), public cv_water
CV for water [J/kg/K].
Definition: scale_atmos_hydrometeor.F90:132
scale_prc::prc_ismaster
logical, public prc_ismaster
master process in local communicator?
Definition: scale_prc.F90:91
scale_atmos_hydrometeor::cv_ice
real(rp), public cv_ice
CV for ice [J/kg/K].
Definition: scale_atmos_hydrometeor.F90:134
scale_atmos_hydrometeor::cp_ice
real(rp), public cp_ice
CP for ice [J/kg/K].
Definition: scale_atmos_hydrometeor.F90:135
scale_atmos_hydrometeor::i_hg
integer, parameter, public i_hg
graupel
Definition: scale_atmos_hydrometeor.F90:85
Generated by   doxygen 1.8.17