scale_atmos_phy_mp_sn14.F90

Go to the documentation of this file.

!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
 
#include "scalelib.h"
module scale_atmos_phy_mp_sn14
  !-----------------------------------------------------------------------------
  !
  !++ used modules
  !
  use scale_precision
  use scale_io
  use scale_prof
 
  use scale_const, only: &
     grav   => const_grav,   &
     pi     => const_pi,     &
     undef8 => const_undef8, &
     rdry   => const_rdry,   &
     cpdry  => const_cpdry,  &
     cvdry  => const_cvdry,  &
     p00    => const_pre00,  &
     t00    => const_tem00,  &
     rvap   => const_rvap,   &
     cpvap  => const_cpvap,  &
     cvvap  => const_cvvap,  &
     cl     => const_cl,     &
     ci     => const_ci,     &
     lhv    => const_lhv00,  &
     lhf    => const_lhf00,  &
     lhv0   => const_lhv0,   &
     lhf0   => const_lhf0,   &
     lhs0   => const_lhs0,   &
     lhv00  => const_lhv00,  &
     lhf00  => const_lhf00,  &
     psat0  => const_psat0,  &
     emelt  => const_emelt,  &
     dwatr  => const_dwatr,  &
     small  => const_eps
 
  use scale_atmos_hydrometeor, only: &
     n_hyd
 
  !-----------------------------------------------------------------------------
  implicit none
  private
  !-----------------------------------------------------------------------------
  !
  !++ Public procedure
  !
  public :: atmos_phy_mp_sn14_setup
  public :: atmos_phy_mp_sn14_finalize
  public :: atmos_phy_mp_sn14_tendency
  public :: atmos_phy_mp_sn14_terminal_velocity
  public :: atmos_phy_mp_sn14_effective_radius
  public :: atmos_phy_mp_sn14_cloud_fraction
  public :: atmos_phy_mp_sn14_qtrc2qhyd
  public :: atmos_phy_mp_sn14_qtrc2nhyd
  public :: atmos_phy_mp_sn14_qhyd2qtrc
 
  !-----------------------------------------------------------------------------
  !
  !++ Public parameters & variables
  !
  integer, public, parameter :: qa_mp  = 11
 
  integer,                parameter, public :: atmos_phy_mp_sn14_ntracers = qa_mp
  integer,                parameter, public :: atmos_phy_mp_sn14_nwaters = 2
  integer,                parameter, public :: atmos_phy_mp_sn14_nices = 3
  character(len=H_SHORT), parameter, public :: atmos_phy_mp_sn14_tracer_names(qa_mp) = (/ &
       'QV', &
       'QC', &
       'QR', &
       'QI', &
       'QS', &
       'QG', &
       'NC', &
       'NR', &
       'NI', &
       'NS', &
       'NG'  /)
  character(len=H_MID)  , parameter, public :: atmos_phy_mp_sn14_tracer_descriptions(qa_mp) = (/ &
       'Ratio of Water Vapor mass to total mass (Specific humidity)', &
       'Ratio of Cloud Water mass to total mass                    ', &
       'Ratio of Rain Water mass to total mass                     ', &
       'Ratio of Cloud Ice mass ratio to total mass                ', &
       'Ratio of Snow mass ratio to total mass                     ', &
       'Ratio of Graupel mass ratio to total mass                  ', &
       'Cloud Water Number Density                                 ', &
       'Rain Water Number Density                                  ', &
       'Cloud Ice Number Density                                   ', &
       'Snow Number Density                                        ', &
       'Graupel Number Density                                     '/)
  character(len=H_SHORT), parameter, public :: atmos_phy_mp_sn14_tracer_units(qa_mp) = (/ &
       'kg/kg ', &
       'kg/kg ', &
       'kg/kg ', &
       'kg/kg ', &
       'kg/kg ', &
       'kg/kg ', &
       'num/kg', &
       'num/kg', &
       'num/kg', &
       'num/kg', &
       'num/kg'  /)
 
  !-----------------------------------------------------------------------------
  !
  !++ Private procedure
  !
  private :: mp_sn14_init
  private :: mp_sn14
 
  !-----------------------------------------------------------------------------
  !
  !++ Private parameters
  !
  integer,  private, parameter   :: i_qv = 1
  integer,  private, parameter   :: i_qc = 2
  integer,  private, parameter   :: i_qr = 3
  integer,  private, parameter   :: i_qi = 4
  integer,  private, parameter   :: i_qs = 5
  integer,  private, parameter   :: i_qg = 6
  integer,  private, parameter   :: i_nc = 7
  integer,  private, parameter   :: i_nr = 8
  integer,  private, parameter   :: i_ni = 9
  integer,  private, parameter   :: i_ns = 10
  integer,  private, parameter   :: i_ng = 11
 
  integer, private, parameter :: hydro_max = 5
 
  integer, private, parameter :: i_mp_qc = 1
  integer, private, parameter :: i_mp_qr = 2
  integer, private, parameter :: i_mp_qi = 3
  integer, private, parameter :: i_mp_qs = 4
  integer, private, parameter :: i_mp_qg = 5
  integer, private, parameter :: i_mp_nc = 6
  integer, private, parameter :: i_mp_nr = 7
  integer, private, parameter :: i_mp_ni = 8
  integer, private, parameter :: i_mp_ns = 9
  integer, private, parameter :: i_mp_ng = 10
 
  ! production rate
  !   nucleation
  integer, parameter :: i_lcccn =  1
  integer, parameter :: i_ncccn =  2
  integer, parameter :: i_liccn =  3
  integer, parameter :: i_niccn =  4
  !   freezing
  integer, parameter :: i_lchom =  5
  integer, parameter :: i_nchom =  6
  integer, parameter :: i_lchet =  7
  integer, parameter :: i_nchet =  8
  integer, parameter :: i_lrhet =  9
  integer, parameter :: i_nrhet = 10
  !   melting
  integer, parameter :: i_limlt = 11
  integer, parameter :: i_nimlt = 12
  integer, parameter :: i_lsmlt = 13
  integer, parameter :: i_nsmlt = 14
  integer, parameter :: i_lgmlt = 15
  integer, parameter :: i_ngmlt = 16
  !   vapor deposition
  integer, parameter :: i_lrdep = 17
  integer, parameter :: i_nrdep = 18
  integer, parameter :: i_lidep = 19
  integer, parameter :: i_nidep = 20
  integer, parameter :: i_lsdep = 21
  integer, parameter :: i_nsdep = 22
  integer, parameter :: i_lgdep = 23
  integer, parameter :: i_ngdep = 24
  integer, parameter :: i_lcdep = 25
!    integer, parameter :: I_NCdep = 26
  !   warm collection process
  !     auto-conversion
  integer, parameter :: i_lcaut = 26
  integer, parameter :: i_ncaut = 27
  integer, parameter :: i_nraut = 28
  !     accretion
  integer, parameter :: i_lcacc = 29
  integer, parameter :: i_ncacc = 30
  !     self-colletion, break-up
  integer, parameter :: i_nrslc = 31
  integer, parameter :: i_nrbrk = 32
 
  !   partial conversion(ice, snow => graupel)
  integer, parameter :: i_licon = 33
  integer, parameter :: i_nicon = 34
  integer, parameter :: i_lscon = 35
  integer, parameter :: i_nscon = 36
  !   enhanced melting due to
  integer, parameter :: i_liacm = 37 ! ice-cloud
  integer, parameter :: i_niacm = 38
  integer, parameter :: i_liarm = 39 ! ice-rain
  integer, parameter :: i_niarm = 40
  integer, parameter :: i_lsacm = 41 ! snow-cloud
  integer, parameter :: i_nsacm = 42
  integer, parameter :: i_lsarm = 43 ! snow-rain
  integer, parameter :: i_nsarm = 44
  integer, parameter :: i_lgacm = 45 ! graupel-cloud
  integer, parameter :: i_ngacm = 46
  integer, parameter :: i_lgarm = 47 ! graupel-rain
  integer, parameter :: i_ngarm = 48
  !   ice multiplication by splintering
  integer, parameter :: i_lgspl = 49
  integer, parameter :: i_lsspl = 50
  integer, parameter :: i_nispl = 51
  integer, parameter :: i_lihom = 52
  integer, parameter :: i_nihom = 53
  ! for charge density
  integer, parameter :: i_ngspl = 54
  integer, parameter :: i_nsspl = 55
 
  integer, parameter :: pq_max = 55
 
 
  ! production rate of mixed-phase collection process
  ! PXXacYY2ZZ means XX collect YY produce ZZ
  integer, parameter :: i_liaclc2li   =  1 ! cloud-ice
  integer, parameter :: i_niacnc2ni   =  2
  integer, parameter :: i_lsaclc2ls   =  3 ! cloud-snow(cloud change)
  integer, parameter :: i_nsacnc2ns   =  4
  integer, parameter :: i_lgaclc2lg   =  5 ! cloud-graupel
  integer, parameter :: i_ngacnc2ng   =  6
  integer, parameter :: i_lracli2lg_i =  7 ! rain-ice(ice change)
  integer, parameter :: i_nracni2ng_i =  8
  integer, parameter :: i_lracli2lg_r =  9 ! rain-ice(rain change)
  integer, parameter :: i_nracni2ng_r = 10
  integer, parameter :: i_lracls2lg_s = 11 ! rain-snow(snow change)
  integer, parameter :: i_nracns2ng_s = 12
  integer, parameter :: i_lracls2lg_r = 13 ! rain-snow(rain change)
  integer, parameter :: i_nracns2ng_r = 14
  integer, parameter :: i_lraclg2lg   = 15 ! rain-graupel(rain change)
  integer, parameter :: i_nracng2ng   = 16
  integer, parameter :: i_liacli2ls   = 17 ! ice-ice
  integer, parameter :: i_niacni2ns   = 18
  integer, parameter :: i_liacls2ls   = 19 ! ice-snow(ice change)
  integer, parameter :: i_niacns2ns   = 20
  integer, parameter :: i_nsacns2ns   = 21 ! snow-snow
  integer, parameter :: i_ngacng2ng   = 22 ! graupel-graupel
  integer, parameter :: i_lgacls2lg   = 23 ! snow-graupel
  integer, parameter :: i_ngacns2ng   = 24
  integer, parameter :: i_lraclg2lr   = 25
  integer, parameter :: i_nracng2nr   = 26
  integer, parameter :: i_liaclg2lg   = 27
  integer, parameter :: i_niacng2ng   = 28
  integer, parameter :: i_cgngacns2ng = 29
  integer, parameter :: i_cgngacni2ng = 30
 
  integer, parameter :: pac_max       = 30
  integer, parameter :: pcrg_max      = 30
 
 
  integer, private, parameter :: w_nmax = pq_max + pac_max
  character(len=H_SHORT), private :: w_name(w_nmax)
 
  data w_name / 'I_LCccn', &
                'I_NCccn', &
                'I_LIccn', &
                'I_NIccn', &
                'I_LChom', &
                'I_NChom', &
                'I_LChet', &
                'I_NChet', &
                'I_LRhet', &
                'I_NRhet', & ! 10
                'I_LImlt', &
                'I_NImlt', &
                'I_LSmlt', &
                'I_NSmlt', &
                'I_LGmlt', &
                'I_NGmlt', &
                'I_LRdep', &
                'I_NRdep', &
                'I_LIdep', &
                'I_NIdep', & ! 20
                'I_LSdep', &
                'I_NSdep', &
                'I_LGdep', &
                'I_NGdep', &
                'I_LCdep', &
                'I_LCaut', &
                'I_NCaut', &
                'I_NRaut', &
                'I_LCacc', &
                'I_NCacc', & ! 30
                'I_NRslc', &
                'I_NRbrk', &
                'I_LIcon', &
                'I_NIcon', &
                'I_LScon', &
                'I_NScon', &
                'I_LIacm', &
                'I_NIacm', &
                'I_LIarm', &
                'I_NIarm', & ! 40
                'I_LSacm', &
                'I_NSacm', &
                'I_LSarm', &
                'I_NSarm', &
                'I_LGacm', &
                'I_NGacm', &
                'I_LGarm', &
                'I_NGarm', &
                'I_LGspl', &
                'I_LSspl', & ! 50
                'I_NIspl', &
                'I_LIhom', &
                'I_NIhom', &
                'I_NGspl', &
                'I_NSspl', & ! PQ_MAX
                'I_LIacLC2LI', &
                'I_NIacNC2NI', &
                'I_LSacLC2LS', &
                'I_NSacNC2NS', &
                'I_LGacLC2LG', &
                'I_NGacNC2NG', &
                'I_LRacLI2LG_I', &
                'I_NRacNI2NG_I', &
                'I_LRacLI2LG_R', &
                'I_NRacNI2NG_R', & ! 10
                'I_LRacLS2LG_S', &
                'I_NRacNS2NG_S', &
                'I_LRacLS2LG_R', &
                'I_NRacNS2NG_R', &
                'I_LRacLG2LG', &
                'I_NRacNG2NG', &
                'I_LIacLI2LS', &
                'I_NIacNI2NS', &
                'I_LIacLS2LS', &
                'I_NIacNS2NS', & ! 20
                'I_NSacNS2NS', &
                'I_NGacNG2NG', &
                'I_LGacLS2LG', &
                'I_NGacNS2NG', &
                'I_LRacLG2LR', &
                'I_NRacNG2NR', &
                'I_LIacLG2LG', &
                'I_NIacNG2NG', &
                'I_CGNGacNS2NG', &
                'I_CGNGacNI2NG' / ! 30 Pac_MAX
 
  real(rp), private, allocatable :: w3d(:,:,:,:)
  integer,  private              :: hist_id(w_nmax), hist_idx(w_nmax)
  integer,  private              :: hist_max
 
 
  real(rp), private, parameter :: rhow =  1000.0_rp ! typical density for warm particles   [kg/m3]
  real(rp), private, parameter :: rhof =   100.0_rp ! typical density for frozen particles [kg/m3]
  real(rp), private, parameter :: rhog =   400.0_rp ! typical density for grapel particles [kg/m3]
 
  ! for all processes
  ! SB06, Table 1.
  real(rp), private, parameter :: xc_min = 4.20e-15_rp   ! [kg] : min mass, D_min=2um
  real(rp), private, parameter :: xr_min = 2.60e-10_rp   ! [kg] : min mass, D_min=79um
  real(rp), private, parameter :: xi_min = 3.382e-13_rp  ! [kg] : min mass, D_min=10um
  real(rp), private, parameter :: xs_min = 1.847e-12_rp  ! [kg] : min mass, D_min=20um
  real(rp), private, parameter :: xg_min = 1.230e-10_rp  ! [kg] : min mass, D_min=100um
  ! refer to Seifert(2002) (Dr. Thesis, Table.5.1)
  real(rp), private, parameter :: xc_max = 2.6e-10_rp    ! [kg] : max, D_max=79um
  real(rp), private, parameter :: xr_max = 5.00e-6_rp    ! [kg] : max, D_max=2mm
  real(rp), private, parameter :: xi_max = 1.377e-6_rp   ! [kg] : max, D_max=5mm
  real(rp), private, parameter :: xs_max = 7.519e-6_rp   ! [kg] : max, D_max=1cm
  real(rp), private, parameter :: xg_max = 4.900e-5_rp   ! [kg] : max, D_max=1cm
  ! filter similar to Ikawa et al.(1991) sec.3.5
  real(rp), private, parameter :: xmin_filter= xc_min
  ! filter of effective radius(1 micron)
  real(rp), private, parameter :: rmin_re= 1.e-6_rp
  !
  ! SB06(95),(96)
  real(rp), private, parameter :: n0r_min= 2.5e+5_rp    ! [m-4]: min intercept parameter of rain
  real(rp), private, parameter :: n0r_max= 2.0e+7_rp    ! [m-4]: max
  real(rp), private, parameter :: lambdar_min= 1.e+3_rp ! [m-1]: min slope parameter of rain
  real(rp), private, parameter :: lambdar_max= 1.e+4_rp ! [m-1]: max
  ! empirical value from Meyers etal.(1991), 1[/liter] = 1.d3[/m3]
  real(rp), private, parameter :: nc_min = 1.e+4_rp     ! [m-3] empirical T.Mitsui
  real(rp), private, parameter :: nr_min = 1.0_rp     ! [m-3] 1/1000 [/liter]
  real(rp), private, parameter :: ni_min = 1.0_rp     ! [m-3]
  real(rp), private, parameter :: ns_min = 1.e-4_rp    ! [m-3]
  real(rp), private, parameter :: ng_min = 1.e-4_rp    ! [m-3]
  ! empirical filter
  real(rp), private, parameter :: lc_min = xc_min*nc_min
  real(rp), private, parameter :: lr_min = xr_min*nr_min
  real(rp), private, parameter :: li_min = xi_min*ni_min
  real(rp), private, parameter :: ls_min = xs_min*ns_min
  real(rp), private, parameter :: lg_min = xg_min*ng_min
  !
  real(rp), private, parameter :: x_sep   = 2.6e-10_rp ! boundary mass between cloud and rain
  !
  real(rp), private, parameter :: tem_min=100.0_rp
  real(rp), private, parameter :: rho_min=1.e-5_rp     ! 3.e-3 is lower limit recognized in many experiments.
  real(rp), private, parameter :: rhoi   = 916.70_rp
  !
  integer, private, save :: ntmax_phase_change = 1
  integer, private, save :: ntmax_collection   = 1
  !
  !--- standard density
  real(rp), private, parameter :: rho_0 = 1.280_rp
  !--- max number of Nc( activatable aerosol number concentration )
  real(rp), allocatable, private, save :: nc_uplim_d(:,:,:)
  !
  !--- thermal conductivity of air
  real(rp), private, parameter :: ka0  = 2.428e-2_rp
  
  real(rp), private, parameter :: dka_dt = 7.47e-5_rp
  
  !====== Ka = Ka0 + temc*dKa_dT
  !
  !--- Dynamic viscosity
  real(rp), private, parameter :: mua0 = 1.718e-5_rp
  
  real(rp), private, parameter :: dmua_dt = 5.28e-8_rp
  
  !======  mua = mua0 + temc*dmua_dT
  !
  real(rp), private, save :: xc_ccn = 1.e-12_rp ! [kg]
  real(rp), private, save :: xi_ccn = 1.e-12_rp ! [kg] ! [move] 11/08/30 T.Mitsui
  !
  ! capacity of diffusional growth
  ! ( dependent of their geometries )
  real(rp), private, save :: cap(hydro_max)
  !
  ! constants for Diameter-Mass relation
  ! D = a * x^b
  real(rp), private, save :: a_m(hydro_max), log_a_m(hydro_max)
  real(rp), private, save :: b_m(hydro_max)
  !$acc declare create(a_m, log_a_m, b_m)
 
  ! constants for Terminal velocity-Mass relation
  ! vt = alpha * x^beta * f
  real(rp), private, save :: alpha_v(hydro_max,2), log_alpha_v(hydro_max,2)
  real(rp), private, save :: beta_v(hydro_max,2), log_beta_v(hydro_max,2)
  real(rp), private, save :: alpha_vn(hydro_max,2)   !
  real(rp), private, save :: beta_vn(hydro_max,2)    !
  real(rp), private, save :: gamma_v(hydro_max)
  !$acc declare create(beta_v, beta_vn, gamma_v)
 
  !  Aerodynamical factor for correction of terminal velocity.(Heymsfield and Iaquinta, 2000)
  !  vt(tem,pre) = vt0 * (pre/pre0)**a_pre0 * (tem/tem0)**a_tem0
  real(rp), private, parameter :: pre0_vt   = 300.e+2_rp  ! 300hPa
  real(rp), private, parameter :: tem0_vt   = 233.0_rp  ! -40degC
  real(rp), private, parameter :: a_pre0_vt = -0.1780_rp
  real(rp), private, parameter :: a_tem0_vt = -0.3940_rp
  ! Parameters to determine Droplet Size Distribution
  ! as a General Gamma Distribution
  ! f(x) = A x^nu exp(-lambda x^mu )
  ! for Marshall Palmer Distribution ( popular for rain )
  !     mu=1/3, nu=-2/3
  ! for Gamma Distribution ( popular for cloud )
  !     mu=1
  real(rp), private, save :: nu(hydro_max)
  real(rp), private, save :: mu(hydro_max)
  !$acc declare create(nu)
 
  ! Mitchell(1996), JAS, vol.53, No.12, pp.1710-1723
  !  area = a_area*D^b_area
  !  area = ax_area*x^bx_area
  ! Auer and Veal(1970), JAS, vol.27, pp.919-pp.926
  ! height = a_h*x^b_h( based on h=a_ar*D^b_ar,  ar:aspect ratio)
  real(rp), private, save :: a_area(hydro_max)       !
  real(rp), private, save :: b_area(hydro_max)       !
  real(rp), private, save :: ax_area(hydro_max)      !
  real(rp), private, save :: bx_area(hydro_max)      !
  ! parameters for radius of equivalent area
  ! r_ea = a_rea*x**b_rea
  real(rp), private, save :: a_rea(hydro_max)        !
  real(rp), private, save :: b_rea(hydro_max)        !
  real(rp), private, save :: a_rea2(hydro_max)       !
  real(rp), private, save :: b_rea2(hydro_max)       !
  real(rp), private, save :: a_rea3(hydro_max)       !
  real(rp), private, save :: b_rea3(hydro_max)       !
  !
  real(rp), private, save :: a_d2vt(hydro_max)       !
  real(rp), private, save :: b_d2vt(hydro_max)       !
  ! coefficient of x^2 moment of DSD
  ! Z = integral x*x*f(x) dx
  !   = coef_m2*N*(L/N)^2
  real(rp), private, save :: coef_m2(hydro_max)
  ! radar reflectivity coefficient defined by diameter
  real(rp), private, save :: coef_d6(hydro_max)      !
  ! volume coefficient defined by diameter
  real(rp), private, save :: coef_d3(hydro_max)      !
  ! coefficient of weighted mean diameter
  real(rp), private, save :: coef_d(hydro_max)
  ! coefficient of weighted mean d*d*v
  real(rp), private, save :: coef_d2v(hydro_max)     !
  ! coefficient of moment of d*d*v
  real(rp), private, save :: coef_md2v(hydro_max)    !
  !
  ! for effective radius(spherical particle)
  real(rp), private, save :: coef_r2(hydro_max)
  real(rp), private, save :: coef_r3(hydro_max)
  real(rp), private, save :: coef_re(hydro_max)
  ! for effective radius(hexagonal plate)
  real(rp), private, save :: coef_rea2(hydro_max)    !
  real(rp), private, save :: coef_rea3(hydro_max)    !
  logical, private, save :: opt_m96_ice=.true.               !
  logical, private, save :: opt_m96_column_ice=.false.       !
  !
  ! coefficeint of weighted mean terminal velocity
  ! vt0 is number weighted and
  ! vt1 is mass   weighted.
  real(rp), private, save :: coef_vt0(hydro_max,2), log_coef_vt0(hydro_max,2)
  real(rp), private, save :: coef_vt1(hydro_max,2), log_coef_vt1(hydro_max,2)
  real(rp), private, save :: coef_deplc
  real(rp), private, save :: coef_dave_n(hydro_max), log_coef_dave_n(hydro_max)
  real(rp), private, save :: coef_dave_l(hydro_max), log_coef_dave_l(hydro_max)
  !$acc declare create(log_coef_vt0, log_coef_vt1)
  !$acc declare create(log_coef_dave_N, log_coef_dave_L)
 
  ! diameter of terminal velocity branch
  !
  real(rp), private, save :: d0_ni=261.76e-6_rp, log_d0_ni
  real(rp), private, save :: d0_li=398.54e-6_rp, log_d0_li
  real(rp), private, parameter :: d0_ns=270.03e-6_rp, log_d0_ns = log(d0_ns)
  real(rp), private, parameter :: d0_ls=397.47e-6_rp, log_d0_ls = log(d0_ls)
  real(rp), private, parameter :: d0_ng=269.08e-6_rp, log_d0_ng = log(d0_ng)
  real(rp), private, parameter :: d0_lg=376.36e-6_rp, log_d0_lg = log(d0_lg)
  !$acc declare create(log_d0_ni, log_d0_li)
 
  !
  real(rp), private, parameter :: coef_vtr_ar1=9.65_rp    ! coef. for large branch
  ! original parameter of Rogers etal.(1993)
  real(rp), private, parameter :: coef_vtr_br1=10.43_rp    ! ...
  real(rp), private, parameter :: coef_vtr_cr1=600.0_rp    ! ...
  real(rp), private, parameter :: coef_vtr_ar2=4.e+3_rp     ! coef. for small branch
  real(rp), private, parameter :: coef_vtr_br2=12.e+3_rp     ! ...
  real(rp), private, parameter :: d_vtr_branch=0.745e-3_rp  ! 0.745 mm (diameter dividing 2-branches)
  ! equilibrium diameter of rain break-up
  real(rp), private, parameter :: dr_eq   = 1.10e-3_rp ! eqilibrium diameter, Seifert 2008(36)
  ! coefficient of General Gamma.
  !  f(x)  = A x^nu exp(-lambda x^mu )
  ! lambda = coef_lambda * (L/N)^{-mu}
  !     A  = coef_A*N*lambda^slope_A
  real(rp), private, save :: coef_a(hydro_max)
  real(rp), private, save :: coef_lambda(hydro_max)
!  real(RP), private, save :: slope_A(HYDRO_MAX)
  ! coefficeint of weighted ventilation effect.
  ! large, and small branch is by PK97(13-60),(13-61),(13-88),(13-89)
  real(rp), private, save :: ah_vent  (hydro_max,2) !
  real(rp), private, save :: bh_vent  (hydro_max,2) !
  real(rp), private, save :: ah_vent0 (hydro_max,2) !
  real(rp), private, save :: bh_vent0 (hydro_max,2) !
  real(rp), private, save :: ah_vent1 (hydro_max,2) !
  real(rp), private, save :: bh_vent1 (hydro_max,2) !
  ! coefficient of collision growth
  real(rp), private, save :: delta_b0 (hydro_max)
  real(rp), private, save :: delta_b1 (hydro_max)
  real(rp), private, save :: delta_ab0(hydro_max,hydro_max)
  real(rp), private, save :: delta_ab1(hydro_max,hydro_max)
  !
  real(rp), private, save :: theta_b0 (hydro_max)
  real(rp), private, save :: theta_b1 (hydro_max)
  real(rp), private, save :: theta_ab0(hydro_max,hydro_max)
  real(rp), private, save :: theta_ab1(hydro_max,hydro_max)
  !
  logical, private, save :: opt_debug=.false.
  !
  logical, private, save :: opt_debug_inc=.true.
  logical, private, save :: opt_debug_act=.true.
  logical, private, save :: opt_debug_ree=.true.
  logical, private, save :: opt_debug_bcs=.true.
 
  logical, save, private :: opt_collection_bin = .false. ! SO22
 
  logical, private, save :: mp_doautoconversion = .true.
  logical, private, save :: mp_couple_aerosol   = .false. ! apply CCN effect?
  real(rp), private, save :: mp_ssw_lim = 1.e+1_rp
 
  !
  ! namelist variables for nucleation
  !
  ! total aerosol number concentration [/m3]
  real(rp), private, parameter :: c_ccn_ocean= 1.00e+8_rp
  real(rp), private, parameter :: c_ccn_land = 1.26e+9_rp
  real(rp), private, save      :: c_ccn      = 1.00e+8_rp
  ! aerosol activation factor
  real(rp), private, parameter :: kappa_ocean= 0.462_rp
  real(rp), private, parameter :: kappa_land = 0.308_rp
  real(rp), private, save      :: kappa      = 0.462_rp
  real(rp), private, save      :: c_in       = 1.0_rp
  ! SB06 (36)
  real(rp), private, save :: nm_m92 = 1.e+3_rp
  real(rp), private, save :: am_m92 = -0.639_rp
  real(rp), private, save :: bm_m92 = 12.96_rp
  !
  real(rp), private, save :: in_max = 1000.e+3_rp ! max num. of Ice-Nuclei [num/m3]
  real(rp), private, save :: ssi_max= 0.60_rp
  real(rp), private, save :: ssw_max= 1.1_rp  ! [%]
  !
  real(rp), private, save :: qke_min = 0.03_rp ! sigma=0.1[m/s], 09/08/18 T.Mitsui
  real(rp), private, save :: tem_ccn_low=233.150_rp  ! = -40 degC  ! [Add] 10/08/03 T.Mitsui
  real(rp), private, save :: tem_in_low =173.150_rp  ! = -100 degC ! [Add] 10/08/03 T.Mitsui
  logical,  private, save :: nucl_twomey = .false.
  logical,  private, save :: inucl_w     = .false.
  logical,  private, save :: so22_het     = .false. ! SO22
  logical,  private, save :: opt_nucleation_ice_hom  = .false. ! SO22
 
  ! for incomplete gamma function
  real(rp), private, parameter :: rc_cr= 12.e-6_rp ! critical size[micron]
  real(rp), private, save :: xc_cr    ! mass[kg] of cloud with r=critical size[micron]
  real(rp), private, save :: alpha    ! slope parameter of gamma function
  real(rp), private, save :: gm, lgm  ! gamma(alpha), log(gamma(alpha))
 
 
  !=== for collection
  !--- threshold of diameters to collide with others
  real(rp), private, save :: dc0 =  15.0e-6_rp       ! lower threshold of cloud
  real(rp), private, save :: dc1 =  40.0e-6_rp       ! upper threshold of cloud
  real(rp), private, save :: di0 = 150.0e-6_rp       ! lower threshold of cloud
  real(rp), private, save :: ds0 = 150.0e-6_rp       ! lower threshold of cloud
  real(rp), private, save :: dg0 = 150.0e-6_rp       ! lower threshold of cloud
  !--- standard deviation of terminal velocity[m/s]
  real(rp), private, save :: sigma_c=0.00_rp        ! cloud
  real(rp), private, save :: sigma_r=0.00_rp        ! rain
  real(rp), private, save :: sigma_i=0.2_rp        ! ice
  real(rp), private, save :: sigma_s=0.2_rp        ! snow
  real(rp), private, save :: sigma_g=0.00_rp        ! graupel
  !--- max collection efficiency for cloud
  real(rp), private, save :: e_im = 0.80_rp        ! ice max
  real(rp), private, save :: e_sm = 0.80_rp        ! snow max
  real(rp), private, save :: e_gm = 1.00_rp        ! graupel max
  !--- collection efficiency between 2 species
  real(rp), private, save :: e_ir=1.0_rp            ! ice     x rain
  real(rp), private, save :: e_sr=1.0_rp            ! snow    x rain
  real(rp), private, save :: e_gr=1.0_rp            ! graupel x rain
  real(rp), private, save :: e_ii=1.0_rp            ! ice     x ice
  real(rp), private, save :: e_si=1.0_rp            ! snow    x ice
  real(rp), private, save :: e_gi=1.0_rp            ! graupel x ice
  real(rp), private, save :: e_ss=1.0_rp            ! snow    x snow
  real(rp), private, save :: e_gs=1.0_rp            ! graupel x snow
  real(rp), private, save :: e_gg=1.0_rp            ! graupel x graupel
  !=== for partial conversion
  !--- flag: 1=> partial conversion to graupel, 0=> no conversion
  integer,  private, save :: i_iconv2g=1          ! ice  => graupel
  integer,  private, save :: i_sconv2g=1          ! snow => graupel
  !--- bulk density of graupel
  real(rp), private, save :: rho_g   = 900.0_rp     ! [kg/m3]
  !--- space filling coefficient [%]
  real(rp), private, save :: cfill_i = 0.68_rp     ! ice
  real(rp), private, save :: cfill_s = 0.01_rp     ! snow
  !--- critical diameter for ice conversion
  real(rp), private, save :: di_cri  = 500.e-6_rp    ! [m]
  logical,  private, save :: opt_stick_ks96=.false.
  logical,  private, save :: opt_stick_co86=.false.
  ! from Seiki and Ohno (2022)
  logical,  private, save :: opt_stick_rhh57=.false.
  logical,  private, save :: opt_stick_rhks96=.false.
  real(rp), private, save :: tem_min_estick=253.0_rp
  logical,  private, save :: opt_stick_c12=.false.
 
  real(rp), private, save :: fac_cndc        = 1.0_rp
  logical,  private, save :: opt_fix_taucnd_c=.false.
 
  ! limitter for vapor diffusivity
  ! this value was suggested in Pruppacher and Klett(1997),(13-3)
  ! although Hall and Pruppacher (1976) extrapolated upto -80 deg
  real(rp), private, save :: temc_lim_diff = -80.0_rp ! HP76
  !                                          -40.0_RP ! PK97
 
 
 
  !-----------------------------------------------------------------------------
contains
  !-----------------------------------------------------------------------------
  subroutine atmos_phy_mp_sn14_setup( &
    KA, IA, JA )
    use scale_prc, only: &
       prc_abort
    use scale_file_history, only: &
       file_history_reg
    implicit none
    integer, intent(in) :: ka
    integer, intent(in) :: ia
    integer, intent(in) :: ja
 
    namelist / param_atmos_phy_mp_sn14 / &
       mp_doautoconversion, &
       mp_ssw_lim,          &
       mp_couple_aerosol
 
    integer :: ip
    integer :: ierr
    !---------------------------------------------------------------------------
 
    log_newline
    log_info("ATMOS_PHY_MP_sn14_setup",*) 'Setup'
    log_info("ATMOS_PHY_MP_sn14_setup",*) 'Seiki and Nakajima (2014) 2-moment bulk 6 category'
 
    !--- read namelist
    rewind(io_fid_conf)
    read(io_fid_conf,nml=param_atmos_phy_mp_sn14,iostat=ierr)
    if( ierr < 0 ) then !--- missing
       log_info("ATMOS_PHY_MP_sn14_setup",*) 'Not found namelist. Default used.'
    elseif( ierr > 0 ) then !--- fatal error
       log_error("ATMOS_PHY_MP_sn14_setup",*) 'Not appropriate names in namelist PARAM_ATMOS_PHY_MP_SN14. Check!'
       call prc_abort
    endif
    log_nml(param_atmos_phy_mp_sn14)
 
    call mp_sn14_init
 
    allocate(nc_uplim_d(1,ia,ja))
    nc_uplim_d(:,:,:) = 150.e6_rp
 
    hist_max = 0
    hist_idx(:) = -1
    do ip = 1, w_nmax
       call file_history_reg( w_name(ip),  'individual tendency term in SN14', 'kg/kg/s', &
                              hist_id(ip) )
       if ( hist_id(ip) > 0 ) then
          hist_max = hist_max + 1
          hist_idx(ip) = hist_max
       end if
    enddo
    allocate( w3d(ka,ia,ja,hist_max) )
    w3d(:,:,:,:) = 0.0_rp
 
    return
  end subroutine atmos_phy_mp_sn14_setup
 
  !-----------------------------------------------------------------------------
  subroutine atmos_phy_mp_sn14_finalize
 
    deallocate(nc_uplim_d)
    deallocate(w3d)
 
    return
  end subroutine atmos_phy_mp_sn14_finalize
 
  !-----------------------------------------------------------------------------
  subroutine atmos_phy_mp_sn14_tendency( &
       KA, KS, KE, IA, IS, IE, JA, JS, JE, &
       DENS, &
       W,    &
       QTRC, &
       PRES, &
       TEMP, &
       Qdry, &
       CPtot, &
       CVtot, &
       CCN, &
       dt, &
       cz, &
       fz, &
       RHOQ_t, &
       RHOE_t, &
       CPtot_t, &
       CVtot_t, &
       EVAPORATE, &
       flg_lt, &
       d0_crg, v0_crg, &
       dqcrg, &
       beta_crg, &
       QTRC_crg, &
       QSPLT_in, Sarea, &
       RHOQcrg_t      )
    implicit none
 
    integer, intent(in) :: ka, ks, ke
    integer, intent(in) :: ia, is, ie
    integer, intent(in) :: ja, js, je
 
    real(rp), intent(in) :: dens     (ka,ia,ja)
    real(rp), intent(in) :: w        (ka,ia,ja)
    real(rp), intent(in) :: qtrc     (ka,ia,ja,qa_mp)
    real(rp), intent(in) :: pres(ka,ia,ja)
    real(rp), intent(in) :: temp(ka,ia,ja)
    real(rp), intent(in) :: qdry(ka,ia,ja)
    real(rp), intent(in) :: cptot(ka,ia,ja)
    real(rp), intent(in) :: cvtot(ka,ia,ja)
    real(rp), intent(in) :: ccn      (ka,ia,ja)
    real(dp), intent(in) :: dt
    real(rp), intent(in) :: cz(  ka,ia,ja)
    real(rp), intent(in) :: fz(0:ka,ia,ja)
 
    real(rp), intent(out) :: rhoq_t   (ka,ia,ja,qa_mp)
    real(rp), intent(out) :: rhoe_t   (ka,ia,ja)
    real(rp), intent(out) :: cptot_t(ka,ia,ja)
    real(rp), intent(out) :: cvtot_t(ka,ia,ja)
    real(rp), intent(out) :: evaporate(ka,ia,ja)   !--- number of evaporated cloud [/m3]
 
    ! Optional for Lightning
    logical,  intent(in), optional :: flg_lt
    real(rp), intent(in), optional :: d0_crg, v0_crg
    real(rp), intent(in), optional :: dqcrg(ka,ia,ja)
    real(rp), intent(in), optional :: beta_crg(ka,ia,ja)
    real(rp), intent(in), optional :: qtrc_crg(ka,ia,ja,hydro_max)
    real(rp), intent(out), optional :: qsplt_in(ka,ia,ja,3)
    real(rp), intent(out), optional :: sarea(ka,ia,ja,hydro_max)
    real(rp), intent(out), optional :: rhoqcrg_t(ka,ia,ja,hydro_max)
    !---------------------------------------------------------------------------
 
    log_progress(*) 'atmosphere / physics / microphysics / SN14'
 
#ifdef PROFILE_FIPP
    call fipp_start()
#endif
 
    !##### MP Main #####
    call mp_sn14 ( &
       ka, ks, ke, ia, is, ie, ja, js, je, &
       dens(:,:,:), w(:,:,:), qtrc(:,:,:,:), pres(:,:,:), temp(:,:,:), & ! (in)
       qdry(:,:,:), cptot(:,:,:), cvtot(:,:,:), ccn(:,:,:),            & ! (in)
       real(dt,rp), cz(:,:,:), fz(:,:,:),                              & ! (in)
       rhoq_t(:,:,:,:), rhoe_t(:,:,:), cptot_t(:,:,:), cvtot_t(:,:,:), & ! (out)
       evaporate(:,:,:),                                               & ! (out)
       flg_lt, d0_crg, v0_crg, dqcrg(:,:,:), beta_crg(:,:,:),          & ! (optional in)
       qtrc_crg(:,:,:,:),                                              & ! (optional in)
       qsplt_in(:,:,:,:), sarea(:,:,:,:), rhoqcrg_t(:,:,:,:)           ) ! (optional out)
 
#ifdef PROFILE_FIPP
    call fipp_stop()
#endif
 
    return
  end subroutine atmos_phy_mp_sn14_tendency
 
  !-----------------------------------------------------------------------------
  subroutine atmos_phy_mp_sn14_cloud_fraction( &
       KA, KS, KE, IA, IS, IE, JA, JS, JE, &
       QTRC,           &
       mask_criterion, &
       cldfrac         )
    implicit none
    integer, intent(in) :: ka, ks, ke
    integer, intent(in) :: ia, is, ie
    integer, intent(in) :: ja, js, je
 
    real(rp), intent(in)  :: qtrc   (ka,ia,ja,qa_mp-1)
    real(rp), intent(in)  :: mask_criterion
 
    real(rp), intent(out) :: cldfrac(ka,ia,ja)
 
    real(rp) :: qhydro
    integer  :: k, i, j, iq
    !---------------------------------------------------------------------------
 
    !$omp parallel do &
    !$omp private(qhydro)
    do j  = js, je
    do i  = is, ie
    do k  = ks, ke
       qhydro = 0.0_rp
       do iq = i_mp_qc, i_mp_qg
          qhydro = qhydro + qtrc(k,i,j,iq)
       enddo
       cldfrac(k,i,j) = 0.5_rp + sign(0.5_rp,qhydro-mask_criterion)
    enddo
    enddo
    enddo
 
    return
  end subroutine atmos_phy_mp_sn14_cloud_fraction
  !-----------------------------------------------------------------------------
  subroutine atmos_phy_mp_sn14_effective_radius( &
       KA, KS, KE, IA, IS, IE, JA, JS, JE, &
       DENS0, TEMP0, QTRC0, &
       Re                   )
    use scale_atmos_hydrometeor, only: &
       n_hyd, &
       i_hc,  &
       i_hr,  &
       i_hi,  &
       i_hs,  &
       i_hg,  &
       i_hh
    implicit none
    integer, intent(in) :: ka, ks, ke
    integer, intent(in) :: ia, is, ie
    integer, intent(in) :: ja, js, je
 
    real(rp), intent(in)  :: dens0(ka,ia,ja)        ! density                   [kg/m3]
    real(rp), intent(in)  :: temp0(ka,ia,ja)        ! temperature               [K]
    real(rp), intent(in)  :: qtrc0(ka,ia,ja,i_qc:i_ng)     ! tracer mass concentration [kg/kg]
 
    real(rp), intent(out) :: re   (ka,ia,ja,n_hyd) ! effective radius          [cm]
 
    ! mass concentration[kg/m3] and mean particle mass[kg]
    real(rp) :: xc(ka)
    real(rp) :: xr(ka)
    real(rp) :: xi(ka)
    real(rp) :: xs(ka)
    real(rp) :: xg(ka)
    ! diameter of average mass[kg/m3]
    real(rp) :: dc_ave(ka)
    real(rp) :: dr_ave(ka)
    ! radius of average mass
    real(rp) :: rc, rr
    ! 2nd. and 3rd. order moment of DSD
    real(rp) :: ri2m(ka), ri3m(ka)
    real(rp) :: rs2m(ka), rs3m(ka)
    real(rp) :: rg2m(ka), rg3m(ka)
 
    real(rp), parameter :: coef_fuetal1998 = 3.0_rp / (4.0_rp*rhoi)
 
    ! r2m_min is minimum value(moment of 1 particle with 1 micron)
    real(rp), parameter :: r2m_min=1.e-12_rp
    real(rp), parameter :: um2cm = 100.0_rp
 
    real(rp) :: limitsw, zerosw
    integer :: k, i, j
    !---------------------------------------------------------------------------
 
    !$omp parallel do &
    !$omp private(xc,xr,xi,xs,xg,dc_ave,dr_ave,rc,rr,ri2m,ri3m,rs2m,rs3m,rg2m,rg3m, &
    !$omp         limitsw,zerosw)
    do j  = js, je
    do i  = is, ie
 
       ! mean particle mass[kg]
       do k  = ks, ke
          xc(k) = min( xc_max, max( xc_min, dens0(k,i,j)*qtrc0(k,i,j,i_qc)/(qtrc0(k,i,j,i_nc)+nc_min) ) )
          xr(k) = min( xr_max, max( xr_min, dens0(k,i,j)*qtrc0(k,i,j,i_qr)/(qtrc0(k,i,j,i_nr)+nr_min) ) )
          xi(k) = min( xi_max, max( xi_min, dens0(k,i,j)*qtrc0(k,i,j,i_qi)/(qtrc0(k,i,j,i_ni)+ni_min) ) )
          xs(k) = min( xs_max, max( xs_min, dens0(k,i,j)*qtrc0(k,i,j,i_qs)/(qtrc0(k,i,j,i_ns)+ns_min) ) )
          xg(k) = min( xg_max, max( xg_min, dens0(k,i,j)*qtrc0(k,i,j,i_qg)/(qtrc0(k,i,j,i_ng)+ng_min) ) )
       enddo
 
       ! diameter of average mass : SB06 eq.(32)
       do k = ks, ke
          dc_ave(k) = a_m(i_mp_qc) * xc(k)**b_m(i_mp_qc)
          dr_ave(k) = a_m(i_mp_qr) * xr(k)**b_m(i_mp_qr)
       enddo
 
       ! cloud effective radius
       do k = ks, ke
          rc = 0.5_rp * dc_ave(k)
          limitsw = 0.5_rp + sign(0.5_rp, rc-rmin_re )
          re(k,i,j,i_hc) = coef_re(i_mp_qc) * rc * limitsw * um2cm
       enddo
 
       ! rain effective radius
       do k = ks, ke
          rr = 0.5_rp * dr_ave(k)
          limitsw = 0.5_rp + sign(0.5_rp, rr-rmin_re )
          re(k,i,j,i_hr) = coef_re(i_mp_qr) * rr * limitsw * um2cm
       enddo
 
       do k = ks, ke
          ri2m(k) = pi * coef_rea2(i_mp_qi) * qtrc0(k,i,j,i_ni) * a_rea2(i_mp_qi) * xi(k)**b_rea2(i_mp_qi)
          rs2m(k) = pi * coef_rea2(i_mp_qs) * qtrc0(k,i,j,i_ns) * a_rea2(i_mp_qs) * xs(k)**b_rea2(i_mp_qs)
          rg2m(k) = pi * coef_rea2(i_mp_qg) * qtrc0(k,i,j,i_ng) * a_rea2(i_mp_qg) * xg(k)**b_rea2(i_mp_qg)
       enddo
 
       ! Fu(1996), eq.(3.11) or Fu et al.(1998), eq.(2.5)
       do k = ks, ke
          ri3m(k) = coef_fuetal1998 * qtrc0(k,i,j,i_ni) * xi(k)
          rs3m(k) = coef_fuetal1998 * qtrc0(k,i,j,i_ns) * xs(k)
          rg3m(k) = coef_fuetal1998 * qtrc0(k,i,j,i_ng) * xg(k)
       enddo
 
       ! ice effective radius
       do k = ks, ke
          zerosw = 0.5_rp - sign(0.5_rp, ri2m(k) - r2m_min )
          re(k,i,j,i_hi) = ri3m(k) / ( ri2m(k) + zerosw ) * ( 1.0_rp - zerosw ) * um2cm
       enddo
 
       ! snow effective radius
       do k = ks, ke
          zerosw = 0.5_rp - sign(0.5_rp, rs2m(k) - r2m_min )
          re(k,i,j,i_hs) = rs3m(k) / ( rs2m(k) + zerosw ) * ( 1.0_rp - zerosw ) * um2cm
       enddo
 
       ! graupel effective radius
       do k = ks, ke
          zerosw = 0.5_rp - sign(0.5_rp, rg2m(k) - r2m_min )
          re(k,i,j,i_hg) = rg3m(k) / ( rg2m(k) + zerosw ) * ( 1.0_rp - zerosw ) * um2cm
       enddo
 
       do k = ks, ke
          re(k,i,j,i_hh) = 0.0_rp
       end do
 
    enddo
    enddo
 
 
    return
  end subroutine atmos_phy_mp_sn14_effective_radius
  !-----------------------------------------------------------------------------
  subroutine atmos_phy_mp_sn14_qtrc2qhyd( &
       KA, KS, KE, IA, IS, IE, JA, JS, JE, &
       QTRC0, &
       Qe     )
    use scale_atmos_hydrometeor, only: &
       n_hyd, &
       i_hc,  &
       i_hr,  &
       i_hi,  &
       i_hs,  &
       i_hg,  &
       i_hh
    implicit none
    integer, intent(in) :: ka, ks, ke
    integer, intent(in) :: ia, is, ie
    integer, intent(in) :: ja, js, je
 
    real(rp), intent(in)  :: qtrc0(ka,ia,ja,qa_mp-1) ! tracer mass concentration [kg/kg]
 
    real(rp), intent(out) :: qe   (ka,ia,ja,n_hyd)   ! mixing ratio of each cateory [kg/kg]
 
    integer :: k, i, j
    !---------------------------------------------------------------------------
 
!OCL XFILL
    !$omp parallel do
    do j = js, je
    do i = is, ie
    do k = ks, ke
       qe(k,i,j,i_hc) = qtrc0(k,i,j,i_mp_qc)
       qe(k,i,j,i_hr) = qtrc0(k,i,j,i_mp_qr)
       qe(k,i,j,i_hi) = qtrc0(k,i,j,i_mp_qi)
       qe(k,i,j,i_hs) = qtrc0(k,i,j,i_mp_qs)
       qe(k,i,j,i_hg) = qtrc0(k,i,j,i_mp_qg)
       qe(k,i,j,i_hh) = 0.0_rp
    end do
    end do
    end do
 
    return
  end subroutine atmos_phy_mp_sn14_qtrc2qhyd
 
  subroutine atmos_phy_mp_sn14_qtrc2nhyd( &
       KA, KS, KE, IA, IS, IE, JA, JS, JE, &
       QTRC0, &
       Ne     )
    use scale_atmos_hydrometeor, only: &
       n_hyd, &
       i_hc,  &
       i_hr,  &
       i_hi,  &
       i_hs,  &
       i_hg,  &
       i_hh
    implicit none
    integer, intent(in) :: ka, ks, ke
    integer, intent(in) :: ia, is, ie
    integer, intent(in) :: ja, js, je
 
    real(rp), intent(in)  :: qtrc0(ka,ia,ja,qa_mp-1) ! tracer mass concentration [kg/kg]
 
    real(rp), intent(out) :: ne   (ka,ia,ja,n_hyd)   ! number density of each cateory [1/m3]
 
    integer :: k, i, j
    !---------------------------------------------------------------------------
 
!OCL XFILL
    !$omp parallel do
    do j = js, je
    do i = is, ie
    do k = ks, ke
       ne(k,i,j,i_hc) = qtrc0(k,i,j,i_mp_nc)
       ne(k,i,j,i_hr) = qtrc0(k,i,j,i_mp_nr)
       ne(k,i,j,i_hi) = qtrc0(k,i,j,i_mp_ni)
       ne(k,i,j,i_hs) = qtrc0(k,i,j,i_mp_ns)
       ne(k,i,j,i_hg) = qtrc0(k,i,j,i_mp_ng)
       ne(k,i,j,i_hh) = 0.0_rp
    end do
    end do
    end do
 
    return
  end subroutine atmos_phy_mp_sn14_qtrc2nhyd
 
  subroutine atmos_phy_mp_sn14_qhyd2qtrc( &
       KA, KS, KE, IA, IS, IE, JA, JS, JE, &
       Qe, &
       QTRC,     &
       QNUM      )
    use scale_const, only: &
       pi    => const_pi, &
       undef => const_undef
    use scale_atmos_hydrometeor, only: &
       n_hyd, &
       i_hc,  &
       i_hr,  &
       i_hi,  &
       i_hs,  &
       i_hg,  &
       i_hh
    implicit none
    integer, intent(in) :: ka, ks, ke
    integer, intent(in) :: ia, is, ie
    integer, intent(in) :: ja, js, je
 
    real(rp), intent(in) :: qe(ka,ia,ja,n_hyd) ! mass ratio of each cateory [kg/kg]
 
    real(rp), intent(out) :: qtrc(ka,ia,ja,qa_mp-1) ! tracer mass concentration [kg/kg]
 
    real(rp), intent(in), optional :: qnum(ka,ia,ja,n_hyd)
 
    real(rp), parameter :: dc   =  20.e-6_rp ! typical particle diameter for cloud  [m]
    real(rp), parameter :: dr   = 200.e-6_rp ! typical particle diameter for rain   [m]
    real(rp), parameter :: di   =  80.e-6_rp ! typical particle diameter for ice    [m]
    real(rp), parameter :: ds   =  80.e-6_rp ! typical particle diameter for snow   [m]
    real(rp), parameter :: dg   = 200.e-6_rp ! typical particle diameter for grapel [m]
    real(rp), parameter :: b    =     3.0_rp ! assume spherical form
 
    real(rp) :: piov6
 
    integer :: k, i, j
    !---------------------------------------------------------------------------
 
 
!OCL XFILL
    !$omp parallel do
    do j = js, je
    do i = is, ie
    do k = ks, ke
       qtrc(k,i,j,i_mp_qc) = qe(k,i,j,i_hc)
    end do
    end do
    end do
 
!OCL XFILL
    !$omp parallel do
    do j = js, je
    do i = is, ie
    do k = ks, ke
       qtrc(k,i,j,i_mp_qr) = qe(k,i,j,i_hr)
    end do
    end do
    end do
 
!OCL XFILL
    !$omp parallel do
    do j = js, je
    do i = is, ie
    do k = ks, ke
       qtrc(k,i,j,i_mp_qi) = qe(k,i,j,i_hi)
    end do
    end do
    end do
 
!OCL XFILL
    !$omp parallel do
    do j = js, je
    do i = is, ie
    do k = ks, ke
       qtrc(k,i,j,i_mp_qs) = qe(k,i,j,i_hs)
    end do
    end do
    end do
 
!OCL XFILL
    !$omp parallel do
    do j = js, je
    do i = is, ie
    do k = ks, ke
       qtrc(k,i,j,i_mp_qg) = qe(k,i,j,i_hg) + qe(k,i,j,i_hh)
    end do
    end do
    end do
 
    piov6 = pi / 6.0_rp
 
    if ( present(qnum) ) then
 
!OCL XFILL
       !$omp parallel do
       do j = js, je
       do i = is, ie
       do k = ks, ke
          if ( qnum(k,i,j,i_hc) .ne. undef ) then
             qtrc(k,i,j,i_mp_nc) = qnum(k,i,j,i_hc)
          else
             qtrc(k,i,j,i_mp_nc) = qtrc(k,i,j,i_mp_qc) / ( (piov6*rhow) * dc**b )
          end if
       end do
       end do
       end do
 
!OCL XFILL
       !$omp parallel do
       do j = js, je
       do i = is, ie
       do k = ks, ke
          if ( qnum(k,i,j,i_hr) .ne. undef ) then
             qtrc(k,i,j,i_mp_nr) = qnum(k,i,j,i_hr)
          else
             qtrc(k,i,j,i_mp_nr) = qtrc(k,i,j,i_mp_qr) / ( (piov6*rhow) * dr**b )
          end if
       end do
       end do
       end do
 
!OCL XFILL
       !$omp parallel do
       do j = js, je
       do i = is, ie
       do k = ks, ke
          if ( qnum(k,i,j,i_hi) .ne. undef ) then
             qtrc(k,i,j,i_mp_ni) = qnum(k,i,j,i_hi)
          else
             qtrc(k,i,j,i_mp_ni) = qtrc(k,i,j,i_mp_qi) / ( (piov6*rhof) * di**b )
          end if
       end do
       end do
       end do
 
!OCL XFILL
       !$omp parallel do
       do j = js, je
       do i = is, ie
       do k = ks, ke
          if ( qnum(k,i,j,i_hs) .ne. undef ) then
             qtrc(k,i,j,i_mp_ns) = qnum(k,i,j,i_hs)
          else
             qtrc(k,i,j,i_mp_ns) = qtrc(k,i,j,i_mp_qs) / ( (piov6*rhof) * ds**b )
          end if
       end do
       end do
       end do
 
!OCL XFILL
       !$omp parallel do
       do j = js, je
       do i = is, ie
       do k = ks, ke
          if ( qnum(k,i,j,i_hg) .ne. undef ) then
             if ( qnum(k,i,j,i_hh) .ne. undef ) then
                qtrc(k,i,j,i_mp_ng) = qnum(k,i,j,i_hg) + qnum(k,i,j,i_hh)
             else
                qtrc(k,i,j,i_mp_ng) = qnum(k,i,j,i_hg)
             end if
          else
             qtrc(k,i,j,i_mp_ng) = qtrc(k,i,j,i_mp_qg) / ( (piov6*rhog) * dg**b )
          end if
       end do
       end do
       end do
 
    else
 
!OCL XFILL
       !$omp parallel do
       do j = js, je
       do i = is, ie
       do k = ks, ke
          qtrc(k,i,j,i_mp_nc) = qtrc(k,i,j,i_mp_qc) / ( (piov6*rhow) * dc**b )
       end do
       end do
       end do
 
!OCL XFILL
       !$omp parallel do
       do j = js, je
       do i = is, ie
       do k = ks, ke
          qtrc(k,i,j,i_mp_nr) = qtrc(k,i,j,i_mp_qr) / ( (piov6*rhow) * dr**b )
       end do
       end do
       end do
 
!OCL XFILL
       !$omp parallel do
       do j = js, je
       do i = is, ie
       do k = ks, ke
          qtrc(k,i,j,i_mp_ni) = qtrc(k,i,j,i_mp_qi) / ( (piov6*rhof) * di**b )
       end do
       end do
       end do
 
!OCL XFILL
       !$omp parallel do
       do j = js, je
       do i = is, ie
       do k = ks, ke
          qtrc(k,i,j,i_mp_ns) = qtrc(k,i,j,i_mp_qs) / ( (piov6*rhof) * ds**b )
       end do
       end do
       end do
 
!OCL XFILL
       !$omp parallel do
       do j = js, je
       do i = is, ie
       do k = ks, ke
          qtrc(k,i,j,i_mp_ng) = qtrc(k,i,j,i_mp_qg) / ( (piov6*rhog) * dg**b )
       end do
       end do
       end do
 
    end if
 
    return
  end subroutine atmos_phy_mp_sn14_qhyd2qtrc
 
  !-----------------------------------------------------------------------------
!OCL SERIAL
  subroutine atmos_phy_mp_sn14_terminal_velocity( &
       KA, KS, KE, &
      DENS, &
      TEMP, &
      RHOQ, &
      PRES, &
      vterm )
    !$acc routine vector
    use scale_const, only: &
       const_undef
    implicit none
 
    integer, intent(in) :: ka, ks, ke
 
    real(rp), intent(in)  :: rhoq(ka,i_qc:i_ng) ! rho * q
    real(rp), intent(in)  :: dens(ka)    ! rho
    real(rp), intent(in)  :: temp(ka)    ! temperature
    real(rp), intent(in)  :: pres(ka)    ! pressure
 
    real(rp), intent(out) :: vterm(ka,qa_mp-1) ! terminal velocity of cloud mass
 
    real(rp) :: xq, log_xq ! average mass of 1 particle( mass/number )
 
    real(rp) :: rhofac   ! density factor for terminal velocity
    real(rp) :: rhofac_q(ka), log_rhofac_q
 
    real(rp) :: rlambdar(ka) ! work for diagnosis of Rain DSD ( Seifert, 2008 )
    real(rp) :: mud_r
    real(rp) :: dq, log_dq   ! weigthed diameter.   Improved Rogers etal. (1993) formula by T.Mitsui
 
    real(rp) :: weight ! weighting coefficient for 2-branches is determined by ratio between 0.745mm and weighted diameter.  SB06 Table.1
    real(rp) :: velq_s ! terminal velocity for small branch of Rogers formula
    real(rp) :: velq_l ! terminal velocity for large branch of Rogers formula
 
    real(rp) :: tmp
    integer :: k, i, j, iq
    !---------------------------------------------------------------------------
 
    ! QC, NC
    do k = ks, ke
       rhofac = rho_0 / max( dens(k), rho_min )
 
       log_rhofac_q = log(rhofac) * gamma_v(i_mp_qc)
       log_xq = log( max( xc_min, min( xc_max, rhoq(k,i_qc) / ( rhoq(k,i_nc) + nc_min ) ) ) )
 
       vterm(k,i_mp_qc) = - exp( log_rhofac_q + log_coef_vt1(i_mp_qc,1) + log_xq * beta_v(i_mp_qc,1) )
 
       vterm(k,i_mp_nc) = - exp( log_rhofac_q + log_coef_vt0(i_mp_qc,1) + log_xq * beta_vn(i_mp_qc,1) )
    end do
 
    ! QR, NR
    mud_r = 3.0_rp * nu(i_mp_qr) + 2.0_rp
    do k = ks, ke
       rhofac = rho_0 / max( dens(k), rho_min )
       rhofac_q(k) = rhofac**gamma_v(i_mp_qr)
    end do
    do k = ks, ke
       xq = max( xr_min, min( xr_max, rhoq(k,i_qr) / ( rhoq(k,i_nr) + nr_min ) ) )
 
       rlambdar(k) = a_m(i_mp_qr) * xq**b_m(i_mp_qr) &
                   * ( (mud_r+3.0_rp) * (mud_r+2.0_rp) * (mud_r+1.0_rp) )**(-0.333333333_rp)
    end do
!OCL LOOP_FISSION_TARGET(LS)
    do k = ks, ke
       dq = ( 4.0_rp + mud_r ) * rlambdar(k) ! D^(3)+mu weighted mean diameter
       weight = min( 1.0_rp, max( 0.0_rp, 0.5_rp * ( 1.0_rp + tanh( pi * log( dq/d_vtr_branch ) ) ) ) )
       velq_s = coef_vtr_ar2 * dq &
              * ( 1.0_rp - ( 1.0_rp + coef_vtr_br2*rlambdar(k) )**(-5.0_rp-mud_r) )
       velq_l = coef_vtr_ar1 &
              - coef_vtr_br1 * ( 1.0_rp + coef_vtr_cr1*rlambdar(k) )**(-4.0_rp-mud_r)
       vterm(k,i_mp_qr) = -rhofac_q(k) * ( velq_l * (          weight ) &
                                         + velq_s * ( 1.0_rp - weight ) )
    end do
!OCL LOOP_FISSION_TARGET(LS)
    do k = ks, ke
       dq = ( 1.0_rp + mud_r ) * rlambdar(k) ! D^(0)+mu weighted mean diameter
       weight = min( 1.0_rp, max( 0.0_rp, 0.5_rp * ( 1.0_rp + tanh( pi * log( dq/d_vtr_branch ) ) ) ) )
       velq_s = coef_vtr_ar2 * dq &
              * ( 1.0_rp - ( 1.0_rp + coef_vtr_br2*rlambdar(k) )**(-2.0_rp-mud_r) )
       velq_l = coef_vtr_ar1 &
              - coef_vtr_br1 * ( 1.0_rp + coef_vtr_cr1*rlambdar(k) )**(-1.0_rp-mud_r)
       vterm(k,i_mp_nr) = -rhofac_q(k) * ( velq_l * (          weight ) &
                                         + velq_s * ( 1.0_rp - weight ) )
    end do
 
    do k = ks, ke
       rhofac_q(k) = exp( log( pres(k)/pre0_vt ) * a_pre0_vt + log( temp(k)/tem0_vt ) * a_tem0_vt )
    end do
 
    ! QI, NI
!OCL LOOP_FISSION_TARGET(LS)
    do k = ks, ke
       log_xq = log( max( xi_min, min( xi_max, rhoq(k,i_qi) / ( rhoq(k,i_ni) + ni_min ) ) ) )
 
       tmp = log_a_m(i_mp_qi) + log_xq * b_m(i_mp_qi)
       log_dq = log_coef_dave_l(i_mp_qi) + tmp
       weight = min( 1.0_rp, max( 0.0_rp, 0.5_rp * ( 1.0_rp + log_dq - log_d0_li ) ) )
 
       velq_s = exp( log_coef_vt1(i_mp_qi,1) + log_xq * beta_v(i_mp_qi,1) )
       velq_l = exp( log_coef_vt1(i_mp_qi,2) + log_xq * beta_v(i_mp_qi,2) )
       vterm(k,i_mp_qi) = - rhofac_q(k) * ( velq_l * (          weight ) &
                                          + velq_s * ( 1.0_rp - weight ) )
 
       log_dq = log_coef_dave_n(i_mp_qi) + tmp
       weight = min( 1.0_rp, max( 0.0_rp, 0.5_rp * ( 1.0_rp + log_dq - log_d0_ni ) ) )
 
       velq_s = exp( log_coef_vt0(i_mp_qi,1) + log_xq * beta_vn(i_mp_qi,1) )
       velq_l = exp( log_coef_vt0(i_mp_qi,2) + log_xq * beta_vn(i_mp_qi,2) )
       vterm(k,i_mp_ni) = - rhofac_q(k) * ( velq_l * (          weight ) &
                                          + velq_s * ( 1.0_rp - weight ) )
    end do
 
    ! QS, NS
!OCL LOOP_FISSION_TARGET(LS)
    do k = ks, ke
       log_xq = log( max( xs_min, min( xs_max, rhoq(k,i_qs) / ( rhoq(k,i_ns) + ns_min ) ) ) )
 
       tmp = log_a_m(i_mp_qs) + log_xq * b_m(i_mp_qs)
       log_dq = log_coef_dave_l(i_mp_qs) + tmp
       weight = min( 1.0_rp, max( 0.0_rp, 0.5_rp * ( 1.0_rp + log_dq - log_d0_ls ) ) )
 
       velq_s = exp( log_coef_vt1(i_mp_qs,1) + log_xq * beta_v(i_mp_qs,1) )
       velq_l = exp( log_coef_vt1(i_mp_qs,2) + log_xq * beta_v(i_mp_qs,2) )
       vterm(k,i_mp_qs) = - rhofac_q(k) * ( velq_l * (          weight ) &
                                          + velq_s * ( 1.0_rp - weight ) )
 
       log_dq = log_coef_dave_n(i_mp_qs) + tmp
       weight = min( 1.0_rp, max( 0.0_rp, 0.5_rp * ( 1.0_rp + log_dq - log_d0_ns ) ) )
 
       velq_s = exp( log_coef_vt0(i_mp_qs,1) + log_xq * beta_vn(i_mp_qs,1) )
       velq_l = exp( log_coef_vt0(i_mp_qs,2) + log_xq * beta_vn(i_mp_qs,2) )
       vterm(k,i_mp_ns) = - rhofac_q(k) * ( velq_l * (          weight ) &
                                          + velq_s * ( 1.0_rp - weight ) )
    end do
 
    ! QG, NG
!OCL LOOP_FISSION_TARGET(LS)
    do k = ks, ke
       log_xq = log( max( xg_min, min( xg_max, rhoq(k,i_qg) / ( rhoq(k,i_ng) + ng_min ) ) ) )
 
       tmp = log_a_m(i_mp_qg) + log_xq * b_m(i_mp_qg)
       log_dq = log_coef_dave_l(i_mp_qg) + tmp
       weight = min( 1.0_rp, max( 0.0_rp, 0.5_rp * ( 1.0_rp + log_dq - log_d0_lg ) ) )
 
       velq_s = exp( log_coef_vt1(i_mp_qg,1) + log_xq * beta_v(i_mp_qg,1) )
       velq_l = exp( log_coef_vt1(i_mp_qg,2) + log_xq * beta_v(i_mp_qg,2) )
       vterm(k,i_mp_qg) = - rhofac_q(k) * ( velq_l * (          weight ) &
                                          + velq_s * ( 1.0_rp - weight ) )
 
       log_dq = log_coef_dave_n(i_mp_qg) + tmp
       weight = min( 1.0_rp, max( 0.0_rp, 0.5_rp * ( 1.0_rp + log_dq - log_d0_ng ) ) )
 
       velq_s = exp( log_coef_vt0(i_mp_qg,1) + log_xq * beta_vn(i_mp_qg,1) )
       velq_l = exp( log_coef_vt0(i_mp_qg,2) + log_xq * beta_vn(i_mp_qg,2) )
       vterm(k,i_mp_ng) = - rhofac_q(k) * ( velq_l * (          weight ) &
                                          + velq_s * ( 1.0_rp - weight ) )
    enddo
 
    do iq = 1, qa_mp-1
       vterm(1:ks-2 ,iq) = const_undef
       vterm(ks-1   ,iq) = vterm(ks,iq)
       vterm(ke+1:ka,iq) = const_undef
    enddo
 
    return
  end subroutine atmos_phy_mp_sn14_terminal_velocity
 
 
  ! private
  !-----------------------------------------------------------------------------
  subroutine mp_sn14_init
    use scale_prc, only: &
       prc_abort
    use scale_specfunc, only: &
        gammafunc => sf_gamma
    implicit none
 
    real(rp), parameter :: eps_gamma=1.e-30_rp
 
    real(rp) :: w1(hydro_max)
    real(rp) :: w2(hydro_max)
    real(rp) :: w3(hydro_max)
    real(rp) :: w4(hydro_max)
    real(rp) :: w5(hydro_max)
    real(rp) :: w6(hydro_max)
    real(rp) :: w7(hydro_max)
    real(rp) :: w8(hydro_max)
 
    character(len=H_SHORT) :: wlabel(hydro_max)
 
    ! work for calculation of capacity, Mitchell and Arnott (1994) , eq.(9)
    real(rp) :: ar_ice_fix = 0.7_rp
    real(rp) :: wcap1, wcap2
    ! work for ventilation coefficient
    logical :: flag_vent0(hydro_max), flag_vent1(hydro_max)
    integer :: ierr
    integer :: iw, ia, ib
    integer :: n
    !
    namelist / param_atmos_phy_mp_sn14_init / &
         opt_debug,                  &
         opt_debug_inc,              &
         opt_debug_act,              &
         opt_debug_ree,              &
         opt_debug_bcs,              &
         opt_collection_bin,         &
         ntmax_phase_change,         &
         ntmax_collection
    !
    namelist / param_atmos_phy_mp_sn14_particles / &
         a_m, b_m, alpha_v, beta_v, gamma_v, &
         alpha_vn, beta_vn,    &
         a_area, b_area, cap,  &
         nu, mu,               &
         opt_m96_column_ice,   &
         opt_m96_ice,          &
         ar_ice_fix
 
    namelist / param_atmos_phy_mp_sn14_nucleation / &
         in_max,                     & !
         c_ccn, kappa,               & ! cloud nucleation
         nm_m92, am_m92, bm_m92,     & ! ice nucleation
         xc_ccn, xi_ccn,             &
         tem_ccn_low,                &
         tem_in_low,                 &
         ssw_max, ssi_max,           &
         nucl_twomey, inucl_w,       &
         so22_het, opt_nucleation_ice_hom
 
    namelist / param_atmos_phy_mp_sn14_collection / &
         dc0, dc1, di0, ds0, dg0,    &
         sigma_c, sigma_r, sigma_i, sigma_s, sigma_g, &
         opt_stick_ks96,   &
         opt_stick_co86,   &
         e_im, e_sm, e_gm, &
         e_ir, e_sr, e_gr, e_ii, e_si, e_gi, e_ss, e_gs, e_gg, &
         i_iconv2g, i_sconv2g, rho_g, cfill_i, cfill_s, di_cri
 
    !
    namelist / param_atmos_phy_mp_sn14_collection_bin / &
         dc0, dc1, di0, ds0, dg0,    &
         opt_stick_ks96,   &
         opt_stick_co86,   &
         tem_min_estick,   &
         opt_stick_rhh57,  &
         opt_stick_rhks96, &
         opt_stick_c12,    &
         e_im, e_sm, e_gm, &
         e_ir, e_sr, e_gr, e_ii, e_si, e_gi, e_ss, e_gs, e_gg, &
         i_iconv2g, i_sconv2g, rho_g, cfill_i, cfill_s, di_cri
 
    namelist / param_atmos_phy_mp_sn14_condensation / &
         opt_fix_taucnd_c, fac_cndc
 
 
    a_m(:)         = undef8
    log_a_m(:)     = undef8
    b_m(:)         = undef8
    alpha_v(:,:)   = undef8
    beta_v(:,:)    = undef8
    alpha_vn(:,:)  = undef8
    beta_vn(:,:)   = undef8
    gamma_v(:)     = undef8
    a_d2vt(:)      = undef8
    b_d2vt(:)      = undef8
    a_area(:)      = undef8
    b_area(:)      = undef8
    ax_area(:)     = undef8
    bx_area(:)     = undef8
    a_rea(:)       = undef8
    b_rea(:)       = undef8
    a_rea2(:)      = undef8
    b_rea2(:)      = undef8
    a_rea3(:)      = undef8
    b_rea3(:)      = undef8
    nu(:)          = undef8
    mu(:)          = undef8
    cap(:)         = undef8
    coef_m2(:)     = undef8
    coef_dave_n(:) = undef8
    coef_dave_l(:) = undef8
    log_coef_dave_n(:) = undef8
    log_coef_dave_l(:) = undef8
    coef_d(:)      = undef8
    coef_d3(:)     = undef8
    coef_d6(:)     = undef8
    coef_d2v(:)    = undef8
    coef_md2v(:)   = undef8
    coef_r2(:)     = undef8
    coef_r3(:)     = undef8
    coef_re(:)     = undef8
    coef_rea2(:)   = undef8
    coef_rea3(:)   = undef8
    coef_a(:)      = undef8
!    slope_A(:)     = UNDEF8
    coef_lambda(:) = undef8
    coef_vt0(:,:)  = undef8
    coef_vt1(:,:)  = undef8
    log_coef_vt0(:,:) = undef8
    log_coef_vt1(:,:) = undef8
    delta_b0(:)    = undef8
    delta_b1(:)    = undef8
    delta_ab0(:,:) = undef8
    delta_ab1(:,:) = undef8
    theta_b0(:)    = undef8
    theta_b1(:)    = undef8
    theta_ab0(:,:) = undef8
    theta_ab1(:,:) = undef8
    !
    ah_vent(:,:)   = undef8
    ah_vent0(:,:)  = undef8
    ah_vent1(:,:)  = undef8
    bh_vent(:,:)   = undef8
    bh_vent0(:,:)  = undef8
    bh_vent1(:,:)  = undef8
 
    !--- read namelist
    rewind(io_fid_conf)
    read(io_fid_conf,nml=param_atmos_phy_mp_sn14_init,iostat=ierr)
 
    if( ierr < 0 ) then !--- missing
       log_info("ATMOS_PHY_MP_sn14_init",*) 'Not found namelist. Default used.'
    elseif( ierr > 0 ) then !--- fatal error
       log_error("ATMOS_PHY_MP_sn14_init",*) 'Not appropriate names in namelist PARAM_ATMOS_PHY_MP_SN14_init. Check!'
       call prc_abort
    endif
    log_nml(param_atmos_phy_mp_sn14_init)
 
    !
    ! default setting
    !
    ! Area parameters with mks unit originated by Mitchell(1996)
    a_area(i_mp_qc) = pi/4.0_rp ! sphere
    a_area(i_mp_qr) = pi/4.0_rp ! sphere
    a_area(i_mp_qi) = 0.65_rp*1.e-4_rp*100.0_rp**(2.00_rp)   ! Mitchell(1996), Hexagonal Plate
    a_area(i_mp_qs) = 0.2285_rp*1.e-4_rp*100.0_rp**(1.88_rp) ! Mitchell(1996), Aggregates
    a_area(i_mp_qg) = 0.50_rp*1.e-4_rp*100.0_rp**(2.0_rp)    ! Mitchell(1996), Lump Graupel
    b_area(i_mp_qc) = 2.0_rp
    b_area(i_mp_qr) = 2.0_rp
    b_area(i_mp_qi) = 2.0_rp
    b_area(i_mp_qs) = 1.88_rp
    b_area(i_mp_qg) = 2.0_rp
    !
    ! Seifert and Beheng(2006), Table. 1 or List of symbols
    !----------------------------------------------------------
    ! Diameter-Mass relationship
    ! D = a * x^b
    a_m(i_mp_qc) = 0.124_rp
    a_m(i_mp_qr) = 0.124_rp
    a_m(i_mp_qi) = 0.217_rp
    a_m(i_mp_qs) = 8.156_rp
    a_m(i_mp_qg) = 0.190_rp
    b_m(i_mp_qc) = 1.0_rp/3.0_rp
    b_m(i_mp_qr) = 1.0_rp/3.0_rp
    b_m(i_mp_qi) = 0.302_rp
    b_m(i_mp_qs) = 0.526_rp
    b_m(i_mp_qg) = 0.323_rp
    !----------------------------------------------------------
    ! Terminal velocity-Mass relationship
    ! vt = alpha * x^beta * (rho0/rho)^gamma
    alpha_v(i_mp_qc,:)= 3.75e+5_rp
    alpha_v(i_mp_qr,:)= 159.0_rp ! not for sedimantation
    alpha_v(i_mp_qi,:)= 317.0_rp
    alpha_v(i_mp_qs,:)= 27.70_rp
    alpha_v(i_mp_qg,:)= 40.0_rp
    beta_v(i_mp_qc,:) = 2.0_rp/3.0_rp
    beta_v(i_mp_qr,:) = 0.266_rp ! not for sedimantation
    beta_v(i_mp_qi,:) = 0.363_rp
    beta_v(i_mp_qs,:) = 0.216_rp
    beta_v(i_mp_qg,:) = 0.230_rp
    gamma_v(i_mp_qc)  = 1.0_rp
    ! This is high Reynolds number limit(Beard 1980)
    gamma_v(i_mp_qr)  = 1.0_rp/2.0_rp
    gamma_v(i_mp_qi)  = 1.0_rp/2.0_rp
    gamma_v(i_mp_qs)  = 1.0_rp/2.0_rp
    gamma_v(i_mp_qg)  = 1.0_rp/2.0_rp
    !----------------------------------------------------------
    ! DSD parameters
    ! f(x) = A x^nu exp( -lambda x^mu )
    ! Gamma Disribution           : mu=1  , nu:arbitrary
    ! Marshall-Palmer Distribution: mu=1/3, nu:-2/3
    ! In the case of MP, f(D) dD = f(x)dx
    !                    f(x)    = c * f(D)/D^2 (c:coefficient)
    nu(i_mp_qc) =  1.0_rp          ! arbitrary for Gamma
    nu(i_mp_qr) = -1.0_rp/3.0_rp     ! nu(diameter)=1, equilibrium condition.
    nu(i_mp_qi) =  1.0_rp          !
    nu(i_mp_qs) =  1.0_rp          !
    nu(i_mp_qg) =  1.0_rp          !
    !
    mu(i_mp_qc) = 1.0_rp           ! Gamma
    mu(i_mp_qr) = 1.0_rp/3.0_rp      ! Marshall Palmer
    mu(i_mp_qi) = 1.0_rp/3.0_rp      !
    mu(i_mp_qs) = 1.0_rp/3.0_rp      !
    mu(i_mp_qg) = 1.0_rp/3.0_rp      !
    !----------------------------------------------------------
    ! Geomeries for diffusion growth
    ! Pruppacher and Klett(1997), (13-77)-(13-80) and
    ! originally derived by McDonald(1963b)
    ! sphere: cap=2
    ! plate : cap=pi
    ! needle with aspect ratio a/b
    !       : cap=log(2*a/b)
    cap(i_mp_qc) = 2.0_rp    ! sphere
    cap(i_mp_qr) = 2.0_rp    ! sphere
    cap(i_mp_qi) = pi ! hexagonal plate
    cap(i_mp_qs) = 2.0_rp    ! mix aggregates
    cap(i_mp_qg) = 2.0_rp    ! lump
    !
    alpha_vn(:,:) = alpha_v(:,:)
    beta_vn(:,:) = beta_v(:,:)
    !------------------------------------------------------------------------
    !
    ! additional setting
    !
 
    !--- read namelist
    rewind(io_fid_conf)
    read(io_fid_conf,nml=param_atmos_phy_mp_sn14_particles,iostat=ierr)
    if( ierr < 0 ) then !--- missing
       log_info("ATMOS_PHY_MP_sn14_init",*) 'Not found namelist. Default used.'
    elseif( ierr > 0 ) then !--- fatal error
       log_error("ATMOS_PHY_MP_sn14_init",*) 'Not appropriate names in namelist PARAM_ATMOS_PHY_MP_SN14_particles. Check!'
       call prc_abort
    endif
    log_nml(param_atmos_phy_mp_sn14_particles)
 
    ! [Add] 10/08/03 T.Mitsui
    ! particles shapes are
    if( opt_m96_ice ) then
       ! ice is randomly oriented Hexagonal plate (Auer and Veal 1970, Takano and Liou 1995, Mitchell 1996)
       ! snow is assemblages of planar polycrystals(Mitchell 1996)
       ! graupel is Lump graupel(R4b) is assumed(Mitchell 1996)
       a_area(i_mp_qi)   = 0.120284936_rp
       a_area(i_mp_qs)   = 0.131488_rp
       a_area(i_mp_qg)   = 0.5_rp
       b_area(i_mp_qi)   = 1.850000_rp
       b_area(i_mp_qs)   = 1.880000_rp
       b_area(i_mp_qg)   = 2.0_rp
       a_m(i_mp_qi)      = 1.23655360084766_rp
       a_m(i_mp_qs)      = a_m(i_mp_qi)
       a_m(i_mp_qg)      = 0.346111225718402_rp
       b_m(i_mp_qi)      = 0.408329930583912_rp
       b_m(i_mp_qs)      = b_m(i_mp_qi)
       b_m(i_mp_qg)      = 0.357142857142857_rp
       !
       if( opt_m96_column_ice )then
          d0_ni=240.49e-6_rp   ! this is column
          d0_li=330.09e-6_rp   ! this is column
          a_area(i_mp_qi)= (0.684_rp*1.e-4_rp)*10.0_rp**(2.0_rp*2.00_rp)
          b_area(i_mp_qi)= 2.0_rp
          a_m(i_mp_qi)   = 0.19834046116844_rp
          b_m(i_mp_qi)   = 0.343642611683849_rp
          ! [Add] 11/08/30 T.Mitsui
          ! approximated by the capacity for prolate spheroid with constant aspect ratio
          wcap1        = sqrt(1.0_rp-ar_ice_fix**2)
          wcap2        = log( (1.0_rp+wcap1)/ar_ice_fix )
          cap(i_mp_qi) = 2.0_rp*wcap2/wcap1
          !
       end if
       !
       ! These value are derived by least-square fitting in the range
       ! qi [100um:1000um] in diameter
       ! qs [100um:1000um] in diameter
       ! qg [200um:2000um] in diameter
       !                      small branch          , large branch
       if( opt_m96_column_ice )then
          alpha_v(i_mp_qi,:) = (/2901.0_rp, 32.20_rp/)
          alpha_vn(i_mp_qi,:) = (/9675.2_rp, 64.16_rp/)
       else
          alpha_v(i_mp_qi,:) =(/ 5798.60107421875_rp, 167.347076416016_rp/)
          alpha_vn(i_mp_qi,:) =(/ 12408.177734375_rp, 421.799865722656_rp/)
       end if
       alpha_v(i_mp_qs,:)    =(/ 15173.3916015625_rp, 305.678619384766_rp/)
       alpha_vn(i_mp_qs,:)    =(/ 29257.1601562500_rp, 817.985717773438_rp/)
       alpha_v(i_mp_qg,:)    =(/ 15481.6904296875_rp, 311.642242431641_rp/)
       alpha_vn(i_mp_qg,:)    =(/ 27574.6562500000_rp, 697.536132812500_rp/)
       !
       beta_v(i_mp_qi,:)  =(/ 0.504873454570770_rp, 0.324817866086960_rp/)
       beta_vn(i_mp_qi,:)  =(/ 0.548495233058929_rp, 0.385287821292877_rp/)
       if( opt_m96_column_ice )then
          beta_v(i_mp_qi,:)  =(/ 0.465552181005478_rp, 0.223826110363007_rp/)
          beta_vn(i_mp_qi,:)  =(/ 0.530453503131866_rp, 0.273761242628098_rp/)
       end if
       beta_v(i_mp_qs,:)     =(/ 0.528109610080719_rp, 0.329863965511322_rp/)
       beta_vn(i_mp_qs,:)     =(/ 0.567154467105865_rp, 0.393876969814301_rp/)
       beta_v(i_mp_qg,:)     =(/ 0.534656763076782_rp, 0.330253750085831_rp/)
       beta_vn(i_mp_qg,:)     =(/ 0.570551633834839_rp, 0.387124240398407_rp/)
    end if
    !
    ! area-diameter relation => area-mass relation
    ax_area(:) = a_area(:)*a_m(:)**b_area(:)
    bx_area(:) = b_area(:)*b_m(:)
    !
    ! radius of equivalent area - m ass relation
    ! pi*rea**2 = ax_area*x**bx_area
    a_rea(:)   = sqrt(ax_area(:)/pi)
    b_rea(:)   = bx_area(:)/2.0_rp
    a_rea2(:)  = a_rea(:)**2
    b_rea2(:)  = b_rea(:)*2.0_rp
    a_rea3(:)  = a_rea(:)**3
    b_rea3(:)  = b_rea(:)*3.0_rp
    !
    a_d2vt(:)=alpha_v(:,2)*(1.0_rp/alpha_v(:,2))**(beta_v(:,2)/b_m(:))
    b_d2vt(:)=(beta_v(:,2)/b_m(:))
    !
    ! Calculation of Moment Coefficient
    !
    w1(:) = 0.0_rp
    w2(:) = 0.0_rp
    w3(:) = 0.0_rp
    w4(:) = 0.0_rp
    w5(:) = 0.0_rp
    w6(:) = 0.0_rp
    w7(:) = 0.0_rp
    w8(:) = 0.0_rp
    !-------------------------------------------------------
    ! moment coefficient
    ! SB06 (82)
    ! M^n /= coef_mn * N * (L/N)**n
    ! M^2 = Z = coef_m2 * N *(L/N)**2
    ! a*M^b = a*integral x^b f(x) dx = ave D
    do iw=1, hydro_max
       n = 2
       w1(iw) = gammafunc( (n+nu(iw)+1.0_rp)/mu(iw) )
       w2(iw) = gammafunc( (nu(iw)+1.0_rp)/mu(iw) )
       w3(iw) = gammafunc( (nu(iw)+2.0_rp)/mu(iw) )
       coef_m2(iw) = w1(iw)/w2(iw)*(  w2(iw)/w3(iw)  )**n
       !
       w4(iw) = gammafunc( (b_m(iw)+nu(iw)+1.0_rp)/mu(iw) )
       coef_d(iw) = a_m(iw) * w4(iw)/w2(iw)*(  w2(iw)/w3(iw)  )**b_m(iw)
       w5(iw) = gammafunc( (2.0_rp*b_m(iw)+beta_v(iw,2)+nu(iw)+1.0_rp)/mu(iw) )
       w6(iw) = gammafunc( (3.0_rp*b_m(iw)+beta_v(iw,2)+nu(iw)+1.0_rp)/mu(iw) )
       coef_d2v(iw) = a_m(iw) * w6(iw)/w5(iw)* ( w2(iw)/w3(iw) )**b_m(iw)
       coef_md2v(iw)=           w5(iw)/w2(iw)* ( w2(iw)/w3(iw) )**(2.0_rp*b_m(iw)+beta_v(iw,2))
       ! 09/04/14 [Add] T.Mitsui, volume and radar reflectivity
       w7(iw) = gammafunc( (3.0_rp*b_m(iw)+nu(iw)+1.0_rp)/mu(iw) )
       coef_d3(iw)  = a_m(iw)**3 * w7(iw)/w2(iw)*(  w2(iw)/w3(iw)  )**(3.0_rp*b_m(iw))
       w8(iw) = gammafunc( (6.0_rp*b_m(iw)+nu(iw)+1.0_rp)/mu(iw) )
       coef_d6(iw)  = a_m(iw)**6 * w8(iw)/w2(iw)*(  w2(iw)/w3(iw)  )**(6.0_rp*b_m(iw))
    end do
    !
    coef_deplc = coef_d(i_mp_qc)/a_m(i_mp_qc)
    !-------------------------------------------------------
    ! coefficient of 2nd and 3rd moments for effective radius
    ! for spherical particle
    do iw=1, hydro_max
       ! integ r^2 f(x)dx
       w1(iw) = gammafunc( (2.0_rp*b_m(iw)+nu(iw)+1.0_rp)/mu(iw) )
       w2(iw) = gammafunc( (nu(iw)+1.0_rp)/mu(iw) )
       w3(iw) = gammafunc( (nu(iw)+2.0_rp)/mu(iw) )
       ! integ r^3 f(x)dx
       w4(iw) = gammafunc( (3.0_rp*b_m(iw)+nu(iw)+1.0_rp)/mu(iw) )
       !
       coef_r2(iw)=w1(iw)/w2(iw)*( w2(iw)/w3(iw) )**(2.0_rp*b_m(iw))
       coef_r3(iw)=w4(iw)/w2(iw)*( w2(iw)/w3(iw) )**(3.0_rp*b_m(iw))
       coef_re(iw)=coef_r3(iw)/coef_r2(iw)
       !
    end do
    !-------------------------------------------------------
    ! coefficient for effective radius of equivalent area and
    ! coefficient for volume of equivalent area
    do iw=1, hydro_max
       w1(iw) = gammafunc( (nu(iw)+1.0_rp)/mu(iw) )
       w2(iw) = gammafunc( (nu(iw)+2.0_rp)/mu(iw) )
       w3(iw) = gammafunc( (b_rea2(iw)+nu(iw)+1.0_rp)/mu(iw) )
       w4(iw) = gammafunc( (b_rea3(iw)+nu(iw)+1.0_rp)/mu(iw) )
       !
       coef_rea2(iw) = w3(iw)/w1(iw)*( w1(iw)/w2(iw) )**b_rea2(iw)
       coef_rea3(iw) = w4(iw)/w1(iw)*( w1(iw)/w2(iw) )**b_rea3(iw)
    end do
    !-------------------------------------------------------
    ! coefficient of gamma-distribution
    ! SB06(80)
    do iw=1, hydro_max
       w1(iw) = gammafunc( (nu(iw) + 1.0_rp)/mu(iw) )
       w2(iw) = gammafunc( (nu(iw) + 2.0_rp)/mu(iw) )
       coef_a(iw)      = mu(iw)/w1(iw)
!       slope_A(iw)     = w1(iw)
       coef_lambda(iw) = (w1(iw)/w2(iw))**(-mu(iw))
    end do
    !-------------------------------------------------------
    ! coefficient for terminal velocity in sedimentation
    ! SB06(78)
    do ia=1,2
       do iw=1, hydro_max
          n = 0
          w1(iw) = gammafunc( (beta_vn(iw,ia) + nu(iw) + 1.0_rp + n)/mu(iw) )
          w2(iw) = gammafunc( (                 nu(iw) + 1.0_rp + n)/mu(iw) )
          w3(iw) = gammafunc( (nu(iw) + 1.0_rp)/mu(iw) )
          w4(iw) = gammafunc( (nu(iw) + 2.0_rp)/mu(iw) )
          ! coefficient of terminal velocity for number
          coef_vt0(iw,ia) = alpha_vn(iw,ia) * w1(iw) / w2(iw) * ( w3(iw) / w4(iw) )**beta_vn(iw,ia)
          log_coef_vt0(iw,ia) = log( coef_vt0(iw,ia) )
          n = 1
          w1(iw) = gammafunc( (beta_v(iw,ia) + nu(iw) + 1.0_rp + n)/mu(iw) )
          w2(iw) = gammafunc( (                nu(iw) + 1.0_rp + n)/mu(iw) )
          ! coefficient of terminal velocity for mass
          coef_vt1(iw,ia) = alpha_v(iw,ia) * w1(iw) / w2(iw) * ( w3(iw) / w4(iw) )**beta_v(iw,ia)
          log_coef_vt1(iw,ia) = log( coef_vt1(iw,ia) )
       end do
    end do
    ! coefficient for weighted diameter used in calculation of terminal velocity
    do iw=1, hydro_max
       w1(iw) = gammafunc( (         b_m(iw) + nu(iw) + 1.0_rp)/mu(iw) )
       w2(iw) = gammafunc( (1.0_rp + b_m(iw) + nu(iw) + 1.0_rp)/mu(iw) )
       w3(iw) = gammafunc( (nu(iw) + 1.0_rp)/mu(iw) )
       w4(iw) = gammafunc( (nu(iw) + 2.0_rp)/mu(iw) )
       coef_dave_n(iw) = ( w1(iw) / w3(iw) ) * ( w3(iw) / w4(iw) )**(       b_m(iw))
       coef_dave_l(iw) = ( w2(iw) / w3(iw) ) * ( w3(iw) / w4(iw) )**(1.0_rp+b_m(iw))
       log_coef_dave_n(iw) = log( coef_dave_n(iw) )
       log_coef_dave_l(iw) = log( coef_dave_l(iw) )
    end do
    !-------------------------------------------------------
    !
    ah_vent(i_mp_qc,1:2) = (/1.0000_rp,1.0000_rp/) ! no effect
    ah_vent(i_mp_qr,1:2) = (/1.0000_rp,0.780_rp/)
    ah_vent(i_mp_qi,1:2) = (/1.0000_rp,0.860_rp/)
    ah_vent(i_mp_qs,1:2) = (/1.0000_rp,0.780_rp/)
    ah_vent(i_mp_qg,1:2) = (/1.0000_rp,0.780_rp/)
    bh_vent(i_mp_qc,1:2) = (/0.0000_rp,0.0000_rp/)
    bh_vent(i_mp_qr,1:2) = (/0.108_rp,0.308_rp/)
    bh_vent(i_mp_qi,1:2) = (/0.140_rp,0.280_rp/)
    bh_vent(i_mp_qs,1:2) = (/0.108_rp,0.308_rp/)
    bh_vent(i_mp_qg,1:2) = (/0.108_rp,0.308_rp/)
    !
    do iw=1, hydro_max
       n = 0
       if( (nu(iw) + b_m(iw) + n) > eps_gamma  )then
          w1(iw) = gammafunc( (nu(iw) + b_m(iw) + n)/mu(iw) )
          w2(iw) = gammafunc( (nu(iw) + 1.0_rp)/mu(iw) )
          w3(iw) = gammafunc( (nu(iw) + 2.0_rp)/mu(iw) )
          ah_vent0(iw,1)= ah_vent(iw,1)*(w1(iw)/w2(iw))*(w2(iw)/w3(iw))**(b_m(iw)+n-1.0_rp)
          ah_vent0(iw,2)= ah_vent(iw,2)*(w1(iw)/w2(iw))*(w2(iw)/w3(iw))**(b_m(iw)+n-1.0_rp)
          flag_vent0(iw)=.true.
       else
          ah_vent0(iw,1)= 1.0_rp
          ah_vent0(iw,2)= 1.0_rp
          flag_vent0(iw)=.false.
       end if
       n = 1
       if( (nu(iw) + b_m(iw) + n) > eps_gamma  )then
          w1(iw) = gammafunc( (nu(iw) + b_m(iw) + n)/mu(iw) )
          w2(iw) = gammafunc( (nu(iw) + 1.0_rp)/mu(iw) )
          w3(iw) = gammafunc( (nu(iw) + 2.0_rp)/mu(iw) )
          ah_vent1(iw,1)= ah_vent(iw,1)*(w1(iw)/w2(iw))*(w2(iw)/w3(iw))**(b_m(iw)+n-1.0_rp)
          ah_vent1(iw,2)= ah_vent(iw,2)*(w1(iw)/w2(iw))*(w2(iw)/w3(iw))**(b_m(iw)+n-1.0_rp)
          flag_vent1(iw)=.true.
       else
          ah_vent1(iw,1)= 1.0_rp
          ah_vent1(iw,2)= 1.0_rp
          flag_vent1(iw)=.true.
       end if
    end do
    do iw=1, hydro_max
       n = 0
       if( (nu(iw) + 1.5_rp*b_m(iw) + 0.5_rp*beta_v(iw,1) + n) < eps_gamma )then
          flag_vent0(iw)=.false.
       end if
       if(flag_vent0(iw))then
!          w1(iw) = gammafunc( (nu(iw) + 1.5_RP*b_m(iw) + 0.5_RP*beta_v(iw,1) + n)/mu(iw) )
          w2(iw) = gammafunc( (nu(iw) + 1.0_rp)/mu(iw) )
          w3(iw) = gammafunc( (nu(iw) + 2.0_rp)/mu(iw) )
          ! [Add] 11/08/30 T.Mitsui
          w4(iw) = gammafunc( (nu(iw) + 2.0_rp*b_m(iw) + beta_v(iw,1) + n)/mu(iw) )
          bh_vent0(iw,1)=bh_vent(iw,1)*(w4(iw)/w2(iw))*(w2(iw)/w3(iw))**(2.00_rp*b_m(iw)+beta_v(iw,1)+n-1.0_rp)
          w5(iw) = gammafunc( (nu(iw) + 1.5_rp*b_m(iw) + 0.5_rp*beta_v(iw,2) + n)/mu(iw) )
          bh_vent0(iw,2)=bh_vent(iw,2)*(w5(iw)/w2(iw))*(w2(iw)/w3(iw))**(1.5_rp*b_m(iw)+0.5_rp*beta_v(iw,2)+n-1.0_rp)
       else
          bh_vent0(iw,1) = 0.0_rp
          bh_vent0(iw,2) = 0.0_rp
       end if
       !
       n = 1
       if( (nu(iw) + 1.5_rp*b_m(iw) + 0.5_rp*beta_v(iw,1) + n) < eps_gamma )then
          flag_vent1(iw)=.false.
       end if
       if(flag_vent1(iw))then
!          w1(iw) = gammafunc( (nu(iw) + 1.5_RP*b_m(iw) + 0.5_RP*beta_v(iw,1) + n)/mu(iw) )
          w2(iw) = gammafunc( (nu(iw) + 1.0_rp)/mu(iw) )
          w3(iw) = gammafunc( (nu(iw) + 2.0_rp)/mu(iw) )
          ! [Add] 11/08/30 T.Mitsui
          w4(iw) = gammafunc( (nu(iw) + 2.0_rp*b_m(iw) + beta_v(iw,1) + n)/mu(iw) )
          bh_vent1(iw,1)=bh_vent(iw,1)*(w4(iw)/w2(iw))*(w2(iw)/w3(iw))**(2.00_rp*b_m(iw)+beta_v(iw,1)+n-1.0_rp)
          !
          w5(iw) = gammafunc( (nu(iw) + 1.5_rp*b_m(iw) + 0.5_rp*beta_v(iw,2) + n)/mu(iw) )
          bh_vent1(iw,2)=bh_vent(iw,2)*(w5(iw)/w2(iw))*(w2(iw)/w3(iw))**(1.5_rp*b_m(iw)+0.5_rp*beta_v(iw,2)+n-1.0_rp)
       else
          bh_vent1(iw,1) = 0.0_rp
          bh_vent1(iw,2) = 0.0_rp
       end if
    end do
    !-------------------------------------------------------
    ! coefficient for collision process
    ! stochastic coefficient for collision cross section
    ! sb06 (90) -- self collection
    do iw=1, hydro_max
       n = 0
       w1(iw) = gammafunc( (2.0_rp*b_rea(iw) + nu(iw) + 1.0_rp + n)/mu(iw) )
       w2(iw) = gammafunc( (nu(iw) + 1.0_rp)/mu(iw) )
       w3(iw) = gammafunc( (nu(iw) + 2.0_rp)/mu(iw) )
       delta_b0(iw) = w1(iw)/w2(iw) &
            *( w2(iw)/w3(iw) )**(2.0_rp*b_rea(iw) + n)
       n = 1
       w1(iw) = gammafunc( (2.0_rp*b_rea(iw) + nu(iw) + 1.0_rp + n)/mu(iw) )
       delta_b1(iw) = w1(iw)/w2(iw) &
            *( w2(iw)/w3(iw) )**(2.0_rp*b_rea(iw) + n)
    end do
    ! stochastic coefficient for collision cross section
    ! sb06(91) -- riming( collide with others )
    do iw=1, hydro_max
       n = 0
       w1(iw) = gammafunc( (b_rea(iw) + nu(iw) + 1.0_rp + n)/mu(iw) )
       w2(iw) = gammafunc( (nu(iw) + 1.0_rp)/mu(iw) )
       w3(iw) = gammafunc( (nu(iw) + 2.0_rp)/mu(iw) )
       w4(iw) = gammafunc( (b_rea(iw) + nu(iw) + 1.0_rp    )/mu(iw) )
       n = 1
       w5(iw) = gammafunc( (b_rea(iw) + nu(iw) + 1.0_rp + n)/mu(iw) )
    end do
    ! ia > ib ( larger particles "a" catch smaller particles "b" )
    do ia=1, hydro_max
       do ib=1, hydro_max
          n=0 !
          ! NOTE, collected  particle has a moment of n.
          !       collecting particle has only number(n=0).
          delta_ab0(ia,ib) = 2.0_rp*(w1(ib)/w2(ib))*(w4(ia)/w2(ia)) &
               * ( w2(ib)/w3(ib) )**(b_rea(ib)+n) &
               * ( w2(ia)/w3(ia) )**(b_rea(ia)  )
          n=1 !
          delta_ab1(ia,ib) = 2.0_rp*(w5(ib)/w2(ib))*(w4(ia)/w2(ia)) &
               * ( w2(ib)/w3(ib) )**(b_rea(ib)+n) &
               * ( w2(ia)/w3(ia) )**(b_rea(ia)  )
       end do
    end do
    ! stochastic coefficient for terminal velocity
    ! sb06(92) -- self collection
    ! assuming equivalent area circle.
    do iw=1, hydro_max
       n = 0
       w1(iw) = gammafunc( (2.0_rp*beta_v(iw,2) + 2.0_rp*b_rea(iw) + nu(iw) + 1.0_rp + n)/mu(iw) )
       w2(iw) = gammafunc( (                      2.0_rp*b_rea(iw) + nu(iw) + 1.0_rp + n)/mu(iw) )
       w3(iw) = gammafunc( (nu(iw) + 1.0_rp)/mu(iw) )
       w4(iw) = gammafunc( (nu(iw) + 2.0_rp)/mu(iw) )
       theta_b0(iw) = w1(iw)/w2(iw) * ( w3(iw)/w4(iw) )**(2.0_rp*beta_v(iw,2))
       n = 1
       w1(iw) = gammafunc( (2.0_rp*beta_v(iw,2) + 2.0_rp*b_rea(iw) + nu(iw) + 1.0_rp + n)/mu(iw) )
       w2(iw) = gammafunc( (                        2.0_rp*b_rea(iw) + nu(iw) + 1.0_rp + n)/mu(iw) )
       theta_b1(iw) = w1(iw)/w2(iw) * ( w3(iw)/w4(iw) )**(2.0_rp*beta_v(iw,2))
    end do
    !
    ! stochastic coefficient for terminal velocity
    ! sb06(93) -- riming( collide with others )
    do iw=1, hydro_max
       n = 0
       w1(iw) = gammafunc( (beta_v(iw,2) + 2.0_rp*b_rea(iw) + nu(iw) + 1.0_rp + n)/mu(iw) )
       w2(iw) = gammafunc( (                   2.0_rp*b_rea(iw) + nu(iw) + 1.0_rp + n)/mu(iw) )
       w3(iw) = gammafunc( (beta_v(iw,2) + 2.0_rp*b_rea(iw) + nu(iw) + 1.0_rp    )/mu(iw) )
       w4(iw) = gammafunc( (                   2.0_rp*b_rea(iw) + nu(iw) + 1.0_rp    )/mu(iw) )
       !
       w5(iw) = gammafunc( (nu(iw) + 1.0_rp)/mu(iw) )
       w6(iw) = gammafunc( (nu(iw) + 2.0_rp)/mu(iw) )
       n = 1
       w7(iw) = gammafunc( (beta_v(iw,2) + b_rea(iw) + nu(iw) + 1.0_rp + n)/mu(iw) )
       w8(iw) = gammafunc( (                   b_rea(iw) + nu(iw) + 1.0_rp + n)/mu(iw) )
    end do
    ! ia > ib ( larger particles "a" catch smaller particles "b" )
    do ia=1, hydro_max
       do ib=1, hydro_max
          theta_ab0(ia,ib) = 2.0_rp * (w1(ib)/w2(ib))*(w3(ia)/w4(ia)) &
               * (w5(ia)/w6(ia))**beta_v(ia,2) &
               * (w5(ib)/w6(ib))**beta_v(ib,2)
          theta_ab1(ia,ib) = 2.0_rp * (w7(ib)/w8(ib))*(w3(ia)/w4(ia)) &
               * (w5(ia)/w6(ia))**beta_v(ia,2) &
               * (w5(ib)/w6(ib))**beta_v(ib,2)
       end do
    end do
 
    rewind(io_fid_conf)
    read(io_fid_conf, nml=param_atmos_phy_mp_sn14_nucleation, iostat=ierr)
    if( ierr < 0 ) then !--- missing
       log_info("ATMOS_PHY_MP_sn14_init",*) 'PARAM_ATMOS_PHY_MP_SN14_nucleation is not specified. Default used.'
    elseif( ierr > 0 ) then !--- fatal error
       log_error("ATMOS_PHY_MP_sn14_init",*) 'Not appropriate names in namelist PARAM_ATMOS_PHY_MP_SN14_nucleation. Check!'
       call prc_abort
    endif
    log_nml(param_atmos_phy_mp_sn14_nucleation)
    if ( mp_couple_aerosol .AND. nucl_twomey ) then
       log_error("ATMOS_PHY_MP_SN14_nucleation_kij",*) "nucl_twomey should be false when MP_couple_aerosol is true, stop"
       call prc_abort
    endif
 
 
    if ( opt_collection_bin ) then
 
       rewind(io_fid_conf)
       read(io_fid_conf,nml=param_atmos_phy_mp_sn14_collection_bin,iostat=ierr)
       if ( ierr < 0 ) then
          log_info("ATMOS_PHY_MP_sn14_init",*) 'PARAM_ATMOS_PHY_MP_SN14_collection_bin is not specified. Default used.'
       elseif( ierr > 0 ) then
          log_error("ATMOS_PHY_MP_sn14_init",*) 'xxx Not appropriate names in namelist PARAM_ATMOS_PHY_MP_SN14_collection_bin. STOP.' ! write(IO_FID_LOG,*)
          call prc_abort
       endif
       log_nml(param_atmos_phy_mp_sn14_collection_bin)
 
    else
 
       rewind( io_fid_conf )
       read( io_fid_conf, nml=param_atmos_phy_mp_sn14_collection, iostat=ierr )
       if( ierr < 0 ) then !--- missing
          log_info("ATMOS_PHY_MP_sn14_init",*) 'PARAM_ATMOS_PHY_MP_SN14_collection is not specified. Default used.'
       elseif( ierr > 0 ) then !--- fatal error
          log_error("ATMOS_PHY_MP_sn14_init",*) 'Not appropriate names in namelist PARAM_ATMOS_PHY_MP_SN14_collection. Check!'
          call prc_abort
       endif
       log_nml(param_atmos_phy_mp_sn14_collection)
 
    end if
 
 
    rewind(io_fid_conf)
    read  (io_fid_conf,nml=param_atmos_phy_mp_sn14_condensation, iostat=ierr )
    if( ierr < 0 ) then !--- missing
       log_info("ATMOS_PHY_MP_sn14_init",*) 'PARAM_ATMOS_PHY_MP_SN14_condensation is not specified. Default used.'
    elseif( ierr > 0 ) then !--- fatal error
       log_error("ATMOS_PHY_MP_sn14_init",*) 'Not appropriate names in namelist PARAM_ATMOS_PHY_MP_SN14_condensation. Check!'
       call prc_abort
    endif
    log_nml(param_atmos_phy_mp_sn14_condensation)
 
 
 
    ! work for Incomplete Gamma function
    xc_cr = (2.0_rp*rc_cr/a_m(i_mp_qc))**(1.0_rp/b_m(i_mp_qc))
    alpha = (nu(i_mp_qc)+1.0_rp)/mu(i_mp_qc)
    gm    = gammafunc(alpha)
    lgm   = log(gm)
 
 
    ! log
    do ia=1, hydro_max
       log_a_m(ia) = log( a_m(ia) )
       log_alpha_v(ia,1) = log( alpha_v(ia,1) )
       log_alpha_v(ia,2) = log( alpha_v(ia,2) )
       log_beta_v(ia,1) = log( beta_v(ia,1) )
       log_beta_v(ia,2) = log( beta_v(ia,2) )
    end do
    log_d0_li = log( d0_li )
    log_d0_ni = log( d0_ni )
 
    wlabel(1) = "CLOUD"
    wlabel(2) = "RAIN"
    wlabel(3) = "ICE"
    wlabel(4) = "SNOW"
    wlabel(5) = "GRAUPEL"
 
    log_info("ATMOS_PHY_MP_sn14_init",'(100a16)')      "LABEL       ",wlabel(:)
    log_info("ATMOS_PHY_MP_sn14_init",'(a,100ES16.6)') "capacity    ",cap(:) ! [Add] 11/08/30 T.Mitsui
    log_info("ATMOS_PHY_MP_sn14_init",'(a,100ES16.6)') "coef_m2     ",coef_m2(:)
    log_info("ATMOS_PHY_MP_sn14_init",'(a,100ES16.6)') "coef_d      ",coef_d(:)
    !
    log_info("ATMOS_PHY_MP_sn14_init",'(a,100ES16.6)') "coef_d3     ",coef_d3(:)
    log_info("ATMOS_PHY_MP_sn14_init",'(a,100ES16.6)') "coef_d6     ",coef_d6(:)
    log_info("ATMOS_PHY_MP_sn14_init",'(a,100ES16.6)') "coef_d2v    ",coef_d2v(:)
    log_info("ATMOS_PHY_MP_sn14_init",'(a,100ES16.6)') "coef_md2v   ",coef_md2v(:)
    log_info("ATMOS_PHY_MP_sn14_init",'(a,100ES16.6)') "a_d2vt      ",a_d2vt(:)
    log_info("ATMOS_PHY_MP_sn14_init",'(a,100ES16.6)') "b_d2vt      ",b_d2vt(:)
    !
    log_info("ATMOS_PHY_MP_sn14_init",'(a,100ES16.6)') "coef_r2     ",coef_r2(:)
    log_info("ATMOS_PHY_MP_sn14_init",'(a,100ES16.6)') "coef_r3     ",coef_r3(:)
    log_info("ATMOS_PHY_MP_sn14_init",'(a,100ES16.6)') "coef_re     ",coef_re(:)
    !
    log_info("ATMOS_PHY_MP_sn14_init",'(a,100ES16.6)') "a_area      ",a_area(:)
    log_info("ATMOS_PHY_MP_sn14_init",'(a,100ES16.6)') "b_area      ",b_area(:)
    log_info("ATMOS_PHY_MP_sn14_init",'(a,100ES16.6)') "ax_area     ",ax_area(:)
    log_info("ATMOS_PHY_MP_sn14_init",'(a,100ES16.6)') "bx_area     ",bx_area(:)
    log_info("ATMOS_PHY_MP_sn14_init",'(a,100ES16.6)') "a_rea       ",a_rea(:)
    log_info("ATMOS_PHY_MP_sn14_init",'(a,100ES16.6)') "b_rea       ",b_rea(:)
    log_info("ATMOS_PHY_MP_sn14_init",'(a,100ES16.6)') "a_rea3      ",a_rea3(:)
    log_info("ATMOS_PHY_MP_sn14_init",'(a,100ES16.6)') "b_rea3      ",b_rea3(:)
    !
    log_info("ATMOS_PHY_MP_sn14_init",'(a,100ES16.6)') "coef_rea2   ",coef_rea2(:)
    log_info("ATMOS_PHY_MP_sn14_init",'(a,100ES16.6)') "coef_rea3   ",coef_rea3(:)
    log_info("ATMOS_PHY_MP_sn14_init",'(a,100ES16.6)') "coef_vt0    ",coef_vt0(:,1)
    log_info("ATMOS_PHY_MP_sn14_init",'(a,100ES16.6)') "coef_vt1    ",coef_vt1(:,1)
    log_info("ATMOS_PHY_MP_sn14_init",'(a,100ES16.6)') "coef_A      ",coef_a(:)
    log_info("ATMOS_PHY_MP_sn14_init",'(a,100ES16.6)') "coef_lambda ",coef_lambda(:)
 
    log_info("ATMOS_PHY_MP_sn14_init",'(a,100ES16.6)') "ah_vent0 sml",ah_vent0(:,1)
    log_info("ATMOS_PHY_MP_sn14_init",'(a,100ES16.6)') "ah_vent0 lrg",ah_vent0(:,2)
    log_info("ATMOS_PHY_MP_sn14_init",'(a,100ES16.6)') "ah_vent1 sml",ah_vent1(:,1)
    log_info("ATMOS_PHY_MP_sn14_init",'(a,100ES16.6)') "ah_vent1 lrg",ah_vent1(:,2)
    log_info("ATMOS_PHY_MP_sn14_init",'(a,100ES16.6)') "bh_vent0 sml",bh_vent0(:,1)
    log_info("ATMOS_PHY_MP_sn14_init",'(a,100ES16.6)') "bh_vent0 lrg",bh_vent0(:,2)
    log_info("ATMOS_PHY_MP_sn14_init",'(a,100ES16.6)') "bh_vent1 sml",bh_vent1(:,1)
    log_info("ATMOS_PHY_MP_sn14_init",'(a,100ES16.6)') "bh_vent1 lrg",bh_vent1(:,2)
 
    log_info("ATMOS_PHY_MP_sn14_init",'(a,100ES16.6)') "delta_b0    ",delta_b0(:)
    log_info("ATMOS_PHY_MP_sn14_init",'(a,100ES16.6)') "delta_b1    ",delta_b1(:)
    log_info("ATMOS_PHY_MP_sn14_init",'(a,100ES16.6)') "theta_b0    ",theta_b0(:)
    log_info("ATMOS_PHY_MP_sn14_init",'(a,100ES16.6)') "theta_b1    ",theta_b1(:)
 
    do ia=1, hydro_max
       log_info("ATMOS_PHY_MP_sn14_init",'(a,a10,a,100ES16.6)') "delta0(a,b)=(",trim(wlabel(ia)),",b)=",(delta_ab0(ia,ib),ib=1,hydro_max)
    enddo
    do ia=1, hydro_max
       log_info("ATMOS_PHY_MP_sn14_init",'(a,a10,a,100ES16.6)') "delta1(a,b)=(",trim(wlabel(ia)),",b)=",(delta_ab1(ia,ib),ib=1,hydro_max)
    enddo
    do ia=1, hydro_max
       log_info("ATMOS_PHY_MP_sn14_init",'(a,a10,a,100ES16.6)') "theta0(a,b)=(",trim(wlabel(ia)),",b)=",(theta_ab0(ia,ib),ib=1,hydro_max)
    enddo
    do ia=1, hydro_max
       log_info("ATMOS_PHY_MP_sn14_init",'(a,a10,a,100ES16.6)') "theta1(a,b)=(",trim(wlabel(ia)),",b)=",(theta_ab1(ia,ib),ib=1,hydro_max)
    enddo
 
    !$acc update device(nu)
    !$acc update device(a_m, log_a_m, b_m)
    !$acc update device(beta_v, beta_vn, gamma_v)
    !$acc update device(log_d0_ni, log_d0_li)
    !$acc update device(log_coef_vt0, log_coef_vt1)
    !$acc update device(log_coef_dave_N, log_coef_dave_L)
 
 
    return
  end subroutine mp_sn14_init
  !-----------------------------------------------------------------------------
  subroutine mp_sn14 ( &
       KA, KS, KE, IA, IS, IE, JA, JS, JE, &
       DENS,  &
       W,     &
       QTRC,  &
       PRES0, &
       TEMP0, &
       Qdry,  &
       CPtot0, &
       CVtot0, &
       CCN,    &
       dt,   &
       cz,   &
       fz,   &
       RHOQ_t, &
       RHOE_t, &
       CPtot_t, &
       CVtot_t, &
       EVAPORATE, &
       flg_lt, &
       d0_crg, &
       v0_crg, &
       dqcrg, &
       beta_crg, &
       QTRC_crg, &
       QSPLT_in, &
       Sarea, &
       RHOQcrg_t_mp )
    use scale_atmos_hydrometeor, only: &
       cp_vapor, &
       cp_water, &
       cp_ice,   &
       cv_vapor, &
       cv_water, &
       cv_ice
    use scale_atmos_saturation, only: &
       moist_psat_liq      => atmos_saturation_psat_liq,   &
       moist_psat_ice      => atmos_saturation_psat_ice,   &
       moist_pres2qsat_ice  => atmos_saturation_pres2qsat_ice
    use scale_file_history, only: &
       file_history_query, &
       file_history_put
    implicit none
 
    integer, intent(in) :: ka, ks, ke
    integer, intent(in) :: ia, is, ie
    integer, intent(in) :: ja, js, je
 
    real(rp), intent(in) :: dens  (ka,ia,ja)
    real(rp), intent(in) :: w     (ka,ia,ja)
    real(rp), intent(in) :: qtrc  (ka,ia,ja,qa_mp)
    real(rp), intent(in) :: pres0 (ka,ia,ja)
    real(rp), intent(in) :: temp0 (ka,ia,ja)
    real(rp), intent(in) :: qdry  (ka,ia,ja)
    real(rp), intent(in) :: cptot0(ka, ia, ja)
    real(rp), intent(in) :: cvtot0(ka, ia, ja)
    real(rp), intent(in) :: ccn   (ka,ia,ja)
    real(rp), intent(in) :: dt
    real(rp), intent(in) :: cz(  ka,ia,ja)
    real(rp), intent(in) :: fz(0:ka,ia,ja)
 
    real(rp),intent(out) :: rhoq_t(ka,ia,ja,qa_mp)
    real(rp),intent(out) :: rhoe_t(ka,ia,ja)
    real(rp),intent(out) :: cptot_t(ka,ia,ja)
    real(rp),intent(out) :: cvtot_t(ka,ia,ja)
 
    real(rp), intent(out)   :: evaporate(ka,ia,ja)   ! number of evaporated cloud [/m3/s]
 
    !--- for lightning
    logical,  intent(in), optional :: flg_lt
    real(rp), intent(in), optional :: d0_crg, v0_crg
    real(rp), intent(in), optional :: dqcrg(ka,ia,ja)
    real(rp), intent(in), optional :: beta_crg(ka,ia,ja)
    real(rp), intent(in), optional :: qtrc_crg(ka,ia,ja,hydro_max)
    real(rp), intent(out), optional :: qsplt_in(ka,ia,ja,3)
    real(rp), intent(out), optional :: sarea(ka,ia,ja,hydro_max)
    real(rp), intent(out), optional :: rhoqcrg_t_mp(ka,ia,ja,hydro_max)
 
    real(rp) :: pres (ka)
    real(rp) :: temp (ka)
    real(rp) :: cva  (ka)
    real(rp) :: cpa  (ka)
    real(rp) :: rrho (ka)
    real(rp) :: rhoe (ka)
    real(rp) :: rhoq (ka,i_qv:i_ng)
    !
    real(rp) :: rhoq0_t (ka,qa_mp)
    real(rp) :: rhoe0_t (ka)
    real(rp) :: cptot0_t(ka)
    real(rp) :: cvtot0_t(ka)
    !
    real(rp) :: xq(ka,hydro_max)
    !
    real(rp) :: dq_xa(ka,hydro_max)
    real(rp) :: vt_xa(ka,hydro_max,2) ! terminal velocity
 
    real(rp) :: wtemp(ka) ! filtered temperature
    real(rp) :: esw  (ka) ! saturated vapor pressure(water)
    real(rp) :: esi  (ka) ! saturated vapor pressure(ice)
    !
    real(rp) :: log_rho_fac
    real(rp) :: log_rho_fac_q(ka,hydro_max) ! factor for tracers, 1:cloud, 2:rain, 3:ice, 4: snow, 5:graupel
    !
    real(rp) :: drhoqv         ! d (rho*qv)
    real(rp) :: drhoqc, drhonc !        qc, nc
    real(rp) :: drhoqr, drhonr !        qr, nr
    real(rp) :: drhoqi, drhoni !        qi, ni
    real(rp) :: drhoqs, drhons !        qs, ns
    real(rp) :: drhoqg, drhong !        qg, ng
 
    real(rp) :: drhoqvhom            ! d (rho*qv)
    real(rp) :: drhoqihom, drhonihom ! qi, ni
 
    ! production rate
    real(rp) :: pq(ka,pq_max)
    real(rp) :: wrm_dqc, wrm_dnc
    real(rp) :: wrm_dqr, wrm_dnr
 
    ! production rate of mixed-phase collection process
    real(rp) :: pac(ka,pac_max)
 
    real(rp) :: gc_dqc, gc_dnc
    real(rp) :: sc_dqc, sc_dnc
    real(rp) :: ic_dqc, ic_dnc
    real(rp) :: rg_dqg, rg_dng
    real(rp) :: rg_dqr, rg_dnr
    real(rp) :: rs_dqr, rs_dnr, rs_dqs, rs_dns
    real(rp) :: ri_dqr, ri_dnr
    real(rp) :: ri_dqi, ri_dni
    real(rp) :: ii_dqi, ii_dni
    real(rp) :: is_dqi, is_dni, ss_dns
    real(rp) :: gs_dqs, gs_dns, gg_dng
 
    ! mixed-phase collection process total plus(clp_), total minus(clm_)
    real(rp) :: clp_dqc, clp_dnc, clm_dqc, clm_dnc
    real(rp) :: clp_dqr, clp_dnr, clm_dqr, clm_dnr
    real(rp) :: clp_dqi, clp_dni, clm_dqi, clm_dni
    real(rp) :: clp_dqs, clp_dns, clm_dqs, clm_dns
    real(rp) :: clp_dqg, clp_dng, clm_dqg, clm_dng
    real(rp) :: fac1, fac3, fac4(ka), fac6(ka), fac7, fac9(ka)
 
    ! production rate of partial conversion(ice, snow => graupel)
    real(rp) :: pco_dqi, pco_dni
    real(rp) :: pco_dqs, pco_dns
    real(rp) :: pco_dqg, pco_dng
 
    ! production rate of enhanced melting due to
    real(rp) :: eml_dqc, eml_dnc
    real(rp) :: eml_dqr, eml_dnr
    real(rp) :: eml_dqi, eml_dni
    real(rp) :: eml_dqs, eml_dns
    real(rp) :: eml_dqg, eml_dng
 
    ! production rate of ice multiplication by splintering
    real(rp) :: spl_dqi, spl_dni
    real(rp) :: spl_dqg, spl_dqs
 
    !-----------------------------------------------
    ! work for explicit supersaturation modeling
    !-----------------------------------------------
    real(rp) :: dtdt_equiv_d(ka)
    real(rp) :: qsi(ka)
    real(rp) :: dtdt_dep(ka)
    real(rp) :: plidep_total(ka)
    !--------------------------------------------------
    !
    ! variables for output
    !
    !--------------------------------------------------
    ! work for column production term
    real(rp) :: sl_plcdep
    real(rp) :: sl_plrdep, sl_pnrdep
    !--------------------------------------------------
    real(rp) :: qke_d(ka)
 
    real(rp), parameter :: eps      = 1.e-19_rp
    real(rp), parameter :: eps_qv   = 1.e-19_rp
    real(rp), parameter :: eps_rhoe = 1.e-19_rp
    real(rp), parameter :: eps_rho  = 1.e-19_rp
 
    ! for limitter
    real(rp) :: di2l, dtem
    real(rp) :: fact(ka)
 
    real(rp) :: sw
 
    integer  :: k, i, j, iq
 
    real(rp) :: dqv, dql, dqi
    real(rp) :: dcv, dcp
    real(rp) :: dqvhom, dqihom
    real(rp) :: dcvhom, dcphom
 
    !---- for Lightning component
!    logical, private, save :: MP_doice_graupel_collection = .false.
!    real(RP), private :: flg_igcol = 0.0_RP
    !--- for Charge separation
    real(rp) :: v0_crg_l, d0_crg_l
    real(rp) :: dqcrg_l(ka)
    real(rp) :: beta_crg_l(ka)
    real(rp) :: facq(i_qc:i_qg), f_crg
    integer :: grid(2), pp, qq
    real(rp) :: drhoqcrg_c, drhoqcrg_r
    real(rp) :: drhoqcrg_i, drhoqcrg_s, drhoqcrg_g
 
    ! production rate of charge density
    real(rp) :: pcrg1(ka,pq_max)
    real(rp) :: pcrg2(ka,pcrg_max)
    real(rp) :: rhoq_crg(ka,i_qc:i_qg)
    real(rp) :: rhoqcrg0_t(ka,i_qc:i_qg)
    real(rp) :: qtrc0(ka,qa_mp)
    real(rp) :: crs(ka,hydro_max)
 
    real(rp) :: crg_split_s
    real(rp) :: crg_split_g
    real(rp) :: crg_split_i
    real(rp) :: wrm_dnc_crg
    real(rp) :: wrm_dnr_crg
    real(rp) :: gc_dnc_crg
    real(rp) :: sc_dnc_crg
    real(rp) :: ic_dnc_crg
    real(rp) :: rg_dng_crg
    real(rp) :: rg_dnr_crg
    real(rp) :: rs_dnr_crg
    real(rp) :: rs_dns_crg
    real(rp) :: ri_dnr_crg
    real(rp) :: ri_dni_crg
    real(rp) :: ii_dni_crg
    real(rp) :: is_dni_crg
    real(rp) :: ss_dns_crg
    real(rp) :: gs_dns_crg
    real(rp) :: gi_dni_crg
    real(rp) :: gg_dng_crg
    ! mixed-phase collection process total plus(clp_), total minus(clm_)
    real(rp) :: clp_dnc_crg, clm_dnc_crg
    real(rp) :: clp_dnr_crg, clm_dnr_crg
    real(rp) :: clp_dni_crg, clm_dni_crg
    real(rp) :: clp_dns_crg, clm_dns_crg
    real(rp) :: clp_dng_crg, clm_dng_crg
    ! production rate of partial conversion(ice, snow => graupel)
    real(rp) :: pco_dni_crg
    real(rp) :: pco_dns_crg
    real(rp) :: pco_dng_crg
    ! production rate of enhanced melting due to
    real(rp) :: eml_dnc_crg
    real(rp) :: eml_dnr_crg
    real(rp) :: eml_dni_crg
    real(rp) :: eml_dns_crg
    real(rp) :: eml_dng_crg
    ! production rate of ice multiplication by splintering
    real(rp) :: spl_dni_crg
    real(rp) :: spl_dns_crg
    real(rp) :: spl_dng_crg
    real(rp) :: rate1
    logical  :: flg_lt_l
 
    real(rp) :: sw1, sw2
    real(rp) :: tmp
    integer :: ip
 
    logical :: hist_sw(w_nmax)
    !---------------------------------------------------------------------------
 
    if ( present(flg_lt) ) then
       flg_lt_l = flg_lt
    else
       flg_lt_l = .false.
    end if
 
 
    !--- Lightning component is on
    if( flg_lt_l ) then
!       flg_igcol = 0.0_RP
       d0_crg_l = d0_crg
       v0_crg_l = v0_crg
 
       !$omp workshare
!OCL ZFILL
       qsplt_in(:,:,:,:) = 0.0_rp
!OCL ZFILL
       rhoqcrg_t_mp(:,:,:,:) = 0.0_rp
       !$omp end workshare
 
!      if( MP_doice_graupel_collection ) then
!        flg_igcol = 1.0_RP
!      else
!        write(*,*) 'xxx MP_doice_graupel_collection should be true for TK78 Stop!'
!        call PRC_MPIstop
!        flg_igcol = 0.0_RP
!      endif
    else
       d0_crg_l = 1.0_rp
       v0_crg_l = 1.0_rp
    endif
 
    do ip = 1, w_nmax
       call file_history_query( hist_id(ip), hist_sw(ip) )
    end do
 
    !$omp parallel do default(none) &
    !$omp shared(KA,KS,KE,IS,IE,JS,JE, &
    !$omp        CP_VAPOR,CP_WATER,CP_ICE,CV_VAPOR,CV_WATER,CV_ICE,LHV,LHF,LHF0, &
    !$omp        MP_doautoconversion, &
    !$omp        DENS,W,QTRC,TEMP0,PRES0,QDRY,CPtot0,CVtot0,CCN, &
    !$omp        cz,fz,dt, &
    !$omp        RHOQ_t,RHOE_t,CPtot_t,CVtot_t,EVAPORATE, &
    !$omp        c_ccn,gamma_v,nc_uplim_d,a_m,b_m,alpha_v,log_alpha_v,beta_v,log_beta_v,a_rea,b_rea, &
    !$omp        ntmax_phase_change, &
    !$omp        opt_collection_bin,opt_nucleation_ice_hom,so22_het, &
    !$omp        w3d,HIST_sw,HIST_idx, &
    !$omp        QTRC_crg,QSPLT_in,RHOQcrg_t_mp,Sarea, &
    !$omp        d0_crg_l,v0_crg_l,beta_crg,dqcrg,flg_lt_l) &
    !$omp private (pres,temp,rrho,rhoe,rhoq,cva,cpa,rhoq0_t,rhoe0_t,cptot0_t,cvtot0_t, &
    !$omp          xq,dq_xa,vt_xa,wtemp,esw,esi,log_rho_fac,log_rho_fac_q, &
    !$omp          drhoqv,drhoqc,drhonc,drhoqr,drhonr,drhoqi,drhoni,drhoqs,drhons,drhoqg,drhong, &
    !$omp          PQ,Pac,wrm_dqc,wrm_dnc,wrm_dqr,wrm_dnr, &
    !$omp          gc_dqc,gc_dnc,sc_dqc,sc_dnc,ic_dqc,ic_dnc, &
    !$omp          rg_dqg,rg_dng,rg_dqr,rg_dnr,rs_dqr,rs_dnr,rs_dqs,rs_dns,ri_dqr,ri_dnr,ri_dqi,ri_dni, &
    !$omp          ii_dqi,ii_dni,is_dqi,is_dni,ss_dns,gs_dqs,gs_dns,gg_dng, &
    !$omp          clp_dqc,clp_dnc,clm_dqc,clm_dnc,clp_dqr,clp_dnr,clm_dqr,clm_dnr, &
    !$omp          clp_dqi,clp_dni,clm_dqi,clm_dni,clp_dqs,clp_dns,clm_dqs,clm_dns,clp_dqg,clp_dng,clm_dqg,clm_dng, &
    !$omp          dqvhom, dqihom,dcvhom,dcphom,drhoqvhom,drhoqihom,drhonihom, &
    !$omp          rhoq_crg,RHOQcrg0_t,Pcrg1,Pcrg2, &
    !$omp          drhoqcrg_c,drhoqcrg_r,drhoqcrg_i,drhoqcrg_s,drhoqcrg_g, &
    !$omp          crg_split_s,crg_split_g,crg_split_i,wrm_dnc_crg,wrm_dnr_crg,QTRC0,crs, &
    !$omp          gc_dnc_crg,sc_dnc_crg,ic_dnc_crg,rg_dng_crg,rg_dnr_crg,rs_dnr_crg,rs_dns_crg,ri_dnr_crg,ri_dni_crg, &
    !$omp          ii_dni_crg,is_dni_crg,ss_dns_crg,gs_dns_crg,gi_dni_crg,gg_dng_crg, &
    !$omp          clp_dnc_crg,clm_dnc_crg,clp_dnr_crg,clm_dnr_crg,clp_dni_crg,clm_dni_crg,clp_dns_crg,clm_dns_crg,clp_dng_crg,clm_dng_crg, &
    !$omp          pco_dni_crg,pco_dns_crg,pco_dng_crg,eml_dnc_crg,eml_dnr_crg,eml_dni_crg,eml_dns_crg,eml_dng_crg,spl_dni_crg,spl_dns_crg,spl_dng_crg, &
    !$omp          fac1,fac3,fac4,fac6,fac7,fac9, &
    !$omp          pco_dqi,pco_dni,pco_dqs,pco_dns,pco_dqg,pco_dng, &
    !$omp          eml_dqc,eml_dnc,eml_dqr,eml_dnr,eml_dqi,eml_dni,eml_dqs,eml_dns,eml_dqg,eml_dng, &
    !$omp          spl_dqi,spl_dni,spl_dqg,spl_dqs, &
    !$omp          dTdt_equiv_d,sl_PLCdep,sl_PLRdep,sl_PNRdep,qke_d, &
    !$omp          beta_crg_l,dqcrg_l, &
    !$omp          dqv,dql,dqi,dcv,dcp, &
    !$omp          di2l,dtem,fact,sw,sw1,sw2,tmp)
    do j = js, je
    do i = is, ie
 
       ! total tendency
       do k = ks, ke
          rhoq_t(k,i,j,:) = 0.0_rp
          rhoe_t(k,i,j)   = 0.0_rp
          cptot_t(k,i,j)  = 0.0_rp
          cvtot_t(k,i,j)  = 0.0_rp
       end do
 
       ! intermidiate variable
       do k = ks, ke
          cpa(k) = cptot0(k,i,j)
          cva(k) = cvtot0(k,i,j)
          pres(k) = pres0(k,i,j)
          temp(k) = temp0(k,i,j)
       enddo
 
       !============================================================================
       !
       !--  Each process is integrated sequentially.
       !    1. Nucleation and filter
       !    2. Phase change
       !    3. Collection
       !
       !============================================================================
 
       do iq = i_qv, i_ng
       do k = ks, ke
          rhoq(k,iq) = dens(k,i,j) * qtrc(k,i,j,iq)
       enddo
       enddo
 
       do k = ks, ke
          log_rho_fac              = log(rho_0 / max(dens(k,i,j),rho_min))
          log_rho_fac_q(k,i_mp_qc) = log_rho_fac * gamma_v(i_mp_qc)
          log_rho_fac_q(k,i_mp_qr) = log_rho_fac * gamma_v(i_mp_qr)
       end do
 
       if( so22_het .or. opt_nucleation_ice_hom) then
 
          do k = ks, ke
             log_rho_fac_q(k,i_mp_qi) = log(pres(k)/pre0_vt) * a_pre0_vt + log(temp(k)/tem0_vt) * a_tem0_vt
             log_rho_fac_q(k,i_mp_qs) = log_rho_fac_q(k,i_mp_qi)
             log_rho_fac_q(k,i_mp_qg) = log_rho_fac_q(k,i_mp_qi)
          enddo
 
          call get_terminal_velocity( &
               ka, ks, ke, &
               vt_xa(:,:,:), xq(:,:), & ! (out)
               rhoq(:,:),             & ! (in)
               log_rho_fac_q(:,:)     ) ! (in)
 
          call get_diamiter( &
               ka, ks, ke, &
               dq_xa(:,:), & ! (out)
               xq(:,:)     ) ! (in)
 
       endif
 
       !----------------------------------------------------------------------------
       !
       ! 1.Nucleation of cloud water and cloud ice
       !
       !----------------------------------------------------------------------------
       do k = ks, ke
          rrho(k) = 1.0_rp / dens(k,i,j)
          rhoe(k) = dens(k,i,j) * temp(k) * cva(k)
          wtemp(k) = max(temp(k), tem_min)
       enddo
 
#ifdef DEBUG
       call debug_tem( ka, ks, ke, &
            1, i, j, temp(:), dens(:,i,j), pres(:), qtrc(:,i,j,i_qv) )
#endif
 
       do k = ks, ke
          log_rho_fac_q(k,i_mp_qi) = log(pres(k)/pre0_vt) * a_pre0_vt + log(temp(k)/tem0_vt) * a_tem0_vt
          log_rho_fac_q(k,i_mp_qs) = log_rho_fac_q(k,i_mp_qi)
          log_rho_fac_q(k,i_mp_qg) = log_rho_fac_q(k,i_mp_qi)
       enddo
 
       sl_plcdep = 0.0_rp
       sl_plrdep = 0.0_rp
       sl_pnrdep = 0.0_rp
 
!OCL XFILL
       do k = ks, ke
          qke_d(k) = 0.0_rp ! 2*TKE
       enddo
 
!OCL XFILL
       do k = ks, ke
          dtdt_equiv_d(k) = 0.0_rp
       enddo
 
!       nc_uplim_d(1)  = c_ccn_map(1,i,j)*1.5_RP
       nc_uplim_d(1,i,j)  = c_ccn*1.5_rp
 
 
       call nucleation( &
            ka, ks, ke, &
            cz(:,i,j), fz(:,i,j),               & ! (in)
            w(:,i,j), dens(:,i,j),              & ! (in)
            wtemp(:), pres(:), qdry(:,i,j),     & ! (in)
            rhoq(:,:), cpa(:), cva(:),          & ! (in)
            dtdt_equiv_d(:),                    & ! (in)
            qke_d(:),                           & ! (in)
            ccn(:,i,j), nc_uplim_d(1,i,j),      & ! (in)
            dt,                                 & ! (in)
            dq_xa, vt_xa,                       & ! (in)
            pq(:,:)                             ) ! (out)
 
 
       if( opt_nucleation_ice_hom ) then
 
          ! homogeneous ice nucleation
          do k = ks, ke
             drhoqihom = pq(k,i_lihom)
             tmp    = - drhoqihom
             drhoqvhom = max( - rhoq(k,i_qv) / dt , tmp )
             fac1 = drhoqvhom / min( tmp, -eps ) ! drhoqc and drhoqi must be >= 0, otherwise fac1 can be artificially huge value.
 
             drhoqihom = drhoqihom * fac1
 
             rhoq0_t(k,i_qv) = drhoqvhom
             rhoq0_t(k,i_qi) = drhoqihom
 
             rhoe0_t(k) = - lhv * drhoqvhom + lhf * drhoqihom
 
             dqvhom = rrho(k) * drhoqvhom
             dqihom = rrho(k) * drhoqihom
 
             dcvhom = cv_vapor * dqvhom + cv_ice * dqihom
             dcphom = cp_vapor * dqvhom + cp_ice * dqihom
 
             cvtot0_t(k) = dcvhom
             cptot0_t(k) = dcphom
 
             drhonihom = pq(k,i_nihom) * fac1
             rhoq0_t(k,i_ni) = drhonihom
          end do
 
          ! total tendency
          do k = ks, ke
             rhoe_t(k,i,j) = rhoe_t(k,i,j) + rhoe0_t(k)
             cvtot_t(k,i,j) = cvtot_t(k,i,j) + cvtot0_t(k)
             cptot_t(k,i,j) = cptot_t(k,i,j) + cptot0_t(k)
          enddo
 
          ! update intermidiate variable
          do k = ks, ke
             rhoq(k,i_qv) = rhoq(k,i_qv) + rhoq0_t(k,i_qv)*dt
             rhoq(k,i_qi) = max(0.0_rp, rhoq(k,i_qi) + rhoq0_t(k,i_qi)*dt )
             rhoq(k,i_ni) = max(0.0_rp, rhoq(k,i_ni) + rhoq0_t(k,i_ni)*dt )
          enddo
 
          do k = ks, ke
             rhoe(k) = rhoe(k) + rhoe0_t(k)*dt
             cva(k) = cva(k) + cvtot0_t(k)*dt
             cpa(k) = cpa(k) + cptot0_t(k)*dt
 
             temp(k) = rhoe(k) / ( dens(k,i,j) * cva(k) )
             pres(k) = dens(k,i,j) * (cpa(k)-cva(k)) * temp(k)
             wtemp(k) = max( temp(k), tem_min )
          enddo
 
       endif
 
       ! nucleation
       do k = ks, ke
          drhoqc = pq(k,i_lcccn)
          drhoqi = pq(k,i_liccn)
          tmp = - drhoqc - drhoqi
          drhoqv = max( - rhoq(k,i_qv) / dt, tmp )
 
          ! limiting coefficient
          fac1 = drhoqv / min( tmp, -eps ) ! drhoqc and drhoqi must be >= 0, otherwise fac1 can be artificially huge value.
 
          drhoqc = drhoqc * fac1
          drhoqi = drhoqi * fac1
 
          rhoq0_t(k,i_qv) = drhoqv
          rhoq0_t(k,i_qc) = drhoqc
          rhoq0_t(k,i_qi) = drhoqi
 
          rhoe0_t(k) = - lhv * drhoqv + lhf * drhoqi
 
          dqv = rrho(k) * drhoqv
          dql = rrho(k) * drhoqc
          dqi = rrho(k) * drhoqi
 
          dcv = cv_vapor * dqv + cv_water * dql + cv_ice * dqi
          dcp = cp_vapor * dqv + cp_water * dql + cp_ice * dqi
 
          cvtot0_t(k) = dcv
          cptot0_t(k) = dcp
 
          drhonc = pq(k,i_ncccn) * fac1
          drhoni = pq(k,i_niccn) * fac1
          rhoq0_t(k,i_nc) = drhonc
          rhoq0_t(k,i_ni) = drhoni
       end do
 
       ! total tendency
       do k = ks, ke
          rhoe_t(k,i,j) = rhoe_t(k,i,j) + rhoe0_t(k)
          cvtot_t(k,i,j) = cvtot_t(k,i,j) + cvtot0_t(k)
          cptot_t(k,i,j) = cptot_t(k,i,j) + cptot0_t(k)
       enddo
 
       ! update intermidiate variable
       do k = ks, ke
          rhoq(k,i_qv) = rhoq(k,i_qv) + rhoq0_t(k,i_qv)*dt
          rhoq(k,i_qc) = max(0.0_rp, rhoq(k,i_qc) + rhoq0_t(k,i_qc)*dt )
          rhoq(k,i_qi) = max(0.0_rp, rhoq(k,i_qi) + rhoq0_t(k,i_qi)*dt )
          rhoq(k,i_nc) = max(0.0_rp, rhoq(k,i_nc) + rhoq0_t(k,i_nc)*dt )
          rhoq(k,i_ni) = max(0.0_rp, rhoq(k,i_ni) + rhoq0_t(k,i_ni)*dt )
 
          ! cloud number concentration filter
          rhoq(k,i_nc) = min( rhoq(k,i_nc), nc_uplim_d(1,i,j) )
       end do
 
       do k = ks, ke
          rhoe(k) = rhoe(k) + rhoe0_t(k)*dt
          cva(k) = cva(k) + cvtot0_t(k)*dt
          cpa(k) = cpa(k) + cptot0_t(k)*dt
 
          temp(k) = rhoe(k) / ( dens(k,i,j) * cva(k) )
          pres(k) = dens(k,i,j) * (cpa(k)-cva(k)) * temp(k)
          wtemp(k) = max( temp(k), tem_min )
       enddo
 
 
#ifdef DEBUG
       call debug_tem( ka, ks, ke, &
            2, i, j, temp(:), dens(:,i,j), pres(:), qtrc(:,i,j,i_qv) )
#endif
 
 
       !----------------------------------------------------------------------------
       !
       ! 2.Phase change: Freezing, Melting, Vapor deposition
       !
       !----------------------------------------------------------------------------
       call get_terminal_velocity( &
            ka, ks, ke, &
            vt_xa(:,:,:), xq(:,:), & ! (out)
            rhoq(:,:),             & ! (in)
            log_rho_fac_q(:,:)     ) ! (in)
 
       call get_diamiter( &
            ka, ks, ke, &
            dq_xa(:,:), & ! (out)
            xq(:,:)     ) ! (in)
 
       if (flg_lt_l) then
          do iq = i_qc, i_qg
          do k = ks, ke
             rhoq_crg(k,iq) = dens(k,i,j) * qtrc_crg(k,i,j,iq-1)
          enddo
          enddo
       end if
 
       call moist_psat_liq( ka, ks, ke, &
                            wtemp(:), esw(:) ) ! [IN], [OUT]
       call moist_psat_ice( ka, ks, ke, &
                            wtemp(:), esi(:) ) ! [IN], [OUT]
 
       call freezing_water( &
            ka, ks, ke, &
            dt,                          & ! (in)
            rhoq(:,:), xq(:,:), temp(:), & ! (in)
            pq(:,:)                      ) ! (inout)
 
       call dep_vapor_melt_ice( &
            ka, ks, ke, &
            dens(:,i,j), wtemp(:), pres(:), qdry(:,i,j), rhoq(:,:), & ! (in)
            esw(:), esi(:), xq(:,:), vt_xa(:,:,:), dq_xa(:,:),      & ! (in)
            pq(:,:)                                                 ) ! (inout)
 
       !
       ! update subroutine
       !
       call update_by_phase_change( &
            ka, ks, ke, &
            ntmax_phase_change, dt,          & ! (in)
            cz(:,i,j), fz(:,i,j),            & ! (in)
            w(:,i,j),                        & ! (in)
            dtdt_equiv_d(:),                 & ! (in)
            dens(:,i,j), qdry(:,i,j),        & ! (in)
            esw(:), esi(:),                  & ! (in)
            rhoq(:,:), pres(:), temp(:),     & ! (in)
            cpa(:), cva(:),                  & ! (in)
            flg_lt_l,                        & ! (in)
            pq(:,:),                         & ! (inout)
            sl_plcdep, sl_plrdep, sl_pnrdep, & ! (inout)
            rhoq0_t(:,:), rhoe0_t(:),        & ! (out)
            cptot0_t(:), cvtot0_t(:),        & ! (out)
            evaporate(:,i,j),                & ! (out)
            rhoq_crg(:,:),                   & ! (in:optional)
            rhoqcrg0_t(:,:)                  ) ! (out:optional)
 
       ! total tendency
       do k = ks, ke
          rhoe_t(k,i,j) = rhoe_t(k,i,j) + rhoe0_t(k)
          cvtot_t(k,i,j) = cvtot_t(k,i,j) + cvtot0_t(k)
          cptot_t(k,i,j) = cptot_t(k,i,j) + cptot0_t(k)
       enddo
 
       ! update intermidiate variable
       do iq = 1, qa_mp
       do k = ks, ke
          rhoq(k,iq) = max(0.0_rp, rhoq(k,iq) + rhoq0_t(k,iq)*dt )
       enddo
       enddo
 
       do k = ks, ke
          rhoe(k) = rhoe(k) + rhoe0_t(k)*dt
          cva(k) = cva(k) + cvtot0_t(k)*dt
          cpa(k) = cpa(k) + cptot0_t(k)*dt
          temp(k) = rhoe(k) / ( dens(k,i,j) * cva(k) )
          pres(k) = dens(k,i,j) * ( cpa(k) - cva(k) ) * temp(k)
       enddo
 
       if (flg_lt_l) then
          do iq = i_qc, i_qg
          do k = ks, ke
             rhoq_crg(k,iq) = rhoq_crg(k,iq) + rhoqcrg0_t(k,iq) * dt  ! need limiter?
          enddo
          enddo
       end if
 
#ifdef DEBUG
       call debug_tem( ka, ks, ke, &
            3, i, j, temp(:), dens(:,i,j), pres(:), qtrc(:,i,j,i_qv) )
#endif
 
       !---------------------------------------------------------------------------
       !
       ! 3.Collection process
       !
       !---------------------------------------------------------------------------
 
       ! parameter setting
 
       call get_terminal_velocity( &
            ka, ks, ke, &
            vt_xa(:,:,:), xq(:,:), & ! (out)
            rhoq(:,:),             & ! (in)
            log_rho_fac_q(:,:)     ) ! (in)
 
       ! effective cross section is assume as area equivalent circle
       do k = ks, ke
          dq_xa(k,i_mp_qc) = 2.0_rp*a_rea(i_mp_qc)*xq(k,i_mp_qc)**b_rea(i_mp_qc)
          dq_xa(k,i_mp_qr) = 2.0_rp*a_rea(i_mp_qr)*xq(k,i_mp_qr)**b_rea(i_mp_qr)
          dq_xa(k,i_mp_qi) = 2.0_rp*a_rea(i_mp_qi)*xq(k,i_mp_qi)**b_rea(i_mp_qi)
          dq_xa(k,i_mp_qs) = 2.0_rp*a_rea(i_mp_qs)*xq(k,i_mp_qs)**b_rea(i_mp_qs)
          dq_xa(k,i_mp_qg) = 2.0_rp*a_rea(i_mp_qg)*xq(k,i_mp_qg)**b_rea(i_mp_qg)
       end do
 
       pcrg1(:,:) = 0.0_rp
       pcrg2(:,:) = 0.0_rp
 
       ! Auto-conversion, Accretion, Self-collection, Break-up
       if ( mp_doautoconversion ) then
          call aut_acc_slc_brk(     &
               ka, ks, ke,          &
               flg_lt_l,            & ! (in)
               rhoq(:,:),           & ! (in)
               rhoq_crg(:,:),       & ! (in)
               xq(:,:), dq_xa(:,:), & ! (in)
               dens(:,i,j),         & ! (in)
               pq(:,:),             & ! (in)
               pcrg1(:,:)           ) ! (inout)
 
       else
!OCL XFILL
          do k = ks, ke
             pq(k,i_lcaut) = 0.0_rp
             pq(k,i_ncaut) = 0.0_rp
             pq(k,i_nraut) = 0.0_rp
             pq(k,i_lcacc) = 0.0_rp
             pq(k,i_ncacc) = 0.0_rp
             pq(k,i_nrslc) = 0.0_rp
             pq(k,i_nrbrk) = 0.0_rp
             !--- for lightning
             pcrg1(k,i_lcaut) = 0.0_rp
             pcrg1(k,i_ncaut) = 0.0_rp
             pcrg1(k,i_nraut) = 0.0_rp
             pcrg1(k,i_lcacc) = 0.0_rp
             pcrg1(k,i_ncacc) = 0.0_rp
             pcrg1(k,i_nrslc) = 0.0_rp
             pcrg1(k,i_nrbrk) = 0.0_rp
          end do
       endif
 
       if ( flg_lt_l ) then
          do k = ks, ke
             beta_crg_l(k) = beta_crg(k,i,j)
             dqcrg_l(k) = dqcrg(k,i,j)
          end do
       end if
 
       ! collection process
       if( opt_collection_bin ) then
          call mixed_phase_collection_bin(            &
               ka, ks, ke,                        & ! (in)
               flg_lt_l,                          & ! (in)
               d0_crg_l, v0_crg_l,                & ! (in)
               beta_crg_l(:), dqcrg_l(:),         & ! (in)
               temp(:), rhoq(:,:),                & ! (in)
               rhoq_crg(:,:),                     & ! (in)
               xq(:,:), dq_xa(:,:), vt_xa(:,:,:), & ! (in)
               dens(:,i,j),                       & ! (in)
               pq(:,:),                           & ! (inout)
               pcrg1(:,:),                        & ! (inout)
               pcrg2(:,:),                        & ! (inout)
               pac(:,:)                           ) ! (out)
       else
          call mixed_phase_collection(            &
               ka, ks, ke,                        & ! (in)
               flg_lt_l,                          & ! (in)
               d0_crg_l, v0_crg_l,                & ! (in)
               beta_crg_l(:), dqcrg_l(:),         & ! (in)
               temp(:), rhoq(:,:),                & ! (in)
               rhoq_crg(:,:),                     & ! (in)
               xq(:,:), dq_xa(:,:), vt_xa(:,:,:), & ! (in)
               pq(:,:),                           & ! (inout)
               pcrg1(:,:),                        & ! (inout)
               pcrg2(:,:),                        & ! (inout)
               pac(:,:)                           ) ! (out)
       endif
 
 
       call ice_multiplication( &
            ka, ks, ke,         & ! (in)
            flg_lt_l,           & ! (in)
            pac(:,:),           & ! (in)
            temp(:), rhoq(:,:), & ! (in)
            rhoq_crg(:,:),      & ! (in)
            xq(:,:),            & ! (in)
            pq(:,:),            & ! (inout)
            pcrg1(:,:)          ) ! (inout)
 
       !
       ! update
       !
!OCL LOOP_FISSION_TARGET(LS)
       do k = ks, ke
          ! warm collection process
          wrm_dqc = max( dt*( pq(k,i_lcaut)+pq(k,i_lcacc)               ), -rhoq(k,i_qc) )
          wrm_dnc = max( dt*( pq(k,i_ncaut)+pq(k,i_ncacc)               ), -rhoq(k,i_nc) )
          wrm_dnr = max( dt*( pq(k,i_nraut)+pq(k,i_nrslc)+pq(k,i_nrbrk) ), -rhoq(k,i_nr) )
          wrm_dqr = -wrm_dqc
 
          ! mixed phase collection
          ! Pxxacyy2zz xx and yy decrease and zz increase .
          !
          ! At first fixer is applied to decreasing particles.
          ! order of fixer: graupel-cloud, snow-cloud, ice-cloud, graupel-rain, snow-rain, ice-rain,
          !                 snow-ice,  ice-ice, graupel-snow, snow-snow
          ! cloud mass decrease
          gc_dqc  = max( dt*pac(k,i_lgaclc2lg), min(0.0_rp, -rhoq(k,i_qc)-wrm_dqc               )) ! => dqg
          sc_dqc  = max( dt*pac(k,i_lsaclc2ls), min(0.0_rp, -rhoq(k,i_qc)-wrm_dqc-gc_dqc        )) ! => dqs
          ic_dqc  = max( dt*pac(k,i_liaclc2li), min(0.0_rp, -rhoq(k,i_qc)-wrm_dqc-gc_dqc-sc_dqc )) ! => dqi
          ! cloud num. decrease
          gc_dnc  = max( dt*pac(k,i_ngacnc2ng), min(0.0_rp, -rhoq(k,i_nc)-wrm_dnc               )) ! => dnc:minus
          sc_dnc  = max( dt*pac(k,i_nsacnc2ns), min(0.0_rp, -rhoq(k,i_nc)-wrm_dnc-gc_dnc        )) ! => dnc:minus
          ic_dnc  = max( dt*pac(k,i_niacnc2ni), min(0.0_rp, -rhoq(k,i_nc)-wrm_dnc-gc_dnc-sc_dnc )) ! => dnc:minus
 
          ! rain mass decrease ( tem < 273.15K)
          sw = sign(0.5_rp, t00-temp(k)) + 0.5_rp ! if( temp(k,i,j) <= T00 )then sw=1, else sw=0
          rg_dqr  = max( dt*pac(k,i_lraclg2lg  ), min(0.0_rp, -rhoq(k,i_qr)-wrm_dqr               )) * sw
          rg_dqg  = max( dt*pac(k,i_lraclg2lg  ), min(0.0_rp, -rhoq(k,i_qg)                       )) * ( 1.0_rp - sw )
          rs_dqr  = max( dt*pac(k,i_lracls2lg_r), min(0.0_rp, -rhoq(k,i_qr)-wrm_dqr-rg_dqr        )) * sw
          ri_dqr  = max( dt*pac(k,i_lracli2lg_r), min(0.0_rp, -rhoq(k,i_qr)-wrm_dqr-rg_dqr-rs_dqr )) * sw
 
          ! rain num. decrease
          rg_dnr  = max( dt*pac(k,i_nracng2ng  ), min(0.0_rp, -rhoq(k,i_nr)-wrm_dnr               )) * sw
          rg_dng  = max( dt*pac(k,i_nracng2ng  ), min(0.0_rp, -rhoq(k,i_ng)                       )) * ( 1.0_rp - sw )
          rs_dnr  = max( dt*pac(k,i_nracns2ng_r), min(0.0_rp, -rhoq(k,i_nr)-wrm_dnr-rg_dnr        )) * sw
          ri_dnr  = max( dt*pac(k,i_nracni2ng_r), min(0.0_rp, -rhoq(k,i_nr)-wrm_dnr-rg_dnr-rs_dnr )) * sw
 
          ! ice mass decrease
          fac1    = (ri_dqr-eps)/ (dt*pac(k,i_lracli2lg_r)-eps) ! suppress factor by filter of rain
          ri_dqi  = max( dt*pac(k,i_lracli2lg_i)*fac1, min(0.0_rp, -rhoq(k,i_qi)+ic_dqc               )) ! => dqg
          ii_dqi  = max( dt*pac(k,i_liacli2ls  )     , min(0.0_rp, -rhoq(k,i_qi)+ic_dqc-ri_dqi        )) ! => dqs
          is_dqi  = max( dt*pac(k,i_liacls2ls  )     , min(0.0_rp, -rhoq(k,i_qi)+ic_dqc-ri_dqi-ii_dqi )) ! => dqs
!!         !-- Y.Sato added(2018/8/31)
!!         gi_dqi  = max( dt*Pac(k,I_LGacLI2LG)       , min(0.0_RP, -rhoq(k,I_QI)+ic_dqc-ri_dqi-ii_dqi-is_dqi )) ! => dqg
 
          ! ice num. decrease
          fac4(k) = (ri_dnr-eps)/ (dt*pac(k,i_nracni2ng_r)-eps) ! suppress factor by filter of rain
          ri_dni  = max( dt*pac(k,i_nracni2ng_i)*fac4(k), min(0.0_rp, -rhoq(k,i_ni)               )) ! => dni:minus
          ii_dni  = max( dt*pac(k,i_niacni2ns  )        , min(0.0_rp, -rhoq(k,i_ni)-ri_dni        )) ! => dni:minus,dns:plus(*0.5)
          is_dni  = max( dt*pac(k,i_niacns2ns  )        , min(0.0_rp, -rhoq(k,i_ni)-ri_dni-ii_dni )) ! => dni:minus,dns:plus
!!         !-- Y.Sato added(2018/8/31)
!!         gi_dni  = max( dt*Pac(k,I_NGacNI2NG)          , min(0.0_RP, -rhoq(k,I_NI)-ri_dni-ii_dni-is_dni )) ! => dns:minus
 
          ! snow mass decrease
          fac3    = (rs_dqr-eps)/(dt*pac(k,i_lracls2lg_r)-eps) ! suppress factor by filter of rain
          rs_dqs  = max( dt*pac(k,i_lracls2lg_s)*fac3, min(0.0_rp, -rhoq(k,i_qs)+sc_dqc+ii_dqi+is_dqi        )) ! => dqg
          gs_dqs  = max( dt*pac(k,i_lgacls2lg  )     , min(0.0_rp, -rhoq(k,i_qs)+sc_dqc+ii_dqi+is_dqi-rs_dqs )) ! => dqg
          ! snow num. decrease
          fac6(k) = (rs_dnr-eps)/(dt*pac(k,i_nracns2ng_r)-eps) ! suppress factor by filter of rain
          !       fac7    = (is_dni-eps)/(dt*Pac(I_NIacNS2NS,  k,i,j)-eps) ! suppress factor by filter of ice
          rs_dns  = max( dt*pac(k,i_nracns2ng_s)*fac6(k), min(0.0_rp, -rhoq(k,i_ns)+0.50_rp*ii_dni+is_dni        )) ! => dns:minus
          gs_dns  = max( dt*pac(k,i_ngacns2ng  )        , min(0.0_rp, -rhoq(k,i_ns)+0.50_rp*ii_dni+is_dni-rs_dns )) ! => dns:minus
          ss_dns  = max( dt*pac(k,i_nsacns2ns  )        , min(0.0_rp, -rhoq(k,i_ns)+0.50_rp*ii_dni+is_dni-rs_dns-gs_dns ))
          gg_dng  = max( dt*pac(k,i_ngacng2ng  )        , min(0.0_rp, -rhoq(k,i_ng) ))
 
          ! total plus in mixed phase collection(clp_)
          ! mass
          ! if( temp(k,i,j) <= T00 )then sw=1, else sw=0
          clp_dqc =  0.0_rp
          clp_dqr = (-rg_dqg-rs_dqs-ri_dqi) * (1.0_rp-sw)
          clp_dqi = -ic_dqc
          clp_dqs = -sc_dqc-ii_dqi-is_dqi
          clp_dqg = -gc_dqc -gs_dqs  + (-rg_dqr-rs_dqr-rs_dqs-ri_dqr-ri_dqi) * sw
          ! num.( number only increase when a+b=>c,  dnc=-dna)
          clp_dnc = 0.0_rp
          clp_dnr = 0.0_rp
          clp_dni = 0.0_rp
          clp_dns = -ii_dni*0.5_rp
          clp_dng = (-rs_dnr-ri_dnr) * sw
 
          ! total minus in mixed phase collection(clm_)
          ! mass
          clm_dqc = gc_dqc+sc_dqc+ic_dqc
          clm_dqr = (rg_dqr+rs_dqr+ri_dqr) * sw
          clm_dqi = ri_dqi+ii_dqi+is_dqi
          clm_dqs = rs_dqs+gs_dqs
          clm_dqg = rg_dqg * (1.0_rp-sw)
          ! num.
          clm_dnc = gc_dnc+sc_dnc+ic_dnc
          clm_dnr = (rg_dnr+rs_dnr+ri_dnr) * sw
          clm_dni = ri_dni+ii_dni+is_dni
          clm_dns = rs_dns+ss_dns+gs_dns
          clm_dng = gg_dng + rg_dng * (1.0_rp-sw)
 
          ! partial conversion
          ! 08/05/08 [Mod] T.Mitsui
          pco_dqi = max( dt*pq(k,i_licon), -clp_dqi )
          pco_dqs = max( dt*pq(k,i_lscon), -clp_dqs )
          pco_dqg = -pco_dqi-pco_dqs
          ! 08/05/08 [Mod] T.Mitsui
          pco_dni = max( dt*pq(k,i_nicon), -clp_dni )
          pco_dns = max( dt*pq(k,i_nscon), -clp_dns )
          pco_dng = -pco_dni-pco_dns
 
          ! enhanced melting ( always negative value )
          ! ice-cloud melting produces cloud, others produce rain
          eml_dqi =  max( dt*pq(k,i_liacm), min(0.0_rp, -rhoq(k,i_qi)-(clp_dqi+clm_dqi)-pco_dqi ))
          eml_dqs =  max( dt*pq(k,i_lsacm), min(0.0_rp, -rhoq(k,i_qs)-(clp_dqs+clm_dqs)-pco_dqs ))
          eml_dqg =  max( dt*(pq(k,i_lgacm)+pq(k,i_lgarm)+pq(k,i_lsarm)+pq(k,i_liarm)), &
                     min(0.0_rp, -rhoq(k,i_qg)-(clp_dqg+clm_dqg)-pco_dqg ))
          eml_dqc = -eml_dqi
          eml_dqr = -eml_dqs-eml_dqg
          !
          eml_dni =  max( dt*pq(k,i_niacm), min(0.0_rp, -rhoq(k,i_ni)-(clp_dni+clm_dni)-pco_dni ))
          eml_dns =  max( dt*pq(k,i_nsacm), min(0.0_rp, -rhoq(k,i_ns)-(clp_dns+clm_dns)-pco_dns ))
          eml_dng =  max( dt*(pq(k,i_ngacm)+pq(k,i_ngarm)+pq(k,i_nsarm)+pq(k,i_niarm)), &
                     min(0.0_rp, -rhoq(k,i_ng)-(clp_dng+clm_dng)-pco_dng ))
          eml_dnc = -eml_dni
          eml_dnr = -eml_dns-eml_dng
 
          ! ice multiplication
          spl_dqg = max( dt*pq(k,i_lgspl), min(0.0_rp, -rhoq(k,i_qg)-(clp_dqg+clm_dqg)-pco_dqg-eml_dqg ))
          spl_dqs = max( dt*pq(k,i_lsspl), min(0.0_rp, -rhoq(k,i_qs)-(clp_dqs+clm_dqs)-pco_dqs-eml_dqs ))
          spl_dqi = -spl_dqg-spl_dqs
          fac9(k)  = (spl_dqg-eps)/(dt*pq(k,i_lgspl)-eps) * (spl_dqs-eps)/(dt*pq(k,i_lsspl)-eps)
          spl_dni = dt*pq(k,i_nispl)*fac9(k)
 
          !
          ! melting and freezing limiter
          di2l = clp_dqc + clp_dqr + clm_dqc + clm_dqr + eml_dqc + eml_dqr ! = - ( clp_dqi + clp_dqs + clp_dqg + clm_dqi + clm_dqs + clm_dqg + eml_dqi + eml_dqs + eml_dqg )
          dtem = - di2l * lhf0 /  ( cva(k) * dens(k,i,j) )
          if ( abs(dtem) < eps ) then
             fact(k) = 1.0_rp
          else
             fact(k) = min( 1.0_rp, max( 0.0_rp, ( t00 - temp(k) ) / dtem ) )
          end if
 
          !
          ! total cloud change
          drhoqc = wrm_dqc + ( clp_dqc + clm_dqc + eml_dqc ) * fact(k)
          drhonc = wrm_dnc + ( clp_dnc + clm_dnc + eml_dnc ) * fact(k)
          ! total rain change
          drhoqr = wrm_dqr + ( clp_dqr + clm_dqr + eml_dqr ) * fact(k)
          drhonr = wrm_dnr + ( clp_dnr + clm_dnr + eml_dnr ) * fact(k)
          ! total ice change
          drhoqi =           ( clp_dqi + clm_dqi + eml_dqi ) * fact(k) + pco_dqi + spl_dqi
          drhoni =           ( clp_dni + clm_dni + eml_dni ) * fact(k) + pco_dni + spl_dni
          ! total snow change
          drhoqs =           ( clp_dqs + clm_dqs + eml_dqs ) * fact(k) + pco_dqs + spl_dqs
          drhons =           ( clp_dns + clm_dns + eml_dns ) * fact(k) + pco_dns
          ! total graupel change
          drhoqg =           ( clp_dqg + clm_dqg + eml_dqg ) * fact(k) + pco_dqg + spl_dqg
          drhong =           ( clp_dng + clm_dng + eml_dng ) * fact(k) + pco_dng
 
          ! tendency
          rhoq0_t(k,i_qc) = drhoqc / dt
          rhoq0_t(k,i_nc) = drhonc / dt
          rhoq0_t(k,i_qr) = drhoqr / dt
          rhoq0_t(k,i_nr) = drhonr / dt
          rhoq0_t(k,i_qi) = drhoqi / dt
          rhoq0_t(k,i_ni) = drhoni / dt
          rhoq0_t(k,i_qs) = drhoqs / dt
          rhoq0_t(k,i_ns) = drhons / dt
          rhoq0_t(k,i_qg) = drhoqg / dt
          rhoq0_t(k,i_ng) = drhong / dt
 
          rhoe0_t(k) = lhf * ( drhoqi + drhoqs + drhoqg ) / dt
 
          dql = rrho(k) * ( drhoqc + drhoqr )
          dqi = rrho(k) * ( drhoqi + drhoqs + drhoqg )
 
          dcv = cv_water * dql + cv_ice * dqi
          dcp = cp_water * dql + cp_ice * dqi
 
          cvtot0_t(k) = dcv / dt
          cptot0_t(k) = dcp / dt
 
 
       enddo
 
       ! total tendency
       do k = ks, ke
          rhoe_t(k,i,j) = rhoe_t(k,i,j) + rhoe0_t(k)
          cvtot_t(k,i,j) = cvtot_t(k,i,j) + cvtot0_t(k)
          cptot_t(k,i,j) = cptot_t(k,i,j) + cptot0_t(k)
       enddo
 
       !--- update
       do iq = i_qc, i_ng
       do k = ks, ke
          rhoq(k,iq) = max(0.0_rp, rhoq(k,iq) + rhoq0_t(k,iq) * dt )
       enddo
       enddo
 
       ! total tendency
       do iq = i_qv, i_ng
       do k = ks, ke
          rhoq_t(k,i,j,iq) = ( rhoq(k,iq) - dens(k,i,j)*qtrc(k,i,j,iq) )/dt
       enddo
       enddo
 
       do ip = 1, w_nmax
          if ( hist_sw(ip) ) then
             if(ip <= pq_max) then
                do k = ks, ke
                   w3d(k,i,j,hist_idx(ip)) = pq(k,ip)
                end do
             else
                do k = ks, ke
                   w3d(k,i,j,hist_idx(ip)) = pac(k,ip-pq_max)
                end do
             endif
          end if
       enddo
 
       !--- for lithgning component
       if ( flg_lt_l ) then
 
!OCL LOOP_FISSION_TARGET(LS)
          do k = ks, ke
             sw = sign(0.5_rp, t00-temp(k)) + 0.5_rp ! if( temp(k,i,j) <= T00 )then sw=1, else sw=0
 
             wrm_dnc_crg = dt*( pcrg1(k,i_ncaut)+pcrg1(k,i_ncacc) )   ! C + C -> R
             !--- limiter
             sw1 = min( abs(rhoq_crg(k,i_qc)),abs(wrm_dnc_crg) )
             wrm_dnc_crg = sign( sw1,wrm_dnc_crg )
             wrm_dnr_crg = - wrm_dnc_crg
 
             ! Decrease of absolute value of cloud charge density
             gc_dnc_crg  = dt*pcrg2(k,i_ngacnc2ng)  ! C + G -> G  ( move from c to g )
             sc_dnc_crg  = dt*pcrg2(k,i_nsacnc2ns)  ! C + S -> S  ( move from c to s )
             ic_dnc_crg  = dt*pcrg2(k,i_niacnc2ni)  ! C + I -> I  ( move from c to i )
             !--- limiter
             sw1 = min( abs(rhoq_crg(k,i_qc)+wrm_dnc_crg                      ),abs(gc_dnc_crg) )
             gc_dnc_crg = sign( sw1,gc_dnc_crg )
             sw1 = min( abs(rhoq_crg(k,i_qc)+wrm_dnc_crg+gc_dnc_crg           ),abs(sc_dnc_crg) )
             sc_dnc_crg = sign( sw1,sc_dnc_crg )
             sw1 = min( abs(rhoq_crg(k,i_qc)+wrm_dnc_crg+gc_dnc_crg+sc_dnc_crg),abs(ic_dnc_crg) )
             ic_dnc_crg = sign( sw1,ic_dnc_crg )
 
             ! Decrease of absolute value of rain charge density
             rg_dnr_crg  = dt*pcrg2(k,i_nracng2ng  )* sw                 ! R + G -> G
             rg_dng_crg  = dt*pcrg2(k,i_nracng2ng  )* ( 1.0_rp - sw )    ! R + G -> R
             rs_dnr_crg  = dt*pcrg2(k,i_nracns2ng_r)* sw                 ! R + S -> G
             ri_dnr_crg  = dt*pcrg2(k,i_nracni2ng_r)* sw                 ! R + I -> G
             !--- limiter
             sw1 = min( abs(rhoq_crg(k,i_qr)+wrm_dnr_crg),abs(rg_dnr_crg) )
             rg_dnr_crg = sign( sw1,rg_dnr_crg )
             sw1 = min( abs(rhoq_crg(k,i_qg)            ),abs(rg_dng_crg) )
             rg_dng_crg = sign( sw1,rg_dng_crg )
             sw1 = min( abs(rhoq_crg(k,i_qr)+wrm_dnr_crg),abs(rs_dnr_crg) )
             rs_dnr_crg = sign( sw1,rs_dnr_crg )
             sw1 = min( abs(rhoq_crg(k,i_qr)+wrm_dnr_crg),abs(ri_dnr_crg) )
             ri_dnr_crg = sign( sw1,ri_dnr_crg )
 
             ! Decrease of absolute value of ice charge density
             ri_dni_crg  = dt*pcrg2(k,i_nracni2ng_i)*fac4(k) !  I + R -> G
             ii_dni_crg  = dt*pcrg2(k,i_niacni2ns)           !  I + I -> S
             is_dni_crg  = dt*pcrg2(k,i_niacns2ns)           !  I + S -> S
!!            !-- Y.Sato added(2018/8/31)
!!            gi_dni_crg  = dt*Pcrg2(k,I_NGacNI2NG)          ! G + S -> G
             !--- limiter
             sw1 = min( abs(rhoq_crg(k,i_qi)-ic_dnc_crg)                      ,abs(ri_dni_crg) )
             ri_dni_crg = sign( sw1,ri_dni_crg )
             sw1 = min( abs(rhoq_crg(k,i_qi)-ic_dnc_crg+ri_dni_crg)           ,abs(ii_dni_crg) )
             ii_dni_crg = sign( sw1,ii_dni_crg )
             sw1 = min( abs(rhoq_crg(k,i_qi)-ic_dnc_crg+ri_dni_crg+ii_dni_crg),abs(is_dni_crg) )
             is_dni_crg = sign( sw1,is_dni_crg )
!!            !-- Y.Sato added(2018/8/31)
!!            sw1 = min( abs(rhoq_crg(k,I_QI)-ic_dnc_crg+ri_dni_crg+ii_dni_crg+is_dni_crg),abs(gi_dni_crg) )
!!            gi_dni_crg = sign( sw1,gi_dni_crg )
 
             ! Decrease of absolute value of snow charge density
             rs_dns_crg  = dt*pcrg2(k,i_nracns2ng_s)*fac6(k) ! R + S -> G
             gs_dns_crg  = dt*pcrg2(k,i_ngacns2ng)           ! G + S -> G
             ss_dns_crg  = 0.0_rp                            ! S + S -> S (No charge transfer)
             gg_dng_crg  = 0.0_rp                            ! G + G -> G (No charge transfer)
             !--- limiter
             sw1 = min( abs(rhoq_crg(k,i_qs)-sc_dnc_crg-ii_dni_crg-is_dni_crg),           abs(rs_dns_crg) )
             rs_dns_crg = sign( sw1,rs_dns_crg )
             sw1 = min( abs(rhoq_crg(k,i_qs)-sc_dnc_crg-ii_dni_crg-is_dni_crg+rs_dns_crg),abs(gs_dns_crg) )
             gs_dns_crg = sign( sw1,gs_dns_crg )
             !--- Charge split
             sw1 = sign(0.5_rp, abs( pcrg2(k,i_cgngacns2ng) )-eps ) + 0.5_rp ! if abs Pcrg2 is smaller than EPS, sw=1, else sw=0
             sw2 = sign(0.5_rp, abs( pcrg2(k,i_cgngacni2ng) )-eps ) + 0.5_rp ! if abs Pcrg2 is smaller than EPS, sw=1, else sw=0
             crg_split_g =  dt*pcrg2(k,i_cgngacns2ng)*sw1 &
                         +  dt*pcrg2(k,i_cgngacni2ng)*sw2
             crg_split_s = -dt*pcrg2(k,i_cgngacns2ng)*sw1
             crg_split_i = 0.0_rp
!!            crg_split_i = -dt*Pcrg2(k,I_CGNGacNI2NG)*sw2  !Y.Sato (2018/8/31)
             qsplt_in(k,i,j,1) = crg_split_g / dt    ! fC/s
             qsplt_in(k,i,j,3) = crg_split_s / dt    ! fC/s
             qsplt_in(k,i,j,2) = crg_split_i / dt    ! fC/s
 
             ! Decrease of absolute value of graupel charge density
             clp_dnc_crg = 0.0_rp
             clp_dnr_crg = -rg_dng_crg*(1.0_rp-sw)
             clp_dni_crg = -ic_dnc_crg !&
!!                          +crg_split_i ! Y.Sato added (2018/8/31)
             clp_dns_crg = -sc_dnc_crg-ii_dni_crg-is_dni_crg-ss_dns_crg &
                           +crg_split_s
             clp_dng_crg = -gc_dnc_crg+(-rg_dnr_crg-rs_dnr_crg-ri_dnr_crg)*sw &
                           -ri_dni_crg-rs_dns_crg-gs_dns_crg-gg_dng_crg &
!!                          -gi_dni_crg & !--- Y.Sato (2018/8/31)
                           +crg_split_g
 
             clm_dnc_crg = gc_dnc_crg+sc_dnc_crg+ic_dnc_crg
             clm_dnr_crg = (rg_dnr_crg+rs_dnr_crg+ri_dnr_crg) * sw
             clm_dni_crg = ri_dni_crg+ii_dni_crg+is_dni_crg  !!&
!!                        + gi_dni_crg  !Y.Sato (2018/8/31)
             clm_dns_crg = rs_dns_crg+gs_dns_crg+ss_dns_crg
             clm_dng_crg = gg_dng_crg+rg_dng_crg*(1.0_rp-sw)
 
             pco_dni_crg = dt*pcrg1(k,i_nicon)
             pco_dns_crg = dt*pcrg1(k,i_nscon)
             !--- limiter
             sw1 = min( abs(rhoq_crg(k,i_qi)+clp_dni_crg  ),abs(pco_dni_crg) )
             pco_dni_crg = sign( sw1,pco_dni_crg )
             sw1 = min( abs(rhoq_crg(k,i_qs)+clp_dns_crg  ),abs(pco_dns_crg) )
             pco_dns_crg = sign( sw1,pco_dns_crg )
             pco_dng_crg = -pco_dni_crg-pco_dns_crg
 
             eml_dni_crg =  dt*pcrg1(k,i_niacm)   ! I+C->C
             eml_dns_crg =  dt*pcrg1(k,i_nsacm)   ! S+C->R
             eml_dng_crg =  dt*(pcrg1(k,i_ngacm)+pcrg1(k,i_ngarm)+pcrg1(k,i_nsarm)+pcrg1(k,i_niarm)) ! G+R->R, G+C->R
             !--- limiter
             sw1 = min( abs(rhoq_crg(k,i_qi)+clp_dni_crg+clm_dni_crg+pco_dni_crg  ),abs(eml_dni_crg) )
             eml_dni_crg = sign( sw1,eml_dni_crg )
             sw1 = min( abs(rhoq_crg(k,i_qs)+clp_dns_crg+clm_dns_crg+pco_dns_crg  ),abs(eml_dns_crg) )
             eml_dns_crg = sign( sw1,eml_dns_crg )
             sw1 = min( abs(rhoq_crg(k,i_qg)+clp_dng_crg+clm_dng_crg+pco_dng_crg  ),abs(eml_dng_crg) )
             eml_dng_crg = sign( sw1,eml_dng_crg )
 
             eml_dnc_crg = -eml_dni_crg
             eml_dnr_crg = -eml_dns_crg-eml_dng_crg
 
             spl_dns_crg = dt*pcrg1(k,i_nsspl)*fac9(k)
             spl_dng_crg = dt*pcrg1(k,i_ngspl)*fac9(k)
             !--- limiter
             sw1 = min( abs(rhoq_crg(k,i_qs)+clp_dns_crg+pco_dns_crg+eml_dns_crg  ),abs(spl_dns_crg) )
             spl_dns_crg = sign( sw1,spl_dns_crg )
             sw1 = min( abs(rhoq_crg(k,i_qg)+clp_dng_crg+pco_dng_crg+eml_dng_crg  ),abs(spl_dng_crg) )
             spl_dng_crg = sign( sw1,spl_dng_crg )
             spl_dni_crg = -spl_dns_crg-spl_dng_crg
 
             drhoqcrg_c = wrm_dnc_crg + ( clp_dnc_crg + clm_dnc_crg + eml_dnc_crg ) * fact(k)
             drhoqcrg_r = wrm_dnr_crg + ( clp_dnr_crg + clm_dnr_crg + eml_dnr_crg ) * fact(k)
             drhoqcrg_i = ( clp_dni_crg + clm_dni_crg + eml_dni_crg ) * fact(k) + pco_dni_crg + spl_dni_crg
             drhoqcrg_s = ( clp_dns_crg + clm_dns_crg + eml_dns_crg ) * fact(k) + pco_dns_crg + spl_dns_crg
             drhoqcrg_g = ( clp_dng_crg + clm_dng_crg + eml_dng_crg ) * fact(k) + pco_dng_crg + spl_dng_crg
 
             rhoqcrg0_t(k,i_qc) = drhoqcrg_c / dt
             rhoqcrg0_t(k,i_qr) = drhoqcrg_r / dt
             rhoqcrg0_t(k,i_qi) = drhoqcrg_i / dt
             rhoqcrg0_t(k,i_qs) = drhoqcrg_s / dt
             rhoqcrg0_t(k,i_qg) = drhoqcrg_g / dt
          end do
 
 
          do iq = i_qc, i_qg
          do k = ks, ke
             rhoq_crg(k,iq) = rhoq_crg(k,iq) + rhoqcrg0_t(k,iq) * dt  !-- need limiter?
          enddo
          enddo
 
          do iq = i_qc, i_ng
          do k = ks, ke
             qtrc0(k,iq) = rhoq(k,iq) / dens(k,i,j)
          enddo
          enddo
          call cross_section( ka, ks, ke,  & ! [IN]
                              qa_mp,       & ! [IN]
                              qtrc0(:,:),  & ! [IN]
                              dens(:,i,j), & ! [IN]
                              crs(:,:)     ) ! [OUT]
 
          do k = ks, ke
             sarea(k,i,j,i_mp_qc) = crs(k,i_mp_qc)
             sarea(k,i,j,i_mp_qr) = crs(k,i_mp_qr)
             sarea(k,i,j,i_mp_qi) = crs(k,i_mp_qi)
             sarea(k,i,j,i_mp_qs) = crs(k,i_mp_qs)
             sarea(k,i,j,i_mp_qg) = crs(k,i_mp_qg)
          enddo
 
          do iq = i_qc, i_qg
          do k = ks, ke
             rhoqcrg_t_mp(k,i,j,iq-1) = ( rhoq_crg(k,iq) - dens(k,i,j)*qtrc_crg(k,i,j,iq-1) ) / dt
          enddo
          enddo
 
       end if
 
#ifdef DEBUG
       call debug_tem( ka, ks, ke, &
            4, i, j, temp(:), dens(:,i,j), pres(:), qtrc(:,i,j,i_qv) )
#endif
 
    end do
    end do
 
    do ip = 1, w_nmax
       if ( hist_sw(ip) ) call file_history_put( hist_id(ip), w3d(:,:,:,hist_idx(ip)) )
    enddo
 
    return
  end subroutine mp_sn14
 
  !-----------------------------------------------------------------------------
!OCL SERIAL
  subroutine debug_tem( &
       KA, KS, KE, &
       point, i, j, &
       tem, rho, pre, qv )
    use scale_prc, only: &
       prc_myrank
    implicit none
    integer, intent(in) :: KA, KS, KE
 
    integer,  intent(in) :: point
    integer,  intent(in) :: i, j
    real(RP), intent(in) :: tem(KA)
    real(RP), intent(in) :: rho(KA)
    real(RP), intent(in) :: pre(KA)
    real(RP), intent(in) :: qv (KA)
 
    integer :: k
    !---------------------------------------------------------------------------
 
    do k = ks, ke
       if (      tem(k) < tem_min &
            .OR. rho(k) < rho_min &
            .OR. pre(k) < 1.0_rp    ) then
 
          log_info("ATMOS_PHY_MP_SN14_debug_tem_kij",'(A,I3,A,4(F16.5),3(I6))') &
          "point: ", point, " low tem,rho,pre:", tem(k), rho(k), pre(k), qv(k), k, i, j, prc_myrank
       endif
    enddo
 
    return
  end subroutine debug_tem
 
!OCL SERIAL
  subroutine nucleation( &
       KA, KS, KE, &
       cz, fz, w,                 &
       rho, tem, pre, qdry,       &
       rhoq, cpa, cva,            &
       dTdt_rad,                  &
       qke,                       &
       CCN, nc_uplim_d,           &
       dt,                        &
       dq_xa, vt_xa,              &
       PQ                         )
    use scale_prc, only: &
       prc_abort
    use scale_atmos_saturation, only: &
       moist_psat_liq       => atmos_saturation_psat_liq, &
       moist_psat_ice       => atmos_saturation_psat_ice,   &
       moist_pres2qsat_liq  => atmos_saturation_pres2qsat_liq, &
       moist_pres2qsat_ice  => atmos_saturation_pres2qsat_ice,   &
       moist_dqsi_dtem_dens => atmos_saturation_dqs_dtem_dens_liq, &
       moist_dqs_dtem_dpre_ice => atmos_saturation_dqs_dtem_dpre_ice
    use scale_atmos_hydrometeor, only: &
       cv_vapor, &
       cv_ice
    implicit none
 
    integer, intent(in) :: KA, KS, KE
 
    real(RP), intent(in)  :: cz(  KA)
    real(RP), intent(in)  :: fz(0:KA)
    real(RP), intent(in)  :: w   (KA)    ! w of full level
    real(RP), intent(in)  :: rho (KA)
    real(RP), intent(in)  :: tem (KA)
    real(RP), intent(in)  :: pre (KA)
    real(RP), intent(in)  :: qdry(KA)
    !
    real(RP), intent(in)  :: rhoq(KA,I_QV:I_NG)
    !
    real(RP), intent(in) ::  cpa(KA)
    real(RP), intent(in) :: dTdt_rad(KA)
    real(RP), intent(in) :: qke(KA)
    real(RP), intent(in) :: dt
    real(RP), intent(in) :: CCN(KA)
    real(RP), intent(in) :: nc_uplim_d
    !
    real(RP), intent(out) :: PQ(KA,PQ_MAX)
    !
    !
!    real(RP) :: c_ccn_map(1)   ! c_ccn horizontal distribution
!    real(RP) :: kappa_map(1)   ! kappa horizontal distribution
!    real(RP) :: c_in_map(1)    ! c_in  horizontal distribution ! [Add] 11/08/30 T.Mitsui
    real(RP) :: esw(KA)       ! saturation vapor pressure, water
    real(RP) :: esi(KA)       !                            ice
    real(RP) :: ssw(KA)       ! super saturation (water)
    real(RP) :: ssi(KA)       ! super saturation (ice)
!    real(RP) :: w_dsswdz(KA)  ! w*(d_ssw/ d_z) super saturation(water) flux
    real(RP) :: w_dssidz(KA)  ! w*(d_ssi/ d_z), 09/04/14 T.Mitsui
!    real(RP) :: ssw_below(KA) ! ssw(k-1)
    real(RP) :: ssi_below(KA) ! ssi(k-1), 09/04/14 T.Mitsui
    real(RP) :: z_below(KA)   ! z(k-1)
    real(RP) :: dzh           ! z(k)-z(k-1)
    real(RP) :: pv            ! vapor pressure
    ! work variables for Twomey Equation.
    real(RP) :: qsw(KA)
    real(RP) :: qsi(KA)
    real(RP) :: dqsidtem_rho(KA)
    real(RP) :: dssidt_rad(KA)
    real(RP) :: wssi, wdssi
    !
 
    real(RP) :: cva(KA)
    real(RP) :: dq_xa(KA,HYDRO_MAX)
    real(RP) :: vt_xa(KA,HYDRO_MAX,2) ! terminal velocity
    real(RP) :: dTdt_dep(KA)
    real(RP) :: PLIdep_total(KA)
    real(RP) :: wtem(KA)         ! temperature[K]
    real(RP) :: dqsidpre_tem(KA)
    real(RP) :: dqsidtem_pre(KA)
    real(RP) :: dssidt
    real(RP) :: dssidt_mp(KA)
    real(RP) :: dssidt_dyn(KA)
    !!
 
 
!    real(RP) :: xi_nuc(1)    ! xi use the value @ cloud base
!    real(RP) :: alpha_nuc(1) ! alpha_nuc
!    real(RP) :: eta_nuc(1)   ! xi use the value @ cloud base
    !
    real(RP) :: sigma_w(KA)
    real(RP) :: weff(KA)
    real(RP) :: weff_max(KA)
    real(RP) :: velz(KA)
    !
    real(RP) :: coef_ccn
    real(RP) :: slope_ccn
    real(RP) :: nc_new(KA)
    real(RP) :: nc_new_below(KA)
    real(RP) :: dnc_new
    real(RP) :: nc_new_max   ! Lohmann (2002),
    real(RP) :: a_max
    real(RP) :: b_max
    logical :: flag_nucleation(KA)
    !
    real(RP) :: r_gravity
    real(RP), parameter :: r_sqrt3=0.577350269_rp ! = sqrt(1.0/3.0)
    real(RP), parameter :: eps=1.e-30_rp
    !====> ! 09/08/18
    !
    real(RP) :: dlcdt_max, dli_max ! defined by supersaturation
    real(RP) :: dncdt_max, dni_max ! defined by supersaturation
    real(RP) :: rdt
 
    real(RP) :: tmp
    !
    integer :: k
    !
    !
 
    if( so22_het ) then
       do k = ks, ke
          ! Temperature lower limit is only used for saturation condition.
          ! On the other hand original "tem" is used for calculation of latent heat or energy equation.
          wtem(k)  = max( tem(k), tem_min )
       end do
    endif
 
 
!    c_ccn_map(1) = c_ccn
!    kappa_map(1) = kappa
!    c_in_map(1)  = c_in
    !
    !
    rdt            = 1.0_rp/dt
    r_gravity      = 1.0_rp/grav
    !
    call moist_psat_liq      ( ka, ks, ke, &
                              tem(:), esw(:) ) ! [IN], [OUT]
    call moist_psat_ice      ( ka, ks, ke, &
                              tem(:), esi(:) ) ! [IN], [OUT]
    call moist_pres2qsat_liq ( ka, ks, ke, &
                              tem(:), pre(:), qdry(:), & ! [IN]
                              qsw(:)                   ) ! [OUT]
    call moist_pres2qsat_ice ( ka, ks, ke, &
                              tem(:), pre(:), qdry(:), & ! [IN]
                              qsi(:)                   ) ! [OUT]
    call moist_dqsi_dtem_dens( ka, ks, ke, &
                               tem(:), rho(:), & ! [IN]
                               dqsidtem_rho(:) ) ! [OUT]
 
    if( so22_het ) then
       call moist_dqs_dtem_dpre_ice( ka, ks, ke, &
                                     wtem(:), pre(:), qdry(:),        & ! [IN]
                                     dqsidtem_pre(:), dqsidpre_tem(:) ) ! [OUT]
    endif
    !!
 
 
    !
    ! Lohmann (2002),JAS, eq.(1) but changing unit [cm-3] => [m-3]
    a_max = 1.e+6_rp*0.1_rp*(1.e-6_rp)**1.27_rp
    b_max = 1.27_rp
    !
    ssi_max = 1.0_rp
 
    do k = ks, ke
       pv     = rhoq(k,i_qv)*rvap*tem(k)
       ssw(k) = min( mp_ssw_lim, ( pv/esw(k)-1.0_rp ) )*100.0_rp
       ssi(k) = ( pv/esi(k) - 1.00_rp )
!       ssw_below(k+1) = ssw(k)
       ssi_below(k+1) = ssi(k)
       z_below(k+1)   = cz(k)
    end do
!    ssw_below(KS) = ssw(KS)
    ssi_below(ks) = ssi(ks)
    z_below(ks)   = cz(ks-1)
 
    ! dS/dz is evaluated by first order upstream difference
    !***  Solution for Twomey Equation ***
!    coef_ccn  = 1.E+6_RP*0.88_RP*(c_ccn_map(1)*1.E-6_RP)**(2.0_RP/(kappa_map(1) + 2.0_RP)) * &
    coef_ccn  = 1.e+6_rp*0.88_rp*(c_ccn*1.e-6_rp)**(2.0_rp/(kappa + 2.0_rp)) &
!           * (70.0_RP)**(kappa_map(1)/(kappa_map(1) + 2.0_RP))
            * (70.0_rp)**(kappa/(kappa + 2.0_rp))
!    slope_ccn = 1.5_RP*kappa_map(1)/(kappa_map(1) + 2.0_RP)
    slope_ccn = 1.5_rp*kappa/(kappa + 2.0_rp)
    !
    do k=ks, ke
       sigma_w(k) = r_sqrt3*sqrt(max(qke(k),qke_min))
    end do
    sigma_w(ks-1) = sigma_w(ks)
    sigma_w(ke+1) = sigma_w(ke)
    ! effective vertical velocity
    do k=ks, ke
       weff(k) = w(k) - cpa(k)*r_gravity*dtdt_rad(k)
    end do
    !
    if( mp_couple_aerosol ) then
 
       do k = ks, ke
          if( ssw(k) > 1.e-10_rp .AND. pre(k) > 300.e+2_rp ) then
             nc_new(k) = max( ccn(k), c_ccn )
          else
             nc_new(k) = 0.0_rp
          endif
       enddo
 
    else
 
       if( nucl_twomey ) then
          ! diagnose cloud condensation nuclei
          do k = ks, ke
             ! effective vertical velocity (maximum vertical velocity in turbulent flow)
             weff_max(k) = weff(k) + sigma_w(k)
             ! large scale upward motion region and saturated
             if( (weff(k) > 1.e-8_rp) .AND. (ssw(k) > 1.e-10_rp)  .AND. pre(k) > 300.e+2_rp )then
                ! Lohmann (2002), eq.(1)
                nc_new_max   = coef_ccn*weff_max(k)**slope_ccn
                nc_new(k) = a_max*nc_new_max**b_max
             else
                nc_new(k) = 0.0_rp
             end if
          end do
 
       else
          ! calculate cloud condensation nuclei
          do k = ks, ke
             if( ssw(k) > 1.e-10_rp .AND. pre(k) > 300.e+2_rp ) then
                nc_new(k) = c_ccn*ssw(k)**kappa
             else
                nc_new(k) = 0.0_rp
             endif
          enddo
      endif
 
    endif
 
    do k = ks, ke
       ! nc_new is bound by upper limit
       if( nc_new(k) > nc_uplim_d ) then ! no more CCN
          flag_nucleation(k) = .false.
          nc_new_below(k+1)  = 1.e+30_rp
       else if( nc_new(k) > eps ) then ! nucleation can occur
          flag_nucleation(k) = .true.
          nc_new_below(k+1)  = nc_new(k)
       else ! nucleation cannot occur(unsaturated or negative w)
          flag_nucleation(k) = .false.
          nc_new_below(k+1)  = 0.0_rp
       end if
    end do
    nc_new_below(ks) = 0.0_rp
!    do k=KS, KE
        ! search maximum value of nc_new
!       if(  ( nc_new(k) < nc_new_below(k) ) .OR. &
!            ( nc_new_below(k) > c_ccn_map(1)*0.05_RP ) )then ! 5% of c_ccn
!            ( nc_new_below(k) > c_ccn*0.05_RP ) )then ! 5% of c_ccn
!          flag_nucleation(k) = .false.
!       end if
!    end do
 
    if( mp_couple_aerosol ) then
       do k = ks, ke
          ! nucleation occurs at only cloud base.
          ! if CCN is more than below parcel, nucleation newly occurs
          ! effective vertical velocity
          if ( flag_nucleation(k) .AND. & ! large scale upward motion region and saturated
               tem(k) > tem_ccn_low ) then
             dlcdt_max     = ( rhoq(k,i_qv) - esw(k) / ( rvap * tem(k) ) ) * rdt
             dlcdt_max     = max( dlcdt_max, 0.0_rp ) ! dlcdt_max can be artificially negative due to truncation error in floating point operation
             dncdt_max     = dlcdt_max/xc_min
!             dnc_new       = nc_new(k)-rhoq(k,I_NC)
             dnc_new       = nc_new(k)
             pq(k,i_ncccn) = min( dncdt_max, dnc_new*rdt )
             pq(k,i_lcccn) = min( dlcdt_max, xc_min*pq(k,i_ncccn) )
          else
             pq(k,i_ncccn) = 0.0_rp
             pq(k,i_lcccn) = 0.0_rp
          end if
       end do
    else
 
       if( nucl_twomey ) then
          do k = ks, ke
             ! nucleation occurs at only cloud base.
             ! if CCN is more than below parcel, nucleation newly occurs
             ! effective vertical velocity
             if ( flag_nucleation(k) .AND. & ! large scale upward motion region and saturated
                  tem(k) > tem_ccn_low .AND. &
                  nc_new(k) > rhoq(k,i_nc) ) then
                dlcdt_max     = ( rhoq(k,i_qv) - esw(k) / ( rvap * tem(k) ) ) * rdt
                dlcdt_max     = max( dlcdt_max, 0.0_rp ) ! dlcdt_max can be artificially negative due to truncation error in floating point operation
                dncdt_max     = dlcdt_max/xc_min
                dnc_new       = nc_new(k)-rhoq(k,i_nc)
                pq(k,i_ncccn) = min( dncdt_max, dnc_new*rdt )
                pq(k,i_lcccn) = min( dlcdt_max, xc_min*pq(k,i_ncccn) )
             else
                pq(k,i_ncccn) = 0.0_rp
                pq(k,i_lcccn) = 0.0_rp
             end if
          end do
       else
          do k = ks, ke
             ! effective vertical velocity
             if(  tem(k) > tem_ccn_low .AND. &
                  nc_new(k) > rhoq(k,i_nc) ) then
                dlcdt_max     = ( rhoq(k,i_qv) - esw(k) / ( rvap * tem(k) ) ) * rdt
                dlcdt_max     = max( dlcdt_max, 0.0_rp ) ! dlcdt_max can be artificially negative due to truncation error in floating point operation
                dncdt_max     = dlcdt_max/xc_min
                dnc_new       = nc_new(k)-rhoq(k,i_nc)
                pq(k,i_ncccn) = min( dncdt_max, dnc_new*rdt )
                pq(k,i_lcccn) = min( dlcdt_max, xc_min*pq(k,i_ncccn) )
             else
                pq(k,i_ncccn) = 0.0_rp
                pq(k,i_lcccn) = 0.0_rp
             end if
          end do
       endif
 
    endif
 
    !
    ! ice nucleation
    !
    ! +++ NOTE ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    ! Based on Phillips etal.(2006).
    ! However this approach doesn't diagnose Ni itself but diagnose tendency.
    ! Original approach adjust Ni instantaneously .
    ! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
    if( so22_het .or. opt_nucleation_ice_hom ) then
       call dep_vapor_ice_wrk(         & ! in
            ka, ks, ke,                & ! in
            plidep_total(:),           & ! out for ice nucleation
            rho(:), tem(:), pre(:),    & ! in
            qdry(:), esi(:), qsi(:),   & ! in
            rhoq(:,:),                 & ! in
            vt_xa, dq_xa,              & ! in
            dt                         ) ! in
 
       do k = ks, ke
          dtdt_dep(k) = (lhs0+(cv_vapor-cv_ice)*tem(k))*plidep_total(k)/(rho(k)*cva(k))
       enddo
    else
       dtdt_dep(:) = 0.0_rp
    endif
 
    do k = ks, ke-1
       velz(k)           = ( w(k) * ( cz(k+1) - fz(k) ) + w(k+1) * ( fz(k) - cz(k) ) ) / ( cz(k+1) - cz(k) ) ! @ half level
    end do
    velz(ke) = 0.0_rp
    do k = ks, ke
       dzh           = cz(k) - z_below(k)
       w_dssidz(k)   = velz(k) * (ssi(k) - ssi_below(k))/dzh
       dssidt_rad(k) = -rhoq(k,i_qv)/(rho(k)*qsi(k)*qsi(k))*dqsidtem_rho(k)*dtdt_rad(k)
       dli_max       = ( rhoq(k,i_qv) - esi(k) / ( rvap * tem(k) ) ) * rdt
       dli_max       = max( dli_max, 0.0_rp ) ! dli_max can be artificially negative due to truncation error in floating point operation
       dni_max       = min( dli_max/xi_ccn, (in_max-rhoq(k,i_ni))*rdt )
       wdssi         = min( w_dssidz(k)+dssidt_rad(k), 0.01_rp)
       wssi          = min( ssi(k), ssi_max)
 
       !! Seiki and Ohno 2022
       if( so22_het ) then
          dssidt_mp(k)  = -plidep_total(k)/(rho(k)*qsi(k))
          !!  PLIdep(k) -> PQ(k,I_LIdep)
          dssidt_rad(k) = -rhoq(k,i_qv)/(rho(k)*qsi(k)*qsi(k))*dqsidtem_rho(k)*dtdt_rad(k)
          !!
          dssidt_dyn(k) = +rhoq(k,i_qv)/(rho(k)*qsi(k)*qsi(k))&
               * velz(k)*grav*(dqsidtem_pre(k)/cpa(k)+dqsidpre_tem(k)*rho(k))
          !    * w(k)*CNST_GRAV*(dqsidtem_pre(ij,k)/cpa(ij,k)+dqsidpre_tem(ij,k)*rho(ij,k))
          dssidt        = dssidt_mp(k) + dssidt_rad(k) + dssidt_dyn(k)
       endif
 
       ! SB06(34),(35)
!#       if(  ( wdssi       > eps         ) .AND. & !
!#            (tem(k)       < 273.15_RP   ) .AND. & !
!#            (rhoq(k,I_NI) < in_max      ) .AND. &
!#            (wssi      >= eps       ) )then   !
!#          tmp = c_in * nm_M92 * exp( 0.3_RP * bm_M92 * ( wssi - 0.1_RP ) )
!#          if( inucl_w ) then
!#             tmp = bm_M92 * 0.3_RP * tmp * wdssi
!#          else
!#             tmp = max( tmp - rhoq(k,I_NI), 0.0_RP ) * rdt
!#          endif
!#          PQ(k,I_NIccn) = min(dni_max, tmp)
!#          PQ(k,I_LIccn) = min(dli_max, PQ(k,I_NIccn)*xi_ccn )
!#       else
!#          PQ(k,I_NIccn) = 0.0_RP
!#          PQ(k,I_LIccn) = 0.0_RP
!#       end if
       if(  (tem(k)     < 273.15_rp   ) .AND. & !
            (rhoq(k,i_ni) < in_max      ) .AND. &
            (wssi        >= eps       ) )then   !
          tmp = c_in * nm_m92 * exp( 0.3_rp * bm_m92 * ( wssi - 0.1_rp ) )
          if( inucl_w .and. wdssi > eps ) then
             tmp = bm_m92 * 0.3_rp * tmp * wdssi
          elseif( so22_het .and. dssidt > eps ) then
             tmp = bm_m92 * 0.3_rp * tmp * dssidt
          else
             tmp = max( tmp - rhoq(k,i_ni), 0.0_rp ) * rdt
          endif
          pq(k,i_niccn) = min(dni_max, tmp)
          pq(k,i_liccn) = min(dli_max, pq(k,i_niccn)*xi_ccn )
       else
          pq(k,i_niccn) = 0.0_rp
          pq(k,i_liccn) = 0.0_rp
       end if
 
 
    end do
 
    if( opt_nucleation_ice_hom ) then
       call nucleation_ice_hom(   &
            ka, ks, ke,           & !in
            tem, pre, rho,        & !in
            qdry, rhoq(:,i_qv),   & !in
            cva, cpa,             & !in
            w,                    & !in
            dtdt_rad,             & !in
            dtdt_dep,             & !in
            plidep_total, dt,     & !in
            pq(:,i_lihom),        & !out
            pq(:,i_nihom)         ) !out
    else
       pq(:,i_lihom) = 0.0_rp
       pq(:,i_nihom) = 0.0_rp
    endif
 
 
    return
  end subroutine nucleation
  !----------------------------
 
!OCL SERIAL
  subroutine nucleation_ice_hom(  &
       KA, KS, KE,                &
       tem, pre, rho,             &
       qd, rhoq_qv, cva, cpa,     &
       w, dTdt_rad, dTdt_dep,     &
       PLIdep, dt, PLIhom, PNIhom )
    use scale_prc, only: &
         prc_abort
    use scale_const, only: &
         psat0  => const_psat0,  &
         t00    => const_tem00,  &
         pstd   => const_pstd,   &
         cpvap  => const_cpvap,  &
         cvvap  => const_cvvap,  &
         ci     => const_ci,     &
         cl     => const_cl,     &
         rvap   => const_rvap,   &
         rdry   => const_rdry,   &
         lhs00  => const_lhs00,  &
         lhs0   => const_lhs0,   &
         lhv00  => const_lhv00,  &
         lhf00  => const_lhf00,  &
         epsvap => const_epsvap, &
         grav   => const_grav,   &
         pi     => const_pi
    implicit none
 
    integer, intent(in)  :: KA, KS, KE
 
    real(RP), intent(in) :: tem(KA)
    real(RP), intent(in) :: pre(KA)
    real(RP), intent(in) :: rho(KA)
    real(RP), intent(in) :: qd(KA)
    real(RP), intent(in) :: rhoq_qv(KA)
    real(RP), intent(in) :: cpa(KA)        ! specific heat @ cnst. pressure
    real(RP), intent(in) :: cva(KA)        ! specific heat @ cnst. volume
    ! balance equation @ homogeneous ice nucleation
    real(RP), intent(in) :: w(KA)          ! adiabatic ascending
    real(RP), intent(in) :: dTdt_rad(KA)  ! effect of radiative heating
    real(RP), intent(in) :: dTdt_dep(KA)  ! effect of radiative heating
    real(RP), intent(in) :: PLIdep(KA)
!    real(RP), intent(out) :: PQ(KA,PQ_MAX)     ! competition effect by vapor consumption
    real(RP), intent(out):: PLIhom(KA)
    real(RP), intent(out):: PNIhom(KA)
    real(RP), intent(in) :: dt
    real(RP), parameter :: rhoi=916.0_rp           ! ice density [kg/m3]
    real(RP), parameter :: rrhoi=1.0_rp/rhoi       !
    real(RP), parameter :: Mw=18.01528_rp         ! Water Molar Weight
    real(RP), parameter :: Nav=6.0221415e+23_rp      ! Avogadro Number
    real(RP), parameter :: vw=(mw*1.e-3_rp/nav)/rhoi ! volume of a water molecule in ice phase
    !                     18nm*exp( 3.0*log(1.5)**2 )=29.4760367
    real(RP), parameter :: r0=29.5e-9_rp          ! aerosol mass(volume) mode radius
    real(RP), parameter :: c_gf =  1.01187_rp     ! dAlmeida
    real(RP), parameter :: g_gf = -0.206449_rp    ! dAlmeida
    real(RP), parameter :: rho_min=1.e-5_rp         ! 3.e-3 is lower limit recognized in many experiments.
    real(RP), parameter :: tem_min=150.0_rp
    real(RP), parameter :: ni_max =300.e+6_rp
!    real(RP) :: dTdt_dep(KA)  ! effect of deposition heating
    real(RP) :: wtem
    real(RP) :: esi, esw
    real(RP) :: qsi
    real(RP) :: lhs
    real(RP) :: dqsidtem
    real(RP) :: den1, den2
    real(RP) :: dqsidt_pre
    real(RP) :: dqsidp_tem
    real(RP) :: rw
    real(RP) :: temc_lim
    real(RP) :: rho_lim
    real(RP) :: pre_lim
    real(RP) :: Dw
    real(RP) :: si, sw
    real(RP) :: Scr
    real(RP) :: dsidt_mp
    real(RP) :: dsidt_rd
    real(RP) :: wp
    real(RP) :: a1,a2,a3
    real(RP) :: b1,b2
    real(RP) :: dlogJdT
    real(RP) :: dtemdt_dyn
    real(RP) :: rtau ! 1/tau
    real(RP) :: delta
    real(RP) :: kappa
    real(RP) :: Rim_w
    real(RP) :: ri_wrk
    real(RP) :: ri
    !
    real(RP), parameter :: r2pi    = 0.5_rp/pi ! 1/2pi
    real(RP), parameter :: sqrt_pi = sqrt(pi)
    real(RP), parameter :: coef_mi = 4.0_rp/3.0_rp*pi*rhoi
    real(RP), parameter :: eps     = 1.e-30_rp
    real(RP) :: rdt
    integer :: ierr
    integer :: ij,k
    !
 
    rdt     = 1.0_rp/dt
    plihom(:)     = 0.0_rp
    pnihom(:)     = 0.0_rp
!    PQ(:,I_NIhom)     = 0.0_RP
!    PQ(:,I_LIhom)     = 0.0_RP
!    PQ(1:KS,I_NIhom)     = 0.0_RP
!    PQ(1:KS,I_LIhom)     = 0.0_RP
!    PQ(KE:KA,I_NIhom)     = 0.0_RP
!    PQ(KE:KA,I_LIhom)     = 0.0_RP
    do k = ks, ke
          wtem= max(tem(k), tem_min)
          esi = min( psat0 &
               * ( wtem / t00 ) ** ( ( cpvap - ci ) / rvap ) &
               * exp( lhs00 / rvap &
               * ( 1.0_rp / t00 - 1.0_rp / wtem ) ), pre(k))
          esw = psat0 &
               * ( wtem / t00 ) ** ( ( cpvap - cl ) / rvap ) &
               * exp( lhv00 / rvap &
               * ( 1.0_rp / t00 - 1.0_rp / wtem ) )
          ! (10) in Ren and MacKenzie (2005)
          scr       = 2.349_rp - wtem/259.0_rp
          qsi       = epsvap * esi / ( pre(k) - ( 1.0_rp - epsvap ) * esi )
          si        = rhoq_qv(k)*rvap*wtem/esi ! rho(k)*qv(k)
          ! sw must be less than 1 to calculate hygroscopic growth (otherwise, already activated)
          sw        = min(rho(k)*rhoq_qv(k)*rvap*wtem/esw,0.999_rp)
          if ( si < scr ) then
             ! No nucleation occurs
             qsi       = 0.0_rp
             lhs       = lhs00 + (cpvap - ci )*(wtem-t00)
             dqsidtem  = 0.0_rp
             si        = 0.0_rp
             sw        = 0.0_rp
             scr       = 100.0_rp
             a1        = 0.0_rp
             wp        = -1.0_rp
             rtau      = -1.0_rp
          else
             ! (dsi/dt)_MP
             lhs       = lhs0 + (cpvap - ci)*(wtem-t00)
             dqsidtem  = esi/(rho(k)*rvap*wtem*wtem)&
                  * (lhs/(rvap*wtem)-1.0_rp)
             dsidt_mp  = -1.0_rp/(rho(k)*qsi) &
                  * (1.0_rp+si*(lhv00+lhf00+(cvvap-ci)*wtem)/cva(k)*dqsidtem)&
                  * plidep(k)
             dsidt_rd  = -si/qsi*dqsidtem*dtdt_rad(k)
             ! This is an simple formulation from original paper
             a1        = lhs0*grav/(cpa(k)*rvap*tem(k)*tem(k))&
                  - grav/(rdry*tem(k))
!!$          ! alternative formulation for NICAM-EXACT
!!$          den1      = (pre(k)-(1.0_RP-EPSvap)*esi)*(pre(k)-(1.0_RP-EPSvap)*esi)
!!$          den2      = den1*Rvap*wtem*wtem
!!$          dqsidp_tem=-EPSvap*              esi/den1
!!$          dqsidt_pre= EPSvap*pre(k)*lhs*esi/den2
!!$          a1        = GRAV/qsi*(dqsidt_pre/cpa(k)+dqsidp_tem*rho(k))
             wp        = w(k) + 1.0_rp/(a1*si)*(dsidt_mp+dsidt_rd)
             ! (21) in RM05
             dlogjdt   = -0.004_rp*wtem*wtem + 2.0_rp*wtem - 304.4_rp
             ! (22) in RM05
             dtemdt_dyn= - grav*w(k)/cpa(k)
             rtau      =  dlogjdt*(dtdt_rad(k)+dtdt_dep(k)+dtemdt_dyn )
          endif
          rw = r0*c_gf*(1-sw)**g_gf
 
          if ( wp > eps .AND. rtau > eps ) then
             ! a1,a2,a3,b1,b2 are given by Appendix B in RM05
             temc_lim= max(tem(k)-t00, temc_lim_diff )
             rho_lim = max(rho(k),rho_min)             !
             pre_lim = rho_lim*(qd(k)*rdry + rhoq_qv(k)*rvap)*(temc_lim+t00)! only for Dw
             dw      = 0.211e-4_rp* (((temc_lim+t00)/t00)**1.94_rp) *(pstd/pre_lim)
             ! v_th = sqrt(8*Rv*T/pi) in the paragraph after eq(2) in Karcher etal.(2006)
             b2      = 0.5_rp/dw*sqrt(rvap*wtem*r2pi)
             b1      = (si-1.0_rp)*0.5_rp*rrhoi*esi/sqrt(2.0_rp*pi*rvap*wtem)
             a2      = mw*rvap*wtem/(nav*esi)
             a3      = epsvap*mw*lhs0*lhs0/(nav*cpa(k)*pre(k)*wtem)
             delta   = b2*rw
             kappa   = 2.0_rp*b1*b2/( rtau*(1.0_rp+delta)*(1.0_rp+delta) )
             ! (A9) in RM05
             rim_w   = max(1.e-20_rp, 0.5_rp*(1.0_rp+delta)*(3.0_rp*kappa/(2.0_rp+sqrt(1.0_rp+9.0_rp/pi*kappa))) &
                  +                1.0_rp/(1.0_rp+delta)*(3.0_rp      /(2.0_rp+sqrt(1.0_rp+9.0_rp/pi*kappa)))+delta-1.0_rp )
             pnihom(k)  = min( scr/(scr-1.0_rp)*a1*wp/(rim_w*4.0_rp*pi*dw/b2), ni_max )* rdt
             ri_wrk        = 1.0_rp+b2*rw
             ri            = ( sqrt(ri_wrk*ri_wrk + 2.0_rp*b1*b2*dt )-1.0_rp )/b2
             plihom(k)  = coef_mi*ri*ri*ri*pnihom(k)
          else
             plihom(k)  = 0.0_rp
             pnihom(k)  = 0.0_rp
          endif
    enddo
    !
    return
  end subroutine nucleation_ice_hom
 
!OCL SERIAL
  subroutine ice_multiplication( &
    KA, KS, KE,    & ! in
    flg_lt,        & ! in
    Pac,           & ! in
    tem, rhoq,     & ! in
    rhoq_crg, xq,  & ! in
    PQ, Pcrg1      ) ! inout
 
    ! ice multiplication by splintering
    ! we consider Hallet-Mossop process
    use scale_specfunc, only: &
       gammafunc => sf_gamma
    implicit none
    integer, intent(in) :: KA, KS, KE
 
    real(RP), intent(in) :: Pac(KA,Pac_MAX)
    real(RP), intent(in) :: tem(KA)
    real(RP), intent(in) :: rhoq(KA,I_QV:I_NG)
    real(RP), intent(in) :: xq(KA,HYDRO_MAX)
    !
    real(RP), intent(inout):: PQ(KA,PQ_MAX)
    ! for lightning
    logical,  intent(in) :: flg_lt
    real(RP), intent(in) :: rhoq_crg(KA,I_QC:I_QG)
    real(RP), intent(inout):: Pcrg1(KA,PQ_MAX)
    !
    ! production of (350.d3 ice particles)/(cloud riming [g]) => 350*d6 [/kg]
    real(RP), parameter :: pice = 350.0e+6_rp
    ! production of (1 ice particle)/(250 cloud particles riming)
    real(RP), parameter :: pnc  = 250.0_rp
    ! temperature factor
    real(RP) :: fp
 
    real(RP) :: igm            ! in complete gamma(x,alpha)
    real(RP) :: x
    ! coefficient of expansion using in calculation of igm
    real(RP) :: a0,a1,a2,a3,a4,a5
    real(RP) :: a6,a7,a8,a9,a10
    real(RP) :: an1,an2,b0,b1,b2,c0,c1,c2
    real(RP) :: d0,d1,d2,e1,e2,h0,h1,h2
    real(RP), parameter :: eps=1.0e-30_rp
    ! number of cloud droplets larger than 12 micron(radius).
    real(RP) :: n12
    !
    real(RP) :: wn, wni, wns, wng
    integer :: k, iq
    real(RP) :: sw1
    !
    !
!OCL LOOP_FISSION_TARGET(LS)
    do k = ks, ke
       ! Here we assume particle temperature is same as environment temperature.
       ! If you want to treat in a better manner,
       ! you can diagnose with eq.(64) in CT(86)
       if     (tem(k) >  270.16_rp)then
          fp   = 0.0_rp
       else if(tem(k) >= 268.16_rp)then
          fp   = (270.16_rp-tem(k))*0.5_rp
       else if(tem(k) >= 265.16_rp)then
          fp   = (tem(k)-265.16_rp)*0.333333333_rp
       else
          fp   = 0.0_rp
       end if
       ! Approximation of Incomplete Gamma function
       ! Here we calculate with algorithm by Numerical Recipes.
       ! This approach is based on eq.(78) in Cotton etal.(1986),
       ! but more accurate and expanded for Generalized Gamma Distribution.
       x       = coef_lambda(i_mp_qc)*(xc_cr/xq(k,i_mp_qc))**mu(i_mp_qc)
       !
       if(x<1.e-2_rp*alpha)then        ! negligible
          igm  = 0.0_rp
       else if(x<alpha+1.0_rp)then    ! series expansion
          ! 10th-truncation is enough for cloud droplet.
          a0   = 1.0_rp/alpha         ! n=0
          a1   = a0*x/(alpha+1.0_rp)  ! n=1
          a2   = a1*x/(alpha+2.0_rp)  ! n=2
          a3   = a2*x/(alpha+3.0_rp)  ! n=3
          a4   = a3*x/(alpha+4.0_rp)  ! n=4
          a5   = a4*x/(alpha+5.0_rp)  ! n=5
          a6   = a5*x/(alpha+6.0_rp)  ! n=6
          a7   = a6*x/(alpha+7.0_rp)  ! n=7
          a8   = a7*x/(alpha+8.0_rp)  ! n=8
          a9   = a8*x/(alpha+9.0_rp)  ! n=9
          a10  = a9*x/(alpha+10.0_rp) ! n=10
          igm  = (a0+a1+a2+a3+a4+a5+a6+a7+a8+a9+a10)*exp( -x + alpha*log(x) - lgm )
       else if(x<alpha*100.0_rp) then ! continued fraction expansion
          ! 2nd-truncation is enough for cloud droplet.
          ! setup
          b0   = x+1.0_rp-alpha
          c0   = 1.0_rp/eps
          d0   = 1.0_rp/b0
          h0   = d0
          ! n=1
          an1  = -(1.0_rp-alpha)
          b1   = b0 + 2.0_rp
          d1   = 1.0_rp/(an1*d0+b1)
          c1   = b1+an1/c0
          e1   = d1*c1
          h1   = h0*e1
          ! n=2
          an2  = -2.0_rp*(2.0_rp-alpha)
          b2   = b1 + 2.0_rp
          d2   = 1.0_rp/(an2*d1+b2)
          c2   = b2+an2/c1
          e2   = d2*c2
          h2   = h1*e2
          !
          igm  = 1.0_rp - exp( -x + alpha*log(x) - lgm )*h2
       else                       ! negligible
          igm  = 1.0_rp
       end if
       ! n12 is number of cloud droplets larger than 12 micron.
       n12 = rhoq(k,i_nc)*(1.0_rp-igm)
       ! eq.(82) CT(86)
       wn            = (pice + n12/((rhoq(k,i_qc)+xc_min)*pnc) )*fp ! filtered by xc_min
       wni           = wn*(-pac(k,i_liaclc2li)  ) ! riming production rate is all negative
       wns           = wn*(-pac(k,i_lsaclc2ls)  )
       wng           = wn*(-pac(k,i_lgaclc2lg)  )
       pq(k,i_nispl) = wni+wns+wng
       !
       pq(k,i_lsspl) = - wns*xq(k,i_mp_qi) ! snow    => ice
       pq(k,i_lgspl) = - wng*xq(k,i_mp_qi) ! graupel => ice
       if (flg_lt) then
          sw1 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_ns)-small ) !--- if NC is small,ignore charge transfer
          pcrg1(k,i_nsspl) = - wns*(1.0_rp-sw1) &
                                / (rhoq(k,i_ns)+sw1)*rhoq_crg(k,i_qs)
          sw1 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_ng)-small ) !--- if NC is small,ignore charge transfer
          pcrg1(k,i_ngspl) = - wng*(1.0_rp-sw1) &
                                / (rhoq(k,i_ng)+sw1)*rhoq_crg(k,i_qg)
          pcrg1(k,i_nispl) = - ( pcrg1(k,i_nsspl) + pcrg1(k,i_ngspl) )
       end if
       !
    end do
    !
    return
  end subroutine ice_multiplication
 
  !----------------------------
!OCL SERIAL
  subroutine mixed_phase_collection( &
    ! collection process
       KA, KS, KE,            & ! in
       flg_lt,                & ! in
       d0_crg, v0_crg,        & ! in
       beta_crg, dqcrg,       & ! in
       wtem, rhoq, rhoq_crg,  & ! in
       xq, dq_xave,  vt_xave, & ! in
    !       rho                            ! [Add] 11/08/30
       PQ,                    & ! inout
       Pcrg1, Pcrg2,          & ! inout
       Pac                    ) ! out
    use scale_atmos_saturation, only: &
       moist_psat_ice => atmos_saturation_psat_ice
    implicit none
 
    integer, intent(in) :: KA, KS, KE
 
    !--- mixed-phase collection process
    !                  And all we set all production term as a negative sign to avoid confusion.
    !
    real(RP), intent(in) :: wtem(KA)
    !--- mass/number concentration[kg/m3]
    real(RP), intent(in) :: rhoq(KA,I_QV:I_NG)
    ! necessary ?
    real(RP), intent(in) :: xq(KA,HYDRO_MAX)
    !--- diameter of averaged mass( D(ave x) )
    real(RP), intent(in) :: dq_xave(KA,HYDRO_MAX)
    !--- terminal velocity of averaged mass( vt(ave x) )
    real(RP), intent(in) :: vt_xave(KA,HYDRO_MAX,2)
    ! [Add] 11/08/30 T.Mitsui, for autoconversion of ice
    !    real(RP), intent(in) :: rho(KA)
    !--- partial conversion
    real(RP), intent(inout):: PQ(KA,PQ_MAX)
    !
    real(RP), intent(out):: Pac(KA,Pac_MAX)
    !--- for lightning component
    logical,  intent(in) :: flg_lt
    real(RP), intent(in) :: beta_crg(KA)
    real(RP), intent(in) :: dqcrg(KA)
    real(RP), intent(in) :: d0_crg, v0_crg
    real(RP), intent(in) :: rhoq_crg(KA,I_QC:I_QG)
    real(RP), intent(inout):: Pcrg1(KA,PQ_MAX)
    real(RP), intent(inout):: Pcrg2(KA,Pcrg_MAX)
 
    real(RP), parameter :: a_dec = 0.883_rp
    real(RP), parameter :: b_dec = 0.093_rp
    real(RP), parameter :: c_dec = 0.00348_rp
    real(RP), parameter :: d_dec = 4.5185e-5_rp
    !
    !
    real(RP) :: tem(KA)
    !
    !--- collection efficency of each specie
    real(RP) :: E_c(KA), E_r, E_i, E_s, E_g
    real(RP) :: E_ic, E_sc, E_gc
    !--- sticking efficiency
    real(RP) :: E_stick(KA)
    ! [Add] 10/08/03 T.Mitsui
    real(RP) :: temc, temc2, temc3
    real(RP) :: E_dec
    real(RP) :: esi_rat
    real(RP) :: esi(KA)
    !
    real(RP) :: temc_p, temc_m             ! celcius tem.
!    real(RP) :: ci_aut(KA)
!    real(RP) :: taui_aut(KA)
!    real(RP) :: tau_sce(KA)
    !--- DSD averaged diameter for each species
    real(RP) :: ave_dc                     ! cloud
!    real(RP) :: ave_dr                     ! rain
    real(RP) :: ave_di(KA)                 ! ice
    real(RP) :: ave_ds(KA)                 ! snow
    real(RP) :: ave_dg                     ! graupel
    !--- coefficient of collection equations(L:mass, N:number)
    real(RP) :: coef_acc_LCI,   coef_acc_NCI   ! cloud     - cloud ice
    real(RP) :: coef_acc_LCS,   coef_acc_NCS   ! cloud     - snow
    !
    real(RP) :: coef_acc_LCG,   coef_acc_NCG   ! cloud     - graupel
    real(RP) :: coef_acc_LRI_I, coef_acc_NRI_I ! rain      - cloud ice
    real(RP) :: coef_acc_LRI_R, coef_acc_NRI_R ! rain      - cloud ice
    real(RP) :: coef_acc_LRS_S, coef_acc_NRS_S ! rain      - snow
    real(RP) :: coef_acc_LRS_R, coef_acc_NRS_R ! rain      - snow
    real(RP) :: coef_acc_LRG,   coef_acc_NRG   ! rain      - graupel
    real(RP) :: coef_acc_LII,   coef_acc_NII   ! cloud ice - cloud ice
    real(RP) :: coef_acc_LIS,   coef_acc_NIS   ! cloud ice - snow
    real(RP) ::                 coef_acc_NSS   ! snow      - snow
    real(RP) ::                 coef_acc_NGG   ! grauepl   - graupel
    real(RP) :: coef_acc_LSG,   coef_acc_NSG(KA) ! snow      - graupel
    !--- (diameter) x (diameter)
    real(RP) :: dcdc(KA), dcdi, dcds, dcdg
    real(RP) :: drdr(KA), drdi(KA), drds(KA), drdg
    real(RP) :: didi(KA), dids, didg
    real(RP) :: dsds(KA), dsdg
    real(RP) :: dgdg(KA)
    !--- (terminal velocity) x (terminal velocity)
    real(RP) :: vcvc(KA), vcvi, vcvs, vcvg
    real(RP) :: vrvr(KA), vrvi(KA), vrvs(KA), vrvg
    real(RP) :: vivi(KA), vivs, vivg
    real(RP) :: vsvs(KA), vsvg
    real(RP) :: vgvg(KA)
    !
    real(RP) :: wx_cri, wx_crs
    real(RP) :: coef_emelt
    real(RP) :: w1
 
    real(RP) :: sw, sw1, sw2
    real(RP) :: alpha_lt
    !
    integer :: k, iqw
    !
    !
    do k = ks, ke
       tem(k) = max( wtem(k), tem_min ) ! 11/08/30 T.Mitsui
    end do
 
    call moist_psat_ice( ka, ks, ke, &
                         tem(:), esi(:)  ) ! [IN], [OUT]
 
    if( opt_stick_ks96 )then
       do k = ks, ke
          ! Khain and Sednev (1996), eq.(3.15)
          temc       = tem(k) - t00
          temc2      = temc*temc
          temc3      = temc2*temc
          e_dec      = max(0.0_rp, a_dec + b_dec*temc + c_dec*temc2 + d_dec*temc3 )
          esi_rat    = rhoq(k,i_qv)*rvap*tem(k)/esi(k)
          e_stick(k) = min(1.0_rp, e_dec*esi_rat)
       end do
    else if( opt_stick_co86 )then
       do k = ks, ke
          ! [Add] 11/08/30 T.Mitsui, Cotton et al. (1986)
          temc       = min(tem(k) - t00,0.0_rp)
          w1         = 0.035_rp*temc-0.7_rp
          e_stick(k) = 10._rp**w1
       end do
    else
       do k = ks, ke
          ! Lin et al. (1983)
          temc_m     = min(tem(k) - t00,0.0_rp) ! T < 273.15
          e_stick(k) = exp(0.09_rp*temc_m)
       end do
    end if
 
    do k = ks, ke
       ! averaged diameter using SB06(82)
       ave_dc = coef_d(i_mp_qc)*xq(k,i_mp_qc)**b_m(i_mp_qc)
       !------------------------------------------------------------------------
       ! coellection efficiency are given as follows
       e_c(k) = max(0.0_rp, min(1.0_rp, (ave_dc-dc0)/(dc1-dc0) ))
    end do
 
    !------------------------------------------------------------------------
    ! Collection:  a collects b ( assuming particle size a>b )
    do k = ks, ke
       dcdc(k) = dq_xave(k,i_mp_qc) * dq_xave(k,i_mp_qc)
       drdr(k) = dq_xave(k,i_mp_qr) * dq_xave(k,i_mp_qr)
       didi(k) = dq_xave(k,i_mp_qi) * dq_xave(k,i_mp_qi)
       dsds(k) = dq_xave(k,i_mp_qs) * dq_xave(k,i_mp_qs)
       dgdg(k) = dq_xave(k,i_mp_qg) * dq_xave(k,i_mp_qg)
       drdi(k) = dq_xave(k,i_mp_qr) * dq_xave(k,i_mp_qi)
       drds(k) = dq_xave(k,i_mp_qr) * dq_xave(k,i_mp_qs)
    end do
    do k = ks, ke
       vcvc(k) = vt_xave(k,i_mp_qc,2) * vt_xave(k,i_mp_qc,2)
       vrvr(k) = vt_xave(k,i_mp_qr,2) * vt_xave(k,i_mp_qr,2)
       vivi(k) = vt_xave(k,i_mp_qi,2) * vt_xave(k,i_mp_qi,2)
       vsvs(k) = vt_xave(k,i_mp_qs,2) * vt_xave(k,i_mp_qs,2)
       vgvg(k) = vt_xave(k,i_mp_qg,2) * vt_xave(k,i_mp_qg,2)
       vrvi(k) = vt_xave(k,i_mp_qr,2) * vt_xave(k,i_mp_qi,2)
       vrvs(k) = vt_xave(k,i_mp_qr,2) * vt_xave(k,i_mp_qs,2)
    end do
 
    do k = ks, ke
       ave_di(k) = coef_d(i_mp_qi)*xq(k,i_mp_qi)**b_m(i_mp_qi)
       ave_ds(k) = coef_d(i_mp_qs)*xq(k,i_mp_qs)**b_m(i_mp_qs)
    end do
 
    !------------------------------------------------------------------------
    !
    !+++ pattern 1: a + b => a  (a>b)
    !                           (i-c, s-c, g-c, s-i, g-r, s-g)
    !------------------------------------------------------------------------
 
    ! cloud-ice => ice
    ! reduction term of cloud
    do k = ks, ke
       dcdi = dq_xave(k,i_mp_qc)   * dq_xave(k,i_mp_qi)
       vcvi = vt_xave(k,i_mp_qc,2) * vt_xave(k,i_mp_qi,2)
       sw = 0.5_rp - sign(0.5_rp, di0-ave_di(k)) ! if(ave_di>di0)then sw=1
       e_i = e_im * sw
       e_ic = e_i*e_c(k)
       coef_acc_lci = &
              ( delta_b1(i_mp_qc)*dcdc(k) + delta_ab1(i_mp_qi,i_mp_qc)*dcdi + delta_b0(i_mp_qi)*didi(k) ) &
        * sqrt( theta_b1(i_mp_qc)*vcvc(k) - theta_ab1(i_mp_qi,i_mp_qc)*vcvi + theta_b0(i_mp_qi)*vivi(k) &
            +  sigma_i + sigma_c )
       coef_acc_nci = &
              ( delta_b0(i_mp_qc)*dcdc(k) + delta_ab0(i_mp_qi,i_mp_qc)*dcdi + delta_b0(i_mp_qi)*didi(k) ) &
        * sqrt( theta_b0(i_mp_qc)*vcvc(k) - theta_ab0(i_mp_qi,i_mp_qc)*vcvi + theta_b0(i_mp_qi)*vivi(k) &
            +  sigma_i + sigma_c )
       pac(k,i_liaclc2li)= -0.25_rp*pi*e_ic*rhoq(k,i_ni)*rhoq(k,i_qc)*coef_acc_lci
       pac(k,i_niacnc2ni)= -0.25_rp*pi*e_ic*rhoq(k,i_ni)*rhoq(k,i_nc)*coef_acc_nci
    end do
 
    ! cloud-snow => snow
    ! reduction term of cloud
    do k = ks, ke
       dcds = dq_xave(k,i_mp_qc)   * dq_xave(k,i_mp_qs)
       vcvs = vt_xave(k,i_mp_qc,2) * vt_xave(k,i_mp_qs,2)
       sw = 0.5_rp - sign(0.5_rp, ds0-ave_ds(k)) ! if(ave_ds>ds0)then sw=1
       e_s = e_sm * sw
       e_sc = e_s*e_c(k)
       coef_acc_lcs = &
              ( delta_b1(i_mp_qc)*dcdc(k) + delta_ab1(i_mp_qs,i_mp_qc)*dcds + delta_b0(i_mp_qs)*dsds(k) ) &
        * sqrt( theta_b1(i_mp_qc)*vcvc(k) - theta_ab1(i_mp_qs,i_mp_qc)*vcvs + theta_b0(i_mp_qs)*vsvs(k) &
            +  sigma_s + sigma_c )
       coef_acc_ncs = &
              ( delta_b0(i_mp_qc)*dcdc(k) + delta_ab0(i_mp_qs,i_mp_qc)*dcds + delta_b0(i_mp_qs)*dsds(k) ) &
        * sqrt( theta_b0(i_mp_qc)*vcvc(k) - theta_ab0(i_mp_qs,i_mp_qc)*vcvs + theta_b0(i_mp_qs)*vsvs(k) &
            +  sigma_s + sigma_c )
       pac(k,i_lsaclc2ls)= -0.25_rp*pi*e_sc*rhoq(k,i_ns)*rhoq(k,i_qc)*coef_acc_lcs
       pac(k,i_nsacnc2ns)= -0.25_rp*pi*e_sc*rhoq(k,i_ns)*rhoq(k,i_nc)*coef_acc_ncs
    end do
 
    ! cloud-graupel => graupel
    ! reduction term of cloud
    do k = ks, ke
       dcdg = dq_xave(k,i_mp_qc)   * dq_xave(k,i_mp_qg)
       vcvg = vt_xave(k,i_mp_qc,2) * vt_xave(k,i_mp_qg,2)
       ave_dg = coef_d(i_mp_qg)*xq(k,i_mp_qg)**b_m(i_mp_qg)
       sw = 0.5_rp - sign(0.5_rp, dg0-ave_dg) ! if(ave_dg>dg0)then sw=1
       e_g = e_gm * sw
       e_gc = e_g*e_c(k)
       coef_acc_lcg = &
              ( delta_b1(i_mp_qc)*dcdc(k) + delta_ab1(i_mp_qg,i_mp_qc)*dcdg + delta_b0(i_mp_qg)*dgdg(k) ) &
        * sqrt( theta_b1(i_mp_qc)*vcvc(k) - theta_ab1(i_mp_qg,i_mp_qc)*vcvg + theta_b0(i_mp_qg)*vgvg(k) &
            +  sigma_g + sigma_c )
       coef_acc_ncg = &
              ( delta_b0(i_mp_qc)*dcdc(k) + delta_ab0(i_mp_qg,i_mp_qc)*dcdg + delta_b0(i_mp_qg)*dgdg(k) ) &
        * sqrt( theta_b0(i_mp_qc)*vcvc(k) - theta_ab0(i_mp_qg,i_mp_qc)*vcvg + theta_b0(i_mp_qg)*vgvg(k) &
            +  sigma_g + sigma_c )
       pac(k,i_lgaclc2lg)= -0.25_rp*pi*e_gc*rhoq(k,i_ng)*rhoq(k,i_qc)*coef_acc_lcg
       pac(k,i_ngacnc2ng)= -0.25_rp*pi*e_gc*rhoq(k,i_ng)*rhoq(k,i_nc)*coef_acc_ncg
    end do
 
    ! snow-graupel => graupel
    do k = ks, ke
       dsdg = dq_xave(k,i_mp_qs)   * dq_xave(k,i_mp_qg)
       vsvg = vt_xave(k,i_mp_qs,2) * vt_xave(k,i_mp_qg,2)
       coef_acc_lsg = &
              ( delta_b1(i_mp_qs)*dsds(k) + delta_ab1(i_mp_qg,i_mp_qs)*dsdg + delta_b0(i_mp_qg)*dgdg(k) ) &
        * sqrt( theta_b1(i_mp_qs)*vsvs(k) - theta_ab1(i_mp_qg,i_mp_qs)*vsvg + theta_b0(i_mp_qg)*vgvg(k) &
            +  sigma_g + sigma_s )
       coef_acc_nsg(k) = &
              ( delta_b0(i_mp_qs)*dsds(k) + delta_ab0(i_mp_qg,i_mp_qs)*dsdg + delta_b0(i_mp_qg)*dgdg(k) ) &
            ! [fix] T.Mitsui 08/05/08
        * sqrt( theta_b0(i_mp_qs)*vsvs(k) - theta_ab0(i_mp_qg,i_mp_qs)*vsvg + theta_b0(i_mp_qg)*vgvg(k) &
            +  sigma_g + sigma_s )
       pac(k,i_lgacls2lg)= -0.25_rp*pi*e_stick(k)*e_gs*rhoq(k,i_ng)*rhoq(k,i_qs)*coef_acc_lsg
       pac(k,i_ngacns2ng)= -0.25_rp*pi*e_stick(k)*e_gs*rhoq(k,i_ng)*rhoq(k,i_ns)*coef_acc_nsg(k)
    end do
 
    !-----------------
    !  (start) Y.Sato added on 2018/8/31
    !--- ice-graupel => graupel
!!$    do k = KS, KE
!!$       didg = dq_xave(k,I_mp_QI)   * dq_xave(k,I_mp_QG)
!!$       vivg = vt_xave(k,I_mp_QI,2) * vt_xave(k,I_mp_QG,2)
!!$       coef_acc_LIG = &
!!$              ( delta_b1(I_QI)*didi(k) + delta_ab1(I_QG,I_QI)*didg + delta_b0(I_QG)*dgdg(k) ) &
!!$        * sqrt( theta_b1(I_QI)*vivi(k) - theta_ab1(I_QG,I_QI)*vivg + theta_b0(I_QG)*vgvg(k)   &
!!$            +  sigma_g + sigma_i )
!!$       coef_acc_NIG(k) = &
!!$              ( delta_b0(I_QI)*didi(k) + delta_ab0(I_QG,I_QI)*didg + delta_b0(I_QG)*dgdg(k) ) &
!!$        * sqrt( theta_b0(I_QI)*vivi(k) - theta_ab0(I_QG,I_QI)*vivg + theta_b0(I_QG)*vgvg(k) &
!!$            +  sigma_g + sigma_i )
!!$       Pac(k,I_LGacLI2LG)= -0.25_RP*pi*E_stick(k)*E_gi*rhoq(k,I_NG)*rhoq(k,I_QI)*coef_acc_LIG*flg_igcol
!!$       Pac(k,I_NGacNI2NG)= -0.25_RP*pi*E_stick(k)*E_gi*rhoq(k,I_NG)*rhoq(k,I_NI)*coef_acc_NIG(k)*flg_igcol
!!$    end do
 
    !------------------------------------------------------------------------
    ! ice-snow => snow
    ! reduction term of ice
    do k = ks, ke
       dids = dq_xave(k,i_mp_qi)   * dq_xave(k,i_mp_qs)
       vivs = vt_xave(k,i_mp_qi,2) * vt_xave(k,i_mp_qs,2)
       coef_acc_lis = &
              ( delta_b1(i_mp_qi)*didi(k) + delta_ab1(i_mp_qs,i_mp_qi)*dids + delta_b0(i_mp_qs)*dsds(k) ) &
        * sqrt( theta_b1(i_mp_qi)*vivi(k) - theta_ab1(i_mp_qs,i_mp_qi)*vivs + theta_b0(i_mp_qs)*vsvs(k) &
            +  sigma_i + sigma_s )
       coef_acc_nis = &
              ( delta_b0(i_mp_qi)*didi(k) + delta_ab0(i_mp_qs,i_mp_qi)*dids + delta_b0(i_mp_qs)*dsds(k) ) &
        * sqrt( theta_b0(i_mp_qi)*vivi(k) - theta_ab0(i_mp_qs,i_mp_qi)*vivs + theta_b0(i_mp_qs)*vsvs(k) &
            +  sigma_i + sigma_s )
       pac(k,i_liacls2ls)= -0.25_rp*pi*e_stick(k)*e_si*rhoq(k,i_ns)*rhoq(k,i_qi)*coef_acc_lis
       pac(k,i_niacns2ns)= -0.25_rp*pi*e_stick(k)*e_si*rhoq(k,i_ns)*rhoq(k,i_ni)*coef_acc_nis
    end do
 
    do k = ks, ke
       drdg = dq_xave(k,i_mp_qr)   * dq_xave(k,i_mp_qg)
       vrvg = vt_xave(k,i_mp_qr,2) * vt_xave(k,i_mp_qg,2)
       sw = sign(0.5_rp, t00-tem(k)) + 0.5_rp
       ! if ( tem(k) <= T00 )then
          ! rain-graupel => graupel
          ! reduction term of rain
          ! sw = 1
       ! else
          ! rain-graupel => rain
          ! reduction term of graupel
          ! sw = 0
       coef_acc_lrg = &
              ( ( delta_b1(i_mp_qr)*drdr(k) + delta_ab1(i_mp_qg,i_mp_qr)*drdg + delta_b0(i_mp_qg)*dgdg(k) ) * sw &
              + ( delta_b1(i_mp_qg)*dgdg(k) + delta_ab1(i_mp_qr,i_mp_qg)*drdg + delta_b0(i_mp_qr)*drdr(k) ) * (1.0_rp-sw) ) &
            * sqrt( ( theta_b1(i_mp_qr)*vrvr(k) - theta_ab1(i_mp_qg,i_mp_qr)*vrvg + theta_b0(i_mp_qg)*vgvg(k) ) * sw &
                  + ( theta_b1(i_mp_qg)*vgvg(k) - theta_ab1(i_mp_qr,i_mp_qg)*vrvg + theta_b0(i_mp_qr)*vrvr(k) ) * (1.0_rp-sw) &
                  + sigma_r + sigma_g )
       pac(k,i_lraclg2lg) = -0.25_rp*pi*e_gr*coef_acc_lrg * ( rhoq(k,i_ng)*rhoq(k,i_qr) * sw &
                                                            + rhoq(k,i_nr)*rhoq(k,i_qg) * (1.0_rp-sw) )
       coef_acc_nrg = &
              ( delta_b0(i_mp_qr)*drdr(k) + delta_ab0(i_mp_qg,i_mp_qr)*drdg + delta_b0(i_mp_qg)*dgdg(k) ) &
        * sqrt( theta_b0(i_mp_qr)*vrvr(k) - theta_ab0(i_mp_qg,i_mp_qr)*vrvg + theta_b0(i_mp_qg)*vgvg(k) &
            +  sigma_r + sigma_g )
       pac(k,i_nracng2ng) = -0.25_rp*pi*e_gr*rhoq(k,i_ng)*rhoq(k,i_nr)*coef_acc_nrg
    end do
 
    !------------------------------------------------------------------------
    !
    !+++ pattern 2: a + b => c  (a>b)
    !                           (r-i,r-s)
    !------------------------------------------------------------------------
 
    ! rain-ice => graupel
    ! reduction term of ice
    do k = ks, ke
       coef_acc_lri_i = &
              ( delta_b1(i_mp_qi)*didi(k) + delta_ab1(i_mp_qr,i_mp_qi)*drdi(k) + delta_b0(i_mp_qr)*drdr(k) ) &
        * sqrt( theta_b1(i_mp_qi)*vivi(k) - theta_ab1(i_mp_qr,i_mp_qi)*vrvi(k) + theta_b0(i_mp_qr)*vrvr(k) &
            +  sigma_r + sigma_i )
       coef_acc_nri_i = &
              ( delta_b0(i_mp_qi)*didi(k) + delta_ab0(i_mp_qr,i_mp_qi)*drdi(k) + delta_b0(i_mp_qr)*drdr(k) ) &
        * sqrt( theta_b0(i_mp_qi)*vivi(k) - theta_ab0(i_mp_qr,i_mp_qi)*vrvi(k) + theta_b0(i_mp_qr)*vrvr(k) &
            +  sigma_r + sigma_i )
       pac(k,i_lracli2lg_i)= -0.25_rp*pi*e_ir*rhoq(k,i_nr)*rhoq(k,i_qi)*coef_acc_lri_i
       pac(k,i_nracni2ng_i)= -0.25_rp*pi*e_ir*rhoq(k,i_nr)*rhoq(k,i_ni)*coef_acc_nri_i
    end do
 
    ! reduction term of rain
    do k = ks, ke
       coef_acc_lri_r = &
              ( delta_b1(i_mp_qr)*drdr(k) + delta_ab1(i_mp_qi,i_mp_qr)*drdi(k) + delta_b0(i_mp_qi)*didi(k) ) &
        * sqrt( theta_b1(i_mp_qr)*vrvr(k) - theta_ab1(i_mp_qi,i_mp_qr)*vrvi(k) + theta_b0(i_mp_qi)*vivi(k) &
            +  sigma_r + sigma_i )
       coef_acc_nri_r = &
              ( delta_b0(i_mp_qr)*drdr(k) + delta_ab0(i_mp_qi,i_mp_qr)*drdi(k) + delta_b0(i_mp_qi)*didi(k) ) &
        * sqrt( theta_b0(i_mp_qr)*vrvr(k) - theta_ab0(i_mp_qi,i_mp_qr)*vrvi(k) + theta_b0(i_mp_qi)*vivi(k) &
            +  sigma_r + sigma_i )
       pac(k,i_lracli2lg_r)= -0.25_rp*pi*e_ir*rhoq(k,i_ni)*rhoq(k,i_qr)*coef_acc_lri_r
       pac(k,i_nracni2ng_r)= -0.25_rp*pi*e_ir*rhoq(k,i_ni)*rhoq(k,i_nr)*coef_acc_nri_r
    end do
 
    ! rain-snow => graupel
    ! reduction term of snow
    do k = ks, ke
       coef_acc_lrs_s = &
              ( delta_b1(i_mp_qs)*dsds(k) + delta_ab1(i_mp_qr,i_mp_qs)*drds(k) + delta_b0(i_mp_qr)*drdr(k) ) &
        * sqrt( theta_b1(i_mp_qs)*vsvs(k) - theta_ab1(i_mp_qr,i_mp_qs)*vrvs(k) + theta_b0(i_mp_qr)*vrvr(k) &
            +  sigma_r + sigma_s )
       coef_acc_nrs_s = &
              ( delta_b0(i_mp_qs)*dsds(k) + delta_ab0(i_mp_qr,i_mp_qs)*drds(k) + delta_b0(i_mp_qr)*drdr(k) ) &
        * sqrt( theta_b0(i_mp_qs)*vsvs(k) - theta_ab0(i_mp_qr,i_mp_qs)*vrvs(k) + theta_b0(i_mp_qr)*vrvr(k) &
            +  sigma_r + sigma_s )
       pac(k,i_lracls2lg_s)= -0.25_rp*pi*e_sr*rhoq(k,i_nr)*rhoq(k,i_qs)*coef_acc_lrs_s
       pac(k,i_nracns2ng_s)= -0.25_rp*pi*e_sr*rhoq(k,i_nr)*rhoq(k,i_ns)*coef_acc_nrs_s
    end do
 
    ! reduction term of rain
    do k = ks, ke
       coef_acc_lrs_r = &
              ( delta_b1(i_mp_qr)*drdr(k) + delta_ab1(i_mp_qs,i_mp_qr)*drds(k) + delta_b0(i_mp_qs)*dsds(k) ) &
        * sqrt( theta_b1(i_mp_qr)*vrvr(k) - theta_ab1(i_mp_qs,i_mp_qr)*vrvs(k) + theta_b0(i_mp_qs)*vsvs(k) &
            +  sigma_r + sigma_s )
       coef_acc_nrs_r = &
              ( delta_b0(i_mp_qr)*drdr(k) + delta_ab0(i_mp_qs,i_mp_qr)*drds(k) + delta_b0(i_mp_qs)*dsds(k) ) &
        * sqrt( theta_b0(i_mp_qr)*vrvr(k) - theta_ab0(i_mp_qs,i_mp_qr)*vrvs(k) + theta_b0(i_mp_qs)*vsvs(k) &
            +  sigma_r + sigma_s )
       pac(k,i_lracls2lg_r)= -0.25_rp*pi*e_sr*rhoq(k,i_ns)*rhoq(k,i_qr)*coef_acc_lrs_r
       pac(k,i_nracns2ng_r)= -0.25_rp*pi*e_sr*rhoq(k,i_ns)*rhoq(k,i_nr)*coef_acc_nrs_r
    end do
 
    !------------------------------------------------------------------------
    !
    !+++ pattern 3: a + a => b  (i-i)
    !
    !------------------------------------------------------------------------
 
    ! ice-ice ( reduction is double, but includes double-count)
    do k = ks, ke
       coef_acc_lii = &
              ( delta_b0(i_mp_qi)*didi(k) + delta_ab1(i_mp_qi,i_mp_qi)*didi(k) + delta_b1(i_mp_qi)*didi(k) ) &
        * sqrt( theta_b0(i_mp_qi)*vivi(k) - theta_ab1(i_mp_qi,i_mp_qi)*vivi(k) + theta_b1(i_mp_qi)*vivi(k) &
            +  sigma_i + sigma_i )
       coef_acc_nii = &
              ( delta_b0(i_mp_qi)*didi(k) + delta_ab0(i_mp_qi,i_mp_qi)*didi(k) + delta_b0(i_mp_qi)*didi(k) ) &
        * sqrt( theta_b0(i_mp_qi)*vivi(k) - theta_ab0(i_mp_qi,i_mp_qi)*vivi(k) + theta_b0(i_mp_qi)*vivi(k) &
            +  sigma_i + sigma_i )
       pac(k,i_liacli2ls)= -0.25_rp*pi*e_stick(k)*e_ii*rhoq(k,i_ni)*rhoq(k,i_qi)*coef_acc_lii
       pac(k,i_niacni2ns)= -0.25_rp*pi*e_stick(k)*e_ii*rhoq(k,i_ni)*rhoq(k,i_ni)*coef_acc_nii
 
!          ci_aut(k)   =  0.25_RP*pi*E_ii*rhoq(k,I_NI)*coef_acc_LII
!          taui_aut(k) = 1._RP/max(E_stick(k)*ci_aut(k),1.E-10_RP)
!          tau_sce(k)  = rhoq(k,I_QI)/max(rhoq(k,I_QIj)+rhoq(k,I_QS),1.E-10_RP)
    end do
 
    !------------------------------------------------------------------------
    !
    !+++ pattern 4: a + a => a  (s-s)
    !
    !------------------------------------------------------------------------
 
    ! snow-snow => snow
    do k = ks, ke
       coef_acc_nss = &
              ( delta_b0(i_mp_qs)*dsds(k) + delta_ab0(i_mp_qs,i_mp_qs)*dsds(k) + delta_b0(i_mp_qs)*dsds(k) ) &
        * sqrt( theta_b0(i_mp_qs)*vsvs(k) - theta_ab0(i_mp_qs,i_mp_qs)*vsvs(k) + theta_b0(i_mp_qs)*vsvs(k) &
            +  sigma_s + sigma_s )
       pac(k,i_nsacns2ns)= -0.125_rp*pi*e_stick(k)*e_ss*rhoq(k,i_ns)*rhoq(k,i_ns)*coef_acc_nss
    end do
 
    ! graupel-grauple => graupel
    do k = ks, ke
       coef_acc_ngg = &
              ( delta_b0(i_mp_qg)*dgdg(k) + delta_ab0(i_mp_qg,i_mp_qg)*dgdg(k) + delta_b0(i_mp_qg)*dgdg(k) ) &
        * sqrt( theta_b0(i_mp_qg)*vgvg(k) - theta_ab0(i_mp_qg,i_mp_qg)*vgvg(k) + theta_b0(i_mp_qg)*vgvg(k) &
            +  sigma_g + sigma_g )
       pac(k,i_ngacng2ng)= -0.125_rp*pi*e_stick(k)*e_gg*rhoq(k,i_ng)*rhoq(k,i_ng)*coef_acc_ngg
    end do
 
    !------------------------------------------------------------------------
    !--- Partial conversion
    ! SB06(70),(71)
    ! i_iconv2g: option whether partial conversions work or not
 
    ! ice-cloud => graupel
    do k = ks, ke
       sw = 0.5_rp - sign(0.5_rp,di_cri-ave_di(k)) ! if( ave_di > di_cri )then sw=1
       wx_cri = cfill_i*dwatr/rho_g*( pi/6.0_rp*rho_g*ave_di(k)**3/xq(k,i_mp_qi) - 1.0_rp ) * sw
       pq(k,i_licon) = i_iconv2g * pac(k,i_liaclc2li)/max(1.0_rp, wx_cri) * sw
       pq(k,i_nicon) = i_iconv2g * pq(k,i_licon)/xq(k,i_mp_qi) * sw
    end do
 
    ! snow-cloud => graupel
    do k = ks, ke
       wx_crs = cfill_s*dwatr/rho_g*( pi/6.0_rp*rho_g*ave_ds(k)**3/xq(k,i_mp_qs) - 1.0_rp )
       pq(k,i_lscon) = i_sconv2g * (pac(k,i_lsaclc2ls))/max(1.0_rp, wx_crs)
       pq(k,i_nscon) = i_sconv2g * pq(k,i_lscon)/xq(k,i_mp_qs)
    end do
 
    !--- enhanced melting( due to collection-freezing of water droplets )
    !    originally from Rutledge and Hobbs(1984). eq.(A.21)
    ! if T > 273.15 then temc_p=T-273.15, else temc_p=0
    ! 08/05/08 [fix] T.Mitsui LHF00 => LHF0
    ! melting occurs around T=273K, so LHF0 is suitable both SIMPLE and EXACT,
    ! otherwise LHF can have sign both negative(EXACT) and positive(SIMPLE).
    do k = ks, ke
!       temc_m = min(tem(k) - T00, 0.0_RP) ! T < 273.15
       temc_p = max(tem(k) - t00, 0.0_rp) ! T > 273.15
!!$       coef_emelt   = -CL/LHF00*temc_p
       coef_emelt   =  cl/lhf0*temc_p
       ! cloud-graupel
       pq(k,i_lgacm) =  coef_emelt*pac(k,i_lgaclc2lg)
       pq(k,i_ngacm) =  pq(k,i_lgacm)/xq(k,i_mp_qg)
       ! rain-graupel
       pq(k,i_lgarm) =  coef_emelt*pac(k,i_lraclg2lg)
       pq(k,i_ngarm) =  pq(k,i_lgarm)/xq(k,i_mp_qg)
       ! cloud-snow
       pq(k,i_lsacm) =  coef_emelt*(pac(k,i_lsaclc2ls))
       pq(k,i_nsacm) =  pq(k,i_lsacm)/xq(k,i_mp_qs)
       ! rain-snow
       pq(k,i_lsarm) =  coef_emelt*(pac(k,i_lracls2lg_r)+pac(k,i_lracls2lg_s))
       pq(k,i_nsarm) =  pq(k,i_lsarm)/xq(k,i_mp_qg)
       ! cloud-ice
       pq(k,i_liacm) =  coef_emelt*pac(k,i_liaclc2li)
       pq(k,i_niacm) =  pq(k,i_liacm)/xq(k,i_mp_qi)
       ! rain-ice
       pq(k,i_liarm) =  coef_emelt*(pac(k,i_lracli2lg_r)+pac(k,i_lracli2lg_i))
       pq(k,i_niarm) =  pq(k,i_liarm)/xq(k,i_mp_qg)
    end do
 
 
    !---- for charge density
    if ( flg_lt ) then
       !--- C + I -> I (decrease from cloud charge)
       do k = ks, ke
          sw1 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_nc)-small ) !--- if NC is small,  ignore charge transfer
          pcrg2(k,i_niacnc2ni) = pac(k,i_niacnc2ni)*(1.0_rp-sw1) / (rhoq(k,i_nc)+sw1) * rhoq_crg(k,i_qc)
       end do
 
       !--- C + S -> S (decrease from cloud charge)
       do k = ks, ke
          sw1 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_nc)-small ) !--- if NC is small,  ignore charge transfer
          pcrg2(k,i_nsacnc2ns) = pac(k,i_nsacnc2ns)*(1.0_rp-sw1) / (rhoq(k,i_nc)+sw1) * rhoq_crg(k,i_qc)
       end do
 
       !--- C + G -> G (decrease from cloud charge)
       do k = ks, ke
          sw1 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_nc)-small ) !--- if NC is small,  ignore charge transfer
          pcrg2(k,i_ngacnc2ng) = pac(k,i_ngacnc2ng)*(1.0_rp-sw1) / (rhoq(k,i_nc)+sw1) * rhoq_crg(k,i_qc)
       end do
 
       !--- S + G -> G (decrease from snow charge)
       do k = ks, ke
          sw1 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_ns)-small ) !--- if NS is small,  ignore charge transfer
          pcrg2(k,i_ngacns2ng) = pac(k,i_ngacns2ng)*(1.0_rp-sw1) / (rhoq(k,i_ns)+sw1) * rhoq_crg(k,i_qs)
       end do
 
       !--- Charge separation by Snow-Graupel rebound--------------------------------
       do k = ks, ke
          alpha_lt = 5.0_rp * ( dq_xave(k,i_mp_qs) / d0_crg )**2 * vt_xave(k,i_mp_qg,2) / v0_crg
          alpha_lt = min( alpha_lt, 10.0_rp )
          pcrg2(k,i_cgngacns2ng)= 0.25_rp*pi*( 1.0_rp - e_stick(k) )*e_gs &
                                * rhoq(k,i_ng)*rhoq(k,i_ns)*coef_acc_nsg(k) &
                                * ( dqcrg(k)*alpha_lt ) &
                                * beta_crg(k)
       end do
 
       !--- I + G -> G (decrease from snow charge)
!!$       do k = KS, KE
!!$         sw1 = 0.5_RP - sign( 0.5_RP, rhoq(k,I_NI)-SMALL ) !--- if NS is small,  ignore charge transfer
!!$         Pcrg2(k,I_NGacNI2NG) = Pac(k,I_NGacNI2NG)*(1.0_RP-sw1) / (rhoq(k,I_NI)+sw1) * rhoq_crg(k,I_QI) * flg_igcol
!!$       !--- Charge separation by Ice-Graupel rebound--------------------------------
!!$         alpha_lt = 5.0_RP * ( dq_xave(k,I_mp_QI) / d0_crg )**2 * vt_xave(k,I_mp_QG,2) / v0_crg
!!$         alpha_lt = min( alpha_lt, 10.0_RP )
!!$         Pcrg2(k,I_CGNGacNI2NG)= 0.25_RP*pi*( 1.0_RP - E_stick(k) )*E_gi &
!!$                                  * rhoq(k,I_NG)*rhoq(k,I_NI)*coef_acc_NIG(k) &
!!$                                  * ( dqcrg(k)*alpha_lt ) &
!!$                                  * beta_crg(k) * flg_igcol
!!$       end do
 
       !--- I + S -> S (decrease from ice charge)
       do k = ks, ke
          sw1 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_ni)-small ) !--- if NI is small,  ignore charge transfer
          pcrg2(k,i_niacns2ns) = pac(k,i_niacns2ns)*(1.0_rp-sw1) / (rhoq(k,i_ni)+sw1) * rhoq_crg(k,i_qi)
       end do
 
       !--- R+G->R (T>T00 sw=0, decrease from graupel charge), ->G(T<=T00 sw=1, dcrerase from rain charge)
       do k = ks, ke
          sw = 0.5_rp + sign( 0.5_rp, t00-tem(k) )
          sw1 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_nr)-small ) !--- if NR is small,  ignore charge transfer
          sw2 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_ng)-small ) !--- if NG is small,  ignore charge transfer
          pcrg2(k,i_nracng2ng) = pac(k,i_nracng2ng)*(1.0_rp-sw1)/(rhoq(k,i_nr)+sw1) * rhoq_crg(k,i_qr) * sw &
                               + pac(k,i_nracng2ng)*(1.0_rp-sw2)/(rhoq(k,i_ng)+sw2) * rhoq_crg(k,i_qg) * (1.0_rp-sw)
       end do
 
       !--- R + I -> G (decrease from both ice and rain charge, but only ice charge at this part)
       do k = ks, ke
          sw1 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_ni)-small ) !--- if NI is small,  ignore charge transfer
          pcrg2(k,i_nracni2ng_i) = pac(k,i_nracni2ng_i)*(1.0_rp-sw1) / (rhoq(k,i_ni)+sw1) * rhoq_crg(k,i_qi)
       end do
 
       !--- R + I -> G (decrease from both ice and rain charge, but only rain charge at this part)
       do k = ks, ke
          sw1 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_nr)-small ) !--- if NR is small,  ignore charge transfer
          pcrg2(k,i_nracni2ng_r) = pac(k,i_nracni2ng_r)*(1.0_rp-sw1) / (rhoq(k,i_nr)+sw1) * rhoq_crg(k,i_qr)
       end do
 
       !--- R + S -> G (decrease from both snow and rain charge, but only snow charge at this part)
       do k = ks, ke
          sw1 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_ns)-small ) !--- if NS is small,  ignore charge transfer
          pcrg2(k,i_nracns2ng_s) = pac(k,i_nracns2ng_s)*(1.0_rp-sw1) / (rhoq(k,i_ns)+sw1) * rhoq_crg(k,i_qs)
       end do
 
       !--- R + S -> G (decrease from both snow and rain charge, but only rain charge at this part)
       do k = ks, ke
          sw1 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_nr)-small ) !--- if NR is small,  ignore charge transfer
          pcrg2(k,i_nracns2ng_r) = pac(k,i_nracns2ng_r)*(1.0_rp-sw1) / (rhoq(k,i_nr)+sw1) * rhoq_crg(k,i_qr)
       end do
 
       !--- I + I -> S (decrease from ice charge)
       do k = ks, ke
          sw1 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_ni)-small ) !--- if NI is small,  ignore charge transfer
          pcrg2(k,i_niacni2ns) = pac(k,i_niacni2ns)*(1.0_rp-sw1) / (rhoq(k,i_ni)+sw1) * rhoq_crg(k,i_qi)
       end do
 
       !--- I + C -> G (decrease from ice charge)
       do k = ks, ke
          sw1 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_ni)-small ) !--- if NI is small,  ignore charge transfer
          pcrg1(k,i_nicon) = i_iconv2g * pq(k,i_nicon)*(1.0_rp-sw1) / (rhoq(k,i_ni)+sw1) * rhoq_crg(k,i_qi)
       end do
 
       !--- S + C -> G (decrease from snow charge)
       do k = ks, ke
          sw1 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_ns)-small ) !--- if NS is small,  ignore charge transfer
          pcrg1(k,i_nscon) = i_sconv2g * pq(k,i_nscon)*(1.0_rp-sw1) / (rhoq(k,i_ns)+sw1) * rhoq_crg(k,i_qs)
       end do
 
       do k = ks, ke
          sw1 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_ng)-small ) !--- if NG is small,  ignore charge transfer
          pcrg1(k,i_ngacm) = pq(k,i_ngacm)*(1.0_rp-sw1) / (rhoq(k,i_ng)+sw1) * rhoq_crg(k,i_qg)
       end do
 
       do k = ks, ke
          sw1 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_ng)-small ) !--- if NG is small,  ignore charge transfer
          pcrg1(k,i_ngarm) = pq(k,i_ngarm)*(1.0_rp-sw1) / (rhoq(k,i_ng)+sw1) * rhoq_crg(k,i_qg)
       end do
 
       do k = ks, ke
          sw1 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_ns)-small ) !--- if NS is small,  ignore charge transfer
          pcrg1(k,i_nsacm) = pq(k,i_nsacm)*(1.0_rp-sw1) / (rhoq(k,i_ns)+sw1) * rhoq_crg(k,i_qs)
       end do
 
       do k = ks, ke
          sw1 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_ns)-small ) !--- if NS is small,  ignore charge transfer
          pcrg1(k,i_nsarm) = pq(k,i_nsarm)*(1.0_rp-sw1) / (rhoq(k,i_ns)+sw1) * rhoq_crg(k,i_qs)
       end do
 
       do k = ks, ke
          sw1 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_ni)-small ) !--- if NI is small,  ignore charge transfer
          pcrg1(k,i_niacm) = pq(k,i_niacm)*(1.0_rp-sw1) / (rhoq(k,i_ni)+sw1) * rhoq_crg(k,i_qi)
       end do
 
       do k = ks, ke
          sw1 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_ni)-small ) !--- if NI is small,  ignore charge transfer
          pcrg1(k,i_niarm) = pq(k,i_niarm)*(1.0_rp-sw1) / (rhoq(k,i_ni)+sw1) * rhoq_crg(k,i_qi)
       end do
 
    end if
 
    return
  end subroutine mixed_phase_collection
 
!OCL SERIAL
  subroutine mixed_phase_collection_bin(   &
    ! collection process
       KA, KS, KE,            & ! in
       flg_lt,                & ! in
       d0_crg, v0_crg,        & ! in
       beta_crg, dqcrg,       & ! in
       wtem, rhoq, rhoq_crg,  & ! in
       xq, dq_xave,  vt_xave, & ! in
       rho,                   & ! in
       PQ,                    & ! inout
       Pcrg1, Pcrg2,          & ! inout
       Pac                    ) ! out
    use scale_atmos_saturation, only: &
       moist_psat_ice => atmos_saturation_psat_ice
    use scale_prc, only: &
       prc_abort
    implicit none
 
    integer, intent(in) :: KA, KS, KE
 
    !--- mixed-phase collection process
    !                  And all we set all production term as a negative sign to avoid confusion.
    !
    real(RP), intent(in) :: wtem(KA)
    !--- mass/number concentration[kg/m3]
    real(RP), intent(in) :: rhoq(KA,I_QV:I_NG)
    real(RP), intent(in) :: rho(KA) ! air density
    ! necessary ?
    real(RP), intent(in) :: xq(KA,HYDRO_MAX)
    !--- diameter of averaged mass( D(ave x) )
    real(RP), intent(in) :: dq_xave(KA,HYDRO_MAX)
    !--- terminal velocity of averaged mass( vt(ave x) )
    real(RP), intent(in) :: vt_xave(KA,HYDRO_MAX,2)
    ! [Add] 11/08/30 T.Mitsui, for autoconversion of ice
    !    real(RP), intent(in) :: rho(KA)
    !--- partial conversion
    real(RP), intent(inout):: PQ(KA,PQ_MAX)
    !
    real(RP), intent(out):: Pac(KA,Pac_MAX)
    !--- for lightning component
    logical,  intent(in) :: flg_lt
    real(RP), intent(in) :: beta_crg(KA)
    real(RP), intent(in) :: dqcrg(KA)
    real(RP), intent(in) :: d0_crg, v0_crg
    real(RP), intent(in) :: rhoq_crg(KA,I_QC:I_QG)
    real(RP), intent(inout):: Pcrg1(KA,PQ_MAX)
    real(RP), intent(inout):: Pcrg2(KA,Pcrg_MAX)
 
    real(RP), parameter :: a_dec = 0.883_rp
    real(RP), parameter :: b_dec = 0.093_rp
    real(RP), parameter :: c_dec = 0.00348_rp
    real(RP), parameter :: d_dec = 4.5185e-5_rp
    !
    !!!!from default SN14
 
    real(RP), parameter :: E_C12(6)=(/&
         0.010_rp, 0.080_rp, 0.10_rp, 0.60_rp, 0.20_rp, 0.10_rp/)
 
    real(RP) :: tem(KA)
    !
    !--- collection efficency of each specie
    real(RP) :: E_c, E_r, E_i, E_s, E_g
!    real(RP) ::  E_ic, E_sc, E_gc
    !--- sticking efficiency
    real(RP):: E_stick(KA)
    ! [Add] 10/08/03 T.Mitsui
    real(RP) :: temc, temc2, temc3
    real(RP) :: E_dec
    real(RP) :: esi_rat(KA)
    real(RP) :: esi(KA)
    !
    real(RP) :: temc_p, temc_m             ! celcius tem.
!    real(RP) :: ci_aut(KA)
!    real(RP) :: taui_aut(KA)
!    real(RP) :: tau_sce(KA)
    !--- DSD averaged diameter for each species
    real(RP) :: ave_dc                     ! cloud
!    real(RP) :: ave_dr                     ! rain
    real(RP) :: ave_di(KA)                 ! ice
    real(RP) :: ave_ds(KA)                 ! snow
    real(RP) :: ave_dg                     ! graupel
    !--- coefficient of collection equations(L:mass, N:number)
    real(RP) :: coef_acc_LCI,   coef_acc_NCI   ! cloud     - cloud ice
    real(RP) :: coef_acc_LCS,   coef_acc_NCS   ! cloud     - snow
    !
    real(RP) :: coef_acc_LCG,   coef_acc_NCG   ! cloud     - graupel
    real(RP) :: coef_acc_LRI_I, coef_acc_NRI_I ! rain      - cloud ice
    real(RP) :: coef_acc_LRI_R, coef_acc_NRI_R ! rain      - cloud ice
    real(RP) :: coef_acc_LRS_S, coef_acc_NRS_S ! rain      - snow
    real(RP) :: coef_acc_LRS_R, coef_acc_NRS_R ! rain      - snow
    real(RP) :: coef_acc_LRG,   coef_acc_NRG   ! rain      - graupel
    real(RP) :: coef_acc_LII,   coef_acc_NII   ! cloud ice - cloud ice
    real(RP) :: coef_acc_LIS,   coef_acc_NIS   ! cloud ice - snow
    real(RP) ::                 coef_acc_NSS   ! snow      - snow
    real(RP) ::                 coef_acc_NGG   ! grauepl   - graupel
    real(RP) :: coef_acc_LSG,   coef_acc_NSG(KA) ! snow      - graupel
    !--- (diameter) x (diameter)
    real(RP) :: dcdc(KA), dcdi, dcds, dcdg
    real(RP) :: drdr(KA), drdi(KA), drds(KA), drdg
    real(RP) :: didi(KA), dids, didg
    real(RP) :: dsds(KA), dsdg
    real(RP) :: dgdg(KA)
!#    !--- (terminal velocity) x (terminal velocity)
!#    real(RP) :: vcvc(KA), vcvi, vcvs, vcvg
!#    real(RP) :: vrvr(KA), vrvi(KA), vrvs(KA), vrvg
!#    real(RP) :: vivi(KA), vivs, vivg
!#    real(RP) :: vsvs(KA), vsvg
!#    real(RP) :: vgvg(KA)
    !
!    real(RP) :: wx_cri, wx_crs
!    real(RP) :: coef_emelt
!    real(RP) :: w1
 
    real(RP) :: sw, sw1, sw2, tmp
    real(RP) :: alpha_lt
    !
    integer  :: k, iqw
    !
 
    real(RP) :: tem_e(KA) ! [Add] 15/05/19 T.Seiki
 
 
    !
    ! work for binary collision
    !
    ! work for Gauss-Legendre quadrature
    integer, parameter :: ngmax=4
 
    real(RP) :: lambdac(KA), lambdar(KA), lambdai(KA), lambdas(KA), lambdag(KA)
    real(RP) :: A_dsdc(KA), A_dsdr(KA), A_dsdi(KA), A_dsds(KA), A_dsdg(KA)
    real(RP) :: dNdx
    real(RP) :: dxdd
    real(RP) :: dNdD
    real(RP) :: dNc_glx(KA,ngmax), dNr_glx(KA,ngmax), dNi_glx(KA,ngmax), dNs_glx(KA,ngmax), dNg_glx(KA,ngmax)
    real(RP) :: dNc_gly, dNr_gly(KA,ngmax), dNi_gly(KA,ngmax), dNs_gly(KA,ngmax), dNg_gly(KA,ngmax)
    !
    real(RP) :: dc_glx, dr_glx, di_glx, ds_glx, dg_glx
    real(RP) :: dc_gly, dr_gly, di_gly, ds_gly, dg_gly
    real(RP) :: xc_glx(KA,ngmax), xr_glx(KA,ngmax), xi_glx(KA,ngmax), xs_glx(KA,ngmax), xg_glx(KA,ngmax)
    real(RP) :: xc_gly, xr_gly(KA,ngmax), xi_gly, xs_gly, xg_gly
 
    real(RP) :: vtc_glx(KA,ngmax), vtr_glx(KA,ngmax), vti_glx(KA,ngmax), vts_glx(KA,ngmax), vtg_glx(KA,ngmax)
    real(RP) :: vtc_gly, vtr_gly(KA,ngmax), vti_gly(KA,ngmax), vts_gly(KA,ngmax), vtg_gly(KA,ngmax)
    real(RP) :: dac_glx(KA,ngmax), dar_glx(KA,ngmax), dai_glx(KA,ngmax), das_glx(KA,ngmax), dag_glx(KA,ngmax)
    real(RP) :: dac_gly, dar_gly(KA,ngmax), dai_gly(KA,ngmax), das_gly(KA,ngmax), dag_gly(KA,ngmax)
    !
    integer :: ngx, ngy
    !
    real(RP) :: E_ic(KA), E_sc(KA), E_gc(KA)
    !
    ! Parameters to calculate terminal velocity formulated by Mitchell (1996)
    !
    real(RP) :: acx, bcx, gcx, scx ! geometric parameters of hexagonal column ice defined by Mitchell (1996)
    real(RP) :: acy, bcy, gcy, scy ! geometric parameters of hexagonal column ice defined by Mitchell (1996)
    real(RP), parameter :: as = 0.59452551_rp
    real(RP), parameter :: bs = 2.4490_rp
    real(RP), parameter :: gs = 0.131488_rp
    real(RP), parameter :: ss = 1.880000_rp
    real(RP), parameter :: ag = 19.5072514_rp !0.049d0*1.d-3*(100.0d0**2.8d0)
    real(RP), parameter :: bg = 2.8_rp
    real(RP), parameter :: gg = 0.5_rp
    real(RP), parameter :: sg = 2.0_rp
    real(RP) :: num_Besti_glx, num_Bests_glx, num_Bestg_glx
    real(RP) :: num_Besti_gly, num_Bests_gly, num_Bestg_gly
    real(RP) :: num_Rei_glx, num_Res_glx, num_Reg_glx
    real(RP) :: num_Rei_gly, num_Res_gly, num_Reg_gly
    real(RP), parameter :: c0=0.6_rp  ! Bohm (1989)
    real(RP), parameter :: d0=5.83_rp ! Bohm (1989)
    !
    real(RP) :: mua(KA), nua(KA)
    !--- Dynamic viscosity
    real(RP), parameter :: mua0 = 1.718e-5_rp
    
    real(RP), parameter :: dmua_dT = 5.28e-8_rp
    
    !======  mua = mua0 + temc*dmua_dT
    !
    ! collection Kernel
    !
    real(RP) :: kernel_cg, kernel_cs, kernel_ci
    real(RP) :: kernel_rg, kernel_rs, kernel_ri
    real(RP) :: kernel_ig, kernel_is, kernel_ii
    real(RP) :: kernel_sg, kernel_ss
    real(RP) :: kernel_gg
    real(RP) :: kernel_sg_reb
    !
    !--------------------------
    !
    ! accurate for PSDs with optimization
    !
    !-------------------------------
    ! cloud
    ! gauss_range = 2.0_RP
    ! ngmax = 4
    ! rain,
    ! gauss_range = xxx
    ! ngmax = 4
    ! ice, snow, graupel
    ! gauss_range = 5.0_RP
    ! ngmax = 4
    !
    real(RP), parameter :: gauss_rangec=2.0_rp
    real(RP), parameter :: wc_gl(ngmax)=(/&
         0.2411146051511425e+00_rp, &
         0.4520325754088027e+00_rp, &
         0.4520325754088027e+00_rp, &
         0.2411146051511425e+00_rp &
         /)
    real(RP), parameter :: coefc_d_gl(ngmax)=(/&
         0.5505187813766612e+00_rp, &
         0.7900516927471093e+00_rp, &
         0.1265739962562290e+01_rp, &
         0.1816468454535444e+01_rp &
         /)
    real(RP), parameter :: gauss_ranger=8.0_rp
    real(RP), parameter :: wr_gl(ngmax)=(/&
         0.723343815453428e+00_rp,&
         1.35609772622641e+00_rp, &
         1.35609772622641e+00_rp, &
         0.723343815453428e+00_rp &
         /)
    real(RP), parameter :: coefr_d_gl(ngmax)=(/&
         0.166846238310235e+00_rp, &
         0.493135790663523e+00_rp, &
         2.02783902311062e+00_rp, &
         5.99354237846583e+00_rp &
         /)
    real(RP), parameter :: gauss_range=5.0_rp
    real(RP), parameter :: w_gl(ngmax)=(/&
         0.559850775788111e+00_rp, &
         1.04958713664599e+00_rp, &
         1.04958713664599e+00_rp, &
         0.559850775788111e+00_rp &
         /)
    real(RP), parameter :: coef_d_gl(ngmax)=(/&
         0.2500872485877803e+00_rp, &
         0.5785800417604080e+00_rp, &
         0.1728369331505741e+01_rp, &
         0.3998604509613778e+01_rp &
         /)
    !
    real(RP) :: wx_cri, wx_crs
    real(RP) :: coef_emelt
    real(RP) :: w1
!    integer :: ij, k
    integer :: ierr
 
    !---------------------------------------------------------------------------
    !
    !
 
    do k = ks, ke
       tem(k) = max( wtem(k), tem_min ) ! 11/08/30 T.Mitsui
    end do
 
    call moist_psat_ice( ka, ks, ke, &
                         tem(:), esi(:)  ) ! [IN], [OUT]
 
    if( opt_stick_ks96 )then
       do k = ks, ke
          ! Khain and Sednev (1996), eq.(3.15)
          temc       = tem(k) - t00
          temc2      = temc*temc
          temc3      = temc2*temc
          e_dec      = max(0.0_rp, a_dec + b_dec*temc + c_dec*temc2 + d_dec*temc3 )
          esi_rat(k)    = rhoq(k,i_qv)*rvap*tem(k)/esi(k)
          e_stick(k) = min(1.0_rp, e_dec*esi_rat(k))
       end do
    else if( opt_stick_co86 )then
       do k = ks, ke
          ! [Add] 11/08/30 T.Mitsui, Cotton et al. (1986)
          temc       = min(tem(k) - t00,0.0_rp)
          w1         = 0.035_rp*temc-0.7_rp
          e_stick(k) = 10._rp**w1
       end do
    else
       do k = ks, ke
          ! Lin et al. (1983)
          temc_m     = min(tem(k) - t00,0.0_rp) ! T < 273.15
          e_stick(k) = exp(0.09_rp*temc_m)
       end do
    end if
 
    !------------------------------------------------------------------------
 
 
    pac(:,:) = 0.0_rp
 
    tem(:) = max(wtem(:), tem_min )
    tem_e(:) = max(wtem(:), tem_min_estick )
 
    call moist_psat_ice( ka, ks, ke, tem(:), esi(:) )
 
 
    if ( opt_stick_ks96 ) then
       do k=ks, ke
          ! Khain and Sednev (1996), eq.(3.15)
          temc          = tem_e(k) - t00 ![Mod] 15/05/19 T.Seiki
          temc2         = temc*temc
          temc3         = temc2*temc
          e_dec         = max(0.0_rp, a_dec + b_dec*temc + c_dec*temc2 + d_dec*temc3 )
          esi_rat(k) = rhoq(k,i_qv)*rvap*tem(k)/esi(k)
          e_stick(k) = min(1.0_rp, e_dec*esi_rat(k))
       enddo
    elseif( opt_stick_co86 ) then
       do k=ks, ke
          temc          = min(tem_e(k) - t00,0.0_rp)
          w1            = 0.035_rp*temc-0.7_rp
          e_stick(k) = 10.0_rp**w1
       enddo
    elseif( opt_stick_c12 ) then
       do k=ks, ke
          if     (tem_e(k)>273.15_rp) then
             e_stick(k)=1.0_rp
          elseif(tem_e(k)<243.15_rp) then  !-30degC
             e_stick(k)=e_c12(1)
          elseif(tem_e(k)<248.15_rp) then  !-25degC
             e_stick(k)=e_c12(1)+0.2_rp*(e_c12(2)-e_c12(1))*(tem_e(k)-243.15_rp)
          elseif(tem_e(k)<253.15_rp) then  !-20degC
             e_stick(k)=e_c12(2)+0.2_rp*(e_c12(3)-e_c12(2))*(tem_e(k)-248.15_rp)
          elseif(tem_e(k)<258.15_rp) then  !-15degC
             e_stick(k)=e_c12(3)+0.2_rp*(e_c12(4)-e_c12(3))*(tem_e(k)-253.15_rp)
          elseif(tem_e(k)<263.15_rp) then  !-10degC
             e_stick(k)=e_c12(4)+0.2_rp*(e_c12(5)-e_c12(4))*(tem_e(k)-258.15_rp)
          elseif(tem_e(k)<268.15_rp) then  !- 5degC
             e_stick(k)=e_c12(5)+0.2_rp*(e_c12(6)-e_c12(5))*(tem_e(k)-263.15_rp)
          else                               !  0degC
             e_stick(k)=e_c12(6)
          endif
       enddo
    else
       if ( opt_stick_rhh57 ) then
          do k=ks, ke
             if ( tem_e(k) < 270.0_rp .AND. rhoq(k,i_qv)*rvap*tem(k) < esi(k) ) then
                esi_rat(k) = 0.0_rp
             else
                esi_rat(k) = 1.0_rp
             endif
          enddo
       elseif( opt_stick_rhks96 ) then
          do k=ks, ke
             esi_rat(k) = min( rhoq(k,i_qv)*rvap*tem(k)/esi(k),1.0_rp )
          enddo
       else
          esi_rat(:) = 1.0_rp
       endif
       !
       do k=ks, ke
          ! Lin et al. (1983)
          temc_m        = min(tem_e(k) - t00,0.0_rp) ! T < 273.15
          e_stick(k) = exp(0.09_rp*temc_m)*esi_rat(k)
       enddo
    endif
 
    !
    ! Integration Start
    !
 
    do k = ks, ke
       mua(k) = mua0 + dmua_dt*(tem(k)-273.15_rp)
       nua(k) = mua(k)/rho(k)        ! [m2/s]
    end do
    do k = ks, ke
       lambdac(k) = xq(k,i_mp_qc)**(-mu(i_mp_qc))*coef_lambda(i_mp_qc)
       a_dsdc(k) = rhoq(k,i_nc)*coef_a(i_mp_qc)*lambdac(k)**((nu(i_mp_qc)+1.0_rp)/mu(i_mp_qc))
    end do
    do k = ks, ke
       lambdar(k) = xq(k,i_mp_qr)**(-mu(i_mp_qr))*coef_lambda(i_mp_qr)
       a_dsdr(k) = rhoq(k,i_nr)*coef_a(i_mp_qr)*lambdar(k)**((nu(i_mp_qr)+1.0_rp)/mu(i_mp_qr))
    end do
    do k = ks, ke
       lambdai(k) = xq(k,i_mp_qi)**(-mu(i_mp_qi))*coef_lambda(i_mp_qi)
       a_dsdi(k) = rhoq(k,i_ni)*coef_a(i_mp_qi)*lambdai(k)**((nu(i_mp_qi)+1.0_rp)/mu(i_mp_qi))
    end do
    do k = ks, ke
       lambdas(k) = xq(k,i_mp_qs)**(-mu(i_mp_qs))*coef_lambda(i_mp_qs)
       a_dsds(k) = rhoq(k,i_ns)*coef_a(i_mp_qs)*lambdas(k)**((nu(i_mp_qs)+1.0_rp)/mu(i_mp_qs))
    end do
    do k = ks, ke
       lambdag(k) = xq(k,i_mp_qg)**(-mu(i_mp_qg))*coef_lambda(i_mp_qg)
       a_dsdg(k) = rhoq(k,i_ng)*coef_a(i_mp_qg)*lambdag(k)**((nu(i_mp_qg)+1.0_rp)/mu(i_mp_qg))
    end do
 
    !
    ! Particle X
    !
    do ngx=1, ngmax ! X < Y
!OCL LOOP_FISSION_TARGET(LS)
       do k = ks, ke
          dc_glx         = dq_xave(k,i_mp_qc)*coefc_d_gl(ngx)
          xc_glx(k,ngx) = ( (dc_glx/a_m(i_mp_qc)) )**(1.0_rp/b_m(i_mp_qc))
          dnc_glx(k,ngx) = a_dsdc(k)*(xc_glx(k,ngx)**nu(i_mp_qc)) * exp(-lambdac(k)*xc_glx(k,ngx)**mu(i_mp_qc))&
               *(xc_glx(k,ngx)/(b_m(i_mp_qc)*dc_glx))*dc_glx*wc_gl(ngx) ! dNdlogD*weight
          !
          dr_glx         = dq_xave(k,i_mp_qr)*coefr_d_gl(ngx)
          xr_glx(k,ngx) = ( (dr_glx/a_m(i_mp_qr)) )**(1.0_rp/b_m(i_mp_qr))
          dnr_glx(k,ngx) = a_dsdr(k)*(xr_glx(k,ngx)**nu(i_mp_qr)) * exp(-lambdar(k)*xr_glx(k,ngx)**mu(i_mp_qr))&
               *(xr_glx(k,ngx)/(b_m(i_mp_qr)*dr_glx))*dr_glx*wr_gl(ngx) ! dNdlogD*weight
          !
          di_glx         = dq_xave(k,i_mp_qi)*coef_d_gl(ngx)
          xi_glx(k,ngx) = ( (di_glx/a_m(i_mp_qi)) )**(1.0_rp/b_m(i_mp_qi))
          dni_glx(k,ngx) = a_dsdi(k)*(xi_glx(k,ngx)**nu(i_mp_qi)) * exp(-lambdai(k)*xi_glx(k,ngx)**mu(i_mp_qi))&
               *(xi_glx(k,ngx)/(b_m(i_mp_qi)*di_glx))*di_glx*w_gl(ngx) ! dNdlogD*weight
          !
          ds_glx         = dq_xave(k,i_mp_qs)*coef_d_gl(ngx)
          xs_glx(k,ngx) = ( (ds_glx/a_m(i_mp_qs)) )**(1.0_rp/b_m(i_mp_qs))
          dns_glx(k,ngx) = a_dsds(k)*(xs_glx(k,ngx)**nu(i_mp_qs)) * exp(-lambdas(k)*xs_glx(k,ngx)**mu(i_mp_qs))&
               *(xs_glx(k,ngx)/(b_m(i_mp_qs)*ds_glx))*ds_glx*w_gl(ngx)! dNdlogD*weight
          !
          dg_glx         = dq_xave(k,i_mp_qg)*coef_d_gl(ngx)
          xg_glx(k,ngx) = ( (dg_glx/a_m(i_mp_qg)) )**(1.0_rp/b_m(i_mp_qg))
          dng_glx(k,ngx) = a_dsdg(k)*(xg_glx(k,ngx)**nu(i_mp_qg)) * exp(-lambdag(k)*xg_glx(k,ngx)**mu(i_mp_qg))&
               *(xg_glx(k,ngx)/(b_m(i_mp_qg)*dg_glx))*dg_glx*w_gl(ngx)! dNdlogD*weight
          !
          ! Hexagonal Columns
!!$          if( di_glx <= 100.e-6_RP )then
!!$             acx = 0.1677_RP*1.e-3_RP*(100.0_RP**2.91_RP)
!!$             bcx = 2.91_RP
!!$             gcx = (0.684_RP*1.e-4_RP)*10.0_RP**(2.0_RP*2.0_RP)
!!$             scx = 2.0_RP
!!$          else
!!$             acx = 0.00166_RP*1.e-3_RP*(100.0_RP**1.91_RP)
!!$             bcx = 1.91_RP
!!$             gcx = (0.0696_RP*1.e-4_RP)*10.0_RP**(2.0_RP*1.5_RP)
!!$             scx = 1.5_RP
!!$          end if
          sw = 0.5_rp + sign(0.5_rp, di_glx - 100.e-6_rp )
          acx = ( 0.1677_rp*(1.0_rp-sw) + 0.00166_rp*sw ) * 1.e-3_rp * 100.0_rp**( 2.91_rp*(1.0_rp-sw) + 1.91_rp*sw )
          bcx = 2.91_rp*(1.0_rp-sw) + 1.91_rp*sw
          gcx = (0.684_rp*(1.0_rp-sw) + 0.0696_rp*sw ) * 1.e-4_rp * 10.0_rp**( 4.0_rp*(1.0_rp-sw) + 3.0_rp*sw )
          scx = 2.0_rp*(1.0_rp-sw) + 1.5_rp*sw
          num_besti_glx = 2.0_rp*acx*grav*rho(k)*di_glx**(bcx+2.0_rp-scx)/(gcx*mua(k)**2)
          num_bests_glx = 2.0_rp*as *grav*rho(k)*ds_glx**(bs +2.0_rp-ss )/(gs *mua(k)**2)
          num_bestg_glx = 2.0_rp*ag *grav*rho(k)*dg_glx**(bg +2.0_rp-sg )/(gg *mua(k)**2)
          num_rei_glx   = 0.25_rp*d0*d0*( sqrt(1.0_rp+4.0_rp*sqrt(num_besti_glx)/(d0*d0*sqrt(c0)))-1.0_rp )**2
          num_res_glx   = 0.25_rp*d0*d0*( sqrt(1.0_rp+4.0_rp*sqrt(num_bests_glx)/(d0*d0*sqrt(c0)))-1.0_rp )**2
          num_reg_glx   = 0.25_rp*d0*d0*( sqrt(1.0_rp+4.0_rp*sqrt(num_bestg_glx)/(d0*d0*sqrt(c0)))-1.0_rp )**2
          !
          vtc_glx(k,ngx) = coef_vtr_ar2*dc_glx*(1.0_rp-exp(-coef_vtr_br2*dc_glx))
          !
!!$          if( dr_glx < d_vtr_branch )then
!!$             vtr_glx = coef_vtr_ar2*dr_glx*(1.0_RP-exp(-coef_vtr_br2*dr_glx))
!!$          else
!!$             vtr_glx = coef_vtr_ar1-coef_vtr_br1*exp(-coef_vtr_cr1*dr_glx)
!!$          end if
          sw = 0.5_rp + sign( 0.5_rp, dr_glx - d_vtr_branch )
          tmp = exp( - ( coef_vtr_br2*(1.0_rp-sw) + coef_vtr_cr1*sw ) * dr_glx )
          vtr_glx(k,ngx) = coef_vtr_ar2 * dr_glx * ( 1.0_rp - tmp ) * (1.0_rp-sw) &
                         + ( coef_vtr_ar1 - coef_vtr_br1 * tmp ) * sw
          !
          vti_glx(k,ngx) = num_rei_glx*nua(k)/di_glx
          vts_glx(k,ngx) = num_res_glx*nua(k)/ds_glx
          vtg_glx(k,ngx) = num_reg_glx*nua(k)/dg_glx
          ! equivalent area diameter
          dac_glx(k,ngx) = dc_glx
          dar_glx(k,ngx) = dr_glx
          dai_glx(k,ngx) = 2.0_rp*sqrt( (gcx*di_glx**scx)/pi )
          das_glx(k,ngx) = 2.0_rp*sqrt( (gs *ds_glx**ss )/pi )
          dag_glx(k,ngx) = 2.0_rp*sqrt( (gg *dg_glx**sg )/pi )
       end do
    end do
 
    !
    ! Particle Y
    !
    do ngy=1, ngmax
!OCL LOOP_FISSION_TARGET(LS)
       do k = ks, ke
          dr_gly         = dq_xave(k,i_mp_qr)*coefr_d_gl(ngy)
          xr_gly(k,ngy) = ( (dr_gly/a_m(i_mp_qr)) )**(1.0_rp/b_m(i_mp_qr))
          dnr_gly(k,ngy) = a_dsdr(k)*(xr_gly(k,ngy)**nu(i_mp_qr)) * exp(-lambdar(k)*xr_gly(k,ngy)**mu(i_mp_qr))&
               *(xr_gly(k,ngy)/(b_m(i_mp_qr)*dr_gly))*dr_gly*wr_gl(ngy) ! dNdlogD*weight
          !
          di_gly         = dq_xave(k,i_mp_qi)*coef_d_gl(ngy)
          xi_gly         = ( (di_gly/a_m(i_mp_qi)) )**(1.0_rp/b_m(i_mp_qi))
          dni_gly(k,ngy) = a_dsdi(k)*(xi_gly**nu(i_mp_qi)) * exp(-lambdai(k)*xi_gly**mu(i_mp_qi))&
               *(xi_gly/(b_m(i_mp_qi)*di_gly))*di_gly*w_gl(ngy) ! dNdlogD*weight
          !
          ds_gly         = dq_xave(k,i_mp_qs)*coef_d_gl(ngy)
          xs_gly         = ( (ds_gly/a_m(i_mp_qs)) )**(1.0_rp/b_m(i_mp_qs))
          dns_gly(k,ngy) = a_dsds(k)*(xs_gly**nu(i_mp_qs)) * exp(-lambdas(k)*xs_gly**mu(i_mp_qs))&
               *(xs_gly/(b_m(i_mp_qs)*ds_gly))*ds_gly*w_gl(ngy)! dNdlogD*weight
          !
          dg_gly         = dq_xave(k,i_mp_qg)*coef_d_gl(ngy)
          xg_gly         = ( (dg_gly/a_m(i_mp_qg)) )**(1.0_rp/b_m(i_mp_qg))
          dng_gly(k,ngy) = a_dsdg(k)*(xg_gly**nu(i_mp_qg)) * exp(-lambdag(k)*xg_gly**mu(i_mp_qg))&
               *(xg_gly/(b_m(i_mp_qg)*dg_gly))*dg_gly*w_gl(ngy)! dNdlogD*weight
          !
          ! Hexagonal Columns
!!$          if( di_gly <= 100.e-6_RP )then
!!$             acy = 0.1677_RP*1.d-3*(100.0_RP**2.91_RP)
!!$             bcy = 2.91_RP
!!$             gcy = (0.684_RP*1.e-4_RP)*10.0_RP**(2.0_RP*2.0_RP)
!!$             scy = 2.0_RP
!!$          else
!!$             acy = 0.00166_RP*1.e-3_RP*(100.0_RP**1.91_RP)
!!$             bcy = 1.91_RP
!!$             gcy = (0.0696_RP*1.e-4_RP)*10.0_RP**(2.0_RP*1.5_RP)
!!$             scy = 1.5_RP
!!$          end if
          sw = 0.5_rp + sign( 0.5_rp, di_gly - 100.e-6_rp )
          acy = ( 0.1677_rp*(1.0_rp-sw) + 0.00166_rp*sw ) * 1.e-3_rp * 100.0_rp**( 2.91_rp*(1.0_rp-sw) + 1.91_rp*sw )
          bcy = 2.91_rp*(1.0_rp-sw) + 1.91_rp*sw
          gcy = ( 0.684_rp*(1.0_rp-sw) + 0.0696_rp*sw ) * 1.e-4_rp * 10.0_rp**( 4.0_rp*(1.0_rp-sw) + 3.0_rp*sw )
          scy = 2.0_rp*(1.0_rp-sw) + 1.5_rp*sw
          num_besti_gly = 2.0_rp*acy*grav*rho(k)*di_gly**(bcy+2.0_rp-scy)/(gcy*mua(k)**2)
          num_bests_gly = 2.0_rp*as *grav*rho(k)*ds_gly**(bs +2.0_rp-ss )/(gs *mua(k)**2)
          num_bestg_gly = 2.0_rp*ag *grav*rho(k)*dg_gly**(bg +2.0_rp-sg )/(gg *mua(k)**2)
          num_rei_gly   = 0.25_rp*d0*d0*( sqrt(1.0_rp+4.0_rp*sqrt(num_besti_gly)/(d0*d0*sqrt(c0)))-1.0_rp )**2
          num_res_gly   = 0.25_rp*d0*d0*( sqrt(1.0_rp+4.0_rp*sqrt(num_bests_gly)/(d0*d0*sqrt(c0)))-1.0_rp )**2
          num_reg_gly   = 0.25_rp*d0*d0*( sqrt(1.0_rp+4.0_rp*sqrt(num_bestg_gly)/(d0*d0*sqrt(c0)))-1.0_rp )**2
          !
!!$          if( dr_gly < d_vtr_branch )then
!!$             vtr_gly(k,ngy) = coef_vtr_ar2*dr_gly*(1.0_RP-exp(-coef_vtr_br2*dr_gly))
!!$          else
!!$             vtr_gly(k,ngy) = coef_vtr_ar1-coef_vtr_br1*exp(-coef_vtr_cr1*dr_gly)
!!$          end if
          sw = 0.5_rp + sign( 0.5_rp, dr_gly - d_vtr_branch )
          tmp = exp( - ( coef_vtr_br2*(1.0_rp-sw) + coef_vtr_cr1*sw ) * dr_gly )
          vtr_gly(k,ngy) = coef_vtr_ar2 * dr_gly * ( 1.0_rp - tmp ) * (1.0_rp-sw) &
                         + ( coef_vtr_ar1 - coef_vtr_br1 * tmp ) * sw
          !
          vti_gly(k,ngy) = num_rei_gly*nua(k)/di_gly
          vts_gly(k,ngy) = num_res_gly*nua(k)/ds_gly
          vtg_gly(k,ngy) = num_reg_gly*nua(k)/dg_gly
          ! equivalent area diameter
          dar_gly(k,ngy) = dr_gly
          dai_gly(k,ngy) = 2.0_rp*sqrt( (gcy*di_gly**scy)/pi )
          das_gly(k,ngy) = 2.0_rp*sqrt( (gs *ds_gly**ss )/pi )
          dag_gly(k,ngy) = 2.0_rp*sqrt( (gg *dg_gly**sg )/pi )
       end do
    end do
 
    !
    ! BULK collection efficiency are given as follows
    !
    do k = ks, ke
       e_c = max(0.0_rp, min(1.0_rp, (dq_xave(k,i_mp_qc)-dc0)/(dc1-dc0) ))
       !
!!$       if (dq_xave(k,I_mp_QI)>di0) then
!!$          E_i = E_im
!!$       else
!!$          E_i = 0.0_RP
!!$       endif
       sw = 0.5_rp + sign( 0.5_rp, dq_xave(k,i_mp_qi)-di0 )
       e_i = e_im * sw
!!$       if (dq_xave(k,I_mp_QS)>ds0) then
!!$          E_s = E_sm
!!$       else
!!$          E_s = 0.0_RP
!!$       endif
       sw = 0.5_rp + sign( 0.5_rp, dq_xave(k,i_mp_qs)-ds0 )
       e_s = e_sm * sw
!!$       if (dq_xave(k,I_mp_QG)>dg0) then
!!$          E_g = E_gm
!!$       else
!!$          E_g = 0.0_RP
!!$       endif
       sw = 0.5_rp + sign( 0.5_rp, dq_xave(k,i_mp_qg)-dg0 )
       e_g = e_gm * sw
 
       e_ic(k) = e_i*e_c
       e_sc(k) = e_s*e_c
       e_gc(k) = e_g*e_c
    end do
 
 
    !=========================================================================================
    ! collection equation
    !=========================================================================================
    do ngx=1, ngmax ! X < Y
       do ngy=1, ngmax
 
          do k = ks, ke
             !
             ! 1.c-g (X=Cloud, Y=Graupel)
             !
!             kernel_cg = 0.25_RP*pi*(dag_gly(k,ngy)+dac_glx(k,ngx))*(dag_gly(k,ngy)+dac_glx(k,ngx))*sqrt((vtg_gly(k,ngy)-vtc_glx(k,ngx))*(vtg_gly(k,ngy)-vtc_glx(k,ngx)))  * E_gc(k)
             kernel_cg = 0.25_rp * pi * (dag_gly(k,ngy)+dac_glx(k,ngx))**2 * abs(vtg_gly(k,ngy)-vtc_glx(k,ngx)) * e_gc(k)
             pac(k,i_ngacnc2ng) = pac(k,i_ngacnc2ng) - kernel_cg              *dnc_glx(k,ngx)*dng_gly(k,ngy)
             pac(k,i_lgaclc2lg) = pac(k,i_lgaclc2lg) - kernel_cg*xc_glx(k,ngx)*dnc_glx(k,ngx)*dng_gly(k,ngy)
          end do
          do k = ks, ke
             !
             ! 2.c-s (X=Cloud, Y=Snow)
             !
!             kernel_cs = 0.25_RP*pi*(das_gly(k,ngy)+dac_glx(k,ngx))*(das_gly(k,ngy)+dac_glx(k,ngx))*sqrt((vts_gly(k,ngy)-vtc_glx(k,ngx))*(vts_gly(k,ngy)-vtc_glx(k,ngx)))  * E_sc(k)
             kernel_cs = 0.25_rp * pi * (das_gly(k,ngy)+dac_glx(k,ngx))**2 * abs(vts_gly(k,ngy)-vtc_glx(k,ngx)) * e_sc(k)
             pac(k,i_nsacnc2ns) = pac(k,i_nsacnc2ns) - kernel_cs              *dnc_glx(k,ngx)*dns_gly(k,ngy)
             pac(k,i_lsaclc2ls) = pac(k,i_lsaclc2ls) - kernel_cs*xc_glx(k,ngx)*dnc_glx(k,ngx)*dns_gly(k,ngy)
          end do
          do k = ks, ke
             !
             ! 3.c-i (X=Cloud, Y=Cloud Ice)
             !
!             kernel_ci = 0.25_RP*pi*(dai_gly(k,ngy)+dac_glx(k,ngx))*(dai_gly(k,ngy)+dac_glx(k,ngx))*sqrt((vti_gly(k,ngy)-vtc_glx(k,ngx))*(vti_gly(k,ngy)-vtc_glx(k,ngx)))  * E_ic(k)
             kernel_ci = 0.25_rp * pi * (dai_gly(k,ngy)+dac_glx(k,ngx))**2 * abs(vti_gly(k,ngy)-vtc_glx(k,ngx)) * e_ic(k)
             pac(k,i_niacnc2ni) = pac(k,i_niacnc2ni) - kernel_ci              *dnc_glx(k,ngx)*dni_gly(k,ngy)
             pac(k,i_liaclc2li) = pac(k,i_liaclc2li) - kernel_ci*xc_glx(k,ngx)*dnc_glx(k,ngx)*dni_gly(k,ngy)
          end do
          do k = ks, ke
             !
             ! 4.r-g
             !
!             kernel_rg = 0.25_RP*pi*(dag_gly(k,ngy)+dar_glx(k,ngx))*(dag_gly(k,ngy)+dar_glx(k,ngx))*sqrt((vtg_gly(k,ngy)-vtr_glx(k,ngx))*(vtg_gly(k,ngy)-vtr_glx(k,ngx))) * E_gr
             kernel_rg = 0.25_rp * pi * (dag_gly(k,ngy)+dar_glx(k,ngx))**2 * abs(vtg_gly(k,ngy)-vtr_glx(k,ngx)) * e_gr
             ! T < 273K  (X=Rain   , Y=Graupel)
             pac(k,i_nracng2ng) = pac(k,i_nracng2ng) - kernel_rg              *dnr_glx(k,ngx)*dng_gly(k,ngy)
             pac(k,i_lraclg2lg) = pac(k,i_lraclg2lg) - kernel_rg*xr_glx(k,ngx)*dnr_glx(k,ngx)*dng_gly(k,ngy)
             ! T > 273K  (X=Graupel, Y=Rain   )
             pac(k,i_nracng2nr) = pac(k,i_nracng2nr) - kernel_rg              *dng_glx(k,ngx)*dnr_gly(k,ngy)
             pac(k,i_lraclg2lr) = pac(k,i_lraclg2lr) - kernel_rg*xg_glx(k,ngx)*dng_glx(k,ngx)*dnr_gly(k,ngy)
          end do
          do k = ks, ke
             !
             ! 5.r-s
             !
!             kernel_rs = 0.25_RP*pi*(das_glx(k,ngx)+dar_gly(k,ngy))*(das_glx(k,ngx)+dar_gly(k,ngy))*sqrt((vts_glx(k,ngx)-vtr_gly(k,ngy))*(vts_glx(k,ngx)-vtr_gly(k,ngy))) * E_sr
             kernel_rs = 0.25_rp * pi * (das_glx(k,ngx)+dar_gly(k,ngy))**2 * abs(vts_glx(k,ngx)-vtr_gly(k,ngy)) * e_sr
             ! (X=Snow, Y=Rain)
             pac(k,i_nracns2ng_r) = pac(k,i_nracns2ng_r) - kernel_rs              *dns_glx(k,ngx)*dnr_gly(k,ngy)
             pac(k,i_lracls2lg_r) = pac(k,i_lracls2lg_r) - kernel_rs*xr_gly(k,ngy)*dns_glx(k,ngx)*dnr_gly(k,ngy)
             !
             pac(k,i_nracns2ng_s) = pac(k,i_nracns2ng_s) - kernel_rs              *dns_glx(k,ngx)*dnr_gly(k,ngy)
             pac(k,i_lracls2lg_s) = pac(k,i_lracls2lg_s) - kernel_rs*xs_glx(k,ngx)*dns_glx(k,ngx)*dnr_gly(k,ngy)
          end do
          do k = ks, ke
             !
             ! 6.r-i
             !
!             kernel_ri = 0.25_RP*pi*(dai_glx(k,ngx)+dar_gly(k,ngy))*(dai_glx(k,ngx)+dar_gly(k,ngy))*sqrt((vti_glx(k,ngx)-vtr_gly(k,ngy))*(vti_glx(k,ngx)-vtr_gly(k,ngy))) * E_ir
             kernel_ri = 0.25_rp * pi * (dai_glx(k,ngx)+dar_gly(k,ngy))**2 * abs(vti_glx(k,ngx)-vtr_gly(k,ngy)) * e_ir
             ! (X=Cloud Ice, Y=Rain)
             pac(k,i_nracni2ng_r) = pac(k,i_nracni2ng_r) - kernel_ri              *dni_glx(k,ngx)*dnr_gly(k,ngy)
             pac(k,i_lracli2lg_r) = pac(k,i_lracli2lg_r) - kernel_ri*xr_gly(k,ngy)*dni_glx(k,ngx)*dnr_gly(k,ngy)
             !
             pac(k,i_nracni2ng_i) = pac(k,i_nracni2ng_i) - kernel_ri              *dni_glx(k,ngx)*dnr_gly(k,ngy)
             pac(k,i_lracli2lg_i) = pac(k,i_lracli2lg_i) - kernel_ri*xi_glx(k,ngx)*dni_glx(k,ngx)*dnr_gly(k,ngy)
          end do
          do k = ks, ke
             !
             ! 7.i-g
             !
!             kernel_ig = 0.25_RP*pi*(dai_glx(k,ngx)+dag_gly(k,ngy))*(dai_glx(k,ngx)+dag_gly(k,ngy))*sqrt((vti_glx(k,ngx)-vtg_gly(k,ngy))*(vti_glx(k,ngx)-vtg_gly(k,ngy)))  * E_stick(k) * E_gi
             kernel_ig = 0.25_rp * pi * (dai_glx(k,ngx)+dag_gly(k,ngy))**2 * abs(vti_glx(k,ngx)-vtg_gly(k,ngy)) * e_stick(k) * e_gi
             pac(k,i_niacng2ng) = pac(k,i_niacng2ng) - kernel_ig              *dni_glx(k,ngx)*dng_gly(k,ngy)
             pac(k,i_liaclg2lg) = pac(k,i_liaclg2lg) - kernel_ig*xi_glx(k,ngx)*dni_glx(k,ngx)*dng_gly(k,ngy)
          end do
          do k = ks, ke
             !
             ! 8.i-s
             !
!             kernel_is = 0.25_RP*pi*(dai_glx(k,ngx)+das_gly(k,ngy))*(dai_glx(k,ngx)+das_gly(k,ngy))*sqrt((vti_glx(k,ngx)-vts_gly(k,ngy))*(vti_glx(k,ngx)-vts_gly(k,ngy)))  * E_stick(k) * E_si
             kernel_is = 0.25_rp * pi * (dai_glx(k,ngx)+das_gly(k,ngy))**2 * abs(vti_glx(k,ngx)-vts_gly(k,ngy)) * e_stick(k) * e_si
             pac(k,i_niacns2ns) = pac(k,i_niacns2ns) - kernel_is              *dni_glx(k,ngx)*dns_gly(k,ngy)
             pac(k,i_liacls2ls) = pac(k,i_liacls2ls) - kernel_is*xi_glx(k,ngx)*dni_glx(k,ngx)*dns_gly(k,ngy)
          end do
          do k = ks, ke
             !
             ! 9.i-i
             !
!             kernel_ii = 0.25_RP*pi*(dai_glx(k,ngx)+dai_gly(k,ngy))*(dai_glx(k,ngx)+dai_gly(k,ngy))*sqrt((vti_glx(k,ngx)-vti_gly(k,ngy))*(vti_glx(k,ngx)-vti_gly(k,ngy)))  * E_stick(k) * E_ii
             kernel_ii = 0.25_rp * pi * (dai_glx(k,ngx)+dai_gly(k,ngy))**2 * abs(vti_glx(k,ngx)-vti_gly(k,ngy)) * e_stick(k) * e_ii
             pac(k,i_niacni2ns) = pac(k,i_niacni2ns) - kernel_ii              *dni_glx(k,ngx)*dni_gly(k,ngy)
             pac(k,i_liacli2ls) = pac(k,i_liacli2ls) - kernel_ii*xi_glx(k,ngx)*dni_glx(k,ngx)*dni_gly(k,ngy)
          end do
          do k = ks, ke
             !
             ! 10.s-g
             !
!             kernel_sg = 0.25_RP*pi*(das_glx(k,ngx)+dag_gly(k,ngy))*(das_glx(k,ngx)+dag_gly(k,ngy))*sqrt((vts_glx(k,ngx)-vtg_gly(k,ngy))*(vts_glx(k,ngx)-vtg_gly(k,ngy)))  * E_stick(k) * E_gs
             kernel_sg = 0.25_rp * pi * (das_glx(k,ngx)+dag_gly(k,ngy))**2 * abs(vts_glx(k,ngx)-vtg_gly(k,ngy)) * e_stick(k) * e_gs
             pac(k,i_ngacns2ng) = pac(k,i_ngacns2ng) - kernel_sg              *dns_glx(k,ngx)*dng_gly(k,ngy)
             pac(k,i_lgacls2lg) = pac(k,i_lgacls2lg) - kernel_sg*xs_glx(k,ngx)*dns_glx(k,ngx)*dng_gly(k,ngy)
          end do
          do k = ks, ke
             !
             ! 11.s-s
             !
!             kernel_ss = 0.125_RP*pi*(das_glx(k,ngx)+das_gly(k,ngy))*(das_glx(k,ngx)+das_gly(k,ngy))*sqrt((vts_glx(k,ngx)-vts_gly(k,ngy))*(vts_glx(k,ngx)-vts_gly(k,ngy)))  * E_stick(k) * E_ss
             kernel_ss = 0.125_rp * pi * (das_glx(k,ngx)+das_gly(k,ngy))**2 * abs(vts_glx(k,ngx)-vts_gly(k,ngy)) * e_stick(k) * e_ss
             pac(k,i_nsacns2ns) = pac(k,i_nsacns2ns) - kernel_ss*dns_glx(k,ngx)*dns_gly(k,ngy)
          end do
          do k = ks, ke
             !
             ! 12.g-g
             !
!             kernel_gg = 0.125_RP*pi*(dag_glx(k,ngx)+dag_gly(k,ngy))*(dag_glx(k,ngx)+dag_gly(k,ngy))*sqrt((vtg_glx(k,ngx)-vtg_gly(k,ngy))*(vtg_glx(k,ngx)-vtg_gly(k,ngy)))  * E_stick(k) * E_gg
             kernel_gg = 0.125_rp * pi * (dag_glx(k,ngx)+dag_gly(k,ngy))**2 * abs(vtg_glx(k,ngx)-vtg_gly(k,ngy)) * e_stick(k) * e_gg
             pac(k,i_ngacng2ng) = pac(k,i_ngacng2ng) - kernel_gg*dng_glx(k,ngx)*dng_gly(k,ngy)
 
          end do
       end do
    end do
 
    !--- Charge separation by Snow-Graupel rebound--------------------------------
    if ( flg_lt ) then
       do k = ks, ke
!OCL UNROLL('full')
          do ngy = 1, ngmax
!OCL UNROLL('full')
             do ngx = 1, ngmax
                alpha_lt = 5.0_rp * ( das_glx(k,ngx) / d0_crg )**2*vtg_gly(k,ngy)/v0_crg
                alpha_lt = min( alpha_lt, 10.0_rp )
!                kernel_sg_reb      = 0.25_RP*pi*(das_glx(k,ngx)+dag_gly(k,ngy))*(das_glx(k,ngx)+dag_gly(k,ngy))*sqrt((vts_glx(k,ngx)-vtg_gly(k,ngy))*(vts_glx(k,ngx)-vtg_gly(k,ngy)))  &
                kernel_sg_reb = 0.25_rp * pi * (das_glx(k,ngx)+dag_gly(k,ngy))**2 * abs(vts_glx(k,ngx)-vtg_gly(k,ngy)) &
                              * ( 1.0_rp - e_stick(k) ) * e_gs
                pcrg2(k,i_cgngacns2ng) = pcrg2(k,i_cgngacns2ng) + kernel_sg_reb*dns_glx(k,ngx)*dng_gly(k,ngy)*dqcrg(k)*alpha_lt*beta_crg(k)
             end do
          end do
       end do
    end if
 
    !
    !
    do k=ks, ke
       temc_p = max(tem(k) - t00,0.0_rp) ! T > 273.15
       !------------------------------------------------------------------------
       !--- Partial conversion
       ! SB06(70),(71)
       ! i_iconv2g: option whether partial conversions work or not
       ! ice-cloud => graupel
       if ( dq_xave(k,i_mp_qi) > di_cri ) then
          wx_cri = cfill_i*rhow/rho_g*( pi/6.0_rp*rho_g*dq_xave(k,i_mp_qi)*dq_xave(k,i_mp_qi)*dq_xave(k,i_mp_qi)/xq(k,i_mp_qi) - 1.0_rp )
          pq(k,i_licon) = i_iconv2g*  pac(k,i_liaclc2li)/max(1.0_rp, wx_cri)
          pq(k,i_nicon) = i_iconv2g*  pq(k,i_licon)/xq(k,i_mp_qi)
       else
          wx_cri       = 0.0_rp
          pq(k,i_licon) = 0.0_rp
          pq(k,i_nicon) = 0.0_rp
       endif
       ! snow-cloud => graupel
       wx_crs = cfill_s*rhow/rho_g*( pi/6.0_rp*rho_g*dq_xave(k,i_mp_qs)*dq_xave(k,i_mp_qs)*dq_xave(k,i_mp_qs)/xq(k,i_mp_qs) - 1.0_rp )
       pq(k,i_lscon) = i_sconv2g*  (pac(k,i_lsaclc2ls))/max(1.0_rp, wx_crs)
       pq(k,i_nscon) = i_sconv2g*  pq(k,i_lscon)/xq(k,i_mp_qs)
       !------------------------------------------------------------------------
       !--- enhanced melting( due to collection-freezing of water droplets )
       !    originally from Rutledge and Hobbs(1984). eq.(A.21)
       ! if T > 273.15 then temc_p=T-273.15, else temc_p=0
       ! 08/05/08 [fix] T.Mitsui LHF00 => LHF0
       ! melting occurs around T=273K, so LHF0 is suitable both SIMPLE and EXACT,
       ! otherwise LHF can have sign both negative(EXACT) and positive(SIMPLE).
       coef_emelt   =  cl/lhf0*temc_p
       ! cloud-graupel
       pq(k,i_lgacm) =  coef_emelt*pac(k,i_lgaclc2lg)
       pq(k,i_ngacm) =  pq(k,i_lgacm)/xq(k,i_mp_qg)
       ! rain-graupel
       pq(k,i_lgarm) =  coef_emelt*pac(k,i_lraclg2lg)
       pq(k,i_ngarm) =  pq(k,i_lgarm)/xq(k,i_mp_qg)
       ! cloud-snow
       pq(k,i_lsacm) =  coef_emelt*(pac(k,i_lsaclc2ls))
       pq(k,i_nsacm) =  pq(k,i_lsacm)/xq(k,i_mp_qs)
       ! rain-snow
       pq(k,i_lsarm) =  coef_emelt*(pac(k,i_lracls2lg_r)+pac(k,i_lracls2lg_s))
       pq(k,i_nsarm) =  pq(k,i_lsarm)/xq(k,i_mp_qg)
       ! cloud-ice
       pq(k,i_liacm) =  coef_emelt*pac(k,i_liaclc2li)
       pq(k,i_niacm) =  pq(k,i_liacm)/xq(k,i_mp_qi)
       ! rain-ice
       pq(k,i_liarm) =  coef_emelt*(pac(k,i_lracli2lg_r)+pac(k,i_lracli2lg_i))
       pq(k,i_niarm) =  pq(k,i_liarm)/xq(k,i_mp_qg)
    enddo
 
    !---- for charge density
    if ( flg_lt ) then
 
       ! 1.c-g (X=Cloud, Y=Graupel)
       do k = ks, ke
          sw1 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_nc)-small )
          pcrg2(k,i_ngacnc2ng) = pac(k,i_ngacnc2ng)*(1.0_rp-sw1) / (rhoq(k,i_nc)+sw1) * rhoq_crg(k,i_qc)
       end do
 
       ! 2.c-s (X=Cloud, Y=Snow)
       do k = ks, ke
          sw1 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_nc)-small )
          pcrg2(k,i_nsacnc2ns) = pac(k,i_nsacnc2ns)*(1.0_rp-sw1) / (rhoq(k,i_nc)+sw1) * rhoq_crg(k,i_qc)
       end do
 
       ! 3.c-i (X=Cloud, Y=Cloud Ice)
       do k = ks, ke
          sw1 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_nc)-small )
          pcrg2(k,i_niacnc2ni) = pac(k,i_niacnc2ni)*(1.0_rp-sw1) / (rhoq(k,i_nc)+sw1) * rhoq_crg(k,i_qc)
       end do
 
       ! 4.r-g
       do k = ks, ke
          sw1 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_nr)-small )
          sw2 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_ng)-small )
          pcrg2(k,i_nracng2ng) = pac(k,i_nracng2ng)*(1.0_rp-sw1) / (rhoq(k,i_nr)+sw1) * rhoq_crg(k,i_qr)
          pcrg2(k,i_nracng2nr) = pac(k,i_nracng2nr)*(1.0_rp-sw2) / (rhoq(k,i_ng)+sw2) * rhoq_crg(k,i_qg)
       end do
 
       ! 5.r-s
       do k = ks, ke
          sw1 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_nr)-small )
          sw2 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_ns)-small )
          pcrg2(k,i_nracns2ng_r) = pac(k,i_nracns2ng_r)*(1.0_rp-sw1) / (rhoq(k,i_nr)+sw1) * rhoq_crg(k,i_qr)
          pcrg2(k,i_nracns2ng_s) = pac(k,i_nracns2ng_s)*(1.0_rp-sw2) / (rhoq(k,i_ns)+sw2) * rhoq_crg(k,i_qs)
       end do
 
 
       ! 6.r-i
       do k = ks, ke
          sw1 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_nr)-small )
          sw2 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_ni)-small )
          pcrg2(k,i_nracni2ng_r) = pac(k,i_nracni2ng_r)*(1.0_rp-sw1) / (rhoq(k,i_nr)+sw1) * rhoq_crg(k,i_qr)
          pcrg2(k,i_nracni2ng_i) = pac(k,i_nracni2ng_i)*(1.0_rp-sw2) / (rhoq(k,i_ni)+sw2) * rhoq_crg(k,i_qi)
       end do
 
       ! 7.i-g
       do k = ks, ke
          sw1 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_ni)-small )
          pcrg2(k,i_niacng2ng) = pac(k,i_niacng2ng)*(1.0_rp-sw1) / (rhoq(k,i_ni)+sw1) * rhoq_crg(k,i_qi)
       end do
 
       ! 8.i-s
       do k = ks, ke
          sw1 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_ni)-small )
          pcrg2(k,i_niacns2ns) = pac(k,i_niacns2ns)*(1.0_rp-sw1) / (rhoq(k,i_ni)+sw1) * rhoq_crg(k,i_qi)
       end do
 
       ! 9.i-i
       do k = ks, ke
          sw1 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_ni)-small )
          pcrg2(k,i_niacni2ns) = pac(k,i_niacni2ns)*(1.0_rp-sw1) / (rhoq(k,i_ni)+sw1) * rhoq_crg(k,i_qi)
       end do
 
       ! 10.s-g
       do k = ks, ke
          sw1 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_ns)-small )
          pcrg2(k,i_ngacns2ng) = pac(k,i_ngacns2ng)*(1.0_rp-sw1) / (rhoq(k,i_ns)+sw1) * rhoq_crg(k,i_qs)
       end do
 
       ! 11.s-s
       do k = ks, ke
          pcrg2(k,i_nsacns2ns) = 0.0_rp ! no charge transfer between category due to the collection of the same category (snow-snow)
       end do
 
       ! 12.g-g
       do k = ks, ke
          pcrg2(k,i_ngacng2ng) = 0.0_rp ! no charge transfer between category due to the collection of the same category (graupel-graupel)
       end do
 
       !--- Partial conversion
       ! ice-cloud => graupel
       do k = ks, ke
          sw1 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_ni)-small )
          pcrg1(k,i_nicon) = pq(k,i_nicon)*(1.0_rp-sw1) / (rhoq(k,i_ni)+sw1) * rhoq_crg(k,i_qi)
       end do
 
       ! snow-cloud => graupel
       do k = ks, ke
          sw1 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_ns)-small )
          pcrg1(k,i_nscon) = pq(k,i_nscon)*(1.0_rp-sw1) / (rhoq(k,i_ns)+sw1) * rhoq_crg(k,i_qs)
       end do
 
       !--- enhanced melting( due to collection-freezing of water droplets )
       ! cloud-graupel
       do k = ks, ke
          sw1 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_ng)-small )
          pcrg1(k,i_ngacm) = pq(k,i_ngacm)*(1.0_rp-sw1) / (rhoq(k,i_ng)+sw1) * rhoq_crg(k,i_qg)
       end do
 
       ! rain-graupel
       do k = ks, ke
          sw1 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_ng)-small )
          pcrg1(k,i_ngarm) = pq(k,i_ngarm)*(1.0_rp-sw1) / (rhoq(k,i_ng)+sw1) * rhoq_crg(k,i_qg)
       end do
 
       ! cloud-snow
       do k = ks, ke
          sw1 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_ns)-small )
          pcrg1(k,i_nsacm) = pq(k,i_nsacm)*(1.0_rp-sw1) / (rhoq(k,i_ns)+sw1) * rhoq_crg(k,i_qs)
       end do
 
       ! rain-snow
       do k = ks, ke
          sw1 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_ns)-small )
          pcrg1(k,i_nsarm) = pq(k,i_nsarm)*(1.0_rp-sw1) / (rhoq(k,i_ns)+sw1) * rhoq_crg(k,i_qs)
       end do
 
       ! cloud-ice
       do k = ks, ke
          sw1 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_ni)-small )
          pcrg1(k,i_niacm) = pq(k,i_niacm)*(1.0_rp-sw1) / (rhoq(k,i_ni)+sw1) * rhoq_crg(k,i_qi)
       end do
 
       ! rain-ice
       do k = ks, ke
          sw1 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_ni)-small )
          pcrg1(k,i_niarm) = pq(k,i_niarm)*(1.0_rp-sw1) / (rhoq(k,i_ni)+sw1) * rhoq_crg(k,i_qi)
       end do
 
    endif
 
    return
  end subroutine mixed_phase_collection_bin
 
  !----------------------------
  ! Auto-conversion, Accretion, Self-collection, Break-up
!OCL SERIAL
  subroutine aut_acc_slc_brk(  &
       KA, KS, KE,             &
       flg_lt,                 &
       rhoq, rhoq_crg,         &
       xq, dq_xave,            &
       rho,                    &
       PQ, Pcrg                )
    implicit none
 
    integer, intent(in) :: KA, KS, KE
    !
    real(RP), intent(in)  :: rhoq(KA,I_QV:I_NG)
    real(RP), intent(in)  :: rhoq_crg(KA,I_QC:I_QG)
    logical,  intent(in)  :: flg_lt
    real(RP), intent(in)  :: xq(KA,HYDRO_MAX)
    real(RP), intent(in)  :: dq_xave(KA,HYDRO_MAX)
    real(RP), intent(in)  :: rho(KA)
    !
    real(RP), intent(inout) :: PQ(KA,PQ_MAX)
    real(RP), intent(inout) :: Pcrg(KA,PQ_MAX)
    !
    ! parameter for autoconversion
    real(RP), parameter :: kcc     = 4.44e+9_rp  ! collision efficiency [m3/kg2/sec]
    real(RP), parameter :: tau_min = 1.e-20_rp  ! empirical filter by T.Mitsui
    real(RP), parameter :: rx_sep  = 1.0_rp/x_sep ! 1/x_sep, 10/08/03 [Add] T.Mitsui
    !
    ! parameter for accretion
    real(RP), parameter :: kcr     = 5.8_rp     ! collision efficiency [m3/kg2/sec]
    real(RP), parameter :: thr_acc = 5.e-5_rp   ! threshold for universal function original
    !
    ! parameter for self collection and collison break-up
    real(RP), parameter :: krr     = 4.33_rp ! k_rr,      S08 (35)
    real(RP), parameter :: kaprr   = 60.7_rp  ! kappa_rr,  SB06(11)
    real(RP), parameter :: kbr     = 1000._rp ! k_br,      SB06(14)
    real(RP), parameter :: kapbr   = 2.3e+3_rp   ! kappa_br,  SB06(15)
    real(RP), parameter :: dr_min  = 0.35e-3_rp ! minimum diameter, SB06(13)-(15)
    !
    ! work variables
    real(RP) :: coef_nuc0 ! coefficient of number for Auto-conversion
    real(RP) :: coef_nuc1 !                mass
    real(RP) :: coef_aut0 !                number
    real(RP) :: coef_aut1 !                mass
    real(RP) :: lwc       ! lc+lr
    real(RP) :: tau       ! conversion ratio: qr/(qc+qr) ranges [0:1]
    real(RP) :: rho_fac   ! factor of air density
    real(RP) :: psi_aut   ! Universal function of Auto-conversion
    real(RP) :: psi_acc   ! Universal function of Accretion
    real(RP) :: psi_brk   ! Universal function of Breakup
    real(RP) :: ddr       ! diameter difference from equilibrium
    !
    integer :: k, iqw
    real(RP) :: sw
    !
    coef_nuc0 = (nu(i_mp_qc)+2.0_rp)/(nu(i_mp_qc)+1.0_rp)
    coef_nuc1 = (nu(i_mp_qc)+2.0_rp)*(nu(i_mp_qc)+4.0_rp)/(nu(i_mp_qc)+1.0_rp)/(nu(i_mp_qc)+1.0_rp)
    coef_aut0 =  -kcc*coef_nuc0
    coef_aut1 =  -kcc/x_sep/20._rp*coef_nuc1
    !
!OCL LOOP_FISSION_TARGET(LS)
    do k = ks, ke
       lwc = rhoq(k,i_qr) + rhoq(k,i_qc)
       if( lwc > xc_min )then
          tau  = max(tau_min, rhoq(k,i_qr)/lwc)
       else
          tau  = tau_min
       end if
       rho_fac = sqrt(rho_0/max(rho(k),rho_min))
       !
       ! Auto-conversion ( cloud-cloud => rain )
       psi_aut       = 400._rp*(tau**0.7_rp)*(1.0_rp - (tau**0.7_rp))**3   ! (6) SB06
       pq(k,i_ncaut)  = coef_aut0*rhoq(k,i_qc)*rhoq(k,i_qc)*rho_fac*rho_fac    ! (9) SB06 sc+aut
       ! lc = lwc*(1-tau), lr = lwc*tau
       pq(k,i_lcaut)  = coef_aut1*lwc*lwc*xq(k,i_mp_qc)*xq(k,i_mp_qc) &          ! (4) SB06
            *((1.0_rp-tau)*(1.0_rp-tau) + psi_aut)*rho_fac*rho_fac        !
       pq(k,i_nraut)  = -rx_sep*pq(k,i_lcaut)                           ! (A7) SB01
       !--- for Charge density
       if (flg_lt) then
          sw = 0.5_rp - sign( 0.5_rp, rhoq(k,i_nc)-small )
          pcrg(k,i_ncaut) = pq(k,i_ncaut)*(1.0_rp-sw)/(rhoq(k,i_nc)+sw)*rhoq_crg(k,i_qc)
          pcrg(k,i_nraut) = -pcrg(k,i_ncaut)
       end if
       !
       ! Accretion ( cloud-rain => rain )
       psi_acc       =(tau/(tau+thr_acc))**4                          ! (8) SB06
       pq(k,i_lcacc)  = -kcr*rhoq(k,i_qc)*rhoq(k,i_qr)*rho_fac*psi_acc         ! (7) SB06
       pq(k,i_ncacc)  = -kcr*rhoq(k,i_nc)*rhoq(k,i_qr)*rho_fac*psi_acc         ! (A6) SB01
       !--- for Charge density
       if (flg_lt) then
          sw = 0.5_rp - sign( 0.5_rp, rhoq(k,i_nc)-small )
          pcrg(k,i_ncacc)  = pq(k,i_ncacc)*(1.0_rp-sw)/(rhoq(k,i_nc)+sw)*rhoq(k,i_qc)
       end if
       !
       ! Self-collection ( rain-rain => rain )
       pq(k,i_nrslc)  = -krr*rhoq(k,i_nr)*rhoq(k,i_qr)*rho_fac                 ! (A.8) SB01
       !
       ! Collisional breakup of rain
       ddr           = min(1.e-3_rp, dq_xave(k,i_mp_qr) - dr_eq )
       if      ( dq_xave(k,i_mp_qr) < dr_min ) then       ! negligible
          psi_brk      = -1.0_rp
       else if ( dq_xave(k,i_mp_qr) <= dr_eq  ) then
          psi_brk      = kbr*ddr                          ! (14) SB06
       else
          psi_brk      = exp(kapbr*ddr) - 1.0_rp          ! (15) SB06 (SB06 has a typo)
       end if
       pq(k,i_nrbrk) = - (psi_brk + 1.0_rp)*pq(k,i_nrslc) ! (13) SB06
       !
    end do
    !
    return
  end subroutine aut_acc_slc_brk
 
  ! Vapor Deposition, Ice Melting
!OCL SERIAL
  subroutine dep_vapor_melt_ice( &
       KA, KS, KE, &
       rho, tem, pre, qd,    & ! in
       rhoq,                 & ! in
       esw, esi,             & ! in
       xq, vt_xave, dq_xave, & ! in
       PQ                    ) ! inout
    use scale_const, only: &
       eps => const_eps
    implicit none
 
    integer, intent(in) :: KA, KS, KE
 
    ! Diffusion growth or Evaporation, Sublimation
    real(RP), intent(inout) :: PQ(KA,PQ_MAX)  ! mass change   for cloud
 
    real(RP), intent(in)  :: rho(KA)     ! air density
    real(RP), intent(in)  :: tem(KA)     ! air temperature
    real(RP), intent(in)  :: pre(KA)     ! air pressure
    real(RP), intent(in)  :: qd (KA)      ! mixing ratio of dry air
    real(RP), intent(in)  :: esw(KA)     ! saturation vapor pressure(liquid water)
    real(RP), intent(in)  :: esi(KA)     ! saturation vapor pressure(solid water)
    real(RP), intent(in)  :: rhoq(KA,I_QV:I_NG)
    real(RP), intent(in)  :: xq(KA,HYDRO_MAX)    ! mean mass
    ! Notice following values differ from mean terminal velocity or diameter.
    ! mean(vt(x)) /= vt(mean(x)) and mean(D(x)) /= D(mean(x))
    ! Following ones are vt(mean(x)) and D(mean(x)).
    real(RP), intent(in)  :: vt_xave(KA,HYDRO_MAX,2) ! terminal velocity of mean cloud
    !
    real(RP), intent(in)  :: dq_xave(KA,HYDRO_MAX) ! diameter
    !
    real(RP) :: rho_lim            ! limited density
    real(RP) :: temc_lim           ! limited temperature[celsius]
    real(RP) :: pre_lim            ! limited density
    real(RP) :: temc               ! temperature[celsius]
!    real(RP) :: pv                 ! vapor pressure
    real(RP) :: qv                 ! mixing ratio of water vapor
!    real(RP) :: ssw                ! super saturation ratio(liquid water)
!    real(RP) :: ssi                ! super saturation ratio(ice water)
    real(RP) :: nua, r_nua         ! kinematic viscosity of air
    real(RP) :: mua                ! viscosity of air
    real(RP) :: Kalfa(KA)          ! thermal conductance
    real(RP) :: Dw(KA)             ! diffusivity of water vapor
    real(RP) :: Dt                 ! diffusivity of heat
    real(RP) :: Gw, Gi             ! diffusion factor by balance between heat and vapor
    real(RP) :: Gwr, Gii, Gis, Gig ! for rain, ice, snow and graupel.
    real(RP) :: Gm                 ! melting factor by balance between heat and vapor
    real(RP) :: Nsc_r3             !
    ! [Mod] 11/08/30 T.Mitsui, considering large and small branches
!    real(RP) :: Nrecs_r2
    real(RP) :: Nrers_r2, Nreis_r2  !
    real(RP) :: Nress_r2, Nregs_r2  !
!    real(RP) :: Nrecl_r2
    real(RP) :: Nrerl_r2, Nreil_r2  !
    real(RP) :: Nresl_r2, Nregl_r2  !
    real(RP) :: NscNrer_s, NscNrer_l
    real(RP) :: NscNrei_s, NscNrei_l
    real(RP) :: NscNres_s, NscNres_l
    real(RP) :: NscNreg_s, NscNreg_l
    real(RP) :: ventLR_s, ventLR_l
    real(RP) :: ventNI_s, ventNI_l, ventLI_s, ventLI_l
    real(RP) :: ventNS_s, ventNS_l, ventLS_s, ventLS_l
    real(RP) :: ventNG_s, ventNG_l, ventLG_s, ventLG_l
    !
    real(RP) :: wtr, wti, wts, wtg
    real(RP), parameter :: r_14=1.0_rp/1.4_rp
    real(RP), parameter :: r_15=1.0_rp/1.5_rp
    !
    real(RP) ::         ventLR
    real(RP) :: ventNI(KA), ventLI(KA)
    real(RP) :: ventNS(KA), ventLS(KA)
    real(RP) :: ventNG(KA), ventLG(KA)
    !
    real(RP), parameter :: Re_max=1.e+3_rp
    real(RP), parameter :: Re_min=1.e-4_rp
 
    real(RP) :: sw
    !
    integer :: k
    !
    ! Notice,T.Mitsui
    ! Vapor deposition and melting would not be solved iteratively to reach equilibrium.
    ! Because following phenomena are not adjustment but transition.
    ! Just time-scales differ among them.
    ! If we would treat more appropreately, there would be time-splitting method to solve each ones.
 
!OCL LOOP_FISSION_TARGET(LS)
    do k = ks, ke
       temc    = tem(k) - t00   ! degC
       temc_lim= max(temc, -40._rp )       ! [Add] 09/08/18 T.Mitsui, Pruppacher and Klett(1997),(13-3)
       rho_lim = max(rho(k),rho_min)   ! [Add] 09/08/18 T.Mitsui
       qv      = rhoq(k,i_qv)/rho_lim
       pre_lim = rho_lim*(qd(k)*rdry + qv*rvap)*(temc_lim+t00) ![Add] 09/08/18 T.Mitsui
       !--------------------------------------------------------------------
       ! Diffusion growth part is described in detail
       ! by Pruppacher and Klett (1997) Sec. 13.2(liquid) and 13.3(solid)
       !
       ! G:factor of thermal diffusion(1st.term) and vapor diffusion(2nd. term)
       ! SB06(23),(38), Lin et al(31),(52) or others
       ! Dw is introduced by Pruppacher and Klett(1997),(13-3)
       dw(k)    = 0.211e-4_rp* (((temc_lim+t00)/t00)**1.94_rp) *(p00/pre_lim)
       kalfa(k) = ka0  + temc_lim*dka_dt
       mua     = mua0 + temc_lim*dmua_dt
       nua     = mua/rho_lim
       r_nua   = 1.0_rp/nua
       gw      = (lhv0/kalfa(k)/tem(k))*(lhv0/rvap/tem(k)-1.0_rp)+(rvap*tem(k)/dw(k)/esw(k))
       gi      = (lhs0/kalfa(k)/tem(k))*(lhs0/rvap/tem(k)-1.0_rp)+(rvap*tem(k)/dw(k)/esi(k))
       ! capacities account for their surface geometries
       gwr     = 4.0_rp*pi/cap(i_mp_qr)/gw
       gii     = 4.0_rp*pi/cap(i_mp_qi)/gi
       gis     = 4.0_rp*pi/cap(i_mp_qs)/gi
       gig     = 4.0_rp*pi/cap(i_mp_qg)/gi
       ! vent: ventilation effect( asymmetry vapor field around particles due to aerodynamic )
       ! SB06 (30),(31) and each coefficient is by (88),(89)
       nsc_r3  = (nua/dw(k))**(0.33333333_rp)                    ! (Schmidt number )^(1/3)
       !
!       Nrecs_r2 = sqrt(max(Re_min,min(Re_max,vt_xave(k,I_mp_QC,1)*dq_xave(k,I_mp_QC)*r_nua))) ! (Reynolds number)^(1/2) cloud
       nrers_r2 = sqrt(max(re_min,min(re_max,vt_xave(k,i_mp_qr,1)*dq_xave(k,i_mp_qr)*r_nua))) ! (Reynolds number)^(1/2) rain
       nreis_r2 = sqrt(max(re_min,min(re_max,vt_xave(k,i_mp_qi,1)*dq_xave(k,i_mp_qi)*r_nua))) ! (Reynolds number)^(1/2) cloud ice
       nress_r2 = sqrt(max(re_min,min(re_max,vt_xave(k,i_mp_qs,1)*dq_xave(k,i_mp_qs)*r_nua))) ! (Reynolds number)^(1/2) snow
       nregs_r2 = sqrt(max(re_min,min(re_max,vt_xave(k,i_mp_qg,1)*dq_xave(k,i_mp_qg)*r_nua))) ! (Reynolds number)^(1/2) graupel
       !
!       Nrecl_r2 = sqrt(max(Re_min,min(Re_max,vt_xave(k,I_mp_QC,2)*dq_xave(k,I_mp_QC)*r_nua))) ! (Reynolds number)^(1/2) cloud
       nrerl_r2 = sqrt(max(re_min,min(re_max,vt_xave(k,i_mp_qr,2)*dq_xave(k,i_mp_qr)*r_nua))) ! (Reynolds number)^(1/2) rain
       nreil_r2 = sqrt(max(re_min,min(re_max,vt_xave(k,i_mp_qi,2)*dq_xave(k,i_mp_qi)*r_nua))) ! (Reynolds number)^(1/2) cloud ice
       nresl_r2 = sqrt(max(re_min,min(re_max,vt_xave(k,i_mp_qs,2)*dq_xave(k,i_mp_qs)*r_nua))) ! (Reynolds number)^(1/2) snow
       nregl_r2 = sqrt(max(re_min,min(re_max,vt_xave(k,i_mp_qg,2)*dq_xave(k,i_mp_qg)*r_nua))) ! (Reynolds number)^(1/2) graupel
       nscnrer_s=nsc_r3*nrers_r2 ! small rain
       nscnrer_l=nsc_r3*nrerl_r2 ! large rain
       !
       nscnrei_s=nsc_r3*nreis_r2 ! small ice
       nscnrei_l=nsc_r3*nreil_r2 ! large ice
       !
       nscnres_s=nsc_r3*nress_r2 ! small snow
       nscnres_l=nsc_r3*nresl_r2 ! large snow
       !
       nscnreg_s=nsc_r3*nregs_r2 ! small snow
       nscnreg_l=nsc_r3*nregl_r2 ! large snow
       !
       ventlr_s = ah_vent1(i_mp_qr,1) + bh_vent1(i_mp_qr,1)*nscnrer_s
       ventlr_l = ah_vent1(i_mp_qr,2) + bh_vent1(i_mp_qr,2)*nscnrer_l
       !
       ventni_s = ah_vent0(i_mp_qi,1) + bh_vent0(i_mp_qi,1)*nscnrei_s
       ventni_l = ah_vent0(i_mp_qi,2) + bh_vent0(i_mp_qi,2)*nscnrei_l
       ventli_s = ah_vent1(i_mp_qi,1) + bh_vent1(i_mp_qi,1)*nscnrei_s
       ventli_l = ah_vent1(i_mp_qi,2) + bh_vent1(i_mp_qi,2)*nscnrei_l
       !
       ventns_s = ah_vent0(i_mp_qs,1) + bh_vent0(i_mp_qs,1)*nscnres_s
       ventns_l = ah_vent0(i_mp_qs,2) + bh_vent0(i_mp_qs,2)*nscnres_l
       ventls_s = ah_vent1(i_mp_qs,1) + bh_vent1(i_mp_qs,1)*nscnres_s
       ventls_l = ah_vent1(i_mp_qs,2) + bh_vent1(i_mp_qs,2)*nscnres_l
       !
       ventng_s = ah_vent0(i_mp_qg,1) + bh_vent0(i_mp_qg,1)*nscnreg_s
       ventng_l = ah_vent0(i_mp_qg,2) + bh_vent0(i_mp_qg,2)*nscnreg_l
       ventlg_s = ah_vent1(i_mp_qg,1) + bh_vent1(i_mp_qg,1)*nscnreg_s
       ventlg_l = ah_vent1(i_mp_qg,2) + bh_vent1(i_mp_qg,2)*nscnreg_l
       !
       ! branch is 1.4 for rain, snow, graupel; is 1.0 for ice (PK97, 13-60,-61,-88,-89).
       !
       wtr     = ( min(max( nscnrer_s*r_14, 0.5_rp), 2.0_rp) -0.5_rp )*r_15 ! weighting between 1.4*0.5 and 1.4*2
       wti     = ( min(max( nscnrei_s     , 0.5_rp), 2.0_rp) -0.5_rp )*r_15 ! weighting between 1.0*0.5 and 1.0*2
       wts     = ( min(max( nscnres_s*r_14, 0.5_rp), 2.0_rp) -0.5_rp )*r_15 ! weighting between 1.4*0.5 and 1.4*2
       wtg     = ( min(max( nscnreg_s*r_14, 0.5_rp), 2.0_rp) -0.5_rp )*r_15 ! weighting between 1.4*0.5 and 1.4*2
       ! interpolation between two branches
       ventni(k) = (1.0_rp-wti)*ventni_s + wti*ventni_l
       ventns(k) = (1.0_rp-wts)*ventns_s + wts*ventns_l
       ventng(k) = (1.0_rp-wtg)*ventng_s + wtg*ventng_l
       !
       ventlr    = (1.0_rp-wtr)*ventlr_s + wtr*ventlr_l
       ventli(k) = (1.0_rp-wti)*ventli_s + wti*ventli_l
       ventls(k) = (1.0_rp-wts)*ventls_s + wts*ventls_l
       ventlg(k) = (1.0_rp-wtg)*ventlg_s + wtg*ventlg_l
       !
       ! SB06(29)
       ! [Mod] 08/05/08 T.Mitsui, recover PNXdep, and rain is only evaporation.
       ! Ni, Ns, Ng should decrease in nature so we add this term.
       ! And vapor deposition never occur unless number exist.
       ! [Add comment]  09/08/18
       ! recover condensation/evaporation of rain,
       ! and ventilation effects are not taken into account for cloud.
       !
!!$***************************************************************************
!!$        NOTICE:
!!$         Hereafter PLxdep means inverse of timescale.
!!$***************************************************************************
!!$     PQ(k,I_LCdep) = Gwr*ssw*rhoq(k,I_NC)*dq_xave(k,I_mp_QC)*coef_deplc
!!$     PQ(k,I_LRdep) = Gwr*ssw*rhoq(k,I_NR)*dq_xave(k,I_mp_QR)*ventLR
!!$     PQ(k,I_LIdep) = Gii*ssi*rhoq(k,I_NI)*dq_xave(k,I_mp_QI)*ventLI(k)
!!$     PQ(k,I_LSdep) = Gis*ssi*rhoq(k,I_NS)*dq_xave(k,I_mp_QS)*ventLS(k)
!!$     PQ(k,I_LGdep) = Gig*ssi*rhoq(k,I_NG)*dq_xave(k,I_mp_QG)*ventLG(k)
       pq(k,i_lcdep) = gwr*rhoq(k,i_nc)*dq_xave(k,i_mp_qc)*coef_deplc
       pq(k,i_lrdep) = gwr*rhoq(k,i_nr)*dq_xave(k,i_mp_qr)*ventlr
       pq(k,i_lidep) = gii*rhoq(k,i_ni)*dq_xave(k,i_mp_qi)*ventli(k)
       pq(k,i_lsdep) = gis*rhoq(k,i_ns)*dq_xave(k,i_mp_qs)*ventls(k)
       pq(k,i_lgdep) = gig*rhoq(k,i_ng)*dq_xave(k,i_mp_qg)*ventlg(k)
       pq(k,i_nrdep) = pq(k,i_lrdep)/xq(k,i_mp_qr)
       pq(k,i_nidep) = 0.0_rp
       pq(k,i_nsdep) = pq(k,i_lsdep)/xq(k,i_mp_qs)
       pq(k,i_ngdep) = pq(k,i_lgdep)/xq(k,i_mp_qg)
    end do
 
    do k = ks, ke
       temc    = tem(k) - t00   ! degC
       !------------------------------------------------------------------------
       ! Melting part is described by Pruppacher and Klett (1997) Sec.16.3.1
       ! Here we omit "Shedding" of snow-flakes and ice-particles.
       ! "Shedding" may be applicative if you refer
       ! eq.(38) in Cotton etal.(1986) Jour. Clim. Appl. Meteor. p.1658-1680.
       ! SB06(73)
       dt      = kalfa(k)/(cpvap*rho_0)
       ! Gm: factor caused by balance between
       !     "water evaporation cooling(1st.)" and "fusion heating(2nd.)"
       ! SB06(76)
       ! [fix] 08/05/08 T.Mitsui  LHF00 => EMELT  and  esw => PSAT0
       ! LHS0 is more suitable than LHS because melting occurs around 273.15 K.
       gm      = 2.0_rp*pi/emelt&
               * ( (kalfa(k)*dt/dw(k))*(temc) + (dw(k)*lhs0/rvap)*(esi(k)/tem(k)-psat0/t00) )
       ! SB06(76)
       ! Notice! melting only occurs where T > 273.15 K else doesn't.
       ! [fix] 08/05/08 T.Mitsui, Gm could be both positive and negative value.
       !       See Pruppacher and Klett(1997) eq.(16-79) or Rasmussen and Pruppacher(1982)
       sw = ( sign(0.5_rp,temc) + 0.5_rp ) * ( sign(0.5_rp,gm-eps) + 0.5_rp ) ! sw = 1 if( (temc>=0.0_RP) .AND. (Gm>0.0_RP) ), otherwise sw = 0
       !  if Gm==0 then rh and tem is critical value for melting process.
       ! 08/05/16 [Mod] T.Mitsui, change term of PLimlt. N_i => L_i/ (limited x_i)
       ! because melting never occur when N_i=0.
       pq(k,i_limlt) = - gm * rhoq(k,i_qi)*dq_xave(k,i_mp_qi)*ventli(k)/xq(k,i_mp_qi) * sw
       pq(k,i_nimlt) = - gm * rhoq(k,i_ni)*dq_xave(k,i_mp_qi)*ventni(k)/xq(k,i_mp_qi) * sw
       pq(k,i_lsmlt) = - gm * rhoq(k,i_qs)*dq_xave(k,i_mp_qs)*ventls(k)/xq(k,i_mp_qs) * sw
       pq(k,i_nsmlt) = - gm * rhoq(k,i_ns)*dq_xave(k,i_mp_qs)*ventns(k)/xq(k,i_mp_qs) * sw
       pq(k,i_lgmlt) = - gm * rhoq(k,i_qg)*dq_xave(k,i_mp_qg)*ventlg(k)/xq(k,i_mp_qg) * sw
       pq(k,i_ngmlt) = - gm * rhoq(k,i_ng)*dq_xave(k,i_mp_qg)*ventng(k)/xq(k,i_mp_qg) * sw
    end do
 
    return
  end subroutine dep_vapor_melt_ice
  !-----------------------------------------------------------------------------
 
  ! Vapor Deposition [Add] 2022/03/23 T.Seiki for nucleation
!OCL SERIAL
  subroutine dep_vapor_ice_wrk(  &
       KA, KS, KE,                &
       PLIdep_total,              &
       rho, tem, pre,             &
       qd,                        &
       esi,  qsi,                 &
       rhoq,                      &
       vt_xave, dq_xave,          &
       dt                         )
    use scale_const, only: &
         rvap    =>  const_rvap,      &
         rdry    =>  const_rdry,      &
         t00     =>  const_tem00,     &
         lhs0    =>  const_lhs0,      &
         lhf00   =>  const_lhf00,     &
         pi      =>  const_pi,        &
         cpdry   =>  const_cpdry,     &
         pstd    =>  const_pstd,      &
         psat0   =>  const_psat0
    implicit none
 
    integer, intent(in)  :: KA
    integer, intent(in)  :: KS
    integer, intent(in)  :: KE
    ! Diffusion growth or Evaporation, Sublimation
    real(RP), intent(out) :: PLIdep_total(KA)  ! mass          for cloud ice
    real(RP), intent(in)  :: rho(KA)     ! air density
    real(RP), intent(in)  :: tem(KA)     ! air temperature
    real(RP), intent(in)  :: pre(KA)     ! air pressure
    real(RP), intent(in)  :: qd(KA)      ! mixing ratio of dry air
    real(RP), intent(in)  :: esi(KA)     ! saturation vapor pressure(solid water)
    real(RP), intent(in)  :: qsi(KA)     ! saturation vapor pressure(solid water)
    real(RP), intent(in)  :: rhoq(KA,I_QV:I_NG)
    ! Notice following values differ from mean terminal velocity or diameter.
    ! mean(vt(x)) /= vt(mean(x)) and mean(D(x)) /= D(mean(x))
    ! Following ones are vt(mean(x)) and D(mean(x)).
    real(RP), intent(in)  :: vt_xave(KA,HYDRO_MAX,1:2) ! terminal velocity of mean cloud
    real(RP), intent(in)  :: dq_xave(KA,HYDRO_MAX) !
    real(RP), intent(in)  :: dt
    !
!    real(RP), intent(in)  :: dtime
!    real(RP) :: dtime
    !
    real(RP) :: rho_lim            ! limited density
    real(RP) :: temc_lim           ! limited temperature[celsius]
    real(RP) :: pre_lim            ! limited density
    real(RP) :: temc               ! temperature[celsius]
    real(RP) :: pv                 ! vapor pressure
    real(RP) :: qv                 ! vapor pressure
    real(RP) :: ssi                ! super saturation ratio(ice water)
    real(RP) :: nua, r_nua         ! kinematic viscosity of air
    real(RP) :: mua                ! viscosity of air
    real(RP) :: Kat                 ! thermal conductance
    real(RP) :: Dw                 ! diffusivity of water vapor
    real(RP) :: Dht                 ! diffusivity of heat
    real(RP) :: Gi                 ! diffusion factor by balance between heat and vapor
    real(RP) :: Gii, Gis, Gig      ! for rain, ice, snow and graupel.
    real(RP) :: Gm                 ! melting factor by balance between heat and vapor
    real(RP) :: Nsc_r3             !
    !
    real(RP) :: Nreis_r2  !
    real(RP) :: Nress_r2, Nregs_r2  !
    real(RP) :: Nreil_r2  !
    real(RP) :: Nresl_r2, Nregl_r2  !
    real(RP) :: NscNrei_s, NscNrei_l
    real(RP) :: NscNres_s, NscNres_l
    real(RP) :: NscNreg_s, NscNreg_l
    real(RP) :: ventLI_s, ventLI_l
    real(RP) :: ventLS_s, ventLS_l
    real(RP) :: ventLG_s, ventLG_l
    real(RP) :: wti, wts, wtg
    real(RP), parameter :: r_14=1.0_rp/1.4_rp
    real(RP), parameter :: r_15=1.0_rp/1.5_rp
    real(RP) :: ventLI !
    real(RP) :: ventLS !
    real(RP) :: ventLG !
    !
    real(RP) :: total_dep
    real(RP) :: PLIdep_wrk
    real(RP) :: PLSdep_wrk
    real(RP) :: PLGdep_wrk
    real(RP) :: dep_limiter
    !
    real(RP), parameter :: Re_max=1.e3_rp
    real(RP), parameter :: Re_min=1.e-4_rp
    integer :: k
    !
!    PLIdep_total(1:KS)=0.0_RP
!    PLIdep_total(KE:KA)=0.0_RP
    plidep_total(:)=0.0_rp  !! 22/10/14
 
    !
    do k=ks, ke
       temc    = tem(k) - t00   ! degC
       temc_lim= max(temc, temc_lim_diff) !
       rho_lim = max(rho(k),rho_min)   !
       qv      = rhoq(k,i_qv)/rho_lim
       pre_lim = rho_lim*(qd(k)*rdry + qv*rvap)*(temc_lim+t00)
       !--------------------------------------------------------------------
       ! Diffusion growth part is described in detail
       ! by Pruppacher and Klett (1997) Sec. 13.2(liquid) and 13.3(solid)
       ! G:factor of thermal diffusion(1st.term) and vapor diffusion(2nd. term)
       ! SB06(23),(38), Lin et al(31),(52) or others
       ! Dw is introduced by Pruppacher and Klett(1997),(13-3)
       dw      = 0.211e-4_rp* (((temc_lim+t00)/t00)**1.94_rp) *(pstd/pre_lim)
       kat     = ka0  + temc_lim*dka_dt
       mua     = mua0 + temc_lim*dmua_dt
       nua     = mua/rho_lim
       r_nua   = 1.0_rp/nua
       gi      = (lhs0/kat/tem(k))*(lhs0/rvap/tem(k)-1.0_rp)+(rvap*tem(k)/dw/esi(k))
       ! capacities account for their surface geometries
       gii     = 4.0_rp*pi/cap(i_mp_qi)/gi
       gis     = 4.0_rp*pi/cap(i_mp_qs)/gi
       gig     = 4.0_rp*pi/cap(i_mp_qg)/gi
       ! vent: ventilation effect( asymmetry vapor field around particles due to aerodynamic )
       ! SB06 (30),(31) and each coefficient is by (88),(89)
       nsc_r3  = (nua/dw)**(0.33333333_rp)                    ! (Schmidt number )^(1/3)
       ! Beard and Pruppacher(1971) had performed in the range [0<Re<=320],
       ! So here we limit Re in the range Re_max=1000, Re_min=0.0001.
       nreis_r2 = sqrt(max(re_min,min(re_max,vt_xave(k,i_mp_qi,1)*dq_xave(k,i_mp_qi)*r_nua))) ! (Reynolds number)^(1/2) cloud ice
       nress_r2 = sqrt(max(re_min,min(re_max,vt_xave(k,i_mp_qs,1)*dq_xave(k,i_mp_qs)*r_nua))) ! (Reynolds number)^(1/2) snow
       nregs_r2 = sqrt(max(re_min,min(re_max,vt_xave(k,i_mp_qg,1)*dq_xave(k,i_mp_qg)*r_nua))) ! (Reynolds number)^(1/2) graupel
       nreil_r2 = sqrt(max(re_min,min(re_max,vt_xave(k,i_mp_qi,2)*dq_xave(k,i_mp_qi)*r_nua))) ! (Reynolds number)^(1/2) cloud ice
       nresl_r2 = sqrt(max(re_min,min(re_max,vt_xave(k,i_mp_qs,2)*dq_xave(k,i_mp_qs)*r_nua))) ! (Reynolds number)^(1/2) snow
       nregl_r2 = sqrt(max(re_min,min(re_max,vt_xave(k,i_mp_qg,2)*dq_xave(k,i_mp_qg)*r_nua))) ! (Reynolds number)^(1/2) graupel
       !
       nscnrei_s=nsc_r3*nreis_r2 ! small ice
       nscnrei_l=nsc_r3*nreil_r2 ! large ice
       nscnres_s=nsc_r3*nress_r2 ! small snow
       nscnres_l=nsc_r3*nresl_r2 ! large snow
       nscnreg_s=nsc_r3*nregs_r2 ! small snow
       nscnreg_l=nsc_r3*nregl_r2 ! large snow
       !
       ventli_s = ah_vent1(i_mp_qi,1) + bh_vent1(i_mp_qi,1)*nscnrei_s
       ventli_l = ah_vent1(i_mp_qi,2) + bh_vent1(i_mp_qi,2)*nscnrei_l
       ventls_s = ah_vent1(i_mp_qs,1) + bh_vent1(i_mp_qs,1)*nscnres_s
       ventls_l = ah_vent1(i_mp_qs,2) + bh_vent1(i_mp_qs,2)*nscnres_l
       ventlg_s = ah_vent1(i_mp_qg,1) + bh_vent1(i_mp_qg,1)*nscnreg_s
       ventlg_l = ah_vent1(i_mp_qg,2) + bh_vent1(i_mp_qg,2)*nscnreg_l
       ! branch is 1.4 for rain, snow, graupel; is 1.0 for ice (PK97, 13-60,-61,-88,-89).
       wti     = ( min(max( nscnrei_s     , 0.5_rp), 2.0_rp) -0.5_rp )*r_15 ! weighting between 1.0*0.5 and 1.0*2
       wts     = ( min(max( nscnres_s*r_14, 0.5_rp), 2.0_rp) -0.5_rp )*r_15 ! weighting between 1.4*0.5 and 1.4*2
       wtg     = ( min(max( nscnreg_s*r_14, 0.5_rp), 2.0_rp) -0.5_rp )*r_15 ! weighting between 1.4*0.5 and 1.4*2
       ! interpolation between two branches
       ventli  = (1.0_rp-wti)*ventli_s + wti*ventli_l
       ventls  = (1.0_rp-wts)*ventls_s + wts*ventls_l
       ventlg  = (1.0_rp-wtg)*ventlg_s + wtg*ventlg_l
       ! SB06(29)
       ssi         = qv/qsi(k) - 1.0_rp  ! supersaturation
       plidep_wrk  = gii*ssi*max(rhoq(k,i_ni),0.0_rp)*dq_xave(k,i_mp_qi)*ventli
       plsdep_wrk  = gis*ssi*max(rhoq(k,i_ns),0.0_rp)*dq_xave(k,i_mp_qs)*ventls
       plgdep_wrk  = gig*ssi*max(rhoq(k,i_ng),0.0_rp)*dq_xave(k,i_mp_qg)*ventlg
       !
       dep_limiter = rho(k)*(qv-qsi(k))/dt
       if      (ssi < -1.e-30_rp)then ! unsaturated
          plidep_total(k) = max(plidep_wrk+plsdep_wrk+plgdep_wrk, dep_limiter)
       else if (ssi >  1.e-30_rp)then !  saturated
          plidep_total(k) = min(plidep_wrk+plsdep_wrk+plgdep_wrk, dep_limiter)
       else
          plidep_total(k) = 0.0_rp
       end if
    enddo
 
    return
  end subroutine dep_vapor_ice_wrk
 
 
!OCL SERIAL
  subroutine freezing_water( &
       KA, KS, KE, &
       dt,            &
       rhoq, xq, tem, &
       PQ             )
    implicit none
    !
    ! In this subroutine,
    ! We assumed surface temperature of droplets are same as environment.
 
    integer, intent(in) :: KA, KS, KE
 
    real(RP), intent(in) :: dt
    !
    real(RP), intent(in) :: tem(KA)
    !
    real(RP), intent(in) :: rhoq(KA,I_QV:I_NG)
    real(RP), intent(in) :: xq(KA,HYDRO_MAX)
    !
    real(RP), intent(inout):: PQ(KA,PQ_MAX)
    !
    real(RP), parameter :: temc_min = -65.0_rp
    real(RP), parameter :: a_het = 0.2_rp  ! SB06 (44)
    real(RP), parameter :: b_het = 0.65_rp ! SB06 (44)
    !
    real(RP) :: coef_m2_c
    real(RP) :: coef_m2_r
    ! temperature [celsius]
    real(RP) :: temc, temc2, temc3, temc4
    ! temperature function of homegenous/heterogenous freezing
    real(RP) :: Jhom, Jhet, Jh(KA)
    real(RP) :: rdt
    real(RP) :: tmp
    !
    integer :: k
    !
    rdt = 1.0_rp/dt
    !
    coef_m2_c =   coef_m2(i_mp_qc)
    coef_m2_r =   coef_m2(i_mp_qr)
    !
 
    ! Note, xc should be limited in range[xc_min:xc_max].
    ! and PNChom need to be calculated by NC
    ! because reduction rate of Nc need to be bound by NC.
    ! For the same reason PLChom also bound by LC and xc.
    ! Basically L and N should be independent
    ! but average particle mass x should be in suitable range.
 
    ! Homogenous Freezing
    do k = ks, ke
       pq(k,i_lchom) = 0.0_rp
       pq(k,i_nchom) = 0.0_rp
    end do
 
    ! Heterogenous Freezing
    do k = ks, ke
       temc = max( tem(k) - t00, temc_min )
       ! These cause from aerosol-droplet interaction.
       ! Bigg(1953) formula, Khain etal.(2000) eq.(4.5), Pruppacher and Klett(1997) eq.(9-48)
       jhet =  a_het*( exp( -b_het*temc ) - 1.0_rp )
       ! These cause in nature.
       ! Cotton and Field 2002, QJRMS. (12)
       if( temc < -30.0_rp ) then
          temc2 = temc*temc
          temc3 = temc*temc2
          temc4 = temc2*temc2
          jhom = 10.0_rp**(&
               - 243.40_rp - 14.75_rp*temc - 0.307_rp*temc2 &
               - 0.00287_rp*temc3 - 0.0000102_rp*temc4 ) *1.e+3_rp
       else if( temc < 0.0_rp) then
          jhom = 10._rp**(-7.63_rp-2.996_rp*(temc+30.0_rp))*1.e+3_rp
       else
          jhom = 0.0_rp
          jhet = 0.0_rp
       end if
       jh(k) = ( jhet + jhom ) * dt
    end do
 
    do k = ks, ke
#if defined(NVIDIA) || defined(SX)
       tmp = min( xq(k,i_mp_qc)*jh(k), 1.e+3_rp) ! apply exp limiter
       pq(k,i_lchet) = -rdt*rhoq(k,i_qc)*( 1.0_rp - exp( -coef_m2_c*tmp ) )
       pq(k,i_nchet) = -rdt*rhoq(k,i_nc)*( 1.0_rp - exp( -          tmp ) )
 
       tmp = min( xq(k,i_mp_qr)*jh(k), 1.e+3_rp) ! apply exp limiter
       pq(k,i_lrhet) = -rdt*rhoq(k,i_qr)*( 1.0_rp - exp( -coef_m2_r*tmp ) )
       pq(k,i_nrhet) = -rdt*rhoq(k,i_nr)*( 1.0_rp - exp( -          tmp ) )
#else
       pq(k,i_lchet) = -rdt*rhoq(k,i_qc)*( 1.0_rp - exp( -coef_m2_c*xq(k,i_mp_qc)*jh(k) ) )
       pq(k,i_nchet) = -rdt*rhoq(k,i_nc)*( 1.0_rp - exp( -          xq(k,i_mp_qc)*jh(k) ) )
       pq(k,i_lrhet) = -rdt*rhoq(k,i_qr)*( 1.0_rp - exp( -coef_m2_r*xq(k,i_mp_qr)*jh(k) ) )
       pq(k,i_nrhet) = -rdt*rhoq(k,i_nr)*( 1.0_rp - exp( -          xq(k,i_mp_qr)*jh(k) ) )
#endif
    end do
 
    !
    return
  end subroutine freezing_water
 
  !----------------------------------------------------------------
!OCL SERIAL
  subroutine update_by_phase_change(   &
       KA, KS, KE, &
       ntmax,                & ! in
       dt,                   & ! in
       cz,                   & ! in
       fz,                   & ! in
       w,                    & ! in
       dTdt_rad,             & ! in
       rho,                  & ! in
       qdry,                 & ! in
       esw, esi, rhoq,       & ! in
       pre, tem,             & ! in
       cpa,cva,              & ! in
       flg_lt,               & ! in
       PQ,                   & ! inout
       sl_PLCdep,            & ! inout
       sl_PLRdep, sl_PNRdep, & ! inout
       RHOQ_t,               & ! out
       RHOE_t,               & ! out
       CPtot_t,              & ! out
       CVtot_t,              & ! out
       qc_evaporate,         & ! out
       rhoq_crg,             & ! in:optional
       RHOQcrg_t             ) ! out:optional
 
    use scale_atmos_hydrometeor, only: &
       cp_vapor, &
       cp_water, &
       cp_ice,   &
       cv_vapor, &
       cv_water, &
       cv_ice
    use scale_atmos_saturation, only: &
       moist_pres2qsat_liq  => atmos_saturation_pres2qsat_liq,  &
       moist_pres2qsat_ice  => atmos_saturation_pres2qsat_ice,  &
       moist_dqs_dtem_dens_liq  => atmos_saturation_dqs_dtem_dens_liq,  &
       moist_dqs_dtem_dens_ice  => atmos_saturation_dqs_dtem_dens_ice,  &
       moist_dqs_dtem_dpre_liq => atmos_saturation_dqs_dtem_dpre_liq, &
       moist_dqs_dtem_dpre_ice => atmos_saturation_dqs_dtem_dpre_ice
    implicit none
 
    integer, intent(in) :: KA, KS, KE
 
    integer, intent(in)    :: ntmax
    !
    real(RP), intent(in)   :: dt           ! time step[s]
    real(RP), intent(in)   :: cz(KA)       ! altitude [m]
    real(RP), intent(in)   :: fz(0:KA)       ! altitude difference [m]
    real(RP), intent(in)   :: w (KA)       ! vertical velocity @ full level [m/s]
    real(RP), intent(in)   :: dTdt_rad(KA) ! temperture tendency by radiation[K/s]
    real(RP), intent(in)   :: rho (KA)     ! density[kg/m3]
    real(RP), intent(in)   :: qdry(KA)     ! dry air mass ratio [kg/kg]
    real(RP), intent(in)   :: esw (KA)     ! saturated vapor pressure for liquid
    real(RP), intent(in)   :: esi (KA)     !                          for ice
    real(RP), intent(in)   :: rhoq(KA,I_QV:I_NG)
 
    real(RP), intent(in)   :: tem(KA)      ! temperature[K]
    real(RP), intent(in)   :: pre(KA)      ! pressure[Pa]
    real(RP), intent(in)   :: cpa(KA)      !
    real(RP), intent(in)   :: cva(KA)      ! specific heat at constant volume
 
    !+++ tendency[kg/m3/s]
    real(RP), intent(inout) :: PQ(KA,PQ_MAX)
    !+++ Column integrated tendency[kg/m2/s]
    real(RP), intent(inout) :: sl_PLCdep
    real(RP), intent(inout) :: sl_PLRdep, sl_PNRdep
 
    real(RP),intent(out) :: RHOQ_t(KA,QA_MP)
    real(RP),intent(out) :: RHOE_t(KA)
    real(RP),intent(out) :: CPtot_t(KA)
    real(RP),intent(out) :: CVtot_t(KA)
 
    !+++ tendency[kg/m3/s]
    real(RP), intent(out)   :: qc_evaporate(KA)
 
    !--- for lightning component
    logical, intent(in)   :: flg_lt ! false -> without lightning, true-> with lightning
    real(RP), intent(in), optional  :: rhoq_crg(KA,I_QC:I_QG)
    real(RP), intent(out), optional :: RHOQcrg_t(KA,I_QC:I_QG)
 
    real(RP) :: xi               ! mean mass of ice particles
    real(RP) :: rrho             ! 1/rho
    real(RP) :: wtem(KA)         ! temperature[K]
    !
    real(RP) :: r_cva            ! specific heat at constant volume
    !real(RP) :: cpa             ! specific heat at constant pressure
    real(RP) :: r_cpa            ! specific heat at constant pressure
    real(RP) :: qsw(KA)          ! saturated mixing ratio for liquid
    real(RP) :: qsi(KA)          ! saturated mixing ratio for solid
    real(RP) :: dqswdtem_rho(KA) ! (dqsw/dtem)_rho
    real(RP) :: dqsidtem_rho(KA) ! (dqsi/dtem)_rho
    real(RP) :: dqswdtem_pre(KA) ! (dqsw/dtem)_pre
    real(RP) :: dqsidtem_pre(KA) ! (dqsi/dtem)_pre
    real(RP) :: dqswdpre_tem(KA) ! (dqsw/dpre)_tem
    real(RP) :: dqsidpre_tem(KA) ! (dqsi/dpre)_tem
    !
    real(RP) :: w2(KA)                 ! vetical velocity[m/s]
    real(RP) :: Acnd                   ! Pdynliq + Bergeron-Findeisen
    real(RP) :: Adep                   ! Pdyndep + Bergeron-Findeisen
    real(RP) :: aliqliq, asolliq
    real(RP) :: aliqsol, asolsol
    real(RP) :: Pdynliq                ! production term of ssw by vertical motion
    real(RP) :: Pdynsol                ! production term of ssi by vertical motion
    real(RP) :: Pradliq                ! production term of ssw by radiation
    real(RP) :: Pradsol                ! production term of ssi by radiation
    real(RP) :: taucnd, r_taucnd       ! time scale of ssw change by MP
    real(RP) :: taudep, r_taudep       ! time scale of ssi change by MP
    real(RP) :: taucnd_c(KA), r_taucnd_c  ! by cloud
    real(RP) :: taucnd_r(KA), r_taucnd_r  ! by rain
    real(RP) :: taudep_i(KA), r_taudep_i  ! by ice
    real(RP) :: taudep_s(KA), r_taudep_s  ! by snow
    real(RP) :: taudep_g(KA), r_taudep_g  ! by graupel
    ! alternative tendency through changing ssw and ssi
    real(RP) :: PNCdep
    real(RP) :: PLR2NR, PLI2NI, PLS2NS, PLG2NG
    real(RP) :: coef_a_cnd, coef_b_cnd
    real(RP) :: coef_a_dep, coef_b_dep
    !
    real(RP) :: frz_dqc
    real(RP) :: frz_dnc(KA)
    real(RP) :: frz_dqr
    real(RP) :: frz_dnr(KA)
    real(RP) :: mlt_dqi
    real(RP) :: mlt_dni(KA)
    real(RP) :: mlt_dqs
    real(RP) :: mlt_dns(KA)
    real(RP) :: mlt_dqg
    real(RP) :: mlt_dng(KA)
    real(RP) :: dep_qv
    real(RP) :: dep_dqi(KA)
    real(RP) :: dep_dni(KA)
    real(RP) :: dep_dqs(KA)
    real(RP) :: dep_dns(KA)
    real(RP) :: dep_dqg(KA)
    real(RP) :: dep_dng(KA)
    real(RP) :: dep_dqr(KA)
    real(RP) :: dep_dnr(KA)
    real(RP) :: dep_dqc(KA)
    real(RP) :: dep_dnc(KA)   ! 11/08/30 [Add] T.Mitsui, dep_dnc
    real(RP) :: r_xc_ccn, r_xi_ccn ! 11/08/30 [Add] T.Mitsui
    !
    real(RP) :: drhoqv(KA)
    real(RP) :: drhoqc(KA), drhoqr(KA), drhoqi(KA), drhoqs(KA), drhoqg(KA)
    real(RP) :: drhonc(KA), drhonr(KA), drhoni(KA), drhons(KA), drhong(KA)
    !-- for Charge densicty
    real(RP) :: drhoqcrg_c(KA), drhoqcrg_r(KA)
    real(RP) :: drhoqcrg_i(KA), drhoqcrg_s(KA), drhoqcrg_g(KA)
    real(RP) :: frz_dnc_crg
    real(RP) :: frz_dnr_crg
    real(RP) :: mlt_dni_crg
    real(RP) :: mlt_dns_crg
    real(RP) :: mlt_dng_crg
    real(RP) :: dep_dni_crg
    real(RP) :: dep_dns_crg
    real(RP) :: dep_dng_crg
    real(RP) :: dep_dnr_crg
    real(RP) :: dep_dnc_crg
    !
    real(RP) :: fac1, fac2, fac3, fac4, fac5, fac6
    real(RP) :: r_rvaptem(KA)    ! 1/(Rvap*tem)
    real(RP) :: pv               ! vapor pressure
    real(RP) :: lvsw, lvsi       ! saturated vapor density
    real(RP) :: dlvsw, dlvsi     !
    ! [Add] 11/08/30 T.Mitsui
    real(RP) :: dcnd, ddep       ! total cndensation/deposition
    real(RP) :: uplim_cnd        ! upper limit of condensation
    real(RP) :: lowlim_cnd       ! lower limit of evaporation
    ! [Add] 11/08/30 T.Mitsui
    real(RP) :: uplim_dep        ! upper limit of condensation
    real(RP) :: lowlim_dep       ! lower limit of evaporation
    real(RP) :: ssw, ssi         ! supersaturation ratio
    real(RP) :: r_esw, r_esi     ! 1/esw, 1/esi
    real(RP) :: r_lvsw, r_lvsi   ! 1/(lvsw*ssw), 1/(lvsi*ssi)
    real(RP) :: r_dt             ! 1/dt
    real(RP) :: ssw_o, ssi_o
!    real(RP) :: dt_dyn
!    real(RP) :: dt_mp
    !
!    real(RP)       :: tem_lh(KA,IA,JA)
!    real(RP)       :: dtemdt_lh(KA,IA,JA)
 
    real(RP) :: fac_cndc_wrk
    !
    real(RP), parameter :: tau100day   = 1.e+7_rp
    real(RP), parameter :: r_tau100day = 1.e-7_rp
    real(RP), parameter :: eps=1.e-30_rp
    !
    real(RP) :: PLCdep(KA), PLRdep(KA), PNRdep(KA)
    real(RP) :: dz
    !
    integer :: k,iqw
    real(RP) :: sw, sw2
    real(RP) :: dqv, dql, dqi
    real(RP) :: dcv, dcp
    real(RP) :: dqc_crg, dqr_crg, dqi_crg, dqs_crg, dqg_crg
 
    !
    real(RP) :: fact
 
    !
!    dt_dyn     = dt*ntmax
    !
    r_dt       = 1.0_rp/dt
    !
    r_xc_ccn=1.0_rp/xc_ccn
!    r_xi_ccn=1.0_RP/xi_ccn
    !
    if( opt_fix_taucnd_c )then
       fac_cndc_wrk = fac_cndc**(1.0_rp-b_m(i_mp_qc))
       do k = ks, ke
          pq(k,i_lcdep)  = pq(k,i_lcdep)*fac_cndc_wrk
       end do
       log_info("ATMOS_PHY_MP_SN14_update_by_phase_change",*) "taucnd:fac_cndc_wrk=",fac_cndc_wrk
    end if
 
!OCL XFILL
    do k = ks, ke
       ! Temperature lower limit is only used for saturation condition.
       ! On the other hand original "tem" is used for calculation of latent heat or energy equation.
       wtem(k)  = max( tem(k), tem_min )
    end do
 
    call moist_pres2qsat_liq( ka, ks, ke, &
                              wtem(:), pre(:), qdry(:), & ! [IN]
                              qsw(:)                    ) ! [OUT]
    call moist_pres2qsat_ice( ka, ks, ke, &
                              wtem(:), pre(:), qdry(:), & ! [IN]
                              qsi(:)                    ) ! [OUT]
    call moist_dqs_dtem_dens_liq( ka, ks, ke, &
                                  wtem(:), rho(:), & ! [IN]
                                  dqswdtem_rho(:)  ) ! [OUT]
    call moist_dqs_dtem_dens_ice( ka, ks, ke, &
                                  wtem(:), rho(:), & ! [IN]
                                  dqsidtem_rho(:)  ) ! [OUT]
    call moist_dqs_dtem_dpre_liq( ka, ks, ke, &
                                  wtem(:), pre(:), qdry(:),        & ! [IN]
                                  dqswdtem_pre(:), dqswdpre_tem(:) ) ! [OUT]
    call moist_dqs_dtem_dpre_ice( ka, ks, ke, &
                                  wtem(:), pre(:), qdry(:),        & ! [IN]
                                  dqsidtem_pre(:), dqsidpre_tem(:) ) ! [OUT]
 
    do k = ks, ke
       if( cz(k) <= 25000.0_rp )then
          w2(k) = w(k)
       else
          w2(k) = 0.0_rp
       end if
       if( pre(k) < esw(k)+1.e-10_rp )then
          qsw(k) = 1.0_rp
          dqswdtem_rho(k) = 0.0_rp
          dqswdtem_pre(k) = 0.0_rp
          dqswdpre_tem(k) = 0.0_rp
       end if
       if( pre(k) < esi(k)+1.e-10_rp )then
          qsi(k) = 1.0_rp
          dqsidtem_rho(k) = 0.0_rp
          dqsidtem_pre(k) = 0.0_rp
          dqsidpre_tem(k) = 0.0_rp
       end if
    end do
 
!OCL LOOP_FISSION_TARGET(LS)
    do k = ks, ke
       r_rvaptem(k)     = 1.0_rp/(rvap*wtem(k))
       lvsw             = esw(k)*r_rvaptem(k)     ! rho=p/(Rv*T)
       lvsi             = esi(k)*r_rvaptem(k)
       pv               = rhoq(k,i_qv)*rvap*tem(k)
       r_esw            = 1.0_rp/esw(k)
       r_esi            = 1.0_rp/esi(k)
       ssw              = min( mp_ssw_lim, ( pv*r_esw-1.0_rp ) )
       ssi              = pv*r_esi - 1.0_rp
       r_lvsw           = 1.0_rp/lvsw
       r_lvsi           = 1.0_rp/lvsi
       r_taucnd_c       = pq(k,i_lcdep)*r_lvsw
       r_taucnd_r       = pq(k,i_lrdep)*r_lvsw
       r_taudep_i       = pq(k,i_lidep)*r_lvsi
       r_taudep_s       = pq(k,i_lsdep)*r_lvsi
       r_taudep_g       = pq(k,i_lgdep)*r_lvsi
!       taucnd_c(k)   = 1.0_RP/(r_taucnd_c+r_tau100day)
!       taucnd_r(k)   = 1.0_RP/(r_taucnd_r+r_tau100day)
!       taudep_i(k)   = 1.0_RP/(r_taudep_i+r_tau100day)
!       taudep_s(k)   = 1.0_RP/(r_taudep_s+r_tau100day)
!       taudep_g(k)   = 1.0_RP/(r_taudep_g+r_tau100day)
 
       r_cva = 1.0_rp / cva(k)
       r_cpa = 1.0_rp / cpa(k)
 
       ! Coefficient of latent heat release for ssw change by PLCdep and PLRdep
       aliqliq = 1.0_rp &
               + r_cva*( lhv00              + (cvvap-cl)*tem(k) )*dqswdtem_rho(k)
       ! Coefficient of latent heat release for ssw change by PLIdep, PLSdep and PLGdep
       asolliq = 1.0_rp &
               + r_cva*( lhv00 + lhf00 + (cvvap-ci)*tem(k) )*dqswdtem_rho(k)
       ! Coefficient of latent heat release for ssi change by PLCdep and PLRdep
       aliqsol = 1.0_rp &
               + r_cva*( lhv00              + (cvvap-cl)*tem(k) )*dqsidtem_rho(k)
       ! Coefficient of latent heat release for ssi change by PLIdep, PLSdep and PLGdep
       asolsol = 1.0_rp &
               + r_cva*( lhv00 + lhf00 + (cvvap-ci)*tem(k) )*dqsidtem_rho(k)
       pdynliq = w2(k) * grav * ( r_cpa*dqswdtem_pre(k) + rho(k)*dqswdpre_tem(k) )
       pdynsol = w2(k) * grav * ( r_cpa*dqsidtem_pre(k) + rho(k)*dqsidpre_tem(k) )
       pradliq = -dtdt_rad(k)    * dqswdtem_rho(k)
       pradsol = -dtdt_rad(k)    * dqsidtem_rho(k)
 
       ssw_o   = ssw
       ssi_o   = ssi
!       ssw_o   = ssw - Pdynliq*(dt_dyn-dt_mp)/qsw(k) + Pradliq*r_qsw*dt_mp
!       ssi_o   = ssi - Pdynsol*(dt_dyn-dt_mp)/qsi(k) + Pradsol*r_qsi*dt_mp
 
       r_taucnd         = &
               + aliqliq*( r_taucnd_c+r_taucnd_r ) &
               + asolliq*( r_taudep_i+r_taudep_s+r_taudep_g )
       r_taudep         = &
               + aliqsol*( r_taucnd_c+r_taucnd_r )&
               + asolsol*( r_taudep_i+r_taudep_s+r_taudep_g )
 
       if( r_taucnd < r_tau100day )then
          uplim_cnd  = max( rho(k)*ssw_o*qsw(k)*r_dt, 0.0_rp )
          lowlim_cnd = min( rho(k)*ssw_o*qsw(k)*r_dt, 0.0_rp )
!          taucnd            = tau100day
          pq(k,i_lcdep) = max(lowlim_cnd, min(uplim_cnd, pq(k,i_lcdep)*ssw_o ))
          pq(k,i_lrdep) = max(lowlim_cnd, min(uplim_cnd, pq(k,i_lrdep)*ssw_o ))
          pq(k,i_nrdep) = min(0.0_rp, pq(k,i_nrdep)*ssw_o )
!          PLR2NR           = 0.0_RP
       else
          acnd = pdynliq + pradliq &
               - ( r_taudep_i+r_taudep_s+r_taudep_g ) * ( qsw(k) - qsi(k) )
          taucnd     = 1.0_rp/r_taucnd
          ! Production term for liquid water content
          coef_a_cnd = rho(k)*acnd*taucnd
          coef_b_cnd = rho(k)*taucnd*r_dt*(ssw_o*qsw(k)-acnd*taucnd) * ( exp(-dt*r_taucnd) - 1.0_rp )
          pq(k,i_lcdep) = coef_a_cnd*r_taucnd_c - coef_b_cnd*r_taucnd_c
          plr2nr            = pq(k,i_nrdep)/(pq(k,i_lrdep)+1.e-30_rp)
          pq(k,i_lrdep) = coef_a_cnd*r_taucnd_r - coef_b_cnd*r_taucnd_r
          pq(k,i_nrdep) = min(0.0_rp, pq(k,i_lrdep)*plr2nr )
       end if
 
       if( r_taudep < r_tau100day )then
          uplim_dep  = max( rho(k)*ssi_o*qsi(k)*r_dt, 0.0_rp )
          lowlim_dep = min( rho(k)*ssi_o*qsi(k)*r_dt, 0.0_rp )
!          taudep            = tau100day
          pq(k,i_lidep) = max(lowlim_dep, min(uplim_dep, pq(k,i_lidep)*ssi_o ))
          pq(k,i_lsdep) = max(lowlim_dep, min(uplim_dep, pq(k,i_lsdep)*ssi_o ))
          pq(k,i_lgdep) = max(lowlim_dep, min(uplim_dep, pq(k,i_lgdep)*ssi_o ))
          pq(k,i_nidep) = min(0.0_rp, pq(k,i_nidep)*ssi_o )
          pq(k,i_nsdep) = min(0.0_rp, pq(k,i_nsdep)*ssi_o )
          pq(k,i_ngdep) = min(0.0_rp, pq(k,i_ngdep)*ssi_o )
       else
          adep = pdynsol + pradsol &
               + ( r_taucnd_c+r_taucnd_r ) * ( qsw(k) - qsi(k) )
          taudep     = 1.0_rp/r_taudep
          ! Production term for ice water content
          coef_a_dep = rho(k)*adep*taudep
          coef_b_dep = rho(k)*taudep*r_dt*(ssi_o*qsi(k)-adep*taudep) * ( exp(-dt*r_taudep) - 1.0_rp )
          pli2ni           = pq(k,i_nidep)/max(pq(k,i_lidep),1.e-30_rp)
          pls2ns           = pq(k,i_nsdep)/max(pq(k,i_lsdep),1.e-30_rp)
          plg2ng           = pq(k,i_ngdep)/max(pq(k,i_lgdep),1.e-30_rp)
          pq(k,i_lidep) =  coef_a_dep*r_taudep_i - coef_b_dep*r_taudep_i
          pq(k,i_lsdep) =  coef_a_dep*r_taudep_s - coef_b_dep*r_taudep_s
          pq(k,i_lgdep) =  coef_a_dep*r_taudep_g - coef_b_dep*r_taudep_g
          pq(k,i_nidep) = min(0.0_rp, pq(k,i_lidep)*pli2ni )
          pq(k,i_nsdep) = min(0.0_rp, pq(k,i_lsdep)*pls2ns )
          pq(k,i_ngdep) = min(0.0_rp, pq(k,i_lgdep)*plg2ng )
       end if
 
    end do
 
    !--- evaporation/condensation
!OCL LOOP_FISSION_TARGET(LS)
    do k = ks, ke
       sw = 0.5_rp - sign(0.5_rp, pq(k,i_lcdep)+eps) != 1 for PLCdep<=-eps
       pncdep = min(0.0_rp, ((rhoq(k,i_qc)+pq(k,i_lcdep)*dt)*r_xc_ccn - rhoq(k,i_nc))*r_dt ) * sw
!       if( PQ(k,I_LCdep) < -eps )then
!          PNCdep = min(0.0_RP, ((rhoq(k,I_QC)+PQ(k,I_LCdep)*dt)*r_xc_ccn - rhoq(k,I_NC))*r_dt )
!       else
!          PNCdep = 0.0_RP
!       end if
!       if( PQ(k,I_LIdep) < -eps )then
!          PQ(k,I_NIdep) = min(0.0_RP, ((li(k)+PQ(k,I_LIdep)*dt)*r_xi_ccn - rhoq(k,I_NI))*r_dt )
!       else
!          PQ(k,I_NIdep) = 0.0_RP
!       end if
 
       lvsw    = esw(k)*r_rvaptem(k)
       dlvsw   = rhoq(k,i_qv)-lvsw
       dcnd    = dt*(pq(k,i_lcdep)+pq(k,i_lrdep))
 
       sw = ( sign(0.5_rp,dcnd) + sign(0.5_rp,dlvsw) ) &
          * ( 0.5_rp + sign(0.5_rp,abs(dcnd)-eps) ) ! to avoid zero division
       ! sw= 1: always supersaturated
       ! sw=-1: always unsaturated
       ! sw= 0: partially unsaturated during timestep
       fac1 = min(dlvsw*sw,dcnd*sw)*sw / (abs(sw)-1.0_rp+dcnd) & ! sw=1,-1
            + 1.0_rp - abs(sw)                                   ! sw=0
       dep_dqc(k) = max( dt*pq(k,i_lcdep)*fac1, &
                        -rhoq(k,i_qc) - 1e30_rp*(sw+1.0_rp) )*abs(sw) != -lc for sw=-1, -inf for sw=1
       dep_dqr(k) = max( dt*pq(k,i_lrdep)*fac1, &
                        -rhoq(k,i_qr) - 1e30_rp*(sw+1.0_rp) )*abs(sw) != -lr for sw=-1, -inf for sw=1
!       if     ( (dcnd >  eps) .AND. (dlvsw > eps) )then
!          ! always supersaturated
!          fac1    = min(dlvsw,dcnd)/dcnd
!          dep_dqc(k) =  dt*PQ(k,I_LCdep)*fac1
!          dep_dqr(k) =  dt*PQ(k,I_LRdep)*fac1
!       else if( (dcnd < -eps) .AND. (dlvsw < -eps) )then
!          ! always unsaturated
!          fac1    = max( dlvsw,dcnd )/dcnd
!          dep_dqc(k) = max( dt*PQ(k,I_LCdep)*fac1, -rhoq(k,I_QC) )
!          dep_dqr(k) = max( dt*PQ(k,I_LRdep)*fac1, -rhoq(k,I_QR) )
!       else
!          ! partially unsaturated during timestep
!          fac1    = 1.0_RP
!          dep_dqc(k) = 0.0_RP
!          dep_dqr(k) = 0.0_RP
!       end if
 
       ! evaporation always lose number(always negative).
       dep_dnc(k) = max( dt*pncdep*fac1, -rhoq(k,i_nc) ) ! ss>0 dep=0, ss<0 dep<0 ! [Add] 11/08/30 T.Mitsui
       dep_dnr(k) = max( dt*pq(k,i_nrdep)*fac1, -rhoq(k,i_nr) ) ! ss>0 dep=0, ss<0 dep<0
 
       qc_evaporate(k) = - dep_dnc(k) ! [Add] Y.Sato 15/09/08
    end do
 
    !--- deposition/sublimation
!OCL LOOP_FISSION_TARGET(LS)
    do k = ks, ke
       lvsi    = esi(k)*r_rvaptem(k)
       ddep    = dt*(pq(k,i_lidep)+pq(k,i_lsdep)+pq(k,i_lgdep))
       dlvsi   = rhoq(k,i_qv)-lvsi  ! limiter for esi>1.0_RP
 
       sw = ( sign(0.5_rp,ddep) + sign(0.5_rp,dlvsi) ) &
          * ( 0.5_rp + sign(0.5_rp,abs(ddep)-eps) ) ! to avoid zero division
       ! sw= 1: always supersaturated
       ! sw=-1: always unsaturated
       ! sw= 0: partially unsaturated during timestep
       fac2 = min(dlvsi*sw,ddep*sw)*sw / (abs(sw)-1.0_rp+ddep) & ! sw=1,-1
            + 1.0_rp - abs(sw)                                   ! sw=0
       dep_dqi(k) = max( dt*pq(k,i_lidep) &
                         * ( 1.0_rp-abs(sw) + fac2*abs(sw) ), & != fac2 for sw=-1,1, 1 for sw=0
                        -rhoq(k,i_qi) - 1e30_rp*(sw+1.0_rp) )  != -li for sw=-1, -inf for sw=0,1
       dep_dqs(k) = max( dt*pq(k,i_lsdep) &
                         * ( 1.0_rp-abs(sw) + fac2*abs(sw) ), & != fac2 for sw=-1,1, 1 for sw=0
                        -rhoq(k,i_qs) - 1e30_rp*(sw+1.0_rp) )  != -ls for sw=-1, -inf for sw=0,1
       dep_dqg(k) = max( dt*pq(k,i_lgdep) &
                         * ( 1.0_rp-abs(sw) + fac2*abs(sw) ), & != fac2 for sw=-1,1, 1 for sw=0
                        -rhoq(k,i_qg) - 1e30_rp*(sw+1.0_rp) )  != -lg for sw=-1, -inf for sw=0,1
!       if      ( (ddep >  eps) .AND. (dlvsi > eps) )then
!          ! always supersaturated
!          fac2    = min(dlvsi,ddep)/ddep
!          dep_dqi(k) = dt*PQ(k,I_LIdep)*fac2
!          dep_dqs(k) = dt*PQ(k,I_LSdep)*fac2
!          dep_dqg(k) = dt*PQ(k,I_LGdep)*fac2
!       else if ( (ddep < -eps) .AND. (dlvsi < -eps) )then
!          ! always unsaturated
!          fac2    = max(dlvsi,ddep)/ddep
!          dep_dqi(k) = max(dt*PQ(k,I_LIdep)*fac2, -rhoq(k,I_QI) )
!          dep_dqs(k) = max(dt*PQ(k,I_LSdep)*fac2, -rhoq(k,I_QS) )
!          dep_dqg(k) = max(dt*PQ(k,I_LGdep)*fac2, -rhoq(k,I_QG) )
!       else
!          ! partially unsaturated during timestep
!          fac2    = 1.0_RP
!          dep_dqi(k) = dt*PQ(k,I_LIdep)
!          dep_dqs(k) = dt*PQ(k,I_LSdep)
!          dep_dqg(k) = dt*PQ(k,I_LGdep)
!       end if
 
       ! evaporation always lose number(always negative).
       dep_dni(k) = max( dt*pq(k,i_nidep)*fac2, -rhoq(k,i_ni) ) ! ss>0 dep=0, ss<0 dep<0
       dep_dns(k) = max( dt*pq(k,i_nsdep)*fac2, -rhoq(k,i_ns) ) ! ss>0 dep=0, ss<0 dep<0
       dep_dng(k) = max( dt*pq(k,i_ngdep)*fac2, -rhoq(k,i_ng) ) ! ss>0 dep=0, ss<0 dep<0
    end do
 
    !--- freezing of cloud drop
!OCL LOOP_FISSION_TARGET(LS)
    do k = ks, ke
       frz_dqc    = max( dt*(pq(k,i_lchom)+pq(k,i_lchet)), -rhoq(k,i_qc)-dep_dqc(k) ) ! negative value
       frz_dnc(k) = max( dt*(pq(k,i_nchom)+pq(k,i_nchet)), -rhoq(k,i_nc)-dep_dnc(k) ) ! negative value
 
       drhoqc(k) =   frz_dqc
       drhonc(k) =   frz_dnc(k)
       drhoqi(k) = - frz_dqc
       drhoni(k) = - frz_dnc(k)
 
       fac3    = ( frz_dqc   -eps )/( dt*(pq(k,i_lchom)+pq(k,i_lchet))-eps )
       fac4    = ( frz_dnc(k)-eps )/( dt*(pq(k,i_nchom)+pq(k,i_nchet))-eps )
       pq(k,i_lchom) = fac3*pq(k,i_lchom)
       pq(k,i_lchet) = fac3*pq(k,i_lchet)
       pq(k,i_nchom) = fac4*pq(k,i_nchom)
       pq(k,i_nchet) = fac4*pq(k,i_nchet)
    end do
 
    !--- melting
!OCL LOOP_FISSION_TARGET(LS)
    do k = ks, ke
       ! ice change
       mlt_dqi    = max( dt*pq(k,i_limlt), -rhoq(k,i_qi)-dep_dqi(k) )  ! negative value
       mlt_dni(k) = max( dt*pq(k,i_nimlt), -rhoq(k,i_ni)-dep_dni(k) )  ! negative value
 
       ! snow change
       mlt_dqs    = max( dt*pq(k,i_lsmlt), -rhoq(k,i_qs)-dep_dqs(k) )  ! negative value
       mlt_dns(k) = max( dt*pq(k,i_nsmlt), -rhoq(k,i_ns)-dep_dns(k) )  ! negative value
 
       ! graupel change
       mlt_dqg    = max( dt*pq(k,i_lgmlt), -rhoq(k,i_qg)-dep_dqg(k) )  ! negative value
       mlt_dng(k) = max( dt*pq(k,i_ngmlt), -rhoq(k,i_ng)-dep_dng(k) )  ! negative value
 
       xi = min(xi_max, max(xi_min, rhoq(k,i_qi)/(rhoq(k,i_ni)+ni_min) ))
       sw = 0.5_rp + sign(0.5_rp,xi-x_sep) ! if (xi>=x_sep) then sw=1 else sw=0
                                                  ! sw=1: large ice crystals turn into rain by melting
 
       drhoqc(k) = drhoqc(k) - mlt_dqi    * (1.0_rp-sw)
       drhonc(k) = drhonc(k) - mlt_dni(k) * (1.0_rp-sw)
 
       drhoqr(k) =           - mlt_dqi    * sw          - mlt_dqs    - mlt_dqg
       drhonr(k) =           - mlt_dni(k) * sw          - mlt_dns(k) - mlt_dng(k)
 
       drhoqi(k) = drhoqi(k) + mlt_dqi
       drhoni(k) = drhoni(k) + mlt_dni(k)
 
       drhoqs(k) =                                        mlt_dqs
       drhons(k) =                                        mlt_dns(k)
 
       drhoqg(k) =                                                     mlt_dqg
       drhong(k) =                                                     mlt_dng(k)
    end do
 
    !--- freezing of larger droplets
!OCL LOOP_FISSION_TARGET(LS)
    do k = ks, ke
       frz_dqr    = max( dt*(pq(k,i_lrhet)), min(0.0_rp, -rhoq(k,i_qr)-dep_dqr(k)) ) ! negative value
       frz_dnr(k) = max( dt*(pq(k,i_nrhet)), min(0.0_rp, -rhoq(k,i_nr)-dep_dnr(k)) ) ! negative value
 
       drhoqr(k) = drhoqr(k) + frz_dqr
       drhonr(k) = drhonr(k) + frz_dnr(k)
       drhoqg(k) = drhoqg(k) - frz_dqr
       drhong(k) = drhong(k) - frz_dnr(k)
 
       fac5         = ( frz_dqr   -eps )/( dt*pq(k,i_lrhet)-eps )
       pq(k,i_lrhet) = fac5*pq(k,i_lrhet)
       fac6         = ( frz_dnr(k)-eps )/( dt*pq(k,i_nrhet)-eps )
       pq(k,i_nrhet) = fac6*pq(k,i_nrhet)
    end do
 
    ! water vapor change
!OCL LOOP_FISSION_TARGET(LS)
    do k = ks, ke
       dep_qv = - ( dep_dqc(k) + dep_dqr(k) + dep_dqi(k) + dep_dqs(k) + dep_dqg(k) )
 
       ! limiter
       sw = 0.5_rp - sign(0.5_rp, abs(dep_qv) - eps) ! if |dep_qv| < eps then sw = 1
       fact = ( max( rhoq(k,i_qv) + dep_qv * dt, 0.0_rp ) - rhoq(k,i_qv) ) / dt / ( dep_qv + sw ) * ( 1.0_rp - sw ) &
            + 1.0_rp * sw
       fact = min( 1.0_rp, max( 0.0_rp, fact ) )
 
       dep_qv     = dep_qv     * fact
 
       dep_dqc(k) = dep_dqc(k) * fact
       dep_dnc(k) = dep_dnc(k) * fact
       dep_dqr(k) = dep_dqr(k) * fact
       dep_dnr(k) = dep_dnr(k) * fact
       dep_dqi(k) = dep_dqi(k) * fact
       dep_dni(k) = dep_dni(k) * fact
       dep_dqs(k) = dep_dqs(k) * fact
       dep_dns(k) = dep_dns(k) * fact
       dep_dqg(k) = dep_dqg(k) * fact
       dep_dng(k) = dep_dng(k) * fact
 
       drhoqv(k) = dep_qv
 
       drhoqc(k) = drhoqc(k) + dep_dqc(k)
       drhonc(k) = drhonc(k) + dep_dnc(k)
       drhoqr(k) = drhoqr(k) + dep_dqr(k)
       drhonr(k) = drhonr(k) + dep_dnr(k)
       drhoqi(k) = drhoqi(k) + dep_dqi(k)
       drhoni(k) = drhoni(k) + dep_dni(k)
       drhoqs(k) = drhoqs(k) + dep_dqs(k)
       drhons(k) = drhons(k) + dep_dns(k)
       drhoqg(k) = drhoqg(k) + dep_dqg(k)
       drhong(k) = drhong(k) + dep_dng(k)
 
       dz = fz(k) - fz(k-1)
       sl_plcdep = sl_plcdep + dep_dqc(k) * dz
       sl_plrdep = sl_plrdep + dep_dqr(k) * dz
       sl_pnrdep = sl_pnrdep + dep_dnr(k) * dz
    end do
 
    ! tendency
!OCL LOOP_FISSION_TARGET(LS)
    do k = ks, ke
       rhoq_t(k,i_qv) = drhoqv(k) / dt
       rhoq_t(k,i_qc) = drhoqc(k) / dt
       rhoq_t(k,i_nc) = drhonc(k) / dt
       rhoq_t(k,i_qr) = drhoqr(k) / dt
       rhoq_t(k,i_nr) = drhonr(k) / dt
       rhoq_t(k,i_qi) = drhoqi(k) / dt
       rhoq_t(k,i_ni) = drhoni(k) / dt
       rhoq_t(k,i_qs) = drhoqs(k) / dt
       rhoq_t(k,i_ns) = drhons(k) / dt
       rhoq_t(k,i_qg) = drhoqg(k) / dt
       rhoq_t(k,i_ng) = drhong(k) / dt
 
       rhoe_t(k) = ( - lhv * drhoqv(k) + lhf * ( drhoqi(k) + drhoqs(k) + drhoqg(k) ) ) / dt
 
       rrho = 1.0_rp/rho(k)
       dqv = rrho * drhoqv(k)
       dql = rrho * ( drhoqc(k) + drhoqr(k) )
       dqi = rrho * ( drhoqi(k) + drhoqs(k) + drhoqg(k) )
 
       dcv = cv_vapor * dqv + cv_water * dql + cv_ice * dqi
       dcp = cp_vapor * dqv + cp_water * dql + cp_ice * dqi
 
       cvtot_t(k) = dcv/dt
       cptot_t(k) = dcp/dt
    end do
 
    !--- for Charge density
    if ( flg_lt ) then
 
       !--- reduce charge density of cloud and rain by evaporation
       do k = ks, ke
          sw = 0.5_rp - sign( 0.5_rp, rhoq(k,i_nc)-small ) !--- if NC is small,  ignore charge transfer
          dep_dnc_crg = dep_dnc(k) * ( 1.0_rp-sw ) / ( rhoq(k,i_nc)+sw ) * rhoq_crg(k,i_qc)
          sw = 0.5_rp - sign( 0.5_rp, rhoq(k,i_nr)-small ) !--- if NR is small,  ignore charge transfer
          dep_dnr_crg = dep_dnr(k) * ( 1.0_rp-sw ) / ( rhoq(k,i_nr)+sw ) * rhoq_crg(k,i_qr)
          !--- limiter
          sw = min( abs(rhoq_crg(k,i_qc)), abs(dep_dnc_crg) )
          dep_dnc_crg = sign( sw, dep_dnc_crg )
          sw = min( abs(rhoq_crg(k,i_qr)), abs(dep_dnr_crg) )
          dep_dnr_crg = sign( sw, dep_dnr_crg )
 
          drhoqcrg_c(k) = dep_dnc_crg
          drhoqcrg_r(k) = dep_dnr_crg
       end do
 
       do k = ks, ke
          sw = 0.5_rp - sign( 0.5_rp, rhoq(k,i_ni)-small ) !--- if NI is small,  ignore charge transfer
          dep_dni_crg = dep_dni(k) * ( 1.0_rp-sw ) / ( rhoq(k,i_ni)+sw ) * rhoq_crg(k,i_qi)
          sw = 0.5_rp - sign( 0.5_rp, rhoq(k,i_ns)-small ) !--- if NS is small,  ignore charge transfer
          dep_dns_crg = dep_dns(k) * ( 1.0_rp-sw ) / ( rhoq(k,i_ns)+sw ) * rhoq_crg(k,i_qs)
          sw = 0.5_rp - sign( 0.5_rp, rhoq(k,i_ng)-small ) !--- if NG is small,  ignore charge transfer
          dep_dng_crg = dep_dng(k) * ( 1.0_rp-sw ) / ( rhoq(k,i_ng)+sw ) * rhoq_crg(k,i_qg)
          !--- limiter
          sw = min( abs(rhoq_crg(k,i_qi)), abs(dep_dni_crg) )
          dep_dni_crg = sign( sw, dep_dni_crg )
          sw = min( abs(rhoq_crg(k,i_qs)), abs(dep_dns_crg) )
          dep_dns_crg = sign( sw, dep_dns_crg )
          sw = min( abs(rhoq_crg(k,i_qg)), abs(dep_dng_crg) )
          dep_dng_crg = sign( sw, dep_dng_crg )
 
          drhoqcrg_i(k) = dep_dni_crg
          drhoqcrg_s(k) = dep_dns_crg
          drhoqcrg_g(k) = dep_dng_crg
       end do
 
       do k = ks, ke
          sw = 0.5_rp - sign( 0.5_rp, rhoq(k,i_nc)-small ) !--- if NC is small,  ignore charge transfer
          frz_dnc_crg = frz_dnc(k) * ( 1.0_rp-sw ) / ( rhoq(k,i_nc)+sw ) * rhoq_crg(k,i_qc)
          !--- limiter
          sw = min( abs(rhoq_crg(k,i_qc) + drhoqcrg_c(k)), abs(frz_dnc_crg) )
          frz_dnc_crg = sign( sw, frz_dnc_crg )
 
          drhoqcrg_c(k) = drhoqcrg_c(k) + frz_dnc_crg
          drhoqcrg_i(k) = drhoqcrg_i(k) - frz_dnc_crg
       end do
 
       do k = ks, ke
          xi = min(xi_max, max(xi_min, rhoq(k,i_qi)/(rhoq(k,i_ni)+ni_min) ))
          sw = 0.5_rp + sign(0.5_rp,xi-x_sep) ! if (xi>=x_sep) then sw=1 else sw=0
                                              ! sw=1: large ice crystals turn into rain by melting
          sw2 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_ni)-small ) !--- if NI is small,  ignore charge transfer   ! I -> C
          mlt_dni_crg = mlt_dni(k) * ( 1.0_rp-sw2 ) / ( rhoq(k,i_ni)+sw2 ) * rhoq_crg(k,i_qi)
          sw2 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_ns)-small ) !--- if NS is small,  ignore charge transfer   ! S -> C
          mlt_dns_crg = mlt_dns(k) * ( 1.0_rp-sw2 ) / ( rhoq(k,i_ns)+sw2 ) * rhoq_crg(k,i_qs)
          sw2 = 0.5_rp - sign( 0.5_rp, rhoq(k,i_ng)-small ) !--- if NG is small,  ignore charge transfer   ! G -> C
          mlt_dng_crg = mlt_dng(k) * ( 1.0_rp-sw2 ) / ( rhoq(k,i_ng)+sw2 ) * rhoq_crg(k,i_qg)
          !--- limiter (|rhoq(NC)| is already reduced by deposition (dep_dni_crg and -frz_dnc_crg) )
          !-- Charge abs(frz_dnc_crg) is already moved from cloud to ice
          sw2 = min( abs(rhoq_crg(k,i_qi) + drhoqcrg_i(k)), abs(mlt_dni_crg) )
          mlt_dni_crg = sign( sw2, mlt_dni_crg )
          sw2 = min( abs(rhoq_crg(k,i_qs) + drhoqcrg_s(k)), abs(mlt_dns_crg) )
          mlt_dns_crg = sign( sw2, mlt_dns_crg )
          sw2 = min( abs(rhoq_crg(k,i_qg) + drhoqcrg_g(k)), abs(mlt_dng_crg) )
          mlt_dng_crg = sign( sw2, mlt_dng_crg )
 
          drhoqcrg_c(k) = drhoqcrg_c(k) - mlt_dni_crg * (1.0_rp-sw)
          drhoqcrg_r(k) = drhoqcrg_r(k) - mlt_dni_crg * sw          - mlt_dns_crg - mlt_dng_crg
          drhoqcrg_i(k) = drhoqcrg_i(k) + mlt_dni_crg
          drhoqcrg_s(k) = drhoqcrg_s(k)                             + mlt_dns_crg
          drhoqcrg_g(k) = drhoqcrg_g(k)                                           + mlt_dng_crg
       end do
 
       do k = ks, ke
          sw = 0.5_rp - sign( 0.5_rp, rhoq(k,i_nr)-small ) !--- if NR is small,  ignore charge transfer
          frz_dnr_crg = frz_dnr(k) * ( 1.0_rp-sw ) / ( rhoq(k,i_nr)+sw ) * rhoq_crg(k,i_qr)
          !--- limiter
          sw = min( abs(rhoq_crg(k,i_qr) + drhoqcrg_r(k)), abs(frz_dnr_crg) )
          frz_dnr_crg = sign( sw, frz_dnr_crg )
 
          drhoqcrg_r(k) = drhoqcrg_r(k) + frz_dnr_crg
          drhoqcrg_g(k) = drhoqcrg_g(k) - frz_dnr_crg
       end do
 
       ! tendency of charge density
       do k = ks, ke
          rhoqcrg_t(k,i_qc) = drhoqcrg_c(k) / dt
          rhoqcrg_t(k,i_qr) = drhoqcrg_r(k) / dt
          rhoqcrg_t(k,i_qi) = drhoqcrg_i(k) / dt
          rhoqcrg_t(k,i_qs) = drhoqcrg_s(k) / dt
          rhoqcrg_t(k,i_qg) = drhoqcrg_g(k) / dt
       end do
 
    end if
 
    return
  end subroutine update_by_phase_change
  !-----------------------------------------------------------------------------
!OCL SERIAL
  subroutine cross_section( &
       KA, KS, KE, &
       QA_MP,      &
       QTRC0,      &
       DENS0,      &
       Crs         )
    implicit none
 
    integer,  intent(in)  :: KA, KS, KE
    integer,  intent(in)  :: QA_MP
    real(RP), intent(in)  :: QTRC0(KA,QA_MP)  ! tracer mass concentration [kg/kg]
    real(RP), intent(in)  :: DENS0(KA)        ! density                   [kg/m3]
    real(RP), intent(out) :: Crs(KA,HYDRO_MAX)! Cross section             [cm]
 
    ! mass concentration[kg/m3] and mean particle mass[kg]
    real(RP) :: xc(KA)
    real(RP) :: xr(KA)
    real(RP) :: xi(KA)
    real(RP) :: xs(KA)
    real(RP) :: xg(KA)
    ! radius of average mass
    real(RP) :: rc, rr
 
    real(RP) :: coef_Fuetal1998
    ! r2m_min is minimum value(moment of 1 particle with 1 micron)
    real(RP), parameter :: r2m_min=1.e-12_rp
    real(RP), parameter :: um2cm = 100.0_rp
 
    real(RP) :: limitsw, zerosw
    integer :: k
    !---------------------------------------------------------------------------
 
    ! mean particle mass[kg]
    do k  = ks, ke
       xc(k) = min( xc_max, max( xc_min, dens0(k)*qtrc0(k,i_qc)/(qtrc0(k,i_nc)+nc_min) ) )
       xr(k) = min( xr_max, max( xr_min, dens0(k)*qtrc0(k,i_qr)/(qtrc0(k,i_nr)+nr_min) ) )
       xi(k) = min( xi_max, max( xi_min, dens0(k)*qtrc0(k,i_qi)/(qtrc0(k,i_ni)+ni_min) ) )
       xs(k) = min( xs_max, max( xs_min, dens0(k)*qtrc0(k,i_qs)/(qtrc0(k,i_ns)+ns_min) ) )
       xg(k) = min( xg_max, max( xg_min, dens0(k)*qtrc0(k,i_qg)/(qtrc0(k,i_ng)+ng_min) ) )
    enddo
 
 
    do k = ks, ke
       crs(k,i_mp_qc) = pi * coef_r2(i_mp_qc) * qtrc0(k,i_nc) * a_rea2(i_mp_qc) * xc(k)**b_rea2(i_mp_qc)
    enddo
 
    do k = ks, ke
       crs(k,i_mp_qr) = pi * coef_r2(i_mp_qr) * qtrc0(k,i_nr) * a_rea2(i_mp_qr) * xr(k)**b_rea2(i_mp_qr)
    enddo
 
    do k = ks, ke
       crs(k,i_mp_qi) = pi * coef_rea2(i_mp_qi) * qtrc0(k,i_ni) * a_rea2(i_mp_qi) * xi(k)**b_rea2(i_mp_qi)
       crs(k,i_mp_qs) = pi * coef_rea2(i_mp_qs) * qtrc0(k,i_ns) * a_rea2(i_mp_qs) * xs(k)**b_rea2(i_mp_qs)
       crs(k,i_mp_qg) = pi * coef_rea2(i_mp_qg) * qtrc0(k,i_ng) * a_rea2(i_mp_qg) * xg(k)**b_rea2(i_mp_qg)
    enddo
 
    return
  end subroutine cross_section
 
!OCL SERIAL
  subroutine get_terminal_velocity( &
       KA, KS, KE,   &
       vt_xa, xq,    &
       rhoq,         &
       log_rho_fac_q )
    implicit none
    integer,  intent(in)  :: KA, KS, KE
    real(RP), intent(out) :: vt_xa        (KA,HYDRO_MAX,2) ! terminal velocity of average mass
    real(RP), intent(out) :: xq           (KA,HYDRO_MAX)   ! Mass of mean particle [kg] SB06(94)
    real(RP), intent(in)  :: rhoq         (KA,I_QV:I_NG)
    real(RP), intent(in)  :: log_rho_fac_q(KA,HYDRO_MAX)
 
    real(RP) :: log_xq
    integer :: k
 
!OCL LOOP_FISSION_TARGET(LS)
    do k = ks, ke
 
       xq(k,i_mp_qc) = min(xc_max, max(xc_min, rhoq(k,i_qc)/(rhoq(k,i_nc)+nc_min) ))
 
       log_xq = log(xq(k,i_mp_qc))
       vt_xa(k,i_mp_qc,1) = exp( log_alpha_v(i_mp_qc,1) + log_xq * beta_v(i_mp_qc,1) + log_rho_fac_q(k,i_mp_qc) )
       vt_xa(k,i_mp_qc,2) = exp( log_alpha_v(i_mp_qc,2) + log_xq * beta_v(i_mp_qc,2) + log_rho_fac_q(k,i_mp_qc) )
 
       xq(k,i_mp_qr) = min(xr_max, max(xr_min, rhoq(k,i_qr)/(rhoq(k,i_nr)+nr_min) ))
       log_xq = log(xq(k,i_mp_qr))
       vt_xa(k,i_mp_qr,1) = exp( log_alpha_v(i_mp_qr,1) + log_xq * beta_v(i_mp_qr,1) + log_rho_fac_q(k,i_mp_qr) )
       vt_xa(k,i_mp_qr,2) = vt_xa(k,i_mp_qr,1)
 
       xq(k,i_mp_qi) = min(xi_max, max(xi_min, rhoq(k,i_qi)/(rhoq(k,i_ni)+ni_min) ))
       log_xq = log(xq(k,i_mp_qi))
       vt_xa(k,i_mp_qi,1) = exp( log_alpha_v(i_mp_qi,1) + log_xq * beta_v(i_mp_qi,1) + log_rho_fac_q(k,i_mp_qi) )
       vt_xa(k,i_mp_qi,2) = exp( log_alpha_v(i_mp_qi,2) + log_xq * beta_v(i_mp_qi,2) + log_rho_fac_q(k,i_mp_qi) )
 
       xq(k,i_mp_qs) = min(xs_max, max(xs_min, rhoq(k,i_qs)/(rhoq(k,i_ns)+ns_min) ))
       log_xq = log(xq(k,i_mp_qs))
       vt_xa(k,i_mp_qs,1) = exp( log_alpha_v(i_mp_qs,1) + log_xq * beta_v(i_mp_qs,1) + log_rho_fac_q(k,i_mp_qs) )
       vt_xa(k,i_mp_qs,2) = exp( log_alpha_v(i_mp_qs,2) + log_xq * beta_v(i_mp_qs,2) + log_rho_fac_q(k,i_mp_qs) )
 
       xq(k,i_mp_qg) = min(xg_max, max(xg_min, rhoq(k,i_qg)/(rhoq(k,i_ng)+ng_min) ))
       log_xq = log(xq(k,i_mp_qg))
       vt_xa(k,i_mp_qg,1) = exp( log_alpha_v(i_mp_qg,1) + log_xq * beta_v(i_mp_qg,1) + log_rho_fac_q(k,i_mp_qg) )
       vt_xa(k,i_mp_qg,2) = exp( log_alpha_v(i_mp_qg,2) + log_xq * beta_v(i_mp_qg,2) + log_rho_fac_q(k,i_mp_qg) )
    end do
 
    return
  end subroutine get_terminal_velocity
 
!OCL SERIAL
  subroutine get_diamiter( &
       KA, KS, KE, &
       dq_xa, &
       xq )
    implicit none
    integer,  intent(in)  :: KA, KS, KE
    real(RP), intent(out) :: dq_xa(KA,HYDRO_MAX)
    real(RP), intent(in)  :: xq   (KA,HYDRO_MAX)
    integer :: k
 
    ! diamter of average mass
    ! SB06(32)
!OCL LOOP_FISSION_TARGET(LS)
    do k = ks, ke
       dq_xa(k,i_mp_qc)  = a_m(i_mp_qc)*xq(k,i_mp_qc)**b_m(i_mp_qc)
       dq_xa(k,i_mp_qr)  = a_m(i_mp_qr)*xq(k,i_mp_qr)**b_m(i_mp_qr)
       dq_xa(k,i_mp_qi)  = a_m(i_mp_qi)*xq(k,i_mp_qi)**b_m(i_mp_qi)
       dq_xa(k,i_mp_qs)  = a_m(i_mp_qs)*xq(k,i_mp_qs)**b_m(i_mp_qs)
       dq_xa(k,i_mp_qg)  = a_m(i_mp_qg)*xq(k,i_mp_qg)**b_m(i_mp_qg)
    end do
 
    return
  end subroutine get_diamiter
 
end module scale_atmos_phy_mp_sn14