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