phys/module_mp_fast_sbm.F

   1 #if( BUILD_SBM_FAST != 1)
   2       MODULE module_mp_fast_sbm
   3       CONTAINS
   4       SUBROUTINE SBM_fast
   5          REAL :: dummy
   6          dummy = 1
   7       END SUBROUTINE SBM_fast
   8       END MODULE module_mp_fast_sbm
   9 #else
  10 ! +-----------------------------------------------------------------------------+
  11 ! +-----------------------------------------------------------------------------+
  12
  13 ! This is the spectral-bin microphysics scheme based on the Hebrew University
  14 ! Cloud Model (HUCM), originally formulated and coded by Alexander Khain
  15 ! (email: Alexander.Khain@mail.huji.ac.il);
  16 ! The WRF bin microphysics scheme (Fast SBM or FSBM) solves equations for four
  17 ! size distribution functions: aerosols, drop (including rain drops), snow and
  18 ! graupel/hail (from which mass mixing ratio qna, qc, qr, qs, qg/qh and
  19 ! their number concentrations are calculated).
  20
  21 ! The scheme is generally written in CGS units. In the updated scheme (FSBM-2)
  22 ! the users can choose either graupel or hail to describe dense particles
  23 ! (see the 'hail_opt' switch). By default, the 'hail_opt = 1' is used.
  24 ! Hail particles have larger terminal velocity than graupel per mass bin.
  25 ! 'hail_opt' is recommended to be used in simulations of continental cloud
  26 ! systems. The Graupel option may lead to better results in simulations of
  27 ! maritime convection.
  28
  29 ! The aerosol spectrum in FSBM-2 is approximated by 3-lognormal size distribution
  30 ! representing smallest aerosols (nucleation mode), intermediate-size
  31 ! (accumulation mode) and largest aerosols (coarse mode). The BC/IC for aerosols
  32 ! ,as well as aerosols vertical distribution profile -- are set from within the
  33 ! FSBM scheme (see the 'DX_BOUND' parameter). The flag to enable the lognormal
  34 ! aerosols is (ILogNormal_modes_Aerosol = 1, manadatory flag). The modes parameters
  35 ! (concentration, mean radius and model width) are defined inside the routine
  36 ! "LogNormal_modes_Aerosol".
  37 !  **NOTE**: In order to set aerosol BC for the outer-most domain, set the threshold
  38 ! 'DX_BOUND' = 'MY_DX_OUTER_DOMAIN'-1. For example, if the outermost domain
  39 ! resolutionis is 4km 'DX_BOUND' = 3999.
  40
  41
  42 ! The user can set the liquid water content threshold (LWC) in which rimed snow
  43 ! is being transferred to hail/graupel (see 'ALCR' parameter).
  44 ! The default value is ALCR = 0.5 [g/m3]. Increasing this value will result
  45 ! in an increase of snow mass content, and a decrease in hail/graupel mass
  46 ! contents.
  47
  48 ! We thank and acknowledge contribution from Jiwen Fan (PNNL), Alexander Rhyzkov
  49 ! (CIMMS/NSSL), Jeffery Snyder (CIMMS/NSSL), Jimy Dudhia (NCAR) and Dave Gill
  50 ! (NCAR).
  51
  52 ! The previous WRF FSBM version  (FSBM-1) was coded by Barry Lynn (email:
  53 ! Barry.H.Lynn@gmail.com); This updated WRF SBM version (FSBM-2) was coded and
  54 ! is maintained by Jacob Shpund (email: kobby.shpund@mail.huji.ac.il).
  55 ! Please feel free to reachout with questions about the scheme.
  56
  57 ! Usefull references:
  58 ! -------------------
  59 !     Khain, A. P., and I. Sednev, 1996: Simulation of precipitation formation in
  60 ! the Eastern Mediterranean coastal zone using a spectral microphysics cloud
  61 ! ensemble model. Atmospheric Research, 43: 77-110;
  62 !     Khain, A. P., A. Pokrovsky and M. Pinsky, A. Seifert, and V. Phillips, 2004:
  63 ! Effects of atmospheric aerosols on deep convective clouds as seen from
  64 ! simulations using a spectral microphysics mixed-phase cumulus cloud model
  65 ! Part 1: Model description. J. Atmos. Sci 61, 2963-2982);
  66 !     Khain A. P. and M. Pinsky, 2018: Physical Processes in Clouds and Cloud
  67 ! modeling. Cambridge University Press. 642 pp
  68 !     Shpund, J., A. Khain, and D. Rosenfeld, 2019: Effects of Sea Spray on the
  69 ! Dynamics and Microphysics of an Idealized Tropical Cyclone. J. Atmos. Sci., 0,
  70 ! https://doi.org/10.1175/JAS-D-18-0270.1 (A preliminary description of the
  71 ! updated FSBM-2 scheme)
  72
  73 ! When using the FSBM-2 version please cite:
  74 ! -------------------------------------------
  75 !     Shpund, J., Khain, A., Lynn, B., Fan, J., Han, B., Ryzhkov, A., Snyder, J.,
  76 ! Dudhia, J. and Gill, D., 2019. Simulating a Mesoscale Convective System Using WRF
  77 ! With a New Spectral Bin Microphysics: 1: Hail vs Graupel.
  78 ! Journal of Geophysical Research: Atmospheres.
  79
  80 ! +---------------------------------------------------------------------------- +
  81 ! +-----------------------------------------------------------------------------+
  82 module module_mp_SBM_BreakUp
  83
  84 private
  85 public Spont_Rain_BreakUp,Spontanous_Init,BreakUp_Snow,KR_SNOW_MIN,KR_SNOW_MAX
  86
  87 ! Kind paramater
  88 INTEGER, PARAMETER, PRIVATE:: R8SIZE = 8
  89 INTEGER, PARAMETER, PRIVATE:: R4SIZE = 4
  90
  91 ! ... Spontanous Rain BreakUp
  92 INTEGER,PARAMETER ::            JBreak_Spontanous = 28, &
  93                                                 I_Break_Method = 1
  94 DOUBLE PRECISION,PARAMETER :: COL = 0.23105
  95 ! ... Snow-BreakUp
  96 INTEGER,PARAMETER :: KR_SNOW_MAX = 35
  97 INTEGER,PARAMETER :: KR_SNOW_MIN = 34
  98 ! ... Snow breakup probability
  99 DOUBLE PRECISION,PARAMETER :: BREAK_SNOW_KRMAX_0 = 0.02D0
 100 DOUBLE PRECISION,PARAMETER :: BREAK_SNOW_KRMAX_1 = 0.012D0
 101 !DOUBLE PRECISION,PARAMETER :: BREAK_SNOW_KRMAX_2 = 0.08D0
 102 !DOUBLE PRECISION,PARAMETER :: BREAK_SNOW_KRMAX_3 = 0.04D0
 103
 104 contains
 105         ! +--------------------------------------------------------------------------+
 106   subroutine Spontanous_Init(DTwrf, XL, DROPRADII, Prob, Gain_Var_New, NND, NKR, &
 107                            ikr_spon_break)
 108
 109   implicit none
 110
 111   integer,intent(in):: NKR
 112   real(kind=r4size),intent(in) ::       DTwrf,XL(:),DROPRADII(:)
 113   real(kind=r8size),intent(out) :: Prob(:), Gain_Var_New(:,:), NND(:,:)
 114
 115 ! ... Locals
 116   real(kind=r8size) :: diameter(nkr), ratio_new, q_m, gain_var(nkr,nkr), dtime_spon_break, &
 117                                  DROPRADII_dp(nkr),XL_dp(nkr)
 118   integer :: kr,i,j, ikr_spon_break
 119   real(kind=r8size),parameter :: gamma = 0.453d0
 120   character*256 :: wrf_err_message
 121 ! ... Locals
 122
 123 !dtime_spon_break = DTwrf
 124 DROPRADII_dp = DROPRADII
 125 XL_dp = XL
 126 ! diameter in nm
 127 diameter(:) = DROPRADII_dp(:)*2.0d0*10.0d0
 128
 129 DO KR=1,NKR
 130         ikr_spon_break=kr
 131         IF (DROPRADII(kr)>=0.3) exit
 132 END DO
 133
 134 WRITE( wrf_err_message , * ) 'IKR_Spon_Break=',ikr_spon_break
 135 CALL wrf_message ( TRIM ( wrf_err_message ) )
 136
 137 if (i_break_method==1) then
 138         DO KR=1,NKR
 139                  prob(kr)=2.94d-7*dexp(34.0d0*DROPRADII(kr))
 140         ENDDO
 141 else if  (i_break_method==2) then
 142         DO KR=1,NKR
 143                  prob(kr)=0.155d-3*dexp(1.466d0*10.0d0*DROPRADII(kr))
 144         ENDDO
 145 endif
 146
 147 !DO KR=1,NKR
 148 !  prob(kr)=2.94d-7*dexp(34.0d0*DROPRADII_dp(kr))*dtime_spon_break
 149 !  IF (prob(kr)>=1.0d0) exit
 150 !END DO
 151
 152 DO j=ikr_spon_break,nkr
 153         DO i=1,j-1
 154                 gain_var(j,i)=(145.37d0/xl_dp(i))*(dropradii_dp(i)/dropradii_dp(j))*dexp(-7.0d0*dropradii_dp(i)/dropradii_dp(j))
 155                 !gain_var_new(j,i)=gain_var(j,i)*xl(j)/(gain_var(j,i)*xl(i)**2.0d0)
 156                 nnd(j,i)=gamma*dexp(-gamma*diameter(i))/(1-dexp(-gamma*diameter(j)))
 157         END DO
 158 END DO
 159 ! Calculation the ratio that leads to mass conservation
 160 q_m = 0.0
 161 DO i=1,ikr_spon_break-1
 162   !nnd_m = nnd_m+nnd(ikr_spon_break,i)*m(i);
 163    q_m = q_m + gain_var(ikr_spon_break,i)*xl_dp(i)**2;
 164 END DO
 165 ratio_new = q_m/xl_dp(ikr_spon_break)
 166  ! print*, 'ikr_spon_break,q_m,xl(ikr_spon_break),ratio_new'
 167  ! print*,  ikr_spon_break,q_m,xl(ikr_spon_break),ratio_new
 168  DO j=ikr_spon_break,nkr
 169         DO i=1,j-1
 170         gain_var_new(j,i) = gain_var(j,i)/ratio_new
 171         END DO
 172  END DO
 173
 174  RETURN
 175  End Subroutine Spontanous_Init
 176 ! +-----------------------------------------------------------------------------+
 177 ! i_break_method=1: Spontaneous breakup according to Srivastava1971_JAS -
 178 ! Size distribution od raindrops generated by their breakup and coalescence
 179 ! i_break_method=2: Spontaneous breakup according to Kamra et al 1991 JGR -
 180 ! SPONTANEOUS BREAKUP OF CHARGED AND UNCHARGED WATER DROPS FREELY SUSPENDED IN A WIND TUNNEL
 181 ! Eyal's new changes (29/3/15)    (start)
 182 ! Description of variables       (start)
 183 ! FF1R(KR), 1/g/cm3 - non conservative drop size distribution
 184 ! XL(kr), g - Mass of liquid drops
 185 ! prob, dimensionless - probability for breakup
 186 ! dropconc_bf(kr), cm^-3 - drops concentration before breakup
 187 ! dropconc_af(kr), cm^-3 - drops concentration before breakup
 188 ! drops_break(kr), cm^-3 - concentration of breaking drops
 189 ! Description of variables       (end)
 190
 191   SUBROUTINE Spont_Rain_BreakUp (DTwrf, FF1R, XL, Prob, Gain_Var_New, NND, NKR, ikr_spon_break)
 192
 193   implicit none
 194
 195   integer,intent(in) :: NKR, IKR_Spon_Break
 196   real(kind=r8size),intent(INOUT) :: FF1R(:)
 197   real(kind=r8size),intent(IN) ::XL(:),Prob(:),Gain_Var_New(:,:),NND(:,:)
 198   real(kind=r4size),intent(in) :: DTwrf
 199
 200 ! ... Local
 201   real(kind=r8size) :: dm, deg01, tmp_1, tmp_2, tmp_3
 202   real(kind=r8size),dimension(nkr) :: dropconc_bf, dropconc_af, drops_break, psi1, dropradii
 203   integer :: kr,i,imax,j
 204   real(kind=r4size) :: start_time, end_time, dtime_spon_break
 205 ! ... Local
 206
 207  dtime_spon_break = DTwrf
 208
 209   DEG01 = 1.0/3.0
 210   DO KR=1,NKR
 211      DROPRADII(KR)=(3.*XL(KR)/4./3.141593/1.)**DEG01
 212   ENDDO
 213
 214   if(SUM(FF1R) <= nkr*1.D-30) return
 215
 216   imax=nkr
 217   do i=nkr,1,-1
 218      imax=i
 219      if (FF1R(i) > 0.0D0) exit
 220   enddo
 221
 222   if (imax<ikr_spon_break) return
 223
 224 ! Initialization        (start)
 225   psi1(:)=ff1r(:)
 226   drops_break(:)=0.0d0
 227   dropconc_bf(:)=0.0d0
 228
 229 ! b) Calculation of concentration of raindrops in all bins
 230   do kr=1,imax
 231      dm=3.0d0*col*xl(kr)
 232      dropconc_bf(kr)=dropconc_bf(kr)+dm*psi1(kr)
 233   enddo
 234   dropconc_af(:)=dropconc_bf(:)
 235
 236 ! c+d) Calculation of number of breaking drops  and the concentration of drops remaining in particular bin
 237
 238   do kr=imax,ikr_spon_break,-1
 239     !dropconc_af(kr)=dropconc_bf(kr)/(1+prob(kr)*dtime_spon_break)
 240                 tmp_1 = prob(kr)*dtime_spon_break ! [KS, 18thJan18] >> the time was added here and not in the initialization
 241                 tmp_2 = dexp(-tmp_1)
 242                 tmp_3 = dropconc_bf(kr)
 243                 dropconc_af(kr) = tmp_2*tmp_3
 244                 !dropconc_af(kr) = dexp(-dtime_spon_break*prob(kr))*dropconc_bf(kr)
 245     drops_break(kr) = dropconc_bf(kr)-dropconc_af(kr)
 246     !if (dropconc_af(kr)<0.0d0) stop 'Spontaneous breakup'
 247   enddo
 248
 249 ! e) Recalculation of DSD in bin j using new concentration
 250 !        do kr=ikr_spon_break,imax
 251 !           dm=3.0D0*col*xl(kr)
 252 !           psi1(kr)=psi1(kr)-drops_break(kr)/dm
 253 !        enddo
 254
 255 ! f+g) Redistributing and calculations drops concentration over smaller (i<j) bins
 256 !
 257   select case (i_break_method)
 258   case(1)
 259   do j=ikr_spon_break,imax
 260        do i=1,j-1
 261             dropconc_af(i)=dropconc_af(i)+drops_break(j)*gain_var_new(j,i)*xl(i)
 262         enddo
 263   enddo
 264
 265   case(2)
 266   do j=ikr_spon_break,imax
 267        do i=1,j-1
 268                         dropconc_af(i)=dropconc_af(i)+drops_break(j)*gain_var_new(j,i)*xl(i)
 269             !dropconc_af(i)=dropconc_af(i)+drops_break(j)*nnd(j,i)
 270         enddo
 271   enddo
 272 end select
 273
 274 ! h) recalculation of DSD in bins kr using new concentrations
 275
 276   do kr=1,imax
 277            dm=3.0D0*col*xl(kr)
 278            psi1(kr)=dropconc_af(kr)/dm
 279   enddo
 280
 281   ff1r(:)=psi1(:)
 282 ! 200   FORMAT(1X,I2,2X,5D13.5)
 283 ! Eyal's new changes (29/3/15)    (end)
 284
 285   RETURN
 286   END SUBROUTINE Spont_Rain_BreakUp
 287 ! +-------------------------------------------+
 288         SUBROUTINE BreakUp_Snow (Tin,F,FL,X,RF,NKR)
 289
 290         IMPLICIT NONE
 291
 292         INTEGER,INTENT(in) :: NKR
 293         real(kind=r8size),INTENT(inout) :: F(:),FL(:),RF(:)
 294         real(kind=r8size),INTENT(in) :: X(:)
 295         real(kind=r4size),INTENT(in) :: Tin
 296
 297 ! ... Locals
 298         real(kind=r8size) :: G(NKR),GLW(NKR),GRM(NKR),DEL_GLW(NKR),DEL_GRM(NKR), BREAK_SNOW(NKR), &
 299                                                            A,GLW_MAX, FLW_MAX, GRM_MAX, FRM_MAX, GMAX
 300         INTEGER :: KR,K,KMAX,KMIN
 301 ! ... Locals
 302
 303         DO KR=1,NKR
 304            BREAK_SNOW(KR)=0.0D0
 305         END DO
 306
 307    if (KR_SNOW_MAX  <=NKR) BREAK_SNOW(KR_SNOW_MAX) = BREAK_SNOW_KRMAX_0
 308    if (KR_SNOW_MAX-1<=NKR) BREAK_SNOW(KR_SNOW_MAX-1) = BREAK_SNOW_KRMAX_1
 309   !if (KR_SNOW_MAX-2<=NKR) BREAK_SNOW(KR_SNOW_MAX-2) = BREAK_SNOW_KRMAX_2
 310   !if (KR_SNOW_MAX-3<=NKR) BREAK_SNOW(KR_SNOW_MAX-3) = BREAK_SNOW_KRMAX_3
 311
 312         DO K=1,NKR
 313                 G(K)=0.0D0
 314                 GLW(K)=0.0D0
 315                 GRM(K)=0.0D0
 316                 DEL_GLW(K)=0.0D0
 317                 DEL_GRM(K)=0.0D0
 318         END DO
 319
 320         KMAX=KR_SNOW_MAX
 321         KMIN=KR_SNOW_MIN
 322
 323         A=X(KMAX)*X(KMAX)
 324
 325         GLW_MAX=0.0D0
 326
 327         DO K=KMAX+1,NKR
 328                 GLW_MAX=GLW_MAX+X(K)*X(K)*F(K)*FL(K)
 329         ENDDO
 330
 331         GLW_MAX=GLW_MAX+A*F(KMAX)*FL(KMAX)
 332
 333         FLW_MAX=GLW_MAX/A
 334
 335         GRM_MAX=0.0D0
 336
 337         DO K=KMAX+1,NKR
 338                 GRM_MAX=GRM_MAX+X(K)*X(K)*F(K)*(1.0D0-FL(K))*RF(K)
 339         ENDDO
 340
 341         GRM_MAX=GRM_MAX+A*F(KMAX)*(1.0D0-FL(KMAX))*RF(KMAX)
 342
 343         FRM_MAX=GRM_MAX/A
 344
 345         GMAX=0.0D0
 346
 347         DO K=KMAX+1,NKR
 348                 GMAX=GMAX+X(K)*X(K)*F(K)
 349         ENDDO
 350
 351         GMAX=GMAX+A*F(KMAX)
 352
 353         F(KMAX) = GMAX/A
 354
 355         !FL(KMAX)=FLW_MAX/F(KMAX)
 356
 357         IF (F(KMAX) .lt. 1.0E-20)then
 358            if(TIN > 273.15)then
 359         FL(kmax) = 1.0d0
 360         RF(kmax) = 0.0d0
 361            else
 362         FL(kmax) = 0.0d0
 363         RF(kmax) = 1.0d0
 364            endif
 365         ELSE
 366            if(TIN > 273.15)then
 367                    RF(KMAX) = 0.0
 368        FL(KMAX) = FLW_MAX/F(KMAX)
 369           else
 370        FL(KMAX) = 0.0
 371        RF(KMAX) = FRM_MAX/F(KMAX)/(1.0D0-FL(KMAX))
 372            endif
 373         END IF
 374
 375         DO K=KMAX+1,NKR
 376                 F(K)=0.0D0
 377                 if(TIN > 273.15)then
 378                   RF(K) = 0.0D0
 379                   FL(K) = 1.0D0
 380                 else
 381                   RF(K) = 1.0D0
 382                   FL(K) = 0.0D0
 383                 endif
 384         ENDDO
 385
 386         G(KMAX)=3.0D0*F(KMAX)*A
 387         DO K=KMAX-1,KMIN-1,-1
 388            G(K)=F(K)*3.0D0*X(K)*X(K)
 389            GLW(K)=G(K)*FL(K)
 390            GRM(K)=G(K)*(1.0D0-FL(K))*RF(K)
 391         ENDDO
 392
 393         DO K=KMAX,KMIN,-1
 394            DEL_GLW(K) = G(K)*BREAK_SNOW(K)*FL(K)
 395            GLW(K-1) = GLW(K-1)+DEL_GLW(K)
 396            DEL_GRM(K) = G(K)*(1.0D0-FL(K))*RF(K)*BREAK_SNOW(K)
 397            GRM(K-1) = GRM(K-1)+DEL_GRM(K)
 398            G(K-1) = G(K-1)+G(K)*BREAK_SNOW(K)
 399            F(K-1) = G(K-1)/3.0D0/X(K-1)/X(K-1)
 400
 401                 if (G(k-1) < 1.0d-20) then
 402                         if(TIN > 273.15)then
 403                                 FL(k-1) = 1.0d0
 404                                 RF(k-1) = 0.0d0
 405                         else
 406                                 FL(k-1) = 0.0d0
 407                                 RF(k-1) = 1.0d0
 408                         endif
 409            else
 410                         if(TIN > 273.15)then
 411                                 FL(k-1) = GLW(k-1)/G(k-1)
 412                                 RF(K-1) = 0.0
 413                         else
 414                                 FL(K-1) = 0.0
 415                                 !print*,'SnowBr',GRM(k-1),G(k-1),FL(k-1)
 416                                 RF(k-1) = GRM(k-1)/G(k-1)/(1.0D0-FL(k-1))
 417                         endif
 418                 endif
 419
 420                  ! FL(K-1)=GLW(K-1)/G(K-1)
 421            ! RF(K-1)=GRM(K-1)/G(K-1)/(1.0D0-FL(K-1))
 422
 423            G(K) = G(K)*(1.0D0-BREAK_SNOW(K))
 424            F(K) = G(K)/3.0D0/X(K)/X(K)
 425         END DO
 426
 427         RETURN
 428         END SUBROUTINE BreakUp_Snow
 429 ! +------------------------------+
 430 end module module_mp_SBM_BreakUp
 431 ! +-----------------------------------------------------------------------------+
 432 ! +-----------------------------------------------------------------------------+
 433  module module_mp_SBM_Collision
 434
 435  private
 436  public coll_xyy_lwf, coll_xyx_lwf, coll_xxx_lwf, &
 437         coll_xyz_lwf, coll_xxy_lwf, &
 438         modkrn_KS, coll_breakup_KS, courant_bott_KS
 439
 440   ! Kind paramater
 441   INTEGER, PARAMETER, PRIVATE:: R8SIZE = 8
 442   INTEGER, PARAMETER, PRIVATE:: R4SIZE = 4
 443   integer,parameter :: kp_flux_max = 44
 444   real(kind=r8size), parameter :: G_LIM = 1.0D-16 ! [g/cm^3]
 445   integer,parameter :: kr_sgs_max = 20 ! rg(20)=218.88 mkm
 446
 447  contains
 448 ! +------------------------------------------------+
 449 subroutine coll_xyy_lwf (gx,gy,flx,fly,ckxy,x,y, &
 450                                                             c,ima,prdkrn,nkr,indc)
 451         implicit none
 452
 453         integer,intent(in) :: nkr
 454         real(kind=r8size),intent(inout) :: gy(:),gx(:),fly(:),flx(:)
 455         real(kind=r8size),intent(in) :: ckxy(:,:),x(:),y(:),c(:,:)
 456         integer,intent(in) :: ima(:,:)
 457         real(kind=r8size),intent(in) :: prdkrn
 458
 459 ! ... Locals
 460  real(kind=r8size) :: gmin,ckxy_ji,x01,x02,x03,gsi,gsj,gsk,gsi_w,gsj_w,gsk_w,gk,gk_w,&
 461                       fl_gk,fl_gsk,flux,x1,flux_w,gy_k_w,gy_kp_old,gy_kp_w
 462  integer :: j,jx0,jx1,i,iy0,iy1,jmin,indc,k,kp
 463 ! ... Locals
 464
 465           gmin = 1.0d-60
 466
 467 ! jx0 - lower limit of integration by j
 468 do j=1,nkr-1
 469    jx0=j
 470    if(gx(j).gt.gmin) goto 2000
 471 enddo
 472 2000   continue
 473 if(jx0.eq.nkr-1) return
 474
 475 ! jx1 - upper limit of integration by j
 476 do j=nkr-1,jx0,-1
 477    jx1=j
 478    if(gx(j).gt.gmin) goto 2010
 479 enddo
 480 2010   continue
 481
 482 ! iy0 - lower limit of integration by i
 483 do i=1,nkr-1
 484    iy0=i
 485    if(gy(i).gt.gmin) goto 2001
 486 enddo
 487 2001   continue
 488 if(iy0.eq.nkr-1) return
 489
 490 ! iy1 - upper limit of integration by i
 491 do i=nkr-1,iy0,-1
 492    iy1=i
 493    if(gy(i).gt.gmin) goto 2011
 494 enddo
 495 2011   continue
 496
 497 ! collisions :
 498         do i = iy0,iy1
 499            if(gy(i).le.gmin) goto 2020
 500            jmin = i
 501            if(jmin.eq.nkr-1) return
 502            if(i.lt.jx0) jmin=jx0-indc
 503             do j=jmin+indc,jx1
 504               if(gx(j).le.gmin) goto 2021
 505               k=ima(i,j)
 506               kp=k+1
 507               ckxy_ji=ckxy(j,i)
 508               x01=ckxy_ji*gy(i)*gx(j)*prdkrn
 509               x02=dmin1(x01,gy(i)*x(j))
 510               x03=dmin1(x02,gx(j)*y(i))
 511               gsi=x03/x(j)
 512               gsj=x03/y(i)
 513               gsk=gsi+gsj
 514               if(gsk.le.gmin) goto 2021
 515               gsi_w=gsi*fly(i)
 516               gsj_w=gsj*flx(j)
 517               gsk_w=gsi_w+gsj_w
 518               gsk_w=dmin1(gsk_w,gsk)
 519               gy(i)=gy(i)-gsi
 520               gy(i)=dmax1(gy(i),0.0d0)
 521               gx(j)=gx(j)-gsj
 522               gx(j)=dmax1(gx(j),0.0d0)
 523               gk=gy(k)+gsk
 524               if(gk.le.gmin) goto 2021
 525               gk_w=gy(k)*fly(k)+gsk_w
 526               gk_w=dmin1(gk_w,gk)
 527
 528                     fl_gk=gk_w/gk
 529
 530               fl_gsk=gsk_w/gsk
 531
 532               flux=0.d0
 533               x1=dlog(gy(kp)/gk+1.d-15)
 534               flux=gsk/x1*(dexp(0.5d0*x1)-dexp(x1*(0.5d0-c(i,j))))
 535               flux=dmin1(flux,gsk)
 536               flux=dmin1(flux,gk)
 537
 538               if(kp.gt.kp_flux_max) flux=0.5d0*flux
 539               flux_w=flux*fl_gsk
 540               flux_w=dmin1(flux_w,gsk_w)
 541               flux_w=dmin1(flux_w,gk_w)
 542
 543                 gy(k)=gk-flux
 544                 gy(k)=dmax1(gy(k),gmin)
 545                 gy_k_w=gk*fl_gk-flux_w
 546                 gy_k_w=dmin1(gy_k_w,gy(k))
 547                 gy_k_w=dmax1(gy_k_w,0.0d0)
 548                 fly(k)=gy_k_w/gy(k)
 549                 gy_kp_old=gy(kp)
 550                 gy(kp)=gy(kp)+flux
 551                 gy(kp)=dmax1(gy(kp),gmin)
 552                 gy_kp_w=gy_kp_old*fly(kp)+flux_w
 553                 gy_kp_w=dmin1(gy_kp_w,gy(kp))
 554                 fly(kp)=gy_kp_w/gy(kp)
 555
 556                 if(fly(k).gt.1.0d0.and.fly(k).le.1.0001d0) &
 557                    fly(k)=1.0d0
 558                 if(fly(kp).gt.1.0d0.and.fly(kp).le.1.0001d0) &
 559                    fly(kp)=1.0d0
 560                 if(fly(k).gt.1.0001d0.or.fly(kp).gt.1.0001d0 &
 561                    .or.fly(k).lt.0.0d0.or.fly(kp).lt.0.0d0) then
 562
 563                 print*,    'in subroutine coll_xyy_lwf'
 564
 565                 if(fly(k).gt.1.0001d0)  print*, 'fly(k).gt.1.0001d0'
 566                 if(fly(kp).gt.1.0001d0) print*, 'fly(kp).gt.1.0001d0'
 567
 568                 if(fly(k).lt.0.0d0)  print*, 'fly(k).lt.0.0d0'
 569                 if(fly(kp).lt.0.0d0) print*, 'fly(kp).lt.0.0d0'
 570
 571                 print*,    'i,j,k,kp'
 572                 print*,     i,j,k,kp
 573
 574                 print*,    'jx0,jx1,iy0,iy1'
 575                 print*,     jx0,jx1,iy0,iy1
 576
 577                 print*,   'ckxy(j,i),x01,x02,x03'
 578                 print 204, ckxy(j,i),x01,x02,x03
 579
 580                 print*,   'gsi,gsj,gsk'
 581                 print 203, gsi,gsj,gsk
 582
 583                 print*,   'gsi_w,gsj_w,gsk_w'
 584                 print 203, gsi_w,gsj_w,gsk_w
 585
 586                 print*,   'gk,gk_w'
 587                 print 202, gk,gk_w
 588
 589                 print*,   'fl_gk,fl_gsk'
 590                 print 202, fl_gk,fl_gsk
 591
 592                 print*,   'x1,c(i,j)'
 593                 print 202, x1,c(i,j)
 594
 595                 print*,   'flux'
 596                 print 201, flux
 597
 598                 print*,   'flux_w'
 599                 print 201, flux_w
 600
 601                 print*,   'gy_k_w'
 602                 print 201, gy_k_w
 603
 604                 print*,   'gy_kp_w'
 605                 print 201, gy_kp_w
 606
 607                             if(fly(k).lt.0.0d0) print*, &
 608                                             'stop 2022: in subroutine coll_xyy_lwf, fly(k) < 0'
 609
 610                 if(fly(kp).lt.0.0d0) print*, &
 611                                                    'stop 2022: in subroutine coll_xyy_lwf, fly(kp) < 0'
 612
 613                 if(fly(k).gt.1.0001d0) print*, &
 614                                                    'stop 2022: in sub. coll_xyy_lwf, fly(k) > 1.0001'
 615
 616                                         if(fly(kp).gt.1.0001d0) print*, &
 617                                                    'stop 2022: in sub. coll_xyy_lwf, fly(kp) > 1.0001'
 618
 619                      call wrf_error_fatal("in coal_bott coll_xyy_lwf, model stop")
 620 ! in case fly(k).gt.1.0001d0.or.fly(kp).gt.1.0001d0
 621 !        .or.fly(k).lt.0.0d0.or.fly(kp).lt.0.0d0
 622           endif
 623  2021   continue
 624        enddo
 625 ! cycle by j
 626  2020   continue
 627     enddo
 628 ! cycle by i
 629
 630  201    format(1x,d13.5)
 631  202    format(1x,2d13.5)
 632  203    format(1x,3d13.5)
 633  204    format(1x,4d13.5)
 634
 635   return
 636   end subroutine coll_xyy_lwf
 637 ! +-----------------------------------------------------+
 638   subroutine coll_xxx_lwf(g,fl,ckxx,x,c,ima,prdkrn,nkr)
 639
 640     implicit none
 641
 642     integer,intent(in) :: nkr
 643     real(kind=r8size),intent(inout) :: g(:),fl(:)
 644     real(kind=r8size),intent(in) ::     ckxx(:,:),x(:), c(:,:)
 645     integer,intent(in) :: ima(:,:)
 646     real(kind=r8size),intent(in) :: prdkrn
 647
 648 ! ... Locals
 649    real(kind=r8size):: gmin,x01,x02,x03,gsi,gsj,gsk,gsi_w,gsj_w,gsk_w,gk, &
 650                        gk_w,fl_gk,fl_gsk,flux,x1,flux_w,g_k_w,g_kp_old,g_kp_w
 651    integer :: i,ix0,ix1,j,k,kp
 652 ! ... Locals
 653
 654   gmin=g_lim*1.0d3
 655
 656 ! ix0 - lower limit of integration by i
 657
 658   do i=1,nkr-1
 659    ix0=i
 660    if(g(i).gt.gmin) goto 2000
 661   enddo
 662   2000   continue
 663   if(ix0.eq.nkr-1) return
 664
 665 ! ix1 - upper limit of integration by i
 666   do i=nkr-1,1,-1
 667    ix1=i
 668    if(g(i).gt.gmin) goto 2010
 669   enddo
 670   2010   continue
 671
 672 ! ... collisions
 673       do i=ix0,ix1
 674          if(g(i).le.gmin) goto 2020
 675          do j=i,ix1
 676             if(g(j).le.gmin) goto 2021
 677             k=ima(i,j)
 678             kp=k+1
 679             x01=ckxx(i,j)*g(i)*g(j)*prdkrn
 680             x02=dmin1(x01,g(i)*x(j))
 681             if(j.ne.k) x03=dmin1(x02,g(j)*x(i))
 682             if(j.eq.k) x03=x02
 683             gsi=x03/x(j)
 684             gsj=x03/x(i)
 685             gsk=gsi+gsj
 686             if(gsk.le.gmin) goto 2021
 687             gsi_w=gsi*fl(i)
 688             gsj_w=gsj*fl(j)
 689             gsk_w=gsi_w+gsj_w
 690             gsk_w=dmin1(gsk_w,gsk)
 691             g(i)=g(i)-gsi
 692             g(i)=dmax1(g(i),0.0d0)
 693             g(j)=g(j)-gsj
 694   ! new change of 23.01.11                                      (start)
 695             if(j.ne.k) g(j)=dmax1(g(j),0.0d0)
 696   ! new change of 23.01.11                                        (end)
 697             gk=g(k)+gsk
 698
 699             if(g(j).lt.0.d0.and.gk.le.gmin) then
 700               g(j)=0.d0
 701               g(k)=g(k)+gsi
 702               goto 2021
 703           endif
 704
 705             if(gk.le.gmin) goto 2021
 706
 707             gk_w=g(k)*fl(k)+gsk_w
 708             gk_w=dmin1(gk_w,gk)
 709
 710             fl_gk=gk_w/gk
 711             fl_gsk=gsk_w/gsk
 712             flux=0.d0
 713             x1=dlog(g(kp)/gk+1.d-15)
 714             flux=gsk/x1*(dexp(0.5d0*x1)-dexp(x1*(0.5d0-c(i,j))))
 715             flux=dmin1(flux,gsk)
 716             flux=dmin1(flux,gk)
 717             if(kp.gt.kp_flux_max) flux=0.5d0*flux
 718             flux_w=flux*fl_gsk
 719             flux_w=dmin1(flux_w,gsk_w)
 720             flux_w=dmin1(flux_w,gk_w)
 721             g(k)=gk-flux
 722             g(k)=dmax1(g(k),gmin)
 723             g_k_w=gk_w-flux_w
 724             g_k_w=dmin1(g_k_w,g(k))
 725             g_k_w=dmax1(g_k_w,0.0d0)
 726             fl(k)=g_k_w/g(k)
 727             g_kp_old=g(kp)
 728             g(kp)=g(kp)+flux
 729             g(kp)=dmax1(g(kp),gmin)
 730             g_kp_w=g_kp_old*fl(kp)+flux_w
 731             g_kp_w=dmin1(g_kp_w,g(kp))
 732             fl(kp)=g_kp_w/g(kp)
 733
 734             if(fl(k).gt.1.0d0.and.fl(k).le.1.0001d0) &
 735                 fl(k)=1.0d0
 736
 737             if(fl(kp).gt.1.0d0.and.fl(kp).le.1.0001d0) &
 738                 fl(kp)=1.0d0
 739
 740             if(fl(k).gt.1.0001d0.or.fl(kp).gt.1.0001d0 &
 741                .or.fl(k).lt.0.0d0.or.fl(kp).lt.0.0d0) then
 742
 743               print*,    'in subroutine coll_xxx_lwf'
 744               print*,    'snow - snow = snow'
 745
 746               if(fl(k).gt.1.0001d0)  print*, 'fl(k).gt.1.0001d0'
 747               if(fl(kp).gt.1.0001d0) print*, 'fl(kp).gt.1.0001d0'
 748
 749               if(fl(k).lt.0.0d0)  print*, 'fl(k).lt.0.0d0'
 750               if(fl(kp).lt.0.0d0) print*, 'fl(kp).lt.0.0d0'
 751
 752               print*,    'i,j,k,kp'
 753               print*,     i,j,k,kp
 754               print*,    'ix0,ix1'
 755               print*,     ix0,ix1
 756
 757               print*,   'ckxx(i,j),x01,x02,x03'
 758                 print 204, ckxx(i,j),x01,x02,x03
 759
 760               print*,   'gsi,gsj,gsk'
 761                 print 203, gsi,gsj,gsk
 762
 763               print*,   'gsi_w,gsj_w,gsk_w'
 764                 print 203, gsi_w,gsj_w,gsk_w
 765
 766               print*,   'gk,gk_w'
 767                 print 202, gk,gk_w
 768
 769               print*,   'fl_gk,fl_gsk'
 770                 print 202, fl_gk,fl_gsk
 771
 772               print*,   'x1,c(i,j)'
 773                 print 202, x1,c(i,j)
 774
 775               print*,   'flux'
 776                 print 201, flux
 777
 778               print*,   'flux_w'
 779                 print 201, flux_w
 780
 781               print*,   'g_k_w'
 782                 print 201, g_k_w
 783
 784                 print *,  'g_kp_w'
 785                 print 201, g_kp_w
 786
 787               if(fl(k).lt.0.0d0) print*, &
 788                  'stop 2022: in subroutine coll_xxx_lwf, fl(k) < 0'
 789
 790               if(fl(kp).lt.0.0d0) print*, &
 791                  'stop 2022: in subroutine coll_xxx_lwf, fl(kp) < 0'
 792
 793               if(fl(k).gt.1.0001d0) print*, &
 794                  'stop 2022: in sub. coll_xxx_lwf, fl(k) > 1.0001'
 795
 796               if(fl(kp).gt.1.0001d0) print*, &
 797                  'stop 2022: in sub. coll_xxx_lwf, fl(kp) > 1.0001'
 798                     call wrf_error_fatal("in coal_bott sub. coll_xxx_lwf, model stop")
 799               endif
 800 2021     continue
 801        enddo
 802 ! cycle by j
 803 2020    continue
 804    enddo
 805 ! cycle by i
 806
 807 201    format(1x,d13.5)
 808 202    format(1x,2d13.5)
 809 203    format(1x,3d13.5)
 810 204    format(1x,4d13.5)
 811
 812  return
 813  end subroutine coll_xxx_lwf
 814 ! +----------------------------------------------------+
 815  subroutine coll_xyx_lwf (gx,gy,flx,fly,ckxy,x,y, &
 816                                                        c,ima,prdkrn,nkr,indc,dm_rime)
 817         implicit none
 818
 819         integer,intent(in) :: nkr
 820         real(kind=r8size),intent(inout) :: gy(:),gx(:),fly(:),flx(:),dm_rime(:)
 821         real(kind=r8size),intent(in) :: ckxy(:,:),x(:),y(:),c(:,:),prdkrn
 822         integer,intent(in) :: ima(:,:)
 823
 824 ! ... Locals
 825         real(kind=r8size) :: gmin,x01,x02,x03,gsi,gsj,gsk,gk,flux,x1,gsi_w,gsj_w,gsk_w, &
 826                         gk_w,fl_gk,fl_gsk,flux_w,gx_k_w,gx_kp_old,gx_kp_w,frac_split
 827         integer :: j, jx0, jx1, i, iy0, iy1, jmin, indc, k, kp
 828 ! ... Locals
 829
 830         gmin=g_lim*1.0d3
 831
 832 ! jx0 - lower limit of integration by j
 833         do j=1,nkr-1
 834            jx0=j
 835            if(gx(j).gt.gmin) goto 2000
 836         end do
 837  2000   continue
 838         if(jx0.eq.nkr-1) return
 839 ! jx1 - upper limit of integration by j
 840         do j=nkr-1,jx0,-1
 841            jx1=j
 842            if(gx(j).gt.gmin) goto 2010
 843         end do
 844  2010   continue
 845 ! iy0 - lower limit of integration by i
 846         do i=1,nkr-1
 847            iy0=i
 848            if(gy(i).gt.gmin) goto 2001
 849         end do
 850  2001   continue
 851         if(iy0.eq.nkr-1) return
 852 ! iy1 - upper limit of integration by i
 853         do i=nkr-1,iy0,-1
 854            iy1=i
 855            if(gy(i).gt.gmin) goto 2011
 856         end do
 857  2011   continue
 858
 859          do i = 1,nkr
 860            dm_rime(i)=0.0
 861          end do
 862
 863 ! ... collisions :
 864         do i=iy0,iy1
 865            if(gy(i).le.gmin) goto 2020
 866            jmin=i
 867            if(jmin.eq.nkr-1) return
 868            if(i.lt.jx0) jmin=jx0-indc
 869                         do j=jmin+indc,jx1
 870               if(gx(j).le.gmin) goto 2021
 871               k=ima(i,j)
 872               kp=k+1
 873               x01=ckxy(j,i)*gy(i)*gx(j)*prdkrn
 874               x02=dmin1(x01,gy(i)*x(j))
 875                         ! new change of 20.01.11                                      (start)
 876               if(j.ne.k) x03=dmin1(x02,gx(j)*y(i))
 877               if(j.eq.k) x03=x02
 878                         ! new change of 20.01.11                                        (end)
 879               gsi=x03/x(j)
 880               gsj=x03/y(i)
 881               gsk=gsi+gsj
 882                                 if(gsk.le.gmin) goto 2021
 883               gsi_w=gsi*fly(i)
 884               gsj_w=gsj*flx(j)
 885               gsk_w=gsi_w+gsj_w
 886                                 gsk_w=dmin1(gsk_w,gsk)
 887               gy(i)=gy(i)-gsi
 888               gy(i)=dmax1(gy(i),0.0d0)
 889               gx(j)=gx(j)-gsj
 890                         ! new change of 20.01.11                                      (start)
 891               if(j.ne.k) gx(j)=dmax1(gx(j),0.0d0)
 892                         ! new change of 20.01.11                                        (end)
 893               gk=gx(k)+gsk
 894               if(gk.le.gmin) goto 2021
 895               gk_w=gx(k)*flx(k)+gsk_w
 896                                 gk_w=dmin1(gk_w,gk)
 897                     fl_gk=gk_w/gk
 898               fl_gsk=gsk_w/gsk
 899               flux=0.d0
 900               x1=dlog(gx(kp)/gk+1.d-15)
 901               flux=gsk/x1*(dexp(0.5d0*x1)-dexp(x1*(0.5d0-c(i,j))))
 902               flux=dmin1(flux,gsk)
 903               flux=dmin1(flux,gk)
 904
 905               if(kp.gt.kp_flux_max) flux=0.5d0*flux
 906               flux_w=flux*fl_gsk
 907               flux_w=dmin1(flux_w,gsk_w)
 908               flux_w=dmin1(flux_w,gk_w)
 909                                 frac_split = flux/gsk
 910               if(frac_split < 0.) frac_split = 0.
 911                     if(frac_split > 1.) frac_split = 1.
 912               dm_rime(k)=dm_rime(k)+gsi*(1.-frac_split)
 913               dm_rime(kp)=dm_rime(kp)+gsi*frac_split
 914               gx(k)=gk-flux
 915                     gx(k)=dmax1(gx(k),gmin)
 916
 917               gx_k_w=gk_w-flux_w
 918               gx_k_w=dmin1(gx_k_w,gx(k))
 919               gx_k_w=dmax1(gx_k_w,0.0d0)
 920               flx(k)=gx_k_w/gx(k)
 921               gx_kp_old=gx(kp)
 922               gx(kp)=gx(kp)+flux
 923               gx(kp)=dmax1(gx(kp),gmin)
 924
 925               gx_kp_w=gx_kp_old*flx(kp)+flux_w
 926               gx_kp_w=dmin1(gx_kp_w,gx(kp))
 927
 928               flx(kp)=gx_kp_w/gx(kp)
 929
 930               if(flx(k).gt.1.0d0.and.flx(k).le.1.0001d0) &
 931               flx(k)=1.0d0
 932
 933               if(flx(kp).gt.1.0d0.and.flx(kp).le.1.0001d0) &
 934                 flx(kp)=1.0d0
 935
 936               if(flx(k).gt.1.0001d0.or.flx(kp).gt.1.0001d0 &
 937               .or.flx(k).lt.0.0d0.or.flx(kp).lt.0.0d0) then
 938
 939               print*, 'in subroutine coll_xyx_lwf'
 940
 941               if(flx(k).gt.1.0001d0) &
 942               print*, 'flx(k).gt.1.0001d0'
 943
 944               if(flx(kp).gt.1.0001d0) &
 945               print*, 'flx(kp).gt.1.0001d0'
 946
 947               if(flx(k).lt.0.0d0)  print*, 'flx(k).lt.0.0d0'
 948               if(flx(kp).lt.0.0d0) print*, 'flx(kp).lt.0.0d0'
 949
 950                 print*,   'i,j,k,kp'
 951                 print*,    i,j,k,kp
 952
 953                 print*,   'jx0,jx1,iy0,iy1'
 954                 print*,    jx0,jx1,iy0,iy1
 955
 956                 print*,   'gx_kp_old'
 957                         print 201, gx_kp_old
 958
 959                 print*,   'ckxy(j,i),x01,x02,x03'
 960                         print 204, ckxy(j,i),x01,x02,x03
 961
 962                 print*,   'gsi,gsj,gsk'
 963                         print 203, gsi,gsj,gsk
 964
 965                 print*,   'gsi_w,gsj_w,gsk_w'
 966                         print 203, gsi_w,gsj_w,gsk_w
 967
 968                 print*,   'gk,gk_w'
 969                         print 202, gk,gk_w
 970
 971                 print*,   'fl_gk,fl_gsk'
 972                         print 202, fl_gk,fl_gsk
 973
 974                 print*,   'x1,c(i,j)'
 975                         print 202, x1,c(i,j)
 976
 977                 print*,   'flux'
 978                         print 201, flux
 979
 980                 print*,   'flux_w'
 981                         print 201, flux_w
 982
 983                 print*,   'gx_k_w'
 984                         print 201, gx_k_w
 985
 986                 print*,   'gx_kp_w'
 987                         print 201, gx_kp_w
 988
 989                                         if(flx(k).lt.0.0d0) print*, &
 990                                                    'stop 2022: in subroutine coll_xyx_lwf, flx(k) < 0'
 991
 992                                         if(flx(kp).lt.0.0d0) print*, &
 993                                                    'stop 2022: in subroutine coll_xyx_lwf, flx(kp) < 0'
 994
 995                                         if(flx(k).gt.1.0001d0) print*, &
 996                                                    'stop 2022: in sub. coll_xyx_lwf, flx(k) > 1.0001'
 997
 998                                         if(flx(kp).gt.1.0001d0) print*, &
 999                                                    'stop 2022: in sub. coll_xyx_lwf, flx(kp) > 1.0001'
1000                   call wrf_error_fatal("fatal error in module_mp_fast_sbm in coll_xyx_lwf (stop 2022), model stop")
1001                   stop 2022
1002                endif
1003  2021         continue
1004            enddo
1005 ! cycle by j
1006  2020      continue
1007         enddo
1008 ! cycle by i
1009
1010  201    format(1x,d13.5)
1011  202    format(1x,2d13.5)
1012  203    format(1x,3d13.5)
1013  204    format(1x,4d13.5)
1014
1015  return
1016  end subroutine coll_xyx_lwf
1017 ! -------------------------------------------------------+
1018  subroutine coll_xyz_lwf(gx,gy,gz,flx,fly,flz,ckxy,x,y, &
1019                         c,ima,prdkrn,nkr,indc)
1020
1021  implicit none
1022
1023  integer,intent(in) :: nkr
1024  real(kind=r8size),intent(inout) :: gx(:),gy(:),gz(:),flx(:),fly(:),flz(:)
1025  real(kind=r8size),intent(in) :: ckxy(:,:),x(:),y(:),c(:,:)
1026  integer,intent(in) :: ima(:,:)
1027  real(kind=r8size),intent(in) :: prdkrn
1028
1029 ! ... Locals
1030  real(kind=r8size) :: gmin,ckxy_ji,x01,x02,x03,gsi,gsj,gsk,gsi_w,gsj_w,gsk_w,gk, &
1031                       gk_w,fl_gk,fl_gsk,flux,x1,flux_w,gz_k_w,gz_kp_old,gz_kp_w
1032 integer :: j,jx0,jx1,i,iy0,iy1,jmin,indc,k,kp
1033 ! ... Locals
1034
1035 gmin = 1.0d-60
1036
1037 ! jx0 - lower limit of integration by j
1038 do j=1,nkr-1
1039  jx0=j
1040  if(gx(j).gt.gmin) goto 2000
1041 enddo
1042 2000   continue
1043 if(jx0.eq.nkr-1) return
1044
1045 ! jx1 - upper limit of integration by j
1046 do j=nkr-1,jx0,-1
1047  jx1=j
1048  if(gx(j).gt.gmin) goto 2010
1049 enddo
1050 2010   continue
1051
1052 ! iy0 - lower limit of integration by i
1053 do i=1,nkr-1
1054  iy0=i
1055  if(gy(i).gt.gmin) goto 2001
1056 enddo
1057 2001   continue
1058 if(iy0.eq.nkr-1) return
1059
1060 ! iy1 - upper limit of integration by i
1061 do i=nkr-1,iy0,-1
1062  iy1=i
1063  if(gy(i).gt.gmin) goto 2011
1064 enddo
1065 2011   continue
1066
1067 ! ... collisions
1068
1069       do i=iy0,iy1
1070          if(gy(i).le.gmin) goto 2020
1071          jmin=i
1072          if(jmin.eq.nkr-1) return
1073          if(i.lt.jx0) jmin=jx0-indc
1074          do j=jmin+indc,jx1
1075             if(gx(j).le.gmin) goto 2021
1076             k=ima(i,j)
1077             kp=k+1
1078             ckxy_ji=ckxy(j,i)
1079             x01=ckxy_ji*gy(i)*gx(j)*prdkrn
1080             x02=dmin1(x01,gy(i)*x(j))
1081             x03=dmin1(x02,gx(j)*y(i))
1082             gsi=x03/x(j)
1083             gsj=x03/y(i)
1084             gsk=gsi+gsj
1085             if(gsk.le.gmin) goto 2021
1086             gsi_w=gsi*fly(i)
1087             gsj_w=gsj*flx(j)
1088             gsk_w=gsi_w+gsj_w
1089             gsk_w=dmin1(gsk_w,gsk)
1090             gy(i)=gy(i)-gsi
1091             gy(i)=dmax1(gy(i),0.0d0)
1092
1093             gx(j)=gx(j)-gsj
1094             gx(j)=dmax1(gx(j),0.0d0)
1095
1096             gk=gz(k)+gsk
1097
1098             if(gk.le.gmin) goto 2021
1099
1100             gk_w=gz(k)*flz(k)+gsk_w
1101             gk_w=dmin1(gk_w,gk)
1102
1103             fl_gk=gk_w/gk
1104
1105             fl_gsk=gsk_w/gsk
1106
1107             flux=0.d0
1108
1109             x1=dlog(gz(kp)/gk+1.d-15)
1110
1111             flux=gsk/x1*(dexp(0.5d0*x1)-dexp(x1*(0.5d0-c(i,j))))
1112             flux=dmin1(flux,gsk)
1113             flux=dmin1(flux,gk)
1114
1115             if(kp.gt.kp_flux_max) flux=0.5d0*flux
1116
1117             flux_w=flux*fl_gsk
1118             flux_w=dmin1(flux_w,gsk_w)
1119             flux_w=dmin1(flux_w,gk_w)
1120
1121             gz(k)=gk-flux
1122             gz(k)=dmax1(gz(k),gmin)
1123
1124             gz_k_w=gk*fl_gk-flux_w
1125             gz_k_w=dmin1(gz_k_w,gz(k))
1126             gz_k_w=dmax1(gz_k_w,0.0d0)
1127
1128             flz(k)=gz_k_w/gz(k)
1129
1130             gz_kp_old=gz(kp)
1131
1132             gz(kp)=gz(kp)+flux
1133             gz(kp)=dmax1(gz(kp),gmin)
1134
1135             gz_kp_w=gz_kp_old*flz(kp)+flux_w
1136             gz_kp_w=dmin1(gz_kp_w,gz(kp))
1137
1138             flz(kp)=gz_kp_w/gz(kp)
1139
1140             if(flz(k).gt.1.0d0.and.flz(k).le.1.0001d0) &
1141             flz(k)=1.0d0
1142
1143             if(flz(kp).gt.1.0d0.and.flz(kp).le.1.0001d0) &
1144             flz(kp)=1.0d0
1145
1146             if(flz(k).gt.1.0001d0.or.flz(kp).gt.1.0001d0 &
1147             .or.flz(k).lt.0.0d0.or.flz(kp).lt.0.0d0) then
1148
1149             print*,    'in subroutine coll_xyz_lwf'
1150
1151             if(flz(k).gt.1.0001d0)  print*, 'flz(k).gt.1.0001d0'
1152             if(flz(kp).gt.1.0001d0) print*, 'flz(kp).gt.1.0001d0'
1153
1154             if(flz(k).lt.0.0d0)  print*, 'flz(k).lt.0.0d0'
1155             if(flz(kp).lt.0.0d0) print*, 'flz(kp).lt.0.0d0'
1156
1157             print*,   'i,j,k,kp'
1158             print*,    i,j,k,kp
1159
1160             print*,   'jx0,jx1,iy0,iy1'
1161             print*,    jx0,jx1,iy0,iy1
1162
1163             print*,   'gz_kp_old'
1164             print 201, gz_kp_old
1165
1166             print*,   'x01,x02,x03'
1167             print 203, x01,x02,x03
1168
1169             print*,   'gsi,gsj,gsk'
1170             print 203, gsi,gsj,gsk
1171
1172             print*,   'gsi_w,gsj_w,gsk_w'
1173             print 203, gsi_w,gsj_w,gsk_w
1174
1175             print*,   'gk,gk_w'
1176             print 202, gk,gk_w
1177
1178             print*,   'fl_gk,fl_gsk'
1179             print 202, fl_gk,fl_gsk
1180
1181             print*,   'x1,c(i,j)'
1182             print 202, x1,c(i,j)
1183
1184             print*,   'flux'
1185             print 201, flux
1186
1187             print*,   'flux_w'
1188             print 201, flux_w
1189
1190             print*,   'gz_k_w'
1191             print 201, gz_k_w
1192
1193             print*,   'gz_kp_w'
1194             print 204, gz_kp_w
1195
1196             if(flz(k).lt.0.0d0) print*, &
1197             'stop 2022: in subroutine coll_xyz_lwf, flz(k) < 0'
1198
1199             if(flz(kp).lt.0.0d0) print*, &
1200                'stop 2022: in subroutine coll_xyz_lwf, flz(kp) < 0'
1201
1202             if(flz(k).gt.1.0001d0) print*, &
1203                'stop 2022: in sub. coll_xyz_lwf, flz(k) > 1.0001'
1204
1205             if(flz(kp).gt.1.0001d0) print*, &
1206                'stop 2022: in sub. coll_xyz_lwf, flz(kp) > 1.0001'
1207               call wrf_error_fatal("fatal error: in sub. coll_xyz_lwf,model stop")
1208             endif
1209 2021         continue
1210          enddo
1211 ! cycle by j
1212 2020      continue
1213       enddo
1214 ! cycle by i
1215
1216 201    format(1x,d13.5)
1217 202    format(1x,2d13.5)
1218 203    format(1x,3d13.5)
1219 204    format(1x,4d13.5)
1220
1221  return
1222  end subroutine coll_xyz_lwf
1223 ! -----------------------------------------------+
1224  subroutine coll_xxy_lwf(gx,gy,flx,fly,ckxx,x, &
1225                         c,ima,prdkrn,nkr)
1226
1227   implicit none
1228
1229   integer,intent(in) :: nkr
1230   real(kind=r8size),intent(inout):: gx(nkr),gy(nkr),flx(nkr),fly(nkr)
1231   real(kind=r8size),intent(in) :: x(nkr),ckxx(nkr,nkr),c(nkr,nkr)
1232   real(kind=r8size),intent(in) :: prdkrn
1233   integer,intent(in) :: ima(nkr,nkr)
1234
1235 ! ... Locals
1236   real(kind=r8size) :: gmin,ckxx_ij,x01,x02,x03,gsi,gsj,gsk,gsi_w,gsj_w,gsk_w, &
1237                        gk,gk_w,flux,flux_w,fl_gk,fl_gsk,x1,gy_k_w,gy_kp_w, &
1238                        gy_kp_old
1239   integer::i,ix0,ix1,j,k,kp
1240 ! ... Locals
1241
1242 !gmin=g_lim*1.0d3
1243 gmin = 1.0d-60
1244
1245 ! ix0 - lower limit of integration by i
1246 do i=1,nkr-1
1247    ix0=i
1248    if(gx(i).gt.gmin) goto 2000
1249 enddo
1250 2000   continue
1251 if(ix0.eq.nkr-1) return
1252
1253 ! ix1 - upper limit of integration by i
1254 do i=nkr-1,ix0,-1
1255    ix1=i
1256    if(gx(i).gt.gmin) goto 2010
1257 enddo
1258 2010   continue
1259
1260 ! ... collisions
1261       do i=ix0,ix1
1262          if(gx(i).le.gmin) goto 2020
1263          do j=i,ix1
1264             if(gx(j).le.gmin) goto 2021
1265             k=ima(i,j)
1266             kp=k+1
1267             ckxx_ij = ckxx(i,j)
1268             x01=ckxx_ij*gx(i)*gx(j)*prdkrn
1269             x02=dmin1(x01,gx(i)*x(j))
1270             x03=dmin1(x02,gx(j)*x(i))
1271             gsi=x03/x(j)
1272             gsj=x03/x(i)
1273             gsk=gsi+gsj
1274
1275             if(gsk.le.gmin) goto 2021
1276
1277             gsi_w=gsi*flx(i)
1278             gsj_w=gsj*flx(j)
1279             gsk_w=gsi_w+gsj_w
1280             gsk_w=dmin1(gsk_w,gsk)
1281
1282             gx(i)=gx(i)-gsi
1283             gx(i)=dmax1(gx(i),0.0d0)
1284
1285             gx(j)=gx(j)-gsj
1286             gx(j)=dmax1(gx(j),0.0d0)
1287
1288             gk=gy(k)+gsk
1289
1290             if(gk.le.gmin) goto 2021
1291
1292             gk_w=gy(k)*fly(k)+gsk_w
1293             gk_w=dmin1(gk_w,gk)
1294             fl_gk=gk_w/gk
1295             fl_gsk=gsk_w/gsk
1296
1297             flux=0.d0
1298
1299             x1=dlog(gy(kp)/gk+1.d-15)
1300             !           print *,'nir1',gy(kp),gk,kp,i,j
1301             flux=gsk/x1*(dexp(0.5d0*x1)-dexp(x1*(0.5d0-c(i,j))))
1302             flux=dmin1(flux,gsk)
1303             flux=dmin1(flux,gk)
1304
1305             if(kp.gt.kp_flux_max) flux=0.5d0*flux
1306
1307             flux_w=flux*fl_gsk
1308             flux_w=dmin1(flux_w,gk_w)
1309             flux_w=dmin1(flux_w,gsk_w)
1310             flux_w=dmax1(flux_w,0.0d0)
1311
1312             gy(k)=gk-flux
1313             gy_k_w=gk*fl_gk-flux_w
1314             gy_k_w=dmin1(gy_k_w,gy(k))
1315             gy_k_w=dmax1(gy_k_w,0.0d0)
1316             !           print *,'nirxxylwf4',k,gy(k),gy_k_w,x1,flux
1317             if (gy(k)/=0.0) then
1318               fly(k)=gy_k_w/gy(k)
1319             else
1320               fly(k)=0.0d0
1321             endif
1322             gy_kp_old=gy(kp)
1323             gy(kp)=gy(kp)+flux
1324             gy_kp_w=gy_kp_old*fly(kp)+flux_w
1325             gy_kp_w=dmin1(gy_kp_w,gy(kp))
1326             if (gy(kp)/=0.0) then
1327               fly(kp)=gy_kp_w/gy(kp)
1328             else
1329               fly(kp)=0.0d0
1330             endif
1331 2021  continue
1332
1333       if(fly(k).gt.1.0d0.and.fly(k).le.1.0001d0) &
1334           fly(k)=1.0d0
1335
1336         if(fly(kp).gt.1.0d0.and.fly(kp).le.1.0001d0) &
1337           fly(kp)=1.0d0
1338
1339          end do
1340 ! cycle by j
1341 2020      continue
1342       end do
1343 ! cycle by i
1344
1345  return
1346  end subroutine coll_xxy_lwf
1347 ! +-------------------------------------------+
1348  SUBROUTINE INTERPOL_SE (NH, H_TAB, X_TAB, H, X)
1349
1350   implicit none
1351 ! ### Interface
1352  integer :: NH
1353  real(kind=r4size) :: H_TAB(NH), X_TAB(NH)
1354  real(kind=r8size) :: H, X
1355 ! ### Interface
1356  integer :: I, J
1357
1358  IF(H > H_TAB(1)) THEN
1359     X = X_TAB(1)
1360     RETURN
1361  ENDIF
1362
1363  IF(H < H_TAB(NH)) THEN
1364     X = X_TAB(NH)
1365     RETURN
1366  ENDIF
1367
1368  DO I = 2,NH
1369     IF(H > H_TAB(I)) THEN
1370        J = I-1
1371        X = X_TAB(J)+(X_TAB(I)-X_TAB(J))/ &
1372            (H_TAB(I)-H_TAB(J))*(H-H_TAB(J))
1373
1374        RETURN
1375     ENDIF
1376  ENDDO
1377
1378  RETURN
1379  END SUBROUTINE INTERPOL_SE
1380 ! +-------------------------------------------------------------------------------+
1381     subroutine modkrn_KS (tt,qq,pp,rho,factor_t,ttcoal,ICase,Icondition, &
1382                           Iin,Jin,Kin)
1383
1384     implicit none
1385
1386     real(kind=r8size),intent(in) :: tt, pp
1387     real(kind=r8size),intent(inout) :: qq
1388     real(kind=r4size),intent(in) :: ttcoal, rho
1389     real(kind=r8size),intent(out) :: factor_t
1390     integer :: ICase, Iin, Jin, Kin, Icondition
1391
1392     real(kind=r8size) :: satq2, temp, epsf, tc, ttt1, ttt, qs2, qq1, dele, tc_min, &
1393                           tc_max, factor_max, factor_min, f, t, a, b, c, p, d
1394     real(kind=r8size) :: at, bt, ct, dt
1395     real(kind=r8size) :: AA,BB,CC,DD,Es,Ew,AA1_MY,BB1_MY
1396     real(kind=r4size) :: tt_r, T_tab(7), SE_tab(7)
1397
1398     satq2(t,p) = 3.80d3*(10**(9.76421d0-2667.1d0/t))/p
1399     temp(a,b,c,d,t) = d*t*t*t+c*t*t+b*t+a
1400
1401
1402     tc = tt - 273.15
1403     if (tc > 0.0) return
1404
1405     SELECT CASE (ICase)
1406
1407     CASE(1)
1408
1409         !satq2(t,p) = 3.80d3*(10**(9.76421d0-2667.1d0/t))/p
1410         !temp(a,b,c,d,t) = d*t*t*t+c*t*t+b*t+a
1411
1412         data at, bt, ct, dt /0.88333d0,  0.0931878d0,  0.0034793d0,  4.5185186d-05/
1413
1414         if(qq.le.0.0) qq = 1.0e-15
1415           epsf = 0.5d0
1416           tc = tt - 273.15
1417
1418           ttt1  =temp(at,bt,ct,dt,tc)
1419           ttt   =ttt1
1420           qs2   =satq2(tt,pp)
1421           qq1   =qq*(0.622d0+0.378d0*qs2)/(0.622d0+0.378d0*qq)/qs2
1422           dele  =ttt*qq1
1423
1424           if(tc.ge.-6.0d0) then
1425             factor_t = dele
1426             if(factor_t.lt.epsf) factor_t = epsf
1427             if(factor_t.gt.1.0d0) factor_t = 1.0d0
1428           endif
1429
1430           if (Icondition == 0) then
1431             if(tc.ge.-12.5d0 .and. tc.lt.-6.0d0) factor_t = 0.5D0  ! 0.5d0 !### (KS-ICE-SNOW)
1432             if(tc.ge.-17.0d0 .and. tc.lt.-12.5d0) factor_t = 1.0
1433             if(tc.ge.-20.0d0 .and. tc.lt.-17.0d0) factor_t = 0.4d0
1434           else
1435             if(tc.ge.-12.5d0 .and. tc.lt.-6.0d0) factor_t = 0.3D0  ! 0.5d0 !### (KS-ICE-SNOW)
1436             if(tc.ge.-17.0d0 .and. tc.lt.-12.5d0) factor_t = 0.1d0
1437             if(tc.ge.-20.0d0 .and. tc.lt.-17.0d0) factor_t = 0.05d0
1438           endif
1439
1440         if(tc.lt.-20.0d0) then
1441           tc_min = ttcoal-273.15d0
1442           tc_max = -20.0d0
1443           if(Icondition == 0)then
1444             factor_max = 0.4d0
1445             factor_min = 0.0d0
1446           else
1447             factor_max = 0.05d0
1448             factor_min = 0.0d0
1449           endif
1450
1451           f = factor_min + (tc-tc_min)*(factor_max-factor_min)/ &
1452                           (tc_max-tc_min)
1453           factor_t = f
1454         ! in case tc.lt.-20.0d0
1455         endif
1456
1457         if(tc.lt.-40.0d0) then
1458           factor_t = 0.0d0
1459         endif
1460
1461         if (factor_t > 1.0) factor_t = 1.0
1462
1463         if(tc.ge.0.0d0) then
1464           factor_t = 1.0d0
1465         endif
1466
1467     CASE(11)
1468
1469     ! ... Dashed-dotted (linear)
1470     T_tab =  [0.0, -0.813, -5.26, -10.13, -14.63, -20.02, -40.0 ]
1471     SE_tab = [10.0**(-0.693), 10.0**(-0.72), 10.0**(-0.877), 10.0**(-1.050),  10.0**(-1.212),  10.0**(-1.401),  10.0**(-2.082) ]
1472
1473
1474     CALL INTERPOL_SE (size(SE_tab), T_TAB, SE_TAB, TC, factor_t)
1475
1476       if(tc < -40.0d0) then
1477           factor_t = 0.0d0
1478       endif
1479
1480       if (factor_t > 1.0) factor_t = 1.0
1481
1482       if(tc > 0.0d0) then
1483           factor_t = 1.0d0
1484       endif
1485
1486     END SELECT
1487
1488   return
1489   end subroutine modkrn_KS
1490   ! +-----------------------------------------------------------+
1491   subroutine coll_breakup_KS (gt_mg, xt_mg, jmax, dt, jbreak, &
1492                               PKIJ, QKJ, NKRinput, NKR)
1493
1494     implicit none
1495   ! ... Interface
1496     integer,intent(in) :: jmax, jbreak, NKRInput, NKR
1497     real(kind=r8size),intent(in) :: xt_mg(:), dt
1498     real(kind=r4size),intent(in) :: pkij(:,:,:),qkj(:,:)
1499     real(kind=r8size),intent(inout) :: gt_mg(:)
1500   ! ... Interface
1501
1502   ! ... Locals
1503   ! ke = jbreak
1504   integer,parameter :: ia=1, ja=1, ka=1
1505   integer :: ie, je, ke, nkrdiff, jdiff, k, i, j
1506   real(kind=r8size),parameter :: eps = 1.0d-20
1507   real(kind=r8size) :: gt(jmax), xt(jmax+1), ft(jmax), fa(jmax), dg(jmax), df(jmax), dbreak(jbreak) &
1508                      ,amweight(jbreak), gain, aloss
1509   ! ... Locals
1510
1511   ie=jbreak
1512   je=jbreak
1513   ke=jbreak
1514
1515   !input variables
1516
1517   ! gt_mg : mass distribution function of Bott
1518   ! xt_mg : mass of bin in mg
1519   ! jmax  : number of bins
1520   ! dt    : timestep in s
1521
1522   !in CGS
1523
1524   nkrdiff = nkrinput-nkr
1525   do j=1,jmax
1526   xt(j)=xt_mg(j)
1527   gt(j)=gt_mg(j)
1528   ft(j)=gt(j)/xt(j)/xt(j)
1529   enddo
1530
1531   !shift between coagulation and breakup grid
1532   jdiff=jmax-jbreak
1533
1534   !initialization
1535   !shift to breakup grid
1536   fa = 0.0
1537   do k=1,ke-nkrdiff
1538     fa(k)=ft(k+jdiff+nkrdiff)
1539   enddo
1540
1541   !breakup: bleck's first order method
1542   !pkij: gain coefficients
1543   !qkj : loss coefficients
1544
1545   xt(jmax+1)=xt(jmax)*2.0d0
1546
1547   amweight = 0.0
1548   dbreak = 0.0
1549   do k=1,ke-nkrdiff
1550     gain=0.0d0
1551     do i=1,ie-nkrdiff
1552       do j=1,i
1553         gain=gain+fa(i)*fa(j)*pkij(k,i,j)
1554       enddo
1555     enddo
1556     aloss=0.0d0
1557     do j=1,je-nkrdiff
1558       aloss=aloss+fa(j)*qkj(k,j)
1559     enddo
1560     j=jmax-jbreak+k+nkrdiff
1561     amweight(k)=2.0/(xt(j+1)**2.0-xt(j)**2.0)
1562     dbreak(k)=amweight(k)*(gain-fa(k)*aloss)
1563
1564     if(dbreak(k) .ne. dbreak(k)) then
1565       print*,dbreak(k),amweight(k),gain,fa(k),aloss
1566       print*,"-"
1567       print*,dbreak
1568       print*,"-"
1569       print*,amweight
1570       print*,"-"
1571       print*,j,jmax,jbreak,k,nkrdiff
1572       print*,"-"
1573       print*,fa
1574       print*,"-"
1575       print*,xt
1576       print*,"-"
1577       print*,gt
1578       call wrf_error_fatal(" inside coll_breakup, NaN, model stop")
1579     endif
1580   enddo
1581
1582   !shift rate to coagulation grid
1583   df = 0.0d0
1584   do j=1,jdiff+nkrdiff
1585     df(j)=0.0d0
1586   enddo
1587
1588   do j=1,ke-nkrdiff
1589     df(j+jdiff)=dbreak(j)
1590   enddo
1591
1592   !transformation to mass distribution function g(ln x)
1593   do j=1,jmax
1594     dg(j)=df(j)*xt(j)*xt(j)
1595   enddo
1596
1597   !time integration
1598
1599   do j=1,jmax
1600     gt(j)=gt(j)+dg(j)*dt
1601   !     if(gt(j)<0.0) then
1602     !print*, 'gt(j) < 0'
1603     !print*, 'j'
1604     !print*,  j
1605     !print*, 'dg(j),dt,gt(j)'
1606     !print*,  dg(j),dt,gt(j)
1607     !hlp=dmin1(gt(j),hlp)
1608   !     gt(j) = eps
1609   !     print*,'kr',j
1610   !     print*,'gt',gt
1611   !     print*,'dg',dg
1612   !     print*,'gt_mg',gt_mg
1613     !stop "in coll_breakup_ks gt(kr) < 0.0 "
1614   !     endif
1615   enddo
1616
1617    gt_mg = gt
1618
1619   return
1620   end subroutine coll_breakup_KS
1621   ! +----------------------------------------------------+
1622   subroutine courant_bott_KS(xl, nkr, chucm, ima, scal)
1623
1624     implicit none
1625
1626     integer,intent(in) :: nkr
1627     real,intent(in) :: xl(:)
1628     real(kind=r8size),intent(inout) :: chucm(:,:)
1629     integer,intent(inout) :: ima(:,:)
1630     real(kind=r8size),intent(in) :: scal
1631
1632     ! ... Locals
1633     integer :: k, kk, j, i
1634     real(kind=r8size) :: x0, xl_mg(nkr), dlnr
1635     ! ... Locals
1636
1637     ! ima(i,j) - k-category number,
1638     ! chucm(i,j)   - courant number :
1639     ! logarithmic grid distance(dlnr) :
1640
1641       !xl_mg(0)=xl_mg(1)/2
1642       xl_mg(1:nkr) = xl(1:nkr)*1.0D3
1643
1644       dlnr=dlog(2.0d0)/(3.0d0*scal)
1645
1646       do i = 1,nkr
1647          do j = i,nkr
1648             x0 = xl_mg(i) + xl_mg(j)
1649             do k = j,nkr
1650               !if(k == 1) goto 1000 ! ### (KS)
1651                kk = k
1652                if(k == 1) goto 1000
1653                if(xl_mg(k) >= x0 .and. xl_mg(k-1) < x0) then
1654                  chucm(i,j) = dlog(x0/xl_mg(k-1))/(3.d0*dlnr)
1655                  if(chucm(i,j) > 1.0d0-1.d-08) then
1656                    chucm(i,j) = 0.0d0
1657                    kk = kk + 1
1658                  endif
1659                  ima(i,j) = min(nkr-1,kk-1)
1660                  !if (ima(i,j) == 0) then
1661                  !      print*,"ima==0"
1662                  !endif
1663                  goto 2000
1664                endif
1665                1000 continue
1666             enddo
1667             2000  continue
1668             !if(i.eq.nkr.or.j.eq.nkr) ima(i,j)=nkr
1669             chucm(j,i) = chucm(i,j)
1670             ima(j,i) = ima(i,j)
1671          enddo
1672       enddo
1673
1674       return
1675       end subroutine courant_bott_KS
1676   ! +----------------------------------+
1677 end module module_mp_SBM_Collision
1678 ! +-----------------------------------------------------------------------------+
1679 ! +-----------------------------------------------------------------------------+
1680  module module_mp_SBM_Auxiliary
1681
1682  private
1683  public :: POLYSVP, JERRATE_KS, JERTIMESC_KS, JERSUPSAT_KS, &
1684                        JERDFUN_KS, JERDFUN_NEW_KS, Relaxation_Time
1685
1686  ! Kind paramater
1687  INTEGER, PARAMETER, PRIVATE:: R8SIZE = 8
1688  INTEGER, PARAMETER, PRIVATE:: R4SIZE = 4
1689
1690  INTEGER,PARAMETER :: ISIGN_KO_1 = 0, ISIGN_KO_2 = 0,  ISIGN_3POINT = 1,  &
1691                       IDebug_Print_DebugModule = 1
1692  DOUBLE PRECISION,PARAMETER::COEFF_REMAPING = 0.0066667D0
1693  DOUBLE PRECISION,PARAMETER::VENTPL_MAX = 5.0D0
1694
1695  DOUBLE PRECISION,PARAMETER::RW_PW_MIN = 1.0D-10
1696  DOUBLE PRECISION,PARAMETER::RI_PI_MIN = 1.0D-10
1697  DOUBLE PRECISION,PARAMETER::RW_PW_RI_PI_MIN = 1.0D-10
1698  DOUBLE PRECISION,PARAMETER::RATIO_ICEW_MIN = 1.0D-4
1699
1700  contains
1701 ! +----------------------------------------------------------+
1702  double precision FUNCTION POLYSVP (TT,ITYPE)
1703
1704  implicit none
1705
1706  real,intent(in) :: TT
1707  integer,intent(in) :: ITYPE
1708
1709  real(4),parameter :: C1 = -9.09718E0, C2 = -3.56654E0, C3 = 0.876793E0, C4 = 0.78583503E0, &
1710                       AA1_MY = 2.53E12, BB1_MY = 5.42E3, AA2_MY = 3.41E13, BB2_MY = 6.13E3
1711  real(4) :: ES1N, ES2N
1712
1713  method_select: SELECT CASE(ITYPE)
1714
1715  ! liquid
1716  Case(0)
1717    ES1N = AA1_MY*EXP(-BB1_MY/TT)
1718    POLYSVP = ES1N ! [dyn/cm2] to [mb]
1719
1720  ! ice
1721  Case(1)
1722    ES2N = AA2_MY*EXP(-BB2_MY/TT)
1723    POLYSVP = ES2N ! [dyn/cm2] to [mb]
1724
1725  END SELECT method_select
1726
1727  return
1728  end function POLYSVP
1729 ! + -------------------------------------------------------- +
1730       SUBROUTINE JERRATE_KS (xlS, &
1731                                                                 TP,PP, &
1732                                                                 Vxl,RIEC,RO1BL, &
1733                                                                 B11_MY, &
1734                                                                 ID,IN,fl1,NKR,ICEMAX)
1735
1736                 IMPLICIT NONE
1737 ! ... Interface
1738                 INTEGER,INTENT(IN) :: ID, IN, NKR, ICEMAX
1739                 REAL(KIND=r4size),INTENT(IN) :: RO1BL(NKR,ID),RIEC(NKR,ID),FL1(NKR)
1740                 REAL(KIND=r4size),INTENT(INOUT) :: B11_MY(NKR,ID)
1741                 REAL(KIND=r8size),INTENT(IN) :: PP, TP, xlS(NKR,ID),Vxl(NKR,ID)
1742 ! ... Interface
1743 ! ... Locals
1744                 INTEGER :: KR, nskin(nkr), ICE
1745                 REAL(KIND=r4size) :: VENTPLM(NKR), FD1(NKR,ICEMAX),FK1(NKR,ICEMAX), xl_MY1(NKR,ICEMAX), &
1746                                       AL1_MY(2),ESAT1(2), TPreal
1747                 REAL(KIND=r8size) :: PZERO, TZERO, CONST, D_MY, COEFF_VISCOUS, SHMIDT_NUMBER,     &
1748                                                                    A, B, RVT, SHMIDT_NUMBER03, XLS_KR_ICE, RO1BL_KR_ICE, VXL_KR_ICE, REINOLDS_NUMBER, &
1749                                                                    RESHM, VENTPL, CONSTL, DETL
1750
1751                 REAL(KIND=r4size) :: deg01,deg03
1752
1753 ! A1L_MY - CONSTANTS FOR "MAXWELL": MKS
1754                 REAL(KIND=r8size),parameter:: RV_MY=461.5D4, CF_MY=2.4D3, D_MYIN=0.211D0
1755
1756 ! CGS :
1757
1758 ! RV_MY, CM*CM/SEC/SEC/KELVIN - INDIVIDUAL GAS CONSTANT
1759 !                               FOR WATER VAPOUR
1760         !RV_MY=461.5D4
1761
1762 ! D_MYIN, CM*CM/SEC - COEFFICIENT OF DIFFUSION OF WATER VAPOUR
1763
1764         !D_MYIN=0.211D0
1765
1766 ! PZERO, DYNES/CM/CM - REFERENCE PRESSURE
1767
1768         PZERO=1.013D6
1769
1770 ! TZERO, KELVIN - REFERENCE TEMPERATURE
1771
1772         TZERO=273.15D0
1773
1774 do kr=1,nkr
1775         if (in==2 .and. fl1(kr)==0.0 .or. in==6 .or. in==3 .and. tp<273.15) then
1776            nskin(kr) = 2
1777         else !in==1 or in==6 or lef/=0
1778            nskin(kr) = 1
1779         endif
1780 enddo
1781
1782 ! CONSTANTS FOR CLAUSIUS-CLAPEYRON EQUATION :
1783
1784 ! A1_MY(1),G/SEC/SEC/CM
1785
1786 !       A1_MY(1)=2.53D12
1787
1788 ! A1_MY(2),G/SEC/SEC/CM
1789
1790 !       A1_MY(2)=3.41D13
1791
1792 ! BB1_MY(1), KELVIN
1793
1794 !       BB1_MY(1)=5.42D3
1795
1796 ! BB1_MY(2), KELVIN
1797
1798 !       BB1_MY(2)=6.13D3
1799
1800 ! AL1_MY(1), CM*CM/SEC/SEC - LATENT HEAT OF VAPORIZATION
1801
1802         AL1_MY(1)=2.5D10
1803
1804 ! AL1_MY(2), CM*CM/SEC/SEC - LATENT HEAT OF SUBLIMATION
1805
1806         AL1_MY(2)=2.834D10
1807
1808 ! CF_MY, G*CM/SEC/SEC/SEC/KELVIN - COEFFICIENT OF
1809 !                                  THERMAL CONDUCTIVITY OF AIR
1810         !CF_MY=2.4D3
1811
1812   DEG01=1.0/3.0
1813   DEG03=1.0/3.0
1814
1815         CONST=12.566372D0
1816
1817 ! coefficient of diffusion
1818
1819         D_MY=D_MYIN*(PZERO/PP)*(TP/TZERO)**1.94D0
1820
1821 ! coefficient of viscousity
1822
1823 ! COEFF_VISCOUS=0.13 cm*cm/sec
1824
1825         COEFF_VISCOUS=0.13D0
1826
1827 ! Shmidt number
1828
1829         SHMIDT_NUMBER=COEFF_VISCOUS/D_MY
1830
1831 ! Constants used for calculation of Reinolds number
1832
1833         A=2.0D0*(3.0D0/4.0D0/3.141593D0)**DEG01
1834         B=A/COEFF_VISCOUS
1835
1836         RVT=RV_MY*TP
1837   !     ESAT1(IN)=A1_MY(IN)*DEXP(-BB1_MY(IN)/TP)
1838   !     if (IN==1) then
1839   !            ESAT1(IN)=EW(TP)
1840   !     ELSE
1841   !            ESAT1(IN)=EI(TP)
1842   !     endif
1843
1844                 ! ... (KS) - update the saturation vapor pressure
1845                 !ESAT1(1)=EW(TP)
1846     !ESAT1(2)=EI(TP)
1847                 TPreal = TP
1848                 ESAT1(1) = POLYSVP(TPreal,0)
1849                 ESAT1(2) = POLYSVP(TPreal,1)
1850
1851            DO KR=1,NKR
1852               VENTPLM(KR)=0.0D0
1853     ENDDO
1854
1855                 SHMIDT_NUMBER03=SHMIDT_NUMBER**DEG03
1856
1857            DO ICE=1,ID
1858               DO KR=1,NKR
1859
1860           xlS_KR_ICE=xlS(KR,ICE)
1861           RO1BL_KR_ICE=RO1BL(KR,ICE)
1862           Vxl_KR_ICE=Vxl(KR,ICE)
1863 ! Reynolds numbers
1864           REINOLDS_NUMBER= &
1865               B*Vxl_KR_ICE*(xlS_KR_ICE/RO1BL_KR_ICE)**DEG03
1866           RESHM=DSQRT(REINOLDS_NUMBER)*SHMIDT_NUMBER03
1867
1868           IF(REINOLDS_NUMBER<2.5D0) THEN
1869             VENTPL=1.0D0+0.108D0*RESHM*RESHM
1870             VENTPLM(KR)=VENTPL
1871           ELSE
1872             VENTPL=0.78D0+0.308D0*RESHM
1873             VENTPLM(KR)=VENTPL
1874           ENDIF
1875
1876         ENDDO
1877 ! cycle by KR
1878
1879 ! VENTPL_MAX is given in MICRO.PRM include file
1880
1881              DO KR=1,NKR
1882
1883         VENTPL=VENTPLM(KR)
1884
1885         IF(VENTPL>VENTPL_MAX) THEN
1886           VENTPL=VENTPL_MAX
1887           VENTPLM(KR)=VENTPL
1888         ENDIF
1889
1890         CONSTL=CONST*RIEC(KR,ICE)
1891
1892         FD1(KR,ICE)=RVT/D_MY/ESAT1(nskin(kr))
1893         FK1(KR,ICE)=(AL1_MY(nskin(kr))/RVT-1.0D0)*AL1_MY(nskin(kr))/CF_MY/TP
1894
1895         xl_MY1(KR,ICE)=VENTPL*CONSTL
1896         ! growth rate
1897         DETL=FK1(KR,ICE)+FD1(KR,ICE)
1898         B11_MY(KR,ICE)=xl_MY1(KR,ICE)/DETL
1899
1900        ENDDO
1901 ! cycle by KR
1902
1903       ENDDO
1904 ! cycle by ICE
1905
1906         RETURN
1907         END SUBROUTINE JERRATE_KS
1908
1909 ! SUBROUTINE JERRATE
1910 ! ................................................................................
1911         SUBROUTINE JERTIMESC_KS (FI1,X1,SFN11, &
1912                                                        B11_MY,CF,ID,NKR,ICEMAX,COL)
1913
1914         IMPLICIT NONE
1915
1916 ! ... Interface
1917         INTEGER,INTENT(IN) :: ID,NKR,ICEMAX
1918         REAL(KIND=r4size),INTENT(in) :: B11_MY(NKR,ID), FI1(NKR,ID), COL, CF
1919         REAL(KIND=r8size),INTENT(in) :: X1(NKR,ID)
1920         REAL(KIND=r4size),INTENT(out) :: SFN11(ID)
1921 ! ... Interface
1922
1923 ! ... Locals
1924         INTEGER :: ICE, KR
1925         REAL(KIND=r4size) :: SFN11S, FK, DELM, FUN, B11
1926 ! ... Locals
1927
1928         DO ICE=1,ID
1929      SFN11S=0.0D0
1930            SFN11(ICE)=CF*SFN11S
1931    DO KR=1,NKR
1932 ! value of size distribution functions
1933         FK=FI1(KR,ICE)
1934 ! delta-m
1935         DELM=X1(KR,ICE)*3.0D0*COL
1936 ! integral's expression
1937                 FUN=FK*DELM
1938 ! values of integrals
1939                 B11=B11_MY(KR,ICE)
1940                         SFN11S=SFN11S+FUN*B11
1941   ENDDO
1942 ! cycle by kr
1943 ! correction
1944         SFN11(ICE)=CF*SFN11S
1945   ENDDO
1946
1947 ! cycle by ice
1948
1949         RETURN
1950         END SUBROUTINE JERTIMESC_KS
1951 ! +--------------------------------------------------------+
1952         SUBROUTINE JERSUPSAT_KS (DEL1,DEL2,DEL1N,DEL2N, &
1953                                              RW,PW,RI,PI, &
1954                                            DT,DEL1INT,DEL2INT,DYN1,DYN2, &
1955                                            ISYM1,ISYM2,ISYM3,ISYM4,ISYM5)
1956
1957                 IMPLICIT NONE
1958 ! ... Interface
1959                 INTEGER,INTENT(INOUT) ::                ISYM1, ISYM2(:), ISYM3, ISYM4, ISYM5
1960                 REAL(KIND=r4size),INTENT(IN) ::   DT, DYN1, DYN2
1961                 REAL(KIND=r8size),INTENT(IN) ::         DEL1, DEL2
1962                 REAL(KIND=r8size),INTENT(INOUT) :: DEL1N,DEL2N,DEL1INT,DEL2INT,RW, PW, RI, PI
1963 ! ... Interface
1964 ! ... Locals
1965            INTEGER :: I, ISYMICE, IRW, IPW, IRI, IPI
1966            REAL(KIND=r8size) :: X, EXPM1, DETER, EXPR, EXPP, A, ALFA, BETA, GAMA, G31, G32, G2, EXPB, EXPG, &
1967                                           C11, C21, C12, C22, A1DEL1N, A2DEL1N, A3DEL1N, A4DEL1N, A1DEL1INT, A2DEL1INT, &
1968                                                         A3DEL1INT, A4DEL1INT, A1DEL2N, A2DEL2N, A3DEL2N , A4DEL2N, A1DEL2INT, A2DEL2INT, &
1969                                                         A3DEL2INT, A4DEL2INT, A5DEL2INT
1970 ! ... Locals
1971
1972                 EXPM1(x)=x+x*x/2.0D0+x*x*x/6.0D0+x*x*x*x/24.0D0+ &
1973                  x*x*x*x*x/120.0D0
1974
1975   ISYMICE = sum(ISYM2) + ISYM3 + ISYM4 + ISYM5
1976   IRW = 1
1977   IPW = 1
1978   IRI = 1
1979   IPI = 1
1980
1981         IF(max(RW,PW,RI,PI)<=RW_PW_RI_PI_MIN) THEN
1982
1983     RW = 0.0
1984     IRW = 0
1985     PW = 0.0
1986     IPW = 0
1987     RI = 0.0
1988     IRI = 0
1989     PI = 0.0
1990     IPI = 0
1991     ISYM1 = 0
1992     ISYMICE = 0
1993
1994         ELSE
1995
1996     IF(DMAX1(RW,PW)>RW_PW_MIN) THEN
1997
1998                         ! ... (KS) - A zero can pass through, assign a minimum value
1999                         IF(RW < RW_PW_MIN*RW_PW_MIN) THEN
2000         RW = 1.0D-20
2001         IRW = 0
2002       ENDIF
2003       IF(PW < RW_PW_MIN*RW_PW_MIN)THEN
2004         PW = 1.0D-20
2005         IPW = 0
2006       ENDIF
2007
2008       IF(DMAX1(PI/PW,RI/RW)<=RATIO_ICEW_MIN) THEN
2009                           ! ... only water
2010         RI = 0.0
2011         IRI = 0
2012         PI = 0.0
2013         IPI = 0
2014         ISYMICE = 0
2015       ENDIF
2016
2017       IF(DMIN1(PI/PW,RI/RW)>1.0D0/RATIO_ICEW_MIN) THEN
2018                           ! ... only ice
2019         RW = 0.0
2020         IRW = 0
2021         PW = 0.0
2022         IPW = 0
2023         ISYM1 = 0
2024       ENDIF
2025
2026     ELSE
2027                         ! only ice
2028                         RW = 0.0
2029       IRW = 0
2030       PW = 0.0
2031       IPW = 0
2032       ISYM1 = 0
2033
2034           ENDIF
2035          ENDIF
2036
2037         IF(ISYMICE == 0)THEN
2038                 ISYM2 = 0
2039                 ISYM3 = 0
2040                 ISYM4 = 0
2041                 ISYM5 = 0
2042         ENDIF
2043
2044     DETER=RW*PI-PW*RI
2045
2046
2047     IF(IRW == 0 .AND. IRI == 0) THEN
2048
2049           DEL1N=DEL1+DYN1*DT
2050           DEL2N=DEL2+DYN2*DT
2051           DEL1INT=DEL1*DT+DYN1*DT*DT/2.0D0
2052           DEL2INT=DEL2*DT+DYN2*DT*DT/2.0D0
2053
2054           GOTO 100
2055
2056     ENDIF
2057
2058 ! solution of equation for supersaturation with
2059 ! different DETER values
2060
2061     IF(IRI == 0) THEN
2062 ! ... only water                                                     (start)
2063
2064       EXPR=EXP(-RW*DT)
2065       IF(ABS(RW*DT)>1.0E-6) THEN
2066         DEL1N=DEL1*EXPR+(DYN1/RW)*(1.0D0-EXPR)
2067         DEL2N=PW*DEL1*EXPR/RW-PW*DYN1*DT/RW- &
2068               PW*DYN1*EXPR/(RW*RW)+DYN2*DT+ &
2069               DEL2-PW*DEL1/RW+PW*DYN1/(RW*RW)
2070         DEL1INT=-DEL1*EXPR/RW+DYN1*DT/RW+ &
2071                  DYN1*EXPR/(RW*RW)+DEL1/RW-DYN1/(RW*RW)
2072         DEL2INT=PW*DEL1*EXPR/(-RW*RW)-PW*DYN1*DT*DT/(2.0D0*RW)+ &
2073                 PW*DYN1*EXPR/(RW*RW*RW)+DYN2*DT*DT/2.0D0+ &
2074                 DEL2*DT-PW*DEL1*DT/RW+PW*DYN1*DT/(RW*RW)+ &
2075                 PW*DEL1/(RW*RW)-PW*DYN1/(RW*RW*RW)
2076         GOTO 100
2077 ! in case DABS(RW*DT)>1.0D-6
2078              ELSE
2079
2080 ! in case DABS(RW*DT)<=1.0D-6
2081
2082           EXPR=EXPM1(-RW*DT)
2083           DEL1N=DEL1+DEL1*EXPR+(DYN1/RW)*(0.0D0-EXPR)
2084           DEL2N=PW*DEL1*EXPR/RW-PW*DYN1*DT/RW- &
2085                    PW*DYN1*EXPR/(RW*RW)+DYN2*DT+DEL2
2086           DEL1INT=-DEL1*EXPR/RW+DYN1*DT/RW+DYN1*EXPR/(RW*RW)
2087           DEL2INT=PW*DEL1*EXPR/(-RW*RW)-PW*DYN1*DT*DT/(2.0D0*RW)+ &
2088                      PW*DYN1*EXPR/(RW*RW*RW)+DYN2*DT*DT/2.0D0+ &
2089                      DEL2*DT-PW*DEL1*DT/RW+PW*DYN1*DT/(RW*RW)
2090           GOTO 100
2091
2092                ENDIF
2093 ! ... only water                                                    (end)
2094
2095 ! in case RI==0.0D0
2096     ENDIF
2097
2098     IF(IRW == 0) THEN
2099 ! ... only ice                                                    (start)
2100
2101       EXPP=EXP(-PI*DT)
2102
2103       IF(ABS(PI*DT)>1.0E-6) THEN
2104
2105         DEL2N = DEL2*EXPP+(DYN2/PI)*(1.0D0-EXPP)
2106         DEL2INT = -DEL2*EXPP/PI+DYN2*DT/PI+ &
2107                    DYN2*EXPP/(PI*PI)+DEL2/PI-DYN2/(PI*PI)
2108         DEL1N = +RI*DEL2*EXPP/PI-RI*DYN2*DT/PI- &
2109                   RI*DYN2*EXPP/(PI*PI)+DYN1*DT+ &
2110                   DEL1-RI*DEL2/PI+RI*DYN2/(PI*PI)
2111         DEL1INT = -RI*DEL2*EXPP/(PI*PI)-RI*DYN2*DT*DT/(2.0D0*PI)+ &
2112                     RI*DYN2*EXPP/(PI*PI*PI)+DYN1*DT*DT/2.0D0+ &
2113                     DEL1*DT-RI*DEL2*DT/PI+RI*DYN2*DT/(PI*PI)+ &
2114                     RI*DEL2/(PI*PI)-RI*DYN2/(PI*PI*PI)
2115         GOTO 100
2116 ! in case DABS(PI*DT)>1.0D-6
2117       ELSE
2118
2119 ! in case DABS(PI*DT)<=1.0D-6
2120
2121           EXPP=EXPM1(-PI*DT)
2122           DEL2N=DEL2+DEL2*EXPP-EXPP*DYN2/PI
2123           DEL2INT=-DEL2*EXPP/PI+DYN2*DT/PI+DYN2*EXPP/(PI*PI)
2124           DEL1N=+RI*DEL2*EXPP/PI-RI*DYN2*DT/PI- &
2125                     RI*DYN2*EXPP/(PI*PI)+DYN1*DT+DEL1
2126           DEL1INT=-RI*DEL2*EXPP/(PI*PI)-RI*DYN2*DT*DT/(2.0D0*PI)+ &
2127                       RI*DYN2*EXPP/(PI*PI*PI)+DYN1*DT*DT/2.0D0+ &
2128                       DEL1*DT-RI*DEL2*DT/PI+RI*DYN2*DT/(PI*PI)
2129           GOTO 100
2130
2131       ENDIF
2132 ! ... only ice                                                      (end)
2133
2134 ! in case RW==0.0D0
2135     ENDIF
2136
2137     IF(IRW == 1 .AND. IRI == 1) THEN
2138
2139       A=(RW-PI)*(RW-PI)+4.0E0*PW*RI
2140
2141              IF(A < 0.0) THEN
2142                   PRINT*,   'IN SUBROUTINE JERSUPSAT: A < 0'
2143             PRINT*,   'DETER'
2144             PRINT 201, DETER
2145             PRINT*,   'RW,PW,RI,PI'
2146             PRINT 204, RW,PW,RI,PI
2147             PRINT*,   'DT,DYN1,DYN2'
2148             PRINT 203, DT,DYN1,DYN2
2149             PRINT*,   'DEL1,DEL2'
2150             PRINT 202, DEL1,DEL2
2151                   PRINT*,   'STOP 1905:A < 0'
2152                   call wrf_error_fatal("fatal error: STOP 1905:A < 0, model stop")
2153        ENDIF
2154 ! ... water and ice                                               (start)
2155        ALFA=DSQRT((RW-PI)*(RW-PI)+4.0D0*PW*RI)
2156
2157 ! 5/8/04 Nir, Beta is negative to the simple solution so it will decay
2158
2159         BETA=0.5D0*(ALFA+RW+PI)
2160         GAMA=0.5D0*(ALFA-RW-PI)
2161         G31=PI*DYN1-RI*DYN2
2162         G32=-PW*DYN1+RW*DYN2
2163         G2=RW*PI-RI*PW
2164         IF (G2 < 1.0d-20) G2 = 1.0004d-11*1.0003d-11-1.0002d-11*1.0001e-11 ! ... (KS) - 24th,May,2016
2165         EXPB=DEXP(-BETA*DT)
2166         EXPG=DEXP(GAMA*DT)
2167
2168         IF(DABS(GAMA*DT)>1.0E-6) THEN
2169           C11=(BETA*DEL1-RW*DEL1-RI*DEL2-BETA*G31/G2+DYN1)/ALFA
2170           C21=(GAMA*DEL1+RW*DEL1+RI*DEL2-GAMA*G31/G2-DYN1)/ALFA
2171           C12=(BETA*DEL2-PW*DEL1-PI*DEL2-BETA*G32/G2+DYN2)/ALFA
2172           C22=(GAMA*DEL2+PW*DEL1+PI*DEL2-GAMA*G32/G2-DYN2)/ALFA
2173           DEL1N=C11*EXPG+C21*EXPB+G31/G2
2174           DEL1INT=C11*EXPG/GAMA-C21*EXPB/BETA+(C21/BETA-C11/GAMA) &
2175                   +G31*DT/G2
2176           DEL2N=C12*EXPG+C22*EXPB+G32/G2
2177           DEL2INT=C12*EXPG/GAMA-C22*EXPB/BETA+(C22/BETA-C12/GAMA) &
2178                   +G32*DT/G2
2179             GOTO 100
2180 ! in case DABS(GAMA*DT)>1.0D-6
2181                ELSE
2182 ! in case DABS(GAMA*DT)<=1.0D-6
2183             IF(ABS(RI/RW)>1.0E-12) THEN
2184               IF(ABS(RW/RI)>1.0E-12) THEN
2185                 ALFA=DSQRT((RW-PI)*(RW-PI)+4.0D0*PW*RI)
2186                 BETA=0.5D0*(ALFA+RW+PI)
2187                 GAMA=0.5D0*(ALFA-RW-PI)
2188                             IF (GAMA < 0.5*2.0d-10) GAMA=0.5D0*(2.002d-10-2.001d-10) ! ... (KS) - 24th,May,2016
2189                 EXPG=EXPM1(GAMA*DT)
2190                 EXPB=DEXP(-BETA*DT)
2191
2192 ! beta/alfa could be very close to 1 that why I transform it
2193 ! remember alfa-beta=gama
2194
2195                 C11=(BETA*DEL1-RW*DEL1-RI*DEL2+DYN1)/ALFA
2196                 C21=(GAMA*DEL1+RW*DEL1+RI*DEL2-GAMA*G31/G2-DYN1)/ALFA
2197                 C12=(BETA*DEL2-PW*DEL1-PI*DEL2+DYN2)/ALFA
2198                 C22=(GAMA*DEL2+PW*DEL1+PI*DEL2-GAMA*G32/G2-DYN2)/ALFA
2199
2200                 A1DEL1N=C11
2201                 A2DEL1N=C11*EXPG
2202                 A3DEL1N=C21*EXPB
2203                 A4DEL1N=G31/G2*(GAMA/ALFA+(GAMA/ALFA-1.0D0)*EXPG)
2204
2205                 DEL1N=A1DEL1N+A2DEL1N+A3DEL1N+A4DEL1N
2206
2207                 A1DEL1INT=C11*EXPG/GAMA
2208                 A2DEL1INT=-C21*EXPB/BETA
2209                 A3DEL1INT=C21/BETA
2210                 A4DEL1INT=G31/G2*DT*(GAMA/ALFA)
2211
2212                 DEL1INT=A1DEL1INT+A2DEL1INT+A3DEL1INT+A4DEL1INT
2213
2214                 A1DEL2N=C12
2215                 A2DEL2N=C12*EXPG
2216                 A3DEL2N=C22*EXPB
2217                 A4DEL2N=G32/G2*(GAMA/ALFA+ &
2218                        (GAMA/ALFA-1.0D0)* &
2219                        (GAMA*DT+GAMA*GAMA*DT*DT/2.0D0))
2220
2221                 DEL2N=A1DEL2N+A2DEL2N+A3DEL2N+A4DEL2N
2222
2223                 A1DEL2INT=C12*EXPG/GAMA
2224                 A2DEL2INT=-C22*EXPB/BETA
2225                 A3DEL2INT=C22/BETA
2226                 A4DEL2INT=G32/G2*DT*(GAMA/ALFA)
2227                 A5DEL2INT=G32/G2*(GAMA/ALFA-1.0D0)* &
2228                                  (GAMA*DT*DT/2.0D0)
2229
2230                 DEL2INT=A1DEL2INT+A2DEL2INT+A3DEL2INT+A4DEL2INT+ &
2231                         A5DEL2INT
2232
2233 ! in case DABS(RW/RI)>1D-12
2234               ELSE
2235
2236 ! in case DABS(RW/RI)<=1D-12
2237
2238                 X=-2.0D0*RW*PI+RW*RW+4.0D0*PW*RI
2239
2240                 ALFA=PI*(1+(X/PI)/2.0D0-(X/PI)*(X/PI)/8.0D0)
2241                 BETA=PI+(X/PI)/4.0D0-(X/PI)*(X/PI)/16.0D0+RW/2.0D0
2242                 GAMA=(X/PI)/4.0D0-(X/PI)*(X/PI)/16.0D0-RW/2.0D0
2243
2244                 EXPG=EXPM1(GAMA*DT)
2245                 EXPB=DEXP(-BETA*DT)
2246
2247                         C11=(BETA*DEL1-RW*DEL1-RI*DEL2+DYN1)/ALFA
2248                         C21=(GAMA*DEL1+RW*DEL1+RI*DEL2-GAMA*G31/G2-DYN1)/ALFA
2249                         C12=(BETA*DEL2-PW*DEL1-PI*DEL2+DYN2)/ALFA
2250                         C22=(GAMA*DEL2+PW*DEL1+PI*DEL2-GAMA*G32/G2-DYN2)/ALFA
2251
2252                 DEL1N=C11+C11*EXPG+C21*EXPB+ &
2253                          G31/G2*(GAMA/ALFA+(GAMA/ALFA-1)*EXPG)
2254                 DEL1INT=C11*EXPG/GAMA-C21*EXPB/BETA+(C21/BETA)+ &
2255                            G31/G2*DT*(GAMA/ALFA)
2256                 DEL2N=C12+C12*EXPG+C22*EXPB+G32/G2*(GAMA/ALFA+ &
2257                         (GAMA/ALFA-1.0D0)* &
2258                         (GAMA*DT+GAMA*GAMA*DT*DT/2.0D0))
2259                       DEL2INT=C12*EXPG/GAMA-C22*EXPB/BETA+ &
2260                        (C22/BETA)+G32/G2*DT*(GAMA/ALFA)+ &
2261                         G32/G2*(GAMA/ALFA-1.0D0)*(GAMA*DT*DT/2.0D0)
2262
2263 ! in case DABS(RW/RI)<=1D-12
2264                  ENDIF
2265 ! alfa/beta 2
2266 ! in case DABS(RI/RW)>1D-12
2267
2268             ELSE
2269
2270 ! in case DABS(RI/RW)<=1D-12
2271
2272               X=-2.0D0*RW*PI+PI*PI+4.0D0*PW*RI
2273
2274               ALFA=RW*(1.0D0+(X/RW)/2.0D0-(X/RW)*(X/RW)/8.0D0)
2275               BETA=RW+(X/RW)/4.0D0-(X/RW)*(X/RW)/16.0D0+PI/2.0D0
2276               GAMA=(X/RW)/4.0D0-(X/RW)*(X/RW)/16.0D0-PI/2.0D0
2277
2278               EXPG=EXPM1(GAMA*DT)
2279               EXPB=DEXP(-BETA*DT)
2280
2281               C11=(BETA*DEL1-RW*DEL1-RI*DEL2+DYN1)/ALFA
2282               C21=(GAMA*DEL1+RW*DEL1+RI*DEL2-GAMA*G31/G2-DYN1)/ALFA
2283               C12=(BETA*DEL2-PW*DEL1-PI*DEL2+DYN2)/ALFA
2284                   C22=(GAMA*DEL2+PW*DEL1+PI*DEL2-GAMA*G32/G2-DYN2)/ALFA
2285
2286               DEL1N=C11+C11*EXPG+C21*EXPB+ &
2287                     G31/G2*(GAMA/ALFA+(GAMA/ALFA-1.0D0)*EXPG)
2288               DEL1INT=C11*EXPG/GAMA-C21*EXPB/BETA+(C21/BETA)+ &
2289                       G31/G2*DT*(GAMA/ALFA)
2290               DEL2N=C12+C12*EXPG+C22*EXPB+G32/G2* &
2291                     (GAMA/ALFA+ &
2292                     (GAMA/ALFA-1.0D0)*(GAMA*DT+GAMA*GAMA*DT*DT/2.0D0))
2293                    DEL2INT=C12*EXPG/GAMA-C22*EXPB/BETA+C22/BETA+ &
2294                       G32/G2*DT*(GAMA/ALFA)+ &
2295                       G32/G2*(GAMA/ALFA-1.0D0)*(GAMA*DT*DT/2.0D0)
2296 ! alfa/beta
2297 ! in case DABS(RI/RW)<=1D-12
2298             ENDIF
2299 ! in case DABS(GAMA*DT)<=1D-6
2300           ENDIF
2301
2302 ! water and ice                                                 (end)
2303
2304 ! in case ISYM1/=0.AND.ISYM2/=0
2305
2306         ENDIF
2307
2308  100    CONTINUE
2309
2310   201   FORMAT(1X,D13.5)
2311   202   FORMAT(1X,2D13.5)
2312   203   FORMAT(1X,3D13.5)
2313   204   FORMAT(1X,4D13.5)
2314
2315         RETURN
2316         END SUBROUTINE JERSUPSAT_KS
2317
2318 ! SUBROUTINE JERSUPSAT
2319 ! ....................................................................
2320         SUBROUTINE JERDFUN_KS (xi,xiN,B21_MY, &
2321                                                        FI2,PSI2,fl2,DEL2N, &
2322                                                        ISYM2,IND,ITYPE,TPN,IDROP, &
2323                                                        FR_LIM,FRH_LIM,ICEMAX,NKR,COL,Ihydro,Iin,Jin,Kin,Itimestep)
2324
2325         IMPLICIT NONE
2326 ! ... Interface
2327         INTEGER,INTENT(IN) :: ISYM2, IND, ITYPE, NKR, ICEMAX, Ihydro, Iin, Jin ,Kin, Itimestep
2328         INTEGER,INTENT(INOUT) :: IDROP
2329         REAL(kind=R4SIZE),INTENT(IN) :: B21_MY(:), FI2(:), FR_LIM(:), FRH_LIM(:), &
2330                                                                         DEL2N, COL
2331         REAL(kind=R8SIZE),INTENT(IN) :: TPN, xi(:)
2332         REAL(kind=R8SIZE),INTENT(INOUT) :: xiN(:)
2333         REAL(kind=R4SIZE),INTENT(INOUT) :: PSI2(:), FL2(:)
2334 ! ... Interface
2335
2336 ! ... Locals
2337         INTEGER :: ITYP, KR, NR, ICE, K, IDSD_Negative
2338         REAL(kind=R8SIZE) :: FL2_NEW(NKR), FI2R(NKR), PSI2R(NKR), C, DEGREE1, DEGREE2, DEGREE3, D, RATEXI, &
2339                                                            B, A, xiR(NKR),xiNR(NKR), FR_LIM_KR
2340 ! ... Locals
2341
2342
2343         C = 2.0D0/3.0D0
2344
2345         DEGREE1 = 1.0D0/3.0D0
2346         DEGREE2 = C
2347         DEGREE3 = 3.0D0/2.0D0
2348
2349         IF(IND > 1) THEN
2350           ITYP = ITYPE
2351         ELSE
2352           ITYP = 1
2353         ENDIF
2354
2355         DO KR=1,NKR
2356            PSI2R(KR) = FI2(KR)
2357            FI2R(KR) = FI2(KR)
2358         ENDDO
2359
2360         NR=NKR
2361
2362 ! new size distribution functions                             (start)
2363
2364         IF(ISYM2 == 1) THEN
2365           IF(IND==1 .AND. ITYPE==1) THEN
2366 ! drop diffusional growth
2367             DO KR=1,NKR
2368                D=xi(KR)**DEGREE1
2369                RATExi=C*DEL2N*B21_MY(KR)/D
2370                B=xi(KR)**DEGREE2
2371                A=B+RATExi
2372                IF(A<0.0D0) THEN
2373                  xiN(KR)=1.0D-50
2374                ELSE
2375                  xiN(KR)=A**DEGREE3
2376                ENDIF
2377             ENDDO
2378 ! in case IND==1.AND.ITYPE==1
2379           ELSE
2380 ! in case IND/=1.OR.ITYPE/=1
2381                  DO KR=1,NKR
2382                     RATExi = DEL2N*B21_MY(KR)
2383                     xiN(KR) = xi(KR) + RATExi
2384                  ENDDO
2385           ENDIF
2386
2387 ! recalculation of size distribution functions                (start)
2388
2389       DO KR=1,NKR
2390         xiR(KR) = xi(KR)
2391         xiNR(KR) = xiN(KR)
2392         FI2R(KR) = FI2(KR)
2393       END DO
2394
2395                 IDSD_Negative = 0
2396                         CALL JERNEWF_KS &
2397                                     (NR,xiR,FI2R,PSI2R,xiNR,ISIGN_3POINT,TPN,IDROP,NKR,COL,IDSD_Negative,Ihydro,Iin,Jin,Kin,Itimestep)
2398                         IF(IDSD_Negative == 1)THEN
2399                                 IF(ISIGN_KO_1 == 1) THEN
2400                                         ! ... (KS) - we do not use Kovatch-Ouland as separate method
2401                                         !       CALL JERNEWF_KO_KS &
2402                         !                                       (NR,xiR,FI2R,PSI2R,xiNR,NKR,COL)
2403                                 ENDIF
2404                         ENDIF
2405
2406                 DO KR=1,NKR
2407           IF(ITYPE==5) THEN
2408                                         FR_LIM_KR=FRH_LIM(KR)
2409                         ELSE
2410                                         FR_LIM_KR=FR_LIM(KR)
2411                                         ENDIF
2412                                 IF(PSI2R(KR)<0.0D0) THEN
2413                                           PRINT*,    'STOP 1506 : PSI2R(KR)<0.0D0, in JERDFUN_KS'
2414                                                 call wrf_error_fatal("fatal error in PSI2R(KR)<0.0D0, in JERDFUN_KS, model stop")
2415                                 ENDIF
2416                 PSI2(KR) = PSI2R(KR)
2417          ENDDO
2418 ! cycle by ICE
2419 ! recalculation of size distribution functions                  (end)
2420 ! in case ISYM2/=0
2421         ENDIF
2422 ! new size distribution functions                               (end)
2423
2424   201   FORMAT(1X,D13.5)
2425   304   FORMAT(1X,I2,2X,4D13.5)
2426
2427         RETURN
2428         END SUBROUTINE JERDFUN_KS
2429 ! +----------------------------------------------------------------------------+
2430                 SUBROUTINE JERNEWF_KS &
2431                                 (NRX,RR,FI,PSI,RN,I3POINT,TPN,IDROP,NKR,COL,IDSD_Negative,Ihydro, &
2432               Iin,Jin,Kin,Itimestep)
2433
2434         IMPLICIT NONE
2435 ! ... Interface
2436                 INTEGER,INTENT(IN) :: NRX, I3POINT, NKR, Ihydro, Iin, Jin, Kin, Itimestep
2437                 INTEGER,INTENT(INOUT) :: IDROP, IDSD_Negative
2438                 real(kind=R8SIZE),INTENT(IN) :: TPN
2439                 real(kind=R4SIZE),INTENT(IN) :: COL
2440                 real(kind=R8SIZE),INTENT(INOUT) :: PSI(:), RN(:), FI(:), RR(:)
2441 ! ... Interface
2442
2443 ! ... Locals
2444                 INTEGER :: KMAX, KR, I, K , NRXP, ISIGN_DIFFUSIONAL_GROWTH, NRX1,  &
2445               I3POINT_CONDEVAP, IEvap
2446                 real(kind=R8SIZE) :: RNTMP,RRTMP,RRP,RRM,RNTMP2,RRTMP2,RRP2,RRM2, GN1,GN2, &
2447                GN3,GN1P,GMAT,GMAT2, &
2448                                                          CDROP(NRX),DELTA_CDROP(NRX),RRS(NRX+1),PSINEW(NRX+1), &
2449                                                          PSI_IM,PSI_I,PSI_IP, AOLDCON, ANEWCON, AOLDMASS, ANEWMASS
2450
2451                 INTEGER,PARAMETER :: KRDROP_REMAPING_MIN = 6, KRDROP_REMAPING_MAX = 12
2452 ! ... Locals
2453
2454 ! >> [KS] 22ndMay19     IF(TPN .LT. 273.15-5.0D0) IDROP=0
2455
2456 ! INITIAL VALUES FOR SOME VARIABLES
2457
2458                 NRXP = NRX + 1
2459 !   NRX1 = 24
2460 !   NRX1 = 35
2461           NRX1 = NKR
2462
2463           DO I=1,NRX
2464 ! RN(I), g - new masses after condensation or evaporation
2465             IF(RN(I) < 0.0D0) THEN
2466                      RN(I) = 1.0D-50
2467                FI(I) = 0.0D0
2468             ENDIF
2469          ENDDO
2470
2471 ! new change 26.10.09                                         (start)
2472         DO K=1,NRX
2473            RRS(K)=RR(K)
2474         ENDDO
2475 ! new change 26.10.09                                           (end)
2476
2477         I3POINT_CONDEVAP = I3POINT
2478
2479         IEvap = 0
2480         IF(RN(1) < RRS(1)) THEN
2481 ! evaporation
2482           I3POINT_CONDEVAP = 0
2483 ! new change 26.10.09                                         (start)
2484           IDROP = 0
2485 ! new change 26.10.09                                           (end)
2486           NRX1 = NRX
2487           IEvap = 1
2488         ENDIF
2489
2490         IF(IDROP == 0) I3POINT_CONDEVAP = 0
2491
2492 ! new change 26.10.09                                         (start)
2493
2494         DO K=1,NRX
2495            PSI(K)=0.0D0
2496            CDROP(K)=0.0D0
2497            DELTA_CDROP(K)=0.0D0
2498            PSINEW(K)=0.0D0
2499         ENDDO
2500
2501         RRS(NRXP)=RRS(NRX)*1024.0D0
2502
2503         PSINEW(NRXP) = 0.0D0
2504
2505 ! new change 26.10.09                                           (end)
2506
2507         ISIGN_DIFFUSIONAL_GROWTH = 0
2508
2509         DO K=1,NRX
2510            IF(RN(K).NE.RR(K)) THEN
2511                   ISIGN_DIFFUSIONAL_GROWTH = 1
2512                   GOTO 2000
2513            ENDIF
2514         ENDDO
2515
2516  2000   CONTINUE
2517
2518         IF(ISIGN_DIFFUSIONAL_GROWTH == 1) THEN
2519
2520 ! Kovetz-Olund method                                         (start)
2521
2522 ! new change 26.10.09                                         (start)
2523           DO K=1,NRX1 ! ... [KS] >> NRX1-1
2524 ! new change 26.10.09                                           (end)
2525
2526                  IF(FI(K) > 0.0) THEN
2527                    IF(DABS(RN(K)-RR(K)) < 1.0D-16) THEN
2528                  PSINEW(K) = FI(K)*RR(K)
2529                  CYCLE
2530        ENDIF
2531
2532                    I = 1
2533                    DO WHILE (.NOT.(RRS(I) <= RN(K) .AND. RRS(I+1) >= RN(K)) &
2534                  .AND.I.LT.NRX1) ! [KS] >> was NRX1-1
2535                   I = I + 1
2536        ENDDO
2537
2538        IF(RN(K).LT.RRS(1)) THEN
2539           RNTMP=RN(K)
2540           RRTMP=0.0D0
2541           RRP=RRS(1)
2542           GMAT2=(RNTMP-RRTMP)/(RRP-RRTMP)
2543           PSINEW(1)=PSINEW(1)+FI(K)*RR(K)*GMAT2
2544                    ELSE
2545
2546         RNTMP=RN(K)
2547         RRTMP=RRS(I)
2548         RRP=RRS(I+1)
2549         GMAT2=(RNTMP-RRTMP)/(RRP-RRTMP)
2550         GMAT=(RRP-RNTMP)/(RRP-RRTMP)
2551         PSINEW(I)=PSINEW(I)+FI(K)*RR(K)*GMAT
2552         PSINEW(I+1)=PSINEW(I+1)+FI(K)*RR(K)*GMAT2
2553                    ENDIF
2554 ! in case FI(K).NE.0.0D0
2555                  ENDIF
2556
2557  3000    CONTINUE
2558
2559           ENDDO
2560 ! cycle by K
2561
2562           DO KR=1,NRX1
2563        PSI(KR)=PSINEW(KR)
2564           ENDDO
2565
2566           DO KR=NRX1+1,NRX
2567        PSI(KR)=FI(KR)
2568           ENDDO
2569 ! Kovetz-Olund method                                           (end)
2570
2571 ! calculation both new total drop concentrations(after KO) and new
2572 ! total drop masses (after KO)
2573
2574 ! 3point method                                               (start)
2575           IF(I3POINT_CONDEVAP == 1) THEN
2576             DO K=1,NRX1-1
2577                    IF(FI(K) > 0.0) THEN
2578                       IF(DABS(RN(K)-RR(K)).LT.1.0D-16) THEN
2579                    PSI(K) = FI(K)*RR(K)
2580                    GOTO 3001
2581                  ENDIF
2582
2583           IF(RRS(2).LT.RN(K)) THEN
2584              I = 2
2585              DO WHILE &
2586                      (.NOT.(RRS(I) <= RN(K) .AND. RRS(I+1) >= RN(K)) &
2587                      .AND.I.LT.NRX1-1)
2588                     I = I + 1
2589                         ENDDO
2590              RNTMP=RN(K)
2591
2592              RRTMP=RRS(I)
2593              RRP=RRS(I+1)
2594              RRM=RRS(I-1)
2595
2596              RNTMP2=RN(K+1)
2597
2598              RRTMP2=RRS(I+1)
2599              RRP2=RRS(I+2)
2600              RRM2=RRS(I)
2601
2602              GN1=(RRP-RNTMP)*(RRTMP-RNTMP)/(RRP-RRM)/ &
2603                   (RRTMP-RRM)
2604
2605              GN1P=(RRP2-RNTMP2)*(RRTMP2-RNTMP2)/ &
2606                    (RRP2-RRM2)/(RRTMP2-RRM2)
2607
2608              GN2=(RRP-RNTMP)*(RNTMP-RRM)/(RRP-RRTMP)/ &
2609                    (RRTMP-RRM)
2610
2611                    GMAT=(RRP-RNTMP)/(RRP-RRTMP)
2612
2613              GN3=(RRTMP-RNTMP)*(RRM-RNTMP)/(RRP-RRM)/ &
2614                                            (RRP-RRTMP)
2615              GMAT2=(RNTMP-RRTMP)/(RRP-RRTMP)
2616
2617              PSI_IM = PSI(I-1)+GN1*FI(K)*RR(K)
2618
2619              PSI_I = PSI(I)+GN1P*FI(K+1)*RR(K+1)+&
2620                    (GN2-GMAT)*FI(K)*RR(K)
2621
2622              PSI_IP = PSI(I+1)+(GN3-GMAT2)*FI(K)*RR(K)
2623
2624              IF(PSI_IM > 0.0D0) THEN
2625
2626                IF(PSI_IP > 0.0D0) THEN
2627
2628                  IF(I > 2) THEN
2629 ! smoothing criteria
2630                    IF(PSI_IM > PSI(I-2) .AND. PSI_IM < PSI_I &
2631                      .AND. PSI(I-2) < PSI(I) .OR. PSI(I-2) >= PSI(I)) THEN
2632
2633                       PSI(I-1) = PSI_IM
2634
2635                       PSI(I) = PSI(I) + FI(K)*RR(K)*(GN2-GMAT)
2636
2637                       PSI(I+1) = PSI_IP
2638 ! in case smoothing criteria
2639                    ENDIF
2640 ! in case I.GT.2
2641                  ENDIF
2642
2643 ! in case PSI_IP.GT.0.0D0
2644                                            ELSE
2645                                                          EXIT
2646                  ENDIF
2647 ! in case PSI_IM.GT.0.0D0
2648                                   ELSE
2649                                         EXIT
2650           ENDIF
2651 ! in case I.LT.NRX1-2
2652 !         ENDIF
2653
2654 ! in case RRS(2).LT.RN(K)
2655        ENDIF
2656
2657 ! in case FI(K).NE.0.0D0
2658       ENDIF
2659
2660  3001 CONTINUE
2661
2662             ENDDO
2663         ! cycle by K
2664
2665       ! in case I3POINT_CONDEVAP.NE.0
2666           ENDIF
2667 ! 3 point method                                                (end)
2668
2669 ! PSI(K) - new hydrometeor size distribution function
2670
2671           DO K=1,NRX1
2672              PSI(K)=PSI(K)/RR(K)
2673           ENDDO
2674
2675           DO K=NRX1+1,NRX
2676                  PSI(K)=FI(K)
2677           ENDDO
2678
2679           IF(IDROP == 1) THEN
2680                                 DO K=KRDROP_REMAPING_MIN,KRDROP_REMAPING_MAX
2681                                         CDROP(K)=3.0D0*COL*PSI(K)*RR(K)
2682                                 ENDDO
2683                ! KMAX - right boundary spectrum of drop sdf
2684                 !(KRDROP_REMAP_MIN =< KMAX =< KRDROP_REMAP_MAX)
2685                                 DO K=KRDROP_REMAPING_MAX,KRDROP_REMAPING_MIN,-1
2686                                    KMAX=K
2687                                    IF(PSI(K).GT.0.0D0) GOTO 2011
2688                                 ENDDO
2689
2690          2011  CONTINUE
2691         ! Andrei's new change 28.04.10                                (start)
2692                                 DO K=KMAX-1,KRDROP_REMAPING_MIN,-1
2693         ! Andrei's new change 28.04.10                                  (end)
2694                                         IF(CDROP(K).GT.0.0D0) THEN
2695                                                 DELTA_CDROP(K)=CDROP(K+1)/CDROP(K)
2696                                                         IF(DELTA_CDROP(K).LT.COEFF_REMAPING) THEN
2697                                                                 CDROP(K)=CDROP(K)+CDROP(K+1)
2698                                                                 CDROP(K+1)=0.0D0
2699                                                         ENDIF
2700                                         ENDIF
2701                                 ENDDO
2702
2703                                 DO K=KRDROP_REMAPING_MIN,KMAX
2704                                         PSI(K)=CDROP(K)/(3.0D0*COL*RR(K))
2705                                 ENDDO
2706
2707         ! in case IDROP.NE.0
2708                   ENDIF
2709
2710 ! new change 26.10.09                                           (end)
2711
2712 ! in case ISIGN_DIFFUSIONAL_GROWTH.NE.0
2713         ELSE
2714 ! in case ISIGN_DIFFUSIONAL_GROWTH.EQ.0
2715                         DO K=1,NRX
2716                         PSI(K)=FI(K)
2717                         ENDDO
2718        ENDIF
2719
2720                 DO KR=1,NRX
2721                         IF(PSI(KR) < 0.0) THEN ! ... (KS)
2722                                         IDSD_Negative = 1
2723                                         print*, "IDSD_Negative=",IDSD_Negative,"kr",kr
2724                                         PRINT*,    'IN SUBROUTINE JERNEWF'
2725                                         PRINT*,         'PSI(KR)<0'
2726                                         PRINT*,    'BEFORE EXIT'
2727                                         PRINT*,    'ISIGN_DIFFUSIONAL_GROWTH'
2728                                         PRINT*,     ISIGN_DIFFUSIONAL_GROWTH
2729                                         PRINT*,    'I3POINT_CONDEVAP'
2730                                         PRINT*,     I3POINT_CONDEVAP
2731                                         PRINT*,    'K,RR(K),RN(K),K=1,NRX'
2732                                         PRINT*,    (K,RR(K),RN(K),K=1,NRX)
2733                                         PRINT*,    'K,RR(K),RN(K),FI(K),PSI(K),K=1,NRX'
2734                                         PRINT 304, (K,RR(K),RN(K),FI(K),PSI(K),K=1,NRX)
2735                                         PRINT*,         IDROP,Ihydro,Iin,Jin,Kin,Itimestep
2736           call wrf_error_fatal("fatal error in SUBROUTINE JERNEWF PSI(KR)<0, < min, model stop")
2737                         ENDIF
2738                 ENDDO
2739
2740   304   FORMAT(1X,I2,2X,4D13.5)
2741
2742         RETURN
2743         END SUBROUTINE JERNEWF_KS
2744 ! +------------------------------------------------------------------+
2745         SUBROUTINE JERDFUN_NEW_KS &
2746                                 (xi,xiN,B21_MY, &
2747                                 FI2,PSI2, &
2748                                 TPN,IDROP,FR_LIM,NKR,COL,Ihydro,Iin,Jin,Kin,Itimestep)
2749
2750         IMPLICIT NONE
2751
2752 ! ... Interface
2753         INTEGER,INTENT(INOUT) :: IDROP, NKR
2754         INTEGER,INTENT(IN) :: Ihydro,Iin,Jin,Kin,Itimestep
2755         REAL(kind=R4SIZE),intent(IN) :: FI2(:), B21_MY(:), FR_LIM(:), COL
2756         REAL(kind=R8SIZE), INTENT(IN) :: TPN, xi(:)
2757         REAL(kind=R4SIZE),INTENT(INOUT) :: PSI2(:)
2758         REAL(kind=R8SIZE),INTENT(INOUT) :: xiN(:)
2759 ! ... Interface
2760
2761 ! ... Locals
2762         INTEGER :: NR, KR, IDSD_Negative
2763         REAL(kind=R8SIZE) :: C, DEGREE1, DEGREE2, DEGREE3, D, RATEXI, B, A, &
2764                                                            xiR(NKR),FI2R(NKR),PSI2R(NKR),xiNR(NKR)
2765 ! ... Locals
2766
2767         C=2.0D0/3.0D0
2768
2769         DEGREE1=C/2.0D0
2770         DEGREE2=C
2771         DEGREE3=3.0D0/2.0D0
2772
2773         NR=NKR
2774
2775         xiR = xi
2776         FI2R = FI2
2777         PSI2R = PSI2
2778         xiNR = xiN
2779
2780 ! new drop size distribution functions                             (start)
2781
2782 ! drop diffusional growth
2783
2784         DO KR=1,NKR
2785            D = xiR(KR)**DEGREE1
2786 ! Andrei's new change of 3.09.10                              (start)
2787 !          RATExi=C*DEL2N*B21_MY(KR)/D
2788            RATExi = C*B21_MY(KR)/D
2789 ! Andrei's new change of 3.09.10                                (end)
2790            B = xiR(KR)**DEGREE2
2791            A = B+RATExi
2792            IF(A<0.0D0) THEN
2793              xiNR(KR) = 1.0D-50
2794            ELSE
2795              xiNR(KR) = A**DEGREE3
2796            ENDIF
2797         ENDDO
2798
2799 ! recalculation of size distribution functions                (start)
2800
2801         IDSD_Negative = 0
2802         CALL JERNEWF_KS &
2803                         (NR,xiR,FI2R,PSI2R,xiNR,ISIGN_3POINT,TPN,IDROP,NKR,COL,IDSD_Negative,Ihydro,Iin,Jin,Kin,Itimestep)
2804         IF(IDSD_Negative == 1)THEN
2805                 IF(ISIGN_KO_2 == 1) THEN
2806                         ! ... (KS) - we do not use Kovatch-Ouland as separate method
2807                 !       CALL JERNEWF_KO_KS &
2808       !                                 (NR,xiR,FI2R,PSI2R,xiNR,NKR,COL)
2809                 ENDIF
2810         ENDIF
2811
2812         PSI2 = PSI2R
2813
2814 ! recalculation of drop size distribution functions                  (end)
2815 ! new drop size distribution functions                          (end)
2816
2817   201   FORMAT(1X,D13.5)
2818
2819         RETURN
2820         END SUBROUTINE JERDFUN_NEW_KS
2821 ! +---------------------------------------------------------+
2822         SUBROUTINE Relaxation_Time(TPS,QPS,PP,ROR,DEL1S,DEL2S, &
2823                                                                    R1,VR1,FF1in,RLEC,RO1BL, &
2824                                                                    R2,VR2,FF2in,RIEC,RO2BL, &
2825                                                                    R3,VR3,FF3in,RSEC,RO3BL, &
2826                                                                    R4,VR4,FF4in,RGEC,RO4BL, &
2827                                                                    R5,VR5,FF5in,RHEC,RO5BL, &
2828                                                                    NKR,ICEMAX,COL,DTdyn,NCOND,DTCOND)
2829
2830         implicit none
2831 ! ... Interface
2832         integer,intent(in) :: NKR,ICEMAX
2833         integer,intent(out) :: NCOND
2834         real(kind=R4SIZE),intent(in) :: R1(:),FF1in(:),RLEC(:),RO1BL(:), &
2835                                            R2(:,:),FF2in(:,:),RIEC(:,:),RO2BL(:,:), &
2836                                            R3(NKR),FF3in(:),RSEC(:),RO3BL(:), &
2837                                            R4(NKR),FF4in(:),RGEC(:),RO4BL(:), &
2838                                            R5(NKR),FF5in(:),RHEC(:),RO5BL(:), &
2839                                            ROR,COL,DTdyn,VR1(:),VR2(:,:),VR3(:),VR4(:),VR5(:)
2840   real(kind=R8SIZE),intent(in) :: TPS,QPS,PP,DEL1S,DEL2S
2841   real(kind=R4SIZE),intent(out) :: DTCOND
2842 ! ... Interface
2843 ! ... Local
2844         integer :: ISYM1, ISYM2(ICEMAX), ISYM3, ISYM4, ISYM5, ISYM_SUM, ICM
2845   real(kind=R8SIZE),parameter :: AA1_MY = 2.53D12, BB1_MY = 5.42D3, AA2_MY = 3.41D13, &
2846                                  BB2_MY = 6.13E3, AL1 = 2500.0, AL2 = 2834.0
2847         real(kind=R8SIZE),parameter :: TAU_Min = 0.1 ! [s]
2848         real(kind=R8SIZE) :: OPER2, AR1, TAU_RELAX, B5L, B5I, &
2849                                                            R1D(NKR), R2D(NKR,ICEMAX), R3D(NKR), R4D(NKR), R5D(NKR), &
2850                        VR1_d(nkr),VR2_d(nkr,icemax),VR3_d(nkr),VR4_d(nkr),VR5_d(nkr)
2851         real(kind=R4SIZE) :: B11_MY(NKR), B21_MY(NKR,ICEMAX), B31_MY(NKR), &
2852                                          B41_MY(NKR), B51_MY(NKR), FL1(NKR), FL3(NKR), FL4(NKR), FL5(NKR), &
2853                        SFNDUMMY(3), SFN11, SFNI1(ICEMAX), SFNII1, SFN21, SFN31, SFN41, SFN51, SFNI, SFNL, B8L, B8I, RI, PW, &
2854                              DOPL, DOPI, TAU_w, TAU_i, phi, RW, PI
2855 ! ... Local
2856
2857                 OPER2(AR1)=0.622/(0.622+0.378*AR1)/AR1
2858     VR1_d = VR1
2859     VR2_d = VR2
2860     VR3_d = VR3
2861     VR4_d = VR4
2862     VR5_d = VR5
2863
2864
2865                 ISYM1 = 0
2866                 ISYM2 = 0
2867                 ISYM3 = 0
2868                 ISYM4 = 0
2869                 ISYM5 = 0
2870                 IF(sum(FF1in) > 0.0) ISYM1 = 1
2871                 IF(sum(FF2in(:,1)) > 1.0D-10) ISYM2(1) = 1
2872                 IF(sum(FF2in(:,2)) > 1.0D-10) ISYM2(2) = 1
2873                 IF(sum(FF2in(:,3)) > 1.0D-10) ISYM2(3) = 1
2874                 IF(sum(FF3in) > 1.0D-10) ISYM3 = 1
2875                 IF(sum(FF4in) > 1.0D-10) ISYM4 = 1
2876                 IF(sum(FF5in) > 1.0D-10) ISYM5 = 1
2877
2878                 ISYM_SUM = ISYM1 + sum(ISYM2) + ISYM3 + ISYM4  + ISYM5
2879                 IF(ISYM_SUM == 0)THEN
2880                         TAU_RELAX = DTdyn
2881                         NCOND = nint(DTdyn/TAU_RELAX)
2882                     DTCOND = TAU_RELAX
2883         RETURN
2884                 ENDIF
2885
2886                 R1D = R1
2887                 R2D = R2
2888                 R3D = R3
2889                 R4D = R4
2890                 R5D = R5
2891                 B8L=1./ROR
2892         B8I=1./ROR
2893                 ICM = ICEMAX
2894                 SFN11 = 0.0
2895                 SFNI1 = 0.0
2896                 SFN31 = 0.0
2897                 SFN41 = 0.0
2898                 SFN51 = 0.0
2899                 B11_MY = 0.0
2900                 B21_MY = 0.0
2901                 B31_MY = 0.0
2902                 B41_MY = 0.0
2903                 B51_MY = 0.0
2904
2905
2906                   ! ... Drops
2907                   IF(ISYM1 == 1)THEN
2908                         FL1 = 0.0
2909                         CALL JERRATE_KS(R1D,TPS,PP,VR1_d,RLEC,RO1BL,B11_MY,1,1,fl1,NKR,ICEMAX)
2910         sfndummy(1) = SFN11
2911         CALL JERTIMESC_KS(FF1in,R1D,SFNDUMMY,B11_MY,B8I,1,NKR,ICEMAX,COL)
2912                         SFN11 = sfndummy(1)
2913                   ENDIF
2914                   ! ... IC
2915                   !IF(sum(ISYM2) > 0) THEN
2916                 !       FL1 = 0.0
2917                 !       ! ... ice crystals
2918                   !     CALL JERRATE_KS (R2D,TPS,PP,VR2_d,RIEC,RO2BL,B21_MY,3,2,fl1,NKR,ICEMAX)
2919                   !     CALL JERTIMESC_KS (FF2in,R2D,SFNI1,B21_MY,B8I,ICM,NKR,ICEMAX,COL)
2920                   !ENDIF
2921       ! ... Snow
2922       IF(ISYM3 == 1) THEN
2923                         FL3 = 0.0
2924                         ! ... snow
2925                         CALL JERRATE_KS (R3D,TPS,PP,VR3_d,RSEC,RO3BL,B31_MY,1,3,fl3,NKR,ICEMAX)
2926                         sfndummy(1) = SFN31
2927                         CALL JERTIMESC_KS(FF3in,R3D,SFNDUMMY,B31_MY,B8I,1,NKR,ICEMAX,COL)
2928                         SFN31 = sfndummy(1)
2929         ENDIF
2930       ! ... Graupel
2931      IF(ISYM4 == 1) THEN
2932                         FL4 = 0.0
2933                         ! ... graupel
2934                         CALL JERRATE_KS(R4D,TPS,PP,VR4_d,RGEC,RO4BL,B41_MY,1,2,fl4,NKR,ICEMAX)
2935
2936                         sfndummy(1) = SFN41
2937                         CALL JERTIMESC_KS(FF4in,R4D,SFNDUMMY,B41_MY,B8I,1,NKR,ICEMAX,COL)
2938                         SFN41 = sfndummy(1)
2939            ENDIF
2940       ! ... Hail
2941       IF(ISYM5 == 1) THEN
2942         FL5 = 0.0
2943         ! ... hail
2944         CALL JERRATE_KS(R5D,TPS,PP,VR5_d,RHEC,RO5BL,B51_MY,1,2,fl5,NKR,ICEMAX)
2945
2946         sfndummy(1) = SFN51
2947         CALL JERTIMESC_KS(FF5in,R5D,SFNDUMMY,B51_MY,B8I,1,NKR,ICEMAX,COL)
2948         SFN51 = sfndummy(1)
2949           ENDIF
2950
2951                   SFNII1 = 0.0
2952                   SFN21 = 0.0
2953                   SFNL = 0.0
2954                   SFNI = 0.0
2955                   RI = 0.0
2956                   PW = 0.0
2957                   SFNII1 = SFNI1(1)+SFNI1(2)+SFNI1(3)
2958                   SFN21 = SFNII1 + SFN31 + SFN41 + SFN51
2959                   SFNL = SFN11  ! Liquid
2960                   SFNI = SFN21  ! Total Ice
2961
2962                   B5L=BB1_MY/TPS/TPS
2963                   B5I=BB2_MY/TPS/TPS
2964                   DOPL=1.+ DEL1S
2965                   DOPI=1.+ DEL2S
2966                   RW=(OPER2(QPS)+B5L*AL1)*DOPL*SFNL
2967                   RI=(OPER2(QPS)+B5L*AL2)*DOPL*SFNI
2968                   PW=(OPER2(QPS)+B5I*AL1)*DOPI*SFNL
2969                   PI=(OPER2(QPS)+B5I*AL2)*DOPI*SFNI
2970
2971       TAU_w = DTdyn
2972       TAU_i = DTdyn
2973       phi = (1.0 + DEL2S)/(1.0 + DEL1S)
2974       if(PW > 0.0 .or. PI > 0.0) TAU_w = (PW + phi*PI)**(-1.0)
2975       if(RW > 0.0 .or. RI > 0.0) TAU_i =  phi/(RW + RI*phi)
2976       TAU_RELAX = DTdyn
2977                   IF(PW > 0.0 .or. RI > 0.0) TAU_RELAX = (PW + RI)**(-1.0)/3.0
2978                   IF(PW > 0.0 .and. RI > 0.0) TAU_RELAX = min(TAU_w,TAU_i)/3.0
2979
2980       if(TAU_RELAX > DTdyn) TAU_RELAX = DTdyn/3.0
2981                   if(TAU_RELAX < TAU_Min) TAU_RELAX = TAU_Min
2982       IF(PW <= 0.0 .and. RI <= 0.0) TAU_RELAX = DTdyn
2983
2984                   !if(TAU_RELAX < DTdyn .and. IDebug_Print_DebugModule==1)then
2985                   !             print*,"in Relaxation_Time,TAU_RELAX < DTdyn"
2986                         !       print*,TAU_RELAX
2987                   !endif
2988
2989                   !NCOND = nint(DTdyn/TAU_RELAX)
2990                   NCOND = ceiling(DTdyn/TAU_RELAX)
2991       DTCOND = TAU_RELAX
2992
2993         RETURN
2994         END SUBROUTINE Relaxation_Time
2995 ! +------------------------------+
2996 end module module_mp_SBM_Auxiliary
2997 ! +-----------------------------------------------------------------------------+
2998 ! +-----------------------------------------------------------------------------+
2999  module module_mp_SBM_Nucleation
3000
3001  USE module_mp_SBM_Auxiliary,ONLY:POLYSVP
3002
3003  private
3004  public JERNUCL01_KS, LogNormal_modes_Aerosol
3005
3006 ! Kind paramater
3007         INTEGER, PARAMETER, PRIVATE:: R8SIZE = 8
3008         INTEGER, PARAMETER, PRIVATE:: R4SIZE = 4
3009
3010         INTEGER,PARAMETER :: Use_cloud_base_nuc = 1
3011         real(kind=r8size),PARAMETER::T_NUCL_DROP_MIN = -80.0D0
3012         real(kind=r8size),PARAMETER::T_NUCL_ICE_MIN = -37.0D0
3013 ! Ice nucleation method
3014 ! using MEYERS method : ice_nucl_method == 0
3015 ! using DE_MOTT method : ice_nucl_method == 1
3016         INTEGER,PARAMETER :: ice_nucl_method = 0
3017         INTEGER,PARAMETER :: ISIGN_TQ_ICENUCL = 1
3018 ! DELSUPICE_MAX=59%
3019         DOUBLE PRECISION,PARAMETER::DELSUPICE_MAX = 59.0D0
3020
3021  contains
3022 ! +-----------------------------------------------------------------------------+
3023  SUBROUTINE JERNUCL01_KS(PSI1_r, PSI2_r, FCCNR_r,                          &
3024                                                             XL_r, XI_r, TT, QQ,                                  &
3025                                     ROR_r, PP_r,                                               &
3026                                           SUP1, SUP2,                                                  &
3027                                           COL_r,                                                                       &
3028                                           SUP2_OLD_r, DSUPICE_XYZ_r,                 &
3029                                           RCCN_r, DROPRADII_r, NKR, NKR_aerosol, ICEMAX, ICEPROCS, &
3030                                           Win_r, Is_This_CloudBase, RO_SOLUTE, IONS, MWAERO, &
3031                                           Iin, Jin, Kin)
3032
3033
3034         implicit none
3035
3036         integer,intent(in) ::    Kin, Jin, Iin, NKR, NKR_aerosol, ICEMAX, ICEPROCS, Is_This_CloudBase,IONS
3037         real(kind=r4size),intent(in) :: XL_r(:), XI_r(:,:), ROR_r, PP_r, COL_r, Win_r, &
3038                                                                      SUP2_OLD_r, DSUPICE_XYZ_r, RCCN_r(:), DROPRADII_r(:)
3039   real(kind=r4size),intent(in) ::                  MWAERO, RO_SOLUTE
3040         real(kind=r4size),intent(inout) ::       PSI1_r(:),PSI2_r(:,:),FCCNR_r(:)
3041         real(kind=r8size),intent(inout) :: TT, QQ, SUP1,SUP2
3042
3043  ! ... Locals
3044         integer :: KR, ICE, K
3045         real(kind=r8size) :: DROPCONCN(NKR), ARG_1, COL3, RORI, TPN, QPN, TPC, AR1, AR2, OPER3,           &
3046                                                            SUM_ICE, DEL2N, FI2(NKR,ICEMAX), TFREEZ_OLD, DTFREEZXZ, RMASSIAA_NUCL, RMASSIBB_NUCL, &
3047                                    FI2_K, xi_K, FI2R2, DELMASSICE_NUCL, ES1N, ES2N, EW1N
3048   real(kind=r8size),parameter :: AL2 = 2834.0D0
3049   real(kind=r8size) :: PSI1(NKR),PSI2(NKR,ICEMAX),FCCNR(NKR_aerosol),ROR,XL(NKR),XI(NKR,ICEMAX),PP,COL, &
3050                                                            SUP2_OLD,DSUPICE_XYZ,Win, RCCN(NKR_aerosol),DROPRADII(NKR)
3051         real(kind=r4size) :: TPNreal
3052  ! ... Locals
3053
3054         OPER3(AR1,AR2) = AR1*AR2/(0.622D0+0.378D0*AR1)
3055
3056         ! ... Adjust the Imput
3057         PSI1 = PSI1_r
3058         PSI2 = PSI2_r
3059         FCCNR = FCCNR_r
3060         XL = XL_r
3061         XI = XI_r
3062         ROR = ROR_r
3063         PP = PP_r
3064         COL = COL_r
3065         SUP2_OLD = SUP2_OLD_r
3066         DSUPICE_XYZ = DSUPICE_XYZ_r
3067         RCCN = RCCN_r
3068         DROPRADII = DROPRADII_r
3069   Win = Win_r
3070
3071         COL3 = 3.0D0*COL
3072         RORI = 1.0D0/ROR
3073
3074 ! ... Drop Nucleation (start)
3075         TPN = TT
3076         QPN = QQ
3077
3078         TPC = TT - 273.15D0
3079
3080         IF(SUP1>0.0D0 .AND. TPC>T_NUCL_DROP_MIN) THEN
3081                 if(sum(FCCNR) > 0.0)then
3082                         DROPCONCN = 0.0D0
3083                         CALL WATER_NUCLEATION (COL, NKR_aerosol, PSI1, FCCNR, xl, TT, QQ, ROR, SUP1, DROPCONCN, &
3084                                                                    PP, Is_This_CloudBase, Win, RO_SOLUTE, RCCN, IONS,MWAERO)
3085                 endif
3086                 ! ... Transfer drops to Ice-Crystals via direct homogenous nucleation
3087                 IF(TPC <= -38.0D0) THEN
3088                   SUM_ICE = 0.0D0
3089                   DO KR=1,NKR
3090                           PSI2(KR,2) = PSI2(KR,2) + PSI1(KR)
3091                           SUM_ICE = SUM_ICE + COL3*xl(KR)*xl(KR)*PSI1(KR)
3092                           PSI1(KR) = 0.0D0
3093                   END DO
3094                   ARG_1 = 334.0D0*SUM_ICE*RORI
3095                   TT = TT + ARG_1
3096                 ENDIF
3097         ENDIF
3098 ! ... Drop nucleation (end)
3099 ! ... Nucleation of crystals (start)
3100         DEL2N = 100.0D0*SUP2
3101         TPC = TT-273.15D0
3102
3103         IF(TPC < 0.0D0 .AND. TPC >= T_NUCL_ICE_MIN .AND. DEL2N > 0.0D0) THEN
3104
3105                 DO KR=1,NKR
3106                         DO ICE=1,ICEMAX
3107                                 FI2(KR,ICE)=PSI2(KR,ICE)
3108                         ENDDO
3109                 ENDDO
3110
3111         if(ice_nucl_method == 0) then
3112           CALL ICE_NUCL (PSI2,xi,SUP2,TT,DSUPICE_XYZ,SUP2_OLD,ICEMAX,NKR,COL)
3113         endif
3114
3115         IF(ISIGN_TQ_ICENUCL == 1) THEN
3116                 RMASSIAA_NUCL=0.0D0
3117                 RMASSIBB_NUCL=0.0D0
3118
3119                 ! before ice crystal nucleation
3120                 DO K=1,NKR
3121                         DO ICE=1,ICEMAX
3122                           FI2_K=FI2(K,ICE)
3123                           xi_K=xi(K,ICE)
3124                           FI2R2=FI2_K*xi_K*xi_K
3125                           RMASSIBB_NUCL=RMASSIBB_NUCL+FI2R2
3126                         ENDDO
3127                 ENDDO
3128
3129                 RMASSIBB_NUCL = RMASSIBB_NUCL*COL3*RORI
3130
3131                 IF(RMASSIBB_NUCL < 0.0D0) RMASSIBB_NUCL = 0.0D0
3132
3133                 ! after ice crystal nucleation
3134                 DO K=1,NKR
3135                         DO ICE=1,ICEMAX
3136                           FI2_K=PSI2(K,ICE)
3137                           xi_K=xi(K,ICE)
3138                           FI2R2=FI2_K*xi_K*xi_K
3139                           RMASSIAA_NUCL=RMASSIAA_NUCL+FI2R2
3140                         ENDDO
3141                 ENDDO
3142
3143                 RMASSIAA_NUCL = RMASSIAA_NUCL*COL3*RORI
3144
3145                 IF(RMASSIAA_NUCL < 0.0D0) RMASSIAA_NUCL=0.0D0
3146
3147                 DELMASSICE_NUCL = RMASSIAA_NUCL-RMASSIBB_NUCL
3148
3149                 QPN = QQ-DELMASSICE_NUCL
3150                 QQ = QPN
3151
3152                 TPN = TT + AL2*DELMASSICE_NUCL
3153                 TT = TPN
3154
3155                 TPNreal = TPN
3156                 ES1N = POLYSVP(TPNreal,0)
3157                 ES2N = POLYSVP(TPNreal,1)
3158
3159                 EW1N = OPER3(QPN,PP)
3160
3161                 SUP1 = EW1N/ES1N-1.0D0
3162                 SUP2 = EW1N/ES2N-1.0D0
3163
3164           ! in case ISIGN_TQ_ICENUCL/=0
3165           ENDIF
3166
3167         ! in case TPC<0.AND.TPC>=T_NUCL_ICE_MIN.AND.DEL2N>0.D0
3168         ENDIF
3169
3170 ! ... Nucleation of crystals (end)
3171
3172         ! ... Output
3173         PSI1_r = PSI1
3174         PSI2_r = PSI2
3175         FCCNR_r = FCCNR
3176
3177  RETURN
3178  END SUBROUTINE JERNUCL01_KS
3179 ! +-------------------------------------------------------------------------------------------------------------------------+
3180  SUBROUTINE WATER_NUCLEATION (COL, NKR, PSI1, FCCNR, xl, TT, QQ, ROR, SUP1,     &
3181                               DROPCONCN, PP, Is_This_CloudBase, Win, RO_SOLUTE, &
3182                               RCCN, IONS, MWAERO)
3183
3184 !===================================================================!
3185 !                                                                   !
3186 ! DROP NUCLEATION SCHEME                                            !
3187 !                                                                   !
3188 ! Authors: Khain A.P. & Pokrovsky A.G. July 2002 at Huji, Israel    !
3189 !                                                                   !
3190 !===================================================================!
3191  implicit none
3192
3193 ! PSI1(KR), 1/g/cm3 - non conservative drop size distribution function
3194 ! FCCNR(KR), 1/cm^3 - aerosol(CCN) non conservative, size distribution function
3195 ! xl((KR), g        - drop bin masses
3196
3197   integer,intent(in) ::                         Is_This_CloudBase, NKR, IONS
3198   real(kind=r8size),intent(in) ::       xl(:), ROR, PP, Win, RCCN(:), COL
3199   real(kind=r8size),intent(inout) :: FCCNR(:), PSI1(:), DROPCONCN(:), QQ, TT, SUP1
3200   real(kind=r4size),intent(in) ::        RO_SOLUTE, MWAERO
3201
3202   ! ... Locals
3203     integer ::                  IMAX, I, NCRITI, KR
3204     real(kind=r8size) :: DX,AR2,RCRITI,DEG01,RORI,CCNCONC(NKR),AKOE,BKOE, AR1, OPER3, RCCN_MINIMUM, &
3205                                                              DLN1, DLN2, RMASSL_NUCL, ES1N, EW1N
3206    real(kind=r8size),parameter :: AL1 = 2500.0D0
3207          real(kind=r4size) :: TTreal
3208   ! ... Locals
3209
3210          OPER3(AR1,AR2)=AR1*AR2/(0.622D0+0.378D0*AR1)
3211
3212    DROPCONCN(:) = 0.0D0
3213
3214         DEG01 = 1.0D0/3.0D0
3215         RORI=1.0/ROR
3216
3217         !RO_SOLUTE=2.16D0
3218
3219         ! imax - right CCN spectrum boundary
3220         IMAX = NKR
3221         DO I=IMAX,1,-1
3222            IF(FCCNR(I) > 0.0D0) THEN
3223                  IMAX = I
3224                  exit
3225            ENDIF
3226         ENDDO
3227
3228         NCRITI=0
3229         ! every iteration we will nucleate one bin, then we will check the new supersaturation
3230         ! and new Rcriti.
3231     do while (IMAX>=NCRITI)
3232              CCNCONC = 0.0
3233
3234         ! akoe & bkoe - constants in Koehler equation
3235                     AKOE=3.3D-05/TT
3236         !BKOE=2.0D0*4.3D0/(22.9D0+35.5D0)
3237               BKOE = ions*4.3/mwaero
3238         BKOE=BKOE*(4.0D0/3.0D0)*3.141593D0*RO_SOLUTE
3239
3240         if(Use_cloud_base_nuc == 1) then
3241                 if(Is_This_CloudBase == 1) then
3242                     CALL Cloud_Base_Super (FCCNR, RCCN, TT, PP, Win, NKR, RCRITI, RO_SOLUTE, IONS, MWAERO, COL)
3243           else
3244                     ! rcriti, cm - critical radius of "dry" aerosol
3245                     RCRITI = (AKOE/3.0D0)*(4.0D0/BKOE/SUP1/SUP1)**DEG01
3246                 endif
3247        else ! ismax_cloud_base==0
3248             ! rcriti, cm - critical radius of "dry" aerosol
3249             RCRITI=(AKOE/3.0D0)*(4.0D0/BKOE/SUP1/SUP1)**DEG01
3250        endif
3251
3252         IF(RCRITI >= RCCN(IMAX)) EXIT ! nothing to nucleate
3253
3254         ! find the minimum bin to nucleate
3255         NCRITI = IMAX
3256         do while (RCRITI<=RCCN(NCRITI) .and. NCRITI>1)
3257             NCRITI=NCRITI-1
3258         enddo
3259
3260                 ! rccn_minimum - minimum aerosol(ccn) radius
3261         RCCN_MINIMUM = RCCN(1)/10000.0D0
3262                 ! calculation of ccnconc(ii)=fccnr(ii)*col - aerosol(ccn) bin
3263                 !                                            concentrations,
3264                 !                                            ii=imin,...,imax
3265                 ! determination of ncriti   - number bin in which is located rcriti
3266                 ! calculation of ccnconc(ncriti)=fccnr(ncriti)*dln1/(dln1+dln2),
3267                 ! where,
3268                 ! dln1=Ln(rcriti)-Ln(rccn_minimum)
3269                 ! dln2=Ln(rccn(1)-Ln(rcriti)
3270                 ! calculation of new value of fccnr(ncriti)
3271
3272         ! each iteration we nucleate the last bin
3273         IF (NCRITI==IMAX-1) then
3274             if (NCRITI>1) then
3275                DLN1=DLOG(RCRITI)-DLOG(RCCN(IMAX-1))
3276                DLN2=COL-DLN1
3277                    CCNCONC(IMAX)=DLN2*FCCNR(IMAX)
3278                    FCCNR(IMAX)=FCCNR(IMAX)*DLN1/COL
3279             else ! NCRITI==1
3280                DLN1=DLOG(RCRITI)-DLOG(RCCN_MINIMUM)
3281                DLN2=DLOG(RCCN(1))-DLOG(RCRITI)
3282                    CCNCONC(IMAX)=DLN2*FCCNR(IMAX)
3283                    FCCNR(IMAX)=FCCNR(IMAX)*DLN1/(DLN1+DLN2)
3284             endif
3285         else
3286              CCNCONC(IMAX) = COL*FCCNR(IMAX)
3287              FCCNR(IMAX)=0.0D0
3288         endif
3289
3290         ! calculate the mass change due to nucleation
3291         RMASSL_NUCL=0.0D0
3292         if (IMAX <= NKR-7) then ! we pass it to drops mass grid
3293                             DROPCONCN(1) = DROPCONCN(1)+CCNCONC(IMAX)
3294                 RMASSL_NUCL = RMASSL_NUCL+CCNCONC(IMAX)*XL(1)*XL(1)
3295         else
3296                             DROPCONCN(8-(NKR-IMAX)) = DROPCONCN(8-(NKR-IMAX))+CCNCONC(IMAX)
3297                 RMASSL_NUCL = RMASSL_NUCL + CCNCONC(IMAX)*XL(8-(NKR-IMAX))*XL(8-(NKR-IMAX))
3298         endif
3299         RMASSL_NUCL = RMASSL_NUCL*COL*3.0*RORI
3300
3301         ! prepering to check if we need to nucleate the next bin
3302         IMAX = IMAX-1
3303
3304    ! cycle IMAX>=NCRITI
3305    end do
3306
3307    ! ... Intergarting for including the previous nucleated drops
3308    IF(sum(DROPCONCN) > 0.0)THEN
3309             DO KR = 1,8
3310                DX = 3.0D0*COL*xl(KR)
3311                PSI1(KR) = PSI1(KR)+DROPCONCN(KR)/DX
3312             ENDDO
3313    ENDIF
3314
3315  RETURN
3316  END SUBROUTINE WATER_NUCLEATION
3317 ! +--------------------------------------------------------------------------+
3318 !====================================================================!
3319 !                                                                    !
3320 ! ICE NUCLEATION SCHEME                                              !
3321 !                                                                    !
3322 ! Authors: Khain A.P. & Pokrovsky A.G. July 2002 at Huji, Israel     !
3323 !                                                                    !
3324 !====================================================================!
3325
3326   SUBROUTINE ICE_NUCL (PSI2,xi,SUP2,TT,DSUPICE_XYZ,SUP2_OLD,ICEMAX,NKR,COL)
3327
3328         implicit none
3329
3330         integer,intent(in) :: NKR, ICEMAX
3331         real(kind=r8size),intent(in) :: xi(:,:), DSUPICE_XYZ, COL
3332         real(kind=r8size),intent(inout) :: PSI2(:,:),TT,SUP2,SUP2_OLD
3333
3334         ! ... Locals
3335         integer :: KR,ICE,ITYPE
3336         real(kind=r8size) :: FI2(NKR,ICEMAX), CONCI_BFNUCL(ICEMAX), CONCI_AFNUCL(ICEMAX)
3337         real(kind=r8size),parameter :: A1 = -0.639D0, B1 = 0.1296D0, A2 = -2.8D0, B2 = 0.262D0, &
3338                                                                                  TEMP1 = -5.0D0, TEMP2 = -2.0D0, TEMP3 = -20.0D0
3339
3340         ! C1_MEY=0.001 1/cm^3
3341         real(kind=r8size),PARAMETER::C1_MEY = 1.0D-3
3342         real(kind=r8size),PARAMETER::C2_MEY = 0.0D0
3343         INTEGER,PARAMETER :: NRGI = 2
3344         real(kind=r8size) :: C1,C2,TPC,DEL2N,DEL2NN,HELEK1,HELEK2,FF1BN,FACT,DSUP2N,DELTACD,DELTAF, &
3345                                          ADDF,DELCONCI_AFNUCL,TPCC,DX
3346         ! ... Locals
3347
3348         C1=C1_MEY
3349         C2=C2_MEY
3350
3351         ! size distribution functions of crystals before ice nucleation
3352
3353         DO KR=1,NKR
3354            DO ICE=1,ICEMAX
3355                   FI2(KR,ICE)=PSI2(KR,ICE)
3356            ENDDO
3357         ENDDO
3358
3359         ! calculation concentration of crystals before ice nucleation
3360
3361         DO ICE=1,ICEMAX
3362            CONCI_BFNUCL(ICE)=0.0D0
3363            DO KR=1,NKR
3364                   CONCI_BFNUCL(ICE)=CONCI_BFNUCL(ICE)+ &
3365                                                         3.0D0*COL*PSI2(KR,ICE)*xi(KR,ICE)
3366            ENDDO
3367         ENDDO
3368
3369         ! type of ice with nucleation                                (start)
3370
3371         TPC = TT-273.15D0
3372         ITYPE=0
3373
3374         IF((TPC>-4.0D0).OR.(TPC<=-8.1D0.AND.TPC>-12.7D0).OR. &
3375                 (TPC<=-17.8D0.AND.TPC>-22.4D0)) THEN
3376                 ITYPE=2
3377         ELSE
3378           IF((TPC<=-4.0D0.AND.TPC>-8.1D0) &
3379                  .OR.(TPC<=-22.4D0)) THEN
3380                 ITYPE=1
3381           ELSE
3382                 ITYPE=3
3383           ENDIF
3384         ENDIF
3385
3386         ! type of ice with nucleation                                  (end)
3387
3388         ! new crystal size distribution function                     (start)
3389         ICE=ITYPE
3390         IF (TPC < TEMP1) THEN
3391           DEL2N = 100.0D0*SUP2
3392           DEL2NN = DEL2N
3393           IF( DEL2N > DELSUPICE_MAX) DEL2NN = DELSUPICE_MAX
3394           HELEK1 = C1*DEXP(A1+B1*DEL2NN)
3395               ELSE
3396           HELEK1 = 0.0D0
3397         ENDIF
3398
3399         IF(TPC < TEMP2) THEN
3400           TPCC = TPC
3401           IF(TPCC < TEMP3) TPCC = TEMP3
3402           HELEK2 = C2*DEXP(A2-B2*TPCC)
3403         ELSE
3404           HELEK2 = 0.0D0
3405         ENDIF
3406
3407         FF1BN = HELEK1+HELEK2
3408         FACT=1.0D0
3409         DSUP2N = (SUP2-SUP2_OLD+DSUPICE_XYZ)*100.0D0
3410         SUP2_OLD = SUP2 ! ### (KS) : We calculate SUP2_OLD outside of JERNUCL01
3411
3412               IF(DSUP2N > DELSUPICE_MAX) DSUP2N = DELSUPICE_MAX
3413
3414         DELTACD = FF1BN*B1*DSUP2N
3415
3416         IF(DELTACD>=FF1BN) DELTACD=FF1BN
3417
3418         IF(DELTACD>0.0D0) THEN
3419           DELTAF=DELTACD*FACT
3420                   ! concentration of ice crystals
3421           if(CONCI_BFNUCL(ICE)<=helek1) then
3422                 DO KR=1,NRGI-1
3423                 DX=3.0D0*xi(KR,ICE)*COL
3424                 ADDF=DELTAF/DX
3425                 PSI2(KR,ICE)=PSI2(KR,ICE)+ADDF
3426                 ENDDO
3427           endif
3428         ENDIF
3429
3430                 ! calculation of crystal concentration after ice nucleation
3431
3432         DO ICE=1,ICEMAX
3433            CONCI_AFNUCL(ICE)=0.0D0
3434            DO KR=1,NKR
3435               CONCI_AFNUCL(ICE)=CONCI_AFNUCL(ICE)+ &
3436               3.0D0*COL*PSI2(KR,ICE)*xi(KR,ICE)
3437            END DO
3438            DELCONCI_AFNUCL=DABS(CONCI_AFNUCL(ICE)-CONCI_BFNUCL(ICE))
3439            IF(DELCONCI_AFNUCL>10.0D0) THEN
3440              PRINT*,    'IN SUBROUTINE ICE_NUCL, AFTER NUCLEATION'
3441              PRINT*,    'BECAUSE DELCONCI_AFNUCL > 10/cm^3'
3442              PRINT*,    'CONCI_BFNUCL(ICE),CONCI_AFNUCL(ICE)'
3443              PRINT 202,  CONCI_BFNUCL(ICE),CONCI_AFNUCL(ICE)
3444              PRINT*,    'DELTACD,DSUP2N,FF1BN,B1,DSUPICEXZ,SUP2'
3445              PRINT 206,  DELTACD,DSUP2N,FF1BN,B1,DSUPICE_XYZ,SUP2
3446              PRINT*,    'KR,   FI2(KR,ICE),   PSI2(KR,ICE), KR=1,NKR'
3447              PRINT 302, (KR,   FI2(KR,ICE),   PSI2(KR,ICE), KR=1,NKR)
3448              PRINT*, 'STOP 099 : DELCONCI_AFNUCL(ICE) > 10/cm^3'
3449              STOP 099
3450            ENDIF
3451         END DO
3452
3453 ! new crystal size distribution function                       (end)
3454
3455
3456   202   FORMAT(1X,2D13.5)
3457   206   FORMAT(1X,6D13.5)
3458   302   FORMAT(1X,I2,2X,2D13.5)
3459
3460         RETURN
3461         END SUBROUTINE ICE_NUCL
3462
3463 ! SUBROUTINE ICE_NUCL
3464 ! +-------------------------------------------------------------------------------------------------+
3465         SUBROUTINE Cloud_Base_Super (FCCNR, RCCN, TT, PP, Wbase, NKR, RCRITI, RO_SOLUTE, IONS, MWAERO, &
3466                                                                               COL)
3467
3468         implicit none
3469
3470 ! RCCN(NKR),  cm- aerosol's radius
3471
3472 ! FCCNR(KR), 1/cm^3 - aerosol(CCN) non conservative, size
3473 !                     distribution function in point with X,Z
3474 !                     coordinates, KR=1,...,NKR
3475         integer,intent(in) ::                              NKR, IONS
3476         real(kind=r8size),intent(in) ::  TT, PP, Wbase, RCCN(:), COL
3477         real(kind=r8size),intent(inout) ::      FCCNR(:), RCRITI
3478         real(kind=r4size),intent(in) ::  MWAERO, RO_SOLUTE
3479
3480         ! ... Locals
3481           integer :: NR, NN, KR
3482           real(kind=r8size) :: PL(NKR), supmax(NKR), AKOE, BKOE, C3, PR, CCNCONACT, DL1, DL2, &
3483                                                             TPC
3484         ! ... Locals
3485
3486         CALL supmax_COEFF(AKOE,BKOE,C3,PP,TT,RO_SOLUTE,IONS,MWAERO)
3487
3488 ! supmax calculation
3489
3490 ! 'Analytical estimation of droplet concentration at cloud base', eq.21, 2012
3491 ! calculation of right side hand of equation for S_MAX
3492 ! while wbase>0, calculation PR
3493
3494         PR = C3*wbase**(0.75D0)
3495
3496 ! calculation supersaturation in cloud base
3497
3498         SupMax = 999.0
3499           PL = 0.0
3500     NN = -1
3501     DO NR=2,NKR
3502            supmax(NR)=DSQRT((4.0D0*AKOE**3.0D0)/(27.0D0*RCCN(NR)**3.0D0*BKOE))
3503         ! calculation CCNCONACT- the concentration of ccn that were activated
3504         ! following nucleation
3505         ! CCNCONACT=N from the paper
3506         ! 'Analytical estimation of droplet concentration at cloud base', eq.19, 2012
3507         ! CCNCONACT, 1/cm^3- concentration of activated CCN = new droplet concentration
3508         ! CCNCONACT=FCCNR(KR)*COL
3509         ! COL=Ln2/3
3510
3511                 CCNCONACT=0.0D0
3512
3513         ! NR represents the number of bin in which rcriti is located
3514         ! from NR bin to NKR bin goes to droplets
3515
3516                 DO KR=NR,NKR
3517                         CCNCONACT = CCNCONACT + COL*FCCNR(KR)
3518                 ENDDO
3519
3520         ! calculate LHS of equation for S_MAX
3521         ! when PL<PR ccn will activate
3522
3523                 PL(NR)=supmax(NR)*(DSQRT(CCNCONACT))
3524                 IF(PL(NR).LE.PR) THEN
3525                         NN = NR
3526                         EXIT
3527                 ENDIF
3528
3529          END DO ! NR
3530
3531    if (nn == -1) then
3532     print*,"PR, Wbase [cm/s], C3",PR,wbase,C3
3533     print*,"PL",PL
3534     CALL wrf_error_fatal ( 'NN is not defined in cloud base routine, model stop' )
3535    endif
3536
3537         ! linear interpolation- finding radius criti of aerosol between
3538         ! bin number (nn-1) to (nn)
3539         ! 1) finding the difference between pl and pr in the left and right over the
3540         ! final bin.
3541
3542         DL1 = dabs(PL(NN-1)-PR) ! left side in the final bin
3543         DL2 = dabs(PL(NN)-PR)   ! right side in the final bin
3544
3545         ! 2) fining the left part of bin that will not activate
3546         !       DLN1=COL*DL1/(DL2+DL1)
3547         ! 3)finding the right part of bin that activate
3548         !       DLN2=COL-DLN1
3549         ! 4)finding radius criti of aerosol- RCRITI
3550
3551         RCRITI = RCCN(NN-1)*dexp(COL*DL1/(DL1+DL2))
3552
3553         ! end linear interpolation
3554
3555         RETURN
3556         END SUBROUTINE Cloud_Base_Super
3557 ! +-------------------------------------------------------------------+
3558         SUBROUTINE supmax_COEFF (AKOE,BKOE,C3,PP,TT,RO_SOLUTE,IONS,MWAERO)
3559
3560                 implicit none
3561
3562 ! akoe, cm- constant in Koehler equation
3563 ! bkoe    - constant in Koehler equation
3564 ! F, cm^-2*s-  from Koehler equation
3565 ! C3 - coefficient depends on thermodynamical parameters
3566 ! PP, (DYNES/CM/CM)- PRESSURE
3567 ! TT, (K)- temperature
3568
3569   integer,intent(in) :: IONS
3570         real(kind=r8size) ,intent(in) ::        PP, TT
3571         real(kind=r8size) ,intent(out) :: AKOE, BKOE, C3
3572         real,intent(in) ::                              MWAERO, RO_SOLUTE
3573
3574         ! ... Local
3575                 real(kind=r8size) ,parameter :: RV_MY = 461.5D4, CP = 1005.0D4, G = 9.8D2, RD_MY = 287.0D4, & ![cgs]
3576                                                                                           PI = 3.141593D0
3577     real(kind=r8size) :: PZERO,TZERO,ALW1,SW,RO_W,HC,EW,RO_V,DV,RO_A,FL,FR,F,TPC,QV,A1,A2, &
3578                                                                    C1,C2,DEG01,DEG02
3579         ! ... Local
3580
3581      TPC = TT-273.15d0
3582
3583 ! CGS :
3584 ! RV_MY, CM*CM/SEC/SEC/KELVIN - INDIVIDUAL GAS CONSTANT
3585 !                               FOR WATER VAPOUR
3586         !RV_MY=461.5D4
3587
3588 ! CP,  CM*CM/SEC/SEC/KELVIN- SPECIFIC HEAT CAPACITY OF
3589 !                                   MOIST AIR AT CONSTANT PRESSURE
3590         !CP=1005.0D4
3591
3592 ! G,  CM/SEC/SEC- ACCELERATION OF GRAVITY
3593         !G=9.8D2
3594
3595 ! RD_MY, CM*CM/SEC/SEC/KELVIN - INDIVIDUAL GAS CONSTANT
3596 !                               FOR DRY AIR
3597         !RD_MY=287.0D4
3598
3599 ! AL2_MY, CM*CM/SEC/SEC - LATENT HEAT OF SUBLIMATION
3600
3601 !       AL2_MY=2.834D10
3602
3603 ! PZERO, DYNES/CM/CM - REFERENCE PRESSURE
3604         PZERO=1.01325D6
3605
3606 ! TZERO, KELVIN - REFERENCE TEMPERATURE
3607         TZERO=273.15D0
3608
3609 ! AL1_MY, CM*CM/SEC/SEC - LATENT HEAT OF VAPORIZATION
3610 ! ALW1=AL1_MY - ALW1 depends on temperature
3611 ! ALW1, [m^2/sec^2] -latent heat of vaporization-
3612
3613         ALW1 = -6.143419998D-2*tpc**(3.0D0)+1.58927D0*tpc**(2.0D0) &
3614          -2.36418D3*tpc+2.50079D6
3615 ! ALW1, [cm^2/sec^2]
3616
3617         ALW1 = ALW1*10.0D3
3618
3619 ! Sw, [N*m^-1] - surface tension of water-air interface
3620
3621         IF(tpc.LT.-5.5D0) THEN
3622                 Sw = 5.285D-11*tpc**(6.0D0)+6.283D-9*tpc**(5.0D0)+ &
3623         2.933D-7*tpc**(4.0D0)+6.511D-6*tpc**(3.0D0)+ &
3624         6.818D-5*tpc**(2.0D0)+1.15D-4*tpc+7.593D-2
3625         ELSE
3626            Sw = -1.55D-4*tpc+7.566165D-2
3627         ENDIF
3628
3629 ! Sw, [g/sec^2]
3630         Sw = Sw*10.0D2
3631
3632 ! RO_W, [kg/m^3] - density of liquid water
3633         IF (tpc.LT.0.0D0) THEN
3634             RO_W= -7.497D-9*tpc**(6.0D0)-3.6449D-7*tpc**(5.0D0) &
3635                   -6.9987D-6*tpc**(4.0D0)+1.518D-4*tpc**(3.0D0) &
3636                   -8.486D-3*tpc**(2.0D0)+6.69D-2*tpc+9.9986D2
3637
3638         ELSE
3639
3640             RO_W=(-3.932952D-10*tpc**(5.0D0)+1.497562D-7*tpc**(4.0D0) &
3641                  -5.544846D-5*tpc**(3.0D0)-7.92221D-3*tpc**(2.0D0)+ &
3642                  1.8224944D1*tpc+9.998396D2)/(1.0D0+1.8159725D-2*tpc)
3643         ENDIF
3644
3645 ! RO_W, [g/cm^3]
3646         RO_W=RO_W*1.0D-3
3647
3648 ! HC, [kg*m/kelvin*sec^3] - coefficient of air heat conductivity
3649         HC=7.1128D-5*tpc+2.380696D-2
3650
3651 ! HC, [g*cm/kelvin*sec^3]
3652         HC=HC*10.0D4
3653
3654 ! ew, water vapor pressure ! ... KS (kg/m2/sec)
3655
3656         ew = 6.38780966D-9*tpc**(6.0D0)+2.03886313D-6*tpc**(5.0D0)+ &
3657            3.02246994D-4*tpc**(4.0D0)+2.65027242D-2*tpc**(3.0D0)+ &
3658            1.43053301D0*tpc**(2.0D0)+4.43986062D1*tpc+6.1117675D2
3659
3660 ! ew, [g/cm*sec^2]
3661
3662         ew=ew*10.0D0
3663
3664 ! akoe & bkoe - constants in Koehler equation
3665
3666         !RO_SOLUTE=2.16D0
3667         AKOE=2.0D0*Sw/(RV_MY*RO_W*(tpc+TZERO))
3668         !BKOE=2.0D0*4.3D0/(22.9D0+35.5D0)
3669         BKOE = ions*4.3/mwaero
3670         BKOE=BKOE*(4.0D0/3.0D0)*pi*RO_SOLUTE
3671
3672 ! RO_V, g/cm^3 - density of water vapor
3673 !                calculate from equation of state for water vapor
3674         RO_V = ew/(RV_MY*(tpc+TZERO))
3675
3676 ! DV,  [cm^2/sec] - coefficient of diffusion
3677
3678 ! 'Pruppacher, H.R., Klett, J.D., 1997. Microphysics of Clouds and Precipitation'
3679 ! 'page num 503, eq. 13-3'
3680         DV = 0.211D0*(PZERO/PP)*((tpc+TZERO)/TZERO)**(1.94D0)
3681
3682 ! QV,  g/g- water vapor mixing ratio
3683 ! ro_a, g/cm^3 - density of air, from equation of state
3684         RO_A=PZERO/((tpc+TZERO)*RD_MY)
3685
3686 ! F, s/m^2 - coefficient depending on thermodynamics parameters
3687 !            such as temperature, thermal conductivity
3688 !            of air, etc
3689 ! left side of F equation
3690         FL=(RO_W*ALW1**(2.0D0))/(HC*RV_MY*(tpc+TZERO)**(2.0D0))
3691
3692 ! right side of F equation
3693         FR = RO_W*RV_MY*(tpc+TZERO)/(ew*DV)
3694         F = FL + FR
3695
3696 ! QV, g/g - water vapor mixing ratio
3697         QV=RO_V/RO_A
3698
3699 ! A1,A2 -  terms from equation describing changes of
3700 !          supersaturation in an adiabatic cloud air
3701 !          parcel
3702 ! A1, [cm^-1] - constant
3703 ! A2, [-]     - constant
3704
3705         A1=(G*ALW1/(CP*RV_MY*(tpc+TZERO)**(2.0D0)))-(G/(RD_MY*(tpc+TZERO)))
3706         A2=(1.0D0/QV)+(ALW1**(2.0D0))/(CP*RV_MY*(tpc+TZERO)**(2.0D0))
3707
3708 ! C1,C2,C3,C4- constant parameters
3709
3710         C1=1.058D0
3711         C2=1.904D0
3712         DEG01=1.0D0/3.0D0
3713         DEG02=1.0D0/6.0D0
3714         C3=C1*(F*A1/3.0D0)**(0.75D0)*DSQRT(3.0D0*RO_A/(4.0D0*pi*RO_W*A2))
3715   !C4=(C2-C1)**(DEG01)*(F*A1/3.0D0)**(0.25D0)*RO_A**(DEG02)* &
3716   !      DSQRT(3.0D0/(4.0D0*pi*RO_W*A2))
3717
3718         RETURN
3719         END SUBROUTINE SupMax_COEFF
3720 ! +----------------------------------------------------------------------------------------------------+
3721         SUBROUTINE LogNormal_modes_Aerosol(FCCNR_CON,FCCNR_MAR,NKR_local,COL,XL,XCCN,RCCN,RO_SOLUTE,Scale_Fa,IType)
3722
3723         implicit none
3724 ! ... Interface
3725                 integer,intent(in) :: NKR_local, Itype
3726                 real(kind=r4size) ,intent(in) :: XL(:), COL, RO_SOLUTE, Scale_Fa
3727                 real(kind=r8size) ,intent(out) :: FCCNR_CON(:), FCCNR_MAR(:)
3728                 real(kind=r4size) ,intent(out) :: XCCN(:),RCCN(:)
3729 ! ... Interface
3730 ! ... Local
3731                 integer :: mode_num, KR
3732                 integer,parameter :: modemax = 3
3733                 real(kind=r8size)  :: ccncon1, ccncon2, ccncon3, radius_mean1, radius_mean2, radius_mean3, &
3734                                                                     sig1, sig2, sig3,                                                                                                    &
3735                                                                     ccncon(modemax), sig(modemax), radius_mean(modemax)
3736                 real(kind=r8size)  :: CONCCCNIN, FCCNR_tmp(NKR_local), DEG01, X0DROP, &
3737                                                               XOCCN, X0, R0, RCCN_MICRON, S_KR, S(NKR_local), X0CCN, ROCCN(NKR_local), &
3738                                 RO_SOLUTE_Ammon, RO_SOLUTE_NaCl,arg11,arg12,arg13,arg21,arg22,arg23, &
3739                           arg31,arg32,arg33,dNbydlogR_norm1,dNbydlogR_norm2,dNbydlogR_norm3
3740
3741
3742                 real(kind=r8size) ,PARAMETER :: RCCN_MAX = 0.4D-4         ! [cm]
3743                 real(kind=r8size) ,PARAMETER :: RCCN_MIN = 0.003D-4             ! [cm]
3744                 ! ... Minimal radii for dry aerosol for the 3 log normal distribution
3745                 real(kind=r8size) ,PARAMETER :: RCCN_MIN_3LN = 0.00048D-4 ! [cm]
3746                 real(kind=r8size) ,PARAMETER :: PI = 3.14159265D0
3747 ! ... Local
3748
3749         ! ... Calculating the CCN radius grid
3750         !RO_SOLUTE_NaCl = 2.16D0  ! [g/cm3]
3751         !RO_SOLUTE_Ammon = 1.79  ! [g/cm3]
3752         DEG01 = 1.0D0/3.0D0
3753         X0DROP = XL(2)
3754         X0CCN = X0DROP/(2.0**(NKR_local))
3755         DO KR = NKR_local,1,-1
3756            ROCCN(KR) = RO_SOLUTE
3757            X0 = X0CCN*2.0D0**(KR)
3758            R0 = (3.0D0*X0/4.0D0/3.141593D0/ROCCN(KR))**DEG01
3759            XCCN(KR) = X0
3760            RCCN(KR) = R0
3761         ENDDO
3762
3763         IF(IType == 1) THEN ! Maritime regime
3764
3765                 ccncon1 = 340.000
3766                 radius_mean1 = 0.00500D-04
3767                 sig1 = 1.60000
3768
3769                 ccncon2 = 60.0000
3770                 radius_mean2 = 0.03500D-04
3771                 sig2 = 2.00000
3772
3773                 ccncon3 = 3.10000
3774                 radius_mean3 = 0.31000D-04
3775                 sig3 = 2.70000
3776
3777         ELSE IF(IType == 2) THEN ! Continental regime
3778
3779                 ccncon1 = 1000.000
3780                 radius_mean1 = 0.00800D-04
3781                 sig1 = 1.60000
3782
3783                 ccncon2 = 800.0000
3784                 radius_mean2 = 0.03400D-04
3785                 sig2 = 2.10000
3786
3787                 ccncon3 = 0.72000
3788                 radius_mean3 = 0.46000D-04
3789                 sig3 = 2.20000
3790
3791         ENDIF
3792
3793         FCCNR_tmp = 0.0
3794   CONCCCNIN = 0.0
3795
3796   arg11 = ccncon1/(sqrt(2.0D0*pi)*log(sig1))
3797   arg21 = ccncon2/(sqrt(2.0D0*pi)*log(sig2))
3798   arg31 = ccncon3/(sqrt(2.0D0*pi)*log(sig3))
3799
3800   dNbydlogR_norm1 = 0.0
3801   dNbydlogR_norm2 = 0.0
3802   dNbydlogR_norm3 = 0.0
3803   do kr = NKR_local,1,-1
3804       if(RCCN(kr) > RCCN_MIN_3LN .and. RCCN(kr) < RCCN_MAX)then
3805           arg12 = (log(RCCN(kr)/radius_mean1))**2.0
3806           arg13 = 2.0D0*((log(sig1))**2.0);
3807           dNbydlogR_norm1 = arg11*exp(-arg12/arg13)*(log(2.0)/3.0)
3808           arg22 = (log(RCCN(kr)/radius_mean2))**2.0
3809           arg23 = 2.0D0*((log(sig2))**2.0)
3810           dNbydlogR_norm2 = dNbydlogR_norm1 + arg21*exp(-arg22/arg23)*(log(2.0)/3.0)
3811           arg32 = (log(RCCN(kr)/radius_mean3))**2.0
3812           arg33 = 2.0D0*((log(sig3))**2.0)
3813           dNbydlogR_norm3 = dNbydlogR_norm2 + arg31*exp(-arg32/arg33)*(log(2.0)/3.0);
3814           FCCNR_tmp(kr) = dNbydlogR_norm3/col
3815       endif
3816 enddo
3817
3818   CONCCCNIN = col*sum(FCCNR_tmp(:))
3819   print*,'CONCCCNIN',CONCCCNIN
3820   if(IType == 1) FCCNR_MAR = Scale_Fa*FCCNR_tmp
3821   if(IType == 2) FCCNR_CON = Scale_Fa*FCCNR_tmp
3822
3823         RETURN
3824         END SUBROUTINE LogNormal_modes_Aerosol
3825 ! +---------------------------------------+
3826  end module module_mp_SBM_Nucleation
3827  ! +----------------------------------------------------------------------------+
3828  ! +----------------------------------------------------------------------------+
3829   MODULE module_mp_fast_sbm
3830
3831   USE module_mp_SBM_polar_radar,ONLY:polar_hucm
3832   USE module_mp_SBM_BreakUp,ONLY:Spont_Rain_BreakUp,BreakUp_Snow,KR_SNOW_MIN,KR_SNOW_MAX
3833   USE module_mp_SBM_Nucleation,ONLY:JERNUCL01_KS, LogNormal_modes_Aerosol
3834   USE module_mp_SBM_Auxiliary,ONLY:JERRATE_KS,JERTIMESC_KS,JERSUPSAT_KS,  &
3835                                    JERDFUN_KS,JERDFUN_NEW_KS,POLYSVP,Relaxation_Time
3836   USE scatt_tables,ONLY:faf1,fbf1,fab1,fbb1,         &
3837                                                             faf3,fbf3,fab3,fbb3,         &
3838                                                         faf4,fbf4,fab4,fbb4,         &
3839                                                         faf5,fbf5,fab5,fbb5,         &
3840                                                         LOAD_TABLES,                 &
3841                                                         temps_water,temps_fd,temps_crystals,  &
3842                                                         temps_snow,temps_graupel,temps_hail,  &
3843                                                         fws_fd,fws_crystals,fws_snow,                 &
3844                                                         fws_graupel,fws_hail,                       &
3845                                                         usetables,                            &
3846                          twolayer_hail,twolayer_graupel,twolayer_fd,twolayer_snow,rpquada,usequad
3847
3848  PRIVATE
3849
3850  PUBLIC FAST_SBM,FAST_HUCMINIT
3851
3852  ! Kind paramater
3853  INTEGER, PARAMETER, PRIVATE:: R8SIZE = 8
3854  INTEGER, PARAMETER, PRIVATE:: R16SIZE = 16
3855  INTEGER, PARAMETER, PRIVATE:: R4SIZE = 4
3856
3857  ! JacobS: Hard coding the bin-wise indices for the NMM core
3858  INTEGER, PRIVATE,PARAMETER ::  p_ff1i01=2, p_ff1i33=34,p_ff5i01=35,p_ff5i33=67,p_ff6i01=68,&
3859                                 p_ff6i33=100,p_ff8i01=101,p_ff8i43=143
3860
3861  ! JacobS: Hard coding for the polarimetric operator output array
3862   INTEGER, PRIVATE,PARAMETER :: r_p_ff1i01=2, r_p_ff1i06=07,r_p_ff2i01=08,r_p_ff2i06=13,r_p_ff3i01=14,&
3863                                 r_p_ff3i06=19,r_p_ff4i01=20,r_p_ff4i06=25,r_p_ff5i01=26,r_p_ff5i06=31,r_p_ff6i01=32,r_p_ff6i06=37,&
3864                                 r_p_ff7i01=38,r_p_ff7i06=43,r_p_ff8i01=44,r_p_ff8i06=49,r_p_ff9i01=50,r_p_ff9i06=55
3865
3866  INTEGER,PARAMETER :: IBREAKUP = 1
3867  INTEGER,PARAMETER :: Snow_BreakUp_On = 1
3868  INTEGER,PARAMETER :: Spont_Rain_BreakUp_On = 1
3869  LOGICAL,PARAMETER :: CONSERV = .TRUE.
3870  INTEGER,PARAMETER :: JIWEN_FAN_MELT = 1
3871  LOGICAL,PARAMETER :: IPolar_HUCM = .TRUE.
3872  INTEGER,PARAMETER :: hail_opt = 1
3873  INTEGER,PARAMETER :: ILogNormal_modes_Aerosol = 1
3874
3875  REAL,PARAMETER :: DX_BOUND = 1433
3876  REAL(kind=r8size), PARAMETER ::  SCAL = 1.d0
3877  INTEGER,PARAMETER :: ICEPROCS = 1
3878  INTEGER,PARAMETER :: ICETURB = 0, LIQTURB = 0
3879
3880  INTEGER,PARAMETER :: icempl=1,ICEMAX=3,NCD=33,NHYDR=5,NHYDRO=7    &
3881                                                 ,K0_LL=8,KRMIN_LL=1,KRMAX_LL=19,L0_LL=6                  &
3882                                                 ,IEPS_400=1,IEPS_800=0,IEPS_1600=0                       &
3883                                                 ,K0L_GL=16,K0G_GL=16                                     &
3884                                                 ,KRMINL_GL=1,KRMAXL_GL=24                                &
3885                                                 ,KRMING_GL=1,KRMAXG_GL=33                                &
3886                                                 ,KRDROP=15,KRBREAK=17,KRICE=18                           & ! KRDROP=Bin 15 --> 50um
3887                                                 !,NKR=43,JMAX=43,NRG=2,JBREAK=28,BR_MAX=43,KRMIN_BREAKUP=31,NKR_aerosol=43   ! 43 bins
3888                                                 ,NKR=33,JMAX=33,NRG=2,JBREAK=18,BR_MAX=33,KRMIN_BREAKUP=31,NKR_aerosol=43    ! 33 bins
3889
3890  REAL(kind=r4size) :: dt_coll
3891  REAL,PARAMETER :: C1_MEY=0.00033,C2_MEY=0.0,COL=0.23105, &
3892                    p1=1000000.0,p2=750000.0,p3=500000.0,  &
3893                    ALCR = 0.5, &
3894                    ALCR_G = 100.0 ! ... [KS] forcing no transition from graupel to hail in this version
3895  INTEGER :: NCOND, NCOLL
3896  INTEGER,PARAMETER :: kr_icempl=9
3897
3898  REAL(kind=r4size) :: &
3899                                          RADXX(NKR,NHYDR-1),MASSXX(NKR,NHYDR-1),DENXX(NKR,NHYDR-1) &
3900                                         ,MASSXXO(NKR,NHYDRO),DENXXO(NKR,NHYDRO),VRI(NKR)           &
3901           ,XX(nkr),ROCCN(nkr),FCCNR_MIX(NKR),FCCNR(NKR)
3902
3903  REAL(kind=r8size),DIMENSION (NKR) :: FF1R_D,XL_D,VR1_D &
3904                                                         ,FF3R_D,XS_D,VR3_D,VTS_D,FLIQFR_SD,RO3BL_D &
3905                                                         ,FF4R_D,XG_D,VR4_D,VTG_D,FLIQFR_GD,RO4BL_D &
3906                                                         ,FF5R_D,XH_D,VR5_D,VTH_D,FLIQFR_HD,RO5BL_D &
3907                                                         ,XS_MELT_D,XG_MELT_D,XH_MELT_D,VR_TEST,FRIMFR_SD,RF3R
3908
3909  ! ... SBMRADAR VARIABLES
3910  REAL(kind=r8size),DIMENSION (nkr,icemax) :: XI_MELT_D &
3911                                                         ,FF2R_D,XI_D,VR2_D,VTC_D,FLIQFR_ID,RO2BL_D
3912  REAL(kind=r8size) :: T_NEW_D,rhocgs_D,pcgs_D,DT_D,qv_old_D,qv_d
3913
3914  REAL(kind=r4size),private :: C2,C3,C4
3915  REAL(kind=r8size),private ::  &
3916                     xl_mg(nkr),xs_mg(nkr),xg_mg(nkr),xh_mg(nkr) &
3917              ,xi1_mg(nkr),xi2_mg(nkr),xi3_mg(nkr)
3918
3919  ! ----------------------------------------------------------------------------------+
3920  ! ... WRFsbm_Init
3921  ! ... Holding Lookup tables and memory arrays for the FAST_SBM module
3922          REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:)::                             &
3923                                           bin_mass,tab_colum,tab_dendr,tab_snow,bin_log
3924          REAL (KIND=R4SIZE), ALLOCATABLE, DIMENSION(:) ::                            &
3925                                           RLEC,RSEC,RGEC,RHEC,XL,XS,XG,XH,VR1,VR3,VR4,VR5
3926          REAL (KIND=R4SIZE), ALLOCATABLE, DIMENSION(:,:)::                           &
3927                                           RIEC,XI,VR2
3928          REAL (KIND=R4SIZE), ALLOCATABLE ::                              &
3929                                           COEFIN(:),SLIC(:,:),TLIC(:,:), &
3930                                           YWLL_1000MB(:,:),YWLL_750MB(:,:),YWLL_500MB(:,:)
3931          REAL (KIND=R4SIZE), ALLOCATABLE ::                              &
3932                                          YWLI_300MB(:,:,:),YWLI_500MB(:,:,:),YWLI_750MB(:,:,:),              &
3933                                          YWLG_300MB(:,:),YWLG_500MB(:,:),YWLG_750MB(:,:),YWLG(:,:),          &
3934                                          YWLH_300MB(:,:),YWLH_500MB(:,:),YWLH_750MB(:,:),                    &
3935                                          YWLS_300MB(:,:),YWLS_500MB(:,:),YWLS_750MB(:,:),                    &
3936                                          YWII_300MB(:,:,:,:),YWII_500MB(:,:,:,:),YWII_750MB(:,:,:,:),        &
3937                                          YWII_300MB_tmp(:,:,:,:),YWII_500MB_tmp(:,:,:,:),YWII_750MB_tmp(:,:,:,:),        &
3938                                          YWIS_300MB(:,:,:),YWIS_500MB(:,:,:),YWIS_750MB(:,:,:),              &
3939                                          YWSG_300MB(:,:),YWSG_500MB(:,:),YWSG_750MB(:,:),                    &
3940                                          YWSS_300MB(:,:),YWSS_500MB(:,:),YWSS_750MB(:,:)
3941
3942          REAL (KIND=R4SIZE), ALLOCATABLE ::                  &
3943                                          RO1BL(:), RO2BL(:,:), RO3BL(:), RO4BL(:), RO5BL(:),                 &
3944                                          RADXXO(:,:)
3945
3946          INTEGER,ALLOCATABLE ::              ima(:,:)
3947          REAL (KIND=R8SIZE), ALLOCATABLE ::  chucm(:,:)
3948
3949          REAL (KIND=R8SIZE), ALLOCATABLE ::  BRKWEIGHT(:),ECOALMASSM(:,:), Prob(:),Gain_Var_New(:,:),NND(:,:)
3950          REAL (KIND=R4SIZE), ALLOCATABLE ::  DROPRADII(:),PKIJ(:,:,:),QKJ(:,:)
3951          INTEGER ::          ikr_spon_break
3952
3953          REAL (KIND=R8SIZE), ALLOCATABLE ::  cwll(:,:), &
3954                                              cwli_1(:,:),cwli_2(:,:),cwli_3(:,:),        &
3955                                              cwil_1(:,:),cwil_2(:,:),cwil_3(:,:),        &
3956                                              cwlg(:,:),cwlh(:,:),cwls(:,:),              &
3957                                              cwgl(:,:),cwhl(:,:),cwsl(:,:),              &
3958                                              cwii_1_1(:,:),cwii_1_2(:,:),cwii_1_3(:,:),  &
3959                                              cwii_2_1(:,:),cwii_2_2(:,:),cwii_2_3(:,:),  &
3960                                              cwii_3_1(:,:),cwii_3_2(:,:),cwii_3_3(:,:),  &
3961                                              cwis_1(:,:),cwis_2(:,:),cwis_3(:,:),        &
3962                                              cwsi_1(:,:),cwsi_2(:,:),cwsi_3(:,:),        &
3963                                              cwig_1(:,:),cwig_2(:,:),cwig_3(:,:),        &
3964                                              cwih_1(:,:),cwih_2(:,:),cwih_3(:,:),        &
3965                                              cwsg(:,:),cwss(:,:)
3966          REAL(kind=r8size),ALLOCATABLE ::  FCCNR_MAR(:),FCCNR_CON(:)
3967          REAL(kind=r4size),ALLOCATABLE :: Scale_CCN_Factor,XCCN(:),RCCN(:),FCCN(:)
3968
3969  ! ... WRFsbm_Init
3970  ! --------------------------------------------------------------------------------+
3971
3972  INTEGER :: icloud
3973
3974  ! ### (KS) - CCN related
3975  ! -----------------------------------------------------------------------
3976  !REAL (KIND=R4SIZE), parameter :: mwaero = 22.9 + 35.5 ! sea salt
3977  real(kind=r4size),parameter :: mwaero = 115.0
3978  !integer,parameter :: ions = 2         ! sea salt
3979  integer,parameter  :: ions = 3         ! ammonium-sulfate
3980  !real(KIND=R4SIZE),parameter :: RO_SOLUTE = 2.16       ! sea salt
3981  real(kind=r4size),parameter ::  RO_SOLUTE = 1.79       ! ammonium-sulfate
3982  ! ----------------------------------------------------------------------
3983  REAL (KIND=R4SIZE) :: FR_LIM(NKR), FRH_LIM(NKR)
3984
3985    CONTAINS
3986  !-----------------------------------------------------------------------
3987        SUBROUTINE FAST_SBM (w,u,v,th_old,                                &
3988       &                      chem_new,n_chem,                            &
3989       &                      itimestep,DT,DX,DY,                         &
3990       &                      dz8w,rho_phy,p_phy,pi_phy,th_phy,           &
3991       &                      xland,domain_id,ivgtyp,xlat,xlong,          &
3992       &                      QV,QC,QR,QI,QS,QG,QV_OLD,                   &
3993       &                      QNC,QNR,QNI,QNS,QNG,QNA,                    &
3994       &                      ids,ide, jds,jde, kds,kde,                  &
3995       &                      ims,ime, jms,jme, kms,kme,                  &
3996       &                      its,ite, jts,jte, kts,kte,                  &
3997       &                      diagflag,                                   &
3998       &                      sbmradar,num_sbmradar,                      &
3999       &                      sbm_diagnostics,                            &
4000       &                      RAINNC,RAINNCV,SNOWNC,SNOWNCV,GRAUPELNC,GRAUPELNCV,SR)
4001  !-----------------------------------------------------------------------
4002        IMPLICIT NONE
4003  !-----------------------------------------------------------------------
4004         INTEGER :: KR,IKL,ICE
4005
4006         INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                     &
4007         &                     ,IMS,IME,JMS,JME,KMS,KME                    &
4008         &                     ,ITS,ITE,JTS,JTE,KTS,KTE                    &
4009         &                     ,ITIMESTEP,N_CHEM,NUM_SBMRADAR,domain_id    &
4010         &                     ,sbm_diagnostics
4011
4012         REAL, INTENT(IN)            :: DT,DX,DY
4013         REAL,  DIMENSION( ims:ime , kms:kme , jms:jme ), &
4014         INTENT(IN   ) ::                                 &
4015                                                           U, &
4016                                                           V, &
4017                                                           W
4018
4019         REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme,n_chem),INTENT(INOUT)   :: chem_new
4020         REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme,num_sbmradar),INTENT(INOUT)   :: sbmradar
4021         REAL,    DIMENSION( ims:ime , kms:kme , jms:jme ),               &
4022                        INTENT(INOUT) ::                                          &
4023                                                   qv,           &
4024                                                   qv_old,       &
4025                                                   th_old,       &
4026                                                   qc,           &
4027                                                   qr,           &
4028                                                   qi,              &
4029                                                   qs,           &
4030                                                   qg,           &
4031                                                   qnc,          &
4032                                                   qnr,          &
4033               qni,    &
4034                                                   qns,          &
4035                                                   qng,          &
4036                                                   qna
4037
4038        REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN)   :: XLAND
4039        LOGICAL, OPTIONAL, INTENT(IN) :: diagflag
4040
4041        INTEGER, DIMENSION( ims:ime , jms:jme ), INTENT(IN)::   IVGTYP
4042        REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN   )    :: XLAT, XLONG
4043        REAL, INTENT(IN),     DIMENSION(ims:ime, kms:kme, jms:jme)::      &
4044       &                      dz8w,p_phy,pi_phy,rho_phy
4045        REAL, INTENT(INOUT),  DIMENSION(ims:ime, kms:kme, jms:jme)::      &
4046       &                      th_phy
4047        REAL, INTENT(INOUT),  DIMENSION(ims:ime,jms:jme), OPTIONAL ::     &
4048       &      RAINNC,RAINNCV,SNOWNC,SNOWNCV,GRAUPELNC,GRAUPELNCV,SR
4049
4050  !-----------------------------------------------------------------------
4051  !     LOCAL VARS
4052  !-----------------------------------------------------------------------
4053
4054        REAL (KIND=R4SIZE),  DIMENSION(its-1:ite+1, kts:kte, jts-1:jte+1)::  &
4055                                                   t_new,t_old,zcgs,rhocgs,pcgs
4056
4057        INTEGER :: I,J,K,KFLIP
4058        INTEGER :: KRFREEZ
4059
4060        REAL (KIND=R4SIZE),PARAMETER :: Z0IN=2.0E5,ZMIN=2.0E5
4061
4062        REAL (KIND=R4SIZE) :: EPSF2D, &
4063       &        TAUR1,TAUR2,EPS_R1,EPS_R2,ANC1IN, &
4064       &        PEPL,PEPI,PERL,PERI,ANC1,ANC2,PARSP, &
4065       &        AFREEZMY,BFREEZMY,BFREEZMAX, &
4066       &        TCRIT,TTCOAL, &
4067       &        EPSF1,EPSF3,EPSF4, &
4068       &        SUP2_OLD, DSUPICEXZ,TFREEZ_OLD,DTFREEZXZ, &
4069       &        AA1_MY,BB1_MY,AA2_MY,BB2_MY, &
4070       &        DTIME,DTCOND,DTNEW,DTCOLL, &
4071       &        A1_MYN, BB1_MYN, A2_MYN, BB2_MYN
4072       DATA A1_MYN, BB1_MYN, A2_MYN, BB2_MYN  &
4073       &      /2.53,5.42,3.41E1,6.13/
4074       DATA AA1_MY,BB1_MY,AA2_MY,BB2_MY/2.53E12,5.42E3,3.41E13,6.13E3/
4075              !QSUM,ISUM,QSUM1,QSUM2,CCNSUM1,CCNSUM2
4076       DATA KRFREEZ,BFREEZMAX,ANC1,ANC2,PARSP,PEPL,PEPI,PERL,PERI, &
4077       &  TAUR1,TAUR2,EPS_R1,EPS_R2,TTCOAL,AFREEZMY,&
4078       &  BFREEZMY,EPSF1,EPSF3,EPSF4,TCRIT/21,&
4079       &  0.6600E00, &
4080       &  1.0000E02,1.0000E02,0.9000E02, &
4081       &  0.6000E00,0.6000E00,1.0000E-03,1.0000E-03, &
4082       &  0.5000E00,0.8000E00,0.1500E09,0.1500E09, &
4083       &  2.3315E02,0.3333E-04,0.6600E00, &
4084       &  0.1000E-02,0.1000E-05,0.1000E-05, &
4085       &  2.7015E02/
4086
4087       REAL (KIND=R4SIZE),DIMENSION (nkr) :: FF1IN,FF3IN,FF4IN,FF5IN,&
4088       &              FF1R,FF3R,FF4R,FF5R,FLIQFR_S,FRIMFR_S,FLIQFR_G,FLIQFR_H, &
4089       &              FF1R_NEW,FF3R_NEW,FF4R_NEW,FF5R_NEW
4090       REAL (KIND=R4SIZE),DIMENSION (nkr) :: FL3R,FL4R,FL5R,FL3R_NEW,FL4R_NEW,FL5R_NEW
4091
4092       REAL (KIND=R4SIZE),DIMENSION (nkr,icemax) :: FF2IN,FF2R,FLIQFR_I
4093
4094       REAL (KIND=R4SIZE) :: XI_MELT(NKR,ICEMAX),XS_MELT(NKR),XG_MELT(NKR),XH_MELT(NKR)
4095  !!!! NOTE: ZCGS AND OTHER VARIABLES ARE ALSO DIMENSIONED IN FALFLUXHUCM
4096       REAL (KIND=R8SIZE) :: DEL1NR,DEL2NR,DEL12R,DEL12RD,ES1N,ES2N,EW1N,EW1PN
4097       REAL (KIND=R8SIZE) :: DELSUP1,DELSUP2,DELDIV1,DELDIV2
4098       REAL (KIND=R8SIZE) :: TT,QQ,TTA,QQA,PP,DPSA,DELTATEMP,DELTAQ
4099       REAL (KIND=R8SIZE) :: DIV1,DIV2,DIV3,DIV4,DEL1IN,DEL2IN,DEL1AD,DEL2AD
4100       REAL (KIND=R4SIZE) :: DEL_BB,DEL_BBN,DEL_BBR, TTA_r
4101       REAL (KIND=R4SIZE) :: FACTZ,CONCCCN_XZ,CONCDROP
4102       REAL (KIND=R4SIZE) :: SUPICE(KTE),AR1,AR2, &
4103                                         & DERIVT_X,DERIVT_Y,DERIVT_Z,DERIVS_X,DERIVS_Y,DERIVS_Z, &
4104                                         & ES2NPLSX,ES2NPLSY,EW1NPLSX,EW1NPLSY,UX,VX, &
4105                                         & DEL2INPLSX,DEL2INPLSY,DZZ(KTE)
4106          INTEGER KRR,I_START,I_END,J_START,J_END
4107       REAL (KIND=R4SIZE) :: DTFREEZ_XYZ(ITE,KTE,JTE),DSUPICE_XYZ(ITE,KTE,JTE)
4108
4109       REAL (KIND=R4SIZE) :: DXHUCM,DYHUCM
4110       REAL (KIND=R4SIZE) :: FMAX1,FMAX2(ICEMAX),FMAX3,FMAX4,FMAX5
4111         INTEGER ISYM1,ISYM2(ICEMAX),ISYM3,ISYM4,ISYM5
4112         INTEGER DIFFU
4113         REAL (KIND=R4SIZE) :: DELTAW
4114         REAL (KIND=R4SIZE) :: zcgs_z(kts:kte),pcgs_z(kts:kte),rhocgs_z(kts:kte),ffx_z(kts:kte,nkr)
4115         REAL (KIND=R4SIZE) :: z_full
4116         REAL (KIND=R4SIZE) :: VRX(kts:kte,NKR)
4117
4118         REAL (KIND=R4SIZE) :: VR1_Z(NKR,KTS:KTE), FACTOR_P, VR1_Z3D(NKR,ITS:ITE,KTS:KTE,JTS:JTE)
4119         REAL (KIND=R4SIZE) :: VR2_ZC(NKR,KTS:KTE), VR2_Z(NKR,ICEMAX)
4120         REAL (KIND=R4SIZE) :: VR2_ZP(NKR,KTS:KTE)
4121         REAL (KIND=R4SIZE) :: VR2_ZD(NKR,KTS:KTE)
4122         REAL (KIND=R4SIZE) :: VR3_Z(NKR,KTS:KTE), VR3_Z3D(NKR,ITS:ITE,KTS:KTE,JTS:JTE)
4123         REAL (KIND=R4SIZE) :: VR4_Z(NKR,KTS:KTE), VR4_Z3D(NKR,ITS:ITE,KTS:KTE,JTS:JTE)
4124         REAL (KIND=R4SIZE) :: VR5_Z(NKR,KTS:KTE), VR5_Z3D(NKR,ITS:ITE,KTS:KTE,JTS:JTE)
4125         REAL (KIND=R4SIZE) :: BulkDen_Snow(NKR,ITS:ITE,KTS:KTE,JTS:JTE) ! Local array for snow density
4126
4127         REAL (KIND=R4SIZE), PARAMETER :: RON=8.E6, GON=5.E7,PI=3.14159265359
4128         REAL (KIND=R4SIZE) :: EFF_N,EFF_D
4129      REAL (KIND=R4SIZE) :: EFF_NI(its:ite,kts:kte,jts:jte),eff_di(its:ite,kts:kte,jts:jte)
4130         REAL (KIND=R4SIZE) :: EFF_NQIC,eff_DQIC
4131         REAL (KIND=R4SIZE) :: EFF_NQIP,eff_DQIP
4132         REAL (KIND=R4SIZE) :: EFF_NQID,eff_DQID
4133         REAL (KIND=R4SIZE) :: lambda,chi0,xi1,xi2,xi3,xi4,xi5,r_e,chi_3,f1,f2,volume,surface_area,xi6,ft,chi_e,ft_bin
4134         REAL (KIND=R4SIZE), DIMENSION(kts:kte)::                            &
4135                                                   qv1d, qr1d, nr1d, qs1d, ns1d, qg1d, ng1d, t1d, p1d
4136         REAL (KIND=R4SIZE), DIMENSION(kts:kte):: dBZ
4137
4138         REAL (KIND=R4SIZE) :: nzero,son,nzero_less
4139         parameter (son=2.E7)
4140         REAL (KIND=R4SIZE) :: raddumb(nkr),massdumb(nkr)
4141         REAL (KIND=R4SIZE) :: hydrosum
4142
4143         integer imax,kmax,jmax
4144         REAL (KIND=R4SIZE) :: gmax,tmax,qmax,divmax,rainmax,qnmax,inmax,knmax,hydro,difmax, tdif, tt_old, w_stag, w_stag_my, qq_old,teten,es
4145         integer  print_int
4146         parameter (print_int=300)
4147
4148         integer t_print,i_print,j_print,k_print
4149         REAL (KIND=R8SIZE), DIMENSION(kts:kte):: zmks_1d
4150         REAL (KIND=R8SIZE) :: dx_dbl, dy_dbl
4151         INTEGER,DIMENSION (nkr) :: melt_snow,melt_graupel,melt_hail,melt_ice
4152         !DOUBLE PRECISION,DIMENSION (nkr) :: dmelt_snow,dmelt_graupel,dmelt_hail,dmelt_ice
4153         INTEGER ihucm_flag
4154         REAL (KIND=R4SIZE) :: NSNOW_ADD
4155
4156         ! ... Polar-HUCM
4157         INTEGER,PARAMETER :: n_radar = 10
4158         integer :: ijk, Mod_Flag
4159         REAL (KIND=R8SIZE),PARAMETER :: wavelength = 11.0D0 ! ### (KS) - Rhyzkov uses this wavelength (NEXRAD)
4160         INTEGER :: IWL
4161         REAL (KIND=R4SIZE) :: DIST_SING
4162         REAL (KIND=R8SIZE) :: BKDEN_Snow(NKR)
4163         REAL (KIND=R8SIZE) ::  DISTANCE,FL1_FD(NKR),BULK(NKR), BulkDens_Snow(NKR)
4164         REAL (KIND=R8SIZE) ::  FF1_FD(NKR),FFL_FD(NKR),OUT1(n_radar),OUT2(n_radar),OUT3(n_radar),OUT4(n_radar),OUT5(n_radar), &
4165                                                    OUT6(n_radar),OUT7(n_radar),OUT8(n_radar),OUT9(n_radar), FL1R_FD(NKR)
4166         REAL (KIND=R8SIZE) :: rate_shed_per_grau_grampersec(NKR), rate_shed_per_hail_grampersec(NKR), rhoair_max
4167
4168         integer :: count_H, count_G, count_S_l, count_S_r
4169
4170         REAL (KIND=R8SIZE) :: RMin_G
4171         integer :: KR_GRAUP_MAX_BLAHAK, KR_G_TO_H
4172
4173         ! ... Cloud Base .........................................................
4174         REAL (KIND=R8SIZE) ::   SUP_WATER, ES1N_KS, ES1N_dummy, ES2N_dummy
4175         logical :: K_found
4176         integer ::      KZ_Cloud_Base(its:ite,jts:jte), IS_THIS_CLOUDBASE,KR_Small_Ice
4177         ! ........................................................................
4178         REAL (KIND=R4SIZE) :: qna0(its:ite,kts:kte,jts:jte), fr_hom, w_stagm, CollEff_out, FACT
4179         REAL (KIND=R4SIZE) :: FACTZ_new(KMS:KME,NKR), TT_r
4180  ! ### (KS) ............................................................................................
4181         INTEGER :: NZ,NZZ,II,JJ
4182
4183   XS_d = XS
4184
4185   if (itimestep.eq.1)then
4186     if (iceprocs.eq.1) call wrf_message(" FAST SBM: ICE PROCESES ACTIVE ")
4187     if (iceprocs.eq.0) call wrf_message(" FAST SBM: LIQUID PROCESES ONLY")
4188   end if
4189
4190   NCOND = 3
4191   NCOLL = 1
4192   DTCOND = DT/REAL(NCOND)
4193   DTCOLL = DT/REAL(NCOLL)
4194   dt_coll = DTCOLL
4195
4196   DEL_BB=BB2_MY-BB1_MY
4197   DEL_BBN=BB2_MYN-BB1_MYN
4198   DEL_BBR=BB1_MYN/DEL_BBN
4199
4200  if (conserv)then
4201     DO j = jts,jte
4202        DO i = its,ite
4203           DO k = kts,kte
4204
4205             rhocgs(I,K,J)=rho_phy(I,K,J)*0.001
4206                                 ! ... Drops
4207                                   KRR=0
4208                                   DO KR=p_ff1i01,p_ff1i33
4209                                 KRR=KRR+1
4210                           chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XL(KRR)/XL(KRR)/3.0
4211                                   END DO
4212                                 ! ... Snow
4213                                   KRR=0
4214                                   DO KR=p_ff5i01,p_ff5i33
4215                               KRR=KRR+1
4216                               chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XS(KRR)/XS(KRR)/3.0
4217                                   END DO
4218                                 ! ... Aerosols
4219                                   KRR=0
4220                                   DO KR=p_ff8i01,p_ff8i43
4221                           KRR=KRR+1
4222                                             chem_new(I,K,J,KR) = chem_new(I,K,J,KR)*RHOCGS(I,K,J)/1000.0
4223                                   END DO
4224                                 !  ... Hail or Graupel [same registry adresses]
4225            if(hail_opt == 1) then
4226              KRR=0
4227              DO KR=p_ff6i01,p_ff6i33
4228                  KRR=KRR+1
4229                  chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XH(KRR)/XH(KRR)/3.0
4230              END DO
4231
4232            else
4233              KRR=0
4234              DO KR=p_ff6i01,p_ff6i33
4235                  KRR=KRR+1
4236                  chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XG(KRR)/XG(KRR)/3.0
4237              END DO
4238            endif
4239
4240                                 END DO ! K
4241                         END DO  ! I
4242                 END DO ! J
4243   end if
4244
4245   DXHUCM=100.*DX
4246   DYHUCM=100.*DY
4247
4248   I_START=MAX(1,ITS-1)
4249   J_START=MAX(1,JTS-1)
4250   I_END=MIN(IDE-1,ITE+1)
4251   J_END=MIN(JDE-1,JTE+1)
4252
4253    DO j = j_start,j_end
4254       DO i = i_start,i_end
4255          z_full=0.
4256          DO k = kts,kte
4257             pcgs(I,K,J)=P_PHY(I,K,J)*10.
4258             rhocgs(I,K,J)=rho_phy(I,K,J)*0.001
4259             zcgs(I,K,J)=z_full+0.5*dz8w(I,K,J)*100
4260             !height(i,k,j) = 1.0e-2*zcgs(i,k,j) ! in [m]
4261             z_full=z_full+dz8w(i,k,j)*100.
4262          ENDDO
4263       ENDDO
4264    ENDDO
4265
4266  ! +---------------------------------------+
4267  ! ... Initial Aerosol distribution
4268  ! +---------------------------------------+
4269           if (itimestep == 1)then
4270            FACTZ_new = 0.0
4271            DO j = jts,jte
4272                   DO i = its,ite
4273                         DO k = kts,kte
4274                            rhoair_max = rhocgs(i,1,j) ! [g/cm3]
4275                            if(ILogNormal_modes_Aerosol == 1)then
4276                                   IF (zcgs(I,K,J) .LE. ZMIN)THEN
4277                                           FACTZ = 1.0
4278                                   ELSE
4279                                           FACTZ=EXP(-(zcgs(I,K,J)-ZMIN)/Z0IN)
4280                                   END IF
4281                                   ! ... CCN
4282                                   KRR = 0
4283                                   DO KR = p_ff8i01,p_ff8i43
4284                                         KRR = KRR + 1
4285                                         if (xland(i,j) == 1)then
4286                                                 ! chem_new(I,K,J,KR)=FCCNR_CON(KRR)*FACTZ
4287                                                 chem_new(I,K,J,KR) = (FCCNR_CON(KRR)/rhoair_max)*rhocgs(i,k,j) ! ... distributed vertically as [#/g]
4288              else
4289               ! chem_new(I,K,J,KR)=FCCNR_MAR(KRR)*FACTZ
4290                                                 chem_new(I,K,J,KR) = (FCCNR_MAR(KRR)/rhoair_max)*rhocgs(i,k,j) ! ... distributed vertically as [#/g]
4291                                         endif
4292                                   END DO
4293                                 endif
4294                         end do
4295                   end do
4296            end do
4297          end if
4298
4299 ! +--------------------------------------------+
4300  ! ... Aerosols boundary conditions
4301  !    (for 3D application running with MPI)
4302  ! +--------------------------------------------+
4303 #if (defined(DM_PARALLEL))
4304     if (itimestep > 1 .and. domain_id == 1)then
4305         DO j = jts,jte
4306          DO k = kts,kte
4307            DO i = its,ite
4308                           rhoair_max = rhocgs(i,1,j) ! [g/cm3]
4309               if (i <= 5 .or. i >= IDE-5 .OR. &
4310                   & j <= 5 .or. j >= JDE-5)THEN
4311                   if(ILogNormal_modes_Aerosol == 1)then
4312                     IF (zcgs(I,K,J).LE.ZMIN) THEN
4313                        FACTZ = 1.0
4314                     ELSE
4315                        FACTZ=EXP(-(zcgs(I,K,J)-ZMIN)/Z0IN)
4316                     END IF
4317                     ! ... CCN
4318                           KRR = 0
4319                     DO kr = p_ff8i01,p_ff8i43
4320                       KRR = KRR + 1
4321                                                         if (xland(i,j) == 1)then
4322                                                                 ! chem_new(I,K,J,KR)=FCCNR_CON(KRR)*FACTZ
4323                                                                 chem_new(I,K,J,KR) = (FCCNR_CON(KRR)/rhoair_max)*rhocgs(i,k,j)
4324                        else
4325                         ! chem_new(I,K,J,KR)=FCCNR_MAR(KRR)*FACTZ
4326                                                                 chem_new(I,K,J,KR) = (FCCNR_MAR(KRR)/rhoair_max)*rhocgs(i,k,j)
4327                                                         endif
4328                    END DO
4329                        endif
4330               end if
4331            end do
4332          end do
4333        end do
4334      end if
4335 #endif
4336
4337      if (itimestep == 1)then
4338         DO j = j_start,j_end
4339            DO k = kts,kte
4340              DO i = i_start,i_end
4341                 th_old(i,k,j)=th_phy(i,k,j)
4342                 qv_old(i,k,j)=qv(i,k,j)
4343               END DO
4344              END DO
4345         END DO
4346      end if
4347
4348      DO j = j_start,j_end
4349         DO k = kts,kte
4350            DO i = i_start,i_end
4351               t_new(i,k,j) = th_phy(i,k,j)*pi_phy(i,k,j)
4352               !tempc(i,k,j)= t_new(i,k,j)-273.16
4353               t_old(i,k,j) = th_old(i,k,j)*pi_phy(i,k,j)
4354            END DO
4355         END DO
4356      END DO
4357
4358      IF(ICEPROCS == 1)THEN
4359       KZ_Cloud_Base = 0
4360       DO j = jts,jte
4361           DO i = its,ite
4362             K_found = .FALSE.
4363             DO k = kts,kte
4364
4365               ES1N = AA1_MY*EXP(-BB1_MY/T_NEW(I,K,J))
4366               EW1N = QV(I,K,J)*pcgs(I,K,J)/(0.622+0.378*QV(I,K,J))
4367               SUP_WATER = EW1N/ES1N - 1.0
4368               if(k.lt.kte)then
4369                   w_stag_my     = 50.*(w(i,k,j)+w(i,k+1,j))
4370                 else
4371                   w_stag_my = 100*w(i,k,j)
4372               end if
4373               if(SUP_WATER > 0.0D0 .and. w_stag_my > 0.1*1.0D2 .and. K_found .eqv. .FALSE. .and. K > 2 .and. zcgs(I,K,J) < 3.0*1.0D5)then
4374                 KZ_Cloud_Base(I,J) = K ! K-level index of cloud base
4375                 K_found = .TRUE.
4376               endif
4377
4378               IF(K.EQ.KTE)THEN
4379                 DZZ(K)=(zcgs(I,K,J)-zcgs(I,K-1,J))
4380                 ELSE IF(K.EQ.1)THEN
4381                 DZZ(K)=(zcgs(I,K+1,J)-zcgs(I,K,J))
4382               ELSE
4383                 DZZ(K)=(zcgs(I,K+1,J)-zcgs(I,K-1,J))
4384               END IF
4385               ES2N=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J))
4386               EW1N=QV_OLD(I,K,J)*pcgs(I,K,J)/(0.622+0.378*QV_OLD(I,K,J))
4387               SUPICE(K)=EW1N/ES2N-1.
4388               IF(SUPICE(K).GT.0.5) SUPICE(K)=.5
4389             END DO
4390             DO k = kts,kte
4391               IF(T_OLD(I,K,J).GE.238.15.AND.T_OLD(I,K,J).LT.274.15) THEN
4392               if (k.lt.kte)then
4393                   w_stag=50.*(w(i,k,j)+w(i,k+1,j))
4394               else
4395                   w_stag=100*w(i,k,j)
4396               end if
4397               IF (I.LT.IDE-1.AND.J.LT.JDE-1)THEN
4398                 UX=25.*(U(I,K,J)+U(I+1,K,J)+U(I,K,J+1)+U(I+1,K,J+1))
4399                 VX=25.*(V(I,K,J)+V(I+1,K,J)+V(I,K,J+1)+V(I+1,K,J+1))
4400               ELSE
4401                 UX=U(I,K,J)*100.
4402                 VX=V(I,K,J)*100.
4403               END IF
4404               IF(K.EQ.1) DERIVT_Z=(T_OLD(I,K+1,J)-T_OLD(I,K,J))/DZZ(K)
4405               IF(K.EQ.KTE) DERIVT_Z=(T_OLD(I,K,J)-T_OLD(I,K-1,J))/DZZ(K)
4406               IF(K.GT.1.AND.K.LT.KTE) DERIVT_Z= &
4407                                     (T_OLD(I,K+1,J)-T_OLD(I,K-1,J))/DZZ(K)
4408               IF (I.EQ.1)THEN
4409                 DERIVT_X=(T_OLD(I+1,K,J)-T_OLD(I,K,J))/(DXHUCM)
4410               ELSE IF (I.EQ.IDE-1)THEN
4411                 DERIVT_X=(T_OLD(I,K,J)-T_OLD(I-1,K,J))/(DXHUCM)
4412               ELSE
4413                 DERIVT_X=(T_OLD(I+1,K,J)-T_OLD(I-1,K,J))/(2.*DXHUCM)
4414               END IF
4415               IF (J.EQ.1)THEN
4416                 DERIVT_Y=(T_OLD(I,K,J+1)-T_OLD(I,K,J))/(DYHUCM)
4417               ELSE IF (J.EQ.JDE-1)THEN
4418                   DERIVT_Y=(T_OLD(I,K,J)-T_OLD(I,K,J-1))/(DYHUCM)
4419               ELSE
4420                   DERIVT_Y=(T_OLD(I,K,J+1)-T_OLD(I,K,J-1))/(2.*DYHUCM)
4421               END IF
4422                 DTFREEZ_XYZ(I,K,J) = DT*(VX*DERIVT_Y+ &
4423                                   UX*DERIVT_X+w_stag*DERIVT_Z)
4424               ELSE ! IF(T_OLD(I,K,J).GE.238.15.AND.T_OLD(I,K,J).LT.274.15)
4425                 DTFREEZ_XYZ(I,K,J)=0.
4426               ENDIF
4427               IF(SUPICE(K).GE.0.02.AND.T_OLD(I,K,J).LT.268.15) THEN
4428                 IF (I.LT.IDE-1)THEN
4429                     ES2NPLSX=AA2_MY*EXP(-BB2_MY/T_OLD(I+1,K,J))
4430                     EW1NPLSX=QV_OLD(I+1,K,J)*pcgs(I+1,K,J)/ &
4431                               (0.622+0.378*QV_OLD(I+1,K,J))
4432                 ELSE
4433                     ES2NPLSX = AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J))
4434                     EW1NPLSX = QV_OLD(I,K,J)*pcgs(I,K,J)/ &
4435                               (0.622+0.378*QV_OLD(I,K,J))
4436                 END IF
4437                 IF (ES2NPLSX.EQ.0)THEN
4438                   DEL2INPLSX=0.5
4439                 ELSE
4440                   DEL2INPLSX=EW1NPLSX/ES2NPLSX-1.
4441                 END IF
4442                 IF(DEL2INPLSX.GT.0.5) DEL2INPLSX=.5
4443                 IF (I.GT.1)THEN
4444                   ES2N=AA2_MY*EXP(-BB2_MY/T_OLD(I-1,K,J))
4445                   EW1N=QV_OLD(I-1,K,J)*pcgs(I-1,K,J)/(0.622+0.378*QV_OLD(I-1,K,J))
4446                 ELSE
4447                   ES2N=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J))
4448                   EW1N=QV_OLD(I,K,J)*pcgs(I,K,J)/(0.622+0.378*QV_OLD(I,K,J))
4449                 END IF
4450                 DEL2IN=EW1N/ES2N-1.
4451                 IF(DEL2IN.GT.0.5) DEL2IN=.5
4452                 IF (I.GT.1.AND.I.LT.IDE-1)THEN
4453                     DERIVS_X=(DEL2INPLSX-DEL2IN)/(2.*DXHUCM)
4454                 ELSE
4455                     DERIVS_X=(DEL2INPLSX-DEL2IN)/(DXHUCM)
4456                 END IF
4457                 IF (J.LT.JDE-1)THEN
4458                   ES2NPLSY=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J+1))
4459                   EW1NPLSY=QV_OLD(I,K,J+1)*pcgs(I,K,J+1)/(0.622+0.378*QV_OLD(I,K,J+1))
4460                 ELSE
4461                   ES2NPLSY=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J))
4462                   EW1NPLSY=QV_OLD(I,K,J)*pcgs(I,K,J)/(0.622+0.378*QV_OLD(I,K,J))
4463                 END IF
4464                 DEL2INPLSY=EW1NPLSY/ES2NPLSY-1.
4465                 IF(DEL2INPLSY.GT.0.5) DEL2INPLSY=.5
4466                 IF (J.GT.1)THEN
4467                   ES2N=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J-1))
4468                   EW1N=QV_OLD(I,K,J-1)*pcgs(I,K,J-1)/(0.622+0.378*QV_OLD(I,K,J-1))
4469                 ELSE
4470                   ES2N=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J))
4471                   EW1N=QV_OLD(I,K,J)*pcgs(I,K,J)/(0.622+0.378*QV_OLD(I,K,J))
4472                 END IF
4473                 DEL2IN=EW1N/ES2N-1.
4474                 IF(DEL2IN.GT.0.5) DEL2IN=.5
4475                 IF (J.GT.1.AND.J.LT.JDE-1)THEN
4476                     DERIVS_Y=(DEL2INPLSY-DEL2IN)/(2.*DYHUCM)
4477                 ELSE
4478                     DERIVS_Y=(DEL2INPLSY-DEL2IN)/(DYHUCM)
4479                 END IF
4480                 IF (K.EQ.1)DERIVS_Z=(SUPICE(K+1)-SUPICE(K))/DZZ(K)
4481                 IF (K.EQ.KTE)DERIVS_Z=(SUPICE(K)-SUPICE(K-1))/DZZ(K)
4482                 IF(K.GT.1.and.K.LT.KTE) DERIVS_Z=(SUPICE(K+1)-SUPICE(K-1))/DZZ(K)
4483                 IF (I.LT.IDE-1.AND.J.LT.JDE-1)THEN
4484                 UX=25.*(U(I,K,J)+U(I+1,K,J)+U(I,K,J+1)+U(I+1,K,J+1))
4485                 VX=25.*(V(I,K,J)+V(I+1,K,J)+V(I,K,J+1)+V(I+1,K,J+1))
4486               ELSE
4487                 UX=U(I,K,J)*100.
4488                 VX=V(I,K,J)*100.
4489               END IF
4490               DSUPICE_XYZ(I,K,J)=(UX*DERIVS_X+VX*DERIVS_Y+ &
4491                                   w_stag*DERIVS_Z)*DTCOND
4492               ELSE
4493                 DSUPICE_XYZ(I,K,J)=0.0
4494               END IF
4495               END DO
4496             END DO
4497           END DO
4498         ENDIF
4499
4500        do j = jts,jte
4501           do k = kts,kte
4502              do i = its,ite
4503
4504             ! ... correcting Look-up-table Terminal velocities
4505             FACTOR_P = DSQRT(1.0D6/PCGS(I,K,J))
4506             VR2_ZC(1:nkr,K) = VR2(1:nkr,1)*FACTOR_P
4507             VR2_ZP(1:nkr,K) = VR2(1:nkr,2)*FACTOR_P
4508             VR2_ZD(1:nkr,K) = VR2(1:nkr,3)*FACTOR_P
4509             VR1_Z(1:nkr,K) =  VR1(1:nkr)*FACTOR_P
4510             VR3_Z(1:nkr,K) = VR3(1:nkr)*FACTOR_P
4511             VR4_Z(1:nkr,K) = VR4(1:nkr)*FACTOR_P
4512             VR5_Z(1:nkr,k) = VR5(1:nkr)*FACTOR_P
4513             VR1_Z3D(1:nkr,I,K,J) = VR1(1:nkr)*FACTOR_P
4514             VR3_Z3D(1:nkr,I,K,J) = VR3(1:nkr)*FACTOR_P
4515             VR4_Z3D(1:nkr,I,K,J) = VR4(1:nkr)*FACTOR_P
4516             VR5_Z3D(1:nkr,I,K,J) = VR5(1:nkr)*FACTOR_P
4517
4518                         ! ... Liquid
4519                           KRR = 0
4520                           DO kr = p_ff1i01,p_ff1i33
4521                                  KRR = KRR + 1
4522                                  FF1R(KRR) = chem_new(I,K,J,KR)
4523                                  IF (FF1R(KRR) < 0.0)FF1R(KRR) = 0.0
4524                           END DO
4525                         ! ... CCN
4526                           KRR = 0
4527                           DO kr=p_ff8i01,p_ff8i43
4528                                  KRR = KRR + 1
4529                                  FCCN(KRR) = chem_new(I,K,J,KR)
4530                                  if (fccn(krr) < 0.0)fccn(krr) = 0.0
4531                           END DO
4532
4533                                 ! no explicit Ice Crystals in FSBM
4534                                  FF2R(:,1) = 0.0
4535                                  FF2R(:,2) = 0.0
4536                                  FF2R(:,3) = 0.0
4537
4538                                 ! ... Snow
4539                                 KRR=0
4540                                 DO kr=p_ff5i01,p_ff5i33
4541                                         KRR=KRR+1
4542                                         FF3R(KRR)=chem_new(I,K,J,KR)
4543                                         if (ff3r(krr) < 0.0)ff3r(krr) = 0.0
4544                                 END DO
4545
4546           ! ... Hail or Graupel
4547           if(hail_opt == 1)then
4548            KRR=0
4549            DO kr=p_ff6i01,p_ff6i33
4550                KRR=KRR+1
4551                FF5R(KRR) = chem_new(I,K,J,KR)
4552                if (ff5r(krr) < 0.0)ff5r(krr) = 0.0
4553                FF4R(KRR) = 0.0
4554            ENDDO
4555           else
4556            KRR=0
4557            DO kr=p_ff6i01,p_ff6i33
4558                KRR=KRR+1
4559                FF4R(KRR) = chem_new(I,K,J,KR)
4560                if (ff4r(krr) < 0.0)ff4r(krr) = 0.0
4561                FF5R(KRR) = 0.0
4562            ENDDO
4563           endif
4564
4565 ! +---------------------------------------------+
4566 ! Neucliation, Condensation, Collisions
4567 ! +---------------------------------------------+
4568           IF (T_OLD(I,K,J).GT.193.15)THEN
4569              TT=T_OLD(I,K,J)
4570              QQ=QV_OLD(I,K,J)
4571              IF(QQ.LE.0.0) QQ = 1.D-10
4572              PP=pcgs(I,K,J)
4573              TTA=T_NEW(I,K,J)
4574              QQA=QV(I,K,J)
4575
4576              IF (QQA.LE.0) call wrf_message("WARNING: FAST SBM, QQA < 0")
4577              IF (QQA.LE.0) print*,'I,J,K,Told,Tnew,QQA = ',I,J,K,TT,TTA,QQA
4578              IF (QQA.LE.0) QQA = 1.0D-10
4579
4580               ES1N = AA1_MY*DEXP(-BB1_MY/TT)
4581               ES2N = AA2_MY*DEXP(-BB2_MY/TT)
4582               EW1N=QQ*PP/(0.622+0.378*QQ)
4583               DIV1=EW1N/ES1N
4584               DEL1IN=EW1N/ES1N-1.
4585               DIV2=EW1N/ES2N
4586               DEL2IN=EW1N/ES2N-1.
4587               ES1N=AA1_MY*DEXP(-BB1_MY/TTA)
4588               ES2N=AA2_MY*DEXP(-BB2_MY/TTA)
4589               EW1N=QQA*PP/(0.622+0.378*QQA)
4590               DIV3=EW1N/ES1N
4591               DEL1AD=EW1N/ES1N-1.
4592               DIV4=EW1N/ES2N
4593               DEL2AD=EW1N/ES2N-1.
4594               SUP2_OLD=DEL2IN
4595
4596               IF(del1ad > 0.0 .or. del2ad > 0.0 .or. (sum(FF1R)+sum(FF3R)+sum(FF4R)+sum(FF5R)) > 1.0e-20)THEN
4597                 ! JacobS: commented for this version
4598                 !                CALL Relaxation_Time(TT,QQ,PP,rhocgs(I,K,J),DEL1IN,DEL2IN, &
4599                 !                                      XL,VR1_Z(:,K),FF1R,RLEC,RO1BL, &
4600                 !                                      XI,VR2_Z,FF2R,RIEC,RO2BL, &
4601                 !                                      XS,VR3_Z(:,K),FF3R,RSEC,RO3BL, &
4602                 !                                      XG,VR4_Z(:,K),FF4R,RGEC,RO4BL, &
4603                 !                                      XH,VR5_Z(:,k),FF5R,RHEC,RO5BL, &
4604                 !                                      NKR,ICEMAX,COL,DT,NCOND,DTCOND)
4605                   DELSUP1=(DEL1AD-DEL1IN)/NCOND
4606                   DELSUP2=(DEL2AD-DEL2IN)/NCOND
4607                   DELDIV1=(DIV3-DIV1)/NCOND
4608                   DELDIV2=(DIV4-DIV2)/NCOND
4609                   DELTATEMP = 0
4610                   DELTAQ = 0
4611                   tt_old = TT
4612                   qq_old = qq
4613                   DIFFU=1
4614
4615                   IF (DIV1.EQ.DIV3) DIFFU = 0
4616                   IF (DIV2.EQ.DIV4) DIFFU = 0
4617
4618                   DTNEW = 0.0
4619                   DO IKL=1,NCOND
4620                     DTCOND = min(DT-DTNEW,DTCOND)
4621                     DTNEW = DTNEW + DTCOND
4622
4623                     IF (DIFFU.NE.0)THEN
4624                       IF (DIFFU.NE.0)THEN
4625                           DEL1IN = DEL1IN+DELSUP1
4626                           DEL2IN = DEL2IN+DELSUP2
4627                           DIV1 = DIV1+DELDIV1
4628                           DIV2 = DIV2+DELDIV2
4629                       END IF
4630                       IF (DIV1.GT.DIV2.AND.TT.LE.265)THEN
4631                         DIFFU=0
4632                       END IF
4633                       IF (DIFFU == 1)THEN
4634                         DEL1NR=A1_MYN*(100.*DIV1)
4635                         DEL2NR=A2_MYN*(100.*DIV2)
4636                         IF (DEL2NR.EQ.0)print*,'ikl = ',ikl
4637                         IF (DEL2NR.EQ.0)print*,'div1,div2 = ',div1,div2
4638                         IF (DEL2NR.EQ.0)print*,'i,j,k = ',i,j,k
4639                         IF (DEL2NR.EQ.0)call wrf_error_fatal("fatal error in module_mp_fast_sbm (DEL2NR.EQ.0) , model stop ")
4640                         DEL12R=DEL1NR/DEL2NR
4641                         DEL12RD=DEL12R**DEL_BBR
4642                         EW1PN=AA1_MY*100.*DIV1*DEL12RD/100.
4643                         TT=-DEL_BB/DLOG(DEL12R)
4644                         QQ=0.622*EW1PN/(PP-0.378*EW1PN)
4645
4646                         IF(DEL1IN > 0.0 .OR. DEL2IN > 0.0)THEN
4647 ! +------------------------------------------+
4648 ! Droplet nucleation :
4649 ! +------------------------------------------+
4650                           DO KR=1,NKR
4651                             FF1IN(KR)=FF1R(KR)
4652                               DO ICE=1,ICEMAX
4653                                 FF2IN(KR,ICE)=FF2R(KR,ICE)
4654                               ENDDO
4655                             ENDDO
4656                           Is_This_CloudBase = 0
4657                           IF(KZ_Cloud_Base(I,J) == K .and. col*sum(FF1IN*XL) < 5.0) Is_This_CloudBase = 1
4658                           if (k.lt.kte)then
4659                             w_stag_my   = 50.*(w(i,k,j)+w(i,k+1,j))
4660                           else
4661                             w_stag_my = 100*w(i,k,j)
4662                           end if
4663                           CALL JERNUCL01_KS(FF1IN,FF2IN,FCCN              &
4664                                             ,XL,XI,TT,QQ                                            &
4665                                             ,rhocgs(I,K,J),pcgs(I,K,J)                  &
4666                                             ,DEL1IN,DEL2IN                              &
4667                                             ,COL                                                                            &
4668                                             ,SUP2_OLD,DSUPICE_XYZ(I,K,J)                &
4669                                             ,RCCN,DROPRADII,NKR,NKR_aerosol,ICEMAX,ICEPROCS &
4670                                             ,W_Stag_My,Is_This_CloudBase,RO_SOLUTE,IONS,MWAERO &
4671                                             ,I,J,K)
4672
4673
4674                           DO KR=1,NKR
4675                             FF1R(KR)=FF1IN(KR)
4676                             DO ICE=1,ICEMAX
4677                               FF3R(KR) = FF3R(KR) + FF2IN(KR,ICE)
4678                               FF2IN(KR,ICE) = 0.0
4679                               FF2R(KR,ICE) = 0.0
4680                             END DO
4681                           END DO
4682                         END IF
4683
4684                         FMAX1=0.
4685                         FMAX2=0.
4686                         FMAX3=0.
4687                         FMAX4=0.
4688                         FMAX5=0.
4689                         DO KR=1,NKR
4690                           FF1IN(KR)=FF1R(KR)
4691                           FMAX1=AMAX1(FF1R(KR),FMAX1)
4692                           FF3IN(KR)=FF3R(KR)
4693                           FMAX3=AMAX1(FF3R(KR),FMAX3)
4694                           FF4IN(KR)=FF4R(KR)
4695                           FMAX4=AMAX1(FF4R(KR),FMAX4)
4696                           FF5IN(KR)=FF5R(KR)
4697                           FMAX5=AMAX1(FF5R(KR),FMAX5)
4698                           DO ICE=1,ICEMAX
4699                             FF2IN(KR,ICE)=FF2R(KR,ICE)
4700                             FMAX2(ICE)=AMAX1(FF2R(KR,ICE),FMAX2(ICE)) ! ### (KS) FMAX2(3)
4701                           END DO
4702                         END DO
4703                       ISYM1=0
4704                       ISYM2=0
4705                       ISYM3=0
4706                       ISYM4=0
4707                       ISYM5=0
4708                       IF(FMAX1 > 0)ISYM1 = 1
4709                       IF (ICEPROCS == 1)THEN
4710                         IF(FMAX2(1) > 1.E-10)ISYM2(1) = 1
4711                         IF(FMAX2(2) > 1.E-10)ISYM2(2) = 1
4712                         IF(FMAX2(3) > 1.E-10)ISYM2(3) = 1
4713                         IF(FMAX3 > 1.E-10)ISYM3 = 1
4714                         IF(FMAX4 > 1.E-10)ISYM4 = 1
4715                         IF(FMAX5 > 1.E-10)ISYM5 = 1
4716                       END IF
4717
4718                       IF(ISYM1==1 .AND. ((TT-273.15)>-0.187 .OR.(sum(ISYM2)==0 .AND. &
4719                           ISYM3==0 .AND. ISYM4==0 .AND. ISYM5==0)))THEN
4720
4721                           ! ... only warm phase
4722                           CALL ONECOND1(TT,QQ,PP,rhocgs(I,K,J) &
4723                                         ,VR1_Z(:,K),pcgs(I,K,J) &
4724                                         ,DEL1IN,DEL2IN,DIV1,DIV2 &
4725                                         ,FF1R,FF1IN,XL,RLEC,RO1BL &
4726                                         ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
4727                                         ,C1_MEY,C2_MEY &
4728                                         ,COL,DTCOND,ICEMAX,NKR,ISYM1 &
4729                                         ,ISYM2,ISYM3,ISYM4,ISYM5,I,J,K,W(i,k,j),DX,Itimestep)
4730
4731                         ELSE IF(ISYM1==0 .AND. (TT-273.15)<-0.187 .AND. &
4732                                 (sum(ISYM2)>1 .OR. ISYM3==1 .OR. ISYM4==1 .OR. ISYM5==1))THEN
4733                                   !IF (TT.GT.213.15)THEN
4734                                     VR2_Z(:,1) = VR2_ZC(:,K)
4735                                     VR2_Z(:,2) = VR2_ZP(:,K)
4736                                     VR2_Z(:,3) = VR2_ZD(:,K)
4737                                     CALL ONECOND2(TT,QQ,PP,rhocgs(I,K,J) &
4738                                     ,VR2_Z,VR3_Z(:,K),VR4_Z(:,K),VR5_Z(:,K),pcgs(I,K,J) &
4739                                     ,DEL1IN,DEL2IN,DIV1,DIV2 &
4740                                     ,FF2R,FF2IN,XI,RIEC,RO2BL &
4741                                     ,FF3R,FF3IN,XS,RSEC,RO3BL &
4742                                     ,FF4R,FF4IN,XG,RGEC,RO4BL &
4743                                     ,FF5R,FF5IN,XH,RHEC,RO5BL &
4744                                     ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
4745                                     ,C1_MEY,C2_MEY &
4746                                     ,COL,DTCOND,ICEMAX,NKR &
4747                                     ,ISYM1,ISYM2,ISYM3,ISYM4,ISYM5,I,J,K,W(i,k,j),DX,Itimestep)
4748                                 !END IF
4749                           ELSE IF(ISYM1==1 .AND. (TT-273.15)<-0.187 .AND. &
4750                               (sum(ISYM2)>1 .OR. ISYM3==1 .OR. ISYM4==1 .OR. ISYM5==1))THEN
4751                               IF (TT > 233.15)THEN
4752                                 VR2_Z(:,1) = VR2_ZC(:,K)
4753                                 VR2_Z(:,2) = VR2_ZP(:,K)
4754                                 VR2_Z(:,3) = VR2_ZD(:,K)
4755                                 CALL ONECOND3(TT,QQ,PP,rhocgs(I,K,J) &
4756                                 ,VR1_Z(:,K),VR2_Z,VR3_Z(:,K),VR4_Z(:,K),VR5_Z(:,K),pcgs(I,K,J) &
4757                                 ,DEL1IN,DEL2IN,DIV1,DIV2 &
4758                                 ,FF1R,FF1IN,XL,RLEC,RO1BL &
4759                                 ,FF2R,FF2IN,XI,RIEC,RO2BL &
4760                                 ,FF3R,FF3IN,XS,RSEC,RO3BL &
4761                                 ,FF4R,FF4IN,XG,RGEC,RO4BL &
4762                                 ,FF5R,FF5IN,XH,RHEC,RO5BL &
4763                                 ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
4764                                 ,C1_MEY,C2_MEY &
4765                                 ,COL,DTCOND,ICEMAX,NKR &
4766                                 ,ISYM1,ISYM2,ISYM3,ISYM4,ISYM5,I,J,K,W(i,k,j),DX,Itimestep)
4767                               ENDIF
4768                             END IF
4769                           END IF ! DIFF.NE.0
4770                       END IF ! DIFFU.NE.0
4771                   END DO ! NCOND - end of NCOND loop
4772 ! +----------------------------------+
4773 ! Collision-Coallescnce
4774 ! +----------------------------------+
4775                   DO IKL = 1,NCOLL
4776                     IF ( TT >= 233.15 ) THEN
4777                       FLIQFR_SD = 0.0
4778                       FLIQFR_GD = 0.0
4779                       FLIQFR_HD = 0.0
4780                       FRIMFR_SD = 0.0
4781                       CALL COAL_BOTT_NEW (FF1R,FF2R,FF3R,                                   &
4782                                 FF4R,FF5R,TT,QQ,PP,                                                 &
4783                                 rhocgs(I,K,J),dt_coll,TCRIT,TTCOAL,         &
4784                                 FLIQFR_SD,FLIQFR_GD,FLIQFR_HD,FRIMFR_SD,  &
4785                                 DEL1IN, DEL2IN,                                                   &
4786                                 I,J,K,Itimestep,CollEff_out)
4787
4788                     END IF
4789                   END DO ! NCOLL - end of NCOLL loop
4790
4791                   T_new(i,k,j) = tt
4792                   qv(i,k,j) = qq
4793
4794             ! in case Sw,Si,mass
4795             ENDIF
4796         ! in case T_OLD(I,K,J).GT.213.15
4797         END IF
4798  ! +-------------------------------- +
4799  ! Immediate Freezing
4800  ! +---------------------------------+
4801                                 IF(T_NEW(i,k,j) < 273.15 .and. ICEPROCS == 1)THEN
4802                                         CALL FREEZ &
4803                                                         (FF1R,XL,FF2R,XI,FF3R,XS,FF4R,XG,FF5R,XH, &
4804                                                          T_NEW(I,K,J),DT,rhocgs(I,K,J),                           &
4805                                                          COL,AFREEZMY,BFREEZMY,BFREEZMAX,                 &
4806                                                          KRFREEZ,ICEMAX,NKR)
4807                                 ENDIF
4808 ! --------------------------------------------------------------+
4809 ! Jiwen Fan Melting (melting along a constant time scale)
4810 ! --------------------------------------------------------------+
4811                     IF (JIWEN_FAN_MELT == 1 .and. T_NEW(i,k,j) > 273.15 .and. ICEPROCS == 1) THEN
4812                                    CALL J_W_MELT(FF1R,XL,FF2R,XI,FF3R,XS,FF4R,XG,FF5R,XH, &
4813                                                              T_NEW(I,K,J),DT,rhocgs(I,K,J),COL,ICEMAX,NKR)
4814         END IF
4815
4816         DO KR=1,NKR
4817           DO ICE=1,ICEMAX
4818             FF3R(KR)=FF3R(KR) + FF2R(KR,ICE)
4819             FF2R(KR,ICE) = 0.0
4820           END DO
4821           if(hail_opt == 1)then
4822             FF5R(KR) = FF5R(KR) + FF4R(KR)
4823             FF4R(KR) = 0.0
4824           else
4825             FF4R(KR) = FF4R(KR) + FF5R(KR)
4826             FF5R(KR) = 0.0
4827           endif
4828         END DO
4829
4830  ! +---------------------------+
4831  ! Spontanaous Rain Breakup
4832 ! +----------------------------+
4833                         IF (Spont_Rain_BreakUp_On == 1 .AND. (SUM(FF1R) > 43.0*1.0D-30) )THEN
4834                                         FF1R_D(:) = FF1R(:)
4835                                         XL_D(:) = XL(:)
4836                                         CALL Spont_Rain_BreakUp (DT ,FF1R_D, XL_D, Prob, Gain_Var_New, NND, NKR, ikr_spon_break)
4837                       FF1R(:) = FF1R_D(:)
4838                         END IF
4839
4840  ! -----------------------------------------------------------+
4841  ! ... Snow BreakUp
4842  ! -----------------------------------------------------------+
4843                 IF (Snow_BreakUp_On == 1 .and. ICEPROCS == 1 .and. sum(FF3R(KR_SNOW_MIN:NKR))> (NKR-KR_SNOW_MIN)*1.0D-30)THEN
4844
4845                         DO KR=1,NKR
4846                                 FF3R_D(KR) = FF3R(KR)
4847                         END DO
4848                         IF (KR_SNOW_MAX <= NKR) CALL BreakUp_Snow (TT_r,FF3R_D,FLIQFR_SD,xs_d,FRIMFR_SD,NKR)
4849                                         DO KR=1,NKR
4850                                                 FF3R(KR) = FF3R_D(KR)
4851                                         END DO
4852                 END IF
4853
4854     ! Update temperature at the end of MP
4855         th_phy(i,k,j) = t_new(i,k,j)/pi_phy(i,k,j)
4856
4857     ! ... Drops
4858           KRR = 0
4859           DO kr = p_ff1i01,p_ff1i33
4860                  KRR = KRR+1
4861                  chem_new(I,K,J,KR) = FF1R(KRR)
4862           END DO
4863           ! ... CCN
4864           KRR = 0
4865           DO kr=p_ff8i01,p_ff8i43
4866                   KRR=KRR+1
4867                   chem_new(I,K,J,KR)=FCCN(KRR)
4868           END DO
4869           IF (ICEPROCS == 1)THEN
4870           ! ... Snow
4871                   KRR = 0
4872                   DO kr=p_ff5i01,p_ff5i33
4873                           KRR=KRR+1
4874                           chem_new(I,K,J,KR)=FF3R(KRR)
4875                   END DO
4876      ! ... Hail/ Graupel
4877       if(hail_opt == 1)then
4878        KRR = 0
4879        DO KR=p_ff6i01,p_ff6i33
4880            KRR=KRR+1
4881            chem_new(I,K,J,KR) = FF5R(KRR)
4882        END DO
4883       else
4884        KRR = 0
4885        DO KR=p_ff6i01,p_ff6i33
4886            KRR=KRR+1
4887            chem_new(I,K,J,KR) = FF4R(KRR)
4888        END DO
4889       endif
4890       ! ICEPROCS == 1
4891                    END IF
4892
4893        END DO
4894       END DO
4895      END DO
4896
4897 ! +-----------------------------+
4898 ! Hydrometeor Sedimentation
4899 ! +-----------------------------+
4900        do j = jts,jte
4901         do i = its,ite
4902  ! ... Drops ...
4903                             do k = kts,kte
4904             rhocgs_z(k)=rhocgs(i,k,j)
4905             pcgs_z(k)=pcgs(i,k,j)
4906             zcgs_z(k)=zcgs(i,k,j)
4907             vrx(k,:)=vr1_z3D(:,i,k,j)
4908             krr=0
4909             do kr=p_ff1i01,p_ff1i33
4910               krr=krr+1
4911               ffx_z(k,krr)=chem_new(i,k,j,kr)/rhocgs(i,k,j)
4912             end do
4913           end do
4914           call FALFLUXHUCM_Z(ffx_z,VRX,RHOCGS_z,PCGS_z,ZCGS_z,DT,kts,kte,nkr)
4915           do k = kts,kte
4916             krr=0
4917             do kr=p_ff1i01,p_ff1i33
4918               krr=krr+1
4919               chem_new(i,k,j,kr)=ffx_z(k,krr)*rhocgs(i,k,j)
4920             end do
4921           end do
4922                 if(iceprocs == 1)then
4923  ! ... Snow ...
4924           do k = kts,kte
4925             rhocgs_z(k)=rhocgs(i,k,j)
4926             pcgs_z(k)=pcgs(i,k,j)
4927             zcgs_z(k)=zcgs(i,k,j)
4928             vrx(k,:)=vr3_z3D(:,i,k,j)
4929             krr=0
4930             do kr=p_ff5i01,p_ff5i33
4931               krr=krr+1
4932               ffx_z(k,krr)=chem_new(i,k,j,kr)/rhocgs(i,k,j)
4933             end do
4934           end do
4935           call FALFLUXHUCM_Z(ffx_z,VRX,RHOCGS_z,PCGS_z,ZCGS_z,DT,kts,kte,nkr)
4936           do k = kts,kte
4937             krr=0
4938             do kr=p_ff5i01,p_ff5i33
4939               krr=krr+1
4940               chem_new(i,k,j,kr)=ffx_z(k,krr)*rhocgs(i,k,j)
4941             end do
4942           end do
4943  ! ... Hail or Graupel ...
4944           do k = kts,kte
4945             rhocgs_z(k)=rhocgs(i,k,j)
4946             pcgs_z(k)=pcgs(i,k,j)
4947             zcgs_z(k)=zcgs(i,k,j)
4948             if(hail_opt == 1)then
4949               vrx(k,:) = vr5_z3D(:,i,k,j)
4950             else
4951               vrx(k,:) = vr4_z3D(:,i,k,j)
4952             endif
4953             krr=0
4954             do kr=p_ff6i01,p_ff6i33
4955               krr=krr+1
4956               ffx_z(k,krr)=chem_new(i,k,j,kr)/rhocgs(i,k,j)
4957             end do
4958           end do
4959           call FALFLUXHUCM_Z(ffx_z,VRX,RHOCGS_z,PCGS_z,ZCGS_z,DT,kts,kte,nkr)
4960           do k = kts,kte
4961             krr=0
4962             do kr=p_ff6i01,p_ff6i33
4963               krr=krr+1
4964               chem_new(i,k,j,kr)=ffx_z(k,krr)*rhocgs(i,k,j)
4965             end do
4966           end do
4967                         end if ! if (iceprocs == 1)
4968         end do
4969    end do
4970
4971     gmax=0
4972     qmax=0
4973     imax=0
4974     kmax=0
4975     qnmax=0
4976     inmax=0
4977     knmax=0
4978     DO j = jts,jte
4979       DO k = kts,kte
4980         DO i = its,ite
4981           QC(I,K,J) = 0.0
4982           QR(I,K,J) = 0.0
4983           QI(I,K,J) = 0.0
4984           QS(I,K,J) = 0.0
4985           QG(I,K,J) = 0.0
4986           QNC(I,K,J) = 0.0
4987           QNR(I,K,J) = 0.0
4988           QNI(I,K,J) = 0.0
4989           QNS(I,K,J) = 0.0
4990           QNG(I,K,J) = 0.0
4991           QNA(I,K,J) = 0.0
4992
4993           tt = th_phy(i,k,j)*pi_phy(i,k,j)
4994
4995           ! ... Drop output
4996           KRR = 0
4997           DO KR = p_ff1i01,p_ff1i33
4998             KRR=KRR+1
4999             IF (KRR < KRDROP)THEN
5000               QC(I,K,J) = QC(I,K,J) &
5001               + (1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XL(KRR)*XL(KRR)*3
5002               QNC(I,K,J) = QNC(I,K,J) &
5003               + COL*chem_new(I,K,J,KR)*XL(KRR)*3.0/rhocgs(I,K,J)*1000.0 ! #/kg
5004             ELSE
5005               QR(I,K,J) = QR(I,K,J) &
5006               + (1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XL(KRR)*XL(KRR)*3.0
5007               QNR(I,K,J) = QNR(I,K,J) &
5008               + COL*chem_new(I,K,J,KR)*XL(KRR)*3/rhocgs(I,K,J)*1000.0 ! #/kg
5009             END IF
5010           END DO
5011
5012                           KRR=0
5013                           IF (ICEPROCS == 1)THEN
5014                           ! ... Snow output
5015                                 KRR=0
5016                                 DO  KR=p_ff5i01,p_ff5i33
5017                                         KRR=KRR+1
5018                                          if (KRR <= KRICE)THEN
5019                                                  QI(I,K,J) = QI(I,K,J) &
5020                                                          +(1.0/RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XS(KRR)*XS(KRR)*3.0
5021                                                  QNI(I,K,J) = QNI(I,K,J) &
5022                                                                   + COL*chem_new(I,K,J,KR)*XS(KRR)*3.0/rhocgs(I,K,J)*1000.0 ! #/kg
5023                                          else
5024                                                  QS(I,K,J) = QS(I,K,J) &
5025                                                                         + (1.0/RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XS(KRR)*XS(KRR)*3.0
5026                                                  QNS(I,K,J) = QNS(I,K,J) &
5027                                                                         + COL*chem_new(I,K,J,KR)*XS(KRR)*3.0/rhocgs(I,K,J)*1000.0 ! #/kg
5028                                         endif
5029                            END DO
5030
5031                            ! ... Hail / Graupel output
5032           KRR=0
5033           DO  KR=p_ff6i01,p_ff6i33
5034             KRR=KRR+1
5035             ! ... Hail or Graupel
5036             if(hail_opt == 1)then
5037               QG(I,K,J)=QG(I,K,J) &
5038               +(1.0/RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XH(KRR)*XH(KRR)*3.0
5039               QNG(I,K,J)=QNG(I,K,J) &
5040               +COL*chem_new(I,K,J,KR)*XH(KRR)*3.0/rhocgs(I,K,J)*1000.0 ! #/kg
5041             else
5042               QG(I,K,J)=QG(I,K,J) &
5043               +(1.0/RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XG(KRR)*XG(KRR)*3.0
5044               QNG(I,K,J)=QNG(I,K,J) &
5045               +COL*chem_new(I,K,J,KR)*XG(KRR)*3.0/rhocgs(I,K,J)*1000.0 ! #/kg
5046             endif
5047           END DO
5048                 END IF !IF (ICEPROCS.EQ.1)THEN
5049
5050       KRR = 0
5051       DO  KR = p_ff8i01,p_ff8i43
5052         KRR = KRR + 1
5053         QNA(I,K,J) = QNA(I,K,J) &
5054                                 + COL*chem_new(I,K,J,KR)/rhocgs(I,K,J)*1000.0   ! #/kg
5055       END DO
5056
5057                 END DO
5058    END DO
5059   END DO
5060
5061  998   format(' ',10(f10.1,1x))
5062
5063   DO j = jts,jte
5064     DO i = its,ite
5065       RAINNCV(I,J) = 0.0
5066       SNOWNCV(I,J) = 0.0
5067       GRAUPELNCV(I,J) = 0.0
5068       krr=0
5069       DO KR=p_ff1i01,p_ff1i33
5070         krr=krr+1
5071         DELTAW = VR1_Z(KRR,1)
5072         RAINNC(I,J) = RAINNC(I,J) &
5073           +10.0*(3./RO1BL(KRR))*COL*DT*DELTAW* &
5074           chem_new(I,1,J,KR)*XL(KRR)*XL(KRR)
5075         RAINNCV(I,J) = RAINNCV(I,J) &
5076           +10.0*(3./RO1BL(KRR))*COL*DT*DELTAW* &
5077           chem_new(I,1,J,KR)*XL(KRR)*XL(KRR)
5078       END DO
5079       KRR=0
5080       DO KR=p_ff5i01,p_ff5i33
5081         KRR=KRR+1
5082         DELTAW = VR3_Z(KRR,1)
5083         RAINNC(I,J)=RAINNC(I,J) &
5084           +10.0*(3./RO1BL(KRR))*COL*DT*DELTAW* &
5085           chem_new(I,1,J,KR)*XS(KRR)*XS(KRR)
5086         RAINNCV(I,J)=RAINNCV(I,J) &
5087           +10.0*(3./RO1BL(KRR))*COL*DT*DELTAW* &
5088           chem_new(I,1,J,KR)*XS(KRR)*XS(KRR)
5089         SNOWNC(I,J) = SNOWNC(I,J) &
5090         + 10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
5091         chem_new(I,1,J,KR)*XS(KRR)*XS(KRR)
5092        SNOWNCV(I,J) = SNOWNCV(I,J) &
5093        + 10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
5094        chem_new(I,1,J,KR)*XS(KRR)*XS(KRR)
5095      END DO
5096      KRR=0
5097      DO KR=p_ff6i01,p_ff6i33
5098        KRR=KRR+1
5099        if(hail_opt == 1)then
5100          DELTAW = VR5_Z(KRR,1)
5101          RAINNC(I,J) = RAINNC(I,J) &
5102          +10.0*(3./RO1BL(KRR))*COL*DT*DELTAW* &
5103          chem_new(I,1,J,KR)*XH(KRR)*XH(KRR)
5104        RAINNCV(I,J) = RAINNCV(I,J) &
5105          +10.0*(3./RO1BL(KRR))*COL*DT*DELTAW* &
5106          chem_new(I,1,J,KR)*XH(KRR)*XH(KRR)
5107        GRAUPELNC(I,J) = GRAUPELNC(I,J) &
5108        + 10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
5109        chem_new(I,1,J,KR)*XH(KRR)*XH(KRR)
5110      GRAUPELNCV(I,J) = GRAUPELNCV(I,J) &
5111      + 10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
5112      chem_new(I,1,J,KR)*XH(KRR)*XH(KRR)
5113    else
5114      DELTAW = VR4_Z(KRR,1)
5115      RAINNC(I,J) = RAINNC(I,J) &
5116       +10.0*(3./RO1BL(KRR))*COL*DT*DELTAW* &
5117       chem_new(I,1,J,KR)*XG(KRR)*XG(KRR)
5118     RAINNCV(I,J) = RAINNCV(I,J) &
5119       +10.0*(3./RO1BL(KRR))*COL*DT*DELTAW* &
5120       chem_new(I,1,J,KR)*XG(KRR)*XG(KRR)
5121     GRAUPELNC(I,J) = GRAUPELNC(I,J) &
5122       + 10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
5123       chem_new(I,1,J,KR)*XG(KRR)*XG(KRR)
5124     GRAUPELNCV(I,J) = GRAUPELNCV(I,J) &
5125       + 10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
5126       chem_new(I,1,J,KR)*XG(KRR)*XG(KRR)
5127   endif
5128   END DO
5129 ! ..........................................
5130 ! ... Polarimetric Forward Radar Operator
5131 ! ..........................................
5132   if ( PRESENT (diagflag) ) then
5133     if( diagflag .and. IPolar_HUCM .and. (sbm_diagnostics==1) ) then
5134
5135       dx_dbl = dx
5136       dy_dbl = dy
5137       do k = kts,kte
5138       zmks_1d(k) = zcgs(i,k,j)*0.01
5139       end do
5140       DIST_SING = ((i-ide/2)**2+(j-jde/2)**2)**(0.5)
5141       DISTANCE = 1.D5
5142
5143       do k=kts,kte
5144         FF2R_d = 0.0
5145         FLIQFR_SD = 0.0
5146         FLIQFR_GD = 0.0
5147         FLIQFR_HD = 0.0
5148         FF1_FD = 0.0
5149         FL1_FD = 0.0
5150         BKDEN_Snow(:) = RO3BL(:)
5151         RO2BL_D(:,:) = RO2BL(:,:)
5152         RO2BL_D(:,:) = RO2BL(:,:)
5153
5154 ! ... Drops
5155         KRR=0
5156         do kr = p_ff1i01,p_ff1i33
5157           KRR=KRR+1
5158           FF1R_D(KRR) = (1./RHOCGS(I,K,J))*chem_new(I,K,J,KR)*XL(KRR)*XL(KRR)*3.0
5159           if (FF1R_D(KRR) < 1.0D-20) FF1R_D(KRR) = 0.0
5160         end do
5161         if (ICEPROCS == 1)then
5162 ! ... SNOW
5163           KRR=0
5164           do kr=p_ff5i01,p_ff5i33
5165             KRR=KRR+1
5166             FF3R_D(KRR)=(1./RHOCGS(I,K,J))*chem_new(I,K,J,KR)*XS(KRR)*XS(KRR)*3.0
5167             FF3R (KRR) = chem_new(I,K,J,KR)
5168             if (ff3r_D(krr) < 1.0D-20) ff3r_D(krr) = 0.0
5169           end do
5170 ! ... Graupel or Hail
5171           KRR=0
5172           if(hail_opt == 0)then
5173             do kr = p_ff6i01,p_ff6i33
5174               KRR=KRR+1
5175               FF4R_D(KRR) = (1./RHOCGS(I,K,J))*chem_new(I,K,J,KR)*XG(KRR)*XG(KRR)*3.0
5176               FF4R(KRR) = chem_new(I,K,J,KR)
5177               if (FF4R_D(KRR) < 1.0D-20) FF4R_D(KRR)= 0.0
5178               FF5R_d(KRR) = 0.0
5179             end do
5180           else
5181             do kr=p_ff6i01,p_ff6i33
5182               KRR=KRR+1
5183               FF5R_D(KRR)=(1./RHOCGS(I,K,J))*chem_new(I,K,J,KR)*XH(KRR)*XH(KRR)*3.0
5184               FF5R(KRR)=chem_new(I,K,J,KR)
5185               if (ff5r_d(krr) < 1.0D-20) ff5r_d(krr)=0.0
5186               FF4R_d(KRR) = 0.0
5187             end do
5188           endif
5189         ! in caseICEPROCS.EQ.1
5190         end if
5191
5192         rhocgs_d = rhocgs(I,K,J)
5193         T_NEW_D = T_NEW(I,K,J)
5194
5195         IWL = 1
5196         ICLOUD = 0
5197
5198                           CALL polar_hucm &
5199                                                 (FF1R_D, FF2R_D, FF3R_D, FF4R_D, FF5R_D, FF1_FD,                    &
5200                                                 FLIQFR_SD, FLIQFR_GD, FLIQFR_HD, FL1_FD,                                        &
5201                                                 BKDEN_Snow, T_NEW_D, rhocgs_D, wavelength, iwl,         &
5202                                                 distance, dx_dbl, dy_dbl, zmks_1d,                                                  &
5203                                                 out1, out2, out3, out4, out5, out6, out7, out8, out9,   &
5204                                                 bin_mass, tab_colum, tab_dendr, tab_snow, bin_log,                &
5205                                                 ijk, i, j, k, kts, kte, NKR, ICEMAX, icloud, itimestep, &
5206                                                 faf1,fbf1,fab1,fbb1,                                                                        &
5207                                                 faf3,fbf3,fab3,fbb3,                                                            &
5208                                                 faf4,fbf4,fab4,fbb4,                                                            &
5209                                                 faf5,fbf5,fab5,fbb5,                                                            &
5210                                                 temps_water,temps_fd,temps_crystals,      &
5211                                                 temps_snow,temps_graupel,temps_hail,            &
5212                                                 fws_fd,fws_crystals,fws_snow,                                           &
5213                                                 fws_graupel,fws_hail,usetables)
5214
5215
5216                         KRR=0
5217                         DO KR=r_p_ff1i01,r_p_ff1i06
5218                                 KRR=KRR+1
5219                                 sbmradar(I,K,J,KR) = out1(KRR)
5220                         END DO
5221                         KRR=0
5222                         DO KR=r_p_ff2i01,r_p_ff2i06
5223                                 KRR=KRR+1
5224                                 sbmradar(I,K,J,KR)=out2(KRR)
5225                         END DO
5226                         KRR=0
5227                         DO KR=r_p_ff3i01,r_p_ff3i06
5228                                 KRR=KRR+1
5229                                 sbmradar(I,K,J,KR)=out3(KRR)
5230                         END DO
5231                         KRR=0
5232                         DO KR=r_p_ff4i01,r_p_ff4i06
5233                                 KRR=KRR+1
5234                                 sbmradar(I,K,J,KR)=out4(KRR)
5235                         END DO
5236                         KRR=0
5237                         DO KR=r_p_ff5i01,r_p_ff5i06
5238                                 KRR=KRR+1
5239                                 sbmradar(I,K,J,KR)=out5(KRR)
5240                         END DO
5241                         KRR=0
5242                         DO KR=r_p_ff6i01,r_p_ff6i06
5243                                 KRR=KRR+1
5244                                 sbmradar(I,K,J,KR)=out6(KRR)
5245                         END DO
5246                         KRR=0
5247                         DO KR=r_p_ff7i01,r_p_ff7i06
5248                                 KRR=KRR+1
5249                                 sbmradar(I,K,J,KR)=out7(KRR)
5250                         END DO
5251                         KRR=0
5252                         DO KR=r_p_ff8i01,r_p_ff8i06
5253                                 KRR=KRR+1
5254                                 sbmradar(I,K,J,KR)=out8(KRR)
5255                         END DO
5256                         KRR=0
5257                         DO KR=r_p_ff9i01,r_p_ff9i06
5258                                 KRR=KRR+1
5259                                 sbmradar(I,K,J,KR)=out9(KRR)
5260                         END DO
5261
5262                  ! cycle by K
5263                  end do
5264                 ! diagflag .and. IPolar_HUCM
5265                 endif
5266         ! PRESENT(diagflag)
5267         endif
5268
5269    ! cycle by I
5270    END DO
5271  ! cycle by J
5272  END DO
5273
5274    do j=jts,jte
5275    do k=kts,kte
5276    do i=its,ite
5277       th_old(i,k,j)=th_phy(i,k,j)
5278       qv_old(i,k,j)=qv(i,k,j)
5279    end do
5280    end do
5281    end do
5282
5283    if (conserv)then
5284                   DO j = jts,jte
5285                      DO i = its,ite
5286                         DO k = kts,kte
5287                           rhocgs(I,K,J)=rho_phy(I,K,J)*0.001
5288                           krr=0
5289                           DO KR=p_ff1i01,p_ff1i33
5290                                     krr=krr+1
5291                                chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*COL*XL(KRR)*XL(KRR)*3.0
5292                                 if (qc(i,k,j)+qr(i,k,j).lt.1.e-13)chem_new(I,K,J,KR)=0.0
5293                           END DO
5294                           KRR=0
5295                           DO KR=p_ff5i01,p_ff5i33
5296                            KRR=KRR+1
5297                            chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*COL*XS(KRR)*XS(KRR)*3.0
5298                            if (qs(i,k,j).lt.1.e-13)chem_new(I,K,J,KR)=0.0
5299                           END DO
5300                           ! ... CCN
5301                           KRR=0
5302                           DO KR=p_ff8i01,p_ff8i43
5303                            KRR=KRR+1
5304                            chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*1000.0
5305                           END DO
5306               ! ... Hail / Graupel
5307               if(hail_opt == 1)then
5308                  KRR=0
5309                  DO KR=p_ff6i01,p_ff6i33
5310                      KRR=KRR+1
5311                      chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*COL*XH(KRR)*XH(KRR)*3.0
5312                      if (qg(i,k,j) < 1.e-13) chem_new(I,K,J,KR) = 0.0
5313                  END DO
5314                else
5315                  KRR=0
5316                  DO KR=p_ff6i01,p_ff6i33
5317                      KRR=KRR+1
5318                      chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*COL*XG(KRR)*XG(KRR)*3.0
5319                      if (qg(i,k,j) < 1.e-13) chem_new(I,K,J,KR) = 0.0
5320                  END DO
5321                endif
5322
5323                           END DO
5324                          END DO
5325                         END DO
5326        END IF
5327
5328    RETURN
5329    END SUBROUTINE FAST_SBM
5330  ! +-------------------------------------------------------------+
5331    SUBROUTINE FALFLUXHUCM_Z(chem_new,VR1,RHOCGS,PCGS,ZCGS,DT, &
5332                                                                kts,kte,nkr)
5333
5334      IMPLICIT NONE
5335
5336            integer,intent(in) :: kts,kte,nkr
5337            real(kind=r4size),intent(inout) :: chem_new(:,:)
5338            real(kind=r4size),intent(in) :: rhocgs(:),pcgs(:),zcgs(:),VR1(:,:),DT
5339
5340           ! ... Locals
5341           integer :: I,J,K,KR
5342     real(kind=r4size) :: TFALL,DTFALL,VFALL(KTE),DWFLUX(KTE)
5343     integer :: IFALL,N,NSUB
5344
5345  ! FALLING FLUXES FOR EACH KIND OF CLOUD PARTICLES: C.G.S. UNIT
5346  ! ADAPTED FROM GSFC CODE FOR HUCM
5347  !  The flux at k=1 is assumed to be the ground so FLUX(1) is the
5348  ! flux into the ground. DWFLUX(1) is at the lowest half level where
5349  ! Q(1) etc are defined. The formula for FLUX(1) uses Q(1) etc which
5350  ! is actually half a grid level above it. This is what is meant by
5351  ! an upstream method. Upstream in this case is above because the
5352  ! velocity is downwards.
5353  ! USE UPSTREAM METHOD (VFALL IS POSITIVE)
5354
5355        DO KR=1,NKR
5356         IFALL=0
5357         DO k = kts,kte
5358            IF(chem_new(K,KR).GE.1.E-20)IFALL=1
5359         END DO
5360         IF (IFALL.EQ.1)THEN
5361          TFALL=1.E10
5362          DO K=kts,kte
5363           ! [KS] VFALL(K) = VR1(K,KR)*SQRT(1.E6/PCGS(K))
5364                        VFALL(K) = VR1(K,KR) ! ... [KS] : The pressure effect is taken into account at the beggining of the calculations
5365            TFALL=AMIN1(TFALL,ZCGS(K)/(VFALL(K)+1.E-20))
5366          END DO
5367          IF(TFALL.GE.1.E10)STOP
5368          NSUB=(INT(2.0*DT/TFALL)+1)
5369          DTFALL=DT/NSUB
5370
5371          DO N=1,NSUB
5372            DO K=KTS,KTE-1
5373              DWFLUX(K)=-(RHOCGS(K)*VFALL(K)*chem_new(k,kr)- &
5374              RHOCGS(K+1)* &
5375              VFALL(K+1)*chem_new(K+1,KR))/(RHOCGS(K)*(ZCGS(K+1)- &
5376              ZCGS(K)))
5377            END DO
5378  ! NO Z ABOVE TOP, SO USE THE SAME DELTAZ
5379            DWFLUX(KTE)=-(RHOCGS(KTE)*VFALL(KTE)* &
5380       &                 chem_new(kte,kr))/(RHOCGS(KTE)*(ZCGS(KTE)-ZCGS(KTE-1)))
5381            DO K=kts,kte
5382             chem_new(k,kr)=chem_new(k,kr)+DWFLUX(K)*DTFALL
5383            END DO
5384          END DO
5385         END IF
5386        END DO
5387
5388        RETURN
5389        END SUBROUTINE FALFLUXHUCM_Z
5390  ! +----------------------------------+
5391    SUBROUTINE FAST_HUCMINIT(DT)
5392
5393     USE module_mp_SBM_BreakUp,ONLY:Spontanous_Init
5394           USE module_mp_SBM_Collision,ONLY:courant_bott_KS
5395           USE module_domain
5396           USE module_dm
5397
5398           IMPLICIT NONE
5399
5400     real(kind=r4size),intent(in) :: DT
5401
5402     LOGICAL , EXTERNAL      :: wrf_dm_on_monitor
5403     LOGICAL :: opened
5404     CHARACTER*80 errmess
5405     integer :: I,J,KR,IType,HUJISBM_UNIT1
5406     real(kind=r4size) :: dlnr,ax,deg01,CONCCCNIN,CONTCCNIN
5407
5408           character(len=256),parameter :: dir_43 = "SBM_input_43", dir_33 = "SBM_input_33"
5409           character(len=256) :: input_dir,Fname
5410
5411          if(nkr == 33) input_dir = trim(dir_33)
5412          if(nkr == 43) input_dir = trim(dir_43)
5413
5414      call wrf_message(" FAST SBM: INITIALIZING WRF_HUJISBM ")
5415      call wrf_message(" FAST SBM: ****** WRF_HUJISBM ******* ")
5416
5417  ! LookUpTable #1
5418  ! +-------------------------------------------------------+
5419         if (.NOT. ALLOCATED(bin_mass)) ALLOCATE(bin_mass(nkr))
5420         if (.NOT. ALLOCATED(tab_colum)) ALLOCATE(tab_colum(nkr))
5421         if (.NOT. ALLOCATED(tab_dendr)) ALLOCATE(tab_dendr(nkr))
5422         if (.NOT. ALLOCATED(tab_snow)) ALLOCATE(tab_snow(nkr))
5423         if (.NOT. ALLOCATED(bin_log)) ALLOCATE(bin_log(nkr))
5424
5425         dlnr=dlog(2.d0)/(3.d0)
5426
5427         hujisbm_unit1 = -1
5428         IF ( wrf_dm_on_monitor() ) THEN
5429                 DO i = 20,99
5430                         INQUIRE ( i , OPENED = opened )
5431                         IF ( .NOT. opened ) THEN
5432                                 hujisbm_unit1 = i
5433                                 GOTO 2060
5434                         ENDIF
5435                 ENDDO
5436         2060  CONTINUE
5437         ENDIF
5438
5439 #if (defined(DM_PARALLEL))
5440                 CALL wrf_dm_bcast_bytes( hujisbm_unit1 , IWORDSIZE )
5441 #endif
5442         IF ( hujisbm_unit1 < 0 ) THEN
5443         CALL wrf_error_fatal ( 'module_mp_FAST-SBM: Table-1 -- FAST_SBM_INIT: '//                       &
5444                                                                       'Can not find unused fortran unit to read in lookup table, model stop' )
5445         ENDIF
5446
5447         IF ( wrf_dm_on_monitor() ) THEN
5448                         WRITE(errmess, '(A,I2)') 'module_mp_FAST-SBM : Table-1 -- opening "BLKD_SDC.dat" on unit',hujisbm_unit1
5449                         CALL wrf_debug(150, errmess)
5450                         OPEN(UNIT=hujisbm_unit1,FILE=trim(input_dir)//"/BLKD_SDC.dat",FORM="FORMATTED",STATUS="OLD",ERR=2070)
5451                         DO kr=1,NKR
5452                                 READ(hujisbm_unit1,*) bin_mass(kr),tab_colum(kr),tab_dendr(kr),tab_snow(kr)
5453                                 bin_log(kr) = log10(bin_mass(kr))
5454                         ENDDO
5455         ENDIF
5456
5457 #define DM_BCAST_MACRO_R4(A) CALL wrf_dm_bcast_bytes(A, size(A)*R4SIZE)
5458 #define DM_BCAST_MACRO_R8(A) CALL wrf_dm_bcast_bytes(A, size(A)*R8SIZE)
5459 #define DM_BCAST_MACRO_R16(A) CALL wrf_dm_bcast_bytes(A, size(A)*R16SIZE)
5460
5461 #if (defined(DM_PARALLEL))
5462     DM_BCAST_MACRO_R8(bin_mass)
5463           DM_BCAST_MACRO_R8(tab_colum)
5464           DM_BCAST_MACRO_R8(tab_dendr)
5465           DM_BCAST_MACRO_R8(tab_snow)
5466           DM_BCAST_MACRO_R8(bin_log)
5467 #endif
5468
5469      WRITE(errmess, '(A,I2)') 'FAST_SBM_INIT : succesfull reading Table-1'
5470      CALL wrf_debug(000, errmess)
5471  ! +-----------------------------------------------------------------------+
5472
5473  ! LookUpTable #2
5474  ! +----------------------------------------------+
5475      if (.NOT. ALLOCATED(RLEC)) ALLOCATE(RLEC(nkr))
5476      if (.NOT. ALLOCATED(RIEC)) ALLOCATE(RIEC(nkr,icemax))
5477      if (.NOT. ALLOCATED(RSEC)) ALLOCATE(RSEC(nkr))
5478      if (.NOT. ALLOCATED(RGEC)) ALLOCATE(RGEC(nkr))
5479      if (.NOT. ALLOCATED(RHEC)) ALLOCATE(RHEC(nkr))
5480
5481      hujisbm_unit1 = -1
5482      IF ( wrf_dm_on_monitor() ) THEN
5483          DO i = 31,99
5484              INQUIRE ( i , OPENED = opened )
5485              IF ( .NOT. opened ) THEN
5486                  hujisbm_unit1 = i
5487                  GOTO 2061
5488              ENDIF
5489          ENDDO
5490      2061  CONTINUE
5491      ENDIF
5492
5493 #if (defined(DM_PARALLEL))
5494         CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
5495 #endif
5496      IF ( hujisbm_unit1 < 0 ) THEN
5497          CALL wrf_error_fatal ( 'module_mp_FAST-SBM: Table-2 -- FAST_SBM_INIT: '//                      &
5498                                'Can not find unused fortran unit to read in lookup table,model stop' )
5499      ENDIF
5500
5501  IF ( wrf_dm_on_monitor() ) THEN
5502         WRITE(errmess, '(A,I2)') 'module_mp_FAST-SBM : Table-2 -- opening capacity.asc on unit',hujisbm_unit1
5503         CALL wrf_debug(150, errmess)
5504         OPEN(UNIT=hujisbm_unit1,FILE=trim(input_dir)//"/capacity33.asc",FORM="FORMATTED",STATUS="OLD",ERR=2070)
5505         !OPEN(UNIT=hujisbm_unit1,FILE=trim(input_dir)//"/capacity43.asc",FORM="FORMATTED",STATUS="OLD",ERR=2070)
5506         900     FORMAT(6E13.5)
5507         READ(hujisbm_unit1,900) RLEC,RIEC,RSEC,RGEC,RHEC
5508  END IF
5509
5510 #if (defined(DM_PARALLEL))
5511      DM_BCAST_MACRO_R4(RLEC)
5512      DM_BCAST_MACRO_R4(RIEC)
5513      DM_BCAST_MACRO_R4(RSEC)
5514      DM_BCAST_MACRO_R4(RGEC)
5515      DM_BCAST_MACRO_R4(RHEC)
5516 #endif
5517
5518      WRITE(errmess, '(A,I2)') 'FAST_SBM_INIT : succesfull reading Table-2'
5519      CALL wrf_debug(000, errmess)
5520  ! +----------------------------------------------------------------------+
5521
5522  ! LookUpTable #3
5523  ! +-----------------------------------------------+
5524      if (.NOT. ALLOCATED(XL)) ALLOCATE(XL(nkr))
5525      if (.NOT. ALLOCATED(XI)) ALLOCATE(XI(nkr,icemax))
5526      if (.NOT. ALLOCATED(XS)) ALLOCATE(XS(nkr))
5527      if (.NOT. ALLOCATED(XG)) ALLOCATE(XG(nkr))
5528      if (.NOT. ALLOCATED(XH)) ALLOCATE(XH(nkr))
5529
5530      hujisbm_unit1 = -1
5531      IF ( wrf_dm_on_monitor() ) THEN
5532        DO i = 31,99
5533          INQUIRE ( i , OPENED = opened )
5534          IF ( .NOT. opened ) THEN
5535            hujisbm_unit1 = i
5536            GOTO 2062
5537          ENDIF
5538        ENDDO
5539      2062 CONTINUE
5540      ENDIF
5541
5542 #if (defined(DM_PARALLEL))
5543      CALL wrf_dm_bcast_bytes ( hujisbm_unit1, IWORDSIZE )
5544 #endif
5545
5546      IF ( hujisbm_unit1 < 0 ) THEN
5547          CALL wrf_error_fatal ( 'module_mp_FAST_SBM: Table-3 -- FAST_SBM_INIT: '//              &
5548                               'Can not find unused fortran unit to read in lookup table,model stop' )
5549      ENDIF
5550      IF ( wrf_dm_on_monitor() ) THEN
5551          WRITE(errmess, '(A,I2)') 'module_mp_FAST_SBM : Table-3 -- opening masses.asc on unit ',hujisbm_unit1
5552          CALL wrf_debug(150, errmess)
5553          OPEN(UNIT=hujisbm_unit1,FILE=trim(input_dir)//"/masses33.asc",FORM="FORMATTED",STATUS="OLD",ERR=2070)
5554          !OPEN(UNIT=hujisbm_unit1,FILE=trim(input_dir)//"/masses43.asc",FORM="FORMATTED",STATUS="OLD",ERR=2070)
5555          READ(hujisbm_unit1,900) XL,XI,XS,XG,XH
5556          CLOSE(hujisbm_unit1)
5557      ENDIF
5558
5559 #if (defined(DM_PARALLEL))
5560         DM_BCAST_MACRO_R4(XL)
5561      DM_BCAST_MACRO_R4(XI)
5562      DM_BCAST_MACRO_R4(XS)
5563      DM_BCAST_MACRO_R4(XG)
5564      DM_BCAST_MACRO_R4(XH)
5565 #endif
5566
5567       WRITE(errmess, '(A,I2)') 'FAST_SBM_INIT : succesfull reading Table-3'
5568       CALL wrf_debug(000, errmess)
5569  ! +-------------------------------------------------------------------------+
5570
5571  ! LookUpTable #4
5572  ! TERMINAL VELOSITY :
5573  ! +---------------------------------------------------+
5574      if (.NOT. ALLOCATED(VR1)) ALLOCATE(VR1(nkr))
5575      if (.NOT. ALLOCATED(VR2)) ALLOCATE(VR2(nkr,icemax))
5576      if (.NOT. ALLOCATED(VR3)) ALLOCATE(VR3(nkr))
5577      if (.NOT. ALLOCATED(VR4)) ALLOCATE(VR4(nkr))
5578      if (.NOT. ALLOCATED(VR5)) ALLOCATE(VR5(nkr))
5579
5580      hujisbm_unit1 = -1
5581      IF ( wrf_dm_on_monitor() ) THEN
5582        DO i = 31,99
5583          INQUIRE ( i , OPENED = opened )
5584          IF ( .NOT. opened ) THEN
5585            hujisbm_unit1 = i
5586            GOTO 2063
5587          ENDIF
5588        ENDDO
5589      2063   CONTINUE
5590      ENDIF
5591
5592 #if (defined(DM_PARALLEL))
5593      CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
5594 #endif
5595      IF ( hujisbm_unit1 < 0 ) THEN
5596          CALL wrf_error_fatal ( 'module_mp_FAST_SBM: Table-4 -- FAST_SBM_INIT: '//                                                                              &
5597                                  'Can not find unused fortran unit to read in lookup table,model stop' )
5598      ENDIF
5599
5600      IF ( wrf_dm_on_monitor() ) THEN
5601          WRITE(errmess, '(A,I2)') 'module_mp_FAST_SBM : Table-4 -- opening termvels.asc on unit ',hujisbm_unit1
5602          CALL wrf_debug(150, errmess)
5603          OPEN(UNIT=hujisbm_unit1,FILE=trim(input_dir)//"/termvels33_corrected.asc",FORM="FORMATTED",STATUS="OLD",ERR=2070)
5604          !OPEN(UNIT=hujisbm_unit1,FILE=trim(input_dir)//"/termvels43_corrected.asc",FORM="FORMATTED",STATUS="OLD",ERR=2070)
5605          READ(hujisbm_unit1,900) VR1,VR2,VR3,VR4,VR5
5606         CLOSE(hujisbm_unit1)
5607      ENDIF
5608
5609 #if (defined(DM_PARALLEL))
5610         DM_BCAST_MACRO_R4(VR1)
5611      DM_BCAST_MACRO_R4(VR2)
5612      DM_BCAST_MACRO_R4(VR3)
5613      DM_BCAST_MACRO_R4(VR4)
5614      DM_BCAST_MACRO_R4(VR5)
5615 #endif
5616      WRITE(errmess, '(A,I2)') 'FAST_SBM_INIT : succesfull reading Table-4'
5617      CALL wrf_debug(000, errmess)
5618  ! +----------------------------------------------------------------------+
5619
5620
5621  ! LookUpTable #5
5622  ! CONSTANTS :
5623  ! +---------------------------------------------------+
5624      if (.NOT. ALLOCATED(SLIC)) ALLOCATE(SLIC(nkr,6))
5625      if (.NOT. ALLOCATED(TLIC)) ALLOCATE(TLIC(nkr,2))
5626      if (.NOT. ALLOCATED(COEFIN)) ALLOCATE(COEFIN(nkr))
5627
5628      hujisbm_unit1 = -1
5629      IF ( wrf_dm_on_monitor() ) THEN
5630        DO i = 31,99
5631          INQUIRE ( i , OPENED = opened )
5632          IF ( .NOT. opened ) THEN
5633            hujisbm_unit1 = i
5634            GOTO 2065
5635          ENDIF
5636        ENDDO
5637        hujisbm_unit1 = -1
5638      2065     CONTINUE
5639      ENDIF
5640
5641 #if (defined(DM_PARALLEL))
5642                 CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
5643 #endif
5644
5645      IF ( hujisbm_unit1 < 0 ) THEN
5646          CALL wrf_error_fatal ( 'module_mp_FAST_SBM: Table-5 -- FAST_SBM_INIT: '//                                                                              &
5647                                 'Can not find unused fortran unit to read in lookup table,model stop' )
5648      ENDIF
5649
5650      IF ( wrf_dm_on_monitor() ) THEN
5651          WRITE(errmess, '(A,I2)') 'module_mp_FAST_SBM : Table-5 -- opening constants.asc on unit  ',hujisbm_unit1
5652          CALL wrf_debug(150, errmess)
5653          OPEN(UNIT=hujisbm_unit1,FILE=trim(input_dir)//"/constants33.asc",FORM="FORMATTED",STATUS="OLD",ERR=2070)
5654          !OPEN(UNIT=hujisbm_unit1,FILE=trim(input_dir)//"/constants43.asc",FORM="FORMATTED",STATUS="OLD",ERR=2070)
5655          READ(hujisbm_unit1,900) SLIC,TLIC,COEFIN
5656       CLOSE(hujisbm_unit1)
5657      END IF
5658
5659 #if (defined(DM_PARALLEL))
5660           DM_BCAST_MACRO_R4(SLIC)
5661     DM_BCAST_MACRO_R4(TLIC)
5662     DM_BCAST_MACRO_R4(COEFIN)
5663 #endif
5664      WRITE(errmess, '(A,I2)') 'FAST_SBM_INIT : succesfull reading Table-5'
5665      CALL wrf_debug(000, errmess)
5666  ! +----------------------------------------------------------------------+
5667
5668  ! LookUpTable #6
5669  ! KERNELS DEPENDING ON PRESSURE :
5670  ! +------------------------------------------------------------------+
5671      if (.NOT. ALLOCATED(YWLL_1000MB)) ALLOCATE(YWLL_1000MB(nkr,nkr))
5672      if (.NOT. ALLOCATED(YWLL_750MB)) ALLOCATE(YWLL_750MB(nkr,nkr))
5673      if (.NOT. ALLOCATED(YWLL_500MB)) ALLOCATE(YWLL_500MB(nkr,nkr))
5674
5675      hujisbm_unit1 = -1
5676      IF ( wrf_dm_on_monitor() ) THEN
5677        DO i = 31,99
5678          INQUIRE ( i , OPENED = opened )
5679          IF ( .NOT. opened ) THEN
5680            hujisbm_unit1 = i
5681            GOTO 2066
5682          ENDIF
5683        ENDDO
5684        hujisbm_unit1 = -1
5685      2066     CONTINUE
5686      ENDIF
5687
5688 #if (defined(DM_PARALLEL))
5689                 CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
5690 #endif
5691      IF ( hujisbm_unit1 < 0 ) THEN
5692          CALL wrf_error_fatal ( 'module_mp_FAST_SBM: Table-6 -- FAST_SBM_INIT: '//                      &
5693                                  'Can not find unused fortran unit to read in lookup table,model stop' )
5694      ENDIF
5695      IF ( wrf_dm_on_monitor() ) THEN
5696          WRITE(errmess, '(A,I2)') 'module_mp_FAST_SBM : Table-6 -- opening kernels_z.asc on unit  ',hujisbm_unit1
5697          CALL wrf_debug(150, errmess)
5698          Fname = trim(input_dir)//'/kernLL_z33.asc'
5699          !Fname = trim(input_dir)//'/kernLL_z43.asc'
5700          OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070)
5701          READ(hujisbm_unit1,900) YWLL_1000MB,YWLL_750MB,YWLL_500MB
5702          CLOSE(hujisbm_unit1)
5703      END IF
5704
5705         DO I=1,NKR
5706                 DO J=1,NKR
5707                         IF(I > 33 .OR. J > 33) THEN
5708                                 YWLL_1000MB(I,J) = 0.0
5709                                 YWLL_750MB(I,J) =  0.0
5710                                 YWLL_500MB(I,J) =  0.0
5711                         ENDIF
5712                 ENDDO
5713         ENDDO
5714
5715 #if (defined(DM_PARALLEL))
5716         DM_BCAST_MACRO_R4(YWLL_1000MB)
5717      DM_BCAST_MACRO_R4(YWLL_750MB)
5718      DM_BCAST_MACRO_R4(YWLL_500MB)
5719 #endif
5720
5721      WRITE(errmess, '(A,I2)') 'FAST_SBM_INIT : succesfull reading Table-6'
5722      CALL wrf_debug(000, errmess)
5723  ! +-----------------------------------------------------------------------+
5724
5725  ! LookUpTable #7
5726  ! COLLISIONS KERNELS :
5727  ! +-----------------------------------------------------------------------+
5728  ! ... Drops - IC
5729  if (.NOT. ALLOCATED(YWLI_300MB)) ALLOCATE(YWLI_300MB(nkr,nkr,icemax))
5730  if (.NOT. ALLOCATED(YWLI_500MB)) ALLOCATE(YWLI_500MB(nkr,nkr,icemax))
5731  if (.NOT. ALLOCATED(YWLI_750MB)) ALLOCATE(YWLI_750MB(nkr,nkr,icemax))
5732
5733  ! ... Drops - Graupel
5734  if (.NOT. ALLOCATED(YWLG_300MB)) ALLOCATE(YWLG_300MB(nkr,nkr))
5735  if (.NOT. ALLOCATED(YWLG_500MB)) ALLOCATE(YWLG_500MB(nkr,nkr))
5736  if (.NOT. ALLOCATED(YWLG_750MB)) ALLOCATE(YWLG_750MB(nkr,nkr))
5737  !if (.NOT. ALLOCATED(YWLG)) ALLOCATE(YWLG(nkr,nkr))
5738
5739  ! ... Drops - Hail
5740  if (.NOT. ALLOCATED(YWLH_300MB)) ALLOCATE(YWLH_300MB(nkr,nkr))
5741  if (.NOT. ALLOCATED(YWLH_500MB)) ALLOCATE(YWLH_500MB(nkr,nkr))
5742  if (.NOT. ALLOCATED(YWLH_750MB)) ALLOCATE(YWLH_750MB(nkr,nkr))
5743
5744  ! ... Drops - Snow
5745  if (.NOT. ALLOCATED(YWLS_300MB)) ALLOCATE(YWLS_300MB(nkr,nkr))
5746  if (.NOT. ALLOCATED(YWLS_500MB)) ALLOCATE(YWLS_500MB(nkr,nkr))
5747  if (.NOT. ALLOCATED(YWLS_750MB)) ALLOCATE(YWLS_750MB(nkr,nkr))
5748
5749  ! ... IC - IC
5750  if (.NOT. ALLOCATED(YWII_300MB)) ALLOCATE(YWII_300MB(nkr,nkr,icemax,icemax))
5751  if (.NOT. ALLOCATED(YWII_500MB)) ALLOCATE(YWII_500MB(nkr,nkr,icemax,icemax))
5752  if (.NOT. ALLOCATED(YWII_750MB)) ALLOCATE(YWII_750MB(nkr,nkr,icemax,icemax))
5753
5754  ! ... IC - SNow
5755  if (.NOT. ALLOCATED(YWIS_300MB)) ALLOCATE(YWIS_300MB(nkr,nkr,icemax))
5756  if (.NOT. ALLOCATED(YWIS_500MB)) ALLOCATE(YWIS_500MB(nkr,nkr,icemax))
5757  if (.NOT. ALLOCATED(YWIS_750MB)) ALLOCATE(YWIS_750MB(nkr,nkr,icemax))
5758
5759  ! ... Snow - Graupel
5760  if (.NOT. ALLOCATED(YWSG_300MB)) ALLOCATE(YWSG_300MB(nkr,nkr))
5761  if (.NOT. ALLOCATED(YWSG_500MB)) ALLOCATE(YWSG_500MB(nkr,nkr))
5762  if (.NOT. ALLOCATED(YWSG_750MB)) ALLOCATE(YWSG_750MB(nkr,nkr))
5763
5764  ! ... Snow - SNow
5765  if (.NOT. ALLOCATED(YWSS_300MB)) ALLOCATE(YWSS_300MB(nkr,nkr))
5766  if (.NOT. ALLOCATED(YWSS_500MB)) ALLOCATE(YWSS_500MB(nkr,nkR))
5767  if (.NOT. ALLOCATED(YWSS_750MB)) ALLOCATE(YWSS_750MB(nkr,nkr))
5768
5769      hujisbm_unit1 = -1
5770      IF ( wrf_dm_on_monitor() ) THEN
5771      DO i = 31,99
5772      INQUIRE ( i , OPENED = opened )
5773      IF ( .NOT. opened ) THEN
5774        hujisbm_unit1 = i
5775        GOTO 2067
5776      ENDIF
5777      ENDDO
5778      2067     CONTINUE
5779      ENDIF
5780
5781 #if (defined(DM_PARALLEL))
5782      CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
5783 #endif
5784  IF ( hujisbm_unit1 < 0 ) THEN
5785         CALL wrf_error_fatal ( 'module_mp_FAST_SBM: Table-7 -- FAST_SBM_INIT: '//                       &
5786                                                                                         'Can not find unused fortran unit to read in lookup table,model stop' )
5787  ENDIF
5788  ! ... KERNELS DEPENDING ON PRESSURE :
5789  IF ( wrf_dm_on_monitor() ) THEN
5790         WRITE(errmess, '(A,I2)') 'module_mp_WRFsbm : Table-7 -- opening kernels33.asc on unit',hujisbm_unit1
5791         CALL wrf_debug(150, errmess)
5792
5793         ! ... Drop - IC
5794         !Fname = trim(input_dir)//'/ckli_300mb_As'
5795         !OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070)
5796         !READ(hujisbm_unit1,900) YWLI_300MB
5797         !Fname = trim(input_dir)//'/ckli_500mb_As'
5798         !OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070)
5799         !READ(hujisbm_unit1,900) YWLI_500MB
5800         !Fname = trim(input_dir)//'/ckli_750mb_As'
5801         !OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070)
5802         !READ(hujisbm_unit1,900) YWLI_750MB
5803
5804         Fname = trim(input_dir)//'/ckli_33_300mb_500mb_750mb.asc'
5805         OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070)
5806         READ(hujisbm_unit1,900) YWLI_300MB,YWLI_500MB,YWLI_750MB
5807         CLOSE(hujisbm_unit1)
5808
5809         ! ... Drop - Graupel
5810         !Fname = trim(input_dir)//'/cklg_300mb_As'
5811         !OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070)
5812         !READ(hujisbm_unit1,900) YWLG_300MB
5813         !Fname = trim(input_dir)//'/cklg_500mb_As'
5814         !OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070)
5815         !READ(hujisbm_unit1,900) YWLG_500MB
5816         !Fname = trim(input_dir)//'/cklg_750mb_As'
5817         !OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070)
5818         !READ(hujisbm_unit1,900) YWLG_750MB
5819
5820         Fname = trim(input_dir)//'/cklg_33_300mb_500mb_750mb.asc'
5821         OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070)
5822         READ(hujisbm_unit1,900) YWLG_300MB,YWLG_500MB,YWLG_750MB
5823         CLOSE(hujisbm_unit1)
5824
5825         ! ... Drop - Hail
5826         !Fname = trim(input_dir)//'/cklh_300mb_As'
5827         !OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070)
5828         !READ(hujisbm_unit1,900) YWLH_300MB
5829         !Fname = trim(input_dir)//'/cklh_500mb_As'
5830         !OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070)
5831         !READ(hujisbm_unit1,900) YWLH_500MB
5832         !Fname = trim(input_dir)//'/cklh_750mb_As'
5833         !OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070)
5834         !READ(hujisbm_unit1,900) YWLH_750MB
5835
5836         Fname = trim(input_dir)//'/cklh_33_300mb_500mb_750mb.asc'
5837         OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070)
5838         READ(hujisbm_unit1,900) YWLH_300MB,YWLH_500MB,YWLH_750MB
5839         CLOSE(hujisbm_unit1)
5840
5841         ! ... Drop - Snow
5842         !Fname = trim(input_dir)//'/ckls_300mb_As'
5843         !OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070)
5844         !READ(hujisbm_unit1,900) YWLS_300MB
5845         !Fname = trim(input_dir)//'/ckls_500mb_As'
5846         !OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070)
5847         !READ(hujisbm_unit1,900) YWLS_500MB
5848         !Fname = trim(input_dir)//'/ckls_750mb_As'
5849         !OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070)
5850         !READ(hujisbm_unit1,900) YWLS_750MB
5851
5852         Fname = trim(input_dir)//'/ckls_33_300mb_500mb_750mb.asc'
5853         OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070)
5854         READ(hujisbm_unit1,900) YWLS_300MB,YWLS_500MB,YWLS_750MB
5855         CLOSE(hujisbm_unit1)
5856
5857         ! ... IC - IC
5858   !Fname = trim(input_dir)//'/ckii_300mb_As'
5859         !OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070)
5860         !READ(hujisbm_unit1,900) YWII_300MB
5861         !Fname = trim(input_dir)//'/ckii_500mb_As'
5862         !OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070)
5863         !READ(hujisbm_unit1,900) YWII_500MB
5864         !Fname = trim(input_dir)//'/ckii_750mb_As'
5865         !OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070)
5866         !READ(hujisbm_unit1,900) YWII_750MB
5867         !CLOSE(hujisbm_unit1)
5868
5869         Fname = trim(input_dir)//'/ckii_33_300mb_500mb_750mb.asc'
5870         OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070)
5871         READ(hujisbm_unit1,900) YWII_300MB,YWII_500MB,YWII_750MB
5872         CLOSE(hujisbm_unit1)
5873
5874         ! ... IC - SNow
5875         !Fname = trim(input_dir)//'/ckis_300mb_As'
5876         !OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070)
5877         !READ(hujisbm_unit1,900) YWIS_300MB
5878         !Fname = trim(input_dir)//'/ckis_500mb_As'
5879         !OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070)
5880         !READ(hujisbm_unit1,900) YWIS_500MB
5881         !Fname = trim(input_dir)//'/ckis_750mb_As'
5882         !OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070)
5883         !READ(hujisbm_unit1,900) YWIS_750MB
5884
5885         Fname = trim(input_dir)//'/ckis_33_300mb_500mb_750mb.asc'
5886         OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070)
5887         READ(hujisbm_unit1,900) YWIS_300MB,YWIS_500MB,YWIS_750MB
5888         CLOSE(hujisbm_unit1)
5889
5890         ! ... Snow - Graupel
5891         !Fname = trim(input_dir)//'/cksg_300mb_As'
5892         !OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070)
5893         !READ(hujisbm_unit1,900) YWSG_300MB
5894         !Fname = trim(input_dir)//'/cksg_500mb_As'
5895         !OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070)
5896         !READ(hujisbm_unit1,900) YWSG_500MB
5897         !Fname = trim(input_dir)//'/cksg_750mb_As'
5898         !OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070)
5899         !READ(hujisbm_unit1,900) YWSG_750MB
5900
5901         Fname = trim(input_dir)//'/cksg_33_300mb_500mb_750mb.asc'
5902         OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070)
5903         READ(hujisbm_unit1,900) YWSG_300MB,YWSG_500MB,YWSG_750MB
5904         CLOSE(hujisbm_unit1)
5905
5906         ! ... Snow - Snow
5907         !Fname = trim(input_dir)//'/ckss_300mb_As'
5908         !OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070)
5909         !READ(hujisbm_unit1,900) YWSS_300MB
5910         !Fname = trim(input_dir)//'/ckss_500mb_As'
5911         !OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070)
5912         !READ(hujisbm_unit1,900) YWSS_500MB
5913         !Fname = trim(input_dir)//'/ckss_750mb_As'
5914         !OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070)
5915         !READ(hujisbm_unit1,900) YWSS_750MB
5916
5917         Fname = trim(input_dir)//'/ckss_33_300mb_500mb_750mb.asc'
5918         OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070)
5919         READ(hujisbm_unit1,900) YWSS_300MB,YWSS_500MB,YWSS_750MB
5920   CLOSE(hujisbm_unit1)
5921  END IF
5922
5923 #if (defined(DM_PARALLEL))
5924            DM_BCAST_MACRO_R4(YWLI_300MB)
5925      DM_BCAST_MACRO_R4(YWLI_500MB)
5926      DM_BCAST_MACRO_R4(YWLI_750MB)
5927
5928      DM_BCAST_MACRO_R4(YWLG_300MB)
5929      DM_BCAST_MACRO_R4(YWLG_500MB)
5930      DM_BCAST_MACRO_R4(YWLG_750MB)
5931      !DM_BCAST_MACRO(YWLG)
5932
5933      DM_BCAST_MACRO_R4(YWLH_300MB)
5934      DM_BCAST_MACRO_R4(YWLH_500MB)
5935      DM_BCAST_MACRO_R4(YWLH_750MB)
5936
5937      DM_BCAST_MACRO_R4(YWLS_300MB)
5938      DM_BCAST_MACRO_R4(YWLS_500MB)
5939      DM_BCAST_MACRO_R4(YWLS_750MB)
5940
5941      DM_BCAST_MACRO_R4(YWII_300MB)
5942      DM_BCAST_MACRO_R4(YWII_500MB)
5943      DM_BCAST_MACRO_R4(YWII_750MB)
5944
5945      DM_BCAST_MACRO_R4(YWIS_300MB)
5946      DM_BCAST_MACRO_R4(YWIS_500MB)
5947      DM_BCAST_MACRO_R4(YWIS_750MB)
5948
5949      DM_BCAST_MACRO_R4(YWSG_300MB)
5950      DM_BCAST_MACRO_R4(YWSG_500MB)
5951      DM_BCAST_MACRO_R4(YWSG_750MB)
5952
5953      DM_BCAST_MACRO_R4(YWSS_300MB)
5954      DM_BCAST_MACRO_R4(YWSS_500MB)
5955      DM_BCAST_MACRO_R4(YWSS_750MB)
5956 #endif
5957
5958      WRITE(errmess, '(A,I2)') 'FAST_SBM_INIT : succesfull reading Table-7'
5959      CALL wrf_debug(000, errmess)
5960  ! +-----------------------------------------------------------------------+
5961
5962  ! LookUpTable #8
5963  ! BULKDENSITY:
5964  ! +--------------------------------------------------------------+
5965      if (.NOT. ALLOCATED(RO1BL)) ALLOCATE(RO1BL(nkr))
5966      if (.NOT. ALLOCATED(RO2BL)) ALLOCATE(RO2BL(nkr,icemax))
5967      if (.NOT. ALLOCATED(RO3BL)) ALLOCATE(RO3BL(nkr))
5968      if (.NOT. ALLOCATED(RO4BL)) ALLOCATE(RO4BL(nkr))
5969      if (.NOT. ALLOCATED(RO5BL)) ALLOCATE(RO5BL(nkr))
5970
5971      hujisbm_unit1 = -1
5972      IF ( wrf_dm_on_monitor() ) THEN
5973        DO i = 31,99
5974          INQUIRE ( i , OPENED = opened )
5975          IF ( .NOT. opened ) THEN
5976            hujisbm_unit1 = i
5977            GOTO 2068
5978          ENDIF
5979        ENDDO
5980      2068     CONTINUE
5981      ENDIF
5982
5983 #if (defined(DM_PARALLEL))
5984      CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
5985 #endif
5986      IF ( hujisbm_unit1 < 0 ) THEN
5987          CALL wrf_error_fatal ( 'module_mp_FAST_SBM: Table-8 -- FAST_SBM_INIT: '//                      &
5988                                  'Can not find unused fortran unit to read in lookup table,model stop' )
5989      ENDIF
5990      IF ( wrf_dm_on_monitor() ) THEN
5991          WRITE(errmess, '(A,I2)') 'module_mp_WRFsbm : Table-8 -- opening bulkdens.asc on unit ',hujisbm_unit1
5992          CALL wrf_debug(150, errmess)
5993          OPEN(UNIT=hujisbm_unit1,FILE=trim(input_dir)//"/bulkdens33.asc",FORM="FORMATTED",STATUS="OLD",ERR=2070)
5994          !OPEN(UNIT=hujisbm_unit1,FILE=trim(input_dir)//"/bulkdens43.asc",FORM="FORMATTED",STATUS="OLD",ERR=2070)
5995          READ(hujisbm_unit1,900) RO1BL,RO2BL,RO3BL,RO4BL,RO5BL
5996          CLOSE(hujisbm_unit1)
5997      END IF
5998
5999 #if (defined(DM_PARALLEL))
6000             DM_BCAST_MACRO_R4(RO1BL)
6001       DM_BCAST_MACRO_R4(RO2BL)
6002       DM_BCAST_MACRO_R4(RO3BL)
6003       DM_BCAST_MACRO_R4(RO4BL)
6004       DM_BCAST_MACRO_R4(RO5BL)
6005 #endif
6006      WRITE(errmess, '(A,I2)') 'FAST_SBM_INIT : succesfull reading Table-8'
6007      CALL wrf_debug(000, errmess)
6008  ! +----------------------------------------------------------------------+
6009
6010  ! LookUpTable #9
6011  ! BULKRADII:
6012  ! +-----------------------------------------------------------+
6013      if (.NOT. ALLOCATED(RADXXO)) ALLOCATE(RADXXO(nkr,nhydro))
6014      hujisbm_unit1 = -1
6015      IF ( wrf_dm_on_monitor() ) THEN
6016        DO i = 31,99
6017          INQUIRE ( i , OPENED = opened )
6018          IF ( .NOT. opened ) THEN
6019            hujisbm_unit1 = i
6020            GOTO 2069
6021          ENDIF
6022        ENDDO
6023      2069     CONTINUE
6024      ENDIF
6025 #if (defined(DM_PARALLEL))
6026                 CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
6027 #endif
6028      IF ( hujisbm_unit1 < 0 ) THEN
6029       CALL wrf_error_fatal ( 'module_mp_FAST_SBM: Table-9 -- FAST_SBM_INIT: '//                         &
6030                                  'Can not find unused fortran unit to read in lookup table,model stop' )
6031      ENDIF
6032      IF ( wrf_dm_on_monitor() ) THEN
6033          WRITE(errmess, '(A,I2)') 'module_mp_FAST_SBM : Table-9 -- opening bulkradii.asc on unit',hujisbm_unit1
6034          CALL wrf_debug(150, errmess)
6035          OPEN(UNIT=hujisbm_unit1,FILE=trim(input_dir)//"/bulkradii33.asc",FORM="FORMATTED",STATUS="OLD",ERR=2070)
6036          !OPEN(UNIT=hujisbm_unit1,FILE=trim(input_dir)//"/bulkradii43.asc",FORM="FORMATTED",STATUS="OLD",ERR=2070)
6037          READ(hujisbm_unit1,*) RADXXO
6038          CLOSE(hujisbm_unit1)
6039      END IF
6040
6041 #if (defined(DM_PARALLEL))
6042        DM_BCAST_MACRO_R4(RADXXO)
6043 #endif
6044      WRITE(errmess, '(A,I2)') 'FAST_SBM_INIT : succesfull reading Table-9'
6045      CALL wrf_debug(000, errmess)
6046  ! +-----------------------------------------------------------------------+
6047
6048  ! LookUpTable #10
6049  ! Polar-HUCM Scattering Amplitudes Look-up table :
6050  ! +-----------------------------------------------------------------------+
6051   CALL LOAD_TABLES(NKR)  ! (KS) - Loading the scattering look-up-table
6052
6053  ! ... (KS) - Broadcating Liquid drops
6054 #if (defined(DM_PARALLEL))
6055         DM_BCAST_MACRO_R16(FAF1)
6056         DM_BCAST_MACRO_R16(FBF1)
6057         DM_BCAST_MACRO_R16(FAB1)
6058         DM_BCAST_MACRO_R16(FBB1)
6059    ! ... (KS) - Broadcating Snow
6060         DM_BCAST_MACRO_R16(FAF3)
6061         DM_BCAST_MACRO_R16(FBF3)
6062         DM_BCAST_MACRO_R16(FAB3)
6063         DM_BCAST_MACRO_R16(FBB3)
6064    ! ... (KS) - Broadcating Graupel
6065         DM_BCAST_MACRO_R16(FAF4)
6066         DM_BCAST_MACRO_R16(FBF4)
6067         DM_BCAST_MACRO_R16(FAB4)
6068         DM_BCAST_MACRO_R16(FBB4)
6069    ! ### (KS) - Broadcating Hail
6070         DM_BCAST_MACRO_R16(FAF5)
6071         DM_BCAST_MACRO_R16(FBF5)
6072         DM_BCAST_MACRO_R16(FAB5)
6073         DM_BCAST_MACRO_R16(FBB5)
6074  ! ### (KS) - Broadcating Usetables array
6075           CALL wrf_dm_bcast_integer ( usetables , size ( usetables ) * IWORDSIZE )
6076 #endif
6077   WRITE(errmess, '(A,I2)') 'module_mp_WRFsbm : succesfull reading Table-10'
6078   call wrf_message(errmess)
6079  ! +-----------------------------------------------------------------------+
6080
6081  ! calculation of the mass(in mg) for categories boundaries :
6082    ax=2.d0**(1.0)
6083
6084    do i=1,nkr
6085          xl_mg(i) = xl(i)*1.e3
6086       xs_mg(i) = xs(i)*1.e3
6087       xg_mg(i) = xg(i)*1.e3
6088       xh_mg(i) = xh(i)*1.e3
6089       xi1_mg(i) = xi(i,1)*1.e3
6090       xi2_mg(i) = xi(i,2)*1.e3
6091       xi3_mg(i) = xi(i,3)*1.e3
6092    enddo
6093
6094    if (.NOT. ALLOCATED(IMA)) ALLOCATE(IMA(nkr,nkr))
6095    if (.NOT. ALLOCATED(CHUCM)) ALLOCATE(CHUCM(nkr,nkr))
6096    chucm  = 0.0d0
6097    ima = 0
6098    CALL courant_bott_KS(xl, nkr, chucm, ima, scal) ! ### (KS) : New courant_bott_KS (without XL_MG(0:nkr))
6099    WRITE(errmess, '(A,I2)') 'FAST_SBM_INIT : succesfull reading "courant_bott_KS" '
6100    CALL wrf_debug(000, errmess)
6101
6102   DEG01=1./3.
6103   CONCCCNIN=0.
6104   CONTCCNIN=0.
6105   if (.NOT. ALLOCATED(DROPRADII)) ALLOCATE(DROPRADII(NKR))
6106   DO KR=1,NKR
6107   DROPRADII(KR)=(3.0*XL(KR)/4.0/3.141593/1.0)**DEG01
6108   ENDDO
6109
6110  ! +-------------------------------------------------------------+
6111  ! Allocating Aerosols Array
6112  ! +-------------------------+
6113  if (.NOT. ALLOCATED(FCCNR_MAR)) ALLOCATE(FCCNR_MAR(NKR_aerosol))
6114  if (.NOT. ALLOCATED(FCCNR_CON)) ALLOCATE(FCCNR_CON(NKR_aerosol))
6115  if (.NOT. ALLOCATED(XCCN)) ALLOCATE(XCCN(NKR_aerosol))
6116  if (.NOT. ALLOCATED(RCCN)) ALLOCATE(RCCN(NKR_aerosol))
6117  if (.NOT. ALLOCATED(Scale_CCN_Factor)) ALLOCATE(Scale_CCN_Factor)
6118  if (.NOT. ALLOCATED(FCCN)) ALLOCATE(FCCN(NKR_aerosol))
6119
6120         IF(ILogNormal_modes_Aerosol == 1)THEN
6121                 ! ... Initializing the FCCNR_MAR and FCCNR_CON
6122                 FCCNR_CON = 0.0
6123                 FCCNR_MAR = 0.0
6124                 Scale_CCN_Factor = 1.0
6125                 XCCN = 0.0
6126                 RCCN = 0.0
6127                 CALL LogNormal_modes_Aerosol(FCCNR_CON,FCCNR_MAR,NKR_aerosol,COL,XL,XCCN,RCCN,RO_SOLUTE,Scale_CCN_Factor,1)
6128                 CALL LogNormal_modes_Aerosol(FCCNR_CON,FCCNR_MAR,NKR_aerosol,COL,XL,XCCN,RCCN,RO_SOLUTE,Scale_CCN_Factor,2)
6129                 WRITE(errmess, '(A,I2)') 'module_mp_WRFsbm : succesfull reading "LogNormal_modes_Aerosol" '
6130                 CALL wrf_debug(000, errmess)
6131         ENDIF
6132  ! +-------------------------------------------------------------+
6133
6134          if (.NOT. ALLOCATED(PKIJ)) ALLOCATE(PKIJ(JBREAK,JBREAK,JBREAK))
6135          if (.NOT. ALLOCATED(QKJ)) ALLOCATE(QKJ(JBREAK,JBREAK))
6136          if (.NOT. ALLOCATED(ECOALMASSM)) ALLOCATE(ECOALMASSM(NKR,NKR))
6137          if (.NOT. ALLOCATED(BRKWEIGHT)) ALLOCATE(BRKWEIGHT(JBREAK))
6138     PKIJ = 0.0e0
6139     QKJ = 0.0e0
6140     ECOALMASSM = 0.0d0
6141     BRKWEIGHT = 0.0d0
6142          CALL BREAKINIT_KS(PKIJ,QKJ,ECOALMASSM,BRKWEIGHT,XL,DROPRADII,BR_MAX,JBREAK,JMAX,NKR,VR1) ! Rain Spontanous Breakup
6143 #if (defined(DM_PARALLEL))
6144                 DM_BCAST_MACRO_R4(PKIJ)
6145     DM_BCAST_MACRO_R4(QKJ)
6146 #endif
6147           WRITE(errmess, '(A,I2)') 'FAST_SBM_INIT : succesfull reading BREAKINIT_KS" '
6148     CALL wrf_debug(000, errmess)
6149   ! +--------------------------------------------------------------------------------------------------------------------+
6150
6151    100  FORMAT(10I4)
6152    101   FORMAT(3X,F7.5,E13.5)
6153    102  FORMAT(4E12.4)
6154    105  FORMAT(A48)
6155    106  FORMAT(A80)
6156    123  FORMAT(3E12.4,3I4)
6157    200  FORMAT(6E13.5)
6158    201   FORMAT(6D13.5)
6159    300  FORMAT(8E14.6)
6160    301   FORMAT(3X,F8.3,3X,E13.5)
6161    302   FORMAT(5E13.5)
6162
6163  if (.NOT. ALLOCATED(cwll)) ALLOCATE(cwll(nkr,nkr))
6164
6165  if (.NOT. ALLOCATED(cwli_1)) ALLOCATE(cwli_1(nkr,nkr))
6166  if (.NOT. ALLOCATED(cwli_2)) ALLOCATE(cwli_2(nkr,nkr))
6167  if (.NOT. ALLOCATED(cwli_3)) ALLOCATE(cwli_3(nkr,nkr))
6168
6169  if (.NOT. ALLOCATED(cwil_1)) ALLOCATE(cwil_1(nkr,nkr))
6170  if (.NOT. ALLOCATED(cwil_2)) ALLOCATE(cwil_2(nkr,nkr))
6171  if (.NOT. ALLOCATED(cwil_3)) ALLOCATE(cwil_3(nkr,nkr))
6172
6173  if (.NOT. ALLOCATED(cwlg)) ALLOCATE(cwlg(nkr,nkr))
6174  if (.NOT. ALLOCATED(cwlh)) ALLOCATE(cwlh(nkr,nkr))
6175  if (.NOT. ALLOCATED(cwls)) ALLOCATE(cwls(nkr,nkr))
6176  if (.NOT. ALLOCATED(cwgl)) ALLOCATE(cwgl(nkr,nkr))
6177  if (.NOT. ALLOCATED(cwhl)) ALLOCATE(cwhl(nkr,nkr))
6178  if (.NOT. ALLOCATED(cwsl)) ALLOCATE(cwsl(nkr,nkr))
6179
6180  if (.NOT. ALLOCATED(cwii_1_1)) ALLOCATE(cwii_1_1(nkr,nkr))
6181  if (.NOT. ALLOCATED(cwii_1_2)) ALLOCATE(cwii_1_2(nkr,nkr))
6182  if (.NOT. ALLOCATED(cwii_1_3)) ALLOCATE(cwii_1_3(nkr,nkr))
6183  if (.NOT. ALLOCATED(cwii_2_1)) ALLOCATE(cwii_2_1(nkr,nkr))
6184  if (.NOT. ALLOCATED(cwii_2_2)) ALLOCATE(cwii_2_2(nkr,nkr))
6185  if (.NOT. ALLOCATED(cwii_2_3)) ALLOCATE(cwii_2_3(nkr,nkr))
6186  if (.NOT. ALLOCATED(cwii_3_1)) ALLOCATE(cwii_3_1(nkr,nkr))
6187  if (.NOT. ALLOCATED(cwii_3_2)) ALLOCATE(cwii_3_2(nkr,nkr))
6188  if (.NOT. ALLOCATED(cwii_3_3)) ALLOCATE(cwii_3_3(nkr,nkr))
6189
6190  if (.NOT. ALLOCATED(cwis_1)) ALLOCATE(cwis_1(nkr,nkr))
6191  if (.NOT. ALLOCATED(cwis_2)) ALLOCATE(cwis_2(nkr,nkr))
6192  if (.NOT. ALLOCATED(cwis_3)) ALLOCATE(cwis_3(nkr,nkr))
6193  if (.NOT. ALLOCATED(cwsi_1)) ALLOCATE(cwsi_1(nkr,nkr))
6194  if (.NOT. ALLOCATED(cwsi_2)) ALLOCATE(cwsi_2(nkr,nkr))
6195  if (.NOT. ALLOCATED(cwsi_3)) ALLOCATE(cwsi_3(nkr,nkr))
6196
6197  if (.NOT. ALLOCATED(cwig_1)) ALLOCATE(cwig_1(nkr,nkr))
6198  if (.NOT. ALLOCATED(cwig_2)) ALLOCATE(cwig_2(nkr,nkr))
6199  if (.NOT. ALLOCATED(cwig_3)) ALLOCATE(cwig_3(nkr,nkr))
6200
6201  if (.NOT. ALLOCATED(cwih_1)) ALLOCATE(cwih_1(nkr,nkr))
6202  if (.NOT. ALLOCATED(cwih_2)) ALLOCATE(cwih_2(nkr,nkr))
6203  if (.NOT. ALLOCATED(cwih_3)) ALLOCATE(cwih_3(nkr,nkr))
6204
6205  if (.NOT. ALLOCATED(cwsg)) ALLOCATE(cwsg(nkr,nkr))
6206  if (.NOT. ALLOCATED(cwss)) ALLOCATE(cwss(nkr,nkr))
6207
6208    cwll(:,:) = 0.0e0
6209    cwli_1(:,:) = 0.0e0 ; cwli_2(:,:) = 0.0e0 ; cwli_3(:,:) = 0.0e0
6210    cwil_1(:,:) = 0.0e0 ; cwil_2(:,:) = 0.0e0 ; cwil_3(:,:) = 0.0e0
6211    cwlg(:,:) = 0.0e0 ; cwlh(:,:) = 0.0e0 ; cwls(:,:) = 0.0e0
6212    cwgl(:,:) = 0.0e0 ; cwhl(:,:) = 0.0e0 ; cwsl(:,:) = 0.0e0
6213    cwii_1_1(:,:) = 0.0e0 ; cwii_1_2(:,:) = 0.0e0 ; cwii_1_3(:,:) = 0.0e0
6214    cwii_2_1(:,:) = 0.0e0 ; cwii_2_2(:,:) = 0.0e0 ; cwii_2_3(:,:) = 0.0e0
6215    cwii_3_1(:,:) = 0.0e0 ; cwii_3_2(:,:) = 0.0e0 ; cwii_3_3(:,:) = 0.0e0
6216    cwis_1(:,:) = 0.0e0 ; cwis_2(:,:) = 0.0e0 ; cwis_3(:,:) = 0.0e0
6217    cwsi_1(:,:) = 0.0e0 ; cwsi_2(:,:) = 0.0e0 ; cwsi_3(:,:) = 0.0e0
6218    cwig_1(:,:) = 0.0e0 ; cwig_2(:,:) = 0.0e0 ; cwig_3(:,:) = 0.0e0
6219    cwih_1(:,:) = 0.0e0 ; cwih_2(:,:) = 0.0e0 ; cwih_3(:,:) = 0.0e0
6220    cwsg(:,:) = 0.0e0 ; cwss(:,:) = 0.0e0
6221
6222    call Kernals_KS(dt,nkr,7.6E6)
6223
6224  !+---+-----------------------------------------+
6225  if (.NOT. ALLOCATED( Prob)) ALLOCATE( Prob(NKR))
6226  if (.NOT. ALLOCATED(Gain_Var_New)) ALLOCATE(Gain_Var_New(NKR,NKR))
6227  if (.NOT. ALLOCATED(NND)) ALLOCATE(NND(NKR,NKR))
6228   Prob = 0.0
6229   Gain_Var_New = 0.0
6230   NND = 0.0
6231   call Spontanous_Init(dt, XL, DROPRADII, Prob, Gain_Var_New, NND, NKR, ikr_spon_break)
6232   WRITE(errmess, '(A,I2)') 'FAST_SBM_INIT : succesfull reading "Spontanous_Init" '
6233   CALL wrf_debug(000, errmess)
6234
6235   return
6236   2070  continue
6237
6238       WRITE( errmess , '(A,I4)' )                                          &
6239                  'module_mp_FAST_SBM_INIT: error opening hujisbm_DATA on unit,model stop ' &
6240                  &, hujisbm_unit1
6241       CALL wrf_error_fatal(errmess)
6242
6243   END SUBROUTINE FAST_HUCMINIT
6244  ! -----------------------------------------------------------------+
6245   subroutine Kernals_KS(dtime_coal,nkr,p_z)
6246
6247   implicit none
6248
6249   integer :: nkr
6250   real(kind=r4size),intent(in) :: dtime_coal,p_z
6251
6252   ! ### Locals
6253   integer :: i,j
6254   real(kind=r4size),parameter :: p1=1.0e6,p2=0.75e6,p3=0.50e6,p4=0.3e6
6255   real(kind=r4size) :: dlnr, scal, dtimelnr, pdm, p_1, p_2, p_3, ckern_1, ckern_2, &
6256                                           ckern_3
6257
6258  ! p1=1.00D6 dynes/cm^2 = 1000.0 mb
6259  ! p2=0.75D6 dynes/cm^2 =  750.0 mb
6260  ! p3=0.50D6 dynes/cm^2 =  500.0 mb
6261  ! p4=0.30D6 dynes/cm^2 =  300.0 mb
6262
6263   scal = 1.0
6264         dlnr = dlog(2.0d0)/(3.0d0*scal)
6265         dtimelnr = dtime_coal*dlnr
6266
6267         p_1=p1
6268         p_2=p2
6269         p_3=p3
6270         do i=1,nkr
6271                 do j=1,nkr
6272                         ! 1. water - water
6273                         ckern_1 = YWLL_1000mb(i,j)
6274                         ckern_2 = YWLL_750mb(i,j)
6275                         ckern_3 = YWLL_500mb(i,j)
6276                         cwll(i,j) = ckern_z(p_z,p_1,p_2,p_3,ckern_1,ckern_2,ckern_3)*dtime_coal*dlnr
6277                 end do
6278         end do
6279
6280         ! ... ECOALMASSM is from "BreakIniit_KS"
6281         DO I=1,NKR
6282          DO J=1,NKR
6283                 CWLL(I,J) = ECOALMASSM(I,J)*CWLL(I,J)
6284          END DO
6285   END DO
6286
6287         p_1=p2
6288         p_2=p3
6289         p_3=p4
6290
6291         if(p_z >= p_1) then
6292                 do j=1,nkr
6293                         do i=1,nkr
6294                                 cwli_1(i,j) = ywli_750mb(i,j,1)*dtimelnr
6295                                 cwli_2(i,j) = ywli_750mb(i,j,2)*dtimelnr
6296                                 cwli_3(i,j) = ywli_750mb(i,j,3)*dtimelnr
6297                                 cwlg(i,j) = ywlg_750mb(i,j)*dtimelnr
6298                                 cwlh(i,j) = ywlh_750mb(i,j)*dtimelnr
6299                                 cwls(i,j) = ywls_750mb(i,j)*dtimelnr
6300                                 cwii_1_1(i,j) = ywii_750mb(i,j,1,1)*dtimelnr
6301                                 cwii_1_2(i,j) = ywii_750mb(i,j,1,2)*dtimelnr
6302                                 cwii_1_3(i,j) = ywii_750mb(i,j,1,3)*dtimelnr
6303                                 cwii_2_1(i,j) = ywii_750mb(i,j,2,1)*dtimelnr
6304                                 cwii_2_2(i,j) = ywii_750mb(i,j,2,2)*dtimelnr
6305                                 cwii_2_3(i,j) = ywii_750mb(i,j,2,3)*dtimelnr
6306                                 cwii_3_1(i,j) = ywii_750mb(i,j,3,1)*dtimelnr
6307                                 cwii_3_2(i,j) = ywii_750mb(i,j,3,2)*dtimelnr
6308                                 cwii_3_3(i,j) = ywii_750mb(i,j,3,3)*dtimelnr
6309                                 cwis_1(i,j) = ywis_750mb(i,j,1)*dtimelnr
6310                                 cwis_2(i,j) = ywis_750mb(i,j,2)*dtimelnr
6311                                 cwis_3(i,j) = ywis_750mb(i,j,3)*dtimelnr
6312                                 cwsg(i,j) = ywsg_750mb(i,j)*dtimelnr
6313                                 cwss(i,j) = ywss_750mb(i,j)*dtimelnr
6314                         end do
6315                 end do
6316         endif
6317
6318         if (p_z <= p_3) then
6319                 do j=1,nkr
6320                   do i=1,nkr
6321                         cwli_1(i,j) = ywli_300mb(i,j,1)*dtimelnr
6322                         cwli_2(i,j) = ywli_300mb(i,j,2)*dtimelnr
6323                         cwli_3(i,j) = ywli_300mb(i,j,3)*dtimelnr
6324                         cwlg(i,j) = ywlg_300mb(i,j)*dtimelnr
6325                         cwlh(i,j) = ywlh_300mb(i,j)*dtimelnr
6326                         cwls(i,j) = ywls_300mb(i,j)*dtimelnr
6327                         cwii_1_1(i,j) = ywii_300mb(i,j,1,1)*dtimelnr
6328                         cwii_1_2(i,j) = ywii_300mb(i,j,1,2)*dtimelnr
6329                         cwii_1_3(i,j) = ywii_300mb(i,j,1,3)*dtimelnr
6330                         cwii_2_1(i,j) = ywii_300mb(i,j,2,1)*dtimelnr
6331                         cwii_2_2(i,j) = ywii_300mb(i,j,2,2)*dtimelnr
6332                         cwii_2_3(i,j) = ywii_300mb(i,j,2,3)*dtimelnr
6333                         cwii_3_1(i,j) = ywii_300mb(i,j,3,1)*dtimelnr
6334                         cwii_3_2(i,j) = ywii_300mb(i,j,3,2)*dtimelnr
6335                         cwii_3_3(i,j) = ywii_300mb(i,j,3,3)*dtimelnr
6336                         cwis_1(i,j) = ywis_300mb(i,j,1)*dtimelnr
6337                         cwis_2(i,j) = ywis_300mb(i,j,2)*dtimelnr
6338                         cwis_3(i,j) = ywis_300mb(i,j,3)*dtimelnr
6339                         cwsg(i,j) = ywsg_300mb(i,j)*dtimelnr
6340                         cwss(i,j) = ywss_300mb(i,j)*dtimelnr
6341                   end do
6342                 end do
6343           endif
6344
6345           if (p_z <  p_1  .and. p_z >= p_2) then
6346                 pdm = (p_z-p_2)/(p_1-p_2)
6347                 do j=1,nkr
6348                   do i=1,nkr
6349                         ckern_1=ywli_750mb(i,j,1)
6350                         ckern_2=ywli_500mb(i,j,1)
6351                         cwli_1(i,j)=(ckern_2+(ckern_1-ckern_2)*pdm)*dtimelnr
6352
6353                         ckern_1=ywli_750mb(i,j,2)
6354                         ckern_2=ywli_500mb(i,j,2)
6355                         cwli_2(i,j)=(ckern_2+(ckern_1-ckern_2)*pdm)*dtimelnr
6356
6357                         ckern_1=ywli_750mb(i,j,3)
6358                         ckern_2=ywli_500mb(i,j,3)
6359                         cwli_3(i,j)=(ckern_2+(ckern_1-ckern_2)*pdm)*dtimelnr
6360
6361                         ckern_1=ywlg_750mb(i,j)
6362                         ckern_2=ywlg_500mb(i,j)
6363                         cwlg(i,j)=(ckern_2+(ckern_1-ckern_2)*pdm)*dtimelnr
6364
6365                         ckern_1=ywlh_750mb(i,j)
6366                         ckern_2=ywlh_500mb(i,j)
6367                         cwlh(i,j)=(ckern_2+(ckern_1-ckern_2)*pdm)*dtimelnr
6368
6369                         ckern_1=ywls_750mb(i,j)
6370                         ckern_2=ywls_500mb(i,j)
6371                         cwls(i,j)=(ckern_2+(ckern_1-ckern_2)*pdm)*dtimelnr
6372
6373                         ckern_1=ywii_750mb(i,j,1,1)
6374                         ckern_2=ywii_500mb(i,j,1,1)
6375                         cwii_1_1(i,j)=(ckern_2+(ckern_1-ckern_2)*pdm)*dtimelnr
6376
6377                         ckern_1=ywii_750mb(i,j,1,2)
6378                         ckern_2=ywii_500mb(i,j,1,2)
6379                         cwii_1_2(i,j)=(ckern_2+(ckern_1-ckern_2)*pdm)*dtimelnr
6380
6381                         ckern_1=ywii_750mb(i,j,1,3)
6382                         ckern_2=ywii_500mb(i,j,1,3)
6383                         cwii_1_3(i,j)=(ckern_2+(ckern_1-ckern_2)*pdm)*dtimelnr
6384
6385                         ckern_1=ywii_750mb(i,j,2,1)
6386                         ckern_2=ywii_500mb(i,j,2,1)
6387                         cwii_2_1(i,j)=(ckern_2+(ckern_1-ckern_2)*pdm)*dtimelnr
6388
6389
6390                         ckern_1=ywii_750mb(i,j,2,2)
6391                         ckern_2=ywii_500mb(i,j,2,2)
6392                         cwii_2_2(i,j)=(ckern_2+(ckern_1-ckern_2)*pdm)*dtimelnr
6393
6394                         ckern_1=ywii_750mb(i,j,2,3)
6395                         ckern_2=ywii_500mb(i,j,2,3)
6396                         cwii_2_3(i,j)=(ckern_2+(ckern_1-ckern_2)*pdm)*dtimelnr
6397
6398                         ckern_1=ywii_750mb(i,j,3,1)
6399                         ckern_2=ywii_500mb(i,j,3,1)
6400                         cwii_3_1(i,j)=(ckern_2+(ckern_1-ckern_2)*pdm)*dtimelnr
6401
6402                         ckern_1=ywii_750mb(i,j,3,2)
6403                         ckern_2=ywii_500mb(i,j,3,2)
6404                         cwii_3_2(i,j)=(ckern_2+(ckern_1-ckern_2)*pdm)*dtimelnr
6405
6406                         ckern_1=ywii_750mb(i,j,3,3)
6407                         ckern_2=ywii_500mb(i,j,3,3)
6408                         cwii_3_3(i,j)=(ckern_2+(ckern_1-ckern_2)*pdm)*dtimelnr
6409
6410                         ckern_1=ywis_750mb(i,j,1)
6411                         ckern_2=ywis_500mb(i,j,1)
6412                         cwis_1(i,j)=(ckern_2+(ckern_1-ckern_2)*pdm)*dtimelnr
6413
6414                         ckern_1=ywis_750mb(i,j,2)
6415                         ckern_2=ywis_500mb(i,j,2)
6416                         cwis_2(i,j)=(ckern_2+(ckern_1-ckern_2)*pdm)*dtimelnr
6417
6418                         ckern_1=ywis_750mb(i,j,3)
6419                         ckern_2=ywis_500mb(i,j,3)
6420                         cwis_3(i,j)=(ckern_2+(ckern_1-ckern_2)*pdm)*dtimelnr
6421
6422                         ckern_1=ywsg_750mb(i,j)
6423                         ckern_2=ywsg_500mb(i,j)
6424                         cwsg(i,j)=(ckern_2+(ckern_1-ckern_2)*pdm)*dtimelnr
6425
6426                         ckern_1=ywss_750mb(i,j)
6427                         ckern_2=ywss_500mb(i,j)
6428                         cwss(i,j)=(ckern_2+(ckern_1-ckern_2)*pdm)*dtimelnr
6429                    end do
6430                  end do
6431            endif
6432
6433                 if (p_z <  p_2  .and. p_z >  p_3) then
6434                    pdm = (p_z-p_3)/(p_2-p_3)
6435                    do j=1,nkr
6436                      do i=1,nkr
6437
6438                           ckern_2=ywli_500mb(i,j,1)
6439                           ckern_3=ywli_300mb(i,j,1)
6440                           cwli_1(i,j)=(ckern_3+(ckern_2-ckern_3)*pdm)*dtimelnr
6441
6442                           ckern_2=ywli_500mb(i,j,2)
6443                           ckern_3=ywli_300mb(i,j,2)
6444                           cwli_2(i,j)=(ckern_3+(ckern_2-ckern_3)*pdm)*dtimelnr
6445
6446                           ckern_2=ywli_500mb(i,j,3)
6447                           ckern_3=ywli_300mb(i,j,3)
6448                           cwli_3(i,j)=(ckern_3+(ckern_2-ckern_3)*pdm)*dtimelnr
6449
6450                           ckern_2=ywlg_500mb(i,j)
6451                           ckern_3=ywlg_300mb(i,j)
6452                           cwlg(i,j)=(ckern_3+(ckern_2-ckern_3)*pdm)*dtimelnr
6453
6454                         ckern_2=ywlh_500mb(i,j)
6455                         ckern_3=ywlh_300mb(i,j)
6456                         cwlh(i,j)=(ckern_3+(ckern_2-ckern_3)*pdm)*dtimelnr
6457
6458                         ckern_2=ywls_500mb(i,j)
6459                         ckern_3=ywls_300mb(i,j)
6460                         cwls(i,j)=(ckern_3+(ckern_2-ckern_3)*pdm)*dtimelnr
6461
6462                         ckern_2=ywii_500mb(i,j,1,1)
6463                         ckern_3=ywii_300mb(i,j,1,1)
6464                         cwii_1_1(i,j)=(ckern_3+(ckern_2-ckern_3)*pdm)*dtimelnr
6465
6466                         ckern_2=ywii_500mb(i,j,1,2)
6467                         ckern_3=ywii_300mb(i,j,1,2)
6468                         cwii_1_2(i,j)=(ckern_3+(ckern_2-ckern_3)*pdm)*dtimelnr
6469
6470                         ckern_2=ywii_500mb(i,j,1,3)
6471                         ckern_3=ywii_300mb(i,j,1,3)
6472                         cwii_1_3(i,j)=(ckern_3+(ckern_2-ckern_3)*pdm)*dtimelnr
6473
6474                         ckern_2=ywii_500mb(i,j,2,1)
6475                         ckern_3=ywii_300mb(i,j,2,1)
6476                         cwii_2_1(i,j)=(ckern_3+(ckern_2-ckern_3)*pdm)*dtimelnr
6477
6478                         ckern_2=ywii_500mb(i,j,2,2)
6479                         ckern_3=ywii_300mb(i,j,2,2)
6480                         cwii_2_2(i,j)=(ckern_3+(ckern_2-ckern_3)*pdm)*dtimelnr
6481
6482                         ckern_2=ywii_500mb(i,j,2,3)
6483                         ckern_3=ywii_300mb(i,j,2,3)
6484                         cwii_2_3(i,j)=(ckern_3+(ckern_2-ckern_3)*pdm)*dtimelnr
6485
6486                         ckern_2=ywii_500mb(i,j,3,1)
6487                         ckern_3=ywii_300mb(i,j,3,1)
6488                         cwii_3_1(i,j)=(ckern_3+(ckern_2-ckern_3)*pdm)*dtimelnr
6489
6490                         ckern_2=ywii_500mb(i,j,3,2)
6491                         ckern_3=ywii_300mb(i,j,3,2)
6492                         cwii_3_2(i,j)=(ckern_3+(ckern_2-ckern_3)*pdm)*dtimelnr
6493
6494                         ckern_2=ywii_500mb(i,j,3,3)
6495                         ckern_3=ywii_300mb(i,j,3,3)
6496                         cwii_3_3(i,j)=(ckern_3+(ckern_2-ckern_3)*pdm)*dtimelnr
6497
6498                         ckern_2=ywis_500mb(i,j,1)
6499                         ckern_3=ywis_300mb(i,j,1)
6500                         cwis_1(i,j)=(ckern_3+(ckern_2-ckern_3)*pdm)*dtimelnr
6501
6502                         ckern_2=ywis_500mb(i,j,2)
6503                         ckern_3=ywis_300mb(i,j,2)
6504                         cwis_2(i,j)=(ckern_3+(ckern_2-ckern_3)*pdm)*dtimelnr
6505
6506                         ckern_2=ywis_500mb(i,j,3)
6507                         ckern_3=ywis_300mb(i,j,3)
6508                         cwis_3(i,j)=(ckern_3+(ckern_2-ckern_3)*pdm)*dtimelnr
6509
6510                         ckern_2=ywsg_500mb(i,j)
6511                         ckern_3=ywsg_300mb(i,j)
6512                         cwsg(i,j)=(ckern_3+(ckern_2-ckern_3)*pdm)*dtimelnr
6513
6514                         ckern_2=ywss_500mb(i,j)
6515                         ckern_3=ywss_300mb(i,j)
6516                         cwss(i,j)=(ckern_3+(ckern_2-ckern_3)*pdm)*dtimelnr
6517
6518                    end do
6519                  end do
6520    endif
6521
6522                 do i=1,nkr
6523                  do j=1,nkr
6524  ! columns - water
6525                   cwil_1(i,j)=cwli_1(j,i)
6526  ! plates - water
6527                   cwil_2(i,j)=cwli_2(j,i)
6528  ! dendrites - water
6529                   cwil_3(i,j)=cwli_3(j,i)
6530  ! 3. graupel - water
6531                   cwgl(i,j)=cwlg(j,i)
6532  ! 4. hail - water
6533                   cwhl(i,j)=cwlh(j,i)
6534  ! 5. snow - water
6535                   cwsl(i,j)=cwls(j,i)
6536  ! 7.snow - crystals :
6537  ! snow - columns
6538                   cwsi_1(i,j)=cwis_1(j,i)
6539  ! snow - plates
6540                   cwsi_2(i,j)=cwis_2(j,i)
6541  ! snow - dendrites
6542                   cwsi_3(i,j)=cwis_3(j,i)
6543                  end do
6544           end do
6545
6546
6547   return
6548   end subroutine Kernals_KS
6549
6550  ! ------------------------------------------------------------+
6551   real function ckern_z (p_z,p_1,p_2,p_3,ckern_1,ckern_2,ckern_3)
6552
6553         implicit none
6554
6555         real(kind=r4size),intent(in) :: p_z,p_1,p_2,p_3,ckern_1, &
6556                                                                         ckern_2,ckern_3
6557
6558         if(p_z>=p_1) ckern_z = ckern_1
6559         !if(p_z==p_2) ckern_z=ckern_2
6560         if(p_z<=p_3) ckern_z = ckern_3
6561         if(p_z<p_1 .and. p_z>=p_2) ckern_z = ckern_2 + (ckern_1-ckern_2)*(p_z-p_2)/(p_1-p_2)
6562         if(p_z<p_2 .and. p_z>p_3) ckern_z = ckern_3 + (ckern_2-ckern_3)*(p_z-p_3)/(p_2-p_3)
6563
6564   return
6565   end function ckern_z
6566  ! -------------------------------------------------------------+
6567   SUBROUTINE FREEZ(FF1,XL,FF2,XI,FF3,XS,FF4,XG,FF5,XH, &
6568                                            TIN,DT,RO,COL,AFREEZMY,BFREEZMY,    &
6569                                      BFREEZMAX,KRFREEZ,ICEMAX,NKR)
6570
6571           IMPLICIT NONE
6572
6573             INTEGER KR,ICE,ICE_TYPE
6574       REAL COL,AFREEZMY,BFREEZMY,BFREEZMAX
6575       INTEGER KRFREEZ,ICEMAX,NKR
6576       REAL DT,RO,YKK,PF,PF_1,DEL_T,TT_DROP,ARG_1,YK2,DF1,BF,ARG_M, &
6577            TT_DROP_AFTER_FREEZ,CFREEZ,SUM_ICE,TIN,TTIN,AF,FF_MAX,F1_MAX, &
6578            F2_MAX,F3_MAX,F4_MAX,F5_MAX
6579
6580       REAL FF1(NKR),XL(NKR),FF2(NKR,ICEMAX) &
6581            ,XI(NKR,ICEMAX),FF3(NKR),XS(NKR),FF4(NKR) &
6582            ,XG(NKR),FF5(NKR),XH(NKR)
6583
6584         TTIN=TIN
6585         DEL_T   =TTIN-273.15
6586         ICE_TYPE=2
6587         F1_MAX=0.
6588         F2_MAX=0.
6589         F3_MAX=0.
6590         F4_MAX=0.
6591         F5_MAX=0.
6592         DO KR=1,NKR
6593         F1_MAX=AMAX1(F1_MAX,FF1(KR))
6594         F3_MAX=AMAX1(F3_MAX,FF3(KR))
6595         F4_MAX=AMAX1(F4_MAX,FF4(KR))
6596         F5_MAX=AMAX1(F5_MAX,FF5(KR))
6597         DO ICE=1,ICEMAX
6598                 F2_MAX=AMAX1(F2_MAX,FF2(KR,ICE))
6599     ENDDO
6600           FF_MAX=AMAX1(F2_MAX,F3_MAX,F4_MAX,F5_MAX)
6601   ENDDO
6602  !
6603  !******************************* FREEZING ****************************
6604  !
6605         IF(DEL_T.LT.0.AND.F1_MAX.NE.0) THEN
6606                               SUM_ICE=0.
6607                         AF      = AFREEZMY
6608                   CFREEZ        =(BFREEZMAX-BFREEZMY)/XL(NKR)
6609  !
6610  !***************************** MASS LOOP **************************
6611  !
6612                 DO  KR  =1,NKR
6613                                         ARG_M   =XL(KR)
6614                                   BF    =BFREEZMY+CFREEZ*ARG_M
6615                             PF_1        =AF*EXP(-BF*DEL_T)
6616                             PF  =ARG_M*PF_1
6617                                   YKK   =EXP(-PF*DT)
6618                             DF1 =FF1(KR)*(1.-YKK)
6619                                   YK2   =DF1
6620                             FF1(KR)=FF1(KR)*YKK
6621                                   IF(KR.LE.KRFREEZ)  THEN
6622                                            FF2(KR,ICE_TYPE)=FF2(KR,ICE_TYPE)+YK2
6623                 ELSE
6624                                            FF5(KR)      =FF5(KR)+YK2
6625                 ENDIF
6626                             SUM_ICE=SUM_ICE+YK2*3.*XL(KR)*XL(KR)*COL
6627  !
6628  !************************ END OF "MASS LOOP" **************************
6629  !
6630                                ENDDO
6631  !
6632  !************************** NEW TEMPERATURE *************************
6633  !
6634                    ARG_1        =333.*SUM_ICE/RO
6635                    TT_DROP_AFTER_FREEZ=TTIN+ARG_1
6636                          TIN    =TT_DROP_AFTER_FREEZ
6637  !
6638  !************************** END OF "FREEZING" ****************************
6639  !
6640                    ENDIF
6641  !
6642         RETURN
6643         END SUBROUTINE FREEZ
6644  ! ----------------------------------------------------------------+
6645   SUBROUTINE J_W_MELT(FF1,XL,FF2,XI,FF3,XS,FF4,XG,FF5,XH &
6646                      ,TIN,DT,RO,COL,ICEMAX,NKR)
6647
6648           IMPLICIT NONE
6649
6650           integer,intent(in) :: NKR,ICEMAX
6651           real(kind=R4size),intent(in)    :: DT,COL,RO
6652           real(kind=R4size),intent(inout) :: FF1(:),XL(:),FF2(:,:),XI(:,:),FF3(:),XS(:),FF4(:),XG(:), &
6653                                                                                                  FF5(:),XH(:),Tin
6654
6655           !  ... Locals
6656       integer :: KR,ICE,ICE_TYPE
6657       real(kind=R4size) :: ARG_M,TT_DROP,ARG_1,TT_DROP_AFTER_FREEZ,DF1,DN,DN0, &
6658                                                          A,B,DTFREEZ,SUM_ICE,FF_MAX,F1_MAX,F2_MAX,F3_MAX,F4_MAX,F5_MAX, &
6659                                        DEL_T,meltrate,gamma
6660           ! ... Locals
6661
6662         gamma=4.4
6663                 DEL_T = TIN-273.15
6664                 ICE_TYPE = 2
6665                 F1_MAX=0.
6666                 F2_MAX=0.
6667                 F3_MAX=0.
6668                 F4_MAX=0.
6669                 F5_MAX=0.
6670                 DO KR=1,NKR
6671                         F1_MAX=AMAX1(F1_MAX,FF1(KR))
6672                         F3_MAX=AMAX1(F3_MAX,FF3(KR))
6673                         F4_MAX=AMAX1(F4_MAX,FF4(KR))
6674                         F5_MAX=AMAX1(F5_MAX,FF5(KR))
6675                         DO ICE=1,ICEMAX
6676                                 F2_MAX=AMAX1(F2_MAX,FF2(KR,ICE))
6677                   END DO
6678                                 FF_MAX=AMAX1(F2_MAX,F3_MAX,F4_MAX,F5_MAX)
6679        END DO
6680                                 SUM_ICE=0.
6681                                 IF(DEL_T.GE.0.AND.FF_MAX.NE.0) THEN
6682                                 DO KR = 1,NKR
6683                         ARG_M = 0.0
6684                         DO ICE = 1,ICEMAX
6685                                    IF (ICE ==1) THEN
6686                                 IF (KR .le. 10) THEN
6687                                         ARG_M = ARG_M+FF2(KR,ICE)
6688                                     FF2(KR,ICE) = 0.0
6689                                     ELSE IF (KR .gt. 10 .and. KR .lt. 18) THEN
6690                                         meltrate = 0.5/50.
6691                                         FF2(KR,ICE)=FF2(KR,ICE)-FF2(KR,ICE)*(meltrate*dt)
6692                                         ARG_M=ARG_M+FF2(KR,ICE)*(meltrate*dt)
6693                                 ELSE
6694                                         meltrate = 0.683/120.
6695                                         FF2(KR,ICE)=FF2(KR,ICE)-FF2(KR,ICE)*(meltrate*dt)
6696                                         ARG_M=ARG_M+FF2(KR,ICE)*(meltrate*dt)
6697                                 ENDIF
6698                                 ENDIF
6699                                 IF (ICE ==2 .or. ICE ==3) THEN
6700                                   IF (kr .le. 12) THEN
6701                                         FF2(KR,ICE)=0.
6702                                         ARG_M = ARG_M+FF2(KR,ICE)
6703                                     ELSE IF (kr .gt. 12 .and. kr .lt. 20) THEN
6704                                         meltrate = 0.5/50.
6705                                         FF2(KR,ICE)=FF2(KR,ICE)-FF2(KR,ICE)*(meltrate*dt)
6706                                         ARG_M=ARG_M+FF2(KR,ICE)*(meltrate*dt)
6707                                         ELSE
6708                                                 meltrate = 0.683/120.
6709                                         FF2(KR,ICE)=FF2(KR,ICE)-FF2(KR,ICE)*(meltrate*dt)
6710                                         ARG_M=ARG_M+FF2(KR,ICE)*(meltrate*dt)
6711                                         ENDIF
6712                                 ENDIF
6713                         END DO  ! Do ice
6714                                          ! ... Snow
6715                   IF (kr .le. 14) THEN
6716                      ARG_M = ARG_M + FF3(KR)
6717                                FF3(KR) = 0.0
6718                   ELSE IF (kr .gt. 14 .and. kr .lt. 22) THEN
6719                      meltrate = 0.5/50.
6720                      FF3(KR)=FF3(KR)-FF3(KR)*(meltrate*dt)
6721                      ARG_M=ARG_M+FF3(KR)*(meltrate*dt)
6722                   ELSE
6723                      meltrate = 0.683/120.
6724                      FF3(KR)=FF3(KR)-FF3(KR)*(meltrate*dt)
6725                      ARG_M=ARG_M+FF3(KR)*(meltrate*dt)
6726                   ENDIF
6727                      ! ... Graupel/Hail
6728                   IF (kr .le. 13) then
6729                       ARG_M = ARG_M+FF4(KR)+FF5(KR)
6730                                 FF4(KR)=0.
6731                       FF5(KR)=0.
6732                   ELSE IF (kr .gt. 13 .and. kr .lt. 23) THEN
6733                       meltrate = 0.5/50.
6734                       FF4(KR)=FF4(KR)-FF4(KR)*(meltrate*dt)
6735                       FF5(KR)=FF5(KR)-FF5(KR)*(meltrate*dt)
6736                       ARG_M=ARG_M+(FF4(KR)+FF5(KR))*(meltrate*dt)
6737                   ELSE
6738                       meltrate = 0.683/120.
6739                      FF4(KR)=FF4(KR)-FF4(KR)*(meltrate*dt)
6740                      FF5(KR)=FF5(KR)-FF5(KR)*(meltrate*dt)
6741                      ARG_M=ARG_M+(FF4(KR)+FF5(KR))*(meltrate*dt)
6742                   ENDIF
6743
6744                     FF1(KR) = FF1(KR) + ARG_M
6745                     SUM_ICE=SUM_ICE+ARG_M*3.*XL(KR)*XL(KR)*COL
6746                 END DO
6747
6748             ARG_1=333.*SUM_ICE/RO
6749             TIN = TIN - ARG_1
6750           ENDIF
6751
6752         RETURN
6753         END SUBROUTINE J_W_MELT
6754  ! +----------------------------------------------------------------------------+
6755    SUBROUTINE ONECOND1 &
6756                                  & (TT,QQ,PP,ROR &
6757                                  & ,VR1,PSINGLE &
6758                                  & ,DEL1N,DEL2N,DIV1,DIV2 &
6759                                  & ,FF1,PSI1,R1,RLEC,RO1BL &
6760                                  & ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
6761                                  & ,C1_MEY,C2_MEY &
6762                                  & ,COL,DTCOND,ICEMAX,NKR,ISYM1 &
6763                                    ,ISYM2,ISYM3,ISYM4,ISYM5,Iin,Jin,Kin,W_in,DX_in,Itimestep)
6764
6765         IMPLICIT NONE
6766
6767
6768        INTEGER NKR,ICEMAX, ISYM1, ISYM2(ICEMAX),ISYM3,ISYM4,ISYM5, Iin, Jin, Kin, &
6769                           sea_spray_no_temp_change_per_grid, Itimestep
6770        REAL    COL,VR1(NKR),PSINGLE &
6771       &       ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
6772       &       ,DTCOND, W_in,DX_in
6773
6774        REAL C1_MEY,C2_MEY
6775        INTEGER I_ABERGERON,I_BERGERON, &
6776       & KR,ICE,ITIME,KCOND,NR,NRM, &
6777       & KLIMIT, &
6778       & KM,KLIMITL
6779        REAL AL1,AL2,D,GAM,POD, &
6780       & RV_MY,CF_MY,D_MYIN,AL1_MY,AL2_MY,ALC,DT0LREF,DTLREF, &
6781       & A1_MYN, BB1_MYN, A2_MYN, BB2_MYN,DT,DTT,XRAD, &
6782       & TPC1, TPC2, TPC3, TPC4, TPC5, &
6783       & EPSDEL, EPSDEL2,DT0L, DT0I,&
6784       & ROR, &
6785       & CWHUCM,B6,B8L,B8I, &
6786       & DEL1,DEL2,DEL1S,DEL2S, &
6787       & TIMENEW,TIMEREV,SFN11,SFN12, &
6788       & SFNL,SFNI,B5L,B5I,B7L,B7I,DOPL,DOPI,RW,RI,QW,PW, &
6789       & PI,QI,DEL1N0,DEL2N0,D1N0,D2N0,DTNEWL,DTNEWL1,D1N,D2N, &
6790       & DEL_R1,DT0L0,DT0I0, &
6791       & DTNEWL0, &
6792       & DTNEWL2
6793         REAL DT_WATER_COND,DT_WATER_EVAP
6794
6795         INTEGER K
6796  ! NEW ALGORITHM OF CONDENSATION (12.01.00)
6797
6798        REAL  FF1_OLD(NKR),SUPINTW(NKR)
6799        DOUBLE PRECISION DSUPINTW(NKR),DD1N,DB11_MY,DAL1,DAL2
6800        DOUBLE PRECISION COL3,RORI,TPN,TPS,QPN,QPS,TOLD,QOLD &
6801       &                  ,FI1_K,FI2_K,FI3_K,FI4_K,FI5_K &
6802       &                  ,R1_K,R2_K,R3_K,R4_K,R5_K &
6803       &                  ,FI1R1,FI2R2,FI3R3,FI4R4,FI5R5 &
6804       &                  ,RMASSLAA,RMASSLBB,RMASSIAA,RMASSIBB &
6805       &                  ,ES1N,ES2N,EW1N,ARGEXP &
6806       &                  ,TT,QQ,PP &
6807       &                  ,DEL1N,DEL2N,DIV1,DIV2 &
6808       &                  ,OPER2,OPER3,AR1,AR2
6809
6810         DOUBLE PRECISION DELMASSL1
6811
6812  ! DROPLETS
6813
6814          REAL R1(NKR) &
6815       &           ,RLEC(NKR),RO1BL(NKR) &
6816       &           ,FI1(NKR),FF1(NKR),PSI1(NKR) &
6817       &           ,B11_MY(NKR),B12_MY(NKR)
6818
6819  ! WORK ARRAYS
6820
6821  ! NEW ALGORITHM OF MIXED PHASE FOR EVAPORATION
6822
6823
6824         REAL DTIMEO(NKR),DTIMEL(NKR) &
6825       &           ,TIMESTEPD(NKR)
6826
6827  ! NEW ALGORITHM (NO TYPE OF ICE)
6828
6829         REAL :: FL1(NKR), sfndummy(3), R1N(NKR)
6830         INTEGER :: IDROP
6831
6832         DOUBLE PRECISION :: R1D(NKR),R1ND(NKR)
6833
6834         OPER2(AR1)=0.622/(0.622+0.378*AR1)/AR1
6835         OPER3(AR1,AR2)=AR1*AR2/(0.622+0.378*AR1)
6836
6837         DATA AL1 /2500./, AL2 /2834./, D /0.211/ &
6838       &      ,GAM /1.E-4/, POD /10./
6839
6840         DATA RV_MY,CF_MY,D_MYIN,AL1_MY,AL2_MY &
6841       &      /461.5,0.24E-1,0.211E-4,2.5E6,2.834E6/
6842
6843         DATA A1_MYN, BB1_MYN, A2_MYN, BB2_MYN &
6844       &      /2.53,5.42,3.41E1,6.13/
6845
6846         DATA TPC1, TPC2, TPC3, TPC4, TPC5 &
6847       &      /-4.0,-8.1,-12.7,-17.8,-22.4/
6848
6849
6850         DATA EPSDEL, EPSDEL2 /0.1E-03,0.1E-03/
6851
6852         DATA DT0L, DT0I /1.E20,1.E20/
6853
6854         DOUBLE PRECISION :: DEL1_d , DEL2_d, RW_d , PW_d, RI_d, PI_d, D1N_d, D2N_d, &
6855                                                 VR1_d(NKR)
6856
6857  sfndummy = 0.0
6858  B12_MY = 0.0
6859  B11_MY = 0.0
6860
6861   I_ABERGERON=0
6862   I_BERGERON=0
6863   COL3=3.0*COL
6864  ITIME=0
6865  KCOND=0
6866  DT_WATER_COND=0.4
6867  DT_WATER_EVAP=0.4
6868  ITIME=0
6869  KCOND=0
6870  DT0LREF=0.2
6871  DTLREF=0.4
6872
6873  NR=NKR
6874  NRM=NKR-1
6875  DT=DTCOND
6876  DTT=DTCOND
6877  XRAD=0.
6878
6879   CWHUCM=0.
6880  XRAD=0.
6881  B6=CWHUCM*GAM-XRAD
6882  B8L=1./ROR
6883  B8I=1./ROR
6884  RORI=1./ROR
6885
6886  DO KR=1,NKR
6887     FF1_OLD(KR)=FF1(KR)
6888     SUPINTW(KR)=0.0
6889     DSUPINTW(KR)=0.0
6890  ENDDO
6891
6892  TPN=TT
6893  QPN=QQ
6894  DO KR=1,NKR
6895      FI1(KR)=FF1(KR)
6896  END DO
6897
6898  ! WARM MP (CONDENSATION OR EVAPORATION) (BEGIN)
6899  TIMENEW=0.
6900  ITIME=0
6901
6902  TOLD = TPN
6903  QOLD = QPN
6904  R1D = R1
6905  R1ND = R1D
6906  SFNL = 0.0
6907  SFN11 = 0.0
6908
6909  56  ITIME = ITIME+1
6910  TIMEREV = DT-TIMENEW
6911  TIMEREV = DT-TIMENEW
6912  DEL1 = DEL1N
6913  DEL2 = DEL2N
6914  DEL1S = DEL1N
6915  DEL2S = DEL2N
6916  TPS = TPN
6917  QPS = QPN
6918
6919  IF(ISYM1 == 1)THEN
6920         FL1 = 0.0
6921         VR1_d = VR1
6922         CALL JERRATE_KS &
6923                                 (R1D,TPS,PP,VR1_d,RLEC,RO1BL,B11_MY,1,1,fl1,NKR,ICEMAX)
6924         sfndummy(1)=SFN11
6925         CALL JERTIMESC_KS(FI1,R1D,SFNDUMMY,B11_MY,B8L,1,NKR,ICEMAX,COL)
6926         SFN11 = sfndummy(1)
6927  ENDIF
6928
6929  SFN12 = 0.0
6930  SFNL = SFN11 + SFN12
6931  SFNI = 0.
6932
6933  B5L=BB1_MY/TPS/TPS
6934  B5I=BB2_MY/TPS/TPS
6935  B7L=B5L*B6
6936  B7I=B5I*B6
6937  DOPL=1.+DEL1S
6938  DOPI=1.+DEL2S
6939  RW=(OPER2(QPS)+B5L*AL1)*DOPL*SFNL
6940  RI=(OPER2(QPS)+B5L*AL2)*DOPL*SFNI
6941  QW=B7L*DOPL
6942  PW=(OPER2(QPS)+B5I*AL1)*DOPI*SFNL
6943  PI=(OPER2(QPS)+B5I*AL2)*DOPI*SFNI
6944  QI=B7I*DOPI
6945
6946  IF(RW.NE.RW .or. PW.NE.PW)THEN
6947     print*, 'NaN In ONECOND1'
6948     call wrf_error_fatal("fatal error in ONECOND1 (RW or PW are NaN), model stop")
6949  ENDIF
6950
6951  KCOND=10
6952  IF(DEL1N >= 0.0D0) KCOND=11
6953
6954    IF(KCOND == 11) THEN
6955           DTNEWL = DT
6956       DTNEWL = DT
6957       DTNEWL = AMIN1(DTNEWL,TIMEREV)
6958       TIMENEW = TIMENEW + DTNEWL
6959       DTT = DTNEWL
6960
6961           IF (DTT < 0.0) call wrf_error_fatal("fatal error in ONECOND1-DEL1N>0:(DTT<0), model stop")
6962
6963         DEL1_d = DEL1
6964         DEL2_d = DEL2
6965         RW_d = RW
6966         PW_d = PW
6967         RI_d = RI
6968         PI_d = PI
6969
6970             CALL JERSUPSAT_KS(DEL1_d,DEL2_d,DEL1N,DEL2N, &
6971                                                   RW_d,PW_d,RI_d,PI_d, &
6972                                                   DTT,D1N_d,D2N_d,0.0,0.0, &
6973                                                   ISYM1,ISYM2,ISYM3,ISYM4,ISYM5)
6974         DEL1 = DEL1_d
6975         DEL2 = DEL2_d
6976         RW = RW_d
6977         PW = PW_d
6978         RI = RI_d
6979         PI = PI_d
6980         D1N = D1N_d
6981         D2N = D2N_d
6982
6983         IF(ISYM1 == 1)THEN
6984                 IDROP = ISYM1
6985                 CALL JERDFUN_KS(R1D, R1ND, B11_MY, FI1, PSI1, fl1, D1N, &
6986                                                         ISYM1, 1, 1, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 1, Iin, Jin ,Kin, Itimestep)
6987         ENDIF
6988
6989         IF((DEL1.GT.0.AND.DEL1N.LT.0) &
6990                 &.AND.ABS(DEL1N).GT.EPSDEL) THEN
6991                         call wrf_error_fatal("fatal error in ONECOND1-1 (DEL1.GT.0.AND.DEL1N.LT.0), model stop")
6992         ENDIF
6993
6994     ! IN CASE : KCOND.EQ.11
6995     ELSE
6996
6997             ! EVAPORATION - ONLY WATER
6998             ! IN CASE : KCOND.NE.11
6999         DTIMEO = DT
7000       DTNEWL = DT
7001       DTNEWL = AMIN1(DTNEWL,TIMEREV)
7002       TIMENEW = TIMENEW + DTNEWL
7003       DTT = DTNEWL
7004
7005             IF (DTT < 0.0) call wrf_error_fatal("fatal error in ONECOND1-DEL1N<0:(DTT<0), model stop")
7006
7007             DEL1_d = DEL1
7008             DEL2_d = DEL2
7009             RW_d = RW
7010             PW_d = PW
7011             RI_d = RI
7012             PI_d = PI
7013             CALL JERSUPSAT_KS(DEL1_d,DEL2_d,DEL1N,DEL2N, &
7014                                           RW_d,PW_d,RI_d,PI_d, &
7015                                           DTT,D1N_d,D2N_d,0.0,0.0, &
7016                                           ISYM1,ISYM2,ISYM3,ISYM4,ISYM5)
7017         DEL1 = DEL1_d
7018         DEL2 = DEL2_d
7019         RW = RW_d
7020         PW = PW_d
7021         RI = RI_d
7022         PI = PI_d
7023         D1N = D1N_d
7024         D2N = D2N_d
7025
7026       IF(ISYM1 == 1)THEN
7027               IDROP = ISYM1
7028               CALL JERDFUN_KS(R1D, R1ND, B11_MY, &
7029                                               FI1, PSI1, fl1, D1N, &
7030                                                     ISYM1, 1, 1, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 1, Iin, Jin ,Kin, Itimestep)
7031       ENDIF
7032
7033       IF((DEL1.LT.0.AND.DEL1N.GT.0) &
7034         .AND.ABS(DEL1N).GT.EPSDEL) THEN
7035          call wrf_error_fatal("fatal error in ONECOND1-2 (DEL1.LT.0.AND.DEL1N.GT.0), model stop")
7036       ENDIF
7037
7038     ENDIF
7039
7040
7041  RMASSLBB=0.
7042  RMASSLAA=0.
7043
7044  ! ... before JERNEWF (ONLY WATER)
7045  DO K=1,NKR
7046   FI1_K = FI1(K)
7047   R1_K = R1(K)
7048   FI1R1 = FI1_K*R1_K*R1_K
7049   RMASSLBB = RMASSLBB+FI1R1
7050  ENDDO
7051  RMASSLBB = RMASSLBB*COL3*RORI
7052  IF(RMASSLBB.LE.0.) RMASSLBB=0.
7053  ! ... after JERNEWF (ONLY WATER)
7054  DO K=1,NKR
7055   FI1_K=PSI1(K)
7056   R1_K=R1(K)
7057   FI1R1=FI1_K*R1_K*R1_K
7058   RMASSLAA=RMASSLAA+FI1R1
7059  END DO
7060  RMASSLAA=RMASSLAA*COL3*RORI
7061  IF(RMASSLAA.LE.0.) RMASSLAA=0.
7062
7063  DELMASSL1 = RMASSLAA - RMASSLBB
7064  QPN = QPS - DELMASSL1
7065  DAL1 = AL1
7066  TPN = TPS + DAL1*DELMASSL1
7067
7068  IF(ABS(DAL1*DELMASSL1) > 3.0 )THEN
7069         print*,"ONECOND1-in(start)"
7070         print*,"I=",Iin,"J=",Jin,"Kin",Kin,"W",w_in,"DX",dx_in
7071         print*,"DELMASSL1",DELMASSL1,"DT",DTT
7072         print*,"DEL1N,DEL2N,DEL1,DEL2,D1N,D2N,RW,PW,RI,PI,DT"
7073         print*,DEL1N,DEL2N,DEL1,DEL2,D1N,D2N,RW,PW,RI,PI,DTT
7074         print*,"TPS",TPS,"QPS",QPS
7075         print*,'FI1 before',FI1,'PSI1 after',PSI1
7076         print*,"ONECOND1-in(end)"
7077         call wrf_error_fatal("fatal error in ONECOND1-in (ABS(DAL1*DELMASSL1) > 3.0), model stop")
7078  ENDIF
7079
7080  ! ... SUPERSATURATION (ONLY WATER)
7081  ARGEXP=-BB1_MY/TPN
7082  ES1N=AA1_MY*DEXP(ARGEXP)
7083  ARGEXP=-BB2_MY/TPN
7084  ES2N=AA2_MY*DEXP(ARGEXP)
7085  EW1N=OPER3(QPN,PP)
7086  IF(ES1N == 0.0D0)THEN
7087           DEL1N=0.5
7088           DIV1=1.5
7089  ELSE
7090           DIV1 = EW1N/ES1N
7091           DEL1N = EW1N/ES1N-1.
7092  END IF
7093  IF(ES2N == 0.0D0)THEN
7094           DEL2N=0.5
7095           DIV2=1.5
7096  ELSE
7097           DEL2N = EW1N/ES2N-1.
7098           DIV2 = EW1N/ES2N
7099  END IF
7100  IF(ISYM1 == 1) THEN
7101         DO KR=1,NKR
7102            SUPINTW(KR)=SUPINTW(KR)+B11_MY(KR)*D1N
7103            DD1N=D1N
7104            DB11_MY=B11_MY(KR)
7105            DSUPINTW(KR)=DSUPINTW(KR)+DB11_MY*DD1N
7106         ENDDO
7107  ENDIF
7108
7109  ! ... REPEATE TIME STEP (ONLY WATER: CONDENSATION OR EVAPORATION)
7110  IF(TIMENEW.LT.DT) GOTO 56
7111
7112  57  CONTINUE
7113
7114  IF(ISYM1 == 1) THEN
7115     CALL JERDFUN_NEW_KS (R1D,R1ND,SUPINTW, &
7116                                         FF1_OLD,PSI1, &
7117                                         TPN,IDROP,FR_LIM, NKR, COL,1,Iin,Jin,Kin,Itimestep)
7118  ENDIF ! in case ISYM1/=0
7119
7120  RMASSLAA=0.0
7121  RMASSLBB=0.0
7122
7123  DO K=1,NKR
7124   FI1_K=FF1_OLD(K)
7125   R1_K=R1(K)
7126   FI1R1=FI1_K*R1_K*R1_K
7127   RMASSLBB=RMASSLBB+FI1R1
7128  ENDDO
7129  RMASSLBB=RMASSLBB*COL3*RORI
7130  IF(RMASSLBB.LT.0.0) RMASSLBB=0.0
7131
7132  DO K=1,NKR
7133   FI1_K=PSI1(K)
7134   R1_K=R1(K)
7135   FI1R1=FI1_K*R1_K*R1_K
7136   RMASSLAA=RMASSLAA+FI1R1
7137  ENDDO
7138  RMASSLAA=RMASSLAA*COL3*RORI
7139  IF(RMASSLAA.LT.0.0) RMASSLAA=0.0
7140  DELMASSL1 = RMASSLAA-RMASSLBB
7141
7142  QPN = QOLD - DELMASSL1
7143  DAL1 = AL1
7144  TPN = TOLD + DAL1*DELMASSL1
7145
7146  IF(ABS(DAL1*DELMASSL1) > 5.0 )THEN
7147         print*,"ONECOND1-out (start)"
7148         print*,"I=",Iin,"J=",Jin,"Kin",Kin,"W",w_in,"DX",dx_in
7149         print*,"DEL1N,DEL2N,D1N,D2N,RW,PW,RI,PI,DT"
7150         print*,DEL1N,DEL2N,D1N,D2N,RW,PW,RI,PI,DTT
7151         print*,"I=",Iin,"J=",Jin,"Kin",Kin
7152         print*,"TPS=",TPS,"QPS=",QPS,"delmassl1",delmassl1
7153         print*,"DAL1=",DAL1
7154         print*,RMASSLBB,RMASSLAA
7155         print*,"FI1",FI1
7156         print*,"PSI1",PSI1
7157         print*,"ONECOND1-out (end)"
7158         IF(ABS(DAL1*DELMASSL1) > 5.0 )THEN
7159                 call wrf_error_fatal("fatal error in ONECOND1-out (ABS(DAL1*DELMASSL1) > 5.0), model stop")
7160         ENDIF
7161  ENDIF
7162
7163  ! ... SUPERSATURATION
7164  ARGEXP=-BB1_MY/TPN
7165  ES1N=AA1_MY*DEXP(ARGEXP)
7166  ARGEXP=-BB2_MY/TPN
7167  ES2N=AA2_MY*DEXP(ARGEXP)
7168  EW1N=OPER3(QPN,PP)
7169  IF(ES1N == 0.0D0)THEN
7170         DEL1N=0.5
7171         DIV1=1.5
7172         call wrf_error_fatal("fatal error in ONECOND1 (ES1N.EQ.0), model stop")
7173  ELSE
7174     DIV1=EW1N/ES1N
7175     DEL1N=EW1N/ES1N-1.
7176  END IF
7177  IF(ES2N.EQ.0)THEN
7178     DEL2N=0.5
7179     DIV2=1.5
7180    call wrf_error_fatal("fatal error in ONECOND1 (ES2N.EQ.0), model stop")
7181  ELSE
7182     DEL2N=EW1N/ES2N-1.
7183     DIV2=EW1N/ES2N
7184  END IF
7185
7186  TT=TPN
7187  QQ=QPN
7188  DO KR=1,NKR
7189   FF1(KR)=PSI1(KR)
7190  ENDDO
7191
7192  RETURN
7193  END SUBROUTINE ONECOND1
7194  ! +----------------------------------------------------------------------------+
7195  SUBROUTINE ONECOND2 &
7196                                          & (TT,QQ,PP,ROR  &
7197                                          & ,VR2,VR3,VR4,VR5,PSINGLE &
7198                                          & ,DEL1N,DEL2N,DIV1,DIV2 &
7199                                          & ,FF2,PSI2,R2,RIEC,RO2BL &
7200                                          & ,FF3,PSI3,R3,RSEC,RO3BL &
7201                                          & ,FF4,PSI4,R4,RGEC,RO4BL &
7202                                          & ,FF5,PSI5,R5,RHEC,RO5BL &
7203                                          & ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
7204                                          & ,C1_MEY,C2_MEY &
7205                                          & ,COL,DTCOND,ICEMAX,NKR &
7206                                          & ,ISYM1,ISYM2,ISYM3,ISYM4,ISYM5, &
7207                                                 Iin,Jin,Kin,W_in,DX_in,Itimestep)
7208
7209     IMPLICIT NONE
7210
7211        INTEGER NKR,ICEMAX,ISYM1, Iin, Jin, Kin, Itimestep
7212        REAL    COL,VR2(NKR,ICEMAX),VR3(NKR),VR4(NKR) &
7213       &           ,VR5(NKR),PSINGLE &
7214       &       ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
7215       &       ,DTCOND,W_in,DX_in
7216
7217        REAL C1_MEY,C2_MEY
7218        INTEGER I_MIXCOND,I_MIXEVAP,I_ABERGERON,I_BERGERON, &
7219       & KR,ICE,ITIME,ICM,KCOND,NR,NRM,INUC, &
7220       & ISYM2(ICEMAX),ISYM3,ISYM4,ISYM5,KP,KLIMIT, &
7221       & KM,ITER,KLIMITL,KLIMITG,KLIMITH,KLIMITI_1,KLIMITI_2,KLIMITI_3, &
7222       & NCRITI
7223        REAL AL1,AL2,D,GAM,POD, &
7224       & RV_MY,CF_MY,D_MYIN,AL1_MY,AL2_MY,ALC,DT0LREF,DTLREF, &
7225       & A1_MYN, BB1_MYN, A2_MYN, BB2_MYN,DT,DTT,XRAD, &
7226       & TPC1, TPC2, TPC3, TPC4, TPC5, &
7227       & EPSDEL, DT0L, DT0I, &
7228       & ROR, &
7229       & DEL1NUC,DEL2NUC, &
7230       & CWHUCM,B6,B8L,B8I,RMASSGL,RMASSGI, &
7231       & DEL1,DEL2,DEL1S,DEL2S, &
7232       & TIMENEW,TIMEREV,SFN11,SFN12, &
7233       & SFNL,SFNI,B5L,B5I,B7L,B7I,DOPL,DOPI,OPERQ,RW,RI,QW,PW, &
7234       & PI,QI,D1N0,D2N0,DTNEWL,DTNEWL1,D1N,D2N, &
7235       & DEL_R1,DT0L0,DT0I0,SFN31,SFN32,SFN52, &
7236       & SFNII1,SFN21,SFN22,DTNEWI3,DTNEWI4,DTNEWI5,DTNEWI2_1, &
7237       & DTNEWI2_2,DTNEWI1,DEL_R2,DEL_R4,DEL_R5,SFN41,SFN42, &
7238       & SNF51,DTNEWI2_3,DTNEWI2,DTNEWI_1,DTNEWI_2, &
7239       & DTNEWL0,DTNEWG1,DTNEWH1,DTNEWI_3, &
7240       & DTNEWL2,SFN51,SFNII2,DEL_R3,DTNEWI
7241         REAL DT_WATER_COND,DT_WATER_EVAP,DT_ICE_COND,DT_ICE_EVAP, &
7242       &  DT_MIX_COND,DT_MIX_EVAP,DT_MIX_BERGERON,DT_MIX_ANTIBERGERON
7243
7244         INTEGER K
7245
7246        DOUBLE PRECISION DD1N,DB11_MY,DAL1,DAL2
7247        DOUBLE PRECISION COL3,RORI,TPN,TPS,QPN,QPS,TOLD,QOLD &
7248       &                  ,FI1_K,FI2_K,FI3_K,FI4_K,FI5_K &
7249       &                  ,R1_K,R2_K,R3_K,R4_K,R5_K &
7250       &                  ,FI1R1,FI2R2,FI3R3,FI4R4,FI5R5 &
7251       &                  ,RMASSLAA,RMASSLBB,RMASSIAA,RMASSIBB &
7252       &                  ,ES1N,ES2N,EW1N,ARGEXP &
7253       &                  ,TT,QQ,PP &
7254       &                  ,DEL1N,DEL2N,DIV1,DIV2 &
7255       &                  ,OPER2,OPER3,AR1,AR2
7256
7257         DOUBLE PRECISION DELTAQ1,DELMASSI1,DELMASSL1
7258
7259          CHARACTER*70 CPRINT
7260
7261  ! CRYSTALS
7262
7263         REAL R2(NKR,ICEMAX) &
7264       &           ,RIEC(NKR,ICEMAX) &
7265       &           ,RO2BL(NKR,ICEMAX) &
7266       &           ,FI2(NKR,ICEMAX),PSI2(NKR,ICEMAX) &
7267       &           ,FF2(NKR,ICEMAX) &
7268       &           ,B21_MY(NKR,ICEMAX),B22_MY(NKR,ICEMAX)
7269
7270  ! SNOW
7271          REAL R3(NKR) &
7272       &           ,RSEC(NKR),RO3BL(NKR) &
7273       &           ,FI3(NKR),FF3(NKR),PSI3(NKR) &
7274       &           ,B31_MY(NKR),B32_MY(NKR)
7275
7276  ! GRAUPELS
7277
7278          REAL R4(NKR) &
7279       &           ,RGEC(NKR),RO4BL(NKR) &
7280       &           ,FI4(NKR),FF4(NKR),PSI4(NKR) &
7281       &           ,B41_MY(NKR),B42_MY(NKR)
7282
7283  ! HAIL
7284          REAL R5(NKR) &
7285       &           ,RHEC(NKR),RO5BL(NKR) &
7286       &           ,FI5(NKR),FF5(NKR),PSI5(NKR) &
7287       &           ,B51_MY(NKR),B52_MY(NKR)
7288
7289  ! CCN
7290
7291         REAL DTIMEG(NKR),DTIMEH(NKR)
7292
7293         REAL DEL2D(ICEMAX),DTIMEO(NKR),DTIMEL(NKR) &
7294
7295       &           ,DTIMEI_1(NKR),DTIMEI_2(NKR),DTIMEI_3(NKR) &
7296       &           ,SFNI1(ICEMAX),SFNI2(ICEMAX) &
7297       &           ,TIMESTEPD(NKR) &
7298       &           ,FI1REF(NKR),PSI1REF(NKR) &
7299       &           ,FI2REF(NKR,ICEMAX),PSI2REF(NKR,ICEMAX)&
7300       &           ,FCCNRREF(NKR)
7301
7302         REAL :: FL1(NKR), sfndummy(3), FL3(NKR), FL4(NKR), FL5(NKR), &
7303                                         R2N(NKR,ICEMAX), R3N(NKR), R4N(NKR), R5N(NKR)
7304         INTEGER :: IDROP, ISYMICE
7305         DOUBLE PRECISION :: R2D(NKR,ICEMAX),R3D(NKR), R4D(NKR), R5D(NKR), &
7306                             R2ND(NKR,ICEMAX),R3ND(NKR), R4ND(NKR), R5ND(NKR), &
7307                             VR2_d(NKR,ICEMAX), VR3_d(NKR), VR4_d(NKR), VR5_d(NKR)
7308
7309         OPER2(AR1)=0.622/(0.622+0.378*AR1)/AR1
7310         OPER3(AR1,AR2)=AR1*AR2/(0.622+0.378*AR1)
7311
7312         DATA AL1 /2500./, AL2 /2834./, D /0.211/ &
7313       &      ,GAM /1.E-4/, POD /10./
7314
7315         DATA RV_MY,CF_MY,D_MYIN,AL1_MY,AL2_MY &
7316       &      /461.5,0.24E-1,0.211E-4,2.5E6,2.834E6/
7317
7318         DATA A1_MYN, BB1_MYN, A2_MYN, BB2_MYN &
7319       &      /2.53,5.42,3.41E1,6.13/
7320
7321         DATA TPC1, TPC2, TPC3, TPC4, TPC5 &
7322       &      /-4.0,-8.1,-12.7,-17.8,-22.4/
7323
7324         DATA EPSDEL/0.1E-03/
7325
7326         DATA DT0L, DT0I /1.E20,1.E20/
7327
7328         DOUBLE PRECISION :: DEL1_d, DEL2_d, RW_d, PW_d, RI_d, PI_d, D1N_d, D2N_d
7329
7330         B22_MY = 0.0
7331         B32_MY = 0.0
7332         B42_MY = 0.0
7333         B52_MY = 0.0
7334
7335         B21_MY = 0.0
7336         B31_MY = 0.0
7337         B41_MY = 0.0
7338         B51_MY = 0.0
7339
7340         SFNDUMMY = 0.0
7341         R2D = R2
7342         R3D = R3
7343         R4D = R4
7344         R5D = R5
7345         R2ND = R2D
7346         R3ND = R3D
7347         R4ND = R4D
7348         R5ND = R5D
7349
7350         SFNI1 = 0.0
7351         SFN31 = 0.0
7352         SFN41 = 0.0
7353         SFN51 = 0.0
7354
7355         I_MIXCOND=0
7356         I_MIXEVAP=0
7357         I_ABERGERON=0
7358         I_BERGERON=0
7359         COL3=3.0*COL
7360         ICM=ICEMAX
7361         ITIME=0
7362         KCOND=0
7363         DT_WATER_COND=0.4
7364         DT_WATER_EVAP=0.4
7365         DT_ICE_COND=0.4
7366         DT_ICE_EVAP=0.4
7367         DT_MIX_COND=0.4
7368         DT_MIX_EVAP=0.4
7369         DT_MIX_BERGERON=0.4
7370         DT_MIX_ANTIBERGERON=0.4
7371         ICM=ICEMAX
7372         ITIME=0
7373         KCOND=0
7374         DT0LREF=0.2
7375         DTLREF=0.4
7376
7377         NR=NKR
7378         NRM=NKR-1
7379         DT=DTCOND
7380         DTT=DTCOND
7381         XRAD=0.
7382
7383         CWHUCM=0.
7384         XRAD=0.
7385         B6=CWHUCM*GAM-XRAD
7386         B8L=1./ROR
7387         B8I=1./ROR
7388         RORI=1./ROR
7389
7390         TPN=TT
7391         QPN=QQ
7392
7393         DO ICE=1,ICEMAX
7394                  SFNI1(ICE)=0.
7395                  SFNI2(ICE)=0.
7396                  DEL2D(ICE)=0.
7397         ENDDO
7398
7399         TIMENEW = 0.
7400         ITIME = 0
7401
7402  ! ONLY ICE (CONDENSATION OR EVAPORATION) :
7403
7404    46 ITIME = ITIME + 1
7405
7406           TIMEREV=DT-TIMENEW
7407
7408           DEL1=DEL1N
7409           DEL2=DEL2N
7410           DEL1S=DEL1N
7411           DEL2S=DEL2N
7412           DEL2D(1)=DEL2N
7413           DEL2D(2)=DEL2N
7414           DEL2D(3)=DEL2N
7415           TPS=TPN
7416           QPS=QPN
7417           DO KR=1,NKR
7418                  FI3(KR)=PSI3(KR)
7419                  FI4(KR)=PSI4(KR)
7420                  FI5(KR)=PSI5(KR)
7421                  DO ICE=1,ICEMAX
7422                         FI2(KR,ICE)=PSI2(KR,ICE)
7423                  ENDDO
7424           ENDDO
7425
7426           IF(sum(ISYM2) > 0) THEN
7427             FL1 = 0.0
7428             VR2_d = VR2
7429           ! ... ice crystals
7430                   CALL JERRATE_KS (R2D,TPS,PP,VR2_d,RIEC,RO2BL,B21_MY,3,2,fl1,NKR,ICEMAX)
7431
7432                   CALL JERTIMESC_KS (FI2,R2D,SFNI1,B21_MY,B8I,ICM,NKR,ICEMAX,COL)
7433           ENDIF
7434           IF(ISYM3 == 1) THEN
7435             FL3 = 0.0
7436             VR3_d = VR3
7437           ! ... snow
7438                   CALL JERRATE_KS (R3D,TPS,PP,VR3_d,RSEC,RO3BL,B31_MY,1,3,fl3,NKR,ICEMAX)
7439
7440                   sfndummy(1) = SFN31
7441                   CALL JERTIMESC_KS(FI3,R3D,SFNDUMMY,B31_MY,B8I,1,NKR,ICEMAX,COL)
7442                   SFN31 = sfndummy(1)
7443           ENDIF
7444           IF(ISYM4 == 1) THEN
7445             FL4 = 0.0
7446             VR4_d = VR4
7447           ! ... graupel
7448                   CALL JERRATE_KS(R4D,TPS,PP,VR4_d,RGEC,RO4BL,B41_MY,1,2,fl4,NKR,ICEMAX)
7449
7450                   sfndummy(1) = SFN41
7451                   CALL JERTIMESC_KS(FI4,R4D,SFNDUMMY,B41_MY,B8I,1,NKR,ICEMAX,COL)
7452                   SFN41 = sfndummy(1)
7453           ENDIF
7454           IF(ISYM5 == 1) THEN
7455             FL5 = 0.0
7456             VR5_d = VR5
7457           ! ... hail
7458                   CALL JERRATE_KS(R5D,TPS,PP,VR5_d,RHEC,RO5BL,B51_MY,1,2,fl5,NKR,ICEMAX)
7459
7460                   sfndummy(1) = SFN51
7461                   CALL JERTIMESC_KS(FI5,R5D,SFNDUMMY,B51_MY,B8I,1,NKR,ICEMAX,COL)
7462                   SFN51 = sfndummy(1)
7463           ENDIF
7464
7465
7466           SFNII1 = SFNI1(1) + SFNI1(2) + SFNI1(3)
7467           SFN21 = SFNII1 + SFN31 + SFN41 + SFN51
7468           SFNL = 0.0
7469           SFN22 = 0.0
7470           SFNI = SFN21 + SFN22
7471
7472         B5L=BB1_MY/TPS/TPS
7473         B5I=BB2_MY/TPS/TPS
7474         B7L=B5L*B6
7475         B7I=B5I*B6
7476         DOPL=1.+DEL1S
7477         DOPI=1.+DEL2S
7478         OPERQ=OPER2(QPS)
7479         RW=(OPERQ+B5L*AL1)*DOPL*SFNL
7480         QW=B7L*DOPL
7481         PW=(OPERQ+B5I*AL1)*DOPI*SFNL
7482         RI=(OPERQ+B5L*AL2)*DOPL*SFNI
7483         PI=(OPERQ+B5I*AL2)*DOPI*SFNI
7484         QI=B7I*DOPI
7485
7486      KCOND=20
7487      IF(DEL2N > 0.0) KCOND=21
7488
7489         IF(RW.NE.RW .or. PW.NE.PW)THEN
7490             print*, 'NaN In ONECOND2'
7491             call wrf_error_fatal("fatal error in ONECOND2 (RW or PW are NaN), model stop")
7492         ENDIF
7493
7494  ! ... (ONLY ICE)
7495         IF(KCOND == 21)  THEN
7496                         ! ... ONLY_ICE: CONDENSATION
7497        DTNEWL = DT
7498        DTNEWL = AMIN1(DTNEWL,TIMEREV)
7499        TIMENEW = TIMENEW + DTNEWL
7500        DTT = DTNEWL
7501
7502                         IF (DTT < 0.0) call wrf_error_fatal("fatal error in ONECOND2-DEL2N>0:(DTT<0), model stop")
7503
7504                         DEL1_d = DEL1
7505                         DEL2_d = DEL2
7506                         RW_d = RW
7507                         PW_d = PW
7508                         RI_d = RI
7509                         PI_d = PI
7510                         CALL JERSUPSAT_KS(DEL1_d,DEL2_d,DEL1N,DEL2N, &
7511                                                                                           RW_d,PW_d,RI_d,PI_d, &
7512                                                                                           DTT,D1N_d,D2N_d,0.0,0.0, &
7513                                                                                           ISYM1,ISYM2,ISYM3,ISYM4,ISYM5)
7514                         DEL1 = DEL1_d
7515                         DEL2 = DEL2_d
7516                         RW = RW_d
7517                         PW = PW_d
7518                         RI = RI_d
7519                         PI = PI_d
7520                         D1N = D1N_d
7521                         D2N = D2N_d
7522
7523                         IF(sum(ISYM2) > 0)THEN
7524                                 IDROP = 0
7525                                 FL1 = 0.0
7526                                 IF(ISYM2(1) == 1) THEN
7527                                   CALL JERDFUN_KS(R2D(:,1), R2ND(:,1), B21_MY(:,1), &
7528                                                                   FI2(:,1), PSI2(:,1), fl1, D2N, &
7529                                                                   ISYM2(1), ICM, 1, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 21, Iin, Jin ,Kin, Itimestep)
7530                                 ENDIF
7531                                 IF(ISYM2(2) == 1) THEN
7532                                   CALL JERDFUN_KS(R2D(:,2), R2ND(:,2), B21_MY(:,2), &
7533                                                                   FI2(:,2), PSI2(:,2), fl1, D2N, &
7534                                                                   ISYM2(2), ICM, 2, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 22, Iin, Jin ,Kin, Itimestep)
7535                                 ENDIF
7536                                 IF(ISYM2(3) == 1) THEN
7537                                   CALL JERDFUN_KS(R2D(:,3), R2ND(:,3), B21_MY(:,3), &
7538                                                                   FI2(:,3), PSI2(:,3), fl1, D2N, &
7539                                                                   ISYM2(3), ICM, 3, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 23, Iin, Jin ,Kin, Itimestep)
7540
7541                                 ! IN CASE : ISYM2.NE.0
7542                                 ENDIF
7543                         ENDIF
7544
7545                         IF(ISYM3 == 1) THEN
7546                                 IDROP = 0
7547                                 FL3 = 0.0
7548                                 CALL JERDFUN_KS(R3D, R3ND, B31_MY, &
7549                                                                 FI3, PSI3, fl3, D2N, &
7550                                                                 ISYM3, 1, 3, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 3, Iin, Jin ,Kin, Itimestep)
7551                         ENDIF
7552
7553
7554                         IF(ISYM4 == 1) THEN
7555                                 IDROP = 0
7556                                 FL4 = 0.0
7557                                 CALL JERDFUN_KS(R4D, R4ND, B41_MY, &
7558                                                                 FI4, PSI4, fl4, D2N, &
7559                                                                 ISYM4, 1, 4, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 4, Iin, Jin ,Kin, Itimestep)
7560                                 ! IN CASE : ISYM4.NE.0
7561                         ENDIF
7562
7563                         IF(ISYM5 == 1) THEN
7564                          IDROP = 0
7565                          FL5 = 0.0
7566                          CALL JERDFUN_KS(R5D, R5ND, B51_MY, &
7567                                                         FI5, PSI5, fl5, D2N, &
7568                                                         ISYM5, 1, 5, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 5, Iin, Jin ,Kin, Itimestep)
7569                         ! IN CASE : ISYM5.NE.0
7570                         ENDIF
7571
7572                         IF((DEL2.GT.0.AND.DEL2N.LT.0) &
7573                         .AND.ABS(DEL2N).GT.EPSDEL) THEN
7574                  call wrf_error_fatal("fatal error in module_mp_fast_sbm (DEL2.GT.0.AND.DEL2N.LT.0), model stop")
7575                         ENDIF
7576
7577           ELSE
7578           ! ... IN CASE KCOND.NE.21
7579                         ! ONLY ICE: EVAPORATION
7580         DTNEWL = DT
7581         DTNEWL = AMIN1(DTNEWL,TIMEREV)
7582         TIMENEW = TIMENEW + DTNEWL
7583         DTT = DTNEWL
7584
7585                           IF (DTT < 0.0) call wrf_error_fatal("fatal error in ONECOND2-DEL2N<0:(DTT<0), model stop")
7586
7587                         DEL1_d = DEL1
7588                         DEL2_d = DEL2
7589                         RW_d = RW
7590                         PW_d = PW
7591                         RI_d = RI
7592                         PI_d = PI
7593                         CALL JERSUPSAT_KS(DEL1_d,DEL2_d,DEL1N,DEL2N, &
7594                                                                                                 RW_d,PW_d,RI_d,PI_d, &
7595                                                                                         DTT,D1N_d,D2N_d,0.0,0.0, &
7596                                                                                         ISYM1,ISYM2,ISYM3,ISYM4,ISYM5)
7597                         DEL1 = DEL1_d
7598                         DEL2 = DEL2_d
7599                         RW = RW_d
7600                         PW = PW_d
7601                         RI = RI_d
7602                         PI = PI_d
7603                         D1N = D1N_d
7604                         D2N = D2N_d
7605
7606                         IF(sum(ISYM2) > 0) THEN
7607                           IDROP = 0
7608                           FL1 = 0.0
7609                           IF(ISYM2(1)==1)THEN
7610                                 CALL JERDFUN_KS(R2D(:,1), R2ND(:,1), B21_MY(:,1), &
7611                                                             FI2(:,1), PSI2(:,1), fl1, D2N, &
7612                                                             ISYM2(1), ICM, 1, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 21, Iin, Jin ,Kin, Itimestep)
7613                           ENDIF
7614                           IF(ISYM2(2)==1)THEN
7615                         CALL JERDFUN_KS(R2D(:,2), R2ND(:,2), B21_MY(:,2), &
7616                                                             FI2(:,2), PSI2(:,2), fl1, D2N, &
7617                                                                 ISYM2(2), ICM, 2, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 22, Iin, Jin ,Kin, Itimestep)
7618                       ENDIF
7619                           IF(ISYM2(3)==1)THEN
7620                         CALL JERDFUN_KS(R2D(:,3), R2ND(:,3), B21_MY(:,3), &
7621                                                                 FI2(:,3), PSI2(:,3), fl1, D2N, &
7622                                                             ISYM2(3), ICM, 3, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 23, Iin, Jin ,Kin, Itimestep)
7623                          ENDIF
7624                         ENDIF
7625
7626        IF(ISYM3 == 1) THEN
7627                         ! ... SNOW
7628                                 IDROP = 0
7629                                 FL3 = 0.0
7630                                 CALL JERDFUN_KS(R3D, R3ND, B31_MY, &
7631                                                                 FI3, PSI3, fl3, D2N, &
7632                                                                 ISYM3, 1, 3, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 3, Iin, Jin ,Kin, Itimestep)
7633                         ! IN CASE : ISYM3.NE.0
7634        ENDIF
7635
7636      IF(ISYM4 == 1) THEN
7637      ! ... GRAUPELS (ONLY_ICE: EVAPORATION)
7638          ! ... New JERDFUN
7639          IDROP = 0
7640          FL4 = 0.0
7641          CALL JERDFUN_KS(R4D, R4ND, B41_MY, &
7642                          FI4, PSI4, fl4, D2N, &
7643                          ISYM4, 1, 4, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 4, Iin, Jin ,Kin, Itimestep)
7644      ! IN CASE : ISYM4.NE.0
7645      ENDIF
7646
7647        IF(ISYM5 == 1) THEN
7648          ! ... HAIL (ONLY_ICE: EVAPORATION)
7649            ! ... New JERDFUN
7650            IDROP = 0
7651            FL5 = 0.0
7652            CALL JERDFUN_KS(R5D, R5ND, B51_MY, &
7653                            FI5, PSI5, fl5, D2N, &
7654                            ISYM5, 1, 5, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 5, Iin, Jin ,Kin, Itimestep)
7655              ! IN CASE : ISYM5.NE.0
7656        ENDIF
7657
7658        IF((DEL2.LT.0.AND.DEL2N.GT.0) &
7659             .AND.ABS(DEL2N).GT.EPSDEL) THEN
7660              call wrf_error_fatal("fatal error in module_mp_fast_sbm (DEL2.LT.0.AND.DEL2N.GT.0), model stop")
7661        ENDIF
7662
7663                  ! IN CASE : KCOND.NE.21
7664      ENDIF
7665
7666  ! MASSES
7667           RMASSIBB=0.0
7668           RMASSIAA=0.0
7669
7670           DO K=1,NKR
7671                  DO ICE = 1,ICEMAX
7672                         FI2_K = FI2(K,ICE)
7673                         R2_K = R2(K,ICE)
7674                         FI2R2 = FI2_K*R2_K*R2_K
7675                         RMASSIBB = RMASSIBB + FI2R2
7676                  ENDDO
7677                  FI3_K=FI3(K)
7678                  FI4_K=FI4(K)
7679                  FI5_K=FI5(K)
7680                  R3_K=R3(K)
7681                  R4_K=R4(K)
7682                  R5_K=R5(K)
7683                  FI3R3=FI3_K*R3_K*R3_K
7684                  FI4R4=FI4_K*R4_K*R4_K
7685                  FI5R5=FI5_K*R5_K*R5_K
7686                  RMASSIBB=RMASSIBB+FI3R3
7687                  RMASSIBB=RMASSIBB+FI4R4
7688                  RMASSIBB=RMASSIBB+FI5R5
7689           ENDDO
7690           RMASSIBB=RMASSIBB*COL3*RORI
7691           IF(RMASSIBB.LT.0.0) RMASSIBB=0.0
7692
7693           DO K=1,NKR
7694                  DO ICE =1,ICEMAX
7695                         FI2_K=PSI2(K,ICE)
7696                         R2_K=R2(K,ICE)
7697                         FI2R2=FI2_K*R2_K*R2_K
7698                         RMASSIAA=RMASSIAA+FI2R2
7699                  ENDDO
7700                  FI3_K = PSI3(K)
7701                  FI4_K = PSI4(K)
7702                  FI5_K = PSI5(K)
7703                  R3_K=R3(K)
7704                  R4_K=R4(K)
7705                  R5_K=R5(K)
7706                  FI3R3=FI3_K*R3_K*R3_K
7707                  FI4R4=FI4_K*R4_K*R4_K
7708                  FI5R5=FI5_K*R5_K*R5_K
7709                  RMASSIAA=RMASSIAA+FI3R3
7710                  RMASSIAA=RMASSIAA+FI4R4
7711                  RMASSIAA=RMASSIAA+FI5R5
7712           ENDDO
7713                 RMASSIAA = RMASSIAA*COL3*RORI
7714
7715                 IF(RMASSIAA.LT.0.0) RMASSIAA=0.0
7716
7717                 DELMASSI1 = RMASSIAA-RMASSIBB
7718                 QPN = QPS-DELMASSI1
7719                 DAL2 = AL2
7720                 TPN = TPS+DAL2*DELMASSI1
7721
7722           IF(ABS(DAL2*DELMASSI1) > 5.0 )THEN
7723       print*,"ONECOND2-out (start)"
7724       print*,"I=",Iin,"J=",Jin,"Kin",Kin,"W",w_in,"DX",dx_in
7725       print*,"DEL1N,DEL2N,D1N,D2N,RW,PW,RI,PI,DT"
7726       print*,DEL1N,DEL2N,D1N,D2N,RW,PW,RI,PI,DTT
7727       print*,"TPS=",TPS,"QPS=",QPS,"delmassi1",delmassi1
7728       print*,"DAL1=",DAL2
7729       print*,RMASSIBB,RMASSIAA
7730       print*,"FI2_1",FI2(:,1)
7731       print*,"FI2_2",FI2(:,2)
7732       print*,"FI2_3",FI2(:,3)
7733       print*,"FI3",FI3
7734       print*,"FI4",FI4
7735       print*,"FI5",FI5
7736       print*,"PSI2_1",PSI2(:,1)
7737       print*,"PSI2_2",PSI2(:,2)
7738       print*,"PSI2_3",PSI2(:,3)
7739       print*,"PSI3",PSI3
7740       print*,"PSI4",PSI4
7741       print*,"PSI5",PSI5
7742       print*,"ONECOND2-out (end)"
7743       IF(ABS(DAL2*DELMASSI1) > 5.0 )THEN
7744       call wrf_error_fatal("fatal error in ONECOND2-out (ABS(DAL2*DELMASSI1) > 5.0), model stop")
7745                 ENDIF
7746           ENDIF
7747
7748  ! ... SUPERSATURATION
7749           ARGEXP=-BB1_MY/TPN
7750           ES1N=AA1_MY*DEXP(ARGEXP)
7751           ARGEXP=-BB2_MY/TPN
7752           ES2N=AA2_MY*DEXP(ARGEXP)
7753           EW1N=OPER3(QPN,PP)
7754           IF(ES1N == 0.0)THEN
7755            DEL1N=0.5
7756            DIV1=1.5
7757            call wrf_error_fatal("fatal error in ONECOND2 (ES1N.EQ.0), model stop")
7758           ELSE
7759            DIV1=EW1N/ES1N
7760            DEL1N=EW1N/ES1N-1.
7761           END IF
7762           IF(ES2N == 0.0)THEN
7763            DEL2N=0.5
7764            DIV2=1.5
7765            call wrf_error_fatal("fatal error in ONECOND2 (ES2N.EQ.0), model stop")
7766           ELSE
7767            DEL2N=EW1N/ES2N-1.
7768            DIV2=EW1N/ES2N
7769           END IF
7770
7771  !  END OF TIME SPLITTING
7772  ! (ONLY ICE: CONDENSATION OR EVAPORATION)
7773         IF(TIMENEW.LT.DT) GOTO 46
7774
7775                 TT=TPN
7776                 QQ=QPN
7777                 DO KR=1,NKR
7778                         DO ICE=1,ICEMAX
7779                                 FF2(KR,ICE)=PSI2(KR,ICE)
7780                         ENDDO
7781                         FF3(KR)=PSI3(KR)
7782                         FF4(KR)=PSI4(KR)
7783                         FF5(KR)=PSI5(KR)
7784                 ENDDO
7785
7786    RETURN
7787    END SUBROUTINE ONECOND2
7788  ! +----------------------------------------------------------------------------+
7789          SUBROUTINE ONECOND3 &
7790                                                  & (TT,QQ,PP,ROR &
7791                                                  & ,VR1,VR2,VR3,VR4,VR5,PSINGLE &
7792                                                  & ,DEL1N,DEL2N,DIV1,DIV2 &
7793                                                  & ,FF1,PSI1,R1,RLEC,RO1BL &
7794                                                  & ,FF2,PSI2,R2,RIEC,RO2BL &
7795                                                  & ,FF3,PSI3,R3,RSEC,RO3BL &
7796                                                  & ,FF4,PSI4,R4,RGEC,RO4BL &
7797                                                  & ,FF5,PSI5,R5,RHEC,RO5BL &
7798                                                  & ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
7799                                                  & ,C1_MEY,C2_MEY &
7800                                                  & ,COL,DTCOND,ICEMAX,NKR &
7801                                                  & ,ISYM1,ISYM2,ISYM3,ISYM4,ISYM5, &
7802                                                         Iin,Jin,Kin,W_in,DX_in, Itimestep)
7803
7804         IMPLICIT NONE
7805         INTEGER ICEMAX,NKR,KR,ITIME,ICE,KCOND,K &
7806       &           ,ISYM1,ISYM2(ICEMAX),ISYM3,ISYM4,ISYM5, Kin, Iin, Jin, Itimestep
7807         INTEGER KLIMITL,KLIMITG,KLIMITH,KLIMITI_1, &
7808       &  KLIMITI_2,KLIMITI_3
7809         INTEGER I_MIXCOND,I_MIXEVAP,I_ABERGERON,I_BERGERON
7810         REAL ROR,VR1(NKR),VR2(NKR,ICEMAX),VR3(NKR),VR4(NKR) &
7811       &           ,VR5(NKR),PSINGLE &
7812       &           ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
7813       &           ,C1_MEY,C2_MEY &
7814       &           ,COL,DTCOND,W_in,DX_in
7815
7816  ! DROPLETS
7817
7818          REAL R1(NKR)&
7819       &           ,RLEC(NKR),RO1BL(NKR) &
7820       &           ,FI1(NKR),FF1(NKR),PSI1(NKR) &
7821       &           ,B11_MY(NKR),B12_MY(NKR)
7822
7823  ! CRYSTALS
7824
7825         REAL R2(NKR,ICEMAX) &
7826       &           ,RIEC(NKR,ICEMAX) &
7827       &           ,RO2BL(NKR,ICEMAX) &
7828       &           ,FI2(NKR,ICEMAX),PSI2(NKR,ICEMAX) &
7829       &           ,FF2(NKR,ICEMAX) &
7830       &           ,B21_MY(NKR,ICEMAX),B22_MY(NKR,ICEMAX) &
7831       &           ,RATE2(NKR,ICEMAX),DEL_R2M(NKR,ICEMAX)
7832
7833  ! SNOW
7834          REAL R3(NKR) &
7835       &           ,RSEC(NKR),RO3BL(NKR) &
7836       &           ,FI3(NKR),FF3(NKR),PSI3(NKR) &
7837       &           ,B31_MY(NKR),B32_MY(NKR) &
7838       &           ,DEL_R3M(NKR)
7839
7840  ! GRAUPELS
7841
7842          REAL R4(NKR) &
7843       &           ,RGEC(NKR),RO4BL(NKR) &
7844       &           ,FI4(NKR),FF4(NKR),PSI4(NKR) &
7845       &           ,B41_MY(NKR),B42_MY(NKR) &
7846       &           ,DEL_R4M(NKR)
7847
7848  ! HAIL
7849          REAL R5(NKR) &
7850       &           ,RHEC(NKR),RO5BL(NKR) &
7851       &           ,FI5(NKR),FF5(NKR),PSI5(NKR) &
7852       &           ,B51_MY(NKR),B52_MY(NKR) &
7853       &           ,DEL_R5M(NKR)
7854
7855        DOUBLE PRECISION DD1N,DB11_MY,DAL1,DAL2
7856        DOUBLE PRECISION COL3,RORI,TPN,TPS,QPN,QPS,TOLD,QOLD &
7857       &                  ,FI1_K,FI2_K,FI3_K,FI4_K,FI5_K &
7858       &                  ,R1_K,R2_K,R3_K,R4_K,R5_K &
7859       &                  ,FI1R1,FI2R2,FI3R3,FI4R4,FI5R5 &
7860       &                  ,RMASSLAA,RMASSLBB,RMASSIAA,RMASSIBB &
7861       &                  ,ES1N,ES2N,EW1N,ARGEXP &
7862       &                  ,TT,QQ,PP,DEL1N0,DEL2N0 &
7863       &                  ,DEL1N,DEL2N,DIV1,DIV2 &
7864       &                  ,OPER2,OPER3,AR1,AR2
7865
7866         DOUBLE PRECISION DELTAQ1,DELMASSI1,DELMASSL1
7867
7868         REAL A1_MYN, BB1_MYN, A2_MYN, BB2_MYN
7869          DATA A1_MYN, BB1_MYN, A2_MYN, BB2_MYN &
7870       &      /2.53,5.42,3.41E1,6.13/
7871         REAL B8L,B8I,SFN11,SFN12,SFNL,SFNI
7872         REAL B5L,B5I,B7L,B7I,B6,DOPL,DEL1S,DEL2S,DOPI,RW,QW,PW, &
7873       &  RI,PI,QI,SFNI1(ICEMAX),SFNI2(ICEMAX),AL1,AL2
7874         REAL D1N,D2N,DT0L, DT0I,D1N0,D2N0
7875         REAL SFN21,SFN22,SFNII1,SFNII2,SFN31,SFN32,SFN41,SFN42,SFN51, &
7876       &  SFN52
7877         REAL DEL1,DEL2
7878         REAL  TIMEREV,DT,DTT,TIMENEW
7879         REAL DTIMEG(NKR),DTIMEH(NKR),totccn_before,totccn_after
7880
7881         REAL DEL2D(ICEMAX),DTIMEO(NKR),DTIMEL(NKR) &
7882       &           ,DTIMEI_1(NKR),DTIMEI_2(NKR),DTIMEI_3(NKR)
7883         REAL DT_WATER_COND,DT_WATER_EVAP,DT_ICE_COND,DT_ICE_EVAP, &
7884       &  DT_MIX_COND,DT_MIX_EVAP,DT_MIX_BERGERON,DT_MIX_ANTIBERGERON
7885         REAL DTNEWL0,DTNEWL1,DTNEWI1,DTNEWI2_1,DTNEWI2_2,DTNEWI2_3, &
7886       & DTNEWI2,DTNEWI_1,DTNEWI_2,DTNEWI3,DTNEWI4,DTNEWI5, &
7887       & DTNEWL,DTNEWL2,DTNEWG1,DTNEWH1
7888         REAL TIMESTEPD(NKR)
7889
7890         DATA AL1 /2500./, AL2 /2834./
7891         REAL EPSDEL,EPSDEL2
7892         DATA EPSDEL, EPSDEL2 /0.1E-03,0.1E-03/
7893
7894            REAL :: FL1(NKR), FL2(NKR,ICEMAX), FL3(NKR), FL4(NKR), FL5(NKR), SFNDUMMY(3), &
7895                            R1N(NKR), R2N(NKR,ICEMAX), R3N(NKR), R4N(NKR), R5N(NKR)
7896            INTEGER :: IDROP, ICM, ISYMICE
7897            DOUBLE PRECISION :: R1D(NKR),R2D(NKR,ICEMAX),R3D(NKR), R4D(NKR), R5D(NKR), &
7898                                R1ND(NKR),R2ND(NKR,ICEMAX),R3ND(NKR), R4ND(NKR), R5ND(NKR)
7899
7900
7901            DATA DT0L, DT0I /1.E20,1.E20/
7902
7903            DOUBLE PRECISION :: DEL1_d, DEL2_d , RW_d, PW_d , RI_d , PI_d , D1N_d, D2N_d, &
7904                                 VR1_d(NKR), VR2_d(NKR,ICEMAX), VR3_d(NKR), VR4_d(NKR), VR5_d(NKR), &
7905                                 TTinput,QQinput,DEL1Ninput,DEL2Ninput
7906
7907         OPER2(AR1)=0.622/(0.622+0.378*AR1)/AR1
7908         OPER3(AR1,AR2)=AR1*AR2/(0.622+0.378*AR1)
7909
7910
7911
7912  TTinput = TT
7913  QQinput = QQ
7914  DEL1Ninput = DEL1N
7915  DEL2Ninput = DEL2N
7916
7917  B12_MY = 0.0
7918  B22_MY = 0.0
7919  B32_MY = 0.0
7920  B42_MY = 0.0
7921  B52_MY = 0.0
7922
7923  B21_MY = 0.0
7924  B31_MY = 0.0
7925  B41_MY = 0.0
7926  B51_MY = 0.0
7927
7928  ICM = ICEMAX
7929  R1D = R1
7930  R2D = R2
7931  R3D = R3
7932  R4D = R4
7933  R5D = R5
7934  R1ND = R1D
7935  R2ND = R2D
7936  R3ND = R3D
7937  R4ND = R4D
7938  R5ND = R5D
7939
7940  VR1_d = VR1
7941  VR2_d = VR2
7942  VR3_d = VR3
7943  VR4_d = VR4
7944  VR5_d = VR5
7945
7946  SFN11 = 0.0
7947  SFNI1 = 0.0
7948  SFN31 = 0.0
7949  SFN41 = 0.0
7950  SFN51 = 0.0
7951
7952  DT_WATER_COND=0.4
7953  DT_WATER_EVAP=0.4
7954  DT_ICE_COND=0.4
7955  DT_ICE_EVAP=0.4
7956  DT_MIX_COND=0.4
7957  DT_MIX_EVAP=0.4
7958  DT_MIX_BERGERON=0.4
7959  DT_MIX_ANTIBERGERON=0.4
7960
7961  I_MIXCOND=0
7962  I_MIXEVAP=0
7963  I_ABERGERON=0
7964  I_BERGERON=0
7965
7966  ITIME = 0
7967  TIMENEW = 0.0
7968  DT = DTCOND
7969  DTT = DTCOND
7970
7971  B6=0.
7972  B8L=1./ROR
7973  B8I=1./ROR
7974
7975  RORI=1.D0/ROR
7976   COL3=3.D0*COL
7977  TPN=TT
7978  QPN=QQ
7979
7980  16  ITIME = ITIME + 1
7981  IF((TPN-273.15).GE.-0.187) GO TO 17
7982  TIMEREV = DT - TIMENEW
7983  DEL1 = DEL1N
7984  DEL2 = DEL2N
7985  DEL1S = DEL1N
7986  DEL2S = DEL2N
7987
7988  DEL2D(1) = DEL2N
7989  DEL2D(2) = DEL2N
7990  DEL2D(3) = DEL2N
7991  TPS = TPN
7992  QPS = QPN
7993  DO KR = 1,NKR
7994         FI1(KR) = PSI1(KR)
7995         FI3(KR) = PSI3(KR)
7996         FI4(KR) = PSI4(KR)
7997         FI5(KR) = PSI5(KR)
7998         DO ICE = 1,ICEMAX
7999                 FI2(KR,ICE) = PSI2(KR,ICE)
8000         ENDDO
8001  ENDDO
8002
8003  IF(ISYM1 == 1)THEN
8004   FL1 = 0.0
8005         CALL JERRATE_KS &
8006                 (R1D,TPS,PP,VR1_d,RLEC,RO1BL,B11_MY,1,1,fl1,NKR,ICEMAX)
8007
8008         sfndummy(1) = SFN11
8009         CALL JERTIMESC_KS(FI1,R1D,SFNDUMMY,B11_MY,B8L,1,NKR,ICEMAX,COL)
8010         SFN11 = sfndummy(1)
8011  ENDIF
8012
8013  IF(sum(ISYM2) > 0) THEN
8014                 FL1 = 0.0
8015                 ! ... ice crystals
8016         CALL JERRATE_KS (R2D,TPS,PP,VR2_d,RIEC,RO2BL,B21_MY,3,2,fl1,NKR,ICEMAX)
8017         CALL JERTIMESC_KS (FI2,R2D,SFNI1,B21_MY,B8I,ICM,NKR,ICEMAX,COL)
8018  ENDIF
8019  IF(ISYM3 == 1) THEN
8020                 FL3 = 0.0
8021                 ! ... snow
8022                 CALL JERRATE_KS (R3D,TPS,PP,VR3_d,RSEC,RO3BL,B31_MY,1,3,fl3,NKR,ICEMAX)
8023                 sfndummy(1) = SFN31
8024                 CALL JERTIMESC_KS(FI3,R3D,SFNDUMMY,B31_MY,B8I,1,NKR,ICEMAX,COL)
8025         SFN31 = sfndummy(1)
8026  ENDIF
8027  IF(ISYM4 == 1) THEN
8028                 FL4 = 0.0
8029                 ! ... graupel
8030                 CALL JERRATE_KS(R4D,TPS,PP,VR4_d,RGEC,RO4BL,B41_MY,1,2,fl4,NKR,ICEMAX)
8031                 sfndummy(1) = SFN41
8032                 CALL JERTIMESC_KS(FI4,R4D,SFNDUMMY,B41_MY,B8I,1,NKR,ICEMAX,COL)
8033                 SFN41 = sfndummy(1)
8034  ENDIF
8035  IF(ISYM5 == 1) THEN
8036                 FL5 = 0.0
8037                 ! ... hail
8038                 CALL JERRATE_KS(R5D,TPS,PP,VR5_d,RHEC,RO5BL,B51_MY,1,2,fl5,NKR,ICEMAX)
8039                 sfndummy(1) = SFN51
8040                 CALL JERTIMESC_KS(FI5,R5D,SFNDUMMY,B51_MY,B8I,1,NKR,ICEMAX,COL)
8041                 SFN51 = sfndummy(1)
8042  ENDIF
8043
8044         SFNII1 = SFNI1(1) + SFNI1(2) + SFNI1(3)
8045         SFN21 = SFNII1 + SFN31 + SFN41 + SFN51
8046         SFN12 = 0.0
8047         SFNL = SFN11 + SFN12
8048         SFN22 = 0.0
8049         SFNI = SFN21 + SFN22
8050
8051         B5L=BB1_MY/TPS/TPS
8052         B5I=BB2_MY/TPS/TPS
8053         B7L=B5L*B6
8054         B7I=B5I*B6
8055         DOPL=1.+DEL1S
8056         DOPI=1.+DEL2S
8057         RW=(OPER2(QPS)+B5L*AL1)*DOPL*SFNL
8058         QW=B7L*DOPL
8059         PW=(OPER2(QPS)+B5I*AL1)*DOPI*SFNL
8060         RI=(OPER2(QPS)+B5L*AL2)*DOPL*SFNI
8061         PI=(OPER2(QPS)+B5I*AL2)*DOPI*SFNI
8062         QI=B7I*DOPI
8063
8064         IF(RW.NE.RW .or. PW.NE.PW)THEN
8065           print*, 'NaN In ONECOND3'
8066           call wrf_error_fatal("fatal error in ONECOND3 (RW or PW are NaN), model stop")
8067         ENDIF
8068
8069         ! DEL1 > 0, DEL2 < 0    (ANTIBERGERON MIXED PHASE - KCOND=50)
8070         ! DEL1 < 0 AND DEL2 < 0 (EVAPORATION MIXED_PHASE - KCOND=30)
8071         ! DEL1 > 0 AND DEL2 > 0 (CONDENSATION MIXED PHASE - KCOND=31)
8072         ! DEL1 < 0, DEL2 > 0    (BERGERON MIXED PHASE - KCOND=32)
8073
8074   KCOND=50
8075         IF(DEL1N .LT. 0.0 .AND. DEL2N .LT. 0.0) KCOND=30
8076         IF(DEL1N .GT. 0.0 .AND. DEL2N .GT. 0.0) KCOND=31
8077         IF(DEL1N .LT. 0.0 .AND. DEL2N .GT. 0.0) KCOND=32
8078
8079         IF(KCOND == 50) THEN
8080                 DTNEWL = DT
8081     DTNEWL = AMIN1(DTNEWL,TIMEREV)
8082     TIMENEW = TIMENEW + DTNEWL
8083     DTT = DTNEWL
8084
8085                 ! ... Incase the Anti-Bregeron regime we do not call diffusional-growth
8086                 PRINT*, "Anti-Bregeron Regime, No DIFFU"
8087                 PRINT*,  DEL1, DEL2, TT, QQ, Kin
8088                 GO TO 17
8089           ! IN CASE : KCOND = 50
8090   ENDIF
8091   IF(KCOND == 31) THEN
8092                 ! ... DEL1 > 0 AND DEL2 > 0 (CONDENSATION MIXED PHASE - KCOND=31)
8093                 ! ... CONDENSATION MIXED PHASE (BEGIN)
8094           DTNEWL = DT
8095     DTNEWL = AMIN1(DTNEWL,TIMEREV)
8096     TIMENEW = TIMENEW + DTNEWL
8097     DTT = DTNEWL
8098                 ! CONDENSATION MIXED PHASE (END)
8099         ! IN CASE : KCOND = 31
8100   ENDIF
8101    IF(KCOND == 30) THEN
8102                 ! ... DEL1 < 0 AND DEL2 < 0 (EVAPORATION MIXED_PHASE - KCOND=30)
8103                 ! ... EVAPORATION MIXED PHASE (BEGIN)
8104                 DTNEWL = DT
8105     DTNEWL = AMIN1(DTNEWL,TIMEREV)
8106     TIMENEW = TIMENEW + DTNEWL
8107     DTT = DTNEWL
8108         ! EVAPORATION MIXED PHASE (END)
8109         ! IN CASE : KCOND = 30
8110         ENDIF
8111         IF(KCOND == 32) THEN
8112                 ! ... IF(DEL1N < 0.0 .AND. DEL2N > 0.0) KCOND=32
8113                 ! ... BERGERON MIXED PHASE (BEGIN)
8114                 DTNEWL = DT
8115     DTNEWL = AMIN1(DTNEWL,TIMEREV)
8116     TIMENEW = TIMENEW + DTNEWL
8117     DTT = DTNEWL
8118         ! BERGERON MIXED PHASE (END)
8119         ! IN CASE : KCOND = 32
8120         ENDIF
8121
8122    IF (DTT < 0.0) call wrf_error_fatal("fatal error in ONECOND3:(DTT<0), model stop")
8123
8124         DEL1_d = DEL1
8125         DEL2_d = DEL2
8126         RW_d = RW
8127         PW_d = PW
8128         RI_d = RI
8129         PI_d = PI
8130         CALL JERSUPSAT_KS(DEL1_d,DEL2_d,DEL1N,DEL2N, &
8131                                                 RW_d,PW_d,RI_d,PI_d, &
8132                                                 DTT,D1N_d,D2N_d,0.0,0.0, &
8133                                                 ISYM1,ISYM2,ISYM3,ISYM4,ISYM5)
8134         DEL1 = DEL1_d
8135         DEL2 = DEL2_d
8136         RW = RW_d
8137         PW = PW_d
8138         RI = RI_d
8139         PI = PI_d
8140         D1N = D1N_d
8141         D2N = D2N_d
8142
8143         IF(ISYM1 == 1) THEN
8144                 ! DROPLETS
8145                 ! DROPLET DISTRIBUTION FUNCTION
8146                 IDROP = ISYM1
8147                 FL1 = 0.0
8148                 CALL JERDFUN_KS(R1D, R1ND, B11_MY, &
8149                                                 FI1, PSI1, fl1, D1N, &
8150                                                 ISYM1, 1, 1, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 1, Iin, Jin ,Kin, Itimestep)
8151                 ! IN CASE ISYM1.NE.0
8152         ENDIF
8153         IF(sum(ISYM2) > 0) THEN
8154                 ! CRYSTALS
8155                 IDROP = 0
8156                 FL1 = 0.0
8157                 IF(ISYM2(1)==1)THEN
8158                         CALL JERDFUN_KS(R2D(:,1), R2ND(:,1), B21_MY(:,1), &
8159                                                     FI2(:,1), PSI2(:,1), fl1, D2N, &
8160                                                         ISYM2(1), ICM, 1, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 21, Iin, Jin ,Kin, Itimestep)
8161                 ENDIF
8162                 IF(ISYM2(2)==1)THEN
8163                         CALL JERDFUN_KS(R2D(:,2), R2ND(:,2), B21_MY(:,2), &
8164                                                     FI2(:,2), PSI2(:,2), fl1, D2N, &
8165                                                         ISYM2(2), ICM, 2, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 22, Iin, Jin ,Kin, Itimestep)
8166                 ENDIF
8167                 IF(ISYM2(3)==1)THEN
8168                         CALL JERDFUN_KS(R2D(:,3), R2ND(:,3), B21_MY(:,3), &
8169                                                     FI2(:,3), PSI2(:,3), fl1, D2N, &
8170                                                         ISYM2(3), ICM, 3, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 23, Iin, Jin ,Kin, Itimestep)
8171                 ENDIF
8172         ENDIF
8173
8174         IF(ISYM3 == 1) THEN
8175                 ! SNOW
8176                 IDROP = 0
8177                 FL3 = 0.0
8178                 CALL JERDFUN_KS(R3D, R3ND, B31_MY, &
8179                                                 FI3, PSI3, fl3, D2N, &
8180                                                 ISYM3, 1, 3, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 3, Iin, Jin ,Kin, Itimestep)
8181         ! IN CASE ISYM3.NE.0
8182         ENDIF
8183
8184         IF(ISYM4 == 1) THEN
8185         ! GRAUPELS
8186                 IDROP = 0
8187                 FL4 = 0.0
8188                 CALL JERDFUN_KS(R4D, R4ND, B41_MY, &
8189                                                 FI4, PSI4, fl4, D2N, &
8190                                                 ISYM4, 1, 4, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 4, Iin, Jin ,Kin, Itimestep)
8191
8192         ! IN CASE ISYM4.NE.0
8193         ENDIF
8194
8195     IF(ISYM5 == 1) THEN
8196      ! HAIL
8197           IDROP = 0
8198           FL5 = 0.0
8199           CALL JERDFUN_KS(R5D, R5ND, B51_MY, &
8200                                         FI5, PSI5, fl5, D2N, &
8201                                         ISYM5, 1, 5, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 5, Iin, Jin ,Kin, Itimestep)
8202   ! IN CASE ISYM5.NE.0
8203   ENDIF
8204
8205  RMASSLBB=0.D0
8206  RMASSIBB=0.D0
8207  RMASSLAA=0.D0
8208  RMASSIAA=0.D0
8209
8210  DO K=1,NKR
8211   FI1_K=FI1(K)
8212   R1_K=R1(K)
8213   FI1R1=FI1_K*R1_K*R1_K
8214   RMASSLBB=RMASSLBB+FI1R1
8215   DO ICE =1,ICEMAX
8216         FI2_K=FI2(K,ICE)
8217         R2_K=R2(K,ICE)
8218         FI2R2=FI2_K*R2_K*R2_K
8219         RMASSIBB=RMASSIBB+FI2R2
8220   ENDDO
8221          FI3_K=FI3(K)
8222          FI4_K=FI4(K)
8223          FI5_K=FI5(K)
8224          R3_K=R3(K)
8225          R4_K=R4(K)
8226          R5_K=R5(K)
8227          FI3R3=FI3_K*R3_K*R3_K
8228          FI4R4=FI4_K*R4_K*R4_K
8229          FI5R5=FI5_K*R5_K*R5_K
8230          RMASSIBB=RMASSIBB+FI3R3
8231          RMASSIBB=RMASSIBB+FI4R4
8232          RMASSIBB=RMASSIBB+FI5R5
8233    ENDDO
8234    RMASSIBB=RMASSIBB*COL3*RORI
8235    IF(RMASSIBB.LT.0.0) RMASSIBB=0.0
8236    RMASSLBB=RMASSLBB*COL3*RORI
8237    IF(RMASSLBB.LT.0.0) RMASSLBB=0.0
8238    DO K=1,NKR
8239          FI1_K=PSI1(K)
8240          R1_K=R1(K)
8241          FI1R1=FI1_K*R1_K*R1_K
8242          RMASSLAA=RMASSLAA+FI1R1
8243          DO ICE =1,ICEMAX
8244                 FI2(K,ICE)=PSI2(K,ICE)
8245                 FI2_K=FI2(K,ICE)
8246                 R2_K=R2(K,ICE)
8247                 FI2R2=FI2_K*R2_K*R2_K
8248                 RMASSIAA=RMASSIAA+FI2R2
8249          ENDDO
8250          FI3_K=PSI3(K)
8251          FI4_K=PSI4(K)
8252          FI5_K=PSI5(K)
8253          R3_K=R3(K)
8254          R4_K=R4(K)
8255          R5_K=R5(K)
8256          FI3R3=FI3_K*R3_K*R3_K
8257          FI4R4=FI4_K*R4_K*R4_K
8258          FI5R5=FI5_K*R5_K*R5_K
8259          RMASSIAA=RMASSIAA+FI3R3
8260          RMASSIAA=RMASSIAA+FI4R4
8261          RMASSIAA=RMASSIAA+FI5R5
8262    ENDDO
8263         RMASSIAA=RMASSIAA*COL3*RORI
8264         IF(RMASSIAA.LE.0.0) RMASSIAA=0.0
8265         RMASSLAA=RMASSLAA*COL3*RORI
8266         IF(RMASSLAA.LT.0.0) RMASSLAA=0.0
8267
8268         DELMASSL1=RMASSLAA-RMASSLBB
8269         DELMASSI1=RMASSIAA-RMASSIBB
8270         DELTAQ1=DELMASSL1+DELMASSI1
8271         QPN=QPS-DELTAQ1
8272         DAL1=AL1
8273         DAL2=AL2
8274         TPN = TPS + DAL1*DELMASSL1+DAL2*DELMASSI1
8275
8276         IF(ABS(DAL1*DELMASSL1+DAL2*DELMASSI1) > 5.0 )THEN
8277                 print*,"ONECOND3-input-start"
8278                 print*,"TTinput",TTinput,"QQinput",QQinput,"PP",PP
8279                 print*,'DEL1Ninput',DEL1Ninput,'DEL2Ninput',DEL2Ninput
8280                 print*,"ROR",ROR,'VR1',VR1,'PSINGLE',PSINGLE
8281                 print*,'DIV1',DIV1,'DIV2',DIV2
8282                 print*,'R1',R1,'RLEC',RLEC,'RO1BL',RO1BL
8283                 print*,'const',AA1_MY,BB1_MY,AA2_MY,BB2_MY
8284                 print*,'const',C1_MEY,C2_MEY,COL
8285                 print*,'DTCOND',DTCOND,'ICEMAX',ICEMAX,'NKR',NKR
8286                 print*,'ISYM1',ISYM1,'ISYM2',ISYM2,'ISYM3',ISYM3,'ISYM4',ISYM4,'ISYM5',ISYM5
8287                 print*,Iin,Jin,Kin,W_in,DX_in
8288                 print*,"ONECOND3-input-end"
8289
8290                 print*,"ONECOND3-out (start)"
8291                 print*,"I=",Iin,"J=",Jin,"Kin",Kin,"W",w_in,"DX",dx_in
8292                 print*,"DEL1N,DEL2N,D1N,D2N,RW,PW,RI,PI,DT"
8293                 print*,DEL1N,DEL2N,D1N,D2N,RW,PW,RI,PI,DTT
8294                 print*,"TPS=",TPS,"TPN=",TPN,"QPS=",QPS,"delmassl1",delmassl1,"delmassi1",delmassi1
8295                 print*,"DAL2=",DAL2,"DAL1=",DAL1
8296                 print*,RMASSLAA,RMASSLBB
8297                 print*,RMASSIAA,RMASSIBB
8298                 print*,"FI1",FI1
8299                 print*,"FI3",FI3
8300                 print*,"FI4",FI4
8301                 print*,"FI5",FI5
8302                 print*,"PSI1",PSI1
8303                 print*,"R1D",R1D,"R1ND",R1ND
8304                 print*,"PSI3",PSI3
8305                 print*,"R3D",R3D,"R3ND",R3ND
8306                 print*,"PSI4",PSI4
8307                 print*,"R4D",R4D,"R4ND",R4ND
8308                 print*,"PSI5",PSI5
8309                 print*,"R5D",R5D,"R5ND",R5ND
8310                 print*,"ONECOND3-out (end)"
8311                 IF(ABS(DAL1*DELMASSL1+DAL2*DELMASSI1) > 5.0 )THEN
8312                         call wrf_error_fatal("fatal error in ONECOND3-out (ABS(DAL1*DELMASSL1+DAL2*DELMASSI1) > 5.0), model stop")
8313                 ENDIF
8314         ENDIF
8315
8316  ! SUPERSATURATION
8317         ARGEXP=-BB1_MY/TPN
8318         ES1N=AA1_MY*DEXP(ARGEXP)
8319         ARGEXP=-BB2_MY/TPN
8320         ES2N=AA2_MY*DEXP(ARGEXP)
8321         EW1N=OPER3(QPN,PP)
8322         IF(ES1N == 0.0)THEN
8323          DEL1N=0.5
8324          DIV1=1.5
8325          print*,'es1n onecond3 = 0'
8326          call wrf_error_fatal("fatal error in ONECOND3 (ES1N.EQ.0), model stop")
8327         ELSE
8328          DIV1=EW1N/ES1N
8329          DEL1N=EW1N/ES1N-1.
8330         END IF
8331         IF(ES2N == 0.0)THEN
8332          DEL2N=0.5
8333          DIV2=1.5
8334          print*,'es2n onecond3 = 0'
8335          call wrf_error_fatal("fatal error in ONECOND3 (ES2N.EQ.0), model stop")
8336         ELSE
8337          DEL2N=EW1N/ES2N-1.
8338          DIV2=EW1N/ES2N
8339         END IF
8340         ! END OF TIME SPLITTING
8341
8342         IF(TIMENEW < DT) GOTO 16
8343         17 CONTINUE
8344
8345         TT=TPN
8346         QQ=QPN
8347         DO KR=1,NKR
8348            FF1(KR)=PSI1(KR)
8349            DO ICE=1,ICEMAX
8350               FF2(KR,ICE)=PSI2(KR,ICE)
8351            ENDDO
8352            FF3(KR)=PSI3(KR)
8353            FF4(KR)=PSI4(KR)
8354            FF5(KR)=PSI5(KR)
8355         ENDDO
8356
8357    RETURN
8358    END SUBROUTINE ONECOND3
8359  ! +---------------------------------------------------------+
8360         SUBROUTINE COAL_BOTT_NEW(FF1R,FF2R,FF3R,                      &
8361                                 FF4R,FF5R,TT,QQ,PP,RHO,dt_coll,TCRIT,TTCOAL,&
8362                                 FLIQFR_S,FLIQFR_G,FLIQFR_H,FRIMFR_S,        &
8363                                 DEL1in, DEL2in,                             &
8364                                 Iin,Jin,Kin,itimestep,CollEff)
8365
8366     use module_mp_SBM_Collision,only:coll_xyy_lwf,coll_xyx_lwf,coll_xxx_lwf,    &
8367                                      coll_xyz_lwf, modkrn_KS, coll_breakup_KS,  &
8368                                      coll_xxy_lwf
8369
8370      implicit none
8371
8372      integer,intent(in) :: Iin,Jin,Kin,itimestep
8373      real(kind=r4size),intent(in) :: tcrit,ttcoal,dt_coll
8374      real(kind=r4size),intent(inout) :: ff1r(:),ff2r(:,:),ff3r(:),ff4r(:),  &
8375                                         ff5r(:),colleff
8376      real(kind=r8size),intent(inout) :: fliqfr_s(:),fliqfr_g(:),fliqfr_h(:), &
8377                                        frimfr_s(:),del1in,del2in,tt,qq
8378      real(kind=r8size),intent(in) :: pp
8379
8380            integer :: KR,ICE,icol_drop,icol_snow,icol_graupel,icol_hail, &
8381                       icol_column,icol_plate,icol_dendrite,icol_drop_brk
8382      real(kind=r8size) :: g1(nkr),g2(nkr,icemax),g3(nkr),g4(nkr),g5(nkr), &
8383                           gdumb(JMAX),gdumb_bf_breakup(JMAX),xl_dumb(JMAX), &
8384                           g_orig(nkr),g2_1(nkr),g2_2(nkr),g2_3(nkr)
8385      real(kind=r4size) :: cont_fin_drop,dconc,conc_icempl,deldrop,t_new, &
8386                          delt_new,cont_fin_ice,conc_old,conc_new,cont_init_ice, &
8387                                    cont_init_drop,ALWC,T_new_real,PP_r,rho,ES1N,ES2N,EW1N
8388      real(kind=r4size),parameter :: tt_no_coll=273.16
8389
8390      integer :: I,J,IT,NDIV
8391      real(kind=r8size) :: break_drop_bef,break_drop_aft,dtbreakup,break_drop_per, &
8392                           prdkrn,fl1(nkr),rf1(nkr),rf3(nkr),fl3(nkr), &
8393                           fl4(nkr),fl5(nkr),fl2_1(nkr),fl2_2(nkr),fl2_3(nkr), &
8394                           rf2(nkr),rf4(nkr),rf5(nkr),conc_drop_old, conc_drop_new, &
8395                           dconc_drop, dm_rime(nkr), conc_plate_icempl, &
8396                           col3, cont_coll_drop
8397      real(kind=r8size),parameter :: prdkrn1 = 1.0d0
8398      real(kind=r4size),parameter :: prdkrn1_r = 1.0
8399            integer,parameter :: icempl = 1
8400            real(kind=r8size),parameter :: t_ice_mpl = 270.15D0 ! for ice multiplication in temp > 268.15
8401            real(kind=r8size),PARAMETER :: g_lim = 1.0D-19*1.0D3,AA1_MY = 2.53E12,  &
8402                                     BB1_MY = 5.42E3, AA2_MY = 3.41E13 ,BB2_MY = 6.13E3
8403
8404     icol_drop_brk=0
8405     icol_drop=0
8406     icol_snow=0
8407     icol_graupel=0
8408     icol_hail=0
8409     icol_column=0
8410     icol_plate=0
8411     icol_dendrite=0
8412     t_new = tt
8413
8414     PP_r = PP
8415     call Kernals_KS(dt_coll,nkr,PP_r)
8416     !CALL MODKRN_KS(TT,QQ,PP,RHO,PRDKRN,TTCOAL,1,1,Iin,Jin,Kin)
8417     CALL MODKRN_KS(TT,QQ,PP,RHO,PRDKRN,TTCOAL,11,1,Iin,Jin,Kin)
8418
8419           CollEff = PRDKRN
8420
8421     DO KR=1,NKR
8422       G1(KR)=FF1R(KR)*3.*XL(KR)*XL(KR)*1.E3
8423       G2(KR,1)=FF2R(KR,1)*3*xi(KR,1)*XI(KR,1)*1.e3
8424       G2(KR,2)=FF2R(KR,2)*3.*xi(KR,2)*XI(KR,2)*1.e3
8425       G2(KR,3)=FF2R(KR,3)*3.*xi(KR,3)*XI(KR,3)*1.e3
8426       G3(KR)=FF3R(KR)*3.*xs(kr)*xs(kr)*1.e3
8427       G4(KR)=FF4R(KR)*3.*xg(kr)*xg(kr)*1.e3
8428       G5(KR)=FF5R(KR)*3.*xh(kr)*xh(kr)*1.e3
8429       g2_1(kr)=g2(KR,1)
8430       g2_2(KR)=g2(KR,2)
8431       g2_3(KR)=g2(KR,3)
8432       if(kr .gt. KRMIN_BREAKUP .and. g1(kr) > g_lim) icol_drop_brk = 1
8433       IF (IBREAKUP.NE.1) icol_drop_brk = 0
8434       if(g1(kr).gt.g_lim) icol_drop=1
8435       if(g2_1(kr).gt.g_lim) icol_column = 1
8436       if(g2_2(kr).gt.g_lim) icol_plate = 1
8437       if(g2_3(kr).gt.g_lim) icol_dendrite = 1
8438       if(g3(kr).gt.g_lim) icol_snow = 1
8439       if(g4(kr).gt.g_lim) icol_graupel = 1
8440       if(g5(kr).gt.g_lim) icol_hail = 1
8441     END DO
8442
8443           fl1 = 1.0
8444           fl3(:) = FLIQFR_S(:)
8445           fl4(:) = FLIQFR_G(:)
8446           fl5(:) = FLIQFR_H(:)
8447           rf1 = 1.0
8448           rf3(:) = FRIMFR_S(:)
8449           rf4(:) = 0.0
8450           rf5(:) = 0.0
8451
8452
8453  ! calculation of initial hydromteors content in g/cm**3 :
8454   cont_init_drop = 0.0
8455   cont_init_ice = 0.0
8456   cont_init_drop = sum(g1(1:nkr))
8457   cont_init_ice = sum(g3(1:nkr)) + sum(g4(1:nkr)) + sum(g5(1:nkr))
8458   do ice=1,icemax
8459       cont_init_ice = cont_init_ice + sum(g2(1:nkr,ice))
8460   enddo
8461   cont_init_drop=col*cont_init_drop*1.e-3
8462   cont_init_ice=col*cont_init_ice*1.e-3
8463 ! calculation of alwc in g/m**3
8464   alwc=cont_init_drop*1.e6
8465 ! calculation interactions :
8466 ! droplets - droplets and droplets - ice :
8467 ! water-water = water
8468
8469   if (icol_drop.eq.1)then
8470 ! ... Drop-Drop collisions
8471   fl1 = 1.0
8472   call coll_xxx_lwf (G1,fl1,CWLL,XL_MG,CHUCM,IMA,1.d0,NKR)
8473 ! ... Breakup
8474   if(icol_drop_brk == 1)then
8475     ndiv = 1
8476     10          continue
8477     do it = 1,ndiv
8478       dtbreakup = dt_coll/ndiv
8479       if (it == 1)then
8480         do kr=1,JMAX
8481           gdumb(kr)= g1(kr)*1.D-3
8482           gdumb_bf_breakup(kr) =  g1(kr)*1.D-3
8483           xl_dumb(kr)=xl_mg(KR)*1.D-3
8484         end do
8485         break_drop_bef=0.d0
8486         do kr=1,JMAX
8487           break_drop_bef = break_drop_bef+g1(kr)*1.D-3
8488         end do
8489       end if
8490
8491       call coll_breakup_KS(gdumb, xl_dumb, JMAX, dtbreakup, JBREAK, PKIJ, QKJ, NKR, NKR)
8492     end do
8493
8494     do KR=1,NKR
8495       FF1R(KR) = (1.0d3*GDUMB(KR))/(3.0*XL(KR)*XL(KR)*1.E3)
8496       if(FF1R(KR) < 0.0)then
8497         if(ndiv < 8)then
8498           ndiv = 2*ndiv
8499           go to 10
8500         else
8501           !print*,"noBreakUp",Iin,Jin,Kin,Itimestep,ndiv
8502           go to 11
8503           !call wrf_error_fatal("in coal_bott af-coll_breakup - FF1R/GDUMB < 0.0")
8504         endif
8505       endif
8506       if(FF1R(kr) .ne. FF1R(kr)) then
8507         print*,kr,GDUMB(kr),GDUMB_BF_BREAKUP(kr),XL(kr)
8508         print*,IT,NDIV, DTBREAKUP
8509         print*,GDUMB
8510         print*,GDUMB_BF_BREAKUP
8511         call wrf_error_fatal("in coal_bott af-coll_breakup - FF1R NaN, model stop")
8512       endif
8513     enddo
8514
8515     break_drop_aft=0.0d0
8516     do kr=1,JMAX
8517       break_drop_aft=break_drop_aft+gdumb(kr)
8518     end do
8519     break_drop_per=break_drop_aft/break_drop_bef
8520     if (break_drop_per > 1.001)then
8521       ndiv=ndiv*2
8522       GO TO 10
8523     else
8524       do kr=1,JMAX
8525         g1(kr) = gdumb(kr)*1.D3
8526       end do
8527     end if
8528   ! if icol_drop_brk.eq.1
8529   end if
8530 ! if icol_drop.eq.1
8531 end if
8532
8533 11   continue
8534  ! +--------------------------------------------------------+
8535  ! Negative temperature collisions block (start)
8536  ! +---------------------------------------------------------+
8537         if(tt <= 273.15)then
8538                 if(icol_drop == 1)then
8539                         ! ... interactions between drops and snow
8540                         !           drop - snow = graupel/hail
8541                         !           snow - drop = snow
8542       !          or
8543                         !     snow - drop = graupel/hail
8544                 if (icol_snow == 1)then
8545                                 rf1 = 1.0
8546                                 rf5 = 0.0
8547                                 rf4 = 0.0
8548                                 if(hail_opt == 1)then
8549                                         call coll_xyz_lwf(g1,g3,g5,rf1,rf3,rf5,cwls,xl_mg,xs_mg, &
8550                                                  chucm,ima,prdkrn1,nkr,0)
8551                                 else
8552                                         call coll_xyz_lwf(g1,g3,g4,rf1,rf3,rf4,cwls,xl_mg,xs_mg, &
8553                                                           chucm,ima,prdkrn1,nkr,0)
8554                                 endif
8555                     rf1 = 1.0
8556         rf5 = 0.0
8557         rf4 = 0.0
8558                     if(alwc < alcr) then
8559                         call coll_xyx_lwf(g3,g1,rf3,rf1,cwsl,xs_mg,xl_mg, &
8560                                               chucm,ima,prdkrn1,nkr,1,dm_rime)
8561                     else
8562                                         if(hail_opt == 1)then
8563                                                 call coll_xyz_lwf(g3,g1,g5,rf3,rf1,rf5,cwsl,xs_mg,xl_mg, &
8564                                                                                    chucm,ima,prdkrn1,nkr,1)
8565                                         else
8566                                                 call coll_xyz_lwf(g3,g1,g4,rf3,rf1,rf4,cwsl,xs_mg,xl_mg, &
8567                                                                                          chucm,ima,prdkrn1,nkr,1)
8568                                         endif
8569                                 endif
8570                         ! in case : icolxz_snow.ne.0
8571                         end if
8572
8573                 if (icol_graupel == 1) then
8574                         ! ... interactions between drops and graupel
8575                         !     drops - graupel = graupel
8576                         !     graupel - drops = graupel
8577                         !     drops - graupel = hail (no transition in FSBM)
8578                         !     graupel - drop = hail (no transition in FSBM)
8579                 if(alwc < alcr_g) then
8580                     rf1 = 1.0
8581                     rf4 = 0.0
8582                                 call coll_xyy_lwf(g1,g4,rf1,rf4,cwlg,xl_mg,xg_mg, &
8583                                                   chucm,ima,prdkrn1,nkr,0)
8584                                         ! ... for ice multiplication
8585                                         conc_old = 0.0
8586                         conc_new = 0.0
8587                                         do kr = kr_icempl,nkr
8588                                                 conc_old = conc_old+col*g1(kr)/xl_mg(kr)
8589                         end do
8590                         rf1 = 1.0
8591                         rf4 = 0.0
8592                                         call coll_xyx_lwf(g4,g1,rf4,rf1,cwgl,xg_mg,xl_mg, &
8593                                                                                    chucm,ima,prdkrn1,nkr,1,dm_rime)
8594                         else
8595           rf1 = 1.0
8596           rf5 = 0.0
8597           rf4 = 0.0
8598                                         call coll_xyz_lwf(g1,g4,g5,rf1,rf4,rf5,cwlg,xl_mg,xg_mg, &
8599                                                           chucm,ima,prdkrn1,nkr,1)
8600                                         ! ... for ice multiplication
8601                                         conc_old = 0.0
8602                           conc_new = 0.0
8603                                         do kr = kr_icempl,nkr
8604                                     conc_old = conc_old+col*g1(kr)/xl_mg(kr)
8605                                 enddo
8606           rf1 = 1.0
8607           rf5 = 0.0
8608           rf4 = 0.0
8609                                         call coll_xyz_lwf(g4,g1,g5,rf4,rf1,rf5,cwgl,xg_mg,xl_mg, &
8610                                             chucm,ima,prdkrn1,nkr,1)
8611                 end if
8612                         ! in case icol_graup == 1
8613                 endif
8614
8615                 if(icol_hail == 1) then
8616                         ! interactions between drops and hail
8617                         ! drops - hail = hail
8618                         ! hail - water = hail
8619          rf1 = 1.0
8620          rf5 = 0.0
8621              call coll_xyy_lwf(g1,g5,rf1,rf5,cwlh,xl_mg,xh_mg, &
8622                                   chucm,ima,prdkrn1,nkr,0)
8623                          ! ... for ice multiplication
8624                          conc_old = 0.0
8625          conc_new = 0.0
8626                          do kr = kr_icempl,nkr
8627                           conc_old = conc_old+col*g1(kr)/xl_mg(kr)
8628              enddo
8629                         rf1 = 1.0
8630                         rf5 = 0.0
8631                         call coll_xyx_lwf(g5,g1,rf5,rf1,cwhl,xh_mg,xl_mg, &
8632                                            chucm,ima,prdkrn1,nkr,1,dm_rime)
8633                 ! in case icol_hail == 1
8634                 endif
8635
8636                         if((icol_graupel == 1 .or. icol_hail == 1) .and. icempl == 1) then
8637                                 if(tt .ge. 265.15 .and. tt .le. tcrit) then
8638                                 ! ... ice-multiplication (H-M) :
8639                                         do kr = kr_icempl,nkr
8640                                            conc_new=conc_new+col*g1(kr)/xl_mg(kr)
8641                                         enddo
8642                                         dconc = conc_old-conc_new
8643                                         if(tt .le. 268.15) then
8644                                                 conc_icempl=dconc*4.e-3*(265.15-tt)/(265.15-268.15)
8645                                         endif
8646                                         if(tt .gt. 268.15) then
8647                                                 conc_icempl=dconc*4.e-3*(tcrit-tt)/(tcrit-268.15)
8648                                         endif
8649                                         !g2_2(1)=g2_2(1)+conc_icempl*xi2_mg(1)/col
8650                                          g3(1)=g3(1)+conc_icempl*xs_mg(1)/col ! [KSS] >> FAST-sbm has small snow as IC
8651                                 ! in case t.ge.265.15 :
8652                                 endif
8653                         ! in case icempl=1
8654                         endif
8655                 ! if icol_drop.eq.1
8656                 endif
8657
8658                 if(icol_snow == 1) then
8659                 ! ... interactions between snowflakes
8660                         call coll_xxx_lwf(g3,rf3,cwss,xs_mg,chucm,ima,prdkrn,nkr)
8661                 ! in case icolxz_snow.ne.0
8662                 endif
8663
8664           ! in case : t > TTCOAL
8665         endif ! if tt <= 273.15
8666  ! Negative temp. collision block (end)
8667  ! +-----------------------------------------------+
8668
8669     cont_fin_drop=0.
8670     cont_fin_ice=0.
8671     do kr=1,nkr
8672       g2(kr,1)=g2_1(kr)
8673       g2(kr,2)=g2_2(kr)
8674       g2(kr,3)=g2_3(kr)
8675       cont_fin_drop=cont_fin_drop+g1(kr)
8676       cont_fin_ice=cont_fin_ice+g3(kr)+g4(kr)+g5(kr)
8677       do ice=1,icemax
8678          cont_fin_ice=cont_fin_ice+g2(kr,ice)
8679       enddo
8680     enddo
8681     cont_fin_drop=col*cont_fin_drop*1.e-3
8682     cont_fin_ice=col*cont_fin_ice*1.e-3
8683     deldrop=cont_init_drop-cont_fin_drop ! [g/cm**3]
8684  ! riming temperature correction (rho in g/cm**3) :
8685      if(t_new <= 273.15) then
8686        if(deldrop > 0.0) then
8687           t_new = t_new + 320.*deldrop/rho
8688           ES1N = POLYSVP(t_new,0)
8689           ES2N = POLYSVP(t_new,1)
8690           EW1N = QQ*PP/(0.622+0.378*QQ)
8691           DEL1in = EW1N/ES1N - 1.0
8692           DEL2in = EW1N/ES2N - 1.0
8693        else
8694              ! if deldrop < 0
8695          if(abs(deldrop).gt.cont_init_drop*0.05) then
8696            call wrf_error_fatal("fatal error in module_mp_fast_sbm (abs(deldrop).gt.cont_init_drop), model stop")
8697          endif
8698        endif
8699       endif
8700
8701  61   continue
8702  ! recalculation of density function f1,f3,f4,f5 in  units [1/(g*cm**3)] :
8703      DO KR=1,NKR
8704         FF1R(KR)=G1(KR)/(3.*XL(KR)*XL(KR)*1.E3)
8705         if((FF1R(kr) .ne. FF1R(kr)) .or. FF1R(kr) < 0.0)then
8706                        print*,"G1",G1
8707                              call wrf_error_fatal("stop at end coal_bott - FF1R NaN or FF1R < 0.0, model stop")
8708               endif
8709         FF3R(KR)=G3(KR)/(3.*xs(kr)*xs(kr)*1.e3)
8710           if((FF3R(kr) .ne. FF3R(kr)) .or. FF3R(kr) < 0.0)then
8711            call wrf_error_fatal("stop at end coal_bott - FF3R NaN or FF3R < 0.0, model stop")
8712           endif
8713                    if(hail_opt == 0)then
8714                            FF4R(KR)=G4(KR)/(3.*xg(kr)*xg(kr)*1.e3)
8715          if((FF4R(kr) .ne. FF4R(kr)) .or. FF4R(kr) < 0.0) then
8716           call wrf_error_fatal("stop at end coal_bott - FF4R NaN or FF4R < 0.0, model stop")
8717          end if
8718       else
8719                            FF5R(KR)=G5(KR)/(3.*xh(kr)*xh(kr)*1.e3)
8720                      if((FF5R(kr) .ne. FF5R(kr)) .or. FF5R(kr) < 0.0) then
8721            call wrf_error_fatal("stop at end coal_bott - FF5R NaN or FF5R < 0.0, model stop")
8722          endif
8723                  endif
8724                 END DO
8725  15   CONTINUE
8726
8727         FLIQFR_S(:) = fl3(:)
8728         FLIQFR_G(:) = fl4(:)
8729         FLIQFR_H(:) = fl5(:)
8730         FRIMFR_S(:) = rf3(:)
8731
8732         if (abs(tt-t_new).gt.5.0) then
8733                 call wrf_error_fatal("fatal error in module_mp_FAST_sbm Del_T 5 K, model stop")
8734         endif
8735
8736   tt = t_new
8737
8738         RETURN
8739         END SUBROUTINE COAL_BOTT_NEW
8740  ! ..................................................................................................
8741      SUBROUTINE BREAKINIT_KS(PKIJ,QKJ,ECOALMASSM,BRKWEIGHT,XL_r,DROPRADII,BR_MAX,JBREAK,JMAX,NKR,VR1)
8742
8743      USE module_domain
8744      USE module_dm
8745
8746      IMPLICIT NONE
8747
8748  ! ... Interface
8749      integer,intent(in) :: br_max, JBREAK, NKR, JMAX
8750      real(kind=r8size),intent(inout) :: ECOALMASSM(:,:),BRKWEIGHT(:)
8751      real,intent(in) :: XL_r(:), DROPRADII(:), VR1(:)
8752      real(kind=r4size),intent(inout) :: PKIJ(:,:,:),QKJ(:,:)
8753  ! ... Interface
8754
8755      !REAL :: XL_r(size(NKR))
8756      INTEGER :: hujisbm_unit1
8757      LOGICAL, PARAMETER :: PRINT_diag=.FALSE.
8758      LOGICAL :: opened
8759      LOGICAL , EXTERNAL :: wrf_dm_on_monitor
8760      CHARACTER*80 errmess
8761
8762  !.....INPUT VARIABLES
8763  !
8764  !     GT    : MASS DISTRIBUTION FUNCTION
8765  !     XT_MG : MASS OF BIN IN MG
8766  !     JMAX  : NUMBER OF BINS
8767
8768  !.....LOCAL VARIABLES
8769
8770      DOUBLE PRECISION :: XL_d(NKR), DROPRADII_d(NKR), VR1_d(NKR)
8771      INTEGER :: IE,JE,KE
8772      INTEGER,PARAMETER :: AP = 1
8773      INTEGER :: I,J,K,JDIFF
8774      REAL :: RPKIJ(JBREAK,JBREAK,JBREAK),RQKJ(JBREAK,JBREAK)
8775      REAL :: PI,D0,HLP
8776      DOUBLE PRECISION :: M(0:JBREAK),ALM
8777      REAL :: DBREAK(JBREAK),GAIN,LOSS
8778
8779  !.....DECLARATIONS FOR INIT
8780      INTEGER :: IP,KP,JP,KQ,JQ
8781      REAL :: XTJ
8782
8783      CHARACTER*256 FILENAME_P,FILENAME_Q, file_p, file_q
8784
8785      xl_d = xl_r
8786
8787      IE = JBREAK
8788      JE = JBREAK
8789      KE = JBREAK
8790
8791      if(nkr == 43) file_p = 'SBM_input_43/'//'coeff_p43.dat'
8792      if(nkr == 43) file_q = 'SBM_input_43/'//'coeff_q43.dat'
8793      if(nkr == 33) file_p = 'SBM_input_33/'//'coeff_p_new_33.dat' ! new Version 33 (taken from 43bins)
8794      if(nkr == 33) file_q = 'SBM_input_33/'//'coeff_q_new_33.dat' ! new Version 33   (taken from 43 bins)
8795
8796      hujisbm_unit1 = -1
8797      IF ( wrf_dm_on_monitor() ) THEN
8798          DO i = 20,99
8799              INQUIRE ( i , OPENED = opened )
8800              IF ( .NOT. opened ) THEN
8801                  hujisbm_unit1 = i
8802                  GOTO 2061
8803              ENDIF
8804          ENDDO
8805          2061     CONTINUE
8806      ENDIF
8807
8808      CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
8809
8810      IF ( hujisbm_unit1 < 0 ) THEN
8811        CALL wrf_error_fatal ( 'Can not find unused fortran unit to read in BREAKINIT_KS lookup table, model stop' )
8812      ENDIF
8813
8814      IF ( wrf_dm_on_monitor() ) THEN
8815        OPEN(UNIT=hujisbm_unit1,FILE=trim(file_p),         &
8816        !OPEN(UNIT=hujisbm_unit1,FILE="coeff_p.asc",       &
8817             FORM="FORMATTED",STATUS="OLD",ERR=2070)
8818
8819          DO K=1,KE
8820              DO I=1,IE
8821                  DO J=1,I
8822                  READ(hujisbm_unit1,'(3I6,1E16.8)') KP,IP,JP,PKIJ(KP,IP,JP) ! PKIJ=[g^3*cm^3/s]
8823                  ENDDO
8824              ENDDO
8825          ENDDO
8826          CLOSE(hujisbm_unit1)
8827      END IF
8828
8829      hujisbm_unit1 = -1
8830      IF ( wrf_dm_on_monitor() ) THEN
8831        DO i = 20,99
8832          INQUIRE ( i , OPENED = opened )
8833          IF ( .NOT. opened ) THEN
8834            hujisbm_unit1 = i
8835            GOTO 2062
8836          ENDIF
8837        ENDDO
8838        2062     CONTINUE
8839      ENDIF
8840
8841      CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
8842
8843      IF ( hujisbm_unit1 < 0 ) THEN
8844        CALL wrf_error_fatal ( 'Can not find unused fortran unit to read in BREAKINIT_KS lookup table, model stop' )
8845      ENDIF
8846
8847      IF ( wrf_dm_on_monitor() ) THEN
8848       OPEN(UNIT=hujisbm_unit1,FILE=trim(file_q),    &
8849            FORM="FORMATTED",STATUS="OLD",ERR=2070)
8850           DO K=1,KE
8851              DO J=1,JE
8852                 READ(hujisbm_unit1,'(2I6,1E16.8)') KQ,JQ,QKJ(KQ,JQ)
8853              ENDDO
8854           ENDDO
8855       CLOSE(hujisbm_unit1)
8856      END IF
8857
8858      DROPRADII_d = DROPRADII
8859      vr1_d = vr1
8860      DO J=1,NKR
8861          DO I=1,NKR
8862              ECOALMASSM(I,J)=ECOALMASS(xl_d(I), xl_d(J), DROPRADII_d, vr1_d, NKR)
8863           ENDDO
8864      ENDDO
8865  ! Correction of coalescence efficiencies for drop collision kernels
8866
8867      DO J=25,31
8868          ECOALMASSM(NKR,J)=0.1D-29
8869      ENDDO
8870
8871        RETURN
8872  2070  continue
8873        WRITE( errmess , '(A,I4)' )                                          &
8874         'module_FAST_SBM: error opening hujisbm_DATA on unit, model stop'  &
8875         , hujisbm_unit1
8876        CALL wrf_error_fatal(errmess)
8877        END SUBROUTINE BREAKINIT_KS
8878
8879  !coalescence efficiency as function of masses
8880  !----------------------------------------------------------------------------+
8881      double precision FUNCTION ecoalmass(x1, x2, DROPRADII, VR1_BREAKUP, NKR)
8882
8883      implicit none
8884      integer,intent(in) :: NKR
8885      real(kind=r8size),intent(in) :: DROPRADII(NKR), VR1_BREAKUP(NKR), x1, x2
8886
8887      real(kind=r8size),PARAMETER :: zero=0.0d0,one=1.0d0,eps=1.0d-10
8888      real(kind=r8size) :: rho, PI, akPI, Deta, Dksi
8889
8890      rho=1.0d0             ! [rho]=g/cm^3
8891
8892      PI=3.1415927d0
8893      akPI=6.0d0/PI
8894
8895      Deta = (akPI*x1/rho)**(1.0d0/3.0d0)
8896      Dksi = (akPI*x2/rho)**(1.0d0/3.0d0)
8897
8898      ecoalmass = ecoaldiam(Deta, Dksi, DROPRADII, VR1_BREAKUP, NKR)
8899
8900      RETURN
8901      END FUNCTION ecoalmass
8902  !coalescence efficiency as function of diameters
8903  !---------------------------------------------------------------------------+
8904      double precision FUNCTION ecoaldiam(Deta,Dksi,DROPRADII,VR1_BREAKUP,NKR)
8905
8906      implicit none
8907      integer,intent(in) :: NKR
8908      real(kind=r8size),intent(in) :: DROPRADII(nkr), VR1_BREAKUP(nkr),Deta,Dksi
8909
8910      real(kind=r8size) :: Dgr, Dkl, Rgr, RKl, q, qmin, qmax, e, x, e1, e2, sin1, cos1
8911      real(kind=r8size),PARAMETER :: zero=0.0d0,one=1.0d0,eps=1.0d-30,PI=3.1415927d0
8912
8913      Dgr=dmax1(Deta,Dksi)
8914      Dkl=dmin1(Deta,Dksi)
8915
8916      Rgr=0.5d0*Dgr
8917      Rkl=0.5d0*Dkl
8918
8919      q=0.5d0*(Rkl+Rgr)
8920
8921      qmin=250.0d-4
8922      qmax=500.0d-4
8923
8924      if(Dkl<100.0d-4) then
8925
8926          e=1.0d0
8927
8928           elseif (q<qmin) then
8929
8930           e = ecoalOchs(Dgr,Dkl,DROPRADII, VR1_BREAKUP, NKR)
8931
8932      elseif(q>=qmin.and.q<qmax) then
8933
8934          x=(q-qmin)/(qmax-qmin)
8935
8936          sin1=dsin(PI/2.0d0*x)
8937          cos1=dcos(PI/2.0d0*x)
8938
8939          e1=ecoalOchs(Dgr, Dkl, DROPRADII, VR1_BREAKUP, NKR)
8940          e2=ecoalLowList(Dgr, Dkl, DROPRADII, VR1_BREAKUP, NKR)
8941
8942          e=cos1**2*e1+sin1**2*e2
8943
8944      elseif(q>=qmax) then
8945
8946          e=ecoalLowList(Dgr, Dkl, DROPRADII, VR1_BREAKUP, NKR)
8947
8948      else
8949
8950          e=0.999d0
8951
8952      endif
8953
8954      ecoaldiam=dmax1(dmin1(one,e),eps)
8955
8956  RETURN
8957  END FUNCTION ecoaldiam
8958  !coalescence efficiency (Low & List)
8959  !----------------------------------------------------------------------------+
8960      double precision FUNCTION ecoalLowList(Dgr,Dkl,DROPRADII,VR1_BREAKUP,NKR)
8961
8962      implicit none
8963
8964      integer,intent(in) :: NKR
8965      real(kind=r8size),intent(in) :: DROPRADII(NKR), VR1_BREAKUP(NKR)
8966      real(kind=r8size),intent(inout) :: Dgr, Dkl
8967
8968      real(kind=r8size) :: sigma, aka, akb, dSTSc, ST, Sc, ET, CKE, qq0, qq1, qq2, Ecl, W1, W2, DC
8969      real(kind=r8size),PARAMETER :: epsi=1.d-20
8970
8971  ! 1 J = 10^7 g cm^2/s^2
8972
8973      sigma=72.8d0    ! Surface Tension,[sigma]=g/s^2 (7.28E-2 N/m)
8974      aka=0.778d0      ! Empirical Constant
8975      akb=2.61d-4      ! Empirical Constant,[b]=2.61E6 m^2/J^2
8976
8977      CALL collenergy(Dgr,Dkl,CKE,ST,Sc,W1,W2,Dc,DROPRADII,VR1_BREAKUP,NKR)
8978
8979      dSTSc=ST-Sc         ! Diff. of Surf. Energies   [dSTSc] = g*cm^2/s^2
8980      ET=CKE+dSTSc        ! Coal. Energy,             [ET]    =     "
8981
8982      IF(ET<50.0d0) THEN    ! ET < 5 uJ (= 50 g*cm^2/s^2)
8983
8984          qq0=1.0d0+(Dkl/Dgr)
8985          qq1=aka/qq0**2
8986          qq2=akb*sigma*(ET**2)/(Sc+epsi)
8987          Ecl=qq1*dexp(-qq2)
8988
8989      !if(i_breakup==24.and.j_breakup==25) then
8990      !print*, 'IF(ET<50.0d0) THEN'
8991      !print*, 'Ecl=qq1*dexp(-qq2)'
8992      !print*, 'qq1,qq2,Ecl'
8993      !print*,  qq1,qq2,Ecl
8994      !endif
8995
8996      ELSE
8997
8998          Ecl=0.0d0
8999
9000      ENDIF
9001
9002      ecoalLowList=Ecl
9003
9004      RETURN
9005      END FUNCTION ecoalLowList
9006
9007  !coalescence efficiency (Beard and Ochs)
9008  !---------------------------------------------------------------------------+
9009      double precision FUNCTION ecoalOchs(D_l,D_s,DROPRADII, VR1_BREAKUP,NKR)
9010
9011      implicit none
9012
9013      integer,intent(in) :: NKR
9014      real(kind=r8size),intent(in) :: DROPRADII(NKR), VR1_BREAKUP(NKR), D_l, D_s
9015
9016      real(kind=r8size) :: PI, sigma, R_s, R_l, p, vTl, vTs, dv, Weber_number, pa1, pa2, pa3, g, x, e
9017      real(kind=r8size),PARAMETER :: epsf=1.d-30 , FPMIN=1.d-30
9018
9019      PI=3.1415927d0
9020      sigma=72.8d0       ! Surface Tension [sigma] = g/s^2 (7.28E-2 N/m)
9021                     ! Alles in CGS (1 J = 10^7 g cm^2/s^2)
9022      R_s=0.5d0*D_s
9023      R_l=0.5d0*D_l
9024      p=R_s/R_l
9025
9026      vTl=vTBeard(D_l,DROPRADII, VR1_BREAKUP,NKR)
9027
9028      vTs=vTBeard(D_s,DROPRADII, VR1_BREAKUP,NKR)
9029
9030      dv=dabs(vTl-vTs)
9031
9032      if(dv<FPMIN) dv=FPMIN
9033
9034      Weber_number=R_s*dv**2/sigma
9035
9036      pa1=1.0d0+p
9037      pa2=1.0d0+p**2
9038      pa3=1.0d0+p**3
9039
9040      g=2**(3.0d0/2.0d0)/(6.0d0*PI)*p**4*pa1/(pa2*pa3)
9041      x=Weber_number**(0.5d0)*g
9042
9043      e=0.767d0-10.14d0*x
9044
9045      ecoalOchs=e
9046
9047      RETURN
9048      END FUNCTION ecoalOchs
9049  !ecoalOchs
9050  !Calculating the Collision Energy
9051  !------------------------------------------------------------------------------+
9052      SUBROUTINE COLLENERGY(Dgr,Dkl,CKE,ST,Sc,W1,W2,Dc,DROPRADII,VR1_BREAKUP,NKR)
9053
9054
9055      implicit none
9056      integer,intent(in) :: NKR
9057      real(kind=r8size),intent(in) :: DROPRADII(NKR), VR1_BREAKUP(NKR)
9058      real(kind=r8size),intent(inout) :: Dgr, Dkl, CKE, ST, Sc, W1, W2, Dc
9059
9060      real(kind=r8size) :: PI, rho, sigma, ak10, Dgka2, Dgka3, v1, v2, dv, Dgkb3
9061      real(kind=r8size),PARAMETER :: epsf = 1.d-30, FPMIN = 1.d-30
9062
9063      !EXTERNAL vTBeard
9064
9065      PI=3.1415927d0
9066      rho=1.0d0            ! Water Density,[rho]=g/cm^3
9067      sigma=72.8d0         ! Surf. Tension,(H2O,20C)=7.28d-2 N/m
9068                       ! [sigma]=g/s^2
9069      ak10=rho*PI/12.0d0
9070
9071      Dgr=dmax1(Dgr,epsf)
9072      Dkl=dmax1(Dkl,epsf)
9073
9074      Dgka2=(Dgr**2)+(Dkl**2)
9075
9076      Dgka3=(Dgr**3)+(Dkl**3)
9077
9078      if(Dgr/=Dkl) then
9079
9080          v1=vTBeard(Dgr,DROPRADII, VR1_BREAKUP,NKR)
9081          v2=vTBeard(Dkl,DROPRADII, VR1_BREAKUP,NKR)
9082          dv=(v1-v2)
9083          if(dv<FPMIN) dv=FPMIN
9084          dv=dv**2
9085          if(dv<FPMIN) dv=FPMIN
9086          Dgkb3=(Dgr**3)*(Dkl**3)
9087          CKE=ak10*dv*Dgkb3/Dgka3            ! Collision Energy [CKE]=g*cm^2/s^2
9088
9089  !if(i_breakup==24.and.j_breakup==25) then
9090  !print*, 'Dgr,Dkl'
9091  !print*,  Dgr,Dkl
9092  !print*, 'Dgkb3,Dgka2,Dgka3,ak10'
9093  !print*,  Dgkb3,Dgka2,Dgka3,ak10
9094  !print*, 'v1,v2,dv,CKE'
9095  !print*,  v1,v2,dv,CKE
9096  !endif
9097
9098      else
9099
9100          CKE = 0.0d0
9101
9102      endif
9103
9104      ST=PI*sigma*Dgka2                 ! Surf.Energy (Parent Drop)
9105      Sc=PI*sigma*Dgka3**(2.0d0/3.0d0)  ! Surf.Energy (coal.System)
9106
9107      W1=CKE/(Sc+epsf)                  ! Weber Number 1
9108      W2=CKE/(ST+epsf)                  ! Weber Number 2
9109
9110      Dc=Dgka3**(1.0d0/3.0d0)           ! Diam. of coal. System
9111
9112  !if(i_breakup==24.and.j_breakup==25) then
9113  !print*, 'ST,Sc,W1,W2,dc'
9114  !print*,  ST,Sc,W1,W2,dc
9115  !endif
9116
9117      RETURN
9118      END SUBROUTINE COLLENERGY
9119  !COLLENERGY
9120  !Calculating Terminal Velocity (Beard-Formula)
9121  !------------------------------------------------------------------------+
9122  ! new change 23.07.07                                         (start)
9123      double precision FUNCTION vTBeard(diam,DROPRADII, VR1_BREAKUP, NKR)
9124
9125      implicit none
9126
9127      integer,intent(in) :: NKR
9128      real(kind=r8size),intent(in) :: DROPRADII(NKR), VR1_BREAKUP(NKR), diam
9129
9130      integer :: kr
9131      real(kind=r8size) :: aa
9132
9133      aa   = diam/2.0d0           ! Radius in cm
9134
9135      IF(aa <= DROPRADII(1)) vTBeard=VR1_BREAKUP(1)
9136      IF(aa > DROPRADII(NKR)) vTBeard=VR1_BREAKUP(NKR)
9137
9138      DO KR=1,NKR-1
9139          IF(aa>DROPRADII(KR).and.aa<=DROPRADII(KR+1)) then
9140              vTBeard=VR1_BREAKUP(KR+1)
9141          ENDIF
9142      ENDDO
9143
9144      RETURN
9145      END FUNCTION vTBeard
9146      !vTBeard
9147  ! new change 23.07.07                                           (end)
9148  !........................................................................
9149        END MODULE module_mp_fast_sbm
9150 #endif